aboutsummaryrefslogtreecommitdiff
path: root/contrib/perl5
diff options
context:
space:
mode:
authorMark Murray <markm@FreeBSD.org>1998-09-09 07:00:04 +0000
committerMark Murray <markm@FreeBSD.org>1998-09-09 07:00:04 +0000
commitff6b7ba98e8d4aab04cbe2bfdffdfc9171c1812b (patch)
tree58b20e81687d6d5931f120b50802ed21225bf440 /contrib/perl5
downloadsrc-ff6b7ba98e8d4aab04cbe2bfdffdfc9171c1812b.tar.gz
src-ff6b7ba98e8d4aab04cbe2bfdffdfc9171c1812b.zip
Initial import of Perl5. The king is dead; long live the king!vendor/perl5/5.005.02
Notes
Notes: svn path=/vendor/perl5/dist/; revision=38980 svn path=/vendor/perl5/5.005.02/; revision=38982; tag=vendor/perl5/5.005.02
Diffstat (limited to 'contrib/perl5')
-rw-r--r--contrib/perl5/Artistic131
-rw-r--r--contrib/perl5/Changes15896
-rw-r--r--contrib/perl5/Changes5.000185
-rw-r--r--contrib/perl5/Changes5.0011299
-rw-r--r--contrib/perl5/Changes5.0024003
-rw-r--r--contrib/perl5/Changes5.003100
-rw-r--r--contrib/perl5/Changes5.00416073
-rwxr-xr-xcontrib/perl5/Configure12126
-rw-r--r--contrib/perl5/Copying248
-rw-r--r--contrib/perl5/EXTERN.h53
-rw-r--r--contrib/perl5/INSTALL1599
-rw-r--r--contrib/perl5/INTERN.h46
-rw-r--r--contrib/perl5/MANIFEST1083
-rwxr-xr-xcontrib/perl5/Makefile.SH646
-rwxr-xr-xcontrib/perl5/Policy_sh.SH153
-rw-r--r--contrib/perl5/Porting/Contract108
-rw-r--r--contrib/perl5/Porting/Glossary2580
-rw-r--r--contrib/perl5/Porting/config.sh585
-rw-r--r--contrib/perl5/Porting/config_H2103
-rwxr-xr-xcontrib/perl5/Porting/findvars373
-rwxr-xr-xcontrib/perl5/Porting/fixCORE68
-rwxr-xr-xcontrib/perl5/Porting/fixvars69
-rwxr-xr-xcontrib/perl5/Porting/genlog118
-rwxr-xr-xcontrib/perl5/Porting/makerel129
-rwxr-xr-xcontrib/perl5/Porting/p4d2p84
-rw-r--r--contrib/perl5/Porting/patching.pod319
-rwxr-xr-xcontrib/perl5/Porting/patchls539
-rw-r--r--contrib/perl5/Porting/pumpkin.pod1313
-rw-r--r--contrib/perl5/README102
-rw-r--r--contrib/perl5/README.threads277
-rw-r--r--contrib/perl5/Todo57
-rw-r--r--contrib/perl5/Todo-5.00568
-rw-r--r--contrib/perl5/XSUB.h93
-rw-r--r--contrib/perl5/XSlock.h35
-rw-r--r--contrib/perl5/av.c658
-rw-r--r--contrib/perl5/av.h51
-rw-r--r--contrib/perl5/bytecode.h161
-rw-r--r--contrib/perl5/bytecode.pl388
-rw-r--r--contrib/perl5/byterun.c867
-rw-r--r--contrib/perl5/byterun.h184
-rw-r--r--contrib/perl5/cc_runtime.h71
-rwxr-xr-xcontrib/perl5/cflags.SH136
-rwxr-xr-xcontrib/perl5/config_h.SH2118
-rwxr-xr-xcontrib/perl5/configpm417
-rw-r--r--contrib/perl5/configure.com2033
-rwxr-xr-xcontrib/perl5/configure.gnu124
-rw-r--r--contrib/perl5/cop.h368
-rw-r--r--contrib/perl5/cv.h96
-rw-r--r--contrib/perl5/deb.c114
-rw-r--r--contrib/perl5/doio.c1670
-rw-r--r--contrib/perl5/doop.c528
-rw-r--r--contrib/perl5/dosish.h135
-rw-r--r--contrib/perl5/dump.c422
-rw-r--r--contrib/perl5/ebcdic.c32
-rw-r--r--contrib/perl5/embed.h1088
-rwxr-xr-xcontrib/perl5/embed.pl323
-rw-r--r--contrib/perl5/embedvar.h891
-rw-r--r--contrib/perl5/ext/B/B.pm825
-rw-r--r--contrib/perl5/ext/B/B.xs1207
-rw-r--r--contrib/perl5/ext/B/B/Asmdata.pm170
-rw-r--r--contrib/perl5/ext/B/B/Assembler.pm227
-rw-r--r--contrib/perl5/ext/B/B/Bblock.pm162
-rw-r--r--contrib/perl5/ext/B/B/Bytecode.pm908
-rw-r--r--contrib/perl5/ext/B/B/C.pm1319
-rw-r--r--contrib/perl5/ext/B/B/CC.pm1734
-rw-r--r--contrib/perl5/ext/B/B/Debug.pm283
-rw-r--r--contrib/perl5/ext/B/B/Deparse.pm2670
-rw-r--r--contrib/perl5/ext/B/B/Disassembler.pm164
-rw-r--r--contrib/perl5/ext/B/B/Lint.pm367
-rw-r--r--contrib/perl5/ext/B/B/Showlex.pm80
-rw-r--r--contrib/perl5/ext/B/B/Stackobj.pm301
-rw-r--r--contrib/perl5/ext/B/B/Terse.pm152
-rw-r--r--contrib/perl5/ext/B/B/Xref.pm392
-rwxr-xr-xcontrib/perl5/ext/B/B/assemble30
-rw-r--r--contrib/perl5/ext/B/B/cc_harness12
-rwxr-xr-xcontrib/perl5/ext/B/B/disassemble22
-rw-r--r--contrib/perl5/ext/B/B/makeliblinks54
-rw-r--r--contrib/perl5/ext/B/Makefile.PL46
-rw-r--r--contrib/perl5/ext/B/NOTES168
-rw-r--r--contrib/perl5/ext/B/O.pm85
-rw-r--r--contrib/perl5/ext/B/README325
-rw-r--r--contrib/perl5/ext/B/TESTS78
-rw-r--r--contrib/perl5/ext/B/Todo37
-rw-r--r--contrib/perl5/ext/B/byteperl.c110
-rw-r--r--contrib/perl5/ext/B/ramblings/cc.notes32
-rw-r--r--contrib/perl5/ext/B/ramblings/curcop.runtime39
-rw-r--r--contrib/perl5/ext/B/ramblings/flip-flop51
-rw-r--r--contrib/perl5/ext/B/ramblings/magic93
-rw-r--r--contrib/perl5/ext/B/ramblings/reg.alloc32
-rw-r--r--contrib/perl5/ext/B/ramblings/runtime.porting350
-rw-r--r--contrib/perl5/ext/B/typemap69
-rw-r--r--contrib/perl5/ext/DB_File/Changes205
-rw-r--r--contrib/perl5/ext/DB_File/DB_File.pm1695
-rw-r--r--contrib/perl5/ext/DB_File/DB_File.xs1497
-rw-r--r--contrib/perl5/ext/DB_File/DB_File_BS6
-rw-r--r--contrib/perl5/ext/DB_File/Makefile.PL20
-rw-r--r--contrib/perl5/ext/DB_File/dbinfo96
-rw-r--r--contrib/perl5/ext/DB_File/typemap41
-rw-r--r--contrib/perl5/ext/Data/Dumper/Changes160
-rw-r--r--contrib/perl5/ext/Data/Dumper/Dumper.pm963
-rw-r--r--contrib/perl5/ext/Data/Dumper/Dumper.xs800
-rw-r--r--contrib/perl5/ext/Data/Dumper/Makefile.PL11
-rw-r--r--contrib/perl5/ext/Data/Dumper/Todo32
-rw-r--r--contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL729
-rw-r--r--contrib/perl5/ext/DynaLoader/Makefile.PL29
-rw-r--r--contrib/perl5/ext/DynaLoader/README53
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_aix.xs670
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_cygwin32.xs153
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_dld.xs175
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_dlopen.xs219
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_hpux.xs157
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_mpeix.xs128
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_next.xs303
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_none.xs19
-rw-r--r--contrib/perl5/ext/DynaLoader/dl_vms.xs356
-rw-r--r--contrib/perl5/ext/DynaLoader/dlutils.c72
-rw-r--r--contrib/perl5/ext/Errno/ChangeLog50
-rw-r--r--contrib/perl5/ext/Errno/Errno_pm.PL276
-rw-r--r--contrib/perl5/ext/Errno/Makefile.PL29
-rw-r--r--contrib/perl5/ext/Fcntl/Fcntl.pm137
-rw-r--r--contrib/perl5/ext/Fcntl/Fcntl.xs377
-rw-r--r--contrib/perl5/ext/Fcntl/Makefile.PL8
-rw-r--r--contrib/perl5/ext/GDBM_File/GDBM_File.pm87
-rw-r--r--contrib/perl5/ext/GDBM_File/GDBM_File.xs243
-rw-r--r--contrib/perl5/ext/GDBM_File/Makefile.PL8
-rw-r--r--contrib/perl5/ext/GDBM_File/typemap27
-rw-r--r--contrib/perl5/ext/IO/IO.pm36
-rw-r--r--contrib/perl5/ext/IO/IO.xs292
-rw-r--r--contrib/perl5/ext/IO/Makefile.PL8
-rw-r--r--contrib/perl5/ext/IO/README4
-rw-r--r--contrib/perl5/ext/IO/lib/IO/File.pm167
-rw-r--r--contrib/perl5/ext/IO/lib/IO/Handle.pm539
-rw-r--r--contrib/perl5/ext/IO/lib/IO/Pipe.pm239
-rw-r--r--contrib/perl5/ext/IO/lib/IO/Seekable.pm68
-rw-r--r--contrib/perl5/ext/IO/lib/IO/Select.pm371
-rw-r--r--contrib/perl5/ext/IO/lib/IO/Socket.pm728
-rw-r--r--contrib/perl5/ext/IPC/SysV/ChangeLog28
-rw-r--r--contrib/perl5/ext/IPC/SysV/MANIFEST10
-rw-r--r--contrib/perl5/ext/IPC/SysV/Makefile.PL36
-rw-r--r--contrib/perl5/ext/IPC/SysV/Msg.pm223
-rw-r--r--contrib/perl5/ext/IPC/SysV/README20
-rw-r--r--contrib/perl5/ext/IPC/SysV/Semaphore.pm297
-rw-r--r--contrib/perl5/ext/IPC/SysV/SysV.pm98
-rw-r--r--contrib/perl5/ext/IPC/SysV/SysV.xs423
-rwxr-xr-xcontrib/perl5/ext/IPC/SysV/t/msg.t41
-rwxr-xr-xcontrib/perl5/ext/IPC/SysV/t/sem.t51
-rw-r--r--contrib/perl5/ext/NDBM_File/Makefile.PL8
-rw-r--r--contrib/perl5/ext/NDBM_File/NDBM_File.pm40
-rw-r--r--contrib/perl5/ext/NDBM_File/NDBM_File.xs70
-rw-r--r--contrib/perl5/ext/NDBM_File/hints/dec_osf.pl2
-rw-r--r--contrib/perl5/ext/NDBM_File/hints/dynixptx.pl3
-rw-r--r--contrib/perl5/ext/NDBM_File/hints/solaris.pl3
-rw-r--r--contrib/perl5/ext/NDBM_File/hints/svr4.pl4
-rw-r--r--contrib/perl5/ext/NDBM_File/typemap27
-rw-r--r--contrib/perl5/ext/ODBM_File/Makefile.PL8
-rw-r--r--contrib/perl5/ext/ODBM_File/ODBM_File.pm35
-rw-r--r--contrib/perl5/ext/ODBM_File/ODBM_File.xs122
-rw-r--r--contrib/perl5/ext/ODBM_File/hints/dec_osf.pl9
-rw-r--r--contrib/perl5/ext/ODBM_File/hints/hpux.pl4
-rw-r--r--contrib/perl5/ext/ODBM_File/hints/sco.pl4
-rw-r--r--contrib/perl5/ext/ODBM_File/hints/solaris.pl3
-rw-r--r--contrib/perl5/ext/ODBM_File/hints/svr4.pl4
-rw-r--r--contrib/perl5/ext/ODBM_File/hints/ultrix.pl4
-rw-r--r--contrib/perl5/ext/ODBM_File/typemap25
-rw-r--r--contrib/perl5/ext/Opcode/Makefile.PL7
-rw-r--r--contrib/perl5/ext/Opcode/Opcode.pm575
-rw-r--r--contrib/perl5/ext/Opcode/Opcode.xs468
-rw-r--r--contrib/perl5/ext/Opcode/Safe.pm559
-rw-r--r--contrib/perl5/ext/Opcode/ops.pm45
-rw-r--r--contrib/perl5/ext/POSIX/Makefile.PL8
-rw-r--r--contrib/perl5/ext/POSIX/POSIX.pm926
-rw-r--r--contrib/perl5/ext/POSIX/POSIX.pod1729
-rw-r--r--contrib/perl5/ext/POSIX/POSIX.xs3666
-rw-r--r--contrib/perl5/ext/POSIX/hints/bsdos.pl3
-rw-r--r--contrib/perl5/ext/POSIX/hints/freebsd.pl3
-rw-r--r--contrib/perl5/ext/POSIX/hints/linux.pl5
-rw-r--r--contrib/perl5/ext/POSIX/hints/netbsd.pl3
-rw-r--r--contrib/perl5/ext/POSIX/hints/next_3.pl5
-rw-r--r--contrib/perl5/ext/POSIX/hints/openbsd.pl3
-rw-r--r--contrib/perl5/ext/POSIX/hints/sunos_4.pl10
-rw-r--r--contrib/perl5/ext/POSIX/typemap14
-rw-r--r--contrib/perl5/ext/SDBM_File/Makefile.PL35
-rw-r--r--contrib/perl5/ext/SDBM_File/SDBM_File.pm35
-rw-r--r--contrib/perl5/ext/SDBM_File/SDBM_File.xs71
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/CHANGES18
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/COMPARE88
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL65
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/README396
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/README.too9
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/biblio64
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/dba.c85
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/dbd.c111
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/dbe.146
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/dbe.c435
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/dbm.c120
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/dbm.h35
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/dbu.c251
-rwxr-xr-xcontrib/perl5/ext/SDBM_File/sdbm/grind9
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/hash.c47
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/linux.patches67
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/makefile.sdbm55
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/pair.c283
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/pair.h20
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/readme.ms353
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/sdbm.3290
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/sdbm.c492
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/sdbm.h290
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/tune.h23
-rw-r--r--contrib/perl5/ext/SDBM_File/sdbm/util.c47
-rw-r--r--contrib/perl5/ext/SDBM_File/typemap27
-rw-r--r--contrib/perl5/ext/Socket/Makefile.PL7
-rw-r--r--contrib/perl5/ext/Socket/Socket.pm307
-rw-r--r--contrib/perl5/ext/Socket/Socket.xs890
-rw-r--r--contrib/perl5/ext/Thread/Makefile.PL7
-rw-r--r--contrib/perl5/ext/Thread/Notes13
-rw-r--r--contrib/perl5/ext/Thread/README20
-rw-r--r--contrib/perl5/ext/Thread/Thread.pm185
-rw-r--r--contrib/perl5/ext/Thread/Thread.xs641
-rw-r--r--contrib/perl5/ext/Thread/Thread/Queue.pm99
-rw-r--r--contrib/perl5/ext/Thread/Thread/Semaphore.pm87
-rw-r--r--contrib/perl5/ext/Thread/Thread/Signal.pm50
-rw-r--r--contrib/perl5/ext/Thread/Thread/Specific.pm29
-rw-r--r--contrib/perl5/ext/Thread/create.t17
-rw-r--r--contrib/perl5/ext/Thread/die.t16
-rw-r--r--contrib/perl5/ext/Thread/die2.t16
-rw-r--r--contrib/perl5/ext/Thread/io.t39
-rw-r--r--contrib/perl5/ext/Thread/join.t11
-rw-r--r--contrib/perl5/ext/Thread/join2.t12
-rw-r--r--contrib/perl5/ext/Thread/list.t30
-rw-r--r--contrib/perl5/ext/Thread/lock.t27
-rw-r--r--contrib/perl5/ext/Thread/queue.t36
-rw-r--r--contrib/perl5/ext/Thread/specific.t17
-rw-r--r--contrib/perl5/ext/Thread/sync.t61
-rw-r--r--contrib/perl5/ext/Thread/sync2.t69
-rw-r--r--contrib/perl5/ext/Thread/typemap24
-rw-r--r--contrib/perl5/ext/Thread/unsync.t37
-rw-r--r--contrib/perl5/ext/Thread/unsync2.t36
-rw-r--r--contrib/perl5/ext/Thread/unsync3.t50
-rw-r--r--contrib/perl5/ext/Thread/unsync4.t38
-rw-r--r--contrib/perl5/ext/attrs/Makefile.PL7
-rw-r--r--contrib/perl5/ext/attrs/attrs.pm55
-rw-r--r--contrib/perl5/ext/attrs/attrs.xs59
-rw-r--r--contrib/perl5/ext/re/Makefile.PL41
-rw-r--r--contrib/perl5/ext/re/hints/mpeix.pl3
-rw-r--r--contrib/perl5/ext/re/re.pm131
-rw-r--r--contrib/perl5/ext/re/re.xs46
-rw-r--r--contrib/perl5/ext/util/make_ext141
-rw-r--r--contrib/perl5/ext/util/mkbootstrap5
-rw-r--r--contrib/perl5/fakethr.h56
-rw-r--r--contrib/perl5/form.h26
-rw-r--r--contrib/perl5/global.sym1071
-rw-r--r--contrib/perl5/globals.c1471
-rw-r--r--contrib/perl5/gv.c1448
-rw-r--r--contrib/perl5/gv.h137
-rw-r--r--contrib/perl5/h2pl/README71
-rw-r--r--contrib/perl5/h2pl/cbreak.pl34
-rw-r--r--contrib/perl5/h2pl/cbreak2.pl33
-rw-r--r--contrib/perl5/h2pl/eg/sizeof.ph14
-rw-r--r--contrib/perl5/h2pl/eg/sys/errno.pl92
-rw-r--r--contrib/perl5/h2pl/eg/sys/ioctl.pl186
-rw-r--r--contrib/perl5/h2pl/eg/sysexits.pl16
-rw-r--r--contrib/perl5/h2pl/getioctlsizes13
-rw-r--r--contrib/perl5/h2pl/mksizes42
-rw-r--r--contrib/perl5/h2pl/mkvars31
-rw-r--r--contrib/perl5/h2pl/tcbreak17
-rw-r--r--contrib/perl5/h2pl/tcbreak217
-rw-r--r--contrib/perl5/handy.h338
-rw-r--r--contrib/perl5/hints/3b1.sh15
-rw-r--r--contrib/perl5/hints/3b1cc88
-rw-r--r--contrib/perl5/hints/README.hints213
-rw-r--r--contrib/perl5/hints/aix.sh102
-rw-r--r--contrib/perl5/hints/altos486.sh3
-rw-r--r--contrib/perl5/hints/amigaos.sh51
-rw-r--r--contrib/perl5/hints/apollo.sh51
-rw-r--r--contrib/perl5/hints/aux_3.sh22
-rw-r--r--contrib/perl5/hints/beos.sh45
-rw-r--r--contrib/perl5/hints/broken-db.msg14
-rw-r--r--contrib/perl5/hints/bsdos.sh106
-rw-r--r--contrib/perl5/hints/convexos.sh12
-rw-r--r--contrib/perl5/hints/cxux.sh106
-rw-r--r--contrib/perl5/hints/cygwin32.sh50
-rw-r--r--contrib/perl5/hints/dcosx.sh188
-rw-r--r--contrib/perl5/hints/dec_osf.sh334
-rw-r--r--contrib/perl5/hints/dgux.sh141
-rw-r--r--contrib/perl5/hints/dos_djgpp.sh59
-rw-r--r--contrib/perl5/hints/dynix.sh7
-rw-r--r--contrib/perl5/hints/dynixptx.sh24
-rw-r--r--contrib/perl5/hints/epix.sh75
-rw-r--r--contrib/perl5/hints/esix4.sh41
-rw-r--r--contrib/perl5/hints/fps.sh1
-rw-r--r--contrib/perl5/hints/freebsd.sh155
-rw-r--r--contrib/perl5/hints/genix.sh1
-rw-r--r--contrib/perl5/hints/greenhills.sh1
-rw-r--r--contrib/perl5/hints/hpux.sh206
-rw-r--r--contrib/perl5/hints/i386.sh1
-rw-r--r--contrib/perl5/hints/irix_4.sh24
-rw-r--r--contrib/perl5/hints/irix_5.sh34
-rw-r--r--contrib/perl5/hints/irix_6.sh190
-rw-r--r--contrib/perl5/hints/irix_6_0.sh51
-rw-r--r--contrib/perl5/hints/irix_6_1.sh50
-rw-r--r--contrib/perl5/hints/isc.sh44
-rw-r--r--contrib/perl5/hints/isc_2.sh25
-rw-r--r--contrib/perl5/hints/linux.sh215
-rw-r--r--contrib/perl5/hints/lynxos.sh11
-rw-r--r--contrib/perl5/hints/machten.sh224
-rw-r--r--contrib/perl5/hints/machten_2.sh94
-rw-r--r--contrib/perl5/hints/mips.sh14
-rw-r--r--contrib/perl5/hints/mpc.sh1
-rw-r--r--contrib/perl5/hints/mpeix.sh104
-rw-r--r--contrib/perl5/hints/ncr_tower.sh16
-rw-r--r--contrib/perl5/hints/netbsd.sh79
-rw-r--r--contrib/perl5/hints/newsos4.sh34
-rw-r--r--contrib/perl5/hints/next_3.sh131
-rw-r--r--contrib/perl5/hints/next_3_0.sh53
-rw-r--r--contrib/perl5/hints/next_4.sh95
-rw-r--r--contrib/perl5/hints/openbsd.sh51
-rw-r--r--contrib/perl5/hints/opus.sh1
-rw-r--r--contrib/perl5/hints/os2.sh302
-rw-r--r--contrib/perl5/hints/os390.sh56
-rw-r--r--contrib/perl5/hints/powerux.sh95
-rw-r--r--contrib/perl5/hints/qnx.sh182
-rw-r--r--contrib/perl5/hints/sco.sh140
-rw-r--r--contrib/perl5/hints/sco_2_3_0.sh2
-rw-r--r--contrib/perl5/hints/sco_2_3_1.sh2
-rw-r--r--contrib/perl5/hints/sco_2_3_2.sh2
-rw-r--r--contrib/perl5/hints/sco_2_3_3.sh3
-rw-r--r--contrib/perl5/hints/sco_2_3_4.sh5
-rw-r--r--contrib/perl5/hints/solaris_2.sh441
-rw-r--r--contrib/perl5/hints/stellar.sh2
-rw-r--r--contrib/perl5/hints/sunos_4_0.sh2
-rw-r--r--contrib/perl5/hints/sunos_4_1.sh72
-rw-r--r--contrib/perl5/hints/svr4.sh153
-rw-r--r--contrib/perl5/hints/ti1500.sh1
-rw-r--r--contrib/perl5/hints/titanos.sh39
-rw-r--r--contrib/perl5/hints/ultrix_4.sh66
-rw-r--r--contrib/perl5/hints/umips.sh39
-rw-r--r--contrib/perl5/hints/unicos.sh16
-rw-r--r--contrib/perl5/hints/unicosmk.sh10
-rw-r--r--contrib/perl5/hints/unisysdynix.sh1
-rw-r--r--contrib/perl5/hints/utekv.sh12
-rw-r--r--contrib/perl5/hints/uts.sh2
-rw-r--r--contrib/perl5/hv.c1226
-rw-r--r--contrib/perl5/hv.h120
-rwxr-xr-xcontrib/perl5/installhtml584
-rwxr-xr-xcontrib/perl5/installman261
-rwxr-xr-xcontrib/perl5/installperl600
-rw-r--r--contrib/perl5/interp.sym211
-rw-r--r--contrib/perl5/intrpvar.h218
-rw-r--r--contrib/perl5/iperlsys.h930
-rw-r--r--contrib/perl5/keywords.h250
-rwxr-xr-xcontrib/perl5/keywords.pl276
-rw-r--r--contrib/perl5/lib/AnyDBM_File.pm92
-rw-r--r--contrib/perl5/lib/AutoLoader.pm295
-rw-r--r--contrib/perl5/lib/AutoSplit.pm461
-rw-r--r--contrib/perl5/lib/Benchmark.pm515
-rw-r--r--contrib/perl5/lib/CGI.pm6102
-rw-r--r--contrib/perl5/lib/CGI/Apache.pm103
-rw-r--r--contrib/perl5/lib/CGI/Carp.pm331
-rw-r--r--contrib/perl5/lib/CGI/Cookie.pm418
-rw-r--r--contrib/perl5/lib/CGI/Fast.pm173
-rw-r--r--contrib/perl5/lib/CGI/Push.pm313
-rw-r--r--contrib/perl5/lib/CGI/Switch.pm71
-rw-r--r--contrib/perl5/lib/CPAN.pm4368
-rw-r--r--contrib/perl5/lib/CPAN/FirstTime.pm439
-rw-r--r--contrib/perl5/lib/CPAN/Nox.pm34
-rw-r--r--contrib/perl5/lib/Carp.pm276
-rw-r--r--contrib/perl5/lib/Class/Struct.pm484
-rw-r--r--contrib/perl5/lib/Cwd.pm385
-rw-r--r--contrib/perl5/lib/Devel/SelfStubber.pm139
-rw-r--r--contrib/perl5/lib/DirHandle.pm72
-rw-r--r--contrib/perl5/lib/English.pm178
-rw-r--r--contrib/perl5/lib/Env.pm77
-rw-r--r--contrib/perl5/lib/Exporter.pm467
-rw-r--r--contrib/perl5/lib/ExtUtils/Command.pm211
-rw-r--r--contrib/perl5/lib/ExtUtils/Embed.pm502
-rw-r--r--contrib/perl5/lib/ExtUtils/Install.pm374
-rw-r--r--contrib/perl5/lib/ExtUtils/Installed.pm272
-rw-r--r--contrib/perl5/lib/ExtUtils/Liblist.pm750
-rw-r--r--contrib/perl5/lib/ExtUtils/MM_OS2.pm85
-rw-r--r--contrib/perl5/lib/ExtUtils/MM_Unix.pm3539
-rw-r--r--contrib/perl5/lib/ExtUtils/MM_VMS.pm2391
-rw-r--r--contrib/perl5/lib/ExtUtils/MM_Win32.pm823
-rw-r--r--contrib/perl5/lib/ExtUtils/MakeMaker.pm1933
-rw-r--r--contrib/perl5/lib/ExtUtils/Manifest.pm408
-rw-r--r--contrib/perl5/lib/ExtUtils/Mkbootstrap.pm103
-rw-r--r--contrib/perl5/lib/ExtUtils/Mksymlists.pm276
-rw-r--r--contrib/perl5/lib/ExtUtils/Packlist.pm288
-rwxr-xr-xcontrib/perl5/lib/ExtUtils/inst139
-rw-r--r--contrib/perl5/lib/ExtUtils/testlib.pm26
-rw-r--r--contrib/perl5/lib/ExtUtils/typemap289
-rwxr-xr-xcontrib/perl5/lib/ExtUtils/xsubpp1512
-rw-r--r--contrib/perl5/lib/Fatal.pm157
-rw-r--r--contrib/perl5/lib/File/Basename.pm263
-rw-r--r--contrib/perl5/lib/File/CheckTree.pm151
-rw-r--r--contrib/perl5/lib/File/Compare.pm143
-rw-r--r--contrib/perl5/lib/File/Copy.pm342
-rw-r--r--contrib/perl5/lib/File/DosGlob.pm249
-rw-r--r--contrib/perl5/lib/File/Find.pm230
-rw-r--r--contrib/perl5/lib/File/Path.pm228
-rw-r--r--contrib/perl5/lib/File/Spec.pm116
-rw-r--r--contrib/perl5/lib/File/Spec/Mac.pm230
-rw-r--r--contrib/perl5/lib/File/Spec/OS2.pm51
-rw-r--r--contrib/perl5/lib/File/Spec/Unix.pm197
-rw-r--r--contrib/perl5/lib/File/Spec/VMS.pm148
-rw-r--r--contrib/perl5/lib/File/Spec/Win32.pm104
-rw-r--r--contrib/perl5/lib/File/stat.pm113
-rw-r--r--contrib/perl5/lib/FileCache.pm78
-rw-r--r--contrib/perl5/lib/FileHandle.pm262
-rw-r--r--contrib/perl5/lib/FindBin.pm188
-rw-r--r--contrib/perl5/lib/Getopt/Long.pm1381
-rw-r--r--contrib/perl5/lib/Getopt/Std.pm166
-rw-r--r--contrib/perl5/lib/I18N/Collate.pm189
-rw-r--r--contrib/perl5/lib/IPC/Open2.pm95
-rw-r--r--contrib/perl5/lib/IPC/Open3.pm292
-rw-r--r--contrib/perl5/lib/Math/BigFloat.pm327
-rw-r--r--contrib/perl5/lib/Math/BigInt.pm415
-rw-r--r--contrib/perl5/lib/Math/Complex.pm1775
-rw-r--r--contrib/perl5/lib/Math/Trig.pm419
-rw-r--r--contrib/perl5/lib/Net/Ping.pm550
-rw-r--r--contrib/perl5/lib/Net/hostent.pm149
-rw-r--r--contrib/perl5/lib/Net/netent.pm167
-rw-r--r--contrib/perl5/lib/Net/protoent.pm94
-rw-r--r--contrib/perl5/lib/Net/servent.pm111
-rw-r--r--contrib/perl5/lib/Pod/Functions.pm296
-rw-r--r--contrib/perl5/lib/Pod/Html.pm1571
-rw-r--r--contrib/perl5/lib/Pod/Text.pm549
-rw-r--r--contrib/perl5/lib/Search/Dict.pm75
-rw-r--r--contrib/perl5/lib/SelectSaver.pm52
-rw-r--r--contrib/perl5/lib/SelfLoader.pm295
-rw-r--r--contrib/perl5/lib/Shell.pm126
-rw-r--r--contrib/perl5/lib/Symbol.pm139
-rw-r--r--contrib/perl5/lib/Sys/Hostname.pm121
-rw-r--r--contrib/perl5/lib/Sys/Syslog.pm276
-rw-r--r--contrib/perl5/lib/Term/Cap.pm410
-rw-r--r--contrib/perl5/lib/Term/Complete.pm150
-rw-r--r--contrib/perl5/lib/Term/ReadLine.pm365
-rw-r--r--contrib/perl5/lib/Test.pm235
-rw-r--r--contrib/perl5/lib/Test/Harness.pm473
-rw-r--r--contrib/perl5/lib/Text/Abbrev.pm87
-rw-r--r--contrib/perl5/lib/Text/ParseWords.pm256
-rw-r--r--contrib/perl5/lib/Text/Soundex.pm148
-rw-r--r--contrib/perl5/lib/Text/Tabs.pm97
-rw-r--r--contrib/perl5/lib/Text/Wrap.pm125
-rw-r--r--contrib/perl5/lib/Tie/Array.pm262
-rw-r--r--contrib/perl5/lib/Tie/Handle.pm161
-rw-r--r--contrib/perl5/lib/Tie/Hash.pm158
-rw-r--r--contrib/perl5/lib/Tie/RefHash.pm123
-rw-r--r--contrib/perl5/lib/Tie/Scalar.pm138
-rw-r--r--contrib/perl5/lib/Tie/SubstrHash.pm180
-rw-r--r--contrib/perl5/lib/Time/Local.pm138
-rw-r--r--contrib/perl5/lib/Time/gmtime.pm88
-rw-r--r--contrib/perl5/lib/Time/localtime.pm84
-rw-r--r--contrib/perl5/lib/Time/tm.pm31
-rw-r--r--contrib/perl5/lib/UNIVERSAL.pm97
-rw-r--r--contrib/perl5/lib/User/grent.pm93
-rw-r--r--contrib/perl5/lib/User/pwent.pm103
-rw-r--r--contrib/perl5/lib/abbrev.pl33
-rw-r--r--contrib/perl5/lib/assert.pl55
-rw-r--r--contrib/perl5/lib/autouse.pm157
-rw-r--r--contrib/perl5/lib/base.pm77
-rw-r--r--contrib/perl5/lib/bigfloat.pl235
-rw-r--r--contrib/perl5/lib/bigint.pl285
-rw-r--r--contrib/perl5/lib/bigrat.pl149
-rw-r--r--contrib/perl5/lib/blib.pm72
-rw-r--r--contrib/perl5/lib/cacheout.pl46
-rw-r--r--contrib/perl5/lib/chat2.pl370
-rw-r--r--contrib/perl5/lib/complete.pl111
-rw-r--r--contrib/perl5/lib/constant.pm172
-rw-r--r--contrib/perl5/lib/ctime.pl51
-rwxr-xr-xcontrib/perl5/lib/diagnostics.pm533
-rw-r--r--contrib/perl5/lib/dotsh.pl67
-rw-r--r--contrib/perl5/lib/dumpvar.pl417
-rw-r--r--contrib/perl5/lib/exceptions.pl54
-rw-r--r--contrib/perl5/lib/fastcwd.pl35
-rw-r--r--contrib/perl5/lib/fields.pm156
-rw-r--r--contrib/perl5/lib/find.pl47
-rw-r--r--contrib/perl5/lib/finddepth.pl46
-rw-r--r--contrib/perl5/lib/flush.pl23
-rw-r--r--contrib/perl5/lib/ftp.pl1077
-rw-r--r--contrib/perl5/lib/getcwd.pl62
-rw-r--r--contrib/perl5/lib/getopt.pl41
-rw-r--r--contrib/perl5/lib/getopts.pl49
-rw-r--r--contrib/perl5/lib/hostname.pl23
-rw-r--r--contrib/perl5/lib/importenv.pl16
-rw-r--r--contrib/perl5/lib/integer.pm43
-rw-r--r--contrib/perl5/lib/less.pm23
-rw-r--r--contrib/perl5/lib/lib.pm139
-rw-r--r--contrib/perl5/lib/locale.pm33
-rw-r--r--contrib/perl5/lib/look.pl44
-rw-r--r--contrib/perl5/lib/newgetopt.pl68
-rw-r--r--contrib/perl5/lib/open2.pl12
-rw-r--r--contrib/perl5/lib/open3.pl12
-rw-r--r--contrib/perl5/lib/overload.pm1216
-rw-r--r--contrib/perl5/lib/perl5db.pl2183
-rw-r--r--contrib/perl5/lib/pwd.pl58
-rw-r--r--contrib/perl5/lib/shellwords.pl48
-rw-r--r--contrib/perl5/lib/sigtrap.pm289
-rw-r--r--contrib/perl5/lib/stat.pl31
-rw-r--r--contrib/perl5/lib/strict.pm104
-rw-r--r--contrib/perl5/lib/subs.pm38
-rw-r--r--contrib/perl5/lib/syslog.pl197
-rw-r--r--contrib/perl5/lib/tainted.pl9
-rw-r--r--contrib/perl5/lib/termcap.pl169
-rw-r--r--contrib/perl5/lib/timelocal.pl18
-rw-r--r--contrib/perl5/lib/validate.pl104
-rw-r--r--contrib/perl5/lib/vars.pm75
-rwxr-xr-xcontrib/perl5/makeaperl.SH130
-rwxr-xr-xcontrib/perl5/makedepend.SH203
-rwxr-xr-xcontrib/perl5/makedir.SH68
-rw-r--r--contrib/perl5/malloc.c1663
-rw-r--r--contrib/perl5/mg.c1984
-rw-r--r--contrib/perl5/mg.h45
-rw-r--r--contrib/perl5/minimod.pl139
-rw-r--r--contrib/perl5/miniperlmain.c65
-rw-r--r--contrib/perl5/mv-if-diff15
-rwxr-xr-xcontrib/perl5/myconfig43
-rw-r--r--contrib/perl5/nostdio.h26
-rw-r--r--contrib/perl5/objXSUB.h2055
-rw-r--r--contrib/perl5/objpp.h1463
-rw-r--r--contrib/perl5/op.c5112
-rw-r--r--contrib/perl5/op.h322
-rw-r--r--contrib/perl5/opcode.h2525
-rwxr-xr-xcontrib/perl5/opcode.pl703
-rw-r--r--contrib/perl5/patchlevel.h51
-rw-r--r--contrib/perl5/perl.c2983
-rw-r--r--contrib/perl5/perl.h2452
-rwxr-xr-xcontrib/perl5/perl_exp.SH113
-rw-r--r--contrib/perl5/perlio.c619
-rw-r--r--contrib/perl5/perlio.h1
-rw-r--r--contrib/perl5/perlio.sym49
-rw-r--r--contrib/perl5/perlsdio.h322
-rw-r--r--contrib/perl5/perlsfio.h58
-rw-r--r--contrib/perl5/perlsh15
-rw-r--r--contrib/perl5/perlvars.h180
-rw-r--r--contrib/perl5/perly.c2366
-rwxr-xr-xcontrib/perl5/perly.fixer208
-rw-r--r--contrib/perl5/perly.h65
-rw-r--r--contrib/perl5/perly.y643
-rw-r--r--contrib/perl5/perly_c.diff444
-rw-r--r--contrib/perl5/pod/Makefile286
-rw-r--r--contrib/perl5/pod/buildtoc241
-rw-r--r--contrib/perl5/pod/checkpods.PL85
-rw-r--r--contrib/perl5/pod/perl.pod319
-rw-r--r--contrib/perl5/pod/perl5004delta.pod1609
-rw-r--r--contrib/perl5/pod/perlapio.pod274
-rw-r--r--contrib/perl5/pod/perlbook.pod16
-rw-r--r--contrib/perl5/pod/perlbot.pod527
-rw-r--r--contrib/perl5/pod/perlcall.pod1959
-rw-r--r--contrib/perl5/pod/perldata.pod603
-rw-r--r--contrib/perl5/pod/perldebug.pod1661
-rw-r--r--contrib/perl5/pod/perldelta.pod919
-rw-r--r--contrib/perl5/pod/perldiag.pod3125
-rw-r--r--contrib/perl5/pod/perldsc.pod832
-rw-r--r--contrib/perl5/pod/perlembed.pod1029
-rw-r--r--contrib/perl5/pod/perlfaq.pod172
-rw-r--r--contrib/perl5/pod/perlfaq1.pod268
-rw-r--r--contrib/perl5/pod/perlfaq2.pod499
-rw-r--r--contrib/perl5/pod/perlfaq3.pod595
-rw-r--r--contrib/perl5/pod/perlfaq4.pod1358
-rw-r--r--contrib/perl5/pod/perlfaq5.pod1074
-rw-r--r--contrib/perl5/pod/perlfaq6.pod626
-rw-r--r--contrib/perl5/pod/perlfaq7.pod816
-rw-r--r--contrib/perl5/pod/perlfaq8.pod1075
-rw-r--r--contrib/perl5/pod/perlfaq9.pod552
-rw-r--r--contrib/perl5/pod/perlform.pod337
-rw-r--r--contrib/perl5/pod/perlfunc.pod4440
-rw-r--r--contrib/perl5/pod/perlguts.pod3557
-rw-r--r--contrib/perl5/pod/perlhist.pod518
-rw-r--r--contrib/perl5/pod/perlipc.pod1443
-rw-r--r--contrib/perl5/pod/perllocale.pod976
-rw-r--r--contrib/perl5/pod/perllol.pod303
-rw-r--r--contrib/perl5/pod/perlmod.pod375
-rw-r--r--contrib/perl5/pod/perlmodinstall.pod410
-rw-r--r--contrib/perl5/pod/perlmodlib.pod1102
-rw-r--r--contrib/perl5/pod/perlobj.pod541
-rw-r--r--contrib/perl5/pod/perlop.pod1724
-rw-r--r--contrib/perl5/pod/perlpod.pod286
-rw-r--r--contrib/perl5/pod/perlport.pod1461
-rw-r--r--contrib/perl5/pod/perlre.pod929
-rw-r--r--contrib/perl5/pod/perlref.pod646
-rw-r--r--contrib/perl5/pod/perlrun.pod731
-rw-r--r--contrib/perl5/pod/perlsec.pod351
-rw-r--r--contrib/perl5/pod/perlstyle.pod275
-rw-r--r--contrib/perl5/pod/perlsub.pod1149
-rw-r--r--contrib/perl5/pod/perlsyn.pod617
-rw-r--r--contrib/perl5/pod/perltie.pod876
-rw-r--r--contrib/perl5/pod/perltoc.pod5840
-rw-r--r--contrib/perl5/pod/perltoot.pod1787
-rw-r--r--contrib/perl5/pod/perltrap.pod1505
-rw-r--r--contrib/perl5/pod/perlvar.pod936
-rw-r--r--contrib/perl5/pod/perlxs.pod1348
-rw-r--r--contrib/perl5/pod/perlxstut.pod739
-rw-r--r--contrib/perl5/pod/pod2html.PL183
-rw-r--r--contrib/perl5/pod/pod2latex.PL708
-rw-r--r--contrib/perl5/pod/pod2man.PL1216
-rw-r--r--contrib/perl5/pod/pod2text.PL51
-rw-r--r--contrib/perl5/pod/roffitall284
-rwxr-xr-xcontrib/perl5/pod/rofftoc66
-rwxr-xr-xcontrib/perl5/pod/splitman46
-rwxr-xr-xcontrib/perl5/pod/splitpod60
-rw-r--r--contrib/perl5/pp.c4550
-rw-r--r--contrib/perl5/pp.h237
-rw-r--r--contrib/perl5/pp_ctl.c3716
-rw-r--r--contrib/perl5/pp_hot.c2535
-rw-r--r--contrib/perl5/pp_proto.h344
-rw-r--r--contrib/perl5/pp_sys.c4595
-rw-r--r--contrib/perl5/proto.h902
-rw-r--r--contrib/perl5/regcomp.c2672
-rw-r--r--contrib/perl5/regcomp.h222
-rw-r--r--contrib/perl5/regcomp.pl98
-rw-r--r--contrib/perl5/regcomp.sym112
-rw-r--r--contrib/perl5/regexec.c1834
-rw-r--r--contrib/perl5/regexp.h103
-rw-r--r--contrib/perl5/regnodes.h254
-rw-r--r--contrib/perl5/run.c139
-rw-r--r--contrib/perl5/scope.c915
-rw-r--r--contrib/perl5/scope.h171
-rw-r--r--contrib/perl5/sv.c5148
-rw-r--r--contrib/perl5/sv.h669
-rw-r--r--contrib/perl5/t/README16
-rwxr-xr-xcontrib/perl5/t/TEST181
-rwxr-xr-xcontrib/perl5/t/base/cond.t19
-rwxr-xr-xcontrib/perl5/t/base/if.t11
-rwxr-xr-xcontrib/perl5/t/base/lex.t119
-rwxr-xr-xcontrib/perl5/t/base/pat.t11
-rwxr-xr-xcontrib/perl5/t/base/rs.t131
-rwxr-xr-xcontrib/perl5/t/base/term.t55
-rwxr-xr-xcontrib/perl5/t/cmd/elsif.t25
-rwxr-xr-xcontrib/perl5/t/cmd/for.t49
-rwxr-xr-xcontrib/perl5/t/cmd/mod.t54
-rwxr-xr-xcontrib/perl5/t/cmd/subval.t186
-rwxr-xr-xcontrib/perl5/t/cmd/switch.t75
-rwxr-xr-xcontrib/perl5/t/cmd/while.t111
-rwxr-xr-xcontrib/perl5/t/comp/cmdopt.t90
-rwxr-xr-xcontrib/perl5/t/comp/colon.t138
-rwxr-xr-xcontrib/perl5/t/comp/cpp.aux39
-rwxr-xr-xcontrib/perl5/t/comp/cpp.t18
-rwxr-xr-xcontrib/perl5/t/comp/decl.t49
-rwxr-xr-xcontrib/perl5/t/comp/multiline.t46
-rwxr-xr-xcontrib/perl5/t/comp/package.t39
-rwxr-xr-xcontrib/perl5/t/comp/proto.t415
-rwxr-xr-xcontrib/perl5/t/comp/redef.t80
-rwxr-xr-xcontrib/perl5/t/comp/require.t50
-rwxr-xr-xcontrib/perl5/t/comp/script.t27
-rwxr-xr-xcontrib/perl5/t/comp/term.t70
-rwxr-xr-xcontrib/perl5/t/comp/use.t101
-rw-r--r--contrib/perl5/t/harness33
-rwxr-xr-xcontrib/perl5/t/io/argv.t48
-rwxr-xr-xcontrib/perl5/t/io/dup.t39
-rwxr-xr-xcontrib/perl5/t/io/fs.t159
-rwxr-xr-xcontrib/perl5/t/io/inplace.t36
-rwxr-xr-xcontrib/perl5/t/io/iprefix.t36
-rwxr-xr-xcontrib/perl5/t/io/pipe.t135
-rwxr-xr-xcontrib/perl5/t/io/print.t32
-rwxr-xr-xcontrib/perl5/t/io/read.t26
-rwxr-xr-xcontrib/perl5/t/io/tell.t44
-rwxr-xr-xcontrib/perl5/t/lib/abbrev.t51
-rwxr-xr-xcontrib/perl5/t/lib/anydbm.t125
-rwxr-xr-xcontrib/perl5/t/lib/autoloader.t100
-rwxr-xr-xcontrib/perl5/t/lib/basename.t139
-rwxr-xr-xcontrib/perl5/t/lib/bigint.t282
-rwxr-xr-xcontrib/perl5/t/lib/bigintpm.t313
-rwxr-xr-xcontrib/perl5/t/lib/cgi-form.t81
-rwxr-xr-xcontrib/perl5/t/lib/cgi-function.t85
-rwxr-xr-xcontrib/perl5/t/lib/cgi-html.t66
-rwxr-xr-xcontrib/perl5/t/lib/cgi-request.t93
-rwxr-xr-xcontrib/perl5/t/lib/checktree.t19
-rwxr-xr-xcontrib/perl5/t/lib/complex.t879
-rwxr-xr-xcontrib/perl5/t/lib/db-btree.t612
-rwxr-xr-xcontrib/perl5/t/lib/db-hash.t416
-rwxr-xr-xcontrib/perl5/t/lib/db-recno.t453
-rwxr-xr-xcontrib/perl5/t/lib/dirhand.t33
-rwxr-xr-xcontrib/perl5/t/lib/dosglob.t112
-rwxr-xr-xcontrib/perl5/t/lib/dumper-ovl.t30
-rwxr-xr-xcontrib/perl5/t/lib/dumper.t611
-rwxr-xr-xcontrib/perl5/t/lib/english.t47
-rwxr-xr-xcontrib/perl5/t/lib/env.t18
-rwxr-xr-xcontrib/perl5/t/lib/errno.t50
-rwxr-xr-xcontrib/perl5/t/lib/fields.t112
-rwxr-xr-xcontrib/perl5/t/lib/filecache.t25
-rwxr-xr-xcontrib/perl5/t/lib/filecopy.t90
-rwxr-xr-xcontrib/perl5/t/lib/filefind.t14
-rwxr-xr-xcontrib/perl5/t/lib/filehand.t90
-rwxr-xr-xcontrib/perl5/t/lib/filepath.t28
-rwxr-xr-xcontrib/perl5/t/lib/filespec.t43
-rwxr-xr-xcontrib/perl5/t/lib/findbin.t13
-rwxr-xr-xcontrib/perl5/t/lib/gdbm.t208
-rwxr-xr-xcontrib/perl5/t/lib/getopt.t73
-rw-r--r--contrib/perl5/t/lib/h2ph.h85
-rw-r--r--contrib/perl5/t/lib/h2ph.pht69
-rwxr-xr-xcontrib/perl5/t/lib/h2ph.t34
-rwxr-xr-xcontrib/perl5/t/lib/hostname.t19
-rwxr-xr-xcontrib/perl5/t/lib/io_dup.t61
-rwxr-xr-xcontrib/perl5/t/lib/io_pipe.t117
-rwxr-xr-xcontrib/perl5/t/lib/io_sel.t116
-rwxr-xr-xcontrib/perl5/t/lib/io_sock.t91
-rwxr-xr-xcontrib/perl5/t/lib/io_taint.t48
-rwxr-xr-xcontrib/perl5/t/lib/io_tell.t64
-rwxr-xr-xcontrib/perl5/t/lib/io_udp.t48
-rwxr-xr-xcontrib/perl5/t/lib/io_xs.t42
-rwxr-xr-xcontrib/perl5/t/lib/ipc_sysv.t178
-rwxr-xr-xcontrib/perl5/t/lib/ndbm.t207
-rwxr-xr-xcontrib/perl5/t/lib/odbm.t207
-rwxr-xr-xcontrib/perl5/t/lib/opcode.t115
-rwxr-xr-xcontrib/perl5/t/lib/open2.t59
-rwxr-xr-xcontrib/perl5/t/lib/open3.t136
-rwxr-xr-xcontrib/perl5/t/lib/ops.t29
-rwxr-xr-xcontrib/perl5/t/lib/parsewords.t103
-rwxr-xr-xcontrib/perl5/t/lib/ph.t96
-rwxr-xr-xcontrib/perl5/t/lib/posix.t101
-rwxr-xr-xcontrib/perl5/t/lib/safe1.t68
-rwxr-xr-xcontrib/perl5/t/lib/safe2.t146
-rwxr-xr-xcontrib/perl5/t/lib/sdbm.t212
-rwxr-xr-xcontrib/perl5/t/lib/searchdict.t65
-rwxr-xr-xcontrib/perl5/t/lib/selectsaver.t28
-rwxr-xr-xcontrib/perl5/t/lib/socket.t76
-rwxr-xr-xcontrib/perl5/t/lib/soundex.t143
-rwxr-xr-xcontrib/perl5/t/lib/symbol.t52
-rwxr-xr-xcontrib/perl5/t/lib/texttabs.t28
-rwxr-xr-xcontrib/perl5/t/lib/textwrap.t40
-rwxr-xr-xcontrib/perl5/t/lib/thread.t73
-rwxr-xr-xcontrib/perl5/t/lib/tie-push.t24
-rwxr-xr-xcontrib/perl5/t/lib/tie-stdarray.t12
-rwxr-xr-xcontrib/perl5/t/lib/tie-stdpush.t10
-rwxr-xr-xcontrib/perl5/t/lib/timelocal.t90
-rwxr-xr-xcontrib/perl5/t/lib/trig.t160
-rwxr-xr-xcontrib/perl5/t/op/append.t21
-rwxr-xr-xcontrib/perl5/t/op/arith.t12
-rwxr-xr-xcontrib/perl5/t/op/array.t208
-rwxr-xr-xcontrib/perl5/t/op/assignwarn.t61
-rwxr-xr-xcontrib/perl5/t/op/auto.t52
-rwxr-xr-xcontrib/perl5/t/op/avhv.t110
-rwxr-xr-xcontrib/perl5/t/op/bop.t64
-rwxr-xr-xcontrib/perl5/t/op/chop.t87
-rwxr-xr-xcontrib/perl5/t/op/closure.t482
-rwxr-xr-xcontrib/perl5/t/op/cmp.t35
-rwxr-xr-xcontrib/perl5/t/op/cond.t12
-rwxr-xr-xcontrib/perl5/t/op/context.t18
-rwxr-xr-xcontrib/perl5/t/op/defins.t147
-rwxr-xr-xcontrib/perl5/t/op/delete.t51
-rwxr-xr-xcontrib/perl5/t/op/die.t43
-rwxr-xr-xcontrib/perl5/t/op/die_exit.t53
-rwxr-xr-xcontrib/perl5/t/op/do.t44
-rwxr-xr-xcontrib/perl5/t/op/each.t122
-rwxr-xr-xcontrib/perl5/t/op/eval.t81
-rwxr-xr-xcontrib/perl5/t/op/exec.t35
-rwxr-xr-xcontrib/perl5/t/op/exp.t27
-rwxr-xr-xcontrib/perl5/t/op/flip.t29
-rwxr-xr-xcontrib/perl5/t/op/fork.t26
-rwxr-xr-xcontrib/perl5/t/op/glob.t37
-rwxr-xr-xcontrib/perl5/t/op/goto.t90
-rwxr-xr-xcontrib/perl5/t/op/goto_xs.t98
-rwxr-xr-xcontrib/perl5/t/op/groups.t50
-rwxr-xr-xcontrib/perl5/t/op/gv.t98
-rwxr-xr-xcontrib/perl5/t/op/hashwarn.t71
-rwxr-xr-xcontrib/perl5/t/op/inc.t52
-rwxr-xr-xcontrib/perl5/t/op/index.t42
-rwxr-xr-xcontrib/perl5/t/op/int.t17
-rwxr-xr-xcontrib/perl5/t/op/join.t12
-rwxr-xr-xcontrib/perl5/t/op/list.t83
-rwxr-xr-xcontrib/perl5/t/op/local.t200
-rwxr-xr-xcontrib/perl5/t/op/magic.t209
-rwxr-xr-xcontrib/perl5/t/op/method.t128
-rwxr-xr-xcontrib/perl5/t/op/misc.t420
-rwxr-xr-xcontrib/perl5/t/op/mkdir.t18
-rwxr-xr-xcontrib/perl5/t/op/my.t94
-rwxr-xr-xcontrib/perl5/t/op/nothread.t35
-rwxr-xr-xcontrib/perl5/t/op/oct.t14
-rwxr-xr-xcontrib/perl5/t/op/ord.t18
-rwxr-xr-xcontrib/perl5/t/op/pack.t205
-rwxr-xr-xcontrib/perl5/t/op/pat.t597
-rwxr-xr-xcontrib/perl5/t/op/pos.t16
-rwxr-xr-xcontrib/perl5/t/op/push.t56
-rwxr-xr-xcontrib/perl5/t/op/quotemeta.t38
-rwxr-xr-xcontrib/perl5/t/op/rand.t348
-rwxr-xr-xcontrib/perl5/t/op/range.t48
-rw-r--r--contrib/perl5/t/op/re_tests485
-rwxr-xr-xcontrib/perl5/t/op/read.t19
-rwxr-xr-xcontrib/perl5/t/op/readdir.t25
-rwxr-xr-xcontrib/perl5/t/op/recurse.t86
-rwxr-xr-xcontrib/perl5/t/op/ref.t287
-rwxr-xr-xcontrib/perl5/t/op/regexp.t97
-rwxr-xr-xcontrib/perl5/t/op/regexp_noamp.t10
-rwxr-xr-xcontrib/perl5/t/op/repeat.t42
-rwxr-xr-xcontrib/perl5/t/op/runlevel.t317
-rwxr-xr-xcontrib/perl5/t/op/sleep.t8
-rwxr-xr-xcontrib/perl5/t/op/sort.t127
-rwxr-xr-xcontrib/perl5/t/op/splice.t34
-rwxr-xr-xcontrib/perl5/t/op/split.t113
-rwxr-xr-xcontrib/perl5/t/op/sprintf.t33
-rwxr-xr-xcontrib/perl5/t/op/stat.t252
-rwxr-xr-xcontrib/perl5/t/op/study.t69
-rwxr-xr-xcontrib/perl5/t/op/subst.t310
-rwxr-xr-xcontrib/perl5/t/op/substr.t211
-rwxr-xr-xcontrib/perl5/t/op/sysio.t194
-rwxr-xr-xcontrib/perl5/t/op/taint.t596
-rwxr-xr-xcontrib/perl5/t/op/tie.t155
-rwxr-xr-xcontrib/perl5/t/op/tiearray.t210
-rwxr-xr-xcontrib/perl5/t/op/tiehandle.t137
-rwxr-xr-xcontrib/perl5/t/op/time.t47
-rwxr-xr-xcontrib/perl5/t/op/undef.t56
-rwxr-xr-xcontrib/perl5/t/op/universal.t104
-rwxr-xr-xcontrib/perl5/t/op/unshift.t14
-rwxr-xr-xcontrib/perl5/t/op/vec.t27
-rwxr-xr-xcontrib/perl5/t/op/wantarray.t16
-rwxr-xr-xcontrib/perl5/t/op/write.t169
-rwxr-xr-xcontrib/perl5/t/pragma/constant.t141
-rwxr-xr-xcontrib/perl5/t/pragma/locale.t483
-rwxr-xr-xcontrib/perl5/t/pragma/overload.t698
-rw-r--r--contrib/perl5/t/pragma/strict-refs295
-rw-r--r--contrib/perl5/t/pragma/strict-subs279
-rw-r--r--contrib/perl5/t/pragma/strict-vars223
-rwxr-xr-xcontrib/perl5/t/pragma/strict.t93
-rwxr-xr-xcontrib/perl5/t/pragma/subs.t133
-rw-r--r--contrib/perl5/t/pragma/warn-1global151
-rwxr-xr-xcontrib/perl5/t/pragma/warning.t94
-rw-r--r--contrib/perl5/taint.c113
-rw-r--r--contrib/perl5/thrdvar.h192
-rw-r--r--contrib/perl5/thread.h234
-rw-r--r--contrib/perl5/thread.sym1
-rw-r--r--contrib/perl5/toke.c6097
-rw-r--r--contrib/perl5/universal.c218
-rw-r--r--contrib/perl5/unixish.h132
-rw-r--r--contrib/perl5/util.c2879
-rw-r--r--contrib/perl5/util.h8
-rw-r--r--contrib/perl5/utils/Makefile43
-rw-r--r--contrib/perl5/utils/c2ph.PL1403
-rw-r--r--contrib/perl5/utils/h2ph.PL636
-rw-r--r--contrib/perl5/utils/h2xs.PL905
-rw-r--r--contrib/perl5/utils/perlbug.PL1093
-rw-r--r--contrib/perl5/utils/perlcc.PL945
-rw-r--r--contrib/perl5/utils/perldoc.PL687
-rw-r--r--contrib/perl5/utils/pl2pm.PL389
-rw-r--r--contrib/perl5/utils/splain.PL49
-rwxr-xr-xcontrib/perl5/writemain.SH104
-rw-r--r--contrib/perl5/x2p/EXTERN.h17
-rw-r--r--contrib/perl5/x2p/INTERN.h17
-rwxr-xr-xcontrib/perl5/x2p/Makefile.SH181
-rw-r--r--contrib/perl5/x2p/a2p.c2731
-rw-r--r--contrib/perl5/x2p/a2p.h482
-rw-r--r--contrib/perl5/x2p/a2p.pod162
-rw-r--r--contrib/perl5/x2p/a2p.y399
-rw-r--r--contrib/perl5/x2p/a2py.c1284
-rwxr-xr-xcontrib/perl5/x2p/cflags.SH95
-rw-r--r--contrib/perl5/x2p/find2perl.PL627
-rw-r--r--contrib/perl5/x2p/hash.c232
-rw-r--r--contrib/perl5/x2p/hash.h52
-rw-r--r--contrib/perl5/x2p/proto.h8
-rw-r--r--contrib/perl5/x2p/s2p.PL848
-rw-r--r--contrib/perl5/x2p/str.c442
-rw-r--r--contrib/perl5/x2p/str.h53
-rw-r--r--contrib/perl5/x2p/util.c218
-rw-r--r--contrib/perl5/x2p/util.h39
-rw-r--r--contrib/perl5/x2p/walk.c2066
854 files changed, 352198 insertions, 0 deletions
diff --git a/contrib/perl5/Artistic b/contrib/perl5/Artistic
new file mode 100644
index 000000000000..5f221241e800
--- /dev/null
+++ b/contrib/perl5/Artistic
@@ -0,0 +1,131 @@
+
+
+
+
+ The "Artistic License"
+
+ Preamble
+
+The intent of this document is to state the conditions under which a
+Package may be copied, such that the Copyright Holder maintains some
+semblance of artistic control over the development of the package,
+while giving the users of the package the right to use and distribute
+the Package in a more-or-less customary fashion, plus the right to make
+reasonable modifications.
+
+Definitions:
+
+ "Package" refers to the collection of files distributed by the
+ Copyright Holder, and derivatives of that collection of files
+ created through textual modification.
+
+ "Standard Version" refers to such a Package if it has not been
+ modified, or has been modified in accordance with the wishes
+ of the Copyright Holder as specified below.
+
+ "Copyright Holder" is whoever is named in the copyright or
+ copyrights for the package.
+
+ "You" is you, if you're thinking about copying or distributing
+ this Package.
+
+ "Reasonable copying fee" is whatever you can justify on the
+ basis of media cost, duplication charges, time of people involved,
+ and so on. (You will not be required to justify it to the
+ Copyright Holder, but only to the computing community at large
+ as a market that must bear the fee.)
+
+ "Freely Available" means that no fee is charged for the item
+ itself, though there may be fees involved in handling the item.
+ It also means that recipients of the item may redistribute it
+ under the same conditions they received it.
+
+1. You may make and give away verbatim copies of the source form of the
+Standard Version of this Package without restriction, provided that you
+duplicate all of the original copyright notices and associated disclaimers.
+
+2. You may apply bug fixes, portability fixes and other modifications
+derived from the Public Domain or from the Copyright Holder. A Package
+modified in such a way shall still be considered the Standard Version.
+
+3. You may otherwise modify your copy of this Package in any way, provided
+that you insert a prominent notice in each changed file stating how and
+when you changed that file, and provided that you do at least ONE of the
+following:
+
+ a) place your modifications in the Public Domain or otherwise make them
+ Freely Available, such as by posting said modifications to Usenet or
+ an equivalent medium, or placing the modifications on a major archive
+ site such as uunet.uu.net, or by allowing the Copyright Holder to include
+ your modifications in the Standard Version of the Package.
+
+ b) use the modified Package only within your corporation or organization.
+
+ c) rename any non-standard executables so the names do not conflict
+ with standard executables, which must also be provided, and provide
+ a separate manual page for each non-standard executable that clearly
+ documents how it differs from the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+4. You may distribute the programs of this Package in object code or
+executable form, provided that you do at least ONE of the following:
+
+ a) distribute a Standard Version of the executables and library files,
+ together with instructions (in the manual page or equivalent) on where
+ to get the Standard Version.
+
+ b) accompany the distribution with the machine-readable source of
+ the Package with your modifications.
+
+ c) give non-standard executables non-standard names, and clearly
+ document the differences in manual pages (or equivalent), together
+ with instructions on where to get the Standard Version.
+
+ d) make other distribution arrangements with the Copyright Holder.
+
+5. You may charge a reasonable copying fee for any distribution of this
+Package. You may charge any fee you choose for support of this
+Package. You may not charge a fee for this Package itself. However,
+you may distribute this Package in aggregate with other (possibly
+commercial) programs as part of a larger (possibly commercial) software
+distribution provided that you do not advertise this Package as a
+product of your own. You may embed this Package's interpreter within
+an executable of yours (by linking); this shall be construed as a mere
+form of aggregation, provided that the complete Standard Version of the
+interpreter is so embedded.
+
+6. The scripts and library files supplied as input to or produced as
+output from the programs of this Package do not automatically fall
+under the copyright of this Package, but belong to whoever generated
+them, and may be sold commercially, and may be aggregated with this
+Package. If such scripts or library files are aggregated with this
+Package via the so-called "undump" or "unexec" methods of producing a
+binary executable image, then distribution of such an image shall
+neither be construed as a distribution of this Package nor shall it
+fall under the restrictions of Paragraphs 3 and 4, provided that you do
+not represent such an executable image as a Standard Version of this
+Package.
+
+7. C subroutines (or comparably compiled subroutines in other
+languages) supplied by you and linked into this Package in order to
+emulate subroutines and variables of the language defined by this
+Package shall not be considered part of this Package, but are the
+equivalent of input as in Paragraph 6, provided these subroutines do
+not change the language in any way that would cause it to fail the
+regression tests for the language.
+
+8. Aggregation of this Package with a commercial distribution is always
+permitted provided that the use of this Package is embedded; that is,
+when no overt attempt is made to make this Package's interfaces visible
+to the end user of the commercial distribution. Such use shall not be
+construed as a distribution of this Package.
+
+9. The name of the Copyright Holder may not be used to endorse or promote
+products derived from this software without specific prior written permission.
+
+10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
+ The End
diff --git a/contrib/perl5/Changes b/contrib/perl5/Changes
new file mode 100644
index 000000000000..325ffeb6a560
--- /dev/null
+++ b/contrib/perl5/Changes
@@ -0,0 +1,15896 @@
+Please note: This file provides a summary of significant changes
+between versions and sub-versions of Perl, not necessarily a complete
+list of each modification. If you'd like more detailed information,
+please consult the comments in the patches on which the relevant
+release of Perl is based. (Patches can be found on any CPAN
+site, in the .../src/5.0 directory for full version releases,
+or in the .../src/5/0/unsupported directory for sub-version
+releases.)
+
+
+ ---------------
+ CAST AND CREW
+ ---------------
+
+To give due honor to those who have made Perl what is is today,
+here are some of the more common names in the Changes file, and their
+current addresses (as of July 1998):
+
+ Gisle Aas <gisle@aas.no>
+ Abigail <abigail@fnx.com>
+ Kenneth Albanowski <kjahds@kjahds.com>
+ Russ Allbery <rra@stanford.edu>
+ Graham Barr <gbarr@ti.com>
+ Spider Boardman <spider@orb.nashua.nh.us>
+ Tom Christiansen <tchrist@perl.com>
+ Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
+ M. J. T. Guy <mjtg@cus.cam.ac.uk>
+ Jarkko Hietaniemi <jhi@iki.fi>
+ Nick Ing-Simmons <nik@tiuk.ti.com>
+ Andreas Koenig <a.koenig@mind.de>
+ Doug MacEachern <dougm@opengroup.org>
+ Paul Marquess <pmarquess@bfsec.bt.co.uk>
+ Stephen McCamant <alias@mcs.com>
+ Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Hans Mulder <hansmu@xs4all.nl>
+ Matthias Neeracher <neeri@iis.ee.ethz.ch>
+ Jeff Okamoto <okamoto@hpcc123.corp.hp.com>
+ Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
+ Tom Phoenix <rootbeer@teleport.com>
+ Joshua Pritikin <joshua.pritikin@db.com>
+ Norbert Pueschel <pueschel@imsdd.meb.uni-bonn.de>
+ Dean Roehrich <roehrich@cray.com>
+ Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Roderick Schertler <roderick@argon.org>
+ Kurt D. Starsinic <kstar@chapin.edu>
+ Dan Sugalski <sugalskd@osshe.edu>
+ Larry W. Virden <lvirden@cas.org>
+ Ilya Zakharevich <ilya@math.ohio-state.edu>
+
+And the Keepers of the Patch Pumpkin:
+
+ Charles Bailey <bailey@hmivax.humgen.upenn.edu>
+ Malcolm Beattie <mbeattie@sable.ox.ac.uk>
+ Tim Bunce <Tim.Bunce@ig.co.uk>
+ Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Gurusamy Sarathy <gsar@engin.umich.edu>
+ Chip Salzenberg <chip@perl.com>
+
+And, of course, the Author of Perl:
+
+ Larry Wall <larry@wall.org>
+
+
+NOTE: Each change entry shows the change number; who checked it into the
+repository; when; description of the change; which branch the change
+happened in; and the affected files. The file lists have a short symbolic
+indicator:
+
+ ! modified
+ + added
+ - deleted
+ +> branched (from elsewhere)
+ !> merged changes (from elsewhere)
+
+
+----------------
+Version 5.005_02 Second maintenance release of 5.005
+----------------
+
+____________________________________________________________________________
+[ 1758] By: gsar on 1998/08/08 03:45:04
+ Log: set patchlevel.h, other minor tweaks
+ Branch: maint-5.005/perl
+ ! Changes patchlevel.h pod/perlhist.pod pod/perlport.pod
+____________________________________________________________________________
+[ 1757] By: gsar on 1998/08/08 03:33:33
+ Log: prevent lexical leaks from Benchmark into target code (inspired by
+ an attempt by John Allen)
+ Branch: maint-5.005/perl
+ ! lib/Benchmark.pm
+____________________________________________________________________________
+[ 1755] By: gsar on 1998/08/07 23:58:33
+ Log: temporary opcode.pl workaround for ebcdic (suggested by
+ David J. Fiander <davidf@mks.com> and M.J.T. Guy)
+ Branch: maint-5.005/perl
+ ! opcode.pl
+____________________________________________________________________________
+[ 1754] By: gsar on 1998/08/07 22:21:10
+ Log: From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Date: Fri, 7 Aug 1998 09:56:01 +0100 (BST)
+ Message-Id: <9808070856.AA28065@claudius.bfsec.bt.co.uk>
+ Subject: [PATCH 5.005_50 & 5.005_02] Fix for command line use of source filters
+ Branch: maint-5.005/perl
+ ! perl.c
+____________________________________________________________________________
+[ 1753] By: gsar on 1998/08/07 22:19:42
+ Log: perlport.pod notes from Jarkko Hietaniemi; utime() note for Win32
+ Branch: maint-5.005/perl
+ ! pod/perlport.pod
+____________________________________________________________________________
+[ 1752] By: gsar on 1998/08/07 22:08:29
+ Log: perlport.pod v1.33 from Chris Nandor <pudge@pobox.com>
+ Branch: maint-5.005/perl
+ ! pod/perlport.pod
+____________________________________________________________________________
+[ 1751] By: gsar on 1998/08/07 22:01:04
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Thu, 6 Aug 1998 19:44:16 -0400 (EDT)
+ Message-Id: <199808062344.TAA09505@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.005_*] Minor cleanup of RE tests and docs
+ Branch: maint-5.005/perl
+ ! pod/perlre.pod t/op/regexp.t
+____________________________________________________________________________
+[ 1750] By: gsar on 1998/08/07 21:51:52
+ Log: allow more compatible interpretation of spaces File::DosGlob::glob()
+ patterns
+ Branch: maint-5.005/perl
+ ! lib/File/DosGlob.pm
+____________________________________________________________________________
+[ 1749] By: gsar on 1998/08/07 21:36:04
+ Log: don't use © in Test.pm (suggested by M.J.T. Guy)
+ Branch: maint-5.005/perl
+ ! lib/Test.pm
+____________________________________________________________________________
+[ 1748] By: gsar on 1998/08/07 21:31:46
+ Log: From: Dominic Dunlop <domo@computer.org>
+ Date: Thu, 6 Aug 1998 12:38:07 +0000
+ Message-Id: <v03110702b1ef5274635a@[195.95.102.104]>
+ Subject: [Patch perl5.005_02-TRIAL2] Update hints, Configure for MachTen 4.1.1
+ Branch: maint-5.005/perl
+ ! Configure hints/machten.sh
+____________________________________________________________________________
+[ 1746] By: gsar on 1998/08/05 22:55:59
+ Log: MM_Win32.pm and Liblist.pm tweaks
+ Branch: maint-5.005/perl
+ ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Win32.pm
+____________________________________________________________________________
+[ 1745] By: gsar on 1998/08/05 21:57:00
+ Log: pod/perlfaq* update from Tom Christiansen <tchrist@perl.com>
+ Branch: maint-5.005/perl
+ ! pod/perlfaq.pod pod/perlfaq1.pod pod/perlfaq2.pod
+ ! pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq8.pod
+____________________________________________________________________________
+[ 1744] By: gsar on 1998/08/05 21:53:30
+ Log: From: Chris Nandor <pudge@pobox.com>
+ Date: Wed, 5 Aug 1998 15:38:48 -0400
+ Message-Id: <v04011701b1ee58b86c63@[192.168.0.3]>
+ Subject: [PATCH] perlport 1.32
+ Branch: maint-5.005/perl
+ ! pod/perlport.pod
+____________________________________________________________________________
+[ 1743] By: gsar on 1998/08/05 21:52:05
+ Log: README.os2 update
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Wed, 5 Aug 1998 05:44:46 -0400 (EDT)
+ Message-Id: <199808050944.FAA09053@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.005_*] Additional OS/2 tweaks: docs, tests
+ Branch: maint-5.005/perl
+ ! README.os2 t/lib/posix.t t/op/exec.t
+____________________________________________________________________________
+[ 1742] By: gsar on 1998/08/05 21:50:07
+ Log: additional INSTALL notes from Jarkko Hietaniemi <jhi@cc.hut.fi>
+ on semget failure in t/lib/ipc_sysv.t
+ Branch: maint-5.005/perl
+ ! INSTALL
+____________________________________________________________________________
+[ 1741] By: gsar on 1998/08/05 21:46:13
+ Log: correct URL for perlcrt.dll
+ Branch: maint-5.005/perl
+ ! Changes win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1740] By: gsar on 1998/08/05 10:05:46
+ Log: update Changes, patchlevel, tweak Liblist.pm
+ Branch: maint-5.005/perl
+ ! Changes lib/ExtUtils/Liblist.pm patchlevel.h
+____________________________________________________________________________
+[ 1739] By: gsar on 1998/08/05 09:10:45
+ Log: newer cperl-mode.el
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Wed, 5 Aug 1998 03:50:16 -0400 (EDT)
+ Message-Id: <199808050750.DAA07240@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.005_*] CPerl update
+ Branch: maint-5.005/perl
+ ! emacs/cperl-mode.el
+____________________________________________________________________________
+[ 1738] By: gsar on 1998/08/05 09:08:33
+ Log: support :nosearch in ExtUtils::Liblist for win32, and make -lfoo
+ processing (somewhat) compiler-specific
+ Branch: maint-5.005/perl
+ ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Win32.pm
+____________________________________________________________________________
+[ 1737] By: gsar on 1998/08/05 03:20:03
+ Log: add index entries for -X
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 02 Aug 1998 16:33:18 EDT
+ Message-Id: <199808022033.QAA18778@monk.mps.ohio-state.edu>
+ Subject: [PATCH] A missing docu patch
+ Branch: maint-5.005/perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 1736] By: gsar on 1998/08/05 03:09:58
+ Log: make Test::Harness optionally check for stray files when running tests
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 2 Aug 1998 18:12:48 -0400 (EDT)
+ Message-Id: <199808022212.SAA20126@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.005_*] File leaked from test suite
+ Branch: maint-5.005/perl
+ ! lib/Test/Harness.pm
+____________________________________________________________________________
+[ 1735] By: gsar on 1998/08/05 02:29:46
+ Log: back out change#1703 that break bincompat with PERL_OBJECT and
+ MULTIPLICITY
+ Branch: maint-5.005/perl
+ ! ext/re/re.pm regcomp.c regexec.c thrdvar.h
+____________________________________________________________________________
+[ 1734] By: gsar on 1998/08/05 02:23:47
+ Log: fixes to enable ISC to build IPC/SysV
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Date: 05 Aug 1998 00:59:13 +0300
+ Message-ID: <oee3ebce7da.fsf@alpha.hut.fi>
+ Subject: [PATCH] 5.005_02-TRIAL1: (Re: Bug in pp_rename and ISC hint)
+ Branch: maint-5.005/perl
+ ! ext/IPC/SysV/SysV.xs hints/isc.sh hints/isc_2.sh
+____________________________________________________________________________
+[ 1733] By: gsar on 1998/08/05 01:20:29
+ Log: let some 'tr' be '$tr' for occult reasons
+ From: Jeff Okamoto <okamoto@xfiles.intercon.hp.com>
+ Date: Mon, 3 Aug 1998 11:04:30 -0700 (PDT)
+ Message-Id: <199808031804.LAA25595@xfiles.intercon.hp.com>
+ Subject: PATCH: Configure uses tr, not $tr
+ Branch: maint-5.005/perl
+ ! Configure
+____________________________________________________________________________
+[ 1732] By: gsar on 1998/08/05 01:16:40
+ Log: perlre.pod tweak suggested by Mike Wescott <mike.wescott@columbiasc.ncr.com>
+ Branch: maint-5.005/perl
+ ! pod/perlre.pod
+____________________________________________________________________________
+[ 1731] By: gsar on 1998/08/05 01:10:41
+ Log: explain caveat about use of numeric constants in podoc for sysopen()
+ From: "David J. Fiander" <davidf@mks.com>
+ Date: Tue, 4 Aug 1998 13:09:58 -0400
+ Message-Id: <199808041709.NAA01750@mks.com>
+ Subject: Re: [PATCH] 5.005_01: OE MVS
+ Branch: maint-5.005/perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 1730] By: gsar on 1998/08/05 00:46:53
+ Log: end pod processing when source file is closed (prevents it carrying
+ over into require()d files)
+ Branch: maint-5.005/perl
+ ! t/comp/require.t toke.c
+____________________________________________________________________________
+[ 1729] By: gsar on 1998/08/04 23:03:23
+ Log: correct prototype for des_fcrypt(), explain how to add it in more
+ detail, and supply a patch for libdes-3.06
+ Branch: maint-5.005/perl
+ + win32/des_fcrypt.patch
+ ! MANIFEST README.win32 win32/Makefile win32/makefile.mk
+ ! win32/win32.c
+____________________________________________________________________________
+[ 1728] By: gsar on 1998/08/04 21:50:40
+ Log: tweak to avoid ambiguity warnings
+ Branch: maint-5.005/perl
+ ! pp.c
+____________________________________________________________________________
+[ 1727] By: gsar on 1998/08/04 20:31:04
+ Log: remove useless 'rcsid' (extension of a suggestion by
+ Stephen McCamant)
+ Branch: maint-5.005/perl
+ ! embed.h ext/SDBM_File/sdbm/pair.c ext/SDBM_File/sdbm/sdbm.c
+ ! global.sym gv.c perl.c vms/gen_shrfls.pl
+____________________________________________________________________________
+[ 1726] By: gsar on 1998/08/04 19:52:43
+ Log: correct Pod::Html's notion of email addresses
+ From: abigail@fnx.com
+ Date: Mon, 3 Aug 1998 20:22:49 -0400 (EDT)
+ Message-ID: <19980804002249.2011.qmail@betelgeuse.wayne.fnx.com>
+ Subject: [PATCH 5.005_01] lib/Pod/Html.pm
+ Branch: maint-5.005/perl
+ ! lib/Pod/Html.pm
+____________________________________________________________________________
+[ 1725] By: gsar on 1998/08/04 19:50:06
+ Log: perlport.pod additions from Peter Prymmer <pvhp@forte.com>
+ Date: Mon, 3 Aug 98 15:31:35 PDT
+ Message-Id: <9808032231.AA22324@forte.com>
+ --
+ Date: Tue, 4 Aug 98 12:44:20 PDT
+ Message-Id: <9808041944.AA04815@forte.com>
+ Branch: maint-5.005/perl
+ ! pod/perlport.pod
+____________________________________________________________________________
+[ 1724] By: gsar on 1998/08/04 18:08:07
+ Log: From: Chris Nandor <pudge@pobox.com>
+ Date: Mon, 3 Aug 1998 13:35:25 -0400
+ Message-Id: <v04011711b1eba46d0827@[192.168.0.3]>
+ Subject: [PATCH] perlport 1.30
+ Branch: maint-5.005/perl
+ ! pod/perlport.pod
+____________________________________________________________________________
+[ 1723] By: gsar on 1998/08/04 18:06:13
+ Log: update postscript generator
+ From: Tom Christiansen <tchrist@chthon.perl.com>
+ Date: Mon, 3 Aug 1998 05:29:25 -0600
+ Message-Id: <199808031129.FAA24985@chthon.perl.com>
+ Subject: PATCH: pod/roffitall (5.005_02)
+ Branch: maint-5.005/perl
+ ! pod/roffitall
+____________________________________________________________________________
+[ 1722] By: gsar on 1998/08/03 17:01:12
+ Log: applied suggested patch, slightly tweaked
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Date: Mon, 3 Aug 1998 11:52:30 +0300 (EET DST)
+ Message-Id: <199808030852.LAA14153@alpha.hut.fi>
+ Subject: [PATCH] perl5.005_02-TRIAL1: pod/perlhist.pod
+ Branch: maint-5.005/perl
+ ! pod/perlhist.pod
+____________________________________________________________________________
+[ 1721] By: gsar on 1998/08/03 16:30:20
+ Log: fix segfault when threadsv is used as foreach itervar
+ From: Stephen McCamant <alias@mcs.com>
+ Date: Sun, 02 Aug 1998 21:44:34 CDT
+ Message-Id: <13765.8641.997452.14516@alias-2.pr.mcs.net>
+ Subject: [PATCH] threadsv index in enteriter targ in op_free()
+ Branch: maint-5.005/perl
+ ! op.c
+____________________________________________________________________________
+[ 1720] By: gsar on 1998/08/02 23:33:42
+ Log: close() open files before unlink()
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 2 Aug 1998 18:14:22 -0400 (EDT)
+ Message-Id: <199808022214.SAA20135@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.005_*] File leaked from test suite - tests
+ Branch: maint-5.005/perl
+ ! t/base/rs.t t/op/defins.t
+____________________________________________________________________________
+[ 1719] By: gsar on 1998/08/02 23:31:51
+ Log: more pack() tests
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Mon, 3 Aug 1998 00:59:41 +0300 (EET DST)
+ Message-Id: <199808022159.AAA17160@alpha.hut.fi>
+ Subject: Re: uudecode 'u' problem
+ Branch: maint-5.005/perl
+ ! t/op/pack.t
+____________________________________________________________________________
+[ 1718] By: gsar on 1998/08/02 23:26:51
+ Log: t/TEST aesthetic tweak suggested by Jarkko
+ Branch: maint-5.005/perl
+ ! t/TEST
+____________________________________________________________________________
+[ 1717] By: gsar on 1998/08/02 23:23:43
+ Log: add Digital Unix 3.x notes to README.threads (as suggested by
+ Phoenix <awrobel@jedi.cis.temple.edu>)
+ Branch: maint-5.005/perl
+ ! README.threads
+____________________________________________________________________________
+[ 1716] By: gsar on 1998/08/02 23:15:00
+ Log: allow *FOO{BAR}[0] etc. (without intervening arrow)
+ From: Stephen McCamant <alias@mcs.com>
+ Date: Sun, 2 Aug 1998 16:16:50 -0500 (CDT)
+ Message-ID: <13764.54929.60137.104838@alias-2.pr.mcs.net>
+ Subject: [PATCH] Re: Minor nit in glob notation
+ Branch: maint-5.005/perl
+ ! Changes op.c
+____________________________________________________________________________
+[ 1715] By: gsar on 1998/08/02 22:49:53
+ Log: fix unpack('u',...) problem with spaces in input
+ Branch: maint-5.005/perl
+ ! pp.c t/op/pack.t
+____________________________________________________________________________
+[ 1714] By: gsar on 1998/08/02 21:27:19
+ Log: update location of perlcrt.dll for win32 builds
+ Branch: maint-5.005/perl
+ ! win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1713] By: gsar on 1998/08/02 09:28:32
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 2 Aug 1998 04:35:11 -0400 (EDT)
+ Message-Id: <199808020835.EAA09367@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.005_*] Better debugging output from malloc.c
+ Branch: maint-5.005/perl
+ ! malloc.c
+____________________________________________________________________________
+[ 1712] By: gsar on 1998/08/02 09:16:55
+ Log: fix longstanding bug in pack('u',...) (reads garbage beyond the end
+ of the input string)
+ Branch: maint-5.005/perl
+ ! pp.c
+____________________________________________________________________________
+[ 1711] By: gsar on 1998/08/02 08:14:25
+ Log: update Changes, tweak Porting/makerel
+ Branch: maint-5.005/perl
+ ! Changes Porting/makerel
+____________________________________________________________________________
+[ 1710] By: gsar on 1998/08/02 07:31:37
+ Log: remove CRs from djgpp/configure.bat (Porting/makerel adds them)
+ Branch: maint-5.005/perl
+ ! djgpp/configure.bat
+____________________________________________________________________________
+[ 1709] By: gsar on 1998/08/02 07:27:34
+ Log: Porting/makerel tweaks
+ Branch: maint-5.005/perl
+ ! Porting/makerel
+____________________________________________________________________________
+[ 1708] By: gsar on 1998/08/02 07:09:35
+ Log: fixes for pod noises
+ Branch: maint-5.005/perl
+ ! ext/B/B/Bytecode.pm ext/Thread/Thread/Specific.pm
+ ! pod/perlembed.pod pod/perlfaq.pod
+____________________________________________________________________________
+[ 1707] By: gsar on 1998/08/02 06:59:47
+ Log: malloc.c tweaks
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sat, 01 Aug 1998 18:46:32 EDT
+ Message-Id: <199808012246.SAA00699@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.005_*] Better malloc.c
+ Branch: maint-5.005/perl
+ ! malloc.c
+____________________________________________________________________________
+[ 1706] By: gsar on 1998/08/02 06:56:37
+ Log: fix quoting of keys with embedded nulls
+ From: Slaven Rezic <eserte@cs.tu-berlin.de>
+ Date: Sat, 01 Aug 1998 13:38:03 +0200
+ Message-Id: <199808011138.NAA05189@mail.cs.tu-berlin.de>
+ Subject: Data::Dumper 2.09, patch
+ Branch: maint-5.005/perl
+ ! ext/Data/Dumper/Dumper.xs
+____________________________________________________________________________
+[ 1705] By: gsar on 1998/08/02 06:50:07
+ Log: From: pvhp@forte.com (Peter Prymmer)
+ Date: Fri, 31 Jul 1998 14:50:41 PDT
+ Message-Id: <9807312150.AA08867@forte.com>
+ Subject: Re: \Q doesn't work in interpolated regular expressions
+ Branch: maint-5.005/perl
+ ! pod/perlre.pod
+____________________________________________________________________________
+[ 1704] By: gsar on 1998/08/02 06:37:06
+ Log: add test for magic autovivification
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Date: Thu, 30 Jul 1998 12:18:15 +0100
+ Message-Id: <E0z1qit-0003O5-00@taurus.cus.cam.ac.uk>
+ Subject: Re: Perl5.005_01 failing to autovivify subroutine args
+ Branch: maint-5.005/perl
+ ! pod/perldiag.pod t/cmd/subval.t
+____________________________________________________________________________
+[ 1703] By: gsar on 1998/08/02 06:26:57
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 21 Jul 1998 23:58:53 -0400 (EDT)
+ Message-Id: <199807220358.XAA19811@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_76] better RE colors
+ Branch: maint-5.005/perl
+ ! ext/re/re.pm regcomp.c regexec.c thrdvar.h
+____________________________________________________________________________
+[ 1702] By: gsar on 1998/08/02 06:22:15
+ Log: mark link type of exported functions for OS/2
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 26 Jul 1998 21:03:03 -0400 (EDT)
+ Message-Id: <199807270103.VAA04977@monk.mps.ohio-state.edu>
+ Subject: Re: Compiler linkage's types [PATCH 5.005]
+ Branch: maint-5.005/perl
+ ! os2/os2ish.h proto.h
+____________________________________________________________________________
+[ 1701] By: gsar on 1998/08/02 06:16:03
+ Log: tweaked version of suggested patch
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 20 Jul 1998 21:40:00 -0400 (EDT)
+ Message-Id: <199807210140.VAA17186@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_75] Enable -DS
+ Branch: maint-5.005/perl
+ ! README.threads ext/Thread/Thread.xs ext/Thread/typemap mg.c
+ ! op.c perl.c perl.h pod/perlrun.pod pp.c pp_hot.c scope.c
+ ! thread.h util.c win32/win32thread.c
+____________________________________________________________________________
+[ 1700] By: gsar on 1998/08/02 05:54:00
+ Log: up patchlevel to 5.005_02
+ Branch: maint-5.005/perl
+ ! Changes patchlevel.h win32/Makefile win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1699] By: gsar on 1998/08/02 05:50:01
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199807180809.EAA09379@monk.mps.ohio-state.edu>
+ Date: Sat, 18 Jul 1998 04:09:26 -0400 (EDT)
+ Subject: [PATCH 5.004_72] Make tests succeed on OS/2
+ Branch: maint-5.005/perl
+ ! t/io/fs.t t/lib/io_pipe.t t/lib/io_sock.t t/op/stat.t
+____________________________________________________________________________
+[ 1698] By: gsar on 1998/08/02 05:41:41
+ Log: use I32_MAX as the limit when U16_MAX > I32_MAX (for CRAY)
+ Branch: maint-5.005/perl
+ ! regcomp.c
+____________________________________________________________________________
+[ 1697] By: gsar on 1998/08/02 05:20:12
+ Log: support OE/MVS
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Message-Id: <199808010903.MAA09371@alpha.hut.fi>
+ Date: Sat, 1 Aug 1998 12:03:02 +0300 (EET DST)
+ Subject: [PATCH] 5.005_01: OE MVS
+ Branch: maint-5.005/perl
+ + README.os390 ebcdic.c
+ ! Configure MANIFEST doio.c ext/Errno/Errno_pm.PL gv.c handy.h
+ ! hints/os390.sh lib/bigint.pl mg.c patchlevel.h perl.c perl.h
+ ! perly.c perly.h perly.y perly_c.diff pod/perldelta.pod
+ ! pod/perlport.pod pp.c pp_ctl.c pp_hot.c pp_sys.c sv.c
+ ! t/base/term.t t/comp/package.t t/comp/require.t
+ ! t/lib/bigintpm.t t/lib/cgi-html.t t/lib/filehand.t t/lib/ph.t
+ ! t/op/auto.t t/op/bop.t t/op/each.t t/op/magic.t t/op/misc.t
+ ! t/op/ord.t t/op/pack.t t/op/quotemeta.t t/op/re_tests
+ ! t/op/regexp.t t/op/sort.t t/op/sprintf.t t/op/subst.t
+ ! t/op/taint.t t/op/universal.t t/pragma/constant.t
+ ! t/pragma/overload.t t/pragma/subs.t toke.c x2p/a2p.h
+ ! x2p/a2py.c
+____________________________________________________________________________
+[ 1696] By: gsar on 1998/08/02 05:03:09
+ Log: VMS patches
+ From: pvhp@forte.com (Peter Prymmer)
+ Message-Id: <9807290017.AA01833@forte.com>
+ Date: Tue, 28 Jul 98 17:17:33 PDT
+ Subject: Re: Not OK: perl 5.00501 on VMS_AXP-thread I7.2
+ --
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Message-Id: <3.0.5.32.19980729125623.00b562b0@ous.edu>
+ Date: Wed, 29 Jul 1998 12:56:23 -0700
+ Subject: [PATCH 5.005_01]Typo in CONFIGURE.COM (vms)
+ --
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Date: Thu, 30 Jul 1998 09:02:24 -0700
+ Message-Id: <3.0.5.32.19980730090224.00b70eb0@ous.edu>
+ Subject: [PATCH 5.005_01]VMS config SOCKETSHR typo patch and fcntl check
+ Branch: maint-5.005/perl
+ ! configure.com vms/subconfigure.com
+____________________________________________________________________________
+[ 1695] By: gsar on 1998/08/02 04:49:32
+ Log: rename duplicate warning in regexec.c
+ Branch: maint-5.005/perl
+ ! regexec.c
+____________________________________________________________________________
+[ 1694] By: gsar on 1998/08/02 04:44:20
+ Log: beware egcs' ld on Solaris
+ From: Tom Spindler <dogcow@home.merit.edu>
+ Message-ID: <19980801212158.A2934@home.merit.edu>
+ Date: Sat, 1 Aug 1998 21:21:58 -0400
+ Subject: Re: [PATCH perl5.005_01] hints/solaris_2.sh, egcs, and ld
+ Branch: maint-5.005/perl
+ ! hints/solaris_2.sh
+____________________________________________________________________________
+[ 1693] By: gsar on 1998/08/02 04:41:43
+ Log: de-utf-ized variation of Ilya's patch
+ From: Jan-Pieter Cornet <johnpc@xs4all.net>
+ Date: 31 Jul 1998 12:44:57 +0200
+ Message-ID: <6ps779$hmj$1@xs1.xs4all.nl>
+ Subject: Re: s/\s*$//g in majordomo causes segfault under 5.005_01
+ Branch: maint-5.005/perl
+ ! regexec.c
+____________________________________________________________________________
+[ 1692] By: gsar on 1998/08/02 04:39:14
+ Log: better validation of SysV IPC availability
+ From: Jarkko Hietaniemi <jarkko.hietaniemi@research.nokia.com>
+ Date: Fri, 31 Jul 1998 13:13:57 +0300 (EEST)
+ Message-Id: <199807311013.NAA28887@koah.research.nokia.com>
+ Subject: Re: lib/ipc_sysv.t fails under FreeBSD 2.2.1
+ Branch: maint-5.005/perl
+ ! Configure INSTALL ext/IPC/SysV/SysV.xs pod/perldiag.pod
+ ! t/lib/ipc_sysv.t
+____________________________________________________________________________
+[ 1691] By: gsar on 1998/08/02 04:32:30
+ Log: fix bug in display of watched expressions
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Thu, 30 Jul 1998 20:02:04 -0400 (EDT)
+ Message-Id: <199807310002.UAA21681@monk.mps.ohio-state.edu>
+ Subject: Re: Bug? in perl5db.pl [PATCH]
+ Branch: maint-5.005/perl
+ ! lib/perl5db.pl
+____________________________________________________________________________
+[ 1690] By: gsar on 1998/08/02 04:29:08
+ Log: applied all but one hunk
+ From: Horst von Brand <vonbrand@sleipnir.valparaiso.cl>
+ Date: Thu, 30 Jul 1998 17:19:42 -0400
+ Message-Id: <199807302119.RAA06852@sleipnir.valparaiso.cl>
+ Subject: Some typos in perldelta.pod
+ Branch: maint-5.005/perl
+ ! pod/perldelta.pod
+____________________________________________________________________________
+[ 1689] By: gsar on 1998/08/02 04:27:02
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Thu, 30 Jul 1998 10:22:36 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980730101627.17514B-100000@newton.phys>
+ Subject: [PATCH 5.005_05] Remove redundant dTHR
+ Branch: maint-5.005/perl
+ ! mg.c sv.c
+____________________________________________________________________________
+[ 1688] By: gsar on 1998/08/02 04:25:49
+ Log: From: Tom Hughes <thh@cyberscience.com>
+ Date: 30 Jul 1998 09:47:31 +0100
+ Message-ID: <yek1zr3vi70.fsf@elva.cyberscience.com>
+ Subject: Class::Struct has an incomplete tied array package
+ Branch: maint-5.005/perl
+ ! lib/Class/Struct.pm
+____________________________________________________________________________
+[ 1687] By: gsar on 1998/08/02 04:21:48
+ Log: ensure implicit close on local(*FH) doesn't affect $! and thence $?
+ Branch: maint-5.005/perl
+ ! sv.c t/op/die_exit.t
+____________________________________________________________________________
+[ 1686] By: gsar on 1998/08/02 03:57:28
+ Log: From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Thu, 30 Jul 1998 00:39:30 +0300 (EET DST)
+ Message-Id: <199807292139.AAA01795@alpha.hut.fi>
+ Subject: Re: [PATCH] 5.004_05-MAINT_TRIAL_5: three locale fixes
+ Branch: maint-5.005/perl
+ ! ext/POSIX/POSIX.xs pod/perllocale.pod
+____________________________________________________________________________
+[ 1685] By: gsar on 1998/08/02 03:54:15
+ Log: PERL_OBJECT bincompat fixes from Douglas Lankshear <dougl@ActiveState.com>
+ Date: Wed, 29 Jul 1998 10:45:31 -0700
+ Message-ID: <000101bdbb18$ae767550$a32fa8c0@tau.Active>
+ Subject: [PATCH 5.005_01] Fixes binary compatibility for PERL_OBJECT
+ --
+ Date: Sat, 1 Aug 1998 09:33:19 -0700
+ Message-ID: <000701bdbd6a$17ada180$a32fa8c0@tau.Active>
+ Subject: [PATCH 5.005_01]
+ Branch: maint-5.005/perl
+ ! perl.h proto.h
+____________________________________________________________________________
+[ 1684] By: gsar on 1998/08/02 03:49:33
+ Log: hand-apply whitespace-mutiliated patch
+ From: Nicholas Clark <nick@flirble.org>
+ Date: Tue, 28 Jul 1998 16:40:42 +0100 (BST)
+ Message-Id: <199807281540.QAA04640@flirble.org>
+ Subject: [PATCH] POSIX::ELOOP
+ Branch: maint-5.005/perl
+ ! ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs
+____________________________________________________________________________
+[ 1683] By: gsar on 1998/08/02 03:45:26
+ Log: document return values of do() better
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Date: Tue, 28 Jul 1998 12:44:36 +0100
+ Message-Id: <E0z18BI-0003cH-00@taurus.cus.cam.ac.uk>
+ Subject: [PATCH] Re: Obscurity of lexicals with do ""
+ Branch: maint-5.005/perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 1682] By: gsar on 1998/08/02 03:42:26
+ Log: avoid reusing foreach itervar if magic got tacked onto it
+ From: Stephen McCamant <alias@mcs.com>
+ Date: Tue, 28 Jul 1998 22:18:25 -0500 (CDT)
+ Message-ID: <13758.36756.215424.719750@alias-2.pr.mcs.net>
+ Subject: [PATCH] Re: pos() resetting changed with 5.005?
+ Branch: maint-5.005/perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 1681] By: gsar on 1998/08/02 03:39:27
+ Log: From: Nick Ing-Simmons <nik@tiuk.ti.com>
+ Date: Wed, 29 Jul 1998 13:28:14 +0100
+ Message-Id: <199807291228.NAA20055@tiuk.ti.com>
+ Subject: [Patch] Math::Complex - Ambiguous call resolved as CORE::foo()
+ Branch: maint-5.005/perl
+ + Porting/fixCORE
+ ! MANIFEST lib/Math/Complex.pm
+____________________________________________________________________________
+[ 1680] By: gsar on 1998/08/02 03:33:07
+ Log: From: h.sanden@elsevier.nl (Hugo van der Sanden)
+ Date: Mon, 27 Jul 1998 13:34:45 +0200
+ Message-Id: <199807271134.NAA24475@dorlas.elsevier.nl>
+ Subject: perlcall.pod
+ Branch: maint-5.005/perl
+ ! pod/perlcall.pod
+____________________________________________________________________________
+[ 1679] By: gsar on 1998/08/02 03:29:41
+ Log: MM_Win32::maybe_command() case-insesitivity tweak
+ Branch: maint-5.005/perl
+ ! lib/ExtUtils/MM_Win32.pm
+____________________________________________________________________________
+[ 1678] By: gsar on 1998/08/02 03:24:29
+ Log: fix MM_Win32::maybe_command()
+ Branch: maint-5.005/perl
+ ! lib/ExtUtils/MM_Win32.pm
+____________________________________________________________________________
+[ 1677] By: gsar on 1998/08/01 19:52:19
+ Log: fixes for overloading bugs and docs, tweaked some
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sat, 25 Jul 1998 21:28:16 -0400 (EDT)
+ Message-Id: <199807260128.VAA10543@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_76] better overloading
+ Branch: maint-5.005/perl
+ ! Changes gv.c lib/dumpvar.pl lib/overload.pm lib/perl5db.pl
+ ! t/pragma/overload.t
+____________________________________________________________________________
+[ 1676] By: gsar on 1998/08/01 19:37:13
+ Log: stray s/foo/PL_foo/
+ From: win@in.rhein-main.de (Winfried Koenig)
+ Date: Mon, 27 Jul 98 21:13 MET
+ Message-Id: <m0z0teW-00019aC@incom.rhein-main.de>
+ Subject: Bug in pp_rename and ISC hint
+ Branch: maint-5.005/perl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 1675] By: gsar on 1998/08/01 19:22:13
+ Log: newer Porting/patchls from maint-5.004
+ Branch: maint-5.005/perl
+ ! Porting/patchls
+____________________________________________________________________________
+[ 1674] By: gsar on 1998/08/01 17:50:44
+ Log: fix buggy detection of failed glob()
+ Branch: maint-5.005/perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 1673] By: gsar on 1998/07/29 18:14:32
+ Log: fix typo in change#1489 that prevented magic-autovivification
+ Branch: maint-5.005/perl
+ ! mg.c
+
+----------------
+Version 5.005_01 First maintenance release of 5.005
+----------------
+
+____________________________________________________________________________
+[ 1669] By: gsar on 1998/07/26 23:19:02
+ Log: update Changes; add sv_*_mg() entries in win32/GenCAPI.pl
+ Branch: maint-5.005/perl
+ ! Changes proto.h win32/GenCAPI.pl
+____________________________________________________________________________
+[ 1668] By: gsar on 1998/07/26 21:12:11
+ Log: s/TMP_CRLF_PATCH/PERL_STRICT_CR/ with sense reversed, so they
+ can disable it from config.sh if they want; up patchlevel to 5_01;
+ little tweaks to pods
+ Branch: maint-5.005/perl
+ ! README.win32 patchlevel.h pod/perldelta.pod toke.c
+ ! win32/Makefile win32/config_H.bc win32/config_H.gc
+ ! win32/config_H.vc win32/makefile.mk win32/win32.c
+____________________________________________________________________________
+[ 1662] By: gsar on 1998/07/26 05:01:52
+ Log: add missing sv_*_mg() prototypes in proto.h, update perlhist.pod
+ Branch: maint-5.005/perl
+ ! pod/perlhist.pod proto.h
+____________________________________________________________________________
+[ 1658] By: gsar on 1998/07/26 02:23:46
+ Log: VMS patches from Dan Sugalski <sugalskd@osshe.edu>
+ Date: Fri, 24 Jul 1998 11:38:25 -0700
+ Message-Id: <3.0.5.32.19980724113825.00a067b0@ous.edu>
+ Subject: [PATCH 5.005] version number problem with VMS (Corrected)
+ --
+ Date: Fri, 24 Jul 1998 12:30:36 -0700
+ Message-Id: <3.0.5.32.19980724123036.009f0390@ous.edu>
+ Subject: [PATCH 5.005]Tweaks to README.vms
+ --
+ Date: Sat, 25 Jul 1998 17:56:55 -0700 (PDT)
+ Message-ID: <Pine.GSO.3.96.980725175626.15740D-100000@netserve.ous.edu>
+ Subject: [PATCH 5.005] Final build cleanup patch
+ Branch: maint-5.005/perl
+ ! README.vms vms/descrip_mms.template vms/subconfigure.com
+____________________________________________________________________________
+[ 1657] By: gsar on 1998/07/26 02:19:50
+ Log: another platform where pp_sselect() needs a whole fd_set buffer
+ From: Lupe Christoph <lupe@alanya.m.isar.de>
+ Date: Sat, 25 Jul 1998 19:49:33 +0200 (MET DST)
+ Message-Id: <199807251749.TAA22347@alanya.m.isar.de>
+ Subject: Patch for Not OK: perl 5.005 on i86pc-solaris-thread 2.6
+ Branch: maint-5.005/perl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 1656] By: gsar on 1998/07/26 02:12:46
+ Log: fix problem building modules on dos-djgpp
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Date: Sat, 25 Jul 1998 00:53:39 +0200
+ Message-ID: <19980725005339.C222@cdata.tvnet.hu>
+ Subject: [PATCH 5.005] dos-djgpp and modules problem
+ Branch: maint-5.005/perl
+ ! djgpp/fixpmain
+____________________________________________________________________________
+[ 1655] By: gsar on 1998/07/26 02:11:09
+ Log: From: Tom Spindler <dogcow@home.merit.edu>
+ Date: Wed, 22 Jul 1998 16:11:07 -0400
+ Message-ID: <19980722161107.A16813@home.merit.edu>
+ Subject: [PATCH 5.005] BeOS tweak
+ Branch: maint-5.005/perl
+ ! hints/beos.sh
+____________________________________________________________________________
+[ 1654] By: gsar on 1998/07/26 02:09:29
+ Log: various pod tweaks
+ Branch: maint-5.005/perl
+ ! Changes pod/perldelta.pod pod/perlmodinstall.pod
+ ! pod/perltoc.pod
+____________________________________________________________________________
+[ 1653] By: gsar on 1998/07/26 02:05:46
+ Log: fix emacs/ptags for PL_* changes
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Fri, 24 Jul 1998 03:12:35 -0400 (EDT)
+ Message-Id: <199807240712.DAA04204@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_76] Yet better ptags
+ Branch: maint-5.005/perl
+ ! emacs/ptags
+____________________________________________________________________________
+[ 1652] By: gsar on 1998/07/26 02:03:01
+ Log: fix behavior of <=> on bigints
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Message-Id: <E0yzlfF-0004kz-00@taurus.cus.cam.ac.uk>
+ Date: Fri, 24 Jul 1998 18:29:53 +0100
+ Subject: [PATCH] Re: Math::BigInt <=> op is not correct.
+ Branch: maint-5.005/perl
+ ! lib/Math/BigInt.pm t/lib/bigintpm.t
+____________________________________________________________________________
+[ 1649] By: gsar on 1998/07/24 03:56:56
+ Log: create maint-5.005 branch
+ Branch: maint-5.005/perl
+ +> (branch 1079 files)
+____________________________________________________________________________
+[ 1648] By: gsar on 1998/07/24 03:36:35
+ Log: un-checked-in 5.005 Changes (this is 5.005 *exactly*)
+ Branch: perl
+ ! Changes
+
+-------------
+Version 5.005 Production release
+-------------
+
+____________________________________________________________________________
+[ 1647] By: gsar on 1998/07/22 21:11:29
+ Log: sneak in hints/irix_6.sh update
+ Branch: perl
+ ! Changes hints/irix_6.sh
+____________________________________________________________________________
+[ 1646] By: gsar on 1998/07/22 21:00:44
+ Log: Update perldelta and Changes; refresh perltoc; newer perlembed.pod
+ from Jon Orwant <orwant@media.mit.edu>; update guts documentation
+ to reflect PL_* changes; is this *it* for 5.005?
+ Branch: perl
+ ! Changes README.win32 patchlevel.h pod/perlcall.pod
+ ! pod/perldelta.pod pod/perlembed.pod pod/perlguts.pod
+ ! pod/perltoc.pod pod/perlxs.pod
+____________________________________________________________________________
+[ 1645] By: gsar on 1998/07/22 19:37:41
+ Log: don't use qualify() in class methods
+ From: Albert Dvornik <bert@genscan.com>
+ Date: 22 Jul 1998 15:14:46 EDT
+ Message-Id: <tqbtqhlmu1.fsf_-_@puma.genscan.com>
+ Subject: [PATCH 5.005-MAYBE] Bug in IO::Handle->input_record_separator
+ Branch: perl
+ ! ext/IO/lib/IO/Handle.pm
+____________________________________________________________________________
+[ 1644] By: gsar on 1998/07/22 18:13:31
+ Log: newer perlembed.pod
+ Branch: perl
+ ! pod/perlembed.pod
+____________________________________________________________________________
+[ 1643] By: gsar on 1998/07/22 18:03:42
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Wed, 22 Jul 1998 13:42:20 EDT
+ Message-Id: <Pine.SUN.3.96.980722134049.10073C-100000@newton.phys>
+ Subject: Re: 5.005 - a sneak preview
+ Branch: perl
+ ! Porting/pumpkin.pod
+____________________________________________________________________________
+[ 1642] By: gsar on 1998/07/22 17:58:42
+ Log: add perlmodinstall, regen perltoc
+ Branch: perl
+ + pod/perlmodinstall.pod
+ ! MANIFEST pod/Makefile pod/buildtoc pod/perl.pod
+ ! pod/perltoc.pod win32/pod.mak
+____________________________________________________________________________
+[ 1641] By: gsar on 1998/07/22 17:11:55
+ Log: support optional crypt() with PERL_OBJECT
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Date: Wed, 22 Jul 1998 08:21:10 PDT
+ Message-Id: <000701bdb584$5b57c070$a32fa8c0@tau.Active>
+ Subject: [PATCH 5.005 maybe] for crypt with PERL_OBJECT
+ Branch: perl
+ ! iperlsys.h pp.c win32/Makefile win32/makefile.mk
+ ! win32/perlhost.h win32/win32.c win32/win32iop.h
+____________________________________________________________________________
+[ 1640] By: gsar on 1998/07/22 17:09:11
+ Log: win32 tweaks
+ Date: Wed, 22 Jul 1998 07:09:09 PDT
+ Message-Id: <000001bdb57a$4bc9dd00$a32fa8c0@tau.Active>
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Branch: perl
+ ! win32/Makefile win32/makefile.mk win32/win32.h
+____________________________________________________________________________
+[ 1639] By: gsar on 1998/07/22 17:00:30
+ Log: From: d-lewart@uiuc.edu (Daniel S. Lewart)
+ Date: Wed, 22 Jul 1998 06:20:08 CDT
+ Message-Id: <199807221120.GAA07962@staff2.cso.uiuc.edu>
+ Subject: [PATCH] lib/Sys/Syslog.pm doc
+ Branch: perl
+ ! Changes lib/Sys/Syslog.pm
+____________________________________________________________________________
+[ 1638] By: gsar on 1998/07/22 09:12:26
+ Log: up patchlevel etc (only doc patching from now on, testing in progress)
+ Branch: perl
+ ! Changes patchlevel.h win32/Makefile win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1637] By: gsar on 1998/07/22 08:27:09
+ Log: VMS patches from Dan Sugalski <sugalskd@osshe.edu>
+ Date: Tue, 21 Jul 1998 16:04:40 PDT
+ Message-Id: <3.0.5.32.19980721160440.00a916f0@ous.edu>
+ Subject: [PATCH 5.004_76]Document Vax C's death for VMS
+ --
+ Date: Tue, 21 Jul 1998 16:08:57 PDT
+ Message-Id: <3.0.5.32.19980721160857.00a6d250@ous.edu>
+ Subject: [PATCH 5.004_76]fix clean/realclean targets of VMS' makefile
+ --
+ Date: Tue, 21 Jul 1998 16:05:56 PDT
+ Message-Id: <3.0.5.32.19980721160556.00a1a100@ous.edu>
+ Subject: [PATCH 5.004_76]Note the record-read capabilities of $/ in perldelta.pod
+ Branch: perl
+ ! README.vms pod/perldelta.pod vms/descrip_mms.template
+____________________________________________________________________________
+[ 1636] By: gsar on 1998/07/22 08:04:37
+ Log: fix quoting in t/io/inplace.t
+ Branch: perl
+ ! t/io/inplace.t
+____________________________________________________________________________
+[ 1635] By: gsar on 1998/07/22 07:59:30
+ Log: From: Dan Sugalski <sugalskd@osshe.edu>
+ Date: Tue, 21 Jul 1998 13:06:44 PDT
+ Message-Id: <3.0.5.32.19980721130644.00ac5100@ous.edu>
+ Subject: [PATCH 5.004_76]t/io/inplace.t enabled for VMS
+ Branch: perl
+ ! t/io/inplace.t vms/test.com
+____________________________________________________________________________
+[ 1634] By: gsar on 1998/07/22 07:55:35
+ Log: From: Dan Sugalski <sugalskd@osshe.edu>
+ Date: Tue, 21 Jul 1998 12:42:20 PDT
+ Message-Id: <3.0.5.32.19980721124220.00a82a20@ous.edu>
+ Subject: [PATCH 5.004_76]Fix inplace editing for VMS
+ Branch: perl
+ ! doio.c
+____________________________________________________________________________
+[ 1633] By: gsar on 1998/07/22 07:53:53
+ Log: fix AIX hints for PL_* changes
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Tue, 21 Jul 1998 22:53:54 +0300
+ Message-Id: <199807211953.WAA55724@vipunen.hut.fi>
+ Subject: Re: _76 fails to link B extension on AIX 414
+ Branch: perl
+ ! perl_exp.SH
+____________________________________________________________________________
+[ 1632] By: gsar on 1998/07/22 07:51:56
+ Log: From: Anton Berezin <tobez@plab.ku.dk>
+ Date: Tue, 21 Jul 1998 21:46:45 +0200
+ Message-Id: <199807211946.VAA01301@lion.plab.ku.dk>
+ Subject: [PATCH _76] t/op/eval.t test for eval & scoping of lexicals
+ Branch: perl
+ ! t/op/eval.t
+____________________________________________________________________________
+[ 1631] By: gsar on 1998/07/22 07:48:20
+ Log: applied patch, with tweak suggested by Michael Parker
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Tue, 21 Jul 1998 14:30:05 EDT
+ Message-Id: <Pine.SUN.3.96.980721142928.8231Q-100000@newton.phys>
+ Subject: Re: Not OK: _76 on IP22-irix6.2 fails tests
+ Branch: perl
+ ! hints/irix_6.sh
+____________________________________________________________________________
+[ 1630] By: gsar on 1998/07/22 07:40:25
+ Log: better diagnostic on errno.t failure
+ From: Graham Barr <gbarr@ti.com>
+ Date: Tue, 21 Jul 1998 13:07:29 CDT
+ Message-Id: <19980721130729.K4337@asic.sc.ti.com>
+ Branch: perl
+ ! t/lib/errno.t
+____________________________________________________________________________
+[ 1629] By: gsar on 1998/07/22 07:36:38
+ Log: win32 tweaks: disable XSLOCKS in perl.c, correct typo, search
+ the registry for anything that begins with "PERL", not "PERL5"
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Date: Tue, 21 Jul 1998 11:08:00 PDT
+ Message-Id: <000601bdb4d2$7ee74720$a32fa8c0@tau.Active>
+ Branch: perl
+ ! perl.c win32/perlhost.h win32/win32.c
+____________________________________________________________________________
+[ 1628] By: gsar on 1998/07/22 07:28:35
+ Log: suppress redefined warnings on C<INIT {} INIT {}>
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 1627] By: gsar on 1998/07/22 07:15:19
+ Log: remove spurious $VERSION line that confuses CPAN
+ From: Johan Vromans <jvromans@squirrel.nl>
+ Date: Tue, 21 Jul 1998 20:01:36 +0200
+ Message-Id: <13748.55168.397720.564438@phoenix.squirrel.nl>
+ Subject: Re: 5.004_76 missing version numbers
+ Branch: perl
+ ! lib/Getopt/Long.pm
+____________________________________________________________________________
+[ 1626] By: gsar on 1998/07/22 06:57:56
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Tue, 21 Jul 1998 10:20:13 EDT
+ Message-Id: <Pine.SUN.3.96.980721101922.8078A-100000@newton.phys>
+ Subject: [PATCH] Porting/config* updates for 5.005
+ Branch: perl
+ ! Changes Porting/config.sh Porting/config_H
+____________________________________________________________________________
+[ 1625] By: gsar on 1998/07/22 06:46:38
+ Log: add a few more globals with old names #defined
+ Branch: perl
+ ! embed.pl embedvar.h
+____________________________________________________________________________
+[ 1624] By: gsar on 1998/07/22 06:39:22
+ Log: allow extensions to be specified as paths
+ From: Paul Johnson <pjcj@transeda.com>
+ Date: Tue, 21 Jul 1998 12:04:27 BST
+ Message-Id: <19980721120427.F903@west-tip.transeda.com>
+ Subject: [PATCH] 5.004_75 Embed and static extensions
+ Branch: perl
+ ! lib/ExtUtils/Embed.pm
+____________________________________________________________________________
+[ 1623] By: gsar on 1998/07/22 06:12:50
+ Log: make $ prototype to accept THREADSVs
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 1622] By: gsar on 1998/07/22 06:04:25
+ Log: fix Liblist.pm to find entries that are plain pathnames on win32
+ Branch: perl
+ ! lib/ExtUtils/Liblist.pm
+____________________________________________________________________________
+[ 1621] By: gsar on 1998/07/22 05:10:53
+ Log: perlfaq update from From Tom Christiansen and Nathan Torkington
+ (removes all mention of training courses from perlfaq*.pod)
+ Branch: perl
+ ! pod/perlfaq.pod pod/perlfaq2.pod pod/perlfaq3.pod
+ ! pod/perlfaq4.pod pod/perlfaq6.pod pod/perlfaq7.pod
+ ! pod/perlfaq8.pod pod/perlfaq9.pod
+____________________________________________________________________________
+[ 1620] By: gsar on 1998/07/22 02:51:13
+ Log: applied patch, modulo parts already added to perldelta
+ From: Stephen McCamant <alias@mcs.com>
+ Date: Tue, 21 Jul 1998 17:06:23 CDT
+ Message-Id: <13749.3106.995764.413053@alias-2.pr.mcs.net>
+ Subject: [PATCH] Re: Beta2 is available
+ Branch: perl
+ ! pod/perldelta.pod
+____________________________________________________________________________
+[ 1619] By: gsar on 1998/07/22 02:45:55
+ Log: applied patch, add new message to perldeta
+ From: Stephen McCamant <alias@mcs.com>
+ Date: Tue, 21 Jul 1998 16:12:25 CDT
+ Message-Id: <13749.910.83378.949909@alias-2.pr.mcs.net>
+ Subject: [PATCH] Band-aid patch for local($avhv->{a})
+ Branch: perl
+ ! pod/perldelta.pod pod/perldiag.pod pp.c pp_hot.c
+____________________________________________________________________________
+[ 1618] By: gsar on 1998/07/22 02:08:00
+ Log: fix up B modules for PL_* changes
+ Branch: perl
+ ! ext/B/B/C.pm ext/B/B/CC.pm ext/B/B/Stackobj.pm
+____________________________________________________________________________
+[ 1617] By: gsar on 1998/07/22 01:42:14
+ Log: From: Malcolm Beattie <mbeattie@sable.ox.ac.uk>
+ Date: Tue, 21 Jul 1998 18:13:16 BST
+ Message-Id: <199807211713.SAA20735@sable.ox.ac.uk>
+ Subject: Compiler docs for 5.005
+ Branch: perl
+ ! ext/B/B.pm ext/B/B/Bytecode.pm ext/B/B/C.pm ext/B/B/CC.pm
+ ! ext/B/O.pm
+____________________________________________________________________________
+[ 1616] By: gsar on 1998/07/22 01:29:09
+ Log: s/PL_sv/PL_bytecode_sv/ etc., so we have unique, case-insensitive
+ names
+ Branch: perl
+ ! bytecode.h bytecode.pl byterun.c embedvar.h interp.sym
+ ! intrpvar.h
+____________________________________________________________________________
+[ 1615] By: nick on 1998/07/21 22:26:34
+ Log: Mingw32 PERL_OBJECT tweaks
+ Branch: perl
+ ! ext/Fcntl/Fcntl.xs ext/IO/IO.xs ext/POSIX/POSIX.xs
+____________________________________________________________________________
+[ 1614] By: gsar on 1998/07/21 19:43:32
+ Log: fix off-by-one in change#623 that broke lexical lookups in eval''
+ Branch: perl
+ ! pp_ctl.c
+
+----------------
+Version 5.004_76 5.005 Public Beta, Issue 2
+----------------
+
+____________________________________________________________________________
+[ 1613] By: gsar on 1998/07/21 10:26:01
+ Log: final tweaks before beta2
+ Branch: perl
+ + Porting/findvars
+ +> Porting/fixvars
+ - fixvars
+ ! Changes MANIFEST intrpvar.h iperlsys.h
+ ! lib/ExtUtils/MM_Win32.pm win32/perlhost.h
+____________________________________________________________________________
+[ 1612] By: gsar on 1998/07/21 07:15:54
+ Log: fixes to enable PERL_OBJECT build with mingw32/egcs-1.0.2
+ Branch: perl
+ ! ext/Opcode/Opcode.xs proto.h win32/makedef.pl
+ ! win32/makefile.mk win32/perlhost.h win32/win32.c win32/win32.h
+ ! win32/win32sck.c
+____________________________________________________________________________
+[ 1611] By: gsar on 1998/07/21 07:12:00
+ Log: fix bytecode.pl with moved var names
+ Branch: perl
+ ! bytecode.pl byterun.c byterun.h ext/B/B/Asmdata.pm
+____________________________________________________________________________
+[ 1610] By: gsar on 1998/07/21 05:51:10
+ Log: tweak toke.c
+ Branch: perl
+ ! toke.c
+____________________________________________________________________________
+[ 1609] By: gsar on 1998/07/21 05:46:59
+ Log: change case of PERL_OBJECT filenames, consistent with the rest
+ Branch: perl
+ + XSlock.h objXSUB.h
+ - ObjXSub.h XSLock.h
+ ! MANIFEST XSUB.h lib/ExtUtils/MM_Win32.pm perl.h
+ ! win32/GenCAPI.pl win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1608] By: gsar on 1998/07/21 05:31:13
+ Log: part 2 of PERL_OBJECT fixes (globals in bytecode.h moved to intrpvar.h)
+ Branch: perl
+ ! bytecode.h byterun.c embedvar.h interp.sym intrpvar.h
+____________________________________________________________________________
+[ 1607] By: gsar on 1998/07/21 05:29:10
+ Log: part 1 of PERL_OBJECT fixes for new var names
+ Branch: perl
+ ! ObjXSub.h bytecode.h globals.c iperlsys.h perl.h pp_ctl.c
+ ! run.c win32/GenCAPI.pl
+____________________________________________________________________________
+[ 1606] By: gsar on 1998/07/21 05:17:26
+ Log: From: Stephen McCamant <alias@mcs.com>
+ Date: Mon, 20 Jul 1998 23:53:32 CDT
+ Message-Id: <13748.6947.311341.657005@alias-2.pr.mcs.net>
+ Subject: [PATCH] redundant RV2GVs in ck_fun()
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 1605] By: gsar on 1998/07/21 05:13:28
+ Log: From: Stephen McCamant <alias@mcs.com>
+ Date: Mon, 20 Jul 1998 23:32:42 CDT
+ Message-Id: <13748.6392.921893.643238@alias-2.pr.mcs.net>
+ Subject: B::Deparse 0.56 (first testsuite fixes; big)
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+____________________________________________________________________________
+[ 1604] By: gsar on 1998/07/21 05:07:29
+ Log: applied a slightly tweaked version of suggested patch
+ From: Colin Kuskie <ckuskie@cadence.com>
+ Date: Mon, 20 Jul 1998 15:58:31 -0700 (PDT)
+ Message-ID: <Pine.GSO.3.96.980720154841.6188M-100000@pdxmail.cadence.com>
+ Subject: [PATCH _75] More documentation for -i prefix
+ Branch: perl
+ ! pod/perlrun.pod
+____________________________________________________________________________
+[ 1603] By: gsar on 1998/07/21 04:59:19
+ Log: disable malloced_size() feedback with -DLEAKTEST
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 20 Jul 1998 21:20:21 -0400 (EDT)
+ Message-Id: <199807210120.VAA15031@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_75] -DLEAKTEST broken
+ Branch: perl
+ ! av.c sv.c
+____________________________________________________________________________
+[ 1602] By: gsar on 1998/07/21 04:57:43
+ Log: fix hints/hpux.sh for cpp recognition
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Mon, 20 Jul 1998 12:46:33 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980720124202.6585B-100000@newton.phys>
+ Subject: RE: Configure misses preprocessor on HP-UX
+ Branch: perl
+ ! hints/hpux.sh
+____________________________________________________________________________
+[ 1601] By: gsar on 1998/07/21 04:55:51
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sun, 19 Jul 1998 18:16:38 -0400 (EDT)
+ Message-Id: <199807192216.SAA10482@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Compile (?{}) into a correct package
+ Branch: perl
+ ! pp_ctl.c t/op/pat.t
+____________________________________________________________________________
+[ 1600] By: gsar on 1998/07/21 04:48:32
+ Log: allocate a whole fd_set for pp_sselect() on more platforms
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Date: 20 Jul 1998 00:14:18 +0300
+ Message-ID: <oeen2a5y251.fsf@alpha.hut.fi>
+ Subject: Re: Not OK: perl 5.00475 +DEVEL_BETA_ISSUE_1 on OPENSTEP-Mach 4_1 (UNINSTALLED)
+ Branch: perl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 1599] By: gsar on 1998/07/21 04:44:04
+ Log: add tests to check if context propagation works
+ From: Francois Desarmenien <desar@club-internet.fr>
+ Date: Sun, 19 Jul 1998 12:28:33 +0200
+ Message-ID: <35B1CA51.A606AD27@club-internet.fr>
+ Subject: Re: m//g strange behaviour in 5.004
+ Branch: perl
+ + t/op/context.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 1598] By: gsar on 1998/07/21 04:37:49
+ Log: applied RE doc patches, with tweaks to the prose
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sat, 18 Jul 1998 23:11:13 -0400 (EDT)
+ Message-Id: <199807190311.XAA25080@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Document irregular zero-length matches
+ --
+ Date: Sun, 19 Jul 1998 00:38:44 -0400 (EDT)
+ Message-Id: <199807190438.AAA26226@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Another irregularity of expressions documented
+ Branch: perl
+ ! pod/perlre.pod
+____________________________________________________________________________
+[ 1597] By: gsar on 1998/07/21 04:16:51
+ Log: pod tweak suggested by Ilya
+ Branch: perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 1596] By: gsar on 1998/07/21 04:12:39
+ Log: enable color output with -Mre=debugcolor with -DDEBUGGING
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sat, 18 Jul 1998 17:34:00 -0400 (EDT)
+ Message-Id: <199807182134.RAA20644@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Better -Mre=colordb
+ Branch: perl
+ ! ext/re/re.xs
+____________________________________________________________________________
+[ 1595] By: gsar on 1998/07/21 04:07:44
+ Log: From: "John L. Allen" <allen@grumman.com>
+ Date: Thu, 16 Jul 1998 11:43:54 -0400 (EDT)
+ Message-ID: <Pine.SOL.3.91.980716113018.14617A-100000@gateway.grumman.com>
+ Subject: [PATCH _75 & _05] perlbug does not report usage on invalid flags
+ Branch: perl
+ ! utils/perlbug.PL
+____________________________________________________________________________
+[ 1594] By: gsar on 1998/07/21 04:06:06
+ Log: don't use SelectSaver on IO::Handle->input_*() methods
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Thu, 16 Jul 1998 15:00:39 +0100 (BST)
+ Message-Id: <199807161400.PAA25532@tempest.cise.npl.co.uk>
+ Subject: Re: Bug in IO::Handle->input_record_separator
+ Branch: perl
+ ! ext/IO/lib/IO/Handle.pm
+____________________________________________________________________________
+[ 1593] By: gsar on 1998/07/21 04:03:46
+ Log: applied a tweaked version of suggested patch
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Wed, 15 Jul 1998 17:02:48 -0400 (EDT)
+ Message-Id: <199807152102.RAA19952@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Enable/document colors in re.pm
+ Branch: perl
+ ! ext/re/re.pm
+____________________________________________________________________________
+[ 1592] By: gsar on 1998/07/21 03:49:55
+ Log: remove compat3.sym and rename perld4.pod
+ Branch: perl
+ +> pod/perl5004delta.pod
+ - compat3.sym pod/perld4.pod
+ ! MANIFEST
+____________________________________________________________________________
+[ 1591] By: gsar on 1998/07/21 03:38:16
+ Log: update patchlevel, Changes
+ Branch: perl
+ ! Changes patchlevel.h win32/Makefile win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1590] By: gsar on 1998/07/21 03:06:04
+ Log: documentation tweaks from Abigail <abigail@fnx.com>
+ Date: Fri, 17 Jul 1998 20:52:36 -0400 (EDT)
+ Message-ID: <19980718005236.5154.qmail@betelgeuse.wayne.fnx.com>
+ Subject: Re: [PATCH 5.00475] pod/perlsyn.pod
+ --
+ Date: Thu, 16 Jul 1998 17:00:49 -0400 (EDT)
+ Message-ID: <19980716210049.16156.qmail@betelgeuse.wayne.fnx.com>
+ Subject: [PATCH 5.00475] pod/perlguts.pod
+ --
+ Date: Thu, 16 Jul 1998 16:52:05 -0400 (EDT)
+ Message-ID: <19980716205205.15949.qmail@betelgeuse.wayne.fnx.com>
+ Subject: [PATCH 5.00475] Tweaking pod/perlfunc.pod
+ --
+ Date: Fri, 17 Jul 1998 22:58:05 -0400 (EDT)
+ Message-ID: <19980718025805.7135.qmail@betelgeuse.wayne.fnx.com>
+ Subject: [PATCH, 5.00475], pod/perlsub.pod
+ --
+ Date: Sat, 18 Jul 1998 04:02:00 -0400 (EDT)
+ Message-ID: <19980718080200.9927.qmail@betelgeuse.wayne.fnx.com>
+ Subject: [PATCH 5.00475] pod/perlfunc.pod
+ Branch: perl
+ ! pod/perlfunc.pod pod/perlguts.pod pod/perlsub.pod
+ ! pod/perlsyn.pod
+____________________________________________________________________________
+[ 1589] By: gsar on 1998/07/21 02:44:25
+ Log: VMS patches from Dan Sugalski <sugalskd@osshe.edu>
+ Date: Wed, 15 Jul 1998 09:38:12 -0700
+ Message-Id: <3.0.5.32.19980715093812.00a42a50@ous.edu>
+ Subject: [PATCH 5.005-beta1]Quick VMS config update
+ --
+ Date: Wed, 15 Jul 1998 12:53:52 -0700
+ Message-Id: <3.0.5.32.19980715125352.00a25cb0@ous.edu>
+ Subject: Re: $ebcdic has broken VMS in _75 (Now with doc patch!)
+ --
+ Date: Thu, 16 Jul 1998 11:15:44 -0700
+ Message-Id: <3.0.5.32.19980716111544.00b78770@ous.edu>
+ Subject: [PATCH 5.004_75]Another VMS tweak for the Vax C compiler
+ --
+ Date: Thu, 16 Jul 1998 11:21:55 -0700
+ Message-Id: <3.0.5.32.19980716112155.00a66c50@ous.edu>
+ Subject: [PATCH 5.004_75]Get archname correct for thread build on VMS
+ --
+ Date: Thu, 16 Jul 1998 11:25:04 -0700
+ Message-Id: <3.0.5.32.19980716112504.00ae0d50@ous.edu>
+ Subject: [PATCH 5.004_75]Thread build tweaks for VMS 6.2 and older
+ --
+ Date: Fri, 17 Jul 1998 15:29:13 -0700
+ Message-Id: <3.0.5.32.19980717152913.00a469b0@ous.edu>
+ Subject: [PATCH 5.004_75]Missed a header file in VMS build procedure
+ --
+ Date: Mon, 20 Jul 1998 10:20:49 -0700
+ Message-Id: <3.0.5.32.19980720102049.00a05100@ous.edu>
+ Subject: [PATCH 5.004_75]Tweaks to Thread.XS for OLD_PTHREADS_API build
+ --
+ Date: Mon, 20 Jul 1998 10:13:03 -0700
+ Message-Id: <3.0.5.32.19980720101303.00a17100@ous.edu>
+ Subject: [PATCH 5.004_75]Explicitly specify extensions during VMS config process
+ --
+ From: Brad Hughes <brad@tgsmc.com>
+ Date: Mon, 20 Jul 1998 15:51:22 -0700
+ Message-Id: <3.0.5.32.19980720155122.00a41950@ous.edu>
+ Subject: patch for readme.vms
+ Branch: perl
+ ! README.vms ext/Thread/Thread.xs vms/descrip_mms.template
+ ! vms/gen_shrfls.pl vms/subconfigure.com
+____________________________________________________________________________
+[ 1588] By: gsar on 1998/07/21 01:26:20
+ Log: change#1481 didn't go through at all, redo it
+ Branch: perl
+ ! t/base/rs.t
+____________________________________________________________________________
+[ 1587] By: gsar on 1998/07/21 01:21:41
+ Log: workaround C<"foo" "bar"> catenation-intolerant compilers
+ Branch: perl
+ ! regexec.c toke.c
+____________________________________________________________________________
+[ 1586] By: gsar on 1998/07/21 01:05:49
+ Log: do not override PERL_DESTRUCT_LEVEL if use has it set
+ Branch: perl
+ ! t/TEST
+____________________________________________________________________________
+[ 1585] By: gsar on 1998/07/21 00:39:17
+ Log: fix small memory leak when mess_sv happens to be touched by magic
+ Branch: perl
+ ! perl.c t/lib/thread.t t/op/local.t t/op/pat.t t/op/regexp.t
+____________________________________________________________________________
+[ 1584] By: gsar on 1998/07/21 00:37:32
+ Log: fix memory leak in C<local(*foo) = 'bar'>
+ Branch: perl
+ ! scope.c
+____________________________________________________________________________
+[ 1583] By: TimBunce on 1998/07/20 22:14:11
+ Log: Update Changes and patchlevel.h for release. At last.
+ Branch: maint-5.004/perl
+ ! Changes patchlevel.h
+____________________________________________________________________________
+[ 1582] By: gsar on 1998/07/20 21:28:43
+ Log: add rsfp_filters and perldb to pollutants list
+ Branch: perl
+ ! embed.pl
+____________________________________________________________________________
+[ 1581] By: nick on 1998/07/20 19:22:37
+ Log: Integrate mainline pre-beta2 - just in case
+ Branch: ansiperl
+ !> (integrate 66 files)
+____________________________________________________________________________
+[ 1580] By: TimBunce on 1998/07/20 17:16:38
+ Log: Assorted patches:
+
+ Title: "Clean up hash array allocation"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807201052.GAA13336@aatma.engin.umich.edu>
+ Files: hv.c
+
+ Title: "Further fixes for cppstdin on HP-UX 11"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980720124202.6585B-100000@newton.phys>
+ Files: hints/hpux.sh
+ Branch: maint-5.004/perl
+ ! hints/hpux.sh hv.c
+____________________________________________________________________________
+[ 1579] By: TimBunce on 1998/07/20 09:46:14
+ Log: Assorted patches:
+
+ Title: "Fix C<$1 .. $2> coredump under debugger"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807200042.UAA23288@aatma.engin.umich.edu>
+ Files: pp_ctl.c
+
+ Title: "Fix lvalue leaks stemming from failure to free LvTARG(sv)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807191829.OAA12433@aatma.engin.umich.edu>
+ Files: embed.h perl.h proto.h global.sym mg.c sv.c t/op/substr.t t/op/vec.t
+
+ Title: "fix major bug (from 5.003_96); void contexts were using the context
+ of the enclosing sub!"
+ From: Francois Desarmenien <desar@club-internet.fr>, Gurusamy Sarathy
+ <gsar@engin.umich.edu>
+ Msg-ID: <199807180927.FAA08032@aatma.engin.umich.edu>,
+ <35B1CA51.A606AD27@club-internet.fr>
+ Files: op.h
+
+ Title: "Update lib/Getopt/Long.pm (from perl5.005 beta 1)"
+ From: Johan Vromans <jvromans@squirrel.nl>
+ Msg-ID: <13745.47704.943964.34613@phoenix.squirrel.nl>
+ Files: lib/Getopt/Long.pm
+
+ Title: "Add Porting/p4d2p utility for converting perforce diffs"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807200002.UAA21398@aatma.engin.umich.edu>
+ Files: MANIFEST Porting/p4d2p
+ Branch: maint-5.004/perl
+ + Porting/p4d2p
+ ! MANIFEST embed.h global.sym lib/Getopt/Long.pm mg.c op.h
+ ! perl.h pp_ctl.c proto.h sv.c t/op/substr.t t/op/vec.t
+____________________________________________________________________________
+[ 1578] By: gsar on 1998/07/20 09:38:39
+ Log: complete s/foo/PL_foo/ changes (all escaped cases identified with
+ brute force search script). Result builds and passes all tests on
+ Solaris. win32 and PERL_OBJECT are still untested.
+ Branch: perl
+ ! XSLock.h XSUB.h bytecode.h bytecode.pl byterun.c cc_runtime.h
+ ! djgpp/djgpp.c embed.pl ext/B/B.xs ext/B/B/Asmdata.pm
+ ! ext/B/byteperl.c ext/DB_File/DB_File.xs ext/DB_File/typemap
+ ! ext/DynaLoader/dl_dld.xs ext/DynaLoader/dl_next.xs
+ ! ext/DynaLoader/dl_vms.xs ext/GDBM_File/typemap ext/IO/IO.xs
+ ! ext/IPC/SysV/SysV.xs ext/NDBM_File/typemap
+ ! ext/ODBM_File/ODBM_File.xs ext/ODBM_File/typemap
+ ! ext/Opcode/Opcode.xs ext/POSIX/POSIX.xs ext/SDBM_File/typemap
+ ! ext/Thread/Thread.xs ext/attrs/attrs.xs fakethr.h gv.c hv.c
+ ! lib/ExtUtils/typemap malloc.c mg.c op.c os2/OS2/PrfDB/PrfDB.xs
+ ! os2/OS2/PrfDB/typemap os2/OS2/REXX/REXX.xs os2/os2.c
+ ! os2/os2ish.h perl.c perl.h pp.c pp_ctl.c pp_hot.c pp_sys.c
+ ! regcomp.c regcomp.h regexec.c scope.c scope.h sv.h taint.c
+ ! toke.c util.c vms/ext/DCLsym/DCLsym.xs vms/ext/Stdio/Stdio.xs
+ ! vms/vms.c vms/vmsish.h win32/win32.c win32/win32thread.c
+____________________________________________________________________________
+[ 1577] By: TimBunce on 1998/07/20 08:28:17
+ Log: Title: "Make failed matches return empty list in list context"
+ From: "Paul E. Maisano" <pem@aaii.oz.au>, Gurusamy Sarathy
+ <gsar@engin.umich.edu>, Paul Maisano <pem@aaii.oz.au>
+ Msg-ID: <199807200002.UAA21398@aatma.engin.umich.edu>,
+ <199807200027.KAA27815@ironbark-ridge.aaii.oz.au>,
+ <35B156FB.504E66E@aaii.oz.au>
+ Files: pod/perlop.pod pp_hot.c t/op/pat.t
+ Branch: maint-5.004/perl
+ ! pod/perlop.pod pp_hot.c t/op/pat.t
+____________________________________________________________________________
+[ 1576] By: TimBunce on 1998/07/20 08:11:37
+ Log: Title: "win32 update from 5.005 beta 2 for 5.004_05"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807192332.TAA20905@aatma.engin.umich.edu>
+ Files: win32/include/dirent.h win32/include/sys/socket.h proto.h
+ lib/ExtUtils/Liblist.pm lib/ExtUtils/Mksymlists.pm
+ win32/win32.h win32/win32iop.h README.win32 installperl
+ pp_ctl.c win32/Makefile win32/config.bc win32/config.vc
+ win32/config_H.bc win32/config_H.vc win32/config_h.PL
+ win32/config_sh.PL win32/dl_win32.xs win32/makedef.pl
+ win32/makefile.mk win32/pod.mak win32/win32.c
+ win32/win32sck.c win32/bin/pl2bat.pl
+ Branch: maint-5.004/perl
+ ! README.win32 installperl lib/ExtUtils/Liblist.pm
+ ! lib/ExtUtils/Mksymlists.pm pp_ctl.c proto.h win32/Makefile
+ ! win32/bin/pl2bat.pl win32/config.bc win32/config.vc
+ ! win32/config_H.bc win32/config_H.vc win32/config_h.PL
+ ! win32/config_sh.PL win32/dl_win32.xs win32/include/dirent.h
+ ! win32/include/sys/socket.h win32/makedef.pl win32/makefile.mk
+ ! win32/pod.mak win32/win32.c win32/win32.h win32/win32iop.h
+ ! win32/win32sck.c
+____________________________________________________________________________
+[ 1575] By: gsar on 1998/07/20 01:27:14
+ Log: integrate ansi branch to get s/foo/PL_foo/ changes
+ Branch: perl
+ +> fixvars
+ !> (integrate 537 files)
+____________________________________________________________________________
+[ 1574] By: gsar on 1998/07/20 00:33:43
+ Log: fix C<$1 .. $2> coredump under debugger
+ Branch: perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 1573] By: gsar on 1998/07/20 00:28:27
+ Log: misc win32 config tweaks
+ Branch: perl
+ ! win32/Makefile win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_h.PL win32/makefile.mk
+____________________________________________________________________________
+[ 1572] By: nick on 1998/07/19 19:04:58
+ Log: Missed file that had changed
+ Branch: ansiperl
+ ! embedvar.h
+____________________________________________________________________________
+[ 1571] By: nick on 1998/07/19 18:57:35
+ Log: Another threaded, perl malloc issue, x2p's Makefile.SH has a
+ pattern match...
+ Branch: ansiperl
+ ! x2p/Makefile.SH
+____________________________________________________________________________
+[ 1570] By: nick on 1998/07/19 18:16:20
+ Log: Drat! - threaded perl-malloc has mutex that needs PL_
+ Branch: ansiperl
+ ! malloc.c perl.h
+____________________________________________________________________________
+[ 1569] By: nick on 1998/07/19 17:55:22
+ Log: PL_ for perl's malloc
+ Branch: ansiperl
+ ! hv.c malloc.c
+____________________________________________________________________________
+[ 1568] By: nick on 1998/07/19 16:23:30
+ Log: PL_ minir tidy up
+ Branch: ansiperl
+ ! embed.pl ext/Thread/Thread.xs util.c
+____________________________________________________________________________
+[ 1567] By: nick on 1998/07/19 13:21:07
+ Log: Add PL_ to merged file
+ Branch: ansiperl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 1566] By: nick on 1998/07/19 12:38:30
+ Log: Merge Mainline
+ Branch: ansiperl
+ + fixvars
+ !> (integrate 29 files)
+____________________________________________________________________________
+[ 1565] By: gsar on 1998/07/19 07:06:54
+ Log: tweak pod in MakeMaker.pm
+ From: Paul Johnson <pjcj@transeda.com>
+ Date: Sat, 18 Jul 1998 15:58:48 +0100
+ Message-ID: <19980718155847.D903@west-tip.transeda.com>
+ Subject: [PATCH]5.004_75 (DOC) MakeMaker.pm
+ Branch: perl
+ ! lib/ExtUtils/MakeMaker.pm
+____________________________________________________________________________
+[ 1564] By: gsar on 1998/07/19 07:04:45
+ Log: From: Gisle Aas <gisle@aas.no>
+ Date: 17 Jul 1998 22:49:32 +0200
+ Message-ID: <m390lsb3tv.fsf@furu.g.aas.no>
+ Subject: [PATCH _75] sv_gets() did not NUL-terminate SV when reading records
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 1563] By: gsar on 1998/07/19 07:03:32
+ Log: update freebsd hints
+ From: Mik Firestone <fireston@lexmark.com>
+ Date: Fri, 17 Jul 1998 15:24:26 -0400 (EDT)
+ Message-Id: <199807171924.AA05297@interlock2.lexmark.com>
+ Subject: [PATCH 5.005b1] hints/freebsd.sh
+ Branch: perl
+ ! hints/freebsd.sh
+____________________________________________________________________________
+[ 1562] By: gsar on 1998/07/19 07:01:33
+ Log: From: Mark Bixby <markb@spock.dis.cccd.edu>
+ Date: Fri, 17 Jul 1998 10:37:49 -0700 (PDT)
+ Message-Id: <199807171737.KAA06967@spock.dis.cccd.edu>
+ Subject: [PATCH 5.005b1] MPE/iX hints and readme tweaks
+ Branch: perl
+ ! README.mpeix hints/mpeix.sh
+____________________________________________________________________________
+[ 1561] By: gsar on 1998/07/19 07:00:19
+ Log: From: Norton Allen <allen@huarp.harvard.edu>
+ Date: Fri, 17 Jul 1998 12:37:27 -0400 (edt)
+ Message-Id: <199807171637.MAA24830@bottesini.harvard.edu>
+ Subject: [PATCH: 75] make install fails
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 1560] By: gsar on 1998/07/19 06:58:55
+ Log: fix flawed substitution-loop detection on zero-length matches
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Fri, 17 Jul 1998 13:55:38 -0400 (EDT)
+ Message-Id: <199807171755.NAA27720@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Substitution loop in devel branch
+ Branch: perl
+ ! pp_hot.c t/op/subst.t
+____________________________________________________________________________
+[ 1559] By: gsar on 1998/07/19 06:56:19
+ Log: add perltrap entry about "${#a}", as suggested by
+ andy barfoot <abarfoot@eng.auburn.edu>
+ Branch: perl
+ ! pod/perltrap.pod
+____________________________________________________________________________
+[ 1558] By: gsar on 1998/07/19 06:43:53
+ Log: From: Anton Berezin <tobez@plab.ku.dk>
+ Date: Fri, 17 Jul 1998 11:49:30 +0200 (CEST)
+ Message-Id: <199807170949.LAA18099@lion.plab.ku.dk>
+ Subject: [PATCH 5.005b1] perlcall.pod SAVETMPS/FREETMPS bracket
+ Branch: perl
+ ! pod/perlcall.pod
+____________________________________________________________________________
+[ 1557] By: gsar on 1998/07/19 06:40:33
+ Log: From: "Art Green" <Art_Green@mercmarine.com>
+ Date: Thu, 16 Jul 1998 21:37:05 -0500
+ Message-ID: <86256644.000E61D4.00@FDLTest1.mercmarine.com>
+ Subject: [PATCH]:_75 - Update hints/aix.sh for c_r library
+ Branch: perl
+ ! hints/aix.sh
+____________________________________________________________________________
+[ 1556] By: gsar on 1998/07/19 06:38:17
+ Log: update README.threads
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Thu, 16 Jul 1998 11:10:33 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980716110949.2651J-100000@newton.phys>
+ Subject: Re: Sort of OK: 5.005-beta1 and threads on ppc-powerux-threads
+ Branch: perl
+ ! README.threads
+____________________________________________________________________________
+[ 1555] By: gsar on 1998/07/19 06:36:32
+ Log: From: Scott Henry <scotth@sgi.com>
+ Date: 15 Jul 1998 20:23:02 -0700
+ Message-ID: <yd890lu1nu1.fsf@hoshi.engr.sgi.com>
+ Subject: [PATCH 5.005-beta1] update hints/irix_6.sh
+ Branch: perl
+ ! hints/irix_6.sh
+____________________________________________________________________________
+[ 1554] By: gsar on 1998/07/19 06:35:10
+ Log: From: Spider Boardman <spider@web.zk3.dec.com>
+ Date: Wed, 15 Jul 1998 16:56:48 -0400
+ Message-Id: <199807152056.QAA369057@web.zk3.dec.com>
+ Subject: [PATCH _75] dec_osf hints still wrong
+ Branch: perl
+ ! hints/dec_osf.sh
+____________________________________________________________________________
+[ 1553] By: gsar on 1998/07/19 06:33:29
+ Log: tweak hpux hints in vain attempt to get cppstdin set properly
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Wed, 15 Jul 1998 16:11:43 -0400 (EDT)
+ Subject: Re: HP-UX 11, perl 5.004_04, Oracle 7.3.3.4, DBI 0.93
+ Message-Id: <Pine.SUN.3.96.980715161018.1560D-100000@newton.phys>
+ --
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Thu, 16 Jul 1998 11:37:58 -0400 (EDT)
+ Subject: Re: Configure misses preprocessor on HP-UX
+ Message-Id: <Pine.SUN.3.96.980716113128.2651N-100000@newton.phys>
+ Branch: perl
+ ! hints/hpux.sh
+____________________________________________________________________________
+[ 1552] By: gsar on 1998/07/19 06:26:24
+ Log: From: Tye McQueen <tye@metronet.com>
+ Date: Wed, 15 Jul 1998 13:46:44 -0500 (CDT)
+ Message-Id: <199807151846.AA12653@metronet.com>
+ Subject: Minor debugger fix
+ Branch: perl
+ ! lib/perl5db.pl
+____________________________________________________________________________
+[ 1551] By: gsar on 1998/07/19 06:25:05
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Wed, 15 Jul 1998 14:23:39 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980715135257.1310F-100000@newton.phys>
+ Subject: Re: Configure s?rand support [PATCH 5.004_75] -- better patch
+ Branch: perl
+ ! INSTALL pp.c
+____________________________________________________________________________
+[ 1550] By: gsar on 1998/07/19 06:23:10
+ Log: minor re.pm cleanup
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Date: Wed, 15 Jul 1998 12:41:14 +0100
+ Message-Id: <E0ywPvu-0003V7-00@ursa.cus.cam.ac.uk>
+ Subject: Re: [PATCH 5.004_74]Don't use tainted REs in Basename.pm when building perl
+ Branch: perl
+ ! ext/re/re.pm pod/perldiag.pod
+____________________________________________________________________________
+[ 1549] By: gsar on 1998/07/19 06:20:49
+ Log: export additional symbols on OS/2
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Wed, 15 Jul 1998 06:13:07 -0400 (EDT)
+ Message-Id: <199807151013.GAA11279@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Export more symbols from Perl DLL
+ Branch: perl
+ ! os2/os2.sym
+____________________________________________________________________________
+[ 1548] By: gsar on 1998/07/19 06:18:58
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Wed, 15 Jul 1998 06:10:36 -0400 (EDT)
+ Message-Id: <199807151010.GAA11270@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Minor improvements to perlcc
+ Branch: perl
+ ! utils/perlcc.PL
+____________________________________________________________________________
+[ 1547] By: gsar on 1998/07/19 06:17:22
+ Log: applied slightly tweaked version of patch
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Thu, 16 Jul 1998 15:49:15 -0400 (EDT)
+ Message-Id: <199807161949.PAA08214@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Updated patch to Test::Harness
+ Branch: perl
+ ! lib/Test/Harness.pm
+____________________________________________________________________________
+[ 1546] By: gsar on 1998/07/19 06:11:03
+ Log: improve 'frame' handling in debugger
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Wed, 15 Jul 1998 00:52:10 -0400 (EDT)
+ Message-Id: <199807150452.AAA06685@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Better debugger trace
+ Branch: perl
+ ! lib/perl5db.pl
+____________________________________________________________________________
+[ 1545] By: gsar on 1998/07/19 06:07:51
+ Log: fix and test handling of literal newlines in heredocs
+ From: Gisle Aas <gisle@aas.no>
+ Date: 17 Jul 1998 14:58:25 +0200
+ Message-ID: <m3iukw63da.fsf@furu.g.aas.no>
+ Subject: Re: [PATCH _71] CRs et al
+ --
+ From: larry@wall.org (Larry Wall)
+ Date: Fri, 17 Jul 1998 09:32:35 -0700
+ Message-Id: <199807171632.JAA12959@wall.org>
+ Subject: Re: [PATCH _71] CRs et al
+ Branch: perl
+ ! t/comp/multiline.t toke.c
+____________________________________________________________________________
+[ 1544] By: gsar on 1998/07/19 06:00:12
+ Log: remove possibly unwritable lib/re.pm before overwrite
+ From: larry@wall.org (Larry Wall)
+ Date: Wed, 15 Jul 1998 14:26:03 -0700
+ Message-Id: <199807152126.OAA04623@wall.org>
+ Subject: Re: bug encountered building perl5.005beta1
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 1543] By: gsar on 1998/07/19 05:56:18
+ Log: unsubmitted Changes tweak
+ Branch: perl
+ ! Changes cygwin32/ld2
+____________________________________________________________________________
+[ 1542] By: gsar on 1998/07/19 01:21:22
+ Log: make failed matches return empty list in list context
+ Branch: perl
+ ! pod/perlop.pod pp_hot.c t/op/pat.t
+____________________________________________________________________________
+[ 1541] By: gsar on 1998/07/18 22:27:59
+ Log: remove obsolete perltrap about m//g's pos() reset behavior
+ Branch: perl
+ ! pod/perltrap.pod
+____________________________________________________________________________
+[ 1540] By: nick on 1998/07/18 22:16:26
+ Log: PL_ stuff passes non-threaded on Mingw32
+ (Why did it compile without this fix?)
+ Branch: ansiperl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 1539] By: TimBunce on 1998/07/18 22:04:58
+ Log: Assorted patches:
+
+ Title: "Minor fixes to MakeMaker docs re ExtUtils::Embed"
+ From: Paul Johnson <pjcj@transeda.com>
+ Msg-ID: <19980718155847.D903@west-tip.transeda.com>
+ Files: lib/ExtUtils/MakeMaker.pm
+
+ Title: "Update t/op/array.t (from 5.005 beta 1)"
+ Files: t/op/array.t
+ Branch: maint-5.004/perl
+ ! lib/ExtUtils/MakeMaker.pm t/op/array.t
+____________________________________________________________________________
+[ 1538] By: TimBunce on 1998/07/18 21:57:50
+ Log: Title: "Remove flawed '// with parens or $&' performance patch (Change 662)"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Tim Bunce <Tim.Bunce@ig.co.uk>,
+ larry@wall.org (Larry Wall)
+ Msg-ID: <19980717015308.E6244@ig.co.uk>, <199807171819.LAA13771@wall.org>,
+ <E0yvtzn-0002F9-00@ursa.cus.cam.ac.uk>
+ Files: cop.h embed.h perl.h proto.h regexp.h gv.c interp.sym perl.c pp.c
+ pp_ctl.c pp_hot.c regexec.c scope.c
+ Branch: maint-5.004/perl
+ ! cop.h embed.h gv.c interp.sym perl.c perl.h pp.c pp_ctl.c
+ ! pp_hot.c proto.h regexec.c regexp.h scope.c
+____________________________________________________________________________
+[ 1537] By: nick on 1998/07/18 20:56:58
+ Log: PL_ scheme Builds under Minw32 - some SEGFAULT snags
+ Branch: ansiperl
+ ! doio.c mg.c perl.c pp_hot.c pp_sys.c util.c win32/perllib.c
+ ! win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 1536] By: nick on 1998/07/18 20:50:26
+ Log: Merge latest mainline
+ Branch: ansiperl
+ ! patchlevel.h
+ !> ext/Thread/Thread.xs op.h util.c
+____________________________________________________________________________
+[ 1535] By: nick on 1998/07/18 16:45:29
+ Log: Edited "behind my back" ...
+ Branch: ansiperl
+ ! vms/perly_c.vms
+____________________________________________________________________________
+[ 1534] By: nick on 1998/07/18 16:38:27
+ Log: PL_ stuff for threads
+ Branch: ansiperl
+ ! byterun.c cop.h deb.c doio.c doop.c embed.pl embedvar.h
+ ! ext/B/B.xs ext/Thread/Thread.xs gv.c intrpvar.h mg.c
+ ! miniperlmain.c op.c op.h perl.c perl.h perly.y pp.c pp.h
+ ! pp_ctl.c pp_hot.c pp_sys.c regexec.c run.c scope.c sv.c sv.h
+ ! thread.h toke.c util.c win32/perllib.c
+____________________________________________________________________________
+[ 1533] By: nick on 1998/07/18 14:30:54
+ Log: Builds and passes tests with -DMULTIPLICITY and -DCRIPPLED_CC
+ (still with PERL_GLOBAL_STRUCT) - to cover more #if branches
+ Branch: ansiperl
+ ! embed.pl intrpvar.h perl.c toke.c
+____________________________________________________________________________
+[ 1532] By: nick on 1998/07/18 13:53:03
+ Log: PL_ prefix to all perlvars, part1
+ Builds and passes all tests at one limit i.e. -DPERL_GLOBAL_STRUCT
+ Branch: ansiperl
+ ! XSUB.h av.c bytecode.h byterun.c byterun.h cop.h deb.c doio.c
+ ! doop.c dump.c embed.h embed.pl embedvar.h ext/B/B.xs
+ ! ext/Data/Dumper/Dumper.xs ext/DynaLoader/dl_next.xs
+ ! ext/ODBM_File/ODBM_File.xs ext/Opcode/Opcode.xs
+ ! ext/POSIX/POSIX.xs ext/Socket/Socket.xs ext/attrs/attrs.xs
+ ! ext/re/re.xs gv.c hv.c hv.h lib/ExtUtils/typemap
+ ! lib/ExtUtils/xsubpp mg.c miniperlmain.c op.c perl.c perl.h
+ ! perly.c perly.y pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c regcomp.c
+ ! regcomp.h regexec.c run.c scope.c scope.h sv.c sv.h taint.c
+ ! thrdvar.h toke.c universal.c util.c
+____________________________________________________________________________
+[ 1531] By: gsar on 1998/07/18 08:48:13
+ Log: fix yet another USE_THREADS leak due to failure to free stacks
+ Branch: perl
+ ! ext/Thread/Thread.xs util.c
+____________________________________________________________________________
+[ 1530] By: gsar on 1998/07/18 08:46:58
+ Log: fix major bug in GIMME (introduced in 5.003_96); void contexts were
+ using the context of the enclosing sub!
+ Branch: perl
+ ! op.h
+____________________________________________________________________________
+[ 1529] By: nick on 1998/07/18 08:18:03
+ Log: Integrate post-beta tweaks to ansiperl
+ Branch: ansiperl
+ !> ObjXSub.h embed.h ext/Thread/Thread.xs global.sym gv.c mg.c
+ !> objpp.h op.c perl.c perl.h pp_sys.c proto.h sv.c t/op/substr.t
+ !> t/op/vec.t toke.c util.c
+____________________________________________________________________________
+[ 1528] By: gsar on 1998/07/18 04:23:12
+ Log: fix lvalue leaks stemming from failure to free LvTARG(sv)
+ Branch: perl
+ ! ObjXSub.h embed.h global.sym mg.c objpp.h perl.h proto.h sv.c
+ ! t/op/substr.t t/op/vec.t
+____________________________________________________________________________
+[ 1527] By: gsar on 1998/07/18 02:16:40
+ Log: check ferror() only if read() returned 0
+ Branch: perl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 1526] By: gsar on 1998/07/18 02:08:01
+ Log: fix another CvMUTEXP() leak
+ Branch: perl
+ ! gv.c
+____________________________________________________________________________
+[ 1525] By: TimBunce on 1998/07/18 01:51:52
+ Log: Assorted patches:
+
+ Title: "Fix @a=@a=qw(...) properly"
+ From: Stephen McCamant <alias@mcs.com>
+ Msg-ID: <13742.49404.367751.437966@alias-2.pr.mcs.net>
+ Files: opcode.h
+
+ Title: "Larry's patch to support CR LF in scripts (updated)"
+ From: Gisle Aas <gisle@aas.no>, larry@wall.org (Larry Wall)
+ Msg-ID: <199807120054.RAA19550@wall.org>, <m3iukw63da.fsf@furu.g.aas.no>
+ Files: t/comp/multiline.t toke.c
+
+ Title: "Change getc() docs to match behaviour. Make read() return undef on
+ error."
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807052257.SAA10004@aatma.engin.umich.edu>
+ Files: pod/perlfunc.pod pp_sys.c
+
+ Title: "Update patchls utility"
+ Files: Porting/patchls
+ Branch: maint-5.004/perl
+ ! Porting/patchls opcode.h pod/perlfunc.pod pp_sys.c
+ ! t/comp/multiline.t toke.c
+____________________________________________________________________________
+[ 1524] By: gsar on 1998/07/18 01:22:35
+ Log: fix CvMUTEXP() leaks with -Dusethreads
+ Branch: perl
+ ! op.c toke.c
+____________________________________________________________________________
+[ 1523] By: gsar on 1998/07/18 01:17:28
+ Log: fix $/ init for multiple interpreters/threads
+ Branch: perl
+ ! ext/Thread/Thread.xs perl.c util.c
+____________________________________________________________________________
+[ 1522] By: gsar on 1998/07/18 01:11:07
+ Log: fix missing init that caused RE alternations to fail under
+ -Dusethreads
+ Branch: perl
+ ! util.c
+____________________________________________________________________________
+[ 1521] By: TimBunce on 1998/07/16 22:23:25
+ Log: Assorted patches:
+
+ Title: "Allow $SIG{CHLD}='IGNORE' to work (reap zombies) on Solaris"
+ From: Albert Dvornik <bert@genscan.com>, Chip Salzenberg <chip@perl.org>
+ Msg-ID: <19980708181055.A8005@perlsupport.com>,
+ <tqn2adkvge.fsf@puma.genscan.com>
+ Files: util.c
+
+ Title: "Document perltrap on precedence of keys/values/each"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807151857.OAA04704@aatma.engin.umich.edu>
+ Files: pod/perltrap.pod
+
+ Title: "perlbook.pod patch"
+ From: Tom Christiansen <tchrist@chthon.perl.com>
+ Msg-ID: <199807140037.SAA04556@chthon.perl.com>
+ Files: pod/perlbook.pod
+
+ Title: "perlmod.pod patch"
+ From: Tom Christiansen <tchrist@chthon.perl.com>
+ Msg-ID: <199807140109.TAA04678@chthon.perl.com>
+ Files: pod/perlmod.pod
+
+ Title: "Fix bug in IO::Handle->input_record_separator"
+ From: Robin Barker <rmb1@cise.npl.co.uk>, Swen Thuemmler
+ <Swen.Thuemmler@paderlinx.de>
+ Msg-ID: <199807161400.PAA25532@tempest.cise.npl.co.uk>,
+ <Pine.GSO.4.00.9807161649380.6537-100000@rmail>
+ Files: ext/IO/lib/IO/Handle.pm
+
+ Title: "update h2ph, Math::Complex and Math::Trig (from 5.005 beta 1)"
+ Files: lib/Math/Complex.pm lib/Math/Trig.pm t/lib/complex.t t/lib/h2ph.t
+ t/lib/trig.t utils/h2ph.PL
+
+ Title: "Update hints/irix_6.sh"
+ From: Scott Henry <scotth@sgi.com>
+ Msg-ID: <yd890lu1nu1.fsf@hoshi.engr.sgi.com>
+ Files: hints/irix_6.sh
+
+ Title: "Configure misses preprocessor on HP-UX (further fix)"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980716113128.2651N-100000@newton.phys>
+ Files: hints/hpux.sh
+
+ Title: "update perlbug to v1.26 (from 5.005 beta 1)"
+ Files: utils/perlbug.PL
+ Branch: maint-5.004/perl
+ ! ext/IO/lib/IO/Handle.pm hints/hpux.sh hints/irix_6.sh
+ ! lib/Math/Complex.pm lib/Math/Trig.pm pod/perlbook.pod
+ ! pod/perlmod.pod pod/perltrap.pod t/lib/complex.t t/lib/h2ph.t
+ ! t/lib/trig.t util.c utils/h2ph.PL utils/perlbug.PL
+____________________________________________________________________________
+[ 1520] By: TimBunce on 1998/07/15 21:24:12
+ Log: Assorted patches:
+
+ Title: "Add stub attrs.pm"
+ From: Graham Barr <gbarr@ti.com>, Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <19980713163312.A18222@asic.sc.ti.com>,
+ <199807132140.RAA09583@aatma.engin.umich.edu>
+ Files: MANIFEST lib/attrs.pm
+
+ Title: "Fix @a=@a=qw(...)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Stephen McCamant
+ <alias@mcs.com>
+ Msg-ID: <13737.12300.950886.821143@alias-2.pr.mcs.net>,
+ <199807122351.TAA05649@aatma.engin.umich.edu>
+ Files: op.c opcode.pl t/op/array.t
+
+ Title: "Fix 'PERL_DESTRUCT_LEVEL=2 ./perl -DD -e 1' loop"
+ From: Gisle Aas <gisle@aas.no>, Stephen McCamant <alias@mcs.com>
+ Msg-ID: <13739.55551.205810.338648@alias-2.pr.mcs.net>,
+ <m33ec4jdwn.fsf@furu.g.aas.no>
+ Files: sv.c
+
+ Title: "Make Power MachTen use vfork() and system malloc()"
+ From: Dominic Dunlop <domo@computer.org>, Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <v03110700b1c95b010820@[195.95.102.91]>
+ Files: hints/machten.sh malloc.c
+
+ Title: "Use REG_INFTY in place of hardwired constant"
+ From: Dominic Dunlop <domo@computer.org>
+ Msg-ID: <v03110703b1ca662c44f8@[195.95.102.91]>
+ Files: regcomp.h regcomp.c regexec.c
+
+ Title: "Minor debugger fix (history adds an extra newline)"
+ From: Tye McQueen <tye@metronet.com>
+ Msg-ID: <199807151846.AA12653@metronet.com>
+ Files: lib/perl5db.pl
+
+ Title: "Protect Term::ReadLine against non-default $/ value"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>,
+ kstar@chapin.edu@ig.co.uk ()
+ Msg-ID: <19980713151749.G8596@O2.chapin.edu>,
+ <199807132139.RAA11270@monk.mps.ohio-state.edu>
+ Files: lib/Term/ReadLine.pm
+
+ Title: "Fix HP-UX 11 build (cppstdin)"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980715161018.1560D-100000@newton.phys>
+ Files: Configure hints/hpux.sh
+
+ Title: "VMS filetest operator fixup (SS$_ACCONFLICT)"
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Msg-ID: <3.0.5.32.19980702135255.00a6ad90@ous.edu>
+ Files: vms/vms.c
+ Branch: maint-5.004/perl
+ + lib/attrs.pm
+ ! Configure MANIFEST hints/hpux.sh hints/machten.sh
+ ! lib/Term/ReadLine.pm lib/perl5db.pl malloc.c op.c opcode.pl
+ ! regcomp.c regcomp.h regexec.c sv.c t/op/array.t vms/vms.c
+____________________________________________________________________________
+[ 1519] By: nick on 1998/07/15 18:56:17
+ Log: Integrate mainline at beta1
+ Branch: ansiperl
+ +> Porting/p4d2p README.mpeix Todo-5.005
+ +> ext/DynaLoader/dl_mpeix.xs ext/re/hints/mpeix.pl
+ +> mpeix/mpeixish.h mpeix/nm mpeix/relink perly_c.diff
+ +> pod/perld4.pod pod/perlport.pod t/lib/ipc_sysv.t
+ - Todo.5.005 lib/Bundle/CPAN.pm perly.c.diff pod/perldelta4.pod
+ - t/op/ipcmsg.t t/op/ipcsem.t
+ !> (integrate 167 files)
+
+----------------
+Version 5.004_75 5.005 Public Beta, Issue 1
+----------------
+
+____________________________________________________________________________
+[ 1518] By: gsar on 1998/07/15 10:01:41
+ Log: add stub docs for ext/B, other minor tweaks
+ Branch: perl
+ ! Changes Porting/config_H config_h.SH ext/B/B.pm
+ ! ext/B/B/Asmdata.pm ext/B/B/Assembler.pm ext/B/B/Bblock.pm
+ ! ext/B/B/Bytecode.pm ext/B/B/C.pm ext/B/B/CC.pm
+ ! ext/B/B/Debug.pm ext/B/B/Disassembler.pm ext/B/B/Showlex.pm
+ ! ext/B/B/Stackobj.pm ext/B/B/Terse.pm ext/B/O.pm sv.c
+____________________________________________________________________________
+[ 1517] By: gsar on 1998/07/15 08:27:15
+ Log: up patchlevel to 75 (Beta, Issue 1), add podpatch
+ From: abigail@fnx.com
+ Date: Wed, 15 Jul 1998 04:03:44 -0400 (EDT)
+ Message-ID: <19980715080344.21975.qmail@betelgeuse.wayne.fnx.com>
+ Subject: [PATCH 5.004_74] pod/perlop.pod
+ Branch: perl
+ ! Changes patchlevel.h pod/perlop.pod win32/Makefile
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 1516] By: gsar on 1998/07/15 08:04:24
+ Log: From: abigail@fnx.com
+ Date: Wed, 15 Jul 1998 03:47:56 EDT
+ Message-Id: <19980715074756.21868.qmail@betelgeuse.wayne.fnx.com>
+ Subject: [PATCH 5.004_74] pod/pod2man.PL Fix use of < inside C<>
+ Branch: perl
+ ! pod/pod2man.PL
+____________________________________________________________________________
+[ 1515] By: gsar on 1998/07/15 08:02:14
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Wed, 15 Jul 1998 03:49:24 EDT
+ Message-Id: <199807150749.DAA09177@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] Additional targets for OS/2 build
+ Branch: perl
+ ! os2/Makefile.SHs
+____________________________________________________________________________
+[ 1514] By: gsar on 1998/07/15 07:58:29
+ Log: rename some long file names to be 8.3 truncation-safe
+ Branch: perl
+ +> Todo-5.005 perly_c.diff pod/perld4.pod
+ - Todo.5.005 perly.c.diff pod/perldelta4.pod
+ ! MANIFEST Porting/pumpkin.pod perly.fixer
+____________________________________________________________________________
+[ 1513] By: gsar on 1998/07/15 07:35:29
+ Log: minor tweaks to docs on qr//
+ Branch: perl
+ ! ext/re/re.pm pod/perldelta.pod pod/perlop.pod pod/perlre.pod
+____________________________________________________________________________
+[ 1512] By: gsar on 1998/07/15 07:06:02
+ Log: applied patch, with tab tweak suggest by Peter Prymmer
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Date: Tue, 14 Jul 1998 16:41:14 -0700
+ Message-Id: <3.0.5.32.19980714164114.00a3e2a0@ous.edu>
+ Subject: [PATCH 5.004_74]VMS build cleanups
+ Branch: perl
+ ! vms/descrip_mms.template
+____________________________________________________________________________
+[ 1511] By: gsar on 1998/07/15 07:03:33
+ Log: allow perlbug -ok when STDIN it not a tty
+ From: Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Date: Wed, 15 Jul 1998 03:24:56 +0200
+ Message-Id: <l03130302b1d1b1e7c2a0@[194.222.64.89]>
+ Subject: Re: [NOT OK] 5.004_74: "make ok" not ok in IRIX 6.2
+ Branch: perl
+ ! utils/perlbug.PL
+____________________________________________________________________________
+[ 1510] By: gsar on 1998/07/15 06:59:43
+ Log: From: "Art Green" <Art_Green@mercmarine.com>
+ Date: Tue, 14 Jul 1998 20:53:48 -0500
+ Message-ID: <86256642.0004D7AB.00@FDLTest1.mercmarine.com>
+ Subject: [PATCH]:_74 - Allow Configure to recognize _AIX41 & _POWER compiler defines
+ Branch: perl
+ ! Configure
+____________________________________________________________________________
+[ 1509] By: gsar on 1998/07/15 06:57:50
+ Log: typecast long vs. IV compares in pp_flip/pp_flop
+ Branch: perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 1508] By: gsar on 1998/07/15 06:50:49
+ Log: don't copy foreach itervar when no external refs exist
+ From: Gisle Aas <gisle@aas.no>
+ Date: 15 Jul 1998 03:35:25 +0200
+ Message-ID: <m33ec3nbfm.fsf@furu.g.aas.no>
+ Subject: Re: Testcase for 1..n closure change
+ Branch: perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 1507] By: gsar on 1998/07/15 06:46:41
+ Log: applied patch, regen headers
+ From: Stephen McCamant <alias@mcs.com>
+ Date: Tue, 14 Jul 1998 19:56:47 -0500 (CDT)
+ Message-ID: <13739.64763.792570.626015@alias-2.pr.mcs.net>
+ Subject: B::Deparse update for qr// and regcreset
+ Branch: perl
+ ! ext/B/B/Deparse.pm opcode.h opcode.pl
+____________________________________________________________________________
+[ 1506] By: gsar on 1998/07/15 06:43:04
+ Log: make pregcomp et al VIRTUAL again for PERL_OBJECT
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Date: Tue, 14 Jul 1998 16:40:30 -0700
+ Message-ID: <000301bdaf80$c93d14a0$a32fa8c0@tau.Active>
+ Subject: [PATCH 5.004_74]
+ Branch: perl
+ ! proto.h
+____________________________________________________________________________
+[ 1505] By: gsar on 1998/07/15 06:41:43
+ Log: dont use sv_dump() in -DD diagnostic
+ From: Gisle Aas <gisle@aas.no>
+ Date: 14 Jul 1998 23:55:36 +0200
+ Message-ID: <m33ec4jdwn.fsf@furu.g.aas.no>
+ Subject: [PATCH] Fix 'PERL_DESTRUCT_LEVEL=2 ./perl -DD -e 1' loop
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 1504] By: gsar on 1998/07/15 06:39:37
+ Log: add a few more thread.t tests
+ Branch: perl
+ ! t/lib/thread.t
+____________________________________________________________________________
+[ 1503] By: gsar on 1998/07/15 06:31:33
+ Log: fix thread.t ('join $t' ne '$t->join' !)
+ Branch: perl
+ ! t/lib/thread.t
+____________________________________________________________________________
+[ 1502] By: gsar on 1998/07/15 06:26:00
+ Log: From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Wed, 15 Jul 1998 01:45:57 +0300 (EET DST)
+ Message-Id: <199807142245.BAA09651@alpha.hut.fi>
+ Subject: [PATCH] 5.004_74: MPE/iX final touches
+ Branch: perl
+ ! installperl lib/File/Copy.pm
+____________________________________________________________________________
+[ 1501] By: gsar on 1998/07/15 05:59:49
+ Log: apply (reversed) patch
+ From: Peter Wolfe <wolfe@titan.teloseng.com>
+ Date: Tue, 14 Jul 1998 13:01:58 -0700 (PDT)
+ Message-Id: <199807142001.NAA26550@titan.teloseng.com>
+ Subject: NOT_OK: perl 5.00474 on SCO 3.2v5.0.4
+ Branch: perl
+ ! ext/IPC/SysV/SysV.xs
+____________________________________________________________________________
+[ 1500] By: gsar on 1998/07/15 05:57:39
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Tue, 14 Jul 1998 14:14:59 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980714141346.29710D-100000@newton.phys>
+ Subject: [PATCH 5.004_74] Config_74-01
+ Branch: perl
+ ! Configure MANIFEST Porting/Glossary Porting/config.sh
+ ! Porting/config_H Porting/pumpkin.pod config_h.SH
+ ! vms/subconfigure.com win32/config.bc win32/config.gc
+ ! win32/config.vc
+____________________________________________________________________________
+[ 1499] By: gsar on 1998/07/15 05:48:38
+ Log: From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Tue, 14 Jul 1998 21:35:02 +0300 (EET DST)
+ Message-Id: <199807141835.VAA09030@alpha.hut.fi>
+ Subject: [PATCH] 5.004_74: trig.t: math inaccuracy fudge for unicos
+ Branch: perl
+ ! t/lib/trig.t
+____________________________________________________________________________
+[ 1498] By: gsar on 1998/07/15 05:47:33
+ Log: -w, strict clean perldoc (via PM)
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Tue, 14 Jul 98 17:22:01 BST
+ Message-Id: <18695.9807141622@tempest.cise.npl.co.uk>
+ Subject: [PATCH 5.004_74] perldoc.PL
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 1497] By: gsar on 1998/07/15 05:35:54
+ Log: add comment about cpprun etc., to hints/hpux.sh
+ Branch: perl
+ ! hints/hpux.sh
+____________________________________________________________________________
+[ 1496] By: gsar on 1998/07/15 05:15:16
+ Log: fix warning from CGI::Carp
+ Branch: perl
+ ! lib/CGI/Carp.pm
+____________________________________________________________________________
+[ 1495] By: gsar on 1998/07/14 23:47:18
+ Log: fix off-by-one in win32 registry handling
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Date: Tue, 14 Jul 1998 07:39:06 -0700
+ Message-ID: <000401bdaf35$27489e80$a32fa8c0@tau.Active>
+ Subject: [PATCH 5.004_73]
+ Branch: perl
+ ! win32/win32.c
+____________________________________________________________________________
+[ 1494] By: gsar on 1998/07/14 23:45:58
+ Log: doc patches from Gisle Aas <gisle@aas.no>
+ Date: 14 Jul 1998 16:18:31 +0200
+ Message-ID: <m33ec4cy88.fsf@furu.g.aas.no>
+ Subject: [PATCH] substr/splice changes for perldelta.pod
+ --
+ Date: 14 Jul 1998 20:31:27 +0200
+ Message-ID: <m3hg0kqo74.fsf@furu.g.aas.no>
+ Subject: [PATCH] Duplicate description of use integer %
+ Branch: perl
+ ! pod/perldelta.pod pod/perlop.pod
+____________________________________________________________________________
+[ 1493] By: gsar on 1998/07/14 23:39:31
+ Log: File/Spec.pm needs trailing newline
+ Branch: perl
+ ! lib/File/Spec.pm
+____________________________________________________________________________
+[ 1492] By: gsar on 1998/07/14 21:43:03
+ Log: unsubmitted _74 tweaks
+ Branch: perl
+ ! Changes mpeix/nm mpeix/relink pod/perldelta.pod
+ ! pod/perldiag.pod
+
+----------------
+Version 5.004_74
+----------------
+
+____________________________________________________________________________
+[ 1491] By: gsar on 1998/07/14 08:48:28
+ Log: up patchlevel to 74; introduce distinct archname for PERL_OBJECT
+ Branch: perl
+ ! Changes patchlevel.h pod/perlhist.pod win32/Makefile
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 1490] By: gsar on 1998/07/14 08:31:13
+ Log: From: Gisle Aas <gisle@aas.no>
+ Date: 14 Jul 1998 10:20:34 +0200
+ Message-Id: <m3hg0k973h.fsf@furu.g.aas.no>
+ Subject: [PATCH] Make -DP work (and readable)
+ Branch: perl
+ ! run.c
+____________________________________________________________________________
+[ 1489] By: gsar on 1998/07/14 08:23:46
+ Log: fix function parameter autovivification for pseudohashes
+ Branch: perl
+ ! mg.c t/op/avhv.t
+____________________________________________________________________________
+[ 1488] By: gsar on 1998/07/14 07:34:45
+ Log: merge changes#1423,1465 from maintbranch; checkin two missed files
+ from earlier changes#1461,1478
+ Branch: perl
+ ! pod/perldiag.pod pod/perlfunc.pod pod/perlop.pod pp_sys.c
+ ! t/TEST t/lib/thread.t t/op/local.t t/op/pat.t t/op/regexp.t
+ ! t/op/substr.t t/op/vec.t
+____________________________________________________________________________
+[ 1487] By: gsar on 1998/07/14 07:04:54
+ Log: tweak t/lib/thread.t
+ Branch: perl
+ ! t/lib/thread.t
+____________________________________________________________________________
+[ 1486] By: gsar on 1998/07/14 06:38:15
+ Log: applied patch, slightly tweaked
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Date: Mon, 13 Jul 1998 11:52:27 -0700
+ Message-Id: <3.0.5.32.19980713115227.00a73970@ous.edu>
+ Subject: [PATCH 5.004_73]Get re module working on VMS
+ Branch: perl
+ ! ext/re/Makefile.PL perl.h proto.h
+____________________________________________________________________________
+[ 1485] By: gsar on 1998/07/14 06:32:58
+ Log: add Porting/p4d2p
+ Branch: perl
+ + Porting/p4d2p
+ ! MANIFEST
+____________________________________________________________________________
+[ 1484] By: gsar on 1998/07/14 06:08:20
+ Log: doc patches from Tom Christiansen <tchrist@chthon.perl.com> (via PM)
+ Date: Mon, 13 Jul 1998 19:09:09 -0600
+ Message-Id: <199807140109.TAA04678@chthon.perl.com>
+ Subject: perlmod.pod patch
+ --
+ Date: Mon, 13 Jul 1998 18:37:07 -0600
+ Message-Id: <199807140037.SAA04556@chthon.perl.com>
+ Subject: perlbook.pod patch
+ Branch: perl
+ ! pod/perlbook.pod pod/perlmod.pod
+____________________________________________________________________________
+[ 1483] By: gsar on 1998/07/14 06:04:25
+ Log: OS/2 update
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199807132336.TAA12967@monk.mps.ohio-state.edu>
+ Date: Mon, 13 Jul 1998 19:36:05 -0400 (EDT)
+ Subject: [PATCH 5.004_72] OS/2 system() and friends additions
+ Branch: perl
+ ! README.os2 hints/os2.sh os2/Changes os2/os2.c t/op/magic.t
+____________________________________________________________________________
+[ 1482] By: gsar on 1998/07/14 06:01:12
+ Log: more VMS patches from Dan Sugalski <sugalskd@osshe.edu>
+ Date: Mon, 13 Jul 1998 16:37:49 -0700
+ Message-Id: <3.0.5.32.19980713163749.00af1c40@ous.edu>
+ Subject: [PATCH 5.004_73]t/io/iprefix.t patch for VMS
+ --
+ Date: Mon, 13 Jul 1998 15:51:09 -0700
+ Message-Id: <3.0.5.32.19980713155109.00a52c30@ous.edu>
+ Subject: [PATCH5.004_73]Tweak t/lib/cgi-html.t to work on VMS
+ Branch: perl
+ ! t/io/iprefix.t t/lib/cgi-html.t
+____________________________________________________________________________
+[ 1481] By: gsar on 1998/07/14 05:57:36
+ Log: From: Dan Sugalski <sugalskd@osshe.edu>
+ Date: Mon, 13 Jul 1998 15:41:53 -0700
+ Message-Id: <3.0.5.32.19980713154153.00a87be0@ous.edu>
+ Subject: [PATCH 5.004_73]Fix t/base/rs.t test failures on VMS
+ Branch: perl
+ ! t/base/rs.t
+____________________________________________________________________________
+[ 1480] By: gsar on 1998/07/14 05:56:14
+ Log: From: Dan Sugalski <sugalskd@osshe.edu>
+ Message-Id: <3.0.5.32.19980713150427.00b2a540@ous.edu>
+ Date: Mon, 13 Jul 1998 15:04:27 -0700
+ Subject: [PATCH 5.004_73]Thread tweak for VMS.C
+ Branch: perl
+ ! vms/vms.c
+____________________________________________________________________________
+[ 1479] By: gsar on 1998/07/14 05:55:13
+ Log: From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Date: Mon, 13 Jul 1998 23:13:43 +0200
+ Message-ID: <19980713231343.A178@cdata.tvnet.hu>
+ Subject: [PATCH _72] Configure problem on dos-djgpp
+ Branch: perl
+ ! Configure
+____________________________________________________________________________
+[ 1478] By: gsar on 1998/07/14 05:53:08
+ Log: add files and tweaks needed for MPE/iX port (via PM)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Tue, 14 Jul 1998 00:07:30 +0300 (EET DST)
+ Message-Id: <199807132107.AAA20603@alpha.hut.fi>
+ Subject: MPE/iX patches for _73
+ Branch: perl
+ + README.mpeix ext/DynaLoader/dl_mpeix.xs ext/re/hints/mpeix.pl
+ + mpeix/mpeixish.h mpeix/nm mpeix/relink
+ ! MANIFEST ext/Socket/Socket.xs hints/mpeix.sh installperl
+ ! lib/File/Copy.pm perl.c perl.h pod/perldelta.pod
+____________________________________________________________________________
+[ 1477] By: gsar on 1998/07/14 04:23:28
+ Log: added suggested patch (via PM), tweaked to implicitly specify -DDEBUGGING
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Mon, 13 Jul 1998 16:50:55 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980713164922.28314B-100000@newton.phys>
+ Subject: Re: _70 and Devel::RE
+ Branch: perl
+ ! ext/re/Makefile.PL ext/re/re.xs regcomp.c regexec.c
+____________________________________________________________________________
+[ 1476] By: gsar on 1998/07/14 04:06:25
+ Log: minor Configure nits
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Mon, 13 Jul 1998 23:25:27 +0300 (EET DST)
+ Message-Id: <199807132025.XAA10771@alpha.hut.fi>
+ Subject: Configure patches for MVS (and one x2p/Makefile.SH)
+ Branch: perl
+ ! Configure x2p/Makefile.SH
+____________________________________________________________________________
+[ 1475] By: gsar on 1998/07/14 03:59:56
+ Log: From: Dan Sugalski <sugalskd@osshe.edu>
+ Date: Mon, 13 Jul 1998 12:54:19 -0700
+ Message-Id: <3.0.5.32.19980713125419.009e0100@ous.edu>
+ Subject: [PATCH 5.004_73] Fixes to the VMS configuration system
+ Branch: perl
+ ! vms/munchconfig.c vms/subconfigure.com
+____________________________________________________________________________
+[ 1474] By: gsar on 1998/07/14 03:58:13
+ Log: make Term::Readline::get_line() independent of caller's $/
+ From: kstar@chapin.edu
+ Date: Mon, 13 Jul 1998 15:17:49 -0400
+ Message-ID: <19980713151749.G8596@O2.chapin.edu>
+ Subject: [PATCH] Was: CPAN.pm still fails
+ Branch: perl
+ ! lib/Term/ReadLine.pm
+____________________________________________________________________________
+[ 1473] By: gsar on 1998/07/14 03:55:29
+ Log: fix $trnl interpolation in here-docs (via PM)
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Mon, 13 Jul 1998 15:49:00 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980713151243.28129F-100000@newton.phys>
+ Subject: Re: [PATCH] 5.004_73: Re: Configure/trnl craziness
+ Branch: perl
+ ! Configure
+____________________________________________________________________________
+[ 1472] By: gsar on 1998/07/14 03:50:18
+ Log: From: Dominic Dunlop <domo@ppp52.vo.lu>
+ Date: Mon, 13 Jul 1998 15:55:09 +0100 (WET DST)
+ Message-Id: <199807131455.PAA23621@ppp52.vo.lu>
+ Subject: Not OK: perl 5.00473 on powerpc-machten 4.1 [PATCH 5.004_73]
+ Branch: perl
+ ! hints/machten.sh
+____________________________________________________________________________
+[ 1471] By: gsar on 1998/07/14 03:49:07
+ Log: From: Dan Sugalski <sugalskd@osshe.edu>
+ Message-Id: <3.0.5.32.19980713123005.00b6be50@ous.edu>
+ Date: Mon, 13 Jul 1998 12:30:05 -0700
+ Subject: [PATCH 5.004_73] Add Data::Dumper and re modules to VMS config stuff
+ Branch: perl
+ ! configure.com vms/descrip_mms.template
+____________________________________________________________________________
+[ 1470] By: gsar on 1998/07/14 03:40:14
+ Log: consistently refer to functions as C<foo()>
+ From: abigail@fnx.com
+ Date: Mon, 13 Jul 1998 03:04:24 -0400 (EDT)
+ Message-ID: <19980713070424.19841.qmail@betelgeuse.wayne.fnx.com>
+ Subject: Re: [PATCH 5.004_71] pod/perlfunc.pod
+ Branch: perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 1469] By: gsar on 1998/07/14 03:35:06
+ Log: From: Tom Hughes <thh@cyberscience.com>
+ Date: 13 Jul 1998 09:34:16 +0100
+ Message-ID: <yekk95i175j.fsf@elva.cyberscience.com>
+ Subject: [PATCH 5.004_72] Fix d_Gconvert definition in hints/svr4.sh
+ Branch: perl
+ ! hints/svr4.sh
+____________________________________________________________________________
+[ 1468] By: gsar on 1998/07/14 03:34:03
+ Log: From: andreas.koenig@kulturbox.de (Andreas J. Koenig)
+ Date: 13 Jul 1998 11:16:27 +0200
+ Message-ID: <sfc90lyqff8.fsf@dubravka.in-berlin.de>
+ Subject: Parallel Makefiles
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+____________________________________________________________________________
+[ 1467] By: gsar on 1998/07/14 03:31:39
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 13 Jul 1998 00:12:19 -0400 (EDT)
+ Message-Id: <199807130412.AAA27128@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_72] t/io/pipe.t - completely broken?
+ Branch: perl
+ ! t/io/pipe.t
+____________________________________________________________________________
+[ 1466] By: gsar on 1998/07/14 03:29:25
+ Log: minor tweaks to perldelta and README.win32
+ Branch: perl
+ ! Changes README.win32 pod/perldelta.pod
+____________________________________________________________________________
+[ 1465] By: TimBunce on 1998/07/13 21:33:45
+ Log: Assorted patches:
+
+ Title: "Fix string substitution returncode problem"
+ From: Dominic Dunlop <domo@vo.lu>, Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805271236.IAA28213@aatma.engin.umich.edu>,
+ <v03110700b191a557f041@[195.95.102.114]>
+ Files: pp_hot.c
+
+ Title: "umask EXPR is fatal only if (EXPR & 0700) > 0"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807111656.MAA03310@aatma.engin.umich.edu>
+ Files: pod/perldiag.pod pp_sys.c
+
+ Title: "Remove reference to qsort from perlfunc.pod"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807111923.PAA05124@aatma.engin.umich.edu>
+ Files: pod/perlfunc.pod
+
+ Title: "Deprecate AvFILL in favor of av_len()"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807111945.PAA05489@aatma.engin.umich.edu>
+ Files: pod/perlguts.pod
+
+ Title: "Further clarify effects of using quotes with m operator"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199806201921.PAA03829@aatma.engin.umich.edu>
+ Files: pod/perlop.pod
+
+ Title: "Add PERL_DESTRUCT_LEVEL=2 to test suite"
+ From: Tim Bunce
+ Files: t/TEST t/op/local.t t/op/pat.t t/op/regexp.t t/op/substr.t t/op/vec.t
+ Branch: maint-5.004/perl
+ ! pod/perldiag.pod pod/perlfunc.pod pod/perlguts.pod
+ ! pod/perlop.pod pp_hot.c pp_sys.c t/TEST t/op/local.t
+ ! t/op/pat.t t/op/regexp.t t/op/substr.t t/op/vec.t toke.c
+
+----------------
+Version 5.004_73
+----------------
+
+____________________________________________________________________________
+[ 1464] By: gsar on 1998/07/13 04:41:07
+ Log: up patchlevel to 73, update Changes &c.
+ Branch: perl
+ ! Changes patchlevel.h pod/perlhist.pod t/op/array.t
+ ! win32/Makefile win32/config_H.bc win32/config_H.gc
+ ! win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1463] By: gsar on 1998/07/13 02:58:51
+ Log: avoid empty rm -f in MM_Unix.pm
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+____________________________________________________________________________
+[ 1462] By: gsar on 1998/07/13 02:54:52
+ Log: update perldelta
+ Branch: perl
+ ! pod/perldelta.pod
+____________________________________________________________________________
+[ 1461] By: gsar on 1998/07/13 02:44:30
+ Log: added patch, tweaked PERL_OBJECT things
+ From: Graham Barr <gbarr@pobox.com>
+ Date: Sun, 12 Jul 1998 19:57:47 CDT
+ Message-Id: <19980712195747.C493@pobox.com>
+ Subject: [ PATCH perl5.004_72] patch to add qr//
+ Branch: perl
+ ! dump.c embed.h ext/Opcode/Opcode.pm global.sym globals.c
+ ! keywords.h keywords.pl op.c op.h opcode.h opcode.pl
+ ! pod/perlfunc.pod pp.c pp_hot.c pp_proto.h proto.h regcomp.c
+ ! regexp.h sv.c t/op/pat.t toke.c
+____________________________________________________________________________
+[ 1460] By: gsar on 1998/07/13 01:25:07
+ Log: add a few more PURIFY guards
+ Branch: perl
+ ! av.c sv.c
+____________________________________________________________________________
+[ 1459] By: gsar on 1998/07/12 23:38:31
+ Log: add tests for change#1458 and then some
+ Branch: perl
+ ! t/op/array.t
+____________________________________________________________________________
+[ 1458] By: gsar on 1998/07/12 22:42:47
+ Log: apply patch for smarter AASSIGN_COMMON detection; regen headers
+ From: Stephen McCamant <alias@mcs.com>
+ Date: Sun, 12 Jul 1998 17:17:00 CDT
+ Message-Id: <13737.12300.950886.821143@alias-2.pr.mcs.net>
+ Subject: [PATCH] @a=@a=qw(1) not working, both 5.004_04 and 5.004_71
+ Branch: perl
+ ! op.c opcode.h opcode.pl
+____________________________________________________________________________
+[ 1457] By: gsar on 1998/07/12 22:06:05
+ Log: small tweaks from Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Branch: perl
+ ! Configure Makefile.SH ext/Socket/Socket.xs perl.c
+____________________________________________________________________________
+[ 1456] By: gsar on 1998/07/12 21:56:39
+ Log: From: Doug MacEachern <dougm@pobox.com>
+ Date: Sun, 12 Jul 1998 14:29:29 -0400
+ Message-Id: <199807121829.OAA00525@postman.opengroup.org>
+ Subject: [PATCH 5.004_72] Embed.pm support for PERL_OBJECT
+ Branch: perl
+ ! lib/ExtUtils/Embed.pm
+____________________________________________________________________________
+[ 1455] By: gsar on 1998/07/12 21:54:02
+ Log: applied installperl patch, corrected other little nits
+ From: andreas.koenig@kulturbox.de (Andreas J. Koenig)
+ Date: 12 Jul 1998 16:27:21 +0200
+ Message-ID: <sfcn2afrvp2.fsf@dubravka.in-berlin.de>
+ Subject: [5.004_72] installperl tweak
+ Branch: perl
+ ! Changes Configure README.win32 installperl win32/makefile.mk
+____________________________________________________________________________
+[ 1454] By: gsar on 1998/07/12 10:14:24
+ Log: update MANIFEST, Changes
+ Branch: perl
+ - lib/Bundle/CPAN.pm
+ ! Changes MANIFEST
+
+----------------
+Version 5.004_72
+----------------
+
+____________________________________________________________________________
+[ 1453] By: gsar on 1998/07/12 10:04:33
+ Log: merge changes 1424, 1428 from maintbranch
+ Branch: perl
+ ! Porting/makerel ext/re/re.pm lib/Sys/Syslog.pm
+____________________________________________________________________________
+[ 1452] By: gsar on 1998/07/12 09:46:40
+ Log: patchlevel up to 72, update Changes, minor tweaks to win32/config*
+ and README.win32
+ Branch: perl
+ ! Changes README.win32 patchlevel.h win32/Makefile
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 1451] By: gsar on 1998/07/12 07:01:26
+ Log: generic Configure mods and HAS_GROUP additions to help MiNT/MPEix/MVS
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Sat, 11 Jul 1998 17:51:07 +0300 (EET DST)
+ Message-Id: <199807111451.RAA27010@alpha.hut.fi>
+ Subject: M3 "generic" parts
+ Branch: perl
+ ! Configure Makefile.SH config_h.SH ext/POSIX/POSIX.xs
+ ! ext/SDBM_File/sdbm/sdbm.h lib/ExtUtils/MM_Unix.pm
+ ! makedepend.SH mv-if-diff perl.h plan9/plan9ish.h pp_sys.c
+ ! unixish.h vms/subconfigure.com vms/vmsish.h win32/config_H.bc
+ ! win32/config_H.gc x2p/Makefile.SH
+____________________________________________________________________________
+[ 1450] By: gsar on 1998/07/12 06:38:27
+ Log: various tweaks for PERL_OBJECT build & test
+ Branch: perl
+ ! globals.c iperlsys.h win32/GenCAPI.pl win32/Makefile
+ ! win32/makefile.mk win32/win32.c win32/win32iop.h
+____________________________________________________________________________
+[ 1449] By: gsar on 1998/07/12 06:29:23
+ Log: From: andreas.koenig@kulturbox.de (Andreas J. Koenig)
+ Date: 12 Jul 1998 08:22:16 +0200
+ Message-Id: <sfck95jtwpz.fsf@dubravka.in-berlin.de>
+ Subject: [5.004_71] Patch: let CPAN.pm work with threaded perl
+ Branch: perl
+ ! lib/CPAN.pm lib/SelfLoader.pm
+____________________________________________________________________________
+[ 1448] By: gsar on 1998/07/12 05:10:50
+ Log: make RE engine threadsafe; -Dusethreads builds, tests on Solaris,
+ and runs regexes in 1000s of threads without crashing; also fixed
+ statcache not being thread-local
+ Branch: perl
+ ! embed.h embedvar.h ext/Thread/Thread.xs ext/re/re.xs
+ ! intrpvar.h op.c perl.c pp_ctl.c regcomp.c regexec.c sv.c
+ ! t/lib/thread.t thrdvar.h util.c
+____________________________________________________________________________
+[ 1447] By: gsar on 1998/07/12 02:40:45
+ Log: From: Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Date: Sun, 12 Jul 1998 03:23:04 +0200
+ Message-Id: <l03130300b1cdbff87621@[194.222.64.89]>
+ Subject: Re: perlbug doesn't check that save succeeded
+ Branch: perl
+ ! utils/perlbug.PL
+____________________________________________________________________________
+[ 1446] By: gsar on 1998/07/12 02:39:24
+ Log: be generous about CRs
+ From: larry@wall.org (Larry Wall)
+ Date: Sat, 11 Jul 1998 17:54:21 PDT
+ Message-Id: <199807120054.RAA19550@wall.org>
+ Subject: [PATCH _71] CRs et al
+ Branch: perl
+ ! toke.c
+____________________________________________________________________________
+[ 1445] By: gsar on 1998/07/12 02:11:16
+ Log: fix pp_caller() to fully traverse stacklevels
+ Branch: perl
+ ! objpp.h pp_ctl.c proto.h t/op/runlevel.t
+____________________________________________________________________________
+[ 1444] By: gsar on 1998/07/11 23:43:37
+ Log: add patch, along with all the missing bits, and doc tweaks
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Thu, 9 Jul 1998 18:47:25 -0400 (EDT)
+ Message-Id: <199807092247.SAA06314@monk.mps.ohio-state.edu>
+ Subject: Re: [PATCH 5.004_71] Secure RE update
+ Branch: perl
+ ! ObjXSub.h embed.h embedvar.h ext/Opcode/Opcode.pm ext/re/re.pm
+ ! global.sym globals.c interp.sym intrpvar.h op.c opcode.h
+ ! opcode.pl pp_ctl.c pp_proto.h regcomp.c sv.c t/op/misc.t
+ ! t/op/pat.t t/op/subst.t
+____________________________________________________________________________
+[ 1443] By: gsar on 1998/07/11 23:08:14
+ Log: tweak to get BSDI to build IPC/SysV
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Date: 11 Jul 1998 16:26:44 +0300
+ Message-ID: <oeeww9kecx7.fsf@alpha.hut.fi>
+ Subject: Re: NOT OK: perl5.004_71 on BSDI 3.1
+ Branch: perl
+ ! ext/IPC/SysV/SysV.xs
+____________________________________________________________________________
+[ 1442] By: gsar on 1998/07/11 23:03:39
+ Log: fix closures in optimized C<for (1..5)> (only the tests are in this
+ change, the pp_hot.c fix accidentally went in change#1441)
+ Branch: perl
+ ! t/op/closure.t
+____________________________________________________________________________
+[ 1441] By: gsar on 1998/07/11 22:35:40
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Sat, 11 Jul 1998 18:21:21 -0400 (EDT)
+ Message-Id: <199807112221.SAA03221@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_71] Update os2's OS2::Process
+ Branch: perl
+ ! os2/OS2/Process/Makefile.PL os2/OS2/Process/Process.pm
+ ! os2/OS2/Process/Process.xs pp_hot.c
+____________________________________________________________________________
+[ 1440] By: gsar on 1998/07/11 19:41:59
+ Log: From: andreas.koenig@kulturbox.de (Andreas J. Koenig)
+ Date: 11 Jul 1998 17:00:21 +0200
+ Message-ID: <sfc1zrsxwje.fsf@dubravka.in-berlin.de>
+ Subject: [perl5.004_71] Patch: change MakeMaker default compress --> gzip
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm
+____________________________________________________________________________
+[ 1439] By: gsar on 1998/07/11 19:36:58
+ Log: export newRV_noinc on win32, deprecate AvFILL in favor of av_len()
+ Branch: perl
+ ! pod/perlguts.pod win32/makedef.pl
+____________________________________________________________________________
+[ 1438] By: gsar on 1998/07/11 19:14:21
+ Log: applied patch for perlfunc tweaks, removed reference to system qsort()
+ From: abigail@fnx.com
+ Date: Sat, 11 Jul 1998 04:20:54 -0400 (EDT)
+ Message-ID: <19980711082054.2184.qmail@betelgeuse.wayne.fnx.com>
+ Subject: [PATCH 5.004_71] pod/perlfunc.pod
+ Branch: perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 1437] By: gsar on 1998/07/11 19:05:00
+ Log: From: abigail@fnx.com
+ Date: Sat, 11 Jul 1998 04:09:57 -0400 (EDT)
+ Message-ID: <19980711080957.2106.qmail@betelgeuse.wayne.fnx.com>
+ Subject: [PATCH 5.004_71] pod/pod2man.PL
+ Branch: perl
+ ! pod/pod2man.PL
+____________________________________________________________________________
+[ 1436] By: gsar on 1998/07/11 18:58:03
+ Log: more complete version of change#1421
+ From: Stephen McCamant <alias@mcs.com>
+ Date: Fri, 10 Jul 1998 23:46:46 -0500 (CDT)
+ Message-ID: <13734.58994.735473.859218@alias-2.pr.mcs.net>
+ Subject: [PATCH] Re: B::Deparse for(1..100000)
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+____________________________________________________________________________
+[ 1435] By: gsar on 1998/07/11 18:54:42
+ Log: win32 fixes for VC 6.0 nits
+ Branch: perl
+ ! ext/Data/Dumper/Dumper.xs win32/Makefile win32/makefile.mk
+ ! win32/win32.h
+____________________________________________________________________________
+[ 1434] By: gsar on 1998/07/11 18:45:32
+ Log: s/AVHV/pseudo-hash/ (via PM)
+ From: Gisle Aas <gisle@aas.no>
+ Date: 11 Jul 1998 00:16:53 +0200
+ Message-ID: <m3hg0pbbca.fsf@furu.g.aas.no>
+ Subject: [PATCH] trivial fields.pm doc patch
+ Branch: perl
+ ! lib/fields.pm
+____________________________________________________________________________
+[ 1433] By: gsar on 1998/07/11 18:43:11
+ Log: From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Date: Fri, 10 Jul 1998 23:12:11 +0200
+ Message-ID: <19980710231211.A161@cdata.tvnet.hu>
+ Subject: [PATCH _71] dos-djgpp update
+ Branch: perl
+ ! Configure djgpp/config.over djgpp/djgppsed.sh djgpp/fixpmain
+____________________________________________________________________________
+[ 1432] By: gsar on 1998/07/11 18:41:00
+ Log: applied patch, reformatted long lines in places
+ From: Dominic Dunlop <domo@computer.org>
+ Date: Fri, 10 Jul 1998 23:11:30 +0000
+ Message-Id: <v03110703b1cc32a02438@[195.95.102.91]>
+ Subject: [PATCH 5.004_71] Re: Document "count exceeded" regular expression
+ warning
+ Branch: perl
+ ! pod/perldiag.pod regexec.c
+____________________________________________________________________________
+[ 1431] By: gsar on 1998/07/11 18:29:18
+ Log: From: "John L. Allen" <allen@grumman.com>
+ Date: Fri, 10 Jul 1998 13:57:01 -0400 (EDT)
+ Message-ID: <Pine.SOL.3.91.980710134236.15717A-100000@gateway.grumman.com>
+ Subject: [PATCH]: _71 & _04 - Make AIX hints preserve ccflags as per docs
+ Branch: perl
+ ! hints/aix.sh
+____________________________________________________________________________
+[ 1430] By: TimBunce on 1998/07/11 18:15:09
+ Log: Title: "Fix string substitution returncode problem"
+ From: Dominic Dunlop <domo@vo.lu>, Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805271236.IAA28213@aatma.engin.umich.edu>,
+ <v03110700b191a557f041@[195.95.102.114]>
+ Files: pp_hot.c
+ Branch: maint-5.004/perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 1429] By: gsar on 1998/07/11 18:07:52
+ Log: applied patch, tweaked doc and code that does labels/indentation
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Thu, 9 Jul 1998 21:39:40 -0400 (EDT)
+ Message-Id: <199807100139.VAA08617@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_71] perldebug.pod and RE
+ Branch: perl
+ ! pod/perldebug.pod regcomp.c regexec.c
+____________________________________________________________________________
+[ 1428] By: TimBunce on 1998/07/11 17:45:56
+ Log: Assorted patches:
+
+ Title: "makerel now reads local patch list from patchlevel.h"
+ Files: patchlevel.h Porting/makerel
+
+ Title: "pod/pod2man.PL"
+ From: abigail@fnx.com
+ Msg-ID: <19980711080957.2106.qmail@betelgeuse.wayne.fnx.com>
+ Files: pod/pod2man.PL
+
+ Title: "Clarify taint example in re.pm"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980623155803.3227X-100000@user2.teleport.com>
+ Files: lib/re.pm
+
+ Title: "Anohter ptags improvement"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199807070059.UAA28815@monk.mps.ohio-state.edu>
+ Files: emacs/ptags
+
+ Title: "_71 & _04 - Make AIX hints preserve ccflags as per docs"
+ From: "John L. Allen" <allen@grumman.com>
+ Msg-ID: <Pine.SOL.3.91.980710134236.15717A-100000@gateway.grumman.com>
+ Files: hints/aix.sh
+ Branch: maint-5.004/perl
+ ! Porting/makerel emacs/ptags hints/aix.sh lib/re.pm
+ ! patchlevel.h pod/pod2man.PL
+____________________________________________________________________________
+[ 1427] By: gsar on 1998/07/11 17:04:47
+ Log: make Liblist return consistently backslashed paths
+ Branch: perl
+ ! lib/ExtUtils/Liblist.pm
+____________________________________________________________________________
+[ 1426] By: gsar on 1998/07/11 16:53:56
+ Log: don't 'touch a2p.c', it might readonly (via PM)
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Fri, 10 Jul 98 17:19:54 BST
+ Message-Id: <20430.9807101619@tempest.cise.npl.co.uk>
+ Branch: perl
+ ! x2p/Makefile.SH
+____________________________________________________________________________
+[ 1425] By: TimBunce on 1998/07/11 16:42:26
+ Log: Title: "Add newCONSTSUB (from 5.005_70)"
+ Files: embed.h proto.h global.sym op.c
+ Branch: maint-5.004/perl
+ ! embed.h global.sym op.c proto.h
+____________________________________________________________________________
+[ 1424] By: TimBunce on 1998/07/11 16:20:21
+ Log: Title: "Assorted fixes for Sys::Syslog.pm"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Sean Robinson
+ <ROBINSON_S@sc.maricopa.edu>, Tim.Bunce@ig.co.uk
+ Msg-ID: <01IXGLISWJ7Q0001B6@sc.maricopa.edu>,
+ <199805270939.KAA08453@toad.ig.co.uk>,
+ <E0yeHPI-00047D-00@taurus.cus.cam.ac.uk>
+ Files: lib/Sys/Syslog.pm
+ Branch: maint-5.004/perl
+ ! lib/Sys/Syslog.pm
+____________________________________________________________________________
+[ 1423] By: TimBunce on 1998/07/11 15:53:37
+ Log: Assorted patches:
+
+ Title: "umask: die if EXPR & 0700 else return undef"
+ From: Chip Salzenberg <chip@perl.org>, Jarkko Hietaniemi <jhi@cc.hut.fi>,
+ Jarkko Hietaniemi <jhi@iki.fi>, Malcolm Beattie
+ <mbeattie@sable.ox.ac.uk>, Tim.Bunce@ig.co.uk (Tim Bunce),
+ kstar@chapin.ed, kstar@chapin.edu@ig.co.uk ()
+ Msg-ID: <199805291520.QAA01615@sable.ox.ac.uk>,
+ <199805291549.SAA01439@alpha.hut.fi>,
+ <199805291608.RAA29283@toad.ig.co.uk>,
+ <19980530105129.A24006@O2.chapin.edu>,
+ <19980608133037.A8793@perlsupport.com>
+ Files: pod/perldiag.pod pod/perlfunc.pod pp_sys.c
+
+ Title: "File name DynaLoader.pm.PL is 8.3 unfriendly"
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Msg-ID: <19980610005417.G162@cdata.tvnet.hu>
+ Files: MANIFEST ext/DynaLoader/Makefile.PL
+ Branch: maint-5.004/perl
+ +> ext/DynaLoader/DynaLoader_pm.PL
+ - ext/DynaLoader/DynaLoader.pm.PL
+ ! MANIFEST ext/DynaLoader/Makefile.PL pod/perldiag.pod
+ ! pod/perlfunc.pod pp_sys.c
+____________________________________________________________________________
+[ 1421] By: gsar on 1998/07/11 02:54:02
+ Log: From: Gisle Aas <gisle@aas.no>
+ Subject: [PATCH] B::Deparse for(1..100000)
+ Date: 10 Jul 1998 14:04:44 +0200
+ Message-ID: <m3n2ahx677.fsf@furu.g.aas.no>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+____________________________________________________________________________
+[ 1420] By: gsar on 1998/07/11 02:28:18
+ Log: add 'clean' target for ext/re
+ Branch: perl
+ ! ext/re/Makefile.PL
+____________________________________________________________________________
+[ 1419] By: gsar on 1998/07/11 02:20:32
+ Log: From: Tom Hughes <thh@cyberscience.com>
+ Date: 10 Jul 1998 10:25:18 +0100
+ Message-ID: <yekn2ai5a81.fsf@elva.cyberscience.com>
+ Subject: [5.004_71] Patch: svr4 hints updates for Unixware
+ Branch: perl
+ ! hints/svr4.sh
+____________________________________________________________________________
+[ 1418] By: gsar on 1998/07/11 02:19:12
+ Log: move op/ipc{msg,sem}.t into lib/ipc_sysv.t
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Fri, 10 Jul 1998 13:08:08 +0300 (EET DST)
+ Message-Id: <199807101008.NAA10817@alpha.hut.fi>
+ Subject: Re: make minitest does not work out of the box - test subset
+ needs pruning
+ Branch: perl
+ + t/lib/ipc_sysv.t
+ - t/op/ipcmsg.t t/op/ipcsem.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 1417] By: gsar on 1998/07/11 02:14:16
+ Log: disable CR croaking (via #define, default off) in lieu of more
+ complete fix
+ Branch: perl
+ ! toke.c
+____________________________________________________________________________
+[ 1416] By: gsar on 1998/07/11 02:06:11
+ Log: added patch, made linking with setargv a build option
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Date: Thu, 9 Jul 1998 09:51:42 -0700
+ Message-ID: <000101bdab59$d9602dc0$a32fa8c0@tau.Active>
+ Subject: [PATCH 5.004_71]
+ Branch: perl
+ ! perl.c pp_sys.c win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1415] By: gsar on 1998/07/11 01:47:19
+ Log: From: Tom Hughes <thh@cyberscience.com>
+ Date: 10 Jul 1998 09:01:12 +0100
+ Message-ID: <yekr9zu5e47.fsf@elva.cyberscience.com>
+ Subject: [5.004_71] Patch: Fix perl_exp.SH for Unixware
+ Branch: perl
+ ! perl_exp.SH
+____________________________________________________________________________
+[ 1414] By: gsar on 1998/07/11 01:45:45
+ Log: make lib/re.pm a prereq for minitest
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 1413] By: gsar on 1998/07/11 01:40:56
+ Log: add patch (via PM)
+ From: Stephen McCamant <alias@mcs.com>
+ Date: Fri, 10 Jul 1998 01:14:11 -0500 (CDT)
+ Message-ID: <13733.45251.47363.431138@alias-2.pr.mcs.net>
+ Subject: Big B::Deparse update
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+____________________________________________________________________________
+[ 1412] By: gsar on 1998/07/11 00:25:17
+ Log: add perlport.pod v1.23 from Chris Nandor <pudge@pobox.com>
+ Branch: perl
+ + pod/perlport.pod
+ ! pod/perl.pod
+____________________________________________________________________________
+[ 1411] By: gsar on 1998/07/10 21:53:06
+ Log: make binmode(STDIN) not whine
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Date: Thu, 09 Jul 1998 16:51:27 -0700
+ Message-Id: <3.0.5.32.19980709165127.00a692e0@ous.edu>
+ Subject: [PATCH 5.004_70] Fix up binmode() for VMS
+ Branch: perl
+ ! vms/vms.c
+____________________________________________________________________________
+[ 1410] By: gsar on 1998/07/10 21:50:57
+ Log: CPAN-1.39 update
+ From: koenig@kulturbox.de (Andreas J. Koenig)
+ Date: 10 Jul 1998 00:45:36 +0200
+ Message-ID: <sfcbtqytzhr.fsf@dubravka.in-berlin.de>
+ Subject: Re: perl5.004_71 hit the stands this morn
+ Branch: perl
+ ! MANIFEST lib/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm
+____________________________________________________________________________
+[ 1409] By: gsar on 1998/07/10 21:45:10
+ Log: manually apply patch with conflicts
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Date: Thu, 09 Jul 1998 12:08:33 -0700
+ Message-Id: <3.0.5.32.19980709120833.009eb100@ous.edu>
+ Subject: [PATCH 5.004_70] Updated duble-quotes in config.h/config.pm patch
+ Branch: perl
+ ! configpm
+____________________________________________________________________________
+[ 1408] By: gsar on 1998/07/10 21:36:54
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Thu, 9 Jul 1998 11:58:30 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980709115556.24236D-100000@newton.phys>
+ Subject: Re: perldelta.pod [PATCH]
+ Branch: perl
+ ! pod/perldelta.pod
+____________________________________________________________________________
+[ 1407] By: gsar on 1998/07/10 21:35:13
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Thu, 9 Jul 1998 11:26:03 -0400 (EDT)
+ Subject: [PATCH 5.004_71] Allow static build of IPC::SysV
+ Message-Id: <Pine.SUN.3.96.980709112507.24236B-100000@newton.phys>
+ Branch: perl
+ ! ext/IPC/SysV/Makefile.PL
+____________________________________________________________________________
+[ 1406] By: gsar on 1998/07/10 21:33:30
+ Log: manually apply patch with conflicts
+ From: kstar@chapin.edu
+ Message-ID: <19980709093621.B7857@O2.chapin.edu>
+ Date: Thu, 9 Jul 1998 09:36:21 -0400
+ Subject: Re: [PATCH] 5.004_70 installperl and docs
+ Branch: perl
+ ! installperl
+____________________________________________________________________________
+[ 1405] By: gsar on 1998/07/10 21:28:29
+ Log: misc tweaks to docs and qsortsv() warning
+ Branch: perl
+ ! Changes pod/perldelta.pod pod/perlsub.pod pp_ctl.c
+____________________________________________________________________________
+[ 1404] By: gsar on 1998/07/10 21:23:53
+ Log: add more correct version of change#1350 (as yet untested)
+ From: joshua.pritikin@db.com
+ Date: Thu, 9 Jul 1998 09:22:46 -0400
+ Message-Id: <H00000e50008f277@MHS>
+ Subject: Re: [PATCH _70] cache missing methods
+ Branch: perl
+ ! embedvar.h gv.c interp.sym intrpvar.h perlvars.h
+____________________________________________________________________________
+[ 1403] By: gsar on 1998/07/10 20:46:12
+ Log: add win32_rename() that does what docs say
+ Branch: perl
+ ! win32/GenCAPI.pl win32/makedef.pl win32/perlhost.h
+ ! win32/win32.c win32/win32iop.h
+____________________________________________________________________________
+[ 1402] By: gsar on 1998/07/10 20:19:18
+ Log: inet_aton() should do DNS lookup only if arg isn't a dotted-quad
+ (suggested by Philippe.Simonet@swisscom.com)
+ Branch: perl
+ ! ext/Socket/Socket.xs
+____________________________________________________________________________
+[ 1401] By: gsar on 1998/07/10 03:24:45
+ Log: undo change#1379 (order of tests *is* significant)
+ Branch: perl
+ ! t/lib/posix.t
+____________________________________________________________________________
+[ 1400] By: nick on 1998/07/09 17:43:14
+ Log: Integrate mainline (_071-ish)
+ Branch: ansiperl
+ +> ext/Data/Dumper/Changes ext/Data/Dumper/Dumper.pm
+ +> ext/Data/Dumper/Dumper.xs ext/Data/Dumper/Makefile.PL
+ +> ext/Data/Dumper/Todo ext/IPC/SysV/ChangeLog
+ +> ext/IPC/SysV/MANIFEST ext/IPC/SysV/Makefile.PL
+ +> ext/IPC/SysV/Msg.pm ext/IPC/SysV/README
+ +> ext/IPC/SysV/Semaphore.pm ext/IPC/SysV/SysV.pm
+ +> ext/IPC/SysV/SysV.xs ext/IPC/SysV/t/msg.t ext/IPC/SysV/t/sem.t
+ +> ext/re/Makefile.PL ext/re/re.pm ext/re/re.xs pp_proto.h
+ +> t/io/iprefix.t t/lib/dumper-ovl.t t/lib/dumper.t
+ !> (integrate 145 files)
+
+----------------
+Version 5.004_71
+----------------
+
+____________________________________________________________________________
+[ 1399] By: gsar on 1998/07/09 12:15:12
+ Log: update Changes, perlhist.pod, beginnings of perldelta.pod
+ Branch: perl
+ ! Changes pod/perldelta.pod pod/perlhist.pod
+____________________________________________________________________________
+[ 1397] By: gsar on 1998/07/09 08:35:39
+ Log: merge changes from maintbranch (1354, and relevant part of 1356); all
+ maintenance changes upto 1356 merged
+ Branch: perl
+ ! pod/perldiag.pod pp_hot.c t/op/misc.t
+____________________________________________________________________________
+[ 1396] By: gsar on 1998/07/09 08:02:52
+ Log: add Data-Dumper, up patchlevel to 71, various misc tweaks to
+ make all configs build on Solaris and win32
+ Branch: perl
+ + ext/Data/Dumper/Changes ext/Data/Dumper/Dumper.pm
+ + ext/Data/Dumper/Dumper.xs ext/Data/Dumper/Makefile.PL
+ + ext/Data/Dumper/Todo t/lib/dumper-ovl.t t/lib/dumper.t
+ ! MANIFEST Todo patchlevel.h win32/Makefile win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1395] By: gsar on 1998/07/09 05:39:48
+ Log: From: Stephen McCamant <alias@mcs.com>
+ Date: Wed, 08 Jul 1998 23:16:49 CDT
+ Message-Id: <13732.16626.904108.608743@alias-2.pr.mcs.net>
+ Subject: [PATCH] UNOP opclass test in B.xs
+ Branch: perl
+ ! ext/B/B.xs
+____________________________________________________________________________
+[ 1394] By: gsar on 1998/07/09 05:37:48
+ Log: get it building again on win32
+ Branch: perl
+ ! bytecode.h embed.h ext/re/Makefile.PL global.sym intrpvar.h
+ ! op.c opcode.pl perl.h pp.c pp_ctl.c pp_hot.c pp_proto.h
+ ! pp_sys.c proto.h win32/Makefile win32/makedef.pl
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 1393] By: gsar on 1998/07/09 05:20:31
+ Log: applied patch from Ilya, tweaked some to get clean static build of
+ the ext/re stuff (untested on win32)
+ Branch: perl
+ ! regcomp.c regexec.c
+____________________________________________________________________________
+[ 1392] By: gsar on 1998/07/09 03:56:45
+ Log: fix installperl typo
+ From: kstar@chapin.edu
+ Date: Wed, 08 Jul 1998 23:51:57 EDT
+ Message-Id: <19980708235157.D1380@O2.chapin.edu>
+ Subject: Re: [PATCH] 5.004_70 installperl and docs
+ Branch: perl
+ ! installperl
+____________________________________________________________________________
+[ 1391] By: gsar on 1998/07/09 01:48:16
+ Log: From: Chip Salzenberg <chip@perl.org>
+ Date: Wed, 8 Jul 1998 18:10:55 -0400
+ Message-ID: <19980708181055.A8005@perlsupport.com>
+ Subject: [PATCH _70] Allow $SIG{CHLD}='IGNORE' to work on Solaris
+ Branch: perl
+ ! util.c
+____________________________________________________________________________
+[ 1390] By: gsar on 1998/07/09 01:45:16
+ Log: added patch, tweaked per Ilya's suggestion
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Date: Wed, 8 Jul 1998 13:34:42 +0100
+ Message-Id: <E0yttQo-0002aH-00@taurus.cus.cam.ac.uk>
+ Subject: [PATCH] perl5db.pl complains about non-integer condition
+ Branch: perl
+ ! lib/perl5db.pl
+____________________________________________________________________________
+[ 1389] By: gsar on 1998/07/09 01:42:13
+ Log: reenable misaligned memory checks, cast to UV & check alignment
+ From: Dominic Dunlop <domo@computer.org>
+ Date: Wed, 8 Jul 1998 11:21:48 +0000
+ Message-Id: <v03110703b1c8ffdb68ed@[195.95.102.91]>
+ Subject: Re: [PATCH 5.00469] corrupt malloc ptr on NeXT
+ Branch: perl
+ ! malloc.c
+____________________________________________________________________________
+[ 1388] By: gsar on 1998/07/09 01:36:22
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Wed, 8 Jul 1998 13:32:07 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980708133010.23053F-100000@newton.phys>
+ Subject: [PATCH 5.004_70] more on finding metaconfig units.
+ Branch: perl
+ ! Porting/pumpkin.pod
+____________________________________________________________________________
+[ 1387] By: gsar on 1998/07/09 01:35:23
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Wed, 8 Jul 1998 13:29:34 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980708132743.23053E-100000@newton.phys>
+ Subject: Configure indentation patch
+ Branch: perl
+ ! Configure
+____________________________________________________________________________
+[ 1386] By: gsar on 1998/07/09 01:33:31
+ Log: don't try to hardlink perldiag.pod; that is no longer not needed
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Wed, 8 Jul 1998 12:18:32 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980708120844.23053D-100000@newton.phys>
+ Subject: Re: pelr installation attempts hard links between file systems
+ Branch: perl
+ ! installperl
+____________________________________________________________________________
+[ 1385] By: gsar on 1998/07/09 01:28:05
+ Log: win32/makefile.mk =~ s|gcc -pipe|gcc|
+ Branch: perl
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 1384] By: gsar on 1998/07/09 01:26:19
+ Log: make t/TEST run 'perl $switches ./foo/test.t' everywhere
+ Branch: perl
+ ! t/TEST
+____________________________________________________________________________
+[ 1383] By: gsar on 1998/07/09 01:06:47
+ Log: manually apply patch with a dependency on unapplied patch
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Wed, 8 Jul 1998 07:03:51 -0400 (EDT)
+ Message-Id: <199807081103.HAA25145@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_70] make quoted RE embeddable
+ Branch: perl
+ ! sv.c t/op/pat.t
+____________________________________________________________________________
+[ 1382] By: gsar on 1998/07/09 01:02:23
+ Log: change order of libs for extensions
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Date: Tue, 7 Jul 1998 23:48:05 +0200
+ Message-ID: <19980707234805.C180@cdata.tvnet.hu>
+ Subject: [PATCH _70] linking problem with modules
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+____________________________________________________________________________
+[ 1381] By: gsar on 1998/07/09 00:56:12
+ Log: patch for more flexible initialization of xsub parameters
+ From: Tye McQueen <tye@metronet.com>
+ Date: Mon, 6 Jul 1998 19:04:27 -0500 (CDT)
+ Message-Id: <199807070004.AA16454@metronet.com>
+ Subject: Enhanced arg inits for xsubpp
+ Branch: perl
+ ! lib/ExtUtils/xsubpp pod/perlxs.pod
+____________________________________________________________________________
+[ 1380] By: gsar on 1998/07/09 00:44:01
+ Log: From: Tye McQueen <tye@metronet.com>
+ Date: Mon, 6 Jul 1998 17:34:54 -0500 (CDT)
+ Message-Id: <16619-17073@lyris.activestate.com>
+ Subject: New pl2bat.pl
+ Branch: perl
+ ! win32/bin/pl2bat.pl
+____________________________________________________________________________
+[ 1379] By: gsar on 1998/07/09 00:30:58
+ Log: remove ordering dependency in posix.t
+ Branch: perl
+ ! t/lib/posix.t
+____________________________________________________________________________
+[ 1378] By: gsar on 1998/07/08 20:17:43
+ Log: make -i'*suffix' work too
+ Branch: perl
+ ! doio.c
+____________________________________________________________________________
+[ 1377] By: gsar on 1998/07/08 08:56:28
+ Log: regen headers; result builds & tests on Solaris again (threaded)
+ Branch: perl
+ ! embedvar.h
+____________________________________________________________________________
+[ 1376] By: gsar on 1998/07/08 08:55:03
+ Log: change#1350 breaks things, back it out
+ Branch: perl
+ ! embedvar.h gv.c interp.sym intrpvar.h perlvars.h
+____________________________________________________________________________
+[ 1375] By: gsar on 1998/07/08 07:47:00
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Wed, 8 Jul 1998 01:30:15 -0400 (EDT)
+ Message-Id: <199807080530.BAA14072@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_70] Switch modifiers in RE off
+ Branch: perl
+ ! pod/perlre.pod regcomp.c t/op/re_tests
+____________________________________________________________________________
+[ 1374] By: gsar on 1998/07/08 07:41:06
+ Log: From: Gisle Aas <gisle@aas.no>
+ Date: 07 Jul 1998 23:08:59 +0200
+ Message-ID: <m3vhp9z7v8.fsf@furu.g.aas.no>
+ Subject: [PATCH] Faster copying from SvIV/SvNVs in sv_setsv()
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 1373] By: gsar on 1998/07/08 07:36:01
+ Log: From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Date: Tue, 7 Jul 1998 23:47:50 +0200
+ Message-ID: <19980707234750.A180@cdata.tvnet.hu>
+ Subject: [PATCH _70] dos-djgpp update
+ Branch: perl
+ ! djgpp/config.over djgpp/djgppsed.sh
+____________________________________________________________________________
+[ 1372] By: gsar on 1998/07/08 07:12:47
+ Log: add extension to support SysV IPC
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Tue, 7 Jul 1998 02:32:53 +0300 (EET DST)
+ Message-Id: <199807062332.CAA25792@alpha.hut.fi>
+ Subject: [PATCH] 5.004_70: IPC::SysV
+ Branch: perl
+ + ext/IPC/SysV/ChangeLog ext/IPC/SysV/MANIFEST
+ + ext/IPC/SysV/Makefile.PL ext/IPC/SysV/Msg.pm
+ + ext/IPC/SysV/README ext/IPC/SysV/Semaphore.pm
+ + ext/IPC/SysV/SysV.pm ext/IPC/SysV/SysV.xs ext/IPC/SysV/t/msg.t
+ + ext/IPC/SysV/t/sem.t
+ ! Configure MANIFEST pod/perlfunc.pod pod/perlipc.pod
+ ! t/op/ipcmsg.t t/op/ipcsem.t
+____________________________________________________________________________
+[ 1371] By: gsar on 1998/07/08 05:12:07
+ Log: add patch for C<use re 'debug'>
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 6 Jul 1998 22:24:33 -0400 (EDT)
+ Message-Id: <199807070224.WAA10318@monk.mps.ohio-state.edu>
+ Subject: Re: _70 and Devel::RE
+ Branch: perl
+ + ext/re/Makefile.PL ext/re/re.pm ext/re/re.xs
+ - lib/re.pm
+ ! MANIFEST Makefile.SH global.sym interp.sym intrpvar.h op.c
+ ! perl.h pp.c pp_ctl.c pp_hot.c regcomp.c regexec.c
+____________________________________________________________________________
+[ 1370] By: gsar on 1998/07/08 04:27:27
+ Log: added patch to generate PPDEF(pp_foo)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 6 Jul 1998 20:43:54 -0400 (EDT)
+ Message-Id: <199807070043.UAA28572@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_70] Autogenerate declarations for opcodes
+ Branch: perl
+ + pp_proto.h
+ ! MANIFEST Makefile.SH opcode.pl proto.h
+____________________________________________________________________________
+[ 1369] By: gsar on 1998/07/08 04:19:49
+ Log: suggest 'make test' after make
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 1368] By: gsar on 1998/07/08 03:58:19
+ Log: added patch for -i'foo*bar', made code somewhat simpler, tweaked doc
+ From: Colin Kuskie <ckuskie@cadence.com>
+ Date: Tue, 7 Jul 1998 09:44:33 -0700 (PDT)
+ Message-ID: <Pine.GSO.3.96.980707093457.28681A-100000@pdxue150.cadence.com>
+ Subject: Corrected -i prefix patch
+ Branch: perl
+ + t/io/iprefix.t
+ ! MANIFEST doio.c pod/perlrun.pod
+____________________________________________________________________________
+[ 1366] By: gsar on 1998/07/08 02:28:30
+ Log: From: Gisle Aas <gisle@aas.no>
+ Date: 07 Jul 1998 17:48:36 +0200
+ Message-ID: <m3vhp94q7f.fsf@furu.g.aas.no>
+ Subject: [PATCH] Remove some rendundant SvOOK_on tests
+ Branch: perl
+ ! sv.c sv.h
+____________________________________________________________________________
+[ 1365] By: gsar on 1998/07/08 02:25:17
+ Log: applied patch to clarify m//g
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Date: Tue, 7 Jul 1998 15:59:03 +0100
+ Message-Id: <E0ytZCx-0006Bi-00@taurus.cus.cam.ac.uk>
+ Subject: [PATCH] Re: m//g in perlop.pod
+ Branch: perl
+ ! pod/perlop.pod
+____________________________________________________________________________
+[ 1364] By: gsar on 1998/07/08 02:13:07
+ Log: From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Subject: [PATCH] 5.004_70 bug in perlfaq.pod
+ Message-Id: <E0ytVTJ-0002kb-00@taurus.cus.cam.ac.uk>
+ Date: Tue, 7 Jul 1998 11:59:41 +0100
+ Branch: perl
+ ! pod/perlfaq.pod
+____________________________________________________________________________
+[ 1363] By: gsar on 1998/07/08 02:11:11
+ Log: applied tweak (via private mail)
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Date: Tue, 7 Jul 1998 13:27:47 +0300 (EET DST)
+ Message-Id: <199807071027.NAA20829@alpha.hut.fi>
+ Subject: tiny perllocale.pod patch for 5.004_70
+ Branch: perl
+ ! pod/perllocale.pod
+____________________________________________________________________________
+[ 1362] By: gsar on 1998/07/08 02:07:48
+ Log: applied patch, various tweaks to pander to pod2man tantrums
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 6 Jul 1998 22:47:30 -0400 (EDT)
+ Message-Id: <199807070247.WAA10677@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_70] CONFIGPM
+ Branch: perl
+ ! Porting/Glossary configpm
+____________________________________________________________________________
+[ 1361] By: gsar on 1998/07/07 22:13:11
+ Log: From: Stephen McCamant <alias@mcs.com>
+ Date: Mon, 6 Jul 1998 21:22:17 -0500 (CDT)
+ Message-ID: <13729.33816.311236.995647@alias-2.pr.mcs.net>
+ Subject: Re: Inconsistent arithmetics on refs
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 1360] By: gsar on 1998/07/07 22:11:11
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Mon, 6 Jul 1998 20:59:10 -0400 (EDT)
+ Message-Id: <199807070059.UAA28815@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_70] Anohter ptags improvement
+ Branch: perl
+ ! emacs/ptags
+____________________________________________________________________________
+[ 1359] By: gsar on 1998/07/07 22:08:48
+ Log: fix accidental RE-de-optimization
+ From: larry@wall.org (Larry Wall)
+ Date: Mon, 6 Jul 1998 17:49:31 -0700
+ Message-Id: <199807070049.RAA23475@wall.org>
+ Subject: Re: before you deluge us with patches
+ --
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Tue, 7 Jul 1998 03:10:56 -0400 (EDT)
+ Message-Id: <199807070710.DAA25399@monk.mps.ohio-state.edu>
+ Subject: Re: before you deluge us with patches
+ Branch: perl
+ ! pp_hot.c regexec.c
+____________________________________________________________________________
+[ 1358] By: gsar on 1998/07/07 21:36:29
+ Log: From: Gisle Aas <gisle@aas.no>
+ Subject: [PATCH] Evaluation of AVHVs in scalar context
+ Date: 06 Jul 1998 21:41:14 +0200
+ Message-ID: <m33ecedaxx.fsf@furu.g.aas.no>
+ Branch: perl
+ ! pp_hot.c t/op/avhv.t
+____________________________________________________________________________
+[ 1357] By: gsar on 1998/07/07 21:29:46
+ Log: doc tweaks suggested by Abigail, M.J.T. Guy, and Larry Wall
+ Branch: perl
+ ! lib/Math/Trig.pm lib/fields.pm thread.sym
+____________________________________________________________________________
+[ 1356] By: TimBunce on 1998/07/07 17:19:42
+ Log: Assorted patches:
+
+ ------ BUILD PROCESS ------
+
+ Title: "Add Test.pm (from perl 5.004_70)"
+ Files: MANIFEST lib/Test.pm
+
+ ------ EXTENSIONS ------
+
+ Title: "Add CR LF CRLF to Socket.pm"
+ From: Chris Nandor <pudge@pobox.com>
+ Msg-ID: <v04003a46b1b6067832a1@[24.48.28.52]>
+ Files: ext/Socket/Socket.pm
+
+ ------ LIBRARY ------
+
+ Title: "AutoSplit upgrade (AutoSplit 1.0302 from 5.004_70)"
+ Files: lib/AutoSplit.pm
+
+ Title: "Upgrade base.pm (from perl 5.004_70)"
+ Files: lib/base.pm
+
+ Title: "Add File::Spec modules (from 5.004_70)"
+ Files: lib/File/Spec.pm lib/File/Spec/Mac.pm lib/File/Spec/OS2.pm
+ lib/File/Spec/Unix.pm lib/File/Spec/VMS.pm
+ lib/File/Spec/Win32.pm
+
+ ------ TESTS ------
+
+ Title: "fixup test for method call on undefined value"
+ Files: t/op/misc.t
+
+ ------ UTILITIES ------
+
+ Title: "perlbug upgrade (from 5.004_70)"
+ Files: utils/perlbug.PL
+
+ Title: "Upgrade perldoc (from 5.004_70)"
+ Files: utils/perldoc.PL
+ Branch: maint-5.004/perl
+ + lib/File/Spec.pm lib/File/Spec/Mac.pm lib/File/Spec/OS2.pm
+ + lib/File/Spec/Unix.pm lib/File/Spec/VMS.pm
+ + lib/File/Spec/Win32.pm lib/Test.pm
+ ! MANIFEST ext/Socket/Socket.pm lib/AutoSplit.pm lib/base.pm
+ ! t/op/misc.t utils/perlbug.PL utils/perldoc.PL
+____________________________________________________________________________
+[ 1355] By: TimBunce on 1998/07/07 14:39:51
+ Log: Title: "Fix memory leak in Safe module"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199806290544.BAA18463@aatma.engin.umich.edu>
+ Files: ext/Opcode/Opcode.xs ext/Opcode/Safe.pm
+ Branch: maint-5.004/perl
+ ! ext/Opcode/Opcode.xs ext/Opcode/Safe.pm
+____________________________________________________________________________
+[ 1354] By: TimBunce on 1998/07/07 14:35:25
+ Log: Title: "Better error message for $undef->method call"
+ From: Tim Bunce <Tim.Bunce@ig.co.uk>, Graham Barr <gbarr@ti.com>,
+ joshua.pritikin@db.com
+ Msg-ID: <19980615171027.U4120@asic.sc.ti.com>, <H00000e500073a20@MHS>
+ Files: pod/perldiag.pod pp_hot.c
+ Branch: maint-5.004/perl
+ ! pod/perldiag.pod pp_hot.c
+____________________________________________________________________________
+[ 1353] By: gsar on 1998/07/06 23:33:38
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Mon, 6 Jul 1998 16:59:06 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980706165659.21068B-100000@newton.phys>
+ Subject: [PATCH 5.004_70] Update metaconfig info
+ Branch: perl
+ ! Porting/pumpkin.pod
+____________________________________________________________________________
+[ 1352] By: gsar on 1998/07/06 23:30:54
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Mon, 6 Jul 1998 13:14:37 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980706130959.20719A-100000@newton.phys>
+ Subject: [PATCH 5.004_70] Config_70-01: Remove default "/share"
+ Branch: perl
+ ! Configure INSTALL Policy_sh.SH Porting/Glossary
+ ! Porting/config.sh Porting/config_H
+____________________________________________________________________________
+[ 1351] By: gsar on 1998/07/06 23:24:47
+ Log: try harder to run non-executable tests
+ Branch: perl
+ ! t/TEST
+____________________________________________________________________________
+[ 1350] By: gsar on 1998/07/06 23:12:17
+ Log: add patch to improve method caching, regen headers
+ From: joshua.pritikin@db.com
+ Date: Mon, 6 Jul 1998 09:19:29 -0400
+ Message-Id: <H00000e50008a518@MHS>
+ Subject: [PATCH _70] cache missing methods
+ Branch: perl
+ ! embedvar.h gv.c interp.sym intrpvar.h perlvars.h
+____________________________________________________________________________
+[ 1349] By: TimBunce on 1998/07/06 23:03:16
+ Log: Assorted patches:
+
+ ------ BUILD PROCESS ------
+
+ Title: "Configure: Workaround bash CDPATH oddity"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980608121159.13706C-100000@newton.phys>
+ Files: Configure
+
+ Title: "Don't suppress display of Makefile recipes that invoke perl"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199806252213.SAA08545@aatma.engin.umich.edu>
+ Files: Makefile.SH
+
+ ------ CORE LANGUAGE ------
+
+ Title: "one more^Wless quad unpack bug"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199806301132.OAA27353@alpha.hut.fi>
+ Files: pp.c
+
+ Title: "minor fixups to bring maint closer to devel for patching"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805200046.UAA19284@aatma.engin.umich.edu>
+ Files: pod/perldiag.pod deb.c dump.c t/op/ref.t t/op/split.t taint.c util.c
+
+ Title: "-Pw switches used together report bogus error"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199806252331.TAA10160@aatma.engin.umich.edu>
+ Files: perl.c
+
+ Title: "Add doc and perl home page info to -v output"
+ From: Tom Christiansen <tchrist@jhereg.perl.com>
+ Msg-ID: <199802172229.PAA29309@jhereg.perl.com>
+ Files: perl.c
+
+ Title: "Fix C<@a = (%a = 1)> bizarreness"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Tom Christiansen
+ <tchrist@jhereg.perl.com>
+ Msg-ID: <199807012026.OAA31507@jhereg.perl.com>,
+ <199807012339.TAA26024@aatma.engin.umich.edu>
+ Files: pp_hot.c
+
+ Title: "make find_script() return saved string, reenable missing
+ diagnostics"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199806262224.SAA00422@aatma.engin.umich.edu>
+ Files: perl.c util.c
+
+ Title: "minor e_script optimization"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807060704.DAA25988@aatma.engin.umich.edu>
+ Files: perl.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "Insecure $ENV{} message out of step with perldiag"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0yooQA-0003za-00@taurus.cus.cam.ac.uk>
+ Files: pod/perldiag.pod pod/perlsec.pod
+
+ Title: "documenting close without arguments"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980623084413.24075V-100000@user2.teleport.com>
+ Files: pod/perlfunc.pod
+
+ Title: "pod for scalar .. op"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0yqyN8-0006gv-00@taurus.cus.cam.ac.uk>
+ Files: pod/perlop.pod
+
+ ------ EXTENSIONS ------
+
+ Title: "Fcntl: add few constants, enhance maintainability"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199806221558.SAA18626@alpha.hut.fi>
+ Files: ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs
+
+ ------ LIBRARY ------
+
+ Title: "Fix undef warnings in Text::Parsewords"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199806300842.LAA26409@alpha.hut.fi>
+ Files: lib/Text/ParseWords.pm
+
+ Title: "Add Symbol::delete_package()"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807060702.DAA25976@aatma.engin.umich.edu>
+ Files: pod/perlembed.pod lib/Symbol.pm
+ Branch: maint-5.004/perl
+ ! Configure Makefile.SH deb.c dump.c ext/Fcntl/Fcntl.pm
+ ! ext/Fcntl/Fcntl.xs lib/Symbol.pm lib/Text/ParseWords.pm perl.c
+ ! pod/perldiag.pod pod/perlembed.pod pod/perlfunc.pod
+ ! pod/perlop.pod pod/perlsec.pod pp.c pp_hot.c t/op/ref.t
+ ! t/op/split.t taint.c util.c
+____________________________________________________________________________
+[ 1348] By: gsar on 1998/07/06 22:55:56
+ Log: remove #! line from Errno_pm.PL
+ Branch: perl
+ ! ext/Errno/Errno_pm.PL
+____________________________________________________________________________
+[ 1347] By: gsar on 1998/07/06 22:51:34
+ Log: added patch to fix Cwd.pm warnings, fixed a couple more places
+ From: Gisle Aas <gisle@aas.no>
+ Date: 06 Jul 1998 13:08:53 +0200
+ Message-ID: <m3af6nfd8a.fsf@furu.g.aas.no>
+ Subject: [PATCH] 5.004_70 Cwd.pm now give warnings
+ Branch: perl
+ ! lib/Cwd.pm
+____________________________________________________________________________
+[ 1346] By: gsar on 1998/07/06 22:20:29
+ Log: much simpler fix to typecheck read/sysread/recv, as suggested by
+ Stephen McCamant
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 1345] By: gsar on 1998/07/06 21:58:52
+ Log: undo ck_sysread() changes#1319,1337 in preparation for a much
+ simpler fix
+ Branch: perl
+ ! ObjXSub.h embed.h global.sym globals.c objpp.h op.c opcode.h
+ ! opcode.pl proto.h
+____________________________________________________________________________
+[ 1344] By: TimBunce on 1998/07/06 21:51:05
+ Log: Title: "Fix for broken goto &xsub"
+ From: Albert Dvornik <bert@genscan.com>,
+ Msg-ID: <tq4sxawf2h.fsf@puma.genscan.com>
+ Files: MANIFEST pp_ctl.c t/op/goto_xs.t
+ Branch: maint-5.004/perl
+ + t/op/goto_xs.t
+ ! MANIFEST pp_ctl.c
+____________________________________________________________________________
+[ 1343] By: TimBunce on 1998/07/06 21:40:14
+ Log: Title: "Undo sub stub optimization and add comments on GV_FOO constants"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199807050841.EAA25114@aatma.engin.umich.edu>
+ Files: gv.h gv.c op.c toke.c
+ Branch: maint-5.004/perl
+ ! gv.c gv.h op.c toke.c
+____________________________________________________________________________
+[ 1342] By: gsar on 1998/07/06 20:57:06
+ Log: From: Gisle Aas <gisle@aas.no>
+ Message-Id: <m3zpem4v0z.fsf@furu.g.aas.no>
+ Date: 06 Jul 1998 21:52:12 +0200
+ Subject: Keepers of the Patch Pumpkin
+ Branch: perl
+ ! Changes
+____________________________________________________________________________
+[ 1341] By: gsar on 1998/07/06 20:43:35
+ Log: remove dup entry in perldiag
+ Branch: perl
+ ! pod/perldiag.pod
+____________________________________________________________________________
+[ 1340] By: gsar on 1998/07/06 20:31:44
+ Log: more reasonable diagnostic on keyword vs. sub ambiguity
+ Branch: perl
+ ! pod/perldiag.pod toke.c
+____________________________________________________________________________
+[ 1339] By: gsar on 1998/07/06 19:23:06
+ Log: rename s/\bSI_/PERLSI_/ to avoid collisions with sysinfo headers
+ Branch: perl
+ ! av.c cop.h gv.c mg.c op.c perl.c pp_ctl.c pp_sys.c scope.c
+ ! sv.c toke.c util.c
+____________________________________________________________________________
+[ 1338] By: gsar on 1998/07/06 18:45:35
+ Log: per Larry suggestion, toss change#1327 and fix the documentation
+ to match behavior instead
+ Branch: perl
+ ! pod/perlfunc.pod pp_sys.c
+____________________________________________________________________________
+[ 1337] By: gsar on 1998/07/06 17:15:26
+ Log: allow read(FH,threadsv,...)
+ Branch: perl
+ ! op.c
+
+----------------
+Version 5.004_70
+----------------
+
+____________________________________________________________________________
+[ 1336] By: gsar on 1998/07/06 09:06:33
+ Log: 5.004_70 tweaks
+ Branch: perl
+ ! Changes win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1335] By: gsar on 1998/07/06 07:05:37
+ Log: update Changes
+ Branch: perl
+ ! Changes pod/perldiag.pod
+____________________________________________________________________________
+[ 1334] By: gsar on 1998/07/06 06:41:17
+ Log: allow eval-groups in patterns only if they C<use re 'eval';>
+ Branch: perl
+ ! lib/re.pm perl.h pod/perldiag.pod pod/perlre.pod regcomp.c
+ ! t/op/misc.t t/op/pat.t t/op/regexp.t t/op/subst.t
+____________________________________________________________________________
+[ 1333] By: gsar on 1998/07/06 03:22:52
+ Log: From: Hans Mulder <hansm@icgroup.nl>
+ Date: Mon, 6 Jul 98 02:11:32 +0200
+ Message-Id: <9807060021.AA29027@icgned.icgroup.nl>
+ Subject: [PATCH 5.00469] corrupt malloc ptr on NeXT
+ Branch: perl
+ ! malloc.c
+____________________________________________________________________________
+[ 1332] By: gsar on 1998/07/06 03:18:34
+ Log: added Errno-1.09 from CPAN
+ Branch: perl
+ ! ext/Errno/ChangeLog ext/Errno/Errno_pm.PL
+____________________________________________________________________________
+[ 1331] By: gsar on 1998/07/06 02:59:09
+ Log: fix small memleak on -e, don't try to find_script() when e_script
+ Branch: perl
+ ! perl.c
+____________________________________________________________________________
+[ 1330] By: gsar on 1998/07/06 00:40:24
+ Log: add Symbol::delete_package()
+ Branch: perl
+ ! lib/Symbol.pm pod/perlembed.pod
+____________________________________________________________________________
+[ 1329] By: gsar on 1998/07/05 23:05:40
+ Log: patch to remove assumptions about offset of IV being == sizeof(XPV)
+ From: Stephen McCamant <alias@mcs.com>
+ Date: Sun, 5 Jul 1998 17:36:14 -0500 (CDT)
+ Message-ID: <13727.63831.95324.696098@alias-2.pr.mcs.net>
+ Subject: [PATCH] alignment in X[IN]V allocation
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 1328] By: gsar on 1998/07/05 22:47:57
+ Log: make read() return undef on errors as documented, and clarify docs
+ Branch: perl
+ ! pod/perlfunc.pod pp_sys.c
+____________________________________________________________________________
+[ 1327] By: gsar on 1998/07/05 22:11:21
+ Log: fix getc() to return empty string instead of undef on eof, as it was
+ documented to behave; still returns undef on error
+ Branch: perl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 1326] By: gsar on 1998/07/05 21:53:30
+ Log: patch whitespace-mutiliated; applied manually
+ From: Hans Mulder <hansm@icgroup.nl>
+ Date: Sun, 5 Jul 98 23:23:20 +0200
+ Message-Id: <9807052133.AA28626@icgned.icgroup.nl>
+ Subject: [PATCH 5.004_69] building Errno.pm still fails on NeXT
+ Branch: perl
+ ! ext/Errno/Errno_pm.PL
+____________________________________________________________________________
+[ 1325] By: gsar on 1998/07/05 21:38:39
+ Log: applied patch (via private mail), modulo retrohunks in pod/perlfaq2.pod
+ From: Tom Christiansen <tchrist@jhereg.perl.com>
+ Date: Sun, 05 Jul 1998 09:15:22 -0500
+ Subject: Re: docpatch
+ Message-Id: <199807051515.JAA03644@jhereg.perl.com>
+ Branch: perl
+ ! pod/perlfaq.pod pod/perlfaq1.pod pod/perlfaq2.pod
+ ! pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod
+ ! pod/perlfaq6.pod pod/perlfaq7.pod pod/perlfaq8.pod
+ ! pod/perlfaq9.pod pod/perlfunc.pod pod/perlipc.pod
+ ! pod/perlrun.pod
+____________________________________________________________________________
+[ 1324] By: gsar on 1998/07/05 21:06:56
+ Log: applied patch, and undid change#1302 which it made unnecessary
+ From: Billy <wdconsta@cs.adelaide.edu.au>
+ Date: Sun, 5 Jul 1998 23:05:52 +0930 (CST)
+ Subject: [PATCH] utils/h2ph.PL and t/lib/h2ph.t
+ Message-ID: <Pine.SV4.3.93.980705230337.27658A-100000@xenon.teaching.cs.adelaide.edu.au>
+ Branch: perl
+ ! t/lib/h2ph.t utils/h2ph.PL
+____________________________________________________________________________
+[ 1323] By: gsar on 1998/07/05 20:56:39
+ Log: fix t/lib/fields.t's @INC so make test runs
+ Branch: perl
+ ! t/lib/fields.t
+____________________________________________________________________________
+[ 1322] By: gsar on 1998/07/05 20:26:43
+ Log: add comments on GV_FOO constants, s/8/GV_ADDINEVAL/
+ Branch: perl
+ ! gv.c gv.h toke.c
+____________________________________________________________________________
+[ 1321] By: gsar on 1998/07/05 07:41:50
+ Log: sundry win32 config tweaks
+ Branch: perl
+ ! Todo.5.005 t/op/stat.t win32/Makefile win32/config.bc
+ ! win32/config.gc win32/config.vc win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc win32/config_h.PL
+ ! win32/config_sh.PL win32/makefile.mk
+____________________________________________________________________________
+[ 1320] By: gsar on 1998/07/05 06:30:35
+ Log: update Changes
+ Branch: perl
+ ! Changes
+____________________________________________________________________________
+[ 1319] By: gsar on 1998/07/05 06:27:37
+ Log: add ck_sysread() for better sysread/read/recv sanity
+ Branch: perl
+ ! ObjXSub.h embed.h global.sym globals.c objpp.h op.c opcode.h
+ ! opcode.pl proto.h
+____________________________________________________________________________
+[ 1318] By: gsar on 1998/07/05 04:34:05
+ Log: From: Stephen McCamant <alias@mcs.com>
+ Date: Sat, 4 Jul 1998 23:24:47 -0500 (CDT)
+ Subject: [PATCH] Document B::Deparse, add pp_threadsv
+ Message-ID: <13726.65230.19324.216849@alias-2.pr.mcs.net>
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+____________________________________________________________________________
+[ 1317] By: gsar on 1998/07/05 04:15:25
+ Log: added patch with tweak to doc
+ From: Chip Salzenberg <chip@perl.org>
+ Message-ID: <19980704205136.A16319@perlsupport.com>
+ Date: Sat, 4 Jul 1998 20:51:36 -0400
+ Subject: [PATCH _69] Take 2: Warn on C<sub log; log($msg)>
+ Branch: perl
+ ! ext/IO/lib/IO/Handle.pm pod/perldiag.pod toke.c
+____________________________________________________________________________
+[ 1316] By: gsar on 1998/07/05 03:56:22
+ Log: Porting/Glossary goes podly into Config.pm
+ Branch: perl
+ ! Porting/Glossary configpm
+____________________________________________________________________________
+[ 1315] By: gsar on 1998/07/05 02:50:18
+ Log: add suggested tool as an example in ExtUtils::Packlist
+ From: Alan Burlison <Alan.Burlison@UK.Sun.com>
+ Message-Id: <199807031028.LAA10456@sale-wts>
+ Date: Fri, 3 Jul 1998 11:28:03 +0100 (BST)
+ Subject: Re: [make install] another horror story
+ Branch: perl
+ ! lib/ExtUtils/Installed.pm lib/ExtUtils/Packlist.pm
+____________________________________________________________________________
+[ 1314] By: gsar on 1998/07/05 02:28:04
+ Log: avoid race condition (storing ptr to SV before incrementing its
+ REFCNT) and warning in newRV()
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 1313] By: gsar on 1998/07/05 02:06:40
+ Log: applied suggested fix for xhv_array sizing, with portability tweaks
+ From: Gisle Aas <gisle@aas.no>
+ Subject: Re: [PATCH] Re: perl5.004_69 core dump
+ Date: 04 Jul 1998 10:20:35 +0200
+ Message-ID: <m3af6qowmk.fsf@furu.g.aas.no>
+ Branch: perl
+ ! hv.c
+____________________________________________________________________________
+[ 1312] By: gsar on 1998/07/05 01:36:45
+ Log: From: Gisle Aas <gisle@aas.no>
+ Subject: [PATCH] hv_max may be a few too many
+ Date: 04 Jul 1998 09:28:46 +0200
+ Message-ID: <m3d8bmoz0x.fsf@furu.g.aas.no>
+ Branch: perl
+ ! doop.c
+____________________________________________________________________________
+[ 1311] By: gsar on 1998/07/05 00:35:27
+ Log: patchlevel up to 5.004_70, various tweaks
+ * fix taint problems due to maintbranch regression
+ * PERL_OBJECT now builds again
+ * deal with C++ strong-typing problems in hv.c
+ * fix mismatch in "reserved word" diagnostic
+ Branch: perl
+ ! av.c hv.c objpp.h patchlevel.h pp_ctl.c pp_hot.c proto.h
+ ! regexec.c regexp.h toke.c win32/perlhost.h win32/win32.c
+____________________________________________________________________________
+[ 1310] By: TimBunce on 1998/07/04 11:35:25
+ Log: Remove old RE //t flag from scan_subst().
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 1309] By: gsar on 1998/07/04 08:32:53
+ Log: various small tweaks (still fails a few taint tests in {taint,locale}.t)
+ Branch: perl
+ ! Todo.5.005 lib/re.pm sv.c t/lib/fields.t
+____________________________________________________________________________
+[ 1307] By: gsar on 1998/07/04 07:00:14
+ Log: fix C<local $tied{foo} = $tied{foo}>, add tests
+ Branch: perl
+ ! pp_hot.c t/op/local.t
+____________________________________________________________________________
+[ 1306] By: gsar on 1998/07/04 05:52:34
+ Log: fixes for mortalization bug in xsubpp, other efficiency tweaks
+ From: joshua.pritikin@db.com
+ Date: Wed, 1 Jul 1998 10:09:43 -0400
+ Message-Id: <H00000e500086fb3@MHS>
+ Subject: [PATCH _69] sv_2mortal fix
+ Branch: perl
+ ! lib/ExtUtils/xsubpp perl.c pp.c pp_hot.c proto.h sv.c sv.h
+____________________________________________________________________________
+[ 1305] By: gsar on 1998/07/04 05:46:42
+ Log: add patch preextend global string table, tweak for 512 entries
+ From: Gisle Aas <gisle@aas.no>
+ Date: 04 Jul 1998 01:04:08 +0200
+ Subject: Re: [PATCH] Re: perl5.004_69 core dump
+ Message-ID: <m3ra02v8nr.fsf@furu.g.aas.no>
+ Branch: perl
+ ! perl.c
+____________________________________________________________________________
+[ 1304] By: gsar on 1998/07/04 05:40:35
+ Log: simplify xhv_array sizing
+ From: Gisle Aas <gisle@aas.no>
+ Date: 04 Jul 1998 00:49:42 +0200
+ Subject: Re: [PATCH] Re: perl5.004_69 core dump
+ Message-ID: <m3yauav9bt.fsf@furu.g.aas.no>
+ Branch: perl
+ ! hv.c
+____________________________________________________________________________
+[ 1303] By: gsar on 1998/07/04 05:37:29
+ Log: make 4-arg win32_select() sleep more reasonably on false values
+ From: Blair Zajac <blair@gps.caltech.edu>
+ Message-Id: <199807020225.TAA18740@gobi.gps.caltech.edu>
+ Date: Wed, 1 Jul 1998 19:25:56 -0700 (PDT)
+ Subject: [PATCH 5.004_69] select dumps core on MSWin32-x86
+ --
+ Message-Id: <199807030107.SAA08595@gobi.gps.caltech.edu>
+ Date: Thu, 2 Jul 1998 18:07:19 -0700 (PDT)
+ Subject: [PATCH 5.004_69] select dumps core on MSWin32-x86
+ Branch: perl
+ ! win32/win32sck.c
+____________________________________________________________________________
+[ 1302] By: gsar on 1998/07/04 05:32:50
+ Log: adjust h2ph.t for dos-specific problem
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Message-ID: <19980703234525.C208@cdata.tvnet.hu>
+ Date: Fri, 3 Jul 1998 23:45:25 +0200
+ Subject: Re: [PATCH _68] t/lib/h2ph.t problem
+ Branch: perl
+ ! t/lib/h2ph.t
+____________________________________________________________________________
+[ 1301] By: gsar on 1998/07/04 05:31:04
+ Log: fix CPAN.pm problem, OS2 tweaks
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199807030459.AAA00097@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_68] PAtch to CPAN first-time
+ Date: Fri, 3 Jul 1998 00:59:35 -0400 (EDT)
+ Branch: perl
+ ! lib/CPAN/FirstTime.pm lib/ExtUtils/MM_OS2.pm
+ ! lib/ExtUtils/MakeMaker.pm
+____________________________________________________________________________
+[ 1300] By: gsar on 1998/07/04 05:27:20
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199807030102.VAA26813@monk.mps.ohio-state.edu>
+ Date: Thu, 2 Jul 1998 21:02:59 -0400 (EDT)
+ Subject: [PATCH 5.004_68] Add elc target to to makefile
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 1299] By: gsar on 1998/07/04 05:25:56
+ Log: newer emacs/cperl-mode.el (via private mail)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199807030104.VAA26825@monk.mps.ohio-state.edu>
+ Date: Thu, 2 Jul 1998 21:04:29 -0400 (EDT)
+ Subject: [PATCH 5.004_68] cperl-mode
+ Branch: perl
+ ! emacs/cperl-mode.el
+____________________________________________________________________________
+[ 1298] By: gsar on 1998/07/04 05:22:41
+ Log: From: Dominic Dunlop <domo@computer.org>
+ Message-Id: <v03110701b1c1603eae52@[195.95.102.68]>
+ Date: Thu, 2 Jul 1998 22:57:26 +0000
+ Subject: [PATCH 5.004_69] Make Power MachTen use vfork and perl's malloc
+ Branch: perl
+ ! hints/machten.sh malloc.c
+____________________________________________________________________________
+[ 1297] By: gsar on 1998/07/04 05:20:52
+ Log: allow a flags args to fbm_instr() for future needs
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199807020749.DAA12379@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_68] mORE FBM_ CHANGES FOR FUTURE
+ Date: Thu, 2 Jul 1998 03:49:32 -0400 (EDT)
+ Branch: perl
+ ! pod/perlguts.pod pp.c pp_hot.c proto.h regexec.c util.c
+____________________________________________________________________________
+[ 1296] By: gsar on 1998/07/04 05:16:15
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Thu, 2 Jul 1998 11:50:41 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980702114956.18246B-100000@newton.phys>
+ Subject: [PATCH 5.004_69] INSTALL-1.39
+ Branch: perl
+ ! INSTALL
+____________________________________________________________________________
+[ 1295] By: gsar on 1998/07/04 05:15:05
+ Log: Configure update
+ From: doughera@newton.phys.lafayette.edu (Andy Dougherty)
+ Date: Wed, 1 Jul 98 23:07:50 EDT
+ Message-Id: <9807020307.AA17848@newton.phys.lafayette.edu>
+ Subject: [PATCH 5.004_69] Config_69-01
+ Branch: perl
+ ! Configure INSTALL MANIFEST Policy_sh.SH Porting/Glossary
+ ! Porting/config.sh Porting/config_H Porting/pumpkin.pod
+ ! config_h.SH win32/config.bc win32/config.gc win32/config.vc
+____________________________________________________________________________
+[ 1294] By: gsar on 1998/07/04 05:10:25
+ Log: add perlbug -F switch to save message to file
+ From: Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Message-Id: <l03130301b1c03a649e45@[194.222.64.89]>
+ Date: Wed, 1 Jul 1998 21:14:22 +0200
+ Subject: Re: [PATCH 5.004_69] perlbug -fok
+ Branch: perl
+ ! Makefile.SH utils/perlbug.PL
+____________________________________________________________________________
+[ 1293] By: gsar on 1998/07/04 05:06:52
+ Log: catch nonexistent backrefs in REs
+ From: Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Message-Id: <l03130304b1c027e1df9e@[194.222.64.89]>
+ Date: Wed, 1 Jul 1998 20:14:05 +0200
+ Subject: Re: [PATCH _66] for bad backrefs
+ --
+ Message-Id: <l03130300b1c03425261c@[194.222.64.89]>
+ Date: Wed, 1 Jul 1998 20:47:16 +0200
+ Subject: Re: [PATCH _66] for bad backrefs
+ Branch: perl
+ ! regcomp.c t/op/re_tests util.c
+____________________________________________________________________________
+[ 1292] By: gsar on 1998/07/04 05:02:01
+ Log: fix perlcc to not rm output file, and other -w(arts)
+ Branch: perl
+ ! utils/perlcc.PL
+____________________________________________________________________________
+[ 1291] By: gsar on 1998/07/04 04:30:03
+ Log: ignore stash entries that are not GVs in dump.c
+ Branch: perl
+ ! dump.c
+____________________________________________________________________________
+[ 1290] By: gsar on 1998/07/04 03:55:10
+ Log: cleaner page headers from pod2man
+ Branch: perl
+ ! pod/pod2man.PL
+____________________________________________________________________________
+[ 1288] By: gsar on 1998/07/04 03:16:39
+ Log: tweaks to Getopt::Std
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Tue, 30 Jun 98 14:45:49 BST
+ Message-Id: <14103.9806301345@tempest.cise.npl.co.uk>
+ Subject: [PATCH perl5.004_69] lib/Getopt/Std.pm
+ --
+ Message-Id: <17918.9807021053@tempest.cise.npl.co.uk>
+ To: perl5-porters@perl.org
+ Subject: [PATCH perl5.004_69] second: lib/Getopt/Std.pm
+ Branch: perl
+ ! lib/Getopt/Std.pm
+____________________________________________________________________________
+[ 1287] By: gsar on 1998/07/04 03:13:02
+ Log: added patch, with tweaks
+ From: Gisle Aas <gisle@aas.no>
+ Date: 03 Jul 1998 00:50:15 +0200
+ Message-ID: <m3btr7n9zs.fsf@furu.g.aas.no>
+ Subject: [PATCH] Some AVHV documentation
+ Branch: perl
+ ! pod/perlref.pod
+____________________________________________________________________________
+[ 1286] By: gsar on 1998/07/04 02:53:26
+ Log: applied patch with tweaks to prose
+ From: Gisle Aas <gisle@aas.no>
+ Subject: [PATCH] Simplified AVHV support
+ Date: 30 Jun 1998 13:34:07 +0200
+ Message-ID: <m3k95z86og.fsf@furu.g.aas.no>
+ Branch: perl
+ ! ObjXSub.h av.c embed.h global.sym objpp.h pod/perldiag.pod
+ ! pp.c proto.h t/op/avhv.t
+____________________________________________________________________________
+[ 1285] By: gsar on 1998/07/04 02:30:48
+ Log: tweak doc for ".."
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Subject: [PATCH] pod for scalar ..
+ Message-Id: <E0yqyN8-0006gv-00@taurus.cus.cam.ac.uk>
+ Date: Tue, 30 Jun 1998 12:14:50 +0100
+ Branch: perl
+ ! pod/perlop.pod
+____________________________________________________________________________
+[ 1284] By: gsar on 1998/07/04 02:28:43
+ Log: fix use of uninitialized var in pp_unpack()
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Tue, 30 Jun 1998 14:32:17 +0300 (EET DST)
+ Message-Id: <199806301132.OAA27353@alpha.hut.fi>
+ Subject: [PATCH] 5.004_69 (also for 5.004_04) one more^Wless quad bug
+ Branch: perl
+ ! pp.c
+____________________________________________________________________________
+[ 1283] By: gsar on 1998/07/04 02:26:37
+ Log: From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Tue, 30 Jun 1998 11:40:22 +0300 (EET DST)
+ Message-Id: <199806300840.LAA04872@alpha.hut.fi>
+ Subject: [PATCH] 5.004_69: Parsewords.pm: avoid undefined warnings
+ Branch: perl
+ ! lib/Text/ParseWords.pm
+____________________________________________________________________________
+[ 1282] By: gsar on 1998/07/04 02:24:32
+ Log: VMS updates from Dan Sugalski <sugalskd@osshe.edu>
+ Message-Id: <3.0.5.32.19980629165356.00a20730@ous.edu>
+ Date: Mon, 29 Jun 1998 16:53:56 -0700
+ Subject: [PATCH 5.004_69]README.vms doc patch
+ --
+ Message-Id: <3.0.5.32.19980629165125.00a4e100@ous.edu>
+ Date: Mon, 29 Jun 1998 16:51:25 -0700
+ --
+ Message-Id: <3.0.5.32.19980702135357.00a5eb40@ous.edu>
+ Date: Thu, 02 Jul 1998 13:53:57 -0700
+ Subject: [PATCH 5.004_69]VMS filetest operator fixup
+ Branch: perl
+ ! README.vms vms/descrip_mms.template vms/vms.c
+____________________________________________________________________________
+[ 1281] By: gsar on 1998/07/04 02:17:48
+ Log: From: Dan Sugalski <sugalskd@osshe.edu>
+ Message-Id: <3.0.5.32.19980629164625.00a4d7c0@ous.edu>
+ Date: Mon, 29 Jun 1998 16:46:25 -0700
+ Subject: [PATCH 5.004_69]Tweaks to VMS configuration procedure
+ Branch: perl
+ ! vms/subconfigure.com
+____________________________________________________________________________
+[ 1280] By: gsar on 1998/07/04 02:16:03
+ Log: don't attempt to copy directories on VMS
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Message-Id: <3.0.5.32.19980629163129.00a82140@ous.edu>
+ Date: Mon, 29 Jun 1998 16:31:29 -0700
+ Subject: [PATCH 5.004_69]Tweak to installperl
+ Branch: perl
+ ! installperl
+____________________________________________________________________________
+[ 1279] By: gsar on 1998/07/04 02:09:26
+ Log: add 'installhtml*dir' to win32 config templates
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Subject: [PATCH 5.004_68] For Win32 config
+ Date: Mon, 29 Jun 1998 09:00:13 -0700
+ Message-ID: <000a01bda376$ffe8b0b0$a32fa8c0@tau.Active>
+ Branch: perl
+ ! win32/config.bc win32/config.gc win32/config.vc
+____________________________________________________________________________
+[ 1278] By: gsar on 1998/07/04 02:06:23
+ Log: implemented described fix for h2ph hanging on "enum"
+ From: Billy <wdconsta@cs.adelaide.edu.au>
+ Subject: Re: h2ph problem on Solaris 2.6/SPARC/Sun compiler
+ Message-ID: <Pine.SV4.3.93.980627010407.21715A-100000@xenon.teaching.cs.adelaide.edu.au>
+ Date: Sat, 27 Jun 1998 01:13:12 +0930 (CST)
+ Branch: perl
+ ! utils/h2ph.PL
+____________________________________________________________________________
+[ 1277] By: gsar on 1998/07/04 01:51:47
+ Log: merge changes#1210,1211,1270 from maintbranch
+ Branch: perl
+ + lib/re.pm
+ ! MANIFEST dump.c installperl lib/File/Basename.pm mg.c op.c
+ ! op.h perl.h pod/perlmodlib.pod pod/perlop.pod pp_ctl.c
+ ! pp_hot.c t/lib/basename.t t/op/taint.t toke.c
+____________________________________________________________________________
+[ 1276] By: gsar on 1998/07/04 00:33:37
+ Log: deprecate use of reserved word "our" (Larry's idea)
+ Date: Mon, 22 Jun 1998 08:55:09 -0700
+ From: larry@wall.org (Larry Wall)
+ Message-Id: <199806221555.IAA07212@wall.org>
+ Subject: Re: our
+ Branch: perl
+ ! pod/perldiag.pod toke.c
+____________________________________________________________________________
+[ 1275] By: nick on 1998/07/02 18:36:59
+ Log: Integrate mainline, just to keep up.
+ Branch: ansiperl
+ +> t/lib/fields.t
+ - lib/Math/Trig/Radial.pm
+ !> MANIFEST lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm
+ !> lib/Math/Trig.pm lib/base.pm lib/fields.pm mg.c
+ !> pod/perldiag.pod pod/perltrap.pod pp_hot.c scope.c scope.h
+ !> t/lib/trig.t t/op/array.t toke.c utils/perldoc.PL
+ !> win32/config.bc win32/config.gc win32/config.vc
+ !> win32/include/dirent.h win32/makedef.pl win32/win32.c
+ !> win32/win32iop.h
+____________________________________________________________________________
+[ 1274] By: gsar on 1998/07/02 16:47:20
+ Log: tweak win32/config.* variables
+ Branch: perl
+ ! win32/config.bc win32/config.gc win32/config.vc
+____________________________________________________________________________
+[ 1273] By: gsar on 1998/07/02 16:33:53
+ Log: export opendir() set of functions on win32
+ Branch: perl
+ ! win32/include/dirent.h win32/makedef.pl win32/win32.c
+ ! win32/win32iop.h
+____________________________________________________________________________
+[ 1272] By: gsar on 1998/07/01 23:21:49
+ Log: fix C<@a = (%a = 1)> bizarreness
+ Branch: perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 1271] By: gsar on 1998/06/30 22:49:39
+ Log: document perltrap on precedence of keys/values/each
+ Branch: perl
+ ! pod/perltrap.pod
+____________________________________________________________________________
+[ 1270] By: TimBunce on 1998/06/30 09:06:21
+ Log: Added lib/re.pm missing from change 1210
+ Branch: maint-5.004/perl
+ + lib/re.pm
+____________________________________________________________________________
+[ 1269] By: gsar on 1998/06/30 08:20:52
+ Log: From: Murray Nesbitt <murray@ActiveState.com>
+ Message-Id: <77180549BCE.AAA466A@mail.rdc1.bc.wave.home.com>
+ Date: Mon, 29 Jun 1998 14:30:59 PDT
+ Subject: Re: [PATCH 5.004_67] MakeMaker mods for PPD support
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm
+____________________________________________________________________________
+[ 1268] By: gsar on 1998/06/30 05:38:34
+ Log: From: Robin Barker <rmb1@cise.npl.co.uk>
+ Message-Id: <13254.9806291404@tempest.cise.npl.co.uk>
+ Date: Mon, 29 Jun 1998 15:04:57 -0000
+ Subject: [PATCH perl5.004_69] perldoc.PL
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 1267] By: gsar on 1998/06/30 05:34:06
+ Log: add patch to integrate Math::Trig::Radial into Math::Trig
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Mon, 29 Jun 1998 16:28:53 +0300 (EET DST)
+ Message-Id: <199806291328.QAA16916@alpha.hut.fi>
+ Subject: [PATCH] 5.004_68 (or 5.004_04): radial trig
+ Branch: perl
+ - lib/Math/Trig/Radial.pm
+ ! MANIFEST lib/Math/Trig.pm t/lib/trig.t
+____________________________________________________________________________
+[ 1266] By: gsar on 1998/06/30 05:17:33
+ Log: From: Gisle Aas <gisle@aas.no>
+ Message-Id: <m367hk4hra.fsf@furu.g.aas.no>
+ Date: 29 Jun 1998 12:36:09 +0200
+ Subject: Re: [PATCH] Simplified magic_setisa() and improved fields.pm
+ Branch: perl
+ + t/lib/fields.t
+ ! MANIFEST lib/base.pm lib/fields.pm mg.c pod/perldiag.pod
+ ! t/op/array.t
+____________________________________________________________________________
+[ 1265] By: gsar on 1998/06/30 05:12:57
+ Log: tweaks to overloaded constants (change#1259)
+ Branch: perl
+ ! scope.c scope.h toke.c
+____________________________________________________________________________
+[ 1264] By: nick on 1998/06/29 17:38:03
+ Log: Integrate mainline c. _69 to ansiperl
+ Branch: ansiperl
+ +> eg/cgi/caution.xbm eg/cgi/dna.small.gif.uu
+ +> eg/cgi/nph-multipart.cgi ext/Errno/ChangeLog
+ +> ext/Errno/Errno_pm.PL ext/Errno/Makefile.PL lib/CGI/Cookie.pm
+ +> lib/Math/Trig/Radial.pm perlio.h t/lib/cgi-form.t
+ +> t/lib/cgi-function.t t/lib/cgi-html.t t/lib/cgi-request.t
+ +> t/lib/errno.t t/op/goto_xs.t t/op/splice.t
+ !> (integrate 100 files)
+
+----------------
+Version 5.004_69
+----------------
+
+____________________________________________________________________________
+[ 1263] By: gsar on 1998/06/29 09:17:28
+ Log: update Changes and perlhist.pod
+ Branch: perl
+ ! Changes pod/perlhist.pod
+____________________________________________________________________________
+[ 1262] By: gsar on 1998/06/29 08:26:36
+ Log: bump patchlevel to 69, various little tweaks (tested on win32, Solaris
+ under several build configurations)
+ Branch: perl
+ ! Todo.5.005 op.c patchlevel.h t/lib/cgi-function.t
+ ! t/lib/cgi-request.t toke.c win32/Makefile win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1261] By: gsar on 1998/06/29 06:51:10
+ Log: add missing SSCHECK() to rectify faulty SSPUSH*() logic in change#1259
+ Branch: perl
+ ! scope.h
+____________________________________________________________________________
+[ 1260] By: gsar on 1998/06/29 06:46:12
+ Log: Message-Id: <199806290610.IAA19443@moulon.inra.fr>
+ Date: Mon, 29 Jun 1998 08:10:46 +0200
+ From: ts <decoux@moulon.inra.fr>
+ Subject: {perlembed.pod] Re: Memory leak in Perl 5.004 and the fix
+ Branch: perl
+ ! pod/perlembed.pod
+____________________________________________________________________________
+[ 1259] By: gsar on 1998/06/29 06:01:35
+ Log: added patch for overloading constants, made PERL_OBJECT-aware
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806270328.XAA21088@monk.mps.ohio-state.edu>
+ Date: Fri, 26 Jun 1998 23:28:41 -0400 (EDT)
+ Branch: perl
+ ! ObjXSub.h embed.h embedvar.h global.sym hv.c interp.sym
+ ! intrpvar.h lib/Math/BigInt.pm lib/overload.pm objpp.h op.c
+ ! perl.c perl.h pp_ctl.c proto.h scope.c scope.h
+ ! t/pragma/overload.t toke.c
+____________________________________________________________________________
+[ 1258] By: gsar on 1998/06/29 05:32:25
+ Log: fix Socket.pm typo from change#1240
+ Branch: perl
+ ! ext/Socket/Socket.pm
+____________________________________________________________________________
+[ 1257] By: gsar on 1998/06/29 05:09:24
+ Log: applied patch, tweak for threads awareness
+ From: Albert Dvornik <bert@genscan.com>
+ Subject: [PATCH]5.004_04-m4 (CORE) fix for broken "goto &xsub"
+ Date: 24 Jun 1998 19:33:09 -0400
+ Message-Id: <tq4sxawf2h.fsf@puma.genscan.com>
+ Branch: perl
+ + t/op/goto_xs.t
+ ! MANIFEST pp_ctl.c
+____________________________________________________________________________
+[ 1256] By: gsar on 1998/06/29 03:34:18
+ Log: applied patch, fixed one more leak, tweaked whitespace bugs
+ From: Guy Decoux <decoux@moulon.inra.fr>
+ (via)
+ Date: Fri, 26 Jun 1998 09:59:32 -0400
+ From: "Chunhui Teng" <cteng@nortel.ca>
+ Message-Id: <199806261359.JAA02393@bmers357.nortel.ca>
+ Subject: Memory leak in Perl 5.004 and the fix
+ Branch: perl
+ ! ext/Opcode/Opcode.xs ext/Opcode/Safe.pm
+____________________________________________________________________________
+[ 1255] By: gsar on 1998/06/29 02:50:37
+ Log: From: koenig@kulturbox.de (Andreas J. Koenig)
+ Subject: Permissions in MakeMaker (Was: patch to MM_Unix.pm)
+ Date: 28 Jun 1998 23:47:07 +0200
+ Message-ID: <sfc1zs9gpwk.fsf@dubravka.in-berlin.de>
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm
+____________________________________________________________________________
+[ 1254] By: gsar on 1998/06/28 21:35:02
+ Log: From: joshua.pritikin@db.com
+ Date: Fri, 26 Jun 1998 09:34:34 -0400
+ Message-Id: <H00000e500081d23@MHS>
+ Subject: [PATCH _68] PUSHSTACK renovation
+ Branch: perl
+ ! av.c cop.h gv.c mg.c perl.c pp_ctl.c pp_sys.c sv.c util.c
+____________________________________________________________________________
+[ 1253] By: gsar on 1998/06/28 21:21:22
+ Log: From: Stephen McCamant <alias@mcs.com>
+ Message-Id: <m0yq2fr-000EalC@alias-2.pr.mcs.net>
+ Date: Sat, 27 Jun 1998 16:38:19 -0500 (CDT)
+ Subject: IV changes for long long (was Re: 5.004_68 on its way to the CPAN)
+ Branch: perl
+ ! perlvars.h sv.c
+____________________________________________________________________________
+[ 1252] By: gsar on 1998/06/28 21:16:34
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806272359.TAA05436@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_68] Improve warning on zero-length chunks in RE
+ Date: Sat, 27 Jun 1998 19:59:13 -0400 (EDT)
+ Branch: perl
+ ! regcomp.c
+____________________________________________________________________________
+[ 1251] By: gsar on 1998/06/28 21:14:32
+ Log: add Math/Trig/Radial.pm, update MANIFEST
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Sat, 27 Jun 1998 17:28:14 +0300 (EET DST)
+ Message-Id: <199806271428.RAA05307@alpha.hut.fi>
+ Subject: Math::Trig::Radial ?
+ Branch: perl
+ + lib/Math/Trig/Radial.pm
+ ! MANIFEST
+____________________________________________________________________________
+[ 1250] By: gsar on 1998/06/28 21:09:48
+ Log: applied patch, tweaked doc, and regen regnodes.h
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806270655.CAA29144@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_68] \z in RE
+ Date: Sat, 27 Jun 1998 02:55:26 -0400 (EDT)
+ Branch: perl
+ ! pod/perlre.pod regcomp.c regcomp.sym regexec.c regnodes.h
+ ! t/op/re_tests t/op/regexp.t toke.c
+____________________________________________________________________________
+[ 1249] By: gsar on 1998/06/28 20:56:38
+ Log: From: mike@bill.iac.net
+ Message-ID: <19980627034913.A32220@bill.minivend.com>
+ Date: Sat, 27 Jun 1998 03:49:13 +0000
+ Subject: [ PATCH 5.004 68 ] Text::ParseWords, ^W fixed, version 3.1
+ Branch: perl
+ ! lib/Text/ParseWords.pm t/lib/parsewords.t
+____________________________________________________________________________
+[ 1248] By: gsar on 1998/06/28 20:54:43
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806270352.XAA21174@monk.mps.ohio-state.edu>
+ Subject: [PATCH] Fix ptags
+ Date: Fri, 26 Jun 1998 23:52:54 -0400 (EDT)
+ Branch: perl
+ ! emacs/ptags
+____________________________________________________________________________
+[ 1247] By: gsar on 1998/06/28 20:42:54
+ Log: apply patch sent via private mail
+ From: Stephen McCamant <alias@mcs.com>
+ Message-Id: <m0ypkmt-000EalC@alias-2.pr.mcs.net>
+ Date: Fri, 26 Jun 1998 21:32:23 -0500 (CDT)
+ Subject: Re: Enhanced B::Deparse
+ Branch: perl
+ ! ext/B/B/Deparse.pm
+____________________________________________________________________________
+[ 1246] By: gsar on 1998/06/28 20:38:24
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806270109.VAA14907@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_68] pat.t tests
+ Date: Fri, 26 Jun 1998 21:09:02 -0400 (EDT)
+ Branch: perl
+ ! t/op/pat.t
+____________________________________________________________________________
+[ 1245] By: gsar on 1998/06/28 20:36:08
+ Log: From: joshua.pritikin@db.com
+ Date: Fri, 26 Jun 1998 10:02:32 -0400
+ Message-Id: <H00000e500081d28@MHS>
+ Subject: [PATCH _68] improve recursive error messages!
+ Branch: perl
+ ! gv.c pod/perldiag.pod universal.c
+____________________________________________________________________________
+[ 1244] By: gsar on 1998/06/28 20:09:02
+ Log: From: Dominic Dunlop <domo@vo.lu>
+ Message-Id: <v03110701b1b83a06733a@[195.95.102.101]>
+ Date: Thu, 25 Jun 1998 17:46:55 +0000
+ Subject: [PATCH 5.004_68]: Move REG_INFTY-dependent tests from op/regexp.t
+ to op/pat.t; add tests for a few more regexp parse failures etc.
+ Branch: perl
+ ! t/op/pat.t t/op/re_tests t/op/regexp.t
+____________________________________________________________________________
+[ 1243] By: gsar on 1998/06/28 20:06:30
+ Log: specify *.sym files needed in perl_exp.SH instead of picking up all
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Thu, 25 Jun 1998 10:36:21 -0400 (EDT)
+ Subject: Re: Not OK: perl 5.00468 on aix-thread 4.1.4.0
+ Message-Id: <Pine.SUN.3.96.980625102459.11241F-100000@newton.phys>
+ Branch: perl
+ ! perl_exp.SH
+____________________________________________________________________________
+[ 1242] By: gsar on 1998/06/28 20:01:28
+ Log:
+ From: Gisle Aas <gisle@aas.no>
+ Subject: Re: [PATCH] 4-arg substr update for perl5.004_68
+ Date: 25 Jun 1998 10:32:43 +0200
+ Message-ID: <m3iulpubis.fsf@furu.g.aas.no>
+ Branch: perl
+ ! op.c pod/perlfunc.pod pp.c t/op/substr.t
+____________________________________________________________________________
+[ 1241] By: gsar on 1998/06/28 19:55:11
+ Log: applied patch, tweaked opcode.pl for PERL_OBJECT, and regen opcode.h
+ From: Stephen McCamant <alias@mcs.com>
+ Message-Id: <m0yp1Ue-000EP2C@alias-2.pr.mcs.net>
+ Date: Wed, 24 Jun 1998 21:10:32 -0500 (CDT)
+ Subject: [PATCH REPOST] refgen in opcode.pl
+ Branch: perl
+ ! opcode.h opcode.pl
+____________________________________________________________________________
+[ 1240] By: gsar on 1998/06/28 19:46:29
+ Log: From: Chris Nandor <pudge@pobox.com>
+ Message-Id: <v04011709b1b742cd7f0c@[24.48.29.192]>
+ Date: Wed, 24 Jun 1998 19:58:28 -0400
+ Subject: [PATCH 3d try] Add CR LF CRLF to Socket.pm
+ Branch: perl
+ ! ext/Socket/Socket.pm
+____________________________________________________________________________
+[ 1239] By: gsar on 1998/06/28 19:44:19
+ Log: From: Gisle Aas <gisle@aas.no>
+ Subject: [PATCH] Optimize foreach (1..1000000)
+ Date: 24 Jun 1998 20:26:48 +0200
+ Message-ID: <m3lnqmwt93.fsf@furu.g.aas.no>
+ Branch: perl
+ ! Todo cop.h op.c pod/perldiag.pod pod/perlop.pod pp_ctl.c
+ ! pp_hot.c t/op/range.t
+____________________________________________________________________________
+[ 1238] By: gsar on 1998/06/28 19:28:13
+ Log: avoid creation of %^R
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806241825.OAA06346@monk.mps.ohio-state.edu>
+ Subject: Re: [5.004_68] What is %^R ? [PATCH?]
+ Date: Wed, 24 Jun 1998 14:25:06 -0400 (EDT)
+ Branch: perl
+ ! perl.c t/op/splice.t
+____________________________________________________________________________
+[ 1237] By: gsar on 1998/06/28 19:23:40
+ Log: From: Gisle Aas <gisle@aas.no>
+ Subject: [PATCH] Negative LENGTH argument to splice
+ Date: 24 Jun 1998 15:11:35 +0200
+ Message-ID: <m3g1gvc5bs.fsf@furu.g.aas.no>
+ Branch: perl
+ + t/op/splice.t
+ ! MANIFEST pod/perlfunc.pod pp.c
+____________________________________________________________________________
+[ 1236] By: gsar on 1998/06/28 19:18:29
+ Log: From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Subject: [PATCH] Insecure $ENV{} message out of step with perldiag
+ Message-Id: <E0yooQA-0003za-00@taurus.cus.cam.ac.uk>
+ Date: Wed, 24 Jun 1998 13:13:02 +0100
+ Branch: perl
+ ! pod/perldiag.pod pod/perlsec.pod
+____________________________________________________________________________
+[ 1235] By: gsar on 1998/06/28 19:16:13
+ Log: Complex.pm update
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Wed, 24 Jun 1998 15:19:05 +0300 (EET DST)
+ Message-Id: <199806241219.PAA04061@alpha.hut.fi>
+ Subject: [PATCH] 5.004_68: Complex.pm, complex.t
+ Branch: perl
+ ! lib/Math/Complex.pm t/lib/complex.t
+____________________________________________________________________________
+[ 1234] By: gsar on 1998/06/28 19:13:05
+ Log: disable perl malloc on UNICOS for now
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Wed, 24 Jun 1998 12:37:14 +0300 (EET DST)
+ Message-Id: <199806240937.MAA01669@alpha.hut.fi>
+ Subject: [PATCH] 5.004_68: UNICOS hints
+ Branch: perl
+ ! hints/unicos.sh
+____________________________________________________________________________
+[ 1233] By: gsar on 1998/06/28 19:10:53
+ Log: fixes unpack("q"...), and semctl() tests for UNICOS
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Wed, 24 Jun 1998 11:55:09 +0300 (EET DST)
+ Message-Id: <199806240855.LAA16152@alpha.hut.fi>
+ Subject: [PATCH] 5.004_68: semctl() in UNICOS (was: pack/unpack)
+ Branch: perl
+ ! pp.c t/op/ipcsem.t t/op/pack.t
+____________________________________________________________________________
+[ 1232] By: gsar on 1998/06/28 19:01:23
+ Log: tweak various places for iperlsys.h awareness
+ Branch: perl
+ ! MANIFEST Makefile.SH lib/ExtUtils/MM_Unix.pm
+ ! lib/ExtUtils/MM_VMS.pm pod/perlapio.pod
+____________________________________________________________________________
+[ 1231] By: gsar on 1998/06/28 18:37:07
+ Log: add a perlio.h stub for compat (some extensions seem to #include it)
+ Branch: perl
+ + perlio.h
+____________________________________________________________________________
+[ 1230] By: gsar on 1998/06/28 18:35:23
+ Log: Message-ID: <19980624003701.C161@cdata.tvnet.hu>
+ Date: Wed, 24 Jun 1998 00:37:01 +0200
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Subject: Re: [PATCH for _66] Makefile.SH problem on dos/djgpp
+ Branch: perl
+ ! pod/pod2text.PL
+____________________________________________________________________________
+[ 1229] By: gsar on 1998/06/28 18:33:42
+ Log: hand apply mutiliated patch
+ Message-Id: <3.0.5.32.19980623114100.00ab76e0@ous.edu>
+ Date: Tue, 23 Jun 1998 11:41:00 -0700
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Subject: [PATCH 5.004_68]Configure update for VMS
+ Branch: perl
+ ! configure.com vms/descrip_mms.template vms/subconfigure.com
+____________________________________________________________________________
+[ 1228] By: gsar on 1998/06/28 17:17:35
+ Log: hand apply whitespace mutiliated patch
+ Date: Tue, 23 Jun 98 16:38:06 BST
+ Message-Id: <5389.9806231538@tempest.cise.npl.co.uk>
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Subject: PATCH [perl5.004_68] perlbug.PL; was Re: Error message for Errno_pm.PL
+ Branch: perl
+ ! utils/perlbug.PL
+____________________________________________________________________________
+[ 1227] By: gsar on 1998/06/28 17:14:34
+ Log: Date: Tue, 23 Jun 1998 08:51:00 -0700 (PDT)
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Subject: [PATCH] documenting close without arguments
+ Message-ID: <Pine.GSO.3.96.980623084413.24075V-100000@user2.teleport.com>
+ Branch: perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 1226] By: gsar on 1998/06/28 17:12:56
+ Log: Date: Tue, 23 Jun 1998 05:37:09 -0700 (PDT)
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Subject: Better diags for vars.pm
+ Message-ID: <Pine.GSO.3.96.980623052846.24075A-100000@user2.teleport.com>
+ Branch: perl
+ ! lib/vars.pm
+____________________________________________________________________________
+[ 1225] By: gsar on 1998/06/28 17:05:59
+ Log: hand apply whitespace mutiliated perldoc.PL patches
+ Date: Tue, 23 Jun 98 15:49:52 BST
+ Message-Id: <5302.9806231449@tempest.cise.npl.co.uk>
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Subject: PATCH [5.004_68] perldoc.PL
+ --
+ Date: Fri, 26 Jun 98 17:50:05 BST
+ Message-Id: <6834.9806261650@tempest.cise.npl.co.uk>
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Subject: [PATCH 5.004_68] perldoc.PL
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 1224] By: gsar on 1998/06/28 16:50:59
+ Log: integrate ansiperl to get makedef.pl tweak
+ Branch: perl
+ ! Porting/pumpkin.pod win32/makedef.pl
+____________________________________________________________________________
+[ 1223] By: gsar on 1998/06/28 16:33:32
+ Log: add CGI-2.42, its and testsuite
+ Branch: perl
+ + eg/cgi/caution.xbm eg/cgi/dna.small.gif.uu
+ + eg/cgi/nph-multipart.cgi lib/CGI/Cookie.pm t/lib/cgi-form.t
+ + t/lib/cgi-function.t t/lib/cgi-html.t t/lib/cgi-request.t
+ ! MANIFEST eg/cgi/RunMeFirst eg/cgi/file_upload.cgi
+ ! eg/cgi/index.html eg/cgi/monty.cgi eg/cgi/save_state.cgi
+ ! eg/cgi/wilogo.gif.uu lib/CGI.pm lib/CGI/Apache.pm
+ ! lib/CGI/Carp.pm lib/CGI/Fast.pm lib/CGI/Push.pm
+ ! lib/CGI/Switch.pm
+____________________________________________________________________________
+[ 1222] By: gsar on 1998/06/28 15:28:29
+ Log: enable Errno build on win32, add Errno-1.08 files to repository
+ Branch: perl
+ + ext/Errno/ChangeLog ext/Errno/Errno_pm.PL
+ + ext/Errno/Makefile.PL t/lib/errno.t
+ ! MANIFEST win32/Makefile win32/config.bc win32/config.gc
+ ! win32/config.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1221] By: gsar on 1998/06/28 14:34:06
+ Log: tweak win32 config templates for cpp
+ Branch: perl
+ ! win32/config.bc win32/config.gc win32/config.vc
+____________________________________________________________________________
+[ 1220] By: nick on 1998/06/26 16:46:13
+ Log: Integrate mainline
+ Branch: ansiperl
+ !> Changes Makefile.SH ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod
+ !> ext/POSIX/POSIX.xs perl.c pod/perlre.pod pod/perlvar.pod sv.c
+ !> util.c win32/win32.h
+____________________________________________________________________________
+[ 1219] By: gsar on 1998/06/26 04:33:57
+ Log: make find_script() return saved string, reenable missing diagnostics
+ Branch: perl
+ ! perl.c util.c
+____________________________________________________________________________
+[ 1218] By: gsar on 1998/06/25 23:24:53
+ Log: avoid warning with -P switch
+ Branch: perl
+ ! perl.c
+____________________________________________________________________________
+[ 1217] By: gsar on 1998/06/25 22:06:58
+ Log: don't suppress display of Makefile recipes that invoke perl
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 1216] By: gsar on 1998/06/25 21:32:06
+ Log: tweak order of destruction so OBJECTs in GLOBs are visited after those
+ in RVs
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 1215] By: gsar on 1998/06/25 18:56:59
+ Log: mknod() is not POSIX, so remove the POSIX pieces from change#1199
+ Branch: perl
+ ! ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs
+____________________________________________________________________________
+[ 1214] By: gsar on 1998/06/25 18:11:22
+ Log: add FILE_SHARE_DELETE ifndef in win32.h
+ Branch: perl
+ ! win32/win32.h
+____________________________________________________________________________
+[ 1213] By: nick on 1998/06/24 17:18:59
+ Log: Correct perl malloc tweak to .def generation
+ Branch: ansiperl
+ ! win32/makedef.pl
+____________________________________________________________________________
+[ 1212] By: gsar on 1998/06/24 12:40:13
+ Log: check in what change#1182 didn't, and Changes
+ Branch: perl
+ ! Changes pod/perlre.pod pod/perlvar.pod
+____________________________________________________________________________
+[ 1211] By: TimBunce on 1998/06/23 23:09:37
+ Log: Update test count in t/lib/basename.t (see change 1210)
+ Branch: maint-5.004/perl
+ ! t/lib/basename.t
+____________________________________________________________________________
+[ 1210] By: TimBunce on 1998/06/23 22:58:18
+ Log: Title: "Add C<use re 'taint'> pragma to propagate tainting in m// and s///"
+ From: Chip Salzenberg <chip@perl.org>, Gurusamy Sarathy
+ <gsar@engin.umich.edu>, Tim.Bunce@ig.co.uk (Tim Bunce)
+ Msg-ID: <19980525155222.A18445@perlsupport.com>,
+ <199805261143.MAA04260@toad.ig.co.uk>,
+ <199805261235.IAA10371@aatma.engin.umich.edu>,
+ Files: MANIFEST pod/perlmodlib.pod pod/perlop.pod op.h perl.h dump.c
+ installperl lib/re.pm lib/File/Basename.pm mg.c op.c
+ pp_ctl.c pp_hot.c t/lib/basename.t t/op/taint.t toke.c
+ Branch: maint-5.004/perl
+ ! MANIFEST dump.c embed.h installperl lib/File/Basename.pm mg.c
+ ! op.c op.h perl.h pod/perlmodlib.pod pod/perlop.pod pp_ctl.c
+ ! pp_hot.c t/lib/basename.t t/op/taint.t toke.c
+____________________________________________________________________________
+[ 1209] By: nick on 1998/06/23 21:33:34
+ Log: Perl_malloced_size() only available with perl's malloc
+ Branch: ansiperl
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 1208] By: nick on 1998/06/23 18:15:23
+ Log: Integrate mainline c. 5.004_68 into ansiperl, mainly
+ so see what has changed...
+ Branch: ansiperl
+ +> Porting/genlog iperlsys.h lib/File/Spec.pm
+ +> lib/File/Spec/Mac.pm lib/File/Spec/OS2.pm
+ +> lib/File/Spec/Unix.pm lib/File/Spec/VMS.pm
+ +> lib/File/Spec/Win32.pm regcomp.pl regcomp.sym regnodes.h
+ +> t/lib/filespec.t win32/perlhost.h
+ - atomic.h ipdir.h ipenv.h iplio.h ipmem.h ipproc.h ipsock.h
+ - ipstdio.h perldir.h perlenv.h perlio.h perllio.h perlmem.h
+ - perlproc.h perlsock.h
+ !> (integrate 96 files)
+
+----------------
+Version 5.004_68
+----------------
+
+____________________________________________________________________________
+[ 1207] By: gsar on 1998/06/23 10:55:05
+ Log: final touches to 5.004_68
+ Branch: perl
+ ! perl.c
+____________________________________________________________________________
+[ 1206] By: gsar on 1998/06/23 10:50:10
+ Log: more MULTIPLICITY tweaks
+ Branch: perl
+ ! objpp.h perl.c perl.h proto.h win32/GenCAPI.pl win32/config.bc
+ ! win32/config.gc win32/config.vc win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc
+____________________________________________________________________________
+[ 1205] By: gsar on 1998/06/23 09:03:46
+ Log: partial MULTIPLICITY cleanup
+ Branch: perl
+ ! embedvar.h interp.sym intrpvar.h perl.c perlvars.h proto.h
+ ! thrdvar.h
+____________________________________________________________________________
+[ 1204] By: gsar on 1998/06/23 09:00:48
+ Log: tweak MANIFEST, add Dev_t to POSIX/typemap
+ Branch: perl
+ ! MANIFEST Porting/makerel README.win32 ext/POSIX/typemap
+____________________________________________________________________________
+[ 1203] By: gsar on 1998/06/23 07:08:02
+ Log: bump patchlevel to 68, Porting/makerel tweaks
+ Branch: perl
+ ! Porting/makerel patchlevel.h win32/Makefile win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1202] By: gsar on 1998/06/23 06:16:19
+ Log: remove atomic.h pending resolution of licensing issues,
+ EMULATE_ATOMIC_REFCOUNTS everywhere
+ Branch: perl
+ - atomic.h
+ ! MANIFEST perl.h sv.h
+____________________________________________________________________________
+[ 1201] By: gsar on 1998/06/23 06:06:23
+ Log: applied patch, regen headers
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806220819.EAA03295@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] Malloc size feedback
+ Date: Mon, 22 Jun 1998 04:19:45 -0400 (EDT)
+ Branch: perl
+ ! ObjXSub.h av.c embed.h global.sym hv.c malloc.c objpp.h perl.c
+ ! pp_sys.c proto.h sv.c toke.c
+____________________________________________________________________________
+[ 1200] By: gsar on 1998/06/23 05:59:09
+ Log: Message-Id: <m0yoIgR-000EP2C@alias-2.pr.mcs.net>
+ Date: Mon, 22 Jun 1998 21:19:43 -0500 (CDT)
+ From: Stephen McCamant <alias@mcs.com>
+ Subject: [PATCH] Inheritance of B:: classes
+ Branch: perl
+ ! ext/B/B.pm
+____________________________________________________________________________
+[ 1199] By: gsar on 1998/06/23 05:57:58
+ Log: applied patch, moved #define mkfifo ... from perl.h to POSIX.xs
+ Date: Tue, 23 Jun 1998 00:01:02 +0300 (EET DST)
+ Message-Id: <199806222101.AAA16456@alpha.hut.fi>
+ Subject: [PATCH] _67: somebody said POSIX::mknod?
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! Configure config_h.SH ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod
+ ! ext/POSIX/POSIX.xs perl.h
+____________________________________________________________________________
+[ 1198] By: gsar on 1998/06/23 05:48:56
+ Log: Date: Mon, 22 Jun 1998 14:10:46 -0600 (MDT)
+ From: Daniel Grisinger <dgris@perrin.dimensional.com>
+ Subject: PATCH [5.004_67] perldoc.PL
+ Message-ID: <Pine.LNX.3.96.980622135953.10412A-100000@perrin.dimensional.com>
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 1197] By: gsar on 1998/06/23 05:47:24
+ Log: Message-Id: <3.0.5.32.19980622092918.00aa46e0@ous.edu>
+ Date: Mon, 22 Jun 1998 09:29:18 -0700
+ From: Dan Sugalski <sugalskd@ous.edu>
+ Subject: [PATCH 5.004_67] Autosplit's not qite case-insensitive enough on VMS
+ Branch: perl
+ ! lib/AutoSplit.pm
+____________________________________________________________________________
+[ 1196] By: gsar on 1998/06/23 05:45:19
+ Log: Date: Mon, 22 Jun 1998 18:58:55 +0300 (EET DST)
+ Message-Id: <199806221558.SAA18626@alpha.hut.fi>
+ Subject: [PATCH] 5.004_67: Fcntl: add few constants, enhance maintainability
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs
+____________________________________________________________________________
+[ 1195] By: gsar on 1998/06/23 05:43:32
+ Log: Message-Id: <v03110700b1b41e1760b2@[195.95.102.55]>
+ Date: Mon, 22 Jun 1998 15:22:24 +0000
+ From: Dominic Dunlop <domo@vo.lu>
+ Subject: [PATCH 5.004_67] Amend tests/regexp.t for variable REG_INFTY;
+ update machten.sh to vary REG_INFTY
+ Branch: perl
+ ! hints/machten.sh t/op/re_tests t/op/regexp.t
+____________________________________________________________________________
+[ 1194] By: gsar on 1998/06/23 05:38:36
+ Log: filter out array subscripts when generating symbols for AIX
+ Date: Mon, 22 Jun 1998 12:14:31 +0300 (EET DST)
+ Message-Id: <199806220914.MAA13631@alpha.hut.fi>
+ Subject: [PATCH] 5.004_67: perl.exp bug, AIX unhappy
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! perl_exp.SH
+____________________________________________________________________________
+[ 1193] By: gsar on 1998/06/23 05:32:52
+ Log: updated hints file to cope with buggy sigsetjmp() on Solaris-x86
+ Message-Id: <199806221102.NAA12106@alanya.m.isar.de>
+ Date: Mon, 22 Jun 1998 13:02:45 +0200 (MET DST)
+ From: Lupe Christoph <lupe@alanya.m.isar.de>
+ Subject: Re: Perl 5.004_67: Death is on vacation - miniperl can't die
+ Branch: perl
+ ! hints/solaris_2.sh
+____________________________________________________________________________
+[ 1192] By: gsar on 1998/06/23 05:27:13
+ Log: add detailed changelogs and 'genlog'--the script which generates them
+ Branch: perl
+ + Porting/genlog
+ ! Changes INSTALL
+____________________________________________________________________________
+[ 1191] By: gsar on 1998/06/22 15:56:27
+ Log: tweak win32 makefiles for PERL_OBJECT build
+ Branch: perl
+ ! win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1190] By: gsar on 1998/06/22 04:06:02
+ Log: backout change#1178 as it was dependent on an unapplied patch,
+ fix filespec.t to know its @INC
+ Branch: perl
+ ! sv.c t/lib/filespec.t
+____________________________________________________________________________
+[ 1189] By: gsar on 1998/06/22 03:47:43
+ Log: eliminate use of tokenbuf in util.c
+ Branch: perl
+ ! util.c
+____________________________________________________________________________
+[ 1188] By: gsar on 1998/06/22 01:53:59
+ Log: add patch that generates regnodes.h via regcomp.pl
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806212038.QAA29797@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] regcomp.h regnodes cleanup
+ Date: Sun, 21 Jun 1998 16:38:21 -0400 (EDT)
+ Branch: perl
+ + regcomp.pl regcomp.sym regnodes.h
+ ! MANIFEST Makefile.SH regcomp.h
+____________________________________________________________________________
+[ 1187] By: gsar on 1998/06/22 01:42:21
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806210145.VAA21629@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] Avoid temporaries on recursion
+ Date: Sat, 20 Jun 1998 21:45:03 -0400 (EDT)
+ Branch: perl
+ ! pp_ctl.c pp_hot.c
+____________________________________________________________________________
+[ 1186] By: gsar on 1998/06/22 01:14:14
+ Log: merge relevant portions from maintbranch change#1155
+ Branch: perl
+ ! lib/Math/BigFloat.pm op.c pod/perlfunc.pod pod/perlop.pod
+ ! pod/perlrun.pod pp_hot.c
+____________________________________________________________________________
+[ 1185] By: gsar on 1998/06/22 00:59:28
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806210827.EAA26322@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] Zero-length matching bug
+ Date: Sun, 21 Jun 1998 04:27:16 -0400 (EDT)
+ Branch: perl
+ ! regexec.c t/op/pat.t
+____________________________________________________________________________
+[ 1184] By: gsar on 1998/06/22 00:57:27
+ Log: fix alignment issues in malloc.c on 64-bit platforms (via private mail)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806170844.EAA24584@monk.mps.ohio-state.edu>
+ Subject: Re: _67 not okay
+ Date: Wed, 17 Jun 1998 04:44:26 -0400 (EDT)
+ Branch: perl
+ ! malloc.c
+____________________________________________________________________________
+[ 1183] By: gsar on 1998/06/22 00:53:37
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806210727.DAA24072@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] Test study/re/
+ Date: Sun, 21 Jun 1998 03:27:13 -0400 (EDT)
+ Branch: perl
+ ! t/op/pat.t
+____________________________________________________________________________
+[ 1182] By: gsar on 1998/06/21 21:25:07
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806210430.AAA21818@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] $^R documented
+ Date: Sun, 21 Jun 1998 00:30:48 -0400 (EDT)
+ Branch: perl
+ ! pod/perlre.pod pod/perlvar.pod
+____________________________________________________________________________
+[ 1181] By: gsar on 1998/06/21 21:23:41
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806210111.VAA17752@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] Re docs
+ Date: Sat, 20 Jun 1998 21:11:37 -0400 (EDT)
+ Branch: perl
+ ! pod/perlop.pod pod/perlre.pod
+____________________________________________________________________________
+[ 1180] By: gsar on 1998/06/21 21:22:16
+ Log: adapted contents of message into comments in malloc.c and INSTALL
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806162240.SAA23597@monk.mps.ohio-state.edu>
+ Subject: [5.004_67] malloc.c -Defines
+ Date: Tue, 16 Jun 1998 18:40:41 -0400 (EDT)
+ Branch: perl
+ ! INSTALL malloc.c
+____________________________________________________________________________
+[ 1179] By: gsar on 1998/06/21 07:26:35
+ Log: applied patch, with edits to the prose
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806201936.PAA17499@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] Error variables compared
+ Date: Sat, 20 Jun 1998 15:36:14 -0400 (EDT)
+ Branch: perl
+ ! pod/perlvar.pod
+____________________________________________________________________________
+[ 1178] By: gsar on 1998/06/21 07:07:16
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806200104.VAA11343@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] print study /re/ broken
+ Date: Fri, 19 Jun 1998 21:04:54 -0400 (EDT)
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 1177] By: gsar on 1998/06/21 07:06:10
+ Log: applied patch, tweaked wording
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806200838.EAA13992@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] Documentation patch for malloc
+ Date: Sat, 20 Jun 1998 04:38:07 -0400 (EDT)
+ Branch: perl
+ ! malloc.c pod/perldiag.pod
+____________________________________________________________________________
+[ 1176] By: gsar on 1998/06/21 07:00:30
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806200829.EAA13974@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] Cosmetic malloc patch
+ Date: Sat, 20 Jun 1998 04:29:00 -0400 (EDT)
+ Branch: perl
+ ! malloc.c
+____________________________________________________________________________
+[ 1175] By: gsar on 1998/06/21 06:58:37
+ Log: Message-Id: <3.0.5.32.19980619160057.032e7480@ous.edu>
+ Date: Fri, 19 Jun 1998 16:00:57 -0700
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Subject: [PATCH 5.004_67] fixup patches for VMS
+ Branch: perl
+ ! ext/SDBM_File/sdbm/Makefile.PL t/lib/filecopy.t t/op/defins.t
+ ! t/op/taint.t vms/test.com vms/vms.c
+____________________________________________________________________________
+[ 1174] By: gsar on 1998/06/21 06:55:18
+ Log: applied VMS patch from Dan Sugalski
+ Date: Fri, 19 Jun 1998 15:36:34 -0700
+ From: SYSTEM@cedar.osshe.edu
+ Message-Id: <980619153634.2063ee12@cedar.osshe.edu>
+ Subject: [PATCH 5.004_67] Enhancements to the VMS configuration procedures
+ Branch: perl
+ ! configure.com lib/ExtUtils/MM_VMS.pm perl.h
+ ! vms/descrip_mms.template vms/gen_shrfls.pl
+ ! vms/subconfigure.com
+____________________________________________________________________________
+[ 1173] By: gsar on 1998/06/21 06:51:38
+ Log: applied patch, modified logic to avoid reentering lexer at compile-time
+ Message-ID: <19980619113104.S9711@asic.sc.ti.com>
+ Date: Fri, 19 Jun 1998 11:31:04 -0500
+ From: Graham Barr <gbarr@ti.com>
+ Subject: Re: [PATCH perl5.004_67] Add Errno in ext/
+ Branch: perl
+ ! Configure MANIFEST Makefile.SH ext/util/make_ext gv.c
+ ! lib/English.pm
+____________________________________________________________________________
+[ 1172] By: gsar on 1998/06/21 06:27:57
+ Log: applied patch, along with many changes:
+ - ipfoo.h headers have been coalesced along with perlfoo.h into
+ iperlsys.h
+ - win32/cp*.h have been combined in perlhost.h
+ - CPerlObj::PerlParse() takes an extra xsinit arg
+ - tweaks to get dl_win32.xs compiling again w/ PERL_OBJECT
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Message-Id: <000001bd9b8c$0417fe90$a32fa8c0@tau.Active>
+ Subject: RE: [PATCH 5.004_67] Fixes for broken MS compiler
+ Date: Fri, 19 Jun 1998 10:59:50 -0700
+ Branch: perl
+ + iperlsys.h win32/perlhost.h
+ - ipdir.h ipenv.h iplio.h ipmem.h ipproc.h ipsock.h ipstdio.h
+ - perldir.h perlenv.h perlio.h perllio.h perlmem.h perlproc.h
+ - perlsock.h
+ ! MANIFEST mg.h op.h perl.h perlio.c proto.h util.c
+ ! win32/Makefile win32/dl_win32.xs win32/makefile.mk
+ ! win32/runperl.c win32/win32.h
+____________________________________________________________________________
+[ 1171] By: gsar on 1998/06/21 00:44:42
+ Log: Date: Fri, 19 Jun 1998 07:55:19 -0600 (MDT)
+ From: Daniel Grisinger <dgris@perrin.dimensional.com>
+ Subject: Re: PATCH _67 (Doc) perlop.pod
+ Message-ID: <Pine.LNX.3.96.980619075203.13326A-100000@perrin.dimensional.com>
+ Branch: perl
+ ! pod/perlop.pod
+____________________________________________________________________________
+[ 1170] By: gsar on 1998/06/21 00:43:06
+ Log: a tweaked version of:
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Subject: [PATCH 5.004_67] Win32 using PerlCRT.dll
+ Date: Wed, 17 Jun 1998 20:25:51 -0700
+ Message-ID: <001b01bd9a68$cb752410$a32fa8c0@tau.Active>
+ Branch: perl
+ ! lib/ExtUtils/MM_Win32.pm win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1169] By: gsar on 1998/06/21 00:10:18
+ Log: added patch, regen headers
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806190227.WAA07371@monk.mps.ohio-state.edu>
+ Subject: Re: Ilya's patches
+ Date: Thu, 18 Jun 1998 22:27:31 -0400 (EDT)
+ Branch: perl
+ ! ObjXSub.h embedvar.h interp.sym intrpvar.h toke.c
+____________________________________________________________________________
+[ 1168] By: gsar on 1998/06/21 00:05:01
+ Log: Date: Thu, 18 Jun 1998 23:37:32 -0700 (PDT)
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Subject: [PATCH] docs creating files via open
+ Message-ID: <Pine.GSO.3.96.980618231856.17544S-100000@user2.teleport.com>
+ Branch: perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 1167] By: gsar on 1998/06/21 00:03:34
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806172151.RAA28441@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_67] Better version of malloc improver
+ Date: Wed, 17 Jun 1998 17:51:54 -0400 (EDT)
+ Branch: perl
+ ! malloc.c
+____________________________________________________________________________
+[ 1166] By: gsar on 1998/06/20 23:59:23
+ Log: enhance perlre.pod to say C<)> can't appear in a (?#...) comment
+ Branch: perl
+ ! pod/perlre.pod
+____________________________________________________________________________
+[ 1165] By: gsar on 1998/06/20 23:47:09
+ Log: added patch, tweaked missed files, excised comment that doesn't really
+ belong in the sources
+ From: joshua.pritikin@db.com
+ Date: Mon, 15 Jun 1998 10:03:37 -0400
+ Message-Id: <H00000e500072c63@MHS>
+ Subject: [PATCH 5.004_57] tied hash slice & do_kv cleanup
+ Branch: perl
+ ! ObjXSub.h av.c doop.c embed.h global.sym objpp.h pp.c proto.h
+ ! t/op/avhv.t
+____________________________________________________________________________
+[ 1164] By: gsar on 1998/06/20 23:29:09
+ Log: add File-Spec-0.6 from CPAN
+ Branch: perl
+ + lib/File/Spec.pm lib/File/Spec/Mac.pm lib/File/Spec/OS2.pm
+ + lib/File/Spec/Unix.pm lib/File/Spec/VMS.pm
+ + lib/File/Spec/Win32.pm t/lib/filespec.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 1163] By: gsar on 1998/06/20 23:15:41
+ Log: tweaks to allow both mingw32{gcc-2.8.1,egcs-1.0.2} build and test
+ Branch: perl
+ ! ext/POSIX/POSIX.xs win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1162] By: gsar on 1998/06/20 21:48:32
+ Log: manual integration of all outstanding ansi branch stuff into mainline
+ Branch: perl
+ ! ext/POSIX/POSIX.xs lib/ExtUtils/MM_Win32.pm t/op/ipcsem.t
+ ! win32/config.gc win32/dl_win32.xs win32/makefile.mk
+ ! win32/win32.h
+____________________________________________________________________________
+[ 1161] By: gsar on 1998/06/20 21:12:01
+ Log: undo goofed change 1157 (backed out the fix instead of keeping it)
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 1160] By: nick on 1998/06/20 21:05:51
+ Log: Patches to build with EGCS-1.0.2 Mingw32 port.
+ Branch: ansiperl
+ ! ext/POSIX/POSIX.xs win32/config.gc win32/config_H.gc
+ ! win32/dl_win32.xs win32/makefile.mk win32/win32.h
+____________________________________________________________________________
+[ 1159] By: gsar on 1998/06/20 02:51:35
+ Log: cleanup installation of utilities on win32
+ Branch: perl
+ ! installperl pod/Makefile win32/Makefile win32/makefile.mk
+ ! win32/pod.mak
+____________________________________________________________________________
+[ 1158] By: gsar on 1998/06/20 02:50:35
+ Log: intuit @INC pathnames from exe location only if dll location
+ is unknown (ensures that multiple executables will coexist)
+ Branch: perl
+ ! win32/win32.c
+____________________________________________________________________________
+[ 1157] By: gsar on 1998/06/20 02:48:34
+ Log: make perldoc ignore null files (it tried to open() them)
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 1156] By: gsar on 1998/06/19 21:18:47
+ Log: fix perldoc to ignore unfound null filenames
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 1155] By: TimBunce on 1998/06/19 18:47:57
+ Log: Assorted patches:
+
+ ------ BUILD PROCESS ------
+
+ Title: "Clarify varargs issues in INSTALL docs"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980603125427.8559C-100000@newton.phys>
+ Files: INSTALL
+
+ ------ CORE LANGUAGE ------
+
+ Title: "Further fixes for updated SysV IPC support"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199805211644.TAA15139@alpha.hut.fi>
+ Files: Configure perl.h doio.c
+
+ Title: "Fixed SEGV caused by bug in pp_hot.c:pp_sassign()"
+ From: Andrew Bettison <andrewb@zip.com.au>
+ Msg-ID: <m0ykMQx-000OQCC@headroom.zip.com.au>
+ Files: pp_hot.c
+
+ Title: "Invalidate method cache on C<local *subname>"
+ From: Chip Salzenberg <chip@perl.org>
+ Msg-ID: <19980604134731.D24343@perlsupport.com>
+ Files: scope.c t/op/method.t
+
+ Title: "fix uninitialized cv variable in op.c"
+ From: joshua.pritikin@db.com
+ Msg-ID: <H00000e50005af05@MHS>
+ Files: op.c
+
+ Title: "fix for undef as last arg to setsockopt"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <19980603112219.B7638@asic.sc.ti.com>
+ Files: pp_sys.c
+
+ Title: "Fix -i when @ARGV is empty"
+ From: Chip Salzenberg <chip@perl.org>, Gurusamy Sarathy
+ <gsar@engin.umich.edu>, Ilya Zakharevich
+ <ilya@math.ohio-state.edu>, Tim.Bunce@ig.co.uk (Tim Bunce)
+ Msg-ID: <19980606184942.A4583@perlsupport.com>,
+ <199806070029.UAA18709@monk.mps.ohio-state.edu>,
+ <199806071817.OAA28141@aatma.engin.umich.edu>,
+ <199806191549.QAA16376@toad.ig.co.uk>
+ Files: pp_hot.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "Discrepancy between perlop.pod and m// operator docs"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980526092614.27437B-100000@user2.teleport.com>
+ Files: pod/perlop.pod
+
+ Title: "Doc addition for perlfunc entry for system()"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>, Mike Fletcher
+ <fletch@phydeaux.org>
+ Msg-ID: <199806011908.PAA31069@dewdrop2.mindspring.com>,
+ <199806012057.QAA26830@monk.mps.ohio-state.edu>
+ Files: pod/perlfunc.pod
+
+ Title: "Clarify effects of using quotes with m operator"
+ From: Daniel Grisinger <dgris@perrin.dimensional.com>
+ Msg-ID: <Pine.LNX.3.96.980617111641.25631B-100000@perrin.dimensional.com>
+ Files: pod/perlop.pod
+
+ Title: "Document -i with STDIN"
+ From: joshua.pritikin@db.com
+ Msg-ID: <H00000e50006a84a@MHS>
+ Files: pod/perlrun.pod
+
+ ------ EXTENSIONS ------
+
+ Title: "Fix Liblist.pm to tolerate backslashen in paths"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199806011954.PAA10900@aatma.engin.umich.edu>
+ Files: lib/ExtUtils/Liblist.pm
+
+ ------ LIBRARY ------
+
+ Title: "Typo fix for Math::BogFloat"
+ From: Mike Stok <mike@stok.co.uk>
+ Msg-ID: <Pine.LNX.3.96.980605101623.982F-100000@stok.co.uk>
+ Files: lib/Math/BigFloat.pm
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Add docs about types of diff to Porting/patching.pod"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199806090105.VAA20005@aatma.engin.umich.edu>
+ Files: Porting/patching.pod
+
+ Title: "Set dont_use_nlink for PowerMAX OS 4.2"
+ From: Tom Horsley <Tom.Horsley@mail.ccur.com>
+ Msg-ID: <199806161354.NAA21316@cleo.ssd.hcsc.com>
+ Files: hints/powerux.sh
+
+ Title: "Assorted improvements to hints/solaris_2.sh"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980527135845.26608K-100000@newton.phys>
+ Files: hints/solaris_2.sh
+ Branch: maint-5.004/perl
+ ! Configure INSTALL Porting/patching.pod doio.c hints/powerux.sh
+ ! hints/solaris_2.sh lib/ExtUtils/Liblist.pm
+ ! lib/Math/BigFloat.pm op.c perl.h pod/perlfunc.pod
+ ! pod/perlop.pod pod/perlrun.pod pp_hot.c pp_sys.c scope.c
+ ! t/op/method.t
+____________________________________________________________________________
+[ 1154] By: gsar on 1998/06/19 17:22:23
+ Log: update repository copy of Asmdata.pm after `perl bytecode.pl`
+ Branch: perl
+ ! ext/B/B/Asmdata.pm regcomp.c
+____________________________________________________________________________
+[ 1153] By: nick on 1998/06/19 17:21:21
+ Log: Use libxxx.a for -lxxx with GCC
+ Branch: ansiperl
+ ! lib/ExtUtils/MM_Win32.pm win32/config.gc win32/config_H.gc
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 1152] By: TimBunce on 1998/06/19 17:08:18
+ Log: Title: Tom's jumbo doc patch
+ From: Tom Christiansen <tchrist@chthon.perl.com>
+ Msg-Id: <199806140419.WAA20549@chthon.perl.com>
+ Files: pod/perl.pod pod/perlbook.pod pod/perldata.pod pod/perldsc.pod
+ pod/perlfaq.pod pod/perlfaq1.pod pod/perlfaq2.pod
+ pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod
+ pod/perlfaq6.pod pod/perlfaq7.pod pod/perlfaq8.pod
+ pod/perlfaq9.pod pod/perlform.pod pod/perlfunc.pod
+ pod/perlipc.pod pod/perllocale.pod pod/perllol.pod
+ pod/perlmod.pod pod/perlmodlib.pod pod/perlobj.pod
+ pod/perlop.pod pod/perlre.pod pod/perlref.pod
+ pod/perlrun.pod pod/perlsec.pod pod/perlsub.pod
+ pod/perlsyn.pod pod/perltie.pod pod/perltoot.pod
+ pod/perlvar.pod
+ Branch: maint-5.004/perl
+ ! pod/perl.pod pod/perlbook.pod pod/perldata.pod pod/perldsc.pod
+ ! pod/perlfaq.pod pod/perlfaq1.pod pod/perlfaq2.pod
+ ! pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod
+ ! pod/perlfaq6.pod pod/perlfaq7.pod pod/perlfaq8.pod
+ ! pod/perlfaq9.pod pod/perlform.pod pod/perlfunc.pod
+ ! pod/perlipc.pod pod/perllocale.pod pod/perllol.pod
+ ! pod/perlmod.pod pod/perlmodlib.pod pod/perlobj.pod
+ ! pod/perlop.pod pod/perlre.pod pod/perlref.pod pod/perlrun.pod
+ ! pod/perlsec.pod pod/perlsub.pod pod/perlsyn.pod
+ ! pod/perltie.pod pod/perltoot.pod pod/perlvar.pod
+____________________________________________________________________________
+[ 1151] By: nick on 1998/06/19 15:38:28
+ Log: Resolve latest
+ Branch: ansiperl
+ !> av.c embed.h embedvar.h ext/Socket/Socket.xs global.sym
+ !> hints/powerux.sh mg.c perl.h pod/perlsub.pod pp_ctl.c proto.h
+ !> sv.c t/TEST
+____________________________________________________________________________
+[ 1150] By: gsar on 1998/06/18 20:43:07
+ Log: Date: Tue, 16 Jun 1998 13:54:17 GMT
+ Message-Id: <199806161354.NAA21316@cleo.ssd.hcsc.com>
+ From: Tom Horsley <Tom.Horsley@mail.ccur.com>
+ Subject: [PATCH] perl5.004 hints file (maint and dev paths)
+ Branch: perl
+ ! hints/powerux.sh
+____________________________________________________________________________
+[ 1149] By: gsar on 1998/06/18 20:41:30
+ Log: hand apply whitespace-mutiliated patch
+ From: joshua.pritikin@db.com
+ Date: Mon, 15 Jun 1998 09:21:36 -0400
+ Message-Id: <H00000e50007289b@MHS>
+ Subject: [PATCH 5.004_67] SvREADONLY for av_clear
+ Branch: perl
+ ! av.c
+____________________________________________________________________________
+[ 1148] By: gsar on 1998/06/18 20:33:59
+ Log: hand apply whitespace-mutiliated and reversed patch
+ Date: Tue, 16 Jun 1998 16:31:40 -0400
+ From: Les Peters <lpeters@aol.net>
+ Message-Id: <199806162031.QAA08202@ds9>
+ Subject: [PATCH 5.004_67] Socket.xs tweak for IRIX 6.3
+ Branch: perl
+ ! ext/Socket/Socket.xs
+____________________________________________________________________________
+[ 1147] By: gsar on 1998/06/18 20:26:59
+ Log: close child pipe in t/TEST, other cosmetic tweaks
+ Branch: perl
+ ! t/TEST
+____________________________________________________________________________
+[ 1146] By: gsar on 1998/06/18 19:37:41
+ Log: back out problematic change#1105, tweak perlsub.pod
+ Branch: perl
+ ! embed.h embedvar.h global.sym mg.c perl.h pod/perlsub.pod
+ ! pp_ctl.c proto.h sv.c
+____________________________________________________________________________
+[ 1145] By: nick on 1998/06/18 19:31:07
+ Log: Integrate and resolve -at mainline to ansiperl prior to Ming32 hacking
+ Branch: ansiperl
+ +> configure.com ext/DB_File/dbinfo
+ +> ext/DynaLoader/DynaLoader_pm.PL t/base/rs.t
+ +> t/op/regexp_noamp.t vms/descrip_mms.template vms/munchconfig.c
+ +> vms/subconfigure.com
+ - ext/DynaLoader/DynaLoader.pm.PL vms/config.vms vms/descrip.mms
+ - vms/fndvers.com
+ !> (integrate 499 files)
+____________________________________________________________________________
+[ 1144] By: gsar on 1998/06/18 16:35:11
+ Log: fix spurious cxstack_max init that trampled memory
+ Branch: perl
+ ! perl.c
+____________________________________________________________________________
+[ 1143] By: gsar on 1998/06/18 16:33:01
+ Log: fix memory leaks and uninitialized memory accesses found by Purify
+ Branch: perl
+ ! doio.c perl.c regexec.c sv.c
+____________________________________________________________________________
+[ 1142] By: gsar on 1998/06/18 16:28:48
+ Log: fix off-by-one that trampled memory in re_croak2()
+ Branch: perl
+ ! regcomp.c
+____________________________________________________________________________
+[ 1141] By: gsar on 1998/06/18 16:26:59
+ Log: fix AutoLoader to do the right thing when there are relative paths
+ in @INC
+ Branch: perl
+ ! lib/AutoLoader.pm
+____________________________________________________________________________
+[ 1140] By: gsar on 1998/06/18 16:22:47
+ Log: fix Makefile.SH typo
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 1139] By: gsar on 1998/06/17 18:06:16
+ Log: 5.004_67 niggles
+ Branch: perl
+ ! Makefile.SH op.c
+
+----------------
+Version 5.004_67
+----------------
+
+____________________________________________________________________________
+[ 1138] By: gsar on 1998/06/15 10:09:27
+ Log: up patchlevel.h to 67, other small tweaks
+ Branch: perl
+ ! patchlevel.h pod/perlhist.pod pod/perltoc.pod vms/perly_c.vms
+ ! win32/Makefile win32/config_H.bc win32/config_H.gc
+ ! win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1137] By: gsar on 1998/06/15 09:08:57
+ Log: tweaks to get PERL_OBJECT building again; passes tests
+ Branch: perl
+ ! ObjXSub.h objpp.h proto.h
+____________________________________________________________________________
+[ 1136] By: gsar on 1998/06/15 08:51:54
+ Log: back out previous change (it breaks PERL_OBJECT)
+ Branch: perl
+ ! ObjXSub.h cc_runtime.h embed.h embedvar.h global.sym
+ ! interp.sym intrpvar.h objpp.h perl.c perl.h pod/perldiag.pod
+ ! pod/perlguts.pod pp_ctl.c proto.h scope.c scope.h util.c
+____________________________________________________________________________
+[ 1135] By: gsar on 1998/06/15 05:32:01
+ Log: added patch, fixed typo, reworked documentation
+ Message-Id: <H00000e500071aa3@MHS>
+ Date: Sun, 14 Jun 1998 14:03:15 EDT
+ From: joshua.pritikin@db.com
+ Subject: [PATCH 5.004_66] JMPENV!
+ Branch: perl
+ ! ObjXSub.h cc_runtime.h embed.h embedvar.h global.sym
+ ! interp.sym intrpvar.h objpp.h perl.c perl.h pod/perldiag.pod
+ ! pod/perlguts.pod pp_ctl.c proto.h scope.c scope.h util.c
+____________________________________________________________________________
+[ 1134] By: gsar on 1998/06/15 04:07:18
+ Log: various win32 odds and ends
+ - added support for waitpid(), open2/open3, and a bugfix for kill()
+ from Ronald Schmidt <RonaldWS@aol.com>
+ - tweak testsuite mods of above
+ - regenerate win32/config_H.?c
+ - change kill() to win32_kill() and export it
+ - coalesce common code in win32.c
+ - add PerlProc_waitpid() and export win32_waitpid()
+ result builds and passes on the three win32 compilers
+ Branch: perl
+ ! ipproc.h lib/IPC/Open3.pm perlproc.h t/lib/open2.t
+ ! t/lib/open3.t util.c win32/config.bc win32/config.gc
+ ! win32/config.vc win32/config_H.bc win32/config_H.gc
+ ! win32/config_H.vc win32/makedef.pl win32/runperl.c
+ ! win32/win32.c win32/win32iop.h
+____________________________________________________________________________
+[ 1133] By: gsar on 1998/06/15 01:39:13
+ Log: newer Getopt/Long.pm from public distribution cited in:
+ Message-Id: <m2n2bgm8en.fsf@phoenix.squirrel.nl>
+ Date: 14 Jun 1998 15:15:28 +0200
+ From: Johan Vromans <jvromans@squirrel.nl>
+ Subject: Getopt::Long version 2.17 released
+ Branch: perl
+ ! lib/Getopt/Long.pm
+____________________________________________________________________________
+[ 1132] By: gsar on 1998/06/15 01:37:12
+ Log: documentation update from tchrist
+ Message-Id: <199806140419.WAA20549@chthon.perl.com>
+ Date: Sat, 13 Jun 1998 22:19:32 MDT
+ From: Tom Christiansen <tchrist@chthon.perl.com>
+ Subject: doc patches
+ Branch: perl
+ ! pod/perl.pod pod/perlbook.pod pod/perldata.pod pod/perldsc.pod
+ ! pod/perlfaq.pod pod/perlfaq1.pod pod/perlfaq2.pod
+ ! pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod
+ ! pod/perlfaq6.pod pod/perlfaq7.pod pod/perlfaq8.pod
+ ! pod/perlfaq9.pod pod/perlform.pod pod/perlfunc.pod
+ ! pod/perlipc.pod pod/perllocale.pod pod/perllol.pod
+ ! pod/perlmod.pod pod/perlmodlib.pod pod/perlobj.pod
+ ! pod/perlop.pod pod/perlre.pod pod/perlref.pod pod/perlrun.pod
+ ! pod/perlsec.pod pod/perlsub.pod pod/perlsyn.pod
+ ! pod/perltie.pod pod/perltoot.pod pod/perlvar.pod
+____________________________________________________________________________
+[ 1131] By: gsar on 1998/06/14 19:33:36
+ Log: Message-ID: <pz3edaedog.fsf@eeyore.ibcinc.com>
+ From: Roderick Schertler <roderick@argon.org>
+ Subject: [PATCH] Re: Exceptions in IPC::Open2
+ Date: 12 Jun 1998 13:24:15 -0400
+ Branch: perl
+ ! lib/IPC/Open3.pm
+____________________________________________________________________________
+[ 1130] By: gsar on 1998/06/14 19:32:25
+ Log: fixup MANIFEST
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 1129] By: gsar on 1998/06/14 18:51:53
+ Log: various win32 fixes
+ - fixes that silence VC noises about dup exports, non-default libs, and
+ unsupported *.def file directives
+ - s/inplace/inplace_label/ malloc.c
+ - update Config{usemymalloc} based on d_mymalloc
+ - export Perl_*Vars
+ - fix makefiles to not build miniperl.exe twice, and to make it properly
+ when defaults are changed
+ Branch: perl
+ ! lib/ExtUtils/MM_Win32.pm lib/ExtUtils/Mksymlists.pm malloc.c
+ ! win32/Makefile win32/config_sh.PL win32/makedef.pl
+ ! win32/makefile.mk win32/perllib.c win32/win32.h
+____________________________________________________________________________
+[ 1128] By: gsar on 1998/06/14 01:38:39
+ Log: remove unused global `scrgv'
+ Branch: perl
+ ! ObjXSub.h cygwin32/cw32imp.h embedvar.h perlvars.h
+____________________________________________________________________________
+[ 1127] By: nick on 1998/06/13 08:39:07
+ Log: Move specialsv_list to embed.sym, regen embed*.h
+ Branch: win32/perl
+ ! embed.h embedvar.h global.sym interp.sym
+____________________________________________________________________________
+[ 1126] By: gsar on 1998/06/12 07:23:06
+ Log: From: jan.dubois@ibm.net (Jan Dubois)
+ Subject: Re: execv in toke.c [PATCH]: win32 wrapper for _66
+ Date: Thu, 11 Jun 1998 21:13:31 +0200
+ Message-ID: <35842ac5.7883075@smtp1.ibm.net>
+ Branch: perl
+ ! win32/makedef.pl win32/win32.c win32/win32iop.h
+____________________________________________________________________________
+[ 1125] By: gsar on 1998/06/12 07:21:29
+ Log: added patch, undo earlier workaround
+ From: jan.dubois@ibm.net (Jan Dubois)
+ Subject: Re: Why does saferealloc(NULL,size) croak? [PATCH] against _66
+ Date: Thu, 11 Jun 1998 20:28:36 +0200
+ Message-ID: <35831f69.4975644@smtp1.ibm.net>
+ Branch: perl
+ ! perl.c util.c
+____________________________________________________________________________
+[ 1124] By: gsar on 1998/06/12 07:16:12
+ Log: hand-applied patch with wrapped lines
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Subject: [PATCH 5.004_66] Win32::Reg... bloat in Win32
+ Date: Thu, 11 Jun 1998 11:06:33 -0700
+ Message-ID: <000101bd9563$aae0c4c0$a32fa8c0@tau.Active>
+ Branch: perl
+ ! win32/win32.c
+____________________________________________________________________________
+[ 1123] By: gsar on 1998/06/12 07:07:25
+ Log: Date: Thu, 11 Jun 1998 12:40:05 -0400 (EDT)
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Subject: [PATCH 5.004_66] Config_66-01-02.diff
+ Message-Id: <Pine.SUN.3.96.980611123857.18493K-100000@newton.phys>
+ Branch: perl
+ ! Configure
+____________________________________________________________________________
+[ 1122] By: gsar on 1998/06/12 07:06:02
+ Log: Message-Id: <Pine.SUN.3.96.980611122249.18493J-100000@newton.phys>
+ Date: Thu, 11 Jun 1998 12:27:15 -0400 (EDT)
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Subject: Re: [PATCH for _66] Makefile.SH problem on dos/djgpp
+ Branch: perl
+ ! pod/checkpods.PL pod/pod2html.PL pod/pod2latex.PL
+ ! pod/pod2man.PL utils/c2ph.PL utils/h2ph.PL utils/h2xs.PL
+ ! utils/perlbug.PL utils/perlcc.PL utils/perldoc.PL
+ ! utils/pl2pm.PL utils/splain.PL x2p/find2perl.PL x2p/s2p.PL
+____________________________________________________________________________
+[ 1121] By: gsar on 1998/06/12 07:01:20
+ Log: a tweaked version of:
+ Message-Id: <l03130300b1a6143078cd@[194.222.64.89]>
+ Date: Fri, 12 Jun 1998 01:26:53 +0200
+ From: Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Subject: Re: Misparsing s///x
+ Branch: perl
+ ! pod/perlre.pod
+____________________________________________________________________________
+[ 1120] By: gsar on 1998/06/12 06:51:08
+ Log: applied patch, with indentation tweaks
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806110803.EAA09149@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_66] Remove REG_ALIGN junk
+ Date: Thu, 11 Jun 1998 04:03:58 -0400 (EDT)
+ Branch: perl
+ ! regcomp.c regcomp.h regexec.c
+____________________________________________________________________________
+[ 1119] By: gsar on 1998/06/11 17:42:07
+ Log: make REG_INFTY default to something saner when sizeof(short) > 2
+ Message-Id: <Pine.SUN.3.96.980611114241.18493H-100000@newton.phys>
+ Date: Thu, 11 Jun 1998 11:50:07 EDT
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Subject: Re: [PATCH for tests] Regexp fails on long string
+ Branch: perl
+ ! regcomp.h
+____________________________________________________________________________
+[ 1118] By: gsar on 1998/06/11 07:09:06
+ Log: regen embedvar.h
+ Branch: perl
+ ! embedvar.h
+____________________________________________________________________________
+[ 1117] By: gsar on 1998/06/11 06:45:52
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806100751.DAA05441@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_66] Bugs with (?{}), $^R and many-to-many subst
+ Date: Wed, 10 Jun 1998 03:51:47 -0400 (EDT)
+ Branch: perl
+ ! interp.sym intrpvar.h op.c op.h perl.c regcomp.c regcomp.h
+ ! regexec.c regexp.h t/op/pat.t t/op/subst.t
+____________________________________________________________________________
+[ 1116] By: gsar on 1998/06/11 06:35:54
+ Log: misc win32 fixes
+ From: "Douglas Lankshear" <dougl@ActiveState.com>
+ Subject: [PATCH 5.004_66]
+ Date: Wed, 10 Jun 1998 11:28:27 -0700
+ Message-ID: <001a01bd949d$8fd18050$a32fa8c0@tau.Active>
+ Branch: perl
+ ! ObjXSub.h perl.c win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1115] By: gsar on 1998/06/11 06:33:21
+ Log: Message-ID: <19980610005325.D162@cdata.tvnet.hu>
+ Date: Wed, 10 Jun 1998 00:53:25 +0200
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Subject: [PATCH for _66] Makefile.SH problem on dos/djgpp
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 1114] By: gsar on 1998/06/11 06:31:34
+ Log: back out change#1111 and add alternative patch:
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806101538.LAA07293@monk.mps.ohio-state.edu>
+ Subject: Re: PATCH for study/foo/
+ Date: Wed, 10 Jun 1998 11:38:58 -0400 (EDT)
+ Branch: perl
+ ! pp.c sv.c
+____________________________________________________________________________
+[ 1113] By: gsar on 1998/06/11 02:59:23
+ Log: fix outdated bytecode.pl
+ Branch: perl
+ ! bytecode.h bytecode.pl byterun.c byterun.h
+____________________________________________________________________________
+[ 1112] By: gsar on 1998/06/10 07:56:06
+ Log: Added patch, regenerated perly.c and perly.c.diff
+ Message-Id: <m0ygCL8-000Eb3C@alias-2.pr.mcs.net>
+ Date: Sun, 31 May 1998 12:56:14 -0500 (CDT)
+ From: Stephen McCamant <alias@mcs.com>
+ Subject: [PATCH] too many RV2GVs in *foo{THING}
+ Branch: perl
+ ! perly.c perly.c.diff perly.y t/op/gv.t
+____________________________________________________________________________
+[ 1111] By: gsar on 1998/06/10 07:40:30
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806100309.XAA04974@monk.mps.ohio-state.edu>
+ Subject: Re: PATCH for study/foo/
+ Date: Tue, 9 Jun 1998 23:09:55 -0400 (EDT)
+ Branch: perl
+ ! pp.c
+____________________________________________________________________________
+[ 1110] By: gsar on 1998/06/10 07:37:04
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806100219.WAA04865@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_66] -DL and PERL_DEBUG_MSTATS unravelled
+ Date: Tue, 9 Jun 1998 22:19:02 -0400 (EDT)
+ Branch: perl
+ ! pod/perldebug.pod
+____________________________________________________________________________
+[ 1109] By: gsar on 1998/06/10 07:35:29
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806100302.XAA04958@monk.mps.ohio-state.edu>
+ Subject: Re: [PATCH 5.004_66] REG_INFTY patch corrected
+ Date: Tue, 9 Jun 1998 23:02:52 -0400 (EDT)
+ Branch: perl
+ ! regcomp.h
+____________________________________________________________________________
+[ 1108] By: gsar on 1998/06/10 07:31:25
+ Log: Added patch, tweaked other places affected by name change
+ Message-ID: <19980610005417.G162@cdata.tvnet.hu>
+ Date: Wed, 10 Jun 1998 00:54:17 +0200
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Subject: [PATCH] file name DynaLoader.pm.PL is 8.3 unfriendly
+ Branch: perl
+ +> ext/DynaLoader/DynaLoader_pm.PL
+ - ext/DynaLoader/DynaLoader.pm.PL
+ ! MANIFEST ext/DynaLoader/Makefile.PL win32/Makefile
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 1107] By: gsar on 1998/06/10 07:24:20
+ Log: Message-ID: <19980610005342.E162@cdata.tvnet.hu>
+ Date: Wed, 10 Jun 1998 00:53:42 +0200
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Subject: [PATCH for _66] new version of README.dos
+ Branch: perl
+ ! README.dos
+____________________________________________________________________________
+[ 1106] By: gsar on 1998/06/10 07:22:31
+ Log: Message-ID: <19980610005404.F162@cdata.tvnet.hu>
+ Date: Wed, 10 Jun 1998 00:54:04 +0200
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Subject: [PATCH for _66] op/taint.t problem on dos/djgpp
+ Branch: perl
+ ! t/op/taint.t
+____________________________________________________________________________
+[ 1105] By: gsar on 1998/06/10 07:21:21
+ Log: Applied patch, followed by tweaks to *.sym and `perl embed.pl`
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806090216.WAA02041@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_66] Resend of RE cache patch (modified)
+ Date: Mon, 8 Jun 1998 22:16:56 -0400 (EDT)
+ Branch: perl
+ ! embed.h embedvar.h global.sym intrpvar.h mg.c perl.h
+ ! perlvars.h pp_ctl.c proto.h sv.c
+____________________________________________________________________________
+[ 1104] By: gsar on 1998/06/10 07:06:01
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806090210.WAA02027@monk.mps.ohio-state.edu>
+ Subject: Lost chunk of RE jumbo patch
+ Date: Mon, 8 Jun 1998 22:10:52 -0400 (EDT)
+ Branch: perl
+ + t/op/regexp_noamp.t
+____________________________________________________________________________
+[ 1103] By: gsar on 1998/06/10 07:04:20
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Message-Id: <199806090207.WAA02015@monk.mps.ohio-state.edu>
+ Subject: [PATCH 5.004_66] Combined OS/2 support
+ Date: Mon, 8 Jun 1998 22:07:48 -0400 (EDT)
+ Branch: perl
+ ! os2/Changes os2/diff.configure os2/os2.c
+____________________________________________________________________________
+[ 1102] By: gsar on 1998/06/10 07:00:08
+ Log: Message-Id: <199803140103.UAA04839@monk.mps.ohio-state.edu>
+ Date: Fri, 13 Mar 1998 20:03:52 EST
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Subject: [PATCH 5.004_62 5_004_04m1] pod2html again
+ Branch: perl
+ ! lib/Pod/Html.pm
+____________________________________________________________________________
+[ 1101] By: gsar on 1998/06/10 06:55:20
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Subject: Re: 5.004_65 uninitialized variable regexec.c (2)
+ Date: Thu, 28 May 1998 01:28:54 -0400 (EDT)
+ Branch: perl
+ ! regexec.c
+____________________________________________________________________________
+[ 1100] By: gsar on 1998/06/10 06:52:50
+ Log: updated MANIFEST for previous change
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 1099] By: gsar on 1998/06/10 06:51:08
+ Log: Mangled patch, needed hand-tweaks, along with binmode for rs.t:
+ Message-Id: <3.0.5.32.19980605110840.009e12b0@ous.edu>
+ Date: Fri, 05 Jun 1998 11:08:40 -0700
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Subject: Re: [PATCH 5.004_66]Add record read capability to <>
+ Branch: perl
+ + t/base/rs.t
+ ! perl.h pod/perlvar.pod sv.c
+____________________________________________________________________________
+[ 1098] By: gsar on 1998/06/10 06:36:59
+ Log: From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Message-Id: <9806042022.AA10418@claudius.bfsec.bt.co.uk>
+ Subject: [PATCH fror 5.004_66] DB_File-1.60
+ Date: Thu, 4 Jun 1998 21:22:35 +0100 (BST)
+ Branch: perl
+ + ext/DB_File/dbinfo
+ ! MANIFEST ext/DB_File/Changes ext/DB_File/DB_File.pm
+ ! ext/DB_File/DB_File.xs ext/DB_File/typemap t/lib/db-btree.t
+ ! t/lib/db-hash.t t/lib/db-recno.t
+____________________________________________________________________________
+[ 1097] By: gsar on 1998/06/10 06:33:16
+ Log: Message-ID: <19980604134731.D24343@perlsupport.com>
+ Date: Thu, 4 Jun 1998 13:47:31 -0400
+ From: Chip Salzenberg <chip@perl.org>
+ Subject: [PATCH] Invalidate method cache on C<local *subname>
+ Branch: perl
+ ! scope.c t/op/method.t
+____________________________________________________________________________
+[ 1096] By: gsar on 1998/06/10 06:30:51
+ Log: From: Norton Allen <allen@huarp.harvard.edu>
+ Message-Id: <199806031908.PAA04183@bottesini.harvard.edu>
+ Subject: [PATCH] _66 MM_Unix.pm for QNX
+ Date: Wed, 3 Jun 1998 15:08:33 -0400 (edt)
+ Branch: perl
+ ! lib/ExtUtils/MM_Unix.pm
+____________________________________________________________________________
+[ 1095] By: gsar on 1998/06/10 06:29:21
+ Log: From: Norton Allen <allen@huarp.harvard.edu>
+ Message-Id: <199806031909.PAA04358@bottesini.harvard.edu>
+ Subject: [PATCH] _66 proto.h
+ Date: Wed, 3 Jun 1998 15:09:14 -0400 (edt)
+ Branch: perl
+ ! proto.h
+____________________________________________________________________________
+[ 1094] By: gsar on 1998/06/10 06:26:39
+ Log: Applied relevant parts of:
+ From: Paul Johnson <pjcj@transeda.com>
+ Date: Wed, 3 Jun 1998 19:07:55 +0100 (BST)
+ Message-Id: <199806031807.TAA04100@west-tip.transeda.com>
+ Subject: [PATCH] Enhancing xsubpp's support for C++
+ Branch: perl
+ ! lib/ExtUtils/xsubpp
+____________________________________________________________________________
+[ 1093] By: gsar on 1998/06/10 06:22:54
+ Log: Message-ID: <19980603112219.B7638@asic.sc.ti.com>
+ Date: Wed, 3 Jun 1998 11:22:19 -0500
+ From: Graham Barr <gbarr@ti.com>
+ Subject: [PATCH perl5.004_04-m4] fix for undef as last arg to setsockopt
+ Branch: perl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 1092] By: gsar on 1998/06/10 06:20:44
+ Log: Message-Id: <199806030919.KAA03527@sale-wts>
+ Date: Wed, 3 Jun 1998 10:20:06 +0100 (BST)
+ From: Alan Burlison <Alan.Burlison@UK.Sun.com>
+ Subject: [PATCH 5.004_66] ExtUtils::Installed.pm and ExtUtils::Packlist.pm
+ Branch: perl
+ ! lib/ExtUtils/Installed.pm lib/ExtUtils/Packlist.pm
+____________________________________________________________________________
+[ 1091] By: gsar on 1998/06/10 06:18:42
+ Log: Message-Id: <3.0.5.32.19980601122229.00a58420@ous.edu>
+ Date: Mon, 01 Jun 1998 12:22:29 -0700
+ From: SYSTEM@cedar.osshe.edu (by way of Dan Sugalski <sugalskd@ous.edu>)
+ Subject: [PATCH 5.004_66] proto.h change to make byterun() visible to VMS
+ Branch: perl
+ ! proto.h
+____________________________________________________________________________
+[ 1090] By: gsar on 1998/06/10 06:14:24
+ Log: A tweaked version of:
+ Date: Mon, 1 Jun 1998 12:05:47 -0700
+ From: SYSTEM@cedar.osshe.edu
+ Message-Id: <980601120547.20617d54@cedar.osshe.edu>
+ Subject: [PATCH 5.004_66] Fix problem with SDBM makefile on VMS
+ Branch: perl
+ ! ext/SDBM_File/sdbm/Makefile.PL
+____________________________________________________________________________
+[ 1089] By: gsar on 1998/06/10 05:58:00
+ Log: Message-Id: <m0yfdd4-000Eb2C@alias-2.pr.mcs.net>
+ Date: Fri, 29 May 1998 23:52:26 -0500 (CDT)
+ From: Stephen McCamant <alias@mcs.com>
+ Subject: [PATCH] Re: Uninitialised error from -M()
+ Branch: perl
+ ! op.c t/op/stat.t
+____________________________________________________________________________
+[ 1088] By: gsar on 1998/06/10 05:55:24
+ Log: Date: Sat, 30 May 1998 08:07:01 -0400
+ From: lvirden@cas.org (Larry Virden)
+ Message-Id: <199805301207.IAA08856@cas.org>
+ Subject: PATCH for pod and warning notice
+ Branch: perl
+ ! pod/perlguts.pod
+____________________________________________________________________________
+[ 1087] By: gsar on 1998/06/10 05:52:05
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Mon, 8 Jun 1998 14:45:36 -0400 (EDT)
+ Message-Id: <Pine.SUN.3.96.980608144437.13972A-100000@newton.phys>
+ Subject: [PATCH 5.004_66] Config_66-01
+ Branch: perl
+ ! Configure MANIFEST Porting/Glossary Porting/config.sh
+ ! Porting/config_H config_h.SH
+____________________________________________________________________________
+[ 1086] By: gsar on 1998/06/10 05:46:38
+ Log: Message-Id: <3.0.5.32.19980608161314.00a0a880@ous.edu>
+ Date: Mon, 08 Jun 1998 16:13:14 -0700
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Subject: [PATCH 5.004_66] Documentation patch for Semaphore.pm
+ Branch: perl
+ ! ext/Thread/Thread/Semaphore.pm
+____________________________________________________________________________
+[ 1085] By: gsar on 1998/06/10 05:44:44
+ Log: Message-Id: <3.0.5.32.19980608161002.00a64a70@ous.edu>
+ Date: Mon, 08 Jun 1998 16:10:02 -0700
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Subject: [PATCH 5.004_66]Doc & feature patch for Thread::Queue
+ Branch: perl
+ - vms/descrip.mms
+ ! ext/Thread/Thread/Queue.pm
+____________________________________________________________________________
+[ 1084] By: gsar on 1998/06/10 05:38:11
+ Log: Message-Id: <3.0.5.32.19980608153828.00a81ea0@ous.edu>
+ Date: Mon, 08 Jun 1998 15:38:28 -0700
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Subject: [PATCH POINTER 5.004_66]A configuration system for VMS perl
+ Branch: perl
+ + configure.com vms/descrip_mms.template vms/munchconfig.c
+ + vms/subconfigure.com
+ - vms/config.vms vms/fndvers.com
+ ! MANIFEST README.vms lib/ExtUtils/MM_VMS.pm
+____________________________________________________________________________
+[ 1083] By: gsar on 1998/06/10 05:07:04
+ Log: xsubpp enhancements ($CPAN/authors/id/ILYAZ/patches/diff_xsubpp_65), a
+ variant of:
+ Message-Id: <199712131231.HAA04125@monk.mps.ohio-state.edu>
+ Date: Sat, 13 Dec 1997 07:31:02 EST
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Subject: 5.004_55: xsubpp: new keywords INTERFACE C_ARGS
+ Branch: perl
+ ! XSUB.h lib/ExtUtils/xsubpp pod/perlxs.pod
+____________________________________________________________________________
+[ 1082] By: gsar on 1998/06/10 04:52:26
+ Log: add newer malloc.c from Ilya Zakharevich <ilya@math.ohio-state.edu>
+ (from $CPAN/authors/id/ILYAZ/patches/diff_malloc_65)
+ Branch: perl
+ ! malloc.c
+____________________________________________________________________________
+[ 1081] By: gsar on 1998/06/10 03:45:10
+ Log: reverse integrate contents of win32 branch into mainline
+ Branch: perl
+ !> (integrate 44 files)
+____________________________________________________________________________
+[ 1080] By: gsar on 1998/06/09 17:37:55
+ Log: `p4 integrate -b ASPerl && p4 resolve -at`
+ Branch: asperl
+ !> (integrate 43 files)
+____________________________________________________________________________
+[ 1079] By: gsar on 1998/06/09 00:59:06
+ Log: add examples of diff(1) usage
+ Branch: win32/perl
+ ! Porting/patching.pod
+____________________________________________________________________________
+[ 1078] By: gsar on 1998/06/09 00:52:23
+ Log: undo change#1077
+ Branch: win32/perl
+ ! sv.c
+____________________________________________________________________________
+[ 1077] By: gsar on 1998/06/06 16:47:32
+ Log: make sv_setsv() treat freed SVs like SVt_NULL
+ Branch: win32/perl
+ ! sv.c
+____________________________________________________________________________
+[ 1076] By: gsar on 1998/06/05 19:03:14
+ Log: delete undiscussed AS changes for PPD (broke .packlist
+ mechanism)
+ Branch: win32/perl
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm
+____________________________________________________________________________
+[ 1075] By: gsar on 1998/06/05 18:18:44
+ Log: add AS patch#26 (rename THIS to PERL_OBJEC_THIS to avoid clash
+ with the xsubpp-generated symbol)
+ Branch: win32/perl
+ ! ObjXSub.h perl.c perl.h pp_ctl.c pp_hot.c toke.c
+ ! win32/dl_win32.xs
+____________________________________________________________________________
+[ 1074] By: gsar on 1998/06/04 22:45:18
+ Log: add AS patch#25 (allow B build with -DPERL_OBJECT)
+ Branch: win32/perl
+ ! ObjXSub.h byterun.h embed.h embedvar.h ext/B/B.xs intrpvar.h
+ ! objpp.h proto.h util.c win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1073] By: nick on 1998/06/04 17:18:14
+ Log: resolve -at win32 branch into ansiperl
+ Branch: ansiperl
+ +> ObjXSub.h XSLock.h ipdir.h ipenv.h iplio.h ipmem.h ipproc.h
+ +> ipsock.h ipstdio.h objpp.h t/lib/h2ph.h t/lib/h2ph.pht
+ +> t/lib/h2ph.t win32/GenCAPI.pl
+ !> (integrate 127 files)
+____________________________________________________________________________
+[ 1072] By: gsar on 1998/06/04 01:49:24
+ Log: document CORE::GLOBAL:: and global overriding, fix up
+ File::DosGlob, testsuited and all
+ Branch: win32/perl
+ ! lib/File/DosGlob.pm pod/perlsub.pod t/lib/dosglob.t
+____________________________________________________________________________
+[ 1071] By: gsar on 1998/06/03 22:12:55
+ Log: add AS patch#24, remove one other instance of error_no
+ that was missed (patch#23 was intentionally skipped)
+ Branch: win32/perl
+ ! embedvar.h globals.c perlvars.h win32/makedef.pl
+ ! win32/runperl.c
+____________________________________________________________________________
+[ 1070] By: gsar on 1998/06/01 19:42:06
+ Log: fix Liblist.pm to tolerate backslashen in paths
+ Branch: win32/perl
+ ! lib/ExtUtils/Liblist.pm
+____________________________________________________________________________
+[ 1069] By: gsar on 1998/06/01 07:43:02
+ Log: @INC construction on win32 cleaned up
+ - perl.dll location based paths should be much more reliable now
+ - registry stuff unchanged
+ - Config.pm now has all the installfoolib entries for MakeMaker et al
+ Branch: win32/perl
+ ! win32/Makefile win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/config_h.PL win32/config_sh.PL win32/makefile.mk
+ ! win32/runperl.c win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 1068] By: gsar on 1998/05/31 21:52:18
+ Log: semctl tweak
+ Message-Id: <199805312127.QAA06750@gbarr.connect.net>
+ Date: Sun, 31 May 1998 16:27:33 CDT
+ From: Graham Barr <gbarr@pobox.com>
+ Subject: Not OK: perl 5.00466 on i586-linux-thread 2.0.31
+ Branch: win32/perl
+ ! doio.c
+____________________________________________________________________________
+[ 1067] By: gsar on 1998/05/31 21:07:44
+ Log: minimal fix to enable compiling with -DMULTIPLICITY
+ (non-threadsafe regcomp.c globals need revisiting)
+ Branch: win32/perl
+ ! ObjXSub.h embedvar.h interp.sym intrpvar.h regcomp.c
+ ! win32/GenCAPI.pl win32/makedef.pl
+____________________________________________________________________________
+[ 1066] By: gsar on 1998/05/30 21:35:37
+ Log: integrate mainline changes (ASPerl branch is identical to
+ win32 branch as of this change)
+ Branch: asperl
+ !> MANIFEST Todo.5.005 embed.h ext/POSIX/POSIX.xs global.sym
+ !> lib/ExtUtils/Mksymlists.pm pod/perldelta.pod pp_sys.c
+ !> t/op/ipcmsg.t t/op/ipcsem.t win32/Makefile win32/config.bc
+ !> win32/config.gc win32/config.vc win32/config_H.bc
+ !> win32/config_H.gc win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1065] By: gsar on 1998/05/30 21:13:06
+ Log: change#1060 was inexplicably missing some of the "ensure
+ AS stuff does no harm" fixes
+ Branch: win32/perl
+ ! embed.h global.sym win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1064] By: gsar on 1998/05/30 21:10:27
+ Log: integrate mainline to pick up trivial changes
+ Branch: win32/perl
+ !> MANIFEST pp_sys.c
+
+----------------
+Version 5.004_66
+----------------
+
+____________________________________________________________________________
+[ 1063] By: mbeattie on 1998/05/29 15:19:55
+ Log: Remove duplicate win32/TEST line from MANIFEST.
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 1062] By: mbeattie on 1998/05/29 15:18:33
+ Log: Add missing ";" to pp_umask (spotted by Jarkko Hietaniemi).
+ Branch: perl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 1061] By: mbeattie on 1998/05/29 12:02:17
+ Log: Integrate from win32 branch into mainline (this now pulls in the
+ asperl stuff).
+ Branch: perl
+ +> ObjXSub.h XSLock.h ipdir.h ipenv.h iplio.h ipmem.h ipproc.h
+ +> ipsock.h ipstdio.h objpp.h t/lib/h2ph.h t/lib/h2ph.pht
+ +> t/lib/h2ph.t win32/GenCAPI.pl
+ !> (integrate 104 files)
+____________________________________________________________________________
+[ 1060] By: gsar on 1998/05/29 11:05:50
+ Log: reverse integrate asperl branch contents (phew!)
+ - various fixups to ensure AS stuff does no harm
+ - adjust win32/makefiles for the new directory layout (new layout
+ looks rather a muddle--needs rework)
+ - verified build & test on NT and Solaris/gcc
+ Branch: win32/perl
+ +> ObjXSub.h XSLock.h ipdir.h ipenv.h iplio.h ipmem.h ipproc.h
+ +> ipsock.h ipstdio.h objpp.h win32/GenCAPI.pl
+ ! ext/POSIX/POSIX.xs lib/ExtUtils/Mksymlists.pm win32/Makefile
+ ! win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/makefile.mk
+ !> (integrate 77 files)
+____________________________________________________________________________
+[ 1059] By: gsar on 1998/05/29 08:33:56
+ Log: asperl branch verified to build w/o PERL_OBJECT on Solaris and NT
+ Branch: asperl
+ ! util.c
+____________________________________________________________________________
+[ 1058] By: gsar on 1998/05/29 08:31:09
+ Log: type xtext for *.t that were missing it
+ Branch: asperl
+ ! t/lib/thread.t t/op/nothread.t
+____________________________________________________________________________
+[ 1057] By: gsar on 1998/05/29 08:28:46
+ Log: stray t/op/ipc*.t fixups
+ Branch: win32/perl
+ ! t/op/ipcmsg.t t/op/ipcsem.t
+____________________________________________________________________________
+[ 1056] By: gsar on 1998/05/29 07:41:49
+ Log: fixups to make it build and pass tests under both compilers
+ Branch: asperl
+ ! ObjXSub.h objpp.h proto.h
+____________________________________________________________________________
+[ 1055] By: gsar on 1998/05/29 07:22:51
+ Log: integrate mainline changes
+ Branch: asperl
+ +> t/lib/h2ph.h t/lib/h2ph.pht t/lib/h2ph.t
+ !> (integrate 69 files)
+ Branch: win32/perl
+ ! Todo.5.005 pod/perldelta.pod
+____________________________________________________________________________
+[ 1054] By: gsar on 1998/05/29 05:04:03
+ Log: add a txt_compare() routine to t/h2ph.t for DOSISH sanity
+ Branch: win32/perl
+ ! t/lib/h2ph.t
+____________________________________________________________________________
+[ 1053] By: gsar on 1998/05/29 05:01:54
+ Log: misc changes
+ - remove code that works around lack of I_STDARG (we're a happy ANSI family)
+ - leave dump_foo() stubs when not -DDEBUGGING for consistent symbol exports
+ Branch: win32/perl
+ ! deb.c dump.c ext/DynaLoader/dlutils.c ext/POSIX/POSIX.xs
+ ! perl.h perlio.c proto.h regcomp.c run.c scope.c sv.c util.c
+ ! x2p/util.c x2p/util.h
+____________________________________________________________________________
+[ 1052] By: gsar on 1998/05/29 02:31:44
+ Log: merge changes#1014,1038 from maintbranch
+ Branch: win32/perl
+ + t/lib/h2ph.h t/lib/h2ph.pht t/lib/h2ph.t
+ ! MANIFEST Makefile.SH doio.c ext/POSIX/POSIX.xs gv.c
+ ! lib/Benchmark.pm lib/ExtUtils/MM_Unix.pm pod/perldebug.pod
+ ! pod/perldiag.pod pod/perlfunc.pod pod/perlop.pod
+ ! pod/perlre.pod pod/perltie.pod pod/perltrap.pod sv.c
+ ! t/io/pipe.t utils/h2ph.PL
+____________________________________________________________________________
+[ 1051] By: gsar on 1998/05/29 01:38:51
+ Log: regenerate win32/config_H.?c
+ Branch: win32/perl
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+____________________________________________________________________________
+[ 1050] By: gsar on 1998/05/29 01:32:41
+ Log: integrate mainline
+ Branch: win32/perl
+ ! win32/Makefile win32/makefile.mk
+ !> Configure INSTALL MANIFEST Porting/Glossary Porting/config.sh
+ !> Porting/config_H Porting/patching.pod config_h.SH doio.c
+ !> ext/POSIX/hints/sunos_4.pl hints/bsdos.sh hints/openbsd.sh
+ !> hints/solaris_2.sh hints/sunos_4_1.sh hints/svr4.sh
+ !> lib/FileHandle.pm patchlevel.h perl.h plan9/config.plan9
+ !> vms/config.vms win32/config.bc win32/config.gc win32/config.vc
+____________________________________________________________________________
+[ 1049] By: gsar on 1998/05/29 00:57:05
+ Log: fix various shenanigans with C<environ>, BC and VC builds now pass
+ all tests
+ Branch: asperl
+ ! globals.c win32/Makefile win32/makefile.mk win32/runperl.c
+ ! win32/win32.h win32/win32iop.h
+____________________________________________________________________________
+[ 1048] By: mbeattie on 1998/05/28 18:07:24
+ Log: Integrated win32 branch into mainline. The changes to t/op/ipc*.t
+ in change 1043 clashed badly with changes made in the win32
+ branch. I did an accept on the win32 branch version for now.
+ Branch: perl
+ +> t/op/die.t
+ !> (integrate 52 files)
+____________________________________________________________________________
+[ 1047] By: mbeattie on 1998/05/28 17:59:18
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Subject: [PATCH 5.004_65] Config_65-02-03.diff: SunOS and Solaris hints
+ Date: Thu, 28 May 1998 13:27:25 -0400 (EDT)
+ Subject: [PATCH 5.004_65] Config_65-03-04.diff: semctl probing
+ Date: Thu, 28 May 1998 13:28:21 -0400 (EDT)
+ Branch: perl
+ ! Configure MANIFEST Porting/Glossary Porting/config.sh
+ ! Porting/config_H config_h.SH doio.c ext/POSIX/hints/sunos_4.pl
+ ! hints/solaris_2.sh hints/sunos_4_1.sh perl.h vms/config.vms
+ ! win32/config.bc win32/config.gc win32/config.vc
+____________________________________________________________________________
+[ 1046] By: mbeattie on 1998/05/28 17:55:48
+ Log: Back out change 1043 since Andy's forthcoming Config patch
+ includes a modified version.
+ Branch: perl
+ ! Configure config_h.SH doio.c perl.h
+____________________________________________________________________________
+[ 1045] By: mbeattie on 1998/05/28 17:52:40
+ Log: Bump patchlevel.h to 66.
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 1044] By: mbeattie on 1998/05/28 17:51:49
+ Log: From: Daniel Grisinger <dgris@perrin.dimensional.com>
+ Subject: [PATCH] _04m2 <DOC> perlfunc.pod (fwd)
+ Date: Fri, 15 May 1998 16:18:26 -0600 (MDT)
+ (above minus the t/system.t test pending checking)
+ Subject: [PATCH] 5.004[04|65] <DOC> FileHandle.pm
+ Date: Wed, 20 May 1998 19:50:50 -0600 (MDT)
+ Subject: [PATCH] _65 and _04 <DOC> patching.pod
+ Date: Thu, 21 May 1998 16:33:03 -0600 (MDT)
+ Branch: perl
+ ! Porting/patching.pod lib/FileHandle.pm pod/perlfunc.pod
+____________________________________________________________________________
+[ 1043] By: mbeattie on 1998/05/28 17:42:21
+ Log: This change really is:
+ Subject: [PATCH] 5.004_65: the infamous semctl()
+ Date: Sun, 24 May 1998 16:13:21 +0300 (EET DST)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+
+ Change 1041 claimed to be this patch but was really:
+ Subject: [PATCH] 5.004_65: t/op/ipc*.t
+ Date: Sat, 16 May 1998 00:52:39 +0300 (EET DST)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! Configure config_h.SH doio.c perl.h
+____________________________________________________________________________
+[ 1042] By: mbeattie on 1998/05/28 17:36:57
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Subject: [PATCH 5.004_65] Config_65-01: lchown() detection.
+ Date: Thu, 28 May 1998 13:25:21 -0400 (EDT)
+ Subject: [PATCH 5.004_65] Config_65-01-02.diff: INSTALL and hints fixes
+ Date: Thu, 28 May 1998 13:26:18 -0400 (EDT)
+ Branch: perl
+ ! Configure INSTALL Porting/Glossary Porting/config.sh
+ ! Porting/config_H config_h.SH doio.c hints/bsdos.sh
+ ! hints/openbsd.sh hints/svr4.sh plan9/config.plan9
+ ! vms/config.vms win32/config.bc win32/config.gc win32/config.vc
+____________________________________________________________________________
+[ 1041] By: mbeattie on 1998/05/28 17:34:26
+ Log: Subject: [PATCH] 5.004_65: the infamous semctl()
+ Date: Sun, 24 May 1998 16:13:21 +0300 (EET DST)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! t/op/ipcmsg.t t/op/ipcsem.t
+____________________________________________________________________________
+[ 1040] By: gsar on 1998/05/28 02:06:47
+ Log: tweaks to enable Borland build
+ Branch: asperl
+ ! win32/makefile.mk win32/win32.c
+____________________________________________________________________________
+[ 1039] By: gsar on 1998/05/27 23:29:22
+ Log: remove C<#define index strchr> from win32.h (unused, and the
+ pollution causes spurious variable name changes in extensions)
+ Branch: win32/perl
+ ! win32/win32.h
+____________________________________________________________________________
+[ 1038] By: TimBunce on 1998/05/27 17:29:15
+ Log: Assorted patches:
+
+ ------ BUILD PROCESS ------
+
+ Title: "add utilities to make test dependencies"
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Msg-ID: <2607.9805211303@tempest.cise.npl.co.uk>
+ Files: Makefile.SH
+
+ Title: "Add 'make nok' complement to 'make ok'"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0ycRDf-0005Wh-00@taurus.cus.cam.ac.uk>
+ Files: Makefile.SH
+
+ Title: "further h2ph patches (add enum support)"
+ From: Billy <wdconsta@cs.adelaide.edu.au>
+ Msg-ID: <Pine.SV4.3.93.980521025541.14577A-100000@xenon.teaching.cs.adelaide.edu.au>
+ Files: MANIFEST t/lib/h2ph.pht t/lib/h2ph.t utils/h2ph.PL
+
+ ------ CORE LANGUAGE ------
+
+ Title: "Fix %! error spelling and add perldiag.pod entry"
+ From: Graham Barr <gbarr@pobox.com>, Tim Bunce
+ Msg-ID: <19980524193101.A573@pobox.com>
+ Files: pod/perldiag.pod gv.c
+
+ Title: "Remove obsolete Win32 uppercasing ENV code"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805201510.LAA28676@aatma.engin.umich.edu>
+ Files: perl.c
+
+ Title: "Don't mung $! on implicit close"
+ From: Chip Salzenberg <chip@perl.org>
+ Msg-ID: <19980525113309.A15845@perlsupport.com>
+ Files: doio.c
+
+ Title: "Maint trial 3 fails on SunOS 4.1.3 with Sun cc"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980527113114.26608D-100000@newton.phys>
+ Files: doio.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "doc patch: you canna return an array ( list context: || vs or)"
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Msg-ID: <oeeemxguf5h.fsf_-_@alpha.hut.fi>
+ Files: pod/perldebug.pod pod/perlfunc.pod pod/perltie.pod pod/perltrap.pod
+
+ Title: "doc patch: @ needs escaping in m/\Q\E/ environment"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0yecim-0002qr-00@taurus.cus.cam.ac.uk>
+ Files: pod/perlop.pod pod/perlre.pod
+
+ Title: "Discrepancy between perlop.pod and m// operator", "Doc fix: Only
+ with /g does list context get matches without parens"
+ From: Greg Chapman <glc@well.com>, Tom Christiansen
+ <tchrist@jhereg.perl.com>, Tom Phoenix
+ <rootbeer@teleport.com>
+ Msg-ID: <000201bd865e$f3bf72e0$1f04400c@assigned.well.com>,
+ <199805231559.JAA21316@jhereg.perl.com>,
+ <Pine.GSO.3.96.980523084947.22348I-100000@user2.teleport.com>
+ Files: pod/perlop.pod
+
+ Title: "Documenting last/next/redo even further"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Tom Phoenix
+ <rootbeer@teleport.com>
+ Msg-ID: <E0yec2h-0000B9-00@taurus.cus.cam.ac.uk>,
+ <Pine.GSO.3.96.980526111426.27437K-100000@user2.teleport.com>
+ Files: pod/perlfunc.pod
+
+ Title: "Documenting last/next/redo within continue block"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980525214558.7133H-100000@user2.teleport.com>
+ Files: pod/perlfunc.pod
+
+ Title: "Document stat return in scalar context"
+ From: Mark-Jason Dominus <mjd@plover.com>
+ Files: pod/perlfunc.pod
+
+ ------ EXTENSIONS ------
+
+ Title: "Better LD_RUN_PATH handling on IRIX"
+ From: "W. Phillip Moore" <wpm@ms.com>
+ Msg-ID: <199805212206.SAA07504@zappa.morgan.com>
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "Dealing with <unistd.h> in POSIX and SunOS"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980527115256.26608F-100000@newton.phys>
+ Files: ext/POSIX/hints/sunos_4.pl hints/sunos_4_1.sh ext/POSIX/POSIX.xs
+
+ ------ LIBRARY ------
+
+ Title: "Fix FileHandle.pm example bug"
+ From: Daniel Grisinger <dgris@perrin.dimensional.com>
+ Msg-ID: <Pine.LNX.3.96.980520194825.10845C-100000@perrin.dimensional.com>
+ Files: lib/FileHandle.pm
+
+ Title: "Add zero/negative $count docs for Benchmark.pm"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0ydEAr-0006NV-00@taurus.cus.cam.ac.uk>
+ Files: lib/Benchmark.pm
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Add test suite recommendations to Porting/patching.pod"
+ From: Daniel Grisinger <dgris@perrin.dimensional.com>
+ Msg-ID: <Pine.LNX.3.96.980521162925.3568B-100000@perrin.dimensional.com>
+ Files: Porting/patching.pod
+
+ ------ TESTS ------
+
+ Title: "Fix looping bug in t/io/pipe.t"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0yc737-0006fB-00@taurus.cus.cam.ac.uk>
+ Files: t/io/pipe.t
+ Branch: maint-5.004/perl
+ ! MANIFEST Makefile.SH Porting/patching.pod doio.c
+ ! ext/POSIX/POSIX.xs ext/POSIX/hints/sunos_4.pl gv.c
+ ! hints/sunos_4_1.sh lib/Benchmark.pm lib/ExtUtils/MM_Unix.pm
+ ! lib/FileHandle.pm perl.c pod/perldebug.pod pod/perldiag.pod
+ ! pod/perlfunc.pod pod/perlop.pod pod/perlre.pod pod/perltie.pod
+ ! pod/perltrap.pod t/io/pipe.t t/lib/h2ph.pht t/lib/h2ph.t
+ ! utils/h2ph.PL
+____________________________________________________________________________
+[ 1037] By: gsar on 1998/05/27 16:18:30
+ Log: add AS patch#22 (fix to make die_exit.t pass)
+ Branch: asperl
+ ! win32/runperl.c
+____________________________________________________________________________
+[ 1036] By: gsar on 1998/05/27 12:50:34
+ Log: add AS patch#21 (misc. fixes)
+ Branch: asperl
+ ! ObjXSub.h lib/ExtUtils/MM_Unix.pm objpp.h perl.h
+ ! win32/GenCAPI.pl win32/Makefile win32/makefile.mk
+ ! win32/win32.c win32/win32sck.c
+____________________________________________________________________________
+[ 1035] By: gsar on 1998/05/26 17:26:17
+ Log: more changes to satisfy non-debug VC build (C-API doesn't
+ build, and the testsuite still won't run)
+ Branch: asperl
+ ! ObjXSub.h deb.c dump.c ext/POSIX/POSIX.xs globals.c proto.h
+ ! regcomp.c run.c scope.c sv.c util.c win32/GenCAPI.pl
+____________________________________________________________________________
+[ 1034] By: gsar on 1998/05/26 17:20:22
+ Log: remove doubled hunk (perforce auto-integrate oddity)
+ Branch: win32/perl
+ ! pod/perldiag.pod
+____________________________________________________________________________
+[ 1033] By: gsar on 1998/05/26 13:39:14
+ Log: tweaks to make it build with the Borland compiler. Won't run
+ testsuite because @INC intuition from location of perlcore.dll seems
+ to be broken. Also, system() and qx// seem broken as well.
+ Branch: asperl
+ ! ObjXSub.h doio.c embedvar.h ext/POSIX/POSIX.xs interp.sym
+ ! intrpvar.h objpp.h perl.c perl.h perlvars.h proto.h regcomp.c
+ ! regexec.c toke.c
+____________________________________________________________________________
+[ 1032] By: gsar on 1998/05/24 23:13:05
+ Log: tweak Benchmark.pm to restore old timestr() behavior--show wall secs
+ Branch: win32/perl
+ ! lib/Benchmark.pm
+____________________________________________________________________________
+[ 1031] By: gsar on 1998/05/24 05:36:44
+ Log: tweak makefiles
+ Branch: asperl
+ ! win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 1030] By: gsar on 1998/05/23 18:58:23
+ Log: merge changes#1016,1018 from maintbranch (1017 is n/a)
+ Branch: win32/perl
+ ! pp_sys.c t/op/die.t
+____________________________________________________________________________
+[ 1029] By: gsar on 1998/05/23 18:55:13
+ Log: merge change#1015 from maintbranch (must revisit 1014 later, is
+ incomplete)
+ Branch: win32/perl
+ ! embed.h global.sym op.c pp.c proto.h sv.c
+____________________________________________________________________________
+[ 1028] By: gsar on 1998/05/23 18:25:14
+ Log: merge change#1013 from maintbranch (1012 is n/a)
+ Branch: win32/perl
+ ! toke.c
+____________________________________________________________________________
+[ 1027] By: gsar on 1998/05/23 18:02:21
+ Log: merge change#1011 from maintbranch
+ Branch: win32/perl
+ ! perl.c pod/perldiag.pod pod/perlfunc.pod pp_ctl.c
+ ! utils/perlbug.PL
+____________________________________________________________________________
+[ 1026] By: nick on 1998/05/23 08:45:04
+ Log: Ids of msgs and sems can be zero, so change || die to a defined() test
+ Branch: win32/perl
+ ! t/op/ipcmsg.t t/op/ipcsem.t
+____________________________________________________________________________
+[ 1025] By: nick on 1998/05/23 08:36:36
+ Log: Resolve win32 into ansiperl
+ Branch: ansiperl
+ +> t/op/die.t
+ !> (integrate 42 files)
+____________________________________________________________________________
+[ 1024] By: gsar on 1998/05/21 21:11:12
+ Log: more mingw32 tweaks
+ Branch: win32/perl
+ ! ext/POSIX/POSIX.xs t/pragma/locale.t
+____________________________________________________________________________
+[ 1023] By: gsar on 1998/05/21 19:15:02
+ Log: fix problematic change#965 from maintbranch
+ Message-Id: <199805162145.RAA02552@monk.mps.ohio-state.edu>
+ Date: Sat, 16 May 1998 17:45:22 EDT
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Subject: Re: Not OK (after all) : perl 5.00404 +MAINT_TRIAL_3 on sun4-solaris 2.5
+ Branch: win32/perl
+ ! gv.c op.c t/comp/proto.t
+____________________________________________________________________________
+[ 1022] By: gsar on 1998/05/21 01:37:04
+ Log: fix POSIX for mingw32
+ Branch: win32/perl
+ ! ext/POSIX/POSIX.xs win32/config.gc win32/config_H.gc
+____________________________________________________________________________
+[ 1021] By: gsar on 1998/05/20 15:02:21
+ Log: remove strupr() from perl.c
+ Branch: win32/perl
+ ! perl.c
+____________________________________________________________________________
+[ 1020] By: TimBunce on 1998/05/19 22:41:40
+ Log: Title: "fix up descrepancy in h2ph test"
+ From: Tim Bunce
+ Files: t/lib/h2ph.pht
+ Branch: maint-5.004/perl
+ ! t/lib/h2ph.pht
+____________________________________________________________________________
+[ 1019] By: TimBunce on 1998/05/19 22:17:15
+ Log: Title: "add a test to check return value from successful s/// (there was none!)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805161759.NAA12995@aatma.engin.umich.edu>
+ Files: t/op/subst.t
+
+ Title: "fix up descrepancy in h2ph test"
+ From: Tim Bunce
+ Files: t/lib/h2ph.t
+ Branch: maint-5.004/perl
+ ! t/lib/h2ph.t t/op/subst.t
+____________________________________________________________________________
+[ 1018] By: TimBunce on 1998/05/19 21:56:32
+ Log: Title: "fix mem leak and core dump from change 1016"
+ From: Tim Bunce
+ Files: pp_sys.c
+ Branch: maint-5.004/perl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 1017] By: TimBunce on 1998/05/19 21:26:03
+ Log: Title: "qsort, Win32 "POSIX" plus other devel changes for patch-compatibility"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: MANIFEST cflags.SH pod/perlembed.pod pod/perlfunc.pod
+ pod/perlguts.pod pod/perlref.pod pod/perlrun.pod
+ pod/perlxstut.pod av.h embed.h hv.h op.h perl.h pp.h
+ proto.h Todo av.c cygwin32/perlgcc cygwin32/perlld deb.c
+ doio.c doop.c ext/ODBM_File/ODBM_File.xs
+ ext/POSIX/Makefile.PL ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs
+ gv.c hv.c interp.sym lib/AutoSplit.pm lib/Cwd.pm
+ lib/FindBin.pm lib/strict.pm lib/ExtUtils/Command.pm
+ lib/ExtUtils/Liblist.pm lib/ExtUtils/MakeMaker.pm
+ lib/ExtUtils/Manifest.pm lib/File/Basename.pm
+ lib/File/Find.pm lib/File/Path.pm lib/Getopt/Long.pm
+ lib/Getopt/Std.pm lib/Net/Ping.pm lib/Pod/Html.pm
+ lib/Pod/Text.pm lib/Term/Cap.pm lib/Test/Harness.pm mg.c
+ op.c perl.c pod/pod2latex.PL pod/pod2man.PL pp.c pp_ctl.c
+ pp_hot.c pp_sys.c scope.c sv.c t/lib/posix.t
+ t/pragma/locale.t utils/perldoc.PL win32/win32.h toke.c
+ universal.c util.c win32/Makefile win32/config_H.bc
+ win32/config_H.vc win32/dl_win32.xs win32/makedef.pl
+ win32/makefile.mk win32/perlglob.c win32/runperl.c
+ win32/win32.c win32/win32sck.c x2p/s2p.PL
+ Branch: maint-5.004/perl
+ ! MANIFEST Todo av.c av.h cflags.SH cygwin32/perlgcc
+ ! cygwin32/perlld deb.c doio.c doop.c embed.h
+ ! ext/ODBM_File/ODBM_File.xs ext/POSIX/Makefile.PL
+ ! ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs gv.c hv.c hv.h
+ ! interp.sym lib/AutoSplit.pm lib/Cwd.pm lib/ExtUtils/Command.pm
+ ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MakeMaker.pm
+ ! lib/ExtUtils/Manifest.pm lib/File/Basename.pm lib/File/Find.pm
+ ! lib/File/Path.pm lib/FindBin.pm lib/Getopt/Long.pm
+ ! lib/Getopt/Std.pm lib/Net/Ping.pm lib/Pod/Html.pm
+ ! lib/Pod/Text.pm lib/Term/Cap.pm lib/Test/Harness.pm
+ ! lib/strict.pm mg.c op.c op.h perl.c perl.h pod/perlembed.pod
+ ! pod/perlfunc.pod pod/perlguts.pod pod/perlref.pod
+ ! pod/perlrun.pod pod/perlxstut.pod pod/pod2latex.PL
+ ! pod/pod2man.PL pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c proto.h
+ ! scope.c sv.c t/lib/posix.t t/pragma/locale.t toke.c
+ ! universal.c util.c utils/perldoc.PL win32/Makefile
+ ! win32/config_H.bc win32/config_H.vc win32/dl_win32.xs
+ ! win32/makedef.pl win32/makefile.mk win32/perlglob.c
+ ! win32/runperl.c win32/win32.c win32/win32.h win32/win32sck.c
+ ! x2p/s2p.PL
+____________________________________________________________________________
+[ 1016] By: TimBunce on 1998/05/19 20:37:42
+ Log: Title: "eval { die $obj }; die; calls $obj->PROPAGATE"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <3561D147.7F3E0C88@ti.com>
+ Files: pp_sys.c t/op/die.t
+ Branch: maint-5.004/perl
+ ! pp_sys.c t/op/die.t
+____________________________________________________________________________
+[ 1015] By: TimBunce on 1998/05/19 20:07:01
+ Log: Title: "loosen const sub re-defined warnings"
+ From: Doug MacEachern <dougm@pobox.com>
+ Msg-ID: <355F713B.6A4C0F04@pobox.com>
+ Files: proto.h global.sym op.c pp.c sv.c
+ Branch: maint-5.004/perl
+ ! global.sym op.c pp.c proto.h sv.c
+____________________________________________________________________________
+[ 1014] By: TimBunce on 1998/05/19 19:48:18
+ Log: Title: "s/FORMLINE/FORMAT/ in sv.c"
+ From: Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Msg-ID: <l03130303b1837a243670@[194.222.64.89]>
+ Files: sv.c
+
+ Title: "Further h2ph patches (including a test suite)"
+ From: Billy <wdconsta@cs.adelaide.edu.au>
+ Msg-ID: <Pine.SV4.3.93.980516234652.2100A-100000@xenon.teaching.cs.adelaide.edu.au>
+ Files: MANIFEST t/lib/h2ph.h t/lib/h2ph.pht t/lib/h2ph.t utils/h2ph.PL
+ Branch: maint-5.004/perl
+ + t/lib/h2ph.h t/lib/h2ph.pht t/lib/h2ph.t
+ ! MANIFEST sv.c utils/h2ph.PL
+____________________________________________________________________________
+[ 1013] By: TimBunce on 1998/05/19 19:14:13
+ Log: Title: "Remove change 673 (Allow empty BLOCK in code)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Ilya Zakharevich
+ <ilya@math.ohio-state.edu>
+ Msg-ID: <199805151857.OAA29586@monk.mps.ohio-state.edu>,
+ <199805151931.PAA23086@aatma.engin.umich.edu>,
+ <19980129002112Z13378-6931+226@scapa.cs.ualberta.ca>
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 1012] By: TimBunce on 1998/05/19 19:03:32
+ Log: Title: "Further SysV sem/msg fixes and removal of non-portable tests"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>, Jarkko Hietaniemi
+ <jhi@iki.fi>
+ Msg-ID: <199805182028.XAA15717@alpha.hut.fi>,
+ <Pine.SUN.3.96.980518133606.17488A-100000@newton.phys>
+ Files: MANIFEST Configure config_h.SH perl.h doio.c t/op/ipcmsg.t
+ t/op/ipcsem.t
+ Branch: maint-5.004/perl
+ ! Configure MANIFEST config_h.SH doio.c perl.h t/op/ipcmsg.t
+ ! t/op/ipcsem.t
+____________________________________________________________________________
+[ 1011] By: TimBunce on 1998/05/19 17:55:38
+ Log: Title: "interp.sym is missing C<e_script> after -e fix"
+ From: jan.dubois@ibm.net (Jan Dubois)
+ Msg-ID: <355d460d.7621669@smtp1.ibm.net>
+ Files: embed.h interp.sym
+
+ Title: "Undo changed error message which breaks Tk"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805161557.LAA08106@aatma.engin.umich.edu>
+ Files: pp_ctl.c
+
+ Title: "Minor fixups to new -e script code"
+ From: Tim Bunce
+ Files: perl.c
+
+ Title: "Remove old diags not relevant after -e fix"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>, Gurusamy Sarathy
+ <gsar@engin.umich.edu>, Tim.Bunce@ig.co.uk (Tim Bunce)
+ Msg-ID: <199805172143.RAA07896@aatma.engin.umich.edu>,
+ <199805181335.OAA07008@toad.ig.co.uk>,
+ <Pine.SUN.3.96.980517104819.16183B-100000@newton.phys>
+ Files: pod/perldiag.pod
+
+ Title: "more examples for vec()"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980518093728.28732P-100000@user2.teleport.com>
+ Files: pod/perlfunc.pod
+
+ Title: ""make ok" (perlbug -ok) should not be interactive"
+ From: Hugo van der Sanden <hv@crypt0.demon.co.uk>, Jarkko Hietaniemi
+ <jhi@iki.fi>
+ Msg-ID: <199805160942.MAA20171@alpha.hut.fi>,
+ <l03130300b1834f9732a0@[194.222.64.89]>
+ Files: utils/perlbug.PL
+ Branch: maint-5.004/perl
+ ! embed.h interp.sym perl.c pod/perldiag.pod pod/perlfunc.pod
+ ! pp_ctl.c utils/perlbug.PL
+____________________________________________________________________________
+[ 1010] By: gsar on 1998/05/18 09:40:58
+ Log: integrate mainline changes (untested)
+ Branch: asperl
+ +> Porting/Contract Porting/patching.pod README.beos beos/nm.c
+ +> ext/DynaLoader/DynaLoader.pm.PL ext/POSIX/hints/bsdos.pl
+ +> ext/POSIX/hints/freebsd.pl ext/POSIX/hints/netbsd.pl
+ +> ext/POSIX/hints/openbsd.pl hints/beos.sh hints/openbsd.sh
+ +> pod/perldelta4.pod t/op/defins.t t/op/die.t t/op/die_exit.t
+ +> t/op/ipcmsg.t t/op/ipcsem.t t/op/pos.t utils/perlcc.PL
+ - ext/DynaLoader/DynaLoader.pm
+ ! win32/win32.c
+ !> (integrate 234 files)
+____________________________________________________________________________
+[ 1009] By: gsar on 1998/05/18 07:51:19
+ Log: more whitespace tweaks from maintbranch
+ Branch: win32/perl
+ ! av.c perl.c pp_ctl.c pp_sys.c toke.c
+____________________________________________________________________________
+[ 1008] By: gsar on 1998/05/17 22:37:20
+ Log: sundry whitespace cleanups from maintbranch
+ Branch: win32/perl
+ ! Porting/Contract XSUB.h av.c gv.c mg.c perl.c
+____________________________________________________________________________
+[ 1007] By: gsar on 1998/05/16 21:59:46
+ Log: integrate mainline
+ Branch: win32/perl
+ !> INSTALL doio.c lib/strict.pm perl.c perl.h pod/perldebug.pod
+ !> t/op/ipcmsg.t t/op/ipcsem.t
+____________________________________________________________________________
+[ 1006] By: gsar on 1998/05/16 21:54:23
+ Log: merge changes#996,998,999 from maintbranch
+ Branch: win32/perl
+ ! Changes5.004 Porting/makerel t/base/lex.t toke.c
+____________________________________________________________________________
+[ 1005] By: gsar on 1998/05/16 21:49:47
+ Log: merge change#995 from maintbranch, tweak interp.sym and
+ run embed.pl
+ Branch: win32/perl
+ ! embedvar.h interp.sym intrpvar.h perl.c
+____________________________________________________________________________
+[ 1004] By: gsar on 1998/05/16 21:27:18
+ Log: merge changes#989,990,992 from maintbranch
+ Branch: win32/perl
+ + t/op/die.t
+ ! MANIFEST installperl pod/perldiag.pod pp_ctl.c t/op/ipcmsg.t
+____________________________________________________________________________
+[ 1003] By: gsar on 1998/05/16 21:16:47
+ Log: sync config*.gc with others, and verify that nothing from
+ change#986 needs to be merged
+ Branch: win32/perl
+ ! win32/config.gc win32/config_H.gc
+____________________________________________________________________________
+[ 1002] By: gsar on 1998/05/16 21:04:04
+ Log: merge change#985 from maintbranch
+ Branch: win32/perl
+ ! lib/AutoSplit.pm lib/ExtUtils/Manifest.pm pp_ctl.c pp_sys.c
+ ! util.c
+____________________________________________________________________________
+[ 1001] By: gsar on 1998/05/16 17:53:16
+ Log: add a test to check return value from successful s/// (there was none!)
+ Branch: win32/perl
+ ! t/op/subst.t
+____________________________________________________________________________
+[ 1000] By: gsar on 1998/05/16 17:42:34
+ Log: fix misplaced SPAGAIN that caused successful s/// to fail to
+ return a value on the stack
+ Branch: win32/perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 999] By: TimBunce on 1998/05/15 23:04:30
+ Log: Title: "Update Porting/makerel script for perforce dir structure"
+ From: Tim Bunce
+ Files: Porting/makerel
+ Branch: maint-5.004/perl
+ ! Porting/makerel
+____________________________________________________________________________
+[ 998] By: TimBunce on 1998/05/15 22:49:55
+ Log: Title: "Updated Changes file for trial 3"
+ From: Tim Bunce
+ Files: Changes
+ Branch: maint-5.004/perl
+ ! Changes
+____________________________________________________________________________
+[ 997] By: gsar on 1998/05/15 22:21:41
+ Log: merge changes#982,984 from maintbranch
+ Branch: win32/perl
+ ! gv.c lib/English.pm perl.c pod/perlfunc.pod t/io/pipe.t
+ ! t/op/exec.t t/op/ipcsem.t util.c utils/h2ph.PL utils/h2xs.PL
+____________________________________________________________________________
+[ 996] By: TimBunce on 1998/05/15 22:19:32
+ Log: Title: "Negative array subscript unrecognized in regex"
+ From: Mark-Jason Dominus <mjd@plover.com>,
+ h.sanden@elsevier.nl (Hugo van der Sanden)
+ Msg-ID: <19980425040819.13828.qmail@plover.com>,
+ <199805151514.RAA04121@dorlas.elsevier.nl>
+ Files: t/base/lex.t toke.c
+
+ Title: "Remove e_fp from toke.c after change 955"
+ From: Tim Bunce
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! t/base/lex.t toke.c
+____________________________________________________________________________
+[ 995] By: TimBunce on 1998/05/15 22:08:32
+ Log: Title: "Fix -e security hole (no longer uses temp file)"
+ From: Tim Bunce
+ Files: embed.h perl.h perl.c
+ Branch: maint-5.004/perl
+ ! embed.h perl.c perl.h
+____________________________________________________________________________
+[ 994] By: gsar on 1998/05/15 22:08:17
+ Log: merge change#981 from maintbranch, add XXX comment about
+ supporting %! for usethreads case
+ Branch: win32/perl
+ ! gv.c op.c
+____________________________________________________________________________
+[ 992] By: TimBunce on 1998/05/15 22:01:32
+ Log: Title: "install non-backwards compatible .pm files into archlib"
+ From: Tim Bunce
+ Files: installperl
+
+ Title: "revert "Can't locate" message to original for maintenance"
+ From: Tim Bunce
+ Msg-ID: <199804240047.SAA24155@den-mdev1.co.csgsystems.com>
+ Files: pod/perldiag.pod pp_ctl.c
+ Branch: maint-5.004/perl
+ ! installperl pod/perldiag.pod pp_ctl.c
+____________________________________________________________________________
+[ 991] By: gsar on 1998/05/15 21:35:00
+ Log: reverse integrate ansiperl (all except the
+ C<attrs qw(package locked)> stuff, and the duplicate hunks)
+ i.e. prototype fixes, perldoc.PL enhancements, and s/comment/comment_t/g
+ Branch: win32/perl
+ !> bytecode.h byterun.c cv.h ext/attrs/attrs.pm
+ !> ext/attrs/attrs.xs pod/perlop.pod pp_hot.c sv.c toke.c
+ !> utils/perldoc.PL
+____________________________________________________________________________
+[ 990] By: TimBunce on 1998/05/15 16:54:18
+ Log: Title: "Add tests for die $ref"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <355C6297.121B576B@ti.com>
+ Files: MANIFEST t/op/die.t
+ Branch: maint-5.004/perl
+ + t/op/die.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 989] By: TimBunce on 1998/05/15 16:38:19
+ Log: Title: "Fix t/op/ipcmsg.t for Digital UNIX"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199805151337.QAA01174@alpha.hut.fi>
+ Files: t/op/ipcmsg.t
+ Branch: maint-5.004/perl
+ ! t/op/ipcmsg.t
+____________________________________________________________________________
+[ 988] By: mbeattie on 1998/05/15 16:28:08
+ Log: Patch from Sarathy to fix up win32 integration. Patch from Jarkko
+ (manually applied and tweaked) to fix up SysV IPC semaphores for
+ Solaris and Linux (pre-glibc and glibc). Fix up t/op/ipcmsg.t and
+ t/op/ipcsem.t for platforms which wanted to skip test. Completely
+ disable ipcsem.t since it doesn't seem to work properly even when
+ not skipped. This is _65.
+ Branch: perl
+ ! INSTALL doio.c lib/strict.pm perl.c perl.h pod/perldebug.pod
+ ! t/op/ipcmsg.t t/op/ipcsem.t
+____________________________________________________________________________
+[ 987] By: nick on 1998/05/15 16:03:35
+ Log: Integrate win32
+ Branch: ansiperl
+ +> Porting/Contract Porting/patching.pod README.beos beos/nm.c
+ +> ext/DynaLoader/DynaLoader.pm.PL ext/POSIX/hints/bsdos.pl
+ +> ext/POSIX/hints/freebsd.pl ext/POSIX/hints/netbsd.pl
+ +> ext/POSIX/hints/openbsd.pl hints/beos.sh hints/openbsd.sh
+ +> pod/perldelta4.pod t/op/die_exit.t t/op/ipcmsg.t t/op/ipcsem.t
+ +> t/op/pos.t utils/perlcc.PL
+ - ext/DynaLoader/DynaLoader.pm
+ !> (integrate 208 files)
+____________________________________________________________________________
+[ 986] By: TimBunce on 1998/05/15 15:28:45
+ Log: Title: "Patches for BeOS port of Perl, courtesy of Tom Spindler"
+ From: Jarkko Hietaniemi <jhi@iki.fi>, Tom Spindler
+ Msg-ID: <199805042312.CAA09025@alpha.hut.fi>
+ Files: MANIFEST Configure config_h.SH hints/beos.sh pod/perlfunc.pod
+ Porting/Glossary README.beos beos/nm.c lib/Term/ReadLine.pm
+ plan9/config.plan9 pp_sys.c t/io/pipe.t vms/config.vms
+ win32/config.bc win32/config.vc win32/config_H.bc
+ win32/config_H.vc
+ Branch: maint-5.004/perl
+ + README.beos beos/nm.c hints/beos.sh
+ ! Configure MANIFEST Porting/Glossary config_h.SH
+ ! lib/Term/ReadLine.pm plan9/config.plan9 pod/perlfunc.pod
+ ! pp_sys.c t/io/pipe.t vms/config.vms win32/config.bc
+ ! win32/config.vc win32/config_H.bc win32/config_H.vc
+____________________________________________________________________________
+[ 985] By: TimBunce on 1998/05/15 15:02:43
+ Log: Title: "allow die $ref"
+ From: Graham Barr <gbarr@ti.com>, Tim.Bunce@ig.co.uk (Tim Bunce)
+ Msg-ID: <199805151351.OAA01985@toad.ig.co.uk>, <355C3E67.AF25B9F7@ti.com>
+ Files: pp_ctl.c pp_sys.c util.c
+
+ Title: "ExtUtils::Manifest could truncate files during "make dist""
+ From: "James E Jurach Jr." <muaddib@arrakis.int.ein.cz>,
+ koenig@kulturbox.de (Andreas J. Koenig)
+ Msg-ID: <199805111048.MAA02573@arrakis.int.ein.cz>,
+ <sfc90o8bgie.fsf@dubravka.in-berlin.de>
+ Files: lib/ExtUtils/Manifest.pm
+
+ Title: "Autosplit doesn't like upper case letters in sub names on VMS"
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Msg-ID: <3.0.5.32.19980330152332.009cb130@osshe.edu>
+ Files: lib/AutoSplit.pm
+
+ Title: "AutoSplit/AutoLoaded subs: give useful line numbers in warnings etc"
+ From: "Jesse N. Glick" <jglick@sig.bsh.com>, koenig@anna.mind.de (Andreas
+ J. Koenig), larry@wall.org (Larry Wall)
+ Msg-ID: <199709292015.NAA09627@wall.org>, <342FCDDF.23534195@sig.bsh.com>,
+ <sfc202c9jsb.fsf@anna.in-berlin.de>,
+ <sfc3efg5rhg.fsf@dubravka.in-berlin.de>
+ Files: lib/AutoSplit.pm
+ Branch: maint-5.004/perl
+ ! lib/AutoSplit.pm lib/ExtUtils/Manifest.pm pp_ctl.c pp_sys.c
+ ! util.c
+____________________________________________________________________________
+[ 984] By: TimBunce on 1998/05/15 14:18:52
+ Log: ------ CORE LANGUAGE ------
+
+ Title: "Fix close pipe returning status from wrong child"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, kstar@chapin.edu@ig.co.uk ()
+ Msg-ID: <199805142313.TAA02684@chapin.edu>,
+ <E0yZ8ah-0005d8-00@taurus.cus.cam.ac.uk>
+ Files: t/io/pipe.t util.c
+
+ Title: "Avoid English.pm triggering load of Errno.pm"
+ From: Tim Bunce
+ Files: gv.c lib/English.pm
+
+ ------ DOCUMENTATION ------
+
+ Title: "Document child exit cause a parent sleep to end early"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0yZwMK-0000D9-00@taurus.cus.cam.ac.uk>
+ Files: pod/perlfunc.pod
+
+ ------ EXTENSIONS ------
+
+ Title: "BSD Platforms need STRUCT_TM_HASZONE for POSIX"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980512095524.8158C-100000@newton.phys>
+ Files: MANIFEST ext/POSIX/hints/bsdos.pl ext/POSIX/hints/freebsd.pl
+ ext/POSIX/hints/netbsd.pl ext/POSIX/hints/openbsd.pl
+
+ Title: "MM_VMS.pm fixes for building external library"
+ From: Dan Sugalski <sugalskd@ous.edu>
+ Msg-ID: <3.0.5.32.19980511160542.009dd480@ous.edu>
+ Files: lib/ExtUtils/MM_VMS.pm
+
+ Title: "Appease picky DEC compiler in POSIX.xs"
+ From: Dan Sugalski <sugalskd@ous.edu>
+ Msg-ID: <3.0.5.32.19980511161434.009f8bb0@ous.edu>
+ Files: ext/POSIX/POSIX.xs
+
+ ------ TESTS ------
+
+ Title: "Fix constant detection in t/op/ipcsem.t for Digit UNIX"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199805121212.PAA15351@alpha.hut.fi>
+ Files: t/op/ipcsem.t
+
+ Title: "Fix doc bug for system() return value"
+ From: Daniel Grisinger <dgris@perrin.dimensional.com>
+ Msg-ID: <Pine.LNX.3.96.980514165608.4062A-100000@perrin.dimensional.com>
+ Files: pod/perlfunc.pod t/op/exec.t
+
+ ------ UTILITIES ------
+
+ Title: "Avoid possible constant autoload loop"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Graham Barr <gbarr@ti.com>, Ilya
+ Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199805141910.PAA26994@monk.mps.ohio-state.edu>,
+ <355B475A.C5AD4B90@ti.com>,
+ <E0ya11X-0000hm-00@taurus.cus.cam.ac.uk>
+ Files: utils/h2xs.PL
+
+ Title: "Further improvements to h2ph.PL"
+ From: kstar@chapin.edu
+ Msg-ID: <199805130241.WAA25459@chapin.edu>
+ Files: utils/h2ph.PL
+ Branch: maint-5.004/perl
+ + ext/POSIX/hints/bsdos.pl ext/POSIX/hints/freebsd.pl
+ + ext/POSIX/hints/netbsd.pl ext/POSIX/hints/openbsd.pl
+ ! MANIFEST ext/POSIX/POSIX.xs gv.c lib/English.pm
+ ! lib/ExtUtils/MM_VMS.pm pod/perlfunc.pod t/io/pipe.t
+ ! t/op/exec.t t/op/ipcsem.t util.c utils/h2ph.PL utils/h2xs.PL
+
+----------------
+Version 5.004_64
+----------------
+
+____________________________________________________________________________
+[ 983] By: mbeattie on 1998/05/15 14:04:17
+ Log: Integrate win32 branch into mainline.
+ Branch: perl
+ +> Porting/patching.pod t/op/defins.t
+ !> (integrate 107 files)
+____________________________________________________________________________
+[ 982] By: TimBunce on 1998/05/15 12:33:26
+ Log: Title: "comment init_postdump_symbols issues"
+ From: Tim Bunce
+ Files: perl.c
+
+ Title: "Improve sort docs re SUBNAME"
+ From: circle@azstarnet.com
+ Msg-ID: <199804281828.LAA22737@andromeda.azstarnet.com>
+ Files: pod/perlfunc.pod
+ Branch: maint-5.004/perl
+ ! perl.c pod/perlfunc.pod
+____________________________________________________________________________
+[ 981] By: TimBunce on 1998/05/15 11:47:28
+ Log: Title: "Add hook to tie %! to external Errno.pm module (not included)"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <355080CD.1111BC81@ti.com>
+ Files: gv.c
+ Branch: maint-5.004/perl
+ ! gv.c
+____________________________________________________________________________
+[ 980] By: gsar on 1998/05/15 06:16:13
+ Log: add doc for C<+{}> vs. C<{;}> disambiguation
+ Branch: win32/perl
+ ! pod/perlref.pod
+____________________________________________________________________________
+[ 979] By: gsar on 1998/05/15 04:59:47
+ Log: tweaks to win32 makefiles. This version builds and passes all
+ tests on Solaris/gcc, win32/[bv]c. Looks all set to go.
+ Branch: win32/perl
+ ! win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 978] By: gsar on 1998/05/15 02:41:58
+ Log: merge changes#922,944,949,965,970 from maintbranch
+ Branch: win32/perl
+ + Porting/patching.pod t/op/defins.t
+ ! MANIFEST Porting/makerel ext/POSIX/POSIX.pod gv.c gv.h hv.c
+ ! lib/File/Find.pm op.c pod/Makefile pod/perlfunc.pod
+ ! pod/perlguts.pod pod/perlop.pod pod/pod2man.PL
+ ! t/lib/filefind.t t/op/die_exit.t t/op/ipcmsg.t t/op/ipcsem.t
+ ! utils/perlbug.PL
+____________________________________________________________________________
+[ 977] By: gsar on 1998/05/15 02:15:25
+ Log: merge changes#906,907,909,910 from maintbranch
+ Branch: win32/perl
+ ! MANIFEST doio.c doop.c embed.h embedvar.h global.sym
+ ! keywords.h lib/Carp.pm lib/File/Basename.pm mg.c opcode.h
+ ! perl.c perl.h pod/perldiag.pod pp.c pp_hot.c proto.h sv.c
+ ! util.c
+____________________________________________________________________________
+[ 976] By: gsar on 1998/05/15 01:34:53
+ Log: merge change#905 from maintbranch, minor fixes to get
+ clean build+test on Solaris
+ Branch: win32/perl
+ ! doop.c dump.c embed.h embedvar.h lib/strict.pm mg.c op.h
+ ! opcode.h pod/perlop.pod pod/perlre.pod pp_ctl.c pp_hot.c
+ ! regcomp.c sv.c t/op/taint.t toke.c
+____________________________________________________________________________
+[ 975] By: gsar on 1998/05/14 23:34:26
+ Log: merge change#904 from maintbranch
+ Branch: win32/perl
+ ! doop.c ext/DynaLoader/dl_aix.xs ext/IO/lib/IO/Socket.pm
+ ! ext/NDBM_File/NDBM_File.pm lib/strict.pm lib/subs.pm
+ ! lib/vars.pm op.c perl.c pod/perldiag.pod pod/perlembed.pod
+ ! pod/perlfunc.pod pod/perlsec.pod pp_ctl.c sv.c utils/h2ph.PL
+ ! vms/descrip.mms
+____________________________________________________________________________
+[ 974] By: gsar on 1998/05/14 23:11:05
+ Log: merge change#897 from maintbranch
+ Branch: win32/perl
+ ! Porting/Contract Todo doio.c emacs/ptags embed.h ext/IO/IO.pm
+ ! ext/Opcode/Opcode.pm lib/Carp.pm lib/ExtUtils/MM_Unix.pm
+ ! lib/Pod/Html.pm lib/Term/ReadLine.pm lib/chat2.pl opcode.h
+ ! opcode.pl perl.c pod/perlapio.pod pod/perlcall.pod
+ ! pod/perldebug.pod pod/perldelta.pod pod/perldelta4.pod
+ ! pod/perldiag.pod pod/perlembed.pod pod/perlfaq2.pod
+ ! pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod
+ ! pod/perlfaq7.pod pod/perlfaq8.pod pod/perlform.pod
+ ! pod/perlfunc.pod pod/perlguts.pod pod/perlhist.pod
+ ! pod/perlipc.pod pod/perllocale.pod pod/perlmodlib.pod
+ ! pod/perlop.pod pod/perlre.pod pod/perlref.pod pod/perlrun.pod
+ ! pod/perlstyle.pod pod/perlsub.pod pod/perlsyn.pod
+ ! pod/perltoot.pod pod/perlvar.pod pod/perlxs.pod pod/pod2man.PL
+ ! pod/roffitall pp.c pp_sys.c t/TEST t/op/gv.t t/op/hashwarn.t
+ ! t/op/substr.t vms/vms.c win32/config.bc win32/config.vc
+ ! win32/config_H.bc win32/config_H.vc win32/win32.c
+ ! x2p/find2perl.PL
+____________________________________________________________________________
+[ 973] By: gsar on 1998/05/14 22:24:26
+ Log: integrate mainline
+ Branch: win32/perl
+ + Porting/Contract
+ +> README.beos beos/nm.c ext/POSIX/hints/bsdos.pl
+ +> ext/POSIX/hints/freebsd.pl ext/POSIX/hints/netbsd.pl
+ +> ext/POSIX/hints/openbsd.pl hints/beos.sh pod/perldelta4.pod
+ +> utils/perlcc.PL
+ ! MANIFEST Todo doio.c emacs/ptags embed.h ext/IO/IO.pm
+ ! ext/Opcode/Opcode.pm ext/Socket/Socket.xs hints/irix_5.sh
+ ! hints/netbsd.sh hv.c lib/Benchmark.pm lib/Carp.pm
+ ! lib/ExtUtils/Install.pm lib/ExtUtils/MM_Unix.pm
+ ! lib/Pod/Html.pm lib/Term/ReadLine.pm lib/chat2.pl opcode.h
+ ! opcode.pl perl.c perl.h pod/perlapio.pod pod/perlcall.pod
+ ! pod/perldebug.pod pod/perldelta.pod pod/perldiag.pod
+ ! pod/perlembed.pod pod/perlfaq2.pod pod/perlfaq3.pod
+ ! pod/perlfaq4.pod pod/perlfaq5.pod pod/perlfaq7.pod
+ ! pod/perlfaq8.pod pod/perlform.pod pod/perlfunc.pod
+ ! pod/perlguts.pod pod/perlhist.pod pod/perlipc.pod
+ ! pod/perllocale.pod pod/perlmodlib.pod pod/perlop.pod
+ ! pod/perlre.pod pod/perlref.pod pod/perlrun.pod
+ ! pod/perlstyle.pod pod/perlsub.pod pod/perlsyn.pod
+ ! pod/perltoot.pod pod/perlvar.pod pod/perlxs.pod pod/pod2man.PL
+ ! pod/roffitall pp.c pp_hot.c pp_sys.c sv.c t/TEST t/op/gv.t
+ ! t/op/hashwarn.t t/op/substr.t vms/vms.c win32/config.bc
+ ! win32/config.vc win32/config_H.bc win32/config_H.vc
+ ! win32/win32.c x2p/find2perl.PL
+ !> (integrate 59 files)
+____________________________________________________________________________
+[ 972] By: nick on 1998/05/14 18:09:01
+ Log: Changes to allow compiler with gcc-2.8.1 in C++ mode,
+ Remove K&R style functions, avoid struct/typedef clash.
+ Branch: ansiperl
+ ! bytecode.h byterun.c sv.c toke.c
+____________________________________________________________________________
+[ 971] By: TimBunce on 1998/05/14 16:52:19
+ Log:
+ Title: "fix C<print "foo ${\()}"> (pp_refgen fumbles when G_SCALAR, no args)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805070402.AAA02858@aatma.engin.umich.edu>
+ Files: pp.c
+ Branch: maint-5.004/perl
+ ! pp.c
+____________________________________________________________________________
+[ 970] By: TimBunce on 1998/05/14 16:18:06
+ Log:
+ Title: "perlbug reformatted"
+ From: Dominic Dunlop <domo@vo.lu>, Hugo van der Sanden
+ <hv@crypt0.demon.co.uk>
+ Msg-ID: <199805110954.LAA20367@dorlas.elsevier.nl>,
+ <l03130300b17cebcb6d33@[194.222.64.89]>,
+ <v03110702b17ccbab6824@[195.95.102.67]>
+ Files: utils/perlbug.PL
+ Branch: maint-5.004/perl
+ ! utils/perlbug.PL
+____________________________________________________________________________
+[ 969] By: mbeattie on 1998/05/14 16:15:09
+ Log: Integrate win32 branch into mainline
+ Branch: perl
+ +> ext/DynaLoader/DynaLoader.pm.PL hints/openbsd.sh
+ +> t/op/die_exit.t t/op/ipcmsg.t t/op/ipcsem.t t/op/pos.t
+ - ext/DynaLoader/DynaLoader.pm
+ !> (integrate 118 files)
+____________________________________________________________________________
+[ 968] By: mbeattie on 1998/05/14 16:05:57
+ Log: Bump patchlevel to 65
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 967] By: mbeattie on 1998/05/14 16:05:19
+ Log: Another fixup of MANIFEST
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 966] By: mbeattie on 1998/05/14 16:02:20
+ Log: Add missing files to MANIFEST
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 965] By: TimBunce on 1998/05/14 16:00:11
+ Log:
+ Title: "Sub declaration cost reduced from ~500 to ~100 bytes"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199805050607.CAA02050@monk.mps.ohio-state.edu>
+ Files: gv.h gv.c op.c
+ Branch: maint-5.004/perl
+ ! gv.c gv.h op.c
+____________________________________________________________________________
+[ 964] By: mbeattie on 1998/05/14 15:58:01
+ Log: Subject: [PATCH] Using Getopts::* with strict vars
+ Date: Wed, 29 Apr 1998 22:48:16 -0700 (PDT)
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Branch: perl
+ ! lib/Getopt/Long.pm lib/Getopt/Std.pm lib/strict.pm
+____________________________________________________________________________
+[ 963] By: mbeattie on 1998/05/14 15:56:53
+ Log: Subject: [ PATCH 5.004_64 ] Integrated regression tests for compiler
+ Date: Wed, 29 Apr 1998 21:02:36 -0600 (MDT)
+ From: epeschko@den-mdev1 (Ed Peschko)
+ Branch: perl
+ + utils/perlcc.PL
+ ! MANIFEST Makefile.SH installperl lib/Test/Harness.pm
+ ! pod/Makefile t/TEST t/harness utils/Makefile x2p/Makefile.SH
+____________________________________________________________________________
+[ 962] By: mbeattie on 1998/05/14 15:45:28
+ Log: From: Dan Sugalski <sugalskd@ous.edu>
+ Subject: [PATCH 5.004_64] Final (I hope) doc patch for Thread.pm
+ Date: Wed, 08 Apr 1998 17:08:48 -0700
+ Subject: [PATCH 5.004_64] Revised second Thread.PM doc patch
+ Date: Fri, 08 May 1998 10:49:16 -0700
+ Branch: perl
+ ! ext/Thread/Thread.pm
+____________________________________________________________________________
+[ 961] By: mbeattie on 1998/05/14 15:43:39
+ Log: Subject: Consolidated patch to 5.004_64
+ Date: Wed, 08 Apr 1998 19:44:34 -0400 (EDT)
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Branch: perl
+ ! ext/B/byteperl.c lib/ExtUtils/MM_Unix.pm
+ ! lib/ExtUtils/MM_VMS.pm lib/chat2.pl perl.c pod/perlsub.pod
+ ! vms/config.vms vms/descrip.mms vms/genconfig.pl
+ ! vms/perlvms.pod
+____________________________________________________________________________
+[ 960] By: mbeattie on 1998/05/14 15:41:41
+ Log: Subject: Re: ANNOUNCE: Perl 5.005b1t3 (a.k.a. perl5.004_64) is available
+ Date: 07 Apr 1998 18:31:21 +0200
+ From: JVromans@Squirrel.nl (Johan Vromans)
+ Branch: perl
+ ! lib/Getopt/Long.pm
+____________________________________________________________________________
+[ 959] By: mbeattie on 1998/05/14 15:39:29
+ Log: From: Jarkko Hietaniemi <jhi@iki.fi>
+ Subject: Re: [PATCH] 5.004_04 or 5.004_64: Benchmark.pm: add run-for-some-time
+ Date: Wed, 8 Apr 1998 09:47:45 +0300 (EET DST)
+ Subject: [PATCH] perl 5.004_64+Config_04
+ Date: Thu, 14 May 1998 12:14:07 +0300 (EET DST)
+ Branch: perl
+ ! lib/Benchmark.pm pod/perlfunc.pod
+____________________________________________________________________________
+[ 958] By: mbeattie on 1998/05/14 15:36:30
+ Log: From: kstar@chapin.edu
+ Subject: [PATCH] hints for Irix 6
+ Date: Mon, 6 Apr 1998 15:14:14 -0400 (EDT)
+ Subject: [PATCH 5.004_64] Threads - an easy way for dual installation
+ Date: Wed, 29 Apr 1998 15:39:46 -0400 (EDT)
+ Branch: perl
+ ! INSTALL hints/irix_6.sh installperl
+____________________________________________________________________________
+[ 957] By: mbeattie on 1998/05/14 15:33:48
+ Log: Subject: [PATCH] Install extensions with bootstrap (again) in $archlib
+ Date: Mon, 06 Apr 1998 21:09:24 +0200
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Branch: perl
+ ! lib/ExtUtils/Install.pm
+____________________________________________________________________________
+[ 956] By: mbeattie on 1998/05/14 15:32:39
+ Log: Subject: [PATCH] Config: Irix 5 hints
+ Date: Mon, 6 Apr 1998 13:12:47 -0400 (EDT)
+ From: kstar@O2.chapin.edu
+ Branch: perl
+ ! hints/irix_5.sh
+____________________________________________________________________________
+[ 955] By: mbeattie on 1998/05/14 15:31:12
+ Log: Subject: PATCH: h2ph produces incorrect code
+ Date: Mon, 6 Apr 1998 23:52:13 +0930 (CST)
+ From: Billy <wdconsta@cs.adelaide.edu.au>
+ Branch: perl
+ ! utils/h2ph.PL
+____________________________________________________________________________
+[ 954] By: mbeattie on 1998/05/14 15:29:27
+ Log: Subject: [PATCH] perldebug.pod
+ Date: Mon, 6 Apr 1998 00:36:57 -0600
+ From: jason stewart <jasons@sandy-home.arc.unm.edu>
+ Branch: perl
+ ! pod/perldebug.pod
+____________________________________________________________________________
+[ 953] By: mbeattie on 1998/05/14 15:28:00
+ Log: From: Dominic Dunlop <domo@vo.lu>
+ Subject: [PATCH 5.004_64]: hints/machten.sh: disable semctl()
+ Date: Wed, 6 May 1998 14:39:32 +0000
+ Subject: [PATCH] Not OK: perl 5.00464 on powerpc-machten 4.1 (hashwarn @INC problem)
+ Date: Sat, 4 Apr 1998 19:44:34 +0000
+ Branch: perl
+ ! hints/machten.sh t/op/hashwarn.t
+____________________________________________________________________________
+[ 952] By: mbeattie on 1998/05/14 15:23:19
+ Log: New pod/perldelta.pod (previous one branched in last change):
+ Subject: [PATCH 5.004_64] Start new perldelta
+ Date: Thu, 23 Apr 1998 12:12:38 -0400 (EDT)
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Branch: perl
+ + pod/perldelta.pod
+____________________________________________________________________________
+[ 951] By: mbeattie on 1998/05/14 15:20:43
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Subject: [PATCH for 5.004_04 and 5.004_64] (Was: Obsoleted svr4.sh)
+ Date: Thu, 23 Apr 1998 11:10:15 -0400 (EDT)
+ Subject: [PATCH 5.004_64] Start new perldelta
+ Date: Thu, 23 Apr 1998 12:12:38 -0400 (EDT)
+ (above branched perldelta -> perldelta4, new perldelta will be
+ created/added next change)
+ Subject: [PATCH] BSD Platforms need STRUCT_TM_HASZONE
+ Date: Tue, 12 May 1998 09:58:49 -0400 (EDT)
+ Branch: perl
+ + ext/POSIX/hints/bsdos.pl ext/POSIX/hints/freebsd.pl
+ + ext/POSIX/hints/netbsd.pl ext/POSIX/hints/openbsd.pl
+ +> pod/perldelta4.pod
+ - pod/perldelta.pod
+ ! MANIFEST hints/svr4.sh
+____________________________________________________________________________
+[ 949] By: TimBunce on 1998/05/14 15:11:30
+ Log:
+ Title: "while($x=<>) no longer warns (implicit defined added)"
+ From: Nick Ing-Simmons <nik@tiuk.ti.com>
+ Msg-ID: <199805051035.LAA27365@pluto.tiuk.ti.com>
+ Files: MANIFEST op.c t/op/defins.t
+ Branch: maint-5.004/perl
+ + t/op/defins.t
+ ! MANIFEST op.c
+____________________________________________________________________________
+[ 948] By: mbeattie on 1998/05/14 15:09:51
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Subject: [PATCH for 5.004_64] Configure patch Config_64-01
+ Date: Tue, 14 Apr 1998 13:04:58 -0400 (EDT)
+ Subject: [PATCH for 5.004_64] Configure patch Config_64-01-02.diff
+ Date: Fri, 17 Apr 1998 11:01:13 -0400 (EDT)
+ Subject: [PATCH for 5.004_64] Configure patch Config_64-02-03.diff
+ Date: Thu, 23 Apr 1998 15:03:20 -0400 (EDT)
+ Subject: [PATCH 5.004_64] Config_64-03-04.diff
+ Date: Wed, 13 May 1998 14:33:30 -0400 (EDT)
+ Branch: perl
+ + README.beos beos/nm.c hints/beos.sh
+ ! Configure INSTALL MANIFEST Makefile.SH Policy_sh.SH
+ ! Porting/Glossary Porting/config.sh Porting/config_H
+ ! Porting/pumpkin.pod Todo cflags.SH config_h.SH
+ ! djgpp/djgppsed.sh doop.c handy.h hints/dos_djgpp.sh
+ ! hints/netbsd.sh hints/solaris_2.sh hints/unicos.sh
+ ! hints/unicosmk.sh hv.h lib/Term/ReadLine.pm perl.h
+ ! plan9/config.plan9 pod/perlfunc.pod pp.c pp_sys.c sv.h
+ ! t/io/pipe.t thread.h vms/config.vms win32/config.bc
+ ! win32/config.vc win32/config_H.bc win32/config_H.vc
+____________________________________________________________________________
+[ 946] By: TimBunce on 1998/05/14 15:07:06
+ Log:
+ Title: "Fix PERL_DESTRUCT_LEVEL core dumps"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805062301.TAA24599@aatma.engin.umich.edu>
+ Files: perl.c sv.c t/op/misc.t
+ Branch: maint-5.004/perl
+ ! perl.c sv.c t/op/misc.t
+____________________________________________________________________________
+[ 945] By: mbeattie on 1998/05/14 15:00:31
+ Log: Subject: Perl Social Contract
+ Date: 13 Apr 1998 06:16:59 -0700
+ From: Russ Allbery <rra@stanford.edu>
+ Branch: perl
+ + Porting/Contract
+____________________________________________________________________________
+[ 944] By: TimBunce on 1998/05/14 14:59:37
+ Log:
+ Title: "5.004_04-m2 Cleanup of test failures"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805070416.AAA03082@aatma.engin.umich.edu>
+ Files: t/op/die_exit.t t/op/ipcmsg.t t/op/ipcsem.t t/op/taint.t
+ win32/config.bc win32/config.vc
+ Branch: maint-5.004/perl
+ ! t/op/die_exit.t t/op/ipcmsg.t t/op/ipcsem.t t/op/taint.t
+ ! win32/config.bc win32/config.vc
+____________________________________________________________________________
+[ 943] By: mbeattie on 1998/05/14 14:58:13
+ Log: From: Joshua.Pritikin@NewYork2.dmg.deuba.com
+ Subject: [PATCH 5.004_64] Test.pm update
+ Date: Sat, 4 Apr 1998 08:33:50 -0500
+ Subject: [PATCH 5.004_64] modcount + comments
+ Date: Fri, 17 Apr 1998 16:07:35 -0400
+ Branch: perl
+ ! lib/Test.pm op.c thrdvar.h
+____________________________________________________________________________
+[ 942] By: mbeattie on 1998/05/14 14:49:43
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Subject: [PATCH 5.004_64] newSV
+ Date: Wed, 8 Apr 1998 03:21:03 -0400 (EDT)
+ Subject: [PATCH 5.004_64] Cryptic error from B::CC
+ Date: Sat, 11 Apr 1998 19:52:25 -0400 (EDT)
+ Branch: perl
+ ! ext/B/B/CC.pm handy.h proto.h sv.c
+____________________________________________________________________________
+[ 941] By: mbeattie on 1998/05/14 14:47:29
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Subject: [PATCH 5.004_64] anydbm.t
+ Date: Sat, 4 Apr 1998 01:39:03 -0500 (EST)
+ Subject: [PATCH 5.004_64] threads on OS/2
+ Date: Sat, 4 Apr 1998 01:44:29 -0500 (EST)
+ Subject: [PATCH 5.004_64] Better handling of Perl DLLs under OS/2
+ Date: Sat, 4 Apr 1998 01:47:58 -0500 (EST)
+ Subject: [PATCH 5.004_64] Immediate stop in debugger
+ Date: Sat, 11 Apr 1998 19:50:58 -0400 (EDT)
+ Subject: [PATCH 5.005_64] ptags broken
+ Date: Sat, 11 Apr 1998 22:08:21 -0400 (EDT)
+ Subject: [PATCH 5.004_64] Document switch syntax via RE
+ Date: Sun, 12 Apr 1998 01:12:33 -0400 (EDT)
+ Branch: perl
+ ! emacs/ptags lib/ExtUtils/MM_OS2.pm lib/ExtUtils/Mksymlists.pm
+ ! lib/perl5db.pl os2/Changes os2/Makefile.SHs os2/os2.c
+ ! os2/os2thread.h pod/perlsyn.pod t/lib/anydbm.t
+____________________________________________________________________________
+[ 940] By: mbeattie on 1998/05/14 14:38:44
+ Log: Subject: [PATCH 5.004_64] Build Stdio and DCLSym modules as part of normal VMS perl build
+ Date: Fri, 03 Apr 1998 16:01:57 -0800
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Branch: perl
+ ! vms/descrip.mms vms/ext/DCLsym/Makefile.PL
+ ! vms/ext/Stdio/Makefile.PL vms/ext/Stdio/Stdio.xs
+____________________________________________________________________________
+[ 939] By: mbeattie on 1998/05/14 14:35:42
+ Log: Subject: [PATCH 5.004_64] perl dies in perl_construct when compiled with MULTIPLICITY
+ Date: Fri, 03 Apr 1998 13:58:15 -0800
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Branch: perl
+ ! perl.c
+____________________________________________________________________________
+[ 938] By: gsar on 1998/05/14 10:53:55
+ Log: merge change#896 from maintbranch
+ Branch: win32/perl
+ ! doio.c ext/Socket/Socket.xs lib/Class/Struct.pm lib/Cwd.pm
+ ! lib/File/Find.pm lib/Math/BigInt.pm lib/lib.pm lib/strict.pm
+ ! op.c pod/perldiag.pod pod/perlfunc.pod pp.c pp_ctl.c sv.c
+ ! t/op/gv.t t/op/misc.t t/op/pack.t
+____________________________________________________________________________
+[ 937] By: gsar on 1998/05/14 09:31:34
+ Log: merge change#887 from maintbranch
+ Branch: win32/perl
+ + t/op/die_exit.t t/op/ipcmsg.t t/op/ipcsem.t
+ ! MANIFEST doio.c lib/File/CheckTree.pm lib/Getopt/Long.pm
+ ! lib/Math/BigFloat.pm lib/Text/ParseWords.pm lib/Text/Wrap.pm
+ ! lib/base.pm perl.c pod/perlre.pod t/lib/io_sock.t
+ ! t/lib/io_udp.t t/lib/parsewords.t t/lib/timelocal.t
+ ! t/op/stat.t toke.c utils/h2xs.PL
+____________________________________________________________________________
+[ 936] By: gsar on 1998/05/14 09:06:18
+ Log: merge change#886 from maintbranch
+ Branch: win32/perl
+ ! README.os2 README.vms cop.h ext/DynaLoader/dl_hpux.xs
+ ! ext/POSIX/POSIX.xs ext/POSIX/hints/linux.pl global.sym
+ ! hints/aix.sh hints/bsdos.sh hints/dec_osf.sh hints/hpux.sh
+ ! hints/linux.sh hints/netbsd.sh hints/os2.sh hints/svr4.sh
+ ! lib/ExtUtils/MM_OS2.pm lib/ExtUtils/MM_Unix.pm
+ ! lib/File/Basename.pm lib/File/Path.pm op.c os2/Makefile.SHs
+ ! os2/os2.c os2/perl2cmd.pl perl.c perl.h pod/perlguts.pod
+ ! pod/pod2man.PL pp_ctl.c pp_hot.c pp_sys.c proto.h
+ ! t/lib/filecopy.t util.c utils/perldoc.PL vms/config.vms
+ ! vms/descrip.mms vms/ext/Filespec.pm vms/ext/filespec.t
+ ! vms/test.com
+____________________________________________________________________________
+[ 935] By: gsar on 1998/05/14 07:00:02
+ Log: merge changes#872,873 from maintbranch
+ Branch: win32/perl
+ ! Changes5.004 INSTALL lib/ExtUtils/MakeMaker.pm
+ ! lib/FileHandle.pm lib/Tie/Hash.pm lib/constant.pm
+ ! lib/integer.pm pod/perl.pod pod/perlbook.pod pod/perldsc.pod
+ ! pod/perlfunc.pod pod/perlguts.pod pod/perlhist.pod
+ ! pod/perlop.pod pod/perlre.pod pod/perlrun.pod pod/perlsec.pod
+ ! pod/perltrap.pod pod/perlvar.pod pod/pod2latex.PL
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 934] By: gsar on 1998/05/14 06:24:38
+ Log: merge changes#755..759,763,764 from maintbranch
+ Branch: win32/perl
+ + hints/openbsd.sh
+ ! MANIFEST Porting/patchls perl.c perlsdio.h pod/perlfunc.pod
+ ! t/op/pos.t utils/perldoc.PL
+____________________________________________________________________________
+[ 933] By: gsar on 1998/05/14 06:07:31
+ Log: merge change#754 from maintbranch
+ Branch: win32/perl
+ ! perl.c
+____________________________________________________________________________
+[ 932] By: gsar on 1998/05/14 06:03:50
+ Log: merge changes#752,753 from maintbranch
+ Branch: win32/perl
+ + t/op/pos.t
+ ! README ext/GDBM_File/GDBM_File.pm
+ ! ext/SDBM_File/sdbm/Makefile.PL pod/perlsyn.pod
+____________________________________________________________________________
+[ 931] By: gsar on 1998/05/14 05:51:19
+ Log: merge change#745 from maintbranch
+ Branch: win32/perl
+ + ext/DynaLoader/DynaLoader.pm.PL
+ - ext/DynaLoader/DynaLoader.pm
+ ! MANIFEST ext/DynaLoader/Makefile.PL
+____________________________________________________________________________
+[ 930] By: nick on 1998/05/13 20:39:59
+ Log: resolve -at //depot/win32 into ansiperl for C++ testing.
+ Branch: ansiperl
+ ! utils/perldoc.PL
+ !> MANIFEST ext/Fcntl/Fcntl.pm hv.c lib/ExtUtils/Liblist.pm op.c
+ !> perl.c pod/perlfunc.pod pod/perlguts.pod pp.c pp_ctl.c
+ !> regcomp.c regcomp.h regexec.c t/op/hashwarn.t t/op/runlevel.t
+ !> win32/Makefile win32/config.bc win32/config.gc win32/config.vc
+ !> win32/makedef.pl win32/makefile.mk
+____________________________________________________________________________
+[ 929] By: gsar on 1998/05/13 10:13:36
+ Log: merge change#687 from maintbranch
+ Branch: win32/perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 928] By: gsar on 1998/05/13 10:08:13
+ Log: merge change#683 from maintbranch
+ Branch: win32/perl
+ ! pod/perlguts.pod
+____________________________________________________________________________
+[ 927] By: gsar on 1998/05/13 09:51:43
+ Log: merge change#681 from maintbranch
+ Branch: win32/perl
+ ! ext/Fcntl/Fcntl.pm
+____________________________________________________________________________
+[ 926] By: gsar on 1998/05/13 09:47:11
+ Log: merge change#664 from maint branch
+ Branch: win32/perl
+ ! regcomp.c regcomp.h regexec.c
+____________________________________________________________________________
+[ 925] By: gsar on 1998/05/13 08:55:28
+ Log: merge missing part of change#663 from maint branch
+ Branch: win32/perl
+ ! op.c
+____________________________________________________________________________
+[ 924] By: gsar on 1998/05/12 18:50:04
+ Log: remove x586 code gen switch (-5) for Borland, it is non-generic,
+ and seems to generate problematic code for PII.
+ Branch: win32/perl
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 923] By: gsar on 1998/05/12 16:24:02
+ Log: fix test failure
+ Message-Id: <199805120940.KAA01252@pluto.tiuk.ti.com>
+ Date: Tue, 12 May 1998 10:40:57 BST
+ From: Nick.Ing-Simmons@tiuk.ti.com
+ Subject: test buglet
+ Branch: win32/perl
+ ! t/op/hashwarn.t
+____________________________________________________________________________
+[ 922] By: TimBunce on 1998/05/11 20:58:58
+ Log: Assorted patches:
+
+ ------ CORE LANGUAGE ------
+
+ Title: "incorrect return value for hv_iterinit"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805031848.OAA20618@aatma.engin.umich.edu>
+ Files: pod/perlguts.pod hv.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "perlvar.pod buglet E<EVMSERR>"
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9805041415.AA22185@o09.xray.mpe.mpg.de>
+ Files: pod/perlvar.pod
+
+ Title: "Improve docs for warning about code after an exec()"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Chaim Frenkel
+ <chaimf@concentric.net>
+ Msg-ID: <E0yYUit-0003yb-00@taurus.cus.cam.ac.uk>,
+ <m3ra22qn1z.fsf@chany-p100.emwp.com>
+ Files: pod/perlfunc.pod
+
+ Title: "Remove dead code from pod2man"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0yXmuT-0006Ll-00@ursa.cus.cam.ac.uk>
+ Files: pod/pod2man.PL
+
+ Title: "tweak doc for C<do FILENAME>"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805090017.UAA06888@aatma.engin.umich.edu>
+ Files: pod/perlfunc.pod
+
+ Title: "Document integer pragma effect on % operator"
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <m3yawjmzhx.fsf@furu.g.aas.no>
+ Files: pod/perlop.pod
+
+ Title: "Reduce rm command line length in pod/Makefile"
+ From: Hugo van der Sanden <h.sanden@elsevier.nl>
+ Msg-ID: <199805041423.QAA13199@dorlas.elsevier.nl>
+ Files: pod/Makefile
+
+ ------ EXTENSIONS ------
+
+ Title: "Clarify Termios usage in POSIX.pod"
+ From: Rocco Caputo <troc@netrus.net>
+ Msg-ID: <199805101952.PAA12738@ns.netrus.net>
+ Files: ext/POSIX/POSIX.pod
+
+ ------ LIBRARY ------
+
+ Title: "Fix File::Find::finddepth typo in trial 2 release"
+ From: koenig@kulturbox.de (Andreas J. Koenig)
+ Msg-ID: <sfcbttflsjz.fsf@dubravka.in-berlin.de>
+ Files: lib/File/Find.pm t/lib/filefind.t
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Add Porting/patching.pod document"
+ From: Daniel Grisinger <dgris@tdrenterprises.com>
+ Msg-ID: <199805030305.XAA16147@relay.pair.com>
+ Files: MANIFEST Porting/patching.pod
+
+ Title: "hints/machten.sh: disable semctl(), align with devel version"
+ From: Dominic Dunlop <domo@vo.lu>
+ Msg-ID: <v03110701b175fc029eb1@[195.95.102.115]>
+ Files: hints/machten.sh
+
+ Title: "Add VMS specifics to Porting/makerel"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01IWDK1LONRQ0026P0@cor.newman.upenn.edu>,
+ <199804271732.SAA13762@toad.ig.co.uk>,
+ <9804250212.AA27695@forte.com>
+ Files: Porting/makerel
+ Branch: maint-5.004/perl
+ + Porting/patching.pod
+ ! MANIFEST Porting/makerel ext/POSIX/POSIX.pod hints/machten.sh
+ ! hv.c lib/File/Find.pm pod/Makefile pod/perlfunc.pod
+ ! pod/perlguts.pod pod/perlop.pod pod/perlvar.pod pod/pod2man.PL
+ ! t/lib/filefind.t
+____________________________________________________________________________
+[ 921] By: gsar on 1998/05/10 02:28:03
+ Log: various tweaks to makefiles
+ Branch: win32/perl
+ ! win32/Makefile win32/makedef.pl win32/makefile.mk
+____________________________________________________________________________
+[ 920] By: gsar on 1998/05/10 02:27:19
+ Log: fix ExtUtils::Liblist mishandling paths with spaces
+ Branch: win32/perl
+ ! lib/ExtUtils/Liblist.pm
+____________________________________________________________________________
+[ 919] By: gsar on 1998/05/09 17:10:15
+ Log: minor cleanup
+ Branch: win32/perl
+ ! MANIFEST perl.c
+____________________________________________________________________________
+[ 918] By: gsar on 1998/05/09 17:09:09
+ Log: protect sortcop from C<sort { sort { ... } ... } ...>
+ Message-Id: <199805082333.TAA06287@aatma.engin.umich.edu>
+ Date: Fri, 08 May 1998 19:33:44 EDT
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Subject: [PATCH] Re: double recursion in sort
+ Branch: win32/perl
+ ! pp_ctl.c t/op/runlevel.t
+____________________________________________________________________________
+[ 917] By: gsar on 1998/05/09 17:05:55
+ Log: c
+ Branch: win32/perl
+ ! win32/config.bc win32/config.gc win32/config.vc
+____________________________________________________________________________
+[ 916] By: gsar on 1998/05/07 03:40:15
+ Log: fix C<print "foo ${\()}"> (pp_refgen fumbles when G_SCALAR, no args)
+ Branch: win32/perl
+ ! pp.c
+____________________________________________________________________________
+[ 915] By: mbeattie on 1998/05/06 13:08:29
+ Log: Speed up pp_entersub for usethreads with only 1 thread running.
+ Branch: perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 914] By: gsar on 1998/05/03 18:44:38
+ Log: make hv_iterinit() return HvKEYS()
+ Message-Id: <3.0.1.32.19980502162922.009e6320@www.syncad.com>
+ Date: Sat, 02 May 1998 16:29:22 EDT
+ From: "SynaptiCAD, Inc." <sales@syncad.com>
+ Subject: incorrect return value for hv_iterinit
+ Branch: win32/perl
+ ! hv.c pod/perlguts.pod
+____________________________________________________________________________
+[ 913] By: TimBunce on 1998/05/01 22:38:38
+ Log: Update MANIFEST for trial 2.
+ (Porting/Contract lib/Tie/Handle.pm t/op/tiehandle.t)
+ Branch: maint-5.004/perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 912] By: TimBunce on 1998/05/01 22:30:29
+ Log: Add t/op/tiehandle.t as xtext to repository (see change 911)
+ Branch: maint-5.004/perl
+ + t/op/tiehandle.t
+____________________________________________________________________________
+[ 911] By: TimBunce on 1998/05/01 21:35:03
+ Log:
+ Title: "Add ERRSV, ERRHV, DEFSV and SAVE_DEFSV for XS 5.005 compatibility"
+ From: timbo@ig.co.uk (Tim Bunce)
+ Msg-ID: <199804200854.JAA01482@toad.ig.co.uk>
+ Files: perl.h
+
+ Title: "Add WRITE & CLOSE to TIEHANDLE"
+ From: Graham Barr <gbarr@pobox.com>
+ Msg-ID: <34F63DC8.CA95670F@pobox.com>
+ Files: pod/perltie.pod lib/Tie/Handle.pm pp_sys.c t/op/tiehandle.t
+ Branch: maint-5.004/perl
+ + lib/Tie/Handle.pm
+ ! perl.h pod/perltie.pod pp_sys.c
+____________________________________________________________________________
+[ 910] By: TimBunce on 1998/05/01 20:47:47
+ Log:
+ Title: "Add warning for Illegal hex digit"
+ From: Stephen P Potter <spp@spp.users.ds.net>, Stephen Potter
+ <spp@psasolar.colltech.com>, Tim.Bunce@ig.co.uk (Tim Bunce)
+ Msg-ID: <199804232219.SAA02267@spp.users.ds.net>,
+ <199804271409.PAA12819@toad.ig.co.uk>,
+ <199804280307.WAA12332@psasolar.psa.pencom.com>
+ Files: pod/perldiag.pod util.c
+
+ Title: "perl_call_method() bug fix (corrupt op pointer)"
+ From: "Alterman, Eugene" <Eugene.Alterman@bremer-inc.com>
+ Msg-ID: <510415F72ECFD111A31700A0C9B3CCDE3098@efx98digmasa.bremer-inc.com>
+ Files: perl.c
+
+ Title: "Fix printf segmentation fault"
+ From: Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Msg-ID: <l03130300b16bebdbc314@[194.222.64.89]>
+ Files: pp_hot.c
+
+ Title: "Document changed local($a[$i],$b{$j}) behaviour re delete/splice"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01IVMVIHNZ36001NKH@cor.newman.upenn.edu>
+ Files: pod/perlsub.pod
+ Branch: maint-5.004/perl
+ ! perl.c pod/perldiag.pod pod/perlsub.pod pp_hot.c util.c
+____________________________________________________________________________
+[ 909] By: TimBunce on 1998/05/01 19:44:47
+ Log:
+ Title: "Change Ilya's do_binmode to K&R prototype and move to doio.c"
+ Files: doio.c util.c
+ Branch: maint-5.004/perl
+ ! doio.c util.c
+____________________________________________________________________________
+[ 908] By: gsar on 1998/05/01 19:21:02
+ Log: add AS patch#20 (exposes more global constants)
+ Branch: asperl
+ ! ObjXSub.h byterun.h embed.h embedvar.h global.sym globals.c
+ ! interp.sym ipsock.h ipstdio.h objpp.h perlio.h perlsock.h
+ ! proto.h util.c win32/GenCAPI.pl win32/runperl.c
+____________________________________________________________________________
+[ 907] By: TimBunce on 1998/05/01 17:50:46
+ Log:
+ Title: "Runtime Carp verbosity without aliasing"
+ From: Joshua.Pritikin@NewYork2.dmg.deuba.com, Tim Bunce
+ Msg-ID: <H00000e50003936c@MHS>
+ Files: lib/Carp.pm
+
+ Title: "Fix File::Basename to not untaint results (using new //t flag)"
+ From: Eric Hammond <erich@finity.citysearch.com>, Tom Phoenix
+ <rootbeer@teleport.com>
+ Msg-ID: <199710070515.WAA00682@finity.citysearch.com>,
+ <Pine.GSO.3.96.971007074114.14211J-100000@usertest.teleport.com>
+ Files: lib/File/Basename.pm
+ Branch: maint-5.004/perl
+ ! lib/Carp.pm lib/File/Basename.pm
+____________________________________________________________________________
+[ 906] By: TimBunce on 1998/04/28 11:04:49
+ Log:
+ ------ CORE LANGUAGE ------
+
+ Title: "5.004_04m5t1: Fix dangling references in LVs", "Fix dangling
+ references in LVs"
+ From: Spider Boardman <spider@orb.nashua.nh.us>
+ Msg-ID: <199804010541.AAA32615@Orb.Nashua.NH.US>,
+ <19980422164037.D29222@perl.org>
+ Files: embed.h keywords.h opcode.h perl.h proto.h doop.c global.sym mg.c
+ pp.c sv.c
+
+ Title: "Fix SvGMAGIC typo in change 904"
+ Files: doop.c
+ Branch: maint-5.004/perl
+ ! doop.c embed.h global.sym keywords.h mg.c opcode.h perl.h pp.c
+ ! proto.h sv.c
+____________________________________________________________________________
+[ 905] By: TimBunce on 1998/04/28 10:32:20
+ Log: Regexp patches
+
+ Title: "New regex flag //t to leave $1 etc. tainted"
+ From: Chip Salzenberg <chip@pobox.com>, Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <19980310192640.37826@cyprus>
+ Files: pod/perlop.pod pod/perlre.pod op.h dump.c mg.c pp_hot.c sv.c
+ t/op/taint.t toke.c
+
+ Title: "Don't accidentally untaint target of s///"
+ From: Chip Salzenberg <chip@pobox.com>
+ Msg-ID: <19980310151756.24767@cyprus>
+ Files: pp_ctl.c pp_hot.c t/op/taint.t
+
+ Title: "Allow but ignore embedded /...(?o).../ in regexp"
+ From: h.sanden@elsevier.nl (Hugo van der Sanden)
+ Msg-ID: <199804201243.OAA08244@dorlas.elsevier.nl>
+ Files: regcomp.c
+ Branch: maint-5.004/perl
+ ! dump.c mg.c op.h pod/perlop.pod pod/perlre.pod pp_ctl.c
+ ! pp_hot.c regcomp.c sv.c t/op/taint.t toke.c
+____________________________________________________________________________
+[ 904] By: TimBunce on 1998/04/27 20:20:21
+ Log: Assorted patches:
+
+ ------ CORE LANGUAGE ------
+
+ Title: "Protect join() against double reads on undef and SvGMAGICALs"
+ From: Chip Salzenberg <chip@perlsupport.com>, Tim Bunce
+ <Tim.Bunce@ig.co.uk>
+ Msg-ID: <19980424080630.D13985@perl.org>
+ Files: doop.c
+
+ Title: "Better error message for require failure"
+ From: epeschko@den-mdev1 (Ed Peschko)
+ Msg-ID: <199804240047.SAA24155@den-mdev1.co.csgsystems.com>
+ Files: pod/perldiag.pod pp_ctl.c
+
+ Title: "fixes for various noises under PERL_DESTRUCT_LEVEL"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199804231926.PAA23969@aatma.engin.umich.edu>
+ Files: perl.c
+
+ Title: "Fix nice_chunk memory leak"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199804052347.TAA15699@aatma.engin.umich.edu>
+ Files: sv.c
+
+ Title: "-2.0 vs. -2 (was Number representations)"
+ From: Chip Salzenberg <chip@pobox.com>
+ Msg-ID: <19980309185652.11231@cyprus>
+ Files: op.c
+
+ Title: "perl.c fixes for -DUNEXEC"
+ From: Matt Wette <mwette@mr-ed.jpl.nasa.gov>, Matthew R Wette
+ <mwette@mr-ed.jpl.nasa.gov>
+ Msg-ID: <199710152146.OAA07283@mr-ed.jpl.nasa.gov>
+ Files: perl.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "perlcall is Perl from C, not C from Perl"
+ From: Steve A Fink <sfink@cs.berkeley.edu>
+ Files: pod/perlembed.pod
+
+ Title: "Clarify require "Foo::Bar" non-bareword issue"
+ From: Dominique Dumont <domi@ss7serv.grenoble.hp.com>
+ Msg-ID: <199804231527.AA153445256@ss7serv.grenoble.hp.com>
+ Files: pod/perlfunc.pod
+
+ Title: "(repost) new text for perlsec", "new text for perlsec"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980423161605.5518N-100000@user2.teleport.com>
+ Files: pod/perlsec.pod
+
+ ------ EXTENSIONS ------
+
+ Title: "IO::Socket->socketpair broken (typo)"
+ From: Olaf Titz <olaf@bigred.inka.de>
+ Msg-ID: <19980425224535.2807.qmail@bigred.inka.de>
+ Files: ext/IO/lib/IO/Socket.pm
+
+ Title: "NDBM_File man page needs Fcntl"
+ From: "Danny R. Faught" <faught@mailhost.rsn.hp.com>
+ Msg-ID: <199707011500.IAA00601@palrel3.hp.com>
+ Files: ext/NDBM_File/NDBM_File.pm
+
+ ------ LIBRARY ------
+
+ Title: "Documentation discrepancy: pragmatic modules"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, h.sanden@elsevier.nl (Hugo van der Sanden)
+ Msg-ID: <199804221525.RAA12695@dorlas.elsevier.nl>,
+ <E0ySPhk-00034f-00@taurus.cus.cam.ac.uk>
+ Files: lib/strict.pm lib/subs.pm lib/vars.pm
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Updated hints file for svr4"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980423110522.26621A-100000@newton.phys>
+ Files: hints/svr4.sh
+
+ Title: "Pumpkin update -- shared libperl.so location"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980424115837.6222A-100000@newton.phys>
+ Files: Porting/pumpkin.pod
+
+ Title: "perl compile fix for AIX 4.3"
+ From: Jens-Uwe Mager <jum@helios.de>
+ Msg-ID: <199804261611.SAA34728@ans.helios.de>
+ Files: ext/DynaLoader/dl_aix.xs
+
+ Title: "Dynaloader build on VMS",
+ From: pvhp@forte.com (Peter Prymmer), timbo@ig.co.uk (Tim Bunce)
+ Msg-ID: <199804271732.SAA13762@toad.ig.co.uk>, <9804250212.AA27695@forte.com>
+ Files: vms/descrip.mms
+
+ ------ UTILITIES ------
+
+ Title: "Major update to h2ph.PL"
+ From: Billy <wdconsta@cs.adelaide.edu.au>
+ Msg-ID: <Pine.SV4.3.93.980424031837.20782A-200000@ermintrude.teaching.cs.adelaide.edu.au>
+ Files: utils/h2ph.PL
+ Branch: maint-5.004/perl
+ ! Porting/pumpkin.pod doop.c ext/DynaLoader/dl_aix.xs
+ ! ext/IO/lib/IO/Socket.pm ext/NDBM_File/NDBM_File.pm
+ ! hints/svr4.sh lib/strict.pm lib/subs.pm lib/vars.pm op.c
+ ! perl.c pod/perldiag.pod pod/perlembed.pod pod/perlfunc.pod
+ ! pod/perlsec.pod pp_ctl.c sv.c utils/h2ph.PL vms/descrip.mms
+____________________________________________________________________________
+[ 903] By: gsar on 1998/04/25 22:27:19
+ Log: add AS patch#19 (adds socket layer generation to GenCAPI.pl)
+ Branch: asperl
+ ! win32/GenCAPI.pl
+____________________________________________________________________________
+[ 902] By: nick on 1998/04/25 16:35:08
+ Log: Case sensitive tweak to perldoc.PL
+ Branch: ansiperl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 901] By: nick on 1998/04/25 15:16:54
+ Log: Implement use attrs qw(locked package);
+ Passes all tests except posix (hangs/dies) in sigaction test after
+ printing "ok 9".
+ Branch: ansiperl
+ ! cv.h ext/attrs/attrs.pm ext/attrs/attrs.xs pp_hot.c
+____________________________________________________________________________
+[ 900] By: nick on 1998/04/25 13:58:17
+ Log: Auto-insert defined() test in while when test expression is
+ readline (i.e. <>), glob, readdir, or each.
+ Branch: ansiperl
+ + t/op/defins.t
+ ! op.c pod/perlop.pod
+____________________________________________________________________________
+[ 899] By: nick on 1998/04/25 13:14:52
+ Log: Resolve ansiperl against win32 branch
+ Branch: ansiperl
+ +> (branch 53 files)
+ - config_H
+ !> (integrate 227 files)
+____________________________________________________________________________
+[ 898] By: gsar on 1998/04/24 17:01:05
+ Log: add AS patch#18
+ Branch: asperl
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/xsubpp win32/GenCAPI.pl
+____________________________________________________________________________
+[ 897] By: TimBunce on 1998/04/23 19:49:22
+ Log: Assorted patches:
+
+ ------ CORE LANGUAGE ------
+
+ Title: "fix for "Unbalanced string table refcount""
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199804042251.RAA25527@aatma.engin.umich.edu>
+ Files: sv.c
+
+ Title: "Allow more lenient switch processing"
+ From: "John L. Allen" <allen@grumman.com>
+ Msg-ID: <199803251638.LAA22664@gateway.grumman.com>
+ Files: perl.c
+
+ Title: "Add fourth arg to substr: substr EXPR,OFFSET,LEN,REPLACEMENT"
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <m3g1jglqtm.fsf@furu.g.aas.no>
+ Files: pod/perlfunc.pod Todo opcode.pl pp.c t/op/substr.t
+
+ Title: "Odd number of elements in hash list."
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980328151929.29336D-100000@user2.teleport.com>
+ Files: MANIFEST pod/perldiag.pod pp.c pp_hot.c t/op/hashwarn.t
+
+ Title: "another destruct_level fix"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199804030105.UAA04400@aatma.engin.umich.edu>
+ Files: hv.c
+
+ Title: "bidirectional pipe warning blues"
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9804082151.AA20399@claudius.bfsec.bt.co.uk>
+ Files: doio.c
+
+ Title: "stale pointers after realloc (MEXTEND in pp_print and pp_prtf)"
+ From: Malcolm Beattie <mbeattie@sable.ox.ac.uk>
+ Msg-ID: <199801191107.LAA17979@sable.ox.ac.uk>
+ Files: pp_hot.c pp_sys.c
+
+ Title: "unimplemented umask() should return undef not die"
+ From: kstar@chapin.edu (Kurt D. Starsinic)
+ Msg-ID: <199803120515.VAA08660@chapin.edu>
+ Files: pod/perlfunc.pod pp_sys.c
+
+ Title: "warning for: bless $foo, """
+ From: Joshua.Pritikin@NewYork2.dmg.deuba.com
+ Msg-ID: <H00000e5000378a0@MHS>
+ Files: pod/perldiag.pod pp.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "Mention SWIG in perlxs.pod"
+ From: Steve A Fink <sfink@cs.berkeley.edu>
+ Msg-ID: <Pine.HPP.3.96.980408154956.20990K-100000@brooksie.CS.Berkeley.EDU>
+ Files: pod/perlxs.pod
+
+ Title: "fix-up of previous perlre.pod patch"
+ From: Ted Ashton <ashted@southern.edu>
+ Msg-ID: <199803031540.KAA09388@ns.southern.edu>
+ Files: pod/perlre.pod
+
+ Title: "long list of man page nitpicks"
+ From: Greg Bacon <gbacon@mickey.cs.uah.edu>, Tom Christiansen
+ <tchrist@jhereg.perl.com>
+ Msg-ID: <199804221844.NAA08338@pluto.cs.uah.edu>,
+ <199804222204.QAA20805@jhereg.perl.com>
+ Files: pod/perlapio.pod pod/perlcall.pod pod/perldebug.pod pod/perldelta.pod
+ pod/perldiag.pod pod/perlembed.pod pod/perlfaq2.pod
+ pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod
+ pod/perlfaq7.pod pod/perlfaq8.pod pod/perlform.pod
+ pod/perlfunc.pod pod/perlguts.pod pod/perlipc.pod
+ pod/perllocale.pod pod/perlmodlib.pod pod/perlop.pod
+ pod/perlre.pod pod/perlref.pod pod/perlrun.pod
+ pod/perlstyle.pod pod/perlsub.pod pod/perlsyn.pod
+ pod/perltoot.pod pod/perlvar.pod pod/perlxs.pod
+ pod/pod2man.PL
+
+ Title: "document that system() does not set $! when it fails"
+ From: "Mark R. Levinson" <mrl@isc.upenn.edu>
+ Msg-ID: <199803011946.OAA31942@anaximander.dccs.upenn.edu>
+ Files: pod/perlfunc.pod
+
+ Title: "Fix pod/roffitall execute permission"
+ From: lvirden@cas.org
+ Msg-ID: <1997Nov17.132031.2589892@cor.newman>
+ Files: pod/roffitall
+
+ Title: "document when split ignores trailing empty fields"
+ From: Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Msg-ID: <l03130300b14fac832b77@[194.222.64.89]>
+ Files: pod/perlfunc.pod
+
+ ------ EXTENSIONS ------
+
+ Title: "Buglet in Opcode.pm documentation"
+ From: Horst von Brand <vonbrand@sleipnir.valparaiso.cl>
+ Msg-ID: <199804170349.XAA32445@sleipnir.valparaiso.cl>
+ Files: ext/Opcode/Opcode.pm
+
+ Title: "Failure to append to perllocal.pod should not be fatal"
+ From: koenig@kulturbox.de (Andreas J. Koenig)
+ Msg-ID: <sfciuogy67x.fsf@dubravka.in-berlin.de>
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "Document that IO.pm does not load IO::Select etc"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <353B48F1.64E35A63@ti.com>
+ Files: ext/IO/IO.pm
+
+ Title: "Install extensions with bootstrap (again) in $archlib"
+ From: Achim Bohnet <ach@mpe.mpg.de>, koenig@kulturbox.de (Andreas J.
+ Koenig)
+ Msg-ID: <9804061909.AA12675@o09.xray.mpe.mpg.de>,
+ <sfc90oxc0uj.fsf@dubravka.in-berlin.de>
+ Files: lib/ExtUtils/Install.pm
+
+ Title: "glibc2.0.6 missing MSG_* <sys/socket.h> defines."
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980406113950.3166L-100000@newton.phys>
+ Files: ext/Socket/Socket.xs
+
+ ------ LIBRARY ------
+
+ Title: "Benchmark.pm: add run-for-some-time mode"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199804080647.JAA15136@alpha.hut.fi>
+ Files: lib/Benchmark.pm
+
+ Title: "Comments added to Carp.pm"
+ From: Andy Wardley <abw@cre.canon.co.uk>, Chip Salzenberg
+ <chip@perlsupport.com>, Tom Christiansen
+ <tchrist@jhereg.perl.com>
+ Msg-ID: <19980422164242.E29222@perl.org>,
+ <199804222033.OAA17959@jhereg.perl.com>,
+ <980409182357.ZM21638@bandanna>
+ Files: lib/Carp.pm
+
+ Title: "chat2.pl fix"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01IVMVF507PO001NKH@cor.newman.upenn.edu>
+ Files: lib/chat2.pl
+
+ Title: "lib/Pod/Html.pm"
+ From: d-lewart@uiuc.edu (Daniel S. Lewart)
+ Msg-ID: <199710170718.DAA25472@staff1.cso.uiuc.edu>,
+ <199710180417.AAA19778@staff2.cso.uiuc.edu>
+ Files: lib/Pod/Html.pm
+
+ Title: "ormaments method in Term/ReadLine.pm causes warning with string
+ arg."
+ From: hiroo.hayashi@computer.org
+ Msg-ID: <199804061519.AAA21907@mail.fb3.so-net.ne.jp>
+ Files: lib/Term/ReadLine.pm
+
+ ------ OTHER CHANGES ------
+
+ Title: "ptags broken"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199804120208.WAA29264@monk.mps.ohio-state.edu>
+ Files: emacs/ptags
+
+ ------ PORTABILITY - WIN32 ------
+
+ Title: "win32 tweaks (signals and crypt support)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199804170505.BAA06413@aatma.engin.umich.edu>
+ Files: perl.h win32/config.bc win32/config.vc win32/config_H.bc
+ win32/config_H.vc win32/win32.c
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Add Social Contract (2nd Draft) as Porting/Contract"
+ From: Russ Allbery <rra@stanford.edu>
+ Msg-ID: <m3btw66n8i.fsf@windlord.Stanford.EDU>
+ Files: Porting/Contract
+
+ Title: "Config: Irix 5 hints"
+ From: kstar@O2.chapin.edu
+ Msg-ID: <199804061712.NAA22823@O2.chapin.edu>
+ Files: hints/irix_5.sh
+
+ Title: "VMS patches to 5.004_03"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01IVYJS0L8D200209B@cor.newman.upenn.edu>
+ Files: vms/vms.c
+
+ Title: "hints/netbsd.sh - enable vfork"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980417110749.19327B-100000@newton.phys>
+ Files: hints/netbsd.sh
+
+ ------ UTILITIES ------
+
+ Title: "support find2perl -follow"
+ From: Billy <wdconsta@cs.adelaide.edu.au>
+ Msg-ID: <Pine.SV4.3.93.980408005903.24081A-100000@ermintrude.teaching.cs.adelaide.edu.au>
+ Files: x2p/find2perl.PL
+ Branch: maint-5.004/perl
+ + Porting/Contract t/op/hashwarn.t
+ ! MANIFEST Todo doio.c emacs/ptags embed.h ext/IO/IO.pm
+ ! ext/Opcode/Opcode.pm ext/Socket/Socket.xs hints/irix_5.sh
+ ! hints/netbsd.sh hv.c lib/Benchmark.pm lib/Carp.pm
+ ! lib/ExtUtils/Install.pm lib/ExtUtils/MM_Unix.pm
+ ! lib/Pod/Html.pm lib/Term/ReadLine.pm lib/chat2.pl opcode.h
+ ! opcode.pl perl.c perl.h pod/perlapio.pod pod/perlcall.pod
+ ! pod/perldebug.pod pod/perldelta.pod pod/perldiag.pod
+ ! pod/perlembed.pod pod/perlfaq2.pod pod/perlfaq3.pod
+ ! pod/perlfaq4.pod pod/perlfaq5.pod pod/perlfaq7.pod
+ ! pod/perlfaq8.pod pod/perlform.pod pod/perlfunc.pod
+ ! pod/perlguts.pod pod/perlhist.pod pod/perlipc.pod
+ ! pod/perllocale.pod pod/perlmodlib.pod pod/perlop.pod
+ ! pod/perlre.pod pod/perlref.pod pod/perlrun.pod
+ ! pod/perlstyle.pod pod/perlsub.pod pod/perlsyn.pod
+ ! pod/perltoot.pod pod/perlvar.pod pod/perlxs.pod pod/pod2man.PL
+ ! pod/roffitall pp.c pp_hot.c pp_sys.c sv.c t/TEST t/op/gv.t
+ ! t/op/substr.t vms/vms.c win32/config.bc win32/config.vc
+ ! win32/config_H.bc win32/config_H.vc win32/win32.c
+ ! x2p/find2perl.PL
+____________________________________________________________________________
+[ 896] By: TimBunce on 1998/04/22 11:49:24
+ Log: Assorted patches:
+
+ ------ CORE LANGUAGE ------
+
+ Title: "Additional regex-cache patch"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Msg-ID: <19980305104831.38100@cyprus>
+ Files: pp_ctl.c
+
+ Title: "Conservative C<*x = undef> patch"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Msg-ID: <19980310163310.48509@cyprus>
+ Files: pod/perldiag.pod pod/perlfunc.pod pp.c sv.c t/op/gv.t
+
+ Title: "Consider @ARGV to be plain files if inplace (-i)"
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Msg-ID: <199802042106.QAA04082@nielsenmedia.com>
+ Files: doio.c
+
+ Title: "Fix semctl for Linux, Sun and SVR4"
+ From: Graham Barr <gbarr@ti.com>, lvirden@cas.org (Larry W. Virden, x2487)
+ Msg-ID: <3484247D.BB036D39@ti.com>, <9712021313.AA11495@cas.org>
+ Files: doio.c
+
+ Title: "C<dSP> entails using C<SP>, not C<sp>"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199803070149.UAA12217@aatma.engin.umich.edu>
+ Files: pod/perlcall.pod pod/perlembed.pod pod/perlguts.pod pod/perlxs.pod
+ doio.c doop.c ext/DB_File/DB_File.xs
+ ext/DynaLoader/dl_dld.xs ext/Opcode/Opcode.xs
+ ext/POSIX/POSIX.xs ext/Socket/Socket.xs gv.c
+ lib/ExtUtils/typemap mg.c os2/OS2/REXX/REXX.xs
+ win32/win32.c
+
+ Title: "Make autouse -w-safe"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199803030236.VAA13244@monk.mps.ohio-state.edu>
+ Files: lib/autouse.pm op.c sv.c
+
+ Title: "Misleading error on close of unopened handle"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0y4R07-0003PH-00@ursa.cus.cam.ac.uk>
+ Files: doio.c
+
+ Title: "Confusing error from perl -e "x'""
+ From: Hans Mulder <hansmu@xs4all.nl>
+ Msg-ID: <1998Mar25.174320.2866352@cor.newman.upenn.edu>
+ Files: toke.c
+
+ Title: "Add HAS_GNULIBC define"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980305115202.9180K-100000@newton.phys>
+ Files: config_H config_h.SH
+
+ Title: "h_errno might not be an int"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980325165059.22255D-100000@newton.phys>
+ Files: pp_sys.c
+
+ Title: "Revised taint hole closer", "Revised taint hole closer"
+ From: Chip Salzenberg <chip@atlantic.net>, Ilya Zakharevich
+ <ilya@math.ohio-state.edu>
+ Msg-ID: <19980310222127.09350@cyprus>,
+ <199803110554.AAA29157@monk.mps.ohio-state.edu>
+ Files: doio.c
+
+ Title: "SEGV compiling localised lexical in perl5.004_05t1"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, h.sanden@elsevier.nl (Hugo
+ van der Sanden)
+ Msg-ID: <199803171530.QAA24053@dorlas.elsevier.nl>,
+ <199803171727.MAA05234@aatma.engin.umich.edu>
+ Files: op.c t/op/misc.t
+
+ Title: "Stale SP in pp_substr"
+ From: Stephen McCamant <alias@mcs.com>
+ Msg-ID: <m0yFsTS-000EZpC@alias-2.pr.mcs.net>
+ Files: pp.c
+
+ Title: "Statement unlikely to be reached warning"
+ From: Hans Mulder <hansm@icgned.nl>
+ Msg-ID: <1997Dec24.171511.2683516@cor.newman>
+ Files: op.c
+
+ Title: "Tainting propagates from nowhere"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199803140411.XAA09343@aatma.engin.umich.edu>
+ Files: pp.c
+
+ Title: "two trivial tweaks to 5.004m5t1"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199803060553.AAA28461@aatma.engin.umich.edu>
+ Files: proto.h win32/Makefile
+
+ Title: "unpacking negatives on Alpha"
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9710201503.AA24797@o09.xray.mpe.mpg.de>
+ Files: pp.c t/op/pack.t
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "Cwd.pm: abs_path() and fast_abs_path() plus code merge"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <3482F365.4A0486BA@ti.com>
+ Files: lib/Cwd.pm
+
+ Title: "Math/BigInt.pm, fixed use of undefined value."
+ From: abigail@fnx.com
+ Msg-ID: <19980313052452.27365.qmail@betelgeuse.wayne.fnx.com>
+ Files: lib/Math/BigInt.pm
+
+ Title: "File::Find rewrite"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199803052344.SAA01008@monk.mps.ohio-state.edu>
+ Files: lib/File/Find.pm
+
+ Title: "efficient version of strict.pm"
+ From: koenig@anna.mind.de (Andreas J. Koenig)
+ Msg-ID: <sfcpvonhdnc.fsf@anna.in-berlin.de>
+ Files: lib/strict.pm
+
+ Title: "Socket occasional SEGV in pack_sockaddr_un"
+ From: Trevor Blackwell <tlb@viaweb.com>
+ Msg-ID: <199710281804.NAA09632@wagg.viaweb.com>
+ Files: ext/Socket/Socket.xs
+
+ Title: "Warning on mis-use of 'use lib'"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Tom Phoenix
+ <rootbeer@teleport.com>, chip@atlantic.net
+ Msg-ID: <199801270435.XAA14147@cyprus.atlantic.net>,
+ <E0xx9x4-0006jc-00@ursa.cus.cam.ac.uk>,
+ <Pine.GSO.3.96.980126192445.22284N-100000@user2.teleport.com>
+ Files: lib/lib.pm
+
+ Title: "bug in Class::Struct"
+ From: Tom Christiansen <tchrist@toy.perl.com>
+ Msg-ID: <199803290814.KAA05699@toy.perl.com>
+ Files: lib/Class/Struct.pm
+
+ Title: "Allow POSIX to export nice()"
+ From: bkeelerx@iwa.dp.intel.com (Bruce J. Keeler)
+ Msg-ID: <eclg1kf5yf0.fsf@ws010.dp.intel.com>
+ Files: ext/POSIX/POSIX.pm
+
+ Title: "'use Env' on WinNT/95 fails"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199803280511.AAA15933@aatma.engin.umich.edu>
+ Files: lib/Env.pm
+
+ ------ OTHER CHANGES ------
+
+ Title: "mv-if-diff"
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Msg-ID: <14572.9803271806@tempest.cise.npl.co.uk>
+ Files: mv-if-diff
+
+ ------ PORTABILITY - WIN32 ------
+
+ Title: "fix various problems with backticks on win32"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199803070705.CAA15945@aatma.engin.umich.edu>
+ Files: win32/config_h.PL win32/win32.c
+
+ ------ TESTS ------
+
+ Title: "Fix bug in locale.t"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199801042148.XAA08599@alpha.hut.fi>
+ Files: t/pragma/locale.t
+ Branch: maint-5.004/perl
+ ! config_H config_h.SH doio.c doop.c ext/DB_File/DB_File.xs
+ ! ext/DynaLoader/dl_dld.xs ext/Opcode/Opcode.xs
+ ! ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs ext/Socket/Socket.xs
+ ! gv.c lib/Class/Struct.pm lib/Cwd.pm lib/Env.pm
+ ! lib/ExtUtils/typemap lib/File/Find.pm lib/Math/BigInt.pm
+ ! lib/autouse.pm lib/lib.pm lib/strict.pm mg.c mv-if-diff op.c
+ ! os2/OS2/REXX/REXX.xs pod/perlcall.pod pod/perldiag.pod
+ ! pod/perlembed.pod pod/perlfunc.pod pod/perlguts.pod
+ ! pod/perlxs.pod pp.c pp_ctl.c pp_sys.c proto.h sv.c t/op/gv.t
+ ! t/op/misc.t t/op/pack.t t/pragma/locale.t toke.c
+ ! win32/Makefile win32/config_h.PL win32/win32.c
+____________________________________________________________________________
+[ 895] By: gsar on 1998/04/22 03:13:19
+ Log: intern -> sys_intern
+ Branch: win32/perl
+ ! embedvar.h interp.sym intrpvar.h win32/win32.h
+____________________________________________________________________________
+[ 894] By: gsar on 1998/04/22 02:42:20
+ Log: hand-applied patch along with small tweaks
+ Message-Id: <35400e2a.13538517@smtp1.ibm.net>
+ Date: Tue, 21 Apr 1998 23:31:06 +0200
+ From: jan.dubois@ibm.net (Jan Dubois)
+ Subject: Re: Per-Interpreter variables for win32.c
+ Branch: win32/perl
+ ! embedvar.h interp.sym intrpvar.h perl.c perl.h proto.h
+ ! win32/makedef.pl win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 893] By: gsar on 1998/04/21 03:42:21
+ Log: add AS patch#17
+ Branch: asperl
+ + win32/GenCAPI.pl
+ ! MANIFEST XSUB.h cv.h ipstdio.h lib/ExtUtils/MM_Unix.pm
+ ! lib/ExtUtils/MM_Win32.pm lib/ExtUtils/MakeMaker.pm
+ ! lib/ExtUtils/Mksymlists.pm lib/ExtUtils/xsubpp op.c perl.h
+ ! pp_ctl.c pp_hot.c proto.h sv.h thread.h win32/Makefile
+ ! win32/dl_win32.xs win32/makefile.mk win32/runperl.c
+ ! win32/win32.c
+____________________________________________________________________________
+[ 892] By: gsar on 1998/04/20 20:51:50
+ Log: add AS patch#16
+ Branch: asperl
+ ! globals.c ipdir.h perl.h perlvars.h regcomp.h win32/Makefile
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 891] By: gsar on 1998/04/19 23:50:34
+ Log: tweak doc for C<do FILENAME>
+ Branch: win32/perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 890] By: gsar on 1998/04/19 01:08:11
+ Log: use a pidtable that grows dynamically for popen()
+ Message-Id: <3539f434.44835409@smtp1.ibm.net>
+ Date: Sat, 18 Apr 1998 21:01:27 +0200
+ From: jan.dubois@ibm.net (Jan Dubois)
+ Subject: Re: [PATCH] for bug in 5.004_64 when compiled with MSC++ 4.2
+ Branch: win32/perl
+ ! win32/win32.c
+____________________________________________________________________________
+[ 889] By: gsar on 1998/04/17 02:13:58
+ Log: support POSIX, enable more locale tests
+ Branch: win32/perl
+ ! ext/POSIX/Makefile.PL ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs
+ ! t/lib/posix.t t/pragma/locale.t win32/Makefile
+ ! win32/makedef.pl win32/makefile.mk
+____________________________________________________________________________
+[ 888] By: mbeattie on 1998/04/14 16:22:51
+ Log: CC did "<<" instead of ">>" for right-shift on ints.
+ Branch: perl
+ ! ext/B/B/CC.pm
+____________________________________________________________________________
+[ 887] By: TimBunce on 1998/04/10 17:44:55
+ Log: Assorted patches:
+
+ ------ CORE LANGUAGE ------
+
+ Title: "Re: die exits with 0"
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Files: perl.c t/op/die_exit.t
+
+ Title: "More toke.c commentary; fix oddity"
+ From: h.sanden@elsevier.nl (Hugo van der Sanden)
+ Msg-ID: <199803251022.LAA01308@dorlas.elsevier.nl>
+ Files: toke.c
+
+ Title: "for semctl on solaris"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <34624B80.C014E841@ti.com>
+ Files: doio.c t/op/ipcmsg.t t/op/ipcsem.t
+
+ ------ DOCUMENTATION ------
+
+ Title: "Add more 'see also's to perlre.pod.", "Perl regexp /g modifier bug"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>, epeschko@den-mdev1 (Ed
+ Peschko), pjr@watcher.telstra.com.au (Peter Richardson)
+ Msg-ID: <199803050000.LAA11476@watcher.telecom.com.au>,
+ <199803050231.VAA19128@monk.mps.ohio-state.edu>,
+ <199803050605.XAA09785@den-mdev1.co.csgsystems.com>
+ Files: pod/perlre.pod
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "BigFloat - small neagtive numbers cause panic"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199711201325.NAA09732@crypt.compulink.co.uk>
+ Files: lib/Math/BigFloat.pm
+
+ Title: "Update Getopt::Long to 2.16"
+ From: JVromans@Squirrel.nl (Johan Vromans), Johan Vromans
+ <jvromans@squirrel.nl>
+ Msg-ID: <13571.48089.726787.147769@plume.nl.compuware.com>,
+ <13572.6847.863219.973795@phoenix.squirrel.nl>
+ Files: lib/Getopt/Long.pm
+
+ Title: "New Text::ParseWords"
+ From: pomeranz@netcom.com (Hal Pomeranz)
+ Msg-ID: <199710162118.OAA06275@netcom7.netcom.com>
+ Files: lib/Text/ParseWords.pm t/lib/parsewords.t
+
+ Title: "Fixed Text/Wrap.pm bugs (2)"
+ From: Jacqui Caren <Jacqui.Caren@ig.co.uk>
+ Msg-ID: <199709291548.QAA08645@toad.ig.co.uk>
+ Files: lib/Text/Wrap.pm
+
+ Title: "Very *evil* File::CheckTree behavior! (now uses warn/die not
+ print/exit)"
+ From: Eryq <eryq@zeegee.com>, Randal Schwartz <merlyn@stonehenge.com>
+ Msg-ID: <34B542FD.190A@zeegee.com>, <8cen2i9k6f.fsf@gadget.cscaper.com>
+ Files: lib/File/CheckTree.pm
+
+ ------ OTHER CHANGES ------
+
+ Title: "Add ./emacs/ptags"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199803150847.DAA08196@monk.mps.ohio-state.edu>
+ Files: emacs/ptags
+
+ ------ TESTS ------
+
+ Title: "Avoid stat test failure from build in /tmp (tmpfs)", "Build in /tmp"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, Greg Bacon
+ <gbacon@adtran.com>, pudge@pobox.com (Chris Nandor)
+ Msg-ID: <199710171616.LAA13435@crp-201.adtran.com>,
+ <Pine.SUN.3.96.971017171023.2349A-100000@newton.phys>,
+ <v02130515b06be80f1486@[205.228.240.16]>
+ Files: t/op/stat.t
+
+ Title: "for failure with lib/timelocal"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, jan.dubois@ibm.net (Jan Dubois)
+ Msg-ID: <34c78f61.2529827@smtp1.ibm.net>,
+ <E0xvdfI-00057d-00@ursa.cus.cam.ac.uk>
+ Files: t/lib/timelocal.t
+
+ Title: "Make "localhost" related failures more clear"
+ From: Paul Hoffman <phoffman@proper.com>
+ Msg-ID: <199801201859.KAA05686@mail.proper.com>
+ Files: t/lib/io_sock.t t/lib/io_udp.t
+
+ ------ UTILITIES ------
+
+ Title: "Let h2xs read multiple header files"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>, Benjamin Sugars
+ <bsugars@canoe.ca>
+ Msg-ID: <Pine.SOL.3.95.980310091946.25236A-100000@interact>,
+ <Pine.SUN.3.96.980310145455.638A-100000@newton.phys>
+ Files: utils/h2xs.PL
+ Branch: maint-5.004/perl
+ + emacs/ptags t/op/die_exit.t t/op/ipcmsg.t t/op/ipcsem.t
+ ! MANIFEST doio.c lib/File/CheckTree.pm lib/Getopt/Long.pm
+ ! lib/Math/BigFloat.pm lib/Text/ParseWords.pm lib/Text/Wrap.pm
+ ! lib/base.pm perl.c pod/perlre.pod t/lib/io_sock.t
+ ! t/lib/io_udp.t t/lib/parsewords.t t/lib/timelocal.t
+ ! t/op/stat.t toke.c utils/h2xs.PL vms/perly_h.vms
+____________________________________________________________________________
+[ 886] By: TimBunce on 1998/04/10 14:35:34
+ Log: Changes relating primarily to portability.
+
+ ------ CORE LANGUAGE ------
+
+ Title: "5.004_55: Another round of OS/2 patches"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199803050945.EAA20153@monk.mps.ohio-state.edu>
+ Files: hints/os2.sh pod/perlguts.pod cop.h perl.h proto.h README.os2
+ global.sym lib/ExtUtils/MM_OS2.pm lib/File/Path.pm op.c
+ os2/Changes os2/Makefile.SHs os2/os2.c os2/perl2cmd.pl
+ perl.c pod/pod2man.PL pp_ctl.c pp_hot.c pp_sys.c
+ t/lib/filecopy.t util.c utils/perldoc.PL
+
+ Title: "VMS: chdir() with empty arg list"
+ From: lane@duphy4.drexel.edu (Charles Lane)
+ Msg-ID: <980317125556.222041c7@DUPHY4.Physics.Drexel.Edu>
+ Files: pp_sys.c
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "ExtUtils/MM_Unix.pm changed to use ld -rpath on IRIX"
+ From: "W. Phillip Moore" <wpm@ms.com>
+ Msg-ID: <199712011738.MAA21139@zappa.morgan.com>
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "[Linux] POSIX::_[PS]C_.+ bug (add HINT_SC_EXIST)"
+ From: Yutaka OIWA <oiwa@is.s.u-tokyo.ac.jp>
+ Msg-ID: <199712251923.EAA08260@tjms1f.is.s.u-tokyo.ac.jp>
+ Files: ext/POSIX/hints/linux.pl ext/POSIX/POSIX.xs
+
+ Title: "5.004_04-m1] Use HAS_GNULIBC in POSIX.xs"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980305115517.9180L-100000@newton.phys>
+ Files: ext/POSIX/POSIX.xs
+
+ Title: ""ODBM_File.c", line 275: NULL undefined"
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9803091310.AA23264@claudius.bfsec.bt.co.uk>
+ Files: ext/ODBM_File/ODBM_File.xs
+
+ ------ OTHER CHANGES ------
+ Files:
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "5.004_04 QNX getcwd"
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Msg-ID: <199802121838.NAA20452@dolores.harvard.edu>,
+ <199803061511.KAA22346@bottesini.harvard.edu>
+ Files: hints/qnx.sh lib/Cwd.pm t/op/magic.t
+
+ Title: "hints/netbsd.sh d_setrgid d_setruid"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199802281435.QAA10866@alpha.hut.fi>
+ Files: hints/netbsd.sh
+
+ Title: "osname=unixware, osvers=2.03, archname=i386-unixware
+ d_casti32=undef"
+ From: Tom Hughes <tom@compton.demon.co.uk>
+ Msg-ID: <465398da47%tom@compton.demon.co.uk>
+ Files: hints/svr4.sh
+
+ Title: "hints/bsdos.sh patch for BSDI 3.1"
+ From: Jan-Pieter Cornet <johnpc@xs4all.nl>
+ Msg-ID: <6fbip6$3cp$1@xs1.xs4all.nl>
+ Files: hints/bsdos.sh
+
+ Title: "Remove BIND_NOSTART from DynaLoader for HP"
+ From: Keong Lim <Keong.Lim@sr.com.au>
+ Msg-ID: <01BD1D03.53B65E90@sieplan2.sr.com.au>
+ Files: ext/DynaLoader/dl_hpux.xs
+
+ Title: "Building Perl on AIX 4+ with shared libraries and dynamic loading"
+ From: Juan Gallego <Little.Boss@physics.mcgill.ca>
+ Msg-ID: <Pine.SGI.3.91.971022084517.17052F-100000@nazgul.physics.mcgill.ca>
+ Files: hints/aix.sh
+
+ Title: "alpha-dec_osf 5.0"
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+ Msg-ID: <199712232305.SAA08359@Orb.Nashua.NH.US>
+ Files: hints/dec_osf.sh
+
+ Title: "Off-by-one error with OS2::PrfDB"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710170920.FAA00390@monk.mps.ohio-state.edu>
+ Files: os2/OS2/PrfDB/PrfDB.xs
+
+ Title: "5.004_04-m1] Allow overrides in hints/openbsd.sh"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980305115956.9180N-100000@newton.phys>
+ Files: hints/openbsd.sh
+
+ Title: "5.004_04-m1] Linux shouldn't use -lnet"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980305115843.9180M-100000@newton.phys>
+ Files: hints/linux.sh
+
+ Title: "5.004_(04|63)] Close VMS security hole"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01IV6LRJCSSC0009C4@cor.newman.upenn.edu>
+ Files: vms/vms.c
+
+ Title: "Re: Perl online documentation on OpenVMS"
+ From: pvhp@forte.com (Peter Prymmer)
+ Msg-ID: <9803192143.AA28120@forte.com>
+ Files: README.vms
+
+ Title: "Perl5.004_04m4t4 *almost* makes it for VMS", "Updated
+ vms/perly_c.vms and vms/perly_h.vms"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, Dan Sugalski
+ <sugalskd@osshe.edu>, larry@wall.org (Larry Wall)
+ Msg-ID: <199710151650.JAA29185@wall.org>,
+ <3.0.3.32.19971014150404.02fdef78@osshe.edu>,
+ <Pine.SUN.3.96.971015121704.28456F-100000@newton.phys>
+ Files: vms/perly_c.vms
+
+ Title: "Updated, non-wordwrapped, patch to README.VMS"
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Msg-ID: <3.0.5.32.19980213133828.0092c870@osshe.edu>
+ Files: README.vms
+
+ Title: "VMS patches to 5.004_03 (excluding installperl and timelocal.t)"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01INZT9G2LZS0006YW@cor.newman.upenn.edu>
+ Files: lib/File/Basename.pm lib/File/Path.pm vms/config.vms vms/descrip.mms
+ vms/genconfig.pl vms/test.com vms/vms.c vms/ext/Filespec.pm
+ vms/ext/filespec.t
+
+ Title: "Re: VMSperl crashes on -Mblib argument"
+ From: bailey@newman.upenn.edu (Charles Bailey)
+ Msg-ID: <1997Dec10.004439.2635060@cor.newman>
+ Files: lib/blib.pm vms/vms.c
+
+ Title: "hints/linux.sh (MkLinux / PPC)"
+ From: pudge@pobox.com (Chris Nandor)
+ Msg-ID: <v0213050cb06c19682a25@[205.228.240.28]>
+ Files: hints/linux.sh
+
+ Title: "hpux.sh hints file clarification suggestion"
+ From: root@qad.com
+ Msg-ID: <199802192351.QAA09096@jhereg.perl.com>
+ Files: hints/hpux.sh
+
+ Title: "new hints/solaris_2.sh"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0xw80h-0005SV-00@ursa.cus.cam.ac.uk>
+ Files: hints/solaris_2.sh
+ Branch: maint-5.004/perl
+ ! README.os2 README.vms cop.h ext/DynaLoader/dl_hpux.xs
+ ! ext/ODBM_File/ODBM_File.xs ext/POSIX/POSIX.xs
+ ! ext/POSIX/hints/linux.pl global.sym hints/aix.sh
+ ! hints/bsdos.sh hints/dec_osf.sh hints/hpux.sh hints/linux.sh
+ ! hints/netbsd.sh hints/openbsd.sh hints/os2.sh hints/qnx.sh
+ ! hints/solaris_2.sh hints/svr4.sh lib/Cwd.pm
+ ! lib/ExtUtils/MM_OS2.pm lib/ExtUtils/MM_Unix.pm
+ ! lib/File/Basename.pm lib/File/Path.pm lib/blib.pm op.c
+ ! os2/Changes os2/Makefile.SHs os2/OS2/PrfDB/PrfDB.xs os2/os2.c
+ ! os2/perl2cmd.pl perl.c perl.h pod/perlguts.pod pod/pod2man.PL
+ ! pp_ctl.c pp_hot.c pp_sys.c proto.h t/lib/filecopy.t
+ ! t/op/magic.t util.c utils/perldoc.PL vms/config.vms
+ ! vms/descrip.mms vms/ext/Filespec.pm vms/ext/filespec.t
+ ! vms/genconfig.pl vms/perly_c.vms vms/perly_h.vms vms/test.com
+ ! vms/vms.c
+____________________________________________________________________________
+[ 885] By: gsar on 1998/04/08 01:14:29
+ Log: small tweaks to make it compile (doesn't run)
+ Branch: asperl
+ ! objpp.h win32/Makefile win32/config.bc win32/config.gc
+ ! win32/config.vc win32/makefile.mk
+____________________________________________________________________________
+[ 884] By: gsar on 1998/04/08 00:14:13
+ Log: integrate mainline changes
+ Branch: asperl
+ +> Changes5.004 ext/Thread/Thread/Signal.pm
+ +> lib/ExtUtils/Installed.pm lib/ExtUtils/Packlist.pm
+ +> lib/ExtUtils/inst t/op/hashwarn.t
+ ! ObjXSub.h embedvar.h interp.sym intrpvar.h objpp.h
+ !> (integrate 127 files)
+____________________________________________________________________________
+[ 883] By: gsar on 1998/04/06 20:21:20
+ Log: make old DomainName() implementation the default (so Win95
+ is happy)
+ Branch: win32/perl
+ ! win32/win32.c
+____________________________________________________________________________
+[ 882] By: gsar on 1998/04/05 23:32:33
+ Log: fix memory leaks in offer_nice_chunk()
+ Branch: win32/perl
+ ! perl.h sv.c
+____________________________________________________________________________
+[ 881] By: gsar on 1998/04/04 23:11:52
+ Log: set up PUSHSTACK for __DIE__ and __WARN__ hooks also
+ Branch: win32/perl
+ ! cop.h util.c
+____________________________________________________________________________
+[ 880] By: gsar on 1998/04/04 22:35:54
+ Log: fix refcounting of GvSTASH() when glob becomes nought
+ (this takes care of the "unbalanced strtab refcount" problem)
+ Branch: win32/perl
+ ! sv.c
+____________________________________________________________________________
+[ 879] By: gsar on 1998/04/04 21:16:17
+ Log: change 866 was incomplete
+ Branch: win32/perl
+ ! hv.c
+____________________________________________________________________________
+[ 878] By: gsar on 1998/04/04 20:31:56
+ Log: fixes for various noises under PERL_DESTRUCT_LEVEL
+ Branch: win32/perl
+ ! cop.h perl.c pp_ctl.c
+____________________________________________________________________________
+[ 877] By: gsar on 1998/04/04 17:55:30
+ Log: integrate mainline
+ Branch: win32/perl
+ +> Changes5.004
+ !> Changes MANIFEST sv.c t/op/misc.t
+____________________________________________________________________________
+[ 876] By: gsar on 1998/04/04 17:26:32
+ Log: remove __declspec kludge in sdbm.h in favor of setting a
+ flag for static symbols
+ Branch: win32/perl
+ ! EXTERN.h ext/SDBM_File/sdbm/Makefile.PL
+ ! ext/SDBM_File/sdbm/sdbm.h
+____________________________________________________________________________
+[ 875] By: gsar on 1998/04/04 01:11:57
+ Log: fix order of init
+ Message-Id: <3.0.5.32.19980403135815.009d2440@osshe.edu>
+ Date: Fri, 03 Apr 1998 13:58:15 PST
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Subject: [PATCH 5.004_64] perl dies in perl_construct when compiled
+ with MULTIPLICITY
+ Branch: win32/perl
+ ! perl.c
+____________________________________________________________________________
+[ 874] By: gsar on 1998/04/04 00:34:59
+ Log: the EXTCONST in sdbm.h breaks SDBM on Borland, since
+ the declared symbol is not in a DLL (so kludge it)
+ Branch: win32/perl
+ ! ext/SDBM_File/sdbm/sdbm.h
+____________________________________________________________________________
+[ 873] By: TimBunce on 1998/04/03 22:17:40
+ Log: Title: "FileHandle Documentation patch"
+ From: "Darren/Torin/Who Ever..." <torin@daft.com>
+ Msg-ID: <87emzqo49g.fsf@perv.daft.com>
+ Files: lib/FileHandle.pm
+ Branch: maint-5.004/perl
+ ! lib/FileHandle.pm
+____________________________________________________________________________
+[ 872] By: TimBunce on 1998/04/03 22:01:03
+ Log: Documentation and documentation related patches:
+
+ ------ BUILD PROCESS ------
+
+ Title: "Docs re /usr/bin/perl quasi-standard location"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.971117080737.12318C-100000@usertest.teleport.com>
+ Files: INSTALL pod/perlrun.pod
+
+ ------ DOCUMENTATION ------
+
+ Title: "/RFC|RFC-1305/ non-greedy"
+ From: Jan-Pieter Cornet <johnpc@xs4all.nl>
+ Msg-ID: <6epo02$c4r$1@xs1.xs4all.nl>
+ Files: pod/perlre.pod
+
+ Title: "5.004_04: perlhist.pod, buildtoc, perltoc.pod"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199802191543.RAA29231@alpha.hut.fi>
+ Files: pod/perl.pod pod/perlhist.pod pod/perltoc.pod pod/buildtoc
+
+ Title: "5.004_04: pod/perlfunc.pod: i18n example for localtime()"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199711141555.RAA18875@alpha.hut.fi>
+ Files: pod/perlfunc.pod
+
+ Title: "typo-fix and suggestion for perlguts.pod"
+ From: h.sanden@elsevier.nl (Hugo van der Sanden)
+ Msg-ID: <199803051543.QAA03097@dorlas.elsevier.nl>
+ Files: pod/perlguts.pod
+
+ Title: "perlfunc/syscall curiosity"
+ From: Roderick Schertler <roderick@argon.org>, Tkil
+ <tkil@reptile.scrye.com>
+ Msg-ID: <199711302259.PAA02134@reptile.scrye.com>,
+ <pziut8snva.fsf@eeyore.ibcinc.com>
+ Files: pod/perlfunc.pod
+
+ Title: "Document sprintf %#x behaviour for zero value"
+ From: ilya@math.ohio-state.edu (Ilya Zakharevich)
+ Msg-ID: <1997Nov5.185959.2539604@cor.newman>
+ Files: pod/perlfunc.pod
+
+ Title: "NUL termination (was Re: STOP THE PRESSES)"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0xsn5M-0002gw-00@ursa.cus.cam.ac.uk>
+ Files: pod/perlguts.pod
+
+ Title: "Typo fix."
+ From: abigail@fnx.com
+ Msg-ID: <19971101120114.1030.qmail@betelgeuse.wayne.fnx.com>
+ Files: pod/perlop.pod pod/perlvar.pod
+
+ Title: "5.004_63 perlrun.pod: _DEBUG_MSTATS"
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9803181940.AA22587@o09.xray.mpe.mpg.de>
+ Files: pod/perlrun.pod
+
+ Title: "Re: Conservative C<*x = undef> patch"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0yCjHT-0005Dt-00@ursa.cus.cam.ac.uk>
+ Files: pod/perltrap.pod
+
+ Title: "perlfunc.pod for flock()"
+ From: "Jeremy D. Zawodny" <jzawodn@wcnet.org>
+ Msg-ID: <3.0.5.32.19971118203119.00a723e0@woody.wcnet.org>
+ Files: pod/perlfunc.pod
+
+ Title: "buglet: 'perltoc' not mentioned in perl.pod"
+ From: Tkil <tkil@scrye.com>
+ Msg-ID: <19971127035036.17668.qmail@scrye.com>
+ Files: pod/perl.pod
+
+ Title: "for() and map() peculiarity"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0y4YAa-0003Qu-00@ursa.cus.cam.ac.uk>
+ Files: pod/perlsyn.pod
+
+ Title: "Re: new text for perlsec"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980328100418.22321T-100000@user2.teleport.com>
+ Files: pod/perlsec.pod
+
+ Title: "perldsc's debugger x command"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <10669.878352893@eeyore.ibcinc.com>
+ Files: pod/perldsc.pod
+
+ Title: "perlre.pod"
+ From: Ted Ashton <ashted@southern.edu>
+ Msg-ID: <199802271501.KAA09279@ns.southern.edu>
+ Files: pod/perlre.pod
+
+ Title: "Re: printf and $\", "printf and $\"
+ From: Roderick Schertler <roderick@argon.org>, Tom Phoenix
+ <rootbeer@teleport.com>, nag <nick@flirble.org>
+ Msg-ID: <199711141918.TAA08096@flirble.org>,
+ <Pine.GSO.3.96.971117085421.12318J-100000@usertest.teleport
+ .com>, <pzyb2ncr42.fsf@eeyore.ibcinc.com>
+ Files: pod/perlfunc.pod
+
+ Title: "recv() typo"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <12064.877012073@eeyore.ibcinc.com>
+ Files: pod/perlfunc.pod
+
+ Title: "truncate return value"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <5490.878337883@eeyore.ibcinc.com>
+ Files: pod/perlfunc.pod
+
+ Title: "update to perlbook.pod"
+ From: "Nathan V. Patwardhan" <nvp@mediaone.net>, Randal Schwartz
+ <merlyn@stonehenge.com>, Stephen Potter
+ <spp@psasolar.colltech.com>, Tom Phoenix
+ <rootbeer@teleport.com>
+ Msg-ID: <199803241354.HAA23938@psasolar.psa.pencom.com>,
+ <199803241441.OAA01261@mediaone.net>,
+ <8clnu0i05k.fsf@gadget.cscaper.com>,
+ <Pine.GSO.3.96.980324111957.15753C-100000@user1.teleport.com>
+ Files: pod/perlbook.pod
+
+ Title: "utime documentation"
+ From: "Brandon S. Allbery KF8NH" <bsa@kf8nh.apk.net>, "M.J.T. Guy"
+ <mjtg@cus.cam.ac.uk>
+ Msg-ID: <199802180256.VAA11369@speaker.kf8nh.apk.net>,
+ <E0y4qd6-0000P6-00@ursa.cus.cam.ac.uk>
+ Files: pod/perlfunc.pod
+
+ Title: "(well, doc patch) use of // requires successful match"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <pz7mb4bips.fsf@eeyore.ibcinc.com>
+ Files: pod/perlop.pod
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "MakeMaker PM doc patch and a DIR buglet"
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9711101050.AA13868@o09.xray.mpe.mpg.de>
+ Files: lib/ExtUtils/MakeMaker.pm
+
+ Title: "bareword clarification for constant.pm"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <6460.878143077@eeyore.ibcinc.com>
+ Files: lib/constant.pm
+
+ Title: "integer rand - bug or feature?"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <pzhg8lvgta.fsf@eeyore.ibcinc.com>
+ Files: lib/integer.pm
+
+ ------ OTHER CHANGES ------
+
+ Title: "FileHandle Documentation patch"
+ From: "Darren/Torin/Who Ever..." <torin@daft.com>
+ Msg-ID: <87emzqo49g.fsf@perv.daft.com>
+
+ Title: "perl5.004_61 myconfig updates"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980305150629.11530G-100000@newton.phys>
+ Files: myconfig
+
+ Title: "small fixups in pod2latex.PL"
+ From: "Darren/Torin/Who Ever..." <torin@daft.com>
+ Msg-ID: <873eg6o3v2.fsf@perv.daft.com>
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Misc doc fixes for README.VMS"
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Msg-ID: <3.0.5.32.19980121113134.00924a20@osshe.edu>
+ Files: README.vms
+
+ Title: "moved DynaLib"
+ From: John Tobey <jtobey@channel1.com>
+ Msg-ID: <199710182332.XAA21630@remote212>
+ Files: ext/DynaLoader/DynaLoader.pm.PL
+
+ ------ UTILITIES ------
+
+ Title: "Searching for FAQs (patch to perldoc)"
+ From: Piers Cawley <pdcawley@bofh.org.uk>, Russ Allbery <rra@stanford.edu>
+ Msg-ID: <m3d8gsb8uk.fsf@windlord.Stanford.EDU>,
+ <m3iuqkfmiq.fsf@tower.bofh.org.uk>
+ Files: utils/perldoc.PL
+
+ Title: "perldoc"
+ From: Ted Ashton <ashted@southern.edu>
+ Msg-ID: <199802271510.KAA10506@ns.southern.edu>
+ Files: utils/perldoc.PL
+
+ Title: "perldoc -f not using pod2man"
+ From: Russ Allbery <rra@stanford.edu>
+ Msg-ID: <m3hg4f9vyy.fsf@windlord.Stanford.EDU>
+ Files: utils/perldoc.PL
+
+ Title: "perldoc -m should not require pod"
+ From: Robin Houston <robin@nml.guardian.co.uk>
+ Msg-ID: <199803241319.NAA24777@stringfellow.guardian.co.uk>
+ Files: utils/perldoc.PL
+
+ Title: "small fix for perldoc in perl 5.004_04"
+ From: Julian Yip <julian@imoney.com>
+ Msg-ID: <Roam.SIMC.2.0.6.884805579.5280.julian@imoney.com>
+ Files: utils/perldoc.PL
+ Branch: maint-5.004/perl
+ - ext/DynaLoader/DynaLoader.pm
+ ! Changes Configure INSTALL README.vms
+ ! ext/DynaLoader/DynaLoader.pm.PL ext/Socket/Socket.pm
+ ! lib/ExtUtils/MakeMaker.pm lib/Tie/Hash.pm lib/constant.pm
+ ! lib/integer.pm myconfig pod/buildtoc pod/checkpods.PL
+ ! pod/perl.pod pod/perlbook.pod pod/perldelta.pod
+ ! pod/perldiag.pod pod/perldsc.pod pod/perlfunc.pod
+ ! pod/perlguts.pod pod/perlhist.pod pod/perllocale.pod
+ ! pod/perlmod.pod pod/perlop.pod pod/perlre.pod pod/perlrun.pod
+ ! pod/perlsec.pod pod/perlstyle.pod pod/perlsyn.pod
+ ! pod/perltoc.pod pod/perltrap.pod pod/perlvar.pod
+ ! pod/pod2latex.PL toke.c utils/perldoc.PL
+
+----------------
+Version 5.004_64
+----------------
+
+____________________________________________________________________________
+[ 871] By: mbeattie on 1998/04/03 13:38:59
+ Log: Update Changes5.004 and Changes, fix MANIFEST
+ Branch: perl
+ + Changes
+ ! Changes5.004 MANIFEST
+____________________________________________________________________________
+[ 870] By: mbeattie on 1998/04/03 13:36:29
+ Log: Rename Changes to Changes5.004 (via an integrate)
+ Branch: perl
+ +> Changes5.004
+ - Changes
+____________________________________________________________________________
+[ 869] By: mbeattie on 1998/04/03 11:53:00
+ Log: Subject: [PATCH] Perl 5.005b1t2/perl5.004_63 (resend)
+ Date: Wed, 18 Mar 1998 01:24:20 +0100 (MET)
+ From: Jan-Pieter Cornet <johnpc@xs4all.net>
+ Branch: perl
+ ! sv.c t/op/misc.t
+____________________________________________________________________________
+[ 868] By: mbeattie on 1998/04/03 11:16:26
+ Log: Integrate win32 branch into mainline
+ Branch: perl
+ !> (integrate 31 files)
+____________________________________________________________________________
+[ 867] By: gsar on 1998/04/03 08:47:55
+ Log: config.* fixes
+ Branch: win32/perl
+ ! win32/Makefile win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 866] By: gsar on 1998/04/03 07:22:50
+ Log: fixup hv_free_ent() to not fail on null HeVAL()
+ Branch: win32/perl
+ ! hv.c perl.c
+____________________________________________________________________________
+[ 865] By: gsar on 1998/04/03 07:06:12
+ Log: integrate mainline
+ Branch: win32/perl
+ +> ext/Thread/Thread/Signal.pm t/op/hashwarn.t
+ !> (integrate 71 files)
+____________________________________________________________________________
+[ 864] By: gsar on 1998/04/03 06:59:37
+ Log: implement stack-of-stacks so that magic invocations don't
+ invalidate local stack pointer
+ Branch: win32/perl
+ ! av.c cop.h deb.c embed.h embedvar.h global.sym gv.c interp.sym
+ ! intrpvar.h mg.c op.c perl.c pp.h pp_ctl.c pp_sys.c proto.h
+ ! scope.c sv.c t/op/runlevel.t thrdvar.h util.c
+____________________________________________________________________________
+[ 863] By: gsar on 1998/04/03 01:26:09
+ Log: add AS patch#15
+ Branch: asperl
+ ! ipenv.h lib/ExtUtils/MM_Unix.pm perl.c perlenv.h
+ ! win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/config_h.PL win32/config_sh.PL win32/runperl.c
+ ! win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 862] By: mbeattie on 1998/04/02 17:08:43
+ Log: Subject: [PATCH for 5.004_63] Config_63-04-05.diff
+ Date: Thu, 2 Apr 1998 11:56:51 -0500 (EST)
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Branch: perl
+ ! Configure ext/Socket/Socket.xs myconfig
+____________________________________________________________________________
+[ 861] By: mbeattie on 1998/04/02 16:32:53
+ Log: Change 854 added { NULL, 0 } to sdbm.h which needs to be {0, 0}
+ since appropriate headers aren't included.
+ Branch: perl
+ ! ext/SDBM_File/sdbm/sdbm.h
+____________________________________________________________________________
+[ 860] By: mbeattie on 1998/04/02 16:17:11
+ Log: Bumped patchlevel.h to 64
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 859] By: mbeattie on 1998/04/02 16:16:26
+ Log: Subject: Re: [PATCH] 5.004_63: UNICOS 9
+ Date: Fri, 20 Mar 1998 19:39:28 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! hints/unicos.sh regcomp.h
+____________________________________________________________________________
+[ 858] By: mbeattie on 1998/04/02 16:13:24
+ Log: Subject: [PATCH] Re: Odd number of elements in hash list.
+ Date: Sat, 28 Mar 1998 15:26:46 -0800 (PST)
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Branch: perl
+ + t/op/hashwarn.t
+ ! MANIFEST pod/perldiag.pod pp.c pp_hot.c
+____________________________________________________________________________
+[ 857] By: mbeattie on 1998/04/02 16:08:43
+ Log: Subject: [PATCH 5.004_(04|63)] Close VMS security hole
+ Date: Sat, 28 Mar 1998 02:05:03 -0500 (EST)
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Branch: perl
+ ! vms/vms.c
+____________________________________________________________________________
+[ 856] By: mbeattie on 1998/04/02 16:07:44
+ Log: Subject: [PATCH] mv-if-diff
+ Date: Fri, 27 Mar 98 18:06:11 GMT
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Branch: perl
+ ! mv-if-diff
+____________________________________________________________________________
+[ 855] By: mbeattie on 1998/04/02 16:06:54
+ Log: From: Jan-Pieter Cornet <johnpc@xs4all.net>
+ Subject: Re: [PATCH] [BUG 5.004_63] define/set of PERL_DESTRUCT_LEVEL
+ Date: Fri, 27 Mar 1998 02:11:21 +0100 (MET)
+ Subject: [PATCH] another destruct_level fix
+ Date: Mon, 30 Mar 1998 23:48:12 +0200 (MET DST)
+ Branch: perl
+ ! perl.c sv.c
+____________________________________________________________________________
+[ 854] By: mbeattie on 1998/04/02 16:03:37
+ Log: Subject: Next wave of _63 VMS patches
+ Date: Thu, 26 Mar 1998 15:11:50 -0500 (EST)
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Branch: perl
+ ! EXTERN.h INTERN.h ext/SDBM_File/Makefile.PL
+ ! ext/SDBM_File/sdbm/Makefile.PL ext/SDBM_File/sdbm/dba.c
+ ! ext/SDBM_File/sdbm/dbd.c ext/SDBM_File/sdbm/dbu.c
+ ! ext/SDBM_File/sdbm/hash.c ext/SDBM_File/sdbm/pair.c
+ ! ext/SDBM_File/sdbm/sdbm.c ext/SDBM_File/sdbm/sdbm.h
+ ! ext/Thread/io.t installperl lib/ExtUtils/MM_VMS.pm
+ ! lib/Net/Ping.pm perldir.h perlsdio.h t/lib/english.t
+ ! vms/config.vms vms/descrip.mms vms/ext/Filespec.pm
+ ! vms/ext/Stdio/0README.txt vms/ext/Stdio/Stdio.pm
+ ! vms/ext/Stdio/Stdio.xs vms/ext/Stdio/test.pl
+ ! vms/ext/filespec.t vms/genconfig.pl vms/perly_c.vms vms/vms.c
+ ! vms/vmsish.h
+____________________________________________________________________________
+[ 853] By: mbeattie on 1998/04/02 15:55:46
+ Log: Subject: [PATCH 5.00463] Confusing error from perl -e "x'"
+ Date: Wed, 25 Mar 1998 17:43:17 -0500 (EST)
+ From: Hans Mulder <hansmu@xs4all.nl>
+ Branch: perl
+ ! toke.c
+____________________________________________________________________________
+[ 852] By: mbeattie on 1998/04/02 15:54:24
+ Log: Subject: [PATCH] small fixups in pod2latex.PL
+ Date: 25 Mar 1998 13:30:25 -0800
+ From: "Darren/Torin/Who Ever..." <torin@daft.com>
+ Branch: perl
+ ! pod/pod2latex.PL
+____________________________________________________________________________
+[ 851] By: mbeattie on 1998/04/02 15:50:58
+ Log: Subject: [PATCH] hints/irix_6.sh with GCC
+ Date: Tue, 24 Mar 1998 12:25:10 -0800 (EST)
+ From: kstar@chapin.edu (Kurt D. Starsinic)
+ Branch: perl
+ ! hints/irix_6.sh
+____________________________________________________________________________
+[ 850] By: mbeattie on 1998/04/02 15:45:33
+ Log: Subject: [PATCH] perldoc -m
+ Date: Tue, 24 Mar 1998 13:19:38 GMT
+ From: Robin Houston <robin@nml.guardian.co.uk>
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 849] By: mbeattie on 1998/04/02 15:42:52
+ Log: Subject: [PATCH for 5.004_63] dos-djgpp update
+ Date: Mon, 23 Mar 1998 14:13:46 +0100
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Branch: perl
+ ! djgpp/config.over hints/dos_djgpp.sh
+____________________________________________________________________________
+[ 848] By: mbeattie on 1998/04/02 15:38:19
+ Log: Subject: [PATCH] Stale SP in pp_substr
+ Date: Thu, 19 Mar 1998 21:28:02 -0600 (CST)
+ From: Stephen McCamant <alias@mcs.com>
+ Branch: perl
+ ! pp.c
+____________________________________________________________________________
+[ 847] By: mbeattie on 1998/04/02 15:36:33
+ Log: Add missing export of "nice" to ext/POSIX/POSIX.pm (Phil Tait)
+ Branch: perl
+ ! ext/POSIX/POSIX.pm
+____________________________________________________________________________
+[ 846] By: mbeattie on 1998/04/02 15:34:36
+ Log: Subject: [PATCH] 5.004_63: further -e patching
+ Date: Wed, 18 Mar 1998 23:21:08 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! perl.c pod/perldiag.pod
+____________________________________________________________________________
+[ 845] By: mbeattie on 1998/04/02 15:25:18
+ Log: Andy Dougherty's configuration patches (Config_63-01 up to 04).
+ Branch: perl
+ ! Configure INSTALL Policy_sh.SH Porting/Glossary
+ ! Porting/config.sh Porting/config_H config_h.SH
+ ! ext/POSIX/POSIX.xs handy.h hints/hpux.sh myconfig perlsock.h
+ ! pp.c pp_sys.c regexec.c
+____________________________________________________________________________
+[ 844] By: mbeattie on 1998/04/02 14:28:17
+ Log: Subject: [PATCH 5.004_63] perlrun.pod: PERL_DEBUG_MSTATS
+ Date: Wed, 18 Mar 1998 20:40:19 +0100
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Branch: perl
+ ! pod/perlrun.pod
+____________________________________________________________________________
+[ 843] By: mbeattie on 1998/04/02 14:26:52
+ Log: From: Dan Sugalski <sugalskd@osshe.edu>
+ Subject: 5.004_63 picky compiler fixes [PATCH]
+ Date: Wed, 18 Mar 1998 09:36:32 -0800
+ Subject: [PATCH 5.004_63] Fix function prototype with long doubles
+ Date: Wed, 18 Mar 1998 14:48:19 -0800
+ Branch: perl
+ ! ext/POSIX/POSIX.xs ext/Thread/Thread.xs vms/vms.c
+____________________________________________________________________________
+[ 842] By: mbeattie on 1998/04/02 14:22:41
+ Log: From: Stephen Potter <spp@psasolar.colltech.com>
+ Subject: Re: doc: perlrun typo
+ Date: Wed, 18 Mar 1998 10:06:55 -0600
+ Subject: Re: [PATCH 5.004_63] PerlLIO abstraction cleanup
+ Date: Tue, 24 Mar 1998 21:20:51 -0600
+ Branch: perl
+ ! mg.c perl.c pod/perlrun.pod pp_hot.c pp_sys.c util.c
+____________________________________________________________________________
+[ 841] By: mbeattie on 1998/04/02 14:17:31
+ Log: Subject: [PATCH] Add "Full 64 bit support" to Todo; document Todo in pumpkin.pod
+ Date: Wed, 18 Mar 1998 12:44:58 +0100
+ From: Dominic Dunlop <domo@vo.lu>
+ Branch: perl
+ ! Porting/pumpkin.pod Todo
+____________________________________________________________________________
+[ 840] By: mbeattie on 1998/04/02 14:14:22
+ Log: Subject: [PATCH] Configure hints/ patches
+ Date: Wed, 18 Mar 1998 02:47:38 +0100 (MET)
+ From: Jan-Pieter Cornet <johnpc@xs4all.net>
+ Branch: perl
+ ! hints/linux.sh hints/qnx.sh
+____________________________________________________________________________
+[ 839] By: mbeattie on 1998/04/02 14:13:13
+ Log: Remove duplicate code in cygwin32/perlgcc (Blair Zajac)
+ Branch: perl
+ ! cygwin32/perlgcc
+____________________________________________________________________________
+[ 838] By: gsar on 1998/03/28 05:01:57
+ Log: fix Env.pm to weed out illegal names
+ Branch: win32/perl
+ ! lib/Env.pm
+____________________________________________________________________________
+[ 837] By: gsar on 1998/03/28 04:39:43
+ Log: fix typo in makefile.mk
+ Branch: win32/perl
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 836] By: gsar on 1998/03/23 17:40:15
+ Log: add file: to installhtml URLs
+ Branch: win32/perl
+ ! win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 835] By: mbeattie on 1998/03/18 11:03:11
+ Log: Add Thread::Signal to run signal handlers reliably in a new thread
+ Branch: perl
+ + ext/Thread/Thread/Signal.pm
+ ! MANIFEST ext/Thread/Thread.xs
+
+----------------
+Version 5.004_63
+----------------
+
+____________________________________________________________________________
+[ 834] By: mbeattie on 1998/03/17 16:19:10
+ Log: Policy_sh.SH had extra $ in pager=$pager comment (Hallvard B Furuseth)
+ Branch: perl
+ ! Policy_sh.SH
+____________________________________________________________________________
+[ 833] By: mbeattie on 1998/03/17 16:11:02
+ Log: Integrate win32 branch into mainline.
+ Branch: perl
+ !> regcomp.c win32/config.bc win32/config.gc win32/config.vc
+ !> win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ !> win32/win32.c
+____________________________________________________________________________
+[ 832] By: gsar on 1998/03/17 14:32:39
+ Log: propagate bugfix @ change831 from asperl
+ Branch: win32/perl
+ ! regcomp.c
+____________________________________________________________________________
+[ 831] By: gsar on 1998/03/17 14:02:51
+ Log: fix buggy order of free() in regcomp.c (from AS)
+ Branch: asperl
+ ! regcomp.c
+____________________________________________________________________________
+[ 830] By: gsar on 1998/03/17 01:10:54
+ Log: add a part of AS patch#14, backout incomplete variable
+ name changes for gcc. Builds and tests under VC/BC once again.
+ Branch: asperl
+ ! bytecode.h mg.c pp.c pp_ctl.c pp_hot.c toke.c
+____________________________________________________________________________
+[ 829] By: gsar on 1998/03/16 23:49:18
+ Log: stray tweak to win32.c
+ Branch: win32/perl
+ ! win32/win32.c
+____________________________________________________________________________
+[ 828] By: gsar on 1998/03/16 22:06:03
+ Log: update win32/config* files
+ Branch: win32/perl
+ ! win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+____________________________________________________________________________
+[ 827] By: gsar on 1998/03/16 19:09:30
+ Log: trivial integrate of mainline
+ Branch: win32/perl
+ +> lib/ExtUtils/Installed.pm lib/ExtUtils/Packlist.pm
+ +> lib/ExtUtils/inst
+ !> (integrate 61 files)
+____________________________________________________________________________
+[ 826] By: mbeattie on 1998/03/16 16:39:23
+ Log: newCONSTSUB had private MY_start_subparse.
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 825] By: mbeattie on 1998/03/16 16:36:55
+ Log: Missing dTHR in hv_fetch_ent when statics moved to thread struct.
+ Branch: perl
+ ! hv.c
+____________________________________________________________________________
+[ 824] By: mbeattie on 1998/03/16 16:27:43
+ Log: Added missing entry for lib/ExtUtils/Packlist.pm to MANIFEST
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 823] By: mbeattie on 1998/03/16 16:26:02
+ Log: Missed p4 add of lib/ExtUtils/Packlist.pm in change 814.
+ Branch: perl
+ + lib/ExtUtils/Packlist.pm
+____________________________________________________________________________
+[ 822] By: mbeattie on 1998/03/16 16:22:58
+ Log: Bump patchlevel.h to 63.
+ Branch: perl
+ ! ext/IO/IO.xs patchlevel.h
+ !> (integrate 41 files)
+____________________________________________________________________________
+[ 821] By: mbeattie on 1998/03/16 16:18:35
+ Log: newCONSTSUB added (XSUB equivalent for inlinable sub () { 123 }).
+ Subject: Bundling builtin.pm and newCONSTSUB with the core?
+ From: jan.dubois@ibm.net (Jan Dubois)
+ Date: Sun, 15 Mar 1998 19:09:05 +0100
+ Branch: perl
+ ! embed.h global.sym op.c pod/perlguts.pod proto.h
+____________________________________________________________________________
+[ 820] By: mbeattie on 1998/03/16 16:02:50
+ Log: Subject: [PATCH] STRESS_REALLOC
+ Date: Fri, 13 Mar 1998 22:28:19 -0600 (CST)
+ From: Stephen McCamant <alias@mcs.com>
+ Branch: perl
+ ! malloc.c perl.c scope.c
+____________________________________________________________________________
+[ 819] By: mbeattie on 1998/03/16 16:01:06
+ Log: Subject: [BUG+PATCH] _62 with -DDEBUGGING and -Duseperlio
+ Date: Fri, 13 Mar 1998 23:21:25 +0100
+ From: Jan-Pieter Cornet <john@pc.xs4all.nl>
+ Branch: perl
+ ! perly.c
+____________________________________________________________________________
+[ 818] By: mbeattie on 1998/03/16 15:59:16
+ Log: Subject: [Configure PATCH] for OS/2
+ Date: Fri, 13 Mar 1998 16:18:12 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ [Two hunks to Configure failed to apply due to clashes]
+ Branch: perl
+ ! Configure hints/os2.sh
+____________________________________________________________________________
+[ 817] By: mbeattie on 1998/03/16 15:55:28
+ Log: Subject: [PATCH 5.004_62] VMS updates (direct)
+ Date: Thu, 12 Mar 1998 16:02:29 -0500 (EST)
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ [Needed manual tweaks on vms/config.vms since it clashed with other
+ patches. I may have got it wrong.]
+ Branch: perl
+ ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_VMS.pm
+ ! lib/ExtUtils/Mksymlists.pm perl.h pp.c pp_hot.c regcomp.c
+ ! regcomp.h utils/perldoc.PL vms/config.vms vms/descrip.mms
+ ! vms/ext/Stdio/Stdio.pm vms/ext/filespec.t vms/fndvers.com
+ ! vms/gen_shrfls.pl vms/genconfig.pl vms/sockadapt.h
+ ! vms/test.com vms/vms.c vms/vmsish.h
+____________________________________________________________________________
+[ 816] By: mbeattie on 1998/03/16 15:26:04
+ Log: Subject: [PATCH] Let h2xs read multiple header files
+ Date: Tue, 10 Mar 1998 09:35:42 -0500 (EST)
+ From: Benjamin Sugars <bsugars@canoe.ca>
+ Branch: perl
+ ! utils/h2xs.PL
+____________________________________________________________________________
+[ 815] By: mbeattie on 1998/03/16 15:24:12
+ Log: Subject: Re: Almost OK: Perl 5.004_62 on VMS 7.1
+ Date: Mon, 09 Mar 1998 09:18:56 -0800
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Branch: perl
+ ! vms/config.vms
+____________________________________________________________________________
+[ 814] By: mbeattie on 1998/03/16 13:17:14
+ Log: Subject: PATCH for 5.004_62 : Add .packlist handling classes to ExtUtils
+ Date: Sun, 08 Mar 1998 12:50:23 +0000
+ From: Alan Burlison <alan.burlison@UK.Sun.COM>
+ plus manual update of MANIFEST
+ Branch: perl
+ + lib/ExtUtils/Installed.pm lib/ExtUtils/inst
+ ! MANIFEST installman installperl lib/ExtUtils/Install.pm
+ ! lib/ExtUtils/MM_Unix.pm
+____________________________________________________________________________
+[ 813] By: mbeattie on 1998/03/16 13:08:55
+ Log: From: Blair Zajac <blair@gps.caltech.edu>
+ Subject: PATCH: util.c and util.h function declarations do not match
+ Date: Fri, 6 Mar 1998 10:29:29 -0800 (PST)
+ Subject: PATCH: cgywin32 patch for perlgcc
+ Date: Fri, 6 Mar 1998 11:15:36 -0800 (PST)
+ Subject: PATCH: perl5.004_62 on cygwin32
+ Date: Fri, 6 Mar 1998 11:57:35 -0800 (PST)
+ Branch: perl
+ ! Configure cygwin32/perlgcc cygwin32/perlld pp_sys.c x2p/util.c
+____________________________________________________________________________
+[ 812] By: mbeattie on 1998/03/16 12:55:39
+ Log: From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Subject: [PATCH 5.004_62} Config_62-01 patch available.
+ Date: Mon, 9 Mar 1998 15:23:33 -0500 (EST)
+ Subject: [PATCH 5.004_62] Tiny hint file updates
+ Date: Mon, 9 Mar 1998 13:21:46 -0500 (EST)
+ Branch: perl
+ ! Configure Porting/Glossary Porting/config.sh Porting/config_H
+ ! config_h.SH ext/ODBM_File/ODBM_File.xs handy.h hints/aix.sh
+ ! hints/dec_osf.sh hints/dos_djgpp.sh hints/freebsd.sh
+ ! hints/irix_6.sh hints/irix_6_0.sh hints/irix_6_1.sh
+ ! hints/os2.sh hints/solaris_2.sh patchlevel.h perl.c perl.h
+ ! perllio.h pod/perldiag.pod pp_sys.c vms/config.vms
+____________________________________________________________________________
+[ 811] By: mbeattie on 1998/03/16 12:13:55
+ Log: DOS djgpp updates:
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Subject: [PATCH for 5.004_61] dos-djgpp update
+ Date: Fri, 6 Mar 1998 10:41:01 +0100
+ Subject: [PATCH 5.004_62] dos-djgpp update
+ Date: Thu, 12 Mar 1998 13:34:51 +0100
+ Branch: perl
+ ! djgpp/config.over hints/dos_djgpp.sh
+____________________________________________________________________________
+[ 810] By: gsar on 1998/03/16 08:48:17
+ Log: integrate mainline
+ Branch: win32/perl
+ !> pp_sys.c
+____________________________________________________________________________
+[ 809] By: gsar on 1998/03/16 08:44:37
+ Log: various changes to get asperl working under Borland
+ (passes all tests when built under PERL_OBJECT)
+ Branch: asperl
+ ! ObjXSub.h ext/Opcode/Opcode.xs globals.c mg.c objpp.h op.c
+ ! perl.h perly.c perly.c.diff pp.c pp_ctl.c pp_hot.c pp_sys.c
+ ! proto.h scope.h sv.c toke.c win32/Makefile win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc win32/makedef.pl
+ ! win32/makefile.mk win32/runperl.c win32/win32.c win32/win32.h
+ ! win32/win32sck.c
+____________________________________________________________________________
+[ 808] By: gsar on 1998/03/12 19:50:20
+ Log: set sockets to nonoverlapped mode for every thread
+ Message-Id: <35081FE4.965A484D@enteract.com>
+ Date: Thu, 12 Mar 1998 11:48:20 CST
+ From: Steve Nielsen <spn@enteract.com>
+ Subject: [PATCH 5.004_62] win32: set sockopt on a per-thread basis
+ Branch: win32/perl
+ ! win32/win32.h win32/win32sck.c
+____________________________________________________________________________
+[ 807] By: gsar on 1998/03/12 19:26:54
+ Log: add AS patch#13
+ Branch: asperl
+ ! win32/Makefile
+____________________________________________________________________________
+[ 806] By: gsar on 1998/03/12 00:51:08
+ Log: added AS patch#12 with minor changes
+ Branch: asperl
+ ! ObjXSub.h bytecode.h byterun.c doio.c iplio.h
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm
+ ! lib/ExtUtils/Mksymlists.pm lib/ExtUtils/xsubpp objpp.h perl.c
+ ! perllio.h proto.h regcomp.c win32/Makefile win32/config_h.PL
+ ! win32/runperl.c
+____________________________________________________________________________
+[ 805] By: gsar on 1998/03/10 20:35:10
+ Log: reinstate some standard sig_names to avoid noise from
+ modules (and in hopes of making them _do_ something in future)
+ Branch: win32/perl
+ ! win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+____________________________________________________________________________
+[ 804] By: gsar on 1998/03/10 20:33:05
+ Log: mingw32 tweaks
+ Branch: win32/perl
+ ! win32/makefile.mk win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 803] By: gsar on 1998/03/09 20:56:07
+ Log: tweak Win32::DomainName() implementation
+ Branch: win32/perl
+ ! win32/Makefile win32/win32.c
+____________________________________________________________________________
+[ 802] By: gsar on 1998/03/09 03:51:01
+ Log: merge C<local $tied{foo}> patch, also moved statics in
+ [ah]v.c to thrdvar.h
+ Branch: win32/perl
+ ! av.c embedvar.h hv.c scope.c t/op/local.t thrdvar.h
+____________________________________________________________________________
+[ 801] By: gsar on 1998/03/09 02:38:35
+ Log: minor win32 support fixes
+ - add a better implementation of Win32::DomainName() (as
+ suggested by Jutta M. Klebe <jmk@exc.bybyte.de>)
+ - fix opendir() emulation was unsafe what given long paths
+ Branch: win32/perl
+ ! win32/win32.c
+____________________________________________________________________________
+[ 800] By: nick on 1998/03/07 09:36:41
+ Log: There has been a 'thaw' in config.h (the ICE has gone ;-))
+ So pp_sys.c needs tweaking otherwise it does not believe getservby*()
+ exist. (Breaks libnet).
+ Branch: perl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 799] By: gsar on 1998/03/07 07:51:28
+ Log: integrate mainline changes
+ Branch: asperl
+ !> (integrate 111 files)
+____________________________________________________________________________
+[ 798] By: gsar on 1998/03/07 07:01:55
+ Log: integrate mainline
+ Branch: win32/perl
+ !> myconfig patchlevel.h
+____________________________________________________________________________
+[ 797] By: gsar on 1998/03/07 06:49:49
+ Log: provide our own popen()/pclose() to fix problems with qx//:
+ - qx// used to always invoke the shell, now does so only when needed
+ - qx// didn't respect PERL5SHELL, now does
+ Branch: win32/perl
+ ! lib/ExtUtils/typemap win32/config_h.PL win32/win32.c
+____________________________________________________________________________
+[ 796] By: gsar on 1998/03/07 01:37:10
+ Log: a missed s/sp/SP/
+ Branch: win32/perl
+ ! lib/ExtUtils/typemap pod/perlcall.pod
+____________________________________________________________________________
+[ 795] By: gsar on 1998/03/07 01:05:21
+ Log: change all 'sp' to 'SP' in code and in the docs. Explicitly
+ mention that local stack pointer should be called SP. This makes the
+ API safer from source incompatibilities down the line.
+ Branch: win32/perl
+ ! av.c doio.c doop.c ext/DB_File/DB_File.xs
+ ! ext/DynaLoader/dl_dld.xs ext/Opcode/Opcode.xs
+ ! ext/POSIX/POSIX.xs ext/Socket/Socket.xs ext/Thread/Thread.xs
+ ! gv.c mg.c op.c os2/OS2/REXX/REXX.xs perl.c pod/perlcall.pod
+ ! pod/perlembed.pod pod/perlguts.pod pod/perlxs.pod pp.c
+ ! pp_ctl.c pp_hot.c pp_sys.c util.c
+
+----------------
+Version 5.004_62
+----------------
+
+____________________________________________________________________________
+[ 794] By: mbeattie on 1998/03/06 09:38:08
+ Log: Subject: [PATCH] perl5.004_61 myconfig updates
+ Date: Thu, 5 Mar 1998 15:10:54 -0500 (EST)
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Branch: perl
+ ! myconfig
+____________________________________________________________________________
+[ 793] By: mbeattie on 1998/03/06 09:36:37
+ Log: Bump patchlevel.h to 62.
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 792] By: mbeattie on 1998/03/06 09:35:57
+ Log: Integrate win32 branch into mainline.
+ Branch: perl
+ !> bytecode.h op.c proto.h scope.c win32/Makefile win32/config.bc
+ !> win32/config.gc win32/config.vc win32/config_H.bc
+ !> win32/config_H.gc win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 791] By: gsar on 1998/03/06 06:00:08
+ Log: various
+ - s/PerlIO_fread/PerlIO_read/, the former doesn't exist
+ - add missing prototypes
+ - regenerate win32/config*.?c
+ Branch: win32/perl
+ ! bytecode.h proto.h win32/config.bc win32/config.gc
+ ! win32/config.vc win32/config_H.bc win32/config_H.gc
+ ! win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 790] By: gsar on 1998/03/06 03:19:23
+ Log: fix typo in Makefile
+ Branch: win32/perl
+ ! win32/Makefile
+____________________________________________________________________________
+[ 789] By: gsar on 1998/03/05 22:55:53
+ Log: integrate mainline
+ Branch: win32/perl
+ !> (integrate 47 files)
+____________________________________________________________________________
+[ 788] By: gsar on 1998/03/05 20:02:09
+ Log: added AS patch#11
+ Message-Id: <01BD4820.AFC70110.dougl@ActiveState.com>
+ Date: Thu, 05 Mar 1998 10:23:04 PST
+ From: Douglas Lankshear <dougl@ActiveState.com>
+
+ This patch fixes a bug I introduced removing duplicate code.
+ -- Doug
+ Branch: asperl
+ ! ObjXSub.h objpp.h win32/runperl.c
+____________________________________________________________________________
+[ 787] By: gsar on 1998/03/05 19:56:17
+ Log: add Nick's dTHR fixes
+ Branch: win32/perl
+ ! op.c scope.c
+____________________________________________________________________________
+[ 786] By: gsar on 1998/03/05 19:54:49
+ Log: maintpatch
+ Message-Id: <199803050749.CAA15206@Orb.Nashua.NH.US>
+ Date: Thu, 05 Mar 1998 02:49:46 EST
+ From: Spider Boardman <spider@orb.nashua.nh.us>
+ Subject: [PATCH] 5.004_04 +MAINT_TRIAL_1 broken when sizeof(int) != sizeof(void
+ Branch: win32/perl
+ ! scope.c
+____________________________________________________________________________
+[ 785] By: mbeattie on 1998/03/05 19:12:14
+ Log: Subject: [5.004_61 PATCH] Make incompatible changes to RE engine NOW
+ Date: Wed, 4 Mar 1998 23:55:54 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! op.c proto.h regcomp.c regexp.h util.c
+____________________________________________________________________________
+[ 784] By: mbeattie on 1998/03/05 19:11:09
+ Log: Subject: [PATCH] Re: perl 5.0061 unable to build on sparc 5 Sol2.5.1 threads.
+ Date: Wed, 4 Mar 1998 10:18:03 GMT
+ From: Nick Ing-Simmons <nik@tiuk.ti.com>
+ Branch: perl
+ ! atomic.h
+____________________________________________________________________________
+[ 783] By: mbeattie on 1998/03/05 19:09:16
+ Log: Subject: Configure patches -01 and -02 for 5.004_61.
+ Date: Tue, 3 Mar 1998 16:41:16 -0500 (EST)
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Branch: perl
+ ! Configure INSTALL Policy_sh.SH Porting/Glossary
+ ! Porting/config.sh Porting/config_H Porting/pumpkin.pod
+ ! config_h.SH handy.h hints/README.hints hints/aix.sh
+ ! hints/linux.sh hints/solaris_2.sh hints/unicos.sh
+ ! makedepend.SH myconfig pp_sys.c
+____________________________________________________________________________
+[ 782] By: mbeattie on 1998/03/05 19:05:23
+ Log: Subject: [PATCH] Compiling with OP_IN_REGISTER
+ Date: 03 Mar 1998 18:05:07 +0100
+ From: Gisle Aas <gisle@aas.no>
+ Branch: perl
+ ! perl.h pp_ctl.c
+____________________________________________________________________________
+[ 781] By: mbeattie on 1998/03/05 19:04:34
+ Log: Subject: [PATCH] Make autouse -w-safe
+ Date: Mon, 2 Mar 1998 21:36:02 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! lib/autouse.pm op.c sv.c
+____________________________________________________________________________
+[ 780] By: mbeattie on 1998/03/05 19:02:50
+ Log: Subject: [PATCH] External symbol re_croak2
+ Date: 02 Mar 1998 13:00:45 +0100
+ From: Gisle Aas <gisle@aas.no>
+ Branch: perl
+ ! regcomp.c regcomp.h
+____________________________________________________________________________
+[ 779] By: mbeattie on 1998/03/05 19:01:25
+ Log: Subject: [PATCH 5.004_61] Miscellaneous minor fixes
+ Date: Mon, 02 Mar 1998 01:48:27 -0500 (EST)
+ From: bailey@newman.upenn.edu (Charles Bailey)
+ Branch: perl
+ ! bytecode.h embedvar.h ext/B/Makefile.PL ext/B/byteperl.c
+ ! ext/Thread/Makefile.PL lib/File/Path.pm patchlevel.h perldir.h
+ ! sv.h
+____________________________________________________________________________
+[ 778] By: mbeattie on 1998/03/05 18:53:13
+ Log: Subject: [PATCH 5.004_61] USHRT range limit macros
+ Date: Mon, 02 Mar 1998 01:41:41 -0500 (EST)
+ From: bailey@newman.upenn.edu (Charles Bailey)
+ Branch: perl
+ ! perl.h
+____________________________________________________________________________
+[ 777] By: mbeattie on 1998/03/05 18:50:25
+ Log: Subject: [PATCH 5.004_61] File::Basename taint fix (revised)
+ Date: Mon, 02 Mar 1998 01:39:47 -0500 (EST)
+ From: bailey@newman.upenn.edu (Charles Bailey)
+ Branch: perl
+ ! lib/File/Basename.pm
+____________________________________________________________________________
+[ 776] By: mbeattie on 1998/03/05 18:49:15
+ Log: Subject: [PATCH] Take out version number in perlguts (perl5.004_61)
+ Date: 01 Mar 1998 15:16:03 +0100
+ From: Gisle Aas <gisle@aas.no>
+ Branch: perl
+ ! pod/perlguts.pod
+____________________________________________________________________________
+[ 775] By: mbeattie on 1998/03/05 18:48:05
+ Log: Subject: Re: [PATCH] 5.004_61: Makefile.SH (Re: 5.004_61: annoyingly missing patch)
+ Date: Sun, 1 Mar 1998 12:14:44 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! Makefile.SH perl_exp.SH
+____________________________________________________________________________
+[ 774] By: mbeattie on 1998/03/05 18:46:32
+ Log: Subject: Almost OK: 5.004_61 (threads, perlio)
+ Date: Sun, 1 Mar 1998 02:02:47 -0500
+ From: Spider Boardman <spider@orb.nashua.nh.us>
+ Branch: perl
+ ! bytecode.h bytecode.pl byterun.c byterun.h perlsdio.h
+____________________________________________________________________________
+[ 773] By: mbeattie on 1998/03/05 18:43:57
+ Log: Subject: [PATCH 5.004_61] print sort {-1} 1..10; hangs
+ Date: Sat, 28 Feb 1998 15:51:14 -0500 (EST)
+ From: Hans Mulder <hansmu@xs4all.nl>
+ Branch: perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 772] By: mbeattie on 1998/03/05 18:39:25
+ Log: Subject: [PATCH] 5.004_61: Makefile.SH: 'ok' target needs perlbug...
+ Date: Sat, 28 Feb 1998 17:06:41 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! Makefile.SH
+____________________________________________________________________________
+[ 771] By: mbeattie on 1998/03/05 18:38:32
+ Log: Subject: [PATCH] 5.004_61: hints/netbsd.sh
+ Date: Sat, 28 Feb 1998 16:35:32 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! hints/netbsd.sh
+____________________________________________________________________________
+[ 770] By: mbeattie on 1998/03/05 18:36:50
+ Log: Add byterun.c to cflags.SH (Dominic Dunlop <domo@vo.lu>)
+ Branch: perl
+ ! cflags.SH
+____________________________________________________________________________
+[ 769] By: mbeattie on 1998/03/05 18:34:35
+ Log: Change getc/fread to PerlIO_getc/fread in bytecode.h:
+ Subject: [PATCH 5.004_61] bunch of small patches
+ Date: Fri, 27 Feb 1998 20:03:29 -0500 (EST)
+ From: Andrew Cohen <cohen@andy.bu.edu>
+ Branch: perl
+ ! bytecode.h
+____________________________________________________________________________
+[ 768] By: mbeattie on 1998/03/05 18:13:06
+ Log: Integrate win32 branch into mainline.
+ Branch: perl
+ !> (integrate 53 files)
+____________________________________________________________________________
+[ 767] By: TimBunce on 1998/03/05 11:48:09
+ Log: Update to change 744.
+ Branch: maint-5.004/perl
+ ! lib/ExtUtils/Install.pm
+____________________________________________________________________________
+[ 765] By: TimBunce on 1998/03/05 11:24:24
+ Log: Update embed.h after make regen_headers.
+ Branch: maint-5.004/perl
+ ! embed.h
+____________________________________________________________________________
+[ 764] By: TimBunce on 1998/03/05 11:05:13
+ Log: APPLLIB_EXP now has arch and version dirs added to @INC
+ Branch: maint-5.004/perl
+ ! perl.c
+____________________________________________________________________________
+[ 763] By: TimBunce on 1998/03/05 11:01:38
+ Log: Added hints/openbsd.sh and t/op/pos.t to MANIFEST
+ Added MAINT_TRIAL_1 local patch label to patchlevel.h
+ Removed win32/win32io.c and win32/win32io.h from repository
+ Branch: maint-5.004/perl
+ - win32/win32io.c win32/win32io.h
+ ! MANIFEST patchlevel.h
+____________________________________________________________________________
+[ 762] By: TimBunce on 1998/03/05 10:05:34
+ Log: Title: "5.004_04 +MAINT_TRIAL_1 broken when sizeof(int) != sizeof(void)"
+ From: Spider Boardman <spider@orb.nashua.nh.us>
+ Files: scope.c
+ Branch: maint-5.004/perl
+ ! scope.c
+____________________________________________________________________________
+[ 761] By: TimBunce on 1998/03/05 10:03:10
+ Log: Title: "properly refcount localization, fix C<local $tied{foo}>"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802191207.MAA10742@toad.ig.co.uk>
+ Files: av.c hv.c scope.c t/op/local.t
+ Branch: maint-5.004/perl
+ ! av.c hv.c scope.c t/op/local.t
+____________________________________________________________________________
+[ 760] By: gsar on 1998/03/04 20:58:21
+ Log: added AS patch#10
+ Message-Id: <01BD4691.963D1670.dougl@ActiveState.com>
+ Date: Tue, 03 Mar 1998 10:46:13 PST
+ From: Douglas Lankshear <dougl@ActiveState.com>
+ Subject: [PATCH]
+
+ Here's a patch to win32/dl_win32.xs that is a fix for the lookup of statically
+ linked modules.
+
+ -- Doug
+ Branch: asperl
+ ! win32/dl_win32.xs
+____________________________________________________________________________
+[ 759] By: TimBunce on 1998/03/04 18:46:41
+ Log: Update patchls utility
+ Branch: maint-5.004/perl
+ ! Porting/patchls
+____________________________________________________________________________
+[ 758] By: TimBunce on 1998/03/04 17:07:06
+ Log: perldoc -f now uses pager if text is too long for screen
+ Branch: maint-5.004/perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 757] By: TimBunce on 1998/03/04 16:57:04
+ Log: Added OpenBSD hint file from <Todd.Miller@courtesan.com>
+ Document 'warn with no args' behaviour, from <johnpc@xs4all.net>
+ Branch: maint-5.004/perl
+ + hints/openbsd.sh
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 756] By: TimBunce on 1998/03/04 16:48:40
+ Log: Fix for new gnulibc stdio.h when using sfio+perlio
+ Branch: maint-5.004/perl
+ ! perlsdio.h
+____________________________________________________________________________
+[ 755] By: TimBunce on 1998/03/04 16:47:08
+ Log: Fixed typo in vms/ext/Stdio/Stdio.pm AUTOLOAD
+ Added details of split in scalar context to perlfunc.pod
+ Branch: maint-5.004/perl
+ ! pod/perlfunc.pod vms/ext/Stdio/Stdio.pm
+____________________________________________________________________________
+[ 754] By: TimBunce on 1998/03/04 16:35:58
+ Log: Updated perl -v info to include reference to docs and home page.
+ Branch: maint-5.004/perl
+ ! perl.c
+____________________________________________________________________________
+[ 753] By: TimBunce on 1998/03/04 16:31:29
+ Log: Updated hints/bsdos.sh for BSD/OS 3.1
+ Fixed typo in pod/perlsyn.pod
+ Added workaround for old gmake in ext/SDBM_File/sdbm/Makefile.PL
+ Fixed typo in ext/GDBM_File/GDBM_File.pm
+ Branch: maint-5.004/perl
+ ! ext/GDBM_File/GDBM_File.pm ext/SDBM_File/sdbm/Makefile.PL
+ ! hints/bsdos.sh pod/perlsyn.pod
+____________________________________________________________________________
+[ 752] By: TimBunce on 1998/03/04 15:49:19
+ Log: Changed bug address in README to perlbug@perl.com
+ Changed Copyright in perl.c to 1998
+ Added op/pos.t test from Robin Houston <robin@oneworld.org>
+ Branch: maint-5.004/perl
+ + t/op/pos.t
+ ! README perl.c
+____________________________________________________________________________
+[ 751] By: TimBunce on 1998/03/04 14:47:15
+ Log: Make t/comp/require.t and t/lib/ph.t executable in repository
+ Branch: maint-5.004/perl
+ ! t/comp/require.t t/lib/ph.t
+____________________________________________________________________________
+[ 750] By: TimBunce on 1998/03/04 13:29:58
+ Log: Added dTHR definition to ease backwards compatibility for XS
+ source code from 5.005.
+ Branch: maint-5.004/perl
+ ! perl.h
+____________________________________________________________________________
+[ 749] By: TimBunce on 1998/03/04 12:19:19
+ Log: Title: "rename local 'op' variables to 'o'", #F114
+ From: Gurusamy Sarathy
+ Files: op.h opcode.h proto.h dump.c op.c opcode.pl pp_ctl.c run.c scope.c
+ toke.c
+ Branch: maint-5.004/perl
+ ! dump.c op.c op.h opcode.h opcode.pl pp_ctl.c proto.h run.c
+ ! scope.c toke.c
+____________________________________________________________________________
+[ 748] By: TimBunce on 1998/03/04 12:12:27
+ Log: Title: "consolidated win32 patch", #F112
+ From: Gurusamy Sarathy
+ Files: MANIFEST pod/perlfaq2.pod pod/perlrun.pod win32/include/sys/socket.h
+ EXTERN.h INTERN.h dosish.h lib/ExtUtils/Command.pm
+ lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Win32.pm
+ lib/ExtUtils/Mksymlists.pm lib/File/DosGlob.pm t/TEST
+ t/harness win32/win32.h win32/win32iop.h README.win32
+ doio.c installhtml installperl pp_sys.c win32/Makefile
+ win32/config.bc win32/config.vc win32/config_H.bc
+ win32/config_H.vc win32/config_h.PL win32/config_sh.PL
+ win32/dl_win32.xs win32/makedef.pl win32/makefile.mk
+ win32/perllib.c win32/runperl.c win32/win32.c
+ win32/win32sck.c win32/bin/perlglob.pl x2p/a2p.h x2p/a2p.c
+ x2p/a2py.c
+ Branch: maint-5.004/perl
+ + win32/bin/perlglob.pl
+ ! EXTERN.h INTERN.h MANIFEST README.win32 doio.c dosish.h
+ ! installhtml installperl lib/ExtUtils/Command.pm
+ ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Win32.pm
+ ! lib/ExtUtils/Mksymlists.pm lib/File/DosGlob.pm
+ ! pod/perlfaq2.pod pod/perlrun.pod pp_sys.c t/TEST t/harness
+ ! win32/Makefile win32/config.bc win32/config.vc
+ ! win32/config_H.bc win32/config_H.vc win32/config_h.PL
+ ! win32/config_sh.PL win32/dl_win32.xs
+ ! win32/include/sys/socket.h win32/makedef.pl win32/makefile.mk
+ ! win32/perllib.c win32/runperl.c win32/win32.c win32/win32.h
+ ! win32/win32iop.h win32/win32sck.c x2p/a2p.c x2p/a2p.h
+ ! x2p/a2py.c
+____________________________________________________________________________
+[ 747] By: TimBunce on 1998/03/04 11:59:57
+ Log: Title: "initialize @INC in ph.t, and fix up MANIFEST", #F111
+ From: Gurusamy Sarathy
+ Files: MANIFEST t/lib/ph.t
+ Branch: maint-5.004/perl
+ ! MANIFEST t/lib/ph.t
+____________________________________________________________________________
+[ 746] By: TimBunce on 1998/03/04 11:47:43
+ Log: Title: "properly save STDOUT during system() in debugger", #F110
+ From: Jason Smith <smithj4@rpi.edu>
+ Files: lib/perl5db.pl
+ Branch: maint-5.004/perl
+ ! lib/perl5db.pl
+____________________________________________________________________________
+[ 745] By: TimBunce on 1998/03/04 11:40:19
+ Log: Title: "generate DynaLoader.pm at build time", #F109
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9802111938.AA26224@o09.xray.mpe.mpg.de>
+ Files: MANIFEST ext/DynaLoader/DynaLoader.pm.PL ext/DynaLoader/Makefile.PL
+ Branch: maint-5.004/perl
+ + ext/DynaLoader/DynaLoader.pm.PL
+ ! MANIFEST ext/DynaLoader/Makefile.PL
+____________________________________________________________________________
+[ 744] By: TimBunce on 1998/03/04 11:34:09
+ Log: Title: "Install extensions with bootstrap in $archlib", #F108
+ From: koenig@anna.mind.de (Andreas J. Koenig), koenig@kulturbox.de (Andreas
+ J. Koenig)
+ Msg-ID: <sfcra9fqx0n.fsf@anna.in-berlin.de>
+ Files: lib/ExtUtils/Install.pm
+ Branch: maint-5.004/perl
+ ! lib/ExtUtils/Install.pm
+____________________________________________________________________________
+[ 743] By: TimBunce on 1998/03/04 10:45:05
+ Log: Title: "Pod::Html trips over "C<0>"", #F107
+ From: Chip Salzenberg
+ Files: lib/Pod/Html.pm
+ Branch: maint-5.004/perl
+ ! lib/Pod/Html.pm
+____________________________________________________________________________
+[ 742] By: TimBunce on 1998/03/04 10:12:54
+ Log: Title: "5.004_58 | _04: pod2*,perlpod: L<show this|man/section>", #F106
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9802111629.AA00595@o09.xray.mpe.mpg.de>
+ Files: pod/perlpod.pod lib/Pod/Html.pm lib/Pod/Text.pm pod/pod2man.PL
+ Branch: maint-5.004/perl
+ ! lib/Pod/Html.pm lib/Pod/Text.pm pod/perlpod.pod pod/pod2man.PL
+____________________________________________________________________________
+[ 741] By: TimBunce on 1998/03/04 10:08:31
+ Log: Title: "New patch for $^E==GetLastError() under Win32", #F105
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Tye McQueen
+ <tye@metronet.com>, ilya@math.ohio-state.edu (Ilya
+ Zakharevich)
+ Msg-ID: <199801040630.AA29298@metronet.com>,
+ <199801041826.NAA11568@aatma.engin.umich.edu>,
+ <1998Jan4.130412.2719461@cor.newman>
+ Files: pod/perlfunc.pod pod/perlvar.pod doio.c lib/dumpvar.pl lib/perl5db.pl
+ win32/win32.h mg.c util.c win32/makedef.pl win32/win32.c
+ Branch: maint-5.004/perl
+ ! doio.c lib/dumpvar.pl lib/perl5db.pl mg.c pod/perlfunc.pod
+ ! pod/perlvar.pod util.c win32/makedef.pl win32/win32.c
+ ! win32/win32.h
+____________________________________________________________________________
+[ 740] By: TimBunce on 1998/03/04 09:55:57
+ Log: Title: "5.004_56: Patch to Tie::Hash and docs", #F104
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199801120134.UAA05437@monk.mps.ohio-state.edu>
+ Files: pod/perlfunc.pod lib/Tie/Hash.pm
+ Branch: maint-5.004/perl
+ ! lib/Tie/Hash.pm pod/perlfunc.pod
+____________________________________________________________________________
+[ 739] By: TimBunce on 1998/03/04 09:26:01
+ Log: Title: "more doc for perldoc", #F103
+ From: Gurusamy Sarathy
+ Files: utils/perldoc.PL
+ Branch: maint-5.004/perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 738] By: TimBunce on 1998/03/04 09:23:16
+ Log: Title: "Make perldoc look for an index file ", #F102
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <199801221220.NAA22902@furu.g.aas.no>
+ Files: utils/perldoc.PL
+ Branch: maint-5.004/perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 737] By: TimBunce on 1998/03/04 09:21:15
+ Log: Title: "perldoc -F filename", #F101
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199712120037.TAA00176@math.mps.ohio-state.edu>
+ Files: utils/perldoc.PL
+ Branch: maint-5.004/perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 736] By: TimBunce on 1998/03/04 09:16:20
+ Log: Title: "sv_grow can fail for HAS_64K_LIMIT systems", #F100
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <m3iuqsl3oq.fsf@furu.g.aas.no>
+ Files: sv.c
+ Branch: maint-5.004/perl
+ ! sv.c
+____________________________________________________________________________
+[ 735] By: TimBunce on 1998/03/04 09:08:51
+ Log: Title: "Benchmark.pm: timethese corrupts $_", #F099
+ From: abigail@fnx.com
+ Msg-ID: <19980201114609.7779.qmail@betelgeuse.wayne.fnx.com>
+ Files: lib/Benchmark.pm
+ Branch: maint-5.004/perl
+ ! lib/Benchmark.pm
+____________________________________________________________________________
+[ 734] By: TimBunce on 1998/03/04 08:59:58
+ Log: Title: "STRANGE_MALLOC should test failed alloc", #F098
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <199802021406.PAA03285@furu.g.aas.no>
+ Files: hv.c
+ Branch: maint-5.004/perl
+ ! hv.c
+____________________________________________________________________________
+[ 733] By: TimBunce on 1998/03/04 08:35:19
+ Log: Title: "support caseless %ENV", #F097
+ From: Gurusamy Sarathy
+ Files: hv.c t/op/magic.t win32/win32.h
+ Branch: maint-5.004/perl
+ ! hv.c t/op/magic.t win32/win32.h
+____________________________________________________________________________
+[ 732] By: TimBunce on 1998/03/04 08:33:58
+ Log: Title: "newer cperl-mode.el (from 5.004_60)", #F096
+ From: Ilya Zakharevich
+ Files: emacs/cperl-mode.el
+ Branch: maint-5.004/perl
+ ! emacs/cperl-mode.el
+____________________________________________________________________________
+[ 731] By: TimBunce on 1998/03/04 08:26:23
+ Log: Title: "Handle set magic on xsub OUTPUT args, add API functions that handle
+ magic", #F095
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199801190409.XAA26710@aatma.engin.umich.edu>
+ Files: pod/perlguts.pod pod/perlxs.pod embed.h proto.h sv.h global.sym
+ lib/ExtUtils/xsubpp sv.c
+ Branch: maint-5.004/perl
+ ! embed.h global.sym lib/ExtUtils/xsubpp pod/perlguts.pod
+ ! pod/perlxs.pod proto.h sv.c sv.h
+____________________________________________________________________________
+[ 730] By: TimBunce on 1998/03/04 08:20:52
+ Log: Title: "Fix flawed cleanup when signal handlers are not defined", #F094
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710290106.UAA11485@aatma.engin.umich.edu>
+ Files: mg.c
+ Branch: maint-5.004/perl
+ ! mg.c
+____________________________________________________________________________
+[ 729] By: TimBunce on 1998/03/04 08:18:02
+ Log: Title: "Tests for C<sort 'foo','bar'>", #F093
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199711021247.MAA01743@crypt.compulink.co.uk>
+ Files: t/op/sort.t
+ Branch: maint-5.004/perl
+ ! t/op/sort.t
+____________________________________________________________________________
+[ 728] By: TimBunce on 1998/03/04 08:17:07
+ Log: Title: "Make search.pl work on win32", #F092
+ From: Gurusamy Sarathy
+ Files: win32/bin/search.pl
+ Branch: maint-5.004/perl
+ ! win32/bin/search.pl
+____________________________________________________________________________
+[ 727] By: gsar on 1998/03/04 04:13:23
+ Log: missing s/op/o/ from one of the mainpatches
+ Branch: win32/perl
+ ! op.c
+____________________________________________________________________________
+[ 726] By: gsar on 1998/03/04 02:12:13
+ Log: maintpatches #102 and #103 to perldoc.PL
+ Branch: win32/perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 725] By: gsar on 1998/03/04 02:00:15
+ Log: renumber some tests to match maint branch
+ Branch: win32/perl
+ ! t/op/local.t
+____________________________________________________________________________
+[ 724] By: gsar on 1998/03/04 01:25:50
+ Log: maintpatch
+ #70: "Fix random whitespace errors in docs"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <12726.877706444@eeyore.ibcinc.com>
+ Date: Fri, 24 Oct 1997 11:20:44 -0400
+ Files: pod/checkpods.PL pod/perlfunc.pod
+ Branch: win32/perl
+ ! pod/checkpods.PL
+____________________________________________________________________________
+[ 723] By: gsar on 1998/03/04 01:04:37
+ Log: sync maintpatch
+ #76: "Fix infinite loop on unlink() failure in File::Path::rmtree()
+ From: Chip Salzenberg
+ Files: lib/File/Path.pm
+ Branch: win32/perl
+ ! lib/File/Path.pm
+____________________________________________________________________________
+[ 722] By: gsar on 1998/03/04 00:46:46
+ Log: remove redundancy in File::Find
+ Branch: win32/perl
+ ! lib/File/Find.pm
+____________________________________________________________________________
+[ 721] By: TimBunce on 1998/03/03 20:06:41
+ Log: Title: "Fix spurious perldoc warnings on DOSISH platforms", #F091
+ From: Molnar Laszlo <molnarl@cdata.tvnet.hu>
+ Msg-ID: <34475659.1AA69855@cdata.tvnet.hu>
+ Files: utils/perldoc.PL
+ Branch: maint-5.004/perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 720] By: TimBunce on 1998/03/03 20:03:59
+ Log: Title: "Make ExtUtils::MM_Unix::fixin() do something meaningful on win32",
+ #F090
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199801070016.TAA17766@aatma.engin.umich.edu>
+ Files: lib/ExtUtils/MM_Unix.pm
+ Branch: maint-5.004/perl
+ ! lib/ExtUtils/MM_Unix.pm
+____________________________________________________________________________
+[ 719] By: TimBunce on 1998/03/03 20:02:06
+ Log: Title: "Fix inconsistent case $ENV{Path} (vs $ENV{PATH})", #F089
+ From: Gurusamy Sarathy
+ Files: lib/FindBin.pm
+ Branch: maint-5.004/perl
+ ! lib/FindBin.pm
+____________________________________________________________________________
+[ 718] By: TimBunce on 1998/03/03 20:00:26
+ Log: Title: "Fix File::Find's longstanding confusion about win32 being like VMS",
+ #F088
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802020459.XAA04964@aatma.engin.umich.edu>
+ Files: lib/File/Find.pm
+ Branch: maint-5.004/perl
+ ! lib/File/Find.pm
+____________________________________________________________________________
+[ 717] By: TimBunce on 1998/03/03 19:59:38
+ Log: Title: "do_postponed breaks with multiple interpreters", #F087
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710290316.WAA15888@aatma.engin.umich.edu>
+ Files: op.c
+ Branch: maint-5.004/perl
+ ! op.c
+____________________________________________________________________________
+[ 716] By: TimBunce on 1998/03/03 19:57:17
+ Log: Title: "Make warning on C<Nosuch::> optional, add to perl{diag,delta}.pod",
+ #F086
+ From: Gurusamy Sarathy
+ Files: pod/perldelta.pod pod/perldiag.pod toke.c
+ Branch: maint-5.004/perl
+ ! pod/perldelta.pod pod/perldiag.pod toke.c
+____________________________________________________________________________
+[ 715] By: TimBunce on 1998/03/03 19:51:33
+ Log: Title: "Pod::Html bug and fix: missing </UL> in index", #F085
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802192314.SAA23326@aatma.engin.umich.edu>
+ Files: lib/Pod/Html.pm
+ Branch: maint-5.004/perl
+ ! lib/Pod/Html.pm
+____________________________________________________________________________
+[ 714] By: TimBunce on 1998/03/03 19:50:28
+ Log: Title: "New pod: perlhist", #F084
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199802191556.RAA09578@alpha.hut.fi>
+ Files: MANIFEST pod/perl.pod pod/perlhist.pod pod/perltoc.pod pod/buildtoc
+ Branch: maint-5.004/perl
+ + pod/perlhist.pod
+ ! MANIFEST pod/buildtoc pod/perl.pod pod/perltoc.pod
+____________________________________________________________________________
+[ 713] By: TimBunce on 1998/03/03 19:47:13
+ Log: Title: "Fix restoration of locals on scope unwinding", #F083
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802110515.AAA23700@aatma.engin.umich.edu>
+ Files: pp_ctl.c t/op/local.t
+ Branch: maint-5.004/perl
+ ! pp_ctl.c t/op/local.t
+____________________________________________________________________________
+[ 712] By: TimBunce on 1998/03/03 19:45:56
+ Log: Title: "after an eval-ed bad require, requiring a string ref SEGVs", #F082
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802102349.SAA16001@aatma.engin.umich.edu>
+ Files: pp_ctl.c
+ Branch: maint-5.004/perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 711] By: TimBunce on 1998/03/03 19:44:41
+ Log: Title: "Fix seg fault on eval/require and syntax errors", #F081
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802102321.SAA15346@aatma.engin.umich.edu>
+ Files: MANIFEST scope.h op.c pp_ctl.c scope.c t/comp/require.t toke.c
+ Branch: maint-5.004/perl
+ + t/comp/require.t
+ ! MANIFEST op.c pp_ctl.c scope.c scope.h toke.c
+____________________________________________________________________________
+[ 710] By: TimBunce on 1998/03/03 19:36:34
+ Log: Title: "5.004_58: the locale.t problem in IRIX", #F080
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199802091747.TAA01735@alpha.hut.fi>
+ Files: t/pragma/locale.t
+ Branch: maint-5.004/perl
+ ! t/pragma/locale.t
+____________________________________________________________________________
+[ 709] By: TimBunce on 1998/03/03 19:32:30
+ Log: Title: "sv_setnv will upgrade SVt_NV to SVt_PVNV", #F079
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <m3g1lwl3bq.fsf@furu.g.aas.no>
+ Files: sv.c
+ Branch: maint-5.004/perl
+ ! sv.c
+____________________________________________________________________________
+[ 708] By: TimBunce on 1998/03/03 19:28:06
+ Log: Title: "Eliminate double warnings under C<package;>", #F077
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0y0paq-0000Ov-00@ursa.cus.cam.ac.uk>
+ Files: gv.c op.c toke.c
+ Branch: maint-5.004/perl
+ ! gv.c op.c toke.c
+____________________________________________________________________________
+[ 707] By: TimBunce on 1998/03/03 19:13:17
+ Log: Title: "Fix infinite loop on unlink() failure in File::Path::rmtree()",
+ #F076
+ From: Murray Nesbitt <mjn@pathcom.com>, Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <199802061100.LAA16423@toad.ig.co.uk>
+ Files: lib/File/Path.pm
+ Branch: maint-5.004/perl
+ ! lib/File/Path.pm
+____________________________________________________________________________
+[ 706] By: TimBunce on 1998/03/03 19:08:45
+ Log: Title: "Update of h2ph", #F075
+ From: kstar@www.chapin.edu (Kurt D. Starsinic)
+ Msg-ID: <199802051354.FAA11452@www.chapin.edu>
+ Files: t/lib/ph.t utils/h2ph.PL
+ Branch: maint-5.004/perl
+ + t/lib/ph.t
+ ! utils/h2ph.PL
+____________________________________________________________________________
+[ 705] By: TimBunce on 1998/03/03 18:56:59
+ Log: Title: "Fix AutoLoader for deep packages", #F074
+ From: Zachary Miller <zcmiller@zappy.er.usgs.gov>
+ Msg-ID: <199710092348.SAA02108@zappy.er.usgs.gov>
+ Files: lib/AutoLoader.pm
+ Branch: maint-5.004/perl
+ ! lib/AutoLoader.pm
+____________________________________________________________________________
+[ 704] By: TimBunce on 1998/03/03 18:35:36
+ Log: Title: "Fix order of warnings for misplaced subscripts", #F073
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199710131023.LAA16796@crypt.compulink.co.uk>
+ Files: op.c
+ Branch: maint-5.004/perl
+ ! op.c
+____________________________________________________________________________
+[ 703] By: TimBunce on 1998/03/03 18:32:28
+ Log: Title: "Make recursive lexical analysis more robust", #F072
+ From: Ilya Zakharevich and Chip Salzenberg
+ Msg-ID: <199710160102.VAA28817@monk.mps.ohio-state.edu>
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 702] By: TimBunce on 1998/03/03 18:18:10
+ Log: Title: "Fix random whitespace errors in docs", #F070
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <12726.877706444@eeyore.ibcinc.com>
+ Files: pod/perlfunc.pod pod/checkpods.PL
+ Branch: maint-5.004/perl
+ ! pod/checkpods.PL pod/perlfunc.pod
+____________________________________________________________________________
+[ 701] By: TimBunce on 1998/03/03 18:13:54
+ Log: Title: "Fix line numbers after here documents in eval STRING", #F069
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710241745.NAA08166@monk.mps.ohio-state.edu>
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 700] By: TimBunce on 1998/03/03 18:11:20
+ Log: Title: "Fix SEGV from combining caller and C<package;>", #F068
+ From: James Duncan <jduncan@epitome.hawk.igs.net>, Nicholas Clark
+ <nick@flirble.org>
+ Msg-ID: <199710241248.NAA00163@flirble.org>,
+ <Pine.LNX.3.96.971024135912.12197A-100000@epitome.hawk.igs.
+ net>
+ Files: pp_ctl.c sv.c
+ Branch: maint-5.004/perl
+ ! pp_ctl.c sv.c
+____________________________________________________________________________
+[ 699] By: TimBunce on 1998/03/03 18:06:59
+ Log: Title: "Don't fold string comparison under C<use locale>", #F067
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199711151506.RAA26287@alpha.hut.fi>
+ Files: op.c
+ Branch: maint-5.004/perl
+ ! op.c
+____________________________________________________________________________
+[ 698] By: TimBunce on 1998/03/03 18:04:51
+ Log: Title: "Fix SEGV on constant at end of sort block", #F066
+ From: Administration <fadmin@informatics.muni.cz>
+ Msg-ID: <199711170838.JAA26073@thetis.fi.muni.cz>
+ Files: op.c
+ Branch: maint-5.004/perl
+ ! op.c
+____________________________________________________________________________
+[ 697] By: TimBunce on 1998/03/03 18:02:54
+ Log: Title: "Allow C<last()> to mean C<last>", #F065
+ From: Chip Salzenberg
+ Files: op.c
+ Branch: maint-5.004/perl
+ ! op.c
+____________________________________________________________________________
+[ 696] By: TimBunce on 1998/03/03 17:58:12
+ Log: Title: "Fix extension version mismatch message", #F064
+ From: Chip Salzenberg
+ Files: XSUB.h
+ Branch: maint-5.004/perl
+ ! XSUB.h
+____________________________________________________________________________
+[ 695] By: TimBunce on 1998/03/03 17:53:04
+ Log: Title: "Better handle and test struct tm of Linux and SunOS", #F063
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980205134340.15567B-100000@newton.phys>
+ Files: MANIFEST ext/POSIX/hints/linux.pl ext/POSIX/hints/sunos_4.pl
+ hints/linux.sh hints/sunos_4_1.sh t/lib/posix.t
+ Branch: maint-5.004/perl
+ + ext/POSIX/hints/linux.pl ext/POSIX/hints/sunos_4.pl
+ ! MANIFEST hints/linux.sh hints/sunos_4_1.sh t/lib/posix.t
+____________________________________________________________________________
+[ 694] By: TimBunce on 1998/03/03 17:40:47
+ Log: Title: "Fix doc bug in getservbyname() examples", #F062
+ From: Tom Christiansen
+ Files: ext/Socket/Socket.pm
+ Branch: maint-5.004/perl
+ ! ext/Socket/Socket.pm
+____________________________________________________________________________
+[ 693] By: TimBunce on 1998/03/03 17:32:57
+ Log: Title: "Kill warning about parameter type", #F061
+ From: Chip Salzenberg
+ Files: op.c
+ Branch: maint-5.004/perl
+ ! op.c
+____________________________________________________________________________
+[ 692] By: TimBunce on 1998/03/03 17:11:07
+ Log: Title: "Socket occasional SEGV", #F060
+ From: Trevor Blackwell <tlb@viaweb.com>
+ Msg-ID: <199710281804.NAA09632@wagg.viaweb.com>
+ Files: ext/Socket/Socket.xs
+ Branch: maint-5.004/perl
+ ! ext/Socket/Socket.xs
+____________________________________________________________________________
+[ 691] By: TimBunce on 1998/03/03 17:09:51
+ Log: Title: "Avoid SEGV from local($@)", #F059
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710290251.VAA14362@aatma.engin.umich.edu>
+ Files: pp_ctl.c
+ Branch: maint-5.004/perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 690] By: TimBunce on 1998/03/03 17:08:21
+ Log: Title: "Don't use broken pad_reset() (was Re: Perl bug in 5.004_03 )", #F058
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710300036.TAA01004@aatma.engin.umich.edu>
+ Files: op.c
+ Branch: maint-5.004/perl
+ ! op.c
+____________________________________________________________________________
+[ 689] By: TimBunce on 1998/03/03 17:05:57
+ Log: Title: "Use STMT_{START,END} in XSRETURN", #F057
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710300245.VAA04244@aatma.engin.umich.edu>
+ Files: XSUB.h
+ Branch: maint-5.004/perl
+ ! XSUB.h
+____________________________________________________________________________
+[ 688] By: TimBunce on 1998/03/03 17:04:15
+ Log: Title: "Re: Sort grammar bug", #F056
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199711011946.OAA18882@aatma.engin.umich.edu>
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 687] By: TimBunce on 1998/03/03 17:01:32
+ Log: Title: "Document indirect object cases for exec(), system()", #F055
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03110700b084e89234a7@[194.51.248.90]>
+ Files: pod/perlfunc.pod
+ Branch: maint-5.004/perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 686] By: TimBunce on 1998/03/03 16:56:44
+ Log: Title: "Update docs on tr///", #F054
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.971103071602.10568C-100000@usertest.teleport.com>
+ Files: pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod
+ pod/perllocale.pod pod/perlmod.pod pod/perlop.pod
+ pod/perlstyle.pod toke.c
+ Branch: maint-5.004/perl
+ ! pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod
+ ! pod/perllocale.pod pod/perlmod.pod pod/perlop.pod
+ ! pod/perlstyle.pod toke.c
+____________________________________________________________________________
+[ 685] By: TimBunce on 1998/03/03 16:38:50
+ Log: Title: "Re: perlop bitwise & | ^ documentation", #F053
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.971106073858.29771O-100000@usertest.teleport.com>
+ Files: pod/perlop.pod
+ Branch: maint-5.004/perl
+ ! pod/perlop.pod
+____________________________________________________________________________
+[ 684] By: TimBunce on 1998/03/03 16:37:00
+ Log: Title: "Fix SEGV on C<*glob{'SCALAR','ARRAY'}>", #F052
+ From: "Joseph N. Hall" <joseph@cscaper.com>
+ Msg-ID: <199711110552.WAA12613@gadget.cscaper.com>
+ Files: perly.c perly.c.diff perly.y vms/perly_c.vms
+ Branch: maint-5.004/perl
+ ! perly.c perly.c.diff perly.y vms/perly_c.vms
+____________________________________________________________________________
+[ 683] By: TimBunce on 1998/03/03 16:31:15
+ Log: Title: "for perlguts.pod: document sv_derived_from, sv_vcatpfn and
+ sv_vsetpfn", #F051
+ From: jan.dubois@ibm.net (Jan Dubois) and Chip Salzenberg
+ Msg-ID: <346ae970.7444534@smtp1.ibm.net>
+ Files: pod/perlguts.pod
+ Branch: maint-5.004/perl
+ ! pod/perlguts.pod
+____________________________________________________________________________
+[ 682] By: TimBunce on 1998/03/03 16:28:30
+ Log: Title: "5.004_04: locale startup failure (at last) documented", #F050
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199711172054.WAA08261@alpha.hut.fi>
+ Files: INSTALL pod/perldiag.pod pod/perllocale.pod
+ Branch: maint-5.004/perl
+ ! INSTALL pod/perldiag.pod pod/perllocale.pod
+____________________________________________________________________________
+[ 681] By: TimBunce on 1998/03/03 16:24:12
+ Log: Title: "Cope with lack of args in Fcntl::AUTOLOAD", #F049
+ From: Jerome Abela <abela@hsc.fr>
+ Msg-ID: <19971120183248.23588@coredump.hsc.fr>
+ Files: ext/Fcntl/Fcntl.pm
+ Branch: maint-5.004/perl
+ ! ext/Fcntl/Fcntl.pm
+____________________________________________________________________________
+[ 680] By: TimBunce on 1998/03/03 16:23:20
+ Log: Title: "Commenting toke.c", #F048
+ From: gnat@frii.com
+ Msg-ID: <199801082138.OAA14186@prometheus.frii.com>
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 679] By: TimBunce on 1998/03/03 16:18:32
+ Log: Title: "Re: 5.004_04 vec() fails with 32-bit values", #F047
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0xsnr8-0007SS-00@taurus.cus.cam.ac.uk>
+ Files: pod/perlguts.pod pp.c t/op/vec.t
+ Branch: maint-5.004/perl
+ ! pod/perlguts.pod pp.c t/op/vec.t
+____________________________________________________________________________
+[ 678] By: TimBunce on 1998/03/03 16:15:44
+ Log: Title: "A few perl5.004_03 bugs", #F046
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199801221211.MAA05315@crypt.compulink.co.uk>
+ Files: mg.c t/op/magic.t
+ Branch: maint-5.004/perl
+ ! mg.c t/op/magic.t
+____________________________________________________________________________
+[ 677] By: TimBunce on 1998/03/03 16:13:11
+ Log: Title: "Faster, cleaner av_unshift() ", #F045
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <199801221850.TAA23111@furu.g.aas.no>
+ Files: av.c
+ Branch: maint-5.004/perl
+ ! av.c
+____________________________________________________________________________
+[ 676] By: TimBunce on 1998/03/03 16:04:30
+ Log: Title: "New hints/solaris2.sh", #F044
+ From: Stephen Zander <srz@mckesson.com>
+ Msg-ID: <87oh12y458.fsf@wsuse5.mckesson.com>
+ Files: hints/solaris_2.sh
+ Branch: maint-5.004/perl
+ ! hints/solaris_2.sh
+____________________________________________________________________________
+[ 675] By: TimBunce on 1998/03/03 15:33:07
+ Log: Title: "Refresh Complex.pm and test", #F043
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199802051608.SAA20262@alpha.hut.fi>
+ Files: lib/Math/Complex.pm t/lib/complex.t
+ Branch: maint-5.004/perl
+ ! lib/Math/Complex.pm t/lib/complex.t
+____________________________________________________________________________
+[ 674] By: TimBunce on 1998/03/03 15:29:16
+ Log: Title: "Fix (\@@) proto", #F042
+ From: "Joseph N. Hall" <joseph@cscaper.com>
+ Msg-ID: <199801240132.SAA25111@gadget.cscaper.com>
+ Files: op.c t/comp/proto.t
+ Branch: maint-5.004/perl
+ ! op.c t/comp/proto.t
+____________________________________________________________________________
+[ 673] By: TimBunce on 1998/03/03 15:26:31
+ Log: Title: "Allow empty BLOCK in code", #F041
+ From: Vladimir Alexiev <vladimir@cs.ualberta.ca>
+ Msg-ID: <19980129002112Z13378-6931+226@scapa.cs.ualberta.ca>
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 672] By: TimBunce on 1998/03/03 15:23:55
+ Log: Title: "Fix name of $Foo::{'Bar::'}: '*Foo::Bar::'", #F040
+ From: Chip Salzenberg
+ Files: gv.c t/op/gv.t
+ Branch: maint-5.004/perl
+ ! gv.c t/op/gv.t
+____________________________________________________________________________
+[ 671] By: TimBunce on 1998/03/03 10:02:32
+ Log: Title: "Keep accurate reference count on globs' stashes", #F038
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <m3zpk7sd3n.fsf@furu.g.aas.no>
+ Files: gv.c sv.c
+ Branch: maint-5.004/perl
+ ! gv.c sv.c
+____________________________________________________________________________
+[ 670] By: TimBunce on 1998/03/03 09:59:48
+ Log: Title: "Avoid memory allocation in gv_fetchpv(), for speed", #F037
+ From: Chip Salzenberg
+ Files: gv.c
+ Branch: maint-5.004/perl
+ ! gv.c
+____________________________________________________________________________
+[ 669] By: TimBunce on 1998/03/03 09:58:58
+ Log: Title: "Make Configure less negative about PerlIO", #F036
+ From: chip@atlantic.net
+ Msg-ID: <199801312323.SAA15237@cyprus.atlantic.net>
+ Files: Configure
+ Branch: maint-5.004/perl
+ ! Configure
+____________________________________________________________________________
+[ 668] By: TimBunce on 1998/03/03 09:55:51
+ Log: Title: "Fix (mostly) pseudo-same-REs due to embedded NULs", #F035
+ From: Martin Plechsmid <plechsmi@karlin.mff.cuni.cz>
+ Msg-ID: <199802021217.NAA05230@albert.karlin.mff.cuni.cz>
+ Files: pp_ctl.c
+ Branch: maint-5.004/perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 667] By: TimBunce on 1998/03/03 09:52:59
+ Log: Title: "Make Getopt::Long avoid $&, $`, $'", #F034
+ From: Irving Reid <irving@tor.securecomputing.com>
+ Msg-ID: <98Feb3.005102est.11655@janus.tor.securecomputing.com>
+ Files: lib/Getopt/Long.pm
+ Branch: maint-5.004/perl
+ ! lib/Getopt/Long.pm
+____________________________________________________________________________
+[ 666] By: TimBunce on 1998/03/03 09:51:27
+ Log: Title: "adding the newSVpvn API function", #F033
+ From: Matthias Ulrich Neeracher <neeri@iis.ee.ethz.ch>
+ Msg-ID: <199801310532.GAA23798@solar.ethz.ch>
+ Files: pod/perlguts.pod pod/perltoc.pod proto.h global.sym sv.c
+ Branch: maint-5.004/perl
+ ! global.sym pod/perlguts.pod pod/perltoc.pod proto.h sv.c
+____________________________________________________________________________
+[ 665] By: TimBunce on 1998/03/03 09:43:30
+ Log: Title: "Support C<Package::> as function-blind bearword", #F032
+ From: Chip Salzenberg
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 664] By: TimBunce on 1998/03/03 09:41:40
+ Log: Title: "Re-optimize character classes", #F031
+ From: Chip Salzenberg
+ Files: regcomp.h regcomp.c regexec.c
+ Branch: maint-5.004/perl
+ ! regcomp.c regcomp.h regexec.c
+____________________________________________________________________________
+[ 663] By: TimBunce on 1998/03/03 09:39:55
+ Log: Title: "Fix C<if (1) { local $x }> which needed ENTER/LEAVE", #F030
+ From: dfh@dwroll.lucent.com (D461-David_F_Haertig(Dave)83040)
+ Msg-ID: <EnKC0q.6qI@drnews.dr.lucent.com>
+ Files: op.c t/op/local.t
+ Branch: maint-5.004/perl
+ ! op.c t/op/local.t
+____________________________________________________________________________
+[ 662] By: TimBunce on 1998/03/03 09:37:51
+ Log: Title: "Dramatically improve performance of // with parens or $&", #F029
+ From: Chip Salzenberg
+ Files: cop.h perl.h proto.h regexp.h gv.c interp.sym perl.c pp.c pp_ctl.c
+ pp_hot.c regexec.c scope.c
+ Branch: maint-5.004/perl
+ ! cop.h gv.c interp.sym perl.c perl.h pp.c pp_ctl.c pp_hot.c
+ ! proto.h regexec.c regexp.h scope.c
+____________________________________________________________________________
+[ 661] By: TimBunce on 1998/03/03 09:27:04
+ Log: Title: "Don't warn on $x{shift}, ne => 1, or -f => 1", #F028
+ From: Chip Salzenberg
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 660] By: TimBunce on 1998/03/03 09:24:41
+ Log: Title: "Protect against weirdness with unreal @_ in C<local @_>", #F027
+ From: Chip Salzenberg
+ Files: scope.c
+ Branch: maint-5.004/perl
+ ! scope.c
+____________________________________________________________________________
+[ 659] By: TimBunce on 1998/03/03 09:24:00
+ Log: Title: "Fix C<printf "%.0d", 0>", #F026
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199711021331.NAA01826@crypt.compulink.co.uk>
+ Files: sv.c t/op/sprintf.t
+ Branch: maint-5.004/perl
+ ! sv.c t/op/sprintf.t
+____________________________________________________________________________
+[ 658] By: TimBunce on 1998/03/03 09:22:13
+ Log: Title: "Tiny core patch for source filters", #F025
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9711202312.AA02937@claudius.bfsec.bt.co.uk>
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 657] By: TimBunce on 1998/03/03 09:20:00
+ Log: Title: "Here-doc in s///e (was: Bug)", #F024
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199711221445.OAA14153@crypt.compulink.co.uk>
+ Files: t/base/lex.t toke.c
+ Branch: maint-5.004/perl
+ ! t/base/lex.t toke.c
+____________________________________________________________________________
+[ 656] By: TimBunce on 1998/03/03 09:17:56
+ Log: Title: "Fix duplicate warnings on C<-e undef>", #F023
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199711221252.MAA14000@crypt.compulink.co.uk>
+ Files: doio.c t/pragma/warn-1global
+ Branch: maint-5.004/perl
+ ! doio.c t/pragma/warn-1global
+____________________________________________________________________________
+[ 655] By: TimBunce on 1998/03/03 09:16:56
+ Log: Title: "Fix '*' prototype", #F022
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199711212225.RAA00755@monk.mps.ohio-state.edu>
+ Files: toke.c
+ Branch: maint-5.004/perl
+ ! toke.c
+____________________________________________________________________________
+[ 654] By: TimBunce on 1998/03/03 09:15:04
+ Log: Title: "File::Find bugs (and patches)", "File::Find bugs & patches", #F021
+ From: "Conrad E. Kimball" <cek@tblv021.ca.boeing.com>
+ Msg-ID: <199711260703.XAA21257@mailgate2.boeing.com>
+ Files: lib/File/Find.pm
+ Branch: maint-5.004/perl
+ ! lib/File/Find.pm
+____________________________________________________________________________
+[ 653] By: TimBunce on 1998/03/03 09:11:55
+ Log: Title: "Fix typo: FORM{,AT}LINE", #F020
+ From: Chip Salzenberg
+ Files: sv.c
+ Branch: maint-5.004/perl
+ ! sv.c
+____________________________________________________________________________
+[ 652] By: TimBunce on 1998/03/03 09:07:50
+ Log: Title: "Fix use of unref mem when blessed object goes out of scope", #F019
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199711282326.SAA15090@aatma.engin.umich.edu>
+ Files: scope.c
+ Branch: maint-5.004/perl
+ ! scope.c
+____________________________________________________________________________
+[ 651] By: TimBunce on 1998/03/03 09:07:10
+ Log: Title: "Fix C<my ($a, undef, $b) = @x>", #F018
+ From: Stephane Payrard <stef@francenet.fr>
+ Msg-ID: <199712040054.BAA04612@www.zweig.com>
+ Files: op.c t/op/my.t
+ Branch: maint-5.004/perl
+ ! op.c t/op/my.t
+____________________________________________________________________________
+[ 650] By: TimBunce on 1998/03/03 09:04:04
+ Log: Title: "enhanced "use strict" warning", #F017
+ From: Tkil <tkil@reptile.scrye.com>
+ Msg-ID: <199712040938.CAA07628@reptile.scrye.com>
+ Files: gv.c t/pragma/strict-subs t/pragma/strict-vars
+ Branch: maint-5.004/perl
+ ! gv.c t/pragma/strict-subs t/pragma/strict-vars
+____________________________________________________________________________
+[ 649] By: TimBunce on 1998/03/03 09:02:55
+ Log: Title: "eval of sub gives spurious "uninitialised" warning", #F016
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199712061025.FAA14396@aatma.engin.umich.edu>
+ Files: pod/perldelta.pod pod/perlfunc.pod op.c t/op/eval.t
+ Branch: maint-5.004/perl
+ ! op.c pod/perldelta.pod pod/perlfunc.pod t/op/eval.t
+____________________________________________________________________________
+[ 648] By: TimBunce on 1998/03/03 08:58:00
+ Log: Title: "[PERL] Assigning result of pop scrambles unrelated reference", #F015
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199712061100.GAA14864@aatma.engin.umich.edu>
+ Files: sv.c
+ Branch: maint-5.004/perl
+ ! sv.c
+____________________________________________________________________________
+[ 647] By: TimBunce on 1998/03/03 08:53:35
+ Log: Title: "[PERL] Filedescriptor leak in 5.004_55 (and earlier)", #F014
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199712151922.OAA06410@monk.mps.ohio-state.edu>
+ Files: os2/os2.c util.c
+ Branch: maint-5.004/perl
+ ! os2/os2.c util.c
+____________________________________________________________________________
+[ 646] By: TimBunce on 1998/03/03 08:51:04
+ Log: Title: "Fix fdopen() on STD{IN,OUT,ERR}", #F013
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <pzg1npp6e3.fsf@eeyore.ibcinc.com>
+ Files: doio.c t/op/misc.t
+ Branch: maint-5.004/perl
+ ! doio.c t/op/misc.t
+____________________________________________________________________________
+[ 645] By: TimBunce on 1998/03/03 08:49:34
+ Log: Title: "Fix local $a[0] and local $h{a}", #F012
+ From: Stephen McCamant <alias@mcs.com>
+ Msg-ID: <m0xjWFq-000EZeC@alias-2.pr.mcs.net>
+ Files: embed.h scope.h global.sym pp.c pp_hot.c scope.c t/op/local.t
+ Branch: maint-5.004/perl
+ ! embed.h global.sym pp.c pp_hot.c scope.c scope.h t/op/local.t
+____________________________________________________________________________
+[ 644] By: TimBunce on 1998/03/03 08:43:06
+ Log: Title: "Eliminate redundant mg_get() in SvTRUE()", #F011
+ From: Spider Boardman <spider@orb.nashua.nh.us>
+ Msg-ID: <199712251839.NAA14800@Orb.Nashua.NH.US>
+ Files: sv.c
+ Branch: maint-5.004/perl
+ ! sv.c
+____________________________________________________________________________
+[ 643] By: TimBunce on 1998/03/03 08:41:07
+ Log: Title: "Don't force scalar context on C<my @x> or C<my %x>", #F010
+ From: Chip Salzenberg
+ Files: op.c t/op/my.t
+ Branch: maint-5.004/perl
+ ! op.c t/op/my.t
+____________________________________________________________________________
+[ 642] By: TimBunce on 1998/03/03 08:39:11
+ Log: Title: "Fix assignment to $_[0] in DESTROY", #F009
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199801010030.TAA14274@aatma.engin.umich.edu>
+ Files: pod/perlobj.pod sv.c t/op/ref.t
+ Branch: maint-5.004/perl
+ ! pod/perlobj.pod sv.c t/op/ref.t
+____________________________________________________________________________
+[ 641] By: gsar on 1998/03/03 04:39:49
+ Log: merge problematic maintpatch to op.c
+ #77: "Eliminate double warnings under C<package;>"
+ From: Chip Salzenberg
+ Files: gv.c op.c toke.c
+ Branch: win32/perl
+ ! gv.c op.c toke.c
+____________________________________________________________________________
+[ 640] By: gsar on 1998/03/03 04:30:22
+ Log: merge another conflicting maintpatch to op.c
+ #17: "Enhanced "use strict" warning"
+ From: Tkil <tkil@reptile.scrye.com>
+ Msg-ID: <199712040938.CAA07628@reptile.scrye.com>
+ Date: Thu, 4 Dec 1997 02:38:26 -0700
+ Files: gv.c t/pragma/strict-subs t/pragma/strict-vars
+ Branch: win32/perl
+ ! gv.c t/pragma/strict-subs t/pragma/strict-vars
+____________________________________________________________________________
+[ 639] By: gsar on 1998/03/03 04:09:11
+ Log: maintpatch
+ #73: "Fix order of warnings for misplaced subscripts"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199710131023.LAA16796@crypt.compulink.co.uk>
+ Date: Mon, 13 Oct 1997 11:23:56 +0100
+ Files: op.c
+ Branch: win32/perl
+ ! op.c
+____________________________________________________________________________
+[ 638] By: gsar on 1998/03/03 04:02:16
+ Log: manually apply another conflicting maintpatch
+ #64: "Fix extension version mismatch message"
+ From: Chip Salzenberg
+ Files: XSUB.h
+ Branch: win32/perl
+ ! XSUB.h
+____________________________________________________________________________
+[ 637] By: gsar on 1998/03/03 03:57:08
+ Log: maintpatch
+ #62: "Fix doc bug in getservbyname() examples"
+ From: Tom Christiansen
+ Files: ext/Socket/Socket.pm
+ Branch: win32/perl
+ ! ext/Socket/Socket.pm
+____________________________________________________________________________
+[ 636] By: gsar on 1998/03/03 03:55:13
+ Log: maintpatch
+ #60: "Socket occasional SEGV"
+ From: Trevor Blackwell <tlb@viaweb.com>
+ Msg-ID: <199710281804.NAA09632@wagg.viaweb.com>
+ Date: Tue, 28 Oct 1997 13:04:43 -0500 (EST)
+ Files: ext/Socket/Socket.xs
+ Branch: win32/perl
+ ! ext/Socket/Socket.xs
+____________________________________________________________________________
+[ 635] By: gsar on 1998/03/03 03:51:01
+ Log: maintpatches for docs
+ #53: "Perlop bitwise & | ^ documentation"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.971106073858.29771O-100000@usertest.teleport.c
+ Date: Thu, 6 Nov 1997 07:44:52 -0800 (PST)
+ Files: pod/perlfunc.pod
+ --------
+ #54: "Update docs on tr///"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.971103071602.10568C-100000@usertest.teleport.c
+ Date: Mon, 3 Nov 1997 07:28:39 -0800 (PST)
+ Files: pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod
+ pod/perllocale.pod pod/perlmod.pod pod/perlop.pod
+ pod/perlstyle.pod toke.c
+ Branch: win32/perl
+ ! pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod
+ ! pod/perllocale.pod pod/perlmod.pod pod/perlop.pod
+ ! pod/perlstyle.pod toke.c
+____________________________________________________________________________
+[ 634] By: gsar on 1998/03/03 03:43:42
+ Log: another maintpatch (this one needed adjust of test nos.)
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Message-Id: <199801221211.MAA05315@crypt.compulink.co.uk>
+ Date: Thu, 22 Jan 1998 12:11:49 +0000
+ Subject: Re: [PERL] A few perl5.004_03 bugs
+ Branch: win32/perl
+ ! mg.c t/op/magic.t
+____________________________________________________________________________
+[ 633] By: gsar on 1998/03/03 03:36:40
+ Log: merge another toke.c patch and its dependent (very carefully)
+ #32: "Support C<Package::> as function-blind bearword"
+ From: Chip Salzenberg
+ Files: toke.c
+ --------
+ #86: "Make warning on C<Nosuch::> optional, add to perl{diag,delta}.pod"
+ From: Gurusamy Sarathy
+ Files: toke.c pod/perldelta.pod pod/perldiag.pod
+ Branch: win32/perl
+ ! pod/perldelta.pod pod/perldiag.pod toke.c
+____________________________________________________________________________
+[ 632] By: gsar on 1998/03/03 03:12:16
+ Log: another toke.c maintpatch
+ #28: "Don't warn on $x{shift}, ne => 1, or -f => 1"
+ From: Chip Salzenberg
+ Files: toke.c
+ Branch: win32/perl
+ ! toke.c
+____________________________________________________________________________
+[ 631] By: gsar on 1998/03/03 03:06:59
+ Log: still another maintpatch
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Message-Id: <199711021331.NAA01826@crypt.compulink.co.uk>
+ Date: Sun, 02 Nov 1997 13:31:54 +0000
+ Subject: [PATCH] assorted sprintf bugs
+ Branch: win32/perl
+ ! sv.c t/op/sprintf.t
+____________________________________________________________________________
+[ 630] By: gsar on 1998/03/03 03:03:55
+ Log: yet another maintpatch
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Message-Id: <199711221252.MAA14000@crypt.compulink.co.uk>
+ Date: Sat, 22 Nov 1997 12:52:16 +0000
+ Subject: Re: [PERL] Unexpected output
+ Branch: win32/perl
+ ! doio.c t/pragma/warn-1global
+____________________________________________________________________________
+[ 629] By: gsar on 1998/03/03 02:57:33
+ Log: merge another maintpatch to toke.c
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Date: Sat, 22 Nov 1997 14:45:23 GMT
+ Message-Id: <199711221445.OAA14153@crypt.compulink.co.uk>
+ Subject: Re: [PERL] Here-doc in s///e (was: Bug)
+ Branch: win32/perl
+ ! t/base/lex.t toke.c
+____________________________________________________________________________
+[ 628] By: gsar on 1998/03/03 02:50:20
+ Log: manually merge a maintpatch
+ Date: Thu, 8 Jan 1998 14:38:04 -0700 (MST)
+ Message-Id: <199801082138.OAA14186@prometheus.frii.com>
+ From: gnat@frii.com
+ Subject: [PERL] Commenting toke.c
+ Branch: win32/perl
+ ! toke.c
+____________________________________________________________________________
+[ 627] By: TimBunce on 1998/03/02 22:34:47
+ Log: Title: "Fix inefficient checks for TIEHANDLE", #F008
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199801080106.UAA05048@aatma.engin.umich.edu>
+ Files: pp_hot.c pp_sys.c
+ Branch: maint-5.004/perl
+ ! pp_hot.c pp_sys.c
+____________________________________________________________________________
+[ 626] By: TimBunce on 1998/03/02 22:31:13
+ Log: This is the change description for change 625
+ Title: "Fix tr///s option", #F007
+ From: Inaba Hiroto <inaba@st.rim.or.jp>
+ Msg-ID: <19980110155333D.inaba@st.rim.or.jp>
+ Files: doop.c
+ Branch: maint-5.004/perl
+ ! doop.c
+____________________________________________________________________________
+[ 625] By: TimBunce on 1998/03/02 22:23:48
+ Log: Branch: maint-5.004/perl
+ ! doop.c
+____________________________________________________________________________
+[ 623] By: TimBunce on 1998/03/02 21:51:53
+ Log: Title: "Fix lexical lookup in eval-sub-eval", #F006
+ From: Chip Salzenberg
+ Files: pp_ctl.c
+ Branch: maint-5.004/perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 622] By: TimBunce on 1998/03/02 21:43:29
+ Log: Title: "Don't upgrade target of assignment from LVALUE", #F005
+ From: Chip Salzenberg
+ Files: sv.c
+ Branch: maint-5.004/perl
+ ! sv.c
+____________________________________________________________________________
+[ 621] By: TimBunce on 1998/03/02 21:29:59
+ Log: Title: "Fix compile-time warning line in while ()", #F004
+ From: Chip Salzenberg
+ Files: op.c
+ Branch: maint-5.004/perl
+ ! op.c
+____________________________________________________________________________
+[ 620] By: TimBunce on 1998/03/02 21:25:27
+ Log: Title: "STMT foreach LIST;", #F002
+ From: Chip Salzenberg
+ Files: pod/perlsyn.pod perly.c perly.c.diff perly.y t/cmd/mod.t toke.c
+ vms/perly_c.vms
+ Branch: maint-5.004/perl
+ ! perly.c perly.c.diff perly.y pod/perlsyn.pod t/cmd/mod.t
+ ! toke.c vms/perly_c.vms
+____________________________________________________________________________
+[ 619] By: TimBunce on 1998/03/02 21:12:58
+ Log: Title: "Fix SIGSEGV on C<42 until forever>", #F001
+ From: Chip Salzenberg
+ Files: op.c
+ Branch: maint-5.004/perl
+ ! op.c
+____________________________________________________________________________
+[ 618] By: gsar on 1998/03/02 04:40:16
+ Log: make t/lib/nothread.t type xtext also
+ Branch: win32/perl
+ ! t/op/nothread.t
+____________________________________________________________________________
+[ 617] By: gsar on 1998/03/02 04:35:15
+ Log: make t/lib/thread.t type xtext
+ Branch: win32/perl
+ ! t/lib/thread.t
+____________________________________________________________________________
+[ 616] By: gsar on 1998/03/02 04:17:40
+ Log: fix misapplied hunks in change#614
+ Branch: win32/perl
+ ! scope.c scope.h
+____________________________________________________________________________
+[ 615] By: gsar on 1998/03/02 03:39:16
+ Log: another one down
+ From: "Conrad E. Kimball" <cek@tblv021.ca.boeing.com>
+ Message-Id: <199711260703.XAA21257@mailgate2.boeing.com>
+ Date: Tue, 25 Nov 1997 23:03:48 -0800
+ Subject: [PERL] File::Find bugs & patches
+ Branch: win32/perl
+ ! lib/File/Find.pm
+____________________________________________________________________________
+[ 614] By: gsar on 1998/03/02 03:28:28
+ Log: this one with adjusted test numbers
+ Message-Id: <m0xjWFq-000EZeC@alias-2.pr.mcs.net>
+ Date: Sat, 20 Dec 1997 15:16:14 -0600 (CST)
+ From: Stephen McCamant <alias@mcs.com>
+ Subject: [PERL] [PATCH] Fix local $a[0] and local $h{a}
+ Branch: win32/perl
+ ! embed.h global.sym pp.c pp_hot.c scope.c scope.h t/op/local.t
+____________________________________________________________________________
+[ 613] By: gsar on 1998/03/02 03:13:32
+ Log: still another
+ From: Inaba Hiroto <inaba@st.rim.or.jp>
+ Subject: [PERL] tr///s bug
+ Message-Id: <19980110155333D.inaba@st.rim.or.jp>
+ Date: Sat, 10 Jan 1998 15:53:33 +0900
+ Branch: win32/perl
+ ! doop.c t/op/subst.t
+____________________________________________________________________________
+[ 612] By: gsar on 1998/03/02 03:01:27
+ Log: yet another patch
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Message-Id: <199709161748.NAA08418@nielsenmedia.com>
+ Subject: Tiny but massively cool: C<statement foreach @list>
+ Date: Tue, 16 Sep 1997 13:47:28 -0400 (EDT)
+ Branch: win32/perl
+ ! perly.c perly.c.diff perly.y pod/perlsyn.pod t/cmd/mod.t
+ ! toke.c vms/perly_c.vms
+____________________________________________________________________________
+[ 611] By: gsar on 1998/03/02 01:52:46
+ Log: yet another 'old' patch
+ From: Stephane Payrard <stef@francenet.fr>
+ Message-Id: <199712040054.BAA04612@www.zweig.com>
+ To: perl5-porters@perl.org
+ Subject: Re: [PERL] buglet : minor but gratuitous inconsistency
+ between `my' and `local' (Patch included)
+ Branch: win32/perl
+ ! op.c t/op/my.t
+____________________________________________________________________________
+[ 610] By: gsar on 1998/03/02 01:45:55
+ Log: another 'old' patch
+ From: Roderick Schertler <roderick@argon.org>
+ Date: 19 Dec 1997 12:52:36 -0500
+ Message-Id: <pzg1npp6e3.fsf@eeyore.ibcinc.com>
+ Subject: [PERL] [PATCH] Re: Problem with open >&=
+ Branch: win32/perl
+ ! doio.c t/op/misc.t
+____________________________________________________________________________
+[ 609] By: gsar on 1998/03/02 01:23:56
+ Log: apply missing pieces from:
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Message-Id: <199711272044.PAA12102@nielsenmedia.com>
+ Subject: [PATCH] Improved LVALUE patch
+ Date: Thu, 27 Nov 1997 15:44:02 -0500 (EST)
+ Branch: win32/perl
+ ! sv.c
+____________________________________________________________________________
+[ 608] By: gsar on 1998/03/02 01:13:01
+ Log: merge two important 'old' patches
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Message-Id: <199709241632.MAA09164@nielsenmedia.com>
+ Subject: [PATCH] Fix C<42 until forever> SIGSEGV
+ Date: Wed, 24 Sep 1997 12:32:11 -0400 (EDT)
+ ------
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Message-Id: <199710221332.JAA04814@nielsenmedia.com>
+ Subject: [PATCH] Fix for compile-time while() warnings
+ Date: Wed, 22 Oct 1997 09:31:50 -0400 (EDT)
+ Branch: win32/perl
+ ! op.c
+____________________________________________________________________________
+[ 607] By: gsar on 1998/03/01 06:52:26
+ Log: integrate mainline changes
+ Branch: asperl
+ +> Policy_sh.SH Porting/config.sh Porting/config_H atomic.h
+ +> lib/Tie/Handle.pm t/op/tiehandle.t
+ - config_H
+ !> (integrate 89 files)
+____________________________________________________________________________
+[ 606] By: gsar on 1998/02/28 23:11:00
+ Log: misc small tweaks
+ - AutoLoader fix for long::pack::names
+ - d_mymalloc can be set from makefiles now
+ - make search.pl actually work on win32
+ - revert podoc about $^E on OS/2 (per Ilya's wishes)
+ Branch: win32/perl
+ ! lib/AutoLoader.pm pod/perlvar.pod win32/Makefile
+ ! win32/bin/search.pl win32/makefile.mk win32/win32.c
+____________________________________________________________________________
+[ 605] By: gsar on 1998/02/28 22:16:45
+ Log: fix typo in sv.h, and run 'make regen_headers' to make it build
+ Branch: win32/perl
+ ! embedvar.h sv.h
+____________________________________________________________________________
+[ 604] By: gsar on 1998/02/28 21:08:58
+ Log: integrate mainline
+ Branch: win32/perl
+ +> Policy_sh.SH atomic.h lib/Tie/Handle.pm t/op/tiehandle.t
+ !> Configure MANIFEST Makefile.SH bytecode.h bytecode.pl
+ !> byterun.c ext/SDBM_File/Makefile.PL
+ !> ext/SDBM_File/sdbm/Makefile.PL ext/SDBM_File/sdbm/sdbm.h
+ !> lib/ExtUtils/MM_VMS.pm os2/diff.configure os2/os2.c perl.c
+ !> perlvars.h pod/perltie.pod pp_sys.c sv.c sv.h t/lib/anydbm.t
+ !> t/lib/sdbm.t util.c vms/descrip.mms vms/perlvms.pod
+ !> vms/test.com win32/makedef.pl
+____________________________________________________________________________
+[ 603] By: nick on 1998/02/28 11:31:15
+ Log: Missed FREAD in bytecode.h
+ Cannot export svref_mutex in non-threaded perl
+ Branch: perl
+ ! bytecode.h win32/makedef.pl
+
+----------------
+Version 5.004_61
+----------------
+
+____________________________________________________________________________
+[ 602] By: mbeattie on 1998/02/27 18:35:27
+ Log: Change FREAD/FGETC to BGET_FREAD/BGET_FGETC to avoid clash with
+ preprocessor symbol on Digital UNIX.
+ Branch: perl
+ ! bytecode.h bytecode.pl byterun.c
+____________________________________________________________________________
+[ 601] By: mbeattie on 1998/02/27 18:27:00
+ Log: Fix stupid ATOMIC_DEC_AND_TEST typo in sv.h.
+ Branch: perl
+ ! sv.h
+____________________________________________________________________________
+[ 600] By: mbeattie on 1998/02/27 18:15:07
+ Log: Add atomic.h to MANIFEST
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 599] By: mbeattie on 1998/02/27 18:13:52
+ Log: Integrate win32 branch into mainline.
+ Branch: perl
+ ! bytecode.pl
+ !> bytecode.h byterun.c byterun.h dosish.h embed.h embedvar.h
+ !> ext/B/B.xs ext/B/Makefile.PL global.sym perl.h sv.c
+ !> win32/Makefile win32/bin/pl2bat.pl win32/config.bc
+ !> win32/config.gc win32/config.vc win32/config_H.bc
+ !> win32/config_H.gc win32/config_H.vc win32/config_h.PL
+ !> win32/makedef.pl win32/makefile.mk win32/win32.c win32/win32.h
+ !> win32/win32thread.h
+____________________________________________________________________________
+[ 598] By: mbeattie on 1998/02/27 18:06:41
+ Log: Make refcounts atomic for threading (dependent on appropriate
+ arch-dependent and compiler-dependent definitions in atomic.h
+ or else falls back to a global mutex to protect refcounts).
+ Branch: perl
+ + atomic.h
+ ! global.sym perl.c perlvars.h sv.c sv.h
+____________________________________________________________________________
+[ 597] By: mbeattie on 1998/02/27 15:37:22
+ Log: Tiehandle stuff in change 595 didn't add to MANIFEST
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 596] By: mbeattie on 1998/02/27 15:34:55
+ Log: Missed adding new file Policy_sh.SH in change 592.
+ Branch: perl
+ + Policy_sh.SH
+____________________________________________________________________________
+[ 595] By: mbeattie on 1998/02/27 15:34:06
+ Log: Subject: [PATCH] _60 & _04 - Add WRITE & CLOSE to TIEHANDLE
+ Date: Fri, 27 Feb 1998 04:15:04 +0000
+ From: Graham Barr <gbarr@pobox.com>
+ Branch: perl
+ + lib/Tie/Handle.pm t/op/tiehandle.t
+ ! pod/perltie.pod pp_sys.c
+____________________________________________________________________________
+[ 594] By: mbeattie on 1998/02/27 15:31:12
+ Log: From: Dan Sugalski <sugalskd@osshe.edu>
+ Subject: [PATCH 5.004_60] Fix to MM_VMS.PM
+ Date: Thu, 26 Feb 1998 11:09:55 -0800
+ Subject: [PATCH 5.004_60] Get SDBM_File working on VMS
+ Date: Thu, 26 Feb 1998 11:15:24 -0800
+ Branch: perl
+ ! ext/SDBM_File/Makefile.PL ext/SDBM_File/sdbm/Makefile.PL
+ ! ext/SDBM_File/sdbm/sdbm.h lib/ExtUtils/MM_VMS.pm
+ ! t/lib/anydbm.t t/lib/sdbm.t vms/descrip.mms vms/perlvms.pod
+ ! vms/test.com
+____________________________________________________________________________
+[ 593] By: mbeattie on 1998/02/27 15:26:45
+ Log: Fix file-descriptor leak when pipes fail via taint checks:
+ Subject: [PATCH] Some patches went through cracks
+ Date: Thu, 26 Feb 1998 02:47:46 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! os2/os2.c util.c
+____________________________________________________________________________
+[ 592] By: mbeattie on 1998/02/27 15:15:12
+ Log: Subject: Config_60-03-04.diff patch for 5.004_60
+ Date: Wed, 25 Feb 1998 17:14:39 -0500 (EST)
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Branch: perl
+ ! Configure MANIFEST Makefile.SH os2/diff.configure
+____________________________________________________________________________
+[ 591] By: gsar on 1998/02/26 19:34:50
+ Log: added AS patch#9
+ Branch: asperl
+ - win32/ipdir.c win32/ipenv.c win32/iplio.c win32/ipmem.c
+ - win32/ipproc.c win32/ipsock.c win32/ipstdio.c
+ - win32/ipstdiowin.h win32/perlobj.def
+ ! ObjXSub.h globals.c perl.c proto.h win32/Makefile
+ ! win32/dl_win32.xs win32/runperl.c win32/win32.c win32/win32.h
+ ! win32/win32sck.c win32/win32thread.c
+____________________________________________________________________________
+[ 590] By: gsar on 1998/02/26 04:25:40
+ Log: various changes to make win32 build under the new Configure & co.
+ - added byterun.c to core C build
+ - makefile.mk now has a regen_config_h target to quickly update config_H.[bgv]c
+ after adding new variables to config.[bgv]c
+ - sig_name_init now has only the valid signals
+ - we now have $Config{usethreads}
+ - tested under the two commercial compilers w/ and w/o usethreads
+ Branch: win32/perl
+ ! win32/Makefile win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/config_h.PL win32/makedef.pl win32/makefile.mk
+____________________________________________________________________________
+[ 589] By: gsar on 1998/02/26 03:56:19
+ Log: various cleanups so that B can be built as "just another extension"
+ - export symbols needed for building B
+ - bset_obj_store() is needed by byterun(), so define it there instead
+ of at B.xs, and export it
+ - freadpv() is only used in B.xs, so move it there
+ - byte*.h are now included by perl.h
+ - regenerate embed*.h
+ Branch: win32/perl
+ ! bytecode.h bytecode.pl byterun.c byterun.h embed.h embedvar.h
+ ! ext/B/B.xs ext/B/Makefile.PL global.sym perl.h
+____________________________________________________________________________
+[ 588] By: gsar on 1998/02/25 21:46:35
+ Log: integrate mainline
+ Branch: win32/perl
+ +> Porting/config.sh Porting/config_H
+ - config_H
+ !> (integrate 54 files)
+____________________________________________________________________________
+[ 587] By: gsar on 1998/02/25 19:20:26
+ Log: added AS patch#8
+ Branch: asperl
+ ! sv.c x2p/a2py.c x2p/util.c
+____________________________________________________________________________
+[ 586] By: gsar on 1998/02/25 19:08:06
+ Log: added AS patch#7
+ Message-Id: <01BD40F9.CE57B210.dougl@ActiveState.com>
+ Date: Tue, 24 Feb 1998 07:57:07 PST
+ From: Douglas Lankshear <dougl@ActiveState.com>
+ Subject: [PATCH]
+
+ Here's an attempt at
+ 6. MANIFEST must be updated with new file names
+ 5. Mktime(), Stat() etc., rather than MKtime()/STat() etc.
+ And some changes to move toward
+ 1. Merge PERL_OBJECT build support into regular Makefile and makefile.mk
+
+ -- Doug
+ Branch: asperl
+ ! MANIFEST installperl ipdir.h ipenv.h iplio.h ipmem.h ipproc.h
+ ! ipsock.h ipstdio.h lib/ExtUtils/MM_Win32.pm perldir.h
+ ! perlenv.h perlio.h perllio.h win32/Makefile
+____________________________________________________________________________
+[ 585] By: mbeattie on 1998/02/25 17:44:34
+ Log: More compiler tweaks.
+ Branch: perl
+ ! Makefile.SH bytecode.pl byterun.c byterun.h ext/B/B/Asmdata.pm
+____________________________________________________________________________
+[ 584] By: mbeattie on 1998/02/25 15:36:38
+ Log: Subject: [PATCH 5.004_60] dos-djgpp update
+ Date: Wed, 25 Feb 1998 11:17:07 +0100
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Branch: perl
+ ! djgpp/djgpp.c dosish.h hints/dos_djgpp.sh perl.c thread.h
+____________________________________________________________________________
+[ 583] By: mbeattie on 1998/02/25 15:34:48
+ Log: Move find_threadsv to right bit of global.sym. Bump patchlevel to 61.
+ Branch: perl
+ ! global.sym patchlevel.h
+____________________________________________________________________________
+[ 582] By: mbeattie on 1998/02/25 15:28:08
+ Log: Subject: Re: [PATCH 5.004_60] Fix goto-in-eval segfault (unwrapped!)
+ Date: Tue, 24 Feb 1998 11:15:57 +0000
+ From: Robin Houston <robin@oneworld.org>
+ Branch: perl
+ ! pod/perldiag.pod pp_ctl.c
+____________________________________________________________________________
+[ 581] By: mbeattie on 1998/02/25 15:27:06
+ Log: Subject: [PATCH] #ifdef CAN_PROTOTYPE cleanup
+ Date: 23 Feb 1998 23:36:09 +0100
+ From: Gisle Aas <gisle@aas.no>
+ Branch: perl
+ ! doio.c miniperlmain.c op.c perl.c pp.h regcomp.c toke.c util.c
+____________________________________________________________________________
+[ 580] By: mbeattie on 1998/02/25 15:25:29
+ Log: Subject: [PATCH 5.004_60] improved Test.pm
+ Date: Sat, 21 Feb 1998 14:17:09 -0500
+ From: Joshua Pritikin <pritikin@mindspring.com>
+ Branch: perl
+ ! lib/Test.pm
+____________________________________________________________________________
+[ 579] By: mbeattie on 1998/02/25 15:23:24
+ Log: HP-UX hints and AIX global.sym changes (with Makefile.SH rule)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Subject: [PATCH] 5.004_60: AIX: global.sym and Makefile.SH
+ Date: Sat, 21 Feb 1998 15:26:19 +0200 (EET)
+ Subject: Re: your HP-UX perl patch
+ Date: Mon, 23 Feb 1998 23:14:37 +0200 (EET)
+ Branch: perl
+ ! Makefile.SH embed.h global.sym hints/hpux.sh
+____________________________________________________________________________
+[ 578] By: mbeattie on 1998/02/25 15:18:06
+ Log: Back out DB_File patch (change _553) and tweak Configure.
+ Subject: ANNOUNCE: perl5.004_60 is available
+ Date: Mon, 23 Feb 1998 10:47:26 -0000
+ From: Paul Marquess <pmarquess@bfsec.bt.co.uk>
+ Branch: perl
+ ! Configure ext/DB_File/DB_File.xs
+____________________________________________________________________________
+[ 577] By: mbeattie on 1998/02/25 15:04:00
+ Log: Subject: [PATCH] Cwd.pm
+ Date: Fri, 20 Feb 1998 10:27:54 -0600
+ From: Graham Barr <gbarr@ti.com>
+ Branch: perl
+ ! lib/Cwd.pm
+____________________________________________________________________________
+[ 576] By: mbeattie on 1998/02/25 15:02:57
+ Log: From: ilya@math.ohio-state.edu (Ilya Zakharevich)
+ Subject: [5.004_5* PATCH] Make ornaments default in Term::ReadLine
+ Date: Fri, 20 Feb 1998 00:09:52 -0500 (EST)
+ Subject: [PATCH 5.004_5*] Fix debugger messages and the default package
+ Date: Fri, 20 Feb 1998 00:12:28 -0500 (EST)
+ Subject: Re: Continued presence of segmentation violation in study_chunk()[PATCH]
+ Date: Sat, 21 Feb 1998 15:32:29 -0500 (EST)
+ Branch: perl
+ ! lib/Term/ReadLine.pm lib/perl5db.pl regcomp.c
+____________________________________________________________________________
+[ 575] By: mbeattie on 1998/02/25 14:58:00
+ Log: Subject: Re: ANNOUNCE: perl5.004_60 Configure patch is available
+ Date: Tue, 24 Feb 1998 16:02:43 -0500 (EST)
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Branch: perl
+ + Porting/config.sh Porting/config_H
+ - config_H
+ ! Configure INSTALL MANIFEST Makefile.SH Porting/Glossary
+ ! Porting/pumpkin.pod config_h.SH ext/POSIX/POSIX.xs
+ ! hints/aix.sh hints/amigaos.sh hints/bsdos.sh hints/dec_osf.sh
+ ! hints/freebsd.sh hints/irix_6.sh hints/linux.sh
+ ! hints/netbsd.sh hints/next_3.sh hints/next_4.sh hints/os2.sh
+ ! hints/solaris_2.sh makedepend.SH perl.c perl.h pp.c pp_sys.c
+ ! t/lib/thread.t t/op/nothread.t x2p/Makefile.SH
+____________________________________________________________________________
+[ 574] By: gsar on 1998/02/24 02:21:14
+ Log: fix typos in sv.c
+ Branch: win32/perl
+ ! sv.c
+____________________________________________________________________________
+[ 573] By: mbeattie on 1998/02/23 10:03:39
+ Log: Remove old Linux+threads segfault degugging kludge.
+ Branch: perl
+ ! perl.c
+____________________________________________________________________________
+[ 572] By: gsar on 1998/02/23 09:45:26
+ Log: undo previous change (no added value!)
+ Branch: win32/perl
+ ! win32/bin/pl2bat.pl
+____________________________________________________________________________
+[ 571] By: gsar on 1998/02/23 09:18:32
+ Log: fix pl2bat.pl to tolerate trailing .bat (as suggested by
+ John Cavanaugh <cavanaug@sdd.hp.com>)
+ Branch: win32/perl
+ ! win32/bin/pl2bat.pl
+____________________________________________________________________________
+[ 570] By: gsar on 1998/02/22 04:02:15
+ Log: support chown() (just a noop for now)
+ Branch: win32/perl
+ ! dosish.h win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 569] By: gsar on 1998/02/22 03:09:55
+ Log: integrate latest win32 branch
+ Branch: asperl
+ +> (branch 41 files)
+ !> (integrate 59 files)
+____________________________________________________________________________
+[ 568] By: gsar on 1998/02/22 02:40:56
+ Log: get compiler building under win32 (needed Makefile.PL
+ hacks that could be applicable to other platforms)
+ Branch: win32/perl
+ ! ext/B/Makefile.PL win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 567] By: gsar on 1998/02/22 01:30:19
+ Log: integrate mainline
+ Branch: win32/perl
+ +> (branch 41 files)
+ !> (integrate 46 files)
+____________________________________________________________________________
+[ 566] By: gsar on 1998/02/20 22:31:56
+ Log: fix handle leak in join()
+ Branch: win32/perl
+ ! win32/win32thread.h
+
+----------------
+Version 5.004_60
+----------------
+
+____________________________________________________________________________
+[ 565] By: mbeattie on 1998/02/20 18:23:47
+ Log: Remove compiler files from their old lib/B locations. The compiler
+ now builds by default (without the byteperl executable so far) and
+ seems to work at least minimally.
+ Branch: perl
+ - lib/B.pm lib/B/Asmdata.pm lib/B/Assembler.pm lib/B/Bblock.pm
+ - lib/B/Bytecode.pm lib/B/C.pm lib/B/CC.pm lib/B/Debug.pm
+ - lib/B/Deparse.pm lib/B/Disassembler.pm lib/B/Lint.pm
+ - lib/B/Showlex.pm lib/B/Stackobj.pm lib/B/Terse.pm
+ - lib/B/Xref.pm lib/B/assemble lib/B/cc_harness
+ - lib/B/disassemble lib/B/makeliblinks lib/O.pm
+ ! MANIFEST bytecode.pl
+____________________________________________________________________________
+[ 564] By: mbeattie on 1998/02/20 18:05:33
+ Log: Move lib/B/... and lib/[BO].pm over to where they should be,
+ under ext/B.
+ Branch: perl
+ +> ext/B/B.pm ext/B/B/Asmdata.pm ext/B/B/Assembler.pm
+ +> ext/B/B/Bblock.pm ext/B/B/Bytecode.pm ext/B/B/C.pm
+ +> ext/B/B/CC.pm ext/B/B/Debug.pm ext/B/B/Deparse.pm
+ +> ext/B/B/Disassembler.pm ext/B/B/Lint.pm ext/B/B/Showlex.pm
+ +> ext/B/B/Stackobj.pm ext/B/B/Terse.pm ext/B/B/Xref.pm
+ +> ext/B/B/assemble ext/B/B/cc_harness ext/B/B/disassemble
+ +> ext/B/B/makeliblinks ext/B/O.pm
+____________________________________________________________________________
+[ 563] By: mbeattie on 1998/02/20 17:54:58
+ Log: Start getting compiler to work when built with the core.
+ [Still won't work as of this change.]
+ Branch: perl
+ +> byterun.c byterun.h lib/B/Asmdata.pm lib/B/Assembler.pm
+ +> lib/B/Bblock.pm lib/B/Bytecode.pm lib/B/C.pm lib/B/CC.pm
+ +> lib/B/Debug.pm lib/B/Deparse.pm lib/B/Disassembler.pm
+ +> lib/B/Lint.pm lib/B/Showlex.pm lib/B/Stackobj.pm
+ +> lib/B/Terse.pm lib/B/Xref.pm
+ ! MANIFEST Makefile.SH bytecode.pl ext/B/Makefile.PL
+____________________________________________________________________________
+[ 562] By: mbeattie on 1998/02/20 16:42:13
+ Log: Merge perlext/Compiler/... into mainline. Some files move to
+ ext/B/..., some to lib/B/..., O.pm and B.pm go in lib and some
+ move to the base perl directory (e.g. headers). Will need some
+ cleaning up before it builds properly, I would guess.
+ Branch: perl
+ +> bytecode.h bytecode.pl cc_runtime.h ext/B/B.xs
+ +> ext/B/Makefile.PL ext/B/NOTES ext/B/README ext/B/TESTS
+ +> ext/B/Todo ext/B/byteperl.c ext/B/ramblings/cc.notes
+ +> ext/B/ramblings/curcop.runtime ext/B/ramblings/flip-flop
+ +> ext/B/ramblings/magic ext/B/ramblings/reg.alloc
+ +> ext/B/ramblings/runtime.porting ext/B/typemap lib/B.pm
+ +> lib/B/assemble lib/B/cc_harness lib/B/disassemble
+ +> lib/B/makeliblinks lib/O.pm
+____________________________________________________________________________
+[ 561] By: mbeattie on 1998/02/20 16:39:38
+ Log: Win32 changes from Sarathy, tweaked slightly by me.
+ Branch: perlext
+ ! Compiler/B.xs Compiler/B/Asmdata.pm Compiler/B/Bytecode.pm
+ ! Compiler/B/C.pm Compiler/Makefile.PL Compiler/assemble
+ ! Compiler/bytecode.h Compiler/bytecode.pl Compiler/byteperl.c
+ ! Compiler/byterun.c Compiler/byterun.h Compiler/cc_harness
+____________________________________________________________________________
+[ 560] By: mbeattie on 1998/02/20 15:46:15
+ Log: Initialise $@ early (fixes t/lib/ph.t for threaded perl).
+ Branch: perl
+ ! perl.c
+____________________________________________________________________________
+[ 559] By: mbeattie on 1998/02/20 12:56:10
+ Log: Add missing t/op/wantarray.t to MANIFEST. Bump patchlevel to 60.
+ Branch: perl
+ ! MANIFEST patchlevel.h
+____________________________________________________________________________
+[ 558] By: mbeattie on 1998/02/20 12:53:26
+ Log: Integrate win32 branch into mainline.
+ Branch: perl
+ !> XSUB.h config_h.SH doio.c lib/Pod/Html.pm pp_sys.c
+ !> win32/Makefile win32/config.bc win32/config.gc win32/config.vc
+ !> win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ !> win32/makedef.pl win32/makefile.mk win32/win32.c win32/win32.h
+ !> win32/win32iop.h x2p/a2p.h
+____________________________________________________________________________
+[ 557] By: mbeattie on 1998/02/20 12:51:42
+ Log: Subject: retry [PATCH] 5.004_59: the perlhist.pod etc
+ Date: Thu, 19 Feb 1998 17:54:52 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! ext/Thread/Thread.pm ext/Thread/Thread/Queue.pm
+ ! ext/Thread/Thread/Semaphore.pm ext/Thread/Thread/Specific.pm
+ ! lib/fields.pm pod/buildtoc pod/perl.pod pod/perlhist.pod
+ ! pod/perltoc.pod pod/perlvar.pod
+____________________________________________________________________________
+[ 556] By: mbeattie on 1998/02/20 12:49:54
+ Log: Subject: [PATCH] installperl
+ Date: Wed, 18 Feb 1998 11:51:44 -0500 (est)
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Branch: perl
+ ! installperl
+____________________________________________________________________________
+[ 555] By: mbeattie on 1998/02/20 12:49:09
+ Log: Subject: [PATCH:_59] t/op/wantarray.t
+ Date: Wed, 18 Feb 1998 11:19:54 -0500 (est)
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Branch: perl
+ + t/op/wantarray.t
+____________________________________________________________________________
+[ 554] By: mbeattie on 1998/02/20 12:47:44
+ Log: Subject: Misprint in regcomp.c [PATCH]
+ Date: Tue, 17 Feb 1998 23:54:07 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! regcomp.c
+____________________________________________________________________________
+[ 553] By: mbeattie on 1998/02/20 12:45:08
+ Log: Subject: DB_File ->length does not work just after tie.
+ Date: Tue, 17 Feb 1998 13:19:18 GMT
+ From: Nick Ing-Simmons <nik@tiuk.ti.com>
+ Branch: perl
+ ! ext/DB_File/DB_File.xs
+____________________________________________________________________________
+[ 552] By: mbeattie on 1998/02/20 12:43:32
+ Log: Subject: [PATCH] - perl5.005_59, update Copyright
+ Date: Mon, 16 Feb 1998 20:31:06 -0500 (EST)
+ From: lusol@CS4.CC.Lehigh.EDU (Stephen O. Lidie)
+ Branch: perl
+ ! perl.c
+____________________________________________________________________________
+[ 551] By: mbeattie on 1998/02/20 12:42:41
+ Log: Subject: Re: for() and map() peculiarity
+ Date: Mon, 16 Feb 1998 21:33:44 +0000
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Branch: perl
+ ! pod/perlsyn.pod
+____________________________________________________________________________
+[ 550] By: mbeattie on 1998/02/20 12:41:53
+ Log: Subject: [PATCH 5.004_59] Updates to VMS/CONFIG.VMS
+ Date: Mon, 16 Feb 1998 11:46:29 -0800
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Branch: perl
+ ! vms/config.vms
+____________________________________________________________________________
+[ 549] By: mbeattie on 1998/02/20 12:40:55
+ Log: Subject: [PATCH] 5.004_59 global.sym for AIX 3.2.5
+ Date: Mon, 16 Feb 1998 14:27:53 -0500 (EST)
+ From: "Stephen O. Lidie" <lusol@turkey.cc.Lehigh.EDU>
+ Branch: perl
+ ! global.sym
+____________________________________________________________________________
+[ 548] By: mbeattie on 1998/02/20 12:39:56
+ Log: Subject: [PATCH] 5.004_59: hints/irix_6.sh
+ Date: Mon, 16 Feb 1998 15:44:57 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! hints/irix_6.sh
+____________________________________________________________________________
+[ 547] By: mbeattie on 1998/02/20 12:38:58
+ Log: Subject: [PATCH] perlguts update
+ Date: 16 Feb 1998 11:23:53 +0100
+ From: Gisle Aas <gisle@aas.no>
+ Branch: perl
+ ! pod/perlguts.pod
+____________________________________________________________________________
+[ 546] By: mbeattie on 1998/02/20 12:38:01
+ Log: Subject: [PATCH 5.004_59] bsdos/hints.sh is wrong
+ Date: Sun, 15 Feb 1998 23:56:05 -0500
+ From: Irving Reid <irving@tor.securecomputing.com>
+ Branch: perl
+ ! hints/bsdos.sh
+____________________________________________________________________________
+[ 545] By: mbeattie on 1998/02/20 12:37:11
+ Log: Subject: [PATCH] 5% speedup in an empty loop
+ Date: Sun, 15 Feb 1998 17:49:46 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 544] By: mbeattie on 1998/02/20 12:36:26
+ Log: Subject: [PATCH for 5.004_59] netdb_host_type and netdb_hlen_type on NeXt
+ Date: Sun, 15 Feb 98 23:06:16 +0100
+ From: Hans Mulder <hansm@icgroup.nl>
+ Branch: perl
+ ! hints/next_3.sh hints/next_4.sh
+____________________________________________________________________________
+[ 543] By: mbeattie on 1998/02/20 12:35:39
+ Log: Subject: [PATCH for 5.004_59] Perl_sbrk declared inconsistently
+ Date: Sun, 15 Feb 98 23:05:20 +0100
+ From: Hans Mulder <hansm@icgroup.nl>
+ Branch: perl
+ ! malloc.c
+____________________________________________________________________________
+[ 542] By: mbeattie on 1998/02/20 12:35:03
+ Log: Subject: [PATCH for 5.004_59] "d_gethbyname" misspelled in Configure
+ From: Hans Mulder <hansm@icgroup.nl>
+ Date: Sun, 15 Feb 98 23:04:29 +0100
+ Branch: perl
+ ! Configure
+____________________________________________________________________________
+[ 541] By: mbeattie on 1998/02/20 12:33:56
+ Log: Subject: [PATCH for 5.004_59] NeXT doesn't need DONT_DECLARE_STD (was:
+ NeXT needs DONT_DECLARE_STD)
+ Date: Sun, 15 Feb 98 23:04:19 +0100
+ From: Hans Mulder <hansm@icgroup.nl>
+ Branch: perl
+ ! perl.h
+____________________________________________________________________________
+[ 540] By: mbeattie on 1998/02/20 12:32:25
+ Log: Subject: [PATCH] sv_check_thinkfirst macroized
+ Date: 15 Feb 1998 22:00:38 +0100
+ From: Gisle Aas <gisle@aas.no>
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 539] By: mbeattie on 1998/02/20 12:31:07
+ Log: Subject: [PATCH 5.004_59] allow the Test::Harness to grok TODO-type tests docs
+ Date: Sat, 14 Feb 1998 17:58:01 -0500
+ From: Joshua Pritikin <pritikin@mindspring.com>
+ Branch: perl
+ + lib/Test.pm
+ ! MANIFEST lib/Test/Harness.pm
+____________________________________________________________________________
+[ 538] By: mbeattie on 1998/02/20 12:24:31
+ Log: Subject: [PATCH] 5.004_59: locale startup problems documentation++
+ Date: Sat, 14 Feb 1998 15:40:44 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! INSTALL pod/perldiag.pod pod/perllocale.pod
+____________________________________________________________________________
+[ 537] By: mbeattie on 1998/02/20 12:23:04
+ Log: Subject: [PATCH] Updated, non-wordwrapped, patch to README.VMS
+ Date: Fri, 13 Feb 1998 13:38:28 -0800
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Branch: perl
+ ! README.vms
+____________________________________________________________________________
+[ 536] By: mbeattie on 1998/02/20 12:20:29
+ Log: Subject: [PATCH] 5.004_58, move intuition tests
+ Date: Thu, 12 Feb 1998 17:11:05 -0600
+ From: Stephen Potter <spp@psa.pencom.com>
+ Branch: perl
+ ! t/lib/anydbm.t t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t
+ ! t/lib/sdbm.t t/op/array.t t/op/delete.t t/op/each.t
+ ! t/op/flip.t t/op/pat.t t/op/push.t
+____________________________________________________________________________
+[ 535] By: gsar on 1998/02/19 23:07:24
+ Log: applied a version of this with tabs intact
+ Message-Id: <wklnv7pdf5.fsf@turangalila.harmonixmusic.com>
+ Date: 19 Feb 1998 15:06:38 EST
+ From: dfan@harmonixmusic.com (Dan Schmidt)
+ Subject: Pod::Html bug and fix: missing </UL> in index
+ Branch: win32/perl
+ ! lib/Pod/Html.pm
+____________________________________________________________________________
+[ 534] By: gsar on 1998/02/19 19:40:27
+ Log: Fix C<0> problem in Pod::Html
+ Branch: win32/perl
+ ! lib/Pod/Html.pm
+____________________________________________________________________________
+[ 533] By: gsar on 1998/02/18 18:11:08
+ Log: non-debug VC builds are -O1 now (they say it works, and is
+ faster)
+ Branch: win32/perl
+ ! win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 532] By: gsar on 1998/02/18 04:11:03
+ Log: integrate nick's patch to mainline
+ Branch: win32/perl
+ !> pp.c
+____________________________________________________________________________
+[ 531] By: mbeattie on 1998/02/17 17:50:50
+ Log: Assorted changes to the compiler
+ Branch: perlext
+ ! Compiler/B.pm Compiler/B.xs Compiler/B/Asmdata.pm
+ ! Compiler/B/Bytecode.pm Compiler/B/C.pm Compiler/B/Debug.pm
+ ! Compiler/NOTES Compiler/O.pm Compiler/bytecode.pl
+ ! Compiler/byterun.c Compiler/byterun.h Compiler/typemap
+____________________________________________________________________________
+[ 530] By: gsar on 1998/02/17 01:47:35
+ Log: DLLs are now ok on mingw32/gcc-2.8.0 after removing the
+ FORCE_ARG_STRING() hack (that bug is fixed in gcc now). mingw32
+ build passes all tests except t/lib/io_xs.t (seems to be due to
+ broken tmpfile() in the CRT or import lib)
+ Branch: win32/perl
+ ! XSUB.h win32/makefile.mk win32/win32.h
+____________________________________________________________________________
+[ 529] By: gsar on 1998/02/16 23:03:31
+ Log: fix mingw32 gcc 2.8.0 build (DLLs generated seem to be broken
+ in this version of gcc!)
+ Branch: win32/perl
+ ! doio.c pp_sys.c win32/config.gc win32/makefile.mk
+ ! win32/win32.c win32/win32.h win32/win32iop.h x2p/a2p.h
+____________________________________________________________________________
+[ 528] By: nick on 1998/02/16 22:13:04
+ Log: Missing PUSHMARK in unshift TIEARRAY hook
+ Branch: perl
+ ! pp.c
+____________________________________________________________________________
+[ 527] By: gsar on 1998/02/15 20:59:07
+ Log: integrate win32 branch
+ Branch: asperl
+ !> config_h.SH win32/config.bc win32/config.gc win32/config.vc
+ !> win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ !> win32/makedef.pl
+____________________________________________________________________________
+[ 526] By: gsar on 1998/02/15 20:02:11
+ Log: Fix typo: s/GETNETBYADD\b/GETNETBYADDR/
+ Branch: win32/perl
+ ! config_h.SH win32/config_H.bc win32/config_H.gc
+ ! win32/config_H.vc
+____________________________________________________________________________
+[ 525] By: gsar on 1998/02/15 03:26:45
+ Log: fix build problems due to renamed Config variables
+ Branch: win32/perl
+ ! win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/makedef.pl
+____________________________________________________________________________
+[ 524] By: gsar on 1998/02/14 01:00:15
+ Log: bring ASPerl uptodate with mainline changes
+ Branch: asperl
+ +> ext/DB_File/Changes t/comp/require.t
+ !> (integrate 41 files)
+____________________________________________________________________________
+[ 523] By: gsar on 1998/02/14 00:52:17
+ Log: integrate mainline
+ Branch: win32/perl
+ !> hints/qnx.sh lib/Cwd.pm lib/ExtUtils/xsubpp patchlevel.h
+ !> pp_hot.c t/op/magic.t
+____________________________________________________________________________
+[ 522] By: gsar on 1998/02/14 00:42:37
+ Log: added AS patch#6
+ Message-Id: <01BD3846.B29FB880.dougl@ActiveState.com>
+ Date: Fri, 13 Feb 1998 06:14:51 PST
+ From: Douglas Lankshear <dougl@ActiveState.com>
+ Subject: [PATCH] command line build
+
+ This patch is for the command line build of perl object.
+ I'll merge the ipfoo.c function with win32_xxx functions next.
+
+ -- Doug
+ Branch: asperl
+ ! ObjXSub.h ext/Opcode/Opcode.xs lib/ExtUtils/MM_Win32.pm
+ ! objpp.h proto.h sv.c win32/dl_win32.xs win32/ipenv.c
+ ! win32/ipstdio.c win32/makedef.pl win32/runperl.c win32/win32.h
+____________________________________________________________________________
+[ 521] By: gsar on 1998/02/14 00:14:04
+ Log: added AS patch#5 (patch #4 was intentionally skipped after
+ discussion)
+ Branch: asperl
+ ! embed.h embedvar.h global.sym globals.c hv.c interp.sym
+ ! intrpvar.h op.c perl.c perl.h pp_ctl.c proto.h regcomp.c
+ ! regexec.c sv.c toke.c
+____________________________________________________________________________
+[ 520] By: nick on 1998/02/13 18:15:46
+ Log: Resolve ansiperl against win32
+ Branch: ansiperl
+ +> ext/DB_File/Changes ext/POSIX/hints/linux.pl
+ +> ext/POSIX/hints/sunos_4.pl lib/Fatal.pm t/comp/require.t
+ +> t/lib/ph.t
+ !> (integrate 898 files)
+
+----------------
+Version 5.004_59
+----------------
+
+____________________________________________________________________________
+[ 519] By: mbeattie on 1998/02/13 17:05:37
+ Log: Integrate win32 into mainline.
+ Branch: perl
+ ! lib/ExtUtils/xsubpp
+ !> win32/Makefile win32/config.bc win32/config.gc win32/config.vc
+ !> win32/makefile.mk
+____________________________________________________________________________
+[ 518] By: mbeattie on 1998/02/13 17:01:16
+ Log: Bump patchlevel.h to 59.
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 517] By: mbeattie on 1998/02/13 16:57:59
+ Log: Subject: [PATCH] _58: wantarray in void context broken
+ Date: Fri, 13 Feb 1998 11:24:49 -0500 (est)
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Branch: perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 516] By: mbeattie on 1998/02/13 16:55:33
+ Log: Subject: [PATCH] 5.004_58 QNX getcwd
+ Date: Thu, 12 Feb 1998 13:40:56 -0500 (est)
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Branch: perl
+ ! hints/qnx.sh lib/Cwd.pm t/op/magic.t
+____________________________________________________________________________
+[ 515] By: gsar on 1998/02/12 18:29:52
+ Log: pickup lddlflags properly for Config.pm
+ Branch: win32/perl
+ ! win32/Makefile win32/config.bc win32/config.gc win32/config.vc
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 514] By: gsar on 1998/02/12 18:16:09
+ Log: fix xsubpp bug in SETMAGIC code
+ Branch: win32/perl
+ ! lib/ExtUtils/xsubpp
+____________________________________________________________________________
+[ 513] By: gsar on 1998/02/12 18:06:30
+ Log: integrate mainline
+ Branch: win32/perl
+ +> ext/DB_File/Changes
+ !> Configure MANIFEST config_h.SH ext/DB_File/DB_File.pm
+ !> ext/DB_File/DB_File.xs hints/machten.sh
+ !> lib/ExtUtils/Install.pm lib/Pod/Html.pm lib/Pod/Text.pm
+ !> lib/perl5db.pl malloc.c pod/perldiag.pod pod/perlpod.pod
+ !> pod/pod2man.PL pp_sys.c regcomp.c regexec.c scope.h sv.c
+ !> t/lib/db-recno.t t/lib/filecopy.t t/op/misc.t t/op/pat.t
+ !> t/op/re_tests t/pragma/locale.t
+____________________________________________________________________________
+[ 512] By: mbeattie on 1998/02/12 17:34:02
+ Log: Missing WITH_THR from new deb() in ENTER/LEAVE caused builds
+ with -DUSE_THREADS -DDEBUGGING to fail.
+ Branch: perl
+ ! scope.h
+____________________________________________________________________________
+[ 511] By: mbeattie on 1998/02/12 16:44:03
+ Log: Integrate win32 into mainline
+ Branch: perl
+ +> t/comp/require.t
+ !> MANIFEST pp_ctl.c scope.c scope.h t/op/local.t toke.c
+____________________________________________________________________________
+[ 510] By: mbeattie on 1998/02/12 16:42:26
+ Log: Subject: Re: [PATCH] 5.004_58 | _04 DynaLoader.pm -> DynaLoader.pm.PL (resend)
+ Date: 12 Feb 1998 14:25:55 +0100
+ From: koenig@kulturbox.de (Andreas J. Koenig)
+ Branch: perl
+ ! lib/ExtUtils/Install.pm
+____________________________________________________________________________
+[ 509] By: mbeattie on 1998/02/12 16:40:34
+ Log: Subject: Re: wrong prototype for sbrk [PATCH]
+ Date: Wed, 11 Feb 1998 15:37:31 -0500 (EST)
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Branch: perl
+ ! malloc.c
+____________________________________________________________________________
+[ 508] By: mbeattie on 1998/02/12 16:36:53
+ Log: Subject: [PATCH] 5.004_58 | _04: pod2*,perlpod: L<show this|man/section>
+ Date: Wed, 11 Feb 1998 17:29:20 +0100
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Branch: perl
+ ! lib/Pod/Html.pm lib/Pod/Text.pm pod/perlpod.pod pod/pod2man.PL
+____________________________________________________________________________
+[ 507] By: mbeattie on 1998/02/12 16:35:26
+ Log: Subject: [PATCH] slight tweaks to hints/machten.sh
+ Date: Wed, 11 Feb 1998 14:59:46 +0100
+ From: Dominic Dunlop <domo@vo.lu>
+ Branch: perl
+ ! hints/machten.sh
+____________________________________________________________________________
+[ 506] By: mbeattie on 1998/02/12 16:28:40
+ Log: Subject: DB_File 1.58 patch
+ Date: Tue, 10 Feb 1998 11:23:22 +0000 (GMT)
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Branch: perl
+ + ext/DB_File/Changes
+ ! MANIFEST ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+ ! t/lib/db-recno.t
+____________________________________________________________________________
+[ 505] By: mbeattie on 1998/02/12 16:24:26
+ Log: Subject: 5.004_5*: [PATCH] restore old behaviour of \1 in RE
+ Date: Tue, 10 Feb 1998 02:57:46 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! regexec.c t/op/re_tests
+____________________________________________________________________________
+[ 504] By: mbeattie on 1998/02/12 16:22:46
+ Log: From: Jarkko Hietaniemi <jhi@iki.fi>
+ Subject: [PATCH] 5.004_58: the locale.t problem in IRIX
+ Date: Mon, 9 Feb 1998 19:47:22 +0200 (EET)
+ Subject: [PATCH] 5.004_58: reserve the POSIX regexp extensions
+ Date: Tue, 10 Feb 1998 15:12:12 +0200 (EET)
+ Subject: [PATCH] 5.004_58: <netdb.h> API prototype probing
+ Date: Wed, 11 Feb 1998 12:50:35 +0200 (EET)
+ Branch: perl
+ ! Configure config_h.SH pod/perldiag.pod pp_sys.c regcomp.c
+ ! t/op/misc.t t/op/pat.t t/op/re_tests t/pragma/locale.t
+____________________________________________________________________________
+[ 503] By: mbeattie on 1998/02/12 16:15:43
+ Log: Subject: [PATCH] filecopy.t #3 fails on dos-djgpp
+ Date: Mon, 9 Feb 1998 13:19:45 +0100
+ From: Laszlo Molnar <molnarl@cdata.tvnet.hu>
+ Branch: perl
+ ! t/lib/filecopy.t
+____________________________________________________________________________
+[ 502] By: mbeattie on 1998/02/12 16:14:27
+ Log: Assorted patches to sv.c:
+ From: Gisle Aas <gisle@aas.no>
+ Subject: [PATCH] sv_grow can fail for HAS_64K_LIMIT systems
+ Date: 07 Feb 1998 00:21:57 +0100
+ Subject: [PATCH] sv_setnv will upgrade SVt_NV to SVt_PVNV
+ Date: 07 Feb 1998 00:29:45 +0100
+ Subject: [PATCH] sv_upgrade() always returns TRUE
+ Date: 09 Feb 1998 15:44:01 +0100
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 501] By: mbeattie on 1998/02/12 16:09:26
+ Log: Fix saving of STDOUT during system() in lib/perl5db.pl:
+ Subject: Perl debugger.
+ Date: Fri, 6 Feb 1998 17:47:08 -0500
+ From: "Jason A. Smith" <smithj4@rpi.edu>
+ Branch: perl
+ ! lib/perl5db.pl
+____________________________________________________________________________
+[ 500] By: gsar on 1998/02/12 03:20:55
+ Log: merge another maint patch
+ Message-Id: <199802102349.SAA16001@aatma.engin.umich.edu>
+ Date: Tue, 10 Feb 1998 18:49:00 EST
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Subject: Re: after an eval-ed bad require, requiring a string ref gives a SEGV
+ Branch: win32/perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 499] By: gsar on 1998/02/12 03:14:39
+ Log: make t/comp/require.t type xtext
+ Branch: win32/perl
+ ! t/comp/require.t
+____________________________________________________________________________
+[ 498] By: gsar on 1998/02/12 03:09:58
+ Log: fix extra LEAVE when require fails
+ Message-Id: <199802102321.SAA15346@aatma.engin.umich.edu>
+ Date: Tue, 10 Feb 1998 18:21:37 EST
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Subject: Re: evals and requires make seg-fault with bad require file
+ Branch: win32/perl
+ + t/comp/require.t
+ ! MANIFEST pp_ctl.c scope.c scope.h toke.c
+____________________________________________________________________________
+[ 497] By: gsar on 1998/02/12 02:47:29
+ Log: merge a maint patch
+ Message-Id: <199802110515.AAA23700@aatma.engin.umich.edu>
+ Date: Wed, 11 Feb 1998 00:15:51 EST
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Subject: Re: "local" can crash perl-4.00[34] on Solaris-x86 & FreeBSD
+ Branch: win32/perl
+ ! pp_ctl.c t/op/local.t
+____________________________________________________________________________
+[ 496] By: mbeattie on 1998/02/11 13:04:50
+ Log: Integrate win32 into mainline.
+ Branch: perl
+ !> embed.h ext/GDBM_File/typemap ext/NDBM_File/typemap
+ !> ext/ODBM_File/typemap ext/SDBM_File/typemap global.sym gv.c
+ !> lib/ExtUtils/typemap lib/ExtUtils/xsubpp op.c
+ !> os2/OS2/PrfDB/typemap pod/perlguts.pod pod/perlobj.pod
+ !> pod/perlxs.pod pod/perlxstut.pod proto.h sv.c sv.h t/op/ref.t
+ !> win32/makedef.pl win32/win32.c win32/win32iop.h
+____________________________________________________________________________
+[ 495] By: mbeattie on 1998/02/11 13:03:59
+ Log: Fix special constants in Xref.pm
+ Branch: perlext
+ ! Compiler/B/Xref.pm
+____________________________________________________________________________
+[ 494] By: gsar on 1998/02/10 18:26:28
+ Log: fix opendir() problem on share names
+ Message-Id: <199802101828.NAA10420@aatma.engin.umich.edu>
+ Date: Tue, 10 Feb 1998 13:28:53 EST
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Subject: Re: BUG: opendir and UNC names on NT
+ Branch: win32/perl
+ ! win32/win32.c
+____________________________________________________________________________
+[ 493] By: gsar on 1998/02/09 23:09:40
+ Log: integrate win32 branch contents
+ Branch: asperl
+ +> ext/POSIX/hints/linux.pl ext/POSIX/hints/sunos_4.pl
+ +> lib/Fatal.pm t/lib/ph.t
+ ! hv.c
+ !> (integrate 895 files)
+____________________________________________________________________________
+[ 492] By: gsar on 1998/02/09 07:30:19
+ Log: enhancements to previous patch for XSUB OUTPUT args
+ Message-Id: <199802090731.CAA04438@aatma.engin.umich.edu>
+ Date: Mon, 09 Feb 1998 02:31:55 EST
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Subject: Re: [PATCH] XSUB OUTPUT arguments and 'set' magic
+ Branch: win32/perl
+ ! embed.h ext/GDBM_File/typemap ext/NDBM_File/typemap
+ ! ext/ODBM_File/typemap ext/SDBM_File/typemap global.sym
+ ! lib/ExtUtils/typemap lib/ExtUtils/xsubpp os2/OS2/PrfDB/typemap
+ ! pod/perlguts.pod pod/perlxs.pod pod/perlxstut.pod proto.h sv.c
+ ! sv.h
+____________________________________________________________________________
+[ 491] By: gsar on 1998/02/09 03:00:52
+ Log: don't share TARG unless -DUSE_BROKEN_PAD_RESET
+ Message-Id: <199710300036.TAA01004@aatma.engin.umich.edu>
+ Date: Wed, 29 Oct 1997 19:36:25 EST
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Subject: [PATCH] Don't use broken pad_reset() (was Re: Perl bug in 5.004_03 )
+ Branch: win32/perl
+ ! op.c
+____________________________________________________________________________
+[ 490] By: gsar on 1998/02/09 02:30:43
+ Log: fix for bugs in handling DESTROY (adjusted test numbers)
+ Message-Id: <199801010030.TAA14274@aatma.engin.umich.edu>
+ Subject: Re: [PERL] RFD: iterative DESTROYing of objects
+ Date: Wed, 31 Dec 1997 19:30:46 -0500
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Branch: win32/perl
+ ! pod/perlobj.pod sv.c t/op/ref.t
+____________________________________________________________________________
+[ 489] By: gsar on 1998/02/09 00:30:35
+ Log: ansify prototype for my_safemalloc(), avoid warnings
+ Branch: win32/perl
+ ! sv.c
+____________________________________________________________________________
+[ 488] By: gsar on 1998/02/09 00:29:08
+ Log: fix misapplied hunks in 5.004_58
+ Message-Id: <199802080718.CAA18115@aatma.engin.umich.edu>
+ Date: Sun, 08 Feb 1998 02:18:12 EST
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Subject: [PATCH] fixes for test failures in 5.004_58
+ Branch: win32/perl
+ ! gv.c op.c
+____________________________________________________________________________
+[ 487] By: gsar on 1998/02/09 00:27:16
+ Log: win32_utime() tweaks to avoid warnings
+ Branch: win32/perl
+ ! win32/win32.c win32/win32iop.h
+____________________________________________________________________________
+[ 486] By: gsar on 1998/02/07 23:45:22
+ Log: integrate mainline, plus a few small win32 enhancements
+ - remove Win32::GetCurrentDirectory()
+ - add Win32::Sleep() for compat
+ - add smarter utime() from Jan Dubois, and export it as win32_utime()
+ Branch: win32/perl
+ +> ext/POSIX/hints/linux.pl ext/POSIX/hints/sunos_4.pl
+ +> lib/Fatal.pm t/lib/ph.t
+ ! win32/makedef.pl win32/win32.c win32/win32iop.h
+ !> (integrate 61 files)
+
+----------------
+Version 5.004_58
+----------------
+
+____________________________________________________________________________
+[ 485] By: mbeattie on 1998/02/06 18:11:47
+ Log: Bump patchlevel to 58.
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 484] By: mbeattie on 1998/02/06 18:08:28
+ Log: Fix up problem with gv.c from change 477.
+ Fix up Config.pm use in t/lib/ph.t from change 478.
+ Branch: perl
+ ! gv.c t/lib/ph.t
+____________________________________________________________________________
+[ 483] By: mbeattie on 1998/02/06 17:34:34
+ Log: Integrate win32 branch into mainline
+ Branch: perl
+ !> win32/win32sck.c
+____________________________________________________________________________
+[ 482] By: mbeattie on 1998/02/06 17:26:41
+ Log: lib/Fatal.pm missing from repository
+ Branch: perl
+ + lib/Fatal.pm
+____________________________________________________________________________
+[ 481] By: mbeattie on 1998/02/06 17:24:57
+ Log: Subject: [PATCH] Re: posix::strftime (core dumped)
+ Date: Thu, 5 Feb 1998 13:55:23 -0500 (EST)
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Branch: perl
+ + ext/POSIX/hints/linux.pl ext/POSIX/hints/sunos_4.pl
+ ! MANIFEST hints/linux.sh hints/sunos_4_1.sh t/lib/posix.t
+____________________________________________________________________________
+[ 480] By: mbeattie on 1998/02/06 17:19:52
+ Log: x2p/str.c was missing from list of changed files in change 466
+ Branch: perl
+ ! x2p/str.c
+____________________________________________________________________________
+[ 479] By: mbeattie on 1998/02/06 17:16:54
+ Log: Added t/lib/ph.t to MANIFEST
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 478] By: mbeattie on 1998/02/06 17:15:38
+ Log: Subject: [PATCH] h2ph.PL
+ Date: Thu, 5 Feb 1998 05:53:54 -0800 (EST)
+ From: kstar@www.chapin.edu (Kurt D. Starsinic)
+ Branch: perl
+ + t/lib/ph.t
+ ! utils/h2ph.PL
+____________________________________________________________________________
+[ 477] By: mbeattie on 1998/02/06 17:10:46
+ Log: Subject: [PATCH] Faster gv_fetchpv() for nested packages
+ Date: 04 Feb 1998 14:49:46 +0100
+ From: Gisle Aas <gisle@aas.no>
+ as modified by
+ From: chip@atlantic.net
+ Date: Wed, 4 Feb 1998 11:46:49 -0500 (EST)
+ Branch: perl
+ ! gv.c
+____________________________________________________________________________
+[ 476] By: mbeattie on 1998/02/06 16:47:03
+ Log: From: Jarkko Hietaniemi <jhi@iki.fi>
+ Subject: [PATCH] almost OK: perl 5.00457 on i386-freebsd-thread 3.0
+ Date: Wed, 4 Feb 1998 12:59:47 +0200 (EET)
+ Subject: Re: [PATCH] 5.004_04 and 5.004_57: Complex.pm and complex.t
+ Date: Thu, 5 Feb 1998 18:08:20 +0200 (EET)
+ Branch: perl
+ ! hints/freebsd.sh lib/Math/Complex.pm t/lib/complex.t
+____________________________________________________________________________
+[ 475] By: mbeattie on 1998/02/06 16:44:57
+ Log: Subject: [PATCH] nomemok
+ Date: Mon, 2 Feb 1998 15:06:50 +0100
+ From: Gisle Aas <gisle@aas.no>
+ Branch: perl
+ ! hv.c
+____________________________________________________________________________
+[ 474] By: mbeattie on 1998/02/06 16:43:46
+ Log: Subject: [PATCH] Benchmark.pm: timethese corrupts $_
+ Date: Sun, 1 Feb 1998 06:46:08 -0500 (EST)
+ From: abigail@fnx.com
+ Branch: perl
+ ! lib/Benchmark.pm
+____________________________________________________________________________
+[ 473] By: mbeattie on 1998/02/06 16:42:53
+ Log: Subject: [PATCH] adding the newSVpvn API function
+ Date: Sat, 31 Jan 1998 06:32:42 +0100
+ From: Matthias Ulrich Neeracher <neeri@iis.ee.ethz.ch>
+ Branch: perl
+ ! embed.h embedvar.h global.sym pod/perlguts.pod pod/perltoc.pod
+ ! proto.h sv.c
+____________________________________________________________________________
+[ 472] By: mbeattie on 1998/02/06 16:35:41
+ Log: Subject: Re: [PATCH] new hints/solaris2.sh (was Re: make check fails 17% of it's tests on Solaris...)
+ Date: 28 Jan 1998 17:40:37 -0800
+ From: Stephen Zander <srz@mckesson.com>
+ Branch: perl
+ ! hints/solaris_2.sh
+____________________________________________________________________________
+[ 471] By: mbeattie on 1998/02/06 16:02:57
+ Log: Subject: [PATCH] Re: 5.004_04 vec() fails with 32-bit values
+ Date: Thu, 15 Jan 1998 11:53:06 +0000
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Branch: perl
+ ! pod/perlguts.pod pp.c t/op/vec.t
+____________________________________________________________________________
+[ 470] By: mbeattie on 1998/02/06 16:01:36
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Subject: 5.004_56: Patch to Tie::Hash and docs
+ Date: Sun, 11 Jan 1998 20:34:05 -0500 (EST)
+ Subject: 5.004_56: Patch to (?{}) quoting + cosmetic
+ Date: Mon, 2 Feb 1998 01:28:46 -0500 (EST)
+ Branch: perl
+ ! lib/Tie/Hash.pm pod/perlfunc.pod pod/perlre.pod regcomp.c
+ ! t/op/misc.t t/op/pat.t toke.c
+____________________________________________________________________________
+[ 469] By: mbeattie on 1998/02/06 15:58:31
+ Log: Subject: Another Array.pm patch
+ Date: Wed, 4 Feb 1998 20:37:03 +0000 (GMT)
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Branch: perl
+ ! lib/Tie/Array.pm
+____________________________________________________________________________
+[ 468] By: mbeattie on 1998/02/06 15:56:28
+ Log: Subject: documentation patch for 5.004_57
+ Date: Wed, 4 Feb 1998 14:54:13 +0000 (GMT)
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Branch: perl
+ ! lib/Tie/Array.pm
+____________________________________________________________________________
+[ 467] By: mbeattie on 1998/02/06 15:55:34
+ Log: Subject: 5.004_56: patch for `use Fatal' again
+ Date: Thu, 29 Jan 1998 17:04:28 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! MANIFEST pod/perldiag.pod pod/perlfunc.pod pod/perlmodlib.pod
+ ! pp.c t/comp/proto.t toke.c
+____________________________________________________________________________
+[ 466] By: mbeattie on 1998/02/06 15:53:53
+ Log: Subject: Newer -DLEAKTEST patch
+ Date: Fri, 9 Jan 1998 17:55:09 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! ext/DB_File/DB_File.xs ext/DynaLoader/dl_next.xs
+ ! ext/DynaLoader/dl_vms.xs ext/Opcode/Opcode.xs handy.h hv.c
+ ! perl.c perly.c perly.c.diff perly.fixer pod/perlembed.pod
+ ! pod/perlguts.pod pod/perlrun.pod pod/perltoc.pod pp_hot.c sv.c
+ ! toke.c util.c vms/perly_c.vms x2p/hash.c
+____________________________________________________________________________
+[ 465] By: mbeattie on 1998/02/06 15:46:35
+ Log: More Chip patches (tweaked for _5x). The final one mentioned here
+ (@ARGV with -i) actually went in at change 462 but I failed to
+ add it to the change description:
+ Subject: [PATCH] Fix typo: "FORM{,AT}LINE"
+ Date: Sun, 11 Jan 1998 19:37:17 -0500 (EST)
+ Subject: [PATCH] Fix for C<@x = my @y>
+ Date: Sun, 11 Jan 1998 18:12:16 -0500 (EST)
+ Subject: [PATCH] Fix SEGV on C<*glob{SCALAR,ARRAY}>
+ Date: Thu, 5 Feb 1998 21:30:13 -0500 (EST)
+ Subject: [PATCH] Allow last() to mean last
+ Date: Thu, 5 Feb 1998 21:42:57 -0500 (EST)
+ Subject: [PATCH] Consider @ARGV to be plain files if inplace (-i)
+ Date: Wed, 4 Feb 1998 16:04:47 -0500 (EST)
+ Branch: perl
+ ! op.c perly.c perly.h perly.y sv.c t/op/my.t vms/perly_c.vms
+ ! vms/perly_h.vms
+____________________________________________________________________________
+[ 464] By: mbeattie on 1998/02/06 15:06:18
+ Log: More Chip patches:
+ Subject: [PATCH] Fix SEGV from combining caller and C<package;>
+ Date: Thu, 5 Feb 1998 21:47:50 -0500 (EST)
+ Subject: [PATCH] Fix line numbers after here documents in eval STRING
+ Date: Thu, 5 Feb 1998 21:50:08 -0500 (EST)
+ Subject: [PATCH] Make recursive lexical analysis more robust
+ Date: Thu, 5 Feb 1998 21:57:02 -0500 (EST)
+ Branch: perl
+ ! pp_ctl.c sv.c toke.c
+____________________________________________________________________________
+[ 463] By: mbeattie on 1998/02/06 15:04:17
+ Log: Some more Chip patches (tweaked to match _5x):
+ Subject: [PATCH] Fix empty BLOCK
+ Date: Wed, 4 Feb 1998 16:52:28 -0500 (EST)
+ Subject: [PATCH] fix (\@@) proto
+ Date: Thu, 5 Feb 1998 10:24:29 -0500 (EST)
+ Subject: [PATCH] Cope with lack of args in Fcntl::AUTOLOAD
+ Date: Thu, 5 Feb 1998 21:26:55 -0500 (EST)
+ Subject: [PATCH] Don't fold string comparison under C<use locale>
+ Date: Thu, 5 Feb 1998 21:46:25 -0500 (EST)
+ Branch: perl
+ ! ext/Fcntl/Fcntl.pm op.c t/comp/proto.t toke.c
+____________________________________________________________________________
+[ 462] By: mbeattie on 1998/02/06 14:56:30
+ Log: Some Chip patches (some tweaked to match _5x source):
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Subject: [PATCH] local leakage
+ Date: Tue, 3 Feb 1998 09:16:50 -0500 (EST)
+ Subject: [PATCH] NULs in patterns
+ Date: Wed, 4 Feb 1998 01:33:51 -0500 (EST)
+ Subject: [PATCH] Configure on PerlIO
+ Date: Wed, 4 Feb 1998 01:38:43 -0500 (EST)
+ Subject: [PATCH] Avoid core dump on package alias
+ Date: Wed, 4 Feb 1998 15:38:42 -0500 (EST)
+ Subject: [PATCH] Fix name of $Foo::{'Bar::'}
+ Date: Wed, 4 Feb 1998 16:37:51 -0500 (EST)
+ Branch: perl
+ ! Configure doio.c gv.c op.c pp_ctl.c sv.c t/op/gv.t
+ ! t/op/local.t
+____________________________________________________________________________
+[ 461] By: gsar on 1998/02/04 03:34:36
+ Log: support win32_select(0,0,0,msec) (winsock doesn't)
+ Branch: win32/perl
+ ! win32/win32sck.c
+____________________________________________________________________________
+[ 460] By: gsar on 1998/02/04 00:44:47
+ Log: bug: win32_select() must StartSockets()
+ Branch: win32/perl
+ ! win32/win32sck.c
+
+----------------
+Version 5.004_57
+----------------
+
+____________________________________________________________________________
+[ 459] By: mbeattie on 1998/02/03 16:00:07
+ Log: Replaced two occurrences of THREADSV(find_thread_sv(...)) (order
+ of execution causes core dump if threadsvp is moved). Replaced
+ lvalue occurrence of AvARRAY(av) with SvPVX(av) (former does cast).
+ Branch: perl
+ ! av.c perl.c
+____________________________________________________________________________
+[ 458] By: mbeattie on 1998/02/03 14:40:02
+ Log: Fix up MANIFEST.
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 457] By: mbeattie on 1998/02/03 13:50:23
+ Log: Integrate win32 into mainline. My last integration from ansiperl
+ to the mainline was a dismal failure: I did -ay but meant -at.
+ This should fix things now since win32 has already integrated
+ all the necessary changes from ansiperl.
+ Branch: perl
+ !> (integrate 111 files)
+____________________________________________________________________________
+[ 456] By: gsar on 1998/02/03 04:48:08
+ Log: Fix minor problems with non USE_THREADS build. win32 branch
+ now looks 5.004_57-ready.
+ Branch: win32/perl
+ ! thread.h win32/makedef.pl
+____________________________________________________________________________
+[ 455] By: gsar on 1998/02/03 03:45:09
+ Log: integrate mainline
+ Branch: win32/perl
+ !> (integrate 887 files)
+____________________________________________________________________________
+[ 454] By: mbeattie on 1998/02/02 16:44:24
+ Log: The new dec_osf.sh didn't work so the new glibpth and useshrplib
+ defaults have been commented out for now.
+ Branch: perl
+ ! hints/dec_osf.sh
+____________________________________________________________________________
+[ 453] By: mbeattie on 1998/02/02 15:51:39
+ Log: Introduced thr->threadsvp and THREADSV() for faster per-thread
+ variables. Moved threadnum to a per-interpreter variable and
+ made dTHR and lock/unlock of sv_mutex bypass the get/lock unless
+ more than one thread may be running. Minor tweaks to Thread.xs.
+ Branch: perl
+ ! dosish.h embedvar.h ext/Thread/Thread.xs interp.sym intrpvar.h
+ ! op.c perl.c perl.h pp.c pp_ctl.c scope.c sv.c thrdvar.h
+ ! thread.h util.c
+____________________________________________________________________________
+[ 452] By: gsar on 1998/02/02 04:56:50
+ Log: remove totally egregious s/\\dir// in File::Find
+ Branch: win32/perl
+ ! lib/File/Find.pm
+____________________________________________________________________________
+[ 451] By: gsar on 1998/02/01 22:20:20
+ Log: added AS patch#3
+ Message-Id: <01BD2EF2.53433A40.dougl@ActiveState.com>
+ Date: Sun, 01 Feb 1998 09:18:13 PST
+ From: Douglas Lankshear <dougl@ActiveState.com>
+ To: "'Gurusamy Sarathy'" <gsar@umich.edu>
+
+ Here's an additional diff against //depot/asperl
+
+ The field name mg_length was changed back to mg_len
+ The function name mg_len was change to mg_length
+
+ The need for sort_mutex removed thanks to the code derived
+ from Tom Horsley's work.
+
+ -- Doug
+ Branch: asperl
+ + XSLock.h
+ ! ObjXSub.h XSUB.h av.c embedvar.h ext/DynaLoader/dlutils.c
+ ! globals.c ipstdio.h mg.c mg.h objpp.h perl.c perl.h perlio.h
+ ! perlvars.h perly.c pp.c pp_ctl.c pp_hot.c proto.h regexec.c
+ ! scope.c scope.h sv.c toke.c universal.c util.c
+ ! win32/dl_win32.xs win32/iplio.c win32/ipstdio.c
+ ! win32/perlobj.def win32/runperl.c
+____________________________________________________________________________
+[ 450] By: gsar on 1998/01/30 23:43:57
+ Log: various tweaks
+ - add new functions to proto.h
+ - fix up makefile.mk for $(OBJECT)
+ Branch: asperl
+ ! pp_ctl.c proto.h win32/makefile.mk
+____________________________________________________________________________
+[ 449] By: gsar on 1998/01/30 21:23:15
+ Log: fix up missing patches from AS patch#2
+ Branch: asperl
+ ! perldir.h perlenv.h perllio.h perlmem.h perlproc.h perlsock.h
+ ! pp_ctl.c proto.h
+____________________________________________________________________________
+[ 448] By: gsar on 1998/01/30 18:23:17
+ Log: fix htonlx typo
+ Branch: win32/perl
+ ! perlsock.h
+____________________________________________________________________________
+[ 447] By: mbeattie on 1998/01/30 16:03:49
+ Log: Fix up MANIFEST to add missing files
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 446] By: mbeattie on 1998/01/30 12:34:55
+ Log: Bump patchlevel to 57.
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 445] By: gsar on 1998/01/30 10:44:38
+ Log: initial merge of latest win32 branch into ASPerl
+ Branch: asperl
+ +> lib/Tie/Array.pm pod/perlhist.pod t/lib/tie-push.t
+ +> t/lib/tie-stdarray.t t/lib/tie-stdpush.t t/op/tiearray.t
+ +> win32/bin/perlglob.pl
+ !> (integrate 141 files)
+____________________________________________________________________________
+[ 444] By: gsar on 1998/01/30 09:25:58
+ Log: goofed branching, redo asperl branch
+ Branch: asperl
+ ! perl.h
+____________________________________________________________________________
+[ 443] By: gsar on 1998/01/30 09:23:36
+ Log: added AS patch#2
+ Branch: asperl
+ + ObjXSub.h ipdir.h ipenv.h iplio.h ipmem.h ipproc.h ipsock.h
+ + ipstdio.h objpp.h win32/ipdir.c win32/ipenv.c win32/iplio.c
+ + win32/ipmem.c win32/ipproc.c win32/ipsock.c win32/ipstdio.c
+ + win32/ipstdiowin.h win32/perlobj.def
+ ! EXTERN.h XSUB.h cv.h doio.c dosish.h dump.c embedvar.h
+ ! globals.c gv.c hv.c intrpvar.h malloc.c mg.c mg.h op.c op.h
+ ! opcode.h perl.c perl.h perldir.h perlenv.h perlio.h perllio.h
+ ! perlmem.h perlproc.h perlsock.h perlvars.h perly.c pp.c pp.h
+ ! pp_ctl.c pp_hot.c pp_sys.c proto.h regcomp.c regcomp.h
+ ! regexec.c run.c scope.c scope.h sv.c sv.h thread.h toke.c
+ ! universal.c util.c vms/vms.c win32/Makefile win32/config_H.bc
+ ! win32/config_H.vc win32/dl_win32.xs win32/include/sys/socket.h
+ ! win32/makedef.pl win32/runperl.c win32/win32iop.h
+____________________________________________________________________________
+[ 441] By: gsar on 1998/01/30 08:54:19
+ Log: Created new branch from win32@396, added AS patch#1
+ Branch: asperl
+ + doio.c malloc.c perl.c perl.h perldir.h perlenv.h perllio.h
+ + perlmem.h perlproc.h perlsock.h pp.c pp_hot.c pp_sys.c
+ + regcomp.c scope.h sv.c toke.c util.c
+ +> (branch 915 files)
+____________________________________________________________________________
+[ 440] By: gsar on 1998/01/30 04:43:23
+ Log: integrate winansi
+ Branch: win32/perl
+ +> pod/perlhist.pod
+ !> MANIFEST av.c hv.c op.c perlsock.h pp_ctl.c pp_sys.c scope.c
+ !> util.c
+____________________________________________________________________________
+[ 439] By: mbeattie on 1998/01/27 15:31:53
+ Log: Integrate ansi branch into mainline (resolve -ay).
+ Branch: perl
+ +> lib/Tie/Array.pm perldir.h perlenv.h perllio.h perlmem.h
+ +> perlproc.h perlsock.h pod/perlhist.pod t/lib/tie-push.t
+ +> t/lib/tie-stdarray.t t/lib/tie-stdpush.t t/op/tiearray.t
+ +> win32/bin/perlglob.pl
+ ! op.c
+ !> (integrate 868 files)
+____________________________________________________________________________
+[ 438] By: nick on 1998/01/24 12:02:34
+ Log: Gisle's av_unshift tweak, two small patches from chip
+ and check for NULL in hv_delete in case '~' and tie magic
+ are present
+ Branch: ansiperl
+ ! av.c hv.c op.c pp_ctl.c scope.c
+____________________________________________________________________________
+[ 437] By: nick on 1998/01/24 10:37:56
+ Log: Get PerlXxx_yyyy() macro stuff to _compile_ on Solaris.
+ Ugh! ...
+ Macros were unsuitable for declaring the functions, extra () round
+ parameters removed - non-function forms of PerlXxx_yyyy() need to
+ add () themselves.
+ Need to include perlmem.h in util.c (at least) if not using Perl's malloc.
+ Branch: ansiperl
+ ! perlsock.h pp_sys.c util.c
+____________________________________________________________________________
+[ 436] By: nick on 1998/01/24 10:03:03
+ Log: Integrate win32 into ansiperl
+ Branch: ansiperl
+ +> perldir.h perlenv.h perllio.h perlmem.h perlproc.h perlsock.h
+ +> win32/bin/perlglob.pl
+ !> (integrate 38 files)
+____________________________________________________________________________
+[ 435] By: nick on 1998/01/24 09:47:49
+ Log: Add perlhist.pod
+ Branch: ansiperl
+ + pod/perlhist.pod
+ ! MANIFEST
+____________________________________________________________________________
+[ 434] By: gsar on 1998/01/19 05:01:47
+ Log: s/PerlENV/PerlEnv/ just to be consistent
+ Branch: win32/perl
+ ! malloc.c perl.c perlenv.h regcomp.c toke.c util.c
+____________________________________________________________________________
+[ 433] By: gsar on 1998/01/19 04:52:18
+ Log: foo() -> PerlGroup_foo() patch from ActiveState
+ Branch: win32/perl
+ + perldir.h perlenv.h perllio.h perlmem.h perlproc.h perlsock.h
+ ! doio.c malloc.c perl.c perl.h pp.c pp_hot.c pp_sys.c regcomp.c
+ ! scope.h sv.c toke.c util.c
+____________________________________________________________________________
+[ 432] By: gsar on 1998/01/19 04:42:26
+ Log: integrate mainline
+ Branch: win32/perl
+ !> pod/perlfunc.pod
+____________________________________________________________________________
+[ 431] By: gsar on 1998/01/19 04:40:04
+ Log: integrate changes in winansi
+ Branch: win32/perl
+ +> lib/Tie/Array.pm t/lib/tie-push.t t/lib/tie-stdarray.t
+ +> t/lib/tie-stdpush.t t/op/tiearray.t
+ !> (integrate 98 files)
+____________________________________________________________________________
+[ 430] By: gsar on 1998/01/19 04:10:43
+ Log: Fix autovivification problems with XSUB OUTPUT args
+ Message-Id: <199801190409.XAA26710@aatma.engin.umich.edu>
+ Date: Sun, 18 Jan 1998 23:09:07 EST
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Subject: [PATCH] XSUB OUTPUT arguments and 'set' magic
+ Branch: win32/perl
+ ! ext/GDBM_File/typemap ext/NDBM_File/typemap
+ ! ext/ODBM_File/typemap ext/SDBM_File/typemap
+ ! lib/ExtUtils/typemap os2/OS2/PrfDB/typemap pod/perlguts.pod
+ ! pod/perlxs.pod pod/perlxstut.pod sv.c sv.h win32/win32.h
+____________________________________________________________________________
+[ 429] By: nick on 1998/01/17 21:01:50
+ Log: Subject: [PATCH] 5.004_56 threaded and "CONFIG key 'exe_ext' does not exist in Config.pm"
+ Date: Thu, 25 Dec 1997 13:39:15 -0500
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+ To: perl5-porters@perl.org
+
+ It turns out that the potential for the "CONFIG key 'exe_ext'
+ does not exist in Config.pm" problem has been around for a while,
+ in the definition of SvTRUE(). It's just that non-gcc compilers
+ are more or less being built as CRIPPLED_CC when USE_THREADS is
+ defined (even if they can inline things). The inline macro for
+ SvTRUE works with tied hashes and the EXISTS method, and the
+ functional version (sv_true in 5.004_56, or SvTRUE in 5.004_04)
+ does not, because it adds an excess mg_get() which replaces the
+ EXISTS result with a FETCH result.
+ Branch: ansiperl
+ ! sv.c
+____________________________________________________________________________
+[ 428] By: nick on 1998/01/17 20:59:11
+ Log: From: Robin Barker <rmb1@cise.npl.co.uk>
+ Date: Fri, 19 Dec 97 17:19:09 GMT
+ Message-Id: <26260.9712191719@lightning.cise.npl.co.uk>
+ Branch: ansiperl
+ ! doio.c sv.c toke.c util.c
+____________________________________________________________________________
+[ 427] By: nick on 1998/01/17 12:01:53
+ Log: Permit tie ?foo,$object
+ tidy up dead #ifdef ORIGINAL_TIE)
+ Remove 'P' magic from hash, before adding new one in dbm_open like tie does.
+ Branch: ansiperl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 426] By: nick on 1998/01/15 18:06:36
+ Log: First working TIEARRAY and other misc tie fixes
+ Branch: ansiperl
+ ! MANIFEST pp.c pp_hot.c t/op/tiearray.t
+____________________________________________________________________________
+[ 425] By: nick on 1998/01/14 21:56:40
+ Log: Not working yet - split problems ...
+ Branch: ansiperl
+ ! pp.c t/lib/thread.t t/op/tiearray.t
+____________________________________________________________________________
+[ 424] By: nick on 1998/01/14 18:49:25
+ Log: TIEARRAY updates - almost works ...
+ Branch: ansiperl
+ + t/lib/tie-push.t t/lib/tie-stdarray.t t/lib/tie-stdpush.t
+ ! MANIFEST av.c av.h ext/DB_File/DB_File.pm lib/Tie/Array.pm
+ ! mg.c pod/perltie.pod pp.c pp_hot.c pp_sys.c scope.c
+ ! t/op/avhv.t t/op/push.t t/op/tiearray.t
+____________________________________________________________________________
+[ 423] By: gsar on 1998/01/14 00:13:16
+ Log: fix MakeMaker installbin problem
+ Message-Id: <199801070016.TAA17766@aatma.engin.umich.edu>
+ Subject: Re: can't modify message with HTML-Stream, v.1.42
+ Date: Tue, 06 Jan 1998 19:16:35 -0500
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Branch: win32/perl
+ ! lib/ExtUtils/MM_Unix.pm
+____________________________________________________________________________
+[ 422] By: gsar on 1998/01/13 23:53:02
+ Log: add archname to *sitearch in config.{b,g,v}c
+ Branch: win32/perl
+ ! win32/config.bc win32/config.gc win32/config.vc
+____________________________________________________________________________
+[ 421] By: gsar on 1998/01/13 23:15:14
+ Log: set $ENV{PERL5LIB} in t/harness (so child perlglob.bat sees it)
+ Branch: win32/perl
+ ! t/harness
+____________________________________________________________________________
+[ 420] By: nick on 1998/01/13 22:55:02
+ Log: tiearray tweaks
+ Branch: ansiperl
+ ! av.c pp_sys.c t/op/nothread.t t/op/tiearray.t
+____________________________________________________________________________
+[ 419] By: nick on 1998/01/13 21:27:33
+ Log: Skeleton Tie::Array
+ Branch: ansiperl
+ + lib/Tie/Array.pm
+____________________________________________________________________________
+[ 418] By: nick on 1998/01/13 20:52:38
+ Log: tie array changes to core and tests
+ Branch: ansiperl
+ + t/op/tiearray.t
+ ! MANIFEST av.c av.h deb.c embed.h ext/DB_File/DB_File.pm
+ ! global.sym gv.c mg.c op.c perl.c perl.h pp.c pp.h pp_ctl.c
+ ! pp_hot.c proto.h sv.c toke.c universal.c util.c
+____________________________________________________________________________
+[ 417] By: gsar on 1998/01/13 20:49:52
+ Log: fix perlglob.bat warnings by splitting it from File::DosGlob
+ Branch: win32/perl
+ + win32/bin/perlglob.pl
+ ! MANIFEST README.win32 lib/File/DosGlob.pm win32/Makefile
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 416] By: gsar on 1998/01/13 02:46:53
+ Log: various tweaks to build support (NOTE: meant for 5.004_57)
+ - build and install x2p
+ - fix installperl warnings on win32
+ - `make install` now does puts the archlibs in right places
+ - makefiles don't default to USE_THREADS anymore
+ - sync config.{b,g,v}c
+ - sync makefile.mk -> Makefile
+ Branch: win32/perl
+ ! installperl win32/Makefile win32/config.bc win32/config.gc
+ ! win32/config.vc win32/config_sh.PL win32/makefile.mk x2p/a2p.h
+ ! x2p/a2py.c
+____________________________________________________________________________
+[ 415] By: nick on 1998/01/11 16:54:26
+ Log: Integrate win32 into ansiperl
+ Branch: ansiperl
+ !> Configure hints/dec_osf.sh hv.c lib/Getopt/Long.pm lib/blib.pm
+ !> lib/newgetopt.pl perl.h perl_exp.SH pp_ctl.c pp_hot.c pp_sys.c
+ !> proto.h regcomp.h regexec.c t/op/re_tests t/pragma/locale.t
+ !> utils/perldoc.PL vms/config.vms vms/descrip.mms
+ !> vms/gen_shrfls.pl vms/genconfig.pl vms/perly_c.vms vms/vms.c
+ !> vms/vmsish.h x2p/s2p.PL
+____________________________________________________________________________
+[ 414] By: nick on 1998/01/11 15:13:49
+ Log: Integratye mainline -> ansiperl
+ Branch: ansiperl
+ !> (integrate 64 files)
+____________________________________________________________________________
+[ 413] By: mbeattie on 1998/01/09 12:57:58
+ Log: Add missing blank line in pod/perlfunc.pod.
+ Branch: perl
+ ! pod/perlfunc.pod
+____________________________________________________________________________
+[ 412] By: gsar on 1998/01/08 20:54:31
+ Log: change#398 breaks ENV_IS_CASELESS, fix it
+ Branch: win32/perl
+ ! hv.c
+____________________________________________________________________________
+[ 411] By: gsar on 1998/01/08 18:33:58
+ Log: Integrate mainline
+ Branch: win32/perl
+ !> Configure hints/dec_osf.sh hv.c lib/Getopt/Long.pm lib/blib.pm
+ !> lib/newgetopt.pl perl.h perl_exp.SH pp_ctl.c pp_hot.c pp_sys.c
+ !> proto.h regcomp.h regexec.c t/op/re_tests t/pragma/locale.t
+ !> utils/perldoc.PL vms/config.vms vms/descrip.mms
+ !> vms/gen_shrfls.pl vms/genconfig.pl vms/perly_c.vms vms/vms.c
+ !> vms/vmsish.h x2p/s2p.PL
+____________________________________________________________________________
+[ 410] By: mbeattie on 1998/01/08 16:06:22
+ Log: Fix thinko in t/pragma/locale.t:
+ Subject: [PATCH] _04 or _56: locale.t
+ Date: Sun, 4 Jan 1998 23:48:44 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! t/pragma/locale.t
+____________________________________________________________________________
+[ 409] By: mbeattie on 1998/01/08 16:05:09
+ Log: Use Tom Horley's qsort for sorting:
+ Subject: Re: [PATCH for 5.004_56] Re: op/sort.t hangs under Solaris 2.5
+ Date: Fri, 02 Jan 1998 19:33:24 -0500 (EST)
+ From: Hans Mulder <hansm@icgned.nl>
+ Branch: perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 408] By: mbeattie on 1998/01/08 16:01:57
+ Log: Make s2p not use cpp:
+ Subject: [PATCH for 5.004_56] s2p shouldn't use cpp
+ Date: Mon, 29 Dec 1997 19:38:18 -0500 (EST)
+ From: Hans Mulder <hansm@icgned.nl>
+ Branch: perl
+ ! x2p/s2p.PL
+____________________________________________________________________________
+[ 407] By: mbeattie on 1998/01/08 15:57:31
+ Log: DG/UX tweaks to perl.h:
+ Subject: [PATCH] _56 on dgux without threads
+ Date: Sat, 20 Dec 1997 23:01:40 -0500
+ From: Roderick Schertler <roderick@argon.org>
+ Branch: perl
+ ! perl.h
+____________________________________________________________________________
+[ 406] By: mbeattie on 1998/01/08 15:56:02
+ Log: Configure and hints/dec_osf.sh changes for Digital UNIX:
+ Subject: [PATCH] perl5.004_56 NOT OK on alpha-dec_osf-thread (Digital UNIX X5.0-13)
+ Date: Sat, 20 Dec 1997 02:30:01 -0500
+ From: Spider Boardman <spider@web.zk3.dec.com>
+ Branch: perl
+ ! Configure hints/dec_osf.sh
+____________________________________________________________________________
+[ 405] By: mbeattie on 1998/01/08 15:53:40
+ Log: Missing "" in Configure echo for gethbadd_addr_type.
+ Branch: perl
+ ! Configure
+____________________________________________________________________________
+[ 404] By: mbeattie on 1998/01/08 13:04:48
+ Log: print/printf/... over-eager mg_find for glob magic:
+ Subject: [PATCH] fix inefficient checks for TIEHANDLE
+ Date: Wed, 07 Jan 1998 20:06:05 -0500
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Branch: perl
+ ! pp_hot.c pp_sys.c
+____________________________________________________________________________
+[ 403] By: mbeattie on 1998/01/08 12:56:31
+ Log: Assorted VMS patches (mostly VMS makefile update for new headers):
+ Subject: [PATCH] VMS update for 5.004_56
+ Date: Sat, 03 Jan 1998 03:54:29 -0500 (EST)
+ From: Charles Bailey <bailey@newman.upenn.edu>
+ Branch: perl
+ ! lib/blib.pm proto.h regcomp.h vms/config.vms vms/descrip.mms
+ ! vms/gen_shrfls.pl vms/genconfig.pl vms/perly_c.vms vms/vms.c
+ ! vms/vmsish.h
+____________________________________________________________________________
+[ 402] By: mbeattie on 1998/01/08 12:46:15
+ Log: Fix utils/perldoc.PL for dos-djgpp:
+ Subject: 5.004_56: perldoc.PL dos-djgpp patches
+ Date: Tue, 6 Jan 1998 18:14:59 +0100
+ From: Molnar Laszlo <molnarl@cdata.tvnet.hu>
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 401] By: mbeattie on 1998/01/08 12:40:14
+ Log: Version 2.13 of GetoptLong:
+ Subject: Re: ANNOUNCE: perl 5.004_56 is available
+ Date: 06 Jan 1998 16:21:45 +0100
+ From: JVromans@Squirrel.nl (Johan Vromans)
+ Branch: perl
+ ! lib/Getopt/Long.pm lib/newgetopt.pl
+____________________________________________________________________________
+[ 400] By: mbeattie on 1998/01/08 12:28:08
+ Log: Fix variable export and threading configuration for AIX:
+ Subject: [PATCH] 5.004_56: AIX 4.1.5.0: sans et avec threads
+ Date: Tue, 23 Dec 1997 15:39:12 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! Configure perl_exp.SH
+____________________________________________________________________________
+[ 399] By: mbeattie on 1998/01/08 12:25:38
+ Log: Regexp fix: (?>a+)b doesn't match aaab:
+ Subject: Re: Regexp [PATCH] 5.004_56 (?>...)
+ Date: Fri, 19 Dec 1997 16:02:50 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! regexec.c t/op/re_tests
+____________________________________________________________________________
+[ 398] By: mbeattie on 1998/01/08 12:23:41
+ Log: Fix hv_delete for 'm'-magic. Based on following patch, modified
+ to cope with ENV_IS_CASELESS:
+ Subject: [perl5.004_56] [PATCH] hv_delete and 'm' magic
+ Date: Fri, 19 Dec 1997 11:31:36 -0500
+ From: Owen Taylor <owt1@cornell.edu>
+ Branch: perl
+ ! hv.c
+____________________________________________________________________________
+[ 397] By: mbeattie on 1998/01/08 12:10:29
+ Log: Integrate win32 branch into mainline.
+ Branch: perl
+ !> (integrate 41 files)
+____________________________________________________________________________
+[ 396] By: gsar on 1998/01/07 19:12:27
+ Log: tweak case-insensitive ENV implementation
+ Branch: win32/perl
+ ! hv.c
+____________________________________________________________________________
+[ 395] By: nick on 1998/01/07 18:40:55
+ Log: Integrate win32 branch
+ Branch: ansiperl
+ !> (integrate 31 files)
+____________________________________________________________________________
+[ 394] By: gsar on 1998/01/05 19:17:40
+ Log: Allow $ENV{PERL5SHELL} to contain switches etc., and document
+ the fact
+ Branch: win32/perl
+ ! pod/perlrun.pod win32/win32.c
+____________________________________________________________________________
+[ 393] By: gsar on 1998/01/05 05:43:33
+ Log: Support case-tolerant %ENV
+ - underlying system calls see the case-as-supplied by user
+ - added tests to verify addition/deletion/enumeration case-tolerance
+ - hv.c touched, but changes are fully conditional on -DENV_IS_CASELESS,
+ which is default on win32 now
+ Branch: win32/perl
+ ! hv.c t/op/magic.t win32/win32.h
+____________________________________________________________________________
+[ 392] By: gsar on 1998/01/04 17:55:19
+ Log: Add a tweaked version of:
+ Message-Id: <199801040630.AA29298@metronet.com>
+ Date: Sun, 04 Jan 1998 00:30:57 CST
+ From: Tye McQueen <tye@metronet.com>
+ Subject: New patch for $^E==GetLastError() under Win32
+ Branch: win32/perl
+ ! doio.c lib/dumpvar.pl lib/perl5db.pl mg.c perl.h
+ ! pod/perlfunc.pod pod/perlvar.pod util.c win32/makedef.pl
+ ! win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 391] By: gsar on 1998/01/04 07:59:44
+ Log: Various win32 fixes
+ - support spawn via system(&P_NOWAIT,...) like OS2
+ - support wait() and waitpid()
+ - s/GetCurrentDirectory/GetCwd/, long-named XS to be removed
+ - support -lfoo properly in ExtUtils::Liblist
+ - fix outdated info about Win32 support in perlfaq2
+ - fix win32 bug in perldoc that causes spurious warnings
+ - regularize global function/variable names yet more
+ - fix bug in do_aspawn() (it was always invoking shell, instead of
+ almost never)
+ - implement and export win32_wait()
+ - stub version of USE_RTL_THREAD_API
+ Branch: win32/perl
+ ! README.win32 dosish.h lib/Cwd.pm lib/ExtUtils/Liblist.pm
+ ! pod/perlfaq2.pod pp_sys.c util.c utils/perldoc.PL
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/config_h.PL win32/perllib.c win32/win32.c win32/win32.h
+ ! win32/win32iop.h win32/win32sck.c win32/win32thread.c
+ ! win32/win32thread.h
+____________________________________________________________________________
+[ 390] By: gsar on 1997/12/30 21:00:28
+ Log: Fix $ENV{Path} in FindBin.pm
+ Branch: win32/perl
+ ! lib/FindBin.pm
+____________________________________________________________________________
+[ 389] By: nick on 1997/12/29 10:33:23
+ Log: Resolve ansiperl against win32
+ Branch: ansiperl
+ !> (integrate 105 files)
+____________________________________________________________________________
+[ 388] By: gsar on 1997/12/24 04:59:28
+ Log: make $? Unix (and ActiveWare) compatible
+ Branch: win32/perl
+ ! README.win32 win32/win32.c
+____________________________________________________________________________
+[ 387] By: gsar on 1997/12/24 04:21:30
+ Log: support ioctl() on sockets (does what ioctlsocket() does) to make
+ non-blocking IO on sockets possible
+ Branch: win32/perl
+ ! README.win32 dosish.h win32/makedef.pl win32/win32.c
+ ! win32/win32iop.h win32/win32sck.c
+____________________________________________________________________________
+[ 386] By: gsar on 1997/12/24 03:10:55
+ Log: support getlogin()
+ Branch: win32/perl
+ ! README.win32 win32/config.bc win32/config.gc win32/config.vc
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+ ! win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 385] By: gsar on 1997/12/24 02:24:59
+ Log: add support for crypt() via user-supplied des_fcrypt() source or library.
+ Update README.win32.
+ Branch: win32/perl
+ ! README.win32 perl.h win32/Makefile win32/makedef.pl
+ ! win32/makefile.mk win32/win32.c win32/win32.h win32/win32iop.h
+____________________________________________________________________________
+[ 384] By: gsar on 1997/12/24 02:22:42
+ Log: tweak op.c to avoid warning
+ Branch: win32/perl
+ ! op.c
+____________________________________________________________________________
+[ 383] By: gsar on 1997/12/23 21:12:42
+ Log: Trivial bugfix#3 from local repository
+ Message-Id: <199712061100.GAA14864@aatma.engin.umich.edu>
+ Subject: Re: Assigning result of pop scrambles unrelated reference
+ Date: Sat, 06 Dec 1997 06:00:45 -0500
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Branch: win32/perl
+ ! sv.c
+____________________________________________________________________________
+[ 382] By: gsar on 1997/12/23 21:09:32
+ Log: Trivial bugfix#2 from local repository
+ Message-Id: <199712061025.FAA14396@aatma.engin.umich.edu>
+ Subject: Re: eval of sub gives spurious "uninitialised" warning
+ Date: Sat, 06 Dec 1997 05:25:07 -0500
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Branch: win32/perl
+ ! op.c pod/perldelta.pod pod/perlfunc.pod t/op/eval.t
+____________________________________________________________________________
+[ 381] By: gsar on 1997/12/23 21:01:04
+ Log: Trivial bugfix#1 from local repository
+ Message-Id: <199711282326.SAA15090@aatma.engin.umich.edu>
+ Subject: [PATCH] Re: [5.004_04 BUG] bless broke scoping?
+ Date: Fri, 28 Nov 1997 18:26:52 -0500
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Branch: win32/perl
+ ! scope.c
+____________________________________________________________________________
+[ 380] By: gsar on 1997/12/18 15:10:23
+ Log: Integrate mainline
+ Branch: win32/perl
+ +> README.dos djgpp/config.over djgpp/configure.bat djgpp/djgpp.c
+ +> djgpp/djgppsed.sh djgpp/fixpmain hints/dos_djgpp.sh
+ +> os2/os2.sym os2/os2thread.h
+ !> (integrate 77 files)
+
+----------------
+Version 5.004_56
+----------------
+
+____________________________________________________________________________
+[ 379] By: mbeattie on 1997/12/18 13:28:35
+ Log: Integrate ansi @364,@366 into mainline.
+ Branch: perl
+ !> lib/ExtUtils/MakeMaker.pm miniperlmain.c perl.h
+____________________________________________________________________________
+[ 378] By: mbeattie on 1997/12/18 13:20:15
+ Log: Add a few missing files to MANIFEST
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 377] By: mbeattie on 1997/12/18 13:00:16
+ Log: Bump patchlevel to 56.
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 376] By: nick on 1997/12/18 01:32:12
+ Log: Resolve against mainline
+ Branch: ansiperl
+ +> README.dos djgpp/config.over djgpp/configure.bat djgpp/djgpp.c
+ +> djgpp/djgppsed.sh djgpp/fixpmain hints/dos_djgpp.sh
+ +> os2/os2.sym os2/os2thread.h
+ !> (integrate 74 files)
+____________________________________________________________________________
+[ 375] By: nick on 1997/12/18 01:06:15
+ Log: Resolve against Win32
+ Branch: ansiperl
+ !> Configure README.threads config_h.SH doop.c embed.h
+ !> ext/DynaLoader/dl_aix.xs global.sym hints/aix.sh
+ !> hints/irix_6.sh op.c op.h perl.h perlvars.h pp_hot.c pp_sys.c
+ !> sv.c sv.h thread.h util.c
+____________________________________________________________________________
+[ 374] By: mbeattie on 1997/12/17 14:44:26
+ Log: Lots of VMS changes. vms/gen_shrfls.pl (which parses header files)
+ needs rewriting now that we use perlvars.h and foovar.h:
+ Subject: [PATCH] 5.004_54 under VMS (fwd)
+ Date: Wed, 26 Nov 1997 12:32:09 -0400 (EDT)
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Branch: perl
+ ! dosish.h handy.h intrpvar.h os2/os2ish.h perl.c perl.h
+ ! plan9/plan9ish.h pp.c proto.h sv.c t/lib/thread.t
+ ! t/lib/timelocal.t t/op/nothread.t taint.c thrdvar.h toke.c
+ ! unixish.h vms/config.vms vms/descrip.mms vms/fndvers.com
+ ! vms/gen_shrfls.pl vms/genconfig.pl vms/perly_c.vms
+ ! vms/test.com vms/vms.c vms/vms_yfix.pl vms/vmsish.h
+____________________________________________________________________________
+[ 373] By: mbeattie on 1997/12/17 14:10:50
+ Log: Major changes to the DOS/djgpp port (including threading):
+ Subject: Re: dos-djgpp port not in perl 5.004_54
+ Date: Fri, 21 Nov 1997 10:58:26 +0100
+ From: Molnar Laszlo <molnarl@cdata.tvnet.hu>
+ Branch: perl
+ + README.dos djgpp/config.over djgpp/configure.bat djgpp/djgpp.c
+ + djgpp/djgppsed.sh djgpp/fixpmain hints/dos_djgpp.sh
+ ! Configure MANIFEST Makefile.SH doio.c dosish.h
+ ! ext/POSIX/POSIX.xs installhtml installperl lib/AutoSplit.pm
+ ! lib/Cwd.pm lib/ExtUtils/Install.pm lib/ExtUtils/MM_Unix.pm
+ ! lib/ExtUtils/Manifest.pm lib/File/Basename.pm lib/File/Find.pm
+ ! lib/File/Path.pm lib/FindBin.pm lib/Pod/Html.pm
+ ! lib/Pod/Text.pm lib/Term/Cap.pm lib/perl5db.pl makedepend.SH
+ ! mg.c perl.c pod/pod2man.PL pp_hot.c t/io/fs.t t/lib/anydbm.t
+ ! t/lib/filehand.t t/lib/gdbm.t t/lib/io_sel.t t/lib/io_tell.t
+ ! t/lib/sdbm.t t/lib/thread.t t/op/magic.t t/op/stat.t
+ ! t/op/sysio.t t/op/taint.t utils/perldoc.PL
+____________________________________________________________________________
+[ 372] By: mbeattie on 1997/12/17 13:18:34
+ Log: Upgrade DB_File to 1.56:
+ Subject: DB_File-1.56 for _55
+ Date: Tue, 16 Dec 1997 22:25:29 +0000 (GMT)
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Branch: perl
+ ! Configure ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+ ! ext/DB_File/Makefile.PL ext/DB_File/typemap t/lib/db-btree.t
+____________________________________________________________________________
+[ 371] By: mbeattie on 1997/12/17 12:02:03
+ Log: Threading patches for OS/2 (missing files taken from previous patch):
+ Subject: Re: 5.004_55: OS/2 patches again
+ Date: Sat, 13 Dec 1997 18:09:15 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ + os2/os2.sym os2/os2thread.h
+ ! MANIFEST hints/os2.sh os2/Changes os2/Makefile.SHs
+ ! os2/OS2/PrfDB/PrfDB.xs os2/OS2/REXX/REXX.xs os2/os2.c
+ ! os2/os2ish.h perl.h
+____________________________________________________________________________
+[ 370] By: mbeattie on 1997/12/17 11:01:34
+ Log: Add OS2 to list for DONT_DECLARE_STD in perl.h:
+ Subject: Re: 5.004_55: OS/2 patches again
+ Date: Sat, 13 Dec 1997 18:05:55 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! perl.h
+____________________________________________________________________________
+[ 369] By: mbeattie on 1997/12/17 10:59:40
+ Log: Fix typo in compiler B/C.pm.
+ Branch: perlext
+ ! Compiler/B/C.pm
+____________________________________________________________________________
+[ 368] By: mbeattie on 1997/12/17 10:58:35
+ Log: Allow "perldoc -F filename":
+ Subject: 5.004_55: Patch to perldoc
+ Date: Thu, 11 Dec 1997 19:37:00 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! utils/perldoc.PL
+____________________________________________________________________________
+[ 367] By: mbeattie on 1997/12/17 10:54:47
+ Log: Fix not-reached warning for pp_threadsv.
+ Branch: perl
+ ! pp.c
+____________________________________________________________________________
+[ 366] By: nick on 1997/12/14 16:06:24
+ Log: Fix typo in Ilya's patch :-(
+ Branch: ansiperl
+ ! lib/ExtUtils/MakeMaker.pm
+____________________________________________________________________________
+[ 365] By: nick on 1997/12/14 15:30:25
+ Log: #undef new PERLVARIC macro in appropriate places
+ Branch: ansiperl
+ ! miniperlmain.c perl.h
+____________________________________________________________________________
+[ 364] By: nick on 1997/12/14 15:04:36
+ Log: Ilya's MakeMaker (empty makefile) patch
+ Branch: ansiperl
+ ! lib/ExtUtils/MakeMaker.pm
+____________________________________________________________________________
+[ 363] By: gsar on 1997/12/13 05:57:13
+ Log: Integrate mainline. Builds and passes (Borland).
+ Branch: win32/perl
+ !> Configure README.threads config_h.SH doop.c embed.h
+ !> ext/DynaLoader/dl_aix.xs global.sym hints/aix.sh
+ !> hints/irix_6.sh op.c op.h perl.h perlvars.h pp_hot.c pp_sys.c
+ !> sv.c sv.h thread.h util.c
+____________________________________________________________________________
+[ 362] By: nick on 1997/12/13 02:53:03
+ Log: Resolve ansiperl against mainline
+ Branch: ansiperl
+ !> (integrate 92 files)
+____________________________________________________________________________
+[ 361] By: mbeattie on 1997/12/12 16:20:38
+ Log: pp_print and pp_prtf handling of tied file handles used EXTEND
+ instead of MEXTEND leading to core dumps. This fix needs
+ propagating back to the maintenance branch.
+ Branch: perl
+ ! pp_hot.c pp_sys.c
+____________________________________________________________________________
+[ 360] By: mbeattie on 1997/12/11 15:45:56
+ Log: Add missing patch to op.c that didn't come across with win32 merge.
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 359] By: mbeattie on 1997/12/11 11:54:41
+ Log: Stop tr/// from writing to target when only counting.
+ Branch: perl
+ ! doop.c op.c op.h
+____________________________________________________________________________
+[ 358] By: mbeattie on 1997/12/10 18:36:26
+ Log: Fix char*/unsigned char* clashes in util.c:fbm_instr and remove
+ a few extraneous trailing semicolons in perlvars.h.
+ Branch: perl
+ ! perlvars.h util.c
+____________________________________________________________________________
+[ 357] By: mbeattie on 1997/12/10 18:33:53
+ Log: Start overhauling compiler. It was working at least minimally
+ right up until the final tweak of B.xs to add threadsv_names
+ at which point building it provokes a seg fault in perl while
+ doing the xsubpp :-(.
+ Branch: perl
+ ! op.h util.c
+ Branch: perlext
+ ! Compiler/B.pm Compiler/B.xs Compiler/B/Asmdata.pm
+ ! Compiler/B/C.pm Compiler/B/CC.pm Compiler/Makefile.PL
+ ! Compiler/bytecode.pl Compiler/byteperl.c Compiler/byterun.c
+ ! Compiler/byterun.h Compiler/cc_harness Compiler/cc_runtime.h
+ ! Compiler/ccop.c Compiler/ccop.h Compiler/test_harness
+ ! Compiler/test_harness_cc
+____________________________________________________________________________
+[ 356] By: mbeattie on 1997/12/10 13:43:32
+ Log: Fix perl_os_thread typedef for pthreads. Tweak SvTAINT so that
+ sv_setfoo functions go back to not needing dTHR. Fix Configure
+ to check for already-existing -thread on archname and to check
+ better for d_pthread_created_joinable.
+ Branch: perl
+ ! Configure perl.h sv.c sv.h thread.h
+____________________________________________________________________________
+[ 355] By: mbeattie on 1997/12/10 10:53:58
+ Log: Minor fix/speedup to util.c:fbm_instr:
+ Subject: 5.004_55: Minor regexp patch
+ Date: Fri, 5 Dec 1997 05:09:54 -0500 (EST)
+ From: Ilya Zakharevich <ilya@MATH.OHIO-STATE.EDU>
+ Branch: perl
+ ! util.c
+____________________________________________________________________________
+[ 354] By: mbeattie on 1997/12/10 10:41:25
+ Log: Patches for IRIX, AIX and some generic stuff:
+ Subject: [PATCH] _55: Mostly AIX stuff but also IRIX and generic
+ Date: Sat, 29 Nov 1997 08:35:30 -0800 (PST)
+ From: Jarkko Hietaniemi <jarkko.hietaniemi@research.nokia.com>
+ (checked/ignored a few rejects; tweaked wording).
+ Branch: perl
+ ! Configure README.threads config_h.SH embed.h
+ ! ext/DynaLoader/dl_aix.xs global.sym hints/aix.sh
+ ! hints/irix_6.sh
+____________________________________________________________________________
+[ 353] By: mbeattie on 1997/12/10 10:10:19
+ Log: Integrate win32 back into mainline (trivial).
+ Branch: perl
+ +> embedvar.h intrpvar.h perlvars.h thrdvar.h win32/config.gc
+ +> win32/config_H.gc
+ !> (integrate 36 files)
+____________________________________________________________________________
+[ 352] By: nick on 1997/12/09 17:36:45
+ Log: Resolve win32 - Sarathy's tweak.
+ Branch: ansiperl
+ !> win32/makedef.pl
+____________________________________________________________________________
+[ 351] By: gsar on 1997/12/08 06:13:04
+ Log: re-add PERLVARI?C? change that somehow went missing in makedef.pl
+ Branch: win32/perl
+ ! win32/makedef.pl
+____________________________________________________________________________
+[ 350] By: nick on 1997/12/05 00:56:03
+ Log: Resolve ansiperl against win32
+ Branch: ansiperl
+ - win32/makegcc.mk
+ !> embed.h embed.pl embedvar.h global.sym miniperlmain.c perl.h
+ !> perlvars.h win32/Makefile win32/config.gc win32/makedef.pl
+ !> win32/makefile.mk win32/perllib.c win32/win32.h
+____________________________________________________________________________
+[ 349] By: gsar on 1997/12/02 07:28:23
+ Log: Revert to keeping (some) constant strings as globals
+ Branch: win32/perl
+ ! embed.h embed.pl embedvar.h global.sym miniperlmain.c perl.h
+ ! perlvars.h win32/makedef.pl win32/perllib.c
+____________________________________________________________________________
+[ 348] By: gsar on 1997/12/02 05:38:06
+ Log: makegcc.mk merged into makefile.mk, so makegcc.mk is gone.
+ Other minor fixes. Now is a good time to get the changes in win32 branch.
+ Branch: win32/perl
+ - win32/makegcc.mk
+ ! win32/Makefile win32/config.gc win32/makefile.mk win32/win32.h
+____________________________________________________________________________
+[ 347] By: gsar on 1997/12/02 03:32:55
+ Log: Integrate winansi again. Result builds and passes all tests on all
+ three compilers.
+ Branch: win32/perl
+ !> lib/ExtUtils/MM_Win32.pm win32/config.gc win32/makefile.mk
+ !> win32/makegcc.mk win32/win32.h
+____________________________________________________________________________
+[ 346] By: gsar on 1997/12/02 03:28:23
+ Log: various hacks to get mingw32 to build. Sync Makefile with makefile.mk.
+ makegcc.mk to be merged into makefile.mk soon.
+ Branch: win32/perl
+ ! lib/ExtUtils/MM_Win32.pm win32/Makefile win32/config.gc
+ ! win32/makedef.pl win32/makefile.mk win32/makegcc.mk
+ ! win32/win32.h
+____________________________________________________________________________
+[ 345] By: nick on 1997/12/02 01:57:17
+ Log: Add a 4th step (yes FOUR) to dll build process for gcc.
+ Now runs again...
+ Branch: ansiperl
+ ! lib/ExtUtils/MM_Win32.pm
+____________________________________________________________________________
+[ 344] By: nick on 1997/12/02 01:11:16
+ Log: Sarathy's patch
+ Branch: ansiperl
+ ! lib/ExtUtils/MM_Win32.pm win32/config.gc win32/makefile.mk
+ ! win32/makegcc.mk win32/win32.h
+____________________________________________________________________________
+[ 343] By: gsar on 1997/12/01 04:37:06
+ Log: Reverse integrate to get all of Nick's changes over at winansi (win32/perl/*
+ is identical to ansiperl/* now)
+ Branch: win32/perl
+ +> embedvar.h intrpvar.h perlvars.h thrdvar.h
+ !> (integrate 34 files)
+____________________________________________________________________________
+[ 342] By: nick on 1997/12/01 04:01:57
+ Log: Builds and passes all tests with gcc on Win32 - phew!
+ Branch: ansiperl
+ ! embed.h embedvar.h ext/Opcode/Opcode.xs global.sym perl.h
+ ! proto.h util.c win32/makedef.pl
+____________________________________________________________________________
+[ 341] By: nick on 1997/12/01 02:54:29
+ Log: Create a struct for all perls globals (as an option)
+ Mainly for Mingw32 which cannot import data.
+ Now only Opcode tests fail (op_desc/op_name not
+ handled yet stuff)
+ Branch: ansiperl
+ ! EXTERN.h embed.h embed.pl embedvar.h ext/Thread/Thread.xs
+ ! global.sym miniperlmain.c perl.c perl.h perlvars.h pp_hot.c
+ ! proto.h run.c util.c win32/Makefile win32/makedef.pl
+ ! win32/makegcc.mk win32/perllib.c win32/win32.c win32/win32.h
+ ! win32/win32iop.h win32/win32thread.c
+____________________________________________________________________________
+[ 340] By: nick on 1997/11/30 20:21:10
+ Log: Fixup exports in non -DDEBUGGING case
+ Branch: ansiperl
+ ! win32/makedef.pl
+____________________________________________________________________________
+[ 339] By: nick on 1997/11/30 20:10:04
+ Log: Disable hard-coded -DDEBUGGING
+ Branch: ansiperl
+ ! win32/config_h.PL
+____________________________________________________________________________
+[ 338] By: nick on 1997/11/30 20:00:19
+ Log: embed.pl now reads *var*.h to do its stuff.
+ Split generated embed.h into two - new embedvar.h
+ is #included when 'op' etc. will not mess up proto.h etc.
+ Removed #define foo (thr->Tfoo) from thread.h
+ Added some 'missing' symbols to global.sym, removed
+ those in the *var*.h files
+ Has build all MULTIPLICITY/USE_THREADS options on win32
+ with VC++ (and passed tests), but not with exactly this set
+ of files.
+ Branch: ansiperl
+ + embedvar.h
+ ! embed.h embed.pl global.sym interp.sym intrpvar.h perl.h
+ ! perlvars.h regcomp.c thrdvar.h thread.h win32/Makefile
+ ! win32/makedef.pl
+____________________________________________________________________________
+[ 337] By: nick on 1997/11/29 23:55:31
+ Log: Globals and structs via macros - part 1 of N
+ - introduce perlvars.h intrpvar.h and thrdvar.h
+ - change perl.h and thread.h to include them with
+ appropriate macros defined
+ - result is status-quo but with macros
+ - next step is to tweak embed.* to capitalize on
+ new easy-to-find info.
+ Branch: ansiperl
+ + intrpvar.h perlvars.h thrdvar.h
+ ! perl.h thread.h win32/Makefile
+____________________________________________________________________________
+[ 336] By: nick on 1997/11/29 19:13:55
+ Log: VC++ default to threaded
+ Branch: ansiperl
+ ! win32/Makefile
+____________________________________________________________________________
+[ 335] By: nick on 1997/11/29 18:38:26
+ Log: Avoid __declspec(thread) by default, for both scratch
+ return areas and THR stuff. Use struct thread intern instead.
+ Branch: ansiperl
+ ! win32/win32.c win32/win32.h win32/win32sck.c
+ ! win32/win32thread.c win32/win32thread.h
+____________________________________________________________________________
+[ 334] By: nick on 1997/11/29 17:49:04
+ Log: Non-threaded build fix
+ Branch: ansiperl
+ ! win32/win32thread.c
+____________________________________________________________________________
+[ 333] By: nick on 1997/11/29 17:29:07
+ Log: Sort out malloc_mutex for perl's malloc
+ Remove BINCOMPAT3 from embed.pl
+ Add dependancy to CORE_H for PERL95_OBJ
+ Branch: ansiperl
+ ! dosish.h embed.h embed.pl global.sym perl.h win32/Makefile
+ ! win32/win32.c
+____________________________________________________________________________
+[ 332] By: nick on 1997/11/29 16:21:01
+ Log: Integrate win32 into ansiperl
+ Branch: ansiperl
+ !> README.threads hints/irix_6.sh lib/Test/Harness.pm
+ !> lib/perl5db.pl malloc.c miniperlmain.c perl.h sv.c t/TEST
+ !> t/lib/anydbm.t t/lib/db-btree.t t/lib/db-hash.t
+ !> t/lib/db-recno.t t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t
+ !> t/lib/safe2.t t/lib/sdbm.t t/op/pat.t t/op/taint.t
+ !> win32/perllib.c
+____________________________________________________________________________
+[ 331] By: nick on 1997/11/29 01:35:45
+ Log: GCC + Threads on Win32 - best gcc results yet
+ Branch: ansiperl
+ ! XSUB.h perl.h thread.h win32/makedef.pl win32/makegcc.mk
+ ! win32/win32.h win32/win32iop.h win32/win32thread.c
+ ! win32/win32thread.h
+____________________________________________________________________________
+[ 330] By: nick on 1997/11/28 23:05:08
+ Log: Un-botch gcc workround
+ Branch: ansiperl
+ ! XSUB.h
+____________________________________________________________________________
+[ 329] By: nick on 1997/11/28 22:39:39
+ Log: Builds completely with Mingw32, dynamic loaded extensions
+ don't work yet - suspect __declspec() non-implemented issues.
+ Branch: ansiperl
+ ! XSUB.h lib/ExtUtils/Command.pm lib/ExtUtils/MM_Win32.pm
+ ! lib/ExtUtils/Mksymlists.pm win32/config.gc win32/makegcc.mk
+ ! win32/runperl.c win32/win32.c win32/win32iop.h
+____________________________________________________________________________
+[ 328] By: gsar on 1997/11/28 05:48:15
+ Log: integrate winansi.
+ Branch: win32/perl
+ +> win32/config.gc win32/config_H.gc win32/makegcc.mk
+ ! perl.h
+ !> dosish.h hv.c win32/dl_win32.xs win32/include/sys/socket.h
+ !> win32/makedef.pl win32/makefile.mk win32/runperl.c
+ !> win32/win32.c win32/win32.h win32/win32iop.h win32/win32sck.c
+____________________________________________________________________________
+[ 327] By: gsar on 1997/11/28 05:38:48
+ Log: Integrate mainline.
+ Branch: win32/perl
+ !> README.threads hints/irix_6.sh lib/Test/Harness.pm
+ !> lib/perl5db.pl malloc.c miniperlmain.c sv.c t/TEST
+ !> t/lib/anydbm.t t/lib/db-btree.t t/lib/db-hash.t
+ !> t/lib/db-recno.t t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t
+ !> t/lib/safe2.t t/lib/sdbm.t t/op/pat.t t/op/taint.t
+ !> win32/perllib.c
+____________________________________________________________________________
+[ 326] By: nick on 1997/11/27 19:13:36
+ Log: GCC builds perl.dll and perl.exe on Win32
+ Branch: ansiperl
+ ! win32/makedef.pl win32/makegcc.mk
+____________________________________________________________________________
+[ 325] By: nick on 1997/11/27 17:46:30
+ Log: Add files and tweak others to get 'native' Mingw32 gcc port as
+ far as building miniperl and perl.dll (but not import lib yet)
+ Seems to lack popen()/pclose() and fcloseall() and fflushall().
+ Also only CRTDLL not MCRTDLL so threading is probably not
+ possible yet.
+ Had to mess with win32iop.h's placement as we need __attribute__
+ to get STDCALL, and #define of printf messes up proto.h
+ Branch: ansiperl
+ + win32/config.gc win32/config_H.gc win32/makegcc.mk
+ ! dosish.h perl.h win32/dl_win32.xs win32/include/sys/socket.h
+ ! win32/makefile.mk win32/runperl.c win32/win32.c win32/win32.h
+ ! win32/win32iop.h win32/win32sck.c
+____________________________________________________________________________
+[ 324] By: mbeattie on 1997/11/27 17:08:06
+ Log: Give dire warnings about the IRIX 6.2 kernel panic.
+ Branch: perl
+ ! README.threads hints/irix_6.sh
+____________________________________________________________________________
+[ 323] By: mbeattie on 1997/11/27 16:57:33
+ Log: Fix prototypes of sv_vsetpvfn and sv_vcatpvfn:
+ Subject: Re: ANNOUNCE: perl 5.004_55 is available
+ Date: 27 Nov 1997 17:18:53 +0100
+ From: koenig@kulturbox.de (Andreas J. Koenig)
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 322] By: mbeattie on 1997/11/27 16:12:15
+ Log: Integrate win32 branch back into mainline.
+ Branch: perl
+ !> (integrate 42 files)
+____________________________________________________________________________
+[ 321] By: mbeattie on 1997/11/27 15:06:36
+ Log: Fix t/lib/safe2.t for SunOS 4.1.3:
+ Subject: Re: ANNOUNCE: perl 5.004_55 is available
+ Date: Thu, 27 Nov 1997 10:46:42 +0000 (GMT)
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Branch: perl
+ ! t/lib/safe2.t
+____________________________________________________________________________
+[ 320] By: mbeattie on 1997/11/27 15:02:59
+ Log: Fix MYMALLOC (wrong #define in malloc.c):
+ Subject: 5.004_55: MYMALLOC completely busted
+ Date: Thu, 27 Nov 1997 01:08:16 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! malloc.c
+____________________________________________________________________________
+[ 319] By: mbeattie on 1997/11/27 15:01:37
+ Log: Fix newSVrv so sv_setref_foo work better:
+ Subject: [PATCH] [5.004_55] newSVrv (again)
+ Date: Thu, 27 Nov 1997 00:25:50 -0500
+ From: Owen Taylor <owt1@cornell.edu>
+ Branch: perl
+ ! sv.c
+____________________________________________________________________________
+[ 318] By: mbeattie on 1997/11/27 14:59:03
+ Log: Output skipped test information in test suite:
+ Subject: 5.004_55: Making test harness platform_aware
+ Date: Wed, 26 Nov 1997 17:16:55 -0500 (EST)
+ Date: Wed, 26 Nov 1997 17:16:55 -0500 (EST)
+ Branch: perl
+ ! lib/Test/Harness.pm t/TEST t/lib/anydbm.t t/lib/db-btree.t
+ ! t/lib/db-hash.t t/lib/db-recno.t t/lib/gdbm.t t/lib/ndbm.t
+ ! t/lib/odbm.t t/lib/sdbm.t t/op/taint.t
+____________________________________________________________________________
+[ 317] By: mbeattie on 1997/11/27 14:55:15
+ Log: Add 'W'atch command to debugger and improve help:
+ Subject: 5.004_55: Debugger patch again
+ Date: Wed, 26 Nov 1997 17:05:57 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! lib/perl5db.pl
+____________________________________________________________________________
+[ 316] By: mbeattie on 1997/11/27 14:52:44
+ Log: Stop double initialisation of malloc_mutex:
+ Subject: 5.004_55: Double initialiazation of malloc_mutex
+ Date: Wed, 26 Nov 1997 16:51:43 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! miniperlmain.c win32/perllib.c
+____________________________________________________________________________
+[ 315] By: mbeattie on 1997/11/27 14:48:58
+ Log: Fix PVLV case in sv_setsv (plus tests in op/pat.t).
+ Branch: perl
+ ! sv.c t/op/pat.t
+____________________________________________________________________________
+[ 314] By: nick on 1997/11/27 01:03:19
+ Log: Merge win32 and ansiperl branches post _55 tweaks from Sarathy.
+ Branch: ansiperl
+ !> (integrate 897 files)
+____________________________________________________________________________
+[ 313] By: gsar on 1997/11/26 03:20:55
+ Log: merge win32-aware installperl in ansiperl branch.
+ Branch: win32/perl
+ !> installperl
+____________________________________________________________________________
+[ 312] By: gsar on 1997/11/26 01:50:37
+ Log: Fix for C<sort 'foo'...> bug:
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Message-Id: <199711011946.OAA18882@aatma.engin.umich.edu>
+ Subject: [PATCH] Re: Sort grammar bug
+ Date: Sat, 01 Nov 1997 14:46:35 -0500
+ ------
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Message-Id: <199711021247.MAA01743@crypt.compulink.co.uk>
+ Subject: Re: Sort grammar bug
+ Date: Sun, 02 Nov 1997 12:47:51 +0000
+ Branch: win32/perl
+ ! t/op/sort.t toke.c
+____________________________________________________________________________
+[ 311] By: nick on 1997/11/26 01:42:50
+ Log: Win32-ize installperl
+ Branch: ansiperl
+ ! installperl
+____________________________________________________________________________
+[ 310] By: gsar on 1997/11/26 01:36:39
+ Log: Another trivial patch:
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Message-Id: <199710300245.VAA04244@aatma.engin.umich.edu>
+ Subject: [PATCH] Re: Why doesn't XSRETURN have STMT_START/STMT_END brackets?
+ Date: Wed, 29 Oct 1997 21:45:26 -0500
+ Branch: win32/perl
+ ! XSUB.h
+____________________________________________________________________________
+[ 309] By: nick on 1997/11/26 01:33:32
+ Log: Fixup _55 for Win32:
+ Missed thread :-> perl_thread changes
+ Two #define THR (not the same)
+ K&R style func in hv.c
+ Branch: ansiperl
+ ! hv.c win32/win32thread.c win32/win32thread.h
+____________________________________________________________________________
+[ 308] By: gsar on 1997/11/26 01:30:21
+ Log: Sync yet another patch (this one manually edited):
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Message-Id: <199710290251.VAA14362@aatma.engin.umich.edu>
+ Subject: [PATCH] Re: local($@) gives core dump
+ Date: Tue, 28 Oct 1997 21:51:25 -0500
+ Branch: win32/perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 307] By: gsar on 1997/11/26 01:22:10
+ Log: Sync another change from local repository.
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Message-Id: <199710290316.WAA15888@aatma.engin.umich.edu>
+ Subject: Re: do_postponed breaks with multiple interpreters
+ Date: Tue, 28 Oct 1997 22:16:13 -0500
+ Branch: win32/perl
+ ! op.c
+____________________________________________________________________________
+[ 306] By: gsar on 1997/11/26 01:17:46
+ Log: Sync a change from local repository.
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Message-Id: <199710290106.UAA11485@aatma.engin.umich.edu>
+ Subject: [PATCH] Re: Core dump from using sockets w/ system or open(pipe) or "`"
+ Date: Tue, 28 Oct 1997 20:06:06 -0500
+ Branch: win32/perl
+ ! mg.c
+____________________________________________________________________________
+[ 305] By: nick on 1997/11/26 00:50:10
+ Log: Integrate mainline as of _55
+ Branch: ansiperl
+ +> emacs/ptags
+ !> (integrate 36 files)
+____________________________________________________________________________
+[ 304] By: gsar on 1997/11/26 00:27:57
+ Log: Various changes to make it build cleanly and pass all tests:
+ - needed to run `perl embed.pl`
+ - use PERL_CORE instead of PERLDLL in places that do mean PERL_CORE
+ - fix prototypes for a few declarations (Borland is finally quiet)
+ - move declaration of Mymalloc etc to perl.h (since win32 and other
+ ports may #define malloc themselves, to let extensions bind to
+ the version that perl used)
+ - move struct reg_data into a public header file, since it is
+ referenced in a public datatype
+ - win32 makefile fixes
+ - fix remaining s/thread/perl_thread/
+ Branch: win32/perl
+ ! EXTERN.h embed.h ext/DynaLoader/dlutils.c
+ ! ext/SDBM_File/sdbm/sdbm.h hv.c perl.h proto.h regcomp.h
+ ! regexp.h win32/Makefile win32/dl_win32.xs win32/makefile.mk
+ ! win32/win32.h win32/win32iop.h win32/win32thread.c
+____________________________________________________________________________
+[ 303] By: gsar on 1997/11/25 20:57:31
+ Log: Fixup the places where the automatic merge got it wrong.
+ Previous change (#302) was just a normal integration--ignore the
+ "reverse" in there.
+ Branch: win32/perl
+ ! op.c perl.h
+____________________________________________________________________________
+[ 302] By: gsar on 1997/11/25 20:32:12
+ Log: reverse integrate mainline
+ Branch: win32/perl
+ +> emacs/ptags
+ !> (integrate 896 files)
+
+----------------
+Version 5.004_55
+----------------
+
+____________________________________________________________________________
+[ 301] By: mbeattie on 1997/11/25 17:59:53
+ Log: Fix minor thinkos in hv.c and pp_ctl.c. This is 5.004_55.
+ Branch: perl
+ ! hv.c pp_ctl.c
+____________________________________________________________________________
+[ 300] By: mbeattie on 1997/11/25 16:29:36
+ Log: Add t/avhv.t to MANIFEST and bump patchlevel.h to 55.
+ Branch: perl
+ ! MANIFEST patchlevel.h
+____________________________________________________________________________
+[ 299] By: mbeattie on 1997/11/25 15:59:16
+ Log: Move malloc_mutex initialisation/destruction:
+ Subject: patch to 5.004_54 for pthreads with Perl's malloc
+ From: ilya@math.ohio-state.edu (Ilya Zakharevich)
+ Branch: perl
+ ! malloc.c os2/os2.c os2/os2ish.h perl.c perl.h plan9/plan9ish.h
+ ! unixish.h vms/vmsish.h
+____________________________________________________________________________
+[ 298] By: mbeattie on 1997/11/25 15:49:22
+ Log: Make hv_ functions cope better with 'm'-magic:
+ Subject: [5.004_54] Another neglected patch
+ Date: Fri, 21 Nov 1997 22:28:17 -0500
+ From: Owen Taylor <owt1@cornell.edu>
+ Branch: perl
+ ! hv.c
+____________________________________________________________________________
+[ 297] By: mbeattie on 1997/11/25 15:47:36
+ Log: Fix typo in Thread.xs.
+ Branch: perl
+ ! ext/Thread/Thread.xs
+____________________________________________________________________________
+[ 296] By: mbeattie on 1997/11/25 15:42:07
+ Log: Integrate from ansi branch to mainline.
+ Branch: perl
+ !> (integrate 890 files)
+____________________________________________________________________________
+[ 295] By: mbeattie on 1997/11/25 14:29:31
+ Log: AIX patch for DynaLoader/dl_aix.xs and hints/aix.sh:
+ Subject: Re: _54 on AIX
+ Date: Tue, 25 Nov 1997 00:49:52 -0800 (PST)
+ From: Jarkko Hietaniemi <jarkko.hietaniemi@research.nokia.com>
+ Branch: perl
+ ! ext/DynaLoader/dl_aix.xs
+____________________________________________________________________________
+[ 294] By: mbeattie on 1997/11/25 14:29:10
+ Log: AIX patch for hints/aix.sh:
+ Subject: Re: _54 on AIX
+ Date: Tue, 25 Nov 1997 00:49:52 -0800 (PST)
+ From: Jarkko Hietaniemi <jarkko.hietaniemi@research.nokia.com>
+ Branch: perl
+ ! hints/aix.sh
+____________________________________________________________________________
+[ 291] By: mbeattie on 1997/11/25 14:17:05
+ Log: Fix scalar dereference of threadsv variables (e.g. $$_).
+ Branch: perl
+ ! op.c op.h
+____________________________________________________________________________
+[ 290] By: mbeattie on 1997/11/25 14:16:29
+ Log: AIX patch (including Configure support for {sched,pthread}_yield,
+ pthread initial detach state, renaming perl_thread to perl_os_thread
+ and struct thread to struct perl_thread):
+ Subject: Re: _54 on AIX
+ Date: Thu, 20 Nov 1997 06:10:51 -0800 (PST)
+ From: Jarkko Hietaniemi <jarkko.hietaniemi@research.nokia.com>
+ Branch: perl
+ ! Configure config_h.SH cv.h ext/DB_File/DB_File.xs
+ ! ext/Thread/Makefile.PL ext/Thread/Thread.pm
+ ! ext/Thread/Thread.xs fakethr.h hints/aix.sh perl.c perl.h pp.h
+ ! proto.h sv.h thread.h util.c win32/win32thread.c
+ ! win32/win32thread.h
+____________________________________________________________________________
+[ 289] By: mbeattie on 1997/11/25 12:33:02
+ Log: Rename perl_thread to perl_os_thread.
+ Branch: perl
+ ! fakethr.h thread.h util.c win32/win32thread.h
+____________________________________________________________________________
+[ 288] By: mbeattie on 1997/11/25 12:27:35
+ Log: Remove bincompat3 support:
+ Subject: Re: ANNOUNCE: perl5.004_54 is available
+ Date: Wed, 19 Nov 1997 08:07:10 -0800 (PST)
+ From: Jarkko Hietaniemi <jarkko.hietaniemi@research.nokia.com>
+ Branch: perl
+ ! Configure INSTALL embed.h global.sym malloc.c
+____________________________________________________________________________
+[ 287] By: mbeattie on 1997/11/25 12:23:50
+ Log: Emacs/tags update:
+ Subject: Emacs/tags update for 5.004_54
+ Date: Fri, 21 Nov 1997 15:02:09 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ + emacs/ptags
+ ! MANIFEST Makefile.SH emacs/cperl-mode.el
+____________________________________________________________________________
+[ 286] By: nick on 1997/11/23 23:03:56
+ Log: Add $$_ test
+ Branch: ansiperl
+ ! t/op/ref.t
+____________________________________________________________________________
+[ 285] By: gsar on 1997/11/23 08:26:00
+ Log: Initial reverse integration of winansi branch.
+ Branch: win32/perl
+ !> (integrate 50 files)
+____________________________________________________________________________
+[ 284] By: gsar on 1997/11/23 07:32:24
+ Log: Add to docs about the BEGIN { shift } feature. Make the change
+ yet simpler using CvUNIQUE(compcv) instead of subline (Chip's idea).
+ Branch: win32/perl
+ ! op.c perly.c perly.y pod/perlfunc.pod vms/perly_c.vms
+____________________________________________________________________________
+[ 283] By: nick on 1997/11/22 21:29:30
+ Log: Duplicate perl_threadsv
+ Branch: ansiperl
+ ! global.sym
+____________________________________________________________________________
+[ 282] By: nick on 1997/11/22 21:18:11
+ Log: Munge pseudo-Configure stuff to add -thread to archname as
+ Malcolm seems to think that is way to test for threads.
+ Update @INC stuffing hackery to have traditional @INC
+ search order archlib, privlib, sitearch, site.
+ Branch: ansiperl
+ ! t/lib/english.t win32/config.bc win32/config_H.bc
+ ! win32/config_H.vc win32/config_h.PL win32/config_sh.PL
+ ! win32/makefile.mk win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 281] By: nick on 1997/11/22 19:28:21
+ Log: Builds and passes all but english.t on win32 VC++
+ Branch: ansiperl
+ ! global.sym pp_ctl.c win32/Makefile win32/config.vc
+ ! win32/config_H.vc win32/win32thread.h
+____________________________________________________________________________
+[ 280] By: nick on 1997/11/22 18:10:50
+ Log: ansiperl builds with Borland C++ again
+ Branch: ansiperl
+ ! pp_ctl.c regcomp.c regcomp.h regexec.c toke.c util.c
+ ! win32/config.bc win32/config_H.bc win32/perlglob.c
+ ! win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 279] By: nick on 1997/11/22 16:42:51
+ Log: Resolve ansiperl against mainline
+ Branch: ansiperl
+ !> embed.h ext/Thread/Thread.xs global.sym op.c op.h perl.c
+ !> perl.h pp.c pp_ctl.c pp_hot.c proto.h scope.c scope.h
+ !> t/lib/english.t thread.h toke.c util.c
+____________________________________________________________________________
+[ 278] By: nick on 1997/11/22 16:30:27
+ Log: Resolve ansiperl against win32
+ Branch: ansiperl
+ !> (integrate 55 files)
+____________________________________________________________________________
+[ 277] By: gsar on 1997/11/22 09:48:02
+ Log: - shift() inside BEGIN|END|INIT now shifts @ARGV instead of @_
+ - added a test for the above
+ - fixed up perly.c.diff and vms/perl_c.vms for above and added the
+ ansification hunks
+ Branch: win32/perl
+ ! op.c perly.c perly.c.diff perly.y t/op/misc.t vms/perly_c.vms
+____________________________________________________________________________
+[ 276] By: gsar on 1997/11/22 07:24:01
+ Log: Generic change in win32 branch: don't just turn on CRIPPLED_CC
+ when USE_THREADS. GCC for instance, can do without macros that use
+ globals. Instead, selectively re#define only those macros
+ that use globals to their functional equivalents. Tests 100% on
+ Solaris/gcc (after `chmod +x t/op/nothread.t t/lib/thread.t` (hint,hint)).
+ Branch: win32/perl
+ ! perl.h sv.h
+____________________________________________________________________________
+[ 275] By: gsar on 1997/11/22 05:27:04
+ Log: Integrate mainline.
+ Branch: win32/perl
+ +> ext/Thread/die.t ext/Thread/die2.t t/op/avhv.t
+ - lib/Class/Fields.pm lib/ISA.pm
+ !> (integrate 41 files)
+____________________________________________________________________________
+[ 274] By: mbeattie on 1997/11/21 18:28:22
+ Log: $_ is now per-thread (rather a lot of changes). Only tested under
+ *-linux-thread at the moment.
+ Branch: perl
+ ! embed.h ext/Thread/Thread.xs global.sym op.c op.h perl.c
+ ! perl.h pp.c pp_ctl.c pp_hot.c proto.h scope.c scope.h
+ ! t/lib/english.t thread.h toke.c util.c
+____________________________________________________________________________
+[ 273] By: mbeattie on 1997/11/21 10:31:29
+ Log: Filter patch to toke.c:
+ Subject: Tiny core patch for source filters
+ Date: Thu, 20 Nov 1997 23:12:09 +0000 (GMT)
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Branch: perl
+ ! toke.c
+____________________________________________________________________________
+[ 272] By: nick on 1997/11/21 00:54:43
+ Log: Basic integrate of lastest perl into ansiperl
+ Branch: ansiperl
+ +> ext/Thread/die.t ext/Thread/die2.t t/op/avhv.t
+ - lib/Class/Fields.pm lib/ISA.pm
+ ! win32/win32.c win32/win32.h
+ !> (integrate 57 files)
+____________________________________________________________________________
+[ 271] By: mbeattie on 1997/11/20 12:12:00
+ Log: Initial stab at IRIX configuration support for threading. Manually
+ applied parts of following patches:
+ Subject: Perl 5.004_54 on IRIX
+ Date: Wed, 19 Nov 1997 18:37:14 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Subject: Re: Perl 5.004_54 on IRIX
+ Date: 19 Nov 1997 17:10:17 -0800
+ From: Scott Henry <scotth@sgi.com>
+ Branch: perl
+ ! README.threads hints/irix_6.sh hints/irix_6_0.sh
+ ! hints/irix_6_1.sh perl.h
+____________________________________________________________________________
+[ 270] By: mbeattie on 1997/11/19 17:45:37
+ Log: The new jumbo regexp stuff did SSPUSHINT on a char* instead of
+ SSPUSHPTR causing Alpha to core dump in pat.t. While fixing it,
+ also fixed two instances of referring to SVs after destruction.
+ Branch: perl
+ ! regcomp.c regexec.c
+____________________________________________________________________________
+[ 269] By: mbeattie on 1997/11/19 15:33:23
+ Log: avhv_keys under Digital UNIX made avhv.t fail because *keysp was
+ changed by mg_get(*keysp) (!). Introducing a new local variable
+ fixed it but I don't know if it's a compiler problem or some
+ other corruption happening elsewhere.
+ Branch: perl
+ ! av.c
+____________________________________________________________________________
+[ 268] By: mbeattie on 1997/11/19 11:39:49
+ Log: Let Configure sort out get{host,net}byaddr* prototypes:
+ Subject: [PATCH] 5.004_54: little something for
+ get{hos,ne}tbyaddr protos (Configure, config_h.SH, pp_sys.c)
+ Date: Tue, 18 Nov 1997 19:08:19 +0200 (EET)
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Branch: perl
+ ! Configure config_h.SH pp_sys.c
+____________________________________________________________________________
+[ 267] By: mbeattie on 1997/11/19 11:04:15
+ Log: Jumbo regexp patch applied (with minor fix-up tweaks):
+ Subject: Version 7 of Jumbo RE patch available
+ Date: Sun, 16 Nov 1997 00:29:39 -0500 (EST)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Branch: perl
+ ! MANIFEST dump.c embed.h global.sym mg.c op.c op.h perl.c
+ ! perl.h pod/perlre.pod pp.c pp_ctl.c pp_hot.c proto.h regcomp.c
+ ! regcomp.h regexec.c regexp.h sv.c t/op/misc.t t/op/pat.t
+ ! t/op/re_tests t/op/regexp.t t/op/split.t t/op/subst.t toke.c
+ ! util.c
+____________________________________________________________________________
+[ 266] By: mbeattie on 1997/11/18 17:26:09
+ Log: Separate avhv_foo() key handling into avhv_keys(). Slightly tweaked
+ version of patch:
+ Subject: tie fake hash patch for 5.004_54
+ Date: Sat, 15 Nov 1997 19:18:30 -0500
+ From: Joshua Pritikin <pritikin@mindspring.com>
+ Branch: perl
+ + t/op/avhv.t
+ ! av.c embed.h global.sym proto.h
+____________________________________________________________________________
+[ 265] By: mbeattie on 1997/11/18 16:51:04
+ Log: Bring MANIFEST up to date. Add new thread tests.
+ Branch: perl
+ + ext/Thread/die.t ext/Thread/die2.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 264] By: mbeattie on 1997/11/18 16:41:27
+ Log: magic_setisa enhanced to update %FIELDS automatically when @ISA
+ is assigned to. Added tests to t/op/array.t. magic_setisa now
+ warns about including non-existent packages in @ISA when -w is on.
+ Branch: perl
+ - lib/Class/Fields.pm lib/ISA.pm
+ ! mg.c t/op/array.t
+____________________________________________________________________________
+[ 263] By: mbeattie on 1997/11/18 16:38:57
+ Log: Fix typo in win32 -> mainline integration.
+ Branch: perl
+ ! perl.h
+____________________________________________________________________________
+[ 262] By: mbeattie on 1997/11/18 11:56:09
+ Log: Integrate win32 branch back into mainline.
+ Branch: perl
+ - win32/win32io.c win32/win32io.h
+ ! op.c
+ !> (integrate 30 files)
+____________________________________________________________________________
+[ 261] By: gsar on 1997/11/18 00:14:02
+ Log: Export our own FD_SET() et al to complete sockets-as-handles pretense.
+ Branch: win32/perl
+ ! win32/config.bc win32/config.vc win32/config_H.bc
+ ! win32/config_H.vc win32/include/sys/socket.h win32/win32sck.c
+____________________________________________________________________________
+[ 260] By: nick on 1997/11/16 23:16:16
+ Log: Generic file changes for MYMALLOC
+ Branch: ansiperl
+ ! miniperlmain.c perl.c
+____________________________________________________________________________
+[ 259] By: nick on 1997/11/16 23:14:36
+ Log: MYMALLOC for Win32:
+ 1. Initialize malloc_mutex before it is used (all platforms!)
+ 2. Adjust #ifdef muddle to allow MYMALLOC and win32_ to coexist
+ 3. Tweak win32/config*.* to define MYMALLOC
+ 4. Provide sbrk() in terms of VirtualAlloc().
+
+ Also fixup -MT (perl95) build to handle Perl_current_thread
+ via call to DLL (as though an extension).
+ Branch: ansiperl
+ ! win32/Makefile win32/config.bc win32/config.vc
+ ! win32/config_H.bc win32/config_H.vc win32/makedef.pl
+ ! win32/makefile.mk win32/perllib.c win32/win32.c win32/win32.h
+ ! win32/win32iop.h win32/win32thread.h
+____________________________________________________________________________
+[ 258] By: nick on 1997/11/15 20:42:28
+ Log: Implement dTHR via __declspec(thread) - part 2
+ Branch: ansiperl
+ ! win32/makedef.pl win32/win32thread.c win32/win32thread.h
+____________________________________________________________________________
+[ 257] By: nick on 1997/11/15 19:52:53
+ Log: Use __declspec(thread) var rather tha TslAlloc & co.
+ Branch: ansiperl
+ ! win32/makedef.pl win32/win32thread.c win32/win32thread.h
+____________________________________________________________________________
+[ 256] By: gsar on 1997/11/15 02:58:09
+ Log: Add #include guard in Thread.xs so it will build even under
+ no USE_THREADS (for win32). This was missed because of edit
+ w/o checkout perforce kludge.
+ Branch: win32/perl
+ ! ext/Thread/Thread.xs
+____________________________________________________________________________
+[ 255] By: nick on 1997/11/15 00:33:46
+ Log: Integrate mainline (5.004_54?) into ansiperl
+ Branch: ansiperl
+ !> MANIFEST embed.h ext/Thread/Thread.pm ext/Thread/Thread.xs
+ !> ext/Thread/Thread/Specific.pm ext/Thread/join.t
+ !> ext/Thread/specific.t global.sym lib/fields.pm mg.c op.c
+ !> perl.c perl.h pp_ctl.c pp_hot.c pp_sys.c proto.h scope.c
+ !> t/io/pipe.t t/lib/io_pipe.t t/op/magic.t thread.h
+____________________________________________________________________________
+[ 254] By: nick on 1997/11/15 00:25:26
+ Log: Interate win32 into ansiperl
+ Branch: ansiperl
+ +> ext/Thread/Thread/Specific.pm ext/Thread/specific.t
+ +> lib/fields.pm
+ !> MANIFEST embed.h ext/Thread/Thread.pm ext/Thread/Thread.xs
+ !> ext/Thread/join.t global.sym mg.c op.c perl.c perl.h pp_ctl.c
+ !> pp_hot.c pp_sys.c proto.h scope.c t/io/pipe.t t/lib/io_pipe.t
+ !> t/op/magic.t thread.h win32/Makefile win32/config.bc
+ !> win32/config.vc win32/config_sh.PL win32/makefile.mk
+____________________________________________________________________________
+[ 253] By: gsar on 1997/11/14 22:04:58
+ Log: Integrate mainline changes into win32 branch. Now would be a good time
+ to reverse integrate the win32 branch into mainline.
+ Branch: win32/perl
+ +> ext/Thread/Thread/Specific.pm ext/Thread/specific.t
+ +> lib/fields.pm
+ !> MANIFEST embed.h ext/Thread/Thread.pm ext/Thread/Thread.xs
+ !> ext/Thread/join.t global.sym mg.c op.c perl.c perl.h pp_ctl.c
+ !> pp_hot.c pp_sys.c proto.h scope.c t/io/pipe.t t/lib/io_pipe.t
+ !> t/op/magic.t thread.h
+
+----------------
+Version 5.004_54
+----------------
+
+____________________________________________________________________________
+[ 252] By: mbeattie on 1997/11/14 15:07:19
+ Log: Two more delays added to test suite to help *-solaris-thread.
+ Branch: perl
+ ! t/io/pipe.t t/lib/io_pipe.t
+____________________________________________________________________________
+[ 251] By: mbeattie on 1997/11/14 15:05:57
+ Log: Remove stale code from Thread.xs.
+ Branch: perl
+ ! ext/Thread/Thread.xs
+____________________________________________________________________________
+[ 250] By: mbeattie on 1997/11/14 10:12:40
+ Log: Add delay to signal handling in t/op/magic.t. (Solaris with pthreads
+ doesn't run handlers for self-sent signals until kill has returned.)
+ Branch: perl
+ ! t/op/magic.t
+____________________________________________________________________________
+[ 249] By: gsar on 1997/11/14 05:14:44
+ Log: Fix various details in win32 makefiles and Config.pm setup.
+ - ldflags is set for both compilers now
+ - extensions list is now correct
+ - delete perl95.exe on distclean
+ - cf_time now gets updated (once)
+ - ccdlflags is set for Borland
+ - fix startperl so dprofpp works
+ Branch: win32/perl
+ ! win32/Makefile win32/config.bc win32/config.vc
+ ! win32/config_sh.PL win32/makefile.mk
+____________________________________________________________________________
+[ 248] By: mbeattie on 1997/11/13 18:01:27
+ Log: Rewrite thread return code to distinguish between ordinary return
+ and die() and make join propagate the die. Add tiny method eval
+ which just does "return eval { shift->join; }". Add Thread::Specific
+ class for access to thread specific user data along with specific.t.
+ Rename Class to classname throughout Thread.xs for consistency.
+ Fix pp_specific to pp_threadsv in global.sym. Add support to
+ pp_entersub in pp_hot.c to lock stash for static locked methods.
+ Branch: perl
+ + ext/Thread/Thread/Specific.pm ext/Thread/specific.t
+ + lib/fields.pm
+ ! MANIFEST embed.h ext/Thread/Thread.pm ext/Thread/Thread.xs
+ ! ext/Thread/join.t global.sym mg.c pp_hot.c thread.h
+____________________________________________________________________________
+[ 247] By: mbeattie on 1997/11/13 14:13:30
+ Log: Change CONTEXT to PERL_CONTEXT throughout source (since the #define
+ to avoid the Digital UNIX clash no longer works). Changed the #ifdef
+ in pp_sys.c for whether getnet* function get protoyped (since the
+ default had a broken prototype for getnetbyaddr).
+ Branch: perl
+ ! mg.c op.c perl.c perl.h pp_ctl.c pp_hot.c pp_sys.c proto.h
+ ! scope.c thread.h
+____________________________________________________________________________
+[ 246] By: nick on 1997/11/13 02:44:40
+ Log: Integrate Win32 branch
+ Branch: ansiperl
+ - configure ext/util/extliblist win32/bin/pl2bat.bat
+ - win32/bin/search.bat win32/bin/test.bat win32/bin/webget.bat
+ - win32/config.H win32/config.w32 win32/win32io.c
+ - win32/win32io.h
+ !> (integrate 905 files)
+____________________________________________________________________________
+[ 245] By: nick on 1997/11/13 00:47:54
+ Log: Integrate (-ay) win32 branch at its creation to
+ establish and ancestor as per perkforce technote #9
+ Branch: ansiperl
+ +> configure ext/util/extliblist win32/bin/pl2bat.bat
+ +> win32/bin/search.bat win32/bin/test.bat win32/bin/webget.bat
+ +> win32/config.H win32/config.w32
+ !> (integrate 859 files)
+____________________________________________________________________________
+[ 244] By: gsar on 1997/11/12 22:26:39
+ Log: More cleanups of win32/win32*.[ch] files. win32/win32iop.h now
+ contains the all the declarations and macros for the win32io layer.
+ New std-ish functions are exported now. All win32-specific exported
+ functions begin with "win32_" consistently. win32 version of
+ init_os_extras() is now exported, so embedders can get the in-core
+ xsubs.
+ Branch: win32/perl
+ ! dosish.h win32/makedef.pl win32/win32.c win32/win32.h
+ ! win32/win32iop.h win32/win32sck.c
+____________________________________________________________________________
+[ 243] By: gsar on 1997/11/12 07:41:52
+ Log: Really delete deleted files.
+ Branch: win32/perl
+ - win32/win32io.c win32/win32io.h
+____________________________________________________________________________
+[ 242] By: gsar on 1997/11/12 07:40:54
+ Log: Egregious IOsubsystem code excised. Phew, what a relief! Two
+ files (win32/win32io.[ch]) completely removed, as are all traces
+ of them in makefiles and MANIFEST. RunPerl() retains the void* arg
+ for later. Various myfoo() things regularized to my_foo(). CPP not
+ required anymore to create a perl binary :)
+ Branch: win32/perl
+ ! MANIFEST win32/Makefile win32/makedef.pl win32/makefile.mk
+ ! win32/perllib.c win32/runperl.c win32/win32.c win32/win32.h
+ ! win32/win32io.c win32/win32io.h win32/win32iop.h
+ ! win32/win32sck.c
+____________________________________________________________________________
+[ 241] By: gsar on 1997/11/12 05:31:28
+ Log: Fix various win32 code blemishes:
+ - s/stolen/win32/g
+ - s/(CROAK|WARN)/lc($1)/eg
+ - remove deadcode from most places
+ Branch: win32/perl
+ ! win32/makedef.pl win32/win32.c win32/win32io.c
+ ! win32/win32iop.h
+____________________________________________________________________________
+[ 240] By: gsar on 1997/11/12 04:36:29
+ Log: Carry over changes in ansiperl branch. Win32 branch is now
+ the leading edge.
+ Branch: win32/perl
+ ! embed.h global.sym perl.c win32/win32thread.c
+ ! win32/win32thread.h
+____________________________________________________________________________
+[ 239] By: gsar on 1997/11/12 03:39:57
+ Log: Add missing win32_closesocket() and export it (extension writers' complaint).
+ Branch: win32/perl
+ ! win32/include/sys/socket.h win32/makedef.pl win32/win32sck.c
+____________________________________________________________________________
+[ 238] By: gsar on 1997/11/12 03:25:17
+ Log: Clean up win32/win32sck.c (runtime load of Winsock now gone, it can be
+ done cleaner, if really needed (perhaps only for efficiency reasons?)).
+ Redundant EXTERN_C definitions and related warnings fixed.
+ Branch: win32/perl
+ ! miniperlmain.c perl.h win32/perllib.c win32/win32io.c
+ ! win32/win32iop.h win32/win32sck.c
+____________________________________________________________________________
+[ 237] By: nick on 1997/11/12 02:45:15
+ Log: Fixup Win32
+ - #undef start_env before re-#defining it
+ - change pp_specific pp_threadsv in global.sym
+ - re-build embed.h
+ - avoid HAVE_THREAD_INTERN - we don't and empty struct
+ is a pain. If we did have it it would contain cached
+ values of things we can only get at _IN_ the thread
+ so new_struct_thread is wrong place to call it.
+ - add new macro SET_THREAD_SELF - we must (in main thread)
+ define in win32thread.h, support in win32thread.c,
+ test and call in perl.c
+ Branch: ansiperl
+ ! embed.h global.sym perl.c thread.h win32/win32thread.c
+ ! win32/win32thread.h
+____________________________________________________________________________
+[ 236] By: nick on 1997/11/12 01:54:23
+ Log: Integrate mainline after it integrated us.
+ Accepted 'theirs' everywhere - so two branches should
+ now point to same files again.
+ Almost all of these were what was suggested, others were
+ whitespace diffs. A few dubious spots which we will now
+ go fix.
+ Branch: ansiperl
+ !> embed.h ext/DB_File/DB_File.xs ext/GDBM_File/GDBM_File.xs
+ !> ext/Opcode/Opcode.pm ext/Thread/Thread.xs interp.sym mg.c op.c
+ !> opcode.h opcode.pl perl.c perl.h pp.c pp_ctl.c pp_sys.c t/TEST
+ !> t/lib/safe2.t t/lib/thread.t t/op/nothread.t thread.h toke.c
+ !> util.c
+____________________________________________________________________________
+[ 235] By: gsar on 1997/11/12 01:22:26
+ Log: Minor tweaks to add a thread_intern struct that should ultimately
+ contain all the win32-specific statics.
+ Win32 branch now passes all tests with or w/o USE_THREADS.
+ Branch: win32/perl
+ ! embed.h perl.c win32/win32thread.c win32/win32thread.h
+____________________________________________________________________________
+[ 234] By: gsar on 1997/11/11 23:08:54
+ Log: Initial (untested) integration of mainline changes.
+ Branch: win32/perl
+ - configure
+ !> (integrate 89 files)
+____________________________________________________________________________
+[ 233] By: mbeattie on 1997/11/11 18:07:30
+ Log: Typo in thread.h: ADD_THREAD_INTERN should be HAVE_THREAD_INTERN
+ Branch: perl
+ ! thread.h
+____________________________________________________________________________
+[ 232] By: mbeattie on 1997/11/11 17:49:12
+ Log: t/TEST (reverted to @229 version) should have been included in the
+ previous change (231) but my way of recovering it didn't work
+ properly. The change 231 comments about successful tests applies
+ to this t/TEST (i.e. as of this change).
+ Branch: perl
+ ! t/TEST
+____________________________________________________________________________
+[ 231] By: mbeattie on 1997/11/11 17:46:59
+ Log: Fix up ansiperl integration. Back to passing all expected tests
+ with usethreads. Untested with non-threaded perl.
+ Branch: perl
+ ! embed.h ext/DB_File/DB_File.xs ext/GDBM_File/GDBM_File.xs
+ ! perl.c perl.h pp.c t/lib/thread.t t/op/nothread.t util.c
+____________________________________________________________________________
+[ 230] By: mbeattie on 1997/11/11 16:36:22
+ Log: Initial integration of ansi branch into mainline (untested).
+ Branch: perl
+ +> t/lib/thread.t t/op/nothread.t thread.sym
+ - configure
+ !> (integrate 84 files)
+____________________________________________________________________________
+[ 229] By: mbeattie on 1997/11/11 15:20:43
+ Log: Change name of OP_SPECIFIC to OP_THREADSV. Fixed perl_get_sv when
+ getting per-thread magicals. Fixed thr->errsv initialisation.
+ Branch: perl
+ ! ext/Opcode/Opcode.pm op.c opcode.h opcode.pl perl.c pp.c
+ ! t/lib/safe2.t toke.c
+____________________________________________________________________________
+[ 228] By: mbeattie on 1997/11/11 12:48:26
+ Log: Fix up $@ (ERRSV now refers to GvSV(errgv) for non-threaded perl and
+ thr->errsv for threaded perl). Fix pp_tie and pp_dbmopen to use
+ GvCV(gv) instead of gv so AUTOLOAD stuff works. All tests now pass
+ again for non-threaded perl. Enhanced perl_get_sv to return
+ per-thread magicals where necessary for threaded perl.
+ Branch: perl
+ ! embed.h ext/Thread/Thread.xs interp.sym mg.c op.c perl.c
+ ! perl.h pp_ctl.c pp_sys.c thread.h toke.c util.c
+____________________________________________________________________________
+[ 227] By: mbeattie on 1997/11/11 11:00:02
+ Log: hashlock bug.
+
+ Jobs fixed ...
+
+ hashlock fixed on 1997/11/11 by mbeattie@localhost
+
+ Subject: [perl5.004_53; patch] Another hash-locking fix
+ Date: 23 Oct 1997 14:13:55 -0400
+ From: Owen Taylor <owt1@cornell.edu>
+ Branch: bugs
+ + hashlock
+____________________________________________________________________________
+[ 226] By: gsar on 1997/11/11 02:11:23
+ Log: Slightly more refined lock() keyword recognition (using %INC).
+ Branch: win32/perl
+ ! toke.c
+____________________________________________________________________________
+[ 225] By: gsar on 1997/11/11 00:26:09
+ Log: "weak" lock keyword (hardcoded initial implementation) now works.
+ if not defined(&Thread::join) and defined(&__PACKAGE__::lock), 'lock'
+ is recognized as a sub, a regular keyword otherwise. Could be
+ generalized by storing a flag for every op in OP struct, and turning
+ the flag off when Thread.xs loads.
+ Branch: win32/perl
+ ! toke.c
+____________________________________________________________________________
+[ 224] By: gsar on 1997/11/10 22:59:55
+ Log: Merge a patch in preparation for "weak keywords":
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Message-Id: <199710080618.CAA23899@aatma.engin.umich.edu>
+ Subject: [PATCH] global overrides for keywords
+ Date: Wed, 08 Oct 1997 02:18:23 -0400
+ Branch: win32/perl
+ ! embed.h interp.sym perl.c perl.h toke.c
+____________________________________________________________________________
+[ 223] By: gsar on 1997/11/10 22:41:31
+ Log: Remove runlevel. It was used to count how many runops() calls
+ we were in the process of executing, and longjmp() to the topmost
+ one (if not already there). We use a null top_env->je_prev
+ to distinguish that now.
+ Branch: win32/perl
+ ! embed.h interp.sym perl.h pp_ctl.c run.c thread.h util.c
+____________________________________________________________________________
+[ 222] By: gsar on 1997/11/10 04:47:48
+ Log: Win32 branch now contains all non-ansification changes in ansiperl branch.
+ USE_THREADS case builds and passes all tests using both compilers.
+ Additional tweaks:
+ - fixup win32/makedef.pl to skip more symbols for non-thread build.
+ - sync win32/Makefile with win32/makefile.mk
+ >>>Non-thread build fails a lot of tests.<<<
+ Branch: win32/perl
+ + thread.sym
+ ! MANIFEST ext/Thread/Thread.xs perl.c perl.h pp_sys.c sv.c
+ ! util.c win32/Makefile win32/config.bc win32/config_H.bc
+ ! win32/makedef.pl win32/makefile.mk
+____________________________________________________________________________
+[ 221] By: gsar on 1997/11/10 00:57:53
+ Log: Initial (untested) merge of all non-ansi changes on ansiperl branch
+ into win32 branch.
+ Branch: win32/perl
+ + t/lib/thread.t t/op/nothread.t
+ ! MANIFEST embed.h ext/Opcode/Opcode.pm global.sym interp.sym
+ ! perl.c proto.h sv.h t/lib/english.t t/op/misc.t thread.h
+ ! util.c win32/Makefile win32/config.bc win32/config.vc
+ ! win32/config_H.bc win32/config_H.vc win32/makedef.pl
+ ! win32/makefile.mk win32/win32.c win32/win32.h win32/win32io.c
+ ! win32/win32io.h win32/win32iop.h win32/win32sck.c
+ ! win32/win32thread.c win32/win32thread.h
+____________________________________________________________________________
+[ 220] By: gsar on 1997/11/09 22:44:41
+ Log: Integrate latest mainline into win32 branch.
+ Branch: win32/perl
+ +> win32/win32thread.c win32/win32thread.h
+ !> (integrate 39 files)
+____________________________________________________________________________
+[ 219] By: nick on 1997/11/09 21:46:06
+ Log: Conditionalize english.t,
+ Enhance times() for NT,
+ (Failed) attempt to implement alarm(),
+ Fixed config.h dependancy in makefile.mk
+ Branch: ansiperl
+ ! t/lib/english.t win32/config.bc win32/config_H.bc
+ ! win32/makefile.mk win32/win32.c
+____________________________________________________________________________
+[ 218] By: nick on 1997/11/09 15:38:00
+ Log: Dick Hardt's patch for build on Alpha
+ Branch: ansiperl
+ ! win32/Makefile
+____________________________________________________________________________
+[ 217] By: nick on 1997/11/09 03:31:20
+ Log: MakeMaker not in vofig noise fix for dmake
+ Branch: ansiperl
+ ! win32/config.bc win32/makefile.mk
+____________________________________________________________________________
+[ 216] By: nick on 1997/11/09 03:15:06
+ Log: Fix 'anydbm.t' - if the gv is passed 1st call to inherited
+ TIEHASH works, but 2nd call (after db is closed, attempt
+ to reopen) tries to AUTOLOAD TIEHASH rather than using
+ cached value.
+ Branch: ansiperl
+ ! pp_sys.c
+____________________________________________________________________________
+[ 215] By: nick on 1997/11/08 16:41:24
+ Log: Cleanup MakeMaker 'not in config' noise
+ Branch: ansiperl
+ ! win32/Makefile win32/config.vc
+____________________________________________________________________________
+[ 214] By: nick on 1997/11/08 15:07:24
+ Log: Remove 'configure' leaving configure.gnu and Configure
+ Win32 ignores case and keeps trying to update
+ repository copy of 'configure' or 'Configure' with
+ the other.
+ Branch: ansiperl
+ - configure
+ ! MANIFEST
+____________________________________________________________________________
+[ 213] By: nick on 1997/11/08 15:03:39
+ Log: Get threads working again on Win32
+ Root cause of fail was init_thread_intern() in
+ new_struct_thread() (which is called in parent thread)
+ clobbering dTHR of parent thread.
+ It is doubtfull if setting 'self' in new_struct_thread()
+ is 'right' but left in for now.
+ Branch: ansiperl
+ ! ext/Thread/Thread.xs perl.c thread.h util.c win32/Makefile
+ ! win32/win32thread.c win32/win32thread.h
+____________________________________________________________________________
+[ 212] By: nick on 1997/11/08 00:34:03
+ Log: Add :base_thread to :default in Opcode.pm
+ This allows lib/safe.t to pass when threaded.
+ It is unclear if 'lock' should be safe as it allows
+ denial of service attack, but could not figure out
+ how to add just 'specific' (sic) to :default
+ without triggering 'already tagged' warning noise.
+ Branch: ansiperl
+ ! ext/Opcode/Opcode.pm win32/makefile.mk
+____________________________________________________________________________
+[ 211] By: nick on 1997/11/07 23:59:31
+ Log: Merge changes as of 18:00 CST
+ Branch: ansiperl
+ !> op.c pp.c pp_sys.c thread.h util.c
+____________________________________________________________________________
+[ 210] By: nick on 1997/11/07 23:52:35
+ Log: Reverse integrate Malcolm's chanes into local
+ repository, then import result back into my view
+ of Malcolm's repository.
+ Builds and passes (most) tests with GNU C++/Solaris
+ and Borland C++, Win32.
+ Branch: ansiperl
+ ! doop.c embed.h ext/Thread/Thread.xs global.sym gv.c hv.c
+ ! interp.sym mg.c op.c opcode.h opcode.pl patchlevel.h perl.c
+ ! perl.h pp.c pp_ctl.c pp_sys.c proto.h sv.c sv.h taint.c
+ ! thread.h toke.c util.c win32/makefile.mk
+____________________________________________________________________________
+[ 209] By: mbeattie on 1997/11/07 18:12:36
+ Log: Change pp_tie and pp_dbmopen to use perl_call_sv instead of a
+ DIY pp_entersub (in preparation for AUTOLOAD change). dbmopen
+ not tested. ofslen now maps to thr->Tofslen in thread.h. Added
+ missing #ifdef USE_THREADS around some DEBU_L statements in die().
+ Building without USE_THREADS fails quite a lot of tests. It looks
+ as though the move to per-thread magicals must be missing some
+ #ifdef USE_THREADS.
+ Branch: perl
+ ! op.c pp.c pp_sys.c thread.h util.c
+____________________________________________________________________________
+[ 208] By: nick on 1997/11/07 01:37:28
+ Log: Raw integrate of latest perl
+ Branch: ansiperl
+ ! t/TEST
+ !> README.threads Todo.5.005 embed.h ext/Opcode/Opcode.pm
+ !> ext/Thread/Thread.xs global.sym gv.c interp.sym op.c op.h
+ !> perl.c perl.h pp.c pp_ctl.c pp_hot.c proto.h scope.h sv.h
+ !> thread.h toke.c util.c
+____________________________________________________________________________
+[ 207] By: mbeattie on 1997/11/06 14:58:00
+ Log: Update README.threads and Todo.5.005.
+ Branch: perl
+ ! README.threads Todo.5.005
+____________________________________________________________________________
+[ 206] By: mbeattie on 1997/11/06 14:37:37
+ Log: Remove #ifdef DEPRECATED stuff: newXSUB, pp_entersubr, FREE_TMPS().
+ Branch: perl
+ ! op.c pp_ctl.c proto.h scope.h
+____________________________________________________________________________
+[ 205] By: mbeattie on 1997/11/06 14:31:38
+ Log: Per-thread magicals now stored in their own thr->magicals and keyed
+ more directly. cvcache and oursv become ordinary struct thread
+ fields instead of #defined thr->Tfoo ones. SvREFCNT_inc now checks
+ for 0 again. Main thread initialisation done by new function
+ init_main_thread instead of (now fixed) new_struct_thread.
+
+ Jobs fixed ...
+
+ jmpenv fixed on 1997/11/06 by mbeattie@localhost
+
+ Subject: [perl5.004_53; patch] eval's and threads
+ Date: 23 Oct 1997 23:59:19 -0400
+ From: Owen Taylor <owt1@cornell.edu>
+ Branch: bugs
+ + jmpenv
+ Branch: perl
+ ! embed.h ext/Thread/Thread.xs global.sym gv.c op.c perl.c
+ ! pp_ctl.c pp_hot.c proto.h sv.h thread.h toke.c util.c
+____________________________________________________________________________
+[ 204] By: mbeattie on 1997/11/05 17:18:18
+ Log: Per-thread magicals mostly working (and localisable). Now getting
+ intermittent occasional "Use of uninitialized value" warnings
+ which may be due to some op flag black magic I've broken.
+ Branch: perl
+ ! embed.h ext/Opcode/Opcode.pm ext/Thread/Thread.xs gv.c
+ ! interp.sym op.c op.h perl.c perl.h pp.c thread.h toke.c util.c
+____________________________________________________________________________
+[ 203] By: nick on 1997/11/05 01:04:10
+ Log: Builds C++ Borland, MSVC++ (Win32) and GCC++ (Solaris)
+ Branch: ansiperl
+ ! XSUB.h doio.c doop.c embed.h ext/SDBM_File/sdbm/sdbm.h
+ ! ext/Thread/Thread.xs global.sym gv.c hv.c interp.sym mg.c
+ ! miniperlmain.c op.c op.h opcode.h opcode.pl patchlevel.h
+ ! perl.c perl.h pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c proto.h
+ ! sv.c sv.h taint.c thread.h toke.c util.c win32/Makefile
+ ! win32/config.vc win32/config_H.vc win32/makedef.pl
+ ! win32/makefile.mk win32/perllib.c win32/win32.c win32/win32.h
+ ! win32/win32io.c win32/win32io.h win32/win32iop.h
+ ! win32/win32sck.c win32/win32thread.h
+____________________________________________________________________________
+[ 202] By: nick on 1997/11/05 00:50:27
+ Log: Compile(d) at least once with threads on win32
+ but did not work
+ Branch: ansiperl
+ ! embed.h perl.c thread.h
+____________________________________________________________________________
+[ 201] By: nick on 1997/11/05 00:32:13
+ Log: Trivial integrate
+ Branch: ansiperl
+ !> patchlevel.h
+____________________________________________________________________________
+[ 200] By: mbeattie on 1997/11/04 12:06:09
+ Log: Up patchlevel to 5.004_54 (I missed _53 for the last release).
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 199] By: nick on 1997/11/01 00:18:52
+ Log: Integrate mainline @ 18:15 CST 31 Oct 1997
+ Branch: ansiperl
+ !> doop.c embed.h ext/Thread/Thread.xs global.sym gv.c hv.c
+ !> interp.sym mg.c op.c opcode.h opcode.pl perl.c perl.h pp.c
+ !> pp_ctl.c pp_sys.c proto.h sv.c sv.h taint.c thread.h toke.c
+ !> util.c
+____________________________________________________________________________
+[ 198] By: nick on 1997/11/01 00:08:33
+ Log: win32thread.* not in MANIFEST which has muddled moving
+ back and forth between depots.
+ Branch: ansiperl
+ ! MANIFEST win32/win32thread.c win32/win32thread.h
+____________________________________________________________________________
+[ 197] By: nick on 1997/11/01 00:02:49
+ Log: Test changes
+ Branch: ansiperl
+ + t/lib/thread.t t/op/nothread.t thread.sym
+ ! MANIFEST
+____________________________________________________________________________
+[ 196] By: nick on 1997/10/31 23:54:01
+ Log: Further ANSI changes now builds and passes (most) tests
+ with gcc -x c++.
+ Branch: ansiperl
+ ! INTERN.h embed.h ext/DynaLoader/dl_dlopen.xs
+ ! ext/Fcntl/Fcntl.xs ext/GDBM_File/GDBM_File.xs ext/IO/IO.xs
+ ! ext/Opcode/Opcode.xs ext/POSIX/POSIX.xs
+ ! ext/SDBM_File/sdbm/hash.c ext/SDBM_File/sdbm/pair.c
+ ! ext/SDBM_File/sdbm/sdbm.c ext/SDBM_File/sdbm/sdbm.h
+ ! ext/SDBM_File/sdbm/util.c ext/Socket/Socket.xs
+ ! ext/Thread/Thread.xs ext/attrs/attrs.xs global.sym perl.h
+ ! perly.c sv.c t/lib/english.t t/op/misc.t thread.h util.c
+ ! win32/Makefile win32/makedef.pl win32/makefile.mk x2p/a2p.c
+ ! x2p/a2p.h x2p/a2py.c x2p/hash.c x2p/str.c x2p/util.c
+ ! x2p/walk.c
+____________________________________________________________________________
+[ 195] By: mbeattie on 1997/10/31 18:05:31
+ Log: Half way through moving per-thread magicals into per-thread fields
+ and the associated new OP_SPECIFIC and find_thread_magical stuff.
+ perl will compile but plenty of the magicals are still broken.
+ Branch: perl
+ ! doop.c embed.h ext/Thread/Thread.xs global.sym gv.c hv.c
+ ! interp.sym mg.c op.c opcode.h opcode.pl perl.c perl.h pp.c
+ ! pp_ctl.c pp_sys.c proto.h sv.c sv.h taint.c thread.h toke.c
+ ! util.c
+____________________________________________________________________________
+[ 194] By: nick on 1997/10/31 01:43:49
+ Log: Convert miniperl sources to ANSI C. Several passes of
+ GNU C's 'protoize' plus a few hand edits.
+ Will compile miniperl with gcc -x c++ (i.e. treat .c a C++ files)
+ Does not link seems gcc's C++ does not define a symbol for
+ const char foo[] = "....";
+ i.e. with empty [].
+ Branch: ansiperl
+ ! av.c deb.c doio.c doop.c dump.c gv.c hv.c malloc.c mg.c
+ ! miniperlmain.c op.c perl.c perl.h perlio.c perly.y pp.c
+ ! pp_ctl.c pp_hot.c pp_sys.c regcomp.c regexec.c run.c scope.c
+ ! sv.c taint.c toke.c universal.c util.c
+____________________________________________________________________________
+[ 193] By: nick on 1997/10/30 03:00:01
+ Log: Make the ansi branch
+ Branch: ansiperl
+ +> (branch 907 files)
+____________________________________________________________________________
+[ 192] By: nick on 1997/10/30 02:48:17
+ Log: Oneperl builds with THREADS/THISPTR Borland
+ Manualy inserted Sarathy's new COND_XXXXX from his mail.
+ Manual change if Tself -> self as was easier than resolve :-(
+ Two aTHIS's in op.c
+ Branch: oneperl
+ ! embed.h op.c thread.h thread.sym win32/makefile.mk
+ ! win32/win32thread.h
+____________________________________________________________________________
+[ 191] By: nick on 1997/10/30 01:54:50
+ Log: Raw resolve of latest sources with oneperl
+ Branch: oneperl
+ !> Todo.5.005 ext/Thread/Thread.xs fakethr.h op.c op.h opcode.h
+ !> opcode.pl perl.c thread.h win32/win32thread.c
+ !> win32/win32thread.h
+____________________________________________________________________________
+[ 190] By: mbeattie on 1997/10/29 14:39:54
+ Log: Remove global macro "self". Change thr->Tself to thr->self.
+ Branch: perl
+ ! ext/Thread/Thread.xs fakethr.h perl.c thread.h
+ ! win32/win32thread.c win32/win32thread.h
+____________________________________________________________________________
+[ 189] By: mbeattie on 1997/10/29 12:49:01
+ Log: Add to Todo: compiler with fake SvCUR in comppad_name entries.
+ Branch: perl
+ ! Todo.5.005
+____________________________________________________________________________
+[ 188] By: mbeattie on 1997/10/29 12:45:32
+ Log: Add pp_lock knowledge to compiler
+ Branch: perlext
+ ! Compiler/ccop.c Compiler/ccop.h
+____________________________________________________________________________
+[ 187] By: mbeattie on 1997/10/29 12:45:02
+ Log: Change peep() to optimise away unneeded rv2av in lval->[] and lval->{}
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 186] By: mbeattie on 1997/10/29 12:43:36
+ Log: Move compiler OP class information into opcode.pl.
+ Branch: perl
+ ! op.h opcode.h opcode.pl
+____________________________________________________________________________
+[ 185] By: nick on 1997/10/26 22:52:05
+ Log: Split failing test in op/misc.t into op/nothread.t
+ so all tests can be passed where they apply.
+ Cleanup other two cases of THREADS/THISPTR.
+ Conditional compile option for CriticalSection's on Win32
+ Branch: oneperl
+ + t/op/nothread.t
+ ! sv.h t/op/misc.t win32/Makefile win32/makedef.pl
+ ! win32/win32thread.h
+____________________________________________________________________________
+[ 184] By: nick on 1997/10/26 19:42:00
+ Log: USE_THISPTR fixes for CRIPPLED_CC (implied by threads)
+ Branch: oneperl
+ ! embed.h global.sym proto.h sv.c sv.h toke.c
+____________________________________________________________________________
+[ 183] By: nick on 1997/10/26 18:31:58
+ Log: Make USE_THREADS imply CRIPPLED_CC.
+ This avoids most of the uses of 'Sv' and hence many needs of
+ dTHR in extension code.
+ With this change Data::Dumper builds as-is
+ and Tk only needs four tweaks:
+ 1. Obscure dump-stack case which really needs dTHR
+ 2. A curcop in error-message code
+ 3. Two cases of SAVETMPS
+ 4. A curcop == &compiling which is probably not required.
+ IMHO the SAVETMPS case is only one which merits further automation.
+ Branch: oneperl
+ ! embed.h global.sym perl.h sv.c win32/Makefile win32/makedef.pl
+____________________________________________________________________________
+[ 182] By: nick on 1997/10/26 16:31:58
+ Log: Change dSP to imply dTHR for extension source compatibility
+ introduce djSP (Declare Just SP) for use in perl sources
+ and thread-aware extensions. Use latter.
+ Branch: oneperl
+ ! XSUB.h doio.c doop.c ext/Thread/Thread.xs gv.c mg.c perl.c
+ ! pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c sv.c
+____________________________________________________________________________
+[ 181] By: nick on 1997/10/26 00:39:57
+ Log: More tests
+ Branch: oneperl
+ ! t/lib/thread.t
+____________________________________________________________________________
+[ 180] By: nick on 1997/10/25 22:18:27
+ Log: Use return of THREAD_CREATE() - add basic thread test
+ Branch: oneperl
+ + t/lib/thread.t
+ ! ext/Thread/Thread.xs
+____________________________________________________________________________
+[ 179] By: nick on 1997/10/25 21:25:23
+ Log: Builds with no thread/this
+ Branch: oneperl
+ ! ext/Thread/Thread.xs t/lib/english.t win32/makedef.pl
+ ! win32/win32thread.c
+____________________________________________________________________________
+[ 178] By: nick on 1997/10/25 18:28:03
+ Log: Cleanup dead #ifdef branch introduced by scruffy merging.
+ Branch: oneperl
+ ! perl.c
+____________________________________________________________________________
+[ 177] By: nick on 1997/10/25 18:11:33
+ Log: Basic integrate of oneperl with threads, passes
+ tests THISPTR+THREADs - win32/win32thread.* needed
+ changes (where did they come from)?
+ Branch: oneperl
+ ! embed.h ext/Thread/Thread.xs perl.h thread.h win32/Makefile
+ ! win32/makedef.pl win32/win32thread.c win32/win32thread.h
+____________________________________________________________________________
+[ 176] By: nick on 1997/10/25 17:05:52
+ Log: Onepel builds THISPTR no threads
+ Branch: oneperl
+ ! ext/Thread/Thread.xs thread.h win32/makedef.pl
+____________________________________________________________________________
+[ 175] By: nick on 1997/10/25 16:40:10
+ Log: Integrate oneperl with new style JOIN etc. macros
+ Branch: oneperl
+ +> win32/win32thread.c win32/win32thread.h
+ !> Todo.5.005 ext/POSIX/POSIX.xs ext/Thread/Thread.xs fakethr.h
+ !> global.sym gv.c hv.c mg.c op.c opcode.h opcode.pl perl.c
+ !> perl.h pp.c pp_hot.c sv.h thread.h vms/descrip.mms
+ !> vms/gen_shrfls.pl vms/vms.c vms/vmsish.h win32/Makefile
+ !> win32/makefile.mk
+____________________________________________________________________________
+[ 174] By: mbeattie on 1997/10/24 17:14:00
+ Log: Remove xcv_condp CV field which is no longer used.
+ Branch: perl
+ ! sv.h
+____________________________________________________________________________
+[ 173] By: mbeattie on 1997/10/24 14:36:09
+ Log: Patches for VMS [Dan Sugalski]
+ Branch: bugs
+ + vms2
+ Branch: perl
+ ! ext/POSIX/POSIX.xs vms/descrip.mms vms/gen_shrfls.pl vms/vms.c
+ ! vms/vmsish.h
+____________________________________________________________________________
+[ 172] By: mbeattie on 1997/10/24 13:50:59
+ Log: Improve internal threading API. Introduce win32/win32thread.[ch]
+ to use new API and patch win32 makefile stuff a little.
+ Branch: perl
+ + win32/win32thread.c win32/win32thread.h
+ ! Todo.5.005 ext/Thread/Thread.xs fakethr.h global.sym gv.c hv.c
+ ! perl.c perl.h thread.h win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 171] By: mbeattie on 1997/10/23 14:00:27
+ Log: Fix pp_hot.c:get_db_sub core dump when perl debugger used.
+
+ Jobs fixed ...
+
+ get_db_sub fixed on 1997/10/23 by mbeattie@squash
+
+ Subject: [perl5.004_53] Debugger crash (patch)
+ Date: Thu, 16 Oct 1997 22:03:09 -0400
+ From: Owen Taylor <owt1@cornell.edu>
+ Branch: bugs
+ + get_db_sub
+ Branch: perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 170] By: mbeattie on 1997/10/23 09:22:40
+ Log: Fix refcounts for lock/magic_mutexfree. Make OP_LOCK auto-ref
+ its argument using ck_rfun as OP_DEFINED. Make pp_lock return
+ a ref to its argument for AV, HV, CV.
+ Branch: perl
+ ! mg.c op.c opcode.h opcode.pl pp.c pp_hot.c
+____________________________________________________________________________
+[ 169] By: gsar on 1997/10/21 03:49:25
+ Log: With these fixes, oneperl builds THISPTR && THREADS under both win32 compilers:
+ - Fixup static functions that were missing aTHIS.
+ - s/extern/EXT/ in dTHR macro, or Borland CC croaks.
+ - Removed static functions from global.sym.
+ - Typo in perl.h.
+ - Additions to makefile.mk.
+ Branch: oneperl
+ ! embed.h embed.pl global.sym op.c perl.h pp_ctl.c toke.c
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 168] By: nick on 1997/10/20 02:47:18
+ Log: Passes expected tests with -DUSE_THREADS with/without -DUSE_THISPTR
+ Branch: oneperl
+ ! embed.h ext/Thread/Thread.xs mg.c pp.c pp_hot.c proto.h
+ ! scope.h thread.h
+____________________________________________________________________________
+[ 167] By: nick on 1997/10/20 01:03:00
+ Log: Add missing aTHIS in cast
+ Branch: oneperl
+ ! win32/dl_win32.xs
+____________________________________________________________________________
+[ 166] By: nick on 1997/10/20 00:44:42
+ Log: Builds and passes test with -DUSE_THISPTR
+ Branch: oneperl
+ ! ext/Thread/Thread.xs win32/Makefile win32/makedef.pl
+ ! win32/perllib.c
+____________________________________________________________________________
+[ 165] By: nick on 1997/10/19 21:45:36
+ Log: Oneperl runs miniperl with THISPTR (Win32 threading patch included)
+ Branch: oneperl
+ ! embed.h ext/Thread/Thread.xs global.sym interp.sym perl.c
+ ! perl.h t/TEST thread.h win32/Makefile win32/makedef.pl
+ ! win32/makefile.mk win32/perllib.c
+____________________________________________________________________________
+[ 164] By: nick on 1997/10/19 20:09:13
+ Log: oneperl compiles (but fails) with -DUSE_THISPTR
+ Branch: oneperl
+ ! av.c embed.h mg.c perl.c perl.h pp.c pp_ctl.c pp_hot.c
+ ! pp_sys.c proto.h regexec.c sv.c thread.h thread.sym util.c
+ ! win32/win32.c win32/win32.h
+____________________________________________________________________________
+[ 163] By: nick on 1997/10/19 16:46:09
+ Log: Builds on NT4 without THISPTR or THREADS, passes all tests
+ Branch: oneperl
+ ! embed.h perl.h thread.h vars.h
+____________________________________________________________________________
+[ 162] By: nick on 1997/10/19 14:42:16
+ Log: Dubious merge of oneperl's variable and struct thread
+ Branch: oneperl
+ !> perl.h thread.h
+____________________________________________________________________________
+[ 161] By: nick on 1997/10/18 18:05:13
+ Log: integrate all but perl.h/thread.h
+ Branch: oneperl
+ +> Todo.5.005 perlio.sym
+ !> (integrate 98 files)
+____________________________________________________________________________
+[ 160] By: nick on 1997/10/18 03:49:27
+ Log: Integrate rest of sub-dirs into oneperl
+ Branch: oneperl
+ +> ext/Thread/Makefile.PL ext/Thread/Notes ext/Thread/README
+ +> ext/Thread/Thread.pm ext/Thread/Thread.xs
+ +> ext/Thread/Thread/Queue.pm ext/Thread/Thread/Semaphore.pm
+ +> ext/Thread/create.t ext/Thread/io.t ext/Thread/join.t
+ +> ext/Thread/join2.t ext/Thread/list.t ext/Thread/lock.t
+ +> ext/Thread/queue.t ext/Thread/sync.t ext/Thread/sync2.t
+ +> ext/Thread/typemap ext/Thread/unsync.t ext/Thread/unsync2.t
+ +> ext/Thread/unsync3.t ext/Thread/unsync4.t hints/newsos4.sh
+ +> hints/os390.sh
+ - ext/util/extliblist
+ !> (integrate 425 files)
+____________________________________________________________________________
+[ 159] By: nick on 1997/10/18 03:20:11
+ Log: Integrate (accept) t and win32 into oneperl
+ Branch: oneperl
+ +> t/lib/dosglob.t win32/bin/pl2bat.pl win32/bin/runperl.pl
+ +> win32/bin/search.pl win32/bin/webget.pl win32/config.bc
+ +> win32/config.vc win32/config_H.bc win32/config_H.vc
+ +> win32/makefile.mk
+ !> (integrate 188 files)
+____________________________________________________________________________
+[ 158] By: nick on 1997/10/18 03:12:59
+ Log: Integrate lib/... into oneperl
+ Branch: oneperl
+ +> lib/File/DosGlob.pm lib/base.pm lib/chat2.pl
+ !> (integrate 138 files)
+____________________________________________________________________________
+[ 157] By: nick on 1997/10/18 02:55:53
+ Log: Make lib/Bundle/CPAN.pm text in oneperl too.
+ Branch: oneperl
+ ! lib/Bundle/CPAN.pm
+____________________________________________________________________________
+[ 156] By: nick on 1997/10/18 02:52:44
+ Log: Make lib/Bundle/CPAN.pm a text file
+ Branch: perl
+ ! lib/Bundle/CPAN.pm
+____________________________________________________________________________
+[ 155] By: nick on 1997/10/18 02:33:02
+ Log: Some weirdness in the intgrate process
+ Branch: oneperl
+ - win32/bin/pl2bat.bat win32/bin/search.bat win32/bin/test.bat
+ - win32/bin/webget.bat win32/config.H win32/config.w32
+____________________________________________________________________________
+[ 153] By: nick on 1997/10/18 02:29:16
+ Log: Let us try all the pure integrate stuff
+ Branch: oneperl
+ !> (integrate 647 files)
+____________________________________________________________________________
+[ 152] By: nick on 1997/10/18 02:13:35
+ Log: Get more sub directories out of the way.
+ Branch: oneperl
+ !> (integrate 92 files)
+____________________________________________________________________________
+[ 151] By: nick on 1997/10/18 02:05:41
+ Log: Integrate hints
+ Branch: oneperl
+ !> (integrate 68 files)
+____________________________________________________________________________
+[ 150] By: nick on 1997/10/18 01:57:20
+ Log: Try reopening some non-contravertial files
+ Branch: oneperl
+ !> x2p/EXTERN.h x2p/INTERN.h x2p/Makefile.SH x2p/a2p.c x2p/a2p.h
+ !> x2p/a2p.pod x2p/a2p.y x2p/a2py.c x2p/cflags.SH
+ !> x2p/find2perl.PL x2p/hash.c x2p/hash.h x2p/proto.h x2p/s2p.PL
+ !> x2p/str.c x2p/str.h x2p/util.c x2p/util.h x2p/walk.c
+____________________________________________________________________________
+[ 144] By: gsar on 1997/10/16 22:26:07
+ Log: Merge changes to Thread and add makefile fixups to accomodate Thread
+ build. Once again, builds and runs all Thread tests using either
+ compiler.
+ Branch: win32/perl
+ ! embed.h ext/Thread/Thread.xs interp.sym perl.c win32/Makefile
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 143] By: gsar on 1997/10/16 20:45:58
+ Log: A quick merge of latest mainline.
+ Branch: win32/perl
+ +> ext/Thread/Makefile.PL ext/Thread/Notes ext/Thread/README
+ +> ext/Thread/Thread.pm ext/Thread/Thread.xs
+ +> ext/Thread/Thread/Queue.pm ext/Thread/Thread/Semaphore.pm
+ +> ext/Thread/create.t ext/Thread/io.t ext/Thread/join.t
+ +> ext/Thread/join2.t ext/Thread/list.t ext/Thread/lock.t
+ +> ext/Thread/queue.t ext/Thread/sync.t ext/Thread/sync2.t
+ +> ext/Thread/typemap ext/Thread/unsync.t ext/Thread/unsync2.t
+ +> ext/Thread/unsync3.t ext/Thread/unsync4.t hints/os390.sh
+ +> lib/base.pm t/lib/dosglob.t
+ - ext/util/extliblist
+ !> (integrate 134 files)
+
+----------------
+Version 5.004_53
+----------------
+
+____________________________________________________________________________
+[ 142] By: mbeattie on 1997/10/16 16:52:55
+ Log: Add newly moved perl/ext/Thread/... files to MANIFEST.
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 141] By: mbeattie on 1997/10/16 16:42:13
+ Log: Move perlext/Thread into perl/ext/Thread.
+ Branch: perl
+ +> ext/Thread/Makefile.PL ext/Thread/Notes ext/Thread/README
+ +> ext/Thread/Thread.pm ext/Thread/Thread.xs
+ +> ext/Thread/Thread/Queue.pm ext/Thread/Thread/Semaphore.pm
+ +> ext/Thread/create.t ext/Thread/io.t ext/Thread/join.t
+ +> ext/Thread/join2.t ext/Thread/list.t ext/Thread/lock.t
+ +> ext/Thread/queue.t ext/Thread/sync.t ext/Thread/sync2.t
+ +> ext/Thread/typemap ext/Thread/unsync.t ext/Thread/unsync2.t
+ +> ext/Thread/unsync3.t ext/Thread/unsync4.t
+ ! Configure
+ Branch: perlext
+ - Thread/Makefile.PL Thread/Notes Thread/README Thread/Thread.pm
+ - Thread/Thread.xs Thread/Thread/Queue.pm
+ - Thread/Thread/Semaphore.pm Thread/create.t Thread/io.t
+ - Thread/join.t Thread/join2.t Thread/list.t Thread/lock.t
+ - Thread/queue.t Thread/sync.t Thread/sync2.t Thread/typemap
+ - Thread/unsync.t Thread/unsync2.t Thread/unsync3.t
+ - Thread/unsync4.t
+____________________________________________________________________________
+[ 140] By: mbeattie on 1997/10/16 16:26:53
+ Log: Correct threads_mutex locking in main thread destruction.
+ Add per-interp thrsv to hold SV struct thread for main thread.
+ Move Thread.xs MUTEX_DESTROY from end of threadstart to remove_thread.
+ Add Thread/list.t test of Thread->list method.
+ Let Thread::Semaphore methods up and down take an extra argument.
+ Branch: perl
+ ! embed.h interp.sym perl.c perl.h thread.h
+ Branch: perlext
+ + Thread/list.t
+ ! Thread/Thread.xs Thread/Thread/Semaphore.pm
+____________________________________________________________________________
+[ 139] By: mbeattie on 1997/10/16 14:01:11
+ Log: Fix up merge with 5.004_04.
+ Branch: perl
+ ! op.c perl.c t/lib/dosglob.t
+____________________________________________________________________________
+[ 138] By: TimBunce on 1997/10/16 12:58:22
+ Log: Fix-up PerForce type for t/lib/dosglob.t from text to xtext
+ Branch: maint-5.004/perl
+ ! t/lib/dosglob.t
+____________________________________________________________________________
+[ 137] By: mbeattie on 1997/10/16 11:09:25
+ Log: Merge maint-5.004 branch (5.004_04) with mainline.
+ Branch: perl
+ +> hints/os390.sh lib/base.pm t/lib/dosglob.t
+ - ext/util/extliblist
+ !> (integrate 132 files)
+____________________________________________________________________________
+[ 135] By: gsar on 1997/10/15 21:46:05
+ Log: Win32 changes over 5.004_52:
+ - rearranged MUTEX_LOCK()s in perl_destroy so that we don't call it
+ on an already locked mutex.
+ - other minor tweaks.
+ Now builds and runs win32-version of Thread_52, passing all tests.
+ Branch: win32/perl
+ ! perl.c proto.h thread.h
+____________________________________________________________________________
+[ 134] By: gsar on 1997/10/15 18:19:31
+ Log: fixup makefile.mk conflict.
+ Branch: win32/perl
+ ! win32/makefile.mk
+____________________________________________________________________________
+[ 133] By: gsar on 1997/10/15 18:02:46
+ Log: Integrated latest changes from mainline into win32.
+ Branch: win32/perl
+ +> fakethr.h
+ !> MANIFEST Porting/makerel Porting/patchls README.threads
+ !> Todo.5.005 perl.c pp_hot.c thread.h util.c win32/config.bc
+ !> win32/config.vc win32/config_H.bc win32/config_H.vc
+ !> win32/makefile.mk
+
+----------------
+Version 5.004_52
+----------------
+
+____________________________________________________________________________
+[ 132] By: mbeattie on 1997/10/15 17:02:38
+ Log: Remove out-of-date test Thread/cond.t.
+ Branch: perlext
+ - Thread/cond.t
+____________________________________________________________________________
+[ 131] By: mbeattie on 1997/10/15 16:57:45
+ Log: Finish thread state machine: fixes global destruction of threads,
+ detaching, joining etc. Alter FAKE_THREADS-specific fields to use
+ new HAVE_THREAD_INTERN stuff. Updates docs. Various fixes to
+ Thread.xs.
+ Branch: perl
+ ! MANIFEST README.threads Todo.5.005 perl.c util.c
+ Branch: perlext
+ ! Thread/Thread.xs Thread/queue.t
+____________________________________________________________________________
+[ 130] By: mbeattie on 1997/10/15 16:55:10
+ Log: Add HAVE_THREAD_INTERN for platform-dependent struct thread additions.
+ Fix ThrSETSTATE not to lock t->mutex itself.
+ Branch: perl
+ ! fakethr.h thread.h
+____________________________________________________________________________
+[ 129] By: mbeattie on 1997/10/15 16:53:35
+ Log: Remove stale code from pp_entersub which breaks sub ownership locks.
+ Branch: perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 128] By: TimBunce on 1997/10/15 15:55:26
+ Log: Maintenance 5.004_04 changes
+ Branch: maint-5.004/perl
+ + hints/os390.sh lib/base.pm t/lib/dosglob.t
+ - ext/util/extliblist
+ ! Changes Configure INSTALL MANIFEST Makefile.SH Porting/makerel
+ ! Porting/patchls Porting/pumpkin.pod README.vms av.c configpm
+ ! doop.c eg/sysvipc/ipcsem emacs/cperl-mode.el embed.h
+ ! ext/DynaLoader/DynaLoader.pm ext/IO/lib/IO/Socket.pm
+ ! ext/util/make_ext global.sym gv.c hints/bsdos.sh
+ ! hints/dec_osf.sh hints/dynixptx.sh hints/irix_6.sh
+ ! hints/linux.sh hints/machten.sh hints/os2.sh hints/qnx.sh hv.c
+ ! installperl lib/AutoLoader.pm lib/CPAN.pm
+ ! lib/CPAN/FirstTime.pm lib/Carp.pm lib/Cwd.pm lib/English.pm
+ ! lib/ExtUtils/Install.pm lib/ExtUtils/Liblist.pm
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/xsubpp
+ ! lib/File/DosGlob.pm lib/File/Find.pm lib/FileHandle.pm
+ ! lib/Getopt/Long.pm lib/Getopt/Std.pm lib/Math/Complex.pm
+ ! lib/Sys/Hostname.pm lib/Sys/Syslog.pm lib/Test/Harness.pm
+ ! lib/Time/Local.pm lib/autouse.pm lib/blib.pm
+ ! lib/diagnostics.pm lib/getopt.pl lib/perl5db.pl lib/vars.pm
+ ! makedepend.SH malloc.c mg.c miniperlmain.c myconfig op.c
+ ! opcode.h os2/Changes os2/OS2/REXX/Makefile.PL
+ ! os2/OS2/REXX/REXX.pm os2/os2.c patchlevel.h perl.c perl.h
+ ! perly.c perly.fixer perly.y pod/perl.pod pod/perlapio.pod
+ ! pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod
+ ! pod/perlguts.pod pod/perlipc.pod pod/perlop.pod
+ ! pod/perlrun.pod pod/perlsec.pod pod/perlsub.pod
+ ! pod/perltrap.pod pod/perlvar.pod pod/perlxs.pod pp.c pp_ctl.c
+ ! pp_hot.c pp_sys.c proto.h regcomp.c regexec.c scope.c sv.c
+ ! t/TEST t/comp/proto.t t/lib/complex.t t/lib/io_sock.t
+ ! t/lib/io_udp.t t/op/glob.t t/op/method.t t/op/misc.t
+ ! t/op/ref.t t/op/runlevel.t t/op/split.t t/op/sprintf.t
+ ! t/op/subst.t t/op/taint.t t/pragma/locale.t taint.c toke.c
+ ! unixish.h util.c utils/h2ph.PL utils/h2xs.PL utils/perlbug.PL
+ ! utils/perldoc.PL vms/perly_c.vms vms/vms.c vms/vmsish.h
+ ! win32/Makefile win32/config_H.bc win32/config_H.vc
+ ! win32/makefile.mk win32/pod.mak win32/win32.c win32/win32io.c
+ ! win32/win32sck.c x2p/Makefile.SH x2p/util.c
+____________________________________________________________________________
+[ 127] By: mbeattie on 1997/10/15 10:00:18
+ Log: Added fakethr.h.
+ Branch: perl
+ + fakethr.h
+____________________________________________________________________________
+[ 126] By: mbeattie on 1997/10/15 09:50:57
+ Log: pthread_condattr_init in thread.h for OLD_PTHREADS_API.
+ Branch: perl
+ ! thread.h
+____________________________________________________________________________
+[ 125] By: mbeattie on 1997/10/15 09:09:24
+ Log: Started rewriting thread state machine.
+ Branch: perl
+ ! perl.c thread.h
+ Branch: perlext
+ ! Thread/Thread.xs
+____________________________________________________________________________
+[ 124] By: gsar on 1997/10/14 00:23:15
+ Log: Remove spurious extra MUTEX_LOCK in pp_entersub(). Now builds and passes
+ tests in win32 version of latest perlext/Thread.
+ Branch: win32/perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 123] By: gsar on 1997/10/13 23:18:38
+ Log: Initial merge of win32 threads patch.
+ Branch: win32/perl
+ ! embed.h global.sym interp.sym perl.c perl.h pp_hot.c thread.h
+ ! win32/Makefile win32/makedef.pl win32/makefile.mk
+ ! win32/perllib.c win32/pod.mak win32/win32.h
+____________________________________________________________________________
+[ 122] By: gsar on 1997/10/10 20:58:40
+ Log: Integrated changes on mainline into the win32 branch. Had to set
+ P4USER=mbeattie for the resolve step (due to the presence of newly
+ branched files that had not been submitted?)
+ Branch: win32/perl
+ +> Porting/makerel Porting/patchls README.threads Todo.5.005
+ +> ext/attrs/Makefile.PL ext/attrs/attrs.pm ext/attrs/attrs.xs
+ +> hints/newsos4.sh lib/File/DosGlob.pm lib/chat2.pl perlio.sym
+ +> win32/bin/pl2bat.pl win32/bin/runperl.pl win32/bin/search.pl
+ +> win32/bin/webget.pl win32/config.bc win32/config.vc
+ +> win32/config_H.bc win32/config_H.vc win32/makefile.mk
+ - win32/bin/pl2bat.bat win32/bin/search.bat win32/bin/test.bat
+ - win32/bin/webget.bat win32/config.H win32/config.w32
+ ! thread.h
+ !> (integrate 858 files)
+____________________________________________________________________________
+[ 121] By: mbeattie on 1997/10/10 17:23:41
+ Log: Tweak a few Thread tests.
+ Branch: perlext
+ + Thread/join2.t
+ ! Thread/io.t Thread/sync2.t
+____________________________________________________________________________
+[ 120] By: mbeattie on 1997/10/10 17:22:46
+ Log: Rewrite thread destruction system using linked list of threads.
+ Still not completely done. Add methods self, equal, flags, list
+ to Thread.xs. Add Thread_MAGIC_SIGNATURE check to typemap.
+ Branch: perl
+ ! perl.c perl.h thread.h
+ Branch: perlext
+ ! Thread/Thread.xs Thread/typemap
+____________________________________________________________________________
+[ 119] By: mbeattie on 1997/10/10 17:19:55
+ Log: Fix up locking/synchronisation for pp_entersub.
+ Branch: perl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 118] By: mbeattie on 1997/10/10 09:55:32
+ Log: Put back entries in MANIFEST for the four now-returned win32/* files
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 117] By: mbeattie on 1997/10/10 08:12:23
+ Log: Took out mystack_foo for good, fixed up interp.sym and win32/makedef.pl
+ Branch: perl
+ ! Todo.5.005 embed.h interp.sym perl.h win32/makedef.pl
+____________________________________________________________________________
+[ 116] By: mbeattie on 1997/10/08 15:41:08
+ Log: Add missing sig_pipe definition to Thread.xs.
+ Branch: perlext
+ ! Thread/Thread.xs
+____________________________________________________________________________
+[ 115] By: mbeattie on 1997/10/08 15:40:46
+ Log: Fix up 5.004_03 merge: remove missing win32 files from MANIFEST,
+ add missing dTHR; to new function unwind_handler_stack() in mg.c
+ and bump patchlevel.h to 5.004_52.
+ Branch: perl
+ ! MANIFEST mg.c patchlevel.h
+____________________________________________________________________________
+[ 114] By: mbeattie on 1997/10/08 10:19:27
+ Log: Merge maint-5.004 branch (5.004_03) with mainline.
+ MANIFEST is out of sync.
+ Branch: perl
+ +> win32/bin/pl2bat.pl win32/bin/runperl.pl win32/bin/search.pl
+ +> win32/bin/webget.pl
+ - win32/bin/pl2bat.bat win32/bin/search.bat win32/bin/test.bat
+ - win32/bin/webget.bat
+ !> (integrate 168 files)
+____________________________________________________________________________
+[ 113] By: mbeattie on 1997/10/05 17:52:49
+ Log: Move init of global mutexes/cond vars earlier.
+ Branch: perl
+ ! perl.c
+____________________________________________________________________________
+[ 112] By: nick on 1997/10/04 15:25:28
+ Log: Add perl.sym to MANIFEST
+ Branch: oneperl
+ ! MANIFEST
+____________________________________________________________________________
+[ 111] By: nick on 1997/10/04 15:23:37
+ Log: Missing file
+ Branch: oneperl
+ + perl.sym
+____________________________________________________________________________
+[ 110] By: nick on 1997/10/04 13:04:26
+ Log: Now builds the extensions as well
+ Passes all tests
+ Branch: oneperl
+ ! XSUB.h embed.pl ext/DynaLoader/dlutils.c ext/Opcode/Opcode.xs
+ ! mg.c op.c perl.c pp_ctl.c pp_hot.c pp_sys.c proto.h sv.c
+ ! toke.c util.c writemain.SH
+____________________________________________________________________________
+[ 109] By: nick on 1997/10/04 12:02:14
+ Log: Odd checkin issue
+ Branch: oneperl
+ ! dump.c global.sym gv.c hv.c malloc.c mg.c op.c opcode.h perl.c
+ ! perly.c perly.c.diff perly.h perly.y pp.c pp_hot.c pp_sys.c
+ ! proto.h scope.c sv.c toke.c universal.c util.c vms/perly_c.vms
+ ! vms/perly_h.vms writemain.SH
+____________________________________________________________________________
+[ 108] By: nick on 1997/10/04 11:12:52
+ Log: Added lots of (missing) prototypes (ckprotos is util to check)
+ Fixed missing aTHIS flagged by above.
+ -DUSE_THISPTR passes minitest!
+ Branch: oneperl
+ + ckprotos
+ ! dump.c global.sym gv.c hv.c malloc.c mg.c op.c opcode.h perl.c
+ ! perly.c perly.c.diff perly.h perly.y pp.c pp_hot.c pp_sys.c
+ ! proto.h scope.c sv.c toke.c universal.c util.c vms/perly_c.vms
+ ! vms/perly_h.vms
+____________________________________________________________________________
+[ 107] By: nick on 1997/10/03 22:36:52
+ Log: .y muddle fixup - will get this sorted oneday ...
+ Branch: oneperl
+ ! miniperlmain.c perly.c perly.c.diff perly.h vms/perly_c.vms
+ ! vms/perly_h.vms
+____________________________________________________________________________
+[ 106] By: mbeattie on 1997/10/03 17:12:33
+ Log: Remove last traces of "tokenbuf as temp buffer" and removed it
+ from struct thread. Added missing thr->Tfoo defines for statbuf
+ and timesbuf and removed unused Tbuf field.
+ Branch: perl
+ ! doio.c mg.c perl.c pp_sys.c sv.c thread.h
+____________________________________________________________________________
+[ 105] By: nick on 1997/10/03 15:56:50
+ Log: dTHIS -> hasTHIS, dTHR -> dTHR; builds without THISPTR with/without USE_THREADS
+ Branch: oneperl
+ ! XSUB.h av.c deb.c doio.c doop.c dump.c embed.pl global.sym
+ ! gv.c hv.c mg.c op.c perl.c perl.h perlio.c perly.c pp.c pp.h
+ ! pp_ctl.c pp_hot.c pp_sys.c regcomp.c regexec.c run.c scope.c
+ ! sv.c taint.c thread.h toke.c universal.c util.c
+____________________________________________________________________________
+[ 104] By: mbeattie on 1997/10/03 15:23:25
+ Log: Back out sv_bless3 change which made pp_bless zap '~'-magic.
+ Branch: perl
+ ! global.sym pp.c proto.h sv.c
+____________________________________________________________________________
+[ 103] By: mbeattie on 1997/10/03 15:17:39
+ Log: Fixed sv_mutex locking for new_SV, del_SV and nice_chunks.
+ Branch: perl
+ ! av.c hv.c perl.h sv.c
+____________________________________________________________________________
+[ 102] By: mbeattie on 1997/10/03 11:53:51
+ Log: Reliable thread signal handling.
+ Branch: perl
+ ! global.sym mg.c perl.c perl.h
+ Branch: perlext
+ ! Thread/Thread.xs
+____________________________________________________________________________
+[ 101] By: nick on 1997/10/02 20:43:17
+ Log: Cleanup perly.y stuff
+ Branch: oneperl
+ ! embed.h perly.c perly.c.diff vms/perly_c.vms vms/perly_h.vms
+____________________________________________________________________________
+[ 100] By: nick on 1997/10/02 18:54:08
+ Log: Compiles with less invasive aTHIS adding
+ Branch: oneperl
+ + nothis.sym
+ ! MANIFEST XSUB.h av.c cop.h deb.c doio.c doop.c dump.c embed.h
+ ! embed.pl global.sym gv.c gv.h handy.h hv.c hv.h mg.c op.c op.h
+ ! opcode.h perl.c perl.h perlio.c perlsdio.h perly.c
+ ! perly.c.diff perly.y pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c
+ ! proto.h regcomp.c regcomp.h regexec.c run.c scope.c scope.h
+ ! sv.c sv.h t/op/sort.t taint.c thread.h toke.c universal.c
+ ! util.c vars.h
+
+----------------
+Version 5.004_51
+----------------
+
+____________________________________________________________________________
+[ 99] By: mbeattie on 1997/10/02 17:23:48
+ Log: Added Thread/queue.t.
+ Branch: perlext
+ + Thread/queue.t
+____________________________________________________________________________
+[ 98] By: mbeattie on 1997/10/02 17:19:44
+ Log: Bumped patchlevel to 51. Updated Todo.5.005.
+ Branch: perl
+ ! Todo.5.005 patchlevel.h
+____________________________________________________________________________
+[ 97] By: mbeattie on 1997/10/02 17:07:47
+ Log: Update README.threads amd Thread/README
+ Branch: perl
+ ! README.threads
+ Branch: perlext
+ ! Thread/README
+____________________________________________________________________________
+[ 96] By: mbeattie on 1997/10/02 16:58:47
+ Log: Configure -Dusethreads hints for dec_osf and solaris_2 and
+ fix sv_bless3 prototype.
+ Branch: perl
+ ! hints/dec_osf.sh hints/solaris_2.sh sv.c
+____________________________________________________________________________
+[ 95] By: mbeattie on 1997/10/02 16:50:21
+ Log: Fixed broken typemap for Thread.
+ Branch: perlext
+ ! Thread/typemap
+____________________________________________________________________________
+[ 94] By: mbeattie on 1997/10/02 16:34:03
+ Log: Fix pod text in Lint.pm for private-names option.
+ Branch: perlext
+ ! Compiler/B/Lint.pm
+____________________________________________________________________________
+[ 93] By: mbeattie on 1997/10/02 13:44:46
+ Log: Add Todo.5.005 to MANIFEST and submit remade embed.h.
+ Branch: perl
+ ! MANIFEST embed.h
+____________________________________________________________________________
+[ 92] By: mbeattie on 1997/10/02 13:27:10
+ Log: Add Todo.5.005
+ Branch: perl
+ + Todo.5.005
+____________________________________________________________________________
+[ 91] By: nick on 1997/10/01 20:23:38
+ Log: Raw _T# trial
+ Branch: oneperl
+ ! embed.h embed.pl proto.h sv.c
+____________________________________________________________________________
+[ 90] By: nick on 1997/10/01 18:22:03
+ Log: THIS + new sort stuff
+ Branch: oneperl
+ ! miniperlmain.c perl.c pp_ctl.c proto.h util.c
+____________________________________________________________________________
+[ 89] By: nick on 1997/10/01 18:03:05
+ Log: qsort cleanup - now tailored to perl's use and 'this' aware.
+ Branch: oneperl
+ ! pp_ctl.c proto.h util.c
+____________________________________________________________________________
+[ 88] By: mbeattie on 1997/10/01 17:04:12
+ Log: Start of Configure support for -Dusethreads plus associated
+ Linux hints.
+ Branch: perl
+ ! Configure hints/linux.sh
+____________________________________________________________________________
+[ 87] By: mbeattie on 1997/10/01 17:03:34
+ Log: Move runops_foo prototypes from proto.h to early in perl.h.
+ Branch: perl
+ ! perl.h proto.h
+____________________________________________________________________________
+[ 86] By: nick on 1997/09/30 19:15:21
+ Log: Debug hackery to thread.h - temporary
+ Quick-fix qsort() replacement - more to come.
+ Branch: oneperl
+ ! thread.h util.c
+____________________________________________________________________________
+[ 85] By: mbeattie on 1997/09/30 15:50:27
+ Log: Added Lint option regexp-variables.
+ Branch: perlext
+ ! Compiler/B/Lint.pm
+____________________________________________________________________________
+[ 84] By: mbeattie on 1997/09/30 15:11:07
+ Log: Merge maint-5.004 branch (5.004_01) with mainline.
+ Branch: perl
+ +> Porting/makerel Porting/patchls hints/newsos4.sh
+ +> lib/File/DosGlob.pm lib/chat2.pl perlio.sym win32/config.bc
+ +> win32/config.vc win32/config_H.bc win32/config_H.vc
+ +> win32/makefile.mk
+ - win32/config.H win32/config.w32
+ !> (integrate 109 files)
+____________________________________________________________________________
+[ 83] By: TimBunce on 1997/09/30 14:27:09
+ Log: Maintenance 5.004_03 changes (addendum)
+ Branch: maint-5.004/perl
+ - win32/bin/search.bat
+____________________________________________________________________________
+[ 82] By: TimBunce on 1997/09/30 14:11:29
+ Log: Maintenance 5.004_03 changes
+ Branch: maint-5.004/perl
+ + win32/bin/pl2bat.pl win32/bin/runperl.pl win32/bin/search.pl
+ + win32/bin/webget.pl
+ - win32/bin/pl2bat.bat win32/bin/runperl.bat win32/bin/test.bat
+ - win32/bin/webget.bat
+ ! Changes Configure MANIFEST Makefile.SH Porting/makerel
+ ! ext/DynaLoader/DynaLoader.pm hints/hpux.sh hints/linux.sh
+ ! hints/sco.sh hints/sunos_4_1.sh installhtml lib/CPAN.pm
+ ! lib/ExtUtils/MM_Unix.pm lib/FileCache.pm lib/Math/Complex.pm
+ ! lib/Math/Trig.pm lib/blib.pm os2/diff.configure patchlevel.h
+ ! perl.c pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod
+ ! pod/perlop.pod pod/perlre.pod pod/perlrun.pod pod/pod2man.PL
+ ! pp_ctl.c pp_sys.c t/lib/complex.t t/pragma/locale.t toke.c
+ ! utils/perlbug.PL win32/Makefile win32/makefile.mk
+ ! win32/win32.c
+____________________________________________________________________________
+[ 81] By: TimBunce on 1997/09/30 13:17:27
+ Log: Maintenance 5.004_02 changes
+ Branch: maint-5.004/perl
+ + win32/bin/runperl.bat
+ ! Changes Configure INSTALL MANIFEST Makefile.SH Porting/patchls
+ ! README.os2 README.win32 Todo XSUB.h av.c configpm doio.c
+ ! dosish.h embed.h ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+ ! ext/DB_File/typemap ext/GDBM_File/typemap ext/IO/IO.xs
+ ! ext/IO/lib/IO/File.pm ext/IO/lib/IO/Handle.pm
+ ! ext/IO/lib/IO/Socket.pm ext/NDBM_File/typemap
+ ! ext/ODBM_File/ODBM_File.xs ext/POSIX/POSIX.xs
+ ! ext/SDBM_File/typemap global.sym gv.c hints/cxux.sh
+ ! hints/os2.sh hints/sunos_4_1.sh hints/svr4.sh installhtml
+ ! lib/Bundle/CPAN.pm lib/CPAN.pm lib/CPAN/FirstTime.pm
+ ! lib/CPAN/Nox.pm lib/Carp.pm lib/Class/Struct.pm
+ ! lib/Exporter.pm lib/ExtUtils/Command.pm lib/ExtUtils/Embed.pm
+ ! lib/ExtUtils/Install.pm lib/ExtUtils/Liblist.pm
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_VMS.pm
+ ! lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm
+ ! lib/ExtUtils/xsubpp lib/File/Compare.pm lib/File/Copy.pm
+ ! lib/File/Find.pm lib/File/Path.pm lib/FileHandle.pm
+ ! lib/I18N/Collate.pm lib/IPC/Open3.pm lib/Net/hostent.pm
+ ! lib/Pod/Html.pm lib/Shell.pm lib/Sys/Hostname.pm
+ ! lib/Sys/Syslog.pm lib/Term/ReadLine.pm lib/Time/Local.pm
+ ! lib/UNIVERSAL.pm lib/dumpvar.pl lib/ftp.pl lib/perl5db.pl
+ ! malloc.c mg.c op.c opcode.pl os2/Changes os2/Makefile.SHs
+ ! os2/diff.configure os2/os2.c os2/os2ish.h patchlevel.h perl.c
+ ! perl.h pod/perlapio.pod pod/perlbook.pod pod/perldebug.pod
+ ! pod/perldelta.pod pod/perldiag.pod pod/perlembed.pod
+ ! pod/perlfunc.pod pod/perlguts.pod pod/perlop.pod
+ ! pod/perlre.pod pod/perlrun.pod pod/perltoc.pod
+ ! pod/perltrap.pod pod/perlvar.pod pod/perlxstut.pod
+ ! pod/pod2man.PL pod/splitpod pp.c pp_ctl.c pp_hot.c pp_sys.c
+ ! proto.h regcomp.c regexec.c scope.c sv.c t/TEST t/base/lex.t
+ ! t/comp/cmdopt.t t/comp/term.t t/lib/db-btree.t t/lib/db-hash.t
+ ! t/lib/db-recno.t t/lib/filehand.t t/lib/gdbm.t t/lib/ndbm.t
+ ! t/lib/odbm.t t/lib/sdbm.t t/op/local.t t/op/magic.t
+ ! t/op/pack.t t/op/re_tests t/op/ref.t t/op/regexp.t t/op/stat.t
+ ! t/op/substr.t t/op/universal.t toke.c universal.c util.c
+ ! utils/Makefile utils/h2ph.PL utils/perlbug.PL utils/perldoc.PL
+ ! vms/config.vms vms/descrip.mms vms/ext/filespec.t
+ ! vms/sockadapt.c vms/sockadapt.h vms/test.com vms/vms.c
+ ! vms/vmsish.h win32/Makefile win32/bin/pl2bat.bat
+ ! win32/config.bc win32/config.vc win32/config_H.bc
+ ! win32/config_H.vc win32/config_h.PL win32/makedef.pl
+ ! win32/makefile.mk win32/perllib.c win32/win32.c win32/win32.h
+ ! win32/win32io.c win32/win32io.h win32/win32iop.h
+ ! win32/win32sck.c
+____________________________________________________________________________
+[ 80] By: nick on 1997/09/29 20:31:43
+ Log: Add some prototypes in attempt to flush out errors
+ Tidy up vars.h usage.
+ Branch: oneperl
+ ! av.c embed.h hv.c opcode.h perl.c perl.h perlio.c pp_sys.c
+ ! proto.h util.c vars.h
+____________________________________________________________________________
+[ 79] By: nick on 1997/09/29 17:12:07
+ Log: Builds and passes tests without THISPTR
+ Branch: oneperl
+ ! MANIFEST global.sym perl.c perl.h vars.h
+____________________________________________________________________________
+[ 78] By: mbeattie on 1997/09/29 16:57:23
+ Log: Re-introduce the changes from change 68 (runops becomes a
+ function pointer and sv_bless3 for '~'-magic) which got lost
+ during the preparation for the maint-merge.
+ Branch: perl
+ ! global.sym perl.h pp.c proto.h run.c sv.c
+____________________________________________________________________________
+[ 77] By: mbeattie on 1997/09/29 16:44:16
+ Log: Start merge with maint-5.004 branch by creating an ancestral
+ branch point via a fake resolution with the maint-merge branch.
+ See Perforce Tech Note 9 for details.
+ Branch: perl
+ !> (integrate 864 files)
+____________________________________________________________________________
+[ 76] By: nick on 1997/09/28 19:04:42
+ Log: Code with this pointer compiles (but core dumps)
+ Branch: oneperl
+ ! EXTERN.h INTERN.h XSUB.h av.c av.h cop.h cv.h deb.c doio.c
+ ! doop.c dosish.h dump.c form.h gv.c gv.h handy.h hv.c hv.h
+ ! keywords.h mg.c mg.h miniperlmain.c nostdio.h op.c op.h
+ ! opcode.h patchlevel.h perl.c perl.h perlio.c perlio.h
+ ! perlsdio.h perlsfio.h perly.c perly.c.diff perly.h perly.y
+ ! pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c proto.h regcomp.c
+ ! regcomp.h regexec.c regexp.h run.c scope.c scope.h sv.c sv.h
+ ! taint.c thread.h toke.c universal.c unixish.h util.c util.h
+ ! vars.h
+____________________________________________________________________________
+[ 75] By: nick on 1997/09/28 15:45:35
+ Log: Quasi sensible starting point for aTHIS addition.
+ Branch: oneperl
+ ! perl.c perl.h pp_ctl.c sv.c thread.h toke.c util.c
+____________________________________________________________________________
+[ 74] By: nick on 1997/09/28 11:23:32
+ Log: Ooops - unwind perly.* stuff for now
+ Branch: oneperl
+ ! perly.c perly.h perly.y vms/perly_c.vms vms/perly_h.vms
+____________________________________________________________________________
+[ 73] By: nick on 1997/09/28 11:17:23
+ Log: Builds and passes all tests again
+ Branch: oneperl
+ ! embed.pl ext/DB_File/DB_File.xs gv.c perl.c perl.h perly.y
+ ! pp.h proto.h thread.sym vms/perly_c.vms vms/perly_h.vms
+____________________________________________________________________________
+[ 72] By: nick on 1997/09/28 10:47:01
+ Log: Save "important things" before re-try
+ Branch: oneperl
+ + vars.h
+ ! embed.pl thread.h thread.sym
+____________________________________________________________________________
+[ 71] By: nick on 1997/09/26 17:47:31
+ Log: Basic hacks to build with USE_THISPTR, not yet useful
+ but builds miniperl and passes minitest with all thread
+ variables via a _GLOBAL_ thr variable rather than globals.
+ Now for the local thr variable ...
+ Branch: oneperl
+ + thread.sym
+ ! MANIFEST README.threads XSUB.h av.c cv.h deb.c doio.c doop.c
+ ! dump.c embed.pl ext/DB_File/DB_File.xs gv.c hints/solaris_2.sh
+ ! hv.c mg.c op.c perl.c perl.h pp.c pp_ctl.c pp_hot.c pp_sys.c
+ ! proto.h regcomp.c regexec.c run.c scope.c sv.c thread.h toke.c
+ ! util.c vms/vms.c
+____________________________________________________________________________
+[ 70] By: mbeattie on 1997/09/23 14:29:23
+ Log: Branch oneperl from mainline.
+ Branch: oneperl
+ +> (branch 871 files)
+____________________________________________________________________________
+[ 69] By: mbeattie on 1997/09/22 16:02:37
+ Log: struct thread now stored in an SV and uses '~'-magic for access.
+ Branch: perl
+ ! thread.h
+ Branch: perlext
+ ! Thread/Thread.xs Thread/typemap
+____________________________________________________________________________
+[ 68] By: mbeattie on 1997/09/22 16:01:48
+ Log: runops becomes a funtion pointer and sv_bless3 created
+ to avoid pointer forgery with '~'-magic.
+ Branch: perl
+ ! global.sym perl.c perl.h pp.c proto.h run.c sv.c
+____________________________________________________________________________
+[ 67] By: mbeattie on 1997/09/22 15:45:56
+ Log: More fprintf -> PerlIO_printf changes.
+ Branch: perl
+ ! perl.c pp_hot.c util.c
+____________________________________________________________________________
+[ 66] By: mbeattie on 1997/09/22 15:10:40
+ Log: Minor multi-threading patches for VMS.
+ Branch: perl
+ ! mg.c thread.h vms/vms.c
+____________________________________________________________________________
+[ 65] By: mbeattie on 1997/09/15 14:09:11
+ Log: Add undefined-subs option to Lint.pm.
+ Branch: perlext
+ ! Compiler/B/Lint.pm
+____________________________________________________________________________
+[ 64] By: mbeattie on 1997/09/10 16:39:41
+ Log: Debugging output for lock handling.
+ Branch: perl
+ ! mg.c pp.c pp_hot.c util.c
+____________________________________________________________________________
+[ 63] By: mbeattie on 1997/09/10 14:49:00
+ Log: Move Thread/Semaphore.pm to Thread/Thread/Semaphore.pm
+ Branch: perlext
+ +> Thread/Thread/Semaphore.pm
+ - Thread/Semaphore.pm
+____________________________________________________________________________
+[ 62] By: mbeattie on 1997/09/10 14:47:31
+ Log: Move Thread/Queue.pm to Thread/Thread/Queue.pm
+ Branch: perlext
+ +> Thread/Thread/Queue.pm
+ - Thread/Queue.pm
+____________________________________________________________________________
+[ 61] By: mbeattie on 1997/09/10 13:56:50
+ Log: Solaris fixes: delete pad and padname from thread.h and remove
+ MUTEX_* stuff when malloc.c gets copied to x2p/malloc.c.
+ Branch: perl
+ ! thread.h x2p/Makefile.SH
+
+----------------
+Version 5.004_50 First developer release towards 5.005
+----------------
+
+Maintenance of the 5.004 version of perl continues with the 5.004_xx
+series, where 'xx' is <= 49. Development of the next version, 5.005,
+starts with 5.004_50.
+
+____________________________________________________________________________
+[ 60] By: mbeattie on 1997/09/09 16:57:41
+ Log: Update README.threads to mention -DL.
+ Branch: perl
+ ! README.threads
+____________________________________________________________________________
+[ 59] By: mbeattie on 1997/09/09 16:49:08
+ Log: Add Thread modules Queue.pm and Semaphore.pm
+ Branch: perlext
+ + Thread/Queue.pm Thread/Semaphore.pm
+____________________________________________________________________________
+[ 58] By: mbeattie on 1997/09/09 16:33:45
+ Log: Update README.threads
+ Branch: perl
+ ! README.threads
+____________________________________________________________________________
+[ 57] By: mbeattie on 1997/09/09 16:26:47
+ Log: Add debug info to Thread typemap.
+ Branch: perlext
+ ! Thread/typemap
+____________________________________________________________________________
+[ 56] By: mbeattie on 1997/09/09 15:04:26
+ Log: Rewrite synchronisation of subs/methods and add attrs
+ extension for specifying 'locked' and 'method' attributes.
+ Branch: perl
+ + ext/attrs/Makefile.PL ext/attrs/attrs.pm ext/attrs/attrs.xs
+ ! MANIFEST cv.h embed.h global.sym op.c perl.c pp.c pp_ctl.c
+ ! pp_hot.c proto.h sv.c sv.h toke.c
+ Branch: perlext
+ ! Thread/Thread.pm Thread/Thread.xs Thread/sync.t Thread/sync2.t
+____________________________________________________________________________
+[ 55] By: mbeattie on 1997/09/03 16:34:47
+ Log: Add new keyword "lock" to Opcode.pm
+ Branch: perl
+ ! ext/Opcode/Opcode.pm
+____________________________________________________________________________
+[ 54] By: mbeattie on 1997/09/03 14:44:44
+ Log: Run embed.pl and keywords.pl to complete RESTART -> INIT change
+ Branch: perl
+ ! embed.h keywords.h
+____________________________________________________________________________
+[ 53] By: mbeattie on 1997/09/03 13:52:24
+ Log: Add to MANIFEST: README.threads, lib/ISA.pm, lib/Class/Fields.pm
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 52] By: mbeattie on 1997/09/03 13:41:20
+ Log: Let Lint private_names catch out-of-package _foo methods.
+ Branch: perlext
+ ! Compiler/B/Lint.pm
+____________________________________________________________________________
+[ 51] By: mbeattie on 1997/09/03 13:20:12
+ Log: Bump patchlevel.h to 5.004_50
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 50] By: mbeattie on 1997/09/03 12:31:48
+ Log: Make compiler build/work with devel 5.005
+ Branch: perlext
+ ! Compiler/B.xs Compiler/B/Asmdata.pm Compiler/bytecode.h
+ ! Compiler/bytecode.pl Compiler/byterun.c Compiler/byterun.h
+____________________________________________________________________________
+[ 49] By: mbeattie on 1997/09/03 12:28:05
+ Log: Rename RESTART to INIT and associated changes
+ Branch: perl
+ ! interp.sym keywords.pl op.c perl.c perl.h perly.c perly.y
+ ! toke.c vms/perly_c.vms
+____________________________________________________________________________
+[ 48] By: mbeattie on 1997/09/02 15:54:27
+ Log: Added private-names option.
+ Branch: perlext
+ ! Compiler/B/Lint.pm
+____________________________________________________________________________
+[ 47] By: mbeattie on 1997/09/02 11:54:55
+ Log: For compiler's CC, make PP_EVAL, PP_ENTERTRY work with JMPENV.
+ Branch: perlext
+ ! Compiler/cc_runtime.h
+____________________________________________________________________________
+[ 46] By: mbeattie on 1997/08/28 19:40:08
+ Log: Missing sprintf in try_autoload.
+ Branch: perlext
+ ! Compiler/B/C.pm
+____________________________________________________________________________
+[ 45] By: mbeattie on 1997/08/13 16:15:25
+ Log: Threading fixups for Digital UNIX.
+ Branch: perl
+ ! README.threads malloc.c perl.h toke.c
+____________________________________________________________________________
+[ 44] By: mbeattie on 1997/08/11 15:46:29
+ Log: Assorted changes for multi-threading (now works rather more).
+ Branch: perl
+ + README.threads
+ ! gv.c mg.c op.c perl.c perl.h pp_ctl.c pp_hot.c sv.c thread.h
+ ! toke.c util.c
+ Branch: perlext
+ ! Thread/Makefile.PL Thread/Thread.xs Thread/lock.t
+ ! Thread/unsync.t
+____________________________________________________________________________
+[ 43] By: mbeattie on 1997/08/08 14:11:00
+ Log: Made Lint check subs (and -u packages).
+ Added support for dollar_underscore and implicit $_ in foreach.
+ Branch: perlext
+ ! Compiler/B/Lint.pm
+____________________________________________________________________________
+[ 42] By: TimBunce on 1997/07/25 17:15:57
+ Log: Maintenance 5.004_01 changes
+ Branch: maint-5.004/perl
+ + Porting/makerel Porting/patchls hints/newsos4.sh
+ + lib/File/DosGlob.pm lib/chat2.pl perlio.sym win32/config.bc
+ + win32/config.vc win32/config_H.bc win32/config_H.vc
+ + win32/makefile.mk
+ - win32/config.H win32/config.w32
+ ! Changes Configure EXTERN.h INSTALL MANIFEST Makefile.SH
+ ! Porting/pumpkin.pod README README.win32 doio.c embed.h
+ ! ext/DynaLoader/dl_aix.xs ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs
+ ! ext/SDBM_File/Makefile.PL ext/SDBM_File/sdbm/Makefile.PL
+ ! global.sym hints/next_3.sh hints/next_4.sh hints/svr4.sh
+ ! installhtml installman lib/AutoLoader.pm lib/AutoSplit.pm
+ ! lib/CGI/Push.pm lib/CPAN.pm lib/ExtUtils/Install.pm
+ ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Unix.pm
+ ! lib/ExtUtils/MM_VMS.pm lib/ExtUtils/MM_Win32.pm
+ ! lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm
+ ! lib/ExtUtils/xsubpp lib/Pod/Html.pm lib/Pod/Text.pm
+ ! lib/Sys/Syslog.pm lib/Term/ReadLine.pm lib/Test/Harness.pm
+ ! lib/ftp.pl mg.c op.c patchlevel.h perl.c perl.h perl_exp.SH
+ ! perlio.c pod/checkpods.PL pod/perlbook.pod pod/perldata.pod
+ ! pod/perldebug.pod pod/perldelta.pod pod/perldiag.pod
+ ! pod/perlembed.pod pod/perlfaq4.pod pod/perlfaq8.pod
+ ! pod/perlfaq9.pod pod/perlfunc.pod pod/perlguts.pod
+ ! pod/perllol.pod pod/perlop.pod pod/perlrun.pod pod/perlsub.pod
+ ! pod/perltoc.pod pod/perltoot.pod pod/pod2man.PL pod/roffitall
+ ! pod/splitpod pp.c pp_ctl.c pp_hot.c pp_sys.c proto.h regcomp.c
+ ! regcomp.h regexec.c sv.c t/lib/safe2.t t/op/flip.t
+ ! t/op/groups.t t/op/magic.t t/op/mkdir.t t/op/re_tests
+ ! t/op/regexp.t t/op/split.t t/op/stat.t t/op/subst.t
+ ! t/op/taint.t util.c utils/Makefile utils/h2xs.PL
+ ! utils/perlbug.PL vms/ext/DCLsym/DCLsym.pm
+ ! vms/ext/Stdio/Stdio.pm vms/gen_shrfls.pl vms/perlvms.pod
+ ! win32/Makefile win32/config_sh.PL win32/include/sys/socket.h
+ ! win32/makedef.pl win32/makeperldef.pl win32/perlglob.c
+ ! win32/perllib.c win32/win32.c win32/win32.h win32/win32io.c
+ ! win32/win32io.h win32/win32iop.h win32/win32sck.c
+____________________________________________________________________________
+[ 41] By: mbeattie on 1997/07/24 14:57:53
+ Log: Start support for fake threads.
+ pp_lock now returns its argument.
+ Branch: perl
+ ! MANIFEST Makefile.SH cv.h op.c opcode.h opcode.pl perl.c
+ ! perl.h pp.c pp_ctl.c pp_hot.c proto.h sv.h thread.h toke.c
+ ! util.c
+ Branch: perlext
+ ! Thread/Thread.xs
+____________________________________________________________________________
+[ 40] By: mbeattie on 1997/07/24 14:55:07
+ Log: Add missing reset of eval_owner if doeval() fails to parse.
+ Branch: perl
+ ! pp_ctl.c
+____________________________________________________________________________
+[ 39] By: mbeattie on 1997/07/17 13:35:51
+ Log: Fix multiple problems with lexical @_.
+ Branch: perl
+ ! cop.h op.c perl.c pp.c pp_ctl.c pp_hot.c t/op/do.t thread.h
+ ! toke.c
+____________________________________________________________________________
+[ 38] By: mbeattie on 1997/07/16 17:02:09
+ Log: Change %lx to %x in B::CV::save to prevent some CV
+ fields becoming 0 in the init section. Add missing
+ write_back in B::Stackobj::Padsv::load_double to fix
+ test 22 of op/my.t.
+ Branch: perlext
+ ! Compiler/B/C.pm Compiler/B/Stackobj.pm
+____________________________________________________________________________
+[ 37] By: mbeattie on 1997/07/10 11:28:16
+ Log: Branch win32 developments from main perl branch.
+ Branch: win32/perl
+ +> (branch 867 files)
+____________________________________________________________________________
+[ 36] By: mbeattie on 1997/07/05 11:58:05
+ Log: B::CC::pp_padsv must cope with vivify_ref (5.004)
+ as well as provide_ref (5.003).
+ Branch: perlext
+ ! Compiler/B/C.pm Compiler/B/CC.pm Compiler/NOTES
+____________________________________________________________________________
+[ 35] By: mbeattie on 1997/07/05 11:55:18
+ Log: Introduce pp_lock.
+ Branch: perl
+ ! embed.h global.sym keywords.h keywords.pl opcode.h opcode.pl
+ ! pp.c pp_ctl.c toke.c
+____________________________________________________________________________
+[ 34] By: mbeattie on 1997/07/01 12:24:28
+ Log: Support for op in global register (still buggy)
+ Branch: perl
+ ! embed.h global.sym gv.c op.c perl.c perl.h pp_ctl.c pp_sys.c
+ ! proto.h scope.c scope.h thread.h
+____________________________________________________________________________
+[ 33] By: mbeattie on 1997/06/24 16:34:24
+ Log: Branch lexical warnings from perl branch.
+ Branch: lexwarn/perl
+ +> (branch 867 files)
+____________________________________________________________________________
+[ 32] By: mbeattie on 1997/06/24 14:33:57
+ Log: Branch integration of maint-5.004 from relperl.
+ Branch: mainline/perl
+ +> (branch 600 files)
+ Branch: maint-5.004/perl
+ +> (branch 864 files)
+____________________________________________________________________________
+[ 31] By: mbeattie on 1997/06/20 11:46:50
+ Log: corrected bad_type() prototype.
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 30] By: mbeattie on 1997/06/12 12:38:05
+ Log: Tweak README.
+ Branch: perlext
+ ! Thread/README
+____________________________________________________________________________
+[ 29] By: mbeattie on 1997/06/12 12:34:59
+ Log: Document -m option of CC backend.
+ Branch: perlext
+ ! Compiler/NOTES
+____________________________________________________________________________
+[ 28] By: mbeattie on 1997/06/12 12:25:05
+ Log: Support sysseek introduced in 5.004.
+ Branch: perlext
+ ! Compiler/ccop.c Compiler/ccop.h
+____________________________________________________________________________
+[ 27] By: mbeattie on 1997/06/05 14:20:51
+ Log: More fixups for thrperl integration.
+ Branch: perl
+ ! ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+ ! ext/Opcode/Makefile.PL ext/Opcode/Opcode.pm
+ ! ext/Opcode/Opcode.xs gv.c hv.c mg.c op.c perl.c perly.c
+ ! perly.y pp.c pp_ctl.c run.c scope.c sv.c sv.h thread.h toke.c
+ ! util.c
+____________________________________________________________________________
+[ 25] By: mbeattie on 1997/05/28 15:11:24
+ Log: Fixups for thrperl integration.
+ Branch: perl
+ ! embed.h keywords.h op.c opcode.h perl.c util.c
+____________________________________________________________________________
+[ 24] By: mbeattie on 1997/05/26 20:10:42
+ Log: Integrate thrperl 5.003->5.004.
+ Branch: perl
+ +> thread.h
+ !> (integrate 33 files)
+____________________________________________________________________________
+[ 23] By: mbeattie on 1997/05/26 11:45:39
+ Log: Fix ppname when saving subs.
+ Branch: perlext
+ ! Compiler/B/C.pm
+____________________________________________________________________________
+[ 22] By: mbeattie on 1997/05/26 11:45:03
+ Log: -mFoo option now forces -uFoo.
+ Branch: perlext
+ ! Compiler/B/CC.pm
+____________________________________________________________________________
+[ 21] By: mbeattie on 1997/05/26 11:43:37
+ Log: Put back objsym/savesym (used by walkoptree_exec).
+ Branch: perlext
+ ! Compiler/B.pm
+____________________________________________________________________________
+[ 20] By: mbeattie on 1997/05/26 11:38:45
+ Log: Add avhv_store_ent. Add missing avhv_* to global.sym.
+ Branch: perl
+ ! av.c global.sym
+____________________________________________________________________________
+[ 19] By: mbeattie on 1997/05/25 21:19:38
+ Log: Fix up integration 5.003->5.004.
+ Branch: perl
+ + lib/Class/Fields.pm lib/ISA.pm
+ ! av.c ext/DB_File/DB_File.xs perl.c pp.c pp_hot.c proto.h
+ ! toke.c
+____________________________________________________________________________
+[ 18] By: mbeattie on 1997/05/25 10:31:21
+ Log: First stab at 5.003 -> 5.004 integration.
+ Branch: perl
+ +> (branch 291 files)
+ - Changes.Conf ext/DynaLoader/dl_os2.xs
+ - ext/FileHandle/FileHandle.pm ext/FileHandle/FileHandle.xs
+ - ext/FileHandle/Makefile.PL ext/SDBM_File/sdbm/readme.ps
+ - ext/Safe/Makefile.PL ext/Safe/Safe.pm ext/Safe/Safe.xs
+ - hints/aux.sh hints/dnix.sh hints/irix_6_2.sh lib/chat2.inter
+ - lib/chat2.pl lib/splain os2/README os2/README.old
+ - os2/diff.db_file os2/notes pod/perlovl.pod t/lib/safe.t
+ - t/op/overload.t t/re_tests vms/Makefile x2p/a2p.man
+ - x2p/handy.h x2p/s2p.man
+ !> (integrate 392 files)
+____________________________________________________________________________
+[ 17] By: mbeattie on 1997/05/24 18:46:49
+ Log: Wholesale update to 5.004.
+ Branch: relperl
+ + Changes5.000 Changes5.001 Changes5.002 Changes5.003
+ + Porting/Glossary Porting/pumpkin.pod README.amiga
+ + README.cygwin32 README.os2 README.plan9 README.qnx
+ + README.win32 compat3.sym configure.gnu cygwin32/cw32imp.h
+ + cygwin32/gcc2 cygwin32/ld2 cygwin32/perlgcc cygwin32/perlld
+ + eg/cgi/RunMeFirst eg/cgi/clickable_image.cgi eg/cgi/cookie.cgi
+ + eg/cgi/crash.cgi eg/cgi/customize.cgi eg/cgi/diff_upload.cgi
+ + eg/cgi/file_upload.cgi eg/cgi/frameset.cgi eg/cgi/index.html
+ + eg/cgi/internal_links.cgi eg/cgi/javascript.cgi
+ + eg/cgi/monty.cgi eg/cgi/multiple_forms.cgi
+ + eg/cgi/nph-clock.cgi eg/cgi/popup.cgi eg/cgi/save_state.cgi
+ + eg/cgi/tryit.cgi eg/cgi/wilogo.gif.uu
+ + ext/DynaLoader/dl_cygwin32.xs 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 ext/NDBM_File/hints/dec_osf.pl
+ + ext/NDBM_File/hints/dynixptx.pl ext/ODBM_File/hints/hpux.pl
+ + ext/ODBM_File/hints/ultrix.pl ext/Opcode/Makefile.PL
+ + ext/Opcode/Opcode.pm ext/Opcode/Opcode.xs ext/Opcode/Safe.pm
+ + ext/Opcode/ops.pm ext/POSIX/hints/next_3.pl hints/amigaos.sh
+ + hints/aux_3.sh hints/broken-db.msg hints/cygwin32.sh
+ + hints/dcosx.sh hints/irix_6_0.sh hints/irix_6_1.sh
+ + hints/lynxos.sh hints/next_4.sh hints/qnx.sh hints/umips.sh
+ + hints/unicosmk.sh installhtml lib/Bundle/CPAN.pm lib/CGI.pm
+ + lib/CGI/Apache.pm lib/CGI/Carp.pm lib/CGI/Fast.pm
+ + lib/CGI/Push.pm lib/CGI/Switch.pm lib/CPAN.pm
+ + lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm lib/Class/Struct.pm
+ + lib/ExtUtils/Command.pm lib/ExtUtils/Embed.pm
+ + lib/ExtUtils/MM_Win32.pm lib/File/Compare.pm lib/File/stat.pm
+ + lib/FileHandle.pm lib/FindBin.pm lib/Math/Trig.pm
+ + lib/Net/hostent.pm lib/Net/netent.pm lib/Net/protoent.pm
+ + lib/Net/servent.pm lib/Pod/Html.pm lib/Tie/RefHash.pm
+ + lib/Time/gmtime.pm lib/Time/localtime.pm lib/Time/tm.pm
+ + lib/UNIVERSAL.pm lib/User/grent.pm lib/User/pwent.pm
+ + lib/autouse.pm lib/blib.pm lib/constant.pm lib/locale.pm
+ + nostdio.h os2/Changes os2/OS2/ExtAttr/Changes
+ + os2/OS2/ExtAttr/ExtAttr.pm os2/OS2/ExtAttr/ExtAttr.xs
+ + os2/OS2/ExtAttr/MANIFEST os2/OS2/ExtAttr/Makefile.PL
+ + os2/OS2/ExtAttr/myea.h os2/OS2/ExtAttr/t/os2_ea.t
+ + os2/OS2/ExtAttr/typemap os2/OS2/PrfDB/Changes
+ + os2/OS2/PrfDB/MANIFEST os2/OS2/PrfDB/Makefile.PL
+ + os2/OS2/PrfDB/PrfDB.pm os2/OS2/PrfDB/PrfDB.xs
+ + os2/OS2/PrfDB/t/os2_prfdb.t os2/OS2/PrfDB/typemap
+ + os2/OS2/Process/MANIFEST os2/OS2/Process/Makefile.PL
+ + os2/OS2/Process/Process.pm os2/OS2/Process/Process.xs
+ + os2/OS2/REXX/Changes os2/OS2/REXX/MANIFEST
+ + os2/OS2/REXX/Makefile.PL os2/OS2/REXX/REXX.pm
+ + os2/OS2/REXX/REXX.xs os2/OS2/REXX/t/rx_cmprt.t
+ + os2/OS2/REXX/t/rx_dllld.t os2/OS2/REXX/t/rx_objcall.t
+ + os2/OS2/REXX/t/rx_sql.test os2/OS2/REXX/t/rx_tiesql.test
+ + os2/OS2/REXX/t/rx_tievar.t os2/OS2/REXX/t/rx_tieydb.t
+ + os2/OS2/REXX/t/rx_varset.t os2/OS2/REXX/t/rx_vrexx.t
+ + os2/dl_os2.c os2/dlfcn.h perlio.c perlio.h perlsdio.h
+ + perlsfio.h plan9/aperl plan9/arpa/inet.h plan9/buildinfo
+ + plan9/config.plan9 plan9/exclude plan9/fndvers
+ + plan9/genconfig.pl plan9/mkfile plan9/myconfig.plan9
+ + plan9/perlplan9.doc plan9/perlplan9.pod plan9/plan9.c
+ + plan9/plan9ish.h plan9/setup.rc plan9/versnum pod/checkpods.PL
+ + pod/perlapio.pod pod/perldelta.pod pod/perlfaq.pod
+ + pod/perlfaq1.pod pod/perlfaq2.pod pod/perlfaq3.pod
+ + pod/perlfaq4.pod pod/perlfaq5.pod pod/perlfaq6.pod
+ + pod/perlfaq7.pod pod/perlfaq8.pod pod/perlfaq9.pod
+ + pod/perllocale.pod pod/perlmodlib.pod pod/perltoot.pod
+ + pod/rofftoc qnx/ar qnx/cpp t/comp/colon.t t/comp/proto.t
+ + t/comp/redef.t t/comp/use.t t/io/read.t t/lib/abbrev.t
+ + t/lib/autoloader.t t/lib/basename.t t/lib/checktree.t
+ + t/lib/complex.t t/lib/env.t t/lib/filecache.t t/lib/filecopy.t
+ + t/lib/filefind.t t/lib/filepath.t t/lib/findbin.t
+ + t/lib/getopt.t t/lib/hostname.t t/lib/io_dup.t t/lib/io_pipe.t
+ + t/lib/io_sel.t t/lib/io_sock.t t/lib/io_taint.t
+ + t/lib/io_tell.t t/lib/io_udp.t t/lib/io_xs.t t/lib/opcode.t
+ + t/lib/open2.t t/lib/open3.t t/lib/ops.t t/lib/parsewords.t
+ + t/lib/safe1.t t/lib/safe2.t t/lib/searchdict.t
+ + t/lib/selectsaver.t t/lib/symbol.t t/lib/texttabs.t
+ + t/lib/textwrap.t t/lib/timelocal.t t/lib/trig.t t/op/arith.t
+ + t/op/assignwarn.t t/op/bop.t t/op/closure.t t/op/cmp.t
+ + t/op/gv.t t/op/inc.t t/op/method.t t/op/recurse.t
+ + t/op/runlevel.t t/op/sysio.t t/op/taint.t t/op/tie.t
+ + t/op/universal.t t/pragma/constant.t t/pragma/locale.t
+ + t/pragma/overload.t t/pragma/strict-refs t/pragma/strict-subs
+ + t/pragma/strict-vars t/pragma/strict.t t/pragma/subs.t
+ + t/pragma/warn-1global t/pragma/warning.t universal.c
+ + utils/splain.PL vms/ext/DCLsym/0README.txt
+ + vms/ext/DCLsym/DCLsym.pm vms/ext/DCLsym/DCLsym.xs
+ + vms/ext/DCLsym/Makefile.PL vms/ext/DCLsym/test.pl
+ + vms/ext/XSSymSet.pm vms/ext/filespec.t vms/ext/vmsish.pm
+ + vms/ext/vmsish.t win32/Makefile win32/TEST win32/autosplit.pl
+ + win32/bin/network.pl win32/bin/pl2bat.bat win32/bin/search.bat
+ + win32/bin/test.bat win32/bin/webget.bat win32/bin/www.pl
+ + win32/config.H win32/config.w32 win32/config_h.PL
+ + win32/config_sh.PL win32/dl_win32.xs win32/genxsdef.pl
+ + win32/include/arpa/inet.h win32/include/dirent.h
+ + win32/include/netdb.h win32/include/sys/socket.h
+ + win32/makedef.pl win32/makemain.pl win32/makeperldef.pl
+ + win32/perlglob.c win32/perllib.c win32/pod.mak win32/runperl.c
+ + win32/splittree.pl win32/win32.c win32/win32.h win32/win32io.c
+ + win32/win32io.h win32/win32iop.h win32/win32sck.c x2p/a2p.pod
+ + x2p/proto.h
+ - Changes.Conf ext/DynaLoader/dl_os2.xs
+ - ext/FileHandle/FileHandle.pm ext/FileHandle/FileHandle.xs
+ - ext/FileHandle/Makefile.PL ext/SDBM_File/sdbm/readme.ps
+ - ext/Safe/Makefile.PL ext/Safe/Safe.pm ext/Safe/Safe.xs
+ - hints/aux.sh hints/dnix.sh hints/irix_6_2.sh lib/chat2.inter
+ - lib/chat2.pl lib/splain os2/README os2/README.old
+ - os2/diff.db_file os2/notes pod/perlovl.pod t/lib/safe.t
+ - t/op/overload.t t/re_tests vms/Makefile x2p/a2p.man
+ - x2p/handy.h x2p/s2p.man
+ ! Artistic Changes Configure EXTERN.h INSTALL INTERN.h MANIFEST
+ ! Makefile.SH README README.vms Todo XSUB.h av.c av.h cflags.SH
+ ! config_H config_h.SH configpm configure cop.h cv.h deb.c
+ ! doio.c doop.c dosish.h dump.c eg/README eg/nih
+ ! eg/sysvipc/ipcmsg eg/sysvipc/ipcsem eg/sysvipc/ipcshm
+ ! emacs/cperl-mode.el embed.h embed.pl ext/DB_File/DB_File.pm
+ ! ext/DB_File/DB_File.xs ext/DB_File/Makefile.PL
+ ! ext/DB_File/typemap ext/DynaLoader/DynaLoader.pm
+ ! ext/DynaLoader/Makefile.PL ext/DynaLoader/dl_aix.xs
+ ! ext/DynaLoader/dl_dld.xs ext/DynaLoader/dl_dlopen.xs
+ ! ext/DynaLoader/dl_hpux.xs ext/DynaLoader/dl_next.xs
+ ! ext/DynaLoader/dl_vms.xs ext/DynaLoader/dlutils.c
+ ! ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs
+ ! ext/GDBM_File/GDBM_File.pm ext/NDBM_File/NDBM_File.pm
+ ! ext/ODBM_File/ODBM_File.pm ext/ODBM_File/ODBM_File.xs
+ ! ext/ODBM_File/hints/dec_osf.pl ext/POSIX/POSIX.pm
+ ! ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs
+ ! ext/SDBM_File/Makefile.PL ext/SDBM_File/SDBM_File.pm
+ ! ext/SDBM_File/sdbm/Makefile.PL ext/SDBM_File/sdbm/pair.c
+ ! ext/SDBM_File/sdbm/pair.h ext/SDBM_File/sdbm/sdbm.3
+ ! ext/SDBM_File/sdbm/sdbm.c ext/SDBM_File/sdbm/sdbm.h
+ ! ext/Socket/Socket.pm ext/Socket/Socket.xs ext/util/make_ext
+ ! form.h global.sym gv.c gv.h handy.h hints/3b1.sh
+ ! hints/README.hints hints/aix.sh hints/apollo.sh hints/bsdos.sh
+ ! hints/convexos.sh hints/cxux.sh hints/dec_osf.sh hints/dgux.sh
+ ! hints/dynixptx.sh hints/epix.sh hints/esix4.sh
+ ! hints/freebsd.sh hints/hpux.sh hints/irix_4.sh hints/irix_5.sh
+ ! hints/irix_6.sh hints/isc.sh hints/linux.sh hints/machten.sh
+ ! hints/machten_2.sh hints/mips.sh hints/mpeix.sh
+ ! hints/netbsd.sh hints/next_3.sh hints/next_3_0.sh hints/os2.sh
+ ! hints/powerux.sh hints/sco.sh hints/sco_2_3_3.sh
+ ! hints/sco_2_3_4.sh hints/solaris_2.sh hints/sunos_4_0.sh
+ ! hints/sunos_4_1.sh hints/svr4.sh hints/titanos.sh
+ ! hints/ultrix_4.sh hints/unicos.sh hints/utekv.sh hv.c hv.h
+ ! installman installperl interp.sym keywords.h keywords.pl
+ ! lib/AnyDBM_File.pm lib/AutoLoader.pm lib/AutoSplit.pm
+ ! lib/Benchmark.pm lib/Carp.pm lib/Cwd.pm
+ ! lib/Devel/SelfStubber.pm lib/English.pm lib/Env.pm
+ ! lib/Exporter.pm lib/ExtUtils/Install.pm
+ ! lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_OS2.pm
+ ! lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_VMS.pm
+ ! lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Manifest.pm
+ ! lib/ExtUtils/Mkbootstrap.pm lib/ExtUtils/Mksymlists.pm
+ ! lib/ExtUtils/testlib.pm lib/ExtUtils/typemap
+ ! lib/ExtUtils/xsubpp lib/File/Basename.pm lib/File/Copy.pm
+ ! lib/File/Find.pm lib/File/Path.pm lib/FileCache.pm
+ ! lib/Getopt/Long.pm lib/Getopt/Std.pm lib/I18N/Collate.pm
+ ! lib/IPC/Open2.pm lib/IPC/Open3.pm lib/Math/BigInt.pm
+ ! lib/Math/Complex.pm lib/Net/Ping.pm lib/Pod/Functions.pm
+ ! lib/Pod/Text.pm lib/Search/Dict.pm lib/SelectSaver.pm
+ ! lib/SelfLoader.pm lib/Symbol.pm lib/Sys/Hostname.pm
+ ! lib/Sys/Syslog.pm lib/Term/Cap.pm lib/Term/Complete.pm
+ ! lib/Term/ReadLine.pm lib/Test/Harness.pm lib/Text/Abbrev.pm
+ ! lib/Text/ParseWords.pm lib/Text/Soundex.pm lib/Text/Tabs.pm
+ ! lib/Text/Wrap.pm lib/Tie/Hash.pm lib/Tie/Scalar.pm
+ ! lib/Tie/SubstrHash.pm lib/Time/Local.pm lib/abbrev.pl
+ ! lib/bigfloat.pl lib/bigint.pl lib/cacheout.pl lib/complete.pl
+ ! lib/diagnostics.pm lib/dotsh.pl lib/dumpvar.pl lib/find.pl
+ ! lib/finddepth.pl lib/ftp.pl lib/getcwd.pl lib/getopts.pl
+ ! lib/importenv.pl lib/lib.pm lib/look.pl lib/newgetopt.pl
+ ! lib/open2.pl lib/open3.pl lib/overload.pm lib/perl5db.pl
+ ! lib/sigtrap.pm lib/strict.pm lib/subs.pm lib/syslog.pl
+ ! lib/termcap.pl lib/timelocal.pl lib/validate.pl lib/vars.pm
+ ! makeaperl.SH makedepend.SH malloc.c mg.c mg.h minimod.pl
+ ! miniperlmain.c myconfig op.c op.h opcode.h opcode.pl
+ ! os2/Makefile.SHs os2/diff.configure os2/os2.c os2/os2ish.h
+ ! os2/perl2cmd.pl patchlevel.h perl.c perl.h perl_exp.SH perlsh
+ ! perly.c perly.c.diff perly.h perly.y pod/Makefile pod/buildtoc
+ ! pod/perl.pod pod/perlbook.pod pod/perlbot.pod pod/perlcall.pod
+ ! pod/perldata.pod pod/perldebug.pod pod/perldiag.pod
+ ! pod/perldsc.pod pod/perlembed.pod pod/perlform.pod
+ ! pod/perlfunc.pod pod/perlguts.pod pod/perlipc.pod
+ ! pod/perllol.pod pod/perlmod.pod pod/perlobj.pod pod/perlop.pod
+ ! pod/perlpod.pod pod/perlre.pod pod/perlref.pod pod/perlrun.pod
+ ! pod/perlsec.pod pod/perlstyle.pod pod/perlsub.pod
+ ! pod/perlsyn.pod pod/perltie.pod pod/perltoc.pod
+ ! pod/perltrap.pod pod/perlvar.pod pod/perlxs.pod
+ ! pod/perlxstut.pod pod/pod2html.PL pod/pod2latex.PL
+ ! pod/pod2man.PL pod/pod2text.PL pod/roffitall pp.c pp.h
+ ! pp_ctl.c pp_hot.c pp_sys.c proto.h regcomp.c regcomp.h
+ ! regexec.c regexp.h run.c scope.c scope.h sv.c sv.h t/README
+ ! t/TEST t/base/lex.t t/base/term.t t/cmd/mod.t t/cmd/while.t
+ ! t/comp/cpp.t t/comp/multiline.t t/comp/package.t
+ ! t/comp/script.t t/harness t/io/argv.t t/io/dup.t t/io/fs.t
+ ! t/io/inplace.t t/io/pipe.t t/io/tell.t t/lib/anydbm.t
+ ! t/lib/bigintpm.t t/lib/db-btree.t t/lib/db-hash.t
+ ! t/lib/db-recno.t t/lib/dirhand.t t/lib/filehand.t t/lib/gdbm.t
+ ! t/lib/ndbm.t t/lib/odbm.t t/lib/posix.t t/lib/sdbm.t
+ ! t/lib/socket.t t/op/chop.t t/op/delete.t t/op/each.t
+ ! t/op/exec.t t/op/fork.t t/op/glob.t t/op/goto.t t/op/groups.t
+ ! t/op/magic.t t/op/misc.t t/op/mkdir.t t/op/my.t t/op/oct.t
+ ! t/op/pack.t t/op/pat.t t/op/quotemeta.t t/op/rand.t
+ ! t/op/re_tests t/op/readdir.t t/op/ref.t t/op/regexp.t
+ ! t/op/sleep.t t/op/sort.t t/op/split.t t/op/stat.t t/op/subst.t
+ ! t/op/substr.t t/op/write.t taint.c toke.c unixish.h util.c
+ ! util.h utils/Makefile utils/c2ph.PL utils/h2ph.PL
+ ! utils/h2xs.PL utils/perlbug.PL utils/perldoc.PL utils/pl2pm.PL
+ ! vms/config.vms vms/descrip.mms vms/ext/Filespec.pm
+ ! vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs
+ ! vms/ext/Stdio/test.pl vms/fndvers.com vms/gen_shrfls.pl
+ ! vms/genconfig.pl vms/genopt.com vms/myconfig.com
+ ! vms/perlvms.pod vms/perly_c.vms vms/perly_h.vms
+ ! vms/sockadapt.c vms/sockadapt.h vms/test.com vms/vms.c
+ ! vms/vms_yfix.pl vms/vmsish.h vms/writemain.pl writemain.SH
+ ! x2p/EXTERN.h x2p/INTERN.h x2p/Makefile.SH x2p/a2p.c x2p/a2p.h
+ ! x2p/a2p.y x2p/a2py.c x2p/cflags.SH x2p/find2perl.PL x2p/hash.c
+ ! x2p/hash.h x2p/s2p.PL x2p/str.c x2p/str.h x2p/util.c
+ ! x2p/util.h x2p/walk.c
+____________________________________________________________________________
+[ 16] By: mbeattie on 1997/05/23 22:42:08
+ Log: Initial integration of relperl from 5.003.
+ Branch: relperl
+ +> (branch 600 files)
+____________________________________________________________________________
+[ 14] By: mbeattie on 1997/05/12 20:22:56
+ Log: Finish code generation rewrite. Clean up B::Section class and
+ handle symbol table translation internally. Simple .pm modules
+ now compile OK.
+ Branch: perlext
+ ! Compiler/B.pm Compiler/B/Bblock.pm Compiler/B/C.pm
+ ! Compiler/B/CC.pm
+____________________________________________________________________________
+[ 13] By: mbeattie on 1997/05/05 19:41:18
+ Log: Don't make pp_enter and pp_return trigger basic blocks.
+ Branch: perlext
+ ! Compiler/B/Bblock.pm
+____________________________________________________________________________
+[ 12] By: mbeattie on 1997/05/05 19:40:16
+ Log: Rewrite code generation. Sections (de)multiplexed into a
+ temporary file instead of stored in arrays.
+ Branch: perlext
+ ! Compiler/B.pm Compiler/B/C.pm Compiler/B/CC.pm
+____________________________________________________________________________
+[ 11] By: mbeattie on 1997/05/03 20:20:59
+ Log: Development to pre-alpha4
+ Branch: perlext
+ + Compiler/B/Deparse.pm Compiler/B/Lint.pm Compiler/makeliblinks
+ ! Compiler/B.pm Compiler/B.xs Compiler/B/Bblock.pm
+ ! Compiler/B/Bytecode.pm Compiler/B/C.pm Compiler/B/CC.pm
+ ! Compiler/B/Debug.pm Compiler/B/Terse.pm Compiler/B/Xref.pm
+ ! Compiler/Makefile.PL Compiler/README Compiler/TESTS
+ ! Compiler/assemble Compiler/bytecode.pl Compiler/byteperl.c
+ ! Compiler/byterun.c Compiler/cc_runtime.h Compiler/disassemble
+ ! Compiler/test_harness Compiler/test_harness_cc
+____________________________________________________________________________
+[ 10] By: mbeattie on 1997/05/03 14:47:06
+ Log: Initial check-in of perl compiler.
+ Branch: perlext
+ + Compiler/Artistic Compiler/B.pm Compiler/B.xs
+ + Compiler/B/Asmdata.pm Compiler/B/Assembler.pm
+ + Compiler/B/Bblock.pm Compiler/B/Bytecode.pm Compiler/B/C.pm
+ + Compiler/B/CC.pm Compiler/B/Debug.pm
+ + Compiler/B/Disassembler.pm Compiler/B/Showlex.pm
+ + Compiler/B/Stackobj.pm Compiler/B/Terse.pm Compiler/B/Xref.pm
+ + Compiler/Copying Compiler/Makefile.PL Compiler/NOTES
+ + Compiler/O.pm Compiler/README Compiler/TESTS
+ + Compiler/TESTS.alpha2 Compiler/Todo Compiler/assemble
+ + Compiler/bytecode.h Compiler/bytecode.pl Compiler/byteperl.c
+ + Compiler/byterun.c Compiler/byterun.h Compiler/cc_harness
+ + Compiler/cc_runtime.h Compiler/ccop.c Compiler/ccop.h
+ + Compiler/disassemble Compiler/old/README.feb11
+ + Compiler/old/TESTS.mar11 Compiler/old/TESTS.mar20
+ + Compiler/old/TESTS.may11 Compiler/old/TESTS.pre-jul27
+ + Compiler/op.patch Compiler/ramblings/cc.notes
+ + Compiler/ramblings/curcop.runtime
+ + Compiler/ramblings/dontparse.c Compiler/ramblings/flip-flop
+ + Compiler/ramblings/foo.bench Compiler/ramblings/foo2.bench
+ + Compiler/ramblings/foo3.bench Compiler/ramblings/magic
+ + Compiler/ramblings/pp_i_add Compiler/ramblings/reg.alloc
+ + Compiler/ramblings/runtime.porting
+ + Compiler/ramblings/sort.notes Compiler/ramblings/sub.call
+ + Compiler/ramblings/subst.notes Compiler/run_bytecode_test
+ + Compiler/run_cc_test Compiler/run_test Compiler/test_harness
+ + Compiler/test_harness_bytecode Compiler/test_harness_cc
+ + Compiler/typemap
+____________________________________________________________________________
+[ 9] By: mbeattie on 1997/05/02 19:03:49
+ Log: Don't require CvDEPTH == 0 when bombing out of subs.
+ Branch: thrperl
+ ! pp_hot.c
+____________________________________________________________________________
+[ 8] By: mbeattie on 1997/04/23 19:06:45
+ Log: Added programmer-level condition variables via "condpair" magic.
+ Added support for detached threads and tweaked a few things.
+ Branch: thrperl
+ ! embed.h global.sym keywords.h mg.c opcode.h perl.c perl.h
+ ! pp_ctl.c pp_hot.c proto.h run.c scope.c sv.c sv.h thread.h
+ ! util.c
+____________________________________________________________________________
+[ 7] By: mbeattie on 1997/04/23 19:04:18
+ Log: Rewrote programmer-level condition variables from scratch. Added
+ support for detaching threads. Fixed handling for arguments
+ passed in to threads and return values for joined threads.
+ Branch: perlext
+ + Thread/lock.t
+ ! Thread/README Thread/Thread.pm Thread/Thread.xs Thread/cond.t
+ ! Thread/typemap
+____________________________________________________________________________
+[ 6] By: mbeattie on 1997/04/10 20:17:26
+ Log: Initial check-in of Thread module.
+ Branch: perlext
+ + Thread/Makefile.PL Thread/Notes Thread/README Thread/Thread.pm
+ + Thread/Thread.xs Thread/cond.t Thread/create.t Thread/io.t
+ + Thread/join.t Thread/sync.t Thread/sync2.t Thread/typemap
+ + Thread/unsync.t Thread/unsync2.t Thread/unsync3.t
+ + Thread/unsync4.t
+____________________________________________________________________________
+[ 5] By: mbeattie on 1997/04/10 20:05:52
+ Log: Tweaks to allow compilation without -DUSE_THREADS and fix
+ missing parens (pad allocation) in the tokener.
+ Branch: thrperl
+ ! op.c pp_ctl.c toke.c
+____________________________________________________________________________
+[ 4] By: mbeattie on 1997/03/28 18:40:44
+ Log: Initial 3-way merge from (5.001m, thr1m, 5.003) plus fixups.
+ Branch: thrperl
+ + thread.h
+ ! XSUB.h av.c cv.h deb.c doio.c doop.c dump.c global.sym gv.c
+ ! hv.c malloc.c mg.c op.c op.h opcode.h opcode.pl perl.c perl.h
+ ! pp.h pp_ctl.c pp_hot.c pp_sys.c proto.h regcomp.c regexec.c
+ ! run.c scope.c sv.c sv.h toke.c util.c
+____________________________________________________________________________
+[ 3] By: mbeattie on 1997/03/28 13:36:23
+ Log: Branch 5.003 -> thrperl
+ Branch: thrperl
+ +> (branch 600 files)
+____________________________________________________________________________
+[ 2] By: mbeattie on 1997/03/28 13:32:21
+ Log: Initial devel changes.
+ Pseudo-hashes. Optional strong typing. RESTART {}.
+ Branch: perl
+ ! av.c doop.c embed.h ext/DB_File/DB_File.xs global.sym
+ ! interp.sym keywords.h keywords.pl lib/ExtUtils/xsubpp op.c
+ ! perl.c perl.h pp.c pp_hot.c proto.h t/op/groups.t toke.c
+____________________________________________________________________________
+[ 1] By: mbeattie on 1997/03/28 13:17:33
+ Log: Perl 5.003 check-in
+ Branch: perl
+ + Artistic Changes Changes.Conf Configure Copying EXTERN.h
+ + INSTALL INTERN.h MANIFEST Makefile.SH README README.vms Todo
+ + XSUB.h av.c av.h cflags.SH config_H config_h.SH configpm
+ + configure cop.h cv.h deb.c doio.c doop.c dosish.h dump.c
+ + eg/ADB eg/README eg/changes eg/client eg/down eg/dus eg/findcp
+ + eg/findtar eg/g/gcp eg/g/gcp.man eg/g/ged eg/g/ghosts eg/g/gsh
+ + eg/g/gsh.man eg/muck eg/muck.man eg/myrup eg/nih eg/relink
+ + eg/rename eg/rmfrom eg/scan/scan_df eg/scan/scan_last
+ + eg/scan/scan_messages eg/scan/scan_passwd eg/scan/scan_ps
+ + eg/scan/scan_sudo eg/scan/scan_suid eg/scan/scanner eg/server
+ + eg/shmkill eg/sysvipc/README eg/sysvipc/ipcmsg
+ + eg/sysvipc/ipcsem eg/sysvipc/ipcshm eg/travesty eg/unuc
+ + eg/uudecode eg/van/empty eg/van/unvanish eg/van/vanexp
+ + eg/van/vanish eg/who eg/wrapsuid emacs/cperl-mode.el embed.h
+ + embed.pl ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+ + ext/DB_File/DB_File_BS ext/DB_File/Makefile.PL
+ + ext/DB_File/typemap ext/DynaLoader/DynaLoader.pm
+ + ext/DynaLoader/Makefile.PL ext/DynaLoader/README
+ + ext/DynaLoader/dl_aix.xs ext/DynaLoader/dl_dld.xs
+ + ext/DynaLoader/dl_dlopen.xs ext/DynaLoader/dl_hpux.xs
+ + ext/DynaLoader/dl_next.xs ext/DynaLoader/dl_none.xs
+ + ext/DynaLoader/dl_os2.xs ext/DynaLoader/dl_vms.xs
+ + ext/DynaLoader/dlutils.c ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs
+ + ext/Fcntl/Makefile.PL ext/FileHandle/FileHandle.pm
+ + ext/FileHandle/FileHandle.xs ext/FileHandle/Makefile.PL
+ + ext/GDBM_File/GDBM_File.pm ext/GDBM_File/GDBM_File.xs
+ + ext/GDBM_File/Makefile.PL ext/GDBM_File/typemap
+ + ext/NDBM_File/Makefile.PL ext/NDBM_File/NDBM_File.pm
+ + ext/NDBM_File/NDBM_File.xs ext/NDBM_File/hints/solaris.pl
+ + ext/NDBM_File/hints/svr4.pl ext/NDBM_File/typemap
+ + ext/ODBM_File/Makefile.PL ext/ODBM_File/ODBM_File.pm
+ + ext/ODBM_File/ODBM_File.xs ext/ODBM_File/hints/dec_osf.pl
+ + ext/ODBM_File/hints/sco.pl ext/ODBM_File/hints/solaris.pl
+ + ext/ODBM_File/hints/svr4.pl ext/ODBM_File/typemap
+ + ext/POSIX/Makefile.PL ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod
+ + ext/POSIX/POSIX.xs ext/POSIX/typemap ext/SDBM_File/Makefile.PL
+ + ext/SDBM_File/SDBM_File.pm ext/SDBM_File/SDBM_File.xs
+ + ext/SDBM_File/sdbm/CHANGES ext/SDBM_File/sdbm/COMPARE
+ + ext/SDBM_File/sdbm/Makefile.PL ext/SDBM_File/sdbm/README
+ + ext/SDBM_File/sdbm/README.too ext/SDBM_File/sdbm/biblio
+ + ext/SDBM_File/sdbm/dba.c ext/SDBM_File/sdbm/dbd.c
+ + ext/SDBM_File/sdbm/dbe.1 ext/SDBM_File/sdbm/dbe.c
+ + ext/SDBM_File/sdbm/dbm.c ext/SDBM_File/sdbm/dbm.h
+ + ext/SDBM_File/sdbm/dbu.c ext/SDBM_File/sdbm/grind
+ + ext/SDBM_File/sdbm/hash.c ext/SDBM_File/sdbm/linux.patches
+ + ext/SDBM_File/sdbm/makefile.sdbm ext/SDBM_File/sdbm/pair.c
+ + ext/SDBM_File/sdbm/pair.h ext/SDBM_File/sdbm/readme.ms
+ + ext/SDBM_File/sdbm/readme.ps ext/SDBM_File/sdbm/sdbm.3
+ + ext/SDBM_File/sdbm/sdbm.c ext/SDBM_File/sdbm/sdbm.h
+ + ext/SDBM_File/sdbm/tune.h ext/SDBM_File/sdbm/util.c
+ + ext/SDBM_File/typemap ext/Safe/Makefile.PL ext/Safe/Safe.pm
+ + ext/Safe/Safe.xs ext/Socket/Makefile.PL ext/Socket/Socket.pm
+ + ext/Socket/Socket.xs ext/util/extliblist ext/util/make_ext
+ + ext/util/mkbootstrap form.h global.sym globals.c gv.c gv.h
+ + h2pl/README h2pl/cbreak.pl h2pl/cbreak2.pl h2pl/eg/sizeof.ph
+ + h2pl/eg/sys/errno.pl h2pl/eg/sys/ioctl.pl h2pl/eg/sysexits.pl
+ + h2pl/getioctlsizes h2pl/mksizes h2pl/mkvars h2pl/tcbreak
+ + h2pl/tcbreak2 handy.h hints/3b1.sh hints/3b1cc
+ + hints/README.hints hints/aix.sh hints/altos486.sh
+ + hints/apollo.sh hints/aux.sh hints/bsdos.sh hints/convexos.sh
+ + hints/cxux.sh hints/dec_osf.sh hints/dgux.sh hints/dnix.sh
+ + hints/dynix.sh hints/dynixptx.sh hints/epix.sh hints/esix4.sh
+ + hints/fps.sh hints/freebsd.sh hints/genix.sh
+ + hints/greenhills.sh hints/hpux.sh hints/i386.sh
+ + hints/irix_4.sh hints/irix_5.sh hints/irix_6.sh
+ + hints/irix_6_2.sh hints/isc.sh hints/isc_2.sh hints/linux.sh
+ + hints/machten.sh hints/machten_2.sh hints/mips.sh hints/mpc.sh
+ + hints/mpeix.sh hints/ncr_tower.sh hints/netbsd.sh
+ + hints/next_3.sh hints/next_3_0.sh hints/opus.sh hints/os2.sh
+ + hints/powerux.sh hints/sco.sh hints/sco_2_3_0.sh
+ + hints/sco_2_3_1.sh hints/sco_2_3_2.sh hints/sco_2_3_3.sh
+ + hints/sco_2_3_4.sh hints/solaris_2.sh hints/stellar.sh
+ + hints/sunos_4_0.sh hints/sunos_4_1.sh hints/svr4.sh
+ + hints/ti1500.sh hints/titanos.sh hints/ultrix_4.sh
+ + hints/unicos.sh hints/unisysdynix.sh hints/utekv.sh
+ + hints/uts.sh hv.c hv.h installman installperl interp.sym
+ + keywords.h keywords.pl lib/AnyDBM_File.pm lib/AutoLoader.pm
+ + lib/AutoSplit.pm lib/Benchmark.pm lib/Carp.pm lib/Cwd.pm
+ + lib/Devel/SelfStubber.pm lib/DirHandle.pm lib/English.pm
+ + lib/Env.pm lib/Exporter.pm lib/ExtUtils/Install.pm
+ + lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_OS2.pm
+ + lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_VMS.pm
+ + lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Manifest.pm
+ + lib/ExtUtils/Mkbootstrap.pm lib/ExtUtils/Mksymlists.pm
+ + lib/ExtUtils/testlib.pm lib/ExtUtils/typemap
+ + lib/ExtUtils/xsubpp lib/File/Basename.pm lib/File/CheckTree.pm
+ + lib/File/Copy.pm lib/File/Find.pm lib/File/Path.pm
+ + lib/FileCache.pm lib/Getopt/Long.pm lib/Getopt/Std.pm
+ + lib/I18N/Collate.pm lib/IPC/Open2.pm lib/IPC/Open3.pm
+ + lib/Math/BigFloat.pm lib/Math/BigInt.pm lib/Math/Complex.pm
+ + lib/Net/Ping.pm lib/Pod/Functions.pm lib/Pod/Text.pm
+ + lib/Search/Dict.pm lib/SelectSaver.pm lib/SelfLoader.pm
+ + lib/Shell.pm lib/Symbol.pm lib/Sys/Hostname.pm
+ + lib/Sys/Syslog.pm lib/Term/Cap.pm lib/Term/Complete.pm
+ + lib/Term/ReadLine.pm lib/Test/Harness.pm lib/Text/Abbrev.pm
+ + lib/Text/ParseWords.pm lib/Text/Soundex.pm lib/Text/Tabs.pm
+ + lib/Text/Wrap.pm lib/Tie/Hash.pm lib/Tie/Scalar.pm
+ + lib/Tie/SubstrHash.pm lib/Time/Local.pm lib/abbrev.pl
+ + lib/assert.pl lib/bigfloat.pl lib/bigint.pl lib/bigrat.pl
+ + lib/cacheout.pl lib/chat2.inter lib/chat2.pl lib/complete.pl
+ + lib/ctime.pl lib/diagnostics.pm lib/dotsh.pl lib/dumpvar.pl
+ + lib/exceptions.pl lib/fastcwd.pl lib/find.pl lib/finddepth.pl
+ + lib/flush.pl lib/ftp.pl lib/getcwd.pl lib/getopt.pl
+ + lib/getopts.pl lib/hostname.pl lib/importenv.pl lib/integer.pm
+ + lib/less.pm lib/lib.pm lib/look.pl lib/newgetopt.pl
+ + lib/open2.pl lib/open3.pl lib/overload.pm lib/perl5db.pl
+ + lib/pwd.pl lib/shellwords.pl lib/sigtrap.pm lib/splain
+ + lib/stat.pl lib/strict.pm lib/subs.pm lib/syslog.pl
+ + lib/tainted.pl lib/termcap.pl lib/timelocal.pl lib/validate.pl
+ + lib/vars.pm makeaperl.SH makedepend.SH makedir.SH malloc.c
+ + mg.c mg.h minimod.pl miniperlmain.c mv-if-diff myconfig op.c
+ + op.h opcode.h opcode.pl os2/Makefile.SHs os2/POSIX.mkfifo
+ + os2/README os2/README.old os2/diff.configure os2/diff.db_file
+ + os2/notes os2/os2.c os2/os2ish.h os2/perl2cmd.pl patchlevel.h
+ + perl.c perl.h perl_exp.SH perlsh perly.c perly.c.diff
+ + perly.fixer perly.h perly.y pod/Makefile pod/buildtoc
+ + pod/perl.pod pod/perlbook.pod pod/perlbot.pod pod/perlcall.pod
+ + pod/perldata.pod pod/perldebug.pod pod/perldiag.pod
+ + pod/perldsc.pod pod/perlembed.pod pod/perlform.pod
+ + pod/perlfunc.pod pod/perlguts.pod pod/perlipc.pod
+ + pod/perllol.pod pod/perlmod.pod pod/perlobj.pod pod/perlop.pod
+ + pod/perlovl.pod pod/perlpod.pod pod/perlre.pod pod/perlref.pod
+ + pod/perlrun.pod pod/perlsec.pod pod/perlstyle.pod
+ + pod/perlsub.pod pod/perlsyn.pod pod/perltie.pod
+ + pod/perltoc.pod pod/perltrap.pod pod/perlvar.pod
+ + pod/perlxs.pod pod/perlxstut.pod pod/pod2html.PL
+ + pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL pod/roffitall
+ + pod/splitman pod/splitpod pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c
+ + proto.h regcomp.c regcomp.h regexec.c regexp.h run.c scope.c
+ + scope.h sv.c sv.h t/README t/TEST t/base/cond.t t/base/if.t
+ + t/base/lex.t t/base/pat.t t/base/term.t t/cmd/elsif.t
+ + t/cmd/for.t t/cmd/mod.t t/cmd/subval.t t/cmd/switch.t
+ + t/cmd/while.t t/comp/cmdopt.t t/comp/cpp.aux t/comp/cpp.t
+ + t/comp/decl.t t/comp/multiline.t t/comp/package.t
+ + t/comp/script.t t/comp/term.t t/harness t/io/argv.t t/io/dup.t
+ + t/io/fs.t t/io/inplace.t t/io/pipe.t t/io/print.t t/io/tell.t
+ + t/lib/anydbm.t t/lib/bigint.t t/lib/bigintpm.t
+ + t/lib/db-btree.t t/lib/db-hash.t t/lib/db-recno.t
+ + t/lib/dirhand.t t/lib/english.t t/lib/filehand.t t/lib/gdbm.t
+ + t/lib/ndbm.t t/lib/odbm.t t/lib/posix.t t/lib/safe.t
+ + t/lib/sdbm.t t/lib/socket.t t/lib/soundex.t t/op/append.t
+ + t/op/array.t t/op/auto.t t/op/chop.t t/op/cond.t t/op/delete.t
+ + t/op/do.t t/op/each.t t/op/eval.t t/op/exec.t t/op/exp.t
+ + t/op/flip.t t/op/fork.t t/op/glob.t t/op/goto.t t/op/groups.t
+ + t/op/index.t t/op/int.t t/op/join.t t/op/list.t t/op/local.t
+ + t/op/magic.t t/op/misc.t t/op/mkdir.t t/op/my.t t/op/oct.t
+ + t/op/ord.t t/op/overload.t t/op/pack.t t/op/pat.t t/op/push.t
+ + t/op/quotemeta.t t/op/rand.t t/op/range.t t/op/re_tests
+ + t/op/read.t t/op/readdir.t t/op/ref.t t/op/regexp.t
+ + t/op/repeat.t t/op/sleep.t t/op/sort.t t/op/split.t
+ + t/op/sprintf.t t/op/stat.t t/op/study.t t/op/subst.t
+ + t/op/substr.t t/op/time.t t/op/undef.t t/op/unshift.t
+ + t/op/vec.t t/op/write.t t/re_tests taint.c toke.c unixish.h
+ + util.c util.h utils/Makefile utils/c2ph.PL utils/h2ph.PL
+ + utils/h2xs.PL utils/perlbug.PL utils/perldoc.PL utils/pl2pm.PL
+ + vms/Makefile vms/config.vms vms/descrip.mms
+ + vms/ext/Filespec.pm vms/ext/Stdio/0README.txt
+ + vms/ext/Stdio/Makefile.PL vms/ext/Stdio/Stdio.pm
+ + vms/ext/Stdio/Stdio.xs vms/ext/Stdio/test.pl vms/fndvers.com
+ + vms/gen_shrfls.pl vms/genconfig.pl vms/genopt.com
+ + vms/make_command.com vms/mms2make.pl vms/myconfig.com
+ + vms/perlvms.pod vms/perly_c.vms vms/perly_h.vms
+ + vms/sockadapt.c vms/sockadapt.h vms/test.com vms/vms.c
+ + vms/vms_yfix.pl vms/vmsish.h vms/writemain.pl writemain.SH
+ + x2p/EXTERN.h x2p/INTERN.h x2p/Makefile.SH x2p/a2p.c x2p/a2p.h
+ + x2p/a2p.man x2p/a2p.y x2p/a2py.c x2p/cflags.SH
+ + x2p/find2perl.PL x2p/handy.h x2p/hash.c x2p/hash.h x2p/s2p.PL
+ + x2p/s2p.man x2p/str.c x2p/str.h x2p/util.c x2p/util.h
+ + x2p/walk.c
diff --git a/contrib/perl5/Changes5.000 b/contrib/perl5/Changes5.000
new file mode 100644
index 000000000000..78cab26f14c8
--- /dev/null
+++ b/contrib/perl5/Changes5.000
@@ -0,0 +1,185 @@
+-------------
+Version 5.000
+-------------
+
+New things
+----------
+ The -w switch is much more informative.
+
+ References. See t/op/ref.t for examples. All entities in Perl 5 are
+ reference counted so that it knows when each item should be destroyed.
+
+ Objects. See t/op/ref.t for examples.
+
+ => is now a synonym for comma. This is useful as documentation for
+ arguments that come in pairs, such as initializers for associative arrays,
+ or named arguments to a subroutine.
+
+ All functions have been turned into list operators or unary operators,
+ meaning the parens are optional. Even subroutines may be called as
+ list operators if they've already been declared.
+
+ More embeddible. See main.c and embed_h.sh. Multiple interpreters
+ in the same process are supported (though not with interleaved
+ execution yet).
+
+ The interpreter is now flattened out. Compare Perl 4's eval.c with
+ the perl 5's pp.c. Compare Perl 4's 900 line interpreter loop in cmd.c
+ with Perl 5's 1 line interpreter loop in run.c. Eventually we'll make
+ everything non-blocking so we can interface nicely with a scheduler.
+
+ eval is now treated more like a subroutine call. Among other things,
+ this means you can return from it.
+
+ Format value lists may be spread over multiple lines by enclosing in
+ a do {} block.
+
+ You may now define BEGIN and END subroutines for each package. The BEGIN
+ subroutine executes the moment it's parsed. The END subroutine executes
+ just before exiting.
+
+ Flags on the #! line are interpreted even if the script wasn't
+ executed directly. (And even if the script was located by "perl -x"!)
+
+ The ?: operator is now legal as an lvalue.
+
+ List context now propagates to the right side of && and ||, as well
+ as the 2nd and 3rd arguments to ?:.
+
+ The "defined" function can now take a general expression.
+
+ Lexical scoping available via "my". eval can see the current lexical
+ variables.
+
+ The preferred package delimiter is now :: rather than '.
+
+ tie/untie are now preferred to dbmopen/dbmclose. Multiple DBM
+ implementations are allowed in the same executable, so you can
+ write scripts to interchange data among different formats.
+
+ New "and" and "or" operators work just like && and || but with
+ a precedence lower than comma, so they work better with list operators.
+
+ New functions include: abs(), chr(), uc(), ucfirst(), lc(), lcfirst(),
+ chomp(), glob()
+
+ require with a number checks to see that the version of Perl that is
+ currently running is at least that number.
+
+ Dynamic loading of external modules is now supported.
+
+ There is a new quote form qw//, which is equivalent to split(' ', q//).
+
+ Assignment of a reference to a glob value now just replaces the
+ single element of the glob corresponding to the reference type:
+ *foo = \$bar, *foo = \&bletch;
+
+ Filehandle methods are now supported:
+ output_autoflush STDOUT 1;
+
+ There is now an "English" module that provides human readable translations
+ for cryptic variable names.
+
+ Autoload stubs can now call the replacement subroutine with goto &realsub.
+
+ Subroutines can be defined lazily in any package by declaring an AUTOLOAD
+ routine, which will be called if a non-existent subroutine is called in
+ that package.
+
+ Several previously added features have been subsumed under the new
+ keywords "use" and "no". Saying "use Module LIST" is short for
+ BEGIN { require Module; import Module LIST; }
+ The "no" keyword is identical except that it calls "unimport" instead.
+ The earlier pragma mechanism now uses this mechanism, and two new
+ modules have been added to the library to implement "use integer"
+ and variations of "use strict vars, refs, subs".
+
+ Variables may now be interpolated literally into a pattern by prefixing
+ them with \Q, which works just like \U, but backwhacks non-alphanumerics
+ instead. There is also a corresponding quotemeta function.
+
+ Any quantifier in a regular expression may now be followed by a ? to
+ indicate that the pattern is supposed to match as little as possible.
+
+ Pattern matches may now be followed by an m or s modifier to explicitly
+ request multiline or singleline semantics. An s modifier makes . match
+ newline.
+
+ Patterns may now contain \A to match only at the beginning of the string,
+ and \Z to match only at the end. These differ from ^ and $ in that
+ they ignore multiline semantics. In addition, \G matches where the
+ last interation of m//g or s///g left off.
+
+ Non-backreference-producing parens of various sorts may now be
+ indicated by placing a ? directly after the opening parenthesis,
+ followed by a character that indicates the purpose of the parens.
+ An :, for instance, indicates simple grouping. (?:a|b|c) will
+ match any of a, b or c without producing a backreference. It does
+ "eat" the input. There are also assertions which do not eat the
+ input but do lookahead for you. (?=stuff) indicates that the next
+ thing must be "stuff". (?!nonsense) indicates that the next thing
+ must not be "nonsense".
+
+ The negation operator now treats non-numeric strings specially.
+ A -"text" is turned into "-text", so that -bareword is the same
+ as "-bareword". If the string already begins with a + or -, it
+ is flipped to the other sign.
+
+Incompatibilities
+-----------------
+ @ now always interpolates an array in double-quotish strings. Some programs
+ may now need to use backslash to protect any @ that shouldn't interpolate.
+
+ Ordinary variables starting with underscore are no longer forced into
+ package main.
+
+ s'$lhs'$rhs' now does no interpolation on either side. It used to
+ interplolate $lhs but not $rhs.
+
+ The second and third arguments of splice are now evaluated in scalar
+ context (like the book says) rather than list context.
+
+ Saying "shift @foo + 20" is now a semantic error because of precedence.
+
+ "open FOO || die" is now incorrect. You need parens around the filehandle.
+
+ The elements of argument lists for formats are now evaluated in list
+ context. This means you can interpolate list values now.
+
+ You can't do a goto into a block that is optimized away. Darn.
+
+ It is no longer syntactically legal to use whitespace as the name
+ of a variable, or as a delimiter for any kind of quote construct.
+
+ Some error messages will be different.
+
+ The caller function now returns a false value in a scalar context if there
+ is no caller. This lets library files determine if they're being required.
+
+ m//g now attaches its state to the searched string rather than the
+ regular expression.
+
+ "reverse" is no longer allowed as the name of a sort subroutine.
+
+ taintperl is no longer a separate executable. There is now a -T
+ switch to turn on tainting when it isn't turned on automatically.
+
+ Symbols starting with _ are no longer forced into package main, except
+ for $_ itself (and @_, etc.).
+
+ Double-quoted strings may no longer end with an unescaped $ or @.
+
+ Negative array subscripts now count from the end of the array.
+
+ The comma operator in a scalar context is now guaranteed to give a
+ scalar context to its arguments.
+
+ The ** operator now binds more tightly than unary minus.
+
+ Setting $#array lower now discards array elements so that destructors
+ work reasonably.
+
+ delete is not guaranteed to return the old value for tied arrays,
+ since this capability may be onerous for some modules to implement.
+
+ Attempts to set $1 through $9 now result in a run-time error.
diff --git a/contrib/perl5/Changes5.001 b/contrib/perl5/Changes5.001
new file mode 100644
index 000000000000..c26134a79aac
--- /dev/null
+++ b/contrib/perl5/Changes5.001
@@ -0,0 +1,1299 @@
+-------------
+Version 5.001
+-------------
+
+Nearly all the changes for 5.001 were bug fixes of one variety or another,
+so here's the bug list, along with the "resolution" for each of them. If
+you wish to correspond about any of them, please include the bug number.
+
+There were a few that can be construed as enhancements:
+ NETaa13059: now warns of use of \1 where $1 is necessary.
+ NETaa13512: added $SIG{__WARN__} and $SIG{__DIE__} hooks
+ NETaa13520: added closures
+ NETaa13530: scalar keys now resets hash iterator
+ NETaa13641: added Tim's fancy new import whizbangers
+ NETaa13710: cryptswitch needed to be more "useable"
+ NETaa13716: Carp now allows multiple packages to be skipped out of
+ NETaa13716: now counts imported routines as "defined" for redef warnings
+ (and, of course, much of the stuff from the perl5-porters)
+
+NETaa12974: README incorrectly said it was a pre-release.
+Files patched: README
+
+NETaa13033: goto pushed a bogus scope on the context stack.
+From: Steve Vinoski
+Files patched: pp_ctl.c
+ The goto operator pushed an extra bogus scope onto the context stack. (This
+ often didn't matter, since many things pop extra unrecognized scopes off.)
+
+NETaa13034: tried to get valid pointer from undef.
+From: Castor Fu
+Also: Achille Hui, the Day Dreamer
+Also: Eric Arnold
+Files patched: pp_sys.c
+ Now treats undef specially, and calls SvPV_force on any non-numeric scalar
+ value to get a real pointer to somewhere.
+
+NETaa13035: included package info with filehandles.
+From: Jack Shirazi - BIU
+Files patched: pp_hot.c pp_sys.c
+ Now passes a glob to filehandle methods to keep the package info intact.
+
+NETaa13048: didn't give strict vars message on every occurrence.
+From: Doug Campbell
+Files patched: gv.c
+ It now complains about every occurrence. (The bug resulted from an
+ ill-conceived attempt to suppress a duplicate error message in a
+ suboptimal fashion.)
+
+NETaa13052: test for numeric sort sub return value fooled by taint magic.
+From: Peter Jaspers-Fayer
+Files patched: pp_ctl.c sv.h
+ The test to see if the sort sub return value was numeric looked at the
+ public flags rather than the private flags of the SV, so taint magic
+ hid that info from the sort.
+
+NETaa13053: forced a2p to use byacc
+From: Andy Dougherty
+Files patched: MANIFEST x2p/Makefile.SH x2p/a2p.c
+ a2p.c is now pre-byacced and shipped with the kit.
+
+NETaa13055: misnamed constant in previous patch.
+From: Conrad Augustin
+Files patched: op.c op.h toke.c
+ The tokener translates $[ to a constant, but with a special marking in case
+ the constant gets assigned to or localized. Unfortunately, the marking
+ was done with a combination of OPf_SPECIAL and OPf_MOD that was easily
+ spoofed. There is now a private OPpCONST_ARYLEN flag for this purpose.
+
+NETaa13055: use of OPf_SPECIAL for $[ lvaluehood was too fragile.
+Files patched: op.c op.h toke.c
+ (same)
+
+NETaa13056: convert needs to throw away any number info on its list.
+From: Jack Shirazi - BIU
+Files patched: op.c
+ The listiness of the argument list leaked out to the subroutine call because
+ of how prepend_elem and append_elem reuse an existing list. The convert()
+ routine just needs to discard any listiness it finds on its argument.
+
+NETaa13058: AUTOLOAD shouldn't assume size of @_ is meaningful.
+From: Florent Guillaume
+Files patched: ext/DB_File/DB_File.pm ext/Fcntl/Fcntl.pm ext/GDBM_File/GDBM_File.pm ext/Socket/Socket.pm h2xs.SH
+ I just deleted the optimization, which is silly anyway since the eventual
+ subroutine definition is cached.
+
+NETaa13059: now warns of use of \1 where $1 is necessary.
+From: Gustaf Neumann
+Files patched: toke.c
+ Now says
+
+ Can't use \1 to mean $1 in expression at foo line 2
+
+ along with an explanation in perldiag.
+
+NETaa13060: no longer warns on attempt to read <> operator's transition state.
+From: Chaim Frenkel
+Files patched: pp_hot.c
+ No longer warns on <> operator's transitional state.
+
+NETaa13140: warning said $ when @ would be more appropriate.
+From: David J. MacKenzie
+Files patched: op.c pod/perldiag.pod
+ Now says
+
+ (Did you mean $ or @ instead of %?)
+
+ and added more explanation to perldiag.
+
+NETaa13149: was reading freed memory to make incorrect error message.
+Files patched: pp_ctl.c
+ It was reading freed memory to make an error message that would be
+ incorrect in any event because it had the inner filename rather than
+ the outer.
+
+NETaa13149: confess was sometimes less informative than croak
+From: Jack Shirazi
+Files patched: lib/Carp.pm
+ (same)
+
+NETaa13150: stderr needs to be STDERR in package
+From: Jack Shirazi
+Files patched: lib/File/CheckTree.pm
+ Also fixed pl2pm to translate the filehandles to uppercase.
+
+NETaa13150: uppercases stdin, stdout and stderr
+Files patched: pl2pm
+ (same)
+
+NETaa13154: array assignment didn't notice package magic.
+From: Brian Reichert
+Files patched: pp_hot.c
+ The list assignment operator looked for only set magic, but set magic is
+ only on the elements of a magical hash, not on the hash as a whole. I made
+ the operator look for any magic at all on the target array or hash.
+
+NETaa13155: &DB::DB left trash on the stack.
+From: Thomas Koenig
+Files patched: lib/perl5db.pl pp_ctl.c
+ The call by pp_dbstate() to &DB::DB left trash on the stack. It now
+ calls DB in list context, and DB returns ().
+
+NETaa13156: lexical variables didn't show up in debugger evals.
+From: Joergen Haegg
+Files patched: op.c
+ The code that searched back up the context stack for the lexical scope
+ outside the eval only partially took into consideration that there
+ might be extra debugger subroutine frames that shouldn't be used, and
+ ended up comparing the wrong statement sequence number to the range of
+ valid sequence numbers for the scope of the lexical variable. (There
+ was also a bug fixed in passing that caused the scope of lexical to go
+ clear to the end of the subroutine even if it was within an inner block.)
+
+NETaa13157: any request for autoloaded DESTROY should create a null one.
+From: Tom Christiansen
+Files patched: lib/AutoLoader.pm
+ If DESTROY.al is not located, it now creates sub DESTROY {} automatically.
+
+NETaa13158: now preserves $@ around destructors while leaving eval.
+From: Tim Bunce
+Files patched: pp_ctl.c
+ Applied supplied patch, except the whole second hunk can be replaced with
+
+ sv_insert(errsv, 0, 0, message, strlen(message));
+
+NETaa13160: clarified behavior of split without arguments
+From: Harry Edmon
+Files patched: pod/perlfunc.pod
+ Clarified the behavior of split without arguments.
+
+NETaa13162: eval {} lost list/scalar context
+From: Dov Grobgeld
+Files patched: op.c
+ LEAVETRY didn't propagate number to ENTERTRY.
+
+NETaa13163: clarified documentation of foreach using my variable
+From: Tom Christiansen
+Files patched: pod/perlsyn.pod
+ Explained that foreach using a lexical is still localized.
+
+NETaa13164: the dot detector for the end of formats was over-rambunctious.
+From: John Stoffel
+Files patched: toke.c
+ The dot detector for the end of formats was over-rambunctious. It would
+ pick up any dot that didn't have a space in front of it.
+
+NETaa13165: do {} while 1 never linked outer block into next chain.
+From: Gisle Aas
+Files patched: op.c
+ When the conditional of do {} while 1; was optimized away, it confused the
+ postfix order construction so that the block that ordinarily sits around the
+ whole loop was never executed. So when the loop tried to unstack between
+ iterations, it got the wrong context, and blew away the lexical variables
+ of the outer scope. Fixed it by introducing a NULL opcode that will be
+ optimized away later.
+
+NETaa13167: coercion was looking at public bits rather than private bits.
+From: Randal L. Schwartz
+Also: Thomas Riechmann
+Also: Shane Castle
+Files patched: sv.c
+ There were some bad ifdefs around the various varieties of set*id(). In
+ addition, tainting was interacting badly with assignment to $> because
+ sv_2iv() was examining SvPOK rather than SvPOKp, and so couldn't coerce
+ a string uid to an integer one.
+
+NETaa13167: had some ifdefs wrong on set*id.
+Files patched: mg.c pp_hot.c
+ (same)
+
+NETaa13168: relaxed test for comparison of new and old fds
+From: Casper H.S. Dik
+Files patched: t/lib/posix.t
+ I relaxed the comparison to just check that the new fd is greater.
+
+NETaa13169: autoincrement can corrupt scalar value state.
+From: Gisle Aas
+Also: Tom Christiansen
+Files patched: sv.c
+ It assumed a PV didn't need to be upgraded to become an NV.
+
+NETaa13169: previous patch could leak a string pointer.
+Files patched: sv.c
+ (same)
+
+NETaa13170: symbols missing from global.sym
+From: Tim Bunce
+Files patched: global.sym
+ Applied suggested patch.
+
+NETaa13171: \\ in <<'END' shouldn't reduce to \.
+From: Randal L. Schwartz
+Files patched: toke.c
+ <<'END' needed to bypass ordinary single-quote processing.
+
+NETaa13172: 'use integer' turned off magical autoincrement.
+From: Erich Rickheit KSC
+Files patched: pp.c pp_hot.c
+ The integer versions of the increment and decrement operators were trying too
+ hard to be efficient.
+
+NETaa13172: deleted duplicate increment and decrement code
+Files patched: opcode.h opcode.pl pp.c
+ (same)
+
+NETaa13173: install should make shared libraries executable.
+From: Brian Grossman
+Also: Dave Nadler
+Also: Eero Pajarre
+Files patched: installperl
+ Now gives permission 555 to any file ending with extension specified by $dlext.
+
+NETaa13176: ck_rvconst didn't free the const it used up.
+From: Nick Duffek
+Files patched: op.c
+ I checked in many random memory leaks under this bug number, since it
+ was an eval that brought many of them out.
+
+NETaa13176: didn't delete XRV for temp ref of destructor.
+Files patched: sv.c
+ (same)
+
+NETaa13176: didn't delete op_pmshort in matching operators.
+Files patched: op.c
+ (same)
+
+NETaa13176: eval leaked the name of the eval.
+Files patched: scope.c
+ (same)
+
+NETaa13176: gp_free didn't free the format.
+Files patched: gv.c
+ (same)
+
+NETaa13176: minor leaks in loop exits and constant subscript optimization.
+Files patched: op.c
+ (same)
+
+NETaa13176: plugged some duplicate struct allocation memory leaks.
+Files patched: perl.c
+ (same)
+
+NETaa13176: sv_clear of an FM didn't clear anything.
+Files patched: sv.c
+ (same)
+
+NETaa13176: tr/// didn't mortalize its return value.
+Files patched: pp.c
+ (same)
+
+NETaa13177: SCOPE optimization hid line number info
+From: David J. MacKenzie
+Also: Hallvard B Furuseth
+Files patched: op.c
+ Every pass on the syntax tree has to keep track of the current statement.
+ Unfortunately, the single-statement block was optimized into a single
+ statement between the time the variable was parsed and the time the
+ void code scan was done, so that pass didn't see the OP_NEXTSTATE
+ operator, because it has been optimized to an OP_NULL.
+
+ Fortunately, null operands remember what they were, so it was pretty easy
+ to make it set the correct line number anyway.
+
+NETaa13178: some linux doesn't handle nm well
+From: Alan Modra
+Files patched: hints/linux.sh
+ Applied supplied patch.
+
+NETaa13180: localized slice now pre-extends array
+From: Larry Schuler
+Files patched: pp.c
+ A localized slice now pre-extends its array to avoid reallocation during
+ the scope of the local.
+
+NETaa13181: m//g didn't keep track of whether previous match matched null.
+From: "philippe.verdret"
+Files patched: mg.h pp_hot.c
+ A pattern isn't allowed to match a null string in the same place twice in
+ a row. m//g wasn't keeping track of whether the previous match matched
+ the null string.
+
+NETaa13182: now includes whitespace as a regexp metacharacter.
+From: Larry Wall
+Files patched: toke.c
+ scan_const() now counts " \t\n\r\f\v" as metacharacters when scanning a pattern.
+
+NETaa13183: sv_setsv shouldn't try to clone an object.
+From: Peter Gordon
+Files patched: sv.c
+ The sv_mortalcopy() done by the return in STORE called sv_setsv(),
+ which cloned the object. sv_setsv() shouldn't be in the business of
+ cloning objects.
+
+NETaa13184: bogus warning on quoted signal handler name removed.
+From: Dan Carson
+Files patched: toke.c
+ Now doesn't complain unless the first non-whitespace character after the =
+ is an alphabetic character.
+
+NETaa13186: now croaks on chop($')
+From: Casper H.S. Dik
+Files patched: doop.c
+ Now croaks on chop($') and such.
+
+NETaa13187: "${foo::bar}" now counts as mere delimitation, not as a bareword.
+From: Jay Rogers
+Files patched: toke.c
+ "${foo::bar}" now counts as mere delimitation, not as a bareword inside a
+ reference block.
+
+NETaa13188: for backward compatibility, looks for "perl -" before "perl".
+From: Russell Mosemann
+Files patched: toke.c
+ Now allows non-whitespace characters on the #! line between the "perl"
+ and the "-".
+
+NETaa13188: now allows non-whitespace after #!...perl before switches.
+Files patched: toke.c
+ (same)
+
+NETaa13189: derivative files need to be removed before recreation
+From: Simon Leinen
+Also: Dick Middleton
+Also: David J. MacKenzie
+Files patched: embed_h.sh x2p/Makefile.SH
+ Fixed various little nits as suggested in several messages.
+
+NETaa13190: certain assignments can spoof pod directive recognizer
+From: Ilya Zakharevich
+Files patched: toke.c
+ The lexer now only recognizes pod directives where a statement is expected.
+
+NETaa13194: now returns undef when there is no curpm.
+From: lusol@Dillon.CC.Lehigh.EDU
+Files patched: mg.c
+ Since there was no regexp prior to the "use", it was returning whatever the
+ last successful match was within the "use", because there was no current
+ regexp, so it treated it as a normal variable. It now returns undef.
+
+NETaa13195: semop had one S too many.
+From: Joachim Huober
+Files patched: opcode.pl
+ The entry in opcode.pl had one too many S's.
+
+NETaa13196: always assumes it's a Perl script if -c is used.
+From: Dan Carson
+Files patched: toke.c
+ It now will assume it's a Perl script if the -c switch is used.
+
+NETaa13197: changed implicit -> message to be more understandable.
+From: Bruce Barnett
+Files patched: op.c pod/perldiag.pod
+ I changed the error message to be more understandable. It now says
+
+ Can't use subscript on sort...
+
+
+NETaa13201: added OPpCONST_ENTERED flag to properly enter filehandle symbols.
+From: E. Jay Berkenbilt
+Also: Tom Christiansen
+Files patched: op.c op.h toke.c
+ The grammatical reduction of a print statement didn't properly count
+ the filehandle as a symbol reference because it couldn't distinguish
+ between a symbol entered earlier in the program and a symbol entered
+ for the first time down in the lexer.
+
+NETaa13203: README shouldn't mention uperl.o any more.
+From: Anno Siegel
+Files patched: README
+
+NETaa13204: .= shouldn't warn on uninitialized target.
+From: Pete Peterson
+Files patched: pp_hot.c
+ No longer warns on uninitialized target of .= operator.
+
+NETaa13206: handy macros in XSUB.h
+From: Tim Bunce
+Files patched: XSUB.h
+ Added suggested macros.
+
+NETaa13228: commonality checker didn't treat lexicals as variables.
+From: mcook@cognex.com
+Files patched: op.c opcode.pl
+ The list assignment operator tries to avoid unnecessary copies by doing the
+ assignment directly if there are no common variables on either side of the
+ equals. Unfortunately, the code that decided that only recognized references
+ to dynamic variables, not lexical variables.
+
+NETaa13229: fixed sign stuff for complement, integer coercion.
+From: Larry Wall
+Files patched: perl.h pp.c sv.c
+ Fixed ~0 and integer coercions.
+
+NETaa13230: no longer tries to reuse scratchpad temps if tainting in effect.
+From: Luca Fini
+Files patched: op.c
+ I haven't reproduced it, but I believe the problem is the reuse of scratchpad
+ temporaries between statements. I've made it not try to reuse them if
+ tainting is in effect.
+
+NETaa13231: *foo = *bar now prevents typo warnings on "foo"
+From: Robin Barker
+Files patched: sv.c
+ Aliasing of the form *foo = *bar is now protected from the typo warnings.
+ Previously only the *foo = \$bar form was.
+
+NETaa13235: require BAREWORD now introduces package name immediately.
+From: Larry Wall
+Files patched: toke.c
+ require BAREWORD now introduces package name immediately. This lets the
+ method intuit code work right even though the require hasn't actually run
+ yet.
+
+NETaa13289: didn't calculate correctly using arybase.
+From: Jared Rhine
+Files patched: pp.c pp_hot.c
+ The runtime code didn't use curcop->cop_arybase correctly.
+
+NETaa13301: store now throws exception on error
+From: Barry Friedman
+Files patched: ext/GDBM_File/GDBM_File.xs ext/NDBM_File/NDBM_File.xs ext/ODBM_File/ODBM_File.xs ext/SDBM_File/SDBM_File.xs
+ Changed warn to croak in ext/*DBM_File/*.xs.
+
+NETaa13302: ctime now takes Time_t rather than Time_t*.
+From: Rodger Anderson
+Files patched: ext/POSIX/POSIX.xs
+ Now declares a Time_t and takes the address of that in CODE.
+
+NETaa13302: shorter way to do this patch
+Files patched: ext/POSIX/POSIX.xs
+ (same)
+
+NETaa13304: could feed too large $@ back into croak, whereupon it croaked.
+From: Larry Wall
+Files patched: perl.c
+ callist() could feed $@ back into croak with more than a bare %s. (croak()
+ handles long strings with a bare %s okay.)
+
+NETaa13305: compiler misoptimized RHS to outside of s/a/print/e
+From: Brian S. Cashman <bsc@umich.edu>
+Files patched: op.c
+ The syntax tree was being misconstructed because the compiler felt that
+ the RHS was invariant, so it did it outside the s///.
+
+NETaa13314: assigning mortal to lexical leaks
+From: Larry Wall
+Files patched: sv.c
+ In stealing strings, sv_setsv was checking SvPOK to see if it should free
+ the destination string. It should have been checking SvPVX.
+
+NETaa13316: wait4pid now recalled when errno == EINTR
+From: Robert J. Pankratz
+Files patched: pp_sys.c util.c
+ system() and the close() of a piped open now recall wait4pid if it returned
+ prematurely with errno == EINTR.
+
+NETaa13329: needed to localize taint magic
+From: Brian Katzung
+Files patched: sv.c doio.c mg.c pp_hot.c pp_sys.c scope.c taint.c
+ Taint magic is now localized better, though I had to resort to a kludge
+ to allow a value to be both tainted and untainted simultaneously during
+ the assignment of
+
+ local $foo = $_[0];
+
+ when $_[0] is a reference to the variable $foo already.
+
+NETaa13341: clarified interaction of AnyDBM_File::ISA and "use"
+From: Ian Phillipps
+Files patched: pod/modpods/AnyDBMFile.pod
+ The doc was misleading.
+
+NETaa13342: grep and map with block would enter block but never leave it.
+From: Ian Phillipps
+Files patched: op.c
+ The compiler use some sort-checking code to handle the arguments of
+ grep and map. Unfortunately, this wiped out the block exit opcode while
+ leaving the block entry opcode. This doesn't matter to sort, but did
+ matter to grep and map. It now leave the block entry intact.
+
+ The reason it worked without the my is because the block entry and exit
+ were optimized away to an OP_SCOPE, which it doesn't matter if it's there
+ or not.
+
+NETaa13343: goto needed to longjmp when in a signal handler.
+From: Robert Partington
+Files patched: pp_ctl.c
+ goto needed to longjmp() when in a signal handler to get back into the
+ right run() context.
+
+
+NETaa13344: strict vars shouldn't apply to globs or filehandles.
+From: Andrew Wilcox
+Files patched: gv.c
+ Filehandles and globs will be excepted from "strict vars", so that you can
+ do the standard Perl 4 trick of
+
+ use strict;
+ sub foo {
+ local(*IN);
+ open(IN,"file");
+ }
+
+
+NETaa13345: assert.pl didn't use package DB
+From: Hans Mulder
+Files patched: lib/assert.pl
+ Now it does.
+
+NETaa13348: av_undef didn't free scalar representing $#foo.
+From: David Filo
+Files patched: av.c
+ av_undef didn't free scalar representing $#foo.
+
+NETaa13349: sort sub accumulated save stack entries
+From: David Filo
+Files patched: pp_ctl.c
+ COMMON only gets set if assigning to @_, which is reasonable. Most of the
+ problem was a memory leak.
+
+NETaa13351: didn't treat indirect filehandles as references.
+From: Andy Dougherty
+Files patched: op.c
+ Now produces
+
+ Can't use an undefined value as a symbol reference at ./foo line 3.
+
+
+NETaa13352: OP_SCOPE allocated as UNOP rather than LISTOP.
+From: Andy Dougherty
+Files patched: op.c
+
+NETaa13353: scope() didn't release filegv on OP_SCOPE optimization.
+From: Larry Wall
+Files patched: op.c
+ When scope() nulled out a NEXTSTATE, it didn't release its filegv reference.
+
+NETaa13355: hv_delete now avoids useless mortalcopy
+From: Larry Wall
+Files patched: hv.c op.c pp.c pp_ctl.c proto.h scope.c util.c
+ hv_delete now avoids useless mortalcopy.
+
+
+NETaa13359: comma operator section missing its heading
+From: Larry Wall
+Files patched: pod/perlop.pod
+
+NETaa13359: random typo
+Files patched: pod/perldiag.pod
+
+NETaa13360: code to handle partial vec values was bogus.
+From: Conrad Augustin
+Files patched: pp.c
+ The code that Mark J. added a long time ago to handle values that were partially
+ off the end of the string was incorrect.
+
+NETaa13361: made it not interpolate inside regexp comments
+From: Martin Jost
+Files patched: toke.c
+ To avoid surprising people, it no longer interpolates inside regexp
+ comments.
+
+NETaa13362: ${q[1]} should be interpreted like it used to
+From: Hans Mulder
+Files patched: toke.c
+ Now resolves ${keyword[1]} to $keyword[1] and warns if -w. Likewise for {}.
+
+NETaa13363: meaning of repeated search chars undocumented in tr///
+From: Stephen P. Potter
+Files patched: pod/perlop.pod
+ Documented that repeated characters use the first translation given.
+
+NETaa13365: if closedir fails, don't try it again.
+From: Frank Crawford
+Files patched: pp_sys.c
+ Now does not attempt to closedir a second time.
+
+NETaa13366: can't do block scope optimization on $1 et al when tainting.
+From: Andrew Vignaux
+Files patched: toke.c
+ The tainting mechanism assumes that every statement starts out
+ untainted. Unfortunately, the scope removal optimization for very
+ short blocks removed the statementhood of statements that were
+ attempting to read $1 as an untainted value, with the effect that $1
+ appeared to be tainted anyway. The optimization is now disabled when
+ tainting and the block contains $1 (or equivalent).
+
+NETaa13366: fixed this a better way in toke.c.
+Files patched: op.c
+ (same)
+
+NETaa13366: need to disable scope optimization when tainting.
+Files patched: op.c
+ (same)
+
+NETaa13367: Did a SvCUR_set without nulling out final char.
+From: "Rob Henderson" <robh@cs.indiana.edu>
+Files patched: doop.c pp.c pp_sys.c
+ When do_vop set the length on its result string it neglected to null-terminate
+ it.
+
+NETaa13368: bigrat::norm sometimes chucked sign
+From: Greg Kuperberg
+Files patched: lib/bigrat.pl
+ The normalization routine was assuming that the gcd of two numbers was
+ never negative, and based on that assumption managed to move the sign
+ to the denominator, where it was deleted on the assumption that the
+ denominator is always positive.
+
+NETaa13368: botched previous patch
+Files patched: lib/bigrat.pl
+ (same)
+
+NETaa13369: # is now a comment character, and \# should be left for regcomp.
+From: Simon Parsons
+Files patched: toke.c
+ It was not skipping the comment when it skipped the white space, and constructed
+ an opcode that tried to match a null string. Unfortunately, the previous
+ star tried to use the first character of the null string to optimize where
+ to recurse, so it never matched.
+
+NETaa13369: comment after regexp quantifier induced non-match.
+Files patched: regcomp.c
+ (same)
+
+NETaa13370: some code assumed SvCUR was of type int.
+From: Spider Boardman
+Files patched: pp_sys.c
+ Did something similar to the proposed patch. I also fixed the problem that
+ it assumed the type of SvCUR was int. And fixed get{peer,sock}name the
+ same way.
+
+NETaa13375: sometimes dontbother wasn't added back into strend.
+From: Jamshid Afshar
+Files patched: regexec.c
+ When the /g modifier was used, the regular expression code would calculate
+ the end of $' too short by the minimum number of characters the pattern could
+ match.
+
+NETaa13375: sv_setpvn now disallows negative length.
+Files patched: sv.c
+ (same)
+
+NETaa13376: suspected indirect objecthood prevented recognition of lexical.
+From: Gisle.Aas@nr.no
+Files patched: toke.c
+ When $data[0] is used in a spot that might be an indirect object, the lexer
+ was getting confused over the rule that says the $data in $$data[0] isn't
+ an array element. (The lexer uses XREF state for both indirect objects
+ and for variables used as names.)
+
+NETaa13377: -I processesing ate remainder of #! line.
+From: Darrell Schiebel
+Files patched: perl.c
+ I made the -I processing in moreswitches look for the end of the string,
+ delimited by whitespace.
+
+NETaa13379: ${foo} now treated the same outside quotes as inside
+From: Hans Mulder
+Files patched: toke.c
+ ${bareword} is now treated the same outside quotes as inside.
+
+NETaa13379: previous fix for this bug was botched
+Files patched: toke.c
+ (same)
+
+NETaa13381: TEST should check for perl link
+From: Andy Dougherty
+Files patched: t/TEST
+ die "You need to run \"make test\" first to set things up.\n" unless -e 'perl';
+
+
+NETaa13384: fixed version 0.000 botch.
+From: Larry Wall
+Files patched: installperl
+
+NETaa13385: return 0 from required file loses message
+From: Malcolm Beattie
+Files patched: pp_ctl.c
+ Works right now.
+
+NETaa13387: added pod2latex
+From: Taro KAWAGISHI
+Files patched: MANIFEST pod/pod2latex
+ Added most recent copy to pod directory.
+
+NETaa13388: constant folding now prefers integer results over double
+From: Ilya Zakharevich
+Files patched: op.c
+ Constant folding now prefers integer results over double.
+
+NETaa13389: now treats . and exec as shell metathingies
+From: Hans Mulder
+Files patched: doio.c
+ Now treats . and exec as shell metathingies.
+
+NETaa13395: eval didn't check taintedness.
+From: Larry Wall
+Files patched: pp_ctl.c
+
+NETaa13396: $^ coredumps at end of string
+From: Paul Rogers
+Files patched: toke.c
+ The scan_ident() didn't check for a null following $^.
+
+NETaa13397: improved error messages when operator expected
+From: Larry Wall
+Files patched: toke.c
+ Added message (Do you need to predeclare BAR?). Also fixed the missing
+ semicolon message.
+
+NETaa13399: cleanup by Andy
+From: Larry Wall
+Files patched: Changes Configure Makefile.SH README cflags.SH config.H config_h.SH deb.c doop.c dump.c ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs ext/DynaLoader/DynaLoader.pm ext/Fcntl/Fcntl.pm ext/GDBM_File/GDBM_File.pm ext/POSIX/POSIX.pm ext/SDBM_File/sdbm/sdbm.h ext/Socket/Socket.pm ext/util/make_ext h2xs.SH hints/aix.sh hints/bsd386.sh hints/dec_osf.sh hints/esix4.sh hints/freebsd.sh hints/irix_5.sh hints/next_3_2.sh hints/sunos_4_1.sh hints/svr4.sh hints/ultrix_4.sh installperl lib/AutoSplit.pm lib/Cwd.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/xsubpp lib/Term/Cap.pm mg.c miniperlmain.c perl.c perl.h perl_exp.SH pod/Makefile pod/perldiag.pod pod/pod2html pp.c pp_ctl.c pp_hot.c pp_sys.c proto.h sv.h t/re_tests util.c x2p/Makefile.SH x2p/a2p.h x2p/a2py.c x2p/handy.h x2p/hash.c x2p/hash.h x2p/str.c x2p/str.h x2p/util.c x2p/util.h x2p/walk.c
+
+NETaa13399: cleanup from Andy
+Files patched: MANIFEST
+
+NETaa13399: configuration cleanup
+Files patched: Configure Configure MANIFEST MANIFEST Makefile.SH Makefile.SH README config.H config.H config_h.SH config_h.SH configpm ext/DynaLoader/DynaLoader.pm ext/DynaLoader/dl_hpux.xs ext/NDBM_File/Makefile.PL ext/ODBM_File/Makefile.PL ext/util/make_ext handy.h hints/aix.sh hints/hpux_9.sh hints/hpux_9.sh hints/irix_4.sh hints/linux.sh hints/mpeix.sh hints/next_3_2.sh hints/solaris_2.sh hints/svr4.sh installperl installperl lib/AutoSplit.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/xsubpp lib/Getopt/Long.pm lib/Text/Tabs.pm makedepend.SH makedepend.SH mg.c op.c perl.h perl_exp.SH pod/perl.pod pod/perldiag.pod pod/perlsyn.pod pod/pod2man pp_sys.c proto.h proto.h unixish.h util.c util.c vms/config.vms writemain.SH x2p/a2p.h x2p/a2p.h x2p/a2py.c x2p/a2py.c x2p/handy.h x2p/util.c x2p/walk.c x2p/walk.c
+
+NETaa13399: new files from Andy
+Files patched: ext/DB_File/Makefile.PL ext/DynaLoader/Makefile.PL ext/Fcntl/Makefile.PL ext/GDBM_File/Makefile.PL ext/NDBM_File/Makefile.PL ext/ODBM_File/Makefile.PL ext/POSIX/Makefile.PL ext/SDBM_File/Makefile.PL ext/SDBM_File/sdbm/Makefile.PL ext/Socket/Makefile.PL globals.c hints/convexos.sh hints/irix_6.sh
+
+NETaa13399: patch0l from Andy
+Files patched: Configure MANIFEST Makefile.SH config.H config_h.SH ext/DB_File/Makefile.PL ext/GDBM_File/Makefile.PL ext/NDBM_File/Makefile.PL ext/POSIX/POSIX.xs ext/SDBM_File/sdbm/Makefile.PL ext/util/make_ext h2xs.SH hints/next_3_2.sh hints/solaris_2.sh hints/unicos.sh installperl lib/Cwd.pm lib/ExtUtils/MakeMaker.pm makeaperl.SH vms/config.vms x2p/util.c x2p/util.h
+
+NETaa13399: stuff from Andy
+Files patched: Configure MANIFEST Makefile.SH configpm hints/dec_osf.sh hints/linux.sh hints/machten.sh lib/ExtUtils/MakeMaker.pm util.c
+
+NETaa13399: Patch 0k from Andy
+Files patched: Configure MANIFEST Makefile.SH config.H config_h.SH hints/dec_osf.sh hints/mpeix.sh hints/next_3_0.sh hints/ultrix_4.sh installperl lib/ExtUtils/MakeMaker.pm lib/File/Path.pm makeaperl.SH minimod.PL perl.c proto.h vms/config.vms vms/ext/MM_VMS.pm x2p/a2p.h
+
+NETaa13399: Patch 0m from Andy
+Files patched: Configure MANIFEST Makefile.SH README config.H config_h.SH ext/DynaLoader/README ext/POSIX/POSIX.xs ext/SDBM_File/sdbm/sdbm.h ext/util/extliblist hints/cxux.sh hints/linux.sh hints/powerunix.sh lib/ExtUtils/MakeMaker.pm malloc.c perl.h pp_sys.c util.c
+
+NETaa13400: pod2html update from Bill Middleton
+From: Larry Wall
+Files patched: pod/pod2html
+
+NETaa13401: Boyer-Moore code attempts to compile string longer than 255.
+From: Kyriakos Georgiou
+Files patched: util.c
+ The Boyer-Moore table uses unsigned char offsets, but the BM compiler wasn't
+ rejecting strings longer than 255 chars, and was miscompiling them.
+
+NETaa13403: missing a $ on variable name
+From: Wayne Scott
+Files patched: installperl
+ Yup, it was missing.
+
+NETaa13406: didn't wipe out dead match when proceeding to next BRANCH
+From: Michael P. Clemens
+Files patched: regexec.c
+ The code to check alternatives didn't invalidate backreferences matched by the
+ failed branch.
+
+NETaa13407: overload upgrade
+From: owner-perl5-porters@nicoh.com
+Also: Ilya Zakharevich
+Files patched: MANIFEST gv.c lib/Math/BigInt.pm perl.h pod/perlovl.pod pp.c pp.h pp_hot.c sv.c t/lib/bigintpm.t t/op/overload.t
+ Applied supplied patch, and fixed bug induced by use of sv_setsv to do
+ a deep copy, since sv_setsv no longer copies objecthood.
+
+NETaa13409: sv_gets tries to grow string at EOF
+From: Harold O Morris
+Files patched: sv.c
+ Applied suggested patch, only two statements earlier, since the end code
+ also does SvCUR_set.
+
+NETaa13410: delaymagic did =~ instead of &= ~
+From: Andreas Schwab
+Files patched: pp_hot.c
+ Applied supplied patch.
+
+NETaa13411: POSIX didn't compile under -DLEAKTEST
+From: Frederic Chauveau
+Files patched: ext/POSIX/POSIX.xs
+ Used NEWSV instead of newSV.
+
+NETaa13412: new version from Tony Sanders
+From: Tony Sanders
+Files patched: lib/Term/Cap.pm
+ Installed as Term::Cap.pm
+
+NETaa13413: regmust extractor needed to restart loop on BRANCH for (?:) to work
+From: DESARMENIEN
+Files patched: regcomp.c
+ The BRANCH skipper should have restarted the loop from the top.
+
+NETaa13414: the check for accidental list context was done after pm_short check
+From: Michael H. Coen
+Files patched: pp_hot.c
+ Moved check for accidental list context to before the pm_short optimization.
+
+NETaa13418: perlre.pod babbled nonsense about | in character classes
+From: Philip Hazel
+Files patched: pod/perlre.pod
+ Removed bogus brackets. Now reads:
+ Note however that "|" is interpreted as a literal with square brackets,
+ so if you write C<[fee|fie|foe]> you're really only matching C<[feio|]>.
+
+NETaa13419: need to document introduction of lexical variables
+From: "Heading, Anthony"
+Files patched: pod/perlfunc.pod
+ Now mentions that lexicals aren't introduced till after the current statement.
+
+NETaa13420: formats that overflowed a page caused endless top of forms
+From: Hildo@CONSUL.NL
+Files patched: pp_sys.c
+ If a record is too large to fit on a page, it now prints whatever will
+ fit and then calls top of form again on the remainder.
+
+NETaa13423: the code to do negative list subscript in scalar context was missing
+From: Steve McDougall
+Files patched: pp.c
+ The negative subscript code worked right in list context but not in scalar
+ context. In fact, there wasn't code to do it in the scalar context.
+
+NETaa13424: existing but undefined CV blocked inheritance
+From: Spider Boardman
+Files patched: gv.c
+ Applied supplied patch.
+
+NETaa13425: removed extra argument to croak
+From: "R. Bernstein"
+Files patched: regcomp.c
+ Removed extra argument.
+
+NETaa13427: added return types
+From: "R. Bernstein"
+Files patched: x2p/a2py.c
+ Applied suggested patch.
+
+NETaa13427: added static declarations
+Files patched: x2p/walk.c
+ (same)
+
+NETaa13428: split was assuming that all backreferences were defined
+From: Dave Schweisguth
+Files patched: pp.c
+ split was assuming that all backreferences were defined.
+
+NETaa13430: hoistmust wasn't hoisting anchored shortcircuit's length
+From: Tom Christiansen
+Also: Rob Hooft
+Files patched: toke.c
+
+NETaa13432: couldn't call code ref under debugger
+From: Mike Fletcher
+Files patched: op.c pp_hot.c sv.h
+ The debugging code assumed it could remember a name to represent a subroutine,
+ but anonymous subroutines don't have a name. It now remembers a CV reference
+ in that case.
+
+NETaa13435: 1' dumped core
+From: Larry Wall
+Files patched: toke.c
+ Didn't check a pointer for nullness.
+
+NETaa13436: print foo(123) didn't treat foo as subroutine
+From: mcook@cognex.com
+Files patched: toke.c
+ Now treats it as a subroutine rather than a filehandle.
+
+NETaa13437: &$::foo didn't think $::foo was a variable name
+From: mcook@cognex.com
+Files patched: toke.c
+ Now treats $::foo as a global variable.
+
+NETaa13439: referred to old package name
+From: Tom Christiansen
+Files patched: lib/Sys/Syslog.pm
+ Wasn't a strict refs problem after all. It was simply referring to package
+ syslog, which had been renamed to Sys::Syslog.
+
+NETaa13440: stat operations didn't know what to do with glob or ref to glob
+From: mcook@cognex.com
+Files patched: doio.c pp_sys.c
+ Now knows about the kinds of filehandles returned by FileHandle constructors
+ and such.
+
+NETaa13442: couldn't find name of copy of deleted symbol table entry
+From: Spider Boardman
+Files patched: gv.c gv.h
+ I did a much simpler fix. When gp_free notices that it's freeing the
+ master GV, it nulls out gp_egv. The GvENAME and GvESTASH macros know
+ to revert to gv if egv is null.
+
+ This has the advantage of not creating a reference loop.
+
+NETaa13443: couldn't override an XSUB
+From: William Setzer
+Files patched: op.c
+ When the newSUB and newXS routines checked for whether the old sub was
+ defined, they only looked at CvROOT(cv), not CvXSUB(cv).
+
+NETaa13443: needed to do same thing in newXS
+Files patched: op.c
+ (same)
+
+NETaa13444: -foo now doesn't warn unless sub foo is defined
+From: Larry Wall
+Files patched: toke.c
+ Made it not warn on -foo, unless there is a sub foo defined.
+
+NETaa13451: in scalar context, pp_entersub now guarantees one item from XSUB
+From: Nick Gianniotis
+Files patched: pp_hot.c
+ The pp_entersub routine now guarantees that an XSUB in scalar context
+ returns one and only one value. If there are fewer, it pushes undef,
+ and if there are more, it returns the last one.
+
+NETaa13457: now explicitly disallows printf format with 'n' or '*'.
+From: lees@cps.msu.edu
+Files patched: doop.c
+ Now says
+
+ Use of n in printf format not supported at ./foo line 3.
+
+
+NETaa13458: needed to call SvPOK_only() in pp_substr
+From: Wayne Scott
+Files patched: pp.c
+ Needed to call SvPOK_only() in pp_substr.
+
+NETaa13459: umask and chmod now warn about missing initial 0 even with paren
+From: Andreas Koenig
+Files patched: toke.c
+ Now skips parens as well as whitespace looking for argument.
+
+NETaa13460: backtracking didn't work on .*? because reginput got clobbered
+From: Andreas Koenig
+Files patched: regexec.c
+ When .*? did a probe of the rest of the string, it clobbered reginput,
+ so the next call to match a . tried to match the newline and failed.
+
+NETaa13475: \(@ary) now treats array as list of scalars
+From: Tim Bunce
+Files patched: op.c
+ The mod() routine now refrains from marking @ary as an lvalue if it's in parens
+ and is the subject of an OP_REFGEN.
+
+NETaa13481: accept buffer wasn't aligned good enough
+From: Holger Bechtold
+Also: Christian Murphy
+Files patched: pp_sys.c
+ Applied suggested patch.
+
+NETaa13486: while (<>) now means while (defined($_ = <>))
+From: Jim Balter
+Files patched: op.c pod/perlop.pod
+ while (<HANDLE>) now means while (defined($_ = <HANDLE>)).
+
+NETaa13500: needed DESTROY in FileHandle
+From: Tim Bunce
+Files patched: ext/POSIX/POSIX.pm
+ Added DESTROY method. Also fixed ungensym to use POSIX:: instead of _POSIX.
+ Removed ungensym from close method, since DESTROY should do that now.
+
+NETaa13502: now complains if you use local on a lexical variable
+From: Larry Wall
+Files patched: op.c
+ Now says something like
+
+ Can't localize lexical variable $var at ./try line 6.
+
+NETaa13512: added $SIG{__WARN__} and $SIG{__DIE__} hooks
+From: Larry Wall
+Files patched: embed.h gv.c interp.sym mg.c perl.h pod/perlvar.pod pp_ctl.c util.c Todo pod/perldiag.pod
+
+NETaa13514: statements before intro of lex var could see lex var
+From: William Setzer
+Files patched: op.c
+ When a lexical variable is declared, introduction is delayed until
+ the start of the next statement, so that any initialization code runs
+ outside the scope of the new variable. Thus,
+
+ my $y = 3;
+ my $y = $y;
+ print $y;
+
+ should print 3. Unfortunately, the declaration was marked with the
+ beginning location at the time that "my $y" was processed instead of
+ when the variable was introduced, so any embedded statements within
+ an anonymous subroutine picked up the wrong "my". The declaration
+ is now labelled correctly when the variable is actually introduced.
+
+NETaa13520: added closures
+From: Larry Wall
+Files patched: Todo cv.h embed.h global.sym gv.c interp.sym op.c perl.c perl.h pod/perlform.pod pp.c pp_ctl.c pp_hot.c sv.c sv.h toke.c
+
+NETaa13520: test to see if lexical works in a format now
+Files patched: t/op/write.t
+
+NETaa13522: substitution couldn't be used on a substr()
+From: Hans Mulder
+Files patched: pp_ctl.c pp_hot.c
+ Changed pp_subst not to use sv_replace() anymore, which didn't handle lvalues
+ and was overkill anyway. Should be slightly faster this way too.
+
+NETaa13525: G_EVAL mode in perl_call_sv didn't return values right.
+Files patched: perl.c
+
+NETaa13525: consolidated error message
+From: Larry Wall
+Files patched: perl.h toke.c
+
+NETaa13525: derived it
+Files patched: perly.h
+
+NETaa13525: missing some values from embed.h
+Files patched: embed.h
+
+NETaa13525: random cleanup
+Files patched: MANIFEST Todo cop.h lib/TieHash.pm lib/perl5db.pl opcode.h patchlevel.h pod/perldata.pod pod/perlsub.pod t/op/ref.t toke.c
+
+NETaa13525: random cleanup
+Files patched: pp_ctl.c util.c
+
+NETaa13527: File::Find needed to export $name and $dir
+From: Chaim Frenkel
+Files patched: lib/File/Find.pm
+ They are now exported.
+
+NETaa13528: cv_undef left unaccounted-for GV pointer in CV
+From: Tye McQueen
+Also: Spider Boardman
+Files patched: op.c
+
+NETaa13530: scalar keys now resets hash iterator
+From: Tim Bunce
+Files patched: doop.c
+ scalar keys() now resets the hash iterator.
+
+NETaa13531: h2ph doesn't check defined right
+From: Casper H.S. Dik
+Files patched: h2ph.SH
+
+NETaa13540: VMS update
+From: Larry Wall
+Files patched: MANIFEST README.vms doio.c embed.h ext/DynaLoader/dl_vms.xs interp.sym lib/Cwd.pm lib/ExtUtils/xsubpp lib/File/Basename.pm lib/File/Find.pm lib/File/Path.pm mg.c miniperlmain.c perl.c perl.h perly.c perly.c.diff pod/perldiag.pod pp_ctl.c pp_hot.c pp_sys.c proto.h util.c vms/Makefile vms/config.vms vms/descrip.mms vms/ext/Filespec.pm vms/ext/MM_VMS.pm vms/ext/VMS/stdio/Makefile.PL vms/ext/VMS/stdio/stdio.pm vms/ext/VMS/stdio/stdio.xs vms/genconfig.pl vms/perlvms.pod vms/sockadapt.c vms/sockadapt.h vms/vms.c vms/vmsish.h vms/writemain.pl
+
+NETaa13540: got some duplicate code
+Files patched: lib/File/Path.pm
+
+NETaa13540: stuff from Charles
+Files patched: MANIFEST README.vms lib/ExtUtils/MakeMaker.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/xsubpp lib/File/Basename.pm lib/File/Path.pm perl.c perl.h pod/perldiag.pod pod/perldiag.pod vms/Makefile vms/Makefile vms/config.vms vms/config.vms vms/descrip.mms vms/descrip.mms vms/ext/Filespec.pm vms/ext/Filespec.pm vms/ext/MM_VMS.pm vms/ext/MM_VMS.pm vms/ext/VMS/stdio/stdio.pm vms/ext/VMS/stdio/stdio.xs vms/gen_shrfls.pl vms/gen_shrfls.pl vms/genconfig.pl vms/genconfig.pl vms/mms2make.pl vms/perlvms.pod vms/sockadapt.h vms/test.com vms/vms.c vms/vms.c vms/vmsish.h vms/vmsish.h vms/writemain.pl
+
+NETaa13540: tweak from Charles
+Files patched: lib/File/Path.pm
+
+NETaa13552: scalar unpack("P4",...) ignored the 4
+From: Eric Arnold
+Files patched: pp.c
+ The optimization that tried to do only one item in a scalar context didn't
+ realize that the argument to P was not a repeat count.
+
+NETaa13553: now warns about 8 or 9 in octal escapes
+From: Mike Rogers
+Files patched: util.c
+ Now warns if it finds 8 or 9 before the end of the octal escape sequence.
+ So \039 produces a warning, but \0339 does not.
+
+NETaa13554: now allows foreach ${"name"}
+From: Johan Holtman
+Files patched: op.c
+ Instead of trying to remove OP_RV2SV, the compiler now just transmutes it into an
+ OP_RV2GV, which is a no-op for ordinary variables and does the right
+ thing for ${"name"}.
+
+NETaa13559: substitution now always checks for readonly
+From: Rodger Anderson
+Files patched: pp_hot.c
+ Substitution now always checks for readonly.
+
+NETaa13561: added explanations of closures and curly-quotes
+From: Larry Wall
+Files patched: pod/perlref.pod
+
+NETaa13562: null components in path cause indigestion
+From: Ambrose Kofi Laing
+Files patched: lib/Cwd.pm lib/pwd.pl
+
+NETaa13575: documented semantics of negative substr length
+From: Jeff Bouis
+Files patched: pod/perlfunc.pod
+ Documented the fact that negative length now leaves characters off the end,
+ and while I was at it, made it work right even if offset wasn't 0.
+
+NETaa13575: negative length to substr didn't work when offset non-zero
+Files patched: pp.c
+ (same)
+
+NETaa13575: random cleanup
+Files patched: pod/perlfunc.pod
+ (same)
+
+NETaa13580: couldn't localize $ACCUMULATOR
+From: Larry Wall
+Files patched: gv.c lib/English.pm mg.c perl.c sv.c
+ Needed to make $^A a real magical variable. Also lib/English.pm wasn't
+ exporting good.
+
+NETaa13583: doc mods from Tom
+From: Larry Wall
+Files patched: pod/modpods/AnyDBMFile.pod pod/modpods/Basename.pod pod/modpods/Benchmark.pod pod/modpods/Cwd.pod pod/modpods/Dynaloader.pod pod/modpods/Exporter.pod pod/modpods/Find.pod pod/modpods/Finddepth.pod pod/modpods/Getopt.pod pod/modpods/MakeMaker.pod pod/modpods/Open2.pod pod/modpods/POSIX.pod pod/modpods/Ping.pod pod/modpods/less.pod pod/modpods/strict.pod pod/perlapi.pod pod/perlbook.pod pod/perldata.pod pod/perlform.pod pod/perlfunc.pod pod/perlipc.pod pod/perlmod.pod pod/perlobj.pod pod/perlref.pod pod/perlrun.pod pod/perlsec.pod pod/perlsub.pod pod/perltrap.pod pod/perlvar.pod
+
+NETaa13589: return was enforcing list context on its arguments
+From: Tim Freeman
+Files patched: opcode.pl
+ A return was being treated like a normal list operator, in that it was
+ setting list context on its arguments. This was bogus.
+
+NETaa13591: POSIX::creat used wrong argument
+From: Paul Marquess
+Files patched: ext/POSIX/POSIX.pm
+ Applied suggested patch.
+
+NETaa13605: use strict refs error message now displays bad ref
+From: Peter Gordon
+Files patched: perl.h pod/perldiag.pod pp.c pp_hot.c
+ Now says
+
+ Can't use string ("2") as a HASH ref while "strict refs" in use at ./foo line 12.
+
+NETaa13630: eof docs were unclear
+From: Hallvard B Furuseth
+Files patched: pod/perlfunc.pod
+ Applied suggested patch.
+
+NETaa13636: $< and $> weren't refetched on undump restart
+From: Steve Pearlmutter
+Files patched: perl.c
+ The code in main() bypassed perl_construct on an undump restart, which bypassed
+ the code that set $< and $>.
+
+NETaa13641: added Tim's fancy new import whizbangers
+From: Tim Bunce
+Files patched: lib/Exporter.pm
+ Applied suggested patch.
+
+NETaa13649: couldn't AUTOLOAD a symbol reference
+From: Larry Wall
+Files patched: pp_hot.c
+ pp_entersub needed to guarantee a CV so it would get to the AUTOLOAD code.
+
+NETaa13651: renamed file had wrong package name
+From: Andreas Koenig
+Files patched: lib/File/Path.pm
+ Applied suggested patch.
+
+NETaa13660: now that we're testing distribution we can diagnose RANDBITS errors
+From: Karl Glazebrook
+Files patched: t/op/rand.t
+ Changed to suggested algorithm. Also duplicated it to test rand(100) too.
+
+NETaa13660: rand.t didn't test for proper distribution within range
+Files patched: t/op/rand.t
+ (same)
+
+NETaa13671: array slice misbehaved in a scalar context
+From: Tye McQueen
+Files patched: pp.c
+ A spurious else prevented the scalar-context-handling code from running.
+
+NETaa13672: filehandle constructors in POSIX don't return failure successfully
+From: Ian Phillipps
+Files patched: ext/POSIX/POSIX.pm
+ Applied suggested patch.
+
+
+NETaa13678: forced $1 to always be untainted
+From: Ka-Ping Yee
+Files patched: mg.c
+ I believe the bug that triggered this was fixed elsewhere, but just in case,
+ I put in explicit code to force $1 et al not to be tainted regardless.
+
+NETaa13682: formline doc need to discuss ~ and ~~ policy
+From: Peter Gordon
+Files patched: pod/perlfunc.pod
+
+NETaa13686: POSIX::open and POSIX::mkfifo didn't check tainting
+From: Larry Wall
+Files patched: ext/POSIX/POSIX.xs
+ open() and mkfifo() now check tainting.
+
+NETaa13687: new Exporter.pm
+From: Tim Bunce
+Files patched: lib/Exporter.pm
+ Added suggested changes, except for @EXPORTABLE, because it looks too much
+ like @EXPORTTABLE. Decided to stick with @EXPORT_OK because it looks more
+ like an adjunct. Also added an export_tags routine. The keys in the
+ %EXPORT_TAGS hash no longer use colons, to make the initializers prettier.
+
+NETaa13687: new Exporter.pm
+Files patched: ext/POSIX/POSIX.pm
+ (same)
+
+NETaa13694: add sockaddr_in to Socket.pm
+From: Tim Bunce
+Files patched: ext/Socket/Socket.pm
+ Applied suggested patch.
+
+NETaa13695: library routines should use qw() as good example
+From: Dean Roehrich
+Files patched: ext/DB_File/DB_File.pm ext/DynaLoader/DynaLoader.pm ext/Fcntl/Fcntl.pm ext/GDBM_File/GDBM_File.pm ext/POSIX/POSIX.pm ext/Socket/Socket.pm
+ Applied suggested patch.
+
+NETaa13696: myconfig should be a routine in Config.pm
+From: Kenneth Albanowski
+Files patched: configpm
+ Applied suggested patch.
+
+NETaa13704: fdopen closed fd on failure
+From: Hallvard B Furuseth
+Files patched: doio.c
+ Applied suggested patch.
+
+NETaa13706: Term::Cap doesn't work
+From: Dean Roehrich
+Files patched: lib/Term/Cap.pm
+ Applied suggested patch.
+
+NETaa13710: cryptswitch needed to be more "useable"
+From: Tim Bunce
+Files patched: embed.h global.sym perl.h toke.c
+ The cryptswitch_fp function now can operate in two modes. It can
+ modify the global rsfp to redirect input as before, or it can modify
+ linestr and return true, indicating that it is not necessary for yylex
+ to read another line since cryptswitch_fp has just done it.
+
+NETaa13712: new_tmpfile() can't be called as constructor
+From: Hans Mulder
+Files patched: ext/POSIX/POSIX.xs
+ Now allows new_tmpfile() to be called as a constructor.
+
+NETaa13714: variable method call not documented
+From: "Randal L. Schwartz"
+Files patched: pod/perlobj.pod
+ Now indicates that OBJECT->$method() works.
+
+NETaa13715: PACK->$method produces spurious warning
+From: Larry Wall
+Files patched: toke.c
+ The -> operator was telling the lexer to expect an operator when the
+ next thing was a variable.
+
+NETaa13716: Carp now allows multiple packages to be skipped out of
+From: Larry Wall
+Files patched: lib/Carp.pm
+ The subroutine redefinition warnings now warn on import collisions.
+
+NETaa13716: Exporter catches warnings and gives a better line number
+Files patched: lib/Exporter.pm
+ (same)
+
+NETaa13716: now counts imported routines as "defined" for redef warnings
+Files patched: op.c sv.c
+ (same)
diff --git a/contrib/perl5/Changes5.002 b/contrib/perl5/Changes5.002
new file mode 100644
index 000000000000..6382d5291757
--- /dev/null
+++ b/contrib/perl5/Changes5.002
@@ -0,0 +1,4003 @@
+-------------
+Version 5.002
+-------------
+
+The main enhancement to the Perl core was the addition of prototypes.
+Many of the modules that come with Perl have been extensively upgraded.
+
+Other than that, nearly all the changes for 5.002 were bug fixes of one
+variety or another, so here's the bug list, along with the "resolution"
+for each of them. If you wish to correspond about any of them, please
+include the bug number (if any).
+
+Changes specific to the Configure and build process are described
+at the bottom.
+
+Added APPLLIB_EXP for embedded perl library support.
+Files patched: perl.c
+
+Couldn't define autoloaded routine by assignment to typeglob.
+Files patched: pp_hot.c sv.c
+
+NETaa13525: Tiny patch to fix installman -n
+From: Larry Wall
+Files patched: installman
+
+NETaa13525: de-documented \v
+Files patched: pod/perlop.pod pod/perlre.pod
+
+NETaa13525: doc changes
+Files patched: pod/perlop.pod pod/perltrap.pod
+
+NETaa13525: perlxs update from Dean Roehrich
+Files patched: pod/perlxs.pod
+
+NETaa13525: rename powerunix to powerux
+Files patched: MANIFEST hints/powerux.sh
+
+NETaa13540: VMS uses CLK_TCK for HZ
+Files patched: pp_sys.c
+
+NETaa13721: pad_findlex core dumps on bad CvOUTSIDE()
+From: Carl Witty
+Files patched: op.c sv.c toke.c
+ Each CV has a reference to the CV containing it lexically. Unfortunately,
+ it didn't reference-count this reference, so when the outer CV was freed,
+ we ended up with a pointer to memory that got reused later as some other kind
+ of SV.
+
+NETaa13721: warning suppression
+Files patched: toke.c
+ (same)
+
+NETaa13722: walk.c had inconsistent static declarations
+From: Tim Bunce
+Files patched: x2p/walk.c
+ Consolidated the various declarations and made them consistent with
+ the actual definitions.
+
+NETaa13724: -MPackage=args patch
+From: Tim Bunce
+Files patched: perl.c pod/perlrun.pod
+ Added in the -MPackage=args patch too.
+
+NETaa13729: order-of-evaluation dependency in scope.c on leaving REGCONTEXT
+From: "Jason Shirk"
+Files patched: scope.c
+ Did
+
+ I32 delta = SSPOPINT;
+ savestack_ix -= delta; /* regexp must have croaked */
+
+ instead.
+
+NETaa13731: couldn't assign external lexical array to itself
+From: oneill@cs.sfu.ca
+Files patched: op.c
+ The pad_findmy routine was only checking previous statements for previous
+ mention of external lexicals, so the fact that the current statement
+ already mentioned @list was not noted. It therefore allocated another
+ reference to the outside lexical, and this didn't compare equal when
+ the assigment parsing code was trying to determine whether there was a
+ common variable on either side of the equals. Since it didn't see the
+ same variable, it thought it could avoid making copies of the values on
+ the stack during list assignment. Unfortunately, before using those
+ values, the list assignment has to zero out the target array, which
+ destroys the values.
+
+ The fix was to make pad_findmy search the current statement as well. This
+ was actually a holdover from some old code that was trying to delay
+ introduction of "my" variables until the next statement. This is now
+ done with a different mechanism, so the fix should not adversely affect
+ that.
+
+NETaa13733: s/// doesn't free old string when using copy mode
+From: Larry Wall
+Files patched: pp_ctl.c pp_hot.c
+ When I removed the use of sv_replace(), I simply forgot to free the old char*.
+
+NETaa13736: closures leaked memory
+From: Carl Witty
+Files patched: op.c pp.c
+ This is a specific example of a more general bug, fixed as NETaa13760, having
+ to do with reference counts on comppads.
+
+NETaa13739: XSUB interface caches gimme in case XSUB clobbers it
+From: Dean Roehrich
+Files patched: pp_hot.c
+ Applied suggest patch. Also deleted second gimme declaration as redundant.
+
+NETaa13760: comppad reference counts were inconsistent
+From: Larry Wall
+Files patched: op.c perl.c pp_ctl.c toke.c
+ All official references to comppads are supposed to be through compcv now,
+ but the transformation was not complete, resulting in memory leakage.
+
+NETaa13761: sv_2pv() wrongly preferred IV to NV when SV was readonly
+From: "Jack R. Lawler"
+Files patched: sv.c
+ Okay, I understand how this one happened. This is a case where a
+ beneficial fix uncovered a bug elsewhere. I changed the constant
+ folder to prefer integer results over double if the numbers are the
+ same. In this case, they aren't, but it leaves the integer value there
+ anyway because the storage is already allocated for it, and it *might*
+ be used in an integer context. And since it's producing a constant, it
+ sets READONLY. Unfortunately, sv_2pv() bogusly preferred the integer
+ value to the double when READONLY was set. This never showed up if you
+ just said
+
+ print 1.4142135623731;
+
+ because in that case, there was already a string value.
+
+
+NETaa13772: shmwrite core dumps consistently
+From: Gabe Schaffer
+Files patched: opcode.h opcode.pl
+ The shmwrite operator is a list operator but neglected to push a stack
+ mark beforehand, because an 'm' was missing from opcode.pl.
+
+NETaa13773: $. was misdocumented as read-only.
+From: Inaba Hiroto
+Files patched: pod/perlvar.pod
+ <1.array-element-read-only>
+ % perl -le '$,=", "; $#w=5; for (@w) { $_=1; } print @w'
+ Modification of a read-only value attempted at -e line 1.
+ % perl4 -le '$,=", "; $#w=5; for (@w) { $_=1; } print @w'
+ 1, 1, 1, 1, 1, 1
+
+ This one may stay the way it is for performance reasons.
+
+ <2.begin-local-RS>
+ % cat abc
+ a
+ b
+ c
+ % perl -e 'BEGIN { local $/ = ""; } print "$.:$_" while <>;' abc
+ 1:a
+ b
+ c
+ % perl -e '{ local $/ = ""; } print "$.:$_" while <>;' abc
+ 1:a
+ 2:b
+ 3:c
+
+ $/ wasn't initialized early enough, so local set it back to permanently
+ undefined on exit from the block.
+
+ <3.grep-x0-bug>
+ % perl -le 'print grep(/^-/ ? ($x=$_) x 0 : 1, "a", "-b", "c");'
+ a
+
+ % perl4 -le 'print grep(/^-/ ? ($x=$_) x 0 : 1, "a", "-b", "c");'
+ ac
+
+ An extra mark was left on the stack if (('x') x $repeat) was used in a scalar
+ context.
+
+ <4.input-lineno-assign>
+ # perl -w does not complain about assignment to $. (Is this just a feature?)
+ # perlvar.pod says "This variable should be considered read-only."
+ % cat abc
+ a
+ b
+ c
+ % perl -wnle '$. = 10 if $. == 2; print "$.:$_"' abc
+ 1:a
+ 10:b
+ 11:c
+
+ Fixed doc.
+
+ <5.local-soft-ref.bug>
+ % perl -e 'local ${"a"}=1;'
+ zsh: 529 segmentation fault perl -e 'local ${"a"}=1;'
+
+ Now says
+ Can't localize a reference at -e line 1.
+
+ <6.package-readline>
+ % perl -e 'package foo; sub foo { 1; } package main; $_ = foo::foo(); print'
+ 1
+ % perl -e '
+ package readline; sub foo { 1; } package main; $_ = readline::foo(); print'
+ Undefined subroutine &main::foo called at -e line 1.
+ % perl -e '
+ package readline; sub foo { 1; } package main; $_ = &readline::foo(); print'
+ 1
+
+ Now treats foo::bar correctly even if foo is a keyword.
+
+ <7.page-head-set-to-null-string>
+ % cat page-head
+ #From: russell@ccu1.auckland.ac.nz (Russell Fulton)
+ #Newsgroups: comp.lang.perl
+ #Subject: This script causes Perl 5.00 to sementation fault
+ #Date: 15 Nov 1994 00:11:37 GMT
+ #Message-ID: <3a8ubp$jrj@net.auckland.ac.nz>
+
+ select((select(STDOUT), $^='')[0]); #this is the critical line
+ $a = 'a';
+ write ;
+ exit;
+
+ format STDOUT =
+ @<<<<<<
+ $a
+ .
+
+ % perl page-head
+ zsh: 1799 segmentation fault perl /tmp/page-head
+
+ Now says
+ Undefined top format "main::" called at ./try line 11.
+
+ <8.sub-as-index>
+ # parser bug?
+ % perl -le 'sub foo {0}; $x[0]=0;$x[foo]<=0'
+ Unterminated <> operator at -e line 1.
+ % perl -le 'sub foo {0}; $x[0]=0;$x[foo()]<=0'
+
+ A right square bracket now forces expectation of an operator.
+
+ <9.unary-minus-to-regexp-var>
+ % cat minus-reg
+ #From: Michael Cook <mcook@cognex.com>
+ #Newsgroups: comp.lang.perl
+ #Subject: bug: print -$1
+ #Date: 01 Feb 1995 15:31:25 GMT
+ #Message-ID: <MCOOK.95Feb1103125@erawan.cognex.com>
+
+ $_ = "123";
+ /\d+/;
+ print $&, "\n";
+ print -$&, "\n";
+ print 0-$&, "\n";
+
+ % perl minus-reg
+ 123
+ 123
+ -123
+
+ Apparently already fixed in my copy.
+
+ <10.vec-segv>
+ % cat vec-bug
+ ## Offset values are changed for my machine.
+
+ #From: augustin@gdstech.grumman.com (Conrad Augustin)
+ #Subject: perl5 vec() bug?
+ #Message-ID: <1994Nov22.193728.25762@gdstech.grumman.com>
+ #Date: Tue, 22 Nov 1994 19:37:28 GMT
+
+ #The following two statements each produce a segmentation fault in perl5:
+
+ #vec($a, 21406, 32) = 1; # seg fault
+ vec($a, 42813, 16) = 1; # seg fault
+
+ #When the offset values are one less, all's well:
+ #vec($a, 21405, 32) = 1; # ok
+ #vec($a, 42812, 16) = 1; # ok
+
+ #Interestingly, this is ok for all high values of N:
+ #$N=1000000; vec($a, $N, 8) = 1;
+
+ % perl vec-bug
+ zsh: 1806 segmentation fault perl vec-bug
+
+ Can't reproduce this one.
+
+
+NETaa13773: $/ not correctly localized in BEGIN
+Files patched: perl.c
+ (same)
+
+NETaa13773: foo::bar was misparsed if foo was a reserved word
+Files patched: toke.c toke.c
+ (same)
+
+NETaa13773: right square bracket didn't force expectation of operator
+Files patched: toke.c
+ (same)
+
+NETaa13773: scalar ((x) x $repeat) left stack mark
+Files patched: op.c
+ (same)
+
+NETaa13778: -w coredumps on <$>
+From: Hans Mulder
+Files patched: pp_hot.c toke.c
+ Now produces suggested error message. Also installed guard in warning code
+ that coredumped.
+
+NETaa13779: foreach didn't use savestack mechanism
+From: Hans Mulder
+Files patched: cop.h pp_ctl.c
+ The foreach mechanism saved the old scalar value on the context stack
+ rather than the savestack. It could consequently get out of sync if
+ unexpectedly unwound.
+
+NETaa13785: GIMME sometimes used wrong context frame
+From: Greg Earle
+Files patched: embed.h global.sym op.h pp_ctl.c proto.h
+ The expression inside the return was taking its context from the immediately
+ surrounding block rather than the innermost surrounding subroutine call.
+
+NETaa13797: could modify sv_undef through auto-vivification
+From: Ilya Zakharevich
+Files patched: pp.c
+ Inserted the missing check for readonly values on auto-vivification.
+
+NETaa13798: if (...) {print} treats print as quoted
+From: Larry Wall
+Files patched: toke.c
+ The trailing paren of the condition was setting expectations to XOPERATOR
+ rather than XBLOCK, so it was being treated like ${print}.
+
+NETaa13926: commonality was not detected in assignments using COND_EXPR
+From: Mark Hanson
+Files patched: opcode.h opcode.pl
+ The assignment compiler didn't check the 2nd and 3rd args of a ?:
+ for commonality. It still doesn't, but I made ?: into a "dangerous"
+ operator so it is forced to treat it as common.
+
+NETaa13957: was marking the PUSHMARK as modifiable rather than the arg
+From: David Couture
+Files patched: op.c sv.c
+ It was marking the PUSHMARK as modifiable rather than the arg.
+
+NETaa13962: documentation of behavior of scalar <*> was unclear
+From: Tom Christiansen
+Files patched: pod/perlop.pod
+ Added the following to perlop:
+
+ A glob only evaluates its (embedded) argument when it is starting a new
+ list. All values must be read before it will start over. In a list
+ context this isn't important, because you automatically get them all
+ anyway. In a scalar context, however, the operator returns the next value
+ each time it is called, or a FALSE value if you've just run out. Again,
+ FALSE is returned only once. So if you're expecting a single value from
+ a glob, it is much better to say
+
+ ($file) = <blurch*>;
+
+ than
+
+ $file = <blurch*>;
+
+ because the latter will alternate between returning a filename and
+ returning FALSE.
+
+
+NETaa13986: split ignored /m pattern modifier
+From: Winfried Koenig
+Files patched: pp.c
+ Fixed to work like m// and s///.
+
+NETaa13992: regexp comments not seen after + in non-extended regexp
+From: Mark Knutsen
+Files patched: regcomp.c
+ The code to skip regexp comments was guarded by a conditional that only
+ let it work when /x was in effect.
+
+NETaa14014: use subs should not count as definition, only as declaration
+From: Keith Thompson
+Files patched: sv.c
+ On *foo = \&bar, doesn't set GVf_IMPORTED if foo and bar are in same package.
+
+NETaa14021: sv_inc and sv_dec "upgraded" magical SV to non-magical
+From: Paul A Sand
+Also: Andreas Koenig
+Files patched: sv.c
+ The sv_inc() and sv_dec() routines "upgraded" null magical SVs to non-magical.
+
+NETaa14086: require should check tainting
+From: Karl Simon Berg
+Files patched: pp_ctl.c
+ Since we shouldn't allow tainted requires anyway, it now says:
+
+ Insecure dependency in require while running with -T switch at tst.pl line 1.
+
+NETaa14104: negation fails on magical variables like $1
+From: tim
+Files patched: pp.c
+ Negation was failing on magical values like $1. It was testing the wrong
+ bits and also failed to provide a final "else" if none of the bits matched.
+
+NETaa14107: deep sort return leaked contexts
+From: Quentin Fennessy
+Files patched: pp_ctl.c
+ Needed to call dounwind() appropriately.
+
+NETaa14129: attempt to localize via a reference core dumps
+From: Michele Sardo
+Files patched: op.c pod/perldiag.pod
+ Now produces an error "Can't localize a reference", with explanation in
+ perldiag.
+
+NETaa14138: substr() and s/// can cause core dump
+From: Andrew Vignaux
+Files patched: pp_hot.c
+ Forgot to call SvOOK_off() on the SV before freeing its string.
+
+NETaa14145: ${@INC}[0] dumped core in debugger
+From: Hans Mulder
+Files patched: sv.c
+ Now croaks "Bizarre copy of ARRAY in block exit", which is better than
+ a core dump. The fact that ${@INC}[0] means $INC[0] outside the debugger
+ is a different bug.
+
+NETaa14147: bitwise assignment ops wipe out byte of target string
+From: Jim Richardson
+Files patched: doop.c
+ The code was assuming that the target was not either of the two operands,
+ which is false for an assignment operator.
+
+NETaa14153: lexing of lexicals in patterns fooled by character class
+From: Dave Bianchi
+Files patched: toke.c
+ It never called the dwimmer, which is how it fooled it.
+
+NETaa14154: allowed autoloaded methods by recognizing sub method; declaration
+From: Larry Wall
+Files patched: gv.c
+ Made sub method declaration sufficient for autoloader to stop searching on.
+
+NETaa14156: shouldn't optimize block scope on tainting
+From: Pete Peterson
+Files patched: op.c toke.c
+ I totally disabled the block scope optimization when running tainted.
+
+NETaa14157: -T and -B only allowed 1/30 "odd" characters--changed to 1/3
+From: Tor Lillqvist
+Files patched: pp_sys.c
+ Applied suggested patch.
+
+NETaa14160: deref of null symbol should produce null list
+From: Jared Rhine
+Files patched: pp_hot.c
+ It didn't check for list context before returning undef.
+
+NETaa14162: POSIX::gensym now returns a symbol reference
+From: Josh N. Pritikin
+Also: Tim Bunce
+Files patched: ext/POSIX/POSIX.pm
+ Applied suggested patch.
+
+NETaa14164: POSIX autoloader now distinguishes non-constant "constants"
+From: Tim Bunce <Tim.Bunce@ig.co.uk>
+Files patched: ext/POSIX/POSIX.pm ext/POSIX/POSIX.xs
+ The .xs file now distinguishes non-constant "constants" by setting EAGAIN.
+ This will also let us use #ifdef within the .xs file to de-constantify
+ any other macros that happen not to be constants even if they don't use
+ an argument.
+
+NETaa14166: missing semicolon after "my" induces core dump
+From: Thomas Kofler
+Files patched: toke.c
+ The parser was left thinking it was still processing a "my", and flubbed.
+ I made it wipe out the "in_my" variable on a syntax error.
+
+NETaa14166: missing semicolon after "my" induces core dump"
+Files patched: toke.c
+ (same)
+
+NETaa14206: can now use English and strict at the same time
+From: Andrew Wilcox
+Files patched: sv.c
+ It now counts imported symbols as okay under "use strict".
+
+NETaa14206: can now use English and strict at the same time
+Files patched: gv.c pod/perldiag.pod
+ (same)
+
+NETaa14265: elseif now produces severe warning
+From: Yutao Feng
+Files patched: pod/perldiag.pod toke.c
+ Now complains explicitly about "elseif".
+
+NETaa14279: list assignment propagated taintedness to independent scalars
+From: Tim Freeman
+Files patched: pp_hot.c
+ List assignment needed to be modified so that tainting didn't propagate
+ between independent scalar values.
+
+NETaa14312: undef in @EXPORTS core dumps
+From: William Setzer
+Files patched: lib/Exporter.pm
+ Now says:
+
+ Unable to create sub named "t::" at lib/Exporter.pm line 159.
+ Illegal null symbol in @t::EXPORT at -e line 1
+ BEGIN failed--compilation aborted at -e line 1.
+
+
+NETaa14312: undef in @EXPORTS core dumps
+Files patched: pod/perldiag.pod sv.c
+ (same)
+
+NETaa14321: literal @array check shouldn't happen inside embedded expressions
+From: Mark H. Nodine
+Files patched: toke.c
+ The general solution to this is to disable the literal @array check within
+ any embedded expression. For instance, this also failed bogusly:
+
+ print "$foo{@foo}";
+
+ The reason fixing this also fixes the s///e problem is that the lexer
+ effectively puts the RHS into a do {} block, making the expression
+ embedded within curlies, as far as the error message is concerned.
+
+NETaa14322: now localizes $! during POSIX::AUTOLOAD
+From: Larry Wall
+Files patched: ext/POSIX/POSIX.pm
+ Added local $! = 0.
+
+NETaa14324: defined() causes spurious sub existence
+From: "Andreas Koenig"
+Files patched: op.c pp.c
+ It called pp_rv2cv which wrongly assumed it could add any sub it referenced.
+
+NETaa14336: use Module () forces import of nothing
+From: Tim Bunce
+Files patched: op.c
+ use Module () now refrains from calling import at all.
+
+NETaa14353: added special HE allocator
+From: Larry Wall
+Files patched: global.sym
+
+NETaa14353: added special HE allocator
+Files patched: hv.c perl.h
+
+NETaa14353: array extension now converts old memory to SV storage.
+Files patched: av.c av.h sv.c
+
+NETaa14353: hashes now convert old storage into SV arenas.
+Files patched: global.sym
+
+NETaa14353: hashes now convert old storage into SV arenas.
+Files patched: hv.c perl.h
+
+NETaa14353: upgraded SV arena allocation
+Files patched: proto.h
+
+NETaa14353: upgraded SV arena allocation
+Files patched: perl.c sv.c
+
+NETaa14422: added rudimentary prototypes
+From: Gisle Aas
+Files patched: Makefile.SH op.c op.c perly.c perly.c.diff perly.h perly.y proto.h sv.c toke.c
+ Message-Id: <9509290018.AA21548@scalpel.netlabs.com>
+ To: doughera@lafcol.lafayette.edu (Andy Dougherty)
+ Cc: perl5-porters@africa.nicoh.com
+ Subject: Re: Jumbo Configure patch vs. 1m.
+ Date: Thu, 28 Sep 95 17:18:54 -0700
+ From: lwall@scalpel.netlabs.com (Larry Wall)
+
+ : No. Larry's currently got the patch pumpkin for all such core perl topics.
+
+ I dunno whether you should let me have the patch pumpkin or not. To fix
+ a Sev 2 I just hacked in rudimentary prototypes. :-)
+
+ We can now define true unary subroutines, as well as argumentless
+ subroutines:
+
+ sub baz () { 12; } # Must not have argument
+ sub bar ($) { $_[0] * 7 } # Must have exactly one argument
+ sub foo ($@) { print "@_\n" } # Must have at least one argument
+ foo bar baz / 2 || "oops", "is the answer";
+
+ This prints "42 is the answer" on my machine. That is, it's the same as
+
+ foo( bar( baz() / 2) || "oops", "is the answer");
+
+ Attempting to compile
+
+ foo;
+
+ results in
+
+ Too few arguments for main::foo at ./try line 8, near "foo;"
+
+ Compiling
+
+ bar 1,2,3;
+
+ results in
+
+ Too many arguments for main::bar at ./try line 8, near "foo;"
+
+ But
+
+ @array = ('a','b','c');
+ foo @array, @array;
+
+ prints "3 a b c" because the $ puts the first arg of foo into scalar context.
+
+ The main win at this point is that we can say
+
+ sub AAA () { 1; }
+ sub BBB () { 2; }
+
+ and the user can say AAA + BBB and get 3.
+
+ I'm not quite sure how this interacts with autoloading though. I fear
+ POSIX.pm will need to say
+
+ sub E2BIG ();
+ sub EACCES ();
+ sub EAGAIN ();
+ sub EBADF ();
+ sub EBUSY ();
+ ...
+ sub _SC_STREAM_MAX ();
+ sub _SC_TZNAME_MAX ();
+ sub _SC_VERSION ();
+
+ unless we can figure out how to efficiently declare a default prototype
+ at import time. Meaning, not using eval. Currently
+
+ *foo = \&bar;
+
+ (the ordinary import mechanism) implicitly stubs &bar with no prototype if
+ &bar is not yet declared. It's almost like you want an AUTOPROTO to
+ go with your AUTOLOAD.
+
+ Another thing to rub one's 5 o'clock shadow over is that there's no way
+ to apply a prototype to a method call at compile time.
+
+ And no, I don't want to have the
+
+ sub howabout ($formal, @arguments) { ... }
+
+ argument right now.
+
+ Larry
+
+NETaa14422: couldn't take reference of a prototyped function
+Files patched: op.c
+ (same)
+
+NETaa14423: use didn't allow expressions involving the scratch pad
+From: Graham Barr
+Files patched: op.c perly.c perly.c.diff perly.y proto.h vms/perly_c.vms
+ Applied suggested patch.
+
+NETaa14444: lexical scalar didn't autovivify
+From: Gurusamy Sarathy
+Files patched: op.c pp_hot.c
+ It didn't have code in pp_padsv to do the right thing.
+
+NETaa14448: caller could dump core when used within an eval or require
+From: Danny R. Faught
+Files patched: pp_ctl.c
+ caller() was incorrectly assuming the context stack contained a subroutine
+ context when it in fact contained an eval context.
+
+NETaa14451: improved error message on bad pipe filehandle
+From: Danny R. Faught
+Files patched: pp_sys.c
+ Now says the slightly more informative
+
+ Can't use an undefined value as filehandle reference at ./try line 3.
+
+NETaa14462: pp_dbstate had a scope leakage on recursion suppression
+From: Tim Bunce
+Files patched: pp_ctl.c
+ Swapped the code in question around.
+
+NETaa14482: sv_unref freed ref prematurely at times
+From: Gurusamy Sarathy
+Files patched: sv.c
+ Made sv_unref() mortalize rather than free the old reference.
+
+NETaa14484: appending string to array produced bizarre results
+From: Greg Ward
+Also: Malcolm Beattie
+Files patched: pp_hot.c
+ Will now say, "Can't coerce ARRAY to string".
+
+NETaa14525: assignment to globs didn't reset them correctly
+From: Gurusamy Sarathy
+Files patched: sv.c
+ Applied parts of patch not overridden by subsequent patch.
+
+NETaa14529: a partially matching subpattern could spoof infinity detector
+From: Wayne Berke
+Files patched: regexec.c
+ A partial match on a subpattern could fool the infinite regress detector
+ into thinking progress had been made.
+ The previous workaround prevented another bug (NETaa14529) from being fixed,
+ so I've backed it out. I'll need to think more about how to detect failure
+ to progress. I'm still hopeful it's not equivalent to the halting problem.
+
+NETaa14535: patches from Gurusamy Sarathy
+From: Gurusamy Sarathy
+Files patched: op.c pp.c pp_hot.c regexec.c sv.c toke.c
+ Applied most recent suggested patches.
+
+NETaa14537: select() can return too soon
+From: Matt Kimball
+Also: Andreas Gustafsson
+Files patched: pp_sys.c
+
+NETaa14538: method calls were treated like do {} under loop modifiers
+From: Ilya Zakharevich
+Files patched: perly.c perly.y
+ Needed to take the OPf_SPECIAL flag off of entersubs from method reductions.
+ (It was probably a cut-and-paste error from long ago.)
+
+NETaa14540: foreach (@array) no longer does extra stack copy
+From: darrinm@lmc.com
+Files patched: Todo op.c pp_ctl.c pp_hot.c
+ Fixed by doing the foreach(@array) optimization, so it iterates
+ directly through the array, and can detect the implicit shift from
+ referencing <>.
+
+NETaa14541: new version of perlbug
+From: Kenneth Albanowski
+Files patched: README pod/perl.pod utils/perlbug.PL
+ Brought it up to version 1.09.
+
+NETaa14541: perlbug 1.11
+Files patched: utils/perlbug.PL
+ (same)
+
+NETaa14548: magic sets didn't check private OK bits
+From: W. Bradley Rubenstein
+Files patched: mg.c
+ The magic code was getting mixed up between private and public POK bits.
+
+NETaa14550: made ~ magic magical
+From: Tim Bunce
+Files patched: sv.c
+ Applied suggested patch.
+
+NETaa14551: humongous header causes infinite loop in format
+From: Grace Lee
+Files patched: pp_sys.c
+ Needed to check for page exhaustion after doing top-of-form.
+
+NETaa14558: attempt to call undefined top format core dumped
+From: Hallvard B Furuseth
+Files patched: pod/perldiag.pod pp_sys.c
+ Now issues an error on attempts to call a non-existent top format.
+
+NETaa14561: Gurusamy Sarathy's G_KEEPERR patch
+From: Andreas Koenig
+Also: Gurusamy Sarathy
+Also: Tim Bunce
+Files patched: cop.h interp.sym perl.c perl.h pp_ctl.c pp_sys.c sv.c toke.c
+ Applied latest patch.
+
+NETaa14581: shouldn't execute BEGIN when there are compilation errors
+From: Rickard Westman
+Files patched: op.c
+ Perl should not try to execute BEGIN and END blocks if there's been a
+ compilation error.
+
+NETaa14582: got SEGV sorting sparse array
+From: Rick Pluta
+Files patched: pp_ctl.c
+ Now weeds out undefined values much like Perl 4 did.
+ Now sorts undefined values to the front.
+
+NETaa14582: sort was letting unsortable values through to comparison routine
+Files patched: pp_ctl.c
+ (same)
+
+NETaa14585: globs in pad space weren't properly cleaned up
+From: Gurusamy Sarathy
+Files patched: op.c pp.c pp_hot.c sv.c
+ Applied suggested patch.
+
+NETaa14614: now does dbmopen with perl_eval_sv()
+From: The Man
+Files patched: perl.c pp_sys.c proto.h
+ dbmopen now invokes perl_eval_sv(), which should handle error conditions
+ better.
+
+NETaa14618: exists doesn't work in GDBM_File
+From: Andrew Wilcox
+Files patched: ext/GDBM_File/GDBM_File.xs
+ Applied suggested patch.
+
+NETaa14619: tied()
+From: Larry Wall
+Also: Paul Marquess
+Files patched: embed.h global.sym keywords.h keywords.pl opcode.h opcode.pl pp_sys.c toke.c
+ Applied suggested patch.
+
+NETaa14636: Jumbo Dynaloader patch
+From: Tim Bunce
+Files patched: ext/DynaLoader/DynaLoader.pm ext/DynaLoader/dl_dld.xs ext/DynaLoader/dl_dlopen.xs ext/DynaLoader/dl_hpux.xs ext/DynaLoader/dl_next.xs ext/DynaLoader/dl_vms.xs ext/DynaLoader/dlutils.c
+ Applied suggested patches.
+
+NETaa14637: checkcomma routine was stupid about bareword sub calls
+From: Tim Bunce <Tim.Bunce@ig.co.uk>
+Files patched: toke.c
+ The checkcomma routine was stupid about bareword sub calls.
+
+NETaa14639: (?i) didn't reset on runtime patterns
+From: Mark A. Scheel
+Files patched: op.h pp_ctl.c toke.c
+ It didn't distinguish between permanent flags outside the pattern and
+ temporary flags within the pattern.
+
+NETaa14649: selecting anonymous globs dumps core
+From: Chip Salzenberg
+Files patched: cop.h doio.c embed.h global.sym perl.c pp_sys.c proto.h
+ Applied suggested patch, but reversed the increment and decrement to avoid
+ decrementing and freeing what we're going to increment.
+
+NETaa14655: $? returned negative value on AIX
+From: Kim Frutiger
+Also: Stephen D. Lee
+Files patched: pp_sys.c
+ Applied suggested patch.
+
+NETaa14668: {2,} could match once
+From: Hugo van der Sanden
+Files patched: regexec.c
+ When an internal pattern failed a conjecture, it didn't back off on the
+ number of times it thought it had matched.
+
+NETaa14673: open $undefined dumped core
+From: Samuli K{rkk{inen
+Files patched: pp_sys.c
+ pp_open() didn't check its argument for globness.
+
+NETaa14683: stringifies were running pad out of space
+From: Robin Barker
+Files patched: op.h toke.c
+ Increased PADOFFSET to a U32, and made lexer not put double-quoted strings
+ inside OP_STRINGIFY unless they really needed it.
+
+NETaa14689: shouldn't have . in @INC when tainting
+From: William R. Somsky
+Files patched: perl.c
+ Now does not put . into @INC when tainting. It may still be added with a
+
+ use lib ".";
+
+ or, to put it at the end,
+
+ BEGIN { push(@INC, ".") }
+
+ but this is not recommended unless a chdir to a known location has been done
+ first.
+
+NETaa14690: values inside tainted SVs were ignored
+From: "James M. Stern"
+Files patched: pp.c pp_ctl.c
+ It was assuming that a tainted value was a string.
+
+NETaa14692: format name required qualification under use strict
+From: Tom Christiansen
+Files patched: gv.c
+ Now treats format names the same as subroutine names.
+
+NETaa14695: added simple regexp caching
+From: John Rowe
+Files patched: pp_ctl.c
+ Applied suggested patch.
+
+NETaa14697: regexp comments were sometimes wrongly treated as literal text
+From: Tom Christiansen
+Files patched: regcomp.c
+ The literal-character grabber didn't know about extended comments.
+ N.B. '#' is treated as a comment character whenever the /x option is
+ used now, so you can't include '#' as a simple literal in /x regexps.
+
+ (By the way, Tom, the boxed form of quoting in the previous enclosure is
+ exceeding antisocial when you want to extract the code from it.)
+
+NETaa14704: closure got wrong outer scope if outer sub was predeclared
+From: Marc Paquette
+Files patched: op.c
+ The outer scope of the anonymous sub was set to the stub rather than to
+ the actual subroutine. I kludged it by making the outer scope of the
+ stub be the actual subroutine, if anything is depending on the stub.
+
+NETaa14705: $foo .= $foo did free memory read
+From: Gerd Knops
+Files patched: sv.c
+ Now modifies address to copy if it was reallocated.
+
+NETaa14709: Chip's FileHandle stuff
+From: Larry Wall
+Also: Chip Salzenberg
+Files patched: MANIFEST ext/FileHandle/FileHandle.pm ext/FileHandle/FileHandle.xs ext/FileHandle/Makefile.PL ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs lib/FileCache.pm lib/Symbol.pm t/lib/filehand.t t/lib/posix.t
+ Applied suggested patches.
+
+NETaa14711: added (&) and (*) prototypes for blocks and symbols
+From: Kenneth Albanowski
+Files patched: Makefile.SH op.c perly.c perly.h perly.y toke.c
+ & now means that it must have an anonymous sub as that argument. If
+ it's the first argument, the sub may be specified as a block in the
+ indirect object slot, much like grep or sort, which have prototypes of (&@).
+
+ Also added * so you can do things like
+
+ sub myopen (*;$);
+
+ myopen(FOO, $filename);
+
+NETaa14713: setuid FROM root now defaults to not do tainting
+From: Tony Camas
+Files patched: mg.c perl.c pp_hot.c
+ Applied suggested patch.
+
+NETaa14714: duplicate magics could be added to an SV
+From: Yary Hluchan
+Files patched: sv.c sv.c
+ The sv_magic() routine didn't properly check to see if it already had a
+ magic of that type. Ordinarily it would have, but it was called during
+ mg_get(), which forces the magic flags off temporarily.
+
+NETaa14721: sub defined during erroneous do-FILE caused core dump
+From: David Campbell
+Files patched: op.c
+ Fixed the seg fault. I couldn't reproduce the return problem.
+
+NETaa14734: ref should never return undef
+From: Dale Amon
+Files patched: pp.c t/op/overload.t
+ Now returns null string.
+
+NETaa14751: slice of undefs now returns null list
+From: Tim Bunce
+Files patched: pp.c pp_hot.c
+ Null list clobberation is now done in lslice, not aassign.
+
+NETaa14789: select coredumped on Linux
+From: Ulrich Kunitz
+Files patched: pp_sys.c
+ Applied suggested patches, more or less.
+
+NETaa14789: straightened out ins and out of duping
+Files patched: lib/IPC/Open3.pm
+ (same)
+
+NETaa14791: implemented internal SUPER class
+From: Nick Ing-Simmons
+Also: Dean Roehrich
+Files patched: gv.c
+ Applied suggested patch.
+
+NETaa14845: s/// didn't handle offset strings
+From: Ken MacLeod
+Files patched: pp_ctl.c
+ Needed a call to SvOOK_off(targ) in pp_substcont().
+
+NETaa14851: Use of << to mean <<"" is deprecated
+From: Larry Wall
+Files patched: toke.c
+
+NETaa14865: added HINT_BLOCK_SCOPE to "elsif"
+From: Jim Avera
+Files patched: perly.y
+ Needed to set HINT_BLOCK_SCOPE on "elsif" to prevent the do block from
+ being optimized away, which caused the statement transition in elsif
+ to reset the stack too far back.
+
+NETaa14876: couldn't delete localized GV safely
+From: John Hughes
+Files patched: pp.c scope.c
+ The reference count of the "borrowed" GV needed to be incremented while
+ there was a reference to it in the savestack.
+
+NETaa14887: couldn't negate magical scalars
+From: ian
+Also: Gurusamy Sarathy
+Files patched: pp.c
+ Applied suggested patch, more or less. (It's not necessary to test both
+ SvNIOK and SvNIOKp, since the private bits are always set if the public
+ bits are set.)
+
+NETaa14893: /m modifier was sticky
+From: Jim Avera
+Files patched: pp_ctl.c
+ pp_match() and pp_subst() were using an improperly scoped SAVEINT to restore
+ the value of the internal variable multiline.
+
+NETaa14893: /m modifier was sticky
+Files patched: cop.h pp_hot.c
+ (same)
+
+NETaa14916: complete.pl retained old return value
+From: Martyn Pearce
+Files patched: lib/complete.pl
+ Applied suggested patch.
+
+NETaa14928: non-const 3rd arg to split assigned to list could coredump
+From: Hans de Graaff
+Files patched: op.c
+ The optimizer was assuming the OP was an OP_CONST.
+
+NETaa14942: substr as lvalue could disable magic
+From: Darrell Kindred <dkindred+@cmu.edu>
+Files patched: pp.c
+ The substr was disabling the magic of $1.
+
+NETaa14990: "not" not parseable when expecting term
+From: "Randal L. Schwartz"
+Files patched: perly.c perly.c.diff perly.y vms/perly_c.vms
+ The NOTOP production needed to be moved down into the terms.
+
+NETaa14993: Bizarre copy of formline
+From: Tom Christiansen
+Also: Charles Bailey
+Files patched: sv.c
+ Applied suggested patch.
+
+NETaa14998: sv_add_arena() no longer leaks memory
+From: Andreas Koenig
+Files patched: av.c hv.c perl.h sv.c
+ Now keeps one potential arena "on tap", but doesn't use it unless there's
+ demand for SV headers. When an AV or HV is extended, its old memory
+ becomes the next potential arena unless there already is one, in which
+ case it is simply freed. This will have the desired property of not
+ stranding medium-sized chunks of memory when extending a single array
+ repeatedly, but will not degrade when there's no SV demand beyond keeping
+ one chunk of memory on tap, which generally will be about 250 bytes big,
+ since it prefers the earlier freed chunk over the later. See the nice_chunk
+ variable.
+
+NETaa14999: $a and $b now protected from use strict and lexical declaration
+From: Tom Christiansen
+Files patched: gv.c pod/perldiag.pod toke.c
+ Bare $a and $b are now allowed during "use strict". In addition,
+ the following diag was added:
+
+ =item Can't use "my %s" in sort comparison
+
+ (F) The global variables $a and $b are reserved for sort comparisons.
+ You mentioned $a or $b in the same line as the <=> or cmp operator,
+ and the variable had earlier been declared as a lexical variable.
+ Either qualify the sort variable with the package name, or rename the
+ lexical variable.
+
+
+NETaa15034: use strict refs should allow calls to prototyped functions
+From: Roderick Schertler
+Files patched: perly.c perly.c.diff perly.y toke.c vms/perly_c.vms
+ Applied patch suggested by Chip.
+
+NETaa15083: forced $AUTOLOAD to be untainted
+From: Tim Bunce
+Files patched: gv.c pp_hot.c
+ Stripped any taintmagic from $AUTOLOAD after setting it.
+
+NETaa15084: patch for Term::Cap
+From: Mark Kaehny
+Also: Hugo van der Sanden
+Files patched: lib/Term/Cap.pm
+ Applied suggested patch.
+
+NETaa15086: null pattern could cause coredump in s//_$1_/
+From: "Paul E. Maisano"
+Files patched: cop.h pp_ctl.c
+ If the replacement pattern was complicated enough to cause pp_substcont
+ to be called, then it lost track of which REGEXP* it was supposed to
+ be using.
+
+NETaa15087: t/io/pipe.t didn't work on AIX
+From: Andy Dougherty
+Files patched: t/io/pipe.t
+ Applied suggested patch.
+
+NETaa15088: study was busted
+From: Hugo van der Sanden
+Files patched: opcode.h opcode.pl pp.c
+ It was studying its scratch pad target rather than the argument supplied.
+
+NETaa15090: MSTATS patch
+From: Tim Bunce
+Files patched: global.sym malloc.c perl.c perl.h proto.h
+ Applied suggested patch.
+
+NETaa15098: longjmp out of magic leaks memory
+From: Chip Salzenberg
+Files patched: mg.c sv.c
+ Applied suggested patch.
+
+NETaa15102: getpgrp() is broken if getpgrp2() is available
+From: Roderick Schertler
+Files patched: perl.h pp_sys.c
+ Applied suggested patch.
+
+NETaa15103: prototypes leaked opcodes
+From: Chip Salzenberg
+Files patched: op.c
+ Applied suggested patch.
+
+NETaa15107: quotameta memory bug on all metacharacters
+From: Chip Salzenberg
+Files patched: pp.c
+ Applied suggested patch.
+
+NETaa15108: Fix for incomplete string leak
+From: Chip Salzenberg
+Files patched: toke.c
+ Applied suggested patch.
+
+NETaa15110: couldn't use $/ with 8th bit set on some architectures
+From: Chip Salzenberg
+Files patched: doop.c interp.sym mg.c op.c perl.c perl.h pp_ctl.c pp_hot.c pp_sys.c sv.c toke.c util.c
+ Applied suggested patches.
+
+NETaa15112: { a_1 => 2 } didn't parse as expected
+From: Stuart M. Weinstein
+Files patched: toke.c
+ The little dwimmer was only skipping ALPHA rather than ALNUM chars.
+
+NETaa15123: bitwise ops produce spurious warnings
+From: Hugo van der Sanden
+Also: Chip Salzenberg
+Also: Andreas Gustafsson
+Files patched: sv.c
+ Decided to suppress the warning in the conversion routines if merely converting
+ a temporary, which can never be a user-supplied value anyway.
+
+NETaa15129: #if defined (foo) misparsed in h2ph
+From: Roderick Schertler <roderick@gate.net>
+Files patched: utils/h2ph.PL
+ Applied suggested patch.
+
+NETaa15131: some POSIX functions assumed valid filehandles
+From: Chip Salzenberg
+Files patched: ext/POSIX/POSIX.xs
+ Applied suggested patch.
+
+NETaa15151: don't optimize split on OPpASSIGN_COMMON
+From: Huw Rogers
+Files patched: op.c
+ Had to swap the optimization down to after the assignment op is generated
+ and COMMON is calculated, and then clean up the resultant tree differently.
+
+NETaa15154: MakeMaker-5.18
+From: Andreas Koenig
+Files patched: MANIFEST lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_VMS.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm
+ Brought it up to 5.18.
+
+NETaa15156: some Exporter tweaks
+From: Roderick Schertler
+Also: Tim Bunce
+Files patched: lib/Exporter.pm
+ Also did Tim's Tiny Trivial patch.
+
+NETaa15157: new version of Test::Harness
+From: Andreas Koenig
+Files patched: lib/Test/Harness.pm
+ Applied suggested patch.
+
+NETaa15175: overloaded nomethod has garbage 4th op
+From: Ilya Zakharevich
+Files patched: gv.c
+ Applied suggested patch.
+
+NETaa15179: SvPOK_only shouldn't back off on offset pointer
+From: Gutorm.Hogasen@oslo.teamco.telenor.no
+Files patched: sv.h
+ SvPOK_only() was calling SvOOK_off(), which adjusted the string pointer
+ after tr/// has already acquired it. It shouldn't really be necessary
+ for SvPOK_only() to undo an offset string pointer, since there's no
+ conflict with a possible integer value where the offset is stored.
+
+NETaa15193: & now always bypasses prototype checking
+From: Larry Wall
+Files patched: dump.c op.c op.h perly.c perly.c.diff perly.y pod/perlsub.pod pp_hot.c proto.h toke.c vms/perly_c.vms vms/perly_h.vms
+ Turned out to be a big hairy deal because the lexer turns foo() into &foo().
+ But it works consistently now. Also fixed pod.
+
+NETaa15197: 5.002b2 is 'appending' to $@
+From: Gurusamy Sarathy
+Files patched: pp_ctl.c
+ Applied suggested patch.
+
+NETaa15201: working around Linux DBL_DIG problems
+From: Kenneth Albanowski
+Files patched: hints/linux.sh sv.c
+ Applied suggested patch.
+
+NETaa15208: SelectSaver
+From: Chip Salzenberg
+Files patched: MANIFEST lib/SelectSaver.pm
+ Applied suggested patch.
+
+NETaa15209: DirHandle
+From: Chip Salzenberg
+Files patched: MANIFEST lib/DirHandle.pm t/lib/dirhand.t
+
+NETaa15210: sysopen()
+From: Chip Salzenberg
+Files patched: doio.c keywords.pl lib/ExtUtils/typemap opcode.pl pod/perlfunc.pod pp_hot.c pp_sys.c proto.h toke.c
+ Applied suggested patch. Hope it works...
+
+NETaa15211: use mnemonic names in Safe setup
+From: Chip Salzenberg
+Files patched: ext/Safe/Safe.pm
+ Applied suggested patch, more or less.
+
+NETaa15214: prototype()
+From: Chip Salzenberg
+Files patched: ext/Safe/Safe.pm global.sym keywords.pl opcode.pl pp.c toke.c
+ Applied suggested patch.
+
+NETaa15217: -w problem with -d:foo
+From: Tim Bunce
+Files patched: perl.c
+ Applied suggested patch.
+
+NETaa15218: *GLOB{ELEMENT}
+From: Larry Wall
+Files patched: Makefile.SH embed.h ext/Safe/Safe.pm keywords.h opcode.h opcode.h opcode.pl perly.c perly.c.diff perly.y pp_hot.c t/lib/safe.t vms/perly_c.vms
+
+NETaa15219: Make *x=\*y do like *x=*y
+From: Chip Salzenberg
+Files patched: sv.c
+ Applied suggested patch.
+
+NETaa15221: Indigestion with Carp::longmess and big eval '...'s
+From: Tim Bunce
+Files patched: lib/Carp.pm
+ Applied suggested patch.
+
+NETaa15222: VERSION patch for standard extensions
+From: Paul Marquess
+Files patched: ext/DB_File/Makefile.PL ext/DynaLoader/DynaLoader.pm ext/DynaLoader/Makefile.PL ext/Fcntl/Fcntl.pm ext/Fcntl/Makefile.PL ext/GDBM_File/GDBM_File.pm ext/GDBM_File/Makefile.PL ext/NDBM_File/Makefile.PL ext/NDBM_File/NDBM_File.pm ext/ODBM_File/Makefile.PL ext/ODBM_File/ODBM_File.pm ext/POSIX/Makefile.PL ext/POSIX/POSIX.pm ext/SDBM_File/Makefile.PL ext/SDBM_File/SDBM_File.pm ext/Safe/Makefile.PL ext/Safe/Safe.pm ext/Socket/Makefile.PL
+ Applied suggested patch.
+
+NETaa15222: VERSION patch for standard extensions (reprise)
+Files patched: ext/DB_File/DB_File.pm ext/DynaLoader/DynaLoader.pm ext/Fcntl/Fcntl.pm ext/GDBM_File/GDBM_File.pm ext/NDBM_File/NDBM_File.pm ext/ODBM_File/ODBM_File.pm ext/POSIX/POSIX.pm ext/SDBM_File/SDBM_File.pm ext/Safe/Safe.pm ext/Socket/Socket.pm
+ (same)
+
+NETaa15227: $i < 10000 should optimize to integer op
+From: Larry Wall
+Files patched: op.c op.c
+ The program
+
+ for ($i = 0; $i < 100000; $i++) {
+ push @foo, $i;
+ }
+
+ takes about one quarter the memory if the optimizer decides that it can
+ use an integer < comparison rather than floating point. It now does so
+ if one side is an integer constant and the other side a simple variable.
+ This should really help some of our benchmarks. You can still force a
+ floating point comparison by using 100000.0 instead.
+
+NETaa15228: CPerl-mode patch
+From: Ilya Zakharevich
+Files patched: emacs/cperl-mode.el
+ Applied suggested patch.
+
+NETaa15231: Symbol::qualify()
+From: Chip Salzenberg
+Files patched: ext/FileHandle/FileHandle.pm gv.c lib/SelectSaver.pm lib/Symbol.pm pp_hot.c
+ Applied suggested patch.
+
+NETaa15236: select select broke under use strict
+From: Chip Salzenberg
+Files patched: op.c
+ Instead of inventing a new bit, I just turned off the HINT_STRICT_REFS bit.
+ I don't think it's worthwhile distinguishing between qualified or unqualified
+ names to select.
+
+NETaa15237: use vars
+From: Larry Wall
+Files patched: MANIFEST gv.c lib/subs.pm lib/vars.pm sv.c
+
+NETaa15240: keep op names _and_ descriptions
+From: Chip Salzenberg
+Files patched: doio.c embed.h ext/Safe/Safe.pm ext/Safe/Safe.xs global.sym op.c opcode.h opcode.pl scope.c sv.c
+ Applied suggested patch.
+
+NETaa15259: study doesn't unset on string modification
+From: Larry Wall
+Files patched: mg.c pp.c
+ Piggybacked on m//g unset magic to unset the study too.
+
+NETaa15276: pick a better initial cxstack_max
+From: Chip Salzenberg
+Files patched: perl.c
+ Added fudge in, and made it calculate how many it could fit into (most of) 8K,
+ to avoid getting 16K of Kingsley malloc.
+
+NETaa15287: numeric comparison optimization adjustments
+From: Clark Cooper
+Files patched: op.c
+ Applied patch suggested by Chip, with liberalization to >= and <=.
+
+NETaa15299: couldn't eval string containing pod or __DATA__
+From: Andreas Koenig
+Also: Gisle Aas
+Files patched: toke.c
+ Basically, eval didn't know how to bypass pods correctly.
+
+NETaa15300: sv_backoff problems
+From: Paul Marquess
+Also: mtr
+Also: Chip Salzenberg
+Files patched: op.c sv.c sv.h
+ Applied suggested patch.
+
+NETaa15312: Avoid fclose(NULL)
+From: Chip Salzenberg
+Files patched: toke.c
+ Applied suggested patch.
+
+NETaa15318: didn't set up perl_init_i18nl14n for export
+From: Ilya Zakharevich
+Files patched: perl_exp.SH
+ Applied suggested patch.
+
+NETaa15331: File::Path::rmtree followed symlinks
+From: Andreas Koenig
+Files patched: lib/File/Path.pm
+ Added suggested patch, except I did
+
+ if (not -l $root and -d _) {
+
+ for efficiency, since if -d is true, the -l already called lstat on it.
+
+NETaa15339: sv_gets() didn't reset count
+From: alanburlison@unn.unisys.com
+Files patched: sv.c
+ Applied suggested patch.
+
+NETaa15341: differentiated importation of different types
+From: Chip Salzenberg
+Files patched: gv.c gv.h op.c perl.c pp.c pp_ctl.c sv.c sv.h toke.c
+ Applied suggested patch.
+
+NETaa15342: Consistent handling of e_{fp,tmpname}
+From: Chip Salzenberg
+Files patched: perl.c pp_ctl.c util.c
+ Applied suggested patch.
+
+NETaa15344: Safe gets confused about malloc on AIX
+From: Tim Bunce
+Files patched: ext/Safe/Safe.xs
+ Applied suggested patch.
+
+NETaa15348: -M upgrade
+From: Tim Bunce
+Files patched: perl.c pod/perlrun.pod
+ Applied suggested patch.
+
+NETaa15369: change in split optimization broke scalar context
+From: Ulrich Pfeifer
+Files patched: op.c
+ The earlier patch to make the split optimization pay attention to
+ OPpASSIGN_COMMON rearranged how the syntax tree is constructed, but kept
+ the wrong context flags. This causes pp_split() do do the wrong thing.
+
+NETaa15423: can't do subversion numbering because of %5.3f assumptions
+From: Andy Dougherty
+Files patched: configpm patchlevel.h perl.c perl.h pp_ctl.c
+ Removed the %5.3f assumptions where appropriate. patchlevel.h now
+ defines SUBVERSION, which if greater than 0 indicates a development version.
+
+NETaa15424: Sigsetjmp patch
+From: Kenneth Albanowski
+Files patched: Configure config_h.SH op.c perl.c perl.h pp_ctl.c util.c
+ Applied suggested patch.
+
+Needed to make install paths absolute.
+Files patched: installperl
+
+h2xs 1.14
+Files patched: utils/h2xs.PL
+
+makedir() looped on a symlink to a directory.
+Files patched: installperl
+
+xsubpp 1.932
+Files patched: lib/ExtUtils/xsubpp
+
+----------------------------------------------------------------
+Summary of user-visible Configure and build changes since 5.001:
+----------------------------------------------------------------
+
+Yet more enhancements and fixes have been made to the Configure and
+build process for perl. Most of these will not be visible to the
+ordinary user--they just make the process more robust and likely to
+work on a wider range of platforms.
+
+This is a brief summary of the most important changes. A more
+detailed description is given below.
+
+ Slightly changed installation directories. See INSTALL.
+
+ Include 5.000 - 5.001 upgrage notes :-) (see below). You might
+ want to read through them as well as these notes.
+
+ Install documentation for perl modules and pod2* translators. You can
+ now view perl module documentation with either your system's man(1)
+ program or with the supplied perldoc script.
+
+ Many hint file updates.
+
+ Improve and simplify detection of local libraries and header files.
+
+ Expand documentation of installation process in new INSTALL file.
+
+ Try to reduce Unixisms (such as SH file extraction) to enhance
+ portability to other platforms. There's still a long way to go.
+
+Upgrade Traps and Pitfalls:
+
+Since a lot has changed in the build process, you are probably best off
+starting with a fresh copy of the perl5.002 sources. In particular,
+your 5.000 or 5.001 config.sh will contain several variables that are no
+longer needed. Further, improvements in the Configure tests may mean
+that some of the answers will be different than they were in previous
+versions, and which answer to keep can be difficult to sort out.
+Therefore, you are probably better off ignoring your old config.sh, as
+in the following:
+
+ make -k distclean # (if you've built perl before)
+ rm -f config.sh # (in case distclean mysteriously fails)
+ sh Configure [whatever options you like]
+ make depend
+ make
+ make test
+
+This, and much more, is described in the new INSTALL file.
+
+Here are the detailed changes from 5.002beta1 to 5.002b2 in
+reverse chronolgical order:
+
+-------------
+Version 5.002beta2
+-------------
+
+This is patch.2b2 to perl5.002beta1.
+This takes you from 5.002beta1h to 5.002beta2.
+
+Renaming this as beta2 reflects _my_ feeling that it's time to
+wrap up things for the release of 5.002.
+
+Index: Changes.Conf
+
+ Include changes from patches 2b1a .. 2b1h, as well as this
+ patch.
+
+Index: Configure
+
+ Use nm -D on Linux with shared libraries, if the system
+ supports nm -D.
+
+Prereq: 3.0.1.8
+*** perl5.002b1h/Configure Thu Jan 4 11:14:37 1996
+--- perl5.002b2/Configure Thu Jan 11 17:09:13 1996
+
+Index: MANIFEST
+
+ Include Stub Readline library as part of new debugger.
+
+ Include hints file dec_osf for ODBM_File extension.
+
+*** perl5.002b1h/MANIFEST Wed Jan 3 14:37:54 1996
+--- perl5.002b2/MANIFEST Sat Jan 13 16:30:43 1996
+
+Index: configpm
+
+ Updates from Tim's -m/-M/-V patch.
+
+*** perl5.002b1h/configpm Tue Oct 31 11:51:52 1995
+--- perl5.002b2/configpm Fri Jan 12 10:53:34 1996
+
+Index: doop.c
+
+ Chip's patch to use STDCHAR and U8 nearly everywhere instead of
+ assuming 8-bit chars or ~(char) 0 == 0xff.
+
+*** perl5.002b1h/doop.c Wed Nov 15 15:08:01 1995
+--- perl5.002b2/doop.c Fri Jan 12 15:05:04 1996
+
+Index: embed.h
+
+ Updates from Tim's -m/-M/-V patch.
+
+*** perl5.002b1h/embed.h Thu Jan 4 13:28:08 1996
+--- perl5.002b2/embed.h Fri Jan 12 15:09:11 1996
+
+Index: ext/DB_File/Makefile.PL
+
+ Disable prototypes.
+ Disable pod2man.
+
+*** perl5.002b1h/ext/DB_File/Makefile.PL Tue Nov 14 14:14:17 1995
+--- perl5.002b2/ext/DB_File/Makefile.PL Tue Jan 9 16:54:17 1996
+
+*** perl5.002b1h/ext/DB_File/Makefile.PL Tue Nov 14 14:14:17 1995
+--- perl5.002b2/ext/DB_File/Makefile.PL Sat Jan 13 17:07:11 1996
+
+Index: ext/DynaLoader/Makefile.PL
+
+ Disable prototypes.
+ Disable pod2man.
+
+*** perl5.002b1h/ext/DynaLoader/Makefile.PL Tue Jun 6 12:24:37 1995
+--- perl5.002b2/ext/DynaLoader/Makefile.PL Sat Jan 13 17:16:34 1996
+
+Index: ext/Fcntl/Makefile.PL
+
+ Disable prototypes.
+ Disable pod2man.
+
+*** perl5.002b1h/ext/Fcntl/Makefile.PL Thu Jan 19 18:58:52 1995
+--- perl5.002b2/ext/Fcntl/Makefile.PL Sat Jan 13 17:16:38 1996
+
+Index: ext/GDBM_File/GDBM_File.pm
+
+ Make the NAME section a legal paragraph.
+
+*** perl5.002b1h/ext/GDBM_File/GDBM_File.pm Mon Nov 20 10:22:26 1995
+--- perl5.002b2/ext/GDBM_File/GDBM_File.pm Fri Jan 12 16:11:38 1996
+
+Index: ext/GDBM_File/Makefile.PL
+
+ Disable prototypes.
+ Disable pod2man.
+
+*** perl5.002b1h/ext/GDBM_File/Makefile.PL Wed Feb 22 14:36:36 1995
+--- perl5.002b2/ext/GDBM_File/Makefile.PL Sat Jan 13 17:08:02 1996
+
+Index: ext/NDBM_File/Makefile.PL
+
+ Disable prototypes.
+ Disable pod2man.
+
+*** perl5.002b1h/ext/NDBM_File/Makefile.PL Wed Feb 22 14:36:39 1995
+--- perl5.002b2/ext/NDBM_File/Makefile.PL Sat Jan 13 17:08:13 1996
+
+Index: ext/ODBM_File/Makefile.PL
+
+ Disable prototypes.
+ Disable pod2man.
+
+*** perl5.002b1h/ext/ODBM_File/Makefile.PL Mon Jun 5 15:03:44 1995
+--- perl5.002b2/ext/ODBM_File/Makefile.PL Sat Jan 13 17:08:22 1996
+
+Index: ext/ODBM_File/hints/dec_osf.pl
+
+ New file.
+
+*** /dev/null Sat Jan 13 16:48:01 1996
+--- perl5.002b2/ext/ODBM_File/hints/dec_osf.pl Sat Jan 13 16:30:01 1996
+
+Index: ext/POSIX/Makefile.PL
+
+ Disable prototypes.
+ Disable pod2man.
+
+*** perl5.002b1h/ext/POSIX/Makefile.PL Thu Jan 19 18:59:00 1995
+--- perl5.002b2/ext/POSIX/Makefile.PL Sat Jan 13 17:08:27 1996
+
+Index: ext/SDBM_File/Makefile.PL
+
+ Disable prototypes.
+ Disable pod2man.
+
+*** perl5.002b1h/ext/SDBM_File/Makefile.PL Tue Nov 14 11:16:43 1995
+--- perl5.002b2/ext/SDBM_File/Makefile.PL Sat Jan 13 17:16:49 1996
+
+Index: ext/SDBM_File/sdbm/sdbm.c
+
+ Give correct prototype for free.
+
+Prereq: 1.16
+*** perl5.002b1h/ext/SDBM_File/sdbm/sdbm.c Mon Nov 13 23:01:41 1995
+--- perl5.002b2/ext/SDBM_File/sdbm/sdbm.c Fri Jan 12 10:33:32 1996
+
+Index: ext/Safe/Makefile.PL
+
+ Disable prototypes.
+ Disable pod2man.
+
+*** perl5.002b1h/ext/Safe/Makefile.PL Tue Jan 2 15:43:53 1996
+--- perl5.002b2/ext/Safe/Makefile.PL Sat Jan 13 17:08:45 1996
+
+Index: ext/Safe/Safe.pm
+
+ Patch from Andreas.
+
+*** perl5.002b1h/ext/Safe/Safe.pm Tue Jan 2 15:45:27 1996
+--- perl5.002b2/ext/Safe/Safe.pm Fri Jan 12 10:52:33 1996
+
+Index: ext/Safe/Safe.xs
+
+ Patch for older compilers which had namespace confusion.
+
+*** perl5.002b1h/ext/Safe/Safe.xs Tue Jan 2 15:45:27 1996
+--- perl5.002b2/ext/Safe/Safe.xs Fri Jan 5 14:27:47 1996
+
+Index: ext/Socket/Makefile.PL
+
+ Disable prototypes.
+ Disable pod2man.
+
+*** perl5.002b1h/ext/Socket/Makefile.PL Sat Dec 2 16:23:52 1995
+--- perl5.002b2/ext/Socket/Makefile.PL Sat Jan 13 17:08:52 1996
+
+Index: ext/Socket/Socket.xs
+
+ Use unsigned shorts for ports.
+
+*** perl5.002b1h/ext/Socket/Socket.xs Sat Dec 2 15:46:20 1995
+--- perl5.002b2/ext/Socket/Socket.xs Mon Jan 8 21:59:52 1996
+
+Index: global.sym
+
+ Updates from Tim's -m/-M/-V patch.
+
+*** perl5.002b1h/global.sym Wed Jan 3 12:01:59 1996
+--- perl5.002b2/global.sym Fri Jan 12 10:53:34 1996
+
+Index: gv.c
+
+ Avoid VMS sprintf bug with buffers >1024.
+
+*** perl5.002b1h/gv.c Fri Dec 8 10:37:22 1995
+--- perl5.002b2/gv.c Fri Jan 12 15:27:27 1996
+
+Index: hints/aix.sh
+
+ Updated
+
+*** perl5.002b1h/hints/aix.sh Mon Nov 13 23:03:33 1995
+--- perl5.002b2/hints/aix.sh Fri Jan 12 12:09:48 1996
+
+Index: hints/irix_5.sh
+
+ Updated
+
+*** perl5.002b1h/hints/irix_5.sh Tue Jan 2 14:53:52 1996
+--- perl5.002b2/hints/irix_5.sh Tue Jan 9 16:05:11 1996
+
+Index: hints/linux.sh
+
+ Updated
+
+*** perl5.002b1h/hints/linux.sh Fri Jun 2 10:20:55 1995
+--- perl5.002b2/hints/linux.sh Fri Jan 12 11:43:52 1996
+
+Index: hints/machten.sh
+
+ Updated
+
+*** perl5.002b1h/hints/machten.sh Sun Mar 12 02:36:04 1995
+--- perl5.002b2/hints/machten.sh Wed Jan 10 14:53:32 1996
+
+Index: installman
+
+ Use File::Path::mkpath instead of our own makedir().
+ ./perl installman --man1dir=man1 could lead to infinte recursion
+ in old makedir() routine. Use the standard library instead.
+
+*** perl5.002b1h/installman Thu Dec 28 16:06:11 1995
+--- perl5.002b2/installman Thu Jan 11 16:12:30 1996
+
+Index: installperl
+
+ Use File::Path::mkpath instead of our own makedir().
+
+*** perl5.002b1h/installperl Wed Jan 3 14:33:57 1996
+--- perl5.002b2/installperl Thu Jan 11 16:12:16 1996
+
+Index: interp.sym
+
+ Updates from Tim's -m/-M/-V patch.
+
+*** perl5.002b1h/interp.sym Fri Nov 10 17:17:32 1995
+--- perl5.002b2/interp.sym Fri Jan 12 15:05:04 1996
+
+Index: lib/AutoLoader.pm
+
+ Undo Tim's tainting patch from beta1h.
+
+*** perl5.002b1h/lib/AutoLoader.pm Tue Jan 2 16:10:36 1996
+--- perl5.002b2/lib/AutoLoader.pm Fri Jan 5 16:02:28 1996
+
+Index: lib/Carp.pm
+*** perl5.002b1h/lib/Carp.pm Tue Jan 2 12:10:38 1996
+--- perl5.002b2/lib/Carp.pm Fri Jan 12 11:23:31 1996
+
+Index: lib/ExtUtils/MM_VMS.pm
+
+ Updated to MakeMaker-5.16.
+
+*** perl5.002b1h/lib/ExtUtils/MM_VMS.pm Tue Jan 2 14:07:10 1996
+--- perl5.002b2/lib/ExtUtils/MM_VMS.pm Thu Jan 4 21:00:46 1996
+
+Index: lib/ExtUtils/MakeMaker.pm
+
+ Updated to MakeMaker-5.16.
+
+Prereq: 1.129
+*** perl5.002b1h/lib/ExtUtils/MakeMaker.pm Tue Jan 2 14:07:10 1996
+--- perl5.002b2/lib/ExtUtils/MakeMaker.pm Wed Jan 10 16:13:05 1996
+
+Index: lib/File/Find.pm
+
+ Fixed exporting of symbols to work.
+
+*** perl5.002b1h/lib/File/Find.pm Wed Nov 15 15:20:03 1995
+--- perl5.002b2/lib/File/Find.pm Wed Jan 10 14:46:24 1996
+
+Index: lib/I18N/Collate.pm
+
+ Updated documentation to match program.
+
+*** perl5.002b1h/lib/I18N/Collate.pm Fri Jun 2 11:30:49 1995
+--- perl5.002b2/lib/I18N/Collate.pm Fri Jan 5 16:05:26 1996
+
+Index: lib/Term/ReadLine.pm
+
+ Stub new file to interface to various readline packages, or
+ give stub functions if none are found.
+
+*** /dev/null Sat Jan 13 16:48:01 1996
+--- perl5.002b2/lib/Term/ReadLine.pm Fri Jan 12 11:23:31 1996
+
+Index: lib/dumpvar.pl
+
+ Ilya's new debugger.
+
+*** perl5.002b1h/lib/dumpvar.pl Tue Oct 18 12:36:00 1994
+--- perl5.002b2/lib/dumpvar.pl Fri Jan 12 11:23:31 1996
+
+Index: lib/perl5db.pl
+
+ Ilya's new debugger.
+
+*** perl5.002b1h/lib/perl5db.pl Tue Jan 2 16:30:33 1996
+--- perl5.002b2/lib/perl5db.pl Fri Jan 12 11:23:31 1996
+
+Index: lib/sigtrap.pm
+
+ Ilya's new debugger.
+
+*** perl5.002b1h/lib/sigtrap.pm Thu May 25 11:20:13 1995
+--- perl5.002b2/lib/sigtrap.pm Fri Jan 12 11:23:31 1996
+
+Index: miniperlmain.c
+
+ More robust i18nl14n() function from jhi.
+
+*** perl5.002b1h/miniperlmain.c Thu Jan 4 12:03:37 1996
+--- perl5.002b2/miniperlmain.c Mon Jan 8 22:00:19 1996
+
+Index: myconfig
+
+ Updates from Tim's -m/-M/-V patch.
+
+*** perl5.002b1h/myconfig Tue Apr 4 12:13:21 1995
+--- perl5.002b2/myconfig Fri Jan 12 10:53:35 1996
+
+Index: op.c
+
+ Chip's U8/STDCHAR patch.
+
+*** perl5.002b1h/op.c Wed Jan 3 14:17:01 1996
+--- perl5.002b2/op.c Fri Jan 12 15:05:05 1996
+
+Index: perl.c
+
+ Change Copyright date to include 1996. Hope you don't mind.
+
+ Presumptively call this beta2.
+
+*** perl5.002b1h/perl.c Thu Jan 4 15:13:53 1996
+--- perl5.002b2/perl.c Fri Jan 12 15:05:05 1996
+
+Index: perl.h
+
+ Updates from Tim's -m/-M/-V patch.
+
+*** perl5.002b1h/perl.h Wed Jan 3 12:21:55 1996
+--- perl5.002b2/perl.h Fri Jan 12 15:05:04 1996
+
+Index: pod/Makefile
+
+ Use PERL=../miniperl
+
+*** perl5.002b1h/pod/Makefile Wed Jan 3 15:06:41 1996
+--- perl5.002b2/pod/Makefile Fri Jan 5 14:14:30 1996
+
+Index: pod/perlembed.pod
+
+ Give correct usage for the 5th arg to perl_parse (don't pass
+ env).
+
+*** perl5.002b1h/pod/perlembed.pod Thu Dec 28 16:34:07 1995
+--- perl5.002b2/pod/perlembed.pod Tue Jan 9 16:02:51 1996
+
+Index: pod/perlfunc.pod
+
+ Work around a pod2man complaint about the -X function.
+
+*** perl5.002b1h/pod/perlfunc.pod Tue Jan 2 15:39:26 1996
+--- perl5.002b2/pod/perlfunc.pod Fri Jan 12 11:04:15 1996
+
+*** perl5.002b1h/pod/perlfunc.pod Tue Jan 2 15:39:26 1996
+--- perl5.002b2/pod/perlfunc.pod Fri Jan 12 11:04:15 1996
+
+Index: pod/perlovl.pod
+
+ Add DESCRIPTION to head1 line.
+
+*** perl5.002b1h/pod/perlovl.pod Thu Dec 28 16:34:13 1995
+--- perl5.002b2/pod/perlovl.pod Thu Jan 11 17:11:16 1996
+
+Index: pod/perlrun.pod
+
+ Updates from Tim's -m/-M/-V patch.
+
+*** perl5.002b1h/pod/perlrun.pod Thu Dec 28 16:34:15 1995
+--- perl5.002b2/pod/perlrun.pod Fri Jan 12 10:53:35 1996
+
+Index: pp_ctl.c
+
+ Debugger patch.
+
+*** perl5.002b1h/pp_ctl.c Wed Jan 3 12:23:13 1996
+--- perl5.002b2/pp_ctl.c Fri Jan 12 15:05:05 1996
+
+Index: t/lib/posix.t
+
+ Not having POSIX shouldn't result in test failing TEST harness.
+
+*** perl5.002b1h/t/lib/posix.t Mon Jan 16 22:27:33 1995
+--- perl5.002b2/t/lib/posix.t Tue Jan 9 15:33:14 1996
+
+Index: t/lib/safe.t
+
+ Not having Safe shouldn't result in test failing TEST harness.
+
+*** perl5.002b1h/t/lib/safe.t Tue Jan 2 15:43:53 1996
+--- perl5.002b2/t/lib/safe.t Tue Jan 9 15:35:43 1996
+
+Index: t/lib/socket.t
+
+ Not having Socket shouldn't result in test failing TEST harness.
+
+*** perl5.002b1h/t/lib/socket.t Fri Dec 8 11:16:01 1995
+--- perl5.002b2/t/lib/socket.t Tue Jan 9 15:35:51 1996
+
+Index: t/op/time.t
+
+ Test missed year-end wrap-around by one day.
+
+*** perl5.002b1h/t/op/time.t Tue Oct 18 12:46:31 1994
+--- perl5.002b2/t/op/time.t Wed Jan 10 16:04:41 1996
+
+Index: toke.c
+
+ Chip's U8/STDCHAR patch.
+
+ Tim's "add a ; after PERL5DB" patch.
+
+*** perl5.002b1h/toke.c Wed Dec 6 13:24:19 1995
+--- perl5.002b2/toke.c Fri Jan 12 15:05:06 1996
+
+Index: utils/h2xs.PL
+
+ Updated to 1.13. Include Changes template file.
+
+*** perl5.002b1h/utils/h2xs.PL Tue Jan 2 13:50:55 1996
+--- perl5.002b2/utils/h2xs.PL Thu Jan 11 16:59:48 1996
+
+Index: writemain.SH
+
+ Updates from Tim's -m/-M/-V patch.
+
+*** perl5.002b1h/writemain.SH Sat Nov 18 15:51:55 1995
+--- perl5.002b2/writemain.SH Fri Jan 12 10:53:35 1996
+
+-------------
+Version 5.002b1h
+-------------
+
+This is patch.2b1h to perl5.002beta1. This is mainly a clean-up
+patch. No progress is made dealing with memory leaks or
+optimizations, though I have used #define STRANGE_MALLOC to
+work around at least some problems.
+
+Index: Configure
+
+ Upgraded to metaconfig patchlevel 60.
+
+ Add in usesafe variable to include or exclude the Safe extension.
+
+ Test for sigaction().
+
+ Check for pager. This was actually accidental since perldoc.PL
+ mentions $pager and metaconfig has a unit to check for the
+ user's pager. In retrospect, I decided the Configure check
+ didn't do any harm and some extension writers might decide to
+ use it.
+
+ Always put man1dir under $prefix unless a command line
+ override is used.
+
+ Allow command-line overrides of $man1ext and $man3ext.
+
+
+ Allow man1dir and man3dir names like .../man.1 instead of
+ just .../man1.
+
+ Lots of rearrangements of various pieces of Configure.
+ This might be because I ran metaconfig on a different
+ architecture.
+
+ libc searching now honors $libpth. Previously, it (almost)
+ always looked in /usr/lib before checking /lib.
+
+ Only prompt user if voidflags is not 15. If voidflags is 15, then
+ we presume all is well.
+
+
+Prereq: 3.0.1.8
+*** perl5.002b1g/Configure Fri Dec 8 11:23:56 1995
+--- perl5.002b1h/Configure Thu Jan 4 11:14:37 1996
+
+Index: INSTALL
+
+ Document how to skip various extensions.
+
+ Indicate that site_perl is typically under (not beside)
+ /usr/local/lib/perl5.
+
+ Mention how to avoid nm extraction.
+
+
+*** perl5.002b1g/INSTALL Tue Nov 21 22:54:28 1995
+--- perl5.002b1h/INSTALL Thu Jan 4 11:06:28 1996
+
+Index: MANIFEST
+
+ Rearrange files some. Try to move .PL utilities to a separate
+ utils/ subdirectory.
+
+ Merge c2ph.PL and c2ph.doc.
+
+ Add the Safe extension.
+
+*** perl5.002b1g/MANIFEST Fri Jan 5 11:41:50 1996
+--- perl5.002b1h/MANIFEST Wed Jan 3 14:37:54 1996
+
+Index: Makefile.SH
+
+ Now builds .PL utilities in the utils/ subdirectory.
+
+*** perl5.002b1g/Makefile.SH Fri Dec 8 10:36:33 1995
+--- perl5.002b1h/Makefile.SH Wed Jan 3 14:28:30 1996
+
+Index: README.vms
+
+ Updated.
+
+*** perl5.002b1g/README.vms Wed Nov 15 14:23:10 1995
+--- perl5.002b1h/README.vms Tue Jan 2 16:33:02 1996
+
+Index: XSUB.h
+
+ Updated to match xsubpp-1.929.
+
+*** perl5.002b1g/XSUB.h Wed Dec 6 13:25:26 1995
+--- perl5.002b1h/XSUB.h Tue Jan 2 11:57:57 1996
+
+Index: config_h.SH
+
+ Check for HAS_SIGACCTION
+
+ Add STARTPERL define for C code (specifically, a2p).
+
+Prereq: 3.0.1.4
+*** perl5.002b1g/config_h.SH Fri Dec 8 11:23:56 1995
+--- perl5.002b1h/config_h.SH Thu Jan 4 11:14:37 1996
+
+Index: doio.c
+
+ VMS changes for kill.
+
+*** perl5.002b1g/doio.c Wed Nov 15 14:36:12 1995
+--- perl5.002b1h/doio.c Tue Jan 2 16:27:07 1996
+
+Index: embed.h
+
+ Auto-generated from global.sym and interp.sym.
+
+*** perl5.002b1g/embed.h Wed Nov 15 14:48:47 1995
+--- perl5.002b1h/embed.h Thu Jan 4 13:28:08 1996
+
+Index: ext/DynaLoader/DynaLoader.pm
+
+ VMS-specific updates.
+
+*** perl5.002b1g/ext/DynaLoader/DynaLoader.pm Fri Nov 10 11:49:00 1995
+--- perl5.002b1h/ext/DynaLoader/DynaLoader.pm Tue Jan 2 16:28:02 1996
+
+Index: ext/DynaLoader/dl_vms.xs
+
+ Updated to Oct 31, 1995 version.
+
+*** perl5.002b1g/ext/DynaLoader/dl_vms.xs Tue Oct 31 11:06:06 1995
+--- perl5.002b1h/ext/DynaLoader/dl_vms.xs Tue Jan 2 16:27:32 1996
+
+Index: global.sym
+
+ Added maxo and save_pptr items.
+
+*** perl5.002b1g/global.sym Wed Nov 15 14:58:14 1995
+--- perl5.002b1h/global.sym Wed Jan 3 12:01:59 1996
+
+Index: hints/README.hints
+
+ List of tested systems updated a little.
+
+*** perl5.002b1g/hints/README.hints Fri May 5 14:12:06 1995
+--- perl5.002b1h/hints/README.hints Tue Dec 12 20:03:36 1995
+
+Index: hints/irix_5.sh
+
+ Note SGI stdio/malloc related problem.
+
+*** perl5.002b1g/hints/irix_5.sh Fri May 5 14:07:52 1995
+--- perl5.002b1h/hints/irix_5.sh Tue Jan 2 14:53:52 1996
+
+Index: hints/irix_6.sh
+
+ Address change.
+
+ Note SGI stdio/malloc related problem.
+
+*** perl5.002b1g/hints/irix_6.sh Fri May 5 14:08:41 1995
+--- perl5.002b1h/hints/irix_6.sh Tue Jan 2 14:54:04 1996
+
+Index: hints/irix_6_2.sh
+
+ Address change.
+
+*** perl5.002b1g/hints/irix_6_2.sh Mon Nov 20 11:16:55 1995
+--- perl5.002b1h/hints/irix_6_2.sh Tue Jan 2 14:49:45 1996
+
+Index: hints/os2.sh
+
+ Updated.
+
+*** perl5.002b1g/hints/os2.sh Tue Nov 14 11:07:33 1995
+--- perl5.002b1h/hints/os2.sh Tue Dec 26 17:51:16 1995
+
+Index: installman
+
+ Use fork if available.
+
+*** perl5.002b1g/installman Fri Jan 5 11:41:52 1996
+--- perl5.002b1h/installman Thu Dec 28 16:06:11 1995
+
+Index: installperl
+
+ Use new location of utility scripts.
+
+ Eliminate double '//' and extra "".
+
+*** perl5.002b1g/installperl Mon Nov 20 12:55:03 1995
+--- perl5.002b1h/installperl Wed Jan 3 14:33:57 1996
+
+Index: lib/AutoLoader.pm
+
+ Avoid tainting problems.
+
+*** perl5.002b1g/lib/AutoLoader.pm Wed Nov 15 15:04:59 1995
+--- perl5.002b1h/lib/AutoLoader.pm Tue Jan 2 16:10:36 1996
+
+Index: lib/Carp.pm
+
+ Honor trailing \n in messages, as is done for warn().
+
+*** perl5.002b1g/lib/Carp.pm Thu May 25 11:16:07 1995
+--- perl5.002b1h/lib/Carp.pm Tue Jan 2 12:10:38 1996
+
+Index: lib/Cwd.pm
+
+ VMS patches.
+
+*** perl5.002b1g/lib/Cwd.pm Fri Jan 5 11:41:52 1996
+--- perl5.002b1h/lib/Cwd.pm Tue Jan 2 16:28:57 1996
+
+Index: lib/Exporter.pm
+
+ Include Tim Bunce's enhanced Exporter. I also tried to
+ resolve the two copies of documentation that I had.
+
+*** perl5.002b1g/lib/Exporter.pm Fri Jan 5 11:41:52 1996
+--- perl5.002b1h/lib/Exporter.pm Thu Jan 4 14:02:08 1996
+
+Index: lib/ExtUtils/MM_VMS.pm
+
+ New file. Incorporates VMS-specific items into MakeMaker.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/lib/ExtUtils/MM_VMS.pm Tue Jan 2 14:07:10 1996
+
+Index: lib/ExtUtils/MakeMaker.pm
+Prereq: 1.116
+
+ Updated from 5.12 to 5.16.
+
+*** perl5.002b1g/lib/ExtUtils/MakeMaker.pm Fri Jan 5 11:41:53 1996
+--- perl5.002b1h/lib/ExtUtils/MakeMaker.pm Tue Jan 2 14:07:10 1996
+
+Index: lib/ExtUtils/Manifest.pm
+
+ Updated from MakeMaker 5.12 to 5.16.
+
+*** perl5.002b1g/lib/ExtUtils/Manifest.pm Fri Jan 5 11:41:54 1996
+--- perl5.002b1h/lib/ExtUtils/Manifest.pm Tue Jan 2 14:07:10 1996
+
+Index: lib/ExtUtils/Mkbootstrap.pm
+
+ Updated from MakeMaker 5.12 to 5.16.
+
+*** perl5.002b1g/lib/ExtUtils/Mkbootstrap.pm Fri Jan 5 11:41:54 1996
+--- perl5.002b1h/lib/ExtUtils/Mkbootstrap.pm Tue Jan 2 14:07:10 1996
+
+Index: lib/ExtUtils/xsubpp
+
+ Updated from xsubpp-1.924 to 1.929.
+
+*** perl5.002b1g/lib/ExtUtils/xsubpp Sun Nov 26 16:04:50 1995
+--- perl5.002b1h/lib/ExtUtils/xsubpp Tue Jan 2 16:29:59 1996
+
+Index: lib/File/Path.pm
+
+ VMS-specific changes.
+
+*** perl5.002b1g/lib/File/Path.pm Wed Nov 15 15:20:31 1995
+--- perl5.002b1h/lib/File/Path.pm Tue Jan 2 16:30:21 1996
+
+Index: lib/Pod/Text.pm
+
+ New file. This was created by Dov (???) and enhanced
+ by Kenneth Albanowski, but all based on Tom C.'s pod2text.
+ Unfortunately, they used a version of pod2text earlier than
+ the one in patch.2b1g. I've tried to straighten this all out.
+
+ Equally unfortunately, we've all left Tom as the AUTHOR, even
+ though we can't hold him responsible for errors he didn't
+ introduce. Oh well.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/lib/Pod/Text.pm Thu Jan 4 14:16:50 1996
+
+Index: lib/Sys/Hostname.pm
+
+ VMS-specific changes.
+
+*** perl5.002b1g/lib/Sys/Hostname.pm Fri Jan 5 11:41:55 1996
+--- perl5.002b1h/lib/Sys/Hostname.pm Tue Jan 2 16:30:49 1996
+
+Index: lib/diagnostics.pm
+
+ A patch from Tim Bunce (?)
+
+*** perl5.002b1g/lib/diagnostics.pm Wed Dec 6 13:58:42 1995
+--- perl5.002b1h/lib/diagnostics.pm Tue Jan 2 12:10:37 1996
+
+Index: lib/perl5db.pl
+
+ VMS-specific changes.
+
+*** perl5.002b1g/lib/perl5db.pl Wed Nov 15 22:37:45 1995
+--- perl5.002b1h/lib/perl5db.pl Tue Jan 2 16:30:33 1996
+
+Index: lib/splain
+
+ Fix some old typos.
+
+*** perl5.002b1g/lib/splain Tue Nov 14 16:16:36 1995
+--- perl5.002b1h/lib/splain Tue Jan 2 12:10:37 1996
+
+Index: makeaperl.SH
+
+ Use the 'new' startperl variable.
+
+*** perl5.002b1g/makeaperl.SH Thu Jun 1 11:20:52 1995
+--- perl5.002b1h/makeaperl.SH Tue Jan 2 12:11:28 1996
+
+Index: mg.c
+
+ Set up a reliable signal handler, courtesy of Kenneth Albanowski.
+ This needs to be documented still. The idea is that even on
+ System V systems, you won't have to reset the signal handler as
+ the first action inside your signal handler.
+
+*** perl5.002b1g/mg.c Wed Nov 15 15:44:10 1995
+--- perl5.002b1h/mg.c Thu Jan 4 13:49:12 1996
+
+Index: minimod.pl
+
+ Give a proper NAME description.
+
+*** perl5.002b1g/minimod.pl Sun Nov 26 16:19:55 1995
+--- perl5.002b1h/minimod.pl Tue Jan 2 14:30:24 1996
+
+Index: miniperlmain.c
+
+ Better locale handling, courtesy of jhi.
+
+ Include a proper cast of NULL for non-prototyping compilers.
+
+*** perl5.002b1g/miniperlmain.c Sat Nov 18 15:48:10 1995
+--- perl5.002b1h/miniperlmain.c Thu Jan 4 12:03:37 1996
+
+Index: op.c
+
+ Turn on USE_OP_MASK by default for the Safe extension. I'll be
+ interested in benchmark results with this on and off.
+
+*** perl5.002b1g/op.c Wed Nov 15 22:10:36 1995
+--- perl5.002b1h/op.c Wed Jan 3 14:17:01 1996
+
+Index: os2/Makefile.SHs
+
+ New file.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/os2/Makefile.SHs Sun Dec 24 13:55:22 1995
+
+Index: os2/README
+
+ Updated.
+
+*** perl5.002b1g/os2/README Tue Nov 14 14:42:13 1995
+--- perl5.002b1h/os2/README Tue Dec 26 18:31:32 1995
+
+Index: os2/diff.MANIFEST
+
+ New file.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/os2/diff.MANIFEST Tue Dec 26 19:54:12 1995
+
+Index: os2/diff.Makefile
+
+ Updated
+
+*** perl5.002b1g/os2/diff.Makefile Tue Nov 14 11:09:29 1995
+--- perl5.002b1h/os2/diff.Makefile Fri Dec 8 00:09:56 1995
+
+Index: os2/diff.c2ph
+
+ New file.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/os2/diff.c2ph Thu Dec 7 15:25:52 1995
+
+Index: os2/diff.configure
+
+ Updated.
+
+*** perl5.002b1g/os2/diff.configure Sun Nov 12 01:31:34 1995
+--- perl5.002b1h/os2/diff.configure Tue Dec 26 19:57:08 1995
+
+Index: os2/diff.db_file
+
+ New file.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/os2/diff.db_file Tue Dec 19 02:14:54 1995
+
+Index: os2/diff.init
+
+ New file.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/os2/diff.init Sun Nov 26 15:05:48 1995
+
+Index: os2/diff.installman
+
+ New file.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/os2/diff.installman Wed Nov 22 03:50:26 1995
+
+Index: os2/diff.installperl
+
+ Updated.
+
+*** perl5.002b1g/os2/diff.installperl Tue Nov 14 11:09:28 1995
+--- perl5.002b1h/os2/diff.installperl Wed Nov 22 02:59:58 1995
+
+Index: os2/diff.mkdep
+
+ Updated.
+
+*** perl5.002b1g/os2/diff.mkdep Tue Nov 14 11:09:28 1995
+--- perl5.002b1h/os2/diff.mkdep Sun Nov 26 15:00:24 1995
+
+Index: os2/diff.rest
+
+ New file.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/os2/diff.rest Thu Dec 7 16:03:26 1995
+
+Index: os2/diff.x2pMakefile
+
+ Updated.
+
+*** perl5.002b1g/os2/diff.x2pMakefile Tue Nov 14 11:09:29 1995
+--- perl5.002b1h/os2/diff.x2pMakefile Wed Nov 22 21:55:42 1995
+
+Index: os2/notes
+
+ New file.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/os2/notes Tue Dec 26 19:55:30 1995
+
+Index: os2/os2.c
+
+ Updated.
+
+*** perl5.002b1g/os2/os2.c Tue Nov 14 11:07:33 1995
+--- perl5.002b1h/os2/os2.c Sun Dec 24 13:43:02 1995
+
+Index: os2/os2ish.h
+
+ Updated.
+
+*** perl5.002b1g/os2/os2ish.h Tue Nov 14 11:07:33 1995
+--- perl5.002b1h/os2/os2ish.h Mon Dec 18 16:17:38 1995
+
+Index: os2/perl2cmd.pl
+
+ New file.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/os2/perl2cmd.pl Tue Dec 19 11:20:42 1995
+
+Index: perl.c
+
+ Updated to say beta1h.
+
+ Move VMS env code.
+
+*** perl5.002b1g/perl.c Fri Jan 5 11:41:56 1996
+--- perl5.002b1h/perl.c Thu Jan 4 15:13:53 1996
+
+Index: perl.h
+
+ 5.002beta1 attempted some memory optimizations, but unfortunately
+ they can result in a memory leak problem. This can be
+ avoided by #define STRANGE_MALLOC. I do that here until
+ consensus is reached on a better strategy for handling the
+ memory optimizations.
+
+ Include maxo for the maximum number of operations (needed
+ for the Safe extension).
+
+*** perl5.002b1g/perl.h Wed Nov 15 17:13:16 1995
+--- perl5.002b1h/perl.h Wed Jan 3 12:21:55 1996
+
+Index: pod/Makefile
+
+ Include -I../lib so that pod2* can find the appropriate libraries.
+
+ The pod names are once again sorted.
+
+ The PERL line is wrong. It should read
+ PERL = ../miniperl
+ This file is automatically generated, but I happened to do it on
+ a system without miniperl avaialable, so my script fell back on
+ the perl default.
+
+*** perl5.002b1g/pod/Makefile Fri Jan 5 11:41:56 1996
+--- perl5.002b1h/pod/Makefile Wed Jan 3 15:06:41 1996
+
+Index: pod/perlmod.pod
+
+ Mention the Safe extension.
+
+*** perl5.002b1g/pod/perlmod.pod Fri Jan 5 11:41:59 1996
+--- perl5.002b1h/pod/perlmod.pod Thu Jan 4 13:52:14 1996
+
+Index: pod/perltoc.pod
+
+ Rebuilt using pod/buildtoc and fmt.
+
+*** perl5.002b1g/pod/perltoc.pod Fri Jan 5 11:42:00 1996
+--- perl5.002b1h/pod/perltoc.pod Thu Jan 4 14:04:20 1996
+
+Index: pod/pod2text.PL
+*** perl5.002b1g/pod/pod2text.PL Fri Jan 5 11:42:01 1996
+--- perl5.002b1h/pod/pod2text.PL Tue Jan 2 14:28:24 1996
+
+Index: pp_sys.c
+
+ VMS changes ?
+
+*** perl5.002b1g/pp_sys.c Wed Nov 15 21:51:33 1995
+--- perl5.002b1h/pp_sys.c Tue Jan 2 16:32:50 1996
+
+Index: t/lib/safe.t
+
+ New test.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/t/lib/safe.t Tue Jan 2 15:43:53 1996
+
+Index: utils/Makefile
+
+ New file to build the utilities.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/utils/Makefile Wed Jan 3 14:06:18 1996
+
+Index: utils/c2ph.PL
+
+ Ungracefully merge the old c2ph.doc in as an embedded pod.
+
+ Delete lots of trailing spaces and tabs that have crept in.
+
+Prereq: 1.7
+*** perl5.002b1g/utils/c2ph.PL Mon Nov 20 12:36:17 1995
+--- perl5.002b1h/utils/c2ph.PL Wed Jan 3 14:05:41 1996
+
+Index: utils/h2ph.PL
+
+ Add patch for AIX files which sometimes have #include<foo.h>,
+ i.e., no spaces after the word 'include'.
+
+*** perl5.002b1g/utils/h2ph.PL Mon Nov 27 10:14:50 1995
+--- perl5.002b1h/utils/h2ph.PL Tue Jan 2 16:13:31 1996
+
+Index: utils/h2xs.PL
+
+ Add version stuff.
+
+ The old version didn't have a number. This one's called 1.12.
+
+*** perl5.002b1g/utils/h2xs.PL Sun Nov 19 22:37:58 1995
+--- perl5.002b1h/utils/h2xs.PL Tue Jan 2 13:50:55 1996
+
+Index: utils/perlbug.PL
+
+ New utility.
+
+*** /dev/null Fri Jan 5 12:48:01 1996
+--- perl5.002b1h/utils/perlbug.PL Sat Nov 18 16:15:13 1995
+
+Index: utils/perldoc.PL
+
+ Better error handling.
+
+ Updated to use Pod::Text, if available.
+
+ More VMS friendly.
+
+ New -u option .
+
+*** perl5.002b1g/utils/perldoc.PL Tue Nov 14 14:57:57 1995
+--- perl5.002b1h/utils/perldoc.PL Tue Jan 2 14:28:08 1996
+
+Index: utils/pl2pm.PL
+
+ Changed into a .PL extract file for proper setting of
+ $startperl.
+
+ Add _minimal_ pod documentation.
+
+*** perl5.002b1g/utils/pl2pm.PL Mon Jan 16 23:45:07 1995
+--- perl5.002b1h/utils/pl2pm.PL Wed Jan 3 14:14:57 1996
+
+Index: vms/Makefile
+
+ Updated for VMS.
+
+*** perl5.002b1g/vms/Makefile Wed Nov 15 22:05:15 1995
+--- perl5.002b1h/vms/Makefile Tue Jan 2 16:33:53 1996
+
+Index: vms/config.vms
+
+ Updated for VMS.
+
+*** perl5.002b1g/vms/config.vms Wed Nov 15 22:05:26 1995
+--- perl5.002b1h/vms/config.vms Tue Jan 2 16:33:09 1996
+
+Index: vms/descrip.mms
+
+ Updated for VMS.
+
+*** perl5.002b1g/vms/descrip.mms Wed Nov 15 22:05:38 1995
+--- perl5.002b1h/vms/descrip.mms Tue Jan 2 16:33:18 1996
+
+Index: vms/ext/Filespec.pm
+
+ Updated for VMS.
+
+*** perl5.002b1g/vms/ext/Filespec.pm Sun Mar 12 03:14:26 1995
+--- perl5.002b1h/vms/ext/Filespec.pm Tue Jan 2 16:33:25 1996
+
+Index: vms/ext/MM_VMS.pm
+
+ Updated for VMS. This might be obsolete now that we have
+ lib/ExtUtils/MM_VMS.pm.
+
+*** perl5.002b1g/vms/ext/MM_VMS.pm Wed Nov 15 22:05:48 1995
+--- perl5.002b1h/vms/ext/MM_VMS.pm Tue Jan 2 16:33:32 1996
+
+Index: vms/gen_shrfls.pl
+
+ Updated for VMS.
+
+*** perl5.002b1g/vms/gen_shrfls.pl Wed Nov 15 22:06:27 1995
+--- perl5.002b1h/vms/gen_shrfls.pl Tue Jan 2 16:33:47 1996
+
+Index: vms/genconfig.pl
+
+ Updated for VMS.
+
+*** perl5.002b1g/vms/genconfig.pl Sun Mar 12 03:14:36 1995
+--- perl5.002b1h/vms/genconfig.pl Tue Jan 2 16:33:39 1996
+
+Index: vms/perlvms.pod
+
+ Updated for VMS.
+
+*** perl5.002b1g/vms/perlvms.pod Wed Nov 15 22:06:32 1995
+--- perl5.002b1h/vms/perlvms.pod Tue Jan 2 16:33:59 1996
+
+Index: vms/test.com
+
+ Updated for VMS.
+
+*** perl5.002b1g/vms/test.com Wed Nov 15 22:06:59 1995
+--- perl5.002b1h/vms/test.com Tue Jan 2 16:34:07 1996
+
+Index: vms/vms.c
+
+ Updated for VMS.
+
+Prereq: 2.2
+*** perl5.002b1g/vms/vms.c Wed Nov 15 22:07:10 1995
+--- perl5.002b1h/vms/vms.c Tue Jan 2 16:34:13 1996
+
+Index: vms/vmsish.h
+
+ Updated for VMS.
+
+*** perl5.002b1g/vms/vmsish.h Wed Nov 15 22:07:24 1995
+--- perl5.002b1h/vms/vmsish.h Tue Jan 2 16:34:20 1996
+
+Index: vms/writemain.pl
+
+ Updated for VMS.
+
+*** perl5.002b1g/vms/writemain.pl Mon Mar 6 20:00:18 1995
+--- perl5.002b1h/vms/writemain.pl Tue Jan 2 16:34:26 1996
+
+Index: x2p/a2py.c
+
+ Use new config_h.SH STARTPERL #define.
+
+*** perl5.002b1g/x2p/a2py.c Tue Mar 7 11:53:10 1995
+--- perl5.002b1h/x2p/a2py.c Tue Jan 2 12:11:28 1996
+
+Index: x2p/find2perl.PL
+
+ Add missing "" around $Config{startperl}.
+
+*** perl5.002b1g/x2p/find2perl.PL Sun Nov 19 23:11:58 1995
+--- perl5.002b1h/x2p/find2perl.PL Tue Jan 2 12:11:27 1996
+
+Index: x2p/s2p.PL
+
+ Add missing "" around $Config{startperl}.
+
+*** perl5.002b1g/x2p/s2p.PL Sun Nov 19 23:14:59 1995
+--- perl5.002b1h/x2p/s2p.PL Tue Jan 2 12:11:27 1996
+
+
+-------------
+Version 5.002b1g
+-------------
+
+This is patch.2b1g to perl5.002beta1.
+
+This patch is just my packaging of Tom's documentation patches
+he released as patch.2b1g.
+
+Index: MANIFEST
+*** perl5.002b1f/MANIFEST Fri Dec 8 13:34:53 1995
+--- perl5.002b1g/MANIFEST Thu Dec 21 13:00:58 1995
+
+Index: ext/DB_File/DB_File.pm
+*** perl5.002b1f/ext/DB_File/DB_File.pm Tue Nov 14 14:14:25 1995
+--- perl5.002b1g/ext/DB_File/DB_File.pm Thu Dec 21 13:00:58 1995
+
+Index: ext/POSIX/POSIX.pm
+*** perl5.002b1f/ext/POSIX/POSIX.pm Fri Dec 8 10:23:54 1995
+--- perl5.002b1g/ext/POSIX/POSIX.pm Thu Dec 21 13:00:58 1995
+
+Index: ext/POSIX/POSIX.pod
+*** perl5.002b1f/ext/POSIX/POSIX.pod Fri Dec 8 10:30:40 1995
+--- perl5.002b1g/ext/POSIX/POSIX.pod Thu Dec 21 13:00:59 1995
+
+Index: ext/Safe/Makefile.PL
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/ext/Safe/Makefile.PL Thu Dec 21 13:01:00 1995
+
+Index: ext/Safe/Safe.pm
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/ext/Safe/Safe.pm Thu Dec 21 13:01:00 1995
+
+Index: ext/Safe/Safe.xs
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/ext/Safe/Safe.xs Thu Dec 21 13:01:00 1995
+
+Index: ext/Socket/Socket.pm
+*** perl5.002b1f/ext/Socket/Socket.pm Wed Dec 6 13:58:41 1995
+--- perl5.002b1g/ext/Socket/Socket.pm Thu Dec 21 13:01:00 1995
+
+Index: installman
+*** perl5.002b1f/installman Mon Nov 6 11:16:43 1995
+--- perl5.002b1g/installman Thu Dec 21 13:01:00 1995
+
+Index: lib/AutoSplit.pm
+*** perl5.002b1f/lib/AutoSplit.pm Wed Nov 15 15:06:19 1995
+--- perl5.002b1g/lib/AutoSplit.pm Thu Dec 21 13:01:01 1995
+
+Index: lib/Cwd.pm
+*** perl5.002b1f/lib/Cwd.pm Fri Dec 8 10:42:46 1995
+--- perl5.002b1g/lib/Cwd.pm Thu Dec 21 13:01:01 1995
+
+Index: lib/Devel/SelfStubber.pm
+*** perl5.002b1f/lib/Devel/SelfStubber.pm Sun Nov 26 16:59:51 1995
+--- perl5.002b1g/lib/Devel/SelfStubber.pm Thu Dec 21 13:01:01 1995
+
+Index: lib/Env.pm
+*** perl5.002b1f/lib/Env.pm Tue Oct 18 12:34:43 1994
+--- perl5.002b1g/lib/Env.pm Thu Dec 21 13:01:01 1995
+
+Index: lib/Exporter.pm
+*** perl5.002b1f/lib/Exporter.pm Wed Nov 15 15:19:33 1995
+--- perl5.002b1g/lib/Exporter.pm Thu Dec 21 13:01:01 1995
+
+Index: lib/ExtUtils/Liblist.pm
+*** perl5.002b1f/lib/ExtUtils/Liblist.pm Tue Dec 5 07:56:53 1995
+--- perl5.002b1g/lib/ExtUtils/Liblist.pm Thu Dec 21 13:01:01 1995
+
+Index: lib/ExtUtils/MakeMaker.pm
+Prereq: 1.115
+*** perl5.002b1f/lib/ExtUtils/MakeMaker.pm Tue Dec 5 13:20:56 1995
+--- perl5.002b1g/lib/ExtUtils/MakeMaker.pm Thu Dec 21 13:01:02 1995
+
+Index: lib/ExtUtils/Manifest.pm
+*** perl5.002b1f/lib/ExtUtils/Manifest.pm Tue Dec 5 13:21:00 1995
+--- perl5.002b1g/lib/ExtUtils/Manifest.pm Thu Dec 21 13:01:02 1995
+
+Index: lib/ExtUtils/Mkbootstrap.pm
+*** perl5.002b1f/lib/ExtUtils/Mkbootstrap.pm Thu Oct 19 05:58:34 1995
+--- perl5.002b1g/lib/ExtUtils/Mkbootstrap.pm Thu Dec 21 13:01:02 1995
+
+Index: lib/FileHandle.pm
+*** perl5.002b1f/lib/FileHandle.pm Thu May 25 11:18:20 1995
+--- perl5.002b1g/lib/FileHandle.pm Thu Dec 21 13:01:02 1995
+
+Index: lib/IPC/Open2.pm
+*** perl5.002b1f/lib/IPC/Open2.pm Thu May 25 11:31:07 1995
+--- perl5.002b1g/lib/IPC/Open2.pm Thu Dec 21 13:01:03 1995
+
+Index: lib/IPC/Open3.pm
+Prereq: 1.1
+*** perl5.002b1f/lib/IPC/Open3.pm Wed Nov 15 15:21:11 1995
+--- perl5.002b1g/lib/IPC/Open3.pm Thu Dec 21 13:01:03 1995
+
+Index: lib/SelfLoader.pm
+*** perl5.002b1f/lib/SelfLoader.pm Sun Nov 26 16:59:51 1995
+--- perl5.002b1g/lib/SelfLoader.pm Thu Dec 21 13:01:03 1995
+
+Index: lib/Sys/Hostname.pm
+*** perl5.002b1f/lib/Sys/Hostname.pm Tue Oct 18 12:38:25 1994
+--- perl5.002b1g/lib/Sys/Hostname.pm Thu Dec 21 13:01:03 1995
+
+Index: lib/Sys/Syslog.pm
+*** perl5.002b1f/lib/Sys/Syslog.pm Wed Dec 6 14:07:54 1995
+--- perl5.002b1g/lib/Sys/Syslog.pm Thu Dec 21 13:01:04 1995
+
+Index: lib/Term/Cap.pm
+*** perl5.002b1f/lib/Term/Cap.pm Sun Mar 12 00:14:42 1995
+--- perl5.002b1g/lib/Term/Cap.pm Thu Dec 21 13:01:04 1995
+
+Index: lib/Term/Complete.pm
+*** perl5.002b1f/lib/Term/Complete.pm Wed May 24 12:09:48 1995
+--- perl5.002b1g/lib/Term/Complete.pm Thu Dec 21 13:01:04 1995
+
+Index: lib/Test/Harness.pm
+*** perl5.002b1f/lib/Test/Harness.pm Mon Nov 13 23:01:40 1995
+--- perl5.002b1g/lib/Test/Harness.pm Thu Dec 21 13:01:04 1995
+
+Index: lib/Text/Soundex.pm
+Prereq: 1.2
+*** perl5.002b1f/lib/Text/Soundex.pm Tue Oct 18 12:38:42 1994
+--- perl5.002b1g/lib/Text/Soundex.pm Thu Dec 21 13:01:04 1995
+
+Index: lib/Text/Tabs.pm
+*** perl5.002b1f/lib/Text/Tabs.pm Sat Nov 18 16:08:55 1995
+--- perl5.002b1g/lib/Text/Tabs.pm Thu Dec 21 13:01:04 1995
+
+Index: lib/Text/Wrap.pm
+*** perl5.002b1f/lib/Text/Wrap.pm Sat Nov 18 16:08:56 1995
+--- perl5.002b1g/lib/Text/Wrap.pm Thu Dec 21 13:01:05 1995
+
+Index: lib/TieHash.pm
+*** perl5.002b1f/lib/TieHash.pm Wed Nov 15 15:27:47 1995
+--- perl5.002b1g/lib/TieHash.pm Thu Dec 21 13:01:05 1995
+
+Index: lib/Time/Local.pm
+*** perl5.002b1f/lib/Time/Local.pm Tue Oct 18 12:38:47 1994
+--- perl5.002b1g/lib/Time/Local.pm Thu Dec 21 13:01:05 1995
+
+Index: lib/less.pm
+*** perl5.002b1f/lib/less.pm Thu May 25 11:19:59 1995
+--- perl5.002b1g/lib/less.pm Thu Dec 21 13:01:05 1995
+
+Index: lib/overload.pm
+*** perl5.002b1f/lib/overload.pm Sat Nov 18 16:03:33 1995
+--- perl5.002b1g/lib/overload.pm Thu Dec 21 13:01:05 1995
+
+Index: lib/strict.pm
+*** perl5.002b1f/lib/strict.pm Thu May 25 11:20:27 1995
+--- perl5.002b1g/lib/strict.pm Thu Dec 21 13:01:05 1995
+
+Index: lib/syslog.pl
+*** perl5.002b1f/lib/syslog.pl Tue Oct 18 12:37:13 1994
+--- perl5.002b1g/lib/syslog.pl Thu Dec 21 13:01:05 1995
+
+Index: perl.c
+*** perl5.002b1f/perl.c Sun Nov 19 16:11:29 1995
+--- perl5.002b1g/perl.c Thu Dec 21 13:01:06 1995
+
+Index: pod/Makefile
+*** perl5.002b1f/pod/Makefile Mon Nov 20 13:00:50 1995
+--- perl5.002b1g/pod/Makefile Thu Dec 21 13:01:06 1995
+
+Index: pod/PerlDoc/Functions.pm
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/pod/PerlDoc/Functions.pm Thu Dec 21 13:01:07 1995
+
+Index: pod/PerlDoc/Functions.pm.POSIX
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/pod/PerlDoc/Functions.pm.POSIX Thu Dec 21 13:01:07 1995
+
+Index: pod/buildtoc
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/pod/buildtoc Thu Dec 21 13:01:07 1995
+
+Index: pod/perl.pod
+*** perl5.002b1f/pod/perl.pod Sat Nov 18 17:23:58 1995
+--- perl5.002b1g/pod/perl.pod Thu Dec 21 13:01:07 1995
+
+Index: pod/perlbot.pod
+*** perl5.002b1f/pod/perlbot.pod Fri Nov 10 17:27:33 1995
+--- perl5.002b1g/pod/perlbot.pod Thu Dec 21 13:01:07 1995
+
+Index: pod/perldata.pod
+*** perl5.002b1f/pod/perldata.pod Sat Nov 18 17:23:59 1995
+--- perl5.002b1g/pod/perldata.pod Thu Dec 21 13:01:07 1995
+
+Index: pod/perldiag.pod
+*** perl5.002b1f/pod/perldiag.pod Sun Nov 19 22:10:58 1995
+--- perl5.002b1g/pod/perldiag.pod Thu Dec 21 13:01:08 1995
+
+Index: pod/perldsc.pod
+*** perl5.002b1f/pod/perldsc.pod Sat Nov 18 17:24:22 1995
+--- perl5.002b1g/pod/perldsc.pod Thu Dec 21 13:01:08 1995
+
+Index: pod/perlembed.pod
+*** perl5.002b1f/pod/perlembed.pod Tue Oct 18 12:39:24 1994
+--- perl5.002b1g/pod/perlembed.pod Thu Dec 21 13:01:09 1995
+
+Index: pod/perlform.pod
+*** perl5.002b1f/pod/perlform.pod Sat Nov 18 17:23:59 1995
+--- perl5.002b1g/pod/perlform.pod Thu Dec 21 13:01:09 1995
+
+Index: pod/perlfunc.pod
+*** perl5.002b1f/pod/perlfunc.pod Sat Nov 18 17:24:01 1995
+--- perl5.002b1g/pod/perlfunc.pod Thu Dec 21 13:01:09 1995
+
+Index: pod/perlguts.pod
+*** perl5.002b1f/pod/perlguts.pod Tue Oct 31 15:38:18 1995
+--- perl5.002b1g/pod/perlguts.pod Thu Dec 21 13:01:10 1995
+
+Index: pod/perlipc.pod
+*** perl5.002b1f/pod/perlipc.pod Sat Nov 18 17:24:02 1995
+--- perl5.002b1g/pod/perlipc.pod Thu Dec 21 13:01:11 1995
+
+Index: pod/perllol.pod
+*** perl5.002b1f/pod/perllol.pod Sat Nov 18 17:24:22 1995
+--- perl5.002b1g/pod/perllol.pod Thu Dec 21 13:01:11 1995
+
+Index: pod/perlmod.pod
+*** perl5.002b1f/pod/perlmod.pod Sat Nov 18 17:24:03 1995
+--- perl5.002b1g/pod/perlmod.pod Thu Dec 21 13:01:11 1995
+
+Index: pod/perlobj.pod
+*** perl5.002b1f/pod/perlobj.pod Sun Mar 12 00:48:38 1995
+--- perl5.002b1g/pod/perlobj.pod Thu Dec 21 13:01:11 1995
+
+Index: pod/perlop.pod
+*** perl5.002b1f/pod/perlop.pod Sat Nov 18 17:24:03 1995
+--- perl5.002b1g/pod/perlop.pod Thu Dec 21 13:01:12 1995
+
+Index: pod/perlovl.pod
+*** perl5.002b1f/pod/perlovl.pod Mon Jan 23 13:25:35 1995
+--- perl5.002b1g/pod/perlovl.pod Thu Dec 21 13:01:12 1995
+
+Index: pod/perlpod.pod
+*** perl5.002b1f/pod/perlpod.pod Sun Nov 19 22:22:59 1995
+--- perl5.002b1g/pod/perlpod.pod Thu Dec 21 13:01:12 1995
+
+Index: pod/perlre.pod
+*** perl5.002b1f/pod/perlre.pod Sun Nov 26 16:57:20 1995
+--- perl5.002b1g/pod/perlre.pod Thu Dec 21 13:01:12 1995
+
+Index: pod/perlref.pod
+*** perl5.002b1f/pod/perlref.pod Sat Nov 18 17:24:04 1995
+--- perl5.002b1g/pod/perlref.pod Thu Dec 21 13:01:12 1995
+
+Index: pod/perlrun.pod
+*** perl5.002b1f/pod/perlrun.pod Wed Feb 22 18:32:59 1995
+--- perl5.002b1g/pod/perlrun.pod Thu Dec 21 13:01:12 1995
+
+Index: pod/perlsec.pod
+*** perl5.002b1f/pod/perlsec.pod Wed Feb 22 18:33:02 1995
+--- perl5.002b1g/pod/perlsec.pod Thu Dec 21 13:01:12 1995
+
+Index: pod/perlstyle.pod
+*** perl5.002b1f/pod/perlstyle.pod Tue Oct 18 12:40:13 1994
+--- perl5.002b1g/pod/perlstyle.pod Thu Dec 21 13:01:13 1995
+
+Index: pod/perlsub.pod
+*** perl5.002b1f/pod/perlsub.pod Sun Mar 12 22:42:58 1995
+--- perl5.002b1g/pod/perlsub.pod Thu Dec 21 13:01:13 1995
+
+Index: pod/perlsyn.pod
+*** perl5.002b1f/pod/perlsyn.pod Sat Nov 18 17:24:04 1995
+--- perl5.002b1g/pod/perlsyn.pod Thu Dec 21 13:01:14 1995
+
+Index: pod/perltie.pod
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/pod/perltie.pod Thu Dec 21 13:01:14 1995
+
+Index: pod/perltoc.pod
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/pod/perltoc.pod Thu Dec 21 13:01:14 1995
+
+Index: pod/perltrap.pod
+*** perl5.002b1f/pod/perltrap.pod Wed Nov 15 21:36:11 1995
+--- perl5.002b1g/pod/perltrap.pod Thu Dec 21 13:01:14 1995
+
+Index: pod/perlvar.pod
+*** perl5.002b1f/pod/perlvar.pod Wed Nov 15 21:36:59 1995
+--- perl5.002b1g/pod/perlvar.pod Thu Dec 21 13:01:15 1995
+
+Index: pod/perlxs.pod
+*** perl5.002b1f/pod/perlxs.pod Sun Nov 19 22:12:44 1995
+--- perl5.002b1g/pod/perlxs.pod Thu Dec 21 13:01:15 1995
+
+Index: pod/perlxstut.pod
+*** perl5.002b1f/pod/perlxstut.pod Mon Nov 20 13:02:12 1995
+--- perl5.002b1g/pod/perlxstut.pod Thu Dec 21 13:01:15 1995
+
+Index: pod/pod2man.PL
+Prereq: 1.5
+*** perl5.002b1f/pod/pod2man.PL Wed Nov 15 22:32:51 1995
+--- perl5.002b1g/pod/pod2man.PL Thu Dec 21 13:01:15 1995
+
+Index: pod/pod2text
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/pod/pod2text Thu Dec 21 13:01:16 1995
+
+Index: pod/roffitall
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/pod/roffitall Thu Dec 21 13:01:16 1995
+
+Index: pod/splitpod
+*** /dev/null Wed Jan 3 14:35:56 1996
+--- perl5.002b1g/pod/splitpod Thu Dec 21 13:01:16 1995
+
+-------------
+Version 5.002b1f
+-------------
+
+This is patch.2b1f to perl5.002beta1.
+
+Index: Changes.Conf
+
+Include 5.001m -> 5.002beta1 changes.
+
+*** perl5.002b1e/Changes.Conf Mon Nov 20 10:08:05 1995
+--- perl5.002b1f/Changes.Conf Wed Dec 6 15:29:48 1995
+
+Index: Configure
+
+ Include Jeff Okamoto's patch to allow arbitrary specification
+ of $startperl.
+
+ As requested, I have moved site_perl to be under
+ $privlib, by default. The default will now be
+ /usr/local/lib/perl5/site_perl. This is in accord with the way
+ emacs used to do it :-).
+
+
+Prereq: 3.0.1.8
+*** perl5.002b1e/Configure Fri Dec 8 14:55:26 1995
+--- perl5.002b1f/Configure Fri Dec 8 11:23:56 1995
+
+Index: MANIFEST
+ Add in POSIX.pod. I didn't include Dean's mkposixman tool because
+ it seemed to confuse MakeMaker, and I didn't want to manually fix
+ the POSIX/Makefile.PL file today.
+
+ Renamed minimod.PL. The idea is as follows: I'd like to reserve
+ the .PL suffix for files that are extracted during build time, and
+ then can be deleted after installation. That is, it will be
+ analogous to the .SH suffix. For example, h2xs.PL creates
+ h2xs, and a 'make realclean' will remove the h2xs. Minimod.PL
+ was an exception to this pattern. Eventually, the .PL dependencies
+ will be generated automatically, just as the .SH dependencies are
+ now.
+
+ Add in socket test.
+
+*** perl5.002b1e/MANIFEST Fri Dec 8 14:55:27 1995
+--- perl5.002b1f/MANIFEST Fri Dec 8 13:34:53 1995
+
+Index: Makefile.SH
+
+ Renamed minimod.PL to minimod.pl
+
+*** perl5.002b1e/Makefile.SH Mon Nov 20 15:56:12 1995
+--- perl5.002b1f/Makefile.SH Fri Dec 8 10:36:33 1995
+
+Index: XSUB.h
+
+ Include (SV*) cast in the newXSproto #define.
+
+*** perl5.002b1e/XSUB.h Fri Dec 8 14:55:14 1995
+--- perl5.002b1f/XSUB.h Wed Dec 6 13:25:26 1995
+
+Index: ext/POSIX/POSIX.pm
+
+ I have included Dean's patch and the .pod generated by mkposixman.
+
+*** perl5.002b1e/ext/POSIX/POSIX.pm Wed Nov 15 14:54:09 1995
+--- perl5.002b1f/ext/POSIX/POSIX.pm Fri Dec 8 10:23:54 1995
+
+Index: ext/POSIX/POSIX.pod
+
+ I have included Dean's patch and the .pod generated by mkposixman.
+
+*** /dev/null Fri Dec 8 13:36:14 1995
+--- perl5.002b1f/ext/POSIX/POSIX.pod Fri Dec 8 10:30:40 1995
+
+Index: ext/POSIX/POSIX.xs
+
+ I have included Dean's patch and the .pod generated by mkposixman.
+
+*** perl5.002b1e/ext/POSIX/POSIX.xs Wed Nov 15 14:56:22 1995
+--- perl5.002b1f/ext/POSIX/POSIX.xs Fri Dec 8 10:23:54 1995
+
+Index: ext/Socket/Socket.pm
+
+ Replace errant sockaddr_in by correct sockaddr_un.
+ Remove an extra ')'. -- from Tom C.
+
+*** perl5.002b1e/ext/Socket/Socket.pm Fri Dec 8 14:55:28 1995
+--- perl5.002b1f/ext/Socket/Socket.pm Wed Dec 6 13:58:41 1995
+
+Index: gv.c
+
+ Fix from Nick Ing-Simmons to get HvNAME(stash) from caller's
+ package.
+
+*** perl5.002b1e/gv.c Wed Nov 15 14:58:39 1995
+--- perl5.002b1f/gv.c Fri Dec 8 10:37:22 1995
+
+Index: lib/Cwd.pm
+
+ Fix a long-standing problem where insufficient permissions higher
+ up in the directory tree caused getcwd to fail. This often showed
+ up on AFS.
+
+*** perl5.002b1e/lib/Cwd.pm Mon Nov 13 23:01:38 1995
+--- perl5.002b1f/lib/Cwd.pm Fri Dec 8 10:42:46 1995
+
+Index: lib/Sys/Syslog.pm
+
+ Modernize Syslog.pm to 'use Socket;' and 'use Sys::Hostname'.
+ Alas, I've lost the attribution for this patch. Sorry about
+ that.
+
+*** perl5.002b1e/lib/Sys/Syslog.pm Thu Feb 9 20:05:36 1995
+--- perl5.002b1f/lib/Sys/Syslog.pm Wed Dec 6 14:07:54 1995
+
+Index: lib/diagnostics.pm
+
+ Fixes from Tom.
+
+*** perl5.002b1e/lib/diagnostics.pm Tue Nov 14 16:16:36 1995
+--- perl5.002b1f/lib/diagnostics.pm Wed Dec 6 13:58:42 1995
+
+Index: t/lib/socket.t
+
+ New test from Tom. I've allowed it to fail if the echo service is
+ disabled, as is apparently the case on some systems.
+
+*** /dev/null Fri Dec 8 13:36:14 1995
+--- perl5.002b1f/t/lib/socket.t Fri Dec 8 11:16:01 1995
+
+Index: toke.c
+
+ A patch from Paul Marquess "purely for source filters".
+
+*** perl5.002b1e/toke.c Wed Nov 15 22:08:23 1995
+--- perl5.002b1f/toke.c Wed Dec 6 13:24:19 1995
+
+-------------
+Version 5.002b1e
+-------------
+
+This is patch.2b1e to perl5.002beta1. This is simply
+an upgrade from MakeMaker-5.10 to MakeMaker-5.11.
+
+
+Index: lib/ExtUtils/Liblist.pm
+*** perl5.002b1d/lib/ExtUtils/Liblist.pm Sat Dec 2 16:50:47 1995
+--- perl5.002b1e/lib/ExtUtils/Liblist.pm Wed Dec 6 11:52:22 1995
+
+Index: lib/ExtUtils/MakeMaker.pm
+Prereq: 1.114
+*** perl5.002b1d/lib/ExtUtils/MakeMaker.pm Sat Dec 2 16:50:48 1995
+--- perl5.002b1e/lib/ExtUtils/MakeMaker.pm Wed Dec 6 11:52:22 1995
+
+Index: lib/ExtUtils/Manifest.pm
+*** perl5.002b1d/lib/ExtUtils/Manifest.pm Sat Dec 2 16:50:48 1995
+--- perl5.002b1e/lib/ExtUtils/Manifest.pm Wed Dec 6 11:52:22 1995
+
+-------------
+Version 5.002b1d
+-------------
+
+This is patch.2b1d to perl5.002beta1.
+
+This patch includes patches for the following items:
+
+ NETaa14710: Included bsdi_bsdos.sh hint file.
+
+ pod/perlre.pod: Mention 32bit limit.
+
+ Configure Updates.
+
+ Update Socket.xs to version 1.5. This handles
+ systems that might not have <sys/un.h>.
+
+ Fix missing quotes in h2ph.PL
+
+These are each described in detail below, after the corresponding
+index line.
+
+Index: Configure
+
+ locincpth should now work as documented in INSTALL
+
+ Improved guessing of man1dir
+
+ Remove spurious semicolon in NONBLOCK testing.
+
+ Send failed './loc' message to fd 4.
+
+ Check for <sys/un.h>
+
+ Allow 'unixisms' to be overridden by hint files.
+
+ Remove -r test from './loc' since some executables are
+ not readable.
+
+ Remove spurious doublings of -L/usr/local/lib when reusing old
+ config.sh.
+
+ Improved domain name guessing, from
+ Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
+
+ Include sitelib (architecture-independent directory).
+
+
+Prereq: 3.0.1.8
+*** perl5.002b1c/Configure Mon Nov 20 10:00:33 1995
+--- perl5.002b1d/Configure Sat Dec 2 15:35:13 1995
+
+Index: INSTALL
+
+ Consistently use "sh Configure" in examples.
+
+ Add reminder that interactive use may be helpful.
+
+*** perl5.002b1c/INSTALL Mon Nov 20 10:46:48 1995
+--- perl5.002b1d/INSTALL Tue Nov 21 22:54:28 1995
+
+Index: MANIFEST
+
+ Include renamed hint file.
+
+*** perl5.002b1c/MANIFEST Sat Dec 2 16:20:21 1995
+--- perl5.002b1d/MANIFEST Sun Nov 26 17:03:31 1995
+
+Index: config_h.SH
+
+ Include check for <sys/un.h>.
+
+ Include SITELIB_EXP definition for architecture-independent
+ site-specific modules. Usually, this will be
+ /usr/local/lib/site_perl.
+
+Prereq: 3.0.1.4
+*** perl5.002b1c/config_h.SH Mon Nov 20 10:00:33 1995
+--- perl5.002b1d/config_h.SH Sat Dec 2 15:35:13 1995
+
+Index: ext/Socket/Makefile.PL
+
+ Update version number to 1.5.
+
+*** perl5.002b1c/ext/Socket/Makefile.PL Sat Nov 18 15:36:56 1995
+--- perl5.002b1d/ext/Socket/Makefile.PL Sat Dec 2 16:23:52 1995
+
+Index: ext/Socket/Socket.pm
+
+ Update to version 1.5.
+
+*** perl5.002b1c/ext/Socket/Socket.pm Sat Nov 18 15:37:03 1995
+--- perl5.002b1d/ext/Socket/Socket.pm Sat Dec 2 16:25:17 1995
+
+Index: ext/Socket/Socket.xs
+
+ Update to version 1.5.
+ This only supports the sockaddr_un -related functions if your
+ system has <sys/un.h>. SVR3 systems generally don't.
+
+*** perl5.002b1c/ext/Socket/Socket.xs Sat Nov 18 15:36:57 1995
+--- perl5.002b1d/ext/Socket/Socket.xs Sat Dec 2 15:46:20 1995
+
+Index: h2ph.PL
+
+ Add missing quotes.
+
+*** perl5.002b1c/h2ph.PL Sun Nov 19 23:00:39 1995
+--- perl5.002b1d/h2ph.PL Mon Nov 27 10:14:50 1995
+
+Index: hints/bsdi_bsdos.sh
+
+ Updated and renamed file.
+
+*** perl5.002b1c/hints/bsdi_bsdos.sh Thu Jan 19 19:08:34 1995
+--- perl5.002b1d/hints/bsdi_bsdos.sh Sun Nov 26 16:50:26 1995
+
+Index: pod/perlre.pod
+
+ Mention 65536 limit explicitly.
+
+*** perl5.002b1c/pod/perlre.pod Wed Nov 15 21:35:31 1995
+--- perl5.002b1d/pod/perlre.pod Sun Nov 26 16:57:20 1995
+
+-------------
+Version 5.002b1c
+-------------
+
+This is patch.2b1c to perl5.002beta1. This patch includes
+ lib/SelfLoader, version 1.06, and
+ lib/Devel/SelfStubber, version 1.01.
+These versions include prototype support.
+
+This is simply re-posting these library modules.
+I have also updated MANIFEST to include them.
+
+
+Index: MANIFEST
+*** perl5.002b1b/MANIFEST Sat Dec 2 16:13:24 1995
+--- perl5.002b1c/MANIFEST Sat Dec 2 16:12:54 1995
+
+Index: lib/Devel/SelfStubber.pm
+*** /dev/null Fri Dec 1 16:03:22 1995
+--- perl5.002b1c/lib/Devel/SelfStubber.pm Sun Nov 26 16:14:19 1995
+
+Index: lib/SelfLoader.pm
+*** /dev/null Fri Dec 1 16:03:22 1995
+--- perl5.002b1c/lib/SelfLoader.pm Sun Nov 26 16:14:50 1995
+
+-------------
+Version 5.002b1b
+-------------
+
+This is patch.2b1b to perl5.002beta1. This is simply
+MakeMaker-5.10. Nothing else is included.
+
+It contains:
+
+Upgrade to MakeMaker-5.10
+and a revised minimod.PL that now writes a pod section into ExtUtils::Miniperl.
+
+Index: lib/ExtUtils/Liblist.pm
+*** perl5.002b1a/lib/ExtUtils/Liblist.pm Mon Nov 13 22:03:29 1995
+--- perl5.002b1b/lib/ExtUtils/Liblist.pm Sat Dec 2 15:58:00 1995
+
+Index: lib/ExtUtils/MakeMaker.pm
+*** perl5.002b1a/lib/ExtUtils/MakeMaker.pm Sat Nov 18 16:01:05 1995
+--- perl5.002b1b/lib/ExtUtils/MakeMaker.pm Sat Dec 2 15:58:01 1995
+
+Index: lib/ExtUtils/Manifest.pm
+*** perl5.002b1a/lib/ExtUtils/Manifest.pm Mon Nov 13 22:03:30 1995
+--- perl5.002b1b/lib/ExtUtils/Manifest.pm Sat Dec 2 15:58:02 1995
+
+Index: minimod.PL
+*** perl5.002b1a/minimod.PL Sun Nov 19 23:01:02 1995
+--- perl5.002b1b/minimod.PL Sat Dec 2 15:58:02 1995
+
+-------------
+Version 5.002b1a
+-------------
+
+This is patch.2b1a to perl5.002beta1. This is simply
+xsubpp-1.944. It includes perl prototype support.
+
+Index: XSUB.h
+
+Updated to match xsubpp-1.944. Includes perl prototype support.
+
+*** perl5.002beta1/XSUB.h Fri Nov 10 13:11:02 1995
+--- perl5.002b1a/XSUB.h Sat Dec 2 15:43:54 1995
+
+Index: lib/ExtUtils/xsubpp
+
+Updated to xsubpp-1.944. Includes perl prototype support.
+
+*** perl5.002beta1/lib/ExtUtils/xsubpp Mon Nov 20 11:03:49 1995
+--- perl5.002b1a/lib/ExtUtils/xsubpp Sat Dec 2 15:43:55 1995
+
+
+
+Here are the detailed changes from 5.001m to 5.002beta1:
+
+# rm -f Doc/perl5-notes # Obsolete
+# rm -f c2ph.SH # Replaced by c2ph.PL
+# rm -f emacs/cperl-mode # Obsolete
+# rm -f emacs/emacs19 # Obsolete
+# rm -f emacs/perl-mode.el # Obsolete
+# rm -f emacs/perldb.el # Obsolete
+# rm -f emacs/perldb.pl # Obsolete
+# rm -f emacs/tedstuff # Obsolete
+# rm -f h2ph.SH # Replaced by h2ph.PL
+# rm -f h2xs.SH # Replaced by h2xs.PL
+# rm -f hints/hpux_9.sh # Replaced by generic hpux.sh
+# rm -f hints/sco_3.sh # Replaced by generic sco.sh
+# rm -f perldoc.SH # Replaced by perldoc.PL
+# rm -f pod/pod2html.SH # Replaced by pod2html.PL
+# rm -f pod/pod2latex.SH # Replaced by pod2latex.PL
+# rm -f pod/pod2man.SH # Replaced by pod2man.PL
+# rm -f x2p/find2perl.SH # Replaced by find2perl.PL
+# rm -f x2p/s2p.SH # Replaced by s2p.PL
+# exit
+
+
+Index: patchlevel.h
+Incremented to 2!
+*** perl5.001.lwall/patchlevel.h Sun Mar 12 22:29:12 1995
+--- perl5.002beta1/patchlevel.h Sat Nov 18 15:41:15 1995
+
+Index: Changes
+This includes the Changes file Larry sent me. I added the first
+paragraph.
+*** perl5.001.lwall/Changes Mon Mar 13 00:44:07 1995
+--- perl5.002beta1/Changes Sat Nov 18 15:43:29 1995
+
+Index: Changes.Conf
+An all too brief summary.
+*** perl5.001.lwall/Changes.Conf Thu Oct 19 21:00:06 1995
+--- perl5.002beta1/Changes.Conf Mon Nov 20 10:08:05 1995
+
+Index: Configure
+
+Upgraded to metaconfig PL60 (despite the erroneous metaconfig message.
+
+Layed some groundwork for support on non Unix systems, such as OS/2.
+Define things such as .o vs. .obj, '' vs. .exe, .a vs. .lib, etc.
+
+Include I_LOCALE testing.
+
+Include checks for new library set-up. I don't want to ever have to
+change this again. It's documented more clearly in INSTALL.
+
+Figure out correct string for $startperl (usually
+#!/usr/local/bin/perl).
+
+Improve signal detection even more. Once again, the signal number
+corresponding to sig_name[n] is n (up to NSIG-1). Gaps in signal
+numbers (e.g. on Solaris) are allowed and are filled with
+innocuous names such as NUM37 NUM38, etc., where the 37 or 38
+represents the actual signal number.
+
+Prereq: 3.0.1.8
+*** perl5.001.lwall/Configure Mon Oct 23 14:08:59 1995
+--- perl5.002beta1/Configure Mon Nov 20 10:00:33 1995
+
+Index: INSTALL
+
+Explain the library directory structure.
+
+Remove some tailing whitespace.
+
+Indicate that only the interfaces to gdbm and db are provided, not
+the libraries themselves.
+
+Add section on upgrading from previous versions of perl5.00x.
+
+Mention how to override old config.sh with Configure -D and -O.
+
+*** perl5.001.lwall/INSTALL Mon Oct 23 14:10:26 1995
+--- perl5.002beta1/INSTALL Mon Nov 20 10:46:48 1995
+
+Index: MANIFEST
+
+In an attempt to make the distribution slightly less Unix specific,
+I've changed .SH extraction to a .PL extraction where possible.
+That way folks on systems without a shell can still get the
+auxilliarly files such as find2perl (assuming they *can* build
+perl).
+
+The emacs/ directory was hopelessly out of date. I don't use emacs,
+but included a current cperl-mode.el
+
+*** perl5.001.lwall/MANIFEST Tue Nov 14 15:21:03 1995
+--- perl5.002beta1/MANIFEST Mon Nov 20 12:40:41 1995
+
+Index: Makefile.SH
+
+Add variables for non unix systems.
+
+Add .PL file extraction logic.
+
+*** perl5.001.lwall/Makefile.SH Tue Nov 14 20:25:48 1995
+--- perl5.002beta1/Makefile.SH Mon Nov 20 15:56:12 1995
+
+Index: XSUB.h
+
+Protect arguments of macros with ().
+
+*** perl5.001.lwall/XSUB.h Tue Mar 7 14:10:00 1995
+--- perl5.002beta1/XSUB.h Fri Nov 10 13:11:02 1995
+
+Index: c2ph.PL
+Replaces c2ph.SH.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/c2ph.PL Mon Nov 20 12:36:17 1995
+
+Index: cflags.SH
+Allow for .o or .obj in file names.
+*** perl5.001.lwall/cflags.SH Thu Jan 19 19:06:13 1995
+--- perl5.002beta1/cflags.SH Tue Nov 14 15:18:41 1995
+
+Index: config_H
+Updated.
+Prereq: 3.0.1.3
+*** perl5.001.lwall/config_H Thu Oct 19 21:01:14 1995
+--- perl5.002beta1/config_H Mon Nov 20 15:41:49 1995
+
+Index: config_h.SH
+Updated to match new Configure.
+Prereq: 3.0.1.3
+*** perl5.001.lwall/config_h.SH Mon Oct 23 14:10:38 1995
+--- perl5.002beta1/config_h.SH Mon Nov 20 10:00:33 1995
+
+Index: configpm
+Add in routine to print out full config.sh file.
+*** perl5.001.lwall/configpm Wed Jun 7 19:46:01 1995
+--- perl5.002beta1/configpm Tue Oct 31 11:51:52 1995
+
+Index: doop.c
+Check for sprintf memory overflow that can arise from things
+like %999999s.
+
+*** perl5.001.lwall/doop.c Sun Jul 2 23:33:44 1995
+--- perl5.002beta1/doop.c Wed Nov 15 15:08:01 1995
+
+Index: emacs/cperl-mode.el
+New version.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/emacs/cperl-mode.el Sat Nov 11 16:29:33 1995
+
+Index: embed.h
+Remove unnecessary whichsigname introduced in patch.1n.
+*** perl5.001.lwall/embed.h Tue Nov 14 15:21:08 1995
+--- perl5.002beta1/embed.h Wed Nov 15 14:48:47 1995
+
+Index: ext/DB_File/DB_File.pm
+Updated to version 1.01.
+*** perl5.001.lwall/ext/DB_File/DB_File.pm Wed Jun 7 19:46:14 1995
+--- perl5.002beta1/ext/DB_File/DB_File.pm Tue Nov 14 14:14:25 1995
+
+Index: ext/DB_File/DB_File.xs
+Updated to version 1.01.
+*** perl5.001.lwall/ext/DB_File/DB_File.xs Wed Jun 7 19:46:17 1995
+--- perl5.002beta1/ext/DB_File/DB_File.xs Tue Nov 14 14:14:37 1995
+
+Index: ext/DB_File/Makefile.PL
+Updated to version 1.01.
+*** perl5.001.lwall/ext/DB_File/Makefile.PL Wed Feb 22 14:36:32 1995
+--- perl5.002beta1/ext/DB_File/Makefile.PL Tue Nov 14 14:14:17 1995
+
+Index: ext/DB_File/typemap
+Fix typemap to avoid core dump.
+*** perl5.001.lwall/ext/DB_File/typemap Tue Oct 18 12:27:52 1994
+--- perl5.002beta1/ext/DB_File/typemap Tue Oct 31 11:53:28 1995
+
+Index: ext/DynaLoader/DynaLoader.pm
+Add parentheses to Carp::confess call.
+*** perl5.001.lwall/ext/DynaLoader/DynaLoader.pm Thu Oct 19 20:13:25 1995
+--- perl5.002beta1/ext/DynaLoader/DynaLoader.pm Fri Nov 10 11:49:00 1995
+
+Index: ext/DynaLoader/dl_os2.xs
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/ext/DynaLoader/dl_os2.xs Mon Nov 13 22:58:42 1995
+
+Index: ext/Fcntl/Fcntl.xs
+Add O_BINARY define for OS/2.
+*** perl5.001.lwall/ext/Fcntl/Fcntl.xs Mon Oct 23 14:10:54 1995
+--- perl5.002beta1/ext/Fcntl/Fcntl.xs Mon Nov 13 23:01:40 1995
+
+Index: ext/GDBM_File/GDBM_File.pm
+Added a tiny bit of documentation, including how to get gdbm.
+Shamelessly stolen from the DB_File.pm documentation.
+*** perl5.001.lwall/ext/GDBM_File/GDBM_File.pm Wed Jun 7 19:46:34 1995
+--- perl5.002beta1/ext/GDBM_File/GDBM_File.pm Mon Nov 20 10:22:26 1995
+
+Index: ext/GDBM_File/GDBM_File.xs
+Add gdbm_EXISTS #define.
+*** perl5.001.lwall/ext/GDBM_File/GDBM_File.xs Sat Jul 1 18:44:02 1995
+--- perl5.002beta1/ext/GDBM_File/GDBM_File.xs Sat Nov 11 14:25:50 1995
+
+Index: ext/NDBM_File/hints/solaris.pl
+Updated for MakeMaker 5.0x.
+*** perl5.001.lwall/ext/NDBM_File/hints/solaris.pl Wed Jun 7 19:46:39 1995
+--- perl5.002beta1/ext/NDBM_File/hints/solaris.pl Fri Nov 10 10:39:23 1995
+
+Index: ext/ODBM_File/hints/sco.pl
+Updated for MakeMaker 5.0x.
+*** perl5.001.lwall/ext/ODBM_File/hints/sco.pl Wed Jun 7 19:46:44 1995
+--- perl5.002beta1/ext/ODBM_File/hints/sco.pl Fri Nov 10 10:39:32 1995
+
+Index: ext/ODBM_File/hints/solaris.pl
+Updated for MakeMaker 5.0x.
+*** perl5.001.lwall/ext/ODBM_File/hints/solaris.pl Wed Jun 7 19:46:46 1995
+--- perl5.002beta1/ext/ODBM_File/hints/solaris.pl Fri Nov 10 10:39:44 1995
+
+Index: ext/ODBM_File/hints/svr4.pl
+Updated for MakeMaker 5.0x.
+*** perl5.001.lwall/ext/ODBM_File/hints/svr4.pl Wed Jun 7 19:46:48 1995
+--- perl5.002beta1/ext/ODBM_File/hints/svr4.pl Fri Nov 10 10:39:54 1995
+
+Index: ext/POSIX/POSIX.pm
+Remove POSIX_loadlibs relics from perl5alpha days.
+*** perl5.001.lwall/ext/POSIX/POSIX.pm Thu Sep 21 19:14:19 1995
+--- perl5.002beta1/ext/POSIX/POSIX.pm Wed Nov 15 14:54:09 1995
+
+Index: ext/POSIX/POSIX.xs
+Change whichsigname(sig) back to sig_name[sig].
+*** perl5.001.lwall/ext/POSIX/POSIX.xs Mon Oct 23 14:11:01 1995
+--- perl5.002beta1/ext/POSIX/POSIX.xs Wed Nov 15 14:56:22 1995
+
+Index: ext/SDBM_File/Makefile.PL
+Updated for MakeMaker 5.0x to allow compilation on non-unix systems.
+*** perl5.001.lwall/ext/SDBM_File/Makefile.PL Thu Jan 19 18:59:02 1995
+--- perl5.002beta1/ext/SDBM_File/Makefile.PL Tue Nov 14 11:16:43 1995
+
+Index: ext/SDBM_File/sdbm/Makefile.PL
+Updated for MakeMaker 5.0x to allow compilation on non-unix systems.
+*** perl5.001.lwall/ext/SDBM_File/sdbm/Makefile.PL Wed Feb 22 14:36:47 1995
+--- perl5.002beta1/ext/SDBM_File/sdbm/Makefile.PL Tue Nov 14 11:17:16 1995
+
+Index: ext/SDBM_File/sdbm/sdbm.c
+Include OS/2 O_BINARY flag.
+Prereq: 1.16
+*** perl5.001.lwall/ext/SDBM_File/sdbm/sdbm.c Wed Jun 7 19:46:57 1995
+--- perl5.002beta1/ext/SDBM_File/sdbm/sdbm.c Mon Nov 13 23:01:41 1995
+
+Index: ext/Socket/Makefile.PL
+Updated to 1.3. Actually we're up to 1.4, but I forgot to update
+the Makefile.PL.
+*** perl5.001.lwall/ext/Socket/Makefile.PL Thu Jan 19 18:59:06 1995
+--- perl5.002beta1/ext/Socket/Makefile.PL Sat Nov 18 15:36:56 1995
+
+Index: ext/Socket/Socket.pm
+Updated to 1.3. Actually we're up to 1.4, but I forgot to update
+the version number. This adds some non-portable stuff to manipulate
+structures in <sys/un.h>. I'll have to #ifdef it out in the next
+patch.
+
+*** perl5.001.lwall/ext/Socket/Socket.pm Sat Jul 1 15:51:54 1995
+--- perl5.002beta1/ext/Socket/Socket.pm Sat Nov 18 15:37:03 1995
+
+Index: ext/Socket/Socket.xs
+Updated to 1.3. Actually we're up to 1.4, but I forgot to update
+the version number. This adds some non-portable stuff to manipulate
+structures in <sys/un.h>. I'll have to #ifdef it out in the next
+patch.
+
+*** perl5.001.lwall/ext/Socket/Socket.xs Sat Jul 1 15:51:56 1995
+--- perl5.002beta1/ext/Socket/Socket.xs Sat Nov 18 15:36:57 1995
+
+Index: global.sym
+Remove unnecessary whichsigname that was added in patch.1n.
+*** perl5.001.lwall/global.sym Tue Nov 14 15:21:11 1995
+--- perl5.002beta1/global.sym Wed Nov 15 14:58:14 1995
+
+Index: h2ph.PL
+Converted from h2ph.SH.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/h2ph.PL Sun Nov 19 23:00:39 1995
+
+Index: h2xs.PL
+Converted from h2xs.SH.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/h2xs.PL Sun Nov 19 22:37:58 1995
+
+Index: hints/aix.sh
+Add gcc-specific -Xlinker, if you're using gcc.
+*** perl5.001.lwall/hints/aix.sh Thu Oct 19 21:02:08 1995
+--- perl5.002beta1/hints/aix.sh Mon Nov 13 23:03:33 1995
+
+Index: hints/freebsd.sh
+Warn about possible here-document problem.
+*** perl5.001.lwall/hints/freebsd.sh Sat Jul 1 18:44:07 1995
+--- perl5.002beta1/hints/freebsd.sh Sat Nov 18 16:21:20 1995
+
+Index: hints/hpux.sh
+Replace old hpux_9.sh, since this works for 9 and 10.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/hints/hpux.sh Mon Nov 20 09:53:28 1995
+
+Index: hints/irix_6_2.sh
+New hint file. This should be merged with irix_6.sh, since it's
+almost identical.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/hints/irix_6_2.sh Mon Nov 20 11:16:55 1995
+
+Index: hints/ncr_tower.sh
+Give pointers about directory functions.
+*** perl5.001.lwall/hints/ncr_tower.sh Tue Oct 18 12:33:25 1994
+--- perl5.002beta1/hints/ncr_tower.sh Tue Oct 31 11:57:51 1995
+
+Index: hints/netbsd.sh
+Updated.
+*** perl5.001.lwall/hints/netbsd.sh Wed Jun 7 19:47:45 1995
+--- perl5.002beta1/hints/netbsd.sh Mon Nov 13 23:04:17 1995
+
+Index: hints/os2.sh
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/hints/os2.sh Tue Nov 14 11:07:33 1995
+
+Index: hints/sco.sh
+Renamed from sco_3, since it should apply to most recent versions.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/hints/sco.sh Mon Jun 5 11:50:11 1995
+
+Index: hints/solaris_2.sh
+Remove temporary file try.c.
+*** perl5.001.lwall/hints/solaris_2.sh Thu Oct 19 21:02:37 1995
+--- perl5.002beta1/hints/solaris_2.sh Mon Nov 20 16:01:50 1995
+
+Index: hints/ultrix_4.sh
+Note that you can substitute sh5 for sh to get a big speed up.
+*** perl5.001.lwall/hints/ultrix_4.sh Mon Feb 13 20:15:05 1995
+--- perl5.002beta1/hints/ultrix_4.sh Sat Nov 11 17:11:41 1995
+
+Index: installman
+Quit if they just asked for help with -h.
+*** perl5.001.lwall/installman Sat Jul 1 18:44:09 1995
+--- perl5.002beta1/installman Mon Nov 6 11:16:43 1995
+
+Index: installperl
+Updated to use Config rather than hand-reading config.sh again.
+
+Install h2ph.
+
+Create site_perl and site_perl/archname directories.
+
+*** perl5.001.lwall/installperl Sat Jul 1 18:44:12 1995
+--- perl5.002beta1/installperl Mon Nov 20 12:55:08 1995
+
+Index: lib/AutoSplit.pm
+Handle OS/2 backslashes.
+
+Tim's prototype patch.
+
+Less enthusiastic checking of autoloader_seen.
+
+*** perl5.001.lwall/lib/AutoSplit.pm Sat Jul 1 15:52:03 1995
+--- perl5.002beta1/lib/AutoSplit.pm Wed Nov 15 15:06:19 1995
+
+Index: lib/Cwd.pm
+Updated for Unix, NT, and OS/2.
+*** perl5.001.lwall/lib/Cwd.pm Wed Jun 7 19:48:18 1995
+--- perl5.002beta1/lib/Cwd.pm Mon Nov 13 23:01:38 1995
+
+Index: lib/ExtUtils/Liblist.pm
+Updated to MakeMaker 5.06.
+*** perl5.001.lwall/lib/ExtUtils/Liblist.pm Wed Jun 7 19:48:27 1995
+--- perl5.002beta1/lib/ExtUtils/Liblist.pm Mon Nov 13 22:03:29 1995
+
+Index: lib/ExtUtils/MakeMaker.pm
+Updated to MakeMaker 5.06.
+Prereq: 1.21
+*** perl5.001.lwall/lib/ExtUtils/MakeMaker.pm Thu Oct 19 21:02:57 1995
+--- perl5.002beta1/lib/ExtUtils/MakeMaker.pm Sat Nov 18 16:01:05 1995
+
+Index: lib/ExtUtils/Manifest.pm
+Updated to MakeMaker 5.06.
+*** perl5.001.lwall/lib/ExtUtils/Manifest.pm Sat Jul 1 15:52:11 1995
+--- perl5.002beta1/lib/ExtUtils/Manifest.pm Mon Nov 13 22:03:30 1995
+
+Index: lib/ExtUtils/xsubpp
+Updated to xsubpp-1.923.
+*** perl5.001.lwall/lib/ExtUtils/xsubpp Sat Jul 1 20:08:00 1995
+--- perl5.002beta1/lib/ExtUtils/xsubpp Mon Nov 20 11:03:49 1995
+
+Index: lib/File/Find.pm
+OS/2 patch for nlink.
+*** perl5.001.lwall/lib/File/Find.pm Sat Jul 1 15:52:13 1995
+--- perl5.002beta1/lib/File/Find.pm Wed Nov 15 15:20:03 1995
+
+Index: lib/Net/Ping.pm
+Updated to Net::Ping 1.00.
+*** perl5.001.lwall/lib/Net/Ping.pm Wed Jun 7 19:49:13 1995
+--- perl5.002beta1/lib/Net/Ping.pm Tue Oct 31 11:15:55 1995
+
+Index: lib/Shell.pm
+Updated for OS/2 or Unix.
+*** perl5.001.lwall/lib/Shell.pm Tue Oct 18 12:34:59 1994
+--- perl5.002beta1/lib/Shell.pm Mon Nov 13 23:01:40 1995
+
+Index: lib/Test/Harness.pm
+Updated for OS/2 or Unix.
+*** perl5.001.lwall/lib/Test/Harness.pm Tue Oct 18 12:38:35 1994
+--- perl5.002beta1/lib/Test/Harness.pm Mon Nov 13 23:01:40 1995
+
+Index: lib/Text/Tabs.pm
+Updated.
+*** perl5.001.lwall/lib/Text/Tabs.pm Wed Jun 7 19:49:20 1995
+--- perl5.002beta1/lib/Text/Tabs.pm Sat Nov 18 16:08:55 1995
+
+Index: lib/Text/Wrap.pm
+New module.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/lib/Text/Wrap.pm Sat Nov 18 16:08:56 1995
+
+Index: lib/diagnostics.pm
+New module.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/lib/diagnostics.pm Tue Nov 14 16:16:36 1995
+
+Index: lib/lib.pm
+Automatically try to load an architecture-dependent library too.
+*** perl5.001.lwall/lib/lib.pm Sat Jul 1 15:51:37 1995
+--- perl5.002beta1/lib/lib.pm Fri Nov 10 16:50:43 1995
+
+Index: lib/overload.pm
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/lib/overload.pm Sat Nov 18 16:03:33 1995
+
+Index: lib/perl5db.pl
+Emacs and OS/2 fixes.
+*** perl5.001.lwall/lib/perl5db.pl Sun Mar 12 22:34:53 1995
+--- perl5.002beta1/lib/perl5db.pl Wed Nov 15 22:37:45 1995
+
+Index: lib/splain
+New file -- same as diagnostics.pm.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/lib/splain Tue Nov 14 16:16:36 1995
+
+Index: mg.c
+Remove unnecessary whichsigname introduced in 5.001n.
+*** perl5.001.lwall/mg.c Tue Nov 14 15:31:03 1995
+--- perl5.002beta1/mg.c Wed Nov 15 15:44:10 1995
+
+Index: minimod.PL
+Made c++ friendly.
+*** perl5.001.lwall/minimod.PL Mon Feb 13 20:15:47 1995
+--- perl5.002beta1/minimod.PL Sun Nov 19 23:01:02 1995
+
+Index: miniperlmain.c
+Made c++ friendly.
+*** perl5.001.lwall/miniperlmain.c Mon Feb 13 21:48:50 1995
+--- perl5.002beta1/miniperlmain.c Sat Nov 18 15:48:10 1995
+
+Index: op.c
+Larry's post 5.001mx prototype patch.
+*** perl5.001.lwall/op.c Tue Nov 14 20:36:08 1995
+--- perl5.002beta1/op.c Wed Nov 15 22:10:36 1995
+
+Index: os2/Makefile.SH
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/os2/Makefile.SH Tue Nov 14 11:07:32 1995
+
+Index: os2/POSIX.mkfifo
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/os2/POSIX.mkfifo Tue Nov 14 10:48:16 1995
+
+Index: os2/README
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/os2/README Tue Nov 14 14:42:13 1995
+
+Index: os2/diff.Makefile
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/os2/diff.Makefile Tue Nov 14 11:09:29 1995
+
+Index: os2/diff.configure
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/os2/diff.configure Sun Nov 12 01:31:34 1995
+
+Index: os2/diff.installperl
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/os2/diff.installperl Tue Nov 14 11:09:28 1995
+
+Index: os2/diff.mkdep
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/os2/diff.mkdep Tue Nov 14 11:09:28 1995
+
+Index: os2/diff.x2pMakefile
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/os2/diff.x2pMakefile Tue Nov 14 11:09:29 1995
+
+Index: os2/os2.c
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/os2/os2.c Tue Nov 14 11:07:33 1995
+
+Index: os2/os2ish.h
+New file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/os2/os2ish.h Tue Nov 14 11:07:33 1995
+
+Index: perl.c
+Add -h option to print out usage.
+
+Add 'beta' to version number.
+
+Add new library hierarchy. See INSTALL.
+
+*** perl5.001.lwall/perl.c Tue Nov 14 20:09:28 1995
+--- perl5.002beta1/perl.c Sun Nov 19 16:11:29 1995
+
+Index: perl.h
+
+Move around some includes for OS/2.
+
+Check for <locale.h>
+
+*** perl5.001.lwall/perl.h Thu Nov 9 19:50:43 1995
+--- perl5.002beta1/perl.h Wed Nov 15 17:13:16 1995
+
+Index: perldoc.PL
+
+Moved from perldoc.SH. Updated to handle no nroff.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/perldoc.PL Tue Nov 14 14:57:57 1995
+
+Index: pod/Makefile
+Updated for new pods and for new .PL format.
+*** perl5.001.lwall/pod/Makefile Wed Jun 7 19:50:02 1995
+--- perl5.002beta1/pod/Makefile Mon Nov 20 13:00:50 1995
+
+Index: pod/perl.pod
+Updated to refer to new pods.
+*** perl5.001.lwall/pod/perl.pod Thu Oct 5 19:54:43 1995
+--- perl5.002beta1/pod/perl.pod Sat Nov 18 17:23:58 1995
+
+Index: pod/perlbook.pod
+Updated info.
+*** perl5.001.lwall/pod/perlbook.pod Wed Feb 22 18:32:35 1995
+--- perl5.002beta1/pod/perlbook.pod Sat Nov 11 17:17:23 1995
+
+Index: pod/perlbot.pod
+Include SUPER stuff.
+*** perl5.001.lwall/pod/perlbot.pod Wed Jun 7 19:50:14 1995
+--- perl5.002beta1/pod/perlbot.pod Fri Nov 10 17:27:33 1995
+
+Index: pod/perlcall.pod
+Change perlapi to perlxs.
+*** perl5.001.lwall/pod/perlcall.pod Wed Jun 7 19:50:17 1995
+--- perl5.002beta1/pod/perlcall.pod Tue Oct 31 15:37:57 1995
+
+Index: pod/perldata.pod
+Tom's updates.
+*** perl5.001.lwall/pod/perldata.pod Sun Mar 12 22:35:14 1995
+--- perl5.002beta1/pod/perldata.pod Sat Nov 18 17:23:59 1995
+
+Index: pod/perldiag.pod
+Tom's updates.
+*** perl5.001.lwall/pod/perldiag.pod Tue Nov 14 22:04:11 1995
+--- perl5.002beta1/pod/perldiag.pod Sun Nov 19 22:10:58 1995
+
+Index: pod/perldsc.pod
+Tom's updates.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/pod/perldsc.pod Sat Nov 18 17:24:22 1995
+
+Index: pod/perlform.pod
+Tom's updates.
+*** perl5.001.lwall/pod/perlform.pod Wed Feb 22 18:32:41 1995
+--- perl5.002beta1/pod/perlform.pod Sat Nov 18 17:23:59 1995
+
+Index: pod/perlfunc.pod
+Tom's updates.
+*** perl5.001.lwall/pod/perlfunc.pod Tue Nov 14 15:31:33 1995
+--- perl5.002beta1/pod/perlfunc.pod Sat Nov 18 17:24:01 1995
+
+Index: pod/perlguts.pod
+Change perlapi to perlxs.
+*** perl5.001.lwall/pod/perlguts.pod Wed Jun 7 19:50:25 1995
+--- perl5.002beta1/pod/perlguts.pod Tue Oct 31 15:38:18 1995
+
+Index: pod/perlipc.pod
+New file from Tom.
+*** perl5.001.lwall/pod/perlipc.pod Wed Feb 22 18:32:48 1995
+--- perl5.002beta1/pod/perlipc.pod Sat Nov 18 17:24:02 1995
+
+Index: pod/perllol.pod
+New file from Tom.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/pod/perllol.pod Sat Nov 18 17:24:22 1995
+
+Index: pod/perlmod.pod
+Updates from Tom.
+*** perl5.001.lwall/pod/perlmod.pod Wed Feb 22 18:32:51 1995
+--- perl5.002beta1/pod/perlmod.pod Sat Nov 18 17:24:03 1995
+
+Index: pod/perlop.pod
+Add missing '>'.
+*** perl5.001.lwall/pod/perlop.pod Tue Nov 14 15:31:37 1995
+--- perl5.002beta1/pod/perlop.pod Sat Nov 18 17:24:03 1995
+
+Index: pod/perlpod.pod
+Add note about =cut operator.
+*** perl5.001.lwall/pod/perlpod.pod Tue Oct 18 12:39:53 1994
+--- perl5.002beta1/pod/perlpod.pod Sun Nov 19 22:22:59 1995
+
+Index: pod/perlref.pod
+Updates from Tom.
+*** perl5.001.lwall/pod/perlref.pod Tue Mar 7 00:56:46 1995
+--- perl5.002beta1/pod/perlref.pod Sat Nov 18 17:24:04 1995
+
+Index: pod/perlsyn.pod
+Updates from Tom.
+*** perl5.001.lwall/pod/perlsyn.pod Sat Mar 11 14:13:48 1995
+--- perl5.002beta1/pod/perlsyn.pod Sat Nov 18 17:24:04 1995
+
+Index: pod/perlxs.pod
+Updated.
+*** perl5.001.lwall/pod/perlxs.pod Tue Nov 14 15:31:42 1995
+--- perl5.002beta1/pod/perlxs.pod Sun Nov 19 22:12:44 1995
+
+Index: pod/perlxstut.pod
+New file from Jeff.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/pod/perlxstut.pod Mon Nov 20 13:02:12 1995
+
+Index: pod/pod2html.PL
+Updated -- version 1.15 merges Tom's suggestions and ideas from
+pod2fm.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/pod/pod2html.PL Sun Nov 19 22:11:59 1995
+
+Index: pod/pod2latex.PL
+Changed to a .PL file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/pod/pod2latex.PL Wed Nov 15 22:32:39 1995
+
+Index: pod/pod2man.PL
+Changed to a .PL file.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/pod/pod2man.PL Wed Nov 15 22:32:51 1995
+
+Index: pp_ctl.c
+Add OS/2 stuff.
+*** perl5.001.lwall/pp_ctl.c Wed Nov 15 00:37:25 1995
+--- perl5.002beta1/pp_ctl.c Wed Nov 15 21:46:37 1995
+
+Index: pp_sys.c
+Add OS/2 stuff.
+*** perl5.001.lwall/pp_sys.c Tue Nov 14 21:03:06 1995
+--- perl5.002beta1/pp_sys.c Wed Nov 15 21:51:33 1995
+
+Index: proto.h
+Add OS/2 stuff to better protect MYMALLOC.
+*** perl5.001.lwall/proto.h Tue Nov 14 21:01:28 1995
+--- perl5.002beta1/proto.h Wed Nov 15 21:55:23 1995
+
+Index: t/TEST
+Add OS/2 check for perl.exe.
+*** perl5.001.lwall/t/TEST Sat Jan 14 19:35:33 1995
+--- perl5.002beta1/t/TEST Tue Nov 14 11:22:08 1995
+
+Index: t/lib/db-btree.t
+Updated.
+*** perl5.001.lwall/t/lib/db-btree.t Tue Oct 18 12:44:05 1994
+--- perl5.002beta1/t/lib/db-btree.t Tue Oct 31 11:53:29 1995
+
+Index: t/op/overload.t
+Updated.
+*** perl5.001.lwall/t/op/overload.t Tue Nov 14 20:56:57 1995
+--- perl5.002beta1/t/op/overload.t Mon Nov 20 15:48:56 1995
+
+Index: t/op/stat.t
+Add note about tmpfs failures.
+*** perl5.001.lwall/t/op/stat.t Tue Oct 18 12:46:23 1994
+--- perl5.002beta1/t/op/stat.t Wed Nov 15 22:00:50 1995
+
+Index: toke.c
+Patch from Paul M. for source filters.
+*** perl5.001.lwall/toke.c Tue Nov 14 21:59:50 1995
+--- perl5.002beta1/toke.c Wed Nov 15 22:08:23 1995
+
+Index: util.c
+Varargs fixes.
+*** perl5.001.lwall/util.c Wed Jun 7 19:51:19 1995
+--- perl5.002beta1/util.c Tue Nov 14 10:46:37 1995
+
+Index: writemain.SH
+Make c++ friendly.
+*** perl5.001.lwall/writemain.SH Wed Feb 8 19:44:20 1995
+--- perl5.002beta1/writemain.SH Sat Nov 18 15:51:55 1995
+
+Index: x2p/Makefile.SH
+Updated for .PL extraction.
+*** perl5.001.lwall/x2p/Makefile.SH Wed Jun 7 19:51:37 1995
+--- perl5.002beta1/x2p/Makefile.SH Sun Nov 19 23:17:39 1995
+
+Index: x2p/a2p.h
+Add OS/2 stuff.
+*** perl5.001.lwall/x2p/a2p.h Thu Oct 19 21:03:58 1995
+--- perl5.002beta1/x2p/a2p.h Tue Nov 14 10:46:57 1995
+
+Index: x2p/cflags.SH
+Add .obj for OS/2.
+*** perl5.001.lwall/x2p/cflags.SH Tue Oct 18 12:47:34 1994
+--- perl5.002beta1/x2p/cflags.SH Tue Nov 14 15:18:27 1995
+
+Index: x2p/find2perl.PL
+Changed from .SH to .PL.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/x2p/find2perl.PL Sun Nov 19 23:11:58 1995
+
+Index: x2p/s2p.PL
+Changed from .SH to .PL extraction.
+*** /dev/null Mon Nov 20 17:28:51 1995
+--- perl5.002beta1/x2p/s2p.PL Sun Nov 19 23:14:59 1995
diff --git a/contrib/perl5/Changes5.003 b/contrib/perl5/Changes5.003
new file mode 100644
index 000000000000..daba248a9e5f
--- /dev/null
+++ b/contrib/perl5/Changes5.003
@@ -0,0 +1,100 @@
+-------------
+Version 5.003
+-------------
+
+ ***> IMPORTANT NOTICE: <***
+The main reason for this release was to fix a security bug affecting
+suidperl on some systems. If you build suidperl on your system, it
+is strongly recommended that you replace any existing copies with
+version 5.003 or later immediately.
+
+The changes in 5.003 have been held to a minimum, in the hope that this
+will simplify installation and testing at sites which may be affected
+by the security hole in suidperl. In brief, 5.003 does the following:
+
+- Plugs security hole in suidperl mechanism on affected systems
+
+- MakeMaker was also updated to version 5.34, and extension Makefile.PLs
+ were modified to match it.
+
+- The following hints files were updated: bsdos.sh, hpux.sh, linux.sh,
+ machten.sh, solaris_2.sh
+
+- A fix was added to installperl to insure that file permissions were
+ set correctly for the installed C header files.
+
+- t/op/stat.t was modified to work around MachTen's belief that /dev/null
+ is a terminal device.
+
+- Incorporation of Perl version information into the VMS' version of
+ config.h was changed to make it compatible with the older VAXC.
+
+- Minor fixes were made to VMS-specific C code, and the routine
+ VMS::Filespec::rmsexpand was added.
+
+----------------
+Version 5.002_01
+----------------
+
+- The EMBED namespace changes are now used by default, in order to better
+ segregate Perl's C global symbols from those belonging to embedding
+ applications or to libraries. This makes it necessary to rebuild dynamic
+ extensions built under previous versions of Perl without the EMBED option.
+ The default use of EMBED can be overridden by placing -DNO_EMBED on the
+ cc command line.
+
+ The EMBED change is the beginning of a general cleanup of C global
+ symbols used by Perl, so binary compatibility with previously
+ compiled dynamic extensions may be broken again in the next few
+ releases.
+
+- Several bugs in the core were fixed, including the following:
+ - made sure FILE * for -e temp file was closed only once
+ - improved form of single-statement macro definitions to keep
+ as many ccs as possible happy
+ - fixed file tests to insure that signed values were used when
+ computing differences between times.
+ - fixed toke.c so implicit loop isn't doubled when perl is
+ invoked with both the -p and -n switches
+
+- The new SUBVERSION number has been included in the default value for
+ architecture-specific library directories, so development and
+ production architecture-dependent libraries can coexist.
+
+- Two new magic variables, $^E and $^O, have been added. $^E contains the
+ OS-specific equivalent of $!. $^O contains the name of the operating
+ system, in order to make it easily available to Perl code whose behavior
+ differs according to its environment. The standard library files have
+ been converted to use $^O in preference to $Config{'osname'}.
+
+- A mechanism was added to allow listing of locally applied patches
+ in the output of perl -v.
+
+- Miscellaneous minor corrections and updates were made to the documentation.
+
+- Extensive updates were made to the OS/2 and VMS ports
+
+- The following hints file were updated: bsdos.sh, dynixptx.sh,
+ irix_6_2.sh, linux.sh, os2.sh
+
+- Several changes were made to standard library files:
+ - reduced use of English.pm and $`, $', and $& in library modules,
+ since these degrade module loading and evaluation of regular expressions,
+ respectively.
+ - File/Basename.pm: Added path separator to dirname('.')
+ - File/Copy.pm: Added support for VMS and OS/2 system-level copy
+ - MakeMaker updated to v5.26
+ - Symbol.pm now accepts old (') and new (::) package delimiters
+ - Sys/Syslog.pm uses Sys::Hostname only when necessary
+ - chat2.pl picks up necessary constants from socket.ph
+ - syslog.pl: Corrected thinko 'Socket' --> 'Syslog'
+ - xsubpp updated to v1.935
+
+
+- The perlbug utility is now more cautious about sending mail, in order
+ to reduce the chance of accidentally send a bug report by giving the
+ wrong response to a prompt.
+
+- The -m switch has been added to perldoc, causing it to display the
+ Perl code in target file as well as any documentation.
+
diff --git a/contrib/perl5/Changes5.004 b/contrib/perl5/Changes5.004
new file mode 100644
index 000000000000..d0601663ecf5
--- /dev/null
+++ b/contrib/perl5/Changes5.004
@@ -0,0 +1,16073 @@
+Please note: This file provides a summary of significant changes
+between versions and sub-versions of Perl, not necessarily a complete
+list of each modification. If you'd like more detailed information,
+please consult the comments in the patches on which the relevant
+release of Perl is based. (Patches can be found on any CPAN
+site, in the .../src/5.0 directory for full version releases,
+or in the .../src/5/0/unsupported directory for sub-version
+releases.)
+
+
+ ---------------
+ CAST AND CREW
+ ---------------
+
+To give due honor to those who have made Perl 5.004 what is is today,
+here are some of the more common names in the Changes file, and their
+current addresses (as of March 1997):
+
+ Gisle Aas <gisle@aas.no>
+ Kenneth Albanowski <kjahds@kjahds.com>
+ Graham Barr <gbarr@ti.com>
+ Spider Boardman <spider@orb.nashua.nh.us>
+ Tom Christiansen <tchrist@perl.com>
+ Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
+ M. J. T. Guy <mjtg@cus.cam.ac.uk>
+ Gurusamy Sarathy <gsar@engin.umich.edu>
+ Jarkko Hietaniemi <jhi@iki.fi>
+ Nick Ing-Simmons <nik@tiuk.ti.com>
+ Andreas Koenig <a.koenig@mind.de>
+ Doug MacEachern <dougm@opengroup.org>
+ Paul Marquess <pmarquess@bfsec.bt.co.uk>
+ Hans Mulder <hansm@euronet.nl>
+ Jeff Okamoto <okamoto@hpcc123.corp.hp.com>
+ Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
+ Tom Phoenix <rootbeer@teleport.com>
+ Norbert Pueschel <pueschel@imsdd.meb.uni-bonn.de>
+ Dean Roehrich <roehrich@cray.com>
+ Roderick Schertler <roderick@argon.org>
+ Larry W. Virden <lvirden@cas.org>
+ Ilya Zakharevich <ilya@math.ohio-state.edu>
+
+And the Keepers of the Patch Pumpkin:
+
+ Charles Bailey <bailey@hmivax.humgen.upenn.edu>
+ Tim Bunce <Tim.Bunce@ig.co.uk>
+ Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Chip Salzenberg <chip@perl.com>
+
+And, of course, the Author of Perl:
+
+ Larry Wall <larry@wall.org>
+
+----------------
+Version 5.004_05 Maintenance release 5 for 5.004
+----------------
+
+"I said to my soul, be still, and wait without hope
+ For hope would hope for the wrong thing; wait without love
+ For love would be love of the wrong thing; there is yet faith
+ But the faith and the love and the hope are all in the waiting.
+ Wait without thought, for you are not ready for thought:
+ So the darkness shall be light, and the stillness the dancing."
+ -- T.S.Eliot, East Coker
+
+
+ HEADLINES FOR THIS MAINTENANCE RELEASE
+
+ TBA
+
+
+Change 996 on 1998/05/15 by TimBunce@ig.co.uk
+
+ Title: "Negative array subscript unrecognized in regex"
+ From: Mark-Jason Dominus <mjd@plover.com>,
+ h.sanden@elsevier.nl (Hugo van der Sanden)
+ Msg-ID: <19980425040819.13828.qmail@plover.com>,
+ <199805151514.RAA04121@dorlas.elsevier.nl>
+ Files: t/base/lex.t toke.c
+
+ Title: "Remove e_fp from toke.c after change 955"
+ From: Tim Bunce
+ Files: toke.c
+
+Change 995 on 1998/05/15 by TimBunce@ig.co.uk
+
+ Title: "Fix -e security hole (no longer uses temp file)"
+ From: Tim Bunce
+ Files: embed.h perl.h perl.c
+
+Change 992 on 1998/05/15 by TimBunce@ig.co.uk
+
+ Title: "install non-backwards compatible .pm files into archlib"
+ From: Tim Bunce
+ Files: installperl
+
+ Title: "revert "Can't locate" message to original for maintenance"
+ From: Tim Bunce
+ Msg-ID: <199804240047.SAA24155@den-mdev1.co.csgsystems.com>
+ Files: pod/perldiag.pod pp_ctl.c
+
+Change 990 on 1998/05/15 by TimBunce@ig.co.uk
+
+ Title: "Add tests for die $ref"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <355C6297.121B576B@ti.com>
+ Files: MANIFEST t/op/die.t
+
+Change 989 on 1998/05/15 by TimBunce@ig.co.uk
+
+ Title: "Fix t/op/ipcmsg.t for Digital UNIX"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199805151337.QAA01174@alpha.hut.fi>
+ Files: t/op/ipcmsg.t
+
+Change 986 on 1998/05/15 by TimBunce@ig.co.uk
+
+ Title: "Patches for BeOS port of Perl, courtesy of Tom Spindler"
+ From: Jarkko Hietaniemi <jhi@iki.fi>, Tom Spindler
+ Msg-ID: <199805042312.CAA09025@alpha.hut.fi>
+ Files: MANIFEST Configure config_h.SH hints/beos.sh pod/perlfunc.pod
+ Porting/Glossary README.beos beos/nm.c lib/Term/ReadLine.pm
+ plan9/config.plan9 pp_sys.c t/io/pipe.t vms/config.vms
+ win32/config.bc win32/config.vc win32/config_H.bc
+ win32/config_H.vc
+
+Change 985 on 1998/05/15 by TimBunce@ig.co.uk
+
+ Title: "allow die $ref"
+ From: Graham Barr <gbarr@ti.com>, Tim.Bunce@ig.co.uk (Tim Bunce)
+ Msg-ID: <199805151351.OAA01985@toad.ig.co.uk>, <355C3E67.AF25B9F7@ti.com>
+ Files: pp_ctl.c pp_sys.c util.c
+
+ Title: "ExtUtils::Manifest could truncate files during "make dist""
+ From: "James E Jurach Jr." <muaddib@arrakis.int.ein.cz>,
+ koenig@kulturbox.de (Andreas J. Koenig)
+ Msg-ID: <199805111048.MAA02573@arrakis.int.ein.cz>,
+ <sfc90o8bgie.fsf@dubravka.in-berlin.de>
+ Files: lib/ExtUtils/Manifest.pm
+
+ Title: "Autosplit doesn't like upper case letters in sub names on VMS"
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Msg-ID: <3.0.5.32.19980330152332.009cb130@osshe.edu>
+ Files: lib/AutoSplit.pm
+
+ Title: "AutoSplit/AutoLoaded subs: give useful line numbers in warnings etc"
+ From: "Jesse N. Glick" <jglick@sig.bsh.com>, koenig@anna.mind.de (Andreas
+ J. Koenig), larry@wall.org (Larry Wall)
+ Msg-ID: <199709292015.NAA09627@wall.org>, <342FCDDF.23534195@sig.bsh.com>,
+ <sfc202c9jsb.fsf@anna.in-berlin.de>,
+ <sfc3efg5rhg.fsf@dubravka.in-berlin.de>
+ Files: lib/AutoSplit.pm
+
+Change 984 on 1998/05/15 by TimBunce@ig.co.uk
+
+ ------ CORE LANGUAGE ------
+
+ Title: "Fix close pipe returning status from wrong child"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, kstar@chapin.edu@ig.co.uk ()
+ Msg-ID: <199805142313.TAA02684@chapin.edu>,
+ <E0yZ8ah-0005d8-00@taurus.cus.cam.ac.uk>
+ Files: t/io/pipe.t util.c
+
+ Title: "Avoid English.pm triggering load of Errno.pm"
+ From: Tim Bunce
+ Files: gv.c lib/English.pm
+
+ ------ DOCUMENTATION ------
+
+ Title: "Document child exit cause a parent sleep to end early"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0yZwMK-0000D9-00@taurus.cus.cam.ac.uk>
+ Files: pod/perlfunc.pod
+
+ ------ EXTENSIONS ------
+
+ Title: "BSD Platforms need STRUCT_TM_HASZONE for POSIX"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980512095524.8158C-100000@newton.phys>
+ Files: MANIFEST ext/POSIX/hints/bsdos.pl ext/POSIX/hints/freebsd.pl
+ ext/POSIX/hints/netbsd.pl ext/POSIX/hints/openbsd.pl
+
+ Title: "MM_VMS.pm fixes for building external library"
+ From: Dan Sugalski <sugalskd@ous.edu>
+ Msg-ID: <3.0.5.32.19980511160542.009dd480@ous.edu>
+ Files: lib/ExtUtils/MM_VMS.pm
+
+ Title: "Appease picky DEC compiler in POSIX.xs"
+ From: Dan Sugalski <sugalskd@ous.edu>
+ Msg-ID: <3.0.5.32.19980511161434.009f8bb0@ous.edu>
+ Files: ext/POSIX/POSIX.xs
+
+ ------ TESTS ------
+
+ Title: "Fix constant detection in t/op/ipcsem.t for Digit UNIX"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199805121212.PAA15351@alpha.hut.fi>
+ Files: t/op/ipcsem.t
+
+ Title: "Fix doc bug for system() return value"
+ From: Daniel Grisinger <dgris@perrin.dimensional.com>
+ Msg-ID: <Pine.LNX.3.96.980514165608.4062A-100000@perrin.dimensional.com>
+ Files: pod/perlfunc.pod t/op/exec.t
+
+ ------ UTILITIES ------
+
+ Title: "Avoid possible constant autoload loop"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Graham Barr <gbarr@ti.com>, Ilya
+ Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199805141910.PAA26994@monk.mps.ohio-state.edu>,
+ <355B475A.C5AD4B90@ti.com>,
+ <E0ya11X-0000hm-00@taurus.cus.cam.ac.uk>
+ Files: utils/h2xs.PL
+
+ Title: "Further improvements to h2ph.PL"
+ From: kstar@chapin.edu
+ Msg-ID: <199805130241.WAA25459@chapin.edu>
+ Files: utils/h2ph.PL
+
+Change 982 on 1998/05/15 by TimBunce@ig.co.uk
+
+ Title: "comment init_postdump_symbols issues"
+ From: Tim Bunce
+ Files: perl.c
+
+ Title: "Improve sort docs re SUBNAME"
+ From: circle@azstarnet.com
+ Msg-ID: <199804281828.LAA22737@andromeda.azstarnet.com>
+ Files: pod/perlfunc.pod
+
+Change 981 on 1998/05/15 by TimBunce@ig.co.uk
+
+ Title: "Add hook to tie %! to external Errno.pm module (not included)"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <355080CD.1111BC81@ti.com>
+ Files: gv.c
+
+Change 971 on 1998/05/14 by TimBunce@ig.co.uk
+
+ Title: "fix C<print "foo ${\()}"> (pp_refgen fumbles when G_SCALAR, no args)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805070402.AAA02858@aatma.engin.umich.edu>
+ Files: pp.c
+
+Change 970 on 1998/05/14 by TimBunce@ig.co.uk
+
+ Title: "perlbug reformatted"
+ From: Dominic Dunlop <domo@vo.lu>, Hugo van der Sanden
+ <hv@crypt0.demon.co.uk>
+ Msg-ID: <199805110954.LAA20367@dorlas.elsevier.nl>,
+ <l03130300b17cebcb6d33@[194.222.64.89]>,
+ <v03110702b17ccbab6824@[195.95.102.67]>
+ Files: utils/perlbug.PL
+
+Change 965 on 1998/05/14 by TimBunce@ig.co.uk
+
+ Title: "Sub declaration cost reduced from ~500 to ~100 bytes"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199805050607.CAA02050@monk.mps.ohio-state.edu>
+ Files: gv.h gv.c op.c
+
+Change 949 on 1998/05/14 by TimBunce@ig.co.uk
+
+ Title: "while($x=<>) no longer warns (implicit defined added)"
+ From: Nick Ing-Simmons <nik@tiuk.ti.com>
+ Msg-ID: <199805051035.LAA27365@pluto.tiuk.ti.com>
+ Files: MANIFEST op.c t/op/defins.t
+
+Change 946 on 1998/05/14 by TimBunce@ig.co.uk
+
+ Title: "Fix PERL_DESTRUCT_LEVEL core dumps"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805062301.TAA24599@aatma.engin.umich.edu>
+ Files: perl.c sv.c t/op/misc.t
+
+Change 944 on 1998/05/14 by TimBunce@ig.co.uk
+
+ Title: "5.004_04-m2 Cleanup of test failures"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805070416.AAA03082@aatma.engin.umich.edu>
+ Files: t/op/die_exit.t t/op/ipcmsg.t t/op/ipcsem.t t/op/taint.t
+ win32/config.bc win32/config.vc
+
+Change 922 on 1998/05/11 by TimBunce@ig.co.uk
+
+ Assorted patches:
+
+ ------ CORE LANGUAGE ------
+
+ Title: "incorrect return value for hv_iterinit"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805031848.OAA20618@aatma.engin.umich.edu>
+ Files: pod/perlguts.pod hv.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "perlvar.pod buglet E<EVMSERR>"
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9805041415.AA22185@o09.xray.mpe.mpg.de>
+ Files: pod/perlvar.pod
+
+ Title: "Improve docs for warning about code after an exec()"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Chaim Frenkel
+ <chaimf@concentric.net>
+ Msg-ID: <E0yYUit-0003yb-00@taurus.cus.cam.ac.uk>,
+ <m3ra22qn1z.fsf@chany-p100.emwp.com>
+ Files: pod/perlfunc.pod
+
+ Title: "Remove dead code from pod2man"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0yXmuT-0006Ll-00@ursa.cus.cam.ac.uk>
+ Files: pod/pod2man.PL
+
+ Title: "tweak doc for C<do FILENAME>"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199805090017.UAA06888@aatma.engin.umich.edu>
+ Files: pod/perlfunc.pod
+
+ Title: "Document integer pragma effect on % operator"
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <m3yawjmzhx.fsf@furu.g.aas.no>
+ Files: pod/perlop.pod
+
+ Title: "Reduce rm command line length in pod/Makefile"
+ From: Hugo van der Sanden <h.sanden@elsevier.nl>
+ Msg-ID: <199805041423.QAA13199@dorlas.elsevier.nl>
+ Files: pod/Makefile
+
+ ------ EXTENSIONS ------
+
+ Title: "Clarify Termios usage in POSIX.pod"
+ From: Rocco Caputo <troc@netrus.net>
+ Msg-ID: <199805101952.PAA12738@ns.netrus.net>
+ Files: ext/POSIX/POSIX.pod
+
+ ------ LIBRARY ------
+
+ Title: "Fix File::Find::finddepth typo in trial 2 release"
+ From: koenig@kulturbox.de (Andreas J. Koenig)
+ Msg-ID: <sfcbttflsjz.fsf@dubravka.in-berlin.de>
+ Files: lib/File/Find.pm t/lib/filefind.t
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Add Porting/patching.pod document"
+ From: Daniel Grisinger <dgris@tdrenterprises.com>
+ Msg-ID: <199805030305.XAA16147@relay.pair.com>
+ Files: MANIFEST Porting/patching.pod
+
+ Title: "hints/machten.sh: disable semctl(), align with devel version"
+ From: Dominic Dunlop <domo@vo.lu>
+ Msg-ID: <v03110701b175fc029eb1@[195.95.102.115]>
+ Files: hints/machten.sh
+
+ Title: "Add VMS specifics to Porting/makerel"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01IWDK1LONRQ0026P0@cor.newman.upenn.edu>,
+ <199804271732.SAA13762@toad.ig.co.uk>,
+ <9804250212.AA27695@forte.com>
+ Files: Porting/makerel
+
+Change 913 on 1998/05/01 by TimBunce@ig.co.uk
+
+ Update MANIFEST for trial 2.
+ (Porting/Contract lib/Tie/Handle.pm t/op/tiehandle.t)
+
+Change 912 on 1998/05/01 by TimBunce@ig.co.uk
+
+ Add t/op/tiehandle.t as xtext to repository (see change 911)
+
+Change 911 on 1998/05/01 by TimBunce@ig.co.uk
+
+ Title: "Add ERRSV, ERRHV, DEFSV and SAVE_DEFSV for XS 5.005 compatibility"
+ From: timbo@ig.co.uk (Tim Bunce)
+ Msg-ID: <199804200854.JAA01482@toad.ig.co.uk>
+ Files: perl.h
+
+ Title: "Add WRITE & CLOSE to TIEHANDLE"
+ From: Graham Barr <gbarr@pobox.com>
+ Msg-ID: <34F63DC8.CA95670F@pobox.com>
+ Files: pod/perltie.pod lib/Tie/Handle.pm pp_sys.c t/op/tiehandle.t
+
+Change 910 on 1998/05/01 by TimBunce@ig.co.uk
+
+ Title: "Add warning for Illegal hex digit"
+ From: Stephen P Potter <spp@spp.users.ds.net>, Stephen Potter
+ <spp@psasolar.colltech.com>, Tim.Bunce@ig.co.uk (Tim Bunce)
+ Msg-ID: <199804232219.SAA02267@spp.users.ds.net>,
+ <199804271409.PAA12819@toad.ig.co.uk>,
+ <199804280307.WAA12332@psasolar.psa.pencom.com>
+ Files: pod/perldiag.pod util.c
+
+ Title: "perl_call_method() bug fix (corrupt op pointer)"
+ From: "Alterman, Eugene" <Eugene.Alterman@bremer-inc.com>
+ Msg-ID: <510415F72ECFD111A31700A0C9B3CCDE3098@efx98digmasa.bremer-inc.com>
+ Files: perl.c
+
+ Title: "Fix printf segmentation fault"
+ From: Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Msg-ID: <l03130300b16bebdbc314@[194.222.64.89]>
+ Files: pp_hot.c
+
+ Title: "Document changed local($a[$i],$b{$j}) behaviour re delete/splice"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01IVMVIHNZ36001NKH@cor.newman.upenn.edu>
+ Files: pod/perlsub.pod
+
+Change 909 on 1998/05/01 by TimBunce@ig.co.uk
+
+ Title: "Change Ilya's do_binmode to K&R prototype and move to doio.c"
+ Files: doio.c util.c
+
+Change 907 on 1998/05/01 by TimBunce@ig.co.uk
+
+ Title: "Runtime Carp verbosity without aliasing"
+ From: Joshua.Pritikin@NewYork2.dmg.deuba.com, Tim Bunce
+ Msg-ID: <H00000e50003936c@MHS>
+ Files: lib/Carp.pm
+
+ Title: "Fix File::Basename to not untaint results (using new //t flag)"
+ From: Eric Hammond <erich@finity.citysearch.com>, Tom Phoenix
+ <rootbeer@teleport.com>
+ Msg-ID: <199710070515.WAA00682@finity.citysearch.com>,
+ <Pine.GSO.3.96.971007074114.14211J-100000@usertest.teleport.com>
+ Files: lib/File/Basename.pm
+
+Change 906 on 1998/04/28 by TimBunce@ig.co.uk
+
+ ------ CORE LANGUAGE ------
+
+ Title: "5.004_04m5t1: Fix dangling references in LVs", "Fix dangling
+ references in LVs"
+ From: Spider Boardman <spider@orb.nashua.nh.us>
+ Msg-ID: <199804010541.AAA32615@Orb.Nashua.NH.US>,
+ <19980422164037.D29222@perl.org>
+ Files: embed.h keywords.h opcode.h perl.h proto.h doop.c global.sym mg.c
+ pp.c sv.c
+
+ Title: "Fix SvGMAGIC typo in change 904"
+ Files: doop.c
+
+Change 905 on 1998/04/28 by TimBunce@ig.co.uk
+
+ Regexp patches
+
+ Title: "New regex flag //t to leave $1 etc. tainted"
+ From: Chip Salzenberg <chip@pobox.com>, Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <19980310192640.37826@cyprus>
+ Files: pod/perlop.pod pod/perlre.pod op.h dump.c mg.c pp_hot.c sv.c
+ t/op/taint.t toke.c
+
+ Title: "Don't accidentally untaint target of s///"
+ From: Chip Salzenberg <chip@pobox.com>
+ Msg-ID: <19980310151756.24767@cyprus>
+ Files: pp_ctl.c pp_hot.c t/op/taint.t
+
+ Title: "Allow but ignore embedded /...(?o).../ in regexp"
+ From: h.sanden@elsevier.nl (Hugo van der Sanden)
+ Msg-ID: <199804201243.OAA08244@dorlas.elsevier.nl>
+ Files: regcomp.c
+
+Change 904 on 1998/04/27 by TimBunce@ig.co.uk
+
+ Assorted patches:
+
+ ------ CORE LANGUAGE ------
+
+ Title: "Protect join() against double reads on undef and SvGMAGICALs"
+ From: Chip Salzenberg <chip@perlsupport.com>, Tim Bunce
+ <Tim.Bunce@ig.co.uk>
+ Msg-ID: <19980424080630.D13985@perl.org>
+ Files: doop.c
+
+ Title: "Better error message for require failure"
+ From: epeschko@den-mdev1 (Ed Peschko)
+ Msg-ID: <199804240047.SAA24155@den-mdev1.co.csgsystems.com>
+ Files: pod/perldiag.pod pp_ctl.c
+
+ Title: "fixes for various noises under PERL_DESTRUCT_LEVEL"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199804231926.PAA23969@aatma.engin.umich.edu>
+ Files: perl.c
+
+ Title: "Fix nice_chunk memory leak"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199804052347.TAA15699@aatma.engin.umich.edu>
+ Files: sv.c
+
+ Title: "-2.0 vs. -2 (was Number representations)"
+ From: Chip Salzenberg <chip@pobox.com>
+ Msg-ID: <19980309185652.11231@cyprus>
+ Files: op.c
+
+ Title: "perl.c fixes for -DUNEXEC"
+ From: Matt Wette <mwette@mr-ed.jpl.nasa.gov>, Matthew R Wette
+ <mwette@mr-ed.jpl.nasa.gov>
+ Msg-ID: <199710152146.OAA07283@mr-ed.jpl.nasa.gov>
+ Files: perl.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "perlcall is Perl from C, not C from Perl"
+ From: Steve A Fink <sfink@cs.berkeley.edu>
+ Files: pod/perlembed.pod
+
+ Title: "Clarify require "Foo::Bar" non-bareword issue"
+ From: Dominique Dumont <domi@ss7serv.grenoble.hp.com>
+ Msg-ID: <199804231527.AA153445256@ss7serv.grenoble.hp.com>
+ Files: pod/perlfunc.pod
+
+ Title: "(repost) new text for perlsec", "new text for perlsec"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980423161605.5518N-100000@user2.teleport.com>
+ Files: pod/perlsec.pod
+
+ ------ EXTENSIONS ------
+
+ Title: "IO::Socket->socketpair broken (typo)"
+ From: Olaf Titz <olaf@bigred.inka.de>
+ Msg-ID: <19980425224535.2807.qmail@bigred.inka.de>
+ Files: ext/IO/lib/IO/Socket.pm
+
+ Title: "NDBM_File man page needs Fcntl"
+ From: "Danny R. Faught" <faught@mailhost.rsn.hp.com>
+ Msg-ID: <199707011500.IAA00601@palrel3.hp.com>
+ Files: ext/NDBM_File/NDBM_File.pm
+
+ ------ LIBRARY ------
+
+ Title: "Documentation discrepancy: pragmatic modules"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, h.sanden@elsevier.nl (Hugo van der Sanden)
+ Msg-ID: <199804221525.RAA12695@dorlas.elsevier.nl>,
+ <E0ySPhk-00034f-00@taurus.cus.cam.ac.uk>
+ Files: lib/strict.pm lib/subs.pm lib/vars.pm
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Updated hints file for svr4"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980423110522.26621A-100000@newton.phys>
+ Files: hints/svr4.sh
+
+ Title: "Pumpkin update -- shared libperl.so location"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980424115837.6222A-100000@newton.phys>
+ Files: Porting/pumpkin.pod
+
+ Title: "perl compile fix for AIX 4.3"
+ From: Jens-Uwe Mager <jum@helios.de>
+ Msg-ID: <199804261611.SAA34728@ans.helios.de>
+ Files: ext/DynaLoader/dl_aix.xs
+
+ Title: "Dynaloader build on VMS",
+ From: pvhp@forte.com (Peter Prymmer), timbo@ig.co.uk (Tim Bunce)
+ Msg-ID: <199804271732.SAA13762@toad.ig.co.uk>, <9804250212.AA27695@forte.com>
+ Files: vms/descrip.mms
+
+ ------ UTILITIES ------
+
+ Title: "Major update to h2ph.PL"
+ From: Billy <wdconsta@cs.adelaide.edu.au>
+ Msg-ID: <Pine.SV4.3.93.980424031837.20782A-200000@ermintrude.teaching.cs.adelaide.edu.au>
+ Files: utils/h2ph.PL
+
+Change 897 on 1998/04/23 by TimBunce@ig.co.uk
+
+ Assorted patches:
+
+ ------ CORE LANGUAGE ------
+
+ Title: "fix for "Unbalanced string table refcount""
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199804042251.RAA25527@aatma.engin.umich.edu>
+ Files: sv.c
+
+ Title: "Allow more lenient switch processing"
+ From: "John L. Allen" <allen@grumman.com>
+ Msg-ID: <199803251638.LAA22664@gateway.grumman.com>
+ Files: perl.c
+
+ Title: "Add fourth arg to substr: substr EXPR,OFFSET,LEN,REPLACEMENT"
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <m3g1jglqtm.fsf@furu.g.aas.no>
+ Files: pod/perlfunc.pod Todo opcode.pl pp.c t/op/substr.t
+
+ Title: "Odd number of elements in hash list."
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980328151929.29336D-100000@user2.teleport.com>
+ Files: MANIFEST pod/perldiag.pod pp.c pp_hot.c t/op/hashwarn.t
+
+ Title: "another destruct_level fix"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199804030105.UAA04400@aatma.engin.umich.edu>
+ Files: hv.c
+
+ Title: "bidirectional pipe warning blues"
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9804082151.AA20399@claudius.bfsec.bt.co.uk>
+ Files: doio.c
+
+ Title: "stale pointers after realloc (MEXTEND in pp_print and pp_prtf)"
+ From: Malcolm Beattie <mbeattie@sable.ox.ac.uk>
+ Msg-ID: <199801191107.LAA17979@sable.ox.ac.uk>
+ Files: pp_hot.c pp_sys.c
+
+ Title: "unimplemented umask() should return undef not die"
+ From: kstar@chapin.edu (Kurt D. Starsinic)
+ Msg-ID: <199803120515.VAA08660@chapin.edu>
+ Files: pod/perlfunc.pod pp_sys.c
+
+ Title: "warning for: bless $foo, """
+ From: Joshua.Pritikin@NewYork2.dmg.deuba.com
+ Msg-ID: <H00000e5000378a0@MHS>
+ Files: pod/perldiag.pod pp.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "Mention SWIG in perlxs.pod"
+ From: Steve A Fink <sfink@cs.berkeley.edu>
+ Msg-ID: <Pine.HPP.3.96.980408154956.20990K-100000@brooksie.CS.Berkeley.EDU>
+ Files: pod/perlxs.pod
+
+ Title: "fix-up of previous perlre.pod patch"
+ From: Ted Ashton <ashted@southern.edu>
+ Msg-ID: <199803031540.KAA09388@ns.southern.edu>
+ Files: pod/perlre.pod
+
+ Title: "long list of man page nitpicks"
+ From: Greg Bacon <gbacon@mickey.cs.uah.edu>, Tom Christiansen
+ <tchrist@jhereg.perl.com>
+ Msg-ID: <199804221844.NAA08338@pluto.cs.uah.edu>,
+ <199804222204.QAA20805@jhereg.perl.com>
+ Files: pod/perlapio.pod pod/perlcall.pod pod/perldebug.pod pod/perldelta.pod
+ pod/perldiag.pod pod/perlembed.pod pod/perlfaq2.pod
+ pod/perlfaq3.pod pod/perlfaq4.pod pod/perlfaq5.pod
+ pod/perlfaq7.pod pod/perlfaq8.pod pod/perlform.pod
+ pod/perlfunc.pod pod/perlguts.pod pod/perlipc.pod
+ pod/perllocale.pod pod/perlmodlib.pod pod/perlop.pod
+ pod/perlre.pod pod/perlref.pod pod/perlrun.pod
+ pod/perlstyle.pod pod/perlsub.pod pod/perlsyn.pod
+ pod/perltoot.pod pod/perlvar.pod pod/perlxs.pod
+ pod/pod2man.PL
+
+ Title: "document that system() does not set $! when it fails"
+ From: "Mark R. Levinson" <mrl@isc.upenn.edu>
+ Msg-ID: <199803011946.OAA31942@anaximander.dccs.upenn.edu>
+ Files: pod/perlfunc.pod
+
+ Title: "Fix pod/roffitall execute permission"
+ From: lvirden@cas.org
+ Msg-ID: <1997Nov17.132031.2589892@cor.newman>
+ Files: pod/roffitall
+
+ Title: "document when split ignores trailing empty fields"
+ From: Hugo van der Sanden <hv@crypt0.demon.co.uk>
+ Msg-ID: <l03130300b14fac832b77@[194.222.64.89]>
+ Files: pod/perlfunc.pod
+
+ ------ EXTENSIONS ------
+
+ Title: "Buglet in Opcode.pm documentation"
+ From: Horst von Brand <vonbrand@sleipnir.valparaiso.cl>
+ Msg-ID: <199804170349.XAA32445@sleipnir.valparaiso.cl>
+ Files: ext/Opcode/Opcode.pm
+
+ Title: "Failure to append to perllocal.pod should not be fatal"
+ From: koenig@kulturbox.de (Andreas J. Koenig)
+ Msg-ID: <sfciuogy67x.fsf@dubravka.in-berlin.de>
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "Document that IO.pm does not load IO::Select etc"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <353B48F1.64E35A63@ti.com>
+ Files: ext/IO/IO.pm
+
+ Title: "Install extensions with bootstrap (again) in $archlib"
+ From: Achim Bohnet <ach@mpe.mpg.de>, koenig@kulturbox.de (Andreas J.
+ Koenig)
+ Msg-ID: <9804061909.AA12675@o09.xray.mpe.mpg.de>,
+ <sfc90oxc0uj.fsf@dubravka.in-berlin.de>
+ Files: lib/ExtUtils/Install.pm
+
+ Title: "glibc2.0.6 missing MSG_* <sys/socket.h> defines."
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980406113950.3166L-100000@newton.phys>
+ Files: ext/Socket/Socket.xs
+
+ ------ LIBRARY ------
+
+ Title: "Benchmark.pm: add run-for-some-time mode"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199804080647.JAA15136@alpha.hut.fi>
+ Files: lib/Benchmark.pm
+
+ Title: "Comments added to Carp.pm"
+ From: Andy Wardley <abw@cre.canon.co.uk>, Chip Salzenberg
+ <chip@perlsupport.com>, Tom Christiansen
+ <tchrist@jhereg.perl.com>
+ Msg-ID: <19980422164242.E29222@perl.org>,
+ <199804222033.OAA17959@jhereg.perl.com>,
+ <980409182357.ZM21638@bandanna>
+ Files: lib/Carp.pm
+
+ Title: "chat2.pl fix"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01IVMVF507PO001NKH@cor.newman.upenn.edu>
+ Files: lib/chat2.pl
+
+ Title: "lib/Pod/Html.pm"
+ From: d-lewart@uiuc.edu (Daniel S. Lewart)
+ Msg-ID: <199710170718.DAA25472@staff1.cso.uiuc.edu>,
+ <199710180417.AAA19778@staff2.cso.uiuc.edu>
+ Files: lib/Pod/Html.pm
+
+ Title: "ormaments method in Term/ReadLine.pm causes warning with string
+ arg."
+ From: hiroo.hayashi@computer.org
+ Msg-ID: <199804061519.AAA21907@mail.fb3.so-net.ne.jp>
+ Files: lib/Term/ReadLine.pm
+
+ ------ OTHER CHANGES ------
+
+ Title: "ptags broken"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199804120208.WAA29264@monk.mps.ohio-state.edu>
+ Files: emacs/ptags
+
+ ------ PORTABILITY - WIN32 ------
+
+ Title: "win32 tweaks (signals and crypt support)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199804170505.BAA06413@aatma.engin.umich.edu>
+ Files: perl.h win32/config.bc win32/config.vc win32/config_H.bc
+ win32/config_H.vc win32/win32.c
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Add Social Contract (2nd Draft) as Porting/Contract"
+ From: Russ Allbery <rra@stanford.edu>
+ Msg-ID: <m3btw66n8i.fsf@windlord.Stanford.EDU>
+ Files: Porting/Contract
+
+ Title: "Config: Irix 5 hints"
+ From: kstar@O2.chapin.edu
+ Msg-ID: <199804061712.NAA22823@O2.chapin.edu>
+ Files: hints/irix_5.sh
+
+ Title: "VMS patches to 5.004_03"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01IVYJS0L8D200209B@cor.newman.upenn.edu>
+ Files: vms/vms.c
+
+ Title: "hints/netbsd.sh - enable vfork"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980417110749.19327B-100000@newton.phys>
+ Files: hints/netbsd.sh
+
+ ------ UTILITIES ------
+
+ Title: "support find2perl -follow"
+ From: Billy <wdconsta@cs.adelaide.edu.au>
+ Msg-ID: <Pine.SV4.3.93.980408005903.24081A-100000@ermintrude.teaching.cs.adelaide.edu.au>
+ Files: x2p/find2perl.PL
+
+Change 896 on 1998/04/22 by TimBunce@ig.co.uk
+
+ Assorted patches:
+
+ ------ CORE LANGUAGE ------
+
+ Title: "Additional regex-cache patch"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Msg-ID: <19980305104831.38100@cyprus>
+ Files: pp_ctl.c
+
+ Title: "Conservative C<*x = undef> patch"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Msg-ID: <19980310163310.48509@cyprus>
+ Files: pod/perldiag.pod pod/perlfunc.pod pp.c sv.c t/op/gv.t
+
+ Title: "Consider @ARGV to be plain files if inplace (-i)"
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Msg-ID: <199802042106.QAA04082@nielsenmedia.com>
+ Files: doio.c
+
+ Title: "Fix semctl for Linux, Sun and SVR4"
+ From: Graham Barr <gbarr@ti.com>, lvirden@cas.org (Larry W. Virden, x2487)
+ Msg-ID: <3484247D.BB036D39@ti.com>, <9712021313.AA11495@cas.org>
+ Files: doio.c
+
+ Title: "C<dSP> entails using C<SP>, not C<sp>"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199803070149.UAA12217@aatma.engin.umich.edu>
+ Files: pod/perlcall.pod pod/perlembed.pod pod/perlguts.pod pod/perlxs.pod
+ doio.c doop.c ext/DB_File/DB_File.xs
+ ext/DynaLoader/dl_dld.xs ext/Opcode/Opcode.xs
+ ext/POSIX/POSIX.xs ext/Socket/Socket.xs gv.c
+ lib/ExtUtils/typemap mg.c os2/OS2/REXX/REXX.xs
+ win32/win32.c
+
+ Title: "Make autouse -w-safe"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199803030236.VAA13244@monk.mps.ohio-state.edu>
+ Files: lib/autouse.pm op.c sv.c
+
+ Title: "Misleading error on close of unopened handle"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0y4R07-0003PH-00@ursa.cus.cam.ac.uk>
+ Files: doio.c
+
+ Title: "Confusing error from perl -e "x'""
+ From: Hans Mulder <hansmu@xs4all.nl>
+ Msg-ID: <1998Mar25.174320.2866352@cor.newman.upenn.edu>
+ Files: toke.c
+
+ Title: "Add HAS_GNULIBC define"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980305115202.9180K-100000@newton.phys>
+ Files: config_H config_h.SH
+
+ Title: "h_errno might not be an int"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980325165059.22255D-100000@newton.phys>
+ Files: pp_sys.c
+
+ Title: "Revised taint hole closer", "Revised taint hole closer"
+ From: Chip Salzenberg <chip@atlantic.net>, Ilya Zakharevich
+ <ilya@math.ohio-state.edu>
+ Msg-ID: <19980310222127.09350@cyprus>,
+ <199803110554.AAA29157@monk.mps.ohio-state.edu>
+ Files: doio.c
+
+ Title: "SEGV compiling localised lexical in perl5.004_05t1"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, h.sanden@elsevier.nl (Hugo
+ van der Sanden)
+ Msg-ID: <199803171530.QAA24053@dorlas.elsevier.nl>,
+ <199803171727.MAA05234@aatma.engin.umich.edu>
+ Files: op.c t/op/misc.t
+
+ Title: "Stale SP in pp_substr"
+ From: Stephen McCamant <alias@mcs.com>
+ Msg-ID: <m0yFsTS-000EZpC@alias-2.pr.mcs.net>
+ Files: pp.c
+
+ Title: "Statement unlikely to be reached warning"
+ From: Hans Mulder <hansm@icgned.nl>
+ Msg-ID: <1997Dec24.171511.2683516@cor.newman>
+ Files: op.c
+
+ Title: "Tainting propagates from nowhere"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199803140411.XAA09343@aatma.engin.umich.edu>
+ Files: pp.c
+
+ Title: "two trivial tweaks to 5.004m5t1"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199803060553.AAA28461@aatma.engin.umich.edu>
+ Files: proto.h win32/Makefile
+
+ Title: "unpacking negatives on Alpha"
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9710201503.AA24797@o09.xray.mpe.mpg.de>
+ Files: pp.c t/op/pack.t
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "Cwd.pm: abs_path() and fast_abs_path() plus code merge"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <3482F365.4A0486BA@ti.com>
+ Files: lib/Cwd.pm
+
+ Title: "Math/BigInt.pm, fixed use of undefined value."
+ From: abigail@fnx.com
+ Msg-ID: <19980313052452.27365.qmail@betelgeuse.wayne.fnx.com>
+ Files: lib/Math/BigInt.pm
+
+ Title: "File::Find rewrite"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199803052344.SAA01008@monk.mps.ohio-state.edu>
+ Files: lib/File/Find.pm
+
+ Title: "efficient version of strict.pm"
+ From: koenig@anna.mind.de (Andreas J. Koenig)
+ Msg-ID: <sfcpvonhdnc.fsf@anna.in-berlin.de>
+ Files: lib/strict.pm
+
+ Title: "Socket occasional SEGV in pack_sockaddr_un"
+ From: Trevor Blackwell <tlb@viaweb.com>
+ Msg-ID: <199710281804.NAA09632@wagg.viaweb.com>
+ Files: ext/Socket/Socket.xs
+
+ Title: "Warning on mis-use of 'use lib'"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Tom Phoenix
+ <rootbeer@teleport.com>, chip@atlantic.net
+ Msg-ID: <199801270435.XAA14147@cyprus.atlantic.net>,
+ <E0xx9x4-0006jc-00@ursa.cus.cam.ac.uk>,
+ <Pine.GSO.3.96.980126192445.22284N-100000@user2.teleport.com>
+ Files: lib/lib.pm
+
+ Title: "bug in Class::Struct"
+ From: Tom Christiansen <tchrist@toy.perl.com>
+ Msg-ID: <199803290814.KAA05699@toy.perl.com>
+ Files: lib/Class/Struct.pm
+
+ Title: "Allow POSIX to export nice()"
+ From: bkeelerx@iwa.dp.intel.com (Bruce J. Keeler)
+ Msg-ID: <eclg1kf5yf0.fsf@ws010.dp.intel.com>
+ Files: ext/POSIX/POSIX.pm
+
+ Title: "'use Env' on WinNT/95 fails"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199803280511.AAA15933@aatma.engin.umich.edu>
+ Files: lib/Env.pm
+
+ ------ OTHER CHANGES ------
+
+ Title: "mv-if-diff"
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Msg-ID: <14572.9803271806@tempest.cise.npl.co.uk>
+ Files: mv-if-diff
+
+ ------ PORTABILITY - WIN32 ------
+
+ Title: "fix various problems with backticks on win32"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199803070705.CAA15945@aatma.engin.umich.edu>
+ Files: win32/config_h.PL win32/win32.c
+
+ ------ TESTS ------
+
+ Title: "Fix bug in locale.t"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199801042148.XAA08599@alpha.hut.fi>
+ Files: t/pragma/locale.t
+
+Change 887 on 1998/04/10 by TimBunce@ig.co.uk
+
+ Assorted patches:
+
+ ------ CORE LANGUAGE ------
+
+ Title: "Re: die exits with 0"
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Files: perl.c t/op/die_exit.t
+
+ Title: "More toke.c commentary; fix oddity"
+ From: h.sanden@elsevier.nl (Hugo van der Sanden)
+ Msg-ID: <199803251022.LAA01308@dorlas.elsevier.nl>
+ Files: toke.c
+
+ Title: "for semctl on solaris"
+ From: Graham Barr <gbarr@ti.com>
+ Msg-ID: <34624B80.C014E841@ti.com>
+ Files: doio.c t/op/ipcmsg.t t/op/ipcsem.t
+
+ ------ DOCUMENTATION ------
+
+ Title: "Add more 'see also's to perlre.pod.", "Perl regexp /g modifier bug"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>, epeschko@den-mdev1 (Ed
+ Peschko), pjr@watcher.telstra.com.au (Peter Richardson)
+ Msg-ID: <199803050000.LAA11476@watcher.telecom.com.au>,
+ <199803050231.VAA19128@monk.mps.ohio-state.edu>,
+ <199803050605.XAA09785@den-mdev1.co.csgsystems.com>
+ Files: pod/perlre.pod
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "BigFloat - small neagtive numbers cause panic"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199711201325.NAA09732@crypt.compulink.co.uk>
+ Files: lib/Math/BigFloat.pm
+
+ Title: "Update Getopt::Long to 2.16"
+ From: JVromans@Squirrel.nl (Johan Vromans), Johan Vromans
+ <jvromans@squirrel.nl>
+ Msg-ID: <13571.48089.726787.147769@plume.nl.compuware.com>,
+ <13572.6847.863219.973795@phoenix.squirrel.nl>
+ Files: lib/Getopt/Long.pm
+
+ Title: "New Text::ParseWords"
+ From: pomeranz@netcom.com (Hal Pomeranz)
+ Msg-ID: <199710162118.OAA06275@netcom7.netcom.com>
+ Files: lib/Text/ParseWords.pm t/lib/parsewords.t
+
+ Title: "Fixed Text/Wrap.pm bugs (2)"
+ From: Jacqui Caren <Jacqui.Caren@ig.co.uk>
+ Msg-ID: <199709291548.QAA08645@toad.ig.co.uk>
+ Files: lib/Text/Wrap.pm
+
+ Title: "Very *evil* File::CheckTree behavior! (now uses warn/die not
+ print/exit)"
+ From: Eryq <eryq@zeegee.com>, Randal Schwartz <merlyn@stonehenge.com>
+ Msg-ID: <34B542FD.190A@zeegee.com>, <8cen2i9k6f.fsf@gadget.cscaper.com>
+ Files: lib/File/CheckTree.pm
+
+ ------ OTHER CHANGES ------
+
+ Title: "Add ./emacs/ptags"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199803150847.DAA08196@monk.mps.ohio-state.edu>
+ Files: emacs/ptags
+
+ ------ TESTS ------
+
+ Title: "Avoid stat test failure from build in /tmp (tmpfs)", "Build in /tmp"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, Greg Bacon
+ <gbacon@adtran.com>, pudge@pobox.com (Chris Nandor)
+ Msg-ID: <199710171616.LAA13435@crp-201.adtran.com>,
+ <Pine.SUN.3.96.971017171023.2349A-100000@newton.phys>,
+ <v02130515b06be80f1486@[205.228.240.16]>
+ Files: t/op/stat.t
+
+ Title: "for failure with lib/timelocal"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, jan.dubois@ibm.net (Jan Dubois)
+ Msg-ID: <34c78f61.2529827@smtp1.ibm.net>,
+ <E0xvdfI-00057d-00@ursa.cus.cam.ac.uk>
+ Files: t/lib/timelocal.t
+
+ Title: "Make "localhost" related failures more clear"
+ From: Paul Hoffman <phoffman@proper.com>
+ Msg-ID: <199801201859.KAA05686@mail.proper.com>
+ Files: t/lib/io_sock.t t/lib/io_udp.t
+
+ ------ UTILITIES ------
+
+ Title: "Let h2xs read multiple header files"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>, Benjamin Sugars
+ <bsugars@canoe.ca>
+ Msg-ID: <Pine.SOL.3.95.980310091946.25236A-100000@interact>,
+ <Pine.SUN.3.96.980310145455.638A-100000@newton.phys>
+ Files: utils/h2xs.PL
+
+Change 886 on 1998/04/10 by TimBunce@ig.co.uk
+
+ Changes relating primarily to portability.
+
+ ------ CORE LANGUAGE ------
+
+ Title: "5.004_55: Another round of OS/2 patches"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199803050945.EAA20153@monk.mps.ohio-state.edu>
+ Files: hints/os2.sh pod/perlguts.pod cop.h perl.h proto.h README.os2
+ global.sym lib/ExtUtils/MM_OS2.pm lib/File/Path.pm op.c
+ os2/Changes os2/Makefile.SHs os2/os2.c os2/perl2cmd.pl
+ perl.c pod/pod2man.PL pp_ctl.c pp_hot.c pp_sys.c
+ t/lib/filecopy.t util.c utils/perldoc.PL
+
+ Title: "VMS: chdir() with empty arg list"
+ From: lane@duphy4.drexel.edu (Charles Lane)
+ Msg-ID: <980317125556.222041c7@DUPHY4.Physics.Drexel.Edu>
+ Files: pp_sys.c
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "ExtUtils/MM_Unix.pm changed to use ld -rpath on IRIX"
+ From: "W. Phillip Moore" <wpm@ms.com>
+ Msg-ID: <199712011738.MAA21139@zappa.morgan.com>
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "[Linux] POSIX::_[PS]C_.+ bug (add HINT_SC_EXIST)"
+ From: Yutaka OIWA <oiwa@is.s.u-tokyo.ac.jp>
+ Msg-ID: <199712251923.EAA08260@tjms1f.is.s.u-tokyo.ac.jp>
+ Files: ext/POSIX/hints/linux.pl ext/POSIX/POSIX.xs
+
+ Title: "5.004_04-m1] Use HAS_GNULIBC in POSIX.xs"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980305115517.9180L-100000@newton.phys>
+ Files: ext/POSIX/POSIX.xs
+
+ Title: ""ODBM_File.c", line 275: NULL undefined"
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9803091310.AA23264@claudius.bfsec.bt.co.uk>
+ Files: ext/ODBM_File/ODBM_File.xs
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "5.004_04 QNX getcwd"
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Msg-ID: <199802121838.NAA20452@dolores.harvard.edu>,
+ <199803061511.KAA22346@bottesini.harvard.edu>
+ Files: hints/qnx.sh lib/Cwd.pm t/op/magic.t
+
+ Title: "hints/netbsd.sh d_setrgid d_setruid"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199802281435.QAA10866@alpha.hut.fi>
+ Files: hints/netbsd.sh
+
+ Title: "osname=unixware, osvers=2.03, archname=i386-unixware
+ d_casti32=undef"
+ From: Tom Hughes <tom@compton.demon.co.uk>
+ Msg-ID: <465398da47%tom@compton.demon.co.uk>
+ Files: hints/svr4.sh
+
+ Title: "hints/bsdos.sh patch for BSDI 3.1"
+ From: Jan-Pieter Cornet <johnpc@xs4all.nl>
+ Msg-ID: <6fbip6$3cp$1@xs1.xs4all.nl>
+ Files: hints/bsdos.sh
+
+ Title: "Remove BIND_NOSTART from DynaLoader for HP"
+ From: Keong Lim <Keong.Lim@sr.com.au>
+ Msg-ID: <01BD1D03.53B65E90@sieplan2.sr.com.au>
+ Files: ext/DynaLoader/dl_hpux.xs
+
+ Title: "Building Perl on AIX 4+ with shared libraries and dynamic loading"
+ From: Juan Gallego <Little.Boss@physics.mcgill.ca>
+ Msg-ID: <Pine.SGI.3.91.971022084517.17052F-100000@nazgul.physics.mcgill.ca>
+ Files: hints/aix.sh
+
+ Title: "alpha-dec_osf 5.0"
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+ Msg-ID: <199712232305.SAA08359@Orb.Nashua.NH.US>
+ Files: hints/dec_osf.sh
+
+ Title: "Off-by-one error with OS2::PrfDB"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710170920.FAA00390@monk.mps.ohio-state.edu>
+ Files: os2/OS2/PrfDB/PrfDB.xs
+
+ Title: "5.004_04-m1] Allow overrides in hints/openbsd.sh"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980305115956.9180N-100000@newton.phys>
+ Files: hints/openbsd.sh
+
+ Title: "5.004_04-m1] Linux shouldn't use -lnet"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980305115843.9180M-100000@newton.phys>
+ Files: hints/linux.sh
+
+ Title: "5.004_(04|63)] Close VMS security hole"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01IV6LRJCSSC0009C4@cor.newman.upenn.edu>
+ Files: vms/vms.c
+
+ Title: "Re: Perl online documentation on OpenVMS"
+ From: pvhp@forte.com (Peter Prymmer)
+ Msg-ID: <9803192143.AA28120@forte.com>
+ Files: README.vms
+
+ Title: "Perl5.004_04m4t4 *almost* makes it for VMS", "Updated
+ vms/perly_c.vms and vms/perly_h.vms"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, Dan Sugalski
+ <sugalskd@osshe.edu>, larry@wall.org (Larry Wall)
+ Msg-ID: <199710151650.JAA29185@wall.org>,
+ <3.0.3.32.19971014150404.02fdef78@osshe.edu>,
+ <Pine.SUN.3.96.971015121704.28456F-100000@newton.phys>
+ Files: vms/perly_c.vms
+
+ Title: "Updated, non-wordwrapped, patch to README.VMS"
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Msg-ID: <3.0.5.32.19980213133828.0092c870@osshe.edu>
+ Files: README.vms
+
+ Title: "VMS patches to 5.004_03 (excluding installperl and timelocal.t)"
+ From: Charles Bailey <BAILEY@newman.upenn.edu>
+ Msg-ID: <01INZT9G2LZS0006YW@cor.newman.upenn.edu>
+ Files: lib/File/Basename.pm lib/File/Path.pm vms/config.vms vms/descrip.mms
+ vms/genconfig.pl vms/test.com vms/vms.c vms/ext/Filespec.pm
+ vms/ext/filespec.t
+
+ Title: "Re: VMSperl crashes on -Mblib argument"
+ From: bailey@newman.upenn.edu (Charles Bailey)
+ Msg-ID: <1997Dec10.004439.2635060@cor.newman>
+ Files: lib/blib.pm vms/vms.c
+
+ Title: "hints/linux.sh (MkLinux / PPC)"
+ From: pudge@pobox.com (Chris Nandor)
+ Msg-ID: <v0213050cb06c19682a25@[205.228.240.28]>
+ Files: hints/linux.sh
+
+ Title: "hpux.sh hints file clarification suggestion"
+ From: root@qad.com
+ Msg-ID: <199802192351.QAA09096@jhereg.perl.com>
+ Files: hints/hpux.sh
+
+ Title: "new hints/solaris_2.sh"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0xw80h-0005SV-00@ursa.cus.cam.ac.uk>
+ Files: hints/solaris_2.sh
+
+Change 873 on 1998/04/03 by TimBunce@ig.co.uk
+
+ Title: "FileHandle Documentation patch"
+ From: "Darren/Torin/Who Ever..." <torin@daft.com>
+ Msg-ID: <87emzqo49g.fsf@perv.daft.com>
+ Files: lib/FileHandle.pm
+
+Change 872 on 1998/04/03 by TimBunce@ig.co.uk
+
+ Documentation and documentation related patches:
+
+ ------ BUILD PROCESS ------
+
+ Title: "Docs re /usr/bin/perl quasi-standard location"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.971117080737.12318C-100000@usertest.teleport.com>
+ Files: INSTALL pod/perlrun.pod
+
+ ------ DOCUMENTATION ------
+
+ Title: "/RFC|RFC-1305/ non-greedy"
+ From: Jan-Pieter Cornet <johnpc@xs4all.nl>
+ Msg-ID: <6epo02$c4r$1@xs1.xs4all.nl>
+ Files: pod/perlre.pod
+
+ Title: "5.004_04: perlhist.pod, buildtoc, perltoc.pod"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199802191543.RAA29231@alpha.hut.fi>
+ Files: pod/perl.pod pod/perlhist.pod pod/perltoc.pod pod/buildtoc
+
+ Title: "5.004_04: pod/perlfunc.pod: i18n example for localtime()"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199711141555.RAA18875@alpha.hut.fi>
+ Files: pod/perlfunc.pod
+
+ Title: "typo-fix and suggestion for perlguts.pod"
+ From: h.sanden@elsevier.nl (Hugo van der Sanden)
+ Msg-ID: <199803051543.QAA03097@dorlas.elsevier.nl>
+ Files: pod/perlguts.pod
+
+ Title: "perlfunc/syscall curiosity"
+ From: Roderick Schertler <roderick@argon.org>, Tkil
+ <tkil@reptile.scrye.com>
+ Msg-ID: <199711302259.PAA02134@reptile.scrye.com>,
+ <pziut8snva.fsf@eeyore.ibcinc.com>
+ Files: pod/perlfunc.pod
+
+ Title: "Document sprintf %#x behaviour for zero value"
+ From: ilya@math.ohio-state.edu (Ilya Zakharevich)
+ Msg-ID: <1997Nov5.185959.2539604@cor.newman>
+ Files: pod/perlfunc.pod
+
+ Title: "NUL termination (was Re: STOP THE PRESSES)"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0xsn5M-0002gw-00@ursa.cus.cam.ac.uk>
+ Files: pod/perlguts.pod
+
+ Title: "Typo fix."
+ From: abigail@fnx.com
+ Msg-ID: <19971101120114.1030.qmail@betelgeuse.wayne.fnx.com>
+ Files: pod/perlop.pod pod/perlvar.pod
+
+ Title: "5.004_63 perlrun.pod: _DEBUG_MSTATS"
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9803181940.AA22587@o09.xray.mpe.mpg.de>
+ Files: pod/perlrun.pod
+
+ Title: "Re: Conservative C<*x = undef> patch"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0yCjHT-0005Dt-00@ursa.cus.cam.ac.uk>
+ Files: pod/perltrap.pod
+
+ Title: "perlfunc.pod for flock()"
+ From: "Jeremy D. Zawodny" <jzawodn@wcnet.org>
+ Msg-ID: <3.0.5.32.19971118203119.00a723e0@woody.wcnet.org>
+ Files: pod/perlfunc.pod
+
+ Title: "buglet: 'perltoc' not mentioned in perl.pod"
+ From: Tkil <tkil@scrye.com>
+ Msg-ID: <19971127035036.17668.qmail@scrye.com>
+ Files: pod/perl.pod
+
+ Title: "for() and map() peculiarity"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0y4YAa-0003Qu-00@ursa.cus.cam.ac.uk>
+ Files: pod/perlsyn.pod
+
+ Title: "Re: new text for perlsec"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.980328100418.22321T-100000@user2.teleport.com>
+ Files: pod/perlsec.pod
+
+ Title: "perldsc's debugger x command"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <10669.878352893@eeyore.ibcinc.com>
+ Files: pod/perldsc.pod
+
+ Title: "perlre.pod"
+ From: Ted Ashton <ashted@southern.edu>
+ Msg-ID: <199802271501.KAA09279@ns.southern.edu>
+ Files: pod/perlre.pod
+
+ Title: "Re: printf and $\", "printf and $\"
+ From: Roderick Schertler <roderick@argon.org>, Tom Phoenix
+ <rootbeer@teleport.com>, nag <nick@flirble.org>
+ Msg-ID: <199711141918.TAA08096@flirble.org>,
+ <Pine.GSO.3.96.971117085421.12318J-100000@usertest.teleport
+ .com>, <pzyb2ncr42.fsf@eeyore.ibcinc.com>
+ Files: pod/perlfunc.pod
+
+ Title: "recv() typo"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <12064.877012073@eeyore.ibcinc.com>
+ Files: pod/perlfunc.pod
+
+ Title: "truncate return value"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <5490.878337883@eeyore.ibcinc.com>
+ Files: pod/perlfunc.pod
+
+ Title: "update to perlbook.pod"
+ From: "Nathan V. Patwardhan" <nvp@mediaone.net>, Randal Schwartz
+ <merlyn@stonehenge.com>, Stephen Potter
+ <spp@psasolar.colltech.com>, Tom Phoenix
+ <rootbeer@teleport.com>
+ Msg-ID: <199803241354.HAA23938@psasolar.psa.pencom.com>,
+ <199803241441.OAA01261@mediaone.net>,
+ <8clnu0i05k.fsf@gadget.cscaper.com>,
+ <Pine.GSO.3.96.980324111957.15753C-100000@user1.teleport.com>
+ Files: pod/perlbook.pod
+
+ Title: "utime documentation"
+ From: "Brandon S. Allbery KF8NH" <bsa@kf8nh.apk.net>, "M.J.T. Guy"
+ <mjtg@cus.cam.ac.uk>
+ Msg-ID: <199802180256.VAA11369@speaker.kf8nh.apk.net>,
+ <E0y4qd6-0000P6-00@ursa.cus.cam.ac.uk>
+ Files: pod/perlfunc.pod
+
+ Title: "(well, doc patch) use of // requires successful match"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <pz7mb4bips.fsf@eeyore.ibcinc.com>
+ Files: pod/perlop.pod
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "MakeMaker PM doc patch and a DIR buglet"
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9711101050.AA13868@o09.xray.mpe.mpg.de>
+ Files: lib/ExtUtils/MakeMaker.pm
+
+ Title: "bareword clarification for constant.pm"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <6460.878143077@eeyore.ibcinc.com>
+ Files: lib/constant.pm
+
+ Title: "integer rand - bug or feature?"
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <pzhg8lvgta.fsf@eeyore.ibcinc.com>
+ Files: lib/integer.pm
+
+ ------ OTHER CHANGES ------
+
+ Title: "FileHandle Documentation patch"
+ From: "Darren/Torin/Who Ever..." <torin@daft.com>
+ Msg-ID: <87emzqo49g.fsf@perv.daft.com>
+
+ Title: "perl5.004_61 myconfig updates"
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980305150629.11530G-100000@newton.phys>
+ Files: myconfig
+
+ Title: "small fixups in pod2latex.PL"
+ From: "Darren/Torin/Who Ever..." <torin@daft.com>
+ Msg-ID: <873eg6o3v2.fsf@perv.daft.com>
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Misc doc fixes for README.VMS"
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Msg-ID: <3.0.5.32.19980121113134.00924a20@osshe.edu>
+ Files: README.vms
+
+ Title: "moved DynaLib"
+ From: John Tobey <jtobey@channel1.com>
+ Msg-ID: <199710182332.XAA21630@remote212>
+ Files: ext/DynaLoader/DynaLoader.pm.PL
+
+ ------ UTILITIES ------
+
+ Title: "Searching for FAQs (patch to perldoc)"
+ From: Piers Cawley <pdcawley@bofh.org.uk>, Russ Allbery <rra@stanford.edu>
+ Msg-ID: <m3d8gsb8uk.fsf@windlord.Stanford.EDU>,
+ <m3iuqkfmiq.fsf@tower.bofh.org.uk>
+ Files: utils/perldoc.PL
+
+ Title: "perldoc"
+ From: Ted Ashton <ashted@southern.edu>
+ Msg-ID: <199802271510.KAA10506@ns.southern.edu>
+ Files: utils/perldoc.PL
+
+ Title: "perldoc -f not using pod2man"
+ From: Russ Allbery <rra@stanford.edu>
+ Msg-ID: <m3hg4f9vyy.fsf@windlord.Stanford.EDU>
+ Files: utils/perldoc.PL
+
+ Title: "perldoc -m should not require pod"
+ From: Robin Houston <robin@nml.guardian.co.uk>
+ Msg-ID: <199803241319.NAA24777@stringfellow.guardian.co.uk>
+ Files: utils/perldoc.PL
+
+ Title: "small fix for perldoc in perl 5.004_04"
+ From: Julian Yip <julian@imoney.com>
+ Msg-ID: <Roam.SIMC.2.0.6.884805579.5280.julian@imoney.com>
+ Files: utils/perldoc.PL
+
+Change 764 on 1998/03/05 by TimBunce@ig.co.uk
+
+ APPLLIB_EXP now has arch and version dirs added to @INC
+
+Change 761 on 1998/03/05 by TimBunce@ig.co.uk
+
+ Title: "properly refcount localization, fix C<local $tied{foo}>"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802191207.MAA10742@toad.ig.co.uk>
+ Files: av.c hv.c scope.c t/op/local.t
+
+Change 758 on 1998/03/04 by TimBunce@ig.co.uk
+
+ perldoc -f now uses pager if text is too long for screen
+
+Change 757 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Added OpenBSD hint file from <Todd.Miller@courtesan.com>
+ Document 'warn with no args' behaviour, from <johnpc@xs4all.net>
+
+Change 756 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Fix for new gnulibc stdio.h when using sfio+perlio
+
+Change 755 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Fixed typo in vms/ext/Stdio/Stdio.pm AUTOLOAD
+ Added details of split in scalar context to perlfunc.pod
+
+Change 754 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Updated perl -v info to include reference to docs and home page.
+
+Change 753 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Updated hints/bsdos.sh for BSD/OS 3.1
+ Fixed typo in pod/perlsyn.pod
+ Added workaround for old gmake in ext/SDBM_File/sdbm/Makefile.PL
+ Fixed typo in ext/GDBM_File/GDBM_File.pm
+
+Change 752 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Changed bug address in README to perlbug@perl.com
+ Changed Copyright in perl.c to 1998
+ Added op/pos.t test from Robin Houston <robin@oneworld.org>
+
+Change 751 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Make t/comp/require.t and t/lib/ph.t executable in repository
+
+Change 750 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Added dTHR definition to ease backwards compatibility for XS
+ source code from 5.005.
+
+Change 749 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "rename local 'op' variables to 'o'", #F114
+ From: Gurusamy Sarathy
+ Files: op.h opcode.h proto.h dump.c op.c opcode.pl pp_ctl.c run.c scope.c
+ toke.c
+
+Change 748 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "consolidated win32 patch", #F112
+ From: Gurusamy Sarathy
+ Files: MANIFEST pod/perlfaq2.pod pod/perlrun.pod win32/include/sys/socket.h
+ EXTERN.h INTERN.h dosish.h lib/ExtUtils/Command.pm
+ lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Win32.pm
+ lib/ExtUtils/Mksymlists.pm lib/File/DosGlob.pm t/TEST
+ t/harness win32/win32.h win32/win32iop.h README.win32
+ doio.c installhtml installperl pp_sys.c win32/Makefile
+ win32/config.bc win32/config.vc win32/config_H.bc
+ win32/config_H.vc win32/config_h.PL win32/config_sh.PL
+ win32/dl_win32.xs win32/makedef.pl win32/makefile.mk
+ win32/perllib.c win32/runperl.c win32/win32.c
+ win32/win32sck.c win32/bin/perlglob.pl x2p/a2p.h x2p/a2p.c
+ x2p/a2py.c
+
+Change 747 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "initialize @INC in ph.t, and fix up MANIFEST", #F111
+ From: Gurusamy Sarathy
+ Files: MANIFEST t/lib/ph.t
+
+Change 746 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "properly save STDOUT during system() in debugger", #F110
+ From: Jason Smith <smithj4@rpi.edu>
+ Files: lib/perl5db.pl
+
+Change 745 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "generate DynaLoader.pm at build time", #F109
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9802111938.AA26224@o09.xray.mpe.mpg.de>
+ Files: MANIFEST ext/DynaLoader/DynaLoader.pm.PL ext/DynaLoader/Makefile.PL
+
+Change 744 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "Install extensions with bootstrap in $archlib", #F108
+ From: koenig@anna.mind.de (Andreas J. Koenig), koenig@kulturbox.de (Andreas
+ J. Koenig)
+ Msg-ID: <sfcra9fqx0n.fsf@anna.in-berlin.de>
+ Files: lib/ExtUtils/Install.pm
+
+Change 743 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "Pod::Html trips over "C<0>"", #F107
+ From: Chip Salzenberg
+ Files: lib/Pod/Html.pm
+
+Change 742 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "5.004_58 | _04: pod2*,perlpod: L<show this|man/section>", #F106
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9802111629.AA00595@o09.xray.mpe.mpg.de>
+ Files: pod/perlpod.pod lib/Pod/Html.pm lib/Pod/Text.pm pod/pod2man.PL
+
+Change 741 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "New patch for $^E==GetLastError() under Win32", #F105
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Tye McQueen
+ <tye@metronet.com>, ilya@math.ohio-state.edu (Ilya
+ Zakharevich)
+ Msg-ID: <199801040630.AA29298@metronet.com>,
+ <199801041826.NAA11568@aatma.engin.umich.edu>,
+ <1998Jan4.130412.2719461@cor.newman>
+ Files: pod/perlfunc.pod pod/perlvar.pod doio.c lib/dumpvar.pl lib/perl5db.pl
+ win32/win32.h mg.c util.c win32/makedef.pl win32/win32.c
+
+Change 740 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "5.004_56: Patch to Tie::Hash and docs", #F104
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199801120134.UAA05437@monk.mps.ohio-state.edu>
+ Files: pod/perlfunc.pod lib/Tie/Hash.pm
+
+Change 739 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "more doc for perldoc", #F103
+ From: Gurusamy Sarathy
+ Files: utils/perldoc.PL
+
+Change 738 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "Make perldoc look for an index file ", #F102
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <199801221220.NAA22902@furu.g.aas.no>
+ Files: utils/perldoc.PL
+
+Change 737 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "perldoc -F filename", #F101
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199712120037.TAA00176@math.mps.ohio-state.edu>
+ Files: utils/perldoc.PL
+
+Change 736 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "sv_grow can fail for HAS_64K_LIMIT systems", #F100
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <m3iuqsl3oq.fsf@furu.g.aas.no>
+ Files: sv.c
+
+Change 735 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "Benchmark.pm: timethese corrupts $_", #F099
+ From: abigail@fnx.com
+ Msg-ID: <19980201114609.7779.qmail@betelgeuse.wayne.fnx.com>
+ Files: lib/Benchmark.pm
+
+Change 734 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "STRANGE_MALLOC should test failed alloc", #F098
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <199802021406.PAA03285@furu.g.aas.no>
+ Files: hv.c
+
+Change 733 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "support caseless %ENV", #F097
+ From: Gurusamy Sarathy
+ Files: hv.c t/op/magic.t win32/win32.h
+
+Change 732 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "newer cperl-mode.el (from 5.004_60)", #F096
+ From: Ilya Zakharevich
+ Files: emacs/cperl-mode.el
+
+Change 731 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "Handle set magic on xsub OUTPUT args, add API functions that handle
+ magic", #F095
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199801190409.XAA26710@aatma.engin.umich.edu>
+ Files: pod/perlguts.pod pod/perlxs.pod embed.h proto.h sv.h global.sym
+ lib/ExtUtils/xsubpp sv.c
+
+Change 730 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "Fix flawed cleanup when signal handlers are not defined", #F094
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710290106.UAA11485@aatma.engin.umich.edu>
+ Files: mg.c
+
+Change 729 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "Tests for C<sort 'foo','bar'>", #F093
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199711021247.MAA01743@crypt.compulink.co.uk>
+ Files: t/op/sort.t
+
+Change 728 on 1998/03/04 by TimBunce@ig.co.uk
+
+ Title: "Make search.pl work on win32", #F092
+ From: Gurusamy Sarathy
+ Files: win32/bin/search.pl
+
+Change 721 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix spurious perldoc warnings on DOSISH platforms", #F091
+ From: Molnar Laszlo <molnarl@cdata.tvnet.hu>
+ Msg-ID: <34475659.1AA69855@cdata.tvnet.hu>
+ Files: utils/perldoc.PL
+
+Change 720 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Make ExtUtils::MM_Unix::fixin() do something meaningful on win32",
+ #F090
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199801070016.TAA17766@aatma.engin.umich.edu>
+ Files: lib/ExtUtils/MM_Unix.pm
+
+Change 719 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix inconsistent case $ENV{Path} (vs $ENV{PATH})", #F089
+ From: Gurusamy Sarathy
+ Files: lib/FindBin.pm
+
+Change 718 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix File::Find's longstanding confusion about win32 being like VMS",
+ #F088
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802020459.XAA04964@aatma.engin.umich.edu>
+ Files: lib/File/Find.pm
+
+Change 717 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "do_postponed breaks with multiple interpreters", #F087
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710290316.WAA15888@aatma.engin.umich.edu>
+ Files: op.c
+
+Change 716 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Make warning on C<Nosuch::> optional, add to perl{diag,delta}.pod",
+ #F086
+ From: Gurusamy Sarathy
+ Files: pod/perldelta.pod pod/perldiag.pod toke.c
+
+Change 715 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Pod::Html bug and fix: missing </UL> in index", #F085
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802192314.SAA23326@aatma.engin.umich.edu>
+ Files: lib/Pod/Html.pm
+
+Change 714 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "New pod: perlhist", #F084
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199802191556.RAA09578@alpha.hut.fi>
+ Files: MANIFEST pod/perl.pod pod/perlhist.pod pod/perltoc.pod pod/buildtoc
+
+Change 713 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix restoration of locals on scope unwinding", #F083
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802110515.AAA23700@aatma.engin.umich.edu>
+ Files: pp_ctl.c t/op/local.t
+
+Change 712 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "after an eval-ed bad require, requiring a string ref SEGVs", #F082
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802102349.SAA16001@aatma.engin.umich.edu>
+ Files: pp_ctl.c
+
+Change 711 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix seg fault on eval/require and syntax errors", #F081
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199802102321.SAA15346@aatma.engin.umich.edu>
+ Files: MANIFEST scope.h op.c pp_ctl.c scope.c t/comp/require.t toke.c
+
+Change 710 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "5.004_58: the locale.t problem in IRIX", #F080
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199802091747.TAA01735@alpha.hut.fi>
+ Files: t/pragma/locale.t
+
+Change 709 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "sv_setnv will upgrade SVt_NV to SVt_PVNV", #F079
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <m3g1lwl3bq.fsf@furu.g.aas.no>
+ Files: sv.c
+
+Change 708 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Eliminate double warnings under C<package;>", #F077
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0y0paq-0000Ov-00@ursa.cus.cam.ac.uk>
+ Files: gv.c op.c toke.c
+
+Change 707 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix infinite loop on unlink() failure in File::Path::rmtree()",
+ #F076
+ From: Murray Nesbitt <mjn@pathcom.com>, Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <199802061100.LAA16423@toad.ig.co.uk>
+ Files: lib/File/Path.pm
+
+Change 706 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Update of h2ph", #F075
+ From: kstar@www.chapin.edu (Kurt D. Starsinic)
+ Msg-ID: <199802051354.FAA11452@www.chapin.edu>
+ Files: t/lib/ph.t utils/h2ph.PL
+
+Change 705 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix AutoLoader for deep packages", #F074
+ From: Zachary Miller <zcmiller@zappy.er.usgs.gov>
+ Msg-ID: <199710092348.SAA02108@zappy.er.usgs.gov>
+ Files: lib/AutoLoader.pm
+
+Change 704 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix order of warnings for misplaced subscripts", #F073
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199710131023.LAA16796@crypt.compulink.co.uk>
+ Files: op.c
+
+Change 703 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Make recursive lexical analysis more robust", #F072
+ From: Ilya Zakharevich and Chip Salzenberg
+ Msg-ID: <199710160102.VAA28817@monk.mps.ohio-state.edu>
+ Files: toke.c
+
+Change 702 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix random whitespace errors in docs", #F070
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <12726.877706444@eeyore.ibcinc.com>
+ Files: pod/perlfunc.pod pod/checkpods.PL
+
+Change 701 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix line numbers after here documents in eval STRING", #F069
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710241745.NAA08166@monk.mps.ohio-state.edu>
+ Files: toke.c
+
+Change 700 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix SEGV from combining caller and C<package;>", #F068
+ From: James Duncan <jduncan@epitome.hawk.igs.net>, Nicholas Clark
+ <nick@flirble.org>
+ Msg-ID: <199710241248.NAA00163@flirble.org>,
+ <Pine.LNX.3.96.971024135912.12197A-100000@epitome.hawk.igs.
+ net>
+ Files: pp_ctl.c sv.c
+
+Change 699 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Don't fold string comparison under C<use locale>", #F067
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199711151506.RAA26287@alpha.hut.fi>
+ Files: op.c
+
+Change 698 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix SEGV on constant at end of sort block", #F066
+ From: Administration <fadmin@informatics.muni.cz>
+ Msg-ID: <199711170838.JAA26073@thetis.fi.muni.cz>
+ Files: op.c
+
+Change 697 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Allow C<last()> to mean C<last>", #F065
+ From: Chip Salzenberg
+ Files: op.c
+
+Change 696 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix extension version mismatch message", #F064
+ From: Chip Salzenberg
+ Files: XSUB.h
+
+Change 695 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Better handle and test struct tm of Linux and SunOS", #F063
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.980205134340.15567B-100000@newton.phys>
+ Files: MANIFEST ext/POSIX/hints/linux.pl ext/POSIX/hints/sunos_4.pl
+ hints/linux.sh hints/sunos_4_1.sh t/lib/posix.t
+
+Change 694 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix doc bug in getservbyname() examples", #F062
+ From: Tom Christiansen
+ Files: ext/Socket/Socket.pm
+
+Change 693 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Kill warning about parameter type", #F061
+ From: Chip Salzenberg
+ Files: op.c
+
+Change 692 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Socket occasional SEGV", #F060
+ From: Trevor Blackwell <tlb@viaweb.com>
+ Msg-ID: <199710281804.NAA09632@wagg.viaweb.com>
+ Files: ext/Socket/Socket.xs
+
+Change 691 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Avoid SEGV from local($@)", #F059
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710290251.VAA14362@aatma.engin.umich.edu>
+ Files: pp_ctl.c
+
+Change 690 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Don't use broken pad_reset() (was Re: Perl bug in 5.004_03 )", #F058
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710300036.TAA01004@aatma.engin.umich.edu>
+ Files: op.c
+
+Change 689 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Use STMT_{START,END} in XSRETURN", #F057
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710300245.VAA04244@aatma.engin.umich.edu>
+ Files: XSUB.h
+
+Change 688 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Re: Sort grammar bug", #F056
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199711011946.OAA18882@aatma.engin.umich.edu>
+ Files: toke.c
+
+Change 687 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Document indirect object cases for exec(), system()", #F055
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03110700b084e89234a7@[194.51.248.90]>
+ Files: pod/perlfunc.pod
+
+Change 686 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Update docs on tr///", #F054
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.971103071602.10568C-100000@usertest.teleport.com>
+ Files: pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod
+ pod/perllocale.pod pod/perlmod.pod pod/perlop.pod
+ pod/perlstyle.pod toke.c
+
+Change 685 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Re: perlop bitwise & | ^ documentation", #F053
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.971106073858.29771O-100000@usertest.teleport.com>
+ Files: pod/perlop.pod
+
+Change 684 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix SEGV on C<*glob{'SCALAR','ARRAY'}>", #F052
+ From: "Joseph N. Hall" <joseph@cscaper.com>
+ Msg-ID: <199711110552.WAA12613@gadget.cscaper.com>
+ Files: perly.c perly.c.diff perly.y vms/perly_c.vms
+
+Change 683 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "for perlguts.pod: document sv_derived_from, sv_vcatpfn and
+ sv_vsetpfn", #F051
+ From: jan.dubois@ibm.net (Jan Dubois) and Chip Salzenberg
+ Msg-ID: <346ae970.7444534@smtp1.ibm.net>
+ Files: pod/perlguts.pod
+
+Change 682 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "5.004_04: locale startup failure (at last) documented", #F050
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199711172054.WAA08261@alpha.hut.fi>
+ Files: INSTALL pod/perldiag.pod pod/perllocale.pod
+
+Change 681 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Cope with lack of args in Fcntl::AUTOLOAD", #F049
+ From: Jerome Abela <abela@hsc.fr>
+ Msg-ID: <19971120183248.23588@coredump.hsc.fr>
+ Files: ext/Fcntl/Fcntl.pm
+
+Change 680 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Commenting toke.c", #F048
+ From: gnat@frii.com
+ Msg-ID: <199801082138.OAA14186@prometheus.frii.com>
+ Files: toke.c
+
+Change 679 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Re: 5.004_04 vec() fails with 32-bit values", #F047
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0xsnr8-0007SS-00@taurus.cus.cam.ac.uk>
+ Files: pod/perlguts.pod pp.c t/op/vec.t
+
+Change 678 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "A few perl5.004_03 bugs", #F046
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199801221211.MAA05315@crypt.compulink.co.uk>
+ Files: mg.c t/op/magic.t
+
+Change 677 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Faster, cleaner av_unshift() ", #F045
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <199801221850.TAA23111@furu.g.aas.no>
+ Files: av.c
+
+Change 676 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "New hints/solaris2.sh", #F044
+ From: Stephen Zander <srz@mckesson.com>
+ Msg-ID: <87oh12y458.fsf@wsuse5.mckesson.com>
+ Files: hints/solaris_2.sh
+
+Change 675 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Refresh Complex.pm and test", #F043
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199802051608.SAA20262@alpha.hut.fi>
+ Files: lib/Math/Complex.pm t/lib/complex.t
+
+Change 674 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix (\@@) proto", #F042
+ From: "Joseph N. Hall" <joseph@cscaper.com>
+ Msg-ID: <199801240132.SAA25111@gadget.cscaper.com>
+ Files: op.c t/comp/proto.t
+
+Change 673 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Allow empty BLOCK in code", #F041
+ From: Vladimir Alexiev <vladimir@cs.ualberta.ca>
+ Msg-ID: <19980129002112Z13378-6931+226@scapa.cs.ualberta.ca>
+ Files: toke.c
+
+Change 672 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix name of $Foo::{'Bar::'}: '*Foo::Bar::'", #F040
+ From: Chip Salzenberg
+ Files: gv.c t/op/gv.t
+
+Change 671 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Keep accurate reference count on globs' stashes", #F038
+ From: Gisle Aas <gisle@aas.no>
+ Msg-ID: <m3zpk7sd3n.fsf@furu.g.aas.no>
+ Files: gv.c sv.c
+
+Change 670 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Avoid memory allocation in gv_fetchpv(), for speed", #F037
+ From: Chip Salzenberg
+ Files: gv.c
+
+Change 669 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Make Configure less negative about PerlIO", #F036
+ From: chip@atlantic.net
+ Msg-ID: <199801312323.SAA15237@cyprus.atlantic.net>
+ Files: Configure
+
+Change 668 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix (mostly) pseudo-same-REs due to embedded NULs", #F035
+ From: Martin Plechsmid <plechsmi@karlin.mff.cuni.cz>
+ Msg-ID: <199802021217.NAA05230@albert.karlin.mff.cuni.cz>
+ Files: pp_ctl.c
+
+Change 667 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Make Getopt::Long avoid $&, $`, $'", #F034
+ From: Irving Reid <irving@tor.securecomputing.com>
+ Msg-ID: <98Feb3.005102est.11655@janus.tor.securecomputing.com>
+ Files: lib/Getopt/Long.pm
+
+Change 666 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "adding the newSVpvn API function", #F033
+ From: Matthias Ulrich Neeracher <neeri@iis.ee.ethz.ch>
+ Msg-ID: <199801310532.GAA23798@solar.ethz.ch>
+ Files: pod/perlguts.pod pod/perltoc.pod proto.h global.sym sv.c
+
+Change 665 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Support C<Package::> as function-blind bearword", #F032
+ From: Chip Salzenberg
+ Files: toke.c
+
+Change 664 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Re-optimize character classes", #F031
+ From: Chip Salzenberg
+ Files: regcomp.h regcomp.c regexec.c
+
+Change 663 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix C<if (1) { local $x }> which needed ENTER/LEAVE", #F030
+ From: dfh@dwroll.lucent.com (D461-David_F_Haertig(Dave)83040)
+ Msg-ID: <EnKC0q.6qI@drnews.dr.lucent.com>
+ Files: op.c t/op/local.t
+
+Change 662 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Dramatically improve performance of // with parens or $&", #F029
+ From: Chip Salzenberg
+ Files: cop.h perl.h proto.h regexp.h gv.c interp.sym perl.c pp.c pp_ctl.c
+ pp_hot.c regexec.c scope.c
+
+Change 661 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Don't warn on $x{shift}, ne => 1, or -f => 1", #F028
+ From: Chip Salzenberg
+ Files: toke.c
+
+Change 660 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Protect against weirdness with unreal @_ in C<local @_>", #F027
+ From: Chip Salzenberg
+ Files: scope.c
+
+Change 659 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix C<printf "%.0d", 0>", #F026
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199711021331.NAA01826@crypt.compulink.co.uk>
+ Files: sv.c t/op/sprintf.t
+
+Change 658 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Tiny core patch for source filters", #F025
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9711202312.AA02937@claudius.bfsec.bt.co.uk>
+ Files: toke.c
+
+Change 657 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Here-doc in s///e (was: Bug)", #F024
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199711221445.OAA14153@crypt.compulink.co.uk>
+ Files: t/base/lex.t toke.c
+
+Change 656 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix duplicate warnings on C<-e undef>", #F023
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199711221252.MAA14000@crypt.compulink.co.uk>
+ Files: doio.c t/pragma/warn-1global
+
+Change 655 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix '*' prototype", #F022
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199711212225.RAA00755@monk.mps.ohio-state.edu>
+ Files: toke.c
+
+Change 654 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "File::Find bugs (and patches)", "File::Find bugs & patches", #F021
+ From: "Conrad E. Kimball" <cek@tblv021.ca.boeing.com>
+ Msg-ID: <199711260703.XAA21257@mailgate2.boeing.com>
+ Files: lib/File/Find.pm
+
+Change 653 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix typo: FORM{,AT}LINE", #F020
+ From: Chip Salzenberg
+ Files: sv.c
+
+Change 652 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix use of unref mem when blessed object goes out of scope", #F019
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199711282326.SAA15090@aatma.engin.umich.edu>
+ Files: scope.c
+
+Change 651 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix C<my ($a, undef, $b) = @x>", #F018
+ From: Stephane Payrard <stef@francenet.fr>
+ Msg-ID: <199712040054.BAA04612@www.zweig.com>
+ Files: op.c t/op/my.t
+
+Change 650 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "enhanced "use strict" warning", #F017
+ From: Tkil <tkil@reptile.scrye.com>
+ Msg-ID: <199712040938.CAA07628@reptile.scrye.com>
+ Files: gv.c t/pragma/strict-subs t/pragma/strict-vars
+
+Change 649 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "eval of sub gives spurious "uninitialised" warning", #F016
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199712061025.FAA14396@aatma.engin.umich.edu>
+ Files: pod/perldelta.pod pod/perlfunc.pod op.c t/op/eval.t
+
+Change 648 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "[PERL] Assigning result of pop scrambles unrelated reference", #F015
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199712061100.GAA14864@aatma.engin.umich.edu>
+ Files: sv.c
+
+Change 647 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "[PERL] Filedescriptor leak in 5.004_55 (and earlier)", #F014
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199712151922.OAA06410@monk.mps.ohio-state.edu>
+ Files: os2/os2.c util.c
+
+Change 646 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix fdopen() on STD{IN,OUT,ERR}", #F013
+ From: Roderick Schertler <roderick@argon.org>
+ Msg-ID: <pzg1npp6e3.fsf@eeyore.ibcinc.com>
+ Files: doio.c t/op/misc.t
+
+Change 645 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix local $a[0] and local $h{a}", #F012
+ From: Stephen McCamant <alias@mcs.com>
+ Msg-ID: <m0xjWFq-000EZeC@alias-2.pr.mcs.net>
+ Files: embed.h scope.h global.sym pp.c pp_hot.c scope.c t/op/local.t
+
+Change 644 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Eliminate redundant mg_get() in SvTRUE()", #F011
+ From: Spider Boardman <spider@orb.nashua.nh.us>
+ Msg-ID: <199712251839.NAA14800@Orb.Nashua.NH.US>
+ Files: sv.c
+
+Change 643 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Don't force scalar context on C<my @x> or C<my %x>", #F010
+ From: Chip Salzenberg
+ Files: op.c t/op/my.t
+
+Change 642 on 1998/03/03 by TimBunce@ig.co.uk
+
+ Title: "Fix assignment to $_[0] in DESTROY", #F009
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199801010030.TAA14274@aatma.engin.umich.edu>
+ Files: pod/perlobj.pod sv.c t/op/ref.t
+
+Change 627 on 1998/03/02 by TimBunce@ig.co.uk
+
+ Title: "Fix inefficient checks for TIEHANDLE", #F008
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199801080106.UAA05048@aatma.engin.umich.edu>
+ Files: pp_hot.c pp_sys.c
+
+Change 626 on 1998/03/02 by TimBunce@ig.co.uk
+
+ This is the change description for change 625
+ Title: "Fix tr///s option", #F007
+ From: Inaba Hiroto <inaba@st.rim.or.jp>
+ Msg-ID: <19980110155333D.inaba@st.rim.or.jp>
+ Files: doop.c
+
+Change 623 on 1998/03/02 by TimBunce@ig.co.uk
+
+ Title: "Fix lexical lookup in eval-sub-eval", #F006
+ From: Chip Salzenberg
+ Files: pp_ctl.c
+
+Change 622 on 1998/03/02 by TimBunce@ig.co.uk
+
+ Title: "Don't upgrade target of assignment from LVALUE", #F005
+ From: Chip Salzenberg
+ Files: sv.c
+
+Change 621 on 1998/03/02 by TimBunce@ig.co.uk
+
+ Title: "Fix compile-time warning line in while ()", #F004
+ From: Chip Salzenberg
+ Files: op.c
+
+Change 620 on 1998/03/02 by TimBunce@ig.co.uk
+
+ Title: "STMT foreach LIST;", #F002
+ From: Chip Salzenberg
+ Files: pod/perlsyn.pod perly.c perly.c.diff perly.y t/cmd/mod.t toke.c
+ vms/perly_c.vms
+
+Change 619 on 1998/03/02 by TimBunce@ig.co.uk
+
+ Title: "Fix SIGSEGV on C<42 until forever>", #F001
+ From: Chip Salzenberg
+ Files: op.c
+
+----------------
+Version 5.004_04 Maintenance release 4 for 5.004
+----------------
+
+"1. Out of clutter, find simplicity.
+ 2. From discord, find harmony.
+ 3. In the middle of difficulty lies opportunity."
+ -- Albert Einstein, three rules of work
+
+
+ HEADLINES FOR THIS MAINTENANCE RELEASE
+
+ Fixed gaps in tainting (readdir, readlink, gecos, bit vector ops).
+ Fixed memory leak in splice(@_).
+ Fixed debugger core dumps.
+ IO::Socket now sets autoflush by default.
+ Several perldoc bugs fixed, now faster and more helpful.
+ Fixed Win32 handle leak.
+ Many other improvements to Win32 support.
+ Many many other bug fixes and enhancements.
+
+
+ ------ BUILD PROCESS ------
+
+ Title: "ExtUtils::Liblist prints diagnostics to STDOUT (vs. STDERR)"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, jesse@ginger
+ (Jesse Glick)
+ Msg-ID: <199708290032.UAA15663@ginger>,
+ <Pine.SUN.3.96.970829132217.28552A-100000@newton.phys>
+ Files: MANIFEST lib/ExtUtils/Liblist.pm
+
+ Title: "Set LD_RUN_PATH when building suidperl"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Tony Sanders
+ <sanders@bsdi.com>
+ Msg-ID: <199708272226.QAA10206@austin.bsdi.com>
+ Files: Makefile.SH
+
+ Title: "INSTALL version 1.26"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.970828143314.27416B-100000@newton.phys>
+ Files: INSTALL
+
+ Title: "Propagate MAKE=$(MAKE) through perl build"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.970908143853.13750C-100000@newton.phys>
+ Files: Makefile.SH makedepend.SH x2p/Makefile.SH ext/util/make_ext
+
+ Title: "update to installperl for perl5.004_02 to skip CVS dir"
+ From: Tony Sanders <sanders@bsdi.com>
+ Msg-ID: <199708272307.RAA13451@austin.bsdi.com>
+ Files: installperl
+
+ Title: "makedepend loop on HP-UX 10.20"
+ Msg-ID: <1997Sep20.183731.2297443@cor.newman>
+ Files: Makefile.SH
+
+ Title: "Tiny Grammaro in INSTALL"
+ From: koenig@anna.mind.de (Andreas J. Koenig)
+ Msg-ID: <sfcwwkb2pc8.fsf@anna.in-berlin.de>
+ Files: INSTALL
+
+ Title: "Fix Configured osvers under Linux 1"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, Hugo van der
+ Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199709241439.PAA17114@crypt.compulink.co.uk>,
+ <Pine.SUN.3.96.970924112654.5054D-100000@newton.phys>
+ Files: Configure
+
+ Title: "INSTALL-1.28"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.971010131207.23751A-100000@newton.phys>
+ Files: INSTALL
+
+ Title: "makedepend.SH fix for UNICOS"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199710132039.XAA21459@alpha.hut.fi>
+ Files: makedepend.SH
+
+ ------ CORE LANGUAGE ------
+
+ Title: "Re: "perl -d" dumps core when loading syslog.ph"
+ From: Jochen Wiedmann <wiedmann@neckar-alb.de>, Stephen McCamant
+ <alias@mcs.com>, ilya@math.ohio-state.edu (Ilya
+ Zakharevich)
+ Msg-ID: <1997Aug30.034921.2297381@cor.newman.upenn.edu>,
+ <3407639E.FEBF20BA@neckar-alb.de>,
+ <m0x4ZGj-000EZYC@alias-2.pr.mcs.net>
+ Files: pp_ctl.c
+
+ Title: "Allow $obj->$coderef()"
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Msg-ID: <199708291649.MAA23276@nielsenmedia.com>
+ Files: pp_hot.c
+
+ Title: "Localize PV value in save_gp()", "typeglob differences in perl4 and
+ perl5"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Stephen McCamant
+ <alias@mcs.com>
+ Msg-ID: <199708272348.TAA03139@aatma.engin.umich.edu>,
+ <m0x4u2o-000EZkC@alias-2.pr.mcs.net>
+ Files: scope.c t/op/ref.t
+
+ Title: "Avoid assumption that STRLEN == I32"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Hallvard B Furuseth
+ <h.b.furuseth@usit.uio.no>
+ Msg-ID: <199708242310.BAA05497@bombur2.uio.no>
+ Files: hv.c
+
+ Title: "Fix memory leak in splice(@_)"
+ From: "Tuomas J. Lukka" <tjl@fkfuga.pc.helsinki.fi>, Chip Salzenberg
+ <chip@rio.atlantic.net>
+ Msg-ID: <m0x3iQE-000CBrC@lukka.student.harvard.edu>
+ Files: proto.h av.c global.sym pp.c
+
+ Title: "Fix line number of warnings in while() conditional", "misleading
+ uninit value warning"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Greg Bacon
+ <gbacon@crp-201.adtran.com>
+ Msg-ID: <199708271607.LAA01403@crp-201.adtran.com>
+ Files: proto.h op.c perly.c perly.y
+
+ Title: "-t and POSIX::isatty on IO::Handle objects", "Fix C<-t $handle>"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Greg Ward
+ <greg@bic.mni.mcgill.ca>
+ Msg-ID: <199708261754.NAA24826@bottom.bic.mni.mcgill.ca>
+ Files: pp_sys.c
+
+ Title: "Fix output of invalid printf formats"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Hugo van der Sanden
+ <hv@crypt.compulink.co.uk>
+ Msg-ID: <199708241529.QAA02457@crypt.compulink.co.uk>
+ Files: sv.c t/op/sprintf.t
+
+ Title: "regexec.c regcppartblow declaration missing an arg"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199708290059.BAA05808@crypt.compulink.co.uk>
+ Files: regexec.c
+
+ Title: "taint readlink, readdir, gecos"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199709131651.TAA13471@alpha.hut.fi>
+ Files: pod/perlfunc.pod pod/perlsec.pod pp_sys.c t/op/taint.t
+
+ Title: "clean up old style package' usage in op.c"
+ From: Stephen Potter <spp@psa.pencom.com>
+ Msg-ID: <199709151813.NAA14433@psisa.psa.pencom.com>
+ Files: op.c
+
+ Title: "beautifying usage() code in perl.c"
+ From: "John L. Allen" <"John L. Allen"<allen@gateway.grumman.com>>
+ Msg-ID: <Pine.SOL.3.91.970905091314.5991C-100000@gateway>
+ Files: perl.c
+
+ Title: "debugger to fix core dumps, adds $^S"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199709170823.EAA21359@monk.mps.ohio-state.edu>
+ Files: pod/perlvar.pod perl.h gv.c lib/perl5db.pl mg.c perl.c toke.c
+
+ Title: "downgrade "my $foo masks earlier" from mandatory to "-w""
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Stephen Potter
+ <spp@psa.pencom.com>
+ Msg-ID: <199709091832.NAA14763@psisa.psa.pencom.com>,
+ <199709102019.QAA09591@aatma.engin.umich.edu>
+ Files: pod/perldelta.pod pod/perldiag.pod op.c
+
+ Title: "fix overridden glob() problems"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199709171645.MAA13988@aatma.engin.umich.edu>
+ Files: MANIFEST pod/perlsub.pod lib/File/DosGlob.pm op.c t/lib/dosglob.t
+ toke.c
+
+ Title: "Reverse previous "Fix C<qq #hi#>" patch"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Kenneth Albanowski
+ <kjahds@kjahds.com>, Tom Christiansen
+ <tchrist@jhereg.perl.com>
+ Msg-ID: <199707050155.VAA27394@rio.atlantic.net>,
+ <199708172326.RAA19344@jhereg.perl.com>,
+ <Pine.LNX.3.93.970817200236.170F-100000@kjahds.com>
+ Files: toke.c
+
+ Title: "printf type warning buglets in m3t2"
+ From: Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
+ Msg-ID: <199708141017.MAA10225@bombur2.uio.no>
+ Files: regcomp.c regexec.c scope.c sv.c util.c x2p/util.c
+
+ Title: "Localize PV value in save_gp()", "typeglob differences in perl4 and
+ perl5"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Stephen McCamant
+ <alias@mcs.com>
+ Msg-ID: <199708272348.TAA03139@aatma.engin.umich.edu>,
+ <m0x4AUk-000EUJC@alias-2.pr.mcs.net>
+ Files: scope.c t/op/ref.t
+
+ Title: "unpack now allows commas but -w warns", "unpack() difference
+ 5.003->5.004"
+ From: "John L. Allen" <allen@gateway.grumman.com>, Chip Salzenberg
+ <chip@rio.atlantic.net>, Jarkko Hietaniemi <jhi@iki.fi>,
+ Jim Esten <jesten@wdynamic.com>, Jim Esten
+ <jesten@wepco.com>, timbo (Tim Bunce)
+ Msg-ID: <199709031632.LAA29584@wepco.com>,
+ <199709090257.WAA32670@rio.atlantic.net>,
+ <199709090917.MAA05602@alpha.hut.fi>,
+ <199709091000.LAA24094@toad.ig.co.uk>,
+ <341077FE.132F@wdynamic.com>,
+ <Pine.SOL.3.91.970905171243.14630A-100000@gateway>
+ Files: pod/perldiag.pod pp.c
+
+ Title: "5.004_04 trial 1 assorted minor details"
+ From: Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
+ Msg-ID: <HBF.970921p5f6@bombur2.uio.no>
+ Files: Porting/pumpkin.pod hv.c op.c sv.c x2p/util.c
+
+ Title: "A couple of 4_04t1 problems"
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9709210959.AA28772@claudius.bfsec.bt.co.uk>
+ Files: lib/Cwd.pm perl.c
+
+ Title: "Minor changes to ease port to MVS"
+ From: Len Johnson <lenjay@ibm.net>, SMTP%"BAHUFF@us.oracle.com" ,
+ SMTP%"pfuntner@vnet.ibm.com" , pvhp@forte.com (Peter
+ Prymmer)
+ Msg-ID: <199709162058.NAA00952@mailsun2.us.oracle.com>
+ Files: unixish.h miniperlmain.c
+
+ Title: "Truer version string and more robust perlbug"
+ From: "Michael A. Chase" <mchase@ix.netcom.com>, Hugo van der Sanden
+ <hv@crypt.compulink.co.uk>
+ Msg-ID: <199709201514.QAA21187@crypt.compulink.co.uk>,
+ <1997Sep22.090701.2297448@cor.newman>
+ Files: perl.c utils/perlbug.PL
+
+ Title: "Fix locale bug for constant (readonly) strings"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199709262125.AAA28292@alpha.hut.fi>
+ Files: sv.c t/pragma/locale.t
+
+ Title: "Enable truly global glob()"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710080000.UAA18972@aatma.engin.umich.edu>
+ Files: op.c
+
+ Title: "Fix for $0 truncation"
+ From: Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <199710081703.SAA02653@toad.ig.co.uk>
+ Files: mg.c
+
+ Title: "Fix for missing &import leaving stack untidy"
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Msg-ID: <199709282252.SAA22915@nielsenmedia.com>
+ Files: pp_hot.c
+
+ Title: "Larry's proto fix"
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Msg-ID: <199709290004.UAA07559@nielsenmedia.com>
+ Files: op.c t/comp/proto.t
+
+ Title: "Fix bugs with magical arrays and hashes (@ISA)"
+ From: Chip Salzenberg <chip@rio.atlantic.net>
+ Msg-ID: <199709232148.RAA29967@rio.atlantic.net>
+ Files: perl.h proto.h av.c global.sym gv.c mg.c pp.c pp_hot.c scope.c
+ t/op/method.t
+
+ Title: "Perl_debug_log stream used for all DEBUG_*(...) macro uses"
+ From: Nick Ing-Simmons <nik@tiuk.ti.com>, Tim Bunce
+ Msg-ID: <199709230820.JAA11945@tiuk.ti.com>
+ Files: perl.c taint.c util.c
+
+ Title: "Tainting bitwise vector ops"
+ From: Chip Salzenberg <chip@rio.atlantic.net>
+ Msg-ID: <199710061726.NAA16438@rio.atlantic.net>
+ Files: doop.c t/op/taint.t
+
+ Title: "Enhance $^E on OS/2"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199709232236.SAA04463@monk.mps.ohio-state.edu>
+ Files: pod/perlvar.pod mg.c os2/Changes
+
+ Title: "option "!#... -- ..." in perl 5.004.03 seems not to work"
+ From: "John L. Allen" <allen@gateway.grumman.com>, Urs Thuermann
+ <urs@isnogud.escape.de>
+ Msg-ID: <199709232030.WAA30425@isnogud.escape.de>,
+ <Pine.SOL.3.91.970930105158.10789A-100000@gateway>
+ Files: perl.c
+
+ Title: "syswrite will again write a zero length buffer"
+ From: Cameron Simpson <cs@zip.com.au>, Jarkko Hietaniemi <jhi@iki.fi>,
+ aml@world.std.com (Andrew M. Langmead)
+ Msg-ID: <199710042107.AAA28561@alpha.hut.fi>,
+ <19971007104652-cameron-1-10391@sid.research.canon.com.au>
+ Files: pp_sys.c
+
+ Title: "make Odd number of elements in hash list warning non-mandatory"
+ From: Jason Varsoke {81530} <jjv@caesun10.msd.ray.com>
+ Msg-ID: <199710021651.MAA15690@caesun7.msd.ray.com>
+ Files: pp.c pp_hot.c
+
+ Title: "Fix defined() bug in m4t3 affecting LWP"
+ From: chip@atlantic.net@ig.co.uk ()
+ Msg-ID: <199710101822.OAA14249@cyprus.atlantic.net>
+ Files: pp.c
+
+ Title: "Include $archname in perl -v output"
+ From: Tim Bunce <Tim.Bunce@ig.co.uk>
+ Files: perl.c
+
+ Title: "-I flag can easily lead to whitespace in @INC"
+ From: Kenneth Stephen <y2kmvs@us.ibm.com>, Tim Bunce <Tim.Bunce@ig.co.uk>,
+ pvhp@forte.com (Peter Prymmer)
+ Msg-ID: <199710130922.KAA07780@toad.ig.co.uk>,
+ <5040400007001448000002L082*@MHS>,
+ <9710132015.AA12457@forte.com>
+ Files: perl.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "perldiag.pod: gotcha in short pattern/char ops"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199709050718.KAA31405@alpha.hut.fi>
+ Files: pod/perldiag.pod
+
+ Title: "Documenting the perl-thanks address"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.970913064628.12359F-100000@julie.teleport.com>
+ Files: pod/perl.pod
+
+ Title: "Missing section for @_ in perlvar."
+ From: abigail@fnx.com (Abigail)
+ Msg-ID: <199708142146.RAA13146@fnx.com>
+ Files: pod/perlvar.pod
+
+ Title: "Promised information about AvHASH in perguts is not delivered"
+ From: mjd@plover.com
+ Files: pod/perlguts.pod
+
+ Title: "perlfunc.doc - $_ aliasing in map, grep, foreach etc"
+ From: Ted Ashton <ashted@southern.edu>
+ Msg-ID: <199708181852.OAA15901@ns.southern.edu>
+ Files: pod/perlfunc.pod
+
+ Title: "-U Unsafe operations need -w to warn"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.970826141343.13463h-100000@julie.teleport.com>
+ Files: pod/perlrun.pod
+
+ Title: "document the return value of syscall"
+ From: Hans Mulder <hansm@icgned.nl>
+ Msg-ID: <1997Sep7.160817.2297395@cor.newman>
+ Files: pod/perlfunc.pod
+
+ Title: "minor fix for perltrap.pod"
+ From: abigail@fnx.com (Abigail)
+ Msg-ID: <199709170500.BAA14805@fnx.com>
+ Files: pod/perltrap.pod
+
+ Title: "xsubpp: document advanced dynamic typemap usage"
+ From: "Rujith S. de Silva" <desilva@netbox.com>
+ Files: pod/perlxs.pod
+
+ Title: "Improved diagnostic docs for here-documents"
+ From: Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.970921074004.21358G-100000@julie.teleport.com>
+ Files: pod/perldiag.pod
+
+ Title: "[POD patch] do-FILE forces scalar context."
+ From: Robin Houston <robin@oneworld.org>
+ Msg-ID: <199709221553.QAA28409@carryon.oneworld.org>
+ Files: pod/perlfunc.pod
+
+ Title: "perlop.pop. Behaviour of C<qq#hi#> vs C<qq #hi#>."
+ From: abigail@fnx.com (Abigail)
+ Msg-ID: <199709220107.VAA27064@fnx.com>
+ Files: pod/perlop.pod
+
+ Title: "Clarify exec docs in perlfunc.pod"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199710081353.OAA00834@crypt.compulink.co.uk>
+ Files: pod/perlfunc.pod
+
+ Title: "Documentation patch for perlguts.pod--document tainting routines"
+ From: Dan Sugalski <sugalskd@osshe.edu>
+ Msg-ID: <3.0.3.32.19971007165226.02fd2cd4@osshe.edu>
+ Files: pod/perlguts.pod
+
+ Title: "Man perlfunc: incorrect split example"
+ From: Joerg Porath <Joerg.Porath@informatik.tu-chemnitz.de>
+ Msg-ID: <199709240620.IAA30928@pandora.hrz.tu-chemnitz.de>
+ Files: pod/perlfunc.pod
+
+ Title: "Improve "Use of inherited AUTOLOAD for non-method" disgnostic"
+ From: rjray@uswest.com (Randy J. Ray)
+ Msg-ID: <199709231710.LAA08854@tremere.ecte.uswc.uswest.com>
+ Files: pod/perldiag.pod
+
+ Title: "Document split-with-limit on empty string perl4/perl5 change"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Gisle Aas <aas@bergen.sn.no>, Hugo
+ van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199709221419.PAA03987@crypt.compulink.co.uk>,
+ <hiuvttdkv.fsf@bergen.sn.no>
+ Files: pod/perlfunc.pod pod/perltrap.pod URI/URL/http.pm t/op/split.t
+
+ Title: "Clarify close() docs"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710081653.MAA20611@monk.mps.ohio-state.edu>
+ Files: pod/perlfunc.pod
+
+ Title: "perldiag log & sqrt - refer to Math::Complex package"
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Msg-ID: <199710042129.AAA20367@alpha.hut.fi>
+ Files: pod/perldiag.pod
+
+ Title: "perlfunc.pod: sysread, syswrite docs"
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Msg-ID: <199710061910.WAA15266@alpha.hut.fi>
+ Files: pod/perlfunc.pod
+
+ Title: "Document //gc"
+ From: abigail@fnx.com (Abigail)
+ Msg-ID: <199709232302.TAA27947@fnx.com>
+ Files: pod/perlop.pod
+
+ Title: "repeating #! switches"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Robin Barker
+ <rmb1@cise.npl.co.uk>
+ Msg-ID: <199709241736.NAA25855@rio.atlantic.net>,
+ <24778.9709241501@tempest.cise.npl.co.uk>
+ Files: pod/perlrun.pod
+
+ Title: "Re: taint documentation bug"
+ From: Ken Estes <estes@ms.com>, Tom Phoenix <rootbeer@teleport.com>
+ Msg-ID: <Pine.GSO.3.96.971006121349.10551X-100000@usertest.teleport.com>
+ Files: pod/perlsec.pod
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "FileHandle.pm fails if Exporter has not been loaded previously"
+ From: jan.dubois@ibm.net (Jan Dubois)
+ Msg-ID: <3445e05b.17874041@smtp2.ibm.net>
+ Files: lib/FileHandle.pm
+
+ Title: "Prefer startperl path over perlpath in MakeMaker"
+ From: Andreas Klussmann <andreas@infosys.heitec.de>
+ Msg-ID: <199709162017.WAA05043@troubadix.infosys.heitec.net>
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "Sys::Hostname fails under Solaris 2.5 when setuid"
+ From: Patrick Hayes <Patrick.Hayes.CAP_SESA@renault.fr>
+ Msg-ID: <199708201240.OAA04243@goblin.renault.fr>
+ Files: lib/Sys/Hostname.pm
+
+ Title: "Cwd::getcwd cannot handle path contains '0' element"
+ From: Hironori Ikura <hikura@tcc.co.jp>, Hironori Ikura
+ <hikura@trans-nt.com>, Stephen Zander <srz@mckesson.com>
+ Msg-ID: <19970830060142J.hikura@matsu.tcc.co.jp>,
+ <m0x4TzI-0003F1C@wsuse5.mckesson.com>
+ Files: lib/Cwd.pm
+
+ Title: "Getopt::Long 2.11"
+ From: JVromans@squirrel.nl (Johan Vromans)
+ Msg-ID: <m0xBcdR-000RArC@plume.nl.compuware.com>
+ Files: lib/Getopt/Long.pm
+
+ Title: "IO::Socket autoflush by default, assume tcp and PeerAddr"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Andy Dougherty
+ <doughera@newton.phys.lafayette.edu>, Gisle Aas
+ <aas@bergen.sn.no>
+ Msg-ID: <E0x9WpH-0003HT-00@ursa.cus.cam.ac.uk>,
+ <Pine.SUN.3.96.970915115856.23236F-100000@newton.phys>,
+ <hvi07zvo9.fsf@bergen.sn.no>
+ Files: ext/IO/lib/IO/Socket.pm
+
+ Title: "Syslog.pm and missing _PATH_LOG"
+ From: Ulrich Pfeifer <upf@de.uu.net>
+ Msg-ID: <p5iuw1cris.fsf@knowway.de.uu.net>
+ Files: lib/Sys/Syslog.pm
+
+ Title: "Undocumented: $Test::Harness::switches"
+ From: Achim Bohnet <ach@mpe.mpg.de>
+ Msg-ID: <9708272110.AA26904@o09.xray.mpe.mpg.de>
+ Files: lib/Test/Harness.pm
+
+ Title: "Patches for lib/Math/Complex.pm and t/lib/complex.t"
+ From: Jarkko Hietaniemi <jhi@anna.in-berlin.de>
+ Msg-ID: <199709102009.WAA27428@anna.in-berlin.de>
+ Files: lib/Math/Complex.pm t/lib/complex.t
+
+ Title: "Win32: Install.pm not correctly comparing binary files."
+ From: Jeff Urlwin <jurlwin@access.digex.net>
+ Msg-ID: <01BCBFAA.E325C4A0.jurlwin@access.digex.net>
+ Files: lib/ExtUtils/Install.pm
+
+ Title: "Document that File::Find doesn't follow symlinks"
+ From: Greg Ward <greg@bic.mni.mcgill.ca>
+ Msg-ID: <199708191853.OAA07111@bottom.bic.mni.mcgill.ca>
+ Files: lib/File/Find.pm
+
+ Title: "fix subroutines called in a void context in perl5db.pl"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0x6Gsa-0004VR-00@ursa.cus.cam.ac.uk>
+ Files: lib/perl5db.pl
+
+ Title: "xsubpp fix to allow #ifdef's around entire XSubs"
+ From: John Tobey <jtobey@user1.channel1.com>
+ Msg-ID: <199709070034.AAA16457@remote119>
+ Files: lib/ExtUtils/xsubpp
+
+ Title: "Banishing eval from getopt.pl and Getopt/Std.pm"
+ From: "John L. Allen" <allen@gateway.grumman.com>
+ Msg-ID: <Pine.SOL.3.91.970920154720.3683A@gateway>
+ Files: lib/getopt.pl lib/Getopt/Std.pm
+
+ Title: "further complex number patches"
+ From: Jarkko Hietaniemi <jhi@iki.fi>, d-lewart@uiuc.edu (Daniel S. Lewart)
+ Msg-ID: <199709221009.FAA21216@staff2.cso.uiuc.edu>,
+ <199709221216.PAA15130@alpha.hut.fi>
+ Files: lib/Math/Complex.pm t/lib/complex.t
+
+ Title: "Trap Time::Local infinite loop"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199710030030.BAA17372@crypt.compulink.co.uk>
+ Files: lib/Time/Local.pm
+
+ Title: "Cosmetic Test::Harness patch"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710032226.SAA15354@monk.mps.ohio-state.edu>
+ Files: lib/Test/Harness.pm
+
+ Title: "ExtUtil::Install sub my_cmp needs to binmode its files"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Stephen Potter
+ <spp@psa.pencom.com>
+ Msg-ID: <199710010617.BAA02037@psisa.psa.pencom.com>,
+ <199710011819.OAA03288@aatma.engin.umich.edu>
+ Files: lib/ExtUtils/Install.pm
+
+ Title: "Enable make test "TEST_FILES=t/*.t.were_failing""
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710032231.SAA15364@monk.mps.ohio-state.edu>
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "Fix for autouse.pm"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710071734.NAA19462@monk.mps.ohio-state.edu>
+ Files: lib/autouse.pm
+
+ Title: "Math::Complex fixes - fixes problems on m68-linux"
+ From: Jarkko Hietaniemi <jarkko.hietaniemi@research.nokia.com>
+ Msg-ID: <199709301422.HAA24368@koah.research.nokia.com>
+ Files: lib/Math/Complex.pm
+
+ Title: "Updated CPAN.pm for 5.004_04"
+ From: koenig@anna.mind.de (Andreas J. Koenig)
+ Msg-ID: <sfcpvpv8teo.fsf@anna.in-berlin.de>
+ Files: lib/CPAN.pm lib/CPAN/FirstTime.pm
+
+ Title: "debugger bug with 'c subname'"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199709232331.TAA04546@monk.mps.ohio-state.edu>
+ Files: lib/perl5db.pl
+
+ Title: "Fix atan2 & restrict $t to (-pi,pi] instead of to [-pi,pi]"
+ From: Daniel S. Lewart, Jarkko Hietaniemi
+ <jarkko.hietaniemi@research.nokia.com>
+ Msg-ID: <199710010939.CAA00964@koah.research.nokia.com>
+ Files: lib/Math/Complex.pm
+
+ Title: "Cwd::fastcwd needs changes to work with tainting"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>, Ulrich Pfeifer
+ <pfeifer@wait.de>, Tim Bunce
+ Msg-ID: <yfmwwk6y0bc.ulp@gretchen.informatik.uni-dortmund.de>
+ Files: lib/Cwd.pm
+
+ Title: "use autouse: requires prototype now"
+ From: user@agate.berkeley.edu
+ Msg-ID: <9709220450.AA0380@tuzik.HIP.Berkeley.EDU>
+ Files: lib/autouse.pm
+
+ Title: ""use base qw(Foo Bar);" to set @ISA at compile time"
+ From: Gisle Aas <gisle@aas.no>, Graham Barr <gbarr@pobox.com>, Graham Barr
+ <gbarr@ti.com>, Tim Bunce <Tim.Bunce@ig.co.uk>,
+ jan.dubois@ibm.net (Jan Dubois), larry@wall.org (Larry
+ Wall)
+ Msg-ID: <199710022151.WAA21250@toad.ig.co.uk>,
+ <199710031613.JAA11286@wall.org>,
+ <199710040829.KAA16739@furu.g.aas.no>,
+ <3434E4C6.AE24135E@ti.com>, <343C2278.7DC1ADC6@pobox.com>,
+ <343ec306.50394803@smtp-gw01.ny.us.ibm.net>
+ Files: lib/base.pm
+
+ Title: "Further Math/Complex.pm enhancements"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199710132055.XAA02086@alpha.hut.fi>
+ Files: lib/Math/Complex.pm t/lib/complex.t
+
+ Title: "Further Math::Complex fixes"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199710120933.MAA01165@alpha.hut.fi>
+ Files: lib/Math/Complex.pm
+
+ ------ OTHER CHANGES ------
+
+ Title: "POD patches w.r.t. $^S"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710030001.UAA14241@monk.mps.ohio-state.edu>
+ Files: ../pod/perlfunc.pod ../pod/perlvar.pod
+
+ Title: "libperl.sl on HP-UX 10.20"
+ From: "Darren/Torin/Who Ever..." <torin@daft.com>, Hugo van der Sanden
+ <hv@crypt.compulink.co.uk>
+ Msg-ID: <199709250003.BAA18085@crypt.compulink.co.uk>,
+ <873emkbpit.fsf@perv.daft.com>
+ Files:
+
+ Title: "myconfig / perl -V: remove randbits and add prototype"
+ From: Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <199709290857.JAA07706@toad.ig.co.uk>
+ Files: myconfig
+
+ Title: "Emacs CPerl update for 5.004_04"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710140835.EAA26825@monk.mps.ohio-state.edu>
+ Files: emacs/cperl-mode.el
+
+ Title: "Enhance perly.fixer to help porters."
+ From: Tim Bunce
+ Files: perly.fixer
+
+ ------ PORTABILITY - WIN32 ------
+
+ Title: "Fix win32/Makefile for perl95"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: win32/Makefile win32/makefile.mk
+
+ Title: "Win32 archnames"
+ From: Bill Middleton <wmiddlet@Adobe.COM>, Gurusamy Sarathy
+ <gsar@engin.umich.edu>, Peter Prymmer <pvhp@forte.com>, Tim
+ Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <199709111929.PAA22488@aatma.engin.umich.edu>,
+ <341719E4.4923@forte.com>,
+ <Pine.GSO.3.95.970905123145.12361B-100000@ducks>
+ Files: win32/config_H.bc win32/config_H.vc
+
+ Title: "pl2bat.bat -> pl2bat.pl change in win32/pod.mak"
+ From: jan.dubois@ibm.net (Jan Dubois)
+ Msg-ID: <3411ee6f.9143607@smtp-gw01.ny.us.ibm.net>
+ Files: win32/pod.mak
+
+ Title: "Add test-notty target to Win32 Makefile"
+ From: jan.dubois@ibm.net (Jan Dubois)
+ Msg-ID: <343f5106.12461608@smtp2.ibm.net>
+ Files: win32/Makefile
+
+ Title: "Bug in Win32::GetShortPathName"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710092229.SAA21556@aatma.engin.umich.edu>
+ Files: win32/win32.c
+
+ Title: "Fix NT handles leak."
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710111319.JAA10918@aatma.engin.umich.edu>
+ Files: win32/win32io.c win32/win32sck.c
+
+ Title: "fix socket init duality on win32"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199710111523.LAA12407@aatma.engin.umich.edu>
+ Files: win32/win32sck.c
+
+ ------ PORTABILITY - GENERAL ------
+
+ Title: "Tweak to hints/machten.sh: stop t/lib/complex.t from failing"
+ From: Dominic Dunlop <domo@tcp.ip.lu>
+ Msg-ID: <v03110700b06a30bdfc42@[194.51.248.80]>
+ Files: hints/machten.sh
+
+ Title: "Irix 6.2 build problem - so_locations"
+ From: "Billinghurst, David" <David.Billinghurst@riotinto.com.au>
+ Msg-ID: <D54B1932FFB4CF11B5C80000F8018BD2907E31@CRCMAIL>
+ Files: hints/irix_6.sh
+
+ Title: "Porting/pumpkin.pod version 1.13"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.970828142011.27416A-100000@newton.phys>
+ Files: Porting/pumpkin.pod
+
+ Title: "lib/timelocal.t fails test 1 for VMS 7.1"
+ From: Dan Sugalski <sugalsd@lbcc.cc.or.us>
+ Msg-ID: <3.0.3.32.19970908112449.0087bc90@stargate.lbcc.cc.or.us>
+ Files: vms/vmsish.h vms/vms.c
+
+ Title: "Patches to updated README.VMS for Perl 5.004_04"
+ From: Dan Sugalski <sugalsd@stargate.lbcc.cc.or.us>
+ Msg-ID: <3.0.3.32.19970918100648.008b1c60@stargate.lbcc.cc.or.us>
+ Files: README.vms
+
+ Title: "Fix perl build on Digital UNIX after JDK installs libnet.so"
+ From: Spider Boardman <spider@orb.nashua.nh.us>
+ Msg-ID: <199709191826.OAA18040@Orb.Nashua.NH.US>
+ Files: hints/dec_osf.sh
+
+ Title: "Updated README.VMS for Perl 5.004_04"
+ From: Dan Sugalski <sugalsd@stargate.lbcc.cc.or.us>
+ Msg-ID: <3.0.3.32.19970912091524.008a3620@stargate.lbcc.cc.or.us>
+ Files: README.vms
+
+ Title: "Dynixptx hints"
+ From: bruce@aps.org ("Bruce P. Schuck")
+ Msg-ID: <Pine.PTX.3.95.971002104651.12112G-200000@lancelot.aps.org>
+ Files: hints/dynixptx.sh
+
+ Title: "Minor OS/2 patch for 4_03"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710032224.SAA15345@monk.mps.ohio-state.edu>
+ Files: os2/os2.c
+
+ Title: "OS2::REXX improvements"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199709272214.SAA08638@monk.mps.ohio-state.edu>
+ Files: os2/Changes os2/OS2/REXX/Makefile.PL os2/OS2/REXX/REXX.pm
+
+ Title: "hints/qnx.sh update"
+ From: Norton Allen <allen@huarp.harvard.edu>
+ Msg-ID: <199709261508.LAA07889@dolores.harvard.edu>
+ Files: hints/qnx.sh
+
+ Title: "New hints file for IBM OS/390 OpenEdition (MVS)"
+ From: pvhp@forte.com (Peter Prymmer)
+ Msg-ID: <9709240106.AA26484@forte.com>
+ Files: hints/os390.sh
+
+ Title: "OS/2 Hints"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199710130631.CAA25426@monk.mps.ohio-state.edu>
+ Files: hints/os2.sh
+
+ ------ TESTS ------
+
+ Title: "op/glob.t test failure under Win32 with CVS"
+ From: Warren Jones <wjones@tc.fluke.com>
+ Msg-ID: <97Aug26.091048pdt.35761-1@gateway.fluke.com>
+ Files: t/op/glob.t
+
+ Title: "tests fail if localhost/loopback address not defined"
+ From: David McLean <David McLean<davem@icc.gsfc.nasa.gov>>, David McLean
+ <davem@icc.gsfc.nasa.gov>
+ Msg-ID: <34048947.2944@icc.gsfc.nasa.gov>
+ Files: t/lib/io_sock.t t/lib/io_udp.t
+
+ Title: "Improve pragma/locale test 102 - and don't fail, just warn"
+ From: Jarkko Hietaniemi <jhi@anna.in-berlin.de>
+ Files: t/pragma/locale.t
+
+ Title: "Invalid test output in t/op/taint.t in trial 1"
+ From: Dan Sugalski <sugalsd@lbcc.cc.or.us>
+ Msg-ID: <3.0.3.32.19970919160918.00857a50@stargate.lbcc.cc.or.us>
+ Files: t/op/taint.t
+
+ Title: "Identify t/*/*.t test failing because of file permissions"
+ From: koenig@anna.mind.de (Andreas J. Koenig)
+ Msg-ID: <sfcraah0xvy.fsf@anna.in-berlin.de>
+ Files: t/TEST
+
+ Title: "fix poor t/op/runlevel.t test"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Hugo van der Sanden
+ <hv@crypt.compulink.co.uk>, Norton Allen
+ <allen@huarp.harvard.edu>
+ Msg-ID: <199709261458.KAA28611@dolores.harvard.edu>
+ Files: t/op/runlevel.t
+
+ ------ UTILITIES ------
+
+ Title: "Missing 'require' in auto-generated .pm by h2xs"
+ From: davidk@tor.securecomputing.com (David Kerry)
+ Msg-ID: <97Aug27.131618edt.11650@janus.tor.securecomputing.com>
+ Files: utils/h2xs.PL
+
+ Title: "Perldoc tiny patch to avoid $0"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199709122141.RAA16846@monk.mps.ohio-state.edu>
+ Files: utils/perldoc.PL
+
+ Title: "h2ph broken in 5.004_02"
+ From: David Mazieres <dm@reeducation-labor.lcs.mit.edu>,
+ kstar@www.chapin.edu (Kurt D. Starsinic)
+ Msg-ID: <199708201454.KAA05122@reeducation-labor.lcs.mit.edu>,
+ <199708201700.KAA02621@www.chapin.edu>
+ Files: utils/h2ph.PL
+
+ Title: "add key_t caddr_t to h2ph", "eg/sysvipc/ipcsem bug", "update
+ hints/bsdos.sh"
+ From: Tony Sanders <sanders@bsdi.com>
+ Msg-ID: <199708272301.RAA12803@austin.bsdi.com>
+ Files: eg/sysvipc/ipcsem utils/h2ph.PL
+
+ Title: "perldoc search ., lib and blib/* if -f 'Makefile.PL'"
+ From: Tim Bunce
+ Msg-ID: <199708251732.KAA19299@gadget.cscaper.com>
+ Files: utils/perldoc.PL
+
+ Title: "5.004m4t1: perlbug: NIS domainname gets into wrong places"
+ From: koenig@anna.mind.de (Andreas J. Koenig)
+ Msg-ID: <sfcg1qy38as.fsf@anna.in-berlin.de>
+ Files: utils/perlbug.PL
+
+ Title: "add better local patch info to perlbug", "perlbug checks perl
+ build/run version changes"
+ From: Tim.Bunce@ig.co.uk
+ Files: utils/perlbug.PL
+
+ Title: "perldoc - suggest modules if requested module not found"
+ From: Anthony David <adavid@netinfo.com.au>
+ Msg-ID: <3439CD83.6969@netinfo.com.au>
+ Files: utils/perldoc.PL
+
+ Title: "perldoc mail::foo tries to read binary /usr/ucb/mail"
+ From: "Joseph Moof-in' Hall" <joseph@cscaper.com>, Tim Bunce
+ Msg-ID: <199710082014.NAA00808@gadget.cscaper.com>
+ Files: utils/perldoc.PL
+
+ Title: "perldoc -f setpwent (for example) returns no descriptive text"
+ From: Tim Bunce
+ Files: utils/perldoc.PL
+
+ Title: "perldoc diffs: don't search auto - much faster"
+ From: "Joseph N. Hall" <joseph@5sigma.com>
+ Msg-ID: <MailDrop1.2d7dPPC.971012211957@screechy.cscaper.com>
+ Files: utils/perldoc.PL
+
+
+
+----------------
+Version 5.004_03 Maintenance release 3 for 5.004
+----------------
+
+"To err is human, to forgive divine."
+ -- Alexander Pope
+
+
+ HEADLINES FOR THIS MAINTENANCE RELEASE
+
+ Fixed 5.004_02 compilation failure on VMS.
+ Fixed Configure (non)errors being displayed to user.
+ Better support for Windows 95.
+ Assorted documentation and hint file improvements.
+ perl --foo no longer silently ignored.
+
+
+ ------ BUILD PROCESS ------
+
+ Title: "Show Configure failure reason even with -s"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.970812141623.14256K-100000@newton.phys>
+ Files: Configure
+
+ Title: "Configure can stop without fully explaining itself"
+ From: Jim Anderson <jander@ml.com>
+ Msg-ID: <199708111328.JAA28976@nsd15.ny-swaps-develop.ml.com>,
+ <199708111952.PAA29346@nsd15.ny-swaps-develop.ml.com>
+ Files: Configure
+
+ ------ CORE LANGUAGE ------
+
+ Title: "typos in perl -h output"
+ From: "Richard A. Wells" <Rwells@uhs.harvard.edu>
+ Msg-ID: <6D0BF914BC@gateuhs.harvard.edu>
+ Files: perl.c
+
+ Title: "Some perldb -> PERLDB_* macro changes were missed"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199708100323.XAA27155@monk.mps.ohio-state.edu>
+ Files: pp_ctl.c
+
+ Title: "Further fix to lseek's in lockf_emulate_flock"
+ From: Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
+ Msg-ID: <199708060031.CAA07387@bombur2.uio.no>,
+ <199708102225.AAA16970@bombur2.uio.no>
+ Files: pp_sys.c
+
+ Title: "GNU style perl --version (or any other --foo) ignored"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Kenneth Albanowski
+ <kjahds@kjahds.com>, Stephen McCamant <alias@mcs.com>
+ Msg-ID: <E0wx8MO-0007BS-00@ursa.cus.cam.ac.uk>,
+ <Pine.LNX.3.93.970813122557.9443C-100000@kjahds.com>,
+ <m0wy8nl-000EYgC@alias-2.pr.mcs.net>
+ Files: pod/perldiag.pod perl.c
+
+ Title: "seen_dot declaration in perl.c needed for VMS"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199708072033.QAA09167@aatma.engin.umich.edu>
+ Files: perl.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "[PATCH] -D info in perlrun", "[PATCH] Re: -D info in perlrun"
+ From: Stephen McCamant <alias@mcs.com>, ilya@math.ohio-state.edu (Ilya
+ Zakharevich)
+ Msg-ID: <1997Aug10.195832.2224477@hmivax.humgen.upenn.edu>,
+ <m0wxNNL-000EYgC@alias-2.pr.mcs.net>,
+ <m0wxz6l-000EYgC@alias-2.pr.mcs.net>
+ Files: pod/perlrun.pod
+
+ Title: "perlop pod inconsistent in presentation of regexp options"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Hans Mulder <hansm@icgned.nl>,
+ jmr@whirlwind.fmr.com
+ Msg-ID: <199708061404.KAA06717@whirlwind.fmr.com>,
+ <199708081505.LAA09810@whirlwind.fmr.com>,
+ <1997Aug7.160530.2196011@hmivax.humgen.upenn.edu>,
+ <E0wwnqc-00057s-00@ursa.cus.cam.ac.uk>,
+ <E0wwswg-00017x-00@ursa.cus.cam.ac.uk>
+ Files: pod/perlop.pod
+
+ Title: "pod2man generated .IX lines upset whatis on Solaris"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, jmr@whirlwind.fmr.com (John
+ Redford)
+ Msg-ID: <E0wxoUZ-0006Ee-00@ursa.cus.cam.ac.uk>
+ Files: pod/pod2man.PL
+
+ Title: "The description of the \Q metacharacter is confusing to novices"
+ From: aml@world.std.com (Andrew M. Langmead)
+ Msg-ID: <199708101946.AA06339@world.std.com>
+ Files: pod/perlre.pod
+
+ Title: "doc patch for pack("p",undef) packing a NULL pointer"
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9708102159.AA11726@claudius.bfsec.bt.co.uk>
+ Files: pod/perldelta.pod pod/perlfunc.pod
+
+ Title: "perlfunc.pod error"
+ From: Tom Christiansen <tchrist@jhereg.perl.com>
+ Msg-ID: <199708102235.QAA18420@jhereg.perl.com>
+ Files: pod/perlfunc.pod
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "patch for documentation error in FileCache.pm"
+ From: Mike Stok <mike@stok.co.uk>, mikebo@tellabs.com
+ Msg-ID: <Pine.LNX.3.95.970810143321.437C-100000@stok.co.uk>
+ Files: lib/FileCache.pm
+
+ Title: "[PATCH] 5.004_02: Complex/Trig: update"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199708081842.VAA31214@alpha.hut.fi>
+ Files: lib/Math/Complex.pm lib/Math/Trig.pm t/lib/complex.t
+
+ Title: "CPAN Use of uninitialized value in newest perl"
+ From: tom@amber.ssd.hcsc.com (Tom Horsley)
+ Msg-ID: <9708091738.AA16435@amber.ssd.hcsc.com>
+ Files: lib/CPAN.pm
+
+ ------ PORTABILITY - WIN32 ------
+
+ Title: "[PATCH] /x is not a valid shell switch on Win95"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199708121720.NAA14760@aatma.engin.umich.edu>
+ Files: win32/win32.c
+
+ Title: "[PATCH] Win95-proofing pl2bat"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199708121733.NAA14888@aatma.engin.umich.edu>
+ Files: MANIFEST win32/Makefile win32/makefile.mk win32/bin/pl2bat.pl
+ win32/bin/runperl.pl win32/bin/search.pl
+ win32/bin/webget.pl
+
+ Title: "[PATCH] [OK] Perl5.004_02 on Alpha NT"
+ From: wmiddlet@adobe.com (William Middleton)
+ Msg-ID: <199708072100.OAA13141@ducks>
+ Files: win32/win32.c
+
+ ------ PORTABILITY - OTHER ------
+
+ Title: "Improve dual-universe comments in hints/sunos_4_1.sh"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.970812170358.14488E-100000@newton.phys>
+ Files: hints/sunos_4_1.sh
+
+ Title: "Dynamic Loading on MkLinux (osname=linux,archname=ppc-linux)"
+ From: Chris Nandor <pudge@pobox.com>, Shimpei Yamashita
+ <shimpei@socrates.patnet.caltech.edu>
+ Msg-ID: <33EF1634.B36B6500@pobox.com>
+ Files: hints/linux.sh
+
+ Title: "5.004_02 Configure - worrying but normal errors displayed to user"
+ From: Paul Marquess <pmarquess@bfsec.bt.co.uk>, pmarquess@bfsec.bt.co.uk
+ (Paul Marquess)
+ Msg-ID: <01BCA3DE.E257BFC0.pmarquess@bfsec.bt.co.uk>,
+ <9708102159.AA11726@claudius.bfsec.bt.co.uk>
+ Files: Configure os2/diff.configure
+
+ Title: "Minor glitch with Perl 5.004_01 on SunOS 4.1.3 (groupstype)"
+ From: thad@thadlabs.com (Thad Floryan)
+ Msg-ID: <9708111415.AA03808@thadlabs.com>
+ Files: hints/sunos_4_1.sh
+
+ Title: "SCO Openserver 5.0.4 - add comment to hint file re compiler bug"
+ From: Bill Glicker <billg@burrelles.com>
+ Msg-ID: <Pine.SCO.3.96.970811153021.18457A-100000@laura.burrelles.com>
+ Files: hints/sco.sh
+
+ ------ UTILITIES ------
+
+ Title: "perlbug -d non-interactive (with patch)"
+ From: Ted Ashton <ashted@southern.edu>
+ Msg-ID: <199708071418.KAA15711@ns.southern.edu>
+ Files: utils/perlbug.PL
+
+
+
+----------------
+Version 5.004_02 Maintenance release 2 for 5.004
+----------------
+
+"When you work you are a flute through whose
+ heart the whispering of the hours turns to music."
+ -- from The Prophet by Kahlil Gibran
+
+
+ HEADLINES FOR THIS MAINTENANCE RELEASE
+
+ Major memory growth bug fixed.
+ Object destruction is more timely and orderly.
+ Further major enhancements to Win32 support, including:
+ Win32 binary compatibility between Visual C++ and Borland C++.
+ The -S option is now more useful on dos/Win32 (see perlrun).
+ Implicit -p print now checks for write errors.
+ DB_File now sub-classable (and other fixes).
+ Memory usage stats available with perl's malloc (see perldelta).
+ 'use UNIVERSAL;' deprecated (see perldelta).
+ Internal integer to string conversions are faster.
+ Carp can be forced to give stack traces (see perldoc Carp).
+ Many other bug fixes and enhancements.
+
+
+ ------ BUILD PROCESS ------
+
+ Title: "[PATCH] m2t3: Configure: cf_time always in C locale"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199708061827.VAA09623@alpha.hut.fi>
+ Files: Configure
+
+ Title: "Configure can't find open3 on NeXTstep"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>, hans@icgned.nl
+ (Hans Mulder)
+ Msg-ID: <9706271816.AA10551@ icgned.icgned.nl >
+ Files: Configure
+
+ Title: "Don't use undef value in Config::myconfig"
+ From: "Andreas J. Koenig" <k@sissy.in-berlin.de>, Chip Salzenberg
+ <salzench@nielsenmedia.com>
+ Msg-ID: <199706271525.RAA13517@sissy.in-berlin.de>
+ Files: configpm
+
+ Title: "make Configure recognize powerux hint (perl5.004_01)"
+ From: tom@amber.ssd.hcsc.com (Tom Horsley)
+ Msg-ID: <9707301938.AA08352@amber.ssd.hcsc.com>
+ Files: Configure
+
+ Title: "[PATCH]: HP-UX 10 w/o transition links"
+ From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com>
+ Msg-ID: <199706181851.AA093329906@hpcc123.corp.hp.com>,
+ <199706231650.AA070364627@hpcc123.corp.hp.com>
+ Files: Configure
+
+ Title: "INSTALL updates for GNU ld and __inet_* errors"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Files: INSTALL
+
+ ------ CORE LANGUAGE ------
+
+ Title: "[PATCH] Additional patch for "Can't execute ...""
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707191651.MAA04897@monk.mps.ohio-state.edu>
+ Files: pod/perldiag.pod perl.c
+
+ Title: "[PATCH] Band-aid fix for local([@%]$x)"
+ From: Stephen McCamant <alias@mcs.com>
+ Msg-ID: <m0wsb7J-000EYPC@alias-2.pr.mcs.net>
+ Files: pod/perldiag.pod op.c pp_hot.c t/op/local.t
+
+ Title: "[PATCH] Re: Bug in Regular Expressions when using colon as
+ delimiter"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0wtbhv-0005Mm-00@ursa.cus.cam.ac.uk>
+ Files: pod/perldiag.pod regcomp.c t/op/re_tests t/op/regexp.t
+
+ Title: "[PATCH] Re: Can't pack literals as pointers"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199708012250.SAA20278@aatma.engin.umich.edu>
+ Files: pod/perldiag.pod pod/perlfunc.pod pp.c t/op/pack.t
+
+ Title: "[PATCH] Do not constant-fold ops that depend on locale if C<use
+ locale>"
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Msg-ID: <199707210519.BAA13785@nielsenmedia.com>
+ Files: op.c
+
+ Title: "Eval fails in certain situations (eval "{'...")"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707211753.NAA14940@aatma.engin.umich.edu>
+ Files: t/comp/term.t toke.c
+
+ Title: "Fix memory leak on eval 'sub {}'"
+ From: Chip Salzenberg <chip@rio.atlantic.net>
+ Files: pp_ctl.c
+
+ Title: "stringify looses integerness"
+ From: Gisle Aas <aas@bergen.sn.no>
+ Msg-ID: <hbu4l96z2.fsf@bergen.sn.no>
+ Files: sv.c
+
+ Title: "Fix intolerance of a space between "print" and opening paren"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707011421.KAA15836@aatma.engin.umich.edu>
+ Files: toke.c
+
+ Title: "[PATCH] Re: Calling Perl from within C from within Perl"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199706301842.OAA05569@aatma.engin.umich.edu>
+ Files: perl.c
+
+ Title: "UNIVERSAL.pm and import methods (tests)"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0whfHh-0007bW-00@ursa.cus.cam.ac.uk>
+ Files: t/op/universal.t universal.c
+
+ Title: "Avoid core dump on some paren'd regexp matches", "One-liner regex
+ causes SEGV on 5.003 under HP-UX and Linux"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199706261236.NAA03472@crypt.compulink.co.uk>,
+ <199707061144.MAA04443@crypt.compulink.co.uk>
+ Files: regexec.c t/op/re_tests
+
+ Title: "Forbid negative splice offset beyond array start"
+ From: "John L. Allen" <allen@gateway.grumman.com>, Chip Salzenberg
+ <chip@rio.atlantic.net>
+ Msg-ID: <Pine.SOL.3.91.970625111744.19300A-100000@gateway>
+ Files: pp.c
+
+ Title: "Forbid "goto" into middle of foreach loop"
+ From: Chip Salzenberg <chip@rio.atlantic.net>
+ Files: pod/perldiag.pod pp_ctl.c
+
+ Title: "Fix C<qq #hi#>"
+ From: Chip Salzenberg <chip@rio.atlantic.net>
+ Files: toke.c
+
+ Title: "bless file handles as FileHandle if loaded else IO::Handle"
+ From: Gisle Aas <aas@bergen.sn.no>
+ Msg-ID: <hyb80drrz.fsf@bergen.sn.no>
+ Files: gv.c lib/FileHandle.pm
+
+ Title: "infinite recursion in malloc() with some compile flags"
+ From: Hans Mulder <hansmu@xs4all.nl>
+ Msg-ID: <199706240050.CAA10550@xs2.xs4all.nl>
+ Files: malloc.c
+
+ Title: "sv_vcatpvfn hogs memory [Patch included]"
+ From: Matthias Neeracher <neeri@iis.ee.ethz.ch>
+ Msg-ID: <199706211521.RAA12778@solar.ethz.ch>
+ Files: sv.c
+
+ Title: "Fix '-' flag on sprintf() of floats"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Jarkko Hietaniemi
+ <jhi@iki.fi>
+ Msg-ID: <199705270646.JAA02510@alpha.hut.fi>
+ Files: sv.c
+
+ Title: "Free temps before calling END blocks", "Too late destruction"
+ From: Chip Salzenberg <chip@rio.atlantic.net>
+ Msg-ID: <m33erfv5hx.fsf@chany-p100.emwp.com>
+ Files: perl.c
+
+ Title: "Fix C<print $foo x 2> parsing"
+ From: "Chuck D. Phillips (NON-HP Employee)" <cdp@hpescdp.fc.hp.com>, Chip
+ Salzenberg <chip@rio.atlantic.net>
+ Msg-ID: <199706121737.KAA00503@palrel3.hp.com>
+ Files: toke.c
+
+ Title: "Fix lockf_emulate_flock() positioning"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, gen@atd.rdc.ricoh.co.jp
+ Msg-ID: <199706091132.UAA00895@wampa.atd.rdc.ricoh.co.jp>
+ Files: pp_sys.c
+
+ Title: "Don't use atol() for unsigned values", "signedness problem in
+ pack("N", "value");"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Roger Espel Llima
+ <espel@llaic.univ-bpclermont.fr>
+ Msg-ID: <19970531200007.40218@llaic.univ-bpclermont.fr>
+ Files: sv.c
+
+ Title: "Don't warn about "${foo}" in string, even if &foo exists"
+ From: Chip Salzenberg <chip@rio.atlantic.net>
+ Files: toke.c
+
+ Title: "[PATCH] -p does not check for failure of implicit print"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v0311070aafea3fa83061@[194.51.248.75]>
+ Files: pod/perldiag.pod pod/perlrun.pod toke.c
+
+ Title: "Fix double form() in XS version check"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707150010.UAA00816@monk.mps.ohio-state.edu>
+ Files: XSUB.h
+
+ Title: "Constant-fold sprintf()"
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Files: opcode.pl
+
+ Title: "[PATCH] Fix double form() in XS version check"
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Msg-ID: <199707210518.BAA13771@nielsenmedia.com>
+ Files: XSUB.h
+
+ Title: "[PATCH] Make DEBUGGING_MSTATS info consistent"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>
+ Msg-ID: <Pine.SUN.3.96.970731131529.3740A-100000@newton.phys>
+ Files: INSTALL pod/perldelta.pod perl.h
+
+ Title: "Minor Win32 glitch with -S flag"
+ From: Warren Jones <wjones@tc.fluke.com>
+ Msg-ID: <97Jun19.150511pdt.35717-2@gateway.fluke.com>
+ Files: perl.c
+
+ Title: "Slightly safer signals"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Files: mg.c perl.c
+
+ Title: "Time::Local patch (plus perl.c and filehand.t)"
+ From: ilya@math.ohio-state.edu (Ilya Zakharevich)
+ Files: lib/Time/Local.pm perl.c t/lib/filehand.t
+
+ Title: "[PATCH] Weirdness in sv_peek()"
+ From: Stephen McCamant <alias@mcs.com>
+ Msg-ID: <m0wsEMU-000EYLC@alias-2.pr.mcs.net>,
+ <m0wsf7Y-000EYPC@alias-2.pr.mcs.net>
+ Files: sv.c
+
+ Title: "Win32 UNC path causes autoload to fail"
+ From: Warren Jones <wjones@tc.fluke.com>
+ Msg-ID: <97Jun18.163826pdt.35714-1@gateway.fluke.com>
+ Files: pp_ctl.c
+
+ Title: "[PATCH]: reduced malloc patch"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707150829.EAA01291@monk.mps.ohio-state.edu>
+ Files: av.c
+
+ Title: "[PATCH] $\1 and serious bug in evalling"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707262127.RAA12883@monk.mps.ohio-state.edu>
+ Files: pp_ctl.c
+
+ Title: "Faster int to string conversion", "[PATCH} Re: memory leak in buffer
+ safety code"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Hugo van der Sanden
+ <hv@crypt.compulink.co.uk>, Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <199707140912.KAA09935@crypt.compulink.co.uk>,
+ <199707142050.QAA20976@rio.atlantic.net>,
+ <199707182035.VAA20990@crypt.compulink.co.uk>,
+ <9707151040.AA02883@toad.ig.co.uk>
+ Files: global.sym sv.c
+
+ Title: "object never destructs"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707131955.PAA29655@aatma.engin.umich.edu>
+ Files: scope.c t/op/ref.t
+
+ Title: "[PATCH] -S flag fixes for DOSISH platforms", "[RESEND] [PATCH] -S
+ flag fixes for DOSISH platforms"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707250043.UAA02385@aatma.engin.umich.edu>,
+ <199707301828.OAA19508@aatma.engin.umich.edu>
+ Files: pod/perldiag.pod pod/perlrun.pod perl.c
+
+ Title: "Perldb internal flag rehaul"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Files: pod/perldebug.pod pod/perlvar.pod perl.h gv.c mg.c op.c perl.c
+ pp_ctl.c pp_hot.c pp_sys.c sv.c toke.c
+
+ Title: "[PATCH] Re: q and escaping paired delimiters"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Kenneth Albanowski
+ <kjahds@kjahds.com>
+ Msg-ID: <199707280516.BAA14055@aatma.engin.umich.edu>,
+ <Pine.LNX.3.93.970727172201.350K-100000@kjahds.com>,
+ <Pine.LNX.3.93.970728013540.350U-100000@kjahds.com>
+ Files: t/base/lex.t toke.c
+
+ Title: "Enable PERL_DEBUG_MSTATS without -DDEBUGGING_MSTATS"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707150829.EAA01291@monk.mps.ohio-state.edu>
+ Files: malloc.c perl.c
+
+ Title: "semctl broken under Linux"
+ From: Andreas Schwab <schwab@LS5.informatik.uni-dortmund.de>, Andreas
+ Schwab <schwab@issan.informatik.uni-dortmund.de>, Graham
+ Barr <gbarr@ti.com>, Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <33C38291.2D9302DA@ti.com>,
+ <9707040912.AA03470@issan.informatik.uni-dortmund.de>,
+ <9707041538.AA08946@toad.ig.co.uk>,
+ <9707070924.AA11774@issan.informatik.uni-dortmund.de>,
+ <9707090933.AA19012@issan.informatik.uni-dortmund.de>
+ Files: doio.c
+
+ Title: "[PATCH] m2t2: problem in NetBSD 1.2D with sfio"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Files: perl.h
+
+ Title: "fix substr fix (tests 27 etc)", "perl5.004_02 trial 1 available
+ (with substr bug and still some"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Hugo van der Sanden
+ <hv@crypt.compulink.co.uk>, Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199707301759.SAA02899@crypt.compulink.co.uk>,
+ <199707302228.BAA18032@alpha.hut.fi>,
+ <199707310929.KAA06515@crypt.compulink.co.uk>,
+ <E0wtruH-0002JM-00@ursa.cus.cam.ac.uk>
+ Files: pp.c
+
+ Title: "Fwd: substr("foo", -1000)", "substr: warn if substring doesn't
+ intersect original at all"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199707100655.JAA14924@alpha.hut.fi>,
+ <E0wm1JG-0000UY-00@taurus.cus.cam.ac.uk>
+ Files: pod/perlfunc.pod pp.c t/op/substr.t
+
+ Title: "[PATCH] work around compiler bug on CX/UX (perl5.004_01)"
+ From: tom@amber.ssd.hcsc.com (Tom Horsley)
+ Msg-ID: <9707301934.AA18594@amber.ssd.hcsc.com>
+ Files: hints/cxux.sh pp.c
+
+ ------ DOCUMENTATION ------
+
+ Title: "Duplicates in perlguts.pod"
+ From: hans@icgned.nl (Hans Mulder)
+ Msg-ID: <9707082346.AA13231@ icgned.icgned.nl >
+ Files: pod/perlguts.pod
+
+ Title: "Better "Can't locate auto/%s.al in @INC" error documentation"
+ From: ilya@math.ohio-state.edu (Ilya Zakharevich)
+ Msg-ID: <1997Jun24.195847.2091744@hmivax.humgen.upenn.edu>
+ Files: pod/perldiag.pod
+
+ Title: "new perlembed.pod:match.c"
+ From: Doug MacEachern <dougm@opengroup.org>
+ Msg-ID: <199707170355.XAA21370@postman.opengroup.org>
+ Files: pod/perlembed.pod
+
+ Title: "Document bug fix in localization of $1 etc."
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ Files: pod/perldelta.pod
+
+ Title: "[PATCH] Major goof in XS Tutorial regarding subdirs"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707260920.FAA12453@monk.mps.ohio-state.edu>
+ Files: pod/perlxstut.pod
+
+ Title: "[PATCH] Magic info in perlguts, take 2"
+ From: Stephen McCamant <alias@mcs.com>
+ Msg-ID: <m0wr6P8-000EYLC@alias-2.pr.mcs.net>
+ Files: pod/perlguts.pod
+
+ Title: "[BUG:PATCH] Missing semicolon message wrong in perldiag"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0welEn-0002vT-00@taurus.cus.cam.ac.uk>,
+ <E0wfRJU-0006Aw-00@taurus.cus.cam.ac.uk>
+ Files: pod/perldiag.pod
+
+ Title: "[PATCH] Updates to perlguts (repost)"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707152223.SAA00776@monk.mps.ohio-state.edu>
+ Files: pod/perlguts.pod
+
+ Title: "[BUG:47:LOG] Dropped "and" in pod2man"
+ From: hans@icgned.nl (Hans Mulder)
+ Msg-ID: <9707082355.AA13254@ icgned.icgned.nl >
+ Files: pod/pod2man.PL
+
+ Title: "[BUG] perlembed.pod:power.c example"
+ From: Doug MacEachern <dougm@opengroup.org>
+ Msg-ID: <199707181344.JAA10565@postman.opengroup.org>
+ Files: pod/perlembed.pod
+
+ Title: "[PATCH] arguments swapped in perlapio.pod"
+ From: Hans Mulder <hansmu@xs4all.nl>
+ Msg-ID: <199706240049.CAA10534@xs2.xs4all.nl>
+ Files: pod/perlapio.pod
+
+ Title: "[PATCH] cool quote for perldebug"
+ From: Greg Bacon <gbacon@adtrn-srv4.adtran.com>
+ Msg-ID: <199707292140.QAA28579@adtrn-srv4.adtran.com>
+ Files: pod/perldebug.pod
+
+ Title: "[PATCH] multiline commands in qx//"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707212350.TAA18496@aatma.engin.umich.edu>
+ Files: pod/perlfunc.pod pod/perlop.pod
+
+ Title: "patch to 5.004_01 perltrap.pod"
+ From: jmm@revenge.elegant.com (John Macdonald)
+ Msg-ID: <9706231525.AA22790@revenge.elegant.com>
+ Files: pod/perltrap.pod
+
+ Title: "perl4 to perl5.004 converion with debugger problem"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0wdKJY-00010w-00@taurus.cus.cam.ac.uk>
+ Files: pod/perltrap.pod
+
+ Title: "done3/perlbook.pod"
+ From: Randal Schwartz <merlyn@gadget.cscaper.com>
+ Files: pod/perlbook.pod
+
+ Title: "[PATCH] readline and readpipe are undocumented"
+ From: Hans Mulder <hansmu@xs4all.nl>
+ Files: pod/perlfunc.pod
+
+ Title: "Document use of - in a regex char class."
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03102804afd578bcef2c@[194.51.248.88]>
+ Files: pod/perlre.pod
+
+ Title: "[PATCH] splitpod broken in 5.004_01"
+ From: Hans Mulder <hansmu@xs4all.nl>, Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <199706240048.CAA10515@xs2.xs4all.nl>,
+ <9706241612.AA09119@toad.ig.co.uk>
+ Files: pod/splitpod
+
+ ------ LIBRARY AND EXTENSIONS ------
+
+ Title: "Carp::cluck() and -MCarp=verbose"
+ From: Tim.Bunce@ig.co.uk, epeschko@elmer.tci.com (Ed Peschko)
+ Msg-ID: <199708060607.AAA16681@den-mdev1.tci.com>,
+ <199708062105.PAA09878@den-mdev1.tci.com>
+ Files: lib/Carp.pm
+
+ Title: "Warning from calls using "use Shell""
+ From: Andrew Pimlott <pimlott@abel.math.harvard.edu>
+ Msg-ID: <Pine.SOL.3.91.970806173903.7320H-100000@abel>
+ Files: lib/Shell.pm
+
+ Title: "confessing a carp"
+ From: Chip Salzenberg <chip@rio.atlantic.net>, Hugo van der Sanden
+ <hv@crypt.compulink.co.uk>, Nick Ing-Simmons
+ <nick@ni-s.u-net.com>, Tim Bunce <Tim.Bunce@ig.co.uk>
+ Msg-ID: <199708052155.WAA25393@crypt.compulink.co.uk>,
+ <199708060721.IAA30894@crypt.compulink.co.uk>,
+ <199708061533.LAA01313@rio.atlantic.net>,
+ <33E79BE2.4E6F@ni-s.u-net.com>,
+ <33E8E3C5.62C@ni-s.u-net.com>,
+ <9708051619.AA13764@toad.ig.co.uk>
+ Files: lib/Carp.pm
+
+ Title: "[BUG:PATCH] dumpvar.pl parses some references incorrectly"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0wwAjQ-0004l6-00@ursa.cus.cam.ac.uk>
+ Files: lib/dumpvar.pl
+
+ Title: "[PATCH] m2t3: minor doc patch (to obsolete I18N::Collate)"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199708060732.KAA02675@alpha.hut.fi>
+ Files: lib/I18N/Collate.pm
+
+ Title: "[PATCH] Binary installers for Perl modules"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707210006.UAA06165@monk.mps.ohio-state.edu>
+ Files: lib/ExtUtils/Install.pm
+
+ Title: "m2t2 broke CPAN.pm :-("
+ From: a.koenig@kulturbox.de (Andreas J. Koenig)
+ Files: lib/CPAN.pm lib/Bundle/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm
+
+ Title: "[PATCH] CPAN.pm on OS/2"
+ From: "Andreas J. Koenig" <k@anna.in-berlin.de>, Ilya Zakharevich
+ <ilya@math.ohio-state.edu>
+ Msg-ID: <199707180415.AAA03180@monk.mps.ohio-state.edu>,
+ <199707181407.QAA12920@anna.in-berlin.de>
+ Files: lib/CPAN.pm
+
+ Title: "Docs of IO::Handle [PATCH]"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707222307.TAA08380@monk.mps.ohio-state.edu>
+ Files: ext/IO/lib/IO/Handle.pm
+
+ Title: "Exporter errors give wrong location"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0wdJra-0000n8-00@taurus.cus.cam.ac.uk>
+ Files: lib/Exporter.pm
+
+ Title: "[PATCH] Exporter new export_to_level method"
+ From: epeschko@elmer.tci.com (Ed Peschko)
+ Files: lib/Exporter.pm
+
+ Title: "DB_File produces spurious output when trapping __DIE__"
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9706302125.AA28254@claudius.bfsec.bt.co.uk>
+ Files: ext/DB_File/DB_File.pm
+
+ Title: "Remove 'use UNIVERSAL;', switch to UNIVERSAL::isa()"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>
+ Msg-ID: <E0whaZJ-0007BA-00@ursa.cus.cam.ac.uk>
+ Files: lib/Class/Struct.pm lib/File/Compare.pm lib/File/Copy.pm
+
+ Title: "perl5.004 Time::Local still broken"
+ From: Mathias Koerber <mathias@dnssec1.singnet.com.sg>
+ Msg-ID: <199706260452.MAA22647@dnssec1.singnet.com.sg>
+ Files: lib/Time/Local.pm
+
+ Title: "Sys::Hostname should localize $SIG{__DIE__}"
+ From: Ken Shan <ken@digitas.harvard.edu>
+ Msg-ID: <199707070357.XAA18065@digitas.harvard.edu>
+ Files: lib/Sys/Hostname.pm
+
+ Title: "xsubpp patch"
+ From: John Tobey <jtobey@user1.channel1.com>
+ Msg-ID: <199707010221.CAA01234@remote133>
+ Files: lib/ExtUtils/xsubpp
+
+ Title: "DB_File 1.15 patch"
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9707192117.AA01973@claudius.bfsec.bt.co.uk>
+ Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs ext/DB_File/typemap
+ t/lib/db-btree.t t/lib/db-hash.t t/lib/db-recno.t
+
+ Title: "Problems with setvbuf"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707250040.UAA11000@monk.mps.ohio-state.edu>
+ Files: ext/IO/IO.xs
+
+ Title: "[PATCH] Repost of fork() debugger patch"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707252101.RAA11846@monk.mps.ohio-state.edu>
+ Files: lib/perl5db.pl lib/Term/ReadLine.pm
+
+ Title: "IO::File and DB_File pollutes namespace with Fcntl constants"
+ From: Gisle Aas <aas@bergen.sn.no>
+ Msg-ID: <h205qyijy.fsf@bergen.sn.no>
+ Files: ext/IO/lib/IO/File.pm
+
+ Title: "[MM] [PATCH] Re: Liblist problems for MSWin32"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199706182152.RAA20273@aatma.engin.umich.edu>
+ Files: lib/ExtUtils/Liblist.pm
+
+ Title: "Net::hostent documentation error"
+ From: gnat@frii.com
+ Msg-ID: <199707082222.QAA24728@elara.frii.com>
+ Files: lib/Net/hostent.pm
+
+ Title: "PATCH: make DBM*_File modules sub-classable"
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <9707121854.AA19472@claudius.bfsec.bt.co.uk>
+ Files: ext/GDBM_File/typemap ext/NDBM_File/typemap
+ ext/ODBM_File/ODBM_File.xs ext/SDBM_File/typemap
+ t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t
+
+ Title: "Sys::Syslog patch to allow unix domain sockets"
+ From: Sean Robinson <robinson_s@sc.maricopa.edu>
+ Msg-ID: <33B31342.7EB16A44@sc.maricopa.edu>
+ Files: lib/Sys/Syslog.pm
+
+ Title: "'use UNIVERSAL;' deprecated, do C<UNIVERSAL::isa()> instead",
+ "UNIVERSAL.pm and import methods"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Gisle Aas <aas@bergen.sn.no>,
+ Graham Barr <gbarr@ti.com>, Gurusamy Sarathy
+ <gsar@engin.umich.edu>, Hugo van der Sanden
+ <hv@crypt.compulink.co.uk>
+ Msg-ID: <199706271701.NAA25664@aatma.engin.umich.edu>,
+ <199706271904.UAA00120@crypt.compulink.co.uk>,
+ <199706272054.QAA28913@aatma.engin.umich.edu>,
+ <199706301554.LAA03763@aatma.engin.umich.edu>,
+ <33B22248.7D7C1985@ti.com>,
+ <E0wf5TN-0006ps-00@taurus.cus.cam.ac.uk>,
+ <E0wguTR-0005bs-00@ursa.cus.cam.ac.uk>,
+ <E0whaZJ-0007BA-00@ursa.cus.cam.ac.uk>,
+ <E0whfHh-0007bW-00@ursa.cus.cam.ac.uk>,
+ <E0wiyUG-00073j-00@taurus.cus.cam.ac.uk>,
+ <hiuyv6q9k.fsf@bergen.sn.no>
+ Files: lib/Class/Struct.pm lib/File/Compare.pm lib/File/Copy.pm
+ t/op/universal.t universal.c
+
+ Title: "[MM] Small patch to MakeMaker, new release"
+ From: "Andreas J. Koenig" <k@anna.in-berlin.de>
+ Msg-ID: <199706281603.SAA10869@anna.in-berlin.de>
+ Files: lib/ExtUtils/Command.pm lib/ExtUtils/Install.pm
+ lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Unix.pm
+ lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm
+
+ Title: "ExtUtils-Embed upgrade"
+ From: Doug MacEachern <dougm@opengroup.org>
+ Files: lib/ExtUtils/Embed.pm
+
+ Title: "[PATCH] icmp tweak for IO::Socket"
+ From: Nick.Ing-Simmons@tiuk.ti.com
+ Msg-ID: <199707041240.NAA21484@pluto.tiuk.ti.com>
+ Files: ext/IO/lib/IO/Socket.pm
+
+ Title: "Allow concurrent mkdir in File::Path::mkpath"
+ From: schattev@imb-jena.de (Ruben Schattevoy)
+ Msg-ID: <199707300943.LAA21574@kant.imb-jena.de>
+ Files: lib/File/Path.pm
+
+ Title: "CPAN.pm, $VERSION and nested (bundled) modules."
+ From: a.koenig@kulturbox.de (Andreas J. Koenig)
+ Files: lib/ExtUtils/Install.pm lib/ExtUtils/Liblist.pm
+ lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm
+ lib/ExtUtils/Mksymlists.pm
+
+ Title: "[PATCH] perl debugger, win32, and emacs"
+ From: Jay Rogers <jay@rgrs.com>
+ Msg-ID: <199707311759.NAA13276@crooked-i.mitre.org>
+ Files: lib/perl5db.pl
+
+ Title: "[PATCH] pod2html mangles C<&foo(42);>"
+ From: Hans Mulder <hansmu@xs4all.nl>
+ Msg-ID: <199706250057.CAA10162@xs1.xs4all.nl>
+ Files: lib/Pod/Html.pm
+
+ Title: "[PATCH] posix.xs broken on VMS 7.1"
+ From: Dan Sugalski <sugalsd@lbcc.cc.or.us>
+ Msg-ID: <3.0.2.32.19970718095755.00875ba0@stargate.lbcc.cc.or.us>
+ Files: ext/POSIX/POSIX.xs
+
+ Title: "MM_Unix.pm nits for Win32 DMAKE"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199708032051.QAA14248@aatma.engin.umich.edu>
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "Sys::Hostname -w unclean in trial 2"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199708032055.QAA14278@aatma.engin.umich.edu>
+ Files: lib/Sys/Hostname.pm
+
+ Title: "(3) File::Find::find()/finddepth() bugs with toplevel paths"
+ From: "Conrad E. Kimball" <cek@tblv021.ca.boeing.com>
+ Msg-ID: <199707040045.RAA24459@mailgate2.boeing.com>
+ Files: lib/File/Find.pm
+
+ ------ OTHER CHANGES ------
+
+ Title: "EMERGENCY_SBRK or PERL_EMERGENCY_SBRK ?"
+ From: Andy Dougherty <doughera@newton.phys.lafayette.edu>,
+ ilya@math.ohio-state.edu (Ilya Zakharevich)
+ Msg-ID: <1997Aug1.191631.2167470@hmivax.humgen.upenn.edu>,
+ <Pine.SUN.3.96.970801134400.4393F-100000@newton.phys>
+ Files:
+ Files:
+
+ ------ PORTABILITY - WIN32 ------
+
+ Title: "[PATCH] Embedding threaded apps in perl.dll"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707261518.LAA24346@aatma.engin.umich.edu>,
+ <199707301833.OAA19570@aatma.engin.umich.edu>
+ Files: win32/win32.c
+
+ Title: "Minor fix for pl2bat.bat", "[PATCH] Re: Minor fix for pl2bat.bat"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Warren Jones
+ <wjones@tc.fluke.com>
+ Msg-ID: <199707061843.OAA23874@aatma.engin.umich.edu>,
+ <97Jun24.115804pdt.35752-2@gateway.fluke.com>
+ Files: win32/bin/pl2bat.bat
+
+ Title: "WIN32 Build - pod2xxx.bat Missing?", "[PATCH] Re: WIN32 Build -
+ pod2xxx.bat Missing?"
+ From: Chris Williams <chrisw@netinfo.com.au>, Gurusamy Sarathy
+ <gsar@engin.umich.edu>
+ Msg-ID: <199707011423.KAA15855@aatma.engin.umich.edu>,
+ <33B8B962.D96FA1F5@netinfo.com.au>
+ Files: win32/Makefile win32/makefile.mk
+
+ Title: "[PATCH] Win32 sitelib intuition from DLL location"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199706231647.MAA23260@aatma.engin.umich.edu>
+ Files: win32/win32.h win32/config_h.PL win32/win32.c
+
+ Title: "[PATCH] binary coexistence on win32", "[RESEND] [PATCH] binary
+ coexistence on win32"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707250109.VAA02666@aatma.engin.umich.edu>,
+ <199707301829.OAA19516@aatma.engin.umich.edu>
+ Files: lib/ExtUtils/Mksymlists.pm win32/win32.h win32/win32io.h
+ win32/win32iop.h win32/makedef.pl win32/win32.c
+ win32/win32io.c
+
+ Title: "[PATCH] docs for win32 utilities"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707250045.UAA02510@aatma.engin.umich.edu>
+ Files: win32/bin/pl2bat.bat win32/bin/runperl.bat
+
+ Title: "[PATCH] exec() fixed on win32"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199706241525.LAA06554@aatma.engin.umich.edu>
+ Files: win32/win32.h win32/win32io.h win32/win32iop.h README.win32 doio.c
+ win32/config_H.bc win32/config_H.vc win32/makedef.pl
+ win32/win32.c win32/win32io.c
+
+ Title: "[PATCH] getenv() after my_setenv() gets old entry on Win32"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199706231700.NAA23400@aatma.engin.umich.edu>
+ Files: win32/win32.h win32/win32.c
+
+ Title: "[PATCH] getservby*() calls fail on Windows NT"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199706231654.MAA23276@aatma.engin.umich.edu>
+ Files: win32/win32sck.c
+
+ Title: "[PATCH] minor win32 scribbles"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Hugo van der Sanden
+ <hv@crypt.compulink.co.uk>
+ Msg-ID: <199707262307.TAA28410@aatma.engin.umich.edu>,
+ <199707270832.JAA19399@crypt.compulink.co.uk>
+ Files: pod/perldelta.pod README.win32 win32/Makefile win32/config.bc
+ win32/config.vc win32/makefile.mk
+
+ Title: "[PATCH] trial2: some batch files won't run"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199708040226.WAA17301@aatma.engin.umich.edu>
+ Files: win32/bin/pl2bat.bat win32/bin/runperl.bat
+
+ Title: "[PATCH] win32 docs and runperl.bat"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707070446.AAA29560@aatma.engin.umich.edu>
+ Files: MANIFEST README.win32 win32/bin/pl2bat.bat win32/bin/runperl.bat
+
+ Title: "[PATCH] win32 extras and embedding"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707250232.WAA03421@aatma.engin.umich.edu>,
+ <199707301831.OAA19528@aatma.engin.umich.edu>
+ Files: dosish.h win32/win32.h perl.c win32/config.bc win32/config_H.bc
+ win32/makedef.pl win32/perllib.c win32/win32.c
+
+ Title: "[PATCH] win32 tweaks"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707042150.RAA01065@aatma.engin.umich.edu>
+ Files: win32/win32.h win32/win32.c
+
+ Title: "[PATCH] win32_stat() fixes (2nd try)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199708040137.VAA16810@aatma.engin.umich.edu>
+ Files: t/op/stat.t win32/win32iop.h win32/win32.c
+
+ ------ PORTABILITY - OTHER ------
+
+ Title: "Additional OS/2 patches"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Ilya Zakharevich
+ <ilya@math.ohio-state.edu>
+ Msg-ID: <199708020823.EAA19521@monk.mps.ohio-state.edu>,
+ <199708021424.KAA28561@aatma.engin.umich.edu>,
+ <199708042108.RAA27671@aatma.engin.umich.edu>
+ Files: README.os2 os2/Changes perl.c
+
+ Title: "Additional patch is needed for os2/diff.configure"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199708020745.DAA19483@monk.mps.ohio-state.edu>
+ Files: os2/diff.configure
+
+ Title: "Assorted OS/2 fixes"
+ From: ilya@math.ohio-state.edu (Ilya Zakharevich)
+ Msg-ID: <1997Jun16.163234.2091727@hmivax.humgen.upenn.edu>
+ Files: hints/os2.sh os2/diff.configure os2/os2ish.h README.os2 os2/Changes
+ os2/Makefile.SHs os2/os2.c util.c
+
+ Title: "[PATCH] Changes for VMS 7.1 support"
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>, Dan Sugalski
+ <sugalsd@lbcc.cc.or.us>
+ Msg-ID: <01ILDXUH0J1W00026U@hmivax.humgen.upenn.edu>,
+ <3.0.2.32.19970718095935.0087a2d0@stargate.lbcc.cc.or.us>
+ Files: vms/sockadapt.h vms/config.vms vms/sockadapt.c
+
+ Title: "[PATCH] Easier TCP stack selection for VMS"
+ From: Dan Sugalski <sugalsd@lbcc.cc.or.us>
+ Msg-ID: <3.0.1.32.19970624151939.00994490@stargate.lbcc.cc.or.us>
+ Files: vms/descrip.mms
+
+ Title: "Minor VMS patches"
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Msg-ID: <01ILCUO6XXTE000WFK@hmivax.humgen.upenn.edu>
+ Files: lib/ExtUtils/MM_VMS.pm vms/vmsish.h vms/descrip.mms vms/test.com
+ vms/vms.c vms/ext/filespec.t
+
+ Title: "[PATCH] Two un-disabled tests for VMS"
+ From: Dan Sugalski <sugalsd@lbcc.cc.or.us>
+ Msg-ID: <3.0.2.32.19970718095842.00879220@stargate.lbcc.cc.or.us>
+ Files: vms/test.com
+
+ Title: "fixes for hints/svr4 for UnixWare >= 2.1.1"
+ From: John Hughes <john@titanic.atlantech.com>
+ Msg-ID: <199707021230.OAA24230@titanic.AtlanTech.COM>
+ Files: hints/svr4.sh
+
+ Title: "make depend loop fix and minor OS/2 improvements to build process"
+ From: ilya@math.ohio-state.edu (Ilya Zakharevich)
+ Files: Makefile.SH hints/os2.sh os2/Makefile.SHs
+
+ ------ TESTS ------
+
+ Title: "Add xor tests to test suite"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199706250730.IAA06097@crypt.compulink.co.uk>
+ Files: t/comp/cmdopt.t
+
+ Title: "[PATCH] enable some tests on Win32"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199707250029.UAA02351@aatma.engin.umich.edu>
+ Files: t/op/magic.t
+
+ Title: "Fix up problems with *DBM tests"
+ From: Paul Marquess <pmarquess@bfsec.bt.co.uk>
+ Files: t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t
+
+ ------ UTILITIES ------
+
+ Title: "[PATCH] m2t3: utils/perlbug.PL: -ok report is not a bug"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Msg-ID: <199708071022.NAA13008@alpha.hut.fi>
+ Files: utils/perlbug.PL
+
+ Title: "perlbug - check sendmail and fix win32 tmp path"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199708060349.XAA15895@aatma.engin.umich.edu>
+ Files: utils/perlbug.PL
+
+ Title: "OK: perl <some_version> on <some_system> (corrected)", "enhancements
+ to perlbug -ok"
+ From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>, Stephen McCamant <alias@mcs.com>
+ Msg-ID: <E0wukVt-0006Da-00@ursa.cus.cam.ac.uk>,
+ <E0wvMQl-00055y-00@ursa.cus.cam.ac.uk>,
+ <m0wv81x-000EYPC@alias-2.pr.mcs.net>
+ Files: utils/Makefile utils/perlbug.PL
+
+ Title: "perlbug -ok [PATCH]"
+ From: "Charles F. Randall" <crandall@free.click-n-call.com>
+ Msg-ID: <199706181824.MAA04082@free.click-n-call.com>
+ Files: utils/perlbug.PL
+
+ Title: "perlbug broken"
+ From: Andreas Schwab <schwab@issan.informatik.uni-dortmund.de>
+ Msg-ID: <9707040912.AA03466@issan.informatik.uni-dortmund.de>
+ Files: utils/perlbug.PL
+
+ Title: "[PATCH] perlbug under OS/2"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707180333.XAA03102@monk.mps.ohio-state.edu>
+ Files: utils/perlbug.PL
+
+ Title: "perldoc doesn't grok Win32 UNC paths"
+ From: Warren Jones <wjones@tc.fluke.com>
+ Msg-ID: <97Jun17.184420pdt.35728-1@gateway.fluke.com>,
+ <97Jun18.165618pdt.35713-1@gateway.fluke.com>
+ Files: utils/perldoc.PL
+
+ Title: "[PATCH] perldoc under OS/2"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199707180340.XAA03114@monk.mps.ohio-state.edu>
+ Files: utils/perldoc.PL
+
+ Title: "h2ph corrections to avoid redefined sub warnings"
+ From: wdconsta <wdconsta@cs.adelaide.edu.au>
+ Msg-ID: <Pine.SV4.3.93.970708143446.23808A-100000@florence.teaching.cs.adelaide.edu.au>
+ Files: utils/h2ph.PL
+
+
+
+----------------
+Version 5.004_01 Maintenance release 1 for 5.004
+----------------
+
+"Practice random kindness and senseless acts of beauty"
+ -- Anne Herbert
+
+ HEADLINES FOR THIS MAINTENANCE RELEASE
+
+ (..., undef, ...) = split(...) bug fixed.
+ Win32 support greatly improved, now very strong.
+ Memory leak using Tied hashes and arrays fixed.
+ Documentation updates.
+ Many other bug fixes and enhancements.
+
+ CORE LANGUAGE
+
+ Title: "[PATCH] first true value returned by scalar C<...> is wrong"
+ From: hansm@euronet.nl
+ Files: pp_ctl.c t/op/flip.t
+
+ Title: "Regex Bug in 5.003_26 thru 003_99a"
+ From: Andreas Karrer <karrer@ife.ee.ethz.ch>, Chip Salzenberg
+ <chip@atlantic.net>
+ Msg-ID: <199705152303.BAA08890@kuru.ee.ethz.ch>,
+ <199705161915.PAA18721@rio.atlantic.net>
+ Files: regcomp.h regcomp.c regexec.c
+
+ Title: "[PATCH] -w interacts badly with -Dt"
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+ Files: sv.c
+
+ Title: "No DESTROY on untie. Tie memory leak fixed."
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, Jay Rogers <jay@rgrs.com>,
+ pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Msg-ID: <199705170235.WAA00267@fluffy.rgrs.com>,
+ <199705172156.RAA20561@aatma.engin.umich.edu>,
+ <9705171506.AA04491@claudius.bfsec.bt.co.uk>
+ Files: pp_hot.c
+
+ Title: "magic_clear_all_env proto should match svt_clear"
+ From: Nick Ing-Simmons <nik@tiuk.ti.com>
+ Files: proto.h mg.c
+
+ Title: "[PATCH] ENV leaks on win32 (was Re: Comments on ENV patch sought)",
+ "[PATCH] for NETaa13787: %ENV=(); doesn't clear the environment"
+ From: hansm@euronet.nl, pvhp@forte.com (Peter Prymmer)
+ Msg-ID: <199705292240.AAA01135@mail.euronet.nl>
+ Files: embed.h perl.h proto.h global.sym mg.c t/op/magic.t
+
+ Title: "Patch to show @INC when require dies"
+ From: avera@hal.com (Jim Avera)
+ Msg-ID: <9705230121.AA27872@membrane.hal.com>
+ Files: pp_ctl.c
+
+ Title: "[PATCH] bug with m// nested inside s///e"
+ From: hansm@euro.net
+ Files: op.c t/op/subst.t
+
+ DOCUMENTATION
+
+ Title: "[PATCH] perlembed Win32 update"
+ From: Doug MacEachern <dougm@opengroup.org>
+ Files: pod/perlembed.pod
+
+ Title: "perldiag.pod patch - "(W) substr outside string" is "(S)evere" if
+ used as lvalue."
+ From: John Hughes <john@AtlanTech.COM>
+ Files: pod/perldiag.pod
+
+ Title: "local(%ENV) looses magic - document behaviour"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: pod/perlsub.pod
+
+ Title: "[PATCH] perlguts caveats", "perlguts additions"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>, ilya@math.ohio-state.edu
+ (Ilya Zakharevich)
+ Msg-ID: <199705180052.UAA22066@aatma.engin.umich.edu>,
+ <199705180202.WAA22826@aatma.engin.umich.edu>,
+ <199705301341.JAA05204@aatma.engin.umich.edu>,
+ <1997May17.235722.2033087@hmivax.humgen.upenn.edu>
+ Files: pod/perlguts.pod
+
+ Title: "pod2man produces broken pages", "weird condition in perldelta breaks
+ nroff"
+ From: Davin Milun <milun@cs.Buffalo.EDU>, Hans Mulder <hansm@icgned.nl>
+ Msg-ID: <199705310447.AAA15721@obelix.cs.Buffalo.EDU>,
+ <1997May25.192350.2055977@hmivax.humgen.upenn.edu>
+ Files: pod/pod2man.PL
+
+ Title: "Perl 5 pod2man fix", "perlguts man page corrupted"
+ From: chen@adi.com (Franklin Chen), gnat@frii.com, lvirden@cas.org, tom
+ (Tom Dinger on Feste), tom@edc.com (Tom Dinger on Feste)
+ Msg-ID: <199705210013.UAA09599@menhaden.adi.com>,
+ <199706011305.JAA18271@cas.org>,
+ <199706012116.PAA14102@elara.frii.com>,
+ <9504250959.AA23419@feste.edc.com>,
+ <9504251700.AA23823@feste.edc.com>
+ Files: pod/pod2man.PL
+
+ Title: "[PATCH] reference form chomp to chop in perlfunc"
+ From: hansm@euronet.nl
+ Files: pod/perlfunc.pod
+
+ Title: "pod2man gags if "=pod" is before "=head1 NAME""
+ From: whyde@pezz.sps.mot.com (Warren Hyde)
+ Msg-ID: <9705212115.AA21730@pezz.sps.mot.com>
+ Files: pod/pod2man.PL
+
+ Title: "perlfunc.pod unclear about return value range of rand"
+ From: "Tuomas J. Lukka" <tjl@lukka.student.harvard.edu>
+ Msg-ID: <m0wSMiC-000C9xC@lukka.student.harvard.edu>
+ Files: pod/perlfunc.pod
+
+ Title: "Error in perllol manpage", "Error in perllol manpage (fwd)"
+ From: Chris Wick <cwick@lmc.com>
+ Files: pod/perllol.pod
+
+ Title: "5.004 removed deprecated %OVERLOAD support silently"
+ From: jon@sems.com (Jonathan Biggar)
+ Msg-ID: <199705232319.QAA28388@clamp.netlabs.com>
+ Files: pod/perldelta.pod
+
+ Title: "[PATCH] Documentation bugs"
+ From: Stephen Potter <spp@psa.pencom.com>
+ Files: pod/perldata.pod pod/perldiag.pod pod/perlfaq8.pod pod/perlfaq9.pod
+ pod/perlop.pod pod/perlsub.pod pod/perltoot.pod
+
+ Title: "5.004 POD stuff", "make html - any takers?", "make html --> unusable
+ xref links", "pod/*.html -- all hyperlinks are invalid"
+ From: "Darren/Torin/Who Ever..." <torin@daft.com>, "Paul D. Smith"
+ <psmith@BayNetworks.COM>, Gurusamy Sarathy
+ <gsar@engin.umich.edu>, Jarkko Hietaniemi <jhi@iki.fi>,
+ Michael R Cook <mcook@cognex.com>, avera@hal.com (Jim
+ Avera), lvirden@cas.org
+ Msg-ID: <199705162008.XAA06906@alpha.hut.fi>,
+ <199705171830.OAA15652@erawan.cognex.com>,
+ <199706081749.NAA04552@aatma.engin.umich.edu>,
+ <1997May16.191039.2033079@hmivax.humgen.upenn.edu>,
+ <87hgg2y1h4.fsf@perv.daft.com>,
+ <9705161931.AA01075@membrane.hal.com>,
+ <9705191839.AA28702@lemming.engeast>
+ Files: INSTALL pod/perldiag.pod installhtml
+
+ Title: "checkpods- forget blank line status when starting a new file"
+ From: Larry Parmelee <parmelee@CS.Cornell.EDU>
+ Files: pod/checkpods.PL
+
+ Title: "installhtml: Fix 'no title' & 'unexpected ...' warnings. Double speed."
+ From: Tim Bunce
+ Files: installhtml lib/Pod/Html.pm pod/splitpod
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "sdbm can fail if a config.h exists in system directories"
+ From: Tim Bunce
+ Files: ext/SDBM_File/sdbm/Makefile.PL
+
+ Title: "LWP and SIG __DIE__ traps not playing well together!"
+ From: Gisle Aas <aas@bergen.sn.no>
+ Files: lib/AutoLoader.pm
+
+ Title: "Memory Consumption of autosplit_lib_modules/sv_gets (workaround)"
+ From: Matthias Neeracher <neeri@iis.ee.ethz.ch>
+ Files: lib/AutoSplit.pm
+
+ Title: "Comments of this Sys::Syslog patch", "Unusual Sys::Syslog behaviour
+ with FQDN ? [Even in 5.004 - a bug?]"
+ From: Jarkko Hietaniemi <jhi@iki.fi>, Russ Allbery <rra@stanford.edu>,
+ alansz@mellers1.psych.berkeley.edu (Alan Schwartz)
+ Msg-ID: <199705231621.TAA16790@alpha.hut.fi>, <5m4fjr$rhs@agate.berkeley.edu>
+ Files: lib/Sys/Syslog.pm
+
+ Title: "Patch to CPAN.pm (perl5.004) for ncftp"
+ From: "Richard L. Maus, Jr." <rmaus@monmouth.com>
+ Msg-ID: <337FBAC8.167EB0E7@monmouth.com>
+ Files: lib/CPAN.pm
+
+ Title: "[PATCH] Harness.pm bug w/perl5.004 & VMS"
+ From: Dan Sugalski <sugalsd@lbcc.cc.or.us>
+ Msg-ID: <3.0.1.32.19970530102300.008a2730@stargate.lbcc.cc.or.us>
+ Files: lib/Test/Harness.pm
+
+ Title: "more Fcntl constants [PATCH]"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Files: ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs
+
+ Title: "5.004 breaks ftp.pl due to missing (although obsolete) chat2.pl"
+ From: Tim Bunce
+ Files: lib/chat2.pl
+
+ BUILD PROCESS
+
+ Title: "make test && ... doesn't work"
+ From: Tim Bunce
+ Files: Makefile.SH
+
+ Title: "[PATCH] INSTALL-1.18"
+ From: Andy Dougherty <doughera@fractal.phys.lafayette.edu>
+ Msg-ID: <Pine.SOL.3.95q.970529142739.662D-100000@fractal.lafayette.edu>
+ Files: INSTALL
+
+ Title: "improved gnuwin32 Configure support"
+ From: Chris Faylor <cgf@bbc.com>
+ Msg-ID: <199706070318.XAA09214@hardy.bbc.com>
+ Files: Configure
+
+ Title: "installhtml problems finding splitpod"
+ From: lvirden@cas.org
+ Files: installhtml INSTALL
+
+ Title: "perl 5.004 (and 01) man pages not generated and installed"
+ From: lvirden@cas.org (Larry W. Virden)
+ Files: installman
+
+ Title: "oddity in Configure"
+ From: Mike Stok <mike@stok.co.uk>
+ Files: Configure
+
+ Title: "perl5.004 on AIX: Patches", "perl5.004 on FreeBSD and AIX"
+ From: Peter van Heusden <pvh@junior.uwc.ac.za>
+ Msg-ID: <Pine.A32.3.93.970519142625.22442B-100000@junior.uwc.ac.za>,
+ <Pine.A32.3.93.970519163700.25188A-100000@junior.uwc.ac.za>
+ Files: Makefile.SH perl_exp.SH ext/DynaLoader/dl_aix.xs perlio.sym
+
+ Title: "Compiling perl5.004 on NEWS-OS 4.x"
+ From: Makoto MATSUSHITA (=?ISO-2022-JP?B?GyRCJF4kRCQ3JD8kXiQzJEgbKEI=?=)
+ <matusita@ics.es.osaka-u.ac.jp>
+ Msg-ID: <19970521132814F.matusita@ics.es.osaka-u.ac.jp>
+ Files: Configure hints/newsos4.sh
+
+ PORTABILITY
+
+ Title: "win32: additional default libraries"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199705291332.JAA21560@aatma.engin.umich.edu>
+ Files: lib/ExtUtils/MM_Win32.pm
+
+ Title: "[PATCH] win32 minor fixes"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_Win32.pm win32/config.bc
+
+ Title: "[PATCH] clean up perlocal.pod output on VMS"
+ From: pvhp@forte.com (Peter Prymmer)
+ Files: lib/ExtUtils/MM_VMS.pm
+
+ Title: "[PATCH] Re: Term::ReadKey on Win32: set console"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: lib/Term/ReadLine.pm
+
+ Title: "[PATCH] Pod::Text nit for Win32"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: lib/Pod/Text.pm
+
+ Title: "pathname bug in xsubpp on win32"
+ From: jon@sems.com (Jonathan Biggar)
+ Msg-ID: <199705230126.SAA23401@clamp.netlabs.com>
+ Files: lib/ExtUtils/xsubpp
+
+ Title: "MakeMaker stumbles on Win32 UNC paths"
+ From: Warren Jones <wjones@TC.FLUKE.COM>
+ Files: lib/ExtUtils/MM_Win32.pm
+
+ Title: "build problem on SGI R10000 PowerChallenge (IRIX 6.2) lseek proto"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Files: doio.c
+
+ Title: "Perl 5.004 + Linux 2.0.30 & semctl()"
+ From: Andy Dougherty <doughera@fractal.phys.lafayette.edu>, Jordan
+ Mendelson <jordy@snappy.wserv.com>
+ Files: doio.c
+
+ Title: "lib/io_udp.t fails on VMS"
+ From: Jonathan.Hudson@jrhudson.demon.co.uk
+ Msg-ID: <XFMail.970522181042.Jonathan.Hudson@jrhudson.demon.co.uk>
+ Files: pp_sys.c
+
+ Title: "Compilation of mg.c from perl5.004m1t2 fails on OpenVMS/AXP"
+ From: Henrik Tougaard <ht.000@foa.dk>
+ Files: mg.c t/op/taint.t
+
+ Title: "[PATCH] (NEXT|OPEN)STEP hints"
+ From: Gerd Knops <gerti@BITart.com>
+ Files: hints/next_3.sh hints/next_4.sh
+
+ Title: "win32: user defined shell"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199705291339.JAA21682@aatma.engin.umich.edu>
+ Files: pod/perlrun.pod win32/win32.c
+
+ Title: "misc perl5.004 doc fixes, especially vms"
+ From: lvirden@cas.org (Larry W. Virden)
+ Msg-ID: <199705160419.AAA16317@cas.org>
+ Files: pod/perlfaq4.pod vms/perlvms.pod lib/Pod/Html.pm pod/roffitall
+ vms/ext/DCLsym/DCLsym.pm vms/ext/Stdio/Stdio.pm
+
+ Title: "[PATCH] gen_shrfls.pl too picky for Dec C 5.6 preprocessor output"
+ From: Dan Sugalski <sugalsd@lbcc.cc.or.us>
+ Files: vms/gen_shrfls.pl
+
+ Title: "[PATCH] win32: Configure cf_email"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199705301335.JAA05079@aatma.engin.umich.edu>
+ Files: win32/Makefile win32/config.bc win32/config.vc win32/config_sh.PL
+ win32/makefile.mk
+
+ Title: "[PATCH] README.win32 nits"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: README.win32
+
+ Title: "Document cause and remedy for op/taint.t failure"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: README.win32
+
+ Title: "SVR4 hints for DDE SMES Supermax Enterprise Server"
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Files: hints/svr4.sh
+
+ Title: "porting.help"
+ From: Tim Bunce
+ Files: Porting/pumpkin.pod Porting/preprel
+
+ Title: "Major 5.004 Win32 update (Borland win32 support, and other patches)",
+ "($a,undef,$b) = qw(a b c) and ties delaying DESTROY fixes"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: MANIFEST pod/perlguts.pod win32/include/sys/socket.h EXTERN.h
+ opcode.h perl.h regcomp.h ext/Fcntl/Fcntl.pm
+ ext/SDBM_File/Makefile.PL lib/ExtUtils/Install.pm
+ lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_Win32.pm
+ lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm
+ lib/File/DosGlob.pm t/op/mkdir.t t/op/stat.t win32/win32.h
+ win32/win32io.h win32/win32iop.h README.win32 doio.c gv.c
+ mg.c op.c perlio.c pp.c pp_ctl.c pp_hot.c pp_sys.c util.c
+ win32/Makefile win32/config.bc win32/config.vc
+ win32/config_H.bc win32/config_H.vc win32/makedef.pl
+ win32/makefile.mk win32/makeperldef.pl win32/perlglob.c
+ win32/perllib.c win32/win32.c win32/win32io.c
+ win32/win32sck.c
+
+ Title: "[PATCH] Re: Maintenance release (remove PERL_DUMMY_SIZE)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: opcode.h perl.h regcomp.h win32/win32.h gv.c
+
+ Title: "[PATCH] ENV leaks on win32 (was Re: Comments on ENV patch sought)"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: win32/win32.h win32/win32io.h win32/win32iop.h global.sym mg.c perl.c
+ t/op/magic.t util.c win32/makedef.pl win32/win32.c
+ win32/win32io.c
+
+ Title: "[PATCH] win32: ExtUtils::Liblist support"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: lib/ExtUtils/Liblist.pm win32/Makefile win32/config.bc
+ win32/makefile.mk
+
+ Title: "[PATCH] Re: borland C++Perl embedding failures re __declspec()"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: win32/win32.c
+
+ Title: "No need to use `pwd` in t/op/magic.t test for amigaos"
+ From: Norbert Pueschel <pueschel@imsdd.meb.uni-bonn.de>
+ Files: t/op/magic.t
+
+ TESTS
+
+ Title: "Tests depend on locale"
+ From: "Jan D." <jan.djarv@mbox200.swipnet.se>, Jarkko Hietaniemi
+ <jhi@iki.fi>
+ Msg-ID: <199705191127.NAA08148@ostrich.gaia.swipnet.se>,
+ <199705191230.PAA21070@alpha.hut.fi>
+ Files: t/lib/safe2.t t/op/mkdir.t
+
+ Title: "op/groups test fails on Linux (groups in /bin)"
+ From: "Jan D." <jan.djarv@mbox200.swipnet.se>
+ Msg-ID: <199705191120.NAA08130@ostrich.gaia.swipnet.se>
+ Files: t/op/groups.t
+
+ Title: "More simple regexp tests and test docs"
+ From: Hans Mulder <hansm@euronet.nl>
+ Files: t/op/re_tests t/op/regexp.t
+
+ Title: "[PATCH] Re: Using undef to ignore values returned from split"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Files: t/op/split.t
+
+ UTILITIES
+
+ Title: "bad test of -A flag in h2xs"
+ From: "Jeffrey S. Haemer" <jsh@woodcock.boulder.qms.com>
+ Files: utils/h2xs.PL
+
+ Title: "[PATCH] h2xs missing from utils/Makefile"
+ From: hansm@euronet.nl
+ Files: utils/Makefile
+
+ Title: "PATCH: bug in perlbug w.r.t. environment variables", "bug in perlbug
+ w.r.t. environment variables"
+ From: "Jan D." <jan.djarv@mbox200.swipnet.se>, Jarkko Hietaniemi
+ <jhi@iki.fi>
+ Msg-ID: <199705191841.UAA00969@ostrich.gaia.swipnet.se>,
+ <199705191857.VAA09154@alpha.hut.fi>
+ Files: utils/perlbug.PL
+
+ Title: "[PATCH] final newline missing in MANIFEST generated by h2xs"
+ From: hansm@euronet.nl
+ Files: utils/h2xs.PL
+
+
+-------------
+Version 5.004
+-------------
+
+"Hey, Rocky! Watch me pull a release out of my hat!"
+"Aww, that trick never works..."
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Make C<m//g> reset pos on failure; make C<m//gc> not reset"
+ From: Chip Salzenberg
+ Files: dump.c op.c op.h pod/perldelta.pod pod/perlfaq6.pod
+ pod/perlop.pod pod/perlre.pod pp_ctl.c pp_hot.c regcomp.c
+ t/op/pat.t toke.c
+
+ Title: "SECURITY: Forbid exec() if $ENV{BASH_ENV} is tainted"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perlrun.pod pod/perlsec.pod t/op/taint.t
+ taint.c
+
+ Title: "Allow exec() if $ENV{TERM} is tainted but innocuous"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perlrun.pod pod/perlsec.pod t/op/taint.t
+ taint.c
+
+ Title: "Allow globbing when tainted under VMS (no external program)"
+ From: Chip Salzenberg
+ Files: pp_sys.c t/op/taint.t
+
+ CORE PORTABILITY
+
+ Title: "Make Irix hints adapt when n32 libm.so is missing"
+ From: Chip Salzenberg
+ Files: hints/irix_6.sh
+
+ Title: "Fix default HP-UX installation path"
+ From: Jeff Okamoto
+ Msg-ID: <199705132228.AA227042483@hpcc123.corp.hp.com>
+ Date: Tue, 13 May 1997 15:28:04 -0700
+ Files: hints/hpux.sh
+
+ Title: "VMS update, including socket support (four patches)"
+ From: Jonathan Hudson <Jonathan.Hudson@jrhudson.demon.co.uk>,
+ Peter Prymmer <pvhp@forte.com>,
+ Dan Sugalski <sugalsd@lbcc.cc.or.us>
+ Files: vms/config.vms vms/descrip.mms vms/sockadapt.h vms/vms.c
+ vms/vmsish.h
+
+ Title: "Win32 update (three patches)"
+ From: Gurusamy Sarathy
+ Files: README.win32 perl.c win32/Makefile win32/config.H
+ win32/config_h.PL win32/config_sh.PL win32/makedef.pl
+ win32/win32.c win32/win32.h win32/win32io.c win32/win32io.h
+ win32/win32iop.h
+
+ Title: "Don't require executable bit on perl -S if DOSISH"
+ From: Danny Sadinoff <sadinoff@olf.com>
+ Msg-ID: <337351CE.79B28DE3@olf.com>
+ Date: Fri, 09 May 1997 12:33:18 -0400
+ Files: perl.c
+
+ OTHER CORE CHANGES
+
+ Title: "In C<eval &func>, always call &func in scalar context"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Fix recursive substitution"
+ From: Chip Salzenberg; test from Tim Bunce
+ Files: cop.h global.sym pp_ctl.c proto.h scope.c t/op/subst.t
+
+ Title: "Make read with <> from a TTY notice EOF"
+ From: Jonathan I. Kamens <jik@kamens.brookline.ma.us>
+ Msg-ID: <199705121147.HAA03845@jik.saturn.net>
+ Date: Mon, 12 May 1997 07:47:13 -0400
+ Files: sv.c
+
+ Title: "Fix core dump from get*() functions returning no alias array"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "Fix typo"
+ From: Mark K Trettin <mkt@lucent.com>
+ Msg-ID: <199705102228.RAA11163@gv18c.ih.lucent.com>
+ Date: Sat, 10 May 1997 17:28:35 -0500
+ Files: pp_sys.c
+
+ BUILD PROCESS
+
+ Title: "Don't use 'unset' in Configure"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Protect against having no such command as 'cc'"
+ From: Hans Mulder <hansm@icgned.nl>
+ Msg-ID: <1997May12.163534.2006434@hmivax.humgen.upenn.edu>
+ Date: Mon, 12 May 1997 16:35:34 -0400 (EDT)
+ Files: Configure
+
+ Title: "minor wording enhancement for Configure"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199705101038.NAA00471@alpha.hut.fi>
+ Date: Sat, 10 May 1997 13:38:31 +0300 (EET DST)
+ Files: Configure
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Refresh CGI.pm to 2.36"
+ From: Lincoln Stein <lstein@genome.wi.mit.edu>
+ Files: eg/cgi/frameset.cgi eg/cgi/javascript.cgi lib/CGI.pm
+
+ Title: "In IO::File::open, prepend './' less often (for Win32 et al)"
+ From: Chip Salzenberg
+ Files: ext/IO/lib/IO/File.pm
+
+ Title: "Fix core dump on IO::Seekable::setpos($fh, undef)"
+ From: Chip Salzenberg
+ Files: ext/IO/IO.xs t/lib/io_xs.t
+
+ TESTS
+
+ Title: "Make rand.t vanishingly unlikely to give false failure"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.96.970510190846.23340K-100000@kelly.teleport.com>
+ Date: Sat, 10 May 1997 19:57:30 -0700 (PDT)
+ Files: t/op/rand.t
+
+ Title: "Fix sleep test: sleep(N) is defined to allow sleeping N-1"
+ From: Chuck D. Phillips <cdp@hpescdp.fc.hp.com>
+ Msg-ID: <199705151735.KAA01143@palrel1.hp.com>
+ Date: Thu, 15 May 1997 11:35:41 -0600
+ Files: t/op/sleep.t
+
+ UTILITIES
+
+ Title: "h2xs and @EXPORT_OK"
+ From: Jeff Okamoto
+ Msg-ID: <199705092348.AA057881699@hpcc123.corp.hp.com>
+ Date: Fri, 9 May 1997 16:48:20 -0700
+ Files: utils/h2xs.PL
+
+ DOCUMENTATION
+
+ Title: "Tweaks for perldelta"
+ From: hansm@euronet.nl
+ Msg-ID: <199705102346.BAA17300@mail.euronet.nl>
+ Date: Sun, 11 May 97 01:46:00 +0200
+ Files: pod/perldelta.pod
+
+ Title: "Mention perlfaq.pod and perlmodlib.pod in perldelta.pod"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "Fix example of use of lexicals with formats"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "Explain that destruction order is not defined"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Msg-ID: <199705150600.CAA13550@aatma.engin.umich.edu>
+ Date: Thu, 15 May 1997 02:00:23 -0400
+ Files: pod/perltoot.pod
+
+ Title: "Note that DATA filehandle is unavailable during BEGIN {}"
+ From: neilb@cre.canon.co.uk (Neil Bowers)
+ Msg-ID: <199705121227.NAA29718@tardis.cre.canon.co.uk>
+ Date: Mon, 12 May 1997 13:27:43 +0100
+ Files: pod/perldata.pod
+
+ Title: "More detailed IO::Socket documentation"
+ From: Tom Christiansen
+ Msg-ID: <199705141456.IAA19061@jhereg.perl.com>
+ Date: Wed, 14 May 1997 08:56:30 -0600
+ Files: pod/perlipc.pod
+
+
+-----------------
+Version 5.003_99a
+-----------------
+
+Herein we find the fruits of the gamma.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "SECURITY: Forbid glob() when tainting (-T or setuid)"
+ From: Chip Salzenberg
+ Files: pod/perlrun.pod pod/perlsec.pod pp_sys.c
+
+ Title: "SECURITY: Forbid exec() if $ENV{TERM} or $ENV{ENV} is tainted"
+ From: Chip Salzenberg
+ Files: pod/perlrun.pod pod/perlsec.pod t/op/taint.t taint.c
+
+ CORE PORTABILITY
+
+ Title: "(NeXT|Open)Step update"
+ From: Gerd Knops <gerti@BITart.com>
+ Msg-ID: <9705072247.AA18882@BITart.com>
+ Date: Wed, 7 May 97 17:47:02 -0500
+ Files: Configure MANIFEST config_h.SH hints/next_3.sh hints/next_4.sh
+
+ Title: "NetBSD hint update"
+ From: Giles Lean <giles@nemeton.com.au>
+ Msg-ID: <199705051346.XAA13584@topaz.nemeton.com.au>
+ Date: Mon, 5 May 1997 23:46:37 +1000 (EST)
+ Files: hints/netbsd.sh
+
+ Title: "Irix hint update"
+ From: Scott Henry <scotth@sgi.com>
+ Msg-ID: <yd83es0fp57.fsf@hoshi.engr.sgi.com>
+ Date: 06 May 1997 11:09:56 -0700
+ Files: hints/irix_6.sh
+
+ Title: "HPUX: patch for ext/DynaLoader/dl_hpux.xs"
+ From: Chuck D. Phillips <cdp@hpescdp.fc.hp.com>
+ Msg-ID: <199705050548.WAA21260@palrel1.hp.com>
+ Date: Sun, 4 May 1997 23:48:39 -0600
+ Files: ext/DynaLoader/dl_hpux.xs
+
+ Title: "Win32 update (consolidated patch plus three followups)"
+ From: Gurusamy Sarathy
+ Files: EXTERN.h README.win32 lib/Sys/Hostname.pm pod/perldelta.pod
+ win32/config.H win32/config.w32 win32/config_sh.PL win32/perllib.c
+ win32/win32.c win32/win32.h win32/include/sys/socket.h
+
+ Title: "Win32 boot_DynaLoader problem in 99"
+ From: Gary Clark <GaryC@mail.jeld-wen.com>
+ Msg-ID: <1997May05.105000.1708.84476@mail.jeld-wen.com>
+ Date: Mon, 05 May 1997 10:49:03 -0700
+ Files: win32/makedef.pl
+
+ OTHER CORE CHANGES
+
+ Title: "Fix wantarray() in sort subs [fixes metaconfig]"
+ From: Chip Salzenberg
+ Files: pp_ctl.c
+
+ Title: "Fix for redefined sort subs nastiness"
+ From: Gurusamy Sarathy
+ Msg-ID: <199705090004.UAA15032@aatma.engin.umich.edu>
+ Date: Thu, 08 May 1997 20:04:18 -0400
+ Files: op.c pod/perldelta.pod pod/perldiag.pod sv.c t/op/sort.t
+
+ BUILD PROCESS
+
+ Title: "AFS patches"
+ From: Chip Salzenberg, Larry Schwimmer <rosebud@cyclone.Stanford.EDU>
+ Files: Configure installperl
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Another blank line patch to Pod::Text"
+ From: Russ Allbery <rra@stanford.edu>
+ Msg-ID: <m3afm5g6ar.fsf@windlord.Stanford.EDU>
+ Date: 08 May 1997 11:36:12 -0700
+ Files: lib/Pod/Text.pm
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ Title: "Three bugs in pod2html"
+ From: hansm@euronet.nl
+ Msg-ID: <199705052228.AAA25351@mail.euronet.nl>
+ Date: Tue, 6 May 97 00:28:06 +0200
+ Files: lib/Pod/Html.pm
+
+ Title: "Trivial bugfix for pod of xsubpp"
+ From: Ralf S. Engelschall <rse@engelschall.com>
+ Msg-ID: <199705051447.QAA09995@en1.engelschall.com>
+ Date: Mon, 5 May 1997 16:47:03 +0200
+ Files: lib/ExtUtils/xsubpp
+
+ Title: "Newer CPerl mode"
+ From: Ilya Zakharevich
+ Msg-ID: <199705080032.UAA22532@monk.mps.ohio-state.edu>
+ Date: Wed, 7 May 1997 20:32:46 -0400 (EDT)
+ Files: emacs/cperl-mode.el
+
+ DOCUMENTATION
+
+ Title: "Updates to perldelta"
+ From: Chip Salzenberg and Dominic Dunlop
+ Files: pod/perldelta.pod
+
+ Title: "More explicit Solaris instructions"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970508171206.438A-100000@fractal.lafayette.ed
+ Date: Thu, 08 May 1997 17:14:54 -0400 (EDT)
+ Files: INSTALL hints/solaris_2.sh
+
+ Title: "Document 'Possible attempt to separate words with commas'"
+ From: Gisle Aas
+ Msg-ID: <hyb9snvdw.fsf@bergen.sn.no>
+ Date: 06 May 1997 23:27:55 +0200
+ Files: pod/perlop.pod
+
+ Title: "perlfaq9, hostname"
+ From: John D Groenveld <groenvel@cse.psu.edu>
+ Msg-ID: <199705061741.NAA22777@cse.psu.edu>
+ Date: Tue, 06 May 1997 13:41:12 EDT
+ Files: pod/perlfaq9.pod
+
+ Title: "Debugger docs patch"
+ From: Ilya Zakharevich
+ Msg-ID: <199705080107.VAA24317@monk.mps.ohio-state.edu>
+ Date: Wed, 7 May 1997 21:07:14 -0400 (EDT)
+ Files: pod/perldebug.pod
+
+ Title: "Document that C<m?x?> is just like C<?x?>"
+ From: Chip Salzenberg
+ Files: pod/perlop.pod
+
+ Title: "Refresh description of sprintf()"
+ From: Chip Salzenberg
+ Files: pod/perl.pod pod/perlfunc.pod
+
+ Title: "Mention the Regular Expressions book"
+ From: Stephen Potter <spp@psa.pencom.com>
+ Msg-ID: <199705071737.MAA18799@psa.pencom.com>
+ Date: Wed, 07 May 1997 12:37:37 -0500
+ Files: pod/perlbook.pod pod/perlre.pod
+
+ Title: "OS/2 doc patch for _99"
+ From: Ilya Zakharevich
+ Msg-ID: <199705080046.UAA23466@monk.mps.ohio-state.edu>
+ Date: Wed, 7 May 1997 20:46:45 -0400 (EDT)
+ Files: README.os2
+
+
+----------------
+Version 5.003_99
+----------------
+
+"Oops." Now this _has_ to be the gamma; we're out of numbers.
+
+ CORE LANGUAGE CHANGES
+
+ (no changes)
+
+ CORE PORTABILITY
+
+ Title: "NeXT hints update"
+ From: hansm@euronet.nl
+ Msg-ID: <199704302229.AAA02690@mail.euronet.nl>
+ Date: Thu, 1 May 97 00:28:41 +0200
+ Files: Configure Makefile.SH hints/next_4.sh
+
+ Title: "Support shared libperl on AIX"
+ From: Eric Bartley <bartley@icd.cc.purdue.edu>
+ Msg-ID: <199704270131.UAA51426@icd.cc.purdue.edu>
+ Date: Sat, 26 Apr 1997 20:31:37 -0500
+ Files: Configure Makefile.SH hints/aix.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Fix NUL-termination bug in delimcpy()"
+ From: Chip Salzenberg
+ Files: util.c
+
+ Title: "Forget prototype of subroutine after C<undef &subr>"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Handle tainted values in lists returned from subs, evals"
+ From: Chip Salzenberg
+ Files: pp_ctl.c pp_hot.c t/op/taint.t
+
+ Title: "Fix sysread() on tied handle"
+ From: Spider Boardman
+ Msg-ID: <199705010601.CAA04926@Orb.Nashua.NH.US>
+ Date: Thu, 1 May 1997 02:01:20 -0400
+ Files: pp_sys.c
+
+ Title: "Fix OS/2-specific buffer overflow"
+ From: Ilya Zakharevich
+ Msg-ID: <199704301920.PAA09681@monk.mps.ohio-state.edu>
+ Date: Wed, 30 Apr 1997 15:20:01 -0400 (EDT)
+ Files: os2/os2.c
+
+ BUILD PROCESS
+
+ Title: "Add new globals to perl.exp"
+ From: Chip Salzenberg
+ Files: perl_exp.SH
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Refresh DB_File to 1.14"
+ From: Paul Marquess
+ Msg-ID: <9704302045.AA05484@claudius.bfsec.bt.co.uk>
+ Date: Wed, 30 Apr 1997 21:45:09 +0100 (BST)
+ Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs t/lib/db-btree.t
+ t/lib/db-hash.t t/lib/db-recno.t
+
+ TESTS
+
+ Title: "Disable op/pipe.t test under Machten"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03102801af8e160d3879@[194.51.248.68]>
+ Date: Thu, 1 May 1997 12:48:26 +0200
+ Files: t/io/pipe.t
+
+ UTILITIES
+
+ Title: "typo fixes to installhtml"
+ From: lvirden@cas.org (Larry W. Virden)
+ Msg-ID: <199705011114.HAA26968@cas.org>
+ Date: Thu, 1 May 1997 07:14:31 -0400
+ Files: installhtml
+
+ DOCUMENTATION
+
+ Title: "Fix description of av_undef() in perlguts"
+ From: Gisle Aas
+ Msg-ID: <199705011042.MAA09897@bergen.sn.no>
+ Date: Thu, 1 May 1997 12:42:46 +0200
+ Files: pod/perlguts.pod
+
+ Title: "Fix typo in perldelta"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+
+----------------
+Version 5.003_98
+----------------
+
+Here it is, the second public beta (a.k.a gamma).
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Support C< $coderef->($x,$y) >"
+ From: Chip Salzenberg
+ Files: perly.c perly.c.diff perly.y pod/perldelta.pod pod/perldsc.pod
+ pod/perlref.pod t/op/ref.t vms/perly_c.vms
+
+ CORE PORTABILITY
+
+ (no changes)
+
+ OTHER CORE CHANGES
+
+ Title: "Fix C< hex('80') * 0x1000000 >"
+ From: Chip Salzenberg
+ Files: opcode.pl
+
+ Title: "Reset errno after failed piped close"
+ From: Roderick Schertler
+ Msg-ID: <28152.862264940@eeyore.ibcinc.com>
+ Date: Mon, 28 Apr 1997 18:02:20 -0400
+ Files: lib/Time/gmtime.pm lib/Time/localtime.pm pod/perlfunc.pod
+ t/io/pipe.t util.c
+
+ Title: "Fix warning wrt return value of PerlIO_getname()"
+ From: Spider Boardman
+ Msg-ID: <199704300448.AAA24174@Orb.Nashua.NH.US>
+ Date: Wed, 30 Apr 1997 00:48:13 -0400
+ Files: perlio.c
+
+ BUILD PROCESS
+
+ (no changes)
+
+ LIBRARY AND EXTENSIONS
+
+ (no changes)
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ (no changes)
+
+ DOCUMENTATION
+
+ Title: "Describe Math::Trig in perlmodlib"
+ From: Chip Salzenberg
+ Files: pod/perlmodlib.pod
+
+ Title: "Add new diagnostics to perldelta"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perldiag.pod
+
+
+-----------------
+Version 5.003_97j
+-----------------
+
+This patch should be _98, unless it's egregiously broken somehow.
+
+ CORE LANGUAGE CHANGES
+
+ (no changes)
+
+ CORE PORTABILITY
+
+ Title: "Return to favoring memset(,0,) over bzero()"
+ From: Chip Salzenberg
+ Files: perl.h
+
+ Title: "NetBSD hint update"
+ From: matthew green <mrg@splode.eterna.com.au>
+ Msg-ID: <199704251021.EAA22570@jhereg.perl.com>
+ Date: Fri, 25 Apr 1997 20:18:02 +1000
+ Files: hints/netbsd.sh
+
+ Title: "HP-UX hint update"
+ From: Chuck D. Phillips <cdp@hpescdp.fc.hp.com>
+ Msg-ID: <199704280535.WAA22441@palrel1.hp.com>
+ Date: Sun, 27 Apr 1997 23:35:07 -0600
+ Files: hints/hpux.sh
+
+ Title: "Win32 update (three patches)"
+ From: Gurusamy Sarathy and Nick Ing-Simmons
+ Files: win32/makedef.pl win32/perllib.c win32/win32.c
+
+ OTHER CORE CHANGES
+
+ Title: "Update sprintf: '%hn'; '%s',NULL; panic on frexp() failure"
+ From: Chip Salzenberg
+ Files: perl.h pod/perldiag.pod sv.c
+
+ Title: "Fix lingering '%S' in XS_VERSION_BOOTCHECK"
+ From: Chip Salzenberg
+ Files: XSUB.h
+
+ Title: "Eliminate Alpha warnings"
+ From: Hallvard B Furuseth and Chip Salzenberg
+ Files: perlsdio.h pp_sys.c
+
+ Title: "Fix typo in NeXT dynaloader"
+ From: Chip Salzenberg
+ Files: ext/DynaLoader/dl_next.xs
+
+ Title: "Fix possible buffer overflow under VMS"
+ From: Chip Salzenberg
+ Files: taint.c
+
+ BUILD PROCESS
+
+ (no changes)
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Refresh CGI.pm to 2.35"
+ From: Lincoln Stein <lstein@genome.wi.mit.edu>
+ Files: lib/CGI.pm
+
+ Title: "Refresh DB_File to 1.13"
+ From: Paul Marquess
+ Msg-ID: <9704271413.AA08876@claudius.bfsec.bt.co.uk>
+ Date: Sun, 27 Apr 1997 15:12:59 +0100 (BST)
+ Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+
+ Title: "SelfLoader: fix prototype pattern, rename intrusive lexical"
+ From: Jesse Glick <jesse@ginger> and Chip Salzenberg
+ Files: lib/SelfLoader.pm
+
+ TESTS
+
+ (no changes)
+
+ UTILITIES
+
+ (no changes)
+
+ DOCUMENTATION
+
+ Title: "Split perlmod"
+ From: Tom Christiansen
+ Msg-ID: <199704260050.RAA02468@toy.perl.com>
+ Date: Fri, 25 Apr 1997 20:50:09 -0400
+ Files: MANIFEST pod/Makefile pod/buildtoc pod/perl.pod
+ pod/perldsc.pod pod/perlfaq3.pod pod/perlipc.pod
+ pod/perlmod.pod pod/perlmodlib.pod pod/perlobj.pod
+ pod/perltie.pod pod/roffitall
+
+ Title: "Describe __PACKAGE__ in perldelta"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "Doc fix for close of pipe handle"
+ From: Chip Salzenberg
+ Files: pod/perlfunc.pod
+
+
+-----------------
+Version 5.003_97i
+-----------------
+
+This patch eliminates all known sources of buffer overflow! (And the
+crowd goes wild. (Yeah.)) Showstoppers only between here and _98.
+
+ CORE LANGUAGE CHANGES
+
+ (no changes)
+
+ CORE PORTABILITY
+
+ Title: "Provide memset() if it's missing"
+ From: Chip Salzenberg
+ Files: global.sym perl.h proto.h util.c
+
+ Title: "Don't tell GCC that warn(), croak(), and die() are printf-lik
+ From: Chip Salzenberg
+ Files: proto.h
+
+ OTHER CORE CHANGES
+
+ Title: "Misc. sv_vcatpvfn() fixes"
+ From: Hugo, Dale, Nick, Hallvard, Chip
+ Files: gv.c mg.c op.c perl.c pp.c pp_ctl.c sv.c toke.c util.c
+
+ Title: "Enforce order of sprintf() elements"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ Title: "Guard against long numbers, <<LONG_DELIM, and <long glob>"
+ From: Chip Salzenberg
+ Files: global.sym mg.c perl.c pod/perldiag.pod proto.h toke.c util.c
+
+ Title: "Guard against C<goto> to deeply nested label"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod pp_ctl.c
+
+ Title: "Guard against overflow in dup2() emulation"
+ From: Chip Salzenberg
+ Files: util.c
+
+ Title: "Win32: Guard against long function names"
+ From: Chip Salzenberg
+ Files: win32/win32sck.c
+
+ Title: "Make mess() always work, by using a non-arena SV"
+ From: Chip Salzenberg, from idea by Gurusamy Sarathy
+ Files: perl.c util.c
+
+ Title: "Fix scalar leak in pp_prtf()"
+ From: Doug MacEachern
+ Msg-ID: <199704241706.NAA19140@postman.osf.org>
+ Date: Thu, 24 Apr 1997 13:06:21 -0400
+ Files: pp_sys.c
+
+ Title: "When copying a format line, take only its string value"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ Title: "Undo private patch"
+ From: Chip Salzenberg
+ Files: installperl lib/ExtUtils/Install.pm
+
+ Title: "Fix LEAKTEST numbers"
+ From: Chip Salzenberg
+ Files: ext/DynaLoader/dl_vms.xs handy.h os2/os2.c util.c vms/vms.c
+ win32/win32.c win32/win32sck.c
+
+ BUILD PROCESS
+
+ Title: "Cope with a <db.h> that isn't related to DB"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199704241728.UAA09951@alpha.hut.fi>
+ Date: Thu, 24 Apr 1997 20:28:39 +0300 (EET DST)
+ Files: Configure
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Always NUL-terminate opsets"
+ From: Chip Salzenberg
+ Files: ext/Opcode/Opcode.xs
+
+ Title: "Don't core dump if my_inet_aton() get a NULL"
+ From: Chip Salzenberg
+ Files: ext/Socket/Socket.xs
+
+ Title: "Handle symlinks, high permission bits in File::Path"
+ From: Chip Salzenberg
+ Files: lib/File/Path.pm
+
+ Title: "Math::{Complex,Trig} update"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199704242221.BAA30363@alpha.hut.fi>
+ Date: Fri, 25 Apr 1997 01:21:44 +0300 (EET DST)
+ Files: lib/Math/Complex.pm lib/Math/Trig.pm pod/roffitall
+ t/lib/complex.t t/lib/trig.t
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ Title: "Fix buffer overflow in a2p"
+ From: Chip Salzenberg
+ Files: x2p/a2py.c
+
+ DOCUMENTATION
+
+ Title: "FAQ udpate (24-apr-97)"
+ From: Nathan Torkington <gnat@prometheus.frii.com>
+ Msg-ID: <199704242247.QAA07010@prometheus.frii.com>
+ Date: Thu, 24 Apr 1997 16:47:23 -0600 (MDT)
+ Files: pod/perlfaq*.pod
+
+ Title: "Document new {,s}printf() behavior"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perlfunc.pod
+
+
+-----------------
+Version 5.003_97h
+-----------------
+
+This patch eliminates almost all possible sources of buffer overflow;
+in particular, there are no more sprintf() bugs. (!!) This patch
+also has a few other fixes. With these changes in place, I can sleep
+at night. (Because I've stopped hacking. :-))
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Support PRINTF for tied handles"
+ From: Doug MacEachern
+ Msg-ID: <199704202226.SAA08032@postman.osf.org>
+ Date: Sun, 20 Apr 1997 18:26:13 -0400
+ Files: pod/perldelta.pod pod/perltie.pod pp_sys.c t/op/misc.t
+
+ CORE PORTABILITY
+
+ Title: "Fix bitwise shifts and pack('w') on Crays"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Win32 update (two patches)"
+ From: Gurusamy Sarathy
+ Files: lib/AutoSplit.pm lib/ExtUtils/MM_Unix.pm win32/config.w32
+ win32/makedef.pl
+
+ OTHER CORE CHANGES
+
+ Title: "Mondo Cool patch for buffer safety and convenience"
+ From: Chip Salzenberg
+ Files: XSUB.h doop.c dump.c ext/DynaLoader/dl_dlopen.xs
+ ext/DynaLoader/dl_hpux.xs ext/DynaLoader/dl_next.xs
+ ext/DynaLoader/dlutils.c ext/ODBM_File/ODBM_File.xs
+ global.sym gv.c interp.sym mg.c op.c perl.c perl.h
+ pod/perlguts.pod pp.c pp_ctl.c pp_hot.c pp_sys.c proto.h
+ regcomp.c regexec.c sv.c toke.c util.c
+
+ Title: "Problems with glob"
+ From: Ilya Zakharevich
+ Msg-ID: <1997Apr20.024432.1941365@hmivax.humgen.upenn.edu>
+ Date: Sun, 20 Apr 1997 02:44:32 -0400 (EDT)
+ Files: op.c
+
+ Title: "Fix scalar leak in closures"
+ From: Chip Salzenberg
+ Files: op.c scope.c
+
+ Title: "Refine error messages re: anon subs' prototypes"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Outermost scope is void, not scalar"
+ From: Chip Salzenberg
+ Files: pp_ctl.c
+
+ BUILD PROCESS
+
+ Title: "Fix up Linux hints for tcsh, and Configure patch"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970422101051.2506C-100000@fractal.lafayette.e
+ Date: Tue, 22 Apr 1997 11:02:27 -0400 (EDT)
+ Files: Configure hints/linux.sh
+
+ Title: "There is no standard answer to 'Use suidperl?'"
+ From: Chip Salzenberg
+ Files: hints/bsdos.sh hints/freebsd.sh hints/linux.sh
+ hints/machten_2.sh
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Math::Complex update"
+ From: Jarkko Hietaniemi
+ Files: lib/Math/Complex.pm t/lib/complex.t
+
+ Title: "Croak on C<use autouse> without module name"
+ From: Chip Salzenberg
+ Files: lib/autouse.pm
+
+ Title: "Silence warnings on simple C<use ops>"
+ From: Roderick Schertler
+ Msg-ID: <pzybafum6k.fsf@eeyore.ibcinc.com>
+ Date: 19 Apr 1997 10:22:43 -0400
+ Files: ext/Opcode/ops.pm
+
+ TESTS
+
+ Title: "Don't put leading newline on numeric strings"
+ From: Andreas Koenig
+ Msg-ID: <199704230847.KAA22752@anna.in-berlin.de>
+ Date: Wed, 23 Apr 1997 10:47:00 +0200
+ Files: t/pragma/constant.t
+
+ UTILITIES
+
+ (no changes)
+
+ DOCUMENTATION
+
+ Title: "FAQ udpate (23-apr-97)"
+ From: Nathan Torkington <gnat@prometheus.frii.com>
+ Msg-ID: <199704231822.MAA05074@prometheus.frii.com>
+ Date: Wed, 23 Apr 1997 12:22:55 -0600 (MDT)
+ Files: pod/perlfaq*.pod
+
+ Title: "Two doublewords less"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199704201938.WAA07722@alpha.hut.fi>
+ Date: Sun, 20 Apr 1997 22:38:13 +0300 (EET DST)
+ Files: pod/perlrun.pod vms/perlvms.pod
+
+
+-----------------
+Version 5.003_97g
+-----------------
+
+This one has two security bug fixes for buffer overflows. Perl has
+not yet been searched to see if more fixes are needed.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Improve sysseek(), remove systell(), fix Opcode"
+ From: Chip Salzenberg
+ Files: doio.c ext/Opcode/Makefile.PL ext/Opcode/Opcode.pm
+ ext/Opcode/Opcode.xs global.sym keywords.pl opcode.pl
+ pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod pp_sys.c
+ proto.h t/op/sysio.t toke.c
+
+ Title: "Fix (and test) spaces in {,un}pack()"
+ From: Chip Salzenberg
+ Files: pp.c t/op/pack.t
+
+ CORE PORTABILITY
+
+ Title: "Irix update"
+ From: Scott Henry <scotth@sgi.com>
+ Msg-ID: <yd8d8rsi0ln.fsf@hoshi.engr.sgi.com>
+ Date: 18 Apr 1997 12:37:24 -0700
+ Files: MANIFEST hints/irix_6.sh hints/irix_6_0.sh hints/irix_6_1.sh
+
+ Title: "ExtUtils/Miniperl.pm not built on Win32"
+ From: Nick Ing-Simmons
+ Msg-ID: <199704181742.SAA08407@ni-s.u-net.com>
+ Date: Fri, 18 Apr 1997 18:42:32 +0100
+ Files: win32/Makefile
+
+ OTHER CORE CHANGES
+
+ Title: "SECURITY FIX: 'Identifier too long'"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perldiag.pod toke.c
+
+ Title: "SECURITY FIX: Buffer overflow in gv_fetchfile()"
+ From: Chip Salzenberg
+ Files: gv.c
+
+ Title: "Remove pp_method() inefficiency from last patch"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ BUILD PROCESS
+
+ Title: "Fix unnecessary re-linking"
+ From: Chip Salzenberg
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "Fix tcsh hack in Configure"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Minor, optional patch to Makefile.SH"
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Msg-ID: <rjray-9703180132.AA00374040@snakepit.ecte.uswc.uswest.com>
+ Date: Thu, 17 Apr 1997 19:32:17 -0600
+ Files: Makefile.SH
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Patch to Getopt::Long"
+ From: Johan Vromans <jvromans@squirrel.nl>
+ Msg-ID: <m0wIKCO-00081IC@phoenix.squirrel.nl>
+ Date: Fri, 18 Apr 97 22:24 MET DST
+ Files: lib/Getopt/Long.pm
+
+ Title: "Fix NAME in SDBM_File build"
+ From: Chip Salzenberg
+ Files: ext/SDBM_File/sdbm/Makefile.PL
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ Title: "Make h2ph generate constant subs"
+ From: Roderick Schertler
+ Msg-ID: <pz2088w5ot.fsf@eeyore.ibcinc.com>
+ Date: 18 Apr 1997 14:23:46 -0400
+ Files: utils/h2ph.PL
+
+ DOCUMENTATION
+
+ Title: "Document {,un}pack changes"
+ From: Paul Marquess
+ Msg-ID: <9704181249.AA11733@claudius.bfsec.bt.co.uk>
+ Date: Fri, 18 Apr 97 13:49:39 BST
+ Files: pod/perldelta.pod pod/perldiag.pod
+
+
+-----------------
+Version 5.003_97f
+-----------------
+
+This is it before _98. No more last-minute features. Really, I mean
+it this time. No kidding.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "New operator systell()"
+ From: Chip Salzenberg
+ Files: doio.c ext/Opcode/Opcode.pm keywords.pl opcode.pl
+ pod/perldelta.pod pod/perldiag.pod pod/perlfunc.pod pp_sys.c
+ t/op/sysio.t toke.c
+
+ Title: "Allow constant sub to be optimized when called with parens"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Make {,un}pack fail on invalid pack types"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod pp.c
+
+ CORE PORTABILITY
+
+ Title: "Fix bitwise ops and {,un}pack() on Cray CPUs"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "VMS update"
+ From: Charles Bailey
+ Files: lib/Cwd.pm lib/File/Path.pm lib/FindBin.pm vms/perly_c.vms
+ vms/vms.c vms/writemain.pl
+
+ Title: "Win32 update (three patches)"
+ From: Gurusamy Sarathy and Nick Ing-Simmons
+ Files: lib/Cwd.pm lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_Win32.pm
+ lib/File/Basename.pm win32/Makefile win32/makedef.pl
+ win32/perllib.c win32/win32.c win32/win32iop.h
+
+ OTHER CORE CHANGES
+
+ Title: "Fix error messages on method lookup failure"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Fix use of var before init in util.c"
+ From: Gurusamy Sarathy
+ Msg-ID: <199704162342.TAA20773@aatma.engin.umich.edu>
+ Date: Wed, 16 Apr 1997 19:42:41 -0400
+ Files: util.c
+
+ BUILD PROCESS
+
+ Title: "Linux hints: Allow build w/o suidperl, prefer tcsh to csh"
+ From: Michael De La Rue <mikedlr@tardis.ed.ac.uk>
+ Files: Configure hints/linux.sh
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Fix bug in Opcode when (maxo & 15) > 8"
+ From: Chip Salzenberg
+ Files: ext/Opcode/Makefile.PL ext/Opcode/Opcode.pm
+ ext/Opcode/Opcode.xs
+
+ Title: "CGI.pm broke again"
+ From: Andreas Koenig
+ Msg-ID: <199704171136.NAA24859@anna.in-berlin.de>
+ Date: Thu, 17 Apr 1997 13:36:28 +0200
+ Files: lib/CGI.pm
+
+ Title: "Revise quotewords()"
+ From: Shishir Gundavaram <shishir@ruby.ora.com>
+ Files: lib/Text/ParseWords.pm
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ (no changes)
+
+ DOCUMENTATION
+
+ Title: "Doc updates: INSTALL-1.13, pumpkin.pod-1.9"
+ From: Andy Dougherty
+ Files: INSTALL Porting/pumpkin.pod
+
+ Title: "Document size restrictions for packed integers"
+ From: Jarkko Hietaniemi
+ Files: pod/perlfunc.pod
+
+
+-----------------
+Version 5.003_97e
+-----------------
+
+Y'know, I've heard of this "beta" thing, but it's been so long since
+I've seen one, I'm not sure it really exists...
+
+ CORE LANGUAGE CHANGES
+
+ Title: "New operator: sysseek()"
+ From: Chip Salzenberg
+ Files: doio.c ext/Opcode/Makefile.PL ext/Opcode/Opcode.pm global.sym
+ keywords.pl opcode.pl pod/perldelta.pod pod/perlfunc.pod
+ pp_sys.c t/op/sysio.t toke.c
+
+ Title: "Allow recursive substitution again"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perldiag.pod pp_hot.c
+
+ CORE PORTABILITY
+
+ Title: "Use size_t for socket size parameters of GNU libc"
+ From: Chip Salzenberg
+ Files: doio.c pp_sys.c
+
+ Title: "Fix STMT_{START,END} under g++"
+ From: Steven Parkes <parkes@sierravista.com>
+ Msg-ID: <199704141935.MAA11240@monterey.sierravista.com>
+ Date: Mon, 14 Apr 1997 12:35:34 -0700
+ Files: perl.h
+
+ Title: "Win32 update (four patches)"
+ From: Gurusamy Sarathy and Nick Ing-Simmons
+ Files: MANIFEST README.win32 dosish.h ext/SDBM_File/Makefile.PL
+ ext/SDBM_File/sdbm/Makefile.PL ext/SDBM_File/sdbm/sdbm.c
+ ext/SDBM_File/sdbm/sdbm.h lib/ExtUtils/MM_Unix.pm perl.c
+ utils/perlbug.PL utils/perldoc.PL win32/Makefile win32/TEST
+ win32/config.H win32/config.w32 win32/config_h.PL
+ win32/config_sh.PL win32/perllib.c win32/runperl.c
+ win32/win32.c win32/win32io.c win32/win32sck.c
+
+ OTHER CORE CHANGES
+
+ Title: "New API function: perl_eval_pv()"
+ From: Doug MacEachern
+ Msg-ID: <199704142113.RAA06823@postman.osf.org>
+ Date: Mon, 14 Apr 1997 17:13:41 -0400
+ Files: perl.c pod/perlcall.pod pod/perldelta.pod pod/perlembed.pod
+ pod/perlguts.pod proto.h
+
+ Title: "Fix C< s//whatever/ >, which reuses old pattern"
+ From: Chip Salzenberg
+ Files: pp_hot.c regexec.c
+
+ Title: "Return a value from PerlIO_{,un}getc"
+ From: Hallvard B Furuseth
+ Msg-ID: <199704131228.OAA05695@bombur2.uio.no>
+ Date: Sun, 13 Apr 1997 14:28:14 +0200 (MET DST)
+ Files: perlio.c
+
+ Title: "Fix for environment leak"
+ From: skimo@breughel.ufsia.ac.be (Sven Verdoolaege)
+ Msg-ID: <19970415103246.NN46698@breughel.ufsia.ac.be>
+ Date: Tue, 15 Apr 1997 10:32:46 +0200
+ Files: util.c
+
+ Title: "Fix comments in seed()"
+ From: Hallvard B Furuseth
+ Msg-ID: <199704141758.TAA06895@bombur2.uio.no>
+ Date: Mon, 14 Apr 1997 19:58:38 +0200 (MET DST)
+ Files: pp.c
+
+ BUILD PROCESS
+
+ Title: "Put extensions' autoload files in $archlib"
+ From: Chip Salzenberg
+ Files: installperl
+
+ Title: "Use '-fPIC' for debugging compiles under Solaris with gcc"
+ From: Hallvard B Furuseth
+ Files: Configure
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Refresh CGI to 2.34"
+ From: Chip Salzenberg
+ Files: eg/cgi/customize.cgi eg/cgi/tryit.cgi lib/CGI.pm
+ lib/CGI/Apache.pm
+
+ Title: "Debugger update"
+ From: Ilya Zakharevich
+ Msg-ID: <199704142115.RAA09923@monk.mps.ohio-state.edu>
+ Date: Mon, 14 Apr 1997 17:15:27 -0400 (EDT)
+ Files: lib/perl5db.pl
+
+ Title: "diagnostics: $/ gotcha"
+ From: Andreas Koenig
+ Msg-ID: <199704151814.UAA03404@anna.in-berlin.de>
+ Date: Tue, 15 Apr 1997 20:14:01 +0200
+ Files: lib/diagnostics.pm
+
+ Title: "Update File::Path"
+ From: Andreas Koenig
+ Msg-ID: <199704151401.QAA02556@anna.in-berlin.de>
+ Date: Tue, 15 Apr 1997 16:01:07 +0200
+ Files: lib/File/Path.pm t/lib/filepath.t
+
+ Title: "User::pwent.pm: g{,e}cos"
+ From: Tom Christiansen
+ Msg-ID: <199704130135.TAA23274@jhereg.perl.com>
+ Date: Sat, 12 Apr 1997 19:35:54 -0600
+ Files: lib/User/pwent.pm
+
+ Title: "Sys::Syslog: hyphens in hostnames"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199704151421.RAA19693@alpha.hut.fi>
+ Date: Tue, 15 Apr 1997 17:21:53 +0300 (EET DST)
+ Files: lib/Sys/Syslog.pm
+
+ Title: "Clean up format of dlopen() debug info"
+ From: Hallvard B Furuseth
+ Files: ext/DynaLoader/dl_dlopen.xs
+
+ TESTS
+
+ (no changes)
+
+ UTILITIES
+
+ Title: "xsubpp incorrectly handles 'class::newthing()'"
+ From: "John Q. Linux" <jql@jql.accessone.com>
+ Msg-ID: <199704122201.PAA01780@jql.accessone.com>
+ Date: Sat, 12 Apr 1997 15:01:33 -0700
+ Files: lib/ExtUtils/xsubpp
+
+ DOCUMENTATION
+
+ Title: "Add CGI to perldelta.pod and improve its description in MANIFEST"
+ From: Chip Salzenberg
+ Files: MANIFEST pod/perldelta.pod
+
+ Title: "Describe probs with majordomo 1.94.1"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "Fix description of /\G/g"
+ From: Chip Salzenberg
+ Files: pod/perlop.pod
+
+ Title: "Mention '...' operator in precedence table"
+ From: Tom Christiansen
+ Msg-ID: <199704131724.LAA23120@jhereg.perl.com>
+ Date: Sun, 13 Apr 1997 11:24:16 -0600
+ Files: pod/perlop.pod
+
+
+-----------------
+Version 5.003_97d
+-----------------
+
+Any minute now... second public beta... no, really...
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Fix for incorrect overloaded assignment"
+ From: Ilya Zakharevich
+ Msg-ID: <199704112225.SAA03482@monk.mps.ohio-state.edu>
+ Date: Fri, 11 Apr 1997 18:25:33 -0400 (EDT)
+ Files: gv.c
+
+ Title: "Fix C< $x=''; pos($x)=0; $x=~/\G$/ >"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Fix label on C<for(;;)> statement"
+ From: Chip Salzenberg
+ Files: perly.c perly.y
+
+ CORE PORTABILITY
+
+ Title: "update to 5.003_97b/hint/irix_6_2.sh"
+ From: Scott Henry <scotth@sgi.com>
+ Msg-ID: <yd8hghdjbk0.fsf@hoshi.engr.sgi.com>
+ Date: 11 Apr 1997 18:05:03 -0700
+ Files: hints/irix_6_2.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Before 'BEGIN not safe', explain why"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "New error msg for low-key failure of C<require>"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod pp_ctl.c t/pragma/strict-subs
+ t/pragma/strict-vars
+
+ Title: "Put "dXSUB_SYS" last in declarations"
+ From: Chip Salzenberg
+ Files: win32/perllib.c
+
+ Title: "Minor type cleanup"
+ From: Chip Salzenberg
+ Files: proto.h toke.c
+
+ BUILD PROCESS
+
+ (no changes)
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "win32: perl5db patch"
+ From: Gurusamy Sarathy
+ Msg-ID: <199704102142.RAA27396@aatma.engin.umich.edu>
+ Date: Thu, 10 Apr 1997 17:42:13 -0400
+ Files: lib/perl5db.pl
+
+ Title: "Enhancements to debugger, Term::ReadLine, Term::Cap"
+ From: Ilya Zakharevich
+ Msg-ID: <199704101948.PAA01841@monk.mps.ohio-state.edu>
+ Date: Thu, 10 Apr 1997 15:48:07 -0400 (EDT)
+ Files: lib/Term/Cap.pm lib/Term/ReadLine.pm lib/perl5db.pl
+
+ Title: "MM_Unix patch for use under CVS"
+ From: Ulrich Pfeifer
+ Msg-ID: <yfmd8s1vhpn.fsf@ls6.informatik.uni-dortmund.de>
+ Date: 11 Apr 1997 14:59:00 +0200
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "Complex update (five patches)"
+ From: Jarkko Hietaniemi
+ Files: lib/Math/Complex.pm t/lib/complex.t
+
+ Title: "Fix undef warning in Math::BigInt"
+ From: Chip Salzenberg
+ Files: lib/Math/BigInt.pm
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ Title: "Add B<-o> option to a2p, for old awk; make new the default"
+ From: Chip Salzenberg
+ Files: x2p/a2p.h x2p/a2p.pod x2p/a2py.c x2p/walk.c
+
+ DOCUMENTATION
+
+ Title: "typo in lib/diagnostics.pm"
+ From: barnett@grymoire.crd.ge.com (Bruce Barnett)
+ Msg-ID: <199704111800.OAA27297@grymoire.crd.ge.com>
+ Date: Fri, 11 Apr 1997 14:00:54 -0400
+ Files: lib/diagnostics.pm
+
+ Title: "Use B<> for options in Class::Struct pod"
+ From: Hugo van der Sanden <hv@iii.co.uk>
+ Msg-ID: <334D2E7B.67F0@iii.co.uk>
+ Date: Thu, 10 Apr 1997 19:16:27 +0100
+ Files: lib/Class/Struct.pm
+
+ Title: "Explain //g and \G issues"
+ From: Gurusamy Sarathy
+ Msg-ID: <199704122048.QAA25060@aatma.engin.umich.edu>
+ Date: Sat, 12 Apr 1997 16:48:41 -0400
+ Files: pod/perldelta.pod pod/perlop.pod pod/perlre.pod
+
+ Title: "more (err, less) doubled words"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199704111931.WAA24460@alpha.hut.fi>
+ Date: Fri, 11 Apr 1997 22:31:25 +0300 (EET DST)
+ Files: ext/DB_File/DB_File.pm ext/DynaLoader/DynaLoader.pm
+ ext/IO/lib/IO/Pipe.pm lib/CGI.pm lib/Exporter.pm
+ lib/ExtUtils/MakeMaker.pm lib/IPC/Open2.pm lib/IPC/Open3.pm
+ lib/vars.pm pod/perlcall.pod pod/perldiag.pod
+ pod/perlfaq1.pod pod/perlfaq3.pod pod/perlfaq5.pod
+ pod/perlfaq7.pod pod/perlfaq8.pod pod/perlipc.pod
+
+ Title: "Freudian slip error in perlsub.pod"
+ From: barnett@grymoire.crd.ge.com (Bruce Barnett)
+ Msg-ID: <199704111755.NAA27200@grymoire.crd.ge.com>
+ Date: Fri, 11 Apr 1997 13:55:07 -0400
+ Files: pod/perlsub.pod
+
+ Title: "Little patch for perl5.003_97c/pod/perlpod.pod"
+ From: rse@engelschall.com (Ralf S. Engelschall)
+ Msg-ID: <199704112048.WAA08733@en1.engelschall.com>
+ Date: Fri, 11 Apr 1997 22:48:37 +0200
+ Files: pod/perlpod.pod
+
+
+-----------------
+Version 5.003_97c
+-----------------
+
+That second public beta will be Real Soon Now...
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Refine setgroups() behavior of C<$)>"
+ From: Chip Salzenberg
+ Files: mg.c pod/perldelta.pod pod/perlvar.pod
+
+ Title: "Forbid -[Mm] on #! line"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perldiag.pod toke.c
+
+ CORE PORTABILITY
+
+ Title: "Fix dynamic loading (and argv[0]) under AmigaOS"
+ From: Norbert Pueschel
+ Msg-ID: <77724842@Armageddon.meb.uni-bonn.de>
+ Date: Tue, 08 Apr 1997 22:01:45 +0200
+ Files: hints/amigaos.sh
+
+ Title: "Special mkdir() for VMS"
+ From: Charles Bailey
+ Msg-ID: <01IHGOXN6MZM0004K3@hmivax.humgen.upenn.edu>
+ Date: Tue, 08 Apr 1997 12:33:56 -0400 (EDT)
+ Files: dosish.h lib/ExtUtils/MM_Unix.pm lib/File/Path.pm os2/os2ish.h
+ plan9/plan9ish.h pp_sys.c unixish.h vms/vms.c vms/vmsish.h
+
+ OTHER CORE CHANGES
+
+ Title: "Fix assignment from magic SV that becomes a glob"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ BUILD PROCESS
+
+ Title: "Fix syntax error in Configure comment(!)"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "For Solaris, if -DDEBUGGING, default to '-KPIC', not '-Kpic'"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Fix usage of dXSUB_SYS, esp. in ExtUtils::Miniperl"
+ From: Chip Salzenberg
+ Files: dosish.h minimod.pl os2/os2ish.h plan9/plan9ish.h vms/vmsish.h
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Replace Class::Template with improved Class::Struct"
+ From: Jim Miner <jfm@winternet.com>
+ Files: MANIFEST lib/Class/Struct.pm lib/Class/Template.pm
+ lib/File/stat.pm lib/Net/hostent.pm lib/Net/netent.pm
+ lib/Net/protoent.pm lib/Net/servent.pm lib/Time/gmtime.pm
+ lib/Time/localtime.pm lib/Time/tm.pm lib/User/grent.pm
+ lib/User/pwent.pm pod/perldelta.pod pod/perlfaq7.pod
+ pod/perlmod.pod pod/perltoot.pod
+
+ Title: "MakeMaker pathname patch"
+ From: Nick Ing-Simmons
+ Msg-ID: <199704091908.UAA00877@ni-s.u-net.com>
+ Date: Wed, 9 Apr 1997 20:08:23 +0100
+ Files: lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm
+
+ Title: "Fix configuration of new socket"
+ From: Chip Salzenberg
+ Files: ext/IO/lib/IO/Socket.pm
+
+ Title: "Improve IO::Handle docs; don't export _open_mode_string"
+ From: Chip Salzenberg
+ Files: ext/IO/lib/IO/File.pm ext/IO/lib/IO/Handle.pm
+
+ Title: "Complex.pm: 0**0 sanity"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199704091804.VAA13930@alpha.hut.fi>
+ Date: Wed, 9 Apr 1997 21:04:23 +0300 (EET DST)
+ Files: lib/Math/Complex.pm
+
+ Title: "Fix typos in Math::Trig"
+ From: Jarkko Hietaniemi
+ Files: lib/Math/Trig.pm
+
+ TESTS
+
+ Title: "Accommodate CodeBuilder variant of Machten 4.0.3"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03020902af704d320f27@[194.51.248.88]>
+ Date: Tue, 8 Apr 1997 22:15:15 +0200
+ Files: t/io/fs.t t/op/stat.t
+
+ UTILITIES
+
+ (no changes)
+
+ DOCUMENTATION
+
+ Title: "IO::Socket doc fix"
+ From: Roderick Schertler
+ Msg-ID: <28383.860527843@eeyore.ibcinc.com>
+ Date: Tue, 08 Apr 1997 15:30:43 -0400
+ Files: ext/IO/lib/IO/Socket.pm
+
+
+-----------------
+Version 5.003_97b
+-----------------
+
+Working on the second public beta...
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Make assignment to C<$)> call setgroups()"
+ From: Chip Salzenberg
+ Files: Configure config_H config_h.SH mg.c plan9/config.plan9
+ pod/perldelta.pod vms/config.vms win32/config.H
+ win32/config.w32
+
+ Title: "Grandfather "$$<digit>" in strings"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod toke.c
+
+ Title: "Disconnect warn and die hooks _after_ object destruction"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ Title: "Forbid recursive substitutions"
+ From: Chip Salzenberg
+ Files: cop.h pod/perldelta.pod pod/perldiag.pod pp_ctl.c pp_hot.c
+
+ CORE PORTABILITY
+
+ Title: "Use SSize_t for values of PerlIO_{read,write}"
+ From: Chip Salzenberg
+ Files: perlio.c perlio.h perlsdio.h pp_sys.c
+
+ Title: "perlwin-97a_4: win32 environ fix"
+ From: Gurusamy Sarathy
+ Msg-ID: <199704060431.XAA23400@aatma.engin.umich.edu>
+ Date: Sat, 05 Apr 1997 23:31:11 -0500
+ Files: win32/win32.c win32/win32io.c win32/win32io.h win32/win32iop.h
+
+ OTHER CORE CHANGES
+
+ Title: "length($') isn't"
+ From: Gurusamy Sarathy
+ Msg-ID: <199704070730.DAA07310@aatma.engin.umich.edu>
+ Date: Mon, 07 Apr 1997 03:30:44 -0400
+ Files: mg.c
+
+ Title: "Fix obscure regex bug related to leading C<.*>"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Add warning for glob failure"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perldiag.pod pp_hot.c
+
+ Title: "Fix C<perl -V> in presence of local patches"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ BUILD PROCESS
+
+ Title: "Don't suggest 'Configure -der' in config.sh comments"
+ From: Chip Salzenberg
+ Files: Configure
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "CGI->redirect patch"
+ From: Doug MacEachern
+ Msg-ID: <199704051527.KAA11280@postman.osf.org>
+ Date: Sat, 05 Apr 1997 10:27:52 -0500
+ Files: lib/CGI.pm
+
+ Title: "Updates to Math::Complex and Math::Trig"
+ From: Jarkko Hietaniemi
+ Files: lib/Math/Complex.pm lib/Math/Trig.pm pod/perldelta.pod
+ t/lib/complex.t
+
+ Title: "Fix FindBin under Win32, and document success"
+ From: Nick Ing-Simmons and Gurusamy Sarathy
+ Msg-ID: <199704051504.QAA09507@ni-s.u-net.com>
+ Date: Sat, 5 Apr 1997 16:04:52 +0100
+ Files: README.win32 lib/Cwd.pm lib/FindBin.pm
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ Title: "Patch for 'perldoc -f'"
+ From: Gisle Aas
+ Msg-ID: <199704061732.TAA00353@bergen.sn.no>
+ Date: Sun, 6 Apr 1997 19:32:04 +0200
+ Files: utils/perldoc.PL
+
+ DOCUMENTATION
+
+ Title: "Document required module versions"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "Document sample function perl_eval()"
+ From: Doug MacEachern
+ Msg-ID: <199704051524.KAA06090@postman.osf.org>
+ Date: Sat, 05 Apr 1997 10:24:43 -0500
+ Files: pod/perlcall.pod pod/perlembed.pod
+
+ Title: "Make L<perltrap> refer to L<perldelta>"
+ From: Chip Salzenberg
+ Files: pod/perltrap.pod
+
+
+-----------------
+Version 5.003_97a
+-----------------
+
+This release gets a letter instead of a full subversion because I'm
+planning on making 5.003_98 the second public beta.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Fix AUTOLOAD, or kill me"
+ From: Chip Salzenberg
+ Files: gv.c pp.c t/op/method.t
+
+ CORE PORTABILITY
+
+ Title: "Add support for Cygwin32 (GNU-Win32) -- very low impact"
+ From: John Cerney <j-cerney1@ti.com>
+ Msg-ID: <199704030821.JAA08762@pluto.tiuk.ti.com>
+ Date: Thu, 3 Apr 1997 09:21:17 +0100
+ Files: MANIFEST README.cygwin32 cygwin32/cw32imp.h cygwin32/gcc2
+ cygwin32/ld2 cygwin32/perlgcc cygwin32/perlld
+ ext/DynaLoader/dl_cygwin32.xs hints/cygwin32.sh perl.h
+ pp_sys.c
+
+ Title: "Win32 update (six patches)"
+ From: Gurusamy Sarathy
+ Files: MANIFEST README.win32 dosish.h t/io/fs.t t/io/tell.t
+ t/lib/io_tell.t t/op/magic.t t/op/mkdir.t t/op/runlevel.t
+ t/op/stat.t t/op/taint.t win32/Makefile win32/VC-2.0/pod.mak
+ win32/makedef.pl win32/pod.mak win32/win32.c win32/win32.h
+ win32/win32io.c win32/win32io.h win32/win32iop.h
+
+ Title: "AmigaOS update"
+ From: Norbert Pueschel
+ Msg-ID: <77724828@Armageddon.meb.uni-bonn.de>
+ Date: Thu, 03 Apr 1997 16:16:51 +0200
+ Files: README.amiga hints/amigaos.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Fix const-sub-related panic on C<sub foo { my $x; 0 } foo>"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Fix warning for useless C<1..2>"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Minor cleanups"
+ From: Gurusamy Sarathy
+ Msg-ID: <199704040056.TAA22253@aatma.engin.umich.edu>
+ Date: Thu, 03 Apr 1997 19:56:57 -0500
+ Files: mg.c mg.h perl.c
+
+ Title: "Eliminate unreliable warning with %SIG and strict refs"
+ From: Chip Salzenberg
+ Files: mg.c
+
+ Title: "Fix impossible test in vivification"
+ From: Chip Salzenberg
+ Files: mg.c
+
+ Title: "runlevel is I32, not int"
+ From: Roderick Schertler
+ Msg-ID: <2848.860109823@eeyore.ibcinc.com>
+ Date: Thu, 03 Apr 1997 18:23:43 -0500
+ Files: pp_ctl.c util.c
+
+ BUILD PROCESS
+
+ Title: "Re: shared lib compilation problem with miniperl5.003_97"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970404124326.647K-100000@fractal.lafayette.ed
+ Date: Fri, 04 Apr 1997 13:02:23 -0500 (EST)
+ Files: Makefile.SH
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Math::Trig, based on (and from an author of) Math::Complex"
+ From: Chip Salzenberg
+ Files: MANIFEST lib/Math/Complex.pm lib/Math/Trig.pm
+ pod/perldelta.pod t/lib/complex.t t/lib/trig.t
+
+ Title: "Update AutoLoader and docs; support C<use AutoLoader 'AUTOLOAD'>"
+ From: Chip Salzenberg and Tim Bunce
+ Files: lib/AutoLoader.pm
+
+ Title: "CPAN & TRL-Gnu"
+ From: Achim Bohnet <ach@rosat.mpe-garching.mpg.de>
+ Msg-ID: <9704040809.AA26143@o09.rosat.mpe-garching.mpg.de>
+ Date: Fri, 04 Apr 1997 10:09:03 +0200
+ Files: lib/CPAN.pm
+
+ Title: "Limit @ISA to actual DBM in AnyDBM"
+ From: Chip Salzenberg
+ Files: lib/AnyDBM_File.pm
+
+ Title: "Don't use $4 when it might be undef"
+ From: Chip Salzenberg
+ Files: lib/bigfloat.pl
+
+ TESTS
+
+ Title: "Make *dbm tests work with Win32"
+ From: Chip Salzenberg
+ Files: t/lib/anydbm.t t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t
+ t/lib/sdbm.t
+
+ UTILITIES
+
+ (no changes)
+
+ DOCUMENTATION
+
+ Title: "Update INSTALL"
+ From: Andy Dougherty
+ Files: INSTALL
+
+ Title: "Pod style"
+ From: Nathan Torkington <gnat@prometheus.frii.com>
+ Files: pod/perlcall.pod pod/perldata.pod pod/perldebug.pod
+ pod/perldiag.pod pod/perlform.pod pod/perlfunc.pod
+ pod/perlipc.pod pod/perllocale.pod pod/perlmod.pod
+ pod/perlop.pod pod/perlre.pod pod/perlrun.pod
+ pod/perlstyle.pod pod/perltoc.pod pod/perlvar.pod
+
+
+----------------
+Version 5.003_97
+----------------
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Reenable but deprecate inherited AUTOLOAD for plain funcs"
+ From: Chip Salzenberg
+ Files: ext/DynaLoader/DynaLoader.pm gv.c lib/Text/ParseWords.pm
+ pod/perldelta.pod pod/perldiag.pod t/op/method.t
+
+ CORE PORTABILITY
+
+ Title: "Don't use setjmp() and longjmp() in complex exprs"
+ From: Chip Salzenberg
+ Files: perl.c pp_ctl.c scope.h
+
+ Title: "Improve definition of Sock_size_t"
+ From: Chip Salzenberg
+ Files: doio.c pp_sys.c
+
+ Title: "Don't use a completely empty macro parameter"
+ From: Chip Salzenberg
+ Files: sv.h
+
+ Title: "Win32 update"
+ From: Gurusamy Sarathy
+ Msg-ID: <199704020608.BAA29538@aatma.engin.umich.edu>
+ Date: Wed, 02 Apr 1997 01:08:09 -0500
+ Files: win32/VC-2.0/modules.mak win32/VC-2.0/perl.mak win32/VC-
+ 2.0/perldll.mak win32/perl.mak
+
+ OTHER CORE CHANGES
+
+ Title: "Introduce and use gv_fetchmethod_autoload()"
+ From: Chip Salzenberg
+ Files: global.sym gv.c pod/perlguts.pod proto.h universal.c
+
+ Title: "Reduce memory footprint of literal strings"
+ From: ilya@math.ohio-state.edu (Ilya Zakharevich)
+ Msg-ID: <1997Apr1.113438.1913905@hmivax.humgen.upenn.edu>
+ Date: Tue, 01 Apr 1997 11:34:37 -0500 (EST)
+ Files: toke.c
+
+ BUILD PROCESS
+
+ Title: "Remove target before link() of perldiag.pod"
+ From: Chip Salzenberg
+ Files: installperl
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Refresh CPAN to 1.24"
+ From: Andreas Koenig
+ Files: lib/CPAN.pm lib/CPAN/FirstTime.pm
+
+ Title: "Refresh ExtUtils::Manifest to 1.33"
+ From: Andreas Koenig
+ Files: lib/ExtUtils/Manifest.pm
+
+ Title: "Update $VERSION of ExtUtils::Embed to reflect reality"
+ From: Chip Salzenberg
+ Files: lib/ExtUtils/Embed.pm
+
+ Title: "Fix POSIX::raise()"
+ From: "Jens T. Berger Thielemann" <jensthi@ifi.uio.no>
+ Msg-ID: <Pine.SUN.3.91.970401153125.8053A-100000@holmenkollen.ifi.uio
+ Date: Tue, 1 Apr 1997 15:34:47 +0200 (MET DST)
+ Files: ext/POSIX/POSIX.pm
+
+ Title: "Eliminate warnings in File::Basename"
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Msg-ID: <11173.9704011111@tempest.cise.npl.co.uk>
+ Date: Tue, 1 Apr 97 12:11:43 BST
+ Files: lib/File/Basename.pm t/lib/basename.t
+
+ Title: "Eliminate warning in CGI.pm"
+ From: Chip Salzenberg
+ Files: lib/CGI.pm
+
+ Title: "Tweaks to constant.pm"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.96.970331205519.16684I-100000@kelly.teleport.com>
+ Date: Mon, 31 Mar 1997 21:10:14 -0800 (PST)
+ Files: lib/constant.pm
+
+ Title: "Document eval vs. sub in Benchmark"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199704012231.XAA00225@crypt.compulink.co.uk>
+ Date: Tue, 01 Apr 1997 23:31:55 +0100
+ Files: lib/Benchmark.pm
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ Title: "Improve heuristics for pod2man titles"
+ From: Roderick Schertler
+ Msg-ID: <pzn2ri9gto.fsf@eeyore.ibcinc.com>
+ Date: 01 Apr 1997 23:41:55 -0500
+ Files: pod/pod2man.PL
+
+ DOCUMENTATION
+
+ Title: "Clean up some poddities, and make C<make html> work again"
+ From: Chip Salzenberg
+ Files: pod/Makefile pod/perldelta.pod pod/perldiag.pod
+ pod/perlfaq8.pod pod/perlfunc.pod pod/perlop.pod
+ pod/perltrap.pod
+
+ Title: "Fix MM doc's use of "SUPER::""
+ From: avera@hal.com (Jim Avera)
+ Msg-ID: <9704012235.AA07841@membrane.hal.com>
+ Date: Tue, 1 Apr 1997 14:35:26 -0800 (PST)
+ Files: lib/ExtUtils/MakeMaker.pm
+
+ Title: "Eliminate pod warnings in libs"
+ From: Chip Salzenberg
+ Files: lib/CGI.pm lib/ExtUtils/Command.pm
+
+
+----------------
+Version 5.003_96
+----------------
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Support $ENV{PERL5OPT}"
+ From: Chip Salzenberg
+ Files: perl.c pod/perldiag.pod pod/perldelta.pod pod/perlrun.pod
+
+ Title: "Implement void context, in which C<wantarray> is undef"
+ From: Chip Salzenberg
+ Files: cop.h doop.c dump.c global.sym gv.c op.c op.h perl.c
+ pod/perlcall.pod pod/perldelta.pod pod/perlfunc.pod
+ pod/perlguts.pod pod/perlsub.pod pp.c pp_ctl.c pp_hot.c
+ pp_sys.c proto.h
+
+ Title: "Don't look up &AUTOLOAD in @ISA when calling plain function"
+ From: Chip Salzenberg
+ Files: global.sym gv.c lib/Text/ParseWords.pm pod/perldelta.pod
+ pp_hot.c proto.h t/op/method.t
+
+ Title: "Allow closures to be constant subroutines"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Make C<scalar(reverse)> mean C<scalar(reverse $_)>"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Fix lexical suicide from C<my $x = $x> in sub"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Make "Unrecog. char." fatal, and update its doc"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod toke.c
+
+ Title: "Die on patterns that will match empty string forever"
+ From: Stephen Potter <spp@psa.pencom.com>
+ Msg-ID: <199703282138.PAA28311@psa.pencom.com>
+ Date: Fri, 28 Mar 1997 15:38:30 -0600
+ Files: regcomp.c
+
+ CORE PORTABILITY
+
+ Title: "safefree() mismatch"
+ From: Roderick Schertler
+ Msg-ID: <21338.859653381@eeyore.ibcinc.com>
+ Date: Sat, 29 Mar 1997 11:36:21 -0500
+ Files: util.c
+
+ Title: "FreeBSD update"
+ From: Slaven Rezic <eserte@cs.tu-berlin.de>
+ Msg-ID: <199703311417.QAA04162@cabulja.herceg.de>
+ Date: Mon, 31 Mar 1997 16:17:42 +0200 (MET DST)
+ Files: hints/freebsd.sh
+
+ Title: "Win32 update (seven patches)"
+ From: Gurusamy Sarathy and Nick Ing-Simmons
+ Files: EXTERN.h MANIFEST win32/Makefile win32/perl.mak
+ win32/perl.rc win32/perldll.mak win32/makedef.pl
+ win32/modules.mak win32/win32io.c win32/bin/pl2bat.bat
+
+ OTHER CORE CHANGES
+
+ Title: "Report PERL* environment variables in -V and perlbug"
+ From: Chip Salzenberg
+ Files: perl.c utils/perlbug.PL
+
+ Title: "Typo in perl.c: Printing NO_EMBED for perl -V"
+ From: Gisle Aas
+ Msg-ID: <199703301922.VAA13509@furubotn.sn.no>
+ Date: Sun, 30 Mar 1997 21:22:11 +0200
+ Files: perl.c
+
+ Title: "Don't let C<$var = $var> untaint $var"
+ From: Chip Salzenberg
+ Files: pp_hot.c pp_sys.c sv.h t/op/taint.t
+
+ Title: "Fix autoviv bug in C<my $x; ++$x->{KEY}>"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Re: 5.004's new srand() default seed"
+ From: Hallvard B Furuseth
+ Msg-ID: <199703302219.AAA20998@bombur2.uio.no>
+ Date: Mon, 31 Mar 1997 00:19:13 +0200 (MET DST)
+ Files: pp.c
+
+ Title: "Re: embedded perl and top_env problem "
+ From: Gurusamy Sarathy
+ Msg-ID: <199703280031.TAA05711@aatma.engin.umich.edu>
+ Date: Thu, 27 Mar 1997 19:31:42 -0500
+ Files: gv.c interp.sym perl.c perl.h pp_ctl.c pp_sys.c scope.h util.c
+
+ Title: "Define and use new macro: boolSV()"
+ From: Tim Bunce
+ Files: gv.c lib/ExtUtils/typemap os2/os2.c pp.c pp_hot.c pp_sys.c
+ sv.c sv.h universal.c vms/vms.c
+
+ Title: "Re: strict @F"
+ From: Hallvard B Furuseth
+ Msg-ID: <199703252110.WAA16038@bombur2.uio.no>
+ Date: Tue, 25 Mar 1997 22:10:33 +0100 (MET)
+ Files: toke.c
+
+ Title: "Try harder to identify errors at EOF"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Minor string change in toke.c: 'bareword'"
+ From: lvirden@cas.org
+ Msg-ID: <1997Mar27.130247.1911552@hmivax.humgen.upenn.edu>
+ Date: Thu, 27 Mar 1997 13:02:46 -0500 (EST)
+ Files: toke.c
+
+ Title: "Improve diagnostic on \r in program text"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod toke.c
+
+ Title: "Make Sock_size_t typedef work right"
+ From: Chip Salzenberg
+ Files: perl.h pp_sys.c
+
+ Title: "Eliminate unused dummy variable"
+ From: Doug MacEachern
+ Msg-ID: <199703270123.UAA25454@postman.osf.org>
+ Date: Wed, 26 Mar 1997 20:23:14 -0500
+ Files: lib/ExtUtils/Embed.pm unixish.h writemain.SH
+
+ BUILD PROCESS
+
+ Title: "Allow for coexistence of various versions of perldiag.pod"
+ From: Chip Salzenberg
+ Files: installperl lib/diagnostics.pm
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "New module constant.pm"
+ From: Tom Phoenix
+ Files: MANIFEST lib/constant.pm op.c pp.c t/pragma/constant.t
+
+ Title: "Remove chat2"
+ From: Chip Salzenberg
+ Files: MANIFEST lib/chat2.inter lib/chat2.pl
+
+ Title: "Include CGI.pm 2.32"
+ From: Chip Salzenberg
+ Files: MANIFEST eg/cgi/* lib/CGI.pm lib/CGI/Apache.pm
+ lib/CGI/Carp.pm lib/CGI/Fast.pm lib/CGI/Push.pm
+ lib/CGI/Switch.pm
+
+ Title: "Fix C<print $_> in debugger"
+ From: Ilya Zakharevich
+ Msg-ID: <199703312355.SAA01068@monk.mps.ohio-state.edu>
+ Date: Mon, 31 Mar 1997 18:55:55 -0500 (EST)
+ Files: lib/perl5db.pl
+
+ Title: "Re: Pod problems & fixes"
+ From: Hallvard B Furuseth
+ Msg-ID: <199703261829.TAA17015@bombur2.uio.no>
+ Date: Wed, 26 Mar 1997 19:29:14 +0100 (MET)
+ Files: lib/Pod/Text.pm
+
+ Title: "Re: $whoami calculation in Sys::Syslog.pm should not be greedy"
+ From: Roderick Schertler
+ Msg-ID: <pz4tdu7j57.fsf@eeyore.ibcinc.com>
+ Date: 29 Mar 1997 11:33:24 -0500
+ Files: lib/Sys/Syslog.pm
+
+ Title: "C<new SelectSaver $fh> doesn't always restore"
+ From: Spider Boardman
+ Msg-ID: <199703291906.OAA07232@Orb.Nashua.NH.US>
+ Date: Sat, 29 Mar 1997 14:06:37 -0500
+ Files: lib/SelectSaver.pm
+
+ Title: "Patch for Benchmark.pm"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk> w/Tim Bunce
+ Msg-ID: <199703291504.PAA01596@crypt.compulink.co.uk>
+ Date: Sat, 29 Mar 1997 15:04:32 +0000
+ Files: lib/Benchmark.pm
+
+ Title: "Tiny doc fix for AutoSplit.pm"
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Msg-ID: <rjray-9702272117.AA001223633@snakepit.ecte.uswc.uswest.com>
+ Date: Thu, 27 Mar 1997 14:17:38 -0700
+ Files: lib/AutoSplit.pm
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ Title: "Tom C's Pod::Html and html tools, as of 30 March 97"
+ From: Chip Salzenberg
+ Files: MANIFEST installhtml lib/Pod/Html.pm pod/pod2html.PL
+
+ Title: "Fix path bugs in installhtml"
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Msg-ID: <3180.9703270906@tempest.cise.npl.co.uk>
+ Date: Thu, 27 Mar 97 09:06:14 GMT
+ Files: installhtml
+
+ Title: "Make perlbug say that it's only for core Perl bugs"
+ From: Chip Salzenberg
+ Files: utils/perlbug.PL
+
+ DOCUMENTATION
+
+ Title: "INSTALL-1.11"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970326140905.10178A-100000@fractal.lafayette.
+ Date: Wed, 26 Mar 1997 14:27:52 -0500 (EST)
+ Files: INSTALL
+
+ Title: "Patch for perl.pod"
+ From: wmiddlet@Adobe.COM (William Middleton)
+ Msg-ID: <199703262305.PAA13121@ducks>
+ Date: Wed, 26 Mar 1997 15:05:39 -0800 (PST)
+ Files: pod/perl.pod
+
+ Title: "Document autouse and constant; update diagnostics"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "Suggest to upgraders that they try '-w' again"
+ From: Hallvard B Furuseth
+ Msg-ID: <199703251901.UAA15982@bombur2.uio.no>
+ Date: Tue, 25 Mar 1997 20:01:26 +0100 (MET)
+ Files: pod/perldelta.pod
+
+ Title: "Improve and update documentation of constant subs"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.96.970331122546.14185C-100000@kelly.teleport.com>
+ Date: Mon, 31 Mar 1997 13:05:54 -0800 (PST)
+ Files: pod/perlsub.pod
+
+ Title: "Improve documentation of C<return>"
+ From: Chip Salzenberg
+ Files: pod/perlfunc.pod pod/perlsub.pod
+
+ Title: "perlfunc.pod patch"
+ From: Gisle Aas
+ Msg-ID: <199703262159.WAA17531@furubotn.sn.no>
+ Date: Wed, 26 Mar 1997 22:59:23 +0100
+ Files: pod/perlfunc.pod
+
+ Title: "Use 'while (defined($x = <>)) {}', per <gnat@frii.com>"
+ From: Chip Salzenberg
+ Files: configpm lib/Term/Cap.pm perlsh pod/perlipc.pod pod/perlop.pod
+ pod/perlsub.pod pod/perlsyn.pod pod/perltrap.pod
+ pod/perlvar.pod win32/bin/search.bat
+
+ Title: "Document and test C<%> behavior with negative operands"
+ From: Chip Salzenberg
+ Files: pod/perlop.pod t/op/arith.t
+
+ Title: "Update docs on $]"
+ From: Chip Salzenberg
+ Files: pod/perlvar.pod
+
+ Title: "perlvar.pod patch"
+ From: Gisle Aas
+ Msg-ID: <199703261254.NAA10237@bergen.sn.no>
+ Date: Wed, 26 Mar 1997 13:54:00 +0100
+ Files: pod/perlvar.pod
+
+ Title: "Fix example of C<or> vs. C<||>"
+ From: Chip Salzenberg
+ Files: pod/perlsyn.pod
+
+ Title: "Pod usage and spelling patch"
+ From: Larry W. Virden
+ Files: pod/*.pod
+
+ Title: "Pod updates"
+ From: "Cary D. Renzema" <caryr@mxim.com>
+ Msg-ID: <199703262353.PAA01819@macs.mxim.com>
+ Date: Wed, 26 Mar 1997 15:53:22 -0800 (PST)
+ Files: pod/*.pod
+
+
+----------------
+Version 5.003_95
+----------------
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Don't compile scalar mods of aggregates, like C<@a =~ s/a/b/>"
+ From: Chip Salzenberg
+ Files: op.c t/op/misc.t
+
+ Title: "Automatically flush on C< $| = 1 >"
+ From: Chip Salzenberg
+ Files: mg.c
+
+ Title: "Refine modulus ("%") per suggestion of Tim Goodwin"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "If C<perl -a>, do equivalent of C<use vars '@F'>"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Warn about undef magic values just like non-magic"
+ From: Chip Salzenberg
+ Files: ext/Opcode/Safe.pm sv.c t/lib/db-btree.t t/lib/db-hash.t
+ t/lib/db-recno.t t/pragma/locale.t
+
+ CORE PORTABILITY
+
+ Title: "Remove redundant patch to hints/bsdos.sh"
+ From: Shigeya Suzuki <shigeya@foretune.co.jp>
+ Msg-ID: <19970322222244K.shigeya@foretune.co.jp>
+ Date: Sat, 22 Mar 1997 22:22:44 +0900
+ Files: hints/bsdos.sh
+
+ Title: "Another MachTen Patch"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.96.970324152150.20610P-100000@kelly.teleport.com>
+ Date: Mon, 24 Mar 1997 15:26:48 -0800 (PST)
+ Files: hints/machten_2.sh
+
+ Title: "Win32 update (five patches)"
+ From: Gurusamy Sarathy and Nick Ing-Simmons
+ Files: MANIFEST README.win32 doio.c dosish.h pp_sys.c
+ lib/ExtUtils/Command.pm t/comp/multiline.t t/op/magic.t
+ t/op/mkdir.t t/op/runlevel.t t/op/stat.t t/op/write.t
+ win32/Makefile win32/config.H win32/config.w32 win32/win32.c
+ win32/win32.h win32/win32aux.c win32/*.mak win32/VC-2.0/*.mak
+
+ OTHER CORE CHANGES
+
+ Title: "Fix botch with G_NOARGS; PUSHMARK *is* required"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ Title: "Improve 'prototype mismatch' warning"
+ From: Chip Salzenberg
+ Files: global.sym op.c pod/perldiag.pod proto.h sv.c t/comp/redef.t
+
+ Title: "In perlio, fix vprintf() definition and define vfprintf()"
+ From: Chip Salzenberg
+ Files: perlio.c
+
+ BUILD PROCESS
+
+ (no other changes)
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Fix C<require> in Getopt::Long to work with 5.003"
+ From: Chip Salzenberg
+ Files: lib/Getopt/Long.pm
+
+ Title: "Extraneous blank lines from Pod::Text"
+ From: Russ Allbery <rra@stanford.edu>
+ Msg-ID: <qumend4qq08.fsf@cyclone.stanford.edu>
+ Date: 25 Mar 1997 01:28:55 -0800
+ Files: lib/Pod/Text.pm
+
+ Title: "Exporting UNIVERSAL::can"
+ From: "M.J.T. Guy"
+ Msg-ID: <E0w9DwX-0000Zr-00@taurus.cus.cam.ac.uk>
+ Date: Mon, 24 Mar 1997 17:54:01 +0000
+ Files: lib/UNIVERSAL.pm
+
+ Title: "Term::Readline patch for AmigaOS"
+ From: Norbert Pueschel
+ Msg-ID: <77724797@Armageddon.meb.uni-bonn.de>
+ Date: Sun, 23 Mar 1997 18:57:22 +0100
+ Files: lib/Term/ReadLine.pm
+
+ TESTS
+
+ Title: "Reduce memory footprint of complex.t"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03020902af5d8e03c5ab@[194.51.248.84]>
+ Date: Tue, 25 Mar 1997 15:39:26 +0100
+ Files: t/lib/complex.t
+
+ UTILITIES
+
+ Title: "Improve pod2man diagnostic when NAME is invalid"
+ From: Chip Salzenberg
+ Files: pod/pod2man.PL
+
+ DOCUMENTATION
+
+ Title: "INSTALL-1.8 to INSTALL-1.9 updates"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970325135138.3374A-100000@fractal.lafayette.e
+ Date: Tue, 25 Mar 1997 13:52:53 -0500 (EST)
+ Files: INSTALL
+
+ Title: "Document possible problems with -Mdiagnostics after upgrade"
+ From: Chip Salzenberg
+ Files: INSTALL
+
+ Title: "Mention perldelta in INSTALL"
+ From: Chip Salzenberg
+ Files: INSTALL
+
+ Title: "Describe pod format at top of INSTALL"
+ From: Chip Salzenberg
+ Files: INSTALL
+
+ Title: "Document C</a *b/x> fix"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "pods for subroutine argument autovivication"
+ From: "M.J.T. Guy"
+ Msg-ID: <E0w9489-0005YT-00@ursa.cus.cam.ac.uk>
+ Date: Mon, 24 Mar 1997 07:25:21 +0000
+ Files: pod/perldelta.pod pod/perlsub.pod
+
+ Title: "Missing item in perldiag"
+ From: "M.J.T. Guy"
+ Msg-ID: <E0w8jVZ-0005va-00@ursa.cus.cam.ac.uk>
+ Date: Sun, 23 Mar 1997 09:24:09 +0000
+ Files: pod/perldiag.pod
+
+ Title: "Mention and discourage use of term 'soft reference'"
+ From: Chip Salzenberg
+ Files: pod/perlref.pod
+
+ Title: "Pod problems & fixes"
+ From: Hallvard B Furuseth
+ Msg-ID: <199703242031.VAA14997@bombur2.uio.no>
+ Date: Mon, 24 Mar 1997 21:31:51 +0100 (MET)
+ Files: INSTALL lib/Term/Complete.pm lib/subs.pm pod/perlcall.pod
+ pod/perldata.pod pod/perldiag.pod pod/perlembed.pod
+ pod/perlguts.pod pod/perlmod.pod pod/perlop.pod
+ pod/perlpod.pod pod/pod2html.PL
+
+ Title: "DB_File documentation fix"
+ From: Paul Marquess
+ Msg-ID: <9703240854.AA08401@claudius.bfsec.bt.co.uk>
+ Date: Mon, 24 Mar 97 08:54:16 GMT
+ Files: ext/DB_File/DB_File.pm
+
+ Title: "FAQ update"
+ From: Nathan Torkington <gnat@prometheus.frii.com>
+ Files: pod/perlfaq*.pod
+
+
+----------------
+Version 5.003_94
+----------------
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Defer creation of array and hash elements as parameters"
+ From: Chip Salzenberg
+ Files: dump.c global.sym mg.c op.c op.h perl.h pp.c pp_hot.c proto.h
+ sv.c
+
+ Title: "New special literal: __PACKAGE__"
+ From: Chip Salzenberg
+ Files: keywords.pl pod/perldata.pod toke.c
+
+ Title: "Ignore whitespace before +*? in //x"
+ From: Chip Salzenberg
+ Files: regcomp.c
+
+ Title: "Abort compilation at C<BEGIN{}> or C<use> after errors"
+ From: Chip Salzenberg
+ Files: op.c pod/perldiag.pod t/pragma/subs.t
+
+ Title: "allow C<substr 'hello', -10>"
+ From: David Dyck <dcd@tc.fluke.com>
+ Msg-ID: <97Mar10.155517pst.35716-2@gateway.fluke.com>
+ Date: Mon, 10 Mar 1997 15:55:44 -0800
+ Files: pp.c
+
+ Title: "Regularize C<x % y>, esp. when y is negative"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Flush before C<flock(FOO, LOCK_UN)>"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perlfunc.pod pp_sys.c
+
+ Title: "Close loopholes in prototype mismatch warning"
+ From: Chip Salzenberg
+ Files: op.c sv.c toke.c
+
+ Title: "Warn on C<while ($x = each %y) {}>"
+ From: Chip Salzenberg
+ Files: op.c pod/perldiag.pod
+
+ Title: "Don't warn on C<print $fh func()>"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ CORE PORTABILITY
+
+ Title: "Don't say 'static var = 1'"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199703091319.PAA24714@alpha.hut.fi>
+ Date: Sun, 9 Mar 1997 15:19:57 +0200 (EET)
+ Files: malloc.c
+
+ Title: "BSD/OS 3.0 hints"
+ From: Christopher Davis <ckd@loiosh.kei.com>
+ Msg-ID: <w47mjakw5t.fsf@loiosh.kei.com>
+ Date: 14 Mar 1997 16:20:46 -0500
+ Files: hints/bsdos.sh
+
+ Title: "More MachTen hints"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95q.970316133852.27997A-100000@kelly.teleport.com
+ Date: Sun, 16 Mar 1997 13:40:35 -0800 (PST)
+ Files: hints/machten_2.sh
+
+ Title: "HP/UX hint comments"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970321153918.28770B-100000@fractal.lafayette.
+ Date: Fri, 21 Mar 1997 15:43:07 -0500 (EST)
+ Files: hints/hpux.sh
+
+ Title: "VMS update"
+ From: Charles Bailey
+ Msg-ID: <1997Mar11.220056.1873182@hmivax.humgen.upenn.edu>
+ Date: Tue, 11 Mar 1997 22:00:55 -0500 (EST)
+ Files: lib/ExtUtils/MM_VMS.pm lib/Test/Harness.pm t/op/taint.t
+ utils/perlbug.PL vms/descrip.mms
+
+ Title: "vmsish.t and related patches"
+ From: Charles Bailey
+ Msg-ID: <01IGQW3IP1KK005VFB@hmivax.humgen.upenn.edu>
+ Date: Fri, 21 Mar 1997 01:32:47 -0500 (EST)
+ Files: MANIFEST perl.h vms/descrip.mms vms/ext/vmsish.t vms/vms.c
+
+ Title: "Win32 update (four patches)"
+ From: Gurusamy Sarathy and Nick Ing-Simmons
+ Files: MANIFEST README.win32 lib/AutoSplit.pm lib/Cwd.pm
+ lib/ExtUtils/Command.pm lib/ExtUtils/Install.pm
+ lib/ExtUtils/MM_OS2.pm lib/ExtUtils/MM_Unix.pm
+ lib/ExtUtils/MM_Win32.pm lib/ExtUtils/MakeMaker.pm
+ lib/ExtUtils/Mksymlists.pm lib/File/Basename.pm
+ lib/File/Path.pm mg.c t/comp/cpp.t t/comp/script.t t/harness
+ t/io/argv.t t/io/dup.t t/io/fs.t t/io/inplace.t
+ t/lib/filehand.t t/lib/io_dup.t t/lib/io_sel.t
+ t/lib/io_taint.t t/op/closure.t t/op/exec.t t/op/glob.t
+ t/op/goto.t t/op/magic.t t/op/misc.t t/op/rand.t
+ t/op/split.t t/op/stat.t t/op/sysio.t t/op/taint.t
+ t/pragma/strict.t t/pragma/subs.t t/pragma/warning.t util.c
+ win32/*
+
+ OTHER CORE CHANGES
+
+ Title: "Guard against buffer overflow in yyerror() and related funcs"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "For bin compat, rename calllist() and he_{,delay}free"
+ From: Chip Salzenberg
+ Files: global.sym hv.c op.c perl.c pod/perlguts.pod proto.h
+
+ Title: "Fix C<print> on tied default handle"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Fix C<local($a, undef, $b) = (1,2,3)>"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Improve diagnostic on C<@a++>, C<--%a>, @a =~ s/a/b/"
+ From: Chip Salzenberg
+ Files: pp.c pp_hot.c
+
+ Title: "Don't warn on C<$x{y} .= "z"> when %x is tied"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Eliminate 'unreachable code' warnings"
+ From: Chip Salzenberg
+ Files: ext/POSIX/POSIX.xs mg.c pp_ctl.c toke.c
+
+ Title: "printf format corrections for -DDEBUGGING"
+ From: Roderick Schertler
+ Msg-ID: <26592.858793370@eeyore.ibcinc.com>
+ Date: Wed, 19 Mar 1997 12:42:50 -0500
+ Files: doop.c malloc.c op.c pp_ctl.c regexec.c sv.c x2p/str.c
+ x2p/util.c
+
+ Title: "Warn about missing -DMULTIPLICITY if likely a problem"
+ From: Doug MacEachern
+ Msg-ID: <199703192345.SAA15070@postman.osf.org>
+ Date: Wed, 19 Mar 1997 18:45:53 -0500
+ Files: perl.c
+
+ BUILD PROCESS
+
+ Title: "Don't use $(LIBS) when creating shared libperl"
+ From: Chip Salzenberg
+ Files: Makefile.SH
+
+ Title: "Don't use db 2.x, we're not yet ready for it"
+ From: Paul Marquess and Andy Dougherty
+ Files: Configure
+
+ Title: "Warn if #! command is longer than 32 chars"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "patches re perl -wc install{perl,man}"
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Msg-ID: <21544.9703111313@tempest.cise.npl.co.uk>
+ Date: Tue, 11 Mar 97 13:13:16 GMT
+ Files: installman installperl
+
+ Title: "3_93 doesn't install pods"
+ From: Spider Boardman
+ Msg-ID: <199703160721.CAA08339@Orb.Nashua.NH.US>
+ Date: Sun, 16 Mar 1997 02:21:35 -0500
+ Files: installperl
+
+ Title: "When installing, use File::Copy instead of `cp`"
+ From: Chip Salzenberg
+ Files: installperl
+
+ Title: "Make hint files' warnings more visible"
+ From: Hallvard B Furuseth
+ Msg-ID: <199703202218.XAA09041@bombur2.uio.no>
+ Date: Thu, 20 Mar 1997 23:18:03 +0100 (MET)
+ Files: hints/3b1.sh hints/apollo.sh hints/cxux.sh hints/dcosx.sh
+ hints/dgux.sh hints/esix4.sh hints/freebsd.sh hints/hpux.sh
+ hints/irix_4.sh hints/mips.sh hints/next_3_0.sh hints/os2.sh
+ hints/qnx.sh hints/sco_2_3_3.sh hints/sco_2_3_4.sh
+ hints/solaris_2.sh hints/ultrix_4.sh hints/utekv.sh
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "New module: autouse.pm"
+ From: Ilya Zakharevich
+ Msg-ID: <199703210034.TAA13469@monk.mps.ohio-state.edu>
+ Date: Thu, 20 Mar 1997 19:34:30 -0500 (EST)
+ Files: MANIFEST lib/autouse.pm
+
+ Title: "Math::Complex update"
+ From: Jarkko Hietaniemi
+ Files: lib/Math/Complex.pm t/lib/complex.t
+
+ Title: "Refresh DB_File to 1.12"
+ From: Paul Marquess
+ Msg-ID: <9703121551.AA07435@claudius.bfsec.bt.co.uk>
+ Date: Wed, 12 Mar 97 15:51:14 GMT
+ Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+
+ Title: "New subroutine Symbol::qualify_to_ref()"
+ From: Roderick Schertler
+ Msg-ID: <pzlo7ut03b.fsf@eeyore.ibcinc.com>
+ Date: 11 Mar 1997 19:39:36 -0500
+ Files: lib/Symbol.pm
+
+ Title: "In debugger, don't reference %{$f{$g}} if $f{$g} doesn't exist"
+ From: Chip Salzenberg
+ Files: lib/perl5db.pl
+
+ Title: "In File::Path, some systems can't remove read-only files"
+ From: Chip Salzenberg
+ Files: lib/File/Path.pm
+
+ Title: "Fix typo in -l*perl* pattern"
+ From: Doug MacEachern
+ Msg-ID: <199703110414.XAA12884@berlin.atlantic.net>
+ Date: Mon, 10 Mar 1997 22:58:38 -0500
+ Files: lib/ExtUtils/Embed.pm
+
+ Title: "Fix bugs revealed by prototype warnings"
+ From: Chip Salzenberg
+ Files: ext/Opcode/Opcode.pm lib/ExtUtils/MakeMaker.pm
+ lib/Getopt/Long.pm
+
+ Title: "Problems with SKIP in makemaker"
+ From: Ilya Zakharevich
+ Msg-ID: <199703210413.XAA21601@monk.mps.ohio-state.edu>
+ Date: Thu, 20 Mar 1997 23:13:31 -0500 (EST)
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "In Exporter, don't C<require Carp> at file scope"
+ From: Chip Salzenberg
+ Files: lib/Exporter.pm
+
+ Title: "fix for Exporter's $SIG{__WARN__} handler"
+ From: Roderick Schertler
+ Msg-ID: <2282.858296451@eeyore.ibcinc.com>
+ Date: Thu, 13 Mar 1997 18:40:51 -0500
+ Files: lib/Exporter.pm
+
+ Title: "Don't try to substr() refs in Carp"
+ From: Chip Salzenberg
+ Files: lib/Carp.pm
+
+ Title: "Re: NUL in die and other messages"
+ From: "M.J.T. Guy"
+ Msg-ID: <E0w815V-0005xs-00@ursa.cus.cam.ac.uk>
+ Date: Fri, 21 Mar 1997 09:58:17 +0000
+ Files: lib/Carp.pm
+
+ Title: "Add entry for prototype() in Pod::Functions"
+ From: Chip Salzenberg
+ Files: lib/Pod/Functions.pm
+
+ Title: "Fix typos in IO::Socket documentation"
+ From: "M.J.T. Guy"
+ Msg-ID: <E0w75po-0003yh-00@taurus.cus.cam.ac.uk>
+ Date: Tue, 18 Mar 1997 20:50:16 +0000
+ Files: ext/IO/lib/IO/Socket.pm
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ Title: "Re: bug in pod2man (5.00326): section=3 for .pm modules"
+ From: Roderick Schertler
+ Msg-ID: <pzn2sat1hg.fsf@eeyore.ibcinc.com>
+ Date: 11 Mar 1997 19:09:31 -0500
+ Files: pod/pod2man.PL
+
+ DOCUMENTATION
+
+ Title: "perlfaq.pod"
+ From: Tom Christiansen
+ Msg-ID: <199703172301.QAA12566@jhereg.perl.com>
+ Date: Mon, 17 Mar 1997 16:01:40 -0700
+ Files: MANIFEST pod/Makefile pod/buildtoc pod/perl.pod
+ pod/perlfaq*.pod pod/roffitall
+
+ Title: "*.pod changes based on the FAQ"
+ From: gnat@frii.com
+ Msg-ID: <199703171650.JAA02655@elara.frii.com>
+ Date: Mon, 17 Mar 1997 09:50:14 -0700 (MST)
+ Files: pod/perldata.pod pod/perlfunc.pod pod/perlipc.pod
+ pod/perlop.pod pod/perlre.pod pod/perlrun.pod
+ pod/perlsec.pod pod/perlvar.pod
+
+ Title: "INSTALL: How to enable debugging"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970321112326.1414A-100000@fractal.lafayette.e
+ Date: Fri, 21 Mar 1997 11:25:32 -0500 (EST)
+ Files: INSTALL
+
+ Title: "Document that $. is not reset on implicit open"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "Re: Embedding success with _93 "
+ From: Doug MacEachern
+ Msg-ID: <199703112255.RAA22775@postman.osf.org>
+ Date: Tue, 11 Mar 1997 17:55:05 -0500
+ Files: pod/perldelta.pod
+
+ Title: "Update site list"
+ From: lvirden@cas.org (Larry W. Virden, x2487)
+ Msg-ID: <9703111053.AA20051@cas.org>
+ Date: Tue, 11 Mar 1997 10:53:49 -0500
+ Files: pod/perlmod.pod
+
+ Title: "Patch to document illegal characters"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.96.970314090558.15346J-100000@kelly.teleport.com>
+ Date: Fri, 14 Mar 1997 09:08:10 -0800 (PST)
+ Files: pod/perldiag.pod pod/perltrap.pod
+
+ Title: "Document trap with //o and closures"
+ From: Charles Bailey
+ Msg-ID: <01IGCHWRNSEU00661G@hmivax.humgen.upenn.edu>
+ Date: Mon, 10 Mar 1997 18:08:08 -0500 (EST)
+ Files: pod/perltrap.pod
+
+ Title: "Re: Inline PI function"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95q.970310143125.22489V-100000@kelly.teleport.com
+ Date: Mon, 10 Mar 1997 14:33:20 -0800 (PST)
+ Files: pod/perlsub.pod
+
+ Title: "Illegal character in input"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95q.970310151512.22489a-100000@kelly.teleport.com
+ Date: Mon, 10 Mar 1997 15:21:21 -0800 (PST)
+ Files: pod/perldiag.pod
+
+ Title: "Patch for docs Re: Lost backslash"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.96.970319071438.24834G-100000@kelly.teleport.com>
+ Date: Wed, 19 Mar 1997 07:28:57 -0800 (PST)
+ Files: pod/perlop.pod
+
+ Title: "XSUB's doc fix"
+ From: Roderick Schertler
+ Msg-ID: <28804.858012126@eeyore.ibcinc.com>
+ Date: Mon, 10 Mar 1997 11:42:06 -0500
+ Files: pod/perlcall.pod pod/perlguts.pod pod/perlxstut.pod
+
+ Title: "Document return from do FILE"
+ From: "M.J.T. Guy"
+ Msg-ID: <E0w70DK-0001yJ-00@ursa.cus.cam.ac.uk>
+ Date: Tue, 18 Mar 1997 14:50:10 +0000
+ Files: pod/perlfunc.pod
+
+ Title: "Document $^M in perlvar"
+ From: Robin Barker <rmb1@cise.npl.co.uk>
+ Msg-ID: <6153.9703202108@tempest.cise.npl.co.uk>
+ Date: Thu, 20 Mar 97 21:08:33 GMT
+ Files: pod/perlvar.pod
+
+ Title: "typos in pods of 5.003_93"
+ From: Jim Meyering <meyering@asic.sc.ti.com>
+ Msg-ID: <wpgendbzvhx.fsf@asic.sc.ti.com>
+ Date: 19 Mar 1997 10:39:38 -0600
+ Files: pod/perlfunc.pod pod/perlguts.pod pod/perlre.pod
+ pod/perltoot.pod pod/perlxs.pod
+
+ Title: "Re: Updates to pod punctuations"
+ From: lvirden@cas.org (Larry W. Virden, x2487)
+ Msg-ID: <9703141700.AA22911@cas.org>
+ Date: Fri, 14 Mar 1997 17:00:12 -0500
+ Files: pod/*.pod
+
+ Title: "clarify example in perlfunc"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199703201746.TAA25195@alpha.hut.fi>
+ Date: Thu, 20 Mar 1997 19:46:01 +0200 (EET)
+ Files: pod/perlfunc.pod
+
+ Title: "Regularize headings in DB_File documentation"
+ From: Chip Salzenberg
+ Files: ext/DB_File/DB_File.pm
+
+
+----------------
+Version 5.003_93
+----------------
+
+Me, last time:
+ "This release will be the public beta of 5.004,
+ or my name isn't Larson T. Pettifogger."
+Me, now:
+ "Gone like *that*, a fortune in letterhead."
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Don't autovivify array and hash elements in sub parameters"
+ From: Gurusamy Sarathy
+ Msg-ID: <199703061912.OAA20606@aatma.engin.umich.edu>
+ Date: Thu, 06 Mar 1997 14:12:09 -0500
+ Files: op.c pod/perldelta.pod pod/perlsub.pod pod/perltrap.pod
+
+ Title: "Support READ and GETC for tied handles"
+ From: Doug MacEachern
+ Msg-ID: <199703090019.TAA32591@postman.osf.org>
+ Date: Sat, 08 Mar 1997 19:19:38 -0500
+ Files: pod/perldelta.pod pod/perltie.pod pp_sys.c t/op/misc.t
+
+ Title: "Warn on C<@x =~ /a/> and C<%x =~ s/a/b/>"
+ From: Chip Salzenberg
+ Files: op.c pod/perldiag.pod
+
+ Title: "Warn on %{+undef} and @{+undef}"
+ From: Chip Salzenberg
+ Files: pp.c pp_hot.c
+
+ CORE PORTABILITY
+
+ Title: "VMS update"
+ From: Charles Bailey
+ Msg-ID: <01IG8KN5R28M00661G@hmivax.humgen.upenn.edu>
+ Date: Fri, 07 Mar 1997 22:49:46 -0500 (EST)
+ Files: lib/ExtUtils/MM_VMS.pm vms/descrip.mms vms/gen_shrfls.pl
+ vms/sockadapt.h
+
+ Title: "AmigaOS hint patch"
+ From: Norbert Pueschel
+ Msg-ID: <77724767@Armageddon.meb.uni-bonn.de>
+ Date: Sat, 08 Mar 1997 12:50:15 +0100
+ Files: hints/amigaos.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Make conversion of @_ to real array work right after C<shift>"
+ From: Chip Salzenberg
+ Files: av.c
+
+ Title: "Fix imbalanced ENTER/LEAVE from C<BEGIN{die}>"
+ From: Chip Salzenberg
+ Files: op.c perl.c proto.h
+
+ Title: "perl -P path patch"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970308120242.23766D-100000@fractal.lafayette.
+ Date: Sat, 08 Mar 1997 12:45:08 -0500 (EST)
+ Files: config_H config_h.SH perl.c plan9/config.plan9 t/comp/cpp.t
+ vms/config.vms win32/config.H
+
+ BUILD PROCESS
+
+ Title: "Fix for Unisys UNIX and libperl.so"
+ From: aburlison@cix.compulink.co.uk (Alan Burlison)
+ Msg-ID: <memo.147328@cix.compulink.co.uk>
+ Date: Thu, 6 Mar 97 16:28 GMT0
+ Files: Configure
+
+ Title: "Allow './Configure -Uoptimize'"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970306110532.11070A-100000@fractal.lafayette.
+ Date: Thu, 06 Mar 1997 11:15:47 -0500 (EST)
+ Files: Configure
+
+ Title: "Use 'test -f', not 'test -x'"
+ From: Spider Boardman
+ Msg-ID: <199703080053.TAA13943@web.zk3.dec.com>
+ Date: Fri, 7 Mar 1997 19:53:00 -0500
+ Files: Configure
+
+ Title: "Don't count on 'trap 0' inside () in shell script"
+ From: aburlison@cix.compulink.co.uk (Alan Burlison)
+ Msg-ID: <memo.147326@cix.compulink.co.uk>
+ Date: Thu, 6 Mar 97 16:28 GMT0
+ Files: perl_exp.SH
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Carp with multiple arguments"
+ From: "M.J.T. Guy"
+ Msg-ID: <E0w3STZ-0007RW-00@taurus.cus.cam.ac.uk>
+ Date: Sat, 8 Mar 1997 20:12:17 +0000
+ Files: lib/Carp.pm
+
+ Title: "@EXPORT_FAIL fix for Exporter.pm"
+ From: Roderick Schertler
+ Msg-ID: <24884.857841724@eeyore.ibcinc.com>
+ Date: Sat, 08 Mar 1997 12:22:04 -0500
+ Files: lib/Exporter.pm
+
+ Title: "Open[23] autoflush docs"
+ From: Roderick Schertler
+ Msg-ID: <7939.857693947@eeyore.ibcinc.com>
+ Date: Thu, 06 Mar 1997 19:19:07 -0500
+ Files: lib/IPC/Open2.pm lib/IPC/Open3.pm
+
+ TESTS
+
+ Title: "Fix counts in output of TEST"
+ From: Hugo van der Sanden <hv@iii.co.uk>
+ Msg-ID: <331F1507.4BE8@iii.co.uk>
+ Date: Thu, 06 Mar 1997 19:03:35 +0000
+ Files: t/TEST
+
+ Title: "Ignore backup files in strict.t and warning.t"
+ From: Chip Salzenberg
+ Files: t/pragma/strict.t t/pragma/warning.t
+
+ UTILITIES
+
+ Title: "Quote pathname before using as pattern"
+ From: Chip Salzenberg
+ Files: pod/pod2html.PL
+
+ DOCUMENTATION
+
+ Title: "Consolidated INSTALL updates since _92"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970308131806.23766F-100000@fractal.lafayette.
+ Date: Sat, 08 Mar 1997 13:21:22 -0500 (EST)
+
+ Title: "Fix more E-Mail addresses in pods"
+ From: Chip Salzenberg
+ Files: lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Manifest.pm
+ lib/diagnostics.pm pod/buildtoc
+
+ Title: "Warn about '.' terminating E-Mail"
+ From: Chip Salzenberg
+ Files: pod/perlform.pod
+
+ Title: "OS/2 doc update"
+ From: Ilya Zakharevich
+ Msg-ID: <199703080537.AAA25157@monk.mps.ohio-state.edu>
+ Date: Sat, 8 Mar 1997 00:37:30 -0500 (EST)
+ Files: README.os2
+
+ Title: "PODs corrections"
+ From: Ilya Zakharevich
+ Msg-ID: <199703080253.VAA24975@monk.mps.ohio-state.edu>
+ Date: Fri, 7 Mar 1997 21:53:04 -0500 (EST)
+ Files: ext/DB_File/DB_File.pm ext/Socket/Socket.pm
+ lib/Class/Template.pm lib/ExtUtils/Embed.pm
+ lib/ExtUtils/MM_VMS.pm lib/ExtUtils/Mksymlists.pm
+ lib/File/Basename.pm lib/File/stat.pm lib/Time/gmtime.pm
+ lib/Time/localtime.pm lib/Time/tm.pm lib/User/grent.pm
+ lib/User/pwent.pm pod/perlcall.pod pod/perldebug.pod
+ pod/perlfunc.pod pod/perlguts.pod pod/perllocale.pod
+ pod/perlop.pod pod/perlsub.pod
+
+
+----------------
+Version 5.003_92
+----------------
+
+This release will be the public beta of 5.004, or my name isn't
+Larson T. Pettifogger.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Strictly follow lexical context of C<eval ''> and nested subs"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Make ::SUPER and UNIVERSAL work together"
+ From: Chip Salzenberg
+ Files: gv.c pod/perlguts.pod
+
+ CORE PORTABILITY
+
+ Title: "HP-UX hint update"
+ From: Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com>
+ Msg-ID: <1479.857653838@lyon.grenoble.hp.com>
+ Date: Thu, 06 Mar 97 14:10:38 +0100
+ Files: hints/hpux.sh
+
+ Title: "Re: The continuing MachTen saga"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95q.970305091611.3572E-100000@kelly.teleport.com>
+ Date: Wed, 5 Mar 1997 09:47:22 -0800 (PST)
+ Files: hints/machten_2.sh
+
+ Title: "OS/2 patches"
+ From: Ilya Zakharevich
+ Msg-ID: <199703060308.WAA22211@monk.mps.ohio-state.edu>
+ Date: Wed, 5 Mar 1997 22:08:43 -0500 (EST)
+ Files: hints/os2.sh lib/ExtUtils/MakeMaker.pm t/op/taint.t
+
+ Title: "VMS patches"
+ From: Charles Bailey
+ Msg-ID: <01IG5SQE4A6U00661G@hmivax.humgen.upenn.edu>
+ Date: Wed, 05 Mar 1997 23:10:24 -0500 (EST)
+ Files: lib/ExtUtils/MM_VMS.pm lib/ExtUtils/Manifest.pm perlsdio.h
+ t/op/runlevel.t t/op/taint.t vms/descrip.mms vms/perly_c.vms
+ vms/sockadapt.c vms/sockadapt.h vms/vms_yfix.pl
+
+ OTHER CORE CHANGES
+
+ Title: "Make sure $^X is tainted when ARG_ZERO_IS_SCRIPT"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Clarify '-T too late' error"
+ From: Chip Salzenberg
+ Files: perl.c pod/perldiag.pod
+
+ Title: "Warn when redefining or undefining a constant sub"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod pp.c sv.c
+
+ Title: "Don't generate spurious 'not imported' warning"
+ From: Chip Salzenberg
+ Files: gv.c t/pragma/strict-vars pod/perldiag.pod
+
+ Title: "Clarify message re: @host in string"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod pod/perltrap.pod toke.c
+
+ Title: "Disconnect refs that are targets of pp_readline"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Fix typo in test of HvFILL()"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Allow for pad name array to be shorter than pad array"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Eliminate format-string type warnings"
+ From: Hallvard B Furuseth
+ Msg-ID: <199703030915.KAA11634@bombur2.uio.no>
+ Date: Mon, 3 Mar 1997 10:15:11 +0100 (MET)
+ Files: doio.c ext/POSIX/POSIX.xs gv.c hints/dec_osf.sh pp.c pp_ctl.c
+ pp_hot.c run.c sv.c x2p/a2py.c
+
+ Title: "Update copyright dates"
+ From: Chip Salzenberg
+ Files: *.[hc] x2p/*.[hc] win32/EXTERN.h vms/vmsish.h vms/vms.c
+
+ BUILD PROCESS
+
+ Title: "near-harmless bug in _91's Configure"
+ From: Roderick Schertler
+ Msg-ID: <pzg1yfuiza.fsf@eeyore.ibcinc.com>
+ Date: 01 Mar 1997 21:26:49 -0500
+ Files: Configure
+
+ Title: "Change 'continuing anyway' to 'probably harmless'"
+ From: Chip Salzenberg
+ Files: INSTALL lib/ExtUtils/Liblist.pm
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Newer ReadLine"
+ From: Ilya Zakharevich
+ Msg-ID: <199703040634.BAA19919@monk.mps.ohio-state.edu>
+ Date: Tue, 4 Mar 1997 01:34:28 -0500 (EST)
+ Files: lib/Term/ReadLine.pm lib/perl5db.pl
+
+ Title: "Refresh Getopt::Long to 2.9"
+ From: Johan Vromans <jvromans@squirrel.nl>
+ Files: lib/Getopt/Long.pm
+
+ Title: "Benchmark: using code refs"
+ From: Hugo van der Sanden <hv@iii.co.uk>
+ Msg-ID: <199703041132.LAA07613@tyree.iii.co.uk>
+ Date: Tue, 04 Mar 1997 11:32:11 +0000
+ Files: lib/Benchmark.pm
+
+ Title: "Fix quotewords"
+ From: Hugo van der Sanden <hv@crypt.compulink.co.uk>
+ Msg-ID: <199703060755.HAA15060@crypt.compulink.co.uk>
+ Date: Thu, 06 Mar 1997 07:55:25 +0000
+ Files: lib/Text/ParseWords.pm
+
+ Title: "Use IV instead of double for tms structure members"
+ From: Chip Salzenberg
+ Files: ext/POSIX/POSIX.xs
+
+ Title: "Document IO::File::new_tmpfile"
+ From: Chip Salzenberg
+ Files: ext/IO/lib/IO/File.pm
+
+ TESTS
+
+ Title: "Make op/TEST silent under -w"
+ From: d-lewart@uiuc.edu (Daniel S. Lewart)
+ Msg-ID: <199703011821.NAA13037@sinistar.idle.com>
+ Date: Sat, 1 Mar 97 12:04:09 CST
+ Files: t/TEST
+
+ Title: "Smarter t/op/taint.t"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95q.970303103047.24000A-100000@kelly.teleport.com
+ Date: Mon, 3 Mar 1997 10:31:54 -0800 (PST)
+ Files: t/op/taint.t
+
+ Title: "Fix taint test for systems without csh"
+ From: Chip Salzenberg
+ Files: t/op/taint.t
+
+ Title: "Don't test locales if there is no setlocale()"
+ From: Chip Salzenberg
+ Files: t/pragma/locale.t
+
+ UTILITIES
+
+ Title: "Update pod2html"
+ From: wmiddlet@Adobe.COM (William Middleton)
+ Msg-ID: <199703030025.QAA08106@ducks>
+ Date: Sun, 2 Mar 1997 16:25:03 -0800 (PST)
+ Files: pod/pod2html.PL
+
+ Title: "Support 'long long' in h2ph"
+ From: (name lost)
+ Files: utils/h2ph.PL
+
+ DOCUMENTATION
+
+ Title: "Add taint checks and srand to perldelta"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95q.970302115355.23058D-100000@kelly.teleport.com
+ Date: Sun, 2 Mar 1997 11:56:08 -0800 (PST)
+ Files: pod/perldelta.pod
+
+ Title: "Don't call FileHandle 'deprecated'"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "Improve sample module header"
+ From: Tom Christiansen and Graham Barr
+ Msg-ID: <199703011732.KAA14693@jhereg.perl.com>
+ Date: Sat, 01 Mar 1997 10:32:31 -0700
+ Files: pod/perlmod.pod
+
+ Title: "Clarify C<crypt> documentation"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95q.970228131112.12357D-100000@kelly.teleport.com
+ Date: Fri, 28 Feb 1997 13:18:25 -0800 (PST)
+ Files: pod/perlfunc.pod
+
+ Title: "Update list of CPAN sites"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199703021454.QAA07446@alpha.hut.fi>
+ Date: Sun, 2 Mar 1997 16:54:22 +0200 (EET)
+ Files: pod/perlmod.pod
+
+ Title: "Enhance description of 'server error'"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199702041903.VAA16070@alpha.hut.fi>
+ Date: Tue, 4 Feb 1997 21:03:23 +0200 (EET)
+ Files: pod/perldiag.pod
+
+ Title: "Regularize format of E-Mail addresses in *.pod"
+ From: Chip Salzenberg
+ Files: pod/*.pod
+
+
+----------------
+Version 5.003_91
+----------------
+
+This is (should be? must be!) the public beta of 5.004.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Fix perl_call_*() when !G_EVAL"
+ From: Gurusamy Sarathy
+ Msg-ID: <199702250725.CAA09192@aatma.engin.umich.edu>,
+ <199702251925.OAA15498@aatma.engin.umich.edu>,
+ <199702252200.RAA16853@aatma.engin.umich.edu>
+ Date: Tue, 25 Feb 1997 02:25:56 -0500
+ Files: MANIFEST gv.c interp.sym perl.c perl.h pp_ctl.c pp_sys.c
+ t/op/runlevel.t
+
+ Title: "Fix taint tests for writeable dirs in $ENV{PATH}"
+ From: Chip Salzenberg
+ Files: mg.c mg.h pod/perlsec.pod taint.c
+
+ Title: "Forbid tainted parameters for truncate()"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "Don't taint magic hash keys unnecessarily"
+ From: Charles Bailey
+ Msg-ID: <01IFXL9TY74Y00661G@hmivax.humgen.upenn.edu>
+ Date: Fri, 28 Feb 1997 02:11:26 -0500 (EST)
+ Files: hv.c
+
+ CORE PORTABILITY
+
+ Title: "VMS patches post _90"
+ From: Charles Bailey
+ Msg-ID: <01IFYDE5ZT7O005A53@hmivax.humgen.upenn.edu>
+ Date: Fri, 28 Feb 1997 15:26:33 -0500 (EST)
+ Files: doio.c mg.c perl.h pp_hot.c t/op/rand.t t/op/taint.t taint.c
+ vms/descrip.mms vms/vms.c
+
+ Title: "Fix taint check in system() and exec() under VMS and OS/2"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "If _XOPEN_VERSION >= 4, socket length parameters are size_t"
+ From: Michael H. Moran <mhm@austin.ibm.com>
+ Files: perl.h pp_sys.c
+
+ Title: "Make dooneliner() compile again"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ OTHER CORE CHANGES
+
+ Title: "Short-circuit duplicate study() calls"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Call sv_set[iu]v() with [IU]V parameter, not [IU]32"
+ From: Chip Salzenberg
+ Files: perl.c pp.c pp_sys.c toke.c util.c
+
+ Title: "Clean up and document API for hashes"
+ From: Gurusamy Sarathy
+ Msg-ID: <199702251824.NAA14859@aatma.engin.umich.edu>
+ Date: Tue, 25 Feb 1997 13:24:02 -0500
+ Files: hv.c hv.h pod/perldelta.pod pod/perlguts.pod
+
+ Title: "pp_undef was not always freeing memory"
+ From: Ilya Zakharevich
+ Msg-ID: <199702270653.BAA13949@monk.mps.ohio-state.edu>
+ Date: Thu, 27 Feb 1997 01:53:51 -0500 (EST)
+ Files: pp.c
+
+ Title: "Fix SEGV when debugging with foreach() lvalue patch"
+ From: Ilya Zakharevich
+ Msg-ID: <199702271924.OAA14557@monk.mps.ohio-state.edu>
+ Date: Thu, 27 Feb 1997 14:24:36 -0500 (EST)
+ Files: sv.c
+
+ Title: "Don't examine rx->exec_tainted if pregexec() fails"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Silence bogus typo warning on $DB::postponed"
+ From: Gurusamy Sarathy
+ Msg-ID: <199702271802.NAA12505@aatma.engin.umich.edu>
+ Date: Thu, 27 Feb 1997 13:02:30 -0500
+ Files: op.c
+
+ BUILD PROCESS
+
+ Title: "Sanity check linking with $libs"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970225221634.2486A-100000@fractal.lafayette.edu>
+ Date: Tue, 25 Feb 1997 14:13:45 -0500 (EST)
+ Files: Configure
+
+ Title: "Flush stdout when printing $randbits guess"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Configure changes for Irix nm"
+ From: Helmut Jarausch and Fabien Tassin
+ Files: Configure
+
+ Title: "Update OS/2 Configure diff"
+ From: Ilya Zakharevich
+ Msg-ID: <199702251906.OAA10608@monk.mps.ohio-state.edu>
+ Date: Tue, 25 Feb 1997 14:06:23 -0500 (EST)
+ Files: os2/diff.configure
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Don't require() in a signal handler"
+ From: Chip Salzenberg
+ Files: lib/perl5db.pl
+
+ Title: "Make IPC::Open3 work without fork()"
+ From: Ilya Zakharevich
+ Msg-ID: <199702251937.OAA10718@monk.mps.ohio-state.edu>
+ Date: Tue, 25 Feb 1997 14:37:07 -0500 (EST)
+ Files: lib/IPC/Open3.pm
+
+ Title: "Follow up on elimination of $` $& $' in libraries"
+ From: "M.J.T. Guy"
+ Msg-ID: <E0w0Sqc-00046E-00@ursa.cus.cam.ac.uk>
+ Date: Fri, 28 Feb 1997 13:59:42 +0000
+ Files: lib/Getopt/Long.pm lib/diagnostics.pm
+
+ Title: "Don't warn on use of CCFLAGS"
+ From: Andreas Koenig
+ Msg-ID: <199702251038.LAA13123@anna.in-berlin.de>
+ Date: Tue, 25 Feb 1997 11:38:43 +0100
+ Files: lib/ExtUtils/MakeMaker.pm
+
+ Title: "Allow explicit '-lperl' in link arguments"
+ From: Doug MacEachern
+ Msg-ID: <199702271625.LAA25402@postman.osf.org>
+ Date: Thu, 27 Feb 1997 11:25:04 -0500
+ Files: lib/ExtUtils/Embed.pm
+
+ TESTS
+
+ Title: "New test op/taint.t"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95q.970225101328.18288M-100000@kelly.teleport.com
+ Date: Tue, 25 Feb 1997 11:36:53 -0800 (PST)
+ Files: MANIFEST t/op/taint.t
+
+ Title: "Patch to t/op/rand.t"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95q.970225181321.13796Q-100000@kelly.teleport.com
+ Date: Tue, 25 Feb 1997 18:19:34 -0800 (PST)
+ Files: t/op/rand.t
+
+ UTILITIES
+
+ Title: "Add --lax option to pod2man; use it in perldoc"
+ From: Nat <gnat@frii.com>, Chip Salzenberg
+ Files: pod/pod2man.PL utils/perldoc.PL
+
+ Title: "Eliminate dead code in pod2man"
+ From: Chip Salzenberg
+ Files: pod/pod2man.PL
+
+ DOCUMENTATION
+
+ Title: "Warn about intrusive sfio behavior"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970228112136.24038G-100000@fractal.lafayette.
+ Date: Fri, 28 Feb 1997 11:35:49 -0500 (EST)
+ Files: INSTALL
+
+ Title: "Updates to perlfunc.pod"
+ From: Tom Phoenix (with help from M.J.T. Guy and Tom C.)
+ Files: pod/perlfunc.pod
+
+ Title: "Move ENVIRONMENT from perl.pod to perlrun.pod"
+ From: Chip Salzenberg
+ Files: pod/perl.pod pod/perlrun.pod
+
+ Title: "Describe PERL_DEBUG_MSTATS in perlrun.pod"
+ From: Nat <gnat@frii.com>
+ Files: pod/perlrun.pod
+
+ Title: "Fix references to perlbug"
+ From: Chip Salzenberg
+ Files: pod/perl.pod pod/perldelta.pod pod/perllocale.pod
+ pod/perltoc.pod
+
+
+----------------
+Version 5.003_90
+----------------
+
+At last, a mil[le]stone: The first beta of Perl 5.004.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Automatically call srand() before rand() if user didn't"
+ From: Chip Salzenberg
+ Files: pod/perlfunc.pod pp.c
+
+ CORE PORTABILITY
+
+ Title: "Ultrix hints"
+ From: Spider Boardman
+ Msg-ID: <199702220951.EAA08156@Orb.Nashua.NH.US>
+ Date: Sat, 22 Feb 1997 04:51:48 -0500
+ Files: hints/ultrix_4.sh
+
+ Title: "Digital UNIX and 3_28"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199702231427.QAA13807@alpha.hut.fi>
+ Date: Sun, 23 Feb 1997 16:27:19 +0200 (EET)
+ Files: Configure MANIFEST ext/NDBM_File/hints/dec_osf.pl
+ ext/ODBM_File/hints/dec_osf.pl hints/dec_osf.sh
+
+ Title: "AmigaOS patches to 5.003_28"
+ From: Norbert Pueschel
+ Msg-ID: <77724759@Armageddon.meb.uni-bonn.de>
+ Date: Sat, 22 Feb 1997 18:08:02 +0100
+ Files: README.amiga hints/amigaos.sh t/io/fs.t t/lib/anydbm.t
+ t/lib/db-btree.t t/lib/db-hash.t t/lib/db-recno.t
+ t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t
+ t/op/magic.t t/op/stat.t
+
+ Title: "Hints for DC/OSx"
+ From: Stephen Zander <srz@loopback>
+ Msg-ID: <199702242124.NAA03796@wsuse5.mckesson.com>
+ Date: Mon, 24 Feb 1997 13:24:54 -0800
+ Files: hints/dcosx.sh
+
+ Title: "Update VMS version"
+ From: Chip Salzenberg
+ Files: vms/config.vms vms/descrip.mms
+
+ OTHER CORE CHANGES
+
+ Title: "Don't assume that sizeof(int) >= sizeof(void*)"
+ From: Chip Salzenberg
+ Files: doio.c malloc.c regexec.c
+
+ BUILD PROCESS
+
+ Title: "Re: ccdlflags don't quite work"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970224160630.5700E-100000@fractal.lafayette.e
+ Date: Mon, 24 Feb 1997 16:07:07 -0500 (EST)
+ Files: Configure
+
+ Title: "Use $ccflags, $ldflags, $libs when determining $randbits"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "'installperl -v' doesn't do enough"
+ From: Spider Boardman
+ Msg-ID: <199702241342.IAA25945@Orb.Nashua.NH.US>
+ Date: Mon, 24 Feb 1997 08:42:59 -0500
+ Files: installperl
+
+ Title: "installperl breaks running system (for a while)"
+ From: Spider Boardman
+ Msg-ID: <199702241412.JAA11829@Orb.Nashua.NH.US>
+ Date: Mon, 24 Feb 1997 09:12:11 -0500
+ Files: installperl
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Don't clobber $1 et al in debugger's DB::sub()"
+ From: Ilya Zakharevich
+ Files: lib/perl5db.pl
+
+ Title: "Fix fd leak in IO::Pipe"
+ From: Roderick Schertler
+ Msg-ID: <pzn2sv722y.fsf@eeyore.ibcinc.com>
+ Date: 23 Feb 1997 14:29:57 -0500
+ Files: ext/IO/lib/IO/Pipe.pm
+
+ Title: "Pod::Text fixes"
+ From: Roderick Schertler
+ Msg-ID: <350.856634588@eeyore.ibcinc.com>
+ Date: Sat, 22 Feb 1997 13:03:08 -0500
+ Files: lib/Pod/Text.pm
+
+ Title: "Trivial patch to make ExtUtils::Install more -w clean"
+ From: Tim Bunce
+ Msg-ID: <9702241605.AA17436@toad.ig.co.uk>
+ Date: Mon, 24 Feb 1997 16:05:17 +0000
+ Files: lib/ExtUtils/Install.pm
+
+ Title: "C<use vars> didn't work until 5.002"
+ From: Chip Salzenberg
+ Files: lib/vars.pm
+
+ TESTS
+
+ Title: "More thoroughly test rand() and srand()"
+ From: Tom Phoenix
+ Files: t/op/rand.t
+
+ Title: "Don't use <*> where readdir() will do"
+ From: Chip Salzenberg
+ Files: t/op/stat.t
+
+ Title: "Allow for $^X to be 'miniperl'"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03020903af360f31aced@[194.51.248.65]>
+ Date: Sun, 23 Feb 1997 16:22:45 +0100
+ Files: t/op/magic.t
+
+ UTILITIES
+
+ Title: "Post-28 INSTALL updates"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970224170713.5700H-100000@fractal.lafayette.e
+ Date: Mon, 24 Feb 1997 17:09:09 -0500 (EST)
+ Files: INSTALL
+
+ Title: "Re: Hash key created by subroutine call? (fwd) "
+ From: Gurusamy Sarathy
+ Msg-ID: <199702242229.RAA04395@aatma.engin.umich.edu>
+ Date: Mon, 24 Feb 1997 17:29:30 -0500
+ Files: pod/perlsub.pod pod/perltrap.pod
+
+ Title: "Add documentation and '-h' option to perlbug"
+ From: Gurusamy Sarathy
+ Msg-ID: <199702240854.DAA27128@aatma.engin.umich.edu>
+ and <199702242009.PAA02849@aatma.engin.umich.edu>
+ Date: Mon, 24 Feb 1997
+ Files: pod/perl.pod pod/perldelta.pod installman
+ utils/perlbug.PL
+
+ Title: "pumpkin-1.9.pod"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970224155702.5700D-100000@fractal.lafayette.e
+ Date: Mon, 24 Feb 1997 16:06:02 -0500 (EST)
+ Files: Porting/pumpkin.pod
+
+ DOCUMENTATION
+
+ Title: "Fix typo in 'Tolkien quotation typo' fix"
+ From: Jarkko Hietaniemi
+ Files: Changes
+
+ Title: "Document one-argument limitation with #! line"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95q.970223182745.15989A-100000@kelly.teleport.com
+ Date: Sun, 23 Feb 1997 18:41:02 -0800 (PST)
+ Files: pod/perldiag.pod pod/perlsec.pod
+
+
+----------------
+Version 5.003_28
+----------------
+
+This release is beta candidate #6. If this isn't good enough to go beta,
+I'll eat a floppy disk. (Okay, it's a chocolate floppy, but still....)
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Don't let C<sub foo;> undefine &foo"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Make code, doc agree on $ENV{PATH} and `cmd`"
+ From: Chip Salzenberg
+ Files: pod/perlsec.pod pp_sys.c
+
+ Title: "Don't taint $x in C<$x = ($tainted =~ /(\w+)/)>"
+ From: Chip Salzenberg
+ Files: pp_ctl.c pp_hot.c
+
+ Title: "Turn off 'expression tainted' flag at end of runops()"
+ From: Chip Salzenberg
+ Files: run.c
+
+ Title: "When overloading, don't throw away nomethod's value"
+ From: Ilya Zakharevich
+ Files: gv.c
+
+ Title: "Optimize keys() and values() in void context"
+ From: Chip Salzenberg
+ Files: doop.c op.c
+
+ CORE PORTABILITY
+
+ Title: "New hints for Digital UNIX"
+ From: Jarkko Hietaniemi
+ Files: hints/dec_osf.sh
+
+ Title: "No version of AIX has working setre[ug]id()"
+ From: neufeld@fast.pvi.org (Keith Neufeld)
+ Files: hints/aix.sh
+
+ Title: "VMS patches post _27"
+ From: Charles Bailey
+ Msg-ID: <01IFMEMPN1IU0057E2@hmivax.humgen.upenn.edu>
+ Date: Thu, 20 Feb 1997 01:58:46 -0500 (EST)
+ Files: MANIFEST dosish.h hv.c lib/ExtUtils/MM_VMS.pm
+ lib/ExtUtils/xsubpp perl.c perlsdio.h pod/perldelta.pod
+ pod/perlvar.pod t/op/closure.t unixish.h vms/Makefile
+ vms/descrip.mms vms/ext/filespec.t vms/genconfig.pl
+ vms/vms.c vms/vmsish.h
+
+ Title: "Re: OS/2 patch for _27"
+ From: Ilya Zakharevich
+ Msg-ID: <199702210024.TAA03174@monk.mps.ohio-state.edu>
+ Date: Thu, 20 Feb 1997 19:24:16 -0500 (EST)
+ Files: INSTALL README.os2 lib/Test/Harness.pm os2/Changes
+ os2/OS2/PrfDB/t/os2_prfdb.t os2/os2.c os2/os2ish.h
+ os2/perl2cmd.pl perl.c pod/perldelta.pod t/TEST t/harness
+ t/op/magic.t
+
+ OTHER CORE CHANGES
+
+ Title: "Fix a typo"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "Undo signal patch -- it broke die() in signal"
+ From: Chip Salzenberg
+ Files: mg.c
+
+ Title: "Fix perl_call_sv(..., G_NOARGS)"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ Title: "Fix SIGSEGV when cloning sub with complex expression"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Minor update to malloc.c"
+ From: Ilya Zakharevich
+ Msg-ID: <199702210244.VAA03676@monk.mps.ohio-state.edu>
+ Date: Thu, 20 Feb 1997 21:44:13 -0500 (EST)
+ Files: malloc.c
+
+ Title: "Fix the Tolkien quotation"
+ From: Chip Salzenberg
+ Files: perly.y
+
+ BUILD PROCESS
+
+ (no changes)
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Debugger patch"
+ From: Ilya Zakharevich
+ Msg-ID: <199702210737.CAA03951@monk.mps.ohio-state.edu>
+ Date: Fri, 21 Feb 1997 02:37:59 -0500 (EST)
+ Files: lib/perl5db.pl
+
+ Title: "Avoid $` $& $' in libraries"
+ From: Ilya Zakharevich
+ Msg-ID: <199702210207.VAA03560@monk.mps.ohio-state.edu>
+ Date: Thu, 20 Feb 1997 21:07:30 -0500 (EST)
+ Files: lib/Getopt/Long.pm lib/Pod/Text.pm lib/diagnostics.pm
+ os2/OS2/REXX/REXX.pm
+
+ Title: "Remove redundant clearerr() from IO::Seekable"
+ From: Chip Salzenberg
+ Files: ext/IO/lib/IO/Handle.pm ext/IO/lib/IO/Seekable.pm
+
+ Title: "prototype error in File::stat"
+ From: Graham.Barr@tiuk.ti.com
+ Msg-ID: <199702180748.HAA14151@ultra-boy>
+ Date: Tue, 18 Feb 1997 07:48:40 GMT
+ Files: lib/File/stat.pm
+
+ TESTS
+
+ Title: "Include 'study' in regexp.t"
+ From: Chip Salzenberg
+ Files: t/op/regexp.t
+
+ Title: "Don't run locale test if -DNO_LOCALE"
+ From: Chip Salzenberg
+ Files: t/pragma/locale.t
+
+ Title: "Tweak tests to notice $dont_use_nlink"
+ From: Chip Salzenberg
+ Files: t/io/fs.t t/op/stat.t
+
+ Title: "Add test for grep() and wantarray"
+ From: Hugo van der Sanden <hv@iii.co.uk>
+ Msg-ID: <199702181105.LAA17895@tyree.iii.co.uk>
+ Date: Tue, 18 Feb 1997 11:05:59 +0000
+ Files: t/op/misc.t
+
+ UTILITIES
+
+ (no changes)
+
+ DOCUMENTATION
+
+ Title: "INSTALL updates since _26"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95q.970218155815.2014F-100000@fractal.lafayette.e
+ Date: Tue, 18 Feb 1997 16:00:08 -0500 (EST)
+ Files: INSTALL
+
+ Title: "Document "$$0" change"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "Don't recommend impossible //o for C<$x =~ $y>"
+ From: Chip Salzenberg
+ Files: pod/perlop.pod
+
+ Title: "Correct doc that claimed that <FH> was never false"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perlop.pod
+
+ Title: "Document C<$?> vs. $SIG{CHLD}"
+ From: Ulrich Pfeifer
+ Files: pod/perlvar.pod
+
+ Title: "Add pumpkin.pod"
+ From: Chip Salzenberg
+ Files: MANIFEST Porting/pumpkin.pod
+
+ Title: "Don't say "associat*ve arr*y""
+ From: Chip Salzenberg
+ Files: MANIFEST gv.h hv.c lib/Env.pm lib/overload.pm opcode.pl
+ pod/perl.pod pod/perldelta.pod pod/perldiag.pod
+ pod/perlfunc.pod pod/perlguts.pod pod/perlmod.pod
+ pod/perltie.pod pod/perltoc.pod pod/perltrap.pod x2p/a2p.pod
+
+
+----------------
+Version 5.003_27
+----------------
+
+This release is beta candidate #5: Our last, best hope for a beta.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Better looks_like_number() function [sv.c]"
+ From: Gisle Aas
+ Msg-ID: <199702141708.SAA17546@bergen.sn.no>
+ Date: Fri, 14 Feb 1997 18:08:52 +0100
+ Files: sv.c
+
+ Title: "Remove redundant functions UNIVERSAL::{class,is_instance}"
+ From: Gisle Aas
+ Msg-ID: <hwwsbpeq2.fsf@bergen.sn.no>
+ Date: 14 Feb 1997 15:52:21 +0000
+ Files: pod/perldelta.pod pod/perlobj.pod t/op/universal.t universal.c
+
+ Title: "Allow C<setpgrp $$>"
+ From: Roderick Schertler
+ Msg-ID: <pzraigyshr.fsf@eeyore.ibcinc.com>
+ Date: 16 Feb 1997 23:19:12 -0500
+ Files: pp_sys.c
+
+ Title: "Fix syntax error on C<&$1>"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Fix sub call through magic var (e.g. C<&$1>)"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Fix grep() with refs in array context"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ CORE PORTABILITY
+
+ Title: "Eliminate $^S; add C<use vmsish qw(status exit time)>"
+ From: Charles Bailey
+ Msg-ID: <01IFI9CFKL0S004R2V@hmivax.humgen.upenn.edu>
+ Date: Mon, 17 Feb 1997 02:45:26 -0500 (EST)
+ Files: MANIFEST gv.c lib/English.pm lib/ExtUtils/MM_VMS.pm
+ lib/ExtUtils/Mksymlists.pm lib/ExtUtils/xsubpp mg.c op.c
+ perl.c perl.h pod/perldelta.pod pod/perlmod.pod
+ pod/perlvar.pod pp_ctl.c pp_sys.c utils/perldoc.PL
+ vms/Makefile vms/config.vms vms/descrip.mms
+ vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs
+ vms/ext/XSSymSet.pm vms/ext/vmsish.pm vms/vms.c vms/vmsish.h
+ win32/makedef.pl
+
+ Title: "Eliminate FP exceptions under SCO 5"
+ From: Chip Salzenberg
+ Files: hints/sco.sh unixish.h
+
+ Title: "Digital UNIX hints"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199702151906.VAA22999@alpha.hut.fi>
+ Date: Sat, 15 Feb 1997 21:06:33 +0200 (EET)
+ Files: hints/dec_osf.sh
+
+ Title: "Irix6.4 (with 7.1 compilers)"
+ From: John Stoffel <jfs@fluent.com>
+ Msg-ID: <199702130238.VAA24468@jfs.Fluent.COM>
+ Date: Wed, 12 Feb 1997 21:38:51 -0500 (EST)
+ Files: hints/irix_6_2.sh hints/irix_6_4.sh
+
+ Title: "Update Plan 9, Win32, VMS configs with $shortsize and $longsize"
+ From: Chip Salzenberg
+ Files: plan9/config.plan9 plan9/genconfig.pl
+ vms/genconfig.pl win32/config.w32
+
+ OTHER CORE CHANGES
+
+ Title: "Fix core dump when embedding"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ Title: "Re: Fragile signals"
+ From: Ilya Zakharevich
+ Msg-ID: <199702130644.BAA07572@monk.mps.ohio-state.edu>
+ Date: Thu, 13 Feb 1997 01:44:39 -0500 (EST)
+ Files: mg.c
+
+ Title: "Make format strings correspond exactly to parameters"
+ From: Roderick Schertler
+ Msg-ID: <pz7mkc1h0g.fsf@eeyore.ibcinc.com>
+ Date: 13 Feb 1997 17:24:31 -0500
+ Files: doio.c ext/DB_File/DB_File.xs ext/Opcode/Opcode.xs gv.c op.c
+ perl.c pp_ctl.c pp_sys.c regcomp.c toke.c
+
+ Title: "Don't try to attach 'o' magic to read-only values"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ Title: "Fix carriage-return message"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "In <=>, test for equality first"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Don't mark sv_{true,false} PADTMP"
+ From: Chip Salzenberg
+ Files: op.c
+
+ BUILD PROCESS
+
+ Title: "Fix eval "" in Configure"
+ From: allen@gateway.grumman.com (John L. Allen)
+ Msg-ID: <9702141809.AA17001@gateway.grumman.com>
+ Date: Fri, 14 Feb 1997 13:09:53 -0500
+ Files: Configure
+
+ Title: "Don't link with -lsfio if sfio is not requested"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "perl5.003_26 Configure change "win" for AIX 4"
+ From: Tim Mooney <mooney@dogbert.cc.ndsu.NoDak.edu>
+ Msg-ID: <Pine.OSF.3.95.970214135751.32654A-100000@dogbert.cc.ndsu.NoD
+ Date: Fri, 14 Feb 1997 13:59:02 -0600 (CST)
+ Files: Configure
+
+ Title: "Update os2/diff.configure"
+ From: Chip Salzenberg
+ Files: os2/diff.configure
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Remove Fatal.pm"
+ From: Chip Salzenberg
+ Files: MANIFEST lib/Fatal.pm pod/perldelta.pod pod/perlmod.pod
+ pod/roffitall t/lib/fatal.t
+
+ Title: "Refresh MakeMaker to 5.40"
+ From: Andy Dougherty, Andreas Koenig, Tim Bunce
+ Files: lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_Unix.pm
+ lib/ExtUtils/MakeMaker.pm lib/ExtUtils/Mksymlists.pm
+
+ Title: "Refresh CPAN.pm to 1.21"
+ From: Andreas Koenig
+ Files: lib/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm
+
+ Title: "Refresh Test::Harness to 1.15"
+ From: Andreas Koenig
+ Files: lib/Test/Harness.pm
+
+ TESTS
+
+ Title: "Remove non-portable locale tests"
+ From: Chip Salzenberg
+ Files: t/pragma/locale.t
+
+ UTILITIES
+
+ Title: "pod2man: missing '-' in name section shouldn't be fatal"
+ From: Ulrich Pfeifer
+ Msg-ID: <yfmzpxcimsa.fsf@ls6.informatik.uni-dortmund.de>
+ Date: 10 Feb 1997 18:38:45 +0100
+ Files: pod/pod2man.PL
+
+ DOCUMENTATION
+
+ Title: "Update To-Do list"
+ From: Tim Bunce
+ Msg-ID: <9702101900.AA25293@toad.ig.co.uk>
+ Date: Mon, 10 Feb 1997 19:00:59 +0000
+ Files: Todo
+
+ Title: "Fix formatting in perldiag"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod
+
+
+----------------
+Version 5.003_26
+----------------
+
+This release is beta candidate #4. "Once more, dear friends...."
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Make \r in script an error (per Larry)"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod toke.c
+
+ Title: "Support '%i' format and 'h' modifier in s?printf"
+ From: Chip Salzenberg
+ Files: doop.c pod/perldelta.pod
+
+ CORE PORTABILITY
+
+ Title: "Fix value of system() and $? for DEC UNIX, VMS, others"
+ From: Chip Salzenberg
+ Files: mg.c perl.h pp_sys.c
+
+ Title: "VMS patches post _25"
+ From: Charles Bailey
+ Msg-ID: <01IF48W3P39W0050BD@hmivax.humgen.upenn.edu>
+ Date: Fri, 07 Feb 1997 01:56:12 -0500 (EST)
+ Files: Porting/Glossary lib/ExtUtils/Liblist.pm
+ lib/ExtUtils/MM_VMS.pm lib/ExtUtils/xsubpp perl.c
+ vms/Makefile vms/config.vms vms/descrip.mms vms/genconfig.pl
+ vms/perlvms.pod vms/vms.c vms/vmsish.h x2p/a2p.c
+
+ Title: "Hints for BSDOS"
+ From: Christopher Davis <ckd@loiosh.kei.com>
+ Msg-ID: <199702042011.PAA09206@loiosh.kei.com>
+ Date: Tue, 4 Feb 1997 15:11:13 -0500 (EST)
+ Files: hints/bsdos.sh
+
+ Title: "On C<sysopen(..., O_APPEND)>, call C<fopen(..., "a")>"
+ From: Chip Salzenberg
+ Files: doio.c
+
+ OTHER CORE CHANGES
+
+ Title: "Fix (yet another) Tk closure problem"
+ From: Chip Salzenberg
+ Files: op.c perl.c pp_ctl.c
+
+ Title: "Fix value of C<foreach>"
+ From: Chip Salzenberg
+ Files: cop.h pp_ctl.c
+
+ Title: "Regexp optimizations"
+ From: Ilya Zakharevich
+ Msg-ID: <199702041102.GAA24805@monk.mps.ohio-state.edu>
+ Date: Tue, 4 Feb 1997 06:02:10 -0500 (EST)
+ Files: regcomp.c regexec.c
+
+ Title: "Re: static buffer in not_a_number() [sv.c] might overflow"
+ From: Gisle Aas
+ Msg-ID: <hbu9uz1si.fsf@bergen.sn.no>
+ Date: 09 Feb 1997 11:55:41 +0100
+ Files: sv.c
+
+ Title: "Refine 'runaway string' heuristic"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Fix core dump on C<print "a", last> in eval"
+ From: Chip Salzenberg
+ Files: pp_ctl.c
+
+ Title: "Catch C<use integer; $x % 0>"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ BUILD PROCESS
+
+ Title: "Fix usage message in configure.gnu"
+ From: Jarkko Hietaniemi
+ Files: configure.gnu
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "DB_File 1.11 patch"
+ From: Paul Marquess
+ Msg-ID: <9702061553.AA18147@claudius.bfsec.bt.co.uk>
+ Date: Thu, 6 Feb 97 15:53:34 GMT
+ Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+
+ Title: "Faster File::Compare"
+ From: Gisle Aas
+ Msg-ID: <199702051342.OAA02753@bergen.sn.no>
+ Date: Wed, 5 Feb 1997 14:42:49 +0100
+ Files: lib/File/Compare.pm
+
+ Title: "Make diagnostics module strip formatting directives"
+ From: Chip Salzenberg
+ Files: lib/diagnostics.pm pod/perldiag.pod
+
+ Title: "Fix warning from missing POSIX::setvbuf()"
+ From: Chip Salzenberg
+ Files: ext/IO/IO.xs
+
+ TESTS
+
+ Title: "Fix closure.t for AmigaOS (again)"
+ From: Norbert Pueschel
+ Msg-ID: <77724742@Armageddon.meb.uni-bonn.de>
+ Date: Wed, 05 Feb 1997 18:56:45 +0100
+ Files: t/op/closure.t
+
+ UTILITIES
+
+ Title: "perldoc -f <perlfunc>"
+ From: Gisle Aas
+ Msg-ID: <199702051127.MAA02090@bergen.sn.no>
+ Date: Wed, 5 Feb 1997 12:27:36 +0100
+ Files: utils/perldoc.PL
+
+ Title: "Fix pod2man's handling of quotes in =items"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199702042023.WAA13143@alpha.hut.fi>
+ Date: Tue, 4 Feb 1997 22:23:34 +0200 (EET)
+ Files: pod/pod2man.PL
+
+ DOCUMENTATION
+
+ Title: "return *FH pod patch"
+ From: allen@gateway.grumman.com (John L. Allen)
+ Msg-ID: <9702061507.AA04474@gateway.grumman.com>
+ Date: Thu, 6 Feb 1997 10:07:28 -0500
+ Files: pod/perldata.pod pod/perlsub.pod
+
+ Title: "Describe interation of untie and DESTROY"
+ From: Paul Marquess and Chip Salzenberg
+ Files: pod/perltie.pod
+
+
+----------------
+Version 5.003_25
+----------------
+
+This release is beta candidate #3. Here's hoping...
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Make $] read-only"
+ From: Chip Salzenberg
+ Files: gv.c
+
+ Title: "New variable C<$^S> is a native version of C<$?>"
+ From: Chip Salzenberg
+ Files: doio.c global.sym gv.c interp.sym lib/English.pm mg.c perl.c
+ perl.h pod/perldelta.pod pod/perlfunc.pod pod/perlvar.pod
+ pp_ctl.c pp_sys.c proto.h util.c
+
+ Title: "Make $^T work with undump, and don't taint it"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ CORE PORTABILITY
+
+ Title: "VMS patches for _24"
+ From: Charles Bailey
+ Msg-ID: <01IEUIFP5038004GQP@hmivax.humgen.upenn.edu>
+ Date: Fri, 31 Jan 1997 02:34:37 -0500 (EST)
+ Files: ext/DynaLoader/DynaLoader.pm ext/DynaLoader/dl_vms.xs
+ lib/AutoSplit.pm lib/ExtUtils/MM_VMS.pm
+ lib/ExtUtils/MakeMaker.pm perl.h pp_hot.c t/lib/filehand.t
+ t/op/closure.t vms/Makefile vms/config.vms vms/descrip.mms
+ vms/ext/filespec.t vms/vms.c vms/vmsish.h
+
+ Title: "hints/dec_osf.sh: polishing the comments"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199701301958.VAA08992@alpha.hut.fi>
+ Date: Thu, 30 Jan 1997 21:58:10 +0200 (EET)
+ Files: hints/dec_osf.sh
+
+ Title: "amigaos.sh"
+ From: Norbert Pueschel
+ Msg-ID: <77724724@Armageddon.meb.uni-bonn.de>
+ Date: Wed, 29 Jan 1997 11:39:49 +0100
+ Files: hints/amigaos.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Require '-T' in argv[], not just on #! line"
+ From: Chip Salzenberg
+ Files: perl.c pod/perldiag.pod
+
+ Title: "Fix C<return @_> and associated stack bugs"
+ From: Chip Salzenberg
+ Files: cop.h pp_ctl.c pp_hot.c t/op/misc.t
+
+ Title: "Fix never-closing handle after C<select>"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "Fix /\G/g with patterns that match empty string"
+ From: Ilya Zakharevich
+ Files: pp_hot.c
+
+ Title: "Fix scalar leak in av_unshift"
+ From: Chip Salzenberg
+ Files: av.c
+
+ Title: "Ignore refs to lexicals when making refs to lexicals"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Don't create AV, HV, IO when assigning glob"
+ From: Chip Salzenberg
+ Files: mg.c
+
+ BUILD PROCESS
+
+ Title: "Configure updates for intsize and ssizetype"
+ From: Andy Dougherty
+ Files: Configure MANIFEST config_H config_h.SH handy.h
+
+ Title: "Ask about /usr/bin/perl iff STDIN and STDERR are terminals"
+ From: Chip Salzenberg
+ Files: installperl
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Refresh CPAN to 1.19"
+ From: Andreas Koenig
+ Files: lib/Bundle/CPAN.pm lib/CPAN.pm lib/CPAN/FirstTime.pm
+
+ Title: "Debugger update"
+ From: Ilya Zakharevich
+ Msg-ID: <199702030406.XAA23029@monk.mps.ohio-state.edu>
+ Date: Sun, 2 Feb 1997 23:06:34 -0500 (EST)
+ Files: lib/perl5db.pl
+
+ Title: "In Symbol::gensym, don't make glob fake by copying it"
+ From: John Hughes <john@AtlanTech.COM>
+ Files: lib/Symbol.pm
+
+ Title: "Make POSIX::is*() eight-bit-clean"
+ From: Chip Salzenberg
+ Files: ext/POSIX/POSIX.xs
+
+ Title: "Make IO::Handle::gets() an alias of getline"
+ From: Gisle Aas
+ Msg-ID: <199701301103.MAA11291@bergen.sn.no>
+ Date: Thu, 30 Jan 1997 12:03:15 +0100
+ Files: ext/IO/lib/IO/Handle.pm lib/IO/Handle.pm
+
+ TESTS
+
+ Title: "More Amiga test patches"
+ From: Norbert Pueschel
+ Msg-ID: <77724725@Armageddon.meb.uni-bonn.de>
+ Date: Wed, 29 Jan 1997 16:07:33 +0100
+ Files: README.amiga t/lib/safe2.t t/op/closure.t
+
+ UTILITIES
+
+ Title: "c2ph.PL fix"
+ From: lvirden@cas.org (Larry W. Virden)
+ Msg-ID: <199701301349.IAA16724@cas.org>
+ Date: Thu, 30 Jan 1997 08:49:19 -0500
+ Files: utils/c2ph.PL
+
+ Title: "Make pod2man a little laxer for perltoc.pod"
+ From: Chip Salzenberg
+ Files: pod/pod2man.PL
+
+ DOCUMENTATION
+
+ Title: "Update to perl INSTALL file"
+ From: lvirden@cas.org (Larry W. Virden)
+ Msg-ID: <199701301338.IAA15878@cas.org>
+ Date: Thu, 30 Jan 1997 08:38:23 -0500
+ Files: INSTALL
+
+ Title: "Update to perl.pod suggested"
+ From: lvirden@cas.org (Larry W. Virden)
+ Msg-ID: <199701301345.IAA16514@cas.org>
+ Date: Thu, 30 Jan 1997 08:45:59 -0500
+ Files: pod/perl.pod
+
+ Title: "Document how extension pms go in $archlib"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod
+
+ Title: "perlfunc.pod tweaks"
+ From: Roderick Schertler
+ Msg-ID: <20526.854659255@eeyore.ibcinc.com>
+ Date: Thu, 30 Jan 1997 16:20:55 -0500
+ Files: pod/perlfunc.pod
+
+ Title: "new (Feb 1) perlembed.pod"
+ From: Jon Orwant <orwant@media.mit.edu>
+ Msg-ID: <9702012334.AA15747@fahrenheit-451.media.mit.edu>
+ Date: Sat, 1 Feb 1997 18:34:59 -0500
+ Files: pod/perlembed.pod
+
+ Title: "Error lines must not have trialing periods"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod
+
+
+----------------
+Version 5.003_24
+----------------
+
+This release is the second candidate for a public beta test.
+It's, well, bunches better than _23.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "glob defaults to $_"
+ From: Gurusamy Sarathy
+ Msg-ID: <199701270809.DAA00934@aatma.engin.umich.edu>
+ Date: Mon, 27 Jan 1997 03:09:13 -0500
+ Files: op.c opcode.pl pod/perlfunc.pod t/op/glob.t
+
+ Title: "Re: an overloading bug "
+ From: Gurusamy Sarathy
+ Msg-ID: <199701270007.TAA26525@aatma.engin.umich.edu>
+ Date: Sun, 26 Jan 1997 19:07:45 -0500
+ Files: pod/perldiag.pod pod/perlfunc.pod pp_ctl.c
+
+ Title: "Don't warn on C<$\ = undef>"
+ From: Chip Salzenberg
+ Files: mg.c
+
+ CORE PORTABILITY
+
+ Title: "Win32 port"
+ From: Gary Ng <71564.1743@compuserve.com>
+ Files: MANIFEST win32/*
+
+ Title: "Amiga files"
+ From: Norbert Pueschel
+ Msg-ID: <77724712@Armageddon.meb.uni-bonn.de>
+ Date: Sun, 26 Jan 1997 17:42:15 +0100
+ Files: MANIFEST README.amiga hints/amigaos.sh
+
+ Title: "New dec_osf hints"
+ From: Jarkko.Hietaniemi@cc.hut.fi
+ Msg-ID: <199701271233.OAA21548@alpha.hut.fi>
+ Date: Mon, 27 Jan 1997 14:33:01 +0200 (EET)
+ Files: hints/dec_osf.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Prevent premature death of @_ during leavesub"
+ From: Chip Salzenberg
+ Files: pp_hot.c t/op/misc.t
+
+ Title: "Deref old stash when re-blessing"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ Title: "Don't abort when RCHECK and DEBUGGING"
+ From: Tim Bunce
+ Msg-ID: <9701272339.AA16537@toad.ig.co.uk>
+ Date: Mon, 27 Jan 1997 23:39:48 +0000
+ Files: malloc.c
+
+ Title: "Fix overloading macro conflict with Digital 'cc -fast'"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199701272216.AAA04557@alpha.hut.fi>
+ Date: Tue, 28 Jan 1997 00:16:49 +0200 (EET)
+ Files: perl.h
+
+ Title: "global.sym: typo?"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199701261937.VAA07556@alpha.hut.fi>
+ Date: Sun, 26 Jan 1997 21:37:59 +0200 (EET)
+ Files: global.sym
+
+ BUILD PROCESS
+
+ Title: "Put all extensions' modules in $archlib"
+ From: Chip Salzenberg
+ Files: installperl
+
+ Title: "Configure fixes: set $archlib, omit _NO_PROTO"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Make configure{,.gnu} ignore --cache-file option"
+ From: Norbert Pueschel
+ Files: configure configure.gnu
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Version checking in XS bootstrap is optional"
+ From: Chip Salzenberg
+ Files: XSUB.h
+
+ Title: "Update $VERSION of DynaLoader and POSIX"
+ From: Chip Salzenberg
+ Files: ext/DynaLoader/DynaLoader.pm ext/POSIX/POSIX.pm
+
+ Title: "Refresh Text::Wrap to 97.011701"
+ From: Chip Salzenberg
+ Files: lib/Text/Wrap.pm
+
+ Title: "Fcntl.xs: F_[GS]ETOWN were in wrong case branch"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199701251510.RAA05142@alpha.hut.fi>
+ Date: Sat, 25 Jan 1997 17:10:20 +0200 (EET)
+ Files: ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs
+
+ Title: "Fix $Is_VMS typo in Test::Harness"
+ From: Chip Salzenberg
+ Files: lib/Test/Harness.pm
+
+ Title: "Allow for really big keys in Tie::SubstrHash"
+ From: data-drift@so.uio.no
+ Msg-ID: <199701282014.VAA12645@selters.uio.no>
+ Date: Tue, 28 Jan 1997 21:14:34 +0100 (MET)
+ Files: lib/Tie/SubstrHash.pm
+
+ Title: "Avoid newRV_noinc() in IO, for compiling with old Perls"
+ From: Chip Salzenberg
+ Files: ext/IO/IO.xs
+
+ TESTS
+
+ Title: "New test op/closure.t"
+ From: Tom Phoenix, Ulrich Pfeifer
+ Files: MANIFEST t/op/closure.t
+
+ UTILITIES
+
+ Title: "xsubpp handing of void funcs breaks extensions using XST_m*()"
+ From: Tim Bunce
+ Msg-ID: <9701271659.AA15137@toad.ig.co.uk>
+ Date: Mon, 27 Jan 1997 16:59:06 +0000
+ Files: lib/ExtUtils/xsubpp
+
+ DOCUMENTATION
+
+ Title: "perldelta Fcntl enhancement"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199701251505.RAA22159@alpha.hut.fi>
+ Date: Sat, 25 Jan 1997 17:05:34 +0200 (EET)
+ Files: pod/perldelta.pod
+
+ Title: "Updates to perldelta re: Fcntl, DB_File, Net::Ping"
+ From: Paul Marquess
+ Files: pod/perldelta.pod
+
+ Title: "Document restrictions on gv_fetchmethod() and perl_call_sv()"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perlguts.pod
+
+ Title: "perldiag.pod: No comma allowed after %s"
+ From: Jarkko.Hietaniemi@cc.hut.fi
+ Msg-ID: <199701251541.RAA04120@alpha.hut.fi>
+ Date: Sat, 25 Jan 1997 17:41:53 +0200 (EET)
+ Files: pod/perldiag.pod
+
+ Title: "perlfunc.pod: localtime"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199701251629.SAA08114@alpha.hut.fi>
+ Date: Sat, 25 Jan 1997 18:29:37 +0200 (EET)
+ Files: pod/perlfunc.pod
+
+ Title: "perlfunc diff: gmtime"
+ From: Peter Haworth <pmh@edison.ioppublishing.com>
+ Msg-ID: <32EE1298.7B90@edison.ioppublishing.com>
+ Date: Tue, 28 Jan 1997 14:52:08 +0000
+ Files: pod/perlfunc.pod
+
+ Title: "Updates to guts"
+ From: Ilya Zakharevich
+ Msg-ID: <199701270034.TAA13177@monk.mps.ohio-state.edu>
+ Date: Sun, 26 Jan 1997 19:34:18 -0500 (EST)
+ Files: pod/perlguts.pod
+
+ Title: "perltoot fixes"
+ From: Tom Christiansen
+ Msg-ID: <6807.854214205@jinete>
+ Date: Sat, 25 Jan 1997 09:43:25 -0800
+ Files: pod/perltoot.pod
+
+ Title: "5.003_23: small typo in perlsyn.pod"
+ From: Gurusamy Sarathy
+ Msg-ID: <199701270824.DAA01169@aatma.engin.umich.edu>
+ Date: Mon, 27 Jan 1997 03:24:25 -0500
+ Files: pod/perlsyn.pod
+
+
+----------------
+Version 5.003_23
+----------------
+
+This release is our first candidate for a public beta test.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Disallow changing $_[0] in __DIE__ handlers"
+ From: Chip Salzenberg
+ Files: pod/perlfunc.pod util.c
+
+ Title: "Fix overloading with inheritance and AUTOLOAD"
+ From: Ilya Zakharevich
+ Msg-ID: <199701202226.RAA05072@monk.mps.ohio-state.edu>
+ Date: Mon, 20 Jan 1997 17:26:32 -0500 (EST)
+ Files: gv.c lib/diagnostics.pm lib/overload.pm pod/perldebug.pod
+ pod/perldiag.pod pod/perlfunc.pod pod/perlop.pod
+ pod/perlre.pod pod/perltoc.pod pod/perlxs.pod
+
+ Title: "Nested here-docs"
+ From: larry@wall.org (Larry Wall)
+ Msg-ID: <199701202313.PAA11693@wall.org>
+ Date: Mon, 20 Jan 1997 15:13:42 -0800
+ Files: toke.c
+
+ Title: "Revert $^X to old behavior (plus HP-UX bug fix)"
+ From: Chip Salzenberg
+ Files: hints/hpux.sh toke.c
+
+ Title: "Protect against '0' in 'stmt while <HANDLE>'"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Don't warn when closure uses var at file scope"
+ From: Chip Salzenberg
+ Files: op.c
+
+ CORE PORTABILITY
+
+ Title: "VMS patches for _22"
+ From: Charles Bailey
+ Msg-ID: <01IEGBJ2TMYS003PCL@hmivax.humgen.upenn.edu>
+ Date: Mon, 20 Jan 1997 22:50:21 -0500 (EST)
+ Files: ext/POSIX/POSIX.xs lib/ExtUtils/MM_VMS.pm lib/ExtUtils/xsubpp
+ lib/Test/Harness.pm toke.c vms/Makefile vms/descrip.mms
+ vms/genconfig.pl vms/perly_c.vms vms/vmsish.h x2p/a2p.h
+ vms/Makefile vms/config.vms vms/descrip.mms vms/perly_c.vms
+
+ Title: "Re: Perl 5.003_21: OS/2 patches"
+ From: Ilya Zakharevich
+ Msg-ID: <199701170446.XAA28939@monk.mps.ohio-state.edu>
+ Date: Thu, 16 Jan 1997 23:46:40 -0500 (EST)
+ Files: os2/Changes os2/os2.c
+
+ Title: "Plan9 update"
+ From: lutherh@stratcom.com (Luther Huffman)
+ Files: plan9/config.plan9 plan9/mkfile
+
+ Title: "Bugfixes for AmigaOS"
+ From: Norbert Pueschel
+ Msg-ID: <77724691@Armageddon.meb.uni-bonn.de>
+ Date: Wed, 22 Jan 1997 00:13:54 +0100
+ Files: hints/amigaos.sh lib/File/Basename.pm
+
+ Title: "New dec_osf.sh hints file"
+ From: Achim Bohnet <ach@rosat.mpe-garching.mpg.de>
+ Msg-ID: <9701241058.AA29550@o09.rosat.mpe-garching.mpg.de>
+ Date: Fri, 24 Jan 1997 11:58:24 +0100
+ Files: hints/dec_osf.sh
+
+ Title: "on NeXT: gdbm problem fixed"
+ From: Andreas Koenig
+ Msg-ID: <199701210201.DAA17794@anna.in-berlin.de>
+ Date: Tue, 21 Jan 1997 03:01:32 +0100
+ Files: hints/next_3.sh hints/next_3_0.sh
+
+ Title: "patch for hints/powerux.sh"
+ From: tom@amber.ssd.hcsc.com (Tom Horsley)
+ Msg-ID: <9701181833.AA02602@amber.ssd.hcsc.com>
+ Date: Sat, 18 Jan 97 13:33:26 -0500
+ Files: hints/powerux.sh
+
+ Title: "hints & Configure changes to build perl on DC/OSx"
+ From: Stephen Zander <stephen.zander@interlock.mckesson.com>
+ Msg-ID: <199701170043.QAA25985@wsbip1.mckesson.com>
+ Date: Thu, 16 Jan 1997 16:43:52 -0800
+ Files: Configure MANIFEST hints/dcosx.sh
+
+ Title: "patch for hints/cxux.sh perl5.003_22"
+ From: tom@amber.ssd.hcsc.com (Tom Horsley)
+ Msg-ID: <9701192014.AA05722@amber.ssd.hcsc.com>
+ Date: Sun, 19 Jan 97 15:14:04 -0500
+ Files: hints/cxux.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Make PERL5LIB and -I work like C<use lib>"
+ From: Tim Bunce
+ Msg-ID: <9701231523.AA26613@toad.ig.co.uk>
+ Date: Thu, 23 Jan 1997 15:23:27 +0000
+ Files: lib/lib.pm perl.c
+
+ Title: "Fix /\G.a/"
+ From: Chip Salzenberg
+ Files: regcomp.c regcomp.h regexec.c regexp.h toke.c
+
+ Title: "Extend stack in pp_undef (!)"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Allow for sub to be redefined while executing"
+ From: Chip Salzenberg
+ Files: cop.h pp_hot.c t/op/misc.t
+
+ Title: "Eliminate redundant flag CVf_FORMAT"
+ From: Chip Salzenberg
+ Files: cv.h op.c perl.c perly.c perly.y proto.h sv.c toke.c
+
+ Title: "Generate IVs when possible in abs() and int()"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Efficiency patchlet for pp_aassign()"
+ From: Ilya Zakharevich
+ Msg-ID: <199701210305.WAA05451@monk.mps.ohio-state.edu>
+ Date: Mon, 20 Jan 1997 22:05:39 -0500 (EST)
+ Files: pp_hot.c
+
+ Title: "When sorting, promote to PVNV only for built-in comparison"
+ From: Chip Salzenberg
+ Files: pp_ctl.c
+
+ Title: "Remove "suidperl security patch" message"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ BUILD PROCESS
+
+ Title: "Make configure.gnu a copy of configure; make configure writea
+ From: Chip Salzenberg
+ Files: MANIFEST configure.gnu
+
+ Title: "Regen Configure with metaconfig: +ARCHNAME, -FILE_filbuf"
+ From: Chip Salzenberg and Charles Bailey
+ Files: Configure config_H config_h.SH hints/lynxos.sh
+ os2/diff.configure os2/os2ish.h plan9/config.plan9 sv.c
+ utils/perlbug.PL vms/config.vms vms/fndvers.com
+
+ Title: "Compile with optimization when testing memory functions"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Minor patch for Debian installation"
+ From: Chip Salzenberg
+ Files: installperl
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Debugger update"
+ From: Ilya Zakharevich
+ Msg-ID: <199701190455.XAA02579@monk.mps.ohio-state.edu>
+ Date: Sat, 18 Jan 1997 23:54:59 -0500 (EST)
+ Files: lib/perl5db.pl
+
+ Title: "DynaLoader enhancement: support RTLD_GLOBAL"
+ From: Nick Ing-Simmons
+ Msg-ID: <199701240937.JAA11443@pluto.tiuk.ti.com>
+ Date: Fri, 24 Jan 1997 09:37:18 GMT
+ Files: ext/DynaLoader/DynaLoader.pm ext/DynaLoader/dl_aix.xs
+ ext/DynaLoader/dl_dld.xs ext/DynaLoader/dl_dlopen.xs
+ ext/DynaLoader/dl_hpux.xs ext/DynaLoader/dl_next.xs
+ ext/DynaLoader/dl_vms.xs
+
+ Title: "Fcntl: add more constants"
+ From: Jarkko.Hietaniemi@cc.hut.fi
+ Msg-ID: <199701191811.UAA16346@alpha.hut.fi>
+ Date: Sun, 19 Jan 1997 20:11:22 +0200 (EET)
+ Files: ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs
+
+ Title: "Refresh IO to 1.15 (plus DESTROY and new_tmpfile fixes)"
+ From: Chip Salzenberg
+ Files: 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/Socket.pm t/lib/io_pipe.t
+
+ Title: "Allow IO.xs to remain at 1.15 while $VERSION is 1.1501"
+ From: Chip Salzenberg
+ Files: XSUB.h ext/IO/Makefile.PL ext/IO/lib/IO/Handle.pm
+
+ Title: "Refresh CPAN to 1.15"
+ From: Andreas Koenig
+ Files: lib/CPAN.pm lib/CPAN/FirstTime.pm
+
+ Title: "Add E* and SA_* constants"
+ From: Roderick Schertler
+ Msg-ID: <23338.853986967@eeyore.ibcinc.com>
+ Date: Wed, 22 Jan 1997 21:36:07 -0500
+ Files: ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs
+
+ TESTS
+
+ Title: "Test nested here-docs"
+ From: hv@crypt.compulink.co.uk (Hugo van der Sanden)
+ Msg-ID: <199701210053.AAA02139@crypt.compulink.co.uk>
+ Date: Tue, 21 Jan 1997 00:53:44 +0000 (GMT)
+ Files: t/base/lex.t
+
+ Title: "Fix tests of $^X and $0 to work with QNX"
+ From: Chip Salzenberg
+ Files: t/lib/io_pipe.t t/lib/open2.t t/lib/open3.t t/op/magic.t
+
+ Title: "Patch tests for systems without fork()"
+ From: Norbert Pueschel
+ Msg-ID: <77724697@Armageddon.meb.uni-bonn.de>
+ Date: Thu, 23 Jan 1997 23:51:28 +0100
+ Files: t/io/pipe.t t/lib/filehand.t t/lib/io_pipe.t t/lib/io_sock.t
+ t/lib/open2.t t/lib/open3.t t/op/fork.t
+
+ Title: "Test patches for OS/2"
+ From: Ilya Zakharevich
+ Msg-ID: <199701170448.XAA28948@monk.mps.ohio-state.edu>
+ Date: Thu, 16 Jan 1997 23:48:18 -0500 (EST)
+ Files: os2/OS2/ExtAttr/t/os2_ea.t os2/OS2/PrfDB/t/os2_prfdb.t
+ os2/OS2/REXX/t/rx_cmprt.t os2/OS2/REXX/t/rx_dllld.t
+ os2/OS2/REXX/t/rx_objcall.t os2/OS2/REXX/t/rx_sql.test
+ os2/OS2/REXX/t/rx_tiesql.test os2/OS2/REXX/t/rx_tievar.t
+ os2/OS2/REXX/t/rx_tieydb.t os2/OS2/REXX/t/rx_varset.t
+ os2/OS2/REXX/t/rx_vrexx.t t/README t/cmd/while.t
+ t/comp/colon.t t/comp/multiline.t t/io/argv.t t/lib/anydbm.t
+ t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t
+ t/op/cmp.t t/op/magic.t
+
+ UTILITIES
+
+ Title: "Translate \200 to &#200; in pod2html"
+ From: Chip Salzenberg
+ Files: pod/pod2html.PL
+
+ Title: "VMS patches: '.com' extension on scripts"
+ From: Charles Bailey
+ Msg-ID: <01IELNPDLYJM003E7J@hmivax.humgen.upenn.edu>
+ Date: Fri, 24 Jan 1997 18:42:29 -0500 (EST)
+ Files: pod/checkpods.PL pod/pod2html.PL pod/pod2latex.PL
+ pod/pod2man.PL pod/pod2text.PL utils/c2ph.PL utils/h2ph.PL
+ utils/h2xs.PL utils/perlbug.PL utils/perldoc.PL
+ utils/pl2pm.PL utils/splain.PL vms/Makefile vms/descrip.mms
+ x2p/find2perl.PL x2p/s2p.PL
+
+ Title: "Allow MakeMaker 5.34 to use libraries containing '+' in name"
+ From: dennism@cyrix.com (Dennis Marsa)
+ Msg-ID: <9701172027.AA27861@orion.cyrix.com>
+ Date: Fri, 17 Jan 97 14:27:32 CST
+ Files: lib/ExtUtils/Liblist.pm
+
+ DOCUMENTATION
+
+ Title: "First cut at INSTALL edit"
+ From: Chip Salzenberg
+ Files: INSTALL
+
+ Title: "Additional docs for __DIE__ and __WARN__"
+ From: Gurusamy Sarathy
+ Files: pod/perlfunc.pod pod/perlrun.pod pod/perlvar.pod
+
+ Title: "Document #line directive"
+ From: Gurusamy Sarathy
+ Msg-ID: <199701240908.EAA23846@aatma.engin.umich.edu>
+ Date: Fri, 24 Jan 1997 04:08:44 -0500
+ Files: pod/perlsyn.pod pod/perltoc.pod
+
+ Title: "Perlguts version 30"
+ From: Jeff Okamoto
+ Msg-ID: <199701172117.AA116515863@hpcc123.corp.hp.com>
+ Date: Fri, 17 Jan 1997 13:17:43 -0800
+ Files: pod/perlguts.pod
+
+ Title: "delta for perldelta"
+ From: Tom Christiansen
+ Msg-ID: <804.854121463@jinete>
+ Date: Fri, 24 Jan 1997 07:57:43 -0800
+ Files: pod/perlnews.pod pod/perltoc.pod
+
+ Title: "Updates to perldelta"
+ From: Ilya Zakharevich
+ Msg-ID: <199701211610.LAA06227@monk.mps.ohio-state.edu>
+ Date: Mon, 20 Jan 1997 06:48:49 -0500 (EST)
+ Files: pod/perlnews.pod pod/perltoc.pod
+
+ Title: "perlnews.pod diff for the Fcntl"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199701211600.SAA30117@alpha.hut.fi>
+ Date: Tue, 21 Jan 1997 18:00:56 +0200 (EET)
+ Files: pod/perlnews.pod
+
+ Title: "Rename perlnews -> perldelta per Tom's request"
+ From: Chip Salzenberg
+ Files: MANIFEST pod/Makefile pod/buildtoc pod/perl.pod
+ pod/perldelta.pod pod/perltoc.pod pod/roffitall
+
+ Title: "Remove bad advice from perllocale.pod"
+ From: Chip Salzenberg
+ Files: pod/perllocale.pod
+
+
+----------------
+Version 5.003_22
+----------------
+
+This release is primarily made up of bug fixes, the foremost among
+which repairs a showstopper memory corruption bug in formats.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Fix parsing of C< ${ xyz } >"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Don't parse method calls in strings"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Fix overly picky carping about leading '{' in regex"
+ From: Chip Salzenberg
+ Files: regcomp.c
+
+ OTHER CORE CHANGES
+
+ Title: "Fix memory corruption from formats"
+ From: Chip Salzenberg
+ Files: op.c perl.c perly.c perly.c.diff perly.y proto.h sv.c toke.c
+
+ BUILD PROCESS
+
+ Title: "Fix '_mopop' typo"
+ From: Chip Salzenberg
+ Files: Makefile.SH
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Gut IO::Handle::DESTROY"
+ From: Chip Salzenberg
+ Files: ext/IO/lib/IO/Handle.pm
+
+ Title: "RiscOS is case-insensitive"
+ From: Chip Salzenberg
+ Files: lib/File/Basename.pm
+
+ TESTS
+
+ Title: "Fix thinko in db-recno.t"
+ From: Chip Salzenberg
+ Files: t/lib/db-recno.t
+
+ UTILITIES
+
+ Title: "Make perlbug more cautionary and more verbose"
+ From: Kenneth Albanowski and Jarkko Hietaniemi
+ Files: utils/perlbug.PL
+
+ DOCUMENTATION
+
+ Title: "NEW roffitall + INSTALL fix"
+ From: Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com>
+ Msg-ID: <6058.853410121@lyon.grenoble.hp.com>
+ Date: Thu, 16 Jan 97 11:22:01 +0100
+ Files: INSTALL pod/roffitall
+
+ Title: "srand() doc update"
+ From: Roderick Schertler
+ Msg-ID: <24195.853379065@eeyore.ibcinc.com>
+ Date: Wed, 15 Jan 1997 20:44:25 -0500
+ Files: pod/perlfunc.pod
+
+ Title: "documentation of configpm (perl5.003_20)"
+ From: win@in.rhein-main.de (Winfried Koenig)
+ Msg-ID: <m0vkU40-0004WAC@incom.rhein-main.de>
+ Date: Wed, 15 Jan 1997 14:03:27 +0200 (EET)
+ Files: configpm
+
+
+----------------
+Version 5.003_21
+----------------
+
+This release includes several important bug fixes, and a couple of
+minor but valuable language tweaks. Please read on for a list of the
+significant changes:
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Fix overloading via inherited autoloaded functions"
+ From: Ilya Zakharevich
+ Msg-ID: <199701131022.FAA22830@monk.mps.ohio-state.edu>
+ Date: Mon, 13 Jan 1997 05:22:47 -0500 (EST)
+ Files: gv.c lib/overload.pm pod/perldiag.pod t/pragma/overload.t
+
+ Title: "Method call fixes: Don't cache in alias, don't skip undef"
+ From: Chip Salzenberg
+ Files: global.sym gv.c gv.h hv.c op.c pod/perlguts.pod
+ pod/perltoc.pod pp.c pp_ctl.c pp_hot.c proto.h scope.c sv.c
+ t/op/method.t
+
+ Title: "Formats can be closures"
+ From: Chip Salzenberg
+ Files: cv.h op.c perly.c perly.c.diff perly.y pp_sys.c sv.h
+
+ Title: "Quote 'foo' in C<$x{-foo}>"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Forbid C< x->{y} > and C< x->[0] > under C<strict refs>"
+ From: Chip Salzenberg
+ Files: op.c pod/perldiag.pod t/pragma/strict-refs
+
+ Title: "Allow <=> to return undef when operands are not ordered"
+ From: Chip Salzenberg and Andreas Koenig
+ Files: MANIFEST pp.c t/op/cmp.t
+
+ Title: "Fail regex that starts with '{'"
+ From: Chip Salzenberg
+ Files: regcomp.c
+
+ CORE PORTABILITY
+
+ Title: "Re: Perl 5.003_20: OS/2 patches"
+ From: Ilya Zakharevich
+ Msg-ID: <199701101102.GAA19051@monk.mps.ohio-state.edu>
+ Date: Fri, 10 Jan 1997 06:02:16 -0500 (EST)
+ Files: hints/os2.sh os2/Changes os2/os2.c os2/os2ish.h pp_sys.c
+
+ Title: "VMS patches for _20"
+ From: Charles Bailey
+ Msg-ID: <01IE7MGK7ULQ003K5M@hmivax.humgen.upenn.edu>
+ Date: Tue, 14 Jan 1997 17:34:43 -0500 (EST)
+ Files: configpm dosish.h os2/os2ish.h plan9/plan9ish.h proto.h
+ t/pragma/strict.t t/pragma/subs.t t/pragma/warning.t toke.c
+ unixish.h vms/Makefile vms/config.vms vms/descrip.mms
+ vms/genconfig.pl vms/perly_c.vms vms/test.com vms/vmsish.h
+ x2p/a2p.h x2p/str.c
+
+ Title: "Irix 6.3 & 6.4 and perl5.003_20"
+ From: John Stoffel <jfs@fluent.com>
+ Msg-ID: <199701132242.RAA14601@jfs.Fluent.COM>
+ Date: Mon, 13 Jan 1997 17:42:50 -0500 (EST)
+ Files: MANIFEST hints/irix_6_3.sh hints/irix_6_4.sh
+
+ Title: "Patch: MachTen hints, Configure"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03010d00af0123a93670@[194.51.248.75]>
+ Date: Tue, 14 Jan 1997 13:43:13 +0100
+ Files: Configure hints/machten.sh
+
+ Title: "Rename aux.sh to aux_3.sh for MS-LOSS"
+ From: Chip Salzenberg
+ Files: MANIFEST hints/aux_3.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Fix C< eval { my $x; eval '$x' } >"
+ From: Chip Salzenberg
+ Files: op.c t/op/misc.t
+
+ Title: "Don't warn if eval '' uses outer func's lexicals"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Avoid memory wastage in wait(); make pidstatus global"
+ From: Chip Salzenberg
+ Files: global.sym interp.sym perl.c perl.h pp_sys.c
+
+ Title: "Forbid ++ and -- on readonly values"
+ From: "John Q. Linux" <jql@accessone.com>
+ Msg-ID: <Pine.LNX.3.95.970110193330.11249D-100000@jql.accessone.com>
+ Date: Fri, 10 Jan 1997 19:47:16 -0800 (PST)
+ Files: pp.c pp_hot.c
+
+ Title: "Keep array from dying during foreach(@array)"
+ From: Chip Salzenberg
+ Files: cop.h pp_ctl.c
+
+ Title: "Fix C< $a="simple"; split /($a)/o >"
+ From: Chip Salzenberg
+ Files: pp.c t/op/misc.t
+
+ Title: "Fix infinite loop for undef function in @SIG{__WARN__,__DIE__}"
+ From: Chip Salzenberg
+ Files: util.c
+
+ Title: "Fix for anon-lists with tied entries coredump"
+ From: Gurusamy Sarathy
+ Msg-ID: <199701100745.CAA13057@aatma.engin.umich.edu>
+ Date: Fri, 10 Jan 1997 02:45:11 -0500
+ Files: pp.c
+
+ Title: "Don't set SVf_PADBUSY on immortal SVs"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Patch for Object subroutines"
+ From: Ilya Zakharevich
+ Msg-ID: <199701080156.UAA15366@monk.mps.ohio-state.edu>
+ Date: Tue, 7 Jan 1997 20:56:02 -0500 (EST)
+ Files: cop.h
+
+ Title: "Use an SVt_PVLV to hold stacked OP pointers when debugging"
+ From: Chip Salzenberg
+ Files: pp.c pp_hot.c
+
+ Title: "Undo change that freed large pad vars"
+ From: Chip Salzenberg
+ Files: scope.c
+
+ BUILD PROCESS
+
+ Title: "Make MachTen hints file warn about db-recno failures"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03010d00aef92fba6aca@[194.51.248.78]>
+ Date: Wed, 8 Jan 1997 12:07:18 +0100
+ Files: hints/machten.sh
+
+ Title: "5.003_20, FreeBSD 3.0 and minor patch"
+ From: roberto@eurocontrol.fr (Ollivier Robert)
+ Msg-ID: <Mutt.19970108143747.roberto@caerdonn.eurocontrol.fr>
+ Date: Wed, 8 Jan 1997 14:37:47 +0100
+ Files: Configure
+
+ Title: "Make installperl quieter; only shared libraries need 0555"
+ From: Chip Salzenberg
+ Files: installperl
+
+ TESTS
+
+ Title: "Advice on TEST failure"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03010d01aefbaefcf3bc@[194.51.248.78]>
+ Date: Fri, 10 Jan 1997 10:19:07 +0100
+ Files: t/TEST
+
+ Title: "UNIVERSAL tests"
+ From: Roderick Schertler
+ Files: MANIFEST t/op/universal.t
+
+ Title: "Test deletion of array during foreach"
+ From: Jarkko Hietaniemi
+ Files: t/op/misc.t
+
+ Title: "patch for db-recno.t"
+ From: Paul Marquess
+ Msg-ID: <9701121509.AA11147@claudius.bfsec.bt.co.uk>
+ Date: Sun, 12 Jan 1997 15:09:33 +0000 (GMT)
+ Files: t/lib/db-recno.t
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Localize info about filesystems being case-forgiving"
+ From: Chip Salzenberg
+ Files: lib/File/Basename.pm pod/checkpods.PL pod/pod2html.PL
+ pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL
+ utils/c2ph.PL utils/h2ph.PL utils/h2xs.PL utils/perlbug.PL
+ utils/perldoc.PL utils/pl2pm.PL utils/splain.PL
+ x2p/find2perl.PL x2p/s2p.PL
+
+ Title: "Fix for fd leak in IO::File::new_tmpfile"
+ From: Graham Barr and Chip Salzenberg
+ Files: ext/IO/IO.xs ext/IO/lib/IO/Handle.pm
+
+ Title: "Refresh Getopt::Long to 2.6"
+ From: Johan Vromans <jvromans@squirrel.nl>
+ Files: lib/Getopt/Long.pm
+
+ Title: "Refresh DB_File to 1.10"
+ From: Paul Marquess
+ Msg-ID: <9701141247.AA21242@claudius.bfsec.bt.co.uk>
+ Date: Tue, 14 Jan 97 12:47:40 GMT
+ Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+
+ Title: "Re: FileCache::cacheout clobbers $_"
+ From: Roderick Schertler
+ Msg-ID: <pz3ewb3189.fsf@eeyore.ibcinc.com>
+ Date: 08 Jan 1997 23:45:58 -0500
+ Files: lib/FileCache.pm lib/cacheout.pl
+
+ Title: "PATCH: AutoSplit"
+ From: Graham Barr
+ Msg-ID: <9603111010.AA29935@tiuk.ti.com>
+ Date: 11 Mar 1996 06:01:58 -0500
+ Files: lib/AutoSplit.pm
+
+ Title: "Re: Uninitialized value in Carp.pm ? "
+ From: Gurusamy Sarathy
+ Msg-ID: <199701141815.NAA07960@aatma.engin.umich.edu>
+ Date: Tue, 14 Jan 1997 13:15:25 -0500
+ Files: lib/Carp.pm
+
+ Title: "Avoid "uninitialized" warnings from POSIX::constant()"
+ From: Chip Salzenberg
+ Files: ext/POSIX/POSIX.pm
+
+ Title: "Eliminate warning from C<use overload>"
+ From: Chip Salzenberg
+ Files: lib/overload.pm
+
+ Title: "low priority patches"
+ From: Paul Marquess
+ Msg-ID: <9701081655.AA27349@claudius.bfsec.bt.co.uk>
+ Date: Wed, 8 Jan 97 16:55:02 GMT
+ Files: lib/Cwd.pm t/comp/redef.t t/lib/db-btree.t
+
+ UTILITIES
+
+ Title: "Re: xsubpp and Tk ==> segfault"
+ From: Ilya Zakharevich
+ Msg-ID: <199701080825.DAA15813@monk.mps.ohio-state.edu>
+ Date: Wed, 8 Jan 1997 03:25:47 -0500 (EST)
+ Files: lib/ExtUtils/xsubpp
+
+ Title: "Re: MakeMaker and 'make uninstall'"
+ From: Andreas Koenig
+ Msg-ID: <199701101243.NAA26400@anna.in-berlin.de>
+ Date: Fri, 10 Jan 1997 13:43:39 +0100
+ Files: lib/ExtUtils/MM_Unix.pm
+
+ Title: "Don't search for pod if path is already valid"
+ From: Wayne Scott <wscott@ichips.intel.com>
+ Msg-ID: <199701082325.PAA04521@pdxlx008.intel.com>
+ Date: Wed, 08 Jan 1997 15:25:19 -0800
+ Files: utils/perldoc.PL
+
+ Title: "Yet another perldoc option"
+ From: Gisle Aas
+ Msg-ID: <199610022200.AAA15334@furubotn.sn.no>
+ Date: Thu, 3 Oct 1996 00:00:35 +0200
+ Files: utils/perldoc.PL
+
+ Title: "Re: perldoc, temp files, async pagers"
+ From: Roderick Schertler
+ Msg-ID: <pzwwtoom8p.fsf@eeyore.ibcinc.com>
+ Date: 07 Jan 1997 22:54:14 -0500
+ Files: utils/perldoc.PL
+
+ DOCUMENTATION
+
+ Title: "Full documentation generation patch"
+ From: Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com>
+ Msg-ID: <15309.853323388@lyon.grenoble.hp.com>
+ Date: Wed, 15 Jan 97 11:16:28 +0100
+ Files: MANIFEST pod/roffitall pod/rofftoc
+
+ Title: "Re: documentation correction (i.e. patch) for perlsyn.pod"
+ From: "M.J.T. Guy"
+ Msg-ID: <E0vilLh-0000M6-00@ursa.cus.cam.ac.uk>
+ Date: Fri, 10 Jan 1997 18:06:37 +0000
+ Files: pod/perlsyn.pod
+
+ Title: "Document use of pos() and /\G/"
+ From: Gurusamy Sarathy
+ Msg-ID: <199701132013.PAA26606@aatma.engin.umich.edu>
+ Date: Mon, 13 Jan 1997 15:13:12 -0500
+ Files: pod/perlfunc.pod pod/perlnews.pod pod/perlop.pod
+ pod/perlre.pod pod/perltoc.pod pod/perltrap.pod
+
+ Title: "Fix example #4 in perlXStut"
+ From: Ilya Zakharevich
+ Msg-ID: <199701050739.CAA11112@monk.mps.ohio-state.edu>
+ Date: Sun, 5 Jan 1997 02:39:45 -0500 (EST)
+ Files: pod/perlxstut.pod
+
+ Title: "Document new closure warnings"
+ From: Chip Salzenberg
+ Files: op.c pod/perldiag.pod
+
+ Title: "Misc. doc patches missing in _20"
+ From: Roderick Schertler
+ Msg-ID: <102.852695733@eeyore.ibcinc.com>
+ Date: Tue, 07 Jan 1997 22:55:33 -0500
+ Files: pod/perlsub.pod pod/perltoc.pod pod/perlvar.pod
+
+
+----------------
+Version 5.003_20
+----------------
+
+The only language change in this release is the recension of support
+for named closures: Now, no subroutine declared "sub foo {}" can be
+a closure. (This is a return to the behavior of 5.003.) In addition,
+there are new warnings triggered by any apparent attempt to use named
+functions as closures.
+
+And, as usual, there are the usual little fixes, documentation
+updates, and expanded tests. This is good stuff. "I love you, man!"
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Rescind named closures"
+ From: Chip Salzenberg
+ Files: Makefile.SH op.c perly.c perly.c.diff perly.y pp_hot.c
+
+ Title: "Fix: empty @_ when calling empty-proto subs without parens"
+ From: Graham Barr
+ Msg-ID: <32CE30F0.7E8425A5@tiuk.ti.com>
+ Date: Sat, 04 Jan 1997 10:29:04 +0000
+ Files: perly.c perly.y
+
+ CORE PORTABILITY
+
+ Title: "Fix $^X on systems that set it to Perl's basename"
+ From: Chip Salzenberg
+ Files: hints/hpux.sh toke.c
+
+ Title: "Configure/perl5/Compartmented Mode Workstation (fwd)"
+ From: Andy Dougherty
+ Msg-ID: <Pine.SOL.3.95.970106131505.1662C-100000@fractal.lafayette.ed
+ Date: Mon, 06 Jan 1997 13:15:38 -0500 (EST)
+ Files: Configure hints/dec_osf.sh
+
+ Title: "Remove obsolete file "dl_os2.xs"."
+ From: Ilya Zakharevich
+ Files: MANIFEST
+
+ OTHER CORE CHANGES
+
+ Title: "Fix C< sub foo (&@); sub bar (&); foo {}, bar {}, bar {} >"
+ From: Chip Salzenberg
+ Files: perly.c perly.c.diff perly.y
+
+ Title: "plug for safe/opcode leaks"
+ From: Doug MacEachern
+ Msg-ID: <199701072220.RAA02117@postman.osf.org>
+ Date: Tue, 07 Jan 1997 17:20:46 -0500
+ Files: op.c
+
+ Title: "Finish OP= warnings: none on ^="
+ From: Chip Salzenberg
+ Files: doop.c pp.c t/op/assignwarn.t
+
+ Title: "Fix Dynaloader failures with DProf"
+ From: Gurusamy Sarathy
+ Msg-ID: <199701061718.MAA26909@aatma.engin.umich.edu>
+ Date: Mon, 06 Jan 1997 12:18:46 -0500
+ Files: pp_hot.c
+
+ BUILD PROCESS
+
+ Title: "Make Configure default to the first domain in /etc/resolv.conf"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Start all helper scripts with $startsh"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Support libperl.so under FreeBSD"
+ From: roberto@keltia.freenix.fr (Ollivier Robert)
+ Msg-ID: <Mutt.19970105224149.roberto@keltia.freenix.fr>
+ Date: Sun, 5 Jan 1997 22:41:49 +0100
+ Files: Configure Makefile.SH
+
+ TESTS
+
+ Title: "New test: comp/proto.t"
+ From: Graham Barr
+ Msg-ID: <32D0C21F.3FB28D51@tiuk.ti.com>
+ Date: Mon, 06 Jan 1997 09:13:03 +0000
+ Files: MANIFEST t/comp/proto.t
+
+ Title: "More magic variable tests"
+ From: Roderick Schertler
+ Msg-ID: <7043.852565192@eeyore.ibcinc.com>
+ Date: Mon, 06 Jan 1997 10:39:52 -0500
+ Files: t/harness t/op/magic.t
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "File::Basename::dirname bugs"
+ From: Robin Barker <rmb@cise.npl.co.uk>
+ Msg-ID: <12393.9701071719@tempest.cise.npl.co.uk>
+ Date: Tue, 7 Jan 97 17:19:59 GMT
+ Files: lib/File/Basename.pm t/lib/basename.t
+
+ Title: "sigaction() problems"
+ From: Roderick Schertler
+ Msg-ID: <12808.852583324@eeyore.ibcinc.com>
+ Date: Mon, 06 Jan 1997 15:42:04 -0500
+ Files: ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod
+
+ Title: "Fix importation of FileHandle methods; fix POSIX docs"
+ From: Chip Salzenberg
+ Files: ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod lib/FileHandle.pm
+
+ Title: "Patch: make hints files warn about db-recno failures"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03010d00aef53ac4d18a@[194.51.248.68]>
+ Date: Sun, 5 Jan 1997 12:34:25 +0100
+ Files: MANIFEST hints/aux.sh hints/broken-db.msg hints/freebsd.sh
+
+ UTILITIES
+
+ Title: "pod2html.PL patch (for 5.003-19)"
+ From: Fabien TASSIN <tassin@eerie.fr>
+ Msg-ID: <199701052347.AAA21297@solar5>
+ Date: Mon, 6 Jan 1997 00:47:01 +0100
+ Files: pod/pod2html.PL
+
+ DOCUMENTATION
+
+ Title: "tiny doc patches"
+ From: Roderick Schertler
+ Msg-ID: <23338.852394333@eeyore.ibcinc.com>
+ Date: Sat, 04 Jan 1997 11:12:13 -0500
+ Files: pod/perlapio.pod pod/perlnews.pod pod/perltoc.pod
+
+ Title: "doc patch for defined on perlfunc.pod"
+ From: Roderick Schertler
+ Msg-ID: <pz91686ek1.fsf@eeyore.ibcinc.com>
+ Date: 04 Jan 1997 21:28:30 -0500
+ Files: pod/perlfunc.pod
+
+ Title: "doc patch: perldsc"
+ From: Roderick Schertler
+ Msg-ID: <pzafqo6eo9.fsf@eeyore.ibcinc.com>
+ Date: 04 Jan 1997 21:25:58 -0500
+ Files: pod/perldsc.pod pod/perltoc.pod
+
+ Title: "Re: constant function inlining"
+ From: Roderick Schertler
+ Msg-ID: <pzk9pp1b95.fsf@eeyore.ibcinc.com>
+ Date: 07 Jan 1997 15:27:50 -0500
+ Files: pod/perldiag.pod pod/perlsub.pod
+
+ Title: "scalar caller doc fix"
+ From: Roderick Schertler
+ Msg-ID: <18245.852608060@eeyore.ibcinc.com>
+ Date: Mon, 06 Jan 1997 22:34:20 -0500
+ Files: pod/perlfunc.pod
+
+ Title: "perlpod.pod possible patches"
+ From: lvirden@cas.org (Larry W. Virden, x2487)
+ Msg-ID: <9701070756.AA1185@cas.org>
+ Date: Tue, 7 Jan 1997 07:56:30 -0500
+ Files: pod/perlpod.pod
+
+ Title: "Misc perlfunc updates"
+ From: Tom Christiansen
+ Files: pod/perlfunc.pod pod/perltoc.pod
+
+
+----------------
+Version 5.003_19
+----------------
+
+Lots of internal cleanup in this patch, especially plugged memory
+leaks when embedded Perl interpreters shut down and restart. The
+method cache is now invisible to user code. And there is a new test
+directory, "t/pragma".
+
+IMHO, this is Beta quality code.
+
+Here's a list of the more significant changes...
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Make method cache invisible to user code"
+ From: Chip Salzenberg
+ Files: dump.c gv.c gv.h hv.c op.c perl.c pp_hot.c pp_sys.c sv.c
+ toke.c
+
+ Title: "Never parse "{m,s,y,tr,q{,q,w,x}}:{,:}" as package or label"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ CORE PORTABILITY
+
+ Title: "Fix $^X under HP-UX"
+ From: Chip Salzenberg
+ Files: hints/hpux.sh toke.c
+
+ Title: "New hints/hpux.sh"
+ From: Jeff Okamoto
+ Msg-ID: <199612312309.AA283393772@hpcc123.corp.hp.com>
+ Date: Tue, 31 Dec 1996 15:09:32 -0800
+ Files: hints/hpux.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Fix segv when calling named closures"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Finish rationalizing "undef value" warnings"
+ From: Chip Salzenberg
+ Files: doop.c pp.c sv.c t/op/assignwarn.t
+
+ Title: "Arrange for all "_<file" entries to be in %main::"
+ From: Chip Salzenberg
+ Files: gv.c lib/perl5db.pl
+
+ Title: "Introduce CVf_NODEBUG flag"
+ From: Gurusamy Sarathy
+ Msg-ID: <199701012042.PAA25994@aatma.engin.umich.edu>
+ Date: Wed, 01 Jan 1997 15:42:05 -0500
+ Files: cv.h pp_hot.c
+
+ Title: "Reword 'may be "0"' warning per Larry; fix its line number"
+ From: Chip Salzenberg
+ Files: op.c pod/perldiag.pod
+
+ Title: "5.003_18: perl_{con,des}truct fixes"
+ From: Doug MacEachern
+ Msg-ID: <199701032042.PAA06766@postman.osf.org>
+ Date: Fri, 03 Jan 1997 15:42:04 -0500
+ Files: perl.c perl.h pod/perlembed.pod pod/perltoc.pod t/op/sysio.t
+
+ Title: "Fix lost value from READLINE after TIEHANDLE"
+ From: Gurusamy Sarathy
+ Files: pp_hot.c sv.h
+
+ Title: "Free memory of large lexical variables when leaving scope"
+ From: Chip Salzenberg
+ Files: scope.c
+
+ TESTS
+
+ Title: "Create t/pragma directory; populate with new and old"
+ From: Paul Marquess
+ Files: MANIFEST Makefile.SH t/TEST t/comp/use.t t/lib/locale.t
+ t/op/overload.t t/op/use.t t/pragma/locale.t t/pragma/overload.t
+ t/pragma/strict-refs t/pragma/strict-subs t/pragma/strict-vars
+ t/pragma/strict.t t/pragma/subs.t t/pragma/warn-global
+ t/pragma/warning.t
+
+ Title: "New tests: comp/colon.t and op/assignwarn.t"
+ From: Robin Barker <rmb@cise.npl.co.uk>
+ Files: MANIFEST t/comp/colon.t t/op/assignwarn.t
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Make libs clean under '-w'"
+ From: Jarkko Hietaniemi
+ Files: lib/AutoSplit.pm lib/Devel/SelfStubber.pm lib/Env.pm
+ lib/Math/Complex.pm lib/Pod/Functions.pm lib/Search/Dict.pm
+ lib/SelfLoader.pm lib/Term/Complete.pm lib/chat2.pl
+ lib/complete.pl lib/diagnostics.pm lib/ftp.pl lib/termcap.pl
+ lib/validate.pl
+
+ DOCUMENTATION
+
+ Title: "Perlguts, version 28"
+ From: Jeff Okamoto
+ Msg-ID: <199701032110.AA102535846@hpcc123.corp.hp.com>
+ Date: Fri, 3 Jan 1997 13:10:46 -0800
+ Files: pod/perlguts.pod
+
+ Title: "Re: perldelta, take 3"
+ From: Tim Bunce
+ Msg-ID: <9701031748.AA15335@toad.ig.co.uk>
+ Date: Fri, 3 Jan 1997 17:48:46 +0000
+ Files: pod/perlnews.pod
+
+ Title: "Miscellaneous pod patches"
+ From: Ralf S. Engelschall <rse@engelschall.com>
+ Files: pod/Makefile pod/perldebug.pod pod/perlfunc.pod
+ pod/perlguts.pod
+
+ Title: "expanded flock() docs"
+ From: Roderick Schertler
+ Msg-ID: <4481.852337871@eeyore.ibcinc.com>
+ Date: Fri, 03 Jan 1997 19:31:11 -0500
+ Files: pod/perlfunc.pod
+
+ Title: "Use Text::Wrap in buildtoc; run buildtoc"
+ From: Ulrich Pfeifer
+ Files: pod/buildtoc pod/perltoc.pod
+
+ Title: "Remove obsolete perlovl.pod"
+ From: Chip Salzenberg
+ Files: MANIFEST plan9/mkfile pod/perlovl.pod vms/Makefile
+ vms/descrip.mms
+
+
+----------------
+Version 5.003_18
+----------------
+
+Yet further down the road to 5.004....
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Inherited overloading"
+ From: Ilya Zakharevich
+ Msg-ID: <199612291312.IAA02134@monk.mps.ohio-state.edu>
+ Date: Sun, 29 Dec 1996 08:12:54 -0500 (EST)
+ Files: gv.c lib/overload.pm perl.h sv.c sv.h t/op/overload.t
+
+ Title: "Hide lexicals from C<use>d or C<require>d module (!)"
+ From: Chip Salzenberg
+ Files: pp_ctl.c
+
+ Title: "Closures at file scope must be anonymous"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Warn on '{if,while} ($x = X)' where X is glob, readdir, or <FH>"
+ From: Chip Salzenberg
+ Files: op.c pod/perldiag.pod
+
+ Title: "Warn on 'undef $x; $x OP 1' where OP is *=, /=, %=, or **="
+ From: Chip Salzenberg
+ Files: pp.c
+
+ CORE PORTABILITY
+
+ Title: "Ultrix setlocale() workaround"
+ From: Chip Salzenberg
+ Files: hints/ultrix_4.sh util.c
+
+ OTHER CORE CHANGES
+
+ Title: "Get rid of 'Leaked scalars'"
+ From: Chip Salzenberg
+ Files: cop.h gv.c op.c
+
+ Title: "Don't forget $c in C<(($a,$b,$c)=(1,2))=(3,4,5)>"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Fix core dump on perl_construct()/perl_destruct() loop"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ Title: "Add missing syms to global.sym; update magic doc"
+ From: Chip Salzenberg
+ Files: global.sym pod/perlguts.pod
+
+ TESTS
+
+ Title: "Expanded locale.t and misc.t"
+ From: Jarkko Hietaniemi
+ Files: t/lib/locale.t t/lib/misc.t
+
+ Title: "Expanded my.t"
+ From: Chip Salzenberg
+ Files: t/lib/my.t
+
+ Title: "test harness for C<use x.xxxx>"
+ From: Graham Barr
+ Msg-ID: <32C76882.3F3C7999@tiuk.ti.com>
+ Date: Mon, 30 Dec 1996 07:00:18 +0000
+ Files: MANIFEST t/op/use.t
+
+ Title: "More tests"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95.961229170736.15213M-100000@solaris.teleport.co
+ Date: Sun, 29 Dec 1996 17:46:21 -0800 (PST)
+ Files: t/op/each.t t/op/oct.t t/op/quotemeta.t t/op/rand.t
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Improving Config.pm"
+ From: Tom Phoenix
+ Msg-ID: <Pine.GSO.3.95.961230091244.13467L-100000@solaris.teleport.co
+ Date: Mon, 30 Dec 1996 09:24:16 -0800 (PST)
+ Files: configpm
+
+ Title: "File::Copy under OS/2"
+ From: Ilya Zakharevich
+ Msg-ID: <199612280347.WAA00293@monk.mps.ohio-state.edu>
+ Date: Fri, 27 Dec 1996 22:47:24 -0500 (EST)
+ Files: lib/File/Copy.pm t/lib/filecopy.t
+
+ DOCUMENTATION
+
+ Title: "Updates to perllocale.pod"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Files: pod/perllocale.pod
+
+ Title: "Locale-related pod patches, take 2"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03007800aeea9e488b36@[194.51.248.77]>
+ Date: Sat, 28 Dec 1996 10:56:41 +0100
+ Files: pod/perl.pod pod/perlform.pod pod/perlfunc.pod pod/perlop.pod
+ pod/perlre.pod pod/perlsec.pod
+
+ Title: "Re: perldiag.pod entry for "Scalar value @%s{%s} ...""
+ From: Roderick Schertler
+ Msg-ID: <2043.852051019@eeyore.ibcinc.com>
+ Date: Tue, 31 Dec 1996 11:50:19 -0500
+ Files: pod/perldiag.pod
+
+
+----------------
+Version 5.003_17
+----------------
+
+The rate of patches is slowing down.... I see 5.004 at the end of the
+tunnel! (Hey, what's that whistle?)
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Support named closures"
+ From: Chip Salzenberg
+ Files: cv.h op.c perl.c pp.c pp_ctl.c pp_hot.c
+
+ CORE PORTABILITY
+
+ Title: "perl5.003_15 and Interactive Unix"
+ From: win@in.rhein-main.de (Winfried Koenig)
+ Msg-ID: <m0vd254-0004oKC@incom.rhein-main.de>
+ Date: Thu, 26 Dec 1996 00:45:45 +0200 (EET)
+ Files: hints/isc.sh pp_sys.c
+
+ Title: "Suggest "usemymalloc='n'" for FreeBSD 2.*"
+ From: rse@engelschall.com (Ralf S. Engelschall)
+ Files: hints/freebsd.sh
+
+ Title: "Minor OS/2 fixes"
+ From: Ilya Zakharevich
+ Msg-ID: <199612252105.QAA11890@monk.mps.ohio-state.edu>
+ Date: Wed, 25 Dec 1996 16:05:42 -0500 (EST)
+ Files: os2/os2ish.h pod/perlxstut.pod
+
+ OTHER CORE CHANGES
+
+ Title: "Fix {,un}tainting of $1 etc. when C<use locale>"
+ From: Chip Salzenberg
+ Files: mg.c sv.c
+
+ Title: "Limit effects of "=pod" to a single file"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ TESTS
+
+ Title: "New tests: op/method.t and op/locale.t"
+ From: Ilya Zakharevich and Jarkko Hietaniemi
+ Files: MANIFEST t/lib/locale.t t/op/method.t
+
+ Title: "Test C< ()=() >"
+ From: Chip Salzenberg
+ Files: t/op/misc.t
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Refresh MakeMaker to 5.39"
+ From: Andreas Koenig
+ Files: lib/ExtUtils/Install.pm lib/ExtUtils/Liblist.pm
+ lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MakeMaker.pm
+ lib/ExtUtils/Mksymlists.pm
+
+ Title: "Newer debugger"
+ From: Ilya Zakharevich
+ Msg-ID: <199612261954.OAA12999@monk.mps.ohio-state.edu>
+ Date: Thu, 26 Dec 1996 14:54:34 -0500 (EST)
+ Files: lib/perl5db.pl
+
+ DOCUMENTATION
+
+ Title: "Perlguts, version 27"
+ From: Jeff Okamoto
+ Msg-ID: <199612250144.AA059528263@hpcc123.corp.hp.com>
+ Date: Tue, 24 Dec 1996 17:44:23 -0800
+ Files: pod/perlguts.pod
+
+ Title: "perlpod.pod patch for _16"
+ From: Kenneth Albanowski
+ Msg-ID: <Pine.LNX.3.93.961224225906.337B-100000@kjahds.com>
+ Date: Tue, 24 Dec 1996 23:00:10 -0500 (EST)
+ Files: pod/perlpod.pod
+
+ Title: "tiny perllocale.pod diff for _16"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199612261306.PAA21161@alpha.hut.fi>
+ Date: Thu, 26 Dec 1996 15:06:04 +0200 (EET)
+ Files: pod/perllocale.pod
+
+
+----------------
+Version 5.003_16
+----------------
+
+This patch is all bug fixes, library updates, and documentation
+updates. We'll get to 5.004 RSN, I promise. :-)
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Fix closures that are not in subroutines"
+ From: Chip Salzenberg
+ Files: op.c
+
+ CORE PORTABILITY
+
+ Title: "_13: patches for unicos/unicosmk"
+ From: Dean Roehrich
+ Msg-ID: <199612202038.OAA22805@poplar.cray.com>
+ Date: Fri, 20 Dec 1996 14:38:50 -0600
+ Files: Configure MANIFEST hints/unicos.sh hints/unicosmk.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Fix 'foreach(@ARGV) { while (<>) { push @p,$_ } }'"
+ From: Chip Salzenberg
+ Files: cop.h pp_hot.c scope.c
+
+ Title: "Eliminate warnings from C< undef $x; $x OP= "foo" >"
+ From: Chip Salzenberg
+ Files: doop.c pp.c pp.h pp_hot.c
+
+ Title: "Try again to improve method caching"
+ From: Ilya Zakharevich
+ Msg-ID: <199612240113.UAA09487@monk.mps.ohio-state.edu>
+ Date: Mon, 23 Dec 1996 20:13:56 -0500 (EST)
+ Files: gv.c sv.c
+
+ Title: "Be more careful about 'o' magic memory management"
+ From: Chip Salzenberg
+ Files: mg.c sv.c
+
+ Title: "Fix bad pointer refs when localized object loses magic"
+ From: Chip Salzenberg
+ Files: scope.c
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Refresh CPAN to 1.09"
+ From: Andreas Koenig
+ Files: lib/CPAN.pm
+
+ Title: "Refresh Net::Ping to 2.02"
+ From: Russell Mosemann <mose@ccsn.edu>
+ Files: lib/Net/Ping.pm
+
+ Title: "Refresh IO to 1.14"
+ From: Graham Barr
+ Files: MANIFEST ext/IO/IO.xs 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_dup.t t/lib/io_pipe.t
+ t/lib/io_sel.t t/lib/io_sock.t t/lib/io_tell.t
+ t/lib/io_udp.t t/lib/io_xs.t
+
+ BUILD PROCESS AND UTILITIES
+
+ Title: "Don't recurse into subdirs twice on 'make realclean'"
+ From: Chip Salzenberg
+ Files: Makefile.SH
+
+ Title: "Use root EXTERN.h when compiling x2p/malloc.c."
+ From: Paul Marquess
+ Files: x2p/Makefile.SH
+
+ Title: "Fix compilation errors when malloc.c used for x2p"
+ From: Robin Barker <rmb@cise.npl.co.uk>
+ Files: malloc.c
+
+ DOCUMENTATION
+
+ Title: "Edit INSTALL to describe new binary compat setup"
+ From: Chip Salzenberg
+ Files: INSTALL
+
+ Title: "Update to perllocale.pod"
+ From: Jarkko Hietaniemi
+ Files: pod/perllocale.pod
+
+
+----------------
+Version 5.003_15
+----------------
+
+As soon as I posted 5.003_14, I found a fatal error in it. :-(
+
+This release is strictly a bug fix -- it removes some function caching
+changes that were supposed to be improvements, but weren't.
+
+
+----------------
+Version 5.003_14
+----------------
+
+We seem to have achieved "release candidate" status.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Eliminate support for {if,unless,while,until} BLOCK BLOCK"
+ From: Chip Salzenberg
+ Files: perly.c perly.c.diff perly.y toke.c
+
+ Title: "Taint $x after $x =~ s/pat/xyz/ if pat or xyz is tainted by locale"
+ From: Chip Salzenberg
+ Files: cop.h mg.c pp_ctl.c pp_hot.c
+
+ Title: "Complete support for modifying undefined array members in foreach"
+ From: Chip Salzenberg
+ Files: global.sym mg.c perl.h pp.c pp_hot.c proto.h sv.c
+
+ OTHER CORE CHANGES
+
+ Title: "patch for regex bug: (x|x){n}"
+ From: Gurusamy Sarathy
+ Msg-ID: <199612210259.VAA10170@aatma.engin.umich.edu>
+ Date: Fri, 20 Dec 1996 21:59:22 -0500
+ Files: regexec.c
+
+ Title: "Bug in debugger with import manipulations"
+ From: Ilya Zakharevich
+ Msg-ID: <199612231037.FAA08617@monk.mps.ohio-state.edu>
+ Date: Mon, 23 Dec 1996 05:37:48 -0500 (EST)
+ Files: pp_hot.c
+
+ Title: "Import and dynamic methods"
+ From: Ilya Zakharevich
+ Msg-ID: <199612230645.BAA08378@monk.mps.ohio-state.edu>
+ Date: Mon, 23 Dec 1996 01:45:37 -0500 (EST)
+ Files: gv.c hv.c sv.c
+
+ Title: "malloc.c patch"
+ From: Ilya Zakharevich
+ Msg-ID: <199612220748.CAA07164@monk.mps.ohio-state.edu>
+ Date: Sun, 22 Dec 1996 02:48:58 -0500 (EST)
+ Files: malloc.c
+
+ Title: "sv_gets patch"
+ From: Ilya Zakharevich
+ Msg-ID: <199612220824.DAA07235@monk.mps.ohio-state.edu>
+ Date: Sun, 22 Dec 1996 03:24:04 -0500 (EST)
+ Files: pp_hot.c
+
+ Title: "pos $str patch"
+ From: Ilya Zakharevich
+ Msg-ID: <199612220831.DAA07247@monk.mps.ohio-state.edu>
+ Date: Sun, 22 Dec 1996 03:31:21 -0500 (EST)
+ Files: mg.c pp_hot.c t/op/pat.t
+
+ Title: "Prevent warnings when STDCHAR is unsigned"
+ From: Chip Salzenberg
+ Files: perlio.c perlio.h
+
+ PORTABILITY
+
+ Title: "Fix bugs in bincompat3 usage"
+ From: Chip Salzenberg
+ Files: perl.h perl_exp.SH
+
+ Title: "Support shared libperl on SunOS"
+ From: Ulrich Pfeifer
+ Files: Makefile.SH
+
+ Title: "Configure on OS/2"
+ From: Ilya Zakharevich
+ Msg-ID: <199612202325.SAA05505@monk.mps.ohio-state.edu>
+ Date: Fri, 20 Dec 1996 18:25:30 -0500 (EST)
+ Files: Configure
+
+ Title: "Fixes for Interactive Unix"
+ From: win@in.rhein-main.de (Winfried Koenig)
+ Msg-ID: <m0vbeNO-00003WC@incom.rhein-main.de>
+ Date: Sun, 22 Dec 96 05:14 EET
+ Files: hints/isc.sh op.c pp_sys.c universal.c
+
+ Title: "Use "proto" instead of "_" in sdbm.h"
+ From: Chip Salzenberg
+ Files: ext/SDBM_File/sdbm/sdbm.h
+
+ Title: "VMS patches to 5.003_13"
+ From: Charles Bailey
+ Msg-ID: <01IDBYYFYPIS002ASE@hmivax.humgen.upenn.edu>
+ Date: Mon, 23 Dec 1996 01:26:47 -0500 (EST)
+ Files: deb.c ext/POSIX/POSIX.xs gv.c lib/File/Copy.pm mg.c perl.c
+ perl.h proto.h sv.c t/lib/filecopy.t taint.c toke.c util.c
+ vms/Makefile vms/config.vms vms/descrip.mms
+ vms/gen_shrfls.pl vms/genconfig.pl vms/genopt.com
+ vms/perly_c.vms vms/perly_h.vms vms/test.com vms/vms.c
+ vms/vms_yfix.pl
+
+ UTILITIES, LIBRARY, AND EXTENSIONS
+
+ Title: "Remove libnet"
+ From: Chip Salzenberg
+ Files: MANIFEST pod/perlmod.pod
+
+ Title: "Refresh CPAN module to 1.08"
+ From: Chip Salzenberg
+ Files: lib/CPAN.pm lib/CPAN/FirstTime.pm
+
+ Title: "Refresh ExtUtils::Manifest to version 1.28"
+ From: Andreas Koenig
+ Files: lib/ExtUtils/Manifest.pm
+
+ Title: "Update IO->VERSION() to 1.1201 for CPAN's sake"
+ From: Chip Salzenberg
+ Files: ext/IO/lib/IO/Handle.pm lib/IO/Handle.pm
+
+ Title: "Remodel File::Copy."
+ From: Chip Salzenberg
+ Files: lib/File/Copy.pm
+
+ Title: "dumb bug in User::pwent.pm"
+ From: Tom Christiansen
+ Msg-ID: <199612201145.EAA27860@mox.perl.com>
+ Date: Fri, 20 Dec 1996 04:45:37 -0700
+ Files: lib/User/pwent.pm
+
+ DOCUMENTATION
+
+ Title: "Better support for =for"
+ From: Kenneth Albanowski
+ Msg-ID: <Pine.LNX.3.93.961220163747.298T-100000@kjahds.com>
+ Date: Fri, 20 Dec 1996 16:43:35 -0500 (EST)
+ Files: lib/Pod/Text.pm pod/pod2latex.PL pod/pod2man.PL
+
+ Title: "perllocale.pod -- second draft"
+ From: Dominic Dunlop <domo@slipper.ip.lu>
+ Msg-ID: <v03007800aee1923e30a2@[194.51.248.68]>
+ Date: Sat, 21 Dec 1996 15:00:50 +0100
+ Files: pod/perllocale.pod
+
+ Title: "Perlguts, version 26"
+ From: Jeff Okamoto
+ Msg-ID: <199612201943.AA048111018@hpcc123.corp.hp.com>
+ Date: Fri, 20 Dec 1996 11:43:38 -0800
+ Files: pod/perlguts.pod
+
+ Title: "Update pod/Makefile; s/perli18n/perllocale/"
+ From: Chip Salzenberg
+ Files: ext/POSIX/POSIX.pod lib/I18N/Collate.pm pod/Makefile
+ pod/perl.pod pod/perlmod.pod pod/perlnews.pod pod/roffitall
+
+ Title: "obstruct pod2man doc tweaks"
+ From: Roderick Schertler
+ Msg-ID: <3923.851106237@eeyore.ibcinc.com>
+ Date: Fri, 20 Dec 1996 13:23:57 -0500
+ Files: lib/Class/Template.pm lib/Time/tm.pm
+
+
+----------------
+Version 5.003_13
+----------------
+
+The watchword here is "synchronization." There were a couple of
+show-stopper bugs in 5.003_12, so I'm issuing this patch to bring
+everyone up to a common working base.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Disallow labels named q, qq, qw, qx, s, y, and tr"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Make evals' lexicals visible to nested evals"
+ From: Chip Salzenberg
+ Files: pp_ctl.c
+
+ OTHER CORE CHANGES
+
+ Title: "Fix core dump bug with anoncode"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Allow DESTROY to make refs to dying objects"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ PORTABILITY
+
+ Title: "Add missing backslash in Configure"
+ From: Chip Salzenberg
+ Files: Configure
+
+ UTILITIES, LIBRARY, AND EXTENSIONS
+
+ Title: "Include libnet-1.01 instead of old Net::FTP"
+ From: Graham Barr
+ Files: MANIFEST lib/Net/Cmd.pm lib/Net/Domain.pm
+ lib/Net/DummyInetd.pm lib/Net/FTP.pm lib/Net/NNTP.pm
+ lib/Net/Netrc.pm lib/Net/POP3.pm lib/Net/SMTP.pm
+ lib/Net/SNPP.pm lib/Net/Socket.pm lib/Net/Telnet.pm
+ lib/Net/Time.pm pod/perlmod.pod
+
+ Title: "Use binmode when doing binary FTP"
+ From: Ilya Zakharevich
+ Files: lib/Net/FTP.pm
+
+ Title: "Re: Open3.pm tries to close unopened file handle"
+ From: Roderick Schertler
+ Msg-ID: <pzloavmd9h.fsf@eeyore.ibcinc.com>
+ Date: 18 Dec 1996 22:19:54 -0500
+ Files: MANIFEST lib/IPC/Open2.pm lib/IPC/Open3.pm lib/open2.pl
+ lib/open3.pl pod/perldiag.pod pod/perlfunc.pod t/lib/open2.t
+ t/lib/open3.t
+
+ Title: "Long-standing problem in Socket module"
+ From: Spider Boardman
+ Msg-ID: <199612190418.XAA07291@Orb.Nashua.NH.US>
+ Date: Wed, 18 Dec 1996 23:18:14 -0500
+ Files: Configure Porting/Glossary config_H config_h.SH
+ ext/Socket/Socket.pm ext/Socket/Socket.xs
+
+ Title: "flock() constants"
+ From: Roderick Schertler
+ Msg-ID: <26669.850977437@eeyore.ibcinc.com>
+ Date: Thu, 19 Dec 1996 01:37:17 -0500
+ Files: ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs pod/perlfunc.pod
+
+ Title: "Re: find2perl . -xdev BROKEN still"
+ From: Roderick Schertler
+ Msg-ID: <pzvi9yig3h.fsf@eeyore.ibcinc.com>
+ Date: 19 Dec 1996 12:44:34 -0500
+ Files: lib/File/Find.pm lib/find.pl lib/finddepth.pl
+
+ DOCUMENTATION
+
+ Title: "small doc tweaks for _12"
+ From: Roderick Schertler
+ Msg-ID: <1826.851011557@eeyore.ibcinc.com>
+ Date: Thu, 19 Dec 1996 11:05:57 -0500
+ Files: lib/UNIVERSAL.pm pod/perldiag.pod pod/perltie.pod
+
+ Title: "Re: missing E<> POD directive in perlpod.pod"
+ From: Roderick Schertler
+ Msg-ID: <pzwwueimak.fsf@eeyore.ibcinc.com>
+ Date: 19 Dec 1996 10:30:43 -0500
+ Files: pod/perlpod.pod pod/pod2html.PL
+
+
+----------------
+Version 5.003_12
+----------------
+
+This patch is huge. A multitude of bug fixes, new modules (especially
+CPAN and Net::FTP), a couple of new Configure variables, updated
+docs... it's a long list. And speaking of lists, here's a list of
+the more significant changes in 5.003_12:
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Support C<delete @hash{@keys}>"
+ From: Chip Salzenberg
+ Files: op.c op.h opcode.pl pod/perldiag.pod pod/perlfunc.pod pp.c
+ t/op/delete.t
+
+ Title: "Autovivify scalars"
+ From: Chip Salzenberg
+ Files: dump.c op.c op.h pp.c pp_hot.c
+
+ Title: "Allow any word, including keyword, as label"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ OTHER CORE CHANGES
+
+ Title: "Allow assignment to empty array values during foreach()"
+ From: Chip Salzenberg
+ Files: cop.h global.sym mg.c op.c perl.h pp_hot.c proto.h sv.c
+
+ Title: "Fix nested closures"
+ From: Chip Salzenberg
+ Files: op.c opcode.pl pp.c pp_ctl.c pp_hot.c
+
+ Title: "Fix core dump on auto-vivification"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Fix core dump on C<open $undef_var, "X">"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "Fix -T/-B on globs and globrefs"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "Fix memory management of $`, $&, and $'"
+ From: Chip Salzenberg
+ Files: pp_hot.c regexec.c
+
+ Title: "Fix paren matching during backtracking"
+ From: Chip Salzenberg
+ Files: regexec.c
+
+ Title: "Fix memory leak and std{in,out,err} death in perl_{con,de}str
+ From: Chip Salzenberg
+ Files: miniperlmain.c perl.c perl.h sv.c
+
+ Title: "Discard garbage bytes at end of prototype()"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Fix local($pack::{foo})"
+ From: Chip Salzenberg
+ Files: global.sym pp.c pp_hot.c proto.h scope.c
+
+ Title: "Fix for AmigaOS - inplace operation"
+ From: Norbert Pueschel
+ Msg-ID: <77724601@Armageddon.meb.uni-bonn.de>
+ Date: Sun, 08 Dec 1996 15:33:00 +0100
+ Files: doio.c
+
+ Title: "Disable warn, die, and parse hooks _before_ global destruction
+ From: Chip Salzenberg
+ Files: perl.c
+
+ Title: "Re: Bug in formline "
+ From: Gurusamy Sarathy
+ Msg-ID: <199612081958.OAA26025@aatma.engin.umich.edu>
+ Date: Sun, 08 Dec 1996 14:58:32 -0500
+ Files: pp_ctl.c
+
+ Title: "Fix C<@a = ($a,$b,$c,$d) = (1,2)>"
+ From: Chip Salzenberg
+ Files: pp_hot.c
+
+ Title: "Fix %ENV assignment when environment starts out empty"
+ From: Chip Salzenberg
+ Files: hv.c
+
+ Title: "Properly support and document newRV{,_inc,_noinc}"
+ From: Chip Salzenberg
+ Files: global.sym pod/perlguts.pod sv.c sv.h
+
+ Title: "Support SvREADONLY on arrays"
+ From: Chip Salzenberg
+ Files: av.c
+
+ Title: "Allow lvalue pos inside recursive function"
+ From: Chip Salzenberg
+ Files: op.c pp.c pp_ctl.c pp_hot.c
+
+ PORTABILITY
+
+ Title: "Eliminate PerlIO warnings when setting cnt to -1"
+ From: Chip Salzenberg
+ Files: perlio.c
+
+ Title: "Make $privlib contents compatible with 5.003"
+ From: Chip Salzenberg
+ Files: INSTALL ext/Opcode/Safe.pm installperl lib/FileHandle.pm
+ lib/Test/Harness.pm
+
+ Title: "Support $bincompat3 config variable; update metaconfig units"
+ From: Chip Salzenberg
+ Files: Configure MANIFEST compat3.sym config_h.SH embed.pl global.sym
+ old_embed.pl old_global.sym old_perl_exp.SH perl_exp.SH
+
+ Title: "Look for gettimeofday() in Configure"
+ From: John Hughes <john@AtlanTech.COM>
+ Msg-ID: <01BBE77A.F6F37F80@malvinas.AtlanTech.COM>
+ Date: Wed, 11 Dec 1996 15:49:57 +0100
+ Files: Configure config_H config_h.SH pp.c
+
+ Title: "Make $startperl a relative path if people want portable scrip
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Homogenize use of "eval exec" hack"
+ From: Chip Salzenberg
+ Files: Porting/Glossary eg/README eg/nih eg/sysvipc/ipcmsg
+ eg/sysvipc/ipcsem eg/sysvipc/ipcshm lib/diagnostics.pm
+ makeaperl.SH pod/checkpods.PL pod/perlrun.pod
+ pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL
+ pod/pod2text.PL utils/c2ph.PL utils/h2ph.PL utils/h2xs.PL
+ utils/perlbug.PL utils/perldoc.PL utils/pl2pm.PL x2p/a2py.c
+ x2p/find2perl.PL x2p/s2p.PL
+
+ Title: "LynxOS support"
+ From: seibert@Lynx.COM (Greg Seibert)
+ Msg-ID: <m0vYEsY-0000IZC@kzinti.lynx.com>
+ Date: Thu, 12 Dec 1996 09:25:00 PST
+ Files: Configure MANIFEST hints/lynxos.sh t/op/stat.t
+
+ Title: "In Linux hints, set suidsafe=no and dosuid=yes"
+ From: Chip Salzenberg
+ Files: hints/linux.sh
+
+ Title: "5.003_11 on UnixWare 2.1.1 - Only one small UnixWare buglet"
+ From: aburlison@cix.compulink.co.uk (Alan Burlison)
+ Msg-ID: <memo.453720@cix.compulink.co.uk>
+ Date: Wed, 11 Dec 96 18:34 GMT0
+ Files: hints/svr4.sh
+
+ Title: "Re: db-recno.t failures with _11 on Freebsd 2.1-stable"
+ From: Roderick Schertler
+ Msg-ID: <pzohg0r5tr.fsf@eeyore.ibcinc.com>
+ Date: 11 Dec 1996 18:58:56 -0500
+ Files: INSTALL hints/freebsd.sh
+
+ Title: "OS/2 updates from Ilya"
+ From: Ilya Zakharevich
+ Files: README.os2 os2/Changes os2/Makefile.SHs os2/os2.c os2/os2ish.h
+
+ Title: "VMS patches to 5.003_11"
+ From: Charles Bailey
+ Msg-ID: <01ICTR32LCZG001A1D@hmivax.humgen.upenn.edu>
+ Date: Mon, 09 Dec 1996 23:16:10 -0500 (EST)
+ Files: MANIFEST regexec.c t/lib/filehand.t util.c vms/*
+
+ TESTING
+
+ Title: "recurse recurse recurse ..."
+ From: Jarkko Hietaniemi
+ Msg-ID: <199612092144.XAA29025@alpha.hut.fi>
+ Date: Mon, 9 Dec 1996 23:44:27 +0200 (EET)
+ Files: MANIFEST t/op/recurse.t
+
+ UTILITIES, LIBRARY, AND EXTENSIONS
+
+ Title: "Add CPAN and Net::FTP"
+ From: Chip Salzenberg
+ Files: MANIFEST lib/CPAN.pm lib/CPAN/FirstTime.pm lib/CPAN/Nox.pm
+ lib/Net/FTP.pm lib/Net/Netrc.pm lib/Net/Socket.pm
+ pod/perlmod.pod
+
+ Title: "Please update Text::Wrap and Text::Tabs"
+ From: David Muir Sharnoff <muir@idiom.com>
+ Msg-ID: <199612180659.WAA24957@idiom.com>
+ Date: Tue, 17 Dec 1996 22:59:59 -0800 (PST)
+ Files: lib/Text/Tabs.pm lib/Text/Wrap.pm
+
+ Title: "Add File::Compare"
+ From: Nick Ing-Simmons
+ Msg-ID: <199612161844.SAA02152@pluto>
+ Date: Mon, 16 Dec 1996 18:44:59 GMT
+ Files: MANIFEST lib/File/Compare.pm pod/perlmod.pod
+
+ Title: "Add Tie::RefHash"
+ From: Gurusamy Sarathy
+ Msg-ID: <199612152358.SAA28665@aatma.engin.umich.edu>
+ Date: Sun, 15 Dec 1996 18:58:08 -0500
+ Files: MANIFEST lib/Tie/RefHash.pm pod/perlmod.pod
+
+ Title: "Put "splain" in utils."
+ From: Chip Salzenberg
+ Files: Makefile.SH installperl utils/Makefile utils/splain.PL
+
+ Title: "Some h2ph fixes"
+ From: Jeff Okamoto
+ Msg-ID: <199612131934.AA289845652@hpcc123.corp.hp.com>
+ Date: Fri, 13 Dec 1996 11:34:12 -0800
+ Files: utils/h2ph.PL
+
+ Title: "xsubpp patch to add #line"
+ From: Nick Ing-Simmons
+ Msg-ID: <199612162153.VAA03590@ni-s.u-net.com>
+ Date: Mon, 16 Dec 1996 21:53:56 GMT
+ Files: lib/ExtUtils/xsubpp
+
+ Title: "Re: Proposed addition to File::Copy: move"
+ From: Charles Bailey
+ Msg-ID: <01ICZBN0LRC8001A1D@hmivax.humgen.upenn.edu>
+ Date: Sat, 14 Dec 1996 00:27:29 -0500 (EST)
+ Files: lib/File/Copy.pm t/lib/filecopy.t
+
+ Title: "DB_File 1.09 patch"
+ From: Paul Marquess
+ Msg-ID: <9612181037.AA10123@claudius.bfsec.bt.co.uk>
+ Date: Wed, 18 Dec 96 10:37:58 GMT
+ Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+
+ Title: "Debugger update"
+ From: Ilya Zakharevich
+ Msg-ID: <199612111038.FAA24363@monk.mps.ohio-state.edu>
+ Date: Wed, 11 Dec 1996 05:38:28 -0500 (EST)
+ Files: lib/perl5db.pl
+
+ DOCUMENTATION
+
+ Title: "Update pods: perldelta -> perlnews, perli18n -> perllocale"
+ From: Tom Christiansen and Dominic Dunlop
+ Files: MANIFEST pod/perl.pod pod/perldelta.pod pod/perli18n.pod
+ pod/perlnews.pod
+
+ Title: "perltoot.pod"
+ From: Tom Christiansen
+ Msg-ID: <199612091444.HAA09947@toy.perl.com>
+ Date: Mon, 09 Dec 1996 07:44:10 -0700
+ Files: MANIFEST pod/perltoot.pod
+
+ Title: "Perlguts, version 25"
+ From: Jeff Okamoto
+ Msg-ID: <199612061940.AA055461228@hpcc123.corp.hp.com>
+ Date: Fri, 6 Dec 96 11:40:27 PST
+ Files: pod/perlguts.pod
+
+ Title: "pod/perlipc.pod patch"
+ From: d-lewart@uiuc.edu (Daniel S. Lewart)
+ Msg-ID: <199612090910.CAA20906@mox.perl.com>
+ Date: Mon, 9 Dec 96 3:10:02 CST
+ Files: pod/perlipc.pod
+
+ Title: "pod patches for English errors"
+ From: Steve Kelem <steve.kelem@xilinx.com>
+ Msg-ID: <24616.850167191@castor>
+ Date: Mon, 09 Dec 1996 13:33:11 -0800
+ Files: pod/*.pod
+
+ Title: "Misc doc updates"
+ From: Tom Christiansen
+ Msg-ID: <199612150156.SAA12506@mox.perl.com>
+ Date: Sat, 14 Dec 1996 18:56:33 -0700
+ Files: pod/*
+
+----------------
+Version 5.003_11
+----------------
+
+This patch is (still) closing in on 5.004. Nothing dramatic, lots of
+value.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Fix precedence problems with subs as uniops or listops"
+ From: Chip Salzenberg
+ Files: perly.c perly.c.diff perly.h perly.y
+
+ Title: "Don't reset $. on open()"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "Support *glob{IO} (eventually deprecate *glob{FILEHANDLE})"
+ From: Chip Salzenberg
+ Files: pod/perlref.pod pp_hot.c sv.c
+
+ Title: "Don't let expression context force return context"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Properly convert "1E2" et al to IV/UV"
+ From: Chip Salzenberg
+ Files: doio.c sv.c
+
+ Title: "Fix modulo operator in UV realm"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Fix stat(_) after stat(HANDLE)"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "Fix: s/// and "$x =~ $y" under 'use locale'"
+ From: Chip Salzenberg
+ Files: op.c toke.c
+
+ OTHER CORE CHANGES
+
+ Title: "Eliminate spurious warning when splicing undefs"
+ From: Chip Salzenberg
+ Files: pp.c sv.h
+
+ Title: "Eliminate spurious warning from "x=" operator"
+ From: Chip Salzenberg
+ Files: op.c
+
+ Title: "Fix line numbers near control structures"
+ From: Chip Salzenberg
+ Files: op.c perly.c perly.c.diff perly.y proto.h
+
+ Title: "Don't let scalar unpack() underflow stack"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Fix core dump from precedence bug in "@foo" warning"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Move die() to utils.c; add varargs hack to croak()"
+ From: Chip Salzenberg
+ Files: pp_ctl.c util.c
+
+ Title: "Avoid memcmp() for magnitude test if it thinks char is signed"
+ From: Chip Salzenberg
+ Files: Configure config_H config_h.SH doop.c
+ ext/SDBM_File/sdbm/pair.c ext/SDBM_File/sdbm/sdbm.h handy.h
+ hv.c perl.h pp_hot.c proto.h regexec.c sv.c toke.c util.c
+
+ Title: "Less malloc in magic"
+ From: Chip Salzenberg
+ Files: mg.c
+
+ Title: "Re: 5.003_09: PADTMP fix"
+ From: Ilya Zakharevich
+ Msg-ID: <199611281150.GAA06884@monk.mps.ohio-state.edu>
+ Date: Thu, 28 Nov 1996 06:50:58 -0500 (EST)
+ Files: pod/perlguts.pod
+
+ Title: "Fully paramaterize locales; disable all if NO_LOCALE"
+ From: Chip Salzenberg
+ Files: ext/POSIX/POSIX.xs op.c perl.h pp.c pp_sys.c sv.c util.c
+
+ PORTABILITY AND TESTING
+
+ Title: "Bitwise op fix for Alpha"
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "hints/dgux.sh update"
+ From: Roderick Schertler
+ Msg-ID: <24178.849309616@eeyore.ibcinc.com>
+ Date: Fri, 29 Nov 1996 18:20:16 -0500
+ Files: hints/dgux.sh
+
+ Title: "BUG in hints/hpux.sh"
+ From: Jeff McDougal <jmcdo@cris.com>
+ Msg-ID: <32A42C11.7FA2@cris.com>
+ Date: Tue, 03 Dec 1996 08:33:05 -0500
+ Files: hints/hpux.sh
+
+ Title: "VMS patches for 5.003_10"
+ From: Charles Bailey
+ Msg-ID: <01ICMALO8NMS001A1D@hmivax.humgen.upenn.edu>
+ Date: Wed, 04 Dec 1996 16:40:12 -0500 (EST)
+ Files: EXTERN.h INTERN.h old_perl_exp.SH perl.c perl.h perl_exp.SH
+ pp.c pp_ctl.c pp_sys.c proto.h sv.c toke.c util.c
+ utils/perldoc.PL vms/config.vms vms/descrip.mms
+ vms/gen_shrfls.pl vms/genconfig.pl vms/vmsish.h
+
+ Title: "_10+ under OS/2"
+ From: Ilya Zakharevich
+ Msg-ID: <199612011107.GAA10805@monk.mps.ohio-state.edu>
+ Date: Sun, 1 Dec 1996 06:07:19 -0500 (EST)
+ Files: malloc.c os2/diff.configure
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "{in,ob}structive pods"
+ From: Tom Christiansen
+ Msg-ID: <199611301652.JAA24201@toy.perl.com>
+ Date: Sat, 30 Nov 1996 09:52:57 -0700
+ Files: MANIFEST lib/Class/Template.pm lib/File/stat.pm
+ lib/Net/hostent.pm lib/Net/netent.pm lib/Net/protoent.pm
+ lib/Net/servent.pm lib/Time/gmtime.pm lib/Time/localtime.pm
+ lib/Time/tm.pm lib/User/grent.pm lib/User/pwent.pm
+
+ Title: "FileHandle that 'ISA' IO::File"
+ From: Nick Ing-Simmons
+ Msg-ID: <199612021718.RAA04416@pluto>
+ Date: Mon, 2 Dec 1996 17:18:02 GMT
+ Files: MANIFEST lib/FileHandle.pm
+
+ Title: "Make IO::File::import use its parameters"
+ From: Chip Salzenberg
+ Files: ext/IO/lib/IO/File.pm
+
+ Title: "10+ debugger patch"
+ From: Ilya Zakharevich
+ Msg-ID: <199612011137.GAA10864@monk.mps.ohio-state.edu>
+ Date: Sun, 1 Dec 1996 06:37:31 -0500 (EST)
+ Files: lib/perl5db.pl perl.c pod/perldebug.pod
+
+ Title: "Don't call CORE::close in file handle DESTROY method"
+ From: Chip Salzenberg
+ Files: ext/IO/lib/IO/Handle.pm
+
+ Title: "Re: Namespace cleanup: Does SDBM need binary compatibility?"
+ From: Hallvard B Furuseth
+ Msg-ID: <199612031445.PAA19056@bombur2.uio.no>
+ Date: Tue, 3 Dec 1996 15:45:27 +0100 (MET)
+ Files: ext/SDBM_File/sdbm/pair.h ext/SDBM_File/sdbm/sdbm.3
+
+ Title: "DB_File 1.07"
+ From: Paul Marquess
+ Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs t/lib/db-btree.t
+ t/lib/db-recno.t
+
+ Title: "DB_File 1.08"
+ From: Paul Marquess
+ Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs
+
+
+----------------
+Version 5.003_10
+----------------
+
+This patch is closing in on 5.004. It contains lots of small and
+valuable changes, but nothing dramatic.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Allow &{sub {...}} without warning"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Make parens optional on [gs]ethost and [gs]et{pw,gr} functions
+ From: John L. Allen <allen@gateway.grumman.com>
+ Files: toke.c
+
+ Title: "Fix syntax error with "$x [0]" and "$x {y}" and "@x {y}""
+ From: Chip Salzenberg
+ Files: toke.c
+
+ OTHER CORE CHANGES
+
+ Title: "Fix regex matching of chars with high bit set"
+ From: Chip Salzenberg
+ Files: regexec.c
+
+ Title: "Hash key memory corruption fix and naming cleanup"
+ From: Chip Salzenberg
+ Files: hv.c hv.h perl.h
+
+ Title: "Undo broken perf. patch (PADTMP stealing)"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ Title: "Make SV unstudied in sv_gets()"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ Title: "Better support for UVs"
+ From: Paul Marquess
+ Files: global.sym old_global.sym perl.h pp.c pp.h proto.h sv.c sv.h
+
+ Title: "Minor locale cleanups"
+ (Accept "POSIX" locale as standard like "C". Reset locale to
+ 'C' when testing strtod() in t/lib/posix.t.)
+ From: Chip Salzenberg
+ Files: t/lib/posix.t util.c
+
+ Title: "Always taint result of sprintf() on float"
+ From: Chip Salzenberg
+ Files: doop.c
+
+ Title: "Fix spurious warning from bitwise string ops"
+ From: Chip Salzenberg
+ Files: doop.c
+
+ Title: "Eliminate warning on {,sys}read(,$newvar,)"
+ From: Chip Salzenberg
+ Files: doop.c pp_sys.c
+
+ Title: "Don't call fcntl(fileno(rsfp)) if !rsfp"
+ From: Chip Salzenberg
+ Files: perl.c
+
+ Title: "Save message when calling __DIE__ hook"
+ From: Chip Salzenberg
+ Files: pp_ctl.c
+
+ Title: "Namespace cleanup"
+ From: Chip Salzenberg
+ Files: global.sym old_global.sym perl.h
+
+ Title: "Modify perl_exp.SH; create old_perl_exp.SH; document old_*"
+ From: Chip Salzenberg
+ Files: Configure INSTALL MANIFEST old_perl_exp.SH perl_exp.SH
+
+ PORTABILITY
+
+ Title: "Reliable signal patch"
+ From: Kenneth Albanowski
+ Msg-ID: <Pine.LNX.3.93.961126053209.294J-100000@kjahds.com>
+ Date: Tue, 26 Nov 1996 05:40:50 -0500 (EST)
+ Files: global.sym mg.c old_global.sym perl.h pp_sys.c proto.h util.c
+
+ Title: "Emulate missing flock() with either fcntl() or lockf()"
+ From: Chip Salzenberg
+ Files: pp_sys.c
+
+ Title: "3_09: minor patches for OS/2"
+ From: Ilya Zakharevich
+ Msg-ID: <199611270830.DAA04985@monk.mps.ohio-state.edu>
+ Date: Wed, 27 Nov 1996 03:30:05 -0500 (EST)
+ Files: doio.c global.sym malloc.c old_global.sym os2/Makefile.SHs
+ os2/OS2/ExtAttr/Makefile.PL os2/OS2/PrfDB/Makefile.PL
+ os2/OS2/Process/Makefile.PL os2/OS2/REXX/Makefile.PL
+ os2/os2.c os2/os2ish.h perl.h
+
+ Title: "Re: 5.003_09 and QNX"
+ From: nort@bottesini.harvard.edu (Norton Allen)
+ Msg-ID: <9611271836.AA14460@bottesini.harvard.edu>
+ Date: Wed, 27 Nov 96 13:36:06 est
+ Files: Configure MANIFEST README.qnx hints/qnx.sh qnx/ar qnx/cpp
+ t/TEST toke.c util.c x2p/proto.h
+
+ Title: "Re: updated patch on the sysread, syswrite for VMS"
+ From: Charles Bailey
+ Msg-ID: <01ICB648K2XG001A1D@hmivax.humgen.upenn.edu>
+ Date: Tue, 26 Nov 1996 17:28:23 -0500 (EST)
+ Files: t/op/sysio.t
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Minor patch to debugger"
+ From: Ilya Zakharevich
+ Msg-ID: <199611290533.AAA08053@monk.mps.ohio-state.edu>
+ Date: Fri, 29 Nov 1996 00:33:49 -0500 (EST)
+ Files: lib/perl5db.pl
+
+ Title: "AutoLoader::AUTOLOAD optimization"
+ From: Nick Ing-Simmons
+ Msg-ID: <199611231954.TAA09921@ni-s.u-net.com>
+ Date: Sat, 23 Nov 1996 19:54:52 GMT
+ Files: lib/AutoLoader.pm
+
+ Title: "Diagnostic cleanup"
+ From: Chip Salzenberg
+ Files: lib/diagnostics.pm pod/perldiag.pod
+
+ DOCUMENTATION
+
+ Title: "Improve documentation for sysread() and syswrite()"
+ From: Chip Salzenberg
+ Files: pod/perlfunc.pod
+
+ Title: "Document how to use $SIG{ALRM} and alarm()"
+ From: Roderick Schertler
+ Msg-ID: <5898.849026569@eeyore.ibcinc.com>
+ Date: Tue, 26 Nov 1996 11:42:49 -0500
+ Files: pod/perlfunc.pod
+
+
+----------------
+Version 5.003_09
+----------------
+
+This patch was a compendium of various fixes and enhancements from
+many people, including some serious improvement in lexical variable
+scoping and locale handling.
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Lexical locales"
+ (make effectiveness of locales depend on C<use locale>)
+ From: Chip Salzenberg
+ Files: too many to list
+
+ Title: "Lexical scoping cleanup"
+ (tighten scoping of lexical variables, somewhat on the
+ new constructs and somewhat on the old)
+ From: Chip Salzenberg
+ Files: many... but mostly perly.y and toke.c
+
+ Title: "Re: memory corruption / security bug in sysread,syswrite + pa
+ From: Jarkko Hietaniemi
+ Msg-ID: <199611251946.VAA30459@alpha.hut.fi>
+ Date: Mon, 25 Nov 1996 21:46:31 +0200 (EET)
+ Files: MANIFEST pod/perldiag.pod pod/perlfunc.pod pp_sys.c
+ t/op/sysio.t
+
+ OTHER CORE CHANGES
+
+ Title: "Configure fix for handling DynaLoader"
+ From: Chip Salzenberg
+ Files: Configure
+
+ Title: "Properly prototype safe{malloc,calloc,realloc,free}."
+ From: Chip Salzenberg
+ Files: proto.h
+
+ Title: "UnixWare 2.1 fix for perl5.003_08 - cope with fp->_cnt < -1,
+ From: John Hughes <john@AtlanTech.COM>
+ Msg-ID: <01BBD6EE.E915C860@malvinas.AtlanTech.COM>
+ Date: Wed, 20 Nov 1996 14:27:06 +0100
+ Files: sv.c
+
+ Title: ""static" call to UNIVERSAL::can"
+ From: Nick Ing-Simmons
+ Msg-ID: <199611211547.PAA15878@pluto>
+ Date: Thu, 21 Nov 1996 15:47:46 GMT
+ Files: universal.c
+
+ Title: "die -> croak"
+ From: Gurusamy Sarathy
+ Msg-ID: <199611212111.QAA17070@aatma.engin.umich.edu>
+ Date: Thu, 21 Nov 1996 16:11:21 -0500
+ Files: pp_ctl.c
+
+ Title: "Patch for embed.pl when !EMBED && !MULTIPLICITY"
+ From: Chip Salzenberg
+ Files: embed.pl
+
+ Title: "Add new symbols to old_global.sym, too."
+ From: Chip Salzenberg
+ Files: global.sym old_global.sym
+
+ Title: "Cleanup of {,un}pack('w')."
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Cleanups from Ilya."
+ From: Chip Salzenberg
+ Files: gv.c malloc.c pod/perlguts.pod pp_ctl.c
+
+ Title: "Fix for unpack('w') on 64-bit systems."
+ From: Chip Salzenberg
+ Files: pp.c
+
+ Title: "Re: LC_NUMERIC support is ready + performance"
+ From: Ilya Zakharevich
+ Msg-ID: <199611260308.WAA02677@monk.mps.ohio-state.edu>
+ Date: Mon, 25 Nov 1996 22:08:27 -0500 (EST)
+ Files: sv.c
+
+ Title: "Hash key sharing improvements from Ilya."
+ From: Chip Salzenberg
+ Files: hv.c hv.h proto.h
+
+ Title: "Mortal stack pre-allocation from Ilya."
+ From: Chip Salzenberg
+ Files: pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c
+
+ PORTABILITY
+
+ Title: "VMS patches post-5.003_08"
+ From: Charles Bailey
+ Msg-ID: <1996Nov22.181631.1603238@hmivax.humgen.upenn.edu>
+ Date: Fri, 22 Nov 1996 18:16:31 -0500 (EST)
+ Files: lib/ExtUtils/MM_Unix.pm lib/ExtUtils/MM_VMS.pm
+ lib/ExtUtils/MakeMaker.pm lib/File/Path.pm mg.c pp_ctl.c
+ utils/h2xs.PL vms/config.vms vms/descrip.mms
+ vms/gen_shrfls.pl vms/genconfig.pl vms/perlvms.pod vms/vms.c
+ vms/vmsish.h
+
+ Title: "5.003_08: OS/2-specific bugs/enhancements"
+ From: Ilya Zakharevich
+ Msg-ID: <199611241147.GAA00490@monk.mps.ohio-state.edu>
+ Date: Sun, 24 Nov 1996 06:47:25 -0500 (EST)
+ Files: README.os2 hints/os2.sh os2/Changes os2/Makefile.SHs
+ os2/OS2/PrfDB/PrfDB.pm os2/os2.c
+
+ Title: "HP patches didn't make it into _08 (fwd)"
+ From: Jeff Okamoto
+ Msg-ID: <199611260215.AA100414526@hpcc123.corp.hp.com>
+ Date: Mon, 25 Nov 96 18:15:26 PST
+ Files: ext/DynaLoader/dl_hpux.xs
+
+ Title: "Another HP "patch" that didn't make it (new hints file)"
+ From: Jeff Okamoto
+ Msg-ID: <199611252116.AA245766577@hpcc123.corp.hp.com>
+ Date: Mon, 25 Nov 1996 13:16:17 -0800
+ Files: hints/hpux.sh
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Elide spurious space in db-hash.t"
+ From: Chip Salzenberg
+ Files: t/lib/db-hash.t
+
+ Title: "Update documentation and warning in I18N::Collate."
+ From: Chip Salzenberg
+ Files: lib/I18N/Collate.pm
+
+ Title: "Fix bitwise op test; clean up a couple of others"
+ From: Chip Salzenberg
+ Files: t/lib/bigintpm.t t/op/bop.t t/op/overload.t
+
+ Title: "minimal timelocal.pl for _09"
+ From: Achim Bohnet <ach@rosat.mpe-garching.mpg.de>
+ Msg-ID: <9611191854.AA19586@o09.rosat.mpe-garching.mpg.de>
+ Date: Tue, 19 Nov 1996 19:54:23 +0100
+ Files: lib/Time/Local.pm
+
+ Title: "Socket test improvement from Ilya."
+ From: Chip Salzenberg
+ Files: t/lib/io_sock.t
+
+ Title: "Re: blib"
+ From: Nick Ing-Simmons
+ Msg-ID: <199611230917.JAA00471@ni-s.u-net.com>
+ Date: Sat, 23 Nov 1996 09:17:40 GMT
+ Files: lib/blib.pm
+
+ DOCUMENTATION
+
+ Title: "perldiag documentation patch."
+ From: Paul Marquess
+ Msg-ID: <9611201607.AA12729@claudius.bfsec.bt.co.uk>
+ Date: Wed, 20 Nov 96 16:07:28 GMT
+ Files: pod/perldiag.pod
+
+ Title: "a missing perldiag entry"
+ From: Gurusamy Sarathy
+ Msg-ID: <199611212024.PAA15758@aatma.engin.umich.edu>
+ Date: Thu, 21 Nov 1996 15:24:02 -0500
+ Files: pod/perldiag.pod
+
+ Title: "perlfunc patch"
+ From: Paul Marquess
+ Msg-ID: <9611201404.AA12477@claudius.bfsec.bt.co.uk>
+ Date: Wed, 20 Nov 96 14:04:08 GMT
+ Files: pod/perlfunc.pod
+
+ Title: "Patch for pod/perlpod.pod"
+ From: "Joseph S. Myers" <jsm28@cam.ac.uk>
+ Msg-ID: <Pine.LNX.3.95.961120235016.6666A-100000@hammer.chu.cam.ac.uk
+ Date: Wed, 20 Nov 1996 23:54:41 +0000 (GMT)
+ Files: pod/perlpod.pod
+
+ Title: "Update locale documentation."
+ From: Chip Salzenberg
+ Files: pod/perli18n.pod
+
+ BUNDLED UTILITIES
+
+ Title: "Fix type mismatches in x2p's safe{alloc,realloc,free}."
+ From: Chip Salzenberg
+ Files: x2p/util.c
+
+
+----------------
+Version 5.003_08
+----------------
+
+This patch was a compendium of various fixes and enhancements from
+many people. Here are some of the more significant changes.
+
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Make C<no FOO> fail if C<unimport FOO> fails"
+ From: Tim Bunce
+ Files: gv.c
+
+ Title: "Bitwise op sign rationalization"
+ (Make bitwise ops result in unsigned values, unless C<use
+ integer> is in effect. Includes initial support for UVs.)
+ From: Chip Salzenberg
+ Files: op.c opcode.pl pod/perlop.pod pod/perltoc.pod pp.c pp.h
+ pp_hot.c proto.h sv.c t/op/bop.t
+
+ Title: "Defined scoping for C<my> in control structures"
+ (Finally defines semantics of "my" in control expressions,
+ like the condition of "if" and "while". In all cases, scope
+ of a "my" var extends to the end of the entire control
+ structure. Also adds new construct "for my", which
+ automatically declares the control variable "my" and limits
+ its scope to the loop.)
+ From: Chip Salzenberg
+ Files: op.c perly.c perly.c.diff perly.h perly.y proto.h toke.c
+
+ Title: "Fix ++/-- after int conversion (e.g. 'printf "%d"')"
+ (This patch makes Perl correctly ignore SvIVX() if either
+ NOK or POK is true, since SvIVX() may be a truncated or
+ overflowed version of the real value.)
+ From: Chip Salzenberg
+ Files: pp.c pp_hot.c sv.c
+
+ Title: "Make code match Camel II re: functions that use $_"
+ From: Paul Marquess
+ Files: opcode.pl
+
+ Title: "Provide scalar context on left side of "->""
+ From: Chip Salzenberg
+ Files: perly.c perly.y
+
+ Title: "Quote bearword package/handle FOO in "funcname FOO => 'bar'""
+ From: Chip Salzenberg
+ Files: toke.c
+
+
+ OTHER CORE CHANGES
+
+ Title: "Warn on overflow of octal and hex integers"
+ From: Chip Salzenberg
+ Files: proto.h toke.c util.c
+
+ Title: "If -w active, warn for commas and hashes ('#') in qw()"
+ From: Chip Salzenberg
+ Files: toke.c
+
+ Title: "Fixes for pack('w')"
+ From: Ulrich Pfeifer
+ Files: pp.c t/op/pack.t
+
+ Title: "More complete output from sv_dump()"
+ From: Gurusamy Sarathy
+ Files: sv.c
+
+ Title: "Major '..' and debugger patches"
+ From: Ilya Zakharevich
+ Files: lib/perl5db.pl op.c pp_ctl.c scope.c scope.h
+
+ Title: "Fix for formline()"
+ From: Gurusamy Sarathy
+ Files: global.sym mg.c perl.h pod/perldiag.pod pp_ctl.c proto.h sv.c
+ t/op/write.t
+
+ Title: "Fix stack botch in untie and binmode"
+ From: Gurusamy Sarathy
+ Files: pp_sys.c
+
+ Title: "Complete EMBED, including symbols from interp.sym"
+ (New define EMBEDMYMALLOC makes embedding total by
+ avoiding "Mymalloc" etc.)
+ From: Chip Salzenberg
+ Files: MANIFEST embed.pl ext/DynaLoader/dlutils.c
+ ext/SDBM_File/sdbm/sdbm.h global.sym handy.h malloc.c
+ perl.h pp_sys.c proto.h regexec.c toke.c util.c
+ x2p/Makefile.SH x2p/a2p.h x2p/handy.h x2p/util.h
+
+ Title: "Support old embedding for people who want it"
+ From: Chip Salzenberg
+ Files: MANIFEST Makefile.SH old_embed.pl old_global.sym
+
+
+ PORTABILITY
+
+ Title: "Miscellaneous VMS fixes"
+ From: Charles Bailey
+ Files: lib/ExtUtils/Liblist.pm lib/ExtUtils/MM_VMS.pm
+ lib/Math/Complex.pm lib/Time/Local.pm lib/timelocal.pl
+ perl.h perl_exp.SH proto.h t/TEST t/io/read.t
+ t/lib/findbin.t t/lib/getopt.t util.c utils/h2xs.PL
+ vms/Makefile vms/config.vms vms/descrip.mms
+ vms/ext/Stdio/Stdio.pm vms/ext/Stdio/Stdio.xs
+ vms/perlvms.pod vms/test.com vms/vms.c
+
+ Title: "DJGPP patches (MS-DOS)"
+ From: "Douglas E. Wegscheid" <wegscd@whirlpool.com>
+ Files: doio.c dosish.h ext/SDBM_File/sdbm/sdbm.c handy.h
+ lib/AutoSplit.pm lib/Cwd.pm lib/File/Find.pm malloc.c perl.c
+ perl.h pp_sys.c proto.h sv.c util.c
+
+ Title: "Plan 9 update"
+ From: Luther Huffman <lutherh@infinet.com>
+ Files: plan9/buildinfo plan9/config.plan9 plan9/exclude
+ plan9/genconfig.pl plan9/mkfile plan9/setup.rc
+
+ Title: "Patch to make Perl work under AmigaOS"
+ From: Norbert Pueschel
+ Files: MANIFEST hints/amigaos.sh installman lib/File/Basename.pm
+ lib/File/Find.pm pod/pod2man.PL pp_sys.c util.c
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "DB_File 1.05"
+ From: Paul Marquess
+ Files: ext/DB_File/DB_File.pm ext/DB_File/DB_File.xs t/lib/db-hash.t
+
+ Title: "Getopts::Std patch for hash support"
+ From: Stephen Zander <stephen.zander@interlock.mckesson.com>
+ Files: lib/Getopt/Std.pm
+
+ Title: "Kludge for bareword handles"
+ (Add 'require IO::Handle' at beginning of FileHandle.pm)
+ From: Chip Salzenberg
+ Files: ext/FileHandle/FileHandle.pm
+
+ Title: "Re: strtod / strtol patch for POSIX module"
+ From: hammen@gothamcity.jsc.nasa.gov (David Hammen)
+ Files: Configure config_h.SH ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod
+ ext/POSIX/POSIX.xs t/lib/posix.t
+
+ BUNDLED UTILITIES
+
+ Title: "Fix a2p translation of '{print "a" "b" "c"}'"
+ From: Chip Salzenberg
+ Files: x2p/a2p.c x2p/a2p.y
+
+
+----------------
+Version 5.003_07
+----------------
+
+This patch was primarily to fix bugs or include little things I missed
+in 5.003_06. 5.003_07 is intended to be stable enough to merit serious
+testing with an eye towards eventual release as 5.004.
+
+If it doesn't work for you, try
+
+ LC_ALL=C; export LC_ALL
+
+for Bourne shell users, or
+
+ setenv LC_ALL C
+
+for C-shell users. Some versions of IRIX are reported to have
+problems with sort when the locale is other than C. This manifests
+as an infinite loop in the ./miniperl configpm step.
+
+The details are described below. A very brief summary is:
+
+o Visible Changes to Core Functionality
+
+ -Support for BER compressed integers. See perlfunc.pod for
+ documentation on the 'w' option.
+
+ -untaint support added to IO extension.
+
+o Changes in Core Internals
+
+ -Perl's realloc is once again called 'Myremalloc' (with -DHIDEMYMALLOC),
+ as it was pre-5.003_01. Again, this is for binary compatibility
+ with 5.003. (5.003_06 erroneously called it Myrealloc.)
+
+ -Getopt::Long updated to version 2.4.
+
+o Configure and build enhancements
+
+ -improved SCO hints. Actually these are unconfirmed guesses, but
+ they may be right.
+
+ -OS/2 and Plan9 updates.
+
+o Bug fixes
+
+ -print sort (4,1,3,2);
+
+ -group numbers are integers again.
+
+ -other things. See the specific changes for details.
+
+o Specific Changes
+
+Here are the specific file-by-file changes.
+
+Index: Changes
+
+ Updated for 5.003_07.
+
+ Fixed a spelling error.
+
+Index: Configure
+
+ Detect GNU libc (thanks, Skimo!) and avoid nm if we have GNU libc.
+ Since the GNU libc test requires compiling and linking a test
+ program, the dependencies have been altered and lots of pieces of
+ Configure have moved around unchanged. The patch is big but the
+ effect is little.
+
+ Allow for both <sys/select.h> and <time.h> in fd_set tests.
+ Systems which don't allow both (e.g. SCO) have to turn off one
+ or the other in the hints file for now.
+
+Index: INSTALL
+
+ Warn about re-using config.sh version-specific values.
+
+Index: MANIFEST
+
+ Date: Tue, 8 Oct 1996 22:24:48 -0400
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Subject: PATCH: untaint method for IO::Handle, 5.003_06 version
+
+ This is a re-post of my patch to Graham's IO library to add a method in
+ IO::Handle called "untaint", that sets the IOf_UNTAINT flag on an object
+ that is of or inherits from IO::Handle. With this flag set, data read from
+ said handle is not tainted, whether running under -T, suid or sgid.
+
+ This patch adds the method to IO.xs, adds documentation and warning to the
+ pod of IO/Handle.pm, creates a new test in t/lib called io_taint.t, and
+ adds mention of the new file to MANIFEST.
+
+ Add mention of t/lib/io_taint.t
+
+ Date: Wed, 9 Oct 1996 22:29:44 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ os2/Changes added.
+
+Index: Makefile.SH
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ All the executable targets are moved into the same chunk with
+ shared library target, which is delegated to
+ $osname/Makefile.SHs if found.
+ config.h should depend on config_h.SH.
+
+ Remove mkmanifest target, since it will generate incorrectly
+ sorted MANIFEST file, I would imagine (I haven't checked).
+
+Index: README.os2
+
+ New version.
+
+Index: config_H
+
+ Update SH_PATH comment.
+
+Index: config_h.SH
+
+ Update SH_PATH comment.
+
+Index: ext/IO/IO.xs
+
+ Date: Tue, 8 Oct 1996 22:24:48 -0400
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Subject: PATCH: untaint method for IO::Handle, 5.003_06 version
+
+ This is a re-post of my patch to Graham's IO library to add a method in
+ IO::Handle called "untaint", that sets the IOf_UNTAINT flag on an object
+ that is of or inherits from IO::Handle. With this flag set, data read from
+ said handle is not tainted, whether running under -T, suid or sgid.
+
+ This patch adds the method to IO.xs, adds documentation and warning to the
+ pod of IO/Handle.pm, creates a new test in t/lib called io_taint.t, and
+ adds mention of the new file to MANIFEST.
+
+ Add method "untaint" into class IO::Handle
+
+Index: ext/IO/lib/IO/Handle.pm
+
+ Date: Tue, 8 Oct 1996 22:24:48 -0400
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Subject: PATCH: untaint method for IO::Handle, 5.003_06 version
+
+ This is a re-post of my patch to Graham's IO library to add a method in
+ IO::Handle called "untaint", that sets the IOf_UNTAINT flag on an object
+ that is of or inherits from IO::Handle. With this flag set, data read from
+ said handle is not tainted, whether running under -T, suid or sgid.
+
+ This patch adds the method to IO.xs, adds documentation and warning to the
+ pod of IO/Handle.pm, creates a new test in t/lib called io_taint.t, and
+ adds mention of the new file to MANIFEST.
+
+ Document IO::Handle::untaint and give warning about the bad
+ things it can do.
+
+Index: ext/SDBM_File/sdbm/sdbm.h
+
+ Change Myrealloc to Myremalloc to conform to 5.003's version.
+ I left in the Mycalloc since malloc.c now includes a calloc,
+ and we might need to hide it.
+
+Index: gv.c
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Better error message for overload.
+
+Index: hints/os2.sh
+
+ Date: Wed, 9 Oct 1996 22:29:44 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Some optimization (speedup in loading GNU utilities with some
+ memory present - 32M should be quite enough).
+ Test for revision of EMX, and setting fork()ing appropriately.
+ libc was in .../st/... instead of mt.
+ README.os2 is installed as pod/perlos2.pod.
+
+Index: hints/sco.sh
+
+ Don't include <sys/select.h> along with <time.h>.
+
+Index: installperl
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Restore timestamps under OS/2 (needed for binary install).
+
+Index: lib/Cwd.pm
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Use builtin methods if present under OS/2 (maybe should be
+ done outside of OS/2 too?).
+
+Index: lib/ExtUtils/MM_Unix.pm
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Made `use strict'-clean even in parts shadowed by Autoloading.
+
+Index: lib/ExtUtils/typemap
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ `bool' entry added.
+
+Index: lib/ExtUtils/xsubpp
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Logic for processing RETVAL documented (at last!).
+
+Index: lib/File/Copy.pm
+
+ Date: Thu, 10 Oct 1996 00:42:29 -0400 (EDT)
+ From: Ilya Zakharevich
+ Subject: Cleanup after new test
+
+ Below are patches for File::Copy (copying to filehandles was just
+ plain broken under OS/2 and VMS)
+
+Index: lib/FindBin.pm
+
+ Date: Fri, 20 Sep 1996 15:04:04 +0200
+ From: Gisle Aas
+ Subject: Documentation patch to the FindBin module
+
+Index: lib/Getopt/Long.pm
+
+ Update to version 2.4.
+
+Index: lib/lib.pm
+
+ Date: Thu, 10 Oct 1996 14:22:05 -0400
+ From: "Brent B. Powers" <powers@ml.com>
+ Subject: Re: patch for lib.pm
+
+ Ignore undefined entries.
+
+Index: lib/newgetopt.pl
+
+ Updated to version 2.4 to match Getopt::Long.
+
+Index: makedepend.SH
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ weed out perl_exp.SH, config_h.SH
+ (They have these funny names to avoid names like perl.exp.SH
+ with more than two '.' Such names are illegal on some systems.)
+
+Index: mg.c
+
+ Date: Thu, 10 Oct 1996 14:33:08 +0000 ()
+ From: Chip Salzenberg
+ Subject: Re: Group fix for 5.003_06
+
+ The group problems recently experienced are due to a small error
+ introduced in 5.003_06. This patch is required to fix the bug:
+
+Index: os2/Changes
+
+ Date: Wed, 9 Oct 1996 22:29:44 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ sys/un.h is not very useful without Merlin toolkit.
+ updates for fork()ing.
+
+ Date: Wed, 9 Oct 1996 22:29:44 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ added.
+
+Index: os2/Makefile.SHs
+
+ Date: Wed, 9 Oct 1996 22:29:44 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Convoluted process to create chimera executables added.
+ aout_clean is done automatically on clean.
+
+Index: os2/OS2/ExtAttr/t/os2_ea.t
+
+ Date: Wed, 9 Oct 1996 22:29:44 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Use `unlink' where appropriate.
+
+Index: os2/diff.configure
+
+ Updated.
+
+Index: os2/os2.c
+
+ Date: Wed, 9 Oct 1996 22:29:44 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ /bin/sh is translated to the configured value of location of sh.exe.
+ popen() used even if we can fork (as we do now).
+ builtins added for the sake of path manipulation.
+
+Index: os2/os2ish.h
+
+ Date: Wed, 9 Oct 1996 22:29:44 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ sys/un.h is not very useful without Merlin toolkit.
+ updates for fork()ing.
+
+Index: patchlevel.h
+
+ Change to subversion 7.
+
+Index: perl.c
+
+ Date: Wed, 9 Oct 1996 19:03:41 +0000
+ From: Tim Bunce
+ Subject: Infinte loop with perl_destruct_level and $SIG{__WARN__}
+
+ I've just started using purify on a perl with DBD::Oracle linked in
+ (the number of uninitialised memory reads in the Oracle libraries
+ is frightning!).
+
+ If perl_destruct_level and $SIG{__WARN__} are set then I see a range
+ of problems typified by this example and folowed by a core dump:
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Copywrite of OS/2 port now has \n\n.
+ Now deletes -e file (again!) if compilation is interrupted.
+
+Index: perl.h
+
+ Change Myrealloc to Myremalloc to conform to 5.003's version.
+ I left in the Mycalloc since malloc.c now includes a calloc,
+ and we might need to hide it.
+
+Index: plan9/aperl
+
+ Updated for 5.003_07
+
+Index: plan9/arpa/inet.h
+
+ Updated for 5.003_07
+
+Index: plan9/buildinfo
+
+ Updated for 5.003_07
+
+Index: plan9/config.plan9
+
+ Updated for 5.003_07
+
+Index: plan9/exclude
+
+ Updated for 5.003_07
+
+Index: plan9/fndvers
+
+ Updated for 5.003_07
+
+Index: plan9/genconfig.pl
+
+ Updated for 5.003_07
+
+Index: plan9/mkfile
+
+ Updated for 5.003_07
+
+Index: plan9/myconfig.plan9
+
+ Updated for 5.003_07
+
+Index: plan9/perlplan9.doc
+
+ Updated for 5.003_07
+
+Index: plan9/perlplan9.pod
+
+ Updated for 5.003_07
+
+Index: plan9/plan9.c
+
+ Updated for 5.003_07
+
+Index: plan9/plan9ish.h
+
+ Updated for 5.003_07
+
+Index: plan9/setup.rc
+
+ Updated for 5.003_07
+
+Index: plan9/versnum
+
+ Updated for 5.003_07
+
+Index: pod/perldiag.pod
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ mention that malloc in berkeley DB is broken, and PERL_BADFREE.
+ OS/2-specific messages added.
+
+Index: pod/perlfunc.pod
+
+ Date: 20 Sep 1996 13:17:14 +0200
+ From: Ulrich Pfeifer
+ Subject: Re: Patch for ASN.1 compressed integer in pack/unpack
+
+Index: pod/perli18n.pod
+
+ Updated version with high bits intact.
+
+Index: pod/perlop.pod
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Crossrefs corrected.
+
+Index: pod/perltrap.pod
+
+ Clarified that warn() _always_ printed to STDERR, both in perl4
+ and perl5.
+
+Index: pod/perlvar.pod
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ $^E under OS/2.
+
+Index: pp.c
+
+ Date: 20 Sep 1996 13:17:14 +0200
+ From: Ulrich Pfeifer
+ Subject: Re: Patch for ASN.1 compressed integer in pack/unpack
+
+Index: pp_sys.c
+
+ Date: Wed, 9 Oct 1996 19:07:24 GMT
+ From: Chris Faylor <cgf@bbc.com>
+
+ The problem is that SCO apparently needs to have a file opened
+ with write privileges for chsize to work correctly.
+
+Index: sv.c
+
+ Date: Tue, 08 Oct 1996 23:54:47 -0400
+ From: Gurusamy Sarathy
+ Subject: Re: Sorting lists of integers doesn't always work
+
+ >> > print sort (4,1,2,3);
+ >> >
+ >> > actually prints "4123", i.e. doesn't actually sort. Bug? Feature?
+
+ This broke between 5.001n and 5.002. There was a long winded thread
+ about sorting undefs in some order (rather than coredumping) around
+ the 5.002beta times (search for "bogorefs" in the subject-line on
+ p5p archive for details). Larry added in some code that presumes that
+ the private flags are set by the time qsort() is called:
+
+ Unfortunately, sv_2pv() does not set the POKp flag, so the above
+ code breaks! Here's a patch against 5.00306.
+
+Index: t/lib/anydbm.t
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ File mode under OS/2 is not what you expect. However, this has
+ nothing to do with databases, _and_ there is a test
+ for this in stat.t (which dutifully fails). There is
+ no point to consider this behaviour as a bug in
+ database code.
+ So OS/2 is special-cased in these tests.
+
+Index: t/lib/db-btree.t
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ File mode under OS/2 is not what you expect. However, this has
+ nothing to do with databases, _and_ there is a test
+ for this in stat.t (which dutifully fails). There is
+ no point to consider this behaviour as a bug in
+ database code.
+ So OS/2 is special-cased in these tests.
+
+Index: t/lib/db-hash.t
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ File mode under OS/2 is not what you expect. However, this has
+ nothing to do with databases, _and_ there is a test
+ for this in stat.t (which dutifully fails). There is
+ no point to consider this behaviour as a bug in
+ database code.
+ So OS/2 is special-cased in these tests.
+
+Index: t/lib/db-recno.t
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ File mode under OS/2 is not what you expect. However, this has
+ nothing to do with databases, _and_ there is a test
+ for this in stat.t (which dutifully fails). There is
+ no point to consider this behaviour as a bug in
+ database code.
+ So OS/2 is special-cased in these tests.
+
+Index: t/lib/gdbm.t
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ File mode under OS/2 is not what you expect. However, this has
+ nothing to do with databases, _and_ there is a test
+ for this in stat.t (which dutifully fails). There is
+ no point to consider this behaviour as a bug in
+ database code.
+ So OS/2 is special-cased in these tests.
+
+Index: t/lib/io_pipe.t
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ Better error message on dying.
+
+Index: t/lib/io_taint.t
+
+ Date: Tue, 8 Oct 1996 22:24:48 -0400
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Subject: PATCH: untaint method for IO::Handle, 5.003_06 version
+
+ This is a re-post of my patch to Graham's IO library to add a method in
+ IO::Handle called "untaint", that sets the IOf_UNTAINT flag on an object
+ that is of or inherits from IO::Handle. With this flag set, data read from
+ said handle is not tainted, whether running under -T, suid or sgid.
+
+ This patch adds the method to IO.xs, adds documentation and warning to the
+ pod of IO/Handle.pm, creates a new test in t/lib called io_taint.t, and
+ adds mention of the new file to MANIFEST.
+
+ Test suite for the untaint method of class IO::Handle.
+
+Index: t/lib/ndbm.t
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ File mode under OS/2 is not what you expect. However, this has
+ nothing to do with databases, _and_ there is a test
+ for this in stat.t (which dutifully fails). There is
+ no point to consider this behaviour as a bug in
+ database code.
+ So OS/2 is special-cased in these tests.
+
+Index: t/lib/odbm.t
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ File mode under OS/2 is not what you expect. However, this has
+ nothing to do with databases, _and_ there is a test
+ for this in stat.t (which dutifully fails). There is
+ no point to consider this behaviour as a bug in
+ database code.
+ So OS/2 is special-cased in these tests.
+
+Index: t/lib/sdbm.t
+
+ Date: Wed, 9 Oct 1996 22:30:38 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ File mode under OS/2 is not what you expect. However, this has
+ nothing to do with databases, _and_ there is a test
+ for this in stat.t (which dutifully fails). There is
+ no point to consider this behaviour as a bug in
+ database code.
+ So OS/2 is special-cased in these tests.
+
+Index: t/lib/socket.t
+
+ Date: Thu, 10 Oct 1996 01:09:59 -0400
+ From: Spider Boardman
+ Subject: Re: 5.003_06 is available (results on ULTRIX)
+
+ fix t/lib/socket.t to treat TCP like the stream protocol it is
+ rather than expecting it behave rationally in all cases.
+
+Index: t/op/pack.t
+
+ Date: 20 Sep 1996 13:17:14 +0200
+ From: Ulrich Pfeifer
+ Subject: Re: Patch for ASN.1 compressed integer in pack/unpack
+
+Index: t/op/sort.t
+
+ Date: Wed, 09 Oct 1996 00:41:27 -0400
+ From: Gurusamy Sarathy
+ Subject: more t/op/sort.t tests
+
+Index: util.c
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich
+
+ uses my_syspopen, my_syspclose ifdef OS2. my_pclose is defined
+ as my_syspclose ifdef OS2 and can FORK (as OS2 does).
+
+Index: x2p/Makefile.SH
+
+ Date: Wed, 9 Oct 96 16:00:29 edt
+ From: Norton Allen <nort@bottesini.harvard.edu>
+ Subject: Re: sh Configure?
+
+ Extract x2p/Makefile.SH and x2p/cflags.SH correctly down
+ in the x2p directory, even if $0 isn't set to the full
+ pathname of the file being extracted.
+
+Index: x2p/cflags.SH
+
+ Date: Wed, 9 Oct 96 16:00:29 edt
+ From: Norton Allen <nort@bottesini.harvard.edu>
+ Subject: Re: sh Configure?
+
+ Extract x2p/Makefile.SH and x2p/cflags.SH correctly down
+ in the x2p directory, even if $0 isn't set to the full
+ pathname of the file being extracted.
+
+
+----------------
+Version 5.003_06
+----------------
+
+This patch was primarily to fix bugs, improve the documentation,
+and work towards restoring binary compatibility with 5.003.
+The details are described below. A very brief summary is:
+
+o Visible Changes to Core Functionality
+
+ -Significantly improved support _with documentation_ for
+ locales, including LC_COLLATE. See the new pod/perli18n.pod.
+ Thanks to Jarkko Hietaniemi.
+
+ -new version of Math::Complex, with test suite. Ought to be
+ backwards compatible, but check it out if you use Math::Complex.
+
+ -Pre-extending hashes now works. keys %hash = 5000 will pre-size
+ %hash.
+
+ -__DATA__ filehandle is untainted.
+
+o Changes in Core Internals
+
+ -gv_fullname and gv_efullname have reverted to their pre-5.003_03
+ versions for binary compatibility. Actually, they are implemented
+ as stubs pointing to the new 3-argument forms gv_fullname3 and
+ gv_efullname3.
+
+ -Perl's malloc is once again called 'Mymalloc' (with -DHIDEMYMALLOC),
+ as it was pre-5.003_01. Again, this is for binary compatibility
+ with 5.003.
+
+o Configure and build enhancements
+
+ -many new tests for the standard library.
+
+ -test suite now locale-friendly.
+
+ -a2p.man and s2p.man now made into pods.
+
+o Bug fixes
+
+ -whitespace lexer errors fixed.
+
+ -many, many other things. See details below.
+
+o Specific Changes
+
+Here are the specific file-by-file changes.
+
+# This is my patch perl5.003_06.pat to perl5.003_05
+# The full description is below.
+# Please execute the following commands before applying this patch.
+# (You can feed this patch to 'sh' to do so.)
+# -- Andy Dougherty
+
+# We'll create some new tests, but patch won't automatically make them
+# executable.
+for t in abbrev.t autoloader.t basename.t checktree.t complex.t \
+ env.t fatal.t filecache.t filecopy.t filefind.t filepath.t \
+ findbin.t getopt.t hostname.t parsewords.t searchdict.t \
+ selectsaver.t symbol.t texttabs.t textwrap.t timelocal.t
+do
+ touch t/lib/$t
+ chmod +x t/lib/$t
+done
+
+# The a2p.man and s2p.man pages have been changed into pods.
+rm -f x2p/a2p.man x2p/s2p.man
+
+exit 0
+
+
+This is patch perl5.003_06.pat to perl version 5.003_05.
+This takes you from 5.003_05 to 5.003_06.
+
+To apply this patch, run the above commands,
+cd to your perl source directory and then type
+
+ patch -p1 -N < perl5.003_06.pat
+
+The changes are described after each /^Index:/ line below. This is
+designed so you can examine each change with a command such as
+
+ csplit -k perl5.003_06.pat '/^Index:/' '{999}'
+
+(Of course, since there are more than 100 Index entries, your
+csplit may complain, since many csplit's have an arbitrary limit of 100
+files. Still, you can manually split the file or roll your own.)
+
+Index: Changes
+
+ Updated for 5.003_06.
+
+Index: Configure
+
+ Add -Wl,rpath option for irix* to find the installed shared
+ libperl.so
+
+ Add /shlib to libpth. It is used by Digital Unix 4.0.
+
+ Date: Mon, 30 Sep 1996 14:01:05 +0100
+ From: Sven Verdoolaege <skimo@breughel.ufsia.ac.be>
+
+ Detect Cygnus Win32, or at least don't let Configure get fooled
+ into thinking it's OS/2.
+
+Index: INSTALL
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ added LC_COLLATE doc.
+
+Index: MANIFEST
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+ Date: Sat, 28 Sep 1996 15:11:06 +0200
+ From: Andreas Koenig
+ Subject: Dale's posting as patch (Was: Perl 5.003_5 make fails on NS3.2 - CURED)
+
+ Handle NeXT, POSIX, and setpgid in pp_sys.c and POSIX.
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ added perli18n.pod.
+
+Index: README
+
+ Changed Larry's address to larry@wall.org.
+
+Index: configpm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: configure
+
+ Date: Mon, 30 Sep 1996 14:01:05 +0100
+ From: Sven Verdoolaege <skimo@breughel.ufsia.ac.be>
+
+ Warn the user of case-insensitive file systems that they may have
+ accidentally gotten 'configure' instead of 'Configure'.
+
+Index: doio.c
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: doop.c
+
+ Date: Mon, 30 Sep 1996 01:13:28 -0400
+ From: Spider Boardman
+ Subject: Re: pre extending hash? - need speed
+
+ The patch below (which is relative to perl5.001l) implements
+ "keys %hash = 50_000;" (or other integer-evaluable sizes) for
+ pre-sizing hashes. I've only moved the patch forward from
+ when I first did it. I'm sure the code in hv_ksplit could be
+ improved.
+
+Index: dump.c
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+Index: embed.h
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+Index: ext/DynaLoader/DynaLoader.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: ext/FileHandle/FileHandle.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: ext/IO/IO.pm
+
+ Updated to IO-1.12.
+
+Index: ext/IO/IO.xs
+
+ Updated to IO-1.12.
+
+Index: ext/IO/lib/IO/File.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Updated to IO-1.12.
+
+Index: ext/IO/lib/IO/Handle.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Updated to IO-1.12.
+
+Index: ext/IO/lib/IO/Pipe.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Updated to IO-1.12.
+
+Index: ext/IO/lib/IO/Seekable.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Updated to IO-1.12.
+
+Index: ext/IO/lib/IO/Select.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Updated to IO-1.12.
+
+Index: ext/IO/lib/IO/Socket.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Updated to IO-1.12.
+
+Index: ext/NDBM_File/hints/dynixptx.pl
+
+ Perl 5.003_05 compiles on DYNIX/ptx 4.0 (v4.1.3), and passes all tests.
+ The only change needed is in "ext/NDBM_File/Makefile.PL" - on this system,
+ ndbm is actually contained in the libc library, and must be linked against
+ -lc when compiling. (this is for dynamic ELF executables, I didn't compile
+ statically)
+
+Index: ext/Opcode/Opcode.pm
+
+ Date: Fri, 20 Sep 1996 12:59:21 +0200
+ From: Gisle Aas
+ Subject: Re: Symbol.pm clobbers $_ at startup
+
+ The same kind of problem seem to be present in Opcode.pm:
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: ext/Opcode/Safe.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: ext/POSIX/POSIX.pod
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ enhanced setlocale() docs and introduced the one-argument variant doc.
+
+Index: ext/POSIX/POSIX.xs
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ setlocale() allowed one argument only,
+ call to perl_init_fold() (in util.c) if setlocale() succeeded.
+
+Index: ext/POSIX/hints/next_3.pl
+
+ Date: Sat, 28 Sep 1996 15:11:06 +0200
+ From: Andreas Koenig
+ Subject: Dale's posting as patch (Was: Perl 5.003_5 make fails on NS3.2 - CURED)
+
+ Handle NeXT, POSIX, and setpgid in pp_sys.c and POSIX.
+
+Index: ext/SDBM_File/sdbm/sdbm.h
+
+ Revert from Perl_malloc to Mymalloc for binary compatibility with
+ 5.003.
+
+Index: ext/Socket/Socket.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: global.sym
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+ Date: Mon, 30 Sep 1996 01:13:28 -0400
+ From: Spider Boardman
+ Subject: Re: pre extending hash? - need speed
+
+ The patch below (which is relative to perl5.001l) implements
+ "keys %hash = 50_000;" (or other integer-evaluable sizes) for
+ pre-sizing hashes. I've only moved the patch forward from
+ when I first did it. I'm sure the code in hv_ksplit could be
+ improved.
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ added var lc_collate_active and func mem_collxfrm.
+
+Index: gv.c
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+Index: handy.h
+
+ Date: Sat, 21 Sep 1996 21:33:15 -0400 (EDT)
+ From: Kenneth Albanowski
+ Subject: Full LONG_MAX & co. patch over 5.003_05
+
+ This patch contains the changes I've collected for the various _MAX issues
+ since 5.003_05. No patches issued between 5.003_05 and this one should be
+ applied, use this one instead.
+
+ The effect is to remove the CHAR_* and I8_* constants (which are
+ ambiguous) and to explicitly cast all of the constants.
+
+Index: hints/machten.sh
+
+ Add notes about MachTen 4.0.3 SYSV IPC.
+
+Index: hints/next_3.sh
+
+ Replace optimize="-g" by optimize="" since we're just trying to turn off
+ the optimizier.
+
+ Date: Sat, 28 Sep 1996 15:11:06 +0200
+ From: Andreas Koenig
+ Subject: Dale's posting as patch (Was: Perl 5.003_5 make fails on NS3.2 - CURED)
+
+ Handle NeXT, POSIX, and setpgid in pp_sys.c and POSIX.
+
+Index: hv.c
+
+ Date: Fri, 20 Sep 1996 15:38:57 -0400
+ From: Gurusamy Sarathy
+ Subject: Re: "Attempt to free non-existent shared string"? (with patch)
+
+ I found a subtle problem with the lazydelete mechanism (which is used
+ to postpone the delete of a entry that may be getting iterated over).
+ I was using the HeKLEN slot to hold the hint, but the real HeKLEN is
+ needed later to call unsharepvn(). This means that only magical
+ hash entries can use the HeKLEN slot to hold flags.
+
+ Here's a tested patch against 5.00305 that fixes the problem.
+ The patch simply moves the LAZYDEL hint to become a SV-level private
+ flag.
+
+ Date: Mon, 30 Sep 1996 01:13:28 -0400
+ From: Spider Boardman
+ Subject: Re: pre extending hash? - need speed
+
+ The patch below (which is relative to perl5.001l) implements
+ "keys %hash = 50_000;" (or other integer-evaluable sizes) for
+ pre-sizing hashes. I've only moved the patch forward from
+ when I first did it. I'm sure the code in hv_ksplit could be
+ improved.
+
+Index: hv.h
+
+ Date: Fri, 20 Sep 1996 15:38:57 -0400
+ From: Gurusamy Sarathy
+ Subject: Re: "Attempt to free non-existent shared string"? (with patch)
+
+ I found a subtle problem with the lazydelete mechanism (which is used
+ to postpone the delete of a entry that may be getting iterated over).
+ I was using the HeKLEN slot to hold the hint, but the real HeKLEN is
+ needed later to call unsharepvn(). This means that only magical
+ hash entries can use the HeKLEN slot to hold flags.
+
+ Here's a tested patch against 5.00305 that fixes the problem.
+ The patch simply moves the LAZYDEL hint to become a SV-level private
+ flag.
+
+Index: installman
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: installperl
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/AutoLoader.pm
+
+ Date: Mon Sep 9 09:29:44 1996
+ From: Gisle Aas
+ Subject: Re: problem with 'die' and UserAgent
+
+ > This is a patch to the AutoLoader.pm (from 5.003) that fixes the problem:
+ This is a better patch (no need to test for /::DESTROY$/ twice):
+
+ Date: Mon, 30 Sep 1996 00:54:37 -0400
+ From: Spider Boardman
+
+ The test and patches for AutoLoader were also non-functional,
+ since the regexp context (curpm) was still being clobbered by the
+ filename manipulations:
+
+ Date: Sun, 06 Oct 1996 16:15:07 +0200
+ From: Gisle Aas
+ Subject: Re: Can't locate auto/U/autosplit.ix
+
+ It would IMHO be much better if the AutoLoader exported the AUTOLOAD()
+ function. With an exported AUTOLOAD() we would not have to inherit
+ from AutoLoader, and we would avoid these problems.
+
+ This patch tries to explain the behavior of AutoLoader instead by
+ updating its documentation.
+
+Index: lib/Benchmark.pm
+
+ Date: Sat, 28 Sep 1996 17:01:22 +0300 (EET DST)
+ From: Jarkko Hietaniemi
+ Subject: a really really tiny typo
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Cwd.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Devel/SelfStubber.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Env.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Exporter.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/ExtUtils/Embed.pm
+
+ Remove unwantd space after the I in -I$Config[archlib}
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/ExtUtils/Install.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/ExtUtils/MM_Unix.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/ExtUtils/MM_VMS.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: lib/ExtUtils/MakeMaker.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/ExtUtils/Manifest.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: lib/ExtUtils/Mksymlists.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/ExtUtils/xsubpp
+
+ Change a reference from perlapi(1) to perlxs(1).
+
+Index: lib/File/Basename.pm
+
+ Date: Fri, 20 Sep 1996 14:11:05 +0200
+ From: Gisle Aas
+ Subject: File::BaseName: "/" is legal path separator for MSDOS
+
+ The File::BaseName module should allow "/" as path separator when
+ fileparse_set_fstype("MSDOS") is in effect:
+
+ Date: Fri, 20 Sep 1996 13:58:52 +0200
+ From: Gisle Aas
+ Subject: File::Basename documentation patch
+
+ Date: Mon, 30 Sep 1996 00:54:37 -0400
+ From: Spider Boardman
+
+ For t/lib/basename.t, though, the associated patch for
+ File::Basename was also wrong:
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: lib/File/Copy.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/File/Find.pm
+
+ Date: Sat, 7 Sep 1996 21:37:44 +0200
+ From: Michael De La Rue <mikedlr@it.com.pl>
+ Subject: File::Find assumes $_ remains unchanged; bug
+
+ The File::Find perl module assumes that the $_ variable remains unchanged
+ through the user defined function which is callbacked from find. It carries
+ out a stat operation
+
+ Simplest fix is merely to document this
+
+Index: lib/File/Path.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/FindBin.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Getopt/Long.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/I18N/Collate.pm
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ deprecated and trapped (will whine if called and tell to migrate away)
+
+Index: lib/IPC/Open2.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/IPC/Open3.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Math/BigInt.pm
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ ord() is a dangerous thing.
+
+Index: lib/Math/Complex.pm
+
+ Date: Thu, 03 Oct 96 18:38:08 +0200
+ From: Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com>
+ # Complex numbers and associated mathematical functions
+ # -- Raphael Manfredi, Sept 1996
+ # New version. Should be backwards compatible, but please
+ # check it out if you use it.
+
+Index: lib/Pod/Text.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Search/Dict.pm
+
+ Date: Sat, 21 Sep 1996 23:02:42 +0200
+ From: Gisle Aas
+ Subject: look() in Search::Dict should use lc() istead of tr/A-Z/a-z/
+
+ The Search::Dict look() function should use the lc() function instead
+ of tr/A-Z/a-z/. This will make folding of non-english letters work if
+ the locale is set up correctly.
+
+Index: lib/SelfLoader.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Symbol.pm
+
+ Date: Fri, 20 Sep 1996 12:38:14 +0200
+ From: Gisle Aas
+ Subject: Symbol.pm clobbers $_ at startup
+
+ perl -le 'BEGIN {$_="foo";} use Symbol; print qualify($_)'
+
+ I don't understand why the module want to initialize %global from
+ <DATA> in the first place. Perhaps we want to apply this patch
+ instead.
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Sys/Hostname.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Term/Cap.pm
+
+ Date: 23 Sep 1996 14:11:38 +0200
+ From: Ulrich Pfeifer
+ Subject: Patch for Term::Cap
+
+ 'use Term::Cap' produces a warning when diagnosics are active. The
+ patch below avoids the warning.
+
+ [The $entry .= $_ usage is idiomatic enough that it ought to be
+ ok, I would think, but the patch certainly is ok too.]
+
+Index: lib/Term/Complete.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Term/ReadLine.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Test/Harness.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: lib/Text/Abbrev.pm
+
+ Date: 23 Sep 1996 11:33:01 +0200
+ From: Ulrich Pfeifer
+ Subject: Text::Abbrev (Re: More standard library test scripts)
+
+ This patch merges the Text::Abbrev related patches/tests from Gisle
+ and my previous patch (i.e. replaces both).
+
+Index: lib/Text/Tabs.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Text/Wrap.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/Time/Local.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/UNIVERSAL.pm
+
+ Add in stub file.
+
+Index: lib/bigint.pl
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ ord() is a dangerous thing.
+
+Index: lib/diagnostics.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/overload.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/perl5db.pl
+
+ Date: Mon, 30 Sep 1996 00:34:58 -0400 (EDT)
+ From: Ilya Zakharevich
+ Subject: Re: dereferencing a hash from the debugger won't work
+
+Index: lib/splain
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: lib/strict.pm
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: makedepend.SH
+
+ Add explicit $touch $firstmakefile for QNX which apparently
+ preserves modification times for a 'cp' command.
+ I worry, though, that touch might not be portable to OS/2.
+ If it is, then I'll remove the fancy case statement.
+
+Index: malloc.c
+
+ Not all sbrks return zeroed memory.
+
+Index: mg.c
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+ Date: Sun, 29 Sep 1996 22:18:19 -0400 (EDT)
+ From: Chip Salzenberg
+ Subject: 5.003_05: Fix numeric value of $!
+
+ This patch undoes a bit of over-zealous integerization in mg.c, related
+ to the numeric value of $!.
+
+ Date: Mon, 30 Sep 1996 01:13:28 -0400
+ From: Spider Boardman
+ Subject: Re: pre extending hash? - need speed
+
+ The patch below (which is relative to perl5.001l) implements
+ "keys %hash = 50_000;" (or other integer-evaluable sizes) for
+ pre-sizing hashes. I've only moved the patch forward from
+ when I first did it. I'm sure the code in hv_ksplit could be
+ improved.
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+ Date: Fri, 4 Oct 1996 12:38:31 -0400 (EDT)
+ From: Chip Salzenberg
+ Subject: 5.003_05: Fix numeric $! and $^E
+
+ This patch undoes a bit of over-zealous integerization in mg.c,
+ related to the numeric values of $! and $^E. This patch *REPLACES*
+ the one I posted earlier, which was only effective for $!.
+
+ [Some of this is superceded by similar stuff in the VMS patches.]
+
+Index: op.c
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+ Date: Mon, 30 Sep 1996 01:13:28 -0400
+ From: Spider Boardman
+ Subject: Re: pre extending hash? - need speed
+
+ The patch below (which is relative to perl5.001l) implements
+ "keys %hash = 50_000;" (or other integer-evaluable sizes) for
+ pre-sizing hashes. I've only moved the patch forward from
+ when I first did it. I'm sure the code in hv_ksplit could be
+ improved.
+
+Index: opcode.h
+
+ Date: Mon, 16 Sep 1996 16:37:48 -0700
+ From: Jonathan Biggar <jon@sems.com>
+ Subject: Perl 5.003 bug when embedding in C++ program
+
+ The following patch is necessary in order to embed the Perl5.003 interpreter
+ into a C++ program without getting prototype mismatch errors from the
+ C++ compiler.
+
+Index: opcode.pl
+
+ Date: Mon, 16 Sep 1996 16:37:48 -0700
+ From: Jonathan Biggar <jon@sems.com>
+ Subject: Perl 5.003 bug when embedding in C++ program
+
+ The following patch is necessary in order to embed the Perl5.003 interpreter
+ into a C++ program without getting prototype mismatch errors from the
+ C++ compiler.
+
+Index: patchlevel.h
+
+ Change to subversion 6.
+
+Index: perl.c
+
+ From: Roderick Schertler
+ Subject: Re: -T flag and removal of `.' from @INC
+
+ support C<perl -e'attached code'>
+
+ Date: Tue, 01 Oct 1996 19:02:17 -0400
+ From: Gurusamy Sarathy
+ Subject: Re: 2 core dumps (patch)
+ Message-Id: <199610012302.TAA08395@aatma.engin.umich.edu>
+
+ The problem is an uninitialized SV slot in errgv. Here's a patch.
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: perl.h
+
+ Date: Sat, 21 Sep 1996 21:33:15 -0400 (EDT)
+ From: Kenneth Albanowski
+ Subject: Full LONG_MAX & co. patch over 5.003_05
+
+ This patch contains the changes I've collected for the various _MAX issues
+ since 5.003_05. No patches issued between 5.003_05 and this one should be
+ applied, use this one instead.
+
+ The effect is to remove the CHAR_* and I8_* constants (which are
+ ambiguous) and to explicitly cast all of the constants.
+
+ Date: Mon, 30 Sep 1996 01:13:28 -0400
+ From: Spider Boardman
+ Subject: Re: pre extending hash? - need speed
+
+ The patch below (which is relative to perl5.001l) implements
+ "keys %hash = 50_000;" (or other integer-evaluable sizes) for
+ pre-sizing hashes. I've only moved the patch forward from
+ when I first did it. I'm sure the code in hv_ksplit could be
+ improved.
+
+ Revert from Perl_malloc to Mymalloc for binary compatibility with
+ 5.003.
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+Index: perl_exp.SH
+
+ Add new function perl_init_fold. (I'm not sure it goes here.)
+
+Index: perlio.c
+
+ Date: Thu, 12 Sep 96 15:58 PDT
+ From: Hunter Kelly <retnuh@zule.pixar.com>
+ Subject: Re: 5.003_05 is available.
+
+ Fix PerlIO_reopen parameters.
+
+Index: perlsdio.h
+
+ Date: Fri, 13 Sep 1996 17:24:01 -0400
+ From: John Stoffel <jfs@jfs.fluent.com>
+ Subject: Re: 5.003_05 is available.
+
+ Undef Irix getc_unlocked and putc_unlocked #defines.
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: pod/Makefile
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ perli18n.pod (and perlapio.pod, btw) added.
+
+Index: pod/buildtoc
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perl.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Changed Larry's address to larry@wall.org.
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ perli18n advertised.
+
+Index: pod/perlapio.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+Index: pod/perlbook.pod
+
+ Updated for Second Edition.
+
+Index: pod/perlcall.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perldata.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perldebug.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perldiag.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: pod/perldsc.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlembed.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlform.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlfunc.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlguts.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+ Date: Mon, 23 Sep 96 13:18:01 PDT
+ From: Jeff Okamoto
+ Subject: Re: perlguts API Listing patch
+
+ Here's the lastest complete version for inclusion into _06 or .004. This
+ incorporates and supersedes Dean's patch.
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perli18n.pod
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ written.
+
+Index: pod/perlipc.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perllol.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlmod.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Date: Wed, 02 Oct 1996 16:52:08 -0400
+ From: Roderick Schertler
+ Subject: documentation for $? in END
+
+ Document the behavior with $? WRT END subroutines.
+
+Index: pod/perlobj.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlop.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Date: Fri, 4 Oct 1996 10:36:19 -0400 (EDT)
+ From: Kenneth Albanowski
+ Subject: Re: Suggestion for improving man page
+
+ Add alternative names for various escape sequences.
+
+Index: pod/perlpod.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlre.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Date: Fri, 4 Oct 1996 10:36:19 -0400 (EDT)
+ From: Kenneth Albanowski
+ Subject: Re: Suggestion for improving man page
+
+ Add alternative names for various escape sequences.
+
+Index: pod/perlref.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlrun.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlsec.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlstyle.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlsub.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlsyn.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perltie.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perltoc.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Changed Larry's address to larry@wall.org.
+
+Index: pod/perltrap.pod
+
+ Date: Wed, 11 Sep 1996 13:26:18 -0400
+ From: Gurusamy Sarathy
+ Subject: a perl425 trap
+
+ Here's an addition that should be self-explanatory.
+ [interpolation issues]
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/perlvar.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Date: Wed, 02 Oct 1996 16:52:08 -0400
+ From: Roderick Schertler
+ Subject: documentation for $? in END
+
+ Document the behavior with $? WRT END subroutines.
+
+Index: pod/perlxstut.pod
+
+ Date: Wed, 11 Sep 1996 11:55:18 -0500
+ From: "Daniel S. Lewart" <lewart@vadds.cvm.uiuc.edu>
+ Subject: POD spelling patches
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: pod/pod2man.PL
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+ Bugs found in pod2man
+
+ The following bugs were noticed, and some fixed:
+
+ 1. Where a L<> link extends over more than one line, pod2man does not
+ treat it as a link but displays it literally, and so these have been
+ rearranged to place the link on one line. This is the only bug worked
+ around. [Fixed; the rearrangements, which were done beforehand,
+ remain in some cases, but are no longer necessary, and pod paragraphs
+ can now be safely reformatted to whatever width is desired in the pod,
+ without breaking links.]
+
+ 2. It seems to swallow spaces after certain links: for example, part
+ of the "open" entry in the perlfunc manpage comes out as "the
+ \f(CWbinmode\fR entry elsewhere in this documentfor tips", the source
+ having been "L</binmode> for tips". [Fixed.]
+
+ 3. 'L</"Pass by Reference">', in perlsub.pod, comes out as '\fI/"Pass
+ by Reference\fR', that is, with an initial '/"'.
+
+ 4. If a pod line begins with ".", nothing is done to prevent [tng]roff
+ from treating it as a [tng]roff instruction.
+
+ 5. When the paragraph below =head1 NAME has more than one line, this
+ confuses pod2man: so in the case of Term::Readline, the manpage begins
+ with a stray line 'no real package is found, substitutes stubs instead
+ of basic functions."'.
+
+ Of course, it would be better to fix pod2man; I hope that the new Pod
+ modules, when ready, will not have these defects.
+
+Index: pp_ctl.c
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ sortcmp() sprouted a LC_COLLATE branch.
+
+Index: pp_hot.c
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+ Date: Thu, 19 Sep 1996 11:58:22 -0400
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Subject: Patch: Untaint FH flag and clean DATA handles
+
+ This patch adds a IOf_UNTAINT flag in sv.h, as one of the possibles
+ on an xpvio->xio_flags struct member. It is used to mark the given
+ file handle as a clean source, even when tainting is turned on.
+ There are also patches to pp_sys.c in pp_sysread to check this flag
+ before tainting data, and in pp_hot.c in do_readline for the same
+ reason. Lastly, it patches toke.c to automatically set this flag on
+ on a __DATA__ filehandle. The creation of the $pack::DATA
+ pseudo-filehandle is already checked against running under eval, so
+ this should not introduce any insecurity.
+
+ This patch *does not*:
+
+ * Add the "untaint" keyword.
+
+Index: pp_sys.c
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+ Date: Thu, 19 Sep 1996 11:58:22 -0400
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Subject: Patch: Untaint FH flag and clean DATA handles
+
+ This patch adds a IOf_UNTAINT flag in sv.h, as one of the possibles
+ on an xpvio->xio_flags struct member. It is used to mark the given
+ file handle as a clean source, even when tainting is turned on.
+ There are also patches to pp_sys.c in pp_sysread to check this flag
+ before tainting data, and in pp_hot.c in do_readline for the same
+ reason. Lastly, it patches toke.c to automatically set this flag on
+ on a __DATA__ filehandle. The creation of the $pack::DATA
+ pseudo-filehandle is already checked against running under eval, so
+ this should not introduce any insecurity.
+
+ This patch *does not*:
+
+ * Add the "untaint" keyword.
+
+ Date: Sun, 22 Sep 1996 17:26:57 -0400
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Subject: Patch to patch for untainting
+
+ The following patch ensures that a glob used as a filehandle that
+ has had the UNTAINT flag set will not carry that flag over on a
+ re-open. In a nutshell, a re-open of the DATA filehandle would be
+ considered untainted, and an object of class IO::Handle (or one of
+ its sub-classes) that is marked untainted with the untaint method,
+ then closed and re-opened, retained the untaintedness.
+
+ Date: Mon, 30 Sep 1996 00:54:37 -0400
+ From: Spider Boardman
+
+ First, with IO::untaint, the patches as posted resulted in a
+ miniperl which couldn't open files, so the autosplitting of the
+ library and the creation of Makefiles for the extensions didn't
+ work. Worse, it didn't just fail to open files, it dumped core.
+
+Index: proto.h
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+ Date: Mon, 30 Sep 1996 01:13:28 -0400
+ From: Spider Boardman
+ Subject: Re: pre extending hash? - need speed
+
+ The patch below (which is relative to perl5.001l) implements
+ "keys %hash = 50_000;" (or other integer-evaluable sizes) for
+ pre-sizing hashes. I've only moved the patch forward from
+ when I first did it. I'm sure the code in hv_ksplit could be
+ improved.
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ mem_collxfrm() and perl_init_fold() added.
+
+Index: run.c
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+Index: sv.c
+
+ Restore the 5.003 gv_fullname() and gv_efullname() functions.
+ Provide new 3-arg forms gv_fullname3() and gv_efullname3().
+
+ Date: Mon, 30 Sep 1996 01:13:28 -0400
+ From: Spider Boardman
+ Subject: Re: pre extending hash? - need speed
+
+ The patch below (which is relative to perl5.001l) implements
+ "keys %hash = 50_000;" (or other integer-evaluable sizes) for
+ pre-sizing hashes. I've only moved the patch forward from
+ when I first did it. I'm sure the code in hv_ksplit could be
+ improved.
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+ I've added some DEBUG_Ps to sv.c which give a trace of the
+ fast I/O fiddling with stdio in sv_gets(). These were useful
+ to me in setting up the VMS fast I/O, and I left them in in
+ case they're useful to someone in the future. However, if you
+ think it overloads -DP too much, feel free to drop it. (-DP
+ already adds a profile of op usage to its advertised output.)
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ sv_cmp() sprouted a LC_COLLATE branch.
+
+Index: sv.h
+
+ Date: Thu, 19 Sep 1996 11:58:22 -0400
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Subject: Patch: Untaint FH flag and clean DATA handles
+
+ This patch adds a IOf_UNTAINT flag in sv.h, as one of the possibles
+ on an xpvio->xio_flags struct member. It is used to mark the given
+ file handle as a clean source, even when tainting is turned on.
+ There are also patches to pp_sys.c in pp_sysread to check this flag
+ before tainting data, and in pp_hot.c in do_readline for the same
+ reason. Lastly, it patches toke.c to automatically set this flag on
+ on a __DATA__ filehandle. The creation of the $pack::DATA
+ pseudo-filehandle is already checked against running under eval, so
+ this should not introduce any insecurity.
+
+ This patch *does not*:
+
+ * Add the "untaint" keyword.
+
+ Date: Fri, 20 Sep 1996 15:38:57 -0400
+ From: Gurusamy Sarathy
+ Subject: Re: "Attempt to free non-existent shared string"? (with patch)
+
+ I found a subtle problem with the lazydelete mechanism (which is used
+ to postpone the delete of a entry that may be getting iterated over).
+ I was using the HeKLEN slot to hold the hint, but the real HeKLEN is
+ needed later to call unsharepvn(). This means that only magical
+ hash entries can use the HeKLEN slot to hold flags.
+
+ Here's a tested patch against 5.00305 that fixes the problem.
+ The patch simply moves the LAZYDEL hint to become a SV-level private
+ flag.
+
+Index: t/base/term.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ \n not necessarily lt ' '.
+
+Index: t/comp/package.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ XYZ not necessarily gt xyz.
+
+Index: t/lib/abbrev.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+ Date: 23 Sep 1996 11:33:01 +0200
+ From: Ulrich Pfeifer
+ Subject: Text::Abbrev (Re: More standard library test scripts)
+
+ This patch merges the Text::Abbrev related patches/tests from Gisle
+ and my previous patch (i.e. replaces both).
+
+Index: t/lib/anydbm.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ A not necessarily gt a.
+
+Index: t/lib/autoloader.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+ Date: Mon, 30 Sep 1996 00:54:37 -0400
+ From: Spider Boardman
+
+ The test and patches for AutoLoader were also non-functional,
+ since the regexp context (curpm) was still being clobbered by the
+ filename manipulations:
+
+Index: t/lib/basename.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+ Date: Mon, 30 Sep 1996 00:54:37 -0400
+ From: Spider Boardman
+
+ Fix the number of tests.
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+ A different set of tests for File::Basename and friends.
+
+Index: t/lib/checktree.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/complex.t
+
+ Date: Thu, 03 Oct 96 18:38:08 +0200
+ From: Raphael Manfredi <Raphael_Manfredi@grenoble.hp.com>
+ # Complex numbers and associated mathematical functions
+ # -- Raphael Manfredi, Sept 1996
+
+ Tests for new version.
+
+Index: t/lib/db-btree.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ A not necessarily gt a.
+
+Index: t/lib/db-hash.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ A not necessarily gt a.
+
+Index: t/lib/env.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/fatal.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/filecache.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/filecopy.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/filefind.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/filepath.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/findbin.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/gdbm.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ A not necessarily gt a.
+
+Index: t/lib/getopt.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/hostname.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/ndbm.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ A not necessarily gt a.
+
+Index: t/lib/odbm.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ A not necessarily gt a.
+
+Index: t/lib/parsewords.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/sdbm.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ A not necessarily gt a.
+
+Index: t/lib/searchdict.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/selectsaver.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/symbol.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+ Date: Mon, 30 Sep 1996 00:54:37 -0400
+ From: Spider Boardman
+
+ The various new lib/*.t tests didn't all work. For some, it was
+ only because the count of tests was wrong:
+
+Index: t/lib/texttabs.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/textwrap.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/lib/timelocal.t
+
+ Date: Sun, 22 Sep 1996 00:59:56 +0200
+ From: Gisle Aas
+ Subject: More standard library test scripts
+
+ This is a collection of test scripts for the standard library modules.
+ Some of the tests does not pass unless some of the patches I have sent
+ out are applied.
+
+Index: t/op/each.t
+
+ Date: Mon, 30 Sep 1996 01:13:28 -0400
+ From: Spider Boardman
+ Subject: Re: pre extending hash? - need speed
+
+ The patch below (which is relative to perl5.001l) implements
+ "keys %hash = 50_000;" (or other integer-evaluable sizes) for
+ pre-sizing hashes. I've only moved the patch forward from
+ when I first did it. I'm sure the code in hv_ksplit could be
+ improved.
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ A not necessarily gt a.
+
+Index: t/op/glob.t
+
+ Date: Tue, 01 Oct 1996 16:37:03 -0400 (EDT)
+ From: Charles Bailey
+ Subject: Re: glob test 1 failing...bad test or bug
+
+ Under AIX 4.1.4, with LOCALE set en_GB (British english) glob test one
+ fails because <op/*> sorts op/re_* before op/rea*, while
+ $otherway = `echo op/*` sorts op/re_* after op/re[a-z]*.t
+
+ This version doesn't rely on the sorting order.
+
+Index: t/op/magic.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+Index: t/op/readdir.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ A not necessarily gt a.
+
+Index: t/op/sort.t
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ A not necessarily gt a.
+
+Index: toke.c
+
+ Date: Sat, 14 Sep 1996 17:08:16 -0400
+ From: Gurusamy Sarathy
+ Subject: whitespace induced lexer errors (with patch)
+
+ I finally got around to fixing skipspace() to not indiscriminately
+ overwrite oldbufptr and oldoldbufptr (which are used in making
+ expectation decisions in the lexer).
+
+ Date: Sat, 14 Sep 1996 18:55:16 -0400
+ From: Gurusamy Sarathy
+ Subject: perl lexer won't accept C<my($a,$b);$a<=>$b;>
+
+ Date: Thu, 19 Sep 1996 11:58:22 -0400
+ From: "Randy J. Ray" <rjray@uswest.com>
+ Subject: Patch: Untaint FH flag and clean DATA handles
+
+ This patch adds a IOf_UNTAINT flag in sv.h, as one of the possibles
+ on an xpvio->xio_flags struct member. It is used to mark the given
+ file handle as a clean source, even when tainting is turned on.
+ There are also patches to pp_sys.c in pp_sysread to check this flag
+ before tainting data, and in pp_hot.c in do_readline for the same
+ reason. Lastly, it patches toke.c to automatically set this flag on
+ on a __DATA__ filehandle. The creation of the $pack::DATA
+ pseudo-filehandle is already checked against running under eval, so
+ this should not introduce any insecurity.
+
+ This patch *does not*:
+
+ * Add the "untaint" keyword.
+
+Index: util.c
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi
+ Subject: LC_COLLATE.
+
+ Big patch to add, document, and test LC_COLLATE support.
+
+ rewrote perl_init_i18n() completely.
+ - reworded to be much more friendly and clear.
+ - perl_init_fold() split to its own function.
+ wrote mem_collxfrm().
+
+Index: utils/c2ph.PL
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: utils/h2ph.PL
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: utils/h2xs.PL
+
+ Date: Sat, 21 Sep 1996 16:38:24 -0500
+ From: Dean Roehrich
+ Subject: h2xs bug fix
+
+ The h2xs that is in perl5.003_05 has a regexp bug which prevents it from
+ finding #define statements and filling the constant() function. This patch
+ fixes that. The h2xs_test program found this--maybe people who are
+ modifying h2xs should get a copy of the test program.
+
+ This also adds a -d to enable debugging messages (there's just one for now).
+ I've also placed some of the doc-related things in alphabetical order.
+
+ h2xs_test can be found in my directory on CPAN. Those of you modifying
+ xsubpp should know there's a test suite for that, too, called XSTEST which
+ can also be found in my directory on CPAN.
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ Here is a patch for various typos and other defects in the Perl
+ 5.003_05 pods, including the pods embedded in library modules.
+
+Index: utils/perldoc.PL
+
+ Date: Sun, 29 Sep 1996 22:00:09 -0400 (EDT)
+ From: Kenneth Albanowski
+ Subject: perldoc patch
+
+ Ilya has found that this change makes perldoc much more useful under OS/2.
+
+Index: vms/config.vms
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: vms/descrip.mms
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: vms/genconfig.pl
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: vms/perlvms.pod
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: vms/vms.c
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey
+ Subject: VMS patches to 5.003_05
+
+Index: x2p/a2p.pod
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ This patch just changed the old a2p.man page into a pod page.
+
+Index: x2p/s2p.PL
+
+ Date: Fri, 20 Sep 1996 15:08:33 +0100 (BST)
+ From: "Joseph S. Myers" <jsm28@hermes.cam.ac.uk>
+ Subject: Pod typos, pod2man bugs, and miscellaneous installation comments
+
+ This patch just changed the old s2p.man page into a pod page.
+ I then embedded the pod into the s2p script.
+
+
+----------------
+Version 5.003_05
+----------------
+
+This patch was primarily to fix bugs and to clean up some of
+the remaining issues from in 5.003_04. The details are described below.
+A very brief summary is:
+
+o Visible Changes to Core Functionality
+
+ -Add support for a READLINE method to tied filehandles.
+
+ -times function now uses CLK_TCK if HZ is not available, rather
+ than just defaulting to 60. times output might change on some
+ systems, but should be correct now.
+
+ -AnyDBM_File (modifying ISA does not work as expected)
+ Now behaves as documented: Modifying ISA works to select
+ order in which *DB* modules are tried. The default is still
+ the same.
+
+o Configure and build enhancements
+
+ -Enhance detection of [gs]etpgrp() variants. Some systems have
+ BSD-style behavior for one and POSIX for the other. Use
+ [gs]etpgid() instead, whenever possible.
+
+ -You can now build a shared libperl.so without running through
+ the LD_RUN_PATH hoops, if your system supports appropriate
+ ld command-line options. Solaris, NetBSD, and Linux are currently
+ supported. Others are easy to add. (This makes like a lot easier
+ for embedders.)
+
+ -VMS updates.
+
+ -Fix installperl and installman so that the -n option really only
+ prints commands. (previously, it would still do the mkdirs.)
+
+o Bug fixes
+
+ -debugger ought to work.
+
+ -A new heredoc tag in Makefile.SH is now quoted. This prevented
+ 5.003_04 from working most places.
+
+ -numerous smaller ones, detailed below.
+
+o Specific Changes
+
+Here are the specific file-by-file changes.
+
+# This is my patch perl5.003_05.pat to perl5.003_04
+# The full description is below.
+# Please execute the following commands before applying this patch.
+# (You can feed this patch to 'sh' to do so.)
+# -- Andy Dougherty
+
+# We'll create a new test, but patch won't automatically make it
+# executable.
+touch t/io/read.t
+chmod +x t/io/read.t
+
+exit 0
+
+
+This is patch perl5.003_05.pat to perl version 5.003_04.
+This takes you from 5.003_04 to 5.003_05.
+
+To apply this patch, run the above commands,
+cd to your perl source directory and then type
+
+ patch -p1 -N < perl5.003_05.pat
+
+The changes are described after each /^Index/ line below. This is
+designed so you can examine each change with a command such as
+
+ csplit -k perl5.003_05.pat '/^Index:/' '{99}'
+
+Index: Changes
+
+ Updated for 5.003_05.
+
+Index: Configure
+
+ Allow command line or hint-file overrides of $afs.
+
+ Allow trailing spaces in nm output for HPUX10.
+
+ Check for newer BIND 'search' directives in /etc/resolv.conf as well
+ as older 'domain' directive.
+
+ Enhance detection of [gs]etpgrp() variants. Some systems have
+ BSD-style behavior for one and POSIX for the other. Use
+ [gs]etpgid() instead, whenever possible.
+
+ Include -s in the -h summary of available options.
+
+ Allow command-line override of $afs.
+
+ Handle trailing spaces in nm-output on HPUX10.
+
+ Set shrpenv for handling LD_RUN_PATH, if needed. (This used to
+ be in Makefile.SH. Now it's available for other modules too.)
+
+ When using shared libperl, avoid LD_RUN_PATH if possible by adding
+ correct ld flags. Currently, Solaris and NetBSD get the correct
+ -R $archlibexp/CORE, and Linux gets its
+ -Wl,-rpath,$archlibexp/CORE flag. Other contributions are
+ welcome.
+
+Index: INSTALL
+
+ Correct libperl5 -> libperl typo.
+
+ Describe MakeMaker's Warning (will try anyway) messages.
+
+ More info on where and how to send reports.
+
+ Add info on non-Unix ports.
+
+
+Index: MANIFEST
+
+ Add new test t/io/read.t.
+
+ Add new hints files for ODBM_File for ultrix and hpux.
+
+ Add new pod checker script.
+
+Index: Makefile.SH
+
+ A new heredoc tag in Makefile.SH needs to be quoted.
+
+ shrpenv stuff moved to Configure.
+
+Index: Porting/Glossary
+
+ Updated to match Configure.
+
+Index: README.vms
+
+ VMS 5.003_05 Update.
+
+Index: av.h
+
+ Subject: turbidity in av.[ch]
+ Date: Sun, 10 Dec 1995 00:21:31 -0500
+ From: Gurusamy Sarathy
+
+ Some unclean code that I noticed today.
+
+Index: config_H
+
+ Updated to match newest config_h.SH.
+
+Index: config_h.SH
+
+ Updated to match Configure.
+
+ Changed the DLSYM_NEEDS_UNDERSCORE comment to
+ /**/ to conform to metaconfig style.
+
+Index: emacs/cperl-mode.el
+
+ From: Ilya Zakharevich
+ Subject: Newer CPerl-mode
+
+Index: ext/DB_File/DB_File.pm
+
+ Update to DB_File 1.03.
+
+Index: ext/DB_File/DB_File.xs
+
+ Update to DB_File 1.03.
+
+Index: ext/Fcntl/Fcntl.pm
+
+ Date: Thu, 5 Sep 1996 18:19:14 -0400 (EDT)
+ From: Chip Salzenberg
+ Subject: No AutoLoader for Fcntl
+
+ Just like Socket, Fcntl doesn't need splitting and AutoLoading.
+
+Index: ext/FileHandle/FileHandle.pm
+
+ From: Roderick Schertler
+ Subject: FileHandle::DESTROY for fd 0
+
+ This fixes FileHandle::DESTROY when called on stdin.
+
+Index: ext/ODBM_File/ODBM_File.xs
+
+ Attempt to correct for "Bad free" in Ultrix and HPUX versions of
+ odbm.
+
+Index: ext/ODBM_File/hints/hpux.pl
+
+ Try to work around "bad free" in dbmclose().
+
+Index: ext/ODBM_File/hints/ultrix.pl
+
+ Try to work around "bad free" in dbmclose().
+
+Index: ext/Socket/Socket.pm
+
+ Date: Thu, 5 Sep 1996 09:58:08 +0200
+ From: Andreas Koenig
+ Subject: Patch to inhibit autosplit on Socket.pm
+
+ This patch inhibits production and use of a completely useless
+ auto/Socket/autosplit.ix.
+
+Index: handy.h
+
+ Make a little more C++-friendly for IBM's CSET++ compiler.
+
+Index: hints/convexos.sh
+
+ Remove [gs]etpgrp workaround. Configure & perl.h should handle
+ this now.
+
+Index: hints/hpux.sh
+
+ Add note about possible gcc GR3 warning message.
+
+ Remove [gs]etpgrp workaround. Configure & perl.h should handle
+ this now.
+
+Index: hints/sco.sh
+
+ Turn off optimization for stock cc. This appears to
+ prevent miniperl core dumps.
+
+Index: hints/solaris_2.sh
+
+ Catch GNU ld even though it doesn't identify itself as a GNU tool.
+ Thanks to Tim Pierce <twpierce@midway.uchicago.edu>.
+
+Index: hints/sunos_4_1.sh
+
+ Describe solution for the __lib_version problem with acc on
+ SunOS.
+
+Index: hv.c
+
+ Date: Thu, 05 Sep 1996 00:25:28 -0400
+ From: Gurusamy Sarathy
+ Subject: minor misc. cleanup
+
+ This patch makes some minor cleanups to the sources. No change
+ in functionality whatsoever.
+
+ Date: Thu, 05 Sep 1996 02:52:21 -0400
+ From: Gurusamy Sarathy
+
+ Subject: debugger problems--another patch (was Re: 5.003_04)
+
+ I have tried to avoid copying of hash keys that are passed to
+ magical hashes, but it seems that copying may be unavoidable
+ since the hv_*_ent() functions could be PADTMPs (and other
+ SVs that may get reused) as keys.
+
+ VMS dynamic %ENV fix
+
+Index: installman
+
+ From: scotth@sgi.com
+ Subject: Re: installperl feature request (was: Re: Upgrade 4.0x to 5.001m)
+
+ Fix installperl so that the -n option really only prints commands.
+ (previously, it would still do the mkdirs.)
+
+ an "ignore installed" option, so that it doesn't bother to check
+ to see if the target already exists (an optimization that I
+ *don't* want it to do when I do #1 above)
+
+Index: installperl
+
+ From: scotth@sgi.com
+ Subject: Re: installperl feature request (was: Re: Upgrade 4.0x to 5.001m)
+
+ Fix installperl so that the -n option really only prints commands.
+ (previously, it would still do the mkdirs.)
+
+ an "ignore installed" option, so that it doesn't bother to check
+ to see if the target already exists (an optimization that I
+ *don't* want it to do when I do #1 above)
+
+Index: lib/AnyDBM_File.pm
+
+ AnyDBM_File (modifying ISA does not work as expected)
+ Now behaves as documented: Modifying ISA works to select
+ order in which *DB* modules are tried. The default is still
+ the same.
+
+
+ Add helpful "die" message to end of AnyDBM_File. Previously
+ it would return a 0, and the failure would eventually show up
+ somewhere else in the script and be hard to track down. It is
+ a failure if perl can't open AnyDBM_File. The test regression
+ suite is supposed to indicate this as a failure too.
+
+Index: lib/ExtUtils/Install.pm
+
+ Updated to MakeMaker-5.38.
+
+ Fix for VMS utime.
+
+Index: lib/ExtUtils/Liblist.pm
+
+ Updated to MakeMaker-5.38.
+
+Index: lib/ExtUtils/MM_Unix.pm
+ Updated to MakeMaker-5.38.
+
+Index: lib/ExtUtils/MakeMaker.pm
+
+ Updated to MakeMaker-5.38.
+
+ Updated to MakeMaker-5.39 to allow CFLAGS in hint files.
+
+Index: lib/ExtUtils/Manifest.pm
+
+ Updated to MakeMaker-5.38.
+
+Index: lib/ExtUtils/Mkbootstrap.pm
+
+ Updated to MakeMaker-5.38.
+
+Index: lib/ExtUtils/Mksymlists.pm
+
+ Updated to MakeMaker-5.38.
+
+Index: lib/File/Find.pm
+
+ From: Michael Mahan <mahanm@nextwork.rose-hulman.edu>
+ Subject: Cwd::fastcwd in File::Find
+
+ Is there a good reason why File::Find uses Cwd::fastcwd instead of
+ Cwd:cwd when fastcwd isn't as portable?
+ [In particular, fastcwd() doesn't work on AFS.]
+
+Index: lib/Math/Complex.pm
+
+ There was a mistake in the sqrt routine in lib/Math/Complex.pm that
+ gave wrong answers when the magnitude of the imaginary part of the
+ argument exceeded the magnitude of the real part. Line 69 had too
+ many sqrt($y)'s. Further, expressions were re-arranged so that
+ calls to the expensive real sqrt() routine were reduced from 4 to 2
+ in this case.
+
+Index: lib/open3.pl
+
+ The I/O directions on the dad_wtr and kid_rdr were backwards.
+ IO/Open3.pm didn't have this error.
+
+Index: lib/syslog.pl
+
+ Date: Tue, 03 Sep 1996 20:33:54 -0400
+ From: Roderick Schertler
+ Subject: syslog.pl `use Socket' lossage
+
+ syslog.pl tries but fails to use
+ Socket.pm, the problem is that use doesn't return a true value. This
+ module should be recast in terms of Sys::Syslog, of course.
+
+Index: makedepend.SH
+
+ This patch eliminates "\|" in sed patterns in makedepend.SH, since
+ they're not really needed anyway in this one case.
+
+Index: mg.c
+
+ Ok, here's a tested patch for the debugger problem.
+ I was missing the fact that DB::dbline magic is actually
+ uppercase (which means hv_store_ent() etc., will pass SV keys
+ to the vtbl_dbline handlers).
+
+ Replace the oft-repeated mg_ptr incantation with
+ the simple MgPVKEY macro.
+
+ Rename MgPVKEY to MgPV (to match with HePV elsewhere). Add
+ additional parens around the "mg".
+
+ (lines near 584) Part of VMS changes. I don't know what this did.
+
+ Date: Fri, 23 Aug 1996 17:20:22 -0400 (EDT)
+ From: Chip Salzenberg
+ Subject: Integerize mg.c; eliminate warning on C< local($)) >
+
+ This patch converts magic variables ($!, $^E, etc.) to use integers
+ (C<sv_setiv>) instead of floats. It also eliminates a warning from
+ C< local($)) >, via a hack similar to $!.
+
+Index: mg.h
+
+ Replace the oft-repeated mg_ptr incantation with
+ the simple MgPVKEY macro.
+
+ Rename MgPVKEY to MgPV (to match with HePV elsewhere). Add
+ additional parens around the "mg".
+
+Index: nostdio.h
+
+ Add _STDIO_LOADED (VMS) to list of guard symbols.
+
+Index: op.c
+
+ From: Gurusamy Sarathy
+ Subject: Re: \ ( @array ) busted for lexical @array (once more)
+
+Index: patchlevel.h
+
+ Change to subversion 5.
+
+Index: perl.c
+
+ Make floating point constants Locale-friendly.
+
+Index: perl.h
+
+ One last LONG & co. fix (yet another cut'n'paste error) and a few
+ minor cleanups. Nothing crucial.
+
+ Make a little more C++-friendly for IBM's CSET++ compiler.
+
+ Enhance detection of [gs]etpgrp() variants. Some systems have
+ BSD-style behavior for one and POSIX for the other. Use
+ [gs]etpgid() instead, whenever possible.
+
+Index: perlio.c
+
+ Eliminate potential "signed vs. unsigned" warning
+
+ Add PerlIO_reopen and PerlIO_cgetname functions.
+
+Index: perlsdio.h
+
+ Don't supply redundant parameters for PerlIO_open and PerlIO_fdopen.
+
+ Include PerlIO_reopen and PerlIO_getname.
+
+ s/FILE_(CNT|PTR)_LVALUE/STDIO_(CNT|PTR)_LVALUE to fix a typo.
+ This had prevented SV_FAST_FGETS from working anywhere.
+
+ Include PerlIO_canset_cnt. I'm not sure how this is supposed to
+ differ from STDIO_CNT_LVALUE.
+
+Index: pod/Makefile
+
+ Remove trailing spaces in pods.
+ Include a call to the checkpods script in the Makefile (though it's
+ not ordinarily used by users).
+
+Index: pod/checkpods.PL
+
+ New script to check for common errors in pods. This is not
+ normally called during the perl build process, but you can
+ use it with B<make check>.
+
+Index: pod/perlfunc.pod
+
+ Document correct C<use POSIX ":wait_h";> usage.
+
+ Add notes about POSIX [gs]etpgrp.
+
+Index: pod/perlipc.pod
+
+ Document correct C<use POSIX ":wait_h";> usage.
+
+Index: pod/perlref.pod
+
+ From: Gurusamy Sarathy
+ Subject: Re: \ ( @array ) busted for lexical @array (once more)
+
+Index: pod/perltie.pod
+
+ Date: Thu, 29 Aug 1996 15:14:51 +0200
+ From: Sven Verdoolaege <skimo@breughel.ufsia.ac.be>
+ Subject: more TIEHANDLE
+
+ This adds support for a READLINE method.
+
+Index: pod/perltrap.pod
+
+ Here's documentation on the change in split's behavior between Perl 4
+ and Perl 5.
+
+ Subject: More (and less!) 425traps
+
+ Large integer traps
+
+ Precedence
+
+ warn STDERR
+
+ Change blank lines to empty lines.
+
+Index: pod/perlvar.pod
+
+ Be explicit about $/="" matching empty lines, that is, lines
+ with no spaces or tabs.
+
+ Change blank lines to empty lines.
+
+Index: pp.c
+
+ Date: Fri, 23 Aug 1996 17:22:40 -0400 (EDT)
+ From: Chip Salzenberg
+ Subject: Minor integer speedups in mathematics
+
+ This patch provides minor speedups by using integer math and SVt_IV
+ values when performing bitwise operations and modulus.
+
+ Date: Tue, 3 Sep 1996 17:49:22 -0400 (EDT)
+ From: Kenneth Albanowski
+ Subject: Pack Patch (was Re: 5.002 - pack/unpack does not do "I" right)
+
+ (double)auint cast added for call to sv_setnv().
+
+Index: pp_hot.c
+
+ Date: Thu, 05 Sep 1996 00:25:28 -0400
+ From: Gurusamy Sarathy
+ Subject: minor misc. cleanup
+
+ This patch makes some minor cleanups to the sources. No change
+ in functionality whatsoever.
+
+ Date: Thu, 29 Aug 1996 15:14:51 +0200
+ From: Sven Verdoolaege <skimo@breughel.ufsia.ac.be>
+ Subject: more TIEHANDLE
+
+ This adds support for a READLINE method.
+
+Index: pp_sys.c
+
+ Clear any buffer space exposed by by read().
+ This is almost certainly a bug-fix.
+
+ Undef and then re-define my_chsize from Perl_my_chsize to
+ just plain chsize if this system HAS_CHSIZE. This probably only
+ applies to SCO. This shows the perils of having internal
+ functions with the same name as external library functions :-).
+
+ Use CLK_TCK if HZ is not available.
+
+Index: sv.c
+
+ Fix more spots where we had PerlIO_stderr() and should have had
+ Perl_debug_log instead.
+
+ Date: Fri, 23 Aug 1996 17:26:42 -0400 (EDT)
+ From: Chip Salzenberg
+ Subject: Minor potential bug in AV creation
+
+ I wasn't the one who originated this patch. But it looks like it
+ would improve the safety of AV creation.
+
+ Remove potentially incorrect casts on PerlIO_set_ptrcnt.
+ 'ptr' is already STDCHAR, which is supposed to be the type of
+ char used in stdio.h, so we shouldn't have to cast it.
+
+Index: t/io/read.t
+
+ Clear any buffer space exposed by by read().
+ This is almost certainly a bug-fix.
+
+Index: t/lib/db-btree.t
+
+ Update to DB_File 1.03.
+
+Index: t/lib/db-hash.t
+
+ Update to DB_File 1.03.
+
+Index: t/lib/db-recno.t
+
+ Update to DB_File 1.03.
+
+Index: t/lib/io_sock.t
+
+ From: Lupe Christoph <lupe@alanya.m.isar.de>
+ Subject: Perl 5.003.03: race condition in t/lib/io_sock.t
+
+ io_sock.t works by forking a subprocess it can communicate with.
+ It has the subprocess wait for the main process by sleeping 10
+ seconds or until an alarm arrives.
+
+ With my setup, the alarm signal arrives *before* the child
+ has a chance to ignore the alarm signal.
+
+ I fixed this by moving the "$SIG{ALRM} = sub {};" up before the
+ fork. It does not hurt to have the parent ignore alarms, too.
+
+Index: t/op/inc.t
+
+ One last LONG & co. fix (yet another cut'n'paste error) and a few
+ minor cleanups. Nothing crucial.
+
+Index: t/op/misc.t
+
+ Date: Thu, 29 Aug 1996 15:14:51 +0200
+ From: Sven Verdoolaege <skimo@breughel.ufsia.ac.be>
+ Subject: more TIEHANDLE
+
+ This adds support for a READLINE method.
+
+Index: t/op/pack.t
+
+ Date: Tue, 3 Sep 1996 17:49:22 -0400 (EDT)
+ From: Kenneth Albanowski
+ Subject: Pack Patch (was Re: 5.002 - pack/unpack does not do "I" right)
+
+Index: t/op/ref.t
+
+ From: Gurusamy Sarathy
+ Subject: Re: \ ( @array ) busted for lexical @array (once more)
+
+Index: universal.c
+
+ Date: Thu, 29 Aug 96 07:05:10 BST
+ From: Graham Barr
+ Subject: Re: UNIVERSAL::class busted
+
+ yes, but I also noticed that this does not check that the reference
+ is an object, so the patch should be
+
+Index: unixish.h
+
+ Change comment style so that IBM's picky xlc compiler doesn't
+ think we've mistakenly tried to nest comments.
+
+Index: util.c
+
+ One last LONG & co. fix (yet another cut'n'paste error) and a few
+ minor cleanups. Nothing crucial.
+
+Index: utils/h2xs.PL
+
+ Date: Fri, 6 Sep 1996 06:09:20 -0400 (EDT)
+ From: Ilya Zakharevich
+ Subject: updated h2xs
+
+ Changes:
+ a) Docs and examples for -x updated;
+ b) Path to xxxx.h would not be changed to /usr/include/xxxx.h
+ unless this file exists (outside of VMS, I'm afraid to make an error
+ there). - Useful with -x option, when the file may be eaten via -I
+ inside -F.
+ c) .h file would be scanned only if needed.
+ d) typemap would be generated (with T_PTROBJ).
+ e) Documentation (=list) for autogenerated guys would be
+ included into POD.
+ f) duplicated XSUBs would not be generated;
+ g) arguments to XSUBs being arrays are recognized (note that
+ xsubpp would probably choke on such guys).
+
+ -x option requires C-Scan-0.3 (releases a couple of minutes ago to
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
+ should propagate to CPAN soon).
+
+Index: utils/perlbug.PL
+
+ Fix typo $Config{'has_sockets'} ought to be $Config{'d_socket'};
+
+Index: utils/perldoc.PL
+
+ More choices in the pager war. Unfortunately, we can't rely on
+ all users agreeing with the Sysadmin's choice, nor can we
+ assign a default preference order, since opinions vary. If the
+ user doesn't have $ENV{PAGER} set, we do want to pick up one that
+ at least works, so we'll try whatever Configure found.
+
+Index: vms/Makefile
+
+ VMS 5.003_05 Update.
+
+Index: vms/config.vms
+
+ VMS 5.003_05 Update.
+
+Index: vms/descrip.mms
+
+ VMS 5.003_05 Update.
+
+Index: vms/ext/Stdio/Stdio.pm
+
+ VMS 5.003_05 Update.
+
+Index: vms/ext/filespec.t
+
+ VMS 5.003_05 Update.
+
+Index: vms/gen_shrfls.pl
+
+ VMS 5.003_05 Update.
+
+Index: vms/perlvms.pod
+
+ VMS 5.003_05 Update.
+
+Index: vms/vms.c
+
+ VMS 5.003_05 Update.
+
+Index: vms/vmsish.h
+
+ VMS 5.003_05 Update.
+
+
+----------------
+Version 5.003_04
+----------------
+
+This patch was primarily to fix bugs and to clean up some of
+the changes made in 5.003_03. The details are described below.
+A very brief summary is:
+
+o Visible Changes to Core Functionality
+
+ -Allow and document permissions for FileHandle::new and
+ IO::File::new.
+ -glob in Safe compartment used to allow shell access; now
+ it's in the same category as `` and system().
+
+o Configure and build enhancements
+
+ -perl library name is again -lperl, not -lperl5 in some cases.
+ -Several hint files no longer set -g -DDEBUGGING by default.
+ Instead, they just turn off optimization, since that is
+ probably what was intended.
+ -Include OS/2 and Plan9 updates.
+
+o Bug fixes
+
+ -SEGV with $_[0] and circular references fixed.
+ -Ilya's debugger patch.
+ -FAKE typeglobs fixed.
+ -truncate with file name now works.
+ -lval substr() no longer coredumps with refs
+ -lval substr now clears lexicals in re-entered scopes.
+ -core dump in caller() for signal handler for __DIE__.
+
+o Specific Changes
+
+Here are the specific file-by-file changes.
+
+# This is my patch perl5.003_04.pat to perl5.003_03
+# The full description is below.
+# Please execute the following commands before applying this patch.
+# (You can feed this patch to 'sh' to do so.)
+# -- Andy Dougherty
+
+# Obsolete perl4 hint file.
+rm -f hints/dnix.sh
+# Obsolete
+rm -f os2/notes
+
+# We'll create a new test, but patch won't automatically make it
+# executable.
+touch t/op/gv.t
+chmod +x t/op/gv.t
+
+exit 0
+
+
+This is patch perl5.003_04.pat to perl version 5.003_03.
+This takes you from 5.003_03 to 5.003_04.
+
+To apply this patch, run the above commands,
+cd to your perl source directory and then type
+
+ patch -p1 -N < perl5.003_04.pat
+
+The changes are described after each /^Index/ line below. This is
+designed so you can examine each change with a command such as
+
+ csplit -k perl5.003_04.pat '/^Index:/' '{99}'
+
+Index: Changes
+
+ Updated for 5.003_04.
+
+Index: Configure
+
+ Change name of shared libperl library back to libperl.so.xxx,
+ so that a simple -lperl picks up either libperl.a or
+ libperl.so.xxx.
+
+ Check if $sh='' in case we've reloaded an old config.sh
+
+Index: INSTALL
+
+ Change name of shared perl library to libperl, instead of
+ libperl5.
+
+ Add notes about fragility of shared libperl and the usefulness
+ of archlib to separate different binaries.
+
+Index: MANIFEST
+
+ os2/notes removed
+
+ obsolete hints/dnix.sh removed.
+
+ New typeglob test.
+
+Index: Makefile.SH
+
+ For building shared libperl, relocate whole rule to
+ inside the if test -f $osname/Makefile.SHs case.
+
+Index: Porting/Glossary
+
+ Updated.
+
+Index: README.os2
+
+ Updated.
+
+Index: av.c
+
+ Subject: Re: SEGV with $_[0] and circular references
+
+ Subject: random cleanup
+
+ This patch removes a few obvious redundancies in the source.
+
+Index: config_H
+
+ Updated. Note new comments to make AIX happy.
+
+Index: config_h.SH
+
+ Change /*#define../**/ into /*#define../ **/
+ to make IBM's xlc compiler shut up about nested comments.
+ The /*#define FOO /**/ is a perfectly legal un-nested comment, and
+ I wish IBM would fix it's blasted compiler instead. In the meantime
+ we'll take mercy on the poor AIX user and get rid of the screenfulls
+ of stupid warning messages. Thanks to Hallvard B Furuseth for the fix.
+
+Index: dump.c
+
+ This patch changes neither behavior nor performance. However, it does
+ reduce code size and improve maintainability by combining some common
+ code in gv_fullname() and gv_efullname().
+
+Index: ext/FileHandle/FileHandle.pm
+
+ This patch documents the behavior of FileHandle::{new,open} with
+ regard to open modes. It also documents the exportation of Fcntl
+ constants.
+
+ This patch fixes a bug observed by Tom Christiansen: FileHandle::new
+ didn't allow for file permissions after the file mode. Here's a patch.
+
+Index: ext/IO/lib/IO/File.pm
+
+ This patch fixes a bug observed by Tom Christiansen: IO::File::new
+ didn't allow for file permissions after the file mode. Here's a patch.
+
+ This patch documents the behavior of IO::File::{new,open} with
+ regard to open modes. It also documents the exportation of Fcntl
+ constants.
+
+Index: ext/Opcode/Opcode.pm
+
+ Subject: Re: glob in Safe compartment allows shell access
+
+ I've moved the glob op into the same opcode tag as backticks and system
+ and added a comment.
+
+Index: gv.c
+
+ This patch changes neither behavior nor performance. However, it does
+ reduce code size and improve maintainability by combining some common
+ code in gv_fullname() and gv_efullname().
+
+Index: handy.h
+
+ Subject: Patch for LONG_MAX & co.
+
+ Sorry about adding yet another #ifdef forest, but hopefully this
+ should resolve the *_MAX issues permanently. It adds to the
+ previously defined PERL_LONG_MAX, PERL_LONG_MIN, and PERL_ULONG_MAX
+ symbols the complete set of
+ /PERL_U?(CHAR|SHORT|INT|LONG)_(MAX|MIN)/, and installs aliases to
+ those from /(I|U)(8|16|32|V)_(MAX|MIN)/ so that for any standard
+ Perl typedef, like I32 or UV, you can reference I32_MAX or UV_MIN,
+ and get appropriate figures. All references to LONG_(MIN|MAX) are
+ changed appropriately.
+
+ The .c changes have the side effect of making cast_uv properly use quad
+ limits if quads are in use, but longs aren't 64 bit. Hopefully this all
+ works, but I don't have any handy Crays to try it out on.
+
+ Add notes on perl's internal types, specifically Quad_t and IV.
+
+Index: hints/hpux.sh
+
+ Remove the d_bsdpgrp hint. The defaults should be ok.
+
+Index: hints/irix_6_2.sh
+
+ Change optimize=-g to optimize=none to avoid pulling in -DDEBUGGING,
+ unless that's what the user really wants.
+
+Index: hints/mpeix.sh
+
+ Change optimize=-g to optimize=none to avoid pulling in -DDEBUGGING,
+ unless that's what the user really wants.
+
+Index: hints/os2.sh
+
+ Fixes for sh vs. bin_sh + cleanup.
+
+Index: hints/ultrix_4.sh
+
+ Don't call optimize=-g, just call optimize=none. The -g
+ pulls in -DDEBUGGING, which might not be wanted.
+
+Index: lib/ExtUtils/MM_Unix.pm
+
+ .C$(obj_ext) removed under OS/2 - conflicts with .c$(obj_ext).
+
+Index: lib/ExtUtils/xsubpp
+
+ Fix SCOPE? (See pod/perlxs.pod).
+ Up version number to 1.938.
+
+Index: lib/Test/Harness.pm
+
+ Add a return value to runtests - non-zero if all tests ran ok,
+ zero otherwise.
+
+Index: lib/perl5db.pl
+
+ Ilya's debugger patch.
+ Undefined subroutine &Carp::longmess called at
+ /opt/perl5.003_03/lib/perl5db.pl line 1423.
+
+
+ Make perl5db compatible with the recent 'strict refs' enforcement
+ in %SIG.
+
+Index: malloc.c
+
+ A patch to perl5.003_02/malloc to give a sensible error abort() message
+ in ANSI C, and to give it to stderr instead of stdout.
+
+ Use config_h's STRINGIFY macro instead of pre-ANSI "p".
+
+Index: mg.c
+
+ Subject: FAKE typeglobs seriously busted (with patch)
+
+ Handling of fake typeglobs (scalars that are really globs
+ in disguise) is seriously busted since 5.002 (it wasn't
+ so in 5.001n).
+ The problem is that mg_get() on a glob calls gv_efullname()
+ which might coerce its first arg to a string.
+
+ Sub-critical patch to conceivably fix some %SIG problems. (Shared hash key
+ weren't being properly detected by some of the sig magic, but as shared
+ hash keys wouldn't normally be used in %SIG it's unlikely this is a
+ significant problem.)
+
+ This patch changes neither behavior nor performance. However, it does
+ reduce code size and improve maintainability by combining some common
+ code in gv_fullname() and gv_efullname().
+
+Index: myconfig
+
+ Update perlio-related variables.
+
+Index: op.c
+
+ This patch changes neither behavior nor performance. However, it does
+ reduce code size and improve maintainability by combining some common
+ code in gv_fullname() and gv_efullname().
+
+Index: opcode.h
+
+ Updated. See opcode.pl.
+
+Index: opcode.pl
+
+ Subject: Re: truncate with file name does not work (with patch)
+
+ The prototype for truncate was changed so that perl won't die
+ with C<use strict;> when the first arg is a bareword (filehandle).
+ I think it was Tom (as in "tchrist") who brought this up.
+
+ Here's a patch that undoes the damage, makes it work with
+ C<use strict;>, and adds to the testsuite.
+
+Index: os2/Makefile.SHs
+
+ perllib vs. LIBPERL
+
+Index: os2/diff.configure
+
+ Updated.
+
+Index: os2/os2.c
+
+ SH_PATH_INI vs. BIN_SH
+
+Index: os2/os2ish.h
+
+ SH_PATH_INI added (needed to redefine SH_PATH for binary
+ distribution).
+ SH_PATH is redefined.
+
+Index: patchlevel.h
+
+ SUBVERSION 4.
+
+Index: perl.h
+
+ Subject: Patch for LONG_MAX & co.
+
+ Sorry about adding yet another #ifdef forest, but hopefully this
+ should resolve the *_MAX issues permanently. It adds to the
+ previously defined PERL_LONG_MAX, PERL_LONG_MIN, and PERL_ULONG_MAX
+ symbols the complete set of
+ /PERL_U?(CHAR|SHORT|INT|LONG)_(MAX|MIN)/, and installs aliases to
+ those from /(I|U)(8|16|32|V)_(MAX|MIN)/ so that for any standard
+ Perl typedef, like I32 or UV, you can reference I32_MAX or UV_MIN,
+ and get appropriate figures. All references to LONG_(MIN|MAX) are
+ changed appropriately.
+
+ The .c changes have the side effect of making cast_uv properly use quad
+ limits if quads are in use, but longs aren't 64 bit. Hopefully this all
+ works, but I don't have any handy Crays to try it out on.
+
+ Add notes on perl's internal types, specifically Quad_t and IV.
+
+Index: perlio.c
+
+ Removes an incorrect prototype for setlinebuf from
+ perlio.c because it conflicts with the correct declaration in
+ MachTen's stdio.h (and possibly other stdio's as well).
+
+ Secondly, the code in perlio.c is not handling the (!PERLIO_IS_STDIO &
+ HAS_F[GS]ETPOS) case. The patch fixes this omission (in a rather lumpen
+ manner). I don't think this should affect platforms which try to hack a
+ different path through the #ifdef forest, but this assertion would benefit
+ from testing...
+
+ Dominic Dunlop
+
+Index: plan9/config.plan9
+
+ Updated.
+
+Index: plan9/fndvers
+
+ Updated.
+
+Index: plan9/mkfile
+
+ Updated.
+
+Index: plan9/setup.rc
+
+ Updated.
+
+Index: pod/perldiag.pod
+
+ Subject: lval substr() coredumps with refs (with patch)
+
+ substr() coredumps with a target that is a ref, when it is used in
+ an lvalue context.
+ The patch below corrects the problem by stringifying the reference
+ first (and emitting a warning when appropriate).
+
+Index: pod/perlxs.pod
+
+ document xsubpp SCOPE:
+
+Index: pp.c
+
+ Subject: lval substr() fails to clear lexicals in re-entered scopes (with patch)
+
+ substr() in lvalue context interacts in buggy fashion with SVs that
+ are !SvOK. This manifests itself with lexicals that have a REFCNT of
+ 1, since these are merely "cleared in place" by setting SvOK_off.
+
+ Subject: lval substr() coredumps with refs (with patch)
+
+ substr() coredumps with a target that is a ref, when it is used in
+ an lvalue context.
+ The patch below corrects the problem by stringifying the reference
+ first (and emitting a warning when appropriate).
+
+ Subject: Patch for LONG_MAX & co.
+
+Index: pp_ctl.c
+
+ This patch changes neither behavior nor performance. However, it does
+ reduce code size and improve maintainability by combining some common
+ code in gv_fullname() and gv_efullname().
+
+Index: pp_hot.c
+
+ Subject: Patch for LONG_MAX & co.
+
+ This patch changes neither behavior nor performance. However, it does
+ reduce code size and improve maintainability by combining some common
+ code in gv_fullname() and gv_efullname().
+
+Index: pp_sys.c
+
+ This patch changes neither behavior nor performance. However, it does
+ reduce code size and improve maintainability by combining some common
+ code in gv_fullname() and gv_efullname().
+
+Index: proto.h
+
+ This patch changes neither behavior nor performance. However, it does
+ reduce code size and improve maintainability by combining some common
+ code in gv_fullname() and gv_efullname().
+
+Index: run.c
+
+ This patch changes neither behavior nor performance. However, it does
+ reduce code size and improve maintainability by combining some common
+ code in gv_fullname() and gv_efullname().
+
+Index: sv.c
+
+ Subject: random cleanup
+
+ This patch removes a few obvious redundancies in the source.
+
+ Subject: sv_setsv patch
+
+ This patch changes neither behavior nor performance. However, it does
+ reduce code size and improve maintainability by combining some common
+ code in gv_fullname() and gv_efullname().
+
+ From: Chip Salzenberg
+ Subject: Track SVs for destruction when -DPURIFY
+
+ When checking for memory leaks, I compiled Perl with "-DPURIFY".
+ Although that flag improves the leak checking, it also breaks
+ destruction of global objects, because SVs aren't kept in captive
+ arenas any more.
+
+ This patch rectifies the problem by providing an alternative
+ method for keeping track of SVs when Perl is compiled for Purify.
+ It has no effect on normal operation.
+
+
+ Add comment about assert(len >=0) when len is unsigned anyway.
+
+Index: t/io/fs.t
+
+ Subject: Re: truncate with file name does not work (with patch)
+
+ The prototype for truncate was changed so that perl won't die
+ with C<use strict;> when the first arg is a bareword (filehandle).
+ I think it was Tom (as in "tchrist") who brought this up.
+
+ Here's a patch that undoes the damage, makes it work with
+ C<use strict;>, and adds to the testsuite.
+
+ The "not implemented" branch is missing a "\n".
+
+Index: t/op/gv.t
+
+ Subject: FAKE typeglobs seriously busted (with patch)
+
+ Handling of fake typeglobs (scalars that are really globs
+ in disguise) is seriously busted since 5.002 (it wasn't
+ so in 5.001n).
+
+ The problem is that mg_get() on a glob calls gv_efullname()
+ which might coerce its first arg to a string.
+
+Index: t/op/substr.t
+
+
+ Subject: lval substr() fails to clear lexicals in re-entered scopes (with patch)
+
+ substr() in lvalue context interacts in buggy fashion with SVs that
+ are !SvOK. This manifests itself with lexicals that have a REFCNT of
+ 1, since these are merely "cleared in place" by setting SvOK_off.
+
+ Subject: lval substr() coredumps with refs (with patch)
+
+ substr() coredumps with a target that is a ref, when it is used in
+ an lvalue context.
+ The patch below corrects the problem by stringifying the reference
+ first (and emitting a warning when appropriate).
+
+Index: toke.c
+
+ Subject: Re: truncate with file name does not work (with patch)
+
+ The prototype for truncate was changed so that perl won't die
+ with C<use strict;> when the first arg is a bareword (filehandle).
+ I think it was Tom (as in "tchrist") who brought this up.
+
+ Here's a patch that undoes the damage, makes it work with
+ C<use strict;>, and adds to the testsuite.
+
+Index: util.c
+
+ Subject: Re: Perl 5.003 dumps core executing caller() in signal handler for
+ __DIE__ (with patch)
+
+ sv_2pv() might call croak() (which is not prepared to handle that
+ when it calls sv_2pv(), itself). Likewise for warn() (but under
+ slightly more esoteric circumstances--mg_get() in sv_2pv() might
+ trigger a call to warn()).
+
+
+ Subject: Patch for LONG_MAX & co.
+
+ PERL_BADLANG is examined by default before issuing a warning during
+ internationalization.
+
+Index: utils/h2xs.PL
+
+ Make leading =head NAME item a paragraph so pod2man finds it.
+
+Index: utils/perldoc.PL
+
+ Use col -x to filter out half-line feeds (ESC-9) from
+ HP-UX nroff -man output. (col -x isn't portable -- SunOS
+ doesn't support the -x option.)
+
+
+----------------
+Version 5.003_03
+----------------
+
+Most of the changes in 5.003_03 are to make the build and installation
+process more robust. The details are described below. A very brief
+summary is:
+
+o Visible Changes to Core Functionality
+
+ -Support for tied filehandles.
+
+o Configure enhancements
+
+ -How to build and install a shared libperl.so is now documented
+ and supported, though it's not the default for most platforms.
+
+o Bug fixes
+
+ -Support bit operations on strings longer than 15 bytes.
+
+ -If a regex supplied to split() contains paranthesized subpatterns
+ that can result in null matches, perl no longer coredumps.
+
+ -Fix problems with each() on tied hashes.
+
+ -Make h2ph architecture-independent by using Config at run-time
+ rather than extraction time.
+
+o Specific Changes
+
+Here are the specific file-by-file changes.
+
+# This is my patch perl5.003_03.pat to perl5.003_02
+# The full description is below.
+# Please execute the following commands before applying this patch.
+# (You can feed this patch to 'sh' to do so.)
+# -- Andy Dougherty
+
+# Absorbed into Changes5.002
+rm -f Changes.Conf
+
+# Not needed.
+rm -f ext/POSIX/mkposixman.pl
+
+# Moved to README.os2. I'm not sure why the README files are
+# here rather than in the appropriate subdirectories.
+rm -f os2/README
+
+# Not needed.
+rm -f pod/Makefile.PL
+
+# New test for bit ops.
+touch t/op/bob.t
+
+# Patches that create new tests don't always make them executable.
+chmod +x t/*/*.t
+
+# Create a new directory for Porting and Patching info.
+mkdir Porting
+
+exit 0
+
+This is patch perl5.003_03.pat to perl version 5.003_02.
+This takes you from 5.003_02 to 5.003_03.
+
+To apply this patch, run the above commands,
+cd to your perl source directory and then type
+
+ patch -p1 -N < perl5.003_03.pat
+
+The changes are described after each /^Index/ line below. This is
+designed so you can examine each change with a command such as
+
+ csplit -k perl5.003_03.pat '/^Index:/' '{99}'
+
+Index: Changes
+
+ Include 5.003_03 change notes.
+
+ Move older change notes to separate files.
+
+Index: Changes5.000
+
+ New file. Changes from perl4.036 to 5.000.
+
+Index: Changes5.001
+
+ New file. Changes from 5.000 to 5.001
+
+Index: Changes5.002
+
+ New file. Changes from 5.001 to 5.002
+
+Index: Changes5.003
+
+ New file. Changes from 5.002 to 5.003
+
+Index: Configure
+
+ Relaxed warning about ksh on exotic machines.
+
+ Changed usesafe to useopcode.
+
+ Add search for gzip and zip.
+
+ Look more carefully for $sh (the Bourne-ish shell).
+ Use that info to set $startsh correctly.
+
+ Change prompts for PerlIO interface. See INSTALL
+ for how this is supposed to work. The default is
+ still the same as in 5.003_02, namely don't use
+ any fancy new PerlIO stuff.
+
+ Don't look for sigvec() since we don't actually use it.
+ (Plus, it used to print an alarming misleading message about
+ race conditions.)
+
+ Look for stdio's _filbuf under the possible names of
+ _filbuf, __filbuf, and _fill.
+
+ New $useshrplib variable to control whether we build a shared
+ libperl.so. The name of the library is in $libperl.
+ Always install it in $installarchlib/CORE/$libperl.
+
+ Check for <sys/resource.h> and <sys/wait.h> for NetBSD.
+
+ Replace old $altmake stuff with newer autoconf-ish
+ $make_set_make, which checks if $make sets $(MAKE). Now you
+ choose an alternate make with sh Configure -Dmake=gmake (or
+ whatever).
+
+ Remove 'ln' for the list of essential commands. Simulate
+ it with 'cp' if necessary.
+
+ Change `logname` prompts to handle extra gratuitous spaces in
+ Ultrix output.
+
+ Autodetect os2.
+
+ Fix silly bug in checking for fully-qualified names in /etc/hosts.
+
+ Generalize Gconvert tests. Give correct and more useful
+ error messages.
+
+ Use $obj_ext instead of literal '.o' in the dynaloader test.
+
+ Include appropriate header files in bcopy() and memcpy()
+ tests. Note whether memmove is available.
+
+ Check whether struct sigaction works (needed for Solaris 2.5
+ with -Xc).
+
+ Include appropriate header files for randbits test.
+
+Index: INSTALL
+
+ Add note about space requirements.
+
+ Update to match Configure changes (Opcode vs. Safe,
+ useperlio, useshrplib, etc.)
+
+ Reorganize the structure of some of the hints.
+
+ Miscellaneous clarifications.
+
+Index: MANIFEST
+
+ Updated. 5.003_02 introduced some massive patches, mostly
+ due to spacing changes. I didn't bother to sort them all out;
+ I just started with 5.003's MANIEFST.
+
+Index: Makefile.SH
+
+ Support the new simplified shared libperl mechanism.
+
+ Use new $make_set_make directive.
+
+ Remove redundant libperl Make variable.
+
+ Remove unnecessary MAB variable.
+
+ Remove dependency of minitest on lib/Config.pm, since it could
+ well have been a failure of configpm that inspired testing
+ miniperl in the first place!
+
+Index: Porting/Glossary
+
+ New file describing all the config.sh variables.
+ Eventually, I hope to fill this directory with other useful
+ stuff.
+
+Index: README.os2
+
+ Replace old README.os2 with more up-to-date os2/README.
+
+Index: config_H
+
+ Updated to match current Configure and config_h.SH.
+ Some rearrangement of parts has occurred due to new
+ dependencies in the metaconfig units.
+
+Index: config_h.SH
+
+ Updated to match current Configure and config_h.SH.
+ Some rearrangement of parts has occurred due to new
+ dependencies in the metaconfig units.
+
+ Include full descriptions of ARCHLIB, OLDARCHLIB, PRIVLIB,
+ SITEARCH, and SITELIB. Previous versions just included the
+ ~-expanded names (with unhelpful descriptions). No functionality
+ is changed, but maybe it's a little better documented now.
+
+Index: doio.c
+
+ Possibly Include <signal.h> and <unistd.h>
+
+Index: doop.c
+
+ No longer prefer bcmp over memcmp when order doesn't matter.
+
+ Support bit operations on strings longer than 15 bytes.
+
+Index: embed.h
+
+ Auto-generated.
+
+Index: embed.pl
+
+ Expand warning at the top.
+
+Index: ext/IO/IO.pm
+
+ Clean up docmentation installation errors.
+
+Index: ext/IO/lib/IO/Seekable.pm
+
+ Clean up docmentation installation errors.
+
+Index: ext/IO/lib/IO/Select.pm
+
+ Clean up docmentation installation errors.
+
+Index: ext/Opcode/Opcode.xs
+
+ Add support for tied filehandles.
+
+Index: ext/SDBM_File/sdbm/sdbm.h
+
+ Change the Mymalloc to match Perl_malloc in perl.h.
+
+Index: ext/util/make_ext
+
+ Typo change.
+ Get rid of unused altmake.
+
+Index: global.sym
+
+ Fix problems with each() on tied hashes.
+
+Index: handy.h
+
+ Change safe*alloc functions to have prototypes that
+ match the system's malloc and free types. That is, use
+ Malloc_t instead of char *, and Free_t instead of void.
+ This is necessary so . . .
+
+ Safefree cast matches type of free() whether it's perl's
+ malloc/free or the system's malloc/free.
+
+Index: hints/README.hints
+
+ Remove out-of-date info.
+
+ Document a bit about how hint files work.
+
+Index: hints/aix.sh
+
+ qmaxmem hint doesn't apply to gcc.
+
+Index: hints/dgux.sh
+
+ Configure will now automatically detect shared libperl stuff.
+
+Index: hints/dynixptx.sh
+
+ Fix typo in comment.
+
+ Configure will now automatically detect shared libperl stuff.
+
+Index: hints/epix.sh
+
+ Use glibpth instead of libpth. This allows Configure to
+ add local directories, such as /opt/local/lib, etc.
+
+Index: hints/irix_6_2.sh
+
+ Include some info on cc -n32 compile.
+
+Index: hints/linux.sh
+
+ Configure now tests gcvt() more thoroughly.
+
+Index: hints/machten_2.sh
+
+ Update where to find dld.
+
+Index: hints/mips.sh
+
+ Use glibpth instead of libpth.
+
+Index: hints/next_3.sh
+
+ Build up $mab dynamically. Since $mab isn't used anywhere
+ anymore, this is useless. However, $mab was never used for
+ next_3.sh anyway, so there's been no change in functionality.
+
+Index: hints/next_4.sh
+
+ Get rid of extraneous isnext_4 variable. Configure and
+ Makefile.SH will use $osname and $osvers instead.
+
+ Build up $mab dynamically based on available architectures.
+
+ Absorb $mab into ccflags and ccdlflags. I hope that will
+ cover everything. (Configure should automatically remove
+ the -arch stuff from cppflags.)
+
+ Configure now knows next4 needs to use a shared libperl.5.so.
+
+ Allow users to use -Dprefix.
+
+Index: hints/os2.sh
+
+ Try to update to reflect newer shared libperl stuff.
+ I probably goofed :-).
+
+Index: hints/sco.sh
+
+ Additional notes on using icc.
+
+ Additional flags for dynamic loading.
+
+Index: hints/solaris_2.sh
+
+ Perl.h no longer prefers bcmp, so it's again ok if Configure
+ finds them, since perl will prefer the mem* versions anyway.
+
+Index: hints/sunos_4_0.sh
+
+ Don't include <unistd.h>
+
+Index: hints/sunos_4_1.sh
+
+ Add brief note about GNU as and ld.
+
+ Don't include <unistd.h>
+
+ Add notes about WHOA THERE messages.
+
+Index: hints/titanos.sh
+
+ Include sfio in libswanted.
+
+ Don't set libpth any more.
+
+Index: hints/umips.sh
+
+ New hint file.
+
+Index: hv.c
+
+ Use memcmp even in cases where ordering doesn't matter.
+
+ Fix problems with each() on tied hashes.
+
+Index: installperl
+
+ Simplify installation of shared libperl.so.
+
+ Avoid reaching Command Failed!!! with /usr/bin/perl.
+
+Index: lib/AutoSplit.pm
+
+ Clean up docmentation installation errors.
+
+Index: lib/ExtUtils/MM_Unix.pm
+
+ Remove MAB references.
+
+ Use 'useshrplib' instead of 'd_shrplib'
+
+Index: lib/ExtUtils/MakeMaker.pm
+
+ Remove mab references.
+
+Index: lib/FindBin.pm
+
+ Clean up docmentation installation errors.
+
+Index: lib/Symbol.pm
+
+ Put back in the BEGIN { require 5.002; }. The version in
+ 5.003_02 wouldn't work in 5.002 anyway. Further, the whole
+ point of the construct is to catch 5.001m, so we can't use
+ syntax introduced after 5.001m to do that.
+
+Index: lib/Text/Wrap.pm
+
+ Remove double 'use strict'.
+
+Index: lib/perl5db.pl
+
+ Add explicit '&' to avoid warnings under strict refs.
+
+Index: lib/sigtrap.pm
+
+ Clean up docmentation installation errors.
+
+Index: makedepend.SH
+
+ Use Configure's $sh and $make_set_make variables.
+
+Index: mg.c
+
+ Include <unistd.h>
+
+ Use Safefree() macro instead of safefree() function with
+ a (possibly) incorrect cast. The whole point of the
+ Safefree() macro is that it does the correct cast for you.
+
+
+Index: patchlevel.h
+
+ Change to SUBVERSION 3.
+
+Index: perl.c
+
+ Include <unistd.h>
+
+Index: perl.h
+
+ No longer prefer bcmp slightly for comparisons that don't care
+ about ordering.
+
+ Rely on Configure setting SH_PATH.
+
+ Change the function name to Pause() instead of pause() to
+ avoid potential prototype problems. (This naming convention
+ is similar to the Fwrite and Fflush macros.)
+
+ Fix problems with each() on tied hashes.
+
+ Work around crypt prototype problem on NeXT.
+
+Index: perlio.c
+
+ Fixes to support non-std stdio.
+
+Index: perlio.h
+
+ Try to document the various #defines a bit. This is far from
+ finished.
+
+ Remove a lot of trailing whitespace. (It's of no consequence, but
+ but I'm not going to redo the patch just to put back in the trailing
+ whitespace either.)
+
+Index: perlsdio.h
+
+ Fixes to support non-std stdio.
+
+Index: perly.c
+
+ Restore use of Safefree() macro.
+
+Index: perly.c.diff
+
+ Restore use of Safefree() macro.
+
+Index: perly.h
+
+ Delete duplicate line.
+
+Index: plan9/buildinfo
+
+ Update.
+
+Index: pod/perlapio.pod
+
+ Clean up docmentation installation errors.
+
+Index: pod/perlipc.pod
+
+ Fix typo.
+
+ Untaint port number.
+
+Index: pod/perlmod.pod
+
+ Fix a minor nit regarding Exporter.
+
+Index: pod/perlre.pod
+
+ Clean up docmentation installation errors.
+
+Index: pod/perltie.pod
+
+ Add support for tied filehandles.
+
+Index: pod/perltrap.pod
+
+ Clean up docmentation installation errors.
+
+Index: pod/perlxstut.pod
+
+ Clean up docmentation installation errors.
+
+Index: pod/pod2man.PL
+
+ Clean up docmentation installation errors.
+
+Index: pp.c
+
+ Add support for tied filehandles.
+
+ If a regex supplied to split() contains paranthesized subpatterns
+ that can result in null matches, perl coredumps.
+
+Index: pp_hot.c
+
+ Use memcmp instead of bcmp even when we don't care about order.
+
+ Add support for tied filehandles.
+
+Index: pp_sys.c
+
+ Include <unistd.h>, <sys/wait.h>, and <sys/resource.h>.
+ (The latter two are especially for NetBSD.)
+
+ Don't assume sys/time.h and sys/select.h can't coexist.
+
+ Use Pause macro.
+
+Index: proto.h
+
+ Fix safe*alloc and safefree prototypes.
+
+Index: regexec.c
+
+ Use memcmp instead of bcmp even when we don't care about order.
+
+Index: sv.c
+
+ Use memcmp instead of bcmp even when we don't care about order.
+
+Index: t/lib/opcode.t
+
+ Add support for tied filehandles.
+
+Index: t/op/bop.t
+
+ Support bit operations on strings longer than 15 bytes.
+
+Index: t/op/misc.t
+
+ Add support for tied filehandles.
+
+Index: t/op/split.t
+
+ If a regex supplied to split() contains paranthesized subpatterns
+ that can result in null matches, perl coredumps.
+
+Index: toke.c
+
+ Include <unistd.h>.
+
+ Use memcmp instead of bcmp even when we don't care about order.
+
+Index: util.c
+
+ Include <unistd.h>.
+
+ Use correct types for safe*alloc and safefree functions.
+
+Index: utils/h2ph.PL
+
+ Make h2ph architecture-independent by using Config at run-time
+ rather than extraction time.
+
+Index: writemain.SH
+
+ Remove unnecessary curlies. (They are a leftover from
+ an older auto_init mechanism.)
+
+Index: x2p/Makefile.SH
+
+ Use Configure's $sh and $make_set_make.
+
+ Remove MAB stuff, since it's now in ccflags.
+
+ Keep 5.003's RCS info.
+
+Index: x2p/a2p.h
+
+ Keep 5.003's RCS info.
+
+Index: x2p/str.c
+
+ Use Configure's FILE_filbuf macro instead of a raw _filbuf.
+
+
+----------------
+Version 5.003_02
+----------------
+
+o Visible Changes to Core Functionality
+ - Redefining constant subs, or changing sub's prototype now give warnings.
+ - Fixes for ++/-- of values close to max/min size of an integer
+ - Warning for un-qualified bareword as handler in $SIG{}.
+ - UNIVERSAL::isa can now be called as static method.
+
+o Changes in Core Internals
+ - PerlIO abstraction added.
+ Perl core and standard extensions no longer assume ANSI C's stdio is IO
+ mechanism, Default Configure mode is still to use stdio via set of C macros.
+ Alternate modes are to use stdio via one perlio.c module, or
+ to use sfio if available.
+
+ - Several bug fixs from perl5-porters
+ - Make sources non-ANSI C correct again.
+ - SUPER in gv.c
+ - Last of shared-hash-key patches
+ - eval '(0,1..3)'; # --> SegFault
+ - coredumps after simple subsitutes.
+ - Correction to UNIVERSAL::VERSION docs.
+ - Fixed io_udp test.
+ - Fixed another abuse of malloc'ed memory.
+ - Enabled DEBUGING_MSTATS whenever perl's malloc() is used.
+ - Reverted to default of not hiding perl's malloc (if used).
+
+o Changes in the Standard Library and Utilities
+ - Fixed MakeMaker for static SDBM and builing in a link tree.
+ - Upgraded to IO-1.09, and includes latest (still experimental) IO::Select.
+ - Documentation/test tweak to DB_File
+ - h2xs upgrade to allow use C::Scan module
+
+o Changes in OS-specific and Build-time Support
+ - Attempted to re-created 5.003_01's NeXT support with metaconfig units.
+ - Updated MANIFEST
+ - make minitest now depends on lib/Config.pm, as some of tests require it.
+ - Included latest plan9 sub-directory
+ - Applied OS/2 patches.
+ - Typo patch for VMS.
+
+
+----------------
+Version 5.003_01
+----------------
+
+Version 5.003_01 contains bugfixes and additions accumulated since
+version 5.002_01, since the patch to version 5.003 was deliberately
+kept simple. In addition to numerous small bugfixes in the core,
+library files, and documentation, this patch contains several
+significant revisions, summarized below:
+
+o Visible Changes to Core Functionality
+
+ - A port to Plan9 has been started, and changes are integrated into
+ the standard distribution. As of this release, the Perl core
+ and several common extensions are working.
+
+ - A set of basic methods in the UNIVERSAL class have been added to
+ the Perl core. Since UNIVERSAL is an implicit member of every
+ class's @ISA, the methods can be called via any object.
+
+ - A mandatory warning has been added for 'declarations' of lexical
+ variables using the "my" operator which mask an existing lexical
+ variable declared in the same scope, making the previous variable
+ inaccessible by its name.
+
+ - The "use" and "require" operators have been extended to allow
+ checking of the required module's version. The "use" operator
+ can now be used for an immediate version check of Perl itself.
+
+ - A new "strict" pragma, "strict untie", has been added, which
+ produces an error if a tied value is untied when other references
+ exist to the internal object implementing the tie.
+
+ - Barewords used as associative array keys (i.e. when specifying
+ an associative array element like $foo{__BAR} or on the left
+ side of the => operator) may now begin with an underscore as
+ well as an alphabetic character.
+
+ - Some of the configuration information previously produced by the
+ -v switch has been moved to the -V switch, in order to keep -v
+ output concise.
+
+o Changes in Core Internals
+
+ - Symbol table and method lookups have been made faster.
+
+ - Perl subroutines which just return a constant value are now
+ optimized at compile time into inline constants.
+
+ - Management of keys for associative arrays has been improved to
+ conserve space when the same keys are reused frequently, and
+ to pass true Perl values to tie functions, instead of stringified
+ representations.
+
+ - Messages normally output to stderr may be directed to another
+ stream when Perl is built. This allows some platforms to
+ present diagnostic output in a separate window from normal
+ program results.
+
+ - A bug which caused suiperl to fail silently, albeit securely,
+ in version 5.003 on some systems has been fixed.
+
+ - Management of Unix-style signal handlers via the %SIG associative
+ array has been made safer.
+
+ - Several global C symbols have been renamed to eliminate collisions
+ with system C header files or libraries on some platforms.
+ Unfortunately, this means that dynamic extensions compiled under
+ previous versions of Perl will need to be rebuilt for Perl
+ 5.003_01. We're in the process of cleaning up Perl's C
+ namespace to make it easier to link Perl with other binaries,
+ so this will probably happen again between now and version 5.004.
+ After that, we'll do our best to maintain binary compatibility
+ between versions.
+
+ - An alternate allocation strategy has been added to Perl's
+ optional private memory management routines. This strategy,
+ which may be selected when Perl is built, is designed to
+ conserve memory in programs which allocate many small
+ chunks of memory with sizes near a power of 2, as is often
+ the case in Perl programs.
+
+ - Several memory leaks in the creation and destruction of
+ multiple interpreters have been fixed.
+
+o Changes in the Standard Library and Utilities
+
+ - The Opcode extension, which allows you to control a program's
+ access to Perl operations, has been added to the standard
+ distribution. This extends the work begun in the original
+ Safe extension, and subsumes it. The Safe interface is still
+ available.
+
+ - The IO extension, which provides a set of classes for object-
+ oriented handling of common I/O tasks, has been added to the
+ standard distribution. The IO classes will form the basis
+ for future development of Perl's I/O interface, and will
+ subsume the FileHandle class in the near future. The default
+ class to which all Perl I/O handles belong is now IO::Handle,
+ rather than FileHandle.
+
+ - The ExtUtils::Embed library module, which provides a set
+ of utility function to help in embedding Perl in other
+ applications, has been added to the standard distribution.
+
+ - The Fatal library module, which provides a simple interface
+ for creating "do-or-die" equivalents of existing functions,
+ has been added to the standard distribution.
+
+ - The FindBin library module, which determines the full path
+ to the currently executing program, has been added to the
+ standard distribution.
+
+ - The DB_File extension, and the Getopt::Long, Test::Harness,
+ Text::Tabs, Text::Wrap, Time::Local and sigtrap library modules
+ have been updated to the authors' latest versions.
+
+ - The Carp library module now considers the @ISA chain when
+ determining the caller's package for inclusion in error messages.
+
+ - The h2xs, perlbug, and xsubpp utilities have been updated.
+
+ - The standard Perl debugger has been updated, and the information
+ provided to the debugger when an XSUB is called has been improved,
+ making it possible for alternate debuggers (such as Devel::DProf)
+ to do a better job of tracking XSUB calls.
+
+ - The pod documentation formatting tools in the standard distribution
+ can now handle characters in the input stream whose high bit is set.
+
+ - The cperl-mode EMACS editing mode has been updated.
+
+o Changes in Documentation
+
+ - Typographic and formatting errors have been corrected in the pod
+ documentation for the core and standard library files
+
+ - Explanations of several core operators have been improved
+
+ - The perldebug, perlembed, perlipc, perlsec, and perltrap documents
+ extensively revised.
+
+o Changes in OS-specific and Build-time Support
+
+ - Support for the NeXT platform has been extended through
+ NeXTSTEP/OPENSTEP 4.0, and now includes the ability to create MABs.
+
+ - Support for OS/2 has been extended as well, and now includes
+ options for building a.out binaries.
+
+ - Support for VMS has also been extended, incorporating improved
+ processing of file specification strings, optional suppression of
+ carriage control interpretation for record-structured files,
+ improved support for the -S command line switch, a number of
+ VMS-specific bugfixes, and significantly improved performance
+ in line-oriented reading of files.
+
+ - Several hints files have been added or updated: aux.sh (updated),
+ convexos.sh (updated), irix_4.sh (updated), irix_5.sh (updated),
+ irix_6_2.sh (updated), next_3.sh (updated), next_3_2.sh (new),
+ next_3_3.sh (new), next_4.sh (new), os2/sh (updated),
+ sco.sh (updated), and solaris_2.sh (updated).
+
+ - The test driver for the regression tests now reports when a set
+ of tests have been skipped (presumable because the operation
+ they're designed to test isn't supported on the current system).
diff --git a/contrib/perl5/Configure b/contrib/perl5/Configure
new file mode 100755
index 000000000000..bc5c59d5f1c3
--- /dev/null
+++ b/contrib/perl5/Configure
@@ -0,0 +1,12126 @@
+#! /bin/sh
+#
+# If these # comments don't work, trim them. Don't worry about any other
+# shell scripts, Configure will trim # comments from them for you.
+#
+# (If you are trying to port this package to a machine without sh,
+# I would suggest you have a look at the prototypical config_h.SH file
+# and edit it to reflect your system. Some packages may include samples
+# of config.h for certain machines, so you might look for one of those.)
+#
+# Yes, you may rip this off to use in other distribution packages. This
+# script belongs to the public domain and cannot be copyrighted.
+#
+# (Note: this Configure script was generated automatically. Rather than
+# working with this copy of Configure, you may wish to get metaconfig.
+# The dist-3.0 package (which contains metaconfig) was posted in
+# comp.sources.misc and is available on CPAN under authors/id/RAM so
+# you may fetch it yourself from your nearest archive site.)
+#
+
+# $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $
+#
+# Generated on Tue Jul 7 10:10:21 EDT 1998 [metaconfig 3.0 PL70]
+# (with additional metaconfig patches by doughera@lafayette.edu)
+
+cat >/tmp/c1$$ <<EOF
+ARGGGHHHH!!!!!
+
+SCO csh still thinks true is false. Write to SCO today and tell them that next
+year Configure ought to "rm /bin/csh" unless they fix their blasted shell. :-)
+
+(Actually, Configure ought to just patch csh in place. Hmm. Hmmmmm. All
+we'd have to do is go in and swap the && and || tokens, wherever they are.)
+
+[End of diatribe. We now return you to your regularly scheduled programming...]
+EOF
+cat >/tmp/c2$$ <<EOF
+
+OOPS! You naughty creature! You didn't run Configure with sh!
+I will attempt to remedy the situation by running sh for you...
+EOF
+
+true || cat /tmp/c1$$ /tmp/c2$$
+true || exec sh $0 $argv:q
+
+(exit $?0) || cat /tmp/c2$$
+(exit $?0) || exec sh $0 $argv:q
+rm -f /tmp/c1$$ /tmp/c2$$
+
+: compute my invocation name
+me=$0
+case "$0" in
+*/*)
+ me=`echo $0 | sed -e 's!.*/\(.*\)!\1!' 2>/dev/null`
+ test "$me" || me=$0
+ ;;
+esac
+
+: the newline for tr
+if test X"$trnl" = X; then
+ case "`echo foo|tr '\n' x 2>/dev/null`" in
+ foox)
+ trnl='\n'
+ ;;
+ esac
+fi
+if test X"$trnl" = X; then
+ case "`echo foo|tr '\012' x 2>/dev/null`" in
+ foox)
+ trnl='\012'
+ ;;
+ esac
+fi
+if test -n "$DJGPP"; then
+ trnl='\012'
+fi
+if test X"$trnl" = X; then
+ cat <<EOM >&2
+
+$me: Fatal Error: cannot figure out how to translate newlines with 'tr'.
+
+EOM
+ exit 1
+fi
+
+: Proper separator for the PATH environment variable
+p_=:
+: On OS/2 this directory should exist if this is not floppy only system :-]
+if test -d c:/. ; then
+ if test -n "$OS2_SHELL"; then
+ p_=\;
+ PATH=`cmd /c "echo %PATH%" | tr '\\\\' / `
+ OS2_SHELL=`cmd /c "echo %OS2_SHELL%" | tr '\\\\' / | tr '[A-Z]' '[a-z]'`
+ elif test -n "$DJGPP"; then
+ p_=\;
+ fi
+fi
+
+: Proper PATH setting
+paths='/bin /usr/bin /usr/local/bin /usr/ucb /usr/local /usr/lbin'
+paths="$paths /opt/bin /opt/local/bin /opt/local /opt/lbin"
+paths="$paths /usr/5bin /etc /usr/gnu/bin /usr/new /usr/new/bin /usr/nbin"
+paths="$paths /opt/gnu/bin /opt/new /opt/new/bin /opt/nbin"
+paths="$paths /sys5.3/bin /sys5.3/usr/bin /bsd4.3/bin /bsd4.3/usr/ucb"
+paths="$paths /bsd4.3/usr/bin /usr/bsd /bsd43/bin /usr/ccs/bin"
+paths="$paths /etc /usr/lib /usr/ucblib /lib /usr/ccs/lib"
+paths="$paths /sbin /usr/sbin /usr/libexec"
+
+for p in $paths
+do
+ case "$p_$PATH$p_" in
+ *$p_$p$p_*) ;;
+ *) test -d $p && PATH=$PATH$p_$p ;;
+ esac
+done
+
+PATH=.$p_$PATH
+export PATH
+
+: shall we be using ksh?
+inksh=''
+needksh=''
+avoidksh=''
+newsh=/bin/ksh
+changesh=''
+if (PATH=.; alias -x) >/dev/null 2>&1; then
+ inksh=true
+fi
+if test -f /hp-ux -a -f /bin/ksh; then
+ needksh='to avoid sh bug in "here document" expansion'
+fi
+if test -d /usr/lpp -a -f /usr/bin/bsh -a -f /usr/bin/uname; then
+ if test X`/usr/bin/uname -v` = X4; then
+ avoidksh="to avoid AIX 4's /bin/sh"
+ newsh=/usr/bin/bsh
+ fi
+fi
+case "$inksh/$needksh" in
+/[a-z]*)
+ ENV=''
+ changesh=true
+ reason="$needksh"
+ ;;
+esac
+case "$inksh/$avoidksh" in
+true/[a-z]*)
+ changesh=true
+ reason="$avoidksh"
+ ;;
+esac
+case "$inksh/$needksh-$avoidksh-" in
+true/--)
+ cat <<EOM
+(I see you are using the Korn shell. Some ksh's blow up on $me,
+mainly on older exotic systems. If yours does, try the Bourne shell instead.)
+EOM
+ ;;
+esac
+case "$changesh" in
+true)
+ echo "(Feeding myself to $newsh $reason.)"
+ case "$0" in
+ Configure|*/Configure) exec $newsh $0 "$@";;
+ *) exec $newsh Configure "$@";;
+ esac
+ ;;
+esac
+
+: if needed set CDPATH to a harmless value that is not chatty
+: avoid bash 2.02 problems with empty CDPATH.
+case "$CDPATH" in
+'') ;;
+*) case "$SHELL" in
+ *bash*) CDPATH='.' ;;
+ *) CDPATH='' ;;
+ esac
+ ;;
+esac
+: Configure runs within the UU subdirectory
+test -d UU || mkdir UU
+cd UU && rm -f ./*
+
+dynamic_ext=''
+extensions=''
+known_extensions=''
+nonxs_ext=''
+static_ext=''
+useopcode=''
+useposix=''
+d_bsd=''
+d_eunice=''
+d_xenix=''
+eunicefix=''
+Mcc=''
+ar=''
+awk=''
+bash=''
+bison=''
+byacc=''
+cat=''
+chgrp=''
+chmod=''
+chown=''
+comm=''
+compress=''
+cp=''
+cpio=''
+cpp=''
+csh=''
+date=''
+echo=''
+egrep=''
+emacs=''
+expr=''
+find=''
+flex=''
+grep=''
+gzip=''
+inews=''
+ksh=''
+less=''
+line=''
+lint=''
+ln=''
+lp=''
+lpr=''
+ls=''
+mail=''
+mailx=''
+make=''
+mkdir=''
+more=''
+mv=''
+nm=''
+nroff=''
+perl=''
+pg=''
+pmake=''
+pr=''
+rm=''
+rmail=''
+sed=''
+sendmail=''
+shar=''
+sleep=''
+smail=''
+sort=''
+submit=''
+tail=''
+tar=''
+tbl=''
+tee=''
+test=''
+touch=''
+tr=''
+troff=''
+uname=''
+uniq=''
+uuname=''
+vi=''
+zcat=''
+zip=''
+full_sed=''
+libswanted=''
+hint=''
+myuname=''
+osname=''
+osvers=''
+Author=''
+Date=''
+Header=''
+Id=''
+Locker=''
+Log=''
+RCSfile=''
+Revision=''
+Source=''
+State=''
+_a=''
+_exe=''
+_o=''
+archobjs=''
+exe_ext=''
+firstmakefile=''
+lib_ext=''
+obj_ext=''
+path_sep=''
+afs=''
+alignbytes=''
+ansi2knr=''
+archlib=''
+archlibexp=''
+d_archlib=''
+installarchlib=''
+archname=''
+myarchname=''
+baserev=''
+bin=''
+binexp=''
+installbin=''
+byteorder=''
+cc=''
+gccversion=''
+ccflags=''
+cppflags=''
+ldflags=''
+lkflags=''
+locincpth=''
+optimize=''
+cf_email=''
+cf_by=''
+cf_time=''
+contains=''
+cpp_stuff=''
+cpplast=''
+cppminus=''
+cpprun=''
+cppstdin=''
+d_access=''
+d_alarm=''
+d_attribut=''
+d_bcmp=''
+d_bcopy=''
+d_bzero=''
+d_casti32=''
+castflags=''
+d_castneg=''
+d_chown=''
+d_chroot=''
+d_chsize=''
+d_closedir=''
+d_void_closedir=''
+d_const=''
+cryptlib=''
+d_crypt=''
+d_csh=''
+full_csh=''
+d_cuserid=''
+d_dbl_dig=''
+d_difftime=''
+d_dlerror=''
+d_dlopen=''
+d_dlsymun=''
+d_dosuid=''
+d_suidsafe=''
+d_dup2=''
+d_endhent=''
+d_endnent=''
+d_endpent=''
+d_endsent=''
+d_fchmod=''
+d_fchown=''
+d_fcntl=''
+d_fd_macros=''
+d_fd_set=''
+d_fds_bits=''
+d_fgetpos=''
+d_flexfnam=''
+d_flock=''
+d_fork=''
+d_fsetpos=''
+d_ftime=''
+d_gettimeod=''
+d_Gconvert=''
+d_getgrps=''
+d_gethbyaddr=''
+d_gethbyname=''
+d_gethent=''
+aphostname=''
+d_gethname=''
+d_phostname=''
+d_uname=''
+d_gethostprotos=''
+d_getlogin=''
+d_getnbyaddr=''
+d_getnbyname=''
+d_getnent=''
+d_getnetprotos=''
+d_getpent=''
+d_getpgid=''
+d_getpgrp2=''
+d_bsdgetpgrp=''
+d_getpgrp=''
+d_getppid=''
+d_getprior=''
+d_getpbyname=''
+d_getpbynumber=''
+d_getprotoprotos=''
+d_getsent=''
+d_getservprotos=''
+d_getsbyname=''
+d_getsbyport=''
+d_gnulibc=''
+i_arpainet=''
+d_htonl=''
+d_inetaton=''
+d_isascii=''
+d_killpg=''
+d_lchown=''
+d_link=''
+d_locconv=''
+d_lockf=''
+d_longdbl=''
+longdblsize=''
+d_longlong=''
+longlongsize=''
+d_lstat=''
+d_mblen=''
+d_mbstowcs=''
+d_mbtowc=''
+d_memcmp=''
+d_memcpy=''
+d_memmove=''
+d_memset=''
+d_mkdir=''
+d_mkfifo=''
+d_mktime=''
+d_msg=''
+d_msgctl=''
+d_msgget=''
+d_msgrcv=''
+d_msgsnd=''
+d_nice=''
+d_open3=''
+d_fpathconf=''
+d_pathconf=''
+d_pause=''
+d_pipe=''
+d_poll=''
+d_portable=''
+d_pthread_yield=''
+d_sched_yield=''
+d_pthreads_created_joinable=''
+d_readdir=''
+d_rewinddir=''
+d_seekdir=''
+d_telldir=''
+d_readlink=''
+d_rename=''
+d_rmdir=''
+d_safebcpy=''
+d_safemcpy=''
+d_sanemcmp=''
+d_select=''
+d_sem=''
+d_semctl=''
+d_semget=''
+d_semop=''
+d_setegid=''
+d_seteuid=''
+d_setgrps=''
+d_sethent=''
+d_setlinebuf=''
+d_setlocale=''
+d_setnent=''
+d_setpent=''
+d_setpgid=''
+d_setpgrp2=''
+d_bsdsetpgrp=''
+d_setpgrp=''
+d_setprior=''
+d_setregid=''
+d_setresgid=''
+d_setresuid=''
+d_setreuid=''
+d_setrgid=''
+d_setruid=''
+d_setsent=''
+d_setsid=''
+d_setvbuf=''
+d_sfio=''
+usesfio=''
+d_shm=''
+d_shmat=''
+d_shmatprototype=''
+shmattype=''
+d_shmctl=''
+d_shmdt=''
+d_shmget=''
+d_sigaction=''
+d_sigsetjmp=''
+d_oldsock=''
+d_socket=''
+d_sockpair=''
+sockethdr=''
+socketlib=''
+d_statblks=''
+d_stdio_cnt_lval=''
+d_stdio_ptr_lval=''
+d_stdiobase=''
+d_stdstdio=''
+stdio_base=''
+stdio_bufsiz=''
+stdio_cnt=''
+stdio_filbuf=''
+stdio_ptr=''
+d_index=''
+d_strchr=''
+d_strcoll=''
+d_strctcpy=''
+d_strerrm=''
+d_strerror=''
+d_sysernlst=''
+d_syserrlst=''
+d_strtod=''
+d_strtol=''
+d_strtoul=''
+d_strxfrm=''
+d_symlink=''
+d_syscall=''
+d_sysconf=''
+d_system=''
+d_tcgetpgrp=''
+d_tcsetpgrp=''
+d_time=''
+timetype=''
+clocktype=''
+d_times=''
+d_truncate=''
+d_tzname=''
+d_umask=''
+d_semctl_semid_ds=''
+d_semctl_semun=''
+d_union_semun=''
+d_vfork=''
+usevfork=''
+d_voidsig=''
+signal_t=''
+d_volatile=''
+d_charvspr=''
+d_vprintf=''
+d_wait4=''
+d_waitpid=''
+d_wcstombs=''
+d_wctomb=''
+dlext=''
+cccdlflags=''
+ccdlflags=''
+dlsrc=''
+ld=''
+lddlflags=''
+usedl=''
+doublesize=''
+fpostype=''
+gidtype=''
+groupstype=''
+h_fcntl=''
+h_sysfile=''
+db_hashtype=''
+db_prefixtype=''
+i_db=''
+i_dbm=''
+i_rpcsvcdbm=''
+d_dirnamlen=''
+direntrytype=''
+i_dirent=''
+i_dld=''
+i_dlfcn=''
+i_fcntl=''
+i_float=''
+i_gdbm=''
+d_grpasswd=''
+d_setgrent=''
+d_getgrent=''
+d_endgrent=''
+i_grp=''
+i_limits=''
+i_locale=''
+i_malloc=''
+i_math=''
+i_memory=''
+i_ndbm=''
+i_netdb=''
+i_neterrno=''
+i_niin=''
+i_sysin=''
+d_pwage=''
+d_pwchange=''
+d_pwclass=''
+d_pwcomment=''
+d_pwexpire=''
+d_pwgecos=''
+d_pwpasswd=''
+d_pwquota=''
+d_setpwent=''
+d_getpwent=''
+d_endpwent=''
+i_pwd=''
+i_sfio=''
+i_stddef=''
+i_stdlib=''
+i_string=''
+strings=''
+i_sysdir=''
+i_sysfile=''
+d_voidtty=''
+i_bsdioctl=''
+i_sysfilio=''
+i_sysioctl=''
+i_syssockio=''
+i_sysndir=''
+i_sysparam=''
+i_sysresrc=''
+i_sysselct=''
+i_sysstat=''
+i_systimes=''
+i_systypes=''
+i_sysun=''
+i_syswait=''
+i_sgtty=''
+i_termio=''
+i_termios=''
+i_systime=''
+i_systimek=''
+i_time=''
+timeincl=''
+i_unistd=''
+i_utime=''
+i_values=''
+i_stdarg=''
+i_varargs=''
+i_varhdr=''
+i_vfork=''
+intsize=''
+longsize=''
+shortsize=''
+libc=''
+libperl=''
+shrpenv=''
+useshrplib=''
+glibpth=''
+libpth=''
+loclibpth=''
+plibpth=''
+xlibpth=''
+libs=''
+lns=''
+lseektype=''
+make_set_make=''
+d_mymalloc=''
+freetype=''
+mallocobj=''
+mallocsrc=''
+malloctype=''
+usemymalloc=''
+installman1dir=''
+man1dir=''
+man1direxp=''
+man1ext=''
+installman3dir=''
+man3dir=''
+man3direxp=''
+man3ext=''
+huge=''
+large=''
+medium=''
+models=''
+small=''
+split=''
+modetype=''
+mydomain=''
+myhostname=''
+phostname=''
+c=''
+n=''
+d_eofnblk=''
+eagain=''
+o_nonblock=''
+rd_nodata=''
+netdb_hlen_type=''
+netdb_host_type=''
+netdb_name_type=''
+netdb_net_type=''
+groupcat=''
+hostcat=''
+passcat=''
+orderlib=''
+ranlib=''
+package=''
+spackage=''
+pager=''
+apiversion=''
+patchlevel=''
+subversion=''
+version=''
+perladmin=''
+perlpath=''
+pidtype=''
+prefix=''
+prefixexp=''
+installprivlib=''
+privlib=''
+privlibexp=''
+prototype=''
+ptrsize=''
+randbits=''
+installscript=''
+scriptdir=''
+scriptdirexp=''
+selecttype=''
+sh=''
+sig_name=''
+sig_name_init=''
+sig_num=''
+installsitearch=''
+sitearch=''
+sitearchexp=''
+installsitelib=''
+sitelib=''
+sitelibexp=''
+sizetype=''
+so=''
+sharpbang=''
+shsharp=''
+spitshell=''
+src=''
+ssizetype=''
+startperl=''
+startsh=''
+stdchar=''
+sysman=''
+uidtype=''
+nm_opt=''
+nm_so_opt=''
+runnm=''
+usenm=''
+useperlio=''
+d_oldpthreads=''
+usethreads=''
+incpath=''
+mips=''
+mips_type=''
+usrinc=''
+defvoidused=''
+voidflags=''
+ebcdic=''
+CONFIG=''
+
+define='define'
+undef='undef'
+smallmach='pdp11 i8086 z8000 i80286 iAPX286'
+rmlist=''
+
+: We must find out about Eunice early
+eunicefix=':'
+if test -f /etc/unixtovms; then
+ eunicefix=/etc/unixtovms
+fi
+if test -f /etc/unixtovms.exe; then
+ eunicefix=/etc/unixtovms.exe
+fi
+
+: list of known cpp symbols, sorted alphabetically
+al="AMIX BIT_MSF BSD BSD4_3 BSD_NET2 CMU CRAY DGUX DOLPHIN DPX2"
+al="$al GO32 GOULD_PN HP700 I386 I80960 I960 Lynx M68000 M68K MACH"
+al="$al MIPSEB MIPSEL MSDOS MTXINU MULTIMAX MVS"
+al="$al M_COFF M_I186 M_I286 M_I386 M_I8086 M_I86 M_I86SM"
+al="$al M_SYS3 M_SYS5 M_SYSIII M_SYSV M_UNIX M_XENIX"
+al="$al NeXT OCS88 OSF1 PARISC PC532 PORTAR POSIX"
+al="$al PWB R3000 RES RISC6000 RT Sun386i SVR3 SVR4"
+al="$al SYSTYPE_BSD SYSTYPE_SVR4 SYSTYPE_SYSV Tek4132 Tek4300"
+al="$al UMAXV USGr4 USGr4_2 UTEK UTS UTek UnicomPBB UnicomPBD Utek"
+al="$al VMS Xenix286"
+al="$al _AIX _AIX32 _AIX370 _AIX41 _AM29000 _COFF _CRAY _CX_UX _EPI _POWER"
+al="$al _IBMESA _IBMR2 _M88K _M88KBCS_TARGET"
+al="$al _MIPSEB _MIPSEL _M_COFF _M_I86 _M_I86SM _M_SYS3"
+al="$al _M_SYS5 _M_SYSIII _M_SYSV _M_UNIX _M_XENIX _NLS _PGC_ _R3000"
+al="$al _SYSTYPE_BSD _SYSTYPE_BSD43 _SYSTYPE_SVR4"
+al="$al _SYSTYPE_SYSV _SYSV3 _U370 _UNICOS"
+al="$al __386BSD__ __BIG_ENDIAN __BIG_ENDIAN__ __BSD_4_4__"
+al="$al __DGUX__ __DPX2__ __H3050R __H3050RX"
+al="$al __LITTLE_ENDIAN __LITTLE_ENDIAN__ __MACH__"
+al="$al __MIPSEB __MIPSEB__ __MIPSEL __MIPSEL__"
+al="$al __Next__ __OSF1__ __PARAGON__ __PGC__ __PWB __STDC__"
+al="$al __SVR4_2__ __UMAXV__"
+al="$al ____386BSD____ __alpha __alpha__ __amiga"
+al="$al __bsd4_2 __bsd4_2__ __bsdi__ __convex__"
+al="$al __host_mips__"
+al="$al __hp9000s200 __hp9000s300 __hp9000s400 __hp9000s500"
+al="$al __hp9000s500 __hp9000s700 __hp9000s800"
+al="$al __hppa __hpux __hp_osf __i286 __i286__ __i386 __i386__"
+al="$al __i486 __i486__ __i860 __i860__ __ibmesa __ksr1__ __linux__"
+al="$al __m68k __m68k__ __m88100__ __m88k __m88k__"
+al="$al __mc68000 __mc68000__ __mc68020 __mc68020__"
+al="$al __mc68030 __mc68030__ __mc68040 __mc68040__"
+al="$al __mc88100 __mc88100__ __mips __mips__"
+al="$al __motorola__ __osf__ __pa_risc __sparc__ __stdc__"
+al="$al __sun __sun__ __svr3__ __svr4__ __ultrix __ultrix__"
+al="$al __unix __unix__ __uxpm__ __uxps__ __vax __vax__"
+al="$al _host_mips _mips _unix"
+al="$al a29k aegis aix aixpc alliant alpha am29000 amiga ansi ardent"
+al="$al apollo ardent att386 att3b"
+al="$al bsd bsd43 bsd4_2 bsd4_3 bsd4_4 bsdi bull"
+al="$al cadmus clipper concurrent convex cray ctix"
+al="$al dmert encore gcos gcx gimpel gould"
+al="$al hbullx20 hcx host_mips hp200 hp300 hp700 hp800"
+al="$al hp9000 hp9000s300 hp9000s400 hp9000s500"
+al="$al hp9000s700 hp9000s800 hp9k8 hppa hpux"
+al="$al i186 i286 i386 i486 i8086"
+al="$al i80960 i860 iAPX286 ibm ibm032 ibmrt interdata is68k"
+al="$al ksr1 linux luna luna88k m68k m88100 m88k"
+al="$al mc300 mc500 mc68000 mc68010 mc68020 mc68030"
+al="$al mc68040 mc68060 mc68k mc68k32 mc700"
+al="$al mc88000 mc88100 merlin mert mips mvs n16"
+al="$al ncl_el ncl_mr"
+al="$al news1500 news1700 news1800 news1900 news3700"
+al="$al news700 news800 news900 ns16000 ns32000"
+al="$al ns32016 ns32332 ns32k nsc32000 os osf"
+al="$al parisc pc532 pdp11 plexus posix pyr"
+al="$al riscix riscos scs sequent sgi sinix sony sony_news"
+al="$al sonyrisc sparc sparclite spectrum stardent stratos"
+al="$al sun sun3 sun386 svr4 sysV68 sysV88"
+al="$al titan tower tower32 tower32_200 tower32_600 tower32_700"
+al="$al tower32_800 tower32_850 tss u370 u3b u3b2 u3b20 u3b200"
+al="$al u3b20d u3b5 ultrix unix unixpc unos vax venix vms"
+al="$al xenix z8000"
+
+i_whoami=''
+: change the next line if compiling for Xenix/286 on Xenix/386
+xlibpth='/usr/lib/386 /lib/386'
+
+: Possible local library directories to search.
+loclibpth="/usr/local/lib /opt/local/lib /usr/gnu/lib"
+loclibpth="$loclibpth /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib"
+
+: general looking path for locating libraries
+glibpth="/shlib /usr/shlib /lib/pa1.1 /usr/lib/large"
+glibpth="$glibpth /lib /usr/lib $xlibpth"
+glibpth="$glibpth /lib/large /usr/lib/small /lib/small"
+glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/local/lib"
+
+: Private path used by Configure to find libraries. Its value
+: is prepended to libpth. This variable takes care of special
+: machines, like the mips. Usually, it should be empty.
+plibpth=''
+
+: default library list
+libswanted=''
+: Possible local include directories to search.
+: Set locincpth to "" in a hint file to defeat local include searches.
+locincpth="/usr/local/include /opt/local/include /usr/gnu/include"
+locincpth="$locincpth /opt/gnu/include /usr/GNU/include /opt/GNU/include"
+:
+: no include file wanted by default
+inclwanted=''
+
+: Trailing extension. Override this in a hint file, if needed.
+_exe=''
+: Extra object files, if any, needed on this platform.
+archobjs=''
+groupstype=''
+: full support for void wanted by default
+defvoidused=15
+
+: set useposix=false in your hint file to disable the POSIX extension.
+useposix=true
+: set useopcode=false in your hint file to disable the Opcode extension.
+useopcode=true
+: set usethreads on the Configure command line to enable threads.
+: List of libraries we want.
+: If anyone needs -lnet, put it in a hint file.
+libswanted='sfio socket inet nsl nm ndbm gdbm dbm db malloc dl'
+libswanted="$libswanted dld ld sun m c cposix posix ndir dir crypt"
+libswanted="$libswanted ucb bsd BSD PW x"
+: We probably want to search /usr/shlib before most other libraries.
+: This is only used by the lib/ExtUtils/MakeMaker.pm routine extliblist.
+glibpth=`echo " $glibpth " | sed -e 's! /usr/shlib ! !'`
+glibpth="/usr/shlib $glibpth"
+: Do not use vfork unless overridden by a hint file.
+usevfork=false
+
+: Find the basic shell for Bourne shell scripts
+case "$sh" in
+'')
+ case "$SYSTYPE" in
+ *bsd*|sys5*) xxx="/$SYSTYPE/bin/sh";;
+ *) xxx='/bin/sh';;
+ esac
+ if test -f "$xxx"; then
+ sh="$xxx"
+ else
+ : Build up a list and do a single loop so we can 'break' out.
+ pth=`echo $PATH | sed -e "s/$p_/ /g"`
+ for xxx in sh bash ksh pdksh ash; do
+ for p in $pth; do
+ try="$try ${p}/${xxx}"
+ done
+ done
+ for xxx in $try; do
+ if test -f "$xxx"; then
+ sh="$xxx";
+ break
+ elif test -f "$xxx.exe"; then
+ sh="$xxx";
+ break
+ fi
+ done
+ fi
+ ;;
+esac
+
+case "$sh" in
+'') cat <<EOM >&2
+$me: Fatal Error: I can't find a Bourne Shell anywhere.
+
+Usually it's in /bin/sh. How did you even get this far?
+Please contact me (Andy Dougherty) at doughera@lafayette.edu and
+we'll try to straighten this all out.
+EOM
+ exit 1
+ ;;
+esac
+
+: see if sh knows # comments
+if `$sh -c '#' >/dev/null 2>&1`; then
+ shsharp=true
+ spitshell=cat
+ xcat=/bin/cat
+ test -f $xcat || xcat=/usr/bin/cat
+ echo "#!$xcat" >try
+ $eunicefix try
+ chmod +x try
+ ./try > today
+ if test -s today; then
+ sharpbang='#!'
+ else
+ echo "#! $xcat" > try
+ $eunicefix try
+ chmod +x try
+ ./try > today
+ if test -s today; then
+ sharpbang='#! '
+ else
+ sharpbang=': use '
+ fi
+ fi
+else
+ echo " "
+ echo "Your $sh doesn't grok # comments--I will strip them later on."
+ shsharp=false
+ cd ..
+ echo "exec grep -v '^[ ]*#'" >spitshell
+ chmod +x spitshell
+ $eunicefix spitshell
+ spitshell=`pwd`/spitshell
+ cd UU
+ echo "I presume that if # doesn't work, #! won't work either!"
+ sharpbang=': use '
+fi
+rm -f try today
+
+: figure out how to guarantee sh startup
+case "$startsh" in
+'') startsh=${sharpbang}${sh} ;;
+*)
+esac
+cat >try <<EOSS
+$startsh
+set abc
+test "$?abc" != 1
+EOSS
+
+chmod +x try
+$eunicefix try
+if ./try; then
+ : echo "Yup, it does."
+else
+ echo "Hmm... '$startsh' does not guarantee sh startup..."
+ echo "You may have to fix up the shell scripts to make sure $sh runs them."
+fi
+rm -f try
+
+
+: Save command line options in file UU/cmdline.opt for later use in
+: generating config.sh.
+cat > cmdline.opt <<EOSH
+# Configure command line arguments.
+config_arg0='$0'
+config_args='$*'
+config_argc=$#
+EOSH
+argn=1
+for arg in "$@"; do
+ cat >>cmdline.opt <<EOSH
+config_arg$argn='$arg'
+EOSH
+ argn=`expr $argn + 1`
+done
+
+: produce awk script to parse command line options
+cat >options.awk <<'EOF'
+BEGIN {
+ optstr = "dD:eEf:hKOrsSU:V"; # getopt-style specification
+
+ len = length(optstr);
+ for (i = 1; i <= len; i++) {
+ c = substr(optstr, i, 1);
+ if (i < len) a = substr(optstr, i + 1, 1); else a = "";
+ if (a == ":") {
+ arg[c] = 1;
+ i++;
+ }
+ opt[c] = 1;
+ }
+}
+{
+ expect = 0;
+ str = $0;
+ if (substr(str, 1, 1) != "-") {
+ printf("'%s'\n", str);
+ next;
+ }
+ len = length($0);
+ for (i = 2; i <= len; i++) {
+ c = substr(str, i, 1);
+ if (!opt[c]) {
+ printf("-%s\n", substr(str, i));
+ next;
+ }
+ printf("-%s\n", c);
+ if (arg[c]) {
+ if (i < len)
+ printf("'%s'\n", substr(str, i + 1));
+ else
+ expect = 1;
+ next;
+ }
+ }
+}
+END {
+ if (expect)
+ print "?";
+}
+EOF
+
+: process the command line options
+set X `for arg in "$@"; do echo "X$arg"; done |
+ sed -e s/X// | awk -f options.awk`
+eval "set $*"
+shift
+rm -f options.awk
+
+: set up default values
+fastread=''
+reuseval=false
+config_sh=''
+alldone=''
+error=''
+silent=''
+extractsh=''
+override=''
+knowitall=''
+rm -f optdef.sh
+cat >optdef.sh <<EOS
+$startsh
+EOS
+
+
+: option parsing
+while test $# -gt 0; do
+ case "$1" in
+ -d) shift; fastread=yes;;
+ -e) shift; alldone=cont;;
+ -f)
+ shift
+ cd ..
+ if test -r "$1"; then
+ config_sh="$1"
+ else
+ echo "$me: cannot read config file $1." >&2
+ error=true
+ fi
+ cd UU
+ shift;;
+ -h) shift; error=true;;
+ -r) shift; reuseval=true;;
+ -s) shift; silent=true; realsilent=true;;
+ -E) shift; alldone=exit;;
+ -K) shift; knowitall=true;;
+ -O) shift; override=true;;
+ -S) shift; silent=true; extractsh=true;;
+ -D)
+ shift
+ case "$1" in
+ *=)
+ echo "$me: use '-U symbol=', not '-D symbol='." >&2
+ echo "$me: ignoring -D $1" >&2
+ ;;
+ *=*) echo "$1" | \
+ sed -e "s/'/'\"'\"'/g" -e "s/=\(.*\)/='\1'/" >> optdef.sh;;
+ *) echo "$1='define'" >> optdef.sh;;
+ esac
+ shift
+ ;;
+ -U)
+ shift
+ case "$1" in
+ *=) echo "$1" >> optdef.sh;;
+ *=*)
+ echo "$me: use '-D symbol=val', not '-U symbol=val'." >&2
+ echo "$me: ignoring -U $1" >&2
+ ;;
+ *) echo "$1='undef'" >> optdef.sh;;
+ esac
+ shift
+ ;;
+ -V) echo "$me generated by metaconfig 3.0 PL70." >&2
+ exit 0;;
+ --) break;;
+ -*) echo "$me: unknown option $1" >&2; shift; error=true;;
+ *) break;;
+ esac
+done
+
+case "$error" in
+true)
+ cat >&2 <<EOM
+Usage: $me [-dehrsEKOSV] [-f config.sh] [-D symbol] [-D symbol=value]
+ [-U symbol] [-U symbol=]
+ -d : use defaults for all answers.
+ -e : go on without questioning past the production of config.sh.
+ -f : specify an alternate default configuration file.
+ -h : print this help message and exit (with an error status).
+ -r : reuse C symbols value if possible (skips costly nm extraction).
+ -s : silent mode, only echoes questions and essential information.
+ -D : define symbol to have some value:
+ -D symbol symbol gets the value 'define'
+ -D symbol=value symbol gets the value 'value'
+ -E : stop at the end of questions, after having produced config.sh.
+ -K : do not use unless you know what you are doing.
+ -O : let -D and -U override definitions from loaded configuration file.
+ -S : perform variable substitutions on all .SH files (can mix with -f)
+ -U : undefine symbol:
+ -U symbol symbol gets the value 'undef'
+ -U symbol= symbol gets completely empty
+ -V : print version number and exit (with a zero status).
+EOM
+ exit 1
+ ;;
+esac
+
+: Sanity checks
+case "$fastread$alldone" in
+yescont|yesexit) ;;
+*)
+ if test ! -t 0; then
+ echo "Say 'sh Configure', not 'sh <Configure'"
+ exit 1
+ fi
+ ;;
+esac
+
+exec 4>&1
+case "$silent" in
+true) exec 1>/dev/null;;
+esac
+
+: run the defines and the undefines, if any, but leave the file out there...
+touch optdef.sh
+. ./optdef.sh
+
+: set package name
+package=perl5
+first=`echo $package | sed -e 's/^\(.\).*/\1/'`
+last=`echo $package | sed -e 's/^.\(.*\)/\1/'`
+case "`echo AbyZ | tr '[:lower:]' '[:upper:]' 2>/dev/null`" in
+ABYZ) spackage=`echo $first | tr '[:lower:]' '[:upper:]'`$last;;
+*) spackage=`echo $first | tr '[a-z]' '[A-Z]'`$last;;
+esac
+
+: Some greps do not return status, grrr.
+echo "grimblepritz" >grimble
+if grep blurfldyick grimble >/dev/null 2>&1 ; then
+ contains=contains
+elif grep grimblepritz grimble >/dev/null 2>&1 ; then
+ contains=grep
+else
+ contains=contains
+fi
+rm -f grimble
+: the following should work in any shell
+case "$contains" in
+contains*)
+ echo " "
+ echo "AGH! Grep doesn't return a status. Attempting remedial action."
+ cat >contains <<'EOSS'
+grep "$1" "$2" >.greptmp && cat .greptmp && test -s .greptmp
+EOSS
+chmod +x contains
+esac
+
+: Find the path to the source tree
+case "$src" in
+'') case "$0" in
+ */*) src=`echo $0 | sed -e 's%/[^/][^/]*$%%'`;;
+ *) src='.';;
+ esac;;
+esac
+case "$src" in
+'') src=/
+ rsrc=/
+ ;;
+/*) rsrc="$src";;
+*) rsrc="../$src";;
+esac
+if test -f $rsrc/Configure && \
+ $contains "^package=$package$" $rsrc/Configure >/dev/null 2>&1
+then
+ : found it, so we are ok.
+else
+ rsrc=''
+ for src in . .. ../.. ../../.. ../../../..; do
+ if test -f ../$src/Configure && \
+ $contains "^package=$package$" ../$src/Configure >/dev/null 2>&1
+ then
+ rsrc=../$src
+ break
+ fi
+ done
+fi
+case "$rsrc" in
+'')
+ cat <<EOM >&4
+
+Sorry, I can't seem to locate the source dir for $package. Please start
+Configure with an explicit path -- i.e. /some/path/Configure.
+
+EOM
+ exit 1
+ ;;
+../.) rsrc='..';;
+*)
+ echo " "
+ echo "Sources for $package found in \"$src\"." >&4
+ ;;
+esac
+
+: script used to extract .SH files with variable substitutions
+cat >extract <<'EOS'
+CONFIG=true
+echo "Doing variable substitutions on .SH files..."
+if test -f $src/MANIFEST; then
+ set x `awk '{print $1}' <$src/MANIFEST | grep '\.SH'`
+else
+ echo "(Looking for .SH files under the source directory.)"
+ set x `(cd $src; find . -name "*.SH" -print)`
+fi
+shift
+case $# in
+0) set x `(cd $src; echo *.SH)`; shift;;
+esac
+if test ! -f $src/$1; then
+ shift
+fi
+mkdir_p='
+name=$1;
+create="";
+while test $name; do
+ if test ! -d "$name"; then
+ create="$name $create";
+ name=`echo $name | sed -e "s|^[^/]*$||"`;
+ name=`echo $name | sed -e "s|\(.*\)/.*|\1|"`;
+ else
+ name="";
+ fi;
+done;
+for file in $create; do
+ mkdir $file;
+done
+'
+for file in $*; do
+ case "$src" in
+ ".")
+ case "$file" in
+ */*)
+ dir=`expr X$file : 'X\(.*\)/'`
+ file=`expr X$file : 'X.*/\(.*\)'`
+ (cd $dir && . ./$file)
+ ;;
+ *)
+ . ./$file
+ ;;
+ esac
+ ;;
+ *)
+ case "$file" in
+ */*)
+ dir=`expr X$file : 'X\(.*\)/'`
+ file=`expr X$file : 'X.*/\(.*\)'`
+ (set x $dir; shift; eval $mkdir_p)
+ sh <$src/$dir/$file
+ ;;
+ *)
+ sh <$src/$file
+ ;;
+ esac
+ ;;
+ esac
+done
+if test -f $src/config_h.SH; then
+ if test ! -f config.h; then
+ : oops, they left it out of MANIFEST, probably, so do it anyway.
+ . $src/config_h.SH
+ fi
+fi
+EOS
+
+: extract files and exit if asked to do so
+case "$extractsh" in
+true)
+ case "$realsilent" in
+ true) ;;
+ *) exec 1>&4;;
+ esac
+ case "$config_sh" in
+ '') config_sh='config.sh';;
+ esac
+ echo " "
+ echo "Fetching answers from $config_sh..."
+ cd ..
+ . $config_sh
+ test "$override" && . ./optdef.sh
+ echo " "
+ . UU/extract
+ rm -rf UU
+ echo "Done."
+ exit 0
+ ;;
+esac
+
+: Eunice requires " " instead of "", can you believe it
+echo " "
+: Here we go...
+echo "Beginning of configuration questions for $package."
+
+trap 'echo " "; test -d ../UU && rm -rf X $rmlist; exit 1' 1 2 3 15
+
+: first determine how to suppress newline on echo command
+echo " "
+echo "Checking echo to see how to suppress newlines..."
+(echo "hi there\c" ; echo " ") >.echotmp
+if $contains c .echotmp >/dev/null 2>&1 ; then
+ echo "...using -n."
+ n='-n'
+ c=''
+else
+ cat <<'EOM'
+...using \c
+EOM
+ n=''
+ c='\c'
+fi
+echo $n "The star should be here-->$c"
+echo '*'
+rm -f .echotmp
+
+: Now test for existence of everything in MANIFEST
+echo " "
+if test -f $rsrc/MANIFEST; then
+ echo "First let's make sure your kit is complete. Checking..." >&4
+ awk '$1 !~ /PACK[A-Z]+/ {print $1}' $rsrc/MANIFEST | split -50
+ rm -f missing
+ tmppwd=`pwd`
+ for filelist in x??; do
+ (cd $rsrc; ls `cat $tmppwd/$filelist` >/dev/null 2>>$tmppwd/missing)
+ done
+ if test -s missing; then
+ cat missing >&4
+ cat >&4 <<'EOM'
+
+THIS PACKAGE SEEMS TO BE INCOMPLETE.
+
+You have the option of continuing the configuration process, despite the
+distinct possibility that your kit is damaged, by typing 'y'es. If you
+do, don't blame me if something goes wrong. I advise you to type 'n'o
+and contact the author (doughera@lafayette.edu).
+
+EOM
+ echo $n "Continue? [n] $c" >&4
+ read ans
+ case "$ans" in
+ y*)
+ echo "Continuing..." >&4
+ rm -f missing
+ ;;
+ *)
+ echo "ABORTING..." >&4
+ kill $$
+ ;;
+ esac
+ else
+ echo "Looks good..."
+ fi
+else
+ echo "There is no MANIFEST file. I hope your kit is complete !"
+fi
+rm -f missing x??
+
+: compute the number of columns on the terminal for proper question formatting
+case "$COLUMNS" in
+'') COLUMNS='80';;
+esac
+
+: set up the echo used in my read
+myecho="case \"\$xxxm\" in
+'') echo $n \"\$rp $c\" >&4;;
+*) case \"\$rp\" in
+ '') echo $n \"[\$xxxm] $c\";;
+ *)
+ if test \`echo \"\$rp [\$xxxm] \" | wc -c\` -ge $COLUMNS; then
+ echo \"\$rp\" >&4
+ echo $n \"[\$xxxm] $c\" >&4
+ else
+ echo $n \"\$rp [\$xxxm] $c\" >&4
+ fi
+ ;;
+ esac;;
+esac"
+
+: now set up to do reads with possible shell escape and default assignment
+cat <<EOSC >myread
+$startsh
+xxxm=\$dflt
+$myecho
+ans='!'
+case "\$fastread" in
+yes) case "\$dflt" in
+ '') ;;
+ *) ans='';
+ case "\$silent-\$rp" in
+ true-) ;;
+ *) echo " " >&4;;
+ esac;;
+ esac;;
+*) case "\$silent" in
+ true) case "\$rp" in
+ '') ans='';;
+ esac;;
+ esac;;
+esac
+while expr "X\$ans" : "X!" >/dev/null; do
+ read answ
+ set x \$xxxm
+ shift
+ aok=''; eval "ans=\\"\$answ\\"" && aok=y
+ case "\$answ" in
+ "!")
+ sh 1>&4
+ echo " "
+ $myecho
+ ;;
+ !*)
+ set x \`expr "X\$ans" : "X!\(.*\)\$"\`
+ shift
+ sh 1>&4 -c "\$*"
+ echo " "
+ $myecho
+ ;;
+ "\$ans")
+ case "\$ans" in
+ \\&*)
+ set x \`expr "X\$ans" : "X&\(.*\)\$"\`
+ shift
+ case "\$1" in
+ -d)
+ fastread=yes
+ echo "(OK, I'll run with -d after this question.)" >&4
+ ;;
+ -*)
+ echo "*** Sorry, \$1 not supported yet." >&4
+ ;;
+ esac
+ $myecho
+ ans=!
+ ;;
+ esac;;
+ *)
+ case "\$aok" in
+ y)
+ echo "*** Substitution done -- please confirm."
+ xxxm="\$ans"
+ ans=\`echo $n "\$ans$c" | tr '$trnl' ' '\`
+ xxxm="\$ans"
+ ans=!
+ ;;
+ *)
+ echo "*** Error -- try again."
+ ans=!
+ ;;
+ esac
+ $myecho
+ ;;
+ esac
+ case "\$ans\$xxxm\$nostick" in
+ '')
+ ans=!
+ $myecho
+ ;;
+ esac
+done
+case "\$ans" in
+'') ans="\$xxxm";;
+esac
+EOSC
+
+: create .config dir to save info across Configure sessions
+test -d ../.config || mkdir ../.config
+cat >../.config/README <<EOF
+This directory created by Configure to save information that should
+persist across sessions for $package.
+
+You may safely delete it if you wish.
+EOF
+
+: general instructions
+needman=true
+firsttime=true
+user=`(logname) 2>/dev/null`
+case "$user" in
+'') user=`whoami 2>&1`;;
+esac
+if $contains "^$user\$" ../.config/instruct >/dev/null 2>&1; then
+ firsttime=false
+ echo " "
+ rp='Would you like to see the instructions?'
+ dflt=n
+ . ./myread
+ case "$ans" in
+ [yY]*) ;;
+ *) needman=false;;
+ esac
+fi
+if $needman; then
+ cat <<EOH
+
+This installation shell script will examine your system and ask you questions
+to determine how the perl5 package should be installed. If you get
+stuck on a question, you may use a ! shell escape to start a subshell or
+execute a command. Many of the questions will have default answers in square
+brackets; typing carriage return will give you the default.
+
+On some of the questions which ask for file or directory names you are allowed
+to use the ~name construct to specify the login directory belonging to "name",
+even if you don't have a shell which knows about that. Questions where this is
+allowed will be marked "(~name ok)".
+
+EOH
+ rp=''
+ dflt='Type carriage return to continue'
+ . ./myread
+ cat <<'EOH'
+
+The prompter used in this script allows you to use shell variables and
+backticks in your answers. You may use $1, $2, etc... to refer to the words
+in the default answer, as if the default line was a set of arguments given to a
+script shell. This means you may also use $* to repeat the whole default line,
+so you do not have to re-type everything to add something to the default.
+
+Everytime there is a substitution, you will have to confirm. If there is an
+error (e.g. an unmatched backtick), the default answer will remain unchanged
+and you will be prompted again.
+
+If you are in a hurry, you may run 'Configure -d'. This will bypass nearly all
+the questions and use the computed defaults (or the previous answers if there
+was already a config.sh file). Type 'Configure -h' for a list of options.
+You may also start interactively and then answer '& -d' at any prompt to turn
+on the non-interactive behaviour for the remainder of the execution.
+
+EOH
+ . ./myread
+ cat <<EOH
+
+Much effort has been expended to ensure that this shell script will run on any
+Unix system. If despite that it blows up on yours, your best bet is to edit
+Configure and run it again. If you can't run Configure for some reason,
+you'll have to generate a config.sh file by hand. Whatever problems you
+have, let me (doughera@lafayette.edu) know how I blew it.
+
+This installation script affects things in two ways:
+
+1) it may do direct variable substitutions on some of the files included
+ in this kit.
+2) it builds a config.h file for inclusion in C programs. You may edit
+ any of these files as the need arises after running this script.
+
+If you make a mistake on a question, there is no easy way to back up to it
+currently. The easiest thing to do is to edit config.sh and rerun all the SH
+files. Configure will offer to let you do this before it runs the SH files.
+
+EOH
+ dflt='Type carriage return to continue'
+ . ./myread
+ case "$firsttime" in
+ true) echo $user >>../.config/instruct;;
+ esac
+fi
+
+: find out where common programs are
+echo " "
+echo "Locating common programs..." >&4
+cat <<EOSC >loc
+$startsh
+case \$# in
+0) exit 1;;
+esac
+thing=\$1
+shift
+dflt=\$1
+shift
+for dir in \$*; do
+ case "\$thing" in
+ .)
+ if test -d \$dir/\$thing; then
+ echo \$dir
+ exit 0
+ fi
+ ;;
+ *)
+ for thisthing in \$dir/\$thing; do
+ : just loop through to pick last item
+ done
+ if test -f \$thisthing; then
+ echo \$thisthing
+ exit 0
+ elif test -f \$dir/\$thing.exe; then
+ if test -n "$DJGPP"; then
+ echo \$dir/\$thing.exe
+ else
+ : on Eunice apparently
+ echo \$dir/\$thing
+ fi
+ exit 0
+ fi
+ ;;
+ esac
+done
+echo \$dflt
+exit 1
+EOSC
+chmod +x loc
+$eunicefix loc
+loclist="
+awk
+cat
+comm
+cp
+echo
+expr
+find
+grep
+ls
+make
+mkdir
+rm
+sed
+sort
+touch
+tr
+uniq
+"
+trylist="
+Mcc
+ar
+byacc
+cpp
+csh
+date
+egrep
+gzip
+less
+line
+ln
+more
+nm
+nroff
+perl
+pg
+sendmail
+tee
+test
+uname
+zip
+"
+pth=`echo $PATH | sed -e "s/$p_/ /g"`
+pth="$pth /lib /usr/lib"
+for file in $loclist; do
+ eval xxx=\$$file
+ case "$xxx" in
+ /*|?:[\\/]*)
+ if test -f "$xxx"; then
+ : ok
+ else
+ echo "WARNING: no $xxx -- ignoring your setting for $file." >&4
+ xxx=`./loc $file $file $pth`
+ fi
+ ;;
+ '') xxx=`./loc $file $file $pth`;;
+ *) xxx=`./loc $xxx $xxx $pth`;;
+ esac
+ eval $file=$xxx
+ eval _$file=$xxx
+ case "$xxx" in
+ /*)
+ echo $file is in $xxx.
+ ;;
+ ?:[\\/]*)
+ echo $file is in $xxx.
+ ;;
+ *)
+ echo "I don't know where '$file' is, and my life depends on it." >&4
+ echo "Go find a public domain implementation or fix your PATH setting!" >&4
+ exit 1
+ ;;
+ esac
+done
+echo " "
+echo "Don't worry if any of the following aren't found..."
+say=offhand
+for file in $trylist; do
+ eval xxx=\$$file
+ case "$xxx" in
+ /*|?:[\\/]*)
+ if test -f "$xxx"; then
+ : ok
+ else
+ echo "WARNING: no $xxx -- ignoring your setting for $file." >&4
+ xxx=`./loc $file $file $pth`
+ fi
+ ;;
+ '') xxx=`./loc $file $file $pth`;;
+ *) xxx=`./loc $xxx $xxx $pth`;;
+ esac
+ eval $file=$xxx
+ eval _$file=$xxx
+ case "$xxx" in
+ /*)
+ echo $file is in $xxx.
+ ;;
+ ?:[\\/]*)
+ echo $file is in $xxx.
+ ;;
+ *)
+ echo "I don't see $file out there, $say."
+ say=either
+ ;;
+ esac
+done
+case "$egrep" in
+egrep)
+ echo "Substituting grep for egrep."
+ egrep=$grep
+ ;;
+esac
+case "$ln" in
+ln)
+ echo "Substituting cp for ln."
+ ln=$cp
+ ;;
+esac
+case "$test" in
+test)
+ echo "Hopefully test is built into your sh."
+ ;;
+*)
+ if `sh -c "PATH= test true" >/dev/null 2>&1`; then
+ echo "Using the test built into your sh."
+ test=test
+ _test=test
+ fi
+ ;;
+esac
+case "$echo" in
+echo)
+ echo "Hopefully echo is built into your sh."
+ ;;
+'') ;;
+*)
+ echo " "
+echo "Checking compatibility between $echo and builtin echo (if any)..." >&4
+ $echo $n "hi there$c" >foo1
+ echo $n "hi there$c" >foo2
+ if cmp foo1 foo2 >/dev/null 2>&1; then
+ echo "They are compatible. In fact, they may be identical."
+ else
+ case "$n" in
+ '-n') n='' c='\c';;
+ *) n='-n' c='';;
+ esac
+ cat <<FOO
+They are not compatible! You are probably running ksh on a non-USG system.
+I'll have to use $echo instead of the builtin, since Bourne shell doesn't
+have echo built in and we may have to run some Bourne shell scripts. That
+means I'll have to use '$n$c' to suppress newlines now. Life is ridiculous.
+
+FOO
+ $echo $n "The star should be here-->$c"
+ $echo "*"
+ fi
+ $rm -f foo1 foo2
+ ;;
+esac
+
+: determine whether symbolic links are supported
+echo " "
+$touch blurfl
+if $ln -s blurfl sym > /dev/null 2>&1 ; then
+ echo "Symbolic links are supported." >&4
+ lns="$ln -s"
+else
+ echo "Symbolic links are NOT supported." >&4
+ lns="$ln"
+fi
+$rm -f blurfl sym
+
+: see whether [:lower:] and [:upper:] are supported character classes
+echo " "
+case "`echo AbyZ | $tr '[:lower:]' '[:upper:]' 2>/dev/null`" in
+ABYZ)
+ echo "Good, your tr supports [:lower:] and [:upper:] to convert case." >&4
+ up='[:upper:]'
+ low='[:lower:]'
+ ;;
+*) # There is a discontinuity in EBCDIC between 'I' and 'J'
+ # (0xc9 and 0xd1), therefore that is a nice testing point.
+ if test "X$up" = X -o "X$low" = X; then
+ case "`echo IJ | $tr '[I-J]' '[i-j]' 2>/dev/null`" in
+ ij) up='[A-Z]'
+ low='[a-z]'
+ ;;
+ esac
+ fi
+ if test "X$up" = X -o "X$low" = X; then
+ case "`echo IJ | $tr I-J i-j 2>/dev/null`" in
+ ij) up='A-Z'
+ low='a-z'
+ ;;
+ esac
+ fi
+ if test "X$up" = X -o "X$low" = X; then
+ case "`echo IJ | od -x 2>/dev/null`" in
+ *C9D1*|*c9d1*)
+ echo "Hey, this might be EBCDIC." >&4
+ if test "X$up" = X -o "X$low" = X; then
+ case "`echo IJ | tr '[A-IJ-RS-Z]' '[a-ij-rs-z]' 2>/dev/null`" in
+ ij) up='[A-IJ-RS-Z]'
+ low='[a-ij-rs-z]'
+ ;;
+ esac
+ fi
+ if test "X$up" = X -o "X$low" = X; then
+ case "`echo IJ | tr A-IJ-RS-Z a-ij-rs-z 2>/dev/null`" in
+ ij) up='A-IJ-RS-Z'
+ low='a-ij-rs-z'
+ ;;
+ esac
+ fi
+ ;;
+ esac
+ fi
+esac
+case "`echo IJ | $tr \"$up\" \"$low\" 2>/dev/null`" in
+ij)
+ echo "Using $up and $low to convert case." >&4
+ ;;
+*)
+ echo "I don't know how to translate letters from upper to lower case." >&4
+ echo "Your tr is not acting any way I know of." >&4
+ exit 1
+ ;;
+esac
+: set up the translation script tr, must be called with ./tr of course
+cat >tr <<EOSC
+$startsh
+case "\$1\$2" in
+'[A-Z][a-z]') exec $tr '$up' '$low';;
+'[a-z][A-Z]') exec $tr '$low' '$up';;
+esac
+exec $tr "\$@"
+EOSC
+chmod +x tr
+$eunicefix tr
+
+: Try to determine whether config.sh was made on this system
+case "$config_sh" in
+'')
+myuname=`( ($uname -a) 2>/dev/null || hostname) 2>&1`
+# tr '[A-Z]' '[a-z]' would not work in EBCDIC
+# because the A-Z/a-z are not consecutive.
+myuname=`echo $myuname | $sed -e 's/^[^=]*=//' -e 's/\///g' | \
+ ./tr '[A-Z]' '[a-z]' | $tr $trnl ' '`
+newmyuname="$myuname"
+dflt=n
+case "$knowitall" in
+'')
+ if test -f ../config.sh; then
+ if $contains myuname= ../config.sh >/dev/null 2>&1; then
+ eval "`grep myuname= ../config.sh`"
+ fi
+ if test "X$myuname" = "X$newmyuname"; then
+ dflt=y
+ fi
+ fi
+ ;;
+*) dflt=y;;
+esac
+
+: Get old answers from old config file if Configure was run on the
+: same system, otherwise use the hints.
+hint=default
+cd ..
+if test -f config.sh; then
+ echo " "
+ rp="I see a config.sh file. Shall I use it to set the defaults?"
+ . UU/myread
+ case "$ans" in
+ n*|N*) echo "OK, I'll ignore it."; mv config.sh config.sh.old;;
+ *) echo "Fetching default answers from your old config.sh file..." >&4
+ tmp_n="$n"
+ tmp_c="$c"
+ tmp_sh="$sh"
+ . ./config.sh
+ cp config.sh UU
+ n="$tmp_n"
+ c="$tmp_c"
+ : Older versions did not always set $sh. Catch re-use of such
+ : an old config.sh.
+ case "$sh" in
+ '') sh="$tmp_sh" ;;
+ esac
+ hint=previous
+ ;;
+ esac
+fi
+if test ! -f config.sh; then
+ $cat <<EOM
+
+First time through, eh? I have some defaults handy for some systems
+that need some extra help getting the Configure answers right:
+
+EOM
+ (cd $src/hints; ls -C *.sh) | $sed 's/\.sh/ /g' >&4
+ dflt=''
+ : Half the following guesses are probably wrong... If you have better
+ : tests or hints, please send them to doughera@lafayette.edu
+ : The metaconfig authors would also appreciate a copy...
+ $test -f /irix && osname=irix
+ $test -f /xenix && osname=sco_xenix
+ $test -f /dynix && osname=dynix
+ $test -f /dnix && osname=dnix
+ $test -f /lynx.os && osname=lynxos
+ $test -f /unicos && osname=unicos && osvers=`$uname -r`
+ $test -f /unicosmk.ar && osname=unicosmk && osvers=`$uname -r`
+ $test -f /bin/mips && /bin/mips && osname=mips
+ $test -d /NextApps && set X `hostinfo | grep 'NeXT Mach.*:' | \
+ $sed -e 's/://' -e 's/\./_/'` && osname=next && osvers=$4
+ $test -d /usr/apollo/bin && osname=apollo
+ $test -f /etc/saf/_sactab && osname=svr4
+ $test -d /usr/include/minix && osname=minix
+ if $test -d /MachTen -o -d /MachTen_Folder; then
+ osname=machten
+ if $test -x /sbin/version; then
+ osvers=`/sbin/version | $awk '{print $2}' |
+ $sed -e 's/[A-Za-z]$//'`
+ elif $test -x /usr/etc/version; then
+ osvers=`/usr/etc/version | $awk '{print $2}' |
+ $sed -e 's/[A-Za-z]$//'`
+ else
+ osvers="$2.$3"
+ fi
+ fi
+ if $test -f $uname; then
+ set X $myuname
+ shift
+
+ case "$5" in
+ fps*) osname=fps ;;
+ mips*)
+ case "$4" in
+ umips) osname=umips ;;
+ *) osname=mips ;;
+ esac;;
+ [23]100) osname=mips ;;
+ next*) osname=next ;;
+ i386*)
+ if $test -f /etc/kconfig; then
+ osname=isc
+ if test "$lns" = "ln -s"; then
+ osvers=4
+ elif $contains _SYSV3 /usr/include/stdio.h > /dev/null 2>&1 ; then
+ osvers=3
+ elif $contains _POSIX_SOURCE /usr/include/stdio.h > /dev/null 2>&1 ; then
+ osvers=2
+ fi
+ fi
+ ;;
+ pc*)
+ if test -n "$DJGPP"; then
+ osname=dos
+ osvers=djgpp
+ fi
+ ;;
+ esac
+
+ case "$1" in
+ aix) osname=aix
+ tmp=`( (oslevel) 2>/dev/null || echo "not found") 2>&1`
+ case "$tmp" in
+ 'not found') osvers="$4"."$3" ;;
+ '<3240'|'<>3240') osvers=3.2.0 ;;
+ '=3240'|'>3240'|'<3250'|'<>3250') osvers=3.2.4 ;;
+ '=3250'|'>3250') osvers=3.2.5 ;;
+ *) osvers=$tmp;;
+ esac
+ ;;
+ *dc.osx) osname=dcosx
+ osvers="$3"
+ ;;
+ dnix) osname=dnix
+ osvers="$3"
+ ;;
+ domainos) osname=apollo
+ osvers="$3"
+ ;;
+ dgux) osname=dgux
+ osvers="$3"
+ ;;
+ dynixptx*) osname=dynixptx
+ osvers="$3"
+ ;;
+ freebsd) osname=freebsd
+ osvers="$3" ;;
+ genix) osname=genix ;;
+ hp*) osname=hpux
+ osvers=`echo "$3" | $sed 's,.*\.\([0-9]*\.[0-9]*\),\1,'`
+ ;;
+ irix*) osname=irix
+ case "$3" in
+ 4*) osvers=4 ;;
+ 5*) osvers=5 ;;
+ *) osvers="$3" ;;
+ esac
+ ;;
+ linux) osname=linux
+ case "$3" in
+ *) osvers="$3" ;;
+ esac
+ ;;
+ MiNT) osname=mint
+ ;;
+ netbsd*) osname=netbsd
+ osvers="$3"
+ ;;
+ news-os) osvers="$3"
+ case "$3" in
+ 4*) osname=newsos4 ;;
+ *) osname=newsos ;;
+ esac
+ ;;
+ bsd386) osname=bsd386
+ osvers=`$uname -r`
+ ;;
+ powerux | power_ux | powermax_os | powermaxos | \
+ powerunix | power_unix) osname=powerux
+ osvers="$3"
+ ;;
+ next*) osname=next ;;
+ solaris) osname=solaris
+ case "$3" in
+ 5*) osvers=`echo $3 | $sed 's/^5/2/g'` ;;
+ *) osvers="$3" ;;
+ esac
+ ;;
+ sunos) osname=sunos
+ case "$3" in
+ 5*) osname=solaris
+ osvers=`echo $3 | $sed 's/^5/2/g'` ;;
+ *) osvers="$3" ;;
+ esac
+ ;;
+ titanos) osname=titanos
+ case "$3" in
+ 1*) osvers=1 ;;
+ 2*) osvers=2 ;;
+ 3*) osvers=3 ;;
+ 4*) osvers=4 ;;
+ *) osvers="$3" ;;
+ esac
+ ;;
+ ultrix) osname=ultrix
+ osvers="$3"
+ ;;
+ osf1|mls+) case "$5" in
+ alpha)
+ osname=dec_osf
+ osvers=`echo "$3" | sed 's/^[xvt]//'`
+ ;;
+ hp*) osname=hp_osf1 ;;
+ mips) osname=mips_osf1 ;;
+ esac
+ ;;
+ uts) osname=uts
+ osvers="$3"
+ ;;
+ qnx) osname=qnx
+ osvers="$4"
+ ;;
+ $2) case "$osname" in
+ *isc*) ;;
+ *freebsd*) ;;
+ svr*)
+ : svr4.x or possibly later
+ case "svr$3" in
+ ${osname}*)
+ osname=svr$3
+ osvers=$4
+ ;;
+ esac
+ case "$osname" in
+ svr4.0)
+ : Check for ESIX
+ if test -f /stand/boot ; then
+ eval `grep '^INITPROG=[a-z/0-9]*$' /stand/boot`
+ if test -n "$INITPROG" -a -f "$INITPROG"; then
+ isesix=`strings -a $INITPROG|grep 'ESIX SYSTEM V/386 Release 4.0'`
+ if test -n "$isesix"; then
+ osname=esix4
+ fi
+ fi
+ fi
+ ;;
+ esac
+ ;;
+ *) if test -f /etc/systemid; then
+ osname=sco
+ set `echo $3 | $sed 's/\./ /g'` $4
+ if $test -f $src/hints/sco_$1_$2_$3.sh; then
+ osvers=$1.$2.$3
+ elif $test -f $src/hints/sco_$1_$2.sh; then
+ osvers=$1.$2
+ elif $test -f $src/hints/sco_$1.sh; then
+ osvers=$1
+ fi
+ else
+ case "$osname" in
+ '') : Still unknown. Probably a generic Sys V.
+ osname="sysv"
+ osvers="$3"
+ ;;
+ esac
+ fi
+ ;;
+ esac
+ ;;
+ *) case "$osname" in
+ '') : Still unknown. Probably a generic BSD.
+ osname="$1"
+ osvers="$3"
+ ;;
+ esac
+ ;;
+ esac
+ else
+ if test -f /vmunix -a -f $src/hints/news_os.sh; then
+ (what /vmunix | UU/tr '[A-Z]' '[a-z]') > UU/kernel.what 2>&1
+ if $contains news-os UU/kernel.what >/dev/null 2>&1; then
+ osname=news_os
+ fi
+ $rm -f UU/kernel.what
+ elif test -d c:/.; then
+ set X $myuname
+ osname=os2
+ osvers="$5"
+ fi
+ fi
+
+ : Now look for a hint file osname_osvers, unless one has been
+ : specified already.
+ case "$hintfile" in
+ ''|' ')
+ file=`echo "${osname}_${osvers}" | $sed -e 's@\.@_@g' -e 's@_$@@'`
+ : Also try without trailing minor version numbers.
+ xfile=`echo $file | $sed -e 's@_[^_]*$@@'`
+ xxfile=`echo $xfile | $sed -e 's@_[^_]*$@@'`
+ xxxfile=`echo $xxfile | $sed -e 's@_[^_]*$@@'`
+ xxxxfile=`echo $xxxfile | $sed -e 's@_[^_]*$@@'`
+ case "$file" in
+ '') dflt=none ;;
+ *) case "$osvers" in
+ '') dflt=$file
+ ;;
+ *) if $test -f $src/hints/$file.sh ; then
+ dflt=$file
+ elif $test -f $src/hints/$xfile.sh ; then
+ dflt=$xfile
+ elif $test -f $src/hints/$xxfile.sh ; then
+ dflt=$xxfile
+ elif $test -f $src/hints/$xxxfile.sh ; then
+ dflt=$xxxfile
+ elif $test -f $src/hints/$xxxxfile.sh ; then
+ dflt=$xxxxfile
+ elif $test -f "$src/hints/${osname}.sh" ; then
+ dflt="${osname}"
+ else
+ dflt=none
+ fi
+ ;;
+ esac
+ ;;
+ esac
+ if $test -f Policy.sh ; then
+ case "$dflt" in
+ *Policy*) ;;
+ none) dflt="Policy" ;;
+ *) dflt="Policy $dflt" ;;
+ esac
+ fi
+ ;;
+ *)
+ dflt=`echo $hintfile | $sed 's/\.sh$//'`
+ ;;
+ esac
+
+ if $test -f Policy.sh ; then
+ $cat <<EOM
+
+There's also a Policy hint file available, which should make the
+site-specific (policy) questions easier to answer.
+EOM
+
+ fi
+
+ $cat <<EOM
+
+You may give one or more space-separated answers, or "none" if appropriate.
+A well-behaved OS will have no hints, so answering "none" or just "Policy"
+is a good thing. DO NOT give a wrong version.
+
+EOM
+
+ rp="Which of these apply, if any?"
+ . UU/myread
+ tans=$ans
+ for file in $tans; do
+ if $test X$file = XPolicy -a -f Policy.sh; then
+ . Policy.sh
+ $cat Policy.sh >> UU/config.sh
+ elif $test -f $src/hints/$file.sh; then
+ . $src/hints/$file.sh
+ $cat $src/hints/$file.sh >> UU/config.sh
+ elif $test X$tans = X -o X$tans = Xnone ; then
+ : nothing
+ else
+ : Give one chance to correct a possible typo.
+ echo "$file.sh does not exist"
+ dflt=$file
+ rp="hint to use instead?"
+ . UU/myread
+ for file in $ans; do
+ if $test -f "$src/hints/$file.sh"; then
+ . $src/hints/$file.sh
+ $cat $src/hints/$file.sh >> UU/config.sh
+ elif $test X$ans = X -o X$ans = Xnone ; then
+ : nothing
+ else
+ echo "$file.sh does not exist -- ignored."
+ fi
+ done
+ fi
+ done
+
+ hint=recommended
+ : Remember our hint file for later.
+ if $test -f "$src/hints/$file.sh" ; then
+ hintfile="$file"
+ else
+ hintfile=''
+ fi
+fi
+cd UU
+;;
+*)
+ echo " "
+ echo "Fetching default answers from $config_sh..." >&4
+ tmp_n="$n"
+ tmp_c="$c"
+ cd ..
+ cp $config_sh config.sh 2>/dev/null
+ chmod +w config.sh
+ . ./config.sh
+ cd UU
+ cp ../config.sh .
+ n="$tmp_n"
+ c="$tmp_c"
+ hint=previous
+ ;;
+esac
+test "$override" && . ./optdef.sh
+myuname="$newmyuname"
+
+: Restore computed paths
+for file in $loclist $trylist; do
+ eval $file="\$_$file"
+done
+
+cat << EOM
+
+Configure uses the operating system name and version to set some defaults.
+The default value is probably right if the name rings a bell. Otherwise,
+since spelling matters for me, either accept the default or answer "none"
+to leave it blank.
+
+EOM
+case "$osname" in
+ ''|' ')
+ case "$hintfile" in
+ ''|' '|none) dflt=none ;;
+ *) dflt=`echo $hintfile | $sed -e 's/\.sh$//' -e 's/_.*$//'` ;;
+ esac
+ ;;
+ *) dflt="$osname" ;;
+esac
+rp="Operating system name?"
+. ./myread
+case "$ans" in
+none) osname='' ;;
+*) osname=`echo "$ans" | $sed -e 's/[ ][ ]*/_/g' | ./tr '[A-Z]' '[a-z]'`;;
+esac
+echo " "
+case "$osvers" in
+ ''|' ')
+ case "$hintfile" in
+ ''|' '|none) dflt=none ;;
+ *) dflt=`echo $hintfile | $sed -e 's/\.sh$//' -e 's/^[^_]*//'`
+ dflt=`echo $dflt | $sed -e 's/^_//' -e 's/_/./g'`
+ case "$dflt" in
+ ''|' ') dflt=none ;;
+ esac
+ ;;
+ esac
+ ;;
+ *) dflt="$osvers" ;;
+esac
+rp="Operating system version?"
+. ./myread
+case "$ans" in
+none) osvers='' ;;
+*) osvers="$ans" ;;
+esac
+
+: who configured the system
+cf_time=`LC_ALL=C; export LC_ALL; $date 2>&1`
+cf_by=`(logname) 2>/dev/null`
+case "$cf_by" in
+"")
+ cf_by=`(whoami) 2>/dev/null`
+ case "$cf_by" in
+ "") cf_by=unknown ;;
+ esac ;;
+esac
+
+: set up the script used to warn in case of inconsistency
+cat <<EOS >whoa
+$startsh
+EOS
+cat <<'EOSC' >>whoa
+dflt=y
+echo " "
+echo "*** WHOA THERE!!! ***" >&4
+echo " The $hint value for \$$var on this machine was \"$was\"!" >&4
+rp=" Keep the $hint value?"
+. ./myread
+case "$ans" in
+y) td=$was; tu=$was;;
+esac
+EOSC
+
+: function used to set $1 to $val
+setvar='var=$1; eval "was=\$$1"; td=$define; tu=$undef;
+case "$val$was" in
+$define$undef) . ./whoa; eval "$var=\$td";;
+$undef$define) . ./whoa; eval "$var=\$tu";;
+*) eval "$var=$val";;
+esac'
+
+cat <<EOM
+
+Perl can be built to take advantage of threads, on some systems.
+To do so, Configure must be run with -Dusethreads.
+(See README.threads for details.)
+EOM
+case "$usethreads" in
+$define|true|[yY]*) dflt='y';;
+*) dflt='n';;
+esac
+rp='Build a threading Perl?'
+. ./myread
+case "$ans" in
+y|Y) val="$define" ;;
+*) val="$undef" ;;
+esac
+set usethreads
+eval $setvar
+: Look for a hint-file generated 'call-back-unit'. Now that the
+: user has specified if a threading perl is to be built, we may need
+: to set or change some other defaults.
+if $test -f usethreads.cbu; then
+ . ./usethreads.cbu
+fi
+case "$d_oldpthreads" in
+'') : Configure tests would be welcome here. For now, assume undef.
+ val="$undef" ;;
+*) val="$d_oldpthreads" ;;
+esac
+set d_oldpthreads
+eval $setvar
+
+: determine the architecture name
+echo " "
+if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then
+ tarch=`arch`"-$osname"
+elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then
+ if uname -m > tmparch 2>&1 ; then
+ tarch=`$sed -e 's/ *$//' -e 's/ /_/g' \
+ -e 's/$/'"-$osname/" tmparch`
+ else
+ tarch="$osname"
+ fi
+ $rm -f tmparch
+else
+ tarch="$osname"
+fi
+case "$myarchname" in
+''|"$tarch") ;;
+*)
+ echo "(Your architecture name used to be $myarchname.)"
+ archname=''
+ ;;
+esac
+case "$archname" in
+'') dflt="$tarch";;
+*) dflt="$archname";;
+esac
+rp='What is your architecture name'
+. ./myread
+case "$usethreads" in
+$define) echo "Threads selected." >&4
+ case "$ans" in
+ *-thread) echo "...and architecture name already ends in -thread." >&4
+ archname="$ans"
+ ;;
+ *) archname="$ans-thread"
+ echo "...setting architecture name to $archname." >&4
+ ;;
+ esac
+ ;;
+*) archname="$ans" ;;
+esac
+myarchname="$tarch"
+: is AFS running?
+echo " "
+case "$afs" in
+$define|true) afs=true ;;
+$undef|false) afs=false ;;
+*) if test -d /afs; then
+ afs=true
+ else
+ afs=false
+ fi
+ ;;
+esac
+if $afs; then
+ echo "AFS may be running... I'll be extra cautious then..." >&4
+else
+ echo "AFS does not seem to be running..." >&4
+fi
+
+: decide how portable to be. Allow command line overrides.
+case "$d_portable" in
+"$undef") ;;
+*) d_portable="$define" ;;
+esac
+
+: set up shell script to do ~ expansion
+cat >filexp <<EOSS
+$startsh
+: expand filename
+case "\$1" in
+ ~/*|~)
+ echo \$1 | $sed "s|~|\${HOME-\$LOGDIR}|"
+ ;;
+ ~*)
+ if $test -f /bin/csh; then
+ /bin/csh -f -c "glob \$1"
+ failed=\$?
+ echo ""
+ exit \$failed
+ else
+ name=\`$expr x\$1 : '..\([^/]*\)'\`
+ dir=\`$sed -n -e "/^\${name}:/{s/^[^:]*:[^:]*:[^:]*:[^:]*:[^:]*:\([^:]*\).*"'\$'"/\1/" -e p -e q -e '}' </etc/passwd\`
+ if $test ! -d "\$dir"; then
+ me=\`basename \$0\`
+ echo "\$me: can't locate home directory for: \$name" >&2
+ exit 1
+ fi
+ case "\$1" in
+ */*)
+ echo \$dir/\`$expr x\$1 : '..[^/]*/\(.*\)'\`
+ ;;
+ *)
+ echo \$dir
+ ;;
+ esac
+ fi
+ ;;
+*)
+ echo \$1
+ ;;
+esac
+EOSS
+chmod +x filexp
+$eunicefix filexp
+
+: now set up to get a file name
+cat <<EOS >getfile
+$startsh
+EOS
+cat <<'EOSC' >>getfile
+tilde=''
+fullpath=''
+already=''
+skip=''
+none_ok=''
+exp_file=''
+nopath_ok=''
+orig_rp="$rp"
+orig_dflt="$dflt"
+
+case "$fn" in
+*\(*)
+ expr $fn : '.*(\(.*\)).*' | tr ',' $trnl >getfile.ok
+ fn=`echo $fn | sed 's/(.*)//'`
+ ;;
+esac
+
+case "$fn" in
+*:*)
+ loc_file=`expr $fn : '.*:\(.*\)'`
+ fn=`expr $fn : '\(.*\):.*'`
+ ;;
+esac
+
+case "$fn" in
+*~*) tilde=true;;
+esac
+case "$fn" in
+*/*) fullpath=true;;
+esac
+case "$fn" in
+*+*) skip=true;;
+esac
+case "$fn" in
+*n*) none_ok=true;;
+esac
+case "$fn" in
+*e*) exp_file=true;;
+esac
+case "$fn" in
+*p*) nopath_ok=true;;
+esac
+
+case "$fn" in
+*f*) type='File';;
+*d*) type='Directory';;
+*l*) type='Locate';;
+esac
+
+what="$type"
+case "$what" in
+Locate) what='File';;
+esac
+
+case "$exp_file" in
+'')
+ case "$d_portable" in
+ "$define") ;;
+ *) exp_file=true;;
+ esac
+ ;;
+esac
+
+cd ..
+while test "$type"; do
+ redo=''
+ rp="$orig_rp"
+ dflt="$orig_dflt"
+ case "$tilde" in
+ true) rp="$rp (~name ok)";;
+ esac
+ . UU/myread
+ if test -f UU/getfile.ok && \
+ $contains "^$ans\$" UU/getfile.ok >/dev/null 2>&1
+ then
+ value="$ans"
+ ansexp="$ans"
+ break
+ fi
+ case "$ans" in
+ none)
+ value=''
+ ansexp=''
+ case "$none_ok" in
+ true) type='';;
+ esac
+ ;;
+ *)
+ case "$tilde" in
+ '') value="$ans"
+ ansexp="$ans";;
+ *)
+ value=`UU/filexp $ans`
+ case $? in
+ 0)
+ if test "$ans" != "$value"; then
+ echo "(That expands to $value on this system.)"
+ fi
+ ;;
+ *) value="$ans";;
+ esac
+ ansexp="$value"
+ case "$exp_file" in
+ '') value="$ans";;
+ esac
+ ;;
+ esac
+ case "$fullpath" in
+ true)
+ case "$ansexp" in
+ /*) value="$ansexp" ;;
+ *)
+ redo=true
+ case "$already" in
+ true)
+ echo "I shall only accept a full path name, as in /bin/ls." >&4
+ echo "Use a ! shell escape if you wish to check pathnames." >&4
+ ;;
+ *)
+ echo "Please give a full path name, starting with slash." >&4
+ case "$tilde" in
+ true)
+ echo "Note that using ~name is ok provided it expands well." >&4
+ already=true
+ ;;
+ esac
+ esac
+ ;;
+ esac
+ ;;
+ esac
+ case "$redo" in
+ '')
+ case "$type" in
+ File)
+ if test -f "$ansexp"; then
+ type=''
+ elif test -r "$ansexp" || (test -h "$ansexp") >/dev/null 2>&1
+ then
+ echo "($value is not a plain file, but that's ok.)"
+ type=''
+ fi
+ ;;
+ Directory)
+ if test -d "$ansexp"; then
+ type=''
+ fi
+ ;;
+ Locate)
+ if test -d "$ansexp"; then
+ echo "(Looking for $loc_file in directory $value.)"
+ value="$value/$loc_file"
+ ansexp="$ansexp/$loc_file"
+ fi
+ if test -f "$ansexp"; then
+ type=''
+ fi
+ case "$nopath_ok" in
+ true) case "$value" in
+ */*) ;;
+ *) echo "Assuming $value will be in people's path."
+ type=''
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+ esac
+
+ case "$skip" in
+ true) type='';
+ esac
+
+ case "$type" in
+ '') ;;
+ *)
+ if test "$fastread" = yes; then
+ dflt=y
+ else
+ dflt=n
+ fi
+ rp="$what $value doesn't exist. Use that name anyway?"
+ . UU/myread
+ dflt=''
+ case "$ans" in
+ y*) type='';;
+ *) echo " ";;
+ esac
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+ esac
+done
+cd UU
+ans="$value"
+rp="$orig_rp"
+dflt="$orig_dflt"
+rm -f getfile.ok
+EOSC
+
+: determine root of directory hierarchy where package will be installed.
+case "$prefix" in
+'')
+ dflt=`./loc . /usr/local /usr/local /local /opt /usr`
+ ;;
+*)
+ dflt="$prefix"
+ ;;
+esac
+$cat <<EOM
+
+By default, $package will be installed in $dflt/bin, manual
+pages under $dflt/man, etc..., i.e. with $dflt as prefix for
+all installation directories. Typically set to /usr/local, but you
+may choose /usr if you wish to install $package among your system
+binaries. If you wish to have binaries under /bin but manual pages
+under /usr/local/man, that's ok: you will be prompted separately
+for each of the installation directories, the prefix being only used
+to set the defaults.
+
+EOM
+fn=d~
+rp='Installation prefix to use?'
+. ./getfile
+oldprefix=''
+case "$prefix" in
+'') ;;
+*)
+ case "$ans" in
+ "$prefix") ;;
+ *) oldprefix="$prefix";;
+ esac
+ ;;
+esac
+prefix="$ans"
+prefixexp="$ansexp"
+
+: set the prefixit variable, to compute a suitable default value
+prefixit='case "$3" in
+""|none)
+ case "$oldprefix" in
+ "") eval "$1=\"\$$2\"";;
+ *)
+ case "$3" in
+ "") eval "$1=";;
+ none)
+ eval "tp=\"\$$2\"";
+ case "$tp" in
+ ""|" ") eval "$1=\"\$$2\"";;
+ *) eval "$1=";;
+ esac;;
+ esac;;
+ esac;;
+*)
+ eval "tp=\"$oldprefix-\$$2-\""; eval "tp=\"$tp\"";
+ case "$tp" in
+ --|/*--|\~*--) eval "$1=\"$prefix/$3\"";;
+ /*-$oldprefix/*|\~*-$oldprefix/*)
+ eval "$1=\`echo \$$2 | sed \"s,^$oldprefix,$prefix,\"\`";;
+ *) eval "$1=\"\$$2\"";;
+ esac;;
+esac'
+
+: set the base revision
+baserev=5.0
+
+: get the patchlevel
+echo " "
+echo "Getting the current patchlevel..." >&4
+if $test -r $rsrc/patchlevel.h;then
+ patchlevel=`awk '/define[ ]+PATCHLEVEL/ {print $3}' $rsrc/patchlevel.h`
+ subversion=`awk '/define[ ]+SUBVERSION/ {print $3}' $rsrc/patchlevel.h`
+else
+ patchlevel=0
+ subversion=0
+fi
+$echo $n "(You have $package" $c
+case "$package" in
+"*$baserev") ;;
+*) $echo $n " $baserev" $c ;;
+esac
+$echo $n " patchlevel $patchlevel" $c
+test 0 -eq "$subversion" || $echo $n " subversion $subversion" $c
+echo ".)"
+
+if test 0 -eq "$subversion"; then
+ version=`LC_ALL=C; export LC_ALL; \
+ echo $baserev $patchlevel | \
+ $awk '{ printf "%.3f\n", $1 + $2/1000.0 }'`
+else
+ version=`LC_ALL=C; export LC_ALL; \
+ echo $baserev $patchlevel $subversion | \
+ $awk '{ printf "%.5f\n", $1 + $2/1000.0 + $3/100000.0 }'`
+fi
+: Figure out perl API version. Perhaps this should be in patchlevel.h
+if test "$subversion" -lt 50; then
+ apiversion=`LC_ALL=C; export LC_ALL; \
+ echo $baserev $patchlevel | \
+ $awk '{ printf "%.3f\n", $1 + $2/1000.0 }'`
+else
+ apiversion="$version"
+fi
+
+: determine where private library files go
+: Usual default is /usr/local/lib/perl5/$version.
+: Also allow things like /opt/perl/lib/$version, since
+: /opt/perl/lib/perl5... would be redundant.
+case "$prefix" in
+*perl*) set dflt privlib lib/$version ;;
+*) set dflt privlib lib/$package/$version ;;
+esac
+eval $prefixit
+$cat <<EOM
+
+There are some auxiliary files for $package that need to be put into a
+private library directory that is accessible by everyone.
+
+EOM
+fn=d~+
+rp='Pathname where the private library files will reside?'
+. ./getfile
+if $test "X$privlibexp" != "X$ansexp"; then
+ installprivlib=''
+fi
+privlib="$ans"
+privlibexp="$ansexp"
+if $afs; then
+ $cat <<EOM
+
+Since you are running AFS, I need to distinguish the directory in which
+private files reside from the directory in which they are installed (and from
+which they are presumably copied to the former directory by occult means).
+
+EOM
+ case "$installprivlib" in
+ '') dflt=`echo $privlibexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installprivlib";;
+ esac
+ fn=de~
+ rp='Where will private files be installed?'
+ . ./getfile
+ installprivlib="$ans"
+else
+ installprivlib="$privlibexp"
+fi
+
+: set the prefixup variable, to restore leading tilda escape
+prefixup='case "$prefixexp" in
+"$prefix") ;;
+*) eval "$1=\`echo \$$1 | sed \"s,^$prefixexp,$prefix,\"\`";;
+esac'
+
+: determine where public architecture dependent libraries go
+set archlib archlib
+eval $prefixit
+: privlib default is /usr/local/lib/$package/$version
+: archlib default is /usr/local/lib/$package/$version/$archname
+: privlib may have an optional trailing /share.
+tdflt=`echo $privlib | $sed 's,/share$,,'`
+tdflt=$tdflt/$archname
+case "$archlib" in
+'') dflt=$tdflt
+ ;;
+*) dflt="$archlib"
+ ;;
+esac
+cat <<EOM
+
+$spackage contains architecture-dependent library files. If you are
+sharing libraries in a heterogeneous environment, you might store
+these files in a separate location. Otherwise, you can just include
+them with the rest of the public library files.
+
+EOM
+fn=d+~
+rp='Where do you want to put the public architecture-dependent libraries?'
+. ./getfile
+archlib="$ans"
+archlibexp="$ansexp"
+
+if $afs; then
+ $cat <<EOM
+
+Since you are running AFS, I need to distinguish the directory in
+which architecture-dependent library files reside from the directory
+in which they are installed (and from which they are presumably copied
+to the former directory by occult means).
+
+EOM
+ case "$installarchlib" in
+ '') dflt=`echo $archlibexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installarchlib";;
+ esac
+ fn=de~
+ rp='Where will architecture-dependent library files be installed?'
+ . ./getfile
+ installarchlib="$ans"
+else
+ installarchlib="$archlibexp"
+fi
+if $test X"$archlib" = X"$privlib"; then
+ d_archlib="$undef"
+else
+ d_archlib="$define"
+fi
+
+: make some quick guesses about what we are up against
+echo " "
+$echo $n "Hmm... $c"
+echo exit 1 >bsd
+echo exit 1 >usg
+echo exit 1 >v7
+echo exit 1 >osf1
+echo exit 1 >eunice
+echo exit 1 >xenix
+echo exit 1 >venix
+echo exit 1 >os2
+d_bsd="$undef"
+$cat /usr/include/signal.h /usr/include/sys/signal.h >foo 2>/dev/null
+if test -f /osf_boot || $contains 'OSF/1' /usr/include/ctype.h >/dev/null 2>&1
+then
+ echo "Looks kind of like an OSF/1 system, but we'll see..."
+ echo exit 0 >osf1
+elif test `echo abc | tr a-z A-Z` = Abc ; then
+ xxx=`./loc addbib blurfl $pth`
+ if $test -f $xxx; then
+ echo "Looks kind of like a USG system with BSD features, but we'll see..."
+ echo exit 0 >bsd
+ echo exit 0 >usg
+ else
+ if $contains SIGTSTP foo >/dev/null 2>&1 ; then
+ echo "Looks kind of like an extended USG system, but we'll see..."
+ else
+ echo "Looks kind of like a USG system, but we'll see..."
+ fi
+ echo exit 0 >usg
+ fi
+elif $contains SIGTSTP foo >/dev/null 2>&1 ; then
+ echo "Looks kind of like a BSD system, but we'll see..."
+ d_bsd="$define"
+ echo exit 0 >bsd
+else
+ echo "Looks kind of like a Version 7 system, but we'll see..."
+ echo exit 0 >v7
+fi
+case "$eunicefix" in
+*unixtovms*)
+ $cat <<'EOI'
+There is, however, a strange, musty smell in the air that reminds me of
+something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit.
+EOI
+ echo exit 0 >eunice
+ d_eunice="$define"
+: it so happens the Eunice I know will not run shell scripts in Unix format
+ ;;
+*)
+ echo " "
+ echo "Congratulations. You aren't running Eunice."
+ d_eunice="$undef"
+ ;;
+esac
+: Detect OS2. The p_ variable is set above in the Head.U unit.
+case "$p_" in
+:) ;;
+*)
+ $cat <<'EOI'
+I have the feeling something is not exactly right, however...don't tell me...
+lemme think...does HAL ring a bell?...no, of course, you're only running OS/2!
+EOI
+ echo exit 0 >os2
+ ;;
+esac
+if test -f /xenix; then
+ echo "Actually, this looks more like a XENIX system..."
+ echo exit 0 >xenix
+ d_xenix="$define"
+else
+ echo " "
+ echo "It's not Xenix..."
+ d_xenix="$undef"
+fi
+chmod +x xenix
+$eunicefix xenix
+if test -f /venix; then
+ echo "Actually, this looks more like a VENIX system..."
+ echo exit 0 >venix
+else
+ echo " "
+ if ./xenix; then
+ : null
+ else
+ echo "Nor is it Venix..."
+ fi
+fi
+chmod +x bsd usg v7 osf1 eunice xenix venix os2
+$eunicefix bsd usg v7 osf1 eunice xenix venix os2
+$rm -f foo
+
+: see if setuid scripts can be secure
+$cat <<EOM
+
+Some kernels have a bug that prevents setuid #! scripts from being
+secure. Some sites have disabled setuid #! scripts because of this.
+
+First let's decide if your kernel supports secure setuid #! scripts.
+(If setuid #! scripts would be secure but have been disabled anyway,
+don't say that they are secure if asked.)
+
+EOM
+
+val="$undef"
+if $test -d /dev/fd; then
+ echo "#!$ls" >reflect
+ chmod +x,u+s reflect
+ ./reflect >flect 2>&1
+ if $contains "/dev/fd" flect >/dev/null; then
+ echo "Congratulations, your kernel has secure setuid scripts!" >&4
+ val="$define"
+ else
+ $cat <<EOM
+If you are not sure if they are secure, I can check but I'll need a
+username and password different from the one you are using right now.
+If you don't have such a username or don't want me to test, simply
+enter 'none'.
+
+EOM
+ rp='Other username to test security of setuid scripts with?'
+ dflt='none'
+ . ./myread
+ case "$ans" in
+ n|none)
+ case "$d_suidsafe" in
+ '') echo "I'll assume setuid scripts are *not* secure." >&4
+ dflt=n;;
+ "$undef")
+ echo "Well, the $hint value is *not* secure." >&4
+ dflt=n;;
+ *) echo "Well, the $hint value *is* secure." >&4
+ dflt=y;;
+ esac
+ ;;
+ *)
+ $rm -f reflect flect
+ echo "#!$ls" >reflect
+ chmod +x,u+s reflect
+ echo >flect
+ chmod a+w flect
+ echo '"su" will (probably) prompt you for '"$ans's password."
+ su $ans -c './reflect >flect'
+ if $contains "/dev/fd" flect >/dev/null; then
+ echo "Okay, it looks like setuid scripts are secure." >&4
+ dflt=y
+ else
+ echo "I don't think setuid scripts are secure." >&4
+ dflt=n
+ fi
+ ;;
+ esac
+ rp='Does your kernel have *secure* setuid scripts?'
+ . ./myread
+ case "$ans" in
+ [yY]*) val="$define";;
+ *) val="$undef";;
+ esac
+ fi
+else
+ echo "I don't think setuid scripts are secure (no /dev/fd directory)." >&4
+ echo "(That's for file descriptors, not floppy disks.)"
+ val="$undef"
+fi
+set d_suidsafe
+eval $setvar
+
+$rm -f reflect flect
+
+: now see if they want to do setuid emulation
+echo " "
+val="$undef"
+case "$d_suidsafe" in
+"$define")
+ val="$undef"
+ echo "No need to emulate SUID scripts since they are secure here." >& 4
+ ;;
+*)
+ $cat <<EOM
+Some systems have disabled setuid scripts, especially systems where
+setuid scripts cannot be secure. On systems where setuid scripts have
+been disabled, the setuid/setgid bits on scripts are currently
+useless. It is possible for $package to detect those bits and emulate
+setuid/setgid in a secure fashion. This emulation will only work if
+setuid scripts have been disabled in your kernel.
+
+EOM
+ case "$d_dosuid" in
+ "$define") dflt=y ;;
+ *) dflt=n ;;
+ esac
+ rp="Do you want to do setuid/setgid emulation?"
+ . ./myread
+ case "$ans" in
+ [yY]*) val="$define";;
+ *) val="$undef";;
+ esac
+ ;;
+esac
+set d_dosuid
+eval $setvar
+
+: determine where manual pages are on this system
+echo " "
+case "$sysman" in
+'')
+ syspath='/usr/man/man1 /usr/man/mann /usr/man/manl /usr/man/local/man1'
+ syspath="$syspath /usr/man/u_man/man1 /usr/share/man/man1"
+ syspath="$syspath /usr/catman/u_man/man1 /usr/man/l_man/man1"
+ syspath="$syspath /usr/local/man/u_man/man1 /usr/local/man/l_man/man1"
+ syspath="$syspath /usr/man/man.L /local/man/man1 /usr/local/man/man1"
+ sysman=`./loc . /usr/man/man1 $syspath`
+ ;;
+esac
+if $test -d "$sysman"; then
+ echo "System manual is in $sysman." >&4
+else
+ echo "Could not find manual pages in source form." >&4
+fi
+
+: see what memory models we can support
+case "$models" in
+'')
+ $cat >pdp11.c <<'EOP'
+main() {
+#ifdef pdp11
+ exit(0);
+#else
+ exit(1);
+#endif
+}
+EOP
+ ( cc -o pdp11 pdp11.c ) >/dev/null 2>&1
+ if $test -f pdp11 && ./pdp11 2>/dev/null; then
+ dflt='unsplit split'
+ else
+ tans=`./loc . X /lib/small /lib/large /usr/lib/small /usr/lib/large /lib/medium /usr/lib/medium /lib/huge`
+ case "$tans" in
+ X) dflt='none';;
+ *) if $test -d /lib/small || $test -d /usr/lib/small; then
+ dflt='small'
+ else
+ dflt=''
+ fi
+ if $test -d /lib/medium || $test -d /usr/lib/medium; then
+ dflt="$dflt medium"
+ fi
+ if $test -d /lib/large || $test -d /usr/lib/large; then
+ dflt="$dflt large"
+ fi
+ if $test -d /lib/huge || $test -d /usr/lib/huge; then
+ dflt="$dflt huge"
+ fi
+ esac
+ fi;;
+*) dflt="$models";;
+esac
+$cat <<EOM
+
+Some systems have different model sizes. On most systems they are called
+small, medium, large, and huge. On the PDP11 they are called unsplit and
+split. If your system doesn't support different memory models, say "none".
+If you wish to force everything to one memory model, say "none" here and
+put the appropriate flags later when it asks you for other cc and ld flags.
+Venix systems may wish to put "none" and let the compiler figure things out.
+(In the following question multiple model names should be space separated.)
+
+The default for most systems is "none".
+
+EOM
+rp="Which memory models are supported?"
+. ./myread
+models="$ans"
+
+case "$models" in
+none)
+ small=''
+ medium=''
+ large=''
+ huge=''
+ unsplit=''
+ split=''
+ ;;
+*split)
+ case "$split" in
+ '') if $contains '\-i' $sysman/ld.1 >/dev/null 2>&1 || \
+ $contains '\-i' $sysman/cc.1 >/dev/null 2>&1; then
+ dflt='-i'
+ else
+ dflt='none'
+ fi;;
+ *) dflt="$split";;
+ esac
+ rp="What flag indicates separate I and D space?"
+ . ./myread
+ tans="$ans"
+ case "$tans" in
+ none) tans='';;
+ esac
+ split="$tans"
+ unsplit='';;
+*large*|*small*|*medium*|*huge*)
+ case "$models" in
+ *large*)
+ case "$large" in
+ '') dflt='-Ml';;
+ *) dflt="$large";;
+ esac
+ rp="What flag indicates large model?"
+ . ./myread
+ tans="$ans"
+ case "$tans" in
+ none) tans='';
+ esac
+ large="$tans";;
+ *) large='';;
+ esac
+ case "$models" in
+ *huge*) case "$huge" in
+ '') dflt='-Mh';;
+ *) dflt="$huge";;
+ esac
+ rp="What flag indicates huge model?"
+ . ./myread
+ tans="$ans"
+ case "$tans" in
+ none) tans='';
+ esac
+ huge="$tans";;
+ *) huge="$large";;
+ esac
+ case "$models" in
+ *medium*) case "$medium" in
+ '') dflt='-Mm';;
+ *) dflt="$medium";;
+ esac
+ rp="What flag indicates medium model?"
+ . ./myread
+ tans="$ans"
+ case "$tans" in
+ none) tans='';
+ esac
+ medium="$tans";;
+ *) medium="$large";;
+ esac
+ case "$models" in
+ *small*) case "$small" in
+ '') dflt='none';;
+ *) dflt="$small";;
+ esac
+ rp="What flag indicates small model?"
+ . ./myread
+ tans="$ans"
+ case "$tans" in
+ none) tans='';
+ esac
+ small="$tans";;
+ *) small='';;
+ esac
+ ;;
+*)
+ echo "Unrecognized memory models--you may have to edit Makefile.SH" >&4
+ ;;
+esac
+$rm -f pdp11.* pdp11
+
+: see if we need a special compiler
+echo " "
+if ./usg; then
+ case "$cc" in
+ '') case "$Mcc" in
+ /*) dflt='Mcc';;
+ *) case "$large" in
+ -M*) dflt='cc';;
+ *) if $contains '\-M' $sysman/cc.1 >/dev/null 2>&1 ; then
+ if $contains '\-M' $sysman/cpp.1 >/dev/null 2>&1; then
+ dflt='cc'
+ else
+ dflt='cc -M'
+ fi
+ else
+ dflt='cc'
+ fi;;
+ esac;;
+ esac;;
+ *) dflt="$cc";;
+ esac
+ case "$dflt" in
+ *M*) $cat <<'EOM'
+On some older systems the default C compiler will not resolve multiple global
+references that happen to have the same name. On some such systems the "Mcc"
+command may be used to force these to be resolved. On other systems a "cc -M"
+command is required. (Note that the -M flag on other systems indicates a
+memory model to use!) If you have the Gnu C compiler, you might wish to use
+that instead.
+
+EOM
+ ;;
+ esac
+ rp="Use which C compiler?"
+ . ./myread
+ cc="$ans"
+else
+ case "$cc" in
+ '') dflt=cc;;
+ *) dflt="$cc";;
+ esac
+ rp="Use which C compiler?"
+ . ./myread
+ cc="$ans"
+fi
+: Look for a hint-file generated 'call-back-unit'. Now that the
+: user has specified the compiler, we may need to set or change some
+: other defaults.
+if $test -f cc.cbu; then
+ . ./cc.cbu
+fi
+echo " "
+echo "Checking for GNU cc in disguise and/or its version number..." >&4
+$cat >gccvers.c <<EOM
+#include <stdio.h>
+int main() {
+#ifdef __GNUC__
+#ifdef __VERSION__
+ printf("%s\n", __VERSION__);
+#else
+ printf("%s\n", "1");
+#endif
+#endif
+ exit(0);
+}
+EOM
+if $cc -o gccvers gccvers.c >/dev/null 2>&1; then
+ gccversion=`./gccvers`
+ case "$gccversion" in
+ '') echo "You are not using GNU cc." ;;
+ *) echo "You are using GNU cc $gccversion." ;;
+ esac
+else
+ echo " "
+ echo "*** WHOA THERE!!! ***" >&4
+ echo " Your C compiler \"$cc\" doesn't seem to be working!" >&4
+ case "$knowitall" in
+ '')
+ echo " You'd better start hunting for one and let me know about it." >&4
+ exit 1
+ ;;
+ esac
+fi
+$rm -f gccvers*
+case "$gccversion" in
+1*) cpp=`./loc gcc-cpp $cpp $pth` ;;
+esac
+
+: What should the include directory be ?
+echo " "
+$echo $n "Hmm... $c"
+dflt='/usr/include'
+incpath=''
+mips_type=''
+if $test -f /bin/mips && /bin/mips; then
+ echo "Looks like a MIPS system..."
+ $cat >usr.c <<'EOCP'
+#ifdef SYSTYPE_BSD43
+/bsd43
+#endif
+EOCP
+ if $cc -E usr.c > usr.out && $contains / usr.out >/dev/null 2>&1; then
+ dflt='/bsd43/usr/include'
+ incpath='/bsd43'
+ mips_type='BSD 4.3'
+ else
+ mips_type='System V'
+ fi
+ $rm -f usr.c usr.out
+ echo "and you're compiling with the $mips_type compiler and libraries."
+ xxx_prompt=y
+ echo "exit 0" >mips
+else
+ echo "Doesn't look like a MIPS system."
+ xxx_prompt=n
+ echo "exit 1" >mips
+fi
+chmod +x mips
+$eunicefix mips
+case "$usrinc" in
+'') ;;
+*) dflt="$usrinc";;
+esac
+case "$xxx_prompt" in
+y) fn=d/
+ echo " "
+ rp='Where are the include files you want to use?'
+ . ./getfile
+ usrinc="$ans"
+ ;;
+*) usrinc="$dflt"
+ ;;
+esac
+
+: see how we invoke the C preprocessor
+echo " "
+echo "Now, how can we feed standard input to your C preprocessor..." >&4
+cat <<'EOT' >testcpp.c
+#define ABC abc
+#define XYZ xyz
+ABC.XYZ
+EOT
+cd ..
+echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin
+chmod 755 cppstdin
+wrapper=`pwd`/cppstdin
+ok='false'
+cd UU
+
+if $test "X$cppstdin" != "X" && \
+ $cppstdin $cppminus <testcpp.c >testcpp.out 2>&1 && \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1
+then
+ echo "You used to use $cppstdin $cppminus so we'll use that again."
+ case "$cpprun" in
+ '') echo "But let's see if we can live without a wrapper..." ;;
+ *)
+ if $cpprun $cpplast <testcpp.c >testcpp.out 2>&1 && \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1
+ then
+ echo "(And we'll use $cpprun $cpplast to preprocess directly.)"
+ ok='true'
+ else
+ echo "(However, $cpprun $cpplast does not work, let's see...)"
+ fi
+ ;;
+ esac
+else
+ case "$cppstdin" in
+ '') ;;
+ *)
+ echo "Good old $cppstdin $cppminus does not seem to be of any help..."
+ ;;
+ esac
+fi
+
+if $ok; then
+ : nothing
+elif echo 'Maybe "'"$cc"' -E" will work...'; \
+ $cc -E <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Yup, it does."
+ x_cpp="$cc -E"
+ x_minus='';
+elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \
+ $cc -E - <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Yup, it does."
+ x_cpp="$cc -E"
+ x_minus='-';
+elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \
+ $cc -P <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Yipee, that works!"
+ x_cpp="$cc -P"
+ x_minus='';
+elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \
+ $cc -P - <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "At long last!"
+ x_cpp="$cc -P"
+ x_minus='-';
+elif echo 'No such luck, maybe "'$cpp'" will work...'; \
+ $cpp <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "It works!"
+ x_cpp="$cpp"
+ x_minus='';
+elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \
+ $cpp - <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "Hooray, it works! I was beginning to wonder."
+ x_cpp="$cpp"
+ x_minus='-';
+elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \
+ $wrapper <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ x_cpp="$wrapper"
+ x_minus=''
+ echo "Eureka!"
+else
+ dflt=''
+ rp="No dice. I can't find a C preprocessor. Name one:"
+ . ./myread
+ x_cpp="$ans"
+ x_minus=''
+ $x_cpp <testcpp.c >testcpp.out 2>&1
+ if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then
+ echo "OK, that will do." >&4
+ else
+echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4
+ exit 1
+ fi
+fi
+
+case "$ok" in
+false)
+ cppstdin="$x_cpp"
+ cppminus="$x_minus"
+ cpprun="$x_cpp"
+ cpplast="$x_minus"
+ set X $x_cpp
+ shift
+ case "$1" in
+ "$cpp")
+ echo "Perhaps can we force $cc -E using a wrapper..."
+ if $wrapper <testcpp.c >testcpp.out 2>&1; \
+ $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1
+ then
+ echo "Yup, we can."
+ cppstdin="$wrapper"
+ cppminus='';
+ else
+ echo "Nope, we'll have to live without it..."
+ fi
+ ;;
+ esac
+ case "$cpprun" in
+ "$wrapper")
+ cpprun=''
+ cpplast=''
+ ;;
+ esac
+ ;;
+esac
+
+case "$cppstdin" in
+"$wrapper") ;;
+*) $rm -f $wrapper;;
+esac
+$rm -f testcpp.c testcpp.out
+
+: Set private lib path
+case "$plibpth" in
+'') if ./mips; then
+ plibpth="$incpath/usr/lib /usr/local/lib /usr/ccs/lib"
+ fi;;
+esac
+case "$libpth" in
+' ') dlist='';;
+'') dlist="$loclibpth $plibpth $glibpth";;
+*) dlist="$libpth";;
+esac
+
+: Now check and see which directories actually exist, avoiding duplicates
+libpth=''
+for xxx in $dlist
+do
+ if $test -d $xxx; then
+ case " $libpth " in
+ *" $xxx "*) ;;
+ *) libpth="$libpth $xxx";;
+ esac
+ fi
+done
+$cat <<'EOM'
+
+Some systems have incompatible or broken versions of libraries. Among
+the directories listed in the question below, please remove any you
+know not to be holding relevant libraries, and add any that are needed.
+Say "none" for none.
+
+EOM
+case "$libpth" in
+'') dflt='none';;
+*)
+ set X $libpth
+ shift
+ dflt=${1+"$@"}
+ ;;
+esac
+rp="Directories to use for library searches?"
+. ./myread
+case "$ans" in
+none) libpth=' ';;
+*) libpth="$ans";;
+esac
+
+: compute shared library extension
+case "$so" in
+'')
+ if xxx=`./loc libc.sl X $libpth`; $test -f "$xxx"; then
+ dflt='sl'
+ else
+ dflt='so'
+ fi
+ ;;
+*) dflt="$so";;
+esac
+$cat <<EOM
+
+On some systems, shared libraries may be available. Answer 'none' if
+you want to suppress searching of shared libraries for the remaining
+of this configuration.
+
+EOM
+rp='What is the file extension used for shared libraries?'
+. ./myread
+so="$ans"
+
+: Define several unixisms.
+: Hints files or command line option can be used to override them.
+: The convoluted testing is in case hints files set either the old
+: or the new name.
+case "$_exe" in
+'') case "$exe_ext" in
+ '') ;;
+ *) _exe="$exe_ext" ;;
+ esac
+ ;;
+esac
+case "$_a" in
+'') case "$lib_ext" in
+ '') _a='.a';;
+ *) _a="$lib_ext" ;;
+ esac
+ ;;
+esac
+case "$_o" in
+'') case "$obj_ext" in
+ '') _o='.o';;
+ *) _o="$obj_ext";;
+ esac
+ ;;
+esac
+case "$p_" in
+'') case "$path_sep" in
+ '') p_=':';;
+ *) p_="$path_sep";;
+ esac
+ ;;
+esac
+exe_ext=$_exe
+lib_ext=$_a
+obj_ext=$_o
+path_sep=$p_
+
+: Which makefile gets called first. This is used by make depend.
+case "$firstmakefile" in
+'') firstmakefile='makefile';;
+esac
+
+: Looking for optional libraries
+echo " "
+echo "Checking for optional libraries..." >&4
+case "$libs" in
+' '|'') dflt='';;
+*) dflt="$libs";;
+esac
+case "$libswanted" in
+'') libswanted='c_s';;
+esac
+for thislib in $libswanted; do
+
+ if xxx=`./loc lib$thislib.$so.[0-9]'*' X $libpth`; $test -f "$xxx"; then
+ echo "Found -l$thislib (shared)."
+ case " $dflt " in
+ *"-l$thislib "*);;
+ *) dflt="$dflt -l$thislib";;
+ esac
+ elif xxx=`./loc lib$thislib.$so X $libpth` ; $test -f "$xxx"; then
+ echo "Found -l$thislib (shared)."
+ case " $dflt " in
+ *"-l$thislib "*);;
+ *) dflt="$dflt -l$thislib";;
+ esac
+ elif xxx=`./loc lib$thislib$_a X $libpth`; $test -f "$xxx"; then
+ echo "Found -l$thislib."
+ case " $dflt " in
+ *"-l$thislib "*);;
+ *) dflt="$dflt -l$thislib";;
+ esac
+ elif xxx=`./loc $thislib$_a X $libpth`; $test -f "$xxx"; then
+ echo "Found -l$thislib."
+ case " $dflt " in
+ *"-l$thislib "*);;
+ *) dflt="$dflt -l$thislib";;
+ esac
+ elif xxx=`./loc lib${thislib}_s$_a X $libpth`; $test -f "$xxx"; then
+ echo "Found -l${thislib}_s."
+ case " $dflt " in
+ *"-l$thislib "*);;
+ *) dflt="$dflt -l${thislib}_s";;
+ esac
+ elif xxx=`./loc Slib$thislib$_a X $xlibpth`; $test -f "$xxx"; then
+ echo "Found -l$thislib."
+ case " $dflt " in
+ *"-l$thislib "*);;
+ *) dflt="$dflt -l$thislib";;
+ esac
+ else
+ echo "No -l$thislib."
+ fi
+done
+set X $dflt
+shift
+dflt="$*"
+case "$libs" in
+'') dflt="$dflt";;
+*) dflt="$libs";;
+esac
+case "$dflt" in
+' '|'') dflt='none';;
+esac
+
+$cat <<EOM
+
+Some versions of Unix support shared libraries, which make executables smaller
+but make load time slightly longer.
+
+On some systems, mostly System V Release 3's, the shared library is included
+by putting the option "-lc_s" as the last thing on the cc command line when
+linking. Other systems use shared libraries by default. There may be other
+libraries needed to compile $package on your machine as well. If your system
+needs the "-lc_s" option, include it here. Include any other special libraries
+here as well. Say "none" for none.
+EOM
+
+echo " "
+rp="Any additional libraries?"
+. ./myread
+case "$ans" in
+none) libs=' ';;
+*) libs="$ans";;
+esac
+
+: determine optimize, if desired, or use for debug flag also
+case "$optimize" in
+' '|$undef) dflt='none';;
+'') dflt='-O';;
+*) dflt="$optimize";;
+esac
+$cat <<EOH
+
+Some C compilers have problems with their optimizers. By default, $package
+compiles with the -O flag to use the optimizer. Alternately, you might want
+to use the symbolic debugger, which uses the -g flag (on traditional Unix
+systems). Either flag can be specified here. To use neither flag, specify
+the word "none".
+
+EOH
+rp="What optimizer/debugger flag should be used?"
+. ./myread
+optimize="$ans"
+case "$optimize" in
+'none') optimize=" ";;
+esac
+
+dflt=''
+: We will not override a previous value, but we might want to
+: augment a hint file
+case "$hint" in
+none|recommended)
+ case "$gccversion" in
+ 1*) dflt='-fpcc-struct-return' ;;
+ esac
+ case "$optimize" in
+ *-g*) dflt="$dflt -DDEBUGGING";;
+ esac
+ case "$gccversion" in
+ 2*) if test -d /etc/conf/kconfig.d &&
+ $contains _POSIX_VERSION $usrinc/sys/unistd.h >/dev/null 2>&1
+ then
+ dflt="$dflt -posix"
+ fi
+ ;;
+ esac
+ ;;
+esac
+
+case "$mips_type" in
+*BSD*|'') inclwanted="$locincpth $usrinc";;
+*) inclwanted="$locincpth $inclwanted $usrinc/bsd";;
+esac
+for thisincl in $inclwanted; do
+ if $test -d $thisincl; then
+ if $test x$thisincl != x$usrinc; then
+ case "$dflt" in
+ *$thisincl*);;
+ *) dflt="$dflt -I$thisincl";;
+ esac
+ fi
+ fi
+done
+
+inctest='if $contains $2 $usrinc/$1 >/dev/null 2>&1; then
+ xxx=true;
+elif $contains $2 $usrinc/sys/$1 >/dev/null 2>&1; then
+ xxx=true;
+else
+ xxx=false;
+fi;
+if $xxx; then
+ case "$dflt" in
+ *$2*);;
+ *) dflt="$dflt -D$2";;
+ esac;
+fi'
+
+if ./osf1; then
+ set signal.h __LANGUAGE_C__; eval $inctest
+else
+ set signal.h LANGUAGE_C; eval $inctest
+fi
+
+case "$hint" in
+none|recommended) dflt="$ccflags $dflt" ;;
+*) dflt="$ccflags";;
+esac
+
+case "$dflt" in
+''|' ') dflt=none;;
+esac
+$cat <<EOH
+
+Your C compiler may want other flags. For this question you should include
+-I/whatever and -DWHATEVER flags and any other flags used by the C compiler,
+but you should NOT include libraries or ld flags like -lwhatever. If you
+want $package to honor its debug switch, you should include -DDEBUGGING here.
+Your C compiler might also need additional flags, such as -D_POSIX_SOURCE.
+
+To use no flags, specify the word "none".
+
+EOH
+set X $dflt
+shift
+dflt=${1+"$@"}
+rp="Any additional cc flags?"
+. ./myread
+case "$ans" in
+none) ccflags='';;
+*) ccflags="$ans";;
+esac
+
+: the following weeds options from ccflags that are of no interest to cpp
+cppflags="$ccflags"
+case "$gccversion" in
+1*) cppflags="$cppflags -D__GNUC__"
+esac
+case "$mips_type" in
+'');;
+*BSD*) cppflags="$cppflags -DSYSTYPE_BSD43";;
+esac
+case "$cppflags" in
+'');;
+*)
+ echo " "
+ echo "Let me guess what the preprocessor flags are..." >&4
+ set X $cppflags
+ shift
+ cppflags=''
+ $cat >cpp.c <<'EOM'
+#define BLURFL foo
+
+BLURFL xx LFRULB
+EOM
+ previous=''
+ for flag in $*
+ do
+ case "$flag" in
+ -*) ftry="$flag";;
+ *) ftry="$previous $flag";;
+ esac
+ if $cppstdin -DLFRULB=bar $cppflags $ftry $cppminus <cpp.c \
+ >cpp1.out 2>/dev/null && \
+ $cpprun -DLFRULB=bar $cppflags $ftry $cpplast <cpp.c \
+ >cpp2.out 2>/dev/null && \
+ $contains 'foo.*xx.*bar' cpp1.out >/dev/null 2>&1 && \
+ $contains 'foo.*xx.*bar' cpp2.out >/dev/null 2>&1
+ then
+ cppflags="$cppflags $ftry"
+ previous=''
+ else
+ previous="$flag"
+ fi
+ done
+ set X $cppflags
+ shift
+ cppflags=${1+"$@"}
+ case "$cppflags" in
+ *-*) echo "They appear to be: $cppflags";;
+ esac
+ $rm -f cpp.c cpp?.out
+ ;;
+esac
+
+: flags used in final linking phase
+case "$ldflags" in
+'') if ./venix; then
+ dflt='-i -z'
+ else
+ dflt=''
+ fi
+ case "$ccflags" in
+ *-posix*) dflt="$dflt -posix" ;;
+ esac
+ ;;
+*) dflt="$ldflags";;
+esac
+
+: Try to guess additional flags to pick up local libraries.
+for thislibdir in $libpth; do
+ case " $loclibpth " in
+ *" $thislibdir "*)
+ case "$dflt " in
+ *"-L$thislibdir "*) ;;
+ *) dflt="$dflt -L$thislibdir" ;;
+ esac
+ ;;
+ esac
+done
+
+case "$dflt" in
+'') dflt='none' ;;
+esac
+
+$cat <<EOH
+
+Your C linker may need flags. For this question you should
+include -L/whatever and any other flags used by the C linker, but you
+should NOT include libraries like -lwhatever.
+
+Make sure you include the appropriate -L/path flags if your C linker
+does not normally search all of the directories you specified above,
+namely
+ $libpth
+To use no flags, specify the word "none".
+
+EOH
+
+rp="Any additional ld flags (NOT including libraries)?"
+. ./myread
+case "$ans" in
+none) ldflags='';;
+*) ldflags="$ans";;
+esac
+rmlist="$rmlist pdp11"
+
+: coherency check
+echo " "
+echo "Checking your choice of C compiler and flags for coherency..." >&4
+set X $cc $optimize $ccflags -o try $ldflags try.c $libs
+shift
+$cat >try.msg <<EOM
+I've tried to compile and run a simple program with:
+
+ $*
+ ./try
+
+and I got the following output:
+
+EOM
+$cat > try.c <<'EOF'
+#include <stdio.h>
+main() { printf("Ok\n"); exit(0); }
+EOF
+dflt=y
+if sh -c "$cc $optimize $ccflags -o try $ldflags try.c $libs" >>try.msg 2>&1; then
+ if sh -c './try' >>try.msg 2>&1; then
+ xxx=`./try`
+ case "$xxx" in
+ "Ok") dflt=n ;;
+ *) echo 'The program compiled OK, but produced no output.' >> try.msg
+ case " $libs " in
+ *" -lsfio "*)
+ cat >> try.msg <<'EOQS'
+If $libs contains -lsfio, and sfio is mis-configured, then it
+sometimes (apparently) runs and exits with a 0 status, but with no
+output! It may have to do with sfio's use of _exit vs. exit.
+
+EOQS
+ rp="You have a big problem. Shall I abort Configure"
+ dflt=y
+ ;;
+ esac
+ ;;
+ esac
+ else
+ echo "The program compiled OK, but exited with status $?." >>try.msg
+ rp="You have a problem. Shall I abort Configure"
+ dflt=y
+ fi
+else
+ echo "I can't compile the test program." >>try.msg
+ rp="You have a BIG problem. Shall I abort Configure"
+ dflt=y
+fi
+case "$dflt" in
+y)
+ $cat try.msg >&4
+ case "$knowitall" in
+ '')
+ echo "(The supplied flags might be incorrect with this C compiler.)"
+ ;;
+ *) dflt=n;;
+ esac
+ echo " "
+ . ./myread
+ case "$ans" in
+ n*|N*) ;;
+ *) echo "Ok. Stopping Configure." >&4
+ exit 1
+ ;;
+ esac
+ ;;
+n) echo "OK, that should do.";;
+esac
+$rm -f try try.* core
+
+: determine filename position in cpp output
+echo " "
+echo "Computing filename position in cpp output for #include directives..." >&4
+echo '#include <stdio.h>' > foo.c
+$cat >fieldn <<EOF
+$startsh
+$cppstdin $cppflags $cppminus <foo.c 2>/dev/null | \
+$grep '^[ ]*#.*stdio\.h' | \
+while read cline; do
+ pos=1
+ set \$cline
+ while $test \$# -gt 0; do
+ if $test -r \`echo \$1 | $tr -d '"'\`; then
+ echo "\$pos"
+ exit 0
+ fi
+ shift
+ pos=\`expr \$pos + 1\`
+ done
+done
+EOF
+chmod +x fieldn
+fieldn=`./fieldn`
+$rm -f foo.c fieldn
+case $fieldn in
+'') pos='???';;
+1) pos=first;;
+2) pos=second;;
+3) pos=third;;
+*) pos="${fieldn}th";;
+esac
+echo "Your cpp writes the filename in the $pos field of the line."
+
+: locate header file
+$cat >findhdr <<EOF
+$startsh
+wanted=\$1
+name=''
+if test -f $usrinc/\$wanted; then
+ echo "$usrinc/\$wanted"
+ exit 0
+fi
+awkprg='{ print \$$fieldn }'
+echo "#include <\$wanted>" > foo\$\$.c
+$cppstdin $cppminus $cppflags < foo\$\$.c 2>/dev/null | \
+$grep "^[ ]*#.*\$wanted" | \
+while read cline; do
+ name=\`echo \$cline | $awk "\$awkprg" | $tr -d '"'\`
+ case "\$name" in
+ */\$wanted) echo "\$name"; exit 0;;
+ *) name='';;
+ esac;
+done;
+$rm -f foo\$\$.c;
+case "\$name" in
+'') exit 1;;
+esac
+EOF
+chmod +x findhdr
+
+: define an alternate in-header-list? function
+inhdr='echo " "; td=$define; tu=$undef; yyy=$@;
+cont=true; xxf="echo \"<\$1> found.\" >&4";
+case $# in 2) xxnf="echo \"<\$1> NOT found.\" >&4";;
+*) xxnf="echo \"<\$1> NOT found, ...\" >&4";;
+esac;
+case $# in 4) instead=instead;; *) instead="at last";; esac;
+while $test "$cont"; do
+ xxx=`./findhdr $1`
+ var=$2; eval "was=\$$2";
+ if $test "$xxx" && $test -r "$xxx";
+ then eval $xxf;
+ eval "case \"\$$var\" in $undef) . ./whoa; esac"; eval "$var=\$td";
+ cont="";
+ else eval $xxnf;
+ eval "case \"\$$var\" in $define) . ./whoa; esac"; eval "$var=\$tu"; fi;
+ set $yyy; shift; shift; yyy=$@;
+ case $# in 0) cont="";;
+ 2) xxf="echo \"but I found <\$1> $instead.\" >&4";
+ xxnf="echo \"and I did not find <\$1> either.\" >&4";;
+ *) xxf="echo \"but I found <\$1\> instead.\" >&4";
+ xxnf="echo \"there is no <\$1>, ...\" >&4";;
+ esac;
+done;
+while $test "$yyy";
+do set $yyy; var=$2; eval "was=\$$2";
+ eval "case \"\$$var\" in $define) . ./whoa; esac"; eval "$var=\$tu";
+ set $yyy; shift; shift; yyy=$@;
+done'
+
+: see if this is a malloc.h system
+set malloc.h i_malloc
+eval $inhdr
+
+: see if stdlib is available
+set stdlib.h i_stdlib
+eval $inhdr
+
+: determine which malloc to compile in
+echo " "
+case "$usemymalloc" in
+''|y*|true) dflt='y' ;;
+n*|false) dflt='n' ;;
+*) dflt="$usemymalloc" ;;
+esac
+rp="Do you wish to attempt to use the malloc that comes with $package?"
+. ./myread
+usemymalloc="$ans"
+case "$ans" in
+y*|true)
+ usemymalloc='y'
+ mallocsrc='malloc.c'
+ mallocobj="malloc$_o"
+ d_mymalloc="$define"
+ case "$libs" in
+ *-lmalloc*)
+ : Remove malloc from list of libraries to use
+ echo "Removing unneeded -lmalloc from library list" >&4
+ set `echo X $libs | $sed -e 's/-lmalloc / /' -e 's/-lmalloc$//'`
+ shift
+ libs="$*"
+ echo "libs = $libs" >&4
+ ;;
+ esac
+ ;;
+*)
+ usemymalloc='n'
+ mallocsrc=''
+ mallocobj=''
+ d_mymalloc="$undef"
+ ;;
+esac
+
+: compute the return types of malloc and free
+echo " "
+$cat >malloc.c <<END
+#$i_malloc I_MALLOC
+#$i_stdlib I_STDLIB
+#include <stdio.h>
+#include <sys/types.h>
+#ifdef I_MALLOC
+#include <malloc.h>
+#endif
+#ifdef I_STDLIB
+#include <stdlib.h>
+#endif
+#ifdef TRY_MALLOC
+void *malloc();
+#endif
+#ifdef TRY_FREE
+void free();
+#endif
+END
+case "$malloctype" in
+'')
+ if $cc $ccflags -c -DTRY_MALLOC malloc.c >/dev/null 2>&1; then
+ malloctype='void *'
+ else
+ malloctype='char *'
+ fi
+ ;;
+esac
+echo "Your system wants malloc to return '$malloctype', it would seem." >&4
+
+case "$freetype" in
+'')
+ if $cc $ccflags -c -DTRY_FREE malloc.c >/dev/null 2>&1; then
+ freetype='void'
+ else
+ freetype='int'
+ fi
+ ;;
+esac
+echo "Your system uses $freetype free(), it would seem." >&4
+$rm -f malloc.[co]
+: Cruising for prototypes
+echo " "
+echo "Checking out function prototypes..." >&4
+$cat >prototype.c <<'EOCP'
+main(int argc, char *argv[]) {
+ exit(0);}
+EOCP
+if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then
+ echo "Your C compiler appears to support function prototypes."
+ val="$define"
+else
+ echo "Your C compiler doesn't seem to understand function prototypes."
+ val="$undef"
+fi
+set prototype
+eval $setvar
+$rm -f prototype*
+
+case "$prototype" in
+"$define") ;;
+*) ansi2knr='ansi2knr'
+ echo " "
+ cat <<EOM >&4
+
+$me: FATAL ERROR:
+This version of $package can only be compiled by a compiler that
+understands function prototypes. Unfortunately, your C compiler
+ $cc $ccflags
+doesn't seem to understand them. Sorry about that.
+
+If GNU cc is avaiable for your system, perhaps you could try that instead.
+
+Eventually, we hope to support building Perl with pre-ANSI compilers.
+If you would like to help in that effort, please contact <perlbug@perl.org>.
+
+Aborting Configure now.
+EOM
+ exit 2
+ ;;
+esac
+
+: determine where public executables go
+echo " "
+set dflt bin bin
+eval $prefixit
+fn=d~
+rp='Pathname where the public executables will reside?'
+. ./getfile
+if $test "X$ansexp" != "X$binexp"; then
+ installbin=''
+fi
+bin="$ans"
+binexp="$ansexp"
+if $afs; then
+ $cat <<EOM
+
+Since you are running AFS, I need to distinguish the directory in which
+executables reside from the directory in which they are installed (and from
+which they are presumably copied to the former directory by occult means).
+
+EOM
+ case "$installbin" in
+ '') dflt=`echo $binexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installbin";;
+ esac
+ fn=de~
+ rp='Where will public executables be installed?'
+ . ./getfile
+ installbin="$ans"
+else
+ installbin="$binexp"
+fi
+
+: define a shorthand compile call
+compile='
+mc_file=$1;
+shift;
+$cc $optimize $ccflags $ldflags -o ${mc_file} $* ${mc_file}.c $libs > /dev/null 2>&1;'
+: define a shorthand compile call for compilations that should be ok.
+compile_ok='
+mc_file=$1;
+shift;
+$cc $optimize $ccflags $ldflags -o ${mc_file} $* ${mc_file}.c $libs;'
+
+echo " "
+echo "Determining whether or not we are on an EBCDIC system..." >&4
+cat >tebcdic.c <<EOM
+int main()
+{
+ if ('M'==0xd4) return 0;
+ return 1;
+}
+EOM
+val=$undef
+set tebcdic
+if eval $compile_ok; then
+ if ./tebcdic; then
+ echo "You have EBCDIC." >&4
+ val="$define"
+ else
+ echo "Nope, no EBCDIC. Assuming ASCII or some ISO Latin." >&4
+ fi
+else
+ echo "I'm unable to compile the test program." >&4
+ echo "I'll asuume ASCII or some ISO Latin." >&4
+fi
+$rm -f tebcdic.c tebcdic
+set ebcdic
+eval $setvar
+
+echo " "
+echo "Checking for GNU C Library..." >&4
+cat >gnulibc.c <<EOM
+#include <stdio.h>
+int
+main()
+{
+#ifdef __GLIBC__
+ exit(0);
+#else
+ exit(1);
+#endif
+}
+EOM
+set gnulibc
+if eval $compile_ok && ./gnulibc; then
+ val="$define"
+ echo "You are using the GNU C Library"
+else
+ val="$undef"
+ echo "You are not using the GNU C Library"
+fi
+$rm -f gnulibc*
+set d_gnulibc
+eval $setvar
+
+: see if nm is to be used to determine whether a symbol is defined or not
+case "$usenm" in
+'')
+ dflt=''
+ case "$d_gnulibc" in
+ "$define")
+ echo " "
+ echo "nm probably won't work on the GNU C Library." >&4
+ dflt=n
+ ;;
+ esac
+ case "$dflt" in
+ '')
+ if $test "$osname" = aix -a ! -f /lib/syscalls.exp; then
+ echo " "
+ echo "Whoops! This is an AIX system without /lib/syscalls.exp!" >&4
+ echo "'nm' won't be sufficient on this sytem." >&4
+ dflt=n
+ fi
+ ;;
+ esac
+ case "$dflt" in
+ '') dflt=`$egrep 'inlibc|csym' $rsrc/Configure | wc -l 2>/dev/null`
+ if $test $dflt -gt 20; then
+ dflt=y
+ else
+ dflt=n
+ fi
+ ;;
+ esac
+ ;;
+*)
+ case "$usenm" in
+ true|$define) dflt=y;;
+ *) dflt=n;;
+ esac
+ ;;
+esac
+$cat <<EOM
+
+I can use $nm to extract the symbols from your C libraries. This
+is a time consuming task which may generate huge output on the disk (up
+to 3 megabytes) but that should make the symbols extraction faster. The
+alternative is to skip the 'nm' extraction part and to compile a small
+test program instead to determine whether each symbol is present. If
+you have a fast C compiler and/or if your 'nm' output cannot be parsed,
+this may be the best solution.
+
+You probably shouldn't let me use 'nm' if you are using the GNU C Library.
+
+EOM
+rp="Shall I use $nm to extract C symbols from the libraries?"
+. ./myread
+case "$ans" in
+[Nn]*) usenm=false;;
+*) usenm=true;;
+esac
+
+runnm=$usenm
+case "$reuseval" in
+true) runnm=false;;
+esac
+
+: nm options which may be necessary
+case "$nm_opt" in
+'') if $test -f /mach_boot; then
+ nm_opt='' # Mach
+ elif $test -d /usr/ccs/lib; then
+ nm_opt='-p' # Solaris (and SunOS?)
+ elif $test -f /dgux; then
+ nm_opt='-p' # DG-UX
+ elif $test -f /lib64/rld; then
+ nm_opt='-p' # 64-bit Irix
+ else
+ nm_opt=''
+ fi;;
+esac
+
+: nm options which may be necessary for shared libraries but illegal
+: for archive libraries. Thank you, Linux.
+case "$nm_so_opt" in
+'') case "$myuname" in
+ *linux*)
+ if $nm --help | $grep 'dynamic' > /dev/null 2>&1; then
+ nm_so_opt='--dynamic'
+ fi
+ ;;
+ esac
+ ;;
+esac
+
+case "$runnm" in
+true)
+: get list of predefined functions in a handy place
+echo " "
+case "$libc" in
+'') libc=unknown
+ case "$libs" in
+ *-lc_s*) libc=`./loc libc_s$_a $libc $libpth`
+ esac
+ ;;
+esac
+libnames='';
+case "$libs" in
+'') ;;
+*) for thislib in $libs; do
+ case "$thislib" in
+ -lc|-lc_s)
+ : Handle C library specially below.
+ ;;
+ -l*)
+ thislib=`echo $thislib | $sed -e 's/^-l//'`
+ if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc lib$thislib$_a X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc $thislib$_a X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc $thislib X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc Slib$thislib$_a X $xlibpth`; $test -f "$try"; then
+ :
+ else
+ try=''
+ fi
+ libnames="$libnames $try"
+ ;;
+ *) libnames="$libnames $thislib" ;;
+ esac
+ done
+ ;;
+esac
+xxx=normal
+case "$libc" in
+unknown)
+ set /lib/libc.$so
+ for xxx in $libpth; do
+ $test -r $1 || set $xxx/libc.$so
+ : The messy sed command sorts on library version numbers.
+ $test -r $1 || \
+ set `echo blurfl; echo $xxx/libc.$so.[0-9]* | \
+ tr ' ' $trnl | egrep -v '\.[A-Za-z]*$' | $sed -e '
+ h
+ s/[0-9][0-9]*/0000&/g
+ s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g
+ G
+ s/\n/ /' | \
+ sort | $sed -e 's/^.* //'`
+ eval set \$$#
+ done
+ $test -r $1 || set /usr/ccs/lib/libc.$so
+ $test -r $1 || set /lib/libsys_s$_a
+ ;;
+*)
+ set blurfl
+ ;;
+esac
+if $test -r "$1"; then
+ echo "Your (shared) C library seems to be in $1."
+ libc="$1"
+elif $test -r /lib/libc && $test -r /lib/clib; then
+ echo "Your C library seems to be in both /lib/clib and /lib/libc."
+ xxx=apollo
+ libc='/lib/clib /lib/libc'
+ if $test -r /lib/syslib; then
+ echo "(Your math library is in /lib/syslib.)"
+ libc="$libc /lib/syslib"
+ fi
+elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then
+ echo "Your C library seems to be in $libc, as you said before."
+elif $test -r $incpath/usr/lib/libc$_a; then
+ libc=$incpath/usr/lib/libc$_a;
+ echo "Your C library seems to be in $libc. That's fine."
+elif $test -r /lib/libc$_a; then
+ libc=/lib/libc$_a;
+ echo "Your C library seems to be in $libc. You're normal."
+else
+ if tans=`./loc libc$_a blurfl/dyick $libpth`; $test -r "$tans"; then
+ :
+ elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then
+ libnames="$libnames "`./loc clib blurfl/dyick $libpth`
+ elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then
+ :
+ elif tans=`./loc Slibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then
+ :
+ elif tans=`./loc Mlibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then
+ :
+ else
+ tans=`./loc Llibc$_a blurfl/dyick $xlibpth`
+ fi
+ if $test -r "$tans"; then
+ echo "Your C library seems to be in $tans, of all places."
+ libc=$tans
+ else
+ libc='blurfl'
+ fi
+fi
+if $test $xxx = apollo -o -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then
+ dflt="$libc"
+ cat <<EOM
+
+If the guess above is wrong (which it might be if you're using a strange
+compiler, or your machine supports multiple models), you can override it here.
+
+EOM
+else
+ dflt=''
+ echo $libpth | tr ' ' $trnl | sort | uniq > libpath
+ cat >&4 <<EOM
+I can't seem to find your C library. I've looked in the following places:
+
+EOM
+ $sed 's/^/ /' libpath
+ cat <<EOM
+
+None of these seems to contain your C library. I need to get its name...
+
+EOM
+fi
+fn=f
+rp='Where is your C library?'
+. ./getfile
+libc="$ans"
+
+echo " "
+echo $libc $libnames | tr ' ' $trnl | sort | uniq > libnames
+set X `cat libnames`
+shift
+xxx=files
+case $# in 1) xxx=file; esac
+echo "Extracting names from the following $xxx for later perusal:" >&4
+echo " "
+$sed 's/^/ /' libnames >&4
+echo " "
+$echo $n "This may take a while...$c" >&4
+
+for file in $*; do
+ case $file in
+ *$so*) $nm $nm_so_opt $nm_opt $file 2>/dev/null;;
+ *) $nm $nm_opt $file 2>/dev/null;;
+ esac
+done >libc.tmp
+
+$echo $n ".$c"
+$grep fprintf libc.tmp > libc.ptf
+xscan='eval "<libc.ptf $com >libc.list"; $echo $n ".$c" >&4'
+xrun='eval "<libc.tmp $com >libc.list"; echo "done" >&4'
+xxx='[ADTSIW]'
+if com="$sed -n -e 's/__IO//' -e 's/^.* $xxx *_[_.]*//p' -e 's/^.* $xxx *//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^.* D __*//p' -e 's/^.* D //p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$grep '|' | $sed -n -e '/|COMMON/d' -e '/|DATA/d' \
+ -e '/ file/d' -e 's/^\([^ ]*\).*/\1/p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^.*|Proc .*|Text *| *//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/^[-0-9a-f ]*_\(.*\)=.*/\1/p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+elif com="$sed -n -e 's/.*\.text n\ \ \ \.//p'";\
+ eval $xscan;\
+ $contains '^fprintf$' libc.list >/dev/null 2>&1; then
+ eval $xrun
+else
+ $nm -p $* 2>/dev/null >libc.tmp
+ $grep fprintf libc.tmp > libc.ptf
+ if com="$sed -n -e 's/^.* [ADTSIW] *_[_.]*//p' -e 's/^.* [ADTSIW] //p'";\
+ eval $xscan; $contains '^fprintf$' libc.list >/dev/null 2>&1
+ then
+ nm_opt='-p'
+ eval $xrun
+ else
+ echo " "
+ echo "$nm didn't seem to work right. Trying $ar instead..." >&4
+ com=''
+ if $ar t $libc > libc.tmp && $contains '^fprintf$' libc.tmp >/dev/null 2>&1; then
+ for thisname in $libnames $libc; do
+ $ar t $thisname >>libc.tmp
+ done
+ $sed -e "s/\\$_o\$//" < libc.tmp > libc.list
+ echo "Ok." >&4
+ elif test "X$osname" = "Xos2" && $ar tv $libc > libc.tmp; then
+ # Repeat libc to extract forwarders to DLL entries too
+ for thisname in $libnames $libc; do
+ $ar tv $thisname >>libc.tmp
+ # Revision 50 of EMX has bug in $ar.
+ # it will not extract forwarders to DLL entries
+ # Use emximp which will extract exactly them.
+ emximp -o tmp.imp $thisname \
+ 2>/dev/null && \
+ $sed -e 's/^\([_a-zA-Z0-9]*\) .*$/\1/p' \
+ < tmp.imp >>libc.tmp
+ $rm tmp.imp
+ done
+ $sed -e "s/\\$_o\$//" -e 's/^ \+//' < libc.tmp > libc.list
+ echo "Ok." >&4
+ else
+ echo "$ar didn't seem to work right." >&4
+ echo "Maybe this is a Cray...trying bld instead..." >&4
+ if bld t $libc | $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" > libc.list
+ then
+ for thisname in $libnames; do
+ bld t $libnames | \
+ $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" >>libc.list
+ $ar t $thisname >>libc.tmp
+ done
+ echo "Ok." >&4
+ else
+ echo "That didn't work either. Giving up." >&4
+ exit 1
+ fi
+ fi
+ fi
+fi
+nm_extract="$com"
+if $test -f /lib/syscalls.exp; then
+ echo " "
+ echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4
+ $sed -n 's/^\([^ ]*\)[ ]*syscall$/\1/p' /lib/syscalls.exp >>libc.list
+fi
+;;
+esac
+$rm -f libnames libpath
+
+: see if dld is available
+set dld.h i_dld
+eval $inhdr
+
+: is a C symbol defined?
+csym='tlook=$1;
+case "$3" in
+-v) tf=libc.tmp; tc=""; tdc="";;
+-a) tf=libc.tmp; tc="[0]"; tdc="[]";;
+*) tlook="^$1\$"; tf=libc.list; tc="()"; tdc="()";;
+esac;
+tx=yes;
+case "$reuseval-$4" in
+true-) ;;
+true-*) tx=no; eval "tval=\$$4"; case "$tval" in "") tx=yes;; esac;;
+esac;
+case "$tx" in
+yes)
+ case "$runnm" in
+ true)
+ if $contains $tlook $tf >/dev/null 2>&1;
+ then tval=true;
+ else tval=false;
+ fi;;
+ *)
+ echo "main() { extern short $1$tdc; printf(\"%hd\", $1$tc); }" > t.c;
+ if $cc $optimize $ccflags $ldflags -o t t.c $libs >/dev/null 2>&1;
+ then tval=true;
+ else tval=false;
+ fi;
+ $rm -f t t.c;;
+ esac;;
+*)
+ case "$tval" in
+ $define) tval=true;;
+ *) tval=false;;
+ esac;;
+esac;
+eval "$2=$tval"'
+
+: define an is-in-libc? function
+inlibc='echo " "; td=$define; tu=$undef;
+sym=$1; var=$2; eval "was=\$$2";
+tx=yes;
+case "$reuseval$was" in
+true) ;;
+true*) tx=no;;
+esac;
+case "$tx" in
+yes)
+ set $sym tres -f;
+ eval $csym;
+ case "$tres" in
+ true)
+ echo "$sym() found." >&4;
+ case "$was" in $undef) . ./whoa; esac; eval "$var=\$td";;
+ *)
+ echo "$sym() NOT found." >&4;
+ case "$was" in $define) . ./whoa; esac; eval "$var=\$tu";;
+ esac;;
+*)
+ case "$was" in
+ $define) echo "$sym() found." >&4;;
+ *) echo "$sym() NOT found." >&4;;
+ esac;;
+esac'
+
+: see if dlopen exists
+xxx_runnm="$runnm"
+runnm=false
+set dlopen d_dlopen
+eval $inlibc
+runnm="$xxx_runnm"
+
+: determine which dynamic loading, if any, to compile in
+echo " "
+dldir="ext/DynaLoader"
+case "$usedl" in
+$define|y|true)
+ dflt='y'
+ usedl="$define"
+ ;;
+$undef|n|false)
+ dflt='n'
+ usedl="$undef"
+ ;;
+*)
+ dflt='n'
+ case "$d_dlopen" in
+ $define) dflt='y' ;;
+ esac
+ case "$i_dld" in
+ $define) dflt='y' ;;
+ esac
+ : Does a dl_xxx.xs file exist for this operating system
+ $test -f $rsrc/$dldir/dl_${osname}.xs && dflt='y'
+ ;;
+esac
+rp="Do you wish to use dynamic loading?"
+. ./myread
+usedl="$ans"
+case "$ans" in
+y*) usedl="$define"
+ case "$dlsrc" in
+ '')
+ if $test -f $rsrc/$dldir/dl_${osname}.xs ; then
+ dflt="$dldir/dl_${osname}.xs"
+ elif $test "$d_dlopen" = "$define" ; then
+ dflt="$dldir/dl_dlopen.xs"
+ elif $test "$i_dld" = "$define" ; then
+ dflt="$dldir/dl_dld.xs"
+ else
+ dflt=''
+ fi
+ ;;
+ *) dflt="$dldir/$dlsrc"
+ ;;
+ esac
+ echo "The following dynamic loading files are available:"
+ : Can not go over to $dldir because getfile has path hard-coded in.
+ tdir=`pwd`; cd $rsrc; $ls -C $dldir/dl*.xs; cd $tdir
+ rp="Source file to use for dynamic loading"
+ fn="fne"
+ # XXX This getfile call will fail the existence check if you try
+ # building away from $src (this is not supported yet).
+ . ./getfile
+ usedl="$define"
+ : emulate basename
+ dlsrc=`echo $ans | $sed -e 's@.*/\([^/]*\)$@\1@'`
+
+ $cat << EOM
+
+Some systems may require passing special flags to $cc -c to
+compile modules that will be used to create a shared library.
+To use no flags, say "none".
+
+EOM
+ case "$cccdlflags" in
+ '') case "$gccversion" in
+ '') case "$osname" in
+ hpux) dflt='+z' ;;
+ next) dflt='none' ;;
+ irix*) dflt='-KPIC' ;;
+ svr4*|esix*|solaris) dflt='-KPIC' ;;
+ sunos) dflt='-pic' ;;
+ *) dflt='none' ;;
+ esac
+ ;;
+ *) case "$osname" in
+ svr4*|esix*|solaris) dflt='-fPIC' ;;
+ *) dflt='-fpic' ;;
+ esac ;;
+ esac ;;
+ ' ') dflt='none' ;;
+ *) dflt="$cccdlflags" ;;
+ esac
+ rp="Any special flags to pass to $cc -c to compile shared library modules?"
+ . ./myread
+ case "$ans" in
+ none) cccdlflags=' ' ;;
+ *) cccdlflags="$ans" ;;
+ esac
+
+ cat << EOM
+
+Some systems use ld to create libraries that can be dynamically loaded,
+while other systems (such as those using ELF) use $cc.
+
+EOM
+ case "$ld" in
+ '') $cat >try.c <<'EOM'
+/* Test for whether ELF binaries are produced */
+#include <fcntl.h>
+#include <stdlib.h>
+main() {
+ char b[4];
+ int i = open("a.out",O_RDONLY);
+ if(i == -1)
+ exit(1); /* fail */
+ if(read(i,b,4)==4 && b[0]==127 && b[1]=='E' && b[2]=='L' && b[3]=='F')
+ exit(0); /* succeed (yes, it's ELF) */
+ else
+ exit(1); /* fail */
+}
+EOM
+ if $cc $ccflags try.c >/dev/null 2>&1 && ./a.out; then
+ cat <<EOM
+You appear to have ELF support. I'll use $cc to build dynamic libraries.
+EOM
+ dflt="$cc"
+ else
+ echo "I'll use ld to build dynamic libraries."
+ dflt='ld'
+ fi
+ rm -f try.c a.out
+ ;;
+ *) dflt="$ld"
+ ;;
+ esac
+
+ rp="What command should be used to create dynamic libraries?"
+ . ./myread
+ ld="$ans"
+
+ cat << EOM
+
+Some systems may require passing special flags to $ld to create a
+library that can be dynamically loaded. If your ld flags include
+-L/other/path options to locate libraries outside your loader's normal
+search path, you may need to specify those -L options here as well. To
+use no flags, say "none".
+
+EOM
+ case "$lddlflags" in
+ '') case "$osname" in
+ hpux) dflt='-b' ;;
+ linux|irix*) dflt='-shared' ;;
+ next) dflt='none' ;;
+ solaris) dflt='-G' ;;
+ sunos) dflt='-assert nodefinitions' ;;
+ svr4*|esix*) dflt="-G $ldflags" ;;
+ *) dflt='none' ;;
+ esac
+ ;;
+ *) dflt="$lddlflags" ;;
+ esac
+
+ : Try to guess additional flags to pick up local libraries.
+ for thisflag in $ldflags; do
+ case "$thisflag" in
+ -L*)
+ case " $dflt " in
+ *" $thisflag "*) ;;
+ *) dflt="$dflt $thisflag" ;;
+ esac
+ ;;
+ esac
+ done
+
+ case "$dflt" in
+ ''|' ') dflt='none' ;;
+ esac
+
+ rp="Any special flags to pass to $ld to create a dynamically loaded library?"
+ . ./myread
+ case "$ans" in
+ none) lddlflags=' ' ;;
+ *) lddlflags="$ans" ;;
+ esac
+
+ cat <<EOM
+
+Some systems may require passing special flags to $cc to indicate that
+the resulting executable will use dynamic linking. To use no flags,
+say "none".
+
+EOM
+ case "$ccdlflags" in
+ '') case "$osname" in
+ hpux) dflt='-Wl,-E' ;;
+ linux) dflt='-rdynamic' ;;
+ next) dflt='none' ;;
+ sunos) dflt='none' ;;
+ *) dflt='none' ;;
+ esac ;;
+ ' ') dflt='none' ;;
+ *) dflt="$ccdlflags" ;;
+ esac
+ rp="Any special flags to pass to $cc to use dynamic loading?"
+ . ./myread
+ case "$ans" in
+ none) ccdlflags=' ' ;;
+ *) ccdlflags="$ans" ;;
+ esac
+ ;;
+*) usedl="$undef"
+ ld='ld'
+ dlsrc='dl_none.xs'
+ lddlflags=''
+ ccdlflags=''
+ ;;
+esac
+
+also=''
+case "$usedl" in
+$undef)
+ # No dynamic loading being used, so don't bother even to prompt.
+ useshrplib='false'
+ ;;
+*) case "$useshrplib" in
+ '') case "$osname" in
+ svr4*|dgux|dynixptx|esix|powerux)
+ dflt=y
+ also='Building a shared libperl is required for dynamic loading to work on your system.'
+ ;;
+ next*)
+ case "$osvers" in
+ 4*) dflt=y
+ also='Building a shared libperl is needed for MAB support.'
+ ;;
+ *) dflt=n
+ ;;
+ esac
+ ;;
+ *) dflt=n
+ ;;
+ esac
+ ;;
+ $define|true|[Yy]*)
+ dflt=y
+ ;;
+ *) dflt=n
+ ;;
+ esac
+ $cat << EOM
+
+The perl executable is normally obtained by linking perlmain.c with
+libperl${_a}, any static extensions (usually just DynaLoader), and
+any other libraries needed on this system (such as -lm, etc.). Since
+your system supports dynamic loading, it is probably possible to build
+a shared libperl.$so. If you will have more than one executable linked
+to libperl.$so, this will significantly reduce the size of each
+executable, but it may have a noticeable affect on performance. The
+default is probably sensible for your system.
+$also
+
+EOM
+ rp="Build a shared libperl.$so (y/n)"
+ . ./myread
+ case "$ans" in
+ true|$define|[Yy]*)
+ useshrplib='true'
+ # Why does next4 have to be so different?
+ case "${osname}${osvers}" in
+ next4*) xxx='DYLD_LIBRARY_PATH' ;;
+ os2*) xxx='' ;; # Nothing special needed.
+ *) xxx='LD_LIBRARY_PATH' ;;
+ esac
+ if test X"$xxx" != "X"; then
+ $cat <<EOM | $tee -a ../config.msg >&4
+
+To build perl, you must add the current working directory to your
+$xxx environment variable before running make. You can do
+this with
+ $xxx=\`pwd\`; export $xxx
+for Bourne-style shells, or
+ setenv $xxx \`pwd\`
+for Csh-style shells. You *MUST* do this before running make.
+
+EOM
+ fi
+ ;;
+ *) useshrplib='false' ;;
+ esac
+ ;;
+esac
+
+case "$useshrplib" in
+true)
+ case "$libperl" in
+ '')
+ # Figure out a good name for libperl.so. Since it gets stored in
+ # a version-specific architecture-dependent library, the version
+ # number isn't really that important, except for making cc/ld happy.
+ #
+ # A name such as libperl.so.3.1
+ majmin="libperl.$so.$patchlevel.$subversion"
+ # A name such as libperl.so.301
+ majonly=`echo $patchlevel $subversion |
+ $awk '{printf "%d%02d", $1, $2}'`
+ majonly=libperl.$so.$majonly
+ # I'd prefer to keep the os-specific stuff here to a minimum, and
+ # rely on figuring it out from the naming of libc.
+ case "${osname}${osvers}" in
+ next4*)
+ dflt=libperl.5.$so
+ # XXX How handle the --version stuff for MAB?
+ ;;
+ linux*) # ld won't link with a bare -lperl otherwise.
+ dflt=libperl.$so
+ ;;
+ *) # Try to guess based on whether libc has major.minor.
+ case "$libc" in
+ *libc.$so.[0-9]*.[0-9]*) dflt=$majmin ;;
+ *libc.$so.[0-9]*) dflt=$majonly ;;
+ *) dflt=libperl.$so ;;
+ esac
+ ;;
+ esac
+ ;;
+ *) dflt=$libperl
+ ;;
+ esac
+ cat << EOM
+
+I need to select a good name for the shared libperl. If your system uses
+library names with major and minor numbers, then you might want something
+like $majmin. Alternatively, if your system uses a single version
+number for shared libraries, then you might want to use $majonly.
+Or, your system might be quite happy with a simple libperl.$so.
+
+Since the shared libperl will get installed into a version-specific
+architecture-dependent directory, the version number of the shared perl
+library probably isn't important, so the default should be o.k.
+
+EOM
+ rp='What name do you want to give to the shared libperl?'
+ . ./myread
+ libperl=$ans
+ echo "Ok, I'll use $libperl"
+ ;;
+*)
+ libperl="libperl${_a}"
+ ;;
+esac
+
+# Detect old use of shrpdir via undocumented Configure -Dshrpdir
+case "$shrpdir" in
+'') ;;
+*) $cat >&4 <<EOM
+WARNING: Use of the shrpdir variable for the installation location of
+the shared $libperl is not supported. It was never documented and
+will not work in this version. Let me (doughera@lafayette.edu)
+know of any problems this may cause.
+
+EOM
+ case "$shrpdir" in
+ "$archlibexp/CORE")
+ $cat >&4 <<EOM
+But your current setting of $shrpdir is
+the default anyway, so it's harmless.
+EOM
+ ;;
+ *)
+ $cat >&4 <<EOM
+Further, your current attempted setting of $shrpdir
+conflicts with the value of $archlibexp/CORE
+that installperl will use.
+EOM
+ ;;
+ esac
+ ;;
+esac
+
+# How will the perl executable find the installed shared $libperl?
+# Add $xxx to ccdlflags.
+# If we can't figure out a command-line option, use $shrpenv to
+# set env LD_RUN_PATH. The main perl makefile uses this.
+shrpdir=$archlibexp/CORE
+xxx=''
+tmp_shrpenv=''
+if "$useshrplib"; then
+ case "$osname" in
+ aix)
+ # We'll set it in Makefile.SH...
+ ;;
+ solaris|netbsd)
+ xxx="-R $shrpdir"
+ ;;
+ freebsd)
+ xxx="-Wl,-R$shrpdir"
+ ;;
+ linux|irix*|dec_osf)
+ xxx="-Wl,-rpath,$shrpdir"
+ ;;
+ next)
+ # next doesn't like the default...
+ ;;
+ *)
+ tmp_shrpenv="env LD_RUN_PATH=$shrpdir"
+ ;;
+ esac
+ case "$xxx" in
+ '') ;;
+ *)
+ # Only add $xxx if it isn't already in ccdlflags.
+ case " $ccdlflags " in
+ *" $xxx "*) ;;
+ *) ccdlflags="$ccdlflags $xxx"
+ cat <<EOM >&4
+
+Adding $xxx to the flags
+passed to $ld so that the perl executable will find the
+installed shared $libperl.
+
+EOM
+ ;;
+ esac
+ ;;
+ esac
+fi
+# Respect a hint or command-line value.
+case "$shrpenv" in
+'') shrpenv="$tmp_shrpenv" ;;
+esac
+
+: determine where manual pages go
+set man1dir man1dir none
+eval $prefixit
+$cat <<EOM
+
+$spackage has manual pages available in source form.
+EOM
+case "$nroff" in
+nroff)
+ echo "However, you don't have nroff, so they're probably useless to you."
+ case "$man1dir" in
+ '') man1dir="none";;
+ esac;;
+esac
+echo "If you don't want the manual sources installed, answer 'none'."
+case "$man1dir" in
+' ') dflt=none
+ ;;
+'')
+ lookpath="$prefixexp/man/man1 $prefixexp/man/l_man/man1"
+ lookpath="$lookpath $prefixexp/man/p_man/man1"
+ lookpath="$lookpath $prefixexp/man/u_man/man1"
+ lookpath="$lookpath $prefixexp/man/man.1"
+ case "$sysman" in
+ */?_man*) dflt=`./loc . $prefixexp/l_man/man1 $lookpath` ;;
+ *) dflt=`./loc . $prefixexp/man/man1 $lookpath` ;;
+ esac
+ set dflt
+ eval $prefixup
+ ;;
+*) dflt="$man1dir"
+ ;;
+esac
+echo " "
+fn=dn+~
+rp="Where do the main $spackage manual pages (source) go?"
+. ./getfile
+if $test "X$man1direxp" != "X$ansexp"; then
+ installman1dir=''
+fi
+man1dir="$ans"
+man1direxp="$ansexp"
+case "$man1dir" in
+'') man1dir=' '
+ installman1dir='';;
+esac
+if $afs; then
+ $cat <<EOM
+
+Since you are running AFS, I need to distinguish the directory in which
+manual pages reside from the directory in which they are installed (and from
+which they are presumably copied to the former directory by occult means).
+
+EOM
+ case "$installman1dir" in
+ '') dflt=`echo $man1direxp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installman1dir";;
+ esac
+ fn=de~
+ rp='Where will man pages be installed?'
+ . ./getfile
+ installman1dir="$ans"
+else
+ installman1dir="$man1direxp"
+fi
+
+: What suffix to use on installed man pages
+
+case "$man1dir" in
+' ')
+ man1ext='0'
+ ;;
+*)
+ rp="What suffix should be used for the main $spackage man pages?"
+ case "$man1ext" in
+ '') case "$man1dir" in
+ *1) dflt=1 ;;
+ *1p) dflt=1p ;;
+ *1pm) dflt=1pm ;;
+ *l) dflt=l;;
+ *n) dflt=n;;
+ *o) dflt=o;;
+ *p) dflt=p;;
+ *C) dflt=C;;
+ *L) dflt=L;;
+ *L1) dflt=L1;;
+ *) dflt=1;;
+ esac
+ ;;
+ *) dflt="$man1ext";;
+ esac
+ . ./myread
+ man1ext="$ans"
+ ;;
+esac
+
+: see if we can have long filenames
+echo " "
+rmlist="$rmlist /tmp/cf$$"
+$test -d /tmp/cf$$ || mkdir /tmp/cf$$
+first=123456789abcdef
+second=/tmp/cf$$/$first
+$rm -f $first $second
+if (echo hi >$first) 2>/dev/null; then
+ if $test -f 123456789abcde; then
+ echo 'You cannot have filenames longer than 14 characters. Sigh.' >&4
+ val="$undef"
+ else
+ if (echo hi >$second) 2>/dev/null; then
+ if $test -f /tmp/cf$$/123456789abcde; then
+ $cat <<'EOM'
+That's peculiar... You can have filenames longer than 14 characters, but only
+on some of the filesystems. Maybe you are using NFS. Anyway, to avoid problems
+I shall consider your system cannot support long filenames at all.
+EOM
+ val="$undef"
+ else
+ echo 'You can have filenames longer than 14 characters.' >&4
+ val="$define"
+ fi
+ else
+ $cat <<'EOM'
+How confusing! Some of your filesystems are sane enough to allow filenames
+longer than 14 characters but some others like /tmp can't even think about them.
+So, for now on, I shall assume your kernel does not allow them at all.
+EOM
+ val="$undef"
+ fi
+ fi
+else
+ $cat <<'EOM'
+You can't have filenames longer than 14 chars. You can't even think about them!
+EOM
+ val="$undef"
+fi
+set d_flexfnam
+eval $setvar
+$rm -rf /tmp/cf$$ 123456789abcde*
+
+: determine where library module manual pages go
+set man3dir man3dir none
+eval $prefixit
+$cat <<EOM
+
+$spackage has manual pages for many of the library modules.
+EOM
+
+case "$nroff" in
+nroff)
+ $cat <<'EOM'
+However, you don't have nroff, so they're probably useless to you.
+EOM
+ case "$man3dir" in
+ '') man3dir="none";;
+ esac;;
+esac
+
+case "$d_flexfnam" in
+undef)
+ $cat <<'EOM'
+However, your system can't handle the long file names like File::Basename.3.
+EOM
+ case "$man3dir" in
+ '') man3dir="none";;
+ esac;;
+esac
+
+echo "If you don't want the manual sources installed, answer 'none'."
+prog=`echo $package | $sed 's/-*[0-9.]*$//'`
+case "$man3dir" in
+'') case "$prefix" in
+ *$prog*) dflt=`echo $man1dir |
+ $sed -e 's/man1/man3/g' -e 's/man\.1/man\.3/g'` ;;
+ *) dflt="$privlib/man/man3" ;;
+ esac
+ ;;
+' ') dflt=none;;
+*) dflt="$man3dir" ;;
+esac
+echo " "
+
+fn=dn+~
+rp="Where do the $package library man pages (source) go?"
+. ./getfile
+if test "X$man3direxp" != "X$ansexp"; then
+ installman3dir=''
+fi
+
+man3dir="$ans"
+man3direxp="$ansexp"
+case "$man3dir" in
+'') man3dir=' '
+ installman3dir='';;
+esac
+if $afs; then
+ $cat <<EOM
+
+Since you are running AFS, I need to distinguish the directory in which
+manual pages reside from the directory in which they are installed (and from
+which they are presumably copied to the former directory by occult means).
+
+EOM
+ case "$installman3dir" in
+ '') dflt=`echo $man3direxp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installman3dir";;
+ esac
+ fn=de~
+ rp='Where will man pages be installed?'
+ . ./getfile
+ installman3dir="$ans"
+else
+ installman3dir="$man3direxp"
+fi
+
+: What suffix to use on installed man pages
+
+case "$man3dir" in
+' ')
+ man3ext='0'
+ ;;
+*)
+ rp="What suffix should be used for the $package library man pages?"
+ case "$man3ext" in
+ '') case "$man3dir" in
+ *3) dflt=3 ;;
+ *3p) dflt=3p ;;
+ *3pm) dflt=3pm ;;
+ *l) dflt=l;;
+ *n) dflt=n;;
+ *o) dflt=o;;
+ *p) dflt=p;;
+ *C) dflt=C;;
+ *L) dflt=L;;
+ *L3) dflt=L3;;
+ *) dflt=3;;
+ esac
+ ;;
+ *) dflt="$man3ext";;
+ esac
+ . ./myread
+ man3ext="$ans"
+ ;;
+esac
+
+: see if we have to deal with yellow pages, now NIS.
+if $test -d /usr/etc/yp || $test -d /etc/yp; then
+ if $test -f /usr/etc/nibindd; then
+ echo " "
+ echo "I'm fairly confident you're on a NeXT."
+ echo " "
+ rp='Do you get the hosts file via NetInfo?'
+ dflt=y
+ case "$hostcat" in
+ nidump*) ;;
+ '') ;;
+ *) dflt=n;;
+ esac
+ . ./myread
+ case "$ans" in
+ y*) hostcat='nidump hosts .';;
+ *) case "$hostcat" in
+ nidump*) hostcat='';;
+ esac
+ ;;
+ esac
+ fi
+ case "$hostcat" in
+ nidump*) ;;
+ *)
+ case "$hostcat" in
+ *ypcat*) dflt=y;;
+ '') if $contains '^\+' /etc/passwd >/dev/null 2>&1; then
+ dflt=y
+ else
+ dflt=n
+ fi;;
+ *) dflt=n;;
+ esac
+ echo " "
+ rp='Are you getting the hosts file via yellow pages?'
+ . ./myread
+ case "$ans" in
+ y*) hostcat='ypcat hosts';;
+ *) hostcat='cat /etc/hosts';;
+ esac
+ ;;
+ esac
+fi
+case "$hostcat" in
+'') hostcat='cat /etc/hosts';;
+esac
+case "$groupcat" in
+'') groupcat='cat /etc/group';;
+esac
+case "$passcat" in
+'') passcat='cat /etc/passwd';;
+esac
+
+: now get the host name
+echo " "
+echo "Figuring out host name..." >&4
+case "$myhostname" in
+'') cont=true
+ echo 'Maybe "hostname" will work...'
+ if tans=`sh -c hostname 2>&1` ; then
+ myhostname=$tans
+ phostname=hostname
+ cont=''
+ fi
+ ;;
+*) cont='';;
+esac
+if $test "$cont"; then
+ if ./xenix; then
+ echo 'Oh, dear. Maybe "/etc/systemid" is the key...'
+ if tans=`cat /etc/systemid 2>&1` ; then
+ myhostname=$tans
+ phostname='cat /etc/systemid'
+ echo "Whadyaknow. Xenix always was a bit strange..."
+ cont=''
+ fi
+ elif $test -r /etc/systemid; then
+ echo "(What is a non-Xenix system doing with /etc/systemid?)"
+ fi
+fi
+if $test "$cont"; then
+ echo 'No, maybe "uuname -l" will work...'
+ if tans=`sh -c 'uuname -l' 2>&1` ; then
+ myhostname=$tans
+ phostname='uuname -l'
+ else
+ echo 'Strange. Maybe "uname -n" will work...'
+ if tans=`sh -c 'uname -n' 2>&1` ; then
+ myhostname=$tans
+ phostname='uname -n'
+ else
+ echo 'Oh well, maybe I can mine it out of whoami.h...'
+ if tans=`sh -c $contains' sysname $usrinc/whoami.h' 2>&1` ; then
+ myhostname=`echo "$tans" | $sed 's/^.*"\(.*\)"/\1/'`
+ phostname="sed -n -e '"'/sysname/s/^.*\"\\(.*\\)\"/\1/{'"' -e p -e q -e '}' <$usrinc/whoami.h"
+ else
+ case "$myhostname" in
+ '') echo "Does this machine have an identity crisis or something?"
+ phostname='';;
+ *)
+ echo "Well, you said $myhostname before..."
+ phostname='echo $myhostname';;
+ esac
+ fi
+ fi
+ fi
+fi
+: you do not want to know about this
+set $myhostname
+myhostname=$1
+
+: verify guess
+if $test "$myhostname" ; then
+ dflt=y
+ rp='Your host name appears to be "'$myhostname'".'" Right?"
+ . ./myread
+ case "$ans" in
+ y*) ;;
+ *) myhostname='';;
+ esac
+fi
+
+: bad guess or no guess
+while $test "X$myhostname" = X ; do
+ dflt=''
+ rp="Please type the (one word) name of your host:"
+ . ./myread
+ myhostname="$ans"
+done
+
+: translate upper to lower if necessary
+case "$myhostname" in
+*[A-Z]*)
+ echo "(Normalizing case in your host name)"
+ myhostname=`echo $myhostname | ./tr '[A-Z]' '[a-z]'`
+ ;;
+esac
+
+case "$myhostname" in
+*.*)
+ dflt=`expr "X$myhostname" : "X[^.]*\(\..*\)"`
+ myhostname=`expr "X$myhostname" : "X\([^.]*\)\."`
+ echo "(Trimming domain name from host name--host name is now $myhostname)"
+ ;;
+*) case "$mydomain" in
+ '')
+ {
+ test "X$hostcat" = "Xypcat hosts" &&
+ ypmatch "$myhostname" hosts 2>/dev/null |\
+ $sed -e 's/[ ]*#.*//; s/$/ /' > hosts && \
+ $test -s hosts
+ } || {
+ $hostcat | $sed -n -e "s/[ ]*#.*//; s/\$/ /
+ /[ ]$myhostname[ . ]/p" > hosts
+ }
+ tmp_re="[ . ]"
+ $test x`$awk "/[0-9].*[ ]$myhostname$tmp_re/ { sum++ }
+ END { print sum }" hosts` = x1 || tmp_re="[ ]"
+ dflt=.`$awk "/[0-9].*[ ]$myhostname$tmp_re/ {for(i=2; i<=NF;i++) print \\\$i}" \
+ hosts | $sort | $uniq | \
+ $sed -n -e "s/$myhostname\.\([-a-zA-Z0-9_.]\)/\1/p"`
+ case `$echo X$dflt` in
+ X*\ *) echo "(Several hosts in /etc/hosts matched hostname)"
+ dflt=.
+ ;;
+ X.) echo "(You do not have fully-qualified names in /etc/hosts)"
+ ;;
+ esac
+ case "$dflt" in
+ .)
+ tans=`./loc resolv.conf X /etc /usr/etc`
+ if $test -f "$tans"; then
+ echo "(Attempting domain name extraction from $tans)"
+ dflt=.`$sed -n -e 's/ / /g' \
+ -e 's/^search *\([^ ]*\).*/\1/p' $tans \
+ | ./tr '[A-Z]' '[a-z]' 2>/dev/null`
+ case "$dflt" in
+ .) dflt=.`$sed -n -e 's/ / /g' \
+ -e 's/^domain *\([^ ]*\).*/\1/p' $tans \
+ | ./tr '[A-Z]' '[a-z]' 2>/dev/null`
+ ;;
+ esac
+ fi
+ ;;
+ esac
+ case "$dflt" in
+ .) echo "(No help from resolv.conf either -- attempting clever guess)"
+ dflt=.`sh -c domainname 2>/dev/null`
+ case "$dflt" in
+ '') dflt='.';;
+ .nis.*|.yp.*|.main.*) dflt=`echo $dflt | $sed -e 's/^\.[^.]*//'`;;
+ esac
+ ;;
+ esac
+ case "$dflt" in
+ .) echo "(Lost all hope -- silly guess then)"
+ dflt='.uucp'
+ ;;
+ esac
+ $rm -f hosts
+ ;;
+ *) dflt="$mydomain";;
+ esac;;
+esac
+echo " "
+rp="What is your domain name?"
+. ./myread
+tans="$ans"
+case "$ans" in
+'') ;;
+.*) ;;
+*) tans=".$tans";;
+esac
+mydomain="$tans"
+
+: translate upper to lower if necessary
+case "$mydomain" in
+*[A-Z]*)
+ echo "(Normalizing case in your domain name)"
+ mydomain=`echo $mydomain | ./tr '[A-Z]' '[a-z]'`
+ ;;
+esac
+
+: a little sanity check here
+case "$phostname" in
+'') ;;
+*)
+ case `$phostname | ./tr '[A-Z]' '[a-z]'` in
+ $myhostname$mydomain|$myhostname) ;;
+ *)
+ case "$phostname" in
+ sed*)
+ echo "(That doesn't agree with your whoami.h file, by the way.)"
+ ;;
+ *)
+ echo "(That doesn't agree with your $phostname command, by the way.)"
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+esac
+
+$cat <<EOM
+
+I need to get your e-mail address in Internet format if possible, i.e.
+something like user@host.domain. Please answer accurately since I have
+no easy means to double check it. The default value provided below
+is most probably close to the reality but may not be valid from outside
+your organization...
+
+EOM
+cont=x
+while test "$cont"; do
+ case "$cf_email" in
+ '') dflt="$cf_by@$myhostname$mydomain";;
+ *) dflt="$cf_email";;
+ esac
+ rp='What is your e-mail address?'
+ . ./myread
+ cf_email="$ans"
+ case "$cf_email" in
+ *@*.*) cont='' ;;
+ *)
+ rp='Address does not look like an Internet one. Use it anyway?'
+ case "$fastread" in
+ yes) dflt=y ;;
+ *) dflt=n ;;
+ esac
+ . ./myread
+ case "$ans" in
+ y*) cont='' ;;
+ *) echo " " ;;
+ esac
+ ;;
+ esac
+done
+
+$cat <<EOM
+
+If you or somebody else will be maintaining perl at your site, please
+fill in the correct e-mail address here so that they may be contacted
+if necessary. Currently, the "perlbug" program included with perl
+will send mail to this address in addition to perlbug@perl.com. You may
+enter "none" for no administrator.
+
+EOM
+case "$perladmin" in
+'') dflt="$cf_email";;
+*) dflt="$perladmin";;
+esac
+rp='Perl administrator e-mail address'
+. ./myread
+perladmin="$ans"
+
+: figure out how to guarantee perl startup
+case "$startperl" in
+'')
+ case "$sharpbang" in
+ *!)
+ $cat <<EOH
+
+I can use the #! construct to start perl on your system. This will
+make startup of perl scripts faster, but may cause problems if you
+want to share those scripts and perl is not in a standard place
+($binexp/perl) on all your platforms. The alternative is to force
+a shell by starting the script with a single ':' character.
+
+EOH
+ dflt="$binexp/perl"
+ rp='What shall I put after the #! to start up perl ("none" to not use #!)?'
+ . ./myread
+ case "$ans" in
+ none) startperl=": # use perl";;
+ *) startperl="#!$ans"
+ if $test 30 -lt `echo "$ans" | wc -c`; then
+ $cat >&4 <<EOM
+
+WARNING: Some systems limit the #! command to 32 characters.
+If you experience difficulty running Perl scripts with #!, try
+installing Perl in a directory with a shorter pathname.
+
+EOM
+ fi ;;
+ esac
+ ;;
+ *) startperl=": # use perl"
+ ;;
+ esac
+ ;;
+esac
+echo "I'll use $startperl to start perl scripts."
+
+: figure best path for perl in scripts
+case "$perlpath" in
+'')
+ perlpath="$binexp/perl"
+ case "$startperl" in
+ *!*) ;;
+ *)
+ $cat <<EOH
+
+I will use the "eval 'exec'" idiom to start Perl on your system.
+I can use the full path of your Perl binary for this purpose, but
+doing so may cause problems if you want to share those scripts and
+Perl is not always in a standard place ($binexp/perl).
+
+EOH
+ dflt="$binexp/perl"
+ rp="What path shall I use in \"eval 'exec'\"?"
+ . ./myread
+ perlpath="$ans"
+ ;;
+ esac
+ ;;
+esac
+case "$startperl" in
+*!*) ;;
+*) echo "I'll use $perlpath in \"eval 'exec'\"" ;;
+esac
+
+: determine where public executable scripts go
+set scriptdir scriptdir
+eval $prefixit
+case "$scriptdir" in
+'')
+ dflt="$bin"
+ : guess some guesses
+ $test -d /usr/share/scripts && dflt=/usr/share/scripts
+ $test -d /usr/share/bin && dflt=/usr/share/bin
+ $test -d /usr/local/script && dflt=/usr/local/script
+ $test -d $prefixexp/script && dflt=$prefixexp/script
+ set dflt
+ eval $prefixup
+ ;;
+*) dflt="$scriptdir"
+ ;;
+esac
+$cat <<EOM
+
+Some installations have a separate directory just for executable scripts so
+that they can mount it across multiple architectures but keep the scripts in
+one spot. You might, for example, have a subdirectory of /usr/share for this.
+Or you might just lump your scripts in with all your other executables.
+
+EOM
+fn=d~
+rp='Where do you keep publicly executable scripts?'
+. ./getfile
+if $test "X$ansexp" != "X$scriptdirexp"; then
+ installscript=''
+fi
+scriptdir="$ans"
+scriptdirexp="$ansexp"
+if $afs; then
+ $cat <<EOM
+
+Since you are running AFS, I need to distinguish the directory in which
+scripts reside from the directory in which they are installed (and from
+which they are presumably copied to the former directory by occult means).
+
+EOM
+ case "$installscript" in
+ '') dflt=`echo $scriptdirexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installscript";;
+ esac
+ fn=de~
+ rp='Where will public scripts be installed?'
+ . ./getfile
+ installscript="$ans"
+else
+ installscript="$scriptdirexp"
+fi
+
+: determine where site specific libraries go.
+: Usual default is /usr/local/lib/perl5/site_perl/$apiversion
+prog=`echo $package | $sed 's/-*[0-9.]*$//'`
+case "$prefix" in
+*perl*) set dflt sitelib lib/site_$prog/$apiversion ;;
+*) set dflt sitelib lib/$package/site_$prog/$apiversion ;;
+esac
+eval $prefixit
+$cat <<EOM
+
+The installation process will also create a directory for
+site-specific extensions and modules. Some users find it convenient
+to place all local files in this directory rather than in the main
+distribution directory.
+
+EOM
+fn=d~+
+rp='Pathname for the site-specific library files?'
+. ./getfile
+if $test "X$sitelibexp" != "X$ansexp"; then
+ installsitelib=''
+fi
+sitelib="$ans"
+sitelibexp="$ansexp"
+if $afs; then
+ $cat <<EOM
+
+Since you are running AFS, I need to distinguish the directory in
+which site-specific files reside from the directory in which they are
+installed (and from which they are presumably copied to the former
+directory by occult means).
+
+EOM
+ case "$installsitelib" in
+ '') dflt=`echo $sitelibexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installsitelib";;
+ esac
+ fn=de~
+ rp='Where will site-specific files be installed?'
+ . ./getfile
+ installsitelib="$ans"
+else
+ installsitelib="$sitelibexp"
+fi
+
+: determine where site specific architecture-dependent libraries go.
+: sitelib default is /usr/local/lib/perl5/site_perl/$apiversion
+: sitearch default is /usr/local/lib/perl5/site_perl/$apiversion/$archname
+: sitelib may have an optional trailing /share.
+tdflt=`echo $sitelib | $sed 's,/share$,,'`
+tdflt="$tdflt/$archname"
+set sitearch sitearch none
+eval $prefixit
+case "$sitearch" in
+'') dflt="$tdflt" ;;
+*) dflt="$sitearch" ;;
+esac
+$cat <<EOM
+
+The installation process will also create a directory for
+architecture-dependent site-specific extensions and modules.
+
+EOM
+fn=nd~+
+rp='Pathname for the site-specific architecture-dependent library files?'
+. ./getfile
+if $test "X$sitearchexp" != "X$ansexp"; then
+ installsitearch=''
+fi
+sitearch="$ans"
+sitearchexp="$ansexp"
+if $afs; then
+ $cat <<EOM
+
+Since you are running AFS, I need to distinguish the directory in
+which site-specific architecture-dependent library files reside from
+the directory in which they are installed (and from which they are
+presumably copied to the former directory by occult means).
+
+EOM
+ case "$installsitearch" in
+ '') dflt=`echo $sitearchexp | sed 's#^/afs/#/afs/.#'`;;
+ *) dflt="$installsitearch";;
+ esac
+ fn=de~
+ rp='Where will site-specific architecture-dependent files be installed?'
+ . ./getfile
+ installsitearch="$ans"
+else
+ installsitearch="$sitearchexp"
+fi
+
+cat <<EOM
+
+Previous version of $package used the standard IO mechanisms as defined
+in <stdio.h>. Versions 5.003_02 and later of perl allow alternate IO
+mechanisms via a "PerlIO" abstraction, but the stdio mechanism is still
+the default. This abstraction layer can use AT&T's sfio (if you already
+have sfio installed) or regular stdio. Using PerlIO with sfio may cause
+problems with some extension modules. Using PerlIO with stdio is safe,
+but it is slower than plain stdio and therefore is not the default.
+
+If this doesn't make any sense to you, just accept the default 'n'.
+EOM
+case "$useperlio" in
+$define|true|[yY]*) dflt='y';;
+*) dflt='n';;
+esac
+rp='Use the experimental PerlIO abstraction layer?'
+. ./myread
+case "$ans" in
+y|Y)
+ val="$define"
+ ;;
+*)
+ echo "Ok, doing things the stdio way"
+ val="$undef"
+ ;;
+esac
+set useperlio
+eval $setvar
+
+: Check how to convert floats to strings.
+if test "X$d_Gconvert" = X; then
+ echo " "
+ echo "Checking for an efficient way to convert floats to strings."
+ $cat >try.c <<'EOP'
+#ifdef TRY_gconvert
+#define Gconvert(x,n,t,b) gconvert((x),(n),(t),(b))
+char *myname = "gconvert";
+#endif
+#ifdef TRY_gcvt
+#define Gconvert(x,n,t,b) gcvt((x),(n),(b))
+char *myname = "gcvt";
+#endif
+#ifdef TRY_sprintf
+#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
+char *myname = "sprintf";
+#endif
+
+#include <stdio.h>
+
+int
+checkit(expect, got)
+char *expect;
+char *got;
+{
+ if (strcmp(expect, got)) {
+ printf("%s oddity: Expected %s, got %s\n",
+ myname, expect, got);
+ exit(1);
+ }
+}
+
+int
+main()
+{
+ char buf[64];
+ buf[63] = '\0';
+
+ /* This must be 1st test on (which?) platform */
+ /* Alan Burlison <AlanBurlsin@unn.unisys.com> */
+ Gconvert(0.1, 8, 0, buf);
+ checkit("0.1", buf);
+
+ Gconvert(1.0, 8, 0, buf);
+ checkit("1", buf);
+
+ Gconvert(0.0, 8, 0, buf);
+ checkit("0", buf);
+
+ Gconvert(-1.0, 8, 0, buf);
+ checkit("-1", buf);
+
+ /* Some Linux gcvt's give 1.e+5 here. */
+ Gconvert(100000.0, 8, 0, buf);
+ checkit("100000", buf);
+
+ /* Some Linux gcvt's give -1.e+5 here. */
+ Gconvert(-100000.0, 8, 0, buf);
+ checkit("-100000", buf);
+
+ exit(0);
+}
+EOP
+ case "$d_Gconvert" in
+ gconvert*) xxx_list='gconvert gcvt sprintf' ;;
+ gcvt*) xxx_list='gcvt gconvert sprintf' ;;
+ sprintf*) xxx_list='sprintf gconvert gcvt' ;;
+ *) xxx_list='gconvert gcvt sprintf' ;;
+ esac
+
+ for xxx_convert in $xxx_list; do
+ echo "Trying $xxx_convert"
+ $rm -f try try$_o
+ set try -DTRY_$xxx_convert
+ if eval $compile; then
+ echo "$xxx_convert" found. >&4
+ if ./try; then
+ echo "I'll use $xxx_convert to convert floats into a string." >&4
+ break;
+ else
+ echo "...But $xxx_convert didn't work as I expected."
+ fi
+ else
+ echo "$xxx_convert NOT found." >&4
+ fi
+ done
+
+ case "$xxx_convert" in
+ gconvert) d_Gconvert='gconvert((x),(n),(t),(b))' ;;
+ gcvt) d_Gconvert='gcvt((x),(n),(b))' ;;
+ *) d_Gconvert='sprintf((b),"%.*g",(n),(x))' ;;
+ esac
+fi
+
+: Initialize h_fcntl
+h_fcntl=false
+
+: Initialize h_sysfile
+h_sysfile=false
+
+: access call always available on UNIX
+set access d_access
+eval $inlibc
+
+: locate the flags for 'access()'
+case "$d_access" in
+"$define")
+ echo " "
+ $cat >access.c <<'EOCP'
+#include <sys/types.h>
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+main() {
+ exit(R_OK);
+}
+EOCP
+ : check sys/file.h first, no particular reason here
+ if $test `./findhdr sys/file.h` && \
+ $cc $cppflags -DI_SYS_FILE -o access access.c >/dev/null 2>&1 ; then
+ h_sysfile=true;
+ echo "<sys/file.h> defines the *_OK access constants." >&4
+ elif $test `./findhdr fcntl.h` && \
+ $cc $cppflags -DI_FCNTL -o access access.c >/dev/null 2>&1 ; then
+ h_fcntl=true;
+ echo "<fcntl.h> defines the *_OK access constants." >&4
+ elif $test `./findhdr unistd.h` && \
+ $cc $cppflags -DI_UNISTD -o access access.c >/dev/null 2>&1 ; then
+ echo "<unistd.h> defines the *_OK access constants." >&4
+ else
+ echo "I can't find the four *_OK access constants--I'll use mine." >&4
+ fi
+ ;;
+esac
+$rm -f access*
+
+: see if alarm exists
+set alarm d_alarm
+eval $inlibc
+
+: Look for GNU-cc style attribute checking
+echo " "
+echo "Checking whether your compiler can handle __attribute__ ..." >&4
+$cat >attrib.c <<'EOCP'
+#include <stdio.h>
+void croak (char* pat,...) __attribute__((format(printf,1,2),noreturn));
+EOCP
+if $cc $ccflags -c attrib.c >attrib.out 2>&1 ; then
+ if $contains 'warning' attrib.out >/dev/null 2>&1; then
+ echo "Your C compiler doesn't fully support __attribute__."
+ val="$undef"
+ else
+ echo "Your C compiler supports __attribute__."
+ val="$define"
+ fi
+else
+ echo "Your C compiler doesn't seem to understand __attribute__ at all."
+ val="$undef"
+fi
+set d_attribut
+eval $setvar
+$rm -f attrib*
+
+: see if bcmp exists
+set bcmp d_bcmp
+eval $inlibc
+
+: see if bcopy exists
+set bcopy d_bcopy
+eval $inlibc
+
+: see if this is a unistd.h system
+set unistd.h i_unistd
+eval $inhdr
+
+: see if getpgrp exists
+set getpgrp d_getpgrp
+eval $inlibc
+
+case "$d_getpgrp" in
+"$define")
+ echo " "
+ echo "Checking to see which flavor of getpgrp is in use..."
+ $cat >set.c <<EOP
+#$i_unistd I_UNISTD
+#include <sys/types.h>
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+main()
+{
+ if (getuid() == 0) {
+ printf("(I see you are running Configure as super-user...)\n");
+ setuid(1);
+ }
+#ifdef TRY_BSD_PGRP
+ if (getpgrp(1) == 0)
+ exit(0);
+#else
+ if (getpgrp() > 0)
+ exit(0);
+#endif
+ exit(1);
+}
+EOP
+ if $cc -DTRY_BSD_PGRP $ccflags $ldflags -o set set.c $libs >/dev/null 2>&1 && ./set; then
+ echo "You have to use getpgrp(pid) instead of getpgrp()." >&4
+ val="$define"
+ elif $cc $ccflags $ldflags -o set set.c $libs >/dev/null 2>&1 && ./set; then
+ echo "You have to use getpgrp() instead of getpgrp(pid)." >&4
+ val="$undef"
+ else
+ echo "I can't seem to compile and run the test program."
+ if ./usg; then
+ xxx="a USG one, i.e. you use getpgrp()."
+ else
+ # SVR4 systems can appear rather BSD-ish.
+ case "$i_unistd" in
+ $undef)
+ xxx="a BSD one, i.e. you use getpgrp(pid)."
+ val="$define"
+ ;;
+ $define)
+ xxx="probably a USG one, i.e. you use getpgrp()."
+ val="$undef"
+ ;;
+ esac
+ fi
+ echo "Assuming your getpgrp is $xxx" >&4
+ fi
+ ;;
+*) val="$undef";;
+esac
+set d_bsdgetpgrp
+eval $setvar
+$rm -f set set.c
+
+: see if setpgrp exists
+set setpgrp d_setpgrp
+eval $inlibc
+
+case "$d_setpgrp" in
+"$define")
+ echo " "
+ echo "Checking to see which flavor of setpgrp is in use..."
+ $cat >set.c <<EOP
+#$i_unistd I_UNISTD
+#include <sys/types.h>
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+main()
+{
+ if (getuid() == 0) {
+ printf("(I see you are running Configure as super-user...)\n");
+ setuid(1);
+ }
+#ifdef TRY_BSD_PGRP
+ if (-1 == setpgrp(1, 1))
+ exit(0);
+#else
+ if (setpgrp() != -1)
+ exit(0);
+#endif
+ exit(1);
+}
+EOP
+ if $cc -DTRY_BSD_PGRP $ccflags $ldflags -o set set.c $libs >/dev/null 2>&1 && ./set; then
+ echo 'You have to use setpgrp(pid,pgrp) instead of setpgrp().' >&4
+ val="$define"
+ elif $cc $ccflags $ldflags -o set set.c $libs >/dev/null 2>&1 && ./set; then
+ echo 'You have to use setpgrp() instead of setpgrp(pid,pgrp).' >&4
+ val="$undef"
+ else
+ echo "(I can't seem to compile and run the test program.)"
+ if ./usg; then
+ xxx="a USG one, i.e. you use setpgrp()."
+ else
+ # SVR4 systems can appear rather BSD-ish.
+ case "$i_unistd" in
+ $undef)
+ xxx="a BSD one, i.e. you use setpgrp(pid,pgrp)."
+ val="$define"
+ ;;
+ $define)
+ xxx="probably a USG one, i.e. you use setpgrp()."
+ val="$undef"
+ ;;
+ esac
+ fi
+ echo "Assuming your setpgrp is $xxx" >&4
+ fi
+ ;;
+*) val="$undef";;
+esac
+set d_bsdsetpgrp
+eval $setvar
+$rm -f set set.c
+: see if bzero exists
+set bzero d_bzero
+eval $inlibc
+
+: check for lengths of integral types
+echo " "
+case "$intsize" in
+'')
+ echo "Checking to see how big your integers are..." >&4
+ $cat >intsize.c <<'EOCP'
+#include <stdio.h>
+main()
+{
+ printf("intsize=%d;\n", sizeof(int));
+ printf("longsize=%d;\n", sizeof(long));
+ printf("shortsize=%d;\n", sizeof(short));
+ exit(0);
+}
+EOCP
+ set intsize
+ if eval $compile_ok && ./intsize > /dev/null; then
+ eval `./intsize`
+ echo "Your integers are $intsize bytes long."
+ echo "Your long integers are $longsize bytes long."
+ echo "Your short integers are $shortsize bytes long."
+ else
+ $cat >&4 <<EOM
+!
+Help! I can't compile and run the intsize test program: please enlighten me!
+(This is probably a misconfiguration in your system or libraries, and
+you really ought to fix it. Still, I'll try anyway.)
+!
+EOM
+ dflt=4
+ rp="What is the size of an integer (in bytes)?"
+ . ./myread
+ intsize="$ans"
+ dflt=$intsize
+ rp="What is the size of a long integer (in bytes)?"
+ . ./myread
+ longsize="$ans"
+ dflt=2
+ rp="What is the size of a short integer (in bytes)?"
+ . ./myread
+ shortsize="$ans"
+ fi
+ ;;
+esac
+$rm -f intsize intsize.*
+
+: see if signal is declared as pointer to function returning int or void
+echo " "
+xxx=`./findhdr signal.h`
+$test "$xxx" && $cppstdin $cppminus $cppflags < $xxx >$$.tmp 2>/dev/null
+if $contains 'int.*\*[ ]*signal' $$.tmp >/dev/null 2>&1 ; then
+ echo "You have int (*signal())() instead of void." >&4
+ val="$undef"
+elif $contains 'void.*\*[ ]*signal' $$.tmp >/dev/null 2>&1 ; then
+ echo "You have void (*signal())()." >&4
+ val="$define"
+elif $contains 'extern[ ]*[(\*]*signal' $$.tmp >/dev/null 2>&1 ; then
+ echo "You have int (*signal())() instead of void." >&4
+ val="$undef"
+elif $contains 'void.*\*.*sig' $$.tmp >/dev/null 2>&1 ; then
+ echo "You have void (*signal())()." >&4
+ val="$define"
+else
+ case "$d_voidsig" in
+ '')
+ echo "I can't determine whether signal handler returns void or int..." >&4
+ dflt=void
+ rp="What type does your signal handler return?"
+ . ./myread
+ case "$ans" in
+ v*) val="$define";;
+ *) val="$undef";;
+ esac;;
+ "$define")
+ echo "As you already told me, signal handler returns void." >&4
+ val="$define"
+ ;;
+ *) echo "As you already told me, signal handler returns int." >&4
+ val="$undef"
+ ;;
+ esac
+fi
+set d_voidsig
+eval $setvar
+case "$d_voidsig" in
+"$define") signal_t="void";;
+*) signal_t="int";;
+esac
+$rm -f $$.tmp
+
+: check for ability to cast large floats to 32-bit ints.
+echo " "
+echo 'Checking whether your C compiler can cast large floats to int32.' >&4
+if $test "$intsize" -ge 4; then
+ xxx=int
+else
+ xxx=long
+fi
+$cat >try.c <<EOCP
+#include <stdio.h>
+#include <sys/types.h>
+#include <signal.h>
+$signal_t blech(s) int s; { exit(3); }
+main()
+{
+ $xxx i32;
+ double f, g;
+ int result = 0;
+ char str[16];
+ signal(SIGFPE, blech);
+
+ /* Don't let compiler optimize the test away. Store the number
+ in a writable string for gcc to pass to sscanf under HP/UX.
+ */
+ sprintf(str, "2147483647");
+ sscanf(str, "%lf", &f); /* f = (double) 0x7fffffff; */
+ g = 10 * f;
+ i32 = ($xxx) g;
+
+ /* x86 processors will probably give 0x8000 0000, which is a
+ sign change. We don't want that. We want to mimic SPARC
+ behavior here, which is to preserve the sign and give
+ back 0x7fff ffff.
+ */
+ if (i32 != ($xxx) f)
+ result |= 1;
+ exit(result);
+}
+EOCP
+set try
+if eval $compile_ok; then
+ ./try
+ yyy=$?
+else
+ echo "(I can't seem to compile the test program--assuming it can't)"
+ yyy=1
+fi
+case "$yyy" in
+0) val="$define"
+ echo "Yup, it can."
+ ;;
+*) val="$undef"
+ echo "Nope, it can't."
+ ;;
+esac
+set d_casti32
+eval $setvar
+$rm -f try try.*
+
+: check for ability to cast negative floats to unsigned
+echo " "
+echo 'Checking whether your C compiler can cast negative float to unsigned.' >&4
+$cat >try.c <<EOCP
+#include <stdio.h>
+#include <sys/types.h>
+#include <signal.h>
+$signal_t blech(s) int s; { exit(7); }
+$signal_t blech_in_list(s) int s; { exit(4); }
+unsigned long dummy_long(p) unsigned long p; { return p; }
+unsigned int dummy_int(p) unsigned int p; { return p; }
+unsigned short dummy_short(p) unsigned short p; { return p; }
+main()
+{
+ double f;
+ unsigned long along;
+ unsigned int aint;
+ unsigned short ashort;
+ int result = 0;
+ char str[16];
+
+ /* Frustrate gcc-2.7.2's optimizer which failed this test with
+ a direct f = -123. assignment. gcc-2.8.0 reportedly
+ optimized the whole file away
+ */
+ /* Store the number in a writable string for gcc to pass to
+ sscanf under HP/UX.
+ */
+ sprintf(str, "-123");
+ sscanf(str, "%lf", &f); /* f = -123.; */
+
+ signal(SIGFPE, blech);
+ along = (unsigned long)f;
+ aint = (unsigned int)f;
+ ashort = (unsigned short)f;
+ if (along != (unsigned long)-123)
+ result |= 1;
+ if (aint != (unsigned int)-123)
+ result |= 1;
+ if (ashort != (unsigned short)-123)
+ result |= 1;
+ sprintf(str, "1073741824.");
+ sscanf(str, "%lf", &f); /* f = (double)0x40000000; */
+ f = f + f;
+ along = 0;
+ along = (unsigned long)f;
+ if (along != 0x80000000)
+ result |= 2;
+ f -= 1.;
+ along = 0;
+ along = (unsigned long)f;
+ if (along != 0x7fffffff)
+ result |= 1;
+ f += 2.;
+ along = 0;
+ along = (unsigned long)f;
+ if (along != 0x80000001)
+ result |= 2;
+ if (result)
+ exit(result);
+ signal(SIGFPE, blech_in_list);
+ sprintf(str, "123.");
+ sscanf(str, "%lf", &f); /* f = 123.; */
+ along = dummy_long((unsigned long)f);
+ aint = dummy_int((unsigned int)f);
+ ashort = dummy_short((unsigned short)f);
+ if (along != (unsigned long)123)
+ result |= 4;
+ if (aint != (unsigned int)123)
+ result |= 4;
+ if (ashort != (unsigned short)123)
+ result |= 4;
+ exit(result);
+
+}
+EOCP
+set try
+if eval $compile_ok; then
+ ./try
+ castflags=$?
+else
+ echo "(I can't seem to compile the test program--assuming it can't)"
+ castflags=7
+fi
+case "$castflags" in
+0) val="$define"
+ echo "Yup, it can."
+ ;;
+*) val="$undef"
+ echo "Nope, it can't."
+ ;;
+esac
+set d_castneg
+eval $setvar
+$rm -f try.*
+
+: see if vprintf exists
+echo " "
+if set vprintf val -f d_vprintf; eval $csym; $val; then
+ echo 'vprintf() found.' >&4
+ val="$define"
+ $cat >vprintf.c <<'EOF'
+#include <varargs.h>
+
+main() { xxx("foo"); }
+
+xxx(va_alist)
+va_dcl
+{
+ va_list args;
+ char buf[10];
+
+ va_start(args);
+ exit((unsigned long)vsprintf(buf,"%s",args) > 10L);
+}
+EOF
+ set vprintf
+ if eval $compile && ./vprintf; then
+ echo "Your vsprintf() returns (int)." >&4
+ val2="$undef"
+ else
+ echo "Your vsprintf() returns (char*)." >&4
+ val2="$define"
+ fi
+else
+ echo 'vprintf() NOT found.' >&4
+ val="$undef"
+ val2="$undef"
+fi
+set d_vprintf
+eval $setvar
+val=$val2
+set d_charvspr
+eval $setvar
+
+: see if chown exists
+set chown d_chown
+eval $inlibc
+
+: see if chroot exists
+set chroot d_chroot
+eval $inlibc
+
+: see if chsize exists
+set chsize d_chsize
+eval $inlibc
+
+: check for const keyword
+echo " "
+echo 'Checking to see if your C compiler knows about "const"...' >&4
+$cat >const.c <<'EOCP'
+typedef struct spug { int drokk; } spug;
+main()
+{
+ const char *foo;
+ const spug y;
+}
+EOCP
+if $cc -c $ccflags const.c >/dev/null 2>&1 ; then
+ val="$define"
+ echo "Yup, it does."
+else
+ val="$undef"
+ echo "Nope, it doesn't."
+fi
+set d_const
+eval $setvar
+
+: see if crypt exists
+echo " "
+if set crypt val -f d_crypt; eval $csym; $val; then
+ echo 'crypt() found.' >&4
+ val="$define"
+ cryptlib=''
+else
+ cryptlib=`./loc Slibcrypt$_a "" $xlibpth`
+ if $test -z "$cryptlib"; then
+ cryptlib=`./loc Mlibcrypt$_a "" $xlibpth`
+ else
+ cryptlib=-lcrypt
+ fi
+ if $test -z "$cryptlib"; then
+ cryptlib=`./loc Llibcrypt$_a "" $xlibpth`
+ else
+ cryptlib=-lcrypt
+ fi
+ if $test -z "$cryptlib"; then
+ cryptlib=`./loc libcrypt$_a "" $libpth`
+ else
+ cryptlib=-lcrypt
+ fi
+ if $test -z "$cryptlib"; then
+ echo 'crypt() NOT found.' >&4
+ val="$undef"
+ else
+ val="$define"
+ fi
+fi
+set d_crypt
+eval $setvar
+
+: see if cuserid exists
+set cuserid d_cuserid
+eval $inlibc
+
+: see if this is a limits.h system
+set limits.h i_limits
+eval $inhdr
+
+: see if this is a float.h system
+set float.h i_float
+eval $inhdr
+
+: See if number of significant digits in a double precision number is known
+echo " "
+$cat >dbl_dig.c <<EOM
+#$i_limits I_LIMITS
+#$i_float I_FLOAT
+#ifdef I_LIMITS
+#include <limits.h>
+#endif
+#ifdef I_FLOAT
+#include <float.h>
+#endif
+#ifdef DBL_DIG
+printf("Contains DBL_DIG");
+#endif
+EOM
+$cppstdin $cppflags $cppminus < dbl_dig.c >dbl_dig.E 2>/dev/null
+if $contains 'DBL_DIG' dbl_dig.E >/dev/null 2>&1; then
+ echo "DBL_DIG found." >&4
+ val="$define"
+else
+ echo "DBL_DIG NOT found." >&4
+ val="$undef"
+fi
+$rm -f dbl_dig.?
+set d_dbl_dig
+eval $setvar
+
+: see if difftime exists
+set difftime d_difftime
+eval $inlibc
+
+: see if this is a dirent system
+echo " "
+if xinc=`./findhdr dirent.h`; $test "$xinc"; then
+ val="$define"
+ echo "<dirent.h> found." >&4
+else
+ val="$undef"
+ if xinc=`./findhdr sys/dir.h`; $test "$xinc"; then
+ echo "<sys/dir.h> found." >&4
+ echo " "
+ else
+ xinc=`./findhdr sys/ndir.h`
+ fi
+ echo "<dirent.h> NOT found." >&4
+fi
+set i_dirent
+eval $setvar
+
+: Look for type of directory structure.
+echo " "
+$cppstdin $cppflags $cppminus < "$xinc" > try.c
+
+case "$direntrytype" in
+''|' ')
+ case "$i_dirent" in
+ $define) guess1='struct dirent' ;;
+ *) guess1='struct direct' ;;
+ esac
+ ;;
+*) guess1="$direntrytype"
+ ;;
+esac
+
+case "$guess1" in
+'struct dirent') guess2='struct direct' ;;
+*) guess2='struct dirent' ;;
+esac
+
+if $contains "$guess1" try.c >/dev/null 2>&1; then
+ direntrytype="$guess1"
+ echo "Your directory entries are $direntrytype." >&4
+elif $contains "$guess2" try.c >/dev/null 2>&1; then
+ direntrytype="$guess2"
+ echo "Your directory entries seem to be $direntrytype." >&4
+else
+ echo "I don't recognize your system's directory entries." >&4
+ rp="What type is used for directory entries on this system?"
+ dflt="$guess1"
+ . ./myread
+ direntrytype="$ans"
+fi
+$rm -f try.c
+
+
+: see if the directory entry stores field length
+echo " "
+$cppstdin $cppflags $cppminus < "$xinc" > try.c
+if $contains 'd_namlen' try.c >/dev/null 2>&1; then
+ echo "Good, your directory entry keeps length information in d_namlen." >&4
+ val="$define"
+else
+ echo "Your directory entry does not know about the d_namlen field." >&4
+ val="$undef"
+fi
+set d_dirnamlen
+eval $setvar
+$rm -f try.c
+
+: see if dlerror exists
+xxx_runnm="$runnm"
+runnm=false
+set dlerror d_dlerror
+eval $inlibc
+runnm="$xxx_runnm"
+
+: see if dlfcn is available
+set dlfcn.h i_dlfcn
+eval $inhdr
+
+case "$usedl" in
+$define|y|true)
+ $cat << EOM
+
+On a few systems, the dynamically loaded modules that perl generates and uses
+will need a different extension than shared libs. The default will probably
+be appropriate.
+
+EOM
+ case "$dlext" in
+ '') dflt="$so" ;;
+ *) dflt="$dlext" ;;
+ esac
+ rp='What is the extension of dynamically loaded modules'
+ . ./myread
+ dlext="$ans"
+ ;;
+*)
+ dlext="none"
+ ;;
+esac
+
+: Check if dlsym need a leading underscore
+echo " "
+val="$undef"
+
+case "$dlsrc" in
+dl_dlopen.xs)
+ echo "Checking whether your dlsym() needs a leading underscore ..." >&4
+ $cat >dyna.c <<'EOM'
+fred () { }
+EOM
+
+$cat >fred.c<<EOM
+
+#include <stdio.h>
+#$i_dlfcn I_DLFCN
+#ifdef I_DLFCN
+#include <dlfcn.h> /* the dynamic linker include file for Sunos/Solaris */
+#else
+#include <sys/types.h>
+#include <nlist.h>
+#include <link.h>
+#endif
+
+extern int fred() ;
+
+main()
+{
+ void * handle ;
+ void * symbol ;
+#ifndef RTLD_LAZY
+ int mode = 1 ;
+#else
+ int mode = RTLD_LAZY ;
+#endif
+ handle = dlopen("./dyna.$dlext", mode) ;
+ if (handle == NULL) {
+ printf ("1\n") ;
+ fflush (stdout) ;
+ exit(0);
+ }
+ symbol = dlsym(handle, "fred") ;
+ if (symbol == NULL) {
+ /* try putting a leading underscore */
+ symbol = dlsym(handle, "_fred") ;
+ if (symbol == NULL) {
+ printf ("2\n") ;
+ fflush (stdout) ;
+ exit(0);
+ }
+ printf ("3\n") ;
+ }
+ else
+ printf ("4\n") ;
+ fflush (stdout) ;
+ exit(0);
+}
+EOM
+ : Call the object file tmp-dyna.o in case dlext=o.
+ if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 &&
+ mv dyna${_o} tmp-dyna${_o} > /dev/null 2>&1 &&
+ $ld $lddlflags -o dyna.$dlext tmp-dyna${_o} > /dev/null 2>&1 &&
+ $cc $ccflags -o fred $ldflags $cccdlflags $ccdlflags fred.c $libs > /dev/null 2>&1; then
+ xxx=`./fred`
+ case $xxx in
+ 1) echo "Test program failed using dlopen." >&4
+ echo "Perhaps you should not use dynamic loading." >&4;;
+ 2) echo "Test program failed using dlsym." >&4
+ echo "Perhaps you should not use dynamic loading." >&4;;
+ 3) echo "dlsym needs a leading underscore" >&4
+ val="$define" ;;
+ 4) echo "dlsym doesn't need a leading underscore." >&4;;
+ esac
+ else
+ echo "I can't compile and run the test program." >&4
+ fi
+ ;;
+esac
+
+$rm -f fred fred.? dyna.$dlext dyna.? tmp-dyna.?
+
+set d_dlsymun
+eval $setvar
+
+: see if dup2 exists
+set dup2 d_dup2
+eval $inlibc
+
+: see if endhostent exists
+set endhostent d_endhent
+eval $inlibc
+
+: see if endnetent exists
+set endnetent d_endnent
+eval $inlibc
+
+: see if endprotoent exists
+set endprotoent d_endpent
+eval $inlibc
+
+: see if endservent exists
+set endservent d_endsent
+eval $inlibc
+
+: Locate the flags for 'open()'
+echo " "
+$cat >open3.c <<'EOCP'
+#include <sys/types.h>
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+main() {
+ if(O_RDONLY);
+#ifdef O_TRUNC
+ exit(0);
+#else
+ exit(1);
+#endif
+}
+EOCP
+: check sys/file.h first to get FREAD on Sun
+if $test `./findhdr sys/file.h` && \
+ set open3 -DI_SYS_FILE && eval $compile; then
+ h_sysfile=true;
+ echo "<sys/file.h> defines the O_* constants..." >&4
+ if ./open3; then
+ echo "and you have the 3 argument form of open()." >&4
+ val="$define"
+ else
+ echo "but not the 3 argument form of open(). Oh, well." >&4
+ val="$undef"
+ fi
+elif $test `./findhdr fcntl.h` && \
+ set open3 -DI_FCNTL && eval $compile; then
+ h_fcntl=true;
+ echo "<fcntl.h> defines the O_* constants..." >&4
+ if ./open3; then
+ echo "and you have the 3 argument form of open()." >&4
+ val="$define"
+ else
+ echo "but not the 3 argument form of open(). Oh, well." >&4
+ val="$undef"
+ fi
+else
+ val="$undef"
+ echo "I can't find the O_* constant definitions! You got problems." >&4
+fi
+set d_open3
+eval $setvar
+$rm -f open3*
+
+: check for non-blocking I/O stuff
+case "$h_sysfile" in
+true) echo "#include <sys/file.h>" > head.c;;
+*)
+ case "$h_fcntl" in
+ true) echo "#include <fcntl.h>" > head.c;;
+ *) echo "#include <sys/fcntl.h>" > head.c;;
+ esac
+ ;;
+esac
+echo " "
+echo "Figuring out the flag used by open() for non-blocking I/O..." >&4
+case "$o_nonblock" in
+'')
+ $cat head.c > try.c
+ $cat >>try.c <<'EOCP'
+main() {
+#ifdef O_NONBLOCK
+ printf("O_NONBLOCK\n");
+ exit(0);
+#endif
+#ifdef O_NDELAY
+ printf("O_NDELAY\n");
+ exit(0);
+#endif
+#ifdef FNDELAY
+ printf("FNDELAY\n");
+ exit(0);
+#endif
+ exit(0);
+}
+EOCP
+ set try
+ if eval $compile_ok; then
+ o_nonblock=`./try`
+ case "$o_nonblock" in
+ '') echo "I can't figure it out, assuming O_NONBLOCK will do.";;
+ *) echo "Seems like we can use $o_nonblock.";;
+ esac
+ else
+ echo "(I can't compile the test program; pray O_NONBLOCK is right!)"
+ fi
+ ;;
+*) echo "Using $hint value $o_nonblock.";;
+esac
+$rm -f try try.* .out core
+
+echo " "
+echo "Let's see what value errno gets from read() on a $o_nonblock file..." >&4
+case "$eagain" in
+'')
+ $cat head.c > try.c
+ $cat >>try.c <<EOCP
+#include <errno.h>
+#include <sys/types.h>
+#include <signal.h>
+#define MY_O_NONBLOCK $o_nonblock
+#ifndef errno /* XXX need better Configure test */
+extern int errno;
+#endif
+$signal_t blech(x) int x; { exit(3); }
+EOCP
+ $cat >> try.c <<'EOCP'
+main()
+{
+ int pd[2];
+ int pu[2];
+ char buf[1];
+ char string[100];
+
+ pipe(pd); /* Down: child -> parent */
+ pipe(pu); /* Up: parent -> child */
+ if (0 != fork()) {
+ int ret;
+ close(pd[1]); /* Parent reads from pd[0] */
+ close(pu[0]); /* Parent writes (blocking) to pu[1] */
+ if (-1 == fcntl(pd[0], F_SETFL, MY_O_NONBLOCK))
+ exit(1);
+ signal(SIGALRM, blech);
+ alarm(5);
+ if ((ret = read(pd[0], buf, 1)) > 0) /* Nothing to read! */
+ exit(2);
+ sprintf(string, "%d\n", ret);
+ write(2, string, strlen(string));
+ alarm(0);
+#ifdef EAGAIN
+ if (errno == EAGAIN) {
+ printf("EAGAIN\n");
+ goto ok;
+ }
+#endif
+#ifdef EWOULDBLOCK
+ if (errno == EWOULDBLOCK)
+ printf("EWOULDBLOCK\n");
+#endif
+ ok:
+ write(pu[1], buf, 1); /* Unblocks child, tell it to close our pipe */
+ sleep(2); /* Give it time to close our pipe */
+ alarm(5);
+ ret = read(pd[0], buf, 1); /* Should read EOF */
+ alarm(0);
+ sprintf(string, "%d\n", ret);
+ write(3, string, strlen(string));
+ exit(0);
+ }
+
+ close(pd[0]); /* We write to pd[1] */
+ close(pu[1]); /* We read from pu[0] */
+ read(pu[0], buf, 1); /* Wait for parent to signal us we may continue */
+ close(pd[1]); /* Pipe pd is now fully closed! */
+ exit(0); /* Bye bye, thank you for playing! */
+}
+EOCP
+ set try
+ if eval $compile_ok; then
+ echo "$startsh" >mtry
+ echo "./try >try.out 2>try.ret 3>try.err || exit 4" >>mtry
+ chmod +x mtry
+ ./mtry >/dev/null 2>&1
+ case $? in
+ 0) eagain=`$cat try.out`;;
+ 1) echo "Could not perform non-blocking setting!";;
+ 2) echo "I did a successful read() for something that was not there!";;
+ 3) echo "Hmm... non-blocking I/O does not seem to be working!";;
+ *) echo "Something terribly wrong happened during testing.";;
+ esac
+ rd_nodata=`$cat try.ret`
+ echo "A read() system call with no data present returns $rd_nodata."
+ case "$rd_nodata" in
+ 0|-1) ;;
+ *)
+ echo "(That's peculiar, fixing that to be -1.)"
+ rd_nodata=-1
+ ;;
+ esac
+ case "$eagain" in
+ '')
+ echo "Forcing errno EAGAIN on read() with no data available."
+ eagain=EAGAIN
+ ;;
+ *)
+ echo "Your read() sets errno to $eagain when no data is available."
+ ;;
+ esac
+ status=`$cat try.err`
+ case "$status" in
+ 0) echo "And it correctly returns 0 to signal EOF.";;
+ -1) echo "But it also returns -1 to signal EOF, so be careful!";;
+ *) echo "However, your read() returns '$status' on EOF??";;
+ esac
+ val="$define"
+ if test "$status" = "$rd_nodata"; then
+ echo "WARNING: you can't distinguish between EOF and no data!"
+ val="$undef"
+ fi
+ else
+ echo "I can't compile the test program--assuming errno EAGAIN will do."
+ eagain=EAGAIN
+ fi
+ set d_eofnblk
+ eval $setvar
+ ;;
+*)
+ echo "Using $hint value $eagain."
+ echo "Your read() returns $rd_nodata when no data is present."
+ case "$d_eofnblk" in
+ "$define") echo "And you can see EOF because read() returns 0.";;
+ "$undef") echo "But you can't see EOF status from read() returned value.";;
+ *)
+ echo "(Assuming you can't see EOF status from read anyway.)"
+ d_eofnblk=$undef
+ ;;
+ esac
+ ;;
+esac
+$rm -f try try.* .out core head.c mtry
+
+: see if fchmod exists
+set fchmod d_fchmod
+eval $inlibc
+
+: see if fchown exists
+set fchown d_fchown
+eval $inlibc
+
+: see if this is an fcntl system
+set fcntl d_fcntl
+eval $inlibc
+
+: see if fgetpos exists
+set fgetpos d_fgetpos
+eval $inlibc
+
+: see if flock exists
+set flock d_flock
+eval $inlibc
+
+: see if fork exists
+set fork d_fork
+eval $inlibc
+
+: see if pathconf exists
+set pathconf d_pathconf
+eval $inlibc
+
+: see if fpathconf exists
+set fpathconf d_fpathconf
+eval $inlibc
+
+: see if fsetpos exists
+set fsetpos d_fsetpos
+eval $inlibc
+
+: see if gethostbyaddr exists
+set gethostbyaddr d_gethbyaddr
+eval $inlibc
+
+: see if gethostbyname exists
+set gethostbyname d_gethbyname
+eval $inlibc
+
+: see if gethostent exists
+set gethostent d_gethent
+eval $inlibc
+
+hasproto='varname=$1; func=$2; shift; shift;
+while $test $# -ge 2; do
+ case "$1" in
+ $define) echo "#include <$2>";;
+ esac ;
+ shift 2;
+done > try.c;
+$cppstdin $cppflags $cppminus < try.c > tryout.c 2>/dev/null;
+if $contains "$func.*(" tryout.c >/dev/null 2>&1; then
+ echo "$func() prototype found.";
+ val="$define";
+else
+ echo "$func() prototype NOT found.";
+ val="$undef";
+fi;
+set $varname;
+eval $setvar;
+$rm -f try.c tryout.c'
+
+: see if this is a netdb.h system
+set netdb.h i_netdb
+eval $inhdr
+
+: see if prototypes for various gethostxxx netdb.h functions are available
+echo " "
+set d_gethostprotos gethostent $i_netdb netdb.h
+eval $hasproto
+
+: see if getlogin exists
+set getlogin d_getlogin
+eval $inlibc
+
+: see if getnetbyaddr exists
+set getnetbyaddr d_getnbyaddr
+eval $inlibc
+
+: see if getnetbyname exists
+set getnetbyname d_getnbyname
+eval $inlibc
+
+: see if getnetent exists
+set getnetent d_getnent
+eval $inlibc
+
+: see if prototypes for various getnetxxx netdb.h functions are available
+echo " "
+set d_getnetprotos getnetent $i_netdb netdb.h
+eval $hasproto
+
+
+: see if getprotobyname exists
+set getprotobyname d_getpbyname
+eval $inlibc
+
+: see if getprotobynumber exists
+set getprotobynumber d_getpbynumber
+eval $inlibc
+
+: see if getprotoent exists
+set getprotoent d_getpent
+eval $inlibc
+
+: see if getpgid exists
+set getpgid d_getpgid
+eval $inlibc
+
+: see if getpgrp2 exists
+set getpgrp2 d_getpgrp2
+eval $inlibc
+
+: see if getppid exists
+set getppid d_getppid
+eval $inlibc
+
+: see if getpriority exists
+set getpriority d_getprior
+eval $inlibc
+
+: see if prototypes for various getprotoxxx netdb.h functions are available
+echo " "
+set d_getprotoprotos getprotoent $i_netdb netdb.h
+eval $hasproto
+
+: see if getservbyname exists
+set getservbyname d_getsbyname
+eval $inlibc
+
+: see if getservbyport exists
+set getservbyport d_getsbyport
+eval $inlibc
+
+: see if getservent exists
+set getservent d_getsent
+eval $inlibc
+
+: see if prototypes for various getservxxx netdb.h functions are available
+echo " "
+set d_getservprotos getservent $i_netdb netdb.h
+eval $hasproto
+
+: see if gettimeofday or ftime exists
+set gettimeofday d_gettimeod
+eval $inlibc
+case "$d_gettimeod" in
+"$undef")
+ set ftime d_ftime
+ eval $inlibc
+ ;;
+*)
+ val="$undef"; set d_ftime; eval $setvar
+ ;;
+esac
+case "$d_gettimeod$d_ftime" in
+"$undef$undef")
+ echo " "
+ echo 'No ftime() nor gettimeofday() -- timing may be less accurate.' >&4
+ ;;
+esac
+
+: see if this is a netinet/in.h or sys/in.h system
+set netinet/in.h i_niin sys/in.h i_sysin
+eval $inhdr
+
+: see if this is an arpa/inet.h
+set arpa/inet.h i_arpainet
+eval $inhdr
+
+: see if htonl --and friends-- exists
+val=''
+set htonl val
+eval $inlibc
+
+: Maybe they are macros.
+case "$val" in
+$undef)
+ $cat >htonl.c <<EOM
+#include <stdio.h>
+#include <sys/types.h>
+#$i_niin I_NETINET_IN
+#$i_sysin I_SYS_IN
+#$i_arpainet I_ARPA_INET
+#ifdef I_NETINET_IN
+#include <netinet/in.h>
+#endif
+#ifdef I_SYS_IN
+#include <sys/in.h>
+#endif
+#ifdef I_ARPA_INET
+#include <arpa/inet.h>
+#endif
+#ifdef htonl
+printf("Defined as a macro.");
+#endif
+EOM
+ $cppstdin $cppflags $cppminus < htonl.c >htonl.E 2>/dev/null
+ if $contains 'Defined as a macro' htonl.E >/dev/null 2>&1; then
+ val="$define"
+ echo "But it seems to be defined as a macro." >&4
+ fi
+ $rm -f htonl.?
+ ;;
+esac
+set d_htonl
+eval $setvar
+
+: see which of string.h or strings.h is needed
+echo " "
+strings=`./findhdr string.h`
+if $test "$strings" && $test -r "$strings"; then
+ echo "Using <string.h> instead of <strings.h>." >&4
+ val="$define"
+else
+ val="$undef"
+ strings=`./findhdr strings.h`
+ if $test "$strings" && $test -r "$strings"; then
+ echo "Using <strings.h> instead of <string.h>." >&4
+ else
+ echo "No string header found -- You'll surely have problems." >&4
+ fi
+fi
+set i_string
+eval $setvar
+case "$i_string" in
+"$undef") strings=`./findhdr strings.h`;;
+*) strings=`./findhdr string.h`;;
+esac
+
+: index or strchr
+echo " "
+if set index val -f; eval $csym; $val; then
+ if set strchr val -f d_strchr; eval $csym; $val; then
+ if $contains strchr "$strings" >/dev/null 2>&1 ; then
+ val="$define"
+ vali="$undef"
+ echo "strchr() found." >&4
+ else
+ val="$undef"
+ vali="$define"
+ echo "index() found." >&4
+ fi
+ else
+ val="$undef"
+ vali="$define"
+ echo "index() found." >&4
+ fi
+else
+ if set strchr val -f d_strchr; eval $csym; $val; then
+ val="$define"
+ vali="$undef"
+ echo "strchr() found." >&4
+ else
+ echo "No index() or strchr() found!" >&4
+ val="$undef"
+ vali="$undef"
+ fi
+fi
+set d_strchr; eval $setvar
+val="$vali"
+set d_index; eval $setvar
+
+: check whether inet_aton exists
+set inet_aton d_inetaton
+eval $inlibc
+
+: Look for isascii
+echo " "
+$cat >isascii.c <<'EOCP'
+#include <stdio.h>
+#include <ctype.h>
+main() {
+ int c = 'A';
+ if (isascii(c))
+ exit(0);
+ else
+ exit(1);
+}
+EOCP
+set isascii
+if eval $compile; then
+ echo "isascii() found." >&4
+ val="$define"
+else
+ echo "isascii() NOT found." >&4
+ val="$undef"
+fi
+set d_isascii
+eval $setvar
+$rm -f isascii*
+
+: see if killpg exists
+set killpg d_killpg
+eval $inlibc
+
+: see if lchown exists
+echo " "
+$cat > try.c <<'EOCP'
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char lchown(); below. */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char lchown();
+int main() {
+ /* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined (__stub_lchown) || defined (__stub___lchown)
+choke me
+#else
+lchown();
+#endif
+; return 0; }
+EOCP
+set try
+if eval $compile; then
+ $echo "lchown() found." >&4
+ val="$define"
+else
+ $echo "lchown() NOT found." >&4
+ val="$undef"
+fi
+set d_lchown
+eval $setvar
+
+: see if link exists
+set link d_link
+eval $inlibc
+
+: see if localeconv exists
+set localeconv d_locconv
+eval $inlibc
+
+: see if lockf exists
+set lockf d_lockf
+eval $inlibc
+
+: check for long doubles
+echo " "
+echo $n "Checking to see if your system supports long doubles...$c" >&4
+echo 'long double foo() { long double x; x = 7.0; return x; }' > try.c
+if $cc $optimize $ccflags -c try.c >/dev/null 2>&1; then
+ val="$define"
+ echo " Yup, it does." >&4
+else
+ val="$undef"
+ echo " Nope, it doesn't." >&4
+fi
+$rm try.*
+set d_longdbl
+eval $setvar
+
+: check for length of long double
+case "${d_longdbl}${longdblsize}" in
+$define)
+ echo " "
+ $echo $n "Checking to see how big your long doubles are...$c" >&4
+ $cat >try.c <<'EOCP'
+#include <stdio.h>
+main()
+{
+ printf("%d\n", sizeof(long double));
+}
+EOCP
+ set try
+ if eval $compile; then
+ longdblsize=`./try`
+ $echo " $longdblsize bytes." >&4
+ else
+ dflt='8'
+ echo " "
+ echo "(I can't seem to compile the test program. Guessing...)" >&4
+ rp="What is the size of a long double (in bytes)?"
+ . ./myread
+ longdblsize="$ans"
+ fi
+ ;;
+esac
+$rm -f try.c try
+
+: check for long long
+echo " "
+echo $n "Checking to see if your system supports long long...$c" >&4
+echo 'long long foo() { long long x; x = 7; return x; }' > try.c
+if $cc $optimize $ccflags -c try.c >/dev/null 2>&1; then
+ val="$define"
+ echo " Yup, it does." >&4
+else
+ val="$undef"
+ echo " Nope, it doesn't." >&4
+fi
+$rm try.*
+set d_longlong
+eval $setvar
+
+: check for length of long long
+case "${d_longlong}${longlongsize}" in
+$define)
+ echo " "
+ $echo $n "Checking to see how big your long longs are...$c" >&4
+ $cat >try.c <<'EOCP'
+#include <stdio.h>
+main()
+{
+ printf("%d\n", sizeof(long long));
+}
+EOCP
+ set try
+ if eval $compile_ok; then
+ longlongsize=`./try`
+ $echo " $longlongsize bytes." >&4
+ else
+ dflt='8'
+ echo " "
+ echo "(I can't seem to compile the test program. Guessing...)"
+ rp="What is the size of a long long (in bytes)?"
+ . ./myread
+ longlongsize="$ans"
+ fi
+ ;;
+esac
+$rm -f try.c try
+
+: see if lstat exists
+set lstat d_lstat
+eval $inlibc
+
+: see if mblen exists
+set mblen d_mblen
+eval $inlibc
+
+: see if mbstowcs exists
+set mbstowcs d_mbstowcs
+eval $inlibc
+
+: see if mbtowc exists
+set mbtowc d_mbtowc
+eval $inlibc
+
+: see if memcmp exists
+set memcmp d_memcmp
+eval $inlibc
+
+: see if memcpy exists
+set memcpy d_memcpy
+eval $inlibc
+
+: see if memmove exists
+set memmove d_memmove
+eval $inlibc
+
+: see if memset exists
+set memset d_memset
+eval $inlibc
+
+: see if mkdir exists
+set mkdir d_mkdir
+eval $inlibc
+
+: see if mkfifo exists
+set mkfifo d_mkfifo
+eval $inlibc
+
+: see if mktime exists
+set mktime d_mktime
+eval $inlibc
+
+: see if msgctl exists
+set msgctl d_msgctl
+eval $inlibc
+
+: see if msgget exists
+set msgget d_msgget
+eval $inlibc
+
+: see if msgsnd exists
+set msgsnd d_msgsnd
+eval $inlibc
+
+: see if msgrcv exists
+set msgrcv d_msgrcv
+eval $inlibc
+
+: see how much of the 'msg*(2)' library is present.
+h_msg=true
+echo " "
+case "$d_msgctl$d_msgget$d_msgsnd$d_msgrcv" in
+*"$undef"*) h_msg=false;;
+esac
+case "$osname" in
+freebsd)
+ case "`ipcs 2>&1`" in
+ "SVID messages"*"not configured"*)
+ echo "But your FreeBSD kernel does not have the msg*(2) configured." >&4
+ h_msg=false
+ val="$undef"
+ set msgctl d_msgctl
+ eval $setvar
+ set msgget d_msgget
+ eval $setvar
+ set msgsnd d_msgsnd
+ eval $setvar
+ set msgrcv d_msgrcv
+ eval $setvar
+ ;;
+ esac
+ ;;
+esac
+: we could also check for sys/ipc.h ...
+if $h_msg && $test `./findhdr sys/msg.h`; then
+ echo "You have the full msg*(2) library." >&4
+ val="$define"
+else
+ echo "You don't have the full msg*(2) library." >&4
+ val="$undef"
+fi
+set d_msg
+eval $setvar
+
+: see if nice exists
+set nice d_nice
+eval $inlibc
+
+: see if pause exists
+set pause d_pause
+eval $inlibc
+
+: see if pipe exists
+set pipe d_pipe
+eval $inlibc
+
+: see if poll exists
+set poll d_poll
+eval $inlibc
+
+
+: see whether the various POSIXish _yields exist within given cccmd
+$cat >try.c <<EOP
+#include <pthread.h>
+main() {
+ YIELD();
+ exit(0);
+}
+EOP
+: see if pthread_yield exists within given cccmd,
+: if we do not usethreads this may well end up undef.
+set try -DYIELD=pthread_yield
+if eval $compile; then
+ val="$define"
+ echo 'pthread_yield() found.' >&4
+else
+ val="$undef"
+ echo 'pthread_yield() NOT found.' >&4
+fi
+set d_pthread_yield
+eval $setvar
+
+: see if sched_yield exists within given cccmd,
+: if we do not usethreads this may well end up undef.
+set try -DYIELD=sched_yield
+if eval $compile; then
+ val="$define"
+ echo 'sched_yield() found.' >&4
+else
+ val="$undef"
+ echo 'sched_yield() NOT found.' >&4
+fi
+set d_sched_yield
+eval $setvar
+$rm -f try try.*
+
+: test whether pthreads are created in joinable -- aka undetached -- state
+if test "X$usethreads" = "X$define"; then
+ echo $n "Checking whether pthreads are created joinable. $c" >&4
+ $cat >try.c <<'EOCP'
+#include <pthread.h>
+#include <stdio.h>
+int main() {
+ pthread_attr_t attr;
+ int detachstate;
+ printf("%s\n",
+ pthread_attr_init(&attr) == 0 &&
+ pthread_attr_getdetachstate(&attr, &detachstate) == 0 &&
+ detachstate == PTHREAD_CREATE_DETACHED ?
+ "detached" : "joinable");
+ exit(0);
+}
+EOCP
+ set try
+ if eval $compile; then
+ yyy=`./try`
+ case "$yyy" in
+ detached) echo "Nope, they aren't." >&4 ;;
+ *) echo "Yup, they are." >&4 ;;
+ esac
+ else
+ echo " "
+ echo "(I can't execute the test program--assuming they are.)" >&4
+ yyy=joinable
+ fi
+ $rm -f try try.*
+ case "$yyy" in
+ detached) val="$undef" ;;
+ *) val="$define" ;;
+ esac
+ set d_pthreads_created_joinable
+ eval $setvar
+else
+ d_pthreads_created_joinable="$undef"
+fi
+
+: see if this is a pwd.h system
+set pwd.h i_pwd
+eval $inhdr
+
+case "$i_pwd" in
+$define)
+ : see if setpwent exists
+ set setpwent d_setpwent
+ eval $inlibc
+
+ : see if getpwent exists
+ set getpwent d_getpwent
+ eval $inlibc
+
+ : see if endpwent exists
+ set endpwent d_endpwent
+ eval $inlibc
+
+ xxx=`./findhdr pwd.h`
+ $cppstdin $cppflags $cppminus < $xxx >$$.h
+
+ if $contains 'pw_quota' $$.h >/dev/null 2>&1; then
+ val="$define"
+ else
+ val="$undef"
+ fi
+ set d_pwquota
+ eval $setvar
+
+ if $contains 'pw_age' $$.h >/dev/null 2>&1; then
+ val="$define"
+ else
+ val="$undef"
+ fi
+ set d_pwage
+ eval $setvar
+
+ if $contains 'pw_change' $$.h >/dev/null 2>&1; then
+ val="$define"
+ else
+ val="$undef"
+ fi
+ set d_pwchange
+ eval $setvar
+
+ if $contains 'pw_class' $$.h >/dev/null 2>&1; then
+ val="$define"
+ else
+ val="$undef"
+ fi
+ set d_pwclass
+ eval $setvar
+
+ if $contains 'pw_expire' $$.h >/dev/null 2>&1; then
+ val="$define"
+ else
+ val="$undef"
+ fi
+ set d_pwexpire
+ eval $setvar
+
+ if $contains 'pw_comment' $$.h >/dev/null 2>&1; then
+ val="$define"
+ else
+ val="$undef"
+ fi
+ set d_pwcomment
+ eval $setvar
+
+ if $contains 'pw_gecos' $$.h >/dev/null 2>&1; then
+ val="$define"
+ else
+ val="$undef"
+ fi
+ set d_pwgecos
+ eval $setvar
+
+ if $contains 'pw_passwd' $$.h >/dev/null 2>&1; then
+ val="$define"
+ else
+ val="$undef"
+ fi
+ set d_pwpasswd
+ eval $setvar
+
+ $rm -f $$.h
+ ;;
+*) # Assume all is lost as far as the d_*pw* go.
+ val="$undef";
+ set d_setpwent; eval $setvar
+ set d_getpwent; eval $setvar
+ set d_endpwent; eval $setvar
+ set d_pwquota; eval $setvar
+ set d_pwage; eval $setvar
+ set d_pwchange; eval $setvar
+ set d_pwclass; eval $setvar
+ set d_pwexpire; eval $setvar
+ set d_pwcomment; eval $setvar
+ set d_pwgecos; eval $setvar
+ set d_pwpasswd; eval $setvar
+ ;;
+esac
+
+: see if readdir and friends exist
+set readdir d_readdir
+eval $inlibc
+set seekdir d_seekdir
+eval $inlibc
+set telldir d_telldir
+eval $inlibc
+set rewinddir d_rewinddir
+eval $inlibc
+
+: see if readlink exists
+set readlink d_readlink
+eval $inlibc
+
+: see if rename exists
+set rename d_rename
+eval $inlibc
+
+: see if rmdir exists
+set rmdir d_rmdir
+eval $inlibc
+
+: see if memory.h is available.
+val=''
+set memory.h val
+eval $inhdr
+
+: See if it conflicts with string.h
+case "$val" in
+$define)
+ case "$strings" in
+ '') ;;
+ *)
+ $cppstdin $cppflags $cppminus < $strings > mem.h
+ if $contains 'memcpy' mem.h >/dev/null 2>&1; then
+ echo " "
+ echo "We won't be including <memory.h>."
+ val="$undef"
+ fi
+ $rm -f mem.h
+ ;;
+ esac
+esac
+set i_memory
+eval $setvar
+
+: can bcopy handle overlapping blocks?
+val="$undef"
+case "$d_bcopy" in
+"$define")
+ echo " "
+ echo "Checking to see if your bcopy() can do overlapping copies..." >&4
+ $cat >try.c <<EOCP
+#$i_memory I_MEMORY
+#$i_stdlib I_STDLIB
+#$i_string I_STRING
+#$i_unistd I_UNISTD
+EOCP
+ $cat >>try.c <<'EOCP'
+#include <stdio.h>
+#ifdef I_MEMORY
+# include <memory.h>
+#endif
+#ifdef I_STDLIB
+# include <stdlib.h>
+#endif
+#ifdef I_STRING
+# include <string.h>
+#else
+# include <strings.h>
+#endif
+#ifdef I_UNISTD
+# include <unistd.h> /* Needed for NetBSD */
+#endif
+main()
+{
+char buf[128], abc[128];
+char *b;
+int len;
+int off;
+int align;
+
+bcopy("abcdefghijklmnopqrstuvwxyz0123456789", abc, 36);
+
+for (align = 7; align >= 0; align--) {
+ for (len = 36; len; len--) {
+ b = buf+align;
+ bcopy(abc, b, len);
+ for (off = 1; off <= len; off++) {
+ bcopy(b, b+off, len);
+ bcopy(b+off, b, len);
+ if (bcmp(b, abc, len))
+ exit(1);
+ }
+ }
+}
+exit(0);
+}
+EOCP
+ set try
+ if eval $compile_ok; then
+ if ./try 2>/dev/null; then
+ echo "Yes, it can."
+ val="$define"
+ else
+ echo "It can't, sorry."
+ case "$d_memmove" in
+ "$define") echo "But that's Ok since you have memmove()." ;;
+ esac
+ fi
+ else
+ echo "(I can't compile the test program, so we'll assume not...)"
+ case "$d_memmove" in
+ "$define") echo "But that's Ok since you have memmove()." ;;
+ esac
+ fi
+ ;;
+esac
+$rm -f try.* try core
+set d_safebcpy
+eval $setvar
+
+: can memcpy handle overlapping blocks?
+val="$undef"
+case "$d_memcpy" in
+"$define")
+ echo " "
+ echo "Checking to see if your memcpy() can do overlapping copies..." >&4
+ $cat >try.c <<EOCP
+#$i_memory I_MEMORY
+#$i_stdlib I_STDLIB
+#$i_string I_STRING
+#$i_unistd I_UNISTD
+EOCP
+ $cat >>try.c <<'EOCP'
+#include <stdio.h>
+#ifdef I_MEMORY
+# include <memory.h>
+#endif
+#ifdef I_STDLIB
+# include <stdlib.h>
+#endif
+#ifdef I_STRING
+# include <string.h>
+#else
+# include <strings.h>
+#endif
+#ifdef I_UNISTD
+# include <unistd.h> /* Needed for NetBSD */
+#endif
+main()
+{
+char buf[128], abc[128];
+char *b;
+int len;
+int off;
+int align;
+
+/* Copy "abcde..." string to char abc[] so that gcc doesn't
+ try to store the string in read-only memory. */
+memcpy(abc, "abcdefghijklmnopqrstuvwxyz0123456789", 36);
+
+for (align = 7; align >= 0; align--) {
+ for (len = 36; len; len--) {
+ b = buf+align;
+ memcpy(b, abc, len);
+ for (off = 1; off <= len; off++) {
+ memcpy(b+off, b, len);
+ memcpy(b, b+off, len);
+ if (memcmp(b, abc, len))
+ exit(1);
+ }
+ }
+}
+exit(0);
+}
+EOCP
+ set try
+ if eval $compile_ok; then
+ if ./try 2>/dev/null; then
+ echo "Yes, it can."
+ val="$define"
+ else
+ echo "It can't, sorry."
+ case "$d_memmove" in
+ "$define") echo "But that's Ok since you have memmove()." ;;
+ esac
+ fi
+ else
+ echo "(I can't compile the test program, so we'll assume not...)"
+ case "$d_memmove" in
+ "$define") echo "But that's Ok since you have memmove()." ;;
+ esac
+ fi
+ ;;
+esac
+$rm -f try.* try core
+set d_safemcpy
+eval $setvar
+
+: can memcmp be trusted to compare relative magnitude?
+val="$undef"
+case "$d_memcmp" in
+"$define")
+ echo " "
+ echo "Checking if your memcmp() can compare relative magnitude..." >&4
+ $cat >try.c <<EOCP
+#$i_memory I_MEMORY
+#$i_stdlib I_STDLIB
+#$i_string I_STRING
+#$i_unistd I_UNISTD
+EOCP
+ $cat >>try.c <<'EOCP'
+#include <stdio.h>
+#ifdef I_MEMORY
+# include <memory.h>
+#endif
+#ifdef I_STDLIB
+# include <stdlib.h>
+#endif
+#ifdef I_STRING
+# include <string.h>
+#else
+# include <strings.h>
+#endif
+#ifdef I_UNISTD
+# include <unistd.h> /* Needed for NetBSD */
+#endif
+main()
+{
+char a = -1;
+char b = 0;
+if ((a < b) && memcmp(&a, &b, 1) < 0)
+ exit(1);
+exit(0);
+}
+EOCP
+ set try
+ if eval $compile_ok; then
+ if ./try 2>/dev/null; then
+ echo "Yes, it can."
+ val="$define"
+ else
+ echo "No, it can't (it uses signed chars)."
+ fi
+ else
+ echo "(I can't compile the test program, so we'll assume not...)"
+ fi
+ ;;
+esac
+$rm -f try.* try core
+set d_sanemcmp
+eval $setvar
+
+: see if select exists
+set select d_select
+eval $inlibc
+
+: see if semctl exists
+set semctl d_semctl
+eval $inlibc
+
+: see if semget exists
+set semget d_semget
+eval $inlibc
+
+: see if semop exists
+set semop d_semop
+eval $inlibc
+
+: see how much of the 'sem*(2)' library is present.
+h_sem=true
+echo " "
+case "$d_semctl$d_semget$d_semop" in
+*"$undef"*) h_sem=false;;
+esac
+case "$osname" in
+freebsd)
+ case "`ipcs 2>&1`" in
+ "SVID messages"*"not configured"*)
+ echo "But your FreeBSD kernel does not have the sem*(2) configured." >&4
+ h_sem=false
+ val="$undef"
+ set semctl d_semctl
+ eval $setvar
+ set semget d_semget
+ eval $setvar
+ set semop d_semop
+ eval $setvar
+ ;;
+ esac
+ ;;
+esac
+: we could also check for sys/ipc.h ...
+if $h_sem && $test `./findhdr sys/sem.h`; then
+ echo "You have the full sem*(2) library." >&4
+ val="$define"
+else
+ echo "You don't have the full sem*(2) library." >&4
+ val="$undef"
+fi
+set d_sem
+eval $setvar
+
+: see whether sys/sem.h defines union semun
+echo " "
+$cat > try.c <<'END'
+#include <sys/types.h>
+#include <sys/ipc.h>
+#include <sys/sem.h>
+int main () { union semun semun; semun.buf = 0; }
+END
+set try
+if eval $compile; then
+ echo "You have union semun in <sys/sem.h>." >&4
+ val="$define"
+else
+ echo "You do not have union semun in <sys/sem.h>." >&4
+ val="$undef"
+fi
+$rm -f try try.c
+set d_union_semun
+eval $setvar
+
+: see how to do semctl IPC_STAT
+case "$d_sem" in
+$define)
+ : see whether semctl IPC_STAT can use union semun
+ echo " "
+ $cat > try.c <<END
+#include <sys/types.h>
+#include <sys/ipc.h>
+#include <sys/sem.h>
+#include <sys/stat.h>
+#include <stdio.h>
+#include <errno.h>
+#ifndef errno
+extern int errno;
+#endif
+#$d_union_semun HAS_UNION_SEMUN
+int main() {
+ union semun
+#ifndef HAS_UNION_SEMUN
+ {
+ int val;
+ struct semid_ds *buf;
+ unsigned short *array;
+ }
+#endif
+ arg;
+ int sem, st;
+
+#if defined(IPC_PRIVATE) && defined(S_IRWXU) && defined(S_IRWXG) && defined(S_IRWXO) && defined(IPC_CREAT)
+ sem = semget(IPC_PRIVATE, 1, S_IRWXU|S_IRWXG|S_IRWXO|IPC_CREAT);
+ if (sem > -1) {
+ struct semid_ds argbuf;
+ arg.buf = &argbuf;
+# ifdef IPC_STAT
+ st = semctl(sem, 0, IPC_STAT, arg);
+ if (st == 0)
+ printf("semun\n");
+ else
+# endif /* IPC_STAT */
+ printf("semctl IPC_STAT failed: errno = %d\n", errno);
+# ifdef IPC_RMID
+ if (semctl(sem, 0, IPC_RMID, arg) != 0)
+# endif /* IPC_RMID */
+ printf("semctl IPC_RMID failed: errno = %d\n", errno);
+ } else
+#endif /* IPC_PRIVATE && ... */
+ printf("semget failed: errno = %d\n", errno);
+ return 0;
+}
+END
+ val="$undef"
+ set try
+ if eval $compile; then
+ xxx=`./try`
+ case "$xxx" in
+ semun) val="$define" ;;
+ esac
+ fi
+ $rm -f try try.c
+ set d_semctl_semun
+ eval $setvar
+ case "$d_semctl_semun" in
+ $define)
+ echo "You can use union semun for semctl IPC_STAT." >&4
+ also='also'
+ ;;
+ *) echo "You cannot use union semun for semctl IPC_STAT." >&4
+ also=''
+ ;;
+ esac
+
+ : see whether semctl IPC_STAT can use struct semid_ds pointer
+ $cat > try.c <<'END'
+#include <sys/types.h>
+#include <sys/ipc.h>
+#include <sys/sem.h>
+#include <sys/stat.h>
+#include <stdio.h>
+#include <errno.h>
+#ifndef errno
+extern int errno;
+#endif
+int main() {
+ struct semid_ds arg;
+ int sem, st;
+
+#if defined(IPC_PRIVATE) && defined(S_IRWXU) && defined(S_IRWXG) && defined(S_IRWXO) && defined(IPC_CREAT)
+ sem = semget(IPC_PRIVATE, 1, S_IRWXU|S_IRWXG|S_IRWXO|IPC_CREAT);
+ if (sem > -1) {
+# ifdef IPC_STAT
+ st = semctl(sem, 0, IPC_STAT, &arg);
+ if (st == 0)
+ printf("semid_ds\n");
+ else
+# endif /* IPC_STAT */
+ printf("semctl IPC_STAT failed: errno = %d\n", errno);
+# ifdef IPC_RMID
+ if (semctl(sem, 0, IPC_RMID, &arg) != 0)
+# endif /* IPC_RMID */
+ printf("semctl IPC_RMID failed: errno = %d\n", errno);
+ } else
+#endif /* IPC_PRIVATE && ... */
+ printf("semget failed: errno = %d\n", errno);
+
+ return 0;
+}
+END
+ val="$undef"
+ set try
+ if eval $compile; then
+ xxx=`./try`
+ case "$xxx" in
+ semid_ds) val="$define" ;;
+ esac
+ fi
+ $rm -f try try.c
+ set d_semctl_semid_ds
+ eval $setvar
+ case "$d_semctl_semid_ds" in
+ $define)
+ echo "You can $also use struct semid_ds * for semctl IPC_STAT." >&4
+ ;;
+ *) echo "You cannot use struct semid_ds * for semctl IPC_STAT." >&4
+ ;;
+ esac
+ ;;
+*) val="$undef"
+
+ # We do not have the full sem*(2) library, so assume we can not
+ # use either.
+
+ set d_semctl_semun
+ eval $setvar
+
+ set d_semctl_semid_ds
+ eval $setvar
+ ;;
+esac
+
+: see if setegid exists
+set setegid d_setegid
+eval $inlibc
+
+: see if seteuid exists
+set seteuid d_seteuid
+eval $inlibc
+
+: see if sethostent exists
+set sethostent d_sethent
+eval $inlibc
+
+: see if setlinebuf exists
+set setlinebuf d_setlinebuf
+eval $inlibc
+
+: see if setlocale exists
+set setlocale d_setlocale
+eval $inlibc
+
+: see if setnetent exists
+set setnetent d_setnent
+eval $inlibc
+
+: see if setprotoent exists
+set setprotoent d_setpent
+eval $inlibc
+
+: see if setpgid exists
+set setpgid d_setpgid
+eval $inlibc
+
+: see if setpgrp2 exists
+set setpgrp2 d_setpgrp2
+eval $inlibc
+
+: see if setpriority exists
+set setpriority d_setprior
+eval $inlibc
+
+: see if setregid exists
+set setregid d_setregid
+eval $inlibc
+set setresgid d_setresgid
+eval $inlibc
+
+: see if setreuid exists
+set setreuid d_setreuid
+eval $inlibc
+set setresuid d_setresuid
+eval $inlibc
+
+: see if setrgid exists
+set setrgid d_setrgid
+eval $inlibc
+
+: see if setruid exists
+set setruid d_setruid
+eval $inlibc
+
+: see if setservent exists
+set setservent d_setsent
+eval $inlibc
+
+: see if setsid exists
+set setsid d_setsid
+eval $inlibc
+
+: see if setvbuf exists
+set setvbuf d_setvbuf
+eval $inlibc
+
+: see if sfio.h is available
+set sfio.h i_sfio
+eval $inhdr
+
+
+: see if sfio library is available
+case "$i_sfio" in
+$define)
+ val=''
+ set sfreserve val
+ eval $inlibc
+ ;;
+*)
+ val="$undef"
+ ;;
+esac
+: Ok, but do we want to use it.
+case "$val" in
+$define)
+ case "$usesfio" in
+ true|$define|[yY]*) dflt='y';;
+ *) dflt='n';;
+ esac
+ echo "$package can use the sfio library, but it is experimental."
+ rp="You seem to have sfio available, do you want to try using it?"
+ . ./myread
+ case "$ans" in
+ y|Y) ;;
+ *) echo "Ok, avoiding sfio this time. I'll use stdio instead."
+ val="$undef"
+ : Remove sfio from list of libraries to use
+ set `echo X $libs | $sed -e 's/-lsfio / /' -e 's/-lsfio$//'`
+ shift
+ libs="$*"
+ echo "libs = $libs" >&4
+ ;;
+ esac
+ ;;
+*) case "$usesfio" in
+ true|$define|[yY]*)
+ echo "Sorry, cannot find sfio on this machine" >&4
+ echo "Ignoring your setting of usesfio=$usesfio" >&4
+ ;;
+ esac
+ ;;
+esac
+set d_sfio
+eval $setvar
+case "$d_sfio" in
+$define) usesfio='true';;
+*) usesfio='false';;
+esac
+
+: see if shmctl exists
+set shmctl d_shmctl
+eval $inlibc
+
+: see if shmget exists
+set shmget d_shmget
+eval $inlibc
+
+: see if shmat exists
+set shmat d_shmat
+eval $inlibc
+: see what shmat returns
+case "$d_shmat" in
+"$define")
+ $cat >shmat.c <<'END'
+#include <sys/shm.h>
+void *shmat();
+END
+ if $cc $ccflags -c shmat.c >/dev/null 2>&1; then
+ shmattype='void *'
+ else
+ shmattype='char *'
+ fi
+ echo "and it returns ($shmattype)." >&4
+ : see if a prototype for shmat is available
+ xxx=`./findhdr sys/shm.h`
+ $cppstdin $cppflags $cppminus < $xxx > shmat.c 2>/dev/null
+ if $contains 'shmat.*(' shmat.c >/dev/null 2>&1; then
+ val="$define"
+ else
+ val="$undef"
+ fi
+ $rm -f shmat.[co]
+ ;;
+*)
+ val="$undef"
+ ;;
+esac
+set d_shmatprototype
+eval $setvar
+
+: see if shmdt exists
+set shmdt d_shmdt
+eval $inlibc
+
+: see how much of the 'shm*(2)' library is present.
+h_shm=true
+echo " "
+case "$d_shmctl$d_shmget$d_shmat$d_shmdt" in
+*"$undef"*) h_shm=false;;
+esac
+case "$osname" in
+freebsd)
+ case "`ipcs 2>&1`" in
+ "SVID shared memory"*"not configured"*)
+ echo "But your FreeBSD kernel does not have the shm*(2) configured." >&4
+ h_shm=false
+ val="$undef"
+ set shmctl d_shmctl
+ evat $setvar
+ set shmget d_shmget
+ evat $setvar
+ set shmat d_shmat
+ evat $setvar
+ set shmdt d_shmdt
+ evat $setvar
+ ;;
+ esac
+ ;;
+esac
+: we could also check for sys/ipc.h ...
+if $h_shm && $test `./findhdr sys/shm.h`; then
+ echo "You have the full shm*(2) library." >&4
+ val="$define"
+else
+ echo "You don't have the full shm*(2) library." >&4
+ val="$undef"
+fi
+set d_shm
+eval $setvar
+
+echo " "
+: see if we have sigaction
+if set sigaction val -f d_sigaction; eval $csym; $val; then
+ echo 'sigaction() found.' >&4
+ $cat > try.c <<'EOP'
+#include <stdio.h>
+#include <sys/types.h>
+#include <signal.h>
+main()
+{
+ struct sigaction act, oact;
+}
+EOP
+ set try
+ if eval $compile_ok; then
+ val="$define"
+ else
+ echo "But you don't seem to have a useable struct sigaction." >&4
+ val="$undef"
+ fi
+else
+ echo 'sigaction NOT found.' >&4
+ val="$undef"
+fi
+set d_sigaction; eval $setvar
+$rm -f try try$_o try.c
+
+: see if sigsetjmp exists
+echo " "
+case "$d_sigsetjmp" in
+'')
+ $cat >try.c <<'EOP'
+#include <setjmp.h>
+sigjmp_buf env;
+int set = 1;
+main()
+{
+ if (sigsetjmp(env,1))
+ exit(set);
+ set = 0;
+ siglongjmp(env, 1);
+ exit(1);
+}
+EOP
+ set try
+ if eval $compile; then
+ if ./try >/dev/null 2>&1; then
+ echo "POSIX sigsetjmp found." >&4
+ val="$define"
+ else
+ $cat >&4 <<EOM
+Uh-Oh! You have POSIX sigsetjmp and siglongjmp, but they do not work properly!!
+I'll ignore them.
+EOM
+ val="$undef"
+ fi
+ else
+ echo "sigsetjmp not found." >&4
+ val="$undef"
+ fi
+ ;;
+*) val="$d_sigsetjmp"
+ case "$d_sigsetjmp" in
+ $define) echo "POSIX sigsetjmp found." >&4;;
+ $undef) echo "sigsetjmp not found." >&4;;
+ esac
+ ;;
+esac
+set d_sigsetjmp
+eval $setvar
+$rm -f try.c try
+
+socketlib=''
+sockethdr=''
+: see whether socket exists
+echo " "
+$echo $n "Hmm... $c" >&4
+if set socket val -f d_socket; eval $csym; $val; then
+ echo "Looks like you have Berkeley networking support." >&4
+ d_socket="$define"
+ if set setsockopt val -f; eval $csym; $val; then
+ d_oldsock="$undef"
+ else
+ echo "...but it uses the old 4.1c interface, rather than 4.2" >&4
+ d_oldsock="$define"
+ fi
+else
+ if $contains socklib libc.list >/dev/null 2>&1; then
+ echo "Looks like you have Berkeley networking support." >&4
+ d_socket="$define"
+ : we will have to assume that it supports the 4.2 BSD interface
+ d_oldsock="$undef"
+ else
+ echo "You don't have Berkeley networking in libc$_a..." >&4
+ if test -f /usr/lib/libnet$_a; then
+ ( ($nm $nm_opt /usr/lib/libnet$_a | eval $nm_extract) || \
+ $ar t /usr/lib/libnet$_a) 2>/dev/null >> libc.list
+ if $contains socket libc.list >/dev/null 2>&1; then
+ echo "...but the Wollongong group seems to have hacked it in." >&4
+ socketlib="-lnet"
+ sockethdr="-I/usr/netinclude"
+ d_socket="$define"
+ if $contains setsockopt libc.list >/dev/null 2>&1; then
+ d_oldsock="$undef"
+ else
+ echo "...using the old 4.1c interface, rather than 4.2" >&4
+ d_oldsock="$define"
+ fi
+ else
+ echo "or even in libnet$_a, which is peculiar." >&4
+ d_socket="$undef"
+ d_oldsock="$undef"
+ fi
+ else
+ echo "or anywhere else I see." >&4
+ d_socket="$undef"
+ d_oldsock="$undef"
+ fi
+ fi
+fi
+
+: see if socketpair exists
+set socketpair d_sockpair
+eval $inlibc
+
+: see if stat knows about block sizes
+echo " "
+xxx=`./findhdr sys/stat.h`
+if $contains 'st_blocks;' "$xxx" >/dev/null 2>&1 ; then
+ if $contains 'st_blksize;' "$xxx" >/dev/null 2>&1 ; then
+ echo "Your stat() knows about block sizes." >&4
+ val="$define"
+ else
+ echo "Your stat() doesn't know about block sizes." >&4
+ val="$undef"
+ fi
+else
+ echo "Your stat() doesn't know about block sizes." >&4
+ val="$undef"
+fi
+set d_statblks
+eval $setvar
+
+: see if _ptr and _cnt from stdio act std
+echo " "
+if $contains '_IO_fpos_t' `./findhdr stdio.h` >/dev/null 2>&1 ; then
+ echo "(Looks like you have stdio.h from Linux.)"
+ case "$stdio_ptr" in
+ '') stdio_ptr='((fp)->_IO_read_ptr)'
+ ptr_lval=$define
+ ;;
+ *) ptr_lval=$d_stdio_ptr_lval;;
+ esac
+ case "$stdio_cnt" in
+ '') stdio_cnt='((fp)->_IO_read_end - (fp)->_IO_read_ptr)'
+ cnt_lval=$undef
+ ;;
+ *) cnt_lval=$d_stdio_cnt_lval;;
+ esac
+ case "$stdio_base" in
+ '') stdio_base='((fp)->_IO_read_base)';;
+ esac
+ case "$stdio_bufsiz" in
+ '') stdio_bufsiz='((fp)->_IO_read_end - (fp)->_IO_read_base)';;
+ esac
+else
+ case "$stdio_ptr" in
+ '') stdio_ptr='((fp)->_ptr)'
+ ptr_lval=$define
+ ;;
+ *) ptr_lval=$d_stdio_ptr_lval;;
+ esac
+ case "$stdio_cnt" in
+ '') stdio_cnt='((fp)->_cnt)'
+ cnt_lval=$define
+ ;;
+ *) cnt_lval=$d_stdio_cnt_lval;;
+ esac
+ case "$stdio_base" in
+ '') stdio_base='((fp)->_base)';;
+ esac
+ case "$stdio_bufsiz" in
+ '') stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)';;
+ esac
+fi
+: test whether _ptr and _cnt really work
+echo "Checking how std your stdio is..." >&4
+$cat >try.c <<EOP
+#include <stdio.h>
+#define FILE_ptr(fp) $stdio_ptr
+#define FILE_cnt(fp) $stdio_cnt
+main() {
+ FILE *fp = fopen("try.c", "r");
+ char c = getc(fp);
+ if (
+ 18 <= FILE_cnt(fp) &&
+ strncmp(FILE_ptr(fp), "include <stdio.h>\n", 18) == 0
+ )
+ exit(0);
+ exit(1);
+}
+EOP
+val="$undef"
+set try
+if eval $compile; then
+ if ./try; then
+ echo "Your stdio acts pretty std."
+ val="$define"
+ else
+ echo "Your stdio isn't very std."
+ fi
+else
+ echo "Your stdio doesn't appear very std."
+fi
+$rm -f try.c try
+set d_stdstdio
+eval $setvar
+
+: Can _ptr be used as an lvalue?
+case "$d_stdstdio$ptr_lval" in
+$define$define) val=$define ;;
+*) val=$undef ;;
+esac
+set d_stdio_ptr_lval
+eval $setvar
+
+: Can _cnt be used as an lvalue?
+case "$d_stdstdio$cnt_lval" in
+$define$define) val=$define ;;
+*) val=$undef ;;
+esac
+set d_stdio_cnt_lval
+eval $setvar
+
+: see if _base is also standard
+val="$undef"
+case "$d_stdstdio" in
+$define)
+ $cat >try.c <<EOP
+#include <stdio.h>
+#define FILE_base(fp) $stdio_base
+#define FILE_bufsiz(fp) $stdio_bufsiz
+main() {
+ FILE *fp = fopen("try.c", "r");
+ char c = getc(fp);
+ if (
+ 19 <= FILE_bufsiz(fp) &&
+ strncmp(FILE_base(fp), "#include <stdio.h>\n", 19) == 0
+ )
+ exit(0);
+ exit(1);
+}
+EOP
+ set try
+ if eval $compile; then
+ if ./try; then
+ echo "And its _base field acts std."
+ val="$define"
+ else
+ echo "But its _base field isn't std."
+ fi
+ else
+ echo "However, it seems to be lacking the _base field."
+ fi
+ $rm -f try.c try
+ ;;
+esac
+set d_stdiobase
+eval $setvar
+
+: see if strcoll exists
+set strcoll d_strcoll
+eval $inlibc
+
+: check for structure copying
+echo " "
+echo "Checking to see if your C compiler can copy structs..." >&4
+$cat >try.c <<'EOCP'
+main()
+{
+ struct blurfl {
+ int dyick;
+ } foo, bar;
+
+ foo = bar;
+}
+EOCP
+if $cc -c try.c >/dev/null 2>&1 ; then
+ val="$define"
+ echo "Yup, it can."
+else
+ val="$undef"
+ echo "Nope, it can't."
+fi
+set d_strctcpy
+eval $setvar
+$rm -f try.*
+
+: see if strerror and/or sys_errlist[] exist
+echo " "
+if test "X$d_strerror" = X -o "X$d_syserrlst" = X; then
+ if set strerror val -f d_strerror; eval $csym; $val; then
+ echo 'strerror() found.' >&4
+ d_strerror="$define"
+ d_strerrm='strerror(e)'
+ if set sys_errlist val -a d_syserrlst; eval $csym; $val; then
+ echo "(You also have sys_errlist[], so we could roll our own strerror.)"
+ d_syserrlst="$define"
+ else
+ echo "(Since you don't have sys_errlist[], sterror() is welcome.)"
+ d_syserrlst="$undef"
+ fi
+ elif xxx=`./findhdr string.h`; test "$xxx" || xxx=`./findhdr strings.h`; \
+ $contains '#[ ]*define.*strerror' "$xxx" >/dev/null 2>&1; then
+ echo 'strerror() found in string header.' >&4
+ d_strerror="$define"
+ d_strerrm='strerror(e)'
+ if set sys_errlist val -a d_syserrlst; eval $csym; $val; then
+ echo "(Most probably, strerror() uses sys_errlist[] for descriptions.)"
+ d_syserrlst="$define"
+ else
+ echo "(You don't appear to have any sys_errlist[], how can this be?)"
+ d_syserrlst="$undef"
+ fi
+ elif set sys_errlist val -a d_syserrlst; eval $csym; $val; then
+echo "strerror() not found, but you have sys_errlist[] so we'll use that." >&4
+ d_strerror="$undef"
+ d_syserrlst="$define"
+ d_strerrm='((e)<0||(e)>=sys_nerr?"unknown":sys_errlist[e])'
+ else
+ echo 'strerror() and sys_errlist[] NOT found.' >&4
+ d_strerror="$undef"
+ d_syserrlst="$undef"
+ d_strerrm='"unknown"'
+ fi
+fi
+
+: see if strtod exists
+set strtod d_strtod
+eval $inlibc
+
+: see if strtol exists
+set strtol d_strtol
+eval $inlibc
+
+: see if strtoul exists
+set strtoul d_strtoul
+eval $inlibc
+
+: see if strxfrm exists
+set strxfrm d_strxfrm
+eval $inlibc
+
+: see if symlink exists
+set symlink d_symlink
+eval $inlibc
+
+: see if syscall exists
+set syscall d_syscall
+eval $inlibc
+
+: see if sysconf exists
+set sysconf d_sysconf
+eval $inlibc
+
+: see if system exists
+set system d_system
+eval $inlibc
+
+: see if tcgetpgrp exists
+set tcgetpgrp d_tcgetpgrp
+eval $inlibc
+
+: see if tcsetpgrp exists
+set tcsetpgrp d_tcsetpgrp
+eval $inlibc
+
+: define an is-a-typedef? function
+typedef='type=$1; var=$2; def=$3; shift; shift; shift; inclist=$@;
+case "$inclist" in
+"") inclist="sys/types.h";;
+esac;
+eval "varval=\$$var";
+case "$varval" in
+"")
+ $rm -f temp.c;
+ for inc in $inclist; do
+ echo "#include <$inc>" >>temp.c;
+ done;
+ echo "#ifdef $type" >> temp.c;
+ echo "printf(\"We have $type\");" >> temp.c;
+ echo "#endif" >> temp.c;
+ $cppstdin $cppflags $cppminus < temp.c >temp.E 2>/dev/null;
+ if $contains $type temp.E >/dev/null 2>&1; then
+ eval "$var=\$type";
+ else
+ eval "$var=\$def";
+ fi;
+ $rm -f temp.?;;
+*) eval "$var=\$varval";;
+esac'
+
+: define an is-a-typedef? function that prompts if the type is not available.
+typedef_ask='type=$1; var=$2; def=$3; shift; shift; shift; inclist=$@;
+case "$inclist" in
+"") inclist="sys/types.h";;
+esac;
+eval "varval=\$$var";
+case "$varval" in
+"")
+ $rm -f temp.c;
+ for inc in $inclist; do
+ echo "#include <$inc>" >>temp.c;
+ done;
+ echo "#ifdef $type" >> temp.c;
+ echo "printf(\"We have $type\");" >> temp.c;
+ echo "#endif" >> temp.c;
+ $cppstdin $cppflags $cppminus < temp.c >temp.E 2>/dev/null;
+ echo " " ;
+ echo "$rp" | $sed -e "s/What is/Looking for/" -e "s/?/./";
+ if $contains $type temp.E >/dev/null 2>&1; then
+ echo "$type found." >&4;
+ eval "$var=\$type";
+ else
+ echo "$type NOT found." >&4;
+ dflt="$def";
+ . ./myread ;
+ eval "$var=\$ans";
+ fi;
+ $rm -f temp.?;;
+*) eval "$var=\$varval";;
+esac'
+
+: see if this is a sys/times.h system
+set sys/times.h i_systimes
+eval $inhdr
+
+: see if times exists
+echo " "
+if set times val -f d_times; eval $csym; $val; then
+ echo 'times() found.' >&4
+ d_times="$define"
+ inc=''
+ case "$i_systimes" in
+ "$define") inc='sys/times.h';;
+ esac
+ rp="What is the type returned by times() on this system?"
+ set clock_t clocktype long stdio.h sys/types.h $inc
+ eval $typedef_ask
+else
+ echo 'times() NOT found, hope that will do.' >&4
+ d_times="$undef"
+ clocktype='int'
+fi
+
+: see if truncate exists
+set truncate d_truncate
+eval $inlibc
+
+: see if tzname[] exists
+echo " "
+if set tzname val -a d_tzname; eval $csym; $val; then
+ val="$define"
+ echo 'tzname[] found.' >&4
+else
+ val="$undef"
+ echo 'tzname[] NOT found.' >&4
+fi
+set d_tzname
+eval $setvar
+
+: see if umask exists
+set umask d_umask
+eval $inlibc
+
+: see how we will look up host name
+echo " "
+if false; then
+ : dummy stub to allow use of elif
+elif set uname val -f d_uname; eval $csym; $val; then
+ if ./xenix; then
+ $cat <<'EOM'
+uname() was found, but you're running xenix, and older versions of xenix
+have a broken uname(). If you don't really know whether your xenix is old
+enough to have a broken system call, use the default answer.
+
+EOM
+ dflt=y
+ case "$d_uname" in
+ "$define") dflt=n;;
+ esac
+ rp='Is your uname() broken?'
+ . ./myread
+ case "$ans" in
+ n*) d_uname="$define"; call=uname;;
+ esac
+ else
+ echo 'uname() found.' >&4
+ d_uname="$define"
+ call=uname
+ fi
+fi
+case "$d_gethname" in
+'') d_gethname="$undef";;
+esac
+case "$d_uname" in
+'') d_uname="$undef";;
+esac
+case "$d_phostname" in
+'') d_phostname="$undef";;
+esac
+
+: backward compatibility for d_hvfork
+if test X$d_hvfork != X; then
+ d_vfork="$d_hvfork"
+ d_hvfork=''
+fi
+: see if there is a vfork
+val=''
+set vfork val
+eval $inlibc
+
+: Ok, but do we want to use it. vfork is reportedly unreliable in
+: perl on Solaris 2.x, and probably elsewhere.
+case "$val" in
+$define)
+ echo " "
+ case "$usevfork" in
+ false) dflt='n';;
+ *) dflt='y';;
+ esac
+ rp="Some systems have problems with vfork(). Do you want to use it?"
+ . ./myread
+ case "$ans" in
+ y|Y) ;;
+ *)
+ echo "Ok, we won't use vfork()."
+ val="$undef"
+ ;;
+ esac
+ ;;
+esac
+set d_vfork
+eval $setvar
+case "$d_vfork" in
+$define) usevfork='true';;
+*) usevfork='false';;
+esac
+
+: see if this is an sysdir system
+set sys/dir.h i_sysdir
+eval $inhdr
+
+: see if this is an sysndir system
+set sys/ndir.h i_sysndir
+eval $inhdr
+
+: see if sys/types.h has to be included
+set sys/types.h i_systypes
+eval $inhdr
+
+: see if closedir exists
+set closedir d_closedir
+eval $inlibc
+
+case "$d_closedir" in
+"$define")
+ echo " "
+ echo "Checking whether closedir() returns a status..." >&4
+ cat > closedir.c <<EOM
+#$i_dirent I_DIRENT /**/
+#$i_sysdir I_SYS_DIR /**/
+#$i_sysndir I_SYS_NDIR /**/
+#$i_systypes I_SYS_TYPES /**/
+
+#if defined(I_SYS_TYPES)
+#include <sys/types.h>
+#endif
+#if defined(I_DIRENT)
+#include <dirent.h>
+#if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */
+#include <sys/dir.h>
+#endif
+#else
+#ifdef I_SYS_NDIR
+#include <sys/ndir.h>
+#else
+#ifdef I_SYS_DIR
+#ifdef hp9000s500
+#include <ndir.h> /* may be wrong in the future */
+#else
+#include <sys/dir.h>
+#endif
+#endif
+#endif
+#endif
+int main() { return closedir(opendir(".")); }
+EOM
+ set closedir
+ if eval $compile_ok; then
+ if ./closedir > /dev/null 2>&1 ; then
+ echo "Yes, it does."
+ val="$undef"
+ else
+ echo "No, it doesn't."
+ val="$define"
+ fi
+ else
+ echo "(I can't seem to compile the test program--assuming it doesn't)"
+ val="$define"
+ fi
+ ;;
+*)
+ val="$undef";
+ ;;
+esac
+set d_void_closedir
+eval $setvar
+$rm -f closedir*
+: check for volatile keyword
+echo " "
+echo 'Checking to see if your C compiler knows about "volatile"...' >&4
+$cat >try.c <<'EOCP'
+main()
+{
+ typedef struct _goo_struct goo_struct;
+ goo_struct * volatile goo = ((goo_struct *)0);
+ struct _goo_struct {
+ long long_int;
+ int reg_int;
+ char char_var;
+ };
+ typedef unsigned short foo_t;
+ char *volatile foo;
+ volatile int bar;
+ volatile foo_t blech;
+ foo = foo;
+}
+EOCP
+if $cc -c $ccflags try.c >/dev/null 2>&1 ; then
+ val="$define"
+ echo "Yup, it does."
+else
+ val="$undef"
+ echo "Nope, it doesn't."
+fi
+set d_volatile
+eval $setvar
+$rm -f try.*
+
+: see if there is a wait4
+set wait4 d_wait4
+eval $inlibc
+
+: see if waitpid exists
+set waitpid d_waitpid
+eval $inlibc
+
+: see if wcstombs exists
+set wcstombs d_wcstombs
+eval $inlibc
+
+: see if wctomb exists
+set wctomb d_wctomb
+eval $inlibc
+
+: preserve RCS keywords in files with variable substitution, grrr
+Date='$Date'
+Id='$Id'
+Log='$Log'
+RCSfile='$RCSfile'
+Revision='$Revision'
+
+: check for alignment requirements
+echo " "
+case "$alignbytes" in
+'') echo "Checking alignment constraints..." >&4
+ $cat >try.c <<'EOCP'
+struct foobar {
+ char foo;
+ double bar;
+} try;
+main()
+{
+ printf("%d\n", (char *)&try.bar - (char *)&try.foo);
+}
+EOCP
+ set try
+ if eval $compile_ok; then
+ dflt=`./try`
+ else
+ dflt='8'
+ echo "(I can't seem to compile the test program...)"
+ fi
+ ;;
+*) dflt="$alignbytes"
+ ;;
+esac
+rp="Doubles must be aligned on a how-many-byte boundary?"
+. ./myread
+alignbytes="$ans"
+$rm -f try.c try
+
+: check for ordering of bytes in a long
+case "$byteorder" in
+'')
+ $cat <<'EOM'
+
+In the following, larger digits indicate more significance. A big-endian
+machine like a Pyramid or a Motorola 680?0 chip will come out to 4321. A
+little-endian machine like a Vax or an Intel 80?86 chip would be 1234. Other
+machines may have weird orders like 3412. A Cray will report 87654321. If
+the test program works the default is probably right.
+I'm now running the test program...
+EOM
+ $cat >try.c <<'EOCP'
+#include <stdio.h>
+main()
+{
+ int i;
+ union {
+ unsigned long l;
+ char c[sizeof(long)];
+ } u;
+
+ if (sizeof(long) > 4)
+ u.l = (0x08070605L << 32) | 0x04030201L;
+ else
+ u.l = 0x04030201L;
+ for (i = 0; i < sizeof(long); i++)
+ printf("%c", u.c[i]+'0');
+ printf("\n");
+ exit(0);
+}
+EOCP
+ xxx_prompt=y
+ set try
+ if eval $compile && ./try > /dev/null; then
+ dflt=`./try`
+ case "$dflt" in
+ [1-4][1-4][1-4][1-4]|12345678|87654321)
+ echo "(The test program ran ok.)"
+ echo "byteorder=$dflt"
+ xxx_prompt=n
+ ;;
+ ????|????????) echo "(The test program ran ok.)" ;;
+ *) echo "(The test program didn't run right for some reason.)" ;;
+ esac
+ else
+ dflt='4321'
+ cat <<'EOM'
+(I can't seem to compile the test program. Guessing big-endian...)
+EOM
+ fi
+ case "$xxx_prompt" in
+ y)
+ rp="What is the order of bytes in a long?"
+ . ./myread
+ byteorder="$ans"
+ ;;
+ *) byteorder=$dflt
+ ;;
+ esac
+ ;;
+esac
+$rm -f try.c try
+
+: how do we catenate cpp tokens here?
+echo " "
+echo "Checking to see how your cpp does stuff like catenate tokens..." >&4
+$cat >cpp_stuff.c <<'EOCP'
+#define RCAT(a,b)a/**/b
+#define ACAT(a,b)a ## b
+RCAT(Rei,ser)
+ACAT(Cir,cus)
+EOCP
+$cppstdin $cppflags $cppminus <cpp_stuff.c >cpp_stuff.out 2>&1
+if $contains 'Circus' cpp_stuff.out >/dev/null 2>&1; then
+ echo "Oh! Smells like ANSI's been here." >&4
+ echo "We can catify or stringify, separately or together!"
+ cpp_stuff=42
+elif $contains 'Reiser' cpp_stuff.out >/dev/null 2>&1; then
+ echo "Ah, yes! The good old days!" >&4
+ echo "However, in the good old days we don't know how to stringify and"
+ echo "catify at the same time."
+ cpp_stuff=1
+else
+ $cat >&4 <<EOM
+Hmm, I don't seem to be able to catenate tokens with your cpp. You're going
+to have to edit the values of CAT[2-5] in config.h...
+EOM
+ cpp_stuff="/* Help! How do we handle cpp_stuff? */*/"
+fi
+$rm -f cpp_stuff.*
+
+: see if this is a db.h system
+set db.h i_db
+eval $inhdr
+
+case "$i_db" in
+$define)
+ : Check db version.
+ echo " "
+ echo "Checking Berkeley DB version ..." >&4
+ $cat >try.c <<EOCP
+#$d_const HASCONST
+#ifndef HASCONST
+#define const
+#endif
+#include <sys/types.h>
+#include <stdio.h>
+#include <db.h>
+main()
+{
+#ifdef DB_VERSION_MAJOR /* DB version >= 2 */
+ int Major, Minor, Patch ;
+ unsigned long Version ;
+ (void)db_version(&Major, &Minor, &Patch) ;
+ printf("You have Berkeley DB Version 2 or greater\n");
+
+ printf("db.h is from Berkeley DB Version %d.%d.%d\n",
+ DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH);
+ printf("libdb is from Berkeley DB Version %d.%d.%d\n",
+ Major, Minor, Patch) ;
+
+ /* check that db.h & libdb are compatible */
+ if (DB_VERSION_MAJOR != Major || DB_VERSION_MINOR != Minor || DB_VERSION_PATCH != Patch) {
+ printf("db.h and libdb are incompatible\n") ;
+ exit(3);
+ }
+
+ printf("db.h and libdb are compatible\n") ;
+
+ Version = DB_VERSION_MAJOR * 1000000 + DB_VERSION_MINOR * 1000
+ + DB_VERSION_PATCH ;
+
+ /* needs to be >= 2.3.4 */
+ if (Version < 2003004) {
+ /* if (DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR == 0 && DB_VERSION_PATCH < 5) { */
+ printf("but Perl needs Berkeley DB 2.3.4 or greater\n") ;
+ exit(2);
+ }
+
+ exit(0);
+#else
+#if defined(_DB_H_) && defined(BTREEMAGIC) && defined(HASHMAGIC)
+ printf("You have Berkeley DB Version 1\n");
+ exit(0); /* DB version < 2: the coast is clear. */
+#else
+ exit(1); /* <db.h> not Berkeley DB? */
+#endif
+#endif
+}
+EOCP
+ set try
+ if eval $compile && ./try; then
+ echo 'Looks OK.' >&4
+ else
+ echo "I can't use Berkeley DB with your <db.h>. I'll disable Berkeley DB." >&4
+ i_db=$undef
+ case " $libs " in
+ *"-ldb "*)
+ : Remove db from list of libraries to use
+ echo "Removing unusable -ldb from library list" >&4
+ set `echo X $libs | $sed -e 's/-ldb / /' -e 's/-ldb$//'`
+ shift
+ libs="$*"
+ echo "libs = $libs" >&4
+ ;;
+ esac
+ fi
+ $rm -f try.*
+ ;;
+esac
+
+case "$i_db" in
+define)
+ : Check the return type needed for hash
+ echo " "
+ echo "Checking return type needed for hash for Berkeley DB ..." >&4
+ $cat >try.c <<EOCP
+#$d_const HASCONST
+#ifndef HASCONST
+#define const
+#endif
+#include <sys/types.h>
+#include <db.h>
+
+#ifndef DB_VERSION_MAJOR
+u_int32_t hash_cb (ptr, size)
+const void *ptr;
+size_t size;
+{
+}
+HASHINFO info;
+main()
+{
+ info.hash = hash_cb;
+}
+#endif
+EOCP
+ if $cc $ccflags -c try.c >try.out 2>&1 ; then
+ if $contains warning try.out >>/dev/null 2>&1 ; then
+ db_hashtype='int'
+ else
+ db_hashtype='u_int32_t'
+ fi
+ else
+ : XXX Maybe we should just give up here.
+ db_hashtype=u_int32_t
+ $cat try.out >&4
+ echo "Help: I can't seem to compile the db test program." >&4
+ echo "Something's wrong, but I'll assume you use $db_hashtype." >&4
+ fi
+ $rm -f try.*
+ echo "Your version of Berkeley DB uses $db_hashtype for hash."
+ ;;
+*) db_hashtype=u_int32_t
+ ;;
+esac
+case "$i_db" in
+define)
+ : Check the return type needed for prefix
+ echo " "
+ echo "Checking return type needed for prefix for Berkeley DB ..." >&4
+ cat >try.c <<EOCP
+#$d_const HASCONST
+#ifndef HASCONST
+#define const
+#endif
+#include <sys/types.h>
+#include <db.h>
+
+#ifndef DB_VERSION_MAJOR
+size_t prefix_cb (key1, key2)
+const DBT *key1;
+const DBT *key2;
+{
+}
+BTREEINFO info;
+main()
+{
+ info.prefix = prefix_cb;
+}
+#endif
+EOCP
+ if $cc $ccflags -c try.c >try.out 2>&1 ; then
+ if $contains warning try.out >>/dev/null 2>&1 ; then
+ db_prefixtype='int'
+ else
+ db_prefixtype='size_t'
+ fi
+ else
+ db_prefixtype='size_t'
+ : XXX Maybe we should just give up here.
+ $cat try.out >&4
+ echo "Help: I can't seem to compile the db test program." >&4
+ echo "Something's wrong, but I'll assume you use $db_prefixtype." >&4
+ fi
+ $rm -f try.*
+ echo "Your version of Berkeley DB uses $db_prefixtype for prefix."
+ ;;
+*) db_prefixtype='size_t'
+ ;;
+esac
+
+: check for void type
+echo " "
+echo "Checking to see how well your C compiler groks the void type..." >&4
+case "$voidflags" in
+'')
+ $cat >try.c <<'EOCP'
+#if TRY & 1
+void sub() {
+#else
+sub() {
+#endif
+ extern void moo(); /* function returning void */
+ void (*goo)(); /* ptr to func returning void */
+#if TRY & 8
+ void *hue; /* generic ptr */
+#endif
+#if TRY & 2
+ void (*foo[10])();
+#endif
+
+#if TRY & 4
+ if(goo == moo) {
+ exit(0);
+ }
+#endif
+ exit(0);
+}
+main() { sub(); }
+EOCP
+ if $cc $ccflags -c -DTRY=$defvoidused try.c >.out 2>&1 ; then
+ voidflags=$defvoidused
+ echo "Good. It appears to support void to the level $package wants.">&4
+ if $contains warning .out >/dev/null 2>&1; then
+ echo "However, you might get some warnings that look like this:"
+ $cat .out
+ fi
+ else
+echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4
+ if $cc $ccflags -c -DTRY=1 try.c >/dev/null 2>&1; then
+ echo "It supports 1..."
+ if $cc $ccflags -c -DTRY=3 try.c >/dev/null 2>&1; then
+ echo "It also supports 2..."
+ if $cc $ccflags -c -DTRY=7 try.c >/dev/null 2>&1; then
+ voidflags=7
+ echo "And it supports 4 but not 8 definitely."
+ else
+ echo "It doesn't support 4..."
+ if $cc $ccflags -c -DTRY=11 try.c >/dev/null 2>&1; then
+ voidflags=11
+ echo "But it supports 8."
+ else
+ voidflags=3
+ echo "Neither does it support 8."
+ fi
+ fi
+ else
+ echo "It does not support 2..."
+ if $cc $ccflags -c -DTRY=13 try.c >/dev/null 2>&1; then
+ voidflags=13
+ echo "But it supports 4 and 8."
+ else
+ if $cc $ccflags -c -DTRY=5 try.c >/dev/null 2>&1; then
+ voidflags=5
+ echo "And it supports 4 but has not heard about 8."
+ else
+ echo "However it supports 8 but not 4."
+ fi
+ fi
+ fi
+ else
+ echo "There is no support at all for void."
+ voidflags=0
+ fi
+ fi
+esac
+case "$voidflags" in
+"$defvoidused") ;;
+*) $cat >&4 <<'EOM'
+ Support flag bits are:
+ 1: basic void declarations.
+ 2: arrays of pointers to functions returning void.
+ 4: operations between pointers to and addresses of void functions.
+ 8: generic void pointers.
+EOM
+ dflt="$voidflags";
+ rp="Your void support flags add up to what?"
+ . ./myread
+ voidflags="$ans"
+ ;;
+esac
+$rm -f try.* .out
+
+: check for length of double
+echo " "
+case "$doublesize" in
+'')
+ $echo $n "Checking to see how big your double precision numbers are...$c" >&4
+ $cat >try.c <<'EOCP'
+#include <stdio.h>
+main()
+{
+ printf("%d\n", sizeof(double));
+}
+EOCP
+ set try
+ if eval $compile_ok; then
+ doublesize=`./try`
+ $echo " $doublesize bytes." >&4
+ else
+ dflt='8'
+ echo "(I can't seem to compile the test program. Guessing...)"
+ rp="What is the size of a double precision number (in bytes)?"
+ . ./myread
+ doublesize="$ans"
+ fi
+ ;;
+esac
+$rm -f try.c try
+
+: see what type file positions are declared as in the library
+rp="What is the type for file position used by fsetpos()?"
+set fpos_t fpostype long stdio.h sys/types.h
+eval $typedef_ask
+
+: get csh whereabouts
+case "$csh" in
+'csh') val="$undef" ;;
+*) val="$define" ;;
+esac
+set d_csh
+eval $setvar
+: Respect a hint or command line value for full_csh.
+case "$full_csh" in
+'') full_csh=$csh ;;
+esac
+
+: Store the full pathname to the sed program for use in the C program
+full_sed=$sed
+
+: see what type gids are declared as in the kernel
+echo " "
+echo "Looking for the type for group ids returned by getgid()."
+set gid_t gidtype xxx stdio.h sys/types.h
+eval $typedef
+case "$gidtype" in
+xxx)
+ xxx=`./findhdr sys/user.h`
+ set `grep 'groups\[NGROUPS\];' "$xxx" 2>/dev/null` unsigned short
+ case $1 in
+ unsigned) dflt="$1 $2" ;;
+ *) dflt="$1" ;;
+ esac
+ ;;
+*) dflt="$gidtype";;
+esac
+case "$gidtype" in
+gid_t) echo "gid_t found." ;;
+*) rp="What is the type for group ids returned by getgid()?"
+ . ./myread
+ gidtype="$ans"
+ ;;
+esac
+
+: see if getgroups exists
+set getgroups d_getgrps
+eval $inlibc
+
+: see if setgroups exists
+set setgroups d_setgrps
+eval $inlibc
+
+
+: Find type of 2nd arg to 'getgroups()' and 'setgroups()'
+echo " "
+case "$d_getgrps$d_setgrps" in
+*define*)
+ case "$groupstype" in
+ '') dflt="$gidtype" ;;
+ *) dflt="$groupstype" ;;
+ esac
+ $cat <<EOM
+What type of pointer is the second argument to getgroups() and setgroups()?
+Usually this is the same as group ids, $gidtype, but not always.
+
+EOM
+ rp='What type pointer is the second argument to getgroups() and setgroups()?'
+ . ./myread
+ groupstype="$ans"
+ ;;
+*) groupstype="$gidtype";;
+esac
+
+: see what type lseek is declared as in the kernel
+rp="What is the type used for lseek's offset on this system?"
+set off_t lseektype long stdio.h sys/types.h
+eval $typedef_ask
+
+echo " "
+echo "Checking if your $make program sets \$(MAKE)..." >&4
+case "$make_set_make" in
+'')
+ $sed 's/^X //' > testmake.mak << 'EOF'
+Xall:
+X @echo 'maketemp="$(MAKE)"'
+EOF
+ case "`$make -f testmake.mak 2>/dev/null`" in
+ *maketemp=*) make_set_make='#' ;;
+ *) make_set_make="MAKE=$make" ;;
+ esac
+ $rm -f testmake.mak
+ ;;
+esac
+case "$make_set_make" in
+'#') echo "Yup, it does.";;
+*) echo "Nope, it doesn't.";;
+esac
+
+: see what type is used for mode_t
+rp="What is the type used for file modes for system calls (e.g. fchmod())?"
+set mode_t modetype int stdio.h sys/types.h
+eval $typedef_ask
+
+: define a fucntion to check prototypes
+$cat > protochk <<EOSH
+$startsh
+cc="$cc"
+optimize="$optimize"
+ccflags="$ccflags"
+prototype="$prototype"
+define="$define"
+rm=$rm
+EOSH
+
+$cat >> protochk <<'EOSH'
+
+$rm -f try.c
+foo="$1"
+shift
+while test $# -ge 2; do
+ case "$1" in
+ $define) echo "#include <$2>" >> try.c ;;
+ literal) echo "$2" >> try.c ;;
+ esac
+ shift 2
+done
+test "$prototype" = "$define" && echo '#define CAN_PROTOTYPE' >> try.c
+cat >> try.c <<'EOCP'
+#ifdef CAN_PROTOTYPE
+#define _(args) args
+#else
+#define _(args) ()
+#endif
+EOCP
+echo "$foo" >> try.c
+echo 'int no_real_function_has_this_name _((void)) { return 0; }' >> try.c
+$cc $optimize $ccflags -c try.c > /dev/null 2>&1
+status=$?
+$rm -f try.[co]
+exit $status
+EOSH
+chmod +x protochk
+$eunicefix protochk
+
+: see what type is used for size_t
+rp="What is the type used for the length parameter for string functions?"
+set size_t sizetype 'unsigned int' stdio.h sys/types.h
+eval $typedef_ask
+
+: check for type of arguments to gethostbyaddr.
+if test "X$netdb_host_type" = X -o "X$netdb_hlen_type" = X; then
+ case "$d_gethbyaddr" in
+ $define)
+ $cat <<EOM
+
+Checking to see what type of arguments are accepted by gethostbyaddr().
+EOM
+ hdrs="$define sys/types.h
+ $d_socket sys/socket.h
+ $i_niin netinet/in.h
+ $i_netdb netdb.h
+ $i_unistd unistd.h"
+ : The first arg can 'char *' or 'void *'
+ : The second arg is some of integral type
+ for xxx in in_addr_t 'const void *' 'const char *' 'void *' 'char *'; do
+ for yyy in size_t long int; do
+ case "$netdb_host_type" in
+ '') try="extern struct hostent *gethostbyaddr($xxx, $yyy, int);"
+ if ./protochk "$try" $hdrs; then
+ echo "Your system accepts $xxx for the first arg."
+ echo "...and $yyy for the second arg."
+ netdb_host_type="$xxx"
+ netdb_hlen_type="$yyy"
+ fi
+ ;;
+ esac
+ done
+ done
+ : In case none of those worked, prompt the user.
+ case "$netdb_host_type" in
+ '') rp='What is the type for the 1st argument to gethostbyaddr?'
+ dflt='char *'
+ . ./myread
+ netdb_host_type=$ans
+ rp='What is the type for the 2nd argument to gethostbyaddr?'
+ dflt="$sizetype"
+ . ./myread
+ netdb_hlen_type=$ans
+ ;;
+ esac
+ ;;
+ *) : no gethostbyaddr, so pick harmless defaults
+ netdb_host_type='char *'
+ netdb_hlen_type="$sizetype"
+ ;;
+ esac
+ # Remove the "const" if needed. -- but then we'll have a
+ # prototype clash!
+ # netdb_host_type=`echo "$netdb_host_type" | sed 's/^const //'`
+fi
+
+: check for type of argument to gethostbyname.
+if test "X$netdb_name_type" = X ; then
+ case "$d_gethbyname" in
+ $define)
+ $cat <<EOM
+
+Checking to see what type of argument is accepted by gethostbyname().
+EOM
+ hdrs="$define sys/types.h
+ $d_socket sys/socket.h
+ $i_niin netinet/in.h
+ $i_netdb netdb.h
+ $i_unistd unistd.h"
+ for xxx in "const char *" "char *"; do
+ case "$netdb_name_type" in
+ '') try="extern struct hostent *gethostbyname($xxx);"
+ if ./protochk "$try" $hdrs; then
+ echo "Your system accepts $xxx."
+ netdb_name_type="$xxx"
+ fi
+ ;;
+ esac
+ done
+ : In case none of those worked, prompt the user.
+ case "$netdb_name_type" in
+ '') rp='What is the type for the 1st argument to gethostbyname?'
+ dflt='char *'
+ . ./myread
+ netdb_name_type=$ans
+ ;;
+ esac
+ ;;
+ *) : no gethostbyname, so pick harmless default
+ netdb_name_type='char *'
+ ;;
+ esac
+fi
+
+: check for type of 1st argument to getnetbyaddr.
+if test "X$netdb_net_type" = X ; then
+ case "$d_getnbyaddr" in
+ $define)
+ $cat <<EOM
+
+Checking to see what type of 1st argument is accepted by getnetbyaddr().
+EOM
+ hdrs="$define sys/types.h
+ $d_socket sys/socket.h
+ $i_niin netinet/in.h
+ $i_netdb netdb.h
+ $i_unistd unistd.h"
+ for xxx in in_addr_t "unsigned long" long "unsigned int" int; do
+ case "$netdb_net_type" in
+ '') try="extern struct netent *getnetbyaddr($xxx, int);"
+ if ./protochk "$try" $hdrs; then
+ echo "Your system accepts $xxx."
+ netdb_net_type="$xxx"
+ fi
+ ;;
+ esac
+ done
+ : In case none of those worked, prompt the user.
+ case "$netdb_net_type" in
+ '') rp='What is the type for the 1st argument to getnetbyaddr?'
+ dflt='long'
+ . ./myread
+ netdb_net_type=$ans
+ ;;
+ esac
+ ;;
+ *) : no getnetbyaddr, so pick harmless default
+ netdb_net_type='long'
+ ;;
+ esac
+fi
+: locate the preferred pager for this system
+case "$pager" in
+'')
+ dflt=''
+ case "$pg" in
+ /*) dflt=$pg;;
+ esac
+ case "$more" in
+ /*) dflt=$more;;
+ esac
+ case "$less" in
+ /*) dflt=$less;;
+ esac
+ case "$dflt" in
+ '') dflt=/usr/ucb/more;;
+ esac
+ ;;
+*) dflt="$pager";;
+esac
+echo " "
+fn=f/
+rp='What pager is used on your system?'
+. ./getfile
+pager="$ans"
+
+: see what type pids are declared as in the kernel
+rp="What is the type of process ids on this system?"
+set pid_t pidtype int stdio.h sys/types.h
+eval $typedef_ask
+
+: check for length of pointer
+echo " "
+case "$ptrsize" in
+'')
+ $echo $n "Checking to see how big your pointers are...$c" >&4
+ if test "$voidflags" -gt 7; then
+ echo '#define VOID_PTR char *' > try.c
+ else
+ echo '#define VOID_PTR void *' > try.c
+ fi
+ $cat >>try.c <<'EOCP'
+#include <stdio.h>
+main()
+{
+ printf("%d\n", sizeof(VOID_PTR));
+ exit(0);
+}
+EOCP
+ set try
+ if eval $compile_ok; then
+ ptrsize=`./try`
+ $echo " $ptrsize bytes." >&4
+ else
+ dflt='4'
+ echo "(I can't seem to compile the test program. Guessing...)" >&4
+ rp="What is the size of a pointer (in bytes)?"
+ . ./myread
+ ptrsize="$ans"
+ fi
+ ;;
+esac
+$rm -f try.c try
+
+: check for size of random number generator
+echo " "
+case "$randbits" in
+'')
+ echo "Checking to see how many bits your rand function produces..." >&4
+ $cat >try.c <<EOCP
+#$i_unistd I_UNISTD
+#$i_stdlib I_STDLIB
+#include <stdio.h>
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+#ifdef I_STDLIB
+# include <stdlib.h>
+#endif
+EOCP
+ $cat >>try.c <<'EOCP'
+main()
+{
+ register int i;
+ register unsigned long tmp;
+ register unsigned long max = 0L;
+
+ for (i = 1000; i; i--) {
+ tmp = (unsigned long)rand();
+ if (tmp > max) max = tmp;
+ }
+ for (i = 0; max; i++)
+ max /= 2;
+ printf("%d\n",i);
+}
+EOCP
+ set try
+ if eval $compile_ok; then
+ dflt=`./try$_exe`
+ else
+ dflt='?'
+ echo "(I can't seem to compile the test program...)"
+ fi
+ ;;
+*)
+ dflt="$randbits"
+ ;;
+esac
+rp='How many bits does your rand() function produce?'
+. ./myread
+randbits="$ans"
+$rm -f try.* try
+
+: see if ar generates random libraries by itself
+echo " "
+echo "Checking how to generate random libraries on your machine..." >&4
+echo 'int bar1() { return bar2(); }' > bar1.c
+echo 'int bar2() { return 2; }' > bar2.c
+$cat > foo.c <<'EOP'
+main() { printf("%d\n", bar1()); exit(0); }
+EOP
+$cc $ccflags -c bar1.c >/dev/null 2>&1
+$cc $ccflags -c bar2.c >/dev/null 2>&1
+$cc $ccflags -c foo.c >/dev/null 2>&1
+$ar rc bar$_a bar2$_o bar1$_o >/dev/null 2>&1
+if $cc $ccflags $ldflags -o foobar foo$_o bar$_a $libs > /dev/null 2>&1 &&
+ ./foobar >/dev/null 2>&1; then
+ echo "$ar appears to generate random libraries itself."
+ orderlib=false
+ ranlib=":"
+elif $ar ts bar$_a >/dev/null 2>&1 &&
+ $cc $ccflags $ldflags -o foobar foo$_o bar$_a $libs > /dev/null 2>&1 &&
+ ./foobar >/dev/null 2>&1; then
+ echo "a table of contents needs to be added with '$ar ts'."
+ orderlib=false
+ ranlib="$ar ts"
+else
+ case "$ranlib" in
+ :) ranlib='';;
+ '')
+ ranlib=`./loc ranlib X /usr/bin /bin /usr/local/bin`
+ $test -f $ranlib || ranlib=''
+ ;;
+ esac
+ if $test -n "$ranlib"; then
+ echo "your system has '$ranlib'; we'll use that."
+ orderlib=false
+ else
+ echo "your system doesn't seem to support random libraries"
+ echo "so we'll use lorder and tsort to order the libraries."
+ orderlib=true
+ ranlib=":"
+ fi
+fi
+$rm -f foo* bar*
+
+: see if sys/select.h has to be included
+set sys/select.h i_sysselct
+eval $inhdr
+
+: see if we should include time.h, sys/time.h, or both
+echo " "
+if test "X$timeincl" = X; then
+ echo "Testing to see if we should include <time.h>, <sys/time.h> or both." >&4
+ $echo $n "I'm now running the test program...$c"
+ $cat >try.c <<'EOCP'
+#include <sys/types.h>
+#ifdef I_TIME
+#include <time.h>
+#endif
+#ifdef I_SYSTIME
+#ifdef SYSTIMEKERNEL
+#define KERNEL
+#endif
+#include <sys/time.h>
+#endif
+#ifdef I_SYSSELECT
+#include <sys/select.h>
+#endif
+main()
+{
+ struct tm foo;
+#ifdef S_TIMEVAL
+ struct timeval bar;
+#endif
+#ifdef S_TIMEZONE
+ struct timezone tzp;
+#endif
+ if (foo.tm_sec == foo.tm_sec)
+ exit(0);
+#ifdef S_TIMEVAL
+ if (bar.tv_sec == bar.tv_sec)
+ exit(0);
+#endif
+ exit(1);
+}
+EOCP
+ flags=''
+ for s_timezone in '-DS_TIMEZONE' ''; do
+ sysselect=''
+ for s_timeval in '-DS_TIMEVAL' ''; do
+ for i_systimek in '' '-DSYSTIMEKERNEL'; do
+ for i_time in '' '-DI_TIME'; do
+ for i_systime in '-DI_SYSTIME' ''; do
+ case "$flags" in
+ '') $echo $n ".$c"
+ set try $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone
+ if eval $compile; then
+ set X $i_time $i_systime $i_systimek $sysselect $s_timeval
+ shift
+ flags="$*"
+ echo " "
+ $echo $n "Succeeded with $flags$c"
+ fi
+ ;;
+ esac
+ done
+ done
+ done
+ done
+ done
+ timeincl=''
+ echo " "
+ case "$flags" in
+ *SYSTIMEKERNEL*) i_systimek="$define"
+ timeincl=`./findhdr sys/time.h`
+ echo "We'll include <sys/time.h> with KERNEL defined." >&4;;
+ *) i_systimek="$undef";;
+ esac
+ case "$flags" in
+ *I_TIME*) i_time="$define"
+ timeincl=`./findhdr time.h`" $timeincl"
+ echo "We'll include <time.h>." >&4;;
+ *) i_time="$undef";;
+ esac
+ case "$flags" in
+ *I_SYSTIME*) i_systime="$define"
+ timeincl=`./findhdr sys/time.h`" $timeincl"
+ echo "We'll include <sys/time.h>." >&4;;
+ *) i_systime="$undef";;
+ esac
+ $rm -f try.c try
+fi
+
+: check for fd_set items
+$cat <<EOM
+
+Checking to see how well your C compiler handles fd_set and friends ...
+EOM
+$cat >fd_set.c <<EOCP
+#$i_systime I_SYS_TIME
+#$i_sysselct I_SYS_SELECT
+#$d_socket HAS_SOCKET
+#include <sys/types.h>
+#ifdef HAS_SOCKET
+#include <sys/socket.h> /* Might include <sys/bsdtypes.h> */
+#endif
+#ifdef I_SYS_TIME
+#include <sys/time.h>
+#endif
+#ifdef I_SYS_SELECT
+#include <sys/select.h>
+#endif
+main() {
+ fd_set fds;
+
+#ifdef TRYBITS
+ if(fds.fds_bits);
+#endif
+
+#if defined(FD_SET) && defined(FD_CLR) && defined(FD_ISSET) && defined(FD_ZERO)
+ exit(0);
+#else
+ exit(1);
+#endif
+}
+EOCP
+set fd_set -DTRYBITS
+if eval $compile; then
+ d_fds_bits="$define"
+ d_fd_set="$define"
+ echo "Well, your system knows about the normal fd_set typedef..." >&4
+ if ./fd_set; then
+ echo "and you have the normal fd_set macros (just as I'd expect)." >&4
+ d_fd_macros="$define"
+ else
+ $cat >&4 <<'EOM'
+but not the normal fd_set macros! Gaaack! I'll have to cover for you.
+EOM
+ d_fd_macros="$undef"
+ fi
+else
+ $cat <<'EOM'
+Hmm, your compiler has some difficulty with fd_set. Checking further...
+EOM
+ set fd_set
+ if eval $compile; then
+ d_fds_bits="$undef"
+ d_fd_set="$define"
+ echo "Well, your system has some sort of fd_set available..." >&4
+ if ./fd_set; then
+ echo "and you have the normal fd_set macros." >&4
+ d_fd_macros="$define"
+ else
+ $cat <<'EOM'
+but not the normal fd_set macros! Gross! More work for me...
+EOM
+ d_fd_macros="$undef"
+ fi
+ else
+ echo "Well, you got zip. That's OK, I can roll my own fd_set stuff." >&4
+ d_fd_set="$undef"
+ d_fds_bits="$undef"
+ d_fd_macros="$undef"
+ fi
+fi
+$rm -f fd_set*
+
+: check for type of arguments to select.
+case "$selecttype" in
+'') case "$d_select" in
+ $define)
+ $cat <<EOM
+Checking to see what type of arguments are accepted by select().
+EOM
+ hdrs="$define sys/types.h
+ $i_systime sys/time.h
+ $i_sysselct sys/select.h
+ $d_socket sys/socket.h"
+ : The first arg can be int, unsigned, or size_t
+ : The last arg may or may not be 'const'
+ val=''
+ for xxx in 'fd_set *' 'int *'; do
+ for nfd in 'int' 'size_t' 'unsigned' ; do
+ for tmo in 'struct timeval *' 'const struct timeval *'; do
+ case "$val" in
+ '') try="extern select _(($nfd, $xxx, $xxx, $xxx, $tmo));"
+ if ./protochk "$try" $hdrs; then
+ echo "Your system accepts $xxx."
+ val="$xxx"
+ fi
+ ;;
+ esac
+ done
+ done
+ done
+ case "$val" in
+ '') rp='What is the type for the 2nd, 3rd, and 4th arguments to select?'
+ case "$d_fd_set" in
+ $define) dflt="fd_set *" ;;
+ *) dflt="int *" ;;
+ esac
+ . ./myread
+ val=$ans
+ ;;
+ esac
+ selecttype="$val"
+ ;;
+ *) : no select, so pick a harmless default
+ selecttype='int *'
+ ;;
+ esac
+ ;;
+esac
+
+: Trace out the files included by signal.h, then look for SIGxxx names.
+: Remove SIGARRAYSIZE used by HPUX.
+: Remove SIGTYP void lines used by OS2.
+xxx=`echo '#include <signal.h>' |
+ $cppstdin $cppminus $cppflags 2>/dev/null |
+ $grep '^[ ]*#.*include' |
+ $awk "{print \\$$fieldn}" | $sed 's!"!!g' | $sort | $uniq`
+: Check this list of files to be sure we have parsed the cpp output ok.
+: This will also avoid potentially non-existent files, such
+: as ../foo/bar.h
+xxxfiles=''
+for xx in $xxx /dev/null ; do
+ $test -f "$xx" && xxxfiles="$xxxfiles $xx"
+done
+: If we have found no files, at least try signal.h
+case "$xxxfiles" in
+'') xxxfiles=`./findhdr signal.h` ;;
+esac
+xxx=`awk '
+$1 ~ /^#define$/ && $2 ~ /^SIG[A-Z0-9]*$/ && $2 !~ /SIGARRAYSIZE/ && $3 !~ /void/ {
+ print substr($2, 4, 20)
+}
+$1 == "#" && $2 ~ /^define$/ && $3 ~ /^SIG[A-Z0-9]*$/ && $3 !~ /SIGARRAYSIZE/ && $4 !~ /void/ {
+ print substr($3, 4, 20)
+}' $xxxfiles`
+: Append some common names just in case the awk scan failed.
+xxx="$xxx ABRT ALRM BUS CHLD CLD CONT DIL EMT FPE HUP ILL INT IO IOT KILL"
+xxx="$xxx LOST PHONE PIPE POLL PROF PWR QUIT SEGV STKFLT STOP SYS TERM TRAP"
+xxx="$xxx TSTP TTIN TTOU URG USR1 USR2 USR3 USR4 VTALRM"
+xxx="$xxx WINCH WIND WINDOW XCPU XFSZ"
+: generate a few handy files for later
+$cat > signal.c <<'EOCP'
+#include <sys/types.h>
+#include <signal.h>
+#include <stdio.h>
+int main() {
+
+/* Strange style to avoid deeply-nested #if/#else/#endif */
+#ifndef NSIG
+# ifdef _NSIG
+# define NSIG (_NSIG)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef SIGMAX
+# define NSIG (SIGMAX+1)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef SIG_MAX
+# define NSIG (SIG_MAX+1)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef MAXSIG
+# define NSIG (MAXSIG+1)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef MAX_SIG
+# define NSIG (MAX_SIG+1)
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef SIGARRAYSIZE
+# define NSIG (SIGARRAYSIZE+1) /* Not sure of the +1 */
+# endif
+#endif
+
+#ifndef NSIG
+# ifdef _sys_nsig
+# define NSIG (_sys_nsig) /* Solaris 2.5 */
+# endif
+#endif
+
+/* Default to some arbitrary number that's big enough to get most
+ of the common signals.
+*/
+#ifndef NSIG
+# define NSIG 50
+#endif
+
+printf("NSIG %d\n", NSIG);
+
+#ifndef JUST_NSIG
+
+EOCP
+
+echo $xxx | $tr ' ' $trnl | $sort | $uniq | $awk '
+{
+ printf "#ifdef SIG"; printf $1; printf "\n"
+ printf "printf(\""; printf $1; printf " %%d\\n\",SIG";
+ printf $1; printf ");\n"
+ printf "#endif\n"
+}
+END {
+ printf "#endif /* JUST_NSIG */\n";
+ printf "}\n";
+}
+' >>signal.c
+$cat >signal.awk <<'EOP'
+BEGIN { ndups = 0 }
+$1 ~ /^NSIG$/ { nsig = $2 }
+($1 !~ /^NSIG$/) && (NF == 2) {
+ if ($2 > maxsig) { maxsig = $2 }
+ if (sig_name[$2]) {
+ dup_name[ndups] = $1
+ dup_num[ndups] = $2
+ ndups++
+ }
+ else {
+ sig_name[$2] = $1
+ sig_num[$2] = $2
+ }
+
+}
+END {
+ if (nsig == 0) { nsig = maxsig + 1 }
+ for (n = 1; n < nsig; n++) {
+ if (sig_name[n]) {
+ printf("%s %d\n", sig_name[n], sig_num[n])
+ }
+ else {
+ printf("NUM%d %d\n", n, n)
+ }
+ }
+ for (n = 0; n < ndups; n++) {
+ printf("%s %d\n", dup_name[n], dup_num[n])
+ }
+}
+EOP
+$cat >signal_cmd <<EOS
+$startsh
+if $test -s signal.lst; then
+ echo "Using your existing signal.lst file"
+ exit 0
+fi
+xxx="$xxx"
+EOS
+$cat >>signal_cmd <<'EOS'
+
+set signal
+if eval $compile_ok; then
+ ./signal$_exe | $sort -n +1 | $uniq | $awk -f signal.awk >signal.lst
+else
+ echo "(I can't seem be able to compile the whole test program)" >&4
+ echo "(I'll try it in little pieces.)" >&4
+ set signal -DJUST_NSIG
+ if eval $compile_ok; then
+ ./signal$_exe > signal.nsg
+ $cat signal.nsg
+ else
+ echo "I can't seem to figure out how many signals you have." >&4
+ echo "Guessing 50." >&4
+ echo 'NSIG 50' > signal.nsg
+ fi
+ : Now look at all the signal names, one at a time.
+ for xx in `echo $xxx | $tr ' ' $trnl | $sort | $uniq`; do
+ $cat > signal.c <<EOCP
+#include <sys/types.h>
+#include <signal.h>
+#include <stdio.h>
+int main() {
+printf("$xx %d\n", SIG${xx});
+return 0;
+}
+EOCP
+ set signal
+ if eval $compile; then
+ echo "SIG${xx} found."
+ ./signal$_exe >> signal.ls1
+ else
+ echo "SIG${xx} NOT found."
+ fi
+ done
+ if $test -s signal.ls1; then
+ $cat signal.nsg signal.ls1 |
+ $sort -n +1 | $uniq | $awk -f signal.awk >signal.lst
+ fi
+
+fi
+if $test -s signal.lst; then
+ :
+else
+ echo "(AAK! I can't compile the test programs -- Guessing)" >&4
+ echo 'kill -l' >signal
+ set X `csh -f <signal`
+ $rm -f signal
+ shift
+ case $# in
+ 0) set HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM;;
+ esac
+ echo $@ | $tr ' ' $trnl | \
+ $awk '{ printf $1; printf " %d\n", ++s; }' >signal.lst
+fi
+$rm -f signal.c signal$_exe signal$_o signal.nsg signal.ls1
+EOS
+chmod a+x signal_cmd
+$eunicefix signal_cmd
+
+: generate list of signal names
+echo " "
+case "$sig_name_init" in
+'')
+ echo "Generating a list of signal names and numbers..." >&4
+ . ./signal_cmd
+ sig_name=`$awk '{printf "%s ", $1}' signal.lst`
+ sig_name="ZERO $sig_name"
+ sig_name_init=`$awk 'BEGIN { printf "\"ZERO\", " }
+ { printf "\"%s\", ", $1 }
+ END { printf "0\n" }' signal.lst`
+ sig_num=`$awk 'BEGIN { printf "0, " }
+ { printf "%d, ", $2}
+ END { printf "0\n"}' signal.lst`
+ ;;
+esac
+echo "The following signals are available:"
+echo " "
+echo $sig_name | $awk \
+'BEGIN { linelen = 0 }
+{
+ for (i = 1; i <= NF; i++) {
+ name = "SIG" $i " "
+ linelen = linelen + length(name)
+ if (linelen > 70) {
+ printf "\n"
+ linelen = length(name)
+ }
+ printf "%s", name
+ }
+ printf "\n"
+}'
+$rm -f signal signal.c signal.awk signal.lst signal_cmd
+
+: see what type is used for signed size_t
+set ssize_t ssizetype int stdio.h sys/types.h
+eval $typedef
+dflt="$ssizetype"
+$cat > ssize.c <<EOM
+#include <stdio.h>
+#include <sys/types.h>
+#define Size_t $sizetype
+#define SSize_t $dflt
+main()
+{
+ if (sizeof(Size_t) == sizeof(SSize_t))
+ printf("$dflt\n");
+ else if (sizeof(Size_t) == sizeof(int))
+ printf("int\n");
+ else
+ printf("long\n");
+ exit(0);
+}
+EOM
+echo " "
+set ssize
+if eval $compile_ok && ./ssize > /dev/null; then
+ ssizetype=`./ssize`
+ echo "I'll be using $ssizetype for functions returning a byte count." >&4
+else
+ $cat >&4 <<EOM
+Help! I can't compile and run the ssize_t test program: please enlighten me!
+(This is probably a misconfiguration in your system or libraries, and
+you really ought to fix it. Still, I'll try anyway.)
+
+I need a type that is the same size as $sizetype, but is guaranteed to
+be signed. Common values are ssize_t, int and long.
+
+EOM
+ rp="What signed type is the same size as $sizetype?"
+ . ./myread
+ ssizetype="$ans"
+fi
+$rm -f ssize ssize.*
+
+: see what type of char stdio uses.
+echo " "
+if $contains 'unsigned.*char.*_ptr;' `./findhdr stdio.h` >/dev/null 2>&1 ; then
+ echo "Your stdio uses unsigned chars." >&4
+ stdchar="unsigned char"
+else
+ echo "Your stdio uses signed chars." >&4
+ stdchar="char"
+fi
+
+: see if time exists
+echo " "
+if test "X$d_time" = X -o X"$timetype" = X; then
+ if set time val -f d_time; eval $csym; $val; then
+ echo 'time() found.' >&4
+ val="$define"
+ rp="What is the type returned by time() on this system?"
+ set time_t timetype long stdio.h sys/types.h
+ eval $typedef_ask
+ else
+ echo 'time() not found, hope that will do.' >&4
+ val="$undef"
+ timetype='int';
+ fi
+ set d_time
+ eval $setvar
+fi
+
+: see what type uids are declared as in the kernel
+echo " "
+echo "Looking for the type for user ids returned by getuid()."
+set uid_t uidtype xxx stdio.h sys/types.h
+eval $typedef
+case "$uidtype" in
+xxx)
+ xxx=`./findhdr sys/user.h`
+ set `grep '_ruid;' "$xxx" 2>/dev/null` unsigned short
+ case $1 in
+ unsigned) dflt="$1 $2" ;;
+ *) dflt="$1" ;;
+ esac
+ ;;
+*) dflt="$uidtype";;
+esac
+case "$uidtype" in
+uid_t) echo "uid_t found." ;;
+*) rp="What is the type for user ids returned by getuid()?"
+ . ./myread
+ uidtype="$ans"
+ ;;
+esac
+
+: see if dbm.h is available
+: see if dbmclose exists
+set dbmclose d_dbmclose
+eval $inlibc
+
+case "$d_dbmclose" in
+$define)
+ set dbm.h i_dbm
+ eval $inhdr
+ case "$i_dbm" in
+ $define)
+ val="$undef"
+ set i_rpcsvcdbm
+ eval $setvar
+ ;;
+ *) set rpcsvc/dbm.h i_rpcsvcdbm
+ eval $inhdr
+ ;;
+ esac
+ ;;
+*) echo "We won't be including <dbm.h>"
+ val="$undef"
+ set i_dbm
+ eval $setvar
+ val="$undef"
+ set i_rpcsvcdbm
+ eval $setvar
+ ;;
+esac
+
+: see if this is a sys/file.h system
+val=''
+set sys/file.h val
+eval $inhdr
+
+: do we need to include sys/file.h ?
+case "$val" in
+"$define")
+ echo " "
+ if $h_sysfile; then
+ val="$define"
+ echo "We'll be including <sys/file.h>." >&4
+ else
+ val="$undef"
+ echo "We won't be including <sys/file.h>." >&4
+ fi
+ ;;
+*)
+ h_sysfile=false
+ ;;
+esac
+set i_sysfile
+eval $setvar
+
+: see if fcntl.h is there
+val=''
+set fcntl.h val
+eval $inhdr
+
+: see if we can include fcntl.h
+case "$val" in
+"$define")
+ echo " "
+ if $h_fcntl; then
+ val="$define"
+ echo "We'll be including <fcntl.h>." >&4
+ else
+ val="$undef"
+ if $h_sysfile; then
+ echo "We don't need to include <fcntl.h> if we include <sys/file.h>." >&4
+ else
+ echo "We won't be including <fcntl.h>." >&4
+ fi
+ fi
+ ;;
+*)
+ h_fcntl=false
+ val="$undef"
+ ;;
+esac
+set i_fcntl
+eval $setvar
+
+: see if this is an grp system
+set grp.h i_grp
+eval $inhdr
+
+case "$i_grp" in
+$define)
+ : see if setgrent exists
+ set setgrent d_setgrent
+ eval $inlibc
+
+ : see if getgrent exists
+ set getgrent d_getgrent
+ eval $inlibc
+
+ : see if endgrent exists
+ set endgrent d_endgrent
+ eval $inlibc
+
+ xxx=`./findhdr grp.h`
+ $cppstdin $cppflags $cppminus < $xxx >$$.h
+
+ if $contains 'gr_passwd' $$.h >/dev/null 2>&1; then
+ val="$define"
+ else
+ val="$undef"
+ fi
+ set d_grpasswd
+ eval $setvar
+
+ $rm -f $$.h
+ ;;
+*) # Assume all is lost as far as the d_*gr* go.
+ val="$undef";
+ set d_setgrent; eval $setvar
+ set d_getgrent; eval $setvar
+ set d_endgrent; eval $setvar
+ set d_grpasswd; eval $setvar
+ ;;
+esac
+
+: see if locale.h is available
+set locale.h i_locale
+eval $inhdr
+
+: see if this is a math.h system
+set math.h i_math
+eval $inhdr
+
+: see if ndbm.h is available
+set ndbm.h t_ndbm
+eval $inhdr
+case "$t_ndbm" in
+$define)
+ : see if dbm_open exists
+ set dbm_open d_dbm_open
+ eval $inlibc
+ case "$d_dbm_open" in
+ $undef)
+ t_ndbm="$undef"
+ echo "We won't be including <ndbm.h>"
+ ;;
+ esac
+ ;;
+esac
+val="$t_ndbm"
+set i_ndbm
+eval $setvar
+
+: see if net/errno.h is available
+val=''
+set net/errno.h val
+eval $inhdr
+
+: Unfortunately, it causes problems on some systems. Arrgh.
+case "$val" in
+$define)
+ cat > try.c <<'EOM'
+#include <stdio.h>
+#include <errno.h>
+#include <net/errno.h>
+int func()
+{
+ return ENOTSOCK;
+}
+EOM
+ if $cc $ccflags -c try.c >/dev/null 2>&1; then
+ echo "We'll be including <net/errno.h>." >&4
+ else
+ echo "We won't be including <net/errno.h>." >&4
+ val="$undef"
+ fi
+ $rm -f try.* try
+ ;;
+esac
+set i_neterrno
+eval $setvar
+
+: get C preprocessor symbols handy
+echo " "
+$echo $n "Hmm... $c"
+echo $al | $tr ' ' $trnl >Cppsym.know
+$cat <<EOSS >Cppsym
+$startsh
+case "\$1" in
+-l) list=true
+ shift
+ ;;
+esac
+unknown=''
+case "\$list\$#" in
+1|2)
+ for sym do
+ if $contains "^\$1$" Cppsym.true >/dev/null 2>&1; then
+ exit 0
+ elif $contains "^\$1$" Cppsym.know >/dev/null 2>&1; then
+ :
+ else
+ unknown="\$unknown \$sym"
+ fi
+ done
+ set X \$unknown
+ shift
+ ;;
+esac
+case \$# in
+0) exit 1;;
+esac
+echo \$* | $tr ' ' '$trnl' | $sed -e 's/\(.*\)/\\
+#ifdef \1\\
+exit 0; _ _ _ _\1\\ \1\\
+#endif\\
+/' >Cppsym\$\$
+echo "exit 1; _ _ _" >>Cppsym\$\$
+$cppstdin $cppminus <Cppsym\$\$ | $grep '^exit [01]; _ _' >Cppsym2\$\$
+case "\$list" in
+true) $awk 'NF > 5 {print substr(\$6,2,100)}' <Cppsym2\$\$ ;;
+*)
+ sh Cppsym2\$\$
+ status=\$?
+ ;;
+esac
+$rm -f Cppsym\$\$ Cppsym2\$\$
+exit \$status
+EOSS
+chmod +x Cppsym
+$eunicefix Cppsym
+./Cppsym -l $al | $sort | $grep -v '^$' >Cppsym.true
+
+: now check the C compiler for additional symbols
+$cat >ccsym <<EOS
+$startsh
+$cat >tmp.c <<EOF
+extern int foo;
+EOF
+for i in \`$cc -v -c tmp.c 2>&1\`
+do
+ case "\$i" in
+ -D*) echo "\$i" | $sed 's/^-D//';;
+ -A*) $test "$gccversion" && echo "\$i" | $sed 's/^-A\(.*\)(\(.*\))/\1=\2/';;
+ esac
+done
+$rm -f try.c
+EOS
+chmod +x ccsym
+$eunicefix ccsym
+./ccsym | $sort | $uniq >ccsym.raw
+$awk '/\=/ { print $0; next }
+ { print $0"=1" }' ccsym.raw >ccsym.list
+$awk '{ print $0"=1" }' Cppsym.true >ccsym.true
+$comm -13 ccsym.true ccsym.list >ccsym.own
+$comm -12 ccsym.true ccsym.list >ccsym.com
+$comm -23 ccsym.true ccsym.list >ccsym.cpp
+also=''
+symbols='symbols'
+if $test -z ccsym.raw; then
+ echo "Your C compiler doesn't seem to define any symbol!" >&4
+ echo " "
+ echo "However, your C preprocessor defines the following ones:"
+ $cat Cppsym.true
+else
+ if $test -s ccsym.com; then
+ echo "Your C compiler and pre-processor define these symbols:"
+ $sed -e 's/\(.*\)=.*/\1/' ccsym.com
+ also='also '
+ symbols='ones'
+ $test "$silent" || sleep 1
+ fi
+ if $test -s ccsym.cpp; then
+ $test "$also" && echo " "
+ echo "Your C pre-processor ${also}defines the following $symbols:"
+ $sed -e 's/\(.*\)=.*/\1/' ccsym.cpp
+ also='further '
+ $test "$silent" || sleep 1
+ fi
+ if $test -s ccsym.own; then
+ $test "$also" && echo " "
+ echo "Your C compiler ${also}defines the following cpp variables:"
+ $sed -e 's/\(.*\)=1/\1/' ccsym.own
+ $sed -e 's/\(.*\)=.*/\1/' ccsym.own | $uniq >>Cppsym.true
+ $test "$silent" || sleep 1
+ fi
+fi
+$rm -f ccsym*
+
+: see if this is a termio system
+val="$undef"
+val2="$undef"
+val3="$undef"
+if $test `./findhdr termios.h`; then
+ set tcsetattr i_termios
+ eval $inlibc
+ val3="$i_termios"
+fi
+echo " "
+case "$val3" in
+"$define") echo "You have POSIX termios.h... good!" >&4;;
+*) if ./Cppsym pyr; then
+ case "`/bin/universe`" in
+ ucb) if $test `./findhdr sgtty.h`; then
+ val2="$define"
+ echo "<sgtty.h> found." >&4
+ else
+ echo "System is pyramid with BSD universe."
+ echo "<sgtty.h> not found--you could have problems." >&4
+ fi;;
+ *) if $test `./findhdr termio.h`; then
+ val="$define"
+ echo "<termio.h> found." >&4
+ else
+ echo "System is pyramid with USG universe."
+ echo "<termio.h> not found--you could have problems." >&4
+ fi;;
+ esac
+ elif ./usg; then
+ if $test `./findhdr termio.h`; then
+ echo "<termio.h> found." >&4
+ val="$define"
+ elif $test `./findhdr sgtty.h`; then
+ echo "<sgtty.h> found." >&4
+ val2="$define"
+ else
+echo "Neither <termio.h> nor <sgtty.h> found--you could have problems." >&4
+ fi
+ else
+ if $test `./findhdr sgtty.h`; then
+ echo "<sgtty.h> found." >&4
+ val2="$define"
+ elif $test `./findhdr termio.h`; then
+ echo "<termio.h> found." >&4
+ val="$define"
+ else
+echo "Neither <sgtty.h> nor <termio.h> found--you could have problems." >&4
+ fi
+ fi;;
+esac
+set i_termio; eval $setvar
+val=$val2; set i_sgtty; eval $setvar
+val=$val3; set i_termios; eval $setvar
+
+: see if stdarg is available
+echo " "
+if $test `./findhdr stdarg.h`; then
+ echo "<stdarg.h> found." >&4
+ valstd="$define"
+else
+ echo "<stdarg.h> NOT found." >&4
+ valstd="$undef"
+fi
+
+: see if varags is available
+echo " "
+if $test `./findhdr varargs.h`; then
+ echo "<varargs.h> found." >&4
+else
+ echo "<varargs.h> NOT found, but that's ok (I hope)." >&4
+fi
+
+: set up the varargs testing programs
+$cat > varargs.c <<EOP
+#ifdef I_STDARG
+#include <stdarg.h>
+#endif
+#ifdef I_VARARGS
+#include <varargs.h>
+#endif
+
+#ifdef I_STDARG
+int f(char *p, ...)
+#else
+int f(va_alist)
+va_dcl
+#endif
+{
+ va_list ap;
+#ifndef I_STDARG
+ char *p;
+#endif
+#ifdef I_STDARG
+ va_start(ap,p);
+#else
+ va_start(ap);
+ p = va_arg(ap, char *);
+#endif
+ va_end(ap);
+}
+EOP
+$cat > varargs <<EOP
+$startsh
+if $cc -c $ccflags -D\$1 varargs.c >/dev/null 2>&1; then
+ echo "true"
+else
+ echo "false"
+fi
+$rm -f varargs$_o
+EOP
+chmod +x varargs
+
+: now check which varargs header should be included
+echo " "
+i_varhdr=''
+case "$valstd" in
+"$define")
+ if `./varargs I_STDARG`; then
+ val='stdarg.h'
+ elif `./varargs I_VARARGS`; then
+ val='varargs.h'
+ fi
+ ;;
+*)
+ if `./varargs I_VARARGS`; then
+ val='varargs.h'
+ fi
+ ;;
+esac
+case "$val" in
+'')
+echo "I could not find the definition for va_dcl... You have problems..." >&4
+ val="$undef"; set i_stdarg; eval $setvar
+ val="$undef"; set i_varargs; eval $setvar
+ ;;
+*)
+ set i_varhdr
+ eval $setvar
+ case "$i_varhdr" in
+ stdarg.h)
+ val="$define"; set i_stdarg; eval $setvar
+ val="$undef"; set i_varargs; eval $setvar
+ ;;
+ varargs.h)
+ val="$undef"; set i_stdarg; eval $setvar
+ val="$define"; set i_varargs; eval $setvar
+ ;;
+ esac
+ echo "We'll include <$i_varhdr> to get va_dcl definition." >&4;;
+esac
+$rm -f varargs*
+
+: see if stddef is available
+set stddef.h i_stddef
+eval $inhdr
+
+: see if ioctl defs are in sgtty, termio, sys/filio or sys/ioctl
+set sys/filio.h i_sysfilio
+eval $inhdr
+echo " "
+if $test `./findhdr sys/ioctl.h`; then
+ val="$define"
+ echo '<sys/ioctl.h> found.' >&4
+else
+ val="$undef"
+ if $test $i_sysfilio = "$define"; then
+ echo '<sys/ioctl.h> NOT found.' >&4
+ else
+ $test $i_sgtty = "$define" && xxx="sgtty.h"
+ $test $i_termio = "$define" && xxx="termio.h"
+ $test $i_termios = "$define" && xxx="termios.h"
+echo "No <sys/ioctl.h> found, assuming ioctl args are defined in <$xxx>." >&4
+ fi
+fi
+set i_sysioctl
+eval $setvar
+
+: see if this is a sys/param system
+set sys/param.h i_sysparam
+eval $inhdr
+
+: see if sys/resource.h has to be included
+set sys/resource.h i_sysresrc
+eval $inhdr
+
+: see if sys/stat.h is available
+set sys/stat.h i_sysstat
+eval $inhdr
+
+: see if this is a sys/un.h system
+set sys/un.h i_sysun
+eval $inhdr
+
+: see if this is a syswait system
+set sys/wait.h i_syswait
+eval $inhdr
+
+: see if this is an utime system
+set utime.h i_utime
+eval $inhdr
+
+: see if this is a values.h system
+set values.h i_values
+eval $inhdr
+
+: see if this is a vfork system
+case "$d_vfork" in
+"$define")
+ set vfork.h i_vfork
+ eval $inhdr
+ ;;
+*)
+ i_vfork="$undef"
+ ;;
+esac
+
+: see if gdbm.h is available
+set gdbm.h t_gdbm
+eval $inhdr
+case "$t_gdbm" in
+$define)
+ : see if gdbm_open exists
+ set gdbm_open d_gdbm_open
+ eval $inlibc
+ case "$d_gdbm_open" in
+ $undef)
+ t_gdbm="$undef"
+ echo "We won't be including <gdbm.h>"
+ ;;
+ esac
+ ;;
+esac
+val="$t_gdbm"
+set i_gdbm
+eval $setvar
+
+echo " "
+echo "Looking for extensions..." >&4
+tdir=`pwd`
+cd $rsrc/ext
+: If we are using the old config.sh, known_extensions may contain
+: old or inaccurate or duplicate values.
+known_extensions=''
+nonxs_extensions=''
+: We do not use find because it might not be available.
+: We do not just use MANIFEST because the user may have dropped
+: some additional extensions into the source tree and expect them
+: to be built.
+for xxx in * ; do
+ case "$xxx" in
+ DynaLoader|dynaload) ;;
+ *) if $test -f $xxx/$xxx.xs; then
+ known_extensions="$known_extensions $xxx"
+ elif $test -f $xxx/Makefile.PL; then
+ nonxs_extensions="$nonxs_extensions $xxx"
+ else
+ if $test -d $xxx; then
+ # Look for nested extensions, eg. Devel/Dprof.
+ cd $xxx
+ for yyy in * ; do
+ if $test -f $yyy/$yyy.xs; then
+ known_extensions="$known_extensions $xxx/$yyy"
+ elif $test -f $yyy/Makefile.PL; then
+ nonxs_extensions="$nonxs_extensions $xxx/$yyy"
+ fi
+ done
+ cd ..
+ fi
+ fi
+ ;;
+ esac
+done
+set X $nonxs_extensions
+shift
+nonxs_extensions="$*"
+set X $known_extensions
+shift
+known_extensions="$*"
+cd $tdir
+
+: Now see which are supported on this system.
+avail_ext=''
+for xxx in $known_extensions ; do
+ case "$xxx" in
+ DB_File|db_file)
+ case "$i_db" in
+ $define) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
+ GDBM_File|gdbm_fil)
+ case "$i_gdbm" in
+ $define) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
+ NDBM_File|ndbm_fil)
+ case "$i_ndbm" in
+ $define) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
+ ODBM_File|odbm_fil)
+ case "${i_dbm}${i_rpcsvcdbm}" in
+ *"${define}"*) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
+ POSIX|posix)
+ case "$useposix" in
+ true|define|y) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
+ Opcode|opcode)
+ case "$useopcode" in
+ true|define|y) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
+ Socket|socket)
+ case "$d_socket" in
+ true|$define|y) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
+ Thread|thread)
+ case "$usethreads" in
+ true|$define|y) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
+ IPC/SysV|ipc/sysv)
+ case "${d_msg}${d_sem}${d_shm}" in
+ *"${define}"*) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
+ *) avail_ext="$avail_ext $xxx"
+ ;;
+ esac
+done
+
+set X $avail_ext
+shift
+avail_ext="$*"
+
+: Now see which nonxs extensions are supported on this system.
+: For now assume all are.
+nonxs_ext=''
+for xxx in $nonxs_extensions ; do
+ case "$xxx" in
+ *) nonxs_ext="$nonxs_ext $xxx"
+ ;;
+ esac
+done
+
+set X $nonxs_ext
+shift
+nonxs_ext="$*"
+
+case $usedl in
+$define)
+ $cat <<EOM
+A number of extensions are supplied with $package. You may choose to
+compile these extensions for dynamic loading (the default), compile
+them into the $package executable (static loading), or not include
+them at all. Answer "none" to include no extensions.
+Note that DynaLoader is always built and need not be mentioned here.
+
+EOM
+ case "$dynamic_ext" in
+ '') dflt="$avail_ext" ;;
+ *) dflt="$dynamic_ext"
+ # Perhaps we are reusing an old out-of-date config.sh.
+ case "$hint" in
+ previous)
+ if test X"$dynamic_ext" != X"$avail_ext"; then
+ $cat <<EOM
+NOTICE: Your previous config.sh list may be incorrect.
+The extensions now available to you are
+ ${avail_ext}
+but the default list from your previous config.sh is
+ ${dynamic_ext}
+
+EOM
+ fi
+ ;;
+ esac
+ ;;
+ esac
+ case "$dflt" in
+ '') dflt=none;;
+ esac
+ rp="What extensions do you wish to load dynamically?"
+ . ./myread
+ case "$ans" in
+ none) dynamic_ext=' ' ;;
+ *) dynamic_ext="$ans" ;;
+ esac
+
+ case "$static_ext" in
+ '')
+ : Exclude those already listed in dynamic linking
+ dflt=''
+ for xxx in $avail_ext; do
+ case " $dynamic_ext " in
+ *" $xxx "*) ;;
+ *) dflt="$dflt $xxx" ;;
+ esac
+ done
+ set X $dflt
+ shift
+ dflt="$*"
+ ;;
+ *) dflt="$static_ext"
+ ;;
+ esac
+
+ case "$dflt" in
+ '') dflt=none;;
+ esac
+ rp="What extensions do you wish to load statically?"
+ . ./myread
+ case "$ans" in
+ none) static_ext=' ' ;;
+ *) static_ext="$ans" ;;
+ esac
+ ;;
+*)
+ $cat <<EOM
+A number of extensions are supplied with $package. Answer "none"
+to include no extensions.
+Note that DynaLoader is always built and need not be mentioned here.
+
+EOM
+ case "$static_ext" in
+ '') dflt="$avail_ext" ;;
+ *) dflt="$static_ext"
+ # Perhaps we are reusing an old out-of-date config.sh.
+ case "$hint" in
+ previous)
+ if test X"$static_ext" != X"$avail_ext"; then
+ $cat <<EOM
+NOTICE: Your previous config.sh list may be incorrect.
+The extensions now available to you are
+ ${avail_ext}
+but the default list from your previous config.sh is
+ ${static_ext}
+
+EOM
+ fi
+ ;;
+ esac
+ ;;
+ esac
+ : Exclude those that are not xs extensions
+ case "$dflt" in
+ '') dflt=none;;
+ esac
+ rp="What extensions do you wish to include?"
+ . ./myread
+ case "$ans" in
+ none) static_ext=' ' ;;
+ *) static_ext="$ans" ;;
+ esac
+ ;;
+esac
+
+set X $dynamic_ext $static_ext $nonxs_ext
+shift
+extensions="$*"
+
+: Remove build directory name from cppstdin so it can be used from
+: either the present location or the final installed location.
+echo " "
+: Get out of the UU directory to get correct path name.
+cd ..
+case "$cppstdin" in
+`pwd`/cppstdin)
+ echo "Stripping down cppstdin path name"
+ cppstdin=cppstdin
+ ;;
+esac
+cd UU
+
+: end of configuration questions
+echo " "
+echo "End of configuration questions."
+echo " "
+
+: back to where it started
+if test -d ../UU; then
+ cd ..
+fi
+
+: configuration may be patched via a 'config.over' file
+if $test -f config.over; then
+ echo " "
+ dflt=y
+ rp='I see a config.over file. Do you wish to load it?'
+ . UU/myread
+ case "$ans" in
+ n*) echo "OK, I'll ignore it.";;
+ *) . ./config.over
+ echo "Configuration override changes have been loaded."
+ ;;
+ esac
+fi
+
+: in case they want portability, strip down executable paths
+case "$d_portable" in
+"$define")
+ echo " "
+ echo "Stripping down executable paths..." >&4
+ for file in $loclist $trylist; do
+ if test X$file != Xln -a X$file != Xar -o X$osname != Xos2; then
+ eval $file="\$file"
+ fi
+ done
+ ;;
+esac
+
+: create config.sh file
+echo " "
+echo "Creating config.sh..." >&4
+$spitshell <<EOT >config.sh
+$startsh
+#
+# This file was produced by running the Configure script. It holds all the
+# definitions figured out by Configure. Should you modify one of these values,
+# do not forget to propagate your changes by running "Configure -der". You may
+# instead choose to run each of the .SH files by yourself, or "Configure -S".
+#
+
+# Package name : $package
+# Source directory : $src
+# Configuration time: $cf_time
+# Configured by : $cf_by
+# Target system : $myuname
+
+Author='$Author'
+Date='$Date'
+Header='$Header'
+Id='$Id'
+Locker='$Locker'
+Log='$Log'
+Mcc='$Mcc'
+RCSfile='$RCSfile'
+Revision='$Revision'
+Source='$Source'
+State='$State'
+_a='$_a'
+_exe='$_exe'
+_o='$_o'
+afs='$afs'
+alignbytes='$alignbytes'
+ansi2knr='$ansi2knr'
+aphostname='$aphostname'
+apiversion='$apiversion'
+ar='$ar'
+archlib='$archlib'
+archlibexp='$archlibexp'
+archname='$archname'
+archobjs='$archobjs'
+awk='$awk'
+baserev='$baserev'
+bash='$bash'
+bin='$bin'
+binexp='$binexp'
+bison='$bison'
+byacc='$byacc'
+byteorder='$byteorder'
+c='$c'
+castflags='$castflags'
+cat='$cat'
+cc='$cc'
+cccdlflags='$cccdlflags'
+ccdlflags='$ccdlflags'
+ccflags='$ccflags'
+cf_by='$cf_by'
+cf_email='$cf_email'
+cf_time='$cf_time'
+chgrp='$chgrp'
+chmod='$chmod'
+chown='$chown'
+clocktype='$clocktype'
+comm='$comm'
+compress='$compress'
+contains='$contains'
+cp='$cp'
+cpio='$cpio'
+cpp='$cpp'
+cpp_stuff='$cpp_stuff'
+cppflags='$cppflags'
+cpplast='$cpplast'
+cppminus='$cppminus'
+cpprun='$cpprun'
+cppstdin='$cppstdin'
+cryptlib='$cryptlib'
+csh='$csh'
+d_Gconvert='$d_Gconvert'
+d_access='$d_access'
+d_alarm='$d_alarm'
+d_archlib='$d_archlib'
+d_attribut='$d_attribut'
+d_bcmp='$d_bcmp'
+d_bcopy='$d_bcopy'
+d_bsd='$d_bsd'
+d_bsdgetpgrp='$d_bsdgetpgrp'
+d_bsdsetpgrp='$d_bsdsetpgrp'
+d_bzero='$d_bzero'
+d_casti32='$d_casti32'
+d_castneg='$d_castneg'
+d_charvspr='$d_charvspr'
+d_chown='$d_chown'
+d_chroot='$d_chroot'
+d_chsize='$d_chsize'
+d_closedir='$d_closedir'
+d_const='$d_const'
+d_crypt='$d_crypt'
+d_csh='$d_csh'
+d_cuserid='$d_cuserid'
+d_dbl_dig='$d_dbl_dig'
+d_difftime='$d_difftime'
+d_dirnamlen='$d_dirnamlen'
+d_dlerror='$d_dlerror'
+d_dlopen='$d_dlopen'
+d_dlsymun='$d_dlsymun'
+d_dosuid='$d_dosuid'
+d_dup2='$d_dup2'
+d_endgrent='$d_endgrent'
+d_endhent='$d_endhent'
+d_endnent='$d_endnent'
+d_endpent='$d_endpent'
+d_endpwent='$d_endpwent'
+d_endsent='$d_endsent'
+d_eofnblk='$d_eofnblk'
+d_eunice='$d_eunice'
+d_fchmod='$d_fchmod'
+d_fchown='$d_fchown'
+d_fcntl='$d_fcntl'
+d_fd_macros='$d_fd_macros'
+d_fd_set='$d_fd_set'
+d_fds_bits='$d_fds_bits'
+d_fgetpos='$d_fgetpos'
+d_flexfnam='$d_flexfnam'
+d_flock='$d_flock'
+d_fork='$d_fork'
+d_fpathconf='$d_fpathconf'
+d_fsetpos='$d_fsetpos'
+d_ftime='$d_ftime'
+d_getgrent='$d_getgrent'
+d_getgrps='$d_getgrps'
+d_gethbyaddr='$d_gethbyaddr'
+d_gethbyname='$d_gethbyname'
+d_gethent='$d_gethent'
+d_gethname='$d_gethname'
+d_gethostprotos='$d_gethostprotos'
+d_getlogin='$d_getlogin'
+d_getnbyaddr='$d_getnbyaddr'
+d_getnbyname='$d_getnbyname'
+d_getnent='$d_getnent'
+d_getnetprotos='$d_getnetprotos'
+d_getpbyname='$d_getpbyname'
+d_getpbynumber='$d_getpbynumber'
+d_getpent='$d_getpent'
+d_getpgid='$d_getpgid'
+d_getpgrp2='$d_getpgrp2'
+d_getpgrp='$d_getpgrp'
+d_getppid='$d_getppid'
+d_getprior='$d_getprior'
+d_getprotoprotos='$d_getprotoprotos'
+d_getpwent='$d_getpwent'
+d_getsbyname='$d_getsbyname'
+d_getsbyport='$d_getsbyport'
+d_getsent='$d_getsent'
+d_getservprotos='$d_getservprotos'
+d_gettimeod='$d_gettimeod'
+d_gnulibc='$d_gnulibc'
+d_grpasswd='$d_grpasswd'
+d_htonl='$d_htonl'
+d_index='$d_index'
+d_inetaton='$d_inetaton'
+d_isascii='$d_isascii'
+d_killpg='$d_killpg'
+d_lchown='$d_lchown'
+d_link='$d_link'
+d_locconv='$d_locconv'
+d_lockf='$d_lockf'
+d_longdbl='$d_longdbl'
+d_longlong='$d_longlong'
+d_lstat='$d_lstat'
+d_mblen='$d_mblen'
+d_mbstowcs='$d_mbstowcs'
+d_mbtowc='$d_mbtowc'
+d_memcmp='$d_memcmp'
+d_memcpy='$d_memcpy'
+d_memmove='$d_memmove'
+d_memset='$d_memset'
+d_mkdir='$d_mkdir'
+d_mkfifo='$d_mkfifo'
+d_mktime='$d_mktime'
+d_msg='$d_msg'
+d_msgctl='$d_msgctl'
+d_msgget='$d_msgget'
+d_msgrcv='$d_msgrcv'
+d_msgsnd='$d_msgsnd'
+d_mymalloc='$d_mymalloc'
+d_nice='$d_nice'
+d_oldpthreads='$d_oldpthreads'
+d_oldsock='$d_oldsock'
+d_open3='$d_open3'
+d_pathconf='$d_pathconf'
+d_pause='$d_pause'
+d_phostname='$d_phostname'
+d_pipe='$d_pipe'
+d_poll='$d_poll'
+d_portable='$d_portable'
+d_pthread_yield='$d_pthread_yield'
+d_pthreads_created_joinable='$d_pthreads_created_joinable'
+d_pwage='$d_pwage'
+d_pwchange='$d_pwchange'
+d_pwclass='$d_pwclass'
+d_pwcomment='$d_pwcomment'
+d_pwexpire='$d_pwexpire'
+d_pwgecos='$d_pwgecos'
+d_pwquota='$d_pwquota'
+d_pwpasswd='$d_pwpasswd'
+d_readdir='$d_readdir'
+d_readlink='$d_readlink'
+d_rename='$d_rename'
+d_rewinddir='$d_rewinddir'
+d_rmdir='$d_rmdir'
+d_safebcpy='$d_safebcpy'
+d_safemcpy='$d_safemcpy'
+d_sanemcmp='$d_sanemcmp'
+d_sched_yield='$d_sched_yield'
+d_seekdir='$d_seekdir'
+d_select='$d_select'
+d_sem='$d_sem'
+d_semctl='$d_semctl'
+d_semctl_semid_ds='$d_semctl_semid_ds'
+d_semctl_semun='$d_semctl_semun'
+d_semget='$d_semget'
+d_semop='$d_semop'
+d_setegid='$d_setegid'
+d_seteuid='$d_seteuid'
+d_setgrent='$d_setgrent'
+d_setgrps='$d_setgrps'
+d_sethent='$d_sethent'
+d_setlinebuf='$d_setlinebuf'
+d_setlocale='$d_setlocale'
+d_setnent='$d_setnent'
+d_setpent='$d_setpent'
+d_setpgid='$d_setpgid'
+d_setpgrp2='$d_setpgrp2'
+d_setpgrp='$d_setpgrp'
+d_setprior='$d_setprior'
+d_setpwent='$d_setpwent'
+d_setregid='$d_setregid'
+d_setresgid='$d_setresgid'
+d_setresuid='$d_setresuid'
+d_setreuid='$d_setreuid'
+d_setrgid='$d_setrgid'
+d_setruid='$d_setruid'
+d_setsent='$d_setsent'
+d_setsid='$d_setsid'
+d_setvbuf='$d_setvbuf'
+d_sfio='$d_sfio'
+d_shm='$d_shm'
+d_shmat='$d_shmat'
+d_shmatprototype='$d_shmatprototype'
+d_shmctl='$d_shmctl'
+d_shmdt='$d_shmdt'
+d_shmget='$d_shmget'
+d_sigaction='$d_sigaction'
+d_sigsetjmp='$d_sigsetjmp'
+d_socket='$d_socket'
+d_sockpair='$d_sockpair'
+d_statblks='$d_statblks'
+d_stdio_cnt_lval='$d_stdio_cnt_lval'
+d_stdio_ptr_lval='$d_stdio_ptr_lval'
+d_stdiobase='$d_stdiobase'
+d_stdstdio='$d_stdstdio'
+d_strchr='$d_strchr'
+d_strcoll='$d_strcoll'
+d_strctcpy='$d_strctcpy'
+d_strerrm='$d_strerrm'
+d_strerror='$d_strerror'
+d_strtod='$d_strtod'
+d_strtol='$d_strtol'
+d_strtoul='$d_strtoul'
+d_strxfrm='$d_strxfrm'
+d_suidsafe='$d_suidsafe'
+d_symlink='$d_symlink'
+d_syscall='$d_syscall'
+d_sysconf='$d_sysconf'
+d_sysernlst='$d_sysernlst'
+d_syserrlst='$d_syserrlst'
+d_system='$d_system'
+d_tcgetpgrp='$d_tcgetpgrp'
+d_tcsetpgrp='$d_tcsetpgrp'
+d_telldir='$d_telldir'
+d_time='$d_time'
+d_times='$d_times'
+d_truncate='$d_truncate'
+d_tzname='$d_tzname'
+d_umask='$d_umask'
+d_uname='$d_uname'
+d_union_semun='$d_union_semun'
+d_vfork='$d_vfork'
+d_void_closedir='$d_void_closedir'
+d_voidsig='$d_voidsig'
+d_voidtty='$d_voidtty'
+d_volatile='$d_volatile'
+d_vprintf='$d_vprintf'
+d_wait4='$d_wait4'
+d_waitpid='$d_waitpid'
+d_wcstombs='$d_wcstombs'
+d_wctomb='$d_wctomb'
+d_xenix='$d_xenix'
+date='$date'
+db_hashtype='$db_hashtype'
+db_prefixtype='$db_prefixtype'
+defvoidused='$defvoidused'
+direntrytype='$direntrytype'
+dlext='$dlext'
+dlsrc='$dlsrc'
+doublesize='$doublesize'
+dynamic_ext='$dynamic_ext'
+eagain='$eagain'
+ebcdic='$ebcdic'
+echo='$echo'
+egrep='$egrep'
+emacs='$emacs'
+eunicefix='$eunicefix'
+exe_ext='$exe_ext'
+expr='$expr'
+extensions='$extensions'
+find='$find'
+firstmakefile='$firstmakefile'
+flex='$flex'
+fpostype='$fpostype'
+freetype='$freetype'
+full_csh='$full_csh'
+full_sed='$full_sed'
+gccversion='$gccversion'
+gidtype='$gidtype'
+glibpth='$glibpth'
+grep='$grep'
+groupcat='$groupcat'
+groupstype='$groupstype'
+gzip='$gzip'
+h_fcntl='$h_fcntl'
+h_sysfile='$h_sysfile'
+hint='$hint'
+hostcat='$hostcat'
+huge='$huge'
+i_arpainet='$i_arpainet'
+i_bsdioctl='$i_bsdioctl'
+i_db='$i_db'
+i_dbm='$i_dbm'
+i_dirent='$i_dirent'
+i_dld='$i_dld'
+i_dlfcn='$i_dlfcn'
+i_fcntl='$i_fcntl'
+i_float='$i_float'
+i_gdbm='$i_gdbm'
+i_grp='$i_grp'
+i_limits='$i_limits'
+i_locale='$i_locale'
+i_malloc='$i_malloc'
+i_math='$i_math'
+i_memory='$i_memory'
+i_ndbm='$i_ndbm'
+i_netdb='$i_netdb'
+i_neterrno='$i_neterrno'
+i_niin='$i_niin'
+i_pwd='$i_pwd'
+i_rpcsvcdbm='$i_rpcsvcdbm'
+i_sfio='$i_sfio'
+i_sgtty='$i_sgtty'
+i_stdarg='$i_stdarg'
+i_stddef='$i_stddef'
+i_stdlib='$i_stdlib'
+i_string='$i_string'
+i_sysdir='$i_sysdir'
+i_sysfile='$i_sysfile'
+i_sysfilio='$i_sysfilio'
+i_sysin='$i_sysin'
+i_sysioctl='$i_sysioctl'
+i_sysndir='$i_sysndir'
+i_sysparam='$i_sysparam'
+i_sysresrc='$i_sysresrc'
+i_sysselct='$i_sysselct'
+i_syssockio='$i_syssockio'
+i_sysstat='$i_sysstat'
+i_systime='$i_systime'
+i_systimek='$i_systimek'
+i_systimes='$i_systimes'
+i_systypes='$i_systypes'
+i_sysun='$i_sysun'
+i_syswait='$i_syswait'
+i_termio='$i_termio'
+i_termios='$i_termios'
+i_time='$i_time'
+i_unistd='$i_unistd'
+i_utime='$i_utime'
+i_values='$i_values'
+i_varargs='$i_varargs'
+i_varhdr='$i_varhdr'
+i_vfork='$i_vfork'
+incpath='$incpath'
+inews='$inews'
+installarchlib='$installarchlib'
+installbin='$installbin'
+installman1dir='$installman1dir'
+installman3dir='$installman3dir'
+installprivlib='$installprivlib'
+installscript='$installscript'
+installsitearch='$installsitearch'
+installsitelib='$installsitelib'
+intsize='$intsize'
+known_extensions='$known_extensions'
+ksh='$ksh'
+large='$large'
+ld='$ld'
+lddlflags='$lddlflags'
+ldflags='$ldflags'
+less='$less'
+lib_ext='$lib_ext'
+libc='$libc'
+libperl='$libperl'
+libpth='$libpth'
+libs='$libs'
+libswanted='$libswanted'
+line='$line'
+lint='$lint'
+lkflags='$lkflags'
+ln='$ln'
+lns='$lns'
+locincpth='$locincpth'
+loclibpth='$loclibpth'
+longdblsize='$longdblsize'
+longlongsize='$longlongsize'
+longsize='$longsize'
+lp='$lp'
+lpr='$lpr'
+ls='$ls'
+lseektype='$lseektype'
+mail='$mail'
+mailx='$mailx'
+make='$make'
+make_set_make='$make_set_make'
+mallocobj='$mallocobj'
+mallocsrc='$mallocsrc'
+malloctype='$malloctype'
+man1dir='$man1dir'
+man1direxp='$man1direxp'
+man1ext='$man1ext'
+man3dir='$man3dir'
+man3direxp='$man3direxp'
+man3ext='$man3ext'
+medium='$medium'
+mips='$mips'
+mips_type='$mips_type'
+mkdir='$mkdir'
+models='$models'
+modetype='$modetype'
+more='$more'
+mv='$mv'
+myarchname='$myarchname'
+mydomain='$mydomain'
+myhostname='$myhostname'
+myuname='$myuname'
+n='$n'
+netdb_hlen_type='$netdb_hlen_type'
+netdb_host_type='$netdb_host_type'
+netdb_name_type='$netdb_name_type'
+netdb_net_type='$netdb_net_type'
+nm='$nm'
+nm_opt='$nm_opt'
+nm_so_opt='$nm_so_opt'
+nonxs_ext='$nonxs_ext'
+nroff='$nroff'
+o_nonblock='$o_nonblock'
+obj_ext='$obj_ext'
+optimize='$optimize'
+orderlib='$orderlib'
+osname='$osname'
+osvers='$osvers'
+package='$package'
+pager='$pager'
+passcat='$passcat'
+patchlevel='$patchlevel'
+path_sep='$path_sep'
+perl='$perl'
+perladmin='$perladmin'
+perlpath='$perlpath'
+pg='$pg'
+phostname='$phostname'
+pidtype='$pidtype'
+plibpth='$plibpth'
+pmake='$pmake'
+pr='$pr'
+prefix='$prefix'
+prefixexp='$prefixexp'
+privlib='$privlib'
+privlibexp='$privlibexp'
+prototype='$prototype'
+ptrsize='$ptrsize'
+randbits='$randbits'
+ranlib='$ranlib'
+rd_nodata='$rd_nodata'
+rm='$rm'
+rmail='$rmail'
+runnm='$runnm'
+scriptdir='$scriptdir'
+scriptdirexp='$scriptdirexp'
+sed='$sed'
+selecttype='$selecttype'
+sendmail='$sendmail'
+sh='$sh'
+shar='$shar'
+sharpbang='$sharpbang'
+shmattype='$shmattype'
+shortsize='$shortsize'
+shrpenv='$shrpenv'
+shsharp='$shsharp'
+sig_name='$sig_name'
+sig_name_init='$sig_name_init'
+sig_num='$sig_num'
+signal_t='$signal_t'
+sitearch='$sitearch'
+sitearchexp='$sitearchexp'
+sitelib='$sitelib'
+sitelibexp='$sitelibexp'
+sizetype='$sizetype'
+sleep='$sleep'
+smail='$smail'
+small='$small'
+so='$so'
+sockethdr='$sockethdr'
+socketlib='$socketlib'
+sort='$sort'
+spackage='$spackage'
+spitshell='$spitshell'
+split='$split'
+src='$src'
+ssizetype='$ssizetype'
+startperl='$startperl'
+startsh='$startsh'
+static_ext='$static_ext'
+stdchar='$stdchar'
+stdio_base='$stdio_base'
+stdio_bufsiz='$stdio_bufsiz'
+stdio_cnt='$stdio_cnt'
+stdio_filbuf='$stdio_filbuf'
+stdio_ptr='$stdio_ptr'
+strings='$strings'
+submit='$submit'
+subversion='$subversion'
+sysman='$sysman'
+tail='$tail'
+tar='$tar'
+tbl='$tbl'
+tee='$tee'
+test='$test'
+timeincl='$timeincl'
+timetype='$timetype'
+touch='$touch'
+tr='$tr'
+trnl='$trnl'
+troff='$troff'
+uidtype='$uidtype'
+uname='$uname'
+uniq='$uniq'
+usedl='$usedl'
+usemymalloc='$usemymalloc'
+usenm='$usenm'
+useopcode='$useopcode'
+useperlio='$useperlio'
+useposix='$useposix'
+usesfio='$usesfio'
+useshrplib='$useshrplib'
+usethreads='$usethreads'
+usevfork='$usevfork'
+usrinc='$usrinc'
+uuname='$uuname'
+version='$version'
+vi='$vi'
+voidflags='$voidflags'
+xlibpth='$xlibpth'
+zcat='$zcat'
+zip='$zip'
+EOT
+
+: Add in command line options if available
+$test -f UU/cmdline.opt && $cat UU/cmdline.opt >> config.sh
+
+: add special variables
+$test -f $src/patchlevel.h && \
+awk '/^#define/ {printf "%s=%s\n",$2,$3}' $src/patchlevel.h >>config.sh
+echo "CONFIG=true" >>config.sh
+
+: propagate old symbols
+if $test -f UU/config.sh; then
+ <UU/config.sh sort | uniq >UU/oldconfig.sh
+ sed -n 's/^\([a-zA-Z_0-9]*\)=.*/\1/p' config.sh config.sh UU/oldconfig.sh |\
+ sort | uniq -u >UU/oldsyms
+ set X `cat UU/oldsyms`
+ shift
+ case $# in
+ 0) ;;
+ *)
+ cat <<EOM
+Hmm...You had some extra variables I don't know about...I'll try to keep 'em...
+EOM
+ echo "# Variables propagated from previous config.sh file." >>config.sh
+ for sym in `cat UU/oldsyms`; do
+ echo " Propagating $hint variable "'$'"$sym..."
+ eval 'tmp="$'"${sym}"'"'
+ echo "$tmp" | \
+ sed -e "s/'/'\"'\"'/g" -e "s/^/$sym='/" -e "s/$/'/" >>config.sh
+ done
+ ;;
+ esac
+fi
+
+: Finish up by extracting the .SH files
+case "$alldone" in
+exit)
+ $rm -rf UU
+ echo "Done."
+ exit 0
+ ;;
+cont)
+ ;;
+'')
+ dflt=''
+ nostick=true
+ $cat <<EOM
+
+If you'd like to make any changes to the config.sh file before I begin
+to configure things, do it as a shell escape now (e.g. !vi config.sh).
+
+EOM
+ rp="Press return or use a shell escape to edit config.sh:"
+ . UU/myread
+ nostick=''
+ case "$ans" in
+ '') ;;
+ *) : in case they cannot read
+ sh 1>&4 -c "$ans";;
+ esac
+ ;;
+esac
+
+: if this fails, just run all the .SH files by hand
+. ./config.sh
+
+case "$ebcdic" in
+$define)
+ xxx=''
+ echo "This is an EBCDIC system, checking if any parser files need regenerating." >&4
+ rm -f y.tab.c y.tab.h
+ yacc -d perly.y >/dev/null 2>&1
+ if cmp -s y.tab.c perly.c; then
+ rm -f y.tab.c
+ else
+ echo "perly.y -> perly.c" >&4
+ mv -f y.tab.c perly.c
+ chmod u+w perly.c
+ sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \
+ -e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c
+ xxx="$xxx perly.c"
+ fi
+ if cmp -s y.tab.h perly.h; then
+ rm -f y.tab.h
+ else
+ echo "perly.y -> perly.h" >&4
+ mv -f y.tab.h perly.h
+ xxx="$xxx perly.h"
+ fi
+ echo "x2p/a2p.y" >&4
+ cd x2p
+ rm -f y.tab.c
+ yacc a2p.y >/dev/null 2>&1
+ if cmp -s y.tab.c a2p.c
+ then
+ rm -f y.tab.c
+ else
+ echo "a2p.y -> a2p.c" >&4
+ mv -f y.tab.c a2p.c
+ chmod u+w a2p.c
+ sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \
+ -e 's/y\.tab/a2p/g' a2p.c >a2p.tmp && mv a2p.tmp a2p.c
+ xxx="$xxx a2p.c"
+ fi
+ cd ..
+ case "$xxx" in
+ '') echo "No parser files were regenerated. That's okay." >&4 ;;
+ esac
+ ;;
+esac
+
+echo " "
+exec 1>&4
+. ./UU/extract
+
+if $contains '^depend:' [Mm]akefile >/dev/null 2>&1; then
+ dflt=y
+ case "$silent" in
+ true) ;;
+ *)
+ $cat <<EOM
+
+Now you need to generate make dependencies by running "make depend".
+You might prefer to run it in background: "make depend > makedepend.out &"
+It can take a while, so you might not want to run it right now.
+
+EOM
+ ;;
+ esac
+ rp="Run make depend now?"
+ . UU/myread
+ case "$ans" in
+ y*)
+ make depend && echo "Now you must run a make."
+ ;;
+ *)
+ echo "You must run 'make depend' then 'make'."
+ ;;
+ esac
+elif test -f [Mm]akefile; then
+ echo " "
+ echo "Now you must run a make."
+else
+ echo "Done."
+fi
+
+if $test -f Policy.sh; then
+ $cat <<EOM
+
+If you compile $package on a different machine or from a different object
+directory, copy the Policy.sh file from this object directory to the
+new one before you run Configure -- this will help you with most of
+the policy defaults.
+
+EOM
+fi
+if $test -f config.msg; then
+ echo "Hmm. I also noted the following information while running:"
+ echo " "
+ $cat config.msg >&4
+ $rm -f config.msg
+fi
+$rm -f kit*isdone ark*isdone
+$rm -rf UU
+
+: End of Configure
+
diff --git a/contrib/perl5/Copying b/contrib/perl5/Copying
new file mode 100644
index 000000000000..3c68f02bb420
--- /dev/null
+++ b/contrib/perl5/Copying
@@ -0,0 +1,248 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 675 Mass Ave, Cambridge, MA 02139, USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 1, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
diff --git a/contrib/perl5/EXTERN.h b/contrib/perl5/EXTERN.h
new file mode 100644
index 000000000000..19f6db896da4
--- /dev/null
+++ b/contrib/perl5/EXTERN.h
@@ -0,0 +1,53 @@
+/* EXTERN.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * EXT designates a global var which is defined in perl.h
+ * dEXT designates a global var which is defined in another
+ * file, so we can't count on finding it in perl.h
+ * (this practice should be avoided).
+ */
+#undef EXT
+#undef dEXT
+#undef EXTCONST
+#undef dEXTCONST
+#if defined(VMS) && !defined(__GNUC__)
+ /* Suppress portability warnings from DECC for VMS-specific extensions */
+# ifdef __DECC
+# pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT)
+# endif
+# define EXT globalref
+# define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare
+# define EXTCONST globalref
+# define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
+#else
+# if defined(WIN32) && !defined(PERL_STATIC_SYMS) && !defined(__GNUC__) && !defined(PERL_OBJECT)
+# ifdef PERLDLL
+# define EXT extern __declspec(dllexport)
+# define dEXT
+# define EXTCONST extern __declspec(dllexport) const
+# define dEXTCONST const
+# else
+# define EXT extern __declspec(dllimport)
+# define dEXT
+# define EXTCONST extern __declspec(dllimport) const
+# define dEXTCONST const
+# endif
+# else
+# define EXT extern
+# define dEXT
+# define EXTCONST extern const
+# define dEXTCONST const
+# endif
+#endif
+
+#undef INIT
+#define INIT(x)
+
+#undef DOINIT
diff --git a/contrib/perl5/INSTALL b/contrib/perl5/INSTALL
new file mode 100644
index 000000000000..a892e7deab67
--- /dev/null
+++ b/contrib/perl5/INSTALL
@@ -0,0 +1,1599 @@
+=head1 NAME
+
+Install - Build and Installation guide for perl5.
+
+=head1 SYNOPSIS
+
+The basic steps to build and install perl5 on a Unix system are:
+
+ rm -f config.sh Policy.sh
+ sh Configure
+ make
+ make test
+ make install
+
+ # You may also wish to add these:
+ (cd /usr/include && h2ph *.h sys/*.h)
+ (installhtml --help)
+ (cd pod && make tex && <process the latex files>)
+
+Each of these is explained in further detail below.
+
+For information on non-Unix systems, see the section on
+L<"Porting information"> below.
+
+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.
+
+=head1 DESCRIPTION
+
+This document is written in pod format as an easy way to indicate its
+structure. The pod format is described in pod/perlpod.pod, but you can
+read it as is with any pager or editor. Headings and items are marked
+by lines beginning with '='. The other mark-up used is
+
+ B<text> embolden text, used for switches, programs or commands
+ C<code> literal code
+ L<name> A link (cross reference) to name
+
+You should probably at least skim through this entire document before
+proceeding.
+
+If you're building Perl on a non-Unix system, you should also read
+the README file specific to your operating system, since this may
+provide additional or different instructions for building Perl.
+
+If there is a hint file for your system (in the hints/ directory) you
+should also read that hint file for specific information for your
+system. (Unixware users should use the svr4.sh hint file.)
+
+=head1 WARNING: This version is not binary compatible with Perl 5.004.
+
+Starting with Perl 5.004_50 there were many deep and far-reaching changes
+to the language internals. If you have dynamically loaded extensions
+that you built under perl 5.003 or 5.004, you can continue to use them
+with 5.004, but you will need to rebuild and reinstall those extensions
+to use them 5.005. See the discussions below on
+L<"Coexistence with earlier versions of perl5"> and
+L<"Upgrading from 5.004 to 5.005"> for more details.
+
+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.
+
+=head1 Space Requirements
+
+The complete perl5 source tree takes up about 10 MB of disk space. The
+complete tree after completing make takes roughly 20 MB, though the
+actual total is likely to be quite system-dependent. The installation
+directories need something on the order of 10 MB, though again that
+value is system-dependent.
+
+=head1 Start with a Fresh Distribution
+
+If you have built perl before, you should clean out the build directory
+with the command
+
+ make distclean
+
+or
+
+ make realclean
+
+The only difference between the two is that make distclean also removes
+your old config.sh and Policy.sh files.
+
+The results of a Configure run are stored in the config.sh and Policy.sh
+files. If you are upgrading from a previous version of perl, or if you
+change systems or compilers or make other significant changes, or if
+you are experiencing difficulties building perl, you should probably
+not re-use your old config.sh. Simply remove it or rename it, e.g.
+
+ mv config.sh config.sh.old
+
+If you wish to use your old config.sh, be especially attentive to the
+version and architecture-specific questions and answers. For example,
+the default directory for architecture-dependent library modules
+includes the version name. By default, Configure will reuse your old
+name (e.g. /opt/perl/lib/i86pc-solaris/5.003) even if you're running
+Configure for a different version, e.g. 5.004. Yes, Configure should
+probably check and correct for this, but it doesn't, presently.
+Similarly, if you used a shared libperl.so (see below) with version
+numbers, you will probably want to adjust them as well.
+
+Also, be careful to check your architecture name. Some Linux systems
+(such as Debian) use i386, while others may use i486, i586, or i686.
+If you pick up a precompiled binary, it might not use the same name.
+
+In short, if you wish to use your old config.sh, I recommend running
+Configure interactively rather than blindly accepting the defaults.
+
+If your reason to reuse your old config.sh is to save your
+particular installation choices, then you can probably achieve the
+same effect by using the new Policy.sh file. See the section on
+L<"Site-wide Policy settings"> below.
+
+=head1 Run Configure
+
+Configure will figure out various things about your system. Some
+things Configure will figure out for itself, other things it will ask
+you about. To accept the default, just press RETURN. The default
+is almost always okay. At any Configure prompt, you can type &-d
+and Configure will use the defaults from then on.
+
+After it runs, Configure will perform variable substitution on all the
+*.SH files and offer to run make depend.
+
+Configure supports a number of useful options. Run B<Configure -h> to
+get a listing. See the Porting/Glossary file for a complete list of
+Configure variables you can set and their definitions.
+
+To compile with gcc, for example, you should run
+
+ sh Configure -Dcc=gcc
+
+This is the preferred way to specify gcc (or another alternative
+compiler) so that the hints files can set appropriate defaults.
+
+If you want to use your old config.sh but override some of the items
+with command line options, you need to use B<Configure -O>.
+
+By default, for most systems, perl will be installed in
+/usr/local/{bin, lib, man}. You can specify a different 'prefix' for
+the default installation directory, when Configure prompts you or by
+using the Configure command line option -Dprefix='/some/directory',
+e.g.
+
+ sh Configure -Dprefix=/opt/perl
+
+If your prefix contains the string "perl", then the directories
+are simplified. For example, if you use prefix=/opt/perl,
+then Configure will suggest /opt/perl/lib instead of
+/opt/perl/lib/perl5/.
+
+NOTE: You must not specify an installation directory that is below
+your perl source directory. If you do, installperl will attempt
+infinite recursion.
+
+It may seem obvious to say, but Perl is useful only when users can
+easily find it. It's often a good idea to have both /usr/bin/perl and
+/usr/local/bin/perl be symlinks to the actual binary. Be especially
+careful, however, of overwriting a version of perl supplied by your
+vendor. In any case, system administrators are strongly encouraged to
+put (symlinks to) perl and its accompanying utilities, such as perldoc,
+into a directory typically found along a user's PATH, or in another
+obvious and convenient place.
+
+By default, Configure will compile perl to use dynamic loading if
+your system supports it. If you want to force perl to be compiled
+statically, you can either choose this when Configure prompts you or
+you can use the Configure command line option -Uusedl.
+
+If you are willing to accept all the defaults, and you want terse
+output, you can run
+
+ sh Configure -des
+
+For my Solaris system, I usually use
+
+ sh Configure -Dprefix=/opt/perl -Doptimize='-xpentium -xO4' -des
+
+=head2 GNU-style configure
+
+If you prefer the GNU-style configure command line interface, you can
+use the supplied configure.gnu command, e.g.
+
+ CC=gcc ./configure.gnu
+
+The configure.gnu script emulates a few of the more common configure
+options. Try
+
+ ./configure.gnu --help
+
+for a listing.
+
+Cross compiling is not supported.
+
+(The file is called configure.gnu to avoid problems on systems
+that would not distinguish the files "Configure" and "configure".)
+
+=head2 Extensions
+
+By default, Configure will offer to build every extension which appears
+to be supported. For example, Configure will offer to build GDBM_File
+only if it is able to find the gdbm library. (See examples below.)
+B, DynaLoader, Fcntl, IO, and attrs are always built by default.
+Configure does not contain code to test for POSIX compliance, so POSIX
+is always built by default as well. If you wish to skip POSIX, you can
+set the Configure variable useposix=false either in a hint file or from
+the Configure command line. Similarly, the Opcode extension is always
+built by default, but you can skip it by setting the Configure variable
+useopcode=false either in a hint file for from the command line.
+
+You can learn more about each of these extensions by consulting the
+documentation in the individual .pm modules, located under the
+ext/ subdirectory.
+
+Even if you do not have dynamic loading, you must still build the
+DynaLoader extension; you should just build the stub dl_none.xs
+version. (Configure will suggest this as the default.)
+
+In summary, here are the Configure command-line variables you can set
+to turn off each extension:
+
+ B (Always included by default)
+ DB_File i_db
+ DynaLoader (Must always be included as a static extension)
+ Fcntl (Always included by default)
+ GDBM_File i_gdbm
+ IO (Always included by default)
+ NDBM_File i_ndbm
+ ODBM_File i_dbm
+ POSIX useposix
+ SDBM_File (Always included by default)
+ Opcode useopcode
+ Socket d_socket
+ Threads usethreads
+ attrs (Always included by default)
+
+Thus to skip the NDBM_File extension, you can use
+
+ sh Configure -Ui_ndbm
+
+Again, this is taken care of automatically if you don't have the ndbm
+library.
+
+Of course, you may always run Configure interactively and select only
+the extensions you want.
+
+Note: The DB_File module will only work with version 1.x of Berkeley
+DB or newer releases of version 2. Configure will automatically detect
+this for you and refuse to try to build DB_File with version 2.
+
+If you re-use your old config.sh but change your system (e.g. by
+adding libgdbm) Configure will still offer your old choices of extensions
+for the default answer, but it will also point out the discrepancy to
+you.
+
+Finally, if you have dynamic loading (most modern Unix systems do)
+remember that these extensions do not increase the size of your perl
+executable, nor do they impact start-up time, so you probably might as
+well build all the ones that will work on your system.
+
+=head2 Including locally-installed libraries
+
+Perl5 comes with interfaces to number of database extensions, including
+dbm, ndbm, gdbm, and Berkeley db. For each extension, if
+Configure can find the appropriate header files and libraries, it will
+automatically include that extension. The gdbm and db libraries
+are not included with perl. See the library documentation for
+how to obtain the libraries.
+
+Note: If your database header (.h) files are not in a
+directory normally searched by your C compiler, then you will need to
+include the appropriate -I/your/directory option when prompted by
+Configure. If your database library (.a) files are not in a directory
+normally searched by your C compiler and linker, then you will need to
+include the appropriate -L/your/directory option when prompted by
+Configure. See the examples below.
+
+=head2 Examples
+
+=over 4
+
+=item gdbm in /usr/local
+
+Suppose you have gdbm and want Configure to find it and build the
+GDBM_File extension. This examples assumes you have gdbm.h
+installed in /usr/local/include/gdbm.h and libgdbm.a installed in
+/usr/local/lib/libgdbm.a. Configure should figure all the
+necessary steps out automatically.
+
+Specifically, when Configure prompts you for flags for
+your C compiler, you should include -I/usr/local/include.
+
+When Configure prompts you for linker flags, you should include
+-L/usr/local/lib.
+
+If you are using dynamic loading, then when Configure prompts you for
+linker flags for dynamic loading, you should again include
+-L/usr/local/lib.
+
+Again, this should all happen automatically. If you want to accept the
+defaults for all the questions and have Configure print out only terse
+messages, then you can just run
+
+ sh Configure -des
+
+and Configure should include the GDBM_File extension automatically.
+
+This should actually work if you have gdbm installed in any of
+(/usr/local, /opt/local, /usr/gnu, /opt/gnu, /usr/GNU, or /opt/GNU).
+
+=item gdbm in /usr/you
+
+Suppose you have gdbm installed in some place other than /usr/local/,
+but you still want Configure to find it. To be specific, assume you
+have /usr/you/include/gdbm.h and /usr/you/lib/libgdbm.a. You
+still have to add -I/usr/you/include to cc flags, but you have to take
+an extra step to help Configure find libgdbm.a. Specifically, when
+Configure prompts you for library directories, you have to add
+/usr/you/lib to the list.
+
+It is possible to specify this from the command line too (all on one
+line):
+
+ sh Configure -des \
+ -Dlocincpth="/usr/you/include" \
+ -Dloclibpth="/usr/you/lib"
+
+locincpth is a space-separated list of include directories to search.
+Configure will automatically add the appropriate -I directives.
+
+loclibpth is a space-separated list of library directories to search.
+Configure will automatically add the appropriate -L directives. If
+you have some libraries under /usr/local/ and others under
+/usr/you, then you have to include both, namely
+
+ sh Configure -des \
+ -Dlocincpth="/usr/you/include /usr/local/include" \
+ -Dloclibpth="/usr/you/lib /usr/local/lib"
+
+=back
+
+=head2 Installation Directories
+
+The installation directories can all be changed by answering the
+appropriate questions in Configure. For convenience, all the
+installation questions are near the beginning of Configure.
+
+I highly recommend running Configure interactively to be sure it puts
+everything where you want it. At any point during the Configure
+process, you can answer a question with &-d and Configure
+will use the defaults from then on.
+
+By default, Configure will use the following directories for library files
+for 5.005 (archname is a string like sun4-sunos, determined by Configure).
+
+ Configure variable Default value
+ $archlib /usr/local/lib/perl5/5.005/archname
+ $privlib /usr/local/lib/perl5/5.005
+ $sitearch /usr/local/lib/perl5/site_perl/5.005/archname
+ $sitelib /usr/local/lib/perl5/site_perl/5.005
+
+Some users prefer to append a "/share" to $privlib and $sitelib
+to emphasize that those directories can be shared among different
+architectures.
+
+By default, Configure will use the following directories for manual pages:
+
+ Configure variable Default value
+ $man1dir /usr/local/man/man1
+ $man3dir /usr/local/lib/perl5/man/man3
+
+(Actually, Configure recognizes the SVR3-style
+/usr/local/man/l_man/man1 directories, if present, and uses those
+instead.)
+
+The module man pages are stuck in that strange spot so that
+they don't collide with other man pages stored in /usr/local/man/man3,
+and so that Perl's man pages don't hide system man pages. On some
+systems, B<man less> would end up calling up Perl's less.pm module man
+page, rather than the less program. (This default location will likely
+change to /usr/local/man/man3 in a future release of perl.)
+
+Note: Many users prefer to store the module man pages in
+/usr/local/man/man3. You can do this from the command line with
+
+ sh Configure -Dman3dir=/usr/local/man/man3
+
+Some users also prefer to use a .3pm suffix. You can do that with
+
+ sh Configure -Dman3ext=3pm
+
+If you specify a prefix that contains the string "perl", then the
+directory structure is simplified. For example, if you Configure with
+-Dprefix=/opt/perl, then the defaults for 5.005 are
+
+ Configure variable Default value
+ $archlib /opt/perl/lib/5.005/archname
+ $privlib /opt/perl/lib/5.005
+ $sitearch /opt/perl/lib/site_perl/5.005/archname
+ $sitelib /opt/perl/lib/site_perl/5.005
+
+ $man1dir /opt/perl/man/man1
+ $man3dir /opt/perl/man/man3
+
+The perl executable will search the libraries in the order given
+above.
+
+The directories under site_perl are empty, but are intended to be used
+for installing local or site-wide extensions. Perl will automatically
+look in these directories.
+
+In order to support using things like #!/usr/local/bin/perl5.005 after
+a later version is released, architecture-dependent libraries are
+stored in a version-specific directory, such as
+/usr/local/lib/perl5/archname/5.005/.
+
+Further details about the installation directories, maintenance and
+development subversions, and about supporting multiple versions are
+discussed in L<"Coexistence with earlier versions of perl5"> below.
+
+Again, these are just the defaults, and can be changed as you run
+Configure.
+
+=head2 Changing the installation directory
+
+Configure distinguishes between the directory in which perl (and its
+associated files) should be installed and the directory in which it
+will eventually reside. For most sites, these two are the same; for
+sites that use AFS, this distinction is handled automatically.
+However, sites that use software such as depot to manage software
+packages may also wish to install perl into a different directory and
+use that management software to move perl to its final destination.
+This section describes how to do this. Someday, Configure may support
+an option -Dinstallprefix=/foo to simplify this.
+
+Suppose you want to install perl under the /tmp/perl5 directory. You
+can edit config.sh and change all the install* variables to point to
+/tmp/perl5 instead of /usr/local/wherever. Or, you can automate this
+process by placing the following lines in a file config.over before you
+run Configure (replace /tmp/perl5 by a directory of your choice):
+
+ installprefix=/tmp/perl5
+ test -d $installprefix || mkdir $installprefix
+ test -d $installprefix/bin || mkdir $installprefix/bin
+ installarchlib=`echo $installarchlib | sed "s!$prefix!$installprefix!"`
+ installbin=`echo $installbin | sed "s!$prefix!$installprefix!"`
+ installman1dir=`echo $installman1dir | sed "s!$prefix!$installprefix!"`
+ installman3dir=`echo $installman3dir | sed "s!$prefix!$installprefix!"`
+ installprivlib=`echo $installprivlib | sed "s!$prefix!$installprefix!"`
+ installscript=`echo $installscript | sed "s!$prefix!$installprefix!"`
+ installsitelib=`echo $installsitelib | sed "s!$prefix!$installprefix!"`
+ installsitearch=`echo $installsitearch | sed "s!$prefix!$installprefix!"`
+
+Then, you can Configure and install in the usual way:
+
+ sh Configure -des
+ make
+ make test
+ make install
+
+Beware, though, that if you go to try to install new add-on
+extensions, they too will get installed in under '/tmp/perl5' if you
+follow this example. The next section shows one way of dealing with
+that problem.
+
+=head2 Creating an installable tar archive
+
+If you need to install perl on many identical systems, it is
+convenient to compile it once and create an archive that can be
+installed on multiple systems. Here's one way to do that:
+
+ # Set up config.over to install perl into a different directory,
+ # e.g. /tmp/perl5 (see previous part).
+ sh Configure -des
+ make
+ make test
+ make install
+ cd /tmp/perl5
+ # Edit $archlib/Config.pm to change all the
+ # install* variables back to reflect where everything will
+ # really be installed.
+ # Edit any of the scripts in $scriptdir to have the correct
+ # #!/wherever/perl line.
+ tar cvf ../perl5-archive.tar .
+ # Then, on each machine where you want to install perl,
+ cd /usr/local # Or wherever you specified as $prefix
+ tar xvf perl5-archive.tar
+
+=head2 Site-wide Policy settings
+
+After Configure runs, it stores a number of common site-wide "policy"
+answers (such as installation directories and the local perl contact
+person) in the Policy.sh file. If you want to build perl on another
+system using the same policy defaults, simply copy the Policy.sh file
+to the new system and Configure will use it along with the appropriate
+hint file for your system.
+
+Alternatively, if you wish to change some or all of those policy
+answers, you should
+
+ rm -f Policy.sh
+
+to ensure that Configure doesn't re-use them.
+
+Further information is in the Policy_sh.SH file itself.
+
+=head2 Configure-time Options
+
+There are several different ways to Configure and build perl for your
+system. For most users, the defaults are sensible and will work.
+Some users, however, may wish to further customize perl. Here are
+some of the main things you can change.
+
+=head2 Threads
+
+On some platforms, perl5.005 can be compiled to use threads. To
+enable this, read the file README.threads, and then try
+
+ sh Configure -Dusethreads
+
+Currently, you need to specify -Dusethreads on the Configure command
+line so that the hint files can make appropriate adjustments.
+
+The default is to compile without thread support.
+
+=head2 Selecting File IO mechanisms
+
+Previous versions of perl used the standard IO mechanisms as defined in
+stdio.h. Versions 5.003_02 and later of perl allow alternate IO
+mechanisms via a "PerlIO" abstraction, but the stdio mechanism is still
+the default and is the only supported mechanism.
+
+This PerlIO abstraction can be enabled either on the Configure command
+line with
+
+ sh Configure -Duseperlio
+
+or interactively at the appropriate Configure prompt.
+
+If you choose to use the PerlIO abstraction layer, there are two
+(experimental) possibilities for the underlying IO calls. These have been
+tested to some extent on some platforms, but are not guaranteed to work
+everywhere.
+
+=over 4
+
+=item 1.
+
+AT&T's "sfio". This has superior performance to stdio.h in many
+cases, and is extensible by the use of "discipline" modules. Sfio
+currently only builds on a subset of the UNIX platforms perl supports.
+Because the data structures are completely different from stdio, perl
+extension modules or external libraries may not work. This
+configuration exists to allow these issues to be worked on.
+
+This option requires the 'sfio' package to have been built and installed.
+A (fairly old) version of sfio is in CPAN.
+
+You select this option by
+
+ sh Configure -Duseperlio -Dusesfio
+
+If you have already selected -Duseperlio, and if Configure detects
+that you have sfio, then sfio will be the default suggested by
+Configure.
+
+Note: On some systems, sfio's iffe configuration script fails
+to detect that you have an atexit function (or equivalent).
+Apparently, this is a problem at least for some versions of Linux
+and SunOS 4.
+
+You can test if you have this problem by trying the following shell
+script. (You may have to add some extra cflags and libraries. A
+portable version of this may eventually make its way into Configure.)
+
+ #!/bin/sh
+ cat > try.c <<'EOCP'
+ #include <stdio.h>
+ main() { printf("42\n"); }
+ EOCP
+ cc -o try try.c -lsfio
+ val=`./try`
+ if test X$val = X42; then
+ echo "Your sfio looks ok"
+ else
+ echo "Your sfio has the exit problem."
+ fi
+
+If you have this problem, the fix is to go back to your sfio sources
+and correct iffe's guess about atexit.
+
+There also might be a more recent release of Sfio that fixes your
+problem.
+
+=item 2.
+
+Normal stdio IO, but with all IO going through calls to the PerlIO
+abstraction layer. This configuration can be used to check that perl and
+extension modules have been correctly converted to use the PerlIO
+abstraction.
+
+This configuration should work on all platforms (but might not).
+
+You select this option via:
+
+ sh Configure -Duseperlio -Uusesfio
+
+If you have already selected -Duseperlio, and if Configure does not
+detect sfio, then this will be the default suggested by Configure.
+
+=back
+
+=head2 Building a shared libperl.so Perl library
+
+Currently, for most systems, the main perl executable is built by
+linking the "perl library" libperl.a with perlmain.o, your static
+extensions (usually just DynaLoader.a) and various extra libraries,
+such as -lm.
+
+On some systems that support dynamic loading, it may be possible to
+replace libperl.a with a shared libperl.so. If you anticipate building
+several different perl binaries (e.g. by embedding libperl into
+different programs, or by using the optional compiler extension), then
+you might wish to build a shared libperl.so so that all your binaries
+can share the same library.
+
+The disadvantages are that there may be a significant performance
+penalty associated with the shared libperl.so, and that the overall
+mechanism is still rather fragile with respect to different versions
+and upgrades.
+
+In terms of performance, on my test system (Solaris 2.5_x86) the perl
+test suite took roughly 15% longer to run with the shared libperl.so.
+Your system and typical applications may well give quite different
+results.
+
+The default name for the shared library is typically something like
+libperl.so.3.2 (for Perl 5.003_02) or libperl.so.302 or simply
+libperl.so. Configure tries to guess a sensible naming convention
+based on your C library name. Since the library gets installed in a
+version-specific architecture-dependent directory, the exact name
+isn't very important anyway, as long as your linker is happy.
+
+For some systems (mostly SVR4), building a shared libperl is required
+for dynamic loading to work, and hence is already the default.
+
+You can elect to build a shared libperl by
+
+ sh Configure -Duseshrplib
+
+To actually build perl, you must add the current working directory to your
+LD_LIBRARY_PATH environment variable before running make. You can do
+this with
+
+ LD_LIBRARY_PATH=`pwd`:$LD_LIBRARY_PATH; export LD_LIBRARY_PATH
+
+for Bourne-style shells, or
+
+ setenv LD_LIBRARY_PATH `pwd`
+
+for Csh-style shells. You *MUST* do this before running make.
+Folks running NeXT OPENSTEP must substitute DYLD_LIBRARY_PATH for
+LD_LIBRARY_PATH above.
+
+There is also an potential problem with the shared perl library if you
+want to have more than one "flavor" of the same version of perl (e.g.
+with and without -DDEBUGGING). For example, suppose you build and
+install a standard Perl 5.004 with a shared library. Then, suppose you
+try to build Perl 5.004 with -DDEBUGGING enabled, but everything else
+the same, including all the installation directories. How can you
+ensure that your newly built perl will link with your newly built
+libperl.so.4 rather with the installed libperl.so.4? The answer is
+that you might not be able to. The installation directory is encoded
+in the perl binary with the LD_RUN_PATH environment variable (or
+equivalent ld command-line option). On Solaris, you can override that
+with LD_LIBRARY_PATH; on Linux you can't. On Digital Unix, you can
+override LD_LIBRARY_PATH by setting the _RLD_ROOT environment variable
+to point to the perl build directory.
+
+The only reliable answer is that you should specify a different
+directory for the architecture-dependent library for your -DDEBUGGING
+version of perl. You can do this by changing all the *archlib*
+variables in config.sh, namely archlib, archlib_exp, and
+installarchlib, to point to your new architecture-dependent library.
+
+=head2 Malloc Issues
+
+Perl relies heavily on malloc(3) to grow data structures as needed, so
+perl's performance can be noticeably affected by the performance of
+the malloc function on your system.
+
+The perl source is shipped with a version of malloc that is very fast but
+somewhat wasteful of space. On the other hand, your system's malloc
+function may be a bit slower but also a bit more frugal. However,
+as of 5.004_68, perl's malloc has been optimized for the typical
+requests from perl, so there's a chance that it may be both faster and
+use less memory.
+
+For many uses, speed is probably the most important consideration, so
+the default behavior (for most systems) is to use the malloc supplied
+with perl. However, if you will be running very large applications
+(e.g. Tk or PDL) or if your system already has an excellent malloc, or
+if you are experiencing difficulties with extensions that use
+third-party libraries that call malloc, then you might wish to use
+your system's malloc. (Or, you might wish to explore the malloc flags
+discussed below.)
+
+To build without perl's malloc, you can use the Configure command
+
+ sh Configure -Uusemymalloc
+
+or you can answer 'n' at the appropriate interactive Configure prompt.
+
+=head2 Malloc Performance Flags
+
+If you are using Perl's malloc, you may add one or more of the following
+items to your ccflags config.sh variable to change its behavior. You can
+find out more about these and other flags by reading the commentary near
+the top of the malloc.c source. The defaults should be fine for
+nearly everyone.
+
+=over 4
+
+=item -DNO_FANCY_MALLOC
+
+Undefined by default. Defining it returns malloc to the version used
+in Perl 5.004.
+
+=item -DPLAIN_MALLOC
+
+Undefined by default. Defining it in addition to NO_FANCY_MALLOC returns
+malloc to the version used in Perl version 5.000.
+
+=back
+
+=head2 Building a debugging perl
+
+You can run perl scripts under the perl debugger at any time with
+B<perl -d your_script>. If, however, you want to debug perl itself,
+you probably want to do
+
+ sh Configure -Doptimize='-g'
+
+This will do two independent things: First, it will force compilation
+to use cc -g so that you can use your system's debugger on the
+executable. (Note: Your system may actually require something like
+cc -g2. Check your man pages for cc(1) and also any hint file for your
+system.) Second, it will add -DDEBUGGING to your ccflags variable in
+config.sh so that you can use B<perl -D> to access perl's internal
+state. (Note: Configure will only add -DDEBUGGING by
+default if you are not reusing your old config.sh. If you want to
+reuse your old config.sh, then you can just edit it and change the
+optimize and ccflags variables by hand and then propagate your changes
+as shown in L<"Propagating your changes to config.sh"> below.)
+
+You can actually specify -g and -DDEBUGGING independently, but usually
+it's convenient to have both.
+
+If you are using a shared libperl, see the warnings about multiple
+versions of perl under L<Building a shared libperl.so Perl library>.
+
+=head2 Other Compiler Flags
+
+For most users, all of the Configure defaults are fine. However,
+you can change a number of factors in the way perl is built
+by adding appropriate -D directives to your ccflags variable in
+config.sh.
+
+For example, you can replace the rand() and srand() functions in the
+perl source by any other random number generator by a trick such as the
+following (this should all be on one line):
+
+ sh Configure -Dccflags='-Dmy_rand=random -Dmy_srand=srandom' \
+ -Drandbits=31
+
+or you can use the drand48 family of functions with
+
+ sh Configure -Dccflags='-Dmy_rand=lrand48 -Dmy_srand=srand48' \
+ -Drandbits=31
+
+or by adding the -D flags to your ccflags at the appropriate Configure
+prompt. (Read pp.c to see how this works.)
+
+You should also run Configure interactively to verify that a hint file
+doesn't inadvertently override your ccflags setting. (Hints files
+shouldn't do that, but some might.)
+
+=head2 What if it doesn't work?
+
+=over 4
+
+=item Running Configure Interactively
+
+If Configure runs into trouble, remember that you can always run
+Configure interactively so that you can check (and correct) its
+guesses.
+
+All the installation questions have been moved to the top, so you don't
+have to wait for them. Once you've handled them (and your C compiler and
+flags) you can type &-d at the next Configure prompt and Configure
+will use the defaults from then on.
+
+If you find yourself trying obscure command line incantations and
+config.over tricks, I recommend you run Configure interactively
+instead. You'll probably save yourself time in the long run.
+
+=item Hint files
+
+The perl distribution includes a number of system-specific hints files
+in the hints/ directory. If one of them matches your system, Configure
+will offer to use that hint file.
+
+Several of the hint files contain additional important information.
+If you have any problems, it is a good idea to read the relevant hint file
+for further information. See hints/solaris_2.sh for an extensive example.
+More information about writing good hints is in the hints/README.hints
+file.
+
+=item *** WHOA THERE!!! ***
+
+Occasionally, Configure makes a wrong guess. For example, on SunOS
+4.1.3, Configure incorrectly concludes that tzname[] is in the
+standard C library. The hint file is set up to correct for this. You
+will see a message:
+
+ *** WHOA THERE!!! ***
+ The recommended value for $d_tzname on this machine was "undef"!
+ Keep the recommended value? [y]
+
+You should always keep the recommended value unless, after reading the
+relevant section of the hint file, you are sure you want to try
+overriding it.
+
+If you are re-using an old config.sh, the word "previous" will be
+used instead of "recommended". Again, you will almost always want
+to keep the previous value, unless you have changed something on your
+system.
+
+For example, suppose you have added libgdbm.a to your system
+and you decide to reconfigure perl to use GDBM_File. When you run
+Configure again, you will need to add -lgdbm to the list of libraries.
+Now, Configure will find your gdbm include file and library and will
+issue a message:
+
+ *** WHOA THERE!!! ***
+ The previous value for $i_gdbm on this machine was "undef"!
+ Keep the previous value? [y]
+
+In this case, you do not want to keep the previous value, so you
+should answer 'n'. (You'll also have to manually add GDBM_File to
+the list of dynamic extensions to build.)
+
+=item Changing Compilers
+
+If you change compilers or make other significant changes, you should
+probably not re-use your old config.sh. Simply remove it or
+rename it, e.g. mv config.sh config.sh.old. Then rerun Configure
+with the options you want to use.
+
+This is a common source of problems. If you change from cc to
+gcc, you should almost always remove your old config.sh.
+
+=item Propagating your changes to config.sh
+
+If you make any changes to config.sh, you should propagate
+them to all the .SH files by running
+
+ sh Configure -S
+
+You will then have to rebuild by running
+
+ make depend
+ make
+
+=item config.over
+
+You can also supply a shell script config.over to over-ride Configure's
+guesses. It will get loaded up at the very end, just before config.sh
+is created. You have to be careful with this, however, as Configure
+does no checking that your changes make sense. See the section on
+L<"Changing the installation directory"> for an example.
+
+=item config.h
+
+Many of the system dependencies are contained in config.h.
+Configure builds config.h by running the config_h.SH script.
+The values for the variables are taken from config.sh.
+
+If there are any problems, you can edit config.h directly. Beware,
+though, that the next time you run Configure, your changes will be
+lost.
+
+=item cflags
+
+If you have any additional changes to make to the C compiler command
+line, they can be made in cflags.SH. For instance, to turn off the
+optimizer on toke.c, find the line in the switch structure for
+toke.c and put the command optimize='-g' before the ;; . You
+can also edit cflags directly, but beware that your changes will be
+lost the next time you run Configure.
+
+To explore various ways of changing ccflags from within a hint file,
+see the file hints/README.hints.
+
+To change the C flags for all the files, edit config.sh and change either
+$ccflags or $optimize, and then re-run
+
+ sh Configure -S
+ make depend
+
+=item No sh
+
+If you don't have sh, you'll have to copy the sample file Porting/config_H
+to config.h and edit the config.h to reflect your system's peculiarities.
+You'll probably also have to extensively modify the extension building
+mechanism.
+
+=item Porting information
+
+Specific information for the OS/2, Plan9, VMS and Win32 ports is in the
+corresponding README files and subdirectories. Additional information,
+including a glossary of all those config.sh variables, is in the Porting
+subdirectory.
+
+Ports for other systems may also be available. You should check out
+http://www.perl.com/CPAN/ports for current information on ports to
+various other operating systems.
+
+=back
+
+=head1 make depend
+
+This will look for all the includes. The output is stored in makefile.
+The only difference between Makefile and makefile is the dependencies at
+the bottom of makefile. If you have to make any changes, you should edit
+makefile, not Makefile since the Unix make command reads makefile first.
+(On non-Unix systems, the output may be stored in a different file.
+Check the value of $firstmakefile in your config.sh if in doubt.)
+
+Configure will offer to do this step for you, so it isn't listed
+explicitly above.
+
+=head1 make
+
+This will attempt to make perl in the current directory.
+
+If you can't compile successfully, try some of the following ideas.
+If none of them help, and careful reading of the error message and
+the relevant manual pages on your system doesn't help, you can
+send a message to either the comp.lang.perl.misc newsgroup or to
+perlbug@perl.com with an accurate description of your problem.
+See L<"Reporting Problems"> below.
+
+=over 4
+
+=item hints
+
+If you used a hint file, try reading the comments in the hint file
+for further tips and information.
+
+=item extensions
+
+If you can successfully build miniperl, but the process crashes
+during the building of extensions, you should run
+
+ make minitest
+
+to test your version of miniperl.
+
+=item locale
+
+If you have any locale-related environment variables set, try unsetting
+them. I have some reports that some versions of IRIX hang while
+running B<./miniperl configpm> with locales other than the C locale.
+See the discussion under L<"make test"> below about locales and the
+whole L<"Locale problems"> section in the file pod/perllocale.pod.
+The latter is especially useful if you see something like this
+
+ perl: warning: Setting locale failed.
+ perl: warning: Please check that your locale settings:
+ LC_ALL = "En_US",
+ LANG = (unset)
+ are supported and installed on your system.
+ perl: warning: Falling back to the standard locale ("C").
+
+at Perl startup.
+
+=item malloc duplicates
+
+If you get duplicates upon linking for malloc et al, add -DEMBEDMYMALLOC
+to your ccflags variable in config.sh.
+
+=item varargs
+
+If you get varargs problems with gcc, be sure that gcc is installed
+correctly and that you are not passing -I/usr/include to gcc. When using
+gcc, you should probably have i_stdarg='define' and i_varargs='undef'
+in config.sh. The problem is usually solved by running fixincludes
+correctly. If you do change config.sh, don't forget to propagate
+your changes (see L<"Propagating your changes to config.sh"> below).
+See also the L<"vsprintf"> item below.
+
+=item util.c
+
+If you get error messages such as the following (the exact line
+numbers and function name may vary in different versions of perl):
+
+ util.c: In function `Perl_form':
+ util.c:1107: number of arguments doesn't match prototype
+ proto.h:125: prototype declaration
+
+it might well be a symptom of the gcc "varargs problem". See the
+previous L<"varargs"> item.
+
+=item Solaris and SunOS dynamic loading
+
+If you have problems with dynamic loading using gcc on SunOS or
+Solaris, and you are using GNU as and GNU ld, you may need to add
+-B/bin/ (for SunOS) or -B/usr/ccs/bin/ (for Solaris) to your
+$ccflags, $ldflags, and $lddlflags so that the system's versions of as
+and ld are used. Note that the trailing '/' is required.
+Alternatively, you can use the GCC_EXEC_PREFIX
+environment variable to ensure that Sun's as and ld are used. Consult
+your gcc documentation for further information on the -B option and
+the GCC_EXEC_PREFIX variable.
+
+One convenient way to ensure you are not using GNU as and ld is to
+invoke Configure with
+
+ sh Configure -Dcc='gcc -B/usr/ccs/bin/'
+
+for Solaris systems. For a SunOS system, you must use -B/bin/
+instead.
+
+Alternatively, recent versions of GNU ld reportedly work if you
+include C<-Wl,-export-dynamic> in the ccdlflags variable in
+config.sh.
+
+=item ld.so.1: ./perl: fatal: relocation error:
+
+If you get this message on SunOS or Solaris, and you're using gcc,
+it's probably the GNU as or GNU ld problem in the previous item
+L<"Solaris and SunOS dynamic loading">.
+
+=item LD_LIBRARY_PATH
+
+If you run into dynamic loading problems, check your setting of
+the LD_LIBRARY_PATH environment variable. If you're creating a static
+Perl library (libperl.a rather than libperl.so) it should build
+fine with LD_LIBRARY_PATH unset, though that may depend on details
+of your local set-up.
+
+=item dlopen: stub interception failed
+
+The primary cause of the 'dlopen: stub interception failed' message is
+that the LD_LIBRARY_PATH environment variable includes a directory
+which is a symlink to /usr/lib (such as /lib).
+
+The reason this causes a problem is quite subtle. The file libdl.so.1.0
+actually *only* contains functions which generate 'stub interception
+failed' errors! The runtime linker intercepts links to
+"/usr/lib/libdl.so.1.0" and links in internal implementation of those
+functions instead. [Thanks to Tim Bunce for this explanation.]
+
+=item nm extraction
+
+If Configure seems to be having trouble finding library functions,
+try not using nm extraction. You can do this from the command line
+with
+
+ sh Configure -Uusenm
+
+or by answering the nm extraction question interactively.
+If you have previously run Configure, you should not reuse your old
+config.sh.
+
+=item umask not found
+
+If the build processes encounters errors relating to umask(), the problem
+is probably that Configure couldn't find your umask() system call.
+Check your config.sh. You should have d_umask='define'. If you don't,
+this is probably the L<"nm extraction"> problem discussed above. Also,
+try reading the hints file for your system for further information.
+
+=item vsprintf
+
+If you run into problems with vsprintf in compiling util.c, the
+problem is probably that Configure failed to detect your system's
+version of vsprintf(). Check whether your system has vprintf().
+(Virtually all modern Unix systems do.) Then, check the variable
+d_vprintf in config.sh. If your system has vprintf, it should be:
+
+ d_vprintf='define'
+
+If Configure guessed wrong, it is likely that Configure guessed wrong
+on a number of other common functions too. This is probably
+the L<"nm extraction"> problem discussed above.
+
+=item do_aspawn
+
+If you run into problems relating to do_aspawn or do_spawn, the
+problem is probably that Configure failed to detect your system's
+fork() function. Follow the procedure in the previous item
+on L<"nm extraction">.
+
+=item __inet_* errors
+
+If you receive unresolved symbol errors during Perl build and/or test
+referring to __inet_* symbols, check to see whether BIND 8.1 is
+installed. It installs a /usr/local/include/arpa/inet.h that refers to
+these symbols. Versions of BIND later than 8.1 do not install inet.h
+in that location and avoid the errors. You should probably update to a
+newer version of BIND. If you can't, you can either link with the
+updated resolver library provided with BIND 8.1 or rename
+/usr/local/bin/arpa/inet.h during the Perl build and test process to
+avoid the problem.
+
+=item Optimizer
+
+If you can't compile successfully, try turning off your compiler's
+optimizer. Edit config.sh and change the line
+
+ optimize='-O'
+
+to
+
+ optimize=' '
+
+then propagate your changes with B<sh Configure -S> and rebuild
+with B<make depend; make>.
+
+=item CRIPPLED_CC
+
+If you still can't compile successfully, try adding a -DCRIPPLED_CC
+flag. (Just because you get no errors doesn't mean it compiled right!)
+This simplifies some complicated expressions for compilers that get
+indigestion easily.
+
+=item Missing functions
+
+If you have missing routines, you probably need to add some library or
+other, or you need to undefine some feature that Configure thought was
+there but is defective or incomplete. Look through config.h for
+likely suspects. If Configure guessed wrong on a number of functions,
+you might have the L<"nm extraction"> problem discussed above.
+
+=item toke.c
+
+Some compilers will not compile or optimize the larger files (such as
+toke.c) without some extra switches to use larger jump offsets or
+allocate larger internal tables. You can customize the switches for
+each file in cflags. It's okay to insert rules for specific files into
+makefile since a default rule only takes effect in the absence of a
+specific rule.
+
+=item Missing dbmclose
+
+SCO prior to 3.2.4 may be missing dbmclose(). An upgrade to 3.2.4
+that includes libdbm.nfs (which includes dbmclose()) may be available.
+
+=item Note (probably harmless): No library found for -lsomething
+
+If you see such a message during the building of an extension, but
+the extension passes its tests anyway (see L<"make test"> below),
+then don't worry about the warning message. The extension
+Makefile.PL goes looking for various libraries needed on various
+systems; few systems will need all the possible libraries listed.
+For example, a system may have -lcposix or -lposix, but it's
+unlikely to have both, so most users will see warnings for the one
+they don't have. The phrase 'probably harmless' is intended to
+reassure you that nothing unusual is happening, and the build
+process is continuing.
+
+On the other hand, if you are building GDBM_File and you get the
+message
+
+ Note (probably harmless): No library found for -lgdbm
+
+then it's likely you're going to run into trouble somewhere along
+the line, since it's hard to see how you can use the GDBM_File
+extension without the -lgdbm library.
+
+It is true that, in principle, Configure could have figured all of
+this out, but Configure and the extension building process are not
+quite that tightly coordinated.
+
+=item sh: ar: not found
+
+This is a message from your shell telling you that the command 'ar'
+was not found. You need to check your PATH environment variable to
+make sure that it includes the directory with the 'ar' command. This
+is a common problem on Solaris, where 'ar' is in the /usr/ccs/bin
+directory.
+
+=item db-recno failure on tests 51, 53 and 55
+
+Old versions of the DB library (including the DB library which comes
+with FreeBSD 2.1) had broken handling of recno databases with modified
+bval settings. Upgrade your DB library or OS.
+
+=item Bad arg length for semctl, is XX, should be ZZZ
+
+If you get this error message from the lib/ipc_sysv test, your System
+V IPC may be broken. The XX typically is 20, and that is what ZZZ
+also should be. Consider upgrading your OS, or reconfiguring your OS
+to include the System V semaphores.
+
+=item lib/ipc_sysv........semget: No space left on device
+
+Either your account or the whole system has run out of semaphores. Or
+both. Either list the semaphores with "ipcs" and remove the unneeded
+ones (which ones these are depends on your system and applications)
+with "ipcrm -s SEMAPHORE_ID_HERE" or configure more semaphores to your
+system.
+
+=item Miscellaneous
+
+Some additional things that have been reported for either perl4 or perl5:
+
+Genix may need to use libc rather than libc_s, or #undef VARARGS.
+
+NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR.
+
+UTS may need one or more of -DCRIPPLED_CC, -K or -g, and undef LSTAT.
+
+FreeBSD can fail the lib/ipc_sysv.t test if SysV IPC has not been
+configured to the kernel. Perl tries to detect this, though, and
+you will get a message telling what to do.
+
+If you get syntax errors on '(', try -DCRIPPLED_CC.
+
+Machines with half-implemented dbm routines will need to #undef I_ODBM
+
+=back
+
+=head1 make test
+
+This will run the regression tests on the perl you just made (you
+should run plain 'make' before 'make test' otherwise you won't have a
+complete build). If 'make test' doesn't say "All tests successful"
+then something went wrong. See the file t/README in the t subdirectory.
+
+Note that you can't run the tests in background if this disables
+opening of /dev/tty. You can use 'make test-notty' in that case but
+a few tty tests will be skipped.
+
+=head2 What if make test doesn't work?
+
+If make test bombs out, just cd to the t directory and run ./TEST
+by hand to see if it makes any difference. If individual tests
+bomb, you can run them by hand, e.g.,
+
+ ./perl op/groups.t
+
+Another way to get more detailed information about failed tests and
+individual subtests is to cd to the t directory and run
+
+ ./perl harness
+
+(this assumes that most basic tests succeed, since harness uses
+complicated constructs).
+
+You should also read the individual tests to see if there are any helpful
+comments that apply to your system.
+
+=over 4
+
+=item locale
+
+Note: One possible reason for errors is that some external programs
+may be broken due to the combination of your environment and the way
+B<make test> exercises them. For example, this may happen if you have
+one or more of these environment variables set: LC_ALL LC_CTYPE
+LC_COLLATE LANG. In some versions of UNIX, the non-English locales
+are known to cause programs to exhibit mysterious errors.
+
+If you have any of the above environment variables set, please try
+
+ setenv LC_ALL C
+
+(for C shell) or
+
+ LC_ALL=C;export LC_ALL
+
+for Bourne or Korn shell) from the command line and then retry
+make test. If the tests then succeed, you may have a broken program that
+is confusing the testing. Please run the troublesome test by hand as
+shown above and see whether you can locate the program. Look for
+things like: exec, `backquoted command`, system, open("|...") or
+open("...|"). All these mean that Perl is trying to run some
+external program.
+
+=item Out of memory
+
+On some systems, particularly those with smaller amounts of RAM, some
+of the tests in t/op/pat.t may fail with an "Out of memory" message.
+Specifically, in perl5.004_64, tests 74 and 78 have been reported to
+fail on some systems. On my SparcStation IPC with 8 MB of RAM, test 78
+will fail if the system is running any other significant tasks at the
+same time.
+
+Try stopping other jobs on the system and then running the test by itself:
+
+ cd t; ./perl op/pat.t
+
+to see if you have any better luck. If your perl still fails this
+test, it does not necessarily mean you have a broken perl. This test
+tries to exercise the regular expression subsystem quite thoroughly,
+and may well be far more demanding than your normal usage.
+
+=back
+
+=head1 make install
+
+This will put perl into the public directory you specified to
+Configure; by default this is /usr/local/bin. It will also try
+to put the man pages in a reasonable place. It will not nroff the man
+pages, however. You may need to be root to run B<make install>. If you
+are not root, you must own the directories in question and you should
+ignore any messages about chown not working.
+
+=head2 Installing perl under different names
+
+If you want to install perl under a name other than "perl" (for example,
+when installing perl with special features enabled, such as debugging),
+indicate the alternate name on the "make install" line, such as:
+
+ make install PERLNAME=myperl
+
+=head2 Installed files
+
+If you want to see exactly what will happen without installing
+anything, you can run
+
+ ./perl installperl -n
+ ./perl installman -n
+
+make install will install the following:
+
+ perl,
+ perl5.nnn where nnn is the current release number. This
+ will be a link to perl.
+ suidperl,
+ sperl5.nnn If you requested setuid emulation.
+ a2p awk-to-perl translator
+ cppstdin This is used by perl -P, if your cc -E can't
+ read from stdin.
+ c2ph, pstruct Scripts for handling C structures in header files.
+ s2p sed-to-perl translator
+ find2perl find-to-perl translator
+ h2ph Extract constants and simple macros from C headers
+ h2xs Converts C .h header files to Perl extensions.
+ perlbug Tool to report bugs in Perl.
+ perldoc Tool to read perl's pod documentation.
+ pl2pm Convert Perl 4 .pl files to Perl 5 .pm modules
+ pod2html, Converters from perl's pod documentation format
+ pod2latex, to other useful formats.
+ pod2man, and
+ pod2text
+ splain Describe Perl warnings and errors
+
+ library files in $privlib and $archlib specified to
+ Configure, usually under /usr/local/lib/perl5/.
+ man pages in the location specified to Configure, usually
+ something like /usr/local/man/man1.
+ module in the location specified to Configure, usually
+ man pages under /usr/local/lib/perl5/man/man3.
+ pod/*.pod in $privlib/pod/.
+
+Installperl will also create the library directories $siteperl and
+$sitearch listed in config.sh. Usually, these are something like
+
+ /usr/local/lib/perl5/site_perl/5.005
+ /usr/local/lib/perl5/site_perl/5.005/archname
+
+where archname is something like sun4-sunos. These directories
+will be used for installing extensions.
+
+Perl's *.h header files and the libperl.a library are also installed
+under $archlib so that any user may later build new extensions, run the
+optional Perl compiler, or embed the perl interpreter into another
+program even if the Perl source is no longer available.
+
+=head1 Coexistence with earlier versions of perl5
+
+WARNING: The upgrade from 5.004_0x to 5.005 is going to be a bit
+tricky. See L<"Upgrading from 5.004 to 5.005"> below.
+
+In general, you can usually safely upgrade from one version of Perl (e.g.
+5.004_04) to another similar version (e.g. 5.004_05) without re-compiling
+all of your add-on extensions. You can also safely leave the old version
+around in case the new version causes you problems for some reason.
+For example, if you want to be sure that your script continues to run
+with 5.004_04, simply replace the '#!/usr/local/bin/perl' line at the
+top of the script with the particular version you want to run, e.g.
+#!/usr/local/bin/perl5.00404.
+
+Most extensions will probably not need to be recompiled to use
+with a newer version of perl. Here is how it is supposed to work.
+(These examples assume you accept all the Configure defaults.)
+
+The directories searched by version 5.005 will be
+
+ Configure variable Default value
+ $archlib /usr/local/lib/perl5/5.005/archname
+ $privlib /usr/local/lib/perl5/5.005
+ $sitearch /usr/local/lib/perl5/site_perl/5.005/archname
+ $sitelib /usr/local/lib/perl5/site_perl/5.005
+
+while the directories searched by version 5.005_01 will be
+
+ $archlib /usr/local/lib/perl5/5.00501/archname
+ $privlib /usr/local/lib/perl5/5.00501
+ $sitearch /usr/local/lib/perl5/site_perl/5.005/archname
+ $sitelib /usr/local/lib/perl5/site_perl/5.005
+
+When you install an add-on extension, it gets installed into $sitelib (or
+$sitearch if it is architecture-specific). This directory deliberately
+does NOT include the sub-version number (01) so that both 5.005 and
+5.005_01 can use the extension. Only when a perl version changes to
+break backwards compatibility will the default suggestions for the
+$sitearch and $sitelib version numbers be increased.
+
+However, if you do run into problems, and you want to continue to use the
+old version of perl along with your extension, move those extension files
+to the appropriate version directory, such as $privlib (or $archlib).
+(The extension's .packlist file lists the files installed with that
+extension. For the Tk extension, for example, the list of files installed
+is in $sitearch/auto/Tk/.packlist.) Then use your newer version of perl
+to rebuild and re-install the extension into $sitelib. This way, Perl
+5.005 will find your files in the 5.005 directory, and newer versions
+of perl will find your newer extension in the $sitelib directory.
+(This is also why perl searches the site-specific libraries last.)
+
+Alternatively, if you are willing to reinstall all your extensions
+every time you upgrade perl, then you can include the subversion
+number in $sitearch and $sitelib when you run Configure.
+
+=head2 Maintaining completely separate versions
+
+Many users prefer to keep all versions of perl in completely
+separate directories. One convenient way to do this is by
+using a separate prefix for each version, such as
+
+ sh Configure -Dprefix=/opt/perl5.004
+
+and adding /opt/perl5.004/bin to the shell PATH variable. Such users
+may also wish to add a symbolic link /usr/local/bin/perl so that
+scripts can still start with #!/usr/local/bin/perl.
+
+Others might share a common directory for maintenance sub-versions
+(e.g. 5.004 for all 5.004_0x versions), but change directory with
+each major version.
+
+If you are installing a development subversion, you probably ought to
+seriously consider using a separate directory, since development
+subversions may not have all the compatibility wrinkles ironed out
+yet.
+
+=head2 Upgrading from 5.004 to 5.005
+
+Extensions built and installed with versions of perl prior to 5.004_50
+will need to be recompiled to be used with 5.004_50 and later. You will,
+however, be able to continue using 5.004 even after you install 5.005.
+The 5.004 binary will still be able to find the extensions built under
+5.004; the 5.005 binary will look in the new $sitearch and $sitelib
+directories, and will not find them.
+
+=head1 Coexistence with perl4
+
+You can safely install perl5 even if you want to keep perl4 around.
+
+By default, the perl5 libraries go into /usr/local/lib/perl5/, so
+they don't override the perl4 libraries in /usr/local/lib/perl/.
+
+In your /usr/local/bin directory, you should have a binary named
+perl4.036. That will not be touched by the perl5 installation
+process. Most perl4 scripts should run just fine under perl5.
+However, if you have any scripts that require perl4, you can replace
+the #! line at the top of them by #!/usr/local/bin/perl4.036
+(or whatever the appropriate pathname is). See pod/perltrap.pod
+for possible problems running perl4 scripts under perl5.
+
+=head1 cd /usr/include; h2ph *.h sys/*.h
+
+Some perl scripts need to be able to obtain information from
+the system header files. This command will convert the most commonly used
+header files in /usr/include into files that can be easily interpreted
+by perl. These files will be placed in the architecture-dependent library
+($archlib) directory you specified to Configure.
+
+Note: Due to differences in the C and perl languages, the
+conversion of the header files is not perfect. You will probably have
+to hand-edit some of the converted files to get them to parse
+correctly. For example, h2ph breaks spectacularly on type casting and
+certain structures.
+
+=head1 installhtml --help
+
+Some sites may wish to make perl documentation available in HTML
+format. The installhtml utility can be used to convert pod
+documentation into linked HTML files and install them.
+
+The following command-line is an example of one used to convert
+perl documentation:
+
+ ./installhtml \
+ --podroot=. \
+ --podpath=lib:ext:pod:vms \
+ --recurse \
+ --htmldir=/perl/nmanual \
+ --htmlroot=/perl/nmanual \
+ --splithead=pod/perlipc \
+ --splititem=pod/perlfunc \
+ --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \
+ --verbose
+
+See the documentation in installhtml for more details. It can take
+many minutes to execute a large installation and you should expect to
+see warnings like "no title", "unexpected directive" and "cannot
+resolve" as the files are processed. We are aware of these problems
+(and would welcome patches for them).
+
+You may find it helpful to run installhtml twice. That should reduce
+the number of "cannot resolve" warnings.
+
+=head1 cd pod && make tex && (process the latex files)
+
+Some sites may also wish to make the documentation in the pod/ directory
+available in TeX format. Type
+
+ (cd pod && make tex && <process the latex files>)
+
+=head1 Reporting Problems
+
+If you have difficulty building perl, and none of the advice in this file
+helps, and careful reading of the error message and the relevant manual
+pages on your system doesn't help either, then you should send a message
+to either the comp.lang.perl.misc newsgroup or to perlbug@perl.com with
+an accurate description of your problem.
+
+Please include the output of the ./myconfig shell script that comes with
+the distribution. Alternatively, you can use the perlbug program that
+comes with the perl distribution, but you need to have perl compiled
+before you can use it. (If you have not installed it yet, you need to
+run C<./perl -Ilib utils/perlbug> instead of a plain C<perlbug>.)
+
+You might also find helpful information in the Porting directory of the
+perl distribution.
+
+=head1 DOCUMENTATION
+
+Read the manual entries before running perl. The main documentation
+is in the pod/ subdirectory and should have been installed during the
+build process. Type B<man perl> to get started. Alternatively, you
+can type B<perldoc perl> to use the supplied perldoc script. This is
+sometimes useful for finding things in the library modules.
+
+Under UNIX, you can produce a documentation book in postscript form,
+along with its table of contents, by going to the pod/ subdirectory and
+running (either):
+
+ ./roffitall -groff # If you have GNU groff installed
+ ./roffitall -psroff # If you have psroff
+
+This will leave you with two postscript files ready to be printed.
+(You may need to fix the roffitall command to use your local troff
+set-up.)
+
+Note that you must have performed the installation already before running
+the above, since the script collects the installed files to generate
+the documentation.
+
+=head1 AUTHOR
+
+Original author: Andy Dougherty doughera@lafayette.edu , borrowing very
+heavily from the original README by Larry Wall, with lots of helpful
+feedback and additions from the perl5-porters@perl.org folks.
+
+If you have problems, corrections, or questions, please see
+L<"Reporting Problems"> above.
+
+=head1 REDISTRIBUTION
+
+This document is part of the Perl package and may be distributed under
+the same terms as perl itself.
+
+If you are distributing a modified version of perl (perhaps as part of
+a larger package) please do modify these installation instructions and
+the contact information to match your distribution.
+
+=head1 LAST MODIFIED
+
+$Id: INSTALL,v 1.42 1998/07/15 18:04:44 doughera Released $
diff --git a/contrib/perl5/INTERN.h b/contrib/perl5/INTERN.h
new file mode 100644
index 000000000000..6ce0367dee56
--- /dev/null
+++ b/contrib/perl5/INTERN.h
@@ -0,0 +1,46 @@
+/* INTERN.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * EXT designates a global var which is defined in perl.h
+ * dEXT designates a global var which is defined in another
+ * file, so we can't count on finding it in perl.h
+ * (this practice should be avoided).
+ */
+#undef EXT
+#undef dEXT
+#undef EXTCONST
+#undef dEXTCONST
+#if defined(VMS) && !defined(__GNUC__)
+ /* Suppress portability warnings from DECC for VMS-specific extensions */
+# ifdef __DECC
+# pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT)
+# endif
+# define EXT globaldef {"$GLOBAL_RW_VARS"} noshare
+# define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare
+# define EXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
+# define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
+#else
+# ifdef __cplusplus
+# define EXT
+# define dEXT
+# define EXTCONST extern const
+# define dEXTCONST const
+#else
+# define EXT
+# define dEXT
+# define EXTCONST const
+# define dEXTCONST const
+#endif
+#endif
+
+#undef INIT
+#define INIT(x) = x
+
+#define DOINIT
diff --git a/contrib/perl5/MANIFEST b/contrib/perl5/MANIFEST
new file mode 100644
index 000000000000..1d6b3a8e7c8e
--- /dev/null
+++ b/contrib/perl5/MANIFEST
@@ -0,0 +1,1083 @@
+Artistic The "Artistic License"
+Changes Differences from previous version
+Changes5.000 Differences between 4.x and 5.000
+Changes5.001 Differences between 5.000 and 5.001
+Changes5.002 Differences between 5.001 and 5.002
+Changes5.003 Differences between 5.002 and 5.003
+Changes5.004 Differences between 5.003 and 5.004
+Configure Portability tool
+Copying The GNU General Public License
+EXTERN.h Included before foreign .h files
+INSTALL Detailed installation instructions
+INTERN.h Included before domestic .h files
+MANIFEST This list of files
+Makefile.SH A script that generates Makefile
+objXSUB.h Scoping macros for Perl Object in extensions
+Policy_sh.SH Hold site-wide preferences between Configure runs.
+Porting/Contract Social contract for contributed modules in Perl core
+Porting/Glossary Glossary of config.sh variables
+Porting/config.sh Sample config.sh
+Porting/config_H Sample config.h
+Porting/findvars Find occurrences of words
+Porting/fixCORE Find and fix modules that generate warnings
+Porting/fixvars Find undeclared variables with C compiler and fix em
+Porting/genlog Generate formatted changelogs by querying p4d
+Porting/makerel Release making utility
+Porting/p4d2p Generate standard patches from p4 diffs
+Porting/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
+README The Instructions
+README.amiga Notes about AmigaOS port
+README.beos Notes about BeOS port
+README.cygwin32 Notes about Cygwin32 port
+README.dos Notes about dos/djgpp port
+README.mpeix Notes about MPE/iX port
+README.os2 Notes about OS/2 port
+README.os390 Notes about OS/390 (nee MVS) port
+README.plan9 Notes about Plan9 port
+README.qnx Notes about QNX port
+README.threads Notes about multithreading
+README.vms Notes about VMS port
+README.win32 Notes about Win32 port
+Todo The Wishlist
+Todo-5.005 What needs doing before 5.005 release
+XSlock.h Include file for extensions built with PERL_OBJECT defined
+XSUB.h Include file for extension subroutines
+av.c Array value code
+av.h Array value header
+beos/nm.c BeOS port
+bytecode.h Bytecode header for compiler
+bytecode.pl Produces byterun.h, byterun.c and ext/B/Asmdata.pm
+byterun.c Runtime support for compiler-generated bytecode
+byterun.h Header for byterun.c
+cc_runtime.h Macros need by runtime of compiler-generated code
+cflags.SH A script that emits C compilation flags per file
+config_h.SH Produces config.h
+configpm Produces lib/Config.pm
+configure.com Configure-equivalent for VMS
+configure.gnu Crude emulation of GNU configure
+cop.h Control operator header
+cv.h Code value header
+cygwin32/cw32imp.h Cygwin32 port
+cygwin32/gcc2 Cygwin32 port
+cygwin32/ld2 Cygwin32 port
+cygwin32/perlgcc Cygwin32 port
+cygwin32/perlld Cygwin32 port
+deb.c Debugging routines
+djgpp/config.over DOS/DJGPP port
+djgpp/configure.bat DOS/DJGPP port
+djgpp/djgpp.c DOS/DJGPP port
+djgpp/djgppsed.sh DOS/DJGPP port
+djgpp/fixpmain DOS/DJGPP port
+doio.c I/O operations
+doop.c Support code for various operations
+dosish.h Some defines for MS/DOSish machines
+dump.c Debugging output
+ebcdic.c EBCDIC support routines
+eg/ADB An adb wrapper to put in your crash dir
+eg/README Intro to example perl scripts
+eg/cgi/RunMeFirst Setup script for CGI examples
+eg/cgi/caution.xbm CGI example
+eg/cgi/clickable_image.cgi CGI example
+eg/cgi/cookie.cgi CGI example
+eg/cgi/crash.cgi CGI example
+eg/cgi/customize.cgi CGI example
+eg/cgi/diff_upload.cgi CGI example
+eg/cgi/dna.small.gif.uu Small image for CGI examples
+eg/cgi/file_upload.cgi CGI example
+eg/cgi/frameset.cgi CGI example
+eg/cgi/index.html Index page for CGI examples
+eg/cgi/internal_links.cgi CGI example
+eg/cgi/javascript.cgi CGI example
+eg/cgi/monty.cgi CGI example
+eg/cgi/multiple_forms.cgi CGI example
+eg/cgi/nph-clock.cgi CGI example
+eg/cgi/nph-multipart.cgi CGI example
+eg/cgi/popup.cgi CGI example
+eg/cgi/save_state.cgi CGI example
+eg/cgi/tryit.cgi CGI example
+eg/cgi/wilogo.gif.uu Small image for CGI examples
+eg/changes A program to list recently changed files
+eg/client A sample client
+eg/down A program to do things to subdirectories
+eg/dus A program to do du -s on non-mounted dirs
+eg/findcp A find wrapper that implements a -cp switch
+eg/findtar A find wrapper that pumps out a tar file
+eg/g/gcp A program to do a global rcp
+eg/g/gcp.man Manual page for gcp
+eg/g/ged A program to do a global edit
+eg/g/ghosts A sample /etc/ghosts file
+eg/g/gsh A program to do a global rsh
+eg/g/gsh.man Manual page for gsh
+eg/muck A program to find missing make dependencies
+eg/muck.man Manual page for muck
+eg/myrup A program to find lightly loaded machines
+eg/nih Script to insert #! workaround
+eg/relink A program to change symbolic links
+eg/rename A program to rename files
+eg/rmfrom A program to feed doomed filenames to
+eg/scan/scan_df Scan for filesystem anomalies
+eg/scan/scan_last Scan for login anomalies
+eg/scan/scan_messages Scan for console message anomalies
+eg/scan/scan_passwd Scan for passwd file anomalies
+eg/scan/scan_ps Scan for process anomalies
+eg/scan/scan_sudo Scan for sudo anomalies
+eg/scan/scan_suid Scan for setuid anomalies
+eg/scan/scanner An anomaly reporter
+eg/server A sample server
+eg/shmkill A program to remove unused shared memory
+eg/sysvipc/README Intro to Sys V IPC examples
+eg/sysvipc/ipcmsg Example of SYS V IPC message queues
+eg/sysvipc/ipcsem Example of Sys V IPC semaphores
+eg/sysvipc/ipcshm Example of Sys V IPC shared memory
+eg/travesty A program to print travesties of its input text
+eg/unuc Un-uppercases an all-uppercase text
+eg/uudecode A version of uudecode
+eg/van/empty A program to empty the trashcan
+eg/van/unvanish A program to undo what vanish does
+eg/van/vanexp A program to expire vanished files
+eg/van/vanish A program to put files in a trashcan
+eg/who A sample who program
+eg/wrapsuid A setuid script wrapper generator
+emacs/cperl-mode.el An alternate perl-mode
+emacs/ptags Creates smart TAGS file
+embed.h Maps symbols to safer names
+embed.pl Produces embed.h
+embedvar.h C namespace management
+ext/B/B.pm Compiler backend support functions and methods
+ext/B/B.xs Compiler backend external subroutines
+ext/B/B/Asmdata.pm Compiler backend data for assembler
+ext/B/B/Assembler.pm Compiler backend assembler support functions
+ext/B/B/Bblock.pm Compiler basic block analysis support
+ext/B/B/Bytecode.pm Compiler Bytecode backend
+ext/B/B/C.pm Compiler C backend
+ext/B/B/CC.pm Compiler CC backend
+ext/B/B/Debug.pm Compiler Debug backend
+ext/B/B/Deparse.pm Compiler Deparse backend
+ext/B/B/Disassembler.pm Compiler Disassembler backend
+ext/B/B/Lint.pm Compiler Lint backend
+ext/B/B/Showlex.pm Compiler Showlex backend
+ext/B/B/Stackobj.pm Compiler stack objects support functions
+ext/B/B/Terse.pm Compiler Terse backend
+ext/B/B/Xref.pm Compiler Xref backend
+ext/B/B/assemble Assemble compiler bytecode
+ext/B/B/cc_harness Simplistic wrapper for using -MO=CC compiler
+ext/B/B/disassemble Disassemble compiler bytecode output
+ext/B/B/makeliblinks Make a simplistic XSUB .so symlink tree for compiler
+ext/B/Makefile.PL Compiler backend makefile writer
+ext/B/NOTES Compiler backend notes
+ext/B/O.pm Compiler front-end module (-MO=...)
+ext/B/README Compiler backend README
+ext/B/TESTS Compiler backend test data
+ext/B/Todo Compiler backend Todo list
+ext/B/byteperl.c Bytecode runner
+ext/B/ramblings/cc.notes Compiler ramblings: notes on CC backend
+ext/B/ramblings/curcop.runtime Compiler ramblings: notes on curcop use
+ext/B/ramblings/flip-flop Compiler ramblings: notes on flip-flop
+ext/B/ramblings/magic Compiler ramblings: notes on magic
+ext/B/ramblings/reg.alloc Compiler ramblings: register allocation
+ext/B/ramblings/runtime.porting Compiler ramblings: porting PP enging
+ext/B/typemap Compiler backend interface types
+ext/DB_File/Changes Berkeley DB extension change log
+ext/DB_File/DB_File.pm Berkeley DB extension Perl module
+ext/DB_File/DB_File.xs Berkeley DB extension external subroutines
+ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder
+ext/DB_File/Makefile.PL Berkeley DB extension makefile writer
+ext/DB_File/dbinfo Berkeley DB database version checker
+ext/DB_File/typemap Berkeley DB extension interface types
+ext/Data/Dumper/Changes Data pretty printer, changelog
+ext/Data/Dumper/Dumper.pm Data pretty printer, module
+ext/Data/Dumper/Dumper.xs Data pretty printer, externals
+ext/Data/Dumper/Makefile.PL Data pretty printer, makefile writer
+ext/Data/Dumper/Todo Data pretty printer, futures
+ext/DynaLoader/DynaLoader_pm.PL Dynamic Loader perl module
+ext/DynaLoader/Makefile.PL Dynamic Loader makefile writer
+ext/DynaLoader/README Dynamic Loader notes and intro
+ext/DynaLoader/dl_aix.xs AIX implementation
+ext/DynaLoader/dl_cygwin32.xs Cygwin32 implementation
+ext/DynaLoader/dl_dld.xs GNU dld style implementation
+ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation
+ext/DynaLoader/dl_hpux.xs HP-UX implementation
+ext/DynaLoader/dl_mpeix.xs MPE/iX implementation
+ext/DynaLoader/dl_next.xs Next implementation
+ext/DynaLoader/dl_none.xs Stub implementation
+ext/DynaLoader/dl_vms.xs VMS implementation
+ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files
+ext/Errno/ChangeLog Errno perl module change log
+ext/Errno/Errno_pm.PL Errno perl module create script
+ext/Errno/Makefile.PL Errno extension makefile writer
+ext/Fcntl/Fcntl.pm Fcntl extension Perl module
+ext/Fcntl/Fcntl.xs Fcntl extension external subroutines
+ext/Fcntl/Makefile.PL Fcntl extension makefile writer
+ext/GDBM_File/GDBM_File.pm GDBM extension Perl module
+ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
+ext/GDBM_File/Makefile.PL GDBM extension makefile writer
+ext/GDBM_File/typemap GDBM extension interface types
+ext/IO/IO.pm Top-level interface to IO::* classes
+ext/IO/IO.xs IO extension external subroutines
+ext/IO/Makefile.PL IO extension makefile writer
+ext/IO/README IO extension maintenance notice
+ext/IO/lib/IO/File.pm IO::File extension Perl module
+ext/IO/lib/IO/Handle.pm IO::Handle extension Perl module
+ext/IO/lib/IO/Pipe.pm IO::Pipe extension Perl module
+ext/IO/lib/IO/Seekable.pm IO::Seekable extension Perl module
+ext/IO/lib/IO/Select.pm IO::Select extension Perl module
+ext/IO/lib/IO/Socket.pm IO::Socket extension Perl module
+ext/IPC/SysV/ChangeLog IPC::SysV extension Perl module
+ext/IPC/SysV/MANIFEST IPC::SysV extension Perl module
+ext/IPC/SysV/Makefile.PL IPC::SysV extension Perl module
+ext/IPC/SysV/Msg.pm IPC::SysV extension Perl module
+ext/IPC/SysV/README IPC::SysV extension Perl module
+ext/IPC/SysV/Semaphore.pm IPC::SysV extension Perl module
+ext/IPC/SysV/SysV.pm IPC::SysV extension Perl module
+ext/IPC/SysV/SysV.xs IPC::SysV extension Perl module
+ext/IPC/SysV/t/msg.t IPC::SysV extension Perl module
+ext/IPC/SysV/t/sem.t IPC::SysV extension Perl module
+ext/NDBM_File/Makefile.PL NDBM extension makefile writer
+ext/NDBM_File/NDBM_File.pm NDBM extension Perl module
+ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines
+ext/NDBM_File/hints/dec_osf.pl Hint for NDBM_File for named architecture
+ext/NDBM_File/hints/dynixptx.pl Hint for NDBM_File for named architecture
+ext/NDBM_File/hints/solaris.pl Hint for NDBM_File for named architecture
+ext/NDBM_File/hints/svr4.pl Hint for NDBM_File for named architecture
+ext/NDBM_File/typemap NDBM extension interface types
+ext/ODBM_File/Makefile.PL ODBM extension makefile writer
+ext/ODBM_File/ODBM_File.pm ODBM extension Perl module
+ext/ODBM_File/ODBM_File.xs ODBM extension external subroutines
+ext/ODBM_File/hints/dec_osf.pl Hint for ODBM_File for named architecture
+ext/ODBM_File/hints/hpux.pl Hint for ODBM_File for named architecture
+ext/ODBM_File/hints/sco.pl Hint for ODBM_File for named architecture
+ext/ODBM_File/hints/solaris.pl Hint for ODBM_File for named architecture
+ext/ODBM_File/hints/svr4.pl Hint for ODBM_File for named architecture
+ext/ODBM_File/hints/ultrix.pl Hint for ODBM_File for named architecture
+ext/ODBM_File/typemap ODBM extension interface types
+ext/Opcode/Makefile.PL Opcode extension makefile writer
+ext/Opcode/Opcode.pm Opcode extension Perl module
+ext/Opcode/Opcode.xs Opcode extension external subroutines
+ext/Opcode/Safe.pm Safe extension Perl module
+ext/Opcode/ops.pm "Pragma" form of Opcode extension Perl module
+ext/POSIX/Makefile.PL POSIX extension makefile writer
+ext/POSIX/POSIX.pm POSIX extension Perl module
+ext/POSIX/POSIX.pod POSIX extension documentation
+ext/POSIX/POSIX.xs POSIX extension external subroutines
+ext/POSIX/hints/bsdos.pl Hint for POSIX for named architecture
+ext/POSIX/hints/freebsd.pl Hint for POSIX for named architecture
+ext/POSIX/hints/linux.pl Hint for POSIX for named architecture
+ext/POSIX/hints/netbsd.pl Hint for POSIX for named architecture
+ext/POSIX/hints/next_3.pl Hint for POSIX for named architecture
+ext/POSIX/hints/openbsd.pl Hint for POSIX for named architecture
+ext/POSIX/hints/sunos_4.pl Hint for POSIX for named architecture
+ext/POSIX/typemap POSIX extension interface types
+ext/SDBM_File/Makefile.PL SDBM extension makefile writer
+ext/SDBM_File/SDBM_File.pm SDBM extension Perl module
+ext/SDBM_File/SDBM_File.xs SDBM extension external subroutines
+ext/SDBM_File/sdbm/CHANGES SDBM kit
+ext/SDBM_File/sdbm/COMPARE SDBM kit
+ext/SDBM_File/sdbm/Makefile.PL SDBM kit
+ext/SDBM_File/sdbm/README SDBM kit
+ext/SDBM_File/sdbm/README.too SDBM kit
+ext/SDBM_File/sdbm/biblio SDBM kit
+ext/SDBM_File/sdbm/dba.c SDBM kit
+ext/SDBM_File/sdbm/dbd.c SDBM kit
+ext/SDBM_File/sdbm/dbe.1 SDBM kit
+ext/SDBM_File/sdbm/dbe.c SDBM kit
+ext/SDBM_File/sdbm/dbm.c SDBM kit
+ext/SDBM_File/sdbm/dbm.h SDBM kit
+ext/SDBM_File/sdbm/dbu.c SDBM kit
+ext/SDBM_File/sdbm/grind SDBM kit
+ext/SDBM_File/sdbm/hash.c SDBM kit
+ext/SDBM_File/sdbm/linux.patches SDBM kit
+ext/SDBM_File/sdbm/makefile.sdbm SDBM kit
+ext/SDBM_File/sdbm/pair.c SDBM kit
+ext/SDBM_File/sdbm/pair.h SDBM kit
+ext/SDBM_File/sdbm/readme.ms SDBM kit
+ext/SDBM_File/sdbm/sdbm.3 SDBM kit
+ext/SDBM_File/sdbm/sdbm.c SDBM kit
+ext/SDBM_File/sdbm/sdbm.h SDBM kit
+ext/SDBM_File/sdbm/tune.h SDBM kit
+ext/SDBM_File/sdbm/util.c SDBM kit
+ext/SDBM_File/typemap SDBM extension interface types
+ext/Socket/Makefile.PL Socket extension makefile writer
+ext/Socket/Socket.pm Socket extension Perl module
+ext/Socket/Socket.xs Socket extension external subroutines
+ext/Thread/Makefile.PL Thread extension makefile writer
+ext/Thread/Notes Thread notes
+ext/Thread/README Thread README
+ext/Thread/Thread.pm Thread extension Perl module
+ext/Thread/Thread.xs Thread extension external subroutines
+ext/Thread/Thread/Queue.pm Thread synchronised queue objects
+ext/Thread/Thread/Semaphore.pm Thread semaphore objects
+ext/Thread/Thread/Signal.pm Start a thread to run signal handlers
+ext/Thread/Thread/Specific.pm Thread specific data access
+ext/Thread/create.t Test thread creation
+ext/Thread/die.t Test thread die()
+ext/Thread/die2.t Test thread die() differently
+ext/Thread/io.t Test threads doing simple I/O
+ext/Thread/join.t Test thread joining
+ext/Thread/join2.t Test thread joining differently
+ext/Thread/list.t Test getting list of all threads
+ext/Thread/lock.t Test lock primitive
+ext/Thread/queue.t Test Thread::Queue module
+ext/Thread/specific.t Test thread-specific user data
+ext/Thread/sync.t Test thread synchronisation
+ext/Thread/sync2.t Test thread synchronisation
+ext/Thread/typemap Thread extension interface types
+ext/Thread/unsync.t Test thread implicit synchronisation
+ext/Thread/unsync2.t Test thread implicit synchronisation
+ext/Thread/unsync3.t Test thread implicit synchronisation
+ext/Thread/unsync4.t Test thread implicit synchronisation
+ext/attrs/Makefile.PL attrs extension makefile writer
+ext/attrs/attrs.pm attrs extension Perl module
+ext/attrs/attrs.xs attrs extension external subroutines
+ext/re/Makefile.PL re extension makefile writer
+ext/re/hints/mpeix.pl Hints for re for named architecture
+ext/re/re.pm re extension Perl module
+ext/re/re.xs re extension external subroutines
+ext/util/make_ext Used by Makefile to execute extension Makefiles
+ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info
+fakethr.h Fake threads header
+form.h Public declarations for the above
+global.sym Symbols that need hiding when embedded
+globals.c File to declare global symbols (for shared library)
+gv.c Glob value code
+gv.h Glob value header
+h2pl/README How to turn .ph files into .pl files
+h2pl/cbreak.pl cbreak routines using .ph
+h2pl/cbreak2.pl cbreak routines using .pl
+h2pl/eg/sizeof.ph Sample sizeof array initialization
+h2pl/eg/sys/errno.pl Sample translated errno.pl
+h2pl/eg/sys/ioctl.pl Sample translated ioctl.pl
+h2pl/eg/sysexits.pl Sample translated sysexits.pl
+h2pl/getioctlsizes Program to extract types from ioctl.h
+h2pl/mksizes Program to make %sizeof array
+h2pl/mkvars Program to make .pl from .ph files
+h2pl/tcbreak cbreak test routine using .ph
+h2pl/tcbreak2 cbreak test routine using .pl
+handy.h Handy definitions
+hints/3b1.sh Hints for named architecture
+hints/3b1cc Hints for named architecture
+hints/README.hints Notes about hints
+hints/aix.sh Hints for named architecture
+hints/altos486.sh Hints for named architecture
+hints/amigaos.sh Hints for named architecture
+hints/apollo.sh Hints for named architecture
+hints/aux_3.sh Hints for named architecture
+hints/beos.sh Hints for named architecture
+hints/broken-db.msg Warning message for systems with broken DB library
+hints/bsdos.sh Hints for named architecture
+hints/convexos.sh Hints for named architecture
+hints/cxux.sh Hints for named architecture
+hints/cygwin32.sh Hints for named architecture
+hints/dcosx.sh Hints for named architecture
+hints/dec_osf.sh Hints for named architecture
+hints/dgux.sh Hints for named architecture
+hints/dos_djgpp.sh Hints for named architecture
+hints/dynix.sh Hints for named architecture
+hints/dynixptx.sh Hints for named architecture
+hints/epix.sh Hints for named architecture
+hints/esix4.sh Hints for named architecture
+hints/fps.sh Hints for named architecture
+hints/freebsd.sh Hints for named architecture
+hints/genix.sh Hints for named architecture
+hints/greenhills.sh Hints for named architecture
+hints/hpux.sh Hints for named architecture
+hints/i386.sh Hints for named architecture
+hints/irix_4.sh Hints for named architecture
+hints/irix_5.sh Hints for named architecture
+hints/irix_6.sh Hints for named architecture
+hints/irix_6_0.sh Hints for named architecture
+hints/irix_6_1.sh Hints for named architecture
+hints/isc.sh Hints for named architecture
+hints/isc_2.sh Hints for named architecture
+hints/linux.sh Hints for named architecture
+hints/lynxos.sh Hints for named architecture
+hints/machten.sh Hints for named architecture
+hints/machten_2.sh Hints for named architecture
+hints/mips.sh Hints for named architecture
+hints/mpc.sh Hints for named architecture
+hints/mpeix.sh Hints for named architecture
+hints/ncr_tower.sh Hints for named architecture
+hints/netbsd.sh Hints for named architecture
+hints/newsos4.sh Hints for named architecture
+hints/next_3.sh Hints for named architecture
+hints/next_3_0.sh Hints for named architecture
+hints/next_4.sh Hints for named architecture
+hints/openbsd.sh Hints for named architecture
+hints/opus.sh Hints for named architecture
+hints/os2.sh Hints for named architecture
+hints/os390.sh Hints for named architecture
+hints/powerux.sh Hints for named architecture
+hints/qnx.sh Hints for named architecture
+hints/sco.sh Hints for named architecture
+hints/sco_2_3_0.sh Hints for named architecture
+hints/sco_2_3_1.sh Hints for named architecture
+hints/sco_2_3_2.sh Hints for named architecture
+hints/sco_2_3_3.sh Hints for named architecture
+hints/sco_2_3_4.sh Hints for named architecture
+hints/solaris_2.sh Hints for named architecture
+hints/stellar.sh Hints for named architecture
+hints/sunos_4_0.sh Hints for named architecture
+hints/sunos_4_1.sh Hints for named architecture
+hints/svr4.sh Hints for named architecture
+hints/ti1500.sh Hints for named architecture
+hints/titanos.sh Hints for named architecture
+hints/ultrix_4.sh Hints for named architecture
+hints/umips.sh Hints for named architecture
+hints/unicos.sh Hints for named architecture
+hints/unicosmk.sh Hints for named architecture
+hints/unisysdynix.sh Hints for named architecture
+hints/utekv.sh Hints for named architecture
+hints/uts.sh Hints for named architecture
+hv.c Hash value code
+hv.h Hash value header
+installhtml Perl script to install html files for pods
+installman Perl script to install man pages for pods
+installperl Perl script to do "make install" dirty work
+interp.sym Interpreter specific symbols to hide in a struct
+intrpvar.h Variables held in each interpreter instance
+iperlsys.h Perl's interface to the system
+keywords.h The keyword numbers
+keywords.pl Program to write keywords.h
+lib/AnyDBM_File.pm Perl module to emulate dbmopen
+lib/AutoLoader.pm Autoloader base class
+lib/AutoSplit.pm Split up autoload functions
+lib/Benchmark.pm Measure execution time
+lib/CGI.pm Web server interface ("Common Gateway Interface")
+lib/CGI/Apache.pm Support for Apache's Perl module
+lib/CGI/Carp.pm Log server errors with helpful context
+lib/CGI/Cookie.pm Interface to Netscape Cookies
+lib/CGI/Fast.pm Support for FastCGI (persistent server process)
+lib/CGI/Push.pm Support for server push
+lib/CGI/Switch.pm Simple interface for multiple server types
+lib/CPAN.pm Interface to Comprehensive Perl Archive Network
+lib/CPAN/FirstTime.pm Utility for creating CPAN config files
+lib/CPAN/Nox.pm Runs CPAN while avoiding compiled extensions
+lib/Carp.pm Error message base class
+lib/Class/Struct.pm Declare struct-like datatypes as Perl classes
+lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir)
+lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm
+lib/DirHandle.pm like FileHandle only for directories
+lib/English.pm Readable aliases for short variables
+lib/Env.pm Map environment into ordinary variables
+lib/Exporter.pm Exporter base class
+lib/ExtUtils/Command.pm Utilities for Make on non-UNIX platforms
+lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs
+lib/ExtUtils/Install.pm Handles 'make install' on extensions
+lib/ExtUtils/Installed.pm Information on installed extensions
+lib/ExtUtils/Liblist.pm Locates libraries
+lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
+lib/ExtUtils/MM_Unix.pm MakeMaker base class for Unix
+lib/ExtUtils/MM_VMS.pm MakeMaker methods for VMS
+lib/ExtUtils/MM_Win32.pm MakeMaker methods for Win32
+lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions
+lib/ExtUtils/Manifest.pm Utilities to write MANIFEST files
+lib/ExtUtils/Mkbootstrap.pm Writes a bootstrap file (see MakeMaker)
+lib/ExtUtils/Mksymlists.pm Writes a linker options file for extensions
+lib/ExtUtils/Packlist.pm Manipulates .packlist files
+lib/ExtUtils/inst Give information about installed extensions
+lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension
+lib/ExtUtils/typemap Extension interface types
+lib/ExtUtils/xsubpp External subroutine preprocessor
+lib/Fatal.pm Make errors in functions/builtins fatal
+lib/File/Basename.pm Emulate the basename program
+lib/File/CheckTree.pm Perl module supporting wholesale file mode validation
+lib/File/Compare.pm Emulation of cmp command
+lib/File/Copy.pm Emulation of cp command
+lib/File/DosGlob.pm Win32 DOS-globbing module
+lib/File/Find.pm Routines to do a find
+lib/File/Path.pm Do things like `mkdir -p' and `rm -r'
+lib/File/Spec.pm portable operations on file names
+lib/File/Spec/Mac.pm portable operations on Mac file names
+lib/File/Spec/OS2.pm portable operations on OS2 file names
+lib/File/Spec/Unix.pm portable operations on Unix file names
+lib/File/Spec/VMS.pm portable operations on VMS file names
+lib/File/Spec/Win32.pm portable operations on Win32 file names
+lib/File/stat.pm By-name interface to Perl's builtin stat
+lib/FileCache.pm Keep more files open than the system permits
+lib/FileHandle.pm Backward-compatible front end to IO extension
+lib/FindBin.pm Find name of currently executing program
+lib/Getopt/Long.pm Fetch command options (GetOptions)
+lib/Getopt/Std.pm Fetch command options (getopt, getopts)
+lib/I18N/Collate.pm Routines to do strxfrm-based collation
+lib/IPC/Open2.pm Open a two-ended pipe
+lib/IPC/Open3.pm Open a three-ended pipe!
+lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package
+lib/Math/BigInt.pm An arbitrary precision integer arithmetic package
+lib/Math/Complex.pm A Complex package
+lib/Math/Trig.pm A simple interface to complex trigonometry
+lib/Net/Ping.pm Hello, anybody home?
+lib/Net/hostent.pm By-name interface to Perl's builtin gethost*
+lib/Net/netent.pm By-name interface to Perl's builtin getnet*
+lib/Net/protoent.pm By-name interface to Perl's builtin getproto*
+lib/Net/servent.pm By-name interface to Perl's builtin getserv*
+lib/Pod/Functions.pm used by pod/splitpod
+lib/Pod/Html.pm Convert POD data to HTML
+lib/Pod/Text.pm Convert POD data to formatted ASCII text
+lib/Search/Dict.pm Perform binary search on dictionaries
+lib/SelectSaver.pm Enforce proper select scoping
+lib/SelfLoader.pm Load functions only on demand
+lib/Shell.pm Make AUTOLOADed system() calls
+lib/Symbol.pm Symbol table manipulation routines
+lib/Sys/Hostname.pm Hostname methods
+lib/Sys/Syslog.pm Perl module supporting syslogging
+lib/Term/Cap.pm Perl module supporting termcap usage
+lib/Term/Complete.pm A command completion subroutine
+lib/Term/ReadLine.pm Stub readline library
+lib/Test.pm A simple framework for writing test scripts
+lib/Test/Harness.pm A test harness
+lib/Text/Abbrev.pm An abbreviation table builder
+lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter
+lib/Text/Soundex.pm Perl module to implement Soundex
+lib/Text/Tabs.pm Do expand and unexpand
+lib/Text/Wrap.pm Paragraph formatter
+lib/Tie/Array.pm Base class for tied arrays
+lib/Tie/Handle.pm Base class for tied handles
+lib/Tie/Hash.pm Base class for tied hashes
+lib/Tie/RefHash.pm Base class for tied hashes with references as keys
+lib/Tie/Scalar.pm Base class for tied scalars
+lib/Tie/SubstrHash.pm Compact hash for known key, value and table size
+lib/Time/Local.pm Reverse translation of localtime, gmtime
+lib/Time/gmtime.pm By-name interface to Perl's builtin gmtime
+lib/Time/localtime.pm By-name interface to Perl's builtin localtime
+lib/Time/tm.pm Internal object for Time::{gm,local}time
+lib/UNIVERSAL.pm Base class for ALL classes
+lib/User/grent.pm By-name interface to Perl's builtin getgr*
+lib/User/pwent.pm By-name interface to Perl's builtin getpw*
+lib/abbrev.pl An abbreviation table builder
+lib/assert.pl assertion and panic with stack trace
+lib/autouse.pm Load and call a function only when it's used
+lib/base.pm Establish IS-A relationship at compile time
+lib/bigfloat.pl An arbitrary precision floating point package
+lib/bigint.pl An arbitrary precision integer arithmetic package
+lib/bigrat.pl An arbitrary precision rational arithmetic package
+lib/blib.pm For "use blib"
+lib/cacheout.pl Manages output filehandles when you need too many
+lib/chat2.pl Obsolete ipc library (use Comm.pm etc instead)
+lib/complete.pl A command completion subroutine
+lib/constant.pm For "use constant"
+lib/ctime.pl A ctime workalike
+lib/diagnostics.pm Print verbose diagnostics
+lib/dotsh.pl Code to "dot" in a shell script
+lib/dumpvar.pl A variable dumper
+lib/exceptions.pl catch and throw routines
+lib/fastcwd.pl a faster but more dangerous getcwd
+lib/fields.pm Set up object field names for pseudo-hash-using classes
+lib/find.pl A find emulator--used by find2perl
+lib/finddepth.pl A depth-first find emulator--used by find2perl
+lib/flush.pl Routines to do single flush
+lib/ftp.pl FTP code (obsolete, use Net::FTP instead)
+lib/getcwd.pl A getcwd() emulator
+lib/getopt.pl Perl library supporting option parsing
+lib/getopts.pl Perl library supporting option parsing
+lib/hostname.pl Old hostname code
+lib/importenv.pl Perl routine to get environment into variables
+lib/integer.pm For "use integer"
+lib/less.pm For "use less"
+lib/lib.pm For "use lib"
+lib/locale.pm For "use locale"
+lib/look.pl A "look" equivalent
+lib/newgetopt.pl A perl library supporting long option parsing
+lib/open2.pl Open a two-ended pipe (uses IPC::Open2)
+lib/open3.pl Open a three-ended pipe (uses IPC::Open3)
+lib/overload.pm Module for overloading perl operators
+lib/perl5db.pl Perl debugging routines
+lib/pwd.pl Routines to keep track of PWD environment variable
+lib/shellwords.pl Perl library to split into words with shell quoting
+lib/sigtrap.pm For trapping an abort and giving traceback
+lib/stat.pl Perl library supporting stat function
+lib/strict.pm For "use strict"
+lib/subs.pm Declare overriding subs
+lib/syslog.pl Perl library supporting syslogging
+lib/tainted.pl Old code for tainting
+lib/termcap.pl Perl library supporting termcap usage
+lib/timelocal.pl Perl library supporting inverse of localtime, gmtime
+lib/validate.pl Perl library supporting wholesale file mode validation
+lib/vars.pm Declare pseudo-imported global variables
+makeaperl.SH perl script that produces a new perl binary
+makedepend.SH Precursor to makedepend
+makedir.SH Precursor to makedir
+malloc.c A version of malloc you might not want
+mg.c Magic code
+mg.h Magic header
+minimod.pl Writes lib/ExtUtils/Miniperl.pm
+miniperlmain.c Basic perl w/o dynamic loading or extensions
+mpeix/mpeixish.h MPE/iX port
+mpeix/nm MPE/iX port
+mpeix/relink MPE/iX port
+mv-if-diff Script to mv a file if it changed
+myconfig Prints summary of the current configuration
+nostdio.h Cause compile error on stdio calls
+objpp.h Scoping macros for Perl Object
+op.c Opcode syntax tree code
+op.h Opcode syntax tree header
+opcode.h Automatically generated opcode header
+opcode.pl Opcode header generatore
+os2/Changes Changelog for OS/2 port
+os2/Makefile.SHs Shared library generation for OS/2
+os2/OS2/ExtAttr/Changes EA access module
+os2/OS2/ExtAttr/ExtAttr.pm EA access module
+os2/OS2/ExtAttr/ExtAttr.xs EA access module
+os2/OS2/ExtAttr/MANIFEST EA access module
+os2/OS2/ExtAttr/Makefile.PL EA access module
+os2/OS2/ExtAttr/myea.h EA access module
+os2/OS2/ExtAttr/t/os2_ea.t EA access module
+os2/OS2/ExtAttr/typemap EA access module
+os2/OS2/PrfDB/Changes System database access module
+os2/OS2/PrfDB/MANIFEST System database access module
+os2/OS2/PrfDB/Makefile.PL System database access module
+os2/OS2/PrfDB/PrfDB.pm System database access module
+os2/OS2/PrfDB/PrfDB.xs System database access module
+os2/OS2/PrfDB/t/os2_prfdb.t System database access module
+os2/OS2/PrfDB/typemap System database access module
+os2/OS2/Process/MANIFEST system() constants in a module
+os2/OS2/Process/Makefile.PL system() constants in a module
+os2/OS2/Process/Process.pm system() constants in a module
+os2/OS2/Process/Process.xs system() constants in a module
+os2/OS2/REXX/Changes DLL access module
+os2/OS2/REXX/MANIFEST DLL access module
+os2/OS2/REXX/Makefile.PL DLL access module
+os2/OS2/REXX/REXX.pm DLL access module
+os2/OS2/REXX/REXX.xs DLL access module
+os2/OS2/REXX/t/rx_cmprt.t DLL access module
+os2/OS2/REXX/t/rx_dllld.t DLL access module
+os2/OS2/REXX/t/rx_objcall.t DLL access module
+os2/OS2/REXX/t/rx_sql.test DLL access module
+os2/OS2/REXX/t/rx_tiesql.test DLL access module
+os2/OS2/REXX/t/rx_tievar.t DLL access module
+os2/OS2/REXX/t/rx_tieydb.t DLL access module
+os2/OS2/REXX/t/rx_varset.t DLL access module
+os2/OS2/REXX/t/rx_vrexx.t DLL access module
+os2/POSIX.mkfifo POSIX.xs patch
+os2/diff.configure Patches to Configure
+os2/dl_os2.c Addon for dl_open
+os2/dlfcn.h Addon for dl_open
+os2/os2.c Additional code for OS/2
+os2/os2.sym Additional symbols to export
+os2/os2ish.h Header for OS/2
+os2/os2thread.h pthread-like typedefs
+os2/perl2cmd.pl Corrects installed binaries under OS/2
+patchlevel.h The current patch level of perl
+perl.c main()
+perl.h Global declarations
+perl_exp.SH Creates list of exported symbols for AIX
+perlio.c C code for PerlIO abstraction
+perlio.h compatibility stub
+perlio.sym Symbols for PerlIO abstraction
+perlsdio.h Fake stdio using perlio
+perlsfio.h Prototype sfio mapping for PerlIO
+perlsh A poor man's perl shell
+perlvars.h Global variables
+perly.c A byacc'ed perly.y
+perly_c.diff Fixup perly.c to allow recursion
+perly.fixer A program to remove yacc stack limitations
+perly.h The header file for perly.c
+perly.y Yacc grammar for perl
+plan9/aperl Shell to make Perl error messages Acme-friendly
+plan9/arpa/inet.h Plan9 port: replacement C header file
+plan9/buildinfo Plan9 port: configuration information
+plan9/config.plan9 Plan9 port: config.h template
+plan9/exclude Plan9 port: tests to skip
+plan9/fndvers Plan9 port: update Perl version in config.plan9
+plan9/genconfig.pl Plan9 port: generate config.sh
+plan9/mkfile Plan9 port: Mk driver for build
+plan9/myconfig.plan9 Plan9 port: script to print config summary
+plan9/perlplan9.doc Plan9 port: Plan9-specific formatted documentation
+plan9/perlplan9.pod Plan9 port: Plan9-specific pod documentation
+plan9/plan9.c Plan9 port: Plan9-specific C routines
+plan9/plan9ish.h Plan9 port: Plan9-specific C header file
+plan9/setup.rc Plan9 port: script for easy build+install
+plan9/versnum Plan9 port: script to print version number
+pod/Makefile Make pods into something else
+pod/buildtoc generate perltoc.pod
+pod/checkpods.PL Tool to check for common errors in pods
+pod/perl.pod Top level perl man page
+pod/perlapio.pod IO API info
+pod/perlbook.pod Book info
+pod/perlbot.pod Object-oriented Bag o' Tricks
+pod/perlcall.pod Callback info
+pod/perldata.pod Data structure info
+pod/perldebug.pod Debugger info
+pod/perldelta.pod Changes since last version
+pod/perl5004delta.pod Changes from 5.003 to 5.004
+pod/perldiag.pod Diagnostic info
+pod/perldsc.pod Data Structures Cookbook
+pod/perlembed.pod Embedding info
+pod/perlfaq.pod Frequently Asked Questions, Top Level
+pod/perlfaq1.pod Frequently Asked Questions, Part 1
+pod/perlfaq2.pod Frequently Asked Questions, Part 2
+pod/perlfaq3.pod Frequently Asked Questions, Part 3
+pod/perlfaq4.pod Frequently Asked Questions, Part 4
+pod/perlfaq5.pod Frequently Asked Questions, Part 5
+pod/perlfaq6.pod Frequently Asked Questions, Part 6
+pod/perlfaq7.pod Frequently Asked Questions, Part 7
+pod/perlfaq8.pod Frequently Asked Questions, Part 8
+pod/perlfaq9.pod Frequently Asked Questions, Part 9
+pod/perlform.pod Format info
+pod/perlfunc.pod Function info
+pod/perlguts.pod Internals info
+pod/perlhist.pod Perl history info
+pod/perlipc.pod IPC info
+pod/perllocale.pod Locale support info
+pod/perllol.pod How to use lists of lists
+pod/perlmod.pod Module mechanism info
+pod/perlmodinstall.pod Installing CPAN Modules
+pod/perlmodlib.pod Module policy info
+pod/perlobj.pod Object info
+pod/perlop.pod Operator info
+pod/perlpod.pod Pod info
+pod/perlport.pod Portability guide
+pod/perlre.pod Regular expression info
+pod/perlref.pod References info
+pod/perlrun.pod Execution info
+pod/perlsec.pod Security info
+pod/perlstyle.pod Style info
+pod/perlsub.pod Subroutine info
+pod/perlsyn.pod Syntax info
+pod/perltie.pod Tieing an object class into a simple variable
+pod/perltoc.pod Table of Contents info
+pod/perltoot.pod Tom's object-oriented tutorial
+pod/perltrap.pod Trap info
+pod/perlvar.pod Variable info
+pod/perlxs.pod XS api info
+pod/perlxstut.pod XS tutorial
+pod/pod2html.PL Precursor for translator to turn pod into HTML
+pod/pod2latex.PL Precursor for translator to turn pod into LaTeX
+pod/pod2man.PL Precursor for translator to turn pod into manpage
+pod/pod2text.PL Precursor for translator to turn pod into text
+pod/roffitall troff the whole man page set
+pod/rofftoc Generate a table of contents in troff format
+pod/splitman Splits perlfunc into multiple man pages
+pod/splitpod Splits perlfunc into multiple pod pages
+pp.c Push/Pop code
+pp.h Push/Pop code defs
+pp_ctl.c Push/Pop code for control flow
+pp_hot.c Push/Pop code for heavily used opcodes
+pp_proto.h C++ definitions for Push/Pop code
+pp_sys.c Push/Pop code for system interaction
+proto.h Prototypes
+qnx/ar QNX implementation of "ar" utility
+qnx/cpp QNX implementation of preprocessor filter
+regcomp.c Regular expression compiler
+regcomp.h Private declarations for above
+regcomp.pl Builder of regnodes.h
+regcomp.sym Data for regnodes.h
+regexec.c Regular expression evaluator
+regexp.h Public declarations for the above
+regnodes.h Description of nodes of RE engine
+run.c The interpreter loop
+scope.c Scope entry and exit code
+scope.h Scope entry and exit header
+sv.c Scalar value code
+sv.h Scalar value header
+t/README Instructions for regression tests
+t/TEST The regression tester
+t/base/cond.t See if conditionals work
+t/base/if.t See if if works
+t/base/lex.t See if lexical items work
+t/base/pat.t See if pattern matching works
+t/base/rs.t See if record-read works
+t/base/term.t See if various terms work
+t/cmd/elsif.t See if else-if works
+t/cmd/for.t See if for loops work
+t/cmd/mod.t See if statement modifiers work
+t/cmd/subval.t See if subroutine values work
+t/cmd/switch.t See if switch optimizations work
+t/cmd/while.t See if while loops work
+t/comp/cmdopt.t See if command optimization works
+t/comp/colon.t See if colons are parsed correctly
+t/comp/cpp.aux main file for cpp.t
+t/comp/cpp.t See if C preprocessor works
+t/comp/decl.t See if declarations work
+t/comp/multiline.t See if multiline strings work
+t/comp/package.t See if packages work
+t/comp/proto.t See if function prototypes work
+t/comp/redef.t See if we get correct warnings on redefined subs
+t/comp/require.t See if require works
+t/comp/script.t See if script invokation works
+t/comp/term.t See if more terms work
+t/comp/use.t See if pragmas work
+t/harness Finer diagnostics from test suite
+t/io/argv.t See if ARGV stuff works
+t/io/dup.t See if >& works right
+t/io/fs.t See if directory manipulations work
+t/io/inplace.t See if inplace editing works
+t/io/iprefix.t See if inplace editing works with prefixes
+t/io/pipe.t See if secure pipes work
+t/io/print.t See if print commands work
+t/io/read.t See if read works
+t/io/tell.t See if file seeking works
+t/lib/abbrev.t See if Text::Abbrev works
+t/lib/anydbm.t See if AnyDBM_File works
+t/lib/autoloader.t See if AutoLoader works
+t/lib/basename.t See if File::Basename works
+t/lib/bigint.t See if bigint.pl works
+t/lib/bigintpm.t See if BigInt.pm works
+t/lib/cgi-form.t See if CGI.pm works
+t/lib/cgi-function.t See if CGI.pm works
+t/lib/cgi-html.t See if CGI.pm works
+t/lib/cgi-request.t See if CGI.pm works
+t/lib/checktree.t See if File::CheckTree works
+t/lib/complex.t See if Math::Complex works
+t/lib/db-btree.t See if DB_File works
+t/lib/db-hash.t See if DB_File works
+t/lib/db-recno.t See if DB_File works
+t/lib/dirhand.t See if DirHandle works
+t/lib/dosglob.t See if File::DosGlob works
+t/lib/dumper-ovl.t See if Data::Dumper works for overloaded data
+t/lib/dumper.t See if Data::Dumper works
+t/lib/english.t See if English works
+t/lib/env.t See if Env works
+t/lib/errno.t See if Errno works
+t/lib/fields.t See if base/fields works
+t/lib/filecache.t See if FileCache works
+t/lib/filecopy.t See if File::Copy works
+t/lib/filefind.t See if File::Find works
+t/lib/filehand.t See if FileHandle works
+t/lib/filepath.t See if File::Path works
+t/lib/filespec.t See if File::Spec works
+t/lib/findbin.t See if FindBin works
+t/lib/gdbm.t See if GDBM_File works
+t/lib/getopt.t See if Getopt::Std and Getopt::Long works
+t/lib/h2ph.h Test header file for h2ph
+t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison
+t/lib/h2ph.t See if h2ph works like it should
+t/lib/hostname.t See if Sys::Hostname works
+t/lib/io_dup.t See if dup()-related methods from IO work
+t/lib/io_pipe.t See if pipe()-related methods from IO work
+t/lib/io_sel.t See if select()-related methods from IO work
+t/lib/io_sock.t See if INET socket-related methods from IO work
+t/lib/io_taint.t See if the untaint method from IO works
+t/lib/io_tell.t See if seek()/tell()-related methods from IO work
+t/lib/io_udp.t See if UDP socket-related methods from IO work
+t/lib/io_xs.t See if XSUB methods from IO work
+t/lib/ipc_sysv.t See if IPC::SysV works
+t/lib/ndbm.t See if NDBM_File works
+t/lib/odbm.t See if ODBM_File works
+t/lib/opcode.t See if Opcode works
+t/lib/open2.t See if IPC::Open2 works
+t/lib/open3.t See if IPC::Open3 works
+t/lib/ops.t See if Opcode works
+t/lib/parsewords.t See if Text::ParseWords works
+t/lib/ph.t See if h2ph works
+t/lib/posix.t See if POSIX works
+t/lib/safe1.t See if Safe works
+t/lib/safe2.t See if Safe works
+t/lib/sdbm.t See if SDBM_File works
+t/lib/searchdict.t See if Search::Dict works
+t/lib/selectsaver.t See if SelectSaver works
+t/lib/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/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
+t/lib/tie-stdpush.t Test for Tie::StdArray
+t/lib/timelocal.t See if Time::Local works
+t/lib/trig.t See if Math::Trig works
+t/op/append.t See if . works
+t/op/arith.t See if arithmetic works
+t/op/array.t See if array operations work
+t/op/assignwarn.t See if OP= operators warn correctly for undef targets
+t/op/auto.t See if autoincrement et all work
+t/op/avhv.t See if pseudo-hashes work
+t/op/bop.t See if bitops work
+t/op/chop.t See if chop works
+t/op/closure.t See if closures work
+t/op/cmp.t See if the various string and numeric compare work
+t/op/cond.t See if conditional expressions work
+t/op/context.t See if context propagation works
+t/op/defins.t See if auto-insert of defined() works
+t/op/delete.t See if delete works
+t/op/die.t See if die works
+t/op/die_exit.t See if die and exit status interaction works
+t/op/do.t See if subroutines work
+t/op/each.t See if hash iterators work
+t/op/eval.t See if eval operator works
+t/op/exec.t See if exec and system work
+t/op/exp.t See if math functions work
+t/op/flip.t See if range operator works
+t/op/fork.t See if fork works
+t/op/glob.t See if <*> works
+t/op/goto.t See if goto works
+t/op/goto_xs.t See if "goto &sub" works on XSUBs
+t/op/groups.t See if $( works
+t/op/gv.t See if typeglobs work
+t/op/hashwarn.t See if warnings for bad hash assignments work
+t/op/inc.t See if inc/dec of integers near 32 bit limit work
+t/op/index.t See if index works
+t/op/int.t See if int works
+t/op/join.t See if join works
+t/op/list.t See if array lists work
+t/op/local.t See if local works
+t/op/magic.t See if magic variables work
+t/op/method.t See if method calls work
+t/op/misc.t See if miscellaneous bugs have been fixed
+t/op/mkdir.t See if mkdir works
+t/op/my.t See if lexical scoping works
+t/op/nothread.t local @_ test which does not work threaded
+t/op/oct.t See if oct and hex work
+t/op/ord.t See if ord works
+t/op/pack.t See if pack and unpack work
+t/op/pat.t See if esoteric patterns work
+t/op/pos.t See if pos works
+t/op/push.t See if push and pop work
+t/op/quotemeta.t See if quotemeta works
+t/op/rand.t See if rand works
+t/op/range.t See if .. works
+t/op/re_tests Regular expressions for regexp.t
+t/op/read.t See if read() works
+t/op/readdir.t See if readdir() works
+t/op/recurse.t See if deep recursion works
+t/op/ref.t See if refs and objects work
+t/op/regexp.t See if regular expressions work
+t/op/regexp_noamp.t See if regular expressions work with optimizations
+t/op/repeat.t See if x operator works
+t/op/runlevel.t See if die() works from perl_call_*()
+t/op/sleep.t See if sleep works
+t/op/sort.t See if sort works
+t/op/splice.t See if splice works
+t/op/split.t See if split works
+t/op/sprintf.t See if sprintf works
+t/op/stat.t See if stat works
+t/op/study.t See if study works
+t/op/subst.t See if substitution works
+t/op/substr.t See if substr works
+t/op/sysio.t See if sysread and syswrite work
+t/op/taint.t See if tainting works
+t/op/tie.t See if tie/untie functions work
+t/op/tiearray.t See if tie for arrays works
+t/op/tiehandle.t See if tie for handles works
+t/op/time.t See if time functions work
+t/op/undef.t See if undef works
+t/op/universal.t See if UNIVERSAL class works
+t/op/unshift.t See if unshift works
+t/op/vec.t See if vectors work
+t/op/wantarray.t See if wantarray works
+t/op/write.t See if write works
+t/pragma/constant.t See if compile-time constants work
+t/pragma/locale.t See if locale support (i18n and l10n) works
+t/pragma/overload.t See if operator overloading works
+t/pragma/strict-refs Tests of "use strict 'refs'" for strict.t
+t/pragma/strict-subs Tests of "use strict 'subs'" for strict.t
+t/pragma/strict-vars Tests of "use strict 'vars'" for strict.t
+t/pragma/strict.t See if strictures work
+t/pragma/subs.t See if subroutine pseudo-importation works
+t/pragma/warn-1global Tests of global warnings for warning.t
+t/pragma/warning.t See if warning controls work
+taint.c Tainting code
+thrdvar.h Per-thread variables
+thread.h Threading header
+thread.sym Symbols for threads
+toke.c The tokener
+universal.c The default UNIVERSAL package methods
+unixish.h Defines that are assumed on Unix
+util.c Utility routines
+util.h Dummy header
+utils/Makefile Extract the utility scripts
+utils/c2ph.PL program to translate dbx stabs to perl
+utils/h2ph.PL A thing to turn C .h files into perl .ph files
+utils/h2xs.PL Program to make .xs files from C header files
+utils/perlbug.PL A simple tool to submit a bug report
+utils/perlcc.PL Front-end for compiler
+utils/perldoc.PL A simple tool to find & display perl's documentation
+utils/pl2pm.PL A pl to pm translator
+utils/splain.PL Stand-alone version of diagnostics.pm
+vms/descrip_mms.template Template MM[SK] description file for build
+vms/ext/DCLsym/0README.txt ReadMe file for VMS::DCLsym
+vms/ext/DCLsym/DCLsym.pm Perl access to CLI symbols
+vms/ext/DCLsym/DCLsym.xs Perl access to CLI symbols
+vms/ext/DCLsym/Makefile.PL MakeMaker driver for VMS::DCLsym
+vms/ext/DCLsym/test.pl regression tests for VMS::DCLsym
+vms/ext/Filespec.pm VMS-Unix file syntax interconversion
+vms/ext/Stdio/0README.txt ReadMe file for VMS::Stdio
+vms/ext/Stdio/Makefile.PL MakeMaker driver for VMS::Stdio
+vms/ext/Stdio/Stdio.pm VMS options to stdio routines
+vms/ext/Stdio/Stdio.xs VMS options to stdio routines
+vms/ext/Stdio/test.pl regression tests for VMS::Stdio
+vms/ext/XSSymSet.pm manage linker symbols when building extensions
+vms/ext/filespec.t See if VMS::Filespec funtions work
+vms/ext/vmsish.pm Control VMS-specific behavior of Perl core
+vms/ext/vmsish.t Tests for vmsish.pm
+vms/gen_shrfls.pl generate options files and glue for shareable image
+vms/genconfig.pl retcon config.sh from config.h
+vms/genopt.com hack to write options files in case of broken makes
+vms/make_command.com record MM[SK] command used to build Perl
+vms/mms2make.pl convert descrip.mms to make syntax
+vms/munchconfig.c performs shell $var substitution for VMS
+vms/myconfig.com record local configuration info for bug report
+vms/perlvms.pod VMS-specific additions to Perl documentation
+vms/perly_c.vms perly.c with fixed declarations for global syms
+vms/perly_h.vms perly.h with fixed declarations for global syms
+vms/sockadapt.c glue for SockshShr socket support
+vms/sockadapt.h glue for SockshShr socket support
+vms/subconfigure.com performs compiler checks and writes config.sh, config.h, and descrip.mms
+vms/test.com DCL driver for regression tests
+vms/vms.c VMS-specific C code for Perl core
+vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms
+vms/vmsish.h VMS-specific C header for Perl core
+vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions
+win32/GenCAPI.pl Win32 port for C API with PERL_OBJECT
+win32/Makefile Win32 makefile for NMAKE (Visual C++ build)
+win32/TEST Win32 port
+win32/autosplit.pl Win32 port
+win32/bin/network.pl Win32 port
+win32/bin/perlglob.pl Win32 globbing
+win32/bin/pl2bat.pl wrap perl scripts into batch files
+win32/bin/runperl.pl run perl script via batch file namesake
+win32/bin/search.pl Win32 port
+win32/bin/webget.pl Win32 port
+win32/bin/www.pl Win32 port
+win32/config.bc Win32 base line config.sh (Borland C++ build)
+win32/config.gc Win32 base line config.sh (mingw32/gcc build)
+win32/config.vc Win32 base line config.sh (Visual C++ build)
+win32/config_H.bc Win32 config header (Borland C++ build)
+win32/config_H.gc Win32 config header (GNU build)?
+win32/config_H.vc Win32 config header (Visual C++ build)
+win32/config_h.PL Perl code to convert Win32 config.sh to config.h
+win32/config_sh.PL Perl code to update Win32 config.sh from Makefile
+win32/des_fcrypt.patch Win32 port
+win32/dl_win32.xs Win32 port
+win32/genxsdef.pl Win32 port
+win32/include/arpa/inet.h Win32 port
+win32/include/dirent.h Win32 port
+win32/include/netdb.h Win32 port
+win32/include/sys/socket.h Win32 port
+win32/makedef.pl Win32 port
+win32/makefile.mk Win32 makefile for DMAKE (BC++, VC++ builds)
+win32/makemain.pl Win32 port
+win32/makeperldef.pl Win32 port
+win32/perlglob.c Win32 port
+win32/perlhost.h Perl host implementation
+win32/perllib.c Win32 port
+win32/pod.mak Win32 port
+win32/runperl.c Win32 port
+win32/splittree.pl Win32 port
+win32/win32.c Win32 port
+win32/win32.h Win32 port
+win32/win32iop.h Win32 port
+win32/win32sck.c Win32 port
+win32/win32thread.c Win32 functions for threads
+win32/win32thread.h Win32 port mapping to threads
+writemain.SH Generate perlmain.c from miniperlmain.c+extensions
+x2p/EXTERN.h Same as above
+x2p/INTERN.h Same as above
+x2p/Makefile.SH Precursor to Makefile
+x2p/a2p.c Output of a2p.y run through byacc
+x2p/a2p.h Global declarations
+x2p/a2p.pod Pod for awk to perl translator
+x2p/a2p.y A yacc grammer for awk
+x2p/a2py.c Awk compiler, sort of
+x2p/cflags.SH A script that emits C compilation flags per file
+x2p/find2perl.PL A find to perl translator
+x2p/hash.c Hashes again
+x2p/hash.h Public declarations for the above
+x2p/proto.h Dummy header
+x2p/s2p.PL Sed to perl translator
+x2p/str.c String handling package
+x2p/str.h Public declarations for the above
+x2p/util.c Utility routines
+x2p/util.h Public declarations for the above
+x2p/walk.c Parse tree walker
diff --git a/contrib/perl5/Makefile.SH b/contrib/perl5/Makefile.SH
new file mode 100755
index 000000000000..050e471e7d7b
--- /dev/null
+++ b/contrib/perl5/Makefile.SH
@@ -0,0 +1,646 @@
+#! /bin/sh
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+
+case "$d_dosuid" in
+*define*) suidperl='suidperl' ;;
+*) suidperl='';;
+esac
+
+linklibperl='$(LIBPERL)'
+shrpldflags='$(LDDLFLAGS)'
+ldlibpth=''
+case "$useshrplib" in
+true)
+ # Prefix all runs of 'miniperl' and 'perl' with
+ # $ldlibpth so that ./perl finds *this* libperl.so.
+ ldlibpth="LD_LIBRARY_PATH=`pwd`:$LD_LIBRARY_PATH"
+
+ pldlflags="$cccdlflags"
+ # NeXT-4 specific stuff. Can't we do this in the hint file?
+ case "${osname}${osvers}" in
+ next4*)
+ ld=libtool
+ lddlflags="-dynamic -undefined warning -framework System \
+ -compatibility_version 1 -current_version $patchlevel \
+ -prebind -seg1addr 0x27000000 -install_name \$(shrpdir)/\$@"
+ # NeXT uses a different name.
+ ldlibpth="DYLD_LIBRARY_PATH=`pwd`:$DYLD_LIBRARY_PATH"
+ ;;
+ os2*) # OS/2 doesn't need anything special for LD_LIBRARY_PATH.
+ ldlibpth=''
+ ;;
+ sunos*|freebsd[23]*|netbsd*)
+ linklibperl="-lperl"
+ ;;
+ aix*)
+ shrpldflags="-H512 -T512 -bhalt:4 -bM:SRE -bE:perl.exp"
+ case "$osvers" in
+ 3*)
+ shrpldflags="$shrpldflags -e _nostart $ldflags $libs $cryptlib"
+ ;;
+ *)
+ shrpldflags="$shrpldflags -b noentry $ldflags $libs $cryptlib"
+ ;;
+ esac
+ aixinstdir=`pwd | sed 's/\/UU$//'`
+ linklibperl="-L $archlibexp/CORE -L $aixinstdir -lperl"
+ ;;
+ hpux10*)
+ linklibperl="-L `pwd | sed 's/\/UU$//'` -Wl,+b$archlibexp/CORE -lperl"
+ ;;
+ esac
+ ;;
+*) pldlflags=''
+ ;;
+esac
+
+: Prepare dependency lists for Makefile.
+dynamic_list=' '
+for f in $dynamic_ext; do
+ : the dependency named here will never exist
+ base=`echo "$f" | sed 's/.*\///'`
+ dynamic_list="$dynamic_list lib/auto/$f/$base.$dlext"
+done
+
+static_list=' '
+for f in $static_ext; do
+ base=`echo "$f" | sed 's/.*\///'`
+ static_list="$static_list lib/auto/$f/$base\$(LIB_EXT)"
+done
+
+nonxs_list=' '
+for f in $nonxs_ext; do
+ base=`echo "$f" | sed 's/.*\///'`
+ nonxs_list="$nonxs_list ext/$f/pm_to_blib"
+done
+
+echo "Extracting Makefile (with variable substitutions)"
+$spitshell >Makefile <<!GROK!THIS!
+# Makefile.SH
+# This file is derived from Makefile.SH. Any changes made here will
+# be lost the next time you run Configure.
+# Makefile is used to generate $firstmakefile. The only difference
+# is that $firstmakefile has the dependencies filled in at the end.
+#
+#
+# I now supply perly.c with the kits, so don't remake perly.c without byacc
+BYACC = $byacc
+CC = $cc
+LD = $ld
+
+LDFLAGS = $ldflags
+CLDFLAGS = $ldflags
+
+SMALL = $small
+LARGE = $large $split
+mallocsrc = $mallocsrc
+mallocobj = $mallocobj
+LNS = $lns
+RMS = rm -f
+ranlib = $ranlib
+
+# The following are mentioned only to make metaconfig include the
+# appropriate questions in Configure. If you want to change these,
+# edit config.sh instead, or specify --man1dir=/wherever on
+# installman commandline.
+bin = $installbin
+scriptdir = $scriptdir
+shrpdir = $archlibexp/CORE
+privlib = $installprivlib
+man1dir = $man1dir
+man1ext = $man1ext
+man3dir = $man3dir
+man3ext = $man3ext
+
+# The following are used to build and install shared libraries for
+# dynamic loading.
+LDDLFLAGS = $lddlflags
+SHRPLDFLAGS = $shrpldflags
+CCDLFLAGS = $ccdlflags
+DLSUFFIX = .$dlext
+PLDLFLAGS = $pldlflags
+LIBPERL = $libperl
+LLIBPERL= $linklibperl
+SHRPENV = $shrpenv
+
+# The following is used to include the current directory in
+# LD_LIBRARY_PATH if you are building a shared libperl.so.
+LDLIBPTH = $ldlibpth
+
+dynamic_ext = $dynamic_list
+static_ext = $static_list
+nonxs_ext = $nonxs_list
+ext = \$(dynamic_ext) \$(static_ext) \$(nonxs_ext)
+DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
+
+libs = $libs $cryptlib
+
+public = perl $suidperl utilities translators
+
+shellflags = $shellflags
+
+# This is set to MAKE=$make if your $make command doesn't
+# do it for you.
+$make_set_make
+
+# These variables may need to be manually set for non-Unix systems.
+AR = $ar
+EXE_EXT = $_exe
+LIB_EXT = $_a
+OBJ_EXT = $_o
+PATH_SEP = $p_
+
+FIRSTMAKEFILE = $firstmakefile
+
+# Any special object files needed by this architecture, e.g. os2/os2.obj
+ARCHOBJS = $archobjs
+
+.SUFFIXES: .c \$(OBJ_EXT)
+
+# grrr
+SHELL = $sh
+
+# how to tr(anslate) newlines
+TRNL = '$trnl'
+
+!GROK!THIS!
+
+## In the following dollars and backticks do not need the extra backslash.
+$spitshell >>Makefile <<'!NO!SUBS!'
+
+CCCMD = `sh $(shellflags) cflags $(LIBPERL) $@`
+
+private = preplibrary lib/ExtUtils/Miniperl.pm lib/Config.pm
+
+# Files to be built with variable substitution before miniperl
+# is available.
+sh = Makefile.SH cflags.SH config_h.SH makeaperl.SH makedepend.SH \
+ makedir.SH perl_exp.SH writemain.SH
+
+shextract = Makefile cflags config.h makeaperl makedepend \
+ makedir perl.exp writemain
+
+# Files to be built with variable substitution after miniperl is
+# available. Dependencies handled manually below (for now).
+
+pl = pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL
+
+plextract = pod/pod2html pod/pod2latex pod/pod2man pod/pod2text
+
+addedbyconf = UU $(shextract) $(plextract) pstruct
+
+h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h
+h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
+h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h
+h4 = regexp.h scope.h sv.h unixish.h util.h iperlsys.h thread.h
+h5 = bytecode.h byterun.h
+h = $(h1) $(h2) $(h3) $(h4) $(h5)
+
+c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c byterun.c
+c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c
+c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c globals.c perlio.c
+
+c = $(c1) $(c2) $(c3) miniperlmain.c perlmain.c
+
+obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) byterun$(OBJ_EXT)
+obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
+obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT)
+
+obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
+
+# Once perl has been Configure'd and built ok you build different
+# perl variants (Debugging, Embedded, Multiplicity etc) by saying:
+# make clean; make LIBPERL=libperl<type>.a
+# where <type> is some combination of 'd' and(or) 'e' or 'm'.
+# See cflags to understand how this works.
+#
+# This mechanism is getting clunky and might not even work any more.
+# EMBEDDING is on by default, and MULTIPLICITY doesn't work.
+#
+
+lintflags = -hbvxac
+
+.c$(OBJ_EXT):
+ $(CCCMD) $(PLDLFLAGS) $*.c
+
+all: $(FIRSTMAKEFILE) miniperl $(private) $(plextract) $(public) $(dynamic_ext) $(nonxs_ext)
+ @echo " ";
+ @echo " Everything is up to date. 'make test' to run test suite."
+
+compile: all
+ echo "testing compilation" > testcompile;
+ cd utils; $(MAKE) compile;
+ cd x2p; $(MAKE) compile;
+ cd pod; $(MAKE) compile;
+
+translators: miniperl lib/Config.pm FORCE
+ @echo " "; echo " Making x2p stuff"; cd x2p; $(LDLIBPTH) $(MAKE) all
+
+utilities: miniperl lib/Config.pm FORCE
+ @echo " "; echo " Making utilities"; cd utils; $(LDLIBPTH) $(MAKE) all
+
+
+# This is now done by installman only if you actually want the man pages.
+# @echo " "; echo " Making docs"; cd pod; $(MAKE) all;
+
+# Phony target to force checking subdirectories.
+# Apparently some makes require an action for the FORCE target.
+FORCE:
+ @sh -c true
+
+miniperlmain$(OBJ_EXT): miniperlmain.c
+ $(CCCMD) $(PLDLFLAGS) $*.c
+
+perlmain.c: miniperlmain.c config.sh $(FIRSTMAKEFILE)
+ sh writemain $(DYNALOADER) $(static_ext) > tmp
+ sh mv-if-diff tmp perlmain.c
+
+perlmain$(OBJ_EXT): perlmain.c
+ $(CCCMD) $(PLDLFLAGS) $*.c
+
+# The file ext.libs is a list of libraries that must be linked in
+# for static extensions, e.g. -lm -lgdbm, etc. The individual
+# static extension Makefile's add to it.
+ext.libs: $(static_ext)
+ -@test -f ext.libs || touch ext.libs
+
+!NO!SUBS!
+
+# How to build libperl. This is still rather convoluted.
+# Load up custom Makefile.SH fragment for shared loading and executables:
+if test -r $osname/Makefile.SHs ; then
+ . $osname/Makefile.SHs
+ $spitshell >>Makefile <<!GROK!THIS!
+
+Makefile: $osname/Makefile.SHs
+!GROK!THIS!
+else
+ $spitshell >>Makefile <<'!NO!SUBS!'
+$(LIBPERL): $& perl$(OBJ_EXT) $(obj)
+!NO!SUBS!
+ case "$useshrplib" in
+ true)
+ $spitshell >>Makefile <<'!NO!SUBS!'
+ $(LD) $(SHRPLDFLAGS) -o $@ perl$(OBJ_EXT) $(obj)
+!NO!SUBS!
+ case "$osname" in
+ aix)
+ $spitshell >>Makefile <<'!NO!SUBS!'
+ rm -f libperl$(OBJ_EXT)
+ mv $@ libperl$(OBJ_EXT)
+ $(AR) qv $(LIBPERL) libperl$(OBJ_EXT)
+!NO!SUBS!
+ ;;
+ esac
+ ;;
+ *)
+ $spitshell >>Makefile <<'!NO!SUBS!'
+ rm -f $(LIBPERL)
+ $(AR) rcu $(LIBPERL) perl$(OBJ_EXT) $(obj)
+ @$(ranlib) $(LIBPERL)
+!NO!SUBS!
+ ;;
+ esac
+ $spitshell >>Makefile <<'!NO!SUBS!'
+
+# How to build executables.
+
+# The $& notation tells Sequent machines that it can do a parallel make,
+# and is harmless otherwise.
+# The miniperl -w -MExporter line is a basic cheap test to catch errors
+# before make goes on to run preplibrary and then MakeMaker on extensions.
+# This is very handy because later errors are often caused by miniperl
+# build problems but that's not obvious to the novice.
+# The Module used here must not depend on Config or any extensions.
+
+miniperl: $& miniperlmain$(OBJ_EXT) $(LIBPERL)
+ $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL) $(libs)
+ $(LDLIBPTH) ./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest
+
+perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+
+pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ $(SHRPENV) $(LDLIBPTH) purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+
+purecovperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ $(SHRPENV) $(LDLIBPTH) purecov $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o purecovperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+
+quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ $(SHRPENV) $(LDLIBPTH) quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+
+# This version, if specified in Configure, does ONLY those scripts which need
+# set-id emulation. Suidperl must be setuid root. It contains the "taint"
+# checks as well as the special code to validate that the script in question
+# has been invoked correctly.
+
+suidperl: $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs)
+
+!NO!SUBS!
+
+fi
+
+$spitshell >>Makefile <<'!NO!SUBS!'
+
+sperl$(OBJ_EXT): perl.c perly.h patchlevel.h $(h)
+ $(RMS) sperl.c
+ $(LNS) perl.c sperl.c
+ $(CCCMD) -DIAMSUID sperl.c
+ $(RMS) sperl.c
+
+# We have to call our ./makedir because Ultrix 4.3 make can't handle the line
+# test -d lib/auto || mkdir lib/auto
+#
+preplibrary: miniperl lib/Config.pm $(plextract)
+ @sh ./makedir lib/auto
+ @echo " AutoSplitting perl library"
+ $(LDLIBPTH) ./miniperl -Ilib -e 'use AutoSplit; \
+ autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm
+
+# Take care to avoid modifying lib/Config.pm without reason
+# (If trying to create a new port and having problems with the configpm script,
+# try 'make minitest' and/or commenting out the tests at the end of configpm.)
+lib/Config.pm: config.sh miniperl configpm
+ $(LDLIBPTH) ./miniperl configpm tmp
+ sh mv-if-diff tmp $@
+
+lib/ExtUtils/Miniperl.pm: miniperlmain.c miniperl minimod.pl lib/Config.pm
+ $(LDLIBPTH) ./miniperl minimod.pl > tmp
+ sh mv-if-diff tmp $@
+
+lib/re.pm: ext/re/re.pm
+ rm -f $@
+ cat ext/re/re.pm > $@
+
+$(plextract): miniperl lib/Config.pm lib/re.pm
+ $(LDLIBPTH) ./miniperl -Ilib $@.PL
+
+install: all install.perl install.man
+
+install.perl: all installperl
+ if [ -n "$(COMPILE)" ]; \
+ then \
+ cd utils; $(MAKE) compile; \
+ cd ../x2p; $(MAKE) compile; \
+ cd ../pod; $(MAKE) compile; \
+ else :; \
+ fi
+ $(LDLIBPTH) ./perl installperl
+
+install.man: all installman
+ $(LDLIBPTH) ./perl installman
+
+# XXX Experimental. Hardwired values, but useful for testing.
+# Eventually Configure could ask for some of these values.
+install.html: all installhtml
+ $(LDLIBPTH) ./perl installhtml \
+ --podroot=. --podpath=. --recurse \
+ --htmldir=$(privlib)/html \
+ --htmlroot=$(privlib)/html \
+ --splithead=pod/perlipc \
+ --splititem=pod/perlfunc \
+ --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \
+ --verbose
+
+
+# I now supply perly.c with the kits, so the following section is
+# used only if you force byacc to run by saying
+# make run_byacc
+# Since we patch up the byacc output, the perly.fixer script needs
+# to run with precisely the same version of byacc as I use. You
+# normally shouldn't remake perly.[ch].
+
+run_byacc: FORCE
+ @ echo 'Expect' 113 shift/reduce and 1 reduce/reduce conflict
+ $(BYACC) -d perly.y
+ chmod 664 perly.c
+ sh $(shellflags) ./perly.fixer y.tab.c perly.c
+ sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' \
+ -e 's/y\.tab/perly/g' perly.c >perly.tmp && mv perly.tmp perly.c
+ echo 'extern YYSTYPE yylval;' >>y.tab.h
+ cmp -s y.tab.h perly.h && rm -f y.tab.h || mv y.tab.h perly.h
+ chmod 664 vms/perly_c.vms vms/perly_h.vms
+ perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms
+
+# We don't want to regenerate perly.c and perly.h, but they might
+# appear out-of-date after a patch is applied or a new distribution is
+# made.
+perly.c: perly.y
+ -@sh -c true
+
+perly.h: perly.y
+ -@sh -c true
+
+# No compat3.sym here since and including the 5.004_50.
+SYM = global.sym interp.sym perlio.sym thread.sym
+
+SYMH = perlvars.h thrdvar.h
+
+# The following files are generated automatically
+# keywords.h: keywords.pl
+# opcode.h: opcode.pl
+# embed.h: embed.pl global.sym interp.sym
+# byterun.h: bytecode.pl
+# byterun.c: bytecode.pl
+# lib/B/Asmdata.pm: bytecode.pl
+# regnodes.h: regcomp.pl
+# The correct versions should be already supplied with the perl kit,
+# in case you don't have perl available.
+# To force them to run, type
+# make regen_headers
+regen_headers: FORCE
+ perl keywords.pl
+ perl opcode.pl
+ perl embed.pl
+ perl bytecode.pl
+ perl regcomp.pl
+
+# Extensions:
+# Names added to $(dynamic_ext) or $(static_ext) or $(nonxs_ext) will
+# automatically get built. There should ordinarily be no need to change
+# any of this part of makefile.
+#
+# The dummy dependency is a place holder in case $(dynamic_ext) or
+# $(static_ext) is empty.
+#
+# DynaLoader may be needed for extensions that use Makefile.PL.
+
+$(DYNALOADER): miniperl preplibrary FORCE
+ @$(LDLIBPTH) sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
+
+d_dummy $(dynamic_ext): miniperl preplibrary $(DYNALOADER) FORCE
+ @$(LDLIBPTH) sh ext/util/make_ext dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
+
+s_dummy $(static_ext): miniperl preplibrary $(DYNALOADER) FORCE
+ @$(LDLIBPTH) sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
+
+n_dummy $(nonxs_ext): miniperl preplibrary $(DYNALOADER) FORCE
+ @$(LDLIBPTH) sh ext/util/make_ext nonxs $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
+
+clean: _tidy _mopup
+
+realclean: _cleaner _mopup
+ @echo "Note that make realclean does not delete config.sh or Policy.sh"
+
+clobber: _cleaner _mopup
+ rm -f config.sh cppstdin Policy.sh
+
+distclean: clobber
+
+# Do not 'make _mopup' directly.
+_mopup:
+ rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c
+ rm -f perl.exp ext.libs
+ -rm -f perl.export perl.dll perl.libexp perl.map perl.def
+ rm -f perl suidperl miniperl $(LIBPERL)
+
+# Do not 'make _tidy' directly.
+_tidy:
+ -cd pod; $(MAKE) clean
+ -cd utils; $(MAKE) clean
+ -cd x2p; $(MAKE) clean
+ -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
+ sh ext/util/make_ext clean $$x MAKE=$(MAKE) ; \
+ done
+ rm -f testcompile compilelog
+
+# Do not 'make _cleaner' directly.
+_cleaner:
+ -cd os2; rm -f Makefile
+ -cd pod; $(MAKE) realclean
+ -cd utils; $(MAKE) realclean
+ -cd x2p; $(MAKE) realclean
+ -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \
+ sh ext/util/make_ext realclean $$x MAKE=$(MAKE) ; \
+ done
+ rm -f *.orig */*.orig *~ */*~ core t/core t/c t/perl
+ rm -rf $(addedbyconf)
+ rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old
+ rm -f $(private)
+ rm -rf lib/auto
+ rm -f lib/.exists
+ rm -f h2ph.man pstruct
+ rm -rf .config
+ rm -f testcompile compilelog
+
+# The following lint has practically everything turned on. Unfortunately,
+# you have to wade through a lot of mumbo jumbo that can't be suppressed.
+# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
+# for that spot.
+
+lint: perly.c $(c)
+ lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz
+
+# Need to unset during recursion to go out of loop.
+# The README below ensures that the dependency list is never empty and
+# that when MAKEDEPEND is empty $(FIRSTMAKEFILE) doesn't need rebuilding.
+
+MAKEDEPEND = Makefile makedepend
+
+$(FIRSTMAKEFILE): README $(MAKEDEPEND)
+ $(MAKE) depend MAKEDEPEND=
+
+config.h: config_h.SH config.sh
+ $(SHELL) config_h.SH
+
+# This is an AIXism.
+perl.exp: perl_exp.SH config.sh $(SYM) $(SYMH)
+ $(SHELL) perl_exp.SH
+
+# When done, touch perlmain.c so that it doesn't get remade each time.
+depend: makedepend
+ sh ./makedepend MAKE=$(MAKE)
+ - test -s perlmain.c && touch perlmain.c
+ cd x2p; $(MAKE) depend
+
+# Cannot postpone this until $firstmakefile is ready ;-)
+makedepend: makedepend.SH config.sh
+ sh ./makedepend.SH
+
+test-prep: miniperl perl preplibrary utilities $(dynamic_ext) $(nonxs_ext)
+ cd t && (rm -f perl$(EXE_EXT); $(LNS) ../perl$(EXE_EXT) perl$(EXE_EXT))
+
+test check: test-prep
+ cd t && $(LDLIBPTH) ./perl TEST </dev/tty
+
+# For testing without a tty or controling terminal. See t/op/stat.t
+test-notty: test-prep
+ cd t && PERL_SKIP_TTY_TEST=1 $(LDLIBPTH) ./perl TEST
+
+# Can't depend on lib/Config.pm because that might be where miniperl
+# is crashing.
+minitest: miniperl lib/re.pm
+ @echo "You may see some irrelevant test failures if you have been unable"
+ @echo "to build lib/Config.pm."
+ - cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \
+ && $(LDLIBPTH) ./perl TEST base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t </dev/tty
+
+# Handy way to run perlbug -ok without having to install and run the
+# installed perlbug. We don't re-run the tests here - we trust the user.
+# Please *don't* use this unless all tests pass.
+# If you want to report test failures, use "make nok" instead.
+ok: utilities
+ $(LBLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)'
+
+okfile: utilities
+ $(LBLIBPTH) ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)' -F perl.ok
+
+nok: utilities
+ $(LBLIBPTH) ./perl -Ilib utils/perlbug -nok -s '(UNINSTALLED)'
+
+clist: $(c)
+ echo $(c) | tr ' ' $(TRNL) >.clist
+
+hlist: $(h)
+ echo $(h) | tr ' ' $(TRNL) >.hlist
+
+shlist: $(sh)
+ echo $(sh) | tr ' ' $(TRNL) >.shlist
+
+pllist: $(pl)
+ echo $(pl) | tr ' ' $(TRNL) >.pllist
+
+Makefile: Makefile.SH ./config.sh
+ $(SHELL) Makefile.SH
+
+distcheck: FORCE
+ perl '-MExtUtils::Manifest=&fullcheck' -e 'fullcheck()'
+
+elc: emacs/cperl-mode.elc
+
+emacs/cperl-mode.elc: emacs/cperl-mode.el
+ -cd emacs; emacs -batch -q -no-site-file -f batch-byte-compile cperl-mode.el
+
+etags: emacs/cperl-mode.elc
+ sh emacs/ptags
+
+# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
+# If this runs make out of memory, delete /usr/include lines.
+!NO!SUBS!
+
+$eunicefix Makefile
+case `pwd` in
+*SH)
+ $rm -f ../Makefile
+ $ln Makefile ../Makefile
+ ;;
+esac
+$rm -f $firstmakefile
diff --git a/contrib/perl5/Policy_sh.SH b/contrib/perl5/Policy_sh.SH
new file mode 100755
index 000000000000..52a2c57da5ee
--- /dev/null
+++ b/contrib/perl5/Policy_sh.SH
@@ -0,0 +1,153 @@
+case $CONFIG in
+'') . ./config.sh ;;
+esac
+echo "Extracting Policy.sh (with variable substitutions)"
+$spitshell <<!GROK!THIS! >Policy.sh
+$startsh
+#
+# This file was produced by running the Policy_sh.SH script, which
+# gets its values from config.sh, which is generally produced by
+# running Configure. The Policy.sh file gets overwritten each time
+# Configure is run. Any variables you add to Policy.sh will be lost
+# unless you copy Policy.sh somewhere else before running Configure.
+#
+# The idea here is to distill in one place the common site-wide
+# "policy" answers (such as installation directories) that are
+# to be "sticky". If you keep the file Policy.sh around in
+# the same directory as you are building Perl, then Configure will
+# (by default) load up the Policy.sh file just before the
+# platform-specific hints file.
+#
+
+# Allow Configure command-line overrides; usually these won't be
+# needed, but something like -Dprefix=/test/location can be quite
+# useful for testing out new versions.
+
+#Site-specific values:
+
+case "\$perladmin" in
+'') perladmin='$perladmin' ;;
+esac
+
+# Installation prefix. Allow a Configure -D override. You
+# may wish to reinstall perl under a different prefix, perhaps
+# in order to test a different configuration.
+case "\$prefix" in
+'') prefix='$prefix' ;;
+esac
+
+# Installation directives. Note that each one comes in three flavors.
+# For example, we have privlib, privlibexp, and installprivlib.
+# privlib is for private (to perl) library files.
+# privlibexp is the same, except any '~' the user gave to Configure
+# is expanded to the user's home directory. This is figured
+# out automatically by Configure, so you don't have to include it here.
+# installprivlib is for systems (such as those running AFS) that
+# need to distinguish between the place where things
+# get installed and where they finally will reside.
+#
+# In each case, if your previous value was the default, leave it commented
+# out. That way, if you override prefix, all of these will be
+# automatically adjusted.
+#
+# WARNING: Be especially careful about architecture-dependent and
+# version-dependent names, particularly if you reuse this file for
+# different versions of perl.
+
+!GROK!THIS!
+
+for var in bin scriptdir privlib archlib \
+ man1dir man3dir sitelib sitearch \
+ installbin installscript installprivlib installarchlib \
+ installman1dir installman3dir installsitelib installsitearch \
+ man1ext man3ext; do
+
+ case "$var" in
+ bin) dflt=$prefix/bin ;;
+ # The scriptdir test is more complex, but this is probably usually ok.
+ scriptdir)
+ if $test -d $prefix/script; then
+ dflt=$prefix/script
+ else
+ dflt=$bin
+ fi
+ ;;
+ privlib)
+ case "$prefix" in
+ *perl*) dflt=$prefix/lib/$version ;;
+ *) dflt=$prefix/lib/$package/$version ;;
+ esac
+ ;;
+ archlib)
+ case "$prefix" in
+ *perl*) dflt=$prefix/lib/$version/$archname ;;
+ *) dflt=$prefix/lib/$package/$version/$archname ;;
+ esac
+ ;;
+ sitelib)
+ case "$prefix" in
+ *perl*) dflt=$prefix/lib/site_perl/$apiversion ;;
+ *) dflt=$prefix/lib/$package/site_perl/$apiversion ;;
+ esac
+ ;;
+ sitearch)
+ case "$prefix" in
+ *perl*) dflt=$prefix/lib/site_perl/$apiversion/$archname ;;
+ *) dflt=$prefix/lib/$package/site_perl/$apiversion/$archname ;;
+ esac
+ ;;
+ man1dir) dflt="$prefix/man/man1" ;;
+ man3dir)
+ case "$prefix" in
+ *perl*) dflt=`echo $man1dir |
+ sed -e 's/man1/man3/g' -e 's/man\.1/man\.3/g'` ;;
+ *) dflt=$privlib/man/man3 ;;
+ esac
+ ;;
+
+ # Can we assume all sed's have greedy matching?
+ man1ext) dflt=`echo $man1dir | sed -e 's!.*man!!' -e 's!^\.!!'` ;;
+ man3ext) dflt=`echo $man3dir | sed -e 's!.*man!!' -e 's!^\.!!'` ;;
+
+ # It might be possible to fool these next tests. Please let
+ # me know if they don't work right for you.
+ installbin) dflt=`echo $binexp | sed 's#^/afs/#/afs/.#'`;;
+ installscript) dflt=`echo $scriptdirexp | sed 's#^/afs/#/afs/.#'`;;
+ installprivlib) dflt=`echo $privlibexp | sed 's#^/afs/#/afs/.#'`;;
+ installarchlib) dflt=`echo $archlibexp | sed 's#^/afs/#/afs/.#'`;;
+ installsitelib) dflt=`echo $sitelibexp | sed 's#^/afs/#/afs/.#'`;;
+ installsitearch) dflt=`echo $sitearchexp | sed 's#^/afs/#/afs/.#'`;;
+ installman1dir) dflt=`echo $man1direxp | sed 's#^/afs/#/afs/.#'`;;
+ installman3dir) dflt=`echo $man3direxp | sed 's#^/afs/#/afs/.#'`;;
+ esac
+
+ eval val="\$$var"
+ if test X"$val" = X"$dflt"; then
+ echo "# $var='$dflt'"
+ else
+ echo "# Preserving custom $var"
+ echo "$var='$val'"
+ fi
+
+done >> Policy.sh
+
+$spitshell <<!GROK!THIS! >>Policy.sh
+
+# Lastly, you may add additional items here. For example, to set the
+# pager to your local favorite value, uncomment the following line in
+# the original Policy_sh.SH file and re-run sh Policy_sh.SH.
+#
+# pager='$pager'
+#
+# A full Glossary of all the config.sh variables is in the file
+# Porting/Glossary.
+
+!GROK!THIS!
+
+#Credits:
+# The original design for this Policy.sh file came from Wayne Davison,
+# maintainer of trn.
+# This version for Perl5.004_61 originally written by
+# Andy Dougherty <doughera@lafcol.lafayette.edu>.
+# This file may be distributed under the same terms as Perl itself.
+
diff --git a/contrib/perl5/Porting/Contract b/contrib/perl5/Porting/Contract
new file mode 100644
index 000000000000..cc91af26bca8
--- /dev/null
+++ b/contrib/perl5/Porting/Contract
@@ -0,0 +1,108 @@
+
+ Contributed Modules in Perl Core
+ A Social Contract about Artistic Control
+
+What follows is a statement about artistic control, defined as the ability
+of authors of packages to guide the future of their code and maintain
+control over their work. It is a recognition that authors should have
+control over their work, and that it is a responsibility of the rest of
+the Perl community to ensure that they retain this control. It is an
+attempt to document the standards to which we, as Perl developers, intend
+to hold ourselves. It is an attempt to write down rough guidelines about
+the respect we owe each other as Perl developers.
+
+This statement is not a legal contract. This statement is not a legal
+document in any way, shape, or form. Perl is distributed under the GNU
+Public License and under the Artistic License; those are the precise legal
+terms. This statement isn't about the law or licenses. It's about
+community, mutual respect, trust, and good-faith cooperation.
+
+We recognize that the Perl core, defined as the software distributed with
+the heart of Perl itself, is a joint project on the part of all of us.
+>From time to time, a script, module, or set of modules (hereafter referred
+to simply as a "module") will prove so widely useful and/or so integral to
+the correct functioning of Perl itself that it should be distributed with
+Perl core. This should never be done without the author's explicit
+consent, and a clear recognition on all parts that this means the module
+is being distributed under the same terms as Perl itself. A module author
+should realize that inclusion of a module into the Perl core will
+necessarily mean some loss of control over it, since changes may
+occasionally have to be made on short notice or for consistency with the
+rest of Perl.
+
+Once a module has been included in the Perl core, however, everyone
+involved in maintaining Perl should be aware that the module is still the
+property of the original author unless the original author explicitly
+gives up their ownership of it. In particular:
+
+ 1) The version of the module in the core should still be considered the
+ work of the original author. All patches, bug reports, and so forth
+ should be fed back to them. Their development directions should be
+ respected whenever possible.
+
+ 2) Patches may be applied by the pumpkin holder without the explicit
+ cooperation of the module author if and only if they are very minor,
+ time-critical in some fashion (such as urgent security fixes), or if
+ the module author cannot be reached. Those patches must still be
+ given back to the author when possible, and if the author decides on
+ an alternate fix in their version, that fix should be strongly
+ preferred unless there is a serious problem with it. Any changes not
+ endorsed by the author should be marked as such, and the contributor
+ of the change acknowledged.
+
+ 3) The version of the module distributed with Perl should, whenever
+ possible, be the latest version of the module as distributed by the
+ author (the latest non-beta version in the case of public Perl
+ releases), although the pumpkin holder may hold off on upgrading the
+ version of the module distributed with Perl to the latest version
+ until the latest version has had sufficient testing.
+
+In other words, the author of a module should be considered to have final
+say on modifications to their module whenever possible (bearing in mind
+that it's expected that everyone involved will work together and arrive at
+reasonable compromises when there are disagreements).
+
+As a last resort, however:
+
+ 4) If the author's vision of the future of their module is sufficiently
+ different from the vision of the pumpkin holder and perl5-porters as a
+ whole so as to cause serious problems for Perl, the pumpkin holder may
+ choose to formally fork the version of the module in the core from the
+ one maintained by the author. This should not be done lightly and
+ should *always* if at all possible be done only after direct input
+ from Larry. If this is done, it must then be made explicit in the
+ module as distributed with Perl core that it is a forked version and
+ that while it is based on the original author's work, it is no longer
+ maintained by them. This must be noted in both the documentation and
+ in the comments in the source of the module.
+
+Again, this should be a last resort only. Ideally, this should never
+happen, and every possible effort at cooperation and compromise should be
+made before doing this. If it does prove necessary to fork a module for
+the overall health of Perl, proper credit must be given to the original
+author in perpetuity and the decision should be constantly re-evaluated to
+see if a remerging of the two branches is possible down the road.
+
+In all dealings with contributed modules, everyone maintaining Perl should
+keep in mind that the code belongs to the original author, that they may
+not be on perl5-porters at any given time, and that a patch is not
+official unless it has been integrated into the author's copy of the
+module. To aid with this, and with points #1, #2, and #3 above, contact
+information for the authors of all contributed modules should be kept with
+the Perl distribution.
+
+Finally, the Perl community as a whole recognizes that respect for
+ownership of code, respect for artistic control, proper credit, and active
+effort to prevent unintentional code skew or communication gaps is vital
+to the health of the community and Perl itself. Members of a community
+should not normally have to resort to rules and laws to deal with each
+other, and this document, although it contains rules so as to be clear, is
+about an attitude and general approach. The first step in any dispute
+should be open communication, respect for opposing views, and an attempt
+at a compromise. In nearly every circumstance nothing more will be
+necessary, and certainly no more drastic measure should be used until
+every avenue of communication and discussion has failed.
+
+--
+Version 1.2. By Russ Allbery (rra@stanford.edu) and the perl5-porters.
+
diff --git a/contrib/perl5/Porting/Glossary b/contrib/perl5/Porting/Glossary
new file mode 100644
index 000000000000..f6816791137e
--- /dev/null
+++ b/contrib/perl5/Porting/Glossary
@@ -0,0 +1,2580 @@
+This file contains a description of all the shell variables whose value is
+determined by the Configure script. Variables intended for use in C
+programs (e.g. I_UNISTD) are already described in config_h.SH. [`configpm'
+generates pod documentation for Config.pm from this file--please try to keep
+the formatting regular.]
+
+Mcc (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the Mcc program. After Configure runs,
+ the value is reset to a plain "Mcc" and is not useful.
+
+_a (Unix.U):
+ This variable defines the extension used for ordinary libraries.
+ For unix, it is '.a'. The '.' is included. Other possible
+ values include '.lib'.
+
+_exe (Unix.U):
+ This variable defines the extension used for executable files.
+ For unix it is empty. Other possible values include '.exe'.
+
+_o (Unix.U):
+ This variable defines the extension used for object files.
+ For unix, it is '.o'. The '.' is included. Other possible
+ values include '.obj'.
+
+afs (afs.U):
+ This variable is set to 'true' if AFS (Andrew File System) is used
+ on the system, 'false' otherwise. It is possible to override this
+ with a hint value or command line option, but you'd better know
+ what you are doing.
+
+alignbytes (alignbytes.U):
+ This variable holds the number of bytes required to align a
+ double. Usual values are 2, 4 and 8.
+
+ansi2knr (ansi2knr.U):
+ This variable is set if the user needs to run ansi2knr.
+ Currently, this is not supported, so we just abort.
+
+aphostname (d_gethname.U):
+ Thie variable contains the command which can be used to compute the
+ host name. The command is fully qualified by its absolute path, to make
+ it safe when used by a process with super-user privileges.
+
+apiversion (patchlevel.U):
+ This is a number which identifies the lowest version of perl
+ to have an API (for XS extensions) compatible with the present
+ version. For example, for 5.005_01, the apiversion should be
+ 5.005, since 5.005_01 should be binary compatible with 5.005.
+ This should probably be incremented manually somehow, perhaps
+ from patchlevel.h. For now, we'll guess maintenance subversions
+ will retain binary compatibility.
+
+ar (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the ar program. After Configure runs,
+ the value is reset to a plain "ar" and is not useful.
+
+archlib (archlib.U):
+ This variable holds the name of the directory in which the user wants
+ to put architecture-dependent public library files for $package.
+ It is most often a local directory such as /usr/local/lib.
+ Programs using this variable must be prepared to deal
+ with filename expansion.
+
+archlibexp (archlib.U):
+ This variable is the same as the archlib variable, but is
+ filename expanded at configuration time, for convenient use.
+
+archname (archname.U):
+ This variable is a short name to characterize the current
+ architecture. It is used mainly to construct the default archlib.
+
+archobjs (Unix.U):
+ This variable defines any additional objects that must be linked
+ in with the program on this architecture. On unix, it is usually
+ empty. It is typically used to include emulations of unix calls
+ or other facilities. For perl on OS/2, for example, this would
+ include os2/os2.obj.
+
+awk (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the awk program. After Configure runs,
+ the value is reset to a plain "awk" and is not useful.
+
+baserev (baserev.U):
+ The base revision level of this package, from the .package file.
+
+bash (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+bin (bin.U):
+ This variable holds the name of the directory in which the user wants
+ to put publicly executable images for the package in question. It
+ is most often a local directory such as /usr/local/bin. Programs using
+ this variable must be prepared to deal with ~name substitution.
+
+binexp (bin.U):
+ This is the same as the bin variable, but is filename expanded at
+ configuration time, for use in your makefiles.
+
+bison (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+byacc (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the byacc program. After Configure runs,
+ the value is reset to a plain "byacc" and is not useful.
+
+byteorder (byteorder.U):
+ This variable holds the byte order. In the following, larger digits
+ indicate more significance. The variable byteorder is either 4321
+ on a big-endian machine, or 1234 on a little-endian, or 87654321
+ on a Cray ... or 3412 with weird order !
+
+c (n.U):
+ This variable contains the \c string if that is what causes the echo
+ command to suppress newline. Otherwise it is null. Correct usage is
+ $echo $n "prompt for a question: $c".
+
+castflags (d_castneg.U):
+ This variable contains a flag that precise difficulties the
+ compiler has casting odd floating values to unsigned long:
+ 0 = ok
+ 1 = couldn't cast < 0
+ 2 = couldn't cast >= 0x80000000
+ 4 = couldn't cast in argument expression list
+
+cat (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the cat program. After Configure runs,
+ the value is reset to a plain "cat" and is not useful.
+
+cc (cc.U):
+ This variable holds the name of a command to execute a C compiler which
+ can resolve multiple global references that happen to have the same
+ name. Usual values are 'cc', 'Mcc', 'cc -M', and 'gcc'.
+
+cccdlflags (dlsrc.U):
+ This variable contains any special flags that might need to be
+ passed with 'cc -c' to compile modules to be used to create a shared
+ library that will be used for dynamic loading. For hpux, this
+ should be +z. It is up to the makefile to use it.
+
+ccdlflags (dlsrc.U):
+ This variable contains any special flags that might need to be
+ passed to cc to link with a shared library for dynamic loading.
+ It is up to the makefile to use it. For sunos 4.1, it should
+ be empty.
+
+ccflags (ccflags.U):
+ This variable contains any additional C compiler flags desired by
+ the user. It is up to the Makefile to use this.
+
+cf_by (cf_who.U):
+ Login name of the person who ran the Configure script and answered the
+ questions. This is used to tag both config.sh and config_h.SH.
+
+cf_email (cf_email.U):
+ Electronic mail address of the person who ran Configure. This can be
+ used by units that require the user's e-mail, like MailList.U.
+
+cf_time (cf_who.U):
+ Holds the output of the "date" command when the configuration file was
+ produced. This is used to tag both config.sh and config_h.SH.
+
+chgrp (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+chmod (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+chown (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+clocktype (d_times.U):
+ This variable holds the type returned by times(). It can be long,
+ or clock_t on BSD sites (in which case <sys/types.h> should be
+ included).
+
+comm (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the comm program. After Configure runs,
+ the value is reset to a plain "comm" and is not useful.
+
+compress (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+contains (contains.U):
+ This variable holds the command to do a grep with a proper return
+ status. On most sane systems it is simply "grep". On insane systems
+ it is a grep followed by a cat followed by a test. This variable
+ is primarily for the use of other Configure units.
+
+cp (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the cp program. After Configure runs,
+ the value is reset to a plain "cp" and is not useful.
+
+cpio (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+cpp (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the cpp program. After Configure runs,
+ the value is reset to a plain "cpp" and is not useful.
+
+cpp_stuff (cpp_stuff.U):
+ This variable contains an identification of the catenation mechanism
+ used by the C preprocessor.
+
+cppflags (ccflags.U):
+ This variable holds the flags that will be passed to the C pre-
+ processor. It is up to the Makefile to use it.
+
+cpplast (cppstdin.U):
+ This variable has the same functionality as cppminus, only it applies to
+ cpprun and not cppstdin.
+
+cppminus (cppstdin.U):
+ This variable contains the second part of the string which will invoke
+ the C preprocessor on the standard input and produce to standard
+ output. This variable will have the value "-" if cppstdin needs a minus
+ to specify standard input, otherwise the value is "".
+
+cpprun (cppstdin.U):
+ This variable contains the command which will invoke a C preprocessor
+ on standard input and put the output to stdout. It is guaranteed not
+ to be a wrapper and may be a null string if no preprocessor can be
+ made directly available. This preprocessor might be different from the
+ one used by the C compiler. Don't forget to append cpplast after the
+ preprocessor options.
+
+cppstdin (cppstdin.U):
+ This variable contains the command which will invoke the C
+ preprocessor on standard input and put the output to stdout.
+ It is primarily used by other Configure units that ask about
+ preprocessor symbols.
+
+cryptlib (d_crypt.U):
+ This variable holds -lcrypt or the path to a libcrypt.a archive if
+ the crypt() function is not defined in the standard C library. It is
+ up to the Makefile to use this.
+
+csh (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the csh program. After Configure runs,
+ the value is reset to a plain "csh" and is not useful.
+
+d_Gconvert (d_gconvert.U):
+ This variable holds what Gconvert is defined as to convert
+ floating point numbers into strings. It could be 'gconvert'
+ or a more complex macro emulating gconvert with gcvt() or sprintf.
+
+d_access (d_access.U):
+ This variable conditionally defines HAS_ACCESS if the access() system
+ call is available to check for access permissions using real IDs.
+
+d_alarm (d_alarm.U):
+ This variable conditionally defines the HAS_ALARM symbol, which
+ indicates to the C program that the alarm() routine is available.
+
+d_archlib (archlib.U):
+ This variable conditionally defines ARCHLIB to hold the pathname
+ of architecture-dependent library files for $package. If
+ $archlib is the same as $privlib, then this is set to undef.
+
+d_attribut (d_attribut.U):
+ This variable conditionally defines HASATTRIBUTE, which
+ indicates the C compiler can check for function attributes,
+ such as printf formats.
+
+d_bcmp (d_bcmp.U):
+ This variable conditionally defines the HAS_BCMP symbol if
+ the bcmp() routine is available to compare strings.
+
+d_bcopy (d_bcopy.U):
+ This variable conditionally defines the HAS_BCOPY symbol if
+ the bcopy() routine is available to copy strings.
+
+d_bsd (Guess.U):
+ This symbol conditionally defines the symbol BSD when running on a
+ BSD system.
+
+d_bsdgetpgrp (d_getpgrp.U):
+ This variable conditionally defines USE_BSD_GETPGRP if
+ getpgrp needs one arguments whereas USG one needs none.
+
+d_bsdsetpgrp (d_setpgrp.U):
+ This variable conditionally defines USE_BSD_SETPGRP if
+ setpgrp needs two arguments whereas USG one needs none.
+ See also d_setpgid for a POSIX interface.
+
+d_bzero (d_bzero.U):
+ This variable conditionally defines the HAS_BZERO symbol if
+ the bzero() routine is available to set memory to 0.
+
+d_casti32 (d_casti32.U):
+ This variable conditionally defines CASTI32, which indicates
+ whether the C compiler can cast large floats to 32-bit ints.
+
+d_castneg (d_castneg.U):
+ This variable conditionally defines CASTNEG, which indicates
+ wether the C compiler can cast negative float to unsigned.
+
+d_charvspr (d_vprintf.U):
+ This variable conditionally defines CHARVSPRINTF if this system
+ has vsprintf returning type (char*). The trend seems to be to
+ declare it as "int vsprintf()".
+
+d_chown (d_chown.U):
+ This variable conditionally defines the HAS_CHOWN symbol, which
+ indicates to the C program that the chown() routine is available.
+
+d_chroot (d_chroot.U):
+ This variable conditionally defines the HAS_CHROOT symbol, which
+ indicates to the C program that the chroot() routine is available.
+
+d_chsize (d_chsize.U):
+ This variable conditionally defines the CHSIZE symbol, which
+ indicates to the C program that the chsize() routine is available
+ to truncate files. You might need a -lx to get this routine.
+
+d_closedir (d_closedir.U):
+ This variable conditionally defines HAS_CLOSEDIR if closedir() is
+ available.
+
+d_const (d_const.U):
+ This variable conditionally defines the HASCONST symbol, which
+ indicates to the C program that this C compiler knows about the
+ const type.
+
+d_crypt (d_crypt.U):
+ This variable conditionally defines the CRYPT symbol, which
+ indicates to the C program that the crypt() routine is available
+ to encrypt passwords and the like.
+
+d_csh (d_csh.U):
+ This variable conditionally defines the CSH symbol, which
+ indicates to the C program that the C-shell exists.
+
+d_cuserid (d_cuserid.U):
+ This variable conditionally defines the HAS_CUSERID symbol, which
+ indicates to the C program that the cuserid() routine is available
+ to get character login names.
+
+d_dbl_dig (d_dbl_dig.U):
+ This variable conditionally defines d_dbl_dig if this system's
+ header files provide DBL_DIG, which is the number of significant
+ digits in a double precision number.
+
+d_difftime (d_difftime.U):
+ This variable conditionally defines the HAS_DIFFTIME symbol, which
+ indicates to the C program that the difftime() routine is available.
+
+d_dirnamlen (i_dirent.U):
+ This variable conditionally defines DIRNAMLEN, which indicates
+ to the C program that the length of directory entry names is
+ provided by a d_namelen field.
+
+d_dlerror (d_dlerror.U):
+ This variable conditionally defines the HAS_DLERROR symbol, which
+ indicates to the C program that the dlerror() routine is available.
+
+d_dlopen (d_dlopen.U):
+ This variable conditionally defines the HAS_DLOPEN symbol, which
+ indicates to the C program that the dlopen() routine is available.
+
+d_dlsymun (d_dlsymun.U):
+ This variable conditionally defines DLSYM_NEEDS_UNDERSCORE, which
+ indicates that we need to prepend an underscore to the symbol
+ name before calling dlsym().
+
+d_dosuid (d_dosuid.U):
+ This variable conditionally defines the symbol DOSUID, which
+ tells the C program that it should insert setuid emulation code
+ on hosts which have setuid #! scripts disabled.
+
+d_dup2 (d_dup2.U):
+ This variable conditionally defines HAS_DUP2 if dup2() is
+ available to duplicate file descriptors.
+
+d_endgrent (d_endgrent.U):
+ This variable conditionally defines the HAS_ENDGRENT symbol, which
+ indicates to the C program that the endgrent() routine is available
+ for sequential access of the group database.
+
+d_endhent (d_endhent.U):
+ This variable conditionally defines HAS_ENDHOSTENT if endhostent() is
+ available to close whatever was being used for host queries.
+
+d_endnent (d_endnent.U):
+ This variable conditionally defines HAS_ENDNETENT if endnetent() is
+ available to close whatever was being used for network queries.
+
+d_endpent (d_endpent.U):
+ This variable conditionally defines HAS_ENDPROTOENT if endprotoent() is
+ available to close whatever was being used for protocol queries.
+
+d_endpwent (d_endpwent.U):
+ This variable conditionally defines the HAS_ENDPWENT symbol, which
+ indicates to the C program that the endpwent() routine is available
+ for sequential access of the passwd database.
+
+d_endsent (d_endsent.U):
+ This variable conditionally defines HAS_ENDSERVENT if endservent() is
+ available to close whatever was being used for service queries.
+
+d_eofnblk (nblock_io.U):
+ This variable conditionally defines EOF_NONBLOCK if EOF can be seen
+ when reading from a non-blocking I/O source.
+
+d_eunice (Guess.U):
+ This variable conditionally defines the symbols EUNICE and VAX, which
+ alerts the C program that it must deal with ideosyncracies of VMS.
+
+d_fchmod (d_fchmod.U):
+ This variable conditionally defines the HAS_FCHMOD symbol, which
+ indicates to the C program that the fchmod() routine is available
+ to change mode of opened files.
+
+d_fchown (d_fchown.U):
+ This variable conditionally defines the HAS_FCHOWN symbol, which
+ indicates to the C program that the fchown() routine is available
+ to change ownership of opened files.
+
+d_fcntl (d_fcntl.U):
+ This variable conditionally defines the HAS_FCNTL symbol, and indicates
+ whether the fcntl() function exists
+
+d_fd_macros (d_fd_set.U):
+ This variable contains the eventual value of the HAS_FD_MACROS symbol,
+ which indicates if your C compiler knows about the macros which
+ manipulate an fd_set.
+
+d_fd_set (d_fd_set.U):
+ This variable contains the eventual value of the HAS_FD_SET symbol,
+ which indicates if your C compiler knows about the fd_set typedef.
+
+d_fds_bits (d_fd_set.U):
+ This variable contains the eventual value of the HAS_FDS_BITS symbol,
+ which indicates if your fd_set typedef contains the fds_bits member.
+ If you have an fd_set typedef, but the dweebs who installed it did
+ a half-fast job and neglected to provide the macros to manipulate
+ an fd_set, HAS_FDS_BITS will let us know how to fix the gaffe.
+
+d_fgetpos (d_fgetpos.U):
+ This variable conditionally defines HAS_FGETPOS if fgetpos() is
+ available to get the file position indicator.
+
+d_flexfnam (d_flexfnam.U):
+ This variable conditionally defines the FLEXFILENAMES symbol, which
+ indicates that the system supports filenames longer than 14 characters.
+
+d_flock (d_flock.U):
+ This variable conditionally defines HAS_FLOCK if flock() is
+ available to do file locking.
+
+d_fork (d_fork.U):
+ This variable conditionally defines the HAS_FORK symbol, which
+ indicates to the C program that the fork() routine is available.
+
+d_fpathconf (d_pathconf.U):
+ This variable conditionally defines the HAS_FPATHCONF symbol, which
+ indicates to the C program that the pathconf() routine is available
+ to determine file-system related limits and options associated
+ with a given open file descriptor.
+
+d_fsetpos (d_fsetpos.U):
+ This variable conditionally defines HAS_FSETPOS if fsetpos() is
+ available to set the file position indicator.
+
+d_ftime (d_ftime.U):
+ This variable conditionally defines the HAS_FTIME symbol, which indicates
+ that the ftime() routine exists. The ftime() routine is basically
+ a sub-second accuracy clock.
+
+d_getgrent (d_getgrent.U):
+ This variable conditionally defines the HAS_GETGRENT symbol, which
+ indicates to the C program that the getgrent() routine is available
+ for sequential access of the group database.
+
+d_getgrps (d_getgrps.U):
+ This variable conditionally defines the HAS_GETGROUPS symbol, which
+ indicates to the C program that the getgroups() routine is available
+ to get the list of process groups.
+
+d_gethbyaddr (d_gethbyad.U):
+ This variable conditionally defines the HAS_GETHOSTBYADDR symbol, which
+ indicates to the C program that the gethostbyaddr() routine is available
+ to look up hosts by their IP addresses.
+
+d_gethbyname (d_gethbynm.U):
+ This variable conditionally defines the HAS_GETHOSTBYNAME symbol, which
+ indicates to the C program that the gethostbyname() routine is available
+ to look up host names in some data base or other.
+
+d_gethent (d_gethent.U):
+ This variable conditionally defines HAS_GETHOSTENT if gethostent() is
+ available to look up host names in some data base or another.
+
+d_gethname (d_gethname.U):
+ This variable conditionally defines the HAS_GETHOSTNAME symbol, which
+ indicates to the C program that the gethostname() routine may be
+ used to derive the host name.
+
+d_gethostprotos (d_gethostprotos.U):
+ This variable conditionally defines the HAS_GETHOST_PROTOS symbol,
+ which indicates to the C program that <netdb.h> supplies
+ prototypes for the various gethost*() functions.
+ See also netdbtype.U for probing for various netdb types.
+
+d_getlogin (d_getlogin.U):
+ This variable conditionally defines the HAS_GETLOGIN symbol, which
+ indicates to the C program that the getlogin() routine is available
+ to get the login name.
+
+d_getnbyaddr (d_getnbyad.U):
+ This variable conditionally defines the HAS_GETNETBYADDR symbol, which
+ indicates to the C program that the getnetbyaddr() routine is available
+ to look up networks by their IP addresses.
+
+d_getnbyname (d_getnbynm.U):
+ This variable conditionally defines the HAS_GETNETBYNAME symbol, which
+ indicates to the C program that the getnetbyname() routine is available
+ to look up networks by their names.
+
+d_getnent (d_getnent.U):
+ This variable conditionally defines HAS_GETNETENT if getnetent() is
+ available to look up network names in some data base or another.
+
+d_getnetprotos (d_getnetprotos.U):
+ This variable conditionally defines the HAS_GETNET_PROTOS symbol,
+ which indicates to the C program that <netdb.h> supplies
+ prototypes for the various getnet*() functions.
+ See also netdbtype.U for probing for various netdb types.
+
+d_getpbyname (d_getprotby.U):
+ This variable conditionally defines the HAS_GETPROTOBYNAME
+ symbol, which indicates to the C program that the
+ getprotobyname() routine is available to look up protocols
+ by their name.
+
+d_getpbynumber (d_getprotby.U):
+ This variable conditionally defines the HAS_GETPROTOBYNUMBER
+ symbol, which indicates to the C program that the
+ getprotobynumber() routine is available to look up protocols
+ by their number.
+
+d_getpent (d_getpent.U):
+ This variable conditionally defines HAS_GETPROTOENT if getprotoent() is
+ available to look up protocols in some data base or another.
+
+d_getpgid (d_getpgid.U):
+ This variable conditionally defines the HAS_GETPGID symbol, which
+ indicates to the C program that the getpgid(pid) function
+ is available to get the process group id.
+
+d_getpgrp2 (d_getpgrp2.U):
+ This variable conditionally defines the HAS_GETPGRP2 symbol, which
+ indicates to the C program that the getpgrp2() (as in DG/UX) routine
+ is available to get the current process group.
+
+d_getpgrp (d_getpgrp.U):
+ This variable conditionally defines HAS_GETPGRP if getpgrp() is
+ available to get the current process group.
+
+d_getppid (d_getppid.U):
+ This variable conditionally defines the HAS_GETPPID symbol, which
+ indicates to the C program that the getppid() routine is available
+ to get the parent process ID.
+
+d_getprior (d_getprior.U):
+ This variable conditionally defines HAS_GETPRIORITY if getpriority()
+ is available to get a process's priority.
+
+d_getprotoprotos (d_getprotoprotos.U):
+ This variable conditionally defines the HAS_GETPROTO_PROTOS symbol,
+ which indicates to the C program that <netdb.h> supplies
+ prototypes for the various getproto*() functions.
+ See also netdbtype.U for probing for various netdb types.
+
+d_getpwent (d_getpwent.U):
+ This variable conditionally defines the HAS_GETPWENT symbol, which
+ indicates to the C program that the getpwent() routine is available
+ for sequential access of the passwd database.
+
+d_getsbyname (d_getsrvby.U):
+ This variable conditionally defines the HAS_GETSERVBYNAME
+ symbol, which indicates to the C program that the
+ getservbyname() routine is available to look up services
+ by their name.
+
+d_getsbyport (d_getsrvby.U):
+ This variable conditionally defines the HAS_GETSERVBYPORT
+ symbol, which indicates to the C program that the
+ getservbyport() routine is available to look up services
+ by their port.
+
+d_getsent (d_getsent.U):
+ This variable conditionally defines HAS_GETSERVENT if getservent() is
+ available to look up network services in some data base or another.
+
+d_getservprotos (d_getservprotos.U):
+ This variable conditionally defines the HAS_GETSERV_PROTOS symbol,
+ which indicates to the C program that <netdb.h> supplies
+ prototypes for the various getserv*() functions.
+ See also netdbtype.U for probing for various netdb types.
+
+d_gettimeod (d_ftime.U):
+ This variable conditionally defines the HAS_GETTIMEOFDAY symbol, which
+ indicates that the gettimeofday() system call exists (to obtain a
+ sub-second accuracy clock). You should probably include <sys/resource.h>.
+
+d_gnulibc (d_gnulibc.U):
+ Defined if we're dealing with the GNU C Library.
+
+d_grpasswd (i_grp.U):
+ This variable conditionally defines GRPASSWD, which indicates
+ that struct group in <grp.h> contains gr_passwd.
+
+d_htonl (d_htonl.U):
+ This variable conditionally defines HAS_HTONL if htonl() and its
+ friends are available to do network order byte swapping.
+
+d_index (d_strchr.U):
+ This variable conditionally defines HAS_INDEX if index() and
+ rindex() are available for string searching.
+
+d_inetaton (d_inetaton.U):
+ This variable conditionally defines the HAS_INET_ATON symbol, which
+ indicates to the C program that the inet_aton() function is available
+ to parse IP address "dotted-quad" strings.
+
+d_isascii (d_isascii.U):
+ This variable conditionally defines the HAS_ISASCII constant,
+ which indicates to the C program that isascii() is available.
+
+d_killpg (d_killpg.U):
+ This variable conditionally defines the HAS_KILLPG symbol, which
+ indicates to the C program that the killpg() routine is available
+ to kill process groups.
+
+d_lchown (d_lchown.U):
+ This variable conditionally defines the HAS_LCHOWN symbol, which
+ indicates to the C program that the lchown() routine is available
+ to operate on a symbolic link (instead of following the link).
+
+d_link (d_link.U):
+ This variable conditionally defines HAS_LINK if link() is
+ available to create hard links.
+
+d_locconv (d_locconv.U):
+ This variable conditionally defines HAS_LOCALECONV if localeconv() is
+ available for numeric and monetary formatting conventions.
+
+d_lockf (d_lockf.U):
+ This variable conditionally defines HAS_LOCKF if lockf() is
+ available to do file locking.
+
+d_longdbl (d_longdbl.U):
+ This variable conditionally defines HAS_LONG_DOUBLE if
+ the long double type is supported.
+
+d_longlong (d_longlong.U):
+ This variable conditionally defines HAS_LONG_LONG if
+ the long long type is supported.
+
+d_lstat (d_lstat.U):
+ This variable conditionally defines HAS_LSTAT if lstat() is
+ available to do file stats on symbolic links.
+
+d_mblen (d_mblen.U):
+ This variable conditionally defines the HAS_MBLEN symbol, which
+ indicates to the C program that the mblen() routine is available
+ to find the number of bytes in a multibye character.
+
+d_mbstowcs (d_mbstowcs.U):
+ This variable conditionally defines the HAS_MBSTOWCS symbol, which
+ indicates to the C program that the mbstowcs() routine is available
+ to convert a multibyte string into a wide character string.
+
+d_mbtowc (d_mbtowc.U):
+ This variable conditionally defines the HAS_MBTOWC symbol, which
+ indicates to the C program that the mbtowc() routine is available
+ to convert multibyte to a wide character.
+
+d_memcmp (d_memcmp.U):
+ This variable conditionally defines the HAS_MEMCMP symbol, which
+ indicates to the C program that the memcmp() routine is available
+ to compare blocks of memory.
+
+d_memcpy (d_memcpy.U):
+ This variable conditionally defines the HAS_MEMCPY symbol, which
+ indicates to the C program that the memcpy() routine is available
+ to copy blocks of memory.
+
+d_memmove (d_memmove.U):
+ This variable conditionally defines the HAS_MEMMOVE symbol, which
+ indicates to the C program that the memmove() routine is available
+ to copy potentatially overlapping blocks of memory.
+
+d_memset (d_memset.U):
+ This variable conditionally defines the HAS_MEMSET symbol, which
+ indicates to the C program that the memset() routine is available
+ to set blocks of memory.
+
+d_mkdir (d_mkdir.U):
+ This variable conditionally defines the HAS_MKDIR symbol, which
+ indicates to the C program that the mkdir() routine is available
+ to create directories..
+
+d_mkfifo (d_mkfifo.U):
+ This variable conditionally defines the HAS_MKFIFO symbol, which
+ indicates to the C program that the mkfifo() routine is available.
+
+d_mktime (d_mktime.U):
+ This variable conditionally defines the HAS_MKTIME symbol, which
+ indicates to the C program that the mktime() routine is available.
+
+d_msg (d_msg.U):
+ This variable conditionally defines the HAS_MSG symbol, which
+ indicates that the entire msg*(2) library is present.
+
+d_msgctl (d_msgctl.U):
+ This variable conditionally defines the HAS_MSGCTL symbol, which
+ indicates to the C program that the msgctl() routine is available.
+
+d_msgget (d_msgget.U):
+ This variable conditionally defines the HAS_MSGGET symbol, which
+ indicates to the C program that the msgget() routine is available.
+
+d_msgrcv (d_msgrcv.U):
+ This variable conditionally defines the HAS_MSGRCV symbol, which
+ indicates to the C program that the msgrcv() routine is available.
+
+d_msgsnd (d_msgsnd.U):
+ This variable conditionally defines the HAS_MSGSND symbol, which
+ indicates to the C program that the msgsnd() routine is available.
+
+d_mymalloc (mallocsrc.U):
+ This variable conditionally defines MYMALLOC in case other parts
+ of the source want to take special action if MYMALLOC is used.
+ This may include different sorts of profiling or error detection.
+
+d_nice (d_nice.U):
+ This variable conditionally defines the HAS_NICE symbol, which
+ indicates to the C program that the nice() routine is available.
+
+d_oldpthreads (usethreads.U):
+ This variable conditionally defines the OLD_PTHREADS_API symbol,
+ and indicates that Perl should be built to use the old
+ draft POSIX threads API. This is only potneially meaningful if
+ usethreads is set.
+
+d_oldsock (d_socket.U):
+ This variable conditionally defines the OLDSOCKET symbol, which
+ indicates that the BSD socket interface is based on 4.1c and not 4.2.
+
+d_open3 (d_open3.U):
+ This variable conditionally defines the HAS_OPEN3 manifest constant,
+ which indicates to the C program that the 3 argument version of
+ the open(2) function is available.
+
+d_pathconf (d_pathconf.U):
+ This variable conditionally defines the HAS_PATHCONF symbol, which
+ indicates to the C program that the pathconf() routine is available
+ to determine file-system related limits and options associated
+ with a given filename.
+
+d_pause (d_pause.U):
+ This variable conditionally defines the HAS_PAUSE symbol, which
+ indicates to the C program that the pause() routine is available
+ to suspend a process until a signal is received.
+
+d_phostname (d_gethname.U):
+ This variable conditionally defines the PHOSTNAME symbol, which
+ contains the shell command which, when fed to popen(), may be
+ used to derive the host name.
+
+d_pipe (d_pipe.U):
+ This variable conditionally defines the HAS_PIPE symbol, which
+ indicates to the C program that the pipe() routine is available
+ to create an inter-process channel.
+
+d_poll (d_poll.U):
+ This variable conditionally defines the HAS_POLL symbol, which
+ indicates to the C program that the poll() routine is available
+ to poll active file descriptors.
+
+d_portable (d_portable.U):
+ This variable conditionally defines the PORTABLE symbol, which
+ indicates to the C program that it should not assume that it is
+ running on the machine it was compiled on.
+
+d_pthread_yield (d_pthread_y.U):
+ This variable conditionally defines the HAS_PTHREAD_YIELD
+ symbol if the pthread_yield routine is available to yield
+ the execution of the current thread.
+
+d_pthreads_created_joinable (d_pthreadj.U):
+ This variable conditionally defines the PTHREADS_CREATED_JOINABLE
+ symbol if pthreads are created in the joinable (aka undetached)
+ state.
+
+d_pwage (i_pwd.U):
+ This variable conditionally defines PWAGE, which indicates
+ that struct passwd contains pw_age.
+
+d_pwchange (i_pwd.U):
+ This variable conditionally defines PWCHANGE, which indicates
+ that struct passwd contains pw_change.
+
+d_pwclass (i_pwd.U):
+ This variable conditionally defines PWCLASS, which indicates
+ that struct passwd contains pw_class.
+
+d_pwcomment (i_pwd.U):
+ This variable conditionally defines PWCOMMENT, which indicates
+ that struct passwd contains pw_comment.
+
+d_pwexpire (i_pwd.U):
+ This variable conditionally defines PWEXPIRE, which indicates
+ that struct passwd contains pw_expire.
+
+d_pwgecos (i_pwd.U):
+ This variable conditionally defines PWGECOS, which indicates
+ that struct passwd contains pw_gecos.
+
+d_pwpasswd (i_pwd.U):
+ This variable conditionally defines PWPASSWD, which indicates
+ that struct passwd contains pw_passwd.
+
+d_pwquota (i_pwd.U):
+ This variable conditionally defines PWQUOTA, which indicates
+ that struct passwd contains pw_quota.
+
+d_readdir (d_readdir.U):
+ This variable conditionally defines HAS_READDIR if readdir() is
+ available to read directory entries.
+
+d_readlink (d_readlink.U):
+ This variable conditionally defines the HAS_READLINK symbol, which
+ indicates to the C program that the readlink() routine is available
+ to read the value of a symbolic link.
+
+d_rename (d_rename.U):
+ This variable conditionally defines the HAS_RENAME symbol, which
+ indicates to the C program that the rename() routine is available
+ to rename files.
+
+d_rewinddir (d_readdir.U):
+ This variable conditionally defines HAS_REWINDDIR if rewinddir() is
+ available.
+
+d_rmdir (d_rmdir.U):
+ This variable conditionally defines HAS_RMDIR if rmdir() is
+ available to remove directories.
+
+d_safebcpy (d_safebcpy.U):
+ This variable conditionally defines the HAS_SAFE_BCOPY symbol if
+ the bcopy() routine can do overlapping copies.
+
+d_safemcpy (d_safemcpy.U):
+ This variable conditionally defines the HAS_SAFE_MEMCPY symbol if
+ the memcpy() routine can do overlapping copies.
+
+d_sanemcmp (d_sanemcmp.U):
+ This variable conditionally defines the HAS_SANE_MEMCMP symbol if
+ the memcpy() routine is available and can be used to compare relative
+ magnitudes of chars with their high bits set.
+
+d_sched_yield (d_pthread_y.U):
+ This variable conditionally defines the HAS_SCHED_YIELD
+ symbol if the sched_yield routine is available to yield
+ the execution of the current thread.
+
+d_seekdir (d_readdir.U):
+ This variable conditionally defines HAS_SEEKDIR if seekdir() is
+ available.
+
+d_select (d_select.U):
+ This variable conditionally defines HAS_SELECT if select() is
+ available to select active file descriptors. A <sys/time.h>
+ inclusion may be necessary for the timeout field.
+
+d_sem (d_sem.U):
+ This variable conditionally defines the HAS_SEM symbol, which
+ indicates that the entire sem*(2) library is present.
+
+d_semctl (d_semctl.U):
+ This variable conditionally defines the HAS_SEMCTL symbol, which
+ indicates to the C program that the semctl() routine is available.
+
+d_semctl_semid_ds (d_union_senum.U):
+ This variable conditionally defines USE_SEMCTL_SEMID_DS, which
+ indicates that struct semid_ds * is to be used for semctl IPC_STAT.
+
+d_semctl_semun (d_union_senum.U):
+ This variable conditionally defines USE_SEMCTL_SEMUN, which
+ indicates that union semun is to be used for semctl IPC_STAT.
+
+d_semget (d_semget.U):
+ This variable conditionally defines the HAS_SEMGET symbol, which
+ indicates to the C program that the semget() routine is available.
+
+d_semop (d_semop.U):
+ This variable conditionally defines the HAS_SEMOP symbol, which
+ indicates to the C program that the semop() routine is available.
+
+d_setegid (d_setegid.U):
+ This variable conditionally defines the HAS_SETEGID symbol, which
+ indicates to the C program that the setegid() routine is available
+ to change the effective gid of the current program.
+
+d_seteuid (d_seteuid.U):
+ This variable conditionally defines the HAS_SETEUID symbol, which
+ indicates to the C program that the seteuid() routine is available
+ to change the effective uid of the current program.
+
+d_setgrent (d_setgrent.U):
+ This variable conditionally defines the HAS_SETGRENT symbol, which
+ indicates to the C program that the setgrent() routine is available
+ for initializing sequential access to the group database.
+
+d_setgrps (d_setgrps.U):
+ This variable conditionally defines the HAS_SETGROUPS symbol, which
+ indicates to the C program that the setgroups() routine is available
+ to set the list of process groups.
+
+d_sethent (d_sethent.U):
+ This variable conditionally defines HAS_SETHOSTENT if sethostent() is
+ available.
+
+d_setlinebuf (d_setlnbuf.U):
+ This variable conditionally defines the HAS_SETLINEBUF symbol, which
+ indicates to the C program that the setlinebuf() routine is available
+ to change stderr or stdout from block-buffered or unbuffered to a
+ line-buffered mode.
+
+d_setlocale (d_setlocale.U):
+ This variable conditionally defines HAS_SETLOCALE if setlocale() is
+ available to handle locale-specific ctype implementations.
+
+d_setnent (d_setnent.U):
+ This variable conditionally defines HAS_SETNETENT if setnetent() is
+ available.
+
+d_setpent (d_setpent.U):
+ This variable conditionally defines HAS_SETPROTOENT if setprotoent() is
+ available.
+
+d_setpgid (d_setpgid.U):
+ This variable conditionally defines the HAS_SETPGID symbol if the
+ setpgid(pid, gpid) function is available to set process group ID.
+
+d_setpgrp2 (d_setpgrp2.U):
+ This variable conditionally defines the HAS_SETPGRP2 symbol, which
+ indicates to the C program that the setpgrp2() (as in DG/UX) routine
+ is available to set the current process group.
+
+d_setpgrp (d_setpgrp.U):
+ This variable conditionally defines HAS_SETPGRP if setpgrp() is
+ available to set the current process group.
+
+d_setprior (d_setprior.U):
+ This variable conditionally defines HAS_SETPRIORITY if setpriority()
+ is available to set a process's priority.
+
+d_setpwent (d_setpwent.U):
+ This variable conditionally defines the HAS_SETPWENT symbol, which
+ indicates to the C program that the setpwent() routine is available
+ for initializing sequential access to the passwd database.
+
+d_setregid (d_setregid.U):
+ This variable conditionally defines HAS_SETREGID if setregid() is
+ available to change the real and effective gid of the current
+ process.
+
+d_setresgid (d_setregid.U):
+ This variable conditionally defines HAS_SETRESGID if setresgid() is
+ available to change the real, effective and saved gid of the current
+ process.
+
+d_setresuid (d_setreuid.U):
+ This variable conditionally defines HAS_SETREUID if setresuid() is
+ available to change the real, effective and saved uid of the current
+ process.
+
+d_setreuid (d_setreuid.U):
+ This variable conditionally defines HAS_SETREUID if setreuid() is
+ available to change the real and effective uid of the current
+ process.
+
+d_setrgid (d_setrgid.U):
+ This variable conditionally defines the HAS_SETRGID symbol, which
+ indicates to the C program that the setrgid() routine is available
+ to change the real gid of the current program.
+
+d_setruid (d_setruid.U):
+ This variable conditionally defines the HAS_SETRUID symbol, which
+ indicates to the C program that the setruid() routine is available
+ to change the real uid of the current program.
+
+d_setsent (d_setsent.U):
+ This variable conditionally defines HAS_SETSERVENT if setservent() is
+ available.
+
+d_setsid (d_setsid.U):
+ This variable conditionally defines HAS_SETSID if setsid() is
+ available to set the process group ID.
+
+d_setvbuf (d_setvbuf.U):
+ This variable conditionally defines the HAS_SETVBUF symbol, which
+ indicates to the C program that the setvbuf() routine is available
+ to change buffering on an open stdio stream.
+
+d_sfio (d_sfio.U):
+ This variable conditionally defines the USE_SFIO symbol,
+ and indicates whether sfio is available (and should be used).
+
+d_shm (d_shm.U):
+ This variable conditionally defines the HAS_SHM symbol, which
+ indicates that the entire shm*(2) library is present.
+
+d_shmat (d_shmat.U):
+ This variable conditionally defines the HAS_SHMAT symbol, which
+ indicates to the C program that the shmat() routine is available.
+
+d_shmatprototype (d_shmat.U):
+ This variable conditionally defines the HAS_SHMAT_PROTOTYPE
+ symbol, which indicates that sys/shm.h has a prototype for
+ shmat.
+
+d_shmctl (d_shmctl.U):
+ This variable conditionally defines the HAS_SHMCTL symbol, which
+ indicates to the C program that the shmctl() routine is available.
+
+d_shmdt (d_shmdt.U):
+ This variable conditionally defines the HAS_SHMDT symbol, which
+ indicates to the C program that the shmdt() routine is available.
+
+d_shmget (d_shmget.U):
+ This variable conditionally defines the HAS_SHMGET symbol, which
+ indicates to the C program that the shmget() routine is available.
+
+d_sigaction (d_sigaction.U):
+ This variable conditionally defines the HAS_SIGACTION symbol, which
+ indicates that the Vr4 sigaction() routine is available.
+
+d_sigsetjmp (d_sigsetjmp.U):
+ This variable conditionally defines the HAS_SIGSETJMP symbol,
+ which indicates that the sigsetjmp() routine is available to
+ call setjmp() and optionally save the process's signal mask.
+
+d_socket (d_socket.U):
+ This variable conditionally defines HAS_SOCKET, which indicates
+ that the BSD socket interface is supported.
+
+d_sockpair (d_socket.U):
+ This variable conditionally defines the HAS_SOCKETPAIR symbol, which
+ indicates that the BSD socketpair() is supported.
+
+d_statblks (d_statblks.U):
+ This variable conditionally defines USE_STAT_BLOCKS if this system
+ has a stat structure declaring st_blksize and st_blocks.
+
+d_stdio_cnt_lval (d_stdstdio.U):
+ This variable conditionally defines STDIO_CNT_LVALUE if the
+ FILE_cnt macro can be used as an lvalue.
+
+d_stdio_ptr_lval (d_stdstdio.U):
+ This variable conditionally defines STDIO_PTR_LVALUE if the
+ FILE_ptr macro can be used as an lvalue.
+
+d_stdiobase (d_stdstdio.U):
+ This variable conditionally defines USE_STDIO_BASE if this system
+ has a FILE structure declaring a usable _base field (or equivalent)
+ in stdio.h.
+
+d_stdstdio (d_stdstdio.U):
+ This variable conditionally defines USE_STDIO_PTR if this system
+ has a FILE structure declaring usable _ptr and _cnt fields (or
+ equivalent) in stdio.h.
+
+d_strchr (d_strchr.U):
+ This variable conditionally defines HAS_STRCHR if strchr() and
+ strrchr() are available for string searching.
+
+d_strcoll (d_strcoll.U):
+ This variable conditionally defines HAS_STRCOLL if strcoll() is
+ available to compare strings using collating information.
+
+d_strctcpy (d_strctcpy.U):
+ This variable conditionally defines the USE_STRUCT_COPY symbol, which
+ indicates to the C program that this C compiler knows how to copy
+ structures.
+
+d_strerrm (d_strerror.U):
+ This variable holds what Strerrr is defined as to translate an error
+ code condition into an error message string. It could be 'strerror'
+ or a more complex macro emulating strrror with sys_errlist[], or the
+ "unknown" string when both strerror and sys_errlist are missing.
+
+d_strerror (d_strerror.U):
+ This variable conditionally defines HAS_STRERROR if strerror() is
+ available to translate error numbers to strings.
+
+d_strtod (d_strtod.U):
+ This variable conditionally defines the HAS_STRTOD symbol, which
+ indicates to the C program that the strtod() routine is available
+ to provide better numeric string conversion than atof().
+
+d_strtol (d_strtol.U):
+ This variable conditionally defines the HAS_STRTOL symbol, which
+ indicates to the C program that the strtol() routine is available
+ to provide better numeric string conversion than atoi() and friends.
+
+d_strtoul (d_strtoul.U):
+ This variable conditionally defines the HAS_STRTOUL symbol, which
+ indicates to the C program that the strtoul() routine is available
+ to provide conversion of strings to unsigned long.
+
+d_strxfrm (d_strxfrm.U):
+ This variable conditionally defines HAS_STRXFRM if strxfrm() is
+ available to transform strings.
+
+d_suidsafe (d_dosuid.U):
+ This variable conditionally defines SETUID_SCRIPTS_ARE_SECURE_NOW
+ if setuid scripts can be secure. This test looks in /dev/fd/.
+
+d_symlink (d_symlink.U):
+ This variable conditionally defines the HAS_SYMLINK symbol, which
+ indicates to the C program that the symlink() routine is available
+ to create symbolic links.
+
+d_syscall (d_syscall.U):
+ This variable conditionally defines HAS_SYSCALL if syscall() is
+ available call arbitrary system calls.
+
+d_sysconf (d_sysconf.U):
+ This variable conditionally defines the HAS_SYSCONF symbol, which
+ indicates to the C program that the sysconf() routine is available
+ to determine system related limits and options.
+
+d_sysernlst (d_strerror.U):
+ This variable conditionally defines HAS_SYS_ERRNOLIST if sys_errnolist[]
+ is available to translate error numbers to the symbolic name.
+
+d_syserrlst (d_strerror.U):
+ This variable conditionally defines HAS_SYS_ERRLIST if sys_errlist[] is
+ available to translate error numbers to strings.
+
+d_system (d_system.U):
+ This variable conditionally defines HAS_SYSTEM if system() is
+ available to issue a shell command.
+
+d_tcgetpgrp (d_tcgtpgrp.U):
+ This variable conditionally defines the HAS_TCGETPGRP symbol, which
+ indicates to the C program that the tcgetpgrp() routine is available.
+ to get foreground process group ID.
+
+d_tcsetpgrp (d_tcstpgrp.U):
+ This variable conditionally defines the HAS_TCSETPGRP symbol, which
+ indicates to the C program that the tcsetpgrp() routine is available
+ to set foreground process group ID.
+
+d_telldir (d_readdir.U):
+ This variable conditionally defines HAS_TELLDIR if telldir() is
+ available.
+
+d_time (d_time.U):
+ This variable conditionally defines the HAS_TIME symbol, which indicates
+ that the time() routine exists. The time() routine is normaly
+ provided on UNIX systems.
+
+d_times (d_times.U):
+ This variable conditionally defines the HAS_TIMES symbol, which indicates
+ that the times() routine exists. The times() routine is normaly
+ provided on UNIX systems. You may have to include <sys/times.h>.
+
+d_truncate (d_truncate.U):
+ This variable conditionally defines HAS_TRUNCATE if truncate() is
+ available to truncate files.
+
+d_tzname (d_tzname.U):
+ This variable conditionally defines HAS_TZNAME if tzname[] is
+ available to access timezone names.
+
+d_umask (d_umask.U):
+ This variable conditionally defines the HAS_UMASK symbol, which
+ indicates to the C program that the umask() routine is available.
+ to set and get the value of the file creation mask.
+
+d_uname (d_gethname.U):
+ This variable conditionally defines the HAS_UNAME symbol, which
+ indicates to the C program that the uname() routine may be
+ used to derive the host name.
+
+d_union_semun (d_union_senum.U):
+ This variable conditionally defines HAS_UNION_SEMUN if the
+ union semun is defined by including <sys/sem.h>.
+
+d_vfork (d_vfork.U):
+ This variable conditionally defines the HAS_VFORK symbol, which
+ indicates the vfork() routine is available.
+
+d_void_closedir (d_closedir.U):
+ This variable conditionally defines VOID_CLOSEDIR if closedir()
+ does not return a value.
+
+d_voidsig (d_voidsig.U):
+ This variable conditionally defines VOIDSIG if this system
+ declares "void (*signal(...))()" in signal.h. The old way was to
+ declare it as "int (*signal(...))()".
+
+d_voidtty (i_sysioctl.U):
+ This variable conditionally defines USE_IOCNOTTY to indicate that the
+ ioctl() call with TIOCNOTTY should be used to void tty association.
+ Otherwise (on USG probably), it is enough to close the standard file
+ decriptors and do a setpgrp().
+
+d_volatile (d_volatile.U):
+ This variable conditionally defines the HASVOLATILE symbol, which
+ indicates to the C program that this C compiler knows about the
+ volatile declaration.
+
+d_vprintf (d_vprintf.U):
+ This variable conditionally defines the HAS_VPRINTF symbol, which
+ indicates to the C program that the vprintf() routine is available
+ to printf with a pointer to an argument list.
+
+d_wait4 (d_wait4.U):
+ This variable conditionally defines the HAS_WAIT4 symbol, which
+ indicates the wait4() routine is available.
+
+d_waitpid (d_waitpid.U):
+ This variable conditionally defines HAS_WAITPID if waitpid() is
+ available to wait for child process.
+
+d_wcstombs (d_wcstombs.U):
+ This variable conditionally defines the HAS_WCSTOMBS symbol, which
+ indicates to the C program that the wcstombs() routine is available
+ to convert wide character strings to multibyte strings.
+
+d_wctomb (d_wctomb.U):
+ This variable conditionally defines the HAS_WCTOMB symbol, which
+ indicates to the C program that the wctomb() routine is available
+ to convert a wide character to a multibyte.
+
+d_xenix (Guess.U):
+ This variable conditionally defines the symbol XENIX, which alerts
+ the C program that it runs under Xenix.
+
+date (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the date program. After Configure runs,
+ the value is reset to a plain "date" and is not useful.
+
+db_hashtype (i_db.U):
+ This variable contains the type of the hash structure element
+ in the <db.h> header file. In older versions of DB, it was
+ int, while in newer ones it is u_int32_t.
+
+db_prefixtype (i_db.U):
+ This variable contains the type of the prefix structure element
+ in the <db.h> header file. In older versions of DB, it was
+ int, while in newer ones it is size_t.
+
+direntrytype (i_dirent.U):
+ This symbol is set to 'struct direct' or 'struct dirent' depending on
+ whether dirent is available or not. You should use this pseudo type to
+ portably declare your directory entries.
+
+dlext (dlext.U):
+ This variable contains the extension that is to be used for the
+ dynamically loaded modules that perl generaties.
+
+dlsrc (dlsrc.U):
+ This variable contains the name of the dynamic loading file that
+ will be used with the package.
+
+doublesize (doublesize.U):
+ This variable contains the value of the DOUBLESIZE symbol, which
+ indicates to the C program how many bytes there are in a double.
+
+dynamic_ext (Extensions.U):
+ This variable holds a list of XS extension files we want to
+ link dynamically into the package. It is used by Makefile.
+
+eagain (nblock_io.U):
+ This variable bears the symbolic errno code set by read() when no
+ data is present on the file and non-blocking I/O was enabled (otherwise,
+ read() blocks naturally).
+
+ebcdic (ebcdic.U):
+ This variable conditionally defines EBCDIC if this
+ system uses EBCDIC encoding. Among other things, this
+ means that the character ranges are not contiguous.
+ See trnl.U
+
+echo (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the echo program. After Configure runs,
+ the value is reset to a plain "echo" and is not useful.
+
+egrep (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the egrep program. After Configure runs,
+ the value is reset to a plain "egrep" and is not useful.
+
+emacs (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+eunicefix (Init.U):
+ When running under Eunice this variable contains a command which will
+ convert a shell script to the proper form of text file for it to be
+ executable by the shell. On other systems it is a no-op.
+
+exe_ext (Unix.U):
+ This is an old synonym for _exe.
+
+expr (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the expr program. After Configure runs,
+ the value is reset to a plain "expr" and is not useful.
+
+extensions (Extensions.U):
+ This variable holds a list of all extension files (both XS and
+ non-xs linked into the package. It is propagated to Config.pm
+ and is typically used to test whether a particular extesion
+ is available.
+
+find (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the find program. After Configure runs,
+ the value is reset to a plain "find" and is not useful.
+
+firstmakefile (Unix.U):
+ This variable defines the first file searched by make. On unix,
+ it is makefile (then Makefile). On case-insensitive systems,
+ it might be something else. This is only used to deal with
+ convoluted make depend tricks.
+
+flex (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+fpostype (fpostype.U):
+ This variable defines Fpos_t to be something like fpost_t, long,
+ uint, or whatever type is used to declare file positions in libc.
+
+freetype (mallocsrc.U):
+ This variable contains the return type of free(). It is usually
+ void, but occasionally int.
+
+full_csh (d_csh.U):
+ This variable contains the full pathname to 'csh', whether or
+ not the user has specified 'portability'. This is only used
+ in the compiled C program, and we assume that all systems which
+ can share this executable will have the same full pathname to
+ 'csh.'
+
+full_sed (Loc_sed.U):
+ This variable contains the full pathname to 'sed', whether or
+ not the user has specified 'portability'. This is only used
+ in the compiled C program, and we assume that all systems which
+ can share this executable will have the same full pathname to
+ 'sed.'
+
+gccversion (cc.U):
+ If GNU cc (gcc) is used, this variable holds '1' or '2' to
+ indicate whether the compiler is version 1 or 2. This is used in
+ setting some of the default cflags. It is set to '' if not gcc.
+
+gidtype (gidtype.U):
+ This variable defines Gid_t to be something like gid_t, int,
+ ushort, or whatever type is used to declare the return type
+ of getgid(). Typically, it is the type of group ids in the kernel.
+
+grep (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the grep program. After Configure runs,
+ the value is reset to a plain "grep" and is not useful.
+
+groupcat (nis.U):
+ This variable contains a command that produces the text of the
+ /etc/group file. This is normally "cat /etc/group", but can be
+ "ypcat group" when NIS is used.
+
+groupstype (groupstype.U):
+ This variable defines Groups_t to be something like gid_t, int,
+ ushort, or whatever type is used for the second argument to
+ getgroups() and setgroups(). Usually, this is the same as
+ gidtype (gid_t), but sometimes it isn't.
+
+gzip (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the gzip program. After Configure runs,
+ the value is reset to a plain "gzip" and is not useful.
+
+h_fcntl (h_fcntl.U):
+ This is variable gets set in various places to tell i_fcntl that
+ <fcntl.h> should be included.
+
+h_sysfile (h_sysfile.U):
+ This is variable gets set in various places to tell i_sys_file that
+ <sys/file.h> should be included.
+
+hint (Oldconfig.U):
+ Gives the type of hints used for previous answers. May be one of
+ "default", "recommended" or "previous".
+
+hostcat (nis.U):
+ This variable contains a command that produces the text of the
+ /etc/hosts file. This is normally "cat /etc/hosts", but can be
+ "ypcat hosts" when NIS is used.
+
+huge (models.U):
+ This variable contains a flag which will tell the C compiler and loader
+ to produce a program running with a huge memory model. If the
+ huge model is not supported, contains the flag to produce large
+ model programs. It is up to the Makefile to use this.
+
+i_arpainet (i_arpainet.U):
+ This variable conditionally defines the I_ARPA_INET symbol,
+ and indicates whether a C program should include <arpa/inet.h>.
+
+i_bsdioctl (i_sysioctl.U):
+ This variable conditionally defines the I_SYS_BSDIOCTL symbol, which
+ indicates to the C program that <sys/bsdioctl.h> exists and should
+ be included.
+
+i_db (i_db.U):
+ This variable conditionally defines the I_DB symbol, and indicates
+ whether a C program may include Berkeley's DB include file <db.h>.
+
+i_dbm (i_dbm.U):
+ This variable conditionally defines the I_DBM symbol, which
+ indicates to the C program that <dbm.h> exists and should
+ be included.
+
+i_dirent (i_dirent.U):
+ This variable conditionally defines I_DIRENT, which indicates
+ to the C program that it should include <dirent.h>.
+
+i_dld (i_dld.U):
+ This variable conditionally defines the I_DLD symbol, which
+ indicates to the C program that <dld.h> (GNU dynamic loading)
+ exists and should be included.
+
+i_dlfcn (i_dlfcn.U):
+ This variable conditionally defines the I_DLFCN symbol, which
+ indicates to the C program that <dlfcn.h> exists and should
+ be included.
+
+i_fcntl (i_fcntl.U):
+ This variable controls the value of I_FCNTL (which tells
+ the C program to include <fcntl.h>).
+
+i_float (i_float.U):
+ This variable conditionally defines the I_FLOAT symbol, and indicates
+ whether a C program may include <float.h> to get symbols like DBL_MAX
+ or DBL_MIN, i.e. machine dependent floating point values.
+
+i_gdbm (i_gdbm.U):
+ This variable conditionally defines the I_GDBM symbol, which
+ indicates to the C program that <gdbm.h> exists and should
+ be included.
+
+i_grp (i_grp.U):
+ This variable conditionally defines the I_GRP symbol, and indicates
+ whether a C program should include <grp.h>.
+
+i_limits (i_limits.U):
+ This variable conditionally defines the I_LIMITS symbol, and indicates
+ whether a C program may include <limits.h> to get symbols like WORD_BIT
+ and friends.
+
+i_locale (i_locale.U):
+ This variable conditionally defines the I_LOCALE symbol,
+ and indicates whether a C program should include <locale.h>.
+
+i_malloc (i_malloc.U):
+ This variable conditionally defines the I_MALLOC symbol, and indicates
+ whether a C program should include <malloc.h>.
+
+i_math (i_math.U):
+ This variable conditionally defines the I_MATH symbol, and indicates
+ whether a C program may include <math.h>.
+
+i_memory (i_memory.U):
+ This variable conditionally defines the I_MEMORY symbol, and indicates
+ whether a C program should include <memory.h>.
+
+i_ndbm (i_ndbm.U):
+ This variable conditionally defines the I_NDBM symbol, which
+ indicates to the C program that <ndbm.h> exists and should
+ be included.
+
+i_netdb (i_netdb.U):
+ This variable conditionally defines the I_NETDB symbol, and indicates
+ whether a C program should include <netdb.h>.
+
+i_neterrno (i_neterrno.U):
+ This variable conditionally defines the I_NET_ERRNO symbol, which
+ indicates to the C program that <net/errno.h> exists and should
+ be included.
+
+i_niin (i_niin.U):
+ This variable conditionally defines I_NETINET_IN, which indicates
+ to the C program that it should include <netinet/in.h>. Otherwise,
+ you may try <sys/in.h>.
+
+i_pwd (i_pwd.U):
+ This variable conditionally defines I_PWD, which indicates
+ to the C program that it should include <pwd.h>.
+
+i_rpcsvcdbm (i_dbm.U):
+ This variable conditionally defines the I_RPCSVC_DBM symbol, which
+ indicates to the C program that <rpcsvc/dbm.h> exists and should
+ be included. Some System V systems might need this instead of <dbm.h>.
+
+i_sfio (i_sfio.U):
+ This variable conditionally defines the I_SFIO symbol,
+ and indicates whether a C program should include <sfio.h>.
+
+i_sgtty (i_termio.U):
+ This variable conditionally defines the I_SGTTY symbol, which
+ indicates to the C program that it should include <sgtty.h> rather
+ than <termio.h>.
+
+i_stdarg (i_varhdr.U):
+ This variable conditionally defines the I_STDARG symbol, which
+ indicates to the C program that <stdarg.h> exists and should
+ be included.
+
+i_stddef (i_stddef.U):
+ This variable conditionally defines the I_STDDEF symbol, which
+ indicates to the C program that <stddef.h> exists and should
+ be included.
+
+i_stdlib (i_stdlib.U):
+ This variable conditionally defines the I_STDLIB symbol, which
+ indicates to the C program that <stdlib.h> exists and should
+ be included.
+
+i_string (i_string.U):
+ This variable conditionally defines the I_STRING symbol, which
+ indicates that <string.h> should be included rather than <strings.h>.
+
+i_sysdir (i_sysdir.U):
+ This variable conditionally defines the I_SYS_DIR symbol, and indicates
+ whether a C program should include <sys/dir.h>.
+
+i_sysfile (i_sysfile.U):
+ This variable conditionally defines the I_SYS_FILE symbol, and indicates
+ whether a C program should include <sys/file.h> to get R_OK and friends.
+
+i_sysfilio (i_sysioctl.U):
+ This variable conditionally defines the I_SYS_FILIO symbol, which
+ indicates to the C program that <sys/filio.h> exists and should
+ be included in preference to <sys/ioctl.h>.
+
+i_sysin (i_niin.U):
+ This variable conditionally defines I_SYS_IN, which indicates
+ to the C program that it should include <sys/in.h> instead of
+ <netinet/in.h>.
+
+i_sysioctl (i_sysioctl.U):
+ This variable conditionally defines the I_SYS_IOCTL symbol, which
+ indicates to the C program that <sys/ioctl.h> exists and should
+ be included.
+
+i_sysndir (i_sysndir.U):
+ This variable conditionally defines the I_SYS_NDIR symbol, and indicates
+ whether a C program should include <sys/ndir.h>.
+
+i_sysparam (i_sysparam.U):
+ This variable conditionally defines the I_SYS_PARAM symbol, and indicates
+ whether a C program should include <sys/param.h>.
+
+i_sysresrc (i_sysresrc.U):
+ This variable conditionally defines the I_SYS_RESOURCE symbol,
+ and indicates whether a C program should include <sys/resource.h>.
+
+i_sysselct (i_sysselct.U):
+ This variable conditionally defines I_SYS_SELECT, which indicates
+ to the C program that it should include <sys/select.h> in order to
+ get the definition of struct timeval.
+
+i_syssockio (i_sysioctl.U):
+ This variable conditionally defines I_SYS_SOCKIO to indicate to the
+ C program that socket ioctl codes may be found in <sys/sockio.h>
+ instead of <sys/ioctl.h>.
+
+i_sysstat (i_sysstat.U):
+ This variable conditionally defines the I_SYS_STAT symbol,
+ and indicates whether a C program should include <sys/stat.h>.
+
+i_systime (i_time.U):
+ This variable conditionally defines I_SYS_TIME, which indicates
+ to the C program that it should include <sys/time.h>.
+
+i_systimek (i_time.U):
+ This variable conditionally defines I_SYS_TIME_KERNEL, which
+ indicates to the C program that it should include <sys/time.h>
+ with KERNEL defined.
+
+i_systimes (i_systimes.U):
+ This variable conditionally defines the I_SYS_TIMES symbol, and indicates
+ whether a C program should include <sys/times.h>.
+
+i_systypes (i_systypes.U):
+ This variable conditionally defines the I_SYS_TYPES symbol,
+ and indicates whether a C program should include <sys/types.h>.
+
+i_sysun (i_sysun.U):
+ This variable conditionally defines I_SYS_UN, which indicates
+ to the C program that it should include <sys/un.h> to get UNIX
+ domain socket definitions.
+
+i_syswait (i_syswait.U):
+ This variable conditionally defines I_SYS_WAIT, which indicates
+ to the C program that it should include <sys/wait.h>.
+
+i_termio (i_termio.U):
+ This variable conditionally defines the I_TERMIO symbol, which
+ indicates to the C program that it should include <termio.h> rather
+ than <sgtty.h>.
+
+i_termios (i_termio.U):
+ This variable conditionally defines the I_TERMIOS symbol, which
+ indicates to the C program that the POSIX <termios.h> file is
+ to be included.
+
+i_time (i_time.U):
+ This variable conditionally defines I_TIME, which indicates
+ to the C program that it should include <time.h>.
+
+i_unistd (i_unistd.U):
+ This variable conditionally defines the I_UNISTD symbol, and indicates
+ whether a C program should include <unistd.h>.
+
+i_utime (i_utime.U):
+ This variable conditionally defines the I_UTIME symbol, and indicates
+ whether a C program should include <utime.h>.
+
+i_values (i_values.U):
+ This variable conditionally defines the I_VALUES symbol, and indicates
+ whether a C program may include <values.h> to get symbols like MAXLONG
+ and friends.
+
+i_varargs (i_varhdr.U):
+ This variable conditionally defines I_VARARGS, which indicates
+ to the C program that it should include <varargs.h>.
+
+i_varhdr (i_varhdr.U):
+ Contains the name of the header to be included to get va_dcl definition.
+ Typically one of varargs.h or stdarg.h.
+
+i_vfork (i_vfork.U):
+ This variable conditionally defines the I_VFORK symbol, and indicates
+ whether a C program should include vfork.h.
+
+incpath (usrinc.U):
+ This variable must preceed the normal include path to get hte
+ right one, as in "$incpath/usr/include" or "$incpath/usr/lib".
+ Value can be "" or "/bsd43" on mips.
+
+inews (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+installarchlib (archlib.U):
+ This variable is really the same as archlibexp but may differ on
+ those systems using AFS. For extra portability, only this variable
+ should be used in makefiles.
+
+installbin (bin.U):
+ This variable is the same as binexp unless AFS is running in which case
+ the user is explicitely prompted for it. This variable should always
+ be used in your makefiles for maximum portability.
+
+installman1dir (man1dir.U):
+ This variable is really the same as man1direxp, unless you are using
+ AFS in which case it points to the read/write location whereas
+ man1direxp only points to the read-only access location. For extra
+ portability, you should only use this variable within your makefiles.
+
+installman3dir (man3dir.U):
+ This variable is really the same as man3direxp, unless you are using
+ AFS in which case it points to the read/write location whereas
+ man3direxp only points to the read-only access location. For extra
+ portability, you should only use this variable within your makefiles.
+
+installprivlib (privlib.U):
+ This variable is really the same as privlibexp but may differ on
+ those systems using AFS. For extra portability, only this variable
+ should be used in makefiles.
+
+installscript (scriptdir.U):
+ This variable is usually the same as scriptdirexp, unless you are on
+ a system running AFS, in which case they may differ slightly. You
+ should always use this variable within your makefiles for portability.
+
+installsitearch (sitearch.U):
+ This variable is really the same as sitearchexp but may differ on
+ those systems using AFS. For extra portability, only this variable
+ should be used in makefiles.
+
+installsitelib (sitelib.U):
+ This variable is really the same as sitelibexp but may differ on
+ those systems using AFS. For extra portability, only this variable
+ should be used in makefiles.
+
+intsize (intsize.U):
+ This variable contains the value of the INTSIZE symbol, which
+ indicates to the C program how many bytes there are in an int.
+
+known_extensions (Extensions.U):
+ This variable holds a list of all XS extensions included in
+ the package.
+
+ksh (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+large (models.U):
+ This variable contains a flag which will tell the C compiler and loader
+ to produce a program running with a large memory model. It is up to
+ the Makefile to use this.
+
+ld (dlsrc.U):
+ This variable indicates the program to be used to link
+ libraries for dynamic loading. On some systems, it is 'ld'.
+ On ELF systems, it should be $cc. Mostly, we'll try to respect
+ the hint file setting.
+
+lddlflags (dlsrc.U):
+ This variable contains any special flags that might need to be
+ passed to $ld to create a shared library suitable for dynamic
+ loading. It is up to the makefile to use it. For hpux, it
+ should be '-b'. For sunos 4.1, it is empty.
+
+ldflags (ccflags.U):
+ This variable contains any additional C loader flags desired by
+ the user. It is up to the Makefile to use this.
+
+less (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the less program. After Configure runs,
+ the value is reset to a plain "less" and is not useful.
+
+lib_ext (Unix.U):
+ This is an old synonym for _a.
+
+libc (libc.U):
+ This variable contains the location of the C library.
+
+libperl (libperl.U):
+ The perl executable is obtained by linking perlmain.c with
+ libperl, any static extensions (usually just DynaLoader),
+ and any other libraries needed on this system. libperl
+ is usually libperl.a, but can also be libperl.so.xxx if
+ the user wishes to build a perl executable with a shared
+ library.
+
+libpth (libpth.U):
+ This variable holds the general path used to find libraries. It is
+ intended to be used by other units.
+
+libs (libs.U):
+ This variable holds the additional libraries we want to use.
+ It is up to the Makefile to deal with it.
+
+libswanted (Myinit.U):
+ This variable holds a list of all the libraries we want to
+ search. The order is chosen to pick up the c library
+ ahead of ucb or bsd libraries for SVR4.
+
+line (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the line program. After Configure runs,
+ the value is reset to a plain "line" and is not useful.
+
+lint (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+lkflags (ccflags.U):
+ This variable contains any additional C partial linker flags desired by
+ the user. It is up to the Makefile to use this.
+
+ln (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the ln program. After Configure runs,
+ the value is reset to a plain "ln" and is not useful.
+
+lns (lns.U):
+ This variable holds the name of the command to make
+ symbolic links (if they are supported). It can be used
+ in the Makefile. It is either 'ln -s' or 'ln'
+
+locincpth (ccflags.U):
+ This variable contains a list of additional directories to be
+ searched by the compiler. The appropriate '-I' directives will
+ be added to ccflags. This is intended to simplify setting
+ local directories from the Configure command line.
+ It's not much, but it parallels the loclibpth stuff in libpth.U.
+
+loclibpth (libpth.U):
+ This variable holds the paths used to find local libraries. It is
+ prepended to libpth, and is intended to be easily set from the
+ command line.
+
+longdblsize (d_longdbl.U):
+ This variable contains the value of the LONG_DOUBLESIZE symbol, which
+ indicates to the C program how many bytes there are in a long double,
+ if this system supports long doubles.
+
+longlongsize (d_longlong.U):
+ This variable contains the value of the LONGLONGSIZE symbol, which
+ indicates to the C program how many bytes there are in a long long,
+ if this system supports long long.
+
+longsize (intsize.U):
+ This variable contains the value of the LONGSIZE symbol, which
+ indicates to the C program how many bytes there are in a long.
+
+lp (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+lpr (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+ls (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the ls program. After Configure runs,
+ the value is reset to a plain "ls" and is not useful.
+
+lseektype (lseektype.U):
+ This variable defines lseektype to be something like off_t, long,
+ or whatever type is used to declare lseek offset's type in the
+ kernel (which also appears to be lseek's return type).
+
+mail (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+mailx (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+make (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the make program. After Configure runs,
+ the value is reset to a plain "make" and is not useful.
+
+make_set_make (make.U):
+ Some versions of 'make' set the variable MAKE. Others do not.
+ This variable contains the string to be included in Makefile.SH
+ so that MAKE is set if needed, and not if not needed.
+ Possible values are:
+ make_set_make='#' # If your make program handles this for you,
+ make_set_make="MAKE=$make" # if it doesn't.
+ I used a comment character so that we can distinguish a
+ 'set' value (from a previous config.sh or Configure '-D' option)
+ from an uncomputed value.
+
+mallocobj (mallocsrc.U):
+ This variable contains the name of the malloc.o that this package
+ generates, if that malloc.o is preferred over the system malloc.
+ Otherwise the value is null. This variable is intended for generating
+ Makefiles. See mallocsrc.
+
+mallocsrc (mallocsrc.U):
+ This variable contains the name of the malloc.c that comes with
+ the package, if that malloc.c is preferred over the system malloc.
+ Otherwise the value is null. This variable is intended for generating
+ Makefiles.
+
+malloctype (mallocsrc.U):
+ This variable contains the kind of ptr returned by malloc and realloc.
+
+man1dir (man1dir.U):
+ This variable contains the name of the directory in which manual
+ source pages are to be put. It is the responsibility of the
+ Makefile.SH to get the value of this into the proper command.
+ You must be prepared to do the ~name expansion yourself.
+
+man1direxp (man1dir.U):
+ This variable is the same as the man1dir variable, but is filename
+ expanded at configuration time, for convenient use in makefiles.
+
+man1ext (man1dir.U):
+ This variable contains the extension that the manual page should
+ have: one of 'n', 'l', or '1'. The Makefile must supply the '.'.
+ See man1dir.
+
+man3dir (man3dir.U):
+ This variable contains the name of the directory in which manual
+ source pages are to be put. It is the responsibility of the
+ Makefile.SH to get the value of this into the proper command.
+ You must be prepared to do the ~name expansion yourself.
+
+man3direxp (man3dir.U):
+ This variable is the same as the man3dir variable, but is filename
+ expanded at configuration time, for convenient use in makefiles.
+
+man3ext (man3dir.U):
+ This variable contains the extension that the manual page should
+ have: one of 'n', 'l', or '3'. The Makefile must supply the '.'.
+ See man3dir.
+
+medium (models.U):
+ This variable contains a flag which will tell the C compiler and loader
+ to produce a program running with a medium memory model. If the
+ medium model is not supported, contains the flag to produce large
+ model programs. It is up to the Makefile to use this.
+
+mips_type (usrinc.U):
+ This variable holds the environment type for the mips system.
+ Possible values are "BSD 4.3" and "System V".
+
+mkdir (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the mkdir program. After Configure runs,
+ the value is reset to a plain "mkdir" and is not useful.
+
+models (models.U):
+ This variable contains the list of memory models supported by this
+ system. Possible component values are none, split, unsplit, small,
+ medium, large, and huge. The component values are space separated.
+
+modetype (modetype.U):
+ This variable defines modetype to be something like mode_t,
+ int, unsigned short, or whatever type is used to declare file
+ modes for system calls.
+
+more (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the more program. After Configure runs,
+ the value is reset to a plain "more" and is not useful.
+
+mv (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+myarchname (archname.U):
+ This variable holds the architecture name computed by Configure in
+ a previous run. It is not intended to be perused by any user and
+ should never be set in a hint file.
+
+mydomain (myhostname.U):
+ This variable contains the eventual value of the MYDOMAIN symbol,
+ which is the domain of the host the program is going to run on.
+ The domain must be appended to myhostname to form a complete host name.
+ The dot comes with mydomain, and need not be supplied by the program.
+
+myhostname (myhostname.U):
+ This variable contains the eventual value of the MYHOSTNAME symbol,
+ which is the name of the host the program is going to run on.
+ The domain is not kept with hostname, but must be gotten from mydomain.
+ The dot comes with mydomain, and need not be supplied by the program.
+
+myuname (Oldconfig.U):
+ The output of 'uname -a' if available, otherwise the hostname. On Xenix,
+ pseudo variables assignments in the output are stripped, thank you. The
+ whole thing is then lower-cased.
+
+n (n.U):
+ This variable contains the '-n' flag if that is what causes the echo
+ command to suppress newline. Otherwise it is null. Correct usage is
+ $echo $n "prompt for a question: $c".
+
+netdb_hlen_type (netdbtype.U):
+ This variable holds the type used for the 2nd argument to
+ gethostbyaddr(). Usually, this is int or size_t or unsigned.
+ This is only useful if you have gethostbyaddr(), naturally.
+
+netdb_host_type (netdbtype.U):
+ This variable holds the type used for the 1st argument to
+ gethostbyaddr(). Usually, this is char * or void *, possibly
+ with or without a const prefix.
+ This is only useful if you have gethostbyaddr(), naturally.
+
+netdb_name_type (netdbtype.U):
+ This variable holds the type used for the argument to
+ gethostbyname(). Usually, this is char * or const char *.
+ This is only useful if you have gethostbyname(), naturally.
+
+netdb_net_type (netdbtype.U):
+ This variable holds the type used for the 1st argument to
+ getnetbyaddr(). Usually, this is int or long.
+ This is only useful if you have getnetbyaddr(), naturally.
+
+nm (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the nm program. After Configure runs,
+ the value is reset to a plain "nm" and is not useful.
+
+nm_opt (usenm.U):
+ This variable holds the options that may be necessary for nm.
+
+nm_so_opt (usenm.U):
+ This variable holds the options that may be necessary for nm
+ to work on a shared library but that can not be used on an
+ archive library. Currently, this is only used by Linux, where
+ nm --dynamic is *required* to get symbols from an ELF library which
+ has been stripped, but nm --dynamic is *fatal* on an archive library.
+ Maybe Linux should just always set usenm=false.
+
+nonxs_ext (Extensions.U):
+ This variable holds a list of all non-xs extensions included
+ in the package. All of them will be built.
+
+nroff (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the nroff program. After Configure runs,
+ the value is reset to a plain "nroff" and is not useful.
+
+o_nonblock (nblock_io.U):
+ This variable bears the symbol value to be used during open() or fcntl()
+ to turn on non-blocking I/O for a file descriptor. If you wish to switch
+ between blocking and non-blocking, you may try ioctl(FIOSNBIO) instead,
+ but that is only supported by some devices.
+
+obj_ext (Unix.U):
+ This is an old synonym for _o.
+
+optimize (ccflags.U):
+ This variable contains any optimizer/debugger flag that should be used.
+ It is up to the Makefile to use it.
+
+orderlib (orderlib.U):
+ This variable is "true" if the components of libraries must be ordered
+ (with `lorder $* | tsort`) before placing them in an archive. Set to
+ "false" if ranlib or ar can generate random libraries.
+
+osname (Oldconfig.U):
+ This variable contains the operating system name (e.g. sunos,
+ solaris, hpux, etc.). It can be useful later on for setting
+ defaults. Any spaces are replaced with underscores. It is set
+ to a null string if we can't figure it out.
+
+osvers (Oldconfig.U):
+ This variable contains the operating system version (e.g.
+ 4.1.3, 5.2, etc.). It is primarily used for helping select
+ an appropriate hints file, but might be useful elsewhere for
+ setting defaults. It is set to '' if we can't figure it out.
+ We try to be flexible about how much of the version number
+ to keep, e.g. if 4.1.1, 4.1.2, and 4.1.3 are essentially the
+ same for this package, hints files might just be os_4.0 or
+ os_4.1, etc., not keeping separate files for each little release.
+
+package (package.U):
+ This variable contains the name of the package being constructed.
+ It is primarily intended for the use of later Configure units.
+
+pager (pager.U):
+ This variable contains the name of the preferred pager on the system.
+ Usual values are (the full pathnames of) more, less, pg, or cat.
+
+passcat (nis.U):
+ This variable contains a command that produces the text of the
+ /etc/passwd file. This is normally "cat /etc/passwd", but can be
+ "ypcat passwd" when NIS is used.
+
+patchlevel (patchlevel.U):
+ The patchlevel level of this package.
+ The value of patchlevel comes from the patchlevel.h file.
+
+path_sep (Unix.U):
+ This is an old synonym for p_ in Head.U, the character
+ used to separate elements in the command shell search PATH.
+
+perl (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the perl program. After Configure runs,
+ the value is reset to a plain "perl" and is not useful.
+
+perladmin (perladmin.U):
+ Electronic mail address of the perl5 administrator.
+
+perlpath (perlpath.U):
+ This variable contains the eventual value of the PERLPATH symbol,
+ which contains the name of the perl interpreter to be used in
+ shell scripts and in the "eval 'exec'" idiom.
+
+pg (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the pg program. After Configure runs,
+ the value is reset to a plain "pg" and is not useful.
+
+phostname (myhostname.U):
+ This variable contains the eventual value of the PHOSTNAME symbol,
+ which is a command that can be fed to popen() to get the host name.
+ The program should probably not presume that the domain is or isn't
+ there already.
+
+pidtype (pidtype.U):
+ This variable defines PIDTYPE to be something like pid_t, int,
+ ushort, or whatever type is used to declare process ids in the kernel.
+
+plibpth (libpth.U):
+ Holds the private path used by Configure to find out the libraries.
+ Its value is prepend to libpth. This variable takes care of special
+ machines, like the mips. Usually, it should be empty.
+
+pmake (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+pr (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+prefix (prefix.U):
+ This variable holds the name of the directory below which the
+ user will install the package. Usually, this is /usr/local, and
+ executables go in /usr/local/bin, library stuff in /usr/local/lib,
+ man pages in /usr/local/man, etc. It is only used to set defaults
+ for things in bin.U, mansrc.U, privlib.U, or scriptdir.U.
+
+prefixexp (prefix.U):
+ This variable holds the full absolute path of the directory below
+ which the user will install the package. Derived from prefix.
+
+privlib (privlib.U):
+ This variable contains the eventual value of the PRIVLIB symbol,
+ which is the name of the private library for this package. It may
+ have a ~ on the front. It is up to the makefile to eventually create
+ this directory while performing installation (with ~ substitution).
+
+privlibexp (privlib.U):
+ This variable is the ~name expanded version of privlib, so that you
+ may use it directly in Makefiles or shell scripts.
+
+prototype (prototype.U):
+ This variable holds the eventual value of CAN_PROTOTYPE, which
+ indicates the C compiler can handle funciton prototypes.
+
+ptrsize (ptrsize.U):
+ This variable contains the value of the PTRSIZE symbol, which
+ indicates to the C program how many bytes there are in a pointer.
+
+randbits (randbits.U):
+ This variable contains the eventual value of the RANDBITS symbol,
+ which indicates to the C program how many bits of random number
+ the rand() function produces.
+
+ranlib (orderlib.U):
+ This variable is set to the pathname of the ranlib program, if it is
+ needed to generate random libraries. Set to ":" if ar can generate
+ random libraries or if random libraries are not supported
+
+rd_nodata (nblock_io.U):
+ This variable holds the return code from read() when no data is
+ present. It should be -1, but some systems return 0 when O_NDELAY is
+ used, which is a shame because you cannot make the difference between
+ no data and an EOF.. Sigh!
+
+rm (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the rm program. After Configure runs,
+ the value is reset to a plain "rm" and is not useful.
+
+rmail (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+runnm (usenm.U):
+ This variable contains 'true' or 'false' depending whether the
+ nm extraction should be performed or not, according to the value
+ of usenm and the flags on the Configure command line.
+
+scriptdir (scriptdir.U):
+ This variable holds the name of the directory in which the user wants
+ to put publicly scripts for the package in question. It is either
+ the same directory as for binaries, or a special one that can be
+ mounted across different architectures, like /usr/share. Programs
+ must be prepared to deal with ~name expansion.
+
+scriptdirexp (scriptdir.U):
+ This variable is the same as scriptdir, but is filename expanded
+ at configuration time, for programs not wanting to bother with it.
+
+sed (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the sed program. After Configure runs,
+ the value is reset to a plain "sed" and is not useful.
+
+selecttype (selecttype.U):
+ This variable holds the type used for the 2nd, 3rd, and 4th
+ arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
+ is defined, and 'int *' otherwise. This is only useful if you
+ have select(), naturally.
+
+sendmail (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the sendmail program. After Configure runs,
+ the value is reset to a plain "sendmail" and is not useful.
+
+sh (sh.U):
+ This variable contains the full pathname of the shell used
+ on this system to execute Bourne shell scripts. Usually, this will be
+ /bin/sh, though it's possible that some systems will have /bin/ksh,
+ /bin/pdksh, /bin/ash, /bin/bash, or even something such as
+ D:/bin/sh.exe.
+ This unit comes before Options.U, so you can't set sh with a '-D'
+ option, though you can override this (and startsh)
+ with '-O -Dsh=/bin/whatever -Dstartsh=whatever'
+
+shar (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+sharpbang (spitshell.U):
+ This variable contains the string #! if this system supports that
+ construct.
+
+shmattype (d_shmat.U):
+ This symbol contains the type of pointer returned by shmat().
+ It can be 'void *' or 'char *'.
+
+shortsize (intsize.U):
+ This variable contains the value of the SHORTSIZE symbol which
+ indicates to the C program how many bytes there are in a short.
+
+shrpenv (libperl.U):
+ If the user builds a shared libperl.so, then we need to tell the
+ 'perl' executable where it will be able to find the installed libperl.so.
+ One way to do this on some systems is to set the environment variable
+ LD_RUN_PATH to the directory that will be the final location of the
+ shared libperl.so. The makefile can use this with something like
+ $shrpenv $(CC) -o perl perlmain.o $libperl $libs
+ Typical values are
+ shrpenv="env LD_RUN_PATH=$archlibexp/CORE"
+ or
+ shrpenv=''
+ See the main perl Makefile.SH for actual working usage.
+ Alternatively, we might be able to use a command line option such
+ as -R $archlibexp/CORE (Solaris, NetBSD) or -Wl,-rpath
+ $archlibexp/CORE (Linux).
+
+shsharp (spitshell.U):
+ This variable tells further Configure units whether your sh can
+ handle # comments.
+
+sig_name (sig_name.U):
+ This variable holds the signal names, space separated. The leading
+ SIG in signal name is removed. A ZERO is prepended to the
+ list. This is currently not used.
+
+sig_name_init (sig_name.U):
+ This variable holds the signal names, enclosed in double quotes and
+ separated by commas, suitable for use in the SIG_NAME definition
+ below. A "ZERO" is prepended to the list, and the list is
+ terminated with a plain 0. The leading SIG in signal names
+ is removed. See sig_num.
+
+sig_num (sig_name.U):
+ This variable holds the signal numbers, comma separated. A 0 is
+ prepended to the list (corresponding to the fake SIGZERO), and
+ the list is terminated with a 0. Those numbers correspond to
+ the value of the signal listed in the same place within the
+ sig_name list.
+
+signal_t (d_voidsig.U):
+ This variable holds the type of the signal handler (void or int).
+
+sitearch (sitearch.U):
+ This variable contains the eventual value of the SITEARCH symbol,
+ which is the name of the private library for this package. It may
+ have a ~ on the front. It is up to the makefile to eventually create
+ this directory while performing installation (with ~ substitution).
+
+sitearchexp (sitearch.U):
+ This variable is the ~name expanded version of sitearch, so that you
+ may use it directly in Makefiles or shell scripts.
+
+sitelib (sitelib.U):
+ This variable contains the eventual value of the SITELIB symbol,
+ which is the name of the private library for this package. It may
+ have a ~ on the front. It is up to the makefile to eventually create
+ this directory while performing installation (with ~ substitution).
+
+sitelibexp (sitelib.U):
+ This variable is the ~name expanded version of sitelib, so that you
+ may use it directly in Makefiles or shell scripts.
+
+sizetype (sizetype.U):
+ This variable defines sizetype to be something like size_t,
+ unsigned long, or whatever type is used to declare length
+ parameters for string functions.
+
+sleep (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+smail (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+small (models.U):
+ This variable contains a flag which will tell the C compiler and loader
+ to produce a program running with a small memory model. It is up to
+ the Makefile to use this.
+
+so (so.U):
+ This variable holds the extension used to identify shared libraries
+ (also known as shared objects) on the system. Usually set to 'so'.
+
+sockethdr (d_socket.U):
+ This variable has any cpp '-I' flags needed for socket support.
+
+socketlib (d_socket.U):
+ This variable has the names of any libraries needed for socket support.
+
+sort (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the sort program. After Configure runs,
+ the value is reset to a plain "sort" and is not useful.
+
+spackage (package.U):
+ This variable contains the name of the package being constructed,
+ with the first letter uppercased, i.e. suitable for starting
+ sentences.
+
+spitshell (spitshell.U):
+ This variable contains the command necessary to spit out a runnable
+ shell on this system. It is either cat or a grep '-v' for # comments.
+
+split (models.U):
+ This variable contains a flag which will tell the C compiler and loader
+ to produce a program that will run in separate I and D space, for those
+ machines that support separation of instruction and data space. It is
+ up to the Makefile to use this.
+
+src (src.U):
+ This variable holds the path to the package source. It is up to
+ the Makefile to use this variable and set VPATH accordingly to
+ find the sources remotely.
+
+ssizetype (ssizetype.U):
+ This variable defines ssizetype to be something like ssize_t,
+ long or int. It is used by functions that return a count
+ of bytes or an error condition. It must be a signed type.
+ We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+
+startperl (startperl.U):
+ This variable contains the string to put on the front of a perl
+ script to make sure (hopefully) that it runs with perl and not some
+ shell. Of course, that leading line must be followed by the classical
+ perl idiom:
+ eval 'exec perl -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+ to guarantee perl startup should the shell execute the script. Note
+ that this magic incatation is not understood by csh.
+
+startsh (startsh.U):
+ This variable contains the string to put on the front of a shell
+ script to make sure (hopefully) that it runs with sh and not some
+ other shell.
+
+static_ext (Extensions.U):
+ This variable holds a list of XS extension files we want to
+ link statically into the package. It is used by Makefile.
+
+stdchar (stdchar.U):
+ This variable conditionally defines STDCHAR to be the type of char
+ used in stdio.h. It has the values "unsigned char" or "char".
+
+stdio_base (d_stdstdio.U):
+ This variable defines how, given a FILE pointer, fp, to access the
+ _base field (or equivalent) of stdio.h's FILE structure. This will
+ be used to define the macro FILE_base(fp).
+
+stdio_bufsiz (d_stdstdio.U):
+ This variable defines how, given a FILE pointer, fp, to determine
+ the number of bytes store in the I/O buffer pointer to by the
+ _base field (or equivalent) of stdio.h's FILE structure. This will
+ be used to define the macro FILE_bufsiz(fp).
+
+stdio_cnt (d_stdstdio.U):
+ This variable defines how, given a FILE pointer, fp, to access the
+ _cnt field (or equivalent) of stdio.h's FILE structure. This will
+ be used to define the macro FILE_cnt(fp).
+
+stdio_filbuf (d_stdstdio.U):
+ This variable defines how, given a FILE pointer, fp, to tell
+ stdio to refill it's internal buffers (?). This will
+ be used to define the macro FILE_filbuf(fp).
+
+stdio_ptr (d_stdstdio.U):
+ This variable defines how, given a FILE pointer, fp, to access the
+ _ptr field (or equivalent) of stdio.h's FILE structure. This will
+ be used to define the macro FILE_ptr(fp).
+
+strings (i_string.U):
+ This variable holds the full path of the string header that will be
+ used. Typically /usr/include/string.h or /usr/include/strings.h.
+
+submit (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+subversion (patchlevel.U):
+ The subversion level of this package.
+ The value of subversion comes from the patchlevel.h file.
+ This is unique to perl.
+
+sysman (sysman.U):
+ This variable holds the place where the manual is located on this
+ system. It is not the place where the user wants to put his manual
+ pages. Rather it is the place where Configure may look to find manual
+ for unix commands (section 1 of the manual usually). See mansrc.
+
+tail (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+tar (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+tbl (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+tee (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the tee program. After Configure runs,
+ the value is reset to a plain "tee" and is not useful.
+
+test (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the test program. After Configure runs,
+ the value is reset to a plain "test" and is not useful.
+
+timeincl (i_time.U):
+ This variable holds the full path of the included time header(s).
+
+timetype (d_time.U):
+ This variable holds the type returned by time(). It can be long,
+ or time_t on BSD sites (in which case <sys/types.h> should be
+ included). Anyway, the type Time_t should be used.
+
+touch (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the touch program. After Configure runs,
+ the value is reset to a plain "touch" and is not useful.
+
+tr (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the tr program. After Configure runs,
+ the value is reset to a plain "tr" and is not useful.
+
+trnl (trnl.U):
+ This variable contains the value to be passed to the tr(1)
+ command to transliterate a newline. Typical values are
+ '\012' and '\n'. This is needed for EBCDIC systems where
+ newline is not necessarily '\012'.
+
+troff (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+uidtype (uidtype.U):
+ This variable defines Uid_t to be something like uid_t, int,
+ ushort, or whatever type is used to declare user ids in the kernel.
+
+uname (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the uname program. After Configure runs,
+ the value is reset to a plain "uname" and is not useful.
+
+uniq (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the uniq program. After Configure runs,
+ the value is reset to a plain "uniq" and is not useful.
+
+usedl (dlsrc.U):
+ This variable indicates if the the system supports dynamic
+ loading of some sort. See also dlsrc and dlobj.
+
+usemymalloc (mallocsrc.U):
+ This variable contains y if the malloc that comes with this package
+ is desired over the system's version of malloc. People often include
+ special versions of malloc for effiency, but such versions are often
+ less portable. See also mallocsrc and mallocobj.
+ If this is 'y', then -lmalloc is removed from $libs.
+
+usenm (usenm.U):
+ This variable contains 'true' or 'false' depending whether the
+ nm extraction is wanted or not.
+
+useopcode (Extensions.U):
+ This variable holds either 'true' or 'false' to indicate
+ whether the Opcode extension should be used. The sole
+ use for this currently is to allow an easy mechanism
+ for users to skip the Opcode extension from the Configure
+ command line.
+
+useperlio (useperlio.U):
+ This variable conditionally defines the USE_PERLIO symbol,
+ and indicates that the PerlIO abstraction should be
+ used throughout.
+
+useposix (Extensions.U):
+ This variable holds either 'true' or 'false' to indicate
+ whether the POSIX extension should be used. The sole
+ use for this currently is to allow an easy mechanism
+ for hints files to indicate that POSIX will not compile
+ on a particular system.
+
+usesfio (d_sfio.U):
+ This variable is set to true when the user agrees to use sfio.
+ It is set to false when sfio is not available or when the user
+ explicitely requests not to use sfio. It is here primarily so
+ that command-line settings can override the auto-detection of
+ d_sfio without running into a "WHOA THERE".
+
+useshrplib (libperl.U):
+ This variable is set to 'yes' if the user wishes
+ to build a shared libperl, and 'no' otherwise.
+
+usethreads (usethreads.U):
+ This variable conditionally defines the USE_THREADS symbol,
+ and indicates that Perl should be built to use threads.
+
+usevfork (d_vfork.U):
+ This variable is set to true when the user accepts to use vfork.
+ It is set to false when no vfork is available or when the user
+ explicitely requests not to use vfork.
+
+usrinc (usrinc.U):
+ This variable holds the path of the include files, which is
+ usually /usr/include. It is mainly used by other Configure units.
+
+uuname (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+version (patchlevel.U):
+ The full version number of this package. This combines
+ baserev, patchlevel, and subversion to get the full
+ version number, including any possible subversions. Care
+ is taken to use the C locale in order to get something
+ like 5.004 instead of 5,004. This is unique to perl.
+
+vi (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+voidflags (voidflags.U):
+ This variable contains the eventual value of the VOIDFLAGS symbol,
+ which indicates how much support of the void type is given by this
+ compiler. See VOIDFLAGS for more info.
+
+zcat (Loc.U):
+ This variable is defined but not used by Configure.
+ The value is a plain '' and is not useful.
+
+zip (Loc.U):
+ This variable is be used internally by Configure to determine the
+ full pathname (if any) of the zip program. After Configure runs,
+ the value is reset to a plain "zip" and is not useful.
+
diff --git a/contrib/perl5/Porting/config.sh b/contrib/perl5/Porting/config.sh
new file mode 100644
index 000000000000..20e1c4cfd789
--- /dev/null
+++ b/contrib/perl5/Porting/config.sh
@@ -0,0 +1,585 @@
+#!/bin/sh
+#
+# This file was produced by running the Configure script. It holds all the
+# definitions figured out by Configure. Should you modify one of these values,
+# do not forget to propagate your changes by running "Configure -der". You may
+# instead choose to run each of the .SH files by yourself, or "Configure -S".
+#
+
+# Package name : perl5
+# Source directory : .
+# Configuration time: Tue Jul 21 10:03:27 EDT 1998
+# Configured by : doughera
+# Target system : linux fractal 2.0.34 #1 tue jun 23 10:09:17 edt 1998 i686 unknown
+
+Author=''
+Date='$Date'
+Header=''
+Id='$Id'
+Locker=''
+Log='$Log'
+Mcc='Mcc'
+RCSfile='$RCSfile'
+Revision='$Revision'
+Source=''
+State=''
+_a='.a'
+_exe=''
+_o='.o'
+afs='false'
+alignbytes='4'
+ansi2knr=''
+aphostname=''
+apiversion='5.005'
+ar='ar'
+archlib='/opt/perl/lib/5.005/i686-linux-thread'
+archlibexp='/opt/perl/lib/5.005/i686-linux-thread'
+archname='i686-linux-thread'
+archobjs=''
+awk='awk'
+baserev='5.0'
+bash=''
+bin='/opt/perl/bin'
+binexp='/opt/perl/bin'
+bison=''
+byacc='byacc'
+byteorder='1234'
+c=''
+castflags='0'
+cat='cat'
+cc='cc'
+cccdlflags='-fpic'
+ccdlflags='-rdynamic'
+ccflags='-D_REENTRANT -Dbool=char -DHAS_BOOL -I/usr/local/include'
+cf_by='doughera'
+cf_email='yourname@yourhost.yourplace.com'
+cf_time='Tue Jul 21 10:03:27 EDT 1998'
+chgrp=''
+chmod=''
+chown=''
+clocktype='clock_t'
+comm='comm'
+compress=''
+contains='grep'
+cp='cp'
+cpio=''
+cpp='cpp'
+cpp_stuff='42'
+cppflags='-D_REENTRANT -Dbool=char -DHAS_BOOL -I/usr/local/include'
+cpplast='-'
+cppminus='-'
+cpprun='cc -E'
+cppstdin='cc -E'
+cryptlib=''
+csh='csh'
+d_Gconvert='gcvt((x),(n),(b))'
+d_access='define'
+d_alarm='define'
+d_archlib='define'
+d_attribut='define'
+d_bcmp='define'
+d_bcopy='define'
+d_bsd='undef'
+d_bsdgetpgrp='undef'
+d_bsdsetpgrp='undef'
+d_bzero='define'
+d_casti32='undef'
+d_castneg='define'
+d_charvspr='undef'
+d_chown='define'
+d_chroot='define'
+d_chsize='undef'
+d_closedir='define'
+d_const='define'
+d_crypt='define'
+d_csh='define'
+d_cuserid='define'
+d_dbl_dig='define'
+d_difftime='define'
+d_dirnamlen='undef'
+d_dlerror='define'
+d_dlopen='define'
+d_dlsymun='undef'
+d_dosuid='undef'
+d_dup2='define'
+d_endgrent='define'
+d_endhent='define'
+d_endnent='define'
+d_endpent='define'
+d_endpwent='define'
+d_endsent='define'
+d_eofnblk='define'
+d_eunice='undef'
+d_fchmod='define'
+d_fchown='define'
+d_fcntl='define'
+d_fd_macros='define'
+d_fd_set='define'
+d_fds_bits='define'
+d_fgetpos='define'
+d_flexfnam='define'
+d_flock='define'
+d_fork='define'
+d_fpathconf='define'
+d_fsetpos='define'
+d_ftime='undef'
+d_getgrent='define'
+d_getgrps='define'
+d_gethbyaddr='define'
+d_gethbyname='define'
+d_gethent='define'
+d_gethname='undef'
+d_gethostprotos='define'
+d_getlogin='define'
+d_getnbyaddr='define'
+d_getnbyname='define'
+d_getnent='define'
+d_getnetprotos='define'
+d_getpbyname='define'
+d_getpbynumber='define'
+d_getpent='define'
+d_getpgid='define'
+d_getpgrp2='undef'
+d_getpgrp='define'
+d_getppid='define'
+d_getprior='define'
+d_getprotoprotos='define'
+d_getpwent='define'
+d_getsbyname='define'
+d_getsbyport='define'
+d_getsent='define'
+d_getservprotos='define'
+d_gettimeod='define'
+d_gnulibc='define'
+d_grpasswd='define'
+d_htonl='define'
+d_index='undef'
+d_inetaton='define'
+d_isascii='define'
+d_killpg='define'
+d_lchown='undef'
+d_link='define'
+d_locconv='define'
+d_lockf='define'
+d_longdbl='define'
+d_longlong='define'
+d_lstat='define'
+d_mblen='define'
+d_mbstowcs='define'
+d_mbtowc='define'
+d_memcmp='define'
+d_memcpy='define'
+d_memmove='define'
+d_memset='define'
+d_mkdir='define'
+d_mkfifo='define'
+d_mktime='define'
+d_msg='define'
+d_msgctl='define'
+d_msgget='define'
+d_msgrcv='define'
+d_msgsnd='define'
+d_mymalloc='undef'
+d_nice='define'
+d_oldpthreads='undef'
+d_oldsock='undef'
+d_open3='define'
+d_pathconf='define'
+d_pause='define'
+d_phostname='undef'
+d_pipe='define'
+d_poll='define'
+d_portable='define'
+d_pthread_yield='undef'
+d_pthreads_created_joinable='define'
+d_pwage='undef'
+d_pwchange='undef'
+d_pwclass='undef'
+d_pwcomment='undef'
+d_pwexpire='undef'
+d_pwgecos='define'
+d_pwquota='undef'
+d_pwpasswd='define'
+d_readdir='define'
+d_readlink='define'
+d_rename='define'
+d_rewinddir='define'
+d_rmdir='define'
+d_safebcpy='define'
+d_safemcpy='undef'
+d_sanemcmp='define'
+d_sched_yield='define'
+d_seekdir='define'
+d_select='define'
+d_sem='define'
+d_semctl='define'
+d_semctl_semid_ds='define'
+d_semctl_semun='define'
+d_semget='define'
+d_semop='define'
+d_setegid='define'
+d_seteuid='define'
+d_setgrent='define'
+d_setgrps='define'
+d_sethent='define'
+d_setlinebuf='define'
+d_setlocale='define'
+d_setnent='define'
+d_setpent='define'
+d_setpgid='define'
+d_setpgrp2='undef'
+d_setpgrp='define'
+d_setprior='define'
+d_setpwent='define'
+d_setregid='define'
+d_setresgid='undef'
+d_setresuid='undef'
+d_setreuid='define'
+d_setrgid='undef'
+d_setruid='undef'
+d_setsent='define'
+d_setsid='define'
+d_setvbuf='define'
+d_sfio='undef'
+d_shm='define'
+d_shmat='define'
+d_shmatprototype='define'
+d_shmctl='define'
+d_shmdt='define'
+d_shmget='define'
+d_sigaction='define'
+d_sigsetjmp='define'
+d_socket='define'
+d_sockpair='define'
+d_statblks='undef'
+d_stdio_cnt_lval='undef'
+d_stdio_ptr_lval='define'
+d_stdiobase='define'
+d_stdstdio='define'
+d_strchr='define'
+d_strcoll='define'
+d_strctcpy='define'
+d_strerrm='strerror(e)'
+d_strerror='define'
+d_strtod='define'
+d_strtol='define'
+d_strtoul='define'
+d_strxfrm='define'
+d_suidsafe='undef'
+d_symlink='define'
+d_syscall='define'
+d_sysconf='define'
+d_sysernlst=''
+d_syserrlst='define'
+d_system='define'
+d_tcgetpgrp='define'
+d_tcsetpgrp='define'
+d_telldir='define'
+d_time='define'
+d_times='define'
+d_truncate='define'
+d_tzname='define'
+d_umask='define'
+d_uname='define'
+d_union_semun='define'
+d_vfork='undef'
+d_void_closedir='undef'
+d_voidsig='define'
+d_voidtty=''
+d_volatile='define'
+d_vprintf='define'
+d_wait4='define'
+d_waitpid='define'
+d_wcstombs='define'
+d_wctomb='define'
+d_xenix='undef'
+date='date'
+db_hashtype='u_int32_t'
+db_prefixtype='size_t'
+defvoidused='15'
+direntrytype='struct dirent'
+dlext='so'
+dlsrc='dl_dlopen.xs'
+doublesize='8'
+dynamic_ext='B DB_File Data/Dumper Fcntl GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re'
+eagain='EAGAIN'
+ebcdic='undef'
+echo='echo'
+egrep='egrep'
+emacs=''
+eunicefix=':'
+exe_ext=''
+expr='expr'
+extensions='B DB_File Data/Dumper Fcntl GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re Errno'
+find='find'
+firstmakefile='makefile'
+flex=''
+fpostype='fpos_t'
+freetype='void'
+full_csh='/bin/csh'
+full_sed='/bin/sed'
+gccversion='2.7.2.3'
+gidtype='gid_t'
+glibpth='/usr/shlib /shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/local/lib '
+grep='grep'
+groupcat='cat /etc/group'
+groupstype='gid_t'
+gzip='gzip'
+h_fcntl='false'
+h_sysfile='true'
+hint='recommended'
+hostcat='cat /etc/hosts'
+huge=''
+i_arpainet='define'
+i_bsdioctl=''
+i_db='define'
+i_dbm='define'
+i_dirent='define'
+i_dld='undef'
+i_dlfcn='define'
+i_fcntl='undef'
+i_float='define'
+i_gdbm='define'
+i_grp='define'
+i_limits='define'
+i_locale='define'
+i_malloc='define'
+i_math='define'
+i_memory='undef'
+i_ndbm='define'
+i_netdb='define'
+i_neterrno='undef'
+i_niin='define'
+i_pwd='define'
+i_rpcsvcdbm='undef'
+i_sfio='undef'
+i_sgtty='undef'
+i_stdarg='define'
+i_stddef='define'
+i_stdlib='define'
+i_string='define'
+i_sysdir='define'
+i_sysfile='define'
+i_sysfilio='undef'
+i_sysin='undef'
+i_sysioctl='define'
+i_sysndir='undef'
+i_sysparam='define'
+i_sysresrc='define'
+i_sysselct='define'
+i_syssockio=''
+i_sysstat='define'
+i_systime='define'
+i_systimek='undef'
+i_systimes='define'
+i_systypes='define'
+i_sysun='define'
+i_syswait='define'
+i_termio='undef'
+i_termios='define'
+i_time='undef'
+i_unistd='define'
+i_utime='define'
+i_values='define'
+i_varargs='undef'
+i_varhdr='stdarg.h'
+i_vfork='undef'
+incpath=''
+inews=''
+installarchlib='/opt/perl/lib/5.005/i686-linux-thread'
+installbin='/opt/perl/bin'
+installman1dir='/opt/perl/man/man1'
+installman3dir='/opt/perl/man/man3'
+installprivlib='/opt/perl/lib/5.005'
+installscript='/opt/perl/script'
+installsitearch='/opt/perl/lib/site_perl/5.005/i686-linux-thread'
+installsitelib='/opt/perl/lib/site_perl/5.005'
+intsize='4'
+known_extensions='B DB_File Data/Dumper Fcntl GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Thread attrs re'
+ksh=''
+large=''
+ld='cc'
+lddlflags='-shared -L/usr/local/lib'
+ldflags=' -L/usr/local/lib'
+less='less'
+lib_ext='.a'
+libc=''
+libperl='libperl.a'
+libpth='/usr/local/lib /lib /usr/lib'
+libs='-lnsl -lndbm -lgdbm -ldbm -ldb -ldl -lm -lpthread -lc -lposix -lcrypt'
+libswanted='sfio socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m pthread c cposix posix ndir dir crypt ucb BSD PW x'
+line='line'
+lint=''
+lkflags=''
+ln='ln'
+lns='/bin/ln -s'
+locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include'
+loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib'
+longdblsize='12'
+longlongsize='8'
+longsize='4'
+lp=''
+lpr=''
+ls='ls'
+lseektype='off_t'
+mail=''
+mailx=''
+make='make'
+make_set_make='#'
+mallocobj=''
+mallocsrc=''
+malloctype='void *'
+man1dir='/opt/perl/man/man1'
+man1direxp='/opt/perl/man/man1'
+man1ext='1'
+man3dir='/opt/perl/man/man3'
+man3direxp='/opt/perl/man/man3'
+man3ext='3'
+medium=''
+mips=''
+mips_type=''
+mkdir='mkdir'
+models='none'
+modetype='mode_t'
+more='more'
+mv=''
+myarchname='i686-linux'
+mydomain='.yourplace.com'
+myhostname='yourhost'
+myuname='linux fractal 2.0.34 #1 tue jun 23 10:09:17 edt 1998 i686 unknown '
+n='-n'
+netdb_hlen_type='int'
+netdb_host_type='const char *'
+netdb_name_type='const char *'
+netdb_net_type='unsigned long'
+nm='nm'
+nm_opt=''
+nm_so_opt='--dynamic'
+nonxs_ext='Errno'
+nroff='nroff'
+o_nonblock='O_NONBLOCK'
+obj_ext='.o'
+optimize='-O'
+orderlib='false'
+osname='linux'
+osvers='2.0.34'
+package='perl5'
+pager='/usr/bin/less'
+passcat='cat /etc/passwd'
+patchlevel='5'
+path_sep=':'
+perl='perl'
+perladmin='yourname@yourhost.yourplace.com'
+perlpath='/opt/perl/bin/perl'
+pg='pg'
+phostname=''
+pidtype='pid_t'
+plibpth=''
+pmake=''
+pr=''
+prefix='/opt/perl'
+prefixexp='/opt/perl'
+privlib='/opt/perl/lib/5.005'
+privlibexp='/opt/perl/lib/5.005'
+prototype='define'
+ptrsize='4'
+randbits='31'
+ranlib=':'
+rd_nodata='-1'
+rm='rm'
+rmail=''
+runnm='false'
+scriptdir='/opt/perl/script'
+scriptdirexp='/opt/perl/script'
+sed='sed'
+selecttype='fd_set *'
+sendmail='sendmail'
+sh='/bin/sh'
+shar=''
+sharpbang='#!'
+shmattype='void *'
+shortsize='2'
+shrpenv=''
+shsharp='true'
+sig_name='ZERO HUP INT QUIT ILL TRAP ABRT BUS FPE KILL USR1 SEGV USR2 PIPE ALRM TERM STKFLT CHLD CONT STOP TSTP TTIN TTOU URG XCPU XFSZ VTALRM PROF WINCH IO PWR UNUSED IOT CLD POLL '
+sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "BUS", "FPE", "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "STKFLT", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "URG", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "IO", "PWR", "UNUSED", "IOT", "CLD", "POLL", 0'
+sig_num='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 6, 17, 29, 0'
+signal_t='void'
+sitearch='/opt/perl/lib/site_perl/5.005/i686-linux-thread'
+sitearchexp='/opt/perl/lib/site_perl/5.005/i686-linux-thread'
+sitelib='/opt/perl/lib/site_perl/5.005'
+sitelibexp='/opt/perl/lib/site_perl/5.005'
+sizetype='size_t'
+sleep=''
+smail=''
+small=''
+so='so'
+sockethdr=''
+socketlib=''
+sort='sort'
+spackage='Perl5'
+spitshell='cat'
+split=''
+src='.'
+ssizetype='ssize_t'
+startperl='#!/opt/perl/bin/perl'
+startsh='#!/bin/sh'
+static_ext=' '
+stdchar='char'
+stdio_base='((fp)->_IO_read_base)'
+stdio_bufsiz='((fp)->_IO_read_end - (fp)->_IO_read_base)'
+stdio_cnt='((fp)->_IO_read_end - (fp)->_IO_read_ptr)'
+stdio_filbuf=''
+stdio_ptr='((fp)->_IO_read_ptr)'
+strings='/usr/include/string.h'
+submit=''
+subversion='0'
+sysman='/usr/man/man1'
+tail=''
+tar=''
+tbl=''
+tee='tee'
+test='test'
+timeincl='/usr/include/sys/time.h '
+timetype='time_t'
+touch='touch'
+tr='tr'
+trnl='\n'
+troff=''
+uidtype='uid_t'
+uname='uname'
+uniq='uniq'
+usedl='define'
+usemymalloc='n'
+usenm='false'
+useopcode='true'
+useperlio='undef'
+useposix='true'
+usesfio='false'
+useshrplib='false'
+usethreads='define'
+usevfork='false'
+usrinc='/usr/include'
+uuname=''
+version='5.005'
+vi=''
+voidflags='15'
+xlibpth='/usr/lib/386 /lib/386'
+zcat=''
+zip='zip'
+# Configure command line arguments.
+config_arg0='Configure'
+config_args='-Dprefix=/opt/perl -Doptimize=-O -Dusethreads -Dcf_by=yourname -Dcf_email=yourname@yourhost.yourplace.com -Dperladmin=yourname@yourhost.yourplace.com -Dmydomain=.yourplace.com -Dmyhostname=yourhost -dE'
+config_argc=9
+config_arg1='-Dprefix=/opt/perl'
+config_arg2='-Doptimize=-O'
+config_arg3='-Dusethreads'
+config_arg4='-Dcf_by=yourname'
+config_arg5='-Dcf_email=yourname@yourhost.yourplace.com'
+config_arg6='-Dperladmin=yourname@yourhost.yourplace.com'
+config_arg7='-Dmydomain=.yourplace.com'
+config_arg8='-Dmyhostname=yourhost'
+config_arg9='-dE'
+PATCHLEVEL=5
+SUBVERSION=0
+CONFIG=true
diff --git a/contrib/perl5/Porting/config_H b/contrib/perl5/Porting/config_H
new file mode 100644
index 000000000000..8cbf3c497b98
--- /dev/null
+++ b/contrib/perl5/Porting/config_H
@@ -0,0 +1,2103 @@
+/* This file (config_H) is a sample config.h file. If you are unable
+ to successfully run Configure, copy this file to config.h and
+ edit it to suit your system.
+*/
+/*
+ * This file was produced by running the config_h.SH script, which
+ * gets its values from config.sh, which is generally produced by
+ * running Configure.
+ *
+ * Feel free to modify any of this as the need arises. Note, however,
+ * that running config_h.SH again will wipe out any changes you've made.
+ * For a more permanent change edit config.sh and rerun config_h.SH.
+ *
+ * $Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $
+ */
+
+/*
+ * Package name : perl5
+ * Source directory : .
+ * Configuration time: Tue Jul 21 10:03:27 EDT 1998
+ * Configured by : doughera
+ * Target system : linux fractal 2.0.34 #1 tue jun 23 10:09:17 edt 1998 i686 unknown
+ */
+
+#ifndef _config_h_
+#define _config_h_
+
+/* LOC_SED:
+ * This symbol holds the complete pathname to the sed program.
+ */
+#define LOC_SED "/bin/sed" /**/
+
+/* BIN:
+ * This symbol holds the path of the bin directory where the package will
+ * be installed. Program must be prepared to deal with ~name substitution.
+ */
+/* BIN_EXP:
+ * This symbol is the filename expanded version of the BIN symbol, for
+ * programs that do not want to deal with that at run-time.
+ */
+#define BIN "/opt/perl/bin" /**/
+#define BIN_EXP "/opt/perl/bin" /**/
+
+/* CPPSTDIN:
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp", but it can also
+ * call a wrapper. See CPPRUN.
+ */
+/* CPPMINUS:
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+#define CPPSTDIN "cc -E"
+#define CPPMINUS "-"
+
+/* HAS_ALARM:
+ * This symbol, if defined, indicates that the alarm routine is
+ * available.
+ */
+#define HAS_ALARM /**/
+
+/* HASATTRIBUTE:
+ * This symbol indicates the C compiler can check for function attributes,
+ * such as printf formats. This is normally only supported by GNU cc.
+ */
+#define HASATTRIBUTE /**/
+#ifndef HASATTRIBUTE
+#define __attribute__(_arg_)
+#endif
+
+/* HAS_BCMP:
+ * This symbol is defined if the bcmp() routine is available to
+ * compare blocks of memory.
+ */
+#define HAS_BCMP /**/
+
+/* HAS_BCOPY:
+ * This symbol is defined if the bcopy() routine is available to
+ * copy blocks of memory.
+ */
+#define HAS_BCOPY /**/
+
+/* HAS_BZERO:
+ * This symbol is defined if the bzero() routine is available to
+ * set a memory block to 0.
+ */
+#define HAS_BZERO /**/
+
+/* HAS_CHOWN:
+ * This symbol, if defined, indicates that the chown routine is
+ * available.
+ */
+#define HAS_CHOWN /**/
+
+/* HAS_CHROOT:
+ * This symbol, if defined, indicates that the chroot routine is
+ * available.
+ */
+#define HAS_CHROOT /**/
+
+/* HAS_CHSIZE:
+ * This symbol, if defined, indicates that the chsize routine is available
+ * to truncate files. You might need a -lx to get this routine.
+ */
+/*#define HAS_CHSIZE / **/
+
+/* HASCONST:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the const type. There is no need to actually test for that symbol
+ * within your programs. The mere use of the "const" keyword will
+ * trigger the necessary tests.
+ */
+#define HASCONST /**/
+#ifndef HASCONST
+#define const
+#endif
+
+/* HAS_CRYPT:
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+#define HAS_CRYPT /**/
+
+/* HAS_CUSERID:
+ * This symbol, if defined, indicates that the cuserid routine is
+ * available to get character login names.
+ */
+#define HAS_CUSERID /**/
+
+/* HAS_DBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol DBL_DIG, which is the number
+ * of significant digits in a double precision number. If this
+ * symbol is not defined, a guess of 15 is usually pretty good.
+ */
+#define HAS_DBL_DIG /* */
+
+/* HAS_DIFFTIME:
+ * This symbol, if defined, indicates that the difftime routine is
+ * available.
+ */
+#define HAS_DIFFTIME /**/
+
+/* HAS_DLERROR:
+ * This symbol, if defined, indicates that the dlerror routine is
+ * available to return a string describing the last error that
+ * occurred from a call to dlopen(), dlclose() or dlsym().
+ */
+#define HAS_DLERROR /**/
+
+/* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+/* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+/*#define SETUID_SCRIPTS_ARE_SECURE_NOW / **/
+/*#define DOSUID / **/
+
+/* HAS_DUP2:
+ * This symbol, if defined, indicates that the dup2 routine is
+ * available to duplicate file descriptors.
+ */
+#define HAS_DUP2 /**/
+
+/* HAS_FCHMOD:
+ * This symbol, if defined, indicates that the fchmod routine is available
+ * to change mode of opened files. If unavailable, use chmod().
+ */
+#define HAS_FCHMOD /**/
+
+/* HAS_FCHOWN:
+ * This symbol, if defined, indicates that the fchown routine is available
+ * to change ownership of opened files. If unavailable, use chown().
+ */
+#define HAS_FCHOWN /**/
+
+/* HAS_FCNTL:
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
+ */
+#define HAS_FCNTL /**/
+
+/* HAS_FGETPOS:
+ * This symbol, if defined, indicates that the fgetpos routine is
+ * available to get the file position indicator, similar to ftell().
+ */
+#define HAS_FGETPOS /**/
+
+/* FLEXFILENAMES:
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+#define FLEXFILENAMES /**/
+
+/* HAS_FLOCK:
+ * This symbol, if defined, indicates that the flock routine is
+ * available to do file locking.
+ */
+#define HAS_FLOCK /**/
+
+/* HAS_FORK:
+ * This symbol, if defined, indicates that the fork routine is
+ * available.
+ */
+#define HAS_FORK /**/
+
+/* HAS_FSETPOS:
+ * This symbol, if defined, indicates that the fsetpos routine is
+ * available to set the file position indicator, similar to fseek().
+ */
+#define HAS_FSETPOS /**/
+
+/* HAS_GETTIMEOFDAY:
+ * This symbol, if defined, indicates that the gettimeofday() system
+ * call is available for a sub-second accuracy clock. Usually, the file
+ * <sys/resource.h> needs to be included (see I_SYS_RESOURCE).
+ * The type "Timeval" should be used to refer to "struct timeval".
+ */
+#define HAS_GETTIMEOFDAY /**/
+#ifdef HAS_GETTIMEOFDAY
+#define Timeval struct timeval /* Structure used by gettimeofday() */
+#endif
+
+/* HAS_GETGROUPS:
+ * This symbol, if defined, indicates that the getgroups() routine is
+ * available to get the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+#define HAS_GETGROUPS /**/
+
+/* HAS_UNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * uname() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and PHOSTNAME.
+ */
+#define HAS_UNAME /**/
+
+/* HAS_GETLOGIN:
+ * This symbol, if defined, indicates that the getlogin routine is
+ * available to get the login name.
+ */
+#define HAS_GETLOGIN /**/
+
+/* HAS_GETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the getpgid(pid) function is available to get the
+ * process group id.
+ */
+#define HAS_GETPGID /**/
+
+/* HAS_GETPGRP:
+ * This symbol, if defined, indicates that the getpgrp routine is
+ * available to get the current process group.
+ */
+/* USE_BSD_GETPGRP:
+ * This symbol, if defined, indicates that getpgrp needs one
+ * arguments whereas USG one needs none.
+ */
+#define HAS_GETPGRP /**/
+/*#define USE_BSD_GETPGRP / **/
+
+/* HAS_GETPGRP2:
+ * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
+ * routine is available to get the current process group.
+ */
+/*#define HAS_GETPGRP2 / **/
+
+/* HAS_GETPPID:
+ * This symbol, if defined, indicates that the getppid routine is
+ * available to get the parent process ID.
+ */
+#define HAS_GETPPID /**/
+
+/* HAS_GETPRIORITY:
+ * This symbol, if defined, indicates that the getpriority routine is
+ * available to get a process's priority.
+ */
+#define HAS_GETPRIORITY /**/
+
+/* HAS_HTONL:
+ * This symbol, if defined, indicates that the htonl() routine (and
+ * friends htons() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_HTONS:
+ * This symbol, if defined, indicates that the htons() routine (and
+ * friends htonl() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHL:
+ * This symbol, if defined, indicates that the ntohl() routine (and
+ * friends htonl() htons() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHS:
+ * This symbol, if defined, indicates that the ntohs() routine (and
+ * friends htonl() htons() ntohl()) are available to do network
+ * order byte swapping.
+ */
+#define HAS_HTONL /**/
+#define HAS_HTONS /**/
+#define HAS_NTOHL /**/
+#define HAS_NTOHS /**/
+
+/* HAS_INET_ATON:
+ * This symbol, if defined, indicates to the C program that the
+ * inet_aton() function is available to parse IP address "dotted-quad"
+ * strings.
+ */
+#define HAS_INET_ATON /**/
+
+/* HAS_KILLPG:
+ * This symbol, if defined, indicates that the killpg routine is available
+ * to kill process groups. If unavailable, you probably should use kill
+ * with a negative process number.
+ */
+#define HAS_KILLPG /**/
+
+/* HAS_LINK:
+ * This symbol, if defined, indicates that the link routine is
+ * available to create hard links.
+ */
+#define HAS_LINK /**/
+
+/* HAS_LOCALECONV:
+ * This symbol, if defined, indicates that the localeconv routine is
+ * available for numeric and monetary formatting conventions.
+ */
+#define HAS_LOCALECONV /**/
+
+/* HAS_LOCKF:
+ * This symbol, if defined, indicates that the lockf routine is
+ * available to do file locking.
+ */
+#define HAS_LOCKF /**/
+
+/* HAS_LSTAT:
+ * This symbol, if defined, indicates that the lstat routine is
+ * available to do file stats on symbolic links.
+ */
+#define HAS_LSTAT /**/
+
+/* HAS_MBLEN:
+ * This symbol, if defined, indicates that the mblen routine is available
+ * to find the number of bytes in a multibye character.
+ */
+#define HAS_MBLEN /**/
+
+/* HAS_MBSTOWCS:
+ * This symbol, if defined, indicates that the mbstowcs routine is
+ * available to covert a multibyte string into a wide character string.
+ */
+#define HAS_MBSTOWCS /**/
+
+/* HAS_MBTOWC:
+ * This symbol, if defined, indicates that the mbtowc routine is available
+ * to covert a multibyte to a wide character.
+ */
+#define HAS_MBTOWC /**/
+
+/* HAS_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * to compare blocks of memory.
+ */
+#define HAS_MEMCMP /**/
+
+/* HAS_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy blocks of memory.
+ */
+#define HAS_MEMCPY /**/
+
+/* HAS_MEMMOVE:
+ * This symbol, if defined, indicates that the memmove routine is available
+ * to copy potentially overlapping blocks of memory. This should be used
+ * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your
+ * own version.
+ */
+#define HAS_MEMMOVE /**/
+
+/* HAS_MEMSET:
+ * This symbol, if defined, indicates that the memset routine is available
+ * to set blocks of memory.
+ */
+#define HAS_MEMSET /**/
+
+/* HAS_MKDIR:
+ * This symbol, if defined, indicates that the mkdir routine is available
+ * to create directories. Otherwise you should fork off a new process to
+ * exec /bin/mkdir.
+ */
+#define HAS_MKDIR /**/
+
+/* HAS_MKFIFO:
+ * This symbol, if defined, indicates that the mkfifo routine is
+ * available to create FIFOs. Otherwise, mknod should be able to
+ * do it for you. However, if mkfifo is there, mknod might require
+ * super-user privileges which mkfifo will not.
+ */
+#define HAS_MKFIFO /**/
+
+/* HAS_MKTIME:
+ * This symbol, if defined, indicates that the mktime routine is
+ * available.
+ */
+#define HAS_MKTIME /**/
+
+/* HAS_MSG:
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported (IPC mechanism based on message queues).
+ */
+#define HAS_MSG /**/
+
+/* HAS_NICE:
+ * This symbol, if defined, indicates that the nice routine is
+ * available.
+ */
+#define HAS_NICE /**/
+
+/* HAS_PATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given filename.
+ */
+/* HAS_FPATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given open file descriptor.
+ */
+#define HAS_PATHCONF /**/
+#define HAS_FPATHCONF /**/
+
+/* HAS_PAUSE:
+ * This symbol, if defined, indicates that the pause routine is
+ * available to suspend a process until a signal is received.
+ */
+#define HAS_PAUSE /**/
+
+/* HAS_PIPE:
+ * This symbol, if defined, indicates that the pipe routine is
+ * available to create an inter-process channel.
+ */
+#define HAS_PIPE /**/
+
+/* HAS_POLL:
+ * This symbol, if defined, indicates that the poll routine is
+ * available to poll active file descriptors. You may safely
+ * include <poll.h> when this symbol is defined.
+ */
+#define HAS_POLL /**/
+
+/* HAS_READDIR:
+ * This symbol, if defined, indicates that the readdir routine is
+ * available to read directory entries. You may have to include
+ * <dirent.h>. See I_DIRENT.
+ */
+#define HAS_READDIR /**/
+
+/* HAS_SEEKDIR:
+ * This symbol, if defined, indicates that the seekdir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+#define HAS_SEEKDIR /**/
+
+/* HAS_TELLDIR:
+ * This symbol, if defined, indicates that the telldir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+#define HAS_TELLDIR /**/
+
+/* HAS_REWINDDIR:
+ * This symbol, if defined, indicates that the rewinddir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+#define HAS_REWINDDIR /**/
+
+/* HAS_READLINK:
+ * This symbol, if defined, indicates that the readlink routine is
+ * available to read the value of a symbolic link.
+ */
+#define HAS_READLINK /**/
+
+/* HAS_RENAME:
+ * This symbol, if defined, indicates that the rename routine is available
+ * to rename files. Otherwise you should do the unlink(), link(), unlink()
+ * trick.
+ */
+#define HAS_RENAME /**/
+
+/* HAS_RMDIR:
+ * This symbol, if defined, indicates that the rmdir routine is
+ * available to remove directories. Otherwise you should fork off a
+ * new process to exec /bin/rmdir.
+ */
+#define HAS_RMDIR /**/
+
+/* HAS_SELECT:
+ * This symbol, if defined, indicates that the select routine is
+ * available to select active file descriptors. If the timeout field
+ * is used, <sys/time.h> may need to be included.
+ */
+#define HAS_SELECT /**/
+
+/* HAS_SEM:
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+#define HAS_SEM /**/
+
+/* HAS_SETEGID:
+ * This symbol, if defined, indicates that the setegid routine is available
+ * to change the effective gid of the current program.
+ */
+#define HAS_SETEGID /**/
+
+/* HAS_SETEUID:
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+#define HAS_SETEUID /**/
+
+/* HAS_SETLINEBUF:
+ * This symbol, if defined, indicates that the setlinebuf routine is
+ * available to change stderr or stdout from block-buffered or unbuffered
+ * to a line-buffered mode.
+ */
+#define HAS_SETLINEBUF /**/
+
+/* HAS_SETLOCALE:
+ * This symbol, if defined, indicates that the setlocale routine is
+ * available to handle locale-specific ctype implementations.
+ */
+#define HAS_SETLOCALE /**/
+
+/* HAS_SETPGID:
+ * This symbol, if defined, indicates that the setpgid(pid, gpid)
+ * routine is available to set process group ID.
+ */
+#define HAS_SETPGID /**/
+
+/* HAS_SETPGRP:
+ * This symbol, if defined, indicates that the setpgrp routine is
+ * available to set the current process group.
+ */
+/* USE_BSD_SETPGRP:
+ * This symbol, if defined, indicates that setpgrp needs two
+ * arguments whereas USG one needs none. See also HAS_SETPGID
+ * for a POSIX interface.
+ */
+#define HAS_SETPGRP /**/
+/*#define USE_BSD_SETPGRP / **/
+
+/* HAS_SETPGRP2:
+ * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
+ * routine is available to set the current process group.
+ */
+/*#define HAS_SETPGRP2 / **/
+
+/* HAS_SETPRIORITY:
+ * This symbol, if defined, indicates that the setpriority routine is
+ * available to set a process's priority.
+ */
+#define HAS_SETPRIORITY /**/
+
+/* HAS_SETREGID:
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current
+ * process.
+ */
+/* HAS_SETRESGID:
+ * This symbol, if defined, indicates that the setresgid routine is
+ * available to change the real, effective and saved gid of the current
+ * process.
+ */
+#define HAS_SETREGID /**/
+/*#define HAS_SETRESGID / **/
+
+/* HAS_SETREUID:
+ * This symbol, if defined, indicates that the setreuid routine is
+ * available to change the real and effective uid of the current
+ * process.
+ */
+/* HAS_SETRESUID:
+ * This symbol, if defined, indicates that the setresuid routine is
+ * available to change the real, effective and saved uid of the current
+ * process.
+ */
+#define HAS_SETREUID /**/
+/*#define HAS_SETRESUID / **/
+
+/* HAS_SETRGID:
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+/*#define HAS_SETRGID / **/
+
+/* HAS_SETRUID:
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+/*#define HAS_SETRUID / **/
+
+/* HAS_SETSID:
+ * This symbol, if defined, indicates that the setsid routine is
+ * available to set the process group ID.
+ */
+#define HAS_SETSID /**/
+
+/* HAS_SHM:
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+#define HAS_SHM /**/
+
+/* Shmat_t:
+ * This symbol holds the return type of the shmat() system call.
+ * Usually set to 'void *' or 'char *'.
+ */
+/* HAS_SHMAT_PROTOTYPE:
+ * This symbol, if defined, indicates that the sys/shm.h includes
+ * a prototype for shmat(). Otherwise, it is up to the program to
+ * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess,
+ * but not always right so it should be emitted by the program only
+ * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs.
+ */
+#define Shmat_t void * /**/
+#define HAS_SHMAT_PROTOTYPE /**/
+
+/* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+/*#define USE_STAT_BLOCKS / **/
+
+/* HAS_STRCHR:
+ * This symbol is defined to indicate that the strchr()/strrchr()
+ * functions are available for string searching. If not, try the
+ * index()/rindex() pair.
+ */
+/* HAS_INDEX:
+ * This symbol is defined to indicate that the index()/rindex()
+ * functions are available for string searching.
+ */
+#define HAS_STRCHR /**/
+/*#define HAS_INDEX / **/
+
+/* HAS_STRCOLL:
+ * This symbol, if defined, indicates that the strcoll routine is
+ * available to compare strings using collating information.
+ */
+#define HAS_STRCOLL /**/
+
+/* USE_STRUCT_COPY:
+ * This symbol, if defined, indicates that this C compiler knows how
+ * to copy structures. If undefined, you'll need to use a block copy
+ * routine of some sort instead.
+ */
+#define USE_STRUCT_COPY /**/
+
+/* HAS_STRERROR:
+ * This symbol, if defined, indicates that the strerror routine is
+ * available to translate error numbers to strings. See the writeup
+ * of Strerror() in this file before you try to define your own.
+ */
+/* HAS_SYS_ERRLIST:
+ * This symbol, if defined, indicates that the sys_errlist array is
+ * available to translate error numbers to strings. The extern int
+ * sys_nerr gives the size of that table.
+ */
+/* Strerror:
+ * This preprocessor symbol is defined as a macro if strerror() is
+ * not available to translate error numbers to strings but sys_errlist[]
+ * array is there.
+ */
+#define HAS_STRERROR /**/
+#define HAS_SYS_ERRLIST /**/
+#define Strerror(e) strerror(e)
+
+/* HAS_STRTOD:
+ * This symbol, if defined, indicates that the strtod routine is
+ * available to provide better numeric string conversion than atof().
+ */
+#define HAS_STRTOD /**/
+
+/* HAS_STRTOL:
+ * This symbol, if defined, indicates that the strtol routine is available
+ * to provide better numeric string conversion than atoi() and friends.
+ */
+#define HAS_STRTOL /**/
+
+/* HAS_STRTOUL:
+ * This symbol, if defined, indicates that the strtoul routine is
+ * available to provide conversion of strings to unsigned long.
+ */
+#define HAS_STRTOUL /**/
+
+/* HAS_STRXFRM:
+ * This symbol, if defined, indicates that the strxfrm() routine is
+ * available to transform strings.
+ */
+#define HAS_STRXFRM /**/
+
+/* HAS_SYMLINK:
+ * This symbol, if defined, indicates that the symlink routine is available
+ * to create symbolic links.
+ */
+#define HAS_SYMLINK /**/
+
+/* HAS_SYSCALL:
+ * This symbol, if defined, indicates that the syscall routine is
+ * available to call arbitrary system calls. If undefined, that's tough.
+ */
+#define HAS_SYSCALL /**/
+
+/* HAS_SYSCONF:
+ * This symbol, if defined, indicates that sysconf() is available
+ * to determine system related limits and options.
+ */
+#define HAS_SYSCONF /**/
+
+/* HAS_SYSTEM:
+ * This symbol, if defined, indicates that the system routine is
+ * available to issue a shell command.
+ */
+#define HAS_SYSTEM /**/
+
+/* HAS_TCGETPGRP:
+ * This symbol, if defined, indicates that the tcgetpgrp routine is
+ * available to get foreground process group ID.
+ */
+#define HAS_TCGETPGRP /**/
+
+/* HAS_TCSETPGRP:
+ * This symbol, if defined, indicates that the tcsetpgrp routine is
+ * available to set foreground process group ID.
+ */
+#define HAS_TCSETPGRP /**/
+
+/* HAS_TRUNCATE:
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
+ */
+#define HAS_TRUNCATE /**/
+
+/* HAS_TZNAME:
+ * This symbol, if defined, indicates that the tzname[] array is
+ * available to access timezone names.
+ */
+#define HAS_TZNAME /**/
+
+/* HAS_UMASK:
+ * This symbol, if defined, indicates that the umask routine is
+ * available to set and get the value of the file creation mask.
+ */
+#define HAS_UMASK /**/
+
+/* HAS_VFORK:
+ * This symbol, if defined, indicates that vfork() exists.
+ */
+/*#define HAS_VFORK / **/
+
+/* HASVOLATILE:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+#define HASVOLATILE /**/
+#ifndef HASVOLATILE
+#define volatile
+#endif
+
+/* HAS_WAIT4:
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+#define HAS_WAIT4 /**/
+
+/* HAS_WAITPID:
+ * This symbol, if defined, indicates that the waitpid routine is
+ * available to wait for child process.
+ */
+#define HAS_WAITPID /**/
+
+/* HAS_WCSTOMBS:
+ * This symbol, if defined, indicates that the wcstombs routine is
+ * available to convert wide character strings to multibyte strings.
+ */
+#define HAS_WCSTOMBS /**/
+
+/* HAS_WCTOMB:
+ * This symbol, if defined, indicates that the wctomb routine is available
+ * to covert a wide character to a multibyte.
+ */
+#define HAS_WCTOMB /**/
+
+/* EBCDIC:
+ * This symbol, if defined, indicates that this system uses
+ * EBCDIC encoding.
+ */
+/*#define EBCDIC / **/
+
+/* I_ARPA_INET:
+ * This symbol, if defined, indicates that <arpa/inet.h> exists and should
+ * be included.
+ */
+#define I_ARPA_INET /**/
+
+/* I_DBM:
+ * This symbol, if defined, indicates that <dbm.h> exists and should
+ * be included.
+ */
+/* I_RPCSVC_DBM:
+ * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and
+ * should be included.
+ */
+#define I_DBM /**/
+/*#define I_RPCSVC_DBM / **/
+
+/* I_DIRENT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <dirent.h>. Using this symbol also triggers the definition
+ * of the Direntry_t define which ends up being 'struct dirent' or
+ * 'struct direct' depending on the availability of <dirent.h>.
+ */
+/* DIRNAMLEN:
+ * This symbol, if defined, indicates to the C program that the length
+ * of directory entry names is provided by a d_namlen field. Otherwise
+ * you need to do strlen() on the d_name field.
+ */
+/* Direntry_t:
+ * This symbol is set to 'struct direct' or 'struct dirent' depending on
+ * whether dirent is available or not. You should use this pseudo type to
+ * portably declare your directory entries.
+ */
+#define I_DIRENT /**/
+/*#define DIRNAMLEN / **/
+#define Direntry_t struct dirent
+
+/* I_DLFCN:
+ * This symbol, if defined, indicates that <dlfcn.h> exists and should
+ * be included.
+ */
+#define I_DLFCN /**/
+
+/* I_FCNTL:
+ * This manifest constant tells the C program to include <fcntl.h>.
+ */
+/*#define I_FCNTL / **/
+
+/* I_FLOAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <float.h> to get definition of symbols like DBL_MAX or
+ * DBL_MIN, i.e. machine dependent floating point values.
+ */
+#define I_FLOAT /**/
+
+/* I_GRP:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <grp.h>.
+ */
+/* GRPASSWD:
+ * This symbol, if defined, indicates to the C program that struct group
+ * contains gr_passwd.
+ */
+/* HAS_SETGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for initializing sequential access of the group database.
+ */
+/* HAS_GETGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for sequential access of the group database.
+ */
+/* HAS_ENDGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the group database.
+ */
+#define I_GRP /**/
+#define GRPASSWD /**/
+#define HAS_SETGRENT /**/
+#define HAS_GETGRENT /**/
+#define HAS_ENDGRENT /**/
+
+/* I_LIMITS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <limits.h> to get definition of symbols like WORD_BIT or
+ * LONG_MAX, i.e. machine dependant limitations.
+ */
+#define I_LIMITS /**/
+
+/* I_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+#define I_LOCALE /**/
+
+/* I_MATH:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <math.h>.
+ */
+#define I_MATH /**/
+
+/* I_MEMORY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <memory.h>.
+ */
+/*#define I_MEMORY / **/
+
+/* I_NDBM:
+ * This symbol, if defined, indicates that <ndbm.h> exists and should
+ * be included.
+ */
+#define I_NDBM /**/
+
+/* I_NET_ERRNO:
+ * This symbol, if defined, indicates that <net/errno.h> exists and
+ * should be included.
+ */
+/*#define I_NET_ERRNO / **/
+
+/* I_NETINET_IN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <netinet/in.h>. Otherwise, you may try <sys/in.h>.
+ */
+#define I_NETINET_IN /**/
+
+/* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+/*#define I_SFIO / **/
+
+/* I_STDDEF:
+ * This symbol, if defined, indicates that <stddef.h> exists and should
+ * be included.
+ */
+#define I_STDDEF /**/
+
+/* I_STDLIB:
+ * This symbol, if defined, indicates that <stdlib.h> exists and should
+ * be included.
+ */
+#define I_STDLIB /**/
+
+/* I_STRING:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <string.h> (USG systems) instead of <strings.h> (BSD systems).
+ */
+#define I_STRING /**/
+
+/* I_SYS_DIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/dir.h>.
+ */
+#define I_SYS_DIR /**/
+
+/* I_SYS_FILE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/file.h> to get definition of R_OK and friends.
+ */
+#define I_SYS_FILE /**/
+
+/* I_SYS_IOCTL:
+ * This symbol, if defined, indicates that <sys/ioctl.h> exists and should
+ * be included. Otherwise, include <sgtty.h> or <termio.h>.
+ */
+#define I_SYS_IOCTL /**/
+
+/* I_SYS_NDIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/ndir.h>.
+ */
+/*#define I_SYS_NDIR / **/
+
+/* I_SYS_PARAM:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/param.h>.
+ */
+#define I_SYS_PARAM /**/
+
+/* I_SYS_RESOURCE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/resource.h>.
+ */
+#define I_SYS_RESOURCE /**/
+
+/* I_SYS_SELECT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/select.h> in order to get definition of struct timeval.
+ */
+#define I_SYS_SELECT /**/
+
+/* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+#define I_SYS_STAT /**/
+
+/* I_SYS_TIMES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/times.h>.
+ */
+#define I_SYS_TIMES /**/
+
+/* I_SYS_TYPES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/types.h>.
+ */
+#define I_SYS_TYPES /**/
+
+/* I_SYS_UN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/un.h> to get UNIX domain socket definitions.
+ */
+#define I_SYS_UN /**/
+
+/* I_SYS_WAIT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/wait.h>.
+ */
+#define I_SYS_WAIT /**/
+
+/* I_TERMIO:
+ * This symbol, if defined, indicates that the program should include
+ * <termio.h> rather than <sgtty.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+/* I_TERMIOS:
+ * This symbol, if defined, indicates that the program should include
+ * the POSIX termios.h rather than sgtty.h or termio.h.
+ * There are also differences in the ioctl() calls that depend on the
+ * value of this symbol.
+ */
+/* I_SGTTY:
+ * This symbol, if defined, indicates that the program should include
+ * <sgtty.h> rather than <termio.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+/*#define I_TERMIO / **/
+#define I_TERMIOS /**/
+/*#define I_SGTTY / **/
+
+/* I_UNISTD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <unistd.h>.
+ */
+#define I_UNISTD /**/
+
+/* I_UTIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <utime.h>.
+ */
+#define I_UTIME /**/
+
+/* I_VALUES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <values.h> to get definition of symbols like MINFLOAT or
+ * MAXLONG, i.e. machine dependant limitations. Probably, you
+ * should use <limits.h> instead, if it is available.
+ */
+#define I_VALUES /**/
+
+/* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+/* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+#define I_STDARG /**/
+/*#define I_VARARGS / **/
+
+/* I_VFORK:
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+/*#define I_VFORK / **/
+
+/* CAN_PROTOTYPE:
+ * If defined, this macro indicates that the C compiler can handle
+ * function prototypes.
+ */
+/* _:
+ * This macro is used to declare function parameters for folks who want
+ * to make declarations with prototypes using a different style than
+ * the above macros. Use double parentheses. For example:
+ *
+ * int main _((int argc, char *argv[]));
+ */
+#define CAN_PROTOTYPE /**/
+#ifdef CAN_PROTOTYPE
+#define _(args) args
+#else
+#define _(args) ()
+#endif
+
+/* SH_PATH:
+ * This symbol contains the full pathname to the shell used on this
+ * on this system to execute Bourne shell scripts. Usually, this will be
+ * /bin/sh, though it's possible that some systems will have /bin/ksh,
+ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as
+ * D:/bin/sh.exe.
+ */
+#define SH_PATH "/bin/sh" /**/
+
+/* STDCHAR:
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+#define STDCHAR char /**/
+
+/* MEM_ALIGNBYTES:
+ * This symbol contains the number of bytes required to align a
+ * double. Usual values are 2, 4 and 8.
+ * On NeXT starting with 3.2, you can build "Fat" Multiple Architecture
+ * Binaries (MAB) for targets with varying alignment. This only matters
+ * for perl, where the config.h can be generated and installed on one
+ * system, and used by a different architecture to build an extension.
+ * The default is eight, for safety.
+ */
+#define MEM_ALIGNBYTES 4 /**/
+
+/* BYTEORDER:
+ * This symbol holds the hexadecimal constant defined in byteorder,
+ * i.e. 0x1234 or 0x4321, etc...
+ * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture
+ * Binaries (MAB) on either big endian or little endian machines.
+ * The endian-ness is available at compile-time. This only matters
+ * for perl, where the config.h can be generated and installed on
+ * one system, and used by a different architecture to build an
+ * extension. Older versions of NeXT that might not have
+ * defined either *_ENDIAN__ were all on Motorola 680x0 series,
+ * so the default case (for NeXT) is big endian to catch them.
+ * This might matter for NeXT 3.0.
+ */
+#ifndef NeXT
+#define BYTEORDER 0x1234 /* large digits for MSB */
+#else /* NeXT */
+#ifdef __LITTLE_ENDIAN__
+#define BYTEORDER 0x1234
+#else /* __BIG_ENDIAN__ */
+#define BYTEORDER 0x4321
+#endif /* ENDIAN CHECK */
+#endif /* NeXT */
+
+/* CASTI32:
+ * This symbol is defined if the C compiler can cast negative
+ * or large floating point numbers to 32-bit ints.
+ */
+/*#define CASTI32 / **/
+
+/* CASTNEGFLOAT:
+ * This symbol is defined if the C compiler can cast negative
+ * numbers to unsigned longs, ints and shorts.
+ */
+/* CASTFLAGS:
+ * This symbol contains flags that say what difficulties the compiler
+ * has casting odd floating values to unsigned long:
+ * 0 = ok
+ * 1 = couldn't cast < 0
+ * 2 = couldn't cast >= 0x80000000
+ * 4 = couldn't cast in argument expression list
+ */
+#define CASTNEGFLOAT /**/
+#define CASTFLAGS 0 /**/
+
+/* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+/*#define VOID_CLOSEDIR / **/
+
+/* Gconvert:
+ * This preprocessor macro is defined to convert a floating point
+ * number to a string without a trailing decimal point. This
+ * emulates the behavior of sprintf("%g"), but is sometimes much more
+ * efficient. If gconvert() is not available, but gcvt() drops the
+ * trailing decimal point, then gcvt() is used. If all else fails,
+ * a macro using sprintf("%g") is used. Arguments for the Gconvert
+ * macro are: value, number of digits, whether trailing zeros should
+ * be retained, and the output buffer.
+ * Possible values are:
+ * d_Gconvert='gconvert((x),(n),(t),(b))'
+ * d_Gconvert='gcvt((x),(n),(b))'
+ * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ * The last two assume trailing zeros should not be kept.
+ */
+#define Gconvert(x,n,t,b) gcvt((x),(n),(b))
+
+/* HAS_GNULIBC:
+ * This symbol, if defined, indicates to the C program that
+ * the GNU C library is being used.
+ */
+#define HAS_GNULIBC /**/
+/* HAS_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+#define HAS_ISASCII /**/
+
+/* HAS_LCHOWN:
+ * This symbol, if defined, indicates that the lchown routine is
+ * available to operate on a symbolic link (instead of following the
+ * link).
+ */
+/*#define HAS_LCHOWN / **/
+
+/* HAS_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+#define HAS_OPEN3 /**/
+
+/* HAS_SAFE_BCOPY:
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy potentially overlapping memory blocks. Otherwise you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+#define HAS_SAFE_BCOPY /**/
+
+/* HAS_SAFE_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy potentially overlapping memory blocks. Otherwise you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+/*#define HAS_SAFE_MEMCPY / **/
+
+/* HAS_SANE_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * and can be used to compare relative magnitudes of chars with their high
+ * bits set. If it is not defined, roll your own version.
+ */
+#define HAS_SANE_MEMCMP /**/
+
+/* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+#define HAS_SIGACTION /**/
+
+/* Sigjmp_buf:
+ * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
+ */
+/* Sigsetjmp:
+ * This macro is used in the same way as sigsetjmp(), but will invoke
+ * traditional setjmp() if sigsetjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+/* Siglongjmp:
+ * This macro is used in the same way as siglongjmp(), but will invoke
+ * traditional longjmp() if siglongjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+#define HAS_SIGSETJMP /**/
+#ifdef HAS_SIGSETJMP
+#define Sigjmp_buf sigjmp_buf
+#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask))
+#define Siglongjmp(buf,retval) siglongjmp((buf),(retval))
+#else
+#define Sigjmp_buf jmp_buf
+#define Sigsetjmp(buf,save_mask) setjmp((buf))
+#define Siglongjmp(buf,retval) longjmp((buf),(retval))
+#endif
+
+/* USE_STDIO_PTR:
+ * This symbol is defined if the _ptr and _cnt fields (or similar)
+ * of the stdio FILE structure can be used to access the stdio buffer
+ * for a file handle. If this is defined, then the FILE_ptr(fp)
+ * and FILE_cnt(fp) macros will also be defined and should be used
+ * to access these fields.
+ */
+/* FILE_ptr:
+ * This macro is used to access the _ptr field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_PTR_LVALUE:
+ * This symbol is defined if the FILE_ptr macro can be used as an
+ * lvalue.
+ */
+/* FILE_cnt:
+ * This macro is used to access the _cnt field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_CNT_LVALUE:
+ * This symbol is defined if the FILE_cnt macro can be used as an
+ * lvalue.
+ */
+#define USE_STDIO_PTR /**/
+#ifdef USE_STDIO_PTR
+#define FILE_ptr(fp) ((fp)->_IO_read_ptr)
+#define STDIO_PTR_LVALUE /**/
+#define FILE_cnt(fp) ((fp)->_IO_read_end - (fp)->_IO_read_ptr)
+/*#define STDIO_CNT_LVALUE / **/
+#endif
+
+/* USE_STDIO_BASE:
+ * This symbol is defined if the _base field (or similar) of the
+ * stdio FILE structure can be used to access the stdio buffer for
+ * a file handle. If this is defined, then the FILE_base(fp) macro
+ * will also be defined and should be used to access this field.
+ * Also, the FILE_bufsiz(fp) macro will be defined and should be used
+ * to determine the number of bytes in the buffer. USE_STDIO_BASE
+ * will never be defined unless USE_STDIO_PTR is.
+ */
+/* FILE_base:
+ * This macro is used to access the _base field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_BASE is defined.
+ */
+/* FILE_bufsiz:
+ * This macro is used to determine the number of bytes in the I/O
+ * buffer pointed to by _base field (or equivalent) of the FILE
+ * structure pointed to its argument. This macro will always be defined
+ * if USE_STDIO_BASE is defined.
+ */
+#define USE_STDIO_BASE /**/
+#ifdef USE_STDIO_BASE
+#define FILE_base(fp) ((fp)->_IO_read_base)
+#define FILE_bufsiz(fp) ((fp)->_IO_read_end - (fp)->_IO_read_base)
+#endif
+
+/* HAS_VPRINTF:
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+/* USE_CHAR_VSPRINTF:
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+#define HAS_VPRINTF /**/
+/*#define USE_CHAR_VSPRINTF / **/
+
+/* DOUBLESIZE:
+ * This symbol contains the size of a double, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define DOUBLESIZE 8 /**/
+
+/* I_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+/* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+/* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+/*#define I_TIME / **/
+#define I_SYS_TIME /**/
+/*#define I_SYS_TIME_KERNEL / **/
+
+/* INTSIZE:
+ * This symbol contains the value of sizeof(int) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* LONGSIZE:
+ * This symbol contains the value of sizeof(long) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* SHORTSIZE:
+ * This symbol contains the value of sizeof(short) so that the C
+ * preprocessor can make decisions based on it.
+ */
+#define INTSIZE 4 /**/
+#define LONGSIZE 4 /**/
+#define SHORTSIZE 2 /**/
+
+/* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+/* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+/* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+/* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+#define VAL_O_NONBLOCK O_NONBLOCK
+#define VAL_EAGAIN EAGAIN
+#define RD_NODATA -1
+#define EOF_NONBLOCK
+
+/* PTRSIZE:
+ * This symbol contains the size of a pointer, so that the C preprocessor
+ * can make decisions based on it. It will be sizeof(void *) if
+ * the compiler supports (void *); otherwise it will be
+ * sizeof(char *).
+ */
+#define PTRSIZE 4 /**/
+
+/* RANDBITS:
+ * This symbol contains the number of bits of random number the rand()
+ * function produces. Usual values are 15, 16, and 31.
+ */
+#define RANDBITS 31 /**/
+
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t ssize_t /* signed count of bytes */
+
+/* OSNAME:
+ * This symbol contains the name of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
+#define OSNAME "linux" /**/
+
+/* CAT2:
+ * This macro catenates 2 tokens together.
+ */
+/* STRINGIFY:
+ * This macro surrounds its token with double quotes.
+ */
+#if 42 == 1
+#define CAT2(a,b)a/**/b
+#define STRINGIFY(a)"a"
+ /* If you can get stringification with catify, tell me how! */
+#endif
+#if 42 == 42
+#define CAT2(a,b)a ## b
+#define StGiFy(a)# a
+#define STRINGIFY(a)StGiFy(a)
+#endif
+#if 42 != 1 && 42 != 42
+#include "Bletch: How does this C preprocessor catenate tokens?"
+#endif
+
+/* CSH:
+ * This symbol, if defined, contains the full pathname of csh.
+ */
+#define HAS_CSH /**/
+#ifdef HAS_CSH
+#define CSH "/bin/csh" /**/
+#endif
+
+/* HAS_ENDHOSTENT:
+ * This symbol, if defined, indicates that the endhostent() routine is
+ * available to close whatever was being used for host queries.
+ */
+#define HAS_ENDHOSTENT /**/
+
+/* HAS_ENDNETENT:
+ * This symbol, if defined, indicates that the endnetent() routine is
+ * available to close whatever was being used for network queries.
+ */
+#define HAS_ENDNETENT /**/
+
+/* HAS_ENDPROTOENT:
+ * This symbol, if defined, indicates that the endprotoent() routine is
+ * available to close whatever was being used for protocol queries.
+ */
+#define HAS_ENDPROTOENT /**/
+
+/* HAS_ENDSERVENT:
+ * This symbol, if defined, indicates that the endservent() routine is
+ * available to close whatever was being used for service queries.
+ */
+#define HAS_ENDSERVENT /**/
+
+/* HAS_GETHOSTBYADDR:
+ * This symbol, if defined, indicates that the gethostbyaddr() routine is
+ * available to look up hosts by their IP addresses.
+ */
+#define HAS_GETHOSTBYADDR /**/
+
+/* HAS_GETHOSTBYNAME:
+ * This symbol, if defined, indicates that the gethostbyname() routine is
+ * available to look up host names in some data base or other.
+ */
+#define HAS_GETHOSTBYNAME /**/
+
+/* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent() routine is
+ * available to look up host names in some data base or another.
+ */
+#define HAS_GETHOSTENT /**/
+
+/* HAS_GETNETBYADDR:
+ * This symbol, if defined, indicates that the getnetbyaddr() routine is
+ * available to look up networks by their IP addresses.
+ */
+#define HAS_GETNETBYADDR /**/
+
+/* HAS_GETNETBYNAME:
+ * This symbol, if defined, indicates that the getnetbyname() routine is
+ * available to look up networks by their names.
+ */
+#define HAS_GETNETBYNAME /**/
+
+/* HAS_GETNETENT:
+ * This symbol, if defined, indicates that the getnetent() routine is
+ * available to look up network names in some data base or another.
+ */
+#define HAS_GETNETENT /**/
+
+/* HAS_GETPROTOENT:
+ * This symbol, if defined, indicates that the getprotoent() routine is
+ * available to look up protocols in some data base or another.
+ */
+#define HAS_GETPROTOENT /**/
+
+/* HAS_GETPROTOBYNAME:
+ * This symbol, if defined, indicates that the getprotobyname()
+ * routine is available to look up protocols by their name.
+ */
+/* HAS_GETPROTOBYNUMBER:
+ * This symbol, if defined, indicates that the getprotobynumber()
+ * routine is available to look up protocols by their number.
+ */
+#define HAS_GETPROTOBYNAME /**/
+#define HAS_GETPROTOBYNUMBER /**/
+
+/* HAS_GETSERVENT:
+ * This symbol, if defined, indicates that the getservent() routine is
+ * available to look up network services in some data base or another.
+ */
+#define HAS_GETSERVENT /**/
+
+/* HAS_GETSERVBYNAME:
+ * This symbol, if defined, indicates that the getservbyname()
+ * routine is available to look up services by their name.
+ */
+/* HAS_GETSERVBYPORT:
+ * This symbol, if defined, indicates that the getservbyport()
+ * routine is available to look up services by their port.
+ */
+#define HAS_GETSERVBYNAME /**/
+#define HAS_GETSERVBYPORT /**/
+
+/* HAS_LONG_DOUBLE:
+ * This symbol will be defined if the C compiler supports long
+ * doubles.
+ */
+/* LONG_DOUBLESIZE:
+ * This symbol contains the size of a long double, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long doubles.
+ */
+#define HAS_LONG_DOUBLE /**/
+#ifdef HAS_LONG_DOUBLE
+#define LONG_DOUBLESIZE 12 /**/
+#endif
+
+/* HAS_LONG_LONG:
+ * This symbol will be defined if the C compiler supports
+ * long long.
+ */
+/* LONGLONGSIZE:
+ * This symbol contains the size of a long long, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long long.
+ */
+#define HAS_LONG_LONG /**/
+#ifdef HAS_LONG_LONG
+#define LONGLONGSIZE 8 /**/
+#endif
+
+/* HAS_SETGROUPS:
+ * This symbol, if defined, indicates that the setgroups() routine is
+ * available to set the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+#define HAS_SETGROUPS /**/
+
+/* HAS_SETHOSTENT:
+ * This symbol, if defined, indicates that the sethostent() routine is
+ * available.
+ */
+#define HAS_SETHOSTENT /**/
+
+/* HAS_SETNETENT:
+ * This symbol, if defined, indicates that the setnetent() routine is
+ * available.
+ */
+#define HAS_SETNETENT /**/
+
+/* HAS_SETPROTOENT:
+ * This symbol, if defined, indicates that the setprotoent() routine is
+ * available.
+ */
+#define HAS_SETPROTOENT /**/
+
+/* HAS_SETSERVENT:
+ * This symbol, if defined, indicates that the setservent() routine is
+ * available.
+ */
+#define HAS_SETSERVENT /**/
+
+/* HAS_SETVBUF:
+ * This symbol, if defined, indicates that the setvbuf routine is
+ * available to change buffering on an open stdio stream.
+ * to a line-buffered mode.
+ */
+#define HAS_SETVBUF /**/
+
+/* HAS_SOCKET:
+ * This symbol, if defined, indicates that the BSD socket interface is
+ * supported.
+ */
+/* HAS_SOCKETPAIR:
+ * This symbol, if defined, indicates that the BSD socketpair() call is
+ * supported.
+ */
+#define HAS_SOCKET /**/
+#define HAS_SOCKETPAIR /**/
+
+/* HAS_UNION_SEMUN:
+ * This symbol, if defined, indicates that the union semun is
+ * defined by including <sys/sem.h>. If not, the user code
+ * probably needs to define it as:
+ * union semun {
+ * int val;
+ * struct semid_ds *buf;
+ * unsigned short *array;
+ * }
+ */
+/* USE_SEMCTL_SEMUN:
+ * This symbol, if defined, indicates that union semun is
+ * used for semctl IPC_STAT.
+ */
+/* USE_SEMCTL_SEMID_DS:
+ * This symbol, if defined, indicates that struct semid_ds * is
+ * used for semctl IPC_STAT.
+ */
+#define HAS_UNION_SEMUN /**/
+#define USE_SEMCTL_SEMUN /**/
+#define USE_SEMCTL_SEMID_DS /**/
+
+/* Signal_t:
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return type of a signal handler. Thus, you can declare
+ * a signal handler using "Signal_t (*handler)()", and define the
+ * handler using "Signal_t handler(sig)".
+ */
+#define Signal_t void /* Signal handler's return type */
+
+/* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * getgroups() and setgropus(). Usually, this is the same as
+ * gidtype (gid_t) , but sometimes it isn't.
+ * It can be int, ushort, uid_t, etc...
+ * It may be necessary to include <sys/types.h> to get any
+ * typedef'ed information. This is only required if you have
+ * getgroups() or setgropus()..
+ */
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+#define Groups_t gid_t /* Type for 2nd arg to [sg]etgroups() */
+#endif
+
+/* I_NETDB:
+ * This symbol, if defined, indicates that <netdb.h> exists and
+ * should be included.
+ */
+#define I_NETDB /**/
+
+/* I_PWD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pwd.h>.
+ */
+/* PWQUOTA:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_quota.
+ */
+/* PWAGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_age.
+ */
+/* PWCHANGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_change.
+ */
+/* PWCLASS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_class.
+ */
+/* PWEXPIRE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_expire.
+ */
+/* PWCOMMENT:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_comment.
+ */
+/* PWGECOS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_gecos.
+ */
+/* PWPASSWD:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_passwd.
+ */
+/* HAS_SETPWENT:
+ * This symbol, if defined, indicates that the getpwrent routine is
+ * available for initializing sequential access of the passwd database.
+ */
+/* HAS_GETPWENT:
+ * This symbol, if defined, indicates that the getpwent routine is
+ * available for sequential access of the password database.
+ */
+/* HAS_ENDPWENT:
+ * This symbol, if defined, indicates that the getpwent routine is
+ * available for finalizing sequential access of the passwd database.
+ */
+#define I_PWD /**/
+/*#define PWQUOTA / **/
+/*#define PWAGE / **/
+/*#define PWCHANGE / **/
+/*#define PWCLASS / **/
+/*#define PWEXPIRE / **/
+/*#define PWCOMMENT / **/
+#define PWGECOS /**/
+#define PWPASSWD /**/
+#define HAS_SETPWENT /**/
+#define HAS_GETPWENT /**/
+#define HAS_ENDPWENT /**/
+
+/* Free_t:
+ * This variable contains the return type of free(). It is usually
+ * void, but occasionally int.
+ */
+/* Malloc_t:
+ * This symbol is the type of pointer returned by malloc and realloc.
+ */
+#define Malloc_t void * /**/
+#define Free_t void /**/
+
+/* MYMALLOC:
+ * This symbol, if defined, indicates that we're using our own malloc.
+ */
+/*#define MYMALLOC / **/
+
+/* SIG_NAME:
+ * This symbol contains a list of signal names in order of
+ * signal number. This is intended
+ * to be used as a static array initialization, like this:
+ * char *sig_name[] = { SIG_NAME };
+ * The signals in the list are separated with commas, and each signal
+ * is surrounded by double quotes. There is no leading SIG in the signal
+ * name, i.e. SIGQUIT is known as "QUIT".
+ * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn,
+ * etc., where nn is the actual signal number (e.g. NUM37).
+ * The signal number for sig_name[i] is stored in sig_num[i].
+ * The last element is 0 to terminate the list with a NULL. This
+ * corresponds to the 0 at the end of the sig_num list.
+ */
+/* SIG_NUM:
+ * This symbol contains a list of signal numbers, in the same order as the
+ * SIG_NAME list. It is suitable for static array initialization, as in:
+ * int sig_num[] = { SIG_NUM };
+ * The signals in the list are separated with commas, and the indices
+ * within that list and the SIG_NAME list match, so it's easy to compute
+ * the signal name from a number or vice versa at the price of a small
+ * dynamic linear lookup.
+ * Duplicates are allowed, but are moved to the end of the list.
+ * The signal number corresponding to sig_name[i] is sig_number[i].
+ * if (i < NSIG) then sig_number[i] == i.
+ * The last element is 0, corresponding to the 0 at the end of
+ * the sig_name list.
+ */
+#define SIG_NAME "ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "BUS", "FPE", "KILL", "USR1", "SEGV", "USR2", "PIPE", "ALRM", "TERM", "STKFLT", "CHLD", "CONT", "STOP", "TSTP", "TTIN", "TTOU", "URG", "XCPU", "XFSZ", "VTALRM", "PROF", "WINCH", "IO", "PWR", "UNUSED", "IOT", "CLD", "POLL", 0 /**/
+#define SIG_NUM 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 6, 17, 29, 0 /**/
+
+/* VOIDFLAGS:
+ * This symbol indicates how much support of the void type is given by this
+ * compiler. What various bits mean:
+ *
+ * 1 = supports declaration of void
+ * 2 = supports arrays of pointers to functions returning void
+ * 4 = supports comparisons between pointers to void functions and
+ * addresses of void functions
+ * 8 = suports declaration of generic void pointers
+ *
+ * The package designer should define VOIDUSED to indicate the requirements
+ * of the package. This can be done either by #defining VOIDUSED before
+ * including config.h, or by defining defvoidused in Myinit.U. If the
+ * latter approach is taken, only those flags will be tested. If the
+ * level of void support necessary is not present, defines void to int.
+ */
+#ifndef VOIDUSED
+#define VOIDUSED 15
+#endif
+#define VOIDFLAGS 15
+#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+#define void int /* is void to be avoided? */
+#define M_VOID /* Xenix strikes again */
+#endif
+
+/* ARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user wants to put architecture-dependent public
+ * library files for perl5. It is most often a local directory
+ * such as /usr/local/lib. Programs using this variable must be
+ * prepared to deal with filename expansion. If ARCHLIB is the
+ * same as PRIVLIB, it is not defined, since presumably the
+ * program already searches PRIVLIB.
+ */
+/* ARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of ARCHLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define ARCHLIB "/opt/perl/lib/5.005/i686-linux-thread" /**/
+#define ARCHLIB_EXP "/opt/perl/lib/5.005/i686-linux-thread" /**/
+
+/* DLSYM_NEEDS_UNDERSCORE:
+ * This symbol, if defined, indicates that we need to prepend an
+ * underscore to the symbol name before calling dlsym(). This only
+ * makes sense if you *have* dlsym, which we will presume is the
+ * case if you're using dl_dlopen.xs.
+ */
+/*#define DLSYM_NEEDS_UNDERSCORE / **/
+
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+/*#define USE_SFIO / **/
+
+/* USE_DYNAMIC_LOADING:
+ * This symbol, if defined, indicates that dynamic loading of
+ * some sort is available.
+ */
+#define USE_DYNAMIC_LOADING /**/
+
+/* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+/* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+#define DB_Hash_t u_int32_t /**/
+#define DB_Prefix_t size_t /**/
+
+/* PRIVLIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ */
+/* PRIVLIB_EXP:
+ * This symbol contains the ~name expanded version of PRIVLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define PRIVLIB "/opt/perl/lib/5.005" /**/
+#define PRIVLIB_EXP "/opt/perl/lib/5.005" /**/
+
+/* SITEARCH:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * The standard distribution will put nothing in this directory.
+ * Individual sites may place their own extensions and modules in
+ * this directory.
+ */
+/* SITEARCH_EXP:
+ * This symbol contains the ~name expanded version of SITEARCH, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define SITEARCH "/opt/perl/lib/site_perl/5.005/i686-linux-thread" /**/
+#define SITEARCH_EXP "/opt/perl/lib/site_perl/5.005/i686-linux-thread" /**/
+
+/* SITELIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * The standard distribution will put nothing in this directory.
+ * Individual sites may place their own extensions and modules in
+ * this directory.
+ */
+/* SITELIB_EXP:
+ * This symbol contains the ~name expanded version of SITELIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define SITELIB "/opt/perl/lib/site_perl/5.005" /**/
+#define SITELIB_EXP "/opt/perl/lib/site_perl/5.005" /**/
+
+/* STARTPERL:
+ * This variable contains the string to put in front of a perl
+ * script to make sure (one hopes) that it runs with perl and not
+ * some shell.
+ */
+#define STARTPERL "#!/opt/perl/bin/perl" /**/
+
+/* USE_PERLIO:
+ * This symbol, if defined, indicates that the PerlIO abstraction should
+ * be used throughout. If not defined, stdio should be
+ * used in a fully backward compatible manner.
+ */
+/*#define USE_PERLIO / **/
+
+/* HAS_GETHOST_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for gethostent(), gethostbyname(), and
+ * gethostbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#define HAS_GETHOST_PROTOS /**/
+
+/* HAS_GETNET_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getnetent(), getnetbyname(), and
+ * getnetbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#define HAS_GETNET_PROTOS /**/
+
+/* HAS_GETPROTO_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getprotoent(), getprotobyname(), and
+ * getprotobyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#define HAS_GETPROTO_PROTOS /**/
+
+/* HAS_GETSERV_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getservent(), getservbyname(), and
+ * getservbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#define HAS_GETSERV_PROTOS /**/
+
+/* Netdb_host_t:
+ * This symbol holds the type used for the 1st argument
+ * to gethostbyaddr().
+ */
+/* Netdb_hlen_t:
+ * This symbol holds the type used for the 2nd argument
+ * to gethostbyaddr().
+ */
+/* Netdb_name_t:
+ * This symbol holds the type used for the argument to
+ * gethostbyname().
+ */
+/* Netdb_net_t:
+ * This symbol holds the type used for the 1st argument to
+ * getnetbyaddr().
+ */
+#define Netdb_host_t const char * /**/
+#define Netdb_hlen_t int /**/
+#define Netdb_name_t const char * /**/
+#define Netdb_net_t unsigned long /**/
+
+/* Select_fd_set_t:
+ * This symbol holds the type used for the 2nd, 3rd, and 4th
+ * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
+ * is defined, and 'int *' otherwise. This is only useful if you
+ * have select(), of course.
+ */
+#define Select_fd_set_t fd_set * /**/
+
+/* ARCHNAME:
+ * This symbol holds a string representing the architecture name.
+ * It may be used to construct an architecture-dependant pathname
+ * where library files may be held under a private library, for
+ * instance.
+ */
+#define ARCHNAME "i686-linux-thread" /**/
+
+/* HAS_PTHREAD_YIELD:
+ * This symbol, if defined, indicates that the pthread_yield
+ * routine is available to yield the execution of the current
+ * thread.
+ */
+/* HAS_SCHED_YIELD:
+ * This symbol, if defined, indicates that the sched_yield
+ * routine is available to yield the execution of the current
+ * thread.
+ */
+/*#define HAS_PTHREAD_YIELD / **/
+#define HAS_SCHED_YIELD /**/
+
+/* PTHREADS_CREATED_JOINABLE:
+ * This symbol, if defined, indicates that pthreads are created
+ * in the joinable (aka undetached) state.
+ */
+#define PTHREADS_CREATED_JOINABLE /**/
+
+/* USE_THREADS:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use threads.
+ */
+/* OLD_PTHREADS_API:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use the old draft POSIX threads API.
+ */
+#define USE_THREADS /**/
+/*#define OLD_PTHREADS_API / **/
+
+/* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+#define Time_t time_t /* Time type */
+
+/* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+#define HAS_TIMES /**/
+
+/* Fpos_t:
+ * This symbol holds the type used to declare file positions in libc.
+ * It can be fpos_t, long, uint, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Fpos_t fpos_t /* File position type */
+
+/* Gid_t:
+ * This symbol holds the return type of getgid() and the type of
+ * argument to setrgid() and related functions. Typically,
+ * it is the type of group ids in the kernel. It can be int, ushort,
+ * uid_t, etc... It may be necessary to include <sys/types.h> to get
+ * any typedef'ed information.
+ */
+#define Gid_t gid_t /* Type for getgid(), etc... */
+
+/* Off_t:
+ * This symbol holds the type used to declare offsets in the kernel.
+ * It can be int, long, off_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Off_t off_t /* <offset> type */
+
+/* Mode_t:
+ * This symbol holds the type used to declare file modes
+ * for systems calls. It is usually mode_t, but may be
+ * int or unsigned short. It may be necessary to include <sys/types.h>
+ * to get any typedef'ed information.
+ */
+#define Mode_t mode_t /* file mode parameter for system calls */
+
+/* Pid_t:
+ * This symbol holds the type used to declare process ids in the kernel.
+ * It can be int, uint, pid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Pid_t pid_t /* PID type */
+
+/* Size_t:
+ * This symbol holds the type used to declare length parameters
+ * for string functions. It is usually size_t, but may be
+ * unsigned long, int, etc. It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Size_t size_t /* length paramater for string functions */
+
+/* Uid_t:
+ * This symbol holds the type used to declare user ids in the kernel.
+ * It can be int, ushort, uid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Uid_t uid_t /* UID type */
+
+#endif
diff --git a/contrib/perl5/Porting/findvars b/contrib/perl5/Porting/findvars
new file mode 100755
index 000000000000..2e81244ac86c
--- /dev/null
+++ b/contrib/perl5/Porting/findvars
@@ -0,0 +1,373 @@
+#!/l/local/bin/perl -w
+
+$pat = '';
+# construct word list
+while (<DATA>) {
+ chomp;
+ next unless $_;
+ $pat .= "$_|";
+}
+chop $pat if $pat =~ /\|$/;
+
+# grep
+while (<>) {
+ if (/^(.*?)\b($pat)\b(.*)$/o) {
+ my $head = "$1#$2#";
+ $_ = $3;
+ while (/^(.*?)\b($pat)\b(.*)$/o) {
+ $head .= "$1#$2#";
+ $_ = $3;
+ }
+ print "$ARGV\:$.\:$head$_\n";
+ }
+}
+continue {
+ close ARGV if eof;
+}
+__END__
+Argv
+Cmd
+DBcv
+DBgv
+DBline
+DBsignal
+DBsingle
+DBsub
+DBtrace
+No
+Sv
+Xpv
+Yes
+amagic_generation
+ampergv
+an
+archpat_auto
+argvgv
+argvoutgv
+av_fetch_sv
+basetime
+beginav
+bodytarget
+bostr
+bufend
+bufptr
+cddir
+chopset
+collation_ix
+collation_name
+collation_standard
+collxfrm_base
+collxfrm_mult
+colors
+colorset
+compcv
+compiling
+comppad
+comppad_name
+comppad_name_fill
+comppad_name_floor
+cop_seqmax
+copline
+cryptseen
+cshlen
+cshname
+curcop
+curcopdb
+curinterp
+curpad
+curpm
+curstack
+curstackinfo
+curstash
+curstname
+curthr
+dbargs
+debdelim
+debname
+debstash
+debug
+defgv
+defoutgv
+defstash
+delaymagic
+diehook
+dirty
+dlevel
+dlmax
+do_undump
+doextract
+doswitches
+dowarn
+dumplvl
+e_script
+egid
+endav
+envgv
+errgv
+error_count
+euid
+eval_cond
+eval_mutex
+eval_owner
+eval_root
+eval_start
+evalseq
+exitlist
+exitlistlen
+expect
+extralen
+fdpid
+filemode
+firstgv
+forkprocess
+formfeed
+formtarget
+generation
+gensym
+gid
+globalstash
+he_root
+hexdigit
+hintgv
+hints
+hv_fetch_ent_mh
+hv_fetch_sv
+in_clean_all
+in_clean_objs
+in_eval
+in_my
+in_my_stash
+incgv
+initav
+inplace
+last_in_gv
+last_lop
+last_lop_op
+last_proto
+last_uni
+lastfd
+lastgotoprobe
+lastscream
+lastsize
+lastspbase
+laststatval
+laststype
+leftgv
+lex_brackets
+lex_brackstack
+lex_casemods
+lex_casestack
+lex_defer
+lex_dojoin
+lex_expect
+lex_fakebrack
+lex_formbrack
+lex_inpat
+lex_inwhat
+lex_op
+lex_repl
+lex_starts
+lex_state
+lex_stuff
+lineary
+linestart
+linestr
+localizing
+localpatches
+main_cv
+main_root
+main_start
+mainstack
+malloc_mutex
+markstack
+markstack_max
+markstack_ptr
+max_intro_pending
+maxo
+maxscream
+maxsysfd
+mess_sv
+min_intro_pending
+minus_F
+minus_a
+minus_c
+minus_l
+minus_n
+minus_p
+modcount
+modglobal
+multi_close
+multi_end
+multi_open
+multi_start
+multiline
+mystrk
+na
+nexttoke
+nexttype
+nextval
+nice_chunk
+nice_chunk_size
+ninterps
+nomemok
+nrs
+nthreads
+nthreads_cond
+numeric_local
+numeric_name
+numeric_standard
+ofmt
+ofs
+ofslen
+oldbufptr
+oldlastpm
+oldname
+oldoldbufptr
+op
+op_mask
+op_seqmax
+opsave
+origalen
+origargc
+origargv
+origenviron
+origfilename
+ors
+orslen
+osname
+pad_reset_pending
+padix
+padix_floor
+parsehook
+patchlevel
+patleave
+pending_ident
+perl_destruct_level
+perldb
+pidstatus
+preambleav
+preambled
+preprocess
+profiledata
+reg_eval_set
+reg_flags
+reg_start_tmp
+reg_start_tmpl
+regbol
+regcc
+regcode
+regcomp_parse
+regcomp_rx
+regcompp
+regdata
+regdummy
+regendp
+regeol
+regexecp
+regflags
+regindent
+reginput
+reginterp_cnt
+reglastparen
+regnarrate
+regnaughty
+regnpar
+regprecomp
+regprev
+regprogram
+regsawback
+regseen
+regsize
+regstartp
+regtill
+regxend
+replgv
+restartop
+retstack
+retstack_ix
+retstack_max
+rightgv
+rs
+rsfp
+rsfp_filters
+runops
+savestack
+savestack_ix
+savestack_max
+sawampersand
+sawstudy
+sawvec
+scopestack
+scopestack_ix
+scopestack_max
+screamfirst
+screamnext
+secondgv
+seen_evals
+seen_zerolen
+sh_path
+siggv
+sighandlerp
+sortcop
+sortcxix
+sortstash
+specialsv_list
+splitstr
+stack_base
+stack_max
+stack_sp
+start_env
+statbuf
+statcache
+statgv
+statname
+statusvalue
+statusvalue_vms
+stdingv
+strchop
+strtab
+sub_generation
+sublex_info
+subline
+subname
+sv_arenaroot
+sv_count
+sv_mutex
+sv_no
+sv_objcount
+sv_root
+sv_undef
+sv_yes
+svref_mutex
+sys_intern
+tainted
+tainting
+thisexpr
+thr_key
+threadnum
+threads_mutex
+threadsv_names
+thrsv
+timesbuf
+tmps_floor
+tmps_ix
+tmps_max
+tmps_stack
+tokenbuf
+top_env
+toptarget
+uid
+unsafe
+warnhook
+xiv_arenaroot
+xiv_root
+xnv_root
+xpv_root
+xrv_root
+piMem
+piENV
+piStdIO
+piLIO
+piDir
+piSock
+piProc
diff --git a/contrib/perl5/Porting/fixCORE b/contrib/perl5/Porting/fixCORE
new file mode 100755
index 000000000000..4c586d896981
--- /dev/null
+++ b/contrib/perl5/Porting/fixCORE
@@ -0,0 +1,68 @@
+#!/usr/local/bin/perl -w
+use Data::Dumper;
+
+my $targ = shift;
+my $inc = join(' ',map("-I$_",@INC));
+
+my $work = 1;
+while ($work)
+ {
+ open(PIPE,"$^X -w $inc -M$targ -e '' 2>&1 |") || die "Cannot open pipe to child:$!";
+ my %fix;
+ while (<PIPE>)
+ {
+ if (/^Ambiguous call resolved as CORE::(\w+)\(\), qualify as such or use \& at (\S+) line (\d+)/
+ && -f $2 )
+ {
+ my ($var,$file,$line) = ($1,$2,$3);
+ $fix{$file} = [] unless exists $fix{$file};
+ push(@{$fix{$file}},[$line => $var]) unless ($var =~ /^PL_/ || $file =~ /\.h$/);
+ }
+ print;
+ }
+ close(PIPE);
+# warn "Make retured $?\n";
+# last unless $?;
+ my $changed = 0;
+ foreach my $file (keys %fix)
+ {
+ my @ar = sort( { $a->[0] <=> $b->[0] } @{delete $fix{$file}});
+ my @miss;
+ my $fixed = 0;
+ @ARGV = ($file);
+ $. = 0;
+ local $^I = '.sav';
+ while (<>)
+ {
+ while (@ar && $. == $ar[0][0])
+ {
+ my ($line,$var) = @{shift(@ar)};
+ if (s/(?<!CORE::)\b$var\b(?=\s*\()/CORE::$var/)
+ {
+ warn "$file:$line: FIX $var\n";
+ $fixed++;
+ $changed++;
+ }
+ else
+ {
+ push(@miss,[$line,$var,$_]);
+ }
+ }
+ print;
+ }
+ unless ($fixed)
+ {
+ rename("$file$^I",$file);
+ if (@miss)
+ {
+ while (@miss)
+ {
+ my ($line,$var,$txt) = @{shift(@miss)};
+ warn "$file:$line:$var | $txt";
+ }
+ }
+ }
+ }
+ last unless $changed;
+ }
+
diff --git a/contrib/perl5/Porting/fixvars b/contrib/perl5/Porting/fixvars
new file mode 100755
index 000000000000..a211e5816fa8
--- /dev/null
+++ b/contrib/perl5/Porting/fixvars
@@ -0,0 +1,69 @@
+#!/usr/local/bin/perl -w
+use Data::Dumper;
+
+my $targ = (@ARGV) ? join(' ',@ARGV) : 'miniperl' ;
+
+my $work = 1;
+while ($work)
+ {
+ open(PIPE,"make $targ 2>&1 |") || die "Cannot open pipe to make:$!";
+ my %fix;
+ while (<PIPE>)
+ {
+ if (/^(.*):(\d+):\s+\`(\w+)'\s+undeclared/ && -f $1 )
+ {
+ my ($file,$line,$var) = ($1,$2,$3);
+ $fix{$file} = [] unless exists $fix{$file};
+ push(@{$fix{$file}},[$line => $var]) unless ($var =~ /^PL_/ || $file =~ /\.h$/);
+ }
+ print;
+ }
+ close(PIPE);
+ warn "Make retured $?\n";
+ last unless $?;
+ my $changed = 0;
+ foreach my $file (keys %fix)
+ {
+ my @ar = sort( { $a->[0] <=> $b->[0] } @{delete $fix{$file}});
+ my @miss;
+ my $fixed = 0;
+ unless (-w $file)
+ {
+ system("d4","edit",$file);
+ }
+ @ARGV = ($file);
+ $. = 0;
+ local $^I = '.sav';
+ while (<>)
+ {
+ while (@ar && $. == $ar[0][0])
+ {
+ my ($line,$var) = @{shift(@ar)};
+ if (s/\b$var\b/PL_$var/)
+ {
+ warn "$file:$line: FIX $var\n";
+ $fixed++;
+ $changed++;
+ }
+ else
+ {
+ push(@miss,[$line,$var,$_]);
+ }
+ }
+ print;
+ }
+ unless ($fixed)
+ {
+ rename("$file$^I",$file);
+ if (@miss)
+ {
+ while (@miss)
+ {
+ my ($line,$var,$txt) = @{shift(@miss)};
+ warn "$file:$line:$var | $txt";
+ }
+ }
+ }
+ }
+ last unless $changed;
+ }
diff --git a/contrib/perl5/Porting/genlog b/contrib/perl5/Porting/genlog
new file mode 100755
index 000000000000..5c3e90577e1c
--- /dev/null
+++ b/contrib/perl5/Porting/genlog
@@ -0,0 +1,118 @@
+#!/l/local/bin/perl -w
+#
+# Generate a nice changelist by querying perforce.
+#
+# Each change is described with the change number, description,
+# which branch the change happened in, files modified,
+# and who was responsible for entering the change.
+#
+# Can be called with a list of change numbers or a range of the
+# form "12..42". Changelog will be printed from highest number
+# to lowest.
+#
+# Outputs the changelist to stdout.
+#
+# Gurusamy Sarathy <gsar@umich.edu>
+#
+
+use Text::Wrap;
+
+$0 =~ s|^.*/||;
+unless (@ARGV) {
+ die <<USAGE;
+ $0 [-p \$P4PORT] <change numbers or from..to>
+USAGE
+}
+
+my @changes;
+
+my %editkind;
+@editkind{ qw( add edit delete integrate branch )}
+ = qw( + ! - !> +> );
+
+my $p4port = $ENV{P4PORT} || 'localhost:1666';
+
+while (@ARGV) {
+ $_ = shift;
+ if (/^(\d+)\.\.(\d+)$/) {
+ push @changes, $1 .. $2;
+ }
+ elsif (/^\d+$/) {
+ push @changes, $_;
+ }
+ elsif (/^-p(.*)$/) {
+ $p4port = $1 || shift;
+ }
+ else {
+ warn "Arguments must be change numbers, ignoring `$_'\n";
+ }
+}
+
+@changes = sort { $b <=> $a } @changes;
+
+my @desc = `p4 -p $p4port describe -s @changes`;
+if ($?) {
+ die "$0: `p4 -p $p4port describe -s @changes` failed, status[$?]\n";
+}
+else {
+ chomp @desc;
+ while (@desc) {
+ my ($change,$who,$date,$time,@log,$branch,$file,$type,%files);
+ $_ = shift @desc;
+ if (/^Change (\d+) by (\w+)\@.+ on (\S+) (\S+)\s*$/) {
+ ($change, $who, $date, $time) = ($1,$2,$3,$4);
+ $_ = shift @desc; # get rid of empty line
+ while (@desc) {
+ $_ = shift @desc;
+ last if /^Affected/;
+ push @log, $_;
+ }
+ if (/^Affected/) {
+ $_ = shift @desc; # get rid of empty line
+ while ($_ = shift @desc) {
+ last unless /^\.\.\./;
+ if (m{^\.\.\. //depot/(.*?perl|[^/]*)/([^#]+)#\d+ (\w+)\s*$}) {
+ ($branch,$file,$type) = ($1,$2,$3);
+ $files{$branch} = {} unless exists $files{$branch};
+ $files{$branch}{$type} = [] unless exists $files{$branch}{$type};
+ push @{$files{$branch}{$type}}, $file;
+ }
+ else {
+ warn "Unknown line [$_], ignoring\n";
+ }
+ }
+ }
+ }
+ next unless $change;
+ print "_" x 76, "\n";
+ printf <<EOT, $change, $who, $date, $time;
+[%6s] By: %-25s on %9s %9s
+EOT
+ print " Log: ";
+ my $i = 0;
+ while (@log) {
+ $_ = shift @log;
+ s/^\s*//;
+ s/^\[.*\]\s*// unless $i ;
+ # don't print last empty line
+ if ($_ or @log) {
+ print " " if $i++;
+ print "$_\n";
+ }
+ }
+ for my $branch (sort keys %files) {
+ printf "%11s: $branch\n", 'Branch';
+ for my $kind (sort keys %{$files{$branch}}) {
+ warn("### $kind ###\n"), next unless exists $editkind{$kind};
+ my $files = $files{$branch}{$kind};
+ # don't show large branches and integrations
+ $files = ["($kind " . scalar(@$files) . ' files)']
+ if (@$files > 25
+ && ( $kind eq 'integrate' || $kind eq 'branch'));
+ print wrap(sprintf("%12s ", $editkind{$kind}),
+ sprintf("%12s ", $editkind{$kind}),
+ "@$files\n");
+ }
+ }
+ }
+}
diff --git a/contrib/perl5/Porting/makerel b/contrib/perl5/Porting/makerel
new file mode 100755
index 000000000000..f2e1f9750b22
--- /dev/null
+++ b/contrib/perl5/Porting/makerel
@@ -0,0 +1,129 @@
+#!/bin/env perl -w
+
+# A first attempt at some automated support for making a perl release.
+# Very basic but functional - if you're on a unix system.
+#
+# No matter how automated this gets, you'll always need to read
+# and re-read pumpkin.pod checking for things to be done at various
+# stages of the process.
+#
+# Tim Bunce, June 1997
+
+use ExtUtils::Manifest qw(fullcheck);
+
+$|=1;
+$relroot = ".."; # XXX make an option
+
+die "Must be in root of the perl source tree.\n"
+ unless -f "./MANIFEST" and -f "patchlevel.h";
+
+open PATCHLEVEL,"<patchlevel.h" or die;
+my @patchlevel_h = <PATCHLEVEL>;
+close PATCHLEVEL;
+my $patchlevel_h = join "", grep { /^#define/ } @patchlevel_h;
+print $patchlevel_h;
+$patchlevel = $1 if $patchlevel_h =~ /PATCHLEVEL\s+(\d+)/;
+$subversion = $1 if $patchlevel_h =~ /SUBVERSION\s+(\d+)/;
+die "Unable to parse patchlevel.h" unless $subversion >= 0;
+$vers = sprintf("5.%03d", $patchlevel);
+$vms_vers = sprintf("5_%03d", $patchlevel);
+if ($subversion) {
+ $vers.= sprintf( "_%02d", $subversion);
+ $vms_vers.= sprintf( "%02d", $subversion);
+} else {
+ $vms_vers.= " ";
+}
+
+# fetch list of local patches
+my (@local_patches, @lpatch_tags, $lpatch_tags);
+@local_patches = grep { /^static.*local_patches/../^};/ } @patchlevel_h;
+@local_patches = grep { !/^\s*,?NULL/ } @local_patches;
+@lpatch_tags = map { /^\s*,"(\w+)/ } @local_patches;
+$lpatch_tags = join "-", @lpatch_tags;
+
+$perl = "perl$vers";
+$reldir = "$perl";
+$reldir .= "-$lpatch_tags" if $lpatch_tags;
+
+print "\nMaking a release for $perl in $relroot/$reldir\n\n";
+
+print "Cross-checking the MANIFEST...\n";
+($missfile, $missentry) = fullcheck();
+warn "Can't make a release with MANIFEST files missing.\n" if @$missfile;
+warn "Can't make a release with files not listed in MANIFEST.\n" if @$missentry;
+if ("@$missentry" =~ m/\.orig\b/) {
+ # Handy listing of find command and .orig files from patching work.
+ # I tend to run 'xargs rm' and copy and paste the file list.
+ my $cmd = "find . -name '*.orig' -print";
+ print "$cmd\n";
+ system($cmd);
+}
+die "Aborted.\n" if @$missentry or @$missfile;
+print "\n";
+
+# VMS no longer has hardcoded version numbers descrip.mms
+#print "Updating VMS version specific files with $vms_vers...\n";
+#system("perl -pi -e 's/^\QPERL_VERSION = \E\d\_\d+(\s*\#)/PERL_VERSION = $vms_vers$1/' vms/descrip.mms");
+
+
+
+print "Creating $relroot/$reldir release directory...\n";
+die "$relroot/$reldir release directory already exists\n" if -e "$relroot/$reldir";
+die "$relroot/$reldir.tar.gz release file already exists\n" if -e "$relroot/$reldir.tar.gz";
+mkdir("$relroot/$reldir", 0755) or die "mkdir $relroot/$reldir: $!\n";
+print "\n";
+
+
+print "Copying files to release directory...\n";
+# ExtUtils::Manifest maniread does not preserve the order
+$cmd = "awk '{print \$1}' MANIFEST | cpio -pdm $relroot/$reldir";
+system($cmd) == 0 or die "$cmd failed";
+print "\n";
+
+chdir "$relroot/$reldir" or die $!;
+
+print "Setting file permissions...\n";
+system("find . -type f -print | xargs chmod -w");
+system("find . -type d -print | xargs chmod g-s");
+system("find t -name '*.t' -print | xargs chmod +x");
+my @exe = qw(
+ Configure
+ configpm
+ embed.pl
+ installperl
+ installman
+ keywords.pl
+ myconfig
+ opcode.pl
+ perly.fixer
+ t/TEST
+ t/*/*.t
+ *.SH
+ vms/ext/Stdio/test.pl
+ vms/ext/filespec.t
+ x2p/*.SH
+ Porting/patchls
+ Porting/makerel
+);
+system("chmod +x @exe");
+
+print "Adding CRs to DOSish files...\n";
+my @crlf = qw(
+ djgpp/configure.bat
+ README.dos
+ README.win32
+ win32/Makefile
+ win32/makefile.mk
+);
+system("perl -pi -e 's/\$/\\r/' @crlf");
+print "\n";
+
+chdir ".." or die $!;
+
+print "Creating and compressing the tar file...\n";
+my $src = (-e $perl) ? $perl : 'perl'; # 'perl' in maint branch
+$cmd = "tar cf - $reldir | gzip --best > $reldir.tar.gz";
+system($cmd) == 0 or die "$cmd failed";
+print "\n";
+
+system("ls -ld $perl*");
diff --git a/contrib/perl5/Porting/p4d2p b/contrib/perl5/Porting/p4d2p
new file mode 100755
index 000000000000..67780a939339
--- /dev/null
+++ b/contrib/perl5/Porting/p4d2p
@@ -0,0 +1,84 @@
+#!/l/local/bin/perl -wspi.bak
+
+#
+# reads a perforce style diff on stdin and outputs appropriate headers
+# so the diff can be applied with the patch program
+#
+# Gurusamy Sarathy <gsar@umich.edu>
+#
+
+BEGIN {
+ $0 =~ s|.*/||;
+ if ($h or $help) {
+ print STDERR <<USAGE;
+Usage: $0 [-v] [-h] files
+
+ -h print this help
+ -v output progress messages
+
+Does inplace edit of diff files output by the perforce commands
+"p4 describe", "p4 diff", and "p4 diff2". The result is suitable
+for feeding to the "patch" program.
+
+If no files are specified, reads from stdin and writes to stdout.
+
+WARNING: It only handles context or unified diffs.
+
+Example: p4 describe -du 123 | $0 > change-123.patch
+
+USAGE
+ exit(0);
+ }
+ unless (@ARGV) { @ARGV = '-'; undef $^I; }
+ use vars qw($thisfile $time $file $fnum $v $h $help);
+ $thisfile = "";
+ $time = localtime(time);
+}
+
+my ($cur, $match);
+$cur = m<^==== //depot/(.+?)\#\d+.* ====$> ... m<^(\@\@.+\@\@|\*+)$>;
+
+$match = $1;
+
+if ($ARGV ne $thisfile) {
+ warn "processing patchfile [$ARGV]\n" unless $ARGV eq '-';
+ $thisfile = $ARGV;
+}
+
+# while we are within range
+if ($cur) {
+ # set the file name after first line
+ if ($cur == 1) {
+ $file = $match;
+ $fnum++;
+ }
+ # emit the diff header when we hit last line
+ elsif ($cur =~ /E0$/) {
+ my $f = $file;
+
+ # special hack for perl so we can always use "patch -p1"
+ $f =~ s<^.*?(perl.*?/)><$1>;
+
+ # unified diff
+ if ($match =~ /^\@/) {
+ warn "emitting udiff header\n" if $v;
+ $_ = "Index: $f\n--- $f.~1~\t$time\n+++ $f\t$time\n$_";
+ }
+ # context diff
+ elsif ($match =~ /^\*/) {
+ warn "emitting cdiff header\n" if $v;
+ $_ = "Index: $f\n*** $f.~1~\t$time\n--- $f\t$time\n$_";
+ }
+ }
+ # see if we hit another patch (i.e. previous patch was empty)
+ elsif (m<^==== //depot/(.+?)\#\d+.* ====$>) {
+ $file = $match = $1;
+ }
+ # suppress all other lines in the header
+ else {
+ $_ = "";
+ }
+ warn "file [$file] line [$cur] file# [$fnum]\n" if $v;
+}
+
+$_ .= "End of Patch.\n" if eof;
diff --git a/contrib/perl5/Porting/patching.pod b/contrib/perl5/Porting/patching.pod
new file mode 100644
index 000000000000..e3b6188ff716
--- /dev/null
+++ b/contrib/perl5/Porting/patching.pod
@@ -0,0 +1,319 @@
+=head1 Name
+
+patching.pod - Appropriate format for patches to the perl source tree
+
+=head2 Where to get this document
+
+The latest version of this document is available from
+ http://perrin.dimensional.com/perl/perlpatch.html
+
+=head2 How to contribute to this document
+
+You may mail corrections, additions, and suggestions to me
+at dgris@tdrenterprises.com but the preferred method would be
+to follow the instructions set forth in this document and
+submit a patch 8-).
+
+=head1 Description
+
+=head2 Why this document exists
+
+As an open source project Perl relies on patches and contributions from
+its users to continue functioning properly and to root out the inevitable
+bugs. But, some users are unsure as to the I<right> way to prepare a patch
+and end up submitting seriously malformed patches. This makes it very
+difficult for the current maintainer to integrate said patches into their
+distribution. This document sets out usage guidelines for patches in an
+attempt to make everybody's life easier.
+
+=head2 Common problems
+
+The most common problems appear to be patches being mangled by certain
+mailers (I won't name names, but most of these seem to be originating on
+boxes running a certain popular commercial operating system). Other problems
+include patches not rooted in the appropriate place in the directory structure,
+and patches not produced using standard utilities (such as diff).
+
+=head1 Proper Patch Guidelines
+
+=head2 How to prepare your patch
+
+=over 4
+
+=item Creating your patch
+
+First, back up the original files. This can't be stressed enough,
+back everything up _first_.
+
+Also, please create patches against a clean distribution of the perl source.
+This insures that everyone else can apply your patch without clobbering their
+source tree.
+
+=item diff
+
+While individual tastes vary (and are not the point here) patches should
+be created using either C<-u> or C<-c> arguments to diff. These produce,
+respectively, unified diffs (where the changed line appears immediately next
+to the original) and context diffs (where several lines surrounding the changes
+are included). See the manpage for diff for more details.
+
+Also, the preferred method for patching is -
+
+C<diff [C<-c> | C<-u>] E<lt>old-fileE<gt> E<lt>new-fileE<gt>>
+
+Note the order of files.
+
+Also, if your patch is to the core (rather than to a module) it
+is better to create it as a context diff as some machines have
+broken patch utilities that choke on unified diffs.
+
+GNU diff has many desirable features not provided by most vendor-supplied
+diffs. Some examples using GNU diff:
+
+ # generate a patch for a newly added file
+ % diff -u /dev/null new/file
+
+ # generate a patch to remove a file (patch > v2.4 will remove it cleanly)
+ % diff -u old/goner /dev/null
+
+ # get additions, deletions along with everything else, recursively
+ % diff -ruN olddir newdir
+
+ # ignore whitespace
+ % diff -bu a/file b/file
+
+ # show function name in every hunk (safer, more informative)
+ % diff -u -F '^[_a-zA-Z0-9]+ *(' old/file new/file
+
+
+=item Directories
+
+Patches should be generated from the source root directory, not from the
+directory that the patched file resides in. This insures that the maintainer
+patches the proper file and avoids name collisions (especially common when trying
+to apply patches to files that appear in both $src_root/ext/* and $src_root/lib/*).
+It is better to diff the file in $src_root/ext than the file in $src_root/lib.
+
+=item Filenames
+
+The most usual convention when submitting patches for a single file is to make
+your changes to a copy of the file with the same name as the original. Rename
+the original file in such a way that it is obvious what is being patched ($file~ or
+$file.old seem to be popular).
+
+If you are submitting patches that affect multiple files then you should backup
+the entire directory tree (to $source_root.old/ for example). This will allow
+C<diff C<-c> E<lt>old-dirE<gt> E<lt>new-dirE<gt>> to create all the patches
+at once.
+
+=back
+
+=head2 What to include in your patch
+
+=over 4
+
+=item Description of problem
+
+The first thing you should include is a description of the problem that
+the patch corrects. If it is a code patch (rather than a documentation
+patch) you should also include a small test case that illustrates the
+bug.
+
+=item Direction for application
+
+You should include instructions on how to properly apply your patch.
+These should include the files affected, any shell scripts or commands
+that need to be run before or after application of the patch, and
+the command line necessary for application.
+
+=item If you have a code patch
+
+If you are submitting a code patch there are several other things that
+you need to do.
+
+=over 4
+
+=item Comments, Comments, Comments
+
+Be sure to adequately comment your code. While commenting every
+line is unnecessary, anything that takes advantage of side effects of
+operators, that creates changes that will be felt outside of the
+function being patched, or that others may find confusing should
+be documented. If you are going to err, it is better to err on the
+side of adding too many comments than too few.
+
+=item Style
+
+Please follow the indentation style and nesting style in use in the
+block of code that you are patching.
+
+=item Testsuite
+
+When submitting a patch you should make every effort to also include
+an addition to perl's regression tests to properly exercise your
+patch. Your testsuite additions should generally follow these
+guidelines (courtesy of Gurusamy Sarathy (gsar@engin.umich.edu))-
+
+ Know what you're testing. Read the docs, and the source.
+ Tend to fail, not succeed.
+ Interpret results strictly.
+ Use unrelated features (this will flush out bizarre interactions).
+ Use non-standard idioms (otherwise you are not testing TIMTOWTDI).
+ Avoid using hardcoded test umbers whenever possible (the EXPECTED/GOT style
+ found in t/op/tie.t is much more maintainable, and gives better failure
+ reports).
+ Give meaningful error messages when a test fails.
+ Avoid using qx// and system() unless you are testing for them. If you
+ do use them, make sure that you cover _all_ perl platforms.
+ Unlink any temporary files you create.
+ Promote unforeseen warnings to errors with $SIG{__WARN__}.
+ Be sure to use the libraries and modules shipped with version being tested,
+ not those that were already installed.
+ Add comments to the code explaining what you are testing for.
+ Make updating the '1..42' string unnecessary. Or make sure that you update it.
+ Test _all_ behaviors of a given operator, library, or function-
+ All optional arguments
+ Return values in various contexts (boolean, scalar, list, lvalue)
+ Use both global and lexical variables
+ Don't forget the exceptional, pathological cases.
+
+=back
+
+=item Test your patch
+
+Apply your patch to a clean distribution, compile, and run the
+regression test suite (you did remember to add one for your
+patch, didn't you).
+
+=back
+
+=head2 An example patch creation
+
+This should work for most patches-
+
+ cp MANIFEST MANIFEST.old
+ emacs MANIFEST
+ (make changes)
+ cd ..
+ diff -c perl5.008_42/MANIFEST.old perl5.008_42/MANIFEST > mypatch
+ (testing the patch:)
+ mv perl5.008_42/MANIFEST perl5.008_42/MANIFEST.new
+ cp perl5.008_42/MANIFEST.old perl5.008_42/MANIFEST
+ patch -p < mypatch
+ (should succeed)
+ diff perl5.008_42/MANIFEST perl5.008_42/MANIFEST.new
+ (should produce no output)
+
+=head2 Submitting your patch
+
+=over 4
+
+=item Mailers
+
+Please, please, please (get the point? 8-) don't use a mailer that
+word wraps your patch or that MIME encodes it. Both of these leave
+the patch essentially worthless to the maintainer.
+
+If you have no choice in mailers and no way to get your hands on a
+better one there is, of course, a perl solution. Just do this-
+
+ perl -ne 'print pack("u*",$_)' patch > patch.uue
+
+and post patch.uue with a note saying to unpack it using
+
+ perl -ne 'print unpack("u*",$_)' patch.uue > patch
+
+=item Subject lines for patches
+
+The subject line on your patch should read
+
+[PATCH]5.xxx_xx (Area) Description
+
+where the x's are replaced by the appropriate version number,
+area is a short keyword identifying what area of perl you are
+patching, and description is a very brief summary of the
+problem (don't forget this is an email header).
+
+Examples-
+
+[PATCH]5.004_04 (DOC) fix minor typos
+
+[PATCH]5.004_99 (CORE) New warning for foo() when frobbing
+
+[PATCH]5.005_42 (CONFIG) Added support for fribnatz 1.5
+
+=item Where to send your patch
+
+If your patch is for the perl core it should be sent perlbug@perl.org.
+If it is a patch to a module that you downloaded from CPAN you should
+submit your patch to that module's author.
+
+=back
+
+=head2 Applying a patch
+
+=over 4
+
+=item General notes on applying patches
+
+The following are some general notes on applying a patch
+to your perl distribution.
+
+=over 4
+
+=item patch C<-p>
+
+It is generally easier to apply patches with the C<-p> argument to
+patch. This helps reconcile differing paths between the machine the
+patch was created on and the machine on which it is being applied.
+
+=item Cut and paste
+
+_Never_ cut and paste a patch into your editor. This usually clobbers
+the tabs and confuses patch.
+
+=item Hand editing patches
+
+Avoid hand editing patches as this frequently screws up the whitespace
+in the patch and confuses the patch program.
+
+=back
+
+=back
+
+=head2 Final notes
+
+If you follow these guidelines it will make everybody's life a little
+easier. You'll have the satisfaction of having contributed to perl,
+others will have an easy time using your work, and it should be easier
+for the maintainers to coordinate the occasionally large numbers of
+patches received.
+
+Also, just because you're not a brilliant coder doesn't mean that you can't
+contribute. As valuable as code patches are there is always a need for better
+documentation (especially considering the general level of joy that most
+programmers feel when forced to sit down and write docs). If all you do
+is patch the documentation you have still contributed more than the person
+who sent in an amazing new feature that noone can use because noone understands
+the code (what I'm getting at is that documentation is both the hardest part to
+do (because everyone hates doing it) and the most valuable).
+
+Mostly, when contributing patches, imagine that it is B<you> receiving hundreds
+of patches and that it is B<your> responsibility to integrate them into the source.
+Obviously you'd want the patches to be as easy to apply as possible. Keep that in
+mind. 8-)
+
+=head1 Last Modified
+
+Last modified 21 May 1998 by Daniel Grisinger <dgris@perrin.dimensional.com>
+
+=head1 Author and Copyright Information
+
+Copyright (c) 1998 Daniel Grisinger
+
+Adapted from a posting to perl5-porters by Tim Bunce (Tim.Bunce@ig.co.uk).
+
+I'd like to thank the perl5-porters for their suggestions.
+
+
+
diff --git a/contrib/perl5/Porting/patchls b/contrib/perl5/Porting/patchls
new file mode 100755
index 000000000000..38c4dd1f473c
--- /dev/null
+++ b/contrib/perl5/Porting/patchls
@@ -0,0 +1,539 @@
+#!/bin/perl -w
+#
+# patchls - patch listing utility
+#
+# Input is one or more patchfiles, output is a list of files to be patched.
+#
+# Copyright (c) 1997 Tim Bunce. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# With thanks to Tom Horsley for the seed code.
+
+
+use Getopt::Std;
+use Text::Wrap qw(wrap $columns);
+use Text::Tabs qw(expand unexpand);
+use strict;
+use vars qw($VERSION);
+
+$VERSION = 2.08;
+
+sub usage {
+die qq{
+ patchls [options] patchfile [ ... ]
+
+ -h no filename headers (like grep), only the listing.
+ -l no listing (like grep), only the filename headers.
+ -i Invert: for each patched file list which patch files patch it.
+ -c Categorise the patch and sort by category (perl specific).
+ -m print formatted Meta-information (Subject,From,Msg-ID etc).
+ -p N strip N levels of directory Prefix (like patch), else automatic.
+ -v more verbose (-d for noisy debugging).
+ -n give a count of the number of patches applied to a file if >1.
+ -f F only list patches which patch files matching regexp F
+ (F has \$ appended unless it contains a /).
+ -e Expect patched files to Exist (relative to current directory)
+ Will print warnings for files which don't. Also affects -4 option.
+ other options for special uses:
+ -I just gather and display summary Information about the patches.
+ -4 write to stdout the PerForce commands to prepare for patching.
+ -5 like -4 but add "|| exit 1" after each command
+ -M T Like -m but only output listed meta tags (eg -M 'Title From')
+ -W N set wrap width to N (defaults to 70, use 0 for no wrap)
+ -X list patchfiles that may clash (i.e. patch the same file)
+
+ patchls version $VERSION by Tim Bunce
+}
+}
+
+$::opt_p = undef; # undef != 0
+$::opt_d = 0;
+$::opt_v = 0;
+$::opt_m = 0;
+$::opt_n = 0;
+$::opt_i = 0;
+$::opt_h = 0;
+$::opt_l = 0;
+$::opt_c = 0;
+$::opt_f = '';
+$::opt_e = 0;
+
+# special purpose options
+$::opt_I = 0;
+$::opt_4 = 0; # output PerForce commands to prepare for patching
+$::opt_5 = 0;
+$::opt_M = ''; # like -m but only output these meta items (-M Title)
+$::opt_W = 70; # set wrap width columns (see Text::Wrap module)
+$::opt_C = 0; # 'Chip' mode (handle from/tags/article/bug files) undocumented
+$::opt_X = 0; # list patchfiles that patch the same file
+
+usage unless @ARGV;
+
+getopts("dmnihlvecC45Xp:f:IM:W:") or usage;
+
+$columns = $::opt_W || 9999999;
+
+$::opt_m = 1 if $::opt_M;
+$::opt_4 = 1 if $::opt_5;
+$::opt_i = 1 if $::opt_X;
+
+# see get_meta_info()
+my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID Files');
+my %show_meta = map { ($_,1) } @show_meta;
+
+my %cat_title = (
+ 'BUILD' => 'BUILD PROCESS',
+ 'CORE' => 'CORE LANGUAGE',
+ 'DOC' => 'DOCUMENTATION',
+ 'LIB' => 'LIBRARY',
+ 'PORT1' => 'PORTABILITY - WIN32',
+ 'PORT2' => 'PORTABILITY - GENERAL',
+ 'TEST' => 'TESTS',
+ 'UTIL' => 'UTILITIES',
+ 'OTHER' => 'OTHER CHANGES',
+ 'EXT' => 'EXTENSIONS',
+ 'UNKNOWN' => 'UNKNOWN - NO FILES PATCH',
+);
+
+
+sub get_meta_info {
+ my $ls = shift;
+ local($_) = shift;
+ if (/^From:\s+(.*\S)/i) {;
+ my $from = $1; # temporary measure for Chip Salzenberg
+ $from =~ s/chip\@(atlantic\.net|perlsupport\.com)/chip\@pobox.com/;
+ $from =~ s/\(Tim Bunce\) \(Tim Bunce\)/(Tim Bunce)/;
+ $ls->{From}{$from} = 1
+ }
+ if (/^Subject:\s+(?:Re: )?(.*\S)/i) {
+ my $title = $1;
+ $title =~ s/\[(PATCH|PERL)[\w\. ]*\]:?//g;
+ $title =~ s/\b(PATCH|PERL)[\w\.]*://g;
+ $title =~ s/\bRe:\s+/ /g;
+ $title =~ s/\s+/ /g;
+ $title =~ s/^\s*(.*?)\s*$/$1/g;
+ $ls->{Title}{$title} = 1;
+ }
+ $ls->{'Msg-ID'}{$1}=1 if /^Message-Id:\s+(.*\S)/i;
+ $ls->{Date}{$1}=1 if /^Date:\s+(.*\S)/i;
+ $ls->{$1}{$2}=1 if $::opt_M && /^([-\w]+):\s+(.*\S)/;
+}
+
+
+# Style 1:
+# *** perl-5.004/embed.h Sat May 10 03:39:32 1997
+# --- perl-5.004.fixed/embed.h Thu May 29 19:48:46 1997
+# ***************
+# *** 308,313 ****
+# --- 308,314 ----
+#
+# 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 (rcs, note the different date format)
+# --- 1.18 1997/05/23 19:22:04
+# +++ ./pod/perlembed.pod 1997/06/03 21:41:38
+#
+# Variation:
+# Index: embed.h
+
+my %ls;
+
+my $in;
+my $ls;
+my $prevline = '';
+my $prevtype = '';
+my (@removed, @added);
+my $prologue = 1; # assume prologue till patch or /^exit\b/ seen
+
+
+foreach my $argv (@ARGV) {
+ $in = $argv;
+ unless (open F, "<$in") {
+ warn "Unable to open $in: $!\n";
+ next;
+ }
+ print "Reading $in...\n" if $::opt_v and @ARGV > 1;
+ $ls = $ls{$in} ||= { is_in => 1, in => $in };
+ my $type;
+ while (<F>) {
+ unless (/^([-+*]{3}) / || /^(Index):/) {
+ # 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+)/;
+ $prologue = 0 if /^exit\b/;
+ }
+ get_meta_info($ls, $_) if $::opt_m;
+ next;
+ }
+ $type = $1;
+ next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/;
+ $prologue = 0;
+
+ print "Last: $prevline","This: ${_}Got: $type\n\n" if $::opt_d;
+
+ # Some patches have Index lines but not diff headers
+ # Patch copes with this, so must we. It's also handy for
+ # documenting manual changes by simply adding Index: lines
+ # to the file which describes the problem being fixed.
+ if (/^Index:\s+(.*)/) {
+ my $f;
+ foreach $f (split(/ /, $1)) { add_file($ls, $f) }
+ next;
+ }
+
+ if ( ($type eq '---' and $prevtype eq '***') # Style 1
+ or ($type eq '+++' and $prevtype eq '---') # Style 2
+ ) {
+ if (/^[-+*]{3} (\S+)\s*(.*?\d\d:\d\d:\d\d)?/) { # double check
+ add_file($ls, $1);
+ }
+ else {
+ warn "$in $.: parse error (prev $prevtype, type $type)\n$prevline$_";
+ }
+ }
+ }
+ continue {
+ $prevline = $_;
+ $prevtype = $type || '';
+ $type = '';
+ }
+
+ # special mode for patch sets from Chip
+ if ($in =~ m:[\\/]patch$:) {
+ my $is_chip;
+ my $chip;
+ my $dir; ($dir = $in) =~ s:[\\/]patch$::;
+ if (!$ls->{From} && (open(CHIP,"$dir/article") || open(CHIP,"$dir/bug"))) {
+ get_meta_info($ls, $_) while (<CHIP>);
+ $is_chip = 1;
+ }
+ if (open CHIP,"<$dir/from") {
+ chop($chip = <CHIP>);
+ $ls->{From} = { $chip => 1 };
+ $is_chip = 1;
+ }
+ if (open CHIP,"<$dir/tag") {
+ chop($chip = <CHIP>);
+ $ls->{Title} = { $chip => 1 };
+ $is_chip = 1;
+ }
+ $ls->{From} = { "Chip Salzenberg" => 1 } if $is_chip && !$ls->{From};
+ }
+
+ # if we don't have a title for -m then use the file name
+ $ls->{Title}{$in}=1 if $::opt_m
+ and !$ls->{Title} and $ls->{out};
+
+ $ls->{category} = $::opt_c
+ ? categorize_files([keys %{ $ls->{out} }], $::opt_v) : '';
+}
+print scalar(@ARGV)." files read.\n" if $::opt_v and @ARGV > 1;
+
+
+# --- Firstly we filter and sort as needed ---
+
+my @ls = values %ls;
+
+if ($::opt_f) { # filter out patches based on -f <regexp>
+ $::opt_f .= '$' unless $::opt_f =~ m:/:;
+ @ls = grep {
+ my $match = 0;
+ if ($_->{is_in}) {
+ my @out = keys %{ $_->{out} };
+ $match=1 if grep { m/$::opt_f/o } @out;
+ }
+ else {
+ $match=1 if $_->{in} =~ m/$::opt_f/o;
+ }
+ $match;
+ } @ls;
+}
+
+@ls = sort {
+ $a->{category} cmp $b->{category} || $a->{in} cmp $b->{in}
+} @ls;
+
+
+# --- Handle special modes ---
+
+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;
+ 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};
+ my @patched = sort keys %patched;
+ foreach(@patched) {
+ my $edit = ($::opt_e && !-f $_) ? "add " : "edit";
+ print "p4 $edit $_$tail\n";
+ }
+ exit 0 unless $::opt_C;
+}
+
+
+if ($::opt_I) {
+ my $n_patches = 0;
+ my($in,$out);
+ my %all_out;
+ my @no_outs;
+ foreach $in (@ls) {
+ next unless $in->{is_in};
+ ++$n_patches;
+ my @outs = keys %{$in->{out}};
+ push @no_outs, $in unless @outs;
+ @all_out{@outs} = ($in->{in}) x @outs;
+ }
+ my @all_out = sort keys %all_out;
+ my @missing = grep { ! -f $_ } @all_out;
+ print "$n_patches patch files patch ".@all_out." files (".@missing." missing)\n";
+ print @no_outs." patch files don't contain patches.\n" if @no_outs;
+ print "(use -v to list patches which patch 'missing' files)\n"
+ if (@missing || @no_outs) && !$::opt_v;
+ if ($::opt_v and @no_outs) {
+ print "Patch files which don't contain patches:\n";
+ foreach $out (@no_outs) {
+ printf " %-20s\n", $out->{in};
+ }
+ }
+ if ($::opt_v and @missing) {
+ print "Missing files:\n";
+ foreach $out (@missing) {
+ printf " %-20s\t", $out unless $::opt_h;
+ print $all_out{$out} unless $::opt_l;
+ print "\n";
+ }
+ }
+ print "Added files: @added\n" if @added;
+ print "Removed files: @removed\n" if @removed;
+ exit 0+@missing;
+}
+
+unless ($::opt_c and $::opt_m) {
+ foreach $ls (@ls) {
+ next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
+ next if $::opt_X and keys %{$ls->{out}} <= 1;
+ list_files_by_patch($ls);
+ }
+}
+else {
+ my $c = '';
+ foreach $ls (@ls) {
+ next unless ($::opt_i) ? $ls->{is_out} : $ls->{is_in};
+ print "\n ------ $cat_title{$ls->{category}} ------\n"
+ if $ls->{category} ne $c;
+ $c = $ls->{category};
+ unless ($::opt_i) {
+ list_files_by_patch($ls);
+ }
+ else {
+ my $out = $ls->{in};
+ print "\n$out patched by:\n";
+ # find all the patches which patch $out and list them
+ my @p = grep { $_->{out}->{$out} } values %ls;
+ foreach $ls (@p) {
+ list_files_by_patch($ls, '');
+ }
+ }
+ }
+ print "\n";
+}
+
+exit 0;
+
+
+# ---
+
+
+sub add_file {
+ my $ls = shift;
+ print "add_file '$_[0]'\n" if $::opt_d;
+ my $out = trim_name(shift);
+
+ $ls->{out}->{$out} = 1;
+
+ warn "$out patched but not present\n" if $::opt_e && !-f $out;
+
+ # do the -i inverse as well, even if we're not doing -i
+ my $i = $ls{$out} ||= {
+ is_out => 1,
+ in => $out,
+ category => $::opt_c ? categorize_files([ $out ], $::opt_v) : '',
+ };
+ $i->{out}->{$in} = 1;
+}
+
+
+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) {
+ # strip on -p levels of directory prefix
+ my $dc = $::opt_p;
+ $name =~ s:^[^/]+/(.+)$:$1: while $dc-- > 0;
+ }
+ 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:^\./::;
+ }
+ return $name;
+}
+
+
+sub list_files_by_patch {
+ my($ls, $name) = @_;
+ $name = $ls->{in} unless defined $name;
+ my @meta;
+ if ($::opt_m) {
+ my $meta;
+ foreach $meta (@show_meta) {
+ next unless $ls->{$meta};
+ my @list = sort keys %{$ls->{$meta}};
+ push @meta, sprintf "%7s: ", $meta;
+ if ($meta eq 'Title') {
+ @list = map { "\"$_\""; } @list;
+ push @list, "#$1" if $::opt_C && $ls->{in} =~ m:\b(\w\d+)/patch$:;
+ }
+ elsif ($meta eq 'From') {
+ # fix-up bizzare addresses from japan and ibm :-)
+ foreach(@list) {
+ s:\W+=?iso.*?<: <:;
+ s/\d\d-\w\w\w-\d{4}\s+\d\d:\S+\s*//;
+ }
+ }
+ elsif ($meta eq 'Msg-ID') {
+ my %from; # limit long threads to one msg-id per site
+ @list = map {
+ $from{(/@(.*?)>/ ? $1 : $_)}++ ? () : ($_);
+ } @list;
+ }
+ push @meta, my_wrap(""," ", join(", ",@list)."\n");
+ }
+ $name = "\n$name" if @meta and $name;
+ }
+ # don't print the header unless the file contains something interesting
+ return if !@meta and !$ls->{out} and !$::opt_v;
+ if ($::opt_l) { # -l = no listing, just names
+ print "$ls->{in}";
+ my $n = keys %{ $ls->{out} };
+ print " ($n patches)" if $::opt_n and $n>1;
+ print "\n";
+ return;
+ }
+
+ # 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;
+
+ return if $::opt_m && !$show_meta{Files};
+ my @v = sort PATORDER keys %{ $ls->{out} };
+ my $n = @v;
+ my $v = "@v";
+ print $::opt_m ? " Files: ".my_wrap(""," ",$v) : $v;
+ print " ($n patches)" if $::opt_n and $n>1;
+ print "\n";
+}
+
+
+sub my_wrap {
+ my $txt = eval { expand(wrap(@_)) }; # die's on long lines!
+ return $txt unless $@;
+ return expand("@_");
+}
+
+
+
+sub categorize_files {
+ my($files, $verb) = @_;
+ my(%c, $refine);
+
+ foreach (@$files) { # assign a score to a file path
+ # the order of some of the tests is important
+ $c{TEST} += 5,next if m:^t/:;
+ $c{DOC} += 5,next if m:^pod/:;
+ $c{UTIL} += 10,next if m:^(utils|x2p|h2pl)/:;
+ $c{PORT1}+= 15,next if m:^win32:;
+ $c{PORT2} += 15,next
+ if m:^(cygwin32|os2|plan9|qnx|vms)/:
+ or m:^(hints|Porting|ext/DynaLoader)/:
+ or m:^README\.:;
+ $c{EXT} += 10,next
+ if m:^(ext|lib/ExtUtils)/:;
+ $c{LIB} += 10,next
+ if m:^(lib)/:;
+ $c{'CORE'} += 15,next
+ if m:^[^/]+[\._]([chH]|sym|pl)$:;
+ $c{BUILD} += 10,next
+ if m:^[A-Z]+$: or m:^[^/]+\.SH$:
+ or m:^(install|configure|configpm):i;
+ print "Couldn't categorise $_\n" if $::opt_v;
+ $c{OTHER} += 1;
+ }
+ if (keys %c > 1) { # sort to find category with highest score
+ refine:
+ ++$refine;
+ my @c = sort { $c{$b} <=> $c{$a} || $a cmp $b } keys %c;
+ my @v = map { $c{$_} } @c;
+ if (@v > 1 and $refine <= 1 and "@v" =~ /^(\d) \1/
+ and $c[0] =~ m/^(DOC|TESTS|OTHER)/) { # rare
+ print "Tie, promoting $c[1] over $c[0]\n" if $::opt_d;
+ ++$c{$c[1]};
+ goto refine;
+ }
+ print " ".@$files." patches: ", join(", ", map { "$_: $c{$_}" } @c),".\n"
+ if $verb;
+ return $c[0] || 'OTHER';
+ }
+ else {
+ my($c, $v) = %c;
+ $c ||= 'UNKNOWN'; $v ||= 0;
+ print " ".@$files." patches: $c: $v\n" if $verb;
+ return $c;
+ }
+}
+
+
+sub PATORDER { # PATORDER sort by Chip Salzenberg
+ my ($i, $j);
+
+ $i = ($a =~ m#^[A-Z]+$#);
+ $j = ($b =~ m#^[A-Z]+$#);
+ return $j - $i if $i != $j;
+
+ $i = ($a =~ m#configure|hint#i) || ($a =~ m#[S_]H$#);
+ $j = ($b =~ m#configure|hint#i) || ($b =~ m#[S_]H$#);
+ return $j - $i if $i != $j;
+
+ $i = ($a =~ m#\.pod$#);
+ $j = ($b =~ m#\.pod$#);
+ return $j - $i if $i != $j;
+
+ $i = ($a =~ m#include/#);
+ $j = ($b =~ m#include/#);
+ return $j - $i if $i != $j;
+
+ if ((($i = $a) =~ s#/+[^/]*$##)
+ && (($j = $b) =~ s#/+[^/]*$##)) {
+ return $i cmp $j if $i ne $j;
+ }
+
+ $i = ($a =~ m#\.h$#);
+ $j = ($b =~ m#\.h$#);
+ return $j - $i if $i != $j;
+
+ return $a cmp $b;
+}
+
diff --git a/contrib/perl5/Porting/pumpkin.pod b/contrib/perl5/Porting/pumpkin.pod
new file mode 100644
index 000000000000..f41dfaca1a72
--- /dev/null
+++ b/contrib/perl5/Porting/pumpkin.pod
@@ -0,0 +1,1313 @@
+=head1 NAME
+
+Pumpkin - Notes on handling the Perl Patch Pumpkin
+
+=head1 SYNOPSIS
+
+There is no simple synopsis, yet.
+
+=head1 DESCRIPTION
+
+This document attempts to begin to describe some of the
+considerations involved in patching and maintaining perl.
+
+This document is still under construction, and still subject to
+significant changes. Still, I hope parts of it will be useful,
+so I'm releasing it even though it's not done.
+
+For the most part, it's a collection of anecdotal information that
+already assumes some familiarity with the Perl sources. I really need
+an introductory section that describes the organization of the sources
+and all the various auxiliary files that are part of the distribution.
+
+=head1 Where Do I Get Perl Sources and Related Material?
+
+The Comprehensive Perl Archive Network (or CPAN) is the place to go.
+There are many mirrors, but the easiest thing to use is probably
+http://www.perl.com/CPAN/README.html , which automatically points you to a
+mirror site "close" to you.
+
+=head2 Perl5-porters mailing list
+
+The mailing list perl5-porters@perl.org
+is the main group working with the development of perl. If you're
+interested in all the latest developments, you should definitely
+subscribe. The list is high volume, but generally has a
+fairly low noise level.
+
+Subscribe by sending the message (in the body of your letter)
+
+ subscribe perl5-porters
+
+to perl5-porters-request@perl.org .
+
+Archives of the list are held at:
+
+ http://www.rosat.mpe-garching.mpg.de/mailing-lists/perl-porters/
+
+=head1 How are Perl Releases Numbered?
+
+Perl version numbers are floating point numbers, such as 5.004.
+(Observations about the imprecision of floating point numbers for
+representing reality probably have more relevance than you might
+imagine :-) The major version number is 5 and the '004' is the
+patchlevel. (Questions such as whether or not '004' is really a minor
+version number can safely be ignored.:)
+
+The version number is available as the magic variable $],
+and can be used in comparisons, e.g.
+
+ print "You've got an old perl\n" if $] < 5.002;
+
+You can also require particular version (or later) with
+
+ use 5.002;
+
+At some point in the future, we may need to decide what to call the
+next big revision. In the .package file used by metaconfig to
+generate Configure, there are two variables that might be relevant:
+$baserev=5.0 and $package=perl5. At various times, I have suggested
+we might change them to $baserev=5.1 and $package=perl5.1 if want
+to signify a fairly major update. Or, we might want to jump to perl6.
+Let's worry about that problem when we get there.
+
+=head2 Subversions
+
+In addition, there may be "developer" sub-versions available. These
+are not official releases. They may contain unstable experimental
+features, and are subject to rapid change. Such developer
+sub-versions are numbered with sub-version numbers. For example,
+version 5.003_04 is the 4'th developer version built on top of
+5.003. It might include the _01, _02, and _03 changes, but it
+also might not. Sub-versions are allowed to be subversive. (But see
+the next section for recent changes.)
+
+These sub-versions can also be used as floating point numbers, so
+you can do things such as
+
+ print "You've got an unstable perl\n" if $] == 5.00303;
+
+You can also require particular version (or later) with
+
+ use 5.003_03; # the "_" is optional
+
+Sub-versions produced by the members of perl5-porters are usually
+available on CPAN in the F<src/5.0/unsupported> directory.
+
+=head2 Maintenance and Development Subversions
+
+As an experiment, starting with version 5.004, subversions _01 through
+_49 will be reserved for bug-fix maintenance releases, and subversions
+_50 through _99 will be available for unstable development versions.
+
+The separate bug-fix track is being established to allow us an easy
+way to distribute important bug fixes without waiting for the
+developers to untangle all the other problems in the current
+developer's release.
+
+Trial releases of bug-fix maintenance releases are announced on
+perl5-porters. Trial releases use the new subversion number (to avoid
+testers installing it over the previous release) and include a 'local
+patch' entry in patchlevel.h.
+
+Watch for announcements of maintenance subversions in
+comp.lang.perl.announce.
+
+The first rule of maintenance work is "First, do no harm."
+
+=head2 Why such a complicated scheme?
+
+Two reasons, really. At least.
+
+First, we need some way to identify and release collections of patches
+that are known to have new features that need testing and exploration. The
+subversion scheme does that nicely while fitting into the
+C<use 5.004;> mold.
+
+Second, since most of the folks who help maintain perl do so on a
+free-time voluntary basis, perl development does not proceed at a
+precise pace, though it always seems to be moving ahead quickly.
+We needed some way to pass around the "patch pumpkin" to allow
+different people chances to work on different aspects of the
+distribution without getting in each other's way. It wouldn't be
+constructive to have multiple people working on incompatible
+implementations of the same idea. Instead what was needed was
+some kind of "baton" or "token" to pass around so everyone knew
+whose turn was next.
+
+=head2 Why is it called the patch pumpkin?
+
+Chip Salzenberg gets credit for that, with a nod to his cow orker,
+David Croy. We had passed around various names (baton, token, hot
+potato) but none caught on. Then, Chip asked:
+
+[begin quote]
+
+ Who has the patch pumpkin?
+
+To explain: David Croy once told me once that at a previous job,
+there was one tape drive and multiple systems that used it for backups.
+But instead of some high-tech exclusion software, they used a low-tech
+method to prevent multiple simultaneous backups: a stuffed pumpkin.
+No one was allowed to make backups unless they had the "backup pumpkin".
+
+[end quote]
+
+The name has stuck.
+
+=head1 Philosophical Issues in Patching Perl
+
+There are no absolute rules, but there are some general guidelines I
+have tried to follow as I apply patches to the perl sources.
+(This section is still under construction.)
+
+=head2 Solve problems as generally as possible
+
+Never implement a specific restricted solution to a problem when you
+can solve the same problem in a more general, flexible way.
+
+For example, for dynamic loading to work on some SVR4 systems, we had
+to build a shared libperl.so library. In order to build "FAT" binaries
+on NeXT 4.0 systems, we had to build a special libperl library. Rather
+than continuing to build a contorted nest of special cases, I
+generalized the process of building libperl so that NeXT and SVR4 users
+could still get their work done, but others could build a shared
+libperl if they wanted to as well.
+
+=head2 Seek consensus on major changes
+
+If you are making big changes, don't do it in secret. Discuss the
+ideas in advance on perl5-porters.
+
+=head2 Keep the documentation up-to-date
+
+If your changes may affect how users use perl, then check to be sure
+that the documentation is in sync with your changes. Be sure to
+check all the files F<pod/*.pod> and also the F<INSTALL> document.
+
+Consider writing the appropriate documentation first and then
+implementing your change to correspond to the documentation.
+
+=head2 Avoid machine-specific #ifdef's
+
+To the extent reasonable, try to avoid machine-specific #ifdef's in
+the sources. Instead, use feature-specific #ifdef's. The reason is
+that the machine-specific #ifdef's may not be valid across major
+releases of the operating system. Further, the feature-specific tests
+may help out folks on another platform who have the same problem.
+
+=head2 Allow for lots of testing
+
+We should never release a main version without testing it as a
+subversion first.
+
+=head2 Test popular applications and modules.
+
+We should never release a main version without testing whether or not
+it breaks various popular modules and applications. A partial list of
+such things would include majordomo, metaconfig, apache, Tk, CGI,
+libnet, and libwww, to name just a few. Of course it's quite possible
+that some of those things will be just plain broken and need to be fixed,
+but, in general, we ought to try to avoid breaking widely-installed
+things.
+
+=head2 Automate generation of derivative files
+
+The F<embed.h>, F<keywords.h>, F<opcode.h>, and F<perltoc.pod> files
+are all automatically generated by perl scripts. In general, don't
+patch these directly; patch the data files instead.
+
+F<Configure> and F<config_h.SH> are also automatically generated by
+B<metaconfig>. In general, you should patch the metaconfig units
+instead of patching these files directly. However, very minor changes to
+F<Configure> may be made in between major sync-ups with the metaconfig
+units, which tends to be complicated operations. But be careful, this
+can quickly spiral out of control. Running metaconfig is not really
+hard.
+
+Finally, the sample files in the F<Porting/> subdirectory are
+generated automatically by the script F<U/mksample> included
+with the metaconfig units. See L<"run metaconfig"> below for
+information on obtaining the metaconfig units.
+
+=head1 How to Make a Distribution
+
+There really ought to be a 'make dist' target, but there isn't.
+The 'dist' suite of tools also contains a number of tools that I haven't
+learned how to use yet. Some of them may make this all a bit easier.
+
+Here are the steps I go through to prepare a patch & distribution.
+
+Lots of it could doubtless be automated but isn't. The Porting/makerel
+(make release) perl script does now help automate some parts of it.
+
+=head2 Announce your intentions
+
+First, you should volunteer out loud to take the patch pumpkin. It's
+generally counter-productive to have multiple people working in secret
+on the same thing.
+
+At the same time, announce what you plan to do with the patch pumpkin,
+to allow folks a chance to object or suggest alternatives, or do it for
+you. Naturally, the patch pumpkin holder ought to incorporate various
+bug fixes and documentation improvements that are posted while he or
+she has the pumpkin, but there might also be larger issues at stake.
+
+One of the precepts of the subversion idea is that we shouldn't give
+the patch pumpkin to anyone unless we have some idea what he or she
+is going to do with it.
+
+=head2 refresh pod/perltoc.pod
+
+Presumably, you have done a full C<make> in your working source
+directory. Before you C<make spotless> (if you do), and if you have
+changed any documentation in any module or pod file, change to the
+F<pod> directory and run C<make toc>.
+
+=head2 run installhtml to check the validity of the pod files
+
+=head2 update patchlevel.h
+
+Don't be shy about using the subversion number, even for a relatively
+modest patch. We've never even come close to using all 99 subversions,
+and it's better to have a distinctive number for your patch. If you
+need feedback on your patch, go ahead and issue it and promise to
+incorporate that feedback quickly (e.g. within 1 week) and send out a
+second patch.
+
+=head2 run metaconfig
+
+If you need to make changes to Configure or config_h.SH, it may be best to
+change the appropriate metaconfig units instead, and regenerate Configure.
+
+ metaconfig -m
+
+will regenerate Configure and config_h.SH. Much more information
+on obtaining and running metaconfig is in the F<U/README> file
+that comes with Perl's metaconfig units. Perl's metaconfig units
+should be available on CPAN. A set of units that will work with
+perl5.005 is in the file F<mc_units-5.005_00-01.tar.gz> under
+http://www.perl.com/CPAN/authors/id/ANDYD/ . The mc_units tar file
+should be unpacked in your main perl source directory. Note: those
+units were for use with 5.005. There may have been changes since then.
+Check for later versions or contact perl5-porters@perl.org to obtain a
+pointer to the current version.
+
+Alternatively, do consider if the F<*ish.h> files might be a better
+place for your changes.
+
+=head2 MANIFEST
+
+Make sure the MANIFEST is up-to-date. You can use dist's B<manicheck>
+program for this. You can also use
+
+ perl -w -MExtUtils::Manifest=fullcheck -e fullcheck
+
+Both commands will also list extra files in the directory that are not
+listed in MANIFEST.
+
+The MANIFEST is normally sorted.
+
+If you are using metaconfig to regenerate Configure, then you should note
+that metaconfig actually uses MANIFEST.new, so you want to be sure
+MANIFEST.new is up-to-date too. I haven't found the MANIFEST/MANIFEST.new
+distinction particularly useful, but that's probably because I still haven't
+learned how to use the full suite of tools in the dist distribution.
+
+=head2 Check permissions
+
+All the tests in the t/ directory ought to be executable. The
+main makefile used to do a 'chmod t/*/*.t', but that resulted in
+a self-modifying distribution--something some users would strongly
+prefer to avoid. The F<t/TEST> script will check for this
+and do the chmod if needed, but the tests still ought to be
+executable.
+
+In all, the following files should probably be executable:
+
+ Configure
+ configpm
+ configure.gnu
+ embed.pl
+ installperl
+ installman
+ keywords.pl
+ myconfig
+ opcode.pl
+ perly.fixer
+ t/TEST
+ t/*/*.t
+ *.SH
+ vms/ext/Stdio/test.pl
+ vms/ext/filespec.t
+ x2p/*.SH
+
+Other things ought to be readable, at least :-).
+
+Probably, the permissions for the files could be encoded in MANIFEST
+somehow, but I'm reluctant to change MANIFEST itself because that
+could break old scripts that use MANIFEST.
+
+I seem to recall that some SVR3 systems kept some sort of file that listed
+permissions for system files; something like that might be appropriate.
+
+=head2 Run Configure
+
+This will build a config.sh and config.h. You can skip this if you haven't
+changed Configure or config_h.SH at all. I use the following command
+
+ sh Configure -Dprefix=/opt/perl -Doptimize=-O -Dusethreads \
+ -Dcf_by='yourname' \
+ -Dcf_email='yourname@yourhost.yourplace.com' \
+ -Dperladmin='yourname@yourhost.yourplace.com' \
+ -Dmydomain='.yourplace.com' \
+ -Dmyhostname='yourhost' \
+ -des
+
+=head2 Update Porting/config.sh and Porting/config_H
+
+[XXX
+This section needs revision. We're currently working on easing
+the task of keeping the vms, win32, and plan9 config.sh info
+up-to-date. The plan is to use keep up-to-date 'canned' config.sh
+files in the appropriate subdirectories and then generate 'canned'
+config.h files for vms, win32, etc. from the generic config.sh file.
+This is to ease maintenance. When Configure gets updated, the parts
+sometimes get scrambled around, and the changes in config_H can
+sometimes be very hard to follow. config.sh, on the other hand, can
+safely be sorted, so it's easy to track (typically very small) changes
+to config.sh and then propoagate them to a canned 'config.h' by any
+number of means, including a perl script in win32/ or carrying
+config.sh and config_h.SH to a Unix system and running sh
+config_h.SH.)
+XXX]
+
+The Porting/config.sh and Porting/config_H files are provided to
+help those folks who can't run Configure. It is important to keep
+them up-to-date. If you have changed config_h.SH, those changes must
+be reflected in config_H as well. (The name config_H was chosen to
+distinguish the file from config.h even on case-insensitive file systems.)
+Simply edit the existing config_H file; keep the first few explanatory
+lines and then copy your new config.h below.
+
+It may also be necessary to update win32/config.?c, vms/config.vms and
+plan9/config.plan9, though you should be quite careful in doing so if
+you are not familiar with those systems. You might want to issue your
+patch with a promise to quickly issue a follow-up that handles those
+directories.
+
+=head2 make run_byacc
+
+If you have byacc-1.8.2 (available from CPAN), and if there have been
+changes to F<perly.y>, you can regenerate the F<perly.c> file. The
+run_byacc makefile target does this by running byacc and then applying
+some patches so that byacc dynamically allocates space, rather than
+having fixed limits. This patch is handled by the F<perly.fixer>
+script. Depending on the nature of the changes to F<perly.y>, you may
+or may not have to hand-edit the patch to apply correctly. If you do,
+you should include the edited patch in the new distribution. If you
+have byacc-1.9, the patch won't apply cleanly. Changes to the printf
+output statements mean the patch won't apply cleanly. Long ago I
+started to fix F<perly.fixer> to detect this, but I never completed the
+task.
+
+Some additional notes from Larry on this:
+
+Don't forget to regenerate perly_c.diff.
+
+ byacc -d perly.y
+ mv y.tab.c perly.c
+ patch perly.c <perly_c.diff
+ # manually apply any failed hunks
+ diff -c2 perly.c.orig perly.c >perly_c.diff
+
+One chunk of lines that often fails begins with
+
+ #line 29 "perly.y"
+
+and ends one line before
+
+ #define YYERRCODE 256
+
+This only happens when you add or remove a token type. I suppose this
+could be automated, but it doesn't happen very often nowadays.
+
+Larry
+
+=head2 make regen_headers
+
+The F<embed.h>, F<keywords.h>, and F<opcode.h> files are all automatically
+generated by perl scripts. Since the user isn't guaranteed to have a
+working perl, we can't require the user to generate them. Hence you have
+to, if you're making a distribution.
+
+I used to include rules like the following in the makefile:
+
+ # The following three header files are generated automatically
+ # The correct versions should be already supplied with the perl kit,
+ # in case you don't have perl or 'sh' available.
+ # The - is to ignore error return codes in case you have the source
+ # installed read-only or you don't have perl yet.
+ keywords.h: keywords.pl
+ @echo "Don't worry if this fails."
+ - perl keywords.pl
+
+
+However, I got B<lots> of mail consisting of people worrying because the
+command failed. I eventually decided that I would save myself time
+and effort by manually running C<make regen_headers> myself rather
+than answering all the questions and complaints about the failing
+command.
+
+=head2 global.sym, interp.sym and perlio.sym
+
+Make sure these files are up-to-date. Read the comments in these
+files and in perl_exp.SH to see what to do.
+
+=head2 Binary compatibility
+
+If you do change F<global.sym> or F<interp.sym>, think carefully about
+what you are doing. To the extent reasonable, we'd like to maintain
+souce and binary compatibility with older releases of perl. That way,
+extensions built under one version of perl will continue to work with
+new versions of perl.
+
+Of course, some incompatible changes may well be necessary. I'm just
+suggesting that we not make any such changes without thinking carefully
+about them first. If possible, we should provide
+backwards-compatibility stubs. There's a lot of XS code out there.
+Let's not force people to keep changing it.
+
+=head2 Changes
+
+Be sure to update the F<Changes> file. Try to include both an overall
+summary as well as detailed descriptions of the changes. Your
+audience will include other developers and users, so describe
+user-visible changes (if any) in terms they will understand, not in
+code like "initialize foo variable in bar function".
+
+There are differing opinions on whether the detailed descriptions
+ought to go in the Changes file or whether they ought to be available
+separately in the patch file (or both). There is no disagreement that
+detailed descriptions ought to be easily available somewhere.
+
+=head2 Todo
+
+The F<Todo> file contains a roughly-catgorized unordered list of
+aspects of Perl that could use enhancement, features that could be
+added, areas that could be cleaned up, and so on. During your term as
+pumpkin-holder, you will probably address some of these issues, and
+perhaps identify others which, while you decide not to address them
+this time around, may be tackled in the future. Update the file
+reflect the situation as it stands when you hand over the pumpkin.
+
+You might like, early in your pumpkin-holding career, to see if you
+can find champions for partiticular issues on the to-do list: an issue
+owned is an issue more likely to be resolved.
+
+There are also some more porting-specific L<Todo> items later in this
+file.
+
+=head2 OS/2-specific updates
+
+In the os2 directory is F<diff.configure>, a set of OS/2-specific
+diffs against B<Configure>. If you make changes to Configure, you may
+want to consider regenerating this diff file to save trouble for the
+OS/2 maintainer.
+
+You can also consider the OS/2 diffs as reminders of portability
+things that need to be fixed in Configure.
+
+=head2 VMS-specific updates
+
+If you have changed F<perly.y>, then you may want to update
+F<vms/perly_{h,c}.vms> by running C<perl vms/vms_yfix.pl>.
+
+The Perl version number appears in several places under F<vms>.
+It is courteous to update these versions. For example, if you are
+making 5.004_42, replace "5.00441" with "5.00442".
+
+=head2 Making the new distribution
+
+Suppose, for example, that you want to make version 5.004_08. Then you can
+do something like the following
+
+ mkdir ../perl5.004_08
+ awk '{print $1}' MANIFEST | cpio -pdm ../perl5.004_08
+ cd ../
+ tar cf perl5.004_08.tar perl5.004_08
+ gzip --best perl5.004_08.tar
+
+These steps, with extra checks, are automated by the Porting/makerel
+script.
+
+=head2 Making a new patch
+
+I find the F<makepatch> utility quite handy for making patches.
+You can obtain it from any CPAN archive under
+http://www.perl.com/CPAN/authors/Johan_Vromans/ . There are a couple
+of differences between my version and the standard one. I have mine do
+a
+
+ # Print a reassuring "End of Patch" note so people won't
+ # wonder if their mailer truncated patches.
+ print "\n\nEnd of Patch.\n";
+
+at the end. That's because I used to get questions from people asking
+if their mail was truncated.
+
+It also writes Index: lines which include the new directory prefix
+(change Index: print, approx line 294 or 310 depending on the version,
+to read: print PATCH ("Index: $newdir$new\n");). That helps patches
+work with more POSIX conformant patch programs.
+
+Here's how I generate a new patch. I'll use the hypothetical
+5.004_07 to 5.004_08 patch as an example.
+
+ # unpack perl5.004_07/
+ gzip -d -c perl5.004_07.tar.gz | tar -xof -
+ # unpack perl5.004_08/
+ gzip -d -c perl5.004_08.tar.gz | tar -xof -
+ makepatch perl5.004_07 perl5.004_08 > perl5.004_08.pat
+
+Makepatch will automatically generate appropriate B<rm> commands to remove
+deleted files. Unfortunately, it will not correctly set permissions
+for newly created files, so you may have to do so manually. For example,
+patch 5.003_04 created a new test F<t/op/gv.t> which needs to be executable,
+so at the top of the patch, I inserted the following lines:
+
+ # Make a new test
+ touch t/op/gv.t
+ chmod +x t/opt/gv.t
+
+Now, of course, my patch is now wrong because makepatch didn't know I
+was going to do that command, and it patched against /dev/null.
+
+So, what I do is sort out all such shell commands that need to be in the
+patch (including possible mv-ing of files, if needed) and put that in the
+shell commands at the top of the patch. Next, I delete all the patch parts
+of perl5.004_08.pat, leaving just the shell commands. Then, I do the
+following:
+
+ cd perl5.004_07
+ sh ../perl5.004_08.pat
+ cd ..
+ makepatch perl5.004_07 perl5.004_08 >> perl5.004_08.pat
+
+(Note the append to preserve my shell commands.)
+Now, my patch will line up with what the end users are going to do.
+
+=head2 Testing your patch
+
+It seems obvious, but be sure to test your patch. That is, verify that
+it produces exactly the same thing as your full distribution.
+
+ rm -rf perl5.004_07
+ gzip -d -c perl5.004_07.tar.gz | tar -xf -
+ cd perl5.004_07
+ sh ../perl5.004_08.pat
+ patch -p1 -N < ../perl5.004_08.pat
+ cd ..
+ gdiff -r perl5.004_07 perl5.004_08
+
+where B<gdiff> is GNU diff. Other diff's may also do recursive checking.
+
+=head2 More testing
+
+Again, it's obvious, but you should test your new version as widely as you
+can. You can be sure you'll hear about it quickly if your version doesn't
+work on both ANSI and pre-ANSI compilers, and on common systems such as
+SunOS 4.1.[34], Solaris, and Linux.
+
+If your changes include conditional code, try to test the different
+branches as thoroughly as you can. For example, if your system
+supports dynamic loading, you can also test static loading with
+
+ sh Configure -Uusedl
+
+You can also hand-tweak your config.h to try out different #ifdef
+branches.
+
+=head1 Common Gotcha's
+
+=over 4
+
+=item #elif
+
+The '#elif' preprocessor directive is not understood on all systems.
+Specifically, I know that Pyramids don't understand it. Thus instead of the
+simple
+
+ #if defined(I_FOO)
+ # include <foo.h>
+ #elif defined(I_BAR)
+ # include <bar.h>
+ #else
+ # include <fubar.h>
+ #endif
+
+You have to do the more Byzantine
+
+ #if defined(I_FOO)
+ # include <foo.h>
+ #else
+ # if defined(I_BAR)
+ # include <bar.h>
+ # else
+ # include <fubar.h>
+ # endif
+ #endif
+
+Incidentally, whitespace between the leading '#' and the preprocessor
+command is not guaranteed, but is very portable and you may use it freely.
+I think it makes things a bit more readable, especially once things get
+rather deeply nested. I also think that things should almost never get
+too deeply nested, so it ought to be a moot point :-)
+
+=item Probably Prefer POSIX
+
+It's often the case that you'll need to choose whether to do
+something the BSD-ish way or the POSIX-ish way. It's usually not
+a big problem when the two systems use different names for similar
+functions, such as memcmp() and bcmp(). The perl.h header file
+handles these by appropriate #defines, selecting the POSIX mem*()
+functions if available, but falling back on the b*() functions, if
+need be.
+
+More serious is the case where some brilliant person decided to
+use the same function name but give it a different meaning or
+calling sequence :-). getpgrp() and setpgrp() come to mind.
+These are a real problem on systems that aim for conformance to
+one standard (e.g. POSIX), but still try to support the other way
+of doing things (e.g. BSD). My general advice (still not really
+implemented in the source) is to do something like the following.
+Suppose there are two alternative versions, fooPOSIX() and
+fooBSD().
+
+ #ifdef HAS_FOOPOSIX
+ /* use fooPOSIX(); */
+ #else
+ # ifdef HAS_FOOBSD
+ /* try to emulate fooPOSIX() with fooBSD();
+ perhaps with the following: */
+ # define fooPOSIX fooBSD
+ # else
+ # /* Uh, oh. We have to supply our own. */
+ # define fooPOSIX Perl_fooPOSIX
+ # endif
+ #endif
+
+=item Think positively
+
+If you need to add an #ifdef test, it is usually easier to follow if you
+think positively, e.g.
+
+ #ifdef HAS_NEATO_FEATURE
+ /* use neato feature */
+ #else
+ /* use some fallback mechanism */
+ #endif
+
+rather than the more impenetrable
+
+ #ifndef MISSING_NEATO_FEATURE
+ /* Not missing it, so we must have it, so use it */
+ #else
+ /* Are missing it, so fall back on something else. */
+ #endif
+
+Of course for this toy example, there's not much difference. But when
+the #ifdef's start spanning a couple of screen fulls, and the #else's
+are marked something like
+
+ #else /* !MISSING_NEATO_FEATURE */
+
+I find it easy to get lost.
+
+=item Providing Missing Functions -- Problem
+
+Not all systems have all the neat functions you might want or need, so
+you might decide to be helpful and provide an emulation. This is
+sound in theory and very kind of you, but please be careful about what
+you name the function. Let me use the C<pause()> function as an
+illustration.
+
+Perl5.003 has the following in F<perl.h>
+
+ #ifndef HAS_PAUSE
+ #define pause() sleep((32767<<16)+32767)
+ #endif
+
+Configure sets HAS_PAUSE if the system has the pause() function, so
+this #define only kicks in if the pause() function is missing.
+Nice idea, right?
+
+Unfortunately, some systems apparently have a prototype for pause()
+in F<unistd.h>, but don't actually have the function in the library.
+(Or maybe they do have it in a library we're not using.)
+
+Thus, the compiler sees something like
+
+ extern int pause(void);
+ /* . . . */
+ #define pause() sleep((32767<<16)+32767)
+
+and dies with an error message. (Some compilers don't mind this;
+others apparently do.)
+
+To work around this, 5.003_03 and later have the following in perl.h:
+
+ /* Some unistd.h's give a prototype for pause() even though
+ HAS_PAUSE ends up undefined. This causes the #define
+ below to be rejected by the compiler. Sigh.
+ */
+ #ifdef HAS_PAUSE
+ # define Pause pause
+ #else
+ # define Pause() sleep((32767<<16)+32767)
+ #endif
+
+This works.
+
+The curious reader may wonder why I didn't do the following in
+F<util.c> instead:
+
+ #ifndef HAS_PAUSE
+ void pause()
+ {
+ sleep((32767<<16)+32767);
+ }
+ #endif
+
+That is, since the function is missing, just provide it.
+Then things would probably be been alright, it would seem.
+
+Well, almost. It could be made to work. The problem arises from the
+conflicting needs of dynamic loading and namespace protection.
+
+For dynamic loading to work on AIX (and VMS) we need to provide a list
+of symbols to be exported. This is done by the script F<perl_exp.SH>,
+which reads F<global.sym> and F<interp.sym>. Thus, the C<pause>
+symbol would have to be added to F<global.sym> So far, so good.
+
+On the other hand, one of the goals of Perl5 is to make it easy to
+either extend or embed perl and link it with other libraries. This
+means we have to be careful to keep the visible namespace "clean".
+That is, we don't want perl's global variables to conflict with
+those in the other application library. Although this work is still
+in progress, the way it is currently done is via the F<embed.h> file.
+This file is built from the F<global.sym> and F<interp.sym> files,
+since those files already list the globally visible symbols. If we
+had added C<pause> to global.sym, then F<embed.h> would contain the
+line
+
+ #define pause Perl_pause
+
+and calls to C<pause> in the perl sources would now point to
+C<Perl_pause>. Now, when B<ld> is run to build the F<perl> executable,
+it will go looking for C<perl_pause>, which probably won't exist in any
+of the standard libraries. Thus the build of perl will fail.
+
+Those systems where C<HAS_PAUSE> is not defined would be ok, however,
+since they would get a C<Perl_pause> function in util.c. The rest of
+the world would be in trouble.
+
+And yes, this scenario has happened. On SCO, the function C<chsize>
+is available. (I think it's in F<-lx>, the Xenix compatibility
+library.) Since the perl4 days (and possibly before), Perl has
+included a C<chsize> function that gets called something akin to
+
+ #ifndef HAS_CHSIZE
+ I32 chsize(fd, length)
+ /* . . . */
+ #endif
+
+When 5.003 added
+
+ #define chsize Perl_chsize
+
+to F<embed.h>, the compile started failing on SCO systems.
+
+The "fix" is to give the function a different name. The one
+implemented in 5.003_05 isn't optimal, but here's what was done:
+
+ #ifdef HAS_CHSIZE
+ # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
+ # undef my_chsize
+ # endif
+ # define my_chsize chsize
+ #endif
+
+My explanatory comment in patch 5.003_05 said:
+
+ Undef and then re-define my_chsize from Perl_my_chsize to
+ just plain chsize if this system HAS_CHSIZE. This probably only
+ applies to SCO. This shows the perils of having internal
+ functions with the same name as external library functions :-).
+
+Now, we can safely put C<my_chsize> in F<global.sym>, export it, and
+hide it with F<embed.h>.
+
+To be consistent with what I did for C<pause>, I probably should have
+called the new function C<Chsize>, rather than C<my_chsize>.
+However, the perl sources are quite inconsistent on this (Consider
+New, Mymalloc, and Myremalloc, to name just a few.)
+
+There is a problem with this fix, however, in that C<Perl_chsize>
+was available as a F<libperl.a> library function in 5.003, but it
+isn't available any more (as of 5.003_07). This means that we've
+broken binary compatibility. This is not good.
+
+=item Providing missing functions -- some ideas
+
+We currently don't have a standard way of handling such missing
+function names. Right now, I'm effectively thinking aloud about a
+solution. Some day, I'll try to formally propose a solution.
+
+Part of the problem is that we want to have some functions listed as
+exported but not have their names mangled by embed.h or possibly
+conflict with names in standard system headers. We actually already
+have such a list at the end of F<perl_exp.SH> (though that list is
+out-of-date):
+
+ # extra globals not included above.
+ cat <<END >> perl.exp
+ perl_init_ext
+ perl_init_fold
+ perl_init_i18nl14n
+ perl_alloc
+ perl_construct
+ perl_destruct
+ perl_free
+ perl_parse
+ perl_run
+ perl_get_sv
+ perl_get_av
+ perl_get_hv
+ perl_get_cv
+ perl_call_argv
+ perl_call_pv
+ perl_call_method
+ perl_call_sv
+ perl_requirepv
+ safecalloc
+ safemalloc
+ saferealloc
+ safefree
+
+This still needs much thought, but I'm inclined to think that one
+possible solution is to prefix all such functions with C<perl_> in the
+source and list them along with the other C<perl_*> functions in
+F<perl_exp.SH>.
+
+Thus, for C<chsize>, we'd do something like the following:
+
+ /* in perl.h */
+ #ifdef HAS_CHSIZE
+ # define perl_chsize chsize
+ #endif
+
+then in some file (e.g. F<util.c> or F<doio.c>) do
+
+ #ifndef HAS_CHSIZE
+ I32 perl_chsize(fd, length)
+ /* implement the function here . . . */
+ #endif
+
+Alternatively, we could just always use C<chsize> everywhere and move
+C<chsize> from F<global.sym> to the end of F<perl_exp.SH>. That would
+probably be fine as long as our C<chsize> function agreed with all the
+C<chsize> function prototypes in the various systems we'll be using.
+As long as the prototypes in actual use don't vary that much, this is
+probably a good alternative. (As a counter-example, note how Configure
+and perl have to go through hoops to find and use get Malloc_t and
+Free_t for C<malloc> and C<free>.)
+
+At the moment, this latter option is what I tend to prefer.
+
+=item All the world's a VAX
+
+Sorry, showing my age:-). Still, all the world is not BSD 4.[34],
+SVR4, or POSIX. Be aware that SVR3-derived systems are still quite
+common (do you have any idea how many systems run SCO?) If you don't
+have a bunch of v7 manuals handy, the metaconfig units (by default
+installed in F</usr/local/lib/dist/U>) are a good resource to look at
+for portability.
+
+=back
+
+=head1 Miscellaneous Topics
+
+=head2 Autoconf
+
+Why does perl use a metaconfig-generated Configure script instead of an
+autoconf-generated configure script?
+
+Metaconfig and autoconf are two tools with very similar purposes.
+Metaconfig is actually the older of the two, and was originally written
+by Larry Wall, while autoconf is probably now used in a wider variety of
+packages. The autoconf info file discusses the history of autoconf and
+how it came to be. The curious reader is referred there for further
+information.
+
+Overall, both tools are quite good, I think, and the choice of which one
+to use could be argued either way. In March, 1994, when I was just
+starting to work on Configure support for Perl5, I considered both
+autoconf and metaconfig, and eventually decided to use metaconfig for the
+following reasons:
+
+=over 4
+
+=item Compatibility with Perl4
+
+Perl4 used metaconfig, so many of the #ifdef's were already set up for
+metaconfig. Of course metaconfig had evolved some since Perl4's days,
+but not so much that it posed any serious problems.
+
+=item Metaconfig worked for me
+
+My system at the time was Interactive 2.2, a SVR3.2/386 derivative that
+also had some POSIX support. Metaconfig-generated Configure scripts
+worked fine for me on that system. On the other hand, autoconf-generated
+scripts usually didn't. (They did come quite close, though, in some
+cases.) At the time, I actually fetched a large number of GNU packages
+and checked. Not a single one configured and compiled correctly
+out-of-the-box with the system's cc compiler.
+
+=item Configure can be interactive
+
+With both autoconf and metaconfig, if the script works, everything is
+fine. However, one of my main problems with autoconf-generated scripts
+was that if it guessed wrong about something, it could be B<very> hard to
+go back and fix it. For example, autoconf always insisted on passing the
+-Xp flag to cc (to turn on POSIX behavior), even when that wasn't what I
+wanted or needed for that package. There was no way short of editing the
+configure script to turn this off. You couldn't just edit the resulting
+Makefile at the end because the -Xp flag influenced a number of other
+configure tests.
+
+Metaconfig's Configure scripts, on the other hand, can be interactive.
+Thus if Configure is guessing things incorrectly, you can go back and fix
+them. This isn't as important now as it was when we were actively
+developing Configure support for new features such as dynamic loading,
+but it's still useful occasionally.
+
+=item GPL
+
+At the time, autoconf-generated scripts were covered under the GNU Public
+License, and hence weren't suitable for inclusion with Perl, which has a
+different licensing policy. (Autoconf's licensing has since changed.)
+
+=item Modularity
+
+Metaconfig builds up Configure from a collection of discrete pieces
+called "units". You can override the standard behavior by supplying your
+own unit. With autoconf, you have to patch the standard files instead.
+I find the metaconfig "unit" method easier to work with. Others
+may find metaconfig's units clumsy to work with.
+
+=back
+
+=head2 @INC search order
+
+By default, the list of perl library directories in @INC is the
+following:
+
+ $archlib
+ $privlib
+ $sitearch
+ $sitelib
+
+Specifically, on my Solaris/x86 system, I run
+B<sh Configure -Dprefix=/opt/perl> and I have the following
+directories:
+
+ /opt/perl/lib/i86pc-solaris/5.00307
+ /opt/perl/lib
+ /opt/perl/lib/site_perl/i86pc-solaris
+ /opt/perl/lib/site_perl
+
+That is, perl's directories come first, followed by the site-specific
+directories.
+
+The site libraries come second to support the usage of extensions
+across perl versions. Read the relevant section in F<INSTALL> for
+more information. If we ever make $sitearch version-specific, this
+topic could be revisited.
+
+=head2 Why isn't there a directory to override Perl's library?
+
+Mainly because no one's gotten around to making one. Note that
+"making one" involves changing perl.c, Configure, config_h.SH (and
+associated files, see above), and I<documenting> it all in the
+INSTALL file.
+
+Apparently, most folks who want to override one of the standard library
+files simply do it by overwriting the standard library files.
+
+=head2 APPLLIB
+
+In the perl.c sources, you'll find an undocumented APPLLIB_EXP
+variable, sort of like PRIVLIB_EXP and ARCHLIB_EXP (which are
+documented in config_h.SH). Here's what APPLLIB_EXP is for, from
+a mail message from Larry:
+
+ The main intent of APPLLIB_EXP is for folks who want to send out a
+ version of Perl embedded in their product. They would set the symbol
+ to be the name of the library containing the files needed to run or to
+ support their particular application. This works at the "override"
+ level to make sure they get their own versions of any library code that
+ they absolutely must have configuration control over.
+
+ As such, I don't see any conflict with a sysadmin using it for a
+ override-ish sort of thing, when installing a generic Perl. It should
+ probably have been named something to do with overriding though. Since
+ it's undocumented we could still change it... :-)
+
+Given that it's already there, you can use it to override
+distribution modules. If you do
+
+ sh Configure -Dccflags='-DAPPLLIB_EXP=/my/override'
+
+then perl.c will put /my/override ahead of ARCHLIB and PRIVLIB.
+
+=head2 Shared libperl.so location
+
+Why isn't the shared libperl.so installed in /usr/lib/ along
+with "all the other" shared libraries? Instead, it is installed
+in $archlib, which is typically something like
+
+ /usr/local/lib/perl5/archname/5.00404
+
+and is architecture- and version-specific.
+
+The basic reason why a shared libperl.so gets put in $archlib is so that
+you can have more than one version of perl on the system at the same time,
+and have each refer to its own libperl.so.
+
+Three examples might help. All of these work now; none would work if you
+put libperl.so in /usr/lib.
+
+=over
+
+=item 1.
+
+Suppose you want to have both threaded and non-threaded perl versions
+around. Configure will name both perl libraries "libperl.so" (so that
+you can link to them with -lperl). The perl binaries tell them apart
+by having looking in the appropriate $archlib directories.
+
+=item 2.
+
+Suppose you have perl5.004_04 installed and you want to try to compile
+it again, perhaps with different options or after applying a patch.
+If you already have libperl.so installed in /usr/lib/, then it may be
+either difficult or impossible to get ld.so to find the new libperl.so
+that you're trying to build. If, instead, libperl.so is tucked away in
+$archlib, then you can always just change $archlib in the current perl
+you're trying to build so that ld.so won't find your old libperl.so.
+(The INSTALL file suggests you do this when building a debugging perl.)
+
+=item 3.
+
+The shared perl library is not a "well-behaved" shared library with
+proper major and minor version numbers, so you can't necessarily
+have perl5.004_04 and perl5.004_05 installed simultaneously. Suppose
+perl5.004_04 were to install /usr/lib/libperl.so.4.4, and perl5.004_05
+were to install /usr/lib/libperl.so.4.5. Now, when you try to run
+perl5.004_04, ld.so might try to load libperl.so.4.5, since it has
+the right "major version" number. If this works at all, it almost
+certainly defeats the reason for keeping perl5.004_04 around. Worse,
+with development subversions, you certaily can't guarantee that
+libperl.so.4.4 and libperl.so.4.55 will be compatible.
+
+Anyway, all this leads to quite obscure failures that are sure to drive
+casual users crazy. Even experienced users will get confused :-). Upon
+reflection, I'd say leave libperl.so in $archlib.
+
+=back
+
+=head1 Upload Your Work to CPAN
+
+You can upload your work to CPAN if you have a CPAN id. Check out
+http://www.perl.com/CPAN/modules/04pause.html for information on
+_PAUSE_, the Perl Author's Upload Server.
+
+I typically upload both the patch file, e.g. F<perl5.004_08.pat.gz>
+and the full tar file, e.g. F<perl5.004_08.tar.gz>.
+
+If you want your patch to appear in the F<src/5.0/unsupported>
+directory on CPAN, send e-mail to the CPAN master librarian. (Check
+out http://www.perl.com/CPAN/CPAN.html ).
+
+=head1 Help Save the World
+
+You should definitely announce your patch on the perl5-porters list.
+You should also consider announcing your patch on
+comp.lang.perl.announce, though you should make it quite clear that a
+subversion is not a production release, and be prepared to deal with
+people who will not read your disclaimer.
+
+=head1 Todo
+
+Here, in no particular order, are some Configure and build-related
+items that merit consideration. This list isn't exhaustive, it's just
+what I came up with off the top of my head.
+
+=head2 Good ideas waiting for round tuits
+
+=over 4
+
+=item installprefix
+
+I think we ought to support
+
+ Configure -Dinstallprefix=/blah/blah
+
+Currently, we support B<-Dprefix=/blah/blah>, but the changing the install
+location has to be handled by something like the F<config.over> trick
+described in F<INSTALL>. AFS users also are treated specially.
+We should probably duplicate the metaconfig prefix stuff for an
+install prefix.
+
+=item Configure -Dsrc=/blah/blah
+
+We should be able to emulate B<configure --srcdir>. Tom Tromey
+tromey@creche.cygnus.com has submitted some patches to
+the dist-users mailing list along these lines. They have been folded
+back into the main distribution, but various parts of the perl
+Configure/build/install process still assume src='.'.
+
+=item Hint file fixes
+
+Various hint files work around Configure problems. We ought to fix
+Configure so that most of them aren't needed.
+
+=item Hint file information
+
+Some of the hint file information (particularly dynamic loading stuff)
+ought to be fed back into the main metaconfig distribution.
+
+=item Catch GNU Libc "Stub" functions
+
+Some functions (such as lchown()) are present in libc, but are
+unimplmented. That is, they always fail and set errno=ENOSYS.
+
+Thomas Bushnell provided the following sample code and the explanation
+that follows:
+
+ /* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char FOO(); below. */
+ #include <assert.h>
+ /* Override any gcc2 internal prototype to avoid an error. */
+ /* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+ char FOO();
+
+ int main() {
+
+ /* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+ #if defined (__stub_FOO) || defined (__stub___FOO)
+ choke me
+ #else
+ FOO();
+ #endif
+
+ ; return 0; }
+
+The choice of <assert.h> is essentially arbitrary. The GNU libc
+macros are found in <gnu/stubs.h>. You can include that file instead
+of <assert.h> (which itself includes <gnu/stubs.h>) if you test for
+its existence first. <assert.h> is assumed to exist on every system,
+which is why it's used here. Any GNU libc header file will include
+the stubs macros. If either __stub_NAME or __stub___NAME is defined,
+then the function doesn't actually exist. Tests using <assert.h> work
+on every system around.
+
+The declaration of FOO is there to override builtin prototypes for
+ANSI C functions.
+
+=back
+
+=head2 Probably good ideas waiting for round tuits
+
+=over 4
+
+=item GNU configure --options
+
+I've received sensible suggestions for --exec_prefix and other
+GNU configure --options. It's not always obvious exactly what is
+intended, but this merits investigation.
+
+=item make clean
+
+Currently, B<make clean> isn't all that useful, though
+B<make realclean> and B<make distclean> are. This needs a bit of
+thought and documentation before it gets cleaned up.
+
+=item Try gcc if cc fails
+
+Currently, we just give up.
+
+=item bypassing safe*alloc wrappers
+
+On some systems, it may be safe to call the system malloc directly
+without going through the util.c safe* layers. (Such systems would
+accept free(0), for example.) This might be a time-saver for systems
+that already have a good malloc. (Recent Linux libc's apparently have
+a nice malloc that is well-tuned for the system.)
+
+=back
+
+=head2 Vague possibilities
+
+=over 4
+
+=item MacPerl
+
+Get some of the Macintosh stuff folded back into the main distribution.
+
+=item gconvert replacement
+
+Maybe include a replacement function that doesn't lose data in rare
+cases of coercion between string and numerical values.
+
+=item Improve makedepend
+
+The current makedepend process is clunky and annoyingly slow, but it
+works for most folks. Alas, it assumes that there is a filename
+$firstmakefile that the B<make> command will try to use before it uses
+F<Makefile>. Such may not be the case for all B<make> commands,
+particularly those on non-Unix systems.
+
+Probably some variant of the BSD F<.depend> file will be useful.
+We ought to check how other packages do this, if they do it at all.
+We could probably pre-generate the dependencies (with the exception of
+malloc.o, which could probably be determined at F<Makefile.SH>
+extraction time.
+
+=item GNU Makefile standard targets
+
+GNU software generally has standardized Makefile targets. Unless we
+have good reason to do otherwise, I see no reason not to support them.
+
+=item File locking
+
+Somehow, straighten out, document, and implement lockf(), flock(),
+and/or fcntl() file locking. It's a mess.
+
+=back
+
+=head1 AUTHORS
+
+Original author: Andy Dougherty doughera@lafcol.lafayette.edu .
+Additions by Chip Salzenberg chip@perl.com and
+Tim Bunce Tim.Bunce@ig.co.uk .
+
+All opinions expressed herein are those of the authorZ<>(s).
+
+=head1 LAST MODIFIED
+
+$Id: pumpkin.pod,v 1.22 1998/07/22 16:33:55 doughera Released $
diff --git a/contrib/perl5/README b/contrib/perl5/README
new file mode 100644
index 000000000000..7cc8021f009a
--- /dev/null
+++ b/contrib/perl5/README
@@ -0,0 +1,102 @@
+
+ Perl Kit, Version 5.0
+
+ Copyright 1989-1997, Larry Wall
+ All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this Kit.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this
+ Kit, in the file named "Artistic". If not, I'll be glad to provide one.
+
+ You should also have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ For those of you that choose to use the GNU General Public License,
+ my interpretation of the GNU General Public License is that no Perl
+ script falls under the terms of the GPL unless you explicitly put
+ said script under the terms of the GPL yourself. Furthermore, any
+ object code linked with perl does not automatically fall under the
+ terms of the GPL, provided such object code only adds definitions
+ of subroutines and variables, and does not otherwise impair the
+ resulting interpreter from executing any standard Perl script. I
+ consider linking in C subroutines in this manner to be the moral
+ equivalent of defining subroutines in the Perl language itself. You
+ may sell such an object file as proprietary provided that you provide
+ or offer to provide the Perl source, as specified by the GNU General
+ Public License. (This is merely an alternate way of specifying input
+ to the program.) You may also sell a binary produced by the dumping of
+ a running Perl script that belongs to you, provided that you provide or
+ offer to provide the Perl source as specified by the GPL. (The
+ fact that a Perl interpreter and your code are in the same binary file
+ is, in this case, a form of mere aggregation.) This is my interpretation
+ of the GPL. If you still have concerns or difficulties understanding
+ my intent, feel free to contact me. Of course, the Artistic License
+ spells all this out for your protection, so you may prefer to use that.
+
+--------------------------------------------------------------------------
+
+Perl is a language that combines some of the features of C, sed, awk
+and shell. See the manual page for more hype. There are also two Nutshell
+Handbooks published by O'Reilly & Assoc. See pod/perlbook.pod
+for more information.
+
+Please read all the directions below before you proceed any further, and
+then follow them carefully.
+
+After you have unpacked your kit, you should have all the files listed
+in MANIFEST.
+
+Installation
+
+1) Detailed instructions are in the file INSTALL which you should read.
+In brief, the following should work on most systems:
+ rm -f config.sh
+ sh Configure
+ make
+ make test
+ make install
+For most systems, it should be safe to accept all the Configure defaults.
+(It is recommended that you accept the defaults the first time you build
+or if you have any problems building.)
+
+2) Read the manual entries before running perl.
+
+3) IMPORTANT! Help save the world! Communicate any problems and suggested
+patches to perlbug@perl.com so we can keep the world in sync.
+If you have a problem, there's someone else out there who either has had
+or will have the same problem. It's usually helpful if you send the
+output of the "myconfig" script in the main perl directory.
+
+If you've succeeded in compiling perl, the perlbug script in the utils/
+subdirectory can be used to help mail in a bug report.
+
+If possible, send in patches such that the patch program will apply them.
+Context diffs are the best, then normal diffs. Don't send ed scripts--
+I've probably changed my copy since the version you have.
+
+Watch for perl patches in comp.lang.perl.announce. Patches will generally
+be in a form usable by the patch program. If you are just now bringing
+up perl and aren't sure how many patches there are, write to me and I'll
+send any you don't have. Your current patch level is shown in
+patchlevel.h.
+
+
+Just a personal note: I want you to know that I create nice things like this
+because it pleases the Author of my story. If this bothers you, then your
+notion of Authorship needs some revision. But you can use perl anyway. :-)
+
+ The author.
diff --git a/contrib/perl5/README.threads b/contrib/perl5/README.threads
new file mode 100644
index 000000000000..952623fcbdfd
--- /dev/null
+++ b/contrib/perl5/README.threads
@@ -0,0 +1,277 @@
+Building
+
+If you want to build with multi-threading support and you are
+running one of the following:
+
+ * Linux 2.x (with the LinuxThreads library installed: that's
+ the linuxthreads and linuxthreads-devel RPMs for RedHat)
+
+ * Digital UNIX 4.x
+
+ * Digital UNIX 3.x (Formerly DEC OSF/1), see additional note below
+
+ * Solaris 2.x for recentish x (2.5 is OK)
+
+ * IRIX 6.2 or newer. 6.2 will require a few os patches.
+ IMPORTANT: Without patch 2401, a kernel bug in IRIX 6.2 will
+ cause your machine to panic and crash when running threaded perl.
+ IRIX 6.3 and up should be OK. See lower down for patch details.
+
+then you should be able to use
+
+ ./Configure -Dusethreads -des
+ make
+
+and ignore the rest of this "Building" section. If it doesn't
+work or you are using another platform which you believe supports
+POSIX.1c threads then read on. Additional information may be in
+a platform-specific "hints" file in the hints/ subdirectory.
+
+Omit the -d from your ./Configure arguments. For example, use
+
+ ./Configure -Dusethreads
+
+When Configure prompts you for ccflags, insert any other arguments in
+there that your compiler needs to use POSIX threads. When Configure
+prompts you for linking flags, include any flags required for
+threading (usually nothing special is required here). Finally, when
+COnfigure prompts you for libraries, include any necessary libraries
+(e.g. -lpthread). Pay attention to the order of libraries. It is
+probably necessary to specify your threading library *before* your
+standard C library, e.g. it might be necessary to have -lpthread -lc,
+instead of -lc -lpthread.
+
+Once you have specified all your compiler flags, you can have Configure
+accept all the defaults for the remainder of the session by typing &-d
+at any Configure prompt.
+
+Some additional notes (some of these may be obsolete now, other items
+may be handled automatically):
+
+For Digital Unix 4.x:
+ Add -pthread to ccflags
+ Add -pthread to ldflags
+ Add -lpthread -lc_r to lddlflags
+
+ For some reason, the extra includes for pthreads make Digital UNIX
+ complain fatally about the sbrk() delcaration in perl's malloc.c
+ so use the native malloc, e.g. sh Configure -Uusemymalloc, or
+ manually edit your config.sh as follows:
+ Change usemymalloc to n
+ Zap mallocobj and mallocsrc (foo='')
+ Change d_mymalloc to undef
+
+For Digital Unix 3.x (Formerly DEC OSF/1):
+ Add -DOLD_PTHREADS_API to ccflags
+ If compiling with the GNU cc compiler, remove -thread from ccflags
+
+ (The following should be done automatically if you call Configure
+ with the -Dusethreads option).
+ Add -lpthread -lmach -lc_r to libs (in the order specified).
+
+For IRIX:
+ (This should all be done automatically by the hint file).
+ Add -lpthread to libs
+ For IRIX 6.2, you have to have the following patches installed:
+ 1404 Irix 6.2 Posix 1003.1b man pages
+ 1645 IRIX 6.2 & 6.3 POSIX header file updates
+ 2000 Irix 6.2 Posix 1003.1b support modules
+ 2254 Pthread library fixes
+ 2401 6.2 all platform kernel rollup
+ IMPORTANT: Without patch 2401, a kernel bug in IRIX 6.2 will
+ cause your machine to panic and crash when running threaded perl.
+ IRIX 6.3 and up should be OK.
+
+ For IRIX 6.3 and 6.4 the pthreads should work out of the box.
+ Thanks to Hannu Napari <Hannu.Napari@hut.fi> for the IRIX
+ pthreads patches information.
+For AIX:
+ (This should all be done automatically by the hint file).
+ Change cc to xlc_r or cc_r.
+ Add -DNEED_PTHREAD_INIT to ccflags and cppflags
+ Add -lc_r to libswanted
+ Change -lc in lddflags to be -lpthread -lc_r -lc
+
+Now you can do a
+ make
+
+
+O/S specific bugs
+
+Irix 6.2: See the Irix warning above.
+
+LinuxThreads 0.5 has a bug which can cause file descriptor 0 to be
+closed after a fork() leading to many strange symptoms. Version 0.6
+has this fixed but the following patch can be applied to 0.5 for now:
+
+----------------------------- cut here -----------------------------
+--- linuxthreads-0.5/pthread.c.ORI Mon Oct 6 13:55:50 1997
++++ linuxthreads-0.5/pthread.c Mon Oct 6 13:57:24 1997
+@@ -312,8 +312,10 @@
+ free(pthread_manager_thread_bos);
+ pthread_manager_thread_bos = pthread_manager_thread_tos = NULL;
+ /* Close the two ends of the pipe */
+- close(pthread_manager_request);
+- close(pthread_manager_reader);
++ if (pthread_manager_request >= 0) {
++ close(pthread_manager_request);
++ close(pthread_manager_reader);
++ }
+ pthread_manager_request = pthread_manager_reader = -1;
+ /* Update the pid of the main thread */
+ self->p_pid = getpid();
+----------------------------- cut here -----------------------------
+
+
+Building the Thread extension
+
+The Thread extension is now part of the main perl distribution tree.
+If you did Configure -Dusethreads then it will have been added to
+the list of extensions automatically.
+
+You can try some of the tests with
+ cd ext/Thread
+ perl create.t
+ perl join.t
+ perl lock.t
+ perl io.t
+etc.
+The io one leaves a thread reading from the keyboard on stdin so
+as the ping messages appear you can type lines and see them echoed.
+
+Try running the main perl test suite too. There are known
+failures for some of the DBM/DB extensions (if their underlying
+libraries were not compiled to be thread-aware).
+
+
+Bugs
+
+* FAKE_THREADS should produce a working perl but the Thread
+extension won't build with it yet.
+
+* There's a known memory leak (curstack isn't freed at the end
+of each thread because it causes refcount problems that I
+haven't tracked down yet) and there are very probably others too.
+
+* There may still be races where bugs show up under contention.
+
+* Need to document "lock", Thread.pm, Queue.pm, ...
+
+
+Debugging
+
+Use the -DS command-line option to turn on debugging of the
+multi-threading code. Under Linux, that also turns on a quick
+hack I did to grab a bit of extra information from segfaults.
+If you have a fancier gdb/threads setup than I do then you'll
+have to delete the lines in perl.c which say
+ #if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
+ DEBUG_S(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
+ #endif
+
+
+Background
+
+Some old globals (e.g. stack_sp, op) and some old per-interpreter
+variables (e.g. tmps_stack, cxstack) move into struct thread.
+All fields of struct thread which derived from original perl
+variables have names of the form Tfoo. For example, stack_sp becomes
+the field Tstack_sp of struct thread. For those fields which moved
+from original perl, thread.h does
+ #define foo (thr->Tfoo)
+This means that all functions in perl which need to use one of these
+fields need an (automatic) variable thr which points at the current
+thread's struct thread. For pp_foo functions, it is passed around as
+an argument, for other functions they do
+ dTHR;
+which declares and initialises thr from thread-specific data
+via pthread_getspecific. If a function fails to compile with an
+error about "no such variable thr", it probably just needs a dTHR
+at the top.
+
+
+Fake threads
+
+For FAKE_THREADS, thr is a global variable and perl schedules threads
+by altering thr in between appropriate ops. The next and prev fields
+of struct thread keep all fake threads on a doubly linked list and
+the next_run and prev_run fields keep all runnable threads on a
+doubly linked list. Mutexes are stubs for FAKE_THREADS. Condition
+variables are implemented as a list of waiting threads.
+
+
+Mutexes and condition variables
+
+The API is via macros MUTEX_{INIT,LOCK,UNLOCK,DESTROY} and
+COND_{INIT,WAIT,SIGNAL,BROADCAST,DESTROY}.
+
+A mutex is only required to be a simple, fast mutex (e.g. it does not
+have to be recursive). It is only ever held across very short pieces
+of code. Condition variables are only ever signalled/broadcast while
+their associated mutex is held. (This constraint simplifies the
+implementation of condition variables in certain porting situations.)
+For POSIX threads, perl mutexes and condition variables correspond to
+POSIX ones. For FAKE_THREADS, mutexes are stubs and condition variables
+are implmented as lists of waiting threads. For FAKE_THREADS, a thread
+waits on a condition variable by removing itself from the runnable
+list, calling SCHEDULE to change thr to the next appropriate
+runnable thread and returning op (i.e. the new threads next op).
+This means that fake threads can only block while in PP code.
+A PP function which contains a COND_WAIT must be prepared to
+handle such restarts and can use the field "private" of struct
+thread to record its state. For fake threads, COND_SIGNAL and
+COND_BROADCAST work by putting back all the threads on the
+condition variables list into the run queue. Note that a mutex
+must *not* be held while returning from a PP function.
+
+Perl locks and condition variables are both implemented as a
+condpair_t structure, containing a mutex, an "owner" condition
+variable, an owner thread field and another condition variable).
+The structure is attached by 'm' magic to any SV. pp_lock locks
+such an object by waiting on the ownercond condition variable until
+the owner field is zero and then setting the owner field to its own
+thread pointer. The lock is semantically recursive so if the owner
+field already matches the current thread then pp_lock returns
+straight away. If the owner field has to be filled in then
+unlock_condpair is queued as an end-of-block destructor and
+that function zeroes out the owner field and signals the ownercond
+condition variable, thus waking up any other thread that wants to
+lock it. When used as a condition variable, the condpair is locked
+(involving the above wait-for-ownership and setting the owner field)
+and the spare condition variable field is used for waiting on.
+
+
+Thread states
+
+
+ $t->join
+R_JOINABLE ---------------------> R_JOINED >----\
+ | \ pthread_join(t) | ^ |
+ | \ | | join | pthread_join
+ | \ | | |
+ | \ | \------/
+ | \ |
+ | \ |
+ | $t->detach\ pthread_detach |
+ | _\| |
+ends| R_DETACHED ends | unlink
+ | \ |
+ | ends \ unlink |
+ | \ |
+ | \ |
+ | \ |
+ | \ |
+ | \ |
+ V join detach _\| V
+ZOMBIE ----------------------------> DEAD
+ pthread_join pthread_detach
+ and unlink and unlink
+
+
+
+Malcolm Beattie
+mbeattie@sable.ox.ac.uk
+Last updated: 27 November 1997
+
+Configure-related info updated 16 July 1998 by
+Andy Dougherty <doughera@lafayette.edu>
diff --git a/contrib/perl5/Todo b/contrib/perl5/Todo
new file mode 100644
index 000000000000..3340e4fbf505
--- /dev/null
+++ b/contrib/perl5/Todo
@@ -0,0 +1,57 @@
+Tie Modules
+ VecArray Implement array using vec()
+ SubstrArray Implement array using substr()
+ VirtualArray Implement array using a file
+ ShiftSplice Defines shift et al in terms of splice method
+
+Would be nice to have
+ pack "(stuff)*"
+ Contiguous bitfields in pack/unpack
+ lexperl
+ Bundled perl preprocessor
+ Use posix calls internally where possible
+ gettimeofday
+ format BOTTOM
+ -iprefix.
+ -i rename file only when successfully changed
+ All ARGV input should act like <>
+ report HANDLE [formats].
+ support in perlmain to rerun debugger
+ regression tests using __DIE__ hook
+ reference to compiled regexp
+ lexically scoped functions: my sub foo { ... }
+ lvalue functions
+ regression/sanity tests for suidperl
+ Full 64 bit support (i.e. "long long")
+
+Possible pragmas
+ debugger
+ optimize (use less memory, CPU)
+
+Optimizations
+ constant function cache
+ switch structures
+ eval qw() at compile time
+ foreach(reverse...)
+ Set KEEP on constant split
+ Cache eval tree (unless lexical outer scope used (mark in &compiling?))
+ rcatmaybe
+ Shrink opcode tables via multiple implementations selected in peep
+ Cache hash value? (Not a win, according to Guido)
+ Optimize away @_ where possible
+ "one pass" global destruction
+ Optimize sort by { $a <=> $b }
+ Rewrite regexp parser for better integrated optimization
+ LRU cache of regexp: foreach $pat (@pats) { foo() if /$pat/ }
+
+Vague possibilities
+ ref function in list context
+ make tr/// return histogram in list context?
+ Loop control on do{} et al
+ Explicit switch statements
+ built-in globbing
+ compile to real threaded code
+ structured types
+ autocroak?
+ Modifiable $1 et al
+
diff --git a/contrib/perl5/Todo-5.005 b/contrib/perl5/Todo-5.005
new file mode 100644
index 000000000000..404e5ecaffb3
--- /dev/null
+++ b/contrib/perl5/Todo-5.005
@@ -0,0 +1,68 @@
+Multi-threading
+ $AUTOLOAD. Hmm.
+ without USE_THREADS, change extern variable for dTHR
+ consistent semantics for exit/die in threads
+ SvREFCNT_dec(curstack) in threadstart() in Thread.xs
+ better support for externally created threads
+ Thread::Pool
+ more Configure support
+ spot-check globals like statcache and global GVs for thread-safety
+
+Compiler
+ auto-produce executable
+ typed lexicals should affect B::CC::load_pad
+ workarounds to help Win32
+ $^C to track compiler/checker status
+ END blocks need saving in compiled output
+ _AUTOLOAD prodding
+ fix comppadlist (names in comppad_name can have fake SvCUR
+ from where newASSIGNOP steals the field)
+
+Namespace cleanup
+ symbol-space: "pl_" prefix for all global vars
+ "Perl_" prefix for all functions
+ CPP-space: restrict what we export from headers
+ stop malloc()/free() pollution unless asked
+ header-space: move into CORE/perl/
+ API-space: begin list of things that constitute public api
+
+MULTIPLICITY support
+ complete work on safe recursive interpreters, C<Perl->new()>
+
+Configure
+ installation layout changes to avoid overwriting old versions
+
+Reliable Signals
+ alternate runops() for signal despatch
+ figure out how to die() in delayed sighandler
+ add tests for Thread::Signal
+
+Win32 stuff
+ automate maintenance of most PERL_OBJECT code
+ get PERL_OBJECT building under gcc
+ rename new headers to be consistent with the rest
+ sort out the spawnvp() mess
+ work out DLL versioning
+ put perlobject in $ARCHNAME so it can coexist with rest
+ get PERL_OBJECT building on non-win32?
+ style-check
+
+Miscellaneous
+ rename and alter ISA.pm
+ magic_setisa should be made to update %FIELDS [???]
+ be generous in accepting foreign line terminations
+ make filenames 8.3 friendly, where feasible
+ upgrade to newer versions of all independently maintained modules
+ add new modules (Data-Dumper, Storable?)
+ test it with large parts of CPAN
+ fix pod2html to generate relative URLs
+
+Documentation
+ comprehensive perldelta.pod
+ describe new age patterns
+ update perl{guts,call,embed,xs} with additions, changes to API
+ document Win32 choices
+ rework INSTALL to reflect changes in installation structure
+ spot-check all new modules for completeness
+ better docs for pack()/unpack()
+ add perlport.pod
diff --git a/contrib/perl5/XSUB.h b/contrib/perl5/XSUB.h
new file mode 100644
index 000000000000..dc805d85ac2d
--- /dev/null
+++ b/contrib/perl5/XSUB.h
@@ -0,0 +1,93 @@
+#define ST(off) PL_stack_base[ax + (off)]
+
+#ifdef CAN_PROTOTYPE
+#ifdef PERL_OBJECT
+#define XS(name) void name(CV* cv, CPerlObj* pPerl)
+#else
+#define XS(name) void name(CV* cv)
+#endif
+#else
+#define XS(name) void name(cv) CV* cv;
+#endif
+
+#define dXSARGS \
+ dSP; dMARK; \
+ I32 ax = mark - PL_stack_base + 1; \
+ I32 items = sp - mark
+
+#define XSANY CvXSUBANY(cv)
+
+#define dXSI32 I32 ix = XSANY.any_i32
+
+#ifdef __cplusplus
+# define XSINTERFACE_CVT(ret,name) ret (*name)(...)
+#else
+# define XSINTERFACE_CVT(ret,name) ret (*name)()
+#endif
+#define dXSFUNCTION(ret) XSINTERFACE_CVT(ret,XSFUNCTION)
+#define XSINTERFACE_FUNC(ret,cv,f) ((XSINTERFACE_CVT(ret,))(f))
+#define XSINTERFACE_FUNC_SET(cv,f) \
+ CvXSUBANY(cv).any_dptr = (void (*) _((void*)))(f)
+
+#define XSRETURN(off) \
+ STMT_START { \
+ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
+ return; \
+ } STMT_END
+
+/* Simple macros to put new mortal values onto the stack. */
+/* Typically used to return values from XS functions. */
+#define XST_mIV(i,v) (ST(i) = sv_2mortal(newSViv(v)) )
+#define XST_mNV(i,v) (ST(i) = sv_2mortal(newSVnv(v)) )
+#define XST_mPV(i,v) (ST(i) = sv_2mortal(newSVpv(v,0)))
+#define XST_mNO(i) (ST(i) = &PL_sv_no )
+#define XST_mYES(i) (ST(i) = &PL_sv_yes )
+#define XST_mUNDEF(i) (ST(i) = &PL_sv_undef)
+
+#define XSRETURN_IV(v) STMT_START { XST_mIV(0,v); XSRETURN(1); } STMT_END
+#define XSRETURN_NV(v) STMT_START { XST_mNV(0,v); XSRETURN(1); } STMT_END
+#define XSRETURN_PV(v) STMT_START { XST_mPV(0,v); XSRETURN(1); } STMT_END
+#define XSRETURN_NO STMT_START { XST_mNO(0); XSRETURN(1); } STMT_END
+#define XSRETURN_YES STMT_START { XST_mYES(0); XSRETURN(1); } STMT_END
+#define XSRETURN_UNDEF STMT_START { XST_mUNDEF(0); XSRETURN(1); } STMT_END
+#define XSRETURN_EMPTY STMT_START { XSRETURN(0); } STMT_END
+
+#define newXSproto(a,b,c,d) sv_setpv((SV*)newXS(a,b,c), d)
+
+#ifdef XS_VERSION
+# define XS_VERSION_BOOTCHECK \
+ STMT_START { \
+ SV *tmpsv; \
+ char *vn = Nullch, *module = SvPV(ST(0),PL_na); \
+ if (items >= 2) /* version supplied as bootstrap arg */ \
+ tmpsv = ST(1); \
+ else { \
+ /* XXX GV_ADDWARN */ \
+ tmpsv = perl_get_sv(form("%s::%s", module, \
+ vn = "XS_VERSION"), FALSE); \
+ if (!tmpsv || !SvOK(tmpsv)) \
+ tmpsv = perl_get_sv(form("%s::%s", module, \
+ vn = "VERSION"), FALSE); \
+ } \
+ if (tmpsv && (!SvOK(tmpsv) || strNE(XS_VERSION, SvPV(tmpsv, PL_na)))) \
+ croak("%s object version %s does not match %s%s%s%s %_", \
+ module, XS_VERSION, \
+ vn ? "$" : "", vn ? module : "", vn ? "::" : "", \
+ vn ? vn : "bootstrap parameter", tmpsv); \
+ } STMT_END
+#else
+# define XS_VERSION_BOOTCHECK
+#endif
+
+#ifdef PERL_OBJECT
+#include "objXSUB.h"
+#ifndef NO_XSLOCKS
+#ifdef WIN32
+#include "XSlock.h"
+#endif /* WIN32 */
+#endif /* NO_XSLOCKS */
+#else
+#ifdef PERL_CAPI
+#include "perlCAPI.h"
+#endif
+#endif /* PERL_OBJECT */
diff --git a/contrib/perl5/XSlock.h b/contrib/perl5/XSlock.h
new file mode 100644
index 000000000000..8fb0ce47899b
--- /dev/null
+++ b/contrib/perl5/XSlock.h
@@ -0,0 +1,35 @@
+#ifndef __XSlock_h__
+#define __XSlock_h__
+
+class XSLockManager
+{
+public:
+ XSLockManager() { InitializeCriticalSection(&cs); };
+ ~XSLockManager() { DeleteCriticalSection(&cs); };
+ void Enter(void) { EnterCriticalSection(&cs); };
+ void Leave(void) { LeaveCriticalSection(&cs); };
+protected:
+ CRITICAL_SECTION cs;
+};
+
+XSLockManager g_XSLock;
+
+class XSLock
+{
+public:
+ XSLock() { g_XSLock.Enter(); };
+ ~XSLock() { g_XSLock.Leave(); };
+};
+
+CPerlObj* pPerl;
+
+#undef dXSARGS
+#define dXSARGS \
+ dSP; dMARK; \
+ I32 ax = mark - PL_stack_base + 1; \
+ I32 items = sp - mark; \
+ XSLock localLock; \
+ ::pPerl = pPerl
+
+
+#endif
diff --git a/contrib/perl5/av.c b/contrib/perl5/av.c
new file mode 100644
index 000000000000..b5c9bc20aa95
--- /dev/null
+++ b/contrib/perl5/av.c
@@ -0,0 +1,658 @@
+/* av.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "...for the Entwives desired order, and plenty, and peace (by which they
+ * meant that things should remain where they had set them)." --Treebeard
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+void
+av_reify(AV *av)
+{
+ I32 key;
+ SV* sv;
+
+ if (AvREAL(av))
+ return;
+#ifdef DEBUGGING
+ if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
+ warn("av_reify called on tied array");
+#endif
+ key = AvMAX(av) + 1;
+ while (key > AvFILLp(av) + 1)
+ AvARRAY(av)[--key] = &PL_sv_undef;
+ while (key) {
+ sv = AvARRAY(av)[--key];
+ assert(sv);
+ if (sv != &PL_sv_undef) {
+ dTHR;
+ (void)SvREFCNT_inc(sv);
+ }
+ }
+ key = AvARRAY(av) - AvALLOC(av);
+ while (key)
+ AvALLOC(av)[--key] = &PL_sv_undef;
+ AvREAL_on(av);
+}
+
+void
+av_extend(AV *av, I32 key)
+{
+ dTHR; /* only necessary if we have to extend stack */
+ MAGIC *mg;
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP,2);
+ PUSHs(mg->mg_obj);
+ PUSHs(sv_2mortal(newSViv(key+1)));
+ PUTBACK;
+ perl_call_method("EXTEND", G_SCALAR|G_DISCARD);
+ POPSTACK;
+ FREETMPS;
+ LEAVE;
+ return;
+ }
+ if (key > AvMAX(av)) {
+ SV** ary;
+ I32 tmp;
+ I32 newmax;
+
+ if (AvALLOC(av) != AvARRAY(av)) {
+ ary = AvALLOC(av) + AvFILLp(av) + 1;
+ tmp = AvARRAY(av) - AvALLOC(av);
+ Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*);
+ AvMAX(av) += tmp;
+ SvPVX(av) = (char*)AvALLOC(av);
+ if (AvREAL(av)) {
+ while (tmp)
+ ary[--tmp] = &PL_sv_undef;
+ }
+
+ if (key > AvMAX(av) - 10) {
+ newmax = key + AvMAX(av);
+ goto resize;
+ }
+ }
+ else {
+ if (AvALLOC(av)) {
+#ifndef STRANGE_MALLOC
+ U32 bytes;
+#endif
+
+#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
+ newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
+
+ if (key <= newmax)
+ goto resized;
+#endif
+ newmax = key + AvMAX(av) / 5;
+ resize:
+#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
+ Renew(AvALLOC(av),newmax+1, SV*);
+#else
+ bytes = (newmax + 1) * sizeof(SV*);
+#define MALLOC_OVERHEAD 16
+ tmp = MALLOC_OVERHEAD;
+ while (tmp - MALLOC_OVERHEAD < bytes)
+ tmp += tmp;
+ tmp -= MALLOC_OVERHEAD;
+ tmp /= sizeof(SV*);
+ assert(tmp > newmax);
+ newmax = tmp - 1;
+ New(2,ary, newmax+1, SV*);
+ Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*);
+ if (AvMAX(av) > 64)
+ offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*));
+ else
+ Safefree(AvALLOC(av));
+ AvALLOC(av) = ary;
+#endif
+ resized:
+ ary = AvALLOC(av) + AvMAX(av) + 1;
+ tmp = newmax - AvMAX(av);
+ if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */
+ PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base);
+ PL_stack_base = AvALLOC(av);
+ PL_stack_max = PL_stack_base + newmax;
+ }
+ }
+ else {
+ newmax = key < 3 ? 3 : key;
+ New(2,AvALLOC(av), newmax+1, SV*);
+ ary = AvALLOC(av) + 1;
+ tmp = newmax;
+ AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */
+ }
+ if (AvREAL(av)) {
+ while (tmp)
+ ary[--tmp] = &PL_sv_undef;
+ }
+
+ SvPVX(av) = (char*)AvALLOC(av);
+ AvMAX(av) = newmax;
+ }
+ }
+}
+
+SV**
+av_fetch(register AV *av, I32 key, I32 lval)
+{
+ SV *sv;
+
+ if (!av)
+ return 0;
+
+ if (key < 0) {
+ key += AvFILL(av) + 1;
+ if (key < 0)
+ return 0;
+ }
+
+ if (SvRMAGICAL(av)) {
+ if (mg_find((SV*)av,'P')) {
+ dTHR;
+ sv = sv_newmortal();
+ mg_copy((SV*)av, sv, 0, key);
+ PL_av_fetch_sv = sv;
+ return &PL_av_fetch_sv;
+ }
+ }
+
+ if (key > AvFILLp(av)) {
+ if (!lval)
+ return 0;
+ if (AvREALISH(av))
+ sv = NEWSV(5,0);
+ else
+ sv = sv_newmortal();
+ return av_store(av,key,sv);
+ }
+ if (AvARRAY(av)[key] == &PL_sv_undef) {
+ emptyness:
+ if (lval) {
+ sv = NEWSV(6,0);
+ return av_store(av,key,sv);
+ }
+ return 0;
+ }
+ else if (AvREIFY(av)
+ && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */
+ || SvTYPE(AvARRAY(av)[key]) == SVTYPEMASK)) {
+ AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */
+ goto emptyness;
+ }
+ return &AvARRAY(av)[key];
+}
+
+SV**
+av_store(register AV *av, I32 key, SV *val)
+{
+ SV** ary;
+ U32 fill;
+
+
+ if (!av)
+ return 0;
+ if (!val)
+ val = &PL_sv_undef;
+
+ if (key < 0) {
+ key += AvFILL(av) + 1;
+ if (key < 0)
+ return 0;
+ }
+
+ if (SvREADONLY(av) && key >= AvFILL(av))
+ croak(no_modify);
+
+ if (SvRMAGICAL(av)) {
+ if (mg_find((SV*)av,'P')) {
+ if (val != &PL_sv_undef) {
+ mg_copy((SV*)av, val, 0, key);
+ }
+ return 0;
+ }
+ }
+
+ if (!AvREAL(av) && AvREIFY(av))
+ av_reify(av);
+ if (key > AvMAX(av))
+ av_extend(av,key);
+ ary = AvARRAY(av);
+ if (AvFILLp(av) < key) {
+ if (!AvREAL(av)) {
+ dTHR;
+ if (av == PL_curstack && key > PL_stack_sp - PL_stack_base)
+ PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */
+ do
+ ary[++AvFILLp(av)] = &PL_sv_undef;
+ while (AvFILLp(av) < key);
+ }
+ AvFILLp(av) = key;
+ }
+ else if (AvREAL(av))
+ SvREFCNT_dec(ary[key]);
+ ary[key] = val;
+ if (SvSMAGICAL(av)) {
+ if (val != &PL_sv_undef) {
+ MAGIC* mg = SvMAGIC(av);
+ sv_magic(val, (SV*)av, toLOWER(mg->mg_type), 0, key);
+ }
+ mg_set((SV*)av);
+ }
+ return &ary[key];
+}
+
+AV *
+newAV(void)
+{
+ register AV *av;
+
+ av = (AV*)NEWSV(3,0);
+ sv_upgrade((SV *)av, SVt_PVAV);
+ AvREAL_on(av);
+ AvALLOC(av) = 0;
+ SvPVX(av) = 0;
+ AvMAX(av) = AvFILLp(av) = -1;
+ return av;
+}
+
+AV *
+av_make(register I32 size, register SV **strp)
+{
+ register AV *av;
+ register I32 i;
+ register SV** ary;
+
+ av = (AV*)NEWSV(8,0);
+ sv_upgrade((SV *) av,SVt_PVAV);
+ AvFLAGS(av) = AVf_REAL;
+ if (size) { /* `defined' was returning undef for size==0 anyway. */
+ New(4,ary,size,SV*);
+ AvALLOC(av) = ary;
+ SvPVX(av) = (char*)ary;
+ AvFILLp(av) = size - 1;
+ AvMAX(av) = size - 1;
+ for (i = 0; i < size; i++) {
+ assert (*strp);
+ ary[i] = NEWSV(7,0);
+ sv_setsv(ary[i], *strp);
+ strp++;
+ }
+ }
+ return av;
+}
+
+AV *
+av_fake(register I32 size, register SV **strp)
+{
+ register AV *av;
+ register SV** ary;
+
+ av = (AV*)NEWSV(9,0);
+ sv_upgrade((SV *)av, SVt_PVAV);
+ New(4,ary,size+1,SV*);
+ AvALLOC(av) = ary;
+ Copy(strp,ary,size,SV*);
+ AvFLAGS(av) = AVf_REIFY;
+ SvPVX(av) = (char*)ary;
+ AvFILLp(av) = size - 1;
+ AvMAX(av) = size - 1;
+ while (size--) {
+ assert (*strp);
+ SvTEMP_off(*strp);
+ strp++;
+ }
+ return av;
+}
+
+void
+av_clear(register AV *av)
+{
+ register I32 key;
+ SV** ary;
+
+#ifdef DEBUGGING
+ if (SvREFCNT(av) <= 0) {
+ warn("Attempt to clear deleted array");
+ }
+#endif
+ if (!av)
+ return;
+ /*SUPPRESS 560*/
+
+ if (SvREADONLY(av))
+ croak(no_modify);
+
+ /* Give any tie a chance to cleanup first */
+ if (SvRMAGICAL(av))
+ mg_clear((SV*)av);
+
+ if (AvMAX(av) < 0)
+ return;
+
+ if (AvREAL(av)) {
+ ary = AvARRAY(av);
+ key = AvFILLp(av) + 1;
+ while (key) {
+ SvREFCNT_dec(ary[--key]);
+ ary[key] = &PL_sv_undef;
+ }
+ }
+ if (key = AvARRAY(av) - AvALLOC(av)) {
+ AvMAX(av) += key;
+ SvPVX(av) = (char*)AvALLOC(av);
+ }
+ AvFILLp(av) = -1;
+
+}
+
+void
+av_undef(register AV *av)
+{
+ register I32 key;
+
+ if (!av)
+ return;
+ /*SUPPRESS 560*/
+
+ /* Give any tie a chance to cleanup first */
+ if (SvRMAGICAL(av) && mg_find((SV*)av,'P'))
+ av_fill(av, -1); /* mg_clear() ? */
+
+ if (AvREAL(av)) {
+ key = AvFILLp(av) + 1;
+ while (key)
+ SvREFCNT_dec(AvARRAY(av)[--key]);
+ }
+ Safefree(AvALLOC(av));
+ AvALLOC(av) = 0;
+ SvPVX(av) = 0;
+ AvMAX(av) = AvFILLp(av) = -1;
+ if (AvARYLEN(av)) {
+ SvREFCNT_dec(AvARYLEN(av));
+ AvARYLEN(av) = 0;
+ }
+}
+
+void
+av_push(register AV *av, SV *val)
+{
+ MAGIC *mg;
+ if (!av)
+ return;
+ if (SvREADONLY(av))
+ croak(no_modify);
+
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP,2);
+ PUSHs(mg->mg_obj);
+ PUSHs(val);
+ PUTBACK;
+ ENTER;
+ perl_call_method("PUSH", G_SCALAR|G_DISCARD);
+ LEAVE;
+ POPSTACK;
+ return;
+ }
+ av_store(av,AvFILLp(av)+1,val);
+}
+
+SV *
+av_pop(register AV *av)
+{
+ SV *retval;
+ MAGIC* mg;
+
+ if (!av || AvFILL(av) < 0)
+ return &PL_sv_undef;
+ if (SvREADONLY(av))
+ croak(no_modify);
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ XPUSHs(mg->mg_obj);
+ PUTBACK;
+ ENTER;
+ if (perl_call_method("POP", G_SCALAR)) {
+ retval = newSVsv(*PL_stack_sp--);
+ } else {
+ retval = &PL_sv_undef;
+ }
+ LEAVE;
+ POPSTACK;
+ return retval;
+ }
+ retval = AvARRAY(av)[AvFILLp(av)];
+ AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
+ if (SvSMAGICAL(av))
+ mg_set((SV*)av);
+ return retval;
+}
+
+void
+av_unshift(register AV *av, register I32 num)
+{
+ register I32 i;
+ register SV **ary;
+ MAGIC* mg;
+
+ if (!av || num <= 0)
+ return;
+ if (SvREADONLY(av))
+ croak(no_modify);
+
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP,1+num);
+ PUSHs(mg->mg_obj);
+ while (num-- > 0) {
+ PUSHs(&PL_sv_undef);
+ }
+ PUTBACK;
+ ENTER;
+ perl_call_method("UNSHIFT", G_SCALAR|G_DISCARD);
+ LEAVE;
+ POPSTACK;
+ return;
+ }
+
+ if (!AvREAL(av) && AvREIFY(av))
+ av_reify(av);
+ i = AvARRAY(av) - AvALLOC(av);
+ if (i) {
+ if (i > num)
+ i = num;
+ num -= i;
+
+ AvMAX(av) += i;
+ AvFILLp(av) += i;
+ SvPVX(av) = (char*)(AvARRAY(av) - i);
+ }
+ if (num) {
+ i = AvFILLp(av);
+ av_extend(av, i + num);
+ AvFILLp(av) += num;
+ ary = AvARRAY(av);
+ Move(ary, ary + num, i + 1, SV*);
+ do {
+ ary[--num] = &PL_sv_undef;
+ } while (num);
+ }
+}
+
+SV *
+av_shift(register AV *av)
+{
+ SV *retval;
+ MAGIC* mg;
+
+ if (!av || AvFILL(av) < 0)
+ return &PL_sv_undef;
+ if (SvREADONLY(av))
+ croak(no_modify);
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ XPUSHs(mg->mg_obj);
+ PUTBACK;
+ ENTER;
+ if (perl_call_method("SHIFT", G_SCALAR)) {
+ retval = newSVsv(*PL_stack_sp--);
+ } else {
+ retval = &PL_sv_undef;
+ }
+ LEAVE;
+ POPSTACK;
+ return retval;
+ }
+ retval = *AvARRAY(av);
+ if (AvREAL(av))
+ *AvARRAY(av) = &PL_sv_undef;
+ SvPVX(av) = (char*)(AvARRAY(av) + 1);
+ AvMAX(av)--;
+ AvFILLp(av)--;
+ if (SvSMAGICAL(av))
+ mg_set((SV*)av);
+ return retval;
+}
+
+I32
+av_len(register AV *av)
+{
+ return AvFILL(av);
+}
+
+void
+av_fill(register AV *av, I32 fill)
+{
+ MAGIC *mg;
+ if (!av)
+ croak("panic: null array");
+ if (fill < 0)
+ fill = -1;
+ if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP,2);
+ PUSHs(mg->mg_obj);
+ PUSHs(sv_2mortal(newSViv(fill+1)));
+ PUTBACK;
+ perl_call_method("STORESIZE", G_SCALAR|G_DISCARD);
+ POPSTACK;
+ FREETMPS;
+ LEAVE;
+ return;
+ }
+ if (fill <= AvMAX(av)) {
+ I32 key = AvFILLp(av);
+ SV** ary = AvARRAY(av);
+
+ if (AvREAL(av)) {
+ while (key > fill) {
+ SvREFCNT_dec(ary[key]);
+ ary[key--] = &PL_sv_undef;
+ }
+ }
+ else {
+ while (key < fill)
+ ary[++key] = &PL_sv_undef;
+ }
+
+ AvFILLp(av) = fill;
+ if (SvSMAGICAL(av))
+ mg_set((SV*)av);
+ }
+ else
+ (void)av_store(av,fill,&PL_sv_undef);
+}
+
+
+/* AVHV: Support for treating arrays as if they were hashes. The
+ * first element of the array should be a hash reference that maps
+ * hash keys to array indices.
+ */
+
+STATIC I32
+avhv_index_sv(SV* sv)
+{
+ I32 index = SvIV(sv);
+ if (index < 1)
+ croak("Bad index while coercing array into hash");
+ return index;
+}
+
+HV*
+avhv_keys(AV *av)
+{
+ SV **keysp = av_fetch(av, 0, FALSE);
+ if (keysp) {
+ SV *sv = *keysp;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (SvROK(sv)) {
+ sv = SvRV(sv);
+ if (SvTYPE(sv) == SVt_PVHV)
+ return (HV*)sv;
+ }
+ }
+ croak("Can't coerce array into hash");
+ return Nullhv;
+}
+
+SV**
+avhv_fetch_ent(AV *av, SV *keysv, I32 lval, U32 hash)
+{
+ SV **indsvp;
+ HV *keys = avhv_keys(av);
+ HE *he;
+
+ he = hv_fetch_ent(keys, keysv, FALSE, hash);
+ if (!he)
+ croak("No such array field");
+ return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
+}
+
+bool
+avhv_exists_ent(AV *av, SV *keysv, U32 hash)
+{
+ HV *keys = avhv_keys(av);
+ return hv_exists_ent(keys, keysv, hash);
+}
+
+HE *
+avhv_iternext(AV *av)
+{
+ HV *keys = avhv_keys(av);
+ return hv_iternext(keys);
+}
+
+SV *
+avhv_iterval(AV *av, register HE *entry)
+{
+ SV *sv = hv_iterval(avhv_keys(av), entry);
+ return *av_fetch(av, avhv_index_sv(sv), TRUE);
+}
diff --git a/contrib/perl5/av.h b/contrib/perl5/av.h
new file mode 100644
index 000000000000..8de81f42e424
--- /dev/null
+++ b/contrib/perl5/av.h
@@ -0,0 +1,51 @@
+/* av.h
+ *
+ * Copyright (c) 1991-1998, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+struct xpvav {
+ char* xav_array; /* pointer to first array element */
+ SSize_t xav_fill; /* Index of last element present */
+ SSize_t xav_max; /* Number of elements for which array has space */
+ IV xof_off; /* ptr is incremented by offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* magic for scalar array */
+ HV* xmg_stash; /* class package */
+
+ SV** xav_alloc; /* pointer to malloced string */
+ SV* xav_arylen;
+ U8 xav_flags;
+};
+
+#define AVf_REAL 1 /* free old entries */
+#define AVf_REIFY 2 /* can become real */
+#define AVf_REUSED 4 /* got undeffed--don't turn old memory into SVs now */
+
+#define Nullav Null(AV*)
+
+#define AvARRAY(av) ((SV**)((XPVAV*) SvANY(av))->xav_array)
+#define AvALLOC(av) ((XPVAV*) SvANY(av))->xav_alloc
+#define AvMAX(av) ((XPVAV*) SvANY(av))->xav_max
+#define AvFILLp(av) ((XPVAV*) SvANY(av))->xav_fill
+#define AvARYLEN(av) ((XPVAV*) SvANY(av))->xav_arylen
+#define AvFLAGS(av) ((XPVAV*) SvANY(av))->xav_flags
+
+#define AvREAL(av) (AvFLAGS(av) & AVf_REAL)
+#define AvREAL_on(av) (AvFLAGS(av) |= AVf_REAL)
+#define AvREAL_off(av) (AvFLAGS(av) &= ~AVf_REAL)
+#define AvREIFY(av) (AvFLAGS(av) & AVf_REIFY)
+#define AvREIFY_on(av) (AvFLAGS(av) |= AVf_REIFY)
+#define AvREIFY_off(av) (AvFLAGS(av) &= ~AVf_REIFY)
+#define AvREUSED(av) (AvFLAGS(av) & AVf_REUSED)
+#define AvREUSED_on(av) (AvFLAGS(av) |= AVf_REUSED)
+#define AvREUSED_off(av) (AvFLAGS(av) &= ~AVf_REUSED)
+
+#define AvREALISH(av) (AvFLAGS(av) & (AVf_REAL|AVf_REIFY))
+
+#define AvFILL(av) ((SvRMAGICAL((SV *) (av))) \
+ ? mg_size((SV *) av) : AvFILLp(av))
+
diff --git a/contrib/perl5/bytecode.h b/contrib/perl5/bytecode.h
new file mode 100644
index 000000000000..e28dd434f202
--- /dev/null
+++ b/contrib/perl5/bytecode.h
@@ -0,0 +1,161 @@
+typedef char *pvcontents;
+typedef char *strconst;
+typedef U32 PV;
+typedef char *op_tr_array;
+typedef int comment_t;
+typedef SV *svindex;
+typedef OP *opindex;
+typedef IV IV64;
+
+#ifdef INDIRECT_BGET_MACROS
+#define BGET_FREAD(argp, len, nelem) \
+ bs.fread((char*)(argp),(len),(nelem),bs.data)
+#define BGET_FGETC() bs.fgetc(bs.data)
+#else
+#define BGET_FREAD(argp, len, nelem) PerlIO_read(fp, (argp), (len)*(nelem))
+#define BGET_FGETC() PerlIO_getc(fp)
+#endif /* INDIRECT_BGET_MACROS */
+
+#define BGET_U32(arg) \
+ BGET_FREAD(&arg, sizeof(U32), 1); arg = PerlSock_ntohl((U32)arg)
+#define BGET_I32(arg) \
+ BGET_FREAD(&arg, sizeof(I32), 1); arg = (I32)PerlSock_ntohl((U32)arg)
+#define BGET_U16(arg) \
+ BGET_FREAD(&arg, sizeof(U16), 1); arg = PerlSock_ntohs((U16)arg)
+#define BGET_U8(arg) arg = BGET_FGETC()
+
+#if INDIRECT_BGET_MACROS
+#define BGET_PV(arg) STMT_START { \
+ BGET_U32(arg); \
+ if (arg) \
+ bs.freadpv(arg, bs.data); \
+ else { \
+ PL_bytecode_pv.xpv_pv = 0; \
+ PL_bytecode_pv.xpv_len = 0; \
+ PL_bytecode_pv.xpv_cur = 0; \
+ } \
+ } STMT_END
+#else
+#define BGET_PV(arg) STMT_START { \
+ BGET_U32(arg); \
+ if (arg) { \
+ New(666, PL_bytecode_pv.xpv_pv, arg, char); \
+ PerlIO_read(fp, PL_bytecode_pv.xpv_pv, arg); \
+ PL_bytecode_pv.xpv_len = arg; \
+ PL_bytecode_pv.xpv_cur = arg - 1; \
+ } else { \
+ PL_bytecode_pv.xpv_pv = 0; \
+ PL_bytecode_pv.xpv_len = 0; \
+ PL_bytecode_pv.xpv_cur = 0; \
+ } \
+ } STMT_END
+#endif /* INDIRECT_BGET_MACROS */
+
+#define BGET_comment_t(arg) \
+ do { arg = BGET_FGETC(); } while (arg != '\n' && arg != EOF)
+
+/*
+ * In the following, sizeof(IV)*4 is just a way of encoding 32 on 64-bit-IV
+ * machines such that 32-bit machine compilers don't whine about the shift
+ * count being too high even though the code is never reached there.
+ */
+#define BGET_IV64(arg) STMT_START { \
+ U32 hi, lo; \
+ BGET_U32(hi); \
+ BGET_U32(lo); \
+ if (sizeof(IV) == 8) \
+ arg = (IV) (hi << (sizeof(IV)*4) | lo); \
+ else if (((I32)hi == -1 && (I32)lo < 0) \
+ || ((I32)hi == 0 && (I32)lo >= 0)) { \
+ arg = (I32)lo; \
+ } \
+ else { \
+ PL_bytecode_iv_overflows++; \
+ arg = 0; \
+ } \
+ } STMT_END
+
+#define BGET_op_tr_array(arg) do { \
+ unsigned short *ary; \
+ int i; \
+ New(666, ary, 256, unsigned short); \
+ BGET_FREAD(ary, 256, 2); \
+ for (i = 0; i < 256; i++) \
+ ary[i] = PerlSock_ntohs(ary[i]); \
+ arg = (char *) ary; \
+ } while (0)
+
+#define BGET_pvcontents(arg) arg = PL_bytecode_pv.xpv_pv
+#define BGET_strconst(arg) STMT_START { \
+ for (arg = PL_tokenbuf; (*arg = BGET_FGETC()); arg++) /* nothing */; \
+ arg = PL_tokenbuf; \
+ } STMT_END
+
+#define BGET_double(arg) STMT_START { \
+ char *str; \
+ BGET_strconst(str); \
+ arg = atof(str); \
+ } STMT_END
+
+#define BGET_objindex(arg, type) STMT_START { \
+ U32 ix; \
+ BGET_U32(ix); \
+ arg = (type)PL_bytecode_obj_list[ix]; \
+ } STMT_END
+#define BGET_svindex(arg) BGET_objindex(arg, svindex)
+#define BGET_opindex(arg) BGET_objindex(arg, opindex)
+
+#define BSET_ldspecsv(sv, arg) sv = PL_specialsv_list[arg]
+
+#define BSET_sv_refcnt_add(svrefcnt, arg) svrefcnt += arg
+#define BSET_gp_refcnt_add(gprefcnt, arg) gprefcnt += arg
+#define BSET_gp_share(sv, arg) STMT_START { \
+ gp_free((GV*)sv); \
+ GvGP(sv) = GvGP(arg); \
+ } STMT_END
+
+#define BSET_gv_fetchpv(sv, arg) sv = (SV*)gv_fetchpv(arg, TRUE, SVt_PV)
+#define BSET_gv_stashpv(sv, arg) sv = (SV*)gv_stashpv(arg, TRUE)
+#define BSET_sv_magic(sv, arg) sv_magic(sv, Nullsv, arg, 0, 0)
+#define BSET_mg_pv(mg, arg) mg->mg_ptr = arg; mg->mg_len = PL_bytecode_pv.xpv_cur
+#define BSET_sv_upgrade(sv, arg) (void)SvUPGRADE(sv, arg)
+#define BSET_xpv(sv) do { \
+ SvPV_set(sv, PL_bytecode_pv.xpv_pv); \
+ SvCUR_set(sv, PL_bytecode_pv.xpv_cur); \
+ SvLEN_set(sv, PL_bytecode_pv.xpv_len); \
+ } while (0)
+#define BSET_av_extend(sv, arg) av_extend((AV*)sv, arg)
+
+#define BSET_av_push(sv, arg) av_push((AV*)sv, arg)
+#define BSET_hv_store(sv, arg) \
+ hv_store((HV*)sv, PL_bytecode_pv.xpv_pv, PL_bytecode_pv.xpv_cur, arg, 0)
+#define BSET_pv_free(pv) Safefree(pv.xpv_pv)
+#define BSET_pregcomp(o, arg) \
+ ((PMOP*)o)->op_pmregexp = arg ? \
+ CALLREGCOMP(arg, arg + PL_bytecode_pv.xpv_cur, ((PMOP*)o)) : 0
+#define BSET_newsv(sv, arg) sv = NEWSV(666,0); SvUPGRADE(sv, arg)
+#define BSET_newop(o, arg) o = (OP*)safemalloc(optype_size[arg])
+#define BSET_newopn(o, arg) STMT_START { \
+ OP *oldop = o; \
+ BSET_newop(o, arg); \
+ oldop->op_next = o; \
+ } STMT_END
+
+#define BSET_ret(foo) return
+
+/*
+ * Kludge special-case workaround for OP_MAPSTART
+ * which needs the ppaddr for OP_GREPSTART. Blech.
+ */
+#define BSET_op_type(o, arg) STMT_START { \
+ o->op_type = arg; \
+ if (arg == OP_MAPSTART) \
+ arg = OP_GREPSTART; \
+ o->op_ppaddr = ppaddr[arg]; \
+ } STMT_END
+#define BSET_op_ppaddr(o, arg) croak("op_ppaddr not yet implemented")
+#define BSET_curpad(pad, arg) pad = AvARRAY(arg)
+
+#define BSET_OBJ_STORE(obj, ix) \
+ (I32)ix > PL_bytecode_obj_list_fill ? \
+ bset_obj_store(obj, (I32)ix) : (PL_bytecode_obj_list[ix] = obj)
diff --git a/contrib/perl5/bytecode.pl b/contrib/perl5/bytecode.pl
new file mode 100644
index 000000000000..cc096ac1bcfe
--- /dev/null
+++ b/contrib/perl5/bytecode.pl
@@ -0,0 +1,388 @@
+use strict;
+my %alias_to = (
+ U32 => [qw(PADOFFSET STRLEN)],
+ I32 => [qw(SSize_t long)],
+ U16 => [qw(OPCODE line_t short)],
+ U8 => [qw(char)],
+);
+
+my @optype= qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP);
+
+# Nullsv *must* come first in the following so that the condition
+# ($$sv == 0) can continue to be used to test (sv == Nullsv).
+my @specialsv = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no);
+
+my (%alias_from, $from, $tos);
+while (($from, $tos) = each %alias_to) {
+ map { $alias_from{$_} = $from } @$tos;
+}
+
+my $c_header = <<'EOT';
+/*
+ * Copyright (c) 1996-1998 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+/*
+ * This file is autogenerated from bytecode.pl. Changes made here will be lost.
+ */
+EOT
+
+my $perl_header;
+($perl_header = $c_header) =~ s{[/ ]?\*/?}{#}g;
+
+unlink "byterun.c", "byterun.h", "ext/B/B/Asmdata.pm";
+
+#
+# Start with boilerplate for Asmdata.pm
+#
+open(ASMDATA_PM, ">ext/B/B/Asmdata.pm") or die "ext/B/B/Asmdata.pm: $!";
+print ASMDATA_PM $perl_header, <<'EOT';
+package B::Asmdata;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
+use vars qw(%insn_data @insn_name @optype @specialsv_name);
+
+EOT
+print ASMDATA_PM <<"EOT";
+\@optype = qw(@optype);
+\@specialsv_name = qw(@specialsv);
+
+# XXX insn_data is initialised this way because with a large
+# %insn_data = (foo => [...], bar => [...], ...) initialiser
+# I get a hard-to-track-down stack underflow and segfault.
+EOT
+
+#
+# Boilerplate for byterun.c
+#
+open(BYTERUN_C, ">byterun.c") or die "byterun.c: $!";
+print BYTERUN_C $c_header, <<'EOT';
+
+#include "EXTERN.h"
+#include "perl.h"
+
+void *
+bset_obj_store(void *obj, I32 ix)
+{
+ if (ix > PL_bytecode_obj_list_fill) {
+ if (PL_bytecode_obj_list_fill == -1)
+ New(666, PL_bytecode_obj_list, ix + 1, void*);
+ else
+ Renew(PL_bytecode_obj_list, ix + 1, void*);
+ PL_bytecode_obj_list_fill = ix;
+ }
+ PL_bytecode_obj_list[ix] = obj;
+ return obj;
+}
+
+#ifdef INDIRECT_BGET_MACROS
+void byterun(struct bytestream bs)
+#else
+void byterun(PerlIO *fp)
+#endif /* INDIRECT_BGET_MACROS */
+{
+ dTHR;
+ int insn;
+ while ((insn = BGET_FGETC()) != EOF) {
+ switch (insn) {
+EOT
+
+
+my (@insn_name, $insn_num, $insn, $lvalue, $argtype, $flags, $fundtype);
+
+while (<DATA>) {
+ chop;
+ s/#.*//; # remove comments
+ next unless length;
+ if (/^%number\s+(.*)/) {
+ $insn_num = $1;
+ next;
+ } elsif (/%enum\s+(.*?)\s+(.*)/) {
+ create_enum($1, $2); # must come before instructions
+ next;
+ }
+ ($insn, $lvalue, $argtype, $flags) = split;
+ $insn_name[$insn_num] = $insn;
+ $fundtype = $alias_from{$argtype} || $argtype;
+
+ #
+ # Add the case statement and code for the bytecode interpreter in byterun.c
+ #
+ printf BYTERUN_C "\t case INSN_%s:\t\t/* %d */\n\t {\n",
+ uc($insn), $insn_num;
+ my $optarg = $argtype eq "none" ? "" : ", arg";
+ if ($optarg) {
+ printf BYTERUN_C "\t\t$argtype arg;\n\t\tBGET_%s(arg);\n", $fundtype;
+ }
+ if ($flags =~ /x/) {
+ print BYTERUN_C "\t\tBSET_$insn($lvalue$optarg);\n";
+ } elsif ($flags =~ /s/) {
+ # Store instructions store to PL_bytecode_obj_list[arg]. "lvalue" field is rvalue.
+ print BYTERUN_C "\t\tBSET_OBJ_STORE($lvalue$optarg);\n";
+ }
+ elsif ($optarg && $lvalue ne "none") {
+ print BYTERUN_C "\t\t$lvalue = arg;\n";
+ }
+ print BYTERUN_C "\t\tbreak;\n\t }\n";
+
+ #
+ # Add the initialiser line for %insn_data in Asmdata.pm
+ #
+ print ASMDATA_PM <<"EOT";
+\$insn_data{$insn} = [$insn_num, \\&PUT_$fundtype, "GET_$fundtype"];
+EOT
+
+ # Find the next unused instruction number
+ do { $insn_num++ } while $insn_name[$insn_num];
+}
+
+#
+# Finish off byterun.c
+#
+print BYTERUN_C <<'EOT';
+ default:
+ croak("Illegal bytecode instruction %d\n", insn);
+ /* NOTREACHED */
+ }
+ }
+}
+EOT
+
+#
+# Write the instruction and optype enum constants into byterun.h
+#
+open(BYTERUN_H, ">byterun.h") or die "byterun.h: $!";
+print BYTERUN_H $c_header, <<'EOT';
+#ifdef INDIRECT_BGET_MACROS
+struct bytestream {
+ void *data;
+ int (*fgetc)(void *);
+ int (*fread)(char *, size_t, size_t, void*);
+ void (*freadpv)(U32, void*);
+};
+#endif /* INDIRECT_BGET_MACROS */
+
+void *bset_obj_store _((void *, I32));
+
+enum {
+EOT
+
+my $i = 0;
+my $add_enum_value = 0;
+my $max_insn;
+for ($i = 0; $i < @insn_name; $i++) {
+ $insn = uc($insn_name[$i]);
+ if (defined($insn)) {
+ $max_insn = $i;
+ if ($add_enum_value) {
+ print BYTERUN_H " INSN_$insn = $i,\t\t\t/* $i */\n";
+ $add_enum_value = 0;
+ } else {
+ print BYTERUN_H " INSN_$insn,\t\t\t/* $i */\n";
+ }
+ } else {
+ $add_enum_value = 1;
+ }
+}
+
+print BYTERUN_H " MAX_INSN = $max_insn\n};\n";
+
+print BYTERUN_H "\nenum {\n";
+for ($i = 0; $i < @optype - 1; $i++) {
+ printf BYTERUN_H " OPt_%s,\t\t/* %d */\n", $optype[$i], $i;
+}
+printf BYTERUN_H " OPt_%s\t\t/* %d */\n};\n\n", $optype[$i], $i;
+print BYTERUN_H <<'EOT';
+EXT int optype_size[]
+#ifdef DOINIT
+= {
+EOT
+for ($i = 0; $i < @optype - 1; $i++) {
+ printf BYTERUN_H " sizeof(%s),\n", $optype[$i], $i;
+}
+printf BYTERUN_H " sizeof(%s)\n}\n", $optype[$i], $i;
+print BYTERUN_H <<'EOT';
+#endif /* DOINIT */
+;
+
+EOT
+
+print BYTERUN_H <<'EOT';
+#define INIT_SPECIALSV_LIST STMT_START { \
+EOT
+for ($i = 0; $i < @specialsv; $i++) {
+ print BYTERUN_H "\tPL_specialsv_list[$i] = $specialsv[$i]; \\\n";
+}
+print BYTERUN_H <<'EOT';
+ } STMT_END
+EOT
+
+#
+# Finish off insn_data and create array initialisers in Asmdata.pm
+#
+print ASMDATA_PM <<'EOT';
+
+my ($insn_name, $insn_data);
+while (($insn_name, $insn_data) = each %insn_data) {
+ $insn_name[$insn_data->[0]] = $insn_name;
+}
+# Fill in any gaps
+@insn_name = map($_ || "unused", @insn_name);
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode
+
+=head1 SYNOPSIS
+
+ use Asmdata;
+
+=head1 DESCRIPTION
+
+See F<ext/B/B/Asmdata.pm>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
+EOT
+
+__END__
+# First set instruction ord("#") to read comment to end-of-line (sneaky)
+%number 35
+comment arg comment_t
+# Then make ord("\n") into a no-op
+%number 10
+nop none none
+# Now for the rest of the ordinary ones, beginning with \0 which is
+# ret so that \0-terminated strings can be read properly as bytecode.
+%number 0
+#
+#opcode lvalue argtype flags
+#
+ret none none x
+ldsv PL_bytecode_sv svindex
+ldop PL_op opindex
+stsv PL_bytecode_sv U32 s
+stop PL_op U32 s
+ldspecsv PL_bytecode_sv U8 x
+newsv PL_bytecode_sv U8 x
+newop PL_op U8 x
+newopn PL_op U8 x
+newpv none PV
+pv_cur PL_bytecode_pv.xpv_cur STRLEN
+pv_free PL_bytecode_pv none x
+sv_upgrade PL_bytecode_sv char x
+sv_refcnt SvREFCNT(PL_bytecode_sv) U32
+sv_refcnt_add SvREFCNT(PL_bytecode_sv) I32 x
+sv_flags SvFLAGS(PL_bytecode_sv) U32
+xrv SvRV(PL_bytecode_sv) svindex
+xpv PL_bytecode_sv none x
+xiv32 SvIVX(PL_bytecode_sv) I32
+xiv64 SvIVX(PL_bytecode_sv) IV64
+xnv SvNVX(PL_bytecode_sv) double
+xlv_targoff LvTARGOFF(PL_bytecode_sv) STRLEN
+xlv_targlen LvTARGLEN(PL_bytecode_sv) STRLEN
+xlv_targ LvTARG(PL_bytecode_sv) svindex
+xlv_type LvTYPE(PL_bytecode_sv) char
+xbm_useful BmUSEFUL(PL_bytecode_sv) I32
+xbm_previous BmPREVIOUS(PL_bytecode_sv) U16
+xbm_rare BmRARE(PL_bytecode_sv) U8
+xfm_lines FmLINES(PL_bytecode_sv) I32
+xio_lines IoLINES(PL_bytecode_sv) long
+xio_page IoPAGE(PL_bytecode_sv) long
+xio_page_len IoPAGE_LEN(PL_bytecode_sv) long
+xio_lines_left IoLINES_LEFT(PL_bytecode_sv) long
+xio_top_name IoTOP_NAME(PL_bytecode_sv) pvcontents
+xio_top_gv *(SV**)&IoTOP_GV(PL_bytecode_sv) svindex
+xio_fmt_name IoFMT_NAME(PL_bytecode_sv) pvcontents
+xio_fmt_gv *(SV**)&IoFMT_GV(PL_bytecode_sv) svindex
+xio_bottom_name IoBOTTOM_NAME(PL_bytecode_sv) pvcontents
+xio_bottom_gv *(SV**)&IoBOTTOM_GV(PL_bytecode_sv) svindex
+xio_subprocess IoSUBPROCESS(PL_bytecode_sv) short
+xio_type IoTYPE(PL_bytecode_sv) char
+xio_flags IoFLAGS(PL_bytecode_sv) char
+xcv_stash *(SV**)&CvSTASH(PL_bytecode_sv) svindex
+xcv_start CvSTART(PL_bytecode_sv) opindex
+xcv_root CvROOT(PL_bytecode_sv) opindex
+xcv_gv *(SV**)&CvGV(PL_bytecode_sv) svindex
+xcv_filegv *(SV**)&CvFILEGV(PL_bytecode_sv) svindex
+xcv_depth CvDEPTH(PL_bytecode_sv) long
+xcv_padlist *(SV**)&CvPADLIST(PL_bytecode_sv) svindex
+xcv_outside *(SV**)&CvOUTSIDE(PL_bytecode_sv) svindex
+xcv_flags CvFLAGS(PL_bytecode_sv) U8
+av_extend PL_bytecode_sv SSize_t x
+av_push PL_bytecode_sv svindex x
+xav_fill AvFILLp(PL_bytecode_sv) SSize_t
+xav_max AvMAX(PL_bytecode_sv) SSize_t
+xav_flags AvFLAGS(PL_bytecode_sv) U8
+xhv_riter HvRITER(PL_bytecode_sv) I32
+xhv_name HvNAME(PL_bytecode_sv) pvcontents
+hv_store PL_bytecode_sv svindex x
+sv_magic PL_bytecode_sv char x
+mg_obj SvMAGIC(PL_bytecode_sv)->mg_obj svindex
+mg_private SvMAGIC(PL_bytecode_sv)->mg_private U16
+mg_flags SvMAGIC(PL_bytecode_sv)->mg_flags U8
+mg_pv SvMAGIC(PL_bytecode_sv) pvcontents x
+xmg_stash *(SV**)&SvSTASH(PL_bytecode_sv) svindex
+gv_fetchpv PL_bytecode_sv strconst x
+gv_stashpv PL_bytecode_sv strconst x
+gp_sv GvSV(PL_bytecode_sv) svindex
+gp_refcnt GvREFCNT(PL_bytecode_sv) U32
+gp_refcnt_add GvREFCNT(PL_bytecode_sv) I32 x
+gp_av *(SV**)&GvAV(PL_bytecode_sv) svindex
+gp_hv *(SV**)&GvHV(PL_bytecode_sv) svindex
+gp_cv *(SV**)&GvCV(PL_bytecode_sv) svindex
+gp_filegv *(SV**)&GvFILEGV(PL_bytecode_sv) svindex
+gp_io *(SV**)&GvIOp(PL_bytecode_sv) svindex
+gp_form *(SV**)&GvFORM(PL_bytecode_sv) svindex
+gp_cvgen GvCVGEN(PL_bytecode_sv) U32
+gp_line GvLINE(PL_bytecode_sv) line_t
+gp_share PL_bytecode_sv svindex x
+xgv_flags GvFLAGS(PL_bytecode_sv) U8
+op_next PL_op->op_next opindex
+op_sibling PL_op->op_sibling opindex
+op_ppaddr PL_op->op_ppaddr strconst x
+op_targ PL_op->op_targ PADOFFSET
+op_type PL_op OPCODE x
+op_seq PL_op->op_seq U16
+op_flags PL_op->op_flags U8
+op_private PL_op->op_private U8
+op_first cUNOP->op_first opindex
+op_last cBINOP->op_last opindex
+op_other cLOGOP->op_other opindex
+op_true cCONDOP->op_true opindex
+op_false cCONDOP->op_false opindex
+op_children cLISTOP->op_children U32
+op_pmreplroot cPMOP->op_pmreplroot opindex
+op_pmreplrootgv *(SV**)&cPMOP->op_pmreplroot svindex
+op_pmreplstart cPMOP->op_pmreplstart opindex
+op_pmnext *(OP**)&cPMOP->op_pmnext opindex
+pregcomp PL_op pvcontents x
+op_pmflags cPMOP->op_pmflags U16
+op_pmpermflags cPMOP->op_pmpermflags U16
+op_sv cSVOP->op_sv svindex
+op_gv *(SV**)&cGVOP->op_gv svindex
+op_pv cPVOP->op_pv pvcontents
+op_pv_tr cPVOP->op_pv op_tr_array
+op_redoop cLOOP->op_redoop opindex
+op_nextop cLOOP->op_nextop opindex
+op_lastop cLOOP->op_lastop opindex
+cop_label cCOP->cop_label pvcontents
+cop_stash *(SV**)&cCOP->cop_stash svindex
+cop_filegv *(SV**)&cCOP->cop_filegv svindex
+cop_seq cCOP->cop_seq U32
+cop_arybase cCOP->cop_arybase I32
+cop_line cCOP->cop_line line_t
+main_start PL_main_start opindex
+main_root PL_main_root opindex
+curpad PL_curpad svindex x
diff --git a/contrib/perl5/byterun.c b/contrib/perl5/byterun.c
new file mode 100644
index 000000000000..34beaf4f4b96
--- /dev/null
+++ b/contrib/perl5/byterun.c
@@ -0,0 +1,867 @@
+/*
+ * Copyright (c) 1996-1998 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+/*
+ * This file is autogenerated from bytecode.pl. Changes made here will be lost.
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+void *
+bset_obj_store(void *obj, I32 ix)
+{
+ if (ix > PL_bytecode_obj_list_fill) {
+ if (PL_bytecode_obj_list_fill == -1)
+ New(666, PL_bytecode_obj_list, ix + 1, void*);
+ else
+ Renew(PL_bytecode_obj_list, ix + 1, void*);
+ PL_bytecode_obj_list_fill = ix;
+ }
+ PL_bytecode_obj_list[ix] = obj;
+ return obj;
+}
+
+#ifdef INDIRECT_BGET_MACROS
+void byterun(struct bytestream bs)
+#else
+void byterun(PerlIO *fp)
+#endif /* INDIRECT_BGET_MACROS */
+{
+ dTHR;
+ int insn;
+ while ((insn = BGET_FGETC()) != EOF) {
+ switch (insn) {
+ case INSN_COMMENT: /* 35 */
+ {
+ comment_t arg;
+ BGET_comment_t(arg);
+ arg = arg;
+ break;
+ }
+ case INSN_NOP: /* 10 */
+ {
+ break;
+ }
+ case INSN_RET: /* 0 */
+ {
+ BSET_ret(none);
+ break;
+ }
+ case INSN_LDSV: /* 1 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ PL_bytecode_sv = arg;
+ break;
+ }
+ case INSN_LDOP: /* 2 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ PL_op = arg;
+ break;
+ }
+ case INSN_STSV: /* 3 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ BSET_OBJ_STORE(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_STOP: /* 4 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ BSET_OBJ_STORE(PL_op, arg);
+ break;
+ }
+ case INSN_LDSPECSV: /* 5 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ BSET_ldspecsv(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_NEWSV: /* 6 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ BSET_newsv(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_NEWOP: /* 7 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ BSET_newop(PL_op, arg);
+ break;
+ }
+ case INSN_NEWOPN: /* 8 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ BSET_newopn(PL_op, arg);
+ break;
+ }
+ case INSN_NEWPV: /* 9 */
+ {
+ PV arg;
+ BGET_PV(arg);
+ break;
+ }
+ case INSN_PV_CUR: /* 11 */
+ {
+ STRLEN arg;
+ BGET_U32(arg);
+ PL_bytecode_pv.xpv_cur = arg;
+ break;
+ }
+ case INSN_PV_FREE: /* 12 */
+ {
+ BSET_pv_free(PL_bytecode_pv);
+ break;
+ }
+ case INSN_SV_UPGRADE: /* 13 */
+ {
+ char arg;
+ BGET_U8(arg);
+ BSET_sv_upgrade(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_SV_REFCNT: /* 14 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ SvREFCNT(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_SV_REFCNT_ADD: /* 15 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ BSET_sv_refcnt_add(SvREFCNT(PL_bytecode_sv), arg);
+ break;
+ }
+ case INSN_SV_FLAGS: /* 16 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ SvFLAGS(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XRV: /* 17 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ SvRV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XPV: /* 18 */
+ {
+ BSET_xpv(PL_bytecode_sv);
+ break;
+ }
+ case INSN_XIV32: /* 19 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ SvIVX(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIV64: /* 20 */
+ {
+ IV64 arg;
+ BGET_IV64(arg);
+ SvIVX(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XNV: /* 21 */
+ {
+ double arg;
+ BGET_double(arg);
+ SvNVX(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XLV_TARGOFF: /* 22 */
+ {
+ STRLEN arg;
+ BGET_U32(arg);
+ LvTARGOFF(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XLV_TARGLEN: /* 23 */
+ {
+ STRLEN arg;
+ BGET_U32(arg);
+ LvTARGLEN(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XLV_TARG: /* 24 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ LvTARG(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XLV_TYPE: /* 25 */
+ {
+ char arg;
+ BGET_U8(arg);
+ LvTYPE(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XBM_USEFUL: /* 26 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ BmUSEFUL(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XBM_PREVIOUS: /* 27 */
+ {
+ U16 arg;
+ BGET_U16(arg);
+ BmPREVIOUS(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XBM_RARE: /* 28 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ BmRARE(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XFM_LINES: /* 29 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ FmLINES(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_LINES: /* 30 */
+ {
+ long arg;
+ BGET_I32(arg);
+ IoLINES(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_PAGE: /* 31 */
+ {
+ long arg;
+ BGET_I32(arg);
+ IoPAGE(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_PAGE_LEN: /* 32 */
+ {
+ long arg;
+ BGET_I32(arg);
+ IoPAGE_LEN(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_LINES_LEFT: /* 33 */
+ {
+ long arg;
+ BGET_I32(arg);
+ IoLINES_LEFT(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_TOP_NAME: /* 34 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ IoTOP_NAME(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_TOP_GV: /* 36 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&IoTOP_GV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_FMT_NAME: /* 37 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ IoFMT_NAME(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_FMT_GV: /* 38 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&IoFMT_GV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_BOTTOM_NAME: /* 39 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ IoBOTTOM_NAME(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_BOTTOM_GV: /* 40 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&IoBOTTOM_GV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_SUBPROCESS: /* 41 */
+ {
+ short arg;
+ BGET_U16(arg);
+ IoSUBPROCESS(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_TYPE: /* 42 */
+ {
+ char arg;
+ BGET_U8(arg);
+ IoTYPE(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XIO_FLAGS: /* 43 */
+ {
+ char arg;
+ BGET_U8(arg);
+ IoFLAGS(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XCV_STASH: /* 44 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&CvSTASH(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XCV_START: /* 45 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ CvSTART(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XCV_ROOT: /* 46 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ CvROOT(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XCV_GV: /* 47 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&CvGV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XCV_FILEGV: /* 48 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&CvFILEGV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XCV_DEPTH: /* 49 */
+ {
+ long arg;
+ BGET_I32(arg);
+ CvDEPTH(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XCV_PADLIST: /* 50 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&CvPADLIST(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XCV_OUTSIDE: /* 51 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&CvOUTSIDE(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XCV_FLAGS: /* 52 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ CvFLAGS(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_AV_EXTEND: /* 53 */
+ {
+ SSize_t arg;
+ BGET_I32(arg);
+ BSET_av_extend(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_AV_PUSH: /* 54 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ BSET_av_push(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_XAV_FILL: /* 55 */
+ {
+ SSize_t arg;
+ BGET_I32(arg);
+ AvFILLp(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XAV_MAX: /* 56 */
+ {
+ SSize_t arg;
+ BGET_I32(arg);
+ AvMAX(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XAV_FLAGS: /* 57 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ AvFLAGS(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XHV_RITER: /* 58 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ HvRITER(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_XHV_NAME: /* 59 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ HvNAME(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_HV_STORE: /* 60 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ BSET_hv_store(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_SV_MAGIC: /* 61 */
+ {
+ char arg;
+ BGET_U8(arg);
+ BSET_sv_magic(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_MG_OBJ: /* 62 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ SvMAGIC(PL_bytecode_sv)->mg_obj = arg;
+ break;
+ }
+ case INSN_MG_PRIVATE: /* 63 */
+ {
+ U16 arg;
+ BGET_U16(arg);
+ SvMAGIC(PL_bytecode_sv)->mg_private = arg;
+ break;
+ }
+ case INSN_MG_FLAGS: /* 64 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ SvMAGIC(PL_bytecode_sv)->mg_flags = arg;
+ break;
+ }
+ case INSN_MG_PV: /* 65 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ BSET_mg_pv(SvMAGIC(PL_bytecode_sv), arg);
+ break;
+ }
+ case INSN_XMG_STASH: /* 66 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&SvSTASH(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GV_FETCHPV: /* 67 */
+ {
+ strconst arg;
+ BGET_strconst(arg);
+ BSET_gv_fetchpv(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_GV_STASHPV: /* 68 */
+ {
+ strconst arg;
+ BGET_strconst(arg);
+ BSET_gv_stashpv(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_GP_SV: /* 69 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ GvSV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GP_REFCNT: /* 70 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ GvREFCNT(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GP_REFCNT_ADD: /* 71 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ BSET_gp_refcnt_add(GvREFCNT(PL_bytecode_sv), arg);
+ break;
+ }
+ case INSN_GP_AV: /* 72 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&GvAV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GP_HV: /* 73 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&GvHV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GP_CV: /* 74 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&GvCV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GP_FILEGV: /* 75 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&GvFILEGV(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GP_IO: /* 76 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&GvIOp(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GP_FORM: /* 77 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&GvFORM(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GP_CVGEN: /* 78 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ GvCVGEN(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GP_LINE: /* 79 */
+ {
+ line_t arg;
+ BGET_U16(arg);
+ GvLINE(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_GP_SHARE: /* 80 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ BSET_gp_share(PL_bytecode_sv, arg);
+ break;
+ }
+ case INSN_XGV_FLAGS: /* 81 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ GvFLAGS(PL_bytecode_sv) = arg;
+ break;
+ }
+ case INSN_OP_NEXT: /* 82 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ PL_op->op_next = arg;
+ break;
+ }
+ case INSN_OP_SIBLING: /* 83 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ PL_op->op_sibling = arg;
+ break;
+ }
+ case INSN_OP_PPADDR: /* 84 */
+ {
+ strconst arg;
+ BGET_strconst(arg);
+ BSET_op_ppaddr(PL_op->op_ppaddr, arg);
+ break;
+ }
+ case INSN_OP_TARG: /* 85 */
+ {
+ PADOFFSET arg;
+ BGET_U32(arg);
+ PL_op->op_targ = arg;
+ break;
+ }
+ case INSN_OP_TYPE: /* 86 */
+ {
+ OPCODE arg;
+ BGET_U16(arg);
+ BSET_op_type(PL_op, arg);
+ break;
+ }
+ case INSN_OP_SEQ: /* 87 */
+ {
+ U16 arg;
+ BGET_U16(arg);
+ PL_op->op_seq = arg;
+ break;
+ }
+ case INSN_OP_FLAGS: /* 88 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ PL_op->op_flags = arg;
+ break;
+ }
+ case INSN_OP_PRIVATE: /* 89 */
+ {
+ U8 arg;
+ BGET_U8(arg);
+ PL_op->op_private = arg;
+ break;
+ }
+ case INSN_OP_FIRST: /* 90 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ cUNOP->op_first = arg;
+ break;
+ }
+ case INSN_OP_LAST: /* 91 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ cBINOP->op_last = arg;
+ break;
+ }
+ case INSN_OP_OTHER: /* 92 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ cLOGOP->op_other = arg;
+ break;
+ }
+ case INSN_OP_TRUE: /* 93 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ cCONDOP->op_true = arg;
+ break;
+ }
+ case INSN_OP_FALSE: /* 94 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ cCONDOP->op_false = arg;
+ break;
+ }
+ case INSN_OP_CHILDREN: /* 95 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ cLISTOP->op_children = arg;
+ break;
+ }
+ case INSN_OP_PMREPLROOT: /* 96 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ cPMOP->op_pmreplroot = arg;
+ break;
+ }
+ case INSN_OP_PMREPLROOTGV: /* 97 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&cPMOP->op_pmreplroot = arg;
+ break;
+ }
+ case INSN_OP_PMREPLSTART: /* 98 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ cPMOP->op_pmreplstart = arg;
+ break;
+ }
+ case INSN_OP_PMNEXT: /* 99 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ *(OP**)&cPMOP->op_pmnext = arg;
+ break;
+ }
+ case INSN_PREGCOMP: /* 100 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ BSET_pregcomp(PL_op, arg);
+ break;
+ }
+ case INSN_OP_PMFLAGS: /* 101 */
+ {
+ U16 arg;
+ BGET_U16(arg);
+ cPMOP->op_pmflags = arg;
+ break;
+ }
+ case INSN_OP_PMPERMFLAGS: /* 102 */
+ {
+ U16 arg;
+ BGET_U16(arg);
+ cPMOP->op_pmpermflags = arg;
+ break;
+ }
+ case INSN_OP_SV: /* 103 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ cSVOP->op_sv = arg;
+ break;
+ }
+ case INSN_OP_GV: /* 104 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&cGVOP->op_gv = arg;
+ break;
+ }
+ case INSN_OP_PV: /* 105 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ cPVOP->op_pv = arg;
+ break;
+ }
+ case INSN_OP_PV_TR: /* 106 */
+ {
+ op_tr_array arg;
+ BGET_op_tr_array(arg);
+ cPVOP->op_pv = arg;
+ break;
+ }
+ case INSN_OP_REDOOP: /* 107 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ cLOOP->op_redoop = arg;
+ break;
+ }
+ case INSN_OP_NEXTOP: /* 108 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ cLOOP->op_nextop = arg;
+ break;
+ }
+ case INSN_OP_LASTOP: /* 109 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ cLOOP->op_lastop = arg;
+ break;
+ }
+ case INSN_COP_LABEL: /* 110 */
+ {
+ pvcontents arg;
+ BGET_pvcontents(arg);
+ cCOP->cop_label = arg;
+ break;
+ }
+ case INSN_COP_STASH: /* 111 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&cCOP->cop_stash = arg;
+ break;
+ }
+ case INSN_COP_FILEGV: /* 112 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ *(SV**)&cCOP->cop_filegv = arg;
+ break;
+ }
+ case INSN_COP_SEQ: /* 113 */
+ {
+ U32 arg;
+ BGET_U32(arg);
+ cCOP->cop_seq = arg;
+ break;
+ }
+ case INSN_COP_ARYBASE: /* 114 */
+ {
+ I32 arg;
+ BGET_I32(arg);
+ cCOP->cop_arybase = arg;
+ break;
+ }
+ case INSN_COP_LINE: /* 115 */
+ {
+ line_t arg;
+ BGET_U16(arg);
+ cCOP->cop_line = arg;
+ break;
+ }
+ case INSN_MAIN_START: /* 116 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ PL_main_start = arg;
+ break;
+ }
+ case INSN_MAIN_ROOT: /* 117 */
+ {
+ opindex arg;
+ BGET_opindex(arg);
+ PL_main_root = arg;
+ break;
+ }
+ case INSN_CURPAD: /* 118 */
+ {
+ svindex arg;
+ BGET_svindex(arg);
+ BSET_curpad(PL_curpad, arg);
+ break;
+ }
+ default:
+ croak("Illegal bytecode instruction %d\n", insn);
+ /* NOTREACHED */
+ }
+ }
+}
diff --git a/contrib/perl5/byterun.h b/contrib/perl5/byterun.h
new file mode 100644
index 000000000000..bd54c76e7635
--- /dev/null
+++ b/contrib/perl5/byterun.h
@@ -0,0 +1,184 @@
+/*
+ * Copyright (c) 1996-1998 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+/*
+ * This file is autogenerated from bytecode.pl. Changes made here will be lost.
+ */
+#ifdef INDIRECT_BGET_MACROS
+struct bytestream {
+ void *data;
+ int (*fgetc)(void *);
+ int (*fread)(char *, size_t, size_t, void*);
+ void (*freadpv)(U32, void*);
+};
+#endif /* INDIRECT_BGET_MACROS */
+
+void *bset_obj_store _((void *, I32));
+
+enum {
+ INSN_RET, /* 0 */
+ INSN_LDSV, /* 1 */
+ INSN_LDOP, /* 2 */
+ INSN_STSV, /* 3 */
+ INSN_STOP, /* 4 */
+ INSN_LDSPECSV, /* 5 */
+ INSN_NEWSV, /* 6 */
+ INSN_NEWOP, /* 7 */
+ INSN_NEWOPN, /* 8 */
+ INSN_NEWPV, /* 9 */
+ INSN_NOP, /* 10 */
+ INSN_PV_CUR, /* 11 */
+ INSN_PV_FREE, /* 12 */
+ INSN_SV_UPGRADE, /* 13 */
+ INSN_SV_REFCNT, /* 14 */
+ INSN_SV_REFCNT_ADD, /* 15 */
+ INSN_SV_FLAGS, /* 16 */
+ INSN_XRV, /* 17 */
+ INSN_XPV, /* 18 */
+ INSN_XIV32, /* 19 */
+ INSN_XIV64, /* 20 */
+ INSN_XNV, /* 21 */
+ INSN_XLV_TARGOFF, /* 22 */
+ INSN_XLV_TARGLEN, /* 23 */
+ INSN_XLV_TARG, /* 24 */
+ INSN_XLV_TYPE, /* 25 */
+ INSN_XBM_USEFUL, /* 26 */
+ INSN_XBM_PREVIOUS, /* 27 */
+ INSN_XBM_RARE, /* 28 */
+ INSN_XFM_LINES, /* 29 */
+ INSN_XIO_LINES, /* 30 */
+ INSN_XIO_PAGE, /* 31 */
+ INSN_XIO_PAGE_LEN, /* 32 */
+ INSN_XIO_LINES_LEFT, /* 33 */
+ INSN_XIO_TOP_NAME, /* 34 */
+ INSN_COMMENT, /* 35 */
+ INSN_XIO_TOP_GV, /* 36 */
+ INSN_XIO_FMT_NAME, /* 37 */
+ INSN_XIO_FMT_GV, /* 38 */
+ INSN_XIO_BOTTOM_NAME, /* 39 */
+ INSN_XIO_BOTTOM_GV, /* 40 */
+ INSN_XIO_SUBPROCESS, /* 41 */
+ INSN_XIO_TYPE, /* 42 */
+ INSN_XIO_FLAGS, /* 43 */
+ INSN_XCV_STASH, /* 44 */
+ INSN_XCV_START, /* 45 */
+ INSN_XCV_ROOT, /* 46 */
+ INSN_XCV_GV, /* 47 */
+ INSN_XCV_FILEGV, /* 48 */
+ INSN_XCV_DEPTH, /* 49 */
+ INSN_XCV_PADLIST, /* 50 */
+ INSN_XCV_OUTSIDE, /* 51 */
+ INSN_XCV_FLAGS, /* 52 */
+ INSN_AV_EXTEND, /* 53 */
+ INSN_AV_PUSH, /* 54 */
+ INSN_XAV_FILL, /* 55 */
+ INSN_XAV_MAX, /* 56 */
+ INSN_XAV_FLAGS, /* 57 */
+ INSN_XHV_RITER, /* 58 */
+ INSN_XHV_NAME, /* 59 */
+ INSN_HV_STORE, /* 60 */
+ INSN_SV_MAGIC, /* 61 */
+ INSN_MG_OBJ, /* 62 */
+ INSN_MG_PRIVATE, /* 63 */
+ INSN_MG_FLAGS, /* 64 */
+ INSN_MG_PV, /* 65 */
+ INSN_XMG_STASH, /* 66 */
+ INSN_GV_FETCHPV, /* 67 */
+ INSN_GV_STASHPV, /* 68 */
+ INSN_GP_SV, /* 69 */
+ INSN_GP_REFCNT, /* 70 */
+ INSN_GP_REFCNT_ADD, /* 71 */
+ INSN_GP_AV, /* 72 */
+ INSN_GP_HV, /* 73 */
+ INSN_GP_CV, /* 74 */
+ INSN_GP_FILEGV, /* 75 */
+ INSN_GP_IO, /* 76 */
+ INSN_GP_FORM, /* 77 */
+ INSN_GP_CVGEN, /* 78 */
+ INSN_GP_LINE, /* 79 */
+ INSN_GP_SHARE, /* 80 */
+ INSN_XGV_FLAGS, /* 81 */
+ INSN_OP_NEXT, /* 82 */
+ INSN_OP_SIBLING, /* 83 */
+ INSN_OP_PPADDR, /* 84 */
+ INSN_OP_TARG, /* 85 */
+ INSN_OP_TYPE, /* 86 */
+ INSN_OP_SEQ, /* 87 */
+ INSN_OP_FLAGS, /* 88 */
+ INSN_OP_PRIVATE, /* 89 */
+ INSN_OP_FIRST, /* 90 */
+ INSN_OP_LAST, /* 91 */
+ INSN_OP_OTHER, /* 92 */
+ INSN_OP_TRUE, /* 93 */
+ INSN_OP_FALSE, /* 94 */
+ INSN_OP_CHILDREN, /* 95 */
+ INSN_OP_PMREPLROOT, /* 96 */
+ INSN_OP_PMREPLROOTGV, /* 97 */
+ INSN_OP_PMREPLSTART, /* 98 */
+ INSN_OP_PMNEXT, /* 99 */
+ INSN_PREGCOMP, /* 100 */
+ INSN_OP_PMFLAGS, /* 101 */
+ INSN_OP_PMPERMFLAGS, /* 102 */
+ INSN_OP_SV, /* 103 */
+ INSN_OP_GV, /* 104 */
+ INSN_OP_PV, /* 105 */
+ INSN_OP_PV_TR, /* 106 */
+ INSN_OP_REDOOP, /* 107 */
+ INSN_OP_NEXTOP, /* 108 */
+ INSN_OP_LASTOP, /* 109 */
+ INSN_COP_LABEL, /* 110 */
+ INSN_COP_STASH, /* 111 */
+ INSN_COP_FILEGV, /* 112 */
+ INSN_COP_SEQ, /* 113 */
+ INSN_COP_ARYBASE, /* 114 */
+ INSN_COP_LINE, /* 115 */
+ INSN_MAIN_START, /* 116 */
+ INSN_MAIN_ROOT, /* 117 */
+ INSN_CURPAD, /* 118 */
+ MAX_INSN = 118
+};
+
+enum {
+ OPt_OP, /* 0 */
+ OPt_UNOP, /* 1 */
+ OPt_BINOP, /* 2 */
+ OPt_LOGOP, /* 3 */
+ OPt_CONDOP, /* 4 */
+ OPt_LISTOP, /* 5 */
+ OPt_PMOP, /* 6 */
+ OPt_SVOP, /* 7 */
+ OPt_GVOP, /* 8 */
+ OPt_PVOP, /* 9 */
+ OPt_LOOP, /* 10 */
+ OPt_COP /* 11 */
+};
+
+EXT int optype_size[]
+#ifdef DOINIT
+= {
+ sizeof(OP),
+ sizeof(UNOP),
+ sizeof(BINOP),
+ sizeof(LOGOP),
+ sizeof(CONDOP),
+ sizeof(LISTOP),
+ sizeof(PMOP),
+ sizeof(SVOP),
+ sizeof(GVOP),
+ sizeof(PVOP),
+ sizeof(LOOP),
+ sizeof(COP)
+}
+#endif /* DOINIT */
+;
+
+#define INIT_SPECIALSV_LIST STMT_START { \
+ PL_specialsv_list[0] = Nullsv; \
+ PL_specialsv_list[1] = &PL_sv_undef; \
+ PL_specialsv_list[2] = &PL_sv_yes; \
+ PL_specialsv_list[3] = &PL_sv_no; \
+ } STMT_END
diff --git a/contrib/perl5/cc_runtime.h b/contrib/perl5/cc_runtime.h
new file mode 100644
index 000000000000..18e3ba2c083d
--- /dev/null
+++ b/contrib/perl5/cc_runtime.h
@@ -0,0 +1,71 @@
+#define DOOP(ppname) PUTBACK; PL_op = ppname(ARGS); SPAGAIN
+
+#define PP_LIST(g) do { \
+ dMARK; \
+ if (g != G_ARRAY) { \
+ if (++MARK <= SP) \
+ *MARK = *SP; \
+ else \
+ *MARK = &PL_sv_undef; \
+ SP = MARK; \
+ } \
+ } while (0)
+
+#define MAYBE_TAINT_SASSIGN_SRC(sv) \
+ if (PL_tainting && PL_tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) || \
+ !((mg=mg_find(left, 't')) && mg->mg_len & 1)))\
+ TAINT_NOT
+
+#define PP_PREINC(sv) do { \
+ if (SvIOK(sv)) { \
+ ++SvIVX(sv); \
+ SvFLAGS(sv) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); \
+ } \
+ else \
+ sv_inc(sv); \
+ SvSETMAGIC(sv); \
+ } while (0)
+
+#define PP_UNSTACK do { \
+ TAINT_NOT; \
+ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; \
+ FREETMPS; \
+ oldsave = PL_scopestack[PL_scopestack_ix - 1]; \
+ LEAVE_SCOPE(oldsave); \
+ SPAGAIN; \
+ } while(0)
+
+/* Anyone using eval "" deserves this mess */
+#define PP_EVAL(ppaddr, nxt) do { \
+ dJMPENV; \
+ int ret; \
+ PUTBACK; \
+ JMPENV_PUSH(ret); \
+ switch (ret) { \
+ case 0: \
+ PL_op = ppaddr(ARGS); \
+ PL_retstack[PL_retstack_ix - 1] = Nullop; \
+ if (PL_op != nxt) runops(); \
+ JMPENV_POP; \
+ break; \
+ case 1: JMPENV_POP; JMPENV_JUMP(1); \
+ case 2: JMPENV_POP; JMPENV_JUMP(2); \
+ case 3: \
+ JMPENV_POP; \
+ if (PL_restartop != nxt) \
+ JMPENV_JUMP(3); \
+ } \
+ PL_op = nxt; \
+ SPAGAIN; \
+ } while (0)
+
+#define PP_ENTERTRY(jmpbuf,label) do { \
+ dJMPENV; \
+ int ret; \
+ JMPENV_PUSH(ret); \
+ switch (ret) { \
+ case 1: JMPENV_POP; JMPENV_JUMP(1); \
+ case 2: JMPENV_POP; JMPENV_JUMP(2); \
+ case 3: JMPENV_POP; SPAGAIN; goto label;\
+ } \
+ } while (0)
diff --git a/contrib/perl5/cflags.SH b/contrib/perl5/cflags.SH
new file mode 100755
index 000000000000..8a1ba8295c89
--- /dev/null
+++ b/contrib/perl5/cflags.SH
@@ -0,0 +1,136 @@
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting cflags (with variable substitutions)"
+: This section of the file will have variable substitutions done on it.
+: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
+: Protect any dollar signs and backticks that you do not want interpreted
+: by putting a backslash in front. You may delete these comments.
+rm -f cflags
+$spitshell >cflags <<!GROK!THIS!
+$startsh
+!GROK!THIS!
+
+: In the following dollars and backticks do not need the extra backslash.
+$spitshell >>cflags <<'!NO!SUBS!'
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+
+perltype=''
+optdebug='' # ensure -g used if building a -DDEBUGGING libperl
+case $# in
+2) case $1 in
+ *perl.*) perltype='';;
+ *perld.*) perltype='-DDEBUGGING'; optdebug='-g' ;;
+ *perle.*) perltype='-DEMBED';;
+ *perlde.*) perltype='-DDEBUGGING -DEMBED'; optdebug='-g' ;;
+ *perlm.*) perltype='-DEMBED -DMULTIPLICITY';;
+ *perldm.*) perltype='-DDEBUGGING -DEMBED -DMULTIPLICITY'; optdebug='-g' ;;
+ esac
+ shift ;;
+esac
+
+also=': '
+case $# in
+1) also='echo 1>&2 " CCCMD = "'
+esac
+
+case $# in
+0) set *.c; echo "The current C flags are:" ;;
+esac
+
+set `echo "$* " | sed -e 's/\.[oc] / /g' -e 's/\.obj / /g'`
+
+for file do
+
+ case "$#" in
+ 1) ;;
+ *) echo $n " $file.c $c" ;;
+ esac
+
+ : allow variables like toke_cflags to be evaluated
+
+ eval 'eval ${'"${file}_cflags"'-""}'
+
+ : or customize here
+
+ case "$file" in
+ DB_File) ;;
+ GDBM_File) ;;
+ NDBM_File) ;;
+ ODBM_File) ;;
+ POSIX) ;;
+ SDBM_File) ;;
+ av) ;;
+ byterun) ;;
+ deb) ;;
+ dl) ;;
+ doio) ;;
+ doop) ;;
+ dump) ;;
+ gv) ;;
+ hv) ;;
+ main) ;;
+ malloc) ;;
+ mg) ;;
+ miniperlmain) ;;
+ op) ;;
+ perl) ;;
+ perlmain) ;;
+ perly) ;;
+ pp) ;;
+ pp_ctl) ;;
+ pp_hot) ;;
+ pp_sys) ;;
+ regcomp) ;;
+ regexec) ;;
+ run) ;;
+ scope) ;;
+ sv) ;;
+ taint) ;;
+ toke) ;;
+ usersub) ;;
+ util) ;;
+ *) ;;
+ esac
+
+ if test "X$optdebug" != "X"; then
+ optimize="$optdebug"
+ fi
+
+ : Can we perhaps use $ansi2knr here
+ echo "$cc -c -DPERL_CORE $ccflags $optimize $perltype $large $split"
+ eval "$also "'"$cc -DPERL_CORE -c $ccflags $optimize $perltype $large $split"'
+
+ . $TOP/config.sh
+
+done
+!NO!SUBS!
+chmod 755 cflags
+$eunicefix cflags
diff --git a/contrib/perl5/config_h.SH b/contrib/perl5/config_h.SH
new file mode 100755
index 000000000000..49f86c7de749
--- /dev/null
+++ b/contrib/perl5/config_h.SH
@@ -0,0 +1,2118 @@
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting config.h (with variable substitutions)"
+sed <<!GROK!THIS! >config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-def!#undef!'
+/*
+ * This file was produced by running the config_h.SH script, which
+ * gets its values from config.sh, which is generally produced by
+ * running Configure.
+ *
+ * Feel free to modify any of this as the need arises. Note, however,
+ * that running config_h.SH again will wipe out any changes you've made.
+ * For a more permanent change edit config.sh and rerun config_h.SH.
+ *
+ * \$Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $
+ */
+
+/*
+ * Package name : $package
+ * Source directory : $src
+ * Configuration time: $cf_time
+ * Configured by : $cf_by
+ * Target system : $myuname
+ */
+
+#ifndef _config_h_
+#define _config_h_
+
+/* LOC_SED:
+ * This symbol holds the complete pathname to the sed program.
+ */
+#define LOC_SED "$full_sed" /**/
+
+/* BIN:
+ * This symbol holds the path of the bin directory where the package will
+ * be installed. Program must be prepared to deal with ~name substitution.
+ */
+/* BIN_EXP:
+ * This symbol is the filename expanded version of the BIN symbol, for
+ * programs that do not want to deal with that at run-time.
+ */
+#define BIN "$bin" /**/
+#define BIN_EXP "$binexp" /**/
+
+/* CPPSTDIN:
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp", but it can also
+ * call a wrapper. See CPPRUN.
+ */
+/* CPPMINUS:
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+#define CPPSTDIN "$cppstdin"
+#define CPPMINUS "$cppminus"
+
+/* HAS_ALARM:
+ * This symbol, if defined, indicates that the alarm routine is
+ * available.
+ */
+#$d_alarm HAS_ALARM /**/
+
+/* HASATTRIBUTE:
+ * This symbol indicates the C compiler can check for function attributes,
+ * such as printf formats. This is normally only supported by GNU cc.
+ */
+#$d_attribut HASATTRIBUTE /**/
+#ifndef HASATTRIBUTE
+#define __attribute__(_arg_)
+#endif
+
+/* HAS_BCMP:
+ * This symbol is defined if the bcmp() routine is available to
+ * compare blocks of memory.
+ */
+#$d_bcmp HAS_BCMP /**/
+
+/* HAS_BCOPY:
+ * This symbol is defined if the bcopy() routine is available to
+ * copy blocks of memory.
+ */
+#$d_bcopy HAS_BCOPY /**/
+
+/* HAS_BZERO:
+ * This symbol is defined if the bzero() routine is available to
+ * set a memory block to 0.
+ */
+#$d_bzero HAS_BZERO /**/
+
+/* HAS_CHOWN:
+ * This symbol, if defined, indicates that the chown routine is
+ * available.
+ */
+#$d_chown HAS_CHOWN /**/
+
+/* HAS_CHROOT:
+ * This symbol, if defined, indicates that the chroot routine is
+ * available.
+ */
+#$d_chroot HAS_CHROOT /**/
+
+/* HAS_CHSIZE:
+ * This symbol, if defined, indicates that the chsize routine is available
+ * to truncate files. You might need a -lx to get this routine.
+ */
+#$d_chsize HAS_CHSIZE /**/
+
+/* HASCONST:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the const type. There is no need to actually test for that symbol
+ * within your programs. The mere use of the "const" keyword will
+ * trigger the necessary tests.
+ */
+#$d_const HASCONST /**/
+#ifndef HASCONST
+#define const
+#endif
+
+/* HAS_CRYPT:
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+#$d_crypt HAS_CRYPT /**/
+
+/* HAS_CUSERID:
+ * This symbol, if defined, indicates that the cuserid routine is
+ * available to get character login names.
+ */
+#$d_cuserid HAS_CUSERID /**/
+
+/* HAS_DBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol DBL_DIG, which is the number
+ * of significant digits in a double precision number. If this
+ * symbol is not defined, a guess of 15 is usually pretty good.
+ */
+#$d_dbl_dig HAS_DBL_DIG /* */
+
+/* HAS_DIFFTIME:
+ * This symbol, if defined, indicates that the difftime routine is
+ * available.
+ */
+#$d_difftime HAS_DIFFTIME /**/
+
+/* HAS_DLERROR:
+ * This symbol, if defined, indicates that the dlerror routine is
+ * available to return a string describing the last error that
+ * occurred from a call to dlopen(), dlclose() or dlsym().
+ */
+#$d_dlerror HAS_DLERROR /**/
+
+/* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+/* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+#$d_suidsafe SETUID_SCRIPTS_ARE_SECURE_NOW /**/
+#$d_dosuid DOSUID /**/
+
+/* HAS_DUP2:
+ * This symbol, if defined, indicates that the dup2 routine is
+ * available to duplicate file descriptors.
+ */
+#$d_dup2 HAS_DUP2 /**/
+
+/* HAS_FCHMOD:
+ * This symbol, if defined, indicates that the fchmod routine is available
+ * to change mode of opened files. If unavailable, use chmod().
+ */
+#$d_fchmod HAS_FCHMOD /**/
+
+/* HAS_FCHOWN:
+ * This symbol, if defined, indicates that the fchown routine is available
+ * to change ownership of opened files. If unavailable, use chown().
+ */
+#$d_fchown HAS_FCHOWN /**/
+
+/* HAS_FCNTL:
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
+ */
+#$d_fcntl HAS_FCNTL /**/
+
+/* HAS_FGETPOS:
+ * This symbol, if defined, indicates that the fgetpos routine is
+ * available to get the file position indicator, similar to ftell().
+ */
+#$d_fgetpos HAS_FGETPOS /**/
+
+/* FLEXFILENAMES:
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+#$d_flexfnam FLEXFILENAMES /**/
+
+/* HAS_FLOCK:
+ * This symbol, if defined, indicates that the flock routine is
+ * available to do file locking.
+ */
+#$d_flock HAS_FLOCK /**/
+
+/* HAS_FORK:
+ * This symbol, if defined, indicates that the fork routine is
+ * available.
+ */
+#$d_fork HAS_FORK /**/
+
+/* HAS_FSETPOS:
+ * This symbol, if defined, indicates that the fsetpos routine is
+ * available to set the file position indicator, similar to fseek().
+ */
+#$d_fsetpos HAS_FSETPOS /**/
+
+/* HAS_GETTIMEOFDAY:
+ * This symbol, if defined, indicates that the gettimeofday() system
+ * call is available for a sub-second accuracy clock. Usually, the file
+ * <sys/resource.h> needs to be included (see I_SYS_RESOURCE).
+ * The type "Timeval" should be used to refer to "struct timeval".
+ */
+#$d_gettimeod HAS_GETTIMEOFDAY /**/
+#ifdef HAS_GETTIMEOFDAY
+#define Timeval struct timeval /* Structure used by gettimeofday() */
+#endif
+
+/* HAS_GETGROUPS:
+ * This symbol, if defined, indicates that the getgroups() routine is
+ * available to get the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+#$d_getgrps HAS_GETGROUPS /**/
+
+/* HAS_UNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * uname() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and PHOSTNAME.
+ */
+#$d_uname HAS_UNAME /**/
+
+/* HAS_GETLOGIN:
+ * This symbol, if defined, indicates that the getlogin routine is
+ * available to get the login name.
+ */
+#$d_getlogin HAS_GETLOGIN /**/
+
+/* HAS_GETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the getpgid(pid) function is available to get the
+ * process group id.
+ */
+#$d_getpgid HAS_GETPGID /**/
+
+/* HAS_GETPGRP:
+ * This symbol, if defined, indicates that the getpgrp routine is
+ * available to get the current process group.
+ */
+/* USE_BSD_GETPGRP:
+ * This symbol, if defined, indicates that getpgrp needs one
+ * arguments whereas USG one needs none.
+ */
+#$d_getpgrp HAS_GETPGRP /**/
+#$d_bsdgetpgrp USE_BSD_GETPGRP /**/
+
+/* HAS_GETPGRP2:
+ * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
+ * routine is available to get the current process group.
+ */
+#$d_getpgrp2 HAS_GETPGRP2 /**/
+
+/* HAS_GETPPID:
+ * This symbol, if defined, indicates that the getppid routine is
+ * available to get the parent process ID.
+ */
+#$d_getppid HAS_GETPPID /**/
+
+/* HAS_GETPRIORITY:
+ * This symbol, if defined, indicates that the getpriority routine is
+ * available to get a process's priority.
+ */
+#$d_getprior HAS_GETPRIORITY /**/
+
+/* HAS_HTONL:
+ * This symbol, if defined, indicates that the htonl() routine (and
+ * friends htons() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_HTONS:
+ * This symbol, if defined, indicates that the htons() routine (and
+ * friends htonl() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHL:
+ * This symbol, if defined, indicates that the ntohl() routine (and
+ * friends htonl() htons() ntohs()) are available to do network
+ * order byte swapping.
+ */
+/* HAS_NTOHS:
+ * This symbol, if defined, indicates that the ntohs() routine (and
+ * friends htonl() htons() ntohl()) are available to do network
+ * order byte swapping.
+ */
+#$d_htonl HAS_HTONL /**/
+#$d_htonl HAS_HTONS /**/
+#$d_htonl HAS_NTOHL /**/
+#$d_htonl HAS_NTOHS /**/
+
+/* HAS_INET_ATON:
+ * This symbol, if defined, indicates to the C program that the
+ * inet_aton() function is available to parse IP address "dotted-quad"
+ * strings.
+ */
+#$d_inetaton HAS_INET_ATON /**/
+
+/* HAS_KILLPG:
+ * This symbol, if defined, indicates that the killpg routine is available
+ * to kill process groups. If unavailable, you probably should use kill
+ * with a negative process number.
+ */
+#$d_killpg HAS_KILLPG /**/
+
+/* HAS_LINK:
+ * This symbol, if defined, indicates that the link routine is
+ * available to create hard links.
+ */
+#$d_link HAS_LINK /**/
+
+/* HAS_LOCALECONV:
+ * This symbol, if defined, indicates that the localeconv routine is
+ * available for numeric and monetary formatting conventions.
+ */
+#$d_locconv HAS_LOCALECONV /**/
+
+/* HAS_LOCKF:
+ * This symbol, if defined, indicates that the lockf routine is
+ * available to do file locking.
+ */
+#$d_lockf HAS_LOCKF /**/
+
+/* HAS_LSTAT:
+ * This symbol, if defined, indicates that the lstat routine is
+ * available to do file stats on symbolic links.
+ */
+#$d_lstat HAS_LSTAT /**/
+
+/* HAS_MBLEN:
+ * This symbol, if defined, indicates that the mblen routine is available
+ * to find the number of bytes in a multibye character.
+ */
+#$d_mblen HAS_MBLEN /**/
+
+/* HAS_MBSTOWCS:
+ * This symbol, if defined, indicates that the mbstowcs routine is
+ * available to covert a multibyte string into a wide character string.
+ */
+#$d_mbstowcs HAS_MBSTOWCS /**/
+
+/* HAS_MBTOWC:
+ * This symbol, if defined, indicates that the mbtowc routine is available
+ * to covert a multibyte to a wide character.
+ */
+#$d_mbtowc HAS_MBTOWC /**/
+
+/* HAS_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * to compare blocks of memory.
+ */
+#$d_memcmp HAS_MEMCMP /**/
+
+/* HAS_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy blocks of memory.
+ */
+#$d_memcpy HAS_MEMCPY /**/
+
+/* HAS_MEMMOVE:
+ * This symbol, if defined, indicates that the memmove routine is available
+ * to copy potentially overlapping blocks of memory. This should be used
+ * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your
+ * own version.
+ */
+#$d_memmove HAS_MEMMOVE /**/
+
+/* HAS_MEMSET:
+ * This symbol, if defined, indicates that the memset routine is available
+ * to set blocks of memory.
+ */
+#$d_memset HAS_MEMSET /**/
+
+/* HAS_MKDIR:
+ * This symbol, if defined, indicates that the mkdir routine is available
+ * to create directories. Otherwise you should fork off a new process to
+ * exec /bin/mkdir.
+ */
+#$d_mkdir HAS_MKDIR /**/
+
+/* HAS_MKFIFO:
+ * This symbol, if defined, indicates that the mkfifo routine is
+ * available to create FIFOs. Otherwise, mknod should be able to
+ * do it for you. However, if mkfifo is there, mknod might require
+ * super-user privileges which mkfifo will not.
+ */
+#$d_mkfifo HAS_MKFIFO /**/
+
+/* HAS_MKTIME:
+ * This symbol, if defined, indicates that the mktime routine is
+ * available.
+ */
+#$d_mktime HAS_MKTIME /**/
+
+/* HAS_MSG:
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported (IPC mechanism based on message queues).
+ */
+#$d_msg HAS_MSG /**/
+
+/* HAS_NICE:
+ * This symbol, if defined, indicates that the nice routine is
+ * available.
+ */
+#$d_nice HAS_NICE /**/
+
+/* HAS_PATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given filename.
+ */
+/* HAS_FPATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given open file descriptor.
+ */
+#$d_pathconf HAS_PATHCONF /**/
+#$d_fpathconf HAS_FPATHCONF /**/
+
+/* HAS_PAUSE:
+ * This symbol, if defined, indicates that the pause routine is
+ * available to suspend a process until a signal is received.
+ */
+#$d_pause HAS_PAUSE /**/
+
+/* HAS_PIPE:
+ * This symbol, if defined, indicates that the pipe routine is
+ * available to create an inter-process channel.
+ */
+#$d_pipe HAS_PIPE /**/
+
+/* HAS_POLL:
+ * This symbol, if defined, indicates that the poll routine is
+ * available to poll active file descriptors. You may safely
+ * include <poll.h> when this symbol is defined.
+ */
+#$d_poll HAS_POLL /**/
+
+/* HAS_READDIR:
+ * This symbol, if defined, indicates that the readdir routine is
+ * available to read directory entries. You may have to include
+ * <dirent.h>. See I_DIRENT.
+ */
+#$d_readdir HAS_READDIR /**/
+
+/* HAS_SEEKDIR:
+ * This symbol, if defined, indicates that the seekdir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+#$d_seekdir HAS_SEEKDIR /**/
+
+/* HAS_TELLDIR:
+ * This symbol, if defined, indicates that the telldir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+#$d_telldir HAS_TELLDIR /**/
+
+/* HAS_REWINDDIR:
+ * This symbol, if defined, indicates that the rewinddir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+#$d_rewinddir HAS_REWINDDIR /**/
+
+/* HAS_READLINK:
+ * This symbol, if defined, indicates that the readlink routine is
+ * available to read the value of a symbolic link.
+ */
+#$d_readlink HAS_READLINK /**/
+
+/* HAS_RENAME:
+ * This symbol, if defined, indicates that the rename routine is available
+ * to rename files. Otherwise you should do the unlink(), link(), unlink()
+ * trick.
+ */
+#$d_rename HAS_RENAME /**/
+
+/* HAS_RMDIR:
+ * This symbol, if defined, indicates that the rmdir routine is
+ * available to remove directories. Otherwise you should fork off a
+ * new process to exec /bin/rmdir.
+ */
+#$d_rmdir HAS_RMDIR /**/
+
+/* HAS_SELECT:
+ * This symbol, if defined, indicates that the select routine is
+ * available to select active file descriptors. If the timeout field
+ * is used, <sys/time.h> may need to be included.
+ */
+#$d_select HAS_SELECT /**/
+
+/* HAS_SEM:
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+#$d_sem HAS_SEM /**/
+
+/* HAS_SETEGID:
+ * This symbol, if defined, indicates that the setegid routine is available
+ * to change the effective gid of the current program.
+ */
+#$d_setegid HAS_SETEGID /**/
+
+/* HAS_SETEUID:
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+#$d_seteuid HAS_SETEUID /**/
+
+/* HAS_SETLINEBUF:
+ * This symbol, if defined, indicates that the setlinebuf routine is
+ * available to change stderr or stdout from block-buffered or unbuffered
+ * to a line-buffered mode.
+ */
+#$d_setlinebuf HAS_SETLINEBUF /**/
+
+/* HAS_SETLOCALE:
+ * This symbol, if defined, indicates that the setlocale routine is
+ * available to handle locale-specific ctype implementations.
+ */
+#$d_setlocale HAS_SETLOCALE /**/
+
+/* HAS_SETPGID:
+ * This symbol, if defined, indicates that the setpgid(pid, gpid)
+ * routine is available to set process group ID.
+ */
+#$d_setpgid HAS_SETPGID /**/
+
+/* HAS_SETPGRP:
+ * This symbol, if defined, indicates that the setpgrp routine is
+ * available to set the current process group.
+ */
+/* USE_BSD_SETPGRP:
+ * This symbol, if defined, indicates that setpgrp needs two
+ * arguments whereas USG one needs none. See also HAS_SETPGID
+ * for a POSIX interface.
+ */
+#$d_setpgrp HAS_SETPGRP /**/
+#$d_bsdsetpgrp USE_BSD_SETPGRP /**/
+
+/* HAS_SETPGRP2:
+ * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
+ * routine is available to set the current process group.
+ */
+#$d_setpgrp2 HAS_SETPGRP2 /**/
+
+/* HAS_SETPRIORITY:
+ * This symbol, if defined, indicates that the setpriority routine is
+ * available to set a process's priority.
+ */
+#$d_setprior HAS_SETPRIORITY /**/
+
+/* HAS_SETREGID:
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current
+ * process.
+ */
+/* HAS_SETRESGID:
+ * This symbol, if defined, indicates that the setresgid routine is
+ * available to change the real, effective and saved gid of the current
+ * process.
+ */
+#$d_setregid HAS_SETREGID /**/
+#$d_setresgid HAS_SETRESGID /**/
+
+/* HAS_SETREUID:
+ * This symbol, if defined, indicates that the setreuid routine is
+ * available to change the real and effective uid of the current
+ * process.
+ */
+/* HAS_SETRESUID:
+ * This symbol, if defined, indicates that the setresuid routine is
+ * available to change the real, effective and saved uid of the current
+ * process.
+ */
+#$d_setreuid HAS_SETREUID /**/
+#$d_setresuid HAS_SETRESUID /**/
+
+/* HAS_SETRGID:
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+#$d_setrgid HAS_SETRGID /**/
+
+/* HAS_SETRUID:
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+#$d_setruid HAS_SETRUID /**/
+
+/* HAS_SETSID:
+ * This symbol, if defined, indicates that the setsid routine is
+ * available to set the process group ID.
+ */
+#$d_setsid HAS_SETSID /**/
+
+/* HAS_SHM:
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+#$d_shm HAS_SHM /**/
+
+/* Shmat_t:
+ * This symbol holds the return type of the shmat() system call.
+ * Usually set to 'void *' or 'char *'.
+ */
+/* HAS_SHMAT_PROTOTYPE:
+ * This symbol, if defined, indicates that the sys/shm.h includes
+ * a prototype for shmat(). Otherwise, it is up to the program to
+ * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess,
+ * but not always right so it should be emitted by the program only
+ * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs.
+ */
+#define Shmat_t $shmattype /**/
+#$d_shmatprototype HAS_SHMAT_PROTOTYPE /**/
+
+/* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+#$d_statblks USE_STAT_BLOCKS /**/
+
+/* HAS_STRCHR:
+ * This symbol is defined to indicate that the strchr()/strrchr()
+ * functions are available for string searching. If not, try the
+ * index()/rindex() pair.
+ */
+/* HAS_INDEX:
+ * This symbol is defined to indicate that the index()/rindex()
+ * functions are available for string searching.
+ */
+#$d_strchr HAS_STRCHR /**/
+#$d_index HAS_INDEX /**/
+
+/* HAS_STRCOLL:
+ * This symbol, if defined, indicates that the strcoll routine is
+ * available to compare strings using collating information.
+ */
+#$d_strcoll HAS_STRCOLL /**/
+
+/* USE_STRUCT_COPY:
+ * This symbol, if defined, indicates that this C compiler knows how
+ * to copy structures. If undefined, you'll need to use a block copy
+ * routine of some sort instead.
+ */
+#$d_strctcpy USE_STRUCT_COPY /**/
+
+/* HAS_STRERROR:
+ * This symbol, if defined, indicates that the strerror routine is
+ * available to translate error numbers to strings. See the writeup
+ * of Strerror() in this file before you try to define your own.
+ */
+/* HAS_SYS_ERRLIST:
+ * This symbol, if defined, indicates that the sys_errlist array is
+ * available to translate error numbers to strings. The extern int
+ * sys_nerr gives the size of that table.
+ */
+/* Strerror:
+ * This preprocessor symbol is defined as a macro if strerror() is
+ * not available to translate error numbers to strings but sys_errlist[]
+ * array is there.
+ */
+#$d_strerror HAS_STRERROR /**/
+#$d_syserrlst HAS_SYS_ERRLIST /**/
+#define Strerror(e) $d_strerrm
+
+/* HAS_STRTOD:
+ * This symbol, if defined, indicates that the strtod routine is
+ * available to provide better numeric string conversion than atof().
+ */
+#$d_strtod HAS_STRTOD /**/
+
+/* HAS_STRTOL:
+ * This symbol, if defined, indicates that the strtol routine is available
+ * to provide better numeric string conversion than atoi() and friends.
+ */
+#$d_strtol HAS_STRTOL /**/
+
+/* HAS_STRTOUL:
+ * This symbol, if defined, indicates that the strtoul routine is
+ * available to provide conversion of strings to unsigned long.
+ */
+#$d_strtoul HAS_STRTOUL /**/
+
+/* HAS_STRXFRM:
+ * This symbol, if defined, indicates that the strxfrm() routine is
+ * available to transform strings.
+ */
+#$d_strxfrm HAS_STRXFRM /**/
+
+/* HAS_SYMLINK:
+ * This symbol, if defined, indicates that the symlink routine is available
+ * to create symbolic links.
+ */
+#$d_symlink HAS_SYMLINK /**/
+
+/* HAS_SYSCALL:
+ * This symbol, if defined, indicates that the syscall routine is
+ * available to call arbitrary system calls. If undefined, that's tough.
+ */
+#$d_syscall HAS_SYSCALL /**/
+
+/* HAS_SYSCONF:
+ * This symbol, if defined, indicates that sysconf() is available
+ * to determine system related limits and options.
+ */
+#$d_sysconf HAS_SYSCONF /**/
+
+/* HAS_SYSTEM:
+ * This symbol, if defined, indicates that the system routine is
+ * available to issue a shell command.
+ */
+#$d_system HAS_SYSTEM /**/
+
+/* HAS_TCGETPGRP:
+ * This symbol, if defined, indicates that the tcgetpgrp routine is
+ * available to get foreground process group ID.
+ */
+#$d_tcgetpgrp HAS_TCGETPGRP /**/
+
+/* HAS_TCSETPGRP:
+ * This symbol, if defined, indicates that the tcsetpgrp routine is
+ * available to set foreground process group ID.
+ */
+#$d_tcsetpgrp HAS_TCSETPGRP /**/
+
+/* HAS_TRUNCATE:
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
+ */
+#$d_truncate HAS_TRUNCATE /**/
+
+/* HAS_TZNAME:
+ * This symbol, if defined, indicates that the tzname[] array is
+ * available to access timezone names.
+ */
+#$d_tzname HAS_TZNAME /**/
+
+/* HAS_UMASK:
+ * This symbol, if defined, indicates that the umask routine is
+ * available to set and get the value of the file creation mask.
+ */
+#$d_umask HAS_UMASK /**/
+
+/* HAS_VFORK:
+ * This symbol, if defined, indicates that vfork() exists.
+ */
+#$d_vfork HAS_VFORK /**/
+
+/* HASVOLATILE:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+#$d_volatile HASVOLATILE /**/
+#ifndef HASVOLATILE
+#define volatile
+#endif
+
+/* HAS_WAIT4:
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+#$d_wait4 HAS_WAIT4 /**/
+
+/* HAS_WAITPID:
+ * This symbol, if defined, indicates that the waitpid routine is
+ * available to wait for child process.
+ */
+#$d_waitpid HAS_WAITPID /**/
+
+/* HAS_WCSTOMBS:
+ * This symbol, if defined, indicates that the wcstombs routine is
+ * available to convert wide character strings to multibyte strings.
+ */
+#$d_wcstombs HAS_WCSTOMBS /**/
+
+/* HAS_WCTOMB:
+ * This symbol, if defined, indicates that the wctomb routine is available
+ * to covert a wide character to a multibyte.
+ */
+#$d_wctomb HAS_WCTOMB /**/
+
+/* EBCDIC:
+ * This symbol, if defined, indicates that this system uses
+ * EBCDIC encoding.
+ */
+#$ebcdic EBCDIC /**/
+
+/* I_ARPA_INET:
+ * This symbol, if defined, indicates that <arpa/inet.h> exists and should
+ * be included.
+ */
+#$i_arpainet I_ARPA_INET /**/
+
+/* I_DBM:
+ * This symbol, if defined, indicates that <dbm.h> exists and should
+ * be included.
+ */
+/* I_RPCSVC_DBM:
+ * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and
+ * should be included.
+ */
+#$i_dbm I_DBM /**/
+#$i_rpcsvcdbm I_RPCSVC_DBM /**/
+
+/* I_DIRENT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <dirent.h>. Using this symbol also triggers the definition
+ * of the Direntry_t define which ends up being 'struct dirent' or
+ * 'struct direct' depending on the availability of <dirent.h>.
+ */
+/* DIRNAMLEN:
+ * This symbol, if defined, indicates to the C program that the length
+ * of directory entry names is provided by a d_namlen field. Otherwise
+ * you need to do strlen() on the d_name field.
+ */
+/* Direntry_t:
+ * This symbol is set to 'struct direct' or 'struct dirent' depending on
+ * whether dirent is available or not. You should use this pseudo type to
+ * portably declare your directory entries.
+ */
+#$i_dirent I_DIRENT /**/
+#$d_dirnamlen DIRNAMLEN /**/
+#define Direntry_t $direntrytype
+
+/* I_DLFCN:
+ * This symbol, if defined, indicates that <dlfcn.h> exists and should
+ * be included.
+ */
+#$i_dlfcn I_DLFCN /**/
+
+/* I_FCNTL:
+ * This manifest constant tells the C program to include <fcntl.h>.
+ */
+#$i_fcntl I_FCNTL /**/
+
+/* I_FLOAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <float.h> to get definition of symbols like DBL_MAX or
+ * DBL_MIN, i.e. machine dependent floating point values.
+ */
+#$i_float I_FLOAT /**/
+
+/* I_GRP:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <grp.h>.
+ */
+/* GRPASSWD:
+ * This symbol, if defined, indicates to the C program that struct group
+ * contains gr_passwd.
+ */
+/* HAS_SETGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for initializing sequential access of the group database.
+ */
+/* HAS_GETGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for sequential access of the group database.
+ */
+/* HAS_ENDGRENT:
+ * This symbol, if defined, indicates that the getgrent routine is
+ * available for finalizing sequential access of the group database.
+ */
+#$i_grp I_GRP /**/
+#$d_grpasswd GRPASSWD /**/
+#$d_setgrent HAS_SETGRENT /**/
+#$d_getgrent HAS_GETGRENT /**/
+#$d_endgrent HAS_ENDGRENT /**/
+
+/* I_LIMITS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <limits.h> to get definition of symbols like WORD_BIT or
+ * LONG_MAX, i.e. machine dependant limitations.
+ */
+#$i_limits I_LIMITS /**/
+
+/* I_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+#$i_locale I_LOCALE /**/
+
+/* I_MATH:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <math.h>.
+ */
+#$i_math I_MATH /**/
+
+/* I_MEMORY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <memory.h>.
+ */
+#$i_memory I_MEMORY /**/
+
+/* I_NDBM:
+ * This symbol, if defined, indicates that <ndbm.h> exists and should
+ * be included.
+ */
+#$i_ndbm I_NDBM /**/
+
+/* I_NET_ERRNO:
+ * This symbol, if defined, indicates that <net/errno.h> exists and
+ * should be included.
+ */
+#$i_neterrno I_NET_ERRNO /**/
+
+/* I_NETINET_IN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <netinet/in.h>. Otherwise, you may try <sys/in.h>.
+ */
+#$i_niin I_NETINET_IN /**/
+
+/* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+#$i_sfio I_SFIO /**/
+
+/* I_STDDEF:
+ * This symbol, if defined, indicates that <stddef.h> exists and should
+ * be included.
+ */
+#$i_stddef I_STDDEF /**/
+
+/* I_STDLIB:
+ * This symbol, if defined, indicates that <stdlib.h> exists and should
+ * be included.
+ */
+#$i_stdlib I_STDLIB /**/
+
+/* I_STRING:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <string.h> (USG systems) instead of <strings.h> (BSD systems).
+ */
+#$i_string I_STRING /**/
+
+/* I_SYS_DIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/dir.h>.
+ */
+#$i_sysdir I_SYS_DIR /**/
+
+/* I_SYS_FILE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/file.h> to get definition of R_OK and friends.
+ */
+#$i_sysfile I_SYS_FILE /**/
+
+/* I_SYS_IOCTL:
+ * This symbol, if defined, indicates that <sys/ioctl.h> exists and should
+ * be included. Otherwise, include <sgtty.h> or <termio.h>.
+ */
+#$i_sysioctl I_SYS_IOCTL /**/
+
+/* I_SYS_NDIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/ndir.h>.
+ */
+#$i_sysndir I_SYS_NDIR /**/
+
+/* I_SYS_PARAM:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/param.h>.
+ */
+#$i_sysparam I_SYS_PARAM /**/
+
+/* I_SYS_RESOURCE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/resource.h>.
+ */
+#$i_sysresrc I_SYS_RESOURCE /**/
+
+/* I_SYS_SELECT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/select.h> in order to get definition of struct timeval.
+ */
+#$i_sysselct I_SYS_SELECT /**/
+
+/* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+#$i_sysstat I_SYS_STAT /**/
+
+/* I_SYS_TIMES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/times.h>.
+ */
+#$i_systimes I_SYS_TIMES /**/
+
+/* I_SYS_TYPES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/types.h>.
+ */
+#$i_systypes I_SYS_TYPES /**/
+
+/* I_SYS_UN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/un.h> to get UNIX domain socket definitions.
+ */
+#$i_sysun I_SYS_UN /**/
+
+/* I_SYS_WAIT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/wait.h>.
+ */
+#$i_syswait I_SYS_WAIT /**/
+
+/* I_TERMIO:
+ * This symbol, if defined, indicates that the program should include
+ * <termio.h> rather than <sgtty.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+/* I_TERMIOS:
+ * This symbol, if defined, indicates that the program should include
+ * the POSIX termios.h rather than sgtty.h or termio.h.
+ * There are also differences in the ioctl() calls that depend on the
+ * value of this symbol.
+ */
+/* I_SGTTY:
+ * This symbol, if defined, indicates that the program should include
+ * <sgtty.h> rather than <termio.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+#$i_termio I_TERMIO /**/
+#$i_termios I_TERMIOS /**/
+#$i_sgtty I_SGTTY /**/
+
+/* I_UNISTD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <unistd.h>.
+ */
+#$i_unistd I_UNISTD /**/
+
+/* I_UTIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <utime.h>.
+ */
+#$i_utime I_UTIME /**/
+
+/* I_VALUES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <values.h> to get definition of symbols like MINFLOAT or
+ * MAXLONG, i.e. machine dependant limitations. Probably, you
+ * should use <limits.h> instead, if it is available.
+ */
+#$i_values I_VALUES /**/
+
+/* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+/* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+#$i_stdarg I_STDARG /**/
+#$i_varargs I_VARARGS /**/
+
+/* I_VFORK:
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+#$i_vfork I_VFORK /**/
+
+/* CAN_PROTOTYPE:
+ * If defined, this macro indicates that the C compiler can handle
+ * function prototypes.
+ */
+/* _:
+ * This macro is used to declare function parameters for folks who want
+ * to make declarations with prototypes using a different style than
+ * the above macros. Use double parentheses. For example:
+ *
+ * int main _((int argc, char *argv[]));
+ */
+#$prototype CAN_PROTOTYPE /**/
+#ifdef CAN_PROTOTYPE
+#define _(args) args
+#else
+#define _(args) ()
+#endif
+
+/* SH_PATH:
+ * This symbol contains the full pathname to the shell used on this
+ * on this system to execute Bourne shell scripts. Usually, this will be
+ * /bin/sh, though it's possible that some systems will have /bin/ksh,
+ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as
+ * D:/bin/sh.exe.
+ */
+#define SH_PATH "$sh" /**/
+
+/* STDCHAR:
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+#define STDCHAR $stdchar /**/
+
+/* MEM_ALIGNBYTES:
+ * This symbol contains the number of bytes required to align a
+ * double. Usual values are 2, 4 and 8.
+ * On NeXT starting with 3.2, you can build "Fat" Multiple Architecture
+ * Binaries (MAB) for targets with varying alignment. This only matters
+ * for perl, where the config.h can be generated and installed on one
+ * system, and used by a different architecture to build an extension.
+ * The default is eight, for safety.
+ */
+#define MEM_ALIGNBYTES $alignbytes /**/
+
+/* BYTEORDER:
+ * This symbol holds the hexadecimal constant defined in byteorder,
+ * i.e. 0x1234 or 0x4321, etc...
+ * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture
+ * Binaries (MAB) on either big endian or little endian machines.
+ * The endian-ness is available at compile-time. This only matters
+ * for perl, where the config.h can be generated and installed on
+ * one system, and used by a different architecture to build an
+ * extension. Older versions of NeXT that might not have
+ * defined either *_ENDIAN__ were all on Motorola 680x0 series,
+ * so the default case (for NeXT) is big endian to catch them.
+ * This might matter for NeXT 3.0.
+ */
+#ifndef NeXT
+#define BYTEORDER 0x$byteorder /* large digits for MSB */
+#else /* NeXT */
+#ifdef __LITTLE_ENDIAN__
+#define BYTEORDER 0x1234
+#else /* __BIG_ENDIAN__ */
+#define BYTEORDER 0x4321
+#endif /* ENDIAN CHECK */
+#endif /* NeXT */
+
+/* CASTI32:
+ * This symbol is defined if the C compiler can cast negative
+ * or large floating point numbers to 32-bit ints.
+ */
+#$d_casti32 CASTI32 /**/
+
+/* CASTNEGFLOAT:
+ * This symbol is defined if the C compiler can cast negative
+ * numbers to unsigned longs, ints and shorts.
+ */
+/* CASTFLAGS:
+ * This symbol contains flags that say what difficulties the compiler
+ * has casting odd floating values to unsigned long:
+ * 0 = ok
+ * 1 = couldn't cast < 0
+ * 2 = couldn't cast >= 0x80000000
+ * 4 = couldn't cast in argument expression list
+ */
+#$d_castneg CASTNEGFLOAT /**/
+#define CASTFLAGS $castflags /**/
+
+/* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+#$d_void_closedir VOID_CLOSEDIR /**/
+
+/* Gconvert:
+ * This preprocessor macro is defined to convert a floating point
+ * number to a string without a trailing decimal point. This
+ * emulates the behavior of sprintf("%g"), but is sometimes much more
+ * efficient. If gconvert() is not available, but gcvt() drops the
+ * trailing decimal point, then gcvt() is used. If all else fails,
+ * a macro using sprintf("%g") is used. Arguments for the Gconvert
+ * macro are: value, number of digits, whether trailing zeros should
+ * be retained, and the output buffer.
+ * Possible values are:
+ * d_Gconvert='gconvert((x),(n),(t),(b))'
+ * d_Gconvert='gcvt((x),(n),(b))'
+ * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ * The last two assume trailing zeros should not be kept.
+ */
+#define Gconvert(x,n,t,b) $d_Gconvert
+
+/* HAS_GNULIBC:
+ * This symbol, if defined, indicates to the C program that
+ * the GNU C library is being used.
+ */
+#$d_gnulibc HAS_GNULIBC /**/
+/* HAS_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+#$d_isascii HAS_ISASCII /**/
+
+/* HAS_LCHOWN:
+ * This symbol, if defined, indicates that the lchown routine is
+ * available to operate on a symbolic link (instead of following the
+ * link).
+ */
+#$d_lchown HAS_LCHOWN /**/
+
+/* HAS_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+#$d_open3 HAS_OPEN3 /**/
+
+/* HAS_SAFE_BCOPY:
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy potentially overlapping memory blocks. Otherwise you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+#$d_safebcpy HAS_SAFE_BCOPY /**/
+
+/* HAS_SAFE_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy potentially overlapping memory blocks. Otherwise you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+#$d_safemcpy HAS_SAFE_MEMCPY /**/
+
+/* HAS_SANE_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * and can be used to compare relative magnitudes of chars with their high
+ * bits set. If it is not defined, roll your own version.
+ */
+#$d_sanemcmp HAS_SANE_MEMCMP /**/
+
+/* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+#$d_sigaction HAS_SIGACTION /**/
+
+/* Sigjmp_buf:
+ * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
+ */
+/* Sigsetjmp:
+ * This macro is used in the same way as sigsetjmp(), but will invoke
+ * traditional setjmp() if sigsetjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+/* Siglongjmp:
+ * This macro is used in the same way as siglongjmp(), but will invoke
+ * traditional longjmp() if siglongjmp isn't available.
+ * See HAS_SIGSETJMP.
+ */
+#$d_sigsetjmp HAS_SIGSETJMP /**/
+#ifdef HAS_SIGSETJMP
+#define Sigjmp_buf sigjmp_buf
+#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask))
+#define Siglongjmp(buf,retval) siglongjmp((buf),(retval))
+#else
+#define Sigjmp_buf jmp_buf
+#define Sigsetjmp(buf,save_mask) setjmp((buf))
+#define Siglongjmp(buf,retval) longjmp((buf),(retval))
+#endif
+
+/* USE_STDIO_PTR:
+ * This symbol is defined if the _ptr and _cnt fields (or similar)
+ * of the stdio FILE structure can be used to access the stdio buffer
+ * for a file handle. If this is defined, then the FILE_ptr(fp)
+ * and FILE_cnt(fp) macros will also be defined and should be used
+ * to access these fields.
+ */
+/* FILE_ptr:
+ * This macro is used to access the _ptr field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_PTR_LVALUE:
+ * This symbol is defined if the FILE_ptr macro can be used as an
+ * lvalue.
+ */
+/* FILE_cnt:
+ * This macro is used to access the _cnt field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+/* STDIO_CNT_LVALUE:
+ * This symbol is defined if the FILE_cnt macro can be used as an
+ * lvalue.
+ */
+#$d_stdstdio USE_STDIO_PTR /**/
+#ifdef USE_STDIO_PTR
+#define FILE_ptr(fp) $stdio_ptr
+#$d_stdio_ptr_lval STDIO_PTR_LVALUE /**/
+#define FILE_cnt(fp) $stdio_cnt
+#$d_stdio_cnt_lval STDIO_CNT_LVALUE /**/
+#endif
+
+/* USE_STDIO_BASE:
+ * This symbol is defined if the _base field (or similar) of the
+ * stdio FILE structure can be used to access the stdio buffer for
+ * a file handle. If this is defined, then the FILE_base(fp) macro
+ * will also be defined and should be used to access this field.
+ * Also, the FILE_bufsiz(fp) macro will be defined and should be used
+ * to determine the number of bytes in the buffer. USE_STDIO_BASE
+ * will never be defined unless USE_STDIO_PTR is.
+ */
+/* FILE_base:
+ * This macro is used to access the _base field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_BASE is defined.
+ */
+/* FILE_bufsiz:
+ * This macro is used to determine the number of bytes in the I/O
+ * buffer pointed to by _base field (or equivalent) of the FILE
+ * structure pointed to its argument. This macro will always be defined
+ * if USE_STDIO_BASE is defined.
+ */
+#$d_stdiobase USE_STDIO_BASE /**/
+#ifdef USE_STDIO_BASE
+#define FILE_base(fp) $stdio_base
+#define FILE_bufsiz(fp) $stdio_bufsiz
+#endif
+
+/* HAS_VPRINTF:
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+/* USE_CHAR_VSPRINTF:
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+#$d_vprintf HAS_VPRINTF /**/
+#$d_charvspr USE_CHAR_VSPRINTF /**/
+
+/* DOUBLESIZE:
+ * This symbol contains the size of a double, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define DOUBLESIZE $doublesize /**/
+
+/* I_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+/* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+/* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+#$i_time I_TIME /**/
+#$i_systime I_SYS_TIME /**/
+#$i_systimek I_SYS_TIME_KERNEL /**/
+
+/* INTSIZE:
+ * This symbol contains the value of sizeof(int) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* LONGSIZE:
+ * This symbol contains the value of sizeof(long) so that the C
+ * preprocessor can make decisions based on it.
+ */
+/* SHORTSIZE:
+ * This symbol contains the value of sizeof(short) so that the C
+ * preprocessor can make decisions based on it.
+ */
+#define INTSIZE $intsize /**/
+#define LONGSIZE $longsize /**/
+#define SHORTSIZE $shortsize /**/
+
+/* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+/* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+/* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+/* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+#define VAL_O_NONBLOCK $o_nonblock
+#define VAL_EAGAIN $eagain
+#define RD_NODATA $rd_nodata
+#$d_eofnblk EOF_NONBLOCK
+
+/* PTRSIZE:
+ * This symbol contains the size of a pointer, so that the C preprocessor
+ * can make decisions based on it. It will be sizeof(void *) if
+ * the compiler supports (void *); otherwise it will be
+ * sizeof(char *).
+ */
+#define PTRSIZE $ptrsize /**/
+
+/* RANDBITS:
+ * This symbol contains the number of bits of random number the rand()
+ * function produces. Usual values are 15, 16, and 31.
+ */
+#define RANDBITS $randbits /**/
+
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t $ssizetype /* signed count of bytes */
+
+/* OSNAME:
+ * This symbol contains the name of the operating system, as determined
+ * by Configure. You shouldn't rely on it too much; the specific
+ * feature tests from Configure are generally more reliable.
+ */
+#define OSNAME "$osname" /**/
+
+/* CAT2:
+ * This macro catenates 2 tokens together.
+ */
+/* STRINGIFY:
+ * This macro surrounds its token with double quotes.
+ */
+#if $cpp_stuff == 1
+#define CAT2(a,b)a/**/b
+#define STRINGIFY(a)"a"
+ /* If you can get stringification with catify, tell me how! */
+#endif
+#if $cpp_stuff == 42
+#define CAT2(a,b)a ## b
+#define StGiFy(a)# a
+#define STRINGIFY(a)StGiFy(a)
+#endif
+#if $cpp_stuff != 1 && $cpp_stuff != 42
+#include "Bletch: How does this C preprocessor catenate tokens?"
+#endif
+
+/* CSH:
+ * This symbol, if defined, contains the full pathname of csh.
+ */
+#$d_csh HAS_CSH /**/
+#ifdef HAS_CSH
+#define CSH "$full_csh" /**/
+#endif
+
+/* HAS_ENDHOSTENT:
+ * This symbol, if defined, indicates that the endhostent() routine is
+ * available to close whatever was being used for host queries.
+ */
+#$d_endhent HAS_ENDHOSTENT /**/
+
+/* HAS_ENDNETENT:
+ * This symbol, if defined, indicates that the endnetent() routine is
+ * available to close whatever was being used for network queries.
+ */
+#$d_endnent HAS_ENDNETENT /**/
+
+/* HAS_ENDPROTOENT:
+ * This symbol, if defined, indicates that the endprotoent() routine is
+ * available to close whatever was being used for protocol queries.
+ */
+#$d_endpent HAS_ENDPROTOENT /**/
+
+/* HAS_ENDSERVENT:
+ * This symbol, if defined, indicates that the endservent() routine is
+ * available to close whatever was being used for service queries.
+ */
+#$d_endsent HAS_ENDSERVENT /**/
+
+/* HAS_GETHOSTBYADDR:
+ * This symbol, if defined, indicates that the gethostbyaddr() routine is
+ * available to look up hosts by their IP addresses.
+ */
+#$d_gethbyaddr HAS_GETHOSTBYADDR /**/
+
+/* HAS_GETHOSTBYNAME:
+ * This symbol, if defined, indicates that the gethostbyname() routine is
+ * available to look up host names in some data base or other.
+ */
+#$d_gethbyname HAS_GETHOSTBYNAME /**/
+
+/* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent() routine is
+ * available to look up host names in some data base or another.
+ */
+#$d_gethent HAS_GETHOSTENT /**/
+
+/* HAS_GETNETBYADDR:
+ * This symbol, if defined, indicates that the getnetbyaddr() routine is
+ * available to look up networks by their IP addresses.
+ */
+#$d_getnbyaddr HAS_GETNETBYADDR /**/
+
+/* HAS_GETNETBYNAME:
+ * This symbol, if defined, indicates that the getnetbyname() routine is
+ * available to look up networks by their names.
+ */
+#$d_getnbyname HAS_GETNETBYNAME /**/
+
+/* HAS_GETNETENT:
+ * This symbol, if defined, indicates that the getnetent() routine is
+ * available to look up network names in some data base or another.
+ */
+#$d_getnent HAS_GETNETENT /**/
+
+/* HAS_GETPROTOENT:
+ * This symbol, if defined, indicates that the getprotoent() routine is
+ * available to look up protocols in some data base or another.
+ */
+#$d_getpent HAS_GETPROTOENT /**/
+
+/* HAS_GETPROTOBYNAME:
+ * This symbol, if defined, indicates that the getprotobyname()
+ * routine is available to look up protocols by their name.
+ */
+/* HAS_GETPROTOBYNUMBER:
+ * This symbol, if defined, indicates that the getprotobynumber()
+ * routine is available to look up protocols by their number.
+ */
+#$d_getpbyname HAS_GETPROTOBYNAME /**/
+#$d_getpbynumber HAS_GETPROTOBYNUMBER /**/
+
+/* HAS_GETSERVENT:
+ * This symbol, if defined, indicates that the getservent() routine is
+ * available to look up network services in some data base or another.
+ */
+#$d_getsent HAS_GETSERVENT /**/
+
+/* HAS_GETSERVBYNAME:
+ * This symbol, if defined, indicates that the getservbyname()
+ * routine is available to look up services by their name.
+ */
+/* HAS_GETSERVBYPORT:
+ * This symbol, if defined, indicates that the getservbyport()
+ * routine is available to look up services by their port.
+ */
+#$d_getsbyname HAS_GETSERVBYNAME /**/
+#$d_getsbyport HAS_GETSERVBYPORT /**/
+
+/* HAS_LONG_DOUBLE:
+ * This symbol will be defined if the C compiler supports long
+ * doubles.
+ */
+/* LONG_DOUBLESIZE:
+ * This symbol contains the size of a long double, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long doubles.
+ */
+#$d_longdbl HAS_LONG_DOUBLE /**/
+#ifdef HAS_LONG_DOUBLE
+#define LONG_DOUBLESIZE $longdblsize /**/
+#endif
+
+/* HAS_LONG_LONG:
+ * This symbol will be defined if the C compiler supports
+ * long long.
+ */
+/* LONGLONGSIZE:
+ * This symbol contains the size of a long long, so that the
+ * C preprocessor can make decisions based on it. It is only
+ * defined if the system supports long long.
+ */
+#$d_longlong HAS_LONG_LONG /**/
+#ifdef HAS_LONG_LONG
+#define LONGLONGSIZE $longlongsize /**/
+#endif
+
+/* HAS_SETGROUPS:
+ * This symbol, if defined, indicates that the setgroups() routine is
+ * available to set the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+#$d_setgrps HAS_SETGROUPS /**/
+
+/* HAS_SETHOSTENT:
+ * This symbol, if defined, indicates that the sethostent() routine is
+ * available.
+ */
+#$d_sethent HAS_SETHOSTENT /**/
+
+/* HAS_SETNETENT:
+ * This symbol, if defined, indicates that the setnetent() routine is
+ * available.
+ */
+#$d_setnent HAS_SETNETENT /**/
+
+/* HAS_SETPROTOENT:
+ * This symbol, if defined, indicates that the setprotoent() routine is
+ * available.
+ */
+#$d_setpent HAS_SETPROTOENT /**/
+
+/* HAS_SETSERVENT:
+ * This symbol, if defined, indicates that the setservent() routine is
+ * available.
+ */
+#$d_setsent HAS_SETSERVENT /**/
+
+/* HAS_SETVBUF:
+ * This symbol, if defined, indicates that the setvbuf routine is
+ * available to change buffering on an open stdio stream.
+ * to a line-buffered mode.
+ */
+#$d_setvbuf HAS_SETVBUF /**/
+
+/* HAS_SOCKET:
+ * This symbol, if defined, indicates that the BSD socket interface is
+ * supported.
+ */
+/* HAS_SOCKETPAIR:
+ * This symbol, if defined, indicates that the BSD socketpair() call is
+ * supported.
+ */
+#$d_socket HAS_SOCKET /**/
+#$d_sockpair HAS_SOCKETPAIR /**/
+
+/* HAS_UNION_SEMUN:
+ * This symbol, if defined, indicates that the union semun is
+ * defined by including <sys/sem.h>. If not, the user code
+ * probably needs to define it as:
+ * union semun {
+ * int val;
+ * struct semid_ds *buf;
+ * unsigned short *array;
+ * }
+ */
+/* USE_SEMCTL_SEMUN:
+ * This symbol, if defined, indicates that union semun is
+ * used for semctl IPC_STAT.
+ */
+/* USE_SEMCTL_SEMID_DS:
+ * This symbol, if defined, indicates that struct semid_ds * is
+ * used for semctl IPC_STAT.
+ */
+#$d_union_semun HAS_UNION_SEMUN /**/
+#$d_semctl_semun USE_SEMCTL_SEMUN /**/
+#$d_semctl_semid_ds USE_SEMCTL_SEMID_DS /**/
+
+/* Signal_t:
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return type of a signal handler. Thus, you can declare
+ * a signal handler using "Signal_t (*handler)()", and define the
+ * handler using "Signal_t handler(sig)".
+ */
+#define Signal_t $signal_t /* Signal handler's return type */
+
+/* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * getgroups() and setgropus(). Usually, this is the same as
+ * gidtype (gid_t) , but sometimes it isn't.
+ * It can be int, ushort, uid_t, etc...
+ * It may be necessary to include <sys/types.h> to get any
+ * typedef'ed information. This is only required if you have
+ * getgroups() or setgropus()..
+ */
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+#define Groups_t $groupstype /* Type for 2nd arg to [sg]etgroups() */
+#endif
+
+/* I_NETDB:
+ * This symbol, if defined, indicates that <netdb.h> exists and
+ * should be included.
+ */
+#$i_netdb I_NETDB /**/
+
+/* I_PWD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pwd.h>.
+ */
+/* PWQUOTA:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_quota.
+ */
+/* PWAGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_age.
+ */
+/* PWCHANGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_change.
+ */
+/* PWCLASS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_class.
+ */
+/* PWEXPIRE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_expire.
+ */
+/* PWCOMMENT:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_comment.
+ */
+/* PWGECOS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_gecos.
+ */
+/* PWPASSWD:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_passwd.
+ */
+/* HAS_SETPWENT:
+ * This symbol, if defined, indicates that the getpwrent routine is
+ * available for initializing sequential access of the passwd database.
+ */
+/* HAS_GETPWENT:
+ * This symbol, if defined, indicates that the getpwent routine is
+ * available for sequential access of the password database.
+ */
+/* HAS_ENDPWENT:
+ * This symbol, if defined, indicates that the getpwent routine is
+ * available for finalizing sequential access of the passwd database.
+ */
+#$i_pwd I_PWD /**/
+#$d_pwquota PWQUOTA /**/
+#$d_pwage PWAGE /**/
+#$d_pwchange PWCHANGE /**/
+#$d_pwclass PWCLASS /**/
+#$d_pwexpire PWEXPIRE /**/
+#$d_pwcomment PWCOMMENT /**/
+#$d_pwgecos PWGECOS /**/
+#$d_pwpasswd PWPASSWD /**/
+#$d_setpwent HAS_SETPWENT /**/
+#$d_getpwent HAS_GETPWENT /**/
+#$d_endpwent HAS_ENDPWENT /**/
+
+/* Free_t:
+ * This variable contains the return type of free(). It is usually
+ * void, but occasionally int.
+ */
+/* Malloc_t:
+ * This symbol is the type of pointer returned by malloc and realloc.
+ */
+#define Malloc_t $malloctype /**/
+#define Free_t $freetype /**/
+
+/* MYMALLOC:
+ * This symbol, if defined, indicates that we're using our own malloc.
+ */
+#$d_mymalloc MYMALLOC /**/
+
+/* SIG_NAME:
+ * This symbol contains a list of signal names in order of
+ * signal number. This is intended
+ * to be used as a static array initialization, like this:
+ * char *sig_name[] = { SIG_NAME };
+ * The signals in the list are separated with commas, and each signal
+ * is surrounded by double quotes. There is no leading SIG in the signal
+ * name, i.e. SIGQUIT is known as "QUIT".
+ * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn,
+ * etc., where nn is the actual signal number (e.g. NUM37).
+ * The signal number for sig_name[i] is stored in sig_num[i].
+ * The last element is 0 to terminate the list with a NULL. This
+ * corresponds to the 0 at the end of the sig_num list.
+ */
+/* SIG_NUM:
+ * This symbol contains a list of signal numbers, in the same order as the
+ * SIG_NAME list. It is suitable for static array initialization, as in:
+ * int sig_num[] = { SIG_NUM };
+ * The signals in the list are separated with commas, and the indices
+ * within that list and the SIG_NAME list match, so it's easy to compute
+ * the signal name from a number or vice versa at the price of a small
+ * dynamic linear lookup.
+ * Duplicates are allowed, but are moved to the end of the list.
+ * The signal number corresponding to sig_name[i] is sig_number[i].
+ * if (i < NSIG) then sig_number[i] == i.
+ * The last element is 0, corresponding to the 0 at the end of
+ * the sig_name list.
+ */
+#define SIG_NAME $sig_name_init /**/
+#define SIG_NUM $sig_num /**/
+
+/* VOIDFLAGS:
+ * This symbol indicates how much support of the void type is given by this
+ * compiler. What various bits mean:
+ *
+ * 1 = supports declaration of void
+ * 2 = supports arrays of pointers to functions returning void
+ * 4 = supports comparisons between pointers to void functions and
+ * addresses of void functions
+ * 8 = suports declaration of generic void pointers
+ *
+ * The package designer should define VOIDUSED to indicate the requirements
+ * of the package. This can be done either by #defining VOIDUSED before
+ * including config.h, or by defining defvoidused in Myinit.U. If the
+ * latter approach is taken, only those flags will be tested. If the
+ * level of void support necessary is not present, defines void to int.
+ */
+#ifndef VOIDUSED
+#define VOIDUSED $defvoidused
+#endif
+#define VOIDFLAGS $voidflags
+#if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+#define void int /* is void to be avoided? */
+#define M_VOID /* Xenix strikes again */
+#endif
+
+/* ARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user wants to put architecture-dependent public
+ * library files for $package. It is most often a local directory
+ * such as /usr/local/lib. Programs using this variable must be
+ * prepared to deal with filename expansion. If ARCHLIB is the
+ * same as PRIVLIB, it is not defined, since presumably the
+ * program already searches PRIVLIB.
+ */
+/* ARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of ARCHLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#$d_archlib ARCHLIB "$archlib" /**/
+#$d_archlib ARCHLIB_EXP "$archlibexp" /**/
+
+/* DLSYM_NEEDS_UNDERSCORE:
+ * This symbol, if defined, indicates that we need to prepend an
+ * underscore to the symbol name before calling dlsym(). This only
+ * makes sense if you *have* dlsym, which we will presume is the
+ * case if you're using dl_dlopen.xs.
+ */
+#$d_dlsymun DLSYM_NEEDS_UNDERSCORE /**/
+
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+#$d_sfio USE_SFIO /**/
+
+/* USE_DYNAMIC_LOADING:
+ * This symbol, if defined, indicates that dynamic loading of
+ * some sort is available.
+ */
+#$usedl USE_DYNAMIC_LOADING /**/
+
+/* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+/* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+#define DB_Hash_t $db_hashtype /**/
+#define DB_Prefix_t $db_prefixtype /**/
+
+/* PRIVLIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ */
+/* PRIVLIB_EXP:
+ * This symbol contains the ~name expanded version of PRIVLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define PRIVLIB "$privlib" /**/
+#define PRIVLIB_EXP "$privlibexp" /**/
+
+/* SITEARCH:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * The standard distribution will put nothing in this directory.
+ * Individual sites may place their own extensions and modules in
+ * this directory.
+ */
+/* SITEARCH_EXP:
+ * This symbol contains the ~name expanded version of SITEARCH, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define SITEARCH "$sitearch" /**/
+#define SITEARCH_EXP "$sitearchexp" /**/
+
+/* SITELIB:
+ * This symbol contains the name of the private library for this package.
+ * The library is private in the sense that it needn't be in anyone's
+ * execution path, but it should be accessible by the world. The program
+ * should be prepared to do ~ expansion.
+ * The standard distribution will put nothing in this directory.
+ * Individual sites may place their own extensions and modules in
+ * this directory.
+ */
+/* SITELIB_EXP:
+ * This symbol contains the ~name expanded version of SITELIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define SITELIB "$sitelib" /**/
+#define SITELIB_EXP "$sitelibexp" /**/
+
+/* STARTPERL:
+ * This variable contains the string to put in front of a perl
+ * script to make sure (one hopes) that it runs with perl and not
+ * some shell.
+ */
+#define STARTPERL "$startperl" /**/
+
+/* USE_PERLIO:
+ * This symbol, if defined, indicates that the PerlIO abstraction should
+ * be used throughout. If not defined, stdio should be
+ * used in a fully backward compatible manner.
+ */
+#$useperlio USE_PERLIO /**/
+
+/* HAS_GETHOST_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for gethostent(), gethostbyname(), and
+ * gethostbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#$d_gethostprotos HAS_GETHOST_PROTOS /**/
+
+/* HAS_GETNET_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getnetent(), getnetbyname(), and
+ * getnetbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#$d_getnetprotos HAS_GETNET_PROTOS /**/
+
+/* HAS_GETPROTO_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getprotoent(), getprotobyname(), and
+ * getprotobyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#$d_getprotoprotos HAS_GETPROTO_PROTOS /**/
+
+/* HAS_GETSERV_PROTOS:
+ * This symbol, if defined, indicates that <netdb.h> includes
+ * prototypes for getservent(), getservbyname(), and
+ * getservbyaddr(). Otherwise, it is up to the program to guess
+ * them. See netdbtype.U for probing for various Netdb_xxx_t types.
+ */
+#$d_getservprotos HAS_GETSERV_PROTOS /**/
+
+/* Netdb_host_t:
+ * This symbol holds the type used for the 1st argument
+ * to gethostbyaddr().
+ */
+/* Netdb_hlen_t:
+ * This symbol holds the type used for the 2nd argument
+ * to gethostbyaddr().
+ */
+/* Netdb_name_t:
+ * This symbol holds the type used for the argument to
+ * gethostbyname().
+ */
+/* Netdb_net_t:
+ * This symbol holds the type used for the 1st argument to
+ * getnetbyaddr().
+ */
+#define Netdb_host_t $netdb_host_type /**/
+#define Netdb_hlen_t $netdb_hlen_type /**/
+#define Netdb_name_t $netdb_name_type /**/
+#define Netdb_net_t $netdb_net_type /**/
+
+/* Select_fd_set_t:
+ * This symbol holds the type used for the 2nd, 3rd, and 4th
+ * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
+ * is defined, and 'int *' otherwise. This is only useful if you
+ * have select(), of course.
+ */
+#define Select_fd_set_t $selecttype /**/
+
+/* ARCHNAME:
+ * This symbol holds a string representing the architecture name.
+ * It may be used to construct an architecture-dependant pathname
+ * where library files may be held under a private library, for
+ * instance.
+ */
+#define ARCHNAME "$archname" /**/
+
+/* HAS_PTHREAD_YIELD:
+ * This symbol, if defined, indicates that the pthread_yield
+ * routine is available to yield the execution of the current
+ * thread.
+ */
+/* HAS_SCHED_YIELD:
+ * This symbol, if defined, indicates that the sched_yield
+ * routine is available to yield the execution of the current
+ * thread.
+ */
+#$d_pthread_yield HAS_PTHREAD_YIELD /**/
+#$d_sched_yield HAS_SCHED_YIELD /**/
+
+/* PTHREADS_CREATED_JOINABLE:
+ * This symbol, if defined, indicates that pthreads are created
+ * in the joinable (aka undetached) state.
+ */
+#$d_pthreads_created_joinable PTHREADS_CREATED_JOINABLE /**/
+
+/* USE_THREADS:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use threads.
+ */
+/* OLD_PTHREADS_API:
+ * This symbol, if defined, indicates that Perl should
+ * be built to use the old draft POSIX threads API.
+ */
+#$usethreads USE_THREADS /**/
+#$d_oldpthreads OLD_PTHREADS_API /**/
+
+/* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+#define Time_t $timetype /* Time type */
+
+/* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+#$d_times HAS_TIMES /**/
+
+/* Fpos_t:
+ * This symbol holds the type used to declare file positions in libc.
+ * It can be fpos_t, long, uint, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Fpos_t $fpostype /* File position type */
+
+/* Gid_t:
+ * This symbol holds the return type of getgid() and the type of
+ * argument to setrgid() and related functions. Typically,
+ * it is the type of group ids in the kernel. It can be int, ushort,
+ * uid_t, etc... It may be necessary to include <sys/types.h> to get
+ * any typedef'ed information.
+ */
+#define Gid_t $gidtype /* Type for getgid(), etc... */
+
+/* Off_t:
+ * This symbol holds the type used to declare offsets in the kernel.
+ * It can be int, long, off_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Off_t $lseektype /* <offset> type */
+
+/* Mode_t:
+ * This symbol holds the type used to declare file modes
+ * for systems calls. It is usually mode_t, but may be
+ * int or unsigned short. It may be necessary to include <sys/types.h>
+ * to get any typedef'ed information.
+ */
+#define Mode_t $modetype /* file mode parameter for system calls */
+
+/* Pid_t:
+ * This symbol holds the type used to declare process ids in the kernel.
+ * It can be int, uint, pid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Pid_t $pidtype /* PID type */
+
+/* Size_t:
+ * This symbol holds the type used to declare length parameters
+ * for string functions. It is usually size_t, but may be
+ * unsigned long, int, etc. It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Size_t $sizetype /* length paramater for string functions */
+
+/* Uid_t:
+ * This symbol holds the type used to declare user ids in the kernel.
+ * It can be int, ushort, uid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+#define Uid_t $uidtype /* UID type */
+
+#endif
+!GROK!THIS!
diff --git a/contrib/perl5/configpm b/contrib/perl5/configpm
new file mode 100755
index 000000000000..ba07f14a878b
--- /dev/null
+++ b/contrib/perl5/configpm
@@ -0,0 +1,417 @@
+#!./miniperl -w
+
+my $config_pm = $ARGV[0] || 'lib/Config.pm';
+my $glossary = $ARGV[1] || 'Porting/Glossary';
+@ARGV = "./config.sh";
+
+# list names to put first (and hence lookup fastest)
+@fast = qw(archname osname osvers prefix libs libpth
+ dynamic_ext static_ext extensions dlsrc so
+ sig_name sig_num cc ccflags cppflags
+ privlibexp archlibexp installprivlib installarchlib
+ sharpbang startsh shsharp
+);
+
+# names of things which may need to have slashes changed to double-colons
+@extensions = qw(dynamic_ext static_ext extensions known_extensions);
+
+
+open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n";
+$myver = $];
+
+print CONFIG <<"ENDOFBEG";
+package Config;
+use Exporter ();
+\@ISA = (Exporter);
+\@EXPORT = qw(%Config);
+\@EXPORT_OK = qw(myconfig config_sh config_vars);
+
+\$] == $myver
+ or die "Perl lib version ($myver) doesn't match executable version (\$])";
+
+# This file was created by configpm when Perl was built. Any changes
+# made to this file will be lost the next time perl is built.
+
+ENDOFBEG
+
+
+@fast{@fast} = @fast;
+@extensions{@extensions} = @extensions;
+@non_v=();
+@v_fast=();
+@v_others=();
+$in_v = 0;
+
+while (<>) {
+ next if m:^#!/bin/sh:;
+ # Catch CONFIG=true and PATCHLEVEL=n line from Configure.
+ s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/;
+ # We can delimit things in config.sh with either ' or ".
+ unless ($in_v or m/^(\w+)=(['"])(.*\n)/){
+ push(@non_v, "#$_"); # not a name='value' line
+ next;
+ }
+ $quote = $2;
+ if ($in_v) { $val .= $_; }
+ else { ($name,$val) = ($1,$3); }
+ $in_v = $val !~ /$quote\n/;
+ next if $in_v;
+ if ($extensions{$name}) { s,/,::,g }
+ if (!$fast{$name}){ push(@v_others, "$name=$quote$val"); next; }
+ push(@v_fast,"$name=$quote$val");
+}
+
+foreach(@non_v){ print CONFIG $_ }
+
+print CONFIG "\n",
+ "my \$config_sh = <<'!END!';\n",
+ join("", @v_fast, sort @v_others),
+ "!END!\n\n";
+
+# copy config summary format from the myconfig script
+
+print CONFIG "my \$summary = <<'!END!';\n";
+
+open(MYCONFIG,"<myconfig") || die "open myconfig failed: $!";
+1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
+do { print CONFIG $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
+close(MYCONFIG);
+
+print CONFIG "\n!END!\n", <<'EOT';
+my $summary_expanded = 0;
+
+sub myconfig {
+ return $summary if $summary_expanded;
+ $summary =~ s{\$(\w+)}
+ { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge;
+ $summary_expanded = 1;
+ $summary;
+}
+EOT
+
+# ----
+
+print CONFIG <<'ENDOFEND';
+
+sub FETCH {
+ # check for cached value (which may be undef so we use exists not defined)
+ return $_[0]->{$_[1]} if (exists $_[0]->{$_[1]});
+
+ # Search for it in the big string
+ my($value, $start, $marker, $quote_type);
+ $marker = "$_[1]=";
+ $quote_type = "'";
+ # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m);
+ # Check for the common case, ' delimeted
+ $start = index($config_sh, "\n$marker$quote_type");
+ # If that failed, check for " delimited
+ if ($start == -1) {
+ $quote_type = '"';
+ $start = index($config_sh, "\n$marker$quote_type");
+ }
+ return undef if ( ($start == -1) && # in case it's first
+ (substr($config_sh, 0, length($marker)) ne $marker) );
+ if ($start == -1) {
+ # It's the very first thing we found. Skip $start forward
+ # and figure out the quote mark after the =.
+ $start = length($marker) + 1;
+ $quote_type = substr($config_sh, $start - 1, 1);
+ }
+ else {
+ $start += length($marker) + 2;
+ }
+ $value = substr($config_sh, $start,
+ index($config_sh, "$quote_type\n", $start) - $start);
+
+ # If we had a double-quote, we'd better eval it so escape
+ # sequences and such can be interpolated. Since the incoming
+ # value is supposed to follow shell rules and not perl rules,
+ # we escape any perl variable markers
+ if ($quote_type eq '"') {
+ $value =~ s/\$/\\\$/g;
+ $value =~ s/\@/\\\@/g;
+ eval "\$value = \"$value\"";
+ }
+ #$value = sprintf($value) if $quote_type eq '"';
+ $value = undef if $value eq 'undef'; # So we can say "if $Config{'foo'}".
+ $_[0]->{$_[1]} = $value; # cache it
+ return $value;
+}
+
+my $prevpos = 0;
+
+sub FIRSTKEY {
+ $prevpos = 0;
+ # my($key) = $config_sh =~ m/^(.*?)=/;
+ substr($config_sh, 0, index($config_sh, '=') );
+ # $key;
+}
+
+sub NEXTKEY {
+ # Find out how the current key's quoted so we can skip to its end.
+ my $quote = substr($config_sh, index($config_sh, "=", $prevpos)+1, 1);
+ my $pos = index($config_sh, qq($quote\n), $prevpos) + 2;
+ my $len = index($config_sh, "=", $pos) - $pos;
+ $prevpos = $pos;
+ $len > 0 ? substr($config_sh, $pos, $len) : undef;
+}
+
+sub EXISTS {
+ # exists($_[0]->{$_[1]}) or $config_sh =~ m/^$_[1]=/m;
+ exists($_[0]->{$_[1]}) or
+ index($config_sh, "\n$_[1]='") != -1 or
+ substr($config_sh, 0, length($_[1])+2) eq "$_[1]='" or
+ index($config_sh, "\n$_[1]=\"") != -1 or
+ substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\"";
+}
+
+sub STORE { die "\%Config::Config is read-only\n" }
+sub DELETE { &STORE }
+sub CLEAR { &STORE }
+
+
+sub config_sh {
+ $config_sh
+}
+
+sub config_re {
+ my $re = shift;
+ my @matches = ($config_sh =~ /^$re=.*\n/mg);
+ @matches ? (print @matches) : print "$re: not found\n";
+}
+
+sub config_vars {
+ foreach(@_){
+ config_re($_), next if /\W/;
+ my $v=(exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
+ $v='undef' unless defined $v;
+ print "$_='$v';\n";
+ }
+}
+
+ENDOFEND
+
+if ($^O eq 'os2') {
+ print CONFIG <<'ENDOFSET';
+my %preconfig;
+if ($OS2::is_aout) {
+ my ($value, $v) = $config_sh =~ m/^used_aout='(.*)'\s*$/m;
+ for (split ' ', $value) {
+ ($v) = $config_sh =~ m/^aout_$_='(.*)'\s*$/m;
+ $preconfig{$_} = $v eq 'undef' ? undef : $v;
+ }
+}
+sub TIEHASH { bless {%preconfig} }
+ENDOFSET
+} else {
+ print CONFIG <<'ENDOFSET';
+sub TIEHASH { bless {} }
+ENDOFSET
+}
+
+print CONFIG <<'ENDOFTAIL';
+
+# avoid Config..Exporter..UNIVERSAL search for DESTROY then AUTOLOAD
+sub DESTROY { }
+
+tie %Config, 'Config';
+
+1;
+__END__
+
+=head1 NAME
+
+Config - access Perl configuration information
+
+=head1 SYNOPSIS
+
+ use Config;
+ if ($Config{'cc'} =~ /gcc/) {
+ print "built by gcc\n";
+ }
+
+ use Config qw(myconfig config_sh config_vars);
+
+ print myconfig();
+
+ print config_sh();
+
+ config_vars(qw(osname archname));
+
+
+=head1 DESCRIPTION
+
+The Config module contains all the information that was available to
+the C<Configure> program at Perl build time (over 900 values).
+
+Shell variables from the F<config.sh> file (written by Configure) are
+stored in the readonly-variable C<%Config>, indexed by their names.
+
+Values stored in config.sh as 'undef' are returned as undefined
+values. The perl C<exists> function can be used to check if a
+named variable exists.
+
+=over 4
+
+=item myconfig()
+
+Returns a textual summary of the major perl configuration values.
+See also C<-V> in L<perlrun/Switches>.
+
+=item config_sh()
+
+Returns the entire perl configuration information in the form of the
+original config.sh shell variable assignment script.
+
+=item config_vars(@names)
+
+Prints to STDOUT the values of the named configuration variable. Each is
+printed on a separate line in the form:
+
+ name='value';
+
+Names which are unknown are output as C<name='UNKNOWN';>.
+See also C<-V:name> in L<perlrun/Switches>.
+
+=back
+
+=head1 EXAMPLE
+
+Here's a more sophisticated example of using %Config:
+
+ use Config;
+ use strict;
+
+ my %sig_num;
+ my @sig_name;
+ unless($Config{sig_name} && $Config{sig_num}) {
+ die "No sigs?";
+ } else {
+ my @names = split ' ', $Config{sig_name};
+ @sig_num{@names} = split ' ', $Config{sig_num};
+ foreach (@names) {
+ $sig_name[$sig_num{$_}] ||= $_;
+ }
+ }
+
+ print "signal #17 = $sig_name[17]\n";
+ if ($sig_num{ALRM}) {
+ print "SIGALRM is $sig_num{ALRM}\n";
+ }
+
+=head1 WARNING
+
+Because this information is not stored within the perl executable
+itself it is possible (but unlikely) that the information does not
+relate to the actual perl binary which is being used to access it.
+
+The Config module is installed into the architecture and version
+specific library directory ($Config{installarchlib}) and it checks the
+perl version number when loaded.
+
+The values stored in config.sh may be either single-quoted or
+double-quoted. Double-quoted strings are handy for those cases where you
+need to include escape sequences in the strings. To avoid runtime variable
+interpolation, any C<$> and C<@> characters are replaced by C<\$> and
+C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
+or C<\@> in double-quoted strings unless you're willing to deal with the
+consequences. (The slashes will end up escaped and the C<$> or C<@> will
+trigger variable interpolation)
+
+=head1 GLOSSARY
+
+Most C<Config> variables are determined by the C<Configure> script
+on platforms supported by it (which is most UNIX platforms). Some
+platforms have custom-made C<Config> variables, and may thus not have
+some of the variables described below, or may have extraneous variables
+specific to that particular port. See the port specific documentation
+in such cases.
+
+ENDOFTAIL
+
+open(GLOS, "<$glossary") or die "Can't open $glossary: $!";
+%seen = ();
+$text = 0;
+$/ = '';
+
+sub process {
+ s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m;
+ my $c = substr $1, 0, 1;
+ unless ($seen{$c}++) {
+ print CONFIG <<EOF if $text;
+=back
+
+EOF
+ print CONFIG <<EOF;
+=head2 $c
+
+=over
+
+EOF
+ $text = 1;
+ }
+ s/n't/n\00t/g; # leave can't, won't etc untouched
+ s/^\t\s+(.*)/\n\t$1\n/gm; # Indented lines ===> paragraphs
+ s/^(?<!\n\n)\t(.*)/$1/gm; # Not indented lines ===> text
+ s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
+ s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
+ s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
+ s{
+ (?<! [\w./<\'\"] ) # Only standalone file names
+ (?! e \. g \. ) # Not e.g.
+ (?! \. \. \. ) # Not ...
+ (?! \d ) # Not 5.004
+ ( [\w./]* [./] [\w./]* ) # Require . or / inside
+ (?<! \. (?= \s ) ) # Do not include trailing dot
+ (?! [\w/] ) # Include all of it
+ }
+ (F<$1>)xg; # /usr/local
+ s/((?<=\s)~\w*)/F<$1>/g; # ~name
+ s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g; # UNISTD
+ s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
+ s/n[\0]t/n't/g; # undo can't, won't damage
+}
+
+<GLOS>; # Skip the preamble
+while (<GLOS>) {
+ process;
+ print CONFIG;
+}
+
+print CONFIG <<'ENDOFTAIL';
+
+=back
+
+=head1 NOTE
+
+This module contains a good example of how to use tie to implement a
+cache and an example of how to make a tied variable readonly to those
+outside of it.
+
+=cut
+
+ENDOFTAIL
+
+close(CONFIG);
+close(GLOS);
+
+# Now do some simple tests on the Config.pm file we have created
+unshift(@INC,'lib');
+require $config_pm;
+import Config;
+
+die "$0: $config_pm not valid"
+ unless $Config{'CONFIG'} eq 'true';
+
+die "$0: error processing $config_pm"
+ if defined($Config{'an impossible name'})
+ or $Config{'CONFIG'} ne 'true' # test cache
+ ;
+
+die "$0: error processing $config_pm"
+ if eval '$Config{"cc"} = 1'
+ or eval 'delete $Config{"cc"}'
+ ;
+
+
+exit 0;
diff --git a/contrib/perl5/configure.com b/contrib/perl5/configure.com
new file mode 100644
index 000000000000..521221978b95
--- /dev/null
+++ b/contrib/perl5/configure.com
@@ -0,0 +1,2033 @@
+$ sav_ver = 'F$VERIFY(0)'
+$! SET VERIFY
+$!
+$! For example, if you unpacked perl into: [USER.PERL5_00n...] then you will
+$! want to cd into the tree and execute Configure:
+$!
+$! $ SET DEFAULT [USER.PERL5_00n]
+$! $ @Configure
+$!
+$! or
+$!
+$! $ SET DEFAULT [USER.PERL5_00n]
+$! $ @Configure "-des"
+$!
+$! That's it. If you get into a bind trying to build perl on VMS then
+$! definitely read through the README.VMS file.
+$! Beyond that send email to VMSPerl@cor.newman.upenn.edu
+$!
+$! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+$!
+$! send suggestions to:
+$! Dan Sugalski <sugalskd@ous.edu>
+$! Thank you!!!!
+$!
+$! Adapted and converted from Larry Wall & Andy Dougherty's
+$! "Configure generated by metaconfig 3.0 PL60." by Peter Prymmer
+$! (a Bourne sh[ell] script for configuring the installation of perl on VMS)
+$! in the perl5.002|3 epoch (spring/summer 1996)
+$! with much valuable help from Charles Bailey &
+$! the whole VMSPerl crew.
+$! Extended and messed about with by Dan Sugalski
+$!
+$! SET NOVERIFY
+$ sav_ver = F$VERIFY(sav_ver)
+$!
+$! VMS-isms we will need:
+$ echo = "write sys$output "
+$ cat = "type"
+$ gcc_symbol = "gcc"
+$ ans = ""
+$ macros = ""
+$ use_debugging_perl = "Y"
+$ C_Compiler_Replace = "CC="
+$ Thread_Live_Dangerously = "MT="
+$ use_two_pot_malloc = "N"
+$ use_pack_malloc = "N"
+$ use_debugmalloc = "N"
+$ preload_env = "N"
+$ vms_default_directory_name = F$ENVIRONMENT("DEFAULT")
+$! max_allowed_dir_depth = 3 ! e.g. [A.B.PERL5_00n] not [A.B.C.PERL5_00n]
+$ max_allowed_dir_depth = 2 ! e.g. [FOO.PERL5_00n] not [FOO.BAR.PERL5_00n]
+$!
+$ vms_filcnt = F$GETJPI ("","FILCNT")
+$!
+$!: compute my invocation name
+$ me = F$ENVIRONMENT("PROCEDURE")
+$!
+$! Many null statements (begin with colon ':') in the Bourne shell version of
+$! this script serve as comments/placeholders. I have retained some of the ones
+$! that will help you compare this .COM file to the sh version - as well as
+$! leave placeholders for future improvements to this .COM file.
+$! sfn = VMS "skipped for now"
+$!
+$!: Proper PATH separator !sfn
+$!: Proper PATH setting !sfn
+$!: Sanity checks !sfn "Say '@''$me''"
+$!: On HP-UX, large Configure scripts may exercise a bug in /bin/sh !sfn
+$!: Configure runs within the UU subdirectory !->after find MANIFEST
+$! <big long list of default values (mostly null)>
+$!: We must find out about Eunice early !(?)
+$!: list of known cpp symbols, sorted alphabetically !sfn
+$! al = al + "..."
+$!: default library list !sfn
+$! <no hints files in use (yet?)>
+$!: Extra object files, if any, needed on this platform. !sfn
+$!: Possible local include directories to search. !sfn
+$!: Set locincpth to "" in a hint file to defeat local include searches. !sfn
+$!locincpth="/usr/local/include /opt/local/include /usr/gnu/include" !sfn
+$!locincpth="$locincpth /opt/gnu/include /usr/GNU/include /opt/GNU/include"
+$!: no include file wanted by default !sfn
+$!inclwanted='' !sfn
+$!: Possible local library directories to search. !sfn
+$!loclibpth="/usr/local/lib /opt/local/lib /usr/gnu/lib" !sfn
+$!loclibpth="$loclibpth /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib" !sfn
+$!: general looking path for locating libraries !sfn
+$!glibpth="/lib/pa1.1 /usr/shlib /usr/lib/large /lib /usr/lib" !sfn
+$!glibpth="$glibpth $xlibpth /lib/large /usr/lib/small /lib/small" !sfn
+$!glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/shlib" !sfn
+$!: Private path used by Configure to find libraries. Its value !sfn
+$!: is prepended to libpth. This variable takes care of special !sfn
+$!: machines, like the mips. Usually, it should be empty. !sfn
+$!plibpth='' !sfn
+$!: full support for void wanted by default !sfn
+$!defvoidused=15 !sfn
+$!: List of libraries we want. !sfn
+$!libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl' !sfn
+$!libswanted="$libswanted dld ld sun m c cposix posix ndir dir crypt" !sfn
+$!libswanted="$libswanted ucb bsd BSD PW x" !sfn
+$!: We probably want to search /usr/shlib before most other libraries. !sfn
+$!: This is only used by the lib/ExtUtils/MakeMaker.pm routine extliblist. !sfn
+$!glibpth=`echo " $glibpth " | sed -e 's! /usr/shlib ! !'` !sfn
+$!glibpth="/usr/shlib $glibpth" !sfn
+$!: Do not use vfork unless overridden by a hint file. !sfn
+$!usevfork=false !sfn
+$!: script used to extract .SH files with variable substitutions !sfn
+$!: produce awk script to parse command line options !sfn
+$!sfn (assume no sed awk) see below
+$!: process the command line options
+$!
+$!: set up default values
+$ fastread=""
+$ reuseval="false"
+$ config_sh=""
+$ alldone=""
+$ error=""
+$ silent=""
+$ extractsh=""
+$ override=""
+$ knowitall=""
+$ Using_Dec_C = ""
+$ Using_Vax_C = ""
+$ Using_Gnu_C = ""
+$ Dec_C_Version = ""
+$ use_threads = "F"
+$!
+$!: option parsing
+$ IF (P1 .NES. "")
+$ THEN !one or more switches was thrown
+$ i = 1
+$ bang = 0
+$Param_loop:
+$ IF (P'i'.NES."") THEN bang = bang + 1
+$ i = i + 1
+$ IF (i.LT.9) THEN GOTO Param_loop !DCL allows P1..P8
+$!
+$ i = 1
+$Opt_loop:
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "-") THEN P'i' = P'i' - "-"
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "/") THEN P'i' = P'i' - "/"
+$Remove_quotation_mark:
+$ P'i' = P'i' - """"
+$ IF F$LOCATE("""",P'i') .LT. F$LENGTH(P'i') THEN GOTO Remove_quotation_mark
+$ gotopt = "f" !"alse"
+$ gotshortopt = "f" !"alse"
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "d")
+$ THEN
+$ fastread = "yes"
+$ gotopt = "t" !"rue"
+$ P'i' = P'i' - "d"
+$ gotshortopt = "t" !"rue"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "e")
+$ THEN
+$ alldone = "cont"
+$ gotopt = "t"
+$ P'i' = P'i' - "e"
+$ gotshortopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "f") !"-f")
+$ THEN
+$ P'i' = P'i' - "f"
+$ config_sh = P'i'
+$ IF (F$SEARCH(config_sh).NES."")
+$ THEN
+$ test = F$FILE_ATTRIBUTES(config_sh,"PRO")
+$ IF (F$LOCATE("R",test).NE.F$LENGTH(test))
+$ THEN
+$ CONTINUE !at this point check UIC && if test allows...
+$ !to be continued ?
+$ ELSE
+$ echo "''me': cannot read config file ''config_sh'."
+$ error="true"
+$ ENDIF
+$ ELSE
+$ echo "''me': cannot read config file ''config_sh'."
+$ error="true"
+$ ENDIF
+$ gotopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "h")
+$ THEN
+$ error = "true"
+$ gotopt = "t"
+$ P'i' = P'i' - "h"
+$ gotshortopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "r")
+$ THEN
+$ reuseval = "true"
+$ gotopt = "t"
+$ P'i' = P'i' - "r"
+$ gotshortopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "s")
+$ THEN
+$ silent = "true"
+$ gotopt = "t"
+$ P'i' = P'i' - "s"
+$ gotshortopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "E") !"-E")
+$ THEN
+$ alldone = "exit"
+$ gotopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "K") !"-K")
+$ THEN
+$ knowitall = "true"
+$ gotopt = "t"
+$ P'i' = P'i' - "K"
+$ gotshortopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "O")
+$ THEN
+$ override = "true"
+$ gotopt = "t"
+$ P'i' = P'i' - "O"
+$ gotshortopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "S") !"-S")
+$ THEN
+$ extractsh = "true" !VMS?
+$ gotopt = "t"
+$ P'i' = P'i' - "S"
+$ gotshortopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "D") !"-D")
+$ THEN
+$ P'i' = P'i' - "D"
+$!Hmm.. this part needs work
+$! P'i'
+$ IF (F$LOCATE("=",P'i') .EQ. F$LENGTH(P'i'))
+$ THEN
+$ P'i' = "define"
+$ ELSE
+$ IF (F$LOCATE("=",P'i') .EQ. (F$LENGTH(P'i') - 1))
+$ THEN
+$ me = F$PARSE(me,,,"NAME") + F$PARSE(me,,,"TYPE")
+$ echo "''me': use '-Usymbol=val' not '-Dsymbol='."
+$ echo "''me': ignoring -D",P'i'
+$ ELSE
+$!Hmm.. this part needs work
+$! 'F$EXTRACT(0,F$LOCATE("=",P'i'),P'i')' = -
+$! 'F$EXTRACT(F$LOCATE("=",P'i'),P'i'),F$LENGTH(P'i'),P'i')'
+$ ENDIF
+$ ENDIF
+$ ECHO "P''i' =>",P'i',"<=" !Diag
+$ gotopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "U") !"-U")
+$ THEN
+$ P'i' = P'i' - "U"
+$ IF (F$LOCATE("=",P'i') .EQ. F$LENGTH(P'i'))
+$ THEN
+$ P'i' = ""
+$ ELSE
+$ IF (F$LOCATE("=",P'i') .LT. (F$LENGTH(P'i') - 1))
+$ THEN
+$ me = F$PARSE(me,,,"NAME") + F$PARSE(me,,,"TYPE")
+$ echo "''me': use '-Dsymbol=val' not '-Usymbol=val'."
+$ echo "''me': ignoring -U",P'i'
+$ ELSE
+$ P'i' = "undef"
+$ ENDIF
+$ ENDIF
+$ ECHO "P''i' =>",P'i',"<=" !Diag
+$ gotopt = "t"
+$ ENDIF
+$ IF (F$EXTRACT(0,1,P'i') .EQS. "V")
+$ THEN
+$ me = F$PARSE(me,,,"NAME") + F$PARSE(me,,,"TYPE")
+$ echo "''me' generated by an unknown version of EDT."
+$ STOP
+$ EXIT !0
+$ ENDIF
+$ IF .NOT.gotopt
+$ THEN
+$ echo "''me': unknown option ",P'i'
+$ error = "true"
+$ ENDIF
+$ IF (F$LENGTH(P'i').GT.0).AND.(gotshortopt) THEN i = i - 1 !clustered switch
+$ i = i + 1
+$ IF (i .LT. (bang + 1)) THEN GOTO Opt_loop
+$!
+$ ENDIF ! (P1 .NES. "")
+$!
+$ IF (error)
+$ THEN
+$ me = F$PARSE(me,,,"DIRECTORY")+ F$PARSE(me,,,"NAME")
+$ echo "Usage: @''me' [-dehrEKOSV] [-fconfig.sh] [-Dsymbol] [-Dsymbol=value]"
+$ echo " [-Usymbol] [-Usymbol=]"
+$ TYPE SYS$INPUT
+ "-d" : use defaults for all answers.
+ "-e" : go on without questioning past the production of config.sh. *
+ "-f" : specify an alternate default configuration file.
+ "-h" : print this help message and exit (with an error status).
+ "-r" : reuse C symbols value if possible (skips costly nm extraction).*
+ "-s" : silent mode, only echoes questions and essential information.
+ -"D" : define symbol to have some value: *
+ -"Dsymbol" symbol gets the value 'define'
+ -"Dsymbol=value" symbol gets the value 'value'
+ -E : stop at the end of questions, after having produced config.sh. *
+ -K : do not use unless you know what you are doing.
+ -O : let -D and -U override definitions from loaded configuration file. *
+ -S : perform variable substitutions on all .SH files (can mix with -f) *
+ -"U" : undefine symbol: *
+ -"Usymbol" symbol gets the value 'undef'
+ -"Usymbol=" symbol gets completely empty
+ -V : print version number and exit (with a zero status).
+$ echo "%Config-I-VMS, lower case switches must be enclosed"
+$ echo "-Config-I-VMS, in double quotation marks, e.g.:"
+$ echo "-Config-I-VMS, @Configure ""-des"""
+$ echo "-Config-I-VMS, * indicates switch may not be fully implemented for VMS."
+$ SET DEFAULT 'vms_default_directory_name' !be kind rewind
+$ STOP
+$ EXIT 3 ! $STATUS = "%X00000003" (informational)
+$ ENDIF
+$!
+$ GOTO Check_silence
+$!
+$Shut_up:
+$ STDOUT = F$TRNLNM("SYS$OUTPUT")
+$ DEFINE SYS$OUTPUT "_NLA0:"
+$ echo4 = "write STDOUT "
+$ cat4 = "TYPE/OUTPUT=''STDOUT'"
+$ open/write STDOUT 'STDOUT'
+$ RETURN
+$!
+$Check_silence:
+$ IF (silent)
+$ THEN
+$ GOSUB Shut_up
+$ ELSE
+$ echo4 = "write SYS$OUTPUT "
+$ cat4 = "TYPE"
+$ ENDIF
+$!
+$!: run the defines and the undefines, if any, but leave the file out there...
+$! Unfortunately Configure.COM in DCL is not yet set up to do this -
+$! maybe someday
+$!
+$!: set package name
+$ package = "perl5"
+$!
+$!: Eunice requires " " instead of "", can you believe it
+$ echo ""
+$!: Here we go...
+$ echo "Beginning of configuration questions for ''package'."
+$ echo ""
+$!
+$!: Some greps do not return status, grrr.
+$ contains = "SEARCH"
+$!
+$!: first determine how to suppress newline on echo command !cant DCL is record oriented
+$! echo "Checking ''echo' to see how to suppress newlines..."
+$! echo "giving up..."
+$! echo "The star should be here-->*"
+$!
+$!: Now test for existence of everything in MANIFEST
+$ echo ""
+$ echo4 "First let's make sure your kit is complete. Checking..."
+$ manifestfound = ""
+$ miss_list = ""
+$! Here I assume we are in the [foo.PERL5xxx.VMS...] tree
+$! because the search routine simply does set def [-] if necessary.
+$ file_2_find = "MANIFEST" !I hope this one is not in [foo.PERL5xxx.VMS...]
+$Research_manifest:
+$ manifestfound = F$SEARCH(file_2_find)
+$ IF (manifestfound .EQS. "")
+$ THEN
+$ IF F$PARSE(F$ENVIRONMENT("DEFAULT"),,,"DIRECTORY",).NES."[000000]"
+$ THEN
+$ SET DEFAULT [-]
+$ GOTO Research_manifest
+$ ELSE
+$ echo ""
+$ echo "There is no MANIFEST file. I hope your kit is complete !"
+$ miss_list = ""
+$ GOTO Beyond_manifest
+$ ENDIF
+$ ELSE
+$! MANIFEST. has been found and we have set def'ed there -
+$! time to bail out before it's too late.
+$ tmp = f$extract(1,3,f$edit(f$getsyi("VERSION"),"TRIM,COLLAPSE"))
+$ IF tmp .GES. "7.2" THEN GOTO Beyond_depth_check
+$ IF (F$ELEMENT(max_allowed_dir_depth,".",F$ENVIRONMENT("Default")).nes.".")
+$ THEN
+$ TYPE SYS$INPUT:
+%Config-E-VMS, ERROR:
+ Sorry! It apears as though your perl build sub-directory is already too
+ deep into the VMS file system. Please try moving stuff into a shallower
+ directory (or altering the "max_allowed_dir_depth" parameter).
+$ echo4 "ABORTING..."
+$ SET DEFAULT 'vms_default_directory_name' !be kind rewind
+$ STOP
+$ EXIT !2 !$STATUS = "%X00000002" (error)
+$ ENDIF
+$Beyond_depth_check:
+$!
+$! after finding MANIFEST let's create (but not yet enter) the UU subdirectory
+$!
+$ IF (manifestfound .NES. "")
+$ THEN
+$ IF ( F$SEARCH("UU.DIR").EQS."" )
+$ THEN
+$ CREATE/DIRECTORY [.UU]
+$ ELSE
+$ IF ( F$SEARCH("[.UU]*.*").NES."" ) THEN DELETE/NOLOG [.UU]*.*;*
+$ ENDIF
+$!: Configure runs within the UU subdirectory
+$ SET DEFAULT [.UU]
+$!
+$! a little redundancy never hurt anybody?
+$ file_2_find = "[-]" + file_2_find
+$ manifestfound = F$SEARCH(file_2_find)
+$!
+$ OPEN/WRITE MISSING MISSING.
+$!change to "FALSE" if you wish to skip the manifest search
+$!(which after all is rather slow in DCL :-)
+$ IF ("TRUE")
+$ THEN
+$ OPEN/READ CONFIG 'manifestfound'
+$Read_loop_manifest:
+$ READ/END_OF_FILE = Done_manifest CONFIG line
+$! This algorithm turns "foo/bar/baz.c" into "[.foo.bar]baz.c"
+$! pvhp@lns62.lns.cornell.edu 10-JUN-1996 20:31:46
+$! 2-MAR-1998 15:46:11 Improved to turn "foo/bar/baz.c.buz"
+$! into "[.foo.bar]baz.c_buz as happens with vmstar and unzip
+$ line = F$EDIT(line,"TRIM, COMPRESS")
+$ file_2_find = F$EXTRACT(0,F$LOCATE(" ",line),line)
+$ IF F$LOCATE("/",file_2_find) .NE. F$LENGTH(file_2_find)
+$ THEN
+$Re_strip_line_manifest:
+$ loca = F$LOCATE("/",file_2_find)
+$ ante = F$EXTRACT(0,loca,file_2_find)
+$ post = F$EXTRACT(loca,F$LENGTH(file_2_find),file_2_find)
+$ test_this = ante + "." + (post - "/")
+$ IF F$LOCATE("/",test_this) .NE. F$LENGTH(test_this)
+$ THEN
+$ file_2_find = ante + "." + (post - "/")
+$ GOTO Re_strip_line_manifest
+$ ELSE
+$ file_2_find = ante + "]" + (post - "/")
+$ ENDIF
+$ file_2_find = "[-."+file_2_find
+$ ELSE
+$ file_2_find = "[-]" + file_2_find
+$ ENDIF
+$!
+$ dirname = F$EXTRACT(0,F$LOCATE("]",file_2_find),file_2_find) + "]"
+$ file_2_find = file_2_find - dirname
+$ dots = 0
+$Dot_loop:
+$ dot_ele = F$ELEMENT(dots,".",file_2_find)
+$ IF dot_ele .EQS. "." THEN GOTO Eo_dot_loop
+$ IF dots .eq. 0
+$ THEN basename = f$extract(0,f$locate(".",file_2_find),file_2_find) + "."
+$ ELSE basename = basename + dot_ele + "_"
+$ ENDIF
+$ dots = dots + 1
+$ GOTO dot_loop
+$Eo_dot_loop:
+$ IF (((f$length(file_2_find)+1) .eq. f$length(basename)) .and. -
+ (f$extract(f$length(basename)-1,1,basename) .eqs. "_")) THEN -
+ basename = f$extract(0,f$length(basename)-1,basename)
+$ file_2_find = dirname + basename
+$!
+$ found = F$SEARCH(file_2_find)
+$ IF (found .EQS. "")
+$ THEN
+$ WRITE MISSING file_2_find
+$ IF ((F$LENGTH(miss_list)+F$LENGTH(file_2_find)).LT.250)
+$ THEN
+$ miss_list = miss_list + "," + file_2_find
+$ ENDIF
+$ ENDIF
+$ GOTO Read_loop_manifest
+$Done_manifest:
+$ CLOSE CONFIG
+$ ENDIF !"TRUE"
+$ CLOSE MISSING
+$ ENDIF ! (manifestfound .NES. "")
+$Beyond_manifest:
+$ IF (miss_list .NES. "")
+$ THEN
+$ echo "Some of the files not found include:"
+$ cat4 MISSING.
+$ ENDIF
+$ IF ((miss_list .NES. "").OR.(manifestfound .EQS. ""))
+$ THEN
+$ TYPE SYS$INPUT:
+
+THIS PACKAGE SEEMS TO BE INCOMPLETE.
+
+You have the option of continuing the configuration process, despite the
+distinct possibility that your kit is damaged, by typing 'y'es. If you
+do, don't blame me if something goes wrong. I advise you to type 'n'o
+and contact the author (sugalskd@ous.edu).
+
+$ READ SYS$COMMAND/PROMPT="Continue? [n] " ans
+$ IF ans
+$ THEN
+$ echo4 "Continuing..."
+$ ELSE
+$ echo4 "ABORTING..."
+$ GOTO Clean_up
+$ ENDIF
+$ ELSE
+$ echo4 "Looks good..."
+$ DELETE/NOLOG MISSING.;
+$ ENDIF ! (miss_list .NES. "")
+$ ENDIF ! (manifestfound .EQS. "") ELSE
+$!
+$! after finding MANIFEST (see above)
+$!: Configure runs within the UU subdirectory
+$!
+$!: compute the number of columns on the terminal for proper question formatting
+$! (sfn, will assume 80-ish)
+$!
+$!: set up the echo used in my read !sfn
+$!: now set up to do reads with possible shell escape and default assignment !sfn
+$ GOTO Beyond_myread
+$!
+$myread:
+$ ans = ""
+$ If (fastread)
+$ Then
+$ echo4 "''rp'"
+$ Else
+$ If (silent)
+$ Then
+$ READ SYS$COMMAND/PROMPT="''rp'" ans
+$ Else
+$ echo ""
+$ READ SYS$COMMAND/PROMPT="''rp'" ans
+$ Endif
+$ Endif
+$ RETURN
+$!
+$Beyond_myread:
+$!
+$!: create .config dir to save info across Configure sessions
+$ IF ( F$SEARCH("[-]CONFIG.DIR").EQS."" )
+$ THEN
+$ CREATE/DIRECTORY [-.CONFIG]
+$ OPEN/WRITE CONFIG [-.CONFIG]README.
+$ WRITE CONFIG -
+ "This directory created by Configure to save information that should"
+$ WRITE CONFIG -
+ "persist across sessions."
+$ WRITE CONFIG ""
+$ WRITE CONFIG -
+ "You may safely delete it if you wish."
+$ CLOSE CONFIG
+$ ENDIF
+$!
+$!: general instructions
+$ needman = "true"
+$ firsttime = "true"
+$ user = F$EDIT(F$GETJPI("","USERNAME"),"TRIM,COLLAPSE")
+$ IF .NOT.(F$SEARCH("[-.CONFIG]INSTRUCT.").EQS."")
+$ THEN
+$ messages = F$ENVIRONMENT("MESSAGE")
+$ SET MESSAGE/NOFAC/NOSEV/NOIDENT/NOTEXT !sorry :-(
+$ contains /NOOUTPUT [-.CONFIG]INSTRUCT. 'user'
+$ IF .NOT.($status.EQ.%X08D78053)
+$ THEN
+$ firsttime=""
+$ dflt = "n"
+$ rp = "Would you like to see the instructions? [''dflt'] "
+$ GOSUB myread
+$ if .NOT.ans THEN needman=""
+$ ENDIF
+$ SET MESSAGE 'messages' !hope you made it here :-)
+$ ENDIF
+$ if (fastread.AND.silent.AND.(alldone.eqs."cont")) THEN needman=""
+$!
+$ IF (needman)
+$ THEN
+$ TYPE SYS$INPUT:
+
+This installation shell script will examine your system and ask you questions
+to determine how the perl5 package should be installed. If you get
+stuck on a question, you may use a ^C or ^Y shell escape to STOP this
+process, edit something, then restart this process as you just did.
+Many of the questions will have default answers in square
+brackets; typing carriage return will give you the default.
+
+$ READ SYS$COMMAND/PROMPT="Type carriage return to continue " ans
+$ TYPE SYS$INPUT:
+
+In a hurry? You may run '@Configure -d'. This will bypass nearly all
+the questions and use the computed defaults (or the previous answers provided
+there was already a config.sh file). Type '@Configure -h' for a list of
+options.
+
+$ READ SYS$COMMAND/PROMPT="Type carriage return to continue " ans
+$ TYPE SYS$INPUT:
+
+Much effort has been expended to ensure that this shell script will
+run on any VMS system. If despite that it blows up on yours, your
+best bet is to edit Configure.com and @ it again. Whatever problems
+you have with Configure.com, let me (sugalskd@ous.edu) know how I blew
+it.
+
+$!This installation script affects things in two ways:
+$!
+$!1) it may do direct variable substitutions on some of the files included
+$! in this kit.
+$!2) it builds a config.h file for inclusion in C programs. You may edit
+$! any of these files as the need arises after running this script.
+$!
+$!If you make a mistake on a question, there is no easy way to back up to it
+$!currently.
+$!
+$ READ SYS$COMMAND/PROMPT="Type carriage return to continue " ans
+$ IF (F$SEARCH("[-.CONFIG]INSTRUCT.").EQS."")
+$ THEN
+$ OPEN/WRITE CONFIG [-.CONFIG]INSTRUCT.
+$ WRITE CONFIG user
+$ CLOSE CONFIG
+$ ENDIF
+$ ENDIF !(needman .EQS. "true")
+$!
+$!: see if sh knows # comments !sfn
+$ sharpbang = "$ "
+$!: figure out how to guarantee sh startup !sfn
+$!: find out where common programs are !sfn
+$!loclist="awk/cat/comm/cp/echo/expr/find/grep/ln/ls/mkdir/rm/sed/sort/touch/tr/uniq"
+$!trylist="Mcc/byacc/cpp/csh/date/egrep/less/line/more/nroff/perl/pg/sendmail/test/uname"
+$! echo "I don't know where '$file' is, and my life depends on it."
+$! echo "Go find a public domain implementation or fix your PATH setting!"
+$! echo ""
+$! echo "Don't worry if any of the following aren't found..."
+$!: determine whether symbolic links are supported !sfn
+$!: see whether [:lower:] and [:upper:] are supported character classes !sfn
+$!: set up the translation script tr, must be called with ./tr of course !sfn
+$!
+$!: Try to determine whether config.sh was made on this system
+$!: Get old answers from old config file if Configure was run on the
+$!: same system, otherwise use the hints.
+$ config_sh_es = "''config_sh'/[-]config.sh/[-.vms]config.vms/"
+$ i = 0
+$ max = 3
+$Config_sh_look:
+$ config_sh = F$ELEMENT(i,"/",config_sh_es)
+$ i = i + 1
+$ IF (config_sh.NES."/").AND.(config_sh.NES."")
+$ THEN
+$ configshfound = F$SEARCH(config_sh)
+$ IF (configshfound.NES."") THEN GOTO Config_sh_found
+$ ENDIF
+$ IF (i.LT.max) THEN GOTO Config_sh_look
+$ IF (configshfound.EQS."") THEN GOTO Beyond_config_sh
+$Config_sh_found:
+$ echo ""
+$ echo "Fetching default answers from ''config_sh'..."
+$!we actually do not have "hints/" for VMS
+$! TYPE SYS$INPUT:
+$!
+$!First time through, eh? I have some defaults handy for the following systems:
+$!
+$! echo " ","VMS_VAX"
+$! echo " ","VMS_AXP"
+$! : Now look for a hint file osname_osvers, unless one has been
+$! : specified already.
+$! TYPE SYS$INPUT:
+$!
+$!You may give one or more space-separated answers, or "none" if appropriate.
+$!If your OS version has no hints, DO NOT give a wrong version -- say "none".
+$!
+$! READ SYS$COMMAND/PROMPT="Which of these apply, if any? " ans
+$!
+$Beyond_config_sh:
+$!
+$!: Restore computed paths !sfn
+$!
+$! genconfig.pl has "osname='VMS'"
+$ osname = F$EDIT(F$GETSYI("NODE_SWTYPE"),"COLLAPSE")
+$! %Config-I-VMS, a necessary error trap (could be PC running VCL)
+$!
+$ IF (osname .NES. "VMS")
+$ THEN
+$ echo4 "Hmm.. I wonder what ''osname' is (?)"
+$ TYPE SYS$INPUT:
+
+%Config-E-VMS, ERROR:
+
+ Err, you do not appear to be running VMS!
+ This package is intended to Configure the building of Perl for VMS.
+
+$ READ SYS$COMMAND/PROMPT="Continue anyway? [n] " ans
+$ IF ans
+$ THEN
+$ echo4 "Continuing..."
+$ ELSE
+$ echo4 "ABORTING..."
+$ SET DEFAULT 'vms_default_directory_name' !be kind rewind
+$ STOP
+$ EXIT 2 !$STATUS = "%X00000002" (error)
+$ ENDIF
+$ ELSE !we are on VMS huzzah!
+$ IF .NOT.silent
+$ THEN TYPE SYS$INPUT:
+
+Configure uses the operating system name and version to set some defaults.
+The default value is probably right if the name rings a bell. Otherwise,
+since spelling matters for me, either accept the default or answer "none"
+to leave it blank.
+$ ENDIF
+$ rp = "Operating system name? [''osname'] "
+$ GOSUB myread
+$ IF ans.nes.""
+$ THEN
+$ IF (ans.NES.osname) !.AND.knowitall
+$ THEN
+$ echo4 "I'll go with ''osname' anyway..."
+$ ENDIF
+$ ENDIF
+$ ENDIF !(osname .NES./.EQS. "VMS")
+$!
+$!: who configured the system
+$! see 'user' above.
+$ cf_by = F$EDIT(user,"LOWERCASE")
+$! cf_time = F$CVTIME() !superceded by procedure below
+$ osvers = F$GETSYI("VERSION")
+$!
+$! Peter Prymmer has seen:
+$! "SYS$TIMEZONE_DIFFERENTIAL" = "-46800" (sic)
+$! "SYS$TIME_ZONE" = "EDT"
+$!
+$! Charles Lane recommended:
+$! "SYS$TIMEZONE_DIFFERENTIAL" = "-14400"
+$! "NEWS_TIMEZONE" = "-0500"
+$! "ST_TIMEZONE" = "EDT"
+$! "JAN_TIME_ZONE" = "EST "
+$! "MULTINET_TIMEZONE" = "EST"
+$! "DAYLIGHT_SAVINGS" = "1"
+$!
+$! Charles Bailey recommends (in ANU NEWS Doc Jan 1995):
+$! "PMDF_Timezone"
+$! "Multinet_Timezone"
+$! "TCPware_Timezone"
+$! "WIN$Time_Zone"
+$!
+$! This snippet o' DCL returns a string in default Unix `date` format,
+$! and it will prompt to set SYS$TIMEZONE_DIFFERENTIAL.
+$! Peter Prymmer pvhp@lns62.lns.cornell.edu
+$!
+$ MIN_TZO = -840 !units are minutes here
+$ MAX_TZO = 840
+$!
+$ wkday = F$EXTRACT(0,3,F$CVTIME(,,"WEEKDAY"))
+$ monn = F$CVTIME(,,"MONTH")
+$ mday = F$EXTRACT(8,2,F$CVTIME(,,"DATE"))
+$ hour = F$CVTIME(,,"HOUR")
+$ min = F$CVTIME(,,"MINUTE")
+$ sec = F$CVTIME(,,"SECOND")
+$ year = F$CVTIME(,,"YEAR")
+$!
+$ months = "/Jan/Feb/Mar/Apr/May/Jun/Jul/Aug/Sep/Oct/Nov/Dec/"
+$ i = 0
+$Mon_loop:
+$ i = i + 1
+$ mon = F$ELEMENT(i,"/",months)
+$ IF i.LT.monn THEN GOTO Mon_loop
+$!
+$ tzneedset = "t"
+$ systz = F$TRNLNM("SYS$TIMEZONE_DIFFERENTIAL")
+$ IF systz.NES.""
+$ THEN
+$ tzhour = F$INTEGER(systz)/3600
+$ tzmins = F$INTEGER(systz)/60
+$ tzminrem = tzmins - tzhour*60
+$ IF tzminrem.lt.0 THEN tzminrem = -1*tzminrem !keeps !2ZL happy
+$ IF tzhour.ge.0
+$ THEN signothetime = "+"
+$ IF tzhour.EQ.0.AND.tzminrem.EQ.0
+$ THEN direction = "on GMT/"
+$ ELSE direction = "east of "
+$ ENDIF
+$ ELSE signothetime = "-"
+$ tzhour = -1*tzhour !keeps !UL happy
+$ direction = "west of "
+$ ENDIF
+$ echo ""
+$ echo "%Config-I-VMS,"
+$ echo "According to the setting of your ""SYS$TIMEZONE_DIFFERENTIAL"" (= ''systz')"
+$ IF tzminrem.ne.0
+$ THEN
+$ tzspan = "''tzhour' hours & ''tzminrem' minutes"
+$ ELSE
+$ tzspan = "''tzhour' hours"
+$ ENDIF
+$ dflt = "y"
+$ echo "Your system is ''tzspan' ''direction'UTC in England."
+$ rp = "%Config-I-VMS, (''systz') Is this UTC Time Zone Offset correct? [''dflt'] "
+$ GOSUB myread
+$ IF ans.OR.(ans.EQS."")
+$ THEN
+$ tzneedset = "f"
+$ tzd = systz
+$ GOTO Beyond_TimeZone
+$ ENDIF
+$ ELSE
+$ echo ""
+$ echo4 "%Config-I-VMS,"
+$ echo4 """SYS$TIMEZONE_DIFFERENTIAL"" does not appear to be DEFINEd on your system"
+$ ENDIF
+$!
+$TZSet:
+$ echo ""
+$ echo "Please tell me in hh:mm form what time offset from GMT/UTC in England"
+$ echo "you are. As an example Eastern (US) Standard Time is -5:00 offset, but"
+$ echo "Eastern Daylight Time (summer) is -4:00 offset."
+$ dflt = "0:00"
+$ rp = "Enter the Time Zone offset: [''dflt'] "
+$ GOSUB myread
+$ ans = F$Edit(ans,"collapse,trim,uncomment,upcase")
+$ IF ans.EQS."" THEN ans = dflt
+$ tzhour = F$ELEMENT(0,":","''ans'") !first
+$ IF tzhour.EQS."" THEN tzhour = 0
+$ tzhour = F$INTEGER(tzhour)
+$ tzminrem = F$ELEMENT(1,":","''ans'") !second
+$ IF tzminrem.NES.""
+$ THEN
+$ tzminrem = F$INTEGER(tzminrem)
+$ IF F$EXTRACT(0,1,"''ans'") .EQS. "-" THEN tzminrem = tzminrem * -1
+$ ELSE
+$ tzminrem = 0
+$ ENDIF
+$ tzmins = tzhour*60 + tzminrem
+$ tzd = F$STRING(tzmins*60)
+$ IF tzhour .GE. 0
+$ THEN
+$ signothetime = "+"
+$ ELSE
+$ tzhour = -1*tzhour !keeps !UL happy
+$ signothetime = "-"
+$ ENDIF
+$ IF (tzmins.GT.MAX_TZO).OR.(tzmins.LT.MIN_TZO)
+$ THEN
+$ echo ""
+$ echo "%Config-W-VMS-TIMERANGE, Response must be in the range -14:00 to 14:00."
+$ goto TZSet
+$ ENDIF
+$!
+$Beyond_TimeZone:
+$ tz = f$fao("UTC!AS!UL:!2ZL",signothetime,tzhour,tzminrem)
+$ cf_time = "''wkday' ''mon' ''mday' ''hour':''min':''sec' ''tz' ''year'"
+$!
+$!: determine the architecture name
+$! genconfig.pl has either archname='VMS_AXP' or 'VMS_VAX'
+$!
+$ IF (F$GETSYI("HW_MODEL") .LT. 1024)
+$ THEN
+$ archname = "VMS_VAX"
+$ ELSE
+$ archname = "VMS_AXP"
+$ ENDIF
+$ rp = "What is your architecture name? [''archname'] "
+$ GOSUB myread
+$ IF ans.NES.""
+$ THEN
+$ ans = F$EDIT(ans,"COLLAPSE, UPCASE")
+$ IF (ans.NES.archname) !.AND.knowitall
+$ THEN
+$ echo4 "I'll go with ''archname' anyway..."
+$ ENDIF
+$ ENDIF
+$ IF (archname.EQS."VMS_AXP")
+$ THEN
+$ dflt = "n"
+$ rp = "Are you sharing your PERL_ROOT with a VAX? [''dflt'] "
+$ GOSUB myread
+$ if ans.NES.""
+$ THEN
+$ ans = F$EDIT(ans,"COLLAPSE, UPCASE")
+$ ENDIF
+$ IF (ans.NES."Y")
+$ THEN
+$ sharedperl = "N"
+$ ELSE
+$ sharedperl = "Y"
+$ macros = macros + """AXE=1"","
+$ ENDIF
+$ ELSE
+$ sharedperl = "N"
+$ ENDIF
+$!
+$!: is AFS running? !sfn
+$!: decide how portable to be. Allow command line overrides. !sfn
+$!: set up shell script to do ~ expansion !sfn
+$!: expand filename !sfn
+$!: now set up to get a file name !sfn
+$!
+$ vms_skip_install = "true"
+$ dflt = "y"
+$! echo ""
+$ rp = "%Config-I-VMS, Do you wish to skip the """"where install"""" questions? [''dflt'] "
+$ GOSUB myread
+$ IF (.NOT.ans).AND.(ans.NES."") THEN vms_skip_install = "false"
+$ prefix = F$ENVIRONMENT("DEFAULT") - ".UU]" + "]"
+$ prefix = f$parse(prefix,,,,"NO_CONCEAL") - "][" - ".;"
+$ prefix = prefix - "]" + ".]"
+$ IF (.NOT.vms_skip_install)
+$ THEN
+$!: determine root of directory hierarchy where package will be installed.
+$ dflt = "default"
+$ IF .NOT.silent
+$ THEN
+$ echo ""
+$ echo "By default, ''package' will be installed in ''dflt'/bin, manual"
+$ echo "pages under ''dflt'/man, etc..., i.e. with ''dflt' as prefix for"
+$ echo "all installation directories. Typically set to /usr/local, but you"
+$ echo "may choose /usr if you wish to install ''package' among your system
+$ ENDIF
+$ IF .NOT.silent
+$ THEN TYPE SYS$INPUT:
+binaries. If you wish to have binaries under /bin but manual pages
+under /usr/local/man, that's ok: you will be prompted separately
+for each of the installation directories, the prefix being only used
+to set the defaults.
+$ ENDIF
+$ dflt = prefix
+$ rp = "Installation prefix to use? [ ''dflt' ] "
+$ GOSUB myread
+$ IF ans.NES.""
+$ THEN
+$ prefix = ans
+$ IF F$LOCATE(".]",ans) .EQ. F$LENGTH(ans) THEN prefix = prefix - "]" + ".]"
+$ ELSE
+$ prefix = dflt
+$ ENDIF
+$!
+$!: set the prefixit variable, to compute a suitable default value
+$!
+$!: determine where private library files go
+$!: Usual default is /usr/local/lib/perl5. Also allow things like
+$!: /opt/perl/lib, since /opt/perl/lib/perl5 would be redundant.
+$ IF .NOT.silent
+$ THEN TYPE SYS$INPUT:
+
+There are some auxiliary files for perl5 that need to be put into a
+private library directory that is accessible by everyone.
+$ ENDIF
+$ dflt = prefix - ".]" + ".LIB]"
+$ rp = "Pathname where the private library files will reside? "
+$ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ")
+$ GOSUB myread
+$ IF ans.NES.""
+$ THEN privlib = ans
+$ ELSE privlib = dflt
+$ ENDIF
+$!
+$ ENDIF !%Config-I-VMS, skip "where install" questions
+$!
+$!: set the base revision
+$ baserev="5.0"
+$!: get the patchlevel
+$ echo ""
+$ echo4 "Getting the current patchlevel..." !>&4
+$ patchlevel_h = F$SEARCH("[-]patchlevel.h")
+$ IF (patchlevel_h.NES."")
+$ THEN
+$ got_patch = "false"
+$ got_sub = "false"
+$ OPEN/READONLY CONFIG 'patchlevel_h'
+$Patchlevel_h_loop:
+$ READ/END_Of_File=Close_patch CONFIG line
+$ IF ((F$LOCATE("#define PATCHLEVEL",line).NE.F$LENGTH(line)).AND.(.NOT.got_patch))
+$ THEN
+$ line = F$EDIT(line,"COMPRESS, TRIM")
+$ patchlevel = F$EXTRACT(18,F$LENGTH(line)-18,line)
+$ got_patch = "true"
+$ ENDIF
+$ IF ((F$LOCATE("SUBVERSION",line).NE.F$LENGTH(line)).AND.(.NOT.got_sub))
+$ THEN
+$ line = F$EDIT(line,"COMPRESS, TRIM")
+$ subversion = F$EXTRACT(18,F$LENGTH(line)-18,line)
+$ got_sub = "true"
+$ ENDIF
+$ IF (.NOT.got_patch).OR.(.NOT.got_sub) THEN GOTO Patchlevel_h_loop
+$Close_patch:
+$ CLOSE CONFIG
+$ ELSE
+$ patchlevel="0"
+$ subversion="0"
+$ ENDIF
+$ echo "(You have ''package' ''baserev' PL''patchlevel' sub''subversion'.)"
+$! This whole thing needs replacing w/ F$FAO() calls:
+$ patchlevel = F$INTEGER(patchlevel)
+$ IF patchlevel.LT.10
+$ THEN patchlevel = "00" + F$STRING(patchlevel)
+$ ELSE patchlevel = "0" + F$STRING(patchlevel)
+$ ENDIF
+$ subversion = F$INTEGER(subversion)
+$ IF subversion.GT.0
+$ THEN
+$ IF subversion.LT.10
+$ THEN subversion = "0" + F$STRING(subversion)
+$ ELSE subversion = F$STRING(subversion)
+$ ENDIF
+$ ELSE subversion = ""
+$ ENDIF
+$!
+$ version = F$EXTRACT(0,1,baserev) + "_" + patchlevel + subversion
+$!
+$ IF (.NOT.vms_skip_install)
+$ THEN
+$!: set the prefixup variable, to restore leading tilda escape !sfn
+$!: set the prefixup variable, to restore leading tilde escape !sfn
+$!
+$!: determine where public architecture dependent libraries go
+$ IF (.NOT.silent)
+$ THEN
+$ echo ""
+$ echo "''package' contains architecture-dependent library files. If you are"
+$ ENDIF
+$ IF (.NOT.silent)
+$ THEN TYPE SYS$INPUT:
+sharing libraries in a heterogeneous environment, you might store
+these files in a separate location. Otherwise, you can just include
+them with the rest of the public library files.
+$ ENDIF
+$ dflt = privlib - "]" + "." + archname + "." + version + "]"
+$ rp = "Where do you want to put the public architecture-dependent libraries? "
+$ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ")
+$ GOSUB myread
+$ IF ans.NES.""
+$ THEN archlib = ans
+$ ELSE archlib = dflt
+$ ENDIF
+$!
+$!: set up the script used to warn in case of inconsistency !sfn
+$!: function used to set $1 to $val !sfn
+$!
+$ ENDIF !%Config-I-VMS, skip "where install" questions
+$! This quotation from Configure has to be included on VMS:
+$ TYPE SYS$INPUT:
+
+There is, however, a strange, musty smell in the air that reminds me of
+something...hmm...yes...I've got it...there's a VMS nearby, or I'm a Blit.
+$ CONTINUE
+$ IF (.NOT.vms_skip_install)
+$ THEN
+$!: it so happens the Eunice I know will not run shell scripts in Unix format
+$!
+$!: see if setuid scripts can be secure !sfn
+$!: now see if they want to do setuid emulation !sfn
+$!
+$!: determine where site specific libraries go.
+$ IF .NOT.silent
+$ THEN TYPE SYS$INPUT:
+
+The installation process will also create a directory for
+site-specific extensions and modules. Some users find it convenient
+to place all local files in this directory rather than in the main
+distribution directory.
+$ ENDIF
+$ dflt = privlib - "]" + ".SITE_PERL]"
+$ rp = "Pathname for the site-specific library files? "
+$ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ")
+$ GOSUB myread
+$ IF ans.NES.""
+$ THEN sitelib = ans
+$ ELSE sitelib = dflt
+$ ENDIF
+$!
+$!: determine where site specific architecture-dependent libraries go.
+$ IF .NOT.silent
+$ THEN TYPE SYS$INPUT:
+
+The installation process will also create a directory for
+architecture-dependent site-specific extensions and modules.
+$ ENDIF
+$ dflt = sitelib - "]" + "." + archname + "]"
+$ rp = "Pathname for the site-specific architecture-dependent library files? "
+$ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ")
+$ GOSUB myread
+$ IF ans.NES.""
+$ THEN sitearch = ans
+$ ELSE sitearch = dflt
+$ ENDIF
+$!
+$!: determine where old public architecture dependent libraries might be
+$!
+$!: determine where public executables go
+$ dflt = prefix - ".]" + ".BIN]"
+$ rp = "Pathname where the public executables will reside? "
+$ rp = F$FAO("!AS!/!AS",rp,"[ ''dflt' ] ")
+$ GOSUB myread
+$ IF ans.NES.""
+$ THEN bin = ans
+$ ELSE bin = dflt
+$ ENDIF
+$!
+$!: determine where manual pages are on this system
+$!: What suffix to use on installed man pages
+$!: see if we can have long filenames
+$!: determine where library module manual pages go
+$!: What suffix to use on installed man pages
+$!: see what memory models we can support
+$!
+$ ENDIF !%Config-I-VMS, skip "where install" questions
+$!
+$!: see if we need a special compiler
+$! cc_list = "cc/vaxc|cc/decc|gcc" !%Config-I-VMS, compiler symbols/commands
+$!
+$ nocc = "f"
+$ vms_cc_dflt = ""
+$ vms_cc_available = ""
+$!
+$ OPEN/WRITE CONFIG ccvms.c
+$ WRITE CONFIG "#include <stdlib.h>" !DECC is sooo picky
+$ WRITE CONFIG "#include <stdio.h>"
+$ WRITE CONFIG "int main() {"
+$ WRITE CONFIG "#ifdef __DECC"
+$ WRITE CONFIG " printf(""/DECC\n"");"
+$ WRITE CONFIG "#else"
+$ WRITE CONFIG " printf(""/VAXC\n"");"
+$ WRITE CONFIG "#endif"
+$ WRITE CONFIG " exit(0);"
+$ WRITE CONFIG "}"
+$ CLOSE CONFIG
+$!
+$ DEFINE SYS$ERROR _NLA0:
+$ DEFINE SYS$OUTPUT _NLA0:
+$ cc/NoObj/list=ccvms.lis ccvms.c
+$ tmp = $status
+$ DEASSIGN SYS$OUTPUT
+$ DEASSIGN SYS$ERROR
+$ IF (silent) THEN GOSUB Shut_up
+$! echo "%Config-I-VMS, After cc compile $status = >''tmp'<" !diagnostic
+$!
+$ IF tmp.NE.%X10B90001
+$ THEN
+$ IF tmp.NE.%X10000001
+$ THEN
+$ nocc = "t" !%X10000001 is return from gcc
+$ GOTO Gcc_initial_check
+$ ENDIF
+$ ENDIF
+$!
+$ GOSUB List_Parse
+$ IF .NOT.silent THEN echo ""
+$ echo "%Config-I-VMS, Default ""cc"" is ''line' ''archsufx' ''F$GETSYI("VERSION")'"
+$ IF F$LOCATE("VAX",line).NE.F$LENGTH(line)
+$ THEN
+$ vms_cc_dflt = "/vaxc"
+$ vms_cc_available = vms_cc_available + "cc/vaxc "
+$ IF .NOT.silent
+$ THEN
+$ echo "%Config-I-VMS, Will try cc/decc..."
+$ ENDIF
+$ DEFINE SYS$ERROR _NLA0:
+$ DEFINE SYS$OUTPUT _NLA0:
+$ SET NOON
+$ cc/decc/NoObj/list=ccvms.lis ccvms.c
+$ tmp = $status
+$ DEASSIGN SYS$OUTPUT
+$ DEASSIGN SYS$ERROR
+$ SET ON
+$ IF (silent) THEN GOSUB Shut_up
+$ IF tmp.NE.%X10B90001
+$ THEN
+$ echo "%Config-I-VMS, Apparently you don't have that one."
+$ ELSE
+$ GOSUB List_parse
+$ echo "%Config-I-VMS, You also have: ''line' ''archsufx' ''F$GETSYI("VERSION")'"
+$ vms_cc_available = vms_cc_available + "cc/decc "
+$ ENDIF
+$ ELSE
+$ IF F$LOCATE("DEC",line).NE.F$LENGTH(line)
+$ THEN
+$ vms_cc_dflt = "/decc"
+$ vms_cc_available = vms_cc_available + "cc/decc "
+$ echo "%Config-I-VMS, Will try cc/vaxc..."
+$ DEFINE SYS$ERROR _NLA0:
+$ DEFINE SYS$OUTPUT _NLA0:
+$ SET NOON
+$ cc/vaxc/NoObj/list=ccvms.lis ccvms.c
+$ tmp = $status
+$ DEASSIGN SYS$OUTPUT
+$ DEASSIGN SYS$ERROR
+$ SET ON
+$ IF (silent) THEN GOSUB Shut_up
+$ IF tmp.NE.%X10B90001
+$ THEN
+$ echo "%Config-I-VMS, Apparently you don't have that one."
+$ ELSE
+$ GOSUB List_parse
+$ echo "%Config-I-VMS, You also have: ''line' ''archsufx' ''F$GETSYI("VERSION")'"
+$ vms_cc_available = vms_cc_available + "cc/vaxc "
+$ ENDIF
+$ ENDIF
+$ ENDIF
+$!
+$Gcc_initial_check:
+$ echo "%Config-I-VMS, Checking for Gcc"
+$ OPEN/WRITE CONFIG gccvers.lis
+$ DEFINE SYS$ERROR CONFIG
+$ DEFINE SYS$OUTPUT CONFIG
+$ 'gcc_symbol'/noobj/version _nla0:
+$ tmp = $status
+$ DEASSIGN SYS$OUTPUT
+$ DEASSIGN SYS$ERROR
+$ IF (silent) THEN GOSUB Shut_up
+$ CLOSE CONFIG
+$ IF (tmp.NE.%X10000001).and.(tmp.ne.%X00030001)
+$ THEN
+$ echo "%Config-I-VMS, Symbol ""''gcc_symbol'"" is not defined. I guess you don't have it."
+$ goto cc_cleanup
+$ ENDIF
+$ OPEN/READ CONFIG gccvers.lis
+$GCC_List_Read:
+$ READ/END_OF_FILE=GCC_List_End CONFIG line
+$ GOTO GCC_List_Read
+$GCC_List_End:
+$ CLOSE CONFIG
+$ echo line
+$ vms_cc_available = vms_cc_available + "''gcc_symbol' "
+$ DELETE/NOLOG/NOCONFIRM gccvers.lis;
+$!
+$CC_Cleanup:
+$ DELETE/NOLOG/NOCONFIRM ccvms.*;
+$CC_Desired:
+$!: see if we need a special compiler
+$! echo ""
+$ echo "%Config-I-VMS, available compiler(s):"
+$ echo "( ''vms_cc_available')"
+$ IF .NOT.nocc
+$ THEN
+$ dflt = "cc''vms_cc_dflt'" !-> "cc" in case first compile went OK
+$ ELSE
+$ dflt = gcc_symbol
+$ ENDIF
+$ rp = "Use which C compiler? [''dflt'] "
+$ GOSUB myread
+$ IF ans.NES.""
+$ THEN
+$ ans = F$EDIT(ans,"TRIM, COMPRESS, LOWERCASE")
+$ Mcc = ans
+$ IF F$LOCATE("dec",ans).NE.F$LENGTH(ans)
+$ THEN
+$ Mcc = "cc/decc"
+$ Using_Dec_C = "Yes"
+$ C_COMPILER_Replace = "CC=cc=''Mcc'"
+$ ENDIF
+$ IF F$LOCATE("vax",ans).NE.F$LENGTH(ans)
+$ THEN
+$ Mcc = "cc/vaxc"
+$ Using_Vax_C = "Yes"
+$ C_COMPILER_Replace = "CC=cc=''Mcc'"
+$ ENDIF
+$ IF Mcc.NES.dflt
+$ THEN
+$ IF F$LOCATE("dec",dflt).NE.F$LENGTH(dflt)
+$ THEN
+$ C_COMPILER_Replace = "CC=cc=''Mcc'"
+$ ELSE
+$ Using_Dec_C = "Yes"
+$ IF F$LOCATE("vax",dflt).NE.F$LENGTH(dflt)
+$ THEN
+$ C_COMPILER_Replace = "CC=cc=''Mcc'"
+$ ENDIF
+$ ENDIF
+$ ELSE
+$ IF Mcc .EQS. "cc/decc"
+$ THEN
+$ Using_Dec_C = "Yes"
+$ C_COMPILER_Replace = "CC=cc=''Mcc'"
+$ ENDIF
+$ ENDIF
+$ ELSE
+$ Mcc = dflt
+$ IF Mcc .EQS. "cc/decc"
+$ THEN
+$ Using_Dec_C = "Yes"
+$ C_COMPILER_Replace = "CC=cc=''Mcc'"
+$ ENDIF
+$ IF Mcc .EQS. "cc/vaxc"
+$ THEN
+$ Using_Vax_C = "Yes"
+$ C_COMPILER_Replace = "CC=cc=''Mcc'"
+$ ENDIF
+$ IF Mcc .EQS. "gcc"
+$ THEN
+$ Using_Gnu_C = "Yes"
+$ C_COMPILER_Replace = "CC=cc=''Mcc'"
+$ ENDIF
+$ ENDIF
+$Decc_Version_check:
+$ IF "''Using_Dec_C'".EQS."Yes"
+$ THEN
+$ echo ""
+$ echo4 "Checking for Dec C's version number..." !>&4
+$ OPEN/WRITE CONFIG deccvers.c
+$ WRITE CONFIG "#include <stdlib.h>" !DECC is sooo picky
+$ WRITE CONFIG "#include <stdio.h>"
+$ WRITE CONFIG "int main() {"
+$ WRITE CONFIG "#ifdef __DECC"
+$ WRITE CONFIG "#ifdef __DECC_VER"
+$ WRITE CONFIG " printf(""%i\n"", __DECC_VER);"
+$ WRITE CONFIG "#else"
+$ WRITE CONFIG " printf(""%i\n"", ""1"");"
+$ WRITE CONFIG "#endif"
+$ WRITE CONFIG "#endif"
+$ WRITE CONFIG " exit(0);"
+$ WRITE CONFIG "}"
+$ CLOSE CONFIG
+$ DEFINE SYS$ERROR _NLA0:
+$ DEFINE SYS$OUTPUT _NLA0:
+$ 'Mcc' deccvers.c
+$ tmp = $status
+$ DEASSIGN SYS$ERROR _NLA0:
+$ DEASSIGN SYS$OUTPUT _NLA0:
+$ IF (silent) THEN GOSUB Shut_up
+$ DEFINE SYS$ERROR _NLA0:
+$ DEFINE SYS$OUTPUT _NLA0:
+$ link deccvers.obj
+$ tmp = $status
+$ DEASSIGN SYS$ERROR
+$ DEASSIGN SYS$OUTPUT
+$ IF (silent) THEN GOSUB Shut_up
+$ OPEN/WRITE CONFIG deccvers.out
+$ DEFINE SYS$ERROR CONFIG
+$ DEFINE SYS$OUTPUT CONFIG
+$ mcr []deccvers.exe
+$ tmp = $status
+$ CLOSE CONFIG
+$ DEASSIGN SYS$OUTPUT
+$ DEASSIGN SYS$ERROR
+$ IF (silent) THEN GOSUB Shut_up
+$ OPEN/READ CONFIG deccvers.out
+$ READ/END_OF_FILE=Dec_c_cleanup CONFIG line
+$Dec_c_cleanup:
+$ CLOSE CONFIG
+$! DELETE/NOLOG/NOCONFIRM deccvers.*;
+$ echo "You are using Dec C ''line'"
+$ Dec_C_Version = line
+$ ENDIF
+$Vaxc_Invoke_check:
+$ IF "''Using_Vax_C'".EQS."Yes"
+$ THEN
+$ echo ""
+$ echo4 "Checking to see how to invoke Vax C..."
+$ OPEN/WRITE CONFIG vaxcchk.c
+$ WRITE CONFIG "#include <stdio.h>"
+$ WRITE CONFIG "int main() {"
+$ WRITE CONFIG " printf(""%i\n"", ""1"");"
+$ WRITE CONFIG " exit(0);"
+$ WRITE CONFIG "}"
+$ CLOSE CONFIG
+$ DEFINE SYS$ERROR _NLA0:
+$ DEFINE SYS$OUTPUT _NLA0:
+$ SET NOON
+$ cc/vaxc/NoObj vaxcchk.c
+$ tmp = $status
+$ DEASSIGN SYS$OUTPUT
+$ DEASSIGN SYS$ERROR
+$ SET ON
+$ IF (silent) THEN GOSUB Shut_up
+$ IF tmp.NE.%X10B90001
+$ THEN
+$ Mcc = "cc"
+$ ELSE
+$ Mcc = "cc/vaxc"
+$ ENDIF
+$Vax_c_cleanup:
+$ DELETE/NOLOG/NOCONFIRM vaxcchk.*;
+$ ENDIF
+$Gcc_check:
+$ if "''using_gnu_c'" .eqs. "Yes"
+$ THEN
+$ vaxcrtl_olb = F$SEARCH("SYS$LIBRARY:VAXCRTL.OLB")
+$ vaxcrtl_exe = F$SEARCH("SYS$SHARE:VAXCRTL.EXE")
+$ gcclib_olb = F$SEARCH("GNU_CC:[000000]GCCLIB.OLB")
+$ IF gcclib_olb .EQS. ""
+$ THEN
+$! These objects/libs come w/ gcc 2.7.2 for AXP:
+$ tmp = F$SEARCH("GNU_CC:[000000]libgcc2.olb")
+$ IF tmp .NES. "" then gcclib_olb = tmp
+$ tmp = F$SEARCH("GNU_CC:[000000]libgcclib.olb")
+$ IF tmp .NES. ""
+$ THEN
+$ IF gcclib_olb .EQS. ""
+$ THEN gcclib_olb = tmp
+$ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp
+$ ENDIF
+$ ENDIF
+$ tmp = F$SEARCH("SYS$LIBRARY:VAXCRTL.OLB")
+$ IF tmp .NES. ""
+$ THEN
+$ IF gcclib_olb .EQS. ""
+$ THEN gcclib_olb = tmp
+$ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp
+$ ENDIF
+$ ENDIF
+$ tmp = F$SEARCH("GNU_CC:[000000]crt0.obj")
+$ IF tmp .NES. ""
+$ THEN
+$ IF gcclib_olb .EQS. ""
+$ THEN gcclib_olb = tmp
+$ ELSE gcclib_olb = gcclib_olb + "/lib," + tmp
+$ ENDIF
+$ ENDIF
+$ IF gcclib_olb .EQS. vaxcrtl_olb THEN gcclib_olb = "" !goofy order of axplibs
+$ ELSE
+$ gcclib_olb = gcclib_olb + "/lib"
+$ ENDIF
+$ IF gcclib_olb .NES. "" .AND. -
+ (vaxcrtl_olb .NES. "" .OR. -
+ vaxcrtl_exe .NES. "" )
+$ THEN
+$ echo ""
+$ echo4 "Checking for GNU cc in disguise and/or its version number..." !>&4
+$ OPEN/WRITE CONFIG gccvers.c
+$ WRITE CONFIG "#include <stdlib.h>" !DECC is sooo picky
+$ WRITE CONFIG "#include <stdio.h>"
+$ WRITE CONFIG "int main() {"
+$ WRITE CONFIG "#ifdef __GNUC__"
+$ WRITE CONFIG "#ifdef __VERSION__"
+$ WRITE CONFIG " printf(""%s\n"", __VERSION__);"
+$ WRITE CONFIG "#else"
+$ WRITE CONFIG " printf(""%s\n"", ""1"");"
+$ WRITE CONFIG "#endif"
+$ WRITE CONFIG "#endif"
+$ WRITE CONFIG " exit(0);"
+$ WRITE CONFIG "}"
+$ CLOSE CONFIG
+$ DEFINE SYS$ERROR _NLA0:
+$ DEFINE SYS$OUTPUT _NLA0:
+$ 'Mcc' gccvers.c
+$ tmp = $status
+$ DEASSIGN SYS$ERROR _NLA0:
+$ DEASSIGN SYS$OUTPUT _NLA0:
+$ IF (silent) THEN GOSUB Shut_up
+$ DEFINE SYS$ERROR _NLA0:
+$ DEFINE SYS$OUTPUT _NLA0:
+$ IF vaxcrtl_exe .EQS. ""
+$ THEN
+$ IF F$LOCATE("VAXCRTL",gcclib_olb).NE.F$LENGTH(gcclib_olb)
+$ THEN
+$ link gccvers.obj,'gcclib_olb',SYS$LIBRARY:VAXCRTL/Library
+$ tmp = $status
+$ ELSE
+$ link gccvers.obj,'gcclib_olb'
+$ tmp = $status
+$ ENDIF
+$ ELSE
+$ OPEN/WRITE CONFIG GCCVERS.OPT
+$ WRITE CONFIG "SYS$SHARE:VAXCRTL/SHARE"
+$ CLOSE CONFIG
+$ link gccvers.obj,GCCVERS.OPT/OPT,'gcclib_olb'
+$ tmp = $status
+$ ENDIF
+$ DEASSIGN SYS$ERROR
+$ DEASSIGN SYS$OUTPUT
+$ IF (silent) THEN GOSUB Shut_up
+$ OPEN/WRITE CONFIG gccvers.out
+$ DEFINE SYS$ERROR CONFIG
+$ DEFINE SYS$OUTPUT CONFIG
+$ mcr []gccvers.exe
+$ tmp = $status
+$ CLOSE CONFIG
+$ DEASSIGN SYS$OUTPUT
+$ DEASSIGN SYS$ERROR
+$ IF (silent) THEN GOSUB Shut_up
+$ OPEN/READ CONFIG gccvers.out
+$ READ/END_OF_FILE=Gcc_cleanup CONFIG line
+$Gcc_cleanup:
+$ CLOSE CONFIG
+$ DELETE/NOLOG/NOCONFIRM gccvers.*;
+$ IF F$LOCATE("GNU C version ",line).NE.F$LENGTH(line)
+$ THEN
+$ echo "You are not using GNU cc."
+$ GOTO Host_name
+$ ELSE
+$ echo "You are using GNU cc ''line'"
+$ Using_Gnu_C = "Yes"
+$ C_COMPILER_Replace = "CC=cc=''Mcc'"
+$ GOTO Include_dirs
+$ ENDIF
+$ ENDIF
+$endif
+$ GOTO Host_name
+$!
+$List_Parse:
+$ OPEN/READ CONFIG ccvms.lis
+$ READ CONFIG line
+$ IF (F$GETSYI("HW_MODEL") .LT. 1024)
+$ THEN
+$ read CONFIG line
+$ archsufx = "VAX"
+$ ELSE
+$ archsufx = "AXP"
+$ ENDIF
+$ CLOSE CONFIG
+$ line = F$EDIT(line,"TRIM,COMPRESS")
+$ line = line - "Page 1" ! occurs at end all compilers
+$ line = line - "CCVMS " ! filename appears w/ VAXC
+$ line = line - "Source Listing " ! Seen w/ AXP DECC
+$ tmp = F$EXTRACT(0,20,line) !timestamp, e.g. "30-JUL-1996 21:12:54 "
+$ line = line - tmp
+$ line = F$EDIT(line,"TRIM") !bit redundant but we're in no big hurry
+$ DELETE/NOLOG/NOCONFIRM ccvms.lis;
+$ RETURN
+$!
+$Include_dirs:
+$!: What should the include directory be ?
+$ dflt = gcclib_olb
+$ rp = "Where are the include files you want to use? "
+$ IF f$length( rp + "[''dflt'] " ).gt.76
+$ THEN rp = F$FAO("!AS!/!AS",rp,"[''dflt'] ")
+$ ELSE rp = rp + "[''dflt'] "
+$ ENDIF
+$ GOSUB myread
+$ usrinc = ans
+$!
+$!: see if we have to deal with yellow pages, now NIS.
+$!: now get the host name
+$Host_name:
+$ echo ""
+$ echo4 "Figuring out host name..." !>&4
+$ myhostname = ""
+$ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("ARPANET_HOST_NAME")
+$ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("INTERNET_HOST_NAME")
+$ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("MULTINET_HOST_NAME")
+$ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("UCX$INET_HOST_NAME")
+$ IF myhostname.eqs."".and. -
+ F$TRNLNM("UCX$INET_HOST") .nes. "" .and. -
+ F$TRNLNM("UCX$INET_DOMAIN") .nes. "" THEN -
+ myhostname = F$TRNLNM("UCX$INET_HOST") + "." + F$TRNLNM("UCX$INET_DOMAIN")
+$ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("TCPWARE_DOMAINNAME")
+$ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("NEWS_ADDRESS")
+$ IF myhostname.eqs."" THEN myhostname = F$TRNLNM("SYS$NODE") - "::"
+$ IF myhostname.eqs."" THEN myhostname = F$EDIT(F$GETSYI("SCSNODE"),"TRIM")
+$!: you do not want to know about this
+$!: verify guess
+$ rp = "Your host name appears to be """"''myhostname'"""". Right? "
+$ GOSUB myread
+$ IF (.not.ans).and.(ans.NES."")
+$ THEN
+$ READ SYS$COMMAND/PROMPT= -
+ "Please type the (one word) name of your host: " ans
+$ myhostname = ans
+$ ENDIF
+$!: translate upper to lower if necessary
+$ myhostname = F$EDIT(myhostname,"COLLAPSE")
+$ mylowhostname = F$EDIT(myhostname," LOWERCASE")
+$ IF mylowhostname.NES.myhostname
+$ THEN
+$ echo "(Normalizing case in your host name)"
+$ myhostname = mylowhostname
+$ ENDIF
+$!
+$ fp = F$LOCATE(".",myhostname)
+$ mydomain = F$EXTRACT(fp,(F$LENGTH(myhostname)-fp)+1,myhostname)
+$ IF mydomain.NES."" !no periods in DECnet names like "MYDECNODE::"
+$ THEN
+$ rp = "What is your domain name? [''mydomain'] "
+$ GOSUB myread
+$ IF ans THEN mydomain = ans
+$!: translate upper to lower if necessary
+$ mydomain = F$EDIT(mydomain,"COLLAPSE")
+$ mylowdomain = F$EDIT(mydomain," LOWERCASE")
+$ IF mylowdomain.NES.mydomain
+$ THEN
+$ echo "(Normalizing case in your domain name)"
+$ mydomain = mylowdomain
+$ ENDIF
+$ ENDIF
+$ myhostname = myhostname - mydomain
+$ echo "(Trimming domain name from host name--host name is now ''myhostname')"
+$ IF .NOT.silent
+$ THEN TYPE SYS$INPUT:
+
+I need to get your e-mail address in Internet format if possible, i.e.
+something like user@host.domain. Please answer accurately since I have
+no easy means to double check it. The default value provided below
+is most probably close to the reality but may not be valid from outside
+your organization...
+$ ENDIF
+$ dflt = "''cf_by@''myhostname'"+"''mydomain'"
+$ rp = "What is your e-mail address? [''dflt'] "
+$ GOSUB myread
+$ IF ans
+$ THEN cf_email = ans
+$ ELSE cf_email = dflt
+$ ENDIF
+$!
+$ IF .NOT.silent
+$ THEN TYPE SYS$INPUT:
+
+If you or somebody else will be maintaining perl at your site, please
+fill in the correct e-mail address here so that they may be contacted
+if necessary. Currently, the "perlbug" program included with perl
+will send mail to this address in addition to perlbug@perl.com. You may
+enter "none" for no administrator.
+$ ENDIF
+$ dflt = "''cf_email'"
+$ rp = "Perl administrator e-mail address [''dflt'] "
+$ GOSUB myread
+$ IF ans
+$ THEN perladmin = ans
+$ ELSE perladmin = dflt
+$ ENDIF
+$!
+$!: determine where public executable scripts go
+$!: determine perl absolute location
+$!: figure out how to guarantee perl startup
+$!
+$!: see how we invoke the C preprocessor
+$! echo ""
+$! echo4 "Now, how can we feed standard input to your C preprocessor..." !>&4
+$!: Set private lib path
+$!: Now check and see which directories actually exist, avoiding duplicates
+$!: determine optimize, if desired, or use for debug flag also
+$!: We will not override a previous value, but we might want to
+$!: augment a hint file
+$!: the following weeds options from ccflags that are of no interest to cpp
+$!: flags used in final linking phase
+$!: Try to guess additional flags to pick up local libraries.
+$!: coherency check
+$! echo ""
+$! echo4 "Checking your choice of C compiler and flags for coherency..." !>&4
+$!: compute shared library extension
+$!: Looking for optional libraries
+$!: see if nm is to be used to determine whether a symbol is defined or not
+$!: get list of predefined functions in a handy place
+$!: see if we have sigaction
+$!: see whether socketshr exists
+$ IF (F$SEARCH(F$PARSE("SocketShr","Sys$Share:.Exe")).NES."")
+$ THEN
+$ has_socketshr = "T"
+$ echo ""
+$ echo4 "Hmm... Looks like you have SOCKETSHR's Berkeley networking support."
+$ endif
+$ if (Dec_C_Version .ge. 50200000)
+$ THEN
+$ Has_Dec_C_Sockets = "T"
+$ echo ""
+$ echo4 "Hmm... Looks like you've got Dec C's Berkeley networking support."
+$ ENDIF
+$ ! Hey, we've got both. Default to Dec C, then, since it's better
+$ if ("''Has_socketshr'".eq."T") .or.("''has_dec_c_sockets'".eq."T")
+$ THEN
+$ echo ""
+$ echo "You've got sockets available. Which socket stack do you want to"
+$ echo "build into perl?"
+$ if "''has_dec_c_sockets'".eqs."T"
+$ THEN
+$ dflt = "DECC"
+$ else
+$ dflt = "SOCKETSHR"
+$ endif
+$ rp = "Choose socket stack (NONE"
+$ if "''has_socketshr'".eqs."T" THEN rp = rp + ",SOCKETSHR"
+$ if "''has_dec_c_sockets'".eqs."T" THEN rp = rp + ",DECC"
+$ rp = rp + ") [''dflt'] "
+$ GOSUB myread
+$ IF "''ans'".eqs."" THEN ans = "''dflt'"
+$ has_dec_c_sockets = "F"
+$ has_socketshr = "F"
+$ ans = F$EDIT(ans,"TRIM,COMPRESS,LOWERCASE")
+$ IF ans.eqs."decc" then has_dec_c_sockets = "T"
+$ IF ans.eqs."socketshr" then has_socketshr = "T"
+$ endif
+$!
+$!
+$! Ask about threads, if appropriate
+$ if (Using_Dec_C.eqs."Yes")
+$ THEN
+$ echo "This version of Perl can be built with threads. While really nifty,
+$ echo "they are a beta feature, and there is a speed penalty for perl
+$ echo "programs if you build with threads *even if you don't use them*
+$ echo ""
+$ dflt = "n"
+$ rp = "Build with threads? [''dflt'] "
+$ GOSUB myread
+$ if ans.eqs."" then ans = dflt
+$ if (f$extract(0, 1, "''ans'").eqs."Y").or.(f$extract(0, 1, "''ans'").eqs."y")
+$ THEN
+$ use_threads="T"
+$ ! Are they on VMS 7.1 on an alpha?
+$ if (Archname.eqs."VMS_AXP").and.("''f$extract(1,3, f$getsyi(""version""))'".ges."7.1")
+$ THEN
+$ echo ""
+$ echo "Threaded perl can be linked to use multiple kernel threads
+$ echo "and system upcalls on VMS 7.1+ on Alpha systems. This feature
+$ echo "allows multiple threads to execute simultaneously on an SMP
+$ echo "system as well as preventing a single thread from blocking
+$ echo "all the threads in a program, even on a single-processor
+$ echo "machine. Unfortunately this feature isn't safe on an
+$ echo "unpatched 7.1 system. (Several OS patches were required when
+$ echo "this procedure was written)
+$ echo ""
+$ dflt = "n"
+$ rp = "Enable multiple kernel threads and upcalls? [''dflt'] "
+$ gosub myread
+$ if ans.eqs."" then ans="''dflt'"
+$ if f$extract(0, 1, f$edit(ans,"TRIM,COMPRESS,UPCASE")).eqs."Y"
+$ THEN
+$ Thread_Live_Dangerously = "MT=MT=1"
+$ ENDIF
+$ ENDIF
+$ ENDIF
+$ ENDIF
+$!
+$! Pre-load %ENV?
+$ echo ""
+$ echo "Because of the way perl fetches the list of logical names
+$ echo "for the %ENV hash (we spawn a subprocess that does a
+$ echo "SHOW LOGICALS *, which is expensive), we defer fetching it
+$ echo "until the first time a program iterates over the %ENV hash.
+$ echo "This means things like 'exists($ENV{'SYS$MANAGER'})' will
+$ echo "return false unless you've already accessed $ENV{SYS$MANAGER}
+$ echo "or done something like a keys %ENV."
+$ echo ""
+$ echo "If you choose, perl can populate the %ENV hash at startup.
+$ echo "This will exact both a memory penalty (to store the keys) and
+$ echo "a time penalty (to spawn the subprocess) every time you invoke
+$ echo "perl. Depending on your system, this might not be a big deal.
+$ echo ""
+$ dflt = "n"
+$ rp = "Populate %ENV at startup time? [''dflt'] "
+$ GOSUB myread
+$ if ans.eqs."" then ans="''dflt'"
+$ preload_env = f$extract(0, 1, f$edit(ans,"TRIM,COMPRESS,UPCASE"))
+$!
+$! Ask if they want to use perl's memory allocator
+$ echo ""
+$ echo "Perl has a built-in memory allocator that's tuned for perl's
+$ echo "normal memory usage. It's oftentimes better than the standard
+$ echo "system memory allocator. It also has the advantage of providing
+$ echo "memory allocation statistics, if you choose to enable them.
+$ echo ""
+$ dflt = "n"
+$ rp = "Build with perl's memory allocator? [''dflt'] "
+$ GOSUB myread
+$ if ans.eqs."" then ans="''dflt'"
+$ mymalloc = f$extract(0, 1, f$edit(ans,"TRIM,COMPRESS,UPCASE"))
+$ if mymalloc.eqs."Y"
+$ THEN
+$ if use_debugging_perl.eqs."Y"
+$ THEN
+$ echo ""
+$ echo "Perl can keep statistics on memory usage if you choose to use
+$ echo "them. This is useful for debugging, but does have some
+$ echo "performance overhead.
+$ echo ""
+$ dflt = "n"
+$ rp = "Do you want the debugging memory allocator? [''dflt'] "
+$ gosub myread
+$ if ans.eqs."" then ans="''dflt'"
+$ use_debugmalloc = f$extract(0, 1, f$edit(ans, "TRIM,COMPRESS,UPCASE"))
+$ ENDIF
+$ ! Check which memory allocator we want
+$ echo ""
+$ echo "There are currently three different memory allocators: the
+$ echo "default (which is a pretty good general-purpose memory manager),
+$ echo "the TWO_POT allocator (which is optimized to save memory for
+$ echo "larger allocations), and PACK_MALLOC (which is optimized to save
+$ echo "memory for smaller allocations). They're all good, but if your
+$ echo "usage tends towards larger chunks use TWO_POT, otherwise use
+$ echo "PACK_MALLOC."
+$ echo ""
+$ dflt = "DEFAULT"
+$ rp = "Memory allocator (DEFAULT, TWO_POT, PACK_MALLOC) [''dflt'] "
+$ GOSUB myread
+$ if ans.eqs."" then ans = "''dflt'"
+$ if ans.eqs."TWO_POT" then use_two_pot_malloc = "Y"
+$ if ans.eqs."PACK_MALLOC" then use_pack_malloc = "Y"
+$ ENDIF
+$!
+$! Ask for their default list of extensions to build
+$ echo ""
+$ echo "It's time to specify which modules you want to build into
+$ echo "perl. Most of these are standard and should be chosen, though
+$ echo "you might, for example, want to build GDBM_File instead of
+$ echo "SDBM_File if you have the GDBM library built on your machine
+$ echo "
+$ echo "Which modules do you want to build into perl?"
+$ dflt = "Fcntl Errno IO Opcode Dumper attrs re Stdio DCLsym B SDBM_File"
+$ if Using_Dec_C.eqs."Yes"
+$ THEN
+$ dflt = dflt + " POSIX"
+$ if Use_Threads.eqs."T"
+$ THEN
+$ dflt = dflt + " Thread"
+$ ENDIF
+$ ENDIF
+$ rp = "[''dflt'] "
+$ GOSUB myread
+$ if ans.eqs."" then ans = "''dflt'"
+$ extensions = "''ans'"
+$!
+$! %Config-I-VMS, determine build/make utility here (make gmake mmk mms)
+$ echo ""
+$ echo "%Config-I-VMS, Checking your ""make"" utilities..."
+$! If the 'build' that you use is not here add it and it's test
+$! switch to the _END_ of these strings (and increment max_build)
+$! (e.g. builders = builders + "/FOOMAKE"
+$! probers = probers + " -fooVersionSwitch"
+$! ) & please let me know about it.
+$ builders = "IMAKE/GNUMAKE/MGMAKE/GMAKE/MAKE/MMS/MMK"
+$ probers = "-f Makefile. -v!-f Makefile. -v!-f Makefile. -v!-f Makefile. -v!-f Makefile. -v!/IDENT!/IDENT"
+$ max_build = 7
+$!
+$ orig_dflt = "MMK"
+$ default_set = ""
+$ ok_builders = ""
+$ OPEN/WRITE/ERROR=Open_error CONFIG Makefile.
+$ WRITE CONFIG "dont_make_anything_yet:"
+$ WRITE CONFIG F$FAO("!_")
+$ CLOSE CONFIG
+$ n = 0
+$ messages = F$ENVIRONMENT("MESSAGE")
+$Build_probe:
+$ build = F$ELEMENT(n,"/",builders)
+$ probe = F$ELEMENT(n,"!",probers)
+$ echo "Testing whether you have ''build' on your system..."
+$ SET NOON !sorry :-(
+$ ON CONTROL_Y THEN GOTO Reenable_messages_build !sorry :-(
+$ SET MESSAGE/NOFAC/NOSEV/NOIDENT/NOTEXT !sorry :-(
+$ 'build' 'probe'
+$ IF ($SEVERITY .EQ. 1)
+$ THEN
+$ echo "OK."
+$ IF (build .EQS. orig_dflt)
+$ THEN
+$ default_set = "TRUE"
+$ dflt = build
+$ ENDIF
+$ ok_builders = ok_builders + " " + build
+$ IF (.NOT. default_set) THEN dflt = build
+$ ELSE
+$ echo "Nope."
+$ ENDIF
+$Reenable_messages_build: !hope you made it here :-)
+$ SET MESSAGE 'messages' !hope you made it here :-)
+$ SET ON !hope you made it here :-)
+$ n = n + 1
+$ IF (n .LT. max_build) THEN GOTO Build_probe
+$!
+$ echo ""
+$ IF (ok_builders .NES. "")
+$ THEN
+$ echo "Here is the list of builders you can apparently use:"
+$ echo "(",ok_builders," )"
+$ rp = "Which """"make"""" utility do you wish to use [''dflt']? "
+$ GOSUB myread
+$ ans = F$EDIT(ans,"TRIM, COMPRESS")
+$ ans = F$EXTRACT(0,F$LOCATE(" ",ans),ans) !throw out "-f Makefile." here
+$ IF (ans .EQS. "")
+$ THEN build = dflt
+$ ELSE build = ans
+$ ENDIF
+$ ELSE
+$ TYPE SYS$INPUT:
+
+%Config-E-VMS, ERROR:
+ Well this looks pretty serious. Perl5 cannot be compiled without a "make"
+ utility of some sort and after checking my "builders" list I cannot find
+ the symbol or command you use on your system to compile programs.
+
+$ READ SYS$COMMAND/PROMPT="%Config-I-VMS, Which ""MMS"" do you use? " ans
+$ ans = F$EDIT(ans,"TRIM, COMPRESS")
+$ ans = F$EXTRACT(0,F$LOCATE(" ",ans),ans) !throw out "-f Makefile." here
+$ IF (ans .EQS. "")
+$ THEN build = dflt
+$ echo "I don't know where 'make' is, and my life depends on it."
+$ echo "Go find a make program or fix your DCL$PATH setting!"
+$ echo "ABORTING..."
+$ SET DEFAULT 'vms_default_directory_name' !be kind rewind
+$ STOP
+$ EXIT 2 !$STATUS = "%X00000002" (error)
+$ ELSE
+$ build = ans
+$ ENDIF
+$ ENDIF
+$!
+$ DELETE/NOLOG Makefile.;
+$ GOTO Beyond_open
+$Open_error:
+$ TYPE SYS$INPUT:
+
+ There seems to be trouble. I just tried to create a file in
+$ echo4 'F$ENVIRONMENT("DEFAULT")'
+$ TYPE SYS$INPUT:
+ but was unsuccessful. I am stopping now. Please check that directories'
+ PROTECTION bits. I will leave you in the directory where you started
+ Configure.com
+$ echo4 "ABORTING..."
+$ GOTO Clean_up
+$ STOP
+$ EXIT
+$!
+$Beyond_open:
+$! echo " Very well I will proceed with ""''build'"""
+$ make = F$EDIT(build,"UPCASE")
+$!
+$!: locate the preferred pager for this system
+$!pagers = "most|more|less|type/page"
+$!rp='What pager is used on your system?'
+$!
+$! update [.vms]config.vms here
+$!
+$! update makefile here
+$! echo4 "Updating makefile..."
+$!
+$ IF (make .EQS. "MMS").OR.(make .EQS. "MMK")
+$ THEN
+$ makefile = "" !wrt MANIFEST dir
+$ UUmakefile = "DESCRIP.MMS" !wrt CWD dir
+$ DEFmakefile = "DESCRIP.MMS" !wrt DEF dir (?)
+$ ELSE
+$ makefile = " -f [.VMS]Makefile." !wrt MANIFEST dir
+$ UUmakefile = "[-.VMS]Makefile." !wrt CWD dir
+$ DEFmakefile = "[-.VMS]Makefile." !wrt DEF dir (?)
+$ ENDIF
+$!
+$ IF macros.NES.""
+$ THEN
+$ tmp = F$LENGTH(macros)
+$ macros = F$EXTRACT(0,(tmp-1),macros) !miss trailing comma
+$ macros = "/macro=(" + macros + ")"
+$ ENDIF
+$!
+$! Invoke the subconfig piece
+$!
+$ echo ""
+$ echo4 "Checking the C Run time library"
+$ dflt = F$ENVIRONMENT("DEFAULT")
+$ SET DEFAULT [-.vms]
+$ @subconfigure
+$ SET DEFAULT 'dflt
+$!
+$! %Config-I-VMS, write perl_setup.com here
+$!
+$ echo ""
+$ echo4 "%Config-I-VMS, The perl_setup.com file is now being written..."
+$ file_2_find = "[-.vms]perl_setup.com"
+$ OPEN/WRITE CONFIG 'file_2_find'
+$ WRITE CONFIG "$!"
+$ WRITE CONFIG "$! Perl_Setup.com ''cf_time'"
+$ IF cf_email.NES.perladmin
+$ THEN
+$ WRITE CONFIG "$! perl configured by ''cf_email'"
+$ ELSE
+$ WRITE CONFIG "$! This perl configured & administered by ''perladmin'"
+$ ENDIF
+$ WRITE CONFIG "$!"
+$ IF F$LOCATE(".]",prefix) .EQ. F$LENGTH(prefix) THEN -
+ prefix = prefix - "]" + ".]"
+$ WRITE CONFIG "$ define/translation=concealed Perl_Root ''prefix'"
+$ WRITE CONFIG "$ perl :== $Perl_Root:[000000]Perl"
+$ WRITE CONFIG "$ define PerlShr Perl_Root:[000000]PerlShr.Exe"
+$ IF (tzneedset)
+$ THEN
+$ WRITE CONFIG "$ define SYS$TIMEZONE_DIFFERENTIAL ''tzd'"
+$ ELSE !leave in but commented out (in case setting was from perl :-)
+$ WRITE CONFIG "$! define SYS$TIMEZONE_DIFFERENTIAL ''tzd'"
+$ ENDIF
+$ WRITE CONFIG "$!"
+$ WRITE CONFIG "$! Symbols for commonly used scripts:"
+$ WRITE CONFIG "$!"
+$ WRITE CONFIG "$ Perldoc == ""'"+"'Perl' Perl_Root:[lib.pod]Perldoc.com -t"""
+$ CLOSE CONFIG
+$!
+$ echo ""
+$ echo "%Config-I-VMS, The file can be found at:"
+$ echo4 "-Config-I-VMS, ''F$SEARCH(file_2_find)'"
+$ echo "-Config-I-VMS, Add that file (or an @ call to it) to your [SY]LOGIN.COM"
+$ echo "-Config-I-VMS, when you are satisfied with a successful compilation,"
+$ echo "-Config-I-VMS, testing, and installation of your perl."
+$ echo ""
+$!
+$!figure out where we "are" by parsing 'vms_default_directory_name'
+$!
+$ set_def_command = ""
+$ dflt = F$ENVIRONMENT("DEFAULT") - ".UU]"
+$ tmp = vms_default_directory_name - dflt - "]"
+$ i = 0
+$ IF tmp .EQS. "" THEN GOTO Beyond_set_def_loop
+$Set_def_loop:
+$ tmp1 = F$ELEMENT(i,".",tmp)
+$ IF tmp1 .EQS. "." THEN GOTO Beyond_set_def_loop
+$ IF i .EQ. 0
+$ THEN set_def_command = "set default [-"
+$ ELSE set_def_command = set_def_command + "-"
+$ ENDIF
+$ i = i + 1
+$ GOTO Set_def_loop
+$Beyond_set_def_loop:
+$ IF set_def_command.NES.""
+$ THEN
+$ set_def_command = set_def_command - "-" + "]"
+$ echo4 ""
+$ echo4 "In order to build ''package' you must now issue the commands:"
+$ echo4 ""
+$ echo4 " ''set_def_command'"
+$ ELSE
+$ echo4 ""
+$ echo4 "In order to build ''package' you must now issue the command:"
+$ echo4 ""
+$ ENDIF
+$ echo4 " ''make'''makefile'", macros
+$ echo4 ""
+$!
+$Clean_up:
+$ IF (silent)
+$ THEN
+$ DEASSIGN SYS$OUTPUT
+$! DEASSIGN SYS$ERROR
+$ ENDIF
+$ IF F$GETJPI("","FILCNT").NE.vms_filcnt THEN CLOSE CONFIG
+$ IF F$GETJPI("","FILCNT").NE.vms_filcnt
+$ THEN WRITE SYS$ERROR "%Config-W-VMS, WARNING: There is a file still open"
+$ ENDIF
+$ dflt = F$ENVIRONMENT("DEFAULT")
+$ IF F$LOCATE("UU]",dflt).EQS.(F$LENGTH(dflt)-3)
+$ THEN
+$ IF ( F$SEARCH("[]*.*").NES."" ) THEN DELETE/NOLOG/NOCONFIRM []*.*;*
+$ SET DEFAULT [-]
+$ SET PROTECTION=(SYSTEM:RWED,OWNER:RWED) UU.DIR
+$ DELETE/NOLOG/NOCONFIRM UU.DIR;
+$ ENDIF
+$ SET DEFAULT 'vms_default_directory_name' !be kind rewind
+$ STOP
+$ EXIT
+$!: End of Configure
diff --git a/contrib/perl5/configure.gnu b/contrib/perl5/configure.gnu
new file mode 100755
index 000000000000..fa465320940d
--- /dev/null
+++ b/contrib/perl5/configure.gnu
@@ -0,0 +1,124 @@
+#! /bin/sh
+#
+# $Id: configure,v 3.0.1.1 1995/07/25 14:16:21 ram Exp $
+#
+# GNU configure-like front end to metaconfig's Configure.
+#
+# Written by Andy Dougherty <doughera@lafcol.lafayette.edu>
+# and Matthew Green <mrg@mame.mu.oz.au>.
+#
+# Reformatted and modified for inclusion in the dist-3.0 package by
+# Raphael Manfredi <ram@hptnos02.grenoble.hp.com>.
+#
+# This script belongs to the public domain and may be freely redistributed.
+#
+# The remaining of this leading shell comment may be removed if you
+# include this script in your own package.
+#
+# $Log: configure,v $
+# Revision 3.0.1.1 1995/07/25 14:16:21 ram
+# patch56: created
+#
+
+(exit $?0) || exec sh $0 $argv:q
+
+case "$0" in
+*configure)
+ if cmp $0 `echo $0 | sed -e s/configure/Configure/` >/dev/null; then
+ echo "Your configure and Configure scripts seem to be identical."
+ echo "This can happen on filesystems that aren't fully case sensitive."
+ echo "You'll have to explicitly extract Configure and run that."
+ exit 1
+ fi
+ ;;
+esac
+
+opts=''
+verbose=''
+create='-e'
+while test $# -gt 0; do
+ case $1 in
+ --help)
+ cat <<EOM
+Usage: configure.gnu [options]
+This is GNU configure-like front end for a metaconfig-generated Configure.
+It emulates the following GNU configure options (must be fully spelled out):
+ --help
+ --no-create
+ --prefix=PREFIX
+ --cache-file (ignored)
+ --quiet
+ --silent
+ --verbose
+ --version
+
+And it honours these environment variables: CC, CFLAGS and DEFS.
+EOM
+ exit 0
+ ;;
+ --no-create)
+ create='-E'
+ shift
+ ;;
+ --prefix=*)
+ arg=`echo $1 | sed 's/--prefix=/-Dprefix=/'`
+ opts="$opts $arg"
+ shift
+ ;;
+ --cache-file=*)
+ shift # Just ignore it.
+ ;;
+ --quiet|--silent)
+ exec >/dev/null 2>&1
+ shift
+ ;;
+ --verbose)
+ verbose=true
+ shift
+ ;;
+ --version)
+ copt="$copt -V"
+ shift
+ ;;
+ --*)
+ opt=`echo $1 | sed 's/=.*//'`
+ echo "This GNU configure front end does not understand $opt"
+ exit 1
+ ;;
+ *)
+ opts="$opts $1"
+ shift
+ ;;
+ esac
+done
+
+case "$CC" in
+'') ;;
+*) opts="$opts -Dcc='$CC'";;
+esac
+
+# Join DEFS and CFLAGS together.
+ccflags=''
+case "$DEFS" in
+'') ;;
+*) ccflags=$DEFS;;
+esac
+case "$CFLAGS" in
+'') ;;
+*) ccflags="$ccflags $CFLAGS";;
+esac
+case "$ccflags" in
+'') ;;
+*) opts="$opts -Dccflags='$ccflags'";;
+esac
+
+# Don't use -s if they want verbose mode
+case "$verbose" in
+'') copt="$copt -ds";;
+*) copt="$copt -d";;
+esac
+
+set X sh Configure $copt $create $opts
+shift
+echo "$@"
+exec "$@"
diff --git a/contrib/perl5/cop.h b/contrib/perl5/cop.h
new file mode 100644
index 000000000000..9c8eae60a6cc
--- /dev/null
+++ b/contrib/perl5/cop.h
@@ -0,0 +1,368 @@
+/* cop.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+struct cop {
+ BASEOP
+ char * cop_label; /* label for this construct */
+ HV * cop_stash; /* package line was compiled in */
+ GV * cop_filegv; /* file the following line # is from */
+ U32 cop_seq; /* parse sequence number */
+ I32 cop_arybase; /* array base this line was compiled with */
+ line_t cop_line; /* line # of this command */
+};
+
+#define Nullcop Null(COP*)
+
+/*
+ * Here we have some enormously heavy (or at least ponderous) wizardry.
+ */
+
+/* subroutine context */
+struct block_sub {
+ CV * cv;
+ GV * gv;
+ GV * dfoutgv;
+#ifndef USE_THREADS
+ AV * savearray;
+#endif /* USE_THREADS */
+ AV * argarray;
+ U16 olddepth;
+ U8 hasargs;
+};
+
+#define PUSHSUB(cx) \
+ cx->blk_sub.cv = cv; \
+ cx->blk_sub.olddepth = CvDEPTH(cv); \
+ cx->blk_sub.hasargs = hasargs;
+
+#define PUSHFORMAT(cx) \
+ cx->blk_sub.cv = cv; \
+ cx->blk_sub.gv = gv; \
+ cx->blk_sub.hasargs = 0; \
+ cx->blk_sub.dfoutgv = PL_defoutgv; \
+ (void)SvREFCNT_inc(cx->blk_sub.dfoutgv)
+
+#define POPSUB(cx) \
+ { struct block_sub cxsub; \
+ POPSUB1(cx); \
+ POPSUB2(); }
+
+#define POPSUB1(cx) \
+ cxsub = cx->blk_sub; /* because DESTROY may clobber *cx */
+
+#ifdef USE_THREADS
+#define POPSAVEARRAY() NOOP
+#else
+#define POPSAVEARRAY() \
+ STMT_START { \
+ SvREFCNT_dec(GvAV(PL_defgv)); \
+ GvAV(PL_defgv) = cxsub.savearray; \
+ } STMT_END
+#endif /* USE_THREADS */
+
+#define POPSUB2() \
+ if (cxsub.hasargs) { \
+ POPSAVEARRAY(); \
+ /* destroy arg array */ \
+ av_clear(cxsub.argarray); \
+ AvREAL_off(cxsub.argarray); \
+ } \
+ if (cxsub.cv) { \
+ if (!(CvDEPTH(cxsub.cv) = cxsub.olddepth)) \
+ SvREFCNT_dec(cxsub.cv); \
+ }
+
+#define POPFORMAT(cx) \
+ setdefout(cx->blk_sub.dfoutgv); \
+ SvREFCNT_dec(cx->blk_sub.dfoutgv);
+
+/* eval context */
+struct block_eval {
+ I32 old_in_eval;
+ I32 old_op_type;
+ char * old_name;
+ OP * old_eval_root;
+ SV * cur_text;
+};
+
+#define PUSHEVAL(cx,n,fgv) \
+ cx->blk_eval.old_in_eval = PL_in_eval; \
+ cx->blk_eval.old_op_type = PL_op->op_type; \
+ cx->blk_eval.old_name = n; \
+ cx->blk_eval.old_eval_root = PL_eval_root; \
+ cx->blk_eval.cur_text = PL_linestr;
+
+#define POPEVAL(cx) \
+ PL_in_eval = cx->blk_eval.old_in_eval; \
+ optype = cx->blk_eval.old_op_type; \
+ PL_eval_root = cx->blk_eval.old_eval_root;
+
+/* loop context */
+struct block_loop {
+ char * label;
+ I32 resetsp;
+ OP * redo_op;
+ OP * next_op;
+ OP * last_op;
+ SV ** itervar;
+ SV * itersave;
+ SV * iterlval;
+ AV * iterary;
+ IV iterix;
+ IV itermax;
+};
+
+#define PUSHLOOP(cx, ivar, s) \
+ cx->blk_loop.label = PL_curcop->cop_label; \
+ cx->blk_loop.resetsp = s - PL_stack_base; \
+ cx->blk_loop.redo_op = cLOOP->op_redoop; \
+ cx->blk_loop.next_op = cLOOP->op_nextop; \
+ cx->blk_loop.last_op = cLOOP->op_lastop; \
+ if (cx->blk_loop.itervar = (ivar)) \
+ cx->blk_loop.itersave = SvREFCNT_inc(*cx->blk_loop.itervar);\
+ cx->blk_loop.iterlval = Nullsv; \
+ cx->blk_loop.iterary = Nullav; \
+ cx->blk_loop.iterix = -1;
+
+#define POPLOOP(cx) \
+ { struct block_loop cxloop; \
+ POPLOOP1(cx); \
+ POPLOOP2(); }
+
+#define POPLOOP1(cx) \
+ cxloop = cx->blk_loop; /* because DESTROY may clobber *cx */ \
+ newsp = PL_stack_base + cxloop.resetsp;
+
+#define POPLOOP2() \
+ SvREFCNT_dec(cxloop.iterlval); \
+ if (cxloop.itervar) { \
+ SvREFCNT_dec(*cxloop.itervar); \
+ *cxloop.itervar = cxloop.itersave; \
+ } \
+ if (cxloop.iterary && cxloop.iterary != PL_curstack) \
+ SvREFCNT_dec(cxloop.iterary);
+
+/* context common to subroutines, evals and loops */
+struct block {
+ I32 blku_oldsp; /* stack pointer to copy stuff down to */
+ COP * blku_oldcop; /* old curcop pointer */
+ I32 blku_oldretsp; /* return stack index */
+ I32 blku_oldmarksp; /* mark stack index */
+ I32 blku_oldscopesp; /* scope stack index */
+ PMOP * blku_oldpm; /* values of pattern match vars */
+ U8 blku_gimme; /* is this block running in list context? */
+
+ union {
+ struct block_sub blku_sub;
+ struct block_eval blku_eval;
+ struct block_loop blku_loop;
+ } blk_u;
+};
+#define blk_oldsp cx_u.cx_blk.blku_oldsp
+#define blk_oldcop cx_u.cx_blk.blku_oldcop
+#define blk_oldretsp cx_u.cx_blk.blku_oldretsp
+#define blk_oldmarksp cx_u.cx_blk.blku_oldmarksp
+#define blk_oldscopesp cx_u.cx_blk.blku_oldscopesp
+#define blk_oldpm cx_u.cx_blk.blku_oldpm
+#define blk_gimme cx_u.cx_blk.blku_gimme
+#define blk_sub cx_u.cx_blk.blk_u.blku_sub
+#define blk_eval cx_u.cx_blk.blk_u.blku_eval
+#define blk_loop cx_u.cx_blk.blk_u.blku_loop
+
+/* Enter a block. */
+#define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \
+ cx->cx_type = t, \
+ cx->blk_oldsp = sp - PL_stack_base, \
+ cx->blk_oldcop = PL_curcop, \
+ cx->blk_oldmarksp = PL_markstack_ptr - PL_markstack, \
+ cx->blk_oldscopesp = PL_scopestack_ix, \
+ cx->blk_oldretsp = PL_retstack_ix, \
+ cx->blk_oldpm = PL_curpm, \
+ cx->blk_gimme = gimme; \
+ DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Entering block %ld, type %s\n", \
+ (long)cxstack_ix, block_type[t]); )
+
+/* Exit a block (RETURN and LAST). */
+#define POPBLOCK(cx,pm) cx = &cxstack[cxstack_ix--], \
+ newsp = PL_stack_base + cx->blk_oldsp, \
+ PL_curcop = cx->blk_oldcop, \
+ PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
+ PL_scopestack_ix = cx->blk_oldscopesp, \
+ PL_retstack_ix = cx->blk_oldretsp, \
+ pm = cx->blk_oldpm, \
+ gimme = cx->blk_gimme; \
+ DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Leaving block %ld, type %s\n", \
+ (long)cxstack_ix+1,block_type[cx->cx_type]); )
+
+/* Continue a block elsewhere (NEXT and REDO). */
+#define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \
+ PL_stack_sp = PL_stack_base + cx->blk_oldsp, \
+ PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
+ PL_scopestack_ix = cx->blk_oldscopesp, \
+ PL_retstack_ix = cx->blk_oldretsp
+
+/* substitution context */
+struct subst {
+ I32 sbu_iters;
+ I32 sbu_maxiters;
+ I32 sbu_safebase;
+ I32 sbu_oldsave;
+ bool sbu_once;
+ bool sbu_rxtainted;
+ char * sbu_orig;
+ SV * sbu_dstr;
+ SV * sbu_targ;
+ char * sbu_s;
+ char * sbu_m;
+ char * sbu_strend;
+ void * sbu_rxres;
+ REGEXP * sbu_rx;
+};
+#define sb_iters cx_u.cx_subst.sbu_iters
+#define sb_maxiters cx_u.cx_subst.sbu_maxiters
+#define sb_safebase cx_u.cx_subst.sbu_safebase
+#define sb_oldsave cx_u.cx_subst.sbu_oldsave
+#define sb_once cx_u.cx_subst.sbu_once
+#define sb_rxtainted cx_u.cx_subst.sbu_rxtainted
+#define sb_orig cx_u.cx_subst.sbu_orig
+#define sb_dstr cx_u.cx_subst.sbu_dstr
+#define sb_targ cx_u.cx_subst.sbu_targ
+#define sb_s cx_u.cx_subst.sbu_s
+#define sb_m cx_u.cx_subst.sbu_m
+#define sb_strend cx_u.cx_subst.sbu_strend
+#define sb_rxres cx_u.cx_subst.sbu_rxres
+#define sb_rx cx_u.cx_subst.sbu_rx
+
+#define PUSHSUBST(cx) CXINC, cx = &cxstack[cxstack_ix], \
+ cx->sb_iters = iters, \
+ cx->sb_maxiters = maxiters, \
+ cx->sb_safebase = safebase, \
+ cx->sb_oldsave = oldsave, \
+ cx->sb_once = once, \
+ cx->sb_rxtainted = rxtainted, \
+ cx->sb_orig = orig, \
+ cx->sb_dstr = dstr, \
+ cx->sb_targ = targ, \
+ cx->sb_s = s, \
+ cx->sb_m = m, \
+ cx->sb_strend = strend, \
+ cx->sb_rxres = Null(void*), \
+ cx->sb_rx = rx, \
+ cx->cx_type = CXt_SUBST; \
+ rxres_save(&cx->sb_rxres, rx)
+
+#define POPSUBST(cx) cx = &cxstack[cxstack_ix--]; \
+ rxres_free(&cx->sb_rxres)
+
+struct context {
+ I32 cx_type; /* what kind of context this is */
+ union {
+ struct block cx_blk;
+ struct subst cx_subst;
+ } cx_u;
+};
+#define CXt_NULL 0
+#define CXt_SUB 1
+#define CXt_EVAL 2
+#define CXt_LOOP 3
+#define CXt_SUBST 4
+#define CXt_BLOCK 5
+
+#define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
+
+/* "gimme" values */
+#define G_SCALAR 0
+#define G_ARRAY 1
+#define G_VOID 128 /* skip this bit when adding flags below */
+
+/* extra flags for perl_call_* routines */
+#define G_DISCARD 2 /* Call FREETMPS. */
+#define G_EVAL 4 /* Assume eval {} around subroutine call. */
+#define G_NOARGS 8 /* Don't construct a @_ array. */
+#define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */
+#define G_NODEBUG 32 /* Disable debugging at toplevel. */
+
+/* Support for switching (stack and block) contexts.
+ * This ensures magic doesn't invalidate local stack and cx pointers.
+ */
+
+#define PERLSI_UNKNOWN -1
+#define PERLSI_UNDEF 0
+#define PERLSI_MAIN 1
+#define PERLSI_MAGIC 2
+#define PERLSI_SORT 3
+#define PERLSI_SIGNAL 4
+#define PERLSI_OVERLOAD 5
+#define PERLSI_DESTROY 6
+#define PERLSI_WARNHOOK 7
+#define PERLSI_DIEHOOK 8
+#define PERLSI_REQUIRE 9
+
+struct stackinfo {
+ AV * si_stack; /* stack for current runlevel */
+ PERL_CONTEXT * si_cxstack; /* context stack for runlevel */
+ I32 si_cxix; /* current context index */
+ I32 si_cxmax; /* maximum allocated index */
+ I32 si_type; /* type of runlevel */
+ struct stackinfo * si_prev;
+ struct stackinfo * si_next;
+ I32 * si_markbase; /* where markstack begins for us.
+ * currently used only with DEBUGGING,
+ * but not #ifdef-ed for bincompat */
+};
+
+typedef struct stackinfo PERL_SI;
+
+#define cxstack (PL_curstackinfo->si_cxstack)
+#define cxstack_ix (PL_curstackinfo->si_cxix)
+#define cxstack_max (PL_curstackinfo->si_cxmax)
+
+#ifdef DEBUGGING
+# define SET_MARKBASE PL_curstackinfo->si_markbase = PL_markstack_ptr
+#else
+# define SET_MARKBASE NOOP
+#endif
+
+#define PUSHSTACKi(type) \
+ STMT_START { \
+ PERL_SI *next = PL_curstackinfo->si_next; \
+ if (!next) { \
+ next = new_stackinfo(32, 2048/sizeof(PERL_CONTEXT) - 1); \
+ next->si_prev = PL_curstackinfo; \
+ PL_curstackinfo->si_next = next; \
+ } \
+ next->si_type = type; \
+ next->si_cxix = -1; \
+ AvFILLp(next->si_stack) = 0; \
+ SWITCHSTACK(PL_curstack,next->si_stack); \
+ PL_curstackinfo = next; \
+ SET_MARKBASE; \
+ } STMT_END
+
+#define PUSHSTACK PUSHSTACKi(PERLSI_UNKNOWN)
+
+#define POPSTACK \
+ STMT_START { \
+ PERL_SI *prev = PL_curstackinfo->si_prev; \
+ if (!prev) { \
+ PerlIO_printf(PerlIO_stderr(), "panic: POPSTACK\n"); \
+ my_exit(1); \
+ } \
+ SWITCHSTACK(PL_curstack,prev->si_stack); \
+ /* don't free prev here, free them all at the END{} */ \
+ PL_curstackinfo = prev; \
+ } STMT_END
+
+#define POPSTACK_TO(s) \
+ STMT_START { \
+ while (PL_curstack != s) { \
+ dounwind(-1); \
+ POPSTACK; \
+ } \
+ } STMT_END
diff --git a/contrib/perl5/cv.h b/contrib/perl5/cv.h
new file mode 100644
index 000000000000..c7c7a73cc5a5
--- /dev/null
+++ b/contrib/perl5/cv.h
@@ -0,0 +1,96 @@
+/* cv.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/* This structure much match the beginning of XPVFM */
+
+struct xpvcv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xp_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xof_off; /* integer value */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* magic for scalar array */
+ HV* xmg_stash; /* class package */
+
+ HV * xcv_stash;
+ OP * xcv_start;
+ OP * xcv_root;
+ void (*xcv_xsub) _((CV* _CPERLproto));
+ ANY xcv_xsubany;
+ GV * xcv_gv;
+ GV * xcv_filegv;
+ long xcv_depth; /* >= 2 indicates recursive call */
+ AV * xcv_padlist;
+ CV * xcv_outside;
+#ifdef USE_THREADS
+ perl_mutex *xcv_mutexp;
+ struct perl_thread *xcv_owner; /* current owner thread */
+#endif /* USE_THREADS */
+ cv_flags_t xcv_flags;
+};
+
+#define Nullcv Null(CV*)
+
+#define CvSTASH(sv) ((XPVCV*)SvANY(sv))->xcv_stash
+#define CvSTART(sv) ((XPVCV*)SvANY(sv))->xcv_start
+#define CvROOT(sv) ((XPVCV*)SvANY(sv))->xcv_root
+#define CvXSUB(sv) ((XPVCV*)SvANY(sv))->xcv_xsub
+#define CvXSUBANY(sv) ((XPVCV*)SvANY(sv))->xcv_xsubany
+#define CvGV(sv) ((XPVCV*)SvANY(sv))->xcv_gv
+#define CvFILEGV(sv) ((XPVCV*)SvANY(sv))->xcv_filegv
+#define CvDEPTH(sv) ((XPVCV*)SvANY(sv))->xcv_depth
+#define CvPADLIST(sv) ((XPVCV*)SvANY(sv))->xcv_padlist
+#define CvOUTSIDE(sv) ((XPVCV*)SvANY(sv))->xcv_outside
+#ifdef USE_THREADS
+#define CvMUTEXP(sv) ((XPVCV*)SvANY(sv))->xcv_mutexp
+#define CvOWNER(sv) ((XPVCV*)SvANY(sv))->xcv_owner
+#endif /* USE_THREADS */
+#define CvFLAGS(sv) ((XPVCV*)SvANY(sv))->xcv_flags
+
+#define CVf_CLONE 0x0001 /* anon CV uses external lexicals */
+#define CVf_CLONED 0x0002 /* a clone of one of those */
+#define CVf_ANON 0x0004 /* CvGV() can't be trusted */
+#define CVf_OLDSTYLE 0x0008
+#define CVf_UNIQUE 0x0010 /* can't be cloned */
+#define CVf_NODEBUG 0x0020 /* no DB::sub indirection for this CV
+ (esp. useful for special XSUBs) */
+#define CVf_METHOD 0x0040 /* CV is explicitly marked as a method */
+#define CVf_LOCKED 0x0080 /* CV locks itself or first arg on entry */
+
+#define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE)
+#define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE)
+#define CvCLONE_off(cv) (CvFLAGS(cv) &= ~CVf_CLONE)
+
+#define CvCLONED(cv) (CvFLAGS(cv) & CVf_CLONED)
+#define CvCLONED_on(cv) (CvFLAGS(cv) |= CVf_CLONED)
+#define CvCLONED_off(cv) (CvFLAGS(cv) &= ~CVf_CLONED)
+
+#define CvANON(cv) (CvFLAGS(cv) & CVf_ANON)
+#define CvANON_on(cv) (CvFLAGS(cv) |= CVf_ANON)
+#define CvANON_off(cv) (CvFLAGS(cv) &= ~CVf_ANON)
+
+#define CvOLDSTYLE(cv) (CvFLAGS(cv) & CVf_OLDSTYLE)
+#define CvOLDSTYLE_on(cv) (CvFLAGS(cv) |= CVf_OLDSTYLE)
+#define CvOLDSTYLE_off(cv) (CvFLAGS(cv) &= ~CVf_OLDSTYLE)
+
+#define CvUNIQUE(cv) (CvFLAGS(cv) & CVf_UNIQUE)
+#define CvUNIQUE_on(cv) (CvFLAGS(cv) |= CVf_UNIQUE)
+#define CvUNIQUE_off(cv) (CvFLAGS(cv) &= ~CVf_UNIQUE)
+
+#define CvNODEBUG(cv) (CvFLAGS(cv) & CVf_NODEBUG)
+#define CvNODEBUG_on(cv) (CvFLAGS(cv) |= CVf_NODEBUG)
+#define CvNODEBUG_off(cv) (CvFLAGS(cv) &= ~CVf_NODEBUG)
+
+#define CvMETHOD(cv) (CvFLAGS(cv) & CVf_METHOD)
+#define CvMETHOD_on(cv) (CvFLAGS(cv) |= CVf_METHOD)
+#define CvMETHOD_off(cv) (CvFLAGS(cv) &= ~CVf_METHOD)
+
+#define CvLOCKED(cv) (CvFLAGS(cv) & CVf_LOCKED)
+#define CvLOCKED_on(cv) (CvFLAGS(cv) |= CVf_LOCKED)
+#define CvLOCKED_off(cv) (CvFLAGS(cv) &= ~CVf_LOCKED)
diff --git a/contrib/perl5/deb.c b/contrib/perl5/deb.c
new file mode 100644
index 000000000000..0c2522584111
--- /dev/null
+++ b/contrib/perl5/deb.c
@@ -0,0 +1,114 @@
+/* deb.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "Didst thou think that the eyes of the White Tower were blind? Nay, I
+ * have seen more than thou knowest, Gray Fool." --Denethor
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+void
+deb(const char *pat, ...)
+{
+#ifdef DEBUGGING
+ dTHR;
+ va_list args;
+ register I32 i;
+ GV* gv = PL_curcop->cop_filegv;
+
+#ifdef USE_THREADS
+ PerlIO_printf(Perl_debug_log, "0x%lx (%s:%ld)\t",
+ (unsigned long) thr,
+ SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
+ (long)PL_curcop->cop_line);
+#else
+ PerlIO_printf(Perl_debug_log, "(%s:%ld)\t",
+ SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
+ (long)PL_curcop->cop_line);
+#endif /* USE_THREADS */
+ for (i=0; i<PL_dlevel; i++)
+ PerlIO_printf(Perl_debug_log, "%c%c ",PL_debname[i],PL_debdelim[i]);
+
+ va_start(args, pat);
+ (void) PerlIO_vprintf(Perl_debug_log,pat,args);
+ va_end( args );
+#endif /* DEBUGGING */
+}
+
+void
+deb_growlevel(void)
+{
+#ifdef DEBUGGING
+ PL_dlmax += 128;
+ Renew(PL_debname, PL_dlmax, char);
+ Renew(PL_debdelim, PL_dlmax, char);
+#endif /* DEBUGGING */
+}
+
+I32
+debstackptrs(void)
+{
+#ifdef DEBUGGING
+ dTHR;
+ PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
+ (unsigned long)PL_curstack, (unsigned long)PL_stack_base,
+ (long)*PL_markstack_ptr, (long)(PL_stack_sp-PL_stack_base),
+ (long)(PL_stack_max-PL_stack_base));
+ PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
+ (unsigned long)PL_mainstack, (unsigned long)AvARRAY(PL_curstack),
+ (long)PL_mainstack, (long)AvFILLp(PL_curstack), (long)AvMAX(PL_curstack));
+#endif /* DEBUGGING */
+ return 0;
+}
+
+I32
+debstack(void)
+{
+#ifdef DEBUGGING
+ dTHR;
+ I32 top = PL_stack_sp - PL_stack_base;
+ register I32 i = top - 30;
+ I32 *markscan = PL_curstackinfo->si_markbase;
+
+ if (i < 0)
+ i = 0;
+
+ while (++markscan <= PL_markstack_ptr)
+ if (*markscan >= i)
+ break;
+
+#ifdef USE_THREADS
+ PerlIO_printf(Perl_debug_log, i ? "0x%lx => ... " : "0x%lx => ",
+ (unsigned long) thr);
+#else
+ PerlIO_printf(Perl_debug_log, i ? " => ... " : " => ");
+#endif /* USE_THREADS */
+ if (PL_stack_base[0] != &PL_sv_undef || PL_stack_sp < PL_stack_base)
+ PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
+ do {
+ ++i;
+ if (markscan <= PL_markstack_ptr && *markscan < i) {
+ do {
+ ++markscan;
+ PerlIO_putc(Perl_debug_log, '*');
+ }
+ while (markscan <= PL_markstack_ptr && *markscan < i);
+ PerlIO_printf(Perl_debug_log, " ");
+ }
+ if (i > top)
+ break;
+ PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(PL_stack_base[i]));
+ }
+ while (1);
+ PerlIO_printf(Perl_debug_log, "\n");
+#endif /* DEBUGGING */
+ return 0;
+}
diff --git a/contrib/perl5/doio.c b/contrib/perl5/doio.c
new file mode 100644
index 000000000000..85d604bc0385
--- /dev/null
+++ b/contrib/perl5/doio.c
@@ -0,0 +1,1670 @@
+/* doio.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "Far below them they saw the white waters pour into a foaming bowl, and
+ * then swirl darkly about a deep oval basin in the rocks, until they found
+ * their way out again through a narrow gate, and flowed away, fuming and
+ * chattering, into calmer and more level reaches."
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+#include <sys/ipc.h>
+#ifdef HAS_MSG
+#include <sys/msg.h>
+#endif
+#ifdef HAS_SEM
+#include <sys/sem.h>
+#endif
+#ifdef HAS_SHM
+#include <sys/shm.h>
+# ifndef HAS_SHMAT_PROTOTYPE
+ extern Shmat_t shmat _((int, char *, int));
+# endif
+#endif
+#endif
+
+#ifdef I_UTIME
+# if defined(_MSC_VER) || defined(__MINGW32__)
+# include <sys/utime.h>
+# else
+# include <utime.h>
+# endif
+#endif
+
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+#ifdef O_EXCL
+# define OPEN_EXCL O_EXCL
+#else
+# define OPEN_EXCL 0
+#endif
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+#include <signal.h>
+#endif
+
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+
+#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
+# include <sys/socket.h>
+# include <netdb.h>
+# ifndef ENOTSOCK
+# ifdef I_NET_ERRNO
+# include <net/errno.h>
+# endif
+# endif
+#endif
+
+/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
+#ifndef Sock_size_t
+# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
+# define Sock_size_t Size_t
+# else
+# define Sock_size_t int
+# endif
+#endif
+
+bool
+do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp)
+{
+ register IO *io = GvIOn(gv);
+ PerlIO *saveifp = Nullfp;
+ PerlIO *saveofp = Nullfp;
+ char savetype = ' ';
+ int writing = 0;
+ PerlIO *fp;
+ int fd;
+ int result;
+ bool was_fdopen = FALSE;
+
+ PL_forkprocess = 1; /* assume true if no fork */
+
+ if (IoIFP(io)) {
+ fd = PerlIO_fileno(IoIFP(io));
+ if (IoTYPE(io) == '-')
+ result = 0;
+ else if (fd <= PL_maxsysfd) {
+ saveifp = IoIFP(io);
+ saveofp = IoOFP(io);
+ savetype = IoTYPE(io);
+ result = 0;
+ }
+ else if (IoTYPE(io) == '|')
+ result = PerlProc_pclose(IoIFP(io));
+ else if (IoIFP(io) != IoOFP(io)) {
+ if (IoOFP(io)) {
+ result = PerlIO_close(IoOFP(io));
+ PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
+ }
+ else
+ result = PerlIO_close(IoIFP(io));
+ }
+ else
+ result = PerlIO_close(IoIFP(io));
+ if (result == EOF && fd > PL_maxsysfd)
+ PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n",
+ GvENAME(gv));
+ IoOFP(io) = IoIFP(io) = Nullfp;
+ }
+
+ if (as_raw) {
+#ifndef O_ACCMODE
+#define O_ACCMODE 3 /* Assume traditional implementation */
+#endif
+ switch (result = rawmode & O_ACCMODE) {
+ case O_RDONLY:
+ IoTYPE(io) = '<';
+ break;
+ case O_WRONLY:
+ IoTYPE(io) = '>';
+ break;
+ case O_RDWR:
+ default:
+ IoTYPE(io) = '+';
+ break;
+ }
+
+ writing = (result > 0);
+ fd = PerlLIO_open3(name, rawmode, rawperm);
+
+ if (fd == -1)
+ fp = NULL;
+ else {
+ char *fpmode;
+ if (result == O_RDONLY)
+ fpmode = "r";
+#ifdef O_APPEND
+ else if (rawmode & O_APPEND)
+ fpmode = (result == O_WRONLY) ? "a" : "a+";
+#endif
+ else
+ fpmode = (result == O_WRONLY) ? "w" : "r+";
+ fp = PerlIO_fdopen(fd, fpmode);
+ if (!fp)
+ PerlLIO_close(fd);
+ }
+ }
+ else {
+ char *myname;
+ char mode[3]; /* stdio file mode ("r\0" or "r+\0") */
+ int dodup;
+
+ myname = savepvn(name, len);
+ SAVEFREEPV(myname);
+ name = myname;
+ while (len && isSPACE(name[len-1]))
+ name[--len] = '\0';
+
+ mode[0] = mode[1] = mode[2] = '\0';
+ IoTYPE(io) = *name;
+ if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
+ mode[1] = *name++;
+ --len;
+ writing = 1;
+ }
+
+ if (*name == '|') {
+ /*SUPPRESS 530*/
+ for (name++; isSPACE(*name); name++) ;
+ if (strNE(name,"-"))
+ TAINT_ENV();
+ TAINT_PROPER("piped open");
+ if (name[strlen(name)-1] == '|') {
+ name[strlen(name)-1] = '\0' ;
+ if (PL_dowarn)
+ warn("Can't do bidirectional pipe");
+ }
+ fp = PerlProc_popen(name,"w");
+ writing = 1;
+ }
+ else if (*name == '>') {
+ TAINT_PROPER("open");
+ name++;
+ if (*name == '>') {
+ mode[0] = IoTYPE(io) = 'a';
+ name++;
+ }
+ else
+ mode[0] = 'w';
+ writing = 1;
+
+ if (*name == '&') {
+ duplicity:
+ dodup = 1;
+ name++;
+ if (*name == '=') {
+ dodup = 0;
+ name++;
+ }
+ if (!*name && supplied_fp)
+ fp = supplied_fp;
+ else {
+ /*SUPPRESS 530*/
+ for (; isSPACE(*name); name++) ;
+ if (isDIGIT(*name))
+ fd = atoi(name);
+ else {
+ IO* thatio;
+ gv = gv_fetchpv(name,FALSE,SVt_PVIO);
+ thatio = GvIO(gv);
+ if (!thatio) {
+#ifdef EINVAL
+ SETERRNO(EINVAL,SS$_IVCHAN);
+#endif
+ goto say_false;
+ }
+ if (IoIFP(thatio)) {
+ fd = PerlIO_fileno(IoIFP(thatio));
+ if (IoTYPE(thatio) == 's')
+ IoTYPE(io) = 's';
+ }
+ else
+ fd = -1;
+ }
+ if (dodup)
+ fd = PerlLIO_dup(fd);
+ else
+ was_fdopen = TRUE;
+ if (!(fp = PerlIO_fdopen(fd,mode))) {
+ if (dodup)
+ PerlLIO_close(fd);
+ }
+ }
+ }
+ else {
+ /*SUPPRESS 530*/
+ for (; isSPACE(*name); name++) ;
+ if (strEQ(name,"-")) {
+ fp = PerlIO_stdout();
+ IoTYPE(io) = '-';
+ }
+ else {
+ fp = PerlIO_open(name,mode);
+ }
+ }
+ }
+ else if (*name == '<') {
+ /*SUPPRESS 530*/
+ for (name++; isSPACE(*name); name++) ;
+ mode[0] = 'r';
+ if (*name == '&')
+ goto duplicity;
+ if (strEQ(name,"-")) {
+ fp = PerlIO_stdin();
+ IoTYPE(io) = '-';
+ }
+ else
+ fp = PerlIO_open(name,mode);
+ }
+ else if (len > 1 && name[len-1] == '|') {
+ name[--len] = '\0';
+ while (len && isSPACE(name[len-1]))
+ name[--len] = '\0';
+ /*SUPPRESS 530*/
+ for (; isSPACE(*name); name++) ;
+ if (strNE(name,"-"))
+ TAINT_ENV();
+ TAINT_PROPER("piped open");
+ fp = PerlProc_popen(name,"r");
+ IoTYPE(io) = '|';
+ }
+ else {
+ IoTYPE(io) = '<';
+ /*SUPPRESS 530*/
+ for (; isSPACE(*name); name++) ;
+ if (strEQ(name,"-")) {
+ fp = PerlIO_stdin();
+ IoTYPE(io) = '-';
+ }
+ else
+ fp = PerlIO_open(name,"r");
+ }
+ }
+ if (!fp) {
+ if (PL_dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
+ warn(warn_nl, "open");
+ goto say_false;
+ }
+ if (IoTYPE(io) &&
+ IoTYPE(io) != '|' && IoTYPE(io) != '-') {
+ dTHR;
+ if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
+ (void)PerlIO_close(fp);
+ goto say_false;
+ }
+ if (S_ISSOCK(PL_statbuf.st_mode))
+ IoTYPE(io) = 's'; /* in case a socket was passed in to us */
+#ifdef HAS_SOCKET
+ else if (
+#ifdef S_IFMT
+ !(PL_statbuf.st_mode & S_IFMT)
+#else
+ !PL_statbuf.st_mode
+#endif
+ ) {
+ char tmpbuf[256];
+ Sock_size_t buflen = sizeof tmpbuf;
+ if (PerlSock_getsockname(PerlIO_fileno(fp), (struct sockaddr *)tmpbuf,
+ &buflen) >= 0
+ || errno != ENOTSOCK)
+ IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
+ /* but some return 0 for streams too, sigh */
+ }
+#endif
+ }
+ if (saveifp) { /* must use old fp? */
+ fd = PerlIO_fileno(saveifp);
+ if (saveofp) {
+ PerlIO_flush(saveofp); /* emulate PerlIO_close() */
+ if (saveofp != saveifp) { /* was a socket? */
+ PerlIO_close(saveofp);
+ if (fd > 2)
+ Safefree(saveofp);
+ }
+ }
+ if (fd != PerlIO_fileno(fp)) {
+ int pid;
+ SV *sv;
+
+ PerlLIO_dup2(PerlIO_fileno(fp), fd);
+ sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE);
+ (void)SvUPGRADE(sv, SVt_IV);
+ pid = SvIVX(sv);
+ SvIVX(sv) = 0;
+ sv = *av_fetch(PL_fdpid,fd,TRUE);
+ (void)SvUPGRADE(sv, SVt_IV);
+ SvIVX(sv) = pid;
+ if (!was_fdopen)
+ PerlIO_close(fp);
+
+ }
+ fp = saveifp;
+ PerlIO_clearerr(fp);
+ }
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fd = PerlIO_fileno(fp);
+ fcntl(fd,F_SETFD,fd > PL_maxsysfd);
+#endif
+ IoIFP(io) = fp;
+ if (writing) {
+ dTHR;
+ if (IoTYPE(io) == 's'
+ || (IoTYPE(io) == '>' && S_ISCHR(PL_statbuf.st_mode)) ) {
+ if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) {
+ PerlIO_close(fp);
+ IoIFP(io) = Nullfp;
+ goto say_false;
+ }
+ }
+ else
+ IoOFP(io) = fp;
+ }
+ return TRUE;
+
+say_false:
+ IoIFP(io) = saveifp;
+ IoOFP(io) = saveofp;
+ IoTYPE(io) = savetype;
+ return FALSE;
+}
+
+PerlIO *
+nextargv(register GV *gv)
+{
+ register SV *sv;
+#ifndef FLEXFILENAMES
+ int filedev;
+ int fileino;
+#endif
+ int fileuid;
+ int filegid;
+
+ if (!PL_argvoutgv)
+ PL_argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
+ if (PL_filemode & (S_ISUID|S_ISGID)) {
+ PerlIO_flush(IoIFP(GvIOn(PL_argvoutgv))); /* chmod must follow last write */
+#ifdef HAS_FCHMOD
+ (void)fchmod(PL_lastfd,PL_filemode);
+#else
+ (void)PerlLIO_chmod(PL_oldname,PL_filemode);
+#endif
+ }
+ PL_filemode = 0;
+ while (av_len(GvAV(gv)) >= 0) {
+ dTHR;
+ STRLEN oldlen;
+ sv = av_shift(GvAV(gv));
+ SAVEFREESV(sv);
+ sv_setsv(GvSV(gv),sv);
+ SvSETMAGIC(GvSV(gv));
+ PL_oldname = SvPVx(GvSV(gv), oldlen);
+ if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) {
+ if (PL_inplace) {
+ TAINT_PROPER("inplace open");
+ if (oldlen == 1 && *PL_oldname == '-') {
+ setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
+ return IoIFP(GvIOp(gv));
+ }
+#ifndef FLEXFILENAMES
+ filedev = PL_statbuf.st_dev;
+ fileino = PL_statbuf.st_ino;
+#endif
+ PL_filemode = PL_statbuf.st_mode;
+ fileuid = PL_statbuf.st_uid;
+ filegid = PL_statbuf.st_gid;
+ if (!S_ISREG(PL_filemode)) {
+ warn("Can't do inplace edit: %s is not a regular file",
+ PL_oldname );
+ do_close(gv,FALSE);
+ continue;
+ }
+ if (*PL_inplace) {
+ char *star = strchr(PL_inplace, '*');
+ if (star) {
+ char *begin = PL_inplace;
+ sv_setpvn(sv, "", 0);
+ do {
+ sv_catpvn(sv, begin, star - begin);
+ sv_catpvn(sv, PL_oldname, oldlen);
+ begin = ++star;
+ } while ((star = strchr(begin, '*')));
+ if (*begin)
+ sv_catpv(sv,begin);
+ }
+ else {
+ sv_catpv(sv,PL_inplace);
+ }
+#ifndef FLEXFILENAMES
+ if (PerlLIO_stat(SvPVX(sv),&PL_statbuf) >= 0
+ && PL_statbuf.st_dev == filedev
+ && PL_statbuf.st_ino == fileino
+#ifdef DJGPP
+ || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
+#endif
+ ) {
+ warn("Can't do inplace edit: %s would not be uniq",
+ SvPVX(sv) );
+ do_close(gv,FALSE);
+ continue;
+ }
+#endif
+#ifdef HAS_RENAME
+#ifndef DOSISH
+ if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
+ warn("Can't rename %s to %s: %s, skipping file",
+ PL_oldname, SvPVX(sv), Strerror(errno) );
+ do_close(gv,FALSE);
+ continue;
+ }
+#else
+ do_close(gv,FALSE);
+ (void)PerlLIO_unlink(SvPVX(sv));
+ (void)PerlLIO_rename(PL_oldname,SvPVX(sv));
+ do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp);
+#endif /* DOSISH */
+#else
+ (void)UNLINK(SvPVX(sv));
+ if (link(PL_oldname,SvPVX(sv)) < 0) {
+ warn("Can't rename %s to %s: %s, skipping file",
+ PL_oldname, SvPVX(sv), Strerror(errno) );
+ do_close(gv,FALSE);
+ continue;
+ }
+ (void)UNLINK(PL_oldname);
+#endif
+ }
+ else {
+#if !defined(DOSISH) && !defined(AMIGAOS)
+# ifndef VMS /* Don't delete; use automatic file versioning */
+ if (UNLINK(PL_oldname) < 0) {
+ warn("Can't remove %s: %s, skipping file",
+ PL_oldname, Strerror(errno) );
+ do_close(gv,FALSE);
+ continue;
+ }
+# endif
+#else
+ croak("Can't do inplace edit without backup");
+#endif
+ }
+
+ sv_setpvn(sv,">",!PL_inplace);
+ sv_catpvn(sv,PL_oldname,oldlen);
+ SETERRNO(0,0); /* in case sprintf set errno */
+#ifdef VMS
+ if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
+ O_WRONLY|O_CREAT|O_TRUNC,0,Nullfp)) {
+#else
+ if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
+ O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) {
+#endif
+ warn("Can't do inplace edit on %s: %s",
+ PL_oldname, Strerror(errno) );
+ do_close(gv,FALSE);
+ continue;
+ }
+ setdefout(PL_argvoutgv);
+ PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
+ (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
+#ifdef HAS_FCHMOD
+ (void)fchmod(PL_lastfd,PL_filemode);
+#else
+# if !(defined(WIN32) && defined(__BORLANDC__))
+ /* Borland runtime creates a readonly file! */
+ (void)PerlLIO_chmod(PL_oldname,PL_filemode);
+# endif
+#endif
+ if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
+#ifdef HAS_FCHOWN
+ (void)fchown(PL_lastfd,fileuid,filegid);
+#else
+#ifdef HAS_CHOWN
+ (void)PerlLIO_chown(PL_oldname,fileuid,filegid);
+#endif
+#endif
+ }
+ }
+ return IoIFP(GvIOp(gv));
+ }
+ else
+ PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",
+ SvPV(sv, PL_na), Strerror(errno));
+ }
+ if (PL_inplace) {
+ (void)do_close(PL_argvoutgv,FALSE);
+ setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO));
+ }
+ return Nullfp;
+}
+
+#ifdef HAS_PIPE
+void
+do_pipe(SV *sv, GV *rgv, GV *wgv)
+{
+ register IO *rstio;
+ register IO *wstio;
+ int fd[2];
+
+ if (!rgv)
+ goto badexit;
+ if (!wgv)
+ goto badexit;
+
+ rstio = GvIOn(rgv);
+ wstio = GvIOn(wgv);
+
+ if (IoIFP(rstio))
+ do_close(rgv,FALSE);
+ if (IoIFP(wstio))
+ do_close(wgv,FALSE);
+
+ if (PerlProc_pipe(fd) < 0)
+ goto badexit;
+ IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
+ IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
+ IoIFP(wstio) = IoOFP(wstio);
+ IoTYPE(rstio) = '<';
+ IoTYPE(wstio) = '>';
+ if (!IoIFP(rstio) || !IoOFP(wstio)) {
+ if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
+ else PerlLIO_close(fd[0]);
+ if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
+ else PerlLIO_close(fd[1]);
+ goto badexit;
+ }
+
+ sv_setsv(sv,&PL_sv_yes);
+ return;
+
+badexit:
+ sv_setsv(sv,&PL_sv_undef);
+ return;
+}
+#endif
+
+/* explicit renamed to avoid C++ conflict -- kja */
+bool
+do_close(GV *gv, bool not_implicit)
+{
+ bool retval;
+ IO *io;
+
+ if (!gv)
+ gv = PL_argvgv;
+ if (!gv || SvTYPE(gv) != SVt_PVGV) {
+ if (not_implicit)
+ SETERRNO(EBADF,SS$_IVCHAN);
+ return FALSE;
+ }
+ io = GvIO(gv);
+ if (!io) { /* never opened */
+ if (not_implicit) {
+ if (PL_dowarn)
+ warn("Close on unopened file <%s>",GvENAME(gv));
+ SETERRNO(EBADF,SS$_IVCHAN);
+ }
+ return FALSE;
+ }
+ retval = io_close(io);
+ if (not_implicit) {
+ IoLINES(io) = 0;
+ IoPAGE(io) = 0;
+ IoLINES_LEFT(io) = IoPAGE_LEN(io);
+ }
+ IoTYPE(io) = ' ';
+ return retval;
+}
+
+bool
+io_close(IO *io)
+{
+ bool retval = FALSE;
+ int status;
+
+ if (IoIFP(io)) {
+ if (IoTYPE(io) == '|') {
+ status = PerlProc_pclose(IoIFP(io));
+ STATUS_NATIVE_SET(status);
+ retval = (STATUS_POSIX == 0);
+ }
+ else if (IoTYPE(io) == '-')
+ retval = TRUE;
+ else {
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
+ retval = (PerlIO_close(IoOFP(io)) != EOF);
+ PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
+ }
+ else
+ retval = (PerlIO_close(IoIFP(io)) != EOF);
+ }
+ IoOFP(io) = IoIFP(io) = Nullfp;
+ }
+ else {
+ SETERRNO(EBADF,SS$_IVCHAN);
+ }
+
+ return retval;
+}
+
+bool
+do_eof(GV *gv)
+{
+ dTHR;
+ register IO *io;
+ int ch;
+
+ io = GvIO(gv);
+
+ if (!io)
+ return TRUE;
+
+ while (IoIFP(io)) {
+
+ if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */
+ if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */
+ return FALSE; /* this is the most usual case */
+ }
+
+ ch = PerlIO_getc(IoIFP(io));
+ if (ch != EOF) {
+ (void)PerlIO_ungetc(IoIFP(io),ch);
+ return FALSE;
+ }
+ if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) {
+ if (PerlIO_get_cnt(IoIFP(io)) < -1)
+ PerlIO_set_cnt(IoIFP(io),-1);
+ }
+ if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
+ if (!nextargv(PL_argvgv)) /* get another fp handy */
+ return TRUE;
+ }
+ else
+ return TRUE; /* normal fp, definitely end of file */
+ }
+ return TRUE;
+}
+
+long
+do_tell(GV *gv)
+{
+ register IO *io;
+ register PerlIO *fp;
+
+ if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
+#ifdef ULTRIX_STDIO_BOTCH
+ if (PerlIO_eof(fp))
+ (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
+#endif
+ return PerlIO_tell(fp);
+ }
+ if (PL_dowarn)
+ warn("tell() on unopened file");
+ SETERRNO(EBADF,RMS$_IFI);
+ return -1L;
+}
+
+bool
+do_seek(GV *gv, long int pos, int whence)
+{
+ register IO *io;
+ register PerlIO *fp;
+
+ if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
+#ifdef ULTRIX_STDIO_BOTCH
+ if (PerlIO_eof(fp))
+ (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
+#endif
+ return PerlIO_seek(fp, pos, whence) >= 0;
+ }
+ if (PL_dowarn)
+ warn("seek() on unopened file");
+ SETERRNO(EBADF,RMS$_IFI);
+ return FALSE;
+}
+
+long
+do_sysseek(GV *gv, long int pos, int whence)
+{
+ register IO *io;
+ register PerlIO *fp;
+
+ if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
+ return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
+ if (PL_dowarn)
+ warn("sysseek() on unopened file");
+ SETERRNO(EBADF,RMS$_IFI);
+ return -1L;
+}
+
+int
+do_binmode(PerlIO *fp, int iotype, int flag)
+{
+ if (flag != TRUE)
+ croak("panic: unsetting binmode"); /* Not implemented yet */
+#ifdef DOSISH
+#ifdef atarist
+ if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
+ return 1;
+ else
+ return 0;
+#else
+ if (PerlLIO_setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
+#if defined(WIN32) && defined(__BORLANDC__)
+ /* The translation mode of the stream is maintained independent
+ * of the translation mode of the fd in the Borland RTL (heavy
+ * digging through their runtime sources reveal). User has to
+ * set the mode explicitly for the stream (though they don't
+ * document this anywhere). GSAR 97-5-24
+ */
+ PerlIO_seek(fp,0L,0);
+ ((FILE*)fp)->flags |= _F_BIN;
+#endif
+ return 1;
+ }
+ else
+ return 0;
+#endif
+#else
+#if defined(USEMYBINMODE)
+ if (my_binmode(fp,iotype) != NULL)
+ return 1;
+ else
+ return 0;
+#else
+ return 1;
+#endif
+#endif
+}
+
+#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
+ /* code courtesy of William Kucharski */
+#define HAS_CHSIZE
+
+I32 my_chsize(fd, length)
+I32 fd; /* file descriptor */
+Off_t length; /* length to set file to */
+{
+ struct flock fl;
+ struct stat filebuf;
+
+ if (PerlLIO_fstat(fd, &filebuf) < 0)
+ return -1;
+
+ if (filebuf.st_size < length) {
+
+ /* extend file length */
+
+ if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0)
+ return -1;
+
+ /* write a "0" byte */
+
+ if ((PerlLIO_write(fd, "", 1)) != 1)
+ return -1;
+ }
+ else {
+ /* truncate length */
+
+ fl.l_whence = 0;
+ fl.l_len = 0;
+ fl.l_start = length;
+ fl.l_type = F_WRLCK; /* write lock on file space */
+
+ /*
+ * This relies on the UNDOCUMENTED F_FREESP argument to
+ * fcntl(2), which truncates the file so that it ends at the
+ * position indicated by fl.l_start.
+ *
+ * Will minor miracles never cease?
+ */
+
+ if (fcntl(fd, F_FREESP, &fl) < 0)
+ return -1;
+
+ }
+
+ return 0;
+}
+#endif /* F_FREESP */
+
+bool
+do_print(register SV *sv, PerlIO *fp)
+{
+ register char *tmps;
+ STRLEN len;
+
+ /* assuming fp is checked earlier */
+ if (!sv)
+ return TRUE;
+ if (PL_ofmt) {
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (SvIOK(sv) && SvIVX(sv) != 0) {
+ PerlIO_printf(fp, PL_ofmt, (double)SvIVX(sv));
+ return !PerlIO_error(fp);
+ }
+ if ( (SvNOK(sv) && SvNVX(sv) != 0.0)
+ || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
+ PerlIO_printf(fp, PL_ofmt, SvNVX(sv));
+ return !PerlIO_error(fp);
+ }
+ }
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ if (PL_dowarn)
+ warn(warn_uninit);
+ return TRUE;
+ case SVt_IV:
+ if (SvIOK(sv)) {
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
+ return !PerlIO_error(fp);
+ }
+ /* FALL THROUGH */
+ default:
+ tmps = SvPV(sv, len);
+ break;
+ }
+ if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
+ return FALSE;
+ return !PerlIO_error(fp);
+}
+
+I32
+my_stat(ARGSproto)
+{
+ djSP;
+ IO *io;
+ GV* tmpgv;
+
+ if (PL_op->op_flags & OPf_REF) {
+ EXTEND(SP,1);
+ tmpgv = cGVOP->op_gv;
+ do_fstat:
+ io = GvIO(tmpgv);
+ if (io && IoIFP(io)) {
+ PL_statgv = tmpgv;
+ sv_setpv(PL_statname,"");
+ PL_laststype = OP_STAT;
+ return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
+ }
+ else {
+ if (tmpgv == PL_defgv)
+ return PL_laststatval;
+ if (PL_dowarn)
+ warn("Stat on unopened file <%s>",
+ GvENAME(tmpgv));
+ PL_statgv = Nullgv;
+ sv_setpv(PL_statname,"");
+ return (PL_laststatval = -1);
+ }
+ }
+ else {
+ SV* sv = POPs;
+ char *s;
+ PUTBACK;
+ if (SvTYPE(sv) == SVt_PVGV) {
+ tmpgv = (GV*)sv;
+ goto do_fstat;
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ tmpgv = (GV*)SvRV(sv);
+ goto do_fstat;
+ }
+
+ s = SvPV(sv, PL_na);
+ PL_statgv = Nullgv;
+ sv_setpv(PL_statname, s);
+ PL_laststype = OP_STAT;
+ PL_laststatval = PerlLIO_stat(s, &PL_statcache);
+ if (PL_laststatval < 0 && PL_dowarn && strchr(s, '\n'))
+ warn(warn_nl, "stat");
+ return PL_laststatval;
+ }
+}
+
+I32
+my_lstat(ARGSproto)
+{
+ djSP;
+ SV *sv;
+ if (PL_op->op_flags & OPf_REF) {
+ EXTEND(SP,1);
+ if (cGVOP->op_gv == PL_defgv) {
+ if (PL_laststype != OP_LSTAT)
+ croak("The stat preceding -l _ wasn't an lstat");
+ return PL_laststatval;
+ }
+ croak("You can't use -l on a filehandle");
+ }
+
+ PL_laststype = OP_LSTAT;
+ PL_statgv = Nullgv;
+ sv = POPs;
+ PUTBACK;
+ sv_setpv(PL_statname,SvPV(sv, PL_na));
+#ifdef HAS_LSTAT
+ PL_laststatval = PerlLIO_lstat(SvPV(sv, PL_na),&PL_statcache);
+#else
+ PL_laststatval = PerlLIO_stat(SvPV(sv, PL_na),&PL_statcache);
+#endif
+ if (PL_laststatval < 0 && PL_dowarn && strchr(SvPV(sv, PL_na), '\n'))
+ warn(warn_nl, "lstat");
+ return PL_laststatval;
+}
+
+bool
+do_aexec(SV *really, register SV **mark, register SV **sp)
+{
+ register char **a;
+ char *tmps;
+
+ if (sp > mark) {
+ dTHR;
+ New(401,PL_Argv, sp - mark + 1, char*);
+ a = PL_Argv;
+ while (++mark <= sp) {
+ if (*mark)
+ *a++ = SvPVx(*mark, PL_na);
+ 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)))
+ PerlProc_execvp(tmps,PL_Argv);
+ else
+ PerlProc_execvp(PL_Argv[0],PL_Argv);
+ if (PL_dowarn)
+ warn("Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno));
+ }
+ do_execfree();
+ return FALSE;
+}
+
+void
+do_execfree(void)
+{
+ if (PL_Argv) {
+ Safefree(PL_Argv);
+ PL_Argv = Null(char **);
+ }
+ if (PL_Cmd) {
+ Safefree(PL_Cmd);
+ PL_Cmd = Nullch;
+ }
+}
+
+#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP)
+
+bool
+do_exec(char *cmd)
+{
+ register char **a;
+ register char *s;
+ char flags[10];
+
+ while (*cmd && isSPACE(*cmd))
+ cmd++;
+
+ /* save an extra exec if possible */
+
+#ifdef CSH
+ if (strnEQ(cmd,PL_cshname,PL_cshlen) && strnEQ(cmd+PL_cshlen," -c",3)) {
+ strcpy(flags,"-c");
+ s = cmd+PL_cshlen+3;
+ if (*s == 'f') {
+ s++;
+ strcat(flags,"f");
+ }
+ if (*s == ' ')
+ s++;
+ if (*s++ == '\'') {
+ char *ncmd = s;
+
+ while (*s)
+ s++;
+ if (s[-1] == '\n')
+ *--s = '\0';
+ if (s[-1] == '\'') {
+ *--s = '\0';
+ PerlProc_execl(PL_cshname,"csh", flags,ncmd,(char*)0);
+ *s = '\'';
+ return FALSE;
+ }
+ }
+ }
+#endif /* CSH */
+
+ /* see if there are shell metacharacters in it */
+
+ if (*cmd == '.' && isSPACE(cmd[1]))
+ goto doshell;
+
+ if (strnEQ(cmd,"exec",4) && isSPACE(cmd[4]))
+ goto doshell;
+
+ for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */
+ if (*s == '=')
+ goto doshell;
+
+ for (s = cmd; *s; s++) {
+ if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
+ if (*s == '\n' && !s[1]) {
+ *s = '\0';
+ break;
+ }
+ doshell:
+ PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
+ return FALSE;
+ }
+ }
+
+ New(402,PL_Argv, (s - cmd) / 2 + 2, char*);
+ PL_Cmd = savepvn(cmd, s-cmd);
+ a = PL_Argv;
+ for (s = PL_Cmd; *s;) {
+ while (*s && isSPACE(*s)) s++;
+ if (*s)
+ *(a++) = s;
+ while (*s && !isSPACE(*s)) s++;
+ if (*s)
+ *s++ = '\0';
+ }
+ *a = Nullch;
+ if (PL_Argv[0]) {
+ PerlProc_execvp(PL_Argv[0],PL_Argv);
+ if (errno == ENOEXEC) { /* for system V NIH syndrome */
+ do_execfree();
+ goto doshell;
+ }
+ if (PL_dowarn)
+ warn("Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno));
+ }
+ do_execfree();
+ return FALSE;
+}
+
+#endif /* OS2 || WIN32 */
+
+I32
+apply(I32 type, register SV **mark, register SV **sp)
+{
+ dTHR;
+ register I32 val;
+ register I32 val2;
+ register I32 tot = 0;
+ char *what;
+ char *s;
+ SV **oldmark = mark;
+
+#define APPLY_TAINT_PROPER() \
+ STMT_START { \
+ if (PL_tainting && PL_tainted) { goto taint_proper_label; } \
+ } STMT_END
+
+ /* This is a first heuristic; it doesn't catch tainting magic. */
+ if (PL_tainting) {
+ while (++mark <= sp) {
+ if (SvTAINTED(*mark)) {
+ TAINT;
+ break;
+ }
+ }
+ mark = oldmark;
+ }
+ switch (type) {
+ case OP_CHMOD:
+ what = "chmod";
+ APPLY_TAINT_PROPER();
+ if (++mark <= sp) {
+ val = SvIVx(*mark);
+ APPLY_TAINT_PROPER();
+ tot = sp - mark;
+ while (++mark <= sp) {
+ char *name = SvPVx(*mark, PL_na);
+ APPLY_TAINT_PROPER();
+ if (PerlLIO_chmod(name, val))
+ tot--;
+ }
+ }
+ break;
+#ifdef HAS_CHOWN
+ case OP_CHOWN:
+ what = "chown";
+ APPLY_TAINT_PROPER();
+ if (sp - mark > 2) {
+ val = SvIVx(*++mark);
+ val2 = SvIVx(*++mark);
+ APPLY_TAINT_PROPER();
+ tot = sp - mark;
+ while (++mark <= sp) {
+ char *name = SvPVx(*mark, PL_na);
+ APPLY_TAINT_PROPER();
+ if (PerlLIO_chown(name, val, val2))
+ tot--;
+ }
+ }
+ break;
+#endif
+/*
+XXX Should we make lchown() directly available from perl?
+For now, we'll let Configure test for HAS_LCHOWN, but do
+nothing in the core.
+ --AD 5/1998
+*/
+#ifdef HAS_KILL
+ case OP_KILL:
+ what = "kill";
+ APPLY_TAINT_PROPER();
+ if (mark == sp)
+ break;
+ s = SvPVx(*++mark, PL_na);
+ if (isUPPER(*s)) {
+ if (*s == 'S' && s[1] == 'I' && s[2] == 'G')
+ s += 3;
+ if (!(val = whichsig(s)))
+ croak("Unrecognized signal name \"%s\"",s);
+ }
+ else
+ val = SvIVx(*mark);
+ APPLY_TAINT_PROPER();
+ tot = sp - mark;
+#ifdef VMS
+ /* kill() doesn't do process groups (job trees?) under VMS */
+ if (val < 0) val = -val;
+ if (val == SIGKILL) {
+# include <starlet.h>
+ /* Use native sys$delprc() to insure that target process is
+ * deleted; supervisor-mode images don't pay attention to
+ * CRTL's emulation of Unix-style signals and kill()
+ */
+ while (++mark <= sp) {
+ I32 proc = SvIVx(*mark);
+ register unsigned long int __vmssts;
+ APPLY_TAINT_PROPER();
+ if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
+ tot--;
+ switch (__vmssts) {
+ case SS$_NONEXPR:
+ case SS$_NOSUCHNODE:
+ SETERRNO(ESRCH,__vmssts);
+ break;
+ case SS$_NOPRIV:
+ SETERRNO(EPERM,__vmssts);
+ break;
+ default:
+ SETERRNO(EVMSERR,__vmssts);
+ }
+ }
+ }
+ break;
+ }
+#endif
+ if (val < 0) {
+ val = -val;
+ while (++mark <= sp) {
+ I32 proc = SvIVx(*mark);
+ APPLY_TAINT_PROPER();
+#ifdef HAS_KILLPG
+ if (PerlProc_killpg(proc,val)) /* BSD */
+#else
+ if (PerlProc_kill(-proc,val)) /* SYSV */
+#endif
+ tot--;
+ }
+ }
+ else {
+ while (++mark <= sp) {
+ I32 proc = SvIVx(*mark);
+ APPLY_TAINT_PROPER();
+ if (PerlProc_kill(proc, val))
+ tot--;
+ }
+ }
+ break;
+#endif
+ case OP_UNLINK:
+ what = "unlink";
+ APPLY_TAINT_PROPER();
+ tot = sp - mark;
+ while (++mark <= sp) {
+ s = SvPVx(*mark, PL_na);
+ APPLY_TAINT_PROPER();
+ if (PL_euid || PL_unsafe) {
+ if (UNLINK(s))
+ tot--;
+ }
+ else { /* don't let root wipe out directories without -U */
+#ifdef HAS_LSTAT
+ if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
+#else
+ if (PerlLIO_stat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode))
+#endif
+ tot--;
+ else {
+ if (UNLINK(s))
+ tot--;
+ }
+ }
+ }
+ break;
+#ifdef HAS_UTIME
+ case OP_UTIME:
+ what = "utime";
+ APPLY_TAINT_PROPER();
+ if (sp - mark > 2) {
+#if defined(I_UTIME) || defined(VMS)
+ struct utimbuf utbuf;
+#else
+ struct {
+ long actime;
+ long modtime;
+ } utbuf;
+#endif
+
+ Zero(&utbuf, sizeof utbuf, char);
+#ifdef BIG_TIME
+ utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
+ utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
+#else
+ utbuf.actime = SvIVx(*++mark); /* time accessed */
+ utbuf.modtime = SvIVx(*++mark); /* time modified */
+#endif
+ APPLY_TAINT_PROPER();
+ tot = sp - mark;
+ while (++mark <= sp) {
+ char *name = SvPVx(*mark, PL_na);
+ APPLY_TAINT_PROPER();
+ if (PerlLIO_utime(name, &utbuf))
+ tot--;
+ }
+ }
+ else
+ tot = 0;
+ break;
+#endif
+ }
+ return tot;
+
+ taint_proper_label:
+ TAINT_PROPER(what);
+ return 0; /* this should never happen */
+
+#undef APPLY_TAINT_PROPER
+}
+
+/* Do the permissions allow some operation? Assumes statcache already set. */
+#ifndef VMS /* VMS' cando is in vms.c */
+I32
+cando(I32 bit, I32 effective, register struct stat *statbufp)
+{
+#ifdef DOSISH
+ /* [Comments and code from Len Reed]
+ * MS-DOS "user" is similar to UNIX's "superuser," but can't write
+ * to write-protected files. The execute permission bit is set
+ * by the Miscrosoft C library stat() function for the following:
+ * .exe files
+ * .com files
+ * .bat files
+ * directories
+ * All files and directories are readable.
+ * Directories and special files, e.g. "CON", cannot be
+ * write-protected.
+ * [Comment by Tom Dinger -- a directory can have the write-protect
+ * bit set in the file system, but DOS permits changes to
+ * the directory anyway. In addition, all bets are off
+ * here for networked software, such as Novell and
+ * Sun's PC-NFS.]
+ */
+
+ /* Atari stat() does pretty much the same thing. we set x_bit_set_in_stat
+ * too so it will actually look into the files for magic numbers
+ */
+ return (bit & statbufp->st_mode) ? TRUE : FALSE;
+
+#else /* ! DOSISH */
+ if ((effective ? PL_euid : PL_uid) == 0) { /* root is special */
+ if (bit == S_IXUSR) {
+ if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
+ return TRUE;
+ }
+ else
+ return TRUE; /* root reads and writes anything */
+ return FALSE;
+ }
+ if (statbufp->st_uid == (effective ? PL_euid : PL_uid) ) {
+ if (statbufp->st_mode & bit)
+ return TRUE; /* ok as "user" */
+ }
+ else if (ingroup((I32)statbufp->st_gid,effective)) {
+ if (statbufp->st_mode & bit >> 3)
+ return TRUE; /* ok as "group" */
+ }
+ else if (statbufp->st_mode & bit >> 6)
+ return TRUE; /* ok as "other" */
+ return FALSE;
+#endif /* ! DOSISH */
+}
+#endif /* ! VMS */
+
+I32
+ingroup(I32 testgid, I32 effective)
+{
+ if (testgid == (effective ? PL_egid : PL_gid))
+ return TRUE;
+#ifdef HAS_GETGROUPS
+#ifndef NGROUPS
+#define NGROUPS 32
+#endif
+ {
+ Groups_t gary[NGROUPS];
+ I32 anum;
+
+ anum = getgroups(NGROUPS,gary);
+ while (--anum >= 0)
+ if (gary[anum] == testgid)
+ return TRUE;
+ }
+#endif
+ return FALSE;
+}
+
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+
+I32
+do_ipcget(I32 optype, SV **mark, SV **sp)
+{
+ dTHR;
+ key_t key;
+ I32 n, flags;
+
+ key = (key_t)SvNVx(*++mark);
+ n = (optype == OP_MSGGET) ? 0 : SvIVx(*++mark);
+ flags = SvIVx(*++mark);
+ SETERRNO(0,0);
+ switch (optype)
+ {
+#ifdef HAS_MSG
+ case OP_MSGGET:
+ return msgget(key, flags);
+#endif
+#ifdef HAS_SEM
+ case OP_SEMGET:
+ return semget(key, n, flags);
+#endif
+#ifdef HAS_SHM
+ case OP_SHMGET:
+ return shmget(key, n, flags);
+#endif
+#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
+ default:
+ croak("%s not implemented", op_desc[optype]);
+#endif
+ }
+ return -1; /* should never happen */
+}
+
+I32
+do_ipcctl(I32 optype, SV **mark, SV **sp)
+{
+ dTHR;
+ SV *astr;
+ char *a;
+ I32 id, n, cmd, infosize, getinfo;
+ I32 ret = -1;
+
+ id = SvIVx(*++mark);
+ n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
+ cmd = SvIVx(*++mark);
+ astr = *++mark;
+ infosize = 0;
+ getinfo = (cmd == IPC_STAT);
+
+ switch (optype)
+ {
+#ifdef HAS_MSG
+ case OP_MSGCTL:
+ if (cmd == IPC_STAT || cmd == IPC_SET)
+ infosize = sizeof(struct msqid_ds);
+ break;
+#endif
+#ifdef HAS_SHM
+ case OP_SHMCTL:
+ if (cmd == IPC_STAT || cmd == IPC_SET)
+ infosize = sizeof(struct shmid_ds);
+ break;
+#endif
+#ifdef HAS_SEM
+ case OP_SEMCTL:
+ if (cmd == IPC_STAT || cmd == IPC_SET)
+ infosize = sizeof(struct semid_ds);
+ else if (cmd == GETALL || cmd == SETALL)
+ {
+ struct semid_ds semds;
+ union semun semun;
+
+ semun.buf = &semds;
+ getinfo = (cmd == GETALL);
+ if (Semctl(id, 0, IPC_STAT, semun) == -1)
+ return -1;
+ infosize = semds.sem_nsems * sizeof(short);
+ /* "short" is technically wrong but much more portable
+ than guessing about u_?short(_t)? */
+ }
+ break;
+#endif
+#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
+ default:
+ croak("%s not implemented", op_desc[optype]);
+#endif
+ }
+
+ if (infosize)
+ {
+ STRLEN len;
+ if (getinfo)
+ {
+ SvPV_force(astr, len);
+ a = SvGROW(astr, infosize+1);
+ }
+ else
+ {
+ a = SvPV(astr, len);
+ if (len != infosize)
+ croak("Bad arg length for %s, is %lu, should be %ld",
+ op_desc[optype], (unsigned long)len, (long)infosize);
+ }
+ }
+ else
+ {
+ IV i = SvIV(astr);
+ a = (char *)i; /* ouch */
+ }
+ SETERRNO(0,0);
+ switch (optype)
+ {
+#ifdef HAS_MSG
+ case OP_MSGCTL:
+ ret = msgctl(id, cmd, (struct msqid_ds *)a);
+ break;
+#endif
+#ifdef HAS_SEM
+ case OP_SEMCTL: {
+ union semun unsemds;
+
+ unsemds.buf = (struct semid_ds *)a;
+ ret = Semctl(id, n, cmd, unsemds);
+ }
+ break;
+#endif
+#ifdef HAS_SHM
+ case OP_SHMCTL:
+ ret = shmctl(id, cmd, (struct shmid_ds *)a);
+ break;
+#endif
+ }
+ if (getinfo && ret >= 0) {
+ SvCUR_set(astr, infosize);
+ *SvEND(astr) = '\0';
+ SvSETMAGIC(astr);
+ }
+ return ret;
+}
+
+I32
+do_msgsnd(SV **mark, SV **sp)
+{
+#ifdef HAS_MSG
+ dTHR;
+ SV *mstr;
+ char *mbuf;
+ I32 id, msize, flags;
+ STRLEN len;
+
+ id = SvIVx(*++mark);
+ mstr = *++mark;
+ flags = SvIVx(*++mark);
+ mbuf = SvPV(mstr, len);
+ if ((msize = len - sizeof(long)) < 0)
+ croak("Arg too short for msgsnd");
+ SETERRNO(0,0);
+ return msgsnd(id, (struct msgbuf *)mbuf, msize, flags);
+#else
+ croak("msgsnd not implemented");
+#endif
+}
+
+I32
+do_msgrcv(SV **mark, SV **sp)
+{
+#ifdef HAS_MSG
+ dTHR;
+ SV *mstr;
+ char *mbuf;
+ long mtype;
+ I32 id, msize, flags, ret;
+ STRLEN len;
+
+ id = SvIVx(*++mark);
+ mstr = *++mark;
+ msize = SvIVx(*++mark);
+ mtype = (long)SvIVx(*++mark);
+ flags = SvIVx(*++mark);
+ if (SvTHINKFIRST(mstr)) {
+ if (SvREADONLY(mstr))
+ croak("Can't msgrcv to readonly var");
+ if (SvROK(mstr))
+ sv_unref(mstr);
+ }
+ SvPV_force(mstr, len);
+ mbuf = SvGROW(mstr, sizeof(long)+msize+1);
+
+ SETERRNO(0,0);
+ ret = msgrcv(id, (struct msgbuf *)mbuf, msize, mtype, flags);
+ if (ret >= 0) {
+ SvCUR_set(mstr, sizeof(long)+ret);
+ *SvEND(mstr) = '\0';
+ }
+ return ret;
+#else
+ croak("msgrcv not implemented");
+#endif
+}
+
+I32
+do_semop(SV **mark, SV **sp)
+{
+#ifdef HAS_SEM
+ dTHR;
+ SV *opstr;
+ char *opbuf;
+ I32 id;
+ STRLEN opsize;
+
+ id = SvIVx(*++mark);
+ opstr = *++mark;
+ opbuf = SvPV(opstr, opsize);
+ if (opsize < sizeof(struct sembuf)
+ || (opsize % sizeof(struct sembuf)) != 0) {
+ SETERRNO(EINVAL,LIB$_INVARG);
+ return -1;
+ }
+ SETERRNO(0,0);
+ return semop(id, (struct sembuf *)opbuf, opsize/sizeof(struct sembuf));
+#else
+ croak("semop not implemented");
+#endif
+}
+
+I32
+do_shmio(I32 optype, SV **mark, SV **sp)
+{
+#ifdef HAS_SHM
+ dTHR;
+ SV *mstr;
+ char *mbuf, *shm;
+ I32 id, mpos, msize;
+ STRLEN len;
+ struct shmid_ds shmds;
+
+ id = SvIVx(*++mark);
+ mstr = *++mark;
+ mpos = SvIVx(*++mark);
+ msize = SvIVx(*++mark);
+ SETERRNO(0,0);
+ if (shmctl(id, IPC_STAT, &shmds) == -1)
+ return -1;
+ if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
+ SETERRNO(EFAULT,SS$_ACCVIO); /* can't do as caller requested */
+ return -1;
+ }
+ shm = (char *)shmat(id, (char*)NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0);
+ if (shm == (char *)-1) /* I hate System V IPC, I really do */
+ return -1;
+ if (optype == OP_SHMREAD) {
+ SvPV_force(mstr, len);
+ mbuf = SvGROW(mstr, msize+1);
+
+ Copy(shm + mpos, mbuf, msize, char);
+ SvCUR_set(mstr, msize);
+ *SvEND(mstr) = '\0';
+ SvSETMAGIC(mstr);
+ }
+ else {
+ I32 n;
+
+ mbuf = SvPV(mstr, len);
+ if ((n = len) > msize)
+ n = msize;
+ Copy(mbuf, shm + mpos, n, char);
+ if (n < msize)
+ memzero(shm + mpos + n, msize - n);
+ }
+ return shmdt(shm);
+#else
+ croak("shm I/O not implemented");
+#endif
+}
+
+#endif /* SYSV IPC */
+
diff --git a/contrib/perl5/doop.c b/contrib/perl5/doop.c
new file mode 100644
index 000000000000..e80fa489ce93
--- /dev/null
+++ b/contrib/perl5/doop.c
@@ -0,0 +1,528 @@
+/* doop.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "'So that was the job I felt I had to do when I started,' thought Sam."
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+#include <signal.h>
+#endif
+
+I32
+do_trans(SV *sv, OP *arg)
+{
+ dTHR;
+ register short *tbl;
+ register U8 *s;
+ register U8 *send;
+ register U8 *d;
+ register I32 ch;
+ register I32 matches = 0;
+ register I32 squash = PL_op->op_private & OPpTRANS_SQUASH;
+ register U8 *p;
+ STRLEN len;
+
+ if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_COUNTONLY))
+ croak(no_modify);
+ tbl = (short*)cPVOP->op_pv;
+ s = (U8*)SvPV(sv, len);
+ if (!len)
+ return 0;
+ if (!SvPOKp(sv))
+ s = (U8*)SvPV_force(sv, len);
+ (void)SvPOK_only(sv);
+ send = s + len;
+ if (!tbl || !s)
+ croak("panic: do_trans");
+ DEBUG_t( deb("2.TBL\n"));
+ if (!PL_op->op_private) {
+ while (s < send) {
+ if ((ch = tbl[*s]) >= 0) {
+ matches++;
+ *s = ch;
+ }
+ s++;
+ }
+ SvSETMAGIC(sv);
+ }
+ else if (PL_op->op_private & OPpTRANS_COUNTONLY) {
+ while (s < send) {
+ if (tbl[*s] >= 0)
+ matches++;
+ s++;
+ }
+ }
+ else {
+ d = s;
+ p = send;
+ while (s < send) {
+ if ((ch = tbl[*s]) >= 0) {
+ *d = ch;
+ matches++;
+ if (squash) {
+ if (p == d - 1 && *p == *d)
+ matches--;
+ else
+ p = d++;
+ }
+ else
+ d++;
+ }
+ else if (ch == -1) /* -1 is unmapped character */
+ *d++ = *s; /* -2 is delete character */
+ s++;
+ }
+ matches += send - d; /* account for disappeared chars */
+ *d = '\0';
+ SvCUR_set(sv, d - (U8*)SvPVX(sv));
+ SvSETMAGIC(sv);
+ }
+ return matches;
+}
+
+void
+do_join(register SV *sv, SV *del, register SV **mark, register SV **sp)
+{
+ SV **oldmark = mark;
+ register I32 items = sp - mark;
+ register STRLEN len;
+ STRLEN delimlen;
+ register char *delim = SvPV(del, delimlen);
+ STRLEN tmplen;
+
+ mark++;
+ len = (items > 0 ? (delimlen * (items - 1) ) : 0);
+ if (SvTYPE(sv) < SVt_PV)
+ sv_upgrade(sv, SVt_PV);
+ if (SvLEN(sv) < len + items) { /* current length is way too short */
+ while (items-- > 0) {
+ if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) {
+ SvPV(*mark, tmplen);
+ len += tmplen;
+ }
+ mark++;
+ }
+ SvGROW(sv, len + 1); /* so try to pre-extend */
+
+ mark = oldmark;
+ items = sp - mark;;
+ ++mark;
+ }
+
+ if (items-- > 0) {
+ char *s;
+
+ if (*mark) {
+ s = SvPV(*mark, tmplen);
+ sv_setpvn(sv, s, tmplen);
+ }
+ else
+ sv_setpv(sv, "");
+ mark++;
+ }
+ else
+ sv_setpv(sv,"");
+ len = delimlen;
+ if (len) {
+ for (; items > 0; items--,mark++) {
+ sv_catpvn(sv,delim,len);
+ sv_catsv(sv,*mark);
+ }
+ }
+ else {
+ for (; items > 0; items--,mark++)
+ sv_catsv(sv,*mark);
+ }
+ SvSETMAGIC(sv);
+}
+
+void
+do_sprintf(SV *sv, I32 len, SV **sarg)
+{
+ STRLEN patlen;
+ char *pat = SvPV(*sarg, patlen);
+ bool do_taint = FALSE;
+
+ sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
+ SvSETMAGIC(sv);
+ if (do_taint)
+ SvTAINTED_on(sv);
+}
+
+void
+do_vecset(SV *sv)
+{
+ SV *targ = LvTARG(sv);
+ register I32 offset;
+ register I32 size;
+ register unsigned char *s;
+ register unsigned long lval;
+ I32 mask;
+ STRLEN targlen;
+ STRLEN len;
+
+ if (!targ)
+ return;
+ s = (unsigned char*)SvPV_force(targ, targlen);
+ lval = U_L(SvNV(sv));
+ offset = LvTARGOFF(sv);
+ size = LvTARGLEN(sv);
+
+ len = (offset + size + 7) / 8;
+ if (len > targlen) {
+ s = (unsigned char*)SvGROW(targ, len + 1);
+ (void)memzero(s + targlen, len - targlen + 1);
+ SvCUR_set(targ, len);
+ }
+
+ if (size < 8) {
+ mask = (1 << size) - 1;
+ size = offset & 7;
+ lval &= mask;
+ offset >>= 3;
+ s[offset] &= ~(mask << size);
+ s[offset] |= lval << size;
+ }
+ else {
+ offset >>= 3;
+ if (size == 8)
+ s[offset] = lval & 255;
+ else if (size == 16) {
+ s[offset] = (lval >> 8) & 255;
+ s[offset+1] = lval & 255;
+ }
+ else if (size == 32) {
+ s[offset] = (lval >> 24) & 255;
+ s[offset+1] = (lval >> 16) & 255;
+ s[offset+2] = (lval >> 8) & 255;
+ s[offset+3] = lval & 255;
+ }
+ }
+}
+
+void
+do_chop(register SV *astr, register SV *sv)
+{
+ STRLEN len;
+ char *s;
+
+ if (SvTYPE(sv) == SVt_PVAV) {
+ register I32 i;
+ I32 max;
+ AV* av = (AV*)sv;
+ max = AvFILL(av);
+ for (i = 0; i <= max; i++) {
+ sv = (SV*)av_fetch(av, i, FALSE);
+ if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
+ do_chop(astr, sv);
+ }
+ return;
+ }
+ if (SvTYPE(sv) == SVt_PVHV) {
+ HV* hv = (HV*)sv;
+ HE* entry;
+ (void)hv_iterinit(hv);
+ /*SUPPRESS 560*/
+ while (entry = hv_iternext(hv))
+ do_chop(astr,hv_iterval(hv,entry));
+ return;
+ }
+ s = SvPV(sv, len);
+ if (len && !SvPOK(sv))
+ s = SvPV_force(sv, len);
+ if (s && len) {
+ s += --len;
+ sv_setpvn(astr, s, 1);
+ *s = '\0';
+ SvCUR_set(sv, len);
+ SvNIOK_off(sv);
+ }
+ else
+ sv_setpvn(astr, "", 0);
+ SvSETMAGIC(sv);
+}
+
+I32
+do_chomp(register SV *sv)
+{
+ dTHR;
+ register I32 count;
+ STRLEN len;
+ char *s;
+
+ if (RsSNARF(PL_rs))
+ return 0;
+ count = 0;
+ if (SvTYPE(sv) == SVt_PVAV) {
+ register I32 i;
+ I32 max;
+ AV* av = (AV*)sv;
+ max = AvFILL(av);
+ for (i = 0; i <= max; i++) {
+ sv = (SV*)av_fetch(av, i, FALSE);
+ if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
+ count += do_chomp(sv);
+ }
+ return count;
+ }
+ if (SvTYPE(sv) == SVt_PVHV) {
+ HV* hv = (HV*)sv;
+ HE* entry;
+ (void)hv_iterinit(hv);
+ /*SUPPRESS 560*/
+ while (entry = hv_iternext(hv))
+ count += do_chomp(hv_iterval(hv,entry));
+ return count;
+ }
+ s = SvPV(sv, len);
+ if (len && !SvPOKp(sv))
+ s = SvPV_force(sv, len);
+ if (s && len) {
+ s += --len;
+ if (RsPARA(PL_rs)) {
+ if (*s != '\n')
+ goto nope;
+ ++count;
+ while (len && s[-1] == '\n') {
+ --len;
+ --s;
+ ++count;
+ }
+ }
+ else {
+ STRLEN rslen;
+ char *rsptr = SvPV(PL_rs, rslen);
+ if (rslen == 1) {
+ if (*s != *rsptr)
+ goto nope;
+ ++count;
+ }
+ else {
+ if (len < rslen - 1)
+ goto nope;
+ len -= rslen - 1;
+ s -= rslen - 1;
+ if (memNE(s, rsptr, rslen))
+ goto nope;
+ count += rslen;
+ }
+ }
+ *s = '\0';
+ SvCUR_set(sv, len);
+ SvNIOK_off(sv);
+ }
+ nope:
+ SvSETMAGIC(sv);
+ return count;
+}
+
+void
+do_vop(I32 optype, SV *sv, SV *left, SV *right)
+{
+ dTHR; /* just for taint */
+#ifdef LIBERAL
+ register long *dl;
+ register long *ll;
+ register long *rl;
+#endif
+ register char *dc;
+ STRLEN leftlen;
+ STRLEN rightlen;
+ register char *lc;
+ register char *rc;
+ register I32 len;
+ I32 lensave;
+ char *lsave;
+ char *rsave;
+
+ if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
+ sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */
+ lsave = lc = SvPV(left, leftlen);
+ rsave = rc = SvPV(right, rightlen);
+ len = leftlen < rightlen ? leftlen : rightlen;
+ lensave = len;
+ if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
+ dc = SvPV_force(sv, PL_na);
+ if (SvCUR(sv) < len) {
+ dc = SvGROW(sv, len + 1);
+ (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
+ }
+ }
+ else {
+ I32 needlen = ((optype == OP_BIT_AND)
+ ? len : (leftlen > rightlen ? leftlen : rightlen));
+ Newz(801, dc, needlen + 1, char);
+ (void)sv_usepvn(sv, dc, needlen);
+ dc = SvPVX(sv); /* sv_usepvn() calls Renew() */
+ }
+ SvCUR_set(sv, len);
+ (void)SvPOK_only(sv);
+#ifdef LIBERAL
+ if (len >= sizeof(long)*4 &&
+ !((long)dc % sizeof(long)) &&
+ !((long)lc % sizeof(long)) &&
+ !((long)rc % sizeof(long))) /* It's almost always aligned... */
+ {
+ I32 remainder = len % (sizeof(long)*4);
+ len /= (sizeof(long)*4);
+
+ dl = (long*)dc;
+ ll = (long*)lc;
+ rl = (long*)rc;
+
+ switch (optype) {
+ case OP_BIT_AND:
+ while (len--) {
+ *dl++ = *ll++ & *rl++;
+ *dl++ = *ll++ & *rl++;
+ *dl++ = *ll++ & *rl++;
+ *dl++ = *ll++ & *rl++;
+ }
+ break;
+ case OP_BIT_XOR:
+ while (len--) {
+ *dl++ = *ll++ ^ *rl++;
+ *dl++ = *ll++ ^ *rl++;
+ *dl++ = *ll++ ^ *rl++;
+ *dl++ = *ll++ ^ *rl++;
+ }
+ break;
+ case OP_BIT_OR:
+ while (len--) {
+ *dl++ = *ll++ | *rl++;
+ *dl++ = *ll++ | *rl++;
+ *dl++ = *ll++ | *rl++;
+ *dl++ = *ll++ | *rl++;
+ }
+ }
+
+ dc = (char*)dl;
+ lc = (char*)ll;
+ rc = (char*)rl;
+
+ len = remainder;
+ }
+#endif
+ {
+ switch (optype) {
+ case OP_BIT_AND:
+ while (len--)
+ *dc++ = *lc++ & *rc++;
+ break;
+ case OP_BIT_XOR:
+ while (len--)
+ *dc++ = *lc++ ^ *rc++;
+ goto mop_up;
+ case OP_BIT_OR:
+ while (len--)
+ *dc++ = *lc++ | *rc++;
+ mop_up:
+ len = lensave;
+ if (rightlen > len)
+ sv_catpvn(sv, rsave + len, rightlen - len);
+ else if (leftlen > len)
+ sv_catpvn(sv, lsave + len, leftlen - len);
+ else
+ *SvEND(sv) = '\0';
+ break;
+ }
+ }
+ SvTAINT(sv);
+}
+
+OP *
+do_kv(ARGSproto)
+{
+ djSP;
+ HV *hv = (HV*)POPs;
+ HV *keys;
+ register HE *entry;
+ SV *tmpstr;
+ I32 gimme = GIMME_V;
+ I32 dokeys = (PL_op->op_type == OP_KEYS);
+ I32 dovalues = (PL_op->op_type == OP_VALUES);
+ I32 realhv = (SvTYPE(hv) == SVt_PVHV);
+
+ if (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV)
+ dokeys = dovalues = TRUE;
+
+ if (!hv) {
+ if (PL_op->op_flags & OPf_MOD) { /* lvalue */
+ dTARGET; /* make sure to clear its target here */
+ if (SvTYPE(TARG) == SVt_PVLV)
+ LvTARG(TARG) = Nullsv;
+ PUSHs(TARG);
+ }
+ RETURN;
+ }
+
+ keys = realhv ? hv : avhv_keys((AV*)hv);
+ (void)hv_iterinit(keys); /* always reset iterator regardless */
+
+ if (gimme == G_VOID)
+ RETURN;
+
+ if (gimme == G_SCALAR) {
+ IV i;
+ dTARGET;
+
+ if (PL_op->op_flags & OPf_MOD) { /* lvalue */
+ if (SvTYPE(TARG) < SVt_PVLV) {
+ sv_upgrade(TARG, SVt_PVLV);
+ sv_magic(TARG, Nullsv, 'k', Nullch, 0);
+ }
+ LvTYPE(TARG) = 'k';
+ if (LvTARG(TARG) != (SV*)keys) {
+ if (LvTARG(TARG))
+ SvREFCNT_dec(LvTARG(TARG));
+ LvTARG(TARG) = SvREFCNT_inc(keys);
+ }
+ PUSHs(TARG);
+ RETURN;
+ }
+
+ if (!SvRMAGICAL(keys) || !mg_find((SV*)keys,'P'))
+ i = HvKEYS(keys);
+ else {
+ i = 0;
+ /*SUPPRESS 560*/
+ while (hv_iternext(keys)) i++;
+ }
+ PUSHi( i );
+ RETURN;
+ }
+
+ EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
+
+ PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
+ while (entry = hv_iternext(keys)) {
+ SPAGAIN;
+ if (dokeys)
+ XPUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
+ if (dovalues) {
+ tmpstr = sv_newmortal();
+ PUTBACK;
+ sv_setsv(tmpstr,realhv ?
+ hv_iterval(hv,entry) : avhv_iterval((AV*)hv,entry));
+ DEBUG_H(sv_setpvf(tmpstr, "%lu%%%d=%lu",
+ (unsigned long)HeHASH(entry),
+ HvMAX(keys)+1,
+ (unsigned long)(HeHASH(entry) & HvMAX(keys))));
+ SPAGAIN;
+ XPUSHs(tmpstr);
+ }
+ PUTBACK;
+ }
+ return NORMAL;
+}
+
diff --git a/contrib/perl5/dosish.h b/contrib/perl5/dosish.h
new file mode 100644
index 000000000000..1d52d0c0cdd4
--- /dev/null
+++ b/contrib/perl5/dosish.h
@@ -0,0 +1,135 @@
+#define ABORT() abort();
+
+#ifndef SH_PATH
+#define SH_PATH "/bin/sh"
+#endif
+
+#ifdef DJGPP
+# define BIT_BUCKET "nul"
+# define OP_BINARY O_BINARY
+# define PERL_SYS_INIT(c,v) Perl_DJGPP_init(c,v)
+# include <signal.h>
+# define HAS_UTIME
+# define HAS_KILL
+ char *djgpp_pathexp (const char*);
+# if (DJGPP==2 && DJGPP_MINOR < 2)
+# define NO_LOCALECONV_MON_THOUSANDS_SEP
+# endif
+# ifdef USE_THREADS
+# define NEED_PTHREAD_INIT
+# define OLD_PTHREADS_API
+# define YIELD pthread_yield(NULL)
+# define DETACH(t) \
+ STMT_START { \
+ if (pthread_detach(&(t)->self)) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ croak("panic: DETACH"); \
+ } \
+ } STMT_END
+# define pthread_mutexattr_default NULL
+# define pthread_condattr_default NULL
+# define pthread_addr_t any_t
+# define PTHREAD_CREATE_JOINABLE (&err)
+# endif
+#else /* DJGPP */
+# ifdef WIN32
+# define PERL_SYS_INIT(c,v) Perl_win32_init(c,v)
+# define BIT_BUCKET "nul"
+# else
+# define PERL_SYS_INIT(c,v)
+# define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?" */
+# endif
+#endif /* DJGPP */
+
+#define PERL_SYS_TERM() MALLOC_TERM
+#define dXSUB_SYS
+#define TMPPATH "plXXXXXX"
+
+/*
+ * 5.003_07 and earlier keyed on #ifdef MSDOS for determining if we were
+ * running on DOS, *and* if we had to cope with 16 bit memory addressing
+ * constraints, *and* we need to have memory allocated as unsigned long.
+ *
+ * with the advent of *real* compilers for DOS, they are not locked together.
+ * MSDOS means "I am running on MSDOS". HAS_64K_LIMIT means "I have
+ * 16 bit memory addressing constraints".
+ *
+ * if you need the last, try #DEFINE MEM_SIZE unsigned long.
+ */
+#ifdef MSDOS
+ #ifndef DJGPP
+ #define HAS_64K_LIMIT
+ #endif
+#endif
+
+/* USEMYBINMODE
+ * This symbol, if defined, indicates that the program should
+ * use the routine my_binmode(FILE *fp, char iotype) to insure
+ * that a file is in "binary" mode -- that is, that no translation
+ * of bytes occurs on read or write operations.
+ */
+#undef USEMYBINMODE
+
+/* Stat_t:
+ * This symbol holds the type used to declare buffers for information
+ * returned by stat(). It's usually just struct stat. It may be necessary
+ * to include <sys/stat.h> and <sys/types.h> to get any typedef'ed
+ * information.
+ */
+#define Stat_t struct stat
+
+/* USE_STAT_RDEV:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_rdev
+ */
+#define USE_STAT_RDEV /**/
+
+/* ACME_MESS:
+ * This symbol, if defined, indicates that error messages should be
+ * should be generated in a format that allows the use of the Acme
+ * GUI/editor's autofind feature.
+ */
+#undef ACME_MESS /**/
+
+/* ALTERNATE_SHEBANG:
+ * This symbol, if defined, contains a "magic" string which may be used
+ * as the first line of a Perl program designed to be executed directly
+ * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG
+ * begins with a character other then #, then Perl will only treat
+ * it as a command line if if finds the string "perl" in the first
+ * word; otherwise it's treated as the first line of code in the script.
+ * (IOW, Perl won't hand off to another interpreter via an alternate
+ * shebang sequence that might be legal Perl code.)
+ */
+/* #define ALTERNATE_SHEBANG "#!" / **/
+
+/*
+ * fwrite1() should be a routine with the same calling sequence as fwrite(),
+ * but which outputs all of the bytes requested as a single stream (unlike
+ * fwrite() itself, which on some systems outputs several distinct records
+ * if the number_of_items parameter is >1).
+ */
+#define fwrite1 fwrite
+
+#define Fstat(fd,bufptr) fstat((fd),(bufptr))
+#define Fflush(fp) fflush(fp)
+#define Mkdir(path,mode) mkdir((path),(mode))
+
+#ifndef WIN32
+# define Stat(fname,bufptr) stat((fname),(bufptr))
+#else
+# define HAS_IOCTL
+# define HAS_UTIME
+# define HAS_KILL
+# define HAS_WAIT
+# define HAS_CHOWN
+/*
+ * This provides a layer of functions and macros to ensure extensions will
+ * get to use the same RTL functions as the core.
+ */
+# ifndef HASATTRIBUTE
+# ifndef PERL_OBJECT
+# include <win32iop.h>
+# endif
+# endif
+#endif /* WIN32 */
diff --git a/contrib/perl5/dump.c b/contrib/perl5/dump.c
new file mode 100644
index 000000000000..b1e984bcadef
--- /dev/null
+++ b/contrib/perl5/dump.c
@@ -0,0 +1,422 @@
+/* dump.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
+ * it has not been hard for me to read your mind and memory.'"
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifndef PERL_OBJECT
+static void dump(char *pat, ...);
+#endif /* PERL_OBJECT */
+
+void
+dump_all(void)
+{
+#ifdef DEBUGGING
+ dTHR;
+ PerlIO_setlinebuf(Perl_debug_log);
+ if (PL_main_root)
+ dump_op(PL_main_root);
+ dump_packsubs(PL_defstash);
+#endif /* DEBUGGING */
+}
+
+void
+dump_packsubs(HV *stash)
+{
+#ifdef DEBUGGING
+ dTHR;
+ I32 i;
+ HE *entry;
+
+ if (!HvARRAY(stash))
+ return;
+ for (i = 0; i <= (I32) HvMAX(stash); i++) {
+ for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
+ GV *gv = (GV*)HeVAL(entry);
+ HV *hv;
+ if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
+ continue;
+ if (GvCVu(gv))
+ dump_sub(gv);
+ if (GvFORM(gv))
+ dump_form(gv);
+ if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
+ (hv = GvHV(gv)) && HvNAME(hv) && hv != PL_defstash)
+ dump_packsubs(hv); /* nested package */
+ }
+ }
+#endif /* DEBUGGING */
+}
+
+void
+dump_sub(GV *gv)
+{
+#ifdef DEBUGGING
+ SV *sv = sv_newmortal();
+
+ gv_fullname3(sv, gv, Nullch);
+ dump("\nSUB %s = ", SvPVX(sv));
+ if (CvXSUB(GvCV(gv)))
+ dump("(xsub 0x%x %d)\n",
+ (long)CvXSUB(GvCV(gv)),
+ CvXSUBANY(GvCV(gv)).any_i32);
+ else if (CvROOT(GvCV(gv)))
+ dump_op(CvROOT(GvCV(gv)));
+ else
+ dump("<undef>\n");
+#endif /* DEBUGGING */
+}
+
+void
+dump_form(GV *gv)
+{
+#ifdef DEBUGGING
+ SV *sv = sv_newmortal();
+
+ gv_fullname3(sv, gv, Nullch);
+ dump("\nFORMAT %s = ", SvPVX(sv));
+ if (CvROOT(GvFORM(gv)))
+ dump_op(CvROOT(GvFORM(gv)));
+ else
+ dump("<undef>\n");
+#endif /* DEBUGGING */
+}
+
+void
+dump_eval(void)
+{
+#ifdef DEBUGGING
+ dump_op(PL_eval_root);
+#endif /* DEBUGGING */
+}
+
+void
+dump_op(OP *o)
+{
+#ifdef DEBUGGING
+ dump("{\n");
+ if (o->op_seq)
+ PerlIO_printf(Perl_debug_log, "%-4d", o->op_seq);
+ else
+ PerlIO_printf(Perl_debug_log, " ");
+ dump("TYPE = %s ===> ", op_name[o->op_type]);
+ if (o->op_next) {
+ if (o->op_seq)
+ PerlIO_printf(Perl_debug_log, "%d\n", o->op_next->op_seq);
+ else
+ PerlIO_printf(Perl_debug_log, "(%d)\n", o->op_next->op_seq);
+ }
+ else
+ PerlIO_printf(Perl_debug_log, "DONE\n");
+ PL_dumplvl++;
+ if (o->op_targ) {
+ if (o->op_type == OP_NULL)
+ dump(" (was %s)\n", op_name[o->op_targ]);
+ else
+ dump("TARG = %d\n", o->op_targ);
+ }
+#ifdef DUMPADDR
+ dump("ADDR = 0x%lx => 0x%lx\n",o, o->op_next);
+#endif
+ if (o->op_flags) {
+ SV *tmpsv = newSVpv("", 0);
+ switch (o->op_flags & OPf_WANT) {
+ case OPf_WANT_VOID:
+ sv_catpv(tmpsv, ",VOID");
+ break;
+ case OPf_WANT_SCALAR:
+ sv_catpv(tmpsv, ",SCALAR");
+ break;
+ case OPf_WANT_LIST:
+ sv_catpv(tmpsv, ",LIST");
+ break;
+ default:
+ sv_catpv(tmpsv, ",UNKNOWN");
+ break;
+ }
+ if (o->op_flags & OPf_KIDS)
+ sv_catpv(tmpsv, ",KIDS");
+ if (o->op_flags & OPf_PARENS)
+ sv_catpv(tmpsv, ",PARENS");
+ if (o->op_flags & OPf_STACKED)
+ sv_catpv(tmpsv, ",STACKED");
+ if (o->op_flags & OPf_REF)
+ sv_catpv(tmpsv, ",REF");
+ if (o->op_flags & OPf_MOD)
+ sv_catpv(tmpsv, ",MOD");
+ if (o->op_flags & OPf_SPECIAL)
+ sv_catpv(tmpsv, ",SPECIAL");
+ dump("FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
+ SvREFCNT_dec(tmpsv);
+ }
+ if (o->op_private) {
+ SV *tmpsv = newSVpv("", 0);
+ if (o->op_type == OP_AASSIGN) {
+ if (o->op_private & OPpASSIGN_COMMON)
+ sv_catpv(tmpsv, ",COMMON");
+ }
+ else if (o->op_type == OP_SASSIGN) {
+ if (o->op_private & OPpASSIGN_BACKWARDS)
+ sv_catpv(tmpsv, ",BACKWARDS");
+ }
+ else if (o->op_type == OP_TRANS) {
+ if (o->op_private & OPpTRANS_SQUASH)
+ sv_catpv(tmpsv, ",SQUASH");
+ if (o->op_private & OPpTRANS_DELETE)
+ sv_catpv(tmpsv, ",DELETE");
+ if (o->op_private & OPpTRANS_COMPLEMENT)
+ sv_catpv(tmpsv, ",COMPLEMENT");
+ }
+ else if (o->op_type == OP_REPEAT) {
+ if (o->op_private & OPpREPEAT_DOLIST)
+ sv_catpv(tmpsv, ",DOLIST");
+ }
+ else if (o->op_type == OP_ENTERSUB ||
+ o->op_type == OP_RV2SV ||
+ o->op_type == OP_RV2AV ||
+ o->op_type == OP_RV2HV ||
+ o->op_type == OP_RV2GV ||
+ o->op_type == OP_AELEM ||
+ o->op_type == OP_HELEM )
+ {
+ if (o->op_type == OP_ENTERSUB) {
+ if (o->op_private & OPpENTERSUB_AMPER)
+ sv_catpv(tmpsv, ",AMPER");
+ if (o->op_private & OPpENTERSUB_DB)
+ sv_catpv(tmpsv, ",DB");
+ }
+ switch (o->op_private & OPpDEREF) {
+ case OPpDEREF_SV:
+ sv_catpv(tmpsv, ",SV");
+ break;
+ case OPpDEREF_AV:
+ sv_catpv(tmpsv, ",AV");
+ break;
+ case OPpDEREF_HV:
+ sv_catpv(tmpsv, ",HV");
+ break;
+ }
+ if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
+ if (o->op_private & OPpLVAL_DEFER)
+ sv_catpv(tmpsv, ",LVAL_DEFER");
+ }
+ else {
+ if (o->op_private & HINT_STRICT_REFS)
+ sv_catpv(tmpsv, ",STRICT_REFS");
+ }
+ }
+ else if (o->op_type == OP_CONST) {
+ if (o->op_private & OPpCONST_BARE)
+ sv_catpv(tmpsv, ",BARE");
+ }
+ else if (o->op_type == OP_FLIP) {
+ if (o->op_private & OPpFLIP_LINENUM)
+ sv_catpv(tmpsv, ",LINENUM");
+ }
+ else if (o->op_type == OP_FLOP) {
+ if (o->op_private & OPpFLIP_LINENUM)
+ sv_catpv(tmpsv, ",LINENUM");
+ }
+ if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
+ sv_catpv(tmpsv, ",INTRO");
+ if (SvCUR(tmpsv))
+ dump("PRIVATE = (%s)\n", SvPVX(tmpsv) + 1);
+ SvREFCNT_dec(tmpsv);
+ }
+
+ switch (o->op_type) {
+ case OP_GVSV:
+ case OP_GV:
+ if (cGVOPo->op_gv) {
+ SV *tmpsv = NEWSV(0,0);
+ ENTER;
+ SAVEFREESV(tmpsv);
+ gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch);
+ dump("GV = %s\n", SvPV(tmpsv, PL_na));
+ LEAVE;
+ }
+ else
+ dump("GV = NULL\n");
+ break;
+ case OP_CONST:
+ dump("SV = %s\n", SvPEEK(cSVOPo->op_sv));
+ break;
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ if (cCOPo->cop_line)
+ dump("LINE = %d\n",cCOPo->cop_line);
+ if (cCOPo->cop_label)
+ dump("LABEL = \"%s\"\n",cCOPo->cop_label);
+ break;
+ case OP_ENTERLOOP:
+ dump("REDO ===> ");
+ if (cLOOPo->op_redoop)
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_redoop->op_seq);
+ else
+ PerlIO_printf(Perl_debug_log, "DONE\n");
+ dump("NEXT ===> ");
+ if (cLOOPo->op_nextop)
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_nextop->op_seq);
+ else
+ PerlIO_printf(Perl_debug_log, "DONE\n");
+ dump("LAST ===> ");
+ if (cLOOPo->op_lastop)
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_lastop->op_seq);
+ else
+ PerlIO_printf(Perl_debug_log, "DONE\n");
+ break;
+ case OP_COND_EXPR:
+ dump("TRUE ===> ");
+ if (cCONDOPo->op_true)
+ PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_true->op_seq);
+ else
+ PerlIO_printf(Perl_debug_log, "DONE\n");
+ dump("FALSE ===> ");
+ if (cCONDOPo->op_false)
+ PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_false->op_seq);
+ else
+ PerlIO_printf(Perl_debug_log, "DONE\n");
+ break;
+ case OP_MAPWHILE:
+ case OP_GREPWHILE:
+ case OP_OR:
+ case OP_AND:
+ dump("OTHER ===> ");
+ if (cLOGOPo->op_other)
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOGOPo->op_other->op_seq);
+ else
+ PerlIO_printf(Perl_debug_log, "DONE\n");
+ break;
+ case OP_PUSHRE:
+ case OP_MATCH:
+ case OP_QR:
+ case OP_SUBST:
+ dump_pm(cPMOPo);
+ break;
+ default:
+ break;
+ }
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+ dump_op(kid);
+ }
+ PL_dumplvl--;
+ dump("}\n");
+#endif /* DEBUGGING */
+}
+
+void
+dump_gv(GV *gv)
+{
+#ifdef DEBUGGING
+ SV *sv;
+
+ if (!gv) {
+ PerlIO_printf(Perl_debug_log, "{}\n");
+ return;
+ }
+ sv = sv_newmortal();
+ PL_dumplvl++;
+ PerlIO_printf(Perl_debug_log, "{\n");
+ gv_fullname3(sv, gv, Nullch);
+ dump("GV_NAME = %s", SvPVX(sv));
+ if (gv != GvEGV(gv)) {
+ gv_efullname3(sv, GvEGV(gv), Nullch);
+ dump("-> %s", SvPVX(sv));
+ }
+ dump("\n");
+ PL_dumplvl--;
+ dump("}\n");
+#endif /* DEBUGGING */
+}
+
+void
+dump_pm(PMOP *pm)
+{
+#ifdef DEBUGGING
+ char ch;
+
+ if (!pm) {
+ dump("{}\n");
+ return;
+ }
+ dump("{\n");
+ PL_dumplvl++;
+ if (pm->op_pmflags & PMf_ONCE)
+ ch = '?';
+ else
+ ch = '/';
+ if (pm->op_pmregexp)
+ dump("PMf_PRE %c%s%c%s\n",
+ ch, pm->op_pmregexp->precomp, ch,
+ (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
+ else
+ dump("PMf_PRE (RUNTIME)\n");
+ if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
+ dump("PMf_REPL = ");
+ dump_op(pm->op_pmreplroot);
+ }
+ if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) {
+ SV *tmpsv = newSVpv("", 0);
+ if (pm->op_pmdynflags & PMdf_USED)
+ sv_catpv(tmpsv, ",USED");
+ if (pm->op_pmdynflags & PMdf_TAINTED)
+ sv_catpv(tmpsv, ",TAINTED");
+ if (pm->op_pmflags & PMf_ONCE)
+ sv_catpv(tmpsv, ",ONCE");
+ if (pm->op_pmregexp && pm->op_pmregexp->check_substr
+ && !(pm->op_pmregexp->reganch & ROPT_NOSCAN))
+ sv_catpv(tmpsv, ",SCANFIRST");
+ if (pm->op_pmregexp && pm->op_pmregexp->check_substr
+ && pm->op_pmregexp->reganch & ROPT_CHECK_ALL)
+ sv_catpv(tmpsv, ",ALL");
+ if (pm->op_pmflags & PMf_SKIPWHITE)
+ sv_catpv(tmpsv, ",SKIPWHITE");
+ if (pm->op_pmflags & PMf_CONST)
+ sv_catpv(tmpsv, ",CONST");
+ if (pm->op_pmflags & PMf_KEEP)
+ sv_catpv(tmpsv, ",KEEP");
+ if (pm->op_pmflags & PMf_GLOBAL)
+ sv_catpv(tmpsv, ",GLOBAL");
+ if (pm->op_pmflags & PMf_CONTINUE)
+ sv_catpv(tmpsv, ",CONTINUE");
+ if (pm->op_pmflags & PMf_RETAINT)
+ sv_catpv(tmpsv, ",RETAINT");
+ if (pm->op_pmflags & PMf_EVAL)
+ sv_catpv(tmpsv, ",EVAL");
+ dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
+ SvREFCNT_dec(tmpsv);
+ }
+
+ PL_dumplvl--;
+ dump("}\n");
+#endif /* DEBUGGING */
+}
+
+
+STATIC void
+dump(char *pat,...)
+{
+#ifdef DEBUGGING
+ I32 i;
+ va_list args;
+
+ va_start(args, pat);
+ for (i = PL_dumplvl*4; i; i--)
+ (void)PerlIO_putc(Perl_debug_log,' ');
+ PerlIO_vprintf(Perl_debug_log,pat,args);
+ va_end(args);
+#endif /* DEBUGGING */
+}
diff --git a/contrib/perl5/ebcdic.c b/contrib/perl5/ebcdic.c
new file mode 100644
index 000000000000..890bd086d2b1
--- /dev/null
+++ b/contrib/perl5/ebcdic.c
@@ -0,0 +1,32 @@
+#include "EXTERN.h"
+#include "perl.h"
+
+/* in ASCII order, not that it matters */
+static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
+
+int
+ebcdic_control(int ch)
+{
+ if (ch > 'a') {
+ char *ctlp;
+
+ if (islower(ch))
+ ch = toupper(ch);
+
+ if ((ctlp = strchr(controllablechars, ch)) == 0) {
+ die("unrecognised control character '%c'\n", ch);
+ }
+
+ if (ctlp == controllablechars)
+ return('\177'); /* DEL */
+ else
+ return((unsigned char)(ctlp - controllablechars - 1));
+ } else { /* Want uncontrol */
+ if (ch == '\177' || ch == -1)
+ return('?');
+ else if (0 < ch && ch < (sizeof(controllablechars) - 1))
+ return(controllablechars[ch+1]);
+ else
+ die("invalid control request: '\\%03o'\n", ch & 0xFF);
+ }
+}
diff --git a/contrib/perl5/embed.h b/contrib/perl5/embed.h
new file mode 100644
index 000000000000..592f39b8c61b
--- /dev/null
+++ b/contrib/perl5/embed.h
@@ -0,0 +1,1088 @@
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by embed.pl from global.sym, intrpvar.h,
+ and thrdvar.h. Any changes made here will be lost!
+*/
+
+/* (Doing namespace management portably in C is really gross.) */
+
+/* EMBED has no run-time penalty, but helps keep the Perl namespace
+ from colliding with that used by other libraries pulled in
+ by extensions or by embedding perl. Allow a cc -DNO_EMBED
+ override, however, to keep binary compatability with previous
+ versions of perl.
+*/
+#ifndef NO_EMBED
+# define EMBED 1
+#endif
+
+/* Hide global symbols? */
+
+#ifdef EMBED
+
+#define AMG_names Perl_AMG_names
+#define Error Perl_Error
+#define Gv_AMupdate Perl_Gv_AMupdate
+#define abs_amg Perl_abs_amg
+#define add_amg Perl_add_amg
+#define add_ass_amg Perl_add_ass_amg
+#define additem Perl_additem
+#define amagic_call Perl_amagic_call
+#define append_elem Perl_append_elem
+#define append_list Perl_append_list
+#define apply Perl_apply
+#define assertref Perl_assertref
+#define atan2_amg Perl_atan2_amg
+#define av_clear Perl_av_clear
+#define av_extend Perl_av_extend
+#define av_fake Perl_av_fake
+#define av_fetch Perl_av_fetch
+#define av_fill Perl_av_fill
+#define av_len Perl_av_len
+#define av_make Perl_av_make
+#define av_pop Perl_av_pop
+#define av_push Perl_av_push
+#define av_reify Perl_av_reify
+#define av_shift Perl_av_shift
+#define av_store Perl_av_store
+#define av_undef Perl_av_undef
+#define av_unshift Perl_av_unshift
+#define avhv_exists_ent Perl_avhv_exists_ent
+#define avhv_fetch_ent Perl_avhv_fetch_ent
+#define avhv_iternext Perl_avhv_iternext
+#define avhv_iterval Perl_avhv_iterval
+#define avhv_keys Perl_avhv_keys
+#define band_amg Perl_band_amg
+#define bind_match Perl_bind_match
+#define block_end Perl_block_end
+#define block_gimme Perl_block_gimme
+#define block_start Perl_block_start
+#define block_type Perl_block_type
+#define bool__amg Perl_bool__amg
+#define boot_core_UNIVERSAL Perl_boot_core_UNIVERSAL
+#define bor_amg Perl_bor_amg
+#define bset_obj_store Perl_bset_obj_store
+#define bxor_amg Perl_bxor_amg
+#define byterun Perl_byterun
+#define call_list Perl_call_list
+#define cando Perl_cando
+#define cast_ulong Perl_cast_ulong
+#define check Perl_check
+#define check_uni Perl_check_uni
+#define checkcomma Perl_checkcomma
+#define ck_aelem Perl_ck_aelem
+#define ck_anoncode Perl_ck_anoncode
+#define ck_bitop Perl_ck_bitop
+#define ck_concat Perl_ck_concat
+#define ck_delete Perl_ck_delete
+#define ck_eof Perl_ck_eof
+#define ck_eval Perl_ck_eval
+#define ck_exec Perl_ck_exec
+#define ck_exists Perl_ck_exists
+#define ck_ftst Perl_ck_ftst
+#define ck_fun Perl_ck_fun
+#define ck_fun_locale Perl_ck_fun_locale
+#define ck_glob Perl_ck_glob
+#define ck_grep Perl_ck_grep
+#define ck_gvconst Perl_ck_gvconst
+#define ck_index Perl_ck_index
+#define ck_lengthconst Perl_ck_lengthconst
+#define ck_lfun Perl_ck_lfun
+#define ck_listiob Perl_ck_listiob
+#define ck_match Perl_ck_match
+#define ck_null Perl_ck_null
+#define ck_repeat Perl_ck_repeat
+#define ck_require Perl_ck_require
+#define ck_retarget Perl_ck_retarget
+#define ck_rfun Perl_ck_rfun
+#define ck_rvconst Perl_ck_rvconst
+#define ck_scmp Perl_ck_scmp
+#define ck_select Perl_ck_select
+#define ck_shift Perl_ck_shift
+#define ck_sort Perl_ck_sort
+#define ck_spair Perl_ck_spair
+#define ck_split Perl_ck_split
+#define ck_subr Perl_ck_subr
+#define ck_svconst Perl_ck_svconst
+#define ck_trunc Perl_ck_trunc
+#define compl_amg Perl_compl_amg
+#define concat_amg Perl_concat_amg
+#define concat_ass_amg Perl_concat_ass_amg
+#define condpair_magic Perl_condpair_magic
+#define convert Perl_convert
+#define cos_amg Perl_cos_amg
+#define croak Perl_croak
+#define cv_ckproto Perl_cv_ckproto
+#define cv_clone Perl_cv_clone
+#define cv_const_sv Perl_cv_const_sv
+#define cv_undef Perl_cv_undef
+#define cx_dump Perl_cx_dump
+#define cxinc Perl_cxinc
+#define dc Perl_dc
+#define deb Perl_deb
+#define deb_growlevel Perl_deb_growlevel
+#define debop Perl_debop
+#define debprofdump Perl_debprofdump
+#define debstack Perl_debstack
+#define debstackptrs Perl_debstackptrs
+#define dec_amg Perl_dec_amg
+#define delimcpy Perl_delimcpy
+#define deprecate Perl_deprecate
+#define di Perl_di
+#define die Perl_die
+#define die_where Perl_die_where
+#define div_amg Perl_div_amg
+#define div_ass_amg Perl_div_ass_amg
+#define do_aexec Perl_do_aexec
+#define do_binmode Perl_do_binmode
+#define do_chomp Perl_do_chomp
+#define do_chop Perl_do_chop
+#define do_close Perl_do_close
+#define do_eof Perl_do_eof
+#define do_exec Perl_do_exec
+#define do_execfree Perl_do_execfree
+#define do_ipcctl Perl_do_ipcctl
+#define do_ipcget Perl_do_ipcget
+#define do_join Perl_do_join
+#define do_kv Perl_do_kv
+#define do_msgrcv Perl_do_msgrcv
+#define do_msgsnd Perl_do_msgsnd
+#define do_open Perl_do_open
+#define do_pipe Perl_do_pipe
+#define do_print Perl_do_print
+#define do_readline Perl_do_readline
+#define do_seek Perl_do_seek
+#define do_semop Perl_do_semop
+#define do_shmio Perl_do_shmio
+#define do_sprintf Perl_do_sprintf
+#define do_sysseek Perl_do_sysseek
+#define do_tell Perl_do_tell
+#define do_trans Perl_do_trans
+#define do_vecset Perl_do_vecset
+#define do_vop Perl_do_vop
+#define dofindlabel Perl_dofindlabel
+#define dopoptoeval Perl_dopoptoeval
+#define dounwind Perl_dounwind
+#define dowantarray Perl_dowantarray
+#define ds Perl_ds
+#define dump_all Perl_dump_all
+#define dump_eval Perl_dump_eval
+#define dump_fds Perl_dump_fds
+#define dump_form Perl_dump_form
+#define dump_gv Perl_dump_gv
+#define dump_mstats Perl_dump_mstats
+#define dump_op Perl_dump_op
+#define dump_packsubs Perl_dump_packsubs
+#define dump_pm Perl_dump_pm
+#define dump_sub Perl_dump_sub
+#define eq_amg Perl_eq_amg
+#define exp_amg Perl_exp_amg
+#define expectterm Perl_expectterm
+#define fallback_amg Perl_fallback_amg
+#define fbm_compile Perl_fbm_compile
+#define fbm_instr Perl_fbm_instr
+#define fetch_gv Perl_fetch_gv
+#define fetch_io Perl_fetch_io
+#define filter_add Perl_filter_add
+#define filter_del Perl_filter_del
+#define filter_read Perl_filter_read
+#define find_script Perl_find_script
+#define find_threadsv Perl_find_threadsv
+#define fold Perl_fold
+#define fold_constants Perl_fold_constants
+#define fold_locale Perl_fold_locale
+#define force_ident Perl_force_ident
+#define force_list Perl_force_list
+#define force_next Perl_force_next
+#define force_word Perl_force_word
+#define form Perl_form
+#define free_tmps Perl_free_tmps
+#define freq Perl_freq
+#define ge_amg Perl_ge_amg
+#define gen_constant_list Perl_gen_constant_list
+#define get_no_modify Perl_get_no_modify
+#define get_op_descs Perl_get_op_descs
+#define get_op_names Perl_get_op_names
+#define get_opargs Perl_get_opargs
+#define get_specialsv_list Perl_get_specialsv_list
+#define gp_free Perl_gp_free
+#define gp_ref Perl_gp_ref
+#define gt_amg Perl_gt_amg
+#define gv_AVadd Perl_gv_AVadd
+#define gv_HVadd Perl_gv_HVadd
+#define gv_IOadd Perl_gv_IOadd
+#define gv_autoload4 Perl_gv_autoload4
+#define gv_check Perl_gv_check
+#define gv_efullname Perl_gv_efullname
+#define gv_efullname3 Perl_gv_efullname3
+#define gv_fetchfile Perl_gv_fetchfile
+#define gv_fetchmeth Perl_gv_fetchmeth
+#define gv_fetchmethod Perl_gv_fetchmethod
+#define gv_fetchmethod_autoload Perl_gv_fetchmethod_autoload
+#define gv_fetchpv Perl_gv_fetchpv
+#define gv_fullname Perl_gv_fullname
+#define gv_fullname3 Perl_gv_fullname3
+#define gv_init Perl_gv_init
+#define gv_stashpv Perl_gv_stashpv
+#define gv_stashpvn Perl_gv_stashpvn
+#define gv_stashsv Perl_gv_stashsv
+#define hv_clear Perl_hv_clear
+#define hv_delayfree_ent Perl_hv_delayfree_ent
+#define hv_delete Perl_hv_delete
+#define hv_delete_ent Perl_hv_delete_ent
+#define hv_exists Perl_hv_exists
+#define hv_exists_ent Perl_hv_exists_ent
+#define hv_fetch Perl_hv_fetch
+#define hv_fetch_ent Perl_hv_fetch_ent
+#define hv_free_ent Perl_hv_free_ent
+#define hv_iterinit Perl_hv_iterinit
+#define hv_iterkey Perl_hv_iterkey
+#define hv_iterkeysv Perl_hv_iterkeysv
+#define hv_iternext Perl_hv_iternext
+#define hv_iternextsv Perl_hv_iternextsv
+#define hv_iterval Perl_hv_iterval
+#define hv_ksplit Perl_hv_ksplit
+#define hv_magic Perl_hv_magic
+#define hv_stashpv Perl_hv_stashpv
+#define hv_store Perl_hv_store
+#define hv_store_ent Perl_hv_store_ent
+#define hv_undef Perl_hv_undef
+#define ibcmp Perl_ibcmp
+#define ibcmp_locale Perl_ibcmp_locale
+#define inc_amg Perl_inc_amg
+#define ingroup Perl_ingroup
+#define init_stacks Perl_init_stacks
+#define init_thread_intern Perl_init_thread_intern
+#define instr Perl_instr
+#define intro_my Perl_intro_my
+#define intuit_more Perl_intuit_more
+#define invert Perl_invert
+#define io_close Perl_io_close
+#define jmaybe Perl_jmaybe
+#define keyword Perl_keyword
+#define know_next Perl_know_next
+#define le_amg Perl_le_amg
+#define leave_scope Perl_leave_scope
+#define lex_end Perl_lex_end
+#define lex_start Perl_lex_start
+#define linklist Perl_linklist
+#define list Perl_list
+#define listkids Perl_listkids
+#define localize Perl_localize
+#define log_amg Perl_log_amg
+#define looks_like_number Perl_looks_like_number
+#define lshift_amg Perl_lshift_amg
+#define lshift_ass_amg Perl_lshift_ass_amg
+#define lt_amg Perl_lt_amg
+#define magic_clear_all_env Perl_magic_clear_all_env
+#define magic_clearenv Perl_magic_clearenv
+#define magic_clearpack Perl_magic_clearpack
+#define magic_clearsig Perl_magic_clearsig
+#define magic_existspack Perl_magic_existspack
+#define magic_freeregexp Perl_magic_freeregexp
+#define magic_get Perl_magic_get
+#define magic_getarylen Perl_magic_getarylen
+#define magic_getdefelem Perl_magic_getdefelem
+#define magic_getglob Perl_magic_getglob
+#define magic_getnkeys Perl_magic_getnkeys
+#define magic_getpack Perl_magic_getpack
+#define magic_getpos Perl_magic_getpos
+#define magic_getsig Perl_magic_getsig
+#define magic_getsubstr Perl_magic_getsubstr
+#define magic_gettaint Perl_magic_gettaint
+#define magic_getuvar Perl_magic_getuvar
+#define magic_getvec Perl_magic_getvec
+#define magic_len Perl_magic_len
+#define magic_mutexfree Perl_magic_mutexfree
+#define magic_nextpack Perl_magic_nextpack
+#define magic_set Perl_magic_set
+#define magic_set_all_env Perl_magic_set_all_env
+#define magic_setamagic Perl_magic_setamagic
+#define magic_setarylen Perl_magic_setarylen
+#define magic_setbm Perl_magic_setbm
+#define magic_setcollxfrm Perl_magic_setcollxfrm
+#define magic_setdbline Perl_magic_setdbline
+#define magic_setdefelem Perl_magic_setdefelem
+#define magic_setenv Perl_magic_setenv
+#define magic_setfm Perl_magic_setfm
+#define magic_setglob Perl_magic_setglob
+#define magic_setisa Perl_magic_setisa
+#define magic_setmglob Perl_magic_setmglob
+#define magic_setnkeys Perl_magic_setnkeys
+#define magic_setpack Perl_magic_setpack
+#define magic_setpos Perl_magic_setpos
+#define magic_setsig Perl_magic_setsig
+#define magic_setsubstr Perl_magic_setsubstr
+#define magic_settaint Perl_magic_settaint
+#define magic_setuvar Perl_magic_setuvar
+#define magic_setvec Perl_magic_setvec
+#define magic_sizepack Perl_magic_sizepack
+#define magic_wipepack Perl_magic_wipepack
+#define magicname Perl_magicname
+#define malloced_size Perl_malloced_size
+#define markstack_grow Perl_markstack_grow
+#define mem_collxfrm Perl_mem_collxfrm
+#define mess Perl_mess
+#define mg_clear Perl_mg_clear
+#define mg_copy Perl_mg_copy
+#define mg_find Perl_mg_find
+#define mg_free Perl_mg_free
+#define mg_get Perl_mg_get
+#define mg_length Perl_mg_length
+#define mg_magical Perl_mg_magical
+#define mg_set Perl_mg_set
+#define mg_size Perl_mg_size
+#define mod Perl_mod
+#define mod_amg Perl_mod_amg
+#define mod_ass_amg Perl_mod_ass_amg
+#define modkids Perl_modkids
+#define moreswitches Perl_moreswitches
+#define mstats Perl_mstats
+#define mult_amg Perl_mult_amg
+#define mult_ass_amg Perl_mult_ass_amg
+#define my Perl_my
+#define my_bcopy Perl_my_bcopy
+#define my_bzero Perl_my_bzero
+#define my_chsize Perl_my_chsize
+#define my_exit Perl_my_exit
+#define my_failure_exit Perl_my_failure_exit
+#define my_htonl Perl_my_htonl
+#define my_lstat Perl_my_lstat
+#define my_memcmp Perl_my_memcmp
+#define my_memset Perl_my_memset
+#define my_ntohl Perl_my_ntohl
+#define my_pclose Perl_my_pclose
+#define my_popen Perl_my_popen
+#define my_setenv Perl_my_setenv
+#define my_stat Perl_my_stat
+#define my_swap Perl_my_swap
+#define my_unexec Perl_my_unexec
+#define ncmp_amg Perl_ncmp_amg
+#define ne_amg Perl_ne_amg
+#define neg_amg Perl_neg_amg
+#define newANONHASH Perl_newANONHASH
+#define newANONLIST Perl_newANONLIST
+#define newANONSUB Perl_newANONSUB
+#define newASSIGNOP Perl_newASSIGNOP
+#define newAV Perl_newAV
+#define newAVREF Perl_newAVREF
+#define newBINOP Perl_newBINOP
+#define newCONDOP Perl_newCONDOP
+#define newCONSTSUB Perl_newCONSTSUB
+#define newCVREF Perl_newCVREF
+#define newFORM Perl_newFORM
+#define newFOROP Perl_newFOROP
+#define newGVOP Perl_newGVOP
+#define newGVREF Perl_newGVREF
+#define newGVgen Perl_newGVgen
+#define newHV Perl_newHV
+#define newHVREF Perl_newHVREF
+#define newHVhv Perl_newHVhv
+#define newIO Perl_newIO
+#define newLISTOP Perl_newLISTOP
+#define newLOGOP Perl_newLOGOP
+#define newLOOPEX Perl_newLOOPEX
+#define newLOOPOP Perl_newLOOPOP
+#define newNULLLIST Perl_newNULLLIST
+#define newOP Perl_newOP
+#define newPMOP Perl_newPMOP
+#define newPROG Perl_newPROG
+#define newPVOP Perl_newPVOP
+#define newRANGE Perl_newRANGE
+#define newRV Perl_newRV
+#define newRV_noinc Perl_newRV_noinc
+#define newSLICEOP Perl_newSLICEOP
+#define newSTATEOP Perl_newSTATEOP
+#define newSUB Perl_newSUB
+#define newSV Perl_newSV
+#define newSVOP Perl_newSVOP
+#define newSVREF Perl_newSVREF
+#define newSViv Perl_newSViv
+#define newSVnv Perl_newSVnv
+#define newSVpv Perl_newSVpv
+#define newSVpvf Perl_newSVpvf
+#define newSVpvn Perl_newSVpvn
+#define newSVrv Perl_newSVrv
+#define newSVsv Perl_newSVsv
+#define newUNOP Perl_newUNOP
+#define newWHILEOP Perl_newWHILEOP
+#define newXS Perl_newXS
+#define newXSUB Perl_newXSUB
+#define new_stackinfo Perl_new_stackinfo
+#define new_struct_thread Perl_new_struct_thread
+#define nextargv Perl_nextargv
+#define ninstr Perl_ninstr
+#define no_aelem Perl_no_aelem
+#define no_dir_func Perl_no_dir_func
+#define no_fh_allowed Perl_no_fh_allowed
+#define no_func Perl_no_func
+#define no_helem Perl_no_helem
+#define no_mem Perl_no_mem
+#define no_modify Perl_no_modify
+#define no_myglob Perl_no_myglob
+#define no_op Perl_no_op
+#define no_security Perl_no_security
+#define no_sock_func Perl_no_sock_func
+#define no_symref Perl_no_symref
+#define no_usym Perl_no_usym
+#define no_wrongref Perl_no_wrongref
+#define nointrp Perl_nointrp
+#define nomem Perl_nomem
+#define nomethod_amg Perl_nomethod_amg
+#define not_amg Perl_not_amg
+#define numer_amg Perl_numer_amg
+#define oopsAV Perl_oopsAV
+#define oopsCV Perl_oopsCV
+#define oopsHV Perl_oopsHV
+#define op_const_sv Perl_op_const_sv
+#define op_desc Perl_op_desc
+#define op_free Perl_op_free
+#define op_name Perl_op_name
+#define opargs Perl_opargs
+#define package Perl_package
+#define pad_alloc Perl_pad_alloc
+#define pad_allocmy Perl_pad_allocmy
+#define pad_findmy Perl_pad_findmy
+#define pad_free Perl_pad_free
+#define pad_leavemy Perl_pad_leavemy
+#define pad_reset Perl_pad_reset
+#define pad_sv Perl_pad_sv
+#define pad_swipe Perl_pad_swipe
+#define peep Perl_peep
+#define pidgone Perl_pidgone
+#define pmflag Perl_pmflag
+#define pmruntime Perl_pmruntime
+#define pmtrans Perl_pmtrans
+#define pop_return Perl_pop_return
+#define pop_scope Perl_pop_scope
+#define pow_amg Perl_pow_amg
+#define pow_ass_amg Perl_pow_ass_amg
+#define pp_aassign Perl_pp_aassign
+#define pp_abs Perl_pp_abs
+#define pp_accept Perl_pp_accept
+#define pp_add Perl_pp_add
+#define pp_aelem Perl_pp_aelem
+#define pp_aelemfast Perl_pp_aelemfast
+#define pp_alarm Perl_pp_alarm
+#define pp_and Perl_pp_and
+#define pp_andassign Perl_pp_andassign
+#define pp_anoncode Perl_pp_anoncode
+#define pp_anonhash Perl_pp_anonhash
+#define pp_anonlist Perl_pp_anonlist
+#define pp_aslice Perl_pp_aslice
+#define pp_atan2 Perl_pp_atan2
+#define pp_av2arylen Perl_pp_av2arylen
+#define pp_backtick Perl_pp_backtick
+#define pp_bind Perl_pp_bind
+#define pp_binmode Perl_pp_binmode
+#define pp_bit_and Perl_pp_bit_and
+#define pp_bit_or Perl_pp_bit_or
+#define pp_bit_xor Perl_pp_bit_xor
+#define pp_bless Perl_pp_bless
+#define pp_caller Perl_pp_caller
+#define pp_chdir Perl_pp_chdir
+#define pp_chmod Perl_pp_chmod
+#define pp_chomp Perl_pp_chomp
+#define pp_chop Perl_pp_chop
+#define pp_chown Perl_pp_chown
+#define pp_chr Perl_pp_chr
+#define pp_chroot Perl_pp_chroot
+#define pp_close Perl_pp_close
+#define pp_closedir Perl_pp_closedir
+#define pp_complement Perl_pp_complement
+#define pp_concat Perl_pp_concat
+#define pp_cond_expr Perl_pp_cond_expr
+#define pp_connect Perl_pp_connect
+#define pp_const Perl_pp_const
+#define pp_cos Perl_pp_cos
+#define pp_crypt Perl_pp_crypt
+#define pp_cswitch Perl_pp_cswitch
+#define pp_dbmclose Perl_pp_dbmclose
+#define pp_dbmopen Perl_pp_dbmopen
+#define pp_dbstate Perl_pp_dbstate
+#define pp_defined Perl_pp_defined
+#define pp_delete Perl_pp_delete
+#define pp_die Perl_pp_die
+#define pp_divide Perl_pp_divide
+#define pp_dofile Perl_pp_dofile
+#define pp_dump Perl_pp_dump
+#define pp_each Perl_pp_each
+#define pp_egrent Perl_pp_egrent
+#define pp_ehostent Perl_pp_ehostent
+#define pp_enetent Perl_pp_enetent
+#define pp_enter Perl_pp_enter
+#define pp_entereval Perl_pp_entereval
+#define pp_enteriter Perl_pp_enteriter
+#define pp_enterloop Perl_pp_enterloop
+#define pp_entersub Perl_pp_entersub
+#define pp_entersubr Perl_pp_entersubr
+#define pp_entertry Perl_pp_entertry
+#define pp_enterwrite Perl_pp_enterwrite
+#define pp_eof Perl_pp_eof
+#define pp_eprotoent Perl_pp_eprotoent
+#define pp_epwent Perl_pp_epwent
+#define pp_eq Perl_pp_eq
+#define pp_eservent Perl_pp_eservent
+#define pp_evalonce Perl_pp_evalonce
+#define pp_exec Perl_pp_exec
+#define pp_exists Perl_pp_exists
+#define pp_exit Perl_pp_exit
+#define pp_exp Perl_pp_exp
+#define pp_fcntl Perl_pp_fcntl
+#define pp_fileno Perl_pp_fileno
+#define pp_flip Perl_pp_flip
+#define pp_flock Perl_pp_flock
+#define pp_flop Perl_pp_flop
+#define pp_fork Perl_pp_fork
+#define pp_formline Perl_pp_formline
+#define pp_ftatime Perl_pp_ftatime
+#define pp_ftbinary Perl_pp_ftbinary
+#define pp_ftblk Perl_pp_ftblk
+#define pp_ftchr Perl_pp_ftchr
+#define pp_ftctime Perl_pp_ftctime
+#define pp_ftdir Perl_pp_ftdir
+#define pp_fteexec Perl_pp_fteexec
+#define pp_fteowned Perl_pp_fteowned
+#define pp_fteread Perl_pp_fteread
+#define pp_ftewrite Perl_pp_ftewrite
+#define pp_ftfile Perl_pp_ftfile
+#define pp_ftis Perl_pp_ftis
+#define pp_ftlink Perl_pp_ftlink
+#define pp_ftmtime Perl_pp_ftmtime
+#define pp_ftpipe Perl_pp_ftpipe
+#define pp_ftrexec Perl_pp_ftrexec
+#define pp_ftrowned Perl_pp_ftrowned
+#define pp_ftrread Perl_pp_ftrread
+#define pp_ftrwrite Perl_pp_ftrwrite
+#define pp_ftsgid Perl_pp_ftsgid
+#define pp_ftsize Perl_pp_ftsize
+#define pp_ftsock Perl_pp_ftsock
+#define pp_ftsuid Perl_pp_ftsuid
+#define pp_ftsvtx Perl_pp_ftsvtx
+#define pp_fttext Perl_pp_fttext
+#define pp_fttty Perl_pp_fttty
+#define pp_ftzero Perl_pp_ftzero
+#define pp_ge Perl_pp_ge
+#define pp_gelem Perl_pp_gelem
+#define pp_getc Perl_pp_getc
+#define pp_getlogin Perl_pp_getlogin
+#define pp_getpeername Perl_pp_getpeername
+#define pp_getpgrp Perl_pp_getpgrp
+#define pp_getppid Perl_pp_getppid
+#define pp_getpriority Perl_pp_getpriority
+#define pp_getsockname Perl_pp_getsockname
+#define pp_ggrent Perl_pp_ggrent
+#define pp_ggrgid Perl_pp_ggrgid
+#define pp_ggrnam Perl_pp_ggrnam
+#define pp_ghbyaddr Perl_pp_ghbyaddr
+#define pp_ghbyname Perl_pp_ghbyname
+#define pp_ghostent Perl_pp_ghostent
+#define pp_glob Perl_pp_glob
+#define pp_gmtime Perl_pp_gmtime
+#define pp_gnbyaddr Perl_pp_gnbyaddr
+#define pp_gnbyname Perl_pp_gnbyname
+#define pp_gnetent Perl_pp_gnetent
+#define pp_goto Perl_pp_goto
+#define pp_gpbyname Perl_pp_gpbyname
+#define pp_gpbynumber Perl_pp_gpbynumber
+#define pp_gprotoent Perl_pp_gprotoent
+#define pp_gpwent Perl_pp_gpwent
+#define pp_gpwnam Perl_pp_gpwnam
+#define pp_gpwuid Perl_pp_gpwuid
+#define pp_grepstart Perl_pp_grepstart
+#define pp_grepwhile Perl_pp_grepwhile
+#define pp_gsbyname Perl_pp_gsbyname
+#define pp_gsbyport Perl_pp_gsbyport
+#define pp_gservent Perl_pp_gservent
+#define pp_gsockopt Perl_pp_gsockopt
+#define pp_gt Perl_pp_gt
+#define pp_gv Perl_pp_gv
+#define pp_gvsv Perl_pp_gvsv
+#define pp_helem Perl_pp_helem
+#define pp_hex Perl_pp_hex
+#define pp_hslice Perl_pp_hslice
+#define pp_i_add Perl_pp_i_add
+#define pp_i_divide Perl_pp_i_divide
+#define pp_i_eq Perl_pp_i_eq
+#define pp_i_ge Perl_pp_i_ge
+#define pp_i_gt Perl_pp_i_gt
+#define pp_i_le Perl_pp_i_le
+#define pp_i_lt Perl_pp_i_lt
+#define pp_i_modulo Perl_pp_i_modulo
+#define pp_i_multiply Perl_pp_i_multiply
+#define pp_i_ncmp Perl_pp_i_ncmp
+#define pp_i_ne Perl_pp_i_ne
+#define pp_i_negate Perl_pp_i_negate
+#define pp_i_subtract Perl_pp_i_subtract
+#define pp_index Perl_pp_index
+#define pp_int Perl_pp_int
+#define pp_interp Perl_pp_interp
+#define pp_ioctl Perl_pp_ioctl
+#define pp_iter Perl_pp_iter
+#define pp_join Perl_pp_join
+#define pp_keys Perl_pp_keys
+#define pp_kill Perl_pp_kill
+#define pp_last Perl_pp_last
+#define pp_lc Perl_pp_lc
+#define pp_lcfirst Perl_pp_lcfirst
+#define pp_le Perl_pp_le
+#define pp_leave Perl_pp_leave
+#define pp_leaveeval Perl_pp_leaveeval
+#define pp_leaveloop Perl_pp_leaveloop
+#define pp_leavesub Perl_pp_leavesub
+#define pp_leavetry Perl_pp_leavetry
+#define pp_leavewrite Perl_pp_leavewrite
+#define pp_left_shift Perl_pp_left_shift
+#define pp_length Perl_pp_length
+#define pp_lineseq Perl_pp_lineseq
+#define pp_link Perl_pp_link
+#define pp_list Perl_pp_list
+#define pp_listen Perl_pp_listen
+#define pp_localtime Perl_pp_localtime
+#define pp_lock Perl_pp_lock
+#define pp_log Perl_pp_log
+#define pp_lslice Perl_pp_lslice
+#define pp_lstat Perl_pp_lstat
+#define pp_lt Perl_pp_lt
+#define pp_map Perl_pp_map
+#define pp_mapstart Perl_pp_mapstart
+#define pp_mapwhile Perl_pp_mapwhile
+#define pp_match Perl_pp_match
+#define pp_method Perl_pp_method
+#define pp_mkdir Perl_pp_mkdir
+#define pp_modulo Perl_pp_modulo
+#define pp_msgctl Perl_pp_msgctl
+#define pp_msgget Perl_pp_msgget
+#define pp_msgrcv Perl_pp_msgrcv
+#define pp_msgsnd Perl_pp_msgsnd
+#define pp_multiply Perl_pp_multiply
+#define pp_ncmp Perl_pp_ncmp
+#define pp_ne Perl_pp_ne
+#define pp_negate Perl_pp_negate
+#define pp_next Perl_pp_next
+#define pp_nextstate Perl_pp_nextstate
+#define pp_not Perl_pp_not
+#define pp_nswitch Perl_pp_nswitch
+#define pp_null Perl_pp_null
+#define pp_oct Perl_pp_oct
+#define pp_open Perl_pp_open
+#define pp_open_dir Perl_pp_open_dir
+#define pp_or Perl_pp_or
+#define pp_orassign Perl_pp_orassign
+#define pp_ord Perl_pp_ord
+#define pp_pack Perl_pp_pack
+#define pp_padany Perl_pp_padany
+#define pp_padav Perl_pp_padav
+#define pp_padhv Perl_pp_padhv
+#define pp_padsv Perl_pp_padsv
+#define pp_pipe_op Perl_pp_pipe_op
+#define pp_pop Perl_pp_pop
+#define pp_pos Perl_pp_pos
+#define pp_postdec Perl_pp_postdec
+#define pp_postinc Perl_pp_postinc
+#define pp_pow Perl_pp_pow
+#define pp_predec Perl_pp_predec
+#define pp_preinc Perl_pp_preinc
+#define pp_print Perl_pp_print
+#define pp_prototype Perl_pp_prototype
+#define pp_prtf Perl_pp_prtf
+#define pp_push Perl_pp_push
+#define pp_pushmark Perl_pp_pushmark
+#define pp_pushre Perl_pp_pushre
+#define pp_qr Perl_pp_qr
+#define pp_quotemeta Perl_pp_quotemeta
+#define pp_rand Perl_pp_rand
+#define pp_range Perl_pp_range
+#define pp_rcatline Perl_pp_rcatline
+#define pp_read Perl_pp_read
+#define pp_readdir Perl_pp_readdir
+#define pp_readline Perl_pp_readline
+#define pp_readlink Perl_pp_readlink
+#define pp_recv Perl_pp_recv
+#define pp_redo Perl_pp_redo
+#define pp_ref Perl_pp_ref
+#define pp_refgen Perl_pp_refgen
+#define pp_regcmaybe Perl_pp_regcmaybe
+#define pp_regcomp Perl_pp_regcomp
+#define pp_regcreset Perl_pp_regcreset
+#define pp_rename Perl_pp_rename
+#define pp_repeat Perl_pp_repeat
+#define pp_require Perl_pp_require
+#define pp_reset Perl_pp_reset
+#define pp_return Perl_pp_return
+#define pp_reverse Perl_pp_reverse
+#define pp_rewinddir Perl_pp_rewinddir
+#define pp_right_shift Perl_pp_right_shift
+#define pp_rindex Perl_pp_rindex
+#define pp_rmdir Perl_pp_rmdir
+#define pp_rv2av Perl_pp_rv2av
+#define pp_rv2cv Perl_pp_rv2cv
+#define pp_rv2gv Perl_pp_rv2gv
+#define pp_rv2hv Perl_pp_rv2hv
+#define pp_rv2sv Perl_pp_rv2sv
+#define pp_sassign Perl_pp_sassign
+#define pp_scalar Perl_pp_scalar
+#define pp_schomp Perl_pp_schomp
+#define pp_schop Perl_pp_schop
+#define pp_scmp Perl_pp_scmp
+#define pp_scope Perl_pp_scope
+#define pp_seek Perl_pp_seek
+#define pp_seekdir Perl_pp_seekdir
+#define pp_select Perl_pp_select
+#define pp_semctl Perl_pp_semctl
+#define pp_semget Perl_pp_semget
+#define pp_semop Perl_pp_semop
+#define pp_send Perl_pp_send
+#define pp_seq Perl_pp_seq
+#define pp_setpgrp Perl_pp_setpgrp
+#define pp_setpriority Perl_pp_setpriority
+#define pp_sge Perl_pp_sge
+#define pp_sgrent Perl_pp_sgrent
+#define pp_sgt Perl_pp_sgt
+#define pp_shift Perl_pp_shift
+#define pp_shmctl Perl_pp_shmctl
+#define pp_shmget Perl_pp_shmget
+#define pp_shmread Perl_pp_shmread
+#define pp_shmwrite Perl_pp_shmwrite
+#define pp_shostent Perl_pp_shostent
+#define pp_shutdown Perl_pp_shutdown
+#define pp_sin Perl_pp_sin
+#define pp_sle Perl_pp_sle
+#define pp_sleep Perl_pp_sleep
+#define pp_slt Perl_pp_slt
+#define pp_sne Perl_pp_sne
+#define pp_snetent Perl_pp_snetent
+#define pp_socket Perl_pp_socket
+#define pp_sockpair Perl_pp_sockpair
+#define pp_sort Perl_pp_sort
+#define pp_splice Perl_pp_splice
+#define pp_split Perl_pp_split
+#define pp_sprintf Perl_pp_sprintf
+#define pp_sprotoent Perl_pp_sprotoent
+#define pp_spwent Perl_pp_spwent
+#define pp_sqrt Perl_pp_sqrt
+#define pp_srand Perl_pp_srand
+#define pp_srefgen Perl_pp_srefgen
+#define pp_sselect Perl_pp_sselect
+#define pp_sservent Perl_pp_sservent
+#define pp_ssockopt Perl_pp_ssockopt
+#define pp_stat Perl_pp_stat
+#define pp_stringify Perl_pp_stringify
+#define pp_stub Perl_pp_stub
+#define pp_study Perl_pp_study
+#define pp_subst Perl_pp_subst
+#define pp_substcont Perl_pp_substcont
+#define pp_substr Perl_pp_substr
+#define pp_subtract Perl_pp_subtract
+#define pp_symlink Perl_pp_symlink
+#define pp_syscall Perl_pp_syscall
+#define pp_sysopen Perl_pp_sysopen
+#define pp_sysread Perl_pp_sysread
+#define pp_sysseek Perl_pp_sysseek
+#define pp_system Perl_pp_system
+#define pp_syswrite Perl_pp_syswrite
+#define pp_tell Perl_pp_tell
+#define pp_telldir Perl_pp_telldir
+#define pp_threadsv Perl_pp_threadsv
+#define pp_tie Perl_pp_tie
+#define pp_tied Perl_pp_tied
+#define pp_time Perl_pp_time
+#define pp_tms Perl_pp_tms
+#define pp_trans Perl_pp_trans
+#define pp_truncate Perl_pp_truncate
+#define pp_uc Perl_pp_uc
+#define pp_ucfirst Perl_pp_ucfirst
+#define pp_umask Perl_pp_umask
+#define pp_undef Perl_pp_undef
+#define pp_unlink Perl_pp_unlink
+#define pp_unpack Perl_pp_unpack
+#define pp_unshift Perl_pp_unshift
+#define pp_unstack Perl_pp_unstack
+#define pp_untie Perl_pp_untie
+#define pp_utime Perl_pp_utime
+#define pp_values Perl_pp_values
+#define pp_vec Perl_pp_vec
+#define pp_wait Perl_pp_wait
+#define pp_waitpid Perl_pp_waitpid
+#define pp_wantarray Perl_pp_wantarray
+#define pp_warn Perl_pp_warn
+#define pp_xor Perl_pp_xor
+#define ppaddr Perl_ppaddr
+#define pregcomp Perl_pregcomp
+#define pregexec Perl_pregexec
+#define pregfree Perl_pregfree
+#define prepend_elem Perl_prepend_elem
+#define psig_name Perl_psig_name
+#define psig_ptr Perl_psig_ptr
+#define push_return Perl_push_return
+#define push_scope Perl_push_scope
+#define q Perl_q
+#define reall_srchlen Perl_reall_srchlen
+#define ref Perl_ref
+#define refkids Perl_refkids
+#define regdump Perl_regdump
+#define regexec_flags Perl_regexec_flags
+#define regkind Perl_regkind
+#define regnext Perl_regnext
+#define regprop Perl_regprop
+#define repeat_amg Perl_repeat_amg
+#define repeat_ass_amg Perl_repeat_ass_amg
+#define repeatcpy Perl_repeatcpy
+#define rninstr Perl_rninstr
+#define rshift_amg Perl_rshift_amg
+#define rshift_ass_amg Perl_rshift_ass_amg
+#define rsignal Perl_rsignal
+#define rsignal_restore Perl_rsignal_restore
+#define rsignal_save Perl_rsignal_save
+#define rsignal_state Perl_rsignal_state
+#define runops_debug Perl_runops_debug
+#define runops_standard Perl_runops_standard
+#define rxres_free Perl_rxres_free
+#define rxres_restore Perl_rxres_restore
+#define rxres_save Perl_rxres_save
+#define safecalloc Perl_safecalloc
+#define safefree Perl_safefree
+#define safemalloc Perl_safemalloc
+#define saferealloc Perl_saferealloc
+#define safexcalloc Perl_safexcalloc
+#define safexfree Perl_safexfree
+#define safexmalloc Perl_safexmalloc
+#define safexrealloc Perl_safexrealloc
+#define same_dirent Perl_same_dirent
+#define save_I16 Perl_save_I16
+#define save_I32 Perl_save_I32
+#define save_aelem Perl_save_aelem
+#define save_aptr Perl_save_aptr
+#define save_ary Perl_save_ary
+#define save_clearsv Perl_save_clearsv
+#define save_delete Perl_save_delete
+#define save_destructor Perl_save_destructor
+#define save_freeop Perl_save_freeop
+#define save_freepv Perl_save_freepv
+#define save_freesv Perl_save_freesv
+#define save_gp Perl_save_gp
+#define save_hash Perl_save_hash
+#define save_helem Perl_save_helem
+#define save_hints Perl_save_hints
+#define save_hptr Perl_save_hptr
+#define save_int Perl_save_int
+#define save_item Perl_save_item
+#define save_iv Perl_save_iv
+#define save_list Perl_save_list
+#define save_long Perl_save_long
+#define save_nogv Perl_save_nogv
+#define save_op Perl_save_op
+#define save_pptr Perl_save_pptr
+#define save_scalar Perl_save_scalar
+#define save_sptr Perl_save_sptr
+#define save_svref Perl_save_svref
+#define save_threadsv Perl_save_threadsv
+#define savepv Perl_savepv
+#define savepvn Perl_savepvn
+#define savestack_grow Perl_savestack_grow
+#define saw_return Perl_saw_return
+#define sawparens Perl_sawparens
+#define scalar Perl_scalar
+#define scalarkids Perl_scalarkids
+#define scalarseq Perl_scalarseq
+#define scalarvoid Perl_scalarvoid
+#define scan_const Perl_scan_const
+#define scan_formline Perl_scan_formline
+#define scan_heredoc Perl_scan_heredoc
+#define scan_hex Perl_scan_hex
+#define scan_ident Perl_scan_ident
+#define scan_inputsymbol Perl_scan_inputsymbol
+#define scan_num Perl_scan_num
+#define scan_oct Perl_scan_oct
+#define scan_pat Perl_scan_pat
+#define scan_prefix Perl_scan_prefix
+#define scan_str Perl_scan_str
+#define scan_subst Perl_scan_subst
+#define scan_trans Perl_scan_trans
+#define scan_word Perl_scan_word
+#define scmp_amg Perl_scmp_amg
+#define scope Perl_scope
+#define screaminstr Perl_screaminstr
+#define seq_amg Perl_seq_amg
+#define setdefout Perl_setdefout
+#define setenv_getix Perl_setenv_getix
+#define sge_amg Perl_sge_amg
+#define sgt_amg Perl_sgt_amg
+#define share_hek Perl_share_hek
+#define sharepvn Perl_sharepvn
+#define sig_name Perl_sig_name
+#define sig_num Perl_sig_num
+#define sighandler Perl_sighandler
+#define simple Perl_simple
+#define sin_amg Perl_sin_amg
+#define skipspace Perl_skipspace
+#define sle_amg Perl_sle_amg
+#define slt_amg Perl_slt_amg
+#define sne_amg Perl_sne_amg
+#define sqrt_amg Perl_sqrt_amg
+#define stack_grow Perl_stack_grow
+#define start_subparse Perl_start_subparse
+#define string_amg Perl_string_amg
+#define sub_crush_depth Perl_sub_crush_depth
+#define subtr_amg Perl_subtr_amg
+#define subtr_ass_amg Perl_subtr_ass_amg
+#define sv_2bool Perl_sv_2bool
+#define sv_2cv Perl_sv_2cv
+#define sv_2io Perl_sv_2io
+#define sv_2iv Perl_sv_2iv
+#define sv_2mortal Perl_sv_2mortal
+#define sv_2nv Perl_sv_2nv
+#define sv_2pv Perl_sv_2pv
+#define sv_2uv Perl_sv_2uv
+#define sv_add_arena Perl_sv_add_arena
+#define sv_backoff Perl_sv_backoff
+#define sv_bless Perl_sv_bless
+#define sv_catpv Perl_sv_catpv
+#define sv_catpv_mg Perl_sv_catpv_mg
+#define sv_catpvf Perl_sv_catpvf
+#define sv_catpvf_mg Perl_sv_catpvf_mg
+#define sv_catpvn Perl_sv_catpvn
+#define sv_catpvn_mg Perl_sv_catpvn_mg
+#define sv_catsv Perl_sv_catsv
+#define sv_catsv_mg Perl_sv_catsv_mg
+#define sv_chop Perl_sv_chop
+#define sv_clean_all Perl_sv_clean_all
+#define sv_clean_objs Perl_sv_clean_objs
+#define sv_clear Perl_sv_clear
+#define sv_cmp Perl_sv_cmp
+#define sv_cmp_locale Perl_sv_cmp_locale
+#define sv_collxfrm Perl_sv_collxfrm
+#define sv_compile_2op Perl_sv_compile_2op
+#define sv_dec Perl_sv_dec
+#define sv_derived_from Perl_sv_derived_from
+#define sv_dump Perl_sv_dump
+#define sv_eq Perl_sv_eq
+#define sv_free Perl_sv_free
+#define sv_free_arenas Perl_sv_free_arenas
+#define sv_gets Perl_sv_gets
+#define sv_grow Perl_sv_grow
+#define sv_inc Perl_sv_inc
+#define sv_insert Perl_sv_insert
+#define sv_isa Perl_sv_isa
+#define sv_isobject Perl_sv_isobject
+#define sv_iv Perl_sv_iv
+#define sv_len Perl_sv_len
+#define sv_magic Perl_sv_magic
+#define sv_mortalcopy Perl_sv_mortalcopy
+#define sv_newmortal Perl_sv_newmortal
+#define sv_newref Perl_sv_newref
+#define sv_nv Perl_sv_nv
+#define sv_peek Perl_sv_peek
+#define sv_pvn Perl_sv_pvn
+#define sv_pvn_force Perl_sv_pvn_force
+#define sv_ref Perl_sv_ref
+#define sv_reftype Perl_sv_reftype
+#define sv_replace Perl_sv_replace
+#define sv_report_used Perl_sv_report_used
+#define sv_reset Perl_sv_reset
+#define sv_setiv Perl_sv_setiv
+#define sv_setiv_mg Perl_sv_setiv_mg
+#define sv_setnv Perl_sv_setnv
+#define sv_setnv_mg Perl_sv_setnv_mg
+#define sv_setptrobj Perl_sv_setptrobj
+#define sv_setpv Perl_sv_setpv
+#define sv_setpv_mg Perl_sv_setpv_mg
+#define sv_setpvf Perl_sv_setpvf
+#define sv_setpvf_mg Perl_sv_setpvf_mg
+#define sv_setpviv Perl_sv_setpviv
+#define sv_setpviv_mg Perl_sv_setpviv_mg
+#define sv_setpvn Perl_sv_setpvn
+#define sv_setpvn_mg Perl_sv_setpvn_mg
+#define sv_setref_iv Perl_sv_setref_iv
+#define sv_setref_nv Perl_sv_setref_nv
+#define sv_setref_pv Perl_sv_setref_pv
+#define sv_setref_pvn Perl_sv_setref_pvn
+#define sv_setsv Perl_sv_setsv
+#define sv_setsv_mg Perl_sv_setsv_mg
+#define sv_setuv Perl_sv_setuv
+#define sv_setuv_mg Perl_sv_setuv_mg
+#define sv_taint Perl_sv_taint
+#define sv_tainted Perl_sv_tainted
+#define sv_true Perl_sv_true
+#define sv_unmagic Perl_sv_unmagic
+#define sv_unref Perl_sv_unref
+#define sv_untaint Perl_sv_untaint
+#define sv_upgrade Perl_sv_upgrade
+#define sv_usepvn Perl_sv_usepvn
+#define sv_usepvn_mg Perl_sv_usepvn_mg
+#define sv_uv Perl_sv_uv
+#define sv_vcatpvfn Perl_sv_vcatpvfn
+#define sv_vsetpvfn Perl_sv_vsetpvfn
+#define taint_env Perl_taint_env
+#define taint_proper Perl_taint_proper
+#define too_few_arguments Perl_too_few_arguments
+#define too_many_arguments Perl_too_many_arguments
+#define unlnk Perl_unlnk
+#define unlock_condpair Perl_unlock_condpair
+#define unshare_hek Perl_unshare_hek
+#define unsharepvn Perl_unsharepvn
+#define utilize Perl_utilize
+#define varies Perl_varies
+#define vivify_defelem Perl_vivify_defelem
+#define vivify_ref Perl_vivify_ref
+#define vtbl_amagic Perl_vtbl_amagic
+#define vtbl_amagicelem Perl_vtbl_amagicelem
+#define vtbl_arylen Perl_vtbl_arylen
+#define vtbl_bm Perl_vtbl_bm
+#define vtbl_collxfrm Perl_vtbl_collxfrm
+#define vtbl_dbline Perl_vtbl_dbline
+#define vtbl_defelem Perl_vtbl_defelem
+#define vtbl_env Perl_vtbl_env
+#define vtbl_envelem Perl_vtbl_envelem
+#define vtbl_fm Perl_vtbl_fm
+#define vtbl_glob Perl_vtbl_glob
+#define vtbl_isa Perl_vtbl_isa
+#define vtbl_isaelem Perl_vtbl_isaelem
+#define vtbl_mglob Perl_vtbl_mglob
+#define vtbl_mutex Perl_vtbl_mutex
+#define vtbl_nkeys Perl_vtbl_nkeys
+#define vtbl_pack Perl_vtbl_pack
+#define vtbl_packelem Perl_vtbl_packelem
+#define vtbl_pos Perl_vtbl_pos
+#define vtbl_regexp Perl_vtbl_regexp
+#define vtbl_sig Perl_vtbl_sig
+#define vtbl_sigelem Perl_vtbl_sigelem
+#define vtbl_substr Perl_vtbl_substr
+#define vtbl_sv Perl_vtbl_sv
+#define vtbl_taint Perl_vtbl_taint
+#define vtbl_uvar Perl_vtbl_uvar
+#define vtbl_vec Perl_vtbl_vec
+#define wait4pid Perl_wait4pid
+#define warn Perl_warn
+#define warn_nl Perl_warn_nl
+#define warn_nosemi Perl_warn_nosemi
+#define warn_reserved Perl_warn_reserved
+#define warn_uninit Perl_warn_uninit
+#define watch Perl_watch
+#define watchaddr Perl_watchaddr
+#define watchok Perl_watchok
+#define whichsig Perl_whichsig
+#define yychar Perl_yychar
+#define yycheck Perl_yycheck
+#define yydebug Perl_yydebug
+#define yydefred Perl_yydefred
+#define yydestruct Perl_yydestruct
+#define yydgoto Perl_yydgoto
+#define yyerrflag Perl_yyerrflag
+#define yyerror Perl_yyerror
+#define yygindex Perl_yygindex
+#define yylen Perl_yylen
+#define yylex Perl_yylex
+#define yylhs Perl_yylhs
+#define yylval Perl_yylval
+#define yyname Perl_yyname
+#define yynerrs Perl_yynerrs
+#define yyparse Perl_yyparse
+#define yyrindex Perl_yyrindex
+#define yyrule Perl_yyrule
+#define yysindex Perl_yysindex
+#define yytable Perl_yytable
+#define yyval Perl_yyval
+#define yywarn Perl_yywarn
+
+#endif /* EMBED */
+
diff --git a/contrib/perl5/embed.pl b/contrib/perl5/embed.pl
new file mode 100755
index 000000000000..a7fb0eda3b10
--- /dev/null
+++ b/contrib/perl5/embed.pl
@@ -0,0 +1,323 @@
+#!/usr/bin/perl -w
+
+require 5.003;
+
+# XXX others that may need adding
+# warnhook
+# hints
+# copline
+my @extvars = qw(sv_undef sv_yes sv_no na dowarn
+ curcop compiling
+ tainting tainted stack_base stack_sp sv_arenaroot
+ curstash DBsub DBsingle debstash
+ rsfp
+ stdingv
+ defgv
+ errgv
+ rsfp_filters
+ perldb
+ diehook
+ dirty
+ perl_destruct_level
+ );
+
+sub readsyms (\%$) {
+ my ($syms, $file) = @_;
+ %$syms = ();
+ local (*FILE, $_);
+ open(FILE, "< $file")
+ or die "embed.pl: Can't open $file: $!\n";
+ while (<FILE>) {
+ s/[ \t]*#.*//; # Delete comments.
+ if (/^\s*(\S+)\s*$/) {
+ $$syms{$1} = 1;
+ }
+ }
+ close(FILE);
+}
+
+readsyms %global, 'global.sym';
+readsyms %interp, 'interp.sym';
+
+sub readvars(\%$$) {
+ my ($syms, $file,$pre) = @_;
+ %$syms = ();
+ local (*FILE, $_);
+ open(FILE, "< $file")
+ or die "embed.pl: Can't open $file: $!\n";
+ while (<FILE>) {
+ s/[ \t]*#.*//; # Delete comments.
+ if (/PERLVARI?C?\($pre(\w+)/) {
+ $$syms{$1} = 1;
+ }
+ }
+ close(FILE);
+}
+
+my %intrp;
+my %thread;
+
+readvars %intrp, 'intrpvar.h','I';
+readvars %thread, 'thrdvar.h','T';
+readvars %globvar, 'perlvars.h','G';
+
+foreach my $sym (sort keys %intrp)
+ {
+ warn "$sym not in interp.sym\n" unless exists $interp{$sym};
+ if (exists $global{$sym})
+ {
+ delete $global{$sym};
+ warn "$sym in global.sym as well as interp\n";
+ }
+ }
+
+foreach my $sym (sort keys %globvar)
+ {
+ if (exists $global{$sym})
+ {
+ delete $global{$sym};
+ warn "$sym in global.sym as well as perlvars.h\n";
+ }
+ }
+
+foreach my $sym (keys %interp)
+ {
+ warn "extra $sym in interp.sym\n"
+ unless exists $intrp{$sym} || exists $thread{$sym};
+ }
+
+foreach my $sym (sort keys %thread)
+ {
+ warn "$sym in intrpvar.h\n" if exists $intrp{$sym};
+ if (exists $global{$sym})
+ {
+ delete $global{$sym};
+ warn "$sym in global.sym as well as thread\n";
+ }
+ }
+
+sub hide ($$) {
+ my ($from, $to) = @_;
+ my $t = int(length($from) / 8);
+ "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
+}
+sub embed ($) {
+ my ($sym) = @_;
+ hide($sym, "Perl_$sym");
+}
+sub embedvar ($) {
+ my ($sym) = @_;
+# hide($sym, "Perl_$sym");
+ return '';
+}
+
+sub multon ($$$) {
+ my ($sym,$pre,$ptr) = @_;
+ hide("PL_$sym", "($ptr$pre$sym)");
+}
+sub multoff ($$) {
+ my ($sym,$pre) = @_;
+ return hide("PL_$pre$sym", "PL_$sym");
+}
+
+unlink 'embed.h';
+open(EM, '> embed.h')
+ or die "Can't create embed.h: $!\n";
+
+print EM <<'END';
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by embed.pl from global.sym, intrpvar.h,
+ and thrdvar.h. Any changes made here will be lost!
+*/
+
+/* (Doing namespace management portably in C is really gross.) */
+
+/* EMBED has no run-time penalty, but helps keep the Perl namespace
+ from colliding with that used by other libraries pulled in
+ by extensions or by embedding perl. Allow a cc -DNO_EMBED
+ override, however, to keep binary compatability with previous
+ versions of perl.
+*/
+#ifndef NO_EMBED
+# define EMBED 1
+#endif
+
+/* Hide global symbols? */
+
+#ifdef EMBED
+
+END
+
+for $sym (sort keys %global) {
+ print EM embed($sym);
+}
+
+print EM <<'END';
+
+#endif /* EMBED */
+
+END
+
+close(EM);
+
+unlink 'embedvar.h';
+open(EM, '> embedvar.h')
+ or die "Can't create embedvar.h: $!\n";
+
+print EM <<'END';
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by embed.pl from global.sym, intrpvar.h,
+ and thrdvar.h. Any changes made here will be lost!
+*/
+
+/* (Doing namespace management portably in C is really gross.) */
+
+/* EMBED has no run-time penalty, but helps keep the Perl namespace
+ from colliding with that used by other libraries pulled in
+ by extensions or by embedding perl. Allow a cc -DNO_EMBED
+ override, however, to keep binary compatability with previous
+ versions of perl.
+*/
+
+
+/* Put interpreter-specific symbols into a struct? */
+
+#ifdef MULTIPLICITY
+
+#ifndef USE_THREADS
+/* If we do not have threads then per-thread vars are per-interpreter */
+
+END
+
+for $sym (sort keys %thread) {
+ print EM multon($sym,'T','PL_curinterp->');
+}
+
+print EM <<'END';
+
+#endif /* !USE_THREADS */
+
+/* These are always per-interpreter if there is more than one */
+
+END
+
+for $sym (sort keys %intrp) {
+ print EM multon($sym,'I','PL_curinterp->');
+}
+
+print EM <<'END';
+
+#else /* !MULTIPLICITY */
+
+END
+
+for $sym (sort keys %intrp) {
+ print EM multoff($sym,'I');
+}
+
+print EM <<'END';
+
+#ifndef USE_THREADS
+
+END
+
+for $sym (sort keys %thread) {
+ print EM multoff($sym,'T');
+}
+
+print EM <<'END';
+
+#endif /* USE_THREADS */
+
+/* Hide what would have been interpreter-specific symbols? */
+
+#ifdef EMBED
+
+END
+
+for $sym (sort keys %intrp) {
+ print EM embedvar($sym);
+}
+
+print EM <<'END';
+
+#ifndef USE_THREADS
+
+END
+
+for $sym (sort keys %thread) {
+ print EM embedvar($sym);
+}
+
+print EM <<'END';
+
+#endif /* USE_THREADS */
+#endif /* EMBED */
+#endif /* MULTIPLICITY */
+
+/* Now same trickey for per-thread variables */
+
+#ifdef USE_THREADS
+
+END
+
+for $sym (sort keys %thread) {
+ print EM multon($sym,'T','thr->');
+}
+
+print EM <<'END';
+
+#endif /* USE_THREADS */
+
+#ifdef PERL_GLOBAL_STRUCT
+
+END
+
+for $sym (sort keys %globvar) {
+ print EM multon($sym,'G','PL_Vars.');
+}
+
+print EM <<'END';
+
+#else /* !PERL_GLOBAL_STRUCT */
+
+END
+
+for $sym (sort keys %globvar) {
+ print EM multoff($sym,'G');
+}
+
+print EM <<'END';
+
+#ifdef EMBED
+
+END
+
+for $sym (sort keys %globvar) {
+ print EM embedvar($sym);
+}
+
+print EM <<'END';
+
+#endif /* EMBED */
+#endif /* PERL_GLOBAL_STRUCT */
+
+END
+
+print EM <<'END';
+
+#ifndef MIN_PERL_DEFINE
+
+END
+
+for $sym (sort @extvars) {
+ print EM hide($sym,"PL_$sym");
+}
+
+print EM <<'END';
+
+#endif /* MIN_PERL_DEFINE */
+END
+
+
+close(EM);
diff --git a/contrib/perl5/embedvar.h b/contrib/perl5/embedvar.h
new file mode 100644
index 000000000000..7a258b0cce66
--- /dev/null
+++ b/contrib/perl5/embedvar.h
@@ -0,0 +1,891 @@
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by embed.pl from global.sym, intrpvar.h,
+ and thrdvar.h. Any changes made here will be lost!
+*/
+
+/* (Doing namespace management portably in C is really gross.) */
+
+/* EMBED has no run-time penalty, but helps keep the Perl namespace
+ from colliding with that used by other libraries pulled in
+ by extensions or by embedding perl. Allow a cc -DNO_EMBED
+ override, however, to keep binary compatability with previous
+ versions of perl.
+*/
+
+
+/* Put interpreter-specific symbols into a struct? */
+
+#ifdef MULTIPLICITY
+
+#ifndef USE_THREADS
+/* If we do not have threads then per-thread vars are per-interpreter */
+
+#define PL_Sv (PL_curinterp->TSv)
+#define PL_Xpv (PL_curinterp->TXpv)
+#define PL_av_fetch_sv (PL_curinterp->Tav_fetch_sv)
+#define PL_bodytarget (PL_curinterp->Tbodytarget)
+#define PL_bostr (PL_curinterp->Tbostr)
+#define PL_chopset (PL_curinterp->Tchopset)
+#define PL_colors (PL_curinterp->Tcolors)
+#define PL_colorset (PL_curinterp->Tcolorset)
+#define PL_curcop (PL_curinterp->Tcurcop)
+#define PL_curpad (PL_curinterp->Tcurpad)
+#define PL_curpm (PL_curinterp->Tcurpm)
+#define PL_curstack (PL_curinterp->Tcurstack)
+#define PL_curstackinfo (PL_curinterp->Tcurstackinfo)
+#define PL_curstash (PL_curinterp->Tcurstash)
+#define PL_defoutgv (PL_curinterp->Tdefoutgv)
+#define PL_defstash (PL_curinterp->Tdefstash)
+#define PL_delaymagic (PL_curinterp->Tdelaymagic)
+#define PL_dirty (PL_curinterp->Tdirty)
+#define PL_extralen (PL_curinterp->Textralen)
+#define PL_firstgv (PL_curinterp->Tfirstgv)
+#define PL_formtarget (PL_curinterp->Tformtarget)
+#define PL_hv_fetch_ent_mh (PL_curinterp->Thv_fetch_ent_mh)
+#define PL_hv_fetch_sv (PL_curinterp->Thv_fetch_sv)
+#define PL_in_eval (PL_curinterp->Tin_eval)
+#define PL_last_in_gv (PL_curinterp->Tlast_in_gv)
+#define PL_lastgotoprobe (PL_curinterp->Tlastgotoprobe)
+#define PL_lastscream (PL_curinterp->Tlastscream)
+#define PL_localizing (PL_curinterp->Tlocalizing)
+#define PL_mainstack (PL_curinterp->Tmainstack)
+#define PL_markstack (PL_curinterp->Tmarkstack)
+#define PL_markstack_max (PL_curinterp->Tmarkstack_max)
+#define PL_markstack_ptr (PL_curinterp->Tmarkstack_ptr)
+#define PL_maxscream (PL_curinterp->Tmaxscream)
+#define PL_modcount (PL_curinterp->Tmodcount)
+#define PL_nrs (PL_curinterp->Tnrs)
+#define PL_ofs (PL_curinterp->Tofs)
+#define PL_ofslen (PL_curinterp->Tofslen)
+#define PL_op (PL_curinterp->Top)
+#define PL_opsave (PL_curinterp->Topsave)
+#define PL_reg_eval_set (PL_curinterp->Treg_eval_set)
+#define PL_reg_flags (PL_curinterp->Treg_flags)
+#define PL_reg_start_tmp (PL_curinterp->Treg_start_tmp)
+#define PL_reg_start_tmpl (PL_curinterp->Treg_start_tmpl)
+#define PL_regbol (PL_curinterp->Tregbol)
+#define PL_regcc (PL_curinterp->Tregcc)
+#define PL_regcode (PL_curinterp->Tregcode)
+#define PL_regcomp_parse (PL_curinterp->Tregcomp_parse)
+#define PL_regcomp_rx (PL_curinterp->Tregcomp_rx)
+#define PL_regcompp (PL_curinterp->Tregcompp)
+#define PL_regdata (PL_curinterp->Tregdata)
+#define PL_regdummy (PL_curinterp->Tregdummy)
+#define PL_regendp (PL_curinterp->Tregendp)
+#define PL_regeol (PL_curinterp->Tregeol)
+#define PL_regexecp (PL_curinterp->Tregexecp)
+#define PL_regflags (PL_curinterp->Tregflags)
+#define PL_regindent (PL_curinterp->Tregindent)
+#define PL_reginput (PL_curinterp->Treginput)
+#define PL_reginterp_cnt (PL_curinterp->Treginterp_cnt)
+#define PL_reglastparen (PL_curinterp->Treglastparen)
+#define PL_regnarrate (PL_curinterp->Tregnarrate)
+#define PL_regnaughty (PL_curinterp->Tregnaughty)
+#define PL_regnpar (PL_curinterp->Tregnpar)
+#define PL_regprecomp (PL_curinterp->Tregprecomp)
+#define PL_regprev (PL_curinterp->Tregprev)
+#define PL_regprogram (PL_curinterp->Tregprogram)
+#define PL_regsawback (PL_curinterp->Tregsawback)
+#define PL_regseen (PL_curinterp->Tregseen)
+#define PL_regsize (PL_curinterp->Tregsize)
+#define PL_regstartp (PL_curinterp->Tregstartp)
+#define PL_regtill (PL_curinterp->Tregtill)
+#define PL_regxend (PL_curinterp->Tregxend)
+#define PL_restartop (PL_curinterp->Trestartop)
+#define PL_retstack (PL_curinterp->Tretstack)
+#define PL_retstack_ix (PL_curinterp->Tretstack_ix)
+#define PL_retstack_max (PL_curinterp->Tretstack_max)
+#define PL_rs (PL_curinterp->Trs)
+#define PL_savestack (PL_curinterp->Tsavestack)
+#define PL_savestack_ix (PL_curinterp->Tsavestack_ix)
+#define PL_savestack_max (PL_curinterp->Tsavestack_max)
+#define PL_scopestack (PL_curinterp->Tscopestack)
+#define PL_scopestack_ix (PL_curinterp->Tscopestack_ix)
+#define PL_scopestack_max (PL_curinterp->Tscopestack_max)
+#define PL_screamfirst (PL_curinterp->Tscreamfirst)
+#define PL_screamnext (PL_curinterp->Tscreamnext)
+#define PL_secondgv (PL_curinterp->Tsecondgv)
+#define PL_seen_evals (PL_curinterp->Tseen_evals)
+#define PL_seen_zerolen (PL_curinterp->Tseen_zerolen)
+#define PL_sortcop (PL_curinterp->Tsortcop)
+#define PL_sortcxix (PL_curinterp->Tsortcxix)
+#define PL_sortstash (PL_curinterp->Tsortstash)
+#define PL_stack_base (PL_curinterp->Tstack_base)
+#define PL_stack_max (PL_curinterp->Tstack_max)
+#define PL_stack_sp (PL_curinterp->Tstack_sp)
+#define PL_start_env (PL_curinterp->Tstart_env)
+#define PL_statbuf (PL_curinterp->Tstatbuf)
+#define PL_statcache (PL_curinterp->Tstatcache)
+#define PL_statgv (PL_curinterp->Tstatgv)
+#define PL_statname (PL_curinterp->Tstatname)
+#define PL_tainted (PL_curinterp->Ttainted)
+#define PL_timesbuf (PL_curinterp->Ttimesbuf)
+#define PL_tmps_floor (PL_curinterp->Ttmps_floor)
+#define PL_tmps_ix (PL_curinterp->Ttmps_ix)
+#define PL_tmps_max (PL_curinterp->Ttmps_max)
+#define PL_tmps_stack (PL_curinterp->Ttmps_stack)
+#define PL_top_env (PL_curinterp->Ttop_env)
+#define PL_toptarget (PL_curinterp->Ttoptarget)
+
+#endif /* !USE_THREADS */
+
+/* These are always per-interpreter if there is more than one */
+
+#define PL_Argv (PL_curinterp->IArgv)
+#define PL_Cmd (PL_curinterp->ICmd)
+#define PL_DBcv (PL_curinterp->IDBcv)
+#define PL_DBgv (PL_curinterp->IDBgv)
+#define PL_DBline (PL_curinterp->IDBline)
+#define PL_DBsignal (PL_curinterp->IDBsignal)
+#define PL_DBsingle (PL_curinterp->IDBsingle)
+#define PL_DBsub (PL_curinterp->IDBsub)
+#define PL_DBtrace (PL_curinterp->IDBtrace)
+#define PL_ampergv (PL_curinterp->Iampergv)
+#define PL_archpat_auto (PL_curinterp->Iarchpat_auto)
+#define PL_argvgv (PL_curinterp->Iargvgv)
+#define PL_argvoutgv (PL_curinterp->Iargvoutgv)
+#define PL_basetime (PL_curinterp->Ibasetime)
+#define PL_beginav (PL_curinterp->Ibeginav)
+#define PL_bytecode_iv_overflows (PL_curinterp->Ibytecode_iv_overflows)
+#define PL_bytecode_obj_list (PL_curinterp->Ibytecode_obj_list)
+#define PL_bytecode_obj_list_fill (PL_curinterp->Ibytecode_obj_list_fill)
+#define PL_bytecode_pv (PL_curinterp->Ibytecode_pv)
+#define PL_bytecode_sv (PL_curinterp->Ibytecode_sv)
+#define PL_cddir (PL_curinterp->Icddir)
+#define PL_compcv (PL_curinterp->Icompcv)
+#define PL_compiling (PL_curinterp->Icompiling)
+#define PL_comppad (PL_curinterp->Icomppad)
+#define PL_comppad_name (PL_curinterp->Icomppad_name)
+#define PL_comppad_name_fill (PL_curinterp->Icomppad_name_fill)
+#define PL_comppad_name_floor (PL_curinterp->Icomppad_name_floor)
+#define PL_copline (PL_curinterp->Icopline)
+#define PL_curcopdb (PL_curinterp->Icurcopdb)
+#define PL_curstname (PL_curinterp->Icurstname)
+#define PL_dbargs (PL_curinterp->Idbargs)
+#define PL_debdelim (PL_curinterp->Idebdelim)
+#define PL_debname (PL_curinterp->Idebname)
+#define PL_debstash (PL_curinterp->Idebstash)
+#define PL_defgv (PL_curinterp->Idefgv)
+#define PL_diehook (PL_curinterp->Idiehook)
+#define PL_dlevel (PL_curinterp->Idlevel)
+#define PL_dlmax (PL_curinterp->Idlmax)
+#define PL_doextract (PL_curinterp->Idoextract)
+#define PL_doswitches (PL_curinterp->Idoswitches)
+#define PL_dowarn (PL_curinterp->Idowarn)
+#define PL_dumplvl (PL_curinterp->Idumplvl)
+#define PL_e_script (PL_curinterp->Ie_script)
+#define PL_endav (PL_curinterp->Iendav)
+#define PL_envgv (PL_curinterp->Ienvgv)
+#define PL_errgv (PL_curinterp->Ierrgv)
+#define PL_eval_root (PL_curinterp->Ieval_root)
+#define PL_eval_start (PL_curinterp->Ieval_start)
+#define PL_exitlist (PL_curinterp->Iexitlist)
+#define PL_exitlistlen (PL_curinterp->Iexitlistlen)
+#define PL_fdpid (PL_curinterp->Ifdpid)
+#define PL_filemode (PL_curinterp->Ifilemode)
+#define PL_forkprocess (PL_curinterp->Iforkprocess)
+#define PL_formfeed (PL_curinterp->Iformfeed)
+#define PL_generation (PL_curinterp->Igeneration)
+#define PL_gensym (PL_curinterp->Igensym)
+#define PL_globalstash (PL_curinterp->Iglobalstash)
+#define PL_hintgv (PL_curinterp->Ihintgv)
+#define PL_in_clean_all (PL_curinterp->Iin_clean_all)
+#define PL_in_clean_objs (PL_curinterp->Iin_clean_objs)
+#define PL_incgv (PL_curinterp->Iincgv)
+#define PL_initav (PL_curinterp->Iinitav)
+#define PL_inplace (PL_curinterp->Iinplace)
+#define PL_last_proto (PL_curinterp->Ilast_proto)
+#define PL_lastfd (PL_curinterp->Ilastfd)
+#define PL_lastsize (PL_curinterp->Ilastsize)
+#define PL_lastspbase (PL_curinterp->Ilastspbase)
+#define PL_laststatval (PL_curinterp->Ilaststatval)
+#define PL_laststype (PL_curinterp->Ilaststype)
+#define PL_leftgv (PL_curinterp->Ileftgv)
+#define PL_lineary (PL_curinterp->Ilineary)
+#define PL_linestart (PL_curinterp->Ilinestart)
+#define PL_localpatches (PL_curinterp->Ilocalpatches)
+#define PL_main_cv (PL_curinterp->Imain_cv)
+#define PL_main_root (PL_curinterp->Imain_root)
+#define PL_main_start (PL_curinterp->Imain_start)
+#define PL_maxsysfd (PL_curinterp->Imaxsysfd)
+#define PL_mess_sv (PL_curinterp->Imess_sv)
+#define PL_minus_F (PL_curinterp->Iminus_F)
+#define PL_minus_a (PL_curinterp->Iminus_a)
+#define PL_minus_c (PL_curinterp->Iminus_c)
+#define PL_minus_l (PL_curinterp->Iminus_l)
+#define PL_minus_n (PL_curinterp->Iminus_n)
+#define PL_minus_p (PL_curinterp->Iminus_p)
+#define PL_modglobal (PL_curinterp->Imodglobal)
+#define PL_multiline (PL_curinterp->Imultiline)
+#define PL_mystrk (PL_curinterp->Imystrk)
+#define PL_ofmt (PL_curinterp->Iofmt)
+#define PL_oldlastpm (PL_curinterp->Ioldlastpm)
+#define PL_oldname (PL_curinterp->Ioldname)
+#define PL_op_mask (PL_curinterp->Iop_mask)
+#define PL_origargc (PL_curinterp->Iorigargc)
+#define PL_origargv (PL_curinterp->Iorigargv)
+#define PL_origfilename (PL_curinterp->Iorigfilename)
+#define PL_ors (PL_curinterp->Iors)
+#define PL_orslen (PL_curinterp->Iorslen)
+#define PL_parsehook (PL_curinterp->Iparsehook)
+#define PL_patchlevel (PL_curinterp->Ipatchlevel)
+#define PL_pending_ident (PL_curinterp->Ipending_ident)
+#define PL_perl_destruct_level (PL_curinterp->Iperl_destruct_level)
+#define PL_perldb (PL_curinterp->Iperldb)
+#define PL_preambleav (PL_curinterp->Ipreambleav)
+#define PL_preambled (PL_curinterp->Ipreambled)
+#define PL_preprocess (PL_curinterp->Ipreprocess)
+#define PL_profiledata (PL_curinterp->Iprofiledata)
+#define PL_replgv (PL_curinterp->Ireplgv)
+#define PL_rightgv (PL_curinterp->Irightgv)
+#define PL_rsfp (PL_curinterp->Irsfp)
+#define PL_rsfp_filters (PL_curinterp->Irsfp_filters)
+#define PL_sawampersand (PL_curinterp->Isawampersand)
+#define PL_sawstudy (PL_curinterp->Isawstudy)
+#define PL_sawvec (PL_curinterp->Isawvec)
+#define PL_siggv (PL_curinterp->Isiggv)
+#define PL_splitstr (PL_curinterp->Isplitstr)
+#define PL_statusvalue (PL_curinterp->Istatusvalue)
+#define PL_statusvalue_vms (PL_curinterp->Istatusvalue_vms)
+#define PL_stdingv (PL_curinterp->Istdingv)
+#define PL_strchop (PL_curinterp->Istrchop)
+#define PL_strtab (PL_curinterp->Istrtab)
+#define PL_sub_generation (PL_curinterp->Isub_generation)
+#define PL_sublex_info (PL_curinterp->Isublex_info)
+#define PL_sv_arenaroot (PL_curinterp->Isv_arenaroot)
+#define PL_sv_count (PL_curinterp->Isv_count)
+#define PL_sv_objcount (PL_curinterp->Isv_objcount)
+#define PL_sv_root (PL_curinterp->Isv_root)
+#define PL_sys_intern (PL_curinterp->Isys_intern)
+#define PL_tainting (PL_curinterp->Itainting)
+#define PL_threadnum (PL_curinterp->Ithreadnum)
+#define PL_thrsv (PL_curinterp->Ithrsv)
+#define PL_unsafe (PL_curinterp->Iunsafe)
+#define PL_warnhook (PL_curinterp->Iwarnhook)
+
+#else /* !MULTIPLICITY */
+
+#define PL_IArgv PL_Argv
+#define PL_ICmd PL_Cmd
+#define PL_IDBcv PL_DBcv
+#define PL_IDBgv PL_DBgv
+#define PL_IDBline PL_DBline
+#define PL_IDBsignal PL_DBsignal
+#define PL_IDBsingle PL_DBsingle
+#define PL_IDBsub PL_DBsub
+#define PL_IDBtrace PL_DBtrace
+#define PL_Iampergv PL_ampergv
+#define PL_Iarchpat_auto PL_archpat_auto
+#define PL_Iargvgv PL_argvgv
+#define PL_Iargvoutgv PL_argvoutgv
+#define PL_Ibasetime PL_basetime
+#define PL_Ibeginav PL_beginav
+#define PL_Ibytecode_iv_overflows PL_bytecode_iv_overflows
+#define PL_Ibytecode_obj_list PL_bytecode_obj_list
+#define PL_Ibytecode_obj_list_fill PL_bytecode_obj_list_fill
+#define PL_Ibytecode_pv PL_bytecode_pv
+#define PL_Ibytecode_sv PL_bytecode_sv
+#define PL_Icddir PL_cddir
+#define PL_Icompcv PL_compcv
+#define PL_Icompiling PL_compiling
+#define PL_Icomppad PL_comppad
+#define PL_Icomppad_name PL_comppad_name
+#define PL_Icomppad_name_fill PL_comppad_name_fill
+#define PL_Icomppad_name_floor PL_comppad_name_floor
+#define PL_Icopline PL_copline
+#define PL_Icurcopdb PL_curcopdb
+#define PL_Icurstname PL_curstname
+#define PL_Idbargs PL_dbargs
+#define PL_Idebdelim PL_debdelim
+#define PL_Idebname PL_debname
+#define PL_Idebstash PL_debstash
+#define PL_Idefgv PL_defgv
+#define PL_Idiehook PL_diehook
+#define PL_Idlevel PL_dlevel
+#define PL_Idlmax PL_dlmax
+#define PL_Idoextract PL_doextract
+#define PL_Idoswitches PL_doswitches
+#define PL_Idowarn PL_dowarn
+#define PL_Idumplvl PL_dumplvl
+#define PL_Ie_script PL_e_script
+#define PL_Iendav PL_endav
+#define PL_Ienvgv PL_envgv
+#define PL_Ierrgv PL_errgv
+#define PL_Ieval_root PL_eval_root
+#define PL_Ieval_start PL_eval_start
+#define PL_Iexitlist PL_exitlist
+#define PL_Iexitlistlen PL_exitlistlen
+#define PL_Ifdpid PL_fdpid
+#define PL_Ifilemode PL_filemode
+#define PL_Iforkprocess PL_forkprocess
+#define PL_Iformfeed PL_formfeed
+#define PL_Igeneration PL_generation
+#define PL_Igensym PL_gensym
+#define PL_Iglobalstash PL_globalstash
+#define PL_Ihintgv PL_hintgv
+#define PL_Iin_clean_all PL_in_clean_all
+#define PL_Iin_clean_objs PL_in_clean_objs
+#define PL_Iincgv PL_incgv
+#define PL_Iinitav PL_initav
+#define PL_Iinplace PL_inplace
+#define PL_Ilast_proto PL_last_proto
+#define PL_Ilastfd PL_lastfd
+#define PL_Ilastsize PL_lastsize
+#define PL_Ilastspbase PL_lastspbase
+#define PL_Ilaststatval PL_laststatval
+#define PL_Ilaststype PL_laststype
+#define PL_Ileftgv PL_leftgv
+#define PL_Ilineary PL_lineary
+#define PL_Ilinestart PL_linestart
+#define PL_Ilocalpatches PL_localpatches
+#define PL_Imain_cv PL_main_cv
+#define PL_Imain_root PL_main_root
+#define PL_Imain_start PL_main_start
+#define PL_Imaxsysfd PL_maxsysfd
+#define PL_Imess_sv PL_mess_sv
+#define PL_Iminus_F PL_minus_F
+#define PL_Iminus_a PL_minus_a
+#define PL_Iminus_c PL_minus_c
+#define PL_Iminus_l PL_minus_l
+#define PL_Iminus_n PL_minus_n
+#define PL_Iminus_p PL_minus_p
+#define PL_Imodglobal PL_modglobal
+#define PL_Imultiline PL_multiline
+#define PL_Imystrk PL_mystrk
+#define PL_Iofmt PL_ofmt
+#define PL_Ioldlastpm PL_oldlastpm
+#define PL_Ioldname PL_oldname
+#define PL_Iop_mask PL_op_mask
+#define PL_Iorigargc PL_origargc
+#define PL_Iorigargv PL_origargv
+#define PL_Iorigfilename PL_origfilename
+#define PL_Iors PL_ors
+#define PL_Iorslen PL_orslen
+#define PL_Iparsehook PL_parsehook
+#define PL_Ipatchlevel PL_patchlevel
+#define PL_Ipending_ident PL_pending_ident
+#define PL_Iperl_destruct_level PL_perl_destruct_level
+#define PL_Iperldb PL_perldb
+#define PL_Ipreambleav PL_preambleav
+#define PL_Ipreambled PL_preambled
+#define PL_Ipreprocess PL_preprocess
+#define PL_Iprofiledata PL_profiledata
+#define PL_Ireplgv PL_replgv
+#define PL_Irightgv PL_rightgv
+#define PL_Irsfp PL_rsfp
+#define PL_Irsfp_filters PL_rsfp_filters
+#define PL_Isawampersand PL_sawampersand
+#define PL_Isawstudy PL_sawstudy
+#define PL_Isawvec PL_sawvec
+#define PL_Isiggv PL_siggv
+#define PL_Isplitstr PL_splitstr
+#define PL_Istatusvalue PL_statusvalue
+#define PL_Istatusvalue_vms PL_statusvalue_vms
+#define PL_Istdingv PL_stdingv
+#define PL_Istrchop PL_strchop
+#define PL_Istrtab PL_strtab
+#define PL_Isub_generation PL_sub_generation
+#define PL_Isublex_info PL_sublex_info
+#define PL_Isv_arenaroot PL_sv_arenaroot
+#define PL_Isv_count PL_sv_count
+#define PL_Isv_objcount PL_sv_objcount
+#define PL_Isv_root PL_sv_root
+#define PL_Isys_intern PL_sys_intern
+#define PL_Itainting PL_tainting
+#define PL_Ithreadnum PL_threadnum
+#define PL_Ithrsv PL_thrsv
+#define PL_Iunsafe PL_unsafe
+#define PL_Iwarnhook PL_warnhook
+
+#ifndef USE_THREADS
+
+#define PL_TSv PL_Sv
+#define PL_TXpv PL_Xpv
+#define PL_Tav_fetch_sv PL_av_fetch_sv
+#define PL_Tbodytarget PL_bodytarget
+#define PL_Tbostr PL_bostr
+#define PL_Tchopset PL_chopset
+#define PL_Tcolors PL_colors
+#define PL_Tcolorset PL_colorset
+#define PL_Tcurcop PL_curcop
+#define PL_Tcurpad PL_curpad
+#define PL_Tcurpm PL_curpm
+#define PL_Tcurstack PL_curstack
+#define PL_Tcurstackinfo PL_curstackinfo
+#define PL_Tcurstash PL_curstash
+#define PL_Tdefoutgv PL_defoutgv
+#define PL_Tdefstash PL_defstash
+#define PL_Tdelaymagic PL_delaymagic
+#define PL_Tdirty PL_dirty
+#define PL_Textralen PL_extralen
+#define PL_Tfirstgv PL_firstgv
+#define PL_Tformtarget PL_formtarget
+#define PL_Thv_fetch_ent_mh PL_hv_fetch_ent_mh
+#define PL_Thv_fetch_sv PL_hv_fetch_sv
+#define PL_Tin_eval PL_in_eval
+#define PL_Tlast_in_gv PL_last_in_gv
+#define PL_Tlastgotoprobe PL_lastgotoprobe
+#define PL_Tlastscream PL_lastscream
+#define PL_Tlocalizing PL_localizing
+#define PL_Tmainstack PL_mainstack
+#define PL_Tmarkstack PL_markstack
+#define PL_Tmarkstack_max PL_markstack_max
+#define PL_Tmarkstack_ptr PL_markstack_ptr
+#define PL_Tmaxscream PL_maxscream
+#define PL_Tmodcount PL_modcount
+#define PL_Tnrs PL_nrs
+#define PL_Tofs PL_ofs
+#define PL_Tofslen PL_ofslen
+#define PL_Top PL_op
+#define PL_Topsave PL_opsave
+#define PL_Treg_eval_set PL_reg_eval_set
+#define PL_Treg_flags PL_reg_flags
+#define PL_Treg_start_tmp PL_reg_start_tmp
+#define PL_Treg_start_tmpl PL_reg_start_tmpl
+#define PL_Tregbol PL_regbol
+#define PL_Tregcc PL_regcc
+#define PL_Tregcode PL_regcode
+#define PL_Tregcomp_parse PL_regcomp_parse
+#define PL_Tregcomp_rx PL_regcomp_rx
+#define PL_Tregcompp PL_regcompp
+#define PL_Tregdata PL_regdata
+#define PL_Tregdummy PL_regdummy
+#define PL_Tregendp PL_regendp
+#define PL_Tregeol PL_regeol
+#define PL_Tregexecp PL_regexecp
+#define PL_Tregflags PL_regflags
+#define PL_Tregindent PL_regindent
+#define PL_Treginput PL_reginput
+#define PL_Treginterp_cnt PL_reginterp_cnt
+#define PL_Treglastparen PL_reglastparen
+#define PL_Tregnarrate PL_regnarrate
+#define PL_Tregnaughty PL_regnaughty
+#define PL_Tregnpar PL_regnpar
+#define PL_Tregprecomp PL_regprecomp
+#define PL_Tregprev PL_regprev
+#define PL_Tregprogram PL_regprogram
+#define PL_Tregsawback PL_regsawback
+#define PL_Tregseen PL_regseen
+#define PL_Tregsize PL_regsize
+#define PL_Tregstartp PL_regstartp
+#define PL_Tregtill PL_regtill
+#define PL_Tregxend PL_regxend
+#define PL_Trestartop PL_restartop
+#define PL_Tretstack PL_retstack
+#define PL_Tretstack_ix PL_retstack_ix
+#define PL_Tretstack_max PL_retstack_max
+#define PL_Trs PL_rs
+#define PL_Tsavestack PL_savestack
+#define PL_Tsavestack_ix PL_savestack_ix
+#define PL_Tsavestack_max PL_savestack_max
+#define PL_Tscopestack PL_scopestack
+#define PL_Tscopestack_ix PL_scopestack_ix
+#define PL_Tscopestack_max PL_scopestack_max
+#define PL_Tscreamfirst PL_screamfirst
+#define PL_Tscreamnext PL_screamnext
+#define PL_Tsecondgv PL_secondgv
+#define PL_Tseen_evals PL_seen_evals
+#define PL_Tseen_zerolen PL_seen_zerolen
+#define PL_Tsortcop PL_sortcop
+#define PL_Tsortcxix PL_sortcxix
+#define PL_Tsortstash PL_sortstash
+#define PL_Tstack_base PL_stack_base
+#define PL_Tstack_max PL_stack_max
+#define PL_Tstack_sp PL_stack_sp
+#define PL_Tstart_env PL_start_env
+#define PL_Tstatbuf PL_statbuf
+#define PL_Tstatcache PL_statcache
+#define PL_Tstatgv PL_statgv
+#define PL_Tstatname PL_statname
+#define PL_Ttainted PL_tainted
+#define PL_Ttimesbuf PL_timesbuf
+#define PL_Ttmps_floor PL_tmps_floor
+#define PL_Ttmps_ix PL_tmps_ix
+#define PL_Ttmps_max PL_tmps_max
+#define PL_Ttmps_stack PL_tmps_stack
+#define PL_Ttop_env PL_top_env
+#define PL_Ttoptarget PL_toptarget
+
+#endif /* USE_THREADS */
+
+/* Hide what would have been interpreter-specific symbols? */
+
+#ifdef EMBED
+
+
+#ifndef USE_THREADS
+
+
+#endif /* USE_THREADS */
+#endif /* EMBED */
+#endif /* MULTIPLICITY */
+
+/* Now same trickey for per-thread variables */
+
+#ifdef USE_THREADS
+
+#define PL_Sv (thr->TSv)
+#define PL_Xpv (thr->TXpv)
+#define PL_av_fetch_sv (thr->Tav_fetch_sv)
+#define PL_bodytarget (thr->Tbodytarget)
+#define PL_bostr (thr->Tbostr)
+#define PL_chopset (thr->Tchopset)
+#define PL_colors (thr->Tcolors)
+#define PL_colorset (thr->Tcolorset)
+#define PL_curcop (thr->Tcurcop)
+#define PL_curpad (thr->Tcurpad)
+#define PL_curpm (thr->Tcurpm)
+#define PL_curstack (thr->Tcurstack)
+#define PL_curstackinfo (thr->Tcurstackinfo)
+#define PL_curstash (thr->Tcurstash)
+#define PL_defoutgv (thr->Tdefoutgv)
+#define PL_defstash (thr->Tdefstash)
+#define PL_delaymagic (thr->Tdelaymagic)
+#define PL_dirty (thr->Tdirty)
+#define PL_extralen (thr->Textralen)
+#define PL_firstgv (thr->Tfirstgv)
+#define PL_formtarget (thr->Tformtarget)
+#define PL_hv_fetch_ent_mh (thr->Thv_fetch_ent_mh)
+#define PL_hv_fetch_sv (thr->Thv_fetch_sv)
+#define PL_in_eval (thr->Tin_eval)
+#define PL_last_in_gv (thr->Tlast_in_gv)
+#define PL_lastgotoprobe (thr->Tlastgotoprobe)
+#define PL_lastscream (thr->Tlastscream)
+#define PL_localizing (thr->Tlocalizing)
+#define PL_mainstack (thr->Tmainstack)
+#define PL_markstack (thr->Tmarkstack)
+#define PL_markstack_max (thr->Tmarkstack_max)
+#define PL_markstack_ptr (thr->Tmarkstack_ptr)
+#define PL_maxscream (thr->Tmaxscream)
+#define PL_modcount (thr->Tmodcount)
+#define PL_nrs (thr->Tnrs)
+#define PL_ofs (thr->Tofs)
+#define PL_ofslen (thr->Tofslen)
+#define PL_op (thr->Top)
+#define PL_opsave (thr->Topsave)
+#define PL_reg_eval_set (thr->Treg_eval_set)
+#define PL_reg_flags (thr->Treg_flags)
+#define PL_reg_start_tmp (thr->Treg_start_tmp)
+#define PL_reg_start_tmpl (thr->Treg_start_tmpl)
+#define PL_regbol (thr->Tregbol)
+#define PL_regcc (thr->Tregcc)
+#define PL_regcode (thr->Tregcode)
+#define PL_regcomp_parse (thr->Tregcomp_parse)
+#define PL_regcomp_rx (thr->Tregcomp_rx)
+#define PL_regcompp (thr->Tregcompp)
+#define PL_regdata (thr->Tregdata)
+#define PL_regdummy (thr->Tregdummy)
+#define PL_regendp (thr->Tregendp)
+#define PL_regeol (thr->Tregeol)
+#define PL_regexecp (thr->Tregexecp)
+#define PL_regflags (thr->Tregflags)
+#define PL_regindent (thr->Tregindent)
+#define PL_reginput (thr->Treginput)
+#define PL_reginterp_cnt (thr->Treginterp_cnt)
+#define PL_reglastparen (thr->Treglastparen)
+#define PL_regnarrate (thr->Tregnarrate)
+#define PL_regnaughty (thr->Tregnaughty)
+#define PL_regnpar (thr->Tregnpar)
+#define PL_regprecomp (thr->Tregprecomp)
+#define PL_regprev (thr->Tregprev)
+#define PL_regprogram (thr->Tregprogram)
+#define PL_regsawback (thr->Tregsawback)
+#define PL_regseen (thr->Tregseen)
+#define PL_regsize (thr->Tregsize)
+#define PL_regstartp (thr->Tregstartp)
+#define PL_regtill (thr->Tregtill)
+#define PL_regxend (thr->Tregxend)
+#define PL_restartop (thr->Trestartop)
+#define PL_retstack (thr->Tretstack)
+#define PL_retstack_ix (thr->Tretstack_ix)
+#define PL_retstack_max (thr->Tretstack_max)
+#define PL_rs (thr->Trs)
+#define PL_savestack (thr->Tsavestack)
+#define PL_savestack_ix (thr->Tsavestack_ix)
+#define PL_savestack_max (thr->Tsavestack_max)
+#define PL_scopestack (thr->Tscopestack)
+#define PL_scopestack_ix (thr->Tscopestack_ix)
+#define PL_scopestack_max (thr->Tscopestack_max)
+#define PL_screamfirst (thr->Tscreamfirst)
+#define PL_screamnext (thr->Tscreamnext)
+#define PL_secondgv (thr->Tsecondgv)
+#define PL_seen_evals (thr->Tseen_evals)
+#define PL_seen_zerolen (thr->Tseen_zerolen)
+#define PL_sortcop (thr->Tsortcop)
+#define PL_sortcxix (thr->Tsortcxix)
+#define PL_sortstash (thr->Tsortstash)
+#define PL_stack_base (thr->Tstack_base)
+#define PL_stack_max (thr->Tstack_max)
+#define PL_stack_sp (thr->Tstack_sp)
+#define PL_start_env (thr->Tstart_env)
+#define PL_statbuf (thr->Tstatbuf)
+#define PL_statcache (thr->Tstatcache)
+#define PL_statgv (thr->Tstatgv)
+#define PL_statname (thr->Tstatname)
+#define PL_tainted (thr->Ttainted)
+#define PL_timesbuf (thr->Ttimesbuf)
+#define PL_tmps_floor (thr->Ttmps_floor)
+#define PL_tmps_ix (thr->Ttmps_ix)
+#define PL_tmps_max (thr->Ttmps_max)
+#define PL_tmps_stack (thr->Ttmps_stack)
+#define PL_top_env (thr->Ttop_env)
+#define PL_toptarget (thr->Ttoptarget)
+
+#endif /* USE_THREADS */
+
+#ifdef PERL_GLOBAL_STRUCT
+
+#define PL_No (PL_Vars.GNo)
+#define PL_Yes (PL_Vars.GYes)
+#define PL_amagic_generation (PL_Vars.Gamagic_generation)
+#define PL_an (PL_Vars.Gan)
+#define PL_bufend (PL_Vars.Gbufend)
+#define PL_bufptr (PL_Vars.Gbufptr)
+#define PL_collation_ix (PL_Vars.Gcollation_ix)
+#define PL_collation_name (PL_Vars.Gcollation_name)
+#define PL_collation_standard (PL_Vars.Gcollation_standard)
+#define PL_collxfrm_base (PL_Vars.Gcollxfrm_base)
+#define PL_collxfrm_mult (PL_Vars.Gcollxfrm_mult)
+#define PL_cop_seqmax (PL_Vars.Gcop_seqmax)
+#define PL_cryptseen (PL_Vars.Gcryptseen)
+#define PL_cshlen (PL_Vars.Gcshlen)
+#define PL_cshname (PL_Vars.Gcshname)
+#define PL_curinterp (PL_Vars.Gcurinterp)
+#define PL_curthr (PL_Vars.Gcurthr)
+#define PL_debug (PL_Vars.Gdebug)
+#define PL_do_undump (PL_Vars.Gdo_undump)
+#define PL_egid (PL_Vars.Gegid)
+#define PL_error_count (PL_Vars.Gerror_count)
+#define PL_euid (PL_Vars.Geuid)
+#define PL_eval_cond (PL_Vars.Geval_cond)
+#define PL_eval_mutex (PL_Vars.Geval_mutex)
+#define PL_eval_owner (PL_Vars.Geval_owner)
+#define PL_evalseq (PL_Vars.Gevalseq)
+#define PL_expect (PL_Vars.Gexpect)
+#define PL_gid (PL_Vars.Ggid)
+#define PL_he_root (PL_Vars.Ghe_root)
+#define PL_hexdigit (PL_Vars.Ghexdigit)
+#define PL_hints (PL_Vars.Ghints)
+#define PL_in_my (PL_Vars.Gin_my)
+#define PL_in_my_stash (PL_Vars.Gin_my_stash)
+#define PL_last_lop (PL_Vars.Glast_lop)
+#define PL_last_lop_op (PL_Vars.Glast_lop_op)
+#define PL_last_uni (PL_Vars.Glast_uni)
+#define PL_lex_brackets (PL_Vars.Glex_brackets)
+#define PL_lex_brackstack (PL_Vars.Glex_brackstack)
+#define PL_lex_casemods (PL_Vars.Glex_casemods)
+#define PL_lex_casestack (PL_Vars.Glex_casestack)
+#define PL_lex_defer (PL_Vars.Glex_defer)
+#define PL_lex_dojoin (PL_Vars.Glex_dojoin)
+#define PL_lex_expect (PL_Vars.Glex_expect)
+#define PL_lex_fakebrack (PL_Vars.Glex_fakebrack)
+#define PL_lex_formbrack (PL_Vars.Glex_formbrack)
+#define PL_lex_inpat (PL_Vars.Glex_inpat)
+#define PL_lex_inwhat (PL_Vars.Glex_inwhat)
+#define PL_lex_op (PL_Vars.Glex_op)
+#define PL_lex_repl (PL_Vars.Glex_repl)
+#define PL_lex_starts (PL_Vars.Glex_starts)
+#define PL_lex_state (PL_Vars.Glex_state)
+#define PL_lex_stuff (PL_Vars.Glex_stuff)
+#define PL_linestr (PL_Vars.Glinestr)
+#define PL_malloc_mutex (PL_Vars.Gmalloc_mutex)
+#define PL_max_intro_pending (PL_Vars.Gmax_intro_pending)
+#define PL_maxo (PL_Vars.Gmaxo)
+#define PL_min_intro_pending (PL_Vars.Gmin_intro_pending)
+#define PL_multi_close (PL_Vars.Gmulti_close)
+#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)
+#define PL_nice_chunk (PL_Vars.Gnice_chunk)
+#define PL_nice_chunk_size (PL_Vars.Gnice_chunk_size)
+#define PL_ninterps (PL_Vars.Gninterps)
+#define PL_nomemok (PL_Vars.Gnomemok)
+#define PL_nthreads (PL_Vars.Gnthreads)
+#define PL_nthreads_cond (PL_Vars.Gnthreads_cond)
+#define PL_numeric_local (PL_Vars.Gnumeric_local)
+#define PL_numeric_name (PL_Vars.Gnumeric_name)
+#define PL_numeric_standard (PL_Vars.Gnumeric_standard)
+#define PL_oldbufptr (PL_Vars.Goldbufptr)
+#define PL_oldoldbufptr (PL_Vars.Goldoldbufptr)
+#define PL_op_seqmax (PL_Vars.Gop_seqmax)
+#define PL_origalen (PL_Vars.Gorigalen)
+#define PL_origenviron (PL_Vars.Gorigenviron)
+#define PL_osname (PL_Vars.Gosname)
+#define PL_pad_reset_pending (PL_Vars.Gpad_reset_pending)
+#define PL_padix (PL_Vars.Gpadix)
+#define PL_padix_floor (PL_Vars.Gpadix_floor)
+#define PL_patleave (PL_Vars.Gpatleave)
+#define PL_pidstatus (PL_Vars.Gpidstatus)
+#define PL_runops (PL_Vars.Grunops)
+#define PL_sh_path (PL_Vars.Gsh_path)
+#define PL_sighandlerp (PL_Vars.Gsighandlerp)
+#define PL_specialsv_list (PL_Vars.Gspecialsv_list)
+#define PL_subline (PL_Vars.Gsubline)
+#define PL_subname (PL_Vars.Gsubname)
+#define PL_sv_mutex (PL_Vars.Gsv_mutex)
+#define PL_sv_no (PL_Vars.Gsv_no)
+#define PL_sv_undef (PL_Vars.Gsv_undef)
+#define PL_sv_yes (PL_Vars.Gsv_yes)
+#define PL_svref_mutex (PL_Vars.Gsvref_mutex)
+#define PL_thisexpr (PL_Vars.Gthisexpr)
+#define PL_thr_key (PL_Vars.Gthr_key)
+#define PL_threads_mutex (PL_Vars.Gthreads_mutex)
+#define PL_threadsv_names (PL_Vars.Gthreadsv_names)
+#define PL_tokenbuf (PL_Vars.Gtokenbuf)
+#define PL_uid (PL_Vars.Guid)
+#define PL_xiv_arenaroot (PL_Vars.Gxiv_arenaroot)
+#define PL_xiv_root (PL_Vars.Gxiv_root)
+#define PL_xnv_root (PL_Vars.Gxnv_root)
+#define PL_xpv_root (PL_Vars.Gxpv_root)
+#define PL_xrv_root (PL_Vars.Gxrv_root)
+
+#else /* !PERL_GLOBAL_STRUCT */
+
+#define PL_GNo PL_No
+#define PL_GYes PL_Yes
+#define PL_Gamagic_generation PL_amagic_generation
+#define PL_Gan PL_an
+#define PL_Gbufend PL_bufend
+#define PL_Gbufptr PL_bufptr
+#define PL_Gcollation_ix PL_collation_ix
+#define PL_Gcollation_name PL_collation_name
+#define PL_Gcollation_standard PL_collation_standard
+#define PL_Gcollxfrm_base PL_collxfrm_base
+#define PL_Gcollxfrm_mult PL_collxfrm_mult
+#define PL_Gcop_seqmax PL_cop_seqmax
+#define PL_Gcryptseen PL_cryptseen
+#define PL_Gcshlen PL_cshlen
+#define PL_Gcshname PL_cshname
+#define PL_Gcurinterp PL_curinterp
+#define PL_Gcurthr PL_curthr
+#define PL_Gdebug PL_debug
+#define PL_Gdo_undump PL_do_undump
+#define PL_Gegid PL_egid
+#define PL_Gerror_count PL_error_count
+#define PL_Geuid PL_euid
+#define PL_Geval_cond PL_eval_cond
+#define PL_Geval_mutex PL_eval_mutex
+#define PL_Geval_owner PL_eval_owner
+#define PL_Gevalseq PL_evalseq
+#define PL_Gexpect PL_expect
+#define PL_Ggid PL_gid
+#define PL_Ghe_root PL_he_root
+#define PL_Ghexdigit PL_hexdigit
+#define PL_Ghints PL_hints
+#define PL_Gin_my PL_in_my
+#define PL_Gin_my_stash PL_in_my_stash
+#define PL_Glast_lop PL_last_lop
+#define PL_Glast_lop_op PL_last_lop_op
+#define PL_Glast_uni PL_last_uni
+#define PL_Glex_brackets PL_lex_brackets
+#define PL_Glex_brackstack PL_lex_brackstack
+#define PL_Glex_casemods PL_lex_casemods
+#define PL_Glex_casestack PL_lex_casestack
+#define PL_Glex_defer PL_lex_defer
+#define PL_Glex_dojoin PL_lex_dojoin
+#define PL_Glex_expect PL_lex_expect
+#define PL_Glex_fakebrack PL_lex_fakebrack
+#define PL_Glex_formbrack PL_lex_formbrack
+#define PL_Glex_inpat PL_lex_inpat
+#define PL_Glex_inwhat PL_lex_inwhat
+#define PL_Glex_op PL_lex_op
+#define PL_Glex_repl PL_lex_repl
+#define PL_Glex_starts PL_lex_starts
+#define PL_Glex_state PL_lex_state
+#define PL_Glex_stuff PL_lex_stuff
+#define PL_Glinestr PL_linestr
+#define PL_Gmalloc_mutex PL_malloc_mutex
+#define PL_Gmax_intro_pending PL_max_intro_pending
+#define PL_Gmaxo PL_maxo
+#define PL_Gmin_intro_pending PL_min_intro_pending
+#define PL_Gmulti_close PL_multi_close
+#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
+#define PL_Gnice_chunk PL_nice_chunk
+#define PL_Gnice_chunk_size PL_nice_chunk_size
+#define PL_Gninterps PL_ninterps
+#define PL_Gnomemok PL_nomemok
+#define PL_Gnthreads PL_nthreads
+#define PL_Gnthreads_cond PL_nthreads_cond
+#define PL_Gnumeric_local PL_numeric_local
+#define PL_Gnumeric_name PL_numeric_name
+#define PL_Gnumeric_standard PL_numeric_standard
+#define PL_Goldbufptr PL_oldbufptr
+#define PL_Goldoldbufptr PL_oldoldbufptr
+#define PL_Gop_seqmax PL_op_seqmax
+#define PL_Gorigalen PL_origalen
+#define PL_Gorigenviron PL_origenviron
+#define PL_Gosname PL_osname
+#define PL_Gpad_reset_pending PL_pad_reset_pending
+#define PL_Gpadix PL_padix
+#define PL_Gpadix_floor PL_padix_floor
+#define PL_Gpatleave PL_patleave
+#define PL_Gpidstatus PL_pidstatus
+#define PL_Grunops PL_runops
+#define PL_Gsh_path PL_sh_path
+#define PL_Gsighandlerp PL_sighandlerp
+#define PL_Gspecialsv_list PL_specialsv_list
+#define PL_Gsubline PL_subline
+#define PL_Gsubname PL_subname
+#define PL_Gsv_mutex PL_sv_mutex
+#define PL_Gsv_no PL_sv_no
+#define PL_Gsv_undef PL_sv_undef
+#define PL_Gsv_yes PL_sv_yes
+#define PL_Gsvref_mutex PL_svref_mutex
+#define PL_Gthisexpr PL_thisexpr
+#define PL_Gthr_key PL_thr_key
+#define PL_Gthreads_mutex PL_threads_mutex
+#define PL_Gthreadsv_names PL_threadsv_names
+#define PL_Gtokenbuf PL_tokenbuf
+#define PL_Guid PL_uid
+#define PL_Gxiv_arenaroot PL_xiv_arenaroot
+#define PL_Gxiv_root PL_xiv_root
+#define PL_Gxnv_root PL_xnv_root
+#define PL_Gxpv_root PL_xpv_root
+#define PL_Gxrv_root PL_xrv_root
+
+#ifdef EMBED
+
+
+#endif /* EMBED */
+#endif /* PERL_GLOBAL_STRUCT */
+
+
+#ifndef MIN_PERL_DEFINE
+
+#define DBsingle PL_DBsingle
+#define DBsub PL_DBsub
+#define compiling PL_compiling
+#define curcop PL_curcop
+#define curstash PL_curstash
+#define debstash PL_debstash
+#define defgv PL_defgv
+#define diehook PL_diehook
+#define dirty PL_dirty
+#define dowarn PL_dowarn
+#define errgv PL_errgv
+#define na PL_na
+#define perl_destruct_level PL_perl_destruct_level
+#define perldb PL_perldb
+#define rsfp PL_rsfp
+#define rsfp_filters PL_rsfp_filters
+#define stack_base PL_stack_base
+#define stack_sp PL_stack_sp
+#define stdingv PL_stdingv
+#define sv_arenaroot PL_sv_arenaroot
+#define sv_no PL_sv_no
+#define sv_undef PL_sv_undef
+#define sv_yes PL_sv_yes
+#define tainted PL_tainted
+#define tainting PL_tainting
+
+#endif /* MIN_PERL_DEFINE */
diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm
new file mode 100644
index 000000000000..d5137d422865
--- /dev/null
+++ b/contrib/perl5/ext/B/B.pm
@@ -0,0 +1,825 @@
+# B.pm
+#
+# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B;
+require DynaLoader;
+require Exporter;
+@ISA = qw(Exporter DynaLoader);
+@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
+ class peekop cast_I32 cstring cchar hash threadsv_names
+ main_root main_start main_cv svref_2object
+ walkoptree walkoptree_slow walkoptree_exec walksymtable
+ parents comppadlist sv_undef compile_stats timing_info);
+
+use strict;
+@B::SV::ISA = 'B::OBJECT';
+@B::NULL::ISA = 'B::SV';
+@B::PV::ISA = 'B::SV';
+@B::IV::ISA = 'B::SV';
+@B::NV::ISA = 'B::IV';
+@B::RV::ISA = 'B::SV';
+@B::PVIV::ISA = qw(B::PV B::IV);
+@B::PVNV::ISA = qw(B::PV B::NV);
+@B::PVMG::ISA = 'B::PVNV';
+@B::PVLV::ISA = 'B::PVMG';
+@B::BM::ISA = 'B::PVMG';
+@B::AV::ISA = 'B::PVMG';
+@B::GV::ISA = 'B::PVMG';
+@B::HV::ISA = 'B::PVMG';
+@B::CV::ISA = 'B::PVMG';
+@B::IO::ISA = 'B::PVMG';
+@B::FM::ISA = 'B::CV';
+
+@B::OP::ISA = 'B::OBJECT';
+@B::UNOP::ISA = 'B::OP';
+@B::BINOP::ISA = 'B::UNOP';
+@B::LOGOP::ISA = 'B::UNOP';
+@B::CONDOP::ISA = 'B::UNOP';
+@B::LISTOP::ISA = 'B::BINOP';
+@B::SVOP::ISA = 'B::OP';
+@B::GVOP::ISA = 'B::OP';
+@B::PVOP::ISA = 'B::OP';
+@B::CVOP::ISA = 'B::OP';
+@B::LOOP::ISA = 'B::LISTOP';
+@B::PMOP::ISA = 'B::LISTOP';
+@B::COP::ISA = 'B::OP';
+
+@B::SPECIAL::ISA = 'B::OBJECT';
+
+{
+ # Stop "-w" from complaining about the lack of a real B::OBJECT class
+ package B::OBJECT;
+}
+
+my $debug;
+my $op_count = 0;
+my @parents = ();
+
+sub debug {
+ my ($class, $value) = @_;
+ $debug = $value;
+ walkoptree_debug($value);
+}
+
+# sub OPf_KIDS;
+# add to .xs for perl5.002
+sub OPf_KIDS () { 4 }
+
+sub class {
+ my $obj = shift;
+ my $name = ref $obj;
+ $name =~ s/^.*:://;
+ return $name;
+}
+
+sub parents { \@parents }
+
+# For debugging
+sub peekop {
+ my $op = shift;
+ return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
+}
+
+sub walkoptree_slow {
+ my($op, $method, $level) = @_;
+ $op_count++; # just for statistics
+ $level ||= 0;
+ warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
+ $op->$method($level);
+ if ($$op && ($op->flags & OPf_KIDS)) {
+ my $kid;
+ unshift(@parents, $op);
+ for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
+ walkoptree_slow($kid, $method, $level + 1);
+ }
+ shift @parents;
+ }
+}
+
+sub compile_stats {
+ return "Total number of OPs processed: $op_count\n";
+}
+
+sub timing_info {
+ my ($sec, $min, $hr) = localtime;
+ my ($user, $sys) = times;
+ sprintf("%02d:%02d:%02d user=$user sys=$sys",
+ $hr, $min, $sec, $user, $sys);
+}
+
+my %symtable;
+sub savesym {
+ my ($obj, $value) = @_;
+# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
+ $symtable{sprintf("sym_%x", $$obj)} = $value;
+}
+
+sub objsym {
+ my $obj = shift;
+ return $symtable{sprintf("sym_%x", $$obj)};
+}
+
+sub walkoptree_exec {
+ my ($op, $method, $level) = @_;
+ my ($sym, $ppname);
+ my $prefix = " " x $level;
+ for (; $$op; $op = $op->next) {
+ $sym = objsym($op);
+ if (defined($sym)) {
+ print $prefix, "goto $sym\n";
+ return;
+ }
+ savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
+ $op->$method($level);
+ $ppname = $op->ppaddr;
+ if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
+ print $prefix, uc($1), " => {\n";
+ walkoptree_exec($op->other, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
+ my $pmreplstart = $op->pmreplstart;
+ if ($$pmreplstart) {
+ print $prefix, "PMREPLSTART => {\n";
+ walkoptree_exec($pmreplstart, $method, $level + 1);
+ print $prefix, "}\n";
+ }
+ } elsif ($ppname eq "pp_substcont") {
+ print $prefix, "SUBSTCONT => {\n";
+ walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
+ print $prefix, "}\n";
+ $op = $op->other;
+ } elsif ($ppname eq "pp_cond_expr") {
+ # pp_cond_expr never returns op_next
+ print $prefix, "TRUE => {\n";
+ walkoptree_exec($op->true, $method, $level + 1);
+ print $prefix, "}\n";
+ $op = $op->false;
+ redo;
+ } elsif ($ppname eq "pp_range") {
+ print $prefix, "TRUE => {\n";
+ walkoptree_exec($op->true, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "FALSE => {\n";
+ walkoptree_exec($op->false, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "pp_enterloop") {
+ print $prefix, "REDO => {\n";
+ walkoptree_exec($op->redoop, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "NEXT => {\n";
+ walkoptree_exec($op->nextop, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "LAST => {\n";
+ walkoptree_exec($op->lastop, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "pp_subst") {
+ my $replstart = $op->pmreplstart;
+ if ($$replstart) {
+ print $prefix, "SUBST => {\n";
+ walkoptree_exec($replstart, $method, $level + 1);
+ print $prefix, "}\n";
+ }
+ }
+ }
+}
+
+sub walksymtable {
+ my ($symref, $method, $recurse, $prefix) = @_;
+ my $sym;
+ no strict 'vars';
+ local(*glob);
+ while (($sym, *glob) = each %$symref) {
+ if ($sym =~ /::$/) {
+ $sym = $prefix . $sym;
+ if ($sym ne "main::" && &$recurse($sym)) {
+ walksymtable(\%glob, $method, $recurse, $sym);
+ }
+ } else {
+ svref_2object(\*glob)->EGV->$method();
+ }
+ }
+}
+
+{
+ package B::Section;
+ my $output_fh;
+ my %sections;
+
+ sub new {
+ my ($class, $section, $symtable, $default) = @_;
+ $output_fh ||= FileHandle->new_tmpfile;
+ my $obj = bless [-1, $section, $symtable, $default], $class;
+ $sections{$section} = $obj;
+ return $obj;
+ }
+
+ sub get {
+ my ($class, $section) = @_;
+ return $sections{$section};
+ }
+
+ sub add {
+ my $section = shift;
+ while (defined($_ = shift)) {
+ print $output_fh "$section->[1]\t$_\n";
+ $section->[0]++;
+ }
+ }
+
+ sub index {
+ my $section = shift;
+ return $section->[0];
+ }
+
+ sub name {
+ my $section = shift;
+ return $section->[1];
+ }
+
+ sub symtable {
+ my $section = shift;
+ return $section->[2];
+ }
+
+ sub default {
+ my $section = shift;
+ return $section->[3];
+ }
+
+ sub output {
+ my ($section, $fh, $format) = @_;
+ my $name = $section->name;
+ my $sym = $section->symtable || {};
+ my $default = $section->default;
+
+ seek($output_fh, 0, 0);
+ while (<$output_fh>) {
+ chomp;
+ s/^(.*?)\t//;
+ if ($1 eq $name) {
+ s{(s\\_[0-9a-f]+)} {
+ exists($sym->{$1}) ? $sym->{$1} : $default;
+ }ge;
+ printf $fh $format, $_;
+ }
+ }
+ }
+}
+
+bootstrap B;
+
+1;
+
+__END__
+
+=head1 NAME
+
+B - The Perl Compiler
+
+=head1 SYNOPSIS
+
+ use B;
+
+=head1 DESCRIPTION
+
+The C<B> module supplies classes which allow a Perl program to delve
+into its own innards. It is the module used to implement the
+"backends" of the Perl compiler. Usage of the compiler does not
+require knowledge of this module: see the F<O> module for the
+user-visible part. The C<B> module is of use to those who want to
+write new compiler backends. This documentation assumes that the
+reader knows a fair amount about perl's internals including such
+things as SVs, OPs and the internal symbol table and syntax tree
+of a program.
+
+=head1 OVERVIEW OF CLASSES
+
+The C structures used by Perl's internals to hold SV and OP
+information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
+class hierarchy and the C<B> module gives access to them via a true
+object hierarchy. Structure fields which point to other objects
+(whether types of SV or types of OP) are represented by the C<B>
+module as Perl objects of the appropriate class. The bulk of the C<B>
+module is the methods for accessing fields of these structures. Note
+that all access is read-only: you cannot modify the internals by
+using this module.
+
+=head2 SV-RELATED CLASSES
+
+B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
+B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
+the obvious way to the underlying C structures of similar names. The
+inheritance hierarchy mimics the underlying C "inheritance". Access
+methods correspond to the underlying C macros for field access,
+usually with the leading "class indication" prefix removed (Sv, Av,
+Hv, ...). The leading prefix is only left in cases where its removal
+would cause a clash in method name. For example, C<GvREFCNT> stays
+as-is since its abbreviation would clash with the "superclass" method
+C<REFCNT> (corresponding to the C function C<SvREFCNT>).
+
+=head2 B::SV METHODS
+
+=over 4
+
+=item REFCNT
+
+=item FLAGS
+
+=back
+
+=head2 B::IV METHODS
+
+=over 4
+
+=item IV
+
+=item IVX
+
+=item needs64bits
+
+=item packiv
+
+=back
+
+=head2 B::NV METHODS
+
+=over 4
+
+=item NV
+
+=item NVX
+
+=back
+
+=head2 B::RV METHODS
+
+=over 4
+
+=item RV
+
+=back
+
+=head2 B::PV METHODS
+
+=over 4
+
+=item PV
+
+=back
+
+=head2 B::PVMG METHODS
+
+=over 4
+
+=item MAGIC
+
+=item SvSTASH
+
+=back
+
+=head2 B::MAGIC METHODS
+
+=over 4
+
+=item MOREMAGIC
+
+=item PRIVATE
+
+=item TYPE
+
+=item FLAGS
+
+=item OBJ
+
+=item PTR
+
+=back
+
+=head2 B::PVLV METHODS
+
+=over 4
+
+=item TARGOFF
+
+=item TARGLEN
+
+=item TYPE
+
+=item TARG
+
+=back
+
+=head2 B::BM METHODS
+
+=over 4
+
+=item USEFUL
+
+=item PREVIOUS
+
+=item RARE
+
+=item TABLE
+
+=back
+
+=head2 B::GV METHODS
+
+=over 4
+
+=item NAME
+
+=item STASH
+
+=item SV
+
+=item IO
+
+=item FORM
+
+=item AV
+
+=item HV
+
+=item EGV
+
+=item CV
+
+=item CVGEN
+
+=item LINE
+
+=item FILEGV
+
+=item GvREFCNT
+
+=item FLAGS
+
+=back
+
+=head2 B::IO METHODS
+
+=over 4
+
+=item LINES
+
+=item PAGE
+
+=item PAGE_LEN
+
+=item LINES_LEFT
+
+=item TOP_NAME
+
+=item TOP_GV
+
+=item FMT_NAME
+
+=item FMT_GV
+
+=item BOTTOM_NAME
+
+=item BOTTOM_GV
+
+=item SUBPROCESS
+
+=item IoTYPE
+
+=item IoFLAGS
+
+=back
+
+=head2 B::AV METHODS
+
+=over 4
+
+=item FILL
+
+=item MAX
+
+=item OFF
+
+=item ARRAY
+
+=item AvFLAGS
+
+=back
+
+=head2 B::CV METHODS
+
+=over 4
+
+=item STASH
+
+=item START
+
+=item ROOT
+
+=item GV
+
+=item FILEGV
+
+=item DEPTH
+
+=item PADLIST
+
+=item OUTSIDE
+
+=item XSUB
+
+=item XSUBANY
+
+=back
+
+=head2 B::HV METHODS
+
+=over 4
+
+=item FILL
+
+=item MAX
+
+=item KEYS
+
+=item RITER
+
+=item NAME
+
+=item PMROOT
+
+=item ARRAY
+
+=back
+
+=head2 OP-RELATED CLASSES
+
+B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP,
+B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
+These classes correspond in
+the obvious way to the underlying C structures of similar names. The
+inheritance hierarchy mimics the underlying C "inheritance". Access
+methods correspond to the underlying C structre field names, with the
+leading "class indication" prefix removed (op_).
+
+=head2 B::OP METHODS
+
+=over 4
+
+=item next
+
+=item sibling
+
+=item ppaddr
+
+This returns the function name as a string (e.g. pp_add, pp_rv2av).
+
+=item desc
+
+This returns the op description from the global C op_desc array
+(e.g. "addition" "array deref").
+
+=item targ
+
+=item type
+
+=item seq
+
+=item flags
+
+=item private
+
+=back
+
+=head2 B::UNOP METHOD
+
+=over 4
+
+=item first
+
+=back
+
+=head2 B::BINOP METHOD
+
+=over 4
+
+=item last
+
+=back
+
+=head2 B::LOGOP METHOD
+
+=over 4
+
+=item other
+
+=back
+
+=head2 B::CONDOP METHODS
+
+=over 4
+
+=item true
+
+=item false
+
+=back
+
+=head2 B::LISTOP METHOD
+
+=over 4
+
+=item children
+
+=back
+
+=head2 B::PMOP METHODS
+
+=over 4
+
+=item pmreplroot
+
+=item pmreplstart
+
+=item pmnext
+
+=item pmregexp
+
+=item pmflags
+
+=item pmpermflags
+
+=item precomp
+
+=back
+
+=head2 B::SVOP METHOD
+
+=over 4
+
+=item sv
+
+=back
+
+=head2 B::GVOP METHOD
+
+=over 4
+
+=item gv
+
+=back
+
+=head2 B::PVOP METHOD
+
+=over 4
+
+=item pv
+
+=back
+
+=head2 B::LOOP METHODS
+
+=over 4
+
+=item redoop
+
+=item nextop
+
+=item lastop
+
+=back
+
+=head2 B::COP METHODS
+
+=over 4
+
+=item label
+
+=item stash
+
+=item filegv
+
+=item cop_seq
+
+=item arybase
+
+=item line
+
+=back
+
+=head1 FUNCTIONS EXPORTED BY C<B>
+
+The C<B> module exports a variety of functions: some are simple
+utility functions, others provide a Perl program with a way to
+get an initial "handle" on an internal object.
+
+=over 4
+
+=item main_cv
+
+Return the (faked) CV corresponding to the main part of the Perl
+program.
+
+=item main_root
+
+Returns the root op (i.e. an object in the appropriate B::OP-derived
+class) of the main part of the Perl program.
+
+=item main_start
+
+Returns the starting op of the main part of the Perl program.
+
+=item comppadlist
+
+Returns the AV object (i.e. in class B::AV) of the global comppadlist.
+
+=item sv_undef
+
+Returns the SV object corresponding to the C variable C<sv_undef>.
+
+=item sv_yes
+
+Returns the SV object corresponding to the C variable C<sv_yes>.
+
+=item sv_no
+
+Returns the SV object corresponding to the C variable C<sv_no>.
+
+=item walkoptree(OP, METHOD)
+
+Does a tree-walk of the syntax tree based at OP and calls METHOD on
+each op it visits. Each node is visited before its children. If
+C<walkoptree_debug> (q.v.) has been called to turn debugging on then
+the method C<walkoptree_debug> is called on each op before METHOD is
+called.
+
+=item walkoptree_debug(DEBUG)
+
+Returns the current debugging flag for C<walkoptree>. If the optional
+DEBUG argument is non-zero, it sets the debugging flag to that. See
+the description of C<walkoptree> above for what the debugging flag
+does.
+
+=item walksymtable(SYMREF, METHOD, RECURSE)
+
+Walk the symbol table starting at SYMREF and call METHOD on each
+symbol visited. When the walk reached package symbols "Foo::" it
+invokes RECURSE and only recurses into the package if that sub
+returns true.
+
+=item svref_2object(SV)
+
+Takes any Perl variable and turns it into an object in the
+appropriate B::OP-derived or B::SV-derived class. Apart from functions
+such as C<main_root>, this is the primary way to get an initial
+"handle" on a internal perl data structure which can then be followed
+with the other access methods.
+
+=item ppname(OPNUM)
+
+Return the PP function name (e.g. "pp_add") of op number OPNUM.
+
+=item hash(STR)
+
+Returns a string in the form "0x..." representing the value of the
+internal hash function used by perl on string STR.
+
+=item cast_I32(I)
+
+Casts I to the internal I32 type used by that perl.
+
+
+=item minus_c
+
+Does the equivalent of the C<-c> command-line option. Obviously, this
+is only useful in a BEGIN block or else the flag is set too late.
+
+
+=item cstring(STR)
+
+Returns a double-quote-surrounded escaped version of STR which can
+be used as a string in C source code.
+
+=item class(OBJ)
+
+Returns the class of an object without the part of the classname
+preceding the first "::". This is used to turn "B::UNOP" into
+"UNOP" for example.
+
+=item threadsv_names
+
+In a perl compiled for threads, this returns a list of the special
+per-thread threadsv variables.
+
+=item byteload_fh(FILEHANDLE)
+
+Load the contents of FILEHANDLE as bytecode. See documentation for
+the B<Bytecode> module in F<B::Backend> for how to generate bytecode.
+
+=back
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B.xs b/contrib/perl5/ext/B/B.xs
new file mode 100644
index 000000000000..8dbc915f92fd
--- /dev/null
+++ b/contrib/perl5/ext/B/B.xs
@@ -0,0 +1,1207 @@
+/* B.xs
+ *
+ * Copyright (c) 1996 Malcolm Beattie
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "INTERN.h"
+
+#ifdef PERL_OBJECT
+#undef op_name
+#undef opargs
+#undef op_desc
+#define op_name (pPerl->Perl_get_op_names())
+#define opargs (pPerl->Perl_get_opargs())
+#define op_desc (pPerl->Perl_get_op_descs())
+#endif
+
+#ifdef PerlIO
+typedef PerlIO * InputStream;
+#else
+typedef FILE * InputStream;
+#endif
+
+
+static char *svclassnames[] = {
+ "B::NULL",
+ "B::IV",
+ "B::NV",
+ "B::RV",
+ "B::PV",
+ "B::PVIV",
+ "B::PVNV",
+ "B::PVMG",
+ "B::BM",
+ "B::PVLV",
+ "B::AV",
+ "B::HV",
+ "B::CV",
+ "B::GV",
+ "B::FM",
+ "B::IO",
+};
+
+typedef enum {
+ OPc_NULL, /* 0 */
+ OPc_BASEOP, /* 1 */
+ OPc_UNOP, /* 2 */
+ OPc_BINOP, /* 3 */
+ OPc_LOGOP, /* 4 */
+ OPc_CONDOP, /* 5 */
+ OPc_LISTOP, /* 6 */
+ OPc_PMOP, /* 7 */
+ OPc_SVOP, /* 8 */
+ OPc_GVOP, /* 9 */
+ OPc_PVOP, /* 10 */
+ OPc_CVOP, /* 11 */
+ OPc_LOOP, /* 12 */
+ OPc_COP /* 13 */
+} opclass;
+
+static char *opclassnames[] = {
+ "B::NULL",
+ "B::OP",
+ "B::UNOP",
+ "B::BINOP",
+ "B::LOGOP",
+ "B::CONDOP",
+ "B::LISTOP",
+ "B::PMOP",
+ "B::SVOP",
+ "B::GVOP",
+ "B::PVOP",
+ "B::CVOP",
+ "B::LOOP",
+ "B::COP"
+};
+
+static int walkoptree_debug = 0; /* Flag for walkoptree debug hook */
+
+static opclass
+cc_opclass(OP *o)
+{
+ if (!o)
+ return OPc_NULL;
+
+ if (o->op_type == 0)
+ return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+
+ if (o->op_type == OP_SASSIGN)
+ return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP);
+
+ switch (opargs[o->op_type] & OA_CLASS_MASK) {
+ case OA_BASEOP:
+ return OPc_BASEOP;
+
+ case OA_UNOP:
+ return OPc_UNOP;
+
+ case OA_BINOP:
+ return OPc_BINOP;
+
+ case OA_LOGOP:
+ return OPc_LOGOP;
+
+ case OA_CONDOP:
+ return OPc_CONDOP;
+
+ case OA_LISTOP:
+ return OPc_LISTOP;
+
+ case OA_PMOP:
+ return OPc_PMOP;
+
+ case OA_SVOP:
+ return OPc_SVOP;
+
+ case OA_GVOP:
+ return OPc_GVOP;
+
+ case OA_PVOP:
+ return OPc_PVOP;
+
+ case OA_LOOP:
+ return OPc_LOOP;
+
+ case OA_COP:
+ return OPc_COP;
+
+ case OA_BASEOP_OR_UNOP:
+ /*
+ * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on
+ * whether parens were seen. perly.y uses OPf_SPECIAL to
+ * signal whether a BASEOP had empty parens or none.
+ * Some other UNOPs are created later, though, so the best
+ * test is OPf_KIDS, which is set in newUNOP.
+ */
+ return (o->op_flags & OPf_KIDS) ? OPc_UNOP : OPc_BASEOP;
+
+ case OA_FILESTATOP:
+ /*
+ * The file stat OPs are created via UNI(OP_foo) in toke.c but use
+ * the OPf_REF flag to distinguish between OP types instead of the
+ * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we
+ * return OPc_UNOP so that walkoptree can find our children. If
+ * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set
+ * (no argument to the operator) it's an OP; with OPf_REF set it's
+ * a GVOP (and op_gv is the GV for the filehandle argument).
+ */
+ return ((o->op_flags & OPf_KIDS) ? OPc_UNOP :
+ (o->op_flags & OPf_REF) ? OPc_GVOP : OPc_BASEOP);
+
+ case OA_LOOPEXOP:
+ /*
+ * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a
+ * label was omitted (in which case it's a BASEOP) or else a term was
+ * seen. In this last case, all except goto are definitely PVOP but
+ * goto is either a PVOP (with an ordinary constant label), an UNOP
+ * with OPf_STACKED (with a non-constant non-sub) or an UNOP for
+ * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to
+ * get set.
+ */
+ if (o->op_flags & OPf_STACKED)
+ return OPc_UNOP;
+ else if (o->op_flags & OPf_SPECIAL)
+ return OPc_BASEOP;
+ else
+ return OPc_PVOP;
+ }
+ warn("can't determine class of operator %s, assuming BASEOP\n",
+ op_name[o->op_type]);
+ return OPc_BASEOP;
+}
+
+static char *
+cc_opclassname(OP *o)
+{
+ return opclassnames[cc_opclass(o)];
+}
+
+static SV *
+make_sv_object(SV *arg, SV *sv)
+{
+ char *type = 0;
+ IV iv;
+
+ for (iv = 0; iv < sizeof(PL_specialsv_list)/sizeof(SV*); iv++) {
+ if (sv == PL_specialsv_list[iv]) {
+ type = "B::SPECIAL";
+ break;
+ }
+ }
+ if (!type) {
+ type = svclassnames[SvTYPE(sv)];
+ iv = (IV)sv;
+ }
+ sv_setiv(newSVrv(arg, type), iv);
+ return arg;
+}
+
+static SV *
+make_mg_object(SV *arg, MAGIC *mg)
+{
+ sv_setiv(newSVrv(arg, "B::MAGIC"), (IV)mg);
+ return arg;
+}
+
+static SV *
+cstring(SV *sv)
+{
+ SV *sstr = newSVpv("", 0);
+ STRLEN len;
+ char *s;
+
+ if (!SvOK(sv))
+ sv_setpvn(sstr, "0", 1);
+ else
+ {
+ /* XXX Optimise? */
+ s = SvPV(sv, len);
+ sv_catpv(sstr, "\"");
+ for (; len; len--, s++)
+ {
+ /* At least try a little for readability */
+ if (*s == '"')
+ sv_catpv(sstr, "\\\"");
+ else if (*s == '\\')
+ sv_catpv(sstr, "\\\\");
+ else if (*s >= ' ' && *s < 127) /* XXX not portable */
+ sv_catpvn(sstr, s, 1);
+ else if (*s == '\n')
+ sv_catpv(sstr, "\\n");
+ else if (*s == '\r')
+ sv_catpv(sstr, "\\r");
+ else if (*s == '\t')
+ sv_catpv(sstr, "\\t");
+ else if (*s == '\a')
+ sv_catpv(sstr, "\\a");
+ else if (*s == '\b')
+ sv_catpv(sstr, "\\b");
+ else if (*s == '\f')
+ sv_catpv(sstr, "\\f");
+ else if (*s == '\v')
+ sv_catpv(sstr, "\\v");
+ else
+ {
+ /* no trigraph support */
+ char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
+ /* Don't want promotion of a signed -1 char in sprintf args */
+ unsigned char c = (unsigned char) *s;
+ sprintf(escbuff, "\\%03o", c);
+ sv_catpv(sstr, escbuff);
+ }
+ /* XXX Add line breaks if string is long */
+ }
+ sv_catpv(sstr, "\"");
+ }
+ return sstr;
+}
+
+static SV *
+cchar(SV *sv)
+{
+ SV *sstr = newSVpv("'", 0);
+ char *s = SvPV(sv, PL_na);
+
+ if (*s == '\'')
+ sv_catpv(sstr, "\\'");
+ else if (*s == '\\')
+ sv_catpv(sstr, "\\\\");
+ else if (*s >= ' ' && *s < 127) /* XXX not portable */
+ sv_catpvn(sstr, s, 1);
+ else if (*s == '\n')
+ sv_catpv(sstr, "\\n");
+ else if (*s == '\r')
+ sv_catpv(sstr, "\\r");
+ else if (*s == '\t')
+ sv_catpv(sstr, "\\t");
+ else if (*s == '\a')
+ sv_catpv(sstr, "\\a");
+ else if (*s == '\b')
+ sv_catpv(sstr, "\\b");
+ else if (*s == '\f')
+ sv_catpv(sstr, "\\f");
+ else if (*s == '\v')
+ sv_catpv(sstr, "\\v");
+ else
+ {
+ /* no trigraph support */
+ char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */
+ /* Don't want promotion of a signed -1 char in sprintf args */
+ unsigned char c = (unsigned char) *s;
+ sprintf(escbuff, "\\%03o", c);
+ sv_catpv(sstr, escbuff);
+ }
+ sv_catpv(sstr, "'");
+ return sstr;
+}
+
+#ifdef INDIRECT_BGET_MACROS
+void freadpv(U32 len, void *data)
+{
+ New(666, pv.xpv_pv, len, char);
+ fread(pv.xpv_pv, 1, len, (FILE*)data);
+ pv.xpv_len = len;
+ pv.xpv_cur = len - 1;
+}
+
+void byteload_fh(InputStream fp)
+{
+ struct bytestream bs;
+ bs.data = fp;
+ bs.fgetc = (int(*) _((void*)))fgetc;
+ bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread;
+ bs.freadpv = freadpv;
+ byterun(bs);
+}
+
+static int fgetc_fromstring(void *data)
+{
+ char **strp = (char **)data;
+ return *(*strp)++;
+}
+
+static int fread_fromstring(char *argp, size_t elemsize, size_t nelem,
+ void *data)
+{
+ char **strp = (char **)data;
+ size_t len = elemsize * nelem;
+
+ memcpy(argp, *strp, len);
+ *strp += len;
+ return (int)len;
+}
+
+static void freadpv_fromstring(U32 len, void *data)
+{
+ char **strp = (char **)data;
+
+ New(666, pv.xpv_pv, len, char);
+ memcpy(pv.xpv_pv, *strp, len);
+ pv.xpv_len = len;
+ pv.xpv_cur = len - 1;
+ *strp += len;
+}
+
+void byteload_string(char *str)
+{
+ struct bytestream bs;
+ bs.data = &str;
+ bs.fgetc = fgetc_fromstring;
+ bs.fread = fread_fromstring;
+ bs.freadpv = freadpv_fromstring;
+ byterun(bs);
+}
+#else
+void byteload_fh(InputStream fp)
+{
+ byterun(fp);
+}
+
+void byteload_string(char *str)
+{
+ croak("Must compile with -DINDIRECT_BGET_MACROS for byteload_string");
+}
+#endif /* INDIRECT_BGET_MACROS */
+
+void
+walkoptree(SV *opsv, char *method)
+{
+ dSP;
+ OP *o;
+
+ if (!SvROK(opsv))
+ croak("opsv is not a reference");
+ opsv = sv_mortalcopy(opsv);
+ o = (OP*)SvIV((SV*)SvRV(opsv));
+ if (walkoptree_debug) {
+ PUSHMARK(sp);
+ XPUSHs(opsv);
+ PUTBACK;
+ perl_call_method("walkoptree_debug", G_DISCARD);
+ }
+ PUSHMARK(sp);
+ XPUSHs(opsv);
+ PUTBACK;
+ perl_call_method(method, G_DISCARD);
+ if (o && (o->op_flags & OPf_KIDS)) {
+ OP *kid;
+ for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
+ /* Use the same opsv. Rely on methods not to mess it up. */
+ sv_setiv(newSVrv(opsv, cc_opclassname(kid)), (IV)kid);
+ walkoptree(opsv, method);
+ }
+ }
+}
+
+typedef OP *B__OP;
+typedef UNOP *B__UNOP;
+typedef BINOP *B__BINOP;
+typedef LOGOP *B__LOGOP;
+typedef CONDOP *B__CONDOP;
+typedef LISTOP *B__LISTOP;
+typedef PMOP *B__PMOP;
+typedef SVOP *B__SVOP;
+typedef GVOP *B__GVOP;
+typedef PVOP *B__PVOP;
+typedef LOOP *B__LOOP;
+typedef COP *B__COP;
+
+typedef SV *B__SV;
+typedef SV *B__IV;
+typedef SV *B__PV;
+typedef SV *B__NV;
+typedef SV *B__PVMG;
+typedef SV *B__PVLV;
+typedef SV *B__BM;
+typedef SV *B__RV;
+typedef AV *B__AV;
+typedef HV *B__HV;
+typedef CV *B__CV;
+typedef GV *B__GV;
+typedef IO *B__IO;
+
+typedef MAGIC *B__MAGIC;
+
+MODULE = B PACKAGE = B PREFIX = B_
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ INIT_SPECIALSV_LIST;
+
+#define B_main_cv() PL_main_cv
+#define B_main_root() PL_main_root
+#define B_main_start() PL_main_start
+#define B_comppadlist() (PL_main_cv ? CvPADLIST(PL_main_cv) : CvPADLIST(PL_compcv))
+#define B_sv_undef() &PL_sv_undef
+#define B_sv_yes() &PL_sv_yes
+#define B_sv_no() &PL_sv_no
+
+B::CV
+B_main_cv()
+
+B::OP
+B_main_root()
+
+B::OP
+B_main_start()
+
+B::AV
+B_comppadlist()
+
+B::SV
+B_sv_undef()
+
+B::SV
+B_sv_yes()
+
+B::SV
+B_sv_no()
+
+MODULE = B PACKAGE = B
+
+
+void
+walkoptree(opsv, method)
+ SV * opsv
+ char * method
+
+int
+walkoptree_debug(...)
+ CODE:
+ RETVAL = walkoptree_debug;
+ if (items > 0 && SvTRUE(ST(1)))
+ walkoptree_debug = 1;
+ OUTPUT:
+ RETVAL
+
+int
+byteload_fh(fp)
+ InputStream fp
+ CODE:
+ byteload_fh(fp);
+ RETVAL = 1;
+ OUTPUT:
+ RETVAL
+
+void
+byteload_string(str)
+ char * str
+
+#define address(sv) (IV)sv
+
+IV
+address(sv)
+ SV * sv
+
+B::SV
+svref_2object(sv)
+ SV * sv
+ CODE:
+ if (!SvROK(sv))
+ croak("argument is not a reference");
+ RETVAL = (SV*)SvRV(sv);
+ OUTPUT:
+ RETVAL
+
+void
+ppname(opnum)
+ int opnum
+ CODE:
+ ST(0) = sv_newmortal();
+ if (opnum >= 0 && opnum < PL_maxo) {
+ sv_setpvn(ST(0), "pp_", 3);
+ sv_catpv(ST(0), op_name[opnum]);
+ }
+
+void
+hash(sv)
+ SV * sv
+ CODE:
+ char *s;
+ STRLEN len;
+ U32 hash = 0;
+ char hexhash[11]; /* must fit "0xffffffff" plus trailing \0 */
+ s = SvPV(sv, len);
+ while (len--)
+ hash = hash * 33 + *s++;
+ sprintf(hexhash, "0x%x", hash);
+ ST(0) = sv_2mortal(newSVpv(hexhash, 0));
+
+#define cast_I32(foo) (I32)foo
+IV
+cast_I32(i)
+ IV i
+
+void
+minus_c()
+ CODE:
+ PL_minus_c = TRUE;
+
+SV *
+cstring(sv)
+ SV * sv
+
+SV *
+cchar(sv)
+ SV * sv
+
+void
+threadsv_names()
+ PPCODE:
+#ifdef USE_THREADS
+ int i;
+ STRLEN len = strlen(PL_threadsv_names);
+
+ EXTEND(sp, len);
+ for (i = 0; i < len; i++)
+ PUSHs(sv_2mortal(newSVpv(&PL_threadsv_names[i], 1)));
+#endif
+
+
+#define OP_next(o) o->op_next
+#define OP_sibling(o) o->op_sibling
+#define OP_desc(o) op_desc[o->op_type]
+#define OP_targ(o) o->op_targ
+#define OP_type(o) o->op_type
+#define OP_seq(o) o->op_seq
+#define OP_flags(o) o->op_flags
+#define OP_private(o) o->op_private
+
+MODULE = B PACKAGE = B::OP PREFIX = OP_
+
+B::OP
+OP_next(o)
+ B::OP o
+
+B::OP
+OP_sibling(o)
+ B::OP o
+
+char *
+OP_ppaddr(o)
+ B::OP o
+ CODE:
+ ST(0) = sv_newmortal();
+ sv_setpvn(ST(0), "pp_", 3);
+ sv_catpv(ST(0), op_name[o->op_type]);
+
+char *
+OP_desc(o)
+ B::OP o
+
+U16
+OP_targ(o)
+ B::OP o
+
+U16
+OP_type(o)
+ B::OP o
+
+U16
+OP_seq(o)
+ B::OP o
+
+U8
+OP_flags(o)
+ B::OP o
+
+U8
+OP_private(o)
+ B::OP o
+
+#define UNOP_first(o) o->op_first
+
+MODULE = B PACKAGE = B::UNOP PREFIX = UNOP_
+
+B::OP
+UNOP_first(o)
+ B::UNOP o
+
+#define BINOP_last(o) o->op_last
+
+MODULE = B PACKAGE = B::BINOP PREFIX = BINOP_
+
+B::OP
+BINOP_last(o)
+ B::BINOP o
+
+#define LOGOP_other(o) o->op_other
+
+MODULE = B PACKAGE = B::LOGOP PREFIX = LOGOP_
+
+B::OP
+LOGOP_other(o)
+ B::LOGOP o
+
+#define CONDOP_true(o) o->op_true
+#define CONDOP_false(o) o->op_false
+
+MODULE = B PACKAGE = B::CONDOP PREFIX = CONDOP_
+
+B::OP
+CONDOP_true(o)
+ B::CONDOP o
+
+B::OP
+CONDOP_false(o)
+ B::CONDOP o
+
+#define LISTOP_children(o) o->op_children
+
+MODULE = B PACKAGE = B::LISTOP PREFIX = LISTOP_
+
+U32
+LISTOP_children(o)
+ B::LISTOP o
+
+#define PMOP_pmreplroot(o) o->op_pmreplroot
+#define PMOP_pmreplstart(o) o->op_pmreplstart
+#define PMOP_pmnext(o) o->op_pmnext
+#define PMOP_pmregexp(o) o->op_pmregexp
+#define PMOP_pmflags(o) o->op_pmflags
+#define PMOP_pmpermflags(o) o->op_pmpermflags
+
+MODULE = B PACKAGE = B::PMOP PREFIX = PMOP_
+
+void
+PMOP_pmreplroot(o)
+ B::PMOP o
+ OP * root = NO_INIT
+ CODE:
+ ST(0) = sv_newmortal();
+ root = o->op_pmreplroot;
+ /* OP_PUSHRE stores an SV* instead of an OP* in op_pmreplroot */
+ if (o->op_type == OP_PUSHRE) {
+ sv_setiv(newSVrv(ST(0), root ?
+ svclassnames[SvTYPE((SV*)root)] : "B::SV"),
+ (IV)root);
+ }
+ else {
+ sv_setiv(newSVrv(ST(0), cc_opclassname(root)), (IV)root);
+ }
+
+B::OP
+PMOP_pmreplstart(o)
+ B::PMOP o
+
+B::PMOP
+PMOP_pmnext(o)
+ B::PMOP o
+
+U16
+PMOP_pmflags(o)
+ B::PMOP o
+
+U16
+PMOP_pmpermflags(o)
+ B::PMOP o
+
+void
+PMOP_precomp(o)
+ B::PMOP o
+ REGEXP * rx = NO_INIT
+ CODE:
+ ST(0) = sv_newmortal();
+ rx = o->op_pmregexp;
+ if (rx)
+ sv_setpvn(ST(0), rx->precomp, rx->prelen);
+
+#define SVOP_sv(o) o->op_sv
+
+MODULE = B PACKAGE = B::SVOP PREFIX = SVOP_
+
+
+B::SV
+SVOP_sv(o)
+ B::SVOP o
+
+#define GVOP_gv(o) o->op_gv
+
+MODULE = B PACKAGE = B::GVOP PREFIX = GVOP_
+
+
+B::GV
+GVOP_gv(o)
+ B::GVOP o
+
+MODULE = B PACKAGE = B::PVOP PREFIX = PVOP_
+
+void
+PVOP_pv(o)
+ B::PVOP o
+ CODE:
+ /*
+ * OP_TRANS uses op_pv to point to a table of 256 shorts
+ * whereas other PVOPs point to a null terminated string.
+ */
+ ST(0) = sv_2mortal(newSVpv(o->op_pv, (o->op_type == OP_TRANS) ?
+ 256 * sizeof(short) : 0));
+
+#define LOOP_redoop(o) o->op_redoop
+#define LOOP_nextop(o) o->op_nextop
+#define LOOP_lastop(o) o->op_lastop
+
+MODULE = B PACKAGE = B::LOOP PREFIX = LOOP_
+
+
+B::OP
+LOOP_redoop(o)
+ B::LOOP o
+
+B::OP
+LOOP_nextop(o)
+ B::LOOP o
+
+B::OP
+LOOP_lastop(o)
+ B::LOOP o
+
+#define COP_label(o) o->cop_label
+#define COP_stash(o) o->cop_stash
+#define COP_filegv(o) o->cop_filegv
+#define COP_cop_seq(o) o->cop_seq
+#define COP_arybase(o) o->cop_arybase
+#define COP_line(o) o->cop_line
+
+MODULE = B PACKAGE = B::COP PREFIX = COP_
+
+char *
+COP_label(o)
+ B::COP o
+
+B::HV
+COP_stash(o)
+ B::COP o
+
+B::GV
+COP_filegv(o)
+ B::COP o
+
+U32
+COP_cop_seq(o)
+ B::COP o
+
+I32
+COP_arybase(o)
+ B::COP o
+
+U16
+COP_line(o)
+ B::COP o
+
+MODULE = B PACKAGE = B::SV PREFIX = Sv
+
+U32
+SvREFCNT(sv)
+ B::SV sv
+
+U32
+SvFLAGS(sv)
+ B::SV sv
+
+MODULE = B PACKAGE = B::IV PREFIX = Sv
+
+IV
+SvIV(sv)
+ B::IV sv
+
+IV
+SvIVX(sv)
+ B::IV sv
+
+MODULE = B PACKAGE = B::IV
+
+#define needs64bits(sv) ((I32)SvIVX(sv) != SvIVX(sv))
+
+int
+needs64bits(sv)
+ B::IV sv
+
+void
+packiv(sv)
+ B::IV sv
+ CODE:
+ if (sizeof(IV) == 8) {
+ U32 wp[2];
+ IV iv = SvIVX(sv);
+ /*
+ * The following way of spelling 32 is to stop compilers on
+ * 32-bit architectures from moaning about the shift count
+ * being >= the width of the type. Such architectures don't
+ * reach this code anyway (unless sizeof(IV) > 8 but then
+ * everything else breaks too so I'm not fussed at the moment).
+ */
+ wp[0] = htonl(((U32)iv) >> (sizeof(IV)*4));
+ wp[1] = htonl(iv & 0xffffffff);
+ ST(0) = sv_2mortal(newSVpv((char *)wp, 8));
+ } else {
+ U32 w = htonl((U32)SvIVX(sv));
+ ST(0) = sv_2mortal(newSVpv((char *)&w, 4));
+ }
+
+MODULE = B PACKAGE = B::NV PREFIX = Sv
+
+double
+SvNV(sv)
+ B::NV sv
+
+double
+SvNVX(sv)
+ B::NV sv
+
+MODULE = B PACKAGE = B::RV PREFIX = Sv
+
+B::SV
+SvRV(sv)
+ B::RV sv
+
+MODULE = B PACKAGE = B::PV PREFIX = Sv
+
+void
+SvPV(sv)
+ B::PV sv
+ CODE:
+ ST(0) = sv_newmortal();
+ sv_setpvn(ST(0), SvPVX(sv), SvCUR(sv));
+
+MODULE = B PACKAGE = B::PVMG PREFIX = Sv
+
+void
+SvMAGIC(sv)
+ B::PVMG sv
+ MAGIC * mg = NO_INIT
+ PPCODE:
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
+ XPUSHs(make_mg_object(sv_newmortal(), mg));
+
+MODULE = B PACKAGE = B::PVMG
+
+B::HV
+SvSTASH(sv)
+ B::PVMG sv
+
+#define MgMOREMAGIC(mg) mg->mg_moremagic
+#define MgPRIVATE(mg) mg->mg_private
+#define MgTYPE(mg) mg->mg_type
+#define MgFLAGS(mg) mg->mg_flags
+#define MgOBJ(mg) mg->mg_obj
+
+MODULE = B PACKAGE = B::MAGIC PREFIX = Mg
+
+B::MAGIC
+MgMOREMAGIC(mg)
+ B::MAGIC mg
+
+U16
+MgPRIVATE(mg)
+ B::MAGIC mg
+
+char
+MgTYPE(mg)
+ B::MAGIC mg
+
+U8
+MgFLAGS(mg)
+ B::MAGIC mg
+
+B::SV
+MgOBJ(mg)
+ B::MAGIC mg
+
+void
+MgPTR(mg)
+ B::MAGIC mg
+ CODE:
+ ST(0) = sv_newmortal();
+ if (mg->mg_ptr)
+ sv_setpvn(ST(0), mg->mg_ptr, mg->mg_len);
+
+MODULE = B PACKAGE = B::PVLV PREFIX = Lv
+
+U32
+LvTARGOFF(sv)
+ B::PVLV sv
+
+U32
+LvTARGLEN(sv)
+ B::PVLV sv
+
+char
+LvTYPE(sv)
+ B::PVLV sv
+
+B::SV
+LvTARG(sv)
+ B::PVLV sv
+
+MODULE = B PACKAGE = B::BM PREFIX = Bm
+
+I32
+BmUSEFUL(sv)
+ B::BM sv
+
+U16
+BmPREVIOUS(sv)
+ B::BM sv
+
+U8
+BmRARE(sv)
+ B::BM sv
+
+void
+BmTABLE(sv)
+ B::BM sv
+ STRLEN len = NO_INIT
+ char * str = NO_INIT
+ CODE:
+ str = SvPV(sv, len);
+ /* Boyer-Moore table is just after string and its safety-margin \0 */
+ ST(0) = sv_2mortal(newSVpv(str + len + 1, 256));
+
+MODULE = B PACKAGE = B::GV PREFIX = Gv
+
+void
+GvNAME(gv)
+ B::GV gv
+ CODE:
+ ST(0) = sv_2mortal(newSVpv(GvNAME(gv), GvNAMELEN(gv)));
+
+B::HV
+GvSTASH(gv)
+ B::GV gv
+
+B::SV
+GvSV(gv)
+ B::GV gv
+
+B::IO
+GvIO(gv)
+ B::GV gv
+
+B::CV
+GvFORM(gv)
+ B::GV gv
+
+B::AV
+GvAV(gv)
+ B::GV gv
+
+B::HV
+GvHV(gv)
+ B::GV gv
+
+B::GV
+GvEGV(gv)
+ B::GV gv
+
+B::CV
+GvCV(gv)
+ B::GV gv
+
+U32
+GvCVGEN(gv)
+ B::GV gv
+
+U16
+GvLINE(gv)
+ B::GV gv
+
+B::GV
+GvFILEGV(gv)
+ B::GV gv
+
+MODULE = B PACKAGE = B::GV
+
+U32
+GvREFCNT(gv)
+ B::GV gv
+
+U8
+GvFLAGS(gv)
+ B::GV gv
+
+MODULE = B PACKAGE = B::IO PREFIX = Io
+
+long
+IoLINES(io)
+ B::IO io
+
+long
+IoPAGE(io)
+ B::IO io
+
+long
+IoPAGE_LEN(io)
+ B::IO io
+
+long
+IoLINES_LEFT(io)
+ B::IO io
+
+char *
+IoTOP_NAME(io)
+ B::IO io
+
+B::GV
+IoTOP_GV(io)
+ B::IO io
+
+char *
+IoFMT_NAME(io)
+ B::IO io
+
+B::GV
+IoFMT_GV(io)
+ B::IO io
+
+char *
+IoBOTTOM_NAME(io)
+ B::IO io
+
+B::GV
+IoBOTTOM_GV(io)
+ B::IO io
+
+short
+IoSUBPROCESS(io)
+ B::IO io
+
+MODULE = B PACKAGE = B::IO
+
+char
+IoTYPE(io)
+ B::IO io
+
+U8
+IoFLAGS(io)
+ B::IO io
+
+MODULE = B PACKAGE = B::AV PREFIX = Av
+
+SSize_t
+AvFILL(av)
+ B::AV av
+
+SSize_t
+AvMAX(av)
+ B::AV av
+
+#define AvOFF(av) ((XPVAV*)SvANY(av))->xof_off
+
+IV
+AvOFF(av)
+ B::AV av
+
+void
+AvARRAY(av)
+ B::AV av
+ PPCODE:
+ if (AvFILL(av) >= 0) {
+ SV **svp = AvARRAY(av);
+ I32 i;
+ for (i = 0; i <= AvFILL(av); i++)
+ XPUSHs(make_sv_object(sv_newmortal(), svp[i]));
+ }
+
+MODULE = B PACKAGE = B::AV
+
+U8
+AvFLAGS(av)
+ B::AV av
+
+MODULE = B PACKAGE = B::CV PREFIX = Cv
+
+B::HV
+CvSTASH(cv)
+ B::CV cv
+
+B::OP
+CvSTART(cv)
+ B::CV cv
+
+B::OP
+CvROOT(cv)
+ B::CV cv
+
+B::GV
+CvGV(cv)
+ B::CV cv
+
+B::GV
+CvFILEGV(cv)
+ B::CV cv
+
+long
+CvDEPTH(cv)
+ B::CV cv
+
+B::AV
+CvPADLIST(cv)
+ B::CV cv
+
+B::CV
+CvOUTSIDE(cv)
+ B::CV cv
+
+void
+CvXSUB(cv)
+ B::CV cv
+ CODE:
+ ST(0) = sv_2mortal(newSViv((IV)CvXSUB(cv)));
+
+
+void
+CvXSUBANY(cv)
+ B::CV cv
+ CODE:
+ ST(0) = sv_2mortal(newSViv(CvXSUBANY(cv).any_iv));
+
+MODULE = B PACKAGE = B::HV PREFIX = Hv
+
+STRLEN
+HvFILL(hv)
+ B::HV hv
+
+STRLEN
+HvMAX(hv)
+ B::HV hv
+
+I32
+HvKEYS(hv)
+ B::HV hv
+
+I32
+HvRITER(hv)
+ B::HV hv
+
+char *
+HvNAME(hv)
+ B::HV hv
+
+B::PMOP
+HvPMROOT(hv)
+ B::HV hv
+
+void
+HvARRAY(hv)
+ B::HV hv
+ PPCODE:
+ if (HvKEYS(hv) > 0) {
+ SV *sv;
+ char *key;
+ I32 len;
+ (void)hv_iterinit(hv);
+ EXTEND(sp, HvKEYS(hv) * 2);
+ while (sv = hv_iternextsv(hv, &key, &len)) {
+ PUSHs(newSVpv(key, len));
+ PUSHs(make_sv_object(sv_newmortal(), sv));
+ }
+ }
diff --git a/contrib/perl5/ext/B/B/Asmdata.pm b/contrib/perl5/ext/B/B/Asmdata.pm
new file mode 100644
index 000000000000..f3e57a17d03c
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Asmdata.pm
@@ -0,0 +1,170 @@
+#
+# Copyright (c) 1996-1998 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+#
+#
+# This file is autogenerated from bytecode.pl. Changes made here will be lost.
+#
+package B::Asmdata;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
+use vars qw(%insn_data @insn_name @optype @specialsv_name);
+
+@optype = qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP);
+@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no);
+
+# XXX insn_data is initialised this way because with a large
+# %insn_data = (foo => [...], bar => [...], ...) initialiser
+# I get a hard-to-track-down stack underflow and segfault.
+$insn_data{comment} = [35, \&PUT_comment_t, "GET_comment_t"];
+$insn_data{nop} = [10, \&PUT_none, "GET_none"];
+$insn_data{ret} = [0, \&PUT_none, "GET_none"];
+$insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
+$insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"];
+$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"];
+$insn_data{stop} = [4, \&PUT_U32, "GET_U32"];
+$insn_data{ldspecsv} = [5, \&PUT_U8, "GET_U8"];
+$insn_data{newsv} = [6, \&PUT_U8, "GET_U8"];
+$insn_data{newop} = [7, \&PUT_U8, "GET_U8"];
+$insn_data{newopn} = [8, \&PUT_U8, "GET_U8"];
+$insn_data{newpv} = [9, \&PUT_PV, "GET_PV"];
+$insn_data{pv_cur} = [11, \&PUT_U32, "GET_U32"];
+$insn_data{pv_free} = [12, \&PUT_none, "GET_none"];
+$insn_data{sv_upgrade} = [13, \&PUT_U8, "GET_U8"];
+$insn_data{sv_refcnt} = [14, \&PUT_U32, "GET_U32"];
+$insn_data{sv_refcnt_add} = [15, \&PUT_I32, "GET_I32"];
+$insn_data{sv_flags} = [16, \&PUT_U32, "GET_U32"];
+$insn_data{xrv} = [17, \&PUT_svindex, "GET_svindex"];
+$insn_data{xpv} = [18, \&PUT_none, "GET_none"];
+$insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"];
+$insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"];
+$insn_data{xnv} = [21, \&PUT_double, "GET_double"];
+$insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"];
+$insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"];
+$insn_data{xlv_targ} = [24, \&PUT_svindex, "GET_svindex"];
+$insn_data{xlv_type} = [25, \&PUT_U8, "GET_U8"];
+$insn_data{xbm_useful} = [26, \&PUT_I32, "GET_I32"];
+$insn_data{xbm_previous} = [27, \&PUT_U16, "GET_U16"];
+$insn_data{xbm_rare} = [28, \&PUT_U8, "GET_U8"];
+$insn_data{xfm_lines} = [29, \&PUT_I32, "GET_I32"];
+$insn_data{xio_lines} = [30, \&PUT_I32, "GET_I32"];
+$insn_data{xio_page} = [31, \&PUT_I32, "GET_I32"];
+$insn_data{xio_page_len} = [32, \&PUT_I32, "GET_I32"];
+$insn_data{xio_lines_left} = [33, \&PUT_I32, "GET_I32"];
+$insn_data{xio_top_name} = [34, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xio_top_gv} = [36, \&PUT_svindex, "GET_svindex"];
+$insn_data{xio_fmt_name} = [37, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xio_fmt_gv} = [38, \&PUT_svindex, "GET_svindex"];
+$insn_data{xio_bottom_name} = [39, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xio_bottom_gv} = [40, \&PUT_svindex, "GET_svindex"];
+$insn_data{xio_subprocess} = [41, \&PUT_U16, "GET_U16"];
+$insn_data{xio_type} = [42, \&PUT_U8, "GET_U8"];
+$insn_data{xio_flags} = [43, \&PUT_U8, "GET_U8"];
+$insn_data{xcv_stash} = [44, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_start} = [45, \&PUT_opindex, "GET_opindex"];
+$insn_data{xcv_root} = [46, \&PUT_opindex, "GET_opindex"];
+$insn_data{xcv_gv} = [47, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_filegv} = [48, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_depth} = [49, \&PUT_I32, "GET_I32"];
+$insn_data{xcv_padlist} = [50, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_outside} = [51, \&PUT_svindex, "GET_svindex"];
+$insn_data{xcv_flags} = [52, \&PUT_U8, "GET_U8"];
+$insn_data{av_extend} = [53, \&PUT_I32, "GET_I32"];
+$insn_data{av_push} = [54, \&PUT_svindex, "GET_svindex"];
+$insn_data{xav_fill} = [55, \&PUT_I32, "GET_I32"];
+$insn_data{xav_max} = [56, \&PUT_I32, "GET_I32"];
+$insn_data{xav_flags} = [57, \&PUT_U8, "GET_U8"];
+$insn_data{xhv_riter} = [58, \&PUT_I32, "GET_I32"];
+$insn_data{xhv_name} = [59, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{hv_store} = [60, \&PUT_svindex, "GET_svindex"];
+$insn_data{sv_magic} = [61, \&PUT_U8, "GET_U8"];
+$insn_data{mg_obj} = [62, \&PUT_svindex, "GET_svindex"];
+$insn_data{mg_private} = [63, \&PUT_U16, "GET_U16"];
+$insn_data{mg_flags} = [64, \&PUT_U8, "GET_U8"];
+$insn_data{mg_pv} = [65, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{xmg_stash} = [66, \&PUT_svindex, "GET_svindex"];
+$insn_data{gv_fetchpv} = [67, \&PUT_strconst, "GET_strconst"];
+$insn_data{gv_stashpv} = [68, \&PUT_strconst, "GET_strconst"];
+$insn_data{gp_sv} = [69, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_refcnt} = [70, \&PUT_U32, "GET_U32"];
+$insn_data{gp_refcnt_add} = [71, \&PUT_I32, "GET_I32"];
+$insn_data{gp_av} = [72, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_hv} = [73, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_cv} = [74, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_filegv} = [75, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_io} = [76, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_form} = [77, \&PUT_svindex, "GET_svindex"];
+$insn_data{gp_cvgen} = [78, \&PUT_U32, "GET_U32"];
+$insn_data{gp_line} = [79, \&PUT_U16, "GET_U16"];
+$insn_data{gp_share} = [80, \&PUT_svindex, "GET_svindex"];
+$insn_data{xgv_flags} = [81, \&PUT_U8, "GET_U8"];
+$insn_data{op_next} = [82, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_sibling} = [83, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_ppaddr} = [84, \&PUT_strconst, "GET_strconst"];
+$insn_data{op_targ} = [85, \&PUT_U32, "GET_U32"];
+$insn_data{op_type} = [86, \&PUT_U16, "GET_U16"];
+$insn_data{op_seq} = [87, \&PUT_U16, "GET_U16"];
+$insn_data{op_flags} = [88, \&PUT_U8, "GET_U8"];
+$insn_data{op_private} = [89, \&PUT_U8, "GET_U8"];
+$insn_data{op_first} = [90, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_last} = [91, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_other} = [92, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_true} = [93, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_false} = [94, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_children} = [95, \&PUT_U32, "GET_U32"];
+$insn_data{op_pmreplroot} = [96, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmreplrootgv} = [97, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_pmreplstart} = [98, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_pmnext} = [99, \&PUT_opindex, "GET_opindex"];
+$insn_data{pregcomp} = [100, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pmflags} = [101, \&PUT_U16, "GET_U16"];
+$insn_data{op_pmpermflags} = [102, \&PUT_U16, "GET_U16"];
+$insn_data{op_sv} = [103, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_gv} = [104, \&PUT_svindex, "GET_svindex"];
+$insn_data{op_pv} = [105, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{op_pv_tr} = [106, \&PUT_op_tr_array, "GET_op_tr_array"];
+$insn_data{op_redoop} = [107, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_nextop} = [108, \&PUT_opindex, "GET_opindex"];
+$insn_data{op_lastop} = [109, \&PUT_opindex, "GET_opindex"];
+$insn_data{cop_label} = [110, \&PUT_pvcontents, "GET_pvcontents"];
+$insn_data{cop_stash} = [111, \&PUT_svindex, "GET_svindex"];
+$insn_data{cop_filegv} = [112, \&PUT_svindex, "GET_svindex"];
+$insn_data{cop_seq} = [113, \&PUT_U32, "GET_U32"];
+$insn_data{cop_arybase} = [114, \&PUT_I32, "GET_I32"];
+$insn_data{cop_line} = [115, \&PUT_U16, "GET_U16"];
+$insn_data{main_start} = [116, \&PUT_opindex, "GET_opindex"];
+$insn_data{main_root} = [117, \&PUT_opindex, "GET_opindex"];
+$insn_data{curpad} = [118, \&PUT_svindex, "GET_svindex"];
+
+my ($insn_name, $insn_data);
+while (($insn_name, $insn_data) = each %insn_data) {
+ $insn_name[$insn_data->[0]] = $insn_name;
+}
+# Fill in any gaps
+@insn_name = map($_ || "unused", @insn_name);
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode
+
+=head1 SYNOPSIS
+
+ use Asmdata;
+
+=head1 DESCRIPTION
+
+See F<ext/B/B/Asmdata.pm>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/Assembler.pm b/contrib/perl5/ext/B/B/Assembler.pm
new file mode 100644
index 000000000000..defcbdf958d2
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Assembler.pm
@@ -0,0 +1,227 @@
+# Assembler.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+package B::Assembler;
+use Exporter;
+use B qw(ppname);
+use B::Asmdata qw(%insn_data @insn_name);
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(assemble_fh assemble_insn strip_comments
+ parse_statement uncstring);
+
+use strict;
+my %opnumber;
+my ($i, $opname);
+for ($i = 0; defined($opname = ppname($i)); $i++) {
+ $opnumber{$opname} = $i;
+}
+
+my ($linenum, $errors);
+
+sub error {
+ my $str = shift;
+ warn "$linenum: $str\n";
+ $errors++;
+}
+
+my $debug = 0;
+sub debug { $debug = shift }
+
+#
+# First define all the data conversion subs to which Asmdata will refer
+#
+
+sub B::Asmdata::PUT_U8 {
+ my $arg = shift;
+ my $c = uncstring($arg);
+ if (defined($c)) {
+ if (length($c) != 1) {
+ error "argument for U8 is too long: $c";
+ $c = substr($c, 0, 1);
+ }
+ } else {
+ $c = chr($arg);
+ }
+ return $c;
+}
+
+sub B::Asmdata::PUT_U16 { pack("n", $_[0]) }
+sub B::Asmdata::PUT_U32 { pack("N", $_[0]) }
+sub B::Asmdata::PUT_I32 { pack("N", $_[0]) }
+sub B::Asmdata::PUT_objindex { pack("N", $_[0]) } # could allow names here
+
+sub B::Asmdata::PUT_strconst {
+ my $arg = shift;
+ $arg = uncstring($arg);
+ if (!defined($arg)) {
+ error "bad string constant: $arg";
+ return "";
+ }
+ if ($arg =~ s/\0//g) {
+ error "string constant argument contains NUL: $arg";
+ }
+ return $arg . "\0";
+}
+
+sub B::Asmdata::PUT_pvcontents {
+ my $arg = shift;
+ error "extraneous argument: $arg" if defined $arg;
+ return "";
+}
+sub B::Asmdata::PUT_PV {
+ my $arg = shift;
+ $arg = uncstring($arg);
+ error "bad string argument: $arg" unless defined($arg);
+ return pack("N", length($arg)) . $arg;
+}
+sub B::Asmdata::PUT_comment {
+ my $arg = shift;
+ $arg = uncstring($arg);
+ error "bad string argument: $arg" unless defined($arg);
+ if ($arg =~ s/\n//g) {
+ error "comment argument contains linefeed: $arg";
+ }
+ return $arg . "\n";
+}
+sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) }
+sub B::Asmdata::PUT_none {
+ my $arg = shift;
+ error "extraneous argument: $arg" if defined $arg;
+ return "";
+}
+sub B::Asmdata::PUT_op_tr_array {
+ my $arg = shift;
+ my @ary = split(/\s*,\s*/, $arg);
+ if (@ary != 256) {
+ error "wrong number of arguments to op_tr_array";
+ @ary = (0) x 256;
+ }
+ return pack("n256", @ary);
+}
+# XXX Check this works
+sub B::Asmdata::PUT_IV64 {
+ my $arg = shift;
+ return pack("NN", $arg >> 32, $arg & 0xffffffff);
+}
+
+my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
+ b => "\b", f => "\f", v => "\013");
+
+sub uncstring {
+ my $s = shift;
+ $s =~ s/^"// and $s =~ s/"$// or return undef;
+ $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
+ return $s;
+}
+
+sub strip_comments {
+ my $stmt = shift;
+ # Comments only allowed in instructions which don't take string arguments
+ $stmt =~ s{
+ (?sx) # Snazzy extended regexp coming up. Also, treat
+ # string as a single line so .* eats \n characters.
+ ^\s* # Ignore leading whitespace
+ (
+ [^"]* # A double quote '"' indicates a string argument. If we
+ # find a double quote, the match fails and we strip nothing.
+ )
+ \s*\# # Any amount of whitespace plus the comment marker...
+ .*$ # ...which carries on to end-of-string.
+ }{$1}; # Keep only the instruction and optional argument.
+ return $stmt;
+}
+
+sub parse_statement {
+ my $stmt = shift;
+ my ($insn, $arg) = $stmt =~ m{
+ (?sx)
+ ^\s* # allow (but ignore) leading whitespace
+ (.*?) # Instruction continues up until...
+ (?: # ...an optional whitespace+argument group
+ \s+ # first whitespace.
+ (.*) # The argument is all the rest (newlines included).
+ )?$ # anchor at end-of-line
+ };
+ if (defined($arg)) {
+ if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
+ $arg = hex($arg);
+ } elsif ($arg =~ s/^0(?=[0-7]+$)//) {
+ $arg = oct($arg);
+ } elsif ($arg =~ /^pp_/) {
+ $arg =~ s/\s*$//; # strip trailing whitespace
+ my $opnum = $opnumber{$arg};
+ if (defined($opnum)) {
+ $arg = $opnum;
+ } else {
+ error qq(No such op type "$arg");
+ $arg = 0;
+ }
+ }
+ }
+ return ($insn, $arg);
+}
+
+sub assemble_insn {
+ my ($insn, $arg) = @_;
+ my $data = $insn_data{$insn};
+ if (defined($data)) {
+ my ($bytecode, $putsub) = @{$data}[0, 1];
+ my $argcode = &$putsub($arg);
+ return chr($bytecode).$argcode;
+ } else {
+ error qq(no such instruction "$insn");
+ return "";
+ }
+}
+
+sub assemble_fh {
+ my ($fh, $out) = @_;
+ my ($line, $insn, $arg);
+ $linenum = 0;
+ $errors = 0;
+ while ($line = <$fh>) {
+ $linenum++;
+ chomp $line;
+ if ($debug) {
+ my $quotedline = $line;
+ $quotedline =~ s/\\/\\\\/g;
+ $quotedline =~ s/"/\\"/g;
+ &$out(assemble_insn("comment", qq("$quotedline")));
+ }
+ $line = strip_comments($line) or next;
+ ($insn, $arg) = parse_statement($line);
+ &$out(assemble_insn($insn, $arg));
+ if ($debug) {
+ &$out(assemble_insn("nop", undef));
+ }
+ }
+ if ($errors) {
+ die "Assembly failed with $errors error(s)\n";
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Assembler - Assemble Perl bytecode
+
+=head1 SYNOPSIS
+
+ use Assembler;
+
+=head1 DESCRIPTION
+
+See F<ext/B/B/Assembler.pm>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/Bblock.pm b/contrib/perl5/ext/B/B/Bblock.pm
new file mode 100644
index 000000000000..a54431b4ce71
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Bblock.pm
@@ -0,0 +1,162 @@
+package B::Bblock;
+use Exporter ();
+@ISA = "Exporter";
+@EXPORT_OK = qw(find_leaders);
+
+use B qw(peekop walkoptree walkoptree_exec
+ main_root main_start svref_2object);
+use B::Terse;
+use strict;
+
+my $bblock;
+my @bblock_ends;
+
+sub mark_leader {
+ my $op = shift;
+ if ($$op) {
+ $bblock->{$$op} = $op;
+ }
+}
+
+sub find_leaders {
+ my ($root, $start) = @_;
+ $bblock = {};
+ mark_leader($start);
+ walkoptree($root, "mark_if_leader");
+ return $bblock;
+}
+
+# Debugging
+sub walk_bblocks {
+ my ($root, $start) = @_;
+ my ($op, $lastop, $leader, $bb);
+ $bblock = {};
+ mark_leader($start);
+ walkoptree($root, "mark_if_leader");
+ my @leaders = values %$bblock;
+ while ($leader = shift @leaders) {
+ $lastop = $leader;
+ $op = $leader->next;
+ while ($$op && !exists($bblock->{$$op})) {
+ $bblock->{$$op} = $leader;
+ $lastop = $op;
+ $op = $op->next;
+ }
+ push(@bblock_ends, [$leader, $lastop]);
+ }
+ foreach $bb (@bblock_ends) {
+ ($leader, $lastop) = @$bb;
+ printf "%s .. %s\n", peekop($leader), peekop($lastop);
+ for ($op = $leader; $$op != $$lastop; $op = $op->next) {
+ printf " %s\n", peekop($op);
+ }
+ printf " %s\n", peekop($lastop);
+ }
+ print "-------\n";
+ walkoptree_exec($start, "terse");
+}
+
+sub walk_bblocks_obj {
+ my $cvref = shift;
+ my $cv = svref_2object($cvref);
+ walk_bblocks($cv->ROOT, $cv->START);
+}
+
+sub B::OP::mark_if_leader {}
+
+sub B::COP::mark_if_leader {
+ my $op = shift;
+ if ($op->label) {
+ mark_leader($op);
+ }
+}
+
+sub B::LOOP::mark_if_leader {
+ my $op = shift;
+ mark_leader($op->next);
+ mark_leader($op->nextop);
+ mark_leader($op->redoop);
+ mark_leader($op->lastop->next);
+}
+
+sub B::LOGOP::mark_if_leader {
+ my $op = shift;
+ my $ppaddr = $op->ppaddr;
+ mark_leader($op->next);
+ if ($ppaddr eq "pp_entertry") {
+ mark_leader($op->other->next);
+ } else {
+ mark_leader($op->other);
+ }
+}
+
+sub B::CONDOP::mark_if_leader {
+ my $op = shift;
+ mark_leader($op->next);
+ mark_leader($op->true);
+ mark_leader($op->false);
+}
+
+sub B::PMOP::mark_if_leader {
+ my $op = shift;
+ if ($op->ppaddr ne "pp_pushre") {
+ my $replroot = $op->pmreplroot;
+ if ($$replroot) {
+ mark_leader($replroot);
+ mark_leader($op->next);
+ mark_leader($op->pmreplstart);
+ }
+ }
+}
+
+# PMOP stuff omitted
+
+sub compile {
+ my @options = @_;
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "walk_bblocks_obj(\\&$objname)";
+ die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
+ }
+ }
+ } else {
+ return sub { walk_bblocks(main_root, main_start) };
+ }
+}
+
+# Basic block leaders:
+# Any COP (pp_nextstate) with a non-NULL label
+# [The op after a pp_enter] Omit
+# [The op after a pp_entersub. Don't count this one.]
+# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
+# The ops pointed at by op_next and op_other of a LOGOP, except
+# for pp_entertry which has op_next and op_other->op_next
+# The ops pointed at by op_true and op_false of a CONDOP
+# The op pointed at by op_pmreplstart of a PMOP
+# The op pointed at by op_other->op_pmreplstart of pp_substcont?
+# [The op after a pp_return] Omit
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Bblock - Walk basic blocks
+
+=head1 SYNOPSIS
+
+ perl -MO=Bblock[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+See F<ext/B/README>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/Bytecode.pm b/contrib/perl5/ext/B/B/Bytecode.pm
new file mode 100644
index 000000000000..0c5a58dc5424
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Bytecode.pm
@@ -0,0 +1,908 @@
+# Bytecode.pm
+#
+# Copyright (c) 1996-1998 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::Bytecode;
+use strict;
+use Carp;
+use IO::File;
+
+use B qw(minus_c main_cv main_root main_start comppadlist
+ class peekop walkoptree svref_2object cstring walksymtable);
+use B::Asmdata qw(@optype @specialsv_name);
+use B::Assembler qw(assemble_fh);
+
+my %optype_enum;
+my $i;
+for ($i = 0; $i < @optype; $i++) {
+ $optype_enum{$optype[$i]} = $i;
+}
+
+# Following is SVf_POK|SVp_POK
+# XXX Shouldn't be hardwired
+sub POK () { 0x04040000 }
+
+# Following is SVf_IOK|SVp_OK
+# XXX Shouldn't be hardwired
+sub IOK () { 0x01010000 }
+
+my ($verbose, $module_only, $no_assemble, $debug_bc, $debug_cv);
+my $assembler_pid;
+
+# Optimisation options. On the command line, use hyphens instead of
+# underscores for compatibility with gcc-style options. We use
+# underscores here because they are OK in (strict) barewords.
+my ($strip_syntree, $compress_nullops, $omit_seq, $bypass_nullops);
+my %optimise = (strip_syntax_tree => \$strip_syntree,
+ compress_nullops => \$compress_nullops,
+ omit_sequence_numbers => \$omit_seq,
+ bypass_nullops => \$bypass_nullops);
+
+my $nextix = 0;
+my %symtable; # maps object addresses to object indices.
+ # Filled in at allocation (newsv/newop) time.
+my %saved; # maps object addresses (for SVish classes) to "saved yet?"
+ # flag. Set at FOO::bytecode time usually by SV::bytecode.
+ # Manipulated via saved(), mark_saved(), unmark_saved().
+
+my $svix = -1; # we keep track of when the sv register contains an element
+ # of the object table to avoid unnecessary repeated
+ # consecutive ldsv instructions.
+my $opix = -1; # Ditto for the op register.
+
+sub ldsv {
+ my $ix = shift;
+ if ($ix != $svix) {
+ print "ldsv $ix\n";
+ $svix = $ix;
+ }
+}
+
+sub stsv {
+ my $ix = shift;
+ print "stsv $ix\n";
+ $svix = $ix;
+}
+
+sub set_svix {
+ $svix = shift;
+}
+
+sub ldop {
+ my $ix = shift;
+ if ($ix != $opix) {
+ print "ldop $ix\n";
+ $opix = $ix;
+ }
+}
+
+sub stop {
+ my $ix = shift;
+ print "stop $ix\n";
+ $opix = $ix;
+}
+
+sub set_opix {
+ $opix = shift;
+}
+
+sub pvstring {
+ my $str = shift;
+ if (defined($str)) {
+ return cstring($str . "\0");
+ } else {
+ return '""';
+ }
+}
+
+sub saved { $saved{${$_[0]}} }
+sub mark_saved { $saved{${$_[0]}} = 1 }
+sub unmark_saved { $saved{${$_[0]}} = 0 }
+
+sub debug { $debug_bc = shift }
+
+sub B::OBJECT::nyi {
+ my $obj = shift;
+ warn sprintf("bytecode save method for %s (0x%x) not yet implemented\n",
+ class($obj), $$obj);
+}
+
+#
+# objix may stomp on the op register (for op objects)
+# or the sv register (for SV objects)
+#
+sub B::OBJECT::objix {
+ my $obj = shift;
+ my $ix = $symtable{$$obj};
+ if (defined($ix)) {
+ return $ix;
+ } else {
+ $obj->newix($nextix);
+ return $symtable{$$obj} = $nextix++;
+ }
+}
+
+sub B::SV::newix {
+ my ($sv, $ix) = @_;
+ printf "newsv %d\t# %s\n", $sv->FLAGS & 0xf, class($sv);
+ stsv($ix);
+}
+
+sub B::GV::newix {
+ my ($gv, $ix) = @_;
+ my $gvname = $gv->NAME;
+ my $name = cstring($gv->STASH->NAME . "::" . $gvname);
+ print "gv_fetchpv $name\n";
+ stsv($ix);
+}
+
+sub B::HV::newix {
+ my ($hv, $ix) = @_;
+ my $name = $hv->NAME;
+ if ($name) {
+ # It's a stash
+ printf "gv_stashpv %s\n", cstring($name);
+ stsv($ix);
+ } else {
+ # It's an ordinary HV. Fall back to ordinary newix method
+ $hv->B::SV::newix($ix);
+ }
+}
+
+sub B::SPECIAL::newix {
+ my ($sv, $ix) = @_;
+ # Special case. $$sv is not the address of the SV but an
+ # index into svspecialsv_list.
+ printf "ldspecsv $$sv\t# %s\n", $specialsv_name[$$sv];
+ stsv($ix);
+}
+
+sub B::OP::newix {
+ my ($op, $ix) = @_;
+ my $class = class($op);
+ my $typenum = $optype_enum{$class};
+ croak "OP::newix: can't understand class $class" unless defined($typenum);
+ print "newop $typenum\t# $class\n";
+ stop($ix);
+}
+
+sub B::OP::walkoptree_debug {
+ my $op = shift;
+ warn(sprintf("walkoptree: %s\n", peekop($op)));
+}
+
+sub B::OP::bytecode {
+ my $op = shift;
+ my $next = $op->next;
+ my $nextix;
+ my $sibix = $op->sibling->objix;
+ my $ix = $op->objix;
+ my $type = $op->type;
+
+ if ($bypass_nullops) {
+ $next = $next->next while $$next && $next->type == 0;
+ }
+ $nextix = $next->objix;
+
+ printf "# %s\n", peekop($op) if $debug_bc;
+ ldop($ix);
+ print "op_next $nextix\n";
+ print "op_sibling $sibix\n" unless $strip_syntree;
+ printf "op_type %s\t# %d\n", $op->ppaddr, $type;
+ printf("op_seq %d\n", $op->seq) unless $omit_seq;
+ if ($type || !$compress_nullops) {
+ printf "op_targ %d\nop_flags 0x%x\nop_private 0x%x\n",
+ $op->targ, $op->flags, $op->private;
+ }
+}
+
+sub B::UNOP::bytecode {
+ my $op = shift;
+ my $firstix = $op->first->objix;
+ $op->B::OP::bytecode;
+ if (($op->type || !$compress_nullops) && !$strip_syntree) {
+ print "op_first $firstix\n";
+ }
+}
+
+sub B::LOGOP::bytecode {
+ my $op = shift;
+ my $otherix = $op->other->objix;
+ $op->B::UNOP::bytecode;
+ print "op_other $otherix\n";
+}
+
+sub B::SVOP::bytecode {
+ my $op = shift;
+ my $sv = $op->sv;
+ my $svix = $sv->objix;
+ $op->B::OP::bytecode;
+ print "op_sv $svix\n";
+ $sv->bytecode;
+}
+
+sub B::GVOP::bytecode {
+ my $op = shift;
+ my $gv = $op->gv;
+ my $gvix = $gv->objix;
+ $op->B::OP::bytecode;
+ print "op_gv $gvix\n";
+ $gv->bytecode;
+}
+
+sub B::PVOP::bytecode {
+ my $op = shift;
+ my $pv = $op->pv;
+ $op->B::OP::bytecode;
+ #
+ # This would be easy except that OP_TRANS uses a PVOP to store an
+ # endian-dependent array of 256 shorts instead of a plain string.
+ #
+ if ($op->ppaddr eq "pp_trans") {
+ my @shorts = unpack("s256", $pv); # assembler handles endianness
+ print "op_pv_tr ", join(",", @shorts), "\n";
+ } else {
+ printf "newpv %s\nop_pv\n", pvstring($pv);
+ }
+}
+
+sub B::BINOP::bytecode {
+ my $op = shift;
+ my $lastix = $op->last->objix;
+ $op->B::UNOP::bytecode;
+ if (($op->type || !$compress_nullops) && !$strip_syntree) {
+ print "op_last $lastix\n";
+ }
+}
+
+sub B::CONDOP::bytecode {
+ my $op = shift;
+ my $trueix = $op->true->objix;
+ my $falseix = $op->false->objix;
+ $op->B::UNOP::bytecode;
+ print "op_true $trueix\nop_false $falseix\n";
+}
+
+sub B::LISTOP::bytecode {
+ my $op = shift;
+ my $children = $op->children;
+ $op->B::BINOP::bytecode;
+ if (($op->type || !$compress_nullops) && !$strip_syntree) {
+ print "op_children $children\n";
+ }
+}
+
+sub B::LOOP::bytecode {
+ my $op = shift;
+ my $redoopix = $op->redoop->objix;
+ my $nextopix = $op->nextop->objix;
+ my $lastopix = $op->lastop->objix;
+ $op->B::LISTOP::bytecode;
+ print "op_redoop $redoopix\nop_nextop $nextopix\nop_lastop $lastopix\n";
+}
+
+sub B::COP::bytecode {
+ my $op = shift;
+ my $stash = $op->stash;
+ my $stashix = $stash->objix;
+ my $filegv = $op->filegv;
+ my $filegvix = $filegv->objix;
+ my $line = $op->line;
+ if ($debug_bc) {
+ printf "# line %s:%d\n", $filegv->SV->PV, $line;
+ }
+ $op->B::OP::bytecode;
+ printf <<"EOT", pvstring($op->label), $op->cop_seq, $op->arybase;
+newpv %s
+cop_label
+cop_stash $stashix
+cop_seq %d
+cop_filegv $filegvix
+cop_arybase %d
+cop_line $line
+EOT
+ $filegv->bytecode;
+ $stash->bytecode;
+}
+
+sub B::PMOP::bytecode {
+ my $op = shift;
+ my $replroot = $op->pmreplroot;
+ my $replrootix = $replroot->objix;
+ my $replstartix = $op->pmreplstart->objix;
+ my $ppaddr = $op->ppaddr;
+ # pmnext is corrupt in some PMOPs (see misc.t for example)
+ #my $pmnextix = $op->pmnext->objix;
+
+ if ($$replroot) {
+ # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
+ # argument to a split) stores a GV in op_pmreplroot instead
+ # of a substitution syntax tree. We don't want to walk that...
+ if ($ppaddr eq "pp_pushre") {
+ $replroot->bytecode;
+ } else {
+ walkoptree($replroot, "bytecode");
+ }
+ }
+ $op->B::LISTOP::bytecode;
+ if ($ppaddr eq "pp_pushre") {
+ printf "op_pmreplrootgv $replrootix\n";
+ } else {
+ print "op_pmreplroot $replrootix\nop_pmreplstart $replstartix\n";
+ }
+ my $re = pvstring($op->precomp);
+ # op_pmnext omitted since a perl bug means it's sometime corrupt
+ printf <<"EOT", $op->pmflags, $op->pmpermflags;
+op_pmflags 0x%x
+op_pmpermflags 0x%x
+newpv $re
+pregcomp
+EOT
+}
+
+sub B::SV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ my $ix = $sv->objix;
+ my $refcnt = $sv->REFCNT;
+ my $flags = sprintf("0x%x", $sv->FLAGS);
+ ldsv($ix);
+ print "sv_refcnt $refcnt\nsv_flags $flags\n";
+ mark_saved($sv);
+}
+
+sub B::PV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ $sv->B::SV::bytecode;
+ printf("newpv %s\nxpv\n", pvstring($sv->PV)) if $sv->FLAGS & POK;
+}
+
+sub B::IV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ my $iv = $sv->IVX;
+ $sv->B::SV::bytecode;
+ printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
+}
+
+sub B::NV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ $sv->B::SV::bytecode;
+ printf "xnv %s\n", $sv->NVX;
+}
+
+sub B::RV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ my $rv = $sv->RV;
+ my $rvix = $rv->objix;
+ $rv->bytecode;
+ $sv->B::SV::bytecode;
+ print "xrv $rvix\n";
+}
+
+sub B::PVIV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ my $iv = $sv->IVX;
+ $sv->B::PV::bytecode;
+ printf "%s $iv\n", $sv->needs64bits ? "xiv64" : "xiv32";
+}
+
+sub B::PVNV::bytecode {
+ my ($sv, $flag) = @_;
+ # The $flag argument is passed through PVMG::bytecode by BM::bytecode
+ # and AV::bytecode and indicates special handling. $flag = 1 is used by
+ # BM::bytecode and means that we should ensure we save the whole B-M
+ # table. It consists of 257 bytes (256 char array plus a final \0)
+ # which follow the ordinary PV+\0 and the 257 bytes are *not* reflected
+ # in SvCUR. $flag = 2 is used by AV::bytecode and means that we only
+ # call SV::bytecode instead of saving PV and calling NV::bytecode since
+ # PV/NV/IV stuff is different for AVs.
+ return if saved($sv);
+ if ($flag == 2) {
+ $sv->B::SV::bytecode;
+ } else {
+ my $pv = $sv->PV;
+ $sv->B::IV::bytecode;
+ printf "xnv %s\n", $sv->NVX;
+ if ($flag == 1) {
+ $pv .= "\0" . $sv->TABLE;
+ printf "newpv %s\npv_cur %d\nxpv\n", pvstring($pv),length($pv)-257;
+ } else {
+ printf("newpv %s\nxpv\n", pvstring($pv)) if $sv->FLAGS & POK;
+ }
+ }
+}
+
+sub B::PVMG::bytecode {
+ my ($sv, $flag) = @_;
+ # See B::PVNV::bytecode for an explanation of $flag.
+ return if saved($sv);
+ # XXX We assume SvSTASH is already saved and don't save it later ourselves
+ my $stashix = $sv->SvSTASH->objix;
+ my @mgchain = $sv->MAGIC;
+ my (@mgobjix, $mg);
+ #
+ # We need to traverse the magic chain and get objix for each OBJ
+ # field *before* we do B::PVNV::bytecode since objix overwrites
+ # the sv register. However, we need to write the magic-saving
+ # bytecode *after* B::PVNV::bytecode since sv isn't initialised
+ # to refer to $sv until then.
+ #
+ @mgobjix = map($_->OBJ->objix, @mgchain);
+ $sv->B::PVNV::bytecode($flag);
+ print "xmg_stash $stashix\n";
+ foreach $mg (@mgchain) {
+ printf "sv_magic %s\nmg_obj %d\nnewpv %s\nmg_pv\n",
+ cstring($mg->TYPE), shift(@mgobjix), pvstring($mg->PTR);
+ }
+}
+
+sub B::PVLV::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ $sv->B::PVMG::bytecode;
+ printf <<'EOT', $sv->TARGOFF, $sv->TARGLEN, cstring($sv->TYPE);
+xlv_targoff %d
+xlv_targlen %d
+xlv_type %s
+EOT
+}
+
+sub B::BM::bytecode {
+ my $sv = shift;
+ return if saved($sv);
+ # See PVNV::bytecode for an explanation of what the argument does
+ $sv->B::PVMG::bytecode(1);
+ printf "xbm_useful %d\nxbm_previous %d\nxbm_rare %d\n",
+ $sv->USEFUL, $sv->PREVIOUS, $sv->RARE;
+}
+
+sub B::GV::bytecode {
+ my $gv = shift;
+ return if saved($gv);
+ my $ix = $gv->objix;
+ mark_saved($gv);
+ my $gvname = $gv->NAME;
+ my $name = cstring($gv->STASH->NAME . "::" . $gvname);
+ my $egv = $gv->EGV;
+ my $egvix = $egv->objix;
+ ldsv($ix);
+ printf <<"EOT", $gv->FLAGS, $gv->GvFLAGS, $gv->LINE;
+sv_flags 0x%x
+xgv_flags 0x%x
+gp_line %d
+EOT
+ my $refcnt = $gv->REFCNT;
+ printf("sv_refcnt_add %d\n", $refcnt - 1) if $refcnt > 1;
+ my $gvrefcnt = $gv->GvREFCNT;
+ printf("gp_refcnt_add %d\n", $gvrefcnt - 1) if $gvrefcnt > 1;
+ if ($gvrefcnt > 1 && $ix != $egvix) {
+ print "gp_share $egvix\n";
+ } else {
+ if ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
+ my $i;
+ my @subfield_names = qw(SV AV HV CV FILEGV FORM IO);
+ my @subfields = map($gv->$_(), @subfield_names);
+ my @ixes = map($_->objix, @subfields);
+ # Reset sv register for $gv
+ ldsv($ix);
+ for ($i = 0; $i < @ixes; $i++) {
+ printf "gp_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
+ }
+ # Now save all the subfields
+ my $sv;
+ foreach $sv (@subfields) {
+ $sv->bytecode;
+ }
+ }
+ }
+}
+
+sub B::HV::bytecode {
+ my $hv = shift;
+ return if saved($hv);
+ mark_saved($hv);
+ my $name = $hv->NAME;
+ my $ix = $hv->objix;
+ if (!$name) {
+ # It's an ordinary HV. Stashes have NAME set and need no further
+ # saving beyond the gv_stashpv that $hv->objix already ensures.
+ my @contents = $hv->ARRAY;
+ my ($i, @ixes);
+ for ($i = 1; $i < @contents; $i += 2) {
+ push(@ixes, $contents[$i]->objix);
+ }
+ for ($i = 1; $i < @contents; $i += 2) {
+ $contents[$i]->bytecode;
+ }
+ ldsv($ix);
+ for ($i = 0; $i < @contents; $i += 2) {
+ printf("newpv %s\nhv_store %d\n",
+ pvstring($contents[$i]), $ixes[$i / 2]);
+ }
+ printf "sv_refcnt %d\nsv_flags 0x%x\n", $hv->REFCNT, $hv->FLAGS;
+ }
+}
+
+sub B::AV::bytecode {
+ my $av = shift;
+ return if saved($av);
+ my $ix = $av->objix;
+ my $fill = $av->FILL;
+ my $max = $av->MAX;
+ my (@array, @ixes);
+ if ($fill > -1) {
+ @array = $av->ARRAY;
+ @ixes = map($_->objix, @array);
+ my $sv;
+ foreach $sv (@array) {
+ $sv->bytecode;
+ }
+ }
+ # See PVNV::bytecode for the meaning of the flag argument of 2.
+ $av->B::PVMG::bytecode(2);
+ # Recover sv register and set AvMAX and AvFILL to -1 (since we
+ # create an AV with NEWSV and SvUPGRADE rather than doing newAV
+ # which is what sets AvMAX and AvFILL.
+ ldsv($ix);
+ printf "xav_flags 0x%x\nxav_max -1\nxav_fill -1\n", $av->AvFLAGS;
+ if ($fill > -1) {
+ my $elix;
+ foreach $elix (@ixes) {
+ print "av_push $elix\n";
+ }
+ } else {
+ if ($max > -1) {
+ print "av_extend $max\n";
+ }
+ }
+}
+
+sub B::CV::bytecode {
+ my $cv = shift;
+ return if saved($cv);
+ my $ix = $cv->objix;
+ $cv->B::PVMG::bytecode;
+ my $i;
+ my @subfield_names = qw(ROOT START STASH GV FILEGV PADLIST OUTSIDE);
+ my @subfields = map($cv->$_(), @subfield_names);
+ my @ixes = map($_->objix, @subfields);
+ # Save OP tree from CvROOT (first element of @subfields)
+ my $root = shift @subfields;
+ if ($$root) {
+ walkoptree($root, "bytecode");
+ }
+ # Reset sv register for $cv (since above ->objix calls stomped on it)
+ ldsv($ix);
+ for ($i = 0; $i < @ixes; $i++) {
+ printf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
+ }
+ printf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->FLAGS;
+ # Now save all the subfields (except for CvROOT which was handled
+ # above) and CvSTART (now the initial element of @subfields).
+ shift @subfields; # bye-bye CvSTART
+ my $sv;
+ foreach $sv (@subfields) {
+ $sv->bytecode;
+ }
+}
+
+sub B::IO::bytecode {
+ my $io = shift;
+ return if saved($io);
+ my $ix = $io->objix;
+ my $top_gv = $io->TOP_GV;
+ my $top_gvix = $top_gv->objix;
+ my $fmt_gv = $io->FMT_GV;
+ my $fmt_gvix = $fmt_gv->objix;
+ my $bottom_gv = $io->BOTTOM_GV;
+ my $bottom_gvix = $bottom_gv->objix;
+
+ $io->B::PVMG::bytecode;
+ ldsv($ix);
+ print "xio_top_gv $top_gvix\n";
+ print "xio_fmt_gv $fmt_gvix\n";
+ print "xio_bottom_gv $bottom_gvix\n";
+ my $field;
+ foreach $field (qw(TOP_NAME FMT_NAME BOTTOM_NAME)) {
+ printf "newpv %s\nxio_%s\n", pvstring($io->$field()), lc($field);
+ }
+ foreach $field (qw(LINES PAGE PAGE_LEN LINES_LEFT SUBPROCESS)) {
+ printf "xio_%s %d\n", lc($field), $io->$field();
+ }
+ printf "xio_type %s\nxio_flags 0x%x\n", cstring($io->IoTYPE), $io->IoFLAGS;
+ $top_gv->bytecode;
+ $fmt_gv->bytecode;
+ $bottom_gv->bytecode;
+}
+
+sub B::SPECIAL::bytecode {
+ # nothing extra needs doing
+}
+
+sub bytecompile_object {
+ my $sv;
+ foreach $sv (@_) {
+ svref_2object($sv)->bytecode;
+ }
+}
+
+sub B::GV::bytecodecv {
+ my $gv = shift;
+ my $cv = $gv->CV;
+ if ($$cv && !saved($cv)) {
+ if ($debug_cv) {
+ warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
+ $gv->STASH->NAME, $gv->NAME, $$cv, $$gv);
+ }
+ $gv->bytecode;
+ }
+}
+
+sub bytecompile_main {
+ my $curpad = (comppadlist->ARRAY)[1];
+ my $curpadix = $curpad->objix;
+ $curpad->bytecode;
+ walkoptree(main_root, "bytecode");
+ warn "done main program, now walking symbol table\n" if $debug_bc;
+ my ($pack, %exclude);
+ foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS strict vars
+ FileHandle Exporter Carp UNIVERSAL IO Fcntl Symbol
+ SelectSaver blib Cwd))
+ {
+ $exclude{$pack."::"} = 1;
+ }
+ no strict qw(vars refs);
+ walksymtable(\%{"main::"}, "bytecodecv", sub {
+ warn "considering $_[0]\n" if $debug_bc;
+ return !defined($exclude{$_[0]});
+ });
+ if (!$module_only) {
+ printf "main_root %d\n", main_root->objix;
+ printf "main_start %d\n", main_start->objix;
+ printf "curpad $curpadix\n";
+ # XXX Do min_intro_pending and max_intro_pending matter?
+ }
+}
+
+sub prepare_assemble {
+ my $newfh = IO::File->new_tmpfile;
+ select($newfh);
+ binmode $newfh;
+ return $newfh;
+}
+
+sub do_assemble {
+ my $fh = shift;
+ seek($fh, 0, 0); # rewind the temporary file
+ assemble_fh($fh, sub { print OUT @_ });
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ open(OUT, ">&STDOUT");
+ binmode OUT;
+ select(OUT);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(OUT, ">$arg") or return "$arg: $!\n";
+ binmode OUT;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "b") {
+ $| = 1;
+ debug(1);
+ } elsif ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "a") {
+ B::Assembler::debug(1);
+ } elsif ($arg eq "C") {
+ $debug_cv = 1;
+ }
+ }
+ } elsif ($opt eq "v") {
+ $verbose = 1;
+ } elsif ($opt eq "m") {
+ $module_only = 1;
+ } elsif ($opt eq "S") {
+ $no_assemble = 1;
+ } elsif ($opt eq "f") {
+ $arg ||= shift @options;
+ my $value = $arg !~ s/^no-//;
+ $arg =~ s/-/_/g;
+ my $ref = $optimise{$arg};
+ if (defined($ref)) {
+ $$ref = $value;
+ } else {
+ warn qq(ignoring unknown optimisation option "$arg"\n);
+ }
+ } elsif ($opt eq "O") {
+ $arg = 1 if $arg eq "";
+ my $ref;
+ foreach $ref (values %optimise) {
+ $$ref = 0;
+ }
+ if ($arg >= 6) {
+ $strip_syntree = 1;
+ }
+ if ($arg >= 2) {
+ $bypass_nullops = 1;
+ }
+ if ($arg >= 1) {
+ $compress_nullops = 1;
+ $omit_seq = 1;
+ }
+ }
+ }
+ if (@options) {
+ return sub {
+ my $objname;
+ my $newfh;
+ $newfh = prepare_assemble() unless $no_assemble;
+ foreach $objname (@options) {
+ eval "bytecompile_object(\\$objname)";
+ }
+ do_assemble($newfh) unless $no_assemble;
+ }
+ } else {
+ return sub {
+ my $newfh;
+ $newfh = prepare_assemble() unless $no_assemble;
+ bytecompile_main();
+ do_assemble($newfh) unless $no_assemble;
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Bytecode - Perl compiler's bytecode backend
+
+=head1 SYNOPSIS
+
+ perl -MO=Bytecode[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This compiler backend takes Perl source and generates a
+platform-independent bytecode encapsulating code to load the
+internal structures perl uses to run your program. When the
+generated bytecode is loaded in, your program is ready to run,
+reducing the time which perl would have taken to load and parse
+your program into its internal semi-compiled form. That means that
+compiling with this backend will not help improve the runtime
+execution speed of your program but may improve the start-up time.
+Depending on the environment in which your program runs this may
+or may not be a help.
+
+The resulting bytecode can be run with a special byteperl executable
+or (for non-main programs) be loaded via the C<byteload_fh> function
+in the F<B> module.
+
+=head1 OPTIONS
+
+If there are any non-option arguments, they are taken to be names of
+objects to be saved (probably doesn't work properly yet). Without
+extra arguments, it saves the main program.
+
+=over 4
+
+=item B<-ofilename>
+
+Output to filename instead of STDOUT.
+
+=item B<-->
+
+Force end of options.
+
+=item B<-f>
+
+Force optimisations on or off one at a time. Each can be preceded
+by B<no-> to turn the option off (e.g. B<-fno-compress-nullops>).
+
+=item B<-fcompress-nullops>
+
+Only fills in the necessary fields of ops which have
+been optimised away by perl's internal compiler.
+
+=item B<-fomit-sequence-numbers>
+
+Leaves out code to fill in the op_seq field of all ops
+which is only used by perl's internal compiler.
+
+=item B<-fbypass-nullops>
+
+If op->op_next ever points to a NULLOP, replaces the op_next field
+with the first non-NULLOP in the path of execution.
+
+=item B<-fstrip-syntax-tree>
+
+Leaves out code to fill in the pointers which link the internal syntax
+tree together. They're not needed at run-time but leaving them out
+will make it impossible to recompile or disassemble the resulting
+program. It will also stop C<goto label> statements from working.
+
+=item B<-On>
+
+Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
+B<-O1> sets B<-fcompress-nullops> B<-fomit-sequence numbers>.
+B<-O6> adds B<-fstrip-syntax-tree>.
+
+=item B<-D>
+
+Debug options (concatenated or separate flags like C<perl -D>).
+
+=item B<-Do>
+
+Prints each OP as it's processed.
+
+=item B<-Db>
+
+Print debugging information about bytecompiler progress.
+
+=item B<-Da>
+
+Tells the (bytecode) assembler to include source assembler lines
+in its output as bytecode comments.
+
+=item B<-DC>
+
+Prints each CV taken from the final symbol tree walk.
+
+=item B<-S>
+
+Output (bytecode) assembler source rather than piping it
+through the assembler and outputting bytecode.
+
+=item B<-m>
+
+Compile as a module rather than a standalone program. Currently this
+just means that the bytecodes for initialising C<main_start>,
+C<main_root> and C<curpad> are omitted.
+
+=back
+
+=head1 EXAMPLES
+
+ perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
+
+ perl -MO=Bytecode,-S foo.pl > foo.S
+ assemble foo.S > foo.plc
+ byteperl foo.plc
+
+ perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
+
+=head1 BUGS
+
+Plenty. Current status: experimental.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/C.pm b/contrib/perl5/ext/B/B/C.pm
new file mode 100644
index 000000000000..0b7d6ebd84d0
--- /dev/null
+++ b/contrib/perl5/ext/B/B/C.pm
@@ -0,0 +1,1319 @@
+# C.pm
+#
+# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::C;
+use Exporter ();
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(output_all output_boilerplate output_main
+ init_sections set_callback save_unused_subs objsym);
+
+use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
+ class cstring cchar svref_2object compile_stats comppadlist hash
+ threadsv_names);
+use B::Asmdata qw(@specialsv_name);
+
+use FileHandle;
+use Carp;
+use strict;
+
+my $hv_index = 0;
+my $gv_index = 0;
+my $re_index = 0;
+my $pv_index = 0;
+my $anonsub_index = 0;
+
+my %symtable;
+my $warn_undefined_syms;
+my $verbose;
+my @unused_sub_packages;
+my $nullop_count;
+my $pv_copy_on_grow;
+my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
+
+my @threadsv_names;
+BEGIN {
+ @threadsv_names = threadsv_names();
+}
+
+# Code sections
+my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect,
+ $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
+ $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
+ $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
+ $xrvsect, $xpvbmsect, $xpviosect);
+
+sub walk_and_save_optree;
+my $saveoptree_callback = \&walk_and_save_optree;
+sub set_callback { $saveoptree_callback = shift }
+sub saveoptree { &$saveoptree_callback(@_) }
+
+sub walk_and_save_optree {
+ my ($name, $root, $start) = @_;
+ walkoptree($root, "save");
+ return objsym($start);
+}
+
+# Current workaround/fix for op_free() trying to free statically
+# defined OPs is to set op_seq = -1 and check for that in op_free().
+# Instead of hardwiring -1 in place of $op->seq, we use $op_seq
+# so that it can be changed back easily if necessary. In fact, to
+# stop compilers from moaning about a U16 being initialised with an
+# uncast -1 (the printf format is %d so we can't tweak it), we have
+# to "know" that op_seq is a U16 and use 65535. Ugh.
+my $op_seq = 65535;
+
+sub AVf_REAL () { 1 }
+
+# XXX This shouldn't really be hardcoded here but it saves
+# looking up the name of every BASEOP in B::OP
+sub OP_THREADSV () { 345 }
+
+sub savesym {
+ my ($obj, $value) = @_;
+ my $sym = sprintf("s\\_%x", $$obj);
+ $symtable{$sym} = $value;
+}
+
+sub objsym {
+ my $obj = shift;
+ return $symtable{sprintf("s\\_%x", $$obj)};
+}
+
+sub getsym {
+ my $sym = shift;
+ my $value;
+
+ return 0 if $sym eq "sym_0"; # special case
+ $value = $symtable{$sym};
+ if (defined($value)) {
+ return $value;
+ } else {
+ warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
+ return "UNUSED";
+ }
+}
+
+sub savepv {
+ my $pv = shift;
+ my $pvsym = 0;
+ my $pvmax = 0;
+ if ($pv_copy_on_grow) {
+ my $cstring = cstring($pv);
+ if ($cstring ne "0") { # sic
+ $pvsym = sprintf("pv%d", $pv_index++);
+ $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
+ }
+ } else {
+ $pvmax = length($pv) + 1;
+ }
+ return ($pvsym, $pvmax);
+}
+
+sub B::OP::save {
+ my ($op, $level) = @_;
+ my $type = $op->type;
+ $nullop_count++ unless $type;
+ if ($type == OP_THREADSV) {
+ # saves looking up ppaddr but it's a bit naughty to hard code this
+ $init->add(sprintf("(void)find_threadsv(%s);",
+ cstring($threadsv_names[$op->targ])));
+ }
+ $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
+ $type, $op_seq, $op->flags, $op->private));
+ savesym($op, sprintf("&op_list[%d]", $opsect->index));
+}
+
+sub B::FAKEOP::new {
+ my ($class, %objdata) = @_;
+ bless \%objdata, $class;
+}
+
+sub B::FAKEOP::save {
+ my ($op, $level) = @_;
+ $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
+ $op->next, $op->sibling, $op->ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private));
+ return sprintf("&op_list[%d]", $opsect->index);
+}
+
+sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
+sub B::FAKEOP::type { $_[0]->{type} || 0}
+sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
+sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
+sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
+sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
+sub B::FAKEOP::private { $_[0]->{private} || 0 }
+
+sub B::UNOP::save {
+ my ($op, $level) = @_;
+ $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr,
+ $op->targ, $op->type, $op_seq, $op->flags,
+ $op->private, ${$op->first}));
+ savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
+}
+
+sub B::BINOP::save {
+ my ($op, $level) = @_;
+ $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr,
+ $op->targ, $op->type, $op_seq, $op->flags,
+ $op->private, ${$op->first}, ${$op->last}));
+ savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
+}
+
+sub B::LISTOP::save {
+ my ($op, $level) = @_;
+ $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr,
+ $op->targ, $op->type, $op_seq, $op->flags,
+ $op->private, ${$op->first}, ${$op->last},
+ $op->children));
+ savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
+}
+
+sub B::LOGOP::save {
+ my ($op, $level) = @_;
+ $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr,
+ $op->targ, $op->type, $op_seq, $op->flags,
+ $op->private, ${$op->first}, ${$op->other}));
+ savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
+}
+
+sub B::CONDOP::save {
+ my ($op, $level) = @_;
+ $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr,
+ $op->targ, $op->type, $op_seq, $op->flags,
+ $op->private, ${$op->first}, ${$op->true},
+ ${$op->false}));
+ savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index));
+}
+
+sub B::LOOP::save {
+ my ($op, $level) = @_;
+ #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
+ # peekop($op->redoop), peekop($op->nextop),
+ # peekop($op->lastop)); # debug
+ $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr,
+ $op->targ, $op->type, $op_seq, $op->flags,
+ $op->private, ${$op->first}, ${$op->last},
+ $op->children, ${$op->redoop}, ${$op->nextop},
+ ${$op->lastop}));
+ savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
+}
+
+sub B::PVOP::save {
+ my ($op, $level) = @_;
+ $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr,
+ $op->targ, $op->type, $op_seq, $op->flags,
+ $op->private, cstring($op->pv)));
+ savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
+}
+
+sub B::SVOP::save {
+ my ($op, $level) = @_;
+ my $svsym = $op->sv->save;
+ $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr,
+ $op->targ, $op->type, $op_seq, $op->flags,
+ $op->private, "(SV*)$svsym"));
+ savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
+}
+
+sub B::GVOP::save {
+ my ($op, $level) = @_;
+ my $gvsym = $op->gv->save;
+ $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr,
+ $op->targ, $op->type, $op_seq, $op->flags,
+ $op->private));
+ $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
+ savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
+}
+
+sub B::COP::save {
+ my ($op, $level) = @_;
+ my $gvsym = $op->filegv->save;
+ my $stashsym = $op->stash->save;
+ warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
+ if $debug_cops;
+ $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
+ ${$op->next}, ${$op->sibling}, $op->ppaddr,
+ $op->targ, $op->type, $op_seq, $op->flags,
+ $op->private, cstring($op->label), $op->cop_seq,
+ $op->arybase, $op->line));
+ my $copix = $copsect->index;
+ $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
+ sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
+ savesym($op, "(OP*)&cop_list[$copix]");
+}
+
+sub B::PMOP::save {
+ my ($op, $level) = @_;
+ my $replroot = $op->pmreplroot;
+ my $replstart = $op->pmreplstart;
+ my $replrootfield = sprintf("s\\_%x", $$replroot);
+ my $replstartfield = sprintf("s\\_%x", $$replstart);
+ my $gvsym;
+ my $ppaddr = $op->ppaddr;
+ if ($$replroot) {
+ # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
+ # argument to a split) stores a GV in op_pmreplroot instead
+ # of a substitution syntax tree. We don't want to walk that...
+ if ($ppaddr eq "pp_pushre") {
+ $gvsym = $replroot->save;
+# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
+ $replrootfield = 0;
+ } else {
+ $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
+ }
+ }
+ # pmnext handling is broken in perl itself, I think. Bad op_pmnext
+ # fields aren't noticed in perl's runtime (unless you try reset) but we
+ # segfault when trying to dereference it to find op->op_pmnext->op_type
+ $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
+ ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
+ $op->type, $op_seq, $op->flags, $op->private,
+ ${$op->first}, ${$op->last}, $op->children,
+ $replrootfield, $replstartfield,
+ $op->pmflags, $op->pmpermflags,));
+ my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
+ my $re = $op->precomp;
+ if (defined($re)) {
+ my $resym = sprintf("re%d", $re_index++);
+ $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
+ $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
+ length($re)));
+ }
+ if ($gvsym) {
+ $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
+ }
+ savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
+}
+
+sub B::SPECIAL::save {
+ my ($sv) = @_;
+ # special case: $$sv is not the address but an index into specialsv_list
+# warn "SPECIAL::save specialsv $$sv\n"; # debug
+ my $sym = $specialsv_name[$$sv];
+ if (!defined($sym)) {
+ confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
+ }
+ return $sym;
+}
+
+sub B::OBJECT::save {}
+
+sub B::NULL::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+# warn "Saving SVt_NULL SV\n"; # debug
+ # debug
+ #if ($$sv == 0) {
+ # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
+ #}
+ $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::IV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
+ $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
+ $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::NV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
+ $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
+ $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVLV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ my ($lvtarg, $lvtarg_sym);
+ $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
+ $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
+ $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
+ $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
+ $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
+ $xpvlvsect->index, cstring($pv), $len));
+ }
+ $sv->save_magic;
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVIV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
+ $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
+ $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
+ $xpvivsect->index, cstring($pv), $len));
+ }
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVNV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
+ $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
+ $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
+ $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
+ $xpvnvsect->index, cstring($pv), $len));
+ }
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::BM::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV . "\0" . $sv->TABLE;
+ my $len = length($pv);
+ $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
+ $len, $len + 258, $sv->IVX, $sv->NVX,
+ $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
+ $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
+ $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+ $sv->save_magic;
+ $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
+ $xpvbmsect->index, cstring($pv), $len),
+ sprintf("xpvbm_list[%d].xpv_cur = %u;",
+ $xpvbmsect->index, $len - 257));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
+ $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
+ $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
+ $xpvsect->index, cstring($pv), $len));
+ }
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub B::PVMG::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ my $pv = $sv->PV;
+ my $len = length($pv);
+ my ($pvsym, $pvmax) = savepv($pv);
+ $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
+ $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
+ $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
+ $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+ if (!$pv_copy_on_grow) {
+ $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
+ $xpvmgsect->index, cstring($pv), $len));
+ }
+ $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+ $sv->save_magic;
+ return $sym;
+}
+
+sub B::PVMG::save_magic {
+ my ($sv) = @_;
+ #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
+ my $stash = $sv->SvSTASH;
+ if ($$stash) {
+ warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
+ if $debug_mg;
+ # XXX Hope stash is already going to be saved.
+ $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
+ }
+ my @mgchain = $sv->MAGIC;
+ my ($mg, $type, $obj, $ptr);
+ foreach $mg (@mgchain) {
+ $type = $mg->TYPE;
+ $obj = $mg->OBJ;
+ $ptr = $mg->PTR;
+ my $len = defined($ptr) ? length($ptr) : 0;
+ if ($debug_mg) {
+ warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
+ class($sv), $$sv, class($obj), $$obj,
+ cchar($type), cstring($ptr));
+ }
+ $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
+ $$sv, $$obj, cchar($type),cstring($ptr),$len));
+ }
+}
+
+sub B::RV::save {
+ my ($sv) = @_;
+ my $sym = objsym($sv);
+ return $sym if defined $sym;
+ $xrvsect->add($sv->RV->save);
+ $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
+ $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
+ return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
+}
+
+sub try_autoload {
+ my ($cvstashname, $cvname) = @_;
+ warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
+ # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
+ # use should be handled by the class itself.
+ no strict 'refs';
+ my $isa = \@{"$cvstashname\::ISA"};
+ if (grep($_ eq "AutoLoader", @$isa)) {
+ warn "Forcing immediate load of sub derived from AutoLoader\n";
+ # Tweaked version of AutoLoader::AUTOLOAD
+ my $dir = $cvstashname;
+ $dir =~ s(::)(/)g;
+ eval { require "auto/$dir/$cvname.al" };
+ if ($@) {
+ warn qq(failed require "auto/$dir/$cvname.al": $@\n);
+ return 0;
+ } else {
+ return 1;
+ }
+ }
+}
+
+sub B::CV::save {
+ my ($cv) = @_;
+ my $sym = objsym($cv);
+ if (defined($sym)) {
+# warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
+ return $sym;
+ }
+ # Reserve a place in svsect and xpvcvsect and record indices
+ my $sv_ix = $svsect->index + 1;
+ $svsect->add("svix$sv_ix");
+ my $xpvcv_ix = $xpvcvsect->index + 1;
+ $xpvcvsect->add("xpvcvix$xpvcv_ix");
+ # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
+ $sym = savesym($cv, "&sv_list[$sv_ix]");
+ warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
+ my $gv = $cv->GV;
+ my $cvstashname = $gv->STASH->NAME;
+ my $cvname = $gv->NAME;
+ my $root = $cv->ROOT;
+ my $cvxsub = $cv->XSUB;
+ if (!$$root && !$cvxsub) {
+ if (try_autoload($cvstashname, $cvname)) {
+ # Recalculate root and xsub
+ $root = $cv->ROOT;
+ $cvxsub = $cv->XSUB;
+ if ($$root || $cvxsub) {
+ warn "Successful forced autoload\n";
+ }
+ }
+ }
+ my $startfield = 0;
+ my $padlist = $cv->PADLIST;
+ my $pv = $cv->PV;
+ my $xsub = 0;
+ my $xsubany = "Nullany";
+ if ($$root) {
+ warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
+ $$cv, $$root) if $debug_cv;
+ my $ppname = "";
+ if ($$gv) {
+ my $stashname = $gv->STASH->NAME;
+ my $gvname = $gv->NAME;
+ if ($gvname ne "__ANON__") {
+ $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
+ $ppname .= ($stashname eq "main") ?
+ $gvname : "$stashname\::$gvname";
+ $ppname =~ s/::/__/g;
+ }
+ }
+ if (!$ppname) {
+ $ppname = "pp_anonsub_$anonsub_index";
+ $anonsub_index++;
+ }
+ $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
+ warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
+ $$cv, $ppname, $$root) if $debug_cv;
+ if ($$padlist) {
+ warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
+ $$padlist, $$cv) if $debug_cv;
+ $padlist->save;
+ warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
+ $$padlist, $$cv) if $debug_cv;
+ }
+ }
+ elsif ($cvxsub) {
+ $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
+ # Try to find out canonical name of XSUB function from EGV.
+ # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
+ # calls newXS() manually with weird arguments).
+ my $egv = $gv->EGV;
+ my $stashname = $egv->STASH->NAME;
+ $stashname =~ s/::/__/g;
+ $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
+ $decl->add("void $xsub _((CV*));");
+ }
+ else {
+ warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
+ $cvstashname, $cvname); # debug
+ }
+ $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0",
+ $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
+ $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
+ $$padlist, ${$cv->OUTSIDE}));
+ if ($$gv) {
+ $gv->save;
+ $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
+ warn sprintf("done saving GV 0x%x for CV 0x%x\n",
+ $$gv, $$cv) if $debug_cv;
+ }
+ my $filegv = $cv->FILEGV;
+ if ($$filegv) {
+ $filegv->save;
+ $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
+ warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
+ $$filegv, $$cv) if $debug_cv;
+ }
+ my $stash = $cv->STASH;
+ if ($$stash) {
+ $stash->save;
+ $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
+ warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
+ $$stash, $$cv) if $debug_cv;
+ }
+ $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
+ $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
+ return $sym;
+}
+
+sub B::GV::save {
+ my ($gv) = @_;
+ my $sym = objsym($gv);
+ if (defined($sym)) {
+ #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
+ return $sym;
+ } else {
+ my $ix = $gv_index++;
+ $sym = savesym($gv, "gv_list[$ix]");
+ #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
+ }
+ my $gvname = $gv->NAME;
+ my $name = cstring($gv->STASH->NAME . "::" . $gvname);
+ #warn "GV name is $name\n"; # debug
+ my $egv = $gv->EGV;
+ my $egvsym;
+ if ($$gv != $$egv) {
+ #warn(sprintf("EGV name is %s, saving it now\n",
+ # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
+ $egvsym = $egv->save;
+ }
+ $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
+ sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
+ sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
+ sprintf("GvLINE($sym) = %u;", $gv->LINE));
+ # Shouldn't need to do save_magic since gv_fetchpv handles that
+ #$gv->save_magic;
+ my $refcnt = $gv->REFCNT + 1;
+ $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
+ my $gvrefcnt = $gv->GvREFCNT;
+ if ($gvrefcnt > 1) {
+ $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
+ }
+ if (defined($egvsym)) {
+ # Shared glob *foo = *bar
+ $init->add("gp_free($sym);",
+ "GvGP($sym) = GvGP($egvsym);");
+ } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
+ # Don't save subfields of special GVs (*_, *1, *# and so on)
+# warn "GV::save saving subfields\n"; # debug
+ my $gvsv = $gv->SV;
+ if ($$gvsv) {
+ $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
+# warn "GV::save \$$name\n"; # debug
+ $gvsv->save;
+ }
+ my $gvav = $gv->AV;
+ if ($$gvav) {
+ $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
+# warn "GV::save \@$name\n"; # debug
+ $gvav->save;
+ }
+ my $gvhv = $gv->HV;
+ if ($$gvhv) {
+ $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
+# warn "GV::save \%$name\n"; # debug
+ $gvhv->save;
+ }
+ my $gvcv = $gv->CV;
+ if ($$gvcv) {
+ $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
+# warn "GV::save &$name\n"; # debug
+ $gvcv->save;
+ }
+ my $gvfilegv = $gv->FILEGV;
+ if ($$gvfilegv) {
+ $init->add(sprintf("GvFILEGV($sym) = s\\_%x;",$$gvfilegv));
+# warn "GV::save GvFILEGV(*$name)\n"; # debug
+ $gvfilegv->save;
+ }
+ my $gvform = $gv->FORM;
+ if ($$gvform) {
+ $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
+# warn "GV::save GvFORM(*$name)\n"; # debug
+ $gvform->save;
+ }
+ my $gvio = $gv->IO;
+ if ($$gvio) {
+ $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
+# warn "GV::save GvIO(*$name)\n"; # debug
+ $gvio->save;
+ }
+ }
+ return $sym;
+}
+sub B::AV::save {
+ my ($av) = @_;
+ my $sym = objsym($av);
+ return $sym if defined $sym;
+ my $avflags = $av->AvFLAGS;
+ $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
+ $avflags));
+ $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
+ $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
+ my $sv_list_index = $svsect->index;
+ my $fill = $av->FILL;
+ $av->save_magic;
+ warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
+ if $debug_av;
+ # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
+ #if ($fill > -1 && ($avflags & AVf_REAL)) {
+ if ($fill > -1) {
+ my @array = $av->ARRAY;
+ if ($debug_av) {
+ my $el;
+ my $i = 0;
+ foreach $el (@array) {
+ warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
+ $$av, $i++, class($el), $$el);
+ }
+ }
+ my @names = map($_->save, @array);
+ # XXX Better ways to write loop?
+ # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
+ # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
+ $init->add("{",
+ "\tSV **svp;",
+ "\tAV *av = (AV*)&sv_list[$sv_list_index];",
+ "\tav_extend(av, $fill);",
+ "\tsvp = AvARRAY(av);",
+ map("\t*svp++ = (SV*)$_;", @names),
+ "\tAvFILLp(av) = $fill;",
+ "}");
+ } else {
+ my $max = $av->MAX;
+ $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
+ if $max > -1;
+ }
+ return savesym($av, "(AV*)&sv_list[$sv_list_index]");
+}
+
+sub B::HV::save {
+ my ($hv) = @_;
+ my $sym = objsym($hv);
+ return $sym if defined $sym;
+ my $name = $hv->NAME;
+ if ($name) {
+ # It's a stash
+
+ # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
+ # the only symptom is that sv_reset tries to reset the PMf_USED flag of
+ # a trashed op but we look at the trashed op_type and segfault.
+ #my $adpmroot = ${$hv->PMROOT};
+ my $adpmroot = 0;
+ $decl->add("static HV *hv$hv_index;");
+ # XXX Beware of weird package names containing double-quotes, \n, ...?
+ $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
+ if ($adpmroot) {
+ $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
+ $adpmroot));
+ }
+ $sym = savesym($hv, "hv$hv_index");
+ $hv_index++;
+ return $sym;
+ }
+ # It's just an ordinary HV
+ $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
+ $hv->MAX, $hv->RITER));
+ $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
+ $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
+ my $sv_list_index = $svsect->index;
+ my @contents = $hv->ARRAY;
+ if (@contents) {
+ my $i;
+ for ($i = 1; $i < @contents; $i += 2) {
+ $contents[$i] = $contents[$i]->save;
+ }
+ $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
+ while (@contents) {
+ my ($key, $value) = splice(@contents, 0, 2);
+ $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
+ cstring($key),length($key),$value, hash($key)));
+ }
+ $init->add("}");
+ }
+ return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
+}
+
+sub B::IO::save {
+ my ($io) = @_;
+ my $sym = objsym($io);
+ return $sym if defined $sym;
+ my $pv = $io->PV;
+ my $len = length($pv);
+ $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
+ $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
+ $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
+ cstring($io->TOP_NAME), cstring($io->FMT_NAME),
+ cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
+ cchar($io->IoTYPE), $io->IoFLAGS));
+ $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
+ $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
+ $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
+ my ($field, $fsym);
+ foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
+ $fsym = $io->$field();
+ if ($$fsym) {
+ $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
+ $fsym->save;
+ }
+ }
+ $io->save_magic;
+ return $sym;
+}
+
+sub B::SV::save {
+ my $sv = shift;
+ # This is where we catch an honest-to-goodness Nullsv (which gets
+ # blessed into B::SV explicitly) and any stray erroneous SVs.
+ return 0 unless $$sv;
+ confess sprintf("cannot save that type of SV: %s (0x%x)\n",
+ class($sv), $$sv);
+}
+
+sub output_all {
+ my $init_name = shift;
+ my $section;
+ my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
+ $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
+ $cvopsect, $loopsect, $copsect, $svsect, $xpvsect,
+ $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
+ $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
+ $symsect->output(\*STDOUT, "#define %s\n");
+ print "\n";
+ output_declarations();
+ foreach $section (@sections) {
+ my $lines = $section->index + 1;
+ if ($lines) {
+ my $name = $section->name;
+ my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
+ print "Static $typename ${name}_list[$lines];\n";
+ }
+ }
+ $decl->output(\*STDOUT, "%s\n");
+ print "\n";
+ foreach $section (@sections) {
+ my $lines = $section->index + 1;
+ if ($lines) {
+ my $name = $section->name;
+ my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
+ printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
+ $section->output(\*STDOUT, "\t{ %s },\n");
+ print "};\n\n";
+ }
+ }
+
+ print <<"EOT";
+static int $init_name()
+{
+ dTHR;
+EOT
+ $init->output(\*STDOUT, "\t%s\n");
+ print "\treturn 0;\n}\n";
+ if ($verbose) {
+ warn compile_stats();
+ warn "NULLOP count: $nullop_count\n";
+ }
+}
+
+sub output_declarations {
+ print <<'EOT';
+#ifdef BROKEN_STATIC_REDECL
+#define Static extern
+#else
+#define Static static
+#endif /* BROKEN_STATIC_REDECL */
+
+#ifdef BROKEN_UNION_INIT
+/*
+ * Cribbed from cv.h with ANY (a union) replaced by void*.
+ * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
+ */
+typedef struct {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xp_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xof_off; /* integer value */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* magic for scalar array */
+ HV* xmg_stash; /* class package */
+
+ HV * xcv_stash;
+ OP * xcv_start;
+ OP * xcv_root;
+ void (*xcv_xsub) _((CV*));
+ void * xcv_xsubany;
+ GV * xcv_gv;
+ GV * xcv_filegv;
+ long xcv_depth; /* >= 2 indicates recursive call */
+ AV * xcv_padlist;
+ CV * xcv_outside;
+#ifdef USE_THREADS
+ perl_mutex *xcv_mutexp;
+ struct perl_thread *xcv_owner; /* current owner thread */
+#endif /* USE_THREADS */
+ U8 xcv_flags;
+} XPVCV_or_similar;
+#define ANYINIT(i) i
+#else
+#define XPVCV_or_similar XPVCV
+#define ANYINIT(i) {i}
+#endif /* BROKEN_UNION_INIT */
+#define Nullany ANYINIT(0)
+
+#define UNUSED 0
+#define sym_0 0
+
+EOT
+ print "static GV *gv_list[$gv_index];\n" if $gv_index;
+ print "\n";
+}
+
+
+sub output_boilerplate {
+ print <<'EOT';
+#include "EXTERN.h"
+#include "perl.h"
+#ifndef PATCHLEVEL
+#include "patchlevel.h"
+#endif
+
+/* Workaround for mapstart: the only op which needs a different ppaddr */
+#undef pp_mapstart
+#define pp_mapstart pp_grepstart
+
+static void xs_init _((void));
+static PerlInterpreter *my_perl;
+EOT
+}
+
+sub output_main {
+ print <<'EOT';
+int
+#ifndef CAN_PROTOTYPE
+main(argc, argv, env)
+int argc;
+char **argv;
+char **env;
+#else /* def(CAN_PROTOTYPE) */
+main(int argc, char **argv, char **env)
+#endif /* def(CAN_PROTOTYPE) */
+{
+ int exitstatus;
+ int i;
+ char **fakeargv;
+
+ PERL_SYS_INIT(&argc,&argv);
+
+ perl_init_i18nl10n(1);
+
+ if (!PL_do_undump) {
+ my_perl = perl_alloc();
+ if (!my_perl)
+ exit(1);
+ perl_construct( my_perl );
+ }
+
+#ifdef CSH
+ if (!PL_cshlen)
+ PL_cshlen = strlen(PL_cshname);
+#endif
+
+#ifdef ALLOW_PERL_OPTIONS
+#define EXTRA_OPTIONS 2
+#else
+#define EXTRA_OPTIONS 3
+#endif /* ALLOW_PERL_OPTIONS */
+ New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
+ fakeargv[0] = argv[0];
+ fakeargv[1] = "-e";
+ fakeargv[2] = "";
+#ifndef ALLOW_PERL_OPTIONS
+ fakeargv[3] = "--";
+#endif /* ALLOW_PERL_OPTIONS */
+ for (i = 1; i < argc; i++)
+ fakeargv[i + EXTRA_OPTIONS] = argv[i];
+ fakeargv[argc + EXTRA_OPTIONS] = 0;
+
+ exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
+ fakeargv, NULL);
+ if (exitstatus)
+ exit( exitstatus );
+
+ sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
+ PL_main_cv = PL_compcv;
+ PL_compcv = 0;
+
+ exitstatus = perl_init();
+ if (exitstatus)
+ exit( exitstatus );
+
+ exitstatus = perl_run( my_perl );
+
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+
+ exit( exitstatus );
+}
+
+static void
+xs_init()
+{
+}
+EOT
+}
+
+sub dump_symtable {
+ # For debugging
+ my ($sym, $val);
+ warn "----Symbol table:\n";
+ while (($sym, $val) = each %symtable) {
+ warn "$sym => $val\n";
+ }
+ warn "---End of symbol table\n";
+}
+
+sub save_object {
+ my $sv;
+ foreach $sv (@_) {
+ svref_2object($sv)->save;
+ }
+}
+
+sub B::GV::savecv {
+ my $gv = shift;
+ my $cv = $gv->CV;
+ my $name = $gv->NAME;
+ if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
+ if ($debug_cv) {
+ warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
+ $gv->STASH->NAME, $name, $$cv, $$gv);
+ }
+ $gv->save;
+ }
+}
+
+sub save_unused_subs {
+ my %search_pack;
+ map { $search_pack{$_} = 1 } @_;
+ no strict qw(vars refs);
+ walksymtable(\%{"main::"}, "savecv", sub {
+ my $package = shift;
+ $package =~ s/::$//;
+ #warn "Considering $package\n";#debug
+ return 1 if exists $search_pack{$package};
+ #warn " (nothing explicit)\n";#debug
+ # Omit the packages which we use (and which cause grief
+ # because of fancy "goto &$AUTOLOAD" stuff).
+ # XXX Surely there must be a nicer way to do this.
+ if ($package eq "FileHandle"
+ || $package eq "Config"
+ || $package eq "SelectSaver") {
+ return 0;
+ }
+ my $m;
+ foreach $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
+ if (defined(&{$package."::$m"})) {
+ warn "$package has method $m: -u$package assumed\n";#debug
+ return 1;
+ }
+ }
+ return 0;
+ });
+}
+
+sub save_main {
+ my $curpad_sym = (comppadlist->ARRAY)[1]->save;
+ walkoptree(main_root, "save");
+ warn "done main optree, walking symtable for extras\n" if $debug_cv;
+ save_unused_subs(@unused_sub_packages);
+
+ $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
+ sprintf("PL_main_start = s\\_%x;", ${main_start()}),
+ "PL_curpad = AvARRAY($curpad_sym);");
+ output_boilerplate();
+ print "\n";
+ output_all("perl_init");
+ print "\n";
+ output_main();
+}
+
+sub init_sections {
+ my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
+ binop => \$binopsect, condop => \$condopsect,
+ cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect,
+ listop => \$listopsect, logop => \$logopsect,
+ loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
+ pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
+ sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
+ xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
+ xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
+ xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
+ xrv => \$xrvsect, xpvbm => \$xpvbmsect,
+ xpvio => \$xpviosect);
+ my ($name, $sectref);
+ while (($name, $sectref) = splice(@sections, 0, 2)) {
+ $$sectref = new B::Section $name, \%symtable, 0;
+ }
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ }
+ if ($opt eq "w") {
+ $warn_undefined_syms = 1;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "c") {
+ $debug_cops = 1;
+ } elsif ($arg eq "A") {
+ $debug_av = 1;
+ } elsif ($arg eq "C") {
+ $debug_cv = 1;
+ } elsif ($arg eq "M") {
+ $debug_mg = 1;
+ } else {
+ warn "ignoring unknown debug option: $arg\n";
+ }
+ }
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "$arg: $!\n";
+ } elsif ($opt eq "v") {
+ $verbose = 1;
+ } elsif ($opt eq "u") {
+ $arg ||= shift @options;
+ push(@unused_sub_packages, $arg);
+ } elsif ($opt eq "f") {
+ $arg ||= shift @options;
+ if ($arg eq "cog") {
+ $pv_copy_on_grow = 1;
+ } elsif ($arg eq "no-cog") {
+ $pv_copy_on_grow = 0;
+ }
+ } elsif ($opt eq "O") {
+ $arg = 1 if $arg eq "";
+ $pv_copy_on_grow = 0;
+ if ($arg >= 1) {
+ # Optimisations for -O1
+ $pv_copy_on_grow = 1;
+ }
+ }
+ }
+ init_sections();
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ eval "save_object(\\$objname)";
+ }
+ output_all();
+ }
+ } else {
+ return sub { save_main() };
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::C - Perl compiler's C backend
+
+=head1 SYNOPSIS
+
+ perl -MO=C[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This compiler backend takes Perl source and generates C source code
+corresponding to the internal structures that perl uses to run
+your program. When the generated C source is compiled and run, it
+cuts out the time which perl would have taken to load and parse
+your program into its internal semi-compiled form. That means that
+compiling with this backend will not help improve the runtime
+execution speed of your program but may improve the start-up time.
+Depending on the environment in which your program runs this may be
+either a help or a hindrance.
+
+=head1 OPTIONS
+
+If there are any non-option arguments, they are taken to be
+names of objects to be saved (probably doesn't work properly yet).
+Without extra arguments, it saves the main program.
+
+=over 4
+
+=item B<-ofilename>
+
+Output to filename instead of STDOUT
+
+=item B<-v>
+
+Verbose compilation (currently gives a few compilation statistics).
+
+=item B<-->
+
+Force end of options
+
+=item B<-uPackname>
+
+Force apparently unused subs from package Packname to be compiled.
+This allows programs to use eval "foo()" even when sub foo is never
+seen to be used at compile time. The down side is that any subs which
+really are never used also have code generated. This option is
+necessary, for example, if you have a signal handler foo which you
+initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
+to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
+options. The compiler tries to figure out which packages may possibly
+have subs in which need compiling but the current version doesn't do
+it very well. In particular, it is confused by nested packages (i.e.
+of the form C<A::B>) where package C<A> does not contain any subs.
+
+=item B<-D>
+
+Debug options (concatenated or separate flags like C<perl -D>).
+
+=item B<-Do>
+
+OPs, prints each OP as it's processed
+
+=item B<-Dc>
+
+COPs, prints COPs as processed (incl. file & line num)
+
+=item B<-DA>
+
+prints AV information on saving
+
+=item B<-DC>
+
+prints CV information on saving
+
+=item B<-DM>
+
+prints MAGIC information on saving
+
+=item B<-f>
+
+Force optimisations on or off one at a time.
+
+=item B<-fcog>
+
+Copy-on-grow: PVs declared and initialised statically.
+
+=item B<-fno-cog>
+
+No copy-on-grow.
+
+=item B<-On>
+
+Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. Currently,
+B<-O1> and higher set B<-fcog>.
+
+=head1 EXAMPLES
+
+ perl -MO=C,-ofoo.c foo.pl
+ perl cc_harness -o foo foo.c
+
+Note that C<cc_harness> lives in the C<B> subdirectory of your perl
+library directory. The utility called C<perlcc> may also be used to
+help make use of this compiler.
+
+ perl -MO=C,-v,-DcA bar.pl > /dev/null
+
+=head1 BUGS
+
+Plenty. Current status: experimental.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/CC.pm b/contrib/perl5/ext/B/B/CC.pm
new file mode 100644
index 000000000000..9991d8e70078
--- /dev/null
+++ b/contrib/perl5/ext/B/B/CC.pm
@@ -0,0 +1,1734 @@
+# CC.pm
+#
+# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::CC;
+use strict;
+use B qw(main_start main_root class comppadlist peekop svref_2object
+ timing_info);
+use B::C qw(save_unused_subs objsym init_sections
+ output_all output_boilerplate output_main);
+use B::Bblock qw(find_leaders);
+use B::Stackobj qw(:types :flags);
+
+# These should probably be elsewhere
+# Flags for $op->flags
+sub OPf_LIST () { 1 }
+sub OPf_KNOW () { 2 }
+sub OPf_MOD () { 32 }
+sub OPf_STACKED () { 64 }
+sub OPf_SPECIAL () { 128 }
+# op-specific flags for $op->private
+sub OPpASSIGN_BACKWARDS () { 64 }
+sub OPpLVAL_INTRO () { 128 }
+sub OPpDEREF_AV () { 32 }
+sub OPpDEREF_HV () { 64 }
+sub OPpDEREF () { OPpDEREF_AV|OPpDEREF_HV }
+sub OPpFLIP_LINENUM () { 64 }
+sub G_ARRAY () { 1 }
+# cop.h
+sub CXt_NULL () { 0 }
+sub CXt_SUB () { 1 }
+sub CXt_EVAL () { 2 }
+sub CXt_LOOP () { 3 }
+sub CXt_SUBST () { 4 }
+sub CXt_BLOCK () { 5 }
+
+my $module; # module name (when compiled with -m)
+my %done; # hash keyed by $$op of leaders of basic blocks
+ # which have already been done.
+my $leaders; # ref to hash of basic block leaders. Keys are $$op
+ # addresses, values are the $op objects themselves.
+my @bblock_todo; # list of leaders of basic blocks that need visiting
+ # sometime.
+my @cc_todo; # list of tuples defining what PP code needs to be
+ # saved (e.g. CV, main or PMOP repl code). Each tuple
+ # is [$name, $root, $start, @padlist]. PMOP repl code
+ # tuples inherit padlist.
+my @stack; # shadows perl's stack when contents are known.
+ # Values are objects derived from class B::Stackobj
+my @pad; # Lexicals in current pad as Stackobj-derived objects
+my @padlist; # Copy of current padlist so PMOP repl code can find it
+my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
+my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
+my %constobj; # OP_CONST constants as Stackobj-derived objects
+ # keyed by $$sv.
+my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
+ # block or even to the end of each loop of blocks,
+ # depending on optimisation options.
+my $know_op = 0; # Set when C variable op already holds the right op
+ # (from an immediately preceding DOOP(ppname)).
+my $errors = 0; # Number of errors encountered
+my %skip_stack; # Hash of PP names which don't need write_back_stack
+my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
+my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
+my %ignore_op; # Hash of ops which do nothing except returning op_next
+
+BEGIN {
+ foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
+ $ignore_op{$_} = 1;
+ }
+}
+
+my @unused_sub_packages; # list of packages (given by -u options) to search
+ # explicitly and save every sub we find there, even
+ # if apparently unused (could be only referenced from
+ # an eval "" or from a $SIG{FOO} = "bar").
+
+my ($module_name);
+my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
+ $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
+
+# Optimisation options. On the command line, use hyphens instead of
+# underscores for compatibility with gcc-style options. We use
+# underscores here because they are OK in (strict) barewords.
+my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
+my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
+ freetmps_each_loop => \$freetmps_each_loop,
+ omit_taint => \$omit_taint);
+# perl patchlevel to generate code for (defaults to current patchlevel)
+my $patchlevel = int(0.5 + 1000 * ($] - 5));
+
+# Could rewrite push_runtime() and output_runtime() to use a
+# temporary file if memory is at a premium.
+my $ppname; # name of current fake PP function
+my $runtime_list_ref;
+my $declare_ref; # Hash ref keyed by C variable type of declarations.
+
+my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
+ # tuples to be written out.
+
+my ($init, $decl);
+
+sub init_hash { map { $_ => 1 } @_ }
+
+#
+# Initialise the hashes for the default PP functions where we can avoid
+# either write_back_stack, write_back_lexicals or invalidate_lexicals.
+#
+%skip_lexicals = init_hash qw(pp_enter pp_enterloop);
+%skip_invalidate = init_hash qw(pp_enter pp_enterloop);
+
+sub debug {
+ if ($debug_runtime) {
+ warn(@_);
+ } else {
+ runtime(map { chomp; "/* $_ */"} @_);
+ }
+}
+
+sub declare {
+ my ($type, $var) = @_;
+ push(@{$declare_ref->{$type}}, $var);
+}
+
+sub push_runtime {
+ push(@$runtime_list_ref, @_);
+ warn join("\n", @_) . "\n" if $debug_runtime;
+}
+
+sub save_runtime {
+ push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
+}
+
+sub output_runtime {
+ my $ppdata;
+ print qq(#include "cc_runtime.h"\n);
+ foreach $ppdata (@pp_list) {
+ my ($name, $runtime, $declare) = @$ppdata;
+ print "\nstatic\nPP($name)\n{\n";
+ my ($type, $varlist, $line);
+ while (($type, $varlist) = each %$declare) {
+ print "\t$type ", join(", ", @$varlist), ";\n";
+ }
+ foreach $line (@$runtime) {
+ print $line, "\n";
+ }
+ print "}\n";
+ }
+}
+
+sub runtime {
+ my $line;
+ foreach $line (@_) {
+ push_runtime("\t$line");
+ }
+}
+
+sub init_pp {
+ $ppname = shift;
+ $runtime_list_ref = [];
+ $declare_ref = {};
+ runtime("djSP;");
+ declare("I32", "oldsave");
+ declare("SV", "**svp");
+ map { declare("SV", "*$_") } qw(sv src dst left right);
+ declare("MAGIC", "*mg");
+ $decl->add("static OP * $ppname _((ARGSproto));");
+ debug "init_pp: $ppname\n" if $debug_queue;
+}
+
+# Initialise runtime_callback function for Stackobj class
+BEGIN { B::Stackobj::set_callback(\&runtime) }
+
+# Initialise saveoptree_callback for B::C class
+sub cc_queue {
+ my ($name, $root, $start, @pl) = @_;
+ debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
+ if $debug_queue;
+ if ($name eq "*ignore*") {
+ $name = 0;
+ } else {
+ push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
+ }
+ my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
+ $start = $fakeop->save;
+ debug "cc_queue: name $name returns $start\n" if $debug_queue;
+ return $start;
+}
+BEGIN { B::C::set_callback(\&cc_queue) }
+
+sub valid_int { $_[0]->{flags} & VALID_INT }
+sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
+sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
+sub valid_sv { $_[0]->{flags} & VALID_SV }
+
+sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
+sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
+sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
+sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
+sub top_bool { @stack ? $stack[-1]->as_numeric : "SvTRUE(TOPs)" }
+
+sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
+sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
+sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
+sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
+sub pop_bool {
+ if (@stack) {
+ return ((pop @stack)->as_numeric);
+ } else {
+ # Careful: POPs has an auto-decrement and SvTRUE evaluates
+ # its argument more than once.
+ runtime("sv = POPs;");
+ return "SvTRUE(sv)";
+ }
+}
+
+sub write_back_lexicals {
+ my $avoid = shift || 0;
+ debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
+ if $debug_shadow;
+ my $lex;
+ foreach $lex (@pad) {
+ next unless ref($lex);
+ $lex->write_back unless $lex->{flags} & $avoid;
+ }
+}
+
+sub write_back_stack {
+ my $obj;
+ return unless @stack;
+ runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
+ foreach $obj (@stack) {
+ runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
+ }
+ @stack = ();
+}
+
+sub invalidate_lexicals {
+ my $avoid = shift || 0;
+ debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
+ if $debug_shadow;
+ my $lex;
+ foreach $lex (@pad) {
+ next unless ref($lex);
+ $lex->invalidate unless $lex->{flags} & $avoid;
+ }
+}
+
+sub reload_lexicals {
+ my $lex;
+ foreach $lex (@pad) {
+ next unless ref($lex);
+ my $type = $lex->{type};
+ if ($type == T_INT) {
+ $lex->as_int;
+ } elsif ($type == T_DOUBLE) {
+ $lex->as_double;
+ } else {
+ $lex->as_sv;
+ }
+ }
+}
+
+{
+ package B::Pseudoreg;
+ #
+ # This class allocates pseudo-registers (OK, so they're C variables).
+ #
+ my %alloc; # Keyed by variable name. A value of 1 means the
+ # variable has been declared. A value of 2 means
+ # it's in use.
+
+ sub new_scope { %alloc = () }
+
+ sub new ($$$) {
+ my ($class, $type, $prefix) = @_;
+ my ($ptr, $i, $varname, $status, $obj);
+ $prefix =~ s/^(\**)//;
+ $ptr = $1;
+ $i = 0;
+ do {
+ $varname = "$prefix$i";
+ $status = $alloc{$varname};
+ } while $status == 2;
+ if ($status != 1) {
+ # Not declared yet
+ B::CC::declare($type, "$ptr$varname");
+ $alloc{$varname} = 2; # declared and in use
+ }
+ $obj = bless \$varname, $class;
+ return $obj;
+ }
+ sub DESTROY {
+ my $obj = shift;
+ $alloc{$$obj} = 1; # no longer in use but still declared
+ }
+}
+{
+ package B::Shadow;
+ #
+ # This class gives a standard API for a perl object to shadow a
+ # C variable and only generate reloads/write-backs when necessary.
+ #
+ # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
+ # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
+ # Use $obj->invalidate whenever an unknown function may have
+ # set shadow itself.
+
+ sub new {
+ my ($class, $write_back) = @_;
+ # Object fields are perl shadow variable, validity flag
+ # (for *C* variable) and callback sub for write_back
+ # (passed perl shadow variable as argument).
+ bless [undef, 1, $write_back], $class;
+ }
+ sub load {
+ my ($obj, $newval) = @_;
+ $obj->[1] = 0; # C variable no longer valid
+ $obj->[0] = $newval;
+ }
+ sub write_back {
+ my $obj = shift;
+ if (!($obj->[1])) {
+ $obj->[1] = 1; # C variable will now be valid
+ &{$obj->[2]}($obj->[0]);
+ }
+ }
+ sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
+}
+my $curcop = new B::Shadow (sub {
+ my $opsym = shift->save;
+ runtime("PL_curcop = (COP*)$opsym;");
+});
+
+#
+# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
+#
+sub dopoptoloop {
+ my $cxix = $#cxstack;
+ while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
+ $cxix--;
+ }
+ debug "dopoptoloop: returning $cxix" if $debug_cxstack;
+ return $cxix;
+}
+
+sub dopoptolabel {
+ my $label = shift;
+ my $cxix = $#cxstack;
+ while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP
+ && $cxstack[$cxix]->{label} ne $label) {
+ $cxix--;
+ }
+ debug "dopoptolabel: returning $cxix" if $debug_cxstack;
+ return $cxix;
+}
+
+sub error {
+ my $format = shift;
+ my $file = $curcop->[0]->filegv->SV->PV;
+ my $line = $curcop->[0]->line;
+ $errors++;
+ if (@_) {
+ warn sprintf("%s:%d: $format\n", $file, $line, @_);
+ } else {
+ warn sprintf("%s:%d: %s\n", $file, $line, $format);
+ }
+}
+
+#
+# Load pad takes (the elements of) a PADLIST as arguments and loads
+# up @pad with Stackobj-derived objects which represent those lexicals.
+# If/when perl itself can generate type information (my int $foo) then
+# we'll take advantage of that here. Until then, we'll use various hacks
+# to tell the compiler when we want a lexical to be a particular type
+# or to be a register.
+#
+sub load_pad {
+ my ($namelistav, $valuelistav) = @_;
+ @padlist = @_;
+ my @namelist = $namelistav->ARRAY;
+ my @valuelist = $valuelistav->ARRAY;
+ my $ix;
+ @pad = ();
+ debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
+ # Temporary lexicals don't get named so it's possible for @valuelist
+ # to be strictly longer than @namelist. We count $ix up to the end of
+ # @valuelist but index into @namelist for the name. Any temporaries which
+ # run off the end of @namelist will make $namesv undefined and we treat
+ # that the same as having an explicit SPECIAL sv_undef object in @namelist.
+ # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
+ for ($ix = 1; $ix < @valuelist; $ix++) {
+ my $namesv = $namelist[$ix];
+ my $type = T_UNKNOWN;
+ my $flags = 0;
+ my $name = "tmp$ix";
+ my $class = class($namesv);
+ if (!defined($namesv) || $class eq "SPECIAL") {
+ # temporaries have &PL_sv_undef instead of a PVNV for a name
+ $flags = VALID_SV|TEMPORARY|REGISTER;
+ } else {
+ if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
+ $name = $1;
+ if ($2 eq "i") {
+ $type = T_INT;
+ $flags = VALID_SV|VALID_INT;
+ } elsif ($2 eq "d") {
+ $type = T_DOUBLE;
+ $flags = VALID_SV|VALID_DOUBLE;
+ }
+ $flags |= REGISTER if $3;
+ }
+ }
+ $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
+ "i_$name", "d_$name");
+ declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
+ declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
+ debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
+ }
+}
+
+#
+# Debugging stuff
+#
+sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
+
+#
+# OP stuff
+#
+
+sub label {
+ my $op = shift;
+ # XXX Preserve original label name for "real" labels?
+ return sprintf("lab_%x", $$op);
+}
+
+sub write_label {
+ my $op = shift;
+ push_runtime(sprintf(" %s:", label($op)));
+}
+
+sub loadop {
+ my $op = shift;
+ my $opsym = $op->save;
+ runtime("PL_op = $opsym;") unless $know_op;
+ return $opsym;
+}
+
+sub doop {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ my $sym = loadop($op);
+ runtime("DOOP($ppname);");
+ $know_op = 1;
+ return $sym;
+}
+
+sub gimme {
+ my $op = shift;
+ my $flags = $op->flags;
+ return (($flags & OPf_KNOW) ? ($flags & OPf_LIST) : "dowantarray()");
+}
+
+#
+# Code generation for PP code
+#
+
+sub pp_null {
+ my $op = shift;
+ return $op->next;
+}
+
+sub pp_stub {
+ my $op = shift;
+ my $gimme = gimme($op);
+ if ($gimme != 1) {
+ # XXX Change to push a constant sv_undef Stackobj onto @stack
+ write_back_stack();
+ runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
+ }
+ return $op->next;
+}
+
+sub pp_unstack {
+ my $op = shift;
+ @stack = ();
+ runtime("PP_UNSTACK;");
+ return $op->next;
+}
+
+sub pp_and {
+ my $op = shift;
+ my $next = $op->next;
+ reload_lexicals();
+ unshift(@bblock_todo, $next);
+ if (@stack >= 1) {
+ my $bool = pop_bool();
+ write_back_stack();
+ runtime(sprintf("if (!$bool) goto %s;", label($next)));
+ } else {
+ runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
+ "*sp--;");
+ }
+ return $op->other;
+}
+
+sub pp_or {
+ my $op = shift;
+ my $next = $op->next;
+ reload_lexicals();
+ unshift(@bblock_todo, $next);
+ if (@stack >= 1) {
+ my $obj = pop @stack;
+ write_back_stack();
+ runtime(sprintf("if (%s) { XPUSHs(%s); goto %s; }",
+ $obj->as_numeric, $obj->as_sv, label($next)));
+ } else {
+ runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
+ "*sp--;");
+ }
+ return $op->other;
+}
+
+sub pp_cond_expr {
+ my $op = shift;
+ my $false = $op->false;
+ unshift(@bblock_todo, $false);
+ reload_lexicals();
+ my $bool = pop_bool();
+ write_back_stack();
+ runtime(sprintf("if (!$bool) goto %s;", label($false)));
+ return $op->true;
+}
+
+sub pp_padsv {
+ my $op = shift;
+ my $ix = $op->targ;
+ push(@stack, $pad[$ix]);
+ if ($op->flags & OPf_MOD) {
+ my $private = $op->private;
+ if ($private & OPpLVAL_INTRO) {
+ runtime("SAVECLEARSV(PL_curpad[$ix]);");
+ } elsif ($private & OPpDEREF) {
+ runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
+ $ix, $private & OPpDEREF));
+ $pad[$ix]->invalidate;
+ }
+ }
+ return $op->next;
+}
+
+sub pp_const {
+ my $op = shift;
+ my $sv = $op->sv;
+ my $obj = $constobj{$$sv};
+ if (!defined($obj)) {
+ $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
+ }
+ push(@stack, $obj);
+ return $op->next;
+}
+
+sub pp_nextstate {
+ my $op = shift;
+ $curcop->load($op);
+ @stack = ();
+ debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
+ runtime("TAINT_NOT;") unless $omit_taint;
+ runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
+ if ($freetmps_each_bblock || $freetmps_each_loop) {
+ $need_freetmps = 1;
+ } else {
+ runtime("FREETMPS;");
+ }
+ return $op->next;
+}
+
+sub pp_dbstate {
+ my $op = shift;
+ $curcop->invalidate; # XXX?
+ return default_pp($op);
+}
+
+sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
+sub pp_bless { $curcop->write_back; default_pp(@_) }
+sub pp_repeat { $curcop->write_back; default_pp(@_) }
+# The following subs need $curcop->write_back if we decide to support arybase:
+# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
+sub pp_sort { $curcop->write_back; default_pp(@_) }
+sub pp_caller { $curcop->write_back; default_pp(@_) }
+sub pp_reset { $curcop->write_back; default_pp(@_) }
+
+sub pp_gv {
+ my $op = shift;
+ my $gvsym = $op->gv->save;
+ write_back_stack();
+ runtime("XPUSHs((SV*)$gvsym);");
+ return $op->next;
+}
+
+sub pp_gvsv {
+ my $op = shift;
+ my $gvsym = $op->gv->save;
+ write_back_stack();
+ if ($op->private & OPpLVAL_INTRO) {
+ runtime("XPUSHs(save_scalar($gvsym));");
+ } else {
+ runtime("XPUSHs(GvSV($gvsym));");
+ }
+ return $op->next;
+}
+
+sub pp_aelemfast {
+ my $op = shift;
+ my $gvsym = $op->gv->save;
+ my $ix = $op->private;
+ my $flag = $op->flags & OPf_MOD;
+ write_back_stack();
+ runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
+ "PUSHs(svp ? *svp : &PL_sv_undef);");
+ return $op->next;
+}
+
+sub int_binop {
+ my ($op, $operator) = @_;
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_int();
+ if (@stack >= 1) {
+ my $left = top_int();
+ $stack[-1]->set_int(&$operator($left, $right));
+ } else {
+ runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ my $right = new B::Pseudoreg ("IV", "riv");
+ my $left = new B::Pseudoreg ("IV", "liv");
+ runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
+ $targ->set_int(&$operator($$left, $$right));
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
+sub INTS_CLOSED () { 0x1 }
+sub INT_RESULT () { 0x2 }
+sub NUMERIC_RESULT () { 0x4 }
+
+sub numeric_binop {
+ my ($op, $operator, $flags) = @_;
+ my $force_int = 0;
+ $force_int ||= ($flags & INT_RESULT);
+ $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
+ && valid_int($stack[-2]) && valid_int($stack[-1]));
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_numeric();
+ if (@stack >= 1) {
+ my $left = top_numeric();
+ if ($force_int) {
+ $stack[-1]->set_int(&$operator($left, $right));
+ } else {
+ $stack[-1]->set_numeric(&$operator($left, $right));
+ }
+ } else {
+ if ($force_int) {
+ runtime(sprintf("sv_setiv(TOPs, %s);",
+ &$operator("TOPi", $right)));
+ } else {
+ runtime(sprintf("sv_setnv(TOPs, %s);",
+ &$operator("TOPn", $right)));
+ }
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ $force_int ||= ($targ->{type} == T_INT);
+ if ($force_int) {
+ my $right = new B::Pseudoreg ("IV", "riv");
+ my $left = new B::Pseudoreg ("IV", "liv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric));
+ $targ->set_int(&$operator($$left, $$right));
+ } else {
+ my $right = new B::Pseudoreg ("double", "rnv");
+ my $left = new B::Pseudoreg ("double", "lnv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric));
+ $targ->set_numeric(&$operator($$left, $$right));
+ }
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
+sub sv_binop {
+ my ($op, $operator, $flags) = @_;
+ if ($op->flags & OPf_STACKED) {
+ my $right = pop_sv();
+ if (@stack >= 1) {
+ my $left = top_sv();
+ if ($flags & INT_RESULT) {
+ $stack[-1]->set_int(&$operator($left, $right));
+ } elsif ($flags & NUMERIC_RESULT) {
+ $stack[-1]->set_numeric(&$operator($left, $right));
+ } else {
+ # XXX Does this work?
+ runtime(sprintf("sv_setsv($left, %s);",
+ &$operator($left, $right)));
+ $stack[-1]->invalidate;
+ }
+ } else {
+ my $f;
+ if ($flags & INT_RESULT) {
+ $f = "sv_setiv";
+ } elsif ($flags & NUMERIC_RESULT) {
+ $f = "sv_setnv";
+ } else {
+ $f = "sv_setsv";
+ }
+ runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
+ }
+ } else {
+ my $targ = $pad[$op->targ];
+ runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
+ if ($flags & INT_RESULT) {
+ $targ->set_int(&$operator("left", "right"));
+ } elsif ($flags & NUMERIC_RESULT) {
+ $targ->set_numeric(&$operator("left", "right"));
+ } else {
+ # XXX Does this work?
+ runtime(sprintf("sv_setsv(%s, %s);",
+ $targ->as_sv, &$operator("left", "right")));
+ $targ->invalidate;
+ }
+ push(@stack, $targ);
+ }
+ return $op->next;
+}
+
+sub bool_int_binop {
+ my ($op, $operator) = @_;
+ my $right = new B::Pseudoreg ("IV", "riv");
+ my $left = new B::Pseudoreg ("IV", "liv");
+ runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
+ my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+ $bool->set_int(&$operator($$left, $$right));
+ push(@stack, $bool);
+ return $op->next;
+}
+
+sub bool_numeric_binop {
+ my ($op, $operator) = @_;
+ my $right = new B::Pseudoreg ("double", "rnv");
+ my $left = new B::Pseudoreg ("double", "lnv");
+ runtime(sprintf("$$right = %s; $$left = %s;",
+ pop_numeric(), pop_numeric()));
+ my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+ $bool->set_numeric(&$operator($$left, $$right));
+ push(@stack, $bool);
+ return $op->next;
+}
+
+sub bool_sv_binop {
+ my ($op, $operator) = @_;
+ runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
+ my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
+ $bool->set_numeric(&$operator("left", "right"));
+ push(@stack, $bool);
+ return $op->next;
+}
+
+sub infix_op {
+ my $opname = shift;
+ return sub { "$_[0] $opname $_[1]" }
+}
+
+sub prefix_op {
+ my $opname = shift;
+ return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
+}
+
+BEGIN {
+ my $plus_op = infix_op("+");
+ my $minus_op = infix_op("-");
+ my $multiply_op = infix_op("*");
+ my $divide_op = infix_op("/");
+ my $modulo_op = infix_op("%");
+ my $lshift_op = infix_op("<<");
+ my $rshift_op = infix_op(">>");
+ my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
+ my $scmp_op = prefix_op("sv_cmp");
+ my $seq_op = prefix_op("sv_eq");
+ my $sne_op = prefix_op("!sv_eq");
+ my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
+ my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
+ my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
+ my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
+ my $eq_op = infix_op("==");
+ my $ne_op = infix_op("!=");
+ my $lt_op = infix_op("<");
+ my $gt_op = infix_op(">");
+ my $le_op = infix_op("<=");
+ my $ge_op = infix_op(">=");
+
+ #
+ # XXX The standard perl PP code has extra handling for
+ # some special case arguments of these operators.
+ #
+ sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
+ sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
+ sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
+ sub pp_divide { numeric_binop($_[0], $divide_op) }
+ sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
+ sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
+
+ sub pp_left_shift { int_binop($_[0], $lshift_op) }
+ sub pp_right_shift { int_binop($_[0], $rshift_op) }
+ sub pp_i_add { int_binop($_[0], $plus_op) }
+ sub pp_i_subtract { int_binop($_[0], $minus_op) }
+ sub pp_i_multiply { int_binop($_[0], $multiply_op) }
+ sub pp_i_divide { int_binop($_[0], $divide_op) }
+ sub pp_i_modulo { int_binop($_[0], $modulo_op) }
+
+ sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
+ sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
+ sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
+ sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
+ sub pp_le { bool_numeric_binop($_[0], $le_op) }
+ sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
+
+ sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
+ sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
+ sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
+ sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
+ sub pp_i_le { bool_int_binop($_[0], $le_op) }
+ sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
+
+ sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
+ sub pp_slt { bool_sv_binop($_[0], $slt_op) }
+ sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
+ sub pp_sle { bool_sv_binop($_[0], $sle_op) }
+ sub pp_sge { bool_sv_binop($_[0], $sge_op) }
+ sub pp_seq { bool_sv_binop($_[0], $seq_op) }
+ sub pp_sne { bool_sv_binop($_[0], $sne_op) }
+}
+
+
+sub pp_sassign {
+ my $op = shift;
+ my $backwards = $op->private & OPpASSIGN_BACKWARDS;
+ my ($dst, $src);
+ if (@stack >= 2) {
+ $dst = pop @stack;
+ $src = pop @stack;
+ ($src, $dst) = ($dst, $src) if $backwards;
+ my $type = $src->{type};
+ if ($type == T_INT) {
+ $dst->set_int($src->as_int);
+ } elsif ($type == T_DOUBLE) {
+ $dst->set_numeric($src->as_numeric);
+ } else {
+ $dst->set_sv($src->as_sv);
+ }
+ push(@stack, $dst);
+ } elsif (@stack == 1) {
+ if ($backwards) {
+ my $src = pop @stack;
+ my $type = $src->{type};
+ runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
+ if ($type == T_INT) {
+ runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
+ } elsif ($type == T_DOUBLE) {
+ runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
+ } else {
+ runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
+ }
+ runtime("SvSETMAGIC(TOPs);");
+ } else {
+ my $dst = pop @stack;
+ my $type = $dst->{type};
+ runtime("sv = POPs;");
+ runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
+ if ($type == T_INT) {
+ $dst->set_int("SvIV(sv)");
+ } elsif ($type == T_DOUBLE) {
+ $dst->set_double("SvNV(sv)");
+ } else {
+ runtime("SvSetSV($dst->{sv}, sv);");
+ $dst->invalidate;
+ }
+ }
+ } else {
+ if ($backwards) {
+ runtime("src = POPs; dst = TOPs;");
+ } else {
+ runtime("dst = POPs; src = TOPs;");
+ }
+ runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
+ "SvSetSV(dst, src);",
+ "SvSETMAGIC(dst);",
+ "SETs(dst);");
+ }
+ return $op->next;
+}
+
+sub pp_preinc {
+ my $op = shift;
+ if (@stack >= 1) {
+ my $obj = $stack[-1];
+ my $type = $obj->{type};
+ if ($type == T_INT || $type == T_DOUBLE) {
+ $obj->set_int($obj->as_int . " + 1");
+ } else {
+ runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
+ $obj->invalidate();
+ }
+ } else {
+ runtime sprintf("PP_PREINC(TOPs);");
+ }
+ return $op->next;
+}
+
+sub pp_pushmark {
+ my $op = shift;
+ write_back_stack();
+ runtime("PUSHMARK(sp);");
+ return $op->next;
+}
+
+sub pp_list {
+ my $op = shift;
+ write_back_stack();
+ my $gimme = gimme($op);
+ if ($gimme == 1) { # sic
+ runtime("POPMARK;"); # need this even though not a "full" pp_list
+ } else {
+ runtime("PP_LIST($gimme);");
+ }
+ return $op->next;
+}
+
+sub pp_entersub {
+ my $op = shift;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = doop($op);
+ runtime("if (PL_op != ($sym)->op_next) PL_op = (*PL_op->op_ppaddr)(ARGS);");
+ runtime("SPAGAIN;");
+ $know_op = 0;
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+sub pp_enterwrite {
+ my $op = shift;
+ pp_entersub($op);
+}
+
+sub pp_leavewrite {
+ my $op = shift;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = doop($op);
+ # XXX Is this the right way to distinguish between it returning
+ # CvSTART(cv) (via doform) and pop_return()?
+ runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
+ runtime("SPAGAIN;");
+ $know_op = 0;
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+sub doeval {
+ my $op = shift;
+ $curcop->write_back;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = loadop($op);
+ my $ppaddr = $op->ppaddr;
+ runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
+ $know_op = 1;
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+sub pp_entereval { doeval(@_) }
+sub pp_require { doeval(@_) }
+sub pp_dofile { doeval(@_) }
+
+sub pp_entertry {
+ my $op = shift;
+ $curcop->write_back;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ my $sym = doop($op);
+ my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
+ declare("Sigjmp_buf", $jmpbuf);
+ runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
+ invalidate_lexicals(REGISTER|TEMPORARY);
+ return $op->next;
+}
+
+sub pp_grepstart {
+ my $op = shift;
+ if ($need_freetmps && $freetmps_each_loop) {
+ runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
+ $need_freetmps = 0;
+ }
+ write_back_stack();
+ doop($op);
+ return $op->next->other;
+}
+
+sub pp_mapstart {
+ my $op = shift;
+ if ($need_freetmps && $freetmps_each_loop) {
+ runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
+ $need_freetmps = 0;
+ }
+ write_back_stack();
+ doop($op);
+ return $op->next->other;
+}
+
+sub pp_grepwhile {
+ my $op = shift;
+ my $next = $op->next;
+ unshift(@bblock_todo, $next);
+ write_back_lexicals();
+ write_back_stack();
+ my $sym = doop($op);
+ # pp_grepwhile can return either op_next or op_other and we need to
+ # be able to distinguish the two at runtime. Since it's possible for
+ # both ops to be "inlined", the fields could both be zero. To get
+ # around that, we hack op_next to be our own op (purely because we
+ # know it's a non-NULL pointer and can't be the same as op_other).
+ $init->add("((LOGOP*)$sym)->op_next = $sym;");
+ runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
+ $know_op = 0;
+ return $op->other;
+}
+
+sub pp_mapwhile {
+ pp_grepwhile(@_);
+}
+
+sub pp_return {
+ my $op = shift;
+ write_back_lexicals(REGISTER|TEMPORARY);
+ write_back_stack();
+ doop($op);
+ runtime("PUTBACK;", "return 0;");
+ $know_op = 0;
+ return $op->next;
+}
+
+sub nyi {
+ my $op = shift;
+ warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
+ return default_pp($op);
+}
+
+sub pp_range {
+ my $op = shift;
+ my $flags = $op->flags;
+ if (!($flags & OPf_KNOW)) {
+ error("context of range unknown at compile-time");
+ }
+ write_back_lexicals();
+ write_back_stack();
+ if (!($flags & OPf_LIST)) {
+ # We need to save our UNOP structure since pp_flop uses
+ # it to find and adjust out targ. We don't need it ourselves.
+ $op->save;
+ runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
+ $op->targ, label($op->false));
+ unshift(@bblock_todo, $op->false);
+ }
+ return $op->true;
+}
+
+sub pp_flip {
+ my $op = shift;
+ my $flags = $op->flags;
+ if (!($flags & OPf_KNOW)) {
+ error("context of flip unknown at compile-time");
+ }
+ if ($flags & OPf_LIST) {
+ return $op->first->false;
+ }
+ write_back_lexicals();
+ write_back_stack();
+ # We need to save our UNOP structure since pp_flop uses
+ # it to find and adjust out targ. We don't need it ourselves.
+ $op->save;
+ my $ix = $op->targ;
+ my $rangeix = $op->first->targ;
+ runtime(($op->private & OPpFLIP_LINENUM) ?
+ "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
+ : "if (SvTRUE(TOPs)) {");
+ runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
+ if ($op->flags & OPf_SPECIAL) {
+ runtime("sv_setiv(PL_curpad[$ix], 1);");
+ } else {
+ runtime("\tsv_setiv(PL_curpad[$ix], 0);",
+ "\tsp--;",
+ sprintf("\tgoto %s;", label($op->first->false)));
+ }
+ runtime("}",
+ qq{sv_setpv(PL_curpad[$ix], "");},
+ "SETs(PL_curpad[$ix]);");
+ $know_op = 0;
+ return $op->next;
+}
+
+sub pp_flop {
+ my $op = shift;
+ default_pp($op);
+ $know_op = 0;
+ return $op->next;
+}
+
+sub enterloop {
+ my $op = shift;
+ my $nextop = $op->nextop;
+ my $lastop = $op->lastop;
+ my $redoop = $op->redoop;
+ $curcop->write_back;
+ debug "enterloop: pushing on cxstack" if $debug_cxstack;
+ push(@cxstack, {
+ type => CXt_LOOP,
+ op => $op,
+ "label" => $curcop->[0]->label,
+ nextop => $nextop,
+ lastop => $lastop,
+ redoop => $redoop
+ });
+ $nextop->save;
+ $lastop->save;
+ $redoop->save;
+ return default_pp($op);
+}
+
+sub pp_enterloop { enterloop(@_) }
+sub pp_enteriter { enterloop(@_) }
+
+sub pp_leaveloop {
+ my $op = shift;
+ if (!@cxstack) {
+ die "panic: leaveloop";
+ }
+ debug "leaveloop: popping from cxstack" if $debug_cxstack;
+ pop(@cxstack);
+ return default_pp($op);
+}
+
+sub pp_next {
+ my $op = shift;
+ my $cxix;
+ if ($op->flags & OPf_SPECIAL) {
+ $cxix = dopoptoloop();
+ if ($cxix < 0) {
+ error('"next" used outside loop');
+ return $op->next; # ignore the op
+ }
+ } else {
+ $cxix = dopoptolabel($op->pv);
+ if ($cxix < 0) {
+ error('Label not found at compile time for "next %s"', $op->pv);
+ return $op->next; # ignore the op
+ }
+ }
+ default_pp($op);
+ my $nextop = $cxstack[$cxix]->{nextop};
+ push(@bblock_todo, $nextop);
+ runtime(sprintf("goto %s;", label($nextop)));
+ return $op->next;
+}
+
+sub pp_redo {
+ my $op = shift;
+ my $cxix;
+ if ($op->flags & OPf_SPECIAL) {
+ $cxix = dopoptoloop();
+ if ($cxix < 0) {
+ error('"redo" used outside loop');
+ return $op->next; # ignore the op
+ }
+ } else {
+ $cxix = dopoptolabel($op->pv);
+ if ($cxix < 0) {
+ error('Label not found at compile time for "redo %s"', $op->pv);
+ return $op->next; # ignore the op
+ }
+ }
+ default_pp($op);
+ my $redoop = $cxstack[$cxix]->{redoop};
+ push(@bblock_todo, $redoop);
+ runtime(sprintf("goto %s;", label($redoop)));
+ return $op->next;
+}
+
+sub pp_last {
+ my $op = shift;
+ my $cxix;
+ if ($op->flags & OPf_SPECIAL) {
+ $cxix = dopoptoloop();
+ if ($cxix < 0) {
+ error('"last" used outside loop');
+ return $op->next; # ignore the op
+ }
+ } else {
+ $cxix = dopoptolabel($op->pv);
+ if ($cxix < 0) {
+ error('Label not found at compile time for "last %s"', $op->pv);
+ return $op->next; # ignore the op
+ }
+ # XXX Add support for "last" to leave non-loop blocks
+ if ($cxstack[$cxix]->{type} != CXt_LOOP) {
+ error('Use of "last" for non-loop blocks is not yet implemented');
+ return $op->next; # ignore the op
+ }
+ }
+ default_pp($op);
+ my $lastop = $cxstack[$cxix]->{lastop}->next;
+ push(@bblock_todo, $lastop);
+ runtime(sprintf("goto %s;", label($lastop)));
+ return $op->next;
+}
+
+sub pp_subst {
+ my $op = shift;
+ write_back_lexicals();
+ write_back_stack();
+ my $sym = doop($op);
+ my $replroot = $op->pmreplroot;
+ if ($$replroot) {
+ runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
+ $sym, label($replroot));
+ $op->pmreplstart->save;
+ push(@bblock_todo, $replroot);
+ }
+ invalidate_lexicals();
+ return $op->next;
+}
+
+sub pp_substcont {
+ my $op = shift;
+ write_back_lexicals();
+ write_back_stack();
+ doop($op);
+ my $pmop = $op->other;
+ warn sprintf("substcont: op = %s, pmop = %s\n",
+ peekop($op), peekop($pmop));#debug
+# my $pmopsym = objsym($pmop);
+ my $pmopsym = $pmop->save; # XXX can this recurse?
+ warn "pmopsym = $pmopsym\n";#debug
+ runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
+ $pmopsym, label($pmop->pmreplstart));
+ invalidate_lexicals();
+ return $pmop->next;
+}
+
+sub default_pp {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ write_back_lexicals() unless $skip_lexicals{$ppname};
+ write_back_stack() unless $skip_stack{$ppname};
+ doop($op);
+ # XXX If the only way that ops can write to a TEMPORARY lexical is
+ # when it's named in $op->targ then we could call
+ # invalidate_lexicals(TEMPORARY) and avoid having to write back all
+ # the temporaries. For now, we'll play it safe and write back the lot.
+ invalidate_lexicals() unless $skip_invalidate{$ppname};
+ return $op->next;
+}
+
+sub compile_op {
+ my $op = shift;
+ my $ppname = $op->ppaddr;
+ if (exists $ignore_op{$ppname}) {
+ return $op->next;
+ }
+ debug peek_stack() if $debug_stack;
+ if ($debug_op) {
+ debug sprintf("%s [%s]\n",
+ peekop($op),
+ $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
+ }
+ no strict 'refs';
+ if (defined(&$ppname)) {
+ $know_op = 0;
+ return &$ppname($op);
+ } else {
+ return default_pp($op);
+ }
+}
+
+sub compile_bblock {
+ my $op = shift;
+ #warn "compile_bblock: ", peekop($op), "\n"; # debug
+ write_label($op);
+ $know_op = 0;
+ do {
+ $op = compile_op($op);
+ } while (defined($op) && $$op && !exists($leaders->{$$op}));
+ write_back_stack(); # boo hoo: big loss
+ reload_lexicals();
+ return $op;
+}
+
+sub cc {
+ my ($name, $root, $start, @padlist) = @_;
+ my $op;
+ init_pp($name);
+ load_pad(@padlist);
+ B::Pseudoreg->new_scope;
+ @cxstack = ();
+ if ($debug_timings) {
+ warn sprintf("Basic block analysis at %s\n", timing_info);
+ }
+ $leaders = find_leaders($root, $start);
+ @bblock_todo = ($start, values %$leaders);
+ if ($debug_timings) {
+ warn sprintf("Compilation at %s\n", timing_info);
+ }
+ while (@bblock_todo) {
+ $op = shift @bblock_todo;
+ #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
+ next if !defined($op) || !$$op || $done{$$op};
+ #warn "...compiling it\n"; # debug
+ do {
+ $done{$$op} = 1;
+ $op = compile_bblock($op);
+ if ($need_freetmps && $freetmps_each_bblock) {
+ runtime("FREETMPS;");
+ $need_freetmps = 0;
+ }
+ } while defined($op) && $$op && !$done{$$op};
+ if ($need_freetmps && $freetmps_each_loop) {
+ runtime("FREETMPS;");
+ $need_freetmps = 0;
+ }
+ if (!$$op) {
+ runtime("PUTBACK;", "return 0;");
+ } elsif ($done{$$op}) {
+ runtime(sprintf("goto %s;", label($op)));
+ }
+ }
+ if ($debug_timings) {
+ warn sprintf("Saving runtime at %s\n", timing_info);
+ }
+ save_runtime();
+}
+
+sub cc_recurse {
+ my $ccinfo;
+ my $start;
+ $start = cc_queue(@_) if @_;
+ while ($ccinfo = shift @cc_todo) {
+ cc(@$ccinfo);
+ }
+ return $start;
+}
+
+sub cc_obj {
+ my ($name, $cvref) = @_;
+ my $cv = svref_2object($cvref);
+ my @padlist = $cv->PADLIST->ARRAY;
+ my $curpad_sym = $padlist[1]->save;
+ cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
+}
+
+sub cc_main {
+ my @comppadlist = comppadlist->ARRAY;
+ my $curpad_sym = $comppadlist[1]->save;
+ my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
+ save_unused_subs(@unused_sub_packages);
+ cc_recurse();
+
+ return if $errors;
+ if (!defined($module)) {
+ $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
+ "PL_main_start = $start;",
+ "PL_curpad = AvARRAY($curpad_sym);");
+ }
+ output_boilerplate();
+ print "\n";
+ output_all("perl_init");
+ output_runtime();
+ print "\n";
+ output_main();
+ if (defined($module)) {
+ my $cmodule = $module;
+ $cmodule =~ s/::/__/g;
+ print <<"EOT";
+
+#include "XSUB.h"
+XS(boot_$cmodule)
+{
+ dXSARGS;
+ perl_init();
+ ENTER;
+ SAVETMPS;
+ SAVESPTR(PL_curpad);
+ SAVESPTR(PL_op);
+ PL_curpad = AvARRAY($curpad_sym);
+ PL_op = $start;
+ pp_main(ARGS);
+ FREETMPS;
+ LEAVE;
+ ST(0) = &PL_sv_yes;
+ XSRETURN(1);
+}
+EOT
+ }
+ if ($debug_timings) {
+ warn sprintf("Done at %s\n", timing_info);
+ }
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
+ } elsif ($opt eq "n") {
+ $arg ||= shift @options;
+ $module_name = $arg;
+ } elsif ($opt eq "u") {
+ $arg ||= shift @options;
+ push(@unused_sub_packages, $arg);
+ } elsif ($opt eq "f") {
+ $arg ||= shift @options;
+ my $value = $arg !~ s/^no-//;
+ $arg =~ s/-/_/g;
+ my $ref = $optimise{$arg};
+ if (defined($ref)) {
+ $$ref = $value;
+ } else {
+ warn qq(ignoring unknown optimisation option "$arg"\n);
+ }
+ } elsif ($opt eq "O") {
+ $arg = 1 if $arg eq "";
+ my $ref;
+ foreach $ref (values %optimise) {
+ $$ref = 0;
+ }
+ if ($arg >= 2) {
+ $freetmps_each_loop = 1;
+ }
+ if ($arg >= 1) {
+ $freetmps_each_bblock = 1 unless $freetmps_each_loop;
+ }
+ } elsif ($opt eq "m") {
+ $arg ||= shift @options;
+ $module = $arg;
+ push(@unused_sub_packages, $arg);
+ } elsif ($opt eq "p") {
+ $arg ||= shift @options;
+ $patchlevel = $arg;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "O") {
+ $debug_op = 1;
+ } elsif ($arg eq "s") {
+ $debug_stack = 1;
+ } elsif ($arg eq "c") {
+ $debug_cxstack = 1;
+ } elsif ($arg eq "p") {
+ $debug_pad = 1;
+ } elsif ($arg eq "r") {
+ $debug_runtime = 1;
+ } elsif ($arg eq "S") {
+ $debug_shadow = 1;
+ } elsif ($arg eq "q") {
+ $debug_queue = 1;
+ } elsif ($arg eq "l") {
+ $debug_lineno = 1;
+ } elsif ($arg eq "t") {
+ $debug_timings = 1;
+ }
+ }
+ }
+ }
+ init_sections();
+ $init = B::Section->get("init");
+ $decl = B::Section->get("decl");
+
+ if (@options) {
+ return sub {
+ my ($objname, $ppname);
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ ($ppname = $objname) =~ s/^.*?:://;
+ eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
+ die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
+ return if $errors;
+ }
+ output_boilerplate();
+ print "\n";
+ output_all($module_name || "init_module");
+ output_runtime();
+ }
+ } else {
+ return sub { cc_main() };
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::CC - Perl compiler's optimized C translation backend
+
+=head1 SYNOPSIS
+
+ perl -MO=CC[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This compiler backend takes Perl source and generates C source code
+corresponding to the flow of your program. In other words, this
+backend is somewhat a "real" compiler in the sense that many people
+think about compilers. Note however that, currently, it is a very
+poor compiler in that although it generates (mostly, or at least
+sometimes) correct code, it performs relatively few optimisations.
+This will change as the compiler develops. The result is that
+running an executable compiled with this backend may start up more
+quickly than running the original Perl program (a feature shared
+by the B<C> compiler backend--see F<B::C>) and may also execute
+slightly faster. This is by no means a good optimising compiler--yet.
+
+=head1 OPTIONS
+
+If there are any non-option arguments, they are taken to be
+names of objects to be saved (probably doesn't work properly yet).
+Without extra arguments, it saves the main program.
+
+=over 4
+
+=item B<-ofilename>
+
+Output to filename instead of STDOUT
+
+=item B<-v>
+
+Verbose compilation (currently gives a few compilation statistics).
+
+=item B<-->
+
+Force end of options
+
+=item B<-uPackname>
+
+Force apparently unused subs from package Packname to be compiled.
+This allows programs to use eval "foo()" even when sub foo is never
+seen to be used at compile time. The down side is that any subs which
+really are never used also have code generated. This option is
+necessary, for example, if you have a signal handler foo which you
+initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
+to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
+options. The compiler tries to figure out which packages may possibly
+have subs in which need compiling but the current version doesn't do
+it very well. In particular, it is confused by nested packages (i.e.
+of the form C<A::B>) where package C<A> does not contain any subs.
+
+=item B<-mModulename>
+
+Instead of generating source for a runnable executable, generate
+source for an XSUB module. The boot_Modulename function (which
+DynaLoader can look for) does the appropriate initialisation and runs
+the main part of the Perl source that is being compiled.
+
+
+=item B<-D>
+
+Debug options (concatenated or separate flags like C<perl -D>).
+
+=item B<-Dr>
+
+Writes debugging output to STDERR just as it's about to write to the
+program's runtime (otherwise writes debugging info as comments in
+its C output).
+
+=item B<-DO>
+
+Outputs each OP as it's compiled
+
+=item B<-Ds>
+
+Outputs the contents of the shadow stack at each OP
+
+=item B<-Dp>
+
+Outputs the contents of the shadow pad of lexicals as it's loaded for
+each sub or the main program.
+
+=item B<-Dq>
+
+Outputs the name of each fake PP function in the queue as it's about
+to process it.
+
+=item B<-Dl>
+
+Output the filename and line number of each original line of Perl
+code as it's processed (C<pp_nextstate>).
+
+=item B<-Dt>
+
+Outputs timing information of compilation stages.
+
+=item B<-f>
+
+Force optimisations on or off one at a time.
+
+=item B<-ffreetmps-each-bblock>
+
+Delays FREETMPS from the end of each statement to the end of the each
+basic block.
+
+=item B<-ffreetmps-each-loop>
+
+Delays FREETMPS from the end of each statement to the end of the group
+of basic blocks forming a loop. At most one of the freetmps-each-*
+options can be used.
+
+=item B<-fomit-taint>
+
+Omits generating code for handling perl's tainting mechanism.
+
+=item B<-On>
+
+Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
+Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
+sets B<-ffreetmps-each-loop>.
+
+=back
+
+=head1 EXAMPLES
+
+ perl -MO=CC,-O2,-ofoo.c foo.pl
+ perl cc_harness -o foo foo.c
+
+Note that C<cc_harness> lives in the C<B> subdirectory of your perl
+library directory. The utility called C<perlcc> may also be used to
+help make use of this compiler.
+
+ perl -MO=CC,-mFoo,-oFoo.c Foo.pm
+ perl cc_harness -shared -c -o Foo.so Foo.c
+
+=head1 BUGS
+
+Plenty. Current status: experimental.
+
+=head1 DIFFERENCES
+
+These aren't really bugs but they are constructs which are heavily
+tied to perl's compile-and-go implementation and with which this
+compiler backend cannot cope.
+
+=head2 Loops
+
+Standard perl calculates the target of "next", "last", and "redo"
+at run-time. The compiler calculates the targets at compile-time.
+For example, the program
+
+ sub skip_on_odd { next NUMBER if $_[0] % 2 }
+ NUMBER: for ($i = 0; $i < 5; $i++) {
+ skip_on_odd($i);
+ print $i;
+ }
+
+produces the output
+
+ 024
+
+with standard perl but gives a compile-time error with the compiler.
+
+=head2 Context of ".."
+
+The context (scalar or array) of the ".." operator determines whether
+it behaves as a range or a flip/flop. Standard perl delays until
+runtime the decision of which context it is in but the compiler needs
+to know the context at compile-time. For example,
+
+ @a = (4,6,1,0,0,1);
+ sub range { (shift @a)..(shift @a) }
+ print range();
+ while (@a) { print scalar(range()) }
+
+generates the output
+
+ 456123E0
+
+with standard Perl but gives a compile-time error with compiled Perl.
+
+=head2 Arithmetic
+
+Compiled Perl programs use native C arithemtic much more frequently
+than standard perl. Operations on large numbers or on boundary
+cases may produce different behaviour.
+
+=head2 Deprecated features
+
+Features of standard perl such as C<$[> which have been deprecated
+in standard perl since Perl5 was released have not been implemented
+in the compiler.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/Debug.pm b/contrib/perl5/ext/B/B/Debug.pm
new file mode 100644
index 000000000000..7754a5a8079e
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Debug.pm
@@ -0,0 +1,283 @@
+package B::Debug;
+use strict;
+use B qw(peekop class walkoptree walkoptree_exec
+ main_start main_root cstring sv_undef);
+use B::Asmdata qw(@specialsv_name);
+
+my %done_gv;
+
+sub B::OP::debug {
+ my ($op) = @_;
+ printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private;
+%s (0x%lx)
+ op_next 0x%x
+ op_sibling 0x%x
+ op_ppaddr %s
+ op_targ %d
+ op_type %d
+ op_seq %d
+ op_flags %d
+ op_private %d
+EOT
+}
+
+sub B::UNOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_first\t0x%x\n", ${$op->first};
+}
+
+sub B::BINOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_last\t\t0x%x\n", ${$op->last};
+}
+
+sub B::LOGOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_other\t0x%x\n", ${$op->other};
+}
+
+sub B::CONDOP::debug {
+ my ($op) = @_;
+ $op->B::UNOP::debug();
+ printf "\top_true\t0x%x\n", ${$op->true};
+ printf "\top_false\t0x%x\n", ${$op->false};
+}
+
+sub B::LISTOP::debug {
+ my ($op) = @_;
+ $op->B::BINOP::debug();
+ printf "\top_children\t%d\n", $op->children;
+}
+
+sub B::PMOP::debug {
+ my ($op) = @_;
+ $op->B::LISTOP::debug();
+ printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
+ printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
+ printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
+ printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
+ printf "\top_pmflags\t0x%x\n", $op->pmflags;
+ $op->pmshort->debug;
+ $op->pmreplroot->debug;
+}
+
+sub B::COP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ my ($filegv) = $op->filegv;
+ printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line;
+ cop_label %s
+ cop_stash 0x%x
+ cop_filegv 0x%x
+ cop_seq %d
+ cop_arybase %d
+ cop_line %d
+EOT
+ $filegv->debug;
+}
+
+sub B::SVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_sv\t\t0x%x\n", ${$op->sv};
+ $op->sv->debug;
+}
+
+sub B::PVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_pv\t\t0x%x\n", $op->pv;
+}
+
+sub B::GVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_gv\t\t0x%x\n", ${$op->gv};
+ $op->gv->debug;
+}
+
+sub B::CVOP::debug {
+ my ($op) = @_;
+ $op->B::OP::debug();
+ printf "\top_cv\t\t0x%x\n", ${$op->cv};
+}
+
+sub B::NULL::debug {
+ my ($sv) = @_;
+ if ($$sv == ${sv_undef()}) {
+ print "&sv_undef\n";
+ } else {
+ printf "NULL (0x%x)\n", $$sv;
+ }
+}
+
+sub B::SV::debug {
+ my ($sv) = @_;
+ if (!$$sv) {
+ print class($sv), " = NULL\n";
+ return;
+ }
+ printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
+%s (0x%x)
+ REFCNT %d
+ FLAGS 0x%x
+EOT
+}
+
+sub B::PV::debug {
+ my ($sv) = @_;
+ $sv->B::SV::debug();
+ my $pv = $sv->PV();
+ printf <<'EOT', cstring($pv), length($pv);
+ xpv_pv %s
+ xpv_cur %d
+EOT
+}
+
+sub B::IV::debug {
+ my ($sv) = @_;
+ $sv->B::SV::debug();
+ printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::NV::debug {
+ my ($sv) = @_;
+ $sv->B::IV::debug();
+ printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVIV::debug {
+ my ($sv) = @_;
+ $sv->B::PV::debug();
+ printf "\txiv_iv\t\t%d\n", $sv->IV;
+}
+
+sub B::PVNV::debug {
+ my ($sv) = @_;
+ $sv->B::PVIV::debug();
+ printf "\txnv_nv\t\t%s\n", $sv->NV;
+}
+
+sub B::PVLV::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
+ printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
+ printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
+}
+
+sub B::BM::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ printf "\txbm_useful\t%d\n", $sv->USEFUL;
+ printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
+ printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
+}
+
+sub B::CV::debug {
+ my ($sv) = @_;
+ $sv->B::PVNV::debug();
+ my ($stash) = $sv->STASH;
+ my ($start) = $sv->START;
+ my ($root) = $sv->ROOT;
+ my ($padlist) = $sv->PADLIST;
+ my ($gv) = $sv->GV;
+ my ($filegv) = $sv->FILEGV;
+ printf <<'EOT', $$stash, $$start, $$root, $$gv, $$filegv, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
+ STASH 0x%x
+ START 0x%x
+ ROOT 0x%x
+ GV 0x%x
+ FILEGV 0x%x
+ DEPTH %d
+ PADLIST 0x%x
+ OUTSIDE 0x%x
+EOT
+ $start->debug if $start;
+ $root->debug if $root;
+ $gv->debug if $gv;
+ $filegv->debug if $filegv;
+ $padlist->debug if $padlist;
+}
+
+sub B::AV::debug {
+ my ($av) = @_;
+ $av->B::SV::debug;
+ my(@array) = $av->ARRAY;
+ print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
+ printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS;
+ FILL %d
+ MAX %d
+ OFF %d
+ AvFLAGS %d
+EOT
+}
+
+sub B::GV::debug {
+ my ($gv) = @_;
+ if ($done_gv{$$gv}++) {
+ printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME;
+ return;
+ }
+ my ($sv) = $gv->SV;
+ my ($av) = $gv->AV;
+ my ($cv) = $gv->CV;
+ $gv->B::SV::debug;
+ printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS;
+ NAME %s
+ STASH %s (0x%x)
+ SV 0x%x
+ GvREFCNT %d
+ FORM 0x%x
+ AV 0x%x
+ HV 0x%x
+ EGV 0x%x
+ CV 0x%x
+ CVGEN %d
+ LINE %d
+ FILEGV 0x%x
+ GvFLAGS 0x%x
+EOT
+ $sv->debug if $sv;
+ $av->debug if $av;
+ $cv->debug if $cv;
+}
+
+sub B::SPECIAL::debug {
+ my $sv = shift;
+ print $specialsv_name[$$sv], "\n";
+}
+
+sub compile {
+ my $order = shift;
+ if ($order eq "exec") {
+ return sub { walkoptree_exec(main_start, "debug") }
+ } else {
+ return sub { walkoptree(main_root, "debug") }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Debug - Walk Perl syntax tree, printing debug info about ops
+
+=head1 SYNOPSIS
+
+ perl -MO=Debug[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+See F<ext/B/README>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/Deparse.pm b/contrib/perl5/ext/B/B/Deparse.pm
new file mode 100644
index 000000000000..5e0bd1d3de7d
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Deparse.pm
@@ -0,0 +1,2670 @@
+# B::Deparse.pm
+# Copyright (c) 1998 Stephen McCamant. All rights reserved.
+# This module is free software; you can redistribute and/or modify
+# it under the same terms as Perl itself.
+
+# This is based on the module of the same name by Malcolm Beattie,
+# but essentially none of his code remains.
+
+package B::Deparse;
+use Carp 'cluck';
+use B qw(class main_root main_start main_cv svref_2object);
+$VERSION = 0.56;
+use strict;
+
+# Changes between 0.50 and 0.51:
+# - fixed nulled leave with live enter in sort { }
+# - fixed reference constants (\"str")
+# - handle empty programs gracefully
+# - handle infinte loops (for (;;) {}, while (1) {})
+# - differentiate between `for my $x ...' and `my $x; for $x ...'
+# - various minor cleanups
+# - moved globals into an object
+# - added `-u', like B::C
+# - package declarations using cop_stash
+# - subs, formats and code sorted by cop_seq
+# Changes between 0.51 and 0.52:
+# - added pp_threadsv (special variables under USE_THREADS)
+# - added documentation
+# Changes between 0.52 and 0.53
+# - many changes adding precedence contexts and associativity
+# - added `-p' and `-s' output style options
+# - various other minor fixes
+# Changes between 0.53 and 0.54
+# - added support for new `for (1..100)' optimization,
+# thanks to Gisle Aas
+# Changes between 0.54 and 0.55
+# - added support for new qr// construct
+# - added support for new pp_regcreset OP
+# Changes between 0.55 and 0.56
+# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
+# - fixed $# on non-lexicals broken in last big rewrite
+# - added temporary fix for change in opcode of OP_STRINGIFY
+# - fixed problem in 0.54's for() patch in `for (@ary)'
+# - fixed precedence in conditional of ?:
+# - tweaked list paren elimination in `my($x) = @_'
+# - made continue-block detection trickier wrt. null ops
+# - fixed various prototype problems in pp_entersub
+# - added support for sub prototypes that never get GVs
+# - added unquoting for special filehandle first arg in truncate
+# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
+# - added semicolons at the ends of blocks
+# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
+
+# Todo:
+# - {} around variables in strings ("${var}letters")
+# base/lex.t 25-27
+# comp/term.t 11
+# - generate symbolic constants directly from core source
+# - left/right context
+# - avoid semis in one-statement blocks
+# - associativity of &&=, ||=, ?:
+# - ',' => '=>' (auto-unquote?)
+# - break long lines ("\r" as discretionary break?)
+# - include values of variables (e.g. set in BEGIN)
+# - coordinate with Data::Dumper (both directions? see previous)
+# - version using op_next instead of op_first/sibling?
+# - avoid string copies (pass arrays, one big join?)
+# - auto-apply `-u'?
+# - while{} with one-statement continue => for(; XXX; XXX) {}?
+# - -uPackage:: descend recursively?
+# - here-docs?
+# - <DATA>?
+
+# Tests that will always fail:
+# comp/redef.t -- all (redefinition happens at compile time)
+
+# Object fields (were globals):
+#
+# avoid_local:
+# (local($a), local($b)) and local($a, $b) have the same internal
+# representation but the short form looks better. We notice we can
+# use a large-scale local when checking the list, but need to prevent
+# individual locals too. This hash holds the addresses of OPs that
+# have already had their local-ness accounted for. The same thing
+# is done with my().
+#
+# curcv:
+# CV for current sub (or main program) being deparsed
+#
+# curstash:
+# name of the current package for deparsed code
+#
+# subs_todo:
+# array of [cop_seq, GV, is_format?] for subs and formats we still
+# want to deparse
+#
+# protos_todo:
+# as above, but [name, prototype] for subs that never got a GV
+#
+# subs_done, forms_done:
+# keys are addresses of GVs for subs and formats we've already
+# deparsed (or at least put into subs_todo)
+#
+# parens: -p
+# linenums: -l
+# cuddle: ` ' or `\n', depending on -sC
+
+# A little explanation of how precedence contexts and associativity
+# work:
+#
+# deparse() calls each per-op subroutine with an argument $cx (short
+# for context, but not the same as the cx* in the perl core), which is
+# a number describing the op's parents in terms of precedence, whether
+# they're inside an expression or at statement level, etc. (see
+# chart below). When ops with children call deparse on them, they pass
+# along their precedence. Fractional values are used to implement
+# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
+# parentheses hacks. The major disadvantage of this scheme is that
+# it doesn't know about right sides and left sides, so say if you
+# assign a listop to a variable, it can't tell it's allowed to leave
+# the parens off the listop.
+
+# Precedences:
+# 26 [TODO] inside interpolation context ("")
+# 25 left terms and list operators (leftward)
+# 24 left ->
+# 23 nonassoc ++ --
+# 22 right **
+# 21 right ! ~ \ and unary + and -
+# 20 left =~ !~
+# 19 left * / % x
+# 18 left + - .
+# 17 left << >>
+# 16 nonassoc named unary operators
+# 15 nonassoc < > <= >= lt gt le ge
+# 14 nonassoc == != <=> eq ne cmp
+# 13 left &
+# 12 left | ^
+# 11 left &&
+# 10 left ||
+# 9 nonassoc .. ...
+# 8 right ?:
+# 7 right = += -= *= etc.
+# 6 left , =>
+# 5 nonassoc list operators (rightward)
+# 4 right not
+# 3 left and
+# 2 left or xor
+# 1 statement modifiers
+# 0 statement level
+
+# Nonprinting characters with special meaning:
+# \cS - steal parens (see maybe_parens_unop)
+# \n - newline and indent
+# \t - increase indent
+# \b - decrease indent (`outdent')
+# \f - flush left (no indent)
+# \cK - kill following semicolon, if any
+
+sub null {
+ my $op = shift;
+ return class($op) eq "NULL";
+}
+
+sub todo {
+ my $self = shift;
+ my($gv, $cv, $is_form) = @_;
+ my $seq;
+ if (!null($cv->START) and is_state($cv->START)) {
+ $seq = $cv->START->cop_seq;
+ } else {
+ $seq = 0;
+ }
+ push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
+}
+
+sub next_todo {
+ my $self = shift;
+ my $ent = shift @{$self->{'subs_todo'}};
+ my $name = $self->gv_name($ent->[1]);
+ if ($ent->[2]) {
+ return "format $name =\n"
+ . $self->deparse_format($ent->[1]->FORM). "\n";
+ } else {
+ return "sub $name " .
+ $self->deparse_sub($ent->[1]->CV);
+ }
+}
+
+sub OPf_KIDS () { 4 }
+
+sub walk_tree {
+ my($op, $sub) = @_;
+ $sub->($op);
+ if ($op->flags & OPf_KIDS) {
+ my $kid;
+ for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
+ walk_tree($kid, $sub);
+ }
+ }
+}
+
+sub walk_sub {
+ my $self = shift;
+ my $cv = shift;
+ my $op = $cv->ROOT;
+ $op = shift if null $op;
+ return if !$op or null $op;
+ walk_tree($op, sub {
+ my $op = shift;
+ if ($op->ppaddr eq "pp_gv") {
+ if ($op->next->ppaddr eq "pp_entersub") {
+ next if $self->{'subs_done'}{$ {$op->gv}}++;
+ next if class($op->gv->CV) eq "SPECIAL";
+ $self->todo($op->gv, $op->gv->CV, 0);
+ $self->walk_sub($op->gv->CV);
+ } elsif ($op->next->ppaddr eq "pp_enterwrite"
+ or ($op->next->ppaddr eq "pp_rv2gv"
+ and $op->next->next->ppaddr eq "pp_enterwrite")) {
+ next if $self->{'forms_done'}{$ {$op->gv}}++;
+ next if class($op->gv->FORM) eq "SPECIAL";
+ $self->todo($op->gv, $op->gv->FORM, 1);
+ $self->walk_sub($op->gv->FORM);
+ }
+ }
+ });
+}
+
+sub stash_subs {
+ my $self = shift;
+ my $pack = shift;
+ my(%stash, @ret);
+ { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
+ if ($pack eq "main") {
+ $pack = "";
+ } else {
+ $pack = $pack . "::";
+ }
+ my($key, $val);
+ while (($key, $val) = each %stash) {
+ my $class = class($val);
+ if ($class eq "PV") {
+ # Just a prototype
+ push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
+ } elsif ($class eq "IV") {
+ # Just a name
+ push @{$self->{'protos_todo'}}, [$pack . $key, undef];
+ } elsif ($class eq "GV") {
+ if (class($val->CV) ne "SPECIAL") {
+ next if $self->{'subs_done'}{$$val}++;
+ $self->todo($val, $val->CV, 0);
+ $self->walk_sub($val->CV);
+ }
+ if (class($val->FORM) ne "SPECIAL") {
+ next if $self->{'forms_done'}{$$val}++;
+ $self->todo($val, $val->FORM, 1);
+ $self->walk_sub($val->FORM);
+ }
+ }
+ }
+}
+
+sub print_protos {
+ my $self = shift;
+ my $ar;
+ my @ret;
+ foreach $ar (@{$self->{'protos_todo'}}) {
+ my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
+ push @ret, "sub " . $ar->[0] . "$proto;\n";
+ }
+ delete $self->{'protos_todo'};
+ return @ret;
+}
+
+sub style_opts {
+ my $self = shift;
+ my $opts = shift;
+ my $opt;
+ while (length($opt = substr($opts, 0, 1))) {
+ if ($opt eq "C") {
+ $self->{'cuddle'} = " ";
+ }
+ $opts = substr($opts, 1);
+ }
+}
+
+sub compile {
+ my(@args) = @_;
+ return sub {
+ my $self = bless {};
+ my $arg;
+ $self->{'subs_todo'} = [];
+ $self->stash_subs("main");
+ $self->{'curcv'} = main_cv;
+ $self->{'curstash'} = "main";
+ $self->{'cuddle'} = "\n";
+ while ($arg = shift @args) {
+ if (substr($arg, 0, 2) eq "-u") {
+ $self->stash_subs(substr($arg, 2));
+ } elsif ($arg eq "-p") {
+ $self->{'parens'} = 1;
+ } elsif ($arg eq "-l") {
+ $self->{'linenums'} = 1;
+ } elsif (substr($arg, 0, 2) eq "-s") {
+ $self->style_opts(substr $arg, 2);
+ }
+ }
+ $self->walk_sub(main_cv, main_start);
+ print $self->print_protos;
+ @{$self->{'subs_todo'}} =
+ sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
+ print indent($self->deparse(main_root, 0)), "\n" unless null main_root;
+ my @text;
+ while (scalar(@{$self->{'subs_todo'}})) {
+ push @text, $self->next_todo;
+ }
+ print indent(join("", @text)), "\n" if @text;
+ }
+}
+
+sub deparse {
+ my $self = shift;
+ my($op, $cx) = @_;
+# cluck if class($op) eq "NULL";
+ my $meth = $op->ppaddr;
+ return $self->$meth($op, $cx);
+}
+
+sub indent {
+ my $txt = shift;
+ my @lines = split(/\n/, $txt);
+ my $leader = "";
+ my $line;
+ for $line (@lines) {
+ if (substr($line, 0, 1) eq "\t") {
+ $leader = $leader . " ";
+ $line = substr($line, 1);
+ } elsif (substr($line, 0, 1) eq "\b") {
+ $leader = substr($leader, 0, length($leader) - 4);
+ $line = substr($line, 1);
+ }
+ if (substr($line, 0, 1) eq "\f") {
+ $line = substr($line, 1); # no indent
+ } else {
+ $line = $leader . $line;
+ }
+ $line =~ s/\cK;?//g;
+ }
+ return join("\n", @lines);
+}
+
+sub SVf_POK () {0x40000}
+
+sub deparse_sub {
+ my $self = shift;
+ my $cv = shift;
+ my $proto = "";
+ if ($cv->FLAGS & SVf_POK) {
+ $proto = "(". $cv->PV . ") ";
+ }
+ local($self->{'curcv'}) = $cv;
+ local($self->{'curstash'}) = $self->{'curstash'};
+ if (not null $cv->ROOT) {
+ # skip leavesub
+ return $proto . "{\n\t" .
+ $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
+ } else { # XSUB?
+ return $proto . "{}\n";
+ }
+}
+
+sub deparse_format {
+ my $self = shift;
+ my $form = shift;
+ my @text;
+ local($self->{'curcv'}) = $form;
+ local($self->{'curstash'}) = $self->{'curstash'};
+ my $op = $form->ROOT;
+ my $kid;
+ $op = $op->first->first; # skip leavewrite, lineseq
+ while (not null $op) {
+ $op = $op->sibling; # skip nextstate
+ my @exprs;
+ $kid = $op->first->sibling; # skip pushmark
+ push @text, $kid->sv->PV;
+ $kid = $kid->sibling;
+ for (; not null $kid; $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 0);
+ }
+ push @text, join(", ", @exprs)."\n" if @exprs;
+ $op = $op->sibling;
+ }
+ return join("", @text) . ".";
+}
+
+# the aassign in-common check messes up SvCUR (always setting it
+# to a value >= 100), but it's probably safe to assume there
+# won't be any NULs in the names of my() variables. (with
+# stash variables, I wouldn't be so sure)
+sub padname_fix {
+ my $str = shift;
+ $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
+ return $str;
+}
+
+sub is_scope {
+ my $op = shift;
+ return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope"
+ || $op->ppaddr eq "pp_lineseq"
+ || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP"
+ && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter"));
+}
+
+sub is_state {
+ my $name = $_[0]->ppaddr;
+ return $name eq "pp_nextstate" || $name eq "pp_dbstate";
+}
+
+sub is_miniwhile { # check for one-line loop (`foo() while $y--')
+ my $op = shift;
+ return (!null($op) and null($op->sibling)
+ and $op->ppaddr eq "pp_null" and class($op) eq "UNOP"
+ and (($op->first->ppaddr =~ /^pp_(and|or)$/
+ and $op->first->first->sibling->ppaddr eq "pp_lineseq")
+ or ($op->first->ppaddr eq "pp_lineseq"
+ and not null $op->first->first->sibling
+ and $op->first->first->sibling->ppaddr eq "pp_unstack")
+ ));
+}
+
+sub is_scalar {
+ my $op = shift;
+ return ($op->ppaddr eq "pp_rv2sv" or
+ $op->ppaddr eq "pp_padsv" or
+ $op->ppaddr eq "pp_gv" or # only in array/hash constructs
+ !null($op->first) && $op->first->ppaddr eq "pp_gvsv");
+}
+
+sub maybe_parens {
+ my $self = shift;
+ my($text, $cx, $prec) = @_;
+ if ($prec < $cx # unary ops nest just fine
+ or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
+ or $self->{'parens'})
+ {
+ $text = "($text)";
+ # In a unop, let parent reuse our parens; see maybe_parens_unop
+ $text = "\cS" . $text if $cx == 16;
+ return $text;
+ } else {
+ return $text;
+ }
+}
+
+# same as above, but get around the `if it looks like a function' rule
+sub maybe_parens_unop {
+ my $self = shift;
+ my($name, $kid, $cx) = @_;
+ if ($cx > 16 or $self->{'parens'}) {
+ return "$name(" . $self->deparse($kid, 1) . ")";
+ } else {
+ $kid = $self->deparse($kid, 16);
+ if (substr($kid, 0, 1) eq "\cS") {
+ # use kid's parens
+ return $name . substr($kid, 1);
+ } elsif (substr($kid, 0, 1) eq "(") {
+ # avoid looks-like-a-function trap with extra parens
+ # (`+' can lead to ambiguities)
+ return "$name(" . $kid . ")";
+ } else {
+ return "$name $kid";
+ }
+ }
+}
+
+sub maybe_parens_func {
+ my $self = shift;
+ my($func, $text, $cx, $prec) = @_;
+ if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
+ return "$func($text)";
+ } else {
+ return "$func $text";
+ }
+}
+
+sub OPp_LVAL_INTRO () { 128 }
+
+sub maybe_local {
+ my $self = shift;
+ my($op, $cx, $text) = @_;
+ if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
+ return $self->maybe_parens_func("local", $text, $cx, 16);
+ } else {
+ return $text;
+ }
+}
+
+sub padname_sv {
+ my $self = shift;
+ my $targ = shift;
+ return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
+}
+
+sub maybe_my {
+ my $self = shift;
+ my($op, $cx, $text) = @_;
+ if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
+ return $self->maybe_parens_func("my", $text, $cx, 16);
+ } else {
+ return $text;
+ }
+}
+
+# The following OPs don't have functions:
+
+# pp_padany -- does not exist after parsing
+# pp_rcatline -- does not exist
+
+sub pp_enter { # see also leave
+ cluck "unexpected OP_ENTER";
+ return "XXX";
+}
+
+sub pp_pushmark { # see also list
+ cluck "unexpected OP_PUSHMARK";
+ return "XXX";
+}
+
+sub pp_leavesub { # see also deparse_sub
+ cluck "unexpected OP_LEAVESUB";
+ return "XXX";
+}
+
+sub pp_leavewrite { # see also deparse_format
+ cluck "unexpected OP_LEAVEWRITE";
+ return "XXX";
+}
+
+sub pp_method { # see also entersub
+ cluck "unexpected OP_METHOD";
+ return "XXX";
+}
+
+sub pp_regcmaybe { # see also regcomp
+ cluck "unexpected OP_REGCMAYBE";
+ return "XXX";
+}
+
+sub pp_regcreset { # see also regcomp
+ cluck "unexpected OP_REGCRESET";
+ return "XXX";
+}
+
+sub pp_substcont { # see also subst
+ cluck "unexpected OP_SUBSTCONT";
+ return "XXX";
+}
+
+sub pp_grepstart { # see also grepwhile
+ cluck "unexpected OP_GREPSTART";
+ return "XXX";
+}
+
+sub pp_mapstart { # see also mapwhile
+ cluck "unexpected OP_MAPSTART";
+ return "XXX";
+}
+
+sub pp_flip { # see also flop
+ cluck "unexpected OP_FLIP";
+ return "XXX";
+}
+
+sub pp_iter { # see also leaveloop
+ cluck "unexpected OP_ITER";
+ return "XXX";
+}
+
+sub pp_enteriter { # see also leaveloop
+ cluck "unexpected OP_ENTERITER";
+ return "XXX";
+}
+
+sub pp_enterloop { # see also leaveloop
+ cluck "unexpected OP_ENTERLOOP";
+ return "XXX";
+}
+
+sub pp_leaveeval { # see also entereval
+ cluck "unexpected OP_LEAVEEVAL";
+ return "XXX";
+}
+
+sub pp_entertry { # see also leavetry
+ cluck "unexpected OP_ENTERTRY";
+ return "XXX";
+}
+
+# leave and scope/lineseq should probably share code
+sub pp_leave {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my ($kid, $expr);
+ my @exprs;
+ local($self->{'curstash'}) = $self->{'curstash'};
+ $kid = $op->first->sibling; # skip enter
+ if (is_miniwhile($kid)) {
+ my $top = $kid->first;
+ my $name = $top->ppaddr;
+ if ($name eq "pp_and") {
+ $name = "while";
+ } elsif ($name eq "pp_or") {
+ $name = "until";
+ } else { # no conditional -> while 1 or until 0
+ return $self->deparse($top->first, 1) . " while 1";
+ }
+ my $cond = $top->first;
+ my $body = $cond->sibling->first; # skip lineseq
+ $cond = $self->deparse($cond, 1);
+ $body = $self->deparse($body, 1);
+ return "$body $name $cond";
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = "";
+ if (is_state $kid) {
+ $expr = $self->deparse($kid, 0);
+ $kid = $kid->sibling;
+ last if null $kid;
+ }
+ $expr .= $self->deparse($kid, 0);
+ push @exprs, $expr if $expr;
+ }
+ if ($cx > 0) { # inside an expression
+ return "do { " . join(";\n", @exprs) . " }";
+ } else {
+ return join(";\n", @exprs) . ";";
+ }
+}
+
+sub pp_scope {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my ($kid, $expr);
+ my @exprs;
+ for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
+ $expr = "";
+ if (is_state $kid) {
+ $expr = $self->deparse($kid, 0);
+ $kid = $kid->sibling;
+ last if null $kid;
+ }
+ $expr .= $self->deparse($kid, 0);
+ push @exprs, $expr if $expr;
+ }
+ if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
+ return "do { " . join(";\n", @exprs) . " }";
+ } else {
+ return join(";\n", @exprs) . ";";
+ }
+}
+
+sub pp_lineseq { pp_scope(@_) }
+
+# The BEGIN {} is used here because otherwise this code isn't executed
+# when you run B::Deparse on itself.
+my %globalnames;
+BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
+ "ENV", "ARGV", "ARGVOUT", "_"); }
+
+sub gv_name {
+ my $self = shift;
+ my $gv = shift;
+ my $stash = $gv->STASH->NAME;
+ my $name = $gv->NAME;
+ if ($stash eq $self->{'curstash'} or $globalnames{$name}
+ or $name =~ /^[^A-Za-z_]/)
+ {
+ $stash = "";
+ } else {
+ $stash = $stash . "::";
+ }
+ if ($name =~ /^([\cA-\cZ])$/) {
+ $name = "^" . chr(64 + ord($1));
+ }
+ return $stash . $name;
+}
+
+# Notice how subs and formats are inserted between statements here
+sub pp_nextstate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my @text;
+ @text = $op->label . ": " if $op->label;
+ my $seq = $op->cop_seq;
+ while (scalar(@{$self->{'subs_todo'}})
+ and $seq > $self->{'subs_todo'}[0][0]) {
+ push @text, $self->next_todo;
+ }
+ my $stash = $op->stash->NAME;
+ if ($stash ne $self->{'curstash'}) {
+ push @text, "package $stash;\n";
+ $self->{'curstash'} = $stash;
+ }
+ if ($self->{'linenums'}) {
+ push @text, "\f#line " . $op->line .
+ ' "' . substr($op->filegv->NAME, 2), qq'"\n';
+ }
+ return join("", @text);
+}
+
+sub pp_dbstate { pp_nextstate(@_) }
+
+sub pp_unstack { return "" } # see also leaveloop
+
+sub baseop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ return $name;
+}
+
+sub pp_stub { baseop(@_, "()") }
+sub pp_wantarray { baseop(@_, "wantarray") }
+sub pp_fork { baseop(@_, "fork") }
+sub pp_wait { baseop(@_, "wait") }
+sub pp_getppid { baseop(@_, "getppid") }
+sub pp_time { baseop(@_, "time") }
+sub pp_tms { baseop(@_, "times") }
+sub pp_ghostent { baseop(@_, "gethostent") }
+sub pp_gnetent { baseop(@_, "getnetent") }
+sub pp_gprotoent { baseop(@_, "getprotoent") }
+sub pp_gservent { baseop(@_, "getservent") }
+sub pp_ehostent { baseop(@_, "endhostent") }
+sub pp_enetent { baseop(@_, "endnetent") }
+sub pp_eprotoent { baseop(@_, "endprotoent") }
+sub pp_eservent { baseop(@_, "endservent") }
+sub pp_gpwent { baseop(@_, "getpwent") }
+sub pp_spwent { baseop(@_, "setpwent") }
+sub pp_epwent { baseop(@_, "endpwent") }
+sub pp_ggrent { baseop(@_, "getgrent") }
+sub pp_sgrent { baseop(@_, "setgrent") }
+sub pp_egrent { baseop(@_, "endgrent") }
+sub pp_getlogin { baseop(@_, "getlogin") }
+
+sub POSTFIX () { 1 }
+
+# I couldn't think of a good short name, but this is the category of
+# symbolic unary operators with interesting precedence
+
+sub pfixop {
+ my $self = shift;
+ my($op, $cx, $name, $prec, $flags) = (@_, 0);
+ my $kid = $op->first;
+ $kid = $self->deparse($kid, $prec);
+ return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
+ $cx, $prec);
+}
+
+sub pp_preinc { pfixop(@_, "++", 23) }
+sub pp_predec { pfixop(@_, "--", 23) }
+sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) }
+sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) }
+sub pp_i_preinc { pfixop(@_, "++", 23) }
+sub pp_i_predec { pfixop(@_, "--", 23) }
+sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) }
+sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) }
+sub pp_complement { pfixop(@_, "~", 21) }
+
+sub pp_negate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) {
+ # avoid --$x
+ $self->pfixop($op, $cx, "-", 21.5);
+ } else {
+ $self->pfixop($op, $cx, "-", 21);
+ }
+}
+sub pp_i_negate { pp_negate(@_) }
+
+sub pp_not {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($cx <= 4) {
+ $self->pfixop($op, $cx, "not ", 4);
+ } else {
+ $self->pfixop($op, $cx, "!", 21);
+ }
+}
+
+sub OPf_SPECIAL () { 128 }
+
+sub unop {
+ my $self = shift;
+ my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
+ my $kid;
+ if ($op->flags & OPf_KIDS) {
+ $kid = $op->first;
+ return $self->maybe_parens_unop($name, $kid, $cx);
+ } else {
+ return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
+ }
+}
+
+sub pp_chop { unop(@_, "chop") }
+sub pp_chomp { unop(@_, "chomp") }
+sub pp_schop { unop(@_, "chop") }
+sub pp_schomp { unop(@_, "chomp") }
+sub pp_defined { unop(@_, "defined") }
+sub pp_undef { unop(@_, "undef") }
+sub pp_study { unop(@_, "study") }
+sub pp_ref { unop(@_, "ref") }
+sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
+
+sub pp_sin { unop(@_, "sin") }
+sub pp_cos { unop(@_, "cos") }
+sub pp_rand { unop(@_, "rand") }
+sub pp_srand { unop(@_, "srand") }
+sub pp_exp { unop(@_, "exp") }
+sub pp_log { unop(@_, "log") }
+sub pp_sqrt { unop(@_, "sqrt") }
+sub pp_int { unop(@_, "int") }
+sub pp_hex { unop(@_, "hex") }
+sub pp_oct { unop(@_, "oct") }
+sub pp_abs { unop(@_, "abs") }
+
+sub pp_length { unop(@_, "length") }
+sub pp_ord { unop(@_, "ord") }
+sub pp_chr { unop(@_, "chr") }
+sub pp_ucfirst { unop(@_, "ucfirst") }
+sub pp_lcfirst { unop(@_, "lcfirst") }
+sub pp_uc { unop(@_, "uc") }
+sub pp_lc { unop(@_, "lc") }
+sub pp_quotemeta { unop(@_, "quotemeta") }
+
+sub pp_each { unop(@_, "each") }
+sub pp_values { unop(@_, "values") }
+sub pp_keys { unop(@_, "keys") }
+sub pp_pop { unop(@_, "pop") }
+sub pp_shift { unop(@_, "shift") }
+
+sub pp_caller { unop(@_, "caller") }
+sub pp_reset { unop(@_, "reset") }
+sub pp_exit { unop(@_, "exit") }
+sub pp_prototype { unop(@_, "prototype") }
+
+sub pp_close { unop(@_, "close") }
+sub pp_fileno { unop(@_, "fileno") }
+sub pp_umask { unop(@_, "umask") }
+sub pp_binmode { unop(@_, "binmode") }
+sub pp_untie { unop(@_, "untie") }
+sub pp_tied { unop(@_, "tied") }
+sub pp_dbmclose { unop(@_, "dbmclose") }
+sub pp_getc { unop(@_, "getc") }
+sub pp_eof { unop(@_, "eof") }
+sub pp_tell { unop(@_, "tell") }
+sub pp_getsockname { unop(@_, "getsockname") }
+sub pp_getpeername { unop(@_, "getpeername") }
+
+sub pp_chdir { unop(@_, "chdir") }
+sub pp_chroot { unop(@_, "chroot") }
+sub pp_readlink { unop(@_, "readlink") }
+sub pp_rmdir { unop(@_, "rmdir") }
+sub pp_readdir { unop(@_, "readdir") }
+sub pp_telldir { unop(@_, "telldir") }
+sub pp_rewinddir { unop(@_, "rewinddir") }
+sub pp_closedir { unop(@_, "closedir") }
+sub pp_getpgrp { unop(@_, "getpgrp") }
+sub pp_localtime { unop(@_, "localtime") }
+sub pp_gmtime { unop(@_, "gmtime") }
+sub pp_alarm { unop(@_, "alarm") }
+sub pp_sleep { unop(@_, "sleep") }
+
+sub pp_dofile { unop(@_, "do") }
+sub pp_entereval { unop(@_, "eval") }
+
+sub pp_ghbyname { unop(@_, "gethostbyname") }
+sub pp_gnbyname { unop(@_, "getnetbyname") }
+sub pp_gpbyname { unop(@_, "getprotobyname") }
+sub pp_shostent { unop(@_, "sethostent") }
+sub pp_snetent { unop(@_, "setnetent") }
+sub pp_sprotoent { unop(@_, "setprotoent") }
+sub pp_sservent { unop(@_, "setservent") }
+sub pp_gpwnam { unop(@_, "getpwnam") }
+sub pp_gpwuid { unop(@_, "getpwuid") }
+sub pp_ggrnam { unop(@_, "getgrnam") }
+sub pp_ggrgid { unop(@_, "getgrgid") }
+
+sub pp_lock { unop(@_, "lock") }
+
+sub pp_exists {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
+ $cx, 16);
+}
+
+sub OPpSLICE () { 64 }
+
+sub pp_delete {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $arg;
+ if ($op->private & OPpSLICE) {
+ return $self->maybe_parens_func("delete",
+ $self->pp_hslice($op->first, 16),
+ $cx, 16);
+ } else {
+ return $self->maybe_parens_func("delete",
+ $self->pp_helem($op->first, 16),
+ $cx, 16);
+ }
+}
+
+sub OPp_CONST_BARE () { 64 }
+
+sub pp_require {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
+ and $op->first->private & OPp_CONST_BARE)
+ {
+ my $name = $op->first->sv->PV;
+ $name =~ s[/][::]g;
+ $name =~ s/\.pm//g;
+ return "require($name)";
+ } else {
+ $self->unop($op, $cx, "require");
+ }
+}
+
+sub pp_scalar {
+ my $self = shift;
+ my($op, $cv) = @_;
+ my $kid = $op->first;
+ if (not null $kid->sibling) {
+ # XXX Was a here-doc
+ return $self->dquote($op);
+ }
+ $self->unop(@_, "scalar");
+}
+
+
+sub padval {
+ my $self = shift;
+ my $targ = shift;
+ return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
+}
+
+sub OPf_REF () { 16 }
+
+sub pp_refgen {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ if ($kid->ppaddr eq "pp_null") {
+ $kid = $kid->first;
+ if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") {
+ my($pre, $post) = @{{"pp_anonlist" => ["[","]"],
+ "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}};
+ my($expr, @exprs);
+ $kid = $kid->first->sibling; # skip pushmark
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = $self->deparse($kid, 6);
+ push @exprs, $expr;
+ }
+ return $pre . join(", ", @exprs) . $post;
+ } elsif (!null($kid->sibling) and
+ $kid->sibling->ppaddr eq "pp_anoncode") {
+ return "sub " .
+ $self->deparse_sub($self->padval($kid->sibling->targ));
+ } elsif ($kid->ppaddr eq "pp_pushmark"
+ and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/
+ and not $kid->sibling->flags & OPf_REF) {
+ # The @a in \(@a) isn't in ref context, but only when the
+ # parens are there.
+ return "\\(" . $self->deparse($kid->sibling, 1) . ")";
+ }
+ }
+ $self->pfixop($op, $cx, "\\", 20);
+}
+
+sub pp_srefgen { pp_refgen(@_) }
+
+sub pp_readline {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
+ if ($kid->ppaddr eq "pp_rv2gv") {
+ $kid = $kid->first;
+ }
+ return "<" . $self->deparse($kid, 1) . ">";
+}
+
+sub loopex {
+ my $self = shift;
+ my ($op, $cx, $name) = @_;
+ if (class($op) eq "PVOP") {
+ return "$name " . $op->pv;
+ } elsif (class($op) eq "OP") {
+ return $name;
+ } elsif (class($op) eq "UNOP") {
+ # Note -- loop exits are actually exempt from the
+ # looks-like-a-func rule, but a few extra parens won't hurt
+ return $self->maybe_parens_unop($name, $op->first, $cx);
+ }
+}
+
+sub pp_last { loopex(@_, "last") }
+sub pp_next { loopex(@_, "next") }
+sub pp_redo { loopex(@_, "redo") }
+sub pp_goto { loopex(@_, "goto") }
+sub pp_dump { loopex(@_, "dump") }
+
+sub ftst {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ if (class($op) eq "UNOP") {
+ # Genuine `-X' filetests are exempt from the LLAFR, but not
+ # l?stat(); for the sake of clarity, give'em all parens
+ return $self->maybe_parens_unop($name, $op->first, $cx);
+ } elsif (class($op) eq "GVOP") {
+ return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
+ } else { # I don't think baseop filetests ever survive ck_ftst, but...
+ return $name;
+ }
+}
+
+sub pp_lstat { ftst(@_, "lstat") }
+sub pp_stat { ftst(@_, "stat") }
+sub pp_ftrread { ftst(@_, "-R") }
+sub pp_ftrwrite { ftst(@_, "-W") }
+sub pp_ftrexec { ftst(@_, "-X") }
+sub pp_fteread { ftst(@_, "-r") }
+sub pp_ftewrite { ftst(@_, "-r") }
+sub pp_fteexec { ftst(@_, "-r") }
+sub pp_ftis { ftst(@_, "-e") }
+sub pp_fteowned { ftst(@_, "-O") }
+sub pp_ftrowned { ftst(@_, "-o") }
+sub pp_ftzero { ftst(@_, "-z") }
+sub pp_ftsize { ftst(@_, "-s") }
+sub pp_ftmtime { ftst(@_, "-M") }
+sub pp_ftatime { ftst(@_, "-A") }
+sub pp_ftctime { ftst(@_, "-C") }
+sub pp_ftsock { ftst(@_, "-S") }
+sub pp_ftchr { ftst(@_, "-c") }
+sub pp_ftblk { ftst(@_, "-b") }
+sub pp_ftfile { ftst(@_, "-f") }
+sub pp_ftdir { ftst(@_, "-d") }
+sub pp_ftpipe { ftst(@_, "-p") }
+sub pp_ftlink { ftst(@_, "-l") }
+sub pp_ftsuid { ftst(@_, "-u") }
+sub pp_ftsgid { ftst(@_, "-g") }
+sub pp_ftsvtx { ftst(@_, "-k") }
+sub pp_fttty { ftst(@_, "-t") }
+sub pp_fttext { ftst(@_, "-T") }
+sub pp_ftbinary { ftst(@_, "-B") }
+
+sub SWAP_CHILDREN () { 1 }
+sub ASSIGN () { 2 } # has OP= variant
+
+sub OPf_STACKED () { 64 }
+
+my(%left, %right);
+
+sub assoc_class {
+ my $op = shift;
+ my $name = $op->ppaddr;
+ if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") {
+ # avoid spurious `=' -- see comment in pp_concat
+ return "pp_concat";
+ }
+ if ($name eq "pp_null" and class($op) eq "UNOP"
+ and $op->first->ppaddr =~ /^pp_(and|x?or)$/
+ and null $op->first->sibling)
+ {
+ # Like all conditional constructs, OP_ANDs and OP_ORs are topped
+ # with a null that's used as the common end point of the two
+ # flows of control. For precedence purposes, ignore it.
+ # (COND_EXPRs have these too, but we don't bother with
+ # their associativity).
+ return assoc_class($op->first);
+ }
+ return $name . ($op->flags & OPf_STACKED ? "=" : "");
+}
+
+# Left associative operators, like `+', for which
+# $a + $b + $c is equivalent to ($a + $b) + $c
+
+BEGIN {
+ %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19,
+ 'pp_divide' => 19, 'pp_i_divide' => 19,
+ 'pp_modulo' => 19, 'pp_i_modulo' => 19,
+ 'pp_repeat' => 19,
+ 'pp_add' => 18, 'pp_i_add' => 18,
+ 'pp_subtract' => 18, 'pp_i_subtract' => 18,
+ 'pp_concat' => 18,
+ 'pp_left_shift' => 17, 'pp_right_shift' => 17,
+ 'pp_bit_and' => 13,
+ 'pp_bit_or' => 12, 'pp_bit_xor' => 12,
+ 'pp_and' => 3,
+ 'pp_or' => 2, 'pp_xor' => 2,
+ );
+}
+
+sub deparse_binop_left {
+ my $self = shift;
+ my($op, $left, $prec) = @_;
+ if ($left{assoc_class($op)}
+ and $left{assoc_class($op)} == $left{assoc_class($left)})
+ {
+ return $self->deparse($left, $prec - .00001);
+ } else {
+ return $self->deparse($left, $prec);
+ }
+}
+
+# Right associative operators, like `=', for which
+# $a = $b = $c is equivalent to $a = ($b = $c)
+
+BEGIN {
+ %right = ('pp_pow' => 22,
+ 'pp_sassign=' => 7, 'pp_aassign=' => 7,
+ 'pp_multiply=' => 7, 'pp_i_multiply=' => 7,
+ 'pp_divide=' => 7, 'pp_i_divide=' => 7,
+ 'pp_modulo=' => 7, 'pp_i_modulo=' => 7,
+ 'pp_repeat=' => 7,
+ 'pp_add=' => 7, 'pp_i_add=' => 7,
+ 'pp_subtract=' => 7, 'pp_i_subtract=' => 7,
+ 'pp_concat=' => 7,
+ 'pp_left_shift=' => 7, 'pp_right_shift=' => 7,
+ 'pp_bit_and=' => 7,
+ 'pp_bit_or=' => 7, 'pp_bit_xor=' => 7,
+ 'pp_andassign' => 7,
+ 'pp_orassign' => 7,
+ );
+}
+
+sub deparse_binop_right {
+ my $self = shift;
+ my($op, $right, $prec) = @_;
+ if ($right{assoc_class($op)}
+ and $right{assoc_class($op)} == $right{assoc_class($right)})
+ {
+ return $self->deparse($right, $prec - .00001);
+ } else {
+ return $self->deparse($right, $prec);
+ }
+}
+
+sub binop {
+ my $self = shift;
+ my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
+ $eq = "=";
+ $prec = 7;
+ }
+ if ($flags & SWAP_CHILDREN) {
+ ($left, $right) = ($right, $left);
+ }
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
+}
+
+sub pp_add { binop(@_, "+", 18, ASSIGN) }
+sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
+sub pp_subtract { binop(@_, "-",18, ASSIGN) }
+sub pp_divide { binop(@_, "/", 19, ASSIGN) }
+sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
+sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
+sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
+sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
+sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
+sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
+sub pp_pow { binop(@_, "**", 22, ASSIGN) }
+
+sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
+sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
+sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
+sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
+sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }
+
+sub pp_eq { binop(@_, "==", 14) }
+sub pp_ne { binop(@_, "!=", 14) }
+sub pp_lt { binop(@_, "<", 15) }
+sub pp_gt { binop(@_, ">", 15) }
+sub pp_ge { binop(@_, ">=", 15) }
+sub pp_le { binop(@_, "<=", 15) }
+sub pp_ncmp { binop(@_, "<=>", 14) }
+sub pp_i_eq { binop(@_, "==", 14) }
+sub pp_i_ne { binop(@_, "!=", 14) }
+sub pp_i_lt { binop(@_, "<", 15) }
+sub pp_i_gt { binop(@_, ">", 15) }
+sub pp_i_ge { binop(@_, ">=", 15) }
+sub pp_i_le { binop(@_, "<=", 15) }
+sub pp_i_ncmp { binop(@_, "<=>", 14) }
+
+sub pp_seq { binop(@_, "eq", 14) }
+sub pp_sne { binop(@_, "ne", 14) }
+sub pp_slt { binop(@_, "lt", 15) }
+sub pp_sgt { binop(@_, "gt", 15) }
+sub pp_sge { binop(@_, "ge", 15) }
+sub pp_sle { binop(@_, "le", 15) }
+sub pp_scmp { binop(@_, "cmp", 14) }
+
+sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
+sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
+
+# `.' is special because concats-of-concats are optimized to save copying
+# by making all but the first concat stacked. The effect is as if the
+# programmer had written `($a . $b) .= $c', except legal.
+sub pp_concat {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ my $prec = 18;
+ if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") {
+ $eq = "=";
+ $prec = 7;
+ }
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left .$eq $right", $cx, $prec);
+}
+
+# `x' is weird when the left arg is a list
+sub pp_repeat {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $left = $op->first;
+ my $right = $op->last;
+ my $eq = "";
+ my $prec = 19;
+ if ($op->flags & OPf_STACKED) {
+ $eq = "=";
+ $prec = 7;
+ }
+ if (null($right)) { # list repeat; count is inside left-side ex-list
+ my $kid = $left->first->sibling; # skip pushmark
+ my @exprs;
+ for (; !null($kid->sibling); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+ $right = $kid;
+ $left = "(" . join(", ", @exprs). ")";
+ } else {
+ $left = $self->deparse_binop_left($op, $left, $prec);
+ }
+ $right = $self->deparse_binop_right($op, $right, $prec);
+ return $self->maybe_parens("$left x$eq $right", $cx, $prec);
+}
+
+sub range {
+ my $self = shift;
+ my ($op, $cx, $type) = @_;
+ my $left = $op->first;
+ my $right = $left->sibling;
+ $left = $self->deparse($left, 9);
+ $right = $self->deparse($right, 9);
+ return $self->maybe_parens("$left $type $right", $cx, 9);
+}
+
+sub pp_flop {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $flip = $op->first;
+ my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
+ return $self->range($flip->first, $cx, $type);
+}
+
+# one-line while/until is handled in pp_leave
+
+sub logop {
+ my $self = shift;
+ my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
+ my $left = $op->first;
+ my $right = $op->first->sibling;
+ if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
+ $left = $self->deparse($left, 1);
+ $right = $self->deparse($right, 0);
+ return "$blockname ($left) {\n\t$right\n\b}\cK";
+ } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
+ $right = $self->deparse($right, 1);
+ $left = $self->deparse($left, 1);
+ return "$right $blockname $left";
+ } elsif ($cx > $lowprec and $highop) { # $a && $b
+ $left = $self->deparse_binop_left($op, $left, $highprec);
+ $right = $self->deparse_binop_right($op, $right, $highprec);
+ return $self->maybe_parens("$left $highop $right", $cx, $highprec);
+ } else { # $a and $b
+ $left = $self->deparse_binop_left($op, $left, $lowprec);
+ $right = $self->deparse_binop_right($op, $right, $lowprec);
+ return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
+ }
+}
+
+sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
+sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
+sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
+
+sub logassignop {
+ my $self = shift;
+ my ($op, $cx, $opname) = @_;
+ my $left = $op->first;
+ my $right = $op->first->sibling->first; # skip sassign
+ $left = $self->deparse($left, 7);
+ $right = $self->deparse($right, 7);
+ return $self->maybe_parens("$left $opname $right", $cx, 7);
+}
+
+sub pp_andassign { logassignop(@_, "&&=") }
+sub pp_orassign { logassignop(@_, "||=") }
+
+sub listop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my(@exprs);
+ my $parens = ($cx >= 5) || $self->{'parens'};
+ my $kid = $op->first->sibling;
+ return $name if null $kid;
+ my $first = $self->deparse($kid, 6);
+ $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
+ push @exprs, $first;
+ $kid = $kid->sibling;
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+ if ($parens) {
+ return "$name(" . join(", ", @exprs) . ")";
+ } else {
+ return "$name " . join(", ", @exprs);
+ }
+}
+
+sub pp_bless { listop(@_, "bless") }
+sub pp_atan2 { listop(@_, "atan2") }
+sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
+sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
+sub pp_index { listop(@_, "index") }
+sub pp_rindex { listop(@_, "rindex") }
+sub pp_sprintf { listop(@_, "sprintf") }
+sub pp_formline { listop(@_, "formline") } # see also deparse_format
+sub pp_crypt { listop(@_, "crypt") }
+sub pp_unpack { listop(@_, "unpack") }
+sub pp_pack { listop(@_, "pack") }
+sub pp_join { listop(@_, "join") }
+sub pp_splice { listop(@_, "splice") }
+sub pp_push { listop(@_, "push") }
+sub pp_unshift { listop(@_, "unshift") }
+sub pp_reverse { listop(@_, "reverse") }
+sub pp_warn { listop(@_, "warn") }
+sub pp_die { listop(@_, "die") }
+# Actually, return is exempt from the LLAFR (see examples in this very
+# module!), but for consistency's sake, ignore that fact
+sub pp_return { listop(@_, "return") }
+sub pp_open { listop(@_, "open") }
+sub pp_pipe_op { listop(@_, "pipe") }
+sub pp_tie { listop(@_, "tie") }
+sub pp_dbmopen { listop(@_, "dbmopen") }
+sub pp_sselect { listop(@_, "select") }
+sub pp_select { listop(@_, "select") }
+sub pp_read { listop(@_, "read") }
+sub pp_sysopen { listop(@_, "sysopen") }
+sub pp_sysseek { listop(@_, "sysseek") }
+sub pp_sysread { listop(@_, "sysread") }
+sub pp_syswrite { listop(@_, "syswrite") }
+sub pp_send { listop(@_, "send") }
+sub pp_recv { listop(@_, "recv") }
+sub pp_seek { listop(@_, "seek") }
+sub pp_fcntl { listop(@_, "fcntl") }
+sub pp_ioctl { listop(@_, "ioctl") }
+sub pp_flock { listop(@_, "flock") }
+sub pp_socket { listop(@_, "socket") }
+sub pp_sockpair { listop(@_, "sockpair") }
+sub pp_bind { listop(@_, "bind") }
+sub pp_connect { listop(@_, "connect") }
+sub pp_listen { listop(@_, "listen") }
+sub pp_accept { listop(@_, "accept") }
+sub pp_shutdown { listop(@_, "shutdown") }
+sub pp_gsockopt { listop(@_, "getsockopt") }
+sub pp_ssockopt { listop(@_, "setsockopt") }
+sub pp_chown { listop(@_, "chown") }
+sub pp_unlink { listop(@_, "unlink") }
+sub pp_chmod { listop(@_, "chmod") }
+sub pp_utime { listop(@_, "utime") }
+sub pp_rename { listop(@_, "rename") }
+sub pp_link { listop(@_, "link") }
+sub pp_symlink { listop(@_, "symlink") }
+sub pp_mkdir { listop(@_, "mkdir") }
+sub pp_open_dir { listop(@_, "opendir") }
+sub pp_seekdir { listop(@_, "seekdir") }
+sub pp_waitpid { listop(@_, "waitpid") }
+sub pp_system { listop(@_, "system") }
+sub pp_exec { listop(@_, "exec") }
+sub pp_kill { listop(@_, "kill") }
+sub pp_setpgrp { listop(@_, "setpgrp") }
+sub pp_getpriority { listop(@_, "getpriority") }
+sub pp_setpriority { listop(@_, "setpriority") }
+sub pp_shmget { listop(@_, "shmget") }
+sub pp_shmctl { listop(@_, "shmctl") }
+sub pp_shmread { listop(@_, "shmread") }
+sub pp_shmwrite { listop(@_, "shmwrite") }
+sub pp_msgget { listop(@_, "msgget") }
+sub pp_msgctl { listop(@_, "msgctl") }
+sub pp_msgsnd { listop(@_, "msgsnd") }
+sub pp_msgrcv { listop(@_, "msgrcv") }
+sub pp_semget { listop(@_, "semget") }
+sub pp_semctl { listop(@_, "semctl") }
+sub pp_semop { listop(@_, "semop") }
+sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
+sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
+sub pp_gpbynumber { listop(@_, "getprotobynumber") }
+sub pp_gsbyname { listop(@_, "getservbyname") }
+sub pp_gsbyport { listop(@_, "getservbyport") }
+sub pp_syscall { listop(@_, "syscall") }
+
+sub pp_glob {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $text = $self->dq($op->first->sibling); # skip pushmark
+ if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
+ or $text =~ /[<>]/) {
+ return 'glob(' . single_delim('qq', '"', $text) . ')';
+ } else {
+ return '<' . $text . '>';
+ }
+}
+
+# Truncate is special because OPf_SPECIAL makes a bareword first arg
+# be a filehandle. This could probably be better fixed in the core
+# by moving the GV lookup into ck_truc.
+
+sub pp_truncate {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my(@exprs);
+ my $parens = ($cx >= 5) || $self->{'parens'};
+ my $kid = $op->first->sibling;
+ my($fh, $len);
+ if ($op->flags & OPf_SPECIAL) {
+ # $kid is an OP_CONST
+ $fh = $kid->sv->PV;
+ } else {
+ $fh = $self->deparse($kid, 6);
+ $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
+ }
+ my $len = $self->deparse($kid->sibling, 6);
+ if ($parens) {
+ return "truncate($fh, $len)";
+ } else {
+ return "truncate $fh, $len";
+ }
+
+}
+
+sub indirop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first->sibling;
+ my $indir = "";
+ if ($op->flags & OPf_STACKED) {
+ $indir = $kid;
+ $indir = $indir->first; # skip rv2gv
+ if (is_scope($indir)) {
+ $indir = "{" . $self->deparse($indir, 0) . "}";
+ } else {
+ $indir = $self->deparse($indir, 24);
+ }
+ $indir = $indir . " ";
+ $kid = $kid->sibling;
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = $self->deparse($kid, 6);
+ push @exprs, $expr;
+ }
+ return $self->maybe_parens_func($name,
+ $indir . join(", ", @exprs),
+ $cx, 5);
+}
+
+sub pp_prtf { indirop(@_, "printf") }
+sub pp_print { indirop(@_, "print") }
+sub pp_sort { indirop(@_, "sort") }
+
+sub mapop {
+ my $self = shift;
+ my($op, $cx, $name) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first; # this is the (map|grep)start
+ $kid = $kid->first->sibling; # skip a pushmark
+ my $code = $kid->first; # skip a null
+ if (is_scope $code) {
+ $code = "{" . $self->deparse($code, 1) . "} ";
+ } else {
+ $code = $self->deparse($code, 24) . ", ";
+ }
+ $kid = $kid->sibling;
+ for (; !null($kid); $kid = $kid->sibling) {
+ $expr = $self->deparse($kid, 6);
+ push @exprs, $expr if $expr;
+ }
+ return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
+}
+
+sub pp_mapwhile { mapop(@_, "map") }
+sub pp_grepwhile { mapop(@_, "grep") }
+
+sub pp_list {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($expr, @exprs);
+ my $kid = $op->first->sibling; # skip pushmark
+ my $lop;
+ my $local = "either"; # could be local(...) or my(...)
+ for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
+ # This assumes that no other private flags equal 128, and that
+ # OPs that store things other than flags in their op_private,
+ # like OP_AELEMFAST, won't be immediate children of a list.
+ unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef")
+ {
+ $local = ""; # or not
+ last;
+ }
+ if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my()
+ ($local = "", last) if $local eq "local";
+ $local = "my";
+ } elsif ($lop->ppaddr ne "pp_undef") { # local()
+ ($local = "", last) if $local eq "my";
+ $local = "local";
+ }
+ }
+ $local = "" if $local eq "either"; # no point if it's all undefs
+ return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
+ for (; !null($kid); $kid = $kid->sibling) {
+ if ($local) {
+ if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
+ $lop = $kid->first;
+ } else {
+ $lop = $kid;
+ }
+ $self->{'avoid_local'}{$$lop}++;
+ $expr = $self->deparse($kid, 6);
+ delete $self->{'avoid_local'}{$$lop};
+ } else {
+ $expr = $self->deparse($kid, 6);
+ }
+ push @exprs, $expr;
+ }
+ if ($local) {
+ return "$local(" . join(", ", @exprs) . ")";
+ } else {
+ return $self->maybe_parens( join(", ", @exprs), $cx, 6);
+ }
+}
+
+sub pp_cond_expr {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $cond = $op->first;
+ my $true = $cond->sibling;
+ my $false = $true->sibling;
+ my $cuddle = $self->{'cuddle'};
+ unless ($cx == 0 and is_scope($true) and is_scope($false)) {
+ $cond = $self->deparse($cond, 8);
+ $true = $self->deparse($true, 8);
+ $false = $self->deparse($false, 8);
+ return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
+ }
+ $cond = $self->deparse($cond, 1);
+ $true = $self->deparse($true, 0);
+ if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
+ my $head = "if ($cond) {\n\t$true\n\b}";
+ my @elsifs;
+ while (!null($false) and $false->ppaddr eq "pp_lineseq") {
+ my $newop = $false->first->sibling->first;
+ my $newcond = $newop->first;
+ my $newtrue = $newcond->sibling;
+ $false = $newtrue->sibling; # last in chain is OP_AND => no else
+ $newcond = $self->deparse($newcond, 1);
+ $newtrue = $self->deparse($newtrue, 0);
+ push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
+ }
+ if (!null($false)) {
+ $false = $cuddle . "else {\n\t" .
+ $self->deparse($false, 0) . "\n\b}\cK";
+ } else {
+ $false = "\cK";
+ }
+ return $head . join($cuddle, "", @elsifs) . $false;
+ }
+ $false = $self->deparse($false, 0);
+ return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
+}
+
+sub pp_leaveloop {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $enter = $op->first;
+ my $kid = $enter->sibling;
+ local($self->{'curstash'}) = $self->{'curstash'};
+ my $head = "";
+ my $bare = 0;
+ if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop
+ if (is_state $kid->last) { # infinite
+ $head = "for (;;) "; # shorter than while (1)
+ } else {
+ $bare = 1;
+ }
+ } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
+ my $ary = $enter->first->sibling; # first was pushmark
+ my $var = $ary->sibling;
+ if ($enter->flags & OPf_STACKED
+ and not null $ary->first->sibling->sibling)
+ {
+ $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
+ $self->deparse($ary->first->sibling->sibling, 9);
+ } else {
+ $ary = $self->deparse($ary, 1);
+ }
+ if (null $var) {
+ if ($enter->flags & OPf_SPECIAL) { # thread special var
+ $var = $self->pp_threadsv($enter, 1);
+ } else { # regular my() variable
+ $var = $self->pp_padsv($enter, 1);
+ if ($self->padname_sv($enter->targ)->IVX ==
+ $kid->first->first->sibling->last->cop_seq)
+ {
+ # If the scope of this variable closes at the last
+ # statement of the loop, it must have been
+ # declared here.
+ $var = "my " . $var;
+ }
+ }
+ } elsif ($var->ppaddr eq "pp_rv2gv") {
+ $var = $self->pp_rv2sv($var, 1);
+ } elsif ($var->ppaddr eq "pp_gv") {
+ $var = "\$" . $self->deparse($var, 1);
+ }
+ $head = "foreach $var ($ary) ";
+ $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
+ } elsif ($kid->ppaddr eq "pp_null") { # while/until
+ $kid = $kid->first;
+ my $name = {"pp_and" => "while", "pp_or" => "until"}
+ ->{$kid->ppaddr};
+ $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
+ $kid = $kid->first->sibling;
+ } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
+ return "{;}"; # {} could be a hashref
+ }
+ # The third-to-last kid is the continue block if the pointer used
+ # by `next BLOCK' points to its first OP, which happens to be the
+ # the op_next of the head of the _previous_ statement.
+ # Unless it's a bare loop, in which case it's last, since there's
+ # no unstack or extra nextstate.
+ # Except if the previous head isn't null but the first kid is
+ # (because it's a nulled out nextstate in a scope), in which
+ # case the head's next is advanced past the null but the nextop's
+ # isn't, so we need to try nextop->next.
+ my($cont, $precont);
+ if ($bare) {
+ $cont = $kid->first;
+ while (!null($cont->sibling)) {
+ $precont = $cont;
+ $cont = $cont->sibling;
+ }
+ } else {
+ $cont = $kid->first;
+ while (!null($cont->sibling->sibling->sibling)) {
+ $precont = $cont;
+ $cont = $cont->sibling;
+ }
+ }
+ if ($precont and $ {$precont->next} == $ {$enter->nextop}
+ || $ {$precont->next} == $ {$enter->nextop->next} )
+ {
+ my $state = $kid->first;
+ my $cuddle = $self->{'cuddle'};
+ my($expr, @exprs);
+ for (; $$state != $$cont; $state = $state->sibling) {
+ $expr = "";
+ if (is_state $state) {
+ $expr = $self->deparse($state, 0);
+ $state = $state->sibling;
+ last if null $kid;
+ }
+ $expr .= $self->deparse($state, 0);
+ push @exprs, $expr if $expr;
+ }
+ $kid = join(";\n", @exprs);
+ $cont = $cuddle . "continue {\n\t" .
+ $self->deparse($cont, 0) . "\n\b}\cK";
+ } else {
+ $cont = "\cK";
+ $kid = $self->deparse($kid, 0);
+ }
+ return $head . "{\n\t" . $kid . "\n\b}" . $cont;
+}
+
+sub pp_leavetry {
+ my $self = shift;
+ return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
+}
+
+sub OP_CONST () { 5 }
+
+# XXX need a better way to do this
+sub OP_STRINGIFY () { $] > 5.004_72 ? 67 : 65 }
+
+sub pp_null {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if (class($op) eq "OP") {
+ return "'???'" if $op->targ == OP_CONST; # old value is lost
+ } elsif ($op->first->ppaddr eq "pp_pushmark") {
+ return $self->pp_list($op, $cx);
+ } elsif ($op->first->ppaddr eq "pp_enter") {
+ return $self->pp_leave($op, $cx);
+ } elsif ($op->targ == OP_STRINGIFY) {
+ return $self->dquote($op);
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->ppaddr eq "pp_readline" and
+ $op->first->sibling->flags & OPf_STACKED) {
+ return $self->maybe_parens($self->deparse($op->first, 7) . " = "
+ . $self->deparse($op->first->sibling, 7),
+ $cx, 7);
+ } elsif (!null($op->first->sibling) and
+ $op->first->sibling->ppaddr eq "pp_trans" and
+ $op->first->sibling->flags & OPf_STACKED) {
+ return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
+ . $self->deparse($op->first->sibling, 20),
+ $cx, 20);
+ } else {
+ return $self->deparse($op->first, $cx);
+ }
+}
+
+sub padname {
+ my $self = shift;
+ my $targ = shift;
+ my $str = $self->padname_sv($targ)->PV;
+ return padname_fix($str);
+}
+
+sub padany {
+ my $self = shift;
+ my $op = shift;
+ return substr($self->padname($op->targ), 1); # skip $/@/%
+}
+
+sub pp_padsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->maybe_my($op, $cx, $self->padname($op->targ));
+}
+
+sub pp_padav { pp_padsv(@_) }
+sub pp_padhv { pp_padsv(@_) }
+
+my @threadsv_names;
+
+BEGIN {
+ @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
+ "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
+ "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
+ "!", "@");
+}
+
+sub pp_threadsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
+}
+
+sub pp_gvsv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
+}
+
+sub pp_gv {
+ my $self = shift;
+ my($op, $cx) = @_;
+ return $self->gv_name($op->gv);
+}
+
+sub pp_aelemfast {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $gv = $op->gv;
+ return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
+}
+
+sub rv2x {
+ my $self = shift;
+ my($op, $cx, $type) = @_;
+ my $kid = $op->first;
+ my $str = $self->deparse($kid, 0);
+ return $type . (is_scalar($kid) ? $str : "{$str}");
+}
+
+sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
+sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
+sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
+
+# skip rv2av
+sub pp_av2arylen {
+ my $self = shift;
+ my($op, $cx) = @_;
+ if ($op->first->ppaddr eq "pp_padav") {
+ return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
+ } else {
+ return $self->maybe_local($op, $cx,
+ $self->rv2x($op->first, $cx, '$#'));
+ }
+}
+
+# skip down to the old, ex-rv2cv
+sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
+
+sub pp_rv2av {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ if ($kid->ppaddr eq "pp_const") { # constant list
+ my $av = $kid->sv;
+ return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
+ } else {
+ return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
+ }
+ }
+
+
+sub elem {
+ my $self = shift;
+ my ($op, $cx, $left, $right, $padname) = @_;
+ my($array, $idx) = ($op->first, $op->first->sibling);
+ unless ($array->ppaddr eq $padname) { # Maybe this has been fixed
+ $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
+ }
+ if ($array->ppaddr eq $padname) {
+ $array = $self->padany($array);
+ } elsif (is_scope($array)) { # ${expr}[0]
+ $array = "{" . $self->deparse($array, 0) . "}";
+ } elsif (is_scalar $array) { # $x[0], $$x[0], ...
+ $array = $self->deparse($array, 24);
+ } else {
+ # $x[20][3]{hi} or expr->[20]
+ my $arrow;
+ $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
+ return $self->deparse($array, 24) . $arrow .
+ $left . $self->deparse($idx, 1) . $right;
+ }
+ $idx = $self->deparse($idx, 1);
+ return "\$" . $array . $left . $idx . $right;
+}
+
+sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
+sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
+
+sub pp_gelem {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($glob, $part) = ($op->first, $op->last);
+ $glob = $glob->first; # skip rv2gv
+ $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
+ my $scope = is_scope($glob);
+ $glob = $self->deparse($glob, 0);
+ $part = $self->deparse($part, 1);
+ return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
+}
+
+sub slice {
+ my $self = shift;
+ my ($op, $cx, $left, $right, $regname, $padname) = @_;
+ my $last;
+ my(@elems, $kid, $array, $list);
+ if (class($op) eq "LISTOP") {
+ $last = $op->last;
+ } else { # ex-hslice inside delete()
+ for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
+ $last = $kid;
+ }
+ $array = $last;
+ $array = $array->first
+ if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
+ if (is_scope($array)) {
+ $array = "{" . $self->deparse($array, 0) . "}";
+ } elsif ($array->ppaddr eq $padname) {
+ $array = $self->padany($array);
+ } else {
+ $array = $self->deparse($array, 24);
+ }
+ $kid = $op->first->sibling; # skip pushmark
+ if ($kid->ppaddr eq "pp_list") {
+ $kid = $kid->first->sibling; # skip list, pushmark
+ for (; !null $kid; $kid = $kid->sibling) {
+ push @elems, $self->deparse($kid, 6);
+ }
+ $list = join(", ", @elems);
+ } else {
+ $list = $self->deparse($kid, 1);
+ }
+ return "\@" . $array . $left . $list . $right;
+}
+
+sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
+ "pp_rv2av", "pp_padav")) }
+sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
+ "pp_rv2hv", "pp_padhv")) }
+
+sub pp_lslice {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $idx = $op->first;
+ my $list = $op->last;
+ my(@elems, $kid);
+ $list = $self->deparse($list, 1);
+ $idx = $self->deparse($idx, 1);
+ return "($list)" . "[$idx]";
+}
+
+sub OPpENTERSUB_AMPER () { 8 }
+
+sub OPf_WANT () { 3 }
+sub OPf_WANT_VOID () { 1 }
+sub OPf_WANT_SCALAR () { 2 }
+sub OPf_WANT_LIST () { 2 }
+
+sub want_scalar {
+ my $op = shift;
+ return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
+}
+
+sub pp_entersub {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $prefix = "";
+ my $amper = "";
+ my $proto = undef;
+ my $simple = 0;
+ my($kid, $args, @exprs);
+ if (not null $op->first->sibling) { # method
+ $kid = $op->first->sibling; # skip pushmark
+ my $obj = $self->deparse($kid, 24);
+ $kid = $kid->sibling;
+ for (; not null $kid->sibling; $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+ my $meth = $kid->first;
+ if ($meth->ppaddr eq "pp_const") {
+ $meth = $meth->sv->PV; # needs to be bare
+ } else {
+ $meth = $self->deparse($meth, 1);
+ }
+ $args = join(", ", @exprs);
+ $kid = $obj . "->" . $meth;
+ if ($args) {
+ return $kid . "(" . $args . ")"; # parens mandatory
+ } else {
+ return $kid; # toke.c fakes parens
+ }
+ }
+ # else, not a method
+ if ($op->flags & OPf_SPECIAL) {
+ $prefix = "do ";
+ } elsif ($op->private & OPpENTERSUB_AMPER) {
+ $amper = "&";
+ }
+ $kid = $op->first;
+ $kid = $kid->first->sibling; # skip ex-list, pushmark
+ for (; not null $kid->sibling; $kid = $kid->sibling) {
+ push @exprs, $kid;
+ }
+ if (is_scope($kid)) {
+ $amper = "&";
+ $kid = "{" . $self->deparse($kid, 0) . "}";
+ } elsif ($kid->first->ppaddr eq "pp_gv") {
+ my $gv = $kid->first->gv;
+ if (class($gv->CV) ne "SPECIAL") {
+ $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
+ }
+ $simple = 1;
+ $kid = $self->deparse($kid, 24);
+ } elsif (is_scalar $kid->first) {
+ $amper = "&";
+ $kid = $self->deparse($kid, 24);
+ } else {
+ $prefix = "";
+ $kid = $self->deparse($kid, 24) . "->";
+ }
+ if (defined $proto and not $amper) {
+ my($arg, $real);
+ my $doneok = 0;
+ my @args = @exprs;
+ my @reals;
+ my $p = $proto;
+ $p =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
+ while ($p) {
+ $p =~ s/^ *([\\]?[\$\@&%*]|;)//;
+ my $chr = $1;
+ if ($chr eq "") {
+ undef $proto if @args;
+ } elsif ($chr eq ";") {
+ $doneok = 1;
+ } elsif ($chr eq "@" or $chr eq "%") {
+ push @reals, map($self->deparse($_, 6), @args);
+ @args = ();
+ } else {
+ $arg = shift @args;
+ last unless $arg;
+ if ($chr eq "\$") {
+ if (want_scalar $arg) {
+ push @reals, $self->deparse($arg, 6);
+ } else {
+ undef $proto;
+ }
+ } elsif ($chr eq "&") {
+ if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
+ push @reals, $self->deparse($arg, 6);
+ } else {
+ undef $proto;
+ }
+ } elsif ($chr eq "*") {
+ if ($arg->ppaddr =~ /^pp_s?refgen$/
+ and $arg->first->first->ppaddr eq "pp_rv2gv")
+ {
+ $real = $arg->first->first; # skip refgen, null
+ if ($real->first->ppaddr eq "pp_gv") {
+ push @reals, $self->deparse($real, 6);
+ } else {
+ push @reals, $self->deparse($real->first, 6);
+ }
+ } else {
+ undef $proto;
+ }
+ } elsif (substr($chr, 0, 1) eq "\\") {
+ $chr = substr($chr, 1);
+ if ($arg->ppaddr =~ /^pp_s?refgen$/ and
+ !null($real = $arg->first) and
+ ($chr eq "\$" && is_scalar($real->first)
+ or ($chr eq "\@"
+ && $real->first->sibling->ppaddr
+ =~ /^pp_(rv2|pad)av$/)
+ or ($chr eq "%"
+ && $real->first->sibling->ppaddr
+ =~ /^pp_(rv2|pad)hv$/)
+ #or ($chr eq "&" # This doesn't work
+ # && $real->first->ppaddr eq "pp_rv2cv")
+ or ($chr eq "*"
+ && $real->first->ppaddr eq "pp_rv2gv")))
+ {
+ push @reals, $self->deparse($real, 6);
+ } else {
+ undef $proto;
+ }
+ }
+ }
+ }
+ undef $proto if $p and !$doneok;
+ undef $proto if @args;
+ $args = join(", ", @reals);
+ $amper = "";
+ unless (defined $proto) {
+ $amper = "&";
+ $args = join(", ", map($self->deparse($_, 6), @exprs));
+ }
+ } else {
+ $args = join(", ", map($self->deparse($_, 6), @exprs));
+ }
+ if ($prefix or $amper) {
+ if ($op->flags & OPf_STACKED) {
+ return $prefix . $amper . $kid . "(" . $args . ")";
+ } else {
+ return $prefix . $amper. $kid;
+ }
+ } else {
+ if (defined $proto and $proto eq "") {
+ return $kid;
+ } elsif ($proto eq "\$") {
+ return $self->maybe_parens_func($kid, $args, $cx, 16);
+ } elsif ($proto or $simple) {
+ return $self->maybe_parens_func($kid, $args, $cx, 5);
+ } else {
+ return "$kid(" . $args . ")";
+ }
+ }
+}
+
+sub pp_enterwrite { unop(@_, "write") }
+
+# escape things that cause interpolation in double quotes,
+# but not character escapes
+sub uninterp {
+ my($str) = @_;
+ $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
+ return $str;
+}
+
+# the same, but treat $|, $), and $ at the end of the string differently
+sub re_uninterp {
+ my($str) = @_;
+ $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
+ $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
+ return $str;
+}
+
+# character escapes, but not delimiters that might need to be escaped
+sub escape_str { # ASCII
+ my($str) = @_;
+ $str =~ s/\a/\\a/g;
+# $str =~ s/\cH/\\b/g; # \b means someting different in a regex
+ $str =~ s/\t/\\t/g;
+ $str =~ s/\n/\\n/g;
+ $str =~ s/\e/\\e/g;
+ $str =~ s/\f/\\f/g;
+ $str =~ s/\r/\\r/g;
+ $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
+ $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
+ return $str;
+}
+
+# Don't do this for regexen
+sub unback {
+ my($str) = @_;
+ $str =~ s/\\/\\\\/g;
+ return $str;
+}
+
+sub balanced_delim {
+ my($str) = @_;
+ my @str = split //, $str;
+ my($ar, $open, $close, $fail, $c, $cnt);
+ for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
+ ($open, $close) = @$ar;
+ $fail = 0; $cnt = 0;
+ for $c (@str) {
+ if ($c eq $open) {
+ $cnt++;
+ } elsif ($c eq $close) {
+ $cnt--;
+ if ($cnt < 0) {
+ $fail = 1;
+ last;
+ }
+ }
+ }
+ $fail = 1 if $cnt != 0;
+ return ($open, "$open$str$close") if not $fail;
+ }
+ return ("", $str);
+}
+
+sub single_delim {
+ my($q, $default, $str) = @_;
+ return "$default$str$default" if $default and index($str, $default) == -1;
+ my($succeed, $delim);
+ ($succeed, $str) = balanced_delim($str);
+ return "$q$str" if $succeed;
+ for $delim ('/', '"', '#') {
+ return "$q$delim" . $str . $delim if index($str, $delim) == -1;
+ }
+ if ($default) {
+ $str =~ s/$default/\\$default/g;
+ return "$default$str$default";
+ } else {
+ $str =~ s[/][\\/]g;
+ return "$q/$str/";
+ }
+}
+
+sub SVf_IOK () {0x10000}
+sub SVf_NOK () {0x20000}
+sub SVf_ROK () {0x80000}
+
+sub const {
+ my $sv = shift;
+ if (class($sv) eq "SPECIAL") {
+ return ('undef', '1', '0')[$$sv-1];
+ } elsif ($sv->FLAGS & SVf_IOK) {
+ return $sv->IV;
+ } elsif ($sv->FLAGS & SVf_NOK) {
+ return $sv->NV;
+ } elsif ($sv->FLAGS & SVf_ROK) {
+ return "\\(" . const($sv->RV) . ")"; # constant folded
+ } else {
+ my $str = $sv->PV;
+ if ($str =~ /[^ -~]/) { # ASCII
+ return single_delim("qq", '"', uninterp escape_str unback $str);
+ } else {
+ $str =~ s/\\/\\\\/g;
+ return single_delim("q", "'", $str);
+ }
+ }
+}
+
+sub pp_const {
+ my $self = shift;
+ my($op, $cx) = @_;
+# if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting
+# return $op->sv->PV;
+# }
+ return const($op->sv);
+}
+
+sub dq {
+ my $self = shift;
+ my $op = shift;
+ my $type = $op->ppaddr;
+ if ($type eq "pp_const") {
+ return uninterp(escape_str(unback($op->sv->PV)));
+ } elsif ($type eq "pp_concat") {
+ return $self->dq($op->first) . $self->dq($op->last);
+ } elsif ($type eq "pp_uc") {
+ return '\U' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "pp_lc") {
+ return '\L' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "pp_ucfirst") {
+ return '\u' . $self->dq($op->first->sibling);
+ } elsif ($type eq "pp_lcfirst") {
+ return '\l' . $self->dq($op->first->sibling);
+ } elsif ($type eq "pp_quotemeta") {
+ return '\Q' . $self->dq($op->first->sibling) . '\E';
+ } elsif ($type eq "pp_join") {
+ return $self->deparse($op->last, 26); # was join($", @ary)
+ } else {
+ return $self->deparse($op, 26);
+ }
+}
+
+sub pp_backtick {
+ my $self = shift;
+ my($op, $cx) = @_;
+ # skip pushmark
+ return single_delim("qx", '`', $self->dq($op->first->sibling));
+}
+
+sub dquote {
+ my $self = shift;
+ my $op = shift;
+ # skip ex-stringify, pushmark
+ return single_delim("qq", '"', $self->dq($op->first->sibling));
+}
+
+# OP_STRINGIFY is a listop, but it only ever has one arg (?)
+sub pp_stringify { dquote(@_) }
+
+# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
+# note that tr(from)/to/ is OK, but not tr/from/(to)
+sub double_delim {
+ my($from, $to) = @_;
+ my($succeed, $delim);
+ if ($from !~ m[/] and $to !~ m[/]) {
+ return "/$from/$to/";
+ } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
+ if (($succeed, $to) = balanced_delim($to) and $succeed) {
+ return "$from$to";
+ } else {
+ for $delim ('/', '"', '#') { # note no `'' -- s''' is special
+ return "$from$delim$to$delim" if index($to, $delim) == -1;
+ }
+ $to =~ s[/][\\/]g;
+ return "$from/$to/";
+ }
+ } else {
+ for $delim ('/', '"', '#') { # note no '
+ return "$delim$from$delim$to$delim"
+ if index($to . $from, $delim) == -1;
+ }
+ $from =~ s[/][\\/]g;
+ $to =~ s[/][\\/]g;
+ return "/$from/$to/";
+ }
+}
+
+sub pchr { # ASCII
+ my($n) = @_;
+ if ($n == ord '\\') {
+ return '\\\\';
+ } elsif ($n >= ord(' ') and $n <= ord('~')) {
+ return chr($n);
+ } elsif ($n == ord "\a") {
+ return '\\a';
+ } elsif ($n == ord "\b") {
+ return '\\b';
+ } elsif ($n == ord "\t") {
+ return '\\t';
+ } elsif ($n == ord "\n") {
+ return '\\n';
+ } elsif ($n == ord "\e") {
+ return '\\e';
+ } elsif ($n == ord "\f") {
+ return '\\f';
+ } elsif ($n == ord "\r") {
+ return '\\r';
+ } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
+ return '\\c' . chr(ord("@") + $n);
+ } else {
+# return '\x' . sprintf("%02x", $n);
+ return '\\' . sprintf("%03o", $n);
+ }
+}
+
+sub collapse {
+ my(@chars) = @_;
+ my($c, $str, $tr);
+ for ($c = 0; $c < @chars; $c++) {
+ $tr = $chars[$c];
+ $str .= pchr($tr);
+ if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
+ $chars[$c + 2] == $tr + 2)
+ {
+ for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {}
+ $str .= "-";
+ $str .= pchr($chars[$c]);
+ }
+ }
+ return $str;
+}
+
+sub OPpTRANS_SQUASH () { 16 }
+sub OPpTRANS_DELETE () { 32 }
+sub OPpTRANS_COMPLEMENT () { 64 }
+
+sub pp_trans {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my(@table) = unpack("s256", $op->pv);
+ my($c, $tr, @from, @to, @delfrom, $delhyphen);
+ if ($table[ord "-"] != -1 and
+ $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
+ {
+ $tr = $table[ord "-"];
+ $table[ord "-"] = -1;
+ if ($tr >= 0) {
+ @from = ord("-");
+ @to = $tr;
+ } else { # -2 ==> delete
+ $delhyphen = 1;
+ }
+ }
+ for ($c = 0; $c < 256; $c++) {
+ $tr = $table[$c];
+ if ($tr >= 0) {
+ push @from, $c; push @to, $tr;
+ } elsif ($tr == -2) {
+ push @delfrom, $c;
+ }
+ }
+ my $flags;
+ @from = (@from, @delfrom);
+ if ($op->private & OPpTRANS_COMPLEMENT) {
+ $flags .= "c";
+ my @newfrom = ();
+ my %from;
+ @from{@from} = (1) x @from;
+ for ($c = 0; $c < 256; $c++) {
+ push @newfrom, $c unless $from{$c};
+ }
+ @from = @newfrom;
+ }
+ if ($op->private & OPpTRANS_DELETE) {
+ $flags .= "d";
+ } else {
+ pop @to while $#to and $to[$#to] == $to[$#to -1];
+ }
+ $flags .= "s" if $op->private & OPpTRANS_SQUASH;
+ my($from, $to);
+ $from = collapse(@from);
+ $to = collapse(@to);
+ $from .= "-" if $delhyphen;
+ return "tr" . double_delim($from, $to) . $flags;
+}
+
+# Like dq(), but different
+sub re_dq {
+ my $self = shift;
+ my $op = shift;
+ my $type = $op->ppaddr;
+ if ($type eq "pp_const") {
+ return uninterp($op->sv->PV);
+ } elsif ($type eq "pp_concat") {
+ return $self->re_dq($op->first) . $self->re_dq($op->last);
+ } elsif ($type eq "pp_uc") {
+ return '\U' . $self->re_dq($op->first->sibling) . '\E';
+ } elsif ($type eq "pp_lc") {
+ return '\L' . $self->re_dq($op->first->sibling) . '\E';
+ } elsif ($type eq "pp_ucfirst") {
+ return '\u' . $self->re_dq($op->first->sibling);
+ } elsif ($type eq "pp_lcfirst") {
+ return '\l' . $self->re_dq($op->first->sibling);
+ } elsif ($type eq "pp_quotemeta") {
+ return '\Q' . $self->re_dq($op->first->sibling) . '\E';
+ } elsif ($type eq "pp_join") {
+ return $self->deparse($op->last, 26); # was join($", @ary)
+ } else {
+ return $self->deparse($op, 26);
+ }
+}
+
+sub pp_regcomp {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
+ $kid = $kid->first if $kid->ppaddr eq "pp_regcreset";
+ return $self->re_dq($kid);
+}
+
+sub OPp_RUNTIME () { 64 }
+
+sub PMf_ONCE () { 0x2 }
+sub PMf_SKIPWHITE () { 0x10 }
+sub PMf_CONST () { 0x40 }
+sub PMf_KEEP () { 0x80 }
+sub PMf_GLOBAL () { 0x100 }
+sub PMf_CONTINUE () { 0x200 }
+sub PMf_EVAL () { 0x400 }
+sub PMf_LOCALE () { 0x800 }
+sub PMf_MULTILINE () { 0x1000 }
+sub PMf_SINGLELINE () { 0x2000 }
+sub PMf_FOLD () { 0x4000 }
+sub PMf_EXTENDED () { 0x8000 }
+
+# osmic acid -- see osmium tetroxide
+
+my %matchwords;
+map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
+ 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
+ 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
+
+sub matchop {
+ my $self = shift;
+ my($op, $cx, $name, $delim) = @_;
+ my $kid = $op->first;
+ my ($binop, $var, $re) = ("", "", "");
+ if ($op->flags & OPf_STACKED) {
+ $binop = 1;
+ $var = $self->deparse($kid, 20);
+ $kid = $kid->sibling;
+ }
+ if (null $kid) {
+ $re = re_uninterp(escape_str($op->precomp));
+ } else {
+ $re = $self->deparse($kid, 1);
+ }
+ my $flags = "";
+ $flags .= "c" if $op->pmflags & PMf_CONTINUE;
+ $flags .= "g" if $op->pmflags & PMf_GLOBAL;
+ $flags .= "i" if $op->pmflags & PMf_FOLD;
+ $flags .= "m" if $op->pmflags & PMf_MULTILINE;
+ $flags .= "o" if $op->pmflags & PMf_KEEP;
+ $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
+ $flags .= "x" if $op->pmflags & PMf_EXTENDED;
+ $flags = $matchwords{$flags} if $matchwords{$flags};
+ if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
+ $re =~ s/\?/\\?/g;
+ $re = "?$re?";
+ } else {
+ $re = single_delim($name, $delim, $re);
+ }
+ $re = $re . $flags;
+ if ($binop) {
+ return $self->maybe_parens("$var =~ $re", $cx, 20);
+ } else {
+ return $re;
+ }
+}
+
+sub pp_match { matchop(@_, "m", "/") }
+sub pp_pushre { matchop(@_, "m", "/") }
+sub pp_qr { matchop(@_, "qr", "") }
+
+sub pp_split {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my($kid, @exprs, $ary, $expr);
+ $kid = $op->first;
+ if ($ {$kid->pmreplroot}) {
+ $ary = '@' . $self->gv_name($kid->pmreplroot);
+ }
+ for (; !null($kid); $kid = $kid->sibling) {
+ push @exprs, $self->deparse($kid, 6);
+ }
+ $expr = "split(" . join(", ", @exprs) . ")";
+ if ($ary) {
+ return $self->maybe_parens("$ary = $expr", $cx, 7);
+ } else {
+ return $expr;
+ }
+}
+
+# oxime -- any of various compounds obtained chiefly by the action of
+# hydroxylamine on aldehydes and ketones and characterized by the
+# bivalent grouping C=NOH [Webster's Tenth]
+
+my %substwords;
+map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
+ 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
+ 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
+ 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
+
+sub pp_subst {
+ my $self = shift;
+ my($op, $cx) = @_;
+ my $kid = $op->first;
+ my($binop, $var, $re, $repl) = ("", "", "", "");
+ if ($op->flags & OPf_STACKED) {
+ $binop = 1;
+ $var = $self->deparse($kid, 20);
+ $kid = $kid->sibling;
+ }
+ my $flags = "";
+ if (null($op->pmreplroot)) {
+ $repl = $self->dq($kid);
+ $kid = $kid->sibling;
+ } else {
+ $repl = $op->pmreplroot->first; # skip substcont
+ while ($repl->ppaddr eq "pp_entereval") {
+ $repl = $repl->first;
+ $flags .= "e";
+ }
+ $repl = $self->dq($repl);
+ }
+ if (null $kid) {
+ $re = re_uninterp(escape_str($op->precomp));
+ } else {
+ $re = $self->deparse($kid, 1);
+ }
+ $flags .= "e" if $op->pmflags & PMf_EVAL;
+ $flags .= "g" if $op->pmflags & PMf_GLOBAL;
+ $flags .= "i" if $op->pmflags & PMf_FOLD;
+ $flags .= "m" if $op->pmflags & PMf_MULTILINE;
+ $flags .= "o" if $op->pmflags & PMf_KEEP;
+ $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
+ $flags .= "x" if $op->pmflags & PMf_EXTENDED;
+ $flags = $substwords{$flags} if $substwords{$flags};
+ if ($binop) {
+ return $self->maybe_parens("$var =~ s"
+ . double_delim($re, $repl) . $flags,
+ $cx, 20);
+ } else {
+ return "s". double_delim($re, $repl) . $flags;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+B::Deparse - Perl compiler backend to produce perl code
+
+=head1 SYNOPSIS
+
+B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-l>][B<,-s>I<LETTERS>] I<prog.pl>
+
+=head1 DESCRIPTION
+
+B::Deparse is a backend module for the Perl compiler that generates
+perl source code, based on the internal compiled structure that perl
+itself creates after parsing a program. The output of B::Deparse won't
+be exactly the same as the original source, since perl doesn't keep
+track of comments or whitespace, and there isn't a one-to-one
+correspondence between perl's syntactical constructions and their
+compiled form, but it will often be close. When you use the B<-p>
+option, the output also includes parentheses even when they are not
+required by precedence, which can make it easy to see if perl is
+parsing your expressions the way you intended.
+
+Please note that this module is mainly new and untested code and is
+still under development, so it may change in the future.
+
+=head1 OPTIONS
+
+As with all compiler backend options, these must follow directly after
+the '-MO=Deparse', separated by a comma but not any white space.
+
+=over 4
+
+=item B<-p>
+
+Print extra parentheses. Without this option, B::Deparse includes
+parentheses in its output only when they are needed, based on the
+structure of your program. With B<-p>, it uses parentheses (almost)
+whenever they would be legal. This can be useful if you are used to
+LISP, or if you want to see how perl parses your input. If you say
+
+ if ($var & 0x7f == 65) {print "Gimme an A!"}
+ print ($which ? $a : $b), "\n";
+ $name = $ENV{USER} or "Bob";
+
+C<B::Deparse,-p> will print
+
+ if (($var & 0)) {
+ print('Gimme an A!')
+ };
+ (print(($which ? $a : $b)), '???');
+ (($name = $ENV{'USER'}) or '???')
+
+which probably isn't what you intended (the C<'???'> is a sign that
+perl optimized away a constant value).
+
+=item B<-u>I<PACKAGE>
+
+Normally, B::Deparse deparses the main code of a program, all the subs
+called by the main program (and all the subs called by them,
+recursively), and any other subs in the main:: package. To include
+subs in other packages that aren't called directly, such as AUTOLOAD,
+DESTROY, other subs called automatically by perl, and methods, which
+aren't resolved to subs until runtime, use the B<-u> option. The
+argument to B<-u> is the name of a package, and should follow directly
+after the 'u'. Multiple B<-u> options may be given, separated by
+commas. Note that unlike some other backends, B::Deparse doesn't
+(yet) try to guess automatically when B<-u> is needed -- you must
+invoke it yourself.
+
+=item B<-l>
+
+Add '#line' declarations to the output based on the line and file
+locations of the original code.
+
+=item B<-s>I<LETTERS>
+
+Tweak the style of B::Deparse's output. At the moment, only one style
+option is implemented:
+
+=over 4
+
+=item B<C>
+
+Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
+
+ if (...) {
+ ...
+ } else {
+ ...
+ }
+
+instead of
+
+ if (...) {
+ ...
+ }
+ else {
+ ...
+ }
+
+The default is not to cuddle.
+
+=back
+
+=back
+
+=head1 BUGS
+
+See the 'to do' list at the beginning of the module file.
+
+=head1 AUTHOR
+
+Stephen McCamant <alias@mcs.com>, based on an earlier version by
+Malcolm Beattie <mbeattie@sable.ox.ac.uk>.
+
+=cut
diff --git a/contrib/perl5/ext/B/B/Disassembler.pm b/contrib/perl5/ext/B/B/Disassembler.pm
new file mode 100644
index 000000000000..f26441d2d062
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Disassembler.pm
@@ -0,0 +1,164 @@
+# Disassembler.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+package B::Disassembler::BytecodeStream;
+use FileHandle;
+use Carp;
+use B qw(cstring cast_I32);
+@ISA = qw(FileHandle);
+sub readn {
+ my ($fh, $len) = @_;
+ my $data;
+ read($fh, $data, $len);
+ croak "reached EOF while reading $len bytes" unless length($data) == $len;
+ return $data;
+}
+
+sub GET_U8 {
+ my $fh = shift;
+ my $c = $fh->getc;
+ croak "reached EOF while reading U8" unless defined($c);
+ return ord($c);
+}
+
+sub GET_U16 {
+ my $fh = shift;
+ my $str = $fh->readn(2);
+ croak "reached EOF while reading U16" unless length($str) == 2;
+ return unpack("n", $str);
+}
+
+sub GET_U32 {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading U32" unless length($str) == 4;
+ return unpack("N", $str);
+}
+
+sub GET_I32 {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading I32" unless length($str) == 4;
+ return cast_I32(unpack("N", $str));
+}
+
+sub GET_objindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading objindex" unless length($str) == 4;
+ return unpack("N", $str);
+}
+
+sub GET_strconst {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading strconst" unless defined($c);
+ return cstring($str);
+}
+
+sub GET_pvcontents {}
+
+sub GET_PV {
+ my $fh = shift;
+ my $str;
+ my $len = $fh->GET_U32;
+ if ($len) {
+ read($fh, $str, $len);
+ croak "reached EOF while reading PV" unless length($str) == $len;
+ return cstring($str);
+ } else {
+ return '""';
+ }
+}
+
+sub GET_comment {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\n") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading comment" unless defined($c);
+ return cstring($str);
+}
+
+sub GET_double {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading double" unless defined($c);
+ return $str;
+}
+
+sub GET_none {}
+
+sub GET_op_tr_array {
+ my $fh = shift;
+ my @ary = unpack("n256", $fh->readn(256 * 2));
+ return join(",", @ary);
+}
+
+sub GET_IV64 {
+ my $fh = shift;
+ my ($hi, $lo) = unpack("NN", $fh->readn(8));
+ return sprintf("0x%4x%04x", $hi, $lo); # cheat
+}
+
+package B::Disassembler;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(disassemble_fh);
+use Carp;
+use strict;
+
+use B::Asmdata qw(%insn_data @insn_name);
+
+sub disassemble_fh {
+ my ($fh, $out) = @_;
+ my ($c, $getmeth, $insn, $arg);
+ bless $fh, "B::Disassembler::BytecodeStream";
+ while (defined($c = $fh->getc)) {
+ $c = ord($c);
+ $insn = $insn_name[$c];
+ if (!defined($insn) || $insn eq "unused") {
+ my $pos = $fh->tell - 1;
+ die "Illegal instruction code $c at stream offset $pos\n";
+ }
+ $getmeth = $insn_data{$insn}->[2];
+ $arg = $fh->$getmeth();
+ if (defined($arg)) {
+ &$out($insn, $arg);
+ } else {
+ &$out($insn);
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Disassembler - Disassemble Perl bytecode
+
+=head1 SYNOPSIS
+
+ use Disassembler;
+
+=head1 DESCRIPTION
+
+See F<ext/B/B/Disassembler.pm>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/Lint.pm b/contrib/perl5/ext/B/B/Lint.pm
new file mode 100644
index 000000000000..d34bd7792bca
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Lint.pm
@@ -0,0 +1,367 @@
+package B::Lint;
+
+=head1 NAME
+
+B::Lint - Perl lint
+
+=head1 SYNOPSIS
+
+perl -MO=Lint[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Lint module is equivalent to an extended version of the B<-w>
+option of B<perl>. It is named after the program B<lint> which carries
+out a similar process for C programs.
+
+=head1 OPTIONS AND LINT CHECKS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options. Following any options
+(indicated by a leading B<->) come lint check arguments. Each such
+argument (apart from the special B<all> and B<none> options) is a
+word representing one possible lint check (turning on that check) or
+is B<no-foo> (turning off that check). Before processing the check
+arguments, a standard list of checks is turned on. Later options
+override earlier ones. Available options are:
+
+=over 8
+
+=item B<context>
+
+Produces a warning whenever an array is used in an implicit scalar
+context. For example, both of the lines
+
+ $foo = length(@bar);
+ $foo = @bar;
+will elicit a warning. Using an explicit B<scalar()> silences the
+warning. For example,
+
+ $foo = scalar(@bar);
+
+=item B<implicit-read> and B<implicit-write>
+
+These options produce a warning whenever an operation implicitly
+reads or (respectively) writes to one of Perl's special variables.
+For example, B<implicit-read> will warn about these:
+
+ /foo/;
+
+and B<implicit-write> will warn about these:
+
+ s/foo/bar/;
+
+Both B<implicit-read> and B<implicit-write> warn about this:
+
+ for (@a) { ... }
+
+=item B<dollar-underscore>
+
+This option warns whenever $_ is used either explicitly anywhere or
+as the implicit argument of a B<print> statement.
+
+=item B<private-names>
+
+This option warns on each use of any variable, subroutine or
+method name that lives in a non-current package but begins with
+an underscore ("_"). Warnings aren't issued for the special case
+of the single character name "_" by itself (e.g. $_ and @_).
+
+=item B<undefined-subs>
+
+This option warns whenever an undefined subroutine is invoked.
+This option will only catch explicitly invoked subroutines such
+as C<foo()> and not indirect invocations such as C<&$subref()>
+or C<$obj-E<gt>meth()>. Note that some programs or modules delay
+definition of subs until runtime by means of the AUTOLOAD
+mechanism.
+
+=item B<regexp-variables>
+
+This option warns whenever one of the regexp variables $', $& or
+$' is used. Any occurrence of any of these variables in your
+program can slow your whole program down. See L<perlre> for
+details.
+
+=item B<all>
+
+Turn all warnings on.
+
+=item B<none>
+
+Turn all warnings off.
+
+=back
+
+=head1 NON LINT-CHECK OPTIONS
+
+=over 8
+
+=item B<-u Package>
+
+Normally, Lint only checks the main code of the program together
+with all subs defined in package main. The B<-u> option lets you
+include other package names whose subs are then checked by Lint.
+
+=back
+
+=head1 BUGS
+
+This is only a very preliminary version.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie@sable.ox.ac.uk.
+
+=cut
+
+use strict;
+use B qw(walkoptree_slow main_root walksymtable svref_2object parents);
+
+# Constants (should probably be elsewhere)
+sub G_ARRAY () { 1 }
+sub OPf_LIST () { 1 }
+sub OPf_KNOW () { 2 }
+sub OPf_STACKED () { 64 }
+
+my $file = "unknown"; # shadows current filename
+my $line = 0; # shadows current line number
+my $curstash = "main"; # shadows current stash
+
+# Lint checks
+my %check;
+my %implies_ok_context;
+BEGIN {
+ map($implies_ok_context{$_}++,
+ qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice
+ pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete));
+}
+
+# Lint checks turned on by default
+my @default_checks = qw(context);
+
+my %valid_check;
+# All valid checks
+BEGIN {
+ map($valid_check{$_}++,
+ qw(context implicit_read implicit_write dollar_underscore
+ private_names undefined_subs regexp_variables));
+}
+
+# Debugging options
+my ($debug_op);
+
+my %done_cv; # used to mark which subs have already been linted
+my @extra_packages; # Lint checks mainline code and all subs which are
+ # in main:: or in one of these packages.
+
+sub warning {
+ my $format = (@_ < 2) ? "%s" : shift;
+ warn sprintf("$format at %s line %d\n", @_, $file, $line);
+}
+
+# This gimme can't cope with context that's only determined
+# at runtime via dowantarray().
+sub gimme {
+ my $op = shift;
+ my $flags = $op->flags;
+ if ($flags & OPf_KNOW) {
+ return(($flags & OPf_LIST) ? 1 : 0);
+ }
+ return undef;
+}
+
+sub B::OP::lint {}
+
+sub B::COP::lint {
+ my $op = shift;
+ if ($op->ppaddr eq "pp_nextstate") {
+ $file = $op->filegv->SV->PV;
+ $line = $op->line;
+ $curstash = $op->stash->NAME;
+ }
+}
+
+sub B::UNOP::lint {
+ my $op = shift;
+ my $ppaddr = $op->ppaddr;
+ if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) {
+ my $parent = parents->[0];
+ my $pname = $parent->ppaddr;
+ return if gimme($op) || $implies_ok_context{$pname};
+ # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
+ # null out the parent so we have to check for a parent of pp_null and
+ # a grandparent of pp_enteriter or pp_delete
+ if ($pname eq "pp_null") {
+ my $gpname = parents->[1]->ppaddr;
+ return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete";
+ }
+ warning("Implicit scalar context for %s in %s",
+ $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc);
+ }
+ if ($check{private_names} && $ppaddr eq "pp_method") {
+ my $methop = $op->first;
+ if ($methop->ppaddr eq "pp_const") {
+ my $method = $methop->sv->PV;
+ if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
+ warning("Illegal reference to private method name $method");
+ }
+ }
+ }
+}
+
+sub B::PMOP::lint {
+ my $op = shift;
+ if ($check{implicit_read}) {
+ my $ppaddr = $op->ppaddr;
+ if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) {
+ warning('Implicit match on $_');
+ }
+ }
+ if ($check{implicit_write}) {
+ my $ppaddr = $op->ppaddr;
+ if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) {
+ warning('Implicit substitution on $_');
+ }
+ }
+}
+
+sub B::LOOP::lint {
+ my $op = shift;
+ if ($check{implicit_read} || $check{implicit_write}) {
+ my $ppaddr = $op->ppaddr;
+ if ($ppaddr eq "pp_enteriter") {
+ my $last = $op->last;
+ if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") {
+ warning('Implicit use of $_ in foreach');
+ }
+ }
+ }
+}
+
+sub B::GVOP::lint {
+ my $op = shift;
+ if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv"
+ && $op->gv->NAME eq "_")
+ {
+ warning('Use of $_');
+ }
+ if ($check{private_names}) {
+ my $ppaddr = $op->ppaddr;
+ my $gv = $op->gv;
+ if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv")
+ && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash)
+ {
+ warning('Illegal reference to private name %s', $gv->NAME);
+ }
+ }
+ if ($check{undefined_subs}) {
+ if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") {
+ my $gv = $op->gv;
+ my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
+ no strict 'refs';
+ if (!defined(&$subname)) {
+ $subname =~ s/^main:://;
+ warning('Undefined subroutine %s called', $subname);
+ }
+ }
+ }
+ if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") {
+ my $name = $op->gv->NAME;
+ if ($name =~ /^[&'`]$/) {
+ warning('Use of regexp variable $%s', $name);
+ }
+ }
+}
+
+sub B::GV::lintcv {
+ my $gv = shift;
+ my $cv = $gv->CV;
+ #warn sprintf("lintcv: %s::%s (done=%d)\n",
+ # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
+ return if !$$cv || $done_cv{$$cv}++;
+ my $root = $cv->ROOT;
+ #warn " root = $root (0x$$root)\n";#debug
+ walkoptree_slow($root, "lint") if $$root;
+}
+
+sub do_lint {
+ my %search_pack;
+ walkoptree_slow(main_root, "lint") if ${main_root()};
+
+ # Now do subs in main
+ no strict qw(vars refs);
+ my $sym;
+ local(*glob);
+ while (($sym, *glob) = each %{"main::"}) {
+ #warn "Trying $sym\n";#debug
+ svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/;
+ }
+
+ # Now do subs in non-main packages given by -u options
+ map { $search_pack{$_} = 1 } @extra_packages;
+ walksymtable(\%{"main::"}, "lintcv", sub {
+ my $package = shift;
+ $package =~ s/::$//;
+ #warn "Considering $package\n";#debug
+ return exists $search_pack{$package};
+ });
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ # Turn on default lint checks
+ for $opt (@default_checks) {
+ $check{$opt} = 1;
+ }
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "O") {
+ $debug_op = 1;
+ }
+ }
+ } elsif ($opt eq "u") {
+ $arg ||= shift @options;
+ push(@extra_packages, $arg);
+ }
+ }
+ foreach $opt (@default_checks, @options) {
+ $opt =~ tr/-/_/;
+ if ($opt eq "all") {
+ %check = %valid_check;
+ }
+ elsif ($opt eq "none") {
+ %check = ();
+ }
+ else {
+ if ($opt =~ s/^no-//) {
+ $check{$opt} = 0;
+ }
+ else {
+ $check{$opt} = 1;
+ }
+ warn "No such check: $opt\n" unless defined $valid_check{$opt};
+ }
+ }
+ # Remaining arguments are things to check
+
+ return \&do_lint;
+}
+
+1;
diff --git a/contrib/perl5/ext/B/B/Showlex.pm b/contrib/perl5/ext/B/B/Showlex.pm
new file mode 100644
index 000000000000..648f95dcc0a3
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Showlex.pm
@@ -0,0 +1,80 @@
+package B::Showlex;
+use strict;
+use B qw(svref_2object comppadlist class);
+use B::Terse ();
+
+#
+# Invoke as
+# perl -MO=Showlex,foo bar.pl
+# to see the names of lexical variables used by &foo
+# or as
+# perl -MO=Showlex bar.pl
+# to see the names of file scope lexicals used by bar.pl
+#
+
+sub showarray {
+ my ($name, $av) = @_;
+ my @els = $av->ARRAY;
+ my $count = @els;
+ my $i;
+ print "$name has $count entries\n";
+ for ($i = 0; $i < $count; $i++) {
+ print "$i: ";
+ $els[$i]->terse;
+ }
+}
+
+sub showlex {
+ my ($objname, $namesav, $valsav) = @_;
+ showarray("Pad of lexical names for $objname", $namesav);
+ showarray("Pad of lexical values for $objname", $valsav);
+}
+
+sub showlex_obj {
+ my ($objname, $obj) = @_;
+ $objname =~ s/^&main::/&/;
+ showlex($objname, svref_2object($obj)->PADLIST->ARRAY);
+}
+
+sub showlex_main {
+ showlex("comppadlist", comppadlist->ARRAY);
+}
+
+sub compile {
+ my @options = @_;
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "showlex_obj('&$objname', \\&$objname)";
+ }
+ }
+ } else {
+ return \&showlex_main;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Showlex - Show lexical variables used in functions or files
+
+=head1 SYNOPSIS
+
+ perl -MO=Showlex[,SUBROUTINE] foo.pl
+
+=head1 DESCRIPTION
+
+When a subroutine name is provided in OPTIONS, prints the lexical
+variables used in that subroutine. Otherwise, prints the file-scope
+lexicals in the file.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/Stackobj.pm b/contrib/perl5/ext/B/B/Stackobj.pm
new file mode 100644
index 000000000000..eea966ceb6b7
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Stackobj.pm
@@ -0,0 +1,301 @@
+# Stackobj.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B::Stackobj;
+use Exporter ();
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT
+ VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
+%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
+ flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
+ REGISTER TEMPORARY)]);
+
+use Carp qw(confess);
+use strict;
+use B qw(class);
+
+# Perl internal constants that I should probably define elsewhere.
+sub SVf_IOK () { 0x10000 }
+sub SVf_NOK () { 0x20000 }
+
+# Types
+sub T_UNKNOWN () { 0 }
+sub T_DOUBLE () { 1 }
+sub T_INT () { 2 }
+
+# Flags
+sub VALID_INT () { 0x01 }
+sub VALID_DOUBLE () { 0x02 }
+sub VALID_SV () { 0x04 }
+sub REGISTER () { 0x08 } # no implicit write-back when calling subs
+sub TEMPORARY () { 0x10 } # no implicit write-back needed at all
+
+#
+# Callback for runtime code generation
+#
+my $runtime_callback = sub { confess "set_callback not yet called" };
+sub set_callback (&) { $runtime_callback = shift }
+sub runtime { &$runtime_callback(@_) }
+
+#
+# Methods
+#
+
+sub write_back { confess "stack object does not implement write_back" }
+
+sub invalidate { shift->{flags} &= ~(VALID_INT | VALID_DOUBLE) }
+
+sub as_sv {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_SV)) {
+ $obj->write_back;
+ $obj->{flags} |= VALID_SV;
+ }
+ return $obj->{sv};
+}
+
+sub as_int {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_INT)) {
+ $obj->load_int;
+ $obj->{flags} |= VALID_INT;
+ }
+ return $obj->{iv};
+}
+
+sub as_double {
+ my $obj = shift;
+ if (!($obj->{flags} & VALID_DOUBLE)) {
+ $obj->load_double;
+ $obj->{flags} |= VALID_DOUBLE;
+ }
+ return $obj->{nv};
+}
+
+sub as_numeric {
+ my $obj = shift;
+ return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
+}
+
+#
+# Debugging methods
+#
+sub peek {
+ my $obj = shift;
+ my $type = $obj->{type};
+ my $flags = $obj->{flags};
+ my @flags;
+ if ($type == T_UNKNOWN) {
+ $type = "T_UNKNOWN";
+ } elsif ($type == T_INT) {
+ $type = "T_INT";
+ } elsif ($type == T_DOUBLE) {
+ $type = "T_DOUBLE";
+ } else {
+ $type = "(illegal type $type)";
+ }
+ push(@flags, "VALID_INT") if $flags & VALID_INT;
+ push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
+ push(@flags, "VALID_SV") if $flags & VALID_SV;
+ push(@flags, "REGISTER") if $flags & REGISTER;
+ push(@flags, "TEMPORARY") if $flags & TEMPORARY;
+ @flags = ("none") unless @flags;
+ return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
+ class($obj), join("|", @flags));
+}
+
+sub minipeek {
+ my $obj = shift;
+ my $type = $obj->{type};
+ my $flags = $obj->{flags};
+ if ($type == T_INT || $flags & VALID_INT) {
+ return $obj->{iv};
+ } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
+ return $obj->{nv};
+ } else {
+ return $obj->{sv};
+ }
+}
+
+#
+# Caller needs to ensure that set_int, set_double,
+# set_numeric and set_sv are only invoked on legal lvalues.
+#
+sub set_int {
+ my ($obj, $expr) = @_;
+ runtime("$obj->{iv} = $expr;");
+ $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
+ $obj->{flags} |= VALID_INT;
+}
+
+sub set_double {
+ my ($obj, $expr) = @_;
+ runtime("$obj->{nv} = $expr;");
+ $obj->{flags} &= ~(VALID_SV | VALID_INT);
+ $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub set_numeric {
+ my ($obj, $expr) = @_;
+ if ($obj->{type} == T_INT) {
+ $obj->set_int($expr);
+ } else {
+ $obj->set_double($expr);
+ }
+}
+
+sub set_sv {
+ my ($obj, $expr) = @_;
+ runtime("SvSetSV($obj->{sv}, $expr);");
+ $obj->invalidate;
+ $obj->{flags} |= VALID_SV;
+}
+
+#
+# Stackobj::Padsv
+#
+
+@B::Stackobj::Padsv::ISA = 'B::Stackobj';
+sub B::Stackobj::Padsv::new {
+ my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
+ bless {
+ type => $type,
+ flags => VALID_SV | $extra_flags,
+ sv => "PL_curpad[$ix]",
+ iv => "$iname",
+ nv => "$dname"
+ }, $class;
+}
+
+sub B::Stackobj::Padsv::load_int {
+ my $obj = shift;
+ if ($obj->{flags} & VALID_DOUBLE) {
+ runtime("$obj->{iv} = $obj->{nv};");
+ } else {
+ runtime("$obj->{iv} = SvIV($obj->{sv});");
+ }
+ $obj->{flags} |= VALID_INT;
+}
+
+sub B::Stackobj::Padsv::load_double {
+ my $obj = shift;
+ $obj->write_back;
+ runtime("$obj->{nv} = SvNV($obj->{sv});");
+ $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub B::Stackobj::Padsv::write_back {
+ my $obj = shift;
+ my $flags = $obj->{flags};
+ return if $flags & VALID_SV;
+ if ($flags & VALID_INT) {
+ runtime("sv_setiv($obj->{sv}, $obj->{iv});");
+ } elsif ($flags & VALID_DOUBLE) {
+ runtime("sv_setnv($obj->{sv}, $obj->{nv});");
+ } else {
+ confess "write_back failed for lexical @{[$obj->peek]}\n";
+ }
+ $obj->{flags} |= VALID_SV;
+}
+
+#
+# Stackobj::Const
+#
+
+@B::Stackobj::Const::ISA = 'B::Stackobj';
+sub B::Stackobj::Const::new {
+ my ($class, $sv) = @_;
+ my $obj = bless {
+ flags => 0,
+ sv => $sv # holds the SV object until write_back happens
+ }, $class;
+ my $svflags = $sv->FLAGS;
+ if ($svflags & SVf_IOK) {
+ $obj->{flags} = VALID_INT|VALID_DOUBLE;
+ $obj->{type} = T_INT;
+ $obj->{nv} = $obj->{iv} = $sv->IV;
+ } elsif ($svflags & SVf_NOK) {
+ $obj->{flags} = VALID_INT|VALID_DOUBLE;
+ $obj->{type} = T_DOUBLE;
+ $obj->{iv} = $obj->{nv} = $sv->NV;
+ } else {
+ $obj->{type} = T_UNKNOWN;
+ }
+ return $obj;
+}
+
+sub B::Stackobj::Const::write_back {
+ my $obj = shift;
+ return if $obj->{flags} & VALID_SV;
+ # Save the SV object and replace $obj->{sv} by its C source code name
+ $obj->{sv} = $obj->{sv}->save;
+ $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
+}
+
+sub B::Stackobj::Const::load_int {
+ my $obj = shift;
+ $obj->{iv} = int($obj->{sv}->PV);
+ $obj->{flags} |= VALID_INT;
+}
+
+sub B::Stackobj::Const::load_double {
+ my $obj = shift;
+ $obj->{nv} = $obj->{sv}->PV + 0.0;
+ $obj->{flags} |= VALID_DOUBLE;
+}
+
+sub B::Stackobj::Const::invalidate {}
+
+#
+# Stackobj::Bool
+#
+
+@B::Stackobj::Bool::ISA = 'B::Stackobj';
+sub B::Stackobj::Bool::new {
+ my ($class, $preg) = @_;
+ my $obj = bless {
+ type => T_INT,
+ flags => VALID_INT|VALID_DOUBLE,
+ iv => $$preg,
+ nv => $$preg,
+ preg => $preg # this holds our ref to the pseudo-reg
+ }, $class;
+ return $obj;
+}
+
+sub B::Stackobj::Bool::write_back {
+ my $obj = shift;
+ return if $obj->{flags} & VALID_SV;
+ $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
+ $obj->{flags} |= VALID_SV;
+}
+
+# XXX Might want to handle as_double/set_double/load_double?
+
+sub B::Stackobj::Bool::invalidate {}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Stackobj - Helper module for CC backend
+
+=head1 SYNOPSIS
+
+ use B::Stackobj;
+
+=head1 DESCRIPTION
+
+See F<ext/B/README>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/Terse.pm b/contrib/perl5/ext/B/B/Terse.pm
new file mode 100644
index 000000000000..93757f34ce88
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Terse.pm
@@ -0,0 +1,152 @@
+package B::Terse;
+use strict;
+use B qw(peekop class walkoptree_slow walkoptree_exec
+ main_start main_root cstring svref_2object);
+use B::Asmdata qw(@specialsv_name);
+
+sub terse {
+ my ($order, $cvref) = @_;
+ my $cv = svref_2object($cvref);
+ if ($order eq "exec") {
+ walkoptree_exec($cv->START, "terse");
+ } else {
+ walkoptree_slow($cv->ROOT, "terse");
+ }
+}
+
+sub compile {
+ my $order = shift;
+ my @options = @_;
+ if (@options) {
+ return sub {
+ my $objname;
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "terse(\$order, \\&$objname)";
+ die "terse($order, \\&$objname) failed: $@" if $@;
+ }
+ }
+ } else {
+ if ($order eq "exec") {
+ return sub { walkoptree_exec(main_start, "terse") }
+ } else {
+ return sub { walkoptree_slow(main_root, "terse") }
+ }
+ }
+}
+
+sub indent {
+ my $level = shift;
+ return " " x $level;
+}
+
+sub B::OP::terse {
+ my ($op, $level) = @_;
+ my $targ = $op->targ;
+ $targ = ($targ > 0) ? " [$targ]" : "";
+ print indent($level), peekop($op), $targ, "\n";
+}
+
+sub B::SVOP::terse {
+ my ($op, $level) = @_;
+ print indent($level), peekop($op), " ";
+ $op->sv->terse(0);
+}
+
+sub B::GVOP::terse {
+ my ($op, $level) = @_;
+ print indent($level), peekop($op), " ";
+ $op->gv->terse(0);
+}
+
+sub B::PMOP::terse {
+ my ($op, $level) = @_;
+ my $precomp = $op->precomp;
+ print indent($level), peekop($op),
+ defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n";
+
+}
+
+sub B::PVOP::terse {
+ my ($op, $level) = @_;
+ print indent($level), peekop($op), " ", cstring($op->pv), "\n";
+}
+
+sub B::COP::terse {
+ my ($op, $level) = @_;
+ my $label = $op->label;
+ if ($label) {
+ $label = " label ".cstring($label);
+ }
+ print indent($level), peekop($op), $label, "\n";
+}
+
+sub B::PV::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV);
+}
+
+sub B::AV::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL;
+}
+
+sub B::GV::terse {
+ my ($gv, $level) = @_;
+ my $stash = $gv->STASH->NAME;
+ if ($stash eq "main") {
+ $stash = "";
+ } else {
+ $stash = $stash . "::";
+ }
+ print indent($level);
+ printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME;
+}
+
+sub B::IV::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV;
+}
+
+sub B::NV::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV;
+}
+
+sub B::NULL::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s (0x%lx)\n", class($sv), $$sv;
+}
+
+sub B::SPECIAL::terse {
+ my ($sv, $level) = @_;
+ print indent($level);
+ printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv];
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Terse - Walk Perl syntax tree, printing terse info about ops
+
+=head1 SYNOPSIS
+
+ perl -MO=Terse[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+See F<ext/B/README>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/B/Xref.pm b/contrib/perl5/ext/B/B/Xref.pm
new file mode 100644
index 000000000000..0102856919ac
--- /dev/null
+++ b/contrib/perl5/ext/B/B/Xref.pm
@@ -0,0 +1,392 @@
+package B::Xref;
+
+=head1 NAME
+
+B::Xref - Generates cross reference reports for Perl programs
+
+=head1 SYNOPSIS
+
+perl -MO=Xref[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+The B::Xref module is used to generate a cross reference listing of all
+definitions and uses of variables, subroutines and formats in a Perl program.
+It is implemented as a backend for the Perl compiler.
+
+The report generated is in the following format:
+
+ File filename1
+ Subroutine subname1
+ Package package1
+ object1 C<line numbers>
+ object2 C<line numbers>
+ ...
+ Package package2
+ ...
+
+Each B<File> section reports on a single file. Each B<Subroutine> section
+reports on a single subroutine apart from the special cases
+"(definitions)" and "(main)". These report, respectively, on subroutine
+definitions found by the initial symbol table walk and on the main part of
+the program or module external to all subroutines.
+
+The report is then grouped by the B<Package> of each variable,
+subroutine or format with the special case "(lexicals)" meaning
+lexical variables. Each B<object> name (implicitly qualified by its
+containing B<Package>) includes its type character(s) at the beginning
+where possible. Lexical variables are easier to track and even
+included dereferencing information where possible.
+
+The C<line numbers> are a comma separated list of line numbers (some
+preceded by code letters) where that object is used in some way.
+Simple uses aren't preceded by a code letter. Introductions (such as
+where a lexical is first defined with C<my>) are indicated with the
+letter "i". Subroutine and method calls are indicated by the character
+"&". Subroutine definitions are indicated by "s" and format
+definitions by "f".
+
+=head1 OPTIONS
+
+Option words are separated by commas (not whitespace) and follow the
+usual conventions of compiler backend options.
+
+=over 8
+
+=item C<-oFILENAME>
+
+Directs output to C<FILENAME> instead of standard output.
+
+=item C<-r>
+
+Raw output. Instead of producing a human-readable report, outputs a line
+in machine-readable form for each definition/use of a variable/sub/format.
+
+=item C<-D[tO]>
+
+(Internal) debug options, probably only useful if C<-r> included.
+The C<t> option prints the object on the top of the stack as it's
+being tracked. The C<O> option prints each operator as it's being
+processed in the execution order of the program.
+
+=back
+
+=head1 BUGS
+
+Non-lexical variables are quite difficult to track through a program.
+Sometimes the type of a non-lexical variable's use is impossible to
+determine. Introductions of non-lexical non-scalars don't seem to be
+reported properly.
+
+=head1 AUTHOR
+
+Malcolm Beattie, mbeattie@sable.ox.ac.uk.
+
+=cut
+
+use strict;
+use B qw(peekop class comppadlist main_start svref_2object walksymtable);
+
+# Constants (should probably be elsewhere)
+sub OPpLVAL_INTRO () { 128 }
+sub SVf_POK () { 0x40000 }
+
+sub UNKNOWN { ["?", "?", "?"] }
+
+my @pad; # lexicals in current pad
+ # as ["(lexical)", type, name]
+my %done; # keyed by $$op: set when each $op is done
+my $top = UNKNOWN; # shadows top element of stack as
+ # [pack, type, name] (pack can be "(lexical)")
+my $file; # shadows current filename
+my $line; # shadows current line number
+my $subname; # shadows current sub name
+my %table; # Multi-level hash to record all uses etc.
+my @todo = (); # List of CVs that need processing
+
+my %code = (intro => "i", used => "",
+ subdef => "s", subused => "&",
+ formdef => "f", meth => "->");
+
+
+# Options
+my ($debug_op, $debug_top, $nodefs, $raw);
+
+sub process {
+ my ($var, $event) = @_;
+ my ($pack, $type, $name) = @$var;
+ if ($type eq "*") {
+ if ($event eq "used") {
+ return;
+ } elsif ($event eq "subused") {
+ $type = "&";
+ }
+ }
+ $type =~ s/(.)\*$/$1/g;
+ if ($raw) {
+ printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
+ $file, $subname, $line, $pack, $type, $name, $event;
+ } else {
+ # Wheee
+ push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
+ $line);
+ }
+}
+
+sub load_pad {
+ my $padlist = shift;
+ my ($namelistav, @namelist, $ix);
+ @pad = ();
+ return if class($padlist) eq "SPECIAL";
+ ($namelistav) = $padlist->ARRAY;
+ @namelist = $namelistav->ARRAY;
+ for ($ix = 1; $ix < @namelist; $ix++) {
+ my $namesv = $namelist[$ix];
+ next if class($namesv) eq "SPECIAL";
+ my ($type, $name) = $namesv->PV =~ /^(.)(.*)$/;
+ $pad[$ix] = ["(lexical)", $type, $name];
+ }
+}
+
+sub xref {
+ my $start = shift;
+ my $op;
+ for ($op = $start; $$op; $op = $op->next) {
+ last if $done{$$op}++;
+ warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
+ warn peekop($op), "\n" if $debug_op;
+ my $ppname = $op->ppaddr;
+ if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile)$/) {
+ xref($op->other);
+ } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
+ xref($op->pmreplstart);
+ } elsif ($ppname eq "pp_substcont") {
+ xref($op->other->pmreplstart);
+ $op = $op->other;
+ redo;
+ } elsif ($ppname eq "pp_cond_expr") {
+ # pp_cond_expr never returns op_next
+ xref($op->true);
+ $op = $op->false;
+ redo;
+ } elsif ($ppname eq "pp_enterloop") {
+ xref($op->redoop);
+ xref($op->nextop);
+ xref($op->lastop);
+ } elsif ($ppname eq "pp_subst") {
+ xref($op->pmreplstart);
+ } else {
+ no strict 'refs';
+ &$ppname($op) if defined(&$ppname);
+ }
+ }
+}
+
+sub xref_cv {
+ my $cv = shift;
+ my $pack = $cv->GV->STASH->NAME;
+ $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
+ load_pad($cv->PADLIST);
+ xref($cv->START);
+ $subname = "(main)";
+}
+
+sub xref_object {
+ my $cvref = shift;
+ xref_cv(svref_2object($cvref));
+}
+
+sub xref_main {
+ $subname = "(main)";
+ load_pad(comppadlist);
+ xref(main_start);
+ while (@todo) {
+ xref_cv(shift @todo);
+ }
+}
+
+sub pp_nextstate {
+ my $op = shift;
+ $file = $op->filegv->SV->PV;
+ $line = $op->line;
+ $top = UNKNOWN;
+}
+
+sub pp_padsv {
+ my $op = shift;
+ $top = $pad[$op->targ];
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_padav { pp_padsv(@_) }
+sub pp_padhv { pp_padsv(@_) }
+
+sub deref {
+ my ($var, $as) = @_;
+ $var->[1] = $as . $var->[1];
+ process($var, "used");
+}
+
+sub pp_rv2cv { deref($top, "&"); }
+sub pp_rv2hv { deref($top, "%"); }
+sub pp_rv2sv { deref($top, "\$"); }
+sub pp_rv2av { deref($top, "\@"); }
+sub pp_rv2gv { deref($top, "*"); }
+
+sub pp_gvsv {
+ my $op = shift;
+ my $gv = $op->gv;
+ $top = [$gv->STASH->NAME, '$', $gv->NAME];
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_gv {
+ my $op = shift;
+ my $gv = $op->gv;
+ $top = [$gv->STASH->NAME, "*", $gv->NAME];
+ process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
+}
+
+sub pp_const {
+ my $op = shift;
+ my $sv = $op->sv;
+ $top = ["?", "",
+ (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) ? $sv->PV : "?"];
+}
+
+sub pp_method {
+ my $op = shift;
+ $top = ["(method)", "->".$top->[1], $top->[2]];
+}
+
+sub pp_entersub {
+ my $op = shift;
+ if ($top->[1] eq "m") {
+ process($top, "meth");
+ } else {
+ process($top, "subused");
+ }
+ $top = UNKNOWN;
+}
+
+#
+# Stuff for cross referencing definitions of variables and subs
+#
+
+sub B::GV::xref {
+ my $gv = shift;
+ my $cv = $gv->CV;
+ if ($$cv) {
+ #return if $done{$$cv}++;
+ $file = $gv->FILEGV->SV->PV;
+ $line = $gv->LINE;
+ process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
+ push(@todo, $cv);
+ }
+ my $form = $gv->FORM;
+ if ($$form) {
+ return if $done{$$form}++;
+ $file = $gv->FILEGV->SV->PV;
+ $line = $gv->LINE;
+ process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
+ }
+}
+
+sub xref_definitions {
+ my ($pack, %exclude);
+ return if $nodefs;
+ $subname = "(definitions)";
+ foreach $pack (qw(B O AutoLoader DynaLoader Config DB VMS
+ strict vars FileHandle Exporter Carp)) {
+ $exclude{$pack."::"} = 1;
+ }
+ no strict qw(vars refs);
+ walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
+}
+
+sub output {
+ return if $raw;
+ my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
+ $perpack, $pername, $perev);
+ foreach $file (sort(keys(%table))) {
+ $perfile = $table{$file};
+ print "File $file\n";
+ foreach $subname (sort(keys(%$perfile))) {
+ $persubname = $perfile->{$subname};
+ print " Subroutine $subname\n";
+ foreach $pack (sort(keys(%$persubname))) {
+ $perpack = $persubname->{$pack};
+ print " Package $pack\n";
+ foreach $name (sort(keys(%$perpack))) {
+ $pername = $perpack->{$name};
+ my @lines;
+ foreach $ev (qw(intro formdef subdef meth subused used)) {
+ $perev = $pername->{$ev};
+ if (defined($perev) && @$perev) {
+ my $code = $code{$ev};
+ push(@lines, map("$code$_", @$perev));
+ }
+ }
+ printf " %-16s %s\n", $name, join(", ", @lines);
+ }
+ }
+ }
+ }
+}
+
+sub compile {
+ my @options = @_;
+ my ($option, $opt, $arg);
+ OPTION:
+ while ($option = shift @options) {
+ if ($option =~ /^-(.)(.*)/) {
+ $opt = $1;
+ $arg = $2;
+ } else {
+ unshift @options, $option;
+ last OPTION;
+ }
+ if ($opt eq "-" && $arg eq "-") {
+ shift @options;
+ last OPTION;
+ } elsif ($opt eq "o") {
+ $arg ||= shift @options;
+ open(STDOUT, ">$arg") or return "$arg: $!\n";
+ } elsif ($opt eq "d") {
+ $nodefs = 1;
+ } elsif ($opt eq "r") {
+ $raw = 1;
+ } elsif ($opt eq "D") {
+ $arg ||= shift @options;
+ foreach $arg (split(//, $arg)) {
+ if ($arg eq "o") {
+ B->debug(1);
+ } elsif ($arg eq "O") {
+ $debug_op = 1;
+ } elsif ($arg eq "t") {
+ $debug_top = 1;
+ }
+ }
+ }
+ }
+ if (@options) {
+ return sub {
+ my $objname;
+ xref_definitions();
+ foreach $objname (@options) {
+ $objname = "main::$objname" unless $objname =~ /::/;
+ eval "xref_object(\\&$objname)";
+ die "xref_object(\\&$objname) failed: $@" if $@;
+ }
+ output();
+ }
+ } else {
+ return sub {
+ xref_definitions();
+ xref_main();
+ output();
+ }
+ }
+}
+
+1;
diff --git a/contrib/perl5/ext/B/B/assemble b/contrib/perl5/ext/B/B/assemble
new file mode 100755
index 000000000000..43cc5bc4b33d
--- /dev/null
+++ b/contrib/perl5/ext/B/B/assemble
@@ -0,0 +1,30 @@
+use B::Assembler qw(assemble_fh);
+use FileHandle;
+
+my ($filename, $fh, $out);
+
+if ($ARGV[0] eq "-d") {
+ B::Assembler::debug(1);
+ shift;
+}
+
+$out = \*STDOUT;
+
+if (@ARGV == 0) {
+ $fh = \*STDIN;
+ $filename = "-";
+} elsif (@ARGV == 1) {
+ $filename = $ARGV[0];
+ $fh = new FileHandle "<$filename";
+} elsif (@ARGV == 2) {
+ $filename = $ARGV[0];
+ $fh = new FileHandle "<$filename";
+ $out = new FileHandle ">$ARGV[1]";
+} else {
+ die "Usage: assemble [filename] [outfilename]\n";
+}
+
+binmode $out;
+$SIG{__WARN__} = sub { warn "$filename:@_" };
+$SIG{__DIE__} = sub { die "$filename: @_" };
+assemble_fh($fh, sub { print $out @_ });
diff --git a/contrib/perl5/ext/B/B/cc_harness b/contrib/perl5/ext/B/B/cc_harness
new file mode 100644
index 000000000000..79f8727a8f02
--- /dev/null
+++ b/contrib/perl5/ext/B/B/cc_harness
@@ -0,0 +1,12 @@
+use Config;
+
+$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE";
+
+if (!grep(/^-[cS]$/, @ARGV)) {
+ $linkargs = sprintf("%s $libdir/$Config{libperl} %s",
+ @Config{qw(ldflags libs)});
+}
+
+$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs";
+print "$cccmd\n";
+exec $cccmd;
diff --git a/contrib/perl5/ext/B/B/disassemble b/contrib/perl5/ext/B/B/disassemble
new file mode 100755
index 000000000000..6530b809502f
--- /dev/null
+++ b/contrib/perl5/ext/B/B/disassemble
@@ -0,0 +1,22 @@
+use B::Disassembler qw(disassemble_fh);
+use FileHandle;
+
+my $fh;
+if (@ARGV == 0) {
+ $fh = \*STDIN;
+} elsif (@ARGV == 1) {
+ $fh = new FileHandle "<$ARGV[0]";
+} else {
+ die "Usage: disassemble [filename]\n";
+}
+
+sub print_insn {
+ my ($insn, $arg) = @_;
+ if (defined($arg)) {
+ printf "%s %s\n", $insn, $arg;
+ } else {
+ print $insn, "\n";
+ }
+}
+
+disassemble_fh($fh, \&print_insn);
diff --git a/contrib/perl5/ext/B/B/makeliblinks b/contrib/perl5/ext/B/B/makeliblinks
new file mode 100644
index 000000000000..82560783c01c
--- /dev/null
+++ b/contrib/perl5/ext/B/B/makeliblinks
@@ -0,0 +1,54 @@
+use File::Find;
+use Config;
+
+if (@ARGV != 2) {
+ warn <<"EOT";
+Usage: makeliblinks libautodir targetdir
+where libautodir is the architecture-dependent auto directory
+(e.g. $Config::Config{archlib}/auto).
+EOT
+ exit 2;
+}
+
+my ($libautodir, $targetdir) = @ARGV;
+
+# Calculate relative path prefix from $targetdir to $libautodir
+sub relprefix {
+ my ($to, $from) = @_;
+ my $up;
+ for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) {
+ $from =~ s(
+ [^/]+ (?# a group of non-slashes)
+ /* (?# maybe with some trailing slashes)
+ $ (?# at the end of the path)
+ )()x;
+ }
+ return (("../" x $up) . substr($to, length($from)));
+}
+
+my $relprefix = relprefix($libautodir, $targetdir);
+
+my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)};
+
+sub link_if_library {
+ if (/\.($dlext|$lib_ext)$/o) {
+ my $ext = $1;
+ my $name = $File::Find::name;
+ if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") {
+ die "directory of $name doesn't match $libautodir\n";
+ }
+ substr($name, 0, length($libautodir) + 1) = '';
+ my @parts = split(m(/), $name);
+ if ($parts[-1] ne "$parts[-2].$ext") {
+ die "module name $_ doesn't match its directory $libautodir\n";
+ }
+ pop @parts;
+ my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext";
+ print "$libpath -> $relprefix/$name\n";
+ symlink("$relprefix/$name", $libpath)
+ or warn "above link failed with error: $!\n";
+ }
+}
+
+find(\&link_if_library, $libautodir);
+exit 0;
diff --git a/contrib/perl5/ext/B/Makefile.PL b/contrib/perl5/ext/B/Makefile.PL
new file mode 100644
index 000000000000..cdcc4ed71b41
--- /dev/null
+++ b/contrib/perl5/ext/B/Makefile.PL
@@ -0,0 +1,46 @@
+use ExtUtils::MakeMaker;
+use Config;
+
+my $e = $Config{'exe_ext'};
+my $o = $Config{'obj_ext'};
+my $exeout_flag = '-o ';
+if ($^O eq 'MSWin32') {
+ if ($Config{'cc'} =~ /^cl/i) {
+ $exeout_flag = '-Fe';
+ }
+ elsif ($Config{'cc'} =~ /^bcc/i) {
+ $exeout_flag = '-e';
+ }
+}
+
+WriteMakefile(
+ NAME => "B",
+ VERSION => "a5",
+ MAN3PODS => ' ',
+ clean => {
+ FILES => "perl$e byteperl$e *$o B.c *~"
+ }
+);
+
+sub MY::post_constants {
+ "\nLIBS = $Config{libs}\n"
+}
+
+# Leave out doing byteperl for now. Probably should be built in the
+# core directory or somewhere else rather than here
+#sub MY::top_targets {
+# my $self = shift;
+# my $targets = $self->MM::top_targets();
+# $targets =~ s/^(all ::.*)$/$1 byteperl$e/m;
+# return <<"EOT" . $targets;
+
+#
+# byteperl is *not* a standard perl+XSUB executable. It's a special
+# program for running standalone bytecode executables. It isn't an XSUB
+# at the moment because a standlone Perl program needs to set up curpad
+# which is overwritten on exit from an XSUB.
+#
+#byteperl$e : byteperl$o B$o \$(PERL_SRC)/byterun$o
+# \$(CC) ${exeout_flag}byteperl$e byteperl$o B$o byterun$o \$(LDFLAGS) \$(PERL_ARCHLIB)/CORE/$Config{libperl} \$(LIBS)
+#EOT
+#}
diff --git a/contrib/perl5/ext/B/NOTES b/contrib/perl5/ext/B/NOTES
new file mode 100644
index 000000000000..ee10ba03e974
--- /dev/null
+++ b/contrib/perl5/ext/B/NOTES
@@ -0,0 +1,168 @@
+C backend invocation
+ If there are any non-option arguments, they are taken to be
+ names of objects to be saved (probably doesn't work properly yet).
+ Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT
+ -v Verbose (currently gives a few compilation statistics)
+ -- Force end of options
+ -uPackname Force apparently unused subs from package Packname to
+ be compiled. This allows programs to use eval "foo()"
+ even when sub foo is never seen to be used at compile
+ time. The down side is that any subs which really are
+ never used also have code generated. This option is
+ necessary, for example, if you have a signal handler
+ foo which you initialise with $SIG{BAR} = "foo".
+ A better fix, though, is just to change it to
+ $SIG{BAR} = \&foo. You can have multiple -u options.
+ -D Debug options (concat or separate flags like perl -D)
+ o OPs, prints each OP as it's processed
+ c COPs, prints COPs as processed (incl. file & line num)
+ A prints AV information on saving
+ C prints CV information on saving
+ M prints MAGIC information on saving
+ -f Force optimisations on or off one at a time.
+ cog Copy-on-grow: PVs declared and initialised statically
+ no-cog No copy-on-grow
+ -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+ Currently, -O1 and higher set -fcog.
+
+Examples
+ perl -MO=C foo.pl > foo.c
+ perl cc_harness -o foo foo.c
+
+ perl -MO=C,-v,-DcA bar.pl > /dev/null
+
+CC backend invocation
+ If there are any non-option arguments, they are taken to be names of
+ subs to be saved. Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT
+ -- Force end of options
+ -uPackname Force apparently unused subs from package Packname to
+ be compiled. This allows programs to use eval "foo()"
+ even when sub foo is never seen to be used at compile
+ time. The down side is that any subs which really are
+ never used also have code generated. This option is
+ necessary, for example, if you have a signal handler
+ foo which you initialise with $SIG{BAR} = "foo".
+ A better fix, though, is just to change it to
+ $SIG{BAR} = \&foo. You can have multiple -u options.
+ -mModulename Instead of generating source for a runnable executable,
+ generate source for an XSUB module. The
+ boot_Modulename function (which DynaLoader can look
+ for) does the appropriate initialisation and runs the
+ main part of the Perl source that is being compiled.
+ -pn Generate code for perl patchlevel n (e.g. 3 or 4).
+ The default is to generate C code which will link
+ with the currently executing version of perl.
+ running the perl compiler.
+ -D Debug options (concat or separate flags like perl -D)
+ r Writes debugging output to STDERR just as it's about
+ to write to the program's runtime (otherwise writes
+ debugging info as comments in its C output).
+ O Outputs each OP as it's compiled
+ s Outputs the contents of the shadow stack at each OP
+ p Outputs the contents of the shadow pad of lexicals as
+ it's loaded for each sub or the main program.
+ q Outputs the name of each fake PP function in the queue
+ as it's about to processes.
+ l Output the filename and line number of each original
+ line of Perl code as it's processed (pp_nextstate).
+ t Outputs timing information of compilation stages
+ -f Force optimisations on or off one at a time.
+ [
+ cog Copy-on-grow: PVs declared and initialised statically
+ no-cog No copy-on-grow
+ These two not in CC yet.
+ ]
+ freetmps-each-bblock Delays FREETMPS from the end of each
+ statement to the end of the each basic
+ block.
+ freetmps-each-loop Delays FREETMPS from the end of each
+ statement to the end of the group of
+ basic blocks forming a loop. At most
+ one of the freetmps-each-* options can
+ be used.
+ omit-taint Omits generating code for handling
+ perl's tainting mechanism.
+ -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+ Currently, -O1 sets -ffreetmps-each-bblock and -O2
+ sets -ffreetmps-each-loop.
+
+Example
+ perl -MO=CC,-O2,-ofoo.c foo.pl
+ perl cc_harness -o foo foo.c
+
+ perl -MO=CC,-mFoo,-oFoo.c Foo.pm
+ perl cc_harness -shared -c -o Foo.so Foo.c
+
+
+Bytecode backend invocation
+
+ If there are any non-option arguments, they are taken to be
+ names of objects to be saved (probably doesn't work properly yet).
+ Without extra arguments, it saves the main program.
+ -ofilename Output to filename instead of STDOUT.
+ -- Force end of options.
+ -f Force optimisations on or off one at a time.
+ Each can be preceded by no- to turn the option off.
+ compress-nullops
+ Only fills in the necessary fields of ops which have
+ been optimised away by perl's internal compiler.
+ omit-sequence-numbers
+ Leaves out code to fill in the op_seq field of all ops
+ which is only used by perl's internal compiler.
+ bypass-nullops
+ If op->op_next ever points to a NULLOP, replaces the
+ op_next field with the first non-NULLOP in the path
+ of execution.
+ strip-syntax-tree
+ Leaves out code to fill in the pointers which link the
+ internal syntax tree together. They're not needed at
+ run-time but leaving them out will make it impossible
+ to recompile or disassemble the resulting program.
+ It will also stop "goto label" statements from working.
+ -On Optimisation level (n = 0, 1, 2, ...). -O means -O1.
+ -O1 sets -fcompress-nullops -fomit-sequence numbers.
+ -O6 adds -fstrip-syntax-tree.
+ -D Debug options (concat or separate flags like perl -D)
+ o OPs, prints each OP as it's processed.
+ b print debugging information about bytecompiler progress
+ a tells the assembler to include source assembler lines
+ in its output as bytecode comments.
+ C prints each CV taken from the final symbol tree walk.
+ -S Output assembler source rather than piping it
+ through the assembler and outputting bytecode.
+ -m Compile as a module rather than a standalone program.
+ Currently this just means that the bytecodes for
+ initialising main_start, main_root and curpad are
+ omitted.
+
+Example
+ perl -MO=Bytecode,-O6,-o,foo.plc foo.pl
+
+ perl -MO=Bytecode,-S foo.pl > foo.S
+ assemble foo.S > foo.plc
+ byteperl foo.plc
+
+ perl -MO=Bytecode,-m,-oFoo.pmc Foo.pm
+
+Backends for debugging
+ perl -MO=Terse,exec foo.pl
+ perl -MO=Debug bar.pl
+
+O module
+ Used with "perl -MO=Backend,foo,bar prog.pl" to invoke the backend
+ B::Backend with options foo and bar. O invokes the sub
+ B::Backend::compile() with arguments foo and bar at BEGIN time.
+ That compile() sub must do any inital argument processing replied.
+ If unsuccessful, it should return a string which O arranges to be
+ printed as an error message followed by a clean error exit. In the
+ normal case where any option processing in compile() is successful,
+ it should return a sub ref (usually a closure) to perform the
+ actual compilation. When O regains control, it ensures that the
+ "-c" option is forced (so that the program being compiled doesn't
+ end up running) and registers an END block to call back the sub ref
+ returned from the backend's compile(). Perl then continues by
+ parsing prog.pl (just as it would with "perl -c prog.pl") and after
+ doing so, assuming there are no parse-time errors, the END block
+ of O gets called and the actual backend compilation happens. Phew.
diff --git a/contrib/perl5/ext/B/O.pm b/contrib/perl5/ext/B/O.pm
new file mode 100644
index 000000000000..ad391a3f4a4f
--- /dev/null
+++ b/contrib/perl5/ext/B/O.pm
@@ -0,0 +1,85 @@
+package O;
+use B qw(minus_c);
+use Carp;
+
+sub import {
+ my ($class, $backend, @options) = @_;
+ eval "use B::$backend ()";
+ if ($@) {
+ croak "use of backend $backend failed: $@";
+ }
+ my $compilesub = &{"B::${backend}::compile"}(@options);
+ if (ref($compilesub) eq "CODE") {
+ minus_c;
+ eval 'END { &$compilesub() }';
+ } else {
+ die $compilesub;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+O - Generic interface to Perl Compiler backends
+
+=head1 SYNOPSIS
+
+ perl -MO=Backend[,OPTIONS] foo.pl
+
+=head1 DESCRIPTION
+
+This is the module that is used as a frontend to the Perl Compiler.
+
+=head1 CONVENTIONS
+
+Most compiler backends use the following conventions: OPTIONS
+consists of a comma-separated list of words (no white-space).
+The C<-v> option usually puts the backend into verbose mode.
+The C<-ofile> option generates output to B<file> instead of
+stdout. The C<-D> option followed by various letters turns on
+various internal debugging flags. See the documentation for the
+desired backend (named C<B::Backend> for the example above) to
+find out about that backend.
+
+=head1 IMPLEMENTATION
+
+This section is only necessary for those who want to write a
+compiler backend module that can be used via this module.
+
+The command-line mentioned in the SYNOPSIS section corresponds to
+the Perl code
+
+ use O ("Backend", OPTIONS);
+
+The C<import> function which that calls loads in the appropriate
+C<B::Backend> module and calls the C<compile> function in that
+package, passing it OPTIONS. That function is expected to return
+a sub reference which we'll call CALLBACK. Next, the "compile-only"
+flag is switched on (equivalent to the command-line option C<-c>)
+and an END block is registered which calls CALLBACK. Thus the main
+Perl program mentioned on the command-line is read in, parsed and
+compiled into internal syntax tree form. Since the C<-c> flag is
+set, the program does not start running (excepting BEGIN blocks of
+course) but the CALLBACK function registered by the compiler
+backend is called.
+
+In summary, a compiler backend module should be called "B::Foo"
+for some foo and live in the appropriate directory for that name.
+It should define a function called C<compile>. When the user types
+
+ perl -MO=Foo,OPTIONS foo.pl
+
+that function is called and is passed those OPTIONS (split on
+commas). It should return a sub ref to the main compilation function.
+After the user's program is loaded and parsed, that returned sub ref
+is invoked which can then go ahead and do the compilation, usually by
+making use of the C<B> module's functionality.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
diff --git a/contrib/perl5/ext/B/README b/contrib/perl5/ext/B/README
new file mode 100644
index 000000000000..4e4ed25fdcc5
--- /dev/null
+++ b/contrib/perl5/ext/B/README
@@ -0,0 +1,325 @@
+ Perl Compiler Kit, Version alpha4
+
+ Copyright (c) 1996, 1997, Malcolm Beattie
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this kit.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
+ the GNU General Public License or the Artistic License for more details.
+
+ You should have received a copy of the Artistic License with this kit,
+ in the file named "Artistic". If not, you can get one from the Perl
+ distribution. You should also have received a copy of the GNU General
+ Public License, in the file named "Copying". If not, you can get one
+ from the Perl distribution or else write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+CHANGES
+
+New since alpha3
+ Anonymous subs work properly with C and CC.
+ Heuristics for forcing compilation of apparently unused subs/methods.
+ Subs which use the AutoLoader module are forcibly loaded at compile-time.
+ Slightly faster compilation.
+ Handles slightly more complex code within a BEGIN { }.
+ Minor bug fixes.
+
+New since alpha2
+ CC backend now supports ".." and s//e.
+ Xref backend generates cross-reference reports
+ Cleanups to fix benign but irritating "-w" warnings
+ Minor cxstack fix
+New since alpha1
+ Working CC backend
+ Shared globs and pre-initialised hash support
+ Some XSUB support
+ Assorted bug fixes
+
+INSTALLATION
+
+(1) You need perl5.002 or later.
+
+(2) If you want to compile and run programs with the C or CC backends
+which undefine (or redefine) subroutines, then you need to apply a
+one-line patch to perl itself. One or two of the programs in perl's
+own test suite do this. The patch is in file op.patch. It prevents
+perl from calling free() on OPs with the magic sequence number (U16)-1.
+The compiler declares all OPs as static structures and uses that magic
+sequence number.
+
+(3) Type
+ perl Makefile.PL
+to write a personalised Makefile for your system. If you want the
+bytecode modules to support reading bytecode from strings (instead of
+just from files) then add the option
+ -DINDIRECT_BGET_MACROS
+into the middle of the definition of the CCCMD macro in the Makefile.
+Your C compiler may need to be able to cope with Standard C for this.
+I haven't tested this option yet with an old pre-Standard compiler.
+
+(4) If your platform supports dynamic loading then just type
+ make
+and you can then use
+ perl -Iblib/arch -MO=foo bar
+to use the compiler modules (see later for details).
+If you need/want instead to make a statically linked perl which
+contains the appropriate modules, then type
+ make perl
+ make byteperl
+and you can then use
+ ./perl -MO=foo bar
+to use the compiler modules.
+In both cases, the byteperl executable is required for running standalone
+bytecode programs. It is *not* a standard perl+XSUB perl executable.
+
+USAGE
+
+As of the alpha3 release, the Bytecode, C and CC backends are now all
+functional enough to compile almost the whole of the main perl test
+suite. In the case of the CC backend, any failures are all due to
+differences and/or known bugs documented below. See the file TESTS.
+In the following examples, you'll need to replace "perl" by
+ perl -Iblib/arch
+if you have built the extensions for a dynamic loading platform but
+haven't installed the extensions completely. You'll need to replace
+"perl" by
+ ./perl
+if you have built the extensions into a statically linked perl binary.
+
+(1) To compile perl program foo.pl with the C backend, do
+ perl -MO=C,-ofoo.c foo.pl
+Then use the cc_harness perl program to compile the resulting C source:
+ perl cc_harness -O2 -o foo foo.c
+
+If you are using a non-ANSI pre-Standard C compiler that can't handle
+pre-declaring static arrays, then add -DBROKEN_STATIC_REDECL to the
+options you use:
+ perl cc_harness -O2 -o foo -DBROKEN_STATIC_REDECL foo.c
+If you are using a non-ANSI pre-Standard C compiler that can't handle
+static initialisation of structures with union members then add
+-DBROKEN_UNION_INIT to the options you use. If you want command line
+arguments passed to your executable to be interpreted by perl (e.g. -Dx)
+then compile foo.c with -DALLOW_PERL_OPTIONS. Otherwise, all command line
+arguments passed to foo will appear directly in @ARGV. The resulting
+executable foo is the compiled version of foo.pl. See the file NOTES for
+extra options you can pass to -MO=C.
+
+There are some constraints on the contents on foo.pl if you want to be
+able to compile it successfully. Some problems can be fixed fairly easily
+by altering foo.pl; some problems with the compiler are known to be
+straightforward to solve and I'll do so soon. The file Todo lists a
+number of known problems. See the XSUB section lower down for information
+about compiling programs which use XSUBs.
+
+(2) To compile foo.pl with the CC backend (which generates actual
+optimised C code for the execution path of your perl program), use
+ perl -MO=CC,-ofoo.c foo.pl
+
+and proceed just as with the C backend. You should almost certainly
+use an option such as -O2 with the subsequent cc_harness invocation
+so that your C compiler uses optimisation. The C code generated by
+the Perl compiler's CC backend looks ugly to humans but is easily
+optimised by C compilers.
+
+To make the most of this compiler backend, you need to tell the
+compiler when you're using int or double variables so that it can
+optimise appropriately (although this part of the compiler is the most
+buggy). You currently do that by naming lexical variables ending in
+"_i" for ints, "_d" for doubles, "_ir" for int "register" variables or
+"_dr" for double "register" variables. Here "register" is a promise
+that you won't pass a reference to the variable into a sub which then
+modifies the variable. The compiler ought to catch attempts to use
+"\$i" just as C compilers catch attempts to do "&i" for a register int
+i but it doesn't at the moment. Bugs in the CC backend may make your
+program fail in mysterious ways and give wrong answers rather than just
+crash in boring ways. But, hey, this is an alpha release so you knew
+that anyway. See the XSUB section lower down for information about
+compiling programs which use XSUBs.
+
+If your program uses classes which define methods (or other subs which
+are not exported and not apparently used until runtime) then you'll
+need to use -u compile-time options (see the NOTES file) to force the
+subs to be compiled. Future releases will probably default the other
+way, do more auto-detection and provide more fine-grained control.
+
+Since compiled executables need linking with libperl, you may want
+to turn libperl.a into a shared library if your platform supports
+it. For example, with Digital UNIX, do something like
+ ld -shared -o libperl.so -all libperl.a -none -lc
+and with Linux/ELF, rebuild the perl .c files with -fPIC (and I
+also suggest -fomit-frame-pointer for Linux on Intel architetcures),
+do "make libperl.a" and then do
+ gcc -shared -Wl,-soname,libperl.so.5 -o libperl.so.5.3 `ar t libperl.a`
+and then
+ # cp libperl.so.5.3 /usr/lib
+ # cd /usr/lib
+ # ln -s libperl.so.5.3 libperl.so.5
+ # ln -s libperl.so.5 libperl.so
+ # ldconfig
+When you compile perl executables with cc_harness, append -L/usr/lib
+otherwise the -L for the perl source directory will override it. For
+example,
+ perl -Iblib/arch -MO=CC,-O2,-ofoo3.c foo3.bench
+ perl cc_harness -o foo3 -O2 foo3.c -L/usr/lib
+ ls -l foo3
+ -rwxr-xr-x 1 mbeattie xzdg 11218 Jul 1 15:28 foo3
+You'll probably also want to link your main perl executable against
+libperl.so; it's nice having an 11K perl executable.
+
+(3) To compile foo.pl into bytecode do
+ perl -MO=Bytecode,-ofoo foo.pl
+To run the resulting bytecode file foo as a standalone program, you
+use the program byteperl which should have been built along with the
+extensions.
+ ./byteperl foo
+Any extra arguments are passed in as @ARGV; they are not interpreted
+as perl options. If you want to load chunks of bytecode into an already
+running perl program then use the -m option and investigate the
+byteload_fh and byteload_string functions exported by the B module.
+See the NOTES file for details of these and other options (including
+optimisation options and ways of getting at the intermediate "assembler"
+code that the Bytecode backend uses).
+
+(3) There are little Bourne shell scripts and perl programs to aid with
+some common operations: assemble, disassemble, run_bytecode_test,
+run_test, cc_harness, test_harness, test_harness_bytecode.
+
+(4) Walk the op tree in execution order printing terse info about each op
+ perl -MO=Terse,exec foo.pl
+
+(5) Walk the op tree in syntax order printing lengthier debug info about
+each op. You can also append ",exec" to walk in execution order, but the
+formatting is designed to look nice with Terse rather than Debug.
+ perl -MO=Debug foo.pl
+
+(6) Produce a cross-reference report of the line numbers at which all
+variables, subs and formats are defined and used.
+ perl -MO=Xref foo.pl
+
+XSUBS
+
+The C and CC backends can successfully compile some perl programs which
+make use of XSUB extensions. [I'll add more detail to this section in a
+later release.] As a prerequisite, such extensions must not need to do
+anything in their BOOT: section which needs to be done at runtime rather
+than compile time. Normally, the only code in the boot_Foo() function is
+a list of newXS() calls which xsubpp puts there and the compiler handles
+saving those XS subs itself. For each XSUB used, the C and CC compiler
+will generate an initialiser in their C output which refers to the name
+of the relevant C function (XS_Foo_somesub). What is not yet automated
+is the necessary commands and cc command-line options (e.g. via
+"perl cc_harness") which link against the extension libraries. For now,
+you need the XSUB extension to have installed files in the right format
+for using as C libraries (e.g. Foo.a or Foo.so). As the Foo.so files (or
+your platform's version) aren't suitable for linking against, you will
+have to reget the extension source and rebuild it as a static extension
+to force the generation of a suitable Foo.a file. Then you need to make
+a symlink (or copy or rename) of that file into a libFoo.a suitable for
+cc linking. Then add the appropriate -L and -l options to your
+"perl cc_harness" command line to find and link against those libraries.
+You may also need to fix up some platform-dependent environment variable
+to ensure that linked-against .so files are found at runtime too.
+
+DIFFERENCES
+
+The result of running a compiled Perl program can sometimes be different
+from running the same program with standard perl. Think of the compiler
+as having a slightly different implementation of the language Perl.
+Unfortunately, since Perl has had a single implementation until now,
+there are no formal standards or documents defining what behaviour is
+guaranteed of Perl the language and what just "happens to work".
+Some of the differences below are almost impossible to change because of
+the way the compiler works. Others can be changed to produce "standard"
+perl behaviour if it's deemed proper and the resulting performance hit
+is accepted. I'll use "standard perl" to mean the result of running a
+Perl program using the perl executable from the perl distribution.
+I'll use "compiled Perl program" to mean running an executable produced
+by this compiler kit ("the compiler") with the CC backend.
+
+Loops
+ Standard perl calculates the target of "next", "last", and "redo"
+ at run-time. The compiler calculates the targets at compile-time.
+ For example, the program
+
+ sub skip_on_odd { next NUMBER if $_[0] % 2 }
+ NUMBER: for ($i = 0; $i < 5; $i++) {
+ skip_on_odd($i);
+ print $i;
+ }
+
+ produces the output
+ 024
+ with standard perl but gives a compile-time error with the compiler.
+
+Context of ".."
+ The context (scalar or array) of the ".." operator determines whether
+ it behaves as a range or a flip/flop. Standard perl delays until
+ runtime the decision of which context it is in but the compiler needs
+ to know the context at compile-time. For example,
+ @a = (4,6,1,0,0,1);
+ sub range { (shift @a)..(shift @a) }
+ print range();
+ while (@a) { print scalar(range()) }
+ generates the output
+ 456123E0
+ with standard Perl but gives a compile-time error with compiled Perl.
+
+Arithmetic
+ Compiled Perl programs use native C arithemtic much more frequently
+ than standard perl. Operations on large numbers or on boundary
+ cases may produce different behaviour.
+
+Deprecated features
+ Features of standard perl such as $[ which have been deprecated
+ in standard perl since version 5 was released have not been
+ implemented in the compiler.
+
+Others
+ I'll add to this list as I remember what they are.
+
+BUGS
+
+Here are some things which may cause the compiler problems.
+
+The following render the compiler useless (without serious hacking):
+* Use of the DATA filehandle (via __END__ or __DATA__ tokens)
+* Operator overloading with %OVERLOAD
+* The (deprecated) magic array-offset variable $[ does not work
+* The following operators are not yet implemented for CC
+ goto
+ sort with a non-default comparison (i.e. a named sub or inline block)
+* You can't use "last" to exit from a non-loop block.
+
+The following may give significant problems:
+* BEGIN blocks containing complex initialisation code
+* Code which is only ever referred to at runtime (e.g. via eval "..." or
+ via method calls): see the -u option for the C and CC backends.
+* Run-time lookups of lexical variables in "outside" closures
+
+The following may cause problems (not thoroughly tested):
+* Dependencies on whether values of some "magic" Perl variables are
+ determined at compile-time or runtime.
+* For the C and CC backends: compile-time strings which are longer than
+ your C compiler can cope with in a single line or definition.
+* Reliance on intimate details of global destruction
+* For the Bytecode backend: high -On optimisation numbers with code
+ that has complex flow of control.
+* Any "-w" option in the first line of your perl program is seen and
+ acted on by perl itself before the compiler starts. The compiler
+ itself then runs with warnings turned on. This may cause perl to
+ print out warnings about the compiler itself since I haven't tested
+ it thoroughly with warnings turned on.
+
+There is a terser but more complete list in the Todo file.
+
+Malcolm Beattie
+2 September 1996
diff --git a/contrib/perl5/ext/B/TESTS b/contrib/perl5/ext/B/TESTS
new file mode 100644
index 000000000000..e050f6cfddb0
--- /dev/null
+++ b/contrib/perl5/ext/B/TESTS
@@ -0,0 +1,78 @@
+Test results from compiling t/*/*.t
+ C Bytecode CC
+
+base/cond.t OK ok OK
+base/if.t OK ok OK
+base/lex.t OK ok OK
+base/pat.t OK ok OK
+base/term.t OK ok OK
+cmd/elsif.t OK ok OK
+cmd/for.t OK ok ok 1, 2, 3, panic: pp_iter
+cmd/mod.t OK ok ok
+cmd/subval.t OK ok 1..34, not ok 27,28 (simply
+ because filename changes).
+cmd/switch.t OK ok ok
+cmd/while.t OK ok ok
+io/argv.t OK ok ok
+io/dup.t OK ok ok
+io/fs.t OK ok ok
+io/inplace.t OK ok ok
+io/pipe.t OK ok ok with -umain
+io/print.t OK ok ok
+io/tell.t OK ok ok
+op/append.t OK ok OK
+op/array.t OK ok 1..36, not ok 7,10 (no $[)
+op/auto.t OK ok OK
+op/chop.t OK ok OK
+op/cond.t OK ok OK
+op/delete.t OK ok OK
+op/do.t OK ok OK
+op/each.t OK ok OK
+op/eval.t OK ok ok 1-6 of 16 then exits
+op/exec.t OK ok OK
+op/exp.t OK ok OK
+op/flip.t OK ok OK
+op/fork.t OK ok OK
+op/glob.t OK ok OK
+op/goto.t OK ok 1..9, Can't find label label1.
+op/groups.t OK (s/ucb/bin/ under Linux) OK 1..0 for now.
+op/index.t OK ok OK
+op/int.t OK ok OK
+op/join.t OK ok OK
+op/list.t OK ok OK
+op/local.t OK ok OK
+op/magic.t OK ok OK
+op/misc.t no DATA filehandle so succeeds trivially with 1..0
+op/mkdir.t OK ok OK
+op/my.t OK ok OK
+op/oct.t OK ok OK (C large const warnings)
+op/ord.t OK ok OK
+op/overload.t Mostly not ok Mostly not ok C errors.
+op/pack.t OK ok OK
+op/pat.t omit 26 (reset) ok [lots of memory for compile]
+op/push.t OK ok OK
+op/quotemeta.t OK ok OK
+op/rand.t OK ok
+op/range.t OK ok OK
+op/read.t OK ok OK
+op/readdir.t OK ok OK (substcont works too)
+op/ref.t omits "ok 40" (lex destruction) ok (Bytecode)
+ CC: need -u for OBJ,BASEOBJ,
+ UNIVERSAL,WHATEVER,main.
+ 1..41, ok1-33,36-38,
+ then ok 41, ok 39.DESTROY probs
+op/regexp.t OK ok ok (trivially all eval'd)
+op/repeat.t OK ok ok
+op/sleep.t OK ok ok
+op/sort.t OK ok 1..10, ok 1, Out of memory!
+op/split.t OK ok ok
+op/sprintf.t OK ok ok
+op/stat.t OK ok ok
+op/study.t OK ok ok
+op/subst.t OK ok ok
+op/substr.t OK ok ok1-22 except 7-9,11 (all $[)
+op/time.t OK ok ok
+op/undef.t omit 21 ok ok
+op/unshift.t OK ok ok
+op/vec.t OK ok ok
+op/write.t not ok 3 (no CvOUTSIDE lex from runtime eval). CC: 1..3, hang
diff --git a/contrib/perl5/ext/B/Todo b/contrib/perl5/ext/B/Todo
new file mode 100644
index 000000000000..495be2ef3d1c
--- /dev/null
+++ b/contrib/perl5/ext/B/Todo
@@ -0,0 +1,37 @@
+* Fixes
+
+CC backend: goto, sort with non-default comparison. last for non-loop blocks.
+Version checking
+improve XSUB handling (both static and dynamic)
+sv_magic can do SvREFCNT_inc(obj) which messes up precalculated refcounts
+allocation of XPV[INAHC]V structures needs fixing: Perl tries to free
+them whereas the compiler expects them to be linked to a xpv[inahc]v_root
+list the same as X[IPR]V structures.
+ref counts
+perl_parse replacement
+fix cstring for long strings
+compile-time initialisation of AvARRAYs
+signed/unsigned problems with NV (and IV?) initialisation and elsewhere?
+CvOUTSIDE for ordinary subs
+DATA filehandle for standalone Bytecode program (easy)
+DATA filehandle for multiple bytecode-compiled modules (harder)
+DATA filehandle for C-compiled program (yet harder)
+
+* Features
+
+type checking
+compile time v. runtime initialisation
+save PMOPs in compiled form
+selection of what to dump
+options for cutting out line info etc.
+comment output
+shared constants
+module dependencies
+
+* Optimisations
+collapse LISTOPs to UNOPs or BASEOPs
+compile-time qw(), constant subs
+global analysis of variables, type hints etc.
+demand-loaded bytecode (leader of each basic block replaced by an op
+which loads in bytecode for its block)
+fast sub calls for CC backend
diff --git a/contrib/perl5/ext/B/byteperl.c b/contrib/perl5/ext/B/byteperl.c
new file mode 100644
index 000000000000..6b53e3b174a5
--- /dev/null
+++ b/contrib/perl5/ext/B/byteperl.c
@@ -0,0 +1,110 @@
+#include "EXTERN.h"
+#include "perl.h"
+#ifndef PATCHLEVEL
+#include "patchlevel.h"
+#endif
+
+static void xs_init _((void));
+static PerlInterpreter *my_perl;
+
+int
+#ifndef CAN_PROTOTYPE
+main(argc, argv, env)
+int argc;
+char **argv;
+char **env;
+#else /* def(CAN_PROTOTYPE) */
+main(int argc, char **argv, char **env)
+#endif /* def(CAN_PROTOTYPE) */
+{
+ int exitstatus;
+ int i;
+ char **fakeargv;
+ FILE *fp;
+#ifdef INDIRECT_BGET_MACROS
+ struct bytestream bs;
+#endif /* INDIRECT_BGET_MACROS */
+
+ INIT_SPECIALSV_LIST;
+ PERL_SYS_INIT(&argc,&argv);
+
+#if PATCHLEVEL > 3 || (PATCHLEVEL == 3 && SUBVERSION >= 1)
+ perl_init_i18nl10n(1);
+#else
+ perl_init_i18nl14n(1);
+#endif
+
+ if (!PL_do_undump) {
+ my_perl = perl_alloc();
+ if (!my_perl)
+#ifdef VMS
+ exit(vaxc$errno);
+#else
+ exit(1);
+#endif
+ perl_construct( my_perl );
+ }
+
+#ifdef CSH
+ if (!PL_cshlen)
+ PL_cshlen = strlen(PL_cshname);
+#endif
+
+ if (argc < 2)
+ fp = stdin;
+ else {
+#ifdef WIN32
+ fp = fopen(argv[1], "rb");
+#else
+ fp = fopen(argv[1], "r");
+#endif
+ if (!fp) {
+ perror(argv[1]);
+#ifdef VMS
+ exit(vaxc$errno);
+#else
+ exit(1);
+#endif
+ }
+ argv++;
+ argc--;
+ }
+ New(666, fakeargv, argc + 4, char *);
+ fakeargv[0] = argv[0];
+ fakeargv[1] = "-e";
+ fakeargv[2] = "";
+ fakeargv[3] = "--";
+ for (i = 1; i < argc; i++)
+ fakeargv[i + 3] = argv[i];
+ fakeargv[argc + 3] = 0;
+
+ exitstatus = perl_parse(my_perl, xs_init, argc + 3, fakeargv, NULL);
+ if (exitstatus)
+ exit( exitstatus );
+
+ sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
+ PL_main_cv = PL_compcv;
+ PL_compcv = 0;
+
+#ifdef INDIRECT_BGET_MACROS
+ bs.data = fp;
+ bs.fgetc = (int(*) _((void*)))fgetc;
+ bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread;
+ bs.freadpv = freadpv;
+ byterun(bs);
+#else
+ byterun(fp);
+#endif /* INDIRECT_BGET_MACROS */
+
+ exitstatus = perl_run( my_perl );
+
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+
+ exit( exitstatus );
+}
+
+static void
+xs_init()
+{
+}
diff --git a/contrib/perl5/ext/B/ramblings/cc.notes b/contrib/perl5/ext/B/ramblings/cc.notes
new file mode 100644
index 000000000000..47bd65a09d82
--- /dev/null
+++ b/contrib/perl5/ext/B/ramblings/cc.notes
@@ -0,0 +1,32 @@
+At entry to each basic block, the following can be assumed (and hence
+must be forced where necessary at the end of each basic block):
+
+The shadow stack @stack is empty.
+For each lexical object in @pad, VALID_IV holds for each T_INT,
+VALID_DOUBLE holds for each T_DOUBLE and VALID_SV holds otherwise.
+The C shadow variable sp holds the stack pointer (not necessarily stack_sp).
+
+write_back_stack
+ Writes the contents of the shadow stack @stack back to the real stack.
+ A write-back of each object in the stack is forced so that its
+ backing SV contains the right value and that SV is then pushed onto the
+ real stack. On return, @stack is empty.
+
+write_back_lexicals
+ Forces a write-back (i.e. achieves VALID_SV), where necessary, for each
+ lexical object in @pad. Objects with the TEMPORARY flag are skipped. If
+ write_back_lexicals is called with an (optional) argument, then it is
+ taken to be a bitmask of more flags: any lexical object with one of those
+ flags set is also skipped and not written back to its SV.
+
+invalidate_lexicals($avoid)
+ The VALID_INT and VALID_DOUBLE flags are turned off for each lexical
+ object in @pad whose flags field doesn't overlap with $avoid.
+
+reload_lexicals
+ For each necessary lexical object in @pad, makes sure that VALID_IV
+ holds for objects of type T_INT, VALID_DOUBLE holds for objects for
+ type T_DOUBLE, and VALID_SV holds for other objects. An object is
+ considered for reloading if its flags field does not overlap with the
+ (optional) argument passed to reload_lexicals.
+
diff --git a/contrib/perl5/ext/B/ramblings/curcop.runtime b/contrib/perl5/ext/B/ramblings/curcop.runtime
new file mode 100644
index 000000000000..9b8b7d52e71f
--- /dev/null
+++ b/contrib/perl5/ext/B/ramblings/curcop.runtime
@@ -0,0 +1,39 @@
+PP code uses of curcop
+----------------------
+
+pp_rv2gv
+ when a new glob is created for an OPpLVAL_INTRO,
+ curcop->cop_line is stored as GvLINE() in the new GP.
+pp_bless
+ curcop->cop_stash is used as the stash in the one-arg form of bless
+
+pp_repeat
+ tests (curcop != &compiling) to warn "Can't x= to readonly value"
+
+pp_pos
+pp_substr
+pp_index
+pp_rindex
+pp_aslice
+pp_lslice
+pp_splice
+ curcop->cop_arybase
+
+pp_sort
+ curcop->cop_stash used to determine whether to gv_fetchpv $a and $b
+
+pp_caller
+ tests (curcop->cop_stash == debstash) to determine whether
+ to set DB::args
+
+pp_reset
+ resets vars in curcop->cop_stash
+
+pp_dbstate
+ sets curcop = (COP*)op
+
+doeval
+ compiles into curcop->cop_stash
+
+pp_nextstate
+ sets curcop = (COP*)op
diff --git a/contrib/perl5/ext/B/ramblings/flip-flop b/contrib/perl5/ext/B/ramblings/flip-flop
new file mode 100644
index 000000000000..183d541b9827
--- /dev/null
+++ b/contrib/perl5/ext/B/ramblings/flip-flop
@@ -0,0 +1,51 @@
+PP(pp_range)
+{
+ if (GIMME == G_ARRAY)
+ return cCONDOP->op_true;
+ return SvTRUEx(PAD_SV(op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
+}
+
+pp_range is a CONDOP.
+In array context, it just returns op_true.
+In scalar context it checks the truth of targ and returns
+op_false if true, op_true if false.
+
+flip is an UNOP.
+It "looks after" its child which is always a pp_range CONDOP.
+In array context, it just returns the child's op_false.
+In scalar context, there are three possible outcomes:
+ (1) set child's targ to 1, our targ to 1 and return op_next.
+ (2) set child's targ to 1, our targ to 0, sp-- and return child's op_false.
+ (3) Blank targ and TOPs and return op_next.
+Case 1 happens for a "..." with a matching lineno... or true TOPs.
+Case 2 happens for a ".." with a matching lineno... or true TOPs.
+Case 3 happens for a non-matching lineno or false TOPs.
+
+ $a = lhs..rhs;
+
+ ,-------> range
+ ^ / \
+ | true/ \false
+ | / \
+ first| lhs rhs
+ | \ first /
+ ^--- flip <----- flop
+ \ /
+ \ /
+ sassign
+
+
+/* range */
+if (SvTRUE(curpad[op->op_targ]))
+ goto label(op_false);
+/* op_true */
+...
+/* flip */
+/* For "..." returns op_next. For ".." returns op_next or op_first->op_false */
+/* end of basic block */
+goto out;
+label(range op_false):
+...
+/* flop */
+out:
+...
diff --git a/contrib/perl5/ext/B/ramblings/magic b/contrib/perl5/ext/B/ramblings/magic
new file mode 100644
index 000000000000..e41930a0f02f
--- /dev/null
+++ b/contrib/perl5/ext/B/ramblings/magic
@@ -0,0 +1,93 @@
+sv_magic()
+----------
+av.c
+av_store()
+ Storing a non-undef element into an SMAGICAL array, av,
+ assigns the equivalent lowercase form of magic (of the first
+ MAGIC in the chain) to the value (with obj = av, name = 0 and
+ namlen = array index).
+
+gv.c
+gv_init()
+ Initialising gv assigns '*' magic to it with obj = gv, name =
+ GvNAME and namlen = GvNAMELEN.
+gv_fetchpv()
+ @ISA gets 'I' magic with obj = gv, zero name and namlen.
+ %OVERLOAD gets 'A' magic with obj = gv, zero name and namlen.
+ $1 to $9, $&, $`, $', $+ get '\0' magic with obj = gv,
+ name = GvNAME and namlen = len ( = 1 presumably).
+Gv_AMupdate()
+ Stashes for overload magic seem to get 'c' magic with obj = 0,
+ name = &amt and namlen = sizeof(amt).
+hv_magic(hv, gv, how)
+ Gives magic how to hv with obj = gv and zero name and namlen.
+
+mg.c
+mg_copy(sv, nsv, key, klen)
+ Traverses the magic chain of sv. Upper case forms of magic
+ (only) are copied across to nsv, preserving obj but using
+ name = key and namlen = klen.
+magic_setpos()
+ LvTARG of a PVLV gets 'g' magic with obj = name = 0 and namlen = pos.
+
+op.c
+mod()
+ PVLV operators give magic to their targs with
+ obj = name = namlen = 0. OP_POS gives '.', OP_VEC gives 'v'
+ and OP_SUBSTR gives 'x'.
+
+perl.c
+magicname(sym, name, namlen)
+ Fetches/creates a GV with name sym and gives it '\0' magic
+ with obj = gv, name and namlen as passed.
+init_postdump_symbols()
+ Elements of the environment get given SVs with 'e' magic.
+ obj = sv and name and namlen point to the actual string
+ within env.
+
+pp.c
+pp_av2arylen()
+ $#foo gives '#' magic to the new SV with obj = av and
+ name = namlen = 0.
+pp_study()
+ SV gets 'g' magic with obj = name = namlen = 0.
+pp_substr()
+ PVLV gets 'x' magic with obj = name = namlen = 0.
+pp_vec()
+ PVLV gets 'x' magic with obj = name = namlen = 0.
+
+pp_hot.c
+pp_match()
+ m//g gets 'g' magic with obj = name = namlen = 0.
+
+pp_sys.c
+pp_tie()
+ sv gets magic with obj = sv and name = namlen = 0.
+ If an HV or an AV, it gets 'P' magic, otherwise 'q' magic.
+pp_dbmopen()
+ 'P' magic for the HV just as with pp_tie().
+pp_sysread()
+ If tainting, the buffer SV gets 't' magic with
+ obj = name = namlen = 0.
+
+sv.c
+sv_setsv()
+ Doing sv_setsv(dstr, gv) gives '*' magic to dstr with
+ obj = dstr, name = GvNAME, namlen = GvNAMELEN.
+
+util.c
+fbm_compile()
+ The PVBM gets 'B' magic with obj = name = namlen = 0 and SvVALID
+ is set to indicate that the Boyer-Moore table is valid.
+ magic_setbm() just clears the SvVALID flag.
+
+hv_magic()
+----------
+
+gv.c
+gv_fetchfile()
+ With perldb, the HV of a gvfile gv gets 'L' magic with obj = gv.
+gv_fetchpv()
+ %SIG gets 'S' magic with obj = siggv.
+init_postdump_symbols()
+ %ENV gets 'E' magic with obj = envgv.
diff --git a/contrib/perl5/ext/B/ramblings/reg.alloc b/contrib/perl5/ext/B/ramblings/reg.alloc
new file mode 100644
index 000000000000..7fd69f2ebe53
--- /dev/null
+++ b/contrib/perl5/ext/B/ramblings/reg.alloc
@@ -0,0 +1,32 @@
+while ($i--) {
+ foo();
+}
+exit
+
+ PP code if i an int register if i an int but not a
+ (i.e. can't be register (i.e. can be
+ implicitly invalidated) implicitly invalidated)
+ nextstate
+ enterloop
+
+
+ loop:
+ gvsv GV (0xe6078) *i validates i validates i
+ postdec invalidates $i invalidates $i
+ and if_false goto out;
+ i valid; $i invalid i valid; $i invalid
+
+ i valid; $i invalid i valid; $i invalid
+ nextstate
+ pushmark
+ gv GV (0xe600c) *foo
+ entersub validates $i; invals i
+
+ unstack
+ goto loop:
+
+ i valid; $i invalid
+ out:
+ leaveloop
+ nextstate
+ exit
diff --git a/contrib/perl5/ext/B/ramblings/runtime.porting b/contrib/perl5/ext/B/ramblings/runtime.porting
new file mode 100644
index 000000000000..4699b255cf4a
--- /dev/null
+++ b/contrib/perl5/ext/B/ramblings/runtime.porting
@@ -0,0 +1,350 @@
+Notes on porting the perl runtime PP engine.
+Importance: 1 = who cares?, 10 = vital
+Difficulty: 1 = trivial, 10 = very difficult. Level assumes a
+reasonable implementation of the SV and OP API already ported.
+
+OP Import Diff Comments
+null 10 1
+stub 10 1
+scalar 10 1
+pushmark 10 1 PUSHMARK
+wantarray 7 3 cxstack, dopoptosub
+const 10 1
+gvsv 10 1 save_scalar
+gv 10 1
+gelem 3 3
+padsv 10 2 SAVECLEARSV, provide_ref
+padav 10 2
+padhv 10 2
+padany 1 1
+pushre 7 3 pushes an op. Blech.
+rv2gv 6 5
+rv2sv 10 4
+av2arylen 7 3 sv_magic
+rv2cv 8 5 sv_2cv
+anoncode 7 6 cv_clone
+prototype 4 4 sv_2cv
+refgen 8 3
+srefgen 8 2
+ref 8 3
+bless 7 3
+backtick 5 4
+glob 5 2 do_readline
+readline 8 2 do_readline
+rcatline 8 2
+regcmaybe 8 1
+regcomp 8 9 pregcomp
+match 8 10
+subst 8 10
+substcont 8 7
+trans 7 4 do_trans
+sassign 10 3 mg_find, SvSETMAGIC
+aassign 10 5
+chop 8 3 do_chop
+schop 8 3 do_chop
+chomp 8 3 do_chomp
+schomp 8 3 do_chomp
+defined 10 2
+undef 10 3
+study 4 5
+pos 8 3 PVLV, mg_find
+preinc 10 2 sv_inc, SvSETMAGIC
+i_preinc
+predec 10 2 sv_dec, SvSETMAGIC
+i_predec
+postinc 10 2 sv_dec, SvSETMAGIC
+i_postinc
+postdec 10 2 sv_dec, SvSETMAGIC
+i_postdec
+pow 10 1
+multiply 10 1
+i_multiply 10 1
+divide 10 2
+i_divide 10 1
+modulo 10 2
+i_modulo 10 1
+repeat 6 4
+add 10 1
+i_add 10 1
+subtract 10 1
+i_subtract 10 1
+concat 10 2 mg_get
+stringify 10 2 sv_setpvn
+left_shift 10 1
+right_shift 10 1
+lt 10 1
+i_lt 10 1
+gt 10 1
+i_gt 10 1
+le 10 1
+i_le 10 1
+ge 10 1
+i_ge 10 1
+eq 10 1
+i_eq 10 1
+ne 10 1
+i_ne 10 1
+ncmp 10 1
+i_ncmp 10 1
+slt 10 2
+sgt 10 2
+sle 10 2
+sge 10 2
+seq 10 2 sv_eq
+sne 10 2
+scmp 10 2
+bit_and 10 2
+bit_xor 10 2
+bit_or 10 2
+negate 10 3
+i_negate 10 1
+not 10 1
+complement 10 3
+atan2 6 1
+sin 6 1
+cos 6 1
+rand 5 2
+srand 5 2
+exp 6 1
+log 6 2
+sqrt 6 2
+int 10 2
+hex 9 2
+oct 9 2
+abs 10 1
+length 10 1
+substr 10 4 PVLV
+vec 5 4
+index 9 3
+rindex 9 3
+sprintf 9 4 do_sprintf
+formline 6 7
+ord 6 2
+chr 6 2
+crypt 3 2
+ucfirst 6 2
+lcfirst 6 2
+uc 6 2
+lc 6 2
+quotemeta 6 3
+rv2av 10 3 save_svref, mg_get, save_ary
+aelemfast 10 2 av_fetch
+aelem 10 3
+aslice 9 4
+each 10 3 hv_iternext
+values 10 3 do_kv
+keys 10 3 do_kv
+delete 10 3
+exists 10 3
+rv2hv 10 3 save_svref, mg_get, save_ary, do_kv
+helem 10 3 save_svref, provide_ref
+hslice 9 4
+unpack 9 6 lengthy
+pack 9 6 lengthy
+split 9 9
+join 10 4 do_join
+list 10 2
+lslice 9 4
+anonlist 10 2
+anonhash 10 3
+splice 9 6
+push 10 2
+pop 10 2
+shift 10 2
+unshift 10 2
+sort 6 7
+reverse 9 4
+grepstart 6 5 modifies flow of control
+grepwhile 6 5 modifies flow of control
+mapstart 1 1
+mapwhile 6 5 modifies flow of control
+range 7 3 modifies flow of control
+flip 7 4 modifies flow of control
+flop 7 4 modifies flow of control
+and 10 3 modifies flow of control
+or 10 3 modifies flow of control
+xor
+cond_expr 10 3 modifies flow of control
+andassign 7 3 modifies flow of control
+orassign 7 3 modifies flow of control
+method 8 5
+entersub 10 7
+leavesub 10 5
+caller 2 8
+warn 9 3
+die 9 3
+reset 2 2
+lineseq 1 1
+nextstate 10 1 Update stack_sp from cxstack. FREETMPS.
+dbstate 3 7
+unstack
+enter 10 3 cxstack, ENTER, SAVETMPS, PUSHBLOCK
+leave 10 3 cxstack, SAVETMPS, LEAVE, POPBLOCK
+scope 1 1
+enteriter 9 4 cxstack
+iter 9 3 cxstack
+enterloop 10 4
+leaveloop 10 4
+return 10 5
+last 9 6
+next 9 6
+redo 9 6
+dump 1 9 pp_goto
+goto 6 9
+exit 9 2 my_exit
+open 9 5 do_open
+close 9 3 do_close
+pipe_op 7 4
+fileno 9 2
+umask 4 2
+binmode 4 2
+tie 5 5 pp_entersub
+untie 5 2 sv_unmagic
+tied 5 2
+dbmopen 4 5
+dbmclose 4 2
+sselect 4 4
+select 7 3
+getc 7 2
+read 8 2 pp_sysread
+enterwrite 4 4 doform
+leavewrite 4 5
+prtf 4 4 do_sprintf
+print 8 6
+sysopen 8 2
+sysread 8 4
+syswrite 8 4 pp_send
+send 8 4
+recv 8 4 pp_sysread
+eof 9 2
+tell 9 3
+seek 9 2
+truncate 8 3
+fcntl 8 4 pp_ioctl
+ioctl 8 4
+flock 8 2
+socket 5 3
+sockpair 5 3
+bind 5 3
+connect 5 3
+listen 5 3
+accept 5 3
+shutdown 5 2
+gsockopt 5 3 pp_ssockopt
+ssockopt 5 3
+getsockname 5 3 pp_getpeername
+getpeername 5 3
+lstat 5 4 pp_stat
+stat 5 4 lengthy
+ftrread 5 2 cando
+ftrwrite 5 2 cando
+ftrexec 5 2 cando
+fteread 5 2 cando
+ftewrite 5 2 cando
+fteexec 5 2 cando
+ftis 5 2 cando
+fteowned 5 2 cando
+ftrowned 5 2 cando
+ftzero 5 2 cando
+ftsize 5 2 cando
+ftmtime 5 2 cando
+ftatime 5 2 cando
+ftctime 5 2 cando
+ftsock 5 2 cando
+ftchr 5 2 cando
+ftblk 5 2 cando
+ftfile 5 2 cando
+ftdir 5 2 cando
+ftpipe 5 2 cando
+ftlink 5 2 cando
+ftsuid 5 2 cando
+ftsgid 5 2 cando
+ftsvtx 5 2 cando
+fttty 5 2 cando
+fttext 5 4
+ftbinary 5 4 fttext
+chdir
+chown
+chroot
+unlink
+chmod
+utime
+rename
+link
+symlink
+readlink
+mkdir
+rmdir
+open_dir
+readdir
+telldir
+seekdir
+rewinddir
+closedir
+fork
+wait
+waitpid
+system
+exec
+kill
+getppid
+getpgrp
+setpgrp
+getpriority
+setpriority
+time
+tms
+localtime
+gmtime
+alarm
+sleep
+shmget
+shmctl
+shmread
+shmwrite
+msgget
+msgctl
+msgsnd
+msgrcv
+semget
+semctl
+semop
+require 6 9 doeval
+dofile 6 9 doeval
+entereval 6 9 doeval
+leaveeval 6 5
+entertry 7 4 modifies flow of control
+leavetry 7 3
+ghbyname
+ghbyaddr
+ghostent
+gnbyname
+gnbyaddr
+gnetent
+gpbyname
+gpbynumber
+gprotoent
+gsbyname
+gsbyport
+gservent
+shostent
+snetent
+sprotoent
+sservent
+ehostent
+enetent
+eprotoent
+eservent
+gpwnam
+gpwuid
+gpwent
+spwent
+epwent
+ggrnam
+ggrgid
+ggrent
+sgrent
+egrent
+getlogin
+syscall
+ \ No newline at end of file
diff --git a/contrib/perl5/ext/B/typemap b/contrib/perl5/ext/B/typemap
new file mode 100644
index 000000000000..7206a6a2e112
--- /dev/null
+++ b/contrib/perl5/ext/B/typemap
@@ -0,0 +1,69 @@
+TYPEMAP
+
+B::OP T_OP_OBJ
+B::UNOP T_OP_OBJ
+B::BINOP T_OP_OBJ
+B::LOGOP T_OP_OBJ
+B::CONDOP T_OP_OBJ
+B::LISTOP T_OP_OBJ
+B::PMOP T_OP_OBJ
+B::SVOP T_OP_OBJ
+B::GVOP T_OP_OBJ
+B::PVOP T_OP_OBJ
+B::CVOP T_OP_OBJ
+B::LOOP T_OP_OBJ
+B::COP T_OP_OBJ
+
+B::SV T_SV_OBJ
+B::PV T_SV_OBJ
+B::IV T_SV_OBJ
+B::NV T_SV_OBJ
+B::PVMG T_SV_OBJ
+B::PVLV T_SV_OBJ
+B::BM T_SV_OBJ
+B::RV T_SV_OBJ
+B::GV T_SV_OBJ
+B::CV T_SV_OBJ
+B::HV T_SV_OBJ
+B::AV T_SV_OBJ
+B::IO T_SV_OBJ
+
+B::MAGIC T_MG_OBJ
+SSize_t T_IV
+STRLEN T_IV
+
+INPUT
+T_OP_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = ($type) tmp;
+ }
+ else
+ croak(\"$var is not a reference\")
+
+T_SV_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = ($type) tmp;
+ }
+ else
+ croak(\"$var is not a reference\")
+
+T_MG_OBJ
+ if (SvROK($arg)) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = ($type) tmp;
+ }
+ else
+ croak(\"$var is not a reference\")
+
+OUTPUT
+T_OP_OBJ
+ sv_setiv(newSVrv($arg, cc_opclassname((OP*)$var)), (IV)$var);
+
+T_SV_OBJ
+ make_sv_object(($arg), (SV*)($var));
+
+
+T_MG_OBJ
+ sv_setiv(newSVrv($arg, "B::MAGIC"), (IV)$var);
diff --git a/contrib/perl5/ext/DB_File/Changes b/contrib/perl5/ext/DB_File/Changes
new file mode 100644
index 000000000000..993fe3228c98
--- /dev/null
+++ b/contrib/perl5/ext/DB_File/Changes
@@ -0,0 +1,205 @@
+
+0.1
+
+ First Release.
+
+0.2
+
+ When DB_File is opening a database file it no longer terminates the
+ process if dbopen returned an error. This allows file protection
+ errors to be caught at run time. Thanks to Judith Grass
+ <grass@cybercash.com> for spotting the bug.
+
+0.3
+
+ Added prototype support for multiple btree compare callbacks.
+
+1.0
+
+ DB_File has been in use for over a year. To reflect that, the
+ version number has been incremented to 1.0.
+
+ Added complete support for multiple concurrent callbacks.
+
+ Using the push method on an empty list didn't work properly. This
+ has been fixed.
+
+1.01
+
+ Fixed a core dump problem with SunOS.
+
+ The return value from TIEHASH wasn't set to NULL when dbopen
+ returned an error.
+
+1.02
+
+ Merged OS/2 specific code into DB_File.xs
+
+ Removed some redundant code in DB_File.xs.
+
+ Documentation update.
+
+ Allow negative subscripts with RECNO interface.
+
+ Changed the default flags from O_RDWR to O_CREAT|O_RDWR.
+
+ The example code which showed how to lock a database needed a call
+ to sync added. Without it the resultant database file was empty.
+
+ Added get_dup method.
+
+1.03
+
+ Documentation update.
+
+ DB_File now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl
+ automatically.
+
+ The standard hash function exists is now supported.
+
+ Modified the behavior of get_dup. When it returns an associative
+ array, the value is the count of the number of matching BTREE
+ values.
+
+1.04
+
+ Minor documentation changes.
+
+ Fixed a bug in hash_cb. Patches supplied by Dave Hammen,
+ <hammen@gothamcity.jsc.nasa.govt>.
+
+ Fixed a bug with the constructors for DB_File::HASHINFO,
+ DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the
+ constructors to make them -w clean.
+
+ Reworked part of the test harness to be more locale friendly.
+
+1.05
+
+ Made all scripts in the documentation strict and -w clean.
+
+ Added logic to DB_File.xs to allow the module to be built after
+ Perl is installed.
+
+1.06
+
+ Minor namespace cleanup: Localized PrintBtree.
+
+1.07
+
+ Fixed bug with RECNO, where bval wasn't defaulting to "\n".
+
+1.08
+
+ Documented operation of bval.
+
+1.09
+
+ Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and
+ DB_File::BTREEINFO.
+
+ Changed default mode to 0666.
+
+1.10
+
+ Fixed fd method so that it still returns -1 for in-memory files
+ when db 1.86 is used.
+
+1.11
+
+ Documented the untie gotcha.
+
+1.12
+
+ Documented the incompatibility with version 2 of Berkeley DB.
+
+1.13
+
+ Minor changes to DB_FIle.xs and DB_File.pm
+
+1.14
+
+ Made it illegal to tie an associative array to a RECNO database and
+ an ordinary array to a HASH or BTREE database.
+
+1.15
+
+ Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined
+ value" warning with db_get and db_seq.
+
+ Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the
+ O_* constants from Fcntl.
+
+ Removed the DESTROY method from the DB_File::HASHINFO module.
+
+ Previously DB_File hard-wired the class name of any object that it
+ created to "DB_File". This makes sub-classing difficult. Now
+ DB_File creats objects in the namespace of the package it has been
+ inherited into.
+
+
+1.16
+
+ A harmless looking tab was causing Makefile.PL to fail on AIX 3.2.5
+
+ Small fix for the AIX strict C compiler XLC which doesn't like
+ __attribute__ being defined via proto.h and redefined via db.h. Fix
+ courtesy of Jarkko Hietaniemi.
+
+1.50
+
+ DB_File can now build with either DB 1.x or 2.x, but not both at
+ the same time.
+
+1.51
+
+ Fixed the test harness so that it doesn't expect DB_File to have
+ been installed by the main Perl build.
+
+
+ Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent
+
+1.52
+
+ Patch from Nick Ing-Simmons now allows DB_File to build on NT.
+ Merged 1.15 patch.
+
+1.53
+
+ Added DB_RENUMBER to flags for recno.
+
+1.54
+
+ Fixed a small bug in the test harness when run under win32
+ The emulation of fd when useing DB 2.x was busted.
+
+1.55
+ Merged 1.16 changes.
+
+1.56
+ Documented the Solaris 2.5 mutex bug
+
+1.57
+ If Perl has been compiled with Threads support,the symbol op will be
+ defined. This clashes with a field name in db.h, so it needs to be
+ #undef'ed before db.h is included.
+
+1.58
+ Tied Array support was enhanced in Perl 5.004_57. DB_File now
+ supports PUSH,POP,SHIFT,UNSHIFT & STORESIZE.
+
+ Fixed a problem with the use of sv_setpvn. When the size is
+ specified as 0, it does a strlen on the data. This was ok for DB
+ 1.x, but isn't for DB 2.x.
+
+1.59
+ Updated the license section.
+
+ Berkeley DB 2.4.10 disallows zero length keys. Tests 32 & 42 in
+ db-btree.t and test 27 in db-hash.t failed because of this change.
+ Those tests have been zapped.
+
+ Added dbinfo to the distribution.
+
+1.60
+ Changed the test to check for full tied array support
diff --git a/contrib/perl5/ext/DB_File/DB_File.pm b/contrib/perl5/ext/DB_File/DB_File.pm
new file mode 100644
index 000000000000..fcd0746a5e90
--- /dev/null
+++ b/contrib/perl5/ext/DB_File/DB_File.pm
@@ -0,0 +1,1695 @@
+# DB_File.pm -- Perl 5 interface to Berkeley DB
+#
+# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
+# last modified 16th May 1998
+# version 1.60
+#
+# Copyright (c) 1995-8 Paul Marquess. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+
+package DB_File::HASHINFO ;
+
+require 5.003 ;
+
+use strict;
+use Carp;
+require Tie::Hash;
+@DB_File::HASHINFO::ISA = qw(Tie::Hash);
+
+sub new
+{
+ my $pkg = shift ;
+ my %x ;
+ tie %x, $pkg ;
+ bless \%x, $pkg ;
+}
+
+
+sub TIEHASH
+{
+ my $pkg = shift ;
+
+ bless { VALID => { map {$_, 1}
+ qw( bsize ffactor nelem cachesize hash lorder)
+ },
+ GOT => {}
+ }, $pkg ;
+}
+
+
+sub FETCH
+{
+ my $self = shift ;
+ my $key = shift ;
+
+ return $self->{GOT}{$key} if exists $self->{VALID}{$key} ;
+
+ my $pkg = ref $self ;
+ croak "${pkg}::FETCH - Unknown element '$key'" ;
+}
+
+
+sub STORE
+{
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+
+ if ( exists $self->{VALID}{$key} )
+ {
+ $self->{GOT}{$key} = $value ;
+ return ;
+ }
+
+ my $pkg = ref $self ;
+ croak "${pkg}::STORE - Unknown element '$key'" ;
+}
+
+sub DELETE
+{
+ my $self = shift ;
+ my $key = shift ;
+
+ if ( exists $self->{VALID}{$key} )
+ {
+ delete $self->{GOT}{$key} ;
+ return ;
+ }
+
+ my $pkg = ref $self ;
+ croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ;
+}
+
+sub EXISTS
+{
+ my $self = shift ;
+ my $key = shift ;
+
+ exists $self->{VALID}{$key} ;
+}
+
+sub NotHere
+{
+ my $self = shift ;
+ my $method = shift ;
+
+ croak ref($self) . " does not define the method ${method}" ;
+}
+
+sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") }
+sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") }
+sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") }
+
+package DB_File::RECNOINFO ;
+
+use strict ;
+
+@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
+
+sub TIEHASH
+{
+ my $pkg = shift ;
+
+ bless { VALID => { map {$_, 1}
+ qw( bval cachesize psize flags lorder reclen bfname )
+ },
+ GOT => {},
+ }, $pkg ;
+}
+
+package DB_File::BTREEINFO ;
+
+use strict ;
+
+@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;
+
+sub TIEHASH
+{
+ my $pkg = shift ;
+
+ bless { VALID => { map {$_, 1}
+ qw( flags cachesize maxkeypage minkeypage psize
+ compare prefix lorder )
+ },
+ GOT => {},
+ }, $pkg ;
+}
+
+
+package DB_File ;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_version) ;
+use Carp;
+
+
+$VERSION = "1.60" ;
+
+#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
+$DB_BTREE = new DB_File::BTREEINFO ;
+$DB_HASH = new DB_File::HASHINFO ;
+$DB_RECNO = new DB_File::RECNOINFO ;
+
+require Tie::Hash;
+require Exporter;
+use AutoLoader;
+require DynaLoader;
+@ISA = qw(Tie::Hash Exporter DynaLoader);
+@EXPORT = qw(
+ $DB_BTREE $DB_HASH $DB_RECNO
+
+ BTREEMAGIC
+ BTREEVERSION
+ DB_LOCK
+ DB_SHMEM
+ DB_TXN
+ HASHMAGIC
+ HASHVERSION
+ MAX_PAGE_NUMBER
+ MAX_PAGE_OFFSET
+ MAX_REC_NUMBER
+ RET_ERROR
+ RET_SPECIAL
+ RET_SUCCESS
+ R_CURSOR
+ R_DUP
+ R_FIRST
+ R_FIXEDLEN
+ R_IAFTER
+ R_IBEFORE
+ R_LAST
+ R_NEXT
+ R_NOKEY
+ R_NOOVERWRITE
+ R_PREV
+ R_RECNOSYNC
+ R_SETCURSOR
+ R_SNAPSHOT
+ __R_UNUSED
+
+);
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ my($pack,$file,$line) = caller;
+ croak "Your vendor has not defined DB macro $constname, used at $file line $line.
+";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+
+eval {
+ # Make all Fcntl O_XXX constants available for importing
+ require Fcntl;
+ my @O = grep /^O_/, @Fcntl::EXPORT;
+ Fcntl->import(@O); # first we import what we want to export
+ push(@EXPORT, @O);
+};
+
+## import borrowed from IO::File
+## exports Fcntl constants if available.
+#sub import {
+# my $pkg = shift;
+# my $callpkg = caller;
+# Exporter::export $pkg, $callpkg, @_;
+# eval {
+# require Fcntl;
+# Exporter::export 'Fcntl', $callpkg, '/^O_/';
+# };
+#}
+
+bootstrap DB_File $VERSION;
+
+# Preloaded methods go here. Autoload methods go after __END__, and are
+# processed by the autosplit program.
+
+sub tie_hash_or_array
+{
+ my (@arg) = @_ ;
+ my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ;
+
+ $arg[4] = tied %{ $arg[4] }
+ if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;
+
+ # make recno in Berkeley DB version 2 work like recno in version 1.
+ if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and
+ $arg[1] and ! -e $arg[1]) {
+ open(FH, ">$arg[1]") or return undef ;
+ close FH ;
+ chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ;
+ }
+
+ DoTie_($tieHASH, @arg) ;
+}
+
+sub TIEHASH
+{
+ tie_hash_or_array(@_) ;
+}
+
+sub TIEARRAY
+{
+ tie_hash_or_array(@_) ;
+}
+
+sub CLEAR
+{
+ my $self = shift;
+ my $key = "" ;
+ my $value = "" ;
+ my $status = $self->seq($key, $value, R_FIRST());
+ my @keys;
+
+ while ($status == 0) {
+ push @keys, $key;
+ $status = $self->seq($key, $value, R_NEXT());
+ }
+ foreach $key (reverse @keys) {
+ my $s = $self->del($key);
+ }
+}
+
+sub EXTEND { }
+
+sub STORESIZE
+{
+ my $self = shift;
+ my $length = shift ;
+ my $current_length = $self->length() ;
+
+ if ($length < $current_length) {
+ my $key ;
+ for ($key = $current_length - 1 ; $key >= $length ; -- $key)
+ { $self->del($key) }
+ }
+ elsif ($length > $current_length) {
+ $self->put($length-1, "") ;
+ }
+}
+
+sub get_dup
+{
+ croak "Usage: \$db->get_dup(key [,flag])\n"
+ unless @_ == 2 or @_ == 3 ;
+
+ my $db = shift ;
+ my $key = shift ;
+ my $flag = shift ;
+ my $value = 0 ;
+ my $origkey = $key ;
+ my $wantarray = wantarray ;
+ my %values = () ;
+ my @values = () ;
+ my $counter = 0 ;
+ my $status = 0 ;
+
+ # iterate through the database until either EOF ($status == 0)
+ # or a different key is encountered ($key ne $origkey).
+ for ($status = $db->seq($key, $value, R_CURSOR()) ;
+ $status == 0 and $key eq $origkey ;
+ $status = $db->seq($key, $value, R_NEXT()) ) {
+
+ # save the value or count number of matches
+ if ($wantarray) {
+ if ($flag)
+ { ++ $values{$value} }
+ else
+ { push (@values, $value) }
+ }
+ else
+ { ++ $counter }
+
+ }
+
+ return ($wantarray ? ($flag ? %values : @values) : $counter) ;
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+DB_File - Perl5 access to Berkeley DB version 1.x
+
+=head1 SYNOPSIS
+
+ use DB_File ;
+
+ [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ;
+ [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ;
+ [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ;
+
+ $status = $X->del($key [, $flags]) ;
+ $status = $X->put($key, $value [, $flags]) ;
+ $status = $X->get($key, $value [, $flags]) ;
+ $status = $X->seq($key, $value, $flags) ;
+ $status = $X->sync([$flags]) ;
+ $status = $X->fd ;
+
+ # BTREE only
+ $count = $X->get_dup($key) ;
+ @list = $X->get_dup($key) ;
+ %list = $X->get_dup($key, 1) ;
+
+ # RECNO only
+ $a = $X->length;
+ $a = $X->pop ;
+ $X->push(list);
+ $a = $X->shift;
+ $X->unshift(list);
+
+ untie %hash ;
+ untie @array ;
+
+=head1 DESCRIPTION
+
+B<DB_File> is a module which allows Perl programs to make use of the
+facilities provided by Berkeley DB version 1.x (if you have a newer
+version of DB, see L<Using DB_File with Berkeley DB version 2>). It is
+assumed that you have a copy of the Berkeley DB manual pages at hand
+when reading this documentation. The interface defined here mirrors the
+Berkeley DB interface closely.
+
+Berkeley DB is a C library which provides a consistent interface to a
+number of database formats. B<DB_File> provides an interface to all
+three of the database types currently supported by Berkeley DB.
+
+The file types are:
+
+=over 5
+
+=item B<DB_HASH>
+
+This database type allows arbitrary key/value pairs to be stored in data
+files. This is equivalent to the functionality provided by other
+hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though,
+the files created using DB_HASH are not compatible with any of the
+other packages mentioned.
+
+A default hashing algorithm, which will be adequate for most
+applications, is built into Berkeley DB. If you do need to use your own
+hashing algorithm it is possible to write your own in Perl and have
+B<DB_File> use it instead.
+
+=item B<DB_BTREE>
+
+The btree format allows arbitrary key/value pairs to be stored in a
+sorted, balanced binary tree.
+
+As with the DB_HASH format, it is possible to provide a user defined
+Perl routine to perform the comparison of keys. By default, though, the
+keys are stored in lexical order.
+
+=item B<DB_RECNO>
+
+DB_RECNO allows both fixed-length and variable-length flat text files
+to be manipulated using the same key/value pair interface as in DB_HASH
+and DB_BTREE. In this case the key will consist of a record (line)
+number.
+
+=back
+
+=head2 Using DB_File with Berkeley DB version 2
+
+Although B<DB_File> is intended to be used with Berkeley DB version 1,
+it can also be used with version 2. In this case the interface is
+limited to the functionality provided by Berkeley DB 1.x. Anywhere the
+version 2 interface differs, B<DB_File> arranges for it to work like
+version 1. This feature allows B<DB_File> scripts that were built with
+version 1 to be migrated to version 2 without any changes.
+
+If you want to make use of the new features available in Berkeley DB
+2.x, use the Perl module B<BerkeleyDB> instead.
+
+At the time of writing this document the B<BerkeleyDB> module is still
+alpha quality (the version number is < 1.0), and so unsuitable for use
+in any serious development work. Once its version number is >= 1.0, it
+is considered stable enough for real work.
+
+B<Note:> The database file format has changed in Berkeley DB version 2.
+If you cannot recreate your databases, you must dump any existing
+databases with the C<db_dump185> utility that comes with Berkeley DB.
+Once you have upgraded DB_File to use Berkeley DB version 2, your
+databases can be recreated using C<db_load>. Refer to the Berkeley DB
+documentation for further details.
+
+Please read L<COPYRIGHT> before using version 2.x of Berkeley DB with
+DB_File.
+
+=head2 Interface to Berkeley DB
+
+B<DB_File> allows access to Berkeley DB files using the tie() mechanism
+in Perl 5 (for full details, see L<perlfunc/tie()>). This facility
+allows B<DB_File> to access Berkeley DB files using either an
+associative array (for DB_HASH & DB_BTREE file types) or an ordinary
+array (for the DB_RECNO file type).
+
+In addition to the tie() interface, it is also possible to access most
+of the functions provided in the Berkeley DB API directly.
+See L<THE API INTERFACE>.
+
+=head2 Opening a Berkeley DB Database File
+
+Berkeley DB uses the function dbopen() to open or create a database.
+Here is the C prototype for dbopen():
+
+ DB*
+ dbopen (const char * file, int flags, int mode,
+ DBTYPE type, const void * openinfo)
+
+The parameter C<type> is an enumeration which specifies which of the 3
+interface methods (DB_HASH, DB_BTREE or DB_RECNO) is to be used.
+Depending on which of these is actually chosen, the final parameter,
+I<openinfo> points to a data structure which allows tailoring of the
+specific interface method.
+
+This interface is handled slightly differently in B<DB_File>. Here is
+an equivalent call using B<DB_File>:
+
+ tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ;
+
+The C<filename>, C<flags> and C<mode> parameters are the direct
+equivalent of their dbopen() counterparts. The final parameter $DB_HASH
+performs the function of both the C<type> and C<openinfo> parameters in
+dbopen().
+
+In the example above $DB_HASH is actually a pre-defined reference to a
+hash object. B<DB_File> has three of these pre-defined references.
+Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO.
+
+The keys allowed in each of these pre-defined references is limited to
+the names used in the equivalent C structure. So, for example, the
+$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>,
+C<ffactor>, C<hash>, C<lorder> and C<nelem>.
+
+To change one of these elements, just assign to it like this:
+
+ $DB_HASH->{'cachesize'} = 10000 ;
+
+The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are
+usually adequate for most applications. If you do need to create extra
+instances of these objects, constructors are available for each file
+type.
+
+Here are examples of the constructors and the valid options available
+for DB_HASH, DB_BTREE and DB_RECNO respectively.
+
+ $a = new DB_File::HASHINFO ;
+ $a->{'bsize'} ;
+ $a->{'cachesize'} ;
+ $a->{'ffactor'};
+ $a->{'hash'} ;
+ $a->{'lorder'} ;
+ $a->{'nelem'} ;
+
+ $b = new DB_File::BTREEINFO ;
+ $b->{'flags'} ;
+ $b->{'cachesize'} ;
+ $b->{'maxkeypage'} ;
+ $b->{'minkeypage'} ;
+ $b->{'psize'} ;
+ $b->{'compare'} ;
+ $b->{'prefix'} ;
+ $b->{'lorder'} ;
+
+ $c = new DB_File::RECNOINFO ;
+ $c->{'bval'} ;
+ $c->{'cachesize'} ;
+ $c->{'psize'} ;
+ $c->{'flags'} ;
+ $c->{'lorder'} ;
+ $c->{'reclen'} ;
+ $c->{'bfname'} ;
+
+The values stored in the hashes above are mostly the direct equivalent
+of their C counterpart. Like their C counterparts, all are set to a
+default values - that means you don't have to set I<all> of the
+values when you only want to change one. Here is an example:
+
+ $a = new DB_File::HASHINFO ;
+ $a->{'cachesize'} = 12345 ;
+ tie %y, 'DB_File', "filename", $flags, 0777, $a ;
+
+A few of the options need extra discussion here. When used, the C
+equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers
+to C functions. In B<DB_File> these keys are used to store references
+to Perl subs. Below are templates for each of the subs:
+
+ sub hash
+ {
+ my ($data) = @_ ;
+ ...
+ # return the hash value for $data
+ return $hash ;
+ }
+
+ sub compare
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return 0 if $key1 eq $key2
+ # -1 if $key1 lt $key2
+ # 1 if $key1 gt $key2
+ return (-1 , 0 or 1) ;
+ }
+
+ sub prefix
+ {
+ my ($key, $key2) = @_ ;
+ ...
+ # return number of bytes of $key2 which are
+ # necessary to determine that it is greater than $key1
+ return $bytes ;
+ }
+
+See L<Changing the BTREE sort order> for an example of using the
+C<compare> template.
+
+If you are using the DB_RECNO interface and you intend making use of
+C<bval>, you should check out L<The 'bval' Option>.
+
+=head2 Default Parameters
+
+It is possible to omit some or all of the final 4 parameters in the
+call to C<tie> and let them take default values. As DB_HASH is the most
+common file format used, the call:
+
+ tie %A, "DB_File", "filename" ;
+
+is equivalent to:
+
+ tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ;
+
+It is also possible to omit the filename parameter as well, so the
+call:
+
+ tie %A, "DB_File" ;
+
+is equivalent to:
+
+ tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ;
+
+See L<In Memory Databases> for a discussion on the use of C<undef>
+in place of a filename.
+
+=head2 In Memory Databases
+
+Berkeley DB allows the creation of in-memory databases by using NULL
+(that is, a C<(char *)0> in C) in place of the filename. B<DB_File>
+uses C<undef> instead of NULL to provide this functionality.
+
+=head1 DB_HASH
+
+The DB_HASH file format is probably the most commonly used of the three
+file formats that B<DB_File> supports. It is also very straightforward
+to use.
+
+=head2 A Simple Example
+
+This example shows how to create a database, add key/value pairs to the
+database, delete keys/value pairs and finally how to enumerate the
+contents of the database.
+
+ use strict ;
+ use DB_File ;
+ use vars qw( %h $k $v ) ;
+
+ tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH
+ or die "Cannot open file 'fruit': $!\n";
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+
+here is the output:
+
+ Banana Exists
+
+ orange -> orange
+ tomato -> red
+ banana -> yellow
+
+Note that the like ordinary associative arrays, the order of the keys
+retrieved is in an apparently random order.
+
+=head1 DB_BTREE
+
+The DB_BTREE format is useful when you want to store data in a given
+order. By default the keys will be stored in lexical order, but as you
+will see from the example shown in the next section, it is very easy to
+define your own sorting function.
+
+=head2 Changing the BTREE sort order
+
+This script shows how to override the default sorting algorithm that
+BTREE uses. Instead of using the normal lexical ordering, a case
+insensitive compare function will be used.
+
+ use strict ;
+ use DB_File ;
+
+ my %h ;
+
+ sub Compare
+ {
+ my ($key1, $key2) = @_ ;
+ "\L$key1" cmp "\L$key2" ;
+ }
+
+ # specify the Perl sub that will do the comparison
+ $DB_BTREE->{'compare'} = \&Compare ;
+
+ tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open file 'tree': $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+
+Here is the output from the code above.
+
+ mouse
+ Smith
+ Wall
+
+There are a few point to bear in mind if you want to change the
+ordering in a BTREE database:
+
+=over 5
+
+=item 1.
+
+The new compare function must be specified when you create the database.
+
+=item 2.
+
+You cannot change the ordering once the database has been created. Thus
+you must use the same compare function every time you access the
+database.
+
+=back
+
+=head2 Handling Duplicate Keys
+
+The BTREE file type optionally allows a single key to be associated
+with an arbitrary number of values. This option is enabled by setting
+the flags element of C<$DB_BTREE> to R_DUP when creating the database.
+
+There are some difficulties in using the tied hash interface if you
+want to manipulate a BTREE database with duplicate keys. Consider this
+code:
+
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename %h ) ;
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+
+ # iterate through the associative array
+ # and print each key/value pair.
+ foreach (keys %h)
+ { print "$_ -> $h{$_}\n" }
+
+ untie %h ;
+
+Here is the output:
+
+ Smith -> John
+ Wall -> Larry
+ Wall -> Larry
+ Wall -> Larry
+ mouse -> mickey
+
+As you can see 3 records have been successfully created with key C<Wall>
+- the only thing is, when they are retrieved from the database they
+I<seem> to have the same value, namely C<Larry>. The problem is caused
+by the way that the associative array interface works. Basically, when
+the associative array interface is used to fetch the value associated
+with a given key, it will only ever retrieve the first value.
+
+Although it may not be immediately obvious from the code above, the
+associative array interface can be used to write values with duplicate
+keys, but it cannot be used to read them back from the database.
+
+The way to get around this problem is to use the Berkeley DB API method
+called C<seq>. This method allows sequential access to key/value
+pairs. See L<THE API INTERFACE> for details of both the C<seq> method
+and the API in general.
+
+Here is the script above rewritten using the C<seq> API method.
+
+ use strict ;
+ use DB_File ;
+
+ use vars qw($filename $x %h $status $key $value) ;
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ # Enable duplicate records
+ $DB_BTREE->{'flags'} = R_DUP ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key
+ $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+
+ # iterate through the btree using seq
+ # and print each key/value pair.
+ $key = $value = 0 ;
+ for ($status = $x->seq($key, $value, R_FIRST) ;
+ $status == 0 ;
+ $status = $x->seq($key, $value, R_NEXT) )
+ { print "$key -> $value\n" }
+
+ undef $x ;
+ untie %h ;
+
+that prints:
+
+ Smith -> John
+ Wall -> Brick
+ Wall -> Brick
+ Wall -> Larry
+ mouse -> mickey
+
+This time we have got all the key/value pairs, including the multiple
+values associated with the key C<Wall>.
+
+=head2 The get_dup() Method
+
+B<DB_File> comes with a utility method, called C<get_dup>, to assist in
+reading duplicate values from BTREE databases. The method can take the
+following forms:
+
+ $count = $x->get_dup($key) ;
+ @list = $x->get_dup($key) ;
+ %list = $x->get_dup($key, 1) ;
+
+In a scalar context the method returns the number of values associated
+with the key, C<$key>.
+
+In list context, it returns all the values which match C<$key>. Note
+that the values will be returned in an apparently random order.
+
+In list context, if the second parameter is present and evaluates
+TRUE, the method returns an associative array. The keys of the
+associative array correspond to the values that matched in the BTREE
+and the values of the array are a count of the number of times that
+particular value occurred in the BTREE.
+
+So assuming the database created above, we can use C<get_dup> like
+this:
+
+ my $cnt = $x->get_dup("Wall") ;
+ print "Wall occurred $cnt times\n" ;
+
+ my %hash = $x->get_dup("Wall", 1) ;
+ print "Larry is there\n" if $hash{'Larry'} ;
+ print "There are $hash{'Brick'} Brick Walls\n" ;
+
+ my @list = $x->get_dup("Wall") ;
+ print "Wall => [@list]\n" ;
+
+ @list = $x->get_dup("Smith") ;
+ print "Smith => [@list]\n" ;
+
+ @list = $x->get_dup("Dog") ;
+ print "Dog => [@list]\n" ;
+
+
+and it will print:
+
+ Wall occurred 3 times
+ Larry is there
+ There are 2 Brick Walls
+ Wall => [Brick Brick Larry]
+ Smith => [John]
+ Dog => []
+
+=head2 Matching Partial Keys
+
+The BTREE interface has a feature which allows partial keys to be
+matched. This functionality is I<only> available when the C<seq> method
+is used along with the R_CURSOR flag.
+
+ $x->seq($key, $value, R_CURSOR) ;
+
+Here is the relevant quote from the dbopen man page where it defines
+the use of the R_CURSOR flag with seq:
+
+ Note, for the DB_BTREE access method, the returned key is not
+ necessarily an exact match for the specified key. The returned key
+ is the smallest key greater than or equal to the specified key,
+ permitting partial key matches and range searches.
+
+In the example script below, the C<match> sub uses this feature to find
+and print the first matching key/value pair given a partial key.
+
+ use strict ;
+ use DB_File ;
+ use Fcntl ;
+
+ use vars qw($filename $x %h $st $key $value) ;
+
+ sub match
+ {
+ my $key = shift ;
+ my $value = 0;
+ my $orig_key = $key ;
+ $x->seq($key, $value, R_CURSOR) ;
+ print "$orig_key\t-> $key\t-> $value\n" ;
+ }
+
+ $filename = "tree" ;
+ unlink $filename ;
+
+ $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open $filename: $!\n";
+
+ # Add some key/value pairs to the file
+ $h{'mouse'} = 'mickey' ;
+ $h{'Wall'} = 'Larry' ;
+ $h{'Walls'} = 'Brick' ;
+ $h{'Smith'} = 'John' ;
+
+
+ $key = $value = 0 ;
+ print "IN ORDER\n" ;
+ for ($st = $x->seq($key, $value, R_FIRST) ;
+ $st == 0 ;
+ $st = $x->seq($key, $value, R_NEXT) )
+
+ { print "$key -> $value\n" }
+
+ print "\nPARTIAL MATCH\n" ;
+
+ match "Wa" ;
+ match "A" ;
+ match "a" ;
+
+ undef $x ;
+ untie %h ;
+
+Here is the output:
+
+ IN ORDER
+ Smith -> John
+ Wall -> Larry
+ Walls -> Brick
+ mouse -> mickey
+
+ PARTIAL MATCH
+ Wa -> Wall -> Larry
+ A -> Smith -> John
+ a -> mouse -> mickey
+
+=head1 DB_RECNO
+
+DB_RECNO provides an interface to flat text files. Both variable and
+fixed length records are supported.
+
+In order to make RECNO more compatible with Perl the array offset for
+all RECNO arrays begins at 0 rather than 1 as in Berkeley DB.
+
+As with normal Perl arrays, a RECNO array can be accessed using
+negative indexes. The index -1 refers to the last element of the array,
+-2 the second last, and so on. Attempting to access an element before
+the start of the array will raise a fatal run-time error.
+
+=head2 The 'bval' Option
+
+The operation of the bval option warrants some discussion. Here is the
+definition of bval from the Berkeley DB 1.85 recno manual page:
+
+ The delimiting byte to be used to mark the end of a
+ record for variable-length records, and the pad charac-
+ ter for fixed-length records. If no value is speci-
+ fied, newlines (``\n'') are used to mark the end of
+ variable-length records and fixed-length records are
+ padded with spaces.
+
+The second sentence is wrong. In actual fact bval will only default to
+C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL
+openinfo parameter is used at all, the value that happens to be in bval
+will be used. That means you always have to specify bval when making
+use of any of the options in the openinfo parameter. This documentation
+error will be fixed in the next release of Berkeley DB.
+
+That clarifies the situation with regards Berkeley DB itself. What
+about B<DB_File>? Well, the behavior defined in the quote above is
+quite useful, so B<DB_File> conforms it.
+
+That means that you can specify other options (e.g. cachesize) and
+still have bval default to C<"\n"> for variable length records, and
+space for fixed length records.
+
+=head2 A Simple Example
+
+Here is a simple example that uses RECNO.
+
+ use strict ;
+ use DB_File ;
+
+ my @h ;
+ tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO
+ or die "Cannot open file 'text': $!\n" ;
+
+ # Add a few key/value pairs to the file
+ $h[0] = "orange" ;
+ $h[1] = "blue" ;
+ $h[2] = "yellow" ;
+
+ # Check for existence of a key
+ print "Element 1 Exists with value $h[1]\n" if $h[1] ;
+
+ # use a negative index
+ print "The last element is $h[-1]\n" ;
+ print "The 2nd last element is $h[-2]\n" ;
+
+ untie @h ;
+
+Here is the output from the script:
+
+
+ Element 1 Exists with value blue
+ The last element is yellow
+ The 2nd last element is blue
+
+=head2 Extra Methods
+
+If you are using a version of Perl earlier than 5.004_57, the tied
+array interface is quite limited. The example script above will work,
+but you won't be able to use C<push>, C<pop>, C<shift>, C<unshift>
+etc. with the tied array.
+
+To make the interface more useful for older versions of Perl, a number
+of methods are supplied with B<DB_File> to simulate the missing array
+operations. All these methods are accessed via the object returned from
+the tie call.
+
+Here are the methods:
+
+=over 5
+
+=item B<$X-E<gt>push(list) ;>
+
+Pushes the elements of C<list> to the end of the array.
+
+=item B<$value = $X-E<gt>pop ;>
+
+Removes and returns the last element of the array.
+
+=item B<$X-E<gt>shift>
+
+Removes and returns the first element of the array.
+
+=item B<$X-E<gt>unshift(list) ;>
+
+Pushes the elements of C<list> to the start of the array.
+
+=item B<$X-E<gt>length>
+
+Returns the number of elements in the array.
+
+=back
+
+=head2 Another Example
+
+Here is a more complete example that makes use of some of the methods
+described above. It also makes use of the API interface directly (see
+L<THE API INTERFACE>).
+
+ use strict ;
+ use vars qw(@h $H $file $i) ;
+ use DB_File ;
+ use Fcntl ;
+
+ $file = "text" ;
+
+ unlink $file ;
+
+ $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO
+ or die "Cannot open file $file: $!\n" ;
+
+ # first create a text file to play with
+ $h[0] = "zero" ;
+ $h[1] = "one" ;
+ $h[2] = "two" ;
+ $h[3] = "three" ;
+ $h[4] = "four" ;
+
+
+ # Print the records in order.
+ #
+ # The length method is needed here because evaluating a tied
+ # array in a scalar context does not return the number of
+ # elements in the array.
+
+ print "\nORIGINAL\n" ;
+ foreach $i (0 .. $H->length - 1) {
+ print "$i: $h[$i]\n" ;
+ }
+
+ # use the push & pop methods
+ $a = $H->pop ;
+ $H->push("last") ;
+ print "\nThe last record was [$a]\n" ;
+
+ # and the shift & unshift methods
+ $a = $H->shift ;
+ $H->unshift("first") ;
+ print "The first record was [$a]\n" ;
+
+ # Use the API to add a new record after record 2.
+ $i = 2 ;
+ $H->put($i, "Newbie", R_IAFTER) ;
+
+ # and a new record before record 1.
+ $i = 1 ;
+ $H->put($i, "New One", R_IBEFORE) ;
+
+ # delete record 3
+ $H->del(3) ;
+
+ # now print the records in reverse order
+ print "\nREVERSE\n" ;
+ for ($i = $H->length - 1 ; $i >= 0 ; -- $i)
+ { print "$i: $h[$i]\n" }
+
+ # same again, but use the API functions instead
+ print "\nREVERSE again\n" ;
+ my ($s, $k, $v) = (0, 0, 0) ;
+ for ($s = $H->seq($k, $v, R_LAST) ;
+ $s == 0 ;
+ $s = $H->seq($k, $v, R_PREV))
+ { print "$k: $v\n" }
+
+ undef $H ;
+ untie @h ;
+
+and this is what it outputs:
+
+ ORIGINAL
+ 0: zero
+ 1: one
+ 2: two
+ 3: three
+ 4: four
+
+ The last record was [four]
+ The first record was [zero]
+
+ REVERSE
+ 5: last
+ 4: three
+ 3: Newbie
+ 2: one
+ 1: New One
+ 0: first
+
+ REVERSE again
+ 5: last
+ 4: three
+ 3: Newbie
+ 2: one
+ 1: New One
+ 0: first
+
+Notes:
+
+=over 5
+
+=item 1.
+
+Rather than iterating through the array, C<@h> like this:
+
+ foreach $i (@h)
+
+it is necessary to use either this:
+
+ foreach $i (0 .. $H->length - 1)
+
+or this:
+
+ for ($a = $H->get($k, $v, R_FIRST) ;
+ $a == 0 ;
+ $a = $H->get($k, $v, R_NEXT) )
+
+=item 2.
+
+Notice that both times the C<put> method was used the record index was
+specified using a variable, C<$i>, rather than the literal value
+itself. This is because C<put> will return the record number of the
+inserted line via that parameter.
+
+=back
+
+=head1 THE API INTERFACE
+
+As well as accessing Berkeley DB using a tied hash or array, it is also
+possible to make direct use of most of the API functions defined in the
+Berkeley DB documentation.
+
+To do this you need to store a copy of the object returned from the tie.
+
+ $db = tie %hash, "DB_File", "filename" ;
+
+Once you have done that, you can access the Berkeley DB API functions
+as B<DB_File> methods directly like this:
+
+ $db->put($key, $value, R_NOOVERWRITE) ;
+
+B<Important:> If you have saved a copy of the object returned from
+C<tie>, the underlying database file will I<not> be closed until both
+the tied variable is untied and all copies of the saved object are
+destroyed.
+
+ use DB_File ;
+ $db = tie %hash, "DB_File", "filename"
+ or die "Cannot tie filename: $!" ;
+ ...
+ undef $db ;
+ untie %hash ;
+
+See L<The untie() Gotcha> for more details.
+
+All the functions defined in L<dbopen> are available except for
+close() and dbopen() itself. The B<DB_File> method interface to the
+supported functions have been implemented to mirror the way Berkeley DB
+works whenever possible. In particular note that:
+
+=over 5
+
+=item *
+
+The methods return a status value. All return 0 on success.
+All return -1 to signify an error and set C<$!> to the exact
+error code. The return code 1 generally (but not always) means that the
+key specified did not exist in the database.
+
+Other return codes are defined. See below and in the Berkeley DB
+documentation for details. The Berkeley DB documentation should be used
+as the definitive source.
+
+=item *
+
+Whenever a Berkeley DB function returns data via one of its parameters,
+the equivalent B<DB_File> method does exactly the same.
+
+=item *
+
+If you are careful, it is possible to mix API calls with the tied
+hash/array interface in the same piece of code. Although only a few of
+the methods used to implement the tied interface currently make use of
+the cursor, you should always assume that the cursor has been changed
+any time the tied hash/array interface is used. As an example, this
+code will probably not do what you expect:
+
+ $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE
+ or die "Cannot tie $filename: $!" ;
+
+ # Get the first key/value pair and set the cursor
+ $X->seq($key, $value, R_FIRST) ;
+
+ # this line will modify the cursor
+ $count = scalar keys %x ;
+
+ # Get the second key/value pair.
+ # oops, it didn't, it got the last key/value pair!
+ $X->seq($key, $value, R_NEXT) ;
+
+The code above can be rearranged to get around the problem, like this:
+
+ $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE
+ or die "Cannot tie $filename: $!" ;
+
+ # this line will modify the cursor
+ $count = scalar keys %x ;
+
+ # Get the first key/value pair and set the cursor
+ $X->seq($key, $value, R_FIRST) ;
+
+ # Get the second key/value pair.
+ # worked this time.
+ $X->seq($key, $value, R_NEXT) ;
+
+=back
+
+All the constants defined in L<dbopen> for use in the flags parameters
+in the methods defined below are also available. Refer to the Berkeley
+DB documentation for the precise meaning of the flags values.
+
+Below is a list of the methods available.
+
+=over 5
+
+=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;>
+
+Given a key (C<$key>) this method reads the value associated with it
+from the database. The value read from the database is returned in the
+C<$value> parameter.
+
+If the key does not exist the method returns 1.
+
+No flags are currently defined for this method.
+
+=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;>
+
+Stores the key/value pair in the database.
+
+If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter
+will have the record number of the inserted key/value pair set.
+
+Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and
+R_SETCURSOR.
+
+=item B<$status = $X-E<gt>del($key [, $flags]) ;>
+
+Removes all key/value pairs with key C<$key> from the database.
+
+A return code of 1 means that the requested key was not in the
+database.
+
+R_CURSOR is the only valid flag at present.
+
+=item B<$status = $X-E<gt>fd ;>
+
+Returns the file descriptor for the underlying database.
+
+See L<Locking Databases> for an example of how to make use of the
+C<fd> method to lock your database.
+
+=item B<$status = $X-E<gt>seq($key, $value, $flags) ;>
+
+This interface allows sequential retrieval from the database. See
+L<dbopen> for full details.
+
+Both the C<$key> and C<$value> parameters will be set to the key/value
+pair read from the database.
+
+The flags parameter is mandatory. The valid flag values are R_CURSOR,
+R_FIRST, R_LAST, R_NEXT and R_PREV.
+
+=item B<$status = $X-E<gt>sync([$flags]) ;>
+
+Flushes any cached buffers to disk.
+
+R_RECNOSYNC is the only valid flag at present.
+
+=back
+
+=head1 HINTS AND TIPS
+
+
+=head2 Locking Databases
+
+Concurrent access of a read-write database by several parties requires
+them all to use some kind of locking. Here's an example of Tom's that
+uses the I<fd> method to get the file descriptor, and then a careful
+open() to give something Perl will flock() for you. Run this repeatedly
+in the background to watch the locks granted in proper order.
+
+ use DB_File;
+
+ use strict;
+
+ sub LOCK_SH { 1 }
+ sub LOCK_EX { 2 }
+ sub LOCK_NB { 4 }
+ sub LOCK_UN { 8 }
+
+ my($oldval, $fd, $db, %db, $value, $key);
+
+ $key = shift || 'default';
+ $value = shift || 'magic';
+
+ $value .= " $$";
+
+ $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644)
+ || die "dbcreat /tmp/foo.db $!";
+ $fd = $db->fd;
+ print "$$: db fd is $fd\n";
+ open(DB_FH, "+<&=$fd") || die "dup $!";
+
+
+ unless (flock (DB_FH, LOCK_SH | LOCK_NB)) {
+ print "$$: CONTENTION; can't read during write update!
+ Waiting for read lock ($!) ....";
+ unless (flock (DB_FH, LOCK_SH)) { die "flock: $!" }
+ }
+ print "$$: Read lock granted\n";
+
+ $oldval = $db{$key};
+ print "$$: Old value was $oldval\n";
+ flock(DB_FH, LOCK_UN);
+
+ unless (flock (DB_FH, LOCK_EX | LOCK_NB)) {
+ print "$$: CONTENTION; must have exclusive lock!
+ Waiting for write lock ($!) ....";
+ unless (flock (DB_FH, LOCK_EX)) { die "flock: $!" }
+ }
+
+ print "$$: Write lock granted\n";
+ $db{$key} = $value;
+ $db->sync; # to flush
+ sleep 10;
+
+ flock(DB_FH, LOCK_UN);
+ undef $db;
+ untie %db;
+ close(DB_FH);
+ print "$$: Updated db to $key=$value\n";
+
+=head2 Sharing Databases With C Applications
+
+There is no technical reason why a Berkeley DB database cannot be
+shared by both a Perl and a C application.
+
+The vast majority of problems that are reported in this area boil down
+to the fact that C strings are NULL terminated, whilst Perl strings are
+not.
+
+Here is a real example. Netscape 2.0 keeps a record of the locations you
+visit along with the time you last visited them in a DB_HASH database.
+This is usually stored in the file F<~/.netscape/history.db>. The key
+field in the database is the location string and the value field is the
+time the location was last visited stored as a 4 byte binary value.
+
+If you haven't already guessed, the location string is stored with a
+terminating NULL. This means you need to be careful when accessing the
+database.
+
+Here is a snippet of code that is loosely based on Tom Christiansen's
+I<ggh> script (available from your nearest CPAN archive in
+F<authors/id/TOMC/scripts/nshist.gz>).
+
+ use strict ;
+ use DB_File ;
+ use Fcntl ;
+
+ use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ;
+ $dotdir = $ENV{HOME} || $ENV{LOGNAME};
+
+ $HISTORY = "$dotdir/.netscape/history.db";
+
+ tie %hist_db, 'DB_File', $HISTORY
+ or die "Cannot open $HISTORY: $!\n" ;;
+
+ # Dump the complete database
+ while ( ($href, $binary_time) = each %hist_db ) {
+
+ # remove the terminating NULL
+ $href =~ s/\x00$// ;
+
+ # convert the binary time into a user friendly string
+ $date = localtime unpack("V", $binary_time);
+ print "$date $href\n" ;
+ }
+
+ # check for the existence of a specific key
+ # remember to add the NULL
+ if ( $binary_time = $hist_db{"http://mox.perl.com/\x00"} ) {
+ $date = localtime unpack("V", $binary_time) ;
+ print "Last visited mox.perl.com on $date\n" ;
+ }
+ else {
+ print "Never visited mox.perl.com\n"
+ }
+
+ untie %hist_db ;
+
+=head2 The untie() Gotcha
+
+If you make use of the Berkeley DB API, it is I<very> strongly
+recommended that you read L<perltie/The untie Gotcha>.
+
+Even if you don't currently make use of the API interface, it is still
+worth reading it.
+
+Here is an example which illustrates the problem from a B<DB_File>
+perspective:
+
+ use DB_File ;
+ use Fcntl ;
+
+ my %x ;
+ my $X ;
+
+ $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_TRUNC
+ or die "Cannot tie first time: $!" ;
+
+ $x{123} = 456 ;
+
+ untie %x ;
+
+ tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT
+ or die "Cannot tie second time: $!" ;
+
+ untie %x ;
+
+When run, the script will produce this error message:
+
+ Cannot tie second time: Invalid argument at bad.file line 14.
+
+Although the error message above refers to the second tie() statement
+in the script, the source of the problem is really with the untie()
+statement that precedes it.
+
+Having read L<perltie> you will probably have already guessed that the
+error is caused by the extra copy of the tied object stored in C<$X>.
+If you haven't, then the problem boils down to the fact that the
+B<DB_File> destructor, DESTROY, will not be called until I<all>
+references to the tied object are destroyed. Both the tied variable,
+C<%x>, and C<$X> above hold a reference to the object. The call to
+untie() will destroy the first, but C<$X> still holds a valid
+reference, so the destructor will not get called and the database file
+F<tst.fil> will remain open. The fact that Berkeley DB then reports the
+attempt to open a database that is alreday open via the catch-all
+"Invalid argument" doesn't help.
+
+If you run the script with the C<-w> flag the error message becomes:
+
+ untie attempted while 1 inner references still exist at bad.file line 12.
+ Cannot tie second time: Invalid argument at bad.file line 14.
+
+which pinpoints the real problem. Finally the script can now be
+modified to fix the original problem by destroying the API object
+before the untie:
+
+ ...
+ $x{123} = 456 ;
+
+ undef $X ;
+ untie %x ;
+
+ $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT
+ ...
+
+
+=head1 COMMON QUESTIONS
+
+=head2 Why is there Perl source in my database?
+
+If you look at the contents of a database file created by DB_File,
+there can sometimes be part of a Perl script included in it.
+
+This happens because Berkeley DB uses dynamic memory to allocate
+buffers which will subsequently be written to the database file. Being
+dynamic, the memory could have been used for anything before DB
+malloced it. As Berkeley DB doesn't clear the memory once it has been
+allocated, the unused portions will contain random junk. In the case
+where a Perl script gets written to the database, the random junk will
+correspond to an area of dynamic memory that happened to be used during
+the compilation of the script.
+
+Unless you don't like the possibility of there being part of your Perl
+scripts embedded in a database file, this is nothing to worry about.
+
+=head2 How do I store complex data structures with DB_File?
+
+Although B<DB_File> cannot do this directly, there is a module which
+can layer transparently over B<DB_File> to accomplish this feat.
+
+Check out the MLDBM module, available on CPAN in the directory
+F<modules/by-module/MLDBM>.
+
+=head2 What does "Invalid Argument" mean?
+
+You will get this error message when one of the parameters in the
+C<tie> call is wrong. Unfortunately there are quite a few parameters to
+get wrong, so it can be difficult to figure out which one it is.
+
+Here are a couple of possibilities:
+
+=over 5
+
+=item 1.
+
+Attempting to reopen a database without closing it.
+
+=item 2.
+
+Using the O_WRONLY flag.
+
+=back
+
+=head2 What does "Bareword 'DB_File' not allowed" mean?
+
+You will encounter this particular error message when you have the
+C<strict 'subs'> pragma (or the full strict pragma) in your script.
+Consider this script:
+
+ use strict ;
+ use DB_File ;
+ use vars qw(%x) ;
+ tie %x, DB_File, "filename" ;
+
+Running it produces the error in question:
+
+ Bareword "DB_File" not allowed while "strict subs" in use
+
+To get around the error, place the word C<DB_File> in either single or
+double quotes, like this:
+
+ tie %x, "DB_File", "filename" ;
+
+Although it might seem like a real pain, it is really worth the effort
+of having a C<use strict> in all your scripts.
+
+=head1 HISTORY
+
+Moved to the Changes file.
+
+=head1 BUGS
+
+Some older versions of Berkeley DB had problems with fixed length
+records using the RECNO file format. This problem has been fixed since
+version 1.85 of Berkeley DB.
+
+I am sure there are bugs in the code. If you do find any, or can
+suggest any enhancements, I would welcome your comments.
+
+=head1 AVAILABILITY
+
+B<DB_File> comes with the standard Perl source distribution. Look in
+the directory F<ext/DB_File>. Given the amount of time between releases
+of Perl the version that ships with Perl is quite likely to be out of
+date, so the most recent version can always be found on CPAN (see
+L<perlmod/CPAN> for details), in the directory
+F<modules/by-module/DB_File>.
+
+This version of B<DB_File> will work with either version 1.x or 2.x of
+Berkeley DB, but is limited to the functionality provided by version 1.
+
+The official web site for Berkeley DB is
+F<http://www.sleepycat.com/db>. The ftp equivalent is
+F<ftp.sleepycat.com:/pub>. Both versions 1 and 2 of Berkeley DB are
+available there.
+
+Alternatively, Berkeley DB version 1 is available at your nearest CPAN
+archive in F<src/misc/db.1.85.tar.gz>.
+
+If you are running IRIX, then get Berkeley DB version 1 from
+F<http://reality.sgi.com/ariel>. It has the patches necessary to
+compile properly on IRIX 5.3.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-8 Paul Marquess. All rights reserved. This program
+is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.
+
+Although B<DB_File> is covered by the Perl license, the library it
+makes use of, namely Berkeley DB, is not. Berkeley DB has its own
+copyright and its own license. Please take the time to read it.
+
+Here are are few words taken from the Berkeley DB FAQ (at
+http://www.sleepycat.com) regarding the license:
+
+ Do I have to license DB to use it in Perl scripts?
+
+ No. The Berkeley DB license requires that software that uses
+ Berkeley DB be freely redistributable. In the case of Perl, that
+ software is Perl, and not your scripts. Any Perl scripts that you
+ write are your property, including scripts that make use of
+ Berkeley DB. Neither the Perl license nor the Berkeley DB license
+ place any restriction on what you may do with them.
+
+If you are in any doubt about the license situation, contact either the
+Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details.
+
+
+=head1 SEE ALSO
+
+L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>
+
+=head1 AUTHOR
+
+The DB_File interface was written by Paul Marquess
+E<lt>pmarquess@bfsec.bt.co.ukE<gt>.
+Questions about the DB system itself may be addressed to
+E<lt>db@sleepycat.com<gt>.
+
+=cut
diff --git a/contrib/perl5/ext/DB_File/DB_File.xs b/contrib/perl5/ext/DB_File/DB_File.xs
new file mode 100644
index 000000000000..c661023a3300
--- /dev/null
+++ b/contrib/perl5/ext/DB_File/DB_File.xs
@@ -0,0 +1,1497 @@
+/*
+
+ DB_File.xs -- Perl 5 interface to Berkeley DB
+
+ written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
+ last modified 16th May 1998
+ version 1.60
+
+ All comments/suggestions/problems are welcome
+
+ Copyright (c) 1995, 1996, 1997, 1998 Paul Marquess. All rights reserved.
+ This program is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+
+ Changes:
+ 0.1 - Initial Release
+ 0.2 - No longer bombs out if dbopen returns an error.
+ 0.3 - Added some support for multiple btree compares
+ 1.0 - Complete support for multiple callbacks added.
+ Fixed a problem with pushing a value onto an empty list.
+ 1.01 - Fixed a SunOS core dump problem.
+ The return value from TIEHASH wasn't set to NULL when
+ dbopen returned an error.
+ 1.02 - Use ALIAS to define TIEARRAY.
+ Removed some redundant commented code.
+ Merged OS2 code into the main distribution.
+ Allow negative subscripts with RECNO interface.
+ Changed the default flags to O_CREAT|O_RDWR
+ 1.03 - Added EXISTS
+ 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by
+ Dave Hammen, hammen@gothamcity.jsc.nasa.gov
+ 1.05 - Added logic to allow prefix & hash types to be specified via
+ Makefile.PL
+ 1.06 - Minor namespace cleanup: Localized PrintBtree.
+ 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n".
+ 1.08 - No change to DB_File.xs
+ 1.09 - Default mode for dbopen changed to 0666
+ 1.10 - Fixed fd method so that it still returns -1 for
+ in-memory files when db 1.86 is used.
+ 1.11 - No change to DB_File.xs
+ 1.12 - No change to DB_File.xs
+ 1.13 - Tidied up a few casts.
+ 1.14 - Made it illegal to tie an associative array to a RECNO
+ database and an ordinary array to a HASH or BTREE database.
+ 1.50 - Make work with both DB 1.x or DB 2.x
+ 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent
+ 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of
+ undefined value" warning with db_get and db_seq.
+ 1.53 - Added DB_RENUMBER to flags for recno.
+ 1.54 - Fixed bug in the fd method
+ 1.55 - Fix for AIX from Jarkko Hietaniemi
+ 1.56 - No change to DB_File.xs
+ 1.57 - added the #undef op to allow building with Threads support.
+ 1.58 - Fixed a problem with the use of sv_setpvn. When the
+ size is specified as 0, it does a strlen on the data.
+ This was ok for DB 1.x, but isn't for DB 2.x.
+ 1.59 - No change to DB_File.xs
+ 1.60 - Some code tidy up
+
+
+
+*/
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be
+ * shortly #included by the <db.h>) __attribute__ to the possibly
+ * already defined __attribute__, for example by GNUC or by Perl. */
+
+#undef __attribute__
+
+/* If Perl has been compiled with Threads support,the symbol op will
+ be defined here. This clashes with a field name in db.h, so get rid of it.
+ */
+#ifdef op
+#undef op
+#endif
+#include <db.h>
+
+#include <fcntl.h>
+
+/* #define TRACE */
+
+
+
+#ifdef DB_VERSION_MAJOR
+
+/* map version 2 features & constants onto their version 1 equivalent */
+
+#ifdef DB_Prefix_t
+#undef DB_Prefix_t
+#endif
+#define DB_Prefix_t size_t
+
+#ifdef DB_Hash_t
+#undef DB_Hash_t
+#endif
+#define DB_Hash_t u_int32_t
+
+/* DBTYPE stays the same */
+/* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */
+typedef DB_INFO INFO ;
+
+/* version 2 has db_recno_t in place of recno_t */
+typedef db_recno_t recno_t;
+
+
+#define R_CURSOR DB_SET_RANGE
+#define R_FIRST DB_FIRST
+#define R_IAFTER DB_AFTER
+#define R_IBEFORE DB_BEFORE
+#define R_LAST DB_LAST
+#define R_NEXT DB_NEXT
+#define R_NOOVERWRITE DB_NOOVERWRITE
+#define R_PREV DB_PREV
+#define R_SETCURSOR 0
+#define R_RECNOSYNC 0
+#define R_FIXEDLEN DB_FIXEDLEN
+#define R_DUP DB_DUP
+
+#define db_HA_hash h_hash
+#define db_HA_ffactor h_ffactor
+#define db_HA_nelem h_nelem
+#define db_HA_bsize db_pagesize
+#define db_HA_cachesize db_cachesize
+#define db_HA_lorder db_lorder
+
+#define db_BT_compare bt_compare
+#define db_BT_prefix bt_prefix
+#define db_BT_flags flags
+#define db_BT_psize db_pagesize
+#define db_BT_cachesize db_cachesize
+#define db_BT_lorder db_lorder
+#define db_BT_maxkeypage
+#define db_BT_minkeypage
+
+
+#define db_RE_reclen re_len
+#define db_RE_flags flags
+#define db_RE_bval re_pad
+#define db_RE_bfname re_source
+#define db_RE_psize db_pagesize
+#define db_RE_cachesize db_cachesize
+#define db_RE_lorder db_lorder
+
+#define TXN NULL,
+
+#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag)
+
+
+#define DBT_flags(x) x.flags = 0
+#define DB_flags(x, v) x |= v
+
+#else /* db version 1.x */
+
+typedef union INFO {
+ HASHINFO hash ;
+ RECNOINFO recno ;
+ BTREEINFO btree ;
+ } INFO ;
+
+
+#ifdef mDB_Prefix_t
+#ifdef DB_Prefix_t
+#undef DB_Prefix_t
+#endif
+#define DB_Prefix_t mDB_Prefix_t
+#endif
+
+#ifdef mDB_Hash_t
+#ifdef DB_Hash_t
+#undef DB_Hash_t
+#endif
+#define DB_Hash_t mDB_Hash_t
+#endif
+
+#define db_HA_hash hash.hash
+#define db_HA_ffactor hash.ffactor
+#define db_HA_nelem hash.nelem
+#define db_HA_bsize hash.bsize
+#define db_HA_cachesize hash.cachesize
+#define db_HA_lorder hash.lorder
+
+#define db_BT_compare btree.compare
+#define db_BT_prefix btree.prefix
+#define db_BT_flags btree.flags
+#define db_BT_psize btree.psize
+#define db_BT_cachesize btree.cachesize
+#define db_BT_lorder btree.lorder
+#define db_BT_maxkeypage btree.maxkeypage
+#define db_BT_minkeypage btree.minkeypage
+
+#define db_RE_reclen recno.reclen
+#define db_RE_flags recno.flags
+#define db_RE_bval recno.bval
+#define db_RE_bfname recno.bfname
+#define db_RE_psize recno.psize
+#define db_RE_cachesize recno.cachesize
+#define db_RE_lorder recno.lorder
+
+#define TXN
+
+#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag)
+#define DBT_flags(x)
+#define DB_flags(x, v)
+
+#endif /* db version 1 */
+
+
+
+#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, TXN &key, flags)
+#define db_STORE(db, key, value, flags) ((db->dbp)->put)(db->dbp, TXN &key, &value, flags)
+#define db_FETCH(db, key, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
+
+#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
+#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags)
+#ifdef DB_VERSION_MAJOR
+#define db_DESTROY(db) ((db->dbp)->close)(db->dbp, 0)
+#define db_close(db) ((db->dbp)->close)(db->dbp, 0)
+#define db_del(db, key, flags) ((flags & R_CURSOR) \
+ ? ((db->cursor)->c_del)(db->cursor, 0) \
+ : ((db->dbp)->del)(db->dbp, NULL, &key, flags) )
+
+#else
+
+#define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
+#define db_close(db) ((db->dbp)->close)(db->dbp)
+#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
+#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
+
+#endif
+
+#define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags)
+
+typedef struct {
+ DBTYPE type ;
+ DB * dbp ;
+ SV * compare ;
+ SV * prefix ;
+ SV * hash ;
+ int in_memory ;
+ INFO info ;
+#ifdef DB_VERSION_MAJOR
+ DBC * cursor ;
+#endif
+ } DB_File_type;
+
+typedef DB_File_type * DB_File ;
+typedef DBT DBTKEY ;
+
+#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
+
+#define OutputValue(arg, name) \
+ { if (RETVAL == 0) { \
+ my_sv_setpvn(arg, name.data, name.size) ; \
+ } \
+ }
+
+#define OutputKey(arg, name) \
+ { if (RETVAL == 0) \
+ { \
+ if (db->type != DB_RECNO) { \
+ my_sv_setpvn(arg, name.data, name.size); \
+ } \
+ else \
+ sv_setiv(arg, (I32)*(I32*)name.data - 1); \
+ } \
+ }
+
+
+/* Internal Global Data */
+static recno_t Value ;
+static recno_t zero = 0 ;
+static DB_File CurrentDB ;
+static DBTKEY empty ;
+
+#ifdef DB_VERSION_MAJOR
+
+static int
+db_put(db, key, value, flags)
+DB_File db ;
+DBTKEY key ;
+DBT value ;
+u_int flags ;
+
+{
+ int status ;
+
+ if (flags & R_CURSOR) {
+ status = ((db->cursor)->c_del)(db->cursor, 0);
+ if (status != 0)
+ return status ;
+
+ flags &= ~R_CURSOR ;
+ }
+
+ return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ;
+
+}
+
+#endif /* DB_VERSION_MAJOR */
+
+static void
+GetVersionInfo()
+{
+ SV * ver_sv = perl_get_sv("DB_File::db_version", TRUE) ;
+#ifdef DB_VERSION_MAJOR
+ int Major, Minor, Patch ;
+
+ (void)db_version(&Major, &Minor, &Patch) ;
+
+ /* check that libdb is recent enough */
+ if (Major == 2 && Minor == 0 && Patch < 5)
+ croak("DB_File needs Berkeley DB 2.0.5 or greater, you have %d.%d.%d\n",
+ Major, Minor, Patch) ;
+
+#if PATCHLEVEL > 3
+ sv_setpvf(ver_sv, "%d.%d", Major, Minor) ;
+#else
+ {
+ char buffer[40] ;
+ sprintf(buffer, "%d.%d", Major, Minor) ;
+ sv_setpv(ver_sv, buffer) ;
+ }
+#endif
+
+#else
+ sv_setiv(ver_sv, 1) ;
+#endif
+
+}
+
+
+static int
+btree_compare(key1, key2)
+const DBT * key1 ;
+const DBT * key2 ;
+{
+ dSP ;
+ void * data1, * data2 ;
+ int retval ;
+ int count ;
+
+ data1 = key1->data ;
+ data2 = key2->data ;
+
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (key1->size == 0)
+ data1 = "" ;
+ if (key2->size == 0)
+ data2 = "" ;
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,2) ;
+ PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
+ PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
+ PUTBACK ;
+
+ count = perl_call_sv(CurrentDB->compare, G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1)
+ croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ return (retval) ;
+
+}
+
+static DB_Prefix_t
+btree_prefix(key1, key2)
+const DBT * key1 ;
+const DBT * key2 ;
+{
+ dSP ;
+ void * data1, * data2 ;
+ int retval ;
+ int count ;
+
+ data1 = key1->data ;
+ data2 = key2->data ;
+
+ /* As newSVpv will assume that the data pointer is a null terminated C
+ string if the size parameter is 0, make sure that data points to an
+ empty string if the length is 0
+ */
+ if (key1->size == 0)
+ data1 = "" ;
+ if (key2->size == 0)
+ data2 = "" ;
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ EXTEND(SP,2) ;
+ PUSHs(sv_2mortal(newSVpv(data1,key1->size)));
+ PUSHs(sv_2mortal(newSVpv(data2,key2->size)));
+ PUTBACK ;
+
+ count = perl_call_sv(CurrentDB->prefix, G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1)
+ croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+
+ return (retval) ;
+}
+
+static DB_Hash_t
+hash_cb(data, size)
+const void * data ;
+size_t size ;
+{
+ dSP ;
+ int retval ;
+ int count ;
+
+ if (size == 0)
+ data = "" ;
+
+ /* DGH - Next two lines added to fix corrupted stack problem */
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+
+ XPUSHs(sv_2mortal(newSVpv((char*)data,size)));
+ PUTBACK ;
+
+ count = perl_call_sv(CurrentDB->hash, G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1)
+ croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
+
+ retval = POPi ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+
+ return (retval) ;
+}
+
+
+#ifdef TRACE
+
+static void
+PrintHash(hash)
+INFO * hash ;
+{
+ printf ("HASH Info\n") ;
+ printf (" hash = %s\n",
+ (hash->db_HA_hash != NULL ? "redefined" : "default")) ;
+ printf (" bsize = %d\n", hash->db_HA_bsize) ;
+ printf (" ffactor = %d\n", hash->db_HA_ffactor) ;
+ printf (" nelem = %d\n", hash->db_HA_nelem) ;
+ printf (" cachesize = %d\n", hash->db_HA_cachesize) ;
+ printf (" lorder = %d\n", hash->db_HA_lorder) ;
+
+}
+
+static void
+PrintRecno(recno)
+INFO * recno ;
+{
+ printf ("RECNO Info\n") ;
+ printf (" flags = %d\n", recno->db_RE_flags) ;
+ printf (" cachesize = %d\n", recno->db_RE_cachesize) ;
+ printf (" psize = %d\n", recno->db_RE_psize) ;
+ printf (" lorder = %d\n", recno->db_RE_lorder) ;
+ printf (" reclen = %ul\n", (unsigned long)recno->db_RE_reclen) ;
+ printf (" bval = %d 0x%x\n", recno->db_RE_bval, recno->db_RE_bval) ;
+ printf (" bfname = %d [%s]\n", recno->db_RE_bfname, recno->db_RE_bfname) ;
+}
+
+static void
+PrintBtree(btree)
+INFO * btree ;
+{
+ printf ("BTREE Info\n") ;
+ printf (" compare = %s\n",
+ (btree->db_BT_compare ? "redefined" : "default")) ;
+ printf (" prefix = %s\n",
+ (btree->db_BT_prefix ? "redefined" : "default")) ;
+ printf (" flags = %d\n", btree->db_BT_flags) ;
+ printf (" cachesize = %d\n", btree->db_BT_cachesize) ;
+ printf (" psize = %d\n", btree->db_BT_psize) ;
+#ifndef DB_VERSION_MAJOR
+ printf (" maxkeypage = %d\n", btree->db_BT_maxkeypage) ;
+ printf (" minkeypage = %d\n", btree->db_BT_minkeypage) ;
+#endif
+ printf (" lorder = %d\n", btree->db_BT_lorder) ;
+}
+
+#else
+
+#define PrintRecno(recno)
+#define PrintHash(hash)
+#define PrintBtree(btree)
+
+#endif /* TRACE */
+
+
+static I32
+GetArrayLength(db)
+DB_File db ;
+{
+ DBT key ;
+ DBT value ;
+ int RETVAL ;
+
+ DBT_flags(key) ;
+ DBT_flags(value) ;
+ RETVAL = do_SEQ(db, key, value, R_LAST) ;
+ if (RETVAL == 0)
+ RETVAL = *(I32 *)key.data ;
+ else /* No key means empty file */
+ RETVAL = 0 ;
+
+ return ((I32)RETVAL) ;
+}
+
+static recno_t
+GetRecnoKey(db, value)
+DB_File db ;
+I32 value ;
+{
+ if (value < 0) {
+ /* Get the length of the array */
+ I32 length = GetArrayLength(db) ;
+
+ /* check for attempt to write before start of array */
+ if (length + value + 1 <= 0)
+ croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ;
+
+ value = length + value + 1 ;
+ }
+ else
+ ++ value ;
+
+ return value ;
+}
+
+static DB_File
+ParseOpenInfo(isHASH, name, flags, mode, sv)
+int isHASH ;
+char * name ;
+int flags ;
+int mode ;
+SV * sv ;
+{
+ SV ** svp;
+ HV * action ;
+ DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
+ void * openinfo = NULL ;
+ INFO * info = &RETVAL->info ;
+
+/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */
+ Zero(RETVAL, 1, DB_File_type) ;
+
+ /* Default to HASH */
+ RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
+ RETVAL->type = DB_HASH ;
+
+ /* DGH - Next line added to avoid SEGV on existing hash DB */
+ CurrentDB = RETVAL;
+
+ /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */
+ RETVAL->in_memory = (name == NULL) ;
+
+ if (sv)
+ {
+ if (! SvROK(sv) )
+ croak ("type parameter is not a reference") ;
+
+ svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ;
+ if (svp && SvOK(*svp))
+ action = (HV*) SvRV(*svp) ;
+ else
+ croak("internal error") ;
+
+ if (sv_isa(sv, "DB_File::HASHINFO"))
+ {
+
+ if (!isHASH)
+ croak("DB_File can only tie an associative array to a DB_HASH database") ;
+
+ RETVAL->type = DB_HASH ;
+ openinfo = (void*)info ;
+
+ svp = hv_fetch(action, "hash", 4, FALSE);
+
+ if (svp && SvOK(*svp))
+ {
+ info->db_HA_hash = hash_cb ;
+ RETVAL->hash = newSVsv(*svp) ;
+ }
+ else
+ info->db_HA_hash = NULL ;
+
+ svp = hv_fetch(action, "ffactor", 7, FALSE);
+ info->db_HA_ffactor = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "nelem", 5, FALSE);
+ info->db_HA_nelem = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "bsize", 5, FALSE);
+ info->db_HA_bsize = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "cachesize", 9, FALSE);
+ info->db_HA_cachesize = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "lorder", 6, FALSE);
+ info->db_HA_lorder = svp ? SvIV(*svp) : 0;
+
+ PrintHash(info) ;
+ }
+ else if (sv_isa(sv, "DB_File::BTREEINFO"))
+ {
+ if (!isHASH)
+ croak("DB_File can only tie an associative array to a DB_BTREE database");
+
+ RETVAL->type = DB_BTREE ;
+ openinfo = (void*)info ;
+
+ svp = hv_fetch(action, "compare", 7, FALSE);
+ if (svp && SvOK(*svp))
+ {
+ info->db_BT_compare = btree_compare ;
+ RETVAL->compare = newSVsv(*svp) ;
+ }
+ else
+ info->db_BT_compare = NULL ;
+
+ svp = hv_fetch(action, "prefix", 6, FALSE);
+ if (svp && SvOK(*svp))
+ {
+ info->db_BT_prefix = btree_prefix ;
+ RETVAL->prefix = newSVsv(*svp) ;
+ }
+ else
+ info->db_BT_prefix = NULL ;
+
+ svp = hv_fetch(action, "flags", 5, FALSE);
+ info->db_BT_flags = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "cachesize", 9, FALSE);
+ info->db_BT_cachesize = svp ? SvIV(*svp) : 0;
+
+#ifndef DB_VERSION_MAJOR
+ svp = hv_fetch(action, "minkeypage", 10, FALSE);
+ info->btree.minkeypage = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "maxkeypage", 10, FALSE);
+ info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
+#endif
+
+ svp = hv_fetch(action, "psize", 5, FALSE);
+ info->db_BT_psize = svp ? SvIV(*svp) : 0;
+
+ svp = hv_fetch(action, "lorder", 6, FALSE);
+ info->db_BT_lorder = svp ? SvIV(*svp) : 0;
+
+ PrintBtree(info) ;
+
+ }
+ else if (sv_isa(sv, "DB_File::RECNOINFO"))
+ {
+ if (isHASH)
+ croak("DB_File can only tie an array to a DB_RECNO database");
+
+ RETVAL->type = DB_RECNO ;
+ openinfo = (void *)info ;
+
+ info->db_RE_flags = 0 ;
+
+ svp = hv_fetch(action, "flags", 5, FALSE);
+ info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0);
+
+ svp = hv_fetch(action, "reclen", 6, FALSE);
+ info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0);
+
+ svp = hv_fetch(action, "cachesize", 9, FALSE);
+ info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0);
+
+ svp = hv_fetch(action, "psize", 5, FALSE);
+ info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0);
+
+ svp = hv_fetch(action, "lorder", 6, FALSE);
+ info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0);
+
+#ifdef DB_VERSION_MAJOR
+ info->re_source = name ;
+ name = NULL ;
+#endif
+ svp = hv_fetch(action, "bfname", 6, FALSE);
+ if (svp && SvOK(*svp)) {
+ char * ptr = SvPV(*svp,PL_na) ;
+#ifdef DB_VERSION_MAJOR
+ name = (char*) PL_na ? ptr : NULL ;
+#else
+ info->db_RE_bfname = (char*) (PL_na ? ptr : NULL) ;
+#endif
+ }
+ else
+#ifdef DB_VERSION_MAJOR
+ name = NULL ;
+#else
+ info->db_RE_bfname = NULL ;
+#endif
+
+ svp = hv_fetch(action, "bval", 4, FALSE);
+#ifdef DB_VERSION_MAJOR
+ if (svp && SvOK(*svp))
+ {
+ int value ;
+ if (SvPOK(*svp))
+ value = (int)*SvPV(*svp, PL_na) ;
+ else
+ value = SvIV(*svp) ;
+
+ if (info->flags & DB_FIXEDLEN) {
+ info->re_pad = value ;
+ info->flags |= DB_PAD ;
+ }
+ else {
+ info->re_delim = value ;
+ info->flags |= DB_DELIMITER ;
+ }
+
+ }
+#else
+ if (svp && SvOK(*svp))
+ {
+ if (SvPOK(*svp))
+ info->db_RE_bval = (u_char)*SvPV(*svp, PL_na) ;
+ else
+ info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ;
+ DB_flags(info->flags, DB_DELIMITER) ;
+
+ }
+ else
+ {
+ if (info->db_RE_flags & R_FIXEDLEN)
+ info->db_RE_bval = (u_char) ' ' ;
+ else
+ info->db_RE_bval = (u_char) '\n' ;
+ DB_flags(info->flags, DB_DELIMITER) ;
+ }
+#endif
+
+#ifdef DB_RENUMBER
+ info->flags |= DB_RENUMBER ;
+#endif
+
+ PrintRecno(info) ;
+ }
+ else
+ croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO");
+ }
+
+
+ /* OS2 Specific Code */
+#ifdef OS2
+#ifdef __EMX__
+ flags |= O_BINARY;
+#endif /* __EMX__ */
+#endif /* OS2 */
+
+#ifdef DB_VERSION_MAJOR
+
+ {
+ int Flags = 0 ;
+ int status ;
+
+ /* Map 1.x flags to 2.x flags */
+ if ((flags & O_CREAT) == O_CREAT)
+ Flags |= DB_CREATE ;
+
+#ifdef O_NONBLOCK
+ if ((flags & O_NONBLOCK) == O_NONBLOCK)
+ Flags |= DB_EXCL ;
+#endif
+
+#if O_RDONLY == 0
+ if (flags == O_RDONLY)
+#else
+ if (flags & O_RDONLY) == O_RDONLY)
+#endif
+ Flags |= DB_RDONLY ;
+
+#ifdef O_NONBLOCK
+ if ((flags & O_TRUNC) == O_TRUNC)
+ Flags |= DB_TRUNCATE ;
+#endif
+
+ status = db_open(name, RETVAL->type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
+ if (status == 0)
+ status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
+
+ if (status)
+ RETVAL->dbp = NULL ;
+
+ }
+#else
+ RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
+#endif
+
+ return (RETVAL) ;
+}
+
+
+static int
+not_here(s)
+char *s;
+{
+ croak("DB_File::%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':
+ if (strEQ(name, "BTREEMAGIC"))
+#ifdef BTREEMAGIC
+ return BTREEMAGIC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "BTREEVERSION"))
+#ifdef BTREEVERSION
+ return BTREEVERSION;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'C':
+ break;
+ case 'D':
+ if (strEQ(name, "DB_LOCK"))
+#ifdef DB_LOCK
+ return DB_LOCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "DB_SHMEM"))
+#ifdef DB_SHMEM
+ return DB_SHMEM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "DB_TXN"))
+#ifdef DB_TXN
+ return (U32)DB_TXN;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'E':
+ break;
+ case 'F':
+ break;
+ case 'G':
+ break;
+ case 'H':
+ if (strEQ(name, "HASHMAGIC"))
+#ifdef HASHMAGIC
+ return HASHMAGIC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "HASHVERSION"))
+#ifdef HASHVERSION
+ return HASHVERSION;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'I':
+ break;
+ case 'J':
+ break;
+ case 'K':
+ break;
+ case 'L':
+ break;
+ case 'M':
+ if (strEQ(name, "MAX_PAGE_NUMBER"))
+#ifdef MAX_PAGE_NUMBER
+ return (U32)MAX_PAGE_NUMBER;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MAX_PAGE_OFFSET"))
+#ifdef MAX_PAGE_OFFSET
+ return MAX_PAGE_OFFSET;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MAX_REC_NUMBER"))
+#ifdef MAX_REC_NUMBER
+ return (U32)MAX_REC_NUMBER;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'N':
+ break;
+ case 'O':
+ break;
+ case 'P':
+ break;
+ case 'Q':
+ break;
+ case 'R':
+ if (strEQ(name, "RET_ERROR"))
+#ifdef RET_ERROR
+ return RET_ERROR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "RET_SPECIAL"))
+#ifdef RET_SPECIAL
+ return RET_SPECIAL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "RET_SUCCESS"))
+#ifdef RET_SUCCESS
+ return RET_SUCCESS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_CURSOR"))
+#ifdef R_CURSOR
+ return R_CURSOR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_DUP"))
+#ifdef R_DUP
+ return R_DUP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_FIRST"))
+#ifdef R_FIRST
+ return R_FIRST;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_FIXEDLEN"))
+#ifdef R_FIXEDLEN
+ return R_FIXEDLEN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_IAFTER"))
+#ifdef R_IAFTER
+ return R_IAFTER;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_IBEFORE"))
+#ifdef R_IBEFORE
+ return R_IBEFORE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_LAST"))
+#ifdef R_LAST
+ return R_LAST;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_NEXT"))
+#ifdef R_NEXT
+ return R_NEXT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_NOKEY"))
+#ifdef R_NOKEY
+ return R_NOKEY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_NOOVERWRITE"))
+#ifdef R_NOOVERWRITE
+ return R_NOOVERWRITE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_PREV"))
+#ifdef R_PREV
+ return R_PREV;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_RECNOSYNC"))
+#ifdef R_RECNOSYNC
+ return R_RECNOSYNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_SETCURSOR"))
+#ifdef R_SETCURSOR
+ return R_SETCURSOR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_SNAPSHOT"))
+#ifdef R_SNAPSHOT
+ return R_SNAPSHOT;
+#else
+ goto not_there;
+#endif
+ 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;
+ case '_':
+ break;
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+MODULE = DB_File PACKAGE = DB_File PREFIX = db_
+
+BOOT:
+ {
+ GetVersionInfo() ;
+
+ empty.data = &zero ;
+ empty.size = sizeof(recno_t) ;
+ DBT_flags(empty) ;
+ }
+
+double
+constant(name,arg)
+ char * name
+ int arg
+
+
+DB_File
+db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
+ int isHASH
+ char * dbtype
+ int flags
+ int mode
+ CODE:
+ {
+ char * name = (char *) NULL ;
+ SV * sv = (SV *) NULL ;
+
+ if (items >= 3 && SvOK(ST(2)))
+ name = (char*) SvPV(ST(2), PL_na) ;
+
+ if (items == 6)
+ sv = ST(5) ;
+
+ RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ;
+ if (RETVAL->dbp == NULL)
+ RETVAL = NULL ;
+ }
+ OUTPUT:
+ RETVAL
+
+int
+db_DESTROY(db)
+ DB_File db
+ INIT:
+ CurrentDB = db ;
+ CLEANUP:
+ if (db->hash)
+ SvREFCNT_dec(db->hash) ;
+ if (db->compare)
+ SvREFCNT_dec(db->compare) ;
+ if (db->prefix)
+ SvREFCNT_dec(db->prefix) ;
+ Safefree(db) ;
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+#endif
+
+
+int
+db_DELETE(db, key, flags=0)
+ DB_File db
+ DBTKEY key
+ u_int flags
+ INIT:
+ CurrentDB = db ;
+
+
+int
+db_EXISTS(db, key)
+ DB_File db
+ DBTKEY key
+ CODE:
+ {
+ DBT value ;
+
+ DBT_flags(value) ;
+ CurrentDB = db ;
+ RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ;
+ }
+ OUTPUT:
+ RETVAL
+
+int
+db_FETCH(db, key, flags=0)
+ DB_File db
+ DBTKEY key
+ u_int flags
+ CODE:
+ {
+ DBT value ;
+
+ DBT_flags(value) ;
+ CurrentDB = db ;
+ /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */
+ RETVAL = db_get(db, key, value, flags) ;
+ ST(0) = sv_newmortal();
+ OutputValue(ST(0), value)
+ }
+
+int
+db_STORE(db, key, value, flags=0)
+ DB_File db
+ DBTKEY key
+ DBT value
+ u_int flags
+ INIT:
+ CurrentDB = db ;
+
+
+int
+db_FIRSTKEY(db)
+ DB_File db
+ CODE:
+ {
+ DBTKEY key ;
+ DBT value ;
+ DB * Db = db->dbp ;
+
+ DBT_flags(key) ;
+ DBT_flags(value) ;
+ CurrentDB = db ;
+ RETVAL = do_SEQ(db, key, value, R_FIRST) ;
+ ST(0) = sv_newmortal();
+ OutputKey(ST(0), key) ;
+ }
+
+int
+db_NEXTKEY(db, key)
+ DB_File db
+ DBTKEY key
+ CODE:
+ {
+ DBT value ;
+ DB * Db = db->dbp ;
+
+ DBT_flags(value) ;
+ CurrentDB = db ;
+ RETVAL = do_SEQ(db, key, value, R_NEXT) ;
+ ST(0) = sv_newmortal();
+ OutputKey(ST(0), key) ;
+ }
+
+#
+# These would be nice for RECNO
+#
+
+int
+unshift(db, ...)
+ DB_File db
+ ALIAS: UNSHIFT = 1
+ CODE:
+ {
+ DBTKEY key ;
+ DBT value ;
+ int i ;
+ int One ;
+ DB * Db = db->dbp ;
+
+ DBT_flags(key) ;
+ DBT_flags(value) ;
+ CurrentDB = db ;
+#ifdef DB_VERSION_MAJOR
+ /* get the first value */
+ RETVAL = do_SEQ(db, key, value, DB_FIRST) ;
+ RETVAL = 0 ;
+#else
+ RETVAL = -1 ;
+#endif
+ for (i = items-1 ; i > 0 ; --i)
+ {
+ value.data = SvPV(ST(i), PL_na) ;
+ value.size = PL_na ;
+ One = 1 ;
+ key.data = &One ;
+ key.size = sizeof(int) ;
+#ifdef DB_VERSION_MAJOR
+ RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ;
+#else
+ RETVAL = (Db->put)(Db, &key, &value, R_IBEFORE) ;
+#endif
+ if (RETVAL != 0)
+ break;
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+I32
+pop(db)
+ DB_File db
+ ALIAS: POP = 1
+ CODE:
+ {
+ DBTKEY key ;
+ DBT value ;
+ DB * Db = db->dbp ;
+
+ DBT_flags(key) ;
+ DBT_flags(value) ;
+ CurrentDB = db ;
+
+ /* First get the final value */
+ RETVAL = do_SEQ(db, key, value, R_LAST) ;
+ ST(0) = sv_newmortal();
+ /* Now delete it */
+ if (RETVAL == 0)
+ {
+ /* the call to del will trash value, so take a copy now */
+ OutputValue(ST(0), value) ;
+ RETVAL = db_del(db, key, R_CURSOR) ;
+ if (RETVAL != 0)
+ sv_setsv(ST(0), &PL_sv_undef);
+ }
+ }
+
+I32
+shift(db)
+ DB_File db
+ ALIAS: SHIFT = 1
+ CODE:
+ {
+ DBT value ;
+ DBTKEY key ;
+ DB * Db = db->dbp ;
+
+ DBT_flags(key) ;
+ DBT_flags(value) ;
+ CurrentDB = db ;
+ /* get the first value */
+ RETVAL = do_SEQ(db, key, value, R_FIRST) ;
+ ST(0) = sv_newmortal();
+ /* Now delete it */
+ if (RETVAL == 0)
+ {
+ /* the call to del will trash value, so take a copy now */
+ OutputValue(ST(0), value) ;
+ RETVAL = db_del(db, key, R_CURSOR) ;
+ if (RETVAL != 0)
+ sv_setsv (ST(0), &PL_sv_undef) ;
+ }
+ }
+
+
+I32
+push(db, ...)
+ DB_File db
+ ALIAS: PUSH = 1
+ CODE:
+ {
+ DBTKEY key ;
+ DBTKEY * keyptr = &key ;
+ DBT value ;
+ DB * Db = db->dbp ;
+ int i ;
+
+ DBT_flags(key) ;
+ DBT_flags(value) ;
+ CurrentDB = db ;
+ /* Set the Cursor to the Last element */
+ RETVAL = do_SEQ(db, key, value, R_LAST) ;
+ if (RETVAL >= 0)
+ {
+ if (RETVAL == 1)
+ keyptr = &empty ;
+#ifdef DB_VERSION_MAJOR
+ for (i = 1 ; i < items ; ++i)
+ {
+
+ ++ (* (int*)key.data) ;
+ value.data = SvPV(ST(i), PL_na) ;
+ value.size = PL_na ;
+ RETVAL = (Db->put)(Db, NULL, &key, &value, 0) ;
+ if (RETVAL != 0)
+ break;
+ }
+#else
+ for (i = items - 1 ; i > 0 ; --i)
+ {
+ value.data = SvPV(ST(i), PL_na) ;
+ value.size = PL_na ;
+ RETVAL = (Db->put)(Db, keyptr, &value, R_IAFTER) ;
+ if (RETVAL != 0)
+ break;
+ }
+#endif
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+
+I32
+length(db)
+ DB_File db
+ ALIAS: FETCHSIZE = 1
+ CODE:
+ CurrentDB = db ;
+ RETVAL = GetArrayLength(db) ;
+ OUTPUT:
+ RETVAL
+
+
+#
+# Now provide an interface to the rest of the DB functionality
+#
+
+int
+db_del(db, key, flags=0)
+ DB_File db
+ DBTKEY key
+ u_int flags
+ CODE:
+ CurrentDB = db ;
+ RETVAL = db_del(db, key, flags) ;
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+ else if (RETVAL == DB_NOTFOUND)
+ RETVAL = 1 ;
+#endif
+ OUTPUT:
+ RETVAL
+
+
+int
+db_get(db, key, value, flags=0)
+ DB_File db
+ DBTKEY key
+ DBT value = NO_INIT
+ u_int flags
+ CODE:
+ CurrentDB = db ;
+ DBT_flags(value) ;
+ RETVAL = db_get(db, key, value, flags) ;
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+ else if (RETVAL == DB_NOTFOUND)
+ RETVAL = 1 ;
+#endif
+ OUTPUT:
+ RETVAL
+ value
+
+int
+db_put(db, key, value, flags=0)
+ DB_File db
+ DBTKEY key
+ DBT value
+ u_int flags
+ CODE:
+ CurrentDB = db ;
+ RETVAL = db_put(db, key, value, flags) ;
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+ else if (RETVAL == DB_KEYEXIST)
+ RETVAL = 1 ;
+#endif
+ OUTPUT:
+ RETVAL
+ key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key);
+
+int
+db_fd(db)
+ DB_File db
+ int status = 0 ;
+ CODE:
+ CurrentDB = db ;
+#ifdef DB_VERSION_MAJOR
+ RETVAL = -1 ;
+ status = (db->in_memory
+ ? -1
+ : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ;
+ if (status != 0)
+ RETVAL = -1 ;
+#else
+ RETVAL = (db->in_memory
+ ? -1
+ : ((db->dbp)->fd)(db->dbp) ) ;
+#endif
+ OUTPUT:
+ RETVAL
+
+int
+db_sync(db, flags=0)
+ DB_File db
+ u_int flags
+ CODE:
+ CurrentDB = db ;
+ RETVAL = db_sync(db, flags) ;
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+#endif
+ OUTPUT:
+ RETVAL
+
+
+int
+db_seq(db, key, value, flags)
+ DB_File db
+ DBTKEY key
+ DBT value = NO_INIT
+ u_int flags
+ CODE:
+ CurrentDB = db ;
+ DBT_flags(value) ;
+ RETVAL = db_seq(db, key, value, flags);
+#ifdef DB_VERSION_MAJOR
+ if (RETVAL > 0)
+ RETVAL = -1 ;
+ else if (RETVAL == DB_NOTFOUND)
+ RETVAL = 1 ;
+#endif
+ OUTPUT:
+ RETVAL
+ key
+ value
+
diff --git a/contrib/perl5/ext/DB_File/DB_File_BS b/contrib/perl5/ext/DB_File/DB_File_BS
new file mode 100644
index 000000000000..9282c498811d
--- /dev/null
+++ b/contrib/perl5/ext/DB_File/DB_File_BS
@@ -0,0 +1,6 @@
+# NeXT needs /usr/lib/libposix.a to load along with DB_File.so
+if ( $dlsrc eq "dl_next.xs" ) {
+ @DynaLoader::dl_resolve_using = ( '/usr/lib/libposix.a' );
+}
+
+1;
diff --git a/contrib/perl5/ext/DB_File/Makefile.PL b/contrib/perl5/ext/DB_File/Makefile.PL
new file mode 100644
index 000000000000..dbe19f1774ac
--- /dev/null
+++ b/contrib/perl5/ext/DB_File/Makefile.PL
@@ -0,0 +1,20 @@
+use ExtUtils::MakeMaker 5.16 ;
+use Config ;
+
+# OS2 is a special case, so check for it now.
+my $OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ;
+
+my $LIB = "-ldb" ;
+# so is win32
+$LIB = "-llibdb" if $^O eq 'MSWin32' ;
+
+WriteMakefile(
+ NAME => 'DB_File',
+ LIBS => ["-L/usr/local/lib $LIB"],
+ MAN3PODS => ' ', # Pods will be built by installman.
+ #INC => '-I/usr/local/include',
+ VERSION_FROM => 'DB_File.pm',
+ XSPROTOARG => '-noprototypes',
+ DEFINE => "$OS2",
+ );
+
diff --git a/contrib/perl5/ext/DB_File/dbinfo b/contrib/perl5/ext/DB_File/dbinfo
new file mode 100644
index 000000000000..9640ba442e42
--- /dev/null
+++ b/contrib/perl5/ext/DB_File/dbinfo
@@ -0,0 +1,96 @@
+#!/usr/local/bin/perl
+
+# Name: dbinfo -- identify berkeley DB version used to create
+# a database file
+#
+# Author: Paul Marquess
+# Version: 1.01
+# Date 16th April 1998
+#
+# Copyright (c) 1998 Paul Marquess. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+# Todo: Print more stats on a db file, e.g. no of records
+# add log/txn/lock files
+
+use strict ;
+
+my %Data =
+ (
+ 0x053162 => {
+ Type => "Btree",
+ Versions =>
+ {
+ 1 => "Unknown (older than 1.71)",
+ 2 => "Unknown (older than 1.71)",
+ 3 => "1.71 -> 1.85, 1.86",
+ 4 => "Unknown",
+ 5 => "2.0.0 -> 2.3.0",
+ 6 => "2.3.1 or greater",
+ }
+ },
+ 0x061561 => {
+ Type => "Hash",
+ Versions =>
+ {
+ 1 => "Unknown (older than 1.71)",
+ 2 => "1.71 -> 1.85",
+ 3 => "1.86",
+ 4 => "2.0.0 -> 2.1.0",
+ 5 => "2.2.6 or greater",
+ }
+ },
+ ) ;
+
+die "Usage: dbinfo file\n" unless @ARGV == 1 ;
+
+print "testing file $ARGV[0]...\n\n" ;
+open (F, "<$ARGV[0]") or die "Cannot open file $ARGV[0]: $!\n" ;
+
+my $buff ;
+read F, $buff, 20 ;
+
+my (@info) = unpack("NNNNN", $buff) ;
+my (@info1) = unpack("VVVVV", $buff) ;
+my ($magic, $version, $endian) ;
+
+if ($Data{$info[0]}) # first try DB 1.x format
+{
+ $magic = $info[0] ;
+ $version = $info[1] ;
+ $endian = "Unknown" ;
+}
+elsif ($Data{$info[3]}) # next DB 2.x big endian
+{
+ $magic = $info[3] ;
+ $version = $info[4] ;
+ $endian = "Big Endian" ;
+}
+elsif ($Data{$info1[3]}) # next DB 2.x little endian
+{
+ $magic = $info1[3] ;
+ $version = $info1[4] ;
+ $endian = "Little Endian" ;
+}
+else
+ { die "not a Berkeley DB database file.\n" }
+
+my $type = $Data{$magic} ;
+my $magic = sprintf "%06X", $magic ;
+
+my $ver_string = "Unknown" ;
+$ver_string = $type->{Versions}{$version}
+ if defined $type->{Versions}{$version} ;
+
+print <<EOM ;
+File Type: Berkeley DB $type->{Type} file.
+File Version ID: $version
+Built with Berkeley DB: $ver_string
+Byte Order: $endian
+Magic: $magic
+EOM
+
+close F ;
+
+exit ;
diff --git a/contrib/perl5/ext/DB_File/typemap b/contrib/perl5/ext/DB_File/typemap
new file mode 100644
index 000000000000..7af55aec21b4
--- /dev/null
+++ b/contrib/perl5/ext/DB_File/typemap
@@ -0,0 +1,41 @@
+# typemap for Perl 5 interface to Berkeley
+#
+# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
+# last modified 13th May 1998
+# version 1.59
+#
+#################################### DB SECTION
+#
+#
+
+u_int T_U_INT
+DB_File T_PTROBJ
+DBT T_dbtdatum
+DBTKEY T_dbtkeydatum
+
+INPUT
+T_dbtkeydatum
+ if (db->type != DB_RECNO) {
+ $var.data = SvPV($arg, PL_na);
+ $var.size = (int)PL_na;
+ DBT_flags($var);
+ }
+ else {
+ Value = GetRecnoKey(db, SvIV($arg)) ;
+ $var.data = & Value;
+ $var.size = (int)sizeof(recno_t);
+ DBT_flags($var);
+ }
+T_dbtdatum
+ $var.data = SvPV($arg, PL_na);
+ $var.size = (int)PL_na;
+ DBT_flags($var);
+
+OUTPUT
+
+T_dbtkeydatum
+ OutputKey($arg, $var)
+T_dbtdatum
+ OutputValue($arg, $var)
+T_PTROBJ
+ sv_setref_pv($arg, dbtype, (void*)$var);
diff --git a/contrib/perl5/ext/Data/Dumper/Changes b/contrib/perl5/ext/Data/Dumper/Changes
new file mode 100644
index 000000000000..a1649583f2c2
--- /dev/null
+++ b/contrib/perl5/ext/Data/Dumper/Changes
@@ -0,0 +1,160 @@
+=head1 NAME
+
+HISTORY - public release history for Data::Dumper
+
+=head1 DESCRIPTION
+
+=over 8
+
+=item 2.09 (9 July 1998)
+
+Implement $Data::Dumper::Bless, suggested by Mark Daku <daku@nortel.ca>.
+
+=item 2.081 (15 January 1998)
+
+Minor release to fix Makefile.PL not accepting MakeMaker args.
+
+=item 2.08 (7 December 1997)
+
+Glob dumps don't output superflous 'undef' anymore.
+
+Fixes from Gisle Aas <gisle@aas.no> to make Dumper() work with
+overloaded strings in recent perls, and his new testsuite.
+
+require 5.004.
+
+A separate flag to always quote hash keys (on by default).
+
+Recreating known CODE refs is now better supported.
+
+Changed flawed constant SCALAR bless workaround.
+
+=item 2.07 (7 December 1996)
+
+Dumpxs output is now exactly the same as Dump. It still doesn't
+honor C<Useqq> though.
+
+Regression tests test for identical output and C<eval>-ability.
+
+Bug in *GLOB{THING} output fixed.
+
+Other small enhancements.
+
+=item 2.06 (2 December 1996)
+
+Bugfix that was serious enough for new release--the bug cripples
+MLDBM. Problem was "Attempt to modify readonly value..." failures
+that stemmed for a misguided SvPV_force() instead of a SvPV().)
+
+=item 2.05 (2 December 1996)
+
+Fixed the type mismatch that was causing Dumpxs test to fail
+on 64-bit platforms.
+
+GLOB elements are dumped now when C<Purity> is set (using the
+*GLOB{THING} syntax).
+
+The C<Freezer> option can be set to a method name to call
+before probing objects for dumping. Some applications: objects with
+external data, can re-bless themselves into a transitional package;
+Objects the maintain ephemeral state (like open files) can put
+additional information in the object to facilitate persistence.
+
+The corresponding C<Toaster> option, if set, specifies
+the method call that will revive the frozen object.
+
+The C<Deepcopy> flag has been added to do just that.
+
+Dumper does more aggressive cataloging of SCALARs encountered
+within ARRAY/HASH structures. Thanks to Norman Gaywood
+<norm@godel.une.edu.au> for reporting the problem.
+
+Objects that C<overload> the '""' operator are now handled
+properly by the C<Dump> method.
+
+Significant additions to the testsuite.
+
+More documentation.
+
+=item 2.04beta (28 August 1996)
+
+Made dump of glob names respect C<Useqq> setting.
+
+[@$%] are now escaped now when in double quotes.
+
+=item 2.03beta (26 August 1996)
+
+Fixed Dumpxs. It was appending trailing nulls to globnames.
+(reported by Randal Schwartz <merlyn@teleport.com>).
+
+Calling the C<Indent()> method on a dumper object now correctly
+resets the internal separator (reported by Curt Tilmes
+<curt@ltpmail.gsfc.nasa.gov>).
+
+New C<Terse> option to suppress the 'C<VARI<n> = >' prefix
+introduced. If the option is set, they are output only when
+absolutely essential.
+
+The C<Useqq> flag is supported (but not by the XSUB version
+yet).
+
+Embedded nulls in keys are now handled properly by Dumpxs.
+
+Dumper.xs now use various integer types in perl.h (should
+make it compile without noises on 64 bit platforms, although
+I haven't been able to test this).
+
+All the dump methods now return a list of strings in a list
+context.
+
+
+=item 2.02beta (13 April 1996)
+
+Non portable sprintf usage in XS code fixed (thanks to
+Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>).
+
+
+=item 2.01beta (10 April 1996)
+
+Minor bugfix (single digit numbers were always getting quoted).
+
+
+=item 2.00beta (9 April 1996)
+
+C<Dumpxs> is now the exact XSUB equivalent of C<Dump>. The XS version
+is 4-5 times faster.
+
+C<require 5.002>.
+
+MLDBM example removed (as its own module, it has a separate CPAN
+reality now).
+
+Fixed bugs in handling keys with wierd characters. Perl can be
+tripped up in its implicit quoting of the word before '=>'. The
+fix: C<Data::Dumper::Purity>, when set, always triggers quotes
+around hash keys.
+
+Andreas Koenig <k@anna.in-berlin.de> pointed out that handling octals
+is busted. His patch added.
+
+Dead code removed, other minor documentation fixes.
+
+
+=item 1.23 (3 Dec 1995)
+
+MLDBM example added.
+
+Several folks pointed out that quoting of ticks and backslashes
+in strings is missing. Added.
+
+Ian Phillips <ian@pipex.net> pointed out that numerics may lose
+precision without quotes. Fixed.
+
+
+=item 1.21 (20 Nov 1995)
+
+Last stable version I can remember.
+
+=back
+
+=cut
diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.pm b/contrib/perl5/ext/Data/Dumper/Dumper.pm
new file mode 100644
index 000000000000..e3c361f3a299
--- /dev/null
+++ b/contrib/perl5/ext/Data/Dumper/Dumper.pm
@@ -0,0 +1,963 @@
+#
+# Data/Dumper.pm
+#
+# convert perl data structures into perl syntax suitable for both printing
+# and eval
+#
+# Documentation at the __END__
+#
+
+package Data::Dumper;
+
+$VERSION = $VERSION = '2.09';
+
+#$| = 1;
+
+require 5.004;
+require Exporter;
+require DynaLoader;
+require overload;
+
+use Carp;
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw(Dumper);
+@EXPORT_OK = qw(DumperX);
+
+bootstrap Data::Dumper;
+
+# module vars and their defaults
+$Indent = 2 unless defined $Indent;
+$Purity = 0 unless defined $Purity;
+$Pad = "" unless defined $Pad;
+$Varname = "VAR" unless defined $Varname;
+$Useqq = 0 unless defined $Useqq;
+$Terse = 0 unless defined $Terse;
+$Freezer = "" unless defined $Freezer;
+$Toaster = "" unless defined $Toaster;
+$Deepcopy = 0 unless defined $Deepcopy;
+$Quotekeys = 1 unless defined $Quotekeys;
+$Bless = "bless" unless defined $Bless;
+#$Expdepth = 0 unless defined $Expdepth;
+#$Maxdepth = 0 unless defined $Maxdepth;
+
+#
+# expects an arrayref of values to be dumped.
+# can optionally pass an arrayref of names for the values.
+# names must have leading $ sign stripped. begin the name with *
+# to cause output of arrays and hashes rather than refs.
+#
+sub new {
+ my($c, $v, $n) = @_;
+
+ croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])"
+ unless (defined($v) && (ref($v) eq 'ARRAY'));
+ $n = [] unless (defined($n) && (ref($v) eq 'ARRAY'));
+
+ my($s) = {
+ level => 0, # current recursive depth
+ indent => $Indent, # various styles of indenting
+ pad => $Pad, # all lines prefixed by this string
+ xpad => "", # padding-per-level
+ apad => "", # added padding for hash keys n such
+ sep => "", # list separator
+ seen => {}, # local (nested) refs (id => [name, val])
+ todump => $v, # values to dump []
+ names => $n, # optional names for values []
+ varname => $Varname, # prefix to use for tagging nameless ones
+ purity => $Purity, # degree to which output is evalable
+ useqq => $Useqq, # use "" for strings (backslashitis ensues)
+ terse => $Terse, # avoid name output (where feasible)
+ freezer => $Freezer, # name of Freezer method for objects
+ toaster => $Toaster, # name of method to revive objects
+ deepcopy => $Deepcopy, # dont cross-ref, except to stop recursion
+ quotekeys => $Quotekeys, # quote hash keys
+ 'bless' => $Bless, # keyword to use for "bless"
+# expdepth => $Expdepth, # cutoff depth for explicit dumping
+# maxdepth => $Maxdepth, # depth beyond which we give up
+ };
+
+ if ($Indent > 0) {
+ $s->{xpad} = " ";
+ $s->{sep} = "\n";
+ }
+ return bless($s, $c);
+}
+
+#
+# add-to or query the table of already seen references
+#
+sub Seen {
+ my($s, $g) = @_;
+ if (defined($g) && (ref($g) eq 'HASH')) {
+ my($k, $v, $id);
+ while (($k, $v) = each %$g) {
+ if (defined $v and ref $v) {
+ ($id) = (overload::StrVal($v) =~ /\((.*)\)$/);
+ if ($k =~ /^[*](.*)$/) {
+ $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) :
+ (ref $v eq 'HASH') ? ( "\\\%" . $1 ) :
+ (ref $v eq 'CODE') ? ( "\\\&" . $1 ) :
+ ( "\$" . $1 ) ;
+ }
+ elsif ($k !~ /^\$/) {
+ $k = "\$" . $k;
+ }
+ $s->{seen}{$id} = [$k, $v];
+ }
+ else {
+ carp "Only refs supported, ignoring non-ref item \$$k";
+ }
+ }
+ return $s;
+ }
+ else {
+ return map { @$_ } values %{$s->{seen}};
+ }
+}
+
+#
+# set or query the values to be dumped
+#
+sub Values {
+ my($s, $v) = @_;
+ if (defined($v) && (ref($v) eq 'ARRAY')) {
+ $s->{todump} = [@$v]; # make a copy
+ return $s;
+ }
+ else {
+ return @{$s->{todump}};
+ }
+}
+
+#
+# set or query the names of the values to be dumped
+#
+sub Names {
+ my($s, $n) = @_;
+ if (defined($n) && (ref($n) eq 'ARRAY')) {
+ $s->{names} = [@$n]; # make a copy
+ return $s;
+ }
+ else {
+ return @{$s->{names}};
+ }
+}
+
+sub DESTROY {}
+
+#
+# dump the refs in the current dumper object.
+# expects same args as new() if called via package name.
+#
+sub Dump {
+ my($s) = shift;
+ my(@out, $val, $name);
+ my($i) = 0;
+ local(@post);
+
+ $s = $s->new(@_) unless ref $s;
+
+ for $val (@{$s->{todump}}) {
+ my $out = "";
+ @post = ();
+ $name = $s->{names}[$i++];
+ if (defined $name) {
+ if ($name =~ /^[*](.*)$/) {
+ if (defined $val) {
+ $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) :
+ (ref $val eq 'HASH') ? ( "\%" . $1 ) :
+ (ref $val eq 'CODE') ? ( "\*" . $1 ) :
+ ( "\$" . $1 ) ;
+ }
+ else {
+ $name = "\$" . $1;
+ }
+ }
+ elsif ($name !~ /^\$/) {
+ $name = "\$" . $name;
+ }
+ }
+ else {
+ $name = "\$" . $s->{varname} . $i;
+ }
+
+ my $valstr;
+ {
+ local($s->{apad}) = $s->{apad};
+ $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2;
+ $valstr = $s->_dump($val, $name);
+ }
+
+ $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse};
+ $out .= $s->{pad} . $valstr . $s->{sep};
+ $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post)
+ . ';' . $s->{sep} if @post;
+
+ push @out, $out;
+ }
+ return wantarray ? @out : join('', @out);
+}
+
+#
+# twist, toil and turn;
+# and recurse, of course.
+#
+sub _dump {
+ my($s, $val, $name) = @_;
+ my($sname);
+ my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad);
+
+ return "undef" unless defined $val;
+
+ $type = ref $val;
+ $out = "";
+
+ if ($type) {
+
+ # prep it, if it looks like an object
+ if ($type =~ /[a-z_:]/) {
+ my $freezer = $s->{freezer};
+ # UNIVERSAL::can should be used here, when we can require 5.004
+ if ($freezer) {
+ eval { $val->$freezer() };
+ carp "WARNING(Freezer method call failed): $@" if $@;
+ }
+ }
+
+ ($realpack, $realtype, $id) =
+ (overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);
+
+ # keep a tab on it so that we dont fall into recursive pit
+ if (exists $s->{seen}{$id}) {
+# if ($s->{expdepth} < $s->{level}) {
+ if ($s->{purity} and $s->{level} > 0) {
+ $out = ($realtype eq 'HASH') ? '{}' :
+ ($realtype eq 'ARRAY') ? '[]' :
+ "''" ;
+ push @post, $name . " = " . $s->{seen}{$id}[0];
+ }
+ else {
+ $out = $s->{seen}{$id}[0];
+ if ($name =~ /^([\@\%])/) {
+ my $start = $1;
+ if ($out =~ /^\\$start/) {
+ $out = substr($out, 1);
+ }
+ else {
+ $out = $start . '{' . $out . '}';
+ }
+ }
+ }
+ return $out;
+# }
+ }
+ else {
+ # store our name
+ $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) :
+ ($realtype eq 'CODE' and
+ $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) :
+ $name ),
+ $val ];
+ }
+
+ $s->{level}++;
+ $ipad = $s->{xpad} x $s->{level};
+
+ if ($realpack) { # we have a blessed ref
+ $out = $s->{'bless'} . '( ';
+ $blesspad = $s->{apad};
+ $s->{apad} .= ' ' if ($s->{indent} >= 2);
+ }
+
+ if ($realtype eq 'SCALAR') {
+ if ($realpack) {
+ $out .= 'do{\\(my $o = ' . $s->_dump($$val, "") . ')}';
+ }
+ else {
+ $out .= '\\' . $s->_dump($$val, "");
+ }
+ }
+ elsif ($realtype eq 'GLOB') {
+ $out .= '\\' . $s->_dump($$val, "");
+ }
+ elsif ($realtype eq 'ARRAY') {
+ my($v, $pad, $mname);
+ my($i) = 0;
+ $out .= ($name =~ /^\@/) ? '(' : '[';
+ $pad = $s->{sep} . $s->{pad} . $s->{apad};
+ ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) :
+ ($name =~ /[]}]$/) ? ($mname = $name) : ($mname = $name . '->');
+ $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
+ for $v (@$val) {
+ $sname = $mname . '[' . $i . ']';
+ $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3;
+ $out .= $pad . $ipad . $s->_dump($v, $sname);
+ $out .= "," if $i++ < $#$val;
+ }
+ $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i;
+ $out .= ($name =~ /^\@/) ? ')' : ']';
+ }
+ elsif ($realtype eq 'HASH') {
+ my($k, $v, $pad, $lpad, $mname);
+ $out .= ($name =~ /^\%/) ? '(' : '{';
+ $pad = $s->{sep} . $s->{pad} . $s->{apad};
+ $lpad = $s->{apad};
+ ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
+ ($name =~ /[]}]$/) ? ($mname = $name) : ($mname = $name . '->');
+ $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
+ while (($k, $v) = each %$val) {
+ my $nk = $s->_dump($k, "");
+ $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
+ $sname = $mname . '{' . $nk . '}';
+ $out .= $pad . $ipad . $nk . " => ";
+
+ # temporarily alter apad
+ $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2;
+ $out .= $s->_dump($val->{$k}, $sname) . ",";
+ $s->{apad} = $lpad if $s->{indent} >= 2;
+ }
+ if (substr($out, -1) eq ',') {
+ chop $out;
+ $out .= $pad . ($s->{xpad} x ($s->{level} - 1));
+ }
+ $out .= ($name =~ /^\%/) ? ')' : '}';
+ }
+ elsif ($realtype eq 'CODE') {
+ $out .= '"DUMMY"';
+ $out = 'sub { ' . $out . ' }';
+ carp "Encountered CODE ref, using dummy placeholder" if $s->{purity};
+ }
+ else {
+ croak "Can\'t handle $realtype type.";
+ }
+
+ if ($realpack) { # we have a blessed ref
+ $out .= ', \'' . $realpack . '\'' . ' )';
+ $out .= '->' . $s->{toaster} . '()' if $s->{toaster} ne '';
+ $s->{apad} = $blesspad;
+ }
+ $s->{level}--;
+
+ }
+ else { # simple scalar
+
+ my $ref = \$_[1];
+ # first, catalog the scalar
+ if ($name ne '') {
+ ($id) = ("$ref" =~ /\(([^\(]*)\)$/);
+ if (exists $s->{seen}{$id}) {
+ $out = $s->{seen}{$id}[0];
+ return $out;
+ }
+ else {
+ $s->{seen}{$id} = ["\\$name", $val];
+ }
+ }
+ if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob
+ my $name = substr($val, 1);
+ if ($name =~ /^[A-Za-z_][\w:]*$/) {
+ $name =~ s/^main::/::/;
+ $sname = $name;
+ }
+ else {
+ $sname = $s->_dump($name, "");
+ $sname = '{' . $sname . '}';
+ }
+ if ($s->{purity}) {
+ my $k;
+ local ($s->{level}) = 0;
+ for $k (qw(SCALAR ARRAY HASH)) {
+ # _dump can push into @post, so we hold our place using $postlen
+ my $postlen = scalar @post;
+ $post[$postlen] = "\*$sname = ";
+ local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2;
+ $post[$postlen] .= $s->_dump(*{$name}{$k}, "\*$sname\{$k\}");
+ }
+ }
+ $out .= '*' . $sname;
+ }
+ elsif ($val =~ /^-?[1-9]\d{0,8}$/) { # safe decimal number
+ $out .= $val;
+ }
+ else { # string
+ if ($s->{useqq}) {
+ $out .= qquote($val);
+ }
+ else {
+ $val =~ s/([\\\'])/\\$1/g;
+ $out .= '\'' . $val . '\'';
+ }
+ }
+ }
+
+ # if we made it this far, $id was added to seen list at current
+ # level, so remove it to get deep copies
+ delete($s->{seen}{$id}) if $id and $s->{deepcopy};
+ return $out;
+}
+
+#
+# non-OO style of earlier version
+#
+sub Dumper {
+ return Data::Dumper->Dump([@_]);
+}
+
+#
+# same, only calls the XS version
+#
+sub DumperX {
+ return Data::Dumper->Dumpxs([@_], []);
+}
+
+sub Dumpf { return Data::Dumper->Dump(@_) }
+
+sub Dumpp { print Data::Dumper->Dump(@_) }
+
+#
+# reset the "seen" cache
+#
+sub Reset {
+ my($s) = shift;
+ $s->{seen} = {};
+ return $s;
+}
+
+sub Indent {
+ my($s, $v) = @_;
+ if (defined($v)) {
+ if ($v == 0) {
+ $s->{xpad} = "";
+ $s->{sep} = "";
+ }
+ else {
+ $s->{xpad} = " ";
+ $s->{sep} = "\n";
+ }
+ $s->{indent} = $v;
+ return $s;
+ }
+ else {
+ return $s->{indent};
+ }
+}
+
+sub Pad {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad};
+}
+
+sub Varname {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname};
+}
+
+sub Purity {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity};
+}
+
+sub Useqq {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq};
+}
+
+sub Terse {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse};
+}
+
+sub Freezer {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer};
+}
+
+sub Toaster {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster};
+}
+
+sub Deepcopy {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy};
+}
+
+sub Quotekeys {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys};
+}
+
+sub Bless {
+ my($s, $v) = @_;
+ defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
+}
+
+# put a string value in double quotes
+sub qquote {
+ local($_) = shift;
+ s/([\\\"\@\$\%])/\\$1/g;
+ s/\a/\\a/g;
+ s/[\b]/\\b/g;
+ s/\t/\\t/g;
+ s/\n/\\n/g;
+ s/\f/\\f/g;
+ s/\r/\\r/g;
+ s/\e/\\e/g;
+
+# this won't work!
+# s/([^\a\b\t\n\f\r\e\038-\176])/'\\'.sprintf('%03o',ord($1))/eg;
+ s/([\000-\006\013\016-\032\034-\037\177\200-\377])/'\\'.sprintf('%03o',ord($1))/eg;
+ return "\"$_\"";
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Data::Dumper - stringified perl data structures, suitable for both printing and C<eval>
+
+
+=head1 SYNOPSIS
+
+ use Data::Dumper;
+
+ # simple procedural interface
+ print Dumper($foo, $bar);
+
+ # extended usage with names
+ print Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]);
+
+ # configuration variables
+ {
+ local $Data::Dump::Purity = 1;
+ eval Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]);
+ }
+
+ # OO usage
+ $d = Data::Dumper->new([$foo, $bar], [qw(foo *ary)]);
+ ...
+ print $d->Dump;
+ ...
+ $d->Purity(1)->Terse(1)->Deepcopy(1);
+ eval $d->Dump;
+
+
+=head1 DESCRIPTION
+
+Given a list of scalars or reference variables, writes out their contents in
+perl syntax. The references can also be objects. The contents of each
+variable is output in a single Perl statement. Handles self-referential
+structures correctly.
+
+The return value can be C<eval>ed to get back an identical copy of the
+original reference structure.
+
+Any references that are the same as one of those passed in will be named
+C<$VAR>I<n> (where I<n> is a numeric suffix), and other duplicate references
+to substructures within C<$VAR>I<n> will be appropriately labeled using arrow
+notation. You can specify names for individual values to be dumped if you
+use the C<Dump()> method, or you can change the default C<$VAR> prefix to
+something else. See C<$Data::Dumper::Varname> and C<$Data::Dumper::Terse>
+below.
+
+The default output of self-referential structures can be C<eval>ed, but the
+nested references to C<$VAR>I<n> will be undefined, since a recursive
+structure cannot be constructed using one Perl statement. You should set the
+C<Purity> flag to 1 to get additional statements that will correctly fill in
+these references.
+
+In the extended usage form, the references to be dumped can be given
+user-specified names. If a name begins with a C<*>, the output will
+describe the dereferenced type of the supplied reference for hashes and
+arrays, and coderefs. Output of names will be avoided where possible if
+the C<Terse> flag is set.
+
+In many cases, methods that are used to set the internal state of the
+object will return the object itself, so method calls can be conveniently
+chained together.
+
+Several styles of output are possible, all controlled by setting
+the C<Indent> flag. See L<Configuration Variables or Methods> below
+for details.
+
+
+=head2 Methods
+
+=over 4
+
+=item I<PACKAGE>->new(I<ARRAYREF [>, I<ARRAYREF]>)
+
+Returns a newly created C<Data::Dumper> object. The first argument is an
+anonymous array of values to be dumped. The optional second argument is an
+anonymous array of names for the values. The names need not have a leading
+C<$> sign, and must be comprised of alphanumeric characters. You can begin
+a name with a C<*> to specify that the dereferenced type must be dumped
+instead of the reference itself, for ARRAY and HASH references.
+
+The prefix specified by C<$Data::Dumper::Varname> will be used with a
+numeric suffix if the name for a value is undefined.
+
+Data::Dumper will catalog all references encountered while dumping the
+values. Cross-references (in the form of names of substructures in perl
+syntax) will be inserted at all possible points, preserving any structural
+interdependencies in the original set of values. Structure traversal is
+depth-first, and proceeds in order from the first supplied value to
+the last.
+
+=item I<$OBJ>->Dump I<or> I<PACKAGE>->Dump(I<ARRAYREF [>, I<ARRAYREF]>)
+
+Returns the stringified form of the values stored in the object (preserving
+the order in which they were supplied to C<new>), subject to the
+configuration options below. In an array context, it returns a list
+of strings corresponding to the supplied values.
+
+The second form, for convenience, simply calls the C<new> method on its
+arguments before dumping the object immediately.
+
+=item I<$OBJ>->Dumpxs I<or> I<PACKAGE>->Dumpxs(I<ARRAYREF [>, I<ARRAYREF]>)
+
+This method is available if you were able to compile and install the XSUB
+extension to C<Data::Dumper>. It is exactly identical to the C<Dump> method
+above, only about 4 to 5 times faster, since it is written entirely in C.
+
+=item I<$OBJ>->Seen(I<[HASHREF]>)
+
+Queries or adds to the internal table of already encountered references.
+You must use C<Reset> to explicitly clear the table if needed. Such
+references are not dumped; instead, their names are inserted wherever they
+are encountered subsequently. This is useful especially for properly
+dumping subroutine references.
+
+Expects a anonymous hash of name => value pairs. Same rules apply for names
+as in C<new>. If no argument is supplied, will return the "seen" list of
+name => value pairs, in an array context. Otherwise, returns the object
+itself.
+
+=item I<$OBJ>->Values(I<[ARRAYREF]>)
+
+Queries or replaces the internal array of values that will be dumped.
+When called without arguments, returns the values. Otherwise, returns the
+object itself.
+
+=item I<$OBJ>->Names(I<[ARRAYREF]>)
+
+Queries or replaces the internal array of user supplied names for the values
+that will be dumped. When called without arguments, returns the names.
+Otherwise, returns the object itself.
+
+=item I<$OBJ>->Reset
+
+Clears the internal table of "seen" references and returns the object
+itself.
+
+=back
+
+=head2 Functions
+
+=over 4
+
+=item Dumper(I<LIST>)
+
+Returns the stringified form of the values in the list, subject to the
+configuration options below. The values will be named C<$VAR>I<n> in the
+output, where I<n> is a numeric suffix. Will return a list of strings
+in an array context.
+
+=item DumperX(I<LIST>)
+
+Identical to the C<Dumper()> function above, but this calls the XSUB
+implementation. Only available if you were able to compile and install
+the XSUB extensions in C<Data::Dumper>.
+
+=back
+
+=head2 Configuration Variables or Methods
+
+Several configuration variables can be used to control the kind of output
+generated when using the procedural interface. These variables are usually
+C<local>ized in a block so that other parts of the code are not affected by
+the change.
+
+These variables determine the default state of the object created by calling
+the C<new> method, but cannot be used to alter the state of the object
+thereafter. The equivalent method names should be used instead to query
+or set the internal state of the object.
+
+The method forms return the object itself when called with arguments,
+so that they can be chained together nicely.
+
+=over 4
+
+=item $Data::Dumper::Indent I<or> I<$OBJ>->Indent(I<[NEWVAL]>)
+
+Controls the style of indentation. It can be set to 0, 1, 2 or 3. Style 0
+spews output without any newlines, indentation, or spaces between list
+items. It is the most compact format possible that can still be called
+valid perl. Style 1 outputs a readable form with newlines but no fancy
+indentation (each level in the structure is simply indented by a fixed
+amount of whitespace). Style 2 (the default) outputs a very readable form
+which takes into account the length of hash keys (so the hash value lines
+up). Style 3 is like style 2, but also annotates the elements of arrays
+with their index (but the comment is on its own line, so array output
+consumes twice the number of lines). Style 2 is the default.
+
+=item $Data::Dumper::Purity I<or> I<$OBJ>->Purity(I<[NEWVAL]>)
+
+Controls the degree to which the output can be C<eval>ed to recreate the
+supplied reference structures. Setting it to 1 will output additional perl
+statements that will correctly recreate nested references. The default is
+0.
+
+=item $Data::Dumper::Pad I<or> I<$OBJ>->Pad(I<[NEWVAL]>)
+
+Specifies the string that will be prefixed to every line of the output.
+Empty string by default.
+
+=item $Data::Dumper::Varname I<or> I<$OBJ>->Varname(I<[NEWVAL]>)
+
+Contains the prefix to use for tagging variable names in the output. The
+default is "VAR".
+
+=item $Data::Dumper::Useqq I<or> I<$OBJ>->Useqq(I<[NEWVAL]>)
+
+When set, enables the use of double quotes for representing string values.
+Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe"
+characters will be backslashed, and unprintable characters will be output as
+quoted octal integers. Since setting this variable imposes a performance
+penalty, the default is 0. The C<Dumpxs()> method does not honor this
+flag yet.
+
+=item $Data::Dumper::Terse I<or> I<$OBJ>->Terse(I<[NEWVAL]>)
+
+When set, Data::Dumper will emit single, non-self-referential values as
+atoms/terms rather than statements. This means that the C<$VAR>I<n> names
+will be avoided where possible, but be advised that such output may not
+always be parseable by C<eval>.
+
+=item $Data::Dumper::Freezer I<or> $I<OBJ>->Freezer(I<[NEWVAL]>)
+
+Can be set to a method name, or to an empty string to disable the feature.
+Data::Dumper will invoke that method via the object before attempting to
+stringify it. This method can alter the contents of the object (if, for
+instance, it contains data allocated from C), and even rebless it in a
+different package. The client is responsible for making sure the specified
+method can be called via the object, and that the object ends up containing
+only perl data types after the method has been called. Defaults to an empty
+string.
+
+=item $Data::Dumper::Toaster I<or> $I<OBJ>->Toaster(I<[NEWVAL]>)
+
+Can be set to a method name, or to an empty string to disable the feature.
+Data::Dumper will emit a method call for any objects that are to be dumped
+using the syntax C<bless(DATA, CLASS)->METHOD()>. Note that this means that
+the method specified will have to perform any modifications required on the
+object (like creating new state within it, and/or reblessing it in a
+different package) and then return it. The client is responsible for making
+sure the method can be called via the object, and that it returns a valid
+object. Defaults to an empty string.
+
+=item $Data::Dumper::Deepcopy I<or> $I<OBJ>->Deepcopy(I<[NEWVAL]>)
+
+Can be set to a boolean value to enable deep copies of structures.
+Cross-referencing will then only be done when absolutely essential
+(i.e., to break reference cycles). Default is 0.
+
+=item $Data::Dumper::Quotekeys I<or> $I<OBJ>->Quotekeys(I<[NEWVAL]>)
+
+Can be set to a boolean value to control whether hash keys are quoted.
+A false value will avoid quoting hash keys when it looks like a simple
+string. Default is 1, which will always enclose hash keys in quotes.
+
+=item $Data::Dumper::Bless I<or> $I<OBJ>->Bless(I<[NEWVAL]>)
+
+Can be set to a string that specifies an alternative to the C<bless>
+builtin operator used to create objects. A function with the specified
+name should exist, and should accept the same arguments as the builtin.
+Default is C<bless>.
+
+=back
+
+=head2 Exports
+
+=over 4
+
+=item Dumper
+
+=back
+
+=head1 EXAMPLES
+
+Run these code snippets to get a quick feel for the behavior of this
+module. When you are through with these examples, you may want to
+add or change the various configuration variables described above,
+to see their behavior. (See the testsuite in the Data::Dumper
+distribution for more examples.)
+
+
+ use Data::Dumper;
+
+ package Foo;
+ sub new {bless {'a' => 1, 'b' => sub { return "foo" }}, $_[0]};
+
+ package Fuz; # a weird REF-REF-SCALAR object
+ sub new {bless \($_ = \ 'fu\'z'), $_[0]};
+
+ package main;
+ $foo = Foo->new;
+ $fuz = Fuz->new;
+ $boo = [ 1, [], "abcd", \*foo,
+ {1 => 'a', 023 => 'b', 0x45 => 'c'},
+ \\"p\q\'r", $foo, $fuz];
+
+ ########
+ # simple usage
+ ########
+
+ $bar = eval(Dumper($boo));
+ print($@) if $@;
+ print Dumper($boo), Dumper($bar); # pretty print (no array indices)
+
+ $Data::Dumper::Terse = 1; # don't output names where feasible
+ $Data::Dumper::Indent = 0; # turn off all pretty print
+ print Dumper($boo), "\n";
+
+ $Data::Dumper::Indent = 1; # mild pretty print
+ print Dumper($boo);
+
+ $Data::Dumper::Indent = 3; # pretty print with array indices
+ print Dumper($boo);
+
+ $Data::Dumper::Useqq = 1; # print strings in double quotes
+ print Dumper($boo);
+
+
+ ########
+ # recursive structures
+ ########
+
+ @c = ('c');
+ $c = \@c;
+ $b = {};
+ $a = [1, $b, $c];
+ $b->{a} = $a;
+ $b->{b} = $a->[1];
+ $b->{c} = $a->[2];
+ print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]);
+
+
+ $Data::Dumper::Purity = 1; # fill in the holes for eval
+ print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a
+ print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b
+
+
+ $Data::Dumper::Deepcopy = 1; # avoid cross-refs
+ print Data::Dumper->Dump([$b, $a], [qw(*b a)]);
+
+
+ $Data::Dumper::Purity = 0; # avoid cross-refs
+ print Data::Dumper->Dump([$b, $a], [qw(*b a)]);
+
+
+ ########
+ # object-oriented usage
+ ########
+
+ $d = Data::Dumper->new([$a,$b], [qw(a b)]);
+ $d->Seen({'*c' => $c}); # stash a ref without printing it
+ $d->Indent(3);
+ print $d->Dump;
+ $d->Reset->Purity(0); # empty the seen cache
+ print join "----\n", $d->Dump;
+
+
+ ########
+ # persistence
+ ########
+
+ package Foo;
+ sub new { bless { state => 'awake' }, shift }
+ sub Freeze {
+ my $s = shift;
+ print STDERR "preparing to sleep\n";
+ $s->{state} = 'asleep';
+ return bless $s, 'Foo::ZZZ';
+ }
+
+ package Foo::ZZZ;
+ sub Thaw {
+ my $s = shift;
+ print STDERR "waking up\n";
+ $s->{state} = 'awake';
+ return bless $s, 'Foo';
+ }
+
+ package Foo;
+ use Data::Dumper;
+ $a = Foo->new;
+ $b = Data::Dumper->new([$a], ['c']);
+ $b->Freezer('Freeze');
+ $b->Toaster('Thaw');
+ $c = $b->Dump;
+ print $c;
+ $d = eval $c;
+ print Data::Dumper->Dump([$d], ['d']);
+
+
+ ########
+ # symbol substitution (useful for recreating CODE refs)
+ ########
+
+ sub foo { print "foo speaking\n" }
+ *other = \&foo;
+ $bar = [ \&other ];
+ $d = Data::Dumper->new([\&other,$bar],['*other','bar']);
+ $d->Seen({ '*foo' => \&foo });
+ print $d->Dump;
+
+
+=head1 BUGS
+
+Due to limitations of Perl subroutine call semantics, you cannot pass an
+array or hash. Prepend it with a C<\> to pass its reference instead. This
+will be remedied in time, with the arrival of prototypes in later versions
+of Perl. For now, you need to use the extended usage form, and prepend the
+name with a C<*> to output it as a hash or array.
+
+C<Data::Dumper> cheats with CODE references. If a code reference is
+encountered in the structure being processed, an anonymous subroutine that
+contains the string '"DUMMY"' will be inserted in its place, and a warning
+will be printed if C<Purity> is set. You can C<eval> the result, but bear
+in mind that the anonymous sub that gets created is just a placeholder.
+Someday, perl will have a switch to cache-on-demand the string
+representation of a compiled piece of code, I hope. If you have prior
+knowledge of all the code refs that your data structures are likely
+to have, you can use the C<Seen> method to pre-seed the internal reference
+table and make the dumped output point to them, instead. See L<EXAMPLES>
+above.
+
+The C<Useqq> flag is not honored by C<Dumpxs()> (it always outputs
+strings in single quotes).
+
+SCALAR objects have the weirdest looking C<bless> workaround.
+
+
+=head1 AUTHOR
+
+Gurusamy Sarathy gsar@umich.edu
+
+Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+
+=head1 VERSION
+
+Version 2.09 (9 July 1998)
+
+=head1 SEE ALSO
+
+perl(1)
+
+=cut
diff --git a/contrib/perl5/ext/Data/Dumper/Dumper.xs b/contrib/perl5/ext/Data/Dumper/Dumper.xs
new file mode 100644
index 000000000000..d8012eec5b10
--- /dev/null
+++ b/contrib/perl5/ext/Data/Dumper/Dumper.xs
@@ -0,0 +1,800 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+static SV *freezer;
+static SV *toaster;
+
+static I32 num_q _((char *s, STRLEN slen));
+static I32 esc_q _((char *dest, char *src, STRLEN slen));
+static SV *sv_x _((SV *sv, char *str, STRLEN len, I32 n));
+static I32 DD_dump _((SV *val, char *name, STRLEN namelen, SV *retval,
+ HV *seenhv, AV *postav, I32 *levelp, I32 indent,
+ SV *pad, SV *xpad, SV *apad, SV *sep,
+ SV *freezer, SV *toaster,
+ I32 purity, I32 deepcopy, I32 quotekeys, SV *bless));
+
+/* does a string need to be protected? */
+static I32
+needs_quote(register char *s)
+{
+TOP:
+ if (s[0] == ':') {
+ if (*++s) {
+ if (*s++ != ':')
+ return 1;
+ }
+ else
+ return 1;
+ }
+ if (isIDFIRST(*s)) {
+ while (*++s)
+ if (!isALNUM(*s))
+ if (*s == ':')
+ goto TOP;
+ else
+ return 1;
+ }
+ else
+ return 1;
+ return 0;
+}
+
+/* count the number of "'"s and "\"s in string */
+static I32
+num_q(register char *s, register STRLEN slen)
+{
+ register I32 ret = 0;
+
+ while (slen > 0) {
+ if (*s == '\'' || *s == '\\')
+ ++ret;
+ ++s;
+ --slen;
+ }
+ return ret;
+}
+
+
+/* returns number of chars added to escape "'"s and "\"s in s */
+/* slen number of characters in s will be escaped */
+/* destination must be long enough for additional chars */
+static I32
+esc_q(register char *d, register char *s, register STRLEN slen)
+{
+ register I32 ret = 0;
+
+ while (slen > 0) {
+ switch (*s) {
+ case '\'':
+ case '\\':
+ *d = '\\';
+ ++d; ++ret;
+ default:
+ *d = *s;
+ ++d; ++s; --slen;
+ break;
+ }
+ }
+ return ret;
+}
+
+/* append a repeated string to an SV */
+static SV *
+sv_x(SV *sv, register char *str, STRLEN len, I32 n)
+{
+ if (sv == Nullsv)
+ sv = newSVpv("", 0);
+ else
+ assert(SvTYPE(sv) >= SVt_PV);
+
+ if (n > 0) {
+ SvGROW(sv, len*n + SvCUR(sv) + 1);
+ if (len == 1) {
+ char *start = SvPVX(sv) + SvCUR(sv);
+ SvCUR(sv) += n;
+ start[n] = '\0';
+ while (n > 0)
+ start[--n] = str[0];
+ }
+ else
+ while (n > 0) {
+ sv_catpvn(sv, str, len);
+ --n;
+ }
+ }
+ return sv;
+}
+
+/*
+ * This ought to be split into smaller functions. (it is one long function since
+ * it exactly parallels the perl version, which was one long thing for
+ * efficiency raisins.) Ugggh!
+ */
+static I32
+DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
+ AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
+ SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
+ I32 deepcopy, I32 quotekeys, SV *bless)
+{
+ char tmpbuf[128];
+ U32 i;
+ char *c, *r, *realpack, id[128];
+ SV **svp;
+ SV *sv;
+ SV *blesspad = Nullsv;
+ SV *ipad;
+ SV *ival;
+ AV *seenentry;
+ char *iname;
+ STRLEN inamelen, idlen = 0;
+ U32 flags;
+ U32 realtype;
+
+ if (!val)
+ return 0;
+
+ flags = SvFLAGS(val);
+ realtype = SvTYPE(val);
+
+ if (SvGMAGICAL(val))
+ mg_get(val);
+ if (val == &PL_sv_undef || !SvOK(val)) {
+ sv_catpvn(retval, "undef", 5);
+ return 1;
+ }
+ if (SvROK(val)) {
+
+ if (SvOBJECT(SvRV(val)) && freezer &&
+ SvPOK(freezer) && SvCUR(freezer))
+ {
+ dSP; ENTER; SAVETMPS; PUSHMARK(sp);
+ XPUSHs(val); PUTBACK;
+ i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
+ SPAGAIN;
+ if (SvTRUE(GvSV(PL_errgv)))
+ warn("WARNING(Freezer method call failed): %s",
+ SvPVX(GvSV(PL_errgv)));
+ else if (i)
+ val = newSVsv(POPs);
+ PUTBACK; FREETMPS; LEAVE;
+ if (i)
+ (void)sv_2mortal(val);
+ }
+
+ ival = SvRV(val);
+ flags = SvFLAGS(ival);
+ realtype = SvTYPE(ival);
+ (void) sprintf(id, "0x%lx", (unsigned long)ival);
+ idlen = strlen(id);
+ if (SvOBJECT(ival))
+ realpack = HvNAME(SvSTASH(ival));
+ else
+ realpack = Nullch;
+ if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
+ (sv = *svp) && SvROK(sv) &&
+ (seenentry = (AV*)SvRV(sv))) {
+ SV *othername;
+ if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
+ if (purity && *levelp > 0) {
+ SV *postentry;
+
+ if (realtype == SVt_PVHV)
+ sv_catpvn(retval, "{}", 2);
+ else if (realtype == SVt_PVAV)
+ sv_catpvn(retval, "[]", 2);
+ else
+ sv_catpvn(retval, "''", 2);
+ postentry = newSVpv(name, namelen);
+ sv_catpvn(postentry, " = ", 3);
+ sv_catsv(postentry, othername);
+ av_push(postav, postentry);
+ }
+ else {
+ if (name[0] == '@' || name[0] == '%') {
+ if ((SvPVX(othername))[0] == '\\' &&
+ (SvPVX(othername))[1] == name[0]) {
+ sv_catpvn(retval, SvPVX(othername)+1, SvCUR(othername)-1);
+ }
+ else {
+ sv_catpvn(retval, name, 1);
+ sv_catpvn(retval, "{", 1);
+ sv_catsv(retval, othername);
+ sv_catpvn(retval, "}", 1);
+ }
+ }
+ else
+ sv_catsv(retval, othername);
+ }
+ return 1;
+ }
+ else {
+ warn("ref name not found for %s", id);
+ return 0;
+ }
+ }
+ else { /* store our name and continue */
+ SV *namesv;
+ if (name[0] == '@' || name[0] == '%') {
+ namesv = newSVpv("\\", 1);
+ sv_catpvn(namesv, name, namelen);
+ }
+ else if (realtype == SVt_PVCV && name[0] == '*') {
+ namesv = newSVpv("\\", 2);
+ sv_catpvn(namesv, name, namelen);
+ (SvPVX(namesv))[1] = '&';
+ }
+ else
+ namesv = newSVpv(name, namelen);
+ seenentry = newAV();
+ av_push(seenentry, namesv);
+ (void)SvREFCNT_inc(val);
+ av_push(seenentry, val);
+ (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
+ SvREFCNT_dec(seenentry);
+ }
+
+ (*levelp)++;
+ ipad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
+
+ if (realpack) { /* we have a blessed ref */
+ STRLEN blesslen;
+ char *blessstr = SvPV(bless, blesslen);
+ sv_catpvn(retval, blessstr, blesslen);
+ sv_catpvn(retval, "( ", 2);
+ if (indent >= 2) {
+ blesspad = apad;
+ apad = newSVsv(apad);
+ sv_x(apad, " ", 1, blesslen+2);
+ }
+ }
+
+ if (realtype <= SVt_PVBM || realtype == SVt_PVGV) { /* scalars */
+ if (realpack && realtype != SVt_PVGV) { /* blessed */
+ sv_catpvn(retval, "do{\\(my $o = ", 13);
+ DD_dump(ival, "", 0, retval, seenhv, postav,
+ levelp, indent, pad, xpad, apad, sep,
+ freezer, toaster, purity, deepcopy, quotekeys, bless);
+ sv_catpvn(retval, ")}", 2);
+ }
+ else {
+ sv_catpvn(retval, "\\", 1);
+ DD_dump(ival, "", 0, retval, seenhv, postav,
+ levelp, indent, pad, xpad, apad, sep,
+ freezer, toaster, purity, deepcopy, quotekeys, bless);
+ }
+ }
+ else if (realtype == SVt_PVAV) {
+ SV *totpad;
+ I32 ix = 0;
+ I32 ixmax = av_len((AV *)ival);
+
+ SV *ixsv = newSViv(0);
+ /* allowing for a 24 char wide array index */
+ New(0, iname, namelen+28, char);
+ (void)strcpy(iname, name);
+ inamelen = namelen;
+ if (name[0] == '@') {
+ sv_catpvn(retval, "(", 1);
+ iname[0] = '$';
+ }
+ else {
+ sv_catpvn(retval, "[", 1);
+ if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
+ iname[inamelen++] = '-'; iname[inamelen++] = '>';
+ iname[inamelen] = '\0';
+ }
+ }
+ if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
+ (instr(iname+inamelen-8, "{SCALAR}") ||
+ instr(iname+inamelen-7, "{ARRAY}") ||
+ instr(iname+inamelen-6, "{HASH}"))) {
+ iname[inamelen++] = '-'; iname[inamelen++] = '>';
+ }
+ iname[inamelen++] = '['; iname[inamelen] = '\0';
+ totpad = newSVsv(sep);
+ sv_catsv(totpad, pad);
+ sv_catsv(totpad, apad);
+
+ for (ix = 0; ix <= ixmax; ++ix) {
+ STRLEN ilen;
+ SV *elem;
+ svp = av_fetch((AV*)ival, ix, FALSE);
+ if (svp)
+ elem = *svp;
+ else
+ elem = &PL_sv_undef;
+
+ ilen = inamelen;
+ sv_setiv(ixsv, ix);
+ (void) sprintf(iname+ilen, "%ld", ix);
+ ilen = strlen(iname);
+ iname[ilen++] = ']'; iname[ilen] = '\0';
+ if (indent >= 3) {
+ sv_catsv(retval, totpad);
+ sv_catsv(retval, ipad);
+ sv_catpvn(retval, "#", 1);
+ sv_catsv(retval, ixsv);
+ }
+ sv_catsv(retval, totpad);
+ sv_catsv(retval, ipad);
+ DD_dump(elem, iname, ilen, retval, seenhv, postav,
+ levelp, indent, pad, xpad, apad, sep,
+ freezer, toaster, purity, deepcopy, quotekeys, bless);
+ if (ix < ixmax)
+ sv_catpvn(retval, ",", 1);
+ }
+ if (ixmax >= 0) {
+ SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
+ sv_catsv(retval, totpad);
+ sv_catsv(retval, opad);
+ SvREFCNT_dec(opad);
+ }
+ if (name[0] == '@')
+ sv_catpvn(retval, ")", 1);
+ else
+ sv_catpvn(retval, "]", 1);
+ SvREFCNT_dec(ixsv);
+ SvREFCNT_dec(totpad);
+ Safefree(iname);
+ }
+ else if (realtype == SVt_PVHV) {
+ SV *totpad, *newapad;
+ SV *iname, *sname;
+ HE *entry;
+ char *key;
+ I32 klen;
+ SV *hval;
+
+ iname = newSVpv(name, namelen);
+ if (name[0] == '%') {
+ sv_catpvn(retval, "(", 1);
+ (SvPVX(iname))[0] = '$';
+ }
+ else {
+ sv_catpvn(retval, "{", 1);
+ if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
+ sv_catpvn(iname, "->", 2);
+ }
+ }
+ if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
+ (instr(name+namelen-8, "{SCALAR}") ||
+ instr(name+namelen-7, "{ARRAY}") ||
+ instr(name+namelen-6, "{HASH}"))) {
+ sv_catpvn(iname, "->", 2);
+ }
+ sv_catpvn(iname, "{", 1);
+ totpad = newSVsv(sep);
+ sv_catsv(totpad, pad);
+ sv_catsv(totpad, apad);
+
+ (void)hv_iterinit((HV*)ival);
+ i = 0;
+ while ((entry = hv_iternext((HV*)ival))) {
+ char *nkey;
+ I32 nticks = 0;
+
+ if (i)
+ sv_catpvn(retval, ",", 1);
+ i++;
+ key = hv_iterkey(entry, &klen);
+ hval = hv_iterval((HV*)ival, entry);
+
+ if (quotekeys || needs_quote(key)) {
+ nticks = num_q(key, klen);
+ New(0, nkey, klen+nticks+3, char);
+ nkey[0] = '\'';
+ if (nticks)
+ klen += esc_q(nkey+1, key, klen);
+ else
+ (void)Copy(key, nkey+1, klen, char);
+ nkey[++klen] = '\'';
+ nkey[++klen] = '\0';
+ }
+ else {
+ New(0, nkey, klen, char);
+ (void)Copy(key, nkey, klen, char);
+ }
+
+ sname = newSVsv(iname);
+ sv_catpvn(sname, nkey, klen);
+ sv_catpvn(sname, "}", 1);
+
+ sv_catsv(retval, totpad);
+ sv_catsv(retval, ipad);
+ sv_catpvn(retval, nkey, klen);
+ sv_catpvn(retval, " => ", 4);
+ if (indent >= 2) {
+ char *extra;
+ I32 elen = 0;
+ newapad = newSVsv(apad);
+ New(0, extra, klen+4+1, char);
+ while (elen < (klen+4))
+ extra[elen++] = ' ';
+ extra[elen] = '\0';
+ sv_catpvn(newapad, extra, elen);
+ Safefree(extra);
+ }
+ else
+ newapad = apad;
+
+ DD_dump(hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
+ postav, levelp, indent, pad, xpad, newapad, sep,
+ freezer, toaster, purity, deepcopy, quotekeys, bless);
+ SvREFCNT_dec(sname);
+ Safefree(nkey);
+ if (indent >= 2)
+ SvREFCNT_dec(newapad);
+ }
+ if (i) {
+ SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
+ sv_catsv(retval, totpad);
+ sv_catsv(retval, opad);
+ SvREFCNT_dec(opad);
+ }
+ if (name[0] == '%')
+ sv_catpvn(retval, ")", 1);
+ else
+ sv_catpvn(retval, "}", 1);
+ SvREFCNT_dec(iname);
+ SvREFCNT_dec(totpad);
+ }
+ else if (realtype == SVt_PVCV) {
+ sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
+ if (purity)
+ warn("Encountered CODE ref, using dummy placeholder");
+ }
+ else {
+ warn("cannot handle ref type %ld", realtype);
+ }
+
+ if (realpack) { /* free blessed allocs */
+ if (indent >= 2) {
+ SvREFCNT_dec(apad);
+ apad = blesspad;
+ }
+ sv_catpvn(retval, ", '", 3);
+ sv_catpvn(retval, realpack, strlen(realpack));
+ sv_catpvn(retval, "' )", 3);
+ if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
+ sv_catpvn(retval, "->", 2);
+ sv_catsv(retval, toaster);
+ sv_catpvn(retval, "()", 2);
+ }
+ }
+ SvREFCNT_dec(ipad);
+ (*levelp)--;
+ }
+ else {
+ STRLEN i;
+
+ if (namelen) {
+ (void) sprintf(id, "0x%lx", (unsigned long)val);
+ if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
+ (sv = *svp) && SvROK(sv) &&
+ (seenentry = (AV*)SvRV(sv))) {
+ SV *othername;
+ if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
+ sv_catsv(retval, othername);
+ return 1;
+ }
+ }
+ else {
+ SV *namesv;
+ namesv = newSVpv("\\", 1);
+ sv_catpvn(namesv, name, namelen);
+ seenentry = newAV();
+ av_push(seenentry, namesv);
+ (void)SvREFCNT_inc(val);
+ av_push(seenentry, val);
+ (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
+ SvREFCNT_dec(seenentry);
+ }
+ }
+
+ if (SvIOK(val)) {
+ STRLEN len;
+ i = SvIV(val);
+ (void) sprintf(tmpbuf, "%d", i);
+ len = strlen(tmpbuf);
+ sv_catpvn(retval, tmpbuf, len);
+ return 1;
+ }
+ else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
+ c = SvPV(val, i);
+ ++c; --i; /* just get the name */
+ if (i >= 6 && strncmp(c, "main::", 6) == 0) {
+ c += 4;
+ i -= 4;
+ }
+ if (needs_quote(c)) {
+ sv_grow(retval, SvCUR(retval)+6+2*i);
+ r = SvPVX(retval)+SvCUR(retval);
+ r[0] = '*'; r[1] = '{'; r[2] = '\'';
+ i += esc_q(r+3, c, i);
+ i += 3;
+ r[i++] = '\''; r[i++] = '}';
+ r[i] = '\0';
+ }
+ else {
+ sv_grow(retval, SvCUR(retval)+i+2);
+ r = SvPVX(retval)+SvCUR(retval);
+ r[0] = '*'; strcpy(r+1, c);
+ i++;
+ }
+
+ if (purity) {
+ static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
+ static STRLEN sizes[] = { 8, 7, 6 };
+ SV *e;
+ SV *nname = newSVpv("", 0);
+ SV *newapad = newSVpv("", 0);
+ GV *gv = (GV*)val;
+ I32 j;
+
+ for (j=0; j<3; j++) {
+ e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
+ if (e) {
+ I32 nlevel = 0;
+ SV *postentry = newSVpv(r,i);
+
+ sv_setsv(nname, postentry);
+ sv_catpvn(nname, entries[j], sizes[j]);
+ sv_catpvn(postentry, " = ", 3);
+ av_push(postav, postentry);
+ e = newRV(e);
+
+ SvCUR(newapad) = 0;
+ if (indent >= 2)
+ (void)sv_x(newapad, " ", 1, SvCUR(postentry));
+
+ DD_dump(e, SvPVX(nname), SvCUR(nname), postentry,
+ seenhv, postav, &nlevel, indent, pad, xpad,
+ newapad, sep, freezer, toaster, purity,
+ deepcopy, quotekeys, bless);
+ SvREFCNT_dec(e);
+ }
+ }
+
+ SvREFCNT_dec(newapad);
+ SvREFCNT_dec(nname);
+ }
+ }
+ else {
+ c = SvPV(val, i);
+ sv_grow(retval, SvCUR(retval)+3+2*i);
+ r = SvPVX(retval)+SvCUR(retval);
+ r[0] = '\'';
+ i += esc_q(r+1, c, i);
+ ++i;
+ r[i++] = '\'';
+ r[i] = '\0';
+ }
+ SvCUR_set(retval, SvCUR(retval)+i);
+ }
+
+ if (deepcopy && idlen)
+ (void)hv_delete(seenhv, id, idlen, G_DISCARD);
+
+ return 1;
+}
+
+
+MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
+
+#
+# This is the exact equivalent of Dump. Well, almost. The things that are
+# different as of now (due to Laziness):
+# * doesnt do double-quotes yet.
+#
+
+void
+Data_Dumper_Dumpxs(href, ...)
+ SV *href;
+ PROTOTYPE: $;$$
+ PPCODE:
+ {
+ HV *hv;
+ SV *retval, *valstr;
+ HV *seenhv = Nullhv;
+ AV *postav, *todumpav, *namesav;
+ I32 level = 0;
+ I32 indent, terse, useqq, i, imax, postlen;
+ SV **svp;
+ SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname;
+ SV *freezer, *toaster, *bless;
+ I32 purity, deepcopy, quotekeys;
+ char tmpbuf[1024];
+ I32 gimme = GIMME;
+
+ if (!SvROK(href)) { /* call new to get an object first */
+ SV *valarray;
+ SV *namearray;
+
+ if (items == 3) {
+ valarray = ST(1);
+ namearray = ST(2);
+ }
+ else
+ croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, NAME_ARY_REF)");
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(sp);
+ XPUSHs(href);
+ XPUSHs(sv_2mortal(newSVsv(valarray)));
+ XPUSHs(sv_2mortal(newSVsv(namearray)));
+ PUTBACK;
+ i = perl_call_method("new", G_SCALAR);
+ SPAGAIN;
+ if (i)
+ href = newSVsv(POPs);
+
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ if (i)
+ (void)sv_2mortal(href);
+ }
+
+ todumpav = namesav = Nullav;
+ seenhv = Nullhv;
+ val = pad = xpad = apad = sep = tmp = varname
+ = freezer = toaster = bless = &PL_sv_undef;
+ name = sv_newmortal();
+ indent = 2;
+ terse = useqq = purity = deepcopy = 0;
+ quotekeys = 1;
+
+ retval = newSVpv("", 0);
+ if (SvROK(href)
+ && (hv = (HV*)SvRV((SV*)href))
+ && SvTYPE(hv) == SVt_PVHV) {
+
+ if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
+ seenhv = (HV*)SvRV(*svp);
+ if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
+ todumpav = (AV*)SvRV(*svp);
+ if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
+ namesav = (AV*)SvRV(*svp);
+ if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
+ indent = SvIV(*svp);
+ if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
+ purity = SvIV(*svp);
+ if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
+ terse = SvTRUE(*svp);
+ if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
+ useqq = SvTRUE(*svp);
+ if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
+ pad = *svp;
+ if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
+ xpad = *svp;
+ if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
+ apad = *svp;
+ if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
+ sep = *svp;
+ if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
+ varname = *svp;
+ if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
+ freezer = *svp;
+ if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
+ toaster = *svp;
+ if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
+ deepcopy = SvTRUE(*svp);
+ if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
+ quotekeys = SvTRUE(*svp);
+ if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
+ bless = *svp;
+ postav = newAV();
+
+ if (todumpav)
+ imax = av_len(todumpav);
+ else
+ imax = -1;
+ valstr = newSVpv("",0);
+ for (i = 0; i <= imax; ++i) {
+ SV *newapad;
+
+ av_clear(postav);
+ if ((svp = av_fetch(todumpav, i, FALSE)))
+ val = *svp;
+ else
+ val = &PL_sv_undef;
+ if ((svp = av_fetch(namesav, i, TRUE)))
+ sv_setsv(name, *svp);
+ else
+ SvOK_off(name);
+
+ if (SvOK(name)) {
+ if ((SvPVX(name))[0] == '*') {
+ if (SvROK(val)) {
+ switch (SvTYPE(SvRV(val))) {
+ case SVt_PVAV:
+ (SvPVX(name))[0] = '@';
+ break;
+ case SVt_PVHV:
+ (SvPVX(name))[0] = '%';
+ break;
+ case SVt_PVCV:
+ (SvPVX(name))[0] = '*';
+ break;
+ default:
+ (SvPVX(name))[0] = '$';
+ break;
+ }
+ }
+ else
+ (SvPVX(name))[0] = '$';
+ }
+ else if ((SvPVX(name))[0] != '$')
+ sv_insert(name, 0, 0, "$", 1);
+ }
+ else {
+ STRLEN nchars = 0;
+ sv_setpvn(name, "$", 1);
+ sv_catsv(name, varname);
+ (void) sprintf(tmpbuf, "%ld", i+1);
+ nchars = strlen(tmpbuf);
+ sv_catpvn(name, tmpbuf, nchars);
+ }
+
+ if (indent >= 2) {
+ SV *tmpsv = sv_x(Nullsv, " ", 1, SvCUR(name)+3);
+ newapad = newSVsv(apad);
+ sv_catsv(newapad, tmpsv);
+ SvREFCNT_dec(tmpsv);
+ }
+ else
+ newapad = apad;
+
+ DD_dump(val, SvPVX(name), SvCUR(name), valstr, seenhv,
+ postav, &level, indent, pad, xpad, newapad, sep,
+ freezer, toaster, purity, deepcopy, quotekeys,
+ bless);
+
+ if (indent >= 2)
+ SvREFCNT_dec(newapad);
+
+ postlen = av_len(postav);
+ if (postlen >= 0 || !terse) {
+ sv_insert(valstr, 0, 0, " = ", 3);
+ sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
+ sv_catpvn(valstr, ";", 1);
+ }
+ sv_catsv(retval, pad);
+ sv_catsv(retval, valstr);
+ sv_catsv(retval, sep);
+ if (postlen >= 0) {
+ I32 i;
+ sv_catsv(retval, pad);
+ for (i = 0; i <= postlen; ++i) {
+ SV *elem;
+ svp = av_fetch(postav, i, FALSE);
+ if (svp && (elem = *svp)) {
+ sv_catsv(retval, elem);
+ if (i < postlen) {
+ sv_catpvn(retval, ";", 1);
+ sv_catsv(retval, sep);
+ sv_catsv(retval, pad);
+ }
+ }
+ }
+ sv_catpvn(retval, ";", 1);
+ sv_catsv(retval, sep);
+ }
+ sv_setpvn(valstr, "", 0);
+ if (gimme == G_ARRAY) {
+ XPUSHs(sv_2mortal(retval));
+ if (i < imax) /* not the last time thro ? */
+ retval = newSVpv("",0);
+ }
+ }
+ SvREFCNT_dec(postav);
+ SvREFCNT_dec(valstr);
+ }
+ else
+ croak("Call to new() method failed to return HASH ref");
+ if (gimme == G_SCALAR)
+ XPUSHs(sv_2mortal(retval));
+ }
diff --git a/contrib/perl5/ext/Data/Dumper/Makefile.PL b/contrib/perl5/ext/Data/Dumper/Makefile.PL
new file mode 100644
index 000000000000..6c94e95dffbb
--- /dev/null
+++ b/contrib/perl5/ext/Data/Dumper/Makefile.PL
@@ -0,0 +1,11 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => "Data::Dumper",
+ VERSION_FROM => 'Dumper.pm',
+ 'dist' => {
+ COMPRESS => 'gzip -9f',
+ SUFFIX => 'gz',
+ DIST_DEFAULT => 'all tardist',
+ },
+ MAN3PODS => ' ',
+);
diff --git a/contrib/perl5/ext/Data/Dumper/Todo b/contrib/perl5/ext/Data/Dumper/Todo
new file mode 100644
index 000000000000..4a41f97d7f00
--- /dev/null
+++ b/contrib/perl5/ext/Data/Dumper/Todo
@@ -0,0 +1,32 @@
+=head1 NAME
+
+TODO - seeds germane, yet not germinated
+
+=head1 DESCRIPTION
+
+The following functionality will be supported in the next few releases.
+
+=over 4
+
+=item $Data::Dumper::Maxdepth I<or> $I<OBJ>->Maxdepth(I<NEWVAL>)
+
+Depth beyond which we don't venture into a structure. Has no effect when
+C<Data::Dumper::Purity> is set. (useful in debugger when we often don't
+want to see more than enough).
+
+=item $Data::Dumper::Expdepth I<or> $I<OBJ>->Expdepth(I<NEWVAL>)
+
+Dump contents explicitly up to a certain depth and then use names for
+cross-referencing identical references. (useful in debugger, in situations
+where we don't care so much for cross-references).
+
+=item Make C<Dumpxs()> honor C<$Useqq>
+
+=item Fix formatting when Terse is set and Indent >= 2
+
+=item Output space after '\' (ref constructor) for high enough Indent
+
+=item Implement redesign that allows various backends (Perl, Lisp,
+some-binary-data-format, graph-description-languages, etc.)
+
+=back
diff --git a/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL
new file mode 100644
index 000000000000..4c4155985db9
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/DynaLoader_pm.PL
@@ -0,0 +1,729 @@
+
+use Config;
+
+sub to_string {
+ my ($value) = @_;
+ $value =~ s/\\/\\\\'/g;
+ $value =~ s/'/\\'/g;
+ return "'$value'";
+}
+
+unlink "DynaLoader.pm" if -f "DynaLoader.pm";
+open OUT, ">DynaLoader.pm" or die $!;
+print OUT <<'EOT';
+
+# Generated from DynaLoader.pm.PL (resolved %Config::Config values)
+
+package DynaLoader;
+
+# And Gandalf said: 'Many folk like to know beforehand what is to
+# be set on the table; but those who have laboured to prepare the
+# feast like to keep their secret; for wonder makes the words of
+# praise louder.'
+
+# (Quote from Tolkien sugested by Anno Siegel.)
+#
+# See pod text at end of file for documentation.
+# See also ext/DynaLoader/README in source tree for other information.
+#
+# Tim.Bunce@ig.co.uk, August 1994
+
+$VERSION = $VERSION = "1.03"; # avoid typo warning
+
+require AutoLoader;
+*AUTOLOAD = \&AutoLoader::AUTOLOAD;
+
+# The following require can't be removed during maintenance
+# releases, sadly, because of the risk of buggy code that does
+# require Carp; Carp::croak "..."; without brackets dying
+# if Carp hasn't been loaded in earlier compile time. :-(
+# We'll let those bugs get found on the development track.
+require Carp if $] < 5.00450;
+
+
+# enable debug/trace messages from DynaLoader perl code
+$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
+
+#
+# Flags to alter dl_load_file behaviour. Assigned bits:
+# 0x01 make symbols available for linking later dl_load_file's.
+# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
+# (ignored under VMS; effect is built-in to image linking)
+#
+# This is called as a class method $module->dl_load_flags. The
+# definition here will be inherited and result on "default" loading
+# behaviour unless a sub-class of DynaLoader defines its own version.
+#
+
+sub dl_load_flags { 0x00 }
+
+# ($dl_dlext, $dlsrc)
+# = @Config::Config{'dlext', 'dlsrc'};
+EOT
+
+print OUT " (\$dl_dlext, \$dlsrc) = (",
+ to_string($Config::Config{'dlext'}), ",",
+ to_string($Config::Config{'dlsrc'}), ")\n;" ;
+
+print OUT <<'EOT';
+
+# Some systems need special handling to expand file specifications
+# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>)
+# See dl_expandspec() for more details. Should be harmless but
+# inefficient to define on systems that don't need it.
+$do_expand = $Is_VMS = $^O eq 'VMS';
+
+@dl_require_symbols = (); # names of symbols we need
+@dl_resolve_using = (); # names of files to link with
+@dl_library_path = (); # path to look for files
+@dl_librefs = (); # things we have loaded
+@dl_modules = (); # Modules we have loaded
+
+# This is a fix to support DLD's unfortunate desire to relink -lc
+@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs";
+
+# Initialise @dl_library_path with the 'standard' library path
+# for this platform as determined by Configure
+
+# push(@dl_library_path, split(' ', $Config::Config{'libpth'});
+EOT
+
+print OUT "push(\@dl_library_path, split(' ', ",
+ to_string($Config::Config{'libpth'}), "));\n";
+
+print OUT <<'EOT';
+
+# Add to @dl_library_path any extra directories we can gather from
+# environment variables. So far LD_LIBRARY_PATH is the only known
+# variable used for this purpose. Others may be added later.
+push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH}))
+ if $ENV{LD_LIBRARY_PATH};
+
+
+# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
+boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader);
+
+
+if ($dl_debug) {
+ print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n";
+ print STDERR "DynaLoader not linked into this perl\n"
+ unless defined(&boot_DynaLoader);
+}
+
+1; # End of main code
+
+
+sub croak { require Carp; Carp::croak(@_) }
+
+# The bootstrap function cannot be autoloaded (without complications)
+# so we define it here:
+
+sub bootstrap {
+ # use local vars to enable $module.bs script to edit values
+ local(@args) = @_;
+ local($module) = $args[0];
+ local(@dirs, $file);
+
+ unless ($module) {
+ require Carp;
+ Carp::confess("Usage: DynaLoader::bootstrap(module)");
+ }
+
+ # A common error on platforms which don't support dynamic loading.
+ # Since it's fatal and potentially confusing we give a detailed message.
+ croak("Can't load module $module, dynamic loading not available in this perl.\n".
+ " (You may need to build a new perl executable which either supports\n".
+ " dynamic loading or has the $module module statically linked into it.)\n")
+ unless defined(&dl_load_file);
+
+ my @modparts = split(/::/,$module);
+ my $modfname = $modparts[-1];
+
+ # Some systems have restrictions on files names for DLL's etc.
+ # mod2fname returns appropriate file base name (typically truncated)
+ # It may also edit @modparts if required.
+ $modfname = &mod2fname(\@modparts) if defined &mod2fname;
+
+ my $modpname = join('/',@modparts);
+
+ print STDERR "DynaLoader::bootstrap for $module ",
+ "(auto/$modpname/$modfname.$dl_dlext)\n" if $dl_debug;
+
+ foreach (@INC) {
+ chop($_ = VMS::Filespec::unixpath($_)) if $Is_VMS;
+ my $dir = "$_/auto/$modpname";
+ next unless -d $dir; # skip over uninteresting directories
+
+ # check for common cases to avoid autoload of dl_findfile
+ my $try = "$dir/$modfname.$dl_dlext";
+ last if $file = ($do_expand) ? dl_expandspec($try) : (-f $try && $try);
+
+ # no luck here, save dir for possible later dl_findfile search
+ push @dirs, $dir;
+ }
+ # last resort, let dl_findfile have a go in all known locations
+ $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file;
+
+ croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)")
+ unless $file; # wording similar to error from 'require'
+
+ my $bootname = "boot_$module";
+ $bootname =~ s/\W/_/g;
+ @dl_require_symbols = ($bootname);
+
+ # Execute optional '.bootstrap' perl script for this module.
+ # The .bs file can be used to configure @dl_resolve_using etc to
+ # match the needs of the individual module on this architecture.
+ my $bs = $file;
+ $bs =~ s/(\.\w+)?$/\.bs/; # look for .bs 'beside' the library
+ if (-s $bs) { # only read file if it's not empty
+ print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
+ eval { do $bs; };
+ warn "$bs: $@\n" if $@;
+ }
+
+ # Many dynamic extension loading problems will appear to come from
+ # this section of code: XYZ failed at line 123 of DynaLoader.pm.
+ # Often these errors are actually occurring in the initialisation
+ # C code of the extension XS file. Perl reports the error as being
+ # in this perl code simply because this was the last perl code
+ # it executed.
+
+ my $libref = dl_load_file($file, $module->dl_load_flags) or
+ croak("Can't load '$file' for module $module: ".dl_error()."\n");
+
+ push(@dl_librefs,$libref); # record loaded object
+
+ my @unresolved = dl_undef_symbols();
+ if (@unresolved) {
+ require Carp;
+ Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
+ }
+
+ my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or
+ croak("Can't find '$bootname' symbol in $file\n");
+
+ my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file);
+
+ push(@dl_modules, $module); # record loaded module
+
+ # See comment block above
+ &$xs(@args);
+}
+
+
+#sub _check_file { # private utility to handle dl_expandspec vs -f tests
+# my($file) = @_;
+# return $file if (!$do_expand && -f $file); # the common case
+# return $file if ( $do_expand && ($file=dl_expandspec($file)));
+# return undef;
+#}
+
+
+# Let autosplit and the autoloader deal with these functions:
+__END__
+
+
+sub dl_findfile {
+ # Read ext/DynaLoader/DynaLoader.doc for detailed information.
+ # This function does not automatically consider the architecture
+ # or the perl library auto directories.
+ my (@args) = @_;
+ my (@dirs, $dir); # which directories to search
+ my (@found); # full paths to real files we have found
+EOT
+
+print OUT ' my $dl_ext= ' . to_string($Config::Config{'dlext'}) .
+ "; # \$Config::Config{'dlext'} suffix for perl extensions\n";
+print OUT ' my $dl_so = ' . to_string($Config::Config{'so'}) .
+ "; # \$Config::Config{'so'} suffix for shared libraries\n";
+
+print OUT <<'EOT';
+
+ print STDERR "dl_findfile(@args)\n" if $dl_debug;
+
+ # accumulate directories but process files as they appear
+ arg: foreach(@args) {
+ # Special fast case: full filepath requires no search
+ if ($Is_VMS && m%[:>/\]]% && -f $_) {
+ push(@found,dl_expandspec(VMS::Filespec::vmsify($_)));
+ last arg unless wantarray;
+ next;
+ }
+ elsif (m:/: && -f $_ && !$do_expand) {
+ push(@found,$_);
+ last arg unless wantarray;
+ next;
+ }
+
+ # Deal with directories first:
+ # Using a -L prefix is the preferred option (faster and more robust)
+ if (m:^-L:) { s/^-L//; push(@dirs, $_); next; }
+
+ # Otherwise we try to try to spot directories by a heuristic
+ # (this is a more complicated issue than it first appears)
+ if (m:/: && -d $_) { push(@dirs, $_); next; }
+
+ # VMS: we may be using native VMS directry syntax instead of
+ # Unix emulation, so check this as well
+ if ($Is_VMS && /[:>\]]/ && -d $_) { push(@dirs, $_); next; }
+
+ # Only files should get this far...
+ my(@names, $name); # what filenames to look for
+ if (m:-l: ) { # convert -lname to appropriate library name
+ s/-l//;
+ push(@names,"lib$_.$dl_so");
+ push(@names,"lib$_.a");
+ } else { # Umm, a bare name. Try various alternatives:
+ # these should be ordered with the most likely first
+ push(@names,"$_.$dl_ext") unless m/\.$dl_ext$/o;
+ push(@names,"$_.$dl_so") unless m/\.$dl_so$/o;
+ push(@names,"lib$_.$dl_so") unless m:/:;
+ push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs";
+ push(@names, $_);
+ }
+ foreach $dir (@dirs, @dl_library_path) {
+ next unless -d $dir;
+ chop($dir = VMS::Filespec::unixpath($dir)) if $Is_VMS;
+ foreach $name (@names) {
+ my($file) = "$dir/$name";
+ print STDERR " checking in $dir for $name\n" if $dl_debug;
+ $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file);
+ #$file = _check_file($file);
+ if ($file) {
+ push(@found, $file);
+ next arg; # no need to look any further
+ }
+ }
+ }
+ }
+ if ($dl_debug) {
+ foreach(@dirs) {
+ print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_;
+ }
+ print STDERR "dl_findfile found: @found\n";
+ }
+ return $found[0] unless wantarray;
+ @found;
+}
+
+
+sub dl_expandspec {
+ my($spec) = @_;
+ # Optional function invoked if DynaLoader.pm sets $do_expand.
+ # Most systems do not require or use this function.
+ # Some systems may implement it in the dl_*.xs file in which case
+ # this autoload version will not be called but is harmless.
+
+ # This function is designed to deal with systems which treat some
+ # 'filenames' in a special way. For example VMS 'Logical Names'
+ # (something like unix environment variables - but different).
+ # This function should recognise such names and expand them into
+ # full file paths.
+ # Must return undef if $spec is invalid or file does not exist.
+
+ my $file = $spec; # default output to input
+
+ if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs
+ require Carp;
+ Carp::croak("dl_expandspec: should be defined in XS file!\n");
+ } else {
+ return undef unless -f $file;
+ }
+ print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug;
+ $file;
+}
+
+sub dl_find_symbol_anywhere
+{
+ my $sym = shift;
+ my $libref;
+ foreach $libref (@dl_librefs) {
+ my $symref = dl_find_symbol($libref,$sym);
+ return $symref if $symref;
+ }
+ return undef;
+}
+
+=head1 NAME
+
+DynaLoader - Dynamically load C libraries into Perl code
+
+dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(), dl_load_flags(), bootstrap() - routines used by DynaLoader modules
+
+=head1 SYNOPSIS
+
+ package YourPackage;
+ require DynaLoader;
+ @ISA = qw(... DynaLoader ...);
+ bootstrap YourPackage;
+
+ # optional method for 'global' loading
+ sub dl_load_flags { 0x01 }
+
+
+=head1 DESCRIPTION
+
+This document defines a standard generic interface to the dynamic
+linking mechanisms available on many platforms. Its primary purpose is
+to implement automatic dynamic loading of Perl modules.
+
+This document serves as both a specification for anyone wishing to
+implement the DynaLoader for a new platform and as a guide for
+anyone wishing to use the DynaLoader directly in an application.
+
+The DynaLoader is designed to be a very simple high-level
+interface that is sufficiently general to cover the requirements
+of SunOS, HP-UX, NeXT, Linux, VMS and other platforms.
+
+It is also hoped that the interface will cover the needs of OS/2, NT
+etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime).
+
+It must be stressed that the DynaLoader, by itself, is practically
+useless for accessing non-Perl libraries because it provides almost no
+Perl-to-C 'glue'. There is, for example, no mechanism for calling a C
+library function or supplying arguments. A C::DynaLib module
+is available from CPAN sites which performs that function for some
+common system types.
+
+DynaLoader Interface Summary
+
+ @dl_library_path
+ @dl_resolve_using
+ @dl_require_symbols
+ $dl_debug
+ @dl_librefs
+ @dl_modules
+ Implemented in:
+ bootstrap($modulename) Perl
+ @filepaths = dl_findfile(@names) Perl
+ $flags = $modulename->dl_load_flags Perl
+ $symref = dl_find_symbol_anywhere($symbol) Perl
+
+ $libref = dl_load_file($filename, $flags) C
+ $symref = dl_find_symbol($libref, $symbol) C
+ @symbols = dl_undef_symbols() C
+ dl_install_xsub($name, $symref [, $filename]) C
+ $message = dl_error C
+
+=over 4
+
+=item @dl_library_path
+
+The standard/default list of directories in which dl_findfile() will
+search for libraries etc. Directories are searched in order:
+$dl_library_path[0], [1], ... etc
+
+@dl_library_path is initialised to hold the list of 'normal' directories
+(F</usr/lib>, etc) determined by B<Configure> (C<$Config{'libpth'}>). This should
+ensure portability across a wide range of platforms.
+
+@dl_library_path should also be initialised with any other directories
+that can be determined from the environment at runtime (such as
+LD_LIBRARY_PATH for SunOS).
+
+After initialisation @dl_library_path can be manipulated by an
+application using push and unshift before calling dl_findfile().
+Unshift can be used to add directories to the front of the search order
+either to save search time or to override libraries with the same name
+in the 'normal' directories.
+
+The load function that dl_load_file() calls may require an absolute
+pathname. The dl_findfile() function and @dl_library_path can be
+used to search for and return the absolute pathname for the
+library/object that you wish to load.
+
+=item @dl_resolve_using
+
+A list of additional libraries or other shared objects which can be
+used to resolve any undefined symbols that might be generated by a
+later call to load_file().
+
+This is only required on some platforms which do not handle dependent
+libraries automatically. For example the Socket Perl extension
+library (F<auto/Socket/Socket.so>) contains references to many socket
+functions which need to be resolved when it's loaded. Most platforms
+will automatically know where to find the 'dependent' library (e.g.,
+F</usr/lib/libsocket.so>). A few platforms need to be told the
+location of the dependent library explicitly. Use @dl_resolve_using
+for this.
+
+Example usage:
+
+ @dl_resolve_using = dl_findfile('-lsocket');
+
+=item @dl_require_symbols
+
+A list of one or more symbol names that are in the library/object file
+to be dynamically loaded. This is only required on some platforms.
+
+=item @dl_librefs
+
+An array of the handles returned by successful calls to dl_load_file(),
+made by bootstrap, in the order in which they were loaded.
+Can be used with dl_find_symbol() to look for a symbol in any of
+the loaded files.
+
+=item @dl_modules
+
+An array of module (package) names that have been bootstrap'ed.
+
+=item dl_error()
+
+Syntax:
+
+ $message = dl_error();
+
+Error message text from the last failed DynaLoader function. Note
+that, similar to errno in unix, a successful function call does not
+reset this message.
+
+Implementations should detect the error as soon as it occurs in any of
+the other functions and save the corresponding message for later
+retrieval. This will avoid problems on some platforms (such as SunOS)
+where the error message is very temporary (e.g., dlerror()).
+
+=item $dl_debug
+
+Internal debugging messages are enabled when $dl_debug is set true.
+Currently setting $dl_debug only affects the Perl side of the
+DynaLoader. These messages should help an application developer to
+resolve any DynaLoader usage problems.
+
+$dl_debug is set to C<$ENV{'PERL_DL_DEBUG'}> if defined.
+
+For the DynaLoader developer/porter there is a similar debugging
+variable added to the C code (see dlutils.c) and enabled if Perl was
+built with the B<-DDEBUGGING> flag. This can also be set via the
+PERL_DL_DEBUG environment variable. Set to 1 for minimal information or
+higher for more.
+
+=item dl_findfile()
+
+Syntax:
+
+ @filepaths = dl_findfile(@names)
+
+Determine the full paths (including file suffix) of one or more
+loadable files given their generic names and optionally one or more
+directories. Searches directories in @dl_library_path by default and
+returns an empty list if no files were found.
+
+Names can be specified in a variety of platform independent forms. Any
+names in the form B<-lname> are converted into F<libname.*>, where F<.*> is
+an appropriate suffix for the platform.
+
+If a name does not already have a suitable prefix and/or suffix then
+the corresponding file will be searched for by trying combinations of
+prefix and suffix appropriate to the platform: "$name.o", "lib$name.*"
+and "$name".
+
+If any directories are included in @names they are searched before
+@dl_library_path. Directories may be specified as B<-Ldir>. Any other
+names are treated as filenames to be searched for.
+
+Using arguments of the form C<-Ldir> and C<-lname> is recommended.
+
+Example:
+
+ @dl_resolve_using = dl_findfile(qw(-L/usr/5lib -lposix));
+
+
+=item dl_expandspec()
+
+Syntax:
+
+ $filepath = dl_expandspec($spec)
+
+Some unusual systems, such as VMS, require special filename handling in
+order to deal with symbolic names for files (i.e., VMS's Logical Names).
+
+To support these systems a dl_expandspec() function can be implemented
+either in the F<dl_*.xs> file or code can be added to the autoloadable
+dl_expandspec() function in F<DynaLoader.pm>. See F<DynaLoader.pm> for
+more information.
+
+=item dl_load_file()
+
+Syntax:
+
+ $libref = dl_load_file($filename, $flags)
+
+Dynamically load $filename, which must be the path to a shared object
+or library. An opaque 'library reference' is returned as a handle for
+the loaded object. Returns undef on error.
+
+The $flags argument to alters dl_load_file behaviour.
+Assigned bits:
+
+ 0x01 make symbols available for linking later dl_load_file's.
+ (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL))
+ (ignored under VMS; this is a normal part of image linking)
+
+(On systems that provide a handle for the loaded object such as SunOS
+and HPUX, $libref will be that handle. On other systems $libref will
+typically be $filename or a pointer to a buffer containing $filename.
+The application should not examine or alter $libref in any way.)
+
+This is the function that does the real work. It should use the
+current values of @dl_require_symbols and @dl_resolve_using if required.
+
+ SunOS: dlopen($filename)
+ HP-UX: shl_load($filename)
+ Linux: dld_create_reference(@dl_require_symbols); dld_link($filename)
+ NeXT: rld_load($filename, @dl_resolve_using)
+ VMS: lib$find_image_symbol($filename,$dl_require_symbols[0])
+
+(The dlopen() function is also used by Solaris and some versions of
+Linux, and is a common choice when providing a "wrapper" on other
+mechanisms as is done in the OS/2 port.)
+
+=item dl_loadflags()
+
+Syntax:
+
+ $flags = dl_loadflags $modulename;
+
+Designed to be a method call, and to be overridden by a derived class
+(i.e. a class which has DynaLoader in its @ISA). The definition in
+DynaLoader itself returns 0, which produces standard behavior from
+dl_load_file().
+
+=item dl_find_symbol()
+
+Syntax:
+
+ $symref = dl_find_symbol($libref, $symbol)
+
+Return the address of the symbol $symbol or C<undef> if not found. If the
+target system has separate functions to search for symbols of different
+types then dl_find_symbol() should search for function symbols first and
+then other types.
+
+The exact manner in which the address is returned in $symref is not
+currently defined. The only initial requirement is that $symref can
+be passed to, and understood by, dl_install_xsub().
+
+ SunOS: dlsym($libref, $symbol)
+ HP-UX: shl_findsym($libref, $symbol)
+ Linux: dld_get_func($symbol) and/or dld_get_symbol($symbol)
+ NeXT: rld_lookup("_$symbol")
+ VMS: lib$find_image_symbol($libref,$symbol)
+
+
+=item dl_find_symbol_anywhere()
+
+Syntax:
+
+ $symref = dl_find_symbol_anywhere($symbol)
+
+Applies dl_find_symbol() to the members of @dl_librefs and returns
+the first match found.
+
+=item dl_undef_symbols()
+
+Example
+
+ @symbols = dl_undef_symbols()
+
+Return a list of symbol names which remain undefined after load_file().
+Returns C<()> if not known. Don't worry if your platform does not provide
+a mechanism for this. Most do not need it and hence do not provide it,
+they just return an empty list.
+
+
+=item dl_install_xsub()
+
+Syntax:
+
+ dl_install_xsub($perl_name, $symref [, $filename])
+
+Create a new Perl external subroutine named $perl_name using $symref as
+a pointer to the function which implements the routine. This is simply
+a direct call to newXSUB(). Returns a reference to the installed
+function.
+
+The $filename parameter is used by Perl to identify the source file for
+the function if required by die(), caller() or the debugger. If
+$filename is not defined then "DynaLoader" will be used.
+
+
+=item bootstrap()
+
+Syntax:
+
+bootstrap($module)
+
+This is the normal entry point for automatic dynamic loading in Perl.
+
+It performs the following actions:
+
+=over 8
+
+=item *
+
+locates an auto/$module directory by searching @INC
+
+=item *
+
+uses dl_findfile() to determine the filename to load
+
+=item *
+
+sets @dl_require_symbols to C<("boot_$module")>
+
+=item *
+
+executes an F<auto/$module/$module.bs> file if it exists
+(typically used to add to @dl_resolve_using any files which
+are required to load the module on the current platform)
+
+=item *
+
+calls dl_load_flags() to determine how to load the file.
+
+=item *
+
+calls dl_load_file() to load the file
+
+=item *
+
+calls dl_undef_symbols() and warns if any symbols are undefined
+
+=item *
+
+calls dl_find_symbol() for "boot_$module"
+
+=item *
+
+calls dl_install_xsub() to install it as "${module}::bootstrap"
+
+=item *
+
+calls &{"${module}::bootstrap"} to bootstrap the module (actually
+it uses the function reference returned by dl_install_xsub for speed)
+
+=back
+
+=back
+
+
+=head1 AUTHOR
+
+Tim Bunce, 11 August 1994.
+
+This interface is based on the work and comments of (in no particular
+order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno
+Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others.
+
+Larry Wall designed the elegant inherited bootstrap mechanism and
+implemented the first Perl 5 dynamic loader using it.
+
+Solaris global loading added by Nick Ing-Simmons with design/coding
+assistance from Tim Bunce, January 1996.
+
+=cut
+EOT
+
+close OUT or die $!;
+
diff --git a/contrib/perl5/ext/DynaLoader/Makefile.PL b/contrib/perl5/ext/DynaLoader/Makefile.PL
new file mode 100644
index 000000000000..7a75115dc45f
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/Makefile.PL
@@ -0,0 +1,29 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'DynaLoader',
+ LINKTYPE => 'static',
+ DEFINE => '-DPERL_CORE -DLIBC="$(LIBC)"',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ SKIP => [qw(dynamic dynamic_lib dynamic_bs)],
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'DynaLoader_pm.PL',
+ PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm'},
+ PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm'},
+ clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm'},
+);
+
+sub MY::postamble {
+ '
+DynaLoader.xs: $(DLSRC)
+ $(CP) $? $@
+
+# Perform very simple tests just to check for major gaffs.
+# We can\'t do much more for platforms we are not executing on.
+test-xs:
+ for i in dl_*xs; \
+ do $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSUBPPARGS) $$i > /dev/null; \
+ done
+';
+}
+
diff --git a/contrib/perl5/ext/DynaLoader/README b/contrib/perl5/ext/DynaLoader/README
new file mode 100644
index 000000000000..0551cf375c9c
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/README
@@ -0,0 +1,53 @@
+Perl 5 DynaLoader
+
+See DynaLoader.pm for detailed specification.
+
+This module is very similar to the other Perl 5 modules except that
+Configure selects which dl_*.xs file to use.
+
+After Configure has been run the Makefile.PL will generate a Makefile
+which will run xsubpp on a specific dl_*.xs file and write the output
+to DynaLoader.c
+
+After that the processing is the same as any other module.
+
+Note that, to be effective, the DynaLoader module must be _statically_
+linked into perl! Configure should arrange this.
+
+This interface is based on the work and comments of (in no particular
+order): Larry Wall, Robert Sanders, Dean Roehrich, Jeff Okamoto, Anno
+Siegel, Thomas Neumann, Paul Marquess, Charles Bailey and others.
+
+The dl_*.xs files should either be named after the dynamic linking
+operating system interface used if that interface is available on more
+than one type of system, e.g.:
+ dlopen for dlopen()/dlsym() type functions (SunOS, BSD)
+ dld for the GNU dld library functions (linux, ?)
+or else the osname, e.g., hpux, next, vms etc.
+
+Both are determined by Configure and so only those specific names that
+Configure knows/uses will work.
+
+If porting the DynaLoader to a platform that has a core dynamic linking
+interface similar to an existing generic type, e.g., dlopen or dld,
+please try to port the corresponding dl_*.xs file (using #ifdef's if
+required).
+
+Otherwise, or if that proves too messy, create a new dl_*.xs file named
+after your osname. Configure will give preference to a dl_$osname.xs
+file if one exists.
+
+The file dl_dlopen.xs is a reference implementation by Paul Marquess
+which is a good place to start if porting from scratch. For more complex
+platforms take a look at dl_dld.xs. The dlutils.c file holds some
+common definitions that are #included into the dl_*.xs files.
+
+After the initial implementation of a new DynaLoader dl_*.xs file you
+may need to edit or create ext/MODULE/MODULE.bs files (library bootstrap
+files) to reflect the needs of your platform and linking software.
+
+Refer to DynaLoader.pm, lib/ExtUtils/MakeMaker.pm and any existing
+ext/MODULE/MODULE.bs files for more information.
+
+Tim Bunce.
+August 1994
diff --git a/contrib/perl5/ext/DynaLoader/dl_aix.xs b/contrib/perl5/ext/DynaLoader/dl_aix.xs
new file mode 100644
index 000000000000..ea5040857d05
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dl_aix.xs
@@ -0,0 +1,670 @@
+/* dl_aix.xs
+ *
+ * Written: 8/31/94 by Wayne Scott (wscott@ichips.intel.com)
+ *
+ * All I did was take Jens-Uwe Mager's libdl emulation library for
+ * AIX and merged it with the dl_dlopen.xs file to create a dynamic library
+ * package that works for AIX.
+ *
+ * I did change all malloc's, free's, strdup's, calloc's to use the perl
+ * equilvant. I also removed some stuff we will not need. Call fini()
+ * on statup... It can probably be trimmed more.
+ */
+
+/*
+ * @(#)dlfcn.c 1.5 revision of 93/02/14 20:14:17
+ * This is an unpublished work copyright (c) 1992 Helios Software GmbH
+ * 3000 Hannover 1, Germany
+ */
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <stdio.h>
+#include <errno.h>
+#include <string.h>
+#include <stdlib.h>
+#include <sys/types.h>
+#include <sys/ldr.h>
+#include <a.out.h>
+#include <ldfcn.h>
+
+/*
+ * AIX 4.3 does remove some useful definitions from ldfcn.h. Define
+ * these here to compensate for that lossage.
+ */
+#ifndef BEGINNING
+# define BEGINNING SEEK_SET
+#endif
+#ifndef FSEEK
+# define FSEEK(ldptr,o,p) fseek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr) +o):o,p)
+#endif
+#ifndef FREAD
+# define FREAD(p,s,n,ldptr) fread(p,s,n,IOPTR(ldptr))
+#endif
+
+/* If using PerlIO, redefine these macros from <ldfcn.h> */
+#ifdef USE_PERLIO
+#define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p)
+#define FREAD(p,s,n,ldptr) PerlIO_read(IOPTR(ldptr),p,s*n)
+#endif
+
+/*
+ * We simulate dlopen() et al. through a call to load. Because AIX has
+ * no call to find an exported symbol we read the loader section of the
+ * loaded module and build a list of exported symbols and their virtual
+ * address.
+ */
+
+typedef struct {
+ char *name; /* the symbols's name */
+ void *addr; /* its relocated virtual address */
+} Export, *ExportPtr;
+
+/*
+ * The void * handle returned from dlopen is actually a ModulePtr.
+ */
+typedef struct Module {
+ struct Module *next;
+ char *name; /* module name for refcounting */
+ int refCnt; /* the number of references */
+ void *entry; /* entry point from load */
+ int nExports; /* the number of exports found */
+ ExportPtr exports; /* the array of exports */
+} Module, *ModulePtr;
+
+/*
+ * We keep a list of all loaded modules to be able to call the fini
+ * handlers at atexit() time.
+ */
+static ModulePtr modList;
+
+/*
+ * The last error from one of the dl* routines is kept in static
+ * variables here. Each error is returned only once to the caller.
+ */
+static char errbuf[BUFSIZ];
+static int errvalid;
+
+static void caterr(char *);
+static int readExports(ModulePtr);
+static void terminate(void);
+static void *findMain(void);
+
+static char *strerror_failed = "(strerror failed)";
+static char *strerror_r_failed = "(strerror_r failed)";
+
+char *strerrorcat(char *str, int err) {
+ int strsiz = strlen(str);
+ int msgsiz;
+ char *msg;
+
+#ifdef USE_THREADS
+ char *buf = malloc(BUFSIZ);
+
+ if (buf == 0)
+ return 0;
+ if (strerror_r(err, buf, sizeof(buf)) == 0)
+ msg = buf;
+ else
+ msg = strerror_r_failed;
+ msgsiz = strlen(msg);
+ if (strsiz + msgsiz < BUFSIZ)
+ strcat(str, msg);
+ free(buf);
+#else
+ if ((msg = strerror(err)) == 0)
+ msg = strerror_failed;
+ msgsiz = strlen(msg); /* Note msg = buf and free() above. */
+ if (strsiz + msgsiz < BUFSIZ) /* Do not move this after #endif. */
+ strcat(str, msg);
+#endif
+
+ return str;
+}
+
+char *strerrorcpy(char *str, int err) {
+ int msgsiz;
+ char *msg;
+
+#ifdef USE_THREADS
+ char *buf = malloc(BUFSIZ);
+
+ if (buf == 0)
+ return 0;
+ if (strerror_r(err, buf, sizeof(buf)) == 0)
+ msg = buf;
+ else
+ msg = strerror_r_failed;
+ msgsiz = strlen(msg);
+ if (msgsiz < BUFSIZ)
+ strcpy(str, msg);
+ free(buf);
+#else
+ if ((msg = strerror(err)) == 0)
+ msg = strerror_failed;
+ msgsiz = strlen(msg); /* Note msg = buf and free() above. */
+ if (msgsiz < BUFSIZ) /* Do not move this after #endif. */
+ strcpy(str, msg);
+#endif
+
+ return str;
+}
+
+/* ARGSUSED */
+void *dlopen(char *path, int mode)
+{
+ register ModulePtr mp;
+ static void *mainModule;
+
+ /*
+ * Upon the first call register a terminate handler that will
+ * close all libraries. Also get a reference to the main module
+ * for use with loadbind.
+ */
+ if (!mainModule) {
+ if ((mainModule = findMain()) == NULL)
+ return NULL;
+ atexit(terminate);
+ }
+ /*
+ * Scan the list of modules if have the module already loaded.
+ */
+ for (mp = modList; mp; mp = mp->next)
+ if (strcmp(mp->name, path) == 0) {
+ mp->refCnt++;
+ return mp;
+ }
+ Newz(1000,mp,1,Module);
+ if (mp == NULL) {
+ errvalid++;
+ strcpy(errbuf, "Newz: ");
+ strerrorcat(errbuf, errno);
+ return NULL;
+ }
+
+ if ((mp->name = savepv(path)) == NULL) {
+ errvalid++;
+ strcpy(errbuf, "savepv: ");
+ strerrorcat(errbuf, errno);
+ safefree(mp);
+ return NULL;
+ }
+ /*
+ * load should be declared load(const char *...). Thus we
+ * cast the path to a normal char *. Ugly.
+ */
+ if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) {
+ safefree(mp->name);
+ safefree(mp);
+ errvalid++;
+ strcpy(errbuf, "dlopen: ");
+ strcat(errbuf, path);
+ strcat(errbuf, ": ");
+ /*
+ * If AIX says the file is not executable, the error
+ * can be further described by querying the loader about
+ * the last error.
+ */
+ if (errno == ENOEXEC) {
+ char *tmp[BUFSIZ/sizeof(char *)];
+ if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1)
+ strerrorcpy(errbuf, errno);
+ else {
+ char **p;
+ for (p = tmp; *p; p++)
+ caterr(*p);
+ }
+ } else
+ strerrorcat(errbuf, errno);
+ return NULL;
+ }
+ mp->refCnt = 1;
+ mp->next = modList;
+ modList = mp;
+ if (loadbind(0, mainModule, mp->entry) == -1) {
+ dlclose(mp);
+ errvalid++;
+ strcpy(errbuf, "loadbind: ");
+ strerrorcat(errbuf, errno);
+ return NULL;
+ }
+ if (readExports(mp) == -1) {
+ dlclose(mp);
+ return NULL;
+ }
+ return mp;
+}
+
+/*
+ * Attempt to decipher an AIX loader error message and append it
+ * to our static error message buffer.
+ */
+static void caterr(char *s)
+{
+ register char *p = s;
+
+ while (*p >= '0' && *p <= '9')
+ p++;
+ switch(atoi(s)) {
+ case L_ERROR_TOOMANY:
+ strcat(errbuf, "to many errors");
+ break;
+ case L_ERROR_NOLIB:
+ strcat(errbuf, "can't load library");
+ strcat(errbuf, p);
+ break;
+ case L_ERROR_UNDEF:
+ strcat(errbuf, "can't find symbol");
+ strcat(errbuf, p);
+ break;
+ case L_ERROR_RLDBAD:
+ strcat(errbuf, "bad RLD");
+ strcat(errbuf, p);
+ break;
+ case L_ERROR_FORMAT:
+ strcat(errbuf, "bad exec format in");
+ strcat(errbuf, p);
+ break;
+ case L_ERROR_ERRNO:
+ strerrorcat(errbuf, atoi(++p));
+ break;
+ default:
+ strcat(errbuf, s);
+ break;
+ }
+}
+
+void *dlsym(void *handle, const char *symbol)
+{
+ register ModulePtr mp = (ModulePtr)handle;
+ register ExportPtr ep;
+ register int i;
+
+ /*
+ * Could speed up search, but I assume that one assigns
+ * the result to function pointers anyways.
+ */
+ for (ep = mp->exports, i = mp->nExports; i; i--, ep++)
+ if (strcmp(ep->name, symbol) == 0)
+ return ep->addr;
+ errvalid++;
+ strcpy(errbuf, "dlsym: undefined symbol ");
+ strcat(errbuf, symbol);
+ return NULL;
+}
+
+char *dlerror(void)
+{
+ if (errvalid) {
+ errvalid = 0;
+ return errbuf;
+ }
+ return NULL;
+}
+
+int dlclose(void *handle)
+{
+ register ModulePtr mp = (ModulePtr)handle;
+ int result;
+ register ModulePtr mp1;
+
+ if (--mp->refCnt > 0)
+ return 0;
+ result = unload(mp->entry);
+ if (result == -1) {
+ errvalid++;
+ strerrorcpy(errbuf, errno);
+ }
+ if (mp->exports) {
+ register ExportPtr ep;
+ register int i;
+ for (ep = mp->exports, i = mp->nExports; i; i--, ep++)
+ if (ep->name)
+ safefree(ep->name);
+ safefree(mp->exports);
+ }
+ if (mp == modList)
+ modList = mp->next;
+ else {
+ for (mp1 = modList; mp1; mp1 = mp1->next)
+ if (mp1->next == mp) {
+ mp1->next = mp->next;
+ break;
+ }
+ }
+ safefree(mp->name);
+ safefree(mp);
+ return result;
+}
+
+static void terminate(void)
+{
+ while (modList)
+ dlclose(modList);
+}
+
+/* Added by Wayne Scott
+ * This is needed because the ldopen system call calls
+ * calloc to allocated a block of date. The ldclose call calls free.
+ * Without this we get this system calloc and perl's free, resulting
+ * in a "Bad free" message. This way we always use perl's malloc.
+ */
+void *calloc(size_t ne, size_t sz)
+{
+ void *out;
+
+ out = (void *) safemalloc(ne*sz);
+ memzero(out, ne*sz);
+ return(out);
+}
+
+/*
+ * Build the export table from the XCOFF .loader section.
+ */
+static int readExports(ModulePtr mp)
+{
+ LDFILE *ldp = NULL;
+ SCNHDR sh;
+ LDHDR *lhp;
+ char *ldbuf;
+ LDSYM *ls;
+ int i;
+ ExportPtr ep;
+
+ if ((ldp = ldopen(mp->name, ldp)) == NULL) {
+ struct ld_info *lp;
+ char *buf;
+ int size = 4*1024;
+ if (errno != ENOENT) {
+ errvalid++;
+ strcpy(errbuf, "readExports: ");
+ strerrorcat(errbuf, errno);
+ return -1;
+ }
+ /*
+ * The module might be loaded due to the LIBPATH
+ * environment variable. Search for the loaded
+ * module using L_GETINFO.
+ */
+ if ((buf = safemalloc(size)) == NULL) {
+ errvalid++;
+ strcpy(errbuf, "readExports: ");
+ strerrorcat(errbuf, errno);
+ return -1;
+ }
+ while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) {
+ safefree(buf);
+ size += 4*1024;
+ if ((buf = safemalloc(size)) == NULL) {
+ errvalid++;
+ strcpy(errbuf, "readExports: ");
+ strerrorcat(errbuf, errno);
+ return -1;
+ }
+ }
+ if (i == -1) {
+ errvalid++;
+ strcpy(errbuf, "readExports: ");
+ strerrorcat(errbuf, errno);
+ safefree(buf);
+ return -1;
+ }
+ /*
+ * Traverse the list of loaded modules. The entry point
+ * returned by load() does actually point to the data
+ * segment origin.
+ */
+ lp = (struct ld_info *)buf;
+ while (lp) {
+ if (lp->ldinfo_dataorg == mp->entry) {
+ ldp = ldopen(lp->ldinfo_filename, ldp);
+ break;
+ }
+ if (lp->ldinfo_next == 0)
+ lp = NULL;
+ else
+ lp = (struct ld_info *)((char *)lp + lp->ldinfo_next);
+ }
+ safefree(buf);
+ if (!ldp) {
+ errvalid++;
+ strcpy(errbuf, "readExports: ");
+ strerrorcat(errbuf, errno);
+ return -1;
+ }
+ }
+ if (TYPE(ldp) != U802TOCMAGIC) {
+ errvalid++;
+ strcpy(errbuf, "readExports: bad magic");
+ while(ldclose(ldp) == FAILURE)
+ ;
+ return -1;
+ }
+ if (ldnshread(ldp, _LOADER, &sh) != SUCCESS) {
+ errvalid++;
+ strcpy(errbuf, "readExports: cannot read loader section header");
+ while(ldclose(ldp) == FAILURE)
+ ;
+ return -1;
+ }
+ /*
+ * We read the complete loader section in one chunk, this makes
+ * finding long symbol names residing in the string table easier.
+ */
+ if ((ldbuf = (char *)safemalloc(sh.s_size)) == NULL) {
+ errvalid++;
+ strcpy(errbuf, "readExports: ");
+ strerrorcat(errbuf, errno);
+ while(ldclose(ldp) == FAILURE)
+ ;
+ return -1;
+ }
+ if (FSEEK(ldp, sh.s_scnptr, BEGINNING) != OKFSEEK) {
+ errvalid++;
+ strcpy(errbuf, "readExports: cannot seek to loader section");
+ safefree(ldbuf);
+ while(ldclose(ldp) == FAILURE)
+ ;
+ return -1;
+ }
+/* This first case is a hack, since it assumes that the 3rd parameter to
+ FREAD is 1. See the redefinition of FREAD above to see how this works. */
+#ifdef USE_PERLIO
+ if (FREAD(ldbuf, sh.s_size, 1, ldp) != sh.s_size) {
+#else
+ if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) {
+#endif
+ errvalid++;
+ strcpy(errbuf, "readExports: cannot read loader section");
+ safefree(ldbuf);
+ while(ldclose(ldp) == FAILURE)
+ ;
+ return -1;
+ }
+ lhp = (LDHDR *)ldbuf;
+ ls = (LDSYM *)(ldbuf+LDHDRSZ);
+ /*
+ * Count the number of exports to include in our export table.
+ */
+ for (i = lhp->l_nsyms; i; i--, ls++) {
+ if (!LDR_EXPORT(*ls))
+ continue;
+ mp->nExports++;
+ }
+ Newz(1001, mp->exports, mp->nExports, Export);
+ if (mp->exports == NULL) {
+ errvalid++;
+ strcpy(errbuf, "readExports: ");
+ strerrorcat(errbuf, errno);
+ safefree(ldbuf);
+ while(ldclose(ldp) == FAILURE)
+ ;
+ return -1;
+ }
+ /*
+ * Fill in the export table. All entries are relative to
+ * the entry point we got from load.
+ */
+ ep = mp->exports;
+ ls = (LDSYM *)(ldbuf+LDHDRSZ);
+ for (i = lhp->l_nsyms; i; i--, ls++) {
+ char *symname;
+ if (!LDR_EXPORT(*ls))
+ continue;
+ if (ls->l_zeroes == 0)
+ symname = ls->l_offset+lhp->l_stoff+ldbuf;
+ else
+ symname = ls->l_name;
+ ep->name = savepv(symname);
+ ep->addr = (void *)((unsigned long)mp->entry + ls->l_value);
+ ep++;
+ }
+ safefree(ldbuf);
+ while(ldclose(ldp) == FAILURE)
+ ;
+ return 0;
+}
+
+/*
+ * Find the main modules entry point. This is used as export pointer
+ * for loadbind() to be able to resolve references to the main part.
+ */
+static void * findMain(void)
+{
+ struct ld_info *lp;
+ char *buf;
+ int size = 4*1024;
+ int i;
+ void *ret;
+
+ if ((buf = safemalloc(size)) == NULL) {
+ errvalid++;
+ strcpy(errbuf, "findMain: ");
+ strerrorcat(errbuf, errno);
+ return NULL;
+ }
+ while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) {
+ safefree(buf);
+ size += 4*1024;
+ if ((buf = safemalloc(size)) == NULL) {
+ errvalid++;
+ strcpy(errbuf, "findMain: ");
+ strerrorcat(errbuf, errno);
+ return NULL;
+ }
+ }
+ if (i == -1) {
+ errvalid++;
+ strcpy(errbuf, "findMain: ");
+ strerrorcat(errbuf, errno);
+ safefree(buf);
+ return NULL;
+ }
+ /*
+ * The first entry is the main module. The entry point
+ * returned by load() does actually point to the data
+ * segment origin.
+ */
+ lp = (struct ld_info *)buf;
+ ret = lp->ldinfo_dataorg;
+ safefree(buf);
+ return ret;
+}
+
+/* dl_dlopen.xs
+ *
+ * Platform: SunOS/Solaris, possibly others which use dlopen.
+ * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk)
+ * Created: 10th July 1994
+ *
+ * Modified:
+ * 15th July 1994 - Added code to explicitly save any error messages.
+ * 3rd August 1994 - Upgraded to v3 spec.
+ * 9th August 1994 - Changed to use IV
+ * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging,
+ * basic FreeBSD support, removed ClearError
+ *
+ */
+
+/* Porting notes:
+
+ see dl_dlopen.xs
+
+*/
+
+#include "dlutils.c" /* SaveError() etc */
+
+
+static void
+dl_private_init()
+{
+ (void)dl_generic_private_init();
+}
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+BOOT:
+ (void)dl_private_init();
+
+
+void *
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
+ CODE:
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags));
+ if (flags & 0x01)
+ warn("Can't make loaded symbols global on this platform while loading %s",filename);
+ RETVAL = dlopen(filename, 1) ;
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL)
+ SaveError("%s",dlerror()) ;
+ else
+ sv_setiv( ST(0), (IV)RETVAL);
+
+
+void *
+dl_find_symbol(libhandle, symbolname)
+ void * libhandle
+ char * symbolname
+ CODE:
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n",
+ libhandle, symbolname));
+ RETVAL = dlsym(libhandle, symbolname);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL)
+ SaveError("%s",dlerror()) ;
+ else
+ sv_setiv( ST(0), (IV)RETVAL);
+
+
+void
+dl_undef_symbols()
+ PPCODE:
+
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ char * filename
+ CODE:
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
+ perl_name, symref));
+ ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
+
+
+char *
+dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs
new file mode 100644
index 000000000000..2b7563764e1e
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dl_cygwin32.xs
@@ -0,0 +1,153 @@
+/* dl_cygwin32.xs
+ *
+ * Platform: Win32 (Windows NT/Windows 95)
+ * Author: Wei-Yuen Tan (wyt@hip.com)
+ * Created: A warm day in June, 1995
+ *
+ * Modified:
+ * August 23rd 1995 - rewritten after losing everything when I
+ * wiped off my NT partition (eek!)
+ */
+/* Modified from the original dl_win32.xs to work with cygwin32
+ -John Cerney 3/26/97
+*/
+/* Porting notes:
+
+I merely took Paul's dl_dlopen.xs, took out extraneous stuff and
+replaced the appropriate SunOS calls with the corresponding Win32
+calls.
+
+*/
+
+#define WIN32_LEAN_AND_MEAN
+// Defines from windows needed for this function only. Can't include full
+// Cygwin32 windows headers because of problems with CONTEXT redefinition
+// Removed logic to tell not dynamically load static modules. It is assumed that all
+// modules are dynamically built. This should be similar to the behavoir on sunOS.
+// Leaving in the logic would have required changes to the standard perlmain.c code
+//
+// // Includes call a dll function to initialize it's impure_ptr.
+#include <stdio.h>
+void (*impure_setupptr)(struct _reent *); // pointer to the impure_setup routine
+
+//#include <windows.h>
+#define LOAD_WITH_ALTERED_SEARCH_PATH (8)
+typedef void *HANDLE;
+typedef HANDLE HINSTANCE;
+#define STDCALL __attribute__ ((stdcall))
+typedef int STDCALL (*FARPROC)();
+
+HINSTANCE
+STDCALL
+LoadLibraryExA(
+ char* lpLibFileName,
+ HANDLE hFile,
+ unsigned int dwFlags
+ );
+unsigned int
+STDCALL
+GetLastError(
+ void
+ );
+FARPROC
+STDCALL
+GetProcAddress(
+ HINSTANCE hModule,
+ char* lpProcName
+ );
+
+#include <string.h>
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "dlutils.c" /* SaveError() etc */
+
+static void
+dl_private_init()
+{
+ (void)dl_generic_private_init();
+}
+
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+BOOT:
+ (void)dl_private_init();
+
+void *
+dl_load_file(filename,flags=0)
+ char * filename
+ int flags
+ PREINIT:
+ CODE:
+ DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
+
+ RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ;
+
+ DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL){
+ SaveError("%d",GetLastError()) ;
+ }
+ else{
+ // setup the dll's impure_ptr:
+ impure_setupptr = GetProcAddress(RETVAL, "impure_setup");
+ if( impure_setupptr == NULL){
+ printf(
+ "Cygwin32 dynaloader error: could not load impure_setup symbol\n");
+ RETVAL = NULL;
+ }
+ else{
+ // setup the DLLs impure_ptr:
+ (*impure_setupptr)(_impure_ptr);
+ sv_setiv( ST(0), (IV)RETVAL);
+ }
+ }
+
+
+
+void *
+dl_find_symbol(libhandle, symbolname)
+ void * libhandle
+ char * symbolname
+ CODE:
+ DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
+ libhandle, symbolname));
+ RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
+ DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL)
+ SaveError("%d",GetLastError()) ;
+ else
+ sv_setiv( ST(0), (IV)RETVAL);
+
+
+void
+dl_undef_symbols()
+ PPCODE:
+
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ char * filename
+ CODE:
+ DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
+ perl_name, symref));
+ ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
+
+
+char *
+dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/contrib/perl5/ext/DynaLoader/dl_dld.xs b/contrib/perl5/ext/DynaLoader/dl_dld.xs
new file mode 100644
index 000000000000..2443ab0d6946
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dl_dld.xs
@@ -0,0 +1,175 @@
+/*
+ * Written 3/1/94, Robert Sanders <Robert.Sanders@linux.org>
+ *
+ * based upon the file "dl.c", which is
+ * Copyright (c) 1994, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Date: 1994/03/07 00:21:43 $
+ * $Source: /home/rsanders/src/perl5alpha6/RCS/dld_dl.c,v $
+ * $Revision: 1.4 $
+ * $State: Exp $
+ *
+ * $Log: dld_dl.c,v $
+ * Removed implicit link against libc. 1994/09/14 William Setzer.
+ *
+ * Integrated other DynaLoader changes. 1994/06/08 Tim Bunce.
+ *
+ * rewrote dl_load_file, misc updates. 1994/09/03 William Setzer.
+ *
+ * Revision 1.4 1994/03/07 00:21:43 rsanders
+ * added min symbol count for load_libs and switched order so system libs
+ * are loaded after app-specified libs.
+ *
+ * Revision 1.3 1994/03/05 01:17:26 rsanders
+ * added path searching.
+ *
+ * Revision 1.2 1994/03/05 00:52:39 rsanders
+ * added package-specified libraries.
+ *
+ * Revision 1.1 1994/03/05 00:33:40 rsanders
+ * Initial revision
+ *
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <dld.h> /* GNU DLD header file */
+#include <unistd.h>
+
+#include "dlutils.c" /* for SaveError() etc */
+
+static AV *dl_resolve_using = Nullav;
+static AV *dl_require_symbols = Nullav;
+
+static void
+dl_private_init()
+{
+ int dlderr;
+ dl_generic_private_init();
+ dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4);
+ dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4);
+#ifdef __linux__
+ dlderr = dld_init("/proc/self/exe");
+ if (dlderr) {
+#endif
+ dlderr = dld_init(dld_find_executable(PL_origargv[0]));
+ if (dlderr) {
+ char *msg = dld_strerror(dlderr);
+ SaveError("dld_init(%s) failed: %s", PL_origargv[0], msg);
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "%s", LastError));
+ }
+#ifdef __linux__
+ }
+#endif
+}
+
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+BOOT:
+ (void)dl_private_init();
+
+
+char *
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
+ PREINIT:
+ int dlderr,x,max;
+ GV *gv;
+ CODE:
+ RETVAL = filename;
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags));
+ if (flags & 0x01)
+ croak("Can't make loaded symbols global on this platform while loading %s",filename);
+ max = AvFILL(dl_require_symbols);
+ for (x = 0; x <= max; x++) {
+ char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_create_ref(%s)\n", sym));
+ if (dlderr = dld_create_reference(sym)) {
+ SaveError("dld_create_reference(%s): %s", sym,
+ dld_strerror(dlderr));
+ goto haverror;
+ }
+ }
+
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", filename));
+ if (dlderr = dld_link(filename)) {
+ SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr));
+ goto haverror;
+ }
+
+ max = AvFILL(dl_resolve_using);
+ for (x = 0; x <= max; x++) {
+ char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", sym));
+ if (dlderr = dld_link(sym)) {
+ SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr));
+ goto haverror;
+ }
+ }
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "libref=%s\n", RETVAL));
+haverror:
+ ST(0) = sv_newmortal() ;
+ if (dlderr == 0)
+ sv_setiv(ST(0), (IV)RETVAL);
+
+
+void *
+dl_find_symbol(libhandle, symbolname)
+ void * libhandle
+ char * symbolname
+ CODE:
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n",
+ libhandle, symbolname));
+ RETVAL = (void *)dld_get_func(symbolname);
+ /* if RETVAL==NULL we should try looking for a non-function symbol */
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL)
+ SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ;
+ else
+ sv_setiv(ST(0), (IV)RETVAL);
+
+
+void
+dl_undef_symbols()
+ PPCODE:
+ if (dld_undefined_sym_count) {
+ int x;
+ char **undef_syms = dld_list_undefined_sym();
+ EXTEND(SP, dld_undefined_sym_count);
+ for (x=0; x < dld_undefined_sym_count; x++)
+ PUSHs(sv_2mortal(newSVpv(undef_syms[x]+1, 0)));
+ free(undef_syms);
+ }
+
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ char * filename
+ CODE:
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
+ perl_name, symref));
+ ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
+
+
+char *
+dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/contrib/perl5/ext/DynaLoader/dl_dlopen.xs b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs
new file mode 100644
index 000000000000..245920565312
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dl_dlopen.xs
@@ -0,0 +1,219 @@
+/* dl_dlopen.xs
+ *
+ * Platform: SunOS/Solaris, possibly others which use dlopen.
+ * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk)
+ * Created: 10th July 1994
+ *
+ * Modified:
+ * 15th July 1994 - Added code to explicitly save any error messages.
+ * 3rd August 1994 - Upgraded to v3 spec.
+ * 9th August 1994 - Changed to use IV
+ * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging,
+ * basic FreeBSD support, removed ClearError
+ *
+ */
+
+/* Porting notes:
+
+
+ Definition of Sunos dynamic Linking functions
+ =============================================
+ In order to make this implementation easier to understand here is a
+ quick definition of the SunOS Dynamic Linking functions which are
+ used here.
+
+ dlopen
+ ------
+ void *
+ dlopen(path, mode)
+ char * path;
+ int mode;
+
+ This function takes the name of a dynamic object file and returns
+ a descriptor which can be used by dlsym later. It returns NULL on
+ error.
+
+ The mode parameter must be set to 1 for Solaris 1 and to
+ RTLD_LAZY (==2) on Solaris 2.
+
+
+ dlsym
+ ------
+ void *
+ dlsym(handle, symbol)
+ void * handle;
+ char * symbol;
+
+ Takes the handle returned from dlopen and the name of a symbol to
+ get the address of. If the symbol was found a pointer is
+ returned. It returns NULL on error. If DL_PREPEND_UNDERSCORE is
+ defined an underscore will be added to the start of symbol. This
+ is required on some platforms (freebsd).
+
+ dlerror
+ ------
+ char * dlerror()
+
+ Returns a null-terminated string which describes the last error
+ that occurred with either dlopen or dlsym. After each call to
+ dlerror the error message will be reset to a null pointer. The
+ SaveError function is used to save the error as soo as it happens.
+
+
+ Return Types
+ ============
+ In this implementation the two functions, dl_load_file &
+ dl_find_symbol, return void *. This is because the underlying SunOS
+ dynamic linker calls also return void *. This is not necessarily
+ the case for all architectures. For example, some implementation
+ will want to return a char * for dl_load_file.
+
+ If void * is not appropriate for your architecture, you will have to
+ change the void * to whatever you require. If you are not certain of
+ how Perl handles C data types, I suggest you start by consulting
+ Dean Roerich's Perl 5 API document. Also, have a look in the typemap
+ file (in the ext directory) for a fairly comprehensive list of types
+ that are already supported. If you are completely stuck, I suggest you
+ post a message to perl5-porters, comp.lang.perl.misc or if you are really
+ desperate to me.
+
+ Remember when you are making any changes that the return value from
+ dl_load_file is used as a parameter in the dl_find_symbol
+ function. Also the return value from find_symbol is used as a parameter
+ to install_xsub.
+
+
+ Dealing with Error Messages
+ ============================
+ In order to make the handling of dynamic linking errors as generic as
+ possible you should store any error messages associated with your
+ implementation with the StoreError function.
+
+ In the case of SunOS the function dlerror returns the error message
+ associated with the last dynamic link error. As the SunOS dynamic
+ linker functions dlopen & dlsym both return NULL on error every call
+ to a SunOS dynamic link routine is coded like this
+
+ RETVAL = dlopen(filename, 1) ;
+ if (RETVAL == NULL)
+ SaveError("%s",dlerror()) ;
+
+ Note that SaveError() takes a printf format string. Use a "%s" as
+ the first parameter if the error may contain and % characters.
+
+*/
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef I_DLFCN
+#include <dlfcn.h> /* the dynamic linker include file for Sunos/Solaris */
+#else
+#include <nlist.h>
+#include <link.h>
+#endif
+
+#ifndef RTLD_LAZY
+# define RTLD_LAZY 1 /* Solaris 1 */
+#endif
+
+#ifndef HAS_DLERROR
+# ifdef __NetBSD__
+# define dlerror() strerror(errno)
+# else
+# define dlerror() "Unknown error - dlerror() not implemented"
+# endif
+#endif
+
+
+#include "dlutils.c" /* SaveError() etc */
+
+
+static void
+dl_private_init()
+{
+ (void)dl_generic_private_init();
+}
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+BOOT:
+ (void)dl_private_init();
+
+
+void *
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
+ PREINIT:
+ int mode = RTLD_LAZY;
+ CODE:
+#ifdef RTLD_NOW
+ if (dl_nonlazy)
+ mode = RTLD_NOW;
+#endif
+ if (flags & 0x01)
+#ifdef RTLD_GLOBAL
+ mode |= RTLD_GLOBAL;
+#else
+ warn("Can't make loaded symbols global on this platform while loading %s",filename);
+#endif
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags));
+ RETVAL = dlopen(filename, mode) ;
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL)
+ SaveError("%s",dlerror()) ;
+ else
+ sv_setiv( ST(0), (IV)RETVAL);
+
+
+void *
+dl_find_symbol(libhandle, symbolname)
+ void * libhandle
+ char * symbolname
+ CODE:
+#ifdef DLSYM_NEEDS_UNDERSCORE
+ symbolname = form("_%s", symbolname);
+#endif
+ DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+ "dl_find_symbol(handle=%lx, symbol=%s)\n",
+ (unsigned long) libhandle, symbolname));
+ RETVAL = dlsym(libhandle, symbolname);
+ DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+ " symbolref = %lx\n", (unsigned long) RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL)
+ SaveError("%s",dlerror()) ;
+ else
+ sv_setiv( ST(0), (IV)RETVAL);
+
+
+void
+dl_undef_symbols()
+ PPCODE:
+
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ char * filename
+ CODE:
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n",
+ perl_name, (unsigned long) symref));
+ ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((CV *)))symref, filename)));
+
+
+char *
+dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/contrib/perl5/ext/DynaLoader/dl_hpux.xs b/contrib/perl5/ext/DynaLoader/dl_hpux.xs
new file mode 100644
index 000000000000..a82e0eac1112
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dl_hpux.xs
@@ -0,0 +1,157 @@
+/*
+ * Author: Jeff Okamoto (okamoto@corp.hp.com)
+ * Version: 2.1, 1995/1/25
+ */
+
+/* o Added BIND_VERBOSE to dl_nonlazy condition to add names of missing
+ * symbols to stderr message on fatal error.
+ *
+ * o Added BIND_NONFATAL comment to default condition.
+ *
+ * Chuck Phillips (cdp@fc.hp.com)
+ * Version: 2.2, 1997/5/4 */
+
+#ifdef __hp9000s300
+#define magic hpux_magic
+#define MAGIC HPUX_MAGIC
+#endif
+
+#include <dl.h>
+#ifdef __hp9000s300
+#undef magic
+#undef MAGIC
+#endif
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+
+#include "dlutils.c" /* for SaveError() etc */
+
+static AV *dl_resolve_using = Nullav;
+
+
+static void
+dl_private_init()
+{
+ (void)dl_generic_private_init();
+ dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4);
+}
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+BOOT:
+ (void)dl_private_init();
+
+
+void *
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
+ PREINIT:
+ shl_t obj = NULL;
+ int i, max, bind_type;
+ CODE:
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags));
+ if (flags & 0x01)
+ warn("Can't make loaded symbols global on this platform while loading %s",filename);
+ if (dl_nonlazy) {
+ bind_type = BIND_IMMEDIATE|BIND_VERBOSE;
+ } else {
+ bind_type = BIND_DEFERRED;
+ /* For certain libraries, like DCE, deferred binding often causes run
+ * time problems. Adding BIND_NONFATAL to BIND_IMMEDIATE still allows
+ * unresolved references in situations like this. */
+ /* bind_type = BIND_IMMEDIATE|BIND_NONFATAL; */
+ }
+ /* BIND_NOSTART removed from bind_type because it causes the shared library's */
+ /* initialisers not to be run. This causes problems with all of the static objects */
+ /* in the library. */
+#ifdef DEBUGGING
+ if (dl_debug)
+ bind_type |= BIND_VERBOSE;
+#endif /* DEBUGGING */
+
+ max = AvFILL(dl_resolve_using);
+ for (i = 0; i <= max; i++) {
+ char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym));
+ obj = shl_load(sym, bind_type, 0L);
+ if (obj == NULL) {
+ goto end;
+ }
+ }
+
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename));
+ obj = shl_load(filename, bind_type, 0L);
+
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj));
+end:
+ ST(0) = sv_newmortal() ;
+ if (obj == NULL)
+ SaveError("%s",Strerror(errno));
+ else
+ sv_setiv( ST(0), (IV)obj);
+
+
+void *
+dl_find_symbol(libhandle, symbolname)
+ void * libhandle
+ char * symbolname
+ CODE:
+ shl_t obj = (shl_t) libhandle;
+ void *symaddr = NULL;
+ int status;
+#ifdef __hp9000s300
+ symbolname = form("_%s", symbolname);
+#endif
+ DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+ "dl_find_symbol(handle=%lx, symbol=%s)\n",
+ (unsigned long) libhandle, symbolname));
+
+ ST(0) = sv_newmortal() ;
+ errno = 0;
+
+ status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(PROCEDURE) = %x\n", symaddr));
+
+ if (status == -1 && errno == 0) { /* try TYPE_DATA instead */
+ status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(DATA) = %x\n", symaddr));
+ }
+
+ if (status == -1) {
+ SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ;
+ } else {
+ sv_setiv( ST(0), (IV)symaddr);
+ }
+
+
+void
+dl_undef_symbols()
+ PPCODE:
+
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ char * filename
+ CODE:
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
+ perl_name, symref));
+ ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
+
+
+char *
+dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/contrib/perl5/ext/DynaLoader/dl_mpeix.xs b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs
new file mode 100644
index 000000000000..808c3b0f190e
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dl_mpeix.xs
@@ -0,0 +1,128 @@
+/*
+ * Author: Mark Klein (mklein@dis.com)
+ * Version: 2.1, 1996/07/25
+ * Version: 2.2, 1997/09/25 Mark Bixby (markb@cccd.edu)
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef __GNUC__
+extern void HPGETPROCPLABEL( int parms,
+ char * procname,
+ int * plabel,
+ int * status,
+ char * firstfile,
+ int casesensitive,
+ int symboltype,
+ int * datasize,
+ int position,
+ int searchpath,
+ int binding);
+#else
+#pragma intrinsic HPGETPROCPLABEL
+#endif
+#include "dlutils.c" /* for SaveError() etc */
+
+typedef struct {
+ char filename[PATH_MAX + 3];
+ } t_mpe_dld, *p_mpe_dld;
+
+static AV *dl_resolve_using = Nullav;
+
+static void
+dl_private_init()
+{
+ (void)dl_generic_private_init();
+ dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4);
+}
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+BOOT:
+ (void)dl_private_init();
+
+void *
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
+ PREINIT:
+ char buf[PATH_MAX + 3];
+ p_mpe_dld obj = NULL;
+ int i;
+ CODE:
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,
+flags));
+ if (flags & 0x01)
+ warn("Can't make loaded symbols global on this platform while loading %s
+",filename);
+ obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld));
+ memzero(obj, sizeof(t_mpe_dld));
+ if (filename[0] == '.')
+ {
+ getcwd(buf,sizeof(buf));
+ sprintf(obj->filename,"$%s/%s$",buf,filename);
+ }
+ else
+ sprintf(obj->filename,"$%s$",filename);
+
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," libref=%x\n", obj));
+
+ ST(0) = sv_newmortal() ;
+ if (obj == NULL)
+ SaveError("%s",Strerror(errno));
+ else
+ sv_setiv( ST(0), (IV)obj);
+
+void *
+dl_find_symbol(libhandle, symbolname)
+ void * libhandle
+ char * symbolname
+ CODE:
+ int datalen;
+ p_mpe_dld obj = (p_mpe_dld) libhandle;
+ char symname[PATH_MAX + 3];
+ void * symaddr = NULL;
+ int status;
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n",
+ libhandle, symbolname));
+ ST(0) = sv_newmortal() ;
+ errno = 0;
+
+ sprintf(symname, "$%s$", symbolname);
+ HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1,
+ 0, &datalen, 1, 0, 0);
+
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr()," symbolref(PROCEDURE) = %x\n", symaddr));
+
+ if (status != 0) {
+ SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ;
+ } else {
+ sv_setiv( ST(0), (IV)symaddr);
+ }
+
+void
+dl_undef_symbols()
+ PPCODE:
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ char * filename
+ CODE:
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(),"dl_install_xsub(name=%s, symref=%x)\n",
+ perl_name, symref));
+ ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
+
+char *
+dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/contrib/perl5/ext/DynaLoader/dl_next.xs b/contrib/perl5/ext/DynaLoader/dl_next.xs
new file mode 100644
index 000000000000..2b547f0f0019
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dl_next.xs
@@ -0,0 +1,303 @@
+/* dl_next.xs
+ *
+ * Platform: NeXT NS 3.2
+ * Author: Anno Siegel (siegel@zrz.TU-Berlin.DE)
+ * Based on: dl_dlopen.xs by Paul Marquess
+ * Created: Aug 15th, 1994
+ *
+ */
+
+/*
+ And Gandalf said: 'Many folk like to know beforehand what is to
+ be set on the table; but those who have laboured to prepare the
+ feast like to keep their secret; for wonder makes the words of
+ praise louder.'
+*/
+
+/* Porting notes:
+
+dl_next.xs is itself a port from dl_dlopen.xs by Paul Marquess. It
+should not be used as a base for further ports though it may be used
+as an example for how dl_dlopen.xs can be ported to other platforms.
+
+The method used here is just to supply the sun style dlopen etc.
+functions in terms of NeXTs rld_*. The xs code proper is unchanged
+from Paul's original.
+
+The port could use some streamlining. For one, error handling could
+be simplified.
+
+Anno Siegel
+
+*/
+
+#if NS_TARGET_MAJOR >= 4
+#else
+/* include these before perl headers */
+#include <mach-o/rld.h>
+#include <streams/streams.h>
+#endif
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define DL_LOADONCEONLY
+
+#include "dlutils.c" /* SaveError() etc */
+
+
+static char * dl_last_error = (char *) 0;
+static AV *dl_resolve_using = Nullav;
+
+static char *dlerror()
+{
+ return dl_last_error;
+}
+
+int dlclose(handle) /* stub only */
+void *handle;
+{
+ return 0;
+}
+
+#if NS_TARGET_MAJOR >= 4
+#import <mach-o/dyld.h>
+
+enum dyldErrorSource
+{
+ OFImage,
+};
+
+static void TranslateError
+ (const char *path, enum dyldErrorSource type, int number)
+{
+ char *error;
+ unsigned int index;
+ static char *OFIErrorStrings[] =
+ {
+ "%s(%d): Object Image Load Failure\n",
+ "%s(%d): Object Image Load Success\n",
+ "%s(%d): Not an recognisable object file\n",
+ "%s(%d): No valid architecture\n",
+ "%s(%d): Object image has an invalid format\n",
+ "%s(%d): Invalid access (permissions?)\n",
+ "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
+ };
+#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
+
+ switch (type)
+ {
+ case OFImage:
+ index = number;
+ if (index > NUM_OFI_ERRORS - 1)
+ index = NUM_OFI_ERRORS - 1;
+ error = form(OFIErrorStrings[index], path, number);
+ break;
+
+ default:
+ error = form("%s(%d): Totally unknown error type %d\n",
+ path, number, type);
+ break;
+ }
+ Safefree(dl_last_error);
+ dl_last_error = savepv(error);
+}
+
+static char *dlopen(char *path, int mode /* mode is ignored */)
+{
+ int dyld_result;
+ NSObjectFileImage ofile;
+ NSModule handle = NULL;
+
+ dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
+ if (dyld_result != NSObjectFileImageSuccess)
+ TranslateError(path, OFImage, dyld_result);
+ else
+ {
+ // NSLinkModule will cause the run to abort on any link error's
+ // not very friendly but the error recovery functionality is limited.
+ handle = NSLinkModule(ofile, path, TRUE);
+ }
+
+ return handle;
+}
+
+void *
+dlsym(handle, symbol)
+void *handle;
+char *symbol;
+{
+ void *addr;
+
+ if (NSIsSymbolNameDefined(symbol))
+ addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
+ else
+ addr = NULL;
+
+ return addr;
+}
+
+#else /* NS_TARGET_MAJOR <= 3 */
+
+static NXStream *OpenError(void)
+{
+ return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
+}
+
+static void TransferError(NXStream *s)
+{
+ char *buffer;
+ int len, maxlen;
+
+ if ( dl_last_error ) {
+ Safefree(dl_last_error);
+ }
+ NXGetMemoryBuffer(s, &buffer, &len, &maxlen);
+ New(1097, dl_last_error, len, char);
+ strcpy(dl_last_error, buffer);
+}
+
+static void CloseError(NXStream *s)
+{
+ if ( s ) {
+ NXCloseMemory( s, NX_FREEBUFFER);
+ }
+}
+
+static char *dlopen(char *path, int mode /* mode is ignored */)
+{
+ int rld_success;
+ NXStream *nxerr;
+ I32 i, psize;
+ char *result;
+ char **p;
+
+ /* Do not load what is already loaded into this process */
+ if (hv_fetch(dl_loaded_files, path, strlen(path), 0))
+ return path;
+
+ nxerr = OpenError();
+ psize = AvFILL(dl_resolve_using) + 3;
+ 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[psize-1] = 0;
+ rld_success = rld_load(nxerr, (struct mach_header **)0, p,
+ (const char *) 0);
+ safefree((char*) p);
+ if (rld_success) {
+ result = path;
+ /* prevent multiple loads of same file into same process */
+ hv_store(dl_loaded_files, path, strlen(path), &PL_sv_yes, 0);
+ } else {
+ TransferError(nxerr);
+ result = (char*) 0;
+ }
+ CloseError(nxerr);
+ return result;
+}
+
+void *
+dlsym(handle, symbol)
+void *handle;
+char *symbol;
+{
+ NXStream *nxerr = OpenError();
+ unsigned long symref = 0;
+
+ if (!rld_lookup(nxerr, form("_%s", symbol), &symref))
+ TransferError(nxerr);
+ CloseError(nxerr);
+ return (void*) symref;
+}
+
+#endif /* NS_TARGET_MAJOR >= 4 */
+
+
+/* ----- code from dl_dlopen.xs below here ----- */
+
+
+static void
+dl_private_init()
+{
+ (void)dl_generic_private_init();
+ dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4);
+}
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+BOOT:
+ (void)dl_private_init();
+
+
+
+void *
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
+ PREINIT:
+ int mode = 1;
+ CODE:
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags));
+ if (flags & 0x01)
+ warn("Can't make loaded symbols global on this platform while loading %s",filename);
+ RETVAL = dlopen(filename, mode) ;
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL)
+ SaveError("%s",dlerror()) ;
+ else
+ sv_setiv( ST(0), (IV)RETVAL);
+
+
+void *
+dl_find_symbol(libhandle, symbolname)
+ void * libhandle
+ char * symbolname
+ CODE:
+#if NS_TARGET_MAJOR >= 4
+ symbolname = form("_%s", symbolname);
+#endif
+ DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+ "dl_find_symbol(handle=%lx, symbol=%s)\n",
+ (unsigned long) libhandle, symbolname));
+ RETVAL = dlsym(libhandle, symbolname);
+ DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+ " symbolref = %lx\n", (unsigned long) RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL)
+ SaveError("%s",dlerror()) ;
+ else
+ sv_setiv( ST(0), (IV)RETVAL);
+
+
+void
+dl_undef_symbols()
+ PPCODE:
+
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ char * filename
+ CODE:
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
+ perl_name, symref));
+ ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
+
+
+char *
+dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/contrib/perl5/ext/DynaLoader/dl_none.xs b/contrib/perl5/ext/DynaLoader/dl_none.xs
new file mode 100644
index 000000000000..5a193e4346ed
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dl_none.xs
@@ -0,0 +1,19 @@
+/* dl_none.xs
+ *
+ * Stubs for platforms that do not support dynamic linking
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+char *
+dl_error()
+ CODE:
+ RETVAL = "Not implemented";
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/contrib/perl5/ext/DynaLoader/dl_vms.xs b/contrib/perl5/ext/DynaLoader/dl_vms.xs
new file mode 100644
index 000000000000..974fd58b5226
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dl_vms.xs
@@ -0,0 +1,356 @@
+/* dl_vms.xs
+ *
+ * Platform: OpenVMS, VAX or AXP
+ * Author: Charles Bailey bailey@genetics.upenn.edu
+ * Revised: 12-Dec-1994
+ *
+ * Implementation Note
+ * This section is added as an aid to users and DynaLoader developers, in
+ * order to clarify the process of dynamic linking under VMS.
+ * dl_vms.xs uses the supported VMS dynamic linking call, which allows
+ * a running program to map an arbitrary file of executable code and call
+ * routines within that file. This is done via the VMS RTL routine
+ * lib$find_image_symbol, whose calling sequence is as follows:
+ * status = lib$find_image_symbol(imgname,symname,symval,defspec);
+ * where
+ * status = a standard VMS status value (unsigned long int)
+ * imgname = a fixed-length string descriptor, passed by
+ * reference, containing the NAME ONLY of the image
+ * file to be mapped. An attempt will be made to
+ * translate this string as a logical name, so it may
+ * not contain any characters which are not allowed in
+ * logical names. If no translation is found, imgname
+ * is used directly as the name of the image file.
+ * symname = a fixed-length string descriptor, passed by
+ * reference, containing the name of the routine
+ * to be located.
+ * symval = an unsigned long int, passed by reference, into
+ * which is written the entry point address of the
+ * routine whose name is specified in symname.
+ * defspec = a fixed-length string descriptor, passed by
+ * reference, containing a default file specification
+ * whichis used to fill in any missing parts of the
+ * image file specification after the imgname argument
+ * is processed.
+ * In order to accommodate the handling of the imgname argument, the routine
+ * dl_expandspec() is provided for use by perl code (e.g. dl_findfile)
+ * which wants to see what image file lib$find_image_symbol would use if
+ * it were passed a given file specification. The file specification passed
+ * to dl_expandspec() and dl_load_file() can be partial or complete, and can
+ * use VMS or Unix syntax; these routines perform the necessary conversions.
+ * In general, writers of perl extensions need only conform to the
+ * procedures set out in the DynaLoader documentation, and let the details
+ * be taken care of by the routines here and in DynaLoader.pm. If anyone
+ * comes across any incompatibilities, please let me know. Thanks.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "dlutils.c" /* dl_debug, LastError; SaveError not used */
+
+static AV *dl_require_symbols = Nullav;
+
+/* N.B.:
+ * dl_debug and LastError are static vars; you'll need to deal
+ * with them appropriately if you need context independence
+ */
+
+#include <descrip.h>
+#include <fscndef.h>
+#include <lib$routines.h>
+#include <rms.h>
+#include <ssdef.h>
+#include <starlet.h>
+
+typedef unsigned long int vmssts;
+
+struct libref {
+ struct dsc$descriptor_s name;
+ struct dsc$descriptor_s defspec;
+};
+
+/* Static data for dl_expand_filespec() - This is static to save
+ * initialization on each call; if you need context-independence,
+ * just make these auto variables in dl_expandspec() and dl_load_file()
+ */
+static char dlesa[NAM$C_MAXRSS], dlrsa[NAM$C_MAXRSS];
+static struct FAB dlfab;
+static struct NAM dlnam;
+
+/* $PutMsg action routine - records error message in LastError */
+static vmssts
+copy_errmsg(msg,unused)
+ struct dsc$descriptor_s * msg;
+ vmssts unused;
+{
+ if (*(msg->dsc$a_pointer) == '%') { /* first line */
+ if (LastError)
+ strncpy((LastError = saferealloc(LastError,msg->dsc$w_length+1)),
+ msg->dsc$a_pointer, msg->dsc$w_length);
+ else
+ strncpy((LastError = safemalloc(msg->dsc$w_length+1)),
+ msg->dsc$a_pointer, msg->dsc$w_length);
+ LastError[msg->dsc$w_length] = '\0';
+ }
+ else { /* continuation line */
+ int errlen = strlen(LastError);
+ LastError = saferealloc(LastError, errlen + msg->dsc$w_length + 2);
+ LastError[errlen] = '\n'; LastError[errlen+1] = '\0';
+ strncat(LastError, msg->dsc$a_pointer, msg->dsc$w_length);
+ LastError[errlen+msg->dsc$w_length+1] = '\0';
+ }
+ return 0;
+}
+
+/* Use $PutMsg to retrieve error message for failure status code */
+static void
+dl_set_error(sts,stv)
+ vmssts sts;
+ vmssts stv;
+{
+ vmssts vec[3];
+
+ vec[0] = stv ? 2 : 1;
+ vec[1] = sts; vec[2] = stv;
+ _ckvmssts(sys$putmsg(vec,copy_errmsg,0,0));
+}
+
+static unsigned int
+findsym_handler(void *sig, void *mech)
+{
+ unsigned long int myvec[8],args, *usig = (unsigned long int *) sig;
+ /* Be paranoid and assume signal vector passed in might be readonly */
+ myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1;
+ while (--args) myvec[args] = usig[args];
+ _ckvmssts(sys$putmsg(myvec,copy_errmsg,0,0));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "findsym_handler: received\n\t%s\n",LastError));
+ return SS$_CONTINUE;
+}
+
+/* wrapper for lib$find_image_symbol, so signalled errors can be saved
+ * for dl_error and then returned */
+static unsigned long int
+my_find_image_symbol(struct dsc$descriptor_s *imgname,
+ struct dsc$descriptor_s *symname,
+ void (**entry)(),
+ struct dsc$descriptor_s *defspec)
+{
+ unsigned long int retsts;
+ VAXC$ESTABLISH(findsym_handler);
+ retsts = lib$find_image_symbol(imgname,symname,entry,defspec);
+ return retsts;
+}
+
+
+static void
+dl_private_init()
+{
+ dl_generic_private_init();
+ dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4);
+ /* Set up the static control blocks for dl_expand_filespec() */
+ dlfab = cc$rms_fab;
+ dlnam = cc$rms_nam;
+ dlfab.fab$l_nam = &dlnam;
+ dlnam.nam$l_esa = dlesa;
+ dlnam.nam$b_ess = sizeof dlesa;
+ dlnam.nam$l_rsa = dlrsa;
+ dlnam.nam$b_rss = sizeof dlrsa;
+}
+MODULE = DynaLoader PACKAGE = DynaLoader
+
+BOOT:
+ (void)dl_private_init();
+
+void
+dl_expandspec(filespec)
+ char * filespec
+ CODE:
+ char vmsspec[NAM$C_MAXRSS], defspec[NAM$C_MAXRSS];
+ size_t deflen;
+ vmssts sts;
+
+ tovmsspec(filespec,vmsspec);
+ dlfab.fab$l_fna = vmsspec;
+ dlfab.fab$b_fns = strlen(vmsspec);
+ dlfab.fab$l_dna = 0;
+ dlfab.fab$b_dns = 0;
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_expand_filespec(%s):\n",vmsspec));
+ /* On the first pass, just parse the specification string */
+ dlnam.nam$b_nop = NAM$M_SYNCHK;
+ sts = sys$parse(&dlfab);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tSYNCHK sys$parse = %d\n",sts));
+ if (!(sts & 1)) {
+ dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
+ ST(0) = &PL_sv_undef;
+ }
+ else {
+ /* Now set up a default spec - everything but the name */
+ deflen = dlnam.nam$l_name - dlesa;
+ memcpy(defspec,dlesa,deflen);
+ memcpy(defspec+deflen,dlnam.nam$l_type,
+ dlnam.nam$b_type + dlnam.nam$b_ver);
+ deflen += dlnam.nam$b_type + dlnam.nam$b_ver;
+ memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsplit filespec: name = %.*s, default = %.*s\n",
+ dlnam.nam$b_name,vmsspec,deflen,defspec));
+ /* . . . and go back to expand it */
+ dlnam.nam$b_nop = 0;
+ dlfab.fab$l_dna = defspec;
+ dlfab.fab$b_dns = deflen;
+ dlfab.fab$b_fns = dlnam.nam$b_name;
+ sts = sys$parse(&dlfab);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tname/default sys$parse = %d\n",sts));
+ if (!(sts & 1)) {
+ dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
+ ST(0) = &PL_sv_undef;
+ }
+ else {
+ /* Now find the actual file */
+ sts = sys$search(&dlfab);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$search = %d\n",sts));
+ if (!(sts & 1)) {
+ dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv);
+ ST(0) = &PL_sv_undef;
+ }
+ else {
+ ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "\tresult = \\%.*s\\\n",
+ dlnam.nam$b_rsl,dlnam.nam$l_rsa));
+ }
+ }
+ }
+
+void
+dl_load_file(filespec, flags)
+ char * filespec
+ int flags
+ PREINIT:
+ char vmsspec[NAM$C_MAXRSS];
+ SV *reqSV, **reqSVhndl;
+ STRLEN deflen;
+ struct dsc$descriptor_s
+ specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
+ symdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ struct fscnlst {
+ unsigned short int len;
+ unsigned short int code;
+ char *string;
+ } namlst[2] = {{0,FSCN$_NAME,0},{0,0,0}};
+ struct libref *dlptr;
+ vmssts sts, failed = 0;
+ void (*entry)();
+ CODE:
+
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filespec,flags));
+ specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec);
+ specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n",
+ specdsc.dsc$a_pointer));
+ New(1399,dlptr,1,struct libref);
+ dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T;
+ dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S;
+ sts = sys$filescan(&specdsc,namlst,0);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$filescan: returns %d, name is %.*s\n",
+ sts,namlst[0].len,namlst[0].string));
+ if (!(sts & 1)) {
+ failed = 1;
+ dl_set_error(sts,0);
+ }
+ else {
+ dlptr->name.dsc$w_length = namlst[0].len;
+ dlptr->name.dsc$a_pointer = savepvn(namlst[0].string,namlst[0].len);
+ dlptr->defspec.dsc$w_length = specdsc.dsc$w_length - namlst[0].len;
+ New(1097, dlptr->defspec.dsc$a_pointer, dlptr->defspec.dsc$w_length + 1, char);
+ deflen = namlst[0].string - specdsc.dsc$a_pointer;
+ memcpy(dlptr->defspec.dsc$a_pointer,specdsc.dsc$a_pointer,deflen);
+ memcpy(dlptr->defspec.dsc$a_pointer + deflen,
+ namlst[0].string + namlst[0].len,
+ dlptr->defspec.dsc$w_length - deflen);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlibref = name: %s, defspec: %.*s\n",
+ dlptr->name.dsc$a_pointer,
+ dlptr->defspec.dsc$w_length,
+ dlptr->defspec.dsc$a_pointer));
+ if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) {
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t@dl_require_symbols empty, returning untested libref\n"));
+ }
+ else {
+ symdsc.dsc$w_length = SvCUR(reqSV);
+ symdsc.dsc$a_pointer = SvPVX(reqSV);
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t$dl_require_symbols[0] = %.*s\n",
+ symdsc.dsc$w_length, symdsc.dsc$a_pointer));
+ sts = my_find_image_symbol(&(dlptr->name),&symdsc,
+ &entry,&(dlptr->defspec));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts));
+ if (!(sts&1)) {
+ failed = 1;
+ dl_set_error(sts,0);
+ }
+ }
+ }
+
+ if (failed) {
+ Safefree(dlptr->name.dsc$a_pointer);
+ Safefree(dlptr->defspec.dsc$a_pointer);
+ Safefree(dlptr);
+ ST(0) = &PL_sv_undef;
+ }
+ else {
+ ST(0) = sv_2mortal(newSViv((IV) dlptr));
+ }
+
+
+void
+dl_find_symbol(librefptr,symname)
+ void * librefptr
+ SV * symname
+ CODE:
+ struct libref thislib = *((struct libref *)librefptr);
+ struct dsc$descriptor_s
+ symdsc = {SvCUR(symname),DSC$K_DTYPE_T,DSC$K_CLASS_S,SvPVX(symname)};
+ void (*entry)();
+ vmssts sts;
+
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_find_dymbol(%.*s,%.*s):\n",
+ thislib.name.dsc$w_length, thislib.name.dsc$a_pointer,
+ symdsc.dsc$w_length,symdsc.dsc$a_pointer));
+ sts = my_find_image_symbol(&(thislib.name),&symdsc,
+ &entry,&(thislib.defspec));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tentry point is %d\n",
+ (unsigned long int) entry));
+ if (!(sts & 1)) {
+ /* error message already saved by findsym_handler */
+ ST(0) = &PL_sv_undef;
+ }
+ else ST(0) = sv_2mortal(newSViv((IV) entry));
+
+
+void
+dl_undef_symbols()
+ PPCODE:
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+ char * perl_name
+ void * symref
+ char * filename
+ CODE:
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n",
+ perl_name, symref));
+ ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
+
+
+char *
+dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/contrib/perl5/ext/DynaLoader/dlutils.c b/contrib/perl5/ext/DynaLoader/dlutils.c
new file mode 100644
index 000000000000..bfa1f78ac0ad
--- /dev/null
+++ b/contrib/perl5/ext/DynaLoader/dlutils.c
@@ -0,0 +1,72 @@
+/* dlutils.c - handy functions and definitions for dl_*.xs files
+ *
+ * Currently this file is simply #included into dl_*.xs/.c files.
+ * It should really be split into a dlutils.h and dlutils.c
+ *
+ */
+
+
+/* pointer to allocated memory for last error message */
+static char *LastError = (char*)NULL;
+
+/* flag for immediate rather than lazy linking (spots unresolved symbol) */
+static int dl_nonlazy = 0;
+
+#ifdef DL_LOADONCEONLY
+static HV *dl_loaded_files = Nullhv; /* only needed on a few systems */
+#endif
+
+
+#ifdef DEBUGGING
+static int dl_debug = 0; /* value copied from $DynaLoader::dl_error */
+#define DLDEBUG(level,code) if (dl_debug>=level) { code; }
+#else
+#define DLDEBUG(level,code)
+#endif
+
+
+static void
+dl_generic_private_init(CPERLarg) /* called by dl_*.xs dl_private_init() */
+{
+ char *perl_dl_nonlazy;
+#ifdef DEBUGGING
+ dl_debug = SvIV( perl_get_sv("DynaLoader::dl_debug", 0x04) );
+#endif
+ if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL )
+ dl_nonlazy = atoi(perl_dl_nonlazy);
+ if (dl_nonlazy)
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "DynaLoader bind mode is 'non-lazy'\n"));
+#ifdef DL_LOADONCEONLY
+ if (!dl_loaded_files)
+ dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */
+#endif
+}
+
+
+/* SaveError() takes printf style args and saves the result in LastError */
+static void
+SaveError(CPERLarg_ char* pat, ...)
+{
+ va_list args;
+ char *message;
+ int len;
+
+ /* This code is based on croak/warn, see mess() in util.c */
+
+ va_start(args, pat);
+ message = mess(pat, &args);
+ va_end(args);
+
+ len = strlen(message) + 1 ; /* include terminating null char */
+
+ /* Allocate some memory for the error message */
+ if (LastError)
+ LastError = (char*)saferealloc(LastError, len) ;
+ else
+ LastError = (char *) safemalloc(len) ;
+
+ /* Copy message into LastError (including terminating null char) */
+ strncpy(LastError, message, len) ;
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError));
+}
+
diff --git a/contrib/perl5/ext/Errno/ChangeLog b/contrib/perl5/ext/Errno/ChangeLog
new file mode 100644
index 000000000000..2bfa003d96a4
--- /dev/null
+++ b/contrib/perl5/ext/Errno/ChangeLog
@@ -0,0 +1,50 @@
+Change 170 on 1998/07/05 by <gbarr@pobox.com> (Graham Barr)
+
+ Fixed three problems reported by Hans Mulder for NeXT
+
+ - Errno_pm.PL does not recognize #define lines because they have
+ whitespace before the '#'. ANSI does not allow that in portable
+ code; that didn't stop the author of NeXT's <errno.h>.
+
+ - Cpp output lines look like this: #1 "errno.c"
+ Errno_pm.PL does not recognize that format; it wants whitespace
+ before the line number.
+
+ - Cpp does a syntax check on files with names ending in ".c"; it
+ reports fatal errors on input lines like: "ENOSYS" [[ENOSYS]]
+ Workaround: use $Config{cppstdin}, like Errno 1.04 did.
+
+Change 160 on 1998/06/27 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added patch from Sarathy to support Win32
+ - Changed use of $Config{cpp} to $Config{cpprun} as suggested by
+ Tom Horsley
+
+Change 159 on 1998/06/27 by <gbarr@pobox.com> (Graham Barr)
+
+ - Changed to use cpp to locate required files
+ - Moved dummy Errno.pm file into d/
+ - Added support for VMS
+
+Change 158 on 1998/06/27 by <gbarr@pobox.com> (Graham Barr)
+
+ Rename errno.pl to Errno_pm.PL
+
+Change 146 on 1998/05/31 by <gbarr@pobox.com> (Graham Barr)
+
+ Added ChangeLog to MANIFEST
+
+Change 140 on 1998/05/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Fix type in errno.pl
+
+Change 139 on 1998/05/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Moved code to generate Errno.pm into errno.pl
+
+Change 136 on 1998/05/19 by <gbarr@pobox.com> (Graham Barr)
+
+ Changed to use cpp to locate constants
+
+ Added t/errno.t
+
diff --git a/contrib/perl5/ext/Errno/Errno_pm.PL b/contrib/perl5/ext/Errno/Errno_pm.PL
new file mode 100644
index 000000000000..f4d50206b5bf
--- /dev/null
+++ b/contrib/perl5/ext/Errno/Errno_pm.PL
@@ -0,0 +1,276 @@
+use ExtUtils::MakeMaker;
+use Config;
+use strict;
+
+use vars qw($VERSION);
+
+$VERSION = "1.09";
+
+my %err = ();
+
+unlink "Errno.pm" if -f "Errno.pm";
+open OUT, ">Errno.pm" or die "Cannot open Errno.pm: $!";
+select OUT;
+my $file;
+foreach $file (get_files()) {
+ process_file($file);
+}
+write_errno_pm();
+unlink "errno.c" if -f "errno.c";
+
+sub process_file {
+ my($file) = @_;
+
+ return unless defined $file;
+
+ local *FH;
+ if (($^O eq 'VMS') && ($Config{vms_cc_type} ne 'gnuc')) {
+ unless(open(FH," LIBRARY/EXTRACT=ERRNO/OUTPUT=SYS\$OUTPUT $file |")) {
+ warn "Cannot open '$file'";
+ return;
+ }
+ } else {
+ unless(open(FH,"< $file")) {
+ warn "Cannot open '$file'";
+ return;
+ }
+ }
+ while(<FH>) {
+ $err{$1} = 1
+ if /^\s*#\s*define\s+(E\w+)\s+/;
+ }
+ close(FH);
+}
+
+sub get_files {
+ my %file = ();
+ # VMS keeps its include files in system libraries (well, except for Gcc)
+ if ($^O eq 'VMS') {
+ if ($Config{vms_cc_type} eq 'decc') {
+ $file{'Sys$Library:DECC$RTLDEF.TLB'} = 1;
+ } elsif ($Config{vms_cc_type} eq 'vaxc') {
+ $file{'Sys$Library:vaxcdef.tlb'} = 1;
+ } elsif ($Config{vms_cc_type} eq 'gcc') {
+ $file{'gnu_cc_include:[000000]errno.h'} = 1;
+ }
+ } elsif ($^O eq 'os390') {
+ # OS/390 C compiler doesn't generate #file or #line directives
+ $file{'/usr/include/errno.h'} = 1;
+ } else {
+ open(CPPI,"> errno.c") or
+ die "Cannot open errno.c";
+
+ print CPPI "#include <errno.h>\n";
+
+ close(CPPI);
+
+ # invoke CPP and read the output
+
+ open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
+ die "Cannot exec $Config{cpprun}";
+
+ my $pat;
+ if ($^O eq 'MSWin32' and $Config{cc} =~ /^bcc/i) {
+ $pat = '^/\*\s+(.+)\s+\d+\s*:\s+\*/';
+ }
+ else {
+ $pat = '^#(?:line)?\s*\d+\s+"([^"]+)"';
+ }
+ while(<CPPO>) {
+ $file{$1} = 1 if /$pat/o;
+ }
+ close(CPPO);
+ }
+ return keys %file;
+}
+
+sub write_errno_pm {
+ my $err;
+
+ # create the CPP input
+
+ open(CPPI,"> errno.c") or
+ die "Cannot open errno.c";
+
+ print CPPI "#include <errno.h>\n";
+
+ foreach $err (keys %err) {
+ print CPPI '"',$err,'" [[',$err,']]',"\n";
+ }
+
+ close(CPPI);
+
+ # invoke CPP and read the output
+
+ if ($^O eq 'VMS') {
+ my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
+ $cpp =~ s/sys\$input//i;
+ open(CPPO,"$cpp errno.c |") or
+ die "Cannot exec $Config{cppstdin}";
+ } elsif(!$Config{'cpprun'} or $^O eq 'next') {
+ # NeXT will do syntax checking unless it is reading from stdin
+ my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
+ open(CPPO,"$cpp < errno.c |")
+ or die "Cannot exec $cpp";
+ } else {
+ open(CPPO,"$Config{cpprun} $Config{cppflags} errno.c |") or
+ die "Cannot exec $Config{cpprun}";
+ }
+
+ %err = ();
+
+ while(<CPPO>) {
+ my($name,$expr);
+ next unless ($name, $expr) = /"(.*?)"\s*\[\s*\[\s*(.*?)\s*\]\s*\]/;
+ next if $name eq $expr;
+ $err{$name} = eval $expr;
+ }
+ close(CPPO);
+
+ # Write Errno.pm
+
+ print <<"EDQ";
+#
+# This file is auto-generated. ***ANY*** changes here will be lost
+#
+
+package Errno;
+use vars qw(\@EXPORT_OK \%EXPORT_TAGS \@ISA \$VERSION \%errno \$AUTOLOAD);
+use Exporter ();
+use Config;
+use strict;
+
+\$Config{'myarchname'} eq "$Config{'myarchname'}" or
+ die "Errno architecture ($Config{'myarchname'}) does not match executable architecture (\$Config{'myarchname'})";
+
+\$VERSION = "$VERSION";
+\@ISA = qw(Exporter);
+
+EDQ
+
+ my $len = 0;
+ my @err = sort { $err{$a} <=> $err{$b} } keys %err;
+ map { $len = length if length > $len } @err;
+
+ my $j = "\@EXPORT_OK = qw(" . join(" ",keys %err) . ");\n";
+ $j =~ s/(.{50,70})\s/$1\n\t/g;
+ print $j,"\n";
+
+print <<'ESQ';
+%EXPORT_TAGS = (
+ POSIX => [qw(
+ESQ
+
+ my $k = join(" ", grep { exists $err{$_} }
+ qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
+ EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
+ ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
+ EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
+ EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
+ EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
+ ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
+ ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
+ ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
+ EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
+ ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
+ ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
+ EUSERS EWOULDBLOCK EXDEV));
+
+ $k =~ s/(.{50,70})\s/$1\n\t/g;
+ print "\t",$k,"\n )]\n);\n\n";
+
+ foreach $err (@err) {
+ printf "sub %s () { %d }\n",,$err,$err{$err};
+ }
+
+ print <<'ESQ';
+
+sub TIEHASH { bless [] }
+
+sub FETCH {
+ my ($self, $errname) = @_;
+ my $proto = prototype("Errno::$errname");
+ if (defined($proto) && $proto eq "") {
+ no strict 'refs';
+ return $! == &$errname;
+ }
+ require Carp;
+ Carp::confess("No errno $errname");
+}
+
+sub STORE {
+ require Carp;
+ Carp::confess("ERRNO hash is read only!");
+}
+
+*CLEAR = \&STORE;
+*DELETE = \&STORE;
+
+sub NEXTKEY {
+ my($k,$v);
+ while(($k,$v) = each %Errno::) {
+ my $proto = prototype("Errno::$k");
+ last if (defined($proto) && $proto eq "");
+
+ }
+ $k
+}
+
+sub FIRSTKEY {
+ my $s = scalar keys %Errno::;
+ goto &NEXTKEY;
+}
+
+sub EXISTS {
+ my ($self, $errname) = @_;
+ my $proto = prototype($errname);
+ defined($proto) && $proto eq "";
+}
+
+tie %!, __PACKAGE__;
+
+1;
+__END__
+
+=head1 NAME
+
+Errno - System errno constants
+
+=head1 SYNOPSIS
+
+ use Errno qw(EINTR EIO :POSIX);
+
+=head1 DESCRIPTION
+
+C<Errno> defines and conditionally exports all the error constants
+defined in your system C<errno.h> include file. It has a single export
+tag, C<:POSIX>, which will export all POSIX defined error numbers.
+
+C<Errno> also makes C<%!> magic such that each element of C<%!> has a non-zero
+value only if C<$!> is set to that value, eg
+
+ use Errno;
+
+ unless (open(FH, "/fangorn/spouse")) {
+ if ($!{ENOENT}) {
+ warn "Get a wife!\n";
+ } else {
+ warn "This path is barred: $!";
+ }
+ }
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-8 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+ESQ
+
+}
diff --git a/contrib/perl5/ext/Errno/Makefile.PL b/contrib/perl5/ext/Errno/Makefile.PL
new file mode 100644
index 000000000000..ffc8c4b7e32f
--- /dev/null
+++ b/contrib/perl5/ext/Errno/Makefile.PL
@@ -0,0 +1,29 @@
+use ExtUtils::MakeMaker;
+
+@VMS = ($^O eq 'VMS') ? (MAN3PODS => ' ') : ();
+
+WriteMakefile(
+ NAME => 'Errno',
+ VERSION_FROM => 'Errno_pm.PL',
+ PL_FILES => {'Errno_pm.PL'=>'Errno.pm'},
+ PM => {'Errno.pm' => '$(INST_LIBDIR)/Errno.pm'},
+ 'clean' => {FILES => 'Errno.pm'},
+ 'dist' => {
+ COMPRESS => 'gzip -9f',
+ SUFFIX => '.gz',
+ DIST_DEFAULT => 'd/Errno.pm tardist',
+ },
+ @VMS,
+);
+
+sub MY::postamble {
+ my $TARG = MM->catfile('d','Errno.pm');
+qq!$TARG : Makefile
+ echo '#This is a dummy file so CPAN will find a VERSION' > $TARG
+ echo 'package Errno;' >> $TARG
+ echo '\$\$VERSION = "\$(VERSION)";' >>$TARG
+ echo '#This is to make sure require will return an error' >>$TARG
+ echo '0;' >>$TARG
+
+!
+}
diff --git a/contrib/perl5/ext/Fcntl/Fcntl.pm b/contrib/perl5/ext/Fcntl/Fcntl.pm
new file mode 100644
index 000000000000..f1edb8ed79d7
--- /dev/null
+++ b/contrib/perl5/ext/Fcntl/Fcntl.pm
@@ -0,0 +1,137 @@
+package Fcntl;
+
+=head1 NAME
+
+Fcntl - load the C Fcntl.h defines
+
+=head1 SYNOPSIS
+
+ use Fcntl;
+ use Fcntl qw(:DEFAULT :flock);
+
+=head1 DESCRIPTION
+
+This module is just a translation of the C F<fnctl.h> file.
+Unlike the old mechanism of requiring a translated F<fnctl.ph>
+file, this uses the B<h2xs> program (see the Perl source distribution)
+and your native C compiler. This means that it has a
+far more likely chance of getting the numbers right.
+
+=head1 NOTE
+
+Only C<#define> symbols get translated; you must still correctly
+pack up your own arguments to pass as args for locking functions, etc.
+
+=head1 EXPORTED SYMBOLS
+
+By default your system's F_* and O_* constants (eg, F_DUPFD and
+O_CREAT) and the FD_CLOEXEC constant are exported into your namespace.
+
+You can request that the flock() constants (LOCK_SH, LOCK_EX, LOCK_NB
+and LOCK_UN) be provided by using the tag C<:flock>. See L<Exporter>.
+
+You can request that the old constants (FAPPEND, FASYNC, FCREAT,
+FDEFER, FEXCL, FNDELAY, FNONBLOCK, FSYNC, FTRUNC) be provided for
+compatibility reasons by using the tag C<:Fcompat>. For new
+applications the newer versions of these constants are suggested
+(O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK,
+O_SYNC, O_TRUNC).
+
+Please refer to your native fcntl() and open() documentation to see
+what constants are implemented in your system.
+
+=cut
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);
+
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+$VERSION = "1.03";
+# Items to export into callers namespace by default
+# (move infrequently used names to @EXPORT_OK below)
+@EXPORT =
+ qw(
+ FD_CLOEXEC
+ F_DUPFD
+ F_EXLCK
+ F_GETFD
+ F_GETFL
+ F_GETLK
+ F_GETOWN
+ F_POSIX
+ F_RDLCK
+ F_SETFD
+ F_SETFL
+ F_SETLK
+ F_SETLKW
+ F_SETOWN
+ F_SHLCK
+ F_UNLCK
+ F_WRLCK
+ O_ACCMODE
+ O_APPEND
+ O_ASYNC
+ O_BINARY
+ O_CREAT
+ O_DEFER
+ O_DSYNC
+ O_EXCL
+ O_EXLOCK
+ O_NDELAY
+ O_NOCTTY
+ O_NONBLOCK
+ O_RDONLY
+ O_RDWR
+ O_RSYNC
+ O_SHLOCK
+ O_SYNC
+ O_TEXT
+ O_TRUNC
+ O_WRONLY
+ );
+
+# Other items we are prepared to export if requested
+@EXPORT_OK = qw(
+ FAPPEND
+ FASYNC
+ FCREAT
+ FDEFER
+ FEXCL
+ FNDELAY
+ FNONBLOCK
+ FSYNC
+ FTRUNC
+ LOCK_EX
+ LOCK_NB
+ LOCK_SH
+ LOCK_UN
+);
+# Named groups of exports
+%EXPORT_TAGS = (
+ 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)],
+ 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FEXCL
+ FNDELAY FNONBLOCK FSYNC FTRUNC)],
+);
+
+sub AUTOLOAD {
+ (my $constname = $AUTOLOAD) =~ s/.*:://;
+ my $val = constant($constname, 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ my ($pack,$file,$line) = caller;
+ die "Your vendor has not defined Fcntl macro $constname, used at $file line $line.
+";
+ }
+ }
+ *$AUTOLOAD = sub { $val };
+ goto &$AUTOLOAD;
+}
+
+bootstrap Fcntl $VERSION;
+
+1;
diff --git a/contrib/perl5/ext/Fcntl/Fcntl.xs b/contrib/perl5/ext/Fcntl/Fcntl.xs
new file mode 100644
index 000000000000..5149444b6855
--- /dev/null
+++ b/contrib/perl5/ext/Fcntl/Fcntl.xs
@@ -0,0 +1,377 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef VMS
+# include <file.h>
+#else
+#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32)
+#define _NO_OLDNAMES
+#endif
+# include <fcntl.h>
+#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32)
+#undef _NO_OLDNAMES
+#endif
+#endif
+
+/* This comment is a kludge to get metaconfig to see the symbols
+ VAL_O_NONBLOCK
+ VAL_EAGAIN
+ RD_NODATA
+ EOF_NONBLOCK
+ and include the appropriate metaconfig unit
+ so that Configure will test how to turn on non-blocking I/O
+ for a file descriptor. See config.h for how to use these
+ in your extension.
+
+ While I'm at it, I'll have metaconfig look for HAS_POLL too.
+ --AD October 16, 1995
+*/
+
+static int
+not_here(char *s)
+{
+ croak("%s not implemented on this architecture", s);
+ return -1;
+}
+
+static double
+constant(char *name, int arg)
+{
+ errno = 0;
+ switch (*name) {
+ case 'F':
+ if (strnEQ(name, "F_", 2)) {
+ if (strEQ(name, "F_DUPFD"))
+#ifdef F_DUPFD
+ return F_DUPFD;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_EXLCK"))
+#ifdef F_EXLCK
+ return F_EXLCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_GETFD"))
+#ifdef F_GETFD
+ return F_GETFD;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_GETFL"))
+#ifdef F_GETFL
+ return F_GETFL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_GETLK"))
+#ifdef F_GETLK
+ return F_GETLK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_GETOWN"))
+#ifdef F_GETOWN
+ return F_GETOWN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_POSIX"))
+#ifdef F_POSIX
+ return F_POSIX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_RDLCK"))
+#ifdef F_RDLCK
+ return F_RDLCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_SETFD"))
+#ifdef F_SETFD
+ return F_SETFD;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_SETFL"))
+#ifdef F_SETFL
+ return F_SETFL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_SETLK"))
+#ifdef F_SETLK
+ return F_SETLK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_SETLKW"))
+#ifdef F_SETLKW
+ return F_SETLKW;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_SETOWN"))
+#ifdef F_SETOWN
+ return F_SETOWN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_SHLCK"))
+#ifdef F_SHLCK
+ return F_SHLCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_UNLCK"))
+#ifdef F_UNLCK
+ return F_UNLCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_WRLCK"))
+#ifdef F_WRLCK
+ return F_WRLCK;
+#else
+ goto not_there;
+#endif
+ errno = EINVAL;
+ return 0;
+ }
+ if (strEQ(name, "FAPPEND"))
+#ifdef FAPPEND
+ return FAPPEND;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FASYNC"))
+#ifdef FASYNC
+ return FASYNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FCREAT"))
+#ifdef FCREAT
+ return FCREAT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FD_CLOEXEC"))
+#ifdef FD_CLOEXEC
+ return FD_CLOEXEC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FDEFER"))
+#ifdef FDEFER
+ return FDEFER;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FEXCL"))
+#ifdef FEXCL
+ return FEXCL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FNDELAY"))
+#ifdef FNDELAY
+ return FNDELAY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FNONBLOCK"))
+#ifdef FNONBLOCK
+ return FNONBLOCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FSYNC"))
+#ifdef FSYNC
+ return FSYNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FTRUNC"))
+#ifdef FTRUNC
+ return FTRUNC;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'L':
+ if (strnEQ(name, "LOCK_", 5)) {
+ /* We support flock() on systems which don't have it, so
+ always supply the constants. */
+ if (strEQ(name, "LOCK_SH"))
+#ifdef LOCK_SH
+ return LOCK_SH;
+#else
+ return 1;
+#endif
+ if (strEQ(name, "LOCK_EX"))
+#ifdef LOCK_EX
+ return LOCK_EX;
+#else
+ return 2;
+#endif
+ if (strEQ(name, "LOCK_NB"))
+#ifdef LOCK_NB
+ return LOCK_NB;
+#else
+ return 4;
+#endif
+ if (strEQ(name, "LOCK_UN"))
+#ifdef LOCK_UN
+ return LOCK_UN;
+#else
+ return 8;
+#endif
+ } else
+ goto not_there;
+ break;
+ case 'O':
+ if (strnEQ(name, "O_", 2)) {
+ if (strEQ(name, "O_ACCMODE"))
+#ifdef O_ACCMODE
+ return O_ACCMODE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_APPEND"))
+#ifdef O_APPEND
+ return O_APPEND;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_ASYNC"))
+#ifdef O_ASYNC
+ return O_ASYNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_BINARY"))
+#ifdef O_BINARY
+ return O_BINARY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_CREAT"))
+#ifdef O_CREAT
+ return O_CREAT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_DEFER"))
+#ifdef O_DEFER
+ return O_DEFER;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_DSYNC"))
+#ifdef O_DSYNC
+ return O_DSYNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_EXCL"))
+#ifdef O_EXCL
+ return O_EXCL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_EXLOCK"))
+#ifdef O_EXLOCK
+ return O_EXLOCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_NDELAY"))
+#ifdef O_NDELAY
+ return O_NDELAY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_NOCTTY"))
+#ifdef O_NOCTTY
+ return O_NOCTTY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_NONBLOCK"))
+#ifdef O_NONBLOCK
+ return O_NONBLOCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_RDONLY"))
+#ifdef O_RDONLY
+ return O_RDONLY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_RDWR"))
+#ifdef O_RDWR
+ return O_RDWR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_RSYNC"))
+#ifdef O_RSYNC
+ return O_RSYNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_SHLOCK"))
+#ifdef O_SHLOCK
+ return O_SHLOCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_SYNC"))
+#ifdef O_SYNC
+ return O_SYNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_TEXT"))
+#ifdef O_TEXT
+ return O_TEXT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_TRUNC"))
+#ifdef O_TRUNC
+ return O_TRUNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_WRONLY"))
+#ifdef O_WRONLY
+ return O_WRONLY;
+#else
+ goto not_there;
+#endif
+ } else
+ goto not_there;
+ break;
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+
+MODULE = Fcntl PACKAGE = Fcntl
+
+double
+constant(name,arg)
+ char * name
+ int arg
+
diff --git a/contrib/perl5/ext/Fcntl/Makefile.PL b/contrib/perl5/ext/Fcntl/Makefile.PL
new file mode 100644
index 000000000000..66a6df6060d5
--- /dev/null
+++ b/contrib/perl5/ext/Fcntl/Makefile.PL
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Fcntl',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'Fcntl.pm',
+);
+
diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.pm b/contrib/perl5/ext/GDBM_File/GDBM_File.pm
new file mode 100644
index 000000000000..09df4373fb65
--- /dev/null
+++ b/contrib/perl5/ext/GDBM_File/GDBM_File.pm
@@ -0,0 +1,87 @@
+# GDBM_File.pm -- Perl 5 interface to GNU gdbm library.
+
+=head1 NAME
+
+GDBM_File - Perl5 access to the gdbm library.
+
+=head1 SYNOPSIS
+
+ use GDBM_File ;
+ tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640;
+ # Use the %hash array.
+ untie %hash ;
+
+=head1 DESCRIPTION
+
+B<GDBM_File> is a module which allows Perl programs to make use of the
+facilities provided by the GNU gdbm library. If you intend to use this
+module you should really have a copy of the gdbm manualpage at hand.
+
+Most of the libgdbm.a functions are available through the GDBM_File
+interface.
+
+=head1 AVAILABILITY
+
+Gdbm is available from any GNU archive. The master site is
+C<prep.ai.mit.edu>, but your are strongly urged to use one of the many
+mirrors. You can obtain a list of mirror sites by issuing the
+command C<finger fsf@prep.ai.mit.edu>.
+
+=head1 BUGS
+
+The available functions and the gdbm/perl interface need to be documented.
+
+=head1 SEE ALSO
+
+L<perl(1)>, L<DB_File(3)>.
+
+=cut
+
+package GDBM_File;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT $AUTOLOAD);
+
+require Carp;
+require Tie::Hash;
+require Exporter;
+use AutoLoader;
+require DynaLoader;
+@ISA = qw(Tie::Hash Exporter DynaLoader);
+@EXPORT = qw(
+ GDBM_CACHESIZE
+ GDBM_FAST
+ GDBM_INSERT
+ GDBM_NEWDB
+ GDBM_READER
+ GDBM_REPLACE
+ GDBM_WRCREAT
+ GDBM_WRITER
+);
+
+$VERSION = "1.00";
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ Carp::croak("Your vendor has not defined GDBM_File macro $constname, used");
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+bootstrap GDBM_File $VERSION;
+
+# Preloaded methods go here. Autoload methods go after __END__, and are
+# processed by the autosplit program.
+
+1;
+__END__
diff --git a/contrib/perl5/ext/GDBM_File/GDBM_File.xs b/contrib/perl5/ext/GDBM_File/GDBM_File.xs
new file mode 100644
index 000000000000..ac1ca8c68d9b
--- /dev/null
+++ b/contrib/perl5/ext/GDBM_File/GDBM_File.xs
@@ -0,0 +1,243 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <gdbm.h>
+#include <fcntl.h>
+
+typedef GDBM_FILE GDBM_File;
+
+#define GDBM_BLOCKSIZE 0 /* gdbm defaults to stat blocksize */
+#define gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func) \
+ gdbm_open(name, GDBM_BLOCKSIZE, read_write, mode, fatal_func)
+
+#define gdbm_FETCH(db,key) gdbm_fetch(db,key)
+#define gdbm_STORE(db,key,value,flags) gdbm_store(db,key,value,flags)
+#define gdbm_DELETE(db,key) gdbm_delete(db,key)
+#define gdbm_FIRSTKEY(db) gdbm_firstkey(db)
+#define gdbm_NEXTKEY(db,key) gdbm_nextkey(db,key)
+#define gdbm_EXISTS(db,key) gdbm_exists(db,key)
+
+typedef datum gdatum;
+
+typedef void (*FATALFUNC)();
+
+static int
+not_here(char *s)
+{
+ croak("GDBM_File::%s not implemented on this architecture", s);
+ return -1;
+}
+
+/* Versions of gdbm prior to 1.7x might not have the gdbm_sync,
+ gdbm_exists, and gdbm_setopt functions. Apparently Slackware
+ (Linux) 2.1 contains gdbm-1.5 (which dates back to 1991).
+*/
+#ifndef GDBM_FAST
+#define gdbm_exists(db,key) not_here("gdbm_exists")
+#define gdbm_sync(db) (void) not_here("gdbm_sync")
+#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
+#endif
+
+static double
+constant(char *name, int arg)
+{
+ errno = 0;
+ switch (*name) {
+ case 'A':
+ break;
+ case 'B':
+ break;
+ case 'C':
+ break;
+ case 'D':
+ break;
+ case 'E':
+ break;
+ case 'F':
+ break;
+ case 'G':
+ if (strEQ(name, "GDBM_CACHESIZE"))
+#ifdef GDBM_CACHESIZE
+ return GDBM_CACHESIZE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "GDBM_FAST"))
+#ifdef GDBM_FAST
+ return GDBM_FAST;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "GDBM_FASTMODE"))
+#ifdef GDBM_FASTMODE
+ return GDBM_FASTMODE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "GDBM_INSERT"))
+#ifdef GDBM_INSERT
+ return GDBM_INSERT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "GDBM_NEWDB"))
+#ifdef GDBM_NEWDB
+ return GDBM_NEWDB;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "GDBM_READER"))
+#ifdef GDBM_READER
+ return GDBM_READER;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "GDBM_REPLACE"))
+#ifdef GDBM_REPLACE
+ return GDBM_REPLACE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "GDBM_WRCREAT"))
+#ifdef GDBM_WRCREAT
+ return GDBM_WRCREAT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "GDBM_WRITER"))
+#ifdef GDBM_WRITER
+ return GDBM_WRITER;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'H':
+ break;
+ case 'I':
+ break;
+ case 'J':
+ break;
+ case 'K':
+ break;
+ case 'L':
+ break;
+ case 'M':
+ break;
+ case 'N':
+ break;
+ case 'O':
+ break;
+ case 'P':
+ break;
+ case 'Q':
+ break;
+ case 'R':
+ break;
+ case 'S':
+ break;
+ case 'T':
+ break;
+ case 'U':
+ break;
+ case 'V':
+ break;
+ case 'W':
+ break;
+ case 'X':
+ break;
+ case 'Y':
+ break;
+ case 'Z':
+ break;
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_
+
+double
+constant(name,arg)
+ char * name
+ int arg
+
+
+GDBM_File
+gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
+ char * dbtype
+ char * name
+ int read_write
+ int mode
+ FATALFUNC fatal_func
+
+void
+gdbm_close(db)
+ GDBM_File db
+ CLEANUP:
+
+void
+gdbm_DESTROY(db)
+ GDBM_File db
+ CODE:
+ gdbm_close(db);
+
+gdatum
+gdbm_FETCH(db, key)
+ GDBM_File db
+ datum key
+
+int
+gdbm_STORE(db, key, value, flags = GDBM_REPLACE)
+ GDBM_File db
+ datum key
+ datum value
+ int flags
+ CLEANUP:
+ if (RETVAL) {
+ if (RETVAL < 0 && errno == EPERM)
+ croak("No write permission to gdbm file");
+ croak("gdbm store returned %d, errno %d, key \"%.*s\"",
+ RETVAL,errno,key.dsize,key.dptr);
+ /* gdbm_clearerr(db); */
+ }
+
+int
+gdbm_DELETE(db, key)
+ GDBM_File db
+ datum key
+
+gdatum
+gdbm_FIRSTKEY(db)
+ GDBM_File db
+
+gdatum
+gdbm_NEXTKEY(db, key)
+ GDBM_File db
+ datum key
+
+int
+gdbm_reorganize(db)
+ GDBM_File db
+
+
+void
+gdbm_sync(db)
+ GDBM_File db
+
+int
+gdbm_EXISTS(db, key)
+ GDBM_File db
+ datum key
+
+int
+gdbm_setopt (db, optflag, optval, optlen)
+ GDBM_File db
+ int optflag
+ int &optval
+ int optlen
+
diff --git a/contrib/perl5/ext/GDBM_File/Makefile.PL b/contrib/perl5/ext/GDBM_File/Makefile.PL
new file mode 100644
index 000000000000..d24461350b61
--- /dev/null
+++ b/contrib/perl5/ext/GDBM_File/Makefile.PL
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'GDBM_File',
+ LIBS => ["-L/usr/local/lib -lgdbm", "-ldbm"],
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'GDBM_File.pm',
+);
diff --git a/contrib/perl5/ext/GDBM_File/typemap b/contrib/perl5/ext/GDBM_File/typemap
new file mode 100644
index 000000000000..317a8f3886cb
--- /dev/null
+++ b/contrib/perl5/ext/GDBM_File/typemap
@@ -0,0 +1,27 @@
+#
+#################################### DBM SECTION
+#
+
+datum T_DATUM
+gdatum T_GDATUM
+NDBM_File T_PTROBJ
+GDBM_File T_PTROBJ
+SDBM_File T_PTROBJ
+ODBM_File T_PTROBJ
+DB_File T_PTROBJ
+DBZ_File T_PTROBJ
+FATALFUNC T_OPAQUEPTR
+
+INPUT
+T_DATUM
+ $var.dptr = SvPV($arg, PL_na);
+ $var.dsize = (int)PL_na;
+T_GDATUM
+ UNIMPLEMENTED
+OUTPUT
+T_DATUM
+ sv_setpvn($arg, $var.dptr, $var.dsize);
+T_GDATUM
+ sv_usepvn($arg, $var.dptr, $var.dsize);
+T_PTROBJ
+ sv_setref_pv($arg, dbtype, (void*)$var);
diff --git a/contrib/perl5/ext/IO/IO.pm b/contrib/perl5/ext/IO/IO.pm
new file mode 100644
index 000000000000..4d4c81ce4053
--- /dev/null
+++ b/contrib/perl5/ext/IO/IO.pm
@@ -0,0 +1,36 @@
+#
+
+package IO;
+
+=head1 NAME
+
+IO - load various IO modules
+
+=head1 SYNOPSIS
+
+ use IO;
+
+=head1 DESCRIPTION
+
+C<IO> provides a simple mechanism to load some of the IO modules at one go.
+Currently this includes:
+
+ IO::Handle
+ IO::Seekable
+ IO::File
+ IO::Pipe
+ IO::Socket
+
+For more information on any of these modules, please see its respective
+documentation.
+
+=cut
+
+use IO::Handle;
+use IO::Seekable;
+use IO::File;
+use IO::Pipe;
+use IO::Socket;
+
+1;
+
diff --git a/contrib/perl5/ext/IO/IO.xs b/contrib/perl5/ext/IO/IO.xs
new file mode 100644
index 000000000000..a434cca78bd0
--- /dev/null
+++ b/contrib/perl5/ext/IO/IO.xs
@@ -0,0 +1,292 @@
+#include "EXTERN.h"
+#define PERLIO_NOT_STDIO 1
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+#ifdef I_FCNTL
+#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32)
+#define _NO_OLDNAMES
+#endif
+# include <fcntl.h>
+#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32)
+#undef _NO_OLDNAMES
+#endif
+
+#endif
+
+#ifdef PerlIO
+typedef int SysRet;
+typedef PerlIO * InputStream;
+typedef PerlIO * OutputStream;
+#else
+#define PERLIO_IS_STDIO 1
+typedef int SysRet;
+typedef FILE * InputStream;
+typedef FILE * OutputStream;
+#endif
+
+static int
+not_here(char *s)
+{
+ croak("%s not implemented on this architecture", s);
+ return -1;
+}
+
+static bool
+constant(char *name, IV *pval)
+{
+ switch (*name) {
+ case '_':
+ if (strEQ(name, "_IOFBF"))
+#ifdef _IOFBF
+ { *pval = _IOFBF; return TRUE; }
+#else
+ return FALSE;
+#endif
+ if (strEQ(name, "_IOLBF"))
+#ifdef _IOLBF
+ { *pval = _IOLBF; return TRUE; }
+#else
+ return FALSE;
+#endif
+ if (strEQ(name, "_IONBF"))
+#ifdef _IONBF
+ { *pval = _IONBF; return TRUE; }
+#else
+ return FALSE;
+#endif
+ break;
+ case 'S':
+ if (strEQ(name, "SEEK_SET"))
+#ifdef SEEK_SET
+ { *pval = SEEK_SET; return TRUE; }
+#else
+ return FALSE;
+#endif
+ if (strEQ(name, "SEEK_CUR"))
+#ifdef SEEK_CUR
+ { *pval = SEEK_CUR; return TRUE; }
+#else
+ return FALSE;
+#endif
+ if (strEQ(name, "SEEK_END"))
+#ifdef SEEK_END
+ { *pval = SEEK_END; return TRUE; }
+#else
+ return FALSE;
+#endif
+ break;
+ }
+
+ return FALSE;
+}
+
+
+MODULE = IO PACKAGE = IO::Seekable PREFIX = f
+
+SV *
+fgetpos(handle)
+ InputStream handle
+ CODE:
+ if (handle) {
+ Fpos_t pos;
+#ifdef PerlIO
+ PerlIO_getpos(handle, &pos);
+#else
+ fgetpos(handle, &pos);
+#endif
+ ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
+ }
+ else {
+ ST(0) = &PL_sv_undef;
+ errno = EINVAL;
+ }
+
+SysRet
+fsetpos(handle, pos)
+ InputStream handle
+ SV * pos
+ CODE:
+ char *p;
+ if (handle && (p = SvPVx(pos, PL_na)) && PL_na == sizeof(Fpos_t))
+#ifdef PerlIO
+ RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
+#else
+ RETVAL = fsetpos(handle, (Fpos_t*)p);
+#endif
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+ OUTPUT:
+ RETVAL
+
+MODULE = IO PACKAGE = IO::File PREFIX = f
+
+SV *
+new_tmpfile(packname = "IO::File")
+ char * packname
+ PREINIT:
+ OutputStream fp;
+ GV *gv;
+ CODE:
+#ifdef PerlIO
+ fp = PerlIO_tmpfile();
+#else
+ fp = tmpfile();
+#endif
+ gv = (GV*)SvREFCNT_inc(newGVgen(packname));
+ hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
+ if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
+ ST(0) = sv_2mortal(newRV((SV*)gv));
+ sv_bless(ST(0), gv_stashpv(packname, TRUE));
+ SvREFCNT_dec(gv); /* undo increment in newRV() */
+ }
+ else {
+ ST(0) = &PL_sv_undef;
+ SvREFCNT_dec(gv);
+ }
+
+MODULE = IO PACKAGE = IO::Handle PREFIX = f
+
+SV *
+constant(name)
+ char * name
+ CODE:
+ IV i;
+ if (constant(name, &i))
+ ST(0) = sv_2mortal(newSViv(i));
+ else
+ ST(0) = &PL_sv_undef;
+
+int
+ungetc(handle, c)
+ InputStream handle
+ int c
+ CODE:
+ if (handle)
+#ifdef PerlIO
+ RETVAL = PerlIO_ungetc(handle, c);
+#else
+ RETVAL = ungetc(c, handle);
+#endif
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+ OUTPUT:
+ RETVAL
+
+int
+ferror(handle)
+ InputStream handle
+ CODE:
+ if (handle)
+#ifdef PerlIO
+ RETVAL = PerlIO_error(handle);
+#else
+ RETVAL = ferror(handle);
+#endif
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+ OUTPUT:
+ RETVAL
+
+int
+clearerr(handle)
+ InputStream handle
+ CODE:
+ if (handle) {
+#ifdef PerlIO
+ PerlIO_clearerr(handle);
+#else
+ clearerr(handle);
+#endif
+ RETVAL = 0;
+ }
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+ OUTPUT:
+ RETVAL
+
+int
+untaint(handle)
+ SV * handle
+ CODE:
+#ifdef IOf_UNTAINT
+ IO * io;
+ io = sv_2io(handle);
+ if (io) {
+ IoFLAGS(io) |= IOf_UNTAINT;
+ RETVAL = 0;
+ }
+ else {
+#endif
+ RETVAL = -1;
+ errno = EINVAL;
+#ifdef IOf_UNTAINT
+ }
+#endif
+ OUTPUT:
+ RETVAL
+
+SysRet
+fflush(handle)
+ OutputStream handle
+ CODE:
+ if (handle)
+#ifdef PerlIO
+ RETVAL = PerlIO_flush(handle);
+#else
+ RETVAL = Fflush(handle);
+#endif
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+ OUTPUT:
+ RETVAL
+
+void
+setbuf(handle, buf)
+ OutputStream handle
+ char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
+ CODE:
+ if (handle)
+#ifdef PERLIO_IS_STDIO
+ setbuf(handle, buf);
+#else
+ not_here("IO::Handle::setbuf");
+#endif
+
+SysRet
+setvbuf(handle, buf, type, size)
+ OutputStream handle
+ char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
+ int type
+ int size
+ CODE:
+/* Should check HAS_SETVBUF once Configure tests for that */
+#if defined(PERLIO_IS_STDIO) && defined(_IOFBF)
+ if (!handle) /* Try input stream. */
+ handle = IoIFP(sv_2io(ST(0)));
+ if (handle)
+ RETVAL = setvbuf(handle, buf, type, size);
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+#else
+ RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
+#endif
+ OUTPUT:
+ RETVAL
+
+
diff --git a/contrib/perl5/ext/IO/Makefile.PL b/contrib/perl5/ext/IO/Makefile.PL
new file mode 100644
index 000000000000..4a34be61fbb3
--- /dev/null
+++ b/contrib/perl5/ext/IO/Makefile.PL
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'IO',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'lib/IO/Handle.pm',
+ XS_VERSION => 1.15
+);
diff --git a/contrib/perl5/ext/IO/README b/contrib/perl5/ext/IO/README
new file mode 100644
index 000000000000..e855afade40a
--- /dev/null
+++ b/contrib/perl5/ext/IO/README
@@ -0,0 +1,4 @@
+This directory contains files from the IO distribution maintained by
+Graham Barr <bodg@tiuk.ti.com>. If you find that you have to modify
+any files in this directory then please forward him a patch for only
+the files in this directory.
diff --git a/contrib/perl5/ext/IO/lib/IO/File.pm b/contrib/perl5/ext/IO/lib/IO/File.pm
new file mode 100644
index 000000000000..de7fabc6f257
--- /dev/null
+++ b/contrib/perl5/ext/IO/lib/IO/File.pm
@@ -0,0 +1,167 @@
+#
+
+package IO::File;
+
+=head1 NAME
+
+IO::File - supply object methods for filehandles
+
+=head1 SYNOPSIS
+
+ use IO::File;
+
+ $fh = new IO::File;
+ if ($fh->open("< file")) {
+ print <$fh>;
+ $fh->close;
+ }
+
+ $fh = new IO::File "> file";
+ if (defined $fh) {
+ print $fh "bar\n";
+ $fh->close;
+ }
+
+ $fh = new IO::File "file", "r";
+ if (defined $fh) {
+ print <$fh>;
+ undef $fh; # automatically closes the file
+ }
+
+ $fh = new IO::File "file", O_WRONLY|O_APPEND;
+ if (defined $fh) {
+ print $fh "corge\n";
+
+ $pos = $fh->getpos;
+ $fh->setpos($pos);
+
+ undef $fh; # automatically closes the file
+ }
+
+ autoflush STDOUT 1;
+
+=head1 DESCRIPTION
+
+C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends
+these classes with methods that are specific to file handles.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ([ ARGS ] )
+
+Creates a C<IO::File>. If it receives any parameters, they are passed to
+the method C<open>; if the open fails, the object is destroyed. Otherwise,
+it is returned to the caller.
+
+=item new_tmpfile
+
+Creates an C<IO::File> opened for read/write on a newly created temporary
+file. On systems where this is possible, the temporary file is anonymous
+(i.e. it is unlinked after creation, but held open). If the temporary
+file cannot be created or opened, the C<IO::File> object is destroyed.
+Otherwise, it is returned to the caller.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item open( FILENAME [,MODE [,PERMS]] )
+
+C<open> accepts one, two or three parameters. With one parameter,
+it is just a front end for the built-in C<open> function. With two
+parameters, the first parameter is a filename that may include
+whitespace or other special characters, and the second parameter is
+the open mode, optionally followed by a file permission value.
+
+If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.)
+or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
+Perl C<open> operator.
+
+If C<IO::File::open> is given a numeric mode, it passes that mode
+and the optional permissions value to the Perl C<sysopen> operator.
+For convenience, C<IO::File::import> tries to import the O_XXX
+constants from the Fcntl module. If dynamic loading is not available,
+this may fail, but the rest of IO::File will still work.
+
+=back
+
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<IO::Handle>
+L<IO::Seekable>
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>.
+
+=cut
+
+require 5.000;
+use strict;
+use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA);
+use Carp;
+use Symbol;
+use SelectSaver;
+use IO::Seekable;
+
+require Exporter;
+require DynaLoader;
+
+@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader);
+
+$VERSION = "1.06021";
+
+@EXPORT = @IO::Seekable::EXPORT;
+
+eval {
+ # Make all Fcntl O_XXX constants available for importing
+ require Fcntl;
+ my @O = grep /^O_/, @Fcntl::EXPORT;
+ Fcntl->import(@O); # first we import what we want to export
+ push(@EXPORT, @O);
+};
+
+
+################################################
+## Constructor
+##
+
+sub new {
+ my $type = shift;
+ my $class = ref($type) || $type || "IO::File";
+ @_ >= 0 && @_ <= 3
+ or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]";
+ my $fh = $class->SUPER::new();
+ if (@_) {
+ $fh->open(@_)
+ or return undef;
+ }
+ $fh;
+}
+
+################################################
+## Open
+##
+
+sub open {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
+ my ($fh, $file) = @_;
+ if (@_ > 2) {
+ my ($mode, $perms) = @_[2, 3];
+ if ($mode =~ /^\d+$/) {
+ defined $perms or $perms = 0666;
+ return sysopen($fh, $file, $mode, $perms);
+ }
+ $file = './' . $file if $file =~ m{\A[^\\/\w]};
+ $file = IO::Handle::_open_mode_string($mode) . " $file\0";
+ }
+ open($fh, $file);
+}
+
+1;
diff --git a/contrib/perl5/ext/IO/lib/IO/Handle.pm b/contrib/perl5/ext/IO/lib/IO/Handle.pm
new file mode 100644
index 000000000000..7927641f7f16
--- /dev/null
+++ b/contrib/perl5/ext/IO/lib/IO/Handle.pm
@@ -0,0 +1,539 @@
+
+package IO::Handle;
+
+=head1 NAME
+
+IO::Handle - supply object methods for I/O handles
+
+=head1 SYNOPSIS
+
+ use IO::Handle;
+
+ $fh = new IO::Handle;
+ if ($fh->fdopen(fileno(STDIN),"r")) {
+ print $fh->getline;
+ $fh->close;
+ }
+
+ $fh = new IO::Handle;
+ if ($fh->fdopen(fileno(STDOUT),"w")) {
+ $fh->print("Some text\n");
+ }
+
+ use IO::Handle '_IOLBF';
+ $fh->setvbuf($buffer_var, _IOLBF, 1024);
+
+ undef $fh; # automatically closes the file if it's open
+
+ autoflush STDOUT 1;
+
+=head1 DESCRIPTION
+
+C<IO::Handle> is the base class for all other IO handle classes. It is
+not intended that objects of C<IO::Handle> would be created directly,
+but instead C<IO::Handle> is inherited from by several other classes
+in the IO hierarchy.
+
+If you are reading this documentation, looking for a replacement for
+the C<FileHandle> package, then I suggest you read the documentation
+for C<IO::File>
+
+A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package)
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ()
+
+Creates a new C<IO::Handle> object.
+
+=item new_from_fd ( FD, MODE )
+
+Creates a C<IO::Handle> like C<new> does.
+It requires two parameters, which are passed to the method C<fdopen>;
+if the fdopen fails, the object is destroyed. Otherwise, it is returned
+to the caller.
+
+=back
+
+=head1 METHODS
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Handle> methods, which are just front ends for the
+corresponding built-in functions:
+
+ close
+ fileno
+ getc
+ eof
+ read
+ truncate
+ stat
+ print
+ printf
+ sysread
+ syswrite
+
+See L<perlvar> for complete descriptions of each of the following
+supported C<IO::Handle> methods:
+
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+ format_write
+
+Furthermore, for doing normal I/O you might need these:
+
+=over
+
+=item $fh->fdopen ( FD, MODE )
+
+C<fdopen> is like an ordinary C<open> except that its first parameter
+is not a filename but rather a file handle name, a IO::Handle object,
+or a file descriptor number.
+
+=item $fh->opened
+
+Returns true if the object is currently a valid file descriptor.
+
+=item $fh->getline
+
+This works like <$fh> described in L<perlop/"I/O Operators">
+except that it's more readable and can be safely called in an
+array context but still returns just one line.
+
+=item $fh->getlines
+
+This works like <$fh> when called in an array context to
+read all the remaining lines in a file, except that it's more readable.
+It will also croak() if accidentally called in a scalar context.
+
+=item $fh->ungetc ( ORD )
+
+Pushes a character with the given ordinal value back onto the given
+handle's input stream.
+
+=item $fh->write ( BUF, LEN [, OFFSET }\] )
+
+This C<write> is like C<write> found in C, that is it is the
+opposite of read. The wrapper for the perl C<write> function is
+called C<format_write>.
+
+=item $fh->flush
+
+Flush the given handle's buffer.
+
+=item $fh->error
+
+Returns a true value if the given handle has experienced any errors
+since it was opened or since the last call to C<clearerr>.
+
+=item $fh->clearerr
+
+Clear the given handle's error indicator.
+
+=back
+
+If the C functions setbuf() and/or setvbuf() are available, then
+C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
+policy for an IO::Handle. The calling sequences for the Perl functions
+are the same as their C counterparts--including the constants C<_IOFBF>,
+C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
+specifies a scalar variable to use as a buffer. WARNING: A variable
+used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any
+way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called
+again, or memory corruption may result! Note that you need to import
+the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly.
+
+Lastly, there is a special method for working under B<-T> and setuid/gid
+scripts:
+
+=over
+
+=item $fh->untaint
+
+Marks the object as taint-clean, and as such data read from it will also
+be considered taint-clean. Note that this is a very trusting action to
+take, and appropriate consideration for the data source and potential
+vulnerability should be kept in mind.
+
+=back
+
+=head1 NOTE
+
+A C<IO::Handle> object is a GLOB reference. Some modules that
+inherit from C<IO::Handle> may want to keep object related variables
+in the hash table part of the GLOB. In an attempt to prevent modules
+trampling on each other I propose the that any such module should prefix
+its variables with its own name separated by _'s. For example the IO::Socket
+module keeps a C<timeout> variable in 'io_socket_timeout'.
+
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<IO::File>
+
+=head1 BUGS
+
+Due to backwards compatibility, all filehandles resemble objects
+of class C<IO::Handle>, or actually classes derived from that class.
+They actually aren't. Which means you can't derive your own
+class from C<IO::Handle> and inherit those methods.
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
+
+=cut
+
+require 5.000;
+use strict;
+use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA);
+use Carp;
+use Symbol;
+use SelectSaver;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+$VERSION = "1.1505";
+$XS_VERSION = "1.15";
+
+@EXPORT_OK = qw(
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+ format_write
+
+ print
+ printf
+ getline
+ getlines
+
+ SEEK_SET
+ SEEK_CUR
+ SEEK_END
+ _IOFBF
+ _IOLBF
+ _IONBF
+);
+
+
+################################################
+## Interaction with the XS.
+##
+
+require DynaLoader;
+@IO::ISA = qw(DynaLoader);
+bootstrap IO $XS_VERSION;
+
+sub AUTOLOAD {
+ if ($AUTOLOAD =~ /::(_?[a-z])/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD
+ }
+ my $constname = $AUTOLOAD;
+ $constname =~ s/.*:://;
+ my $val = constant($constname);
+ defined $val or croak "$constname is not a valid IO::Handle macro";
+ no strict 'refs';
+ *$AUTOLOAD = sub { $val };
+ goto &$AUTOLOAD;
+}
+
+
+################################################
+## Constructors, destructors.
+##
+
+sub new {
+ my $class = ref($_[0]) || $_[0] || "IO::Handle";
+ @_ == 1 or croak "usage: new $class";
+ my $fh = gensym;
+ bless $fh, $class;
+}
+
+sub new_from_fd {
+ my $class = ref($_[0]) || $_[0] || "IO::Handle";
+ @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
+ my $fh = gensym;
+ shift;
+ IO::Handle::fdopen($fh, @_)
+ or return undef;
+ bless $fh, $class;
+}
+
+#
+# There is no need for DESTROY to do anything, because when the
+# last reference to an IO object is gone, Perl automatically
+# closes its associated files (if any). However, to avoid any
+# attempts to autoload DESTROY, we here define it to do nothing.
+#
+sub DESTROY {}
+
+
+################################################
+## Open and close.
+##
+
+sub _open_mode_string {
+ my ($mode) = @_;
+ $mode =~ /^\+?(<|>>?)$/
+ or $mode =~ s/^r(\+?)$/$1</
+ or $mode =~ s/^w(\+?)$/$1>/
+ or $mode =~ s/^a(\+?)$/$1>>/
+ or croak "IO::Handle: bad open mode: $mode";
+ $mode;
+}
+
+sub fdopen {
+ @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
+ my ($fh, $fd, $mode) = @_;
+ local(*GLOB);
+
+ if (ref($fd) && "".$fd =~ /GLOB\(/o) {
+ # It's a glob reference; Alias it as we cannot get name of anon GLOBs
+ my $n = qualify(*GLOB);
+ *GLOB = *{*$fd};
+ $fd = $n;
+ } elsif ($fd =~ m#^\d+$#) {
+ # It's an FD number; prefix with "=".
+ $fd = "=$fd";
+ }
+
+ open($fh, _open_mode_string($mode) . '&' . $fd)
+ ? $fh : undef;
+}
+
+sub close {
+ @_ == 1 or croak 'usage: $fh->close()';
+ my($fh) = @_;
+
+ close($fh);
+}
+
+################################################
+## Normal I/O functions.
+##
+
+# flock
+# select
+
+sub opened {
+ @_ == 1 or croak 'usage: $fh->opened()';
+ defined fileno($_[0]);
+}
+
+sub fileno {
+ @_ == 1 or croak 'usage: $fh->fileno()';
+ fileno($_[0]);
+}
+
+sub getc {
+ @_ == 1 or croak 'usage: $fh->getc()';
+ getc($_[0]);
+}
+
+sub eof {
+ @_ == 1 or croak 'usage: $fh->eof()';
+ eof($_[0]);
+}
+
+sub print {
+ @_ or croak 'usage: $fh->print([ARGS])';
+ my $this = shift;
+ print $this @_;
+}
+
+sub printf {
+ @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])';
+ my $this = shift;
+ printf $this @_;
+}
+
+sub getline {
+ @_ == 1 or croak 'usage: $fh->getline';
+ my $this = shift;
+ return scalar <$this>;
+}
+
+*gets = \&getline; # deprecated
+
+sub getlines {
+ @_ == 1 or croak 'usage: $fh->getline()';
+ wantarray or
+ croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline';
+ my $this = shift;
+ return <$this>;
+}
+
+sub truncate {
+ @_ == 2 or croak 'usage: $fh->truncate(LEN)';
+ truncate($_[0], $_[1]);
+}
+
+sub read {
+ @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])';
+ read($_[0], $_[1], $_[2], $_[3] || 0);
+}
+
+sub sysread {
+ @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])';
+ sysread($_[0], $_[1], $_[2], $_[3] || 0);
+}
+
+sub write {
+ @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])';
+ local($\) = "";
+ print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
+}
+
+sub syswrite {
+ @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])';
+ syswrite($_[0], $_[1], $_[2], $_[3] || 0);
+}
+
+sub stat {
+ @_ == 1 or croak 'usage: $fh->stat()';
+ stat($_[0]);
+}
+
+################################################
+## State modification functions.
+##
+
+sub autoflush {
+ my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $|;
+ $| = @_ > 1 ? $_[1] : 1;
+ $prev;
+}
+
+sub output_field_separator {
+ my $prev = $,;
+ $, = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub output_record_separator {
+ my $prev = $\;
+ $\ = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub input_record_separator {
+ my $prev = $/;
+ $/ = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub input_line_number {
+ # localizing $. doesn't work as advertised. grrrrrr.
+ my $prev = $.;
+ $. = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_page_number {
+ my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $%;
+ $% = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_lines_per_page {
+ my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $=;
+ $= = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_lines_left {
+ my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $-;
+ $- = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_name {
+ my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $~;
+ $~ = qualify($_[1], caller) if @_ > 1;
+ $prev;
+}
+
+sub format_top_name {
+ my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
+ my $prev = $^;
+ $^ = qualify($_[1], caller) if @_ > 1;
+ $prev;
+}
+
+sub format_line_break_characters {
+ my $prev = $:;
+ $: = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_formfeed {
+ my $prev = $^L;
+ $^L = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub formline {
+ my $fh = shift;
+ my $picture = shift;
+ local($^A) = $^A;
+ local($\) = "";
+ formline($picture, @_);
+ print $fh $^A;
+}
+
+sub format_write {
+ @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )';
+ if (@_ == 2) {
+ my ($fh, $fmt) = @_;
+ my $oldfmt = $fh->format_name($fmt);
+ CORE::write($fh);
+ $fh->format_name($oldfmt);
+ } else {
+ CORE::write($_[0]);
+ }
+}
+
+sub fcntl {
+ @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );';
+ my ($fh, $op, $val) = @_;
+ my $r = fcntl($fh, $op, $val);
+ defined $r && $r eq "0 but true" ? 0 : $r;
+}
+
+sub ioctl {
+ @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );';
+ my ($fh, $op, $val) = @_;
+ my $r = ioctl($fh, $op, $val);
+ defined $r && $r eq "0 but true" ? 0 : $r;
+}
+
+1;
diff --git a/contrib/perl5/ext/IO/lib/IO/Pipe.pm b/contrib/perl5/ext/IO/lib/IO/Pipe.pm
new file mode 100644
index 000000000000..ae6d9a547e28
--- /dev/null
+++ b/contrib/perl5/ext/IO/lib/IO/Pipe.pm
@@ -0,0 +1,239 @@
+# IO::Pipe.pm
+#
+# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Pipe;
+
+require 5.000;
+
+use IO::Handle;
+use strict;
+use vars qw($VERSION);
+use Carp;
+use Symbol;
+
+$VERSION = "1.0901";
+
+sub new {
+ my $type = shift;
+ my $class = ref($type) || $type || "IO::Pipe";
+ @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]";
+
+ my $me = bless gensym(), $class;
+
+ my($readfh,$writefh) = @_ ? @_ : $me->handles;
+
+ pipe($readfh, $writefh)
+ or return undef;
+
+ @{*$me} = ($readfh, $writefh);
+
+ $me;
+}
+
+sub handles {
+ @_ == 1 or croak 'usage: $pipe->handles()';
+ (IO::Pipe::End->new(), IO::Pipe::End->new());
+}
+
+my $do_spawn = $^O eq 'os2';
+
+sub _doit {
+ my $me = shift;
+ my $rw = shift;
+
+ my $pid = $do_spawn ? 0 : fork();
+
+ if($pid) { # Parent
+ return $pid;
+ }
+ elsif(defined $pid) { # Child or spawn
+ my $fh;
+ my $io = $rw ? \*STDIN : \*STDOUT;
+ my ($mode, $save) = $rw ? "r" : "w";
+ if ($do_spawn) {
+ require Fcntl;
+ $save = IO::Handle->new_from_fd($io, $mode);
+ # Close in child:
+ fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
+ $fh = $rw ? ${*$me}[0] : ${*$me}[1];
+ } else {
+ shift;
+ $fh = $rw ? $me->reader() : $me->writer(); # close the other end
+ }
+ bless $io, "IO::Handle";
+ $io->fdopen($fh, $mode);
+ $fh->close;
+
+ if ($do_spawn) {
+ $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
+ my $err = $!;
+
+ $io->fdopen($save, $mode);
+ $save->close or croak "Cannot close $!";
+ croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
+ return $pid;
+ } else {
+ exec @_ or
+ croak "IO::Pipe: Cannot exec: $!";
+ }
+ }
+ else {
+ croak "IO::Pipe: Cannot fork: $!";
+ }
+
+ # NOT Reached
+}
+
+sub reader {
+ @_ >= 1 or croak 'usage: $pipe->reader()';
+ my $me = shift;
+ my $fh = ${*$me}[0];
+ my $pid = $me->_doit(0, $fh, @_)
+ if(@_);
+
+ close ${*$me}[1];
+ bless $me, ref($fh);
+ *{*$me} = *{*$fh}; # Alias self to handle
+ bless $fh; # Really wan't un-bless here
+ ${*$me}{'io_pipe_pid'} = $pid
+ if defined $pid;
+
+ $me;
+}
+
+sub writer {
+ @_ >= 1 or croak 'usage: $pipe->writer()';
+ my $me = shift;
+ my $fh = ${*$me}[1];
+ my $pid = $me->_doit(1, $fh, @_)
+ if(@_);
+
+ close ${*$me}[0];
+ bless $me, ref($fh);
+ *{*$me} = *{*$fh}; # Alias self to handle
+ bless $fh; # Really wan't un-bless here
+ ${*$me}{'io_pipe_pid'} = $pid
+ if defined $pid;
+
+ $me;
+}
+
+package IO::Pipe::End;
+
+use vars qw(@ISA);
+
+@ISA = qw(IO::Handle);
+
+sub close {
+ my $fh = shift;
+ my $r = $fh->SUPER::close(@_);
+
+ waitpid(${*$fh}{'io_pipe_pid'},0)
+ if(defined ${*$fh}{'io_pipe_pid'});
+
+ $r;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::pipe - supply object methods for pipes
+
+=head1 SYNOPSIS
+
+ use IO::Pipe;
+
+ $pipe = new IO::Pipe;
+
+ if($pid = fork()) { # Parent
+ $pipe->reader();
+
+ while(<$pipe> {
+ ....
+ }
+
+ }
+ elsif(defined $pid) { # Child
+ $pipe->writer();
+
+ print $pipe ....
+ }
+
+ or
+
+ $pipe = new IO::Pipe;
+
+ $pipe->reader(qw(ls -l));
+
+ while(<$pipe>) {
+ ....
+ }
+
+=head1 DESCRIPTION
+
+C<IO::Pipe> provides an interface to createing pipes between
+processes.
+
+=head1 CONSTRCUTOR
+
+=over 4
+
+=item new ( [READER, WRITER] )
+
+Creates a C<IO::Pipe>, which is a reference to a newly created symbol
+(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two
+arguments, which should be objects blessed into C<IO::Handle>, or a
+subclass thereof. These two objects will be used for the system call
+to C<pipe>. If no arguments are given then method C<handles> is called
+on the new C<IO::Pipe> object.
+
+These two handles are held in the array part of the GLOB until either
+C<reader> or C<writer> is called.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item reader ([ARGS])
+
+The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
+handle at the reading end of the pipe. If C<ARGS> are given then C<fork>
+is called and C<ARGS> are passed to exec.
+
+=item writer ([ARGS])
+
+The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
+handle at the writing end of the pipe. If C<ARGS> are given then C<fork>
+is called and C<ARGS> are passed to exec.
+
+=item handles ()
+
+This method is called during construction by C<IO::Pipe::new>
+on the newly created C<IO::Pipe> object. It returns an array of two objects
+blessed into C<IO::Pipe::End>, or a subclass thereof.
+
+=back
+
+=head1 SEE ALSO
+
+L<IO::Handle>
+
+=head1 AUTHOR
+
+Graham Barr <bodg@tiuk.ti.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1996 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
diff --git a/contrib/perl5/ext/IO/lib/IO/Seekable.pm b/contrib/perl5/ext/IO/lib/IO/Seekable.pm
new file mode 100644
index 000000000000..91c381a61e9a
--- /dev/null
+++ b/contrib/perl5/ext/IO/lib/IO/Seekable.pm
@@ -0,0 +1,68 @@
+#
+
+package IO::Seekable;
+
+=head1 NAME
+
+IO::Seekable - supply seek based methods for I/O objects
+
+=head1 SYNOPSIS
+
+ use IO::Seekable;
+ package IO::Something;
+ @ISA = qw(IO::Seekable);
+
+=head1 DESCRIPTION
+
+C<IO::Seekable> does not have a constuctor of its own as is intended to
+be inherited by other C<IO::Handle> based objects. It provides methods
+which allow seeking of the file descriptors.
+
+If the C functions fgetpos() and fsetpos() are available, then
+C<IO::File::getpos> returns an opaque value that represents the
+current position of the IO::File, and C<IO::File::setpos> uses
+that value to return to a previously visited position.
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Seekable> methods, which are just front ends for the
+corresponding built-in functions:
+
+ seek
+ tell
+
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<IO::Handle>
+L<IO::File>
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt>
+
+=cut
+
+require 5.000;
+use Carp;
+use strict;
+use vars qw($VERSION @EXPORT @ISA);
+use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
+require Exporter;
+
+@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
+@ISA = qw(Exporter);
+
+$VERSION = "1.06";
+
+sub seek {
+ @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
+ seek($_[0], $_[1], $_[2]);
+}
+
+sub tell {
+ @_ == 1 or croak 'usage: $fh->tell()';
+ tell($_[0]);
+}
+
+1;
diff --git a/contrib/perl5/ext/IO/lib/IO/Select.pm b/contrib/perl5/ext/IO/lib/IO/Select.pm
new file mode 100644
index 000000000000..dea684a62eda
--- /dev/null
+++ b/contrib/perl5/ext/IO/lib/IO/Select.pm
@@ -0,0 +1,371 @@
+# IO::Select.pm
+#
+# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+# software; you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+
+package IO::Select;
+
+=head1 NAME
+
+IO::Select - OO interface to the select system call
+
+=head1 SYNOPSIS
+
+ use IO::Select;
+
+ $s = IO::Select->new();
+
+ $s->add(\*STDIN);
+ $s->add($some_handle);
+
+ @ready = $s->can_read($timeout);
+
+ @ready = IO::Select->new(@handles)->read(0);
+
+=head1 DESCRIPTION
+
+The C<IO::Select> package implements an object approach to the system C<select>
+function call. It allows the user to see what IO handles, see L<IO::Handle>,
+are ready for reading, writing or have an error condition pending.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HANDLES ] )
+
+The constructor creates a new object and optionally initialises it with a set
+of handles.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item add ( HANDLES )
+
+Add the list of handles to the C<IO::Select> object. It is these values that
+will be returned when an event occurs. C<IO::Select> keeps these values in a
+cache which is indexed by the C<fileno> of the handle, so if more than one
+handle with the same C<fileno> is specified then only the last one is cached.
+
+Each handle can be an C<IO::Handle> object, an integer or an array
+reference where the first element is a C<IO::Handle> or an integer.
+
+=item remove ( HANDLES )
+
+Remove all the given handles from the object. This method also works
+by the C<fileno> of the handles. So the exact handles that were added
+need not be passed, just handles that have an equivalent C<fileno>
+
+=item exists ( HANDLE )
+
+Returns a true value (actually the handle itself) if it is present.
+Returns undef otherwise.
+
+=item handles
+
+Return an array of all registered handles.
+
+=item can_read ( [ TIMEOUT ] )
+
+Return an array of handles that are ready for reading. C<TIMEOUT> is
+the maximum amount of time to wait before returning an empty list. If
+C<TIMEOUT> is not given and any handles are registered then the call
+will block.
+
+=item can_write ( [ TIMEOUT ] )
+
+Same as C<can_read> except check for handles that can be written to.
+
+=item has_error ( [ TIMEOUT ] )
+
+Same as C<can_read> except check for handles that have an error
+condition, for example EOF.
+
+=item count ()
+
+Returns the number of handles that the object will check for when
+one of the C<can_> methods is called or the object is passed to
+the C<select> static method.
+
+=item bits()
+
+Return the bit string suitable as argument to the core select() call.
+
+=item bits()
+
+Return the bit string suitable as argument to the core select() call.
+
+=item select ( READ, WRITE, ERROR [, TIMEOUT ] )
+
+C<select> is a static method, that is you call it with the package
+name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef>
+or C<IO::Select> objects. C<TIMEOUT> is optional and has the same
+effect as for the core select call.
+
+The result will be an array of 3 elements, each a reference to an array
+which will hold the handles that are ready for reading, writing and have
+error conditions respectively. Upon error an empty array is returned.
+
+=back
+
+=head1 EXAMPLE
+
+Here is a short example which shows how C<IO::Select> could be used
+to write a server which communicates with several sockets while also
+listening for more connections on a listen socket
+
+ use IO::Select;
+ use IO::Socket;
+
+ $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
+ $sel = new IO::Select( $lsn );
+
+ while(@ready = $sel->can_read) {
+ foreach $fh (@ready) {
+ if($fh == $lsn) {
+ # Create a new socket
+ $new = $lsn->accept;
+ $sel->add($new);
+ }
+ else {
+ # Process socket
+
+ # Maybe we have finished with the socket
+ $sel->remove($fh);
+ $fh->close;
+ }
+ }
+ }
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+use strict;
+use vars qw($VERSION @ISA);
+require Exporter;
+
+$VERSION = "1.10";
+
+@ISA = qw(Exporter); # This is only so we can do version checking
+
+sub VEC_BITS () {0}
+sub FD_COUNT () {1}
+sub FIRST_FD () {2}
+
+sub new
+{
+ my $self = shift;
+ my $type = ref($self) || $self;
+
+ my $vec = bless [undef,0], $type;
+
+ $vec->add(@_)
+ if @_;
+
+ $vec;
+}
+
+sub add
+{
+ shift->_update('add', @_);
+}
+
+
+sub remove
+{
+ shift->_update('remove', @_);
+}
+
+
+sub exists
+{
+ my $vec = shift;
+ $vec->[$vec->_fileno(shift) + FIRST_FD];
+}
+
+
+sub _fileno
+{
+ my($self, $f) = @_;
+ $f = $f->[0] if ref($f) eq 'ARRAY';
+ ($f =~ /^\d+$/) ? $f : fileno($f);
+}
+
+sub _update
+{
+ my $vec = shift;
+ my $add = shift eq 'add';
+
+ my $bits = $vec->[VEC_BITS];
+ $bits = '' unless defined $bits;
+
+ my $count = 0;
+ my $f;
+ foreach $f (@_)
+ {
+ my $fn = $vec->_fileno($f);
+ next unless defined $fn;
+ my $i = $fn + FIRST_FD;
+ if ($add) {
+ if (defined $vec->[$i]) {
+ $vec->[$i] = $f; # if array rest might be different, so we update
+ next;
+ }
+ $vec->[FD_COUNT]++;
+ vec($bits, $fn, 1) = 1;
+ $vec->[$i] = $f;
+ } else { # remove
+ next unless defined $vec->[$i];
+ $vec->[FD_COUNT]--;
+ vec($bits, $fn, 1) = 0;
+ $vec->[$i] = undef;
+ }
+ $count++;
+ }
+ $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
+ $count;
+}
+
+sub can_read
+{
+ my $vec = shift;
+ my $timeout = shift;
+ my $r = $vec->[VEC_BITS];
+
+ defined($r) && (select($r,undef,undef,$timeout) > 0)
+ ? handles($vec, $r)
+ : ();
+}
+
+sub can_write
+{
+ my $vec = shift;
+ my $timeout = shift;
+ my $w = $vec->[VEC_BITS];
+
+ defined($w) && (select(undef,$w,undef,$timeout) > 0)
+ ? handles($vec, $w)
+ : ();
+}
+
+sub has_error
+{
+ my $vec = shift;
+ my $timeout = shift;
+ my $e = $vec->[VEC_BITS];
+
+ defined($e) && (select(undef,undef,$e,$timeout) > 0)
+ ? handles($vec, $e)
+ : ();
+}
+
+sub count
+{
+ my $vec = shift;
+ $vec->[FD_COUNT];
+}
+
+sub bits
+{
+ my $vec = shift;
+ $vec->[VEC_BITS];
+}
+
+sub as_string # for debugging
+{
+ my $vec = shift;
+ my $str = ref($vec) . ": ";
+ my $bits = $vec->bits;
+ my $count = $vec->count;
+ $str .= defined($bits) ? unpack("b*", $bits) : "undef";
+ $str .= " $count";
+ my @handles = @$vec;
+ splice(@handles, 0, FIRST_FD);
+ for (@handles) {
+ $str .= " " . (defined($_) ? "$_" : "-");
+ }
+ $str;
+}
+
+sub _max
+{
+ my($a,$b,$c) = @_;
+ $a > $b
+ ? $a > $c
+ ? $a
+ : $c
+ : $b > $c
+ ? $b
+ : $c;
+}
+
+sub select
+{
+ shift
+ if defined $_[0] && !ref($_[0]);
+
+ my($r,$w,$e,$t) = @_;
+ my @result = ();
+
+ my $rb = defined $r ? $r->[VEC_BITS] : undef;
+ my $wb = defined $w ? $w->[VEC_BITS] : undef;
+ my $eb = defined $e ? $e->[VEC_BITS] : undef;
+
+ if(select($rb,$wb,$eb,$t) > 0)
+ {
+ my @r = ();
+ my @w = ();
+ my @e = ();
+ my $i = _max(defined $r ? scalar(@$r)-1 : 0,
+ defined $w ? scalar(@$w)-1 : 0,
+ defined $e ? scalar(@$e)-1 : 0);
+
+ for( ; $i >= FIRST_FD ; $i--)
+ {
+ my $j = $i - FIRST_FD;
+ push(@r, $r->[$i])
+ if defined $rb && defined $r->[$i] && vec($rb, $j, 1);
+ push(@w, $w->[$i])
+ if defined $wb && defined $w->[$i] && vec($wb, $j, 1);
+ push(@e, $e->[$i])
+ if defined $eb && defined $e->[$i] && vec($eb, $j, 1);
+ }
+
+ @result = (\@r, \@w, \@e);
+ }
+ @result;
+}
+
+
+sub handles
+{
+ my $vec = shift;
+ my $bits = shift;
+ my @h = ();
+ my $i;
+ my $max = scalar(@$vec) - 1;
+
+ for ($i = FIRST_FD; $i <= $max; $i++)
+ {
+ next unless defined $vec->[$i];
+ push(@h, $vec->[$i])
+ if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
+ }
+
+ @h;
+}
+
+1;
diff --git a/contrib/perl5/ext/IO/lib/IO/Socket.pm b/contrib/perl5/ext/IO/lib/IO/Socket.pm
new file mode 100644
index 000000000000..406f74d2ffe6
--- /dev/null
+++ b/contrib/perl5/ext/IO/lib/IO/Socket.pm
@@ -0,0 +1,728 @@
+# IO::Socket.pm
+#
+# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Socket;
+
+=head1 NAME
+
+IO::Socket - Object interface to socket communications
+
+=head1 SYNOPSIS
+
+ use IO::Socket;
+
+=head1 DESCRIPTION
+
+C<IO::Socket> provides an object interface to creating and using sockets. It
+is built upon the L<IO::Handle> interface and inherits all the methods defined
+by L<IO::Handle>.
+
+C<IO::Socket> only defines methods for those operations which are common to all
+types of socket. Operations which are specified to a socket in a particular
+domain have methods defined in sub classes of C<IO::Socket>
+
+C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ARGS] )
+
+Creates an C<IO::Socket>, which is a reference to a
+newly created symbol (see the C<Symbol> package). C<new>
+optionally takes arguments, these arguments are in key-value pairs.
+C<new> only looks for one key C<Domain> which tells new which domain
+the socket will be in. All other arguments will be passed to the
+configuration method of the package for that domain, See below.
+
+C<IO::Socket>s will be in autoflush mode after creation. Note that
+versions of IO::Socket prior to 1.1603 (as shipped with Perl 5.004_04)
+did not do this. So if you need backward compatibility, you should
+set autoflush explicitly.
+
+=back
+
+=head1 METHODS
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Socket> methods, which are just front ends for the
+corresponding built-in functions:
+
+ socket
+ socketpair
+ bind
+ listen
+ accept
+ send
+ recv
+ peername (getpeername)
+ sockname (getsockname)
+
+Some methods take slightly different arguments to those defined in L<perlfunc>
+in attempt to make the interface more flexible. These are
+
+=over 4
+
+=item accept([PKG])
+
+perform the system call C<accept> on the socket and return a new object. The
+new object will be created in the same class as the listen socket, unless
+C<PKG> is specified. This object can be used to communicate with the client
+that was trying to connect. In a scalar context the new socket is returned,
+or undef upon failure. In an array context a two-element array is returned
+containing the new socket and the peer address, the list will
+be empty upon failure.
+
+Additional methods that are provided are
+
+=item timeout([VAL])
+
+Set or get the timeout value associated with this socket. If called without
+any arguments then the current setting is returned. If called with an argument
+the current setting is changed and the previous value returned.
+
+=item sockopt(OPT [, VAL])
+
+Unified method to both set and get options in the SOL_SOCKET level. If called
+with one argument then getsockopt is called, otherwise setsockopt is called.
+
+=item sockdomain
+
+Returns the numerical number for the socket domain type. For example, for
+a AF_INET socket the value of &AF_INET will be returned.
+
+=item socktype
+
+Returns the numerical number for the socket type. For example, for
+a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
+
+=item protocol
+
+Returns the numerical number for the protocol being used on the socket, if
+known. If the protocol is unknown, as with an AF_UNIX socket, zero
+is returned.
+
+=back
+
+=cut
+
+
+require 5.000;
+
+use Config;
+use IO::Handle;
+use Socket 1.3;
+use Carp;
+use strict;
+use vars qw(@ISA $VERSION);
+use Exporter;
+
+@ISA = qw(IO::Handle);
+
+$VERSION = "1.1603";
+
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+ Exporter::export 'Socket', $callpkg, @_;
+}
+
+sub new {
+ my($class,%arg) = @_;
+ my $fh = $class->SUPER::new();
+ $fh->autoflush;
+
+ ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
+
+ return scalar(%arg) ? $fh->configure(\%arg)
+ : $fh;
+}
+
+my @domain2pkg = ();
+
+sub register_domain {
+ my($p,$d) = @_;
+ $domain2pkg[$d] = $p;
+}
+
+sub configure {
+ my($fh,$arg) = @_;
+ my $domain = delete $arg->{Domain};
+
+ croak 'IO::Socket: Cannot configure a generic socket'
+ unless defined $domain;
+
+ croak "IO::Socket: Unsupported socket domain"
+ unless defined $domain2pkg[$domain];
+
+ croak "IO::Socket: Cannot configure socket in domain '$domain'"
+ unless ref($fh) eq "IO::Socket";
+
+ bless($fh, $domain2pkg[$domain]);
+ $fh->configure($arg);
+}
+
+sub socket {
+ @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
+ my($fh,$domain,$type,$protocol) = @_;
+
+ socket($fh,$domain,$type,$protocol) or
+ return undef;
+
+ ${*$fh}{'io_socket_domain'} = $domain;
+ ${*$fh}{'io_socket_type'} = $type;
+ ${*$fh}{'io_socket_proto'} = $protocol;
+
+ $fh;
+}
+
+sub socketpair {
+ @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
+ my($class,$domain,$type,$protocol) = @_;
+ my $fh1 = $class->new();
+ my $fh2 = $class->new();
+
+ socketpair($fh1,$fh2,$domain,$type,$protocol) or
+ return ();
+
+ ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type;
+ ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol;
+
+ ($fh1,$fh2);
+}
+
+sub connect {
+ @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
+ my $fh = shift;
+ my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+ my $timeout = ${*$fh}{'io_socket_timeout'};
+ local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
+ : $SIG{ALRM} || 'DEFAULT';
+
+ eval {
+ croak 'connect: Bad address'
+ if(@_ == 2 && !defined $_[1]);
+
+ if($timeout) {
+ defined $Config{d_alarm} && defined alarm($timeout) or
+ $timeout = 0;
+ }
+
+ my $ok = connect($fh, $addr);
+
+ alarm(0)
+ if($timeout);
+
+ croak "connect: timeout"
+ unless defined $fh;
+
+ undef $fh unless $ok;
+ };
+
+ $fh;
+}
+
+sub bind {
+ @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
+ my $fh = shift;
+ my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+
+ return bind($fh, $addr) ? $fh
+ : undef;
+}
+
+sub listen {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
+ my($fh,$queue) = @_;
+ $queue = 5
+ unless $queue && $queue > 0;
+
+ return listen($fh, $queue) ? $fh
+ : undef;
+}
+
+sub accept {
+ @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
+ my $fh = shift;
+ my $pkg = shift || $fh;
+ my $timeout = ${*$fh}{'io_socket_timeout'};
+ my $new = $pkg->new(Timeout => $timeout);
+ my $peer = undef;
+
+ eval {
+ if($timeout) {
+ my $fdset = "";
+ vec($fdset, $fh->fileno,1) = 1;
+ croak "accept: timeout"
+ unless select($fdset,undef,undef,$timeout);
+ }
+ $peer = accept($new,$fh);
+ };
+
+ return wantarray ? defined $peer ? ($new, $peer)
+ : ()
+ : defined $peer ? $new
+ : undef;
+}
+
+sub sockname {
+ @_ == 1 or croak 'usage: $fh->sockname()';
+ getsockname($_[0]);
+}
+
+sub peername {
+ @_ == 1 or croak 'usage: $fh->peername()';
+ my($fh) = @_;
+ getpeername($fh)
+ || ${*$fh}{'io_socket_peername'}
+ || undef;
+}
+
+sub send {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
+ my $fh = $_[0];
+ my $flags = $_[2] || 0;
+ my $peer = $_[3] || $fh->peername;
+
+ croak 'send: Cannot determine peer address'
+ unless($peer);
+
+ my $r = defined(getpeername($fh))
+ ? send($fh, $_[1], $flags)
+ : send($fh, $_[1], $flags, $peer);
+
+ # remember who we send to, if it was sucessful
+ ${*$fh}{'io_socket_peername'} = $peer
+ if(@_ == 4 && defined $r);
+
+ $r;
+}
+
+sub recv {
+ @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
+ my $sock = $_[0];
+ my $len = $_[2];
+ my $flags = $_[3] || 0;
+
+ # remember who we recv'd from
+ ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
+}
+
+
+sub setsockopt {
+ @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
+ setsockopt($_[0],$_[1],$_[2],$_[3]);
+}
+
+my $intsize = length(pack("i",0));
+
+sub getsockopt {
+ @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
+ my $r = getsockopt($_[0],$_[1],$_[2]);
+ # Just a guess
+ $r = unpack("i", $r)
+ if(defined $r && length($r) == $intsize);
+ $r;
+}
+
+sub sockopt {
+ my $fh = shift;
+ @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
+ : $fh->setsockopt(SOL_SOCKET,@_);
+}
+
+sub timeout {
+ @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
+ my($fh,$val) = @_;
+ my $r = ${*$fh}{'io_socket_timeout'} || undef;
+
+ ${*$fh}{'io_socket_timeout'} = 0 + $val
+ if(@_ == 2);
+
+ $r;
+}
+
+sub sockdomain {
+ @_ == 1 or croak 'usage: $fh->sockdomain()';
+ my $fh = shift;
+ ${*$fh}{'io_socket_domain'};
+}
+
+sub socktype {
+ @_ == 1 or croak 'usage: $fh->socktype()';
+ my $fh = shift;
+ ${*$fh}{'io_socket_type'}
+}
+
+sub protocol {
+ @_ == 1 or croak 'usage: $fh->protocol()';
+ my($fh) = @_;
+ ${*$fh}{'io_socket_protocol'};
+}
+
+=head1 SUB-CLASSES
+
+=cut
+
+##
+## AF_INET
+##
+
+package IO::Socket::INET;
+
+use strict;
+use vars qw(@ISA);
+use Socket;
+use Carp;
+use Exporter;
+
+@ISA = qw(IO::Socket);
+
+IO::Socket::INET->register_domain( AF_INET );
+
+my %socket_type = ( tcp => SOCK_STREAM,
+ udp => SOCK_DGRAM,
+ icmp => SOCK_RAW,
+ );
+
+=head2 IO::Socket::INET
+
+C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
+and some related methods. The constructor can take the following options
+
+ PeerAddr Remote host address <hostname>[:<port>]
+ PeerPort Remote port or service <service>[(<no>)] | <no>
+ LocalAddr Local host bind address hostname[:port]
+ LocalPort Local host bind port <service>[(<no>)] | <no>
+ Proto Protocol name (or number) "tcp" | "udp" | ...
+ Type Socket type SOCK_STREAM | SOCK_DGRAM | ...
+ Listen Queue size for listen
+ Reuse Set SO_REUSEADDR before binding
+ Timeout Timeout value for various operations
+
+
+If C<Listen> is defined then a listen socket is created, else if the
+socket type, which is derived from the protocol, is SOCK_STREAM then
+connect() is called.
+
+The C<PeerAddr> can be a hostname or the IP-address on the
+"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic
+service name. The service name might be followed by a number in
+parenthesis which is used if the service is not known by the system.
+The C<PeerPort> specification can also be embedded in the C<PeerAddr>
+by preceding it with a ":".
+
+If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
+then the constructor will try to derive C<Proto> from the service
+name. As a last resort C<Proto> "tcp" is assumed. The C<Type>
+parameter will be deduced from C<Proto> if not specified.
+
+If the constructor is only passed a single argument, it is assumed to
+be a C<PeerAddr> specification.
+
+Examples:
+
+ $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
+ PeerPort => 'http(80)',
+ Proto => 'tcp');
+
+ $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
+
+ $sock = IO::Socket::INET->new(Listen => 5,
+ LocalAddr => 'localhost',
+ LocalPort => 9000,
+ Proto => 'tcp');
+
+ $sock = IO::Socket::INET->new('127.0.0.1:25');
+
+
+=head2 METHODS
+
+=over 4
+
+=item sockaddr ()
+
+Return the address part of the sockaddr structure for the socket
+
+=item sockport ()
+
+Return the port number that the socket is using on the local host
+
+=item sockhost ()
+
+Return the address part of the sockaddr structure for the socket in a
+text form xx.xx.xx.xx
+
+=item peeraddr ()
+
+Return the address part of the sockaddr structure for the socket on
+the peer host
+
+=item peerport ()
+
+Return the port number for the socket on the peer host.
+
+=item peerhost ()
+
+Return the address part of the sockaddr structure for the socket on the
+peer host in a text form xx.xx.xx.xx
+
+=back
+
+=cut
+
+sub new
+{
+ my $class = shift;
+ unshift(@_, "PeerAddr") if @_ == 1;
+ return $class->SUPER::new(@_);
+}
+
+sub _sock_info {
+ my($addr,$port,$proto) = @_;
+ my @proto = ();
+ my @serv = ();
+
+ $port = $1
+ if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
+
+ if(defined $proto) {
+ @proto = $proto =~ m,\D, ? getprotobyname($proto)
+ : getprotobynumber($proto);
+
+ $proto = $proto[2] || undef;
+ }
+
+ if(defined $port) {
+ $port =~ s,\((\d+)\)$,,;
+
+ my $defport = $1 || undef;
+ my $pnum = ($port =~ m,^(\d+)$,)[0];
+
+ @serv= getservbyname($port, $proto[0] || "")
+ if($port =~ m,\D,);
+
+ $port = $pnum || $serv[2] || $defport || undef;
+
+ $proto = (getprotobyname($serv[3]))[2] || undef
+ if @serv && !$proto;
+ }
+
+ return ($addr || undef,
+ $port || undef,
+ $proto || undef
+ );
+}
+
+sub _error {
+ my $fh = shift;
+ $@ = join("",ref($fh),": ",@_);
+ carp $@ if $^W;
+ close($fh)
+ if(defined fileno($fh));
+ return undef;
+}
+
+sub configure {
+ my($fh,$arg) = @_;
+ my($lport,$rport,$laddr,$raddr,$proto,$type);
+
+
+ ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
+ $arg->{LocalPort},
+ $arg->{Proto});
+
+ $laddr = defined $laddr ? inet_aton($laddr)
+ : INADDR_ANY;
+
+ return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'")
+ unless(defined $laddr);
+
+ unless(exists $arg->{Listen}) {
+ ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
+ $arg->{PeerPort},
+ $proto);
+ }
+
+ if(defined $raddr) {
+ $raddr = inet_aton($raddr);
+ return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'")
+ unless(defined $raddr);
+ }
+
+ $proto ||= (getprotobyname "tcp")[2];
+ return _error($fh,'Cannot determine protocol')
+ unless($proto);
+
+ my $pname = (getprotobynumber($proto))[0];
+ $type = $arg->{Type} || $socket_type{$pname};
+
+ $fh->socket(AF_INET, $type, $proto) or
+ return _error($fh,"$!");
+
+ if ($arg->{Reuse}) {
+ $fh->sockopt(SO_REUSEADDR,1) or
+ return _error($fh);
+ }
+
+ $fh->bind($lport || 0, $laddr) or
+ return _error($fh,"$!");
+
+ if(exists $arg->{Listen}) {
+ $fh->listen($arg->{Listen} || 5) or
+ return _error($fh,"$!");
+ }
+ else {
+ return _error($fh,'Cannot determine remote port')
+ unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
+
+ if($type == SOCK_STREAM || defined $raddr) {
+ return _error($fh,'Bad peer address')
+ unless(defined $raddr);
+
+ $fh->connect($rport,$raddr) or
+ return _error($fh,"$!");
+ }
+ }
+
+ $fh;
+}
+
+sub sockaddr {
+ @_ == 1 or croak 'usage: $fh->sockaddr()';
+ my($fh) = @_;
+ (sockaddr_in($fh->sockname))[1];
+}
+
+sub sockport {
+ @_ == 1 or croak 'usage: $fh->sockport()';
+ my($fh) = @_;
+ (sockaddr_in($fh->sockname))[0];
+}
+
+sub sockhost {
+ @_ == 1 or croak 'usage: $fh->sockhost()';
+ my($fh) = @_;
+ inet_ntoa($fh->sockaddr);
+}
+
+sub peeraddr {
+ @_ == 1 or croak 'usage: $fh->peeraddr()';
+ my($fh) = @_;
+ (sockaddr_in($fh->peername))[1];
+}
+
+sub peerport {
+ @_ == 1 or croak 'usage: $fh->peerport()';
+ my($fh) = @_;
+ (sockaddr_in($fh->peername))[0];
+}
+
+sub peerhost {
+ @_ == 1 or croak 'usage: $fh->peerhost()';
+ my($fh) = @_;
+ inet_ntoa($fh->peeraddr);
+}
+
+##
+## AF_UNIX
+##
+
+package IO::Socket::UNIX;
+
+use strict;
+use vars qw(@ISA $VERSION);
+use Socket;
+use Carp;
+use Exporter;
+
+@ISA = qw(IO::Socket);
+
+IO::Socket::UNIX->register_domain( AF_UNIX );
+
+=head2 IO::Socket::UNIX
+
+C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
+and some related methods. The constructor can take the following options
+
+ Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
+ Local Path to local fifo
+ Peer Path to peer fifo
+ Listen Create a listen socket
+
+=head2 METHODS
+
+=over 4
+
+=item hostpath()
+
+Returns the pathname to the fifo at the local end
+
+=item peerpath()
+
+Returns the pathanme to the fifo at the peer end
+
+=back
+
+=cut
+
+sub configure {
+ my($fh,$arg) = @_;
+ my($bport,$cport);
+
+ my $type = $arg->{Type} || SOCK_STREAM;
+
+ $fh->socket(AF_UNIX, $type, 0) or
+ return undef;
+
+ if(exists $arg->{Local}) {
+ my $addr = sockaddr_un($arg->{Local});
+ $fh->bind($addr) or
+ return undef;
+ }
+ if(exists $arg->{Listen}) {
+ $fh->listen($arg->{Listen} || 5) or
+ return undef;
+ }
+ elsif(exists $arg->{Peer}) {
+ my $addr = sockaddr_un($arg->{Peer});
+ $fh->connect($addr) or
+ return undef;
+ }
+
+ $fh;
+}
+
+sub hostpath {
+ @_ == 1 or croak 'usage: $fh->hostpath()';
+ my $n = $_[0]->sockname || return undef;
+ (sockaddr_un($n))[0];
+}
+
+sub peerpath {
+ @_ == 1 or croak 'usage: $fh->peerpath()';
+ my $n = $_[0]->peername || return undef;
+ (sockaddr_un($n))[0];
+}
+
+=head1 SEE ALSO
+
+L<Socket>, L<IO::Handle>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1996 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+1; # Keep require happy
diff --git a/contrib/perl5/ext/IPC/SysV/ChangeLog b/contrib/perl5/ext/IPC/SysV/ChangeLog
new file mode 100644
index 000000000000..fff95bec4318
--- /dev/null
+++ b/contrib/perl5/ext/IPC/SysV/ChangeLog
@@ -0,0 +1,28 @@
+Fri Jul 3 15:06:40 1998 Jarkko Hietaniemi <jhi@iki.fi>
+
+ - Integrated IPC::SysV 1.03 to Perl 5.004_69.
+
+Change 142 on 1998/05/31 by <gbarr@pobox.com> (Graham Barr)
+
+ - Changed SHMLBA from a constSUB to an XS sub as on some systems it is not
+ a constant
+ - Added a missing MODULE line to SysV.xs so ftok is defined in IPC::SysV
+
+Change 138 on 1998/05/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Applied patch from Jarkko Hietaniemi to add constats for UNICOS
+
+ Reduced size of XS object by changing constant sub definition
+ into a loop
+
+ Updated POD to include ftok()
+
+Change 135 on 1998/05/18 by <gbarr@pobox.com> (Graham Barr)
+
+ applied changes from Jarkko Hietaniemi <jhi@iki.fi> to add
+ new constants and ftok
+
+ fixed to compile with >5.004_50
+
+ surrounded newCONSTSUB with #ifndef as perl now defines this itself
+
diff --git a/contrib/perl5/ext/IPC/SysV/MANIFEST b/contrib/perl5/ext/IPC/SysV/MANIFEST
new file mode 100644
index 000000000000..4b2aa00daf1f
--- /dev/null
+++ b/contrib/perl5/ext/IPC/SysV/MANIFEST
@@ -0,0 +1,10 @@
+MANIFEST
+Makefile.PL
+Msg.pm
+README
+Semaphore.pm
+SysV.pm
+SysV.xs
+t/msg.t
+t/sem.t
+ChangeLog
diff --git a/contrib/perl5/ext/IPC/SysV/Makefile.PL b/contrib/perl5/ext/IPC/SysV/Makefile.PL
new file mode 100644
index 000000000000..c8e320f03013
--- /dev/null
+++ b/contrib/perl5/ext/IPC/SysV/Makefile.PL
@@ -0,0 +1,36 @@
+# This -*- perl -*- script makes the Makefile
+# $Id: Makefile.PL,v 1.3 1997/03/04 09:21:12 gbarr Exp $
+
+require 5.002;
+use ExtUtils::MakeMaker;
+
+#--- MY package
+
+sub MY::libscan
+{
+ my($self,$path) = @_;
+
+ return ''
+ if($path =~ m:/(RCS|CVS|SCCS)/: ||
+ $path =~ m:[~%]$: ||
+ $path =~ m:\.(orig|rej)$:
+ );
+
+ $path;
+}
+
+WriteMakefile(
+ VERSION_FROM => "SysV.pm",
+ NAME => "IPC::SysV",
+
+ 'dist' => {COMPRESS => 'gzip -9f',
+ SUFFIX => 'gz',
+ DIST_DEFAULT => 'all tardist',
+ },
+
+ 'clean' => {FILES => join(" ",
+ map { "$_ */$_ */*/$_" }
+ qw(*% *.html *.b[ac]k *.old *.orig))
+ },
+ 'macro' => { INSTALLDIRS => 'perl' },
+);
diff --git a/contrib/perl5/ext/IPC/SysV/Msg.pm b/contrib/perl5/ext/IPC/SysV/Msg.pm
new file mode 100644
index 000000000000..93d2ae16ee6f
--- /dev/null
+++ b/contrib/perl5/ext/IPC/SysV/Msg.pm
@@ -0,0 +1,223 @@
+# IPC::Msg.pm
+#
+# Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IPC::Msg;
+
+use IPC::SysV qw(IPC_STAT IPC_SET IPC_RMID);
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+$VERSION = "1.00";
+
+{
+ package IPC::Msg::stat;
+
+ use Class::Struct qw(struct);
+
+ struct 'IPC::Msg::stat' => [
+ uid => '$',
+ gid => '$',
+ cuid => '$',
+ cgid => '$',
+ mode => '$',
+ qnum => '$',
+ qbytes => '$',
+ lspid => '$',
+ lrpid => '$',
+ stime => '$',
+ rtime => '$',
+ ctime => '$',
+ ];
+}
+
+sub new {
+ @_ == 3 || croak 'new IPC::Msg ( KEY , FLAGS )';
+ my $class = shift;
+
+ my $id = msgget($_[0],$_[1]);
+
+ defined($id)
+ ? bless \$id, $class
+ : undef;
+}
+
+sub id {
+ my $self = shift;
+ $$self;
+}
+
+sub stat {
+ my $self = shift;
+ my $data = "";
+ msgctl($$self,IPC_STAT,$data) or
+ return undef;
+ IPC::Msg::stat->new->unpack($data);
+}
+
+sub set {
+ my $self = shift;
+ my $ds;
+
+ if(@_ == 1) {
+ $ds = shift;
+ }
+ else {
+ croak 'Bad arg count' if @_ % 2;
+ my %arg = @_;
+ my $ds = $self->stat
+ or return undef;
+ my($key,$val);
+ $ds->$key($val)
+ while(($key,$val) = each %arg);
+ }
+
+ msgctl($$self,IPC_SET,$ds->pack);
+}
+
+sub remove {
+ my $self = shift;
+ (msgctl($$self,IPC_RMID,0), undef $$self)[0];
+}
+
+sub rcv {
+ @_ == 5 || croak '$msg->rcv( BUF, LEN, TYPE, FLAGS )';
+ my $self = shift;
+ my $buf = "";
+ msgrcv($$self,$buf,$_[1],$_[2] || 0, $_[3] || 0) or
+ return;
+ my $type;
+ ($type,$_[0]) = unpack("L a*",$buf);
+ $type;
+}
+
+sub snd {
+ @_ == 4 || croak '$msg->snd( TYPE, BUF, FLAGS )';
+ my $self = shift;
+ msgsnd($$self,pack("L a*",$_[0],$_[1]), $_[2] || 0);
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+IPC::Msg - SysV Msg IPC object class
+
+=head1 SYNOPSIS
+
+ use IPC::SysV qw(IPC_PRIVATE S_IRWXU S_IRWXG S_IRWXO);
+ use IPC::Msg;
+
+ $msg = new IPC::Msg(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO);
+
+ $msg->snd(pack("L a*",$msgtype,$msg));
+
+ $msg->rcv($buf,256);
+
+ $ds = $msg->stat;
+
+ $msg->remove;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item new ( KEY , FLAGS )
+
+Creates a new message queue associated with C<KEY>. A new queue is
+created if
+
+=over 4
+
+=item *
+
+C<KEY> is equal to C<IPC_PRIVATE>
+
+=item *
+
+C<KEY> does not already have a message queue
+associated with it, and C<I<FLAGS> & IPC_CREAT> is true.
+
+=back
+
+On creation of a new message queue C<FLAGS> is used to set the
+permissions.
+
+=item id
+
+Returns the system message queue identifier.
+
+=item rcv ( BUF, LEN [, TYPE [, FLAGS ]] )
+
+Read a message from the queue. Returns the type of the message read. See
+L<msgrcv>
+
+=item remove
+
+Remove and destroy the message queue from the system.
+
+=item set ( STAT )
+
+=item set ( NAME => VALUE [, NAME => VALUE ...] )
+
+C<set> will set the following values of the C<stat> structure associated
+with the message queue.
+
+ uid
+ gid
+ mode (oly the permission bits)
+ qbytes
+
+C<set> accepts either a stat object, as returned by the C<stat> method,
+or a list of I<name>-I<value> pairs.
+
+=item snd ( TYPE, MSG [, FLAGS ] )
+
+Place a message on the queue with the data from C<MSG> and with type C<TYPE>.
+See L<msgsnd>.
+
+=item stat
+
+Returns an object of type C<IPC::Msg::stat> which is a sub-class of
+C<Class::Struct>. It provides the following fields. For a description
+of these fields see you system documentation.
+
+ uid
+ gid
+ cuid
+ cgid
+ mode
+ qnum
+ qbytes
+ lspid
+ lrpid
+ stime
+ rtime
+ ctime
+
+=back
+
+=head1 SEE ALSO
+
+L<IPC::SysV> L<Class::Struct>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
diff --git a/contrib/perl5/ext/IPC/SysV/README b/contrib/perl5/ext/IPC/SysV/README
new file mode 100644
index 000000000000..d412c4c712df
--- /dev/null
+++ b/contrib/perl5/ext/IPC/SysV/README
@@ -0,0 +1,20 @@
+Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This package is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+The SysV-IPC contains three packages
+
+ IPC::Semaphore
+ - Provides an object interface to using SysV IPC semaphores
+
+ IPC::Msg
+ - Provides an object interface to using SysV IPC messages
+
+ IPC::SysV
+ - Provides the constants required to use the system SysV IPC calls.
+
+Currently there is not object support for SysV shared memory, but
+SysV::SharedMem is a project for the future.
+
+Share and enjoy!
+
diff --git a/contrib/perl5/ext/IPC/SysV/Semaphore.pm b/contrib/perl5/ext/IPC/SysV/Semaphore.pm
new file mode 100644
index 000000000000..464eb0bc1929
--- /dev/null
+++ b/contrib/perl5/ext/IPC/SysV/Semaphore.pm
@@ -0,0 +1,297 @@
+# IPC::Semaphore
+#
+# Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IPC::Semaphore;
+
+use IPC::SysV qw(GETNCNT GETZCNT GETVAL SETVAL GETPID GETALL SETALL
+ IPC_STAT IPC_SET IPC_RMID);
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+$VERSION = "1.00";
+
+{
+ package IPC::Semaphore::stat;
+
+ use Class::Struct qw(struct);
+
+ struct 'IPC::Semaphore::stat' => [
+ uid => '$',
+ gid => '$',
+ cuid => '$',
+ cgid => '$',
+ mode => '$',
+ ctime => '$',
+ otime => '$',
+ nsems => '$',
+ ];
+}
+
+sub new {
+ @_ == 4 || croak 'new ' . __PACKAGE__ . '( KEY, NSEMS, FLAGS )';
+ my $class = shift;
+
+ my $id = semget($_[0],$_[1],$_[2]);
+
+ defined($id)
+ ? bless \$id, $class
+ : undef;
+}
+
+sub id {
+ my $self = shift;
+ $$self;
+}
+
+sub remove {
+ my $self = shift;
+ (semctl($$self,0,IPC_RMID,0), undef $$self)[0];
+}
+
+sub getncnt {
+ @_ == 2 || croak '$sem->getncnt( SEM )';
+ my $self = shift;
+ my $sem = shift;
+ my $v = semctl($$self,$sem,GETNCNT,0);
+ $v ? 0 + $v : undef;
+}
+
+sub getzcnt {
+ @_ == 2 || croak '$sem->getzcnt( SEM )';
+ my $self = shift;
+ my $sem = shift;
+ my $v = semctl($$self,$sem,GETZCNT,0);
+ $v ? 0 + $v : undef;
+}
+
+sub getval {
+ @_ == 2 || croak '$sem->getval( SEM )';
+ my $self = shift;
+ my $sem = shift;
+ my $v = semctl($$self,$sem,GETVAL,0);
+ $v ? 0 + $v : undef;
+}
+
+sub getpid {
+ @_ == 2 || croak '$sem->getpid( SEM )';
+ my $self = shift;
+ my $sem = shift;
+ my $v = semctl($$self,$sem,GETPID,0);
+ $v ? 0 + $v : undef;
+}
+
+sub op {
+ @_ >= 4 || croak '$sem->op( OPLIST )';
+ my $self = shift;
+ croak 'Bad arg count' if @_ % 3;
+ my $data = pack("s*",@_);
+ semop($$self,$data);
+}
+
+sub stat {
+ my $self = shift;
+ my $data = "";
+ semctl($$self,0,IPC_STAT,$data)
+ or return undef;
+ IPC::Semaphore::stat->new->unpack($data);
+}
+
+sub set {
+ my $self = shift;
+ my $ds;
+
+ if(@_ == 1) {
+ $ds = shift;
+ }
+ else {
+ croak 'Bad arg count' if @_ % 2;
+ my %arg = @_;
+ my $ds = $self->stat
+ or return undef;
+ my($key,$val);
+ $ds->$key($val)
+ while(($key,$val) = each %arg);
+ }
+
+ my $v = semctl($$self,0,IPC_SET,$ds->pack);
+ $v ? 0 + $v : undef;
+}
+
+sub getall {
+ my $self = shift;
+ my $data = "";
+ semctl($$self,0,GETALL,$data)
+ or return ();
+ (unpack("s*",$data));
+}
+
+sub setall {
+ my $self = shift;
+ my $data = pack("s*",@_);
+ semctl($$self,0,SETALL,$data);
+}
+
+sub setval {
+ @_ == 3 || croak '$sem->setval( SEM, VAL )';
+ my $self = shift;
+ my $sem = shift;
+ my $val = shift;
+ semctl($$self,$sem,SETVAL,$val);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IPC::Semaphore - SysV Semaphore IPC object class
+
+=head1 SYNOPSIS
+
+ use IPC::SysV qw(IPC_PRIVATE S_IRWXU IPC_CREAT);
+ use IPC::Semaphore;
+
+ $sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | IPC_CREAT);
+
+ $sem->setall( (0) x 10);
+
+ @sem = $sem->getall;
+
+ $ncnt = $sem->getncnt;
+
+ $zcnt = $sem->getzcnt;
+
+ $ds = $sem->stat;
+
+ $sem->remove;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item new ( KEY , NSEMS , FLAGS )
+
+Create a new semaphore set associated with C<KEY>. C<NSEMS> is the number
+of semaphores in the set. A new set is created if
+
+=over 4
+
+=item *
+
+C<KEY> is equal to C<IPC_PRIVATE>
+
+=item *
+
+C<KEY> does not already have a semaphore identifier
+associated with it, and C<I<FLAGS> & IPC_CREAT> is true.
+
+=back
+
+On creation of a new semaphore set C<FLAGS> is used to set the
+permissions.
+
+=item getall
+
+Returns the values of the semaphore set as an array.
+
+=item getncnt ( SEM )
+
+Returns the number of processed waiting for the semaphore C<SEM> to
+become greater than it's current value
+
+=item getpid ( SEM )
+
+Returns the process id of the last process that performed an operation
+on the semaphore C<SEM>.
+
+=item getval ( SEM )
+
+Returns the current value of the semaphore C<SEM>.
+
+=item getzcnt ( SEM )
+
+Returns the number of processed waiting for the semaphore C<SEM> to
+become zero.
+
+=item id
+
+Returns the system identifier for the semaphore set.
+
+=item op ( OPLIST )
+
+C<OPLIST> is a list of operations to pass to C<semop>. C<OPLIST> is
+a concatenation of smaller lists, each which has three values. The
+first is the semaphore number, the second is the operation and the last
+is a flags value. See L<semop> for more details. For example
+
+ $sem->op(
+ 0, -1, IPC_NOWAIT,
+ 1, 1, IPC_NOWAIT
+ );
+
+=item remove
+
+Remove and destroy the semaphore set from the system.
+
+=item set ( STAT )
+
+=item set ( NAME => VALUE [, NAME => VALUE ...] )
+
+C<set> will set the following values of the C<stat> structure associated
+with the semaphore set.
+
+ uid
+ gid
+ mode (oly the permission bits)
+
+C<set> accepts either a stat object, as returned by the C<stat> method,
+or a list of I<name>-I<value> pairs.
+
+=item setall ( VALUES )
+
+Sets all values in the semaphore set to those given on the C<VALUES> list.
+C<VALUES> must contain the correct number of values.
+
+=item setval ( N , VALUE )
+
+Set the C<N>th value in the semaphore set to C<VALUE>
+
+=item stat
+
+Returns an object of type C<IPC::Semaphore::stat> which is a sub-class of
+C<Class::Struct>. It provides the following fields. For a description
+of these fields see you system documentation.
+
+ uid
+ gid
+ cuid
+ cgid
+ mode
+ ctime
+ otime
+ nsems
+
+=back
+
+=head1 SEE ALSO
+
+L<IPC::SysV> L<Class::Struct> L<semget> L<semctl> L<semop>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/contrib/perl5/ext/IPC/SysV/SysV.pm b/contrib/perl5/ext/IPC/SysV/SysV.pm
new file mode 100644
index 000000000000..eb245937aa41
--- /dev/null
+++ b/contrib/perl5/ext/IPC/SysV/SysV.pm
@@ -0,0 +1,98 @@
+# IPC::SysV.pm
+#
+# Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IPC::SysV;
+
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
+use Carp;
+use Config;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+$VERSION = "1.03";
+
+@EXPORT_OK = qw(
+ GETALL GETNCNT GETPID GETVAL GETZCNT
+
+ IPC_ALLOC IPC_CREAT IPC_EXCL IPC_GETACL IPC_LOCKED IPC_M
+ IPC_NOERROR IPC_NOWAIT IPC_PRIVATE IPC_R IPC_RMID IPC_SET
+ IPC_SETACL IPC_SETLABEL IPC_STAT IPC_W IPC_WANTED
+
+ MSG_FWAIT MSG_LOCKED MSG_MWAIT MSG_NOERROR MSG_QWAIT
+ MSG_R MSG_RWAIT MSG_STAT MSG_W MSG_WWAIT
+
+ SEM_A SEM_ALLOC SEM_DEST SEM_ERR SEM_ORDER SEM_R SEM_UNDO
+
+ SETALL SETVAL
+
+ SHMLBA
+
+ SHM_A SHM_CLEAR SHM_COPY SHM_DCACHE SHM_DEST SHM_ECACHE
+ SHM_FMAP SHM_ICACHE SHM_INIT SHM_LOCK SHM_LOCKED SHM_MAP
+ SHM_NOSWAP SHM_R SHM_RDONLY SHM_REMOVED SHM_RND SHM_SHARE_MMU
+ SHM_SHATTR SHM_SIZE SHM_UNLOCK SHM_W
+
+ S_IRUSR S_IWUSR S_IRWXU
+ S_IRGRP S_IWGRP S_IRWXG
+ S_IROTH S_IWOTH S_IRWXO
+
+ ftok
+);
+
+BOOT_XS: {
+ # If I inherit DynaLoader then I inherit AutoLoader and I DON'T WANT TO
+ require DynaLoader;
+
+ # DynaLoader calls dl_load_flags as a static method.
+ *dl_load_flags = DynaLoader->can('dl_load_flags');
+
+ do {
+ __PACKAGE__->can('bootstrap') || \&DynaLoader::bootstrap
+ }->(__PACKAGE__, $VERSION);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IPC::SysV - SysV IPC constants
+
+=head1 SYNOPSIS
+
+ use IPC::SysV qw(IPC_STAT IPC_PRIVATE);
+
+=head1 DESCRIPTION
+
+C<IPC::SysV> defines and conditionally exports all the constants
+defined in your system include files which are needed by the SysV
+IPC calls.
+
+=item ftok( PATH, ID )
+
+Return a key based on PATH and ID, which can be used as a key for
+C<msgget>, C<semget> and C<shmget>. See L<ftok>
+
+=head1 SEE ALSO
+
+L<IPC::Msg>, L<IPC::Semaphore>, L<ftok>
+
+=head1 AUTHORS
+
+Graham Barr <gbarr@pobox.com>
+Jarkko Hietaniemi <jhi@iki.fi>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
diff --git a/contrib/perl5/ext/IPC/SysV/SysV.xs b/contrib/perl5/ext/IPC/SysV/SysV.xs
new file mode 100644
index 000000000000..0fbf783347f0
--- /dev/null
+++ b/contrib/perl5/ext/IPC/SysV/SysV.xs
@@ -0,0 +1,423 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <sys/types.h>
+#ifdef __linux__
+#include <asm/page.h>
+#endif
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+#include <sys/ipc.h>
+#ifdef HAS_MSG
+#include <sys/msg.h>
+#endif
+#ifdef HAS_SEM
+#include <sys/sem.h>
+#endif
+#ifdef HAS_SHM
+#if defined(PERL_SCO5) || defined(PERL_ISC)
+#include <sys/sysmacros.h>
+#endif
+#include <sys/shm.h>
+# ifndef HAS_SHMAT_PROTOTYPE
+ extern Shmat_t shmat _((int, char *, int));
+# endif
+#endif
+#endif
+
+/* Required in BSDI to get PAGE_SIZE definition for SHMLBA.
+ * Ugly. More beautiful solutions welcome.
+ * Shouting at BSDI sounds quite beautiful. */
+#ifdef __bsdi__
+# include <vm/vm_param.h>
+#endif
+
+MODULE=IPC::SysV PACKAGE=IPC::Msg::stat
+
+PROTOTYPES: ENABLE
+
+void
+pack(obj)
+ SV * obj
+PPCODE:
+{
+#ifdef HAS_MSG
+ SV *sv;
+ struct msqid_ds ds;
+ AV *list = (AV*)SvRV(obj);
+ sv = *av_fetch(list,0,TRUE); ds.msg_perm.uid = SvIV(sv);
+ sv = *av_fetch(list,1,TRUE); ds.msg_perm.gid = SvIV(sv);
+ sv = *av_fetch(list,4,TRUE); ds.msg_perm.mode = SvIV(sv);
+ sv = *av_fetch(list,6,TRUE); ds.msg_qbytes = SvIV(sv);
+ ST(0) = sv_2mortal(newSVpv((char *)&ds,sizeof(ds)));
+ XSRETURN(1);
+#else
+ croak("System V msgxxx is not implemented on this machine");
+#endif
+}
+
+void
+unpack(obj,buf)
+ SV * obj
+ SV * buf
+PPCODE:
+{
+#ifdef HAS_MSG
+ STRLEN len;
+ SV **sv_ptr;
+ struct msqid_ds *ds = (struct msqid_ds *)SvPV(buf,len);
+ AV *list = (AV*)SvRV(obj);
+ if (len != sizeof(*ds)) {
+ croak("Bad arg length for %s, length is %d, should be %d",
+ "IPC::Msg::stat",
+ len, sizeof(*ds));
+ }
+ sv_ptr = av_fetch(list,0,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_perm.uid);
+ sv_ptr = av_fetch(list,1,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_perm.gid);
+ sv_ptr = av_fetch(list,2,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_perm.cuid);
+ sv_ptr = av_fetch(list,3,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_perm.cgid);
+ sv_ptr = av_fetch(list,4,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_perm.mode);
+ sv_ptr = av_fetch(list,5,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_qnum);
+ sv_ptr = av_fetch(list,6,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_qbytes);
+ sv_ptr = av_fetch(list,7,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_lspid);
+ sv_ptr = av_fetch(list,8,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_lrpid);
+ sv_ptr = av_fetch(list,9,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_stime);
+ sv_ptr = av_fetch(list,10,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_rtime);
+ sv_ptr = av_fetch(list,11,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_ctime);
+ XSRETURN(1);
+#else
+ croak("System V msgxxx is not implemented on this machine");
+#endif
+}
+
+MODULE=IPC::SysV PACKAGE=IPC::Semaphore::stat
+
+void
+unpack(obj,ds)
+ SV * obj
+ SV * ds
+PPCODE:
+{
+#ifdef HAS_SEM
+ STRLEN len;
+ AV *list = (AV*)SvRV(obj);
+ struct semid_ds *data = (struct semid_ds *)SvPV(ds,len);
+ if(!sv_isa(obj, "IPC::Semaphore::stat"))
+ croak("method %s not called a %s object",
+ "unpack","IPC::Semaphore::stat");
+ if (len != sizeof(*data)) {
+ croak("Bad arg length for %s, length is %d, should be %d",
+ "IPC::Semaphore::stat",
+ len, sizeof(*data));
+ }
+ sv_setiv(*av_fetch(list,0,TRUE), data[0].sem_perm.uid);
+ sv_setiv(*av_fetch(list,1,TRUE), data[0].sem_perm.gid);
+ sv_setiv(*av_fetch(list,2,TRUE), data[0].sem_perm.cuid);
+ sv_setiv(*av_fetch(list,3,TRUE), data[0].sem_perm.cgid);
+ sv_setiv(*av_fetch(list,4,TRUE), data[0].sem_perm.mode);
+ sv_setiv(*av_fetch(list,5,TRUE), data[0].sem_ctime);
+ sv_setiv(*av_fetch(list,6,TRUE), data[0].sem_otime);
+ sv_setiv(*av_fetch(list,7,TRUE), data[0].sem_nsems);
+ XSRETURN(1);
+#else
+ croak("System V semxxx is not implemented on this machine");
+#endif
+}
+
+void
+pack(obj)
+ SV * obj
+PPCODE:
+{
+#ifdef HAS_SEM
+ SV **sv_ptr;
+ SV *sv;
+ struct semid_ds ds;
+ AV *list = (AV*)SvRV(obj);
+ if(!sv_isa(obj, "IPC::Semaphore::stat"))
+ croak("method %s not called a %s object",
+ "pack","IPC::Semaphore::stat");
+ if((sv_ptr = av_fetch(list,0,TRUE)) && (sv = *sv_ptr))
+ ds.sem_perm.uid = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,1,TRUE)) && (sv = *sv_ptr))
+ ds.sem_perm.gid = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,2,TRUE)) && (sv = *sv_ptr))
+ ds.sem_perm.cuid = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,3,TRUE)) && (sv = *sv_ptr))
+ ds.sem_perm.cgid = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,4,TRUE)) && (sv = *sv_ptr))
+ ds.sem_perm.mode = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,5,TRUE)) && (sv = *sv_ptr))
+ ds.sem_ctime = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,6,TRUE)) && (sv = *sv_ptr))
+ ds.sem_otime = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,7,TRUE)) && (sv = *sv_ptr))
+ ds.sem_nsems = SvIV(*sv_ptr);
+ ST(0) = sv_2mortal(newSVpv((char *)&ds,sizeof(ds)));
+ XSRETURN(1);
+#else
+ croak("System V semxxx is not implemented on this machine");
+#endif
+}
+
+MODULE=IPC::SysV PACKAGE=IPC::SysV
+
+int
+ftok(path, id)
+ char * path
+ int id
+ CODE:
+#if defined(HAS_SEM) || defined(HAS_SHM)
+ key_t k = ftok(path, id);
+ ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k));
+#else
+ DIE(no_func, "ftok");
+#endif
+
+int
+SHMLBA()
+ CODE:
+#ifdef SHMLBA
+ ST(0) = sv_2mortal(newSViv(SHMLBA));
+#else
+ croak("SHMLBA is not defined on this architecture");
+#endif
+
+BOOT:
+{
+ HV *stash = gv_stashpvn("IPC::SysV", 9, TRUE);
+ /*
+ * constant subs for IPC::SysV
+ */
+ struct { char *n; I32 v; } IPC__SysV__const[] = {
+#ifdef GETVAL
+ {"GETVAL", GETVAL},
+#endif
+#ifdef GETPID
+ {"GETPID", GETPID},
+#endif
+#ifdef GETNCNT
+ {"GETNCNT", GETNCNT},
+#endif
+#ifdef GETZCNT
+ {"GETZCNT", GETZCNT},
+#endif
+#ifdef GETALL
+ {"GETALL", GETALL},
+#endif
+#ifdef IPC_ALLOC
+ {"IPC_ALLOC", IPC_ALLOC},
+#endif
+#ifdef IPC_CREAT
+ {"IPC_CREAT", IPC_CREAT},
+#endif
+#ifdef IPC_EXCL
+ {"IPC_EXCL", IPC_EXCL},
+#endif
+#ifdef IPC_GETACL
+ {"IPC_GETACL", IPC_EXCL},
+#endif
+#ifdef IPC_LOCKED
+ {"IPC_LOCKED", IPC_LOCKED},
+#endif
+#ifdef IPC_M
+ {"IPC_M", IPC_M},
+#endif
+#ifdef IPC_NOERROR
+ {"IPC_NOERROR", IPC_NOERROR},
+#endif
+#ifdef IPC_NOWAIT
+ {"IPC_NOWAIT", IPC_NOWAIT},
+#endif
+#ifdef IPC_PRIVATE
+ {"IPC_PRIVATE", IPC_PRIVATE},
+#endif
+#ifdef IPC_R
+ {"IPC_R", IPC_R},
+#endif
+#ifdef IPC_RMID
+ {"IPC_RMID", IPC_RMID},
+#endif
+#ifdef IPC_SET
+ {"IPC_SET", IPC_SET},
+#endif
+#ifdef IPC_SETACL
+ {"IPC_SETACL", IPC_SETACL},
+#endif
+#ifdef IPC_SETLABEL
+ {"IPC_SETLABEL", IPC_SETLABEL},
+#endif
+#ifdef IPC_STAT
+ {"IPC_STAT", IPC_STAT},
+#endif
+#ifdef IPC_W
+ {"IPC_W", IPC_W},
+#endif
+#ifdef IPC_WANTED
+ {"IPC_WANTED", IPC_WANTED},
+#endif
+#ifdef MSG_NOERROR
+ {"MSG_NOERROR", MSG_NOERROR},
+#endif
+#ifdef MSG_FWAIT
+ {"MSG_FWAIT", MSG_FWAIT},
+#endif
+#ifdef MSG_LOCKED
+ {"MSG_LOCKED", MSG_LOCKED},
+#endif
+#ifdef MSG_MWAIT
+ {"MSG_MWAIT", MSG_MWAIT},
+#endif
+#ifdef MSG_WAIT
+ {"MSG_WAIT", MSG_WAIT},
+#endif
+#ifdef MSG_R
+ {"MSG_R", MSG_R},
+#endif
+#ifdef MSG_RWAIT
+ {"MSG_RWAIT", MSG_RWAIT},
+#endif
+#ifdef MSG_STAT
+ {"MSG_STAT", MSG_STAT},
+#endif
+#ifdef MSG_W
+ {"MSG_W", MSG_W},
+#endif
+#ifdef MSG_WWAIT
+ {"MSG_WWAIT", MSG_WWAIT},
+#endif
+#ifdef SEM_A
+ {"SEM_A", SEM_A},
+#endif
+#ifdef SEM_ALLOC
+ {"SEM_ALLOC", SEM_ALLOC},
+#endif
+#ifdef SEM_DEST
+ {"SEM_DEST", SEM_DEST},
+#endif
+#ifdef SEM_ERR
+ {"SEM_ERR", SEM_ERR},
+#endif
+#ifdef SEM_R
+ {"SEM_R", SEM_R},
+#endif
+#ifdef SEM_ORDER
+ {"SEM_ORDER", SEM_ORDER},
+#endif
+#ifdef SEM_UNDO
+ {"SEM_UNDO", SEM_UNDO},
+#endif
+#ifdef SETVAL
+ {"SETVAL", SETVAL},
+#endif
+#ifdef SETALL
+ {"SETALL", SETALL},
+#endif
+#ifdef SHM_CLEAR
+ {"SHM_CLEAR", SHM_CLEAR},
+#endif
+#ifdef SHM_COPY
+ {"SHM_COPY", SHM_COPY},
+#endif
+#ifdef SHM_DCACHE
+ {"SHM_DCACHE", SHM_DCACHE},
+#endif
+#ifdef SHM_DEST
+ {"SHM_DEST", SHM_DEST},
+#endif
+#ifdef SHM_ECACHE
+ {"SHM_ECACHE", SHM_ECACHE},
+#endif
+#ifdef SHM_FMAP
+ {"SHM_FMAP", SHM_FMAP},
+#endif
+#ifdef SHM_ICACHE
+ {"SHM_ICACHE", SHM_ICACHE},
+#endif
+#ifdef SHM_INIT
+ {"SHM_INIT", SHM_INIT},
+#endif
+#ifdef SHM_LOCK
+ {"SHM_LOCK", SHM_LOCK},
+#endif
+#ifdef SHM_LOCKED
+ {"SHM_LOCKED", SHM_LOCKED},
+#endif
+#ifdef SHM_MAP
+ {"SHM_MAP", SHM_MAP},
+#endif
+#ifdef SHM_NOSWAP
+ {"SHM_NOSWAP", SHM_NOSWAP},
+#endif
+#ifdef SHM_RDONLY
+ {"SHM_RDONLY", SHM_RDONLY},
+#endif
+#ifdef SHM_REMOVED
+ {"SHM_REMOVED", SHM_REMOVED},
+#endif
+#ifdef SHM_RND
+ {"SHM_RND", SHM_RND},
+#endif
+#ifdef SHM_SHARE_MMU
+ {"SHM_SHARE_MMU", SHM_SHARE_MMU},
+#endif
+#ifdef SHM_SHATTR
+ {"SHM_SHATTR", SHM_SHATTR},
+#endif
+#ifdef SHM_SIZE
+ {"SHM_SIZE", SHM_SIZE},
+#endif
+#ifdef SHM_UNLOCK
+ {"SHM_UNLOCK", SHM_UNLOCK},
+#endif
+#ifdef SHM_W
+ {"SHM_W", SHM_W},
+#endif
+#ifdef S_IRUSR
+ {"S_IRUSR", S_IRUSR},
+#endif
+#ifdef S_IWUSR
+ {"S_IWUSR", S_IWUSR},
+#endif
+#ifdef S_IRWXU
+ {"S_IRWXU", S_IRWXU},
+#endif
+#ifdef S_IRGRP
+ {"S_IRGRP", S_IRGRP},
+#endif
+#ifdef S_IWGRP
+ {"S_IWGRP", S_IWGRP},
+#endif
+#ifdef S_IRWXG
+ {"S_IRWXG", S_IRWXG},
+#endif
+#ifdef S_IROTH
+ {"S_IROTH", S_IROTH},
+#endif
+#ifdef S_IWOTH
+ {"S_IWOTH", S_IWOTH},
+#endif
+#ifdef S_IRWXO
+ {"S_IRWXO", S_IRWXO},
+#endif
+ {Nullch,0}};
+ char *name;
+ int i;
+
+ for(i = 0 ; name = IPC__SysV__const[i].n ; i++) {
+ newCONSTSUB(stash,name, newSViv(IPC__SysV__const[i].v));
+ }
+}
+
diff --git a/contrib/perl5/ext/IPC/SysV/t/msg.t b/contrib/perl5/ext/IPC/SysV/t/msg.t
new file mode 100755
index 000000000000..2a982f054a7b
--- /dev/null
+++ b/contrib/perl5/ext/IPC/SysV/t/msg.t
@@ -0,0 +1,41 @@
+use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_NOWAIT IPC_STAT S_IRWXU S_IRWXG S_IRWXO);
+
+use IPC::Msg;
+#Creating a message queue
+
+print "1..9\n";
+
+$msq = new IPC::Msg(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO)
+ || die "msgget: ",$!+0," $!\n";
+
+print "ok 1\n";
+
+#Putting a message on the queue
+$msgtype = 1;
+$msg = "hello";
+$msq->snd($msgtype,$msg,0) || print "not ";
+print "ok 2\n";
+
+#Check if there are messages on the queue
+$ds = $msq->stat() or print "not ";
+print "ok 3\n";
+
+print "not " unless $ds && $ds->qnum() == 1;
+print "ok 4\n";
+
+#Retreiving a message from the queue
+$rmsgtype = 0; # Give me any type
+$rmsgtype = $msq->rcv($rmsg,256,$rmsgtype,IPC_NOWAIT) || print "not ";
+print "ok 5\n";
+
+print "not " unless $rmsgtype == $msgtype && $rmsg eq $msg;
+print "ok 6\n";
+
+$ds = $msq->stat() or print "not ";
+print "ok 7\n";
+
+print "not " unless $ds && $ds->qnum() == 0;
+print "ok 8\n";
+
+$msq->remove || print "not ";
+print "ok 9\n";
diff --git a/contrib/perl5/ext/IPC/SysV/t/sem.t b/contrib/perl5/ext/IPC/SysV/t/sem.t
new file mode 100755
index 000000000000..9d6fff64f23b
--- /dev/null
+++ b/contrib/perl5/ext/IPC/SysV/t/sem.t
@@ -0,0 +1,51 @@
+
+use IPC::SysV qw(
+ SETALL
+ IPC_PRIVATE
+ IPC_CREAT
+ IPC_RMID
+ IPC_NOWAIT
+ IPC_STAT
+ S_IRWXU
+ S_IRWXG
+ S_IRWXO
+);
+use IPC::Semaphore;
+
+print "1..10\n";
+
+$sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT)
+ || die "semget: ",$!+0," $!\n";
+
+print "ok 1\n";
+
+my $st = $sem->stat || print "not ";
+print "ok 2\n";
+
+$sem->setall( (0) x 10) || print "not ";
+print "ok 3\n";
+
+my @sem = $sem->getall;
+print "not " unless join("",@sem) eq "0000000000";
+print "ok 4\n";
+
+$sem[2] = 1;
+$sem->setall( @sem ) || print "not ";
+print "ok 5\n";
+
+@sem = $sem->getall;
+print "not " unless join("",@sem) eq "0010000000";
+print "ok 6\n";
+
+my $ncnt = $sem->getncnt(0);
+print "not " if $sem->getncnt(0) || !defined($ncnt);
+print "ok 7\n";
+
+$sem->op(2,-1,IPC_NOWAIT) || print "not ";
+print "ok 8\n";
+
+print "not " if $sem->getncnt(0);
+print "ok 9\n";
+
+$sem->remove || print "not ";
+print "ok 10\n";
diff --git a/contrib/perl5/ext/NDBM_File/Makefile.PL b/contrib/perl5/ext/NDBM_File/Makefile.PL
new file mode 100644
index 000000000000..ca4c107c0d27
--- /dev/null
+++ b/contrib/perl5/ext/NDBM_File/Makefile.PL
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'NDBM_File',
+ LIBS => ["-L/usr/local/lib -lndbm", "-ldbm -lucb"],
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'NDBM_File.pm',
+);
diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.pm b/contrib/perl5/ext/NDBM_File/NDBM_File.pm
new file mode 100644
index 000000000000..ed4fe2b36f9b
--- /dev/null
+++ b/contrib/perl5/ext/NDBM_File/NDBM_File.pm
@@ -0,0 +1,40 @@
+package NDBM_File;
+
+BEGIN {
+ if ($] >= 5.002) {
+ use strict;
+ }
+}
+use vars qw($VERSION @ISA);
+
+require Tie::Hash;
+require DynaLoader;
+
+@ISA = qw(Tie::Hash DynaLoader);
+
+$VERSION = "1.01";
+
+bootstrap NDBM_File $VERSION;
+
+1;
+
+__END__
+
+=head1 NAME
+
+NDBM_File - Tied access to ndbm files
+
+=head1 SYNOPSIS
+
+ use NDBM_File;
+ use Fcntl; # for O_ constants
+
+ tie(%h, 'NDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640);
+
+ untie %h;
+
+=head1 DESCRIPTION
+
+See L<perlfunc/tie>
+
+=cut
diff --git a/contrib/perl5/ext/NDBM_File/NDBM_File.xs b/contrib/perl5/ext/NDBM_File/NDBM_File.xs
new file mode 100644
index 000000000000..d129a9c49053
--- /dev/null
+++ b/contrib/perl5/ext/NDBM_File/NDBM_File.xs
@@ -0,0 +1,70 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <ndbm.h>
+
+typedef DBM* NDBM_File;
+#define dbm_TIEHASH(dbtype,filename,flags,mode) dbm_open(filename,flags,mode)
+#define dbm_FETCH(db,key) dbm_fetch(db,key)
+#define dbm_STORE(db,key,value,flags) dbm_store(db,key,value,flags)
+#define dbm_DELETE(db,key) dbm_delete(db,key)
+#define dbm_FIRSTKEY(db) dbm_firstkey(db)
+#define dbm_NEXTKEY(db,key) dbm_nextkey(db)
+
+MODULE = NDBM_File PACKAGE = NDBM_File PREFIX = dbm_
+
+NDBM_File
+dbm_TIEHASH(dbtype, filename, flags, mode)
+ char * dbtype
+ char * filename
+ int flags
+ int mode
+
+void
+dbm_DESTROY(db)
+ NDBM_File db
+ CODE:
+ dbm_close(db);
+
+datum
+dbm_FETCH(db, key)
+ NDBM_File db
+ datum key
+
+int
+dbm_STORE(db, key, value, flags = DBM_REPLACE)
+ NDBM_File db
+ datum key
+ datum value
+ int flags
+ CLEANUP:
+ if (RETVAL) {
+ if (RETVAL < 0 && errno == EPERM)
+ croak("No write permission to ndbm file");
+ croak("ndbm store returned %d, errno %d, key \"%s\"",
+ RETVAL,errno,key.dptr);
+ dbm_clearerr(db);
+ }
+
+int
+dbm_DELETE(db, key)
+ NDBM_File db
+ datum key
+
+datum
+dbm_FIRSTKEY(db)
+ NDBM_File db
+
+datum
+dbm_NEXTKEY(db, key)
+ NDBM_File db
+ datum key
+
+int
+dbm_error(db)
+ NDBM_File db
+
+void
+dbm_clearerr(db)
+ NDBM_File db
+
diff --git a/contrib/perl5/ext/NDBM_File/hints/dec_osf.pl b/contrib/perl5/ext/NDBM_File/hints/dec_osf.pl
new file mode 100644
index 000000000000..e96d907e10a0
--- /dev/null
+++ b/contrib/perl5/ext/NDBM_File/hints/dec_osf.pl
@@ -0,0 +1,2 @@
+# Spider Boardman <spider@Orb.Nashua.NH.US>
+$self->{LIBS} = [''];
diff --git a/contrib/perl5/ext/NDBM_File/hints/dynixptx.pl b/contrib/perl5/ext/NDBM_File/hints/dynixptx.pl
new file mode 100644
index 000000000000..d402c1790141
--- /dev/null
+++ b/contrib/perl5/ext/NDBM_File/hints/dynixptx.pl
@@ -0,0 +1,3 @@
+# On DYNIX/ptx 4.0 (v4.1.3), ndbm is actually contained in the
+# libc library, and must be explicitly linked against -lc when compiling.
+$self->{LIBS} = ['-lc'];
diff --git a/contrib/perl5/ext/NDBM_File/hints/solaris.pl b/contrib/perl5/ext/NDBM_File/hints/solaris.pl
new file mode 100644
index 000000000000..11310a972f5c
--- /dev/null
+++ b/contrib/perl5/ext/NDBM_File/hints/solaris.pl
@@ -0,0 +1,3 @@
+# -lucb has been reported to be fatal for perl5 on Solaris.
+# Thus we deliberately don't include it here.
+$self->{LIBS} = ["-lndbm", "-ldbm"];
diff --git a/contrib/perl5/ext/NDBM_File/hints/svr4.pl b/contrib/perl5/ext/NDBM_File/hints/svr4.pl
new file mode 100644
index 000000000000..3285d9a685fb
--- /dev/null
+++ b/contrib/perl5/ext/NDBM_File/hints/svr4.pl
@@ -0,0 +1,4 @@
+# Some SVR4 systems may need to link against routines in -lucb for
+# odbm. Some may also need to link against -lc to pick up things like
+# ecvt.
+$self->{LIBS} = ['-ldbm -lucb -lc'];
diff --git a/contrib/perl5/ext/NDBM_File/typemap b/contrib/perl5/ext/NDBM_File/typemap
new file mode 100644
index 000000000000..317a8f3886cb
--- /dev/null
+++ b/contrib/perl5/ext/NDBM_File/typemap
@@ -0,0 +1,27 @@
+#
+#################################### DBM SECTION
+#
+
+datum T_DATUM
+gdatum T_GDATUM
+NDBM_File T_PTROBJ
+GDBM_File T_PTROBJ
+SDBM_File T_PTROBJ
+ODBM_File T_PTROBJ
+DB_File T_PTROBJ
+DBZ_File T_PTROBJ
+FATALFUNC T_OPAQUEPTR
+
+INPUT
+T_DATUM
+ $var.dptr = SvPV($arg, PL_na);
+ $var.dsize = (int)PL_na;
+T_GDATUM
+ UNIMPLEMENTED
+OUTPUT
+T_DATUM
+ sv_setpvn($arg, $var.dptr, $var.dsize);
+T_GDATUM
+ sv_usepvn($arg, $var.dptr, $var.dsize);
+T_PTROBJ
+ sv_setref_pv($arg, dbtype, (void*)$var);
diff --git a/contrib/perl5/ext/ODBM_File/Makefile.PL b/contrib/perl5/ext/ODBM_File/Makefile.PL
new file mode 100644
index 000000000000..76a5d1999908
--- /dev/null
+++ b/contrib/perl5/ext/ODBM_File/Makefile.PL
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'ODBM_File',
+ LIBS => ["-ldbm -lucb"],
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'ODBM_File.pm',
+);
diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.pm b/contrib/perl5/ext/ODBM_File/ODBM_File.pm
new file mode 100644
index 000000000000..923640ff3481
--- /dev/null
+++ b/contrib/perl5/ext/ODBM_File/ODBM_File.pm
@@ -0,0 +1,35 @@
+package ODBM_File;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+require Tie::Hash;
+require DynaLoader;
+
+@ISA = qw(Tie::Hash DynaLoader);
+
+$VERSION = "1.00";
+
+bootstrap ODBM_File $VERSION;
+
+1;
+
+__END__
+
+=head1 NAME
+
+ODBM_File - Tied access to odbm files
+
+=head1 SYNOPSIS
+
+ use ODBM_File;
+
+ tie(%h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640);
+
+ untie %h;
+
+=head1 DESCRIPTION
+
+See L<perlfunc/tie>
+
+=cut
diff --git a/contrib/perl5/ext/ODBM_File/ODBM_File.xs b/contrib/perl5/ext/ODBM_File/ODBM_File.xs
new file mode 100644
index 000000000000..892c038a9ced
--- /dev/null
+++ b/contrib/perl5/ext/ODBM_File/ODBM_File.xs
@@ -0,0 +1,122 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef NULL
+#undef NULL /* XXX Why? */
+#endif
+#ifdef I_DBM
+# include <dbm.h>
+#else
+# ifdef I_RPCSVC_DBM
+# include <rpcsvc/dbm.h>
+# endif
+#endif
+
+#ifdef DBM_BUG_DUPLICATE_FREE
+/*
+ * DBM on at least Ultrix and HPUX call dbmclose() from dbminit(),
+ * resulting in duplicate free() because dbmclose() does *not*
+ * check if it has already been called for this DBM.
+ * If some malloc/free calls have been done between dbmclose() and
+ * the next dbminit(), the memory might be used for something else when
+ * it is freed.
+ * Verified to work on ultrix4.3. Probably will work on HP/UX.
+ * Set DBM_BUG_DUPLICATE_FREE in the extension hint file.
+ */
+/* Close the previous dbm, and fail to open a new dbm */
+#define dbmclose() ((void) dbminit("/tmp/x/y/z/z/y"))
+#endif
+
+#include <fcntl.h>
+
+typedef void* ODBM_File;
+
+#define odbm_FETCH(db,key) fetch(key)
+#define odbm_STORE(db,key,value,flags) store(key,value)
+#define odbm_DELETE(db,key) delete(key)
+#define odbm_FIRSTKEY(db) firstkey()
+#define odbm_NEXTKEY(db,key) nextkey(key)
+
+static int dbmrefcnt;
+
+#ifndef DBM_REPLACE
+#define DBM_REPLACE 0
+#endif
+
+MODULE = ODBM_File PACKAGE = ODBM_File PREFIX = odbm_
+
+#ifndef NULL
+# define NULL 0
+#endif
+
+ODBM_File
+odbm_TIEHASH(dbtype, filename, flags, mode)
+ char * dbtype
+ char * filename
+ int flags
+ int mode
+ CODE:
+ {
+ char *tmpbuf;
+ if (dbmrefcnt++)
+ croak("Old dbm can only open one database");
+ New(0, tmpbuf, strlen(filename) + 5, char);
+ SAVEFREEPV(tmpbuf);
+ sprintf(tmpbuf,"%s.dir",filename);
+ if (stat(tmpbuf, &PL_statbuf) < 0) {
+ if (flags & O_CREAT) {
+ if (mode < 0 || close(creat(tmpbuf,mode)) < 0)
+ croak("ODBM_File: Can't create %s", filename);
+ sprintf(tmpbuf,"%s.pag",filename);
+ if (close(creat(tmpbuf,mode)) < 0)
+ croak("ODBM_File: Can't create %s", filename);
+ }
+ else
+ croak("ODBM_FILE: Can't open %s", filename);
+ }
+ RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
+ ST(0) = sv_mortalcopy(&PL_sv_undef);
+ sv_setptrobj(ST(0), RETVAL, dbtype);
+ }
+
+void
+DESTROY(db)
+ ODBM_File db
+ CODE:
+ dbmrefcnt--;
+ dbmclose();
+
+datum
+odbm_FETCH(db, key)
+ ODBM_File db
+ datum key
+
+int
+odbm_STORE(db, key, value, flags = DBM_REPLACE)
+ ODBM_File db
+ datum key
+ datum value
+ int flags
+ CLEANUP:
+ if (RETVAL) {
+ if (RETVAL < 0 && errno == EPERM)
+ croak("No write permission to odbm file");
+ croak("odbm store returned %d, errno %d, key \"%s\"",
+ RETVAL,errno,key.dptr);
+ }
+
+int
+odbm_DELETE(db, key)
+ ODBM_File db
+ datum key
+
+datum
+odbm_FIRSTKEY(db)
+ ODBM_File db
+
+datum
+odbm_NEXTKEY(db, key)
+ ODBM_File db
+ datum key
+
diff --git a/contrib/perl5/ext/ODBM_File/hints/dec_osf.pl b/contrib/perl5/ext/ODBM_File/hints/dec_osf.pl
new file mode 100644
index 000000000000..febb7cdb21a3
--- /dev/null
+++ b/contrib/perl5/ext/ODBM_File/hints/dec_osf.pl
@@ -0,0 +1,9 @@
+# The -hidden option causes compilation to fail on Digital Unix.
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Sat Jan 13 16:29:52 EST 1996
+$self->{LDDLFLAGS} = $Config{lddlflags};
+$self->{LDDLFLAGS} =~ s/-hidden//;
+# As long as we're hinting, note the known location of the dbm routines.
+# Spider Boardman <spider@Orb.Nashua.NH.US>
+# Fri Feb 21 14:50:31 EST 1997
+$self->{LIBS} = ['-ldbm'];
diff --git a/contrib/perl5/ext/ODBM_File/hints/hpux.pl b/contrib/perl5/ext/ODBM_File/hints/hpux.pl
new file mode 100644
index 000000000000..31f9d24bcae0
--- /dev/null
+++ b/contrib/perl5/ext/ODBM_File/hints/hpux.pl
@@ -0,0 +1,4 @@
+# Try to work around "bad free" messages. See note in ODBM_File.xs.
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Sun Sep 8 12:57:52 EDT 1996
+$self->{CCFLAGS} = $Config{ccflags} . ' -DDBM_BUG_DUPLICATE_FREE' ;
diff --git a/contrib/perl5/ext/ODBM_File/hints/sco.pl b/contrib/perl5/ext/ODBM_File/hints/sco.pl
new file mode 100644
index 000000000000..4664f2bee0f2
--- /dev/null
+++ b/contrib/perl5/ext/ODBM_File/hints/sco.pl
@@ -0,0 +1,4 @@
+# Some versions of SCO contain a broken -ldbm library that is missing
+# dbmclose. Some of those might have a fixed library installed as
+# -ldbm.nfs.
+$self->{LIBS} = ['-ldbm.nfs', '-ldbm'];
diff --git a/contrib/perl5/ext/ODBM_File/hints/solaris.pl b/contrib/perl5/ext/ODBM_File/hints/solaris.pl
new file mode 100644
index 000000000000..ac573932cced
--- /dev/null
+++ b/contrib/perl5/ext/ODBM_File/hints/solaris.pl
@@ -0,0 +1,3 @@
+# -lucb has been reported to be fatal for perl5 on Solaris.
+# Thus we deliberately don't include it here.
+$self->{LIBS} = ['-ldbm'];
diff --git a/contrib/perl5/ext/ODBM_File/hints/svr4.pl b/contrib/perl5/ext/ODBM_File/hints/svr4.pl
new file mode 100644
index 000000000000..3285d9a685fb
--- /dev/null
+++ b/contrib/perl5/ext/ODBM_File/hints/svr4.pl
@@ -0,0 +1,4 @@
+# Some SVR4 systems may need to link against routines in -lucb for
+# odbm. Some may also need to link against -lc to pick up things like
+# ecvt.
+$self->{LIBS} = ['-ldbm -lucb -lc'];
diff --git a/contrib/perl5/ext/ODBM_File/hints/ultrix.pl b/contrib/perl5/ext/ODBM_File/hints/ultrix.pl
new file mode 100644
index 000000000000..31f9d24bcae0
--- /dev/null
+++ b/contrib/perl5/ext/ODBM_File/hints/ultrix.pl
@@ -0,0 +1,4 @@
+# Try to work around "bad free" messages. See note in ODBM_File.xs.
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Sun Sep 8 12:57:52 EDT 1996
+$self->{CCFLAGS} = $Config{ccflags} . ' -DDBM_BUG_DUPLICATE_FREE' ;
diff --git a/contrib/perl5/ext/ODBM_File/typemap b/contrib/perl5/ext/ODBM_File/typemap
new file mode 100644
index 000000000000..5e12e739338d
--- /dev/null
+++ b/contrib/perl5/ext/ODBM_File/typemap
@@ -0,0 +1,25 @@
+#
+#################################### DBM SECTION
+#
+
+datum T_DATUM
+gdatum T_GDATUM
+NDBM_File T_PTROBJ
+GDBM_File T_PTROBJ
+SDBM_File T_PTROBJ
+ODBM_File T_PTROBJ
+DB_File T_PTROBJ
+DBZ_File T_PTROBJ
+FATALFUNC T_OPAQUEPTR
+
+INPUT
+T_DATUM
+ $var.dptr = SvPV($arg, PL_na);
+ $var.dsize = (int)PL_na;
+T_GDATUM
+ UNIMPLEMENTED
+OUTPUT
+T_DATUM
+ sv_setpvn($arg, $var.dptr, $var.dsize);
+T_GDATUM
+ sv_usepvn($arg, $var.dptr, $var.dsize);
diff --git a/contrib/perl5/ext/Opcode/Makefile.PL b/contrib/perl5/ext/Opcode/Makefile.PL
new file mode 100644
index 000000000000..48a6ed82b897
--- /dev/null
+++ b/contrib/perl5/ext/Opcode/Makefile.PL
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Opcode',
+ MAN3PODS => ' ',
+ VERSION_FROM => 'Opcode.pm',
+ XS_VERSION => '1.03'
+);
diff --git a/contrib/perl5/ext/Opcode/Opcode.pm b/contrib/perl5/ext/Opcode/Opcode.pm
new file mode 100644
index 000000000000..0ee6be695592
--- /dev/null
+++ b/contrib/perl5/ext/Opcode/Opcode.pm
@@ -0,0 +1,575 @@
+package Opcode;
+
+require 5.002;
+
+use vars qw($VERSION $XS_VERSION @ISA @EXPORT_OK);
+
+$VERSION = "1.04";
+$XS_VERSION = "1.03";
+
+use strict;
+use Carp;
+use Exporter ();
+use DynaLoader ();
+@ISA = qw(Exporter DynaLoader);
+
+BEGIN {
+ @EXPORT_OK = qw(
+ opset ops_to_opset
+ opset_to_ops opset_to_hex invert_opset
+ empty_opset full_opset
+ opdesc opcodes opmask define_optag
+ opmask_add verify_opset opdump
+ );
+}
+
+sub opset (;@);
+sub opset_to_hex ($);
+sub opdump (;$);
+use subs @EXPORT_OK;
+
+bootstrap Opcode $XS_VERSION;
+
+_init_optags();
+
+sub ops_to_opset { opset @_ } # alias for old name
+
+sub opset_to_hex ($) {
+ return "(invalid opset)" unless verify_opset($_[0]);
+ unpack("h*",$_[0]);
+}
+
+sub opdump (;$) {
+ my $pat = shift;
+ # handy utility: perl -MOpcode=opdump -e 'opdump File'
+ foreach(opset_to_ops(full_opset)) {
+ my $op = sprintf " %12s %s\n", $_, opdesc($_);
+ next if defined $pat and $op !~ m/$pat/i;
+ print $op;
+ }
+}
+
+
+
+sub _init_optags {
+ my(%all, %seen);
+ @all{opset_to_ops(full_opset)} = (); # keys only
+
+ local($_);
+ local($/) = "\n=cut"; # skip to optags definition section
+ <DATA>;
+ $/ = "\n="; # now read in 'pod section' chunks
+ while(<DATA>) {
+ next unless m/^item\s+(:\w+)/;
+ my $tag = $1;
+
+ # Split into lines, keep only indented lines
+ my @lines = grep { m/^\s/ } split(/\n/);
+ foreach (@lines) { s/--.*// } # delete comments
+ my @ops = map { split ' ' } @lines; # get op words
+
+ foreach(@ops) {
+ warn "$tag - $_ already tagged in $seen{$_}\n" if $seen{$_};
+ $seen{$_} = $tag;
+ delete $all{$_};
+ }
+ # opset will croak on invalid names
+ define_optag($tag, opset(@ops));
+ }
+ close(DATA);
+ warn "Untagged opnames: ".join(' ',keys %all)."\n" if %all;
+}
+
+
+1;
+
+__DATA__
+
+=head1 NAME
+
+Opcode - Disable named opcodes when compiling perl code
+
+=head1 SYNOPSIS
+
+ use Opcode;
+
+
+=head1 DESCRIPTION
+
+Perl code is always compiled into an internal format before execution.
+
+Evaluating perl code (e.g. via "eval" or "do 'file'") causes
+the code to be compiled into an internal format and then,
+provided there was no error in the compilation, executed.
+The internal format is based on many distinct I<opcodes>.
+
+By default no opmask is in effect and any code can be compiled.
+
+The Opcode module allow you to define an I<operator mask> to be in
+effect when perl I<next> compiles any code. Attempting to compile code
+which contains a masked opcode will cause the compilation to fail
+with an error. The code will not be executed.
+
+=head1 NOTE
+
+The Opcode module is not usually used directly. See the ops pragma and
+Safe modules for more typical uses.
+
+=head1 WARNING
+
+The authors make B<no warranty>, implied or otherwise, about the
+suitability of this software for safety or security purposes.
+
+The authors shall not in any case be liable for special, incidental,
+consequential, indirect or other similar damages arising from the use
+of this software.
+
+Your mileage will vary. If in any doubt B<do not use it>.
+
+
+=head1 Operator Names and Operator Lists
+
+The canonical list of operator names is the contents of the array
+op_name defined and initialised in file F<opcode.h> of the Perl
+source distribution (and installed into the perl library).
+
+Each operator has both a terse name (its opname) and a more verbose or
+recognisable descriptive name. The opdesc function can be used to
+return a list of descriptions for a list of operators.
+
+Many of the functions and methods listed below take a list of
+operators as parameters. Most operator lists can be made up of several
+types of element. Each element can be one of
+
+=over 8
+
+=item an operator name (opname)
+
+Operator names are typically small lowercase words like enterloop,
+leaveloop, last, next, redo etc. Sometimes they are rather cryptic
+like gv2cv, i_ncmp and ftsvtx.
+
+=item an operator tag name (optag)
+
+Operator tags can be used to refer to groups (or sets) of operators.
+Tag names always begin with a colon. The Opcode module defines several
+optags and the user can define others using the define_optag function.
+
+=item a negated opname or optag
+
+An opname or optag can be prefixed with an exclamation mark, e.g., !mkdir.
+Negating an opname or optag means remove the corresponding ops from the
+accumulated set of ops at that point.
+
+=item an operator set (opset)
+
+An I<opset> as a binary string of approximately 43 bytes which holds a
+set or zero or more operators.
+
+The opset and opset_to_ops functions can be used to convert from
+a list of operators to an opset and I<vice versa>.
+
+Wherever a list of operators can be given you can use one or more opsets.
+See also Manipulating Opsets below.
+
+=back
+
+
+=head1 Opcode Functions
+
+The Opcode package contains functions for manipulating operator names
+tags and sets. All are available for export by the package.
+
+=over 8
+
+=item opcodes
+
+In a scalar context opcodes returns the number of opcodes in this
+version of perl (around 340 for perl5.002).
+
+In a list context it returns a list of all the operator names.
+(Not yet implemented, use @names = opset_to_ops(full_opset).)
+
+=item opset (OP, ...)
+
+Returns an opset containing the listed operators.
+
+=item opset_to_ops (OPSET)
+
+Returns a list of operator names corresponding to those operators in
+the set.
+
+=item opset_to_hex (OPSET)
+
+Returns a string representation of an opset. Can be handy for debugging.
+
+=item full_opset
+
+Returns an opset which includes all operators.
+
+=item empty_opset
+
+Returns an opset which contains no operators.
+
+=item invert_opset (OPSET)
+
+Returns an opset which is the inverse set of the one supplied.
+
+=item verify_opset (OPSET, ...)
+
+Returns true if the supplied opset looks like a valid opset (is the
+right length etc) otherwise it returns false. If an optional second
+parameter is true then verify_opset will croak on an invalid opset
+instead of returning false.
+
+Most of the other Opcode functions call verify_opset automatically
+and will croak if given an invalid opset.
+
+=item define_optag (OPTAG, OPSET)
+
+Define OPTAG as a symbolic name for OPSET. Optag names always start
+with a colon C<:>.
+
+The optag name used must not be defined already (define_optag will
+croak if it is already defined). Optag names are global to the perl
+process and optag definitions cannot be altered or deleted once
+defined.
+
+It is strongly recommended that applications using Opcode should use a
+leading capital letter on their tag names since lowercase names are
+reserved for use by the Opcode module. If using Opcode within a module
+you should prefix your tags names with the name of your module to
+ensure uniqueness and thus avoid clashes with other modules.
+
+=item opmask_add (OPSET)
+
+Adds the supplied opset to the current opmask. Note that there is
+currently I<no> mechanism for unmasking ops once they have been masked.
+This is intentional.
+
+=item opmask
+
+Returns an opset corresponding to the current opmask.
+
+=item opdesc (OP, ...)
+
+This takes a list of operator names and returns the corresponding list
+of operator descriptions.
+
+=item opdump (PAT)
+
+Dumps to STDOUT a two column list of op names and op descriptions.
+If an optional pattern is given then only lines which match the
+(case insensitive) pattern will be output.
+
+It's designed to be used as a handy command line utility:
+
+ perl -MOpcode=opdump -e opdump
+ perl -MOpcode=opdump -e 'opdump Eval'
+
+=back
+
+=head1 Manipulating Opsets
+
+Opsets may be manipulated using the perl bit vector operators & (and), | (or),
+^ (xor) and ~ (negate/invert).
+
+However you should never rely on the numerical position of any opcode
+within the opset. In other words both sides of a bit vector operator
+should be opsets returned from Opcode functions.
+
+Also, since the number of opcodes in your current version of perl might
+not be an exact multiple of eight, there may be unused bits in the last
+byte of an upset. This should not cause any problems (Opcode functions
+ignore those extra bits) but it does mean that using the ~ operator
+will typically not produce the same 'physical' opset 'string' as the
+invert_opset function.
+
+
+=head1 TO DO (maybe)
+
+ $bool = opset_eq($opset1, $opset2) true if opsets are logically eqiv
+
+ $yes = opset_can($opset, @ops) true if $opset has all @ops set
+
+ @diff = opset_diff($opset1, $opset2) => ('foo', '!bar', ...)
+
+=cut
+
+# the =cut above is used by _init_optags() to get here quickly
+
+=head1 Predefined Opcode Tags
+
+=over 5
+
+=item :base_core
+
+ null stub scalar pushmark wantarray const defined undef
+
+ rv2sv sassign
+
+ rv2av aassign aelem aelemfast aslice av2arylen
+
+ rv2hv helem hslice each values keys exists delete
+
+ preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec
+ int hex oct abs pow multiply i_multiply divide i_divide
+ modulo i_modulo add i_add subtract i_subtract
+
+ left_shift right_shift bit_and bit_xor bit_or negate i_negate
+ not complement
+
+ lt i_lt gt i_gt le i_le ge i_ge eq i_eq ne i_ne ncmp i_ncmp
+ slt sgt sle sge seq sne scmp
+
+ substr vec stringify study pos length index rindex ord chr
+
+ ucfirst lcfirst uc lc quotemeta trans chop schop chomp schomp
+
+ match split qr
+
+ list lslice splice push pop shift unshift reverse
+
+ cond_expr flip flop andassign orassign and or xor
+
+ warn die lineseq nextstate unstack scope enter leave
+
+ rv2cv anoncode prototype
+
+ entersub leavesub return method -- XXX loops via recursion?
+
+ leaveeval -- needed for Safe to operate, is safe without entereval
+
+=item :base_mem
+
+These memory related ops are not included in :base_core because they
+can easily be used to implement a resource attack (e.g., consume all
+available memory).
+
+ concat repeat join range
+
+ anonlist anonhash
+
+Note that despite the existance of this optag a memory resource attack
+may still be possible using only :base_core ops.
+
+Disabling these ops is a I<very> heavy handed way to attempt to prevent
+a memory resource attack. It's probable that a specific memory limit
+mechanism will be added to perl in the near future.
+
+=item :base_loop
+
+These loop ops are not included in :base_core because they can easily be
+used to implement a resource attack (e.g., consume all available CPU time).
+
+ grepstart grepwhile
+ mapstart mapwhile
+ enteriter iter
+ enterloop leaveloop
+ last next redo
+ goto
+
+=item :base_io
+
+These ops enable I<filehandle> (rather than filename) based input and
+output. These are safe on the assumption that only pre-existing
+filehandles are available for use. To create new filehandles other ops
+such as open would need to be enabled.
+
+ readline rcatline getc read
+
+ formline enterwrite leavewrite
+
+ print sysread syswrite send recv
+
+ eof tell seek sysseek
+
+ readdir telldir seekdir rewinddir
+
+=item :base_orig
+
+These are a hotchpotch of opcodes still waiting to be considered
+
+ gvsv gv gelem
+
+ padsv padav padhv padany
+
+ rv2gv refgen srefgen ref
+
+ bless -- could be used to change ownership of objects (reblessing)
+
+ pushre regcmaybe regcreset regcomp subst substcont
+
+ sprintf prtf -- can core dump
+
+ crypt
+
+ tie untie
+
+ dbmopen dbmclose
+ sselect select
+ pipe_op sockpair
+
+ getppid getpgrp setpgrp getpriority setpriority localtime gmtime
+
+ entertry leavetry -- can be used to 'hide' fatal errors
+
+=item :base_math
+
+These ops are not included in :base_core because of the risk of them being
+used to generate floating point exceptions (which would have to be caught
+using a $SIG{FPE} handler).
+
+ atan2 sin cos exp log sqrt
+
+These ops are not included in :base_core because they have an effect
+beyond the scope of the compartment.
+
+ rand srand
+
+=item :base_thread
+
+These ops are related to multi-threading.
+
+ lock threadsv
+
+=item :default
+
+A handy tag name for a I<reasonable> default set of ops. (The current ops
+allowed are unstable while development continues. It will change.)
+
+ :base_core :base_mem :base_loop :base_io :base_orig :base_thread
+
+If safety matters to you (and why else would you be using the Opcode module?)
+then you should not rely on the definition of this, or indeed any other, optag!
+
+
+=item :filesys_read
+
+ stat lstat readlink
+
+ ftatime ftblk ftchr ftctime ftdir fteexec fteowned fteread
+ ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned
+ ftrread ftsgid ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx
+
+ fttext ftbinary
+
+ fileno
+
+=item :sys_db
+
+ ghbyname ghbyaddr ghostent shostent ehostent -- hosts
+ gnbyname gnbyaddr gnetent snetent enetent -- networks
+ gpbyname gpbynumber gprotoent sprotoent eprotoent -- protocols
+ gsbyname gsbyport gservent sservent eservent -- services
+
+ gpwnam gpwuid gpwent spwent epwent getlogin -- users
+ ggrnam ggrgid ggrent sgrent egrent -- groups
+
+=item :browse
+
+A handy tag name for a I<reasonable> default set of ops beyond the
+:default optag. Like :default (and indeed all the other optags) its
+current definition is unstable while development continues. It will change.
+
+The :browse tag represents the next step beyond :default. It it a
+superset of the :default ops and adds :filesys_read the :sys_db.
+The intent being that scripts can access more (possibly sensitive)
+information about your system but not be able to change it.
+
+ :default :filesys_read :sys_db
+
+=item :filesys_open
+
+ sysopen open close
+ umask binmode
+
+ open_dir closedir -- other dir ops are in :base_io
+
+=item :filesys_write
+
+ link unlink rename symlink truncate
+
+ mkdir rmdir
+
+ utime chmod chown
+
+ fcntl -- not strictly filesys related, but possibly as dangerous?
+
+=item :subprocess
+
+ backtick system
+
+ fork
+
+ wait waitpid
+
+ glob -- access to Cshell via <`rm *`>
+
+=item :ownprocess
+
+ exec exit kill
+
+ time tms -- could be used for timing attacks (paranoid?)
+
+=item :others
+
+This tag holds groups of assorted specialist opcodes that don't warrant
+having optags defined for them.
+
+SystemV Interprocess Communications:
+
+ msgctl msgget msgrcv msgsnd
+
+ semctl semget semop
+
+ shmctl shmget shmread shmwrite
+
+=item :still_to_be_decided
+
+ chdir
+ flock ioctl
+
+ socket getpeername ssockopt
+ bind connect listen accept shutdown gsockopt getsockname
+
+ sleep alarm -- changes global timer state and signal handling
+ sort -- assorted problems including core dumps
+ tied -- can be used to access object implementing a tie
+ pack unpack -- can be used to create/use memory pointers
+
+ entereval -- can be used to hide code from initial compile
+ require dofile
+
+ caller -- get info about calling environment and args
+
+ reset
+
+ dbstate -- perl -d version of nextstate(ment) opcode
+
+=item :dangerous
+
+This tag is simply a bucket for opcodes that are unlikely to be used via
+a tag name but need to be tagged for completness and documentation.
+
+ syscall dump chroot
+
+
+=back
+
+=head1 SEE ALSO
+
+ops(3) -- perl pragma interface to Opcode module.
+
+Safe(3) -- Opcode and namespace limited execution compartments
+
+=head1 AUTHORS
+
+Originally designed and implemented by Malcolm Beattie,
+mbeattie@sable.ox.ac.uk as part of Safe version 1.
+
+Split out from Safe module version 1, named opcode tags and other
+changes added by Tim Bunce.
+
+=cut
+
diff --git a/contrib/perl5/ext/Opcode/Opcode.xs b/contrib/perl5/ext/Opcode/Opcode.xs
new file mode 100644
index 000000000000..e853cf19a364
--- /dev/null
+++ b/contrib/perl5/ext/Opcode/Opcode.xs
@@ -0,0 +1,468 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* PL_maxo shouldn't differ from MAXO but leave room anyway (see BOOT:) */
+#define OP_MASK_BUF_SIZE (MAXO + 100)
+
+/* XXX op_named_bits and opset_all are never freed */
+static HV *op_named_bits; /* cache shared for whole process */
+static SV *opset_all; /* mask with all bits set */
+static IV opset_len; /* length of opmasks in bytes */
+static int opcode_debug = 0;
+
+static SV *new_opset _((SV *old_opset));
+static int verify_opset _((SV *opset, int fatal));
+static void set_opset_bits _((char *bitmap, SV *bitspec, int on, char *opname));
+static void put_op_bitspec _((char *optag, STRLEN len, SV *opset));
+static SV *get_op_bitspec _((char *opname, STRLEN len, int fatal));
+
+
+/* Initialise our private op_named_bits HV.
+ * It is first loaded with the name and number of each perl operator.
+ * Then the builtin tags :none and :all are added.
+ * Opcode.pm loads the standard optags from __DATA__
+ * XXX leak-alert: data allocated here is never freed, call this
+ * at most once
+ */
+
+static void
+op_names_init(void)
+{
+ int i;
+ STRLEN len;
+ char **op_names;
+ char *bitmap;
+
+ op_named_bits = newHV();
+ op_names = get_op_names();
+ for(i=0; i < PL_maxo; ++i) {
+ SV *sv;
+ sv = newSViv(i);
+ SvREADONLY_on(sv);
+ hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0);
+ }
+
+ put_op_bitspec(":none",0, sv_2mortal(new_opset(Nullsv)));
+
+ opset_all = new_opset(Nullsv);
+ bitmap = SvPV(opset_all, len);
+ i = len-1; /* deal with last byte specially, see below */
+ while(i-- > 0)
+ bitmap[i] = 0xFF;
+ /* Take care to set the right number of bits in the last byte */
+ bitmap[len-1] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF;
+ put_op_bitspec(":all",0, opset_all); /* don't mortalise */
+}
+
+
+/* Store a new tag definition. Always a mask.
+ * The tag must not already be defined.
+ * SV *mask is copied not referenced.
+ */
+
+static void
+put_op_bitspec(char *optag, STRLEN len, SV *mask)
+{
+ SV **svp;
+ verify_opset(mask,1);
+ if (!len)
+ len = strlen(optag);
+ svp = hv_fetch(op_named_bits, optag, len, 1);
+ if (SvOK(*svp))
+ croak("Opcode tag \"%s\" already defined", optag);
+ sv_setsv(*svp, mask);
+ SvREADONLY_on(*svp);
+}
+
+
+
+/* Fetch a 'bits' entry for an opname or optag (IV/PV).
+ * Note that we return the actual entry for speed.
+ * Always sv_mortalcopy() if returing it to user code.
+ */
+
+static SV *
+get_op_bitspec(char *opname, STRLEN len, int fatal)
+{
+ SV **svp;
+ if (!len)
+ len = strlen(opname);
+ svp = hv_fetch(op_named_bits, opname, len, 0);
+ if (!svp || !SvOK(*svp)) {
+ if (!fatal)
+ return Nullsv;
+ if (*opname == ':')
+ croak("Unknown operator tag \"%s\"", opname);
+ if (*opname == '!') /* XXX here later, or elsewhere? */
+ croak("Can't negate operators here (\"%s\")", opname);
+ if (isALPHA(*opname))
+ croak("Unknown operator name \"%s\"", opname);
+ croak("Unknown operator prefix \"%s\"", opname);
+ }
+ return *svp;
+}
+
+
+
+static SV *
+new_opset(SV *old_opset)
+{
+ SV *opset;
+ if (old_opset) {
+ verify_opset(old_opset,1);
+ opset = newSVsv(old_opset);
+ }
+ else {
+ opset = NEWSV(1156, opset_len);
+ Zero(SvPVX(opset), opset_len + 1, char);
+ SvCUR_set(opset, opset_len);
+ (void)SvPOK_only(opset);
+ }
+ /* not mortalised here */
+ return opset;
+}
+
+
+static int
+verify_opset(SV *opset, int fatal)
+{
+ char *err = Nullch;
+ if (!SvOK(opset)) err = "undefined";
+ else if (!SvPOK(opset)) err = "wrong type";
+ else if (SvCUR(opset) != opset_len) err = "wrong size";
+ if (err && fatal) {
+ croak("Invalid opset: %s", err);
+ }
+ return !err;
+}
+
+
+static void
+set_opset_bits(char *bitmap, SV *bitspec, int on, char *opname)
+{
+ if (SvIOK(bitspec)) {
+ int myopcode = SvIV(bitspec);
+ int offset = myopcode >> 3;
+ int bit = myopcode & 0x07;
+ if (myopcode >= PL_maxo || myopcode < 0)
+ croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode);
+ if (opcode_debug >= 2)
+ warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n",
+ myopcode, offset, bit, opname, (on)?"on":"off");
+ if (on)
+ bitmap[offset] |= 1 << bit;
+ else
+ bitmap[offset] &= ~(1 << bit);
+ }
+ else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
+
+ STRLEN len;
+ char *specbits = SvPV(bitspec, len);
+ if (opcode_debug >= 2)
+ warn("set_opset_bits opset %s %s\n", opname, (on)?"on":"off");
+ if (on)
+ while(len-- > 0) bitmap[len] |= specbits[len];
+ else
+ while(len-- > 0) bitmap[len] &= ~specbits[len];
+ }
+ else
+ croak("panic: invalid bitspec for \"%s\" (type %u)",
+ opname, (unsigned)SvTYPE(bitspec));
+}
+
+
+static void
+opmask_add(SV *opset) /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */
+{
+ int i,j;
+ char *bitmask;
+ STRLEN len;
+ int myopcode = 0;
+
+ verify_opset(opset,1); /* croaks on bad opset */
+
+ if (!PL_op_mask) /* caller must ensure PL_op_mask exists */
+ croak("Can't add to uninitialised PL_op_mask");
+
+ /* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal() */
+
+ bitmask = SvPV(opset, len);
+ for (i=0; i < opset_len; i++) {
+ U16 bits = bitmask[i];
+ if (!bits) { /* optimise for sparse masks */
+ myopcode += 8;
+ continue;
+ }
+ for (j=0; j < 8 && myopcode < PL_maxo; )
+ PL_op_mask[myopcode++] |= bits & (1 << j++);
+ }
+}
+
+static void
+opmask_addlocal(SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */
+{
+ char *orig_op_mask = PL_op_mask;
+ SAVEPPTR(PL_op_mask);
+#if !defined(PERL_OBJECT)
+ /* XXX casting to an ordinary function ptr from a member function ptr
+ * is disallowed by Borland
+ */
+ if (opcode_debug >= 2)
+ SAVEDESTRUCTOR((void(CPERLscope(*))_((void*)))warn,"PL_op_mask restored");
+#endif
+ PL_op_mask = &op_mask_buf[0];
+ if (orig_op_mask)
+ Copy(orig_op_mask, PL_op_mask, PL_maxo, char);
+ else
+ Zero(PL_op_mask, PL_maxo, char);
+ opmask_add(opset);
+}
+
+
+
+MODULE = Opcode PACKAGE = Opcode
+
+PROTOTYPES: ENABLE
+
+BOOT:
+ assert(PL_maxo < OP_MASK_BUF_SIZE);
+ opset_len = (PL_maxo + 7) / 8;
+ if (opcode_debug >= 1)
+ warn("opset_len %ld\n", (long)opset_len);
+ op_names_init();
+
+
+void
+_safe_call_sv(Package, mask, codesv)
+ char * Package
+ SV * mask
+ SV * codesv
+PPCODE:
+ char op_mask_buf[OP_MASK_BUF_SIZE];
+ GV *gv;
+
+ ENTER;
+
+ opmask_addlocal(mask, op_mask_buf);
+
+ save_aptr(&PL_endav);
+ PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */
+
+ save_hptr(&PL_defstash); /* save current default stack */
+ /* the assignment to global defstash changes our sense of 'main' */
+ PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */
+
+ /* defstash must itself contain a main:: so we'll add that now */
+ /* take care with the ref counts (was cause of long standing bug) */
+ /* XXX I'm still not sure if this is right, GV_ADDWARN should warn! */
+ gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV);
+ sv_free((SV*)GvHV(gv));
+ GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
+
+ PUSHMARK(SP);
+ perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */
+ SPAGAIN; /* for the PUTBACK added by xsubpp */
+ LEAVE;
+
+
+int
+verify_opset(opset, fatal = 0)
+ SV *opset
+ int fatal
+
+
+void
+invert_opset(opset)
+ SV *opset
+CODE:
+ {
+ char *bitmap;
+ STRLEN len = opset_len;
+ opset = sv_2mortal(new_opset(opset)); /* verify and clone opset */
+ bitmap = SvPVX(opset);
+ while(len-- > 0)
+ bitmap[len] = ~bitmap[len];
+ /* take care of extra bits beyond PL_maxo in last byte */
+ if (PL_maxo & 07)
+ bitmap[opset_len-1] &= ~(0xFF << (PL_maxo & 0x07));
+ }
+ ST(0) = opset;
+
+
+void
+opset_to_ops(opset, desc = 0)
+ SV *opset
+ int desc
+PPCODE:
+ {
+ STRLEN len;
+ int i, j, myopcode;
+ char *bitmap = SvPV(opset, len);
+ char **names = (desc) ? get_op_descs() : get_op_names();
+ verify_opset(opset,1);
+ for (myopcode=0, i=0; i < opset_len; i++) {
+ U16 bits = bitmap[i];
+ for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) {
+ if ( bits & (1 << j) )
+ XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0)));
+ }
+ }
+ }
+
+
+void
+opset(...)
+CODE:
+ int i, j;
+ SV *bitspec, *opset;
+ char *bitmap;
+ STRLEN len, on;
+ opset = sv_2mortal(new_opset(Nullsv));
+ bitmap = SvPVX(opset);
+ for (i = 0; i < items; i++) {
+ char *opname;
+ on = 1;
+ if (verify_opset(ST(i),0)) {
+ opname = "(opset)";
+ bitspec = ST(i);
+ }
+ else {
+ opname = SvPV(ST(i), len);
+ if (*opname == '!') { on=0; ++opname;--len; }
+ bitspec = get_op_bitspec(opname, len, 1);
+ }
+ set_opset_bits(bitmap, bitspec, on, opname);
+ }
+ ST(0) = opset;
+
+
+#define PERMITING (ix == 0 || ix == 1)
+#define ONLY_THESE (ix == 0 || ix == 2)
+
+void
+permit_only(safe, ...)
+ SV *safe
+ALIAS:
+ permit = 1
+ deny_only = 2
+ deny = 3
+CODE:
+ int i, on;
+ SV *bitspec, *mask;
+ char *bitmap, *opname;
+ STRLEN len;
+
+ if (!SvROK(safe) || !SvOBJECT(SvRV(safe)) || SvTYPE(SvRV(safe))!=SVt_PVHV)
+ croak("Not a Safe object");
+ mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1);
+ if (ONLY_THESE) /* *_only = new mask, else edit current */
+ sv_setsv(mask, sv_2mortal(new_opset(PERMITING ? opset_all : Nullsv)));
+ else
+ verify_opset(mask,1); /* croaks */
+ bitmap = SvPVX(mask);
+ for (i = 1; i < items; i++) {
+ on = PERMITING ? 0 : 1; /* deny = mask bit on */
+ if (verify_opset(ST(i),0)) { /* it's a valid mask */
+ opname = "(opset)";
+ bitspec = ST(i);
+ }
+ else { /* it's an opname/optag */
+ opname = SvPV(ST(i), len);
+ /* invert if op has ! prefix (only one allowed) */
+ if (*opname == '!') { on = !on; ++opname; --len; }
+ bitspec = get_op_bitspec(opname, len, 1); /* croaks */
+ }
+ set_opset_bits(bitmap, bitspec, on, opname);
+ }
+ ST(0) = &PL_sv_yes;
+
+
+
+void
+opdesc(...)
+PPCODE:
+ int i, myopcode;
+ STRLEN len;
+ SV **args;
+ char **op_desc = get_op_descs();
+ /* copy args to a scratch area since we may push output values onto */
+ /* the stack faster than we read values off it if masks are used. */
+ args = (SV**)SvPVX(sv_2mortal(newSVpv((char*)&ST(0), items*sizeof(SV*))));
+ for (i = 0; i < items; i++) {
+ char *opname = SvPV(args[i], len);
+ SV *bitspec = get_op_bitspec(opname, len, 1);
+ if (SvIOK(bitspec)) {
+ myopcode = SvIV(bitspec);
+ if (myopcode < 0 || myopcode >= PL_maxo)
+ croak("panic: opcode %d (%s) out of range",myopcode,opname);
+ XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
+ }
+ else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
+ int b, j;
+ char *bitmap = SvPV(bitspec,PL_na);
+ myopcode = 0;
+ for (b=0; b < opset_len; b++) {
+ U16 bits = bitmap[b];
+ for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++)
+ if (bits & (1 << j))
+ XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
+ }
+ }
+ else
+ croak("panic: invalid bitspec for \"%s\" (type %u)",
+ opname, (unsigned)SvTYPE(bitspec));
+ }
+
+
+void
+define_optag(optagsv, mask)
+ SV *optagsv
+ SV *mask
+CODE:
+ STRLEN len;
+ char *optag = SvPV(optagsv, len);
+ put_op_bitspec(optag, len, mask); /* croaks */
+ ST(0) = &PL_sv_yes;
+
+
+void
+empty_opset()
+CODE:
+ ST(0) = sv_2mortal(new_opset(Nullsv));
+
+void
+full_opset()
+CODE:
+ ST(0) = sv_2mortal(new_opset(opset_all));
+
+void
+opmask_add(opset)
+ SV *opset
+PREINIT:
+ if (!PL_op_mask)
+ Newz(0, PL_op_mask, PL_maxo, char);
+
+void
+opcodes()
+PPCODE:
+ if (GIMME == G_ARRAY) {
+ croak("opcodes in list context not yet implemented"); /* XXX */
+ }
+ else {
+ XPUSHs(sv_2mortal(newSViv(PL_maxo)));
+ }
+
+void
+opmask()
+CODE:
+ ST(0) = sv_2mortal(new_opset(Nullsv));
+ if (PL_op_mask) {
+ char *bitmap = SvPVX(ST(0));
+ int myopcode;
+ for(myopcode=0; myopcode < PL_maxo; ++myopcode) {
+ if (PL_op_mask[myopcode])
+ bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07);
+ }
+ }
+
diff --git a/contrib/perl5/ext/Opcode/Safe.pm b/contrib/perl5/ext/Opcode/Safe.pm
new file mode 100644
index 000000000000..940a972fd1b6
--- /dev/null
+++ b/contrib/perl5/ext/Opcode/Safe.pm
@@ -0,0 +1,559 @@
+package Safe;
+
+use 5.003_11;
+use strict;
+use vars qw($VERSION);
+
+$VERSION = "2.06";
+
+use Carp;
+
+use Opcode 1.01, qw(
+ opset opset_to_ops opmask_add
+ empty_opset full_opset invert_opset verify_opset
+ opdesc opcodes opmask define_optag opset_to_hex
+);
+
+*ops_to_opset = \&opset; # Temporary alias for old Penguins
+
+
+my $default_root = 0;
+my $default_share = ['*_']; #, '*main::'];
+
+sub new {
+ my($class, $root, $mask) = @_;
+ my $obj = {};
+ bless $obj, $class;
+
+ if (defined($root)) {
+ croak "Can't use \"$root\" as root name"
+ if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
+ $obj->{Root} = $root;
+ $obj->{Erase} = 0;
+ }
+ else {
+ $obj->{Root} = "Safe::Root".$default_root++;
+ $obj->{Erase} = 1;
+ }
+
+ # use permit/deny methods instead till interface issues resolved
+ # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
+ croak "Mask parameter to new no longer supported" if defined $mask;
+ $obj->permit_only(':default');
+
+ # We must share $_ and @_ with the compartment or else ops such
+ # as split, length and so on won't default to $_ properly, nor
+ # will passing argument to subroutines work (via @_). In fact,
+ # for reasons I don't completely understand, we need to share
+ # the whole glob *_ rather than $_ and @_ separately, otherwise
+ # @_ in non default packages within the compartment don't work.
+ $obj->share_from('main', $default_share);
+ return $obj;
+}
+
+sub DESTROY {
+ my $obj = shift;
+ $obj->erase('DESTROY') if $obj->{Erase};
+}
+
+sub erase {
+ my ($obj, $action) = @_;
+ my $pkg = $obj->root();
+ my ($stem, $leaf);
+
+ no strict 'refs';
+ $pkg = "main::$pkg\::"; # expand to full symbol table name
+ ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+
+ # The 'my $foo' is needed! Without it you get an
+ # 'Attempt to free unreferenced scalar' warning!
+ my $stem_symtab = *{$stem}{HASH};
+
+ #warn "erase($pkg) stem=$stem, leaf=$leaf";
+ #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
+ # ", join(', ', %$stem_symtab),"\n";
+
+# delete $stem_symtab->{$leaf};
+
+ my $leaf_glob = $stem_symtab->{$leaf};
+ my $leaf_symtab = *{$leaf_glob}{HASH};
+# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
+ %$leaf_symtab = ();
+ #delete $leaf_symtab->{'__ANON__'};
+ #delete $leaf_symtab->{'foo'};
+ #delete $leaf_symtab->{'main::'};
+# my $foo = undef ${"$stem\::"}{"$leaf\::"};
+
+ if ($action and $action eq 'DESTROY') {
+ delete $stem_symtab->{$leaf};
+ } else {
+ $obj->share_from('main', $default_share);
+ }
+ 1;
+}
+
+
+sub reinit {
+ my $obj= shift;
+ $obj->erase;
+ $obj->share_redo;
+}
+
+sub root {
+ my $obj = shift;
+ croak("Safe root method now read-only") if @_;
+ return $obj->{Root};
+}
+
+
+sub mask {
+ my $obj = shift;
+ return $obj->{Mask} unless @_;
+ $obj->deny_only(@_);
+}
+
+# v1 compatibility methods
+sub trap { shift->deny(@_) }
+sub untrap { shift->permit(@_) }
+
+sub deny {
+ my $obj = shift;
+ $obj->{Mask} |= opset(@_);
+}
+sub deny_only {
+ my $obj = shift;
+ $obj->{Mask} = opset(@_);
+}
+
+sub permit {
+ my $obj = shift;
+ # XXX needs testing
+ $obj->{Mask} &= invert_opset opset(@_);
+}
+sub permit_only {
+ my $obj = shift;
+ $obj->{Mask} = invert_opset opset(@_);
+}
+
+
+sub dump_mask {
+ my $obj = shift;
+ print opset_to_hex($obj->{Mask}),"\n";
+}
+
+
+
+sub share {
+ my($obj, @vars) = @_;
+ $obj->share_from(scalar(caller), \@vars);
+}
+
+sub share_from {
+ my $obj = shift;
+ my $pkg = shift;
+ my $vars = shift;
+ my $no_record = shift || 0;
+ my $root = $obj->root();
+ croak("vars not an array ref") unless ref $vars eq 'ARRAY';
+ no strict 'refs';
+ # Check that 'from' package actually exists
+ croak("Package \"$pkg\" does not exist")
+ unless keys %{"$pkg\::"};
+ my $arg;
+ foreach $arg (@$vars) {
+ # catch some $safe->share($var) errors:
+ croak("'$arg' not a valid symbol table name")
+ unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/
+ or $arg =~ /^\$\W$/;
+ my ($var, $type);
+ $type = $1 if ($var = $arg) =~ s/^(\W)//;
+ # warn "share_from $pkg $type $var";
+ *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
+ : ($type eq '&') ? \&{$pkg."::$var"}
+ : ($type eq '$') ? \${$pkg."::$var"}
+ : ($type eq '@') ? \@{$pkg."::$var"}
+ : ($type eq '%') ? \%{$pkg."::$var"}
+ : ($type eq '*') ? *{$pkg."::$var"}
+ : croak(qq(Can't share "$type$var" of unknown type));
+ }
+ $obj->share_record($pkg, $vars) unless $no_record or !$vars;
+}
+
+sub share_record {
+ my $obj = shift;
+ my $pkg = shift;
+ my $vars = shift;
+ my $shares = \%{$obj->{Shares} ||= {}};
+ # Record shares using keys of $obj->{Shares}. See reinit.
+ @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
+}
+sub share_redo {
+ my $obj = shift;
+ my $shares = \%{$obj->{Shares} ||= {}};
+ my($var, $pkg);
+ while(($var, $pkg) = each %$shares) {
+ # warn "share_redo $pkg\:: $var";
+ $obj->share_from($pkg, [ $var ], 1);
+ }
+}
+sub share_forget {
+ delete shift->{Shares};
+}
+
+sub varglob {
+ my ($obj, $var) = @_;
+ no strict 'refs';
+ return *{$obj->root()."::$var"};
+}
+
+
+sub reval {
+ my ($obj, $expr, $strict) = @_;
+ my $root = $obj->{Root};
+
+ # Create anon sub ref in root of compartment.
+ # Uses a closure (on $expr) to pass in the code to be executed.
+ # (eval on one line to keep line numbers as expected by caller)
+ my $evalcode = sprintf('package %s; sub { eval $expr; }', $root);
+ my $evalsub;
+
+ if ($strict) { use strict; $evalsub = eval $evalcode; }
+ else { no strict; $evalsub = eval $evalcode; }
+
+ return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+}
+
+sub rdo {
+ my ($obj, $file) = @_;
+ my $root = $obj->{Root};
+
+ my $evalsub = eval
+ sprintf('package %s; sub { do $file }', $root);
+ return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+}
+
+
+1;
+
+__DATA__
+
+=head1 NAME
+
+Safe - Compile and execute code in restricted compartments
+
+=head1 SYNOPSIS
+
+ use Safe;
+
+ $compartment = new Safe;
+
+ $compartment->permit(qw(time sort :browse));
+
+ $result = $compartment->reval($unsafe_code);
+
+=head1 DESCRIPTION
+
+The Safe extension module allows the creation of compartments
+in which perl code can be evaluated. Each compartment has
+
+=over 8
+
+=item a new namespace
+
+The "root" of the namespace (i.e. "main::") is changed to a
+different package and code evaluated in the compartment cannot
+refer to variables outside this namespace, even with run-time
+glob lookups and other tricks.
+
+Code which is compiled outside the compartment can choose to place
+variables into (or I<share> variables with) the compartment's namespace
+and only that data will be visible to code evaluated in the
+compartment.
+
+By default, the only variables shared with compartments are the
+"underscore" variables $_ and @_ (and, technically, the less frequently
+used %_, the _ filehandle and so on). This is because otherwise perl
+operators which default to $_ will not work and neither will the
+assignment of arguments to @_ on subroutine entry.
+
+=item an operator mask
+
+Each compartment has an associated "operator mask". Recall that
+perl code is compiled into an internal format before execution.
+Evaluating perl code (e.g. via "eval" or "do 'file'") causes
+the code to be compiled into an internal format and then,
+provided there was no error in the compilation, executed.
+Code evaulated in a compartment compiles subject to the
+compartment's operator mask. Attempting to evaulate code in a
+compartment which contains a masked operator will cause the
+compilation to fail with an error. The code will not be executed.
+
+The default operator mask for a newly created compartment is
+the ':default' optag.
+
+It is important that you read the Opcode(3) module documentation
+for more information, especially for detailed definitions of opnames,
+optags and opsets.
+
+Since it is only at the compilation stage that the operator mask
+applies, controlled access to potentially unsafe operations can
+be achieved by having a handle to a wrapper subroutine (written
+outside the compartment) placed into the compartment. For example,
+
+ $cpt = new Safe;
+ sub wrapper {
+ # vet arguments and perform potentially unsafe operations
+ }
+ $cpt->share('&wrapper');
+
+=back
+
+
+=head1 WARNING
+
+The authors make B<no warranty>, implied or otherwise, about the
+suitability of this software for safety or security purposes.
+
+The authors shall not in any case be liable for special, incidental,
+consequential, indirect or other similar damages arising from the use
+of this software.
+
+Your mileage will vary. If in any doubt B<do not use it>.
+
+
+=head2 RECENT CHANGES
+
+The interface to the Safe module has changed quite dramatically since
+version 1 (as supplied with Perl5.002). Study these pages carefully if
+you have code written to use Safe version 1 because you will need to
+makes changes.
+
+
+=head2 Methods in class Safe
+
+To create a new compartment, use
+
+ $cpt = new Safe;
+
+Optional argument is (NAMESPACE), where NAMESPACE is the root namespace
+to use for the compartment (defaults to "Safe::Root0", incremented for
+each new compartment).
+
+Note that version 1.00 of the Safe module supported a second optional
+parameter, MASK. That functionality has been withdrawn pending deeper
+consideration. Use the permit and deny methods described below.
+
+The following methods can then be used on the compartment
+object returned by the above constructor. The object argument
+is implicit in each case.
+
+
+=over 8
+
+=item permit (OP, ...)
+
+Permit the listed operators to be used when compiling code in the
+compartment (in I<addition> to any operators already permitted).
+
+=item permit_only (OP, ...)
+
+Permit I<only> the listed operators to be used when compiling code in
+the compartment (I<no> other operators are permitted).
+
+=item deny (OP, ...)
+
+Deny the listed operators from being used when compiling code in the
+compartment (other operators may still be permitted).
+
+=item deny_only (OP, ...)
+
+Deny I<only> the listed operators from being used when compiling code
+in the compartment (I<all> other operators will be permitted).
+
+=item trap (OP, ...)
+
+=item untrap (OP, ...)
+
+The trap and untrap methods are synonyms for deny and permit
+respectfully.
+
+=item share (NAME, ...)
+
+This shares the variable(s) in the argument list with the compartment.
+This is almost identical to exporting variables using the L<Exporter(3)>
+module.
+
+Each NAME must be the B<name> of a variable, typically with the leading
+type identifier included. A bareword is treated as a function name.
+
+Examples of legal names are '$foo' for a scalar, '@foo' for an
+array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
+for a glob (i.e. all symbol table entries associated with "foo",
+including scalar, array, hash, sub and filehandle).
+
+Each NAME is assumed to be in the calling package. See share_from
+for an alternative method (which share uses).
+
+=item share_from (PACKAGE, ARRAYREF)
+
+This method is similar to share() but allows you to explicitly name the
+package that symbols should be shared from. The symbol names (including
+type characters) are supplied as an array reference.
+
+ $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
+
+
+=item varglob (VARNAME)
+
+This returns a glob reference for the symbol table entry of VARNAME in
+the package of the compartment. VARNAME must be the B<name> of a
+variable without any leading type marker. For example,
+
+ $cpt = new Safe 'Root';
+ $Root::foo = "Hello world";
+ # Equivalent version which doesn't need to know $cpt's package name:
+ ${$cpt->varglob('foo')} = "Hello world";
+
+
+=item reval (STRING)
+
+This evaluates STRING as perl code inside the compartment.
+
+The code can only see the compartment's namespace (as returned by the
+B<root> method). The compartment's root package appears to be the
+C<main::> package to the code inside the compartment.
+
+Any attempt by the code in STRING to use an operator which is not permitted
+by the compartment will cause an error (at run-time of the main program
+but at compile-time for the code in STRING). The error is of the form
+"%s trapped by operation mask operation...".
+
+If an operation is trapped in this way, then the code in STRING will
+not be executed. If such a trapped operation occurs or any other
+compile-time or return error, then $@ is set to the error message, just
+as with an eval().
+
+If there is no error, then the method returns the value of the last
+expression evaluated, or a return statement may be used, just as with
+subroutines and B<eval()>. The context (list or scalar) is determined
+by the caller as usual.
+
+This behaviour differs from the beta distribution of the Safe extension
+where earlier versions of perl made it hard to mimic the return
+behaviour of the eval() command and the context was always scalar.
+
+Some points to note:
+
+If the entereval op is permitted then the code can use eval "..." to
+'hide' code which might use denied ops. This is not a major problem
+since when the code tries to execute the eval it will fail because the
+opmask is still in effect. However this technique would allow clever,
+and possibly harmful, code to 'probe' the boundaries of what is
+possible.
+
+Any string eval which is executed by code executing in a compartment,
+or by code called from code executing in a compartment, will be eval'd
+in the namespace of the compartment. This is potentially a serious
+problem.
+
+Consider a function foo() in package pkg compiled outside a compartment
+but shared with it. Assume the compartment has a root package called
+'Root'. If foo() contains an eval statement like eval '$foo = 1' then,
+normally, $pkg::foo will be set to 1. If foo() is called from the
+compartment (by whatever means) then instead of setting $pkg::foo, the
+eval will actually set $Root::pkg::foo.
+
+This can easily be demonstrated by using a module, such as the Socket
+module, which uses eval "..." as part of an AUTOLOAD function. You can
+'use' the module outside the compartment and share an (autoloaded)
+function with the compartment. If an autoload is triggered by code in
+the compartment, or by any code anywhere that is called by any means
+from the compartment, then the eval in the Socket module's AUTOLOAD
+function happens in the namespace of the compartment. Any variables
+created or used by the eval'd code are now under the control of
+the code in the compartment.
+
+A similar effect applies to I<all> runtime symbol lookups in code
+called from a compartment but not compiled within it.
+
+
+
+=item rdo (FILENAME)
+
+This evaluates the contents of file FILENAME inside the compartment.
+See above documentation on the B<reval> method for further details.
+
+=item root (NAMESPACE)
+
+This method returns the name of the package that is the root of the
+compartment's namespace.
+
+Note that this behaviour differs from version 1.00 of the Safe module
+where the root module could be used to change the namespace. That
+functionality has been withdrawn pending deeper consideration.
+
+=item mask (MASK)
+
+This is a get-or-set method for the compartment's operator mask.
+
+With no MASK argument present, it returns the current operator mask of
+the compartment.
+
+With the MASK argument present, it sets the operator mask for the
+compartment (equivalent to calling the deny_only method).
+
+=back
+
+
+=head2 Some Safety Issues
+
+This section is currently just an outline of some of the things code in
+a compartment might do (intentionally or unintentionally) which can
+have an effect outside the compartment.
+
+=over 8
+
+=item Memory
+
+Consuming all (or nearly all) available memory.
+
+=item CPU
+
+Causing infinite loops etc.
+
+=item Snooping
+
+Copying private information out of your system. Even something as
+simple as your user name is of value to others. Much useful information
+could be gleaned from your environment variables for example.
+
+=item Signals
+
+Causing signals (especially SIGFPE and SIGALARM) to affect your process.
+
+Setting up a signal handler will need to be carefully considered
+and controlled. What mask is in effect when a signal handler
+gets called? If a user can get an imported function to get an
+exception and call the user's signal handler, does that user's
+restricted mask get re-instated before the handler is called?
+Does an imported handler get called with its original mask or
+the user's one?
+
+=item State Changes
+
+Ops such as chdir obviously effect the process as a whole and not just
+the code in the compartment. Ops such as rand and srand have a similar
+but more subtle effect.
+
+=back
+
+=head2 AUTHOR
+
+Originally designed and implemented by Malcolm Beattie,
+mbeattie@sable.ox.ac.uk.
+
+Reworked to use the Opcode module and other changes added by Tim Bunce
+E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
+
+=cut
+
diff --git a/contrib/perl5/ext/Opcode/ops.pm b/contrib/perl5/ext/Opcode/ops.pm
new file mode 100644
index 000000000000..b9ea36cef39e
--- /dev/null
+++ b/contrib/perl5/ext/Opcode/ops.pm
@@ -0,0 +1,45 @@
+package ops;
+
+use Opcode qw(opmask_add opset invert_opset);
+
+sub import {
+ shift;
+ # Not that unimport is the prefered form since import's don't
+ # accumulate well owing to the 'only ever add opmask' rule.
+ # E.g., perl -Mops=:set1 -Mops=:setb is unlikely to do as expected.
+ opmask_add(invert_opset opset(@_)) if @_;
+}
+
+sub unimport {
+ shift;
+ opmask_add(opset(@_)) if @_;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ops - Perl pragma to restrict unsafe operations when compiling
+
+=head1 SYNOPSIS
+
+ perl -Mops=:default ... # only allow reasonably safe operations
+
+ perl -M-ops=system ... # disable the 'system' opcode
+
+=head1 DESCRIPTION
+
+Since the ops pragma currently has an irreversable global effect, it is
+only of significant practical use with the C<-M> option on the command line.
+
+See the L<Opcode> module for information about opcodes, optags, opmasks
+and important information about safety.
+
+=head1 SEE ALSO
+
+Opcode(3), Safe(3), perlrun(3)
+
+=cut
+
diff --git a/contrib/perl5/ext/POSIX/Makefile.PL b/contrib/perl5/ext/POSIX/Makefile.PL
new file mode 100644
index 000000000000..bc1dda9387b3
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/Makefile.PL
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'POSIX',
+ ($^O eq 'MSWin32' ? () : (LIBS => ["-lm -lposix -lcposix"])),
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'POSIX.pm',
+);
diff --git a/contrib/perl5/ext/POSIX/POSIX.pm b/contrib/perl5/ext/POSIX/POSIX.pm
new file mode 100644
index 000000000000..5d3ef5cb5031
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/POSIX.pm
@@ -0,0 +1,926 @@
+package POSIX;
+
+use vars qw($VERSION @ISA %EXPORT_TAGS @EXPORT_OK $AUTOLOAD);
+
+use Carp;
+use AutoLoader;
+require Config;
+use Symbol;
+
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+
+$VERSION = "1.02" ;
+
+%EXPORT_TAGS = (
+
+ assert_h => [qw(assert NDEBUG)],
+
+ ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower
+ isprint ispunct isspace isupper isxdigit tolower toupper)],
+
+ dirent_h => [qw()],
+
+ errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
+ EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
+ ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
+ EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
+ EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
+ EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
+ ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
+ ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
+ ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
+ EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
+ ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
+ ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
+ EUSERS EWOULDBLOCK EXDEV errno)],
+
+ fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK
+ F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK
+ O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK
+ O_RDONLY O_RDWR O_TRUNC O_WRONLY
+ creat
+ SEEK_CUR SEEK_END SEEK_SET
+ S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
+ S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID
+ S_IWGRP S_IWOTH S_IWUSR)],
+
+ float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG
+ DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP
+ DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP
+ FLT_DIG FLT_EPSILON FLT_MANT_DIG
+ FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP
+ FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP
+ FLT_RADIX FLT_ROUNDS
+ LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG
+ LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP
+ LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)],
+
+ grp_h => [qw()],
+
+ limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX
+ INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON
+ MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX
+ PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN
+ SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX
+ ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX
+ _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT
+ _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX
+ _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX
+ _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)],
+
+ locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC
+ LC_TIME NULL localeconv setlocale)],
+
+ math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod
+ frexp ldexp log10 modf pow sinh tan tanh)],
+
+ pwd_h => [qw()],
+
+ setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)],
+
+ signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK
+ SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM
+ SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL
+ SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN
+ SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR
+ SIG_IGN SIG_SETMASK SIG_UNBLOCK raise sigaction signal
+ sigpending sigprocmask sigsuspend)],
+
+ stdarg_h => [qw()],
+
+ stddef_h => [qw(NULL offsetof)],
+
+ stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid
+ L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET
+ STREAM_MAX TMP_MAX stderr stdin stdout
+ clearerr fclose fdopen feof ferror fflush fgetc fgetpos
+ fgets fopen fprintf fputc fputs fread freopen
+ fscanf fseek fsetpos ftell fwrite getchar gets
+ perror putc putchar puts remove rewind
+ scanf setbuf setvbuf sscanf tmpfile tmpnam
+ ungetc vfprintf vprintf vsprintf)],
+
+ stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX
+ abort atexit atof atoi atol bsearch calloc div
+ free getenv labs ldiv malloc mblen mbstowcs mbtowc
+ qsort realloc strtod strtol strtoul wcstombs wctomb)],
+
+ string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat
+ strchr strcmp strcoll strcpy strcspn strerror strlen
+ strncat strncmp strncpy strpbrk strrchr strspn strstr
+ strtok strxfrm)],
+
+ sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
+ S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG
+ S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
+ fstat mkfifo)],
+
+ sys_times_h => [qw()],
+
+ sys_types_h => [qw()],
+
+ sys_utsname_h => [qw(uname)],
+
+ sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
+ WNOHANG WSTOPSIG WTERMSIG WUNTRACED)],
+
+ termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400
+ B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL
+ CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK
+ ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR
+ INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST
+ PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION
+ TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW
+ TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART
+ VSTOP VSUSP VTIME
+ cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain
+ tcflow tcflush tcgetattr tcsendbreak tcsetattr )],
+
+ time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime
+ difftime mktime strftime tzset tzname)],
+
+ unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET
+ STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK
+ _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON
+ _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX
+ _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED
+ _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS
+ _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX
+ _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL
+ _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS
+ _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION
+ _exit access ctermid cuserid
+ dup2 dup execl execle execlp execv execve execvp
+ fpathconf getcwd getegid geteuid getgid getgroups
+ getpid getuid isatty lseek pathconf pause setgid setpgid
+ setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)],
+
+ utime_h => [qw()],
+
+);
+
+Exporter::export_tags();
+
+@EXPORT_OK = qw(
+ closedir opendir readdir rewinddir
+ fcntl open
+ getgrgid getgrnam
+ atan2 cos exp log sin sqrt
+ getpwnam getpwuid
+ kill
+ fileno getc printf rename sprintf
+ abs exit rand srand system
+ chmod mkdir stat umask
+ times
+ wait waitpid
+ gmtime localtime time
+ alarm chdir chown close fork getlogin getppid getpgrp link
+ pipe read rmdir sleep unlink write
+ utime
+ nice
+);
+
+# Grandfather old foo_h form to new :foo_h form
+sub import {
+ my $this = shift;
+ my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_;
+ local $Exporter::ExportLevel = 1;
+ Exporter::import($this,@list);
+}
+
+
+bootstrap POSIX $VERSION;
+
+my $EINVAL = constant("EINVAL", 0);
+my $EAGAIN = constant("EAGAIN", 0);
+
+sub AUTOLOAD {
+ if ($AUTOLOAD =~ /::(_?[a-z])/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD
+ }
+ local $! = 0;
+ my $constname = $AUTOLOAD;
+ $constname =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! == 0) {
+ *$AUTOLOAD = sub { $val };
+ }
+ elsif ($! == $EAGAIN) { # Not really a constant, so always call.
+ *$AUTOLOAD = sub { constant($constname, $_[0]) };
+ }
+ elsif ($! == $EINVAL) {
+ croak "$constname is not a valid POSIX macro";
+ }
+ else {
+ croak "Your vendor has not defined POSIX macro $constname, used";
+ }
+
+ goto &$AUTOLOAD;
+}
+
+sub usage {
+ my ($mess) = @_;
+ croak "Usage: POSIX::$mess";
+}
+
+sub redef {
+ my ($mess) = @_;
+ croak "Use method $mess instead";
+}
+
+sub unimpl {
+ my ($mess) = @_;
+ $mess =~ s/xxx//;
+ croak "Unimplemented: POSIX::$mess";
+}
+
+############################
+package POSIX::SigAction;
+
+sub new {
+ bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0}, $_[0];
+}
+
+############################
+package POSIX; # return to package POSIX so AutoSplit is happy
+1;
+__END__
+
+sub assert {
+ usage "assert(expr)" if @_ != 1;
+ if (!$_[0]) {
+ croak "Assertion failed";
+ }
+}
+
+sub tolower {
+ usage "tolower(string)" if @_ != 1;
+ lc($_[0]);
+}
+
+sub toupper {
+ usage "toupper(string)" if @_ != 1;
+ uc($_[0]);
+}
+
+sub closedir {
+ usage "closedir(dirhandle)" if @_ != 1;
+ closedir($_[0]);
+}
+
+sub opendir {
+ usage "opendir(directory)" if @_ != 1;
+ my $dirhandle = gensym;
+ opendir($dirhandle, $_[0])
+ ? $dirhandle
+ : undef;
+}
+
+sub readdir {
+ usage "readdir(dirhandle)" if @_ != 1;
+ readdir($_[0]);
+}
+
+sub rewinddir {
+ usage "rewinddir(dirhandle)" if @_ != 1;
+ rewinddir($_[0]);
+}
+
+sub errno {
+ usage "errno()" if @_ != 0;
+ $! + 0;
+}
+
+sub creat {
+ usage "creat(filename, mode)" if @_ != 2;
+ &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1]);
+}
+
+sub fcntl {
+ usage "fcntl(filehandle, cmd, arg)" if @_ != 3;
+ fcntl($_[0], $_[1], $_[2]);
+}
+
+sub getgrgid {
+ usage "getgrgid(gid)" if @_ != 1;
+ getgrgid($_[0]);
+}
+
+sub getgrnam {
+ usage "getgrnam(name)" if @_ != 1;
+ getgrnam($_[0]);
+}
+
+sub atan2 {
+ usage "atan2(x,y)" if @_ != 2;
+ atan2($_[0], $_[1]);
+}
+
+sub cos {
+ usage "cos(x)" if @_ != 1;
+ cos($_[0]);
+}
+
+sub exp {
+ usage "exp(x)" if @_ != 1;
+ exp($_[0]);
+}
+
+sub fabs {
+ usage "fabs(x)" if @_ != 1;
+ abs($_[0]);
+}
+
+sub log {
+ usage "log(x)" if @_ != 1;
+ log($_[0]);
+}
+
+sub pow {
+ usage "pow(x,exponent)" if @_ != 2;
+ $_[0] ** $_[1];
+}
+
+sub sin {
+ usage "sin(x)" if @_ != 1;
+ sin($_[0]);
+}
+
+sub sqrt {
+ usage "sqrt(x)" if @_ != 1;
+ sqrt($_[0]);
+}
+
+sub getpwnam {
+ usage "getpwnam(name)" if @_ != 1;
+ getpwnam($_[0]);
+}
+
+sub getpwuid {
+ usage "getpwuid(uid)" if @_ != 1;
+ getpwuid($_[0]);
+}
+
+sub longjmp {
+ unimpl "longjmp() is C-specific: use die instead";
+}
+
+sub setjmp {
+ unimpl "setjmp() is C-specific: use eval {} instead";
+}
+
+sub siglongjmp {
+ unimpl "siglongjmp() is C-specific: use die instead";
+}
+
+sub sigsetjmp {
+ unimpl "sigsetjmp() is C-specific: use eval {} instead";
+}
+
+sub kill {
+ usage "kill(pid, sig)" if @_ != 2;
+ kill $_[1], $_[0];
+}
+
+sub raise {
+ usage "raise(sig)" if @_ != 1;
+ kill $_[0], $$; # Is this good enough?
+}
+
+sub offsetof {
+ unimpl "offsetof() is C-specific, stopped";
+}
+
+sub clearerr {
+ redef "IO::Handle::clearerr()";
+}
+
+sub fclose {
+ redef "IO::Handle::close()";
+}
+
+sub fdopen {
+ redef "IO::Handle::new_from_fd()";
+}
+
+sub feof {
+ redef "IO::Handle::eof()";
+}
+
+sub fgetc {
+ redef "IO::Handle::getc()";
+}
+
+sub fgets {
+ redef "IO::Handle::gets()";
+}
+
+sub fileno {
+ redef "IO::Handle::fileno()";
+}
+
+sub fopen {
+ redef "IO::File::open()";
+}
+
+sub fprintf {
+ unimpl "fprintf() is C-specific--use printf instead";
+}
+
+sub fputc {
+ unimpl "fputc() is C-specific--use print instead";
+}
+
+sub fputs {
+ unimpl "fputs() is C-specific--use print instead";
+}
+
+sub fread {
+ unimpl "fread() is C-specific--use read instead";
+}
+
+sub freopen {
+ unimpl "freopen() is C-specific--use open instead";
+}
+
+sub fscanf {
+ unimpl "fscanf() is C-specific--use <> and regular expressions instead";
+}
+
+sub fseek {
+ redef "IO::Seekable::seek()";
+}
+
+sub ferror {
+ redef "IO::Handle::error()";
+}
+
+sub fflush {
+ redef "IO::Handle::flush()";
+}
+
+sub fgetpos {
+ redef "IO::Seekable::getpos()";
+}
+
+sub fsetpos {
+ redef "IO::Seekable::setpos()";
+}
+
+sub ftell {
+ redef "IO::Seekable::tell()";
+}
+
+sub fwrite {
+ unimpl "fwrite() is C-specific--use print instead";
+}
+
+sub getc {
+ usage "getc(handle)" if @_ != 1;
+ getc($_[0]);
+}
+
+sub getchar {
+ usage "getchar()" if @_ != 0;
+ getc(STDIN);
+}
+
+sub gets {
+ usage "gets()" if @_ != 0;
+ scalar <STDIN>;
+}
+
+sub perror {
+ print STDERR "@_: " if @_;
+ print STDERR $!,"\n";
+}
+
+sub printf {
+ usage "printf(pattern, args...)" if @_ < 1;
+ printf STDOUT @_;
+}
+
+sub putc {
+ unimpl "putc() is C-specific--use print instead";
+}
+
+sub putchar {
+ unimpl "putchar() is C-specific--use print instead";
+}
+
+sub puts {
+ unimpl "puts() is C-specific--use print instead";
+}
+
+sub remove {
+ usage "remove(filename)" if @_ != 1;
+ unlink($_[0]);
+}
+
+sub rename {
+ usage "rename(oldfilename, newfilename)" if @_ != 2;
+ rename($_[0], $_[1]);
+}
+
+sub rewind {
+ usage "rewind(filehandle)" if @_ != 1;
+ seek($_[0],0,0);
+}
+
+sub scanf {
+ unimpl "scanf() is C-specific--use <> and regular expressions instead";
+}
+
+sub sprintf {
+ usage "sprintf(pattern,args)" if @_ == 0;
+ sprintf(shift,@_);
+}
+
+sub sscanf {
+ unimpl "sscanf() is C-specific--use regular expressions instead";
+}
+
+sub tmpfile {
+ redef "IO::File::new_tmpfile()";
+}
+
+sub ungetc {
+ redef "IO::Handle::ungetc()";
+}
+
+sub vfprintf {
+ unimpl "vfprintf() is C-specific";
+}
+
+sub vprintf {
+ unimpl "vprintf() is C-specific";
+}
+
+sub vsprintf {
+ unimpl "vsprintf() is C-specific";
+}
+
+sub abs {
+ usage "abs(x)" if @_ != 1;
+ abs($_[0]);
+}
+
+sub atexit {
+ unimpl "atexit() is C-specific: use END {} instead";
+}
+
+sub atof {
+ unimpl "atof() is C-specific, stopped";
+}
+
+sub atoi {
+ unimpl "atoi() is C-specific, stopped";
+}
+
+sub atol {
+ unimpl "atol() is C-specific, stopped";
+}
+
+sub bsearch {
+ unimpl "bsearch() not supplied";
+}
+
+sub calloc {
+ unimpl "calloc() is C-specific, stopped";
+}
+
+sub div {
+ unimpl "div() is C-specific, stopped";
+}
+
+sub exit {
+ usage "exit(status)" if @_ != 1;
+ exit($_[0]);
+}
+
+sub free {
+ unimpl "free() is C-specific, stopped";
+}
+
+sub getenv {
+ usage "getenv(name)" if @_ != 1;
+ $ENV{$_[0]};
+}
+
+sub labs {
+ unimpl "labs() is C-specific, use abs instead";
+}
+
+sub ldiv {
+ unimpl "ldiv() is C-specific, use / and int instead";
+}
+
+sub malloc {
+ unimpl "malloc() is C-specific, stopped";
+}
+
+sub qsort {
+ unimpl "qsort() is C-specific, use sort instead";
+}
+
+sub rand {
+ unimpl "rand() is non-portable, use Perl's rand instead";
+}
+
+sub realloc {
+ unimpl "realloc() is C-specific, stopped";
+}
+
+sub srand {
+ unimpl "srand()";
+}
+
+sub system {
+ usage "system(command)" if @_ != 1;
+ system($_[0]);
+}
+
+sub memchr {
+ unimpl "memchr() is C-specific, use index() instead";
+}
+
+sub memcmp {
+ unimpl "memcmp() is C-specific, use eq instead";
+}
+
+sub memcpy {
+ unimpl "memcpy() is C-specific, use = instead";
+}
+
+sub memmove {
+ unimpl "memmove() is C-specific, use = instead";
+}
+
+sub memset {
+ unimpl "memset() is C-specific, use x instead";
+}
+
+sub strcat {
+ unimpl "strcat() is C-specific, use .= instead";
+}
+
+sub strchr {
+ unimpl "strchr() is C-specific, use index() instead";
+}
+
+sub strcmp {
+ unimpl "strcmp() is C-specific, use eq instead";
+}
+
+sub strcpy {
+ unimpl "strcpy() is C-specific, use = instead";
+}
+
+sub strcspn {
+ unimpl "strcspn() is C-specific, use regular expressions instead";
+}
+
+sub strerror {
+ usage "strerror(errno)" if @_ != 1;
+ local $! = $_[0];
+ $! . "";
+}
+
+sub strlen {
+ unimpl "strlen() is C-specific, use length instead";
+}
+
+sub strncat {
+ unimpl "strncat() is C-specific, use .= instead";
+}
+
+sub strncmp {
+ unimpl "strncmp() is C-specific, use eq instead";
+}
+
+sub strncpy {
+ unimpl "strncpy() is C-specific, use = instead";
+}
+
+sub strpbrk {
+ unimpl "strpbrk() is C-specific, stopped";
+}
+
+sub strrchr {
+ unimpl "strrchr() is C-specific, use rindex() instead";
+}
+
+sub strspn {
+ unimpl "strspn() is C-specific, stopped";
+}
+
+sub strstr {
+ usage "strstr(big, little)" if @_ != 2;
+ index($_[0], $_[1]);
+}
+
+sub strtok {
+ unimpl "strtok() is C-specific, stopped";
+}
+
+sub chmod {
+ usage "chmod(mode, filename)" if @_ != 2;
+ chmod($_[0], $_[1]);
+}
+
+sub fstat {
+ usage "fstat(fd)" if @_ != 1;
+ local *TMP;
+ open(TMP, "<&$_[0]"); # Gross.
+ my @l = stat(TMP);
+ close(TMP);
+ @l;
+}
+
+sub mkdir {
+ usage "mkdir(directoryname, mode)" if @_ != 2;
+ mkdir($_[0], $_[1]);
+}
+
+sub stat {
+ usage "stat(filename)" if @_ != 1;
+ stat($_[0]);
+}
+
+sub umask {
+ usage "umask(mask)" if @_ != 1;
+ umask($_[0]);
+}
+
+sub wait {
+ usage "wait()" if @_ != 0;
+ wait();
+}
+
+sub waitpid {
+ usage "waitpid(pid, options)" if @_ != 2;
+ waitpid($_[0], $_[1]);
+}
+
+sub gmtime {
+ usage "gmtime(time)" if @_ != 1;
+ gmtime($_[0]);
+}
+
+sub localtime {
+ usage "localtime(time)" if @_ != 1;
+ localtime($_[0]);
+}
+
+sub time {
+ usage "time()" if @_ != 0;
+ time;
+}
+
+sub alarm {
+ usage "alarm(seconds)" if @_ != 1;
+ alarm($_[0]);
+}
+
+sub chdir {
+ usage "chdir(directory)" if @_ != 1;
+ chdir($_[0]);
+}
+
+sub chown {
+ usage "chown(filename, uid, gid)" if @_ != 3;
+ chown($_[0], $_[1], $_[2]);
+}
+
+sub execl {
+ unimpl "execl() is C-specific, stopped";
+}
+
+sub execle {
+ unimpl "execle() is C-specific, stopped";
+}
+
+sub execlp {
+ unimpl "execlp() is C-specific, stopped";
+}
+
+sub execv {
+ unimpl "execv() is C-specific, stopped";
+}
+
+sub execve {
+ unimpl "execve() is C-specific, stopped";
+}
+
+sub execvp {
+ unimpl "execvp() is C-specific, stopped";
+}
+
+sub fork {
+ usage "fork()" if @_ != 0;
+ fork;
+}
+
+sub getcwd
+{
+ usage "getcwd()" if @_ != 0;
+ if ($^O eq 'MSWin32') {
+ # this perhaps applies to everyone else also?
+ require Cwd;
+ $cwd = &Cwd::cwd;
+ }
+ else {
+ chop($cwd = `pwd`);
+ }
+ $cwd;
+}
+
+sub getegid {
+ usage "getegid()" if @_ != 0;
+ $) + 0;
+}
+
+sub geteuid {
+ usage "geteuid()" if @_ != 0;
+ $> + 0;
+}
+
+sub getgid {
+ usage "getgid()" if @_ != 0;
+ $( + 0;
+}
+
+sub getgroups {
+ usage "getgroups()" if @_ != 0;
+ my %seen;
+ grep(!$seen{$_}++, split(' ', $) ));
+}
+
+sub getlogin {
+ usage "getlogin()" if @_ != 0;
+ getlogin();
+}
+
+sub getpgrp {
+ usage "getpgrp()" if @_ != 0;
+ getpgrp($_[0]);
+}
+
+sub getpid {
+ usage "getpid()" if @_ != 0;
+ $$;
+}
+
+sub getppid {
+ usage "getppid()" if @_ != 0;
+ getppid;
+}
+
+sub getuid {
+ usage "getuid()" if @_ != 0;
+ $<;
+}
+
+sub isatty {
+ usage "isatty(filehandle)" if @_ != 1;
+ -t $_[0];
+}
+
+sub link {
+ usage "link(oldfilename, newfilename)" if @_ != 2;
+ link($_[0], $_[1]);
+}
+
+sub rmdir {
+ usage "rmdir(directoryname)" if @_ != 1;
+ rmdir($_[0]);
+}
+
+sub setgid {
+ usage "setgid(gid)" if @_ != 1;
+ $( = $_[0];
+}
+
+sub setuid {
+ usage "setuid(uid)" if @_ != 1;
+ $< = $_[0];
+}
+
+sub sleep {
+ usage "sleep(seconds)" if @_ != 1;
+ sleep($_[0]);
+}
+
+sub unlink {
+ usage "unlink(filename)" if @_ != 1;
+ unlink($_[0]);
+}
+
+sub utime {
+ usage "utime(filename, atime, mtime)" if @_ != 3;
+ utime($_[1], $_[2], $_[0]);
+}
+
diff --git a/contrib/perl5/ext/POSIX/POSIX.pod b/contrib/perl5/ext/POSIX/POSIX.pod
new file mode 100644
index 000000000000..4726487b47e6
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/POSIX.pod
@@ -0,0 +1,1729 @@
+=head1 NAME
+
+POSIX - Perl interface to IEEE Std 1003.1
+
+=head1 SYNOPSIS
+
+ use POSIX;
+ use POSIX qw(setsid);
+ use POSIX qw(:errno_h :fcntl_h);
+
+ printf "EINTR is %d\n", EINTR;
+
+ $sess_id = POSIX::setsid();
+
+ $fd = POSIX::open($path, O_CREAT|O_EXCL|O_WRONLY, 0644);
+ # note: that's a filedescriptor, *NOT* a filehandle
+
+=head1 DESCRIPTION
+
+The POSIX module permits you to access all (or nearly all) the standard
+POSIX 1003.1 identifiers. Many of these identifiers have been given Perl-ish
+interfaces. Things which are C<#defines> in C, like EINTR or O_NDELAY, are
+automatically exported into your namespace. All functions are only exported
+if you ask for them explicitly. Most likely people will prefer to use the
+fully-qualified function names.
+
+This document gives a condensed list of the features available in the POSIX
+module. Consult your operating system's manpages for general information on
+most features. Consult L<perlfunc> for functions which are noted as being
+identical to Perl's builtin functions.
+
+The first section describes POSIX functions from the 1003.1 specification.
+The second section describes some classes for signal objects, TTY objects,
+and other miscellaneous objects. The remaining sections list various
+constants and macros in an organization which roughly follows IEEE Std
+1003.1b-1993.
+
+=head1 NOTE
+
+The POSIX module is probably the most complex Perl module supplied with
+the standard distribution. It incorporates autoloading, namespace games,
+and dynamic loading of code that's in Perl, C, or both. It's a great
+source of wisdom.
+
+=head1 CAVEATS
+
+A few functions are not implemented because they are C specific. If you
+attempt to call these, they will print a message telling you that they
+aren't implemented, and suggest using the Perl equivalent should one
+exist. For example, trying to access the setjmp() call will elicit the
+message "setjmp() is C-specific: use eval {} instead".
+
+Furthermore, some evil vendors will claim 1003.1 compliance, but in fact
+are not so: they will not pass the PCTS (POSIX Compliance Test Suites).
+For example, one vendor may not define EDEADLK, or the semantics of the
+errno values set by open(2) might not be quite right. Perl does not
+attempt to verify POSIX compliance. That means you can currently
+successfully say "use POSIX", and then later in your program you find
+that your vendor has been lax and there's no usable ICANON macro after
+all. This could be construed to be a bug.
+
+=head1 FUNCTIONS
+
+=over 8
+
+=item _exit
+
+This is identical to the C function C<_exit()>.
+
+=item abort
+
+This is identical to the C function C<abort()>.
+
+=item abs
+
+This is identical to Perl's builtin C<abs()> function.
+
+=item access
+
+Determines the accessibility of a file.
+
+ if( POSIX::access( "/", &POSIX::R_OK ) ){
+ print "have read permission\n";
+ }
+
+Returns C<undef> on failure.
+
+=item acos
+
+This is identical to the C function C<acos()>.
+
+=item alarm
+
+This is identical to Perl's builtin C<alarm()> function.
+
+=item asctime
+
+This is identical to the C function C<asctime()>.
+
+=item asin
+
+This is identical to the C function C<asin()>.
+
+=item assert
+
+Unimplemented.
+
+=item atan
+
+This is identical to the C function C<atan()>.
+
+=item atan2
+
+This is identical to Perl's builtin C<atan2()> function.
+
+=item atexit
+
+atexit() is C-specific: use END {} instead.
+
+=item atof
+
+atof() is C-specific.
+
+=item atoi
+
+atoi() is C-specific.
+
+=item atol
+
+atol() is C-specific.
+
+=item bsearch
+
+bsearch() not supplied.
+
+=item calloc
+
+calloc() is C-specific.
+
+=item ceil
+
+This is identical to the C function C<ceil()>.
+
+=item chdir
+
+This is identical to Perl's builtin C<chdir()> function.
+
+=item chmod
+
+This is identical to Perl's builtin C<chmod()> function.
+
+=item chown
+
+This is identical to Perl's builtin C<chown()> function.
+
+=item clearerr
+
+Use method C<IO::Handle::clearerr()> instead.
+
+=item clock
+
+This is identical to the C function C<clock()>.
+
+=item close
+
+Close the file. This uses file descriptors such as those obtained by calling
+C<POSIX::open>.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ POSIX::close( $fd );
+
+Returns C<undef> on failure.
+
+=item closedir
+
+This is identical to Perl's builtin C<closedir()> function.
+
+=item cos
+
+This is identical to Perl's builtin C<cos()> function.
+
+=item cosh
+
+This is identical to the C function C<cosh()>.
+
+=item creat
+
+Create a new file. This returns a file descriptor like the ones returned by
+C<POSIX::open>. Use C<POSIX::close> to close the file.
+
+ $fd = POSIX::creat( "foo", 0611 );
+ POSIX::close( $fd );
+
+=item ctermid
+
+Generates the path name for the controlling terminal.
+
+ $path = POSIX::ctermid();
+
+=item ctime
+
+This is identical to the C function C<ctime()>.
+
+=item cuserid
+
+Get the character login name of the user.
+
+ $name = POSIX::cuserid();
+
+=item difftime
+
+This is identical to the C function C<difftime()>.
+
+=item div
+
+div() is C-specific.
+
+=item dup
+
+This is similar to the C function C<dup()>.
+
+This uses file descriptors such as those obtained by calling
+C<POSIX::open>.
+
+Returns C<undef> on failure.
+
+=item dup2
+
+This is similar to the C function C<dup2()>.
+
+This uses file descriptors such as those obtained by calling
+C<POSIX::open>.
+
+Returns C<undef> on failure.
+
+=item errno
+
+Returns the value of errno.
+
+ $errno = POSIX::errno();
+
+=item execl
+
+execl() is C-specific.
+
+=item execle
+
+execle() is C-specific.
+
+=item execlp
+
+execlp() is C-specific.
+
+=item execv
+
+execv() is C-specific.
+
+=item execve
+
+execve() is C-specific.
+
+=item execvp
+
+execvp() is C-specific.
+
+=item exit
+
+This is identical to Perl's builtin C<exit()> function.
+
+=item exp
+
+This is identical to Perl's builtin C<exp()> function.
+
+=item fabs
+
+This is identical to Perl's builtin C<abs()> function.
+
+=item fclose
+
+Use method C<IO::Handle::close()> instead.
+
+=item fcntl
+
+This is identical to Perl's builtin C<fcntl()> function.
+
+=item fdopen
+
+Use method C<IO::Handle::new_from_fd()> instead.
+
+=item feof
+
+Use method C<IO::Handle::eof()> instead.
+
+=item ferror
+
+Use method C<IO::Handle::error()> instead.
+
+=item fflush
+
+Use method C<IO::Handle::flush()> instead.
+
+=item fgetc
+
+Use method C<IO::Handle::getc()> instead.
+
+=item fgetpos
+
+Use method C<IO::Seekable::getpos()> instead.
+
+=item fgets
+
+Use method C<IO::Handle::gets()> instead.
+
+=item fileno
+
+Use method C<IO::Handle::fileno()> instead.
+
+=item floor
+
+This is identical to the C function C<floor()>.
+
+=item fmod
+
+This is identical to the C function C<fmod()>.
+
+=item fopen
+
+Use method C<IO::File::open()> instead.
+
+=item fork
+
+This is identical to Perl's builtin C<fork()> function.
+
+=item fpathconf
+
+Retrieves the value of a configurable limit on a file or directory. This
+uses file descriptors such as those obtained by calling C<POSIX::open>.
+
+The following will determine the maximum length of the longest allowable
+pathname on the filesystem which holds C</tmp/foo>.
+
+ $fd = POSIX::open( "/tmp/foo", &POSIX::O_RDONLY );
+ $path_max = POSIX::fpathconf( $fd, &POSIX::_PC_PATH_MAX );
+
+Returns C<undef> on failure.
+
+=item fprintf
+
+fprintf() is C-specific--use printf instead.
+
+=item fputc
+
+fputc() is C-specific--use print instead.
+
+=item fputs
+
+fputs() is C-specific--use print instead.
+
+=item fread
+
+fread() is C-specific--use read instead.
+
+=item free
+
+free() is C-specific.
+
+=item freopen
+
+freopen() is C-specific--use open instead.
+
+=item frexp
+
+Return the mantissa and exponent of a floating-point number.
+
+ ($mantissa, $exponent) = POSIX::frexp( 3.14 );
+
+=item fscanf
+
+fscanf() is C-specific--use <> and regular expressions instead.
+
+=item fseek
+
+Use method C<IO::Seekable::seek()> instead.
+
+=item fsetpos
+
+Use method C<IO::Seekable::setpos()> instead.
+
+=item fstat
+
+Get file status. This uses file descriptors such as those obtained by
+calling C<POSIX::open>. The data returned is identical to the data from
+Perl's builtin C<stat> function.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ @stats = POSIX::fstat( $fd );
+
+=item ftell
+
+Use method C<IO::Seekable::tell()> instead.
+
+=item fwrite
+
+fwrite() is C-specific--use print instead.
+
+=item getc
+
+This is identical to Perl's builtin C<getc()> function.
+
+=item getchar
+
+Returns one character from STDIN.
+
+=item getcwd
+
+Returns the name of the current working directory.
+
+=item getegid
+
+Returns the effective group id.
+
+=item getenv
+
+Returns the value of the specified enironment variable.
+
+=item geteuid
+
+Returns the effective user id.
+
+=item getgid
+
+Returns the user's real group id.
+
+=item getgrgid
+
+This is identical to Perl's builtin C<getgrgid()> function.
+
+=item getgrnam
+
+This is identical to Perl's builtin C<getgrnam()> function.
+
+=item getgroups
+
+Returns the ids of the user's supplementary groups.
+
+=item getlogin
+
+This is identical to Perl's builtin C<getlogin()> function.
+
+=item getpgrp
+
+This is identical to Perl's builtin C<getpgrp()> function.
+
+=item getpid
+
+Returns the process's id.
+
+=item getppid
+
+This is identical to Perl's builtin C<getppid()> function.
+
+=item getpwnam
+
+This is identical to Perl's builtin C<getpwnam()> function.
+
+=item getpwuid
+
+This is identical to Perl's builtin C<getpwuid()> function.
+
+=item gets
+
+Returns one line from STDIN.
+
+=item getuid
+
+Returns the user's id.
+
+=item gmtime
+
+This is identical to Perl's builtin C<gmtime()> function.
+
+=item isalnum
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item isalpha
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item isatty
+
+Returns a boolean indicating whether the specified filehandle is connected
+to a tty.
+
+=item iscntrl
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item isdigit
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item isgraph
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item islower
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item isprint
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item ispunct
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item isspace
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item isupper
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item isxdigit
+
+This is identical to the C function, except that it can apply to a single
+character or to a whole string.
+
+=item kill
+
+This is identical to Perl's builtin C<kill()> function.
+
+=item labs
+
+labs() is C-specific, use abs instead.
+
+=item ldexp
+
+This is identical to the C function C<ldexp()>.
+
+=item ldiv
+
+ldiv() is C-specific, use / and int instead.
+
+=item link
+
+This is identical to Perl's builtin C<link()> function.
+
+=item localeconv
+
+Get numeric formatting information. Returns a reference to a hash
+containing the current locale formatting values.
+
+The database for the B<de> (Deutsch or German) locale.
+
+ $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" );
+ print "Locale = $loc\n";
+ $lconv = POSIX::localeconv();
+ print "decimal_point = ", $lconv->{decimal_point}, "\n";
+ print "thousands_sep = ", $lconv->{thousands_sep}, "\n";
+ print "grouping = ", $lconv->{grouping}, "\n";
+ print "int_curr_symbol = ", $lconv->{int_curr_symbol}, "\n";
+ print "currency_symbol = ", $lconv->{currency_symbol}, "\n";
+ print "mon_decimal_point = ", $lconv->{mon_decimal_point}, "\n";
+ print "mon_thousands_sep = ", $lconv->{mon_thousands_sep}, "\n";
+ print "mon_grouping = ", $lconv->{mon_grouping}, "\n";
+ print "positive_sign = ", $lconv->{positive_sign}, "\n";
+ print "negative_sign = ", $lconv->{negative_sign}, "\n";
+ print "int_frac_digits = ", $lconv->{int_frac_digits}, "\n";
+ print "frac_digits = ", $lconv->{frac_digits}, "\n";
+ print "p_cs_precedes = ", $lconv->{p_cs_precedes}, "\n";
+ print "p_sep_by_space = ", $lconv->{p_sep_by_space}, "\n";
+ print "n_cs_precedes = ", $lconv->{n_cs_precedes}, "\n";
+ print "n_sep_by_space = ", $lconv->{n_sep_by_space}, "\n";
+ print "p_sign_posn = ", $lconv->{p_sign_posn}, "\n";
+ print "n_sign_posn = ", $lconv->{n_sign_posn}, "\n";
+
+=item localtime
+
+This is identical to Perl's builtin C<localtime()> function.
+
+=item log
+
+This is identical to Perl's builtin C<log()> function.
+
+=item log10
+
+This is identical to the C function C<log10()>.
+
+=item longjmp
+
+longjmp() is C-specific: use die instead.
+
+=item lseek
+
+Move the file's read/write position. This uses file descriptors such as
+those obtained by calling C<POSIX::open>.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ $off_t = POSIX::lseek( $fd, 0, &POSIX::SEEK_SET );
+
+Returns C<undef> on failure.
+
+=item malloc
+
+malloc() is C-specific.
+
+=item mblen
+
+This is identical to the C function C<mblen()>.
+
+=item mbstowcs
+
+This is identical to the C function C<mbstowcs()>.
+
+=item mbtowc
+
+This is identical to the C function C<mbtowc()>.
+
+=item memchr
+
+memchr() is C-specific, use index() instead.
+
+=item memcmp
+
+memcmp() is C-specific, use eq instead.
+
+=item memcpy
+
+memcpy() is C-specific, use = instead.
+
+=item memmove
+
+memmove() is C-specific, use = instead.
+
+=item memset
+
+memset() is C-specific, use x instead.
+
+=item mkdir
+
+This is identical to Perl's builtin C<mkdir()> function.
+
+=item mkfifo
+
+This is similar to the C function C<mkfifo()>.
+
+Returns C<undef> on failure.
+
+=item mktime
+
+Convert date/time info to a calendar time.
+
+Synopsis:
+
+ mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0)
+
+The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero.
+I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The
+year (C<year>) is given in years since 1900. I.e. The year 1995 is 95; the
+year 2001 is 101. Consult your system's C<mktime()> manpage for details
+about these and the other arguments.
+
+Calendar time for December 12, 1995, at 10:30 am.
+
+ $time_t = POSIX::mktime( 0, 30, 10, 12, 11, 95 );
+ print "Date = ", POSIX::ctime($time_t);
+
+Returns C<undef> on failure.
+
+=item modf
+
+Return the integral and fractional parts of a floating-point number.
+
+ ($fractional, $integral) = POSIX::modf( 3.14 );
+
+=item nice
+
+This is similar to the C function C<nice()>.
+
+Returns C<undef> on failure.
+
+=item offsetof
+
+offsetof() is C-specific.
+
+=item open
+
+Open a file for reading for writing. This returns file descriptors, not
+Perl filehandles. Use C<POSIX::close> to close the file.
+
+Open a file read-only with mode 0666.
+
+ $fd = POSIX::open( "foo" );
+
+Open a file for read and write.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDWR );
+
+Open a file for write, with truncation.
+
+ $fd = POSIX::open( "foo", &POSIX::O_WRONLY | &POSIX::O_TRUNC );
+
+Create a new file with mode 0640. Set up the file for writing.
+
+ $fd = POSIX::open( "foo", &POSIX::O_CREAT | &POSIX::O_WRONLY, 0640 );
+
+Returns C<undef> on failure.
+
+=item opendir
+
+Open a directory for reading.
+
+ $dir = POSIX::opendir( "/tmp" );
+ @files = POSIX::readdir( $dir );
+ POSIX::closedir( $dir );
+
+Returns C<undef> on failure.
+
+=item pathconf
+
+Retrieves the value of a configurable limit on a file or directory.
+
+The following will determine the maximum length of the longest allowable
+pathname on the filesystem which holds C</tmp>.
+
+ $path_max = POSIX::pathconf( "/tmp", &POSIX::_PC_PATH_MAX );
+
+Returns C<undef> on failure.
+
+=item pause
+
+This is similar to the C function C<pause()>.
+
+Returns C<undef> on failure.
+
+=item perror
+
+This is identical to the C function C<perror()>.
+
+=item pipe
+
+Create an interprocess channel. This returns file descriptors like those
+returned by C<POSIX::open>.
+
+ ($fd0, $fd1) = POSIX::pipe();
+ POSIX::write( $fd0, "hello", 5 );
+ POSIX::read( $fd1, $buf, 5 );
+
+=item pow
+
+Computes $x raised to the power $exponent.
+
+ $ret = POSIX::pow( $x, $exponent );
+
+=item printf
+
+Prints the specified arguments to STDOUT.
+
+=item putc
+
+putc() is C-specific--use print instead.
+
+=item putchar
+
+putchar() is C-specific--use print instead.
+
+=item puts
+
+puts() is C-specific--use print instead.
+
+=item qsort
+
+qsort() is C-specific, use sort instead.
+
+=item raise
+
+Sends the specified signal to the current process.
+
+=item rand
+
+rand() is non-portable, use Perl's rand instead.
+
+=item read
+
+Read from a file. This uses file descriptors such as those obtained by
+calling C<POSIX::open>. If the buffer C<$buf> is not large enough for the
+read then Perl will extend it to make room for the request.
+
+ $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
+ $bytes = POSIX::read( $fd, $buf, 3 );
+
+Returns C<undef> on failure.
+
+=item readdir
+
+This is identical to Perl's builtin C<readdir()> function.
+
+=item realloc
+
+realloc() is C-specific.
+
+=item remove
+
+This is identical to Perl's builtin C<unlink()> function.
+
+=item rename
+
+This is identical to Perl's builtin C<rename()> function.
+
+=item rewind
+
+Seeks to the beginning of the file.
+
+=item rewinddir
+
+This is identical to Perl's builtin C<rewinddir()> function.
+
+=item rmdir
+
+This is identical to Perl's builtin C<rmdir()> function.
+
+=item scanf
+
+scanf() is C-specific--use <> and regular expressions instead.
+
+=item setgid
+
+Sets the real group id for this process.
+
+=item setjmp
+
+setjmp() is C-specific: use eval {} instead.
+
+=item setlocale
+
+Modifies and queries program's locale.
+
+The following will set the traditional UNIX system locale behavior
+(the second argument C<"C">).
+
+ $loc = POSIX::setlocale( &POSIX::LC_ALL, "C" );
+
+The following will query (the missing second argument) the current
+LC_CTYPE category.
+
+ $loc = POSIX::setlocale( &POSIX::LC_CTYPE);
+
+The following will set the LC_CTYPE behaviour according to the locale
+environment variables (the second argument C<"">).
+Please see your systems L<setlocale(3)> documentation for the locale
+environment variables' meaning or consult L<perllocale>.
+
+ $loc = POSIX::setlocale( &POSIX::LC_CTYPE, "");
+
+The following will set the LC_COLLATE behaviour to Argentinian
+Spanish. B<NOTE>: The naming and availability of locales depends on
+your operating system. Please consult L<perllocale> for how to find
+out which locales are available in your system.
+
+ $loc = POSIX::setlocale( &POSIX::LC_ALL, "es_AR.ISO8859-1" );
+
+=item setpgid
+
+This is similar to the C function C<setpgid()>.
+
+Returns C<undef> on failure.
+
+=item setsid
+
+This is identical to the C function C<setsid()>.
+
+=item setuid
+
+Sets the real user id for this process.
+
+=item sigaction
+
+Detailed signal management. This uses C<POSIX::SigAction> objects for the
+C<action> and C<oldaction> arguments. Consult your system's C<sigaction>
+manpage for details.
+
+Synopsis:
+
+ sigaction(sig, action, oldaction = 0)
+
+Returns C<undef> on failure.
+
+=item siglongjmp
+
+siglongjmp() is C-specific: use die instead.
+
+=item sigpending
+
+Examine signals that are blocked and pending. This uses C<POSIX::SigSet>
+objects for the C<sigset> argument. Consult your system's C<sigpending>
+manpage for details.
+
+Synopsis:
+
+ sigpending(sigset)
+
+Returns C<undef> on failure.
+
+=item sigprocmask
+
+Change and/or examine calling process's signal mask. This uses
+C<POSIX::SigSet> objects for the C<sigset> and C<oldsigset> arguments.
+Consult your system's C<sigprocmask> manpage for details.
+
+Synopsis:
+
+ sigprocmask(how, sigset, oldsigset = 0)
+
+Returns C<undef> on failure.
+
+=item sigsetjmp
+
+sigsetjmp() is C-specific: use eval {} instead.
+
+=item sigsuspend
+
+Install a signal mask and suspend process until signal arrives. This uses
+C<POSIX::SigSet> objects for the C<signal_mask> argument. Consult your
+system's C<sigsuspend> manpage for details.
+
+Synopsis:
+
+ sigsuspend(signal_mask)
+
+Returns C<undef> on failure.
+
+=item sin
+
+This is identical to Perl's builtin C<sin()> function.
+
+=item sinh
+
+This is identical to the C function C<sinh()>.
+
+=item sleep
+
+This is identical to Perl's builtin C<sleep()> function.
+
+=item sprintf
+
+This is identical to Perl's builtin C<sprintf()> function.
+
+=item sqrt
+
+This is identical to Perl's builtin C<sqrt()> function.
+
+=item srand
+
+srand().
+
+=item sscanf
+
+sscanf() is C-specific--use regular expressions instead.
+
+=item stat
+
+This is identical to Perl's builtin C<stat()> function.
+
+=item strcat
+
+strcat() is C-specific, use .= instead.
+
+=item strchr
+
+strchr() is C-specific, use index() instead.
+
+=item strcmp
+
+strcmp() is C-specific, use eq instead.
+
+=item strcoll
+
+This is identical to the C function C<strcoll()>.
+
+=item strcpy
+
+strcpy() is C-specific, use = instead.
+
+=item strcspn
+
+strcspn() is C-specific, use regular expressions instead.
+
+=item strerror
+
+Returns the error string for the specified errno.
+
+=item strftime
+
+Convert date and time information to string. Returns the string.
+
+Synopsis:
+
+ strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0)
+
+The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero.
+I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The
+year (C<year>) is given in years since 1900. I.e. The year 1995 is 95; the
+year 2001 is 101. Consult your system's C<strftime()> manpage for details
+about these and the other arguments.
+
+The string for Tuesday, December 12, 1995.
+
+ $str = POSIX::strftime( "%A, %B %d, %Y", 0, 0, 0, 12, 11, 95, 2 );
+ print "$str\n";
+
+=item strlen
+
+strlen() is C-specific, use length instead.
+
+=item strncat
+
+strncat() is C-specific, use .= instead.
+
+=item strncmp
+
+strncmp() is C-specific, use eq instead.
+
+=item strncpy
+
+strncpy() is C-specific, use = instead.
+
+=item stroul
+
+stroul() is C-specific.
+
+=item strpbrk
+
+strpbrk() is C-specific.
+
+=item strrchr
+
+strrchr() is C-specific, use rindex() instead.
+
+=item strspn
+
+strspn() is C-specific.
+
+=item strstr
+
+This is identical to Perl's builtin C<index()> function.
+
+=item strtod
+
+String to double translation. Returns the parsed number and the number
+of characters in the unparsed portion of the string. Truly
+POSIX-compliant systems set $! ($ERRNO) to indicate a translation
+error, so clear $! before calling strtod. However, non-POSIX systems
+may not check for overflow, and therefore will never set $!.
+
+strtod should respect any POSIX I<setlocale()> settings.
+
+To parse a string $str as a floating point number use
+
+ $! = 0;
+ ($num, $n_unparsed) = POSIX::strtod($str);
+
+The second returned item and $! can be used to check for valid input:
+
+ if (($str eq '') || ($n_unparsed != 0) || !$!) {
+ die "Non-numeric input $str" . $! ? ": $!\n" : "\n";
+ }
+
+When called in a scalar context strtod returns the parsed number.
+
+=item strtok
+
+strtok() is C-specific.
+
+=item strtol
+
+String to (long) integer translation. Returns the parsed number and
+the number of characters in the unparsed portion of the string. Truly
+POSIX-compliant systems set $! ($ERRNO) to indicate a translation
+error, so clear $! before calling strtol. However, non-POSIX systems
+may not check for overflow, and therefore will never set $!.
+
+strtol should respect any POSIX I<setlocale()> settings.
+
+To parse a string $str as a number in some base $base use
+
+ $! = 0;
+ ($num, $n_unparsed) = POSIX::strtol($str, $base);
+
+The base should be zero or between 2 and 36, inclusive. When the base
+is zero or omitted strtol will use the string itself to determine the
+base: a leading "0x" or "0X" means hexadecimal; a leading "0" means
+octal; any other leading characters mean decimal. Thus, "1234" is
+parsed as a decimal number, "01234" as an octal number, and "0x1234"
+as a hexadecimal number.
+
+The second returned item and $! can be used to check for valid input:
+
+ if (($str eq '') || ($n_unparsed != 0) || !$!) {
+ die "Non-numeric input $str" . $! ? ": $!\n" : "\n";
+ }
+
+When called in a scalar context strtol returns the parsed number.
+
+=item strtoul
+
+String to unsigned (long) integer translation. strtoul is identical
+to strtol except that strtoul only parses unsigned integers. See
+I<strtol> for details.
+
+Note: Some vendors supply strtod and strtol but not strtoul.
+Other vendors that do suply strtoul parse "-1" as a valid value.
+
+=item strxfrm
+
+String transformation. Returns the transformed string.
+
+ $dst = POSIX::strxfrm( $src );
+
+=item sysconf
+
+Retrieves values of system configurable variables.
+
+The following will get the machine's clock speed.
+
+ $clock_ticks = POSIX::sysconf( &POSIX::_SC_CLK_TCK );
+
+Returns C<undef> on failure.
+
+=item system
+
+This is identical to Perl's builtin C<system()> function.
+
+=item tan
+
+This is identical to the C function C<tan()>.
+
+=item tanh
+
+This is identical to the C function C<tanh()>.
+
+=item tcdrain
+
+This is similar to the C function C<tcdrain()>.
+
+Returns C<undef> on failure.
+
+=item tcflow
+
+This is similar to the C function C<tcflow()>.
+
+Returns C<undef> on failure.
+
+=item tcflush
+
+This is similar to the C function C<tcflush()>.
+
+Returns C<undef> on failure.
+
+=item tcgetpgrp
+
+This is identical to the C function C<tcgetpgrp()>.
+
+=item tcsendbreak
+
+This is similar to the C function C<tcsendbreak()>.
+
+Returns C<undef> on failure.
+
+=item tcsetpgrp
+
+This is similar to the C function C<tcsetpgrp()>.
+
+Returns C<undef> on failure.
+
+=item time
+
+This is identical to Perl's builtin C<time()> function.
+
+=item times
+
+The times() function returns elapsed realtime since some point in the past
+(such as system startup), user and system times for this process, and user
+and system times used by child processes. All times are returned in clock
+ticks.
+
+ ($realtime, $user, $system, $cuser, $csystem) = POSIX::times();
+
+Note: Perl's builtin C<times()> function returns four values, measured in
+seconds.
+
+=item tmpfile
+
+Use method C<IO::File::new_tmpfile()> instead.
+
+=item tmpnam
+
+Returns a name for a temporary file.
+
+ $tmpfile = POSIX::tmpnam();
+
+=item tolower
+
+This is identical to Perl's builtin C<lc()> function.
+
+=item toupper
+
+This is identical to Perl's builtin C<uc()> function.
+
+=item ttyname
+
+This is identical to the C function C<ttyname()>.
+
+=item tzname
+
+Retrieves the time conversion information from the C<tzname> variable.
+
+ POSIX::tzset();
+ ($std, $dst) = POSIX::tzname();
+
+=item tzset
+
+This is identical to the C function C<tzset()>.
+
+=item umask
+
+This is identical to Perl's builtin C<umask()> function.
+
+=item uname
+
+Get name of current operating system.
+
+ ($sysname, $nodename, $release, $version, $machine ) = POSIX::uname();
+
+=item ungetc
+
+Use method C<IO::Handle::ungetc()> instead.
+
+=item unlink
+
+This is identical to Perl's builtin C<unlink()> function.
+
+=item utime
+
+This is identical to Perl's builtin C<utime()> function.
+
+=item vfprintf
+
+vfprintf() is C-specific.
+
+=item vprintf
+
+vprintf() is C-specific.
+
+=item vsprintf
+
+vsprintf() is C-specific.
+
+=item wait
+
+This is identical to Perl's builtin C<wait()> function.
+
+=item waitpid
+
+Wait for a child process to change state. This is identical to Perl's
+builtin C<waitpid()> function.
+
+ $pid = POSIX::waitpid( -1, &POSIX::WNOHANG );
+ print "status = ", ($? / 256), "\n";
+
+=item wcstombs
+
+This is identical to the C function C<wcstombs()>.
+
+=item wctomb
+
+This is identical to the C function C<wctomb()>.
+
+=item write
+
+Write to a file. This uses file descriptors such as those obtained by
+calling C<POSIX::open>.
+
+ $fd = POSIX::open( "foo", &POSIX::O_WRONLY );
+ $buf = "hello";
+ $bytes = POSIX::write( $b, $buf, 5 );
+
+Returns C<undef> on failure.
+
+=back
+
+=head1 CLASSES
+
+=head2 POSIX::SigAction
+
+=over 8
+
+=item new
+
+Creates a new C<POSIX::SigAction> object which corresponds to the C
+C<struct sigaction>. This object will be destroyed automatically when it is
+no longer needed. The first parameter is the fully-qualified name of a sub
+which is a signal-handler. The second parameter is a C<POSIX::SigSet>
+object, it defaults to the empty set. The third parameter contains the
+C<sa_flags>, it defaults to 0.
+
+ $sigset = POSIX::SigSet->new(SIGINT, SIGQUIT);
+ $sigaction = POSIX::SigAction->new( 'main::handler', $sigset, &POSIX::SA_NOCLDSTOP );
+
+This C<POSIX::SigAction> object should be used with the C<POSIX::sigaction()>
+function.
+
+=back
+
+=head2 POSIX::SigSet
+
+=over 8
+
+=item new
+
+Create a new SigSet object. This object will be destroyed automatically
+when it is no longer needed. Arguments may be supplied to initialize the
+set.
+
+Create an empty set.
+
+ $sigset = POSIX::SigSet->new;
+
+Create a set with SIGUSR1.
+
+ $sigset = POSIX::SigSet->new( &POSIX::SIGUSR1 );
+
+=item addset
+
+Add a signal to a SigSet object.
+
+ $sigset->addset( &POSIX::SIGUSR2 );
+
+Returns C<undef> on failure.
+
+=item delset
+
+Remove a signal from the SigSet object.
+
+ $sigset->delset( &POSIX::SIGUSR2 );
+
+Returns C<undef> on failure.
+
+=item emptyset
+
+Initialize the SigSet object to be empty.
+
+ $sigset->emptyset();
+
+Returns C<undef> on failure.
+
+=item fillset
+
+Initialize the SigSet object to include all signals.
+
+ $sigset->fillset();
+
+Returns C<undef> on failure.
+
+=item ismember
+
+Tests the SigSet object to see if it contains a specific signal.
+
+ if( $sigset->ismember( &POSIX::SIGUSR1 ) ){
+ print "contains SIGUSR1\n";
+ }
+
+=back
+
+=head2 POSIX::Termios
+
+=over 8
+
+=item new
+
+Create a new Termios object. This object will be destroyed automatically
+when it is no longer needed. A Termios object corresponds to the termios
+C struct. new() mallocs a new one, getattr() fills it from a file descriptor,
+and setattr() sets a file descriptor's parameters to match Termios' contents.
+
+ $termios = POSIX::Termios->new;
+
+=item getattr
+
+Get terminal control attributes.
+
+Obtain the attributes for stdin.
+
+ $termios->getattr()
+
+Obtain the attributes for stdout.
+
+ $termios->getattr( 1 )
+
+Returns C<undef> on failure.
+
+=item getcc
+
+Retrieve a value from the c_cc field of a termios object. The c_cc field is
+an array so an index must be specified.
+
+ $c_cc[1] = $termios->getcc(1);
+
+=item getcflag
+
+Retrieve the c_cflag field of a termios object.
+
+ $c_cflag = $termios->getcflag;
+
+=item getiflag
+
+Retrieve the c_iflag field of a termios object.
+
+ $c_iflag = $termios->getiflag;
+
+=item getispeed
+
+Retrieve the input baud rate.
+
+ $ispeed = $termios->getispeed;
+
+=item getlflag
+
+Retrieve the c_lflag field of a termios object.
+
+ $c_lflag = $termios->getlflag;
+
+=item getoflag
+
+Retrieve the c_oflag field of a termios object.
+
+ $c_oflag = $termios->getoflag;
+
+=item getospeed
+
+Retrieve the output baud rate.
+
+ $ospeed = $termios->getospeed;
+
+=item setattr
+
+Set terminal control attributes.
+
+Set attributes immediately for stdout.
+
+ $termios->setattr( 1, &POSIX::TCSANOW );
+
+Returns C<undef> on failure.
+
+=item setcc
+
+Set a value in the c_cc field of a termios object. The c_cc field is an
+array so an index must be specified.
+
+ $termios->setcc( &POSIX::VEOF, 1 );
+
+=item setcflag
+
+Set the c_cflag field of a termios object.
+
+ $termios->setcflag( $c_cflag | &POSIX::CLOCAL );
+
+=item setiflag
+
+Set the c_iflag field of a termios object.
+
+ $termios->setiflag( $c_iflag | &POSIX::BRKINT );
+
+=item setispeed
+
+Set the input baud rate.
+
+ $termios->setispeed( &POSIX::B9600 );
+
+Returns C<undef> on failure.
+
+=item setlflag
+
+Set the c_lflag field of a termios object.
+
+ $termios->setlflag( $c_lflag | &POSIX::ECHO );
+
+=item setoflag
+
+Set the c_oflag field of a termios object.
+
+ $termios->setoflag( $c_oflag | &POSIX::OPOST );
+
+=item setospeed
+
+Set the output baud rate.
+
+ $termios->setospeed( &POSIX::B9600 );
+
+Returns C<undef> on failure.
+
+=item Baud rate values
+
+B38400 B75 B200 B134 B300 B1800 B150 B0 B19200 B1200 B9600 B600 B4800 B50 B2400 B110
+
+=item Terminal interface values
+
+TCSADRAIN TCSANOW TCOON TCIOFLUSH TCOFLUSH TCION TCIFLUSH TCSAFLUSH TCIOFF TCOOFF
+
+=item c_cc field values
+
+VEOF VEOL VERASE VINTR VKILL VQUIT VSUSP VSTART VSTOP VMIN VTIME NCCS
+
+=item c_cflag field values
+
+CLOCAL CREAD CSIZE CS5 CS6 CS7 CS8 CSTOPB HUPCL PARENB PARODD
+
+=item c_iflag field values
+
+BRKINT ICRNL IGNBRK IGNCR IGNPAR INLCR INPCK ISTRIP IXOFF IXON PARMRK
+
+=item c_lflag field values
+
+ECHO ECHOE ECHOK ECHONL ICANON IEXTEN ISIG NOFLSH TOSTOP
+
+=item c_oflag field values
+
+OPOST
+
+=back
+
+=head1 PATHNAME CONSTANTS
+
+=over 8
+
+=item Constants
+
+_PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE
+
+=back
+
+=head1 POSIX CONSTANTS
+
+=over 8
+
+=item Constants
+
+_POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED _POSIX_JOB_CONTROL _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_NO_TRUNC _POSIX_OPEN_MAX _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SAVED_IDS _POSIX_SSIZE_MAX _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE _POSIX_VERSION
+
+=back
+
+=head1 SYSTEM CONFIGURATION
+
+=over 8
+
+=item Constants
+
+_SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION
+
+=back
+
+=head1 ERRNO
+
+=over 8
+
+=item Constants
+
+E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF
+EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ
+EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS EINTR
+EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE ENAMETOOLONG
+ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODEV ENOENT ENOEXEC
+ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
+ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE
+EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART EROFS
+ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS
+ETXTBSY EUSERS EWOULDBLOCK EXDEV
+
+=back
+
+=head1 FCNTL
+
+=over 8
+
+=item Constants
+
+FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC O_WRONLY
+
+=back
+
+=head1 FLOAT
+
+=over 8
+
+=item Constants
+
+DBL_DIG DBL_EPSILON DBL_MANT_DIG DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX FLT_ROUNDS LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP
+
+=back
+
+=head1 LIMITS
+
+=over 8
+
+=item Constants
+
+ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX
+
+=back
+
+=head1 LOCALE
+
+=over 8
+
+=item Constants
+
+LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC LC_TIME
+
+=back
+
+=head1 MATH
+
+=over 8
+
+=item Constants
+
+HUGE_VAL
+
+=back
+
+=head1 SIGNAL
+
+=over 8
+
+=item Constants
+
+SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND SA_RESTART
+SA_SIGINFO SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT
+SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU
+SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK
+SIG_UNBLOCK
+
+=back
+
+=head1 STAT
+
+=over 8
+
+=item Constants
+
+S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
+
+=item Macros
+
+S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG
+
+=back
+
+=head1 STDLIB
+
+=over 8
+
+=item Constants
+
+EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX RAND_MAX
+
+=back
+
+=head1 STDIO
+
+=over 8
+
+=item Constants
+
+BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid L_tmpname TMP_MAX
+
+=back
+
+=head1 TIME
+
+=over 8
+
+=item Constants
+
+CLK_TCK CLOCKS_PER_SEC
+
+=back
+
+=head1 UNISTD
+
+=over 8
+
+=item Constants
+
+R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STRERR_FILENO W_OK X_OK
+
+=back
+
+=head1 WAIT
+
+=over 8
+
+=item Constants
+
+WNOHANG WUNTRACED
+
+=item Macros
+
+WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG
+
+=back
+
+=head1 CREATION
+
+This document generated by ./mkposixman.PL version 19960129.
+
diff --git a/contrib/perl5/ext/POSIX/POSIX.xs b/contrib/perl5/ext/POSIX/POSIX.xs
new file mode 100644
index 000000000000..6958c00c4730
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/POSIX.xs
@@ -0,0 +1,3666 @@
+#ifdef WIN32
+#define _POSIX_
+#endif
+#include "EXTERN.h"
+#define PERLIO_NOT_STDIO 1
+#include "perl.h"
+#include "XSUB.h"
+#ifdef PERL_OBJECT /* XXX _very_ temporary hacks */
+# undef signal
+# undef open
+# undef setmode
+# define open PerlLIO_open3
+# undef TAINT_PROPER
+# define TAINT_PROPER(a)
+#endif
+#include <ctype.h>
+#ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */
+#include <dirent.h>
+#endif
+#include <errno.h>
+#ifdef I_FLOAT
+#include <float.h>
+#endif
+#ifdef I_LIMITS
+#include <limits.h>
+#endif
+#include <locale.h>
+#include <math.h>
+#ifdef I_PWD
+#include <pwd.h>
+#endif
+#include <setjmp.h>
+#include <signal.h>
+#include <stdarg.h>
+
+#ifdef I_STDDEF
+#include <stddef.h>
+#endif
+
+/* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
+ metaconfig for future extension writers. We don't use them in POSIX.
+ (This is really sneaky :-) --AD
+*/
+#if defined(I_TERMIOS)
+#include <termios.h>
+#endif
+#ifdef I_STDLIB
+#include <stdlib.h>
+#endif
+#include <string.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <time.h>
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+#include <fcntl.h>
+
+#if defined(__VMS) && !defined(__POSIX_SOURCE)
+# include <libdef.h> /* LIB$_INVARG constant */
+# include <lib$routines.h> /* prototype for lib$ediv() */
+# include <starlet.h> /* prototype for sys$gettim() */
+# if DECC_VERSION < 50000000
+# define pid_t int /* old versions of DECC miss this in types.h */
+# endif
+
+# undef mkfifo
+# define mkfifo(a,b) (not_here("mkfifo"),-1)
+# define tzset() not_here("tzset")
+
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+# define HAS_TZNAME /* shows up in VMS 7.0 or Dec C 5.6 */
+# include <utsname.h>
+# endif /* __VMS_VER >= 70000000 or Dec C 5.6 */
+
+ /* The POSIX notion of ttyname() is better served by getname() under VMS */
+ static char ttnambuf[64];
+# define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL)
+
+ /* The non-POSIX CRTL times() has void return type, so we just get the
+ current time directly */
+ clock_t vms_times(struct tms *PL_bufptr) {
+ clock_t retval;
+ /* Get wall time and convert to 10 ms intervals to
+ * produce the return value that the POSIX standard expects */
+# if defined(__DECC) && defined (__ALPHA)
+# include <ints.h>
+ uint64 vmstime;
+ _ckvmssts(sys$gettim(&vmstime));
+ vmstime /= 100000;
+ retval = vmstime & 0x7fffffff;
+# else
+ /* (Older hw or ccs don't have an atomic 64-bit type, so we
+ * juggle 32-bit ints (and a float) to produce a time_t result
+ * with minimal loss of information.) */
+ long int vmstime[2],remainder,divisor = 100000;
+ _ckvmssts(sys$gettim((unsigned long int *)vmstime));
+ vmstime[1] &= 0x7fff; /* prevent overflow in EDIV */
+ _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
+# endif
+ /* Fill in the struct tms using the CRTL routine . . .*/
+ times((tbuffer_t *)PL_bufptr);
+ return (clock_t) retval;
+ }
+# define times(t) vms_times(t)
+#else
+#if defined (WIN32)
+# undef mkfifo
+# define mkfifo(a,b) not_here("mkfifo")
+# define ttyname(a) (char*)not_here("ttyname")
+# define sigset_t long
+# define pid_t long
+# ifdef __BORLANDC__
+# define tzname _tzname
+# endif
+# ifdef _MSC_VER
+# define mode_t short
+# endif
+# ifdef __MINGW32__
+# define mode_t short
+# ifndef tzset
+# define tzset() not_here("tzset")
+# endif
+# ifndef _POSIX_OPEN_MAX
+# define _POSIX_OPEN_MAX FOPEN_MAX /* XXX bogus ? */
+# endif
+# endif
+# define sigaction(a,b,c) not_here("sigaction")
+# define sigpending(a) not_here("sigpending")
+# define sigprocmask(a,b,c) not_here("sigprocmask")
+# define sigsuspend(a) not_here("sigsuspend")
+# define sigemptyset(a) not_here("sigemptyset")
+# define sigaddset(a,b) not_here("sigaddset")
+# define sigdelset(a,b) not_here("sigdelset")
+# define sigfillset(a) not_here("sigfillset")
+# define sigismember(a,b) not_here("sigismember")
+#else
+
+# ifndef HAS_MKFIFO
+# ifndef mkfifo
+# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
+# endif
+# endif /* !HAS_MKFIFO */
+
+# include <grp.h>
+# include <sys/times.h>
+# ifdef HAS_UNAME
+# include <sys/utsname.h>
+# endif
+# include <sys/wait.h>
+# ifdef I_UTIME
+# include <utime.h>
+# endif
+#endif /* WIN32 */
+#endif /* __VMS */
+
+typedef int SysRet;
+typedef long SysRetLong;
+typedef sigset_t* POSIX__SigSet;
+typedef HV* POSIX__SigAction;
+#ifdef I_TERMIOS
+typedef struct termios* POSIX__Termios;
+#else /* Define termios types to int, and call not_here for the functions.*/
+#define POSIX__Termios int
+#define speed_t int
+#define tcflag_t int
+#define cc_t int
+#define cfgetispeed(x) not_here("cfgetispeed")
+#define cfgetospeed(x) not_here("cfgetospeed")
+#define tcdrain(x) not_here("tcdrain")
+#define tcflush(x,y) not_here("tcflush")
+#define tcsendbreak(x,y) not_here("tcsendbreak")
+#define cfsetispeed(x,y) not_here("cfsetispeed")
+#define cfsetospeed(x,y) not_here("cfsetospeed")
+#define ctermid(x) (char *) not_here("ctermid")
+#define tcflow(x,y) not_here("tcflow")
+#define tcgetattr(x,y) not_here("tcgetattr")
+#define tcsetattr(x,y,z) not_here("tcsetattr")
+#endif
+
+/* Possibly needed prototypes */
+char *cuserid _((char *));
+double strtod _((const char *, char **));
+long strtol _((const char *, char **, int));
+unsigned long strtoul _((const char *, char **, int));
+
+#ifndef HAS_CUSERID
+#define cuserid(a) (char *) not_here("cuserid")
+#endif
+#ifndef HAS_DIFFTIME
+#ifndef difftime
+#define difftime(a,b) not_here("difftime")
+#endif
+#endif
+#ifndef HAS_FPATHCONF
+#define fpathconf(f,n) (SysRetLong) not_here("fpathconf")
+#endif
+#ifndef HAS_MKTIME
+#define mktime(a) not_here("mktime")
+#endif
+#ifndef HAS_NICE
+#define nice(a) not_here("nice")
+#endif
+#ifndef HAS_PATHCONF
+#define pathconf(f,n) (SysRetLong) not_here("pathconf")
+#endif
+#ifndef HAS_SYSCONF
+#define sysconf(n) (SysRetLong) not_here("sysconf")
+#endif
+#ifndef HAS_READLINK
+#define readlink(a,b,c) not_here("readlink")
+#endif
+#ifndef HAS_SETPGID
+#define setpgid(a,b) not_here("setpgid")
+#endif
+#ifndef HAS_SETSID
+#define setsid() not_here("setsid")
+#endif
+#ifndef HAS_STRCOLL
+#define strcoll(s1,s2) not_here("strcoll")
+#endif
+#ifndef HAS_STRTOD
+#define strtod(s1,s2) not_here("strtod")
+#endif
+#ifndef HAS_STRTOL
+#define strtol(s1,s2,b) not_here("strtol")
+#endif
+#ifndef HAS_STRTOUL
+#define strtoul(s1,s2,b) not_here("strtoul")
+#endif
+#ifndef HAS_STRXFRM
+#define strxfrm(s1,s2,n) not_here("strxfrm")
+#endif
+#ifndef HAS_TCGETPGRP
+#define tcgetpgrp(a) not_here("tcgetpgrp")
+#endif
+#ifndef HAS_TCSETPGRP
+#define tcsetpgrp(a,b) not_here("tcsetpgrp")
+#endif
+#ifndef HAS_TIMES
+#define times(a) not_here("times")
+#endif
+#ifndef HAS_UNAME
+#define uname(a) not_here("uname")
+#endif
+#ifndef HAS_WAITPID
+#define waitpid(a,b,c) not_here("waitpid")
+#endif
+
+#ifndef HAS_MBLEN
+#ifndef mblen
+#define mblen(a,b) not_here("mblen")
+#endif
+#endif
+#ifndef HAS_MBSTOWCS
+#define mbstowcs(s, pwcs, n) not_here("mbstowcs")
+#endif
+#ifndef HAS_MBTOWC
+#define mbtowc(pwc, s, n) not_here("mbtowc")
+#endif
+#ifndef HAS_WCSTOMBS
+#define wcstombs(s, pwcs, n) not_here("wcstombs")
+#endif
+#ifndef HAS_WCTOMB
+#define wctomb(s, wchar) not_here("wcstombs")
+#endif
+#if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
+/* If we don't have these functions, then we wouldn't have gotten a typedef
+ for wchar_t, the wide character type. Defining wchar_t allows the
+ functions referencing it to compile. Its actual type is then meaningless,
+ since without the above functions, all sections using it end up calling
+ not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */
+#ifndef wchar_t
+#define wchar_t char
+#endif
+#endif
+
+#ifndef HAS_LOCALECONV
+#define localeconv() not_here("localeconv")
+#endif
+
+#ifdef HAS_TZNAME
+# ifndef WIN32
+extern char *tzname[];
+# endif
+#else
+#if !defined(WIN32) || (defined(__MINGW32__) && !defined(tzname))
+char *tzname[] = { "" , "" };
+#endif
+#endif
+
+/* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX)
+ * fields for which we don't have Configure support yet:
+ * char *tm_zone; -- abbreviation of timezone name
+ * long tm_gmtoff; -- offset from GMT in seconds
+ * To workaround core dumps from the uninitialised tm_zone we get the
+ * system to give us a reasonable struct to copy. This fix means that
+ * strftime uses the tm_zone and tm_gmtoff values returned by
+ * localtime(time()). That should give the desired result most of the
+ * time. But probably not always!
+ *
+ * This is a temporary workaround to be removed once Configure
+ * support is added and NETaa14816 is considered in full.
+ * It does not address tzname aspects of NETaa14816.
+ */
+#ifdef HAS_GNULIBC
+# ifndef STRUCT_TM_HASZONE
+# define STRUCT_TM_HAS_ZONE
+# endif
+#endif
+
+#ifdef STRUCT_TM_HASZONE
+static void
+init_tm(ptm) /* see mktime, strftime and asctime */
+ struct tm *ptm;
+{
+ Time_t now;
+ (void)time(&now);
+ Copy(localtime(&now), ptm, 1, struct tm);
+}
+
+#else
+# define init_tm(ptm)
+#endif
+
+
+#ifdef HAS_LONG_DOUBLE
+# if LONG_DOUBLESIZE > DOUBLESIZE
+# undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */
+# endif
+#endif
+
+#ifndef HAS_LONG_DOUBLE
+#ifdef LDBL_MAX
+#undef LDBL_MAX
+#endif
+#ifdef LDBL_MIN
+#undef LDBL_MIN
+#endif
+#ifdef LDBL_EPSILON
+#undef LDBL_EPSILON
+#endif
+#endif
+
+static int
+not_here(char *s)
+{
+ croak("POSIX::%s not implemented on this architecture", s);
+ return -1;
+}
+
+static
+#ifdef HAS_LONG_DOUBLE
+long double
+#else
+double
+#endif
+constant(char *name, int arg)
+{
+ errno = 0;
+ switch (*name) {
+ case 'A':
+ if (strEQ(name, "ARG_MAX"))
+#ifdef ARG_MAX
+ return ARG_MAX;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'B':
+ if (strEQ(name, "BUFSIZ"))
+#ifdef BUFSIZ
+ return BUFSIZ;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "BRKINT"))
+#ifdef BRKINT
+ return BRKINT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B9600"))
+#ifdef B9600
+ return B9600;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B19200"))
+#ifdef B19200
+ return B19200;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B38400"))
+#ifdef B38400
+ return B38400;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B0"))
+#ifdef B0
+ return B0;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B110"))
+#ifdef B110
+ return B110;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B1200"))
+#ifdef B1200
+ return B1200;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B134"))
+#ifdef B134
+ return B134;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B150"))
+#ifdef B150
+ return B150;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B1800"))
+#ifdef B1800
+ return B1800;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B200"))
+#ifdef B200
+ return B200;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B2400"))
+#ifdef B2400
+ return B2400;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B300"))
+#ifdef B300
+ return B300;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B4800"))
+#ifdef B4800
+ return B4800;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B50"))
+#ifdef B50
+ return B50;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B600"))
+#ifdef B600
+ return B600;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "B75"))
+#ifdef B75
+ return B75;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'C':
+ if (strEQ(name, "CHAR_BIT"))
+#ifdef CHAR_BIT
+ return CHAR_BIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CHAR_MAX"))
+#ifdef CHAR_MAX
+ return CHAR_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CHAR_MIN"))
+#ifdef CHAR_MIN
+ return CHAR_MIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CHILD_MAX"))
+#ifdef CHILD_MAX
+ return CHILD_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CLK_TCK"))
+#ifdef CLK_TCK
+ return CLK_TCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CLOCAL"))
+#ifdef CLOCAL
+ return CLOCAL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CLOCKS_PER_SEC"))
+#ifdef CLOCKS_PER_SEC
+ return CLOCKS_PER_SEC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CREAD"))
+#ifdef CREAD
+ return CREAD;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CS5"))
+#ifdef CS5
+ return CS5;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CS6"))
+#ifdef CS6
+ return CS6;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CS7"))
+#ifdef CS7
+ return CS7;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CS8"))
+#ifdef CS8
+ return CS8;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CSIZE"))
+#ifdef CSIZE
+ return CSIZE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "CSTOPB"))
+#ifdef CSTOPB
+ return CSTOPB;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'D':
+ if (strEQ(name, "DBL_MAX"))
+#ifdef DBL_MAX
+ return DBL_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "DBL_MIN"))
+#ifdef DBL_MIN
+ return DBL_MIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "DBL_DIG"))
+#ifdef DBL_DIG
+ return DBL_DIG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "DBL_EPSILON"))
+#ifdef DBL_EPSILON
+ return DBL_EPSILON;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "DBL_MANT_DIG"))
+#ifdef DBL_MANT_DIG
+ return DBL_MANT_DIG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "DBL_MAX_10_EXP"))
+#ifdef DBL_MAX_10_EXP
+ return DBL_MAX_10_EXP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "DBL_MAX_EXP"))
+#ifdef DBL_MAX_EXP
+ return DBL_MAX_EXP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "DBL_MIN_10_EXP"))
+#ifdef DBL_MIN_10_EXP
+ return DBL_MIN_10_EXP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "DBL_MIN_EXP"))
+#ifdef DBL_MIN_EXP
+ return DBL_MIN_EXP;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'E':
+ switch (name[1]) {
+ case 'A':
+ if (strEQ(name, "EACCES"))
+#ifdef EACCES
+ return EACCES;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EADDRINUSE"))
+#ifdef EADDRINUSE
+ return EADDRINUSE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EADDRNOTAVAIL"))
+#ifdef EADDRNOTAVAIL
+ return EADDRNOTAVAIL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EAFNOSUPPORT"))
+#ifdef EAFNOSUPPORT
+ return EAFNOSUPPORT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EAGAIN"))
+#ifdef EAGAIN
+ return EAGAIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EALREADY"))
+#ifdef EALREADY
+ return EALREADY;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'B':
+ if (strEQ(name, "EBADF"))
+#ifdef EBADF
+ return EBADF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EBUSY"))
+#ifdef EBUSY
+ return EBUSY;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'C':
+ if (strEQ(name, "ECHILD"))
+#ifdef ECHILD
+ return ECHILD;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ECHO"))
+#ifdef ECHO
+ return ECHO;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ECHOE"))
+#ifdef ECHOE
+ return ECHOE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ECHOK"))
+#ifdef ECHOK
+ return ECHOK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ECHONL"))
+#ifdef ECHONL
+ return ECHONL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ECONNABORTED"))
+#ifdef ECONNABORTED
+ return ECONNABORTED;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ECONNREFUSED"))
+#ifdef ECONNREFUSED
+ return ECONNREFUSED;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ECONNRESET"))
+#ifdef ECONNRESET
+ return ECONNRESET;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'D':
+ if (strEQ(name, "EDEADLK"))
+#ifdef EDEADLK
+ return EDEADLK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EDESTADDRREQ"))
+#ifdef EDESTADDRREQ
+ return EDESTADDRREQ;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EDOM"))
+#ifdef EDOM
+ return EDOM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EDQUOT"))
+#ifdef EDQUOT
+ return EDQUOT;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'E':
+ if (strEQ(name, "EEXIST"))
+#ifdef EEXIST
+ return EEXIST;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'F':
+ if (strEQ(name, "EFAULT"))
+#ifdef EFAULT
+ return EFAULT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EFBIG"))
+#ifdef EFBIG
+ return EFBIG;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'H':
+ if (strEQ(name, "EHOSTDOWN"))
+#ifdef EHOSTDOWN
+ return EHOSTDOWN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EHOSTUNREACH"))
+#ifdef EHOSTUNREACH
+ return EHOSTUNREACH;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'I':
+ if (strEQ(name, "EINPROGRESS"))
+#ifdef EINPROGRESS
+ return EINPROGRESS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EINTR"))
+#ifdef EINTR
+ return EINTR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EINVAL"))
+#ifdef EINVAL
+ return EINVAL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EIO"))
+#ifdef EIO
+ return EIO;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EISCONN"))
+#ifdef EISCONN
+ return EISCONN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EISDIR"))
+#ifdef EISDIR
+ return EISDIR;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'L':
+ if (strEQ(name, "ELOOP"))
+#ifdef ELOOP
+ return ELOOP;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'M':
+ if (strEQ(name, "EMFILE"))
+#ifdef EMFILE
+ return EMFILE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EMLINK"))
+#ifdef EMLINK
+ return EMLINK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EMSGSIZE"))
+#ifdef EMSGSIZE
+ return EMSGSIZE;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'N':
+ if (strEQ(name, "ENETDOWN"))
+#ifdef ENETDOWN
+ return ENETDOWN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENETRESET"))
+#ifdef ENETRESET
+ return ENETRESET;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENETUNREACH"))
+#ifdef ENETUNREACH
+ return ENETUNREACH;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOBUFS"))
+#ifdef ENOBUFS
+ return ENOBUFS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOEXEC"))
+#ifdef ENOEXEC
+ return ENOEXEC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOMEM"))
+#ifdef ENOMEM
+ return ENOMEM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOPROTOOPT"))
+#ifdef ENOPROTOOPT
+ return ENOPROTOOPT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOSPC"))
+#ifdef ENOSPC
+ return ENOSPC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOTBLK"))
+#ifdef ENOTBLK
+ return ENOTBLK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOTCONN"))
+#ifdef ENOTCONN
+ return ENOTCONN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOTDIR"))
+#ifdef ENOTDIR
+ return ENOTDIR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOTEMPTY"))
+#ifdef ENOTEMPTY
+ return ENOTEMPTY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOTSOCK"))
+#ifdef ENOTSOCK
+ return ENOTSOCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOTTY"))
+#ifdef ENOTTY
+ return ENOTTY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENFILE"))
+#ifdef ENFILE
+ return ENFILE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENODEV"))
+#ifdef ENODEV
+ return ENODEV;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOENT"))
+#ifdef ENOENT
+ return ENOENT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOLCK"))
+#ifdef ENOLCK
+ return ENOLCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENOSYS"))
+#ifdef ENOSYS
+ return ENOSYS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENXIO"))
+#ifdef ENXIO
+ return ENXIO;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ENAMETOOLONG"))
+#ifdef ENAMETOOLONG
+ return ENAMETOOLONG;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'O':
+ if (strEQ(name, "EOF"))
+#ifdef EOF
+ return EOF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EOPNOTSUPP"))
+#ifdef EOPNOTSUPP
+ return EOPNOTSUPP;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'P':
+ if (strEQ(name, "EPERM"))
+#ifdef EPERM
+ return EPERM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EPFNOSUPPORT"))
+#ifdef EPFNOSUPPORT
+ return EPFNOSUPPORT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EPIPE"))
+#ifdef EPIPE
+ return EPIPE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EPROCLIM"))
+#ifdef EPROCLIM
+ return EPROCLIM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EPROTONOSUPPORT"))
+#ifdef EPROTONOSUPPORT
+ return EPROTONOSUPPORT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EPROTOTYPE"))
+#ifdef EPROTOTYPE
+ return EPROTOTYPE;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'R':
+ if (strEQ(name, "ERANGE"))
+#ifdef ERANGE
+ return ERANGE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EREMOTE"))
+#ifdef EREMOTE
+ return EREMOTE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ERESTART"))
+#ifdef ERESTART
+ return ERESTART;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "EROFS"))
+#ifdef EROFS
+ return EROFS;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'S':
+ if (strEQ(name, "ESHUTDOWN"))
+#ifdef ESHUTDOWN
+ return ESHUTDOWN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ESOCKTNOSUPPORT"))
+#ifdef ESOCKTNOSUPPORT
+ return ESOCKTNOSUPPORT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ESPIPE"))
+#ifdef ESPIPE
+ return ESPIPE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ESRCH"))
+#ifdef ESRCH
+ return ESRCH;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ESTALE"))
+#ifdef ESTALE
+ return ESTALE;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'T':
+ if (strEQ(name, "ETIMEDOUT"))
+#ifdef ETIMEDOUT
+ return ETIMEDOUT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ETOOMANYREFS"))
+#ifdef ETOOMANYREFS
+ return ETOOMANYREFS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ETXTBSY"))
+#ifdef ETXTBSY
+ return ETXTBSY;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'U':
+ if (strEQ(name, "EUSERS"))
+#ifdef EUSERS
+ return EUSERS;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'W':
+ if (strEQ(name, "EWOULDBLOCK"))
+#ifdef EWOULDBLOCK
+ return EWOULDBLOCK;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'X':
+ if (strEQ(name, "EXIT_FAILURE"))
+#ifdef EXIT_FAILURE
+ return EXIT_FAILURE;
+#else
+ return 1;
+#endif
+ if (strEQ(name, "EXIT_SUCCESS"))
+#ifdef EXIT_SUCCESS
+ return EXIT_SUCCESS;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "EXDEV"))
+#ifdef EXDEV
+ return EXDEV;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (strEQ(name, "E2BIG"))
+#ifdef E2BIG
+ return E2BIG;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'F':
+ if (strnEQ(name, "FLT_", 4)) {
+ if (strEQ(name, "FLT_MAX"))
+#ifdef FLT_MAX
+ return FLT_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FLT_MIN"))
+#ifdef FLT_MIN
+ return FLT_MIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FLT_ROUNDS"))
+#ifdef FLT_ROUNDS
+ return FLT_ROUNDS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FLT_DIG"))
+#ifdef FLT_DIG
+ return FLT_DIG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FLT_EPSILON"))
+#ifdef FLT_EPSILON
+ return FLT_EPSILON;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FLT_MANT_DIG"))
+#ifdef FLT_MANT_DIG
+ return FLT_MANT_DIG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FLT_MAX_10_EXP"))
+#ifdef FLT_MAX_10_EXP
+ return FLT_MAX_10_EXP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FLT_MAX_EXP"))
+#ifdef FLT_MAX_EXP
+ return FLT_MAX_EXP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FLT_MIN_10_EXP"))
+#ifdef FLT_MIN_10_EXP
+ return FLT_MIN_10_EXP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FLT_MIN_EXP"))
+#ifdef FLT_MIN_EXP
+ return FLT_MIN_EXP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FLT_RADIX"))
+#ifdef FLT_RADIX
+ return FLT_RADIX;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (strnEQ(name, "F_", 2)) {
+ if (strEQ(name, "F_DUPFD"))
+#ifdef F_DUPFD
+ return F_DUPFD;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_GETFD"))
+#ifdef F_GETFD
+ return F_GETFD;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_GETFL"))
+#ifdef F_GETFL
+ return F_GETFL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_GETLK"))
+#ifdef F_GETLK
+ return F_GETLK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_OK"))
+#ifdef F_OK
+ return F_OK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_RDLCK"))
+#ifdef F_RDLCK
+ return F_RDLCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_SETFD"))
+#ifdef F_SETFD
+ return F_SETFD;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_SETFL"))
+#ifdef F_SETFL
+ return F_SETFL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_SETLK"))
+#ifdef F_SETLK
+ return F_SETLK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_SETLKW"))
+#ifdef F_SETLKW
+ return F_SETLKW;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_UNLCK"))
+#ifdef F_UNLCK
+ return F_UNLCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "F_WRLCK"))
+#ifdef F_WRLCK
+ return F_WRLCK;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (strEQ(name, "FD_CLOEXEC"))
+#ifdef FD_CLOEXEC
+ return FD_CLOEXEC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "FILENAME_MAX"))
+#ifdef FILENAME_MAX
+ return FILENAME_MAX;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'H':
+ if (strEQ(name, "HUGE_VAL"))
+#ifdef HUGE_VAL
+ return HUGE_VAL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "HUPCL"))
+#ifdef HUPCL
+ return HUPCL;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'I':
+ if (strEQ(name, "INT_MAX"))
+#ifdef INT_MAX
+ return INT_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "INT_MIN"))
+#ifdef INT_MIN
+ return INT_MIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ICANON"))
+#ifdef ICANON
+ return ICANON;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ICRNL"))
+#ifdef ICRNL
+ return ICRNL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "IEXTEN"))
+#ifdef IEXTEN
+ return IEXTEN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "IGNBRK"))
+#ifdef IGNBRK
+ return IGNBRK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "IGNCR"))
+#ifdef IGNCR
+ return IGNCR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "IGNPAR"))
+#ifdef IGNPAR
+ return IGNPAR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "INLCR"))
+#ifdef INLCR
+ return INLCR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "INPCK"))
+#ifdef INPCK
+ return INPCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ISIG"))
+#ifdef ISIG
+ return ISIG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ISTRIP"))
+#ifdef ISTRIP
+ return ISTRIP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "IXOFF"))
+#ifdef IXOFF
+ return IXOFF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "IXON"))
+#ifdef IXON
+ return IXON;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'L':
+ if (strnEQ(name, "LC_", 3)) {
+ if (strEQ(name, "LC_ALL"))
+#ifdef LC_ALL
+ return LC_ALL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LC_COLLATE"))
+#ifdef LC_COLLATE
+ return LC_COLLATE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LC_CTYPE"))
+#ifdef LC_CTYPE
+ return LC_CTYPE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LC_MONETARY"))
+#ifdef LC_MONETARY
+ return LC_MONETARY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LC_NUMERIC"))
+#ifdef LC_NUMERIC
+ return LC_NUMERIC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LC_TIME"))
+#ifdef LC_TIME
+ return LC_TIME;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (strnEQ(name, "LDBL_", 5)) {
+ if (strEQ(name, "LDBL_MAX"))
+#ifdef LDBL_MAX
+ return LDBL_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LDBL_MIN"))
+#ifdef LDBL_MIN
+ return LDBL_MIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LDBL_DIG"))
+#ifdef LDBL_DIG
+ return LDBL_DIG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LDBL_EPSILON"))
+#ifdef LDBL_EPSILON
+ return LDBL_EPSILON;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LDBL_MANT_DIG"))
+#ifdef LDBL_MANT_DIG
+ return LDBL_MANT_DIG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LDBL_MAX_10_EXP"))
+#ifdef LDBL_MAX_10_EXP
+ return LDBL_MAX_10_EXP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LDBL_MAX_EXP"))
+#ifdef LDBL_MAX_EXP
+ return LDBL_MAX_EXP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LDBL_MIN_10_EXP"))
+#ifdef LDBL_MIN_10_EXP
+ return LDBL_MIN_10_EXP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LDBL_MIN_EXP"))
+#ifdef LDBL_MIN_EXP
+ return LDBL_MIN_EXP;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (strnEQ(name, "L_", 2)) {
+ if (strEQ(name, "L_ctermid"))
+#ifdef L_ctermid
+ return L_ctermid;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "L_cuserid"))
+#ifdef L_cuserid
+ return L_cuserid;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "L_tmpname"))
+#ifdef L_tmpname
+ return L_tmpname;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (strEQ(name, "LONG_MAX"))
+#ifdef LONG_MAX
+ return LONG_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LONG_MIN"))
+#ifdef LONG_MIN
+ return LONG_MIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "LINK_MAX"))
+#ifdef LINK_MAX
+ return LINK_MAX;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'M':
+ if (strEQ(name, "MAX_CANON"))
+#ifdef MAX_CANON
+ return MAX_CANON;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MAX_INPUT"))
+#ifdef MAX_INPUT
+ return MAX_INPUT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MB_CUR_MAX"))
+#ifdef MB_CUR_MAX
+ return MB_CUR_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MB_LEN_MAX"))
+#ifdef MB_LEN_MAX
+ return MB_LEN_MAX;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'N':
+ if (strEQ(name, "NULL")) return 0;
+ if (strEQ(name, "NAME_MAX"))
+#ifdef NAME_MAX
+ return NAME_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "NCCS"))
+#ifdef NCCS
+ return NCCS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "NGROUPS_MAX"))
+#ifdef NGROUPS_MAX
+ return NGROUPS_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "NOFLSH"))
+#ifdef NOFLSH
+ return NOFLSH;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'O':
+ if (strnEQ(name, "O_", 2)) {
+ if (strEQ(name, "O_APPEND"))
+#ifdef O_APPEND
+ return O_APPEND;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_CREAT"))
+#ifdef O_CREAT
+ return O_CREAT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_TRUNC"))
+#ifdef O_TRUNC
+ return O_TRUNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_RDONLY"))
+#ifdef O_RDONLY
+ return O_RDONLY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_RDWR"))
+#ifdef O_RDWR
+ return O_RDWR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_WRONLY"))
+#ifdef O_WRONLY
+ return O_WRONLY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_EXCL"))
+#ifdef O_EXCL
+ return O_EXCL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_NOCTTY"))
+#ifdef O_NOCTTY
+ return O_NOCTTY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_NONBLOCK"))
+#ifdef O_NONBLOCK
+ return O_NONBLOCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_ACCMODE"))
+#ifdef O_ACCMODE
+ return O_ACCMODE;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (strEQ(name, "OPEN_MAX"))
+#ifdef OPEN_MAX
+ return OPEN_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "OPOST"))
+#ifdef OPOST
+ return OPOST;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'P':
+ if (strEQ(name, "PATH_MAX"))
+#ifdef PATH_MAX
+ return PATH_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PARENB"))
+#ifdef PARENB
+ return PARENB;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PARMRK"))
+#ifdef PARMRK
+ return PARMRK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PARODD"))
+#ifdef PARODD
+ return PARODD;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PIPE_BUF"))
+#ifdef PIPE_BUF
+ return PIPE_BUF;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'R':
+ if (strEQ(name, "RAND_MAX"))
+#ifdef RAND_MAX
+ return RAND_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "R_OK"))
+#ifdef R_OK
+ return R_OK;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'S':
+ if (strnEQ(name, "SIG", 3)) {
+ if (name[3] == '_') {
+ if (strEQ(name, "SIG_BLOCK"))
+#ifdef SIG_BLOCK
+ return SIG_BLOCK;
+#else
+ goto not_there;
+#endif
+#ifdef SIG_DFL
+ if (strEQ(name, "SIG_DFL")) return (IV)SIG_DFL;
+#endif
+#ifdef SIG_ERR
+ if (strEQ(name, "SIG_ERR")) return (IV)SIG_ERR;
+#endif
+#ifdef SIG_IGN
+ if (strEQ(name, "SIG_IGN")) return (IV)SIG_IGN;
+#endif
+ if (strEQ(name, "SIG_SETMASK"))
+#ifdef SIG_SETMASK
+ return SIG_SETMASK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIG_UNBLOCK"))
+#ifdef SIG_UNBLOCK
+ return SIG_UNBLOCK;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (strEQ(name, "SIGABRT"))
+#ifdef SIGABRT
+ return SIGABRT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGALRM"))
+#ifdef SIGALRM
+ return SIGALRM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGCHLD"))
+#ifdef SIGCHLD
+ return SIGCHLD;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGCONT"))
+#ifdef SIGCONT
+ return SIGCONT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGFPE"))
+#ifdef SIGFPE
+ return SIGFPE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGHUP"))
+#ifdef SIGHUP
+ return SIGHUP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGILL"))
+#ifdef SIGILL
+ return SIGILL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGINT"))
+#ifdef SIGINT
+ return SIGINT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGKILL"))
+#ifdef SIGKILL
+ return SIGKILL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGPIPE"))
+#ifdef SIGPIPE
+ return SIGPIPE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGQUIT"))
+#ifdef SIGQUIT
+ return SIGQUIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGSEGV"))
+#ifdef SIGSEGV
+ return SIGSEGV;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGSTOP"))
+#ifdef SIGSTOP
+ return SIGSTOP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGTERM"))
+#ifdef SIGTERM
+ return SIGTERM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGTSTP"))
+#ifdef SIGTSTP
+ return SIGTSTP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGTTIN"))
+#ifdef SIGTTIN
+ return SIGTTIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGTTOU"))
+#ifdef SIGTTOU
+ return SIGTTOU;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGUSR1"))
+#ifdef SIGUSR1
+ return SIGUSR1;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SIGUSR2"))
+#ifdef SIGUSR2
+ return SIGUSR2;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (name[1] == '_') {
+ if (strEQ(name, "S_ISGID"))
+#ifdef S_ISGID
+ return S_ISGID;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_ISUID"))
+#ifdef S_ISUID
+ return S_ISUID;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IRGRP"))
+#ifdef S_IRGRP
+ return S_IRGRP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IROTH"))
+#ifdef S_IROTH
+ return S_IROTH;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IRUSR"))
+#ifdef S_IRUSR
+ return S_IRUSR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IRWXG"))
+#ifdef S_IRWXG
+ return S_IRWXG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IRWXO"))
+#ifdef S_IRWXO
+ return S_IRWXO;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IRWXU"))
+#ifdef S_IRWXU
+ return S_IRWXU;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IWGRP"))
+#ifdef S_IWGRP
+ return S_IWGRP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IWOTH"))
+#ifdef S_IWOTH
+ return S_IWOTH;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IWUSR"))
+#ifdef S_IWUSR
+ return S_IWUSR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IXGRP"))
+#ifdef S_IXGRP
+ return S_IXGRP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IXOTH"))
+#ifdef S_IXOTH
+ return S_IXOTH;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "S_IXUSR"))
+#ifdef S_IXUSR
+ return S_IXUSR;
+#else
+ goto not_there;
+#endif
+ errno = EAGAIN; /* the following aren't constants */
+#ifdef S_ISBLK
+ if (strEQ(name, "S_ISBLK")) return S_ISBLK(arg);
+#endif
+#ifdef S_ISCHR
+ if (strEQ(name, "S_ISCHR")) return S_ISCHR(arg);
+#endif
+#ifdef S_ISDIR
+ if (strEQ(name, "S_ISDIR")) return S_ISDIR(arg);
+#endif
+#ifdef S_ISFIFO
+ if (strEQ(name, "S_ISFIFO")) return S_ISFIFO(arg);
+#endif
+#ifdef S_ISREG
+ if (strEQ(name, "S_ISREG")) return S_ISREG(arg);
+#endif
+ break;
+ }
+ if (strEQ(name, "SEEK_CUR"))
+#ifdef SEEK_CUR
+ return SEEK_CUR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SEEK_END"))
+#ifdef SEEK_END
+ return SEEK_END;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SEEK_SET"))
+#ifdef SEEK_SET
+ return SEEK_SET;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "STREAM_MAX"))
+#ifdef STREAM_MAX
+ return STREAM_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SHRT_MAX"))
+#ifdef SHRT_MAX
+ return SHRT_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SHRT_MIN"))
+#ifdef SHRT_MIN
+ return SHRT_MIN;
+#else
+ goto not_there;
+#endif
+ if (strnEQ(name, "SA_", 3)) {
+ if (strEQ(name, "SA_NOCLDSTOP"))
+#ifdef SA_NOCLDSTOP
+ return SA_NOCLDSTOP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SA_NOCLDWAIT"))
+#ifdef SA_NOCLDWAIT
+ return SA_NOCLDWAIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SA_NODEFER"))
+#ifdef SA_NODEFER
+ return SA_NODEFER;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SA_ONSTACK"))
+#ifdef SA_ONSTACK
+ return SA_ONSTACK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SA_RESETHAND"))
+#ifdef SA_RESETHAND
+ return SA_RESETHAND;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SA_RESTART"))
+#ifdef SA_RESTART
+ return SA_RESTART;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SA_SIGINFO"))
+#ifdef SA_SIGINFO
+ return SA_SIGINFO;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (strEQ(name, "SCHAR_MAX"))
+#ifdef SCHAR_MAX
+ return SCHAR_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SCHAR_MIN"))
+#ifdef SCHAR_MIN
+ return SCHAR_MIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SSIZE_MAX"))
+#ifdef SSIZE_MAX
+ return SSIZE_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "STDIN_FILENO"))
+#ifdef STDIN_FILENO
+ return STDIN_FILENO;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "STDOUT_FILENO"))
+#ifdef STDOUT_FILENO
+ return STDOUT_FILENO;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "STRERR_FILENO"))
+#ifdef STRERR_FILENO
+ return STRERR_FILENO;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'T':
+ if (strEQ(name, "TCIFLUSH"))
+#ifdef TCIFLUSH
+ return TCIFLUSH;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TCIOFF"))
+#ifdef TCIOFF
+ return TCIOFF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TCIOFLUSH"))
+#ifdef TCIOFLUSH
+ return TCIOFLUSH;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TCION"))
+#ifdef TCION
+ return TCION;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TCOFLUSH"))
+#ifdef TCOFLUSH
+ return TCOFLUSH;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TCOOFF"))
+#ifdef TCOOFF
+ return TCOOFF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TCOON"))
+#ifdef TCOON
+ return TCOON;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TCSADRAIN"))
+#ifdef TCSADRAIN
+ return TCSADRAIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TCSAFLUSH"))
+#ifdef TCSAFLUSH
+ return TCSAFLUSH;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TCSANOW"))
+#ifdef TCSANOW
+ return TCSANOW;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TMP_MAX"))
+#ifdef TMP_MAX
+ return TMP_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TOSTOP"))
+#ifdef TOSTOP
+ return TOSTOP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "TZNAME_MAX"))
+#ifdef TZNAME_MAX
+ return TZNAME_MAX;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'U':
+ if (strEQ(name, "UCHAR_MAX"))
+#ifdef UCHAR_MAX
+ return UCHAR_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "UINT_MAX"))
+#ifdef UINT_MAX
+ return UINT_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ULONG_MAX"))
+#ifdef ULONG_MAX
+ return ULONG_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "USHRT_MAX"))
+#ifdef USHRT_MAX
+ return USHRT_MAX;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'V':
+ if (strEQ(name, "VEOF"))
+#ifdef VEOF
+ return VEOF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "VEOL"))
+#ifdef VEOL
+ return VEOL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "VERASE"))
+#ifdef VERASE
+ return VERASE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "VINTR"))
+#ifdef VINTR
+ return VINTR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "VKILL"))
+#ifdef VKILL
+ return VKILL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "VMIN"))
+#ifdef VMIN
+ return VMIN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "VQUIT"))
+#ifdef VQUIT
+ return VQUIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "VSTART"))
+#ifdef VSTART
+ return VSTART;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "VSTOP"))
+#ifdef VSTOP
+ return VSTOP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "VSUSP"))
+#ifdef VSUSP
+ return VSUSP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "VTIME"))
+#ifdef VTIME
+ return VTIME;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'W':
+ if (strEQ(name, "W_OK"))
+#ifdef W_OK
+ return W_OK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "WNOHANG"))
+#ifdef WNOHANG
+ return WNOHANG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "WUNTRACED"))
+#ifdef WUNTRACED
+ return WUNTRACED;
+#else
+ goto not_there;
+#endif
+ errno = EAGAIN; /* the following aren't constants */
+#ifdef WEXITSTATUS
+ if (strEQ(name, "WEXITSTATUS")) return WEXITSTATUS(arg);
+#endif
+#ifdef WIFEXITED
+ if (strEQ(name, "WIFEXITED")) return WIFEXITED(arg);
+#endif
+#ifdef WIFSIGNALED
+ if (strEQ(name, "WIFSIGNALED")) return WIFSIGNALED(arg);
+#endif
+#ifdef WIFSTOPPED
+ if (strEQ(name, "WIFSTOPPED")) return WIFSTOPPED(arg);
+#endif
+#ifdef WSTOPSIG
+ if (strEQ(name, "WSTOPSIG")) return WSTOPSIG(arg);
+#endif
+#ifdef WTERMSIG
+ if (strEQ(name, "WTERMSIG")) return WTERMSIG(arg);
+#endif
+ break;
+ case 'X':
+ if (strEQ(name, "X_OK"))
+#ifdef X_OK
+ return X_OK;
+#else
+ goto not_there;
+#endif
+ break;
+ case '_':
+ if (strnEQ(name, "_PC_", 4)) {
+ if (strEQ(name, "_PC_CHOWN_RESTRICTED"))
+#if defined(_PC_CHOWN_RESTRICTED) || HINT_SC_EXIST
+ return _PC_CHOWN_RESTRICTED;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_PC_LINK_MAX"))
+#if defined(_PC_LINK_MAX) || HINT_SC_EXIST
+ return _PC_LINK_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_PC_MAX_CANON"))
+#if defined(_PC_MAX_CANON) || HINT_SC_EXIST
+ return _PC_MAX_CANON;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_PC_MAX_INPUT"))
+#if defined(_PC_MAX_INPUT) || HINT_SC_EXIST
+ return _PC_MAX_INPUT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_PC_NAME_MAX"))
+#if defined(_PC_NAME_MAX) || HINT_SC_EXIST
+ return _PC_NAME_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_PC_NO_TRUNC"))
+#if defined(_PC_NO_TRUNC) || HINT_SC_EXIST
+ return _PC_NO_TRUNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_PC_PATH_MAX"))
+#if defined(_PC_PATH_MAX) || HINT_SC_EXIST
+ return _PC_PATH_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_PC_PIPE_BUF"))
+#if defined(_PC_PIPE_BUF) || HINT_SC_EXIST
+ return _PC_PIPE_BUF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_PC_VDISABLE"))
+#if defined(_PC_VDISABLE) || HINT_SC_EXIST
+ return _PC_VDISABLE;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ if (strnEQ(name, "_POSIX_", 7)) {
+ if (strEQ(name, "_POSIX_ARG_MAX"))
+#ifdef _POSIX_ARG_MAX
+ return _POSIX_ARG_MAX;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_CHILD_MAX"))
+#ifdef _POSIX_CHILD_MAX
+ return _POSIX_CHILD_MAX;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_CHOWN_RESTRICTED"))
+#ifdef _POSIX_CHOWN_RESTRICTED
+ return _POSIX_CHOWN_RESTRICTED;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_JOB_CONTROL"))
+#ifdef _POSIX_JOB_CONTROL
+ return _POSIX_JOB_CONTROL;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_LINK_MAX"))
+#ifdef _POSIX_LINK_MAX
+ return _POSIX_LINK_MAX;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_MAX_CANON"))
+#ifdef _POSIX_MAX_CANON
+ return _POSIX_MAX_CANON;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_MAX_INPUT"))
+#ifdef _POSIX_MAX_INPUT
+ return _POSIX_MAX_INPUT;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_NAME_MAX"))
+#ifdef _POSIX_NAME_MAX
+ return _POSIX_NAME_MAX;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_NGROUPS_MAX"))
+#ifdef _POSIX_NGROUPS_MAX
+ return _POSIX_NGROUPS_MAX;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_NO_TRUNC"))
+#ifdef _POSIX_NO_TRUNC
+ return _POSIX_NO_TRUNC;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_OPEN_MAX"))
+#ifdef _POSIX_OPEN_MAX
+ return _POSIX_OPEN_MAX;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_PATH_MAX"))
+#ifdef _POSIX_PATH_MAX
+ return _POSIX_PATH_MAX;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_PIPE_BUF"))
+#ifdef _POSIX_PIPE_BUF
+ return _POSIX_PIPE_BUF;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_SAVED_IDS"))
+#ifdef _POSIX_SAVED_IDS
+ return _POSIX_SAVED_IDS;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_SSIZE_MAX"))
+#ifdef _POSIX_SSIZE_MAX
+ return _POSIX_SSIZE_MAX;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_STREAM_MAX"))
+#ifdef _POSIX_STREAM_MAX
+ return _POSIX_STREAM_MAX;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_TZNAME_MAX"))
+#ifdef _POSIX_TZNAME_MAX
+ return _POSIX_TZNAME_MAX;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_VDISABLE"))
+#ifdef _POSIX_VDISABLE
+ return _POSIX_VDISABLE;
+#else
+ return 0;
+#endif
+ if (strEQ(name, "_POSIX_VERSION"))
+#ifdef _POSIX_VERSION
+ return _POSIX_VERSION;
+#else
+ return 0;
+#endif
+ break;
+ }
+ if (strnEQ(name, "_SC_", 4)) {
+ if (strEQ(name, "_SC_ARG_MAX"))
+#if defined(_SC_ARG_MAX) || HINT_SC_EXIST
+ return _SC_ARG_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_SC_CHILD_MAX"))
+#if defined(_SC_CHILD_MAX) || HINT_SC_EXIST
+ return _SC_CHILD_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_SC_CLK_TCK"))
+#if defined(_SC_CLK_TCK) || HINT_SC_EXIST
+ return _SC_CLK_TCK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_SC_JOB_CONTROL"))
+#if defined(_SC_JOB_CONTROL) || HINT_SC_EXIST
+ return _SC_JOB_CONTROL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_SC_NGROUPS_MAX"))
+#if defined(_SC_NGROUPS_MAX) || HINT_SC_EXIST
+ return _SC_NGROUPS_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_SC_OPEN_MAX"))
+#if defined(_SC_OPEN_MAX) || HINT_SC_EXIST
+ return _SC_OPEN_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_SC_SAVED_IDS"))
+#if defined(_SC_SAVED_IDS) || HINT_SC_EXIST
+ return _SC_SAVED_IDS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_SC_STREAM_MAX"))
+#if defined(_SC_STREAM_MAX) || HINT_SC_EXIST
+ return _SC_STREAM_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_SC_TZNAME_MAX"))
+#if defined(_SC_TZNAME_MAX) || HINT_SC_EXIST
+ return _SC_TZNAME_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "_SC_VERSION"))
+#if defined(_SC_VERSION) || HINT_SC_EXIST
+ return _SC_VERSION;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
+
+POSIX::SigSet
+new(packname = "POSIX::SigSet", ...)
+ char * packname
+ CODE:
+ {
+ int i;
+ RETVAL = (sigset_t*)safemalloc(sizeof(sigset_t));
+ sigemptyset(RETVAL);
+ for (i = 1; i < items; i++)
+ sigaddset(RETVAL, SvIV(ST(i)));
+ }
+ OUTPUT:
+ RETVAL
+
+void
+DESTROY(sigset)
+ POSIX::SigSet sigset
+ CODE:
+ safefree((char *)sigset);
+
+SysRet
+sigaddset(sigset, sig)
+ POSIX::SigSet sigset
+ int sig
+
+SysRet
+sigdelset(sigset, sig)
+ POSIX::SigSet sigset
+ int sig
+
+SysRet
+sigemptyset(sigset)
+ POSIX::SigSet sigset
+
+SysRet
+sigfillset(sigset)
+ POSIX::SigSet sigset
+
+int
+sigismember(sigset, sig)
+ POSIX::SigSet sigset
+ int sig
+
+
+MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf
+
+POSIX::Termios
+new(packname = "POSIX::Termios", ...)
+ char * packname
+ CODE:
+ {
+#ifdef I_TERMIOS
+ RETVAL = (struct termios*)safemalloc(sizeof(struct termios));
+#else
+ not_here("termios");
+ RETVAL = 0;
+#endif
+ }
+ OUTPUT:
+ RETVAL
+
+void
+DESTROY(termios_ref)
+ POSIX::Termios termios_ref
+ CODE:
+#ifdef I_TERMIOS
+ safefree((char *)termios_ref);
+#else
+ not_here("termios");
+#endif
+
+SysRet
+getattr(termios_ref, fd = 0)
+ POSIX::Termios termios_ref
+ int fd
+ CODE:
+ RETVAL = tcgetattr(fd, termios_ref);
+ OUTPUT:
+ RETVAL
+
+SysRet
+setattr(termios_ref, fd = 0, optional_actions = 0)
+ POSIX::Termios termios_ref
+ int fd
+ int optional_actions
+ CODE:
+ RETVAL = tcsetattr(fd, optional_actions, termios_ref);
+ OUTPUT:
+ RETVAL
+
+speed_t
+cfgetispeed(termios_ref)
+ POSIX::Termios termios_ref
+
+speed_t
+cfgetospeed(termios_ref)
+ POSIX::Termios termios_ref
+
+tcflag_t
+getiflag(termios_ref)
+ POSIX::Termios termios_ref
+ CODE:
+#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
+ RETVAL = termios_ref->c_iflag;
+#else
+ not_here("getiflag");
+ RETVAL = 0;
+#endif
+ OUTPUT:
+ RETVAL
+
+tcflag_t
+getoflag(termios_ref)
+ POSIX::Termios termios_ref
+ CODE:
+#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
+ RETVAL = termios_ref->c_oflag;
+#else
+ not_here("getoflag");
+ RETVAL = 0;
+#endif
+ OUTPUT:
+ RETVAL
+
+tcflag_t
+getcflag(termios_ref)
+ POSIX::Termios termios_ref
+ CODE:
+#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
+ RETVAL = termios_ref->c_cflag;
+#else
+ not_here("getcflag");
+ RETVAL = 0;
+#endif
+ OUTPUT:
+ RETVAL
+
+tcflag_t
+getlflag(termios_ref)
+ POSIX::Termios termios_ref
+ CODE:
+#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
+ RETVAL = termios_ref->c_lflag;
+#else
+ not_here("getlflag");
+ RETVAL = 0;
+#endif
+ OUTPUT:
+ RETVAL
+
+cc_t
+getcc(termios_ref, ccix)
+ POSIX::Termios termios_ref
+ int ccix
+ CODE:
+#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
+ if (ccix >= NCCS)
+ croak("Bad getcc subscript");
+ RETVAL = termios_ref->c_cc[ccix];
+#else
+ not_here("getcc");
+ RETVAL = 0;
+#endif
+ OUTPUT:
+ RETVAL
+
+SysRet
+cfsetispeed(termios_ref, speed)
+ POSIX::Termios termios_ref
+ speed_t speed
+
+SysRet
+cfsetospeed(termios_ref, speed)
+ POSIX::Termios termios_ref
+ speed_t speed
+
+void
+setiflag(termios_ref, iflag)
+ POSIX::Termios termios_ref
+ tcflag_t iflag
+ CODE:
+#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
+ termios_ref->c_iflag = iflag;
+#else
+ not_here("setiflag");
+#endif
+
+void
+setoflag(termios_ref, oflag)
+ POSIX::Termios termios_ref
+ tcflag_t oflag
+ CODE:
+#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
+ termios_ref->c_oflag = oflag;
+#else
+ not_here("setoflag");
+#endif
+
+void
+setcflag(termios_ref, cflag)
+ POSIX::Termios termios_ref
+ tcflag_t cflag
+ CODE:
+#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
+ termios_ref->c_cflag = cflag;
+#else
+ not_here("setcflag");
+#endif
+
+void
+setlflag(termios_ref, lflag)
+ POSIX::Termios termios_ref
+ tcflag_t lflag
+ CODE:
+#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
+ termios_ref->c_lflag = lflag;
+#else
+ not_here("setlflag");
+#endif
+
+void
+setcc(termios_ref, ccix, cc)
+ POSIX::Termios termios_ref
+ int ccix
+ cc_t cc
+ CODE:
+#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
+ if (ccix >= NCCS)
+ croak("Bad setcc subscript");
+ termios_ref->c_cc[ccix] = cc;
+#else
+ not_here("setcc");
+#endif
+
+
+MODULE = POSIX PACKAGE = POSIX
+
+double
+constant(name,arg)
+ char * name
+ int arg
+
+int
+isalnum(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!isalnum(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+int
+isalpha(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!isalpha(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+int
+iscntrl(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!iscntrl(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+int
+isdigit(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!isdigit(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+int
+isgraph(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!isgraph(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+int
+islower(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!islower(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+int
+isprint(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!isprint(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+int
+ispunct(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!ispunct(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+int
+isspace(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!isspace(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+int
+isupper(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!isupper(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+int
+isxdigit(charstring)
+ unsigned char * charstring
+ CODE:
+ unsigned char *s = charstring;
+ unsigned char *e = s + PL_na; /* "PL_na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
+ if (!isxdigit(*s))
+ RETVAL = 0;
+ OUTPUT:
+ RETVAL
+
+SysRet
+open(filename, flags = O_RDONLY, mode = 0666)
+ char * filename
+ int flags
+ Mode_t mode
+ CODE:
+ if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
+ TAINT_PROPER("open");
+ RETVAL = open(filename, flags, mode);
+ OUTPUT:
+ RETVAL
+
+
+HV *
+localeconv()
+ CODE:
+#ifdef HAS_LOCALECONV
+ struct lconv *lcbuf;
+ RETVAL = newHV();
+ if (lcbuf = localeconv()) {
+ /* the strings */
+ if (lcbuf->decimal_point && *lcbuf->decimal_point)
+ hv_store(RETVAL, "decimal_point", 13,
+ newSVpv(lcbuf->decimal_point, 0), 0);
+ if (lcbuf->thousands_sep && *lcbuf->thousands_sep)
+ hv_store(RETVAL, "thousands_sep", 13,
+ newSVpv(lcbuf->thousands_sep, 0), 0);
+#ifndef NO_LOCALECONV_GROUPING
+ if (lcbuf->grouping && *lcbuf->grouping)
+ hv_store(RETVAL, "grouping", 8,
+ newSVpv(lcbuf->grouping, 0), 0);
+#endif
+ if (lcbuf->int_curr_symbol && *lcbuf->int_curr_symbol)
+ hv_store(RETVAL, "int_curr_symbol", 15,
+ newSVpv(lcbuf->int_curr_symbol, 0), 0);
+ if (lcbuf->currency_symbol && *lcbuf->currency_symbol)
+ hv_store(RETVAL, "currency_symbol", 15,
+ newSVpv(lcbuf->currency_symbol, 0), 0);
+ if (lcbuf->mon_decimal_point && *lcbuf->mon_decimal_point)
+ hv_store(RETVAL, "mon_decimal_point", 17,
+ newSVpv(lcbuf->mon_decimal_point, 0), 0);
+#ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
+ if (lcbuf->mon_thousands_sep && *lcbuf->mon_thousands_sep)
+ hv_store(RETVAL, "mon_thousands_sep", 17,
+ newSVpv(lcbuf->mon_thousands_sep, 0), 0);
+#endif
+#ifndef NO_LOCALECONV_MON_GROUPING
+ if (lcbuf->mon_grouping && *lcbuf->mon_grouping)
+ hv_store(RETVAL, "mon_grouping", 12,
+ newSVpv(lcbuf->mon_grouping, 0), 0);
+#endif
+ if (lcbuf->positive_sign && *lcbuf->positive_sign)
+ hv_store(RETVAL, "positive_sign", 13,
+ newSVpv(lcbuf->positive_sign, 0), 0);
+ if (lcbuf->negative_sign && *lcbuf->negative_sign)
+ hv_store(RETVAL, "negative_sign", 13,
+ newSVpv(lcbuf->negative_sign, 0), 0);
+ /* the integers */
+ if (lcbuf->int_frac_digits != CHAR_MAX)
+ hv_store(RETVAL, "int_frac_digits", 15,
+ newSViv(lcbuf->int_frac_digits), 0);
+ if (lcbuf->frac_digits != CHAR_MAX)
+ hv_store(RETVAL, "frac_digits", 11,
+ newSViv(lcbuf->frac_digits), 0);
+ if (lcbuf->p_cs_precedes != CHAR_MAX)
+ hv_store(RETVAL, "p_cs_precedes", 13,
+ newSViv(lcbuf->p_cs_precedes), 0);
+ if (lcbuf->p_sep_by_space != CHAR_MAX)
+ hv_store(RETVAL, "p_sep_by_space", 14,
+ newSViv(lcbuf->p_sep_by_space), 0);
+ if (lcbuf->n_cs_precedes != CHAR_MAX)
+ hv_store(RETVAL, "n_cs_precedes", 13,
+ newSViv(lcbuf->n_cs_precedes), 0);
+ if (lcbuf->n_sep_by_space != CHAR_MAX)
+ hv_store(RETVAL, "n_sep_by_space", 14,
+ newSViv(lcbuf->n_sep_by_space), 0);
+ if (lcbuf->p_sign_posn != CHAR_MAX)
+ hv_store(RETVAL, "p_sign_posn", 11,
+ newSViv(lcbuf->p_sign_posn), 0);
+ if (lcbuf->n_sign_posn != CHAR_MAX)
+ hv_store(RETVAL, "n_sign_posn", 11,
+ newSViv(lcbuf->n_sign_posn), 0);
+ }
+#else
+ localeconv(); /* A stub to call not_here(). */
+#endif
+ OUTPUT:
+ RETVAL
+
+char *
+setlocale(category, locale = 0)
+ int category
+ char * locale
+ CODE:
+ RETVAL = setlocale(category, locale);
+ if (RETVAL) {
+#ifdef USE_LOCALE_CTYPE
+ if (category == LC_CTYPE
+#ifdef LC_ALL
+ || category == LC_ALL
+#endif
+ )
+ {
+ char *newctype;
+#ifdef LC_ALL
+ if (category == LC_ALL)
+ newctype = setlocale(LC_CTYPE, NULL);
+ else
+#endif
+ newctype = RETVAL;
+ perl_new_ctype(newctype);
+ }
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ if (category == LC_COLLATE
+#ifdef LC_ALL
+ || category == LC_ALL
+#endif
+ )
+ {
+ char *newcoll;
+#ifdef LC_ALL
+ if (category == LC_ALL)
+ newcoll = setlocale(LC_COLLATE, NULL);
+ else
+#endif
+ newcoll = RETVAL;
+ perl_new_collate(newcoll);
+ }
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ if (category == LC_NUMERIC
+#ifdef LC_ALL
+ || category == LC_ALL
+#endif
+ )
+ {
+ char *newnum;
+#ifdef LC_ALL
+ if (category == LC_ALL)
+ newnum = setlocale(LC_NUMERIC, NULL);
+ else
+#endif
+ newnum = RETVAL;
+ perl_new_numeric(newnum);
+ }
+#endif /* USE_LOCALE_NUMERIC */
+ }
+ OUTPUT:
+ RETVAL
+
+
+double
+acos(x)
+ double x
+
+double
+asin(x)
+ double x
+
+double
+atan(x)
+ double x
+
+double
+ceil(x)
+ double x
+
+double
+cosh(x)
+ double x
+
+double
+floor(x)
+ double x
+
+double
+fmod(x,y)
+ double x
+ double y
+
+void
+frexp(x)
+ double x
+ PPCODE:
+ int expvar;
+ /* (We already know stack is long enough.) */
+ PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar))));
+ PUSHs(sv_2mortal(newSViv(expvar)));
+
+double
+ldexp(x,exp)
+ double x
+ int exp
+
+double
+log10(x)
+ double x
+
+void
+modf(x)
+ double x
+ PPCODE:
+ double intvar;
+ /* (We already know stack is long enough.) */
+ PUSHs(sv_2mortal(newSVnv(modf(x,&intvar))));
+ PUSHs(sv_2mortal(newSVnv(intvar)));
+
+double
+sinh(x)
+ double x
+
+double
+tan(x)
+ double x
+
+double
+tanh(x)
+ double x
+
+SysRet
+sigaction(sig, action, oldaction = 0)
+ int sig
+ POSIX::SigAction action
+ POSIX::SigAction oldaction
+ CODE:
+#ifdef WIN32
+ RETVAL = not_here("sigaction");
+#else
+# This code is really grody because we're trying to make the signal
+# interface look beautiful, which is hard.
+
+ if (!PL_siggv)
+ gv_fetchpv("SIG", TRUE, SVt_PVHV);
+
+ {
+ struct sigaction act;
+ struct sigaction oact;
+ POSIX__SigSet sigset;
+ SV** svp;
+ SV** sigsvp = hv_fetch(GvHVn(PL_siggv),
+ sig_name[sig],
+ strlen(sig_name[sig]),
+ TRUE);
+
+ /* Remember old handler name if desired. */
+ if (oldaction) {
+ char *hand = SvPVx(*sigsvp, PL_na);
+ svp = hv_fetch(oldaction, "HANDLER", 7, TRUE);
+ sv_setpv(*svp, *hand ? hand : "DEFAULT");
+ }
+
+ if (action) {
+ /* Vector new handler through %SIG. (We always use sighandler
+ for the C signal handler, which reads %SIG to dispatch.) */
+ 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));
+ mg_set(*sigsvp); /* handles DEFAULT and IGNORE */
+ act.sa_handler = sighandler;
+
+ /* Set up any desired mask. */
+ svp = hv_fetch(action, "MASK", 4, FALSE);
+ if (svp && sv_isa(*svp, "POSIX::SigSet")) {
+ unsigned long tmp;
+ tmp = (unsigned long)SvNV((SV*)SvRV(*svp));
+ sigset = (sigset_t*) tmp;
+ act.sa_mask = *sigset;
+ }
+ else
+ sigemptyset(& act.sa_mask);
+
+ /* Set up any desired flags. */
+ svp = hv_fetch(action, "FLAGS", 5, FALSE);
+ act.sa_flags = svp ? SvIV(*svp) : 0;
+ }
+
+ /* Now work around sigaction oddities */
+ if (action && oldaction)
+ RETVAL = sigaction(sig, & act, & oact);
+ else if (action)
+ RETVAL = sigaction(sig, & act, (struct sigaction *)0);
+ else if (oldaction)
+ RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
+ else
+ RETVAL = -1;
+
+ if (oldaction) {
+ /* Get back the mask. */
+ svp = hv_fetch(oldaction, "MASK", 4, TRUE);
+ if (sv_isa(*svp, "POSIX::SigSet")) {
+ unsigned long tmp;
+ tmp = (unsigned long)SvNV((SV*)SvRV(*svp));
+ sigset = (sigset_t*) tmp;
+ }
+ else {
+ sigset = (sigset_t*)safemalloc(sizeof(sigset_t));
+ sv_setptrobj(*svp, sigset, "POSIX::SigSet");
+ }
+ *sigset = oact.sa_mask;
+
+ /* Get back the flags. */
+ svp = hv_fetch(oldaction, "FLAGS", 5, TRUE);
+ sv_setiv(*svp, oact.sa_flags);
+ }
+ }
+#endif
+ OUTPUT:
+ RETVAL
+
+SysRet
+sigpending(sigset)
+ POSIX::SigSet sigset
+
+SysRet
+sigprocmask(how, sigset, oldsigset = 0)
+ int how
+ POSIX::SigSet sigset
+ POSIX::SigSet oldsigset
+
+SysRet
+sigsuspend(signal_mask)
+ POSIX::SigSet signal_mask
+
+void
+_exit(status)
+ int status
+
+SysRet
+close(fd)
+ int fd
+
+SysRet
+dup(fd)
+ int fd
+
+SysRet
+dup2(fd1, fd2)
+ int fd1
+ int fd2
+
+SysRetLong
+lseek(fd, offset, whence)
+ int fd
+ Off_t offset
+ int whence
+
+SysRet
+nice(incr)
+ int incr
+
+int
+pipe()
+ PPCODE:
+ int fds[2];
+ if (pipe(fds) != -1) {
+ EXTEND(SP,2);
+ PUSHs(sv_2mortal(newSViv(fds[0])));
+ PUSHs(sv_2mortal(newSViv(fds[1])));
+ }
+
+SysRet
+read(fd, buffer, nbytes)
+ PREINIT:
+ SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
+ INPUT:
+ int fd
+ size_t nbytes
+ char * buffer = sv_grow( sv_buffer, nbytes+1 );
+ CLEANUP:
+ if (RETVAL >= 0) {
+ SvCUR(sv_buffer) = RETVAL;
+ SvPOK_only(sv_buffer);
+ *SvEND(sv_buffer) = '\0';
+ SvTAINTED_on(sv_buffer);
+ }
+
+SysRet
+setpgid(pid, pgid)
+ pid_t pid
+ pid_t pgid
+
+pid_t
+setsid()
+
+pid_t
+tcgetpgrp(fd)
+ int fd
+
+SysRet
+tcsetpgrp(fd, pgrp_id)
+ int fd
+ pid_t pgrp_id
+
+int
+uname()
+ PPCODE:
+#ifdef HAS_UNAME
+ struct utsname buf;
+ if (uname(&buf) >= 0) {
+ EXTEND(SP, 5);
+ PUSHs(sv_2mortal(newSVpv(buf.sysname, 0)));
+ PUSHs(sv_2mortal(newSVpv(buf.nodename, 0)));
+ PUSHs(sv_2mortal(newSVpv(buf.release, 0)));
+ PUSHs(sv_2mortal(newSVpv(buf.version, 0)));
+ PUSHs(sv_2mortal(newSVpv(buf.machine, 0)));
+ }
+#else
+ uname((char *) 0); /* A stub to call not_here(). */
+#endif
+
+SysRet
+write(fd, buffer, nbytes)
+ int fd
+ char * buffer
+ size_t nbytes
+
+char *
+tmpnam(s = 0)
+ char * s = 0;
+
+void
+abort()
+
+int
+mblen(s, n)
+ char * s
+ size_t n
+
+size_t
+mbstowcs(s, pwcs, n)
+ wchar_t * s
+ char * pwcs
+ size_t n
+
+int
+mbtowc(pwc, s, n)
+ wchar_t * pwc
+ char * s
+ size_t n
+
+int
+wcstombs(s, pwcs, n)
+ char * s
+ wchar_t * pwcs
+ size_t n
+
+int
+wctomb(s, wchar)
+ char * s
+ wchar_t wchar
+
+int
+strcoll(s1, s2)
+ char * s1
+ char * s2
+
+void
+strtod(str)
+ char * str
+ PREINIT:
+ double num;
+ char *unparsed;
+ PPCODE:
+ SET_NUMERIC_LOCAL();
+ num = strtod(str, &unparsed);
+ PUSHs(sv_2mortal(newSVnv(num)));
+ if (GIMME == G_ARRAY) {
+ EXTEND(SP, 1);
+ if (unparsed)
+ PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
+ else
+ PUSHs(&PL_sv_undef);
+ }
+
+void
+strtol(str, base = 0)
+ char * str
+ int base
+ PREINIT:
+ long num;
+ char *unparsed;
+ PPCODE:
+ num = strtol(str, &unparsed, base);
+ if (num >= IV_MIN && num <= IV_MAX)
+ PUSHs(sv_2mortal(newSViv((IV)num)));
+ else
+ PUSHs(sv_2mortal(newSVnv((double)num)));
+ if (GIMME == G_ARRAY) {
+ EXTEND(SP, 1);
+ if (unparsed)
+ PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
+ else
+ PUSHs(&PL_sv_undef);
+ }
+
+void
+strtoul(str, base = 0)
+ char * str
+ int base
+ PREINIT:
+ unsigned long num;
+ char *unparsed;
+ PPCODE:
+ num = strtoul(str, &unparsed, base);
+ if (num <= IV_MAX)
+ PUSHs(sv_2mortal(newSViv((IV)num)));
+ else
+ PUSHs(sv_2mortal(newSVnv((double)num)));
+ if (GIMME == G_ARRAY) {
+ EXTEND(SP, 1);
+ if (unparsed)
+ PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
+ else
+ PUSHs(&PL_sv_undef);
+ }
+
+SV *
+strxfrm(src)
+ SV * src
+ CODE:
+ {
+ STRLEN srclen;
+ STRLEN dstlen;
+ char *p = SvPV(src,srclen);
+ srclen++;
+ ST(0) = sv_2mortal(NEWSV(800,srclen));
+ dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)srclen);
+ if (dstlen > srclen) {
+ dstlen++;
+ SvGROW(ST(0), dstlen);
+ strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
+ dstlen--;
+ }
+ SvCUR(ST(0)) = dstlen;
+ SvPOK_only(ST(0));
+ }
+
+SysRet
+mkfifo(filename, mode)
+ char * filename
+ Mode_t mode
+ CODE:
+ TAINT_PROPER("mkfifo");
+ RETVAL = mkfifo(filename, mode);
+ OUTPUT:
+ RETVAL
+
+SysRet
+tcdrain(fd)
+ int fd
+
+
+SysRet
+tcflow(fd, action)
+ int fd
+ int action
+
+
+SysRet
+tcflush(fd, queue_selector)
+ int fd
+ int queue_selector
+
+SysRet
+tcsendbreak(fd, duration)
+ int fd
+ int duration
+
+char *
+asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0)
+ int sec
+ int min
+ int hour
+ int mday
+ int mon
+ int year
+ int wday
+ int yday
+ int isdst
+ CODE:
+ {
+ struct tm mytm;
+ init_tm(&mytm); /* XXX workaround - see init_tm() above */
+ mytm.tm_sec = sec;
+ mytm.tm_min = min;
+ mytm.tm_hour = hour;
+ mytm.tm_mday = mday;
+ mytm.tm_mon = mon;
+ mytm.tm_year = year;
+ mytm.tm_wday = wday;
+ mytm.tm_yday = yday;
+ mytm.tm_isdst = isdst;
+ RETVAL = asctime(&mytm);
+ }
+ OUTPUT:
+ RETVAL
+
+long
+clock()
+
+char *
+ctime(time)
+ Time_t &time
+
+void
+times()
+ PPCODE:
+ struct tms tms;
+ clock_t realtime;
+ realtime = times( &tms );
+ EXTEND(SP,5);
+ PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
+ PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
+ PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
+ PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
+ PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
+
+double
+difftime(time1, time2)
+ Time_t time1
+ Time_t time2
+
+SysRetLong
+mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0)
+ int sec
+ int min
+ int hour
+ int mday
+ int mon
+ int year
+ int wday
+ int yday
+ int isdst
+ CODE:
+ {
+ struct tm mytm;
+ init_tm(&mytm); /* XXX workaround - see init_tm() above */
+ mytm.tm_sec = sec;
+ mytm.tm_min = min;
+ mytm.tm_hour = hour;
+ mytm.tm_mday = mday;
+ mytm.tm_mon = mon;
+ mytm.tm_year = year;
+ mytm.tm_wday = wday;
+ mytm.tm_yday = yday;
+ mytm.tm_isdst = isdst;
+ RETVAL = mktime(&mytm);
+ }
+ OUTPUT:
+ RETVAL
+
+char *
+strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0)
+ char * fmt
+ int sec
+ int min
+ int hour
+ int mday
+ int mon
+ int year
+ int wday
+ int yday
+ int isdst
+ CODE:
+ {
+ char tmpbuf[128];
+ struct tm mytm;
+ int len;
+ init_tm(&mytm); /* XXX workaround - see init_tm() above */
+ mytm.tm_sec = sec;
+ mytm.tm_min = min;
+ mytm.tm_hour = hour;
+ mytm.tm_mday = mday;
+ mytm.tm_mon = mon;
+ mytm.tm_year = year;
+ mytm.tm_wday = wday;
+ mytm.tm_yday = yday;
+ mytm.tm_isdst = isdst;
+ len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm);
+ ST(0) = sv_2mortal(newSVpv(tmpbuf, len));
+ }
+
+void
+tzset()
+
+void
+tzname()
+ PPCODE:
+ EXTEND(SP,2);
+ PUSHs(sv_2mortal(newSVpv(tzname[0],strlen(tzname[0]))));
+ PUSHs(sv_2mortal(newSVpv(tzname[1],strlen(tzname[1]))));
+
+SysRet
+access(filename, mode)
+ char * filename
+ Mode_t mode
+
+char *
+ctermid(s = 0)
+ char * s = 0;
+
+char *
+cuserid(s = 0)
+ char * s = 0;
+
+SysRetLong
+fpathconf(fd, name)
+ int fd
+ int name
+
+SysRetLong
+pathconf(filename, name)
+ char * filename
+ int name
+
+SysRet
+pause()
+
+SysRetLong
+sysconf(name)
+ int name
+
+char *
+ttyname(fd)
+ int fd
diff --git a/contrib/perl5/ext/POSIX/hints/bsdos.pl b/contrib/perl5/ext/POSIX/hints/bsdos.pl
new file mode 100644
index 000000000000..62732ac7b9d7
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/hints/bsdos.pl
@@ -0,0 +1,3 @@
+# BSD platforms have extra fields in struct tm that need to be initialized.
+# XXX A Configure test is needed.
+$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ;
diff --git a/contrib/perl5/ext/POSIX/hints/freebsd.pl b/contrib/perl5/ext/POSIX/hints/freebsd.pl
new file mode 100644
index 000000000000..62732ac7b9d7
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/hints/freebsd.pl
@@ -0,0 +1,3 @@
+# BSD platforms have extra fields in struct tm that need to be initialized.
+# XXX A Configure test is needed.
+$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ;
diff --git a/contrib/perl5/ext/POSIX/hints/linux.pl b/contrib/perl5/ext/POSIX/hints/linux.pl
new file mode 100644
index 000000000000..f1d19814ae10
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/hints/linux.pl
@@ -0,0 +1,5 @@
+# libc6, aka glibc2, seems to need STRUCT_TM_HASZONE defined.
+# Thanks to Bart Schuller <schuller@Lunatech.com>
+# See Message-ID: <19971009002636.50729@tanglefoot>
+# XXX A Configure test is needed.
+$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE -DHINT_SC_EXIST' ;
diff --git a/contrib/perl5/ext/POSIX/hints/netbsd.pl b/contrib/perl5/ext/POSIX/hints/netbsd.pl
new file mode 100644
index 000000000000..62732ac7b9d7
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/hints/netbsd.pl
@@ -0,0 +1,3 @@
+# BSD platforms have extra fields in struct tm that need to be initialized.
+# XXX A Configure test is needed.
+$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ;
diff --git a/contrib/perl5/ext/POSIX/hints/next_3.pl b/contrib/perl5/ext/POSIX/hints/next_3.pl
new file mode 100644
index 000000000000..d90778398b27
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/hints/next_3.pl
@@ -0,0 +1,5 @@
+# NeXT *does* have setpgid when we use the -posix flag, but
+# doesn't when we don't. The main perl sources are compiled
+# without -posix, so the hints/next_3.sh hint file tells Configure
+# that d_setpgid=undef.
+$self->{CCFLAGS} = $Config{ccflags} . ' -posix -DHAS_SETPGID' ;
diff --git a/contrib/perl5/ext/POSIX/hints/openbsd.pl b/contrib/perl5/ext/POSIX/hints/openbsd.pl
new file mode 100644
index 000000000000..62732ac7b9d7
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/hints/openbsd.pl
@@ -0,0 +1,3 @@
+# BSD platforms have extra fields in struct tm that need to be initialized.
+# XXX A Configure test is needed.
+$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ;
diff --git a/contrib/perl5/ext/POSIX/hints/sunos_4.pl b/contrib/perl5/ext/POSIX/hints/sunos_4.pl
new file mode 100644
index 000000000000..32b3558a5e88
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/hints/sunos_4.pl
@@ -0,0 +1,10 @@
+# SunOS 4.1.3 has two extra fields in struct tm. This works around
+# the problem. Other BSD platforms may have similar problems.
+# This state of affairs also persists in glibc2, found
+# on linux systems running libc6.
+# XXX A Configure test is needed.
+
+# Although <unistd.h> is inappropriate in general for SunOS, we need it
+# in POSIX.xs to get the correct prototype for ttyname().
+
+$self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE -DI_UNISTD' ;
diff --git a/contrib/perl5/ext/POSIX/typemap b/contrib/perl5/ext/POSIX/typemap
new file mode 100644
index 000000000000..63e41c77bf1f
--- /dev/null
+++ b/contrib/perl5/ext/POSIX/typemap
@@ -0,0 +1,14 @@
+Mode_t T_NV
+pid_t T_NV
+Uid_t T_NV
+Time_t T_NV
+Gid_t T_NV
+Off_t T_NV
+Dev_t T_NV
+fd T_IV
+speed_t T_IV
+tcflag_t T_IV
+cc_t T_IV
+POSIX::SigSet T_PTROBJ
+POSIX::Termios T_PTROBJ
+POSIX::SigAction T_HVREF
diff --git a/contrib/perl5/ext/SDBM_File/Makefile.PL b/contrib/perl5/ext/SDBM_File/Makefile.PL
new file mode 100644
index 000000000000..b639b2948f1a
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/Makefile.PL
@@ -0,0 +1,35 @@
+use ExtUtils::MakeMaker;
+
+# The existence of the ./sdbm/Makefile.PL file causes MakeMaker
+# to automatically include Makefile code for the targets
+# config, all, clean, realclean and sdbm/Makefile
+# which perform the corresponding actions in the subdirectory.
+
+$define = ($^O eq 'MSWin32') ? '-DMSDOS' : '';
+if ($^O eq 'MSWin32') { $myextlib = 'sdbm\\libsdbm$(LIB_EXT)'; }
+else { $myextlib = 'sdbm/libsdbm$(LIB_EXT)'; }
+
+WriteMakefile(
+ NAME => 'SDBM_File',
+ MYEXTLIB => $myextlib,
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'SDBM_File.pm',
+ DEFINE => $define,
+ );
+
+sub MY::postamble {
+ if ($^O ne 'VMS') {
+ '
+$(MYEXTLIB): sdbm/Makefile
+ cd sdbm && $(MAKE) all
+';
+ } else {
+ '
+$(MYEXTLIB) : [.sdbm]descrip.mms
+ set def [.sdbm]
+ $(MMS) all
+ set def [-]
+';
+ }
+}
diff --git a/contrib/perl5/ext/SDBM_File/SDBM_File.pm b/contrib/perl5/ext/SDBM_File/SDBM_File.pm
new file mode 100644
index 000000000000..a2d4df85587d
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/SDBM_File.pm
@@ -0,0 +1,35 @@
+package SDBM_File;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+require Tie::Hash;
+require DynaLoader;
+
+@ISA = qw(Tie::Hash DynaLoader);
+
+$VERSION = "1.00" ;
+
+bootstrap SDBM_File $VERSION;
+
+1;
+
+__END__
+
+=head1 NAME
+
+SDBM_File - Tied access to sdbm files
+
+=head1 SYNOPSIS
+
+ use SDBM_File;
+
+ tie(%h, 'SDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640);
+
+ untie %h;
+
+=head1 DESCRIPTION
+
+See L<perlfunc/tie>
+
+=cut
diff --git a/contrib/perl5/ext/SDBM_File/SDBM_File.xs b/contrib/perl5/ext/SDBM_File/SDBM_File.xs
new file mode 100644
index 000000000000..38eaebf5c5ef
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/SDBM_File.xs
@@ -0,0 +1,71 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "sdbm/sdbm.h"
+
+typedef DBM* SDBM_File;
+#define sdbm_TIEHASH(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode)
+#define sdbm_FETCH(db,key) sdbm_fetch(db,key)
+#define sdbm_STORE(db,key,value,flags) sdbm_store(db,key,value,flags)
+#define sdbm_DELETE(db,key) sdbm_delete(db,key)
+#define sdbm_FIRSTKEY(db) sdbm_firstkey(db)
+#define sdbm_NEXTKEY(db,key) sdbm_nextkey(db)
+
+
+MODULE = SDBM_File PACKAGE = SDBM_File PREFIX = sdbm_
+
+SDBM_File
+sdbm_TIEHASH(dbtype, filename, flags, mode)
+ char * dbtype
+ char * filename
+ int flags
+ int mode
+
+void
+sdbm_DESTROY(db)
+ SDBM_File db
+ CODE:
+ sdbm_close(db);
+
+datum
+sdbm_FETCH(db, key)
+ SDBM_File db
+ datum key
+
+int
+sdbm_STORE(db, key, value, flags = DBM_REPLACE)
+ SDBM_File db
+ datum key
+ datum value
+ int flags
+ CLEANUP:
+ if (RETVAL) {
+ if (RETVAL < 0 && errno == EPERM)
+ croak("No write permission to sdbm file");
+ croak("sdbm store returned %d, errno %d, key \"%s\"",
+ RETVAL,errno,key.dptr);
+ sdbm_clearerr(db);
+ }
+
+int
+sdbm_DELETE(db, key)
+ SDBM_File db
+ datum key
+
+datum
+sdbm_FIRSTKEY(db)
+ SDBM_File db
+
+datum
+sdbm_NEXTKEY(db, key)
+ SDBM_File db
+ datum key
+
+int
+sdbm_error(db)
+ SDBM_File db
+
+int
+sdbm_clearerr(db)
+ SDBM_File db
+
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/CHANGES b/contrib/perl5/ext/SDBM_File/sdbm/CHANGES
new file mode 100644
index 000000000000..f7296d1b3aaf
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/CHANGES
@@ -0,0 +1,18 @@
+Changes from the earlier BETA releases.
+
+o dbm_prep does everything now, so dbm_open is just a simple
+ wrapper that builds the default filenames. dbm_prep no longer
+ requires a (DBM *) db parameter: it allocates one itself. It
+ returns (DBM *) db or (DBM *) NULL.
+
+o makroom is now reliable. In the common-case optimization of the page
+ split, the page into which the incoming key/value pair is to be inserted
+ is write-deferred (if the split is successful), thereby saving a cosly
+ write. BUT, if the split does not make enough room (unsuccessful), the
+ deferred page is written out, as the failure-window is now dependent on
+ the number of split attempts.
+
+o if -DDUFF is defined, hash function will also use the DUFF construct.
+ This may look like a micro-performance tweak (maybe it is), but in fact,
+ the hash function is the third most-heavily used function, after read
+ and write.
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/COMPARE b/contrib/perl5/ext/SDBM_File/sdbm/COMPARE
new file mode 100644
index 000000000000..a595e831d269
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/COMPARE
@@ -0,0 +1,88 @@
+
+Script started on Thu Sep 28 15:41:06 1989
+% uname -a
+titan titan 4_0 UMIPS mips
+% make all x-dbm
+ cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dbm.c
+ cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c sdbm.c
+ cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c pair.c
+ cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c hash.c
+ ar cr libsdbm.a sdbm.o pair.o hash.o
+ ranlib libsdbm.a
+ cc -o dbm dbm.o libsdbm.a
+ cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dba.c
+ cc -o dba dba.o
+ cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -c dbd.c
+ cc -o dbd dbd.o
+ cc -O -DSDBM -DDUFF -DDUPERROR -DSPLITFAIL -o x-dbm dbm.o
+%
+%
+% wc history
+ 65110 218344 3204883 history
+%
+% /bin/time dbm build foo <history
+
+real 5:56.9
+user 13.3
+sys 26.3
+% ls -s
+total 14251
+ 5 README 2 dbd.c 1 hash.c 1 pair.h
+ 0 SCRIPT 5 dbd.o 1 hash.o 5 pair.o
+ 1 WISHLIST 62 dbm 3130 history 1 port.h
+ 46 dba 5 dbm.c 11 howtodbm.txt 11 sdbm.c
+ 3 dba.c 8 dbm.o 14 libsdbm.a 2 sdbm.h
+ 6 dba.o 4 foo.dir 1 makefile 8 sdbm.o
+ 46 dbd 10810 foo.pag 6 pair.c 60 x-dbm
+% ls -l foo.*
+-rw-r--r-- 1 oz 4096 Sep 28 15:48 foo.dir
+-rw-r--r-- 1 oz 11069440 Sep 28 15:48 foo.pag
+%
+% /bin/time x-dbm build bar <history
+
+real 5:59.4
+user 24.7
+sys 29.1
+%
+% ls -s
+total 27612
+ 5 README 46 dbd 1 hash.c 5 pair.o
+ 1 SCRIPT 2 dbd.c 1 hash.o 1 port.h
+ 1 WISHLIST 5 dbd.o 3130 history 11 sdbm.c
+ 4 bar.dir 62 dbm 11 howtodbm.txt 2 sdbm.h
+13356 bar.pag 5 dbm.c 14 libsdbm.a 8 sdbm.o
+ 46 dba 8 dbm.o 1 makefile 60 x-dbm
+ 3 dba.c 4 foo.dir 6 pair.c
+ 6 dba.o 10810 foo.pag 1 pair.h
+%
+% ls -l bar.*
+-rw-r--r-- 1 oz 4096 Sep 28 15:54 bar.dir
+-rw-r--r-- 1 oz 13676544 Sep 28 15:54 bar.pag
+%
+% dba foo | tail
+#10801: ok. no entries.
+#10802: ok. no entries.
+#10803: ok. no entries.
+#10804: ok. no entries.
+#10805: ok. no entries.
+#10806: ok. no entries.
+#10807: ok. no entries.
+#10808: ok. no entries.
+#10809: ok. 11 entries 67% used free 337.
+10810 pages (6036 holes): 65073 entries
+%
+% dba bar | tail
+#13347: ok. no entries.
+#13348: ok. no entries.
+#13349: ok. no entries.
+#13350: ok. no entries.
+#13351: ok. no entries.
+#13352: ok. no entries.
+#13353: ok. no entries.
+#13354: ok. no entries.
+#13355: ok. 7 entries 33% used free 676.
+13356 pages (8643 holes): 65073 entries
+%
+% exit
+script done on Thu Sep 28 16:08:45 1989
+
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL b/contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL
new file mode 100644
index 000000000000..e6fdcf93069e
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/Makefile.PL
@@ -0,0 +1,65 @@
+use ExtUtils::MakeMaker;
+
+$define = '-DSDBM -DDUFF';
+$define .= ' -DWIN32 -DPERL_STATIC_SYMS' if ($^O eq 'MSWin32');
+
+if ($^O eq 'VMS') { # Old VAXC compiler can't handle Duff's device
+ require Config;
+ $define =~ s/\s+-DDUFF// if $Config::Config{'vms_cc_type'} eq 'vaxc';
+}
+
+WriteMakefile(
+ NAME => 'sdbm', # (doesn't matter what the name is here) oh yes it does
+# LINKTYPE => 'static',
+ DEFINE => $define,
+ INC => '-I$(PERL_INC)', # force PERL_INC dir ahead of system -I's
+ INST_ARCHLIB => '.',
+ SKIP => [qw(dynamic dynamic_lib dlsyms)],
+ OBJECT => '$(O_FILES)',
+ clean => {'FILES' => 'dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag'},
+ H => [qw(tune.h sdbm.h pair.h $(PERL_INC)/config.h)],
+ C => [qw(sdbm.c pair.c hash.c)]
+);
+
+sub MY::constants {
+ package MY;
+ my $r = shift->SUPER::constants();
+ if ($^O eq 'VMS') {
+ $r =~ s/^INST_STATIC =.*$/INST_STATIC = libsdbm\$(LIB_EXT)/m
+ }
+ return $r;
+}
+
+sub MY::post_constants {
+ package MY;
+ if ($^O eq 'VMS') {
+ shift->SUPER::post_constants();
+ } else {
+'
+INST_STATIC = libsdbm$(LIB_EXT)
+'
+ }
+}
+
+sub MY::top_targets {
+ my $r = '
+all :: static
+ $(NOECHO) $(NOOP)
+
+config ::
+ $(NOECHO) $(NOOP)
+
+lint:
+ lint -abchx $(LIBSRCS)
+
+';
+ $r .= '
+# This is a workaround, the problem is that our old GNU make exports
+# variables into the environment so $(MYEXTLIB) is set in here to this
+# value which can not be built.
+sdbm/libsdbm.a:
+ $(NOECHO) $(NOOP)
+' unless $^O eq 'VMS';
+
+ return $r;
+}
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/README b/contrib/perl5/ext/SDBM_File/sdbm/README
new file mode 100644
index 000000000000..cd7312cc5755
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/README
@@ -0,0 +1,396 @@
+
+
+
+
+
+
+ sdbm - Substitute DBM
+ or
+ Berkeley ndbm for Every UN*X[1] Made Simple
+
+ Ozan (oz) Yigit
+
+ The Guild of PD Software Toolmakers
+ Toronto - Canada
+
+ oz@nexus.yorku.ca
+
+
+
+Implementation is the sincerest form of flattery. - L. Peter
+Deutsch
+
+A The Clone of the ndbm library
+
+ The sources accompanying this notice - sdbm - consti-
+tute the first public release (Dec. 1990) of a complete
+clone of the Berkeley UN*X ndbm library. The sdbm library is
+meant to clone the proven functionality of ndbm as closely
+as possible, including a few improvements. It is practical,
+easy to understand, and compatible. The sdbm library is not
+derived from any licensed, proprietary or copyrighted
+software.
+
+ The sdbm implementation is based on a 1978 algorithm
+[Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''.
+In the course of searching for a substitute for ndbm, I pro-
+totyped three different external-hashing algorithms [Lar78,
+Fag79, Lit80] and ultimately chose Larson's algorithm as a
+basis of the sdbm implementation. The Bell Labs dbm (and
+therefore ndbm) is based on an algorithm invented by Ken
+Thompson, [Tho90, Tor87] and predates Larson's work.
+
+ The sdbm programming interface is totally compatible
+with ndbm and includes a slight improvement in database ini-
+tialization. It is also expected to be binary-compatible
+under most UN*X versions that support the ndbm library.
+
+ The sdbm implementation shares the shortcomings of the
+ndbm library, as a side effect of various simplifications to
+the original Larson algorithm. It does produce holes in the
+page file as it writes pages past the end of file. (Larson's
+paper include a clever solution to this problem that is a
+result of using the hash value directly as a block address.)
+On the other hand, extensive tests seem to indicate that
+sdbm creates fewer holes in general, and the resulting page-
+files are smaller. The sdbm implementation is also faster
+than ndbm in database creation. Unlike the ndbm, the sdbm
+_________________________
+
+ [1] UN*X is not a trademark of any (dis)organization.
+
+
+
+
+
+
+
+
+
+ - 2 -
+
+
+store operation will not ``wander away'' trying to split its
+data pages to insert a datum that cannot (due to elaborate
+worst-case situations) be inserted. (It will fail after a
+pre-defined number of attempts.)
+
+Important Compatibility Warning
+
+ The sdbm and ndbm libraries cannot share databases: one
+cannot read the (dir/pag) database created by the other.
+This is due to the differences between the ndbm and sdbm
+algorithms[2], and the hash functions used. It is easy to
+convert between the dbm/ndbm databases and sdbm by ignoring
+the index completely: see dbd, dbu etc.
+
+
+Notice of Intellectual Property
+
+The entire sdbm library package, as authored by me, Ozan S.
+Yigit, is hereby placed in the public domain. As such, the
+author is not responsible for the consequences of use of
+this software, no matter how awful, even if they arise from
+defects in it. There is no expressed or implied warranty for
+the sdbm library.
+
+ Since the sdbm library package is in the public domain,
+this original release or any additional public-domain
+releases of the modified original cannot possibly (by defin-
+ition) be withheld from you. Also by definition, You (singu-
+lar) have all the rights to this code (including the right
+to sell without permission, the right to hoard[3] and the
+right to do other icky things as you see fit) but those
+rights are also granted to everyone else.
+
+ Please note that all previous distributions of this
+software contained a copyright (which is now dropped) to
+protect its origins and its current public domain status
+against any possible claims and/or challenges.
+
+Acknowledgments
+
+ Many people have been very helpful and supportive. A
+partial list would necessarily include Rayan Zacherissen
+(who contributed the man page, and also hacked a MMAP
+_________________________
+
+ [2] Torek's discussion [Tor87] indicates that
+dbm/ndbm implementations use the hash value to traverse
+the radix trie differently than sdbm and as a result,
+the page indexes are generated in different order. For
+more information, send e-mail to the author.
+ [3] You cannot really hoard something that is avail-
+able to the public at large, but try if it makes you
+feel any better.
+
+
+
+
+
+
+
+
+
+
+ - 3 -
+
+
+version of sdbm), Arnold Robbins, Chris Lewis, Bill David-
+sen, Henry Spencer, Geoff Collyer, Rich Salz (who got me
+started in the first place), Johannes Ruschein (who did the
+minix port) and David Tilbrook. I thank you all.
+
+Distribution Manifest and Notes
+
+This distribution of sdbm includes (at least) the following:
+
+ CHANGES change log
+ README this file.
+ biblio a small bibliography on external hashing
+ dba.c a crude (n/s)dbm page file analyzer
+ dbd.c a crude (n/s)dbm page file dumper (for conversion)
+ dbe.1 man page for dbe.c
+ dbe.c Janick's database editor
+ dbm.c a dbm library emulation wrapper for ndbm/sdbm
+ dbm.h header file for the above
+ dbu.c a crude db management utility
+ hash.c hashing function
+ makefile guess.
+ pair.c page-level routines (posted earlier)
+ pair.h header file for the above
+ readme.ms troff source for the README file
+ sdbm.3 man page
+ sdbm.c the real thing
+ sdbm.h header file for the above
+ tune.h place for tuning & portability thingies
+ util.c miscellaneous
+
+ dbu is a simple database manipulation program[4] that
+tries to look like Bell Labs' cbt utility. It is currently
+incomplete in functionality. I use dbu to test out the rou-
+tines: it takes (from stdin) tab separated key/value pairs
+for commands like build or insert or takes keys for commands
+like delete or look.
+
+ dbu <build|creat|look|insert|cat|delete> dbmfile
+
+ dba is a crude analyzer of dbm/sdbm/ndbm page files. It
+scans the entire page file, reporting page level statistics,
+and totals at the end.
+
+ dbd is a crude dump program for dbm/ndbm/sdbm data-
+bases. It ignores the bitmap, and dumps the data pages in
+sequence. It can be used to create input for the dbu util-
+ity. Note that dbd will skip any NULLs in the key and data
+fields, thus is unsuitable to convert some peculiar
+_________________________
+
+ [4] The dbd, dba, dbu utilities are quick hacks and
+are not fit for production use. They were developed
+late one night, just to test out sdbm, and convert some
+databases.
+
+
+
+
+
+
+
+
+
+ - 4 -
+
+
+databases that insist in including the terminating null.
+
+ I have also included a copy of the dbe (ndbm DataBase
+Editor) by Janick Bergeron [janick@bnr.ca] for your pleas-
+ure. You may find it more useful than the little dbu util-
+ity.
+
+ dbm.[ch] is a dbm library emulation on top of ndbm (and
+hence suitable for sdbm). Written by Robert Elz.
+
+ The sdbm library has been around in beta test for quite
+a long time, and from whatever little feedback I received
+(maybe no news is good news), I believe it has been func-
+tioning without any significant problems. I would, of
+course, appreciate all fixes and/or improvements. Portabil-
+ity enhancements would especially be useful.
+
+Implementation Issues
+
+ Hash functions: The algorithm behind sdbm implementa-
+tion needs a good bit-scrambling hash function to be effec-
+tive. I ran into a set of constants for a simple hash func-
+tion that seem to help sdbm perform better than ndbm for
+various inputs:
+
+ /*
+ * polynomial conversion ignoring overflows
+ * 65599 nice. 65587 even better.
+ */
+ long
+ dbm_hash(char *str, int len) {
+ register unsigned long n = 0;
+
+ while (len--)
+ n = n * 65599 + *str++;
+ return n;
+ }
+
+ There may be better hash functions for the purposes of
+dynamic hashing. Try your favorite, and check the pagefile.
+If it contains too many pages with too many holes, (in rela-
+tion to this one for example) or if sdbm simply stops work-
+ing (fails after SPLTMAX attempts to split) when you feed
+your NEWS history file to it, you probably do not have a
+good hashing function. If you do better (for different
+types of input), I would like to know about the function you
+use.
+
+ Block sizes: It seems (from various tests on a few
+machines) that a page file block size PBLKSIZ of 1024 is by
+far the best for performance, but this also happens to limit
+the size of a key/value pair. Depending on your needs, you
+may wish to increase the page size, and also adjust PAIRMAX
+(the maximum size of a key/value pair allowed: should always
+
+
+
+
+
+
+
+
+
+ - 5 -
+
+
+be at least three words smaller than PBLKSIZ.) accordingly.
+The system-wide version of the library should probably be
+configured with 1024 (distribution default), as this appears
+to be sufficient for most common uses of sdbm.
+
+Portability
+
+ This package has been tested in many different UN*Xes
+even including minix, and appears to be reasonably portable.
+This does not mean it will port easily to non-UN*X systems.
+
+Notes and Miscellaneous
+
+ The sdbm is not a very complicated package, at least
+not after you familiarize yourself with the literature on
+external hashing. There are other interesting algorithms in
+existence that ensure (approximately) single-read access to
+a data value associated with any key. These are directory-
+less schemes such as linear hashing [Lit80] (+ Larson varia-
+tions), spiral storage [Mar79] or directory schemes such as
+extensible hashing [Fag79] by Fagin et al. I do hope these
+sources provide a reasonable playground for experimentation
+with other algorithms. See the June 1988 issue of ACM Com-
+puting Surveys [Enb88] for an excellent overview of the
+field.
+
+References
+
+
+[Lar78]
+ P.-A. Larson, ``Dynamic Hashing'', BIT, vol. 18, pp.
+ 184-201, 1978.
+
+[Tho90]
+ Ken Thompson, private communication, Nov. 1990
+
+[Lit80]
+ W. Litwin, `` Linear Hashing: A new tool for file and
+ table addressing'', Proceedings of the 6th Conference on
+ Very Large Dabatases (Montreal), pp. 212-223, Very
+ Large Database Foundation, Saratoga, Calif., 1980.
+
+[Fag79]
+ R. Fagin, J. Nievergelt, N. Pippinger, and H. R.
+ Strong, ``Extendible Hashing - A Fast Access Method for
+ Dynamic Files'', ACM Trans. Database Syst., vol. 4,
+ no.3, pp. 315-344, Sept. 1979.
+
+[Wal84]
+ Rich Wales, ``Discussion of "dbm" data base system'',
+ USENET newsgroup unix.wizards, Jan. 1984.
+
+[Tor87]
+ Chris Torek, ``Re: dbm.a and ndbm.a archives'',
+
+
+
+
+
+
+
+
+
+ - 6 -
+
+
+ USENET newsgroup comp.unix, 1987.
+
+[Mar79]
+ G. N. Martin, ``Spiral Storage: Incrementally Augment-
+ able Hash Addressed Storage'', Technical Report #27,
+ University of Varwick, Coventry, U.K., 1979.
+
+[Enb88]
+ R. J. Enbody and H. C. Du, ``Dynamic Hashing
+ Schemes'',ACM Computing Surveys, vol. 20, no. 2, pp.
+ 85-113, June 1988.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/README.too b/contrib/perl5/ext/SDBM_File/sdbm/README.too
new file mode 100644
index 000000000000..c2d095944da0
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/README.too
@@ -0,0 +1,9 @@
+This version of sdbm merely has all the dbm_* names translated to sdbm_*
+so that we can link ndbm and sdbm into the same executable. (It also has
+the bad() macro redefined to allow a zero-length key.)
+
+
+Fri Apr 15 10:15:30 EDT 1994.
+
+Additional portability/configuration changes for libsdbm by Andy Dougherty
+doughera@lafcol.lafayette.edu.
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/biblio b/contrib/perl5/ext/SDBM_File/sdbm/biblio
new file mode 100644
index 000000000000..0be09fa005b0
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/biblio
@@ -0,0 +1,64 @@
+%A R. J. Enbody
+%A H. C. Du
+%T Dynamic Hashing Schemes
+%J ACM Computing Surveys
+%V 20
+%N 2
+%D June 1988
+%P 85-113
+%K surveys
+
+%A P.-A. Larson
+%T Dynamic Hashing
+%J BIT
+%V 18
+%P 184-201
+%D 1978
+%K dynamic
+
+%A W. Litwin
+%T Linear Hashing: A new tool for file and table addressing
+%J Proceedings of the 6th Conference on Very Large Dabatases (Montreal)
+%I Very Large Database Foundation
+%C Saratoga, Calif.
+%P 212-223
+%D 1980
+%K linear
+
+%A R. Fagin
+%A J. Nievergelt
+%A N. Pippinger
+%A H. R. Strong
+%T Extendible Hashing - A Fast Access Method for Dynamic Files
+%J ACM Trans. Database Syst.
+%V 4
+%N 3
+%D Sept. 1979
+%P 315-344
+%K extend
+
+%A G. N. Martin
+%T Spiral Storage: Incrementally Augmentable Hash Addressed Storage
+%J Technical Report #27
+%I University of Varwick
+%C Coventry, U.K.
+%D 1979
+%K spiral
+
+%A Chris Torek
+%T Re: dbm.a and ndbm.a archives
+%B USENET newsgroup comp.unix
+%D 1987
+%K torek
+
+%A Rich Wales
+%T Discusson of "dbm" data base system
+%B USENET newsgroup unix.wizards
+%D Jan. 1984
+%K rich
+
+
+
+
+
+
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dba.c b/contrib/perl5/ext/SDBM_File/sdbm/dba.c
new file mode 100644
index 000000000000..05e70c8961c3
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/dba.c
@@ -0,0 +1,85 @@
+/*
+ * dba dbm analysis/recovery
+ */
+
+#include <stdio.h>
+#include <sys/file.h>
+#include "EXTERN.h"
+#include "sdbm.h"
+
+char *progname;
+extern void oops();
+
+int
+main(argc, argv)
+char **argv;
+{
+ int n;
+ char *p;
+ char *name;
+ int pagf;
+
+ progname = argv[0];
+
+ if (p = argv[1]) {
+ name = (char *) malloc((n = strlen(p)) + 5);
+ strcpy(name, p);
+ strcpy(name + n, ".pag");
+
+ if ((pagf = open(name, O_RDONLY)) < 0)
+ oops("cannot open %s.", name);
+
+ sdump(pagf);
+ }
+ else
+ oops("usage: %s dbname", progname);
+
+ return 0;
+}
+
+sdump(pagf)
+int pagf;
+{
+ register b;
+ register n = 0;
+ register t = 0;
+ register o = 0;
+ register e;
+ char pag[PBLKSIZ];
+
+ while ((b = read(pagf, pag, PBLKSIZ)) > 0) {
+ printf("#%d: ", n);
+ if (!okpage(pag))
+ printf("bad\n");
+ else {
+ printf("ok. ");
+ if (!(e = pagestat(pag)))
+ o++;
+ else
+ t += e;
+ }
+ n++;
+ }
+
+ if (b == 0)
+ printf("%d pages (%d holes): %d entries\n", n, o, t);
+ else
+ oops("read failed: block %d", n);
+}
+
+pagestat(pag)
+char *pag;
+{
+ register n;
+ register free;
+ register short *ino = (short *) pag;
+
+ if (!(n = ino[0]))
+ printf("no entries.\n");
+ else {
+ free = ino[n] - (n + 1) * sizeof(short);
+ printf("%3d entries %2d%% used free %d.\n",
+ n / 2, ((PBLKSIZ - free) * 100) / PBLKSIZ, free);
+ }
+ return n / 2;
+}
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbd.c b/contrib/perl5/ext/SDBM_File/sdbm/dbd.c
new file mode 100644
index 000000000000..04ab842e2d65
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/dbd.c
@@ -0,0 +1,111 @@
+/*
+ * dbd - dump a dbm data file
+ */
+
+#include <stdio.h>
+#include <sys/file.h>
+#include "EXTERN.h"
+#include "sdbm.h"
+
+char *progname;
+extern void oops();
+
+
+#define empty(page) (((short *) page)[0] == 0)
+
+int
+main(argc, argv)
+char **argv;
+{
+ int n;
+ char *p;
+ char *name;
+ int pagf;
+
+ progname = argv[0];
+
+ if (p = argv[1]) {
+ name = (char *) malloc((n = strlen(p)) + 5);
+ strcpy(name, p);
+ strcpy(name + n, ".pag");
+
+ if ((pagf = open(name, O_RDONLY)) < 0)
+ oops("cannot open %s.", name);
+
+ sdump(pagf);
+ }
+ else
+ oops("usage: %s dbname", progname);
+ return 0;
+}
+
+sdump(pagf)
+int pagf;
+{
+ register r;
+ register n = 0;
+ register o = 0;
+ char pag[PBLKSIZ];
+
+ while ((r = read(pagf, pag, PBLKSIZ)) > 0) {
+ if (!okpage(pag))
+ fprintf(stderr, "%d: bad page.\n", n);
+ else if (empty(pag))
+ o++;
+ else
+ dispage(pag);
+ n++;
+ }
+
+ if (r == 0)
+ fprintf(stderr, "%d pages (%d holes).\n", n, o);
+ else
+ oops("read failed: block %d", n);
+}
+
+
+#ifdef OLD
+dispage(pag)
+char *pag;
+{
+ register i, n;
+ register off;
+ register short *ino = (short *) pag;
+
+ off = PBLKSIZ;
+ for (i = 1; i < ino[0]; i += 2) {
+ printf("\t[%d]: ", ino[i]);
+ for (n = ino[i]; n < off; n++)
+ putchar(pag[n]);
+ putchar(' ');
+ off = ino[i];
+ printf("[%d]: ", ino[i + 1]);
+ for (n = ino[i + 1]; n < off; n++)
+ putchar(pag[n]);
+ off = ino[i + 1];
+ putchar('\n');
+ }
+}
+#else
+dispage(pag)
+char *pag;
+{
+ register i, n;
+ register off;
+ register short *ino = (short *) pag;
+
+ off = PBLKSIZ;
+ for (i = 1; i < ino[0]; i += 2) {
+ for (n = ino[i]; n < off; n++)
+ if (pag[n] != 0)
+ putchar(pag[n]);
+ putchar('\t');
+ off = ino[i];
+ for (n = ino[i + 1]; n < off; n++)
+ if (pag[n] != 0)
+ putchar(pag[n]);
+ putchar('\n');
+ off = ino[i + 1];
+ }
+}
+#endif
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbe.1 b/contrib/perl5/ext/SDBM_File/sdbm/dbe.1
new file mode 100644
index 000000000000..3b32272684ba
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/dbe.1
@@ -0,0 +1,46 @@
+.TH dbe 1 "ndbm(3) EDITOR"
+.SH NAME
+dbe \- Edit a ndbm(3) database
+.SH USAGE
+dbe <database> [-m r|w|rw] [-crtvx] -a|-d|-f|-F|-s [<key> [<content>]]
+.SH DESCRIPTION
+\fIdbme\fP operates on ndbm(3) databases.
+It can be used to create them, look at them or change them.
+When specifying the value of a key or the content of its associated entry,
+\\nnn, \\0, \\n, \\t, \\f and \\r are interpreted as usual.
+When displaying key/content pairs, non-printable characters are displayed
+using the \\nnn notation.
+.SH OPTIONS
+.IP -a
+List all entries in the database.
+.IP -c
+Create the database if it does not exist.
+.IP -d
+Delete the entry associated with the specified key.
+.IP -f
+Fetch and display the entry associated with the specified key.
+.IP -F
+Fetch and display all the entries whose key match the specified
+regular-expression
+.IP "-m r|w|rw"
+Open the database in read-only, write-only or read-write mode
+.IP -r
+Replace the entry associated with the specified key if it already exists.
+See option -s.
+.IP -s
+Store an entry under a specific key.
+An error occurs if the key already exists and the option -r was not specified.
+.IP -t
+Re-initialize the database before executing the command.
+.IP -v
+Verbose mode.
+Confirm stores and deletions.
+.IP -x
+If option -x is used with option -c, then if the database already exists,
+an error occurs.
+This can be used to implement a simple exclusive access locking mechanism.
+.SH SEE ALSO
+ndbm(3)
+.SH AUTHOR
+janick@bnr.ca
+
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbe.c b/contrib/perl5/ext/SDBM_File/sdbm/dbe.c
new file mode 100644
index 000000000000..2a306f276ecf
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/dbe.c
@@ -0,0 +1,435 @@
+#include <stdio.h>
+#ifndef VMS
+#include <sys/file.h>
+#include <ndbm.h>
+#else
+#include "file.h"
+#include "ndbm.h"
+#endif
+#include <ctype.h>
+
+/***************************************************************************\
+** **
+** Function name: getopt() **
+** Author: Henry Spencer, UofT **
+** Coding date: 84/04/28 **
+** **
+** Description: **
+** **
+** Parses argv[] for arguments. **
+** Works with Whitesmith's C compiler. **
+** **
+** Inputs - The number of arguments **
+** - The base address of the array of arguments **
+** - A string listing the valid options (':' indicates an **
+** argument to the preceding option is required, a ';' **
+** indicates an argument to the preceding option is optional) **
+** **
+** Outputs - Returns the next option character, **
+** '?' for non '-' arguments **
+** or ':' when there is no more arguments. **
+** **
+** Side Effects + The argument to an option is pointed to by 'optarg' **
+** **
+*****************************************************************************
+** **
+** REVISION HISTORY: **
+** **
+** DATE NAME DESCRIPTION **
+** YY/MM/DD ------------------ ------------------------------------ **
+** 88/10/20 Janick Bergeron Returns '?' on unamed arguments **
+** returns '!' on unknown options **
+** and 'EOF' only when exhausted. **
+** 88/11/18 Janick Bergeron Return ':' when no more arguments **
+** 89/08/11 Janick Bergeron Optional optarg when ';' in optstring **
+** **
+\***************************************************************************/
+
+char *optarg; /* Global argument pointer. */
+
+#ifdef VMS
+#define index strchr
+#endif
+
+char
+getopt(argc, argv, optstring)
+int argc;
+char **argv;
+char *optstring;
+{
+ register int c;
+ register char *place;
+ extern char *index();
+ static int optind = 0;
+ static char *scan = NULL;
+
+ optarg = NULL;
+
+ if (scan == NULL || *scan == '\0') {
+
+ if (optind == 0)
+ optind++;
+ if (optind >= argc)
+ return ':';
+
+ optarg = place = argv[optind++];
+ if (place[0] != '-' || place[1] == '\0')
+ return '?';
+ if (place[1] == '-' && place[2] == '\0')
+ return '?';
+ scan = place + 1;
+ }
+
+ c = *scan++;
+ place = index(optstring, c);
+ if (place == NULL || c == ':' || c == ';') {
+
+ (void) fprintf(stderr, "%s: unknown option %c\n", argv[0], c);
+ scan = NULL;
+ return '!';
+ }
+ if (*++place == ':') {
+
+ if (*scan != '\0') {
+
+ optarg = scan;
+ scan = NULL;
+
+ }
+ else {
+
+ if (optind >= argc) {
+
+ (void) fprintf(stderr, "%s: %c requires an argument\n",
+ argv[0], c);
+ return '!';
+ }
+ optarg = argv[optind];
+ optind++;
+ }
+ }
+ else if (*place == ';') {
+
+ if (*scan != '\0') {
+
+ optarg = scan;
+ scan = NULL;
+
+ }
+ else {
+
+ if (optind >= argc || *argv[optind] == '-')
+ optarg = NULL;
+ else {
+ optarg = argv[optind];
+ optind++;
+ }
+ }
+ }
+ return c;
+}
+
+
+void
+print_datum(db)
+datum db;
+{
+ int i;
+
+ putchar('"');
+ for (i = 0; i < db.dsize; i++) {
+ if (isprint(db.dptr[i]))
+ putchar(db.dptr[i]);
+ else {
+ putchar('\\');
+ putchar('0' + ((db.dptr[i] >> 6) & 0x07));
+ putchar('0' + ((db.dptr[i] >> 3) & 0x07));
+ putchar('0' + (db.dptr[i] & 0x07));
+ }
+ }
+ putchar('"');
+}
+
+
+datum
+read_datum(s)
+char *s;
+{
+ datum db;
+ char *p;
+ int i;
+
+ db.dsize = 0;
+ db.dptr = (char *) malloc(strlen(s) * sizeof(char));
+ for (p = db.dptr; *s != '\0'; p++, db.dsize++, s++) {
+ if (*s == '\\') {
+ if (*++s == 'n')
+ *p = '\n';
+ else if (*s == 'r')
+ *p = '\r';
+ else if (*s == 'f')
+ *p = '\f';
+ else if (*s == 't')
+ *p = '\t';
+ else if (isdigit(*s) && isdigit(*(s + 1)) && isdigit(*(s + 2))) {
+ i = (*s++ - '0') << 6;
+ i |= (*s++ - '0') << 3;
+ i |= *s - '0';
+ *p = i;
+ }
+ else if (*s == '0')
+ *p = '\0';
+ else
+ *p = *s;
+ }
+ else
+ *p = *s;
+ }
+
+ return db;
+}
+
+
+char *
+key2s(db)
+datum db;
+{
+ char *buf;
+ char *p1, *p2;
+
+ buf = (char *) malloc((db.dsize + 1) * sizeof(char));
+ for (p1 = buf, p2 = db.dptr; *p2 != '\0'; *p1++ = *p2++);
+ *p1 = '\0';
+ return buf;
+}
+
+
+main(argc, argv)
+int argc;
+char **argv;
+{
+ typedef enum {
+ YOW, FETCH, STORE, DELETE, SCAN, REGEXP
+ } commands;
+ char opt;
+ int flags;
+ int giveusage = 0;
+ int verbose = 0;
+ commands what = YOW;
+ char *comarg[3];
+ int st_flag = DBM_INSERT;
+ int argn;
+ DBM *db;
+ datum key;
+ datum content;
+
+ flags = O_RDWR;
+ argn = 0;
+
+ while ((opt = getopt(argc, argv, "acdfFm:rstvx")) != ':') {
+ switch (opt) {
+ case 'a':
+ what = SCAN;
+ break;
+ case 'c':
+ flags |= O_CREAT;
+ break;
+ case 'd':
+ what = DELETE;
+ break;
+ case 'f':
+ what = FETCH;
+ break;
+ case 'F':
+ what = REGEXP;
+ break;
+ case 'm':
+ flags &= ~(000007);
+ if (strcmp(optarg, "r") == 0)
+ flags |= O_RDONLY;
+ else if (strcmp(optarg, "w") == 0)
+ flags |= O_WRONLY;
+ else if (strcmp(optarg, "rw") == 0)
+ flags |= O_RDWR;
+ else {
+ fprintf(stderr, "Invalid mode: \"%s\"\n", optarg);
+ giveusage = 1;
+ }
+ break;
+ case 'r':
+ st_flag = DBM_REPLACE;
+ break;
+ case 's':
+ what = STORE;
+ break;
+ case 't':
+ flags |= O_TRUNC;
+ break;
+ case 'v':
+ verbose = 1;
+ break;
+ case 'x':
+ flags |= O_EXCL;
+ break;
+ case '!':
+ giveusage = 1;
+ break;
+ case '?':
+ if (argn < 3)
+ comarg[argn++] = optarg;
+ else {
+ fprintf(stderr, "Too many arguments.\n");
+ giveusage = 1;
+ }
+ break;
+ }
+ }
+
+ if (giveusage | what == YOW | argn < 1) {
+ fprintf(stderr, "Usage: %s databse [-m r|w|rw] [-crtx] -a|-d|-f|-F|-s [key [content]]\n", argv[0]);
+ exit(-1);
+ }
+
+ if ((db = dbm_open(comarg[0], flags, 0777)) == NULL) {
+ fprintf(stderr, "Error opening database \"%s\"\n", comarg[0]);
+ exit(-1);
+ }
+
+ if (argn > 1)
+ key = read_datum(comarg[1]);
+ if (argn > 2)
+ content = read_datum(comarg[2]);
+
+ switch (what) {
+
+ case SCAN:
+ key = dbm_firstkey(db);
+ if (dbm_error(db)) {
+ fprintf(stderr, "Error when fetching first key\n");
+ goto db_exit;
+ }
+ while (key.dptr != NULL) {
+ content = dbm_fetch(db, key);
+ if (dbm_error(db)) {
+ fprintf(stderr, "Error when fetching ");
+ print_datum(key);
+ printf("\n");
+ goto db_exit;
+ }
+ print_datum(key);
+ printf(": ");
+ print_datum(content);
+ printf("\n");
+ if (dbm_error(db)) {
+ fprintf(stderr, "Error when fetching next key\n");
+ goto db_exit;
+ }
+ key = dbm_nextkey(db);
+ }
+ break;
+
+ case REGEXP:
+ if (argn < 2) {
+ fprintf(stderr, "Missing regular expression.\n");
+ goto db_exit;
+ }
+ if (re_comp(comarg[1])) {
+ fprintf(stderr, "Invalid regular expression\n");
+ goto db_exit;
+ }
+ key = dbm_firstkey(db);
+ if (dbm_error(db)) {
+ fprintf(stderr, "Error when fetching first key\n");
+ goto db_exit;
+ }
+ while (key.dptr != NULL) {
+ if (re_exec(key2s(key))) {
+ content = dbm_fetch(db, key);
+ if (dbm_error(db)) {
+ fprintf(stderr, "Error when fetching ");
+ print_datum(key);
+ printf("\n");
+ goto db_exit;
+ }
+ print_datum(key);
+ printf(": ");
+ print_datum(content);
+ printf("\n");
+ if (dbm_error(db)) {
+ fprintf(stderr, "Error when fetching next key\n");
+ goto db_exit;
+ }
+ }
+ key = dbm_nextkey(db);
+ }
+ break;
+
+ case FETCH:
+ if (argn < 2) {
+ fprintf(stderr, "Missing fetch key.\n");
+ goto db_exit;
+ }
+ content = dbm_fetch(db, key);
+ if (dbm_error(db)) {
+ fprintf(stderr, "Error when fetching ");
+ print_datum(key);
+ printf("\n");
+ goto db_exit;
+ }
+ if (content.dptr == NULL) {
+ fprintf(stderr, "Cannot find ");
+ print_datum(key);
+ printf("\n");
+ goto db_exit;
+ }
+ print_datum(key);
+ printf(": ");
+ print_datum(content);
+ printf("\n");
+ break;
+
+ case DELETE:
+ if (argn < 2) {
+ fprintf(stderr, "Missing delete key.\n");
+ goto db_exit;
+ }
+ if (dbm_delete(db, key) || dbm_error(db)) {
+ fprintf(stderr, "Error when deleting ");
+ print_datum(key);
+ printf("\n");
+ goto db_exit;
+ }
+ if (verbose) {
+ print_datum(key);
+ printf(": DELETED\n");
+ }
+ break;
+
+ case STORE:
+ if (argn < 3) {
+ fprintf(stderr, "Missing key and/or content.\n");
+ goto db_exit;
+ }
+ if (dbm_store(db, key, content, st_flag) || dbm_error(db)) {
+ fprintf(stderr, "Error when storing ");
+ print_datum(key);
+ printf("\n");
+ goto db_exit;
+ }
+ if (verbose) {
+ print_datum(key);
+ printf(": ");
+ print_datum(content);
+ printf(" STORED\n");
+ }
+ break;
+ }
+
+db_exit:
+ dbm_clearerr(db);
+ dbm_close(db);
+ if (dbm_error(db)) {
+ fprintf(stderr, "Error closing database \"%s\"\n", comarg[0]);
+ exit(-1);
+ }
+}
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbm.c b/contrib/perl5/ext/SDBM_File/sdbm/dbm.c
new file mode 100644
index 000000000000..1388230e2d31
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/dbm.c
@@ -0,0 +1,120 @@
+/*
+ * Copyright (c) 1985 The Regents of the University of California.
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms are permitted
+ * provided that the above copyright notice and this paragraph are
+ * duplicated in all such forms and that any documentation,
+ * advertising materials, and other materials related to such
+ * distribution and use acknowledge that the software was developed
+ * by the University of California, Berkeley. The name of the
+ * University may not be used to endorse or promote products derived
+ * from this software without specific prior written permission.
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+ */
+
+#ifndef lint
+static char sccsid[] = "@(#)dbm.c 5.4 (Berkeley) 5/24/89";
+#endif /* not lint */
+
+#include "dbm.h"
+
+#define NODB ((DBM *)0)
+
+static DBM *cur_db = NODB;
+
+static char no_db[] = "dbm: no open database\n";
+
+dbminit(file)
+ char *file;
+{
+ if (cur_db != NODB)
+ dbm_close(cur_db);
+
+ cur_db = dbm_open(file, 2, 0);
+ if (cur_db == NODB) {
+ cur_db = dbm_open(file, 0, 0);
+ if (cur_db == NODB)
+ return (-1);
+ }
+ return (0);
+}
+
+long
+forder(key)
+datum key;
+{
+ if (cur_db == NODB) {
+ printf(no_db);
+ return (0L);
+ }
+ return (dbm_forder(cur_db, key));
+}
+
+datum
+fetch(key)
+datum key;
+{
+ datum item;
+
+ if (cur_db == NODB) {
+ printf(no_db);
+ item.dptr = 0;
+ return (item);
+ }
+ return (dbm_fetch(cur_db, key));
+}
+
+delete(key)
+datum key;
+{
+ if (cur_db == NODB) {
+ printf(no_db);
+ return (-1);
+ }
+ if (dbm_rdonly(cur_db))
+ return (-1);
+ return (dbm_delete(cur_db, key));
+}
+
+store(key, dat)
+datum key, dat;
+{
+ if (cur_db == NODB) {
+ printf(no_db);
+ return (-1);
+ }
+ if (dbm_rdonly(cur_db))
+ return (-1);
+
+ return (dbm_store(cur_db, key, dat, DBM_REPLACE));
+}
+
+datum
+firstkey()
+{
+ datum item;
+
+ if (cur_db == NODB) {
+ printf(no_db);
+ item.dptr = 0;
+ return (item);
+ }
+ return (dbm_firstkey(cur_db));
+}
+
+datum
+nextkey(key)
+datum key;
+{
+ datum item;
+
+ if (cur_db == NODB) {
+ printf(no_db);
+ item.dptr = 0;
+ return (item);
+ }
+ return (dbm_nextkey(cur_db, key));
+}
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbm.h b/contrib/perl5/ext/SDBM_File/sdbm/dbm.h
new file mode 100644
index 000000000000..1196953d9653
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/dbm.h
@@ -0,0 +1,35 @@
+/*
+ * Copyright (c) 1983 The Regents of the University of California.
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms are permitted
+ * provided that the above copyright notice and this paragraph are
+ * duplicated in all such forms and that any documentation,
+ * advertising materials, and other materials related to such
+ * distribution and use acknowledge that the software was developed
+ * by the University of California, Berkeley. The name of the
+ * University may not be used to endorse or promote products derived
+ * from this software without specific prior written permission.
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * @(#)dbm.h 5.2 (Berkeley) 5/24/89
+ */
+
+#ifndef NULL
+/*
+ * this is lunacy, we no longer use it (and never should have
+ * unconditionally defined it), but, this whole file is for
+ * backwards compatability - someone may rely on this.
+ */
+#define NULL ((char *) 0)
+#endif
+
+#ifdef I_NDBM
+# include <ndbm.h>
+#endif
+
+datum fetch();
+datum firstkey();
+datum nextkey();
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/dbu.c b/contrib/perl5/ext/SDBM_File/sdbm/dbu.c
new file mode 100644
index 000000000000..a3c0004da9ff
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/dbu.c
@@ -0,0 +1,251 @@
+#include <stdio.h>
+#include <sys/file.h>
+#ifdef SDBM
+#include "EXTERN.h"
+#include "sdbm.h"
+#else
+#include <ndbm.h>
+#endif
+#include <string.h>
+
+#ifdef BSD42
+#define strchr index
+#endif
+
+extern int getopt();
+extern char *strchr();
+extern void oops();
+
+char *progname;
+
+static int rflag;
+static char *usage = "%s [-R] cat | look |... dbmname";
+
+#define DERROR 0
+#define DLOOK 1
+#define DINSERT 2
+#define DDELETE 3
+#define DCAT 4
+#define DBUILD 5
+#define DPRESS 6
+#define DCREAT 7
+
+#define LINEMAX 8192
+
+typedef struct {
+ char *sname;
+ int scode;
+ int flags;
+} cmd;
+
+static cmd cmds[] = {
+
+ "fetch", DLOOK, O_RDONLY,
+ "get", DLOOK, O_RDONLY,
+ "look", DLOOK, O_RDONLY,
+ "add", DINSERT, O_RDWR,
+ "insert", DINSERT, O_RDWR,
+ "store", DINSERT, O_RDWR,
+ "delete", DDELETE, O_RDWR,
+ "remove", DDELETE, O_RDWR,
+ "dump", DCAT, O_RDONLY,
+ "list", DCAT, O_RDONLY,
+ "cat", DCAT, O_RDONLY,
+ "creat", DCREAT, O_RDWR | O_CREAT | O_TRUNC,
+ "new", DCREAT, O_RDWR | O_CREAT | O_TRUNC,
+ "build", DBUILD, O_RDWR | O_CREAT,
+ "squash", DPRESS, O_RDWR,
+ "compact", DPRESS, O_RDWR,
+ "compress", DPRESS, O_RDWR
+};
+
+#define CTABSIZ (sizeof (cmds)/sizeof (cmd))
+
+static cmd *parse();
+static void badk(), doit(), prdatum();
+
+int
+main(argc, argv)
+int argc;
+char *argv[];
+{
+ int c;
+ register cmd *act;
+ extern int optind;
+ extern char *optarg;
+
+ progname = argv[0];
+
+ while ((c = getopt(argc, argv, "R")) != EOF)
+ switch (c) {
+ case 'R': /* raw processing */
+ rflag++;
+ break;
+
+ default:
+ oops("usage: %s", usage);
+ break;
+ }
+
+ if ((argc -= optind) < 2)
+ oops("usage: %s", usage);
+
+ if ((act = parse(argv[optind])) == NULL)
+ badk(argv[optind]);
+ optind++;
+ doit(act, argv[optind]);
+ return 0;
+}
+
+static void
+doit(act, file)
+register cmd *act;
+char *file;
+{
+ datum key;
+ datum val;
+ register DBM *db;
+ register char *op;
+ register int n;
+ char *line;
+#ifdef TIME
+ long start;
+ extern long time();
+#endif
+
+ if ((db = dbm_open(file, act->flags, 0644)) == NULL)
+ oops("cannot open: %s", file);
+
+ if ((line = (char *) malloc(LINEMAX)) == NULL)
+ oops("%s: cannot get memory", "line alloc");
+
+ switch (act->scode) {
+
+ case DLOOK:
+ while (fgets(line, LINEMAX, stdin) != NULL) {
+ n = strlen(line) - 1;
+ line[n] = 0;
+ key.dptr = line;
+ key.dsize = n;
+ val = dbm_fetch(db, key);
+ if (val.dptr != NULL) {
+ prdatum(stdout, val);
+ putchar('\n');
+ continue;
+ }
+ prdatum(stderr, key);
+ fprintf(stderr, ": not found.\n");
+ }
+ break;
+ case DINSERT:
+ break;
+ case DDELETE:
+ while (fgets(line, LINEMAX, stdin) != NULL) {
+ n = strlen(line) - 1;
+ line[n] = 0;
+ key.dptr = line;
+ key.dsize = n;
+ if (dbm_delete(db, key) == -1) {
+ prdatum(stderr, key);
+ fprintf(stderr, ": not found.\n");
+ }
+ }
+ break;
+ case DCAT:
+ for (key = dbm_firstkey(db); key.dptr != 0;
+ key = dbm_nextkey(db)) {
+ prdatum(stdout, key);
+ putchar('\t');
+ prdatum(stdout, dbm_fetch(db, key));
+ putchar('\n');
+ }
+ break;
+ case DBUILD:
+#ifdef TIME
+ start = time(0);
+#endif
+ while (fgets(line, LINEMAX, stdin) != NULL) {
+ n = strlen(line) - 1;
+ line[n] = 0;
+ key.dptr = line;
+ if ((op = strchr(line, '\t')) != 0) {
+ key.dsize = op - line;
+ *op++ = 0;
+ val.dptr = op;
+ val.dsize = line + n - op;
+ }
+ else
+ oops("bad input; %s", line);
+
+ if (dbm_store(db, key, val, DBM_REPLACE) < 0) {
+ prdatum(stderr, key);
+ fprintf(stderr, ": ");
+ oops("store: %s", "failed");
+ }
+ }
+#ifdef TIME
+ printf("done: %d seconds.\n", time(0) - start);
+#endif
+ break;
+ case DPRESS:
+ break;
+ case DCREAT:
+ break;
+ }
+
+ dbm_close(db);
+}
+
+static void
+badk(word)
+char *word;
+{
+ register int i;
+
+ if (progname)
+ fprintf(stderr, "%s: ", progname);
+ fprintf(stderr, "bad keywd %s. use one of\n", word);
+ for (i = 0; i < (int)CTABSIZ; i++)
+ fprintf(stderr, "%-8s%c", cmds[i].sname,
+ ((i + 1) % 6 == 0) ? '\n' : ' ');
+ fprintf(stderr, "\n");
+ exit(1);
+ /*NOTREACHED*/
+}
+
+static cmd *
+parse(str)
+register char *str;
+{
+ register int i = CTABSIZ;
+ register cmd *p;
+
+ for (p = cmds; i--; p++)
+ if (strcmp(p->sname, str) == 0)
+ return p;
+ return NULL;
+}
+
+static void
+prdatum(stream, d)
+FILE *stream;
+datum d;
+{
+ register int c;
+ register char *p = d.dptr;
+ register int n = d.dsize;
+
+ while (n--) {
+ c = *p++ & 0377;
+ if (c & 0200) {
+ fprintf(stream, "M-");
+ c &= 0177;
+ }
+ if (c == 0177 || c < ' ')
+ fprintf(stream, "^%c", (c == 0177) ? '?' : c + '@');
+ else
+ putc(c, stream);
+ }
+}
+
+
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/grind b/contrib/perl5/ext/SDBM_File/sdbm/grind
new file mode 100755
index 000000000000..23728b7d494f
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/grind
@@ -0,0 +1,9 @@
+#!/bin/sh
+rm -f /tmp/*.dir /tmp/*.pag
+awk -e '{
+ printf "%s\t", $0
+ for (i = 0; i < 40; i++)
+ printf "%s.", $0
+ printf "\n"
+}' < /usr/dict/words | $1 build /tmp/$2
+
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/hash.c b/contrib/perl5/ext/SDBM_File/sdbm/hash.c
new file mode 100644
index 000000000000..9b276485993e
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/hash.c
@@ -0,0 +1,47 @@
+/*
+ * sdbm - ndbm work-alike hashed database library
+ * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978).
+ * author: oz@nexus.yorku.ca
+ * status: public domain. keep it that way.
+ *
+ * hashing routine
+ */
+
+#include "config.h"
+#include "EXTERN.h"
+#include "sdbm.h"
+/*
+ * polynomial conversion ignoring overflows
+ * [this seems to work remarkably well, in fact better
+ * then the ndbm hash function. Replace at your own risk]
+ * use: 65599 nice.
+ * 65587 even better.
+ */
+long
+sdbm_hash(register char *str, register int len)
+{
+ register unsigned long n = 0;
+
+#ifdef DUFF
+
+#define HASHC n = *str++ + 65599 * n
+
+ if (len > 0) {
+ register int loop = (len + 8 - 1) >> 3;
+
+ switch(len & (8 - 1)) {
+ case 0: do {
+ HASHC; case 7: HASHC;
+ case 6: HASHC; case 5: HASHC;
+ case 4: HASHC; case 3: HASHC;
+ case 2: HASHC; case 1: HASHC;
+ } while (--loop);
+ }
+
+ }
+#else
+ while (len--)
+ n = *str++ + 65599 * n;
+#endif
+ return n;
+}
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/linux.patches b/contrib/perl5/ext/SDBM_File/sdbm/linux.patches
new file mode 100644
index 000000000000..cb7b1b7d8eb4
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/linux.patches
@@ -0,0 +1,67 @@
+*** sdbm.dist/./dbu.c Mon Feb 17 21:18:52 1992
+--- sdbm/./dbu.c Mon Feb 17 21:11:20 1992
+***************
+*** 12,18 ****
+ #endif
+
+ extern int getopt();
+! extern char *strchr();
+ extern void oops();
+
+ char *progname;
+--- 12,18 ----
+ #endif
+
+ extern int getopt();
+! /* extern char *strchr(); */
+ extern void oops();
+
+ char *progname;
+*** sdbm.dist/./makefile Mon Feb 17 21:18:56 1992
+--- sdbm/./makefile Mon Feb 17 21:10:46 1992
+***************
+*** 2,8 ****
+ # makefile for public domain ndbm-clone: sdbm
+ # DUFF: use duff's device (loop unroll) in parts of the code
+ #
+! CFLAGS = -O -DSDBM -DDUFF -DBSD42
+ #LDFLAGS = -p
+
+ OBJS = sdbm.o pair.o hash.o
+--- 2,8 ----
+ # makefile for public domain ndbm-clone: sdbm
+ # DUFF: use duff's device (loop unroll) in parts of the code
+ #
+! CFLAGS = -O -DSDBM -DDUFF
+ #LDFLAGS = -p
+
+ OBJS = sdbm.o pair.o hash.o
+*** sdbm.dist/./sdbm.c Mon Feb 17 21:19:17 1992
+--- sdbm/./sdbm.c Mon Feb 17 21:12:59 1992
+***************
+*** 25,30 ****
+--- 25,31 ----
+ #endif
+ #include <errno.h>
+ #include <string.h>
++ #include <unistd.h>
+
+ #ifdef __STDC__
+ #include <stddef.h>
+***************
+*** 43,49 ****
+
+ extern char *malloc proto((unsigned int));
+ extern void free proto((void *));
+! extern long lseek();
+
+ /*
+ * forward
+--- 44,50 ----
+
+ extern char *malloc proto((unsigned int));
+ extern void free proto((void *));
+! /* extern long lseek(); */
+
+ /*
+ * forward
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/makefile.sdbm b/contrib/perl5/ext/SDBM_File/sdbm/makefile.sdbm
new file mode 100644
index 000000000000..c959c1fab557
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/makefile.sdbm
@@ -0,0 +1,55 @@
+#
+# makefile for public domain ndbm-clone: sdbm
+# DUFF: use duff's device (loop unroll) in parts of the code
+#
+CFLAGS = -O -DSDBM -DDUFF -DBSD42 -pic
+#LDFLAGS = -p
+
+OBJS = sdbm.o pair.o hash.o
+SRCS = sdbm.c pair.c hash.c dbu.c dba.c dbd.c util.c
+HDRS = tune.h sdbm.h pair.h
+MISC = README CHANGES COMPARE sdbm.3 dbe.c dbe.1 dbm.c dbm.h biblio \
+ readme.ms readme.ps
+
+all: dbu dba dbd dbe
+
+dbu: dbu.o sdbm util.o
+ cc $(LDFLAGS) -o dbu dbu.o util.o libsdbm.a
+
+dba: dba.o util.o
+ cc $(LDFLAGS) -o dba dba.o util.o
+dbd: dbd.o util.o
+ cc $(LDFLAGS) -o dbd dbd.o util.o
+dbe: dbe.o sdbm
+ cc $(LDFLAGS) -o dbe dbe.o libsdbm.a
+
+sdbm: $(OBJS)
+ ar cr libsdbm.a $(OBJS)
+ ranlib libsdbm.a
+### cp libsdbm.a /usr/lib/libsdbm.a
+
+dba.o: sdbm.h
+dbu.o: sdbm.h
+util.o:sdbm.h
+
+$(OBJS): sdbm.h tune.h pair.h
+
+#
+# dbu using berkelezoid ndbm routines [if you have them] for testing
+#
+#x-dbu: dbu.o util.o
+# cc $(CFLAGS) -o x-dbu dbu.o util.o
+lint:
+ lint -abchx $(SRCS)
+
+clean:
+ rm -f *.o mon.out core
+
+purge: clean
+ rm -f dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag
+
+shar:
+ shar $(MISC) makefile $(SRCS) $(HDRS) >SDBM.SHAR
+
+readme:
+ nroff -ms readme.ms | col -b >README
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/pair.c b/contrib/perl5/ext/SDBM_File/sdbm/pair.c
new file mode 100644
index 000000000000..a9a805a4aa30
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/pair.c
@@ -0,0 +1,283 @@
+/*
+ * sdbm - ndbm work-alike hashed database library
+ * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978).
+ * author: oz@nexus.yorku.ca
+ * status: public domain.
+ *
+ * page-level routines
+ */
+
+#include "config.h"
+#include "EXTERN.h"
+#include "sdbm.h"
+#include "tune.h"
+#include "pair.h"
+
+#define exhash(item) sdbm_hash((item).dptr, (item).dsize)
+
+/*
+ * forward
+ */
+static int seepair proto((char *, int, char *, int));
+
+/*
+ * page format:
+ * +------------------------------+
+ * ino | n | keyoff | datoff | keyoff |
+ * +------------+--------+--------+
+ * | datoff | - - - ----> |
+ * +--------+---------------------+
+ * | F R E E A R E A |
+ * +--------------+---------------+
+ * | <---- - - - | data |
+ * +--------+-----+----+----------+
+ * | key | data | key |
+ * +--------+----------+----------+
+ *
+ * calculating the offsets for free area: if the number
+ * of entries (ino[0]) is zero, the offset to the END of
+ * the free area is the block size. Otherwise, it is the
+ * nth (ino[ino[0]]) entry's offset.
+ */
+
+int
+fitpair(char *pag, int need)
+{
+ register int n;
+ register int off;
+ register int free;
+ register short *ino = (short *) pag;
+
+ off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ;
+ free = off - (n + 1) * sizeof(short);
+ need += 2 * sizeof(short);
+
+ debug(("free %d need %d\n", free, need));
+
+ return need <= free;
+}
+
+void
+putpair(char *pag, datum key, datum val)
+{
+ register int n;
+ register int off;
+ register short *ino = (short *) pag;
+
+ off = ((n = ino[0]) > 0) ? ino[n] : PBLKSIZ;
+/*
+ * enter the key first
+ */
+ off -= key.dsize;
+ (void) memcpy(pag + off, key.dptr, key.dsize);
+ ino[n + 1] = off;
+/*
+ * now the data
+ */
+ off -= val.dsize;
+ (void) memcpy(pag + off, val.dptr, val.dsize);
+ ino[n + 2] = off;
+/*
+ * adjust item count
+ */
+ ino[0] += 2;
+}
+
+datum
+getpair(char *pag, datum key)
+{
+ register int i;
+ register int n;
+ datum val;
+ register short *ino = (short *) pag;
+
+ if ((n = ino[0]) == 0)
+ return nullitem;
+
+ if ((i = seepair(pag, n, key.dptr, key.dsize)) == 0)
+ return nullitem;
+
+ val.dptr = pag + ino[i + 1];
+ val.dsize = ino[i] - ino[i + 1];
+ return val;
+}
+
+#ifdef SEEDUPS
+int
+duppair(char *pag, datum key)
+{
+ register short *ino = (short *) pag;
+ return ino[0] > 0 && seepair(pag, ino[0], key.dptr, key.dsize) > 0;
+}
+#endif
+
+datum
+getnkey(char *pag, int num)
+{
+ datum key;
+ register int off;
+ register short *ino = (short *) pag;
+
+ num = num * 2 - 1;
+ if (ino[0] == 0 || num > ino[0])
+ return nullitem;
+
+ off = (num > 1) ? ino[num - 1] : PBLKSIZ;
+
+ key.dptr = pag + ino[num];
+ key.dsize = off - ino[num];
+
+ return key;
+}
+
+int
+delpair(char *pag, datum key)
+{
+ register int n;
+ register int i;
+ register short *ino = (short *) pag;
+
+ if ((n = ino[0]) == 0)
+ return 0;
+
+ if ((i = seepair(pag, n, key.dptr, key.dsize)) == 0)
+ return 0;
+/*
+ * found the key. if it is the last entry
+ * [i.e. i == n - 1] we just adjust the entry count.
+ * hard case: move all data down onto the deleted pair,
+ * shift offsets onto deleted offsets, and adjust them.
+ * [note: 0 < i < n]
+ */
+ if (i < n - 1) {
+ register int m;
+ register char *dst = pag + (i == 1 ? PBLKSIZ : ino[i - 1]);
+ register char *src = pag + ino[i + 1];
+ register int zoo = dst - src;
+
+ debug(("free-up %d ", zoo));
+/*
+ * shift data/keys down
+ */
+ m = ino[i + 1] - ino[n];
+#ifdef DUFF
+#define MOVB *--dst = *--src
+
+ if (m > 0) {
+ register int loop = (m + 8 - 1) >> 3;
+
+ switch (m & (8 - 1)) {
+ case 0: do {
+ MOVB; case 7: MOVB;
+ case 6: MOVB; case 5: MOVB;
+ case 4: MOVB; case 3: MOVB;
+ case 2: MOVB; case 1: MOVB;
+ } while (--loop);
+ }
+ }
+#else
+#ifdef HAS_MEMMOVE
+ dst -= m;
+ src -= m;
+ memmove(dst, src, m);
+#else
+ while (m--)
+ *--dst = *--src;
+#endif
+#endif
+/*
+ * adjust offset index up
+ */
+ while (i < n - 1) {
+ ino[i] = ino[i + 2] + zoo;
+ i++;
+ }
+ }
+ ino[0] -= 2;
+ return 1;
+}
+
+/*
+ * search for the key in the page.
+ * return offset index in the range 0 < i < n.
+ * return 0 if not found.
+ */
+static int
+seepair(char *pag, register int n, register char *key, register int siz)
+{
+ register int i;
+ register int off = PBLKSIZ;
+ register short *ino = (short *) pag;
+
+ for (i = 1; i < n; i += 2) {
+ if (siz == off - ino[i] &&
+ memEQ(key, pag + ino[i], siz))
+ return i;
+ off = ino[i + 1];
+ }
+ return 0;
+}
+
+void
+splpage(char *pag, char *New, long int sbit)
+{
+ datum key;
+ datum val;
+
+ register int n;
+ register int off = PBLKSIZ;
+ char cur[PBLKSIZ];
+ register short *ino = (short *) cur;
+
+ (void) memcpy(cur, pag, PBLKSIZ);
+ (void) memset(pag, 0, PBLKSIZ);
+ (void) memset(New, 0, PBLKSIZ);
+
+ n = ino[0];
+ for (ino++; n > 0; ino += 2) {
+ key.dptr = cur + ino[0];
+ key.dsize = off - ino[0];
+ val.dptr = cur + ino[1];
+ val.dsize = ino[0] - ino[1];
+/*
+ * select the page pointer (by looking at sbit) and insert
+ */
+ (void) putpair((exhash(key) & sbit) ? New : pag, key, val);
+
+ off = ino[1];
+ n -= 2;
+ }
+
+ debug(("%d split %d/%d\n", ((short *) cur)[0] / 2,
+ ((short *) New)[0] / 2,
+ ((short *) pag)[0] / 2));
+}
+
+/*
+ * check page sanity:
+ * number of entries should be something
+ * reasonable, and all offsets in the index should be in order.
+ * this could be made more rigorous.
+ */
+int
+chkpage(char *pag)
+{
+ register int n;
+ register int off;
+ register short *ino = (short *) pag;
+
+ if ((n = ino[0]) < 0 || n > PBLKSIZ / sizeof(short))
+ return 0;
+
+ if (n > 0) {
+ off = PBLKSIZ;
+ for (ino++; n > 0; ino += 2) {
+ if (ino[0] > off || ino[1] > off ||
+ ino[1] > ino[0])
+ return 0;
+ off = ino[1];
+ n -= 2;
+ }
+ }
+ return 1;
+}
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/pair.h b/contrib/perl5/ext/SDBM_File/sdbm/pair.h
new file mode 100644
index 000000000000..8a675b906598
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/pair.h
@@ -0,0 +1,20 @@
+/* Mini EMBED (pair.c) */
+#define chkpage sdbm__chkpage
+#define delpair sdbm__delpair
+#define duppair sdbm__duppair
+#define fitpair sdbm__fitpair
+#define getnkey sdbm__getnkey
+#define getpair sdbm__getpair
+#define putpair sdbm__putpair
+#define splpage sdbm__splpage
+
+extern int fitpair proto((char *, int));
+extern void putpair proto((char *, datum, datum));
+extern datum getpair proto((char *, datum));
+extern int delpair proto((char *, datum));
+extern int chkpage proto((char *));
+extern datum getnkey proto((char *, int));
+extern void splpage proto((char *, char *, long));
+#ifdef SEEDUPS
+extern int duppair proto((char *, datum));
+#endif
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/readme.ms b/contrib/perl5/ext/SDBM_File/sdbm/readme.ms
new file mode 100644
index 000000000000..01ca17ccdfda
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/readme.ms
@@ -0,0 +1,353 @@
+.\" tbl | readme.ms | [tn]roff -ms | ...
+.\" note the "C" (courier) and "CB" fonts: you will probably have to
+.\" change these.
+.\" $Id: readme.ms,v 1.1 90/12/13 13:09:15 oz Exp Locker: oz $
+
+.de P1
+.br
+.nr dT 4
+.nf
+.ft C
+.sp .5
+.nr t \\n(dT*\\w'x'u
+.ta 1u*\\ntu 2u*\\ntu 3u*\\ntu 4u*\\ntu 5u*\\ntu 6u*\\ntu 7u*\\ntu 8u*\\ntu 9u*\\ntu 10u*\\ntu 11u*\\ntu 12u*\\ntu 13u*\\ntu 14u*\\ntu
+..
+.de P2
+.br
+.ft 1
+.br
+.sp .5
+.br
+.fi
+..
+.\" CW uses the typewriter/courier font.
+.de CW
+\fC\\$1\\fP\\$2
+..
+
+.\" Footnote numbering [by Henry Spencer]
+.\" <text>\*f for a footnote number..
+.\" .FS
+.\" \*F <footnote text>
+.\" .FE
+.\"
+.ds f \\u\\s-2\\n+f\\s+2\\d
+.nr f 0 1
+.ds F \\n+F.
+.nr F 0 1
+
+.ND
+.LP
+.TL
+\fIsdbm\fP \(em Substitute DBM
+.br
+or
+.br
+Berkeley \fIndbm\fP for Every UN*X\** Made Simple
+.AU
+Ozan (oz) Yigit
+.AI
+The Guild of PD Software Toolmakers
+Toronto - Canada
+.sp
+oz@nexus.yorku.ca
+.LP
+.FS
+UN*X is not a trademark of any (dis)organization.
+.FE
+.sp 2
+\fIImplementation is the sincerest form of flattery. \(em L. Peter Deutsch\fP
+.SH
+A The Clone of the \fIndbm\fP library
+.PP
+The sources accompanying this notice \(em \fIsdbm\fP \(em constitute
+the first public release (Dec. 1990) of a complete clone of
+the Berkeley UN*X \fIndbm\fP library. The \fIsdbm\fP library is meant to
+clone the proven functionality of \fIndbm\fP as closely as possible,
+including a few improvements. It is practical, easy to understand, and
+compatible.
+The \fIsdbm\fP library is not derived from any licensed, proprietary or
+copyrighted software.
+.PP
+The \fIsdbm\fP implementation is based on a 1978 algorithm
+[Lar78] by P.-A. (Paul) Larson known as ``Dynamic Hashing''.
+In the course of searching for a substitute for \fIndbm\fP, I
+prototyped three different external-hashing algorithms [Lar78, Fag79, Lit80]
+and ultimately chose Larson's algorithm as a basis of the \fIsdbm\fP
+implementation. The Bell Labs
+\fIdbm\fP (and therefore \fIndbm\fP) is based on an algorithm invented by
+Ken Thompson, [Tho90, Tor87] and predates Larson's work.
+.PP
+The \fIsdbm\fR programming interface is totally compatible
+with \fIndbm\fP and includes a slight improvement in database initialization.
+It is also expected to be binary-compatible under most UN*X versions that
+support the \fIndbm\fP library.
+.PP
+The \fIsdbm\fP implementation shares the shortcomings of the \fIndbm\fP
+library, as a side effect of various simplifications to the original Larson
+algorithm. It does produce \fIholes\fP in the page file as it writes
+pages past the end of file. (Larson's paper include a clever solution to
+this problem that is a result of using the hash value directly as a block
+address.) On the other hand, extensive tests seem to indicate that \fIsdbm\fP
+creates fewer holes in general, and the resulting pagefiles are
+smaller. The \fIsdbm\fP implementation is also faster than \fIndbm\fP
+in database creation.
+Unlike the \fIndbm\fP, the \fIsdbm\fP
+.CW store
+operation will not ``wander away'' trying to split its
+data pages to insert a datum that \fIcannot\fP (due to elaborate worst-case
+situations) be inserted. (It will fail after a pre-defined number of attempts.)
+.SH
+Important Compatibility Warning
+.PP
+The \fIsdbm\fP and \fIndbm\fP
+libraries \fIcannot\fP share databases: one cannot read the (dir/pag)
+database created by the other. This is due to the differences
+between the \fIndbm\fP and \fIsdbm\fP algorithms\**,
+.FS
+Torek's discussion [Tor87]
+indicates that \fIdbm/ndbm\fP implementations use the hash
+value to traverse the radix trie differently than \fIsdbm\fP
+and as a result, the page indexes are generated in \fIdifferent\fP order.
+For more information, send e-mail to the author.
+.FE
+and the hash functions
+used.
+It is easy to convert between the \fIdbm/ndbm\fP databases and \fIsdbm\fP
+by ignoring the index completely: see
+.CW dbd ,
+.CW dbu
+etc.
+.R
+.LP
+.SH
+Notice of Intellectual Property
+.LP
+\fIThe entire\fP sdbm \fIlibrary package, as authored by me,\fP Ozan S. Yigit,
+\fIis hereby placed in the public domain.\fP As such, the author is not
+responsible for the consequences of use of this software, no matter how
+awful, even if they arise from defects in it. There is no expressed or
+implied warranty for the \fIsdbm\fP library.
+.PP
+Since the \fIsdbm\fP
+library package is in the public domain, this \fIoriginal\fP
+release or any additional public-domain releases of the modified original
+cannot possibly (by definition) be withheld from you. Also by definition,
+You (singular) have all the rights to this code (including the right to
+sell without permission, the right to hoard\**
+.FS
+You cannot really hoard something that is available to the public at
+large, but try if it makes you feel any better.
+.FE
+and the right to do other icky things as
+you see fit) but those rights are also granted to everyone else.
+.PP
+Please note that all previous distributions of this software contained
+a copyright (which is now dropped) to protect its
+origins and its current public domain status against any possible claims
+and/or challenges.
+.SH
+Acknowledgments
+.PP
+Many people have been very helpful and supportive. A partial list would
+necessarily include Rayan Zacherissen (who contributed the man page,
+and also hacked a MMAP version of \fIsdbm\fP),
+Arnold Robbins, Chris Lewis,
+Bill Davidsen, Henry Spencer, Geoff Collyer, Rich Salz (who got me started
+in the first place), Johannes Ruschein
+(who did the minix port) and David Tilbrook. I thank you all.
+.SH
+Distribution Manifest and Notes
+.LP
+This distribution of \fIsdbm\fP includes (at least) the following:
+.P1
+ CHANGES change log
+ README this file.
+ biblio a small bibliography on external hashing
+ dba.c a crude (n/s)dbm page file analyzer
+ dbd.c a crude (n/s)dbm page file dumper (for conversion)
+ dbe.1 man page for dbe.c
+ dbe.c Janick's database editor
+ dbm.c a dbm library emulation wrapper for ndbm/sdbm
+ dbm.h header file for the above
+ dbu.c a crude db management utility
+ hash.c hashing function
+ makefile guess.
+ pair.c page-level routines (posted earlier)
+ pair.h header file for the above
+ readme.ms troff source for the README file
+ sdbm.3 man page
+ sdbm.c the real thing
+ sdbm.h header file for the above
+ tune.h place for tuning & portability thingies
+ util.c miscellaneous
+.P2
+.PP
+.CW dbu
+is a simple database manipulation program\** that tries to look
+.FS
+The
+.CW dbd ,
+.CW dba ,
+.CW dbu
+utilities are quick hacks and are not fit for production use. They were
+developed late one night, just to test out \fIsdbm\fP, and convert some
+databases.
+.FE
+like Bell Labs'
+.CW cbt
+utility. It is currently incomplete in functionality.
+I use
+.CW dbu
+to test out the routines: it takes (from stdin) tab separated
+key/value pairs for commands like
+.CW build
+or
+.CW insert
+or takes keys for
+commands like
+.CW delete
+or
+.CW look .
+.P1
+ dbu <build|creat|look|insert|cat|delete> dbmfile
+.P2
+.PP
+.CW dba
+is a crude analyzer of \fIdbm/sdbm/ndbm\fP
+page files. It scans the entire
+page file, reporting page level statistics, and totals at the end.
+.PP
+.CW dbd
+is a crude dump program for \fIdbm/ndbm/sdbm\fP
+databases. It ignores the
+bitmap, and dumps the data pages in sequence. It can be used to create
+input for the
+.CW dbu
+utility.
+Note that
+.CW dbd
+will skip any NULLs in the key and data
+fields, thus is unsuitable to convert some peculiar databases that
+insist in including the terminating null.
+.PP
+I have also included a copy of the
+.CW dbe
+(\fIndbm\fP DataBase Editor) by Janick Bergeron [janick@bnr.ca] for
+your pleasure. You may find it more useful than the little
+.CW dbu
+utility.
+.PP
+.CW dbm.[ch]
+is a \fIdbm\fP library emulation on top of \fIndbm\fP
+(and hence suitable for \fIsdbm\fP). Written by Robert Elz.
+.PP
+The \fIsdbm\fP
+library has been around in beta test for quite a long time, and from whatever
+little feedback I received (maybe no news is good news), I believe it has been
+functioning without any significant problems. I would, of course, appreciate
+all fixes and/or improvements. Portability enhancements would especially be
+useful.
+.SH
+Implementation Issues
+.PP
+Hash functions:
+The algorithm behind \fIsdbm\fP implementation needs a good bit-scrambling
+hash function to be effective. I ran into a set of constants for a simple
+hash function that seem to help \fIsdbm\fP perform better than \fIndbm\fP
+for various inputs:
+.P1
+ /*
+ * polynomial conversion ignoring overflows
+ * 65599 nice. 65587 even better.
+ */
+ long
+ dbm_hash(char *str, int len) {
+ register unsigned long n = 0;
+
+ while (len--)
+ n = n * 65599 + *str++;
+ return n;
+ }
+.P2
+.PP
+There may be better hash functions for the purposes of dynamic hashing.
+Try your favorite, and check the pagefile. If it contains too many pages
+with too many holes, (in relation to this one for example) or if
+\fIsdbm\fP
+simply stops working (fails after
+.CW SPLTMAX
+attempts to split) when you feed your
+NEWS
+.CW history
+file to it, you probably do not have a good hashing function.
+If you do better (for different types of input), I would like to know
+about the function you use.
+.PP
+Block sizes: It seems (from various tests on a few machines) that a page
+file block size
+.CW PBLKSIZ
+of 1024 is by far the best for performance, but
+this also happens to limit the size of a key/value pair. Depending on your
+needs, you may wish to increase the page size, and also adjust
+.CW PAIRMAX
+(the maximum size of a key/value pair allowed: should always be at least
+three words smaller than
+.CW PBLKSIZ .)
+accordingly. The system-wide version of the library
+should probably be
+configured with 1024 (distribution default), as this appears to be sufficient
+for most common uses of \fIsdbm\fP.
+.SH
+Portability
+.PP
+This package has been tested in many different UN*Xes even including minix,
+and appears to be reasonably portable. This does not mean it will port
+easily to non-UN*X systems.
+.SH
+Notes and Miscellaneous
+.PP
+The \fIsdbm\fP is not a very complicated package, at least not after you
+familiarize yourself with the literature on external hashing. There are
+other interesting algorithms in existence that ensure (approximately)
+single-read access to a data value associated with any key. These are
+directory-less schemes such as \fIlinear hashing\fP [Lit80] (+ Larson
+variations), \fIspiral storage\fP [Mar79] or directory schemes such as
+\fIextensible hashing\fP [Fag79] by Fagin et al. I do hope these sources
+provide a reasonable playground for experimentation with other algorithms.
+See the June 1988 issue of ACM Computing Surveys [Enb88] for an
+excellent overview of the field.
+.PG
+.SH
+References
+.LP
+.IP [Lar78] 4m
+P.-A. Larson,
+``Dynamic Hashing'', \fIBIT\fP, vol. 18, pp. 184-201, 1978.
+.IP [Tho90] 4m
+Ken Thompson, \fIprivate communication\fP, Nov. 1990
+.IP [Lit80] 4m
+W. Litwin,
+`` Linear Hashing: A new tool for file and table addressing'',
+\fIProceedings of the 6th Conference on Very Large Dabatases (Montreal)\fP,
+pp. 212-223, Very Large Database Foundation, Saratoga, Calif., 1980.
+.IP [Fag79] 4m
+R. Fagin, J. Nievergelt, N. Pippinger, and H. R. Strong,
+``Extendible Hashing - A Fast Access Method for Dynamic Files'',
+\fIACM Trans. Database Syst.\fP, vol. 4, no.3, pp. 315-344, Sept. 1979.
+.IP [Wal84] 4m
+Rich Wales,
+``Discussion of "dbm" data base system'', \fIUSENET newsgroup unix.wizards\fP,
+Jan. 1984.
+.IP [Tor87] 4m
+Chris Torek,
+``Re: dbm.a and ndbm.a archives'', \fIUSENET newsgroup comp.unix\fP,
+1987.
+.IP [Mar79] 4m
+G. N. Martin,
+``Spiral Storage: Incrementally Augmentable Hash Addressed Storage'',
+\fITechnical Report #27\fP, University of Varwick, Coventry, U.K., 1979.
+.IP [Enb88] 4m
+R. J. Enbody and H. C. Du,
+``Dynamic Hashing Schemes'',\fIACM Computing Surveys\fP,
+vol. 20, no. 2, pp. 85-113, June 1988.
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.3 b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.3
new file mode 100644
index 000000000000..7e5c1764042d
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.3
@@ -0,0 +1,290 @@
+.\" $Id: sdbm.3,v 1.2 90/12/13 13:00:57 oz Exp $
+.TH SDBM 3 "1 March 1990"
+.SH NAME
+sdbm, sdbm_open, sdbm_prep, sdbm_close, sdbm_fetch, sdbm_store, sdbm_delete, sdbm_firstkey, sdbm_nextkey, sdbm_hash, sdbm_rdonly, sdbm_error, sdbm_clearerr, sdbm_dirfno, sdbm_pagfno \- data base subroutines
+.SH SYNOPSIS
+.nf
+.ft B
+#include <sdbm.h>
+.sp
+typedef struct {
+ char *dptr;
+ int dsize;
+} datum;
+.sp
+datum nullitem = { NULL, 0 };
+.sp
+\s-1DBM\s0 *sdbm_open(char *file, int flags, int mode)
+.sp
+\s-1DBM\s0 *sdbm_prep(char *dirname, char *pagname, int flags, int mode)
+.sp
+void sdbm_close(\s-1DBM\s0 *db)
+.sp
+datum sdbm_fetch(\s-1DBM\s0 *db, key)
+.sp
+int sdbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags)
+.sp
+int sdbm_delete(\s-1DBM\s0 *db, datum key)
+.sp
+datum sdbm_firstkey(\s-1DBM\s0 *db)
+.sp
+datum sdbm_nextkey(\s-1DBM\s0 *db)
+.sp
+long sdbm_hash(char *string, int len)
+.sp
+int sdbm_rdonly(\s-1DBM\s0 *db)
+int sdbm_error(\s-1DBM\s0 *db)
+sdbm_clearerr(\s-1DBM\s0 *db)
+int sdbm_dirfno(\s-1DBM\s0 *db)
+int sdbm_pagfno(\s-1DBM\s0 *db)
+.ft R
+.fi
+.SH DESCRIPTION
+.IX "database library" sdbm "" "\fLsdbm\fR"
+.IX sdbm_open "" "\fLsdbm_open\fR \(em open \fLsdbm\fR database"
+.IX sdbm_prep "" "\fLsdbm_prep\fR \(em prepare \fLsdbm\fR database"
+.IX sdbm_close "" "\fLsdbm_close\fR \(em close \fLsdbm\fR routine"
+.IX sdbm_fetch "" "\fLsdbm_fetch\fR \(em fetch \fLsdbm\fR database data"
+.IX sdbm_store "" "\fLsdbm_store\fR \(em add data to \fLsdbm\fR database"
+.IX sdbm_delete "" "\fLsdbm_delete\fR \(em remove data from \fLsdbm\fR database"
+.IX sdbm_firstkey "" "\fLsdbm_firstkey\fR \(em access \fLsdbm\fR database"
+.IX sdbm_nextkey "" "\fLsdbm_nextkey\fR \(em access \fLsdbm\fR database"
+.IX sdbm_hash "" "\fLsdbm_hash\fR \(em string hash for \fLsdbm\fR database"
+.IX sdbm_rdonly "" "\fLsdbm_rdonly\fR \(em return \fLsdbm\fR database read-only mode"
+.IX sdbm_error "" "\fLsdbm_error\fR \(em return \fLsdbm\fR database error condition"
+.IX sdbm_clearerr "" "\fLsdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition"
+.IX sdbm_dirfno "" "\fLsdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descriptor"
+.IX sdbm_pagfno "" "\fLsdbm_pagfno\fR \(em return \fLsdbm\fR database data file descriptor"
+.IX "database functions \(em \fLsdbm\fR" sdbm_open "" \fLsdbm_open\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_prep "" \fLsdbm_prep\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_close "" \fLsdbm_close\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_fetch "" \fLsdbm_fetch\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_store "" \fLsdbm_store\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_delete "" \fLsdbm_delete\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_firstkey "" \fLsdbm_firstkey\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_nextkey "" \fLsdbm_nextkey\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_rdonly "" \fLsdbm_rdonly\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_error "" \fLsdbm_error\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_clearerr "" \fLsdbm_clearerr\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_dirfno "" \fLsdbm_dirfno\fP
+.IX "database functions \(em \fLsdbm\fR" sdbm_pagfno "" \fLsdbm_pagfno\fP
+.LP
+This package allows an application to maintain a mapping of <key,value> pairs
+in disk files. This is not to be considered a real database system, but is
+still useful in many simple applications built around fast retrieval of a data
+value from a key. This implementation uses an external hashing scheme,
+called Dynamic Hashing, as described by Per-Aake Larson in BIT 18 (1978) pp.
+184-201. Retrieval of any item usually requires a single disk access.
+The application interface is compatible with the
+.IR ndbm (3)
+library.
+.LP
+An
+.B sdbm
+database is kept in two files usually given the extensions
+.B \.dir
+and
+.BR \.pag .
+The
+.B \.dir
+file contains a bitmap representing a forest of binary hash trees, the leaves
+of which indicate data pages in the
+.B \.pag
+file.
+.LP
+The application interface uses the
+.B datum
+structure to describe both
+.I keys
+and
+.IR value s.
+A
+.B datum
+specifies a byte sequence of
+.I dsize
+size pointed to by
+.IR dptr .
+If you use
+.SM ASCII
+strings as
+.IR key s
+or
+.IR value s,
+then you must decide whether or not to include the terminating
+.SM NUL
+byte which sometimes defines strings. Including it will require larger
+database files, but it will be possible to get sensible output from a
+.IR strings (1)
+command applied to the data file.
+.LP
+In order to allow a process using this package to manipulate multiple
+databases, the applications interface always requires a
+.IR handle ,
+a
+.BR "DBM *" ,
+to identify the database to be manipulated. Such a handle can be obtained
+from the only routines that do not require it, namely
+.BR sdbm_open (\|)
+or
+.BR sdbm_prep (\|).
+Either of these will open or create the two necessary files. The
+difference is that the latter allows explicitly naming the bitmap and data
+files whereas
+.BR sdbm_open (\|)
+will take a base file name and call
+.BR sdbm_prep (\|)
+with the default extensions.
+The
+.I flags
+and
+.I mode
+parameters are the same as for
+.BR open (2).
+.LP
+To free the resources occupied while a database handle is active, call
+.BR sdbm_close (\|).
+.LP
+Given a handle, one can retrieve data associated with a key by using the
+.BR sdbm_fetch (\|)
+routine, and associate data with a key by using the
+.BR sdbm_store (\|)
+routine.
+.LP
+The values of the
+.I flags
+parameter for
+.BR sdbm_store (\|)
+can be either
+.BR \s-1DBM_INSERT\s0 ,
+which will not change an existing entry with the same key, or
+.BR \s-1DBM_REPLACE\s0 ,
+which will replace an existing entry with the same key.
+Keys are unique within the database.
+.LP
+To delete a key and its associated value use the
+.BR sdbm_delete (\|)
+routine.
+.LP
+To retrieve every key in the database, use a loop like:
+.sp
+.nf
+.ft B
+for (key = sdbm_firstkey(db); key.dptr != NULL; key = sdbm_nextkey(db))
+ ;
+.ft R
+.fi
+.LP
+The order of retrieval is unspecified.
+.LP
+If you determine that the performance of the database is inadequate or
+you notice clustering or other effects that may be due to the hashing
+algorithm used by this package, you can override it by supplying your
+own
+.BR sdbm_hash (\|)
+routine. Doing so will make the database unintelligable to any other
+applications that do not use your specialized hash function.
+.sp
+.LP
+The following macros are defined in the header file:
+.IP
+.BR sdbm_rdonly (\|)
+returns true if the database has been opened read\-only.
+.IP
+.BR sdbm_error (\|)
+returns true if an I/O error has occurred.
+.IP
+.BR sdbm_clearerr (\|)
+allows you to clear the error flag if you think you know what the error
+was and insist on ignoring it.
+.IP
+.BR sdbm_dirfno (\|)
+returns the file descriptor associated with the bitmap file.
+.IP
+.BR sdbm_pagfno (\|)
+returns the file descriptor associated with the data file.
+.SH SEE ALSO
+.IR open (2).
+.SH DIAGNOSTICS
+Functions that return a
+.B "DBM *"
+handle will use
+.SM NULL
+to indicate an error.
+Functions that return an
+.B int
+will use \-1 to indicate an error. The normal return value in that case is 0.
+Functions that return a
+.B datum
+will return
+.B nullitem
+to indicate an error.
+.LP
+As a special case of
+.BR sdbm_store (\|),
+if it is called with the
+.B \s-1DBM_INSERT\s0
+flag and the key already exists in the database, the return value will be 1.
+.LP
+In general, if a function parameter is invalid,
+.B errno
+will be set to
+.BR \s-1EINVAL\s0 .
+If a write operation is requested on a read-only database,
+.B errno
+will be set to
+.BR \s-1ENOPERM\s0 .
+If a memory allocation (using
+.IR malloc (3))
+failed,
+.B errno
+will be set to
+.BR \s-1ENOMEM\s0 .
+For I/O operation failures
+.B errno
+will contain the value set by the relevant failed system call, either
+.IR read (2),
+.IR write (2),
+or
+.IR lseek (2).
+.SH AUTHOR
+.IP "Ozan S. Yigit" (oz@nexus.yorku.ca)
+.SH BUGS
+The sum of key and value data sizes must not exceed
+.B \s-1PAIRMAX\s0
+(1008 bytes).
+.LP
+The sum of the key and value data sizes where several keys hash to the
+same value must fit within one bitmap page.
+.LP
+The
+.B \.pag
+file will contain holes, so its apparent size is larger than its contents.
+When copied through the filesystem the holes will be filled.
+.LP
+The contents of
+.B datum
+values returned are in volatile storage. If you want to retain the values
+pointed to, you must copy them immediately before another call to this package.
+.LP
+The only safe way for multiple processes to (read and) update a database at
+the same time, is to implement a private locking scheme outside this package
+and open and close the database between lock acquisitions. It is safe for
+multiple processes to concurrently access a database read-only.
+.SH APPLICATIONS PORTABILITY
+For complete source code compatibility with the Berkeley Unix
+.IR ndbm (3)
+library, the
+.B sdbm.h
+header file should be installed in
+.BR /usr/include/ndbm.h .
+.LP
+The
+.B nullitem
+data item, and the
+.BR sdbm_prep (\|),
+.BR sdbm_hash (\|),
+.BR sdbm_rdonly (\|),
+.BR sdbm_dirfno (\|),
+and
+.BR sdbm_pagfno (\|)
+functions are unique to this package.
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c
new file mode 100644
index 000000000000..637fbe98a1b5
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.c
@@ -0,0 +1,492 @@
+/*
+ * sdbm - ndbm work-alike hashed database library
+ * based on Per-Aake Larson's Dynamic Hashing algorithms. BIT 18 (1978).
+ * author: oz@nexus.yorku.ca
+ * status: public domain.
+ *
+ * core routines
+ */
+
+#include "INTERN.h"
+#include "config.h"
+#include "sdbm.h"
+#include "tune.h"
+#include "pair.h"
+
+#ifdef I_FCNTL
+# include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+# include <sys/file.h>
+#endif
+
+#ifdef I_STRING
+# include <string.h>
+#else
+# include <strings.h>
+#endif
+
+/*
+ * externals
+ */
+#ifndef WIN32
+#ifndef sun
+extern int errno;
+#endif
+
+extern Malloc_t malloc proto((MEM_SIZE));
+extern Free_t free proto((Malloc_t));
+extern Off_t lseek(int, Off_t, int);
+#endif
+
+/*
+ * forward
+ */
+static int getdbit proto((DBM *, long));
+static int setdbit proto((DBM *, long));
+static int getpage proto((DBM *, long));
+static datum getnext proto((DBM *));
+static int makroom proto((DBM *, long, int));
+
+/*
+ * useful macros
+ */
+#define bad(x) ((x).dptr == NULL || (x).dsize < 0)
+#define exhash(item) sdbm_hash((item).dptr, (item).dsize)
+#define ioerr(db) ((db)->flags |= DBM_IOERR)
+
+#define OFF_PAG(off) (long) (off) * PBLKSIZ
+#define OFF_DIR(off) (long) (off) * DBLKSIZ
+
+static long masks[] = {
+ 000000000000, 000000000001, 000000000003, 000000000007,
+ 000000000017, 000000000037, 000000000077, 000000000177,
+ 000000000377, 000000000777, 000000001777, 000000003777,
+ 000000007777, 000000017777, 000000037777, 000000077777,
+ 000000177777, 000000377777, 000000777777, 000001777777,
+ 000003777777, 000007777777, 000017777777, 000037777777,
+ 000077777777, 000177777777, 000377777777, 000777777777,
+ 001777777777, 003777777777, 007777777777, 017777777777
+};
+
+DBM *
+sdbm_open(register char *file, register int flags, register int mode)
+{
+ register DBM *db;
+ register char *dirname;
+ register char *pagname;
+ register int n;
+
+ if (file == NULL || !*file)
+ return errno = EINVAL, (DBM *) NULL;
+/*
+ * need space for two seperate filenames
+ */
+ n = strlen(file) * 2 + strlen(DIRFEXT) + strlen(PAGFEXT) + 2;
+
+ if ((dirname = (char *) malloc((unsigned) n)) == NULL)
+ return errno = ENOMEM, (DBM *) NULL;
+/*
+ * build the file names
+ */
+ dirname = strcat(strcpy(dirname, file), DIRFEXT);
+ pagname = strcpy(dirname + strlen(dirname) + 1, file);
+ pagname = strcat(pagname, PAGFEXT);
+
+ db = sdbm_prep(dirname, pagname, flags, mode);
+ free((char *) dirname);
+ return db;
+}
+
+DBM *
+sdbm_prep(char *dirname, char *pagname, int flags, int mode)
+{
+ register DBM *db;
+ struct stat dstat;
+
+ if ((db = (DBM *) malloc(sizeof(DBM))) == NULL)
+ return errno = ENOMEM, (DBM *) NULL;
+
+ db->flags = 0;
+ db->hmask = 0;
+ db->blkptr = 0;
+ db->keyptr = 0;
+/*
+ * adjust user flags so that WRONLY becomes RDWR,
+ * as required by this package. Also set our internal
+ * flag for RDONLY if needed.
+ */
+ if (flags & O_WRONLY)
+ flags = (flags & ~O_WRONLY) | O_RDWR;
+
+ else if ((flags & 03) == O_RDONLY)
+ db->flags = DBM_RDONLY;
+/*
+ * open the files in sequence, and stat the dirfile.
+ * If we fail anywhere, undo everything, return NULL.
+ */
+#if defined(OS2) || defined(MSDOS) || defined(WIN32)
+ flags |= O_BINARY;
+# endif
+ if ((db->pagf = open(pagname, flags, mode)) > -1) {
+ if ((db->dirf = open(dirname, flags, mode)) > -1) {
+/*
+ * need the dirfile size to establish max bit number.
+ */
+ if (fstat(db->dirf, &dstat) == 0) {
+/*
+ * zero size: either a fresh database, or one with a single,
+ * unsplit data page: dirpage is all zeros.
+ */
+ db->dirbno = (!dstat.st_size) ? 0 : -1;
+ db->pagbno = -1;
+ db->maxbno = dstat.st_size * BYTESIZ;
+
+ (void) memset(db->pagbuf, 0, PBLKSIZ);
+ (void) memset(db->dirbuf, 0, DBLKSIZ);
+ /*
+ * success
+ */
+ return db;
+ }
+ (void) close(db->dirf);
+ }
+ (void) close(db->pagf);
+ }
+ free((char *) db);
+ return (DBM *) NULL;
+}
+
+void
+sdbm_close(register DBM *db)
+{
+ if (db == NULL)
+ errno = EINVAL;
+ else {
+ (void) close(db->dirf);
+ (void) close(db->pagf);
+ free((char *) db);
+ }
+}
+
+datum
+sdbm_fetch(register DBM *db, datum key)
+{
+ if (db == NULL || bad(key))
+ return errno = EINVAL, nullitem;
+
+ if (getpage(db, exhash(key)))
+ return getpair(db->pagbuf, key);
+
+ return ioerr(db), nullitem;
+}
+
+int
+sdbm_delete(register DBM *db, datum key)
+{
+ if (db == NULL || bad(key))
+ return errno = EINVAL, -1;
+ if (sdbm_rdonly(db))
+ return errno = EPERM, -1;
+
+ if (getpage(db, exhash(key))) {
+ if (!delpair(db->pagbuf, key))
+ return -1;
+/*
+ * update the page file
+ */
+ if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0
+ || write(db->pagf, db->pagbuf, PBLKSIZ) < 0)
+ return ioerr(db), -1;
+
+ return 0;
+ }
+
+ return ioerr(db), -1;
+}
+
+int
+sdbm_store(register DBM *db, datum key, datum val, int flags)
+{
+ int need;
+ register long hash;
+
+ if (db == NULL || bad(key))
+ return errno = EINVAL, -1;
+ if (sdbm_rdonly(db))
+ return errno = EPERM, -1;
+
+ need = key.dsize + val.dsize;
+/*
+ * is the pair too big (or too small) for this database ??
+ */
+ if (need < 0 || need > PAIRMAX)
+ return errno = EINVAL, -1;
+
+ if (getpage(db, (hash = exhash(key)))) {
+/*
+ * if we need to replace, delete the key/data pair
+ * first. If it is not there, ignore.
+ */
+ if (flags == DBM_REPLACE)
+ (void) delpair(db->pagbuf, key);
+#ifdef SEEDUPS
+ else if (duppair(db->pagbuf, key))
+ return 1;
+#endif
+/*
+ * if we do not have enough room, we have to split.
+ */
+ if (!fitpair(db->pagbuf, need))
+ if (!makroom(db, hash, need))
+ return ioerr(db), -1;
+/*
+ * we have enough room or split is successful. insert the key,
+ * and update the page file.
+ */
+ (void) putpair(db->pagbuf, key, val);
+
+ if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0
+ || write(db->pagf, db->pagbuf, PBLKSIZ) < 0)
+ return ioerr(db), -1;
+ /*
+ * success
+ */
+ return 0;
+ }
+
+ return ioerr(db), -1;
+}
+
+/*
+ * makroom - make room by splitting the overfull page
+ * this routine will attempt to make room for SPLTMAX times before
+ * giving up.
+ */
+static int
+makroom(register DBM *db, long int hash, int need)
+{
+ long newp;
+ char twin[PBLKSIZ];
+ char *pag = db->pagbuf;
+ char *New = twin;
+ register int smax = SPLTMAX;
+
+ do {
+/*
+ * split the current page
+ */
+ (void) splpage(pag, New, db->hmask + 1);
+/*
+ * address of the new page
+ */
+ newp = (hash & db->hmask) | (db->hmask + 1);
+
+/*
+ * write delay, read avoidence/cache shuffle:
+ * select the page for incoming pair: if key is to go to the new page,
+ * write out the previous one, and copy the new one over, thus making
+ * it the current page. If not, simply write the new page, and we are
+ * still looking at the page of interest. current page is not updated
+ * here, as sdbm_store will do so, after it inserts the incoming pair.
+ */
+ if (hash & (db->hmask + 1)) {
+ if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0
+ || write(db->pagf, db->pagbuf, PBLKSIZ) < 0)
+ return 0;
+ db->pagbno = newp;
+ (void) memcpy(pag, New, PBLKSIZ);
+ }
+ else if (lseek(db->pagf, OFF_PAG(newp), SEEK_SET) < 0
+ || write(db->pagf, New, PBLKSIZ) < 0)
+ return 0;
+
+ if (!setdbit(db, db->curbit))
+ return 0;
+/*
+ * see if we have enough room now
+ */
+ if (fitpair(pag, need))
+ return 1;
+/*
+ * try again... update curbit and hmask as getpage would have
+ * done. because of our update of the current page, we do not
+ * need to read in anything. BUT we have to write the current
+ * [deferred] page out, as the window of failure is too great.
+ */
+ db->curbit = 2 * db->curbit +
+ ((hash & (db->hmask + 1)) ? 2 : 1);
+ db->hmask |= db->hmask + 1;
+
+ if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0
+ || write(db->pagf, db->pagbuf, PBLKSIZ) < 0)
+ return 0;
+
+ } while (--smax);
+/*
+ * if we are here, this is real bad news. After SPLTMAX splits,
+ * we still cannot fit the key. say goodnight.
+ */
+#ifdef BADMESS
+ (void) write(2, "sdbm: cannot insert after SPLTMAX attempts.\n", 44);
+#endif
+ return 0;
+
+}
+
+/*
+ * the following two routines will break if
+ * deletions aren't taken into account. (ndbm bug)
+ */
+datum
+sdbm_firstkey(register DBM *db)
+{
+ if (db == NULL)
+ return errno = EINVAL, nullitem;
+/*
+ * start at page 0
+ */
+ if (lseek(db->pagf, OFF_PAG(0), SEEK_SET) < 0
+ || read(db->pagf, db->pagbuf, PBLKSIZ) < 0)
+ return ioerr(db), nullitem;
+ db->pagbno = 0;
+ db->blkptr = 0;
+ db->keyptr = 0;
+
+ return getnext(db);
+}
+
+datum
+sdbm_nextkey(register DBM *db)
+{
+ if (db == NULL)
+ return errno = EINVAL, nullitem;
+ return getnext(db);
+}
+
+/*
+ * all important binary trie traversal
+ */
+static int
+getpage(register DBM *db, register long int hash)
+{
+ register int hbit;
+ register long dbit;
+ register long pagb;
+
+ dbit = 0;
+ hbit = 0;
+ while (dbit < db->maxbno && getdbit(db, dbit))
+ dbit = 2 * dbit + ((hash & (1 << hbit++)) ? 2 : 1);
+
+ debug(("dbit: %d...", dbit));
+
+ db->curbit = dbit;
+ db->hmask = masks[hbit];
+
+ pagb = hash & db->hmask;
+/*
+ * see if the block we need is already in memory.
+ * note: this lookaside cache has about 10% hit rate.
+ */
+ if (pagb != db->pagbno) {
+/*
+ * note: here, we assume a "hole" is read as 0s.
+ * if not, must zero pagbuf first.
+ */
+ if (lseek(db->pagf, OFF_PAG(pagb), SEEK_SET) < 0
+ || read(db->pagf, db->pagbuf, PBLKSIZ) < 0)
+ return 0;
+ if (!chkpage(db->pagbuf))
+ return 0;
+ db->pagbno = pagb;
+
+ debug(("pag read: %d\n", pagb));
+ }
+ return 1;
+}
+
+static int
+getdbit(register DBM *db, register long int dbit)
+{
+ register long c;
+ register long dirb;
+
+ c = dbit / BYTESIZ;
+ dirb = c / DBLKSIZ;
+
+ if (dirb != db->dirbno) {
+ if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0
+ || read(db->dirf, db->dirbuf, DBLKSIZ) < 0)
+ return 0;
+ db->dirbno = dirb;
+
+ debug(("dir read: %d\n", dirb));
+ }
+
+ return db->dirbuf[c % DBLKSIZ] & (1 << dbit % BYTESIZ);
+}
+
+static int
+setdbit(register DBM *db, register long int dbit)
+{
+ register long c;
+ register long dirb;
+
+ c = dbit / BYTESIZ;
+ dirb = c / DBLKSIZ;
+
+ if (dirb != db->dirbno) {
+ if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0
+ || read(db->dirf, db->dirbuf, DBLKSIZ) < 0)
+ return 0;
+ db->dirbno = dirb;
+
+ debug(("dir read: %d\n", dirb));
+ }
+
+ db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ);
+
+ if (dbit >= db->maxbno)
+ db->maxbno += DBLKSIZ * BYTESIZ;
+
+ if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0
+ || write(db->dirf, db->dirbuf, DBLKSIZ) < 0)
+ return 0;
+
+ return 1;
+}
+
+/*
+ * getnext - get the next key in the page, and if done with
+ * the page, try the next page in sequence
+ */
+static datum
+getnext(register DBM *db)
+{
+ datum key;
+
+ for (;;) {
+ db->keyptr++;
+ key = getnkey(db->pagbuf, db->keyptr);
+ if (key.dptr != NULL)
+ return key;
+/*
+ * we either run out, or there is nothing on this page..
+ * try the next one... If we lost our position on the
+ * file, we will have to seek.
+ */
+ db->keyptr = 0;
+ if (db->pagbno != db->blkptr++)
+ if (lseek(db->pagf, OFF_PAG(db->blkptr), SEEK_SET) < 0)
+ break;
+ db->pagbno = db->blkptr;
+ if (read(db->pagf, db->pagbuf, PBLKSIZ) <= 0)
+ break;
+ if (!chkpage(db->pagbuf))
+ break;
+ }
+
+ return ioerr(db), nullitem;
+}
+
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/sdbm.h b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.h
new file mode 100644
index 000000000000..84d5f75468cd
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/sdbm.h
@@ -0,0 +1,290 @@
+/*
+ * sdbm - ndbm work-alike hashed database library
+ * based on Per-Ake Larson's Dynamic Hashing algorithms. BIT 18 (1978).
+ * author: oz@nexus.yorku.ca
+ * status: public domain.
+ */
+#define DBLKSIZ 4096
+#define PBLKSIZ 1024
+#define PAIRMAX 1008 /* arbitrary on PBLKSIZ-N */
+#define SPLTMAX 10 /* maximum allowed splits */
+ /* for a single insertion */
+#ifdef VMS
+#define DIRFEXT ".sdbm_dir"
+#else
+#define DIRFEXT ".dir"
+#endif
+#define PAGFEXT ".pag"
+
+typedef struct {
+ int dirf; /* directory file descriptor */
+ int pagf; /* page file descriptor */
+ int flags; /* status/error flags, see below */
+ long maxbno; /* size of dirfile in bits */
+ long curbit; /* current bit number */
+ long hmask; /* current hash mask */
+ long blkptr; /* current block for nextkey */
+ int keyptr; /* current key for nextkey */
+ long blkno; /* current page to read/write */
+ long pagbno; /* current page in pagbuf */
+ char pagbuf[PBLKSIZ]; /* page file block buffer */
+ long dirbno; /* current block in dirbuf */
+ char dirbuf[DBLKSIZ]; /* directory file block buffer */
+} DBM;
+
+#define DBM_RDONLY 0x1 /* data base open read-only */
+#define DBM_IOERR 0x2 /* data base I/O error */
+
+/*
+ * utility macros
+ */
+#define sdbm_rdonly(db) ((db)->flags & DBM_RDONLY)
+#define sdbm_error(db) ((db)->flags & DBM_IOERR)
+
+#define sdbm_clearerr(db) ((db)->flags &= ~DBM_IOERR) /* ouch */
+
+#define sdbm_dirfno(db) ((db)->dirf)
+#define sdbm_pagfno(db) ((db)->pagf)
+
+typedef struct {
+ char *dptr;
+ int dsize;
+} datum;
+
+EXTCONST datum nullitem
+#ifdef DOINIT
+ = {0, 0}
+#endif
+ ;
+
+#if defined(__STDC__) || defined(__cplusplus) || defined(CAN_PROTOTYPE)
+#define proto(p) p
+#else
+#define proto(p) ()
+#endif
+
+/*
+ * flags to sdbm_store
+ */
+#define DBM_INSERT 0
+#define DBM_REPLACE 1
+
+/*
+ * ndbm interface
+ */
+extern DBM *sdbm_open proto((char *, int, int));
+extern void sdbm_close proto((DBM *));
+extern datum sdbm_fetch proto((DBM *, datum));
+extern int sdbm_delete proto((DBM *, datum));
+extern int sdbm_store proto((DBM *, datum, datum, int));
+extern datum sdbm_firstkey proto((DBM *));
+extern datum sdbm_nextkey proto((DBM *));
+
+/*
+ * other
+ */
+extern DBM *sdbm_prep proto((char *, char *, int, int));
+extern long sdbm_hash proto((char *, int));
+
+#ifndef SDBM_ONLY
+#define dbm_open sdbm_open
+#define dbm_close sdbm_close
+#define dbm_fetch sdbm_fetch
+#define dbm_store sdbm_store
+#define dbm_delete sdbm_delete
+#define dbm_firstkey sdbm_firstkey
+#define dbm_nextkey sdbm_nextkey
+#define dbm_error sdbm_error
+#define dbm_clearerr sdbm_clearerr
+#endif
+
+/* Most of the following is stolen from perl.h. */
+#ifndef H_PERL /* Include guard */
+
+/*
+ * The following contortions are brought to you on behalf of all the
+ * standards, semi-standards, de facto standards, not-so-de-facto standards
+ * of the world, as well as all the other botches anyone ever thought of.
+ * The basic theory is that if we work hard enough here, the rest of the
+ * code can be a lot prettier. Well, so much for theory. Sorry, Henry...
+ */
+
+#include <errno.h>
+#ifdef HAS_SOCKET
+# ifdef I_NET_ERRNO
+# include <net/errno.h>
+# endif
+#endif
+
+#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus)
+# define STANDARD_C 1
+#endif
+
+#include <stdio.h>
+#include <ctype.h>
+#include <setjmp.h>
+
+#if defined(I_UNISTD)
+#include <unistd.h>
+#endif
+
+#ifdef VMS
+# include <file.h>
+# include <unixio.h>
+#endif
+
+#ifdef I_SYS_PARAM
+# if !defined(MSDOS) && !defined(WIN32) && !defined(VMS)
+# ifdef PARAM_NEEDS_TYPES
+# include <sys/types.h>
+# endif
+# include <sys/param.h>
+# endif
+#endif
+
+#ifndef _TYPES_ /* If types.h defines this it's easy. */
+# ifndef major /* Does everyone's types.h define this? */
+# include <sys/types.h>
+# endif
+#endif
+
+#include <sys/stat.h>
+
+#ifndef SEEK_SET
+# ifdef L_SET
+# define SEEK_SET L_SET
+# else
+# define SEEK_SET 0 /* Wild guess. */
+# endif
+#endif
+
+/* Use all the "standard" definitions? */
+#if defined(STANDARD_C) && defined(I_STDLIB)
+# include <stdlib.h>
+#endif /* STANDARD_C */
+
+#define MEM_SIZE Size_t
+
+/* This comes after <stdlib.h> so we don't try to change the standard
+ * library prototypes; we'll use our own instead. */
+
+#if defined(MYMALLOC) && (defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC))
+
+# ifdef HIDEMYMALLOC
+# define malloc Mymalloc
+# define calloc Mycalloc
+# define realloc Myremalloc
+# define free Myfree
+# endif
+# ifdef EMBEDMYMALLOC
+# define malloc Perl_malloc
+# define calloc Perl_calloc
+# define realloc Perl_realloc
+# define free Perl_free
+# endif
+
+ Malloc_t malloc proto((MEM_SIZE nbytes));
+ Malloc_t calloc proto((MEM_SIZE elements, MEM_SIZE size));
+ Malloc_t realloc proto((Malloc_t where, MEM_SIZE nbytes));
+ Free_t free proto((Malloc_t where));
+
+#endif /* MYMALLOC && (HIDEMYMALLOC || EMBEDMYMALLOC) */
+
+#ifdef I_STRING
+#include <string.h>
+#else
+#include <strings.h>
+#endif
+
+#ifdef I_MEMORY
+#include <memory.h>
+#endif
+
+#ifdef __cplusplus
+#define HAS_MEMCPY
+#endif
+
+#ifdef HAS_MEMCPY
+# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
+# ifndef memcpy
+ extern char * memcpy proto((char*, char*, int));
+# endif
+# endif
+#else
+# ifndef memcpy
+# ifdef HAS_BCOPY
+# define memcpy(d,s,l) bcopy(s,d,l)
+# else
+# define memcpy(d,s,l) my_bcopy(s,d,l)
+# endif
+# endif
+#endif /* HAS_MEMCPY */
+
+#ifdef HAS_MEMSET
+# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
+# ifndef memset
+ extern char *memset proto((char*, int, int));
+# endif
+# endif
+# define memzero(d,l) memset(d,0,l)
+#else
+# ifndef memzero
+# ifdef HAS_BZERO
+# define memzero(d,l) bzero(d,l)
+# else
+# define memzero(d,l) my_bzero(d,l)
+# endif
+# endif
+#endif /* HAS_MEMSET */
+
+#if defined(mips) && defined(ultrix) && !defined(__STDC__)
+# undef HAS_MEMCMP
+#endif
+
+#if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP)
+# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
+# ifndef memcmp
+ extern int memcmp proto((char*, char*, int));
+# endif
+# endif
+# ifdef BUGGY_MSC
+ # pragma function(memcmp)
+# endif
+#else
+# ifndef memcmp
+ /* maybe we should have included the full embedding header... */
+# ifdef NO_EMBED
+# define memcmp my_memcmp
+# else
+# define memcmp Perl_my_memcmp
+# endif
+#ifndef __cplusplus
+ extern int memcmp proto((char*, char*, int));
+#endif
+# endif
+#endif /* HAS_MEMCMP */
+
+#ifndef HAS_BCMP
+# ifndef bcmp
+# define bcmp(s1,s2,l) memcmp(s1,s2,l)
+# endif
+#endif /* !HAS_BCMP */
+
+#ifdef HAS_MEMCMP
+# define memNE(s1,s2,l) (memcmp(s1,s2,l))
+# define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
+#else
+# define memNE(s1,s2,l) (bcmp(s1,s2,l))
+# define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
+#endif
+
+#ifdef I_NETINET_IN
+# ifdef VMS
+# include <in.h>
+# else
+# include <netinet/in.h>
+# endif
+#endif
+
+#endif /* Include guard */
+
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/tune.h b/contrib/perl5/ext/SDBM_File/sdbm/tune.h
new file mode 100644
index 000000000000..b95c8c8634ae
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/tune.h
@@ -0,0 +1,23 @@
+/*
+ * sdbm - ndbm work-alike hashed database library
+ * tuning and portability constructs [not nearly enough]
+ * author: oz@nexus.yorku.ca
+ */
+
+#define BYTESIZ 8
+
+/*
+ * important tuning parms (hah)
+ */
+
+#define SEEDUPS /* always detect duplicates */
+#define BADMESS /* generate a message for worst case:
+ cannot make room after SPLTMAX splits */
+/*
+ * misc
+ */
+#ifdef DEBUG
+#define debug(x) printf x
+#else
+#define debug(x)
+#endif
diff --git a/contrib/perl5/ext/SDBM_File/sdbm/util.c b/contrib/perl5/ext/SDBM_File/sdbm/util.c
new file mode 100644
index 000000000000..16bd4ac9a5c1
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/sdbm/util.c
@@ -0,0 +1,47 @@
+#include <stdio.h>
+#ifdef SDBM
+#include "sdbm.h"
+#else
+#include "ndbm.h"
+#endif
+
+void
+oops(register char *s1, register char *s2)
+{
+ extern int errno, sys_nerr;
+ extern char *sys_errlist[];
+ extern char *progname;
+
+ if (progname)
+ fprintf(stderr, "%s: ", progname);
+ fprintf(stderr, s1, s2);
+ if (errno > 0 && errno < sys_nerr)
+ fprintf(stderr, " (%s)", sys_errlist[errno]);
+ fprintf(stderr, "\n");
+ exit(1);
+}
+
+int
+okpage(char *pag)
+{
+ register unsigned n;
+ register off;
+ register short *ino = (short *) pag;
+
+ if ((n = ino[0]) > PBLKSIZ / sizeof(short))
+ return 0;
+
+ if (!n)
+ return 1;
+
+ off = PBLKSIZ;
+ for (ino++; n; ino += 2) {
+ if (ino[0] > off || ino[1] > off ||
+ ino[1] > ino[0])
+ return 0;
+ off = ino[1];
+ n -= 2;
+ }
+
+ return 1;
+}
diff --git a/contrib/perl5/ext/SDBM_File/typemap b/contrib/perl5/ext/SDBM_File/typemap
new file mode 100644
index 000000000000..317a8f3886cb
--- /dev/null
+++ b/contrib/perl5/ext/SDBM_File/typemap
@@ -0,0 +1,27 @@
+#
+#################################### DBM SECTION
+#
+
+datum T_DATUM
+gdatum T_GDATUM
+NDBM_File T_PTROBJ
+GDBM_File T_PTROBJ
+SDBM_File T_PTROBJ
+ODBM_File T_PTROBJ
+DB_File T_PTROBJ
+DBZ_File T_PTROBJ
+FATALFUNC T_OPAQUEPTR
+
+INPUT
+T_DATUM
+ $var.dptr = SvPV($arg, PL_na);
+ $var.dsize = (int)PL_na;
+T_GDATUM
+ UNIMPLEMENTED
+OUTPUT
+T_DATUM
+ sv_setpvn($arg, $var.dptr, $var.dsize);
+T_GDATUM
+ sv_usepvn($arg, $var.dptr, $var.dsize);
+T_PTROBJ
+ sv_setref_pv($arg, dbtype, (void*)$var);
diff --git a/contrib/perl5/ext/Socket/Makefile.PL b/contrib/perl5/ext/Socket/Makefile.PL
new file mode 100644
index 000000000000..7b9469a728ea
--- /dev/null
+++ b/contrib/perl5/ext/Socket/Makefile.PL
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Socket',
+ VERSION_FROM => 'Socket.pm',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+);
diff --git a/contrib/perl5/ext/Socket/Socket.pm b/contrib/perl5/ext/Socket/Socket.pm
new file mode 100644
index 000000000000..5a4870f4afa4
--- /dev/null
+++ b/contrib/perl5/ext/Socket/Socket.pm
@@ -0,0 +1,307 @@
+package Socket;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+$VERSION = "1.7";
+
+=head1 NAME
+
+Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa - load the C socket.h defines and structure manipulators
+
+=head1 SYNOPSIS
+
+ use Socket;
+
+ $proto = getprotobyname('udp');
+ socket(Socket_Handle, PF_INET, SOCK_DGRAM, $proto);
+ $iaddr = gethostbyname('hishost.com');
+ $port = getservbyname('time', 'udp');
+ $sin = sockaddr_in($port, $iaddr);
+ send(Socket_Handle, 0, 0, $sin);
+
+ $proto = getprotobyname('tcp');
+ socket(Socket_Handle, PF_INET, SOCK_STREAM, $proto);
+ $port = getservbyname('smtp', 'tcp');
+ $sin = sockaddr_in($port,inet_aton("127.1"));
+ $sin = sockaddr_in(7,inet_aton("localhost"));
+ $sin = sockaddr_in(7,INADDR_LOOPBACK);
+ connect(Socket_Handle,$sin);
+
+ ($port, $iaddr) = sockaddr_in(getpeername(Socket_Handle));
+ $peer_host = gethostbyaddr($iaddr, AF_INET);
+ $peer_addr = inet_ntoa($iaddr);
+
+ $proto = getprotobyname('tcp');
+ socket(Socket_Handle, PF_UNIX, SOCK_STREAM, $proto);
+ unlink('/tmp/usock');
+ $sun = sockaddr_un('/tmp/usock');
+ connect(Socket_Handle,$sun);
+
+=head1 DESCRIPTION
+
+This module is just a translation of the C F<socket.h> file.
+Unlike the old mechanism of requiring a translated F<socket.ph>
+file, this uses the B<h2xs> program (see the Perl source distribution)
+and your native C compiler. This means that it has a
+far more likely chance of getting the numbers right. This includes
+all of the commonly used pound-defines like AF_INET, SOCK_STREAM, etc.
+
+Also, some common socket "newline" constants are provided: the
+constants C<CR>, C<LF>, and C<CRLF>, as well as C<$CR>, C<$LF>, and
+C<$CRLF>, which map to C<\015>, C<\012>, and C<\015\012>. If you do
+not want to use the literal characters in your programs, then use
+the constants provided here. They are not exported by default, but can
+be imported individually, and with the C<:crlf> export tag:
+
+ use Socket qw(:DEFAULT :crlf);
+
+In addition, some structure manipulation functions are available:
+
+=over
+
+=item inet_aton HOSTNAME
+
+Takes a string giving the name of a host, and translates that
+to the 4-byte string (structure). Takes arguments of both
+the 'rtfm.mit.edu' type and '18.181.0.24'. If the host name
+cannot be resolved, returns undef. For multi-homed hosts (hosts
+with more than one address), the first address found is returned.
+
+=item inet_ntoa IP_ADDRESS
+
+Takes a four byte ip address (as returned by inet_aton())
+and translates it into a string of the form 'd.d.d.d'
+where the 'd's are numbers less than 256 (the normal
+readable four dotted number notation for internet addresses).
+
+=item INADDR_ANY
+
+Note: does not return a number, but a packed string.
+
+Returns the 4-byte wildcard ip address which specifies any
+of the hosts ip addresses. (A particular machine can have
+more than one ip address, each address corresponding to
+a particular network interface. This wildcard address
+allows you to bind to all of them simultaneously.)
+Normally equivalent to inet_aton('0.0.0.0').
+
+=item INADDR_BROADCAST
+
+Note: does not return a number, but a packed string.
+
+Returns the 4-byte 'this-lan' ip broadcast address.
+This can be useful for some protocols to solicit information
+from all servers on the same LAN cable.
+Normally equivalent to inet_aton('255.255.255.255').
+
+=item INADDR_LOOPBACK
+
+Note - does not return a number.
+
+Returns the 4-byte loopback address. Normally equivalent
+to inet_aton('localhost').
+
+=item INADDR_NONE
+
+Note - does not return a number.
+
+Returns the 4-byte 'invalid' ip address. Normally equivalent
+to inet_aton('255.255.255.255').
+
+=item sockaddr_in PORT, ADDRESS
+
+=item sockaddr_in SOCKADDR_IN
+
+In an array context, unpacks its SOCKADDR_IN argument and returns an array
+consisting of (PORT, ADDRESS). In a scalar context, packs its (PORT,
+ADDRESS) arguments as a SOCKADDR_IN and returns it. If this is confusing,
+use pack_sockaddr_in() and unpack_sockaddr_in() explicitly.
+
+=item pack_sockaddr_in PORT, IP_ADDRESS
+
+Takes two arguments, a port number and a 4 byte IP_ADDRESS (as returned by
+inet_aton()). Returns the sockaddr_in structure with those arguments
+packed in with AF_INET filled in. For internet domain sockets, this
+structure is normally what you need for the arguments in bind(),
+connect(), and send(), and is also returned by getpeername(),
+getsockname() and recv().
+
+=item unpack_sockaddr_in SOCKADDR_IN
+
+Takes a sockaddr_in structure (as returned by pack_sockaddr_in()) and
+returns an array of two elements: the port and the 4-byte ip-address.
+Will croak if the structure does not have AF_INET in the right place.
+
+=item sockaddr_un PATHNAME
+
+=item sockaddr_un SOCKADDR_UN
+
+In an array context, unpacks its SOCKADDR_UN argument and returns an array
+consisting of (PATHNAME). In a scalar context, packs its PATHNAME
+arguments as a SOCKADDR_UN and returns it. If this is confusing, use
+pack_sockaddr_un() and unpack_sockaddr_un() explicitly.
+These are only supported if your system has E<lt>F<sys/un.h>E<gt>.
+
+=item pack_sockaddr_un PATH
+
+Takes one argument, a pathname. Returns the sockaddr_un structure with
+that path packed in with AF_UNIX filled in. For unix domain sockets, this
+structure is normally what you need for the arguments in bind(),
+connect(), and send(), and is also returned by getpeername(),
+getsockname() and recv().
+
+=item unpack_sockaddr_un SOCKADDR_UN
+
+Takes a sockaddr_un structure (as returned by pack_sockaddr_un())
+and returns the pathname. Will croak if the structure does not
+have AF_UNIX in the right place.
+
+=back
+
+=cut
+
+use Carp;
+
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw(
+ inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in
+ pack_sockaddr_un unpack_sockaddr_un
+ sockaddr_in sockaddr_un
+ INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
+ AF_802
+ AF_APPLETALK
+ AF_CCITT
+ AF_CHAOS
+ AF_DATAKIT
+ AF_DECnet
+ AF_DLI
+ AF_ECMA
+ AF_GOSIP
+ AF_HYLINK
+ AF_IMPLINK
+ AF_INET
+ AF_LAT
+ AF_MAX
+ AF_NBS
+ AF_NIT
+ AF_NS
+ AF_OSI
+ AF_OSINET
+ AF_PUP
+ AF_SNA
+ AF_UNIX
+ AF_UNSPEC
+ AF_X25
+ MSG_DONTROUTE
+ MSG_MAXIOVLEN
+ MSG_OOB
+ MSG_PEEK
+ PF_802
+ PF_APPLETALK
+ PF_CCITT
+ PF_CHAOS
+ PF_DATAKIT
+ PF_DECnet
+ PF_DLI
+ PF_ECMA
+ PF_GOSIP
+ PF_HYLINK
+ PF_IMPLINK
+ PF_INET
+ PF_LAT
+ PF_MAX
+ PF_NBS
+ PF_NIT
+ PF_NS
+ PF_OSI
+ PF_OSINET
+ PF_PUP
+ PF_SNA
+ PF_UNIX
+ PF_UNSPEC
+ PF_X25
+ SOCK_DGRAM
+ SOCK_RAW
+ SOCK_RDM
+ SOCK_SEQPACKET
+ SOCK_STREAM
+ SOL_SOCKET
+ SOMAXCONN
+ SO_ACCEPTCONN
+ SO_BROADCAST
+ SO_DEBUG
+ SO_DONTLINGER
+ SO_DONTROUTE
+ SO_ERROR
+ SO_KEEPALIVE
+ SO_LINGER
+ SO_OOBINLINE
+ SO_RCVBUF
+ SO_RCVLOWAT
+ SO_RCVTIMEO
+ SO_REUSEADDR
+ SO_SNDBUF
+ SO_SNDLOWAT
+ SO_SNDTIMEO
+ SO_TYPE
+ SO_USELOOPBACK
+);
+
+@EXPORT_OK = qw(CR LF CRLF $CR $LF $CRLF);
+
+%EXPORT_TAGS = (
+ crlf => [qw(CR LF CRLF $CR $LF $CRLF)],
+ all => [@EXPORT, @EXPORT_OK],
+);
+
+BEGIN {
+ sub CR () {"\015"}
+ sub LF () {"\012"}
+ sub CRLF () {"\015\012"}
+}
+
+*CR = \CR();
+*LF = \LF();
+*CRLF = \CRLF();
+
+sub sockaddr_in {
+ if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die
+ my($af, $port, @quad) = @_;
+ carp "6-ARG sockaddr_in call is deprecated" if $^W;
+ pack_sockaddr_in($port, inet_aton(join('.', @quad)));
+ } elsif (wantarray) {
+ croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1;
+ unpack_sockaddr_in(@_);
+ } else {
+ croak "usage: sin_sv = sockaddr_in(port,iaddr))" unless @_ == 2;
+ pack_sockaddr_in(@_);
+ }
+}
+
+sub sockaddr_un {
+ if (wantarray) {
+ croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1;
+ unpack_sockaddr_un(@_);
+ } else {
+ croak "usage: sun_sv = sockaddr_un(filename)" unless @_ == 1;
+ pack_sockaddr_un(@_);
+ }
+}
+
+
+sub AUTOLOAD {
+ my($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ my ($pack,$file,$line) = caller;
+ croak "Your vendor has not defined Socket macro $constname, used";
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+bootstrap Socket $VERSION;
+
+1;
diff --git a/contrib/perl5/ext/Socket/Socket.xs b/contrib/perl5/ext/Socket/Socket.xs
new file mode 100644
index 000000000000..de0217bdb4da
--- /dev/null
+++ b/contrib/perl5/ext/Socket/Socket.xs
@@ -0,0 +1,890 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifndef VMS
+# ifdef I_SYS_TYPES
+# include <sys/types.h>
+# endif
+#include <sys/socket.h>
+#ifdef MPE
+# define PF_INET AF_INET
+# define PF_UNIX AF_UNIX
+# define SOCK_RAW 3
+#endif
+#ifdef I_SYS_UN
+#include <sys/un.h>
+#endif
+# ifdef I_NETINET_IN
+# include <netinet/in.h>
+# endif
+#include <netdb.h>
+#ifdef I_ARPA_INET
+# include <arpa/inet.h>
+#endif
+#else
+#include "sockadapt.h"
+#endif
+
+#ifndef AF_NBS
+#undef PF_NBS
+#endif
+
+#ifndef AF_X25
+#undef PF_X25
+#endif
+
+#ifndef INADDR_NONE
+#define INADDR_NONE 0xffffffff
+#endif /* INADDR_NONE */
+#ifndef INADDR_BROADCAST
+#define INADDR_BROADCAST 0xffffffff
+#endif /* INADDR_BROADCAST */
+#ifndef INADDR_LOOPBACK
+#define INADDR_LOOPBACK 0x7F000001
+#endif /* INADDR_LOOPBACK */
+
+#ifndef HAS_INET_ATON
+
+/*
+ * Check whether "cp" is a valid ascii representation
+ * of an Internet address and convert to a binary address.
+ * Returns 1 if the address is valid, 0 if not.
+ * This replaces inet_addr, the return value from which
+ * cannot distinguish between failure and a local broadcast address.
+ */
+static int
+my_inet_aton(register const char *cp, struct in_addr *addr)
+{
+ register U32 val;
+ register int base;
+ register char c;
+ int nparts;
+ const char *s;
+ unsigned int parts[4];
+ register unsigned int *pp = parts;
+
+ if (!cp)
+ return 0;
+ for (;;) {
+ /*
+ * Collect number up to ``.''.
+ * Values are specified as for C:
+ * 0x=hex, 0=octal, other=decimal.
+ */
+ val = 0; base = 10;
+ if (*cp == '0') {
+ if (*++cp == 'x' || *cp == 'X')
+ base = 16, cp++;
+ else
+ base = 8;
+ }
+ while ((c = *cp) != '\0') {
+ if (isDIGIT(c)) {
+ val = (val * base) + (c - '0');
+ cp++;
+ continue;
+ }
+ if (base == 16 && (s=strchr(PL_hexdigit,c))) {
+ val = (val << 4) +
+ ((s - PL_hexdigit) & 15);
+ cp++;
+ continue;
+ }
+ break;
+ }
+ if (*cp == '.') {
+ /*
+ * Internet format:
+ * a.b.c.d
+ * a.b.c (with c treated as 16-bits)
+ * a.b (with b treated as 24 bits)
+ */
+ if (pp >= parts + 3 || val > 0xff)
+ return 0;
+ *pp++ = val, cp++;
+ } else
+ break;
+ }
+ /*
+ * Check for trailing characters.
+ */
+ if (*cp && !isSPACE(*cp))
+ return 0;
+ /*
+ * Concoct the address according to
+ * the number of parts specified.
+ */
+ nparts = pp - parts + 1; /* force to an int for switch() */
+ switch (nparts) {
+
+ case 1: /* a -- 32 bits */
+ break;
+
+ case 2: /* a.b -- 8.24 bits */
+ if (val > 0xffffff)
+ return 0;
+ val |= parts[0] << 24;
+ break;
+
+ case 3: /* a.b.c -- 8.8.16 bits */
+ if (val > 0xffff)
+ return 0;
+ val |= (parts[0] << 24) | (parts[1] << 16);
+ break;
+
+ case 4: /* a.b.c.d -- 8.8.8.8 bits */
+ if (val > 0xff)
+ return 0;
+ val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8);
+ break;
+ }
+ addr->s_addr = htonl(val);
+ return 1;
+}
+
+#undef inet_aton
+#define inet_aton my_inet_aton
+
+#endif /* ! HAS_INET_ATON */
+
+
+static int
+not_here(char *s)
+{
+ croak("Socket::%s not implemented on this architecture", s);
+ return -1;
+}
+
+static double
+constant(char *name, int arg)
+{
+ errno = 0;
+ switch (*name) {
+ case 'A':
+ if (strEQ(name, "AF_802"))
+#ifdef AF_802
+ return AF_802;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_APPLETALK"))
+#ifdef AF_APPLETALK
+ return AF_APPLETALK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_CCITT"))
+#ifdef AF_CCITT
+ return AF_CCITT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_CHAOS"))
+#ifdef AF_CHAOS
+ return AF_CHAOS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_DATAKIT"))
+#ifdef AF_DATAKIT
+ return AF_DATAKIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_DECnet"))
+#ifdef AF_DECnet
+ return AF_DECnet;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_DLI"))
+#ifdef AF_DLI
+ return AF_DLI;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_ECMA"))
+#ifdef AF_ECMA
+ return AF_ECMA;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_GOSIP"))
+#ifdef AF_GOSIP
+ return AF_GOSIP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_HYLINK"))
+#ifdef AF_HYLINK
+ return AF_HYLINK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_IMPLINK"))
+#ifdef AF_IMPLINK
+ return AF_IMPLINK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_INET"))
+#ifdef AF_INET
+ return AF_INET;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_LAT"))
+#ifdef AF_LAT
+ return AF_LAT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_MAX"))
+#ifdef AF_MAX
+ return AF_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_NBS"))
+#ifdef AF_NBS
+ return AF_NBS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_NIT"))
+#ifdef AF_NIT
+ return AF_NIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_NS"))
+#ifdef AF_NS
+ return AF_NS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_OSI"))
+#ifdef AF_OSI
+ return AF_OSI;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_OSINET"))
+#ifdef AF_OSINET
+ return AF_OSINET;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_PUP"))
+#ifdef AF_PUP
+ return AF_PUP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_SNA"))
+#ifdef AF_SNA
+ return AF_SNA;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_UNIX"))
+#ifdef AF_UNIX
+ return AF_UNIX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_UNSPEC"))
+#ifdef AF_UNSPEC
+ return AF_UNSPEC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "AF_X25"))
+#ifdef AF_X25
+ return AF_X25;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'B':
+ break;
+ case 'C':
+ break;
+ case 'D':
+ break;
+ case 'E':
+ break;
+ case 'F':
+ break;
+ case 'G':
+ break;
+ case 'H':
+ break;
+ case 'I':
+ break;
+ case 'J':
+ break;
+ case 'K':
+ break;
+ case 'L':
+ break;
+ case 'M':
+ if (strEQ(name, "MSG_CTRUNC"))
+#if defined(MSG_CTRUNC) || defined(HAS_GNULIBC) /* XXX it's an enum */
+ return MSG_CTRUNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_DONTROUTE"))
+#if defined(MSG_DONTROUTE) || defined(HAS_GNULIBC) /* XXX it's an enum */
+ return MSG_DONTROUTE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_MAXIOVLEN"))
+#ifdef MSG_MAXIOVLEN
+ return MSG_MAXIOVLEN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_OOB"))
+#if defined(MSG_OOB) || defined(HAS_GNULIBC) /* XXX it's an enum */
+ return MSG_OOB;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_PEEK"))
+#if defined(MSG_PEEK) || defined(HAS_GNULIBC) /* XXX it's an enum */
+ return MSG_PEEK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "MSG_PROXY"))
+#if defined(MSG_PROXY) || defined(HAS_GNULIBC) /* XXX it's an enum */
+ return MSG_PROXY;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'N':
+ break;
+ case 'O':
+ break;
+ case 'P':
+ if (strEQ(name, "PF_802"))
+#ifdef PF_802
+ return PF_802;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_APPLETALK"))
+#ifdef PF_APPLETALK
+ return PF_APPLETALK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_CCITT"))
+#ifdef PF_CCITT
+ return PF_CCITT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_CHAOS"))
+#ifdef PF_CHAOS
+ return PF_CHAOS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_DATAKIT"))
+#ifdef PF_DATAKIT
+ return PF_DATAKIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_DECnet"))
+#ifdef PF_DECnet
+ return PF_DECnet;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_DLI"))
+#ifdef PF_DLI
+ return PF_DLI;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_ECMA"))
+#ifdef PF_ECMA
+ return PF_ECMA;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_GOSIP"))
+#ifdef PF_GOSIP
+ return PF_GOSIP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_HYLINK"))
+#ifdef PF_HYLINK
+ return PF_HYLINK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_IMPLINK"))
+#ifdef PF_IMPLINK
+ return PF_IMPLINK;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_INET"))
+#ifdef PF_INET
+ return PF_INET;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_LAT"))
+#ifdef PF_LAT
+ return PF_LAT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_MAX"))
+#ifdef PF_MAX
+ return PF_MAX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_NBS"))
+#ifdef PF_NBS
+ return PF_NBS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_NIT"))
+#ifdef PF_NIT
+ return PF_NIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_NS"))
+#ifdef PF_NS
+ return PF_NS;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_OSI"))
+#ifdef PF_OSI
+ return PF_OSI;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_OSINET"))
+#ifdef PF_OSINET
+ return PF_OSINET;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_PUP"))
+#ifdef PF_PUP
+ return PF_PUP;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_SNA"))
+#ifdef PF_SNA
+ return PF_SNA;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_UNIX"))
+#ifdef PF_UNIX
+ return PF_UNIX;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_UNSPEC"))
+#ifdef PF_UNSPEC
+ return PF_UNSPEC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "PF_X25"))
+#ifdef PF_X25
+ return PF_X25;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'Q':
+ break;
+ case 'R':
+ break;
+ case 'S':
+ if (strEQ(name, "SOCK_DGRAM"))
+#ifdef SOCK_DGRAM
+ return SOCK_DGRAM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SOCK_RAW"))
+#ifdef SOCK_RAW
+ return SOCK_RAW;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SOCK_RDM"))
+#ifdef SOCK_RDM
+ return SOCK_RDM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SOCK_SEQPACKET"))
+#ifdef SOCK_SEQPACKET
+ return SOCK_SEQPACKET;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SOCK_STREAM"))
+#ifdef SOCK_STREAM
+ return SOCK_STREAM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SOL_SOCKET"))
+#ifdef SOL_SOCKET
+ return SOL_SOCKET;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SOMAXCONN"))
+#ifdef SOMAXCONN
+ return SOMAXCONN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_ACCEPTCONN"))
+#ifdef SO_ACCEPTCONN
+ return SO_ACCEPTCONN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_BROADCAST"))
+#ifdef SO_BROADCAST
+ return SO_BROADCAST;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_DEBUG"))
+#ifdef SO_DEBUG
+ return SO_DEBUG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_DONTLINGER"))
+#ifdef SO_DONTLINGER
+ return SO_DONTLINGER;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_DONTROUTE"))
+#ifdef SO_DONTROUTE
+ return SO_DONTROUTE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_ERROR"))
+#ifdef SO_ERROR
+ return SO_ERROR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_KEEPALIVE"))
+#ifdef SO_KEEPALIVE
+ return SO_KEEPALIVE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_LINGER"))
+#ifdef SO_LINGER
+ return SO_LINGER;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_OOBINLINE"))
+#ifdef SO_OOBINLINE
+ return SO_OOBINLINE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_RCVBUF"))
+#ifdef SO_RCVBUF
+ return SO_RCVBUF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_RCVLOWAT"))
+#ifdef SO_RCVLOWAT
+ return SO_RCVLOWAT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_RCVTIMEO"))
+#ifdef SO_RCVTIMEO
+ return SO_RCVTIMEO;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_REUSEADDR"))
+#ifdef SO_REUSEADDR
+ return SO_REUSEADDR;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_REUSEPORT"))
+#ifdef SO_REUSEPORT
+ return SO_REUSEPORT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_SNDBUF"))
+#ifdef SO_SNDBUF
+ return SO_SNDBUF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_SNDLOWAT"))
+#ifdef SO_SNDLOWAT
+ return SO_SNDLOWAT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_SNDTIMEO"))
+#ifdef SO_SNDTIMEO
+ return SO_SNDTIMEO;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_TYPE"))
+#ifdef SO_TYPE
+ return SO_TYPE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "SO_USELOOPBACK"))
+#ifdef SO_USELOOPBACK
+ return SO_USELOOPBACK;
+#else
+ goto not_there;
+#endif
+ break;
+ case 'T':
+ break;
+ case 'U':
+ break;
+ case 'V':
+ break;
+ case 'W':
+ break;
+ case 'X':
+ break;
+ case 'Y':
+ break;
+ case 'Z':
+ break;
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+
+MODULE = Socket PACKAGE = Socket
+
+double
+constant(name,arg)
+ char * name
+ int arg
+
+
+void
+inet_aton(host)
+ char * host
+ CODE:
+ {
+ struct in_addr ip_address;
+ struct hostent * phe;
+ int ok = inet_aton(host, &ip_address);
+
+ if (!ok && (phe = gethostbyname(host))) {
+ Copy( phe->h_addr, &ip_address, phe->h_length, char );
+ ok = 1;
+ }
+
+ ST(0) = sv_newmortal();
+ if (ok) {
+ sv_setpvn( ST(0), (char *)&ip_address, sizeof ip_address );
+ }
+ }
+
+void
+inet_ntoa(ip_address_sv)
+ SV * ip_address_sv
+ CODE:
+ {
+ STRLEN addrlen;
+ struct in_addr addr;
+ char * addr_str;
+ char * ip_address = SvPV(ip_address_sv,addrlen);
+ if (addrlen != sizeof(addr)) {
+ croak("Bad arg length for %s, length is %d, should be %d",
+ "Socket::inet_ntoa",
+ addrlen, sizeof(addr));
+ }
+
+ Copy( ip_address, &addr, sizeof addr, char );
+ addr_str = inet_ntoa(addr);
+
+ ST(0) = sv_2mortal(newSVpv(addr_str, strlen(addr_str)));
+ }
+
+void
+pack_sockaddr_un(pathname)
+ char * pathname
+ CODE:
+ {
+#ifdef I_SYS_UN
+ struct sockaddr_un sun_ad; /* fear using sun */
+ STRLEN len;
+ Zero( &sun_ad, sizeof sun_ad, char );
+ sun_ad.sun_family = AF_UNIX;
+ len = strlen(pathname);
+ if (len > sizeof(sun_ad.sun_path))
+ len = sizeof(sun_ad.sun_path);
+ Copy( pathname, sun_ad.sun_path, len, char );
+ ST(0) = sv_2mortal(newSVpv((char *)&sun_ad, sizeof sun_ad));
+#else
+ ST(0) = (SV *) not_here("pack_sockaddr_un");
+#endif
+
+ }
+
+void
+unpack_sockaddr_un(sun_sv)
+ SV * sun_sv
+ CODE:
+ {
+#ifdef I_SYS_UN
+ struct sockaddr_un addr;
+ STRLEN sockaddrlen;
+ char * sun_ad = SvPV(sun_sv,sockaddrlen);
+ char * e;
+
+ if (sockaddrlen != sizeof(addr)) {
+ croak("Bad arg length for %s, length is %d, should be %d",
+ "Socket::unpack_sockaddr_un",
+ sockaddrlen, sizeof(addr));
+ }
+
+ Copy( sun_ad, &addr, sizeof addr, char );
+
+ if ( addr.sun_family != AF_UNIX ) {
+ croak("Bad address family for %s, got %d, should be %d",
+ "Socket::unpack_sockaddr_un",
+ addr.sun_family,
+ AF_UNIX);
+ }
+ e = addr.sun_path;
+ while (*e && e < addr.sun_path + sizeof addr.sun_path)
+ ++e;
+ ST(0) = sv_2mortal(newSVpv(addr.sun_path, e - addr.sun_path));
+#else
+ ST(0) = (SV *) not_here("unpack_sockaddr_un");
+#endif
+ }
+
+void
+pack_sockaddr_in(port,ip_address)
+ unsigned short port
+ char * ip_address
+ CODE:
+ {
+ struct sockaddr_in sin;
+
+ Zero( &sin, sizeof sin, char );
+ sin.sin_family = AF_INET;
+ sin.sin_port = htons(port);
+ Copy( ip_address, &sin.sin_addr, sizeof sin.sin_addr, char );
+
+ ST(0) = sv_2mortal(newSVpv((char *)&sin, sizeof sin));
+ }
+
+void
+unpack_sockaddr_in(sin_sv)
+ SV * sin_sv
+ PPCODE:
+ {
+ STRLEN sockaddrlen;
+ struct sockaddr_in addr;
+ unsigned short port;
+ struct in_addr ip_address;
+ char * sin = SvPV(sin_sv,sockaddrlen);
+ if (sockaddrlen != sizeof(addr)) {
+ croak("Bad arg length for %s, length is %d, should be %d",
+ "Socket::unpack_sockaddr_in",
+ sockaddrlen, sizeof(addr));
+ }
+ Copy( sin, &addr,sizeof addr, char );
+ if ( addr.sin_family != AF_INET ) {
+ croak("Bad address family for %s, got %d, should be %d",
+ "Socket::unpack_sockaddr_in",
+ addr.sin_family,
+ AF_INET);
+ }
+ port = ntohs(addr.sin_port);
+ ip_address = addr.sin_addr;
+
+ EXTEND(SP, 2);
+ PUSHs(sv_2mortal(newSViv((IV) port)));
+ PUSHs(sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)));
+ }
+
+void
+INADDR_ANY()
+ CODE:
+ {
+ struct in_addr ip_address;
+ ip_address.s_addr = htonl(INADDR_ANY);
+ ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address ));
+ }
+
+void
+INADDR_LOOPBACK()
+ CODE:
+ {
+ struct in_addr ip_address;
+ ip_address.s_addr = htonl(INADDR_LOOPBACK);
+ ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address));
+ }
+
+void
+INADDR_NONE()
+ CODE:
+ {
+ struct in_addr ip_address;
+ ip_address.s_addr = htonl(INADDR_NONE);
+ ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address));
+ }
+
+void
+INADDR_BROADCAST()
+ CODE:
+ {
+ struct in_addr ip_address;
+ ip_address.s_addr = htonl(INADDR_BROADCAST);
+ ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address));
+ }
diff --git a/contrib/perl5/ext/Thread/Makefile.PL b/contrib/perl5/ext/Thread/Makefile.PL
new file mode 100644
index 000000000000..e252d4e6c384
--- /dev/null
+++ b/contrib/perl5/ext/Thread/Makefile.PL
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Thread',
+ VERSION_FROM => 'Thread.pm',
+ MAN3PODS => ' '
+ );
+
diff --git a/contrib/perl5/ext/Thread/Notes b/contrib/perl5/ext/Thread/Notes
new file mode 100644
index 000000000000..1505877ee9d4
--- /dev/null
+++ b/contrib/perl5/ext/Thread/Notes
@@ -0,0 +1,13 @@
+Should cvcache be per CV (keyed by thread) or per thread (keyed by CV)?
+
+Maybe ought to protect all SVs by a mutex for SvREFCNT_{dec,inc},
+upgrades and so on. Then use SvMUTEX instead of CvMUTEX for CVs.
+On the other hand, people shouldn't expect concurrent operations
+on non-lexicals to be safe anyway.
+
+Probably don't need to bother keeping track of CvOWNER on clones.
+
+Either @_ needs to be made lexical or other arrangments need to be
+made so that some globs (or just *_) are per-thread.
+
+tokenbuf and buf probably ought to be global protected by a global lock.
diff --git a/contrib/perl5/ext/Thread/README b/contrib/perl5/ext/Thread/README
new file mode 100644
index 000000000000..a6b22fb4ae68
--- /dev/null
+++ b/contrib/perl5/ext/Thread/README
@@ -0,0 +1,20 @@
+See the README.threads in the main perl 5.004_xx development
+distribution (x >= 50) for details of how to build and use this.
+If all else fails, read on.
+
+If your version of patch can't create a file from scratch, then you'll
+need to create an empty thread.h manually first. Perl itself will need
+to be built with -DUSE_THREADS yet. If you're using MIT pthreads or
+another threads package that needs pthread_init() to be called, then
+add -DNEED_PTHREAD_INIT. If you're using a threads library that only
+follows one of the old POSIX drafts, then you'll probably need to add
+-DOLD_PTHREADS_API. I haven't tested -DOLD_PTHREADS_API properly yet
+and I think you may still have to tweak a couple of the mutex calls
+to follow the old API.
+
+This extension is copyright Malcolm Beattie 1995-1997 and is freely
+distributable under your choice of the GNU Public License or the
+Artistic License (see the main perl distribution).
+
+Malcolm Beattie
+mbeattie@sable.ox.ac.uk
diff --git a/contrib/perl5/ext/Thread/Thread.pm b/contrib/perl5/ext/Thread/Thread.pm
new file mode 100644
index 000000000000..c8bca0db7136
--- /dev/null
+++ b/contrib/perl5/ext/Thread/Thread.pm
@@ -0,0 +1,185 @@
+package Thread;
+require Exporter;
+require DynaLoader;
+use vars qw($VERSION @ISA @EXPORT);
+
+$VERSION = "1.0";
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT_OK = qw(yield cond_signal cond_broadcast cond_wait async);
+
+=head1 NAME
+
+Thread - multithreading
+
+=head1 SYNOPSIS
+
+ use Thread;
+
+ my $t = new Thread \&start_sub, @start_args;
+
+ $t->join;
+
+ my $tid = Thread->self->tid;
+
+ my $tlist = Thread->list;
+
+ lock($scalar);
+
+ use Thread 'async';
+
+ use Thread 'eval';
+
+=head1 DESCRIPTION
+
+The C<Thread> module provides multithreading support for perl.
+
+=head1 FUNCTIONS
+
+=over 8
+
+=item new \&start_sub
+
+=item new \&start_sub, LIST
+
+C<new> starts a new thread of execution in the referenced subroutine. The
+optional list is passed as parameters to the subroutine. Execution
+continues in both the subroutine and the code after the C<new> call.
+
+C<new Thread> returns a thread object representing the newly created
+thread.
+
+=item lock VARIABLE
+
+C<lock> places a lock on a variable until the lock goes out of scope. If
+the variable is locked by another thread, the C<lock> call will block until
+it's available. C<lock> is recursive, so multiple calls to C<lock> are
+safe--the variable will remain locked until the outermost lock on the
+variable goes out of scope.
+
+Locks on variables only affect C<lock> calls--they do I<not> affect normal
+access to a variable. (Locks on subs are different, and covered in a bit)
+If you really, I<really> want locks to block access, then go ahead and tie
+them to something and manage this yourself. This is done on purpose. While
+managing access to variables is a good thing, perl doesn't force you out of
+its living room...
+
+If a container object, such as a hash or array, is locked, all the elements
+of that container are not locked. For example, if a thread does a C<lock
+@a>, any other thread doing a C<lock($a[12])> won't block.
+
+You may also C<lock> a sub, using C<lock &sub>. Any calls to that sub from
+another thread will block until the lock is released. This behaviour is not
+equvalent to C<use attrs qw(locked)> in the sub. C<use attrs qw(locked)>
+serializes access to a subroutine, but allows different threads
+non-simultaneous access. C<lock &sub>, on the other hand, will not allow
+I<any> other thread access for the duration of the lock.
+
+Finally, C<lock> will traverse up references exactly I<one> level.
+C<lock(\$a)> is equivalent to C<lock($a)>, while C<lock(\\$a)> is not.
+
+=item async BLOCK;
+
+C<async> creates a thread to execute the block immediately following
+it. This block is treated as an anonymous sub, and so must have a
+semi-colon after the closing brace. Like C<new Thread>, C<async> returns a
+thread object.
+
+=item Thread->self
+
+The C<Thread-E<gt>self> function returns a thread object that represents
+the thread making the C<Thread-E<gt>self> call.
+
+=item Thread->list
+
+C<Thread-E<gt>list> returns a list of thread objects for all running and
+finished but un-C<join>ed threads.
+
+=item cond_wait VARIABLE
+
+The C<cond_wait> function takes a B<locked> variable as a parameter,
+unlocks the variable, and blocks until another thread does a C<cond_signal>
+or C<cond_broadcast> for that same locked variable. The variable that
+C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied.
+If there are multiple threads C<cond_wait>ing on the same variable, all but
+one will reblock waiting to reaquire the lock on the variable. (So if
+you're only using C<cond_wait> for synchronization, give up the lock as
+soon as possible)
+
+=item cond_signal VARIABLE
+
+The C<cond_signal> function takes a locked variable as a parameter and
+unblocks one thread that's C<cond_wait>ing on that variable. If more than
+one thread is blocked in a C<cond_wait> on that variable, only one (and
+which one is indeterminate) will be unblocked.
+
+If there are no threads blocked in a C<cond_wait> on the variable, the
+signal is discarded.
+
+=item cond_broadcast VARIABLE
+
+The C<cond_broadcast> function works similarly to C<cond_wait>.
+C<cond_broadcast>, though, will unblock B<all> the threads that are blocked
+in a C<cond_wait> on the locked variable, rather than only one.
+
+=back
+
+=head1 METHODS
+
+=over 8
+
+=item join
+
+C<join> waits for a thread to end and returns any values the thread exited
+with. C<join> will block until the thread has ended, though it won't block
+if the thread has already terminated.
+
+If the thread being C<join>ed C<die>d, the error it died with will be
+returned at this time. If you don't want the thread performing the C<join>
+to die as well, you should either wrap the C<join> in an C<eval> or use the
+C<eval> thread method instead of C<join>.
+
+=item eval
+
+The C<eval> method wraps an C<eval> around a C<join>, and so waits for a
+thread to exit, passing along any values the thread might have returned.
+Errors, of course, get placed into C<$@>.
+
+=item tid
+
+The C<tid> method returns the tid of a thread. The tid is a monotonically
+increasing integer assigned when a thread is created. The main thread of a
+program will have a tid of zero, while subsequent threads will have tids
+assigned starting with one.
+
+=head1 LIMITATIONS
+
+The sequence number used to assign tids is a simple integer, and no
+checking is done to make sure the tid isn't currently in use. If a program
+creates more than 2^32 - 1 threads in a single run, threads may be assigned
+duplicate tids. This limitation may be lifted in a future version of Perl.
+
+=head1 SEE ALSO
+
+L<attrs>, L<Thread::Queue>, L<Thread::Semaphore>, L<Thread::Specific>.
+
+=cut
+
+#
+# Methods
+#
+
+#
+# Exported functions
+#
+sub async (&) {
+ return new Thread $_[0];
+}
+
+sub eval {
+ return eval { shift->join; };
+}
+
+bootstrap Thread;
+
+1;
diff --git a/contrib/perl5/ext/Thread/Thread.xs b/contrib/perl5/ext/Thread/Thread.xs
new file mode 100644
index 000000000000..48f8aa03fc78
--- /dev/null
+++ b/contrib/perl5/ext/Thread/Thread.xs
@@ -0,0 +1,641 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* Magic signature for Thread's mg_private is "Th" */
+#define Thread_MAGIC_SIGNATURE 0x5468
+
+#ifdef __cplusplus
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+#endif
+#include <fcntl.h>
+
+static int sig_pipe[2];
+
+#ifndef THREAD_RET_TYPE
+#define THREAD_RET_TYPE void *
+#define THREAD_RET_CAST(x) ((THREAD_RET_TYPE) x)
+#endif
+
+static void
+remove_thread(struct perl_thread *t)
+{
+#ifdef USE_THREADS
+ DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(),
+ "%p: remove_thread %p\n", thr, t)));
+ MUTEX_LOCK(&PL_threads_mutex);
+ MUTEX_DESTROY(&t->mutex);
+ PL_nthreads--;
+ t->prev->next = t->next;
+ t->next->prev = t->prev;
+ COND_BROADCAST(&PL_nthreads_cond);
+ MUTEX_UNLOCK(&PL_threads_mutex);
+#endif
+}
+
+static THREAD_RET_TYPE
+threadstart(void *arg)
+{
+#ifdef USE_THREADS
+#ifdef FAKE_THREADS
+ Thread savethread = thr;
+ LOGOP myop;
+ dSP;
+ I32 oldscope = PL_scopestack_ix;
+ I32 retval;
+ AV *av;
+ int i;
+
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
+ thr, SvPEEK(TOPs)));
+ thr = (Thread) arg;
+ savemark = TOPMARK;
+ thr->prev = thr->prev_run = savethread;
+ thr->next = savethread->next;
+ thr->next_run = savethread->next_run;
+ savethread->next = savethread->next_run = thr;
+ thr->wait_queue = 0;
+ thr->private = 0;
+
+ /* Now duplicate most of perl_call_sv but with a few twists */
+ PL_op = (OP*)&myop;
+ Zero(PL_op, 1, LOGOP);
+ myop.op_flags = OPf_STACKED;
+ myop.op_next = Nullop;
+ myop.op_flags |= OPf_KNOW;
+ myop.op_flags |= OPf_WANT_LIST;
+ PL_op = pp_entersub(ARGS);
+ DEBUG_S(if (!PL_op)
+ PerlIO_printf(PerlIO_stderr(), "thread starts at Nullop\n"));
+ /*
+ * When this thread is next scheduled, we start in the right
+ * place. When the thread runs off the end of the sub, perl.c
+ * handles things, using savemark to figure out how much of the
+ * stack is the return value for any join.
+ */
+ thr = savethread; /* back to the old thread */
+ return 0;
+#else
+ Thread thr = (Thread) arg;
+ LOGOP myop;
+ djSP;
+ I32 oldmark = TOPMARK;
+ I32 oldscope = PL_scopestack_ix;
+ I32 retval;
+ SV *sv;
+ AV *av = newAV();
+ int i, ret;
+ dJMPENV;
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p waiting to start\n",
+ thr));
+
+ /* Don't call *anything* requiring dTHR until after SET_THR() */
+ /*
+ * Wait until our creator releases us. If we didn't do this, then
+ * it would be potentially possible for out thread to carry on and
+ * do stuff before our creator fills in our "self" field. For example,
+ * if we went and created another thread which tried to JOIN with us,
+ * then we'd be in a mess.
+ */
+ MUTEX_LOCK(&thr->mutex);
+ MUTEX_UNLOCK(&thr->mutex);
+
+ /*
+ * It's safe to wait until now to set the thread-specific pointer
+ * from our pthread_t structure to our struct perl_thread, since
+ * we're the only thread who can get at it anyway.
+ */
+ SET_THR(thr);
+
+ /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
+ thr, SvPEEK(TOPs)));
+
+ sv = POPs;
+ PUTBACK;
+ perl_call_sv(sv, G_ARRAY|G_EVAL);
+ SPAGAIN;
+ retval = SP - (PL_stack_base + oldmark);
+ SP = PL_stack_base + oldmark + 1;
+ if (SvCUR(thr->errsv)) {
+ MUTEX_LOCK(&thr->mutex);
+ thr->flags |= THRf_DID_DIE;
+ MUTEX_UNLOCK(&thr->mutex);
+ av_store(av, 0, &PL_sv_no);
+ av_store(av, 1, newSVsv(thr->errsv));
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p died: %s\n",
+ thr, SvPV(thr->errsv, PL_na)));
+ } else {
+ DEBUG_S(STMT_START {
+ for (i = 1; i <= retval; i++) {
+ PerlIO_printf(PerlIO_stderr(), "%p return[%d] = %s\n",
+ thr, i, SvPEEK(SP[i - 1]));
+ }
+ } STMT_END);
+ av_store(av, 0, &PL_sv_yes);
+ for (i = 1; i <= retval; i++, SP++)
+ sv_setsv(*av_fetch(av, i, TRUE), SvREFCNT_inc(*SP));
+ }
+
+ finishoff:
+#if 0
+ /* removed for debug */
+ SvREFCNT_dec(PL_curstack);
+#endif
+ SvREFCNT_dec(thr->cvcache);
+ SvREFCNT_dec(thr->threadsv);
+ SvREFCNT_dec(thr->specific);
+ SvREFCNT_dec(thr->errsv);
+ SvREFCNT_dec(thr->errhv);
+
+ /*Safefree(cxstack);*/
+ while (PL_curstackinfo->si_next)
+ PL_curstackinfo = PL_curstackinfo->si_next;
+ while (PL_curstackinfo) {
+ PERL_SI *p = PL_curstackinfo->si_prev;
+ SvREFCNT_dec(PL_curstackinfo->si_stack);
+ Safefree(PL_curstackinfo->si_cxstack);
+ Safefree(PL_curstackinfo);
+ PL_curstackinfo = p;
+ }
+ Safefree(PL_markstack);
+ Safefree(PL_scopestack);
+ Safefree(PL_savestack);
+ Safefree(PL_retstack);
+ Safefree(PL_tmps_stack);
+ Safefree(PL_ofs);
+
+ SvREFCNT_dec(PL_rs);
+ SvREFCNT_dec(PL_nrs);
+ SvREFCNT_dec(PL_statname);
+ Safefree(PL_screamfirst);
+ Safefree(PL_screamnext);
+ Safefree(PL_reg_start_tmp);
+ SvREFCNT_dec(PL_lastscream);
+ /*SvREFCNT_dec(PL_defoutgv);*/
+
+ MUTEX_LOCK(&thr->mutex);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p: threadstart finishing: state is %u\n",
+ thr, ThrSTATE(thr)));
+ switch (ThrSTATE(thr)) {
+ case THRf_R_JOINABLE:
+ ThrSETSTATE(thr, THRf_ZOMBIE);
+ MUTEX_UNLOCK(&thr->mutex);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p: R_JOINABLE thread finished\n", thr));
+ break;
+ case THRf_R_JOINED:
+ ThrSETSTATE(thr, THRf_DEAD);
+ MUTEX_UNLOCK(&thr->mutex);
+ remove_thread(thr);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p: R_JOINED thread finished\n", thr));
+ break;
+ case THRf_R_DETACHED:
+ ThrSETSTATE(thr, THRf_DEAD);
+ MUTEX_UNLOCK(&thr->mutex);
+ SvREFCNT_dec(av);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p: DETACHED thread finished\n", thr));
+ remove_thread(thr); /* This might trigger main thread to finish */
+ break;
+ default:
+ MUTEX_UNLOCK(&thr->mutex);
+ croak("panic: illegal state %u at end of threadstart", ThrSTATE(thr));
+ /* NOTREACHED */
+ }
+ return THREAD_RET_CAST(av); /* Available for anyone to join with */
+ /* us unless we're detached, in which */
+ /* case noone sees the value anyway. */
+#endif
+#else
+ return THREAD_RET_CAST(NULL);
+#endif
+}
+
+static SV *
+newthread (SV *startsv, AV *initargs, char *classname)
+{
+#ifdef USE_THREADS
+ dSP;
+ Thread savethread;
+ int i;
+ SV *sv;
+ int err;
+#ifndef THREAD_CREATE
+ static pthread_attr_t attr;
+ static int attr_inited = 0;
+ sigset_t fullmask, oldmask;
+#endif
+
+ savethread = thr;
+ thr = new_struct_thread(thr);
+ SPAGAIN;
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p: newthread (%p), tid is %u, preparing stack\n",
+ savethread, thr, thr->tid));
+ /* The following pushes the arg list and startsv onto the *new* stack */
+ PUSHMARK(SP);
+ /* Could easily speed up the following greatly */
+ for (i = 0; i <= AvFILL(initargs); i++)
+ XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
+ XPUSHs(SvREFCNT_inc(startsv));
+ PUTBACK;
+#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)
+ croak("panic: sigprocmask");
+ err = 0;
+ if (!attr_inited) {
+ attr_inited = 1;
+#ifdef OLD_PTHREADS_API
+ err = pthread_attr_create(&attr);
+#else
+ err = pthread_attr_init(&attr);
+#endif
+#ifdef OLD_PTHREADS_API
+#ifdef VMS
+/* This is available with the old pthreads API, but only with */
+/* DecThreads (VMS and Digital Unix) */
+ if (err == 0)
+ err = pthread_attr_setdetach_np(&attr, ATTR_JOINABLE);
+#endif
+#else
+ if (err == 0)
+ err = pthread_attr_setdetachstate(&attr, ATTR_JOINABLE);
+#endif
+ }
+ if (err == 0)
+#ifdef OLD_PTHREADS_API
+ err = pthread_create(&thr->self, attr, threadstart, (void*) thr);
+#else
+ err = pthread_create(&thr->self, &attr, threadstart, (void*) thr);
+#endif
+ /* Go */
+ MUTEX_UNLOCK(&thr->mutex);
+#endif
+ if (err) {
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p: create of %p failed %d\n",
+ savethread, thr, err));
+ /* Thread creation failed--clean up */
+ SvREFCNT_dec(thr->cvcache);
+ remove_thread(thr);
+ MUTEX_DESTROY(&thr->mutex);
+ for (i = 0; i <= AvFILL(initargs); i++)
+ SvREFCNT_dec(*av_fetch(initargs, i, FALSE));
+ 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));
+#else
+ croak("No threads in this perl");
+ return &PL_sv_undef;
+#endif
+}
+
+static Signal_t handle_thread_signal _((int sig));
+
+static Signal_t
+handle_thread_signal(int sig)
+{
+ unsigned char c = (unsigned char) sig;
+ /*
+ * We're not really allowed to call fprintf in a signal handler
+ * so don't be surprised if this isn't robust while debugging
+ * with -DL.
+ */
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "handle_thread_signal: got signal %d\n", sig););
+ write(sig_pipe[1], &c, 1);
+}
+
+MODULE = Thread PACKAGE = Thread
+PROTOTYPES: DISABLE
+
+void
+new(classname, startsv, ...)
+ char * classname
+ SV * startsv
+ AV * av = av_make(items - 2, &ST(2));
+ PPCODE:
+ XPUSHs(sv_2mortal(newthread(startsv, av, classname)));
+
+void
+join(t)
+ Thread t
+ AV * av = NO_INIT
+ int i = NO_INIT
+ PPCODE:
+#ifdef USE_THREADS
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: joining %p (state %u)\n",
+ thr, t, ThrSTATE(t)););
+ MUTEX_LOCK(&t->mutex);
+ switch (ThrSTATE(t)) {
+ case THRf_R_JOINABLE:
+ case THRf_R_JOINED:
+ ThrSETSTATE(t, THRf_R_JOINED);
+ MUTEX_UNLOCK(&t->mutex);
+ break;
+ case THRf_ZOMBIE:
+ ThrSETSTATE(t, THRf_DEAD);
+ MUTEX_UNLOCK(&t->mutex);
+ remove_thread(t);
+ break;
+ default:
+ MUTEX_UNLOCK(&t->mutex);
+ croak("can't join with thread");
+ /* NOTREACHED */
+ }
+ JOIN(t, &av);
+
+ if (SvTRUE(*av_fetch(av, 0, FALSE))) {
+ /* Could easily speed up the following if necessary */
+ 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);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p: join propagating die message: %s\n",
+ thr, mess));
+ croak(mess);
+ }
+#endif
+
+void
+detach(t)
+ Thread t
+ CODE:
+#ifdef USE_THREADS
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: detaching %p (state %u)\n",
+ thr, t, ThrSTATE(t)););
+ MUTEX_LOCK(&t->mutex);
+ switch (ThrSTATE(t)) {
+ case THRf_R_JOINABLE:
+ ThrSETSTATE(t, THRf_R_DETACHED);
+ /* fall through */
+ case THRf_R_DETACHED:
+ DETACH(t);
+ MUTEX_UNLOCK(&t->mutex);
+ break;
+ case THRf_ZOMBIE:
+ ThrSETSTATE(t, THRf_DEAD);
+ DETACH(t);
+ MUTEX_UNLOCK(&t->mutex);
+ remove_thread(t);
+ break;
+ default:
+ MUTEX_UNLOCK(&t->mutex);
+ croak("can't detach thread");
+ /* NOTREACHED */
+ }
+#endif
+
+void
+equal(t1, t2)
+ Thread t1
+ Thread t2
+ PPCODE:
+ PUSHs((t1 == t2) ? &PL_sv_yes : &PL_sv_no);
+
+void
+flags(t)
+ Thread t
+ PPCODE:
+#ifdef USE_THREADS
+ PUSHs(sv_2mortal(newSViv(t->flags)));
+#endif
+
+void
+self(classname)
+ char * classname
+ PREINIT:
+ SV *sv;
+ PPCODE:
+#ifdef USE_THREADS
+ sv = newSViv(thr->tid);
+ sv_magic(sv, thr->oursv, '~', 0, 0);
+ SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
+ PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv),
+ gv_stashpv(classname, TRUE))));
+#endif
+
+U32
+tid(t)
+ Thread t
+ CODE:
+#ifdef USE_THREADS
+ MUTEX_LOCK(&t->mutex);
+ RETVAL = t->tid;
+ MUTEX_UNLOCK(&t->mutex);
+#else
+ RETVAL = 0;
+#endif
+ OUTPUT:
+ RETVAL
+
+void
+DESTROY(t)
+ SV * t
+ PPCODE:
+ PUSHs(&PL_sv_yes);
+
+void
+yield()
+ CODE:
+{
+#ifdef USE_THREADS
+ YIELD;
+#endif
+}
+
+void
+cond_wait(sv)
+ SV * sv
+ MAGIC * mg = NO_INIT
+CODE:
+#ifdef USE_THREADS
+ if (SvROK(sv))
+ sv = SvRV(sv);
+
+ mg = condpair_magic(sv);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_wait %p\n", thr, sv));
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) != thr) {
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ croak("cond_wait for lock that we don't own\n");
+ }
+ MgOWNER(mg) = 0;
+ COND_WAIT(MgCONDP(mg), MgMUTEXP(mg));
+ while (MgOWNER(mg))
+ COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
+ MgOWNER(mg) = thr;
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+#endif
+
+void
+cond_signal(sv)
+ SV * sv
+ MAGIC * mg = NO_INIT
+CODE:
+#ifdef USE_THREADS
+ if (SvROK(sv))
+ sv = SvRV(sv);
+
+ mg = condpair_magic(sv);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_signal %p\n",thr,sv));
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) != thr) {
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ croak("cond_signal for lock that we don't own\n");
+ }
+ COND_SIGNAL(MgCONDP(mg));
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+#endif
+
+void
+cond_broadcast(sv)
+ SV * sv
+ MAGIC * mg = NO_INIT
+CODE:
+#ifdef USE_THREADS
+ if (SvROK(sv))
+ sv = SvRV(sv);
+
+ mg = condpair_magic(sv);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_broadcast %p\n",
+ thr, sv));
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) != thr) {
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ croak("cond_broadcast for lock that we don't own\n");
+ }
+ COND_BROADCAST(MgCONDP(mg));
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+#endif
+
+void
+list(classname)
+ char * classname
+ PREINIT:
+ Thread t;
+ AV * av;
+ SV ** svp;
+ int n = 0;
+ PPCODE:
+#ifdef USE_THREADS
+ av = newAV();
+ /*
+ * Iterate until we have enough dynamic storage for all threads.
+ * We mustn't do any allocation while holding threads_mutex though.
+ */
+ MUTEX_LOCK(&PL_threads_mutex);
+ do {
+ n = PL_nthreads;
+ MUTEX_UNLOCK(&PL_threads_mutex);
+ if (AvFILL(av) < n - 1) {
+ int i = AvFILL(av);
+ for (i = AvFILL(av); i < n - 1; i++) {
+ SV *sv = newSViv(0); /* fill in tid later */
+ sv_magic(sv, 0, '~', 0, 0); /* fill in other magic later */
+ av_push(av, sv_bless(newRV_noinc(sv),
+ gv_stashpv(classname, TRUE)));
+
+ }
+ }
+ MUTEX_LOCK(&PL_threads_mutex);
+ } while (n < PL_nthreads);
+ n = PL_nthreads; /* Get the final correct value */
+
+ /*
+ * At this point, there's enough room to fill in av.
+ * Note that we are holding threads_mutex so the list
+ * won't change out from under us but all the remaining
+ * processing is "fast" (no blocking, malloc etc.)
+ */
+ t = thr;
+ svp = AvARRAY(av);
+ do {
+ SV *sv = (SV*)SvRV(*svp);
+ sv_setiv(sv, t->tid);
+ SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->oursv);
+ SvMAGIC(sv)->mg_flags |= MGf_REFCOUNTED;
+ SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
+ t = t->next;
+ svp++;
+ } while (t != thr);
+ /* */
+ MUTEX_UNLOCK(&PL_threads_mutex);
+ /* Truncate any unneeded slots in av */
+ av_fill(av, n - 1);
+ /* Finally, push all the new objects onto the stack and drop av */
+ EXTEND(SP, n);
+ for (svp = AvARRAY(av); n > 0; n--, svp++)
+ PUSHs(*svp);
+ (void)sv_2mortal((SV*)av);
+#endif
+
+
+MODULE = Thread PACKAGE = Thread::Signal
+
+void
+kill_sighandler_thread()
+ PPCODE:
+ write(sig_pipe[1], "\0", 1);
+ PUSHs(&PL_sv_yes);
+
+void
+init_thread_signals()
+ PPCODE:
+ PL_sighandlerp = handle_thread_signal;
+ if (pipe(sig_pipe) == -1)
+ XSRETURN_UNDEF;
+ PUSHs(&PL_sv_yes);
+
+void
+await_signal()
+ PREINIT:
+ unsigned char c;
+ SSize_t ret;
+ CODE:
+ do {
+ ret = read(sig_pipe[0], &c, 1);
+ } while (ret == -1 && errno == EINTR);
+ if (ret == -1)
+ croak("panic: await_signal");
+ ST(0) = sv_newmortal();
+ if (ret)
+ sv_setsv(ST(0), c ? psig_ptr[c] : &PL_sv_no);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "await_signal returning %s\n", SvPEEK(ST(0))););
+
+MODULE = Thread PACKAGE = Thread::Specific
+
+void
+data(classname = "Thread::Specific")
+ char * classname
+ PPCODE:
+#ifdef USE_THREADS
+ if (AvFILL(thr->specific) == -1) {
+ GV *gv = gv_fetchpv("Thread::Specific::FIELDS", TRUE, SVt_PVHV);
+ av_store(thr->specific, 0, newRV((SV*)GvHV(gv)));
+ }
+ XPUSHs(sv_bless(newRV((SV*)thr->specific),gv_stashpv(classname,TRUE)));
+#endif
diff --git a/contrib/perl5/ext/Thread/Thread/Queue.pm b/contrib/perl5/ext/Thread/Thread/Queue.pm
new file mode 100644
index 000000000000..6d5f82be3444
--- /dev/null
+++ b/contrib/perl5/ext/Thread/Thread/Queue.pm
@@ -0,0 +1,99 @@
+package Thread::Queue;
+use Thread qw(cond_wait cond_broadcast);
+
+=head1 NAME
+
+Thread::Queue - thread-safe queues
+
+=head1 SYNOPSIS
+
+ use Thread::Queue;
+ my $q = new Thread::Queue;
+ $q->enqueue("foo", "bar");
+ my $foo = $q->dequeue; # The "bar" is still in the queue.
+ my $foo = $q->dequeue_nb; # returns "bar", or undef if the queue was
+ # empty
+ my $left = $q->pending; # returns the number of items still in the queue
+
+=head1 DESCRIPTION
+
+A queue, as implemented by C<Thread::Queue> is a thread-safe data structure
+much like a list. Any number of threads can safely add elements to the end
+of the list, or remove elements from the head of the list. (Queues don't
+permit adding or removing elements from the middle of the list)
+
+=head1 FUNCTIONS AND METHODS
+
+=over 8
+
+=item new
+
+The C<new> function creates a new empty queue.
+
+=item enqueue LIST
+
+The C<enqueue> method adds a list of scalars on to the end of the queue.
+The queue will grow as needed to accomodate the list.
+
+=item dequeue
+
+The C<dequeue> method removes a scalar from the head of the queue and
+returns it. If the queue is currently empty, C<dequeue> will block the
+thread until another thread C<enqueue>s a scalar.
+
+=item dequeue_nb
+
+The C<dequeue_nb> method, like the C<dequeue> method, removes a scalar from
+the head of the queue and returns it. Unlike C<dequeue>, though,
+C<dequeue_nb> won't block if the queue is empty, instead returning
+C<undef>.
+
+=item pending
+
+The C<pending> method returns the number of items still in the queue. (If
+there can be multiple readers on the queue it's best to lock the queue
+before checking to make sure that it stays in a consistent state)
+
+=back
+
+=head1 SEE ALSO
+
+L<Thread>
+
+=cut
+
+sub new {
+ my $class = shift;
+ return bless [@_], $class;
+}
+
+sub dequeue {
+ use attrs qw(locked method);
+ my $q = shift;
+ cond_wait $q until @$q;
+ return shift @$q;
+}
+
+sub dequeue_nb {
+ use attrs qw(locked method);
+ my $q = shift;
+ if (@$q) {
+ return shift @$q;
+ } else {
+ return undef;
+ }
+}
+
+sub enqueue {
+ use attrs qw(locked method);
+ my $q = shift;
+ push(@$q, @_) and cond_broadcast $q;
+}
+
+sub pending {
+ use attrs qw(locked method);
+ my $q = shift;
+ return scalar(@$q);
+}
+
+1;
diff --git a/contrib/perl5/ext/Thread/Thread/Semaphore.pm b/contrib/perl5/ext/Thread/Thread/Semaphore.pm
new file mode 100644
index 000000000000..915808cbed7e
--- /dev/null
+++ b/contrib/perl5/ext/Thread/Thread/Semaphore.pm
@@ -0,0 +1,87 @@
+package Thread::Semaphore;
+use Thread qw(cond_wait cond_broadcast);
+
+=head1 NAME
+
+Thread::Semaphore - thread-safe semaphores
+
+=head1 SYNOPSIS
+
+ use Thread::Semaphore;
+ my $s = new Thread::Semaphore;
+ $s->up; # Also known as the semaphore V -operation.
+ # The guarded section is here
+ $s->down; # Also known as the semaphore P -operation.
+
+ # The default semaphore value is 1.
+ my $s = new Thread::Semaphore($initial_value);
+ $s->up($up_value);
+ $s->down($up_value);
+
+=head1 DESCRIPTION
+
+Semaphores provide a mechanism to regulate access to resources. Semaphores,
+unlike locks, aren't tied to particular scalars, and so may be used to
+control access to anything you care to use them for.
+
+Semaphores don't limit their values to zero or one, so they can be used to
+control access to some resource that may have more than one of. (For
+example, filehandles) Increment and decrement amounts aren't fixed at one
+either, so threads can reserve or return multiple resources at once.
+
+=head1 FUNCTIONS AND METHODS
+
+=over 8
+
+=item new
+
+=item new NUMBER
+
+C<new> creates a new semaphore, and initializes its count to the passed
+number. If no number is passed, the semaphore's count is set to one.
+
+=item down
+
+=item down NUMBER
+
+The C<down> method decreases the semaphore's count by the specified number,
+or one if no number has been specified. If the semaphore's count would drop
+below zero, this method will block until such time that the semaphore's
+count is equal to or larger than the amount you're C<down>ing the
+semaphore's count by.
+
+=item up
+
+=item up NUMBER
+
+The C<up> method increases the semaphore's count by the number specified,
+or one if no number's been specified. This will unblock any thread blocked
+trying to C<down> the semaphore if the C<up> raises the semaphore count
+above what the C<down>s are trying to decrement it by.
+
+=back
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $val = @_ ? shift : 1;
+ bless \$val, $class;
+}
+
+sub down {
+ use attrs qw(locked method);
+ my $s = shift;
+ my $inc = @_ ? shift : 1;
+ cond_wait $s until $$s >= $inc;
+ $$s -= $inc;
+}
+
+sub up {
+ use attrs qw(locked method);
+ my $s = shift;
+ my $inc = @_ ? shift : 1;
+ ($$s += $inc) > 0 and cond_broadcast $s;
+}
+
+1;
diff --git a/contrib/perl5/ext/Thread/Thread/Signal.pm b/contrib/perl5/ext/Thread/Thread/Signal.pm
new file mode 100644
index 000000000000..f5f03db8a82b
--- /dev/null
+++ b/contrib/perl5/ext/Thread/Thread/Signal.pm
@@ -0,0 +1,50 @@
+package Thread::Signal;
+use Thread qw(async);
+
+=head1 NAME
+
+Thread::Signal - Start a thread which runs signal handlers reliably
+
+=head1 SYNOPSIS
+
+ use Thread::Signal;
+
+ $SIG{HUP} = \&some_handler;
+
+=head1 DESCRIPTION
+
+The C<Thread::Signal> module starts up a special signal handler thread.
+All signals to the process are delivered to it and it runs the
+associated C<$SIG{FOO}> handlers for them. Without this module,
+signals arriving at inopportune moments (such as when perl's internals
+are in the middle of updating critical structures) cause the perl
+code of the handler to be run unsafely which can cause memory corruption
+or worse.
+
+=head1 BUGS
+
+This module changes the semantics of signal handling slightly in that
+the signal handler is run separately from the main thread (and in
+parallel with it). This means that tricks such as calling C<die> from
+a signal handler behave differently (and, in particular, can't be
+used to exit directly from a system call).
+
+=cut
+
+if (!init_thread_signals()) {
+ require Carp;
+ Carp::croak("init_thread_signals failed: $!");
+}
+
+async {
+ my $sig;
+ while ($sig = await_signal()) {
+ &$sig();
+ }
+};
+
+END {
+ kill_sighandler_thread();
+}
+
+1;
diff --git a/contrib/perl5/ext/Thread/Thread/Specific.pm b/contrib/perl5/ext/Thread/Thread/Specific.pm
new file mode 100644
index 000000000000..9c8a66a9e6a1
--- /dev/null
+++ b/contrib/perl5/ext/Thread/Thread/Specific.pm
@@ -0,0 +1,29 @@
+package Thread::Specific;
+
+=head1 NAME
+
+Thread::Specific - thread-specific keys
+
+=head1 SYNOPSIS
+
+ use Thread::Specific;
+ my $k = key_create Thread::Specific;
+
+=head1 DESCRIPTION
+
+C<key_create> returns a unique thread-specific key.
+
+=cut
+
+sub import {
+ use attrs qw(locked method);
+ require fields;
+ fields->import(@_);
+}
+
+sub key_create {
+ use attrs qw(locked method);
+ return ++$FIELDS{__MAX__};
+}
+
+1;
diff --git a/contrib/perl5/ext/Thread/create.t b/contrib/perl5/ext/Thread/create.t
new file mode 100644
index 000000000000..7d6d189e9293
--- /dev/null
+++ b/contrib/perl5/ext/Thread/create.t
@@ -0,0 +1,17 @@
+use Thread;
+sub start_here {
+ my $i;
+ print "In start_here with args: @_\n";
+ for ($i = 1; $i <= 5; $i++) {
+ print "start_here: $i\n";
+ sleep 1;
+ }
+}
+
+print "Starting new thread now\n";
+$t = new Thread \&start_here, qw(foo bar baz);
+print "Started thread $t\n";
+for ($count = 1; $count <= 5; $count++) {
+ print "main: $count\n";
+ sleep 1;
+}
diff --git a/contrib/perl5/ext/Thread/die.t b/contrib/perl5/ext/Thread/die.t
new file mode 100644
index 000000000000..623940579ffd
--- /dev/null
+++ b/contrib/perl5/ext/Thread/die.t
@@ -0,0 +1,16 @@
+use Thread 'async';
+
+$t = async {
+ print "here\n";
+ die "success";
+ print "shouldn't get here\n";
+};
+
+sleep 1;
+print "joining...\n";
+eval { @r = $t->join; };
+if ($@) {
+ print "thread died with message: $@";
+} else {
+ print "thread failed to die successfully\n";
+}
diff --git a/contrib/perl5/ext/Thread/die2.t b/contrib/perl5/ext/Thread/die2.t
new file mode 100644
index 000000000000..f6b695520f9e
--- /dev/null
+++ b/contrib/perl5/ext/Thread/die2.t
@@ -0,0 +1,16 @@
+use Thread 'async';
+
+$t = async {
+ sleep 1;
+ print "here\n";
+ die "success if preceded by 'thread died...'";
+ print "shouldn't get here\n";
+};
+
+print "joining...\n";
+@r = eval { $t->join; };
+if ($@) {
+ print "thread died with message: $@";
+} else {
+ print "thread failed to die successfully\n";
+}
diff --git a/contrib/perl5/ext/Thread/io.t b/contrib/perl5/ext/Thread/io.t
new file mode 100644
index 000000000000..6012008ef574
--- /dev/null
+++ b/contrib/perl5/ext/Thread/io.t
@@ -0,0 +1,39 @@
+use Thread;
+
+sub counter {
+$count = 10;
+while ($count--) {
+ sleep 1;
+ print "ping $count\n";
+}
+}
+
+sub reader {
+ my $line;
+ while ($line = <STDIN>) {
+ print "reader: $line";
+ }
+ print "End of input in reader\n";
+ return 0;
+}
+
+print <<'EOT';
+This test starts up a thread to read and echo whatever is typed on
+the keyboard/stdin, line by line, while the main thread counts down
+to zero. The test stays running until both the main thread has
+finished counting down and the I/O thread has seen end-of-file on
+the terminal/stdin.
+EOT
+
+$r = new Thread \&counter;
+
+&reader;
+
+__END__
+
+
+$count = 10;
+while ($count--) {
+ sleep 1;
+ print "ping $count\n";
+}
diff --git a/contrib/perl5/ext/Thread/join.t b/contrib/perl5/ext/Thread/join.t
new file mode 100644
index 000000000000..cba2c1cf5671
--- /dev/null
+++ b/contrib/perl5/ext/Thread/join.t
@@ -0,0 +1,11 @@
+use Thread;
+sub foo {
+ print "In foo with args: @_\n";
+ return (7, 8, 9);
+}
+
+print "Starting thread\n";
+$t = new Thread \&foo, qw(foo bar baz);
+print "Joining with $t\n";
+@results = $t->join();
+print "Joining returned ", scalar(@results), " values: @results\n";
diff --git a/contrib/perl5/ext/Thread/join2.t b/contrib/perl5/ext/Thread/join2.t
new file mode 100644
index 000000000000..99b43a54dc54
--- /dev/null
+++ b/contrib/perl5/ext/Thread/join2.t
@@ -0,0 +1,12 @@
+use Thread;
+sub foo {
+ print "In foo with args: @_\n";
+ return (7, 8, 9);
+}
+
+print "Starting thread\n";
+$t = new Thread \&foo, qw(foo bar baz);
+sleep 2;
+print "Joining with $t\n";
+@results = $t->join();
+print "Joining returned @results\n";
diff --git a/contrib/perl5/ext/Thread/list.t b/contrib/perl5/ext/Thread/list.t
new file mode 100644
index 000000000000..f13f4b266a4c
--- /dev/null
+++ b/contrib/perl5/ext/Thread/list.t
@@ -0,0 +1,30 @@
+use Thread qw(async);
+use Thread::Semaphore;
+
+my $sem = Thread::Semaphore->new(0);
+
+$nthreads = 4;
+
+for (my $i = 0; $i < $nthreads; $i++) {
+ async {
+ my $tid = Thread->self->tid;
+ print "thread $tid started...\n";
+ $sem->down;
+ print "thread $tid finishing\n";
+ };
+}
+
+print "main: started $nthreads threads\n";
+sleep 2;
+
+my @list = Thread->list;
+printf "main: Thread->list returned %d threads\n", scalar(@list);
+
+foreach my $t (@list) {
+ print "inspecting thread $t...\n";
+ print "...deref is $$t\n";
+ print "...flags = ", $t->flags, "\n";
+ print "...tid = ", $t->tid, "\n";
+}
+print "main thread telling workers to finish off...\n";
+$sem->up($nthreads);
diff --git a/contrib/perl5/ext/Thread/lock.t b/contrib/perl5/ext/Thread/lock.t
new file mode 100644
index 000000000000..fefb1298797b
--- /dev/null
+++ b/contrib/perl5/ext/Thread/lock.t
@@ -0,0 +1,27 @@
+use Thread;
+
+$level = 0;
+
+sub worker
+{
+ my $num = shift;
+ my $i;
+ print "thread $num starting\n";
+ for ($i = 1; $i <= 20; $i++) {
+ print "thread $num iteration $i\n";
+ select(undef, undef, undef, rand(10)/100);
+ {
+ lock($lock);
+ warn "thread $num saw non-zero level = $level\n" if $level;
+ $level++;
+ print "thread $num has lock\n";
+ select(undef, undef, undef, rand(10)/100);
+ $level--;
+ }
+ print "thread $num released lock\n";
+ }
+}
+
+for ($t = 1; $t <= 5; $t++) {
+ new Thread \&worker, $t;
+}
diff --git a/contrib/perl5/ext/Thread/queue.t b/contrib/perl5/ext/Thread/queue.t
new file mode 100644
index 000000000000..4672ba6ee74a
--- /dev/null
+++ b/contrib/perl5/ext/Thread/queue.t
@@ -0,0 +1,36 @@
+use Thread;
+use Thread::Queue;
+
+$q = new Thread::Queue;
+
+sub reader {
+ my $tid = Thread->self->tid;
+ my $i = 0;
+ while (1) {
+ $i++;
+ print "reader (tid $tid): waiting for element $i...\n";
+ my $el = $q->dequeue;
+ print "reader (tid $tid): dequeued element $i: value $el\n";
+ select(undef, undef, undef, rand(2));
+ if ($el == -1) {
+ # end marker
+ print "reader (tid $tid) returning\n";
+ return;
+ }
+ }
+}
+
+my $nthreads = 3;
+
+for (my $i = 0; $i < $nthreads; $i++) {
+ Thread->new(\&reader, $i);
+}
+
+for (my $i = 1; $i <= 10; $i++) {
+ my $el = int(rand(100));
+ select(undef, undef, undef, rand(2));
+ print "writer: enqueuing value $el\n";
+ $q->enqueue($el);
+}
+
+$q->enqueue((-1) x $nthreads); # one end marker for each thread
diff --git a/contrib/perl5/ext/Thread/specific.t b/contrib/perl5/ext/Thread/specific.t
new file mode 100644
index 000000000000..da130b1d64c7
--- /dev/null
+++ b/contrib/perl5/ext/Thread/specific.t
@@ -0,0 +1,17 @@
+use Thread;
+
+use Thread::Specific qw(foo);
+
+sub count {
+ my $tid = Thread->self->tid;
+ my Thread::Specific $tsd = Thread::Specific::data;
+ for (my $i = 0; $i < 5; $i++) {
+ $tsd->{foo} = $i;
+ print "thread $tid count: $tsd->{foo}\n";
+ select(undef, undef, undef, rand(2));
+ }
+};
+
+for(my $t = 0; $t < 5; $t++) {
+ new Thread \&count;
+}
diff --git a/contrib/perl5/ext/Thread/sync.t b/contrib/perl5/ext/Thread/sync.t
new file mode 100644
index 000000000000..9c2e5897da5c
--- /dev/null
+++ b/contrib/perl5/ext/Thread/sync.t
@@ -0,0 +1,61 @@
+use Thread;
+
+$level = 0;
+
+sub single_file {
+ use attrs 'locked';
+ my $arg = shift;
+ $level++;
+ print "Level $level for $arg\n";
+ print "(something is wrong)\n" if $level < 0 || $level > 1;
+ sleep 1;
+ $level--;
+ print "Back to level $level\n";
+}
+
+sub start_bar {
+ my $i;
+ print "start bar\n";
+ for $i (1..3) {
+ print "bar $i\n";
+ single_file("bar $i");
+ sleep 1 if rand > 0.5;
+ }
+ print "end bar\n";
+ return 1;
+}
+
+sub start_foo {
+ my $i;
+ print "start foo\n";
+ for $i (1..3) {
+ print "foo $i\n";
+ single_file("foo $i");
+ sleep 1 if rand > 0.5;
+ }
+ print "end foo\n";
+ return 1;
+}
+
+sub start_baz {
+ my $i;
+ print "start baz\n";
+ for $i (1..3) {
+ print "baz $i\n";
+ single_file("baz $i");
+ sleep 1 if rand > 0.5;
+ }
+ print "end baz\n";
+ return 1;
+}
+
+$| = 1;
+srand($$^$^T);
+
+$foo = new Thread \&start_foo;
+$bar = new Thread \&start_bar;
+$baz = new Thread \&start_baz;
+$foo->join();
+$bar->join();
+$baz->join();
+print "main: threads finished, exiting\n";
diff --git a/contrib/perl5/ext/Thread/sync2.t b/contrib/perl5/ext/Thread/sync2.t
new file mode 100644
index 000000000000..0901da46a0ab
--- /dev/null
+++ b/contrib/perl5/ext/Thread/sync2.t
@@ -0,0 +1,69 @@
+use Thread;
+
+$global = undef;
+
+sub single_file {
+ use attrs 'locked';
+ my $who = shift;
+ my $i;
+
+ print "Uh oh: $who entered while locked by $global\n" if $global;
+ $global = $who;
+ print "[";
+ for ($i = 0; $i < int(10 * rand); $i++) {
+ print $who;
+ select(undef, undef, undef, 0.1);
+ }
+ print "]";
+ $global = undef;
+}
+
+sub start_a {
+ my ($i, $j);
+ for ($j = 0; $j < 10; $j++) {
+ single_file("A");
+ for ($i = 0; $i < int(10 * rand); $i++) {
+ print "a";
+ select(undef, undef, undef, 0.1);
+ }
+ }
+}
+
+sub start_b {
+ my ($i, $j);
+ for ($j = 0; $j < 10; $j++) {
+ single_file("B");
+ for ($i = 0; $i < int(10 * rand); $i++) {
+ print "b";
+ select(undef, undef, undef, 0.1);
+ }
+ }
+}
+
+sub start_c {
+ my ($i, $j);
+ for ($j = 0; $j < 10; $j++) {
+ single_file("C");
+ for ($i = 0; $i < int(10 * rand); $i++) {
+ print "c";
+ select(undef, undef, undef, 0.1);
+ }
+ }
+}
+
+$| = 1;
+srand($$^$^T);
+
+print <<'EOT';
+Each pair of square brackets [...] should contain a repeated sequence of
+a unique upper case letter. Lower case letters may appear randomly both
+in and out of the brackets.
+EOT
+$foo = new Thread \&start_a;
+$bar = new Thread \&start_b;
+$baz = new Thread \&start_c;
+print "\nmain: joining...\n";
+#$foo->join;
+#$bar->join;
+#$baz->join;
+print "\ndone\n";
diff --git a/contrib/perl5/ext/Thread/typemap b/contrib/perl5/ext/Thread/typemap
new file mode 100644
index 000000000000..21eb6c32409b
--- /dev/null
+++ b/contrib/perl5/ext/Thread/typemap
@@ -0,0 +1,24 @@
+Thread T_XSCPTR
+
+INPUT
+T_XSCPTR
+ STMT_START {
+ MAGIC *mg;
+ SV *sv = ($arg);
+
+ if (!sv_isobject(sv))
+ croak(\"$var is not an object\");
+ sv = (SV*)SvRV(sv);
+ if (!SvRMAGICAL(sv) || !(mg = mg_find(sv, '~'))
+ || mg->mg_private != ${ntype}_MAGIC_SIGNATURE)
+ croak(\"XSUB ${func_name}: $var is a forged ${ntype} object\");
+ $var = ($type) SvPVX(mg->mg_obj);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ \"XSUB ${func_name}: %p\\n\", $var);)
+ } STMT_END
+T_IVREF
+ if (SvROK($arg))
+ $var = ($type) SvIV((SV*)SvRV($arg));
+ else
+ croak(\"$var is not a reference\")
+
diff --git a/contrib/perl5/ext/Thread/unsync.t b/contrib/perl5/ext/Thread/unsync.t
new file mode 100644
index 000000000000..f0a51efe1f7e
--- /dev/null
+++ b/contrib/perl5/ext/Thread/unsync.t
@@ -0,0 +1,37 @@
+use Thread;
+
+$| = 1;
+
+if (@ARGV) {
+ srand($ARGV[0]);
+} else {
+ my $seed = $$ ^ $^T;
+ print "Randomising to $seed\n";
+ srand($seed);
+}
+
+sub whoami {
+ my ($depth, $a, $b, $c) = @_;
+ my $i;
+ print "whoami ($depth): $a $b $c\n";
+ sleep 1;
+ whoami($depth - 1, $a, $b, $c) if $depth > 0;
+}
+
+sub start_foo {
+ my $r = 3 + int(10 * rand);
+ print "start_foo: r is $r\n";
+ whoami($r, "start_foo", "foo1", "foo2");
+ print "start_foo: finished\n";
+}
+
+sub start_bar {
+ my $r = 3 + int(10 * rand);
+ print "start_bar: r is $r\n";
+ whoami($r, "start_bar", "bar1", "bar2");
+ print "start_bar: finished\n";
+}
+
+$foo = new Thread \&start_foo;
+$bar = new Thread \&start_bar;
+print "main: exiting\n";
diff --git a/contrib/perl5/ext/Thread/unsync2.t b/contrib/perl5/ext/Thread/unsync2.t
new file mode 100644
index 000000000000..fb955ac31e12
--- /dev/null
+++ b/contrib/perl5/ext/Thread/unsync2.t
@@ -0,0 +1,36 @@
+use Thread;
+
+$| = 1;
+
+srand($$^$^T);
+
+sub printargs {
+ my $thread = shift;
+ my $arg;
+ my $i;
+ while ($arg = shift) {
+ my $delay = int(rand(500));
+ $i++;
+ print "$thread arg $i is $arg\n";
+ 1 while $delay--;
+ }
+}
+
+sub start_thread {
+ my $thread = shift;
+ my $count = 10;
+ while ($count--) {
+ my(@args) = ($thread) x int(rand(10));
+ print "$thread $count calling printargs @args\n";
+ printargs($thread, @args);
+ }
+}
+
+new Thread (\&start_thread, "A");
+new Thread (\&start_thread, "B");
+#new Thread (\&start_thread, "C");
+#new Thread (\&start_thread, "D");
+#new Thread (\&start_thread, "E");
+#new Thread (\&start_thread, "F");
+
+print "main: exiting\n";
diff --git a/contrib/perl5/ext/Thread/unsync3.t b/contrib/perl5/ext/Thread/unsync3.t
new file mode 100644
index 000000000000..e03e9c8af104
--- /dev/null
+++ b/contrib/perl5/ext/Thread/unsync3.t
@@ -0,0 +1,50 @@
+use Thread;
+
+$| = 1;
+
+srand($$^$^T);
+
+sub whoami {
+ my $thread = shift;
+ print $thread;
+}
+
+sub uppercase {
+ my $count = 100;
+ while ($count--) {
+ my $i = int(rand(1000));
+ 1 while $i--;
+ print "A";
+ $i = int(rand(1000));
+ 1 while $i--;
+ whoami("B");
+ }
+}
+
+sub lowercase {
+ my $count = 100;
+ while ($count--) {
+ my $i = int(rand(1000));
+ 1 while $i--;
+ print "x";
+ $i = int(rand(1000));
+ 1 while $i--;
+ whoami("y");
+ }
+}
+
+sub numbers {
+ my $count = 100;
+ while ($count--) {
+ my $i = int(rand(1000));
+ 1 while $i--;
+ print 1;
+ $i = int(rand(1000));
+ 1 while $i--;
+ whoami(2);
+ }
+}
+
+new Thread \&numbers;
+new Thread \&uppercase;
+new Thread \&lowercase;
diff --git a/contrib/perl5/ext/Thread/unsync4.t b/contrib/perl5/ext/Thread/unsync4.t
new file mode 100644
index 000000000000..494ad2be9200
--- /dev/null
+++ b/contrib/perl5/ext/Thread/unsync4.t
@@ -0,0 +1,38 @@
+use Thread;
+
+$| = 1;
+
+srand($$^$^T);
+
+sub printargs {
+ my(@copyargs) = @_;
+ my $thread = shift @copyargs;
+ my $arg;
+ my $i;
+ while ($arg = shift @copyargs) {
+ my $delay = int(rand(500));
+ $i++;
+ print "$thread arg $i is $arg\n";
+ 1 while $delay--;
+ }
+}
+
+sub start_thread {
+ my(@threadargs) = @_;
+ my $thread = $threadargs[0];
+ my $count = 10;
+ while ($count--) {
+ my(@args) = ($thread) x int(rand(10));
+ print "$thread $count calling printargs @args\n";
+ printargs($thread, @args);
+ }
+}
+
+new Thread (\&start_thread, "A");
+new Thread (\&start_thread, "B");
+new Thread (\&start_thread, "C");
+new Thread (\&start_thread, "D");
+new Thread (\&start_thread, "E");
+new Thread (\&start_thread, "F");
+
+print "main: exiting\n";
diff --git a/contrib/perl5/ext/attrs/Makefile.PL b/contrib/perl5/ext/attrs/Makefile.PL
new file mode 100644
index 000000000000..c42175761546
--- /dev/null
+++ b/contrib/perl5/ext/attrs/Makefile.PL
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'attrs',
+ VERSION_FROM => 'attrs.pm',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes'
+);
diff --git a/contrib/perl5/ext/attrs/attrs.pm b/contrib/perl5/ext/attrs/attrs.pm
new file mode 100644
index 000000000000..fe2bf356e4fa
--- /dev/null
+++ b/contrib/perl5/ext/attrs/attrs.pm
@@ -0,0 +1,55 @@
+package attrs;
+require DynaLoader;
+use vars '@ISA';
+@ISA = 'DynaLoader';
+
+use vars qw($VERSION);
+$VERSION = "1.0";
+
+=head1 NAME
+
+attrs - set/get attributes of a subroutine
+
+=head1 SYNOPSIS
+
+ sub foo {
+ use attrs qw(locked method);
+ ...
+ }
+
+ @a = attrs::get(\&foo);
+
+=head1 DESCRIPTION
+
+This module lets you set and get attributes for subroutines.
+Setting attributes takes place at compile time; trying to set
+invalid attribute names causes a compile-time error. Calling
+C<attr::get> on a subroutine reference or name returns its list
+of attribute names. Notice that C<attr::get> is not exported.
+Valid attributes are as follows.
+
+=over
+
+=item method
+
+Indicates that the invoking subroutine is a method.
+
+=item locked
+
+Setting this attribute is only meaningful when the subroutine or
+method is to be called by multiple threads. When set on a method
+subroutine (i.e. one marked with the B<method> attribute above),
+perl ensures that any invocation of it implicitly locks its first
+argument before execution. When set on a non-method subroutine,
+perl ensures that a lock is taken on the subroutine itself before
+execution. The semantics of the lock are exactly those of one
+explicitly taken with the C<lock> operator immediately after the
+subroutine is entered.
+
+=back
+
+=cut
+
+bootstrap attrs $VERSION;
+
+1;
diff --git a/contrib/perl5/ext/attrs/attrs.xs b/contrib/perl5/ext/attrs/attrs.xs
new file mode 100644
index 000000000000..da952d5a3f1a
--- /dev/null
+++ b/contrib/perl5/ext/attrs/attrs.xs
@@ -0,0 +1,59 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+static cv_flags_t
+get_flag(char *attr)
+{
+ if (strnEQ(attr, "method", 6))
+ return CVf_METHOD;
+ else if (strnEQ(attr, "locked", 6))
+ return CVf_LOCKED;
+ else
+ return 0;
+}
+
+MODULE = attrs PACKAGE = attrs
+
+void
+import(Class, ...)
+char * Class
+ ALIAS:
+ unimport = 1
+ PREINIT:
+ int i;
+ CV *cv;
+ PPCODE:
+ if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
+ croak("can't set attributes outside a subroutine scope");
+ for (i = 1; i < items; i++) {
+ char *attr = SvPV(ST(i), PL_na);
+ cv_flags_t flag = get_flag(attr);
+ if (!flag)
+ croak("invalid attribute name %s", attr);
+ if (ix)
+ CvFLAGS(cv) &= ~flag;
+ else
+ CvFLAGS(cv) |= flag;
+ }
+
+void
+get(sub)
+SV * sub
+ PPCODE:
+ if (SvROK(sub)) {
+ sub = SvRV(sub);
+ if (SvTYPE(sub) != SVt_PVCV)
+ sub = Nullsv;
+ }
+ else {
+ char *name = SvPV(sub, PL_na);
+ sub = (SV*)perl_get_cv(name, FALSE);
+ }
+ if (!sub)
+ croak("invalid subroutine reference or name");
+ if (CvFLAGS(sub) & CVf_METHOD)
+ XPUSHs(sv_2mortal(newSVpv("method", 0)));
+ if (CvFLAGS(sub) & CVf_LOCKED)
+ XPUSHs(sv_2mortal(newSVpv("locked", 0)));
+
diff --git a/contrib/perl5/ext/re/Makefile.PL b/contrib/perl5/ext/re/Makefile.PL
new file mode 100644
index 000000000000..9ed83d17c84c
--- /dev/null
+++ b/contrib/perl5/ext/re/Makefile.PL
@@ -0,0 +1,41 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 're',
+ VERSION_FROM => 're.pm',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes',
+ OBJECT => 're_exec$(OBJ_EXT) re_comp$(OBJ_EXT) re$(OBJ_EXT)',
+ DEFINE => '-DPERL_EXT_RE_BUILD',
+ clean => { FILES => '*$(OBJ_EXT) *.c ../../lib/re.pm' },
+);
+
+sub MY::postamble {
+ if ($^O eq 'VMS') {
+ return <<'VMS_EOF';
+re_comp.c : [--]regcomp.c
+ - $(RM_F) $(MMS$TARGET_NAME)
+ $(CP) [--]regcomp.c $(MMS$TARGET_NAME)
+
+re_comp$(OBJ_EXT) : re_comp.c
+
+re_exec.c : [--]regexec.c
+ - $(RM_F) $(MMS$TARGET_NAME)
+ $(CP) [--]regexec.c $(MMS$TARGET_NAME)
+
+re_exec$(OBJ_EXT) : re_exec.c
+
+
+VMS_EOF
+ } else {
+ return <<'EOF';
+re_comp.c: ../../regcomp.c
+ -$(RM_F) $@
+ $(CP) ../../regcomp.c $@
+
+re_exec.c: ../../regexec.c
+ -$(RM_F) $@
+ $(CP) ../../regexec.c $@
+
+EOF
+ }
+}
diff --git a/contrib/perl5/ext/re/hints/mpeix.pl b/contrib/perl5/ext/re/hints/mpeix.pl
new file mode 100644
index 000000000000..d1fbb91f8fdd
--- /dev/null
+++ b/contrib/perl5/ext/re/hints/mpeix.pl
@@ -0,0 +1,3 @@
+# Fall back to -O optimization to avoid known gcc 2.8.0 -O2 problems on MPE/iX.
+# Mark Bixby <markb@cccd.edu>
+$self->{OPTIMIZE} = '-O';
diff --git a/contrib/perl5/ext/re/re.pm b/contrib/perl5/ext/re/re.pm
new file mode 100644
index 000000000000..7cea77dd42bd
--- /dev/null
+++ b/contrib/perl5/ext/re/re.pm
@@ -0,0 +1,131 @@
+package re;
+
+$VERSION = 0.02;
+
+=head1 NAME
+
+re - Perl pragma to alter regular expression behaviour
+
+=head1 SYNOPSIS
+
+ use re 'taint';
+ ($x) = ($^X =~ /^(.*)$/s); # $x is tainted here
+
+ $pat = '(?{ $foo = 1 })';
+ use re 'eval';
+ /foo${pat}bar/; # won't fail (when not under -T switch)
+
+ {
+ no re 'taint'; # the default
+ ($x) = ($^X =~ /^(.*)$/s); # $x is not tainted here
+
+ no re 'eval'; # the default
+ /foo${pat}bar/; # disallowed (with or without -T switch)
+ }
+
+ use re 'debug'; # NOT lexically scoped (as others are)
+ /^(.*)$/s; # output debugging info during
+ # compile and run time
+
+ use re 'debugcolor'; # same as 'debug', but with colored output
+ ...
+
+(We use $^X in these examples because it's tainted by default.)
+
+=head1 DESCRIPTION
+
+When C<use re 'taint'> is in effect, and a tainted string is the target
+of a regex, the regex memories (or values returned by the m// operator
+in list context) are tainted. This feature is useful when regex operations
+on tainted data aren't meant to extract safe substrings, but to perform
+other transformations.
+
+When C<use re 'eval'> is in effect, a regex is allowed to contain
+C<(?{ ... })> zero-width assertions even if regular expression contains
+variable interpolation. That is normally disallowed, since it is a
+potential security risk. Note that this pragma is ignored when the regular
+expression is obtained from tainted data, i.e. evaluation is always
+disallowed with tainted regular expresssions. See L<perlre/(?{ code })>.
+
+For the purpose of this pragma, interpolation of precompiled regular
+expressions (i.e., the result of C<qr//>) is I<not> considered variable
+interpolation. Thus:
+
+ /foo${pat}bar/
+
+I<is> allowed if $pat is a precompiled regular expression, even
+if $pat contains C<(?{ ... })> assertions.
+
+When C<use re 'debug'> is in effect, perl emits debugging messages when
+compiling and using regular expressions. The output is the same as that
+obtained by running a C<-DDEBUGGING>-enabled perl interpreter with the
+B<-Dr> switch. It may be quite voluminous depending on the complexity
+of the match. Using C<debugcolor> instead of C<debug> enables a
+form of output that can be used to get a colorful display on terminals
+that understand termcap color sequences. Set C<$ENV{PERL_RE_TC}> to a
+comma-separated list of C<termcap> properties to use for highlighting
+strings on/off, pre-point part on/off.
+See L<perldebug/"Debugging regular expressions"> for additional info.
+
+The directive C<use re 'debug'> is I<not lexically scoped>, as the
+other directives are. It has both compile-time and run-time effects.
+
+See L<perlmodlib/Pragmatic Modules>.
+
+=cut
+
+my %bitmask = (
+taint => 0x00100000,
+eval => 0x00200000,
+);
+
+sub setcolor {
+ eval { # Ignore errors
+ require Term::Cap;
+
+ my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
+ my $props = $ENV{PERL_RE_TC} || 'md,me,so,se'; # can use us/ue later
+ my @props = split /,/, $props;
+
+
+ $ENV{TERMCAP_COLORS} = join "\t", map {$terminal->Tputs($_,1)} @props;
+ };
+
+ not defined $ENV{TERMCAP_COLORS} or ($ENV{TERMCAP_COLORS} =~ tr/\t/\t/) >= 4
+ or not defined $ENV{PERL_RE_TC}
+ or die "Not enough fields in \$ENV{PERL_RE_TC}=`$ENV{PERL_RE_TC}'";
+}
+
+sub bits {
+ my $on = shift;
+ my $bits = 0;
+ unless(@_) {
+ require Carp;
+ Carp::carp("Useless use of \"re\" pragma");
+ }
+ foreach my $s (@_){
+ if ($s eq 'debug' or $s eq 'debugcolor') {
+ setcolor() if $s eq 'debugcolor';
+ require DynaLoader;
+ @ISA = ('DynaLoader');
+ bootstrap re;
+ install() if $on;
+ uninstall() unless $on;
+ next;
+ }
+ $bits |= $bitmask{$s} || 0;
+ }
+ $bits;
+}
+
+sub import {
+ shift;
+ $^H |= bits(1,@_);
+}
+
+sub unimport {
+ shift;
+ $^H &= ~ bits(0,@_);
+}
+
+1;
diff --git a/contrib/perl5/ext/re/re.xs b/contrib/perl5/ext/re/re.xs
new file mode 100644
index 000000000000..7230d626dc2a
--- /dev/null
+++ b/contrib/perl5/ext/re/re.xs
@@ -0,0 +1,46 @@
+/* We need access to debugger hooks */
+#ifndef DEBUGGING
+# define DEBUGGING
+#endif
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+extern regexp* my_regcomp _((char* exp, char* xend, PMOP* pm));
+extern I32 my_regexec _((regexp* prog, char* stringarg, char* strend,
+ char* strbeg, I32 minend, SV* screamer,
+ void* data, U32 flags));
+
+static int oldfl;
+
+#define R_DB 512
+
+static void
+deinstall(void)
+{
+ dTHR;
+ PL_regexecp = &regexec_flags;
+ PL_regcompp = &pregcomp;
+ if (!oldfl)
+ PL_debug &= ~R_DB;
+}
+
+static void
+install(void)
+{
+ dTHR;
+ PL_colorset = 0; /* Allow reinspection of ENV. */
+ PL_regexecp = &my_regexec;
+ PL_regcompp = &my_regcomp;
+ oldfl = PL_debug & R_DB;
+ PL_debug |= R_DB;
+}
+
+MODULE = re PACKAGE = re
+
+void
+install()
+
+void
+deinstall()
diff --git a/contrib/perl5/ext/util/make_ext b/contrib/perl5/ext/util/make_ext
new file mode 100644
index 000000000000..54caf7dfd8d8
--- /dev/null
+++ b/contrib/perl5/ext/util/make_ext
@@ -0,0 +1,141 @@
+#!/bin/sh
+
+# This script acts as a simple interface for building extensions.
+# It primarily used by the perl Makefile:
+#
+# d_dummy $(dynamic_ext): miniperl preplibrary FORCE
+# @sh ext/util/make_ext dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
+#
+# It may be deleted in a later release of perl so try to
+# avoid using it for other purposes.
+
+target=$1; shift
+extspec=$1; shift
+makecmd=$1; shift # Should be something like MAKE=make
+passthru="$*" # allow extra macro=value to be passed through
+echo ""
+
+# Previously, $make was taken from config.sh. However, the user might
+# instead be running a possibly incompatible make. This might happen if
+# the user types "gmake" instead of a plain "make", for example. The
+# correct current value of MAKE will come through from the main perl
+# makefile as MAKE=/whatever/make in $makecmd. We'll be cautious in
+# case third party users of this script (are there any?) don't have the
+# MAKE=$(MAKE) argument, which was added after 5.004_03.
+case "$makecmd" in
+MAKE=*)
+ eval $makecmd
+ ;;
+*) echo 'ext/util/make_ext: WARNING: Please include MAKE=$(MAKE)'
+ echo ' in your call to make_ext. See ext/util/make_ext for details.'
+ exit 1
+ ;;
+esac
+
+
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh generated by Configure"; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+
+if test "X$extspec" = X; then
+ echo "make_ext: no extension specified"
+ exit 1;
+fi
+
+# The Perl Makefile.SH will expand all extensions to
+# lib/auto/X/X.a (or lib/auto/X/Y/Y.a if nested)
+# A user wishing to run make_ext might use
+# X (or X/Y or X::Y if nested)
+
+# canonise into X/Y form (pname)
+case "$extspec" in
+lib*) # Remove lib/auto prefix and /*.* suffix
+ pname=`echo "$extspec" | sed -e 's:^lib/auto/::' -e 's:/[^/]*\.[^/]*$::' ` ;;
+ext*) # Remove ext/ prefix and /pm_to_blib suffix
+ pname=`echo "$extspec" | sed -e 's:^ext/::' -e 's:/pm_to_blib$::' ` ;;
+*::*) # Convert :: to /
+ pname=`echo "$extspec" | sed -e 's/::/\//g' ` ;;
+*) pname="$extspec" ;;
+esac
+# echo "Converted $extspec to $pname"
+
+mname=`echo "$pname" | sed -e 's!/!::!g'`
+depth=`echo "$pname" | sed -e 's![^/][^/]*!..!g'`
+makefile=Makefile
+makeargs=''
+makeopts=''
+
+if test ! -d "ext/$pname"; then
+ echo " Skipping $extspec (directory does not exist)"
+ exit 0 # not an error ?
+fi
+
+
+echo " Making $mname ($target)"
+
+cd ext/$pname
+
+# check link type and do any preliminaries
+case "$target" in
+ # convert 'static' or 'dynamic' into 'all LINKTYPE=XXX'
+static) makeargs="LINKTYPE=static CCCDLFLAGS="
+ target=all
+ ;;
+dynamic) makeargs="LINKTYPE=dynamic";
+ target=all
+ ;;
+
+nonxs) makeargs="";
+ target=all
+ ;;
+
+*clean) # If Makefile has been moved to Makefile.old by a make clean
+ # then use Makefile.old for realclean rather than rebuild it
+ if test ! -f $makefile -a -f Makefile.old; then
+ makefile=Makefile.old
+ makeopts="-f $makefile"
+ echo "Note: Using Makefile.old"
+ fi
+ ;;
+
+*) # for the time being we are strict about what make_ext is used for
+ echo "make_ext: unknown make target '$target'"; exit 1
+ ;;
+'') echo "make_ext: no make target specified (eg static or dynamic)"; exit 1
+ ;;
+esac
+
+if test ! -f $makefile ; then
+ test -f Makefile.PL && ../$depth/miniperl -I../$depth/lib Makefile.PL INSTALLDIRS=perl $passthru
+fi
+if test ! -f $makefile ; then
+ if test -f Makefile.SH; then
+ echo "Warning: Writing $makefile from old-style Makefile.SH!"
+ sh Makefile.SH
+ else
+ echo "Warning: No Makefile!"
+ fi
+fi
+
+case "$target" in
+clean) ;;
+realclean) ;;
+*) # Give makefile an opportunity to rewrite itself.
+ # reassure users that life goes on...
+ $MAKE config $passthru || echo "$MAKE config failed, continuing anyway..."
+ ;;
+esac
+
+$MAKE $makeopts $target $makeargs $passthru || exit
+
+exit $?
diff --git a/contrib/perl5/ext/util/mkbootstrap b/contrib/perl5/ext/util/mkbootstrap
new file mode 100644
index 000000000000..6c3a7e10edb9
--- /dev/null
+++ b/contrib/perl5/ext/util/mkbootstrap
@@ -0,0 +1,5 @@
+#!../../miniperl -w -I../../lib
+
+use ExtUtils::MakeMaker;
+&mkbootstrap(join(" ",@ARGV));
+exit;
diff --git a/contrib/perl5/fakethr.h b/contrib/perl5/fakethr.h
new file mode 100644
index 000000000000..098fefea9ec9
--- /dev/null
+++ b/contrib/perl5/fakethr.h
@@ -0,0 +1,56 @@
+typedef int perl_mutex;
+typedef int perl_key;
+
+typedef struct perl_thread *perl_os_thread;
+/* With fake threads, thr is global(ish) so we don't need dTHR */
+#define dTHR extern int errno
+
+struct perl_wait_queue {
+ struct perl_thread * thread;
+ struct perl_wait_queue * next;
+};
+typedef struct perl_wait_queue *perl_cond;
+
+/* Ask thread.h to include our per-thread extras */
+#define HAVE_THREAD_INTERN
+struct thread_intern {
+ perl_os_thread next_run, prev_run; /* Linked list of runnable threads */
+ perl_cond wait_queue; /* Wait queue that we are waiting on */
+ IV private; /* Holds data across time slices */
+ I32 savemark; /* Holds MARK for thread join values */
+};
+
+#define init_thread_intern(t) \
+ STMT_START { \
+ t->self = (t); \
+ (t)->i.next_run = (t)->i.prev_run = (t); \
+ (t)->i.wait_queue = 0; \
+ (t)->i.private = 0; \
+ } STMT_END
+
+/*
+ * Note that SCHEDULE() is only callable from pp code (which
+ * must be expecting to be restarted). We'll have to do
+ * something a bit different for XS code.
+ */
+
+#define SCHEDULE() return schedule(), PL_op
+
+#define MUTEX_LOCK(m)
+#define MUTEX_UNLOCK(m)
+#define MUTEX_INIT(m)
+#define MUTEX_DESTROY(m)
+#define COND_INIT(c) perl_cond_init(c)
+#define COND_SIGNAL(c) perl_cond_signal(c)
+#define COND_BROADCAST(c) perl_cond_broadcast(c)
+#define COND_WAIT(c, m) \
+ STMT_START { \
+ perl_cond_wait(c); \
+ SCHEDULE(); \
+ } STMT_END
+#define COND_DESTROY(c)
+
+#define THREAD_CREATE(t, f) f((t))
+#define THREAD_POST_CREATE(t) NOOP
+
+#define YIELD NOOP
diff --git a/contrib/perl5/form.h b/contrib/perl5/form.h
new file mode 100644
index 000000000000..5e74c613fad4
--- /dev/null
+++ b/contrib/perl5/form.h
@@ -0,0 +1,26 @@
+/* form.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#define FF_END 0
+#define FF_LINEMARK 1
+#define FF_LITERAL 2
+#define FF_SKIP 3
+#define FF_FETCH 4
+#define FF_CHECKNL 5
+#define FF_CHECKCHOP 6
+#define FF_SPACE 7
+#define FF_HALFSPACE 8
+#define FF_ITEM 9
+#define FF_CHOP 10
+#define FF_LINEGLOB 11
+#define FF_DECIMAL 12
+#define FF_NEWLINE 13
+#define FF_BLANK 14
+#define FF_MORE 15
+
diff --git a/contrib/perl5/global.sym b/contrib/perl5/global.sym
new file mode 100644
index 000000000000..f3c73fedf14e
--- /dev/null
+++ b/contrib/perl5/global.sym
@@ -0,0 +1,1071 @@
+# Global symbols that need to be hidden in embedded applications.
+
+# Variables - should not be here but in perlvars.h
+
+AMG_names
+Error
+abs_amg
+add_amg
+add_ass_amg
+additem
+atan2_amg
+band_amg
+block_type
+bool__amg
+bor_amg
+bxor_amg
+check
+compl_amg
+concat_amg
+concat_ass_amg
+cos_amg
+dc
+dec_amg
+di
+div_amg
+div_ass_amg
+do_binmode
+ds
+eq_amg
+exp_amg
+expectterm
+fallback_amg
+fold
+fold_locale
+freq
+ge_amg
+gt_amg
+inc_amg
+init_thread_intern
+io_close
+know_next
+le_amg
+log_amg
+lshift_amg
+lshift_ass_amg
+lt_amg
+mod_amg
+mod_ass_amg
+mult_amg
+mult_ass_amg
+ncmp_amg
+ne_amg
+neg_amg
+new_struct_thread
+new_stackinfo
+no_aelem
+no_dir_func
+no_func
+no_helem
+no_mem
+no_modify
+no_myglob
+no_security
+no_sock_func
+no_symref
+no_usym
+no_wrongref
+nointrp
+nomem
+nomethod_amg
+not_amg
+numer_amg
+op_const_sv
+op_desc
+op_name
+opargs
+pow_amg
+pow_ass_amg
+ppaddr
+psig_name
+psig_ptr
+reall_srchlen
+regkind
+repeat_amg
+repeat_ass_amg
+rshift_amg
+rshift_ass_amg
+runops_debug
+runops_standard
+saw_return
+scmp_amg
+seq_amg
+sge_amg
+sgt_amg
+sig_name
+sig_num
+simple
+sin_amg
+sle_amg
+slt_amg
+sne_amg
+sqrt_amg
+string_amg
+subtr_amg
+subtr_ass_amg
+varies
+vivify_defelem
+vivify_ref
+vtbl_amagic
+vtbl_amagicelem
+vtbl_arylen
+vtbl_bm
+vtbl_collxfrm
+vtbl_dbline
+vtbl_defelem
+vtbl_env
+vtbl_envelem
+vtbl_fm
+vtbl_glob
+vtbl_isa
+vtbl_isaelem
+vtbl_mglob
+vtbl_mutex
+vtbl_nkeys
+vtbl_pack
+vtbl_packelem
+vtbl_pos
+vtbl_regexp
+vtbl_sig
+vtbl_sigelem
+vtbl_substr
+vtbl_sv
+vtbl_taint
+vtbl_uvar
+vtbl_vec
+warn_nl
+warn_nosemi
+warn_reserved
+warn_uninit
+watchaddr
+watchok
+yychar
+yycheck
+yydebug
+yydefred
+yydgoto
+yyerrflag
+yygindex
+yylen
+yylhs
+yylval
+yyname
+yynerrs
+yyrindex
+yyrule
+yysindex
+yytable
+yyval
+
+# Functions
+
+Gv_AMupdate
+amagic_call
+append_elem
+append_list
+apply
+assertref
+av_clear
+av_extend
+av_fake
+av_fetch
+av_fill
+av_len
+av_make
+av_pop
+av_push
+av_reify
+av_shift
+av_store
+av_undef
+av_unshift
+avhv_exists_ent
+avhv_fetch_ent
+avhv_iternext
+avhv_iterval
+avhv_keys
+bind_match
+block_end
+block_gimme
+block_start
+boot_core_UNIVERSAL
+bset_obj_store
+byterun
+call_list
+cando
+cast_ulong
+check_uni
+checkcomma
+ck_aelem
+ck_anoncode
+ck_bitop
+ck_concat
+ck_delete
+ck_eof
+ck_eval
+ck_exec
+ck_exists
+ck_ftst
+ck_fun
+ck_fun_locale
+ck_glob
+ck_grep
+ck_gvconst
+ck_index
+ck_lengthconst
+ck_lfun
+ck_listiob
+ck_match
+ck_null
+ck_repeat
+ck_require
+ck_retarget
+ck_rfun
+ck_rvconst
+ck_scmp
+ck_select
+ck_shift
+ck_sort
+ck_spair
+ck_split
+ck_subr
+ck_svconst
+ck_trunc
+condpair_magic
+convert
+croak
+cv_ckproto
+cv_clone
+cv_const_sv
+cv_undef
+cx_dump
+cxinc
+deb
+deb_growlevel
+debop
+debprofdump
+debstack
+debstackptrs
+delimcpy
+deprecate
+die
+die_where
+do_aexec
+do_chomp
+do_chop
+do_close
+do_eof
+do_exec
+do_execfree
+do_ipcctl
+do_ipcget
+do_join
+do_kv
+do_msgrcv
+do_msgsnd
+do_open
+do_pipe
+do_print
+do_readline
+do_seek
+do_semop
+do_shmio
+do_sprintf
+do_sysseek
+do_tell
+do_trans
+do_vecset
+do_vop
+dofindlabel
+dopoptoeval
+dounwind
+dowantarray
+dump_all
+dump_eval
+dump_fds
+dump_form
+dump_gv
+dump_mstats
+dump_op
+dump_packsubs
+dump_pm
+dump_sub
+fbm_compile
+fbm_instr
+fetch_gv
+fetch_io
+filter_add
+filter_del
+filter_read
+find_script
+find_threadsv
+fold_constants
+force_ident
+force_list
+force_next
+force_word
+form
+free_tmps
+gen_constant_list
+get_op_descs
+get_op_names
+get_no_modify
+get_opargs
+get_specialsv_list
+gp_free
+gp_ref
+gv_AVadd
+gv_HVadd
+gv_IOadd
+gv_autoload4
+gv_check
+gv_efullname
+gv_efullname3
+gv_fetchfile
+gv_fetchmeth
+gv_fetchmethod
+gv_fetchmethod_autoload
+gv_fetchpv
+gv_fullname
+gv_fullname3
+gv_init
+gv_stashpv
+gv_stashpvn
+gv_stashsv
+hv_clear
+hv_delayfree_ent
+hv_delete
+hv_delete_ent
+hv_exists
+hv_exists_ent
+hv_fetch
+hv_fetch_ent
+hv_free_ent
+hv_iterinit
+hv_iterkey
+hv_iterkeysv
+hv_iternext
+hv_iternextsv
+hv_iterval
+hv_ksplit
+hv_magic
+hv_stashpv
+hv_store
+hv_store_ent
+hv_undef
+ibcmp
+ibcmp_locale
+ingroup
+init_stacks
+instr
+intro_my
+intuit_more
+invert
+jmaybe
+keyword
+leave_scope
+lex_end
+lex_start
+linklist
+list
+listkids
+localize
+looks_like_number
+magic_clear_all_env
+magic_clearenv
+magic_clearpack
+magic_clearsig
+magic_existspack
+magic_freeregexp
+magic_get
+magic_getarylen
+magic_getdefelem
+magic_getglob
+magic_getnkeys
+magic_getpack
+magic_getpos
+magic_getsig
+magic_getsubstr
+magic_gettaint
+magic_getuvar
+magic_getvec
+magic_len
+magic_mutexfree
+magic_nextpack
+magic_set
+magic_set_all_env
+magic_setamagic
+magic_setarylen
+magic_setbm
+magic_setcollxfrm
+magic_setdbline
+magic_setdefelem
+magic_setenv
+magic_setfm
+magic_setglob
+magic_setisa
+magic_setmglob
+magic_setnkeys
+magic_setpack
+magic_setpos
+magic_setsig
+magic_setsubstr
+magic_settaint
+magic_setuvar
+magic_setvec
+magic_sizepack
+magic_wipepack
+magicname
+malloced_size
+markstack_grow
+mem_collxfrm
+mess
+mg_clear
+mg_copy
+mg_find
+mg_free
+mg_get
+mg_length
+mg_magical
+mg_set
+mg_size
+mod
+modkids
+moreswitches
+mstats
+my
+my_bcopy
+my_bzero
+my_chsize
+my_exit
+my_failure_exit
+my_htonl
+my_lstat
+my_memcmp
+my_memset
+my_ntohl
+my_pclose
+my_popen
+my_setenv
+my_stat
+my_swap
+my_unexec
+newANONHASH
+newANONLIST
+newANONSUB
+newASSIGNOP
+newAV
+newAVREF
+newBINOP
+newCONDOP
+newCONSTSUB
+newCVREF
+newFORM
+newFOROP
+newGVOP
+newGVREF
+newGVgen
+newHV
+newHVREF
+newHVhv
+newIO
+newLISTOP
+newLOGOP
+newLOOPEX
+newLOOPOP
+newNULLLIST
+newOP
+newPMOP
+newPROG
+newPVOP
+newRANGE
+newRV
+newRV_noinc
+newSLICEOP
+newSTATEOP
+newSUB
+newSV
+newSVOP
+newSVREF
+newSViv
+newSVnv
+newSVpv
+newSVpvf
+newSVpvn
+newSVrv
+newSVsv
+newUNOP
+newWHILEOP
+newXS
+newXSUB
+nextargv
+ninstr
+no_fh_allowed
+no_op
+oopsAV
+oopsCV
+oopsHV
+op_free
+package
+pad_alloc
+pad_allocmy
+pad_findmy
+pad_free
+pad_leavemy
+pad_reset
+pad_sv
+pad_swipe
+peep
+pidgone
+pmflag
+pmruntime
+pmtrans
+pop_return
+pop_scope
+pp_aassign
+pp_abs
+pp_accept
+pp_add
+pp_aelem
+pp_aelemfast
+pp_alarm
+pp_and
+pp_andassign
+pp_anoncode
+pp_anonhash
+pp_anonlist
+pp_aslice
+pp_atan2
+pp_av2arylen
+pp_backtick
+pp_bind
+pp_binmode
+pp_bit_and
+pp_bit_or
+pp_bit_xor
+pp_bless
+pp_caller
+pp_chdir
+pp_chmod
+pp_chomp
+pp_chop
+pp_chown
+pp_chr
+pp_chroot
+pp_close
+pp_closedir
+pp_complement
+pp_concat
+pp_cond_expr
+pp_connect
+pp_const
+pp_cos
+pp_crypt
+pp_cswitch
+pp_dbmclose
+pp_dbmopen
+pp_dbstate
+pp_defined
+pp_delete
+pp_die
+pp_divide
+pp_dofile
+pp_dump
+pp_each
+pp_egrent
+pp_ehostent
+pp_enetent
+pp_enter
+pp_entereval
+pp_enteriter
+pp_enterloop
+pp_entersub
+pp_entersubr
+pp_entertry
+pp_enterwrite
+pp_eof
+pp_eprotoent
+pp_epwent
+pp_eq
+pp_eservent
+pp_evalonce
+pp_exec
+pp_exists
+pp_exit
+pp_exp
+pp_fcntl
+pp_fileno
+pp_flip
+pp_flock
+pp_flop
+pp_fork
+pp_formline
+pp_ftatime
+pp_ftbinary
+pp_ftblk
+pp_ftchr
+pp_ftctime
+pp_ftdir
+pp_fteexec
+pp_fteowned
+pp_fteread
+pp_ftewrite
+pp_ftfile
+pp_ftis
+pp_ftlink
+pp_ftmtime
+pp_ftpipe
+pp_ftrexec
+pp_ftrowned
+pp_ftrread
+pp_ftrwrite
+pp_ftsgid
+pp_ftsize
+pp_ftsock
+pp_ftsuid
+pp_ftsvtx
+pp_fttext
+pp_fttty
+pp_ftzero
+pp_ge
+pp_gelem
+pp_getc
+pp_getlogin
+pp_getpeername
+pp_getpgrp
+pp_getppid
+pp_getpriority
+pp_getsockname
+pp_ggrent
+pp_ggrgid
+pp_ggrnam
+pp_ghbyaddr
+pp_ghbyname
+pp_ghostent
+pp_glob
+pp_gmtime
+pp_gnbyaddr
+pp_gnbyname
+pp_gnetent
+pp_goto
+pp_gpbyname
+pp_gpbynumber
+pp_gprotoent
+pp_gpwent
+pp_gpwnam
+pp_gpwuid
+pp_grepstart
+pp_grepwhile
+pp_gsbyname
+pp_gsbyport
+pp_gservent
+pp_gsockopt
+pp_gt
+pp_gv
+pp_gvsv
+pp_helem
+pp_hex
+pp_hslice
+pp_i_add
+pp_i_divide
+pp_i_eq
+pp_i_ge
+pp_i_gt
+pp_i_le
+pp_i_lt
+pp_i_modulo
+pp_i_multiply
+pp_i_ncmp
+pp_i_ne
+pp_i_negate
+pp_i_subtract
+pp_index
+pp_int
+pp_interp
+pp_ioctl
+pp_iter
+pp_join
+pp_keys
+pp_kill
+pp_last
+pp_lc
+pp_lcfirst
+pp_le
+pp_leave
+pp_leaveeval
+pp_leaveloop
+pp_leavesub
+pp_leavetry
+pp_leavewrite
+pp_left_shift
+pp_length
+pp_lineseq
+pp_link
+pp_list
+pp_listen
+pp_localtime
+pp_lock
+pp_log
+pp_lslice
+pp_lstat
+pp_lt
+pp_map
+pp_mapstart
+pp_mapwhile
+pp_match
+pp_method
+pp_mkdir
+pp_modulo
+pp_msgctl
+pp_msgget
+pp_msgrcv
+pp_msgsnd
+pp_multiply
+pp_ncmp
+pp_ne
+pp_negate
+pp_next
+pp_nextstate
+pp_not
+pp_nswitch
+pp_null
+pp_oct
+pp_open
+pp_open_dir
+pp_or
+pp_orassign
+pp_ord
+pp_pack
+pp_padany
+pp_padav
+pp_padhv
+pp_padsv
+pp_pipe_op
+pp_pop
+pp_pos
+pp_postdec
+pp_postinc
+pp_pow
+pp_predec
+pp_preinc
+pp_print
+pp_prototype
+pp_prtf
+pp_push
+pp_pushmark
+pp_pushre
+pp_qr
+pp_quotemeta
+pp_rand
+pp_range
+pp_rcatline
+pp_read
+pp_readdir
+pp_readline
+pp_readlink
+pp_recv
+pp_redo
+pp_ref
+pp_refgen
+pp_regcmaybe
+pp_regcreset
+pp_regcomp
+pp_rename
+pp_repeat
+pp_require
+pp_reset
+pp_return
+pp_reverse
+pp_rewinddir
+pp_right_shift
+pp_rindex
+pp_rmdir
+pp_rv2av
+pp_rv2cv
+pp_rv2gv
+pp_rv2hv
+pp_rv2sv
+pp_sassign
+pp_scalar
+pp_schomp
+pp_schop
+pp_scmp
+pp_scope
+pp_seek
+pp_seekdir
+pp_select
+pp_semctl
+pp_semget
+pp_semop
+pp_send
+pp_seq
+pp_setpgrp
+pp_setpriority
+pp_sge
+pp_sgrent
+pp_sgt
+pp_shift
+pp_shmctl
+pp_shmget
+pp_shmread
+pp_shmwrite
+pp_shostent
+pp_shutdown
+pp_sin
+pp_sle
+pp_sleep
+pp_slt
+pp_sne
+pp_snetent
+pp_socket
+pp_sockpair
+pp_sort
+pp_splice
+pp_split
+pp_sprintf
+pp_sprotoent
+pp_spwent
+pp_sqrt
+pp_srand
+pp_srefgen
+pp_sselect
+pp_sservent
+pp_ssockopt
+pp_stat
+pp_stringify
+pp_stub
+pp_study
+pp_subst
+pp_substcont
+pp_substr
+pp_subtract
+pp_symlink
+pp_syscall
+pp_sysopen
+pp_sysread
+pp_sysseek
+pp_system
+pp_syswrite
+pp_tell
+pp_telldir
+pp_threadsv
+pp_tie
+pp_tied
+pp_time
+pp_tms
+pp_trans
+pp_truncate
+pp_uc
+pp_ucfirst
+pp_umask
+pp_undef
+pp_unlink
+pp_unpack
+pp_unshift
+pp_unstack
+pp_untie
+pp_utime
+pp_values
+pp_vec
+pp_wait
+pp_waitpid
+pp_wantarray
+pp_warn
+pp_xor
+pregcomp
+pregexec
+pregfree
+prepend_elem
+push_return
+push_scope
+q
+ref
+refkids
+regdump
+regexec_flags
+regnext
+regprop
+repeatcpy
+rninstr
+rsignal
+rsignal_restore
+rsignal_save
+rsignal_state
+rxres_free
+rxres_restore
+rxres_save
+safecalloc
+safefree
+safemalloc
+saferealloc
+safexcalloc
+safexfree
+safexmalloc
+safexrealloc
+same_dirent
+save_I16
+save_I32
+save_aelem
+save_aptr
+save_ary
+save_clearsv
+save_delete
+save_destructor
+save_freeop
+save_freepv
+save_freesv
+save_gp
+save_hash
+save_helem
+save_hints
+save_hptr
+save_int
+save_item
+save_iv
+save_list
+save_long
+save_nogv
+save_op
+save_pptr
+save_scalar
+save_sptr
+save_svref
+save_threadsv
+savepv
+savepvn
+savestack_grow
+sawparens
+scalar
+scalarkids
+scalarseq
+scalarvoid
+scan_const
+scan_formline
+scan_heredoc
+scan_hex
+scan_ident
+scan_inputsymbol
+scan_num
+scan_oct
+scan_pat
+scan_prefix
+scan_str
+scan_subst
+scan_trans
+scan_word
+scope
+screaminstr
+setdefout
+setenv_getix
+share_hek
+sharepvn
+sighandler
+skipspace
+stack_grow
+start_subparse
+sub_crush_depth
+sv_2bool
+sv_2cv
+sv_2io
+sv_2iv
+sv_2mortal
+sv_2nv
+sv_2pv
+sv_2uv
+sv_add_arena
+sv_backoff
+sv_bless
+sv_catpv
+sv_catpv_mg
+sv_catpvf
+sv_catpvf_mg
+sv_catpvn
+sv_catpvn_mg
+sv_catsv
+sv_catsv_mg
+sv_chop
+sv_clean_all
+sv_clean_objs
+sv_clear
+sv_cmp
+sv_cmp_locale
+sv_collxfrm
+sv_compile_2op
+sv_dec
+sv_derived_from
+sv_dump
+sv_eq
+sv_free
+sv_free_arenas
+sv_gets
+sv_grow
+sv_inc
+sv_insert
+sv_isa
+sv_isobject
+sv_iv
+sv_len
+sv_magic
+sv_mortalcopy
+sv_newmortal
+sv_newref
+sv_nv
+sv_peek
+sv_pvn
+sv_pvn_force
+sv_ref
+sv_reftype
+sv_replace
+sv_report_used
+sv_reset
+sv_setiv
+sv_setiv_mg
+sv_setnv
+sv_setnv_mg
+sv_setptrobj
+sv_setpv
+sv_setpv_mg
+sv_setpvf
+sv_setpvf_mg
+sv_setpviv
+sv_setpviv_mg
+sv_setpvn
+sv_setpvn_mg
+sv_setref_iv
+sv_setref_nv
+sv_setref_pv
+sv_setref_pvn
+sv_setsv
+sv_setsv_mg
+sv_setuv
+sv_setuv_mg
+sv_taint
+sv_tainted
+sv_true
+sv_unmagic
+sv_unref
+sv_untaint
+sv_upgrade
+sv_usepvn
+sv_usepvn_mg
+sv_uv
+sv_vcatpvfn
+sv_vsetpvfn
+taint_env
+taint_proper
+too_few_arguments
+too_many_arguments
+unlnk
+unlock_condpair
+unshare_hek
+unsharepvn
+utilize
+wait4pid
+warn
+watch
+whichsig
+yydestruct
+yyerror
+yylex
+yyparse
+yywarn
diff --git a/contrib/perl5/globals.c b/contrib/perl5/globals.c
new file mode 100644
index 000000000000..1d8ef9272d2f
--- /dev/null
+++ b/contrib/perl5/globals.c
@@ -0,0 +1,1471 @@
+#include "INTERN.h"
+#include "perl.h"
+
+#ifdef PERL_OBJECT
+#undef pp_null
+#define pp_null CPerlObj::Perl_pp_null
+#undef pp_stub
+#define pp_stub CPerlObj::Perl_pp_stub
+#undef pp_scalar
+#define pp_scalar CPerlObj::Perl_pp_scalar
+#undef pp_pushmark
+#define pp_pushmark CPerlObj::Perl_pp_pushmark
+#undef pp_wantarray
+#define pp_wantarray CPerlObj::Perl_pp_wantarray
+#undef pp_const
+#define pp_const CPerlObj::Perl_pp_const
+#undef pp_gvsv
+#define pp_gvsv CPerlObj::Perl_pp_gvsv
+#undef pp_gv
+#define pp_gv CPerlObj::Perl_pp_gv
+#undef pp_gelem
+#define pp_gelem CPerlObj::Perl_pp_gelem
+#undef pp_padsv
+#define pp_padsv CPerlObj::Perl_pp_padsv
+#undef pp_padav
+#define pp_padav CPerlObj::Perl_pp_padav
+#undef pp_padhv
+#define pp_padhv CPerlObj::Perl_pp_padhv
+#undef pp_padany
+#define pp_padany CPerlObj::Perl_pp_padany
+#undef pp_pushre
+#define pp_pushre CPerlObj::Perl_pp_pushre
+#undef pp_rv2gv
+#define pp_rv2gv CPerlObj::Perl_pp_rv2gv
+#undef pp_rv2sv
+#define pp_rv2sv CPerlObj::Perl_pp_rv2sv
+#undef pp_av2arylen
+#define pp_av2arylen CPerlObj::Perl_pp_av2arylen
+#undef pp_rv2cv
+#define pp_rv2cv CPerlObj::Perl_pp_rv2cv
+#undef pp_anoncode
+#define pp_anoncode CPerlObj::Perl_pp_anoncode
+#undef pp_prototype
+#define pp_prototype CPerlObj::Perl_pp_prototype
+#undef pp_refgen
+#define pp_refgen CPerlObj::Perl_pp_refgen
+#undef pp_srefgen
+#define pp_srefgen CPerlObj::Perl_pp_srefgen
+#undef pp_ref
+#define pp_ref CPerlObj::Perl_pp_ref
+#undef pp_bless
+#define pp_bless CPerlObj::Perl_pp_bless
+#undef pp_backtick
+#define pp_backtick CPerlObj::Perl_pp_backtick
+#undef pp_glob
+#define pp_glob CPerlObj::Perl_pp_glob
+#undef pp_readline
+#define pp_readline CPerlObj::Perl_pp_readline
+#undef pp_rcatline
+#define pp_rcatline CPerlObj::Perl_pp_rcatline
+#undef pp_regcmaybe
+#define pp_regcmaybe CPerlObj::Perl_pp_regcmaybe
+#undef pp_regcreset
+#define pp_regcreset CPerlObj::Perl_pp_regcreset
+#undef pp_regcomp
+#define pp_regcomp CPerlObj::Perl_pp_regcomp
+#undef pp_match
+#define pp_match CPerlObj::Perl_pp_match
+#undef pp_qr
+#define pp_qr CPerlObj::Perl_pp_qr
+#undef pp_subst
+#define pp_subst CPerlObj::Perl_pp_subst
+#undef pp_substcont
+#define pp_substcont CPerlObj::Perl_pp_substcont
+#undef pp_trans
+#define pp_trans CPerlObj::Perl_pp_trans
+#undef pp_sassign
+#define pp_sassign CPerlObj::Perl_pp_sassign
+#undef pp_aassign
+#define pp_aassign CPerlObj::Perl_pp_aassign
+#undef pp_chop
+#define pp_chop CPerlObj::Perl_pp_chop
+#undef pp_schop
+#define pp_schop CPerlObj::Perl_pp_schop
+#undef pp_chomp
+#define pp_chomp CPerlObj::Perl_pp_chomp
+#undef pp_schomp
+#define pp_schomp CPerlObj::Perl_pp_schomp
+#undef pp_defined
+#define pp_defined CPerlObj::Perl_pp_defined
+#undef pp_undef
+#define pp_undef CPerlObj::Perl_pp_undef
+#undef pp_study
+#define pp_study CPerlObj::Perl_pp_study
+#undef pp_pos
+#define pp_pos CPerlObj::Perl_pp_pos
+#undef pp_preinc
+#define pp_preinc CPerlObj::Perl_pp_preinc
+#undef pp_i_preinc
+#define pp_i_preinc CPerlObj::Perl_pp_preinc
+#undef pp_predec
+#define pp_predec CPerlObj::Perl_pp_predec
+#undef pp_i_predec
+#define pp_i_predec CPerlObj::Perl_pp_predec
+#undef pp_postinc
+#define pp_postinc CPerlObj::Perl_pp_postinc
+#undef pp_i_postinc
+#define pp_i_postinc CPerlObj::Perl_pp_postinc
+#undef pp_postdec
+#define pp_postdec CPerlObj::Perl_pp_postdec
+#undef pp_i_postdec
+#define pp_i_postdec CPerlObj::Perl_pp_postdec
+#undef pp_pow
+#define pp_pow CPerlObj::Perl_pp_pow
+#undef pp_multiply
+#define pp_multiply CPerlObj::Perl_pp_multiply
+#undef pp_i_multiply
+#define pp_i_multiply CPerlObj::Perl_pp_i_multiply
+#undef pp_divide
+#define pp_divide CPerlObj::Perl_pp_divide
+#undef pp_i_divide
+#define pp_i_divide CPerlObj::Perl_pp_i_divide
+#undef pp_modulo
+#define pp_modulo CPerlObj::Perl_pp_modulo
+#undef pp_i_modulo
+#define pp_i_modulo CPerlObj::Perl_pp_i_modulo
+#undef pp_repeat
+#define pp_repeat CPerlObj::Perl_pp_repeat
+#undef pp_add
+#define pp_add CPerlObj::Perl_pp_add
+#undef pp_i_add
+#define pp_i_add CPerlObj::Perl_pp_i_add
+#undef pp_subtract
+#define pp_subtract CPerlObj::Perl_pp_subtract
+#undef pp_i_subtract
+#define pp_i_subtract CPerlObj::Perl_pp_i_subtract
+#undef pp_concat
+#define pp_concat CPerlObj::Perl_pp_concat
+#undef pp_stringify
+#define pp_stringify CPerlObj::Perl_pp_stringify
+#undef pp_left_shift
+#define pp_left_shift CPerlObj::Perl_pp_left_shift
+#undef pp_right_shift
+#define pp_right_shift CPerlObj::Perl_pp_right_shift
+#undef pp_lt
+#define pp_lt CPerlObj::Perl_pp_lt
+#undef pp_i_lt
+#define pp_i_lt CPerlObj::Perl_pp_i_lt
+#undef pp_gt
+#define pp_gt CPerlObj::Perl_pp_gt
+#undef pp_i_gt
+#define pp_i_gt CPerlObj::Perl_pp_i_gt
+#undef pp_le
+#define pp_le CPerlObj::Perl_pp_le
+#undef pp_i_le
+#define pp_i_le CPerlObj::Perl_pp_i_le
+#undef pp_ge
+#define pp_ge CPerlObj::Perl_pp_ge
+#undef pp_i_ge
+#define pp_i_ge CPerlObj::Perl_pp_i_ge
+#undef pp_eq
+#define pp_eq CPerlObj::Perl_pp_eq
+#undef pp_i_eq
+#define pp_i_eq CPerlObj::Perl_pp_i_eq
+#undef pp_ne
+#define pp_ne CPerlObj::Perl_pp_ne
+#undef pp_i_ne
+#define pp_i_ne CPerlObj::Perl_pp_i_ne
+#undef pp_ncmp
+#define pp_ncmp CPerlObj::Perl_pp_ncmp
+#undef pp_i_ncmp
+#define pp_i_ncmp CPerlObj::Perl_pp_i_ncmp
+#undef pp_slt
+#define pp_slt CPerlObj::Perl_pp_slt
+#undef pp_sgt
+#define pp_sgt CPerlObj::Perl_pp_sgt
+#undef pp_sle
+#define pp_sle CPerlObj::Perl_pp_sle
+#undef pp_sge
+#define pp_sge CPerlObj::Perl_pp_sge
+#undef pp_seq
+#define pp_seq CPerlObj::Perl_pp_seq
+#undef pp_sne
+#define pp_sne CPerlObj::Perl_pp_sne
+#undef pp_scmp
+#define pp_scmp CPerlObj::Perl_pp_scmp
+#undef pp_bit_and
+#define pp_bit_and CPerlObj::Perl_pp_bit_and
+#undef pp_bit_xor
+#define pp_bit_xor CPerlObj::Perl_pp_bit_xor
+#undef pp_bit_or
+#define pp_bit_or CPerlObj::Perl_pp_bit_or
+#undef pp_negate
+#define pp_negate CPerlObj::Perl_pp_negate
+#undef pp_i_negate
+#define pp_i_negate CPerlObj::Perl_pp_i_negate
+#undef pp_not
+#define pp_not CPerlObj::Perl_pp_not
+#undef pp_complement
+#define pp_complement CPerlObj::Perl_pp_complement
+#undef pp_atan2
+#define pp_atan2 CPerlObj::Perl_pp_atan2
+#undef pp_sin
+#define pp_sin CPerlObj::Perl_pp_sin
+#undef pp_cos
+#define pp_cos CPerlObj::Perl_pp_cos
+#undef pp_rand
+#define pp_rand CPerlObj::Perl_pp_rand
+#undef pp_srand
+#define pp_srand CPerlObj::Perl_pp_srand
+#undef pp_exp
+#define pp_exp CPerlObj::Perl_pp_exp
+#undef pp_log
+#define pp_log CPerlObj::Perl_pp_log
+#undef pp_sqrt
+#define pp_sqrt CPerlObj::Perl_pp_sqrt
+#undef pp_int
+#define pp_int CPerlObj::Perl_pp_int
+#undef pp_hex
+#define pp_hex CPerlObj::Perl_pp_hex
+#undef pp_oct
+#define pp_oct CPerlObj::Perl_pp_oct
+#undef pp_abs
+#define pp_abs CPerlObj::Perl_pp_abs
+#undef pp_length
+#define pp_length CPerlObj::Perl_pp_length
+#undef pp_substr
+#define pp_substr CPerlObj::Perl_pp_substr
+#undef pp_vec
+#define pp_vec CPerlObj::Perl_pp_vec
+#undef pp_index
+#define pp_index CPerlObj::Perl_pp_index
+#undef pp_rindex
+#define pp_rindex CPerlObj::Perl_pp_rindex
+#undef pp_sprintf
+#define pp_sprintf CPerlObj::Perl_pp_sprintf
+#undef pp_formline
+#define pp_formline CPerlObj::Perl_pp_formline
+#undef pp_ord
+#define pp_ord CPerlObj::Perl_pp_ord
+#undef pp_chr
+#define pp_chr CPerlObj::Perl_pp_chr
+#undef pp_crypt
+#define pp_crypt CPerlObj::Perl_pp_crypt
+#undef pp_ucfirst
+#define pp_ucfirst CPerlObj::Perl_pp_ucfirst
+#undef pp_lcfirst
+#define pp_lcfirst CPerlObj::Perl_pp_lcfirst
+#undef pp_uc
+#define pp_uc CPerlObj::Perl_pp_uc
+#undef pp_lc
+#define pp_lc CPerlObj::Perl_pp_lc
+#undef pp_quotemeta
+#define pp_quotemeta CPerlObj::Perl_pp_quotemeta
+#undef pp_rv2av
+#define pp_rv2av CPerlObj::Perl_pp_rv2av
+#undef pp_aelemfast
+#define pp_aelemfast CPerlObj::Perl_pp_aelemfast
+#undef pp_aelem
+#define pp_aelem CPerlObj::Perl_pp_aelem
+#undef pp_aslice
+#define pp_aslice CPerlObj::Perl_pp_aslice
+#undef pp_each
+#define pp_each CPerlObj::Perl_pp_each
+#undef pp_values
+#define pp_values CPerlObj::Perl_pp_values
+#undef pp_keys
+#define pp_keys CPerlObj::Perl_pp_keys
+#undef pp_delete
+#define pp_delete CPerlObj::Perl_pp_delete
+#undef pp_exists
+#define pp_exists CPerlObj::Perl_pp_exists
+#undef pp_rv2hv
+#define pp_rv2hv CPerlObj::Perl_pp_rv2hv
+#undef pp_helem
+#define pp_helem CPerlObj::Perl_pp_helem
+#undef pp_hslice
+#define pp_hslice CPerlObj::Perl_pp_hslice
+#undef pp_unpack
+#define pp_unpack CPerlObj::Perl_pp_unpack
+#undef pp_pack
+#define pp_pack CPerlObj::Perl_pp_pack
+#undef pp_split
+#define pp_split CPerlObj::Perl_pp_split
+#undef pp_join
+#define pp_join CPerlObj::Perl_pp_join
+#undef pp_list
+#define pp_list CPerlObj::Perl_pp_list
+#undef pp_lslice
+#define pp_lslice CPerlObj::Perl_pp_lslice
+#undef pp_anonlist
+#define pp_anonlist CPerlObj::Perl_pp_anonlist
+#undef pp_anonhash
+#define pp_anonhash CPerlObj::Perl_pp_anonhash
+#undef pp_splice
+#define pp_splice CPerlObj::Perl_pp_splice
+#undef pp_push
+#define pp_push CPerlObj::Perl_pp_push
+#undef pp_pop
+#define pp_pop CPerlObj::Perl_pp_pop
+#undef pp_shift
+#define pp_shift CPerlObj::Perl_pp_shift
+#undef pp_unshift
+#define pp_unshift CPerlObj::Perl_pp_unshift
+#undef pp_sort
+#define pp_sort CPerlObj::Perl_pp_sort
+#undef pp_reverse
+#define pp_reverse CPerlObj::Perl_pp_reverse
+#undef pp_grepstart
+#define pp_grepstart CPerlObj::Perl_pp_grepstart
+#undef pp_grepwhile
+#define pp_grepwhile CPerlObj::Perl_pp_grepwhile
+#undef pp_mapstart
+#define pp_mapstart CPerlObj::Perl_pp_mapstart
+#undef pp_mapwhile
+#define pp_mapwhile CPerlObj::Perl_pp_mapwhile
+#undef pp_range
+#define pp_range CPerlObj::Perl_pp_range
+#undef pp_flip
+#define pp_flip CPerlObj::Perl_pp_flip
+#undef pp_flop
+#define pp_flop CPerlObj::Perl_pp_flop
+#undef pp_and
+#define pp_and CPerlObj::Perl_pp_and
+#undef pp_or
+#define pp_or CPerlObj::Perl_pp_or
+#undef pp_xor
+#define pp_xor CPerlObj::Perl_pp_xor
+#undef pp_cond_expr
+#define pp_cond_expr CPerlObj::Perl_pp_cond_expr
+#undef pp_andassign
+#define pp_andassign CPerlObj::Perl_pp_andassign
+#undef pp_orassign
+#define pp_orassign CPerlObj::Perl_pp_orassign
+#undef pp_method
+#define pp_method CPerlObj::Perl_pp_method
+#undef pp_entersub
+#define pp_entersub CPerlObj::Perl_pp_entersub
+#undef pp_leavesub
+#define pp_leavesub CPerlObj::Perl_pp_leavesub
+#undef pp_caller
+#define pp_caller CPerlObj::Perl_pp_caller
+#undef pp_warn
+#define pp_warn CPerlObj::Perl_pp_warn
+#undef pp_die
+#define pp_die CPerlObj::Perl_pp_die
+#undef pp_reset
+#define pp_reset CPerlObj::Perl_pp_reset
+#undef pp_lineseq
+#define pp_lineseq CPerlObj::Perl_pp_lineseq
+#undef pp_nextstate
+#define pp_nextstate CPerlObj::Perl_pp_nextstate
+#undef pp_dbstate
+#define pp_dbstate CPerlObj::Perl_pp_dbstate
+#undef pp_unstack
+#define pp_unstack CPerlObj::Perl_pp_unstack
+#undef pp_enter
+#define pp_enter CPerlObj::Perl_pp_enter
+#undef pp_leave
+#define pp_leave CPerlObj::Perl_pp_leave
+#undef pp_scope
+#define pp_scope CPerlObj::Perl_pp_scope
+#undef pp_enteriter
+#define pp_enteriter CPerlObj::Perl_pp_enteriter
+#undef pp_iter
+#define pp_iter CPerlObj::Perl_pp_iter
+#undef pp_enterloop
+#define pp_enterloop CPerlObj::Perl_pp_enterloop
+#undef pp_leaveloop
+#define pp_leaveloop CPerlObj::Perl_pp_leaveloop
+#undef pp_return
+#define pp_return CPerlObj::Perl_pp_return
+#undef pp_last
+#define pp_last CPerlObj::Perl_pp_last
+#undef pp_next
+#define pp_next CPerlObj::Perl_pp_next
+#undef pp_redo
+#define pp_redo CPerlObj::Perl_pp_redo
+#undef pp_dump
+#define pp_dump CPerlObj::Perl_pp_dump
+#undef pp_goto
+#define pp_goto CPerlObj::Perl_pp_goto
+#undef pp_exit
+#define pp_exit CPerlObj::Perl_pp_exit
+#undef pp_open
+#define pp_open CPerlObj::Perl_pp_open
+#undef pp_close
+#define pp_close CPerlObj::Perl_pp_close
+#undef pp_pipe_op
+#define pp_pipe_op CPerlObj::Perl_pp_pipe_op
+#undef pp_fileno
+#define pp_fileno CPerlObj::Perl_pp_fileno
+#undef pp_umask
+#define pp_umask CPerlObj::Perl_pp_umask
+#undef pp_binmode
+#define pp_binmode CPerlObj::Perl_pp_binmode
+#undef pp_tie
+#define pp_tie CPerlObj::Perl_pp_tie
+#undef pp_untie
+#define pp_untie CPerlObj::Perl_pp_untie
+#undef pp_tied
+#define pp_tied CPerlObj::Perl_pp_tied
+#undef pp_dbmopen
+#define pp_dbmopen CPerlObj::Perl_pp_dbmopen
+#undef pp_dbmclose
+#define pp_dbmclose CPerlObj::Perl_pp_dbmclose
+#undef pp_sselect
+#define pp_sselect CPerlObj::Perl_pp_sselect
+#undef pp_select
+#define pp_select CPerlObj::Perl_pp_select
+#undef pp_getc
+#define pp_getc CPerlObj::Perl_pp_getc
+#undef pp_read
+#define pp_read CPerlObj::Perl_pp_read
+#undef pp_enterwrite
+#define pp_enterwrite CPerlObj::Perl_pp_enterwrite
+#undef pp_leavewrite
+#define pp_leavewrite CPerlObj::Perl_pp_leavewrite
+#undef pp_prtf
+#define pp_prtf CPerlObj::Perl_pp_prtf
+#undef pp_print
+#define pp_print CPerlObj::Perl_pp_print
+#undef pp_sysopen
+#define pp_sysopen CPerlObj::Perl_pp_sysopen
+#undef pp_sysseek
+#define pp_sysseek CPerlObj::Perl_pp_sysseek
+#undef pp_sysread
+#define pp_sysread CPerlObj::Perl_pp_sysread
+#undef pp_syswrite
+#define pp_syswrite CPerlObj::Perl_pp_syswrite
+#undef pp_send
+#define pp_send CPerlObj::Perl_pp_send
+#undef pp_recv
+#define pp_recv CPerlObj::Perl_pp_recv
+#undef pp_eof
+#define pp_eof CPerlObj::Perl_pp_eof
+#undef pp_tell
+#define pp_tell CPerlObj::Perl_pp_tell
+#undef pp_seek
+#define pp_seek CPerlObj::Perl_pp_seek
+#undef pp_truncate
+#define pp_truncate CPerlObj::Perl_pp_truncate
+#undef pp_fcntl
+#define pp_fcntl CPerlObj::Perl_pp_fcntl
+#undef pp_ioctl
+#define pp_ioctl CPerlObj::Perl_pp_ioctl
+#undef pp_flock
+#define pp_flock CPerlObj::Perl_pp_flock
+#undef pp_socket
+#define pp_socket CPerlObj::Perl_pp_socket
+#undef pp_sockpair
+#define pp_sockpair CPerlObj::Perl_pp_sockpair
+#undef pp_bind
+#define pp_bind CPerlObj::Perl_pp_bind
+#undef pp_connect
+#define pp_connect CPerlObj::Perl_pp_connect
+#undef pp_listen
+#define pp_listen CPerlObj::Perl_pp_listen
+#undef pp_accept
+#define pp_accept CPerlObj::Perl_pp_accept
+#undef pp_shutdown
+#define pp_shutdown CPerlObj::Perl_pp_shutdown
+#undef pp_gsockopt
+#define pp_gsockopt CPerlObj::Perl_pp_gsockopt
+#undef pp_ssockopt
+#define pp_ssockopt CPerlObj::Perl_pp_ssockopt
+#undef pp_getsockname
+#define pp_getsockname CPerlObj::Perl_pp_getsockname
+#undef pp_getpeername
+#define pp_getpeername CPerlObj::Perl_pp_getpeername
+#undef pp_lstat
+#define pp_lstat CPerlObj::Perl_pp_lstat
+#undef pp_stat
+#define pp_stat CPerlObj::Perl_pp_stat
+#undef pp_ftrread
+#define pp_ftrread CPerlObj::Perl_pp_ftrread
+#undef pp_ftrwrite
+#define pp_ftrwrite CPerlObj::Perl_pp_ftrwrite
+#undef pp_ftrexec
+#define pp_ftrexec CPerlObj::Perl_pp_ftrexec
+#undef pp_fteread
+#define pp_fteread CPerlObj::Perl_pp_fteread
+#undef pp_ftewrite
+#define pp_ftewrite CPerlObj::Perl_pp_ftewrite
+#undef pp_fteexec
+#define pp_fteexec CPerlObj::Perl_pp_fteexec
+#undef pp_ftis
+#define pp_ftis CPerlObj::Perl_pp_ftis
+#undef pp_fteowned
+#define pp_fteowned CPerlObj::Perl_pp_fteowned
+#undef pp_ftrowned
+#define pp_ftrowned CPerlObj::Perl_pp_ftrowned
+#undef pp_ftzero
+#define pp_ftzero CPerlObj::Perl_pp_ftzero
+#undef pp_ftsize
+#define pp_ftsize CPerlObj::Perl_pp_ftsize
+#undef pp_ftmtime
+#define pp_ftmtime CPerlObj::Perl_pp_ftmtime
+#undef pp_ftatime
+#define pp_ftatime CPerlObj::Perl_pp_ftatime
+#undef pp_ftctime
+#define pp_ftctime CPerlObj::Perl_pp_ftctime
+#undef pp_ftsock
+#define pp_ftsock CPerlObj::Perl_pp_ftsock
+#undef pp_ftchr
+#define pp_ftchr CPerlObj::Perl_pp_ftchr
+#undef pp_ftblk
+#define pp_ftblk CPerlObj::Perl_pp_ftblk
+#undef pp_ftfile
+#define pp_ftfile CPerlObj::Perl_pp_ftfile
+#undef pp_ftdir
+#define pp_ftdir CPerlObj::Perl_pp_ftdir
+#undef pp_ftpipe
+#define pp_ftpipe CPerlObj::Perl_pp_ftpipe
+#undef pp_ftlink
+#define pp_ftlink CPerlObj::Perl_pp_ftlink
+#undef pp_ftsuid
+#define pp_ftsuid CPerlObj::Perl_pp_ftsuid
+#undef pp_ftsgid
+#define pp_ftsgid CPerlObj::Perl_pp_ftsgid
+#undef pp_ftsvtx
+#define pp_ftsvtx CPerlObj::Perl_pp_ftsvtx
+#undef pp_fttty
+#define pp_fttty CPerlObj::Perl_pp_fttty
+#undef pp_fttext
+#define pp_fttext CPerlObj::Perl_pp_fttext
+#undef pp_ftbinary
+#define pp_ftbinary CPerlObj::Perl_pp_ftbinary
+#undef pp_chdir
+#define pp_chdir CPerlObj::Perl_pp_chdir
+#undef pp_chown
+#define pp_chown CPerlObj::Perl_pp_chown
+#undef pp_chroot
+#define pp_chroot CPerlObj::Perl_pp_chroot
+#undef pp_unlink
+#define pp_unlink CPerlObj::Perl_pp_unlink
+#undef pp_chmod
+#define pp_chmod CPerlObj::Perl_pp_chmod
+#undef pp_utime
+#define pp_utime CPerlObj::Perl_pp_utime
+#undef pp_rename
+#define pp_rename CPerlObj::Perl_pp_rename
+#undef pp_link
+#define pp_link CPerlObj::Perl_pp_link
+#undef pp_symlink
+#define pp_symlink CPerlObj::Perl_pp_symlink
+#undef pp_readlink
+#define pp_readlink CPerlObj::Perl_pp_readlink
+#undef pp_mkdir
+#define pp_mkdir CPerlObj::Perl_pp_mkdir
+#undef pp_rmdir
+#define pp_rmdir CPerlObj::Perl_pp_rmdir
+#undef pp_open_dir
+#define pp_open_dir CPerlObj::Perl_pp_open_dir
+#undef pp_readdir
+#define pp_readdir CPerlObj::Perl_pp_readdir
+#undef pp_telldir
+#define pp_telldir CPerlObj::Perl_pp_telldir
+#undef pp_seekdir
+#define pp_seekdir CPerlObj::Perl_pp_seekdir
+#undef pp_rewinddir
+#define pp_rewinddir CPerlObj::Perl_pp_rewinddir
+#undef pp_closedir
+#define pp_closedir CPerlObj::Perl_pp_closedir
+#undef pp_fork
+#define pp_fork CPerlObj::Perl_pp_fork
+#undef pp_wait
+#define pp_wait CPerlObj::Perl_pp_wait
+#undef pp_waitpid
+#define pp_waitpid CPerlObj::Perl_pp_waitpid
+#undef pp_system
+#define pp_system CPerlObj::Perl_pp_system
+#undef pp_exec
+#define pp_exec CPerlObj::Perl_pp_exec
+#undef pp_kill
+#define pp_kill CPerlObj::Perl_pp_kill
+#undef pp_getppid
+#define pp_getppid CPerlObj::Perl_pp_getppid
+#undef pp_getpgrp
+#define pp_getpgrp CPerlObj::Perl_pp_getpgrp
+#undef pp_setpgrp
+#define pp_setpgrp CPerlObj::Perl_pp_setpgrp
+#undef pp_getpriority
+#define pp_getpriority CPerlObj::Perl_pp_getpriority
+#undef pp_setpriority
+#define pp_setpriority CPerlObj::Perl_pp_setpriority
+#undef pp_time
+#define pp_time CPerlObj::Perl_pp_time
+#undef pp_tms
+#define pp_tms CPerlObj::Perl_pp_tms
+#undef pp_localtime
+#define pp_localtime CPerlObj::Perl_pp_localtime
+#undef pp_gmtime
+#define pp_gmtime CPerlObj::Perl_pp_gmtime
+#undef pp_alarm
+#define pp_alarm CPerlObj::Perl_pp_alarm
+#undef pp_sleep
+#define pp_sleep CPerlObj::Perl_pp_sleep
+#undef pp_shmget
+#define pp_shmget CPerlObj::Perl_pp_shmget
+#undef pp_shmctl
+#define pp_shmctl CPerlObj::Perl_pp_shmctl
+#undef pp_shmread
+#define pp_shmread CPerlObj::Perl_pp_shmread
+#undef pp_shmwrite
+#define pp_shmwrite CPerlObj::Perl_pp_shmwrite
+#undef pp_msgget
+#define pp_msgget CPerlObj::Perl_pp_msgget
+#undef pp_msgctl
+#define pp_msgctl CPerlObj::Perl_pp_msgctl
+#undef pp_msgsnd
+#define pp_msgsnd CPerlObj::Perl_pp_msgsnd
+#undef pp_msgrcv
+#define pp_msgrcv CPerlObj::Perl_pp_msgrcv
+#undef pp_semget
+#define pp_semget CPerlObj::Perl_pp_semget
+#undef pp_semctl
+#define pp_semctl CPerlObj::Perl_pp_semctl
+#undef pp_semop
+#define pp_semop CPerlObj::Perl_pp_semop
+#undef pp_require
+#define pp_require CPerlObj::Perl_pp_require
+#undef pp_dofile
+#define pp_dofile CPerlObj::Perl_pp_dofile
+#undef pp_entereval
+#define pp_entereval CPerlObj::Perl_pp_entereval
+#undef pp_leaveeval
+#define pp_leaveeval CPerlObj::Perl_pp_leaveeval
+#undef pp_entertry
+#define pp_entertry CPerlObj::Perl_pp_entertry
+#undef pp_leavetry
+#define pp_leavetry CPerlObj::Perl_pp_leavetry
+#undef pp_ghbyname
+#define pp_ghbyname CPerlObj::Perl_pp_ghbyname
+#undef pp_ghbyaddr
+#define pp_ghbyaddr CPerlObj::Perl_pp_ghbyaddr
+#undef pp_ghostent
+#define pp_ghostent CPerlObj::Perl_pp_ghostent
+#undef pp_gnbyname
+#define pp_gnbyname CPerlObj::Perl_pp_gnbyname
+#undef pp_gnbyaddr
+#define pp_gnbyaddr CPerlObj::Perl_pp_gnbyaddr
+#undef pp_gnetent
+#define pp_gnetent CPerlObj::Perl_pp_gnetent
+#undef pp_gpbyname
+#define pp_gpbyname CPerlObj::Perl_pp_gpbyname
+#undef pp_gpbynumber
+#define pp_gpbynumber CPerlObj::Perl_pp_gpbynumber
+#undef pp_gprotoent
+#define pp_gprotoent CPerlObj::Perl_pp_gprotoent
+#undef pp_gsbyname
+#define pp_gsbyname CPerlObj::Perl_pp_gsbyname
+#undef pp_gsbyport
+#define pp_gsbyport CPerlObj::Perl_pp_gsbyport
+#undef pp_gservent
+#define pp_gservent CPerlObj::Perl_pp_gservent
+#undef pp_shostent
+#define pp_shostent CPerlObj::Perl_pp_shostent
+#undef pp_snetent
+#define pp_snetent CPerlObj::Perl_pp_snetent
+#undef pp_sprotoent
+#define pp_sprotoent CPerlObj::Perl_pp_sprotoent
+#undef pp_sservent
+#define pp_sservent CPerlObj::Perl_pp_sservent
+#undef pp_ehostent
+#define pp_ehostent CPerlObj::Perl_pp_ehostent
+#undef pp_enetent
+#define pp_enetent CPerlObj::Perl_pp_enetent
+#undef pp_eprotoent
+#define pp_eprotoent CPerlObj::Perl_pp_eprotoent
+#undef pp_eservent
+#define pp_eservent CPerlObj::Perl_pp_eservent
+#undef pp_gpwnam
+#define pp_gpwnam CPerlObj::Perl_pp_gpwnam
+#undef pp_gpwuid
+#define pp_gpwuid CPerlObj::Perl_pp_gpwuid
+#undef pp_gpwent
+#define pp_gpwent CPerlObj::Perl_pp_gpwent
+#undef pp_spwent
+#define pp_spwent CPerlObj::Perl_pp_spwent
+#undef pp_epwent
+#define pp_epwent CPerlObj::Perl_pp_epwent
+#undef pp_ggrnam
+#define pp_ggrnam CPerlObj::Perl_pp_ggrnam
+#undef pp_ggrgid
+#define pp_ggrgid CPerlObj::Perl_pp_ggrgid
+#undef pp_ggrent
+#define pp_ggrent CPerlObj::Perl_pp_ggrent
+#undef pp_sgrent
+#define pp_sgrent CPerlObj::Perl_pp_sgrent
+#undef pp_egrent
+#define pp_egrent CPerlObj::Perl_pp_egrent
+#undef pp_getlogin
+#define pp_getlogin CPerlObj::Perl_pp_getlogin
+#undef pp_syscall
+#define pp_syscall CPerlObj::Perl_pp_syscall
+#undef pp_lock
+#define pp_lock CPerlObj::Perl_pp_lock
+#undef pp_threadsv
+#define pp_threadsv CPerlObj::Perl_pp_threadsv
+
+OP * (CPERLscope(*check)[]) _((OP *op)) = {
+ ck_null, /* null */
+ ck_null, /* stub */
+ ck_fun, /* scalar */
+ ck_null, /* pushmark */
+ ck_null, /* wantarray */
+ ck_svconst, /* const */
+ ck_null, /* gvsv */
+ ck_null, /* gv */
+ ck_null, /* gelem */
+ ck_null, /* padsv */
+ ck_null, /* padav */
+ ck_null, /* padhv */
+ ck_null, /* padany */
+ ck_null, /* pushre */
+ ck_rvconst, /* rv2gv */
+ ck_rvconst, /* rv2sv */
+ ck_null, /* av2arylen */
+ ck_rvconst, /* rv2cv */
+ ck_anoncode, /* anoncode */
+ ck_null, /* prototype */
+ ck_spair, /* refgen */
+ ck_null, /* srefgen */
+ ck_fun, /* ref */
+ ck_fun, /* bless */
+ ck_null, /* backtick */
+ ck_glob, /* glob */
+ ck_null, /* readline */
+ ck_null, /* rcatline */
+ ck_fun, /* regcmaybe */
+ ck_fun, /* regcreset */
+ ck_null, /* regcomp */
+ ck_match, /* match */
+ ck_match, /* qr */
+ ck_null, /* subst */
+ ck_null, /* substcont */
+ ck_null, /* trans */
+ ck_null, /* sassign */
+ ck_null, /* aassign */
+ ck_spair, /* chop */
+ ck_null, /* schop */
+ ck_spair, /* chomp */
+ ck_null, /* schomp */
+ ck_rfun, /* defined */
+ ck_lfun, /* undef */
+ ck_fun, /* study */
+ ck_lfun, /* pos */
+ ck_lfun, /* preinc */
+ ck_lfun, /* i_preinc */
+ ck_lfun, /* predec */
+ ck_lfun, /* i_predec */
+ ck_lfun, /* postinc */
+ ck_lfun, /* i_postinc */
+ ck_lfun, /* postdec */
+ ck_lfun, /* i_postdec */
+ ck_null, /* pow */
+ ck_null, /* multiply */
+ ck_null, /* i_multiply */
+ ck_null, /* divide */
+ ck_null, /* i_divide */
+ ck_null, /* modulo */
+ ck_null, /* i_modulo */
+ ck_repeat, /* repeat */
+ ck_null, /* add */
+ ck_null, /* i_add */
+ ck_null, /* subtract */
+ ck_null, /* i_subtract */
+ ck_concat, /* concat */
+ ck_fun, /* stringify */
+ ck_bitop, /* left_shift */
+ ck_bitop, /* right_shift */
+ ck_null, /* lt */
+ ck_null, /* i_lt */
+ ck_null, /* gt */
+ ck_null, /* i_gt */
+ ck_null, /* le */
+ ck_null, /* i_le */
+ ck_null, /* ge */
+ ck_null, /* i_ge */
+ ck_null, /* eq */
+ ck_null, /* i_eq */
+ ck_null, /* ne */
+ ck_null, /* i_ne */
+ ck_null, /* ncmp */
+ ck_null, /* i_ncmp */
+ ck_scmp, /* slt */
+ ck_scmp, /* sgt */
+ ck_scmp, /* sle */
+ ck_scmp, /* sge */
+ ck_null, /* seq */
+ ck_null, /* sne */
+ ck_scmp, /* scmp */
+ ck_bitop, /* bit_and */
+ ck_bitop, /* bit_xor */
+ ck_bitop, /* bit_or */
+ ck_null, /* negate */
+ ck_null, /* i_negate */
+ ck_null, /* not */
+ ck_bitop, /* complement */
+ ck_fun, /* atan2 */
+ ck_fun, /* sin */
+ ck_fun, /* cos */
+ ck_fun, /* rand */
+ ck_fun, /* srand */
+ ck_fun, /* exp */
+ ck_fun, /* log */
+ ck_fun, /* sqrt */
+ ck_fun, /* int */
+ ck_fun, /* hex */
+ ck_fun, /* oct */
+ ck_fun, /* abs */
+ ck_lengthconst, /* length */
+ ck_fun, /* substr */
+ ck_fun, /* vec */
+ ck_index, /* index */
+ ck_index, /* rindex */
+ ck_fun_locale, /* sprintf */
+ ck_fun, /* formline */
+ ck_fun, /* ord */
+ ck_fun, /* chr */
+ ck_fun, /* crypt */
+ ck_fun_locale, /* ucfirst */
+ ck_fun_locale, /* lcfirst */
+ ck_fun_locale, /* uc */
+ ck_fun_locale, /* lc */
+ ck_fun, /* quotemeta */
+ ck_rvconst, /* rv2av */
+ ck_null, /* aelemfast */
+ ck_null, /* aelem */
+ ck_null, /* aslice */
+ ck_fun, /* each */
+ ck_fun, /* values */
+ ck_fun, /* keys */
+ ck_delete, /* delete */
+ ck_exists, /* exists */
+ ck_rvconst, /* rv2hv */
+ ck_null, /* helem */
+ ck_null, /* hslice */
+ ck_fun, /* unpack */
+ ck_fun, /* pack */
+ ck_split, /* split */
+ ck_fun, /* join */
+ ck_null, /* list */
+ ck_null, /* lslice */
+ ck_fun, /* anonlist */
+ ck_fun, /* anonhash */
+ ck_fun, /* splice */
+ ck_fun, /* push */
+ ck_shift, /* pop */
+ ck_shift, /* shift */
+ ck_fun, /* unshift */
+ ck_sort, /* sort */
+ ck_fun, /* reverse */
+ ck_grep, /* grepstart */
+ ck_null, /* grepwhile */
+ ck_grep, /* mapstart */
+ ck_null, /* mapwhile */
+ ck_null, /* range */
+ ck_null, /* flip */
+ ck_null, /* flop */
+ ck_null, /* and */
+ ck_null, /* or */
+ ck_null, /* xor */
+ ck_null, /* cond_expr */
+ ck_null, /* andassign */
+ ck_null, /* orassign */
+ ck_null, /* method */
+ ck_subr, /* entersub */
+ ck_null, /* leavesub */
+ ck_fun, /* caller */
+ ck_fun, /* warn */
+ ck_fun, /* die */
+ ck_fun, /* reset */
+ ck_null, /* lineseq */
+ ck_null, /* nextstate */
+ ck_null, /* dbstate */
+ ck_null, /* unstack */
+ ck_null, /* enter */
+ ck_null, /* leave */
+ ck_null, /* scope */
+ ck_null, /* enteriter */
+ ck_null, /* iter */
+ ck_null, /* enterloop */
+ ck_null, /* leaveloop */
+ ck_null, /* return */
+ ck_null, /* last */
+ ck_null, /* next */
+ ck_null, /* redo */
+ ck_null, /* dump */
+ ck_null, /* goto */
+ ck_fun, /* exit */
+ ck_fun, /* open */
+ ck_fun, /* close */
+ ck_fun, /* pipe_op */
+ ck_fun, /* fileno */
+ ck_fun, /* umask */
+ ck_fun, /* binmode */
+ ck_fun, /* tie */
+ ck_fun, /* untie */
+ ck_fun, /* tied */
+ ck_fun, /* dbmopen */
+ ck_fun, /* dbmclose */
+ ck_select, /* sselect */
+ ck_select, /* select */
+ ck_eof, /* getc */
+ ck_fun, /* read */
+ ck_fun, /* enterwrite */
+ ck_null, /* leavewrite */
+ ck_listiob, /* prtf */
+ ck_listiob, /* print */
+ ck_fun, /* sysopen */
+ ck_fun, /* sysseek */
+ ck_fun, /* sysread */
+ ck_fun, /* syswrite */
+ ck_fun, /* send */
+ ck_fun, /* recv */
+ ck_eof, /* eof */
+ ck_fun, /* tell */
+ ck_fun, /* seek */
+ ck_trunc, /* truncate */
+ ck_fun, /* fcntl */
+ ck_fun, /* ioctl */
+ ck_fun, /* flock */
+ ck_fun, /* socket */
+ ck_fun, /* sockpair */
+ ck_fun, /* bind */
+ ck_fun, /* connect */
+ ck_fun, /* listen */
+ ck_fun, /* accept */
+ ck_fun, /* shutdown */
+ ck_fun, /* gsockopt */
+ ck_fun, /* ssockopt */
+ ck_fun, /* getsockname */
+ ck_fun, /* getpeername */
+ ck_ftst, /* lstat */
+ ck_ftst, /* stat */
+ ck_ftst, /* ftrread */
+ ck_ftst, /* ftrwrite */
+ ck_ftst, /* ftrexec */
+ ck_ftst, /* fteread */
+ ck_ftst, /* ftewrite */
+ ck_ftst, /* fteexec */
+ ck_ftst, /* ftis */
+ ck_ftst, /* fteowned */
+ ck_ftst, /* ftrowned */
+ ck_ftst, /* ftzero */
+ ck_ftst, /* ftsize */
+ ck_ftst, /* ftmtime */
+ ck_ftst, /* ftatime */
+ ck_ftst, /* ftctime */
+ ck_ftst, /* ftsock */
+ ck_ftst, /* ftchr */
+ ck_ftst, /* ftblk */
+ ck_ftst, /* ftfile */
+ ck_ftst, /* ftdir */
+ ck_ftst, /* ftpipe */
+ ck_ftst, /* ftlink */
+ ck_ftst, /* ftsuid */
+ ck_ftst, /* ftsgid */
+ ck_ftst, /* ftsvtx */
+ ck_ftst, /* fttty */
+ ck_ftst, /* fttext */
+ ck_ftst, /* ftbinary */
+ ck_fun, /* chdir */
+ ck_fun, /* chown */
+ ck_fun, /* chroot */
+ ck_fun, /* unlink */
+ ck_fun, /* chmod */
+ ck_fun, /* utime */
+ ck_fun, /* rename */
+ ck_fun, /* link */
+ ck_fun, /* symlink */
+ ck_fun, /* readlink */
+ ck_fun, /* mkdir */
+ ck_fun, /* rmdir */
+ ck_fun, /* open_dir */
+ ck_fun, /* readdir */
+ ck_fun, /* telldir */
+ ck_fun, /* seekdir */
+ ck_fun, /* rewinddir */
+ ck_fun, /* closedir */
+ ck_null, /* fork */
+ ck_null, /* wait */
+ ck_fun, /* waitpid */
+ ck_exec, /* system */
+ ck_exec, /* exec */
+ ck_fun, /* kill */
+ ck_null, /* getppid */
+ ck_fun, /* getpgrp */
+ ck_fun, /* setpgrp */
+ ck_fun, /* getpriority */
+ ck_fun, /* setpriority */
+ ck_null, /* time */
+ ck_null, /* tms */
+ ck_fun, /* localtime */
+ ck_fun, /* gmtime */
+ ck_fun, /* alarm */
+ ck_fun, /* sleep */
+ ck_fun, /* shmget */
+ ck_fun, /* shmctl */
+ ck_fun, /* shmread */
+ ck_fun, /* shmwrite */
+ ck_fun, /* msgget */
+ ck_fun, /* msgctl */
+ ck_fun, /* msgsnd */
+ ck_fun, /* msgrcv */
+ ck_fun, /* semget */
+ ck_fun, /* semctl */
+ ck_fun, /* semop */
+ ck_require, /* require */
+ ck_fun, /* dofile */
+ ck_eval, /* entereval */
+ ck_null, /* leaveeval */
+ ck_null, /* entertry */
+ ck_null, /* leavetry */
+ ck_fun, /* ghbyname */
+ ck_fun, /* ghbyaddr */
+ ck_null, /* ghostent */
+ ck_fun, /* gnbyname */
+ ck_fun, /* gnbyaddr */
+ ck_null, /* gnetent */
+ ck_fun, /* gpbyname */
+ ck_fun, /* gpbynumber */
+ ck_null, /* gprotoent */
+ ck_fun, /* gsbyname */
+ ck_fun, /* gsbyport */
+ ck_null, /* gservent */
+ ck_fun, /* shostent */
+ ck_fun, /* snetent */
+ ck_fun, /* sprotoent */
+ ck_fun, /* sservent */
+ ck_null, /* ehostent */
+ ck_null, /* enetent */
+ ck_null, /* eprotoent */
+ ck_null, /* eservent */
+ ck_fun, /* gpwnam */
+ ck_fun, /* gpwuid */
+ ck_null, /* gpwent */
+ ck_null, /* spwent */
+ ck_null, /* epwent */
+ ck_fun, /* ggrnam */
+ ck_fun, /* ggrgid */
+ ck_null, /* ggrent */
+ ck_null, /* sgrent */
+ ck_null, /* egrent */
+ ck_null, /* getlogin */
+ ck_fun, /* syscall */
+ ck_rfun, /* lock */
+ ck_null, /* threadsv */
+};
+
+OP * (CPERLscope(*ppaddr)[])(ARGSproto) = {
+ pp_null,
+ pp_stub,
+ pp_scalar,
+ pp_pushmark,
+ pp_wantarray,
+ pp_const,
+ pp_gvsv,
+ pp_gv,
+ pp_gelem,
+ pp_padsv,
+ pp_padav,
+ pp_padhv,
+ pp_padany,
+ pp_pushre,
+ pp_rv2gv,
+ pp_rv2sv,
+ pp_av2arylen,
+ pp_rv2cv,
+ pp_anoncode,
+ pp_prototype,
+ pp_refgen,
+ pp_srefgen,
+ pp_ref,
+ pp_bless,
+ pp_backtick,
+ pp_glob,
+ pp_readline,
+ pp_rcatline,
+ pp_regcmaybe,
+ pp_regcreset,
+ pp_regcomp,
+ pp_match,
+ pp_qr,
+ pp_subst,
+ pp_substcont,
+ pp_trans,
+ pp_sassign,
+ pp_aassign,
+ pp_chop,
+ pp_schop,
+ pp_chomp,
+ pp_schomp,
+ pp_defined,
+ pp_undef,
+ pp_study,
+ pp_pos,
+ pp_preinc,
+ pp_i_preinc,
+ pp_predec,
+ pp_i_predec,
+ pp_postinc,
+ pp_i_postinc,
+ pp_postdec,
+ pp_i_postdec,
+ pp_pow,
+ pp_multiply,
+ pp_i_multiply,
+ pp_divide,
+ pp_i_divide,
+ pp_modulo,
+ pp_i_modulo,
+ pp_repeat,
+ pp_add,
+ pp_i_add,
+ pp_subtract,
+ pp_i_subtract,
+ pp_concat,
+ pp_stringify,
+ pp_left_shift,
+ pp_right_shift,
+ pp_lt,
+ pp_i_lt,
+ pp_gt,
+ pp_i_gt,
+ pp_le,
+ pp_i_le,
+ pp_ge,
+ pp_i_ge,
+ pp_eq,
+ pp_i_eq,
+ pp_ne,
+ pp_i_ne,
+ pp_ncmp,
+ pp_i_ncmp,
+ pp_slt,
+ pp_sgt,
+ pp_sle,
+ pp_sge,
+ pp_seq,
+ pp_sne,
+ pp_scmp,
+ pp_bit_and,
+ pp_bit_xor,
+ pp_bit_or,
+ pp_negate,
+ pp_i_negate,
+ pp_not,
+ pp_complement,
+ pp_atan2,
+ pp_sin,
+ pp_cos,
+ pp_rand,
+ pp_srand,
+ pp_exp,
+ pp_log,
+ pp_sqrt,
+ pp_int,
+ pp_hex,
+ pp_oct,
+ pp_abs,
+ pp_length,
+ pp_substr,
+ pp_vec,
+ pp_index,
+ pp_rindex,
+ pp_sprintf,
+ pp_formline,
+ pp_ord,
+ pp_chr,
+ pp_crypt,
+ pp_ucfirst,
+ pp_lcfirst,
+ pp_uc,
+ pp_lc,
+ pp_quotemeta,
+ pp_rv2av,
+ pp_aelemfast,
+ pp_aelem,
+ pp_aslice,
+ pp_each,
+ pp_values,
+ pp_keys,
+ pp_delete,
+ pp_exists,
+ pp_rv2hv,
+ pp_helem,
+ pp_hslice,
+ pp_unpack,
+ pp_pack,
+ pp_split,
+ pp_join,
+ pp_list,
+ pp_lslice,
+ pp_anonlist,
+ pp_anonhash,
+ pp_splice,
+ pp_push,
+ pp_pop,
+ pp_shift,
+ pp_unshift,
+ pp_sort,
+ pp_reverse,
+ pp_grepstart,
+ pp_grepwhile,
+ pp_mapstart,
+ pp_mapwhile,
+ pp_range,
+ pp_flip,
+ pp_flop,
+ pp_and,
+ pp_or,
+ pp_xor,
+ pp_cond_expr,
+ pp_andassign,
+ pp_orassign,
+ pp_method,
+ pp_entersub,
+ pp_leavesub,
+ pp_caller,
+ pp_warn,
+ pp_die,
+ pp_reset,
+ pp_lineseq,
+ pp_nextstate,
+ pp_dbstate,
+ pp_unstack,
+ pp_enter,
+ pp_leave,
+ pp_scope,
+ pp_enteriter,
+ pp_iter,
+ pp_enterloop,
+ pp_leaveloop,
+ pp_return,
+ pp_last,
+ pp_next,
+ pp_redo,
+ pp_dump,
+ pp_goto,
+ pp_exit,
+ pp_open,
+ pp_close,
+ pp_pipe_op,
+ pp_fileno,
+ pp_umask,
+ pp_binmode,
+ pp_tie,
+ pp_untie,
+ pp_tied,
+ pp_dbmopen,
+ pp_dbmclose,
+ pp_sselect,
+ pp_select,
+ pp_getc,
+ pp_read,
+ pp_enterwrite,
+ pp_leavewrite,
+ pp_prtf,
+ pp_print,
+ pp_sysopen,
+ pp_sysseek,
+ pp_sysread,
+ pp_syswrite,
+ pp_send,
+ pp_recv,
+ pp_eof,
+ pp_tell,
+ pp_seek,
+ pp_truncate,
+ pp_fcntl,
+ pp_ioctl,
+ pp_flock,
+ pp_socket,
+ pp_sockpair,
+ pp_bind,
+ pp_connect,
+ pp_listen,
+ pp_accept,
+ pp_shutdown,
+ pp_gsockopt,
+ pp_ssockopt,
+ pp_getsockname,
+ pp_getpeername,
+ pp_lstat,
+ pp_stat,
+ pp_ftrread,
+ pp_ftrwrite,
+ pp_ftrexec,
+ pp_fteread,
+ pp_ftewrite,
+ pp_fteexec,
+ pp_ftis,
+ pp_fteowned,
+ pp_ftrowned,
+ pp_ftzero,
+ pp_ftsize,
+ pp_ftmtime,
+ pp_ftatime,
+ pp_ftctime,
+ pp_ftsock,
+ pp_ftchr,
+ pp_ftblk,
+ pp_ftfile,
+ pp_ftdir,
+ pp_ftpipe,
+ pp_ftlink,
+ pp_ftsuid,
+ pp_ftsgid,
+ pp_ftsvtx,
+ pp_fttty,
+ pp_fttext,
+ pp_ftbinary,
+ pp_chdir,
+ pp_chown,
+ pp_chroot,
+ pp_unlink,
+ pp_chmod,
+ pp_utime,
+ pp_rename,
+ pp_link,
+ pp_symlink,
+ pp_readlink,
+ pp_mkdir,
+ pp_rmdir,
+ pp_open_dir,
+ pp_readdir,
+ pp_telldir,
+ pp_seekdir,
+ pp_rewinddir,
+ pp_closedir,
+ pp_fork,
+ pp_wait,
+ pp_waitpid,
+ pp_system,
+ pp_exec,
+ pp_kill,
+ pp_getppid,
+ pp_getpgrp,
+ pp_setpgrp,
+ pp_getpriority,
+ pp_setpriority,
+ pp_time,
+ pp_tms,
+ pp_localtime,
+ pp_gmtime,
+ pp_alarm,
+ pp_sleep,
+ pp_shmget,
+ pp_shmctl,
+ pp_shmread,
+ pp_shmwrite,
+ pp_msgget,
+ pp_msgctl,
+ pp_msgsnd,
+ pp_msgrcv,
+ pp_semget,
+ pp_semctl,
+ pp_semop,
+ pp_require,
+ pp_dofile,
+ pp_entereval,
+ pp_leaveeval,
+ pp_entertry,
+ pp_leavetry,
+ pp_ghbyname,
+ pp_ghbyaddr,
+ pp_ghostent,
+ pp_gnbyname,
+ pp_gnbyaddr,
+ pp_gnetent,
+ pp_gpbyname,
+ pp_gpbynumber,
+ pp_gprotoent,
+ pp_gsbyname,
+ pp_gsbyport,
+ pp_gservent,
+ pp_shostent,
+ pp_snetent,
+ pp_sprotoent,
+ pp_sservent,
+ pp_ehostent,
+ pp_enetent,
+ pp_eprotoent,
+ pp_eservent,
+ pp_gpwnam,
+ pp_gpwuid,
+ pp_gpwent,
+ pp_spwent,
+ pp_epwent,
+ pp_ggrnam,
+ pp_ggrgid,
+ pp_ggrent,
+ pp_sgrent,
+ pp_egrent,
+ pp_getlogin,
+ pp_syscall,
+ pp_lock,
+ pp_threadsv,
+};
+
+int
+fprintf(PerlIO *stream, const char *format, ...)
+{
+ va_list(arglist);
+ va_start(arglist, format);
+ return PerlIO_vprintf(stream, format, arglist);
+}
+
+#undef PERLVAR
+#define PERLVAR(x, y)
+#undef PERLVARI
+#define PERLVARI(x, y, z) PL_##x = z;
+#undef PERLVARIC
+#define PERLVARIC(x, y, z) PL_##x = z;
+
+CPerlObj::CPerlObj(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
+ IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
+{
+ memset(((char*)this)+sizeof(void*), 0, sizeof(CPerlObj)-sizeof(void*));
+
+#include "thrdvar.h"
+#include "intrpvar.h"
+#include "perlvars.h"
+
+ PL_piMem = ipM;
+ PL_piENV = ipE;
+ PL_piStdIO = ipStd;
+ PL_piLIO = ipLIO;
+ PL_piDir = ipD;
+ PL_piSock = ipS;
+ PL_piProc = ipP;
+}
+
+void*
+CPerlObj::operator new(size_t nSize, IPerlMem *pvtbl)
+{
+ if(pvtbl != NULL)
+ return pvtbl->Malloc(nSize);
+
+ return NULL;
+}
+
+int&
+CPerlObj::ErrorNo(void)
+{
+ return errno;
+}
+
+void
+CPerlObj::Init(void)
+{
+}
+
+#ifdef WIN32 /* XXX why are these needed? */
+bool
+do_exec(char *cmd)
+{
+ return PerlProc_Cmd(cmd);
+}
+
+int
+do_aspawn(void *vreally, void **vmark, void **vsp)
+{
+ return PerlProc_aspawn(vreally, vmark, vsp);
+}
+#endif /* WIN32 */
+
+#endif /* PERL_OBJECT */
diff --git a/contrib/perl5/gv.c b/contrib/perl5/gv.c
new file mode 100644
index 000000000000..0d96ffa97c3e
--- /dev/null
+++ b/contrib/perl5/gv.c
@@ -0,0 +1,1448 @@
+/* gv.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure
+ * of your inquisitiveness, I shall spend all the rest of my days answering
+ * you. What more do you want to know?'
+ * 'The names of all the stars, and of all living things, and the whole
+ * history of Middle-earth and Over-heaven and of the Sundering Seas,'
+ * laughed Pippin.
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+GV *
+gv_AVadd(register GV *gv)
+{
+ if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
+ croak("Bad symbol for array");
+ if (!GvAV(gv))
+ GvAV(gv) = newAV();
+ return gv;
+}
+
+GV *
+gv_HVadd(register GV *gv)
+{
+ if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
+ croak("Bad symbol for hash");
+ if (!GvHV(gv))
+ GvHV(gv) = newHV();
+ return gv;
+}
+
+GV *
+gv_IOadd(register GV *gv)
+{
+ if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
+ croak("Bad symbol for filehandle");
+ if (!GvIOp(gv))
+ GvIOp(gv) = newIO();
+ return gv;
+}
+
+GV *
+gv_fetchfile(char *name)
+{
+ dTHR;
+ char smallbuf[256];
+ char *tmpbuf;
+ STRLEN tmplen;
+ GV *gv;
+
+ tmplen = strlen(name) + 2;
+ if (tmplen < sizeof smallbuf)
+ tmpbuf = smallbuf;
+ else
+ New(603, tmpbuf, tmplen + 1, char);
+ tmpbuf[0] = '_';
+ tmpbuf[1] = '<';
+ strcpy(tmpbuf + 2, name);
+ gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
+ if (!isGV(gv))
+ gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
+ if (tmpbuf != smallbuf)
+ Safefree(tmpbuf);
+ sv_setpv(GvSV(gv), name);
+ if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
+ GvMULTI_on(gv);
+ if (PERLDB_LINE)
+ hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
+ return gv;
+}
+
+void
+gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi)
+{
+ dTHR;
+ register GP *gp;
+ bool doproto = SvTYPE(gv) > SVt_NULL;
+ char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
+
+ sv_upgrade((SV*)gv, SVt_PVGV);
+ if (SvLEN(gv)) {
+ if (proto) {
+ SvPVX(gv) = NULL;
+ SvLEN(gv) = 0;
+ SvPOK_off(gv);
+ } else
+ Safefree(SvPVX(gv));
+ }
+ Newz(602, gp, 1, GP);
+ GvGP(gv) = gp_ref(gp);
+ GvSV(gv) = NEWSV(72,0);
+ GvLINE(gv) = PL_curcop->cop_line;
+ GvFILEGV(gv) = PL_curcop->cop_filegv;
+ GvCVGEN(gv) = 0;
+ GvEGV(gv) = gv;
+ sv_magic((SV*)gv, (SV*)gv, '*', name, len);
+ GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
+ GvNAME(gv) = savepvn(name, len);
+ GvNAMELEN(gv) = len;
+ if (multi)
+ GvMULTI_on(gv);
+ if (doproto) { /* Replicate part of newSUB here. */
+ SvIOK_off(gv);
+ ENTER;
+ start_subparse(0,0); /* Create CV in compcv. */
+ GvCV(gv) = PL_compcv;
+ LEAVE;
+
+ PL_sub_generation++;
+ CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
+ CvFILEGV(GvCV(gv)) = PL_curcop->cop_filegv;
+ CvSTASH(GvCV(gv)) = PL_curstash;
+#ifdef USE_THREADS
+ CvOWNER(GvCV(gv)) = 0;
+ if (!CvMUTEXP(GvCV(gv)))
+ New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(GvCV(gv)));
+#endif /* USE_THREADS */
+ if (proto) {
+ sv_setpv((SV*)GvCV(gv), proto);
+ Safefree(proto);
+ }
+ }
+}
+
+STATIC void
+gv_init_sv(GV *gv, I32 sv_type)
+{
+ switch (sv_type) {
+ case SVt_PVIO:
+ (void)GvIOn(gv);
+ break;
+ case SVt_PVAV:
+ (void)GvAVn(gv);
+ break;
+ case SVt_PVHV:
+ (void)GvHVn(gv);
+ break;
+ }
+}
+
+GV *
+gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level)
+{
+ AV* av;
+ GV* topgv;
+ GV* gv;
+ GV** gvp;
+ CV* cv;
+
+ if (!stash)
+ return 0;
+ if ((level > 100) || (level < -100))
+ croak("Recursive inheritance detected while looking for method '%s' in package '%s'",
+ name, HvNAME(stash));
+
+ DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
+
+ gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
+ if (!gvp)
+ topgv = Nullgv;
+ else {
+ topgv = *gvp;
+ if (SvTYPE(topgv) != SVt_PVGV)
+ gv_init(topgv, stash, name, len, TRUE);
+ if (cv = GvCV(topgv)) {
+ /* If genuine method or valid cache entry, use it */
+ if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
+ return topgv;
+ /* Stale cached entry: junk it */
+ SvREFCNT_dec(cv);
+ GvCV(topgv) = cv = Nullcv;
+ GvCVGEN(topgv) = 0;
+ }
+ else if (GvCVGEN(topgv) == PL_sub_generation)
+ return 0; /* cache indicates sub doesn't exist */
+ }
+
+ gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
+ av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
+
+ /* create and re-create @.*::SUPER::ISA on demand */
+ if (!av || !SvMAGIC(av)) {
+ char* packname = HvNAME(stash);
+ STRLEN packlen = strlen(packname);
+
+ if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
+ HV* basestash;
+
+ packlen -= 7;
+ basestash = gv_stashpvn(packname, packlen, TRUE);
+ gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
+ if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
+ dTHR; /* just for SvREFCNT_dec */
+ gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
+ if (!gvp || !(gv = *gvp))
+ croak("Cannot create %s::ISA", HvNAME(stash));
+ if (SvTYPE(gv) != SVt_PVGV)
+ gv_init(gv, stash, "ISA", 3, TRUE);
+ SvREFCNT_dec(GvAV(gv));
+ GvAV(gv) = (AV*)SvREFCNT_inc(av);
+ }
+ }
+ }
+
+ if (av) {
+ SV** svp = AvARRAY(av);
+ /* NOTE: No support for tied ISA */
+ I32 items = AvFILLp(av) + 1;
+ while (items--) {
+ SV* sv = *svp++;
+ HV* basestash = gv_stashsv(sv, FALSE);
+ if (!basestash) {
+ if (PL_dowarn)
+ warn("Can't locate package %s for @%s::ISA",
+ SvPVX(sv), HvNAME(stash));
+ continue;
+ }
+ gv = gv_fetchmeth(basestash, name, len,
+ (level >= 0) ? level + 1 : level - 1);
+ if (gv)
+ goto gotcha;
+ }
+ }
+
+ /* if at top level, try UNIVERSAL */
+
+ if (level == 0 || level == -1) {
+ HV* lastchance;
+
+ if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
+ if (gv = gv_fetchmeth(lastchance, name, len,
+ (level >= 0) ? level + 1 : level - 1)) {
+ gotcha:
+ /*
+ * Cache method in topgv if:
+ * 1. topgv has no synonyms (else inheritance crosses wires)
+ * 2. method isn't a stub (else AUTOLOAD fails spectacularly)
+ */
+ if (topgv &&
+ GvREFCNT(topgv) == 1 &&
+ (cv = GvCV(gv)) &&
+ (CvROOT(cv) || CvXSUB(cv)))
+ {
+ if (cv = GvCV(topgv))
+ SvREFCNT_dec(cv);
+ GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
+ GvCVGEN(topgv) = PL_sub_generation;
+ }
+ return gv;
+ }
+ else if (topgv && GvREFCNT(topgv) == 1) {
+ /* cache the fact that the method is not defined */
+ GvCVGEN(topgv) = PL_sub_generation;
+ }
+ }
+ }
+
+ return 0;
+}
+
+GV *
+gv_fetchmethod(HV *stash, char *name)
+{
+ return gv_fetchmethod_autoload(stash, name, TRUE);
+}
+
+GV *
+gv_fetchmethod_autoload(HV *stash, char *name, I32 autoload)
+{
+ dTHR;
+ register char *nend;
+ char *nsplit = 0;
+ GV* gv;
+
+ for (nend = name; *nend; nend++) {
+ if (*nend == '\'')
+ nsplit = nend;
+ else if (*nend == ':' && *(nend + 1) == ':')
+ nsplit = ++nend;
+ }
+ if (nsplit) {
+ char *origname = name;
+ name = nsplit + 1;
+ if (*nsplit == ':')
+ --nsplit;
+ if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
+ /* ->SUPER::method should really be looked up in original stash */
+ SV *tmpstr = sv_2mortal(newSVpvf("%s::SUPER",
+ HvNAME(PL_curcop->cop_stash)));
+ stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
+ DEBUG_o( deb("Treating %s as %s::%s\n",
+ origname, HvNAME(stash), name) );
+ }
+ else
+ stash = gv_stashpvn(origname, nsplit - origname, TRUE);
+ }
+
+ gv = gv_fetchmeth(stash, name, nend - name, 0);
+ if (!gv) {
+ if (strEQ(name,"import"))
+ gv = (GV*)&PL_sv_yes;
+ else if (autoload)
+ gv = gv_autoload4(stash, name, nend - name, TRUE);
+ }
+ else if (autoload) {
+ CV* cv = GvCV(gv);
+ if (!CvROOT(cv) && !CvXSUB(cv)) {
+ GV* stubgv;
+ GV* autogv;
+
+ if (CvANON(cv))
+ stubgv = gv;
+ else {
+ stubgv = CvGV(cv);
+ if (GvCV(stubgv) != cv) /* orphaned import */
+ stubgv = gv;
+ }
+ autogv = gv_autoload4(GvSTASH(stubgv),
+ GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
+ if (autogv)
+ gv = autogv;
+ }
+ }
+
+ return gv;
+}
+
+GV*
+gv_autoload4(HV *stash, char *name, STRLEN len, I32 method)
+{
+ static char autoload[] = "AUTOLOAD";
+ static STRLEN autolen = 8;
+ GV* gv;
+ CV* cv;
+ HV* varstash;
+ GV* vargv;
+ SV* varsv;
+
+ if (len == autolen && strnEQ(name, autoload, autolen))
+ return Nullgv;
+ if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
+ return Nullgv;
+ cv = GvCV(gv);
+
+ /*
+ * Inheriting AUTOLOAD for non-methods works ... for now.
+ */
+ if (PL_dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash))
+ warn(
+ "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
+ HvNAME(stash), (int)len, name);
+
+ /*
+ * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
+ * The subroutine's original name may not be "AUTOLOAD", so we don't
+ * use that, but for lack of anything better we will use the sub's
+ * original package to look up $AUTOLOAD.
+ */
+ varstash = GvSTASH(CvGV(cv));
+ vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
+ if (!isGV(vargv))
+ gv_init(vargv, varstash, autoload, autolen, FALSE);
+ varsv = GvSV(vargv);
+ sv_setpv(varsv, HvNAME(stash));
+ sv_catpvn(varsv, "::", 2);
+ sv_catpvn(varsv, name, len);
+ SvTAINTED_off(varsv);
+ return gv;
+}
+
+HV*
+gv_stashpv(char *name, I32 create)
+{
+ return gv_stashpvn(name, strlen(name), create);
+}
+
+HV*
+gv_stashpvn(char *name, U32 namelen, I32 create)
+{
+ char smallbuf[256];
+ char *tmpbuf;
+ HV *stash;
+ GV *tmpgv;
+
+ if (namelen + 3 < sizeof smallbuf)
+ tmpbuf = smallbuf;
+ else
+ New(606, tmpbuf, namelen + 3, char);
+ Copy(name,tmpbuf,namelen,char);
+ tmpbuf[namelen++] = ':';
+ tmpbuf[namelen++] = ':';
+ tmpbuf[namelen] = '\0';
+ tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
+ if (tmpbuf != smallbuf)
+ Safefree(tmpbuf);
+ if (!tmpgv)
+ return 0;
+ if (!GvHV(tmpgv))
+ GvHV(tmpgv) = newHV();
+ stash = GvHV(tmpgv);
+ if (!HvNAME(stash))
+ HvNAME(stash) = savepv(name);
+ return stash;
+}
+
+HV*
+gv_stashsv(SV *sv, I32 create)
+{
+ register char *ptr;
+ STRLEN len;
+ ptr = SvPV(sv,len);
+ return gv_stashpvn(ptr, len, create);
+}
+
+
+GV *
+gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
+{
+ dTHR;
+ register char *name = nambeg;
+ register GV *gv = 0;
+ GV**gvp;
+ I32 len;
+ register char *namend;
+ HV *stash = 0;
+ U32 add_gvflags = 0;
+
+ if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
+ name++;
+
+ for (namend = name; *namend; namend++) {
+ if ((*namend == '\'' && namend[1]) ||
+ (*namend == ':' && namend[1] == ':'))
+ {
+ if (!stash)
+ stash = PL_defstash;
+ if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
+ return Nullgv;
+
+ len = namend - name;
+ if (len > 0) {
+ char smallbuf[256];
+ char *tmpbuf;
+
+ if (len + 3 < sizeof smallbuf)
+ tmpbuf = smallbuf;
+ else
+ New(601, tmpbuf, len+3, char);
+ Copy(name, tmpbuf, len, char);
+ tmpbuf[len++] = ':';
+ tmpbuf[len++] = ':';
+ tmpbuf[len] = '\0';
+ gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
+ gv = gvp ? *gvp : Nullgv;
+ if (gv && gv != (GV*)&PL_sv_undef) {
+ if (SvTYPE(gv) != SVt_PVGV)
+ gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
+ else
+ GvMULTI_on(gv);
+ }
+ if (tmpbuf != smallbuf)
+ Safefree(tmpbuf);
+ if (!gv || gv == (GV*)&PL_sv_undef)
+ return Nullgv;
+
+ if (!(stash = GvHV(gv)))
+ stash = GvHV(gv) = newHV();
+
+ if (!HvNAME(stash))
+ HvNAME(stash) = savepvn(nambeg, namend - nambeg);
+ }
+
+ if (*namend == ':')
+ namend++;
+ namend++;
+ name = namend;
+ if (!*name)
+ return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
+ }
+ }
+ len = namend - name;
+ if (!len)
+ len = 1;
+
+ /* No stash in name, so see how we can default */
+
+ if (!stash) {
+ if (isIDFIRST(*name)) {
+ bool global = FALSE;
+
+ if (isUPPER(*name)) {
+ if (*name == 'S' && (
+ strEQ(name, "SIG") ||
+ strEQ(name, "STDIN") ||
+ strEQ(name, "STDOUT") ||
+ strEQ(name, "STDERR")))
+ global = TRUE;
+ else if (*name == 'I' && strEQ(name, "INC"))
+ global = TRUE;
+ else if (*name == 'E' && strEQ(name, "ENV"))
+ global = TRUE;
+ else if (*name == 'A' && (
+ strEQ(name, "ARGV") ||
+ strEQ(name, "ARGVOUT")))
+ global = TRUE;
+ }
+ else if (*name == '_' && !name[1])
+ global = TRUE;
+
+ if (global)
+ stash = PL_defstash;
+ else if ((COP*)PL_curcop == &PL_compiling) {
+ stash = PL_curstash;
+ if (add && (PL_hints & HINT_STRICT_VARS) &&
+ sv_type != SVt_PVCV &&
+ sv_type != SVt_PVGV &&
+ sv_type != SVt_PVFM &&
+ sv_type != SVt_PVIO &&
+ !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
+ {
+ gvp = (GV**)hv_fetch(stash,name,len,0);
+ if (!gvp ||
+ *gvp == (GV*)&PL_sv_undef ||
+ SvTYPE(*gvp) != SVt_PVGV)
+ {
+ stash = 0;
+ }
+ else if (sv_type == SVt_PV && !GvIMPORTED_SV(*gvp) ||
+ sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
+ sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
+ {
+ warn("Variable \"%c%s\" is not imported",
+ sv_type == SVt_PVAV ? '@' :
+ sv_type == SVt_PVHV ? '%' : '$',
+ name);
+ if (GvCVu(*gvp))
+ warn("(Did you mean &%s instead?)\n", name);
+ stash = 0;
+ }
+ }
+ }
+ else
+ stash = PL_curcop->cop_stash;
+ }
+ else
+ stash = PL_defstash;
+ }
+
+ /* By this point we should have a stash and a name */
+
+ if (!stash) {
+ if (!add)
+ return Nullgv;
+ if (add & ~GV_ADDMULTI) {
+ char sv_type_char = ((sv_type == SVt_PV) ? '$'
+ : (sv_type == SVt_PVAV) ? '@'
+ : (sv_type == SVt_PVHV) ? '%'
+ : 0);
+ if (sv_type_char)
+ warn("Global symbol \"%c%s\" requires explicit package name",
+ sv_type_char, name);
+ else
+ warn("Global symbol \"%s\" requires explicit package name",
+ name);
+ }
+ ++PL_error_count;
+ stash = PL_curstash ? PL_curstash : PL_defstash; /* avoid core dumps */
+ add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
+ : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
+ : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
+ : 0);
+ }
+
+ if (!SvREFCNT(stash)) /* symbol table under destruction */
+ return Nullgv;
+
+ gvp = (GV**)hv_fetch(stash,name,len,add);
+ if (!gvp || *gvp == (GV*)&PL_sv_undef)
+ return Nullgv;
+ gv = *gvp;
+ if (SvTYPE(gv) == SVt_PVGV) {
+ if (add) {
+ GvMULTI_on(gv);
+ gv_init_sv(gv, sv_type);
+ }
+ return gv;
+ } else if (add & GV_NOINIT) {
+ return gv;
+ }
+
+ /* Adding a new symbol */
+
+ if (add & GV_ADDWARN)
+ warn("Had to create %s unexpectedly", nambeg);
+ gv_init(gv, stash, name, len, add & GV_ADDMULTI);
+ gv_init_sv(gv, sv_type);
+ GvFLAGS(gv) |= add_gvflags;
+
+ /* set up magic where warranted */
+ switch (*name) {
+ case 'A':
+ if (strEQ(name, "ARGV")) {
+ IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
+ }
+ break;
+
+ case 'a':
+ case 'b':
+ if (len == 1)
+ GvMULTI_on(gv);
+ break;
+ case 'E':
+ if (strnEQ(name, "EXPORT", 6))
+ GvMULTI_on(gv);
+ break;
+ case 'I':
+ if (strEQ(name, "ISA")) {
+ AV* av = GvAVn(gv);
+ GvMULTI_on(gv);
+ sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
+ /* NOTE: No support for tied ISA */
+ if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
+ && AvFILLp(av) == -1)
+ {
+ char *pname;
+ av_push(av, newSVpv(pname = "NDBM_File",0));
+ gv_stashpvn(pname, 9, TRUE);
+ av_push(av, newSVpv(pname = "DB_File",0));
+ gv_stashpvn(pname, 7, TRUE);
+ av_push(av, newSVpv(pname = "GDBM_File",0));
+ gv_stashpvn(pname, 9, TRUE);
+ av_push(av, newSVpv(pname = "SDBM_File",0));
+ gv_stashpvn(pname, 9, TRUE);
+ av_push(av, newSVpv(pname = "ODBM_File",0));
+ gv_stashpvn(pname, 9, TRUE);
+ }
+ }
+ break;
+#ifdef OVERLOAD
+ case 'O':
+ if (strEQ(name, "OVERLOAD")) {
+ HV* hv = GvHVn(gv);
+ GvMULTI_on(gv);
+ hv_magic(hv, gv, 'A');
+ }
+ break;
+#endif /* OVERLOAD */
+ case 'S':
+ if (strEQ(name, "SIG")) {
+ HV *hv;
+ I32 i;
+ PL_siggv = gv;
+ GvMULTI_on(PL_siggv);
+ hv = GvHVn(PL_siggv);
+ hv_magic(hv, PL_siggv, 'S');
+ for(i=1;sig_name[i];i++) {
+ SV ** init;
+ init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1);
+ if(init)
+ sv_setsv(*init,&PL_sv_undef);
+ psig_ptr[i] = 0;
+ psig_name[i] = 0;
+ }
+ }
+ break;
+
+ case '&':
+ if (len > 1)
+ break;
+ PL_ampergv = gv;
+ PL_sawampersand = TRUE;
+ goto ro_magicalize;
+
+ case '`':
+ if (len > 1)
+ break;
+ PL_leftgv = gv;
+ PL_sawampersand = TRUE;
+ goto ro_magicalize;
+
+ case '\'':
+ if (len > 1)
+ break;
+ PL_rightgv = gv;
+ PL_sawampersand = TRUE;
+ goto ro_magicalize;
+
+ case ':':
+ if (len > 1)
+ break;
+ sv_setpv(GvSV(gv),PL_chopset);
+ goto magicalize;
+
+ case '?':
+ if (len > 1)
+ break;
+#ifdef COMPLEX_STATUS
+ sv_upgrade(GvSV(gv), SVt_PVLV);
+#endif
+ goto magicalize;
+
+ case '!':
+ if (len > 1)
+ break;
+ if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
+ HV* stash = gv_stashpvn("Errno",5,FALSE);
+ if(!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
+ dSP;
+ PUTBACK;
+ perl_require_pv("Errno.pm");
+ SPAGAIN;
+ stash = gv_stashpvn("Errno",5,FALSE);
+ if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
+ croak("Can't use %%! because Errno.pm is not available");
+ }
+ }
+ goto magicalize;
+ case '#':
+ case '*':
+ if (PL_dowarn && len == 1 && sv_type == SVt_PV)
+ warn("Use of $%s is deprecated", name);
+ /* FALL THROUGH */
+ case '[':
+ case '^':
+ case '~':
+ case '=':
+ case '-':
+ case '%':
+ case '.':
+ case '(':
+ case ')':
+ case '<':
+ case '>':
+ case ',':
+ case '\\':
+ case '/':
+ case '|':
+ case '\001':
+ case '\004':
+ case '\005':
+ case '\006':
+ case '\010':
+ case '\011': /* NOT \t in EBCDIC */
+ case '\017':
+ case '\020':
+ case '\024':
+ case '\027':
+ if (len > 1)
+ break;
+ goto magicalize;
+
+ case '+':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ case '\023':
+ ro_magicalize:
+ SvREADONLY_on(GvSV(gv));
+ magicalize:
+ sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
+ break;
+
+ case '\014':
+ if (len > 1)
+ break;
+ sv_setpv(GvSV(gv),"\f");
+ PL_formfeed = GvSV(gv);
+ break;
+ case ';':
+ if (len > 1)
+ break;
+ sv_setpv(GvSV(gv),"\034");
+ break;
+ case ']':
+ if (len == 1) {
+ SV *sv = GvSV(gv);
+ sv_upgrade(sv, SVt_PVNV);
+ sv_setpv(sv, PL_patchlevel);
+ (void)sv_2nv(sv);
+ SvREADONLY_on(sv);
+ }
+ break;
+ }
+ return gv;
+}
+
+void
+gv_fullname3(SV *sv, GV *gv, char *prefix)
+{
+ HV *hv = GvSTASH(gv);
+ if (!hv) {
+ SvOK_off(sv);
+ return;
+ }
+ sv_setpv(sv, prefix ? prefix : "");
+ sv_catpv(sv,HvNAME(hv));
+ sv_catpvn(sv,"::", 2);
+ sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+}
+
+void
+gv_efullname3(SV *sv, GV *gv, char *prefix)
+{
+ GV *egv = GvEGV(gv);
+ if (!egv)
+ egv = gv;
+ gv_fullname3(sv, egv, prefix);
+}
+
+/* XXX compatibility with versions <= 5.003. */
+void
+gv_fullname(SV *sv, GV *gv)
+{
+ gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
+}
+
+/* XXX compatibility with versions <= 5.003. */
+void
+gv_efullname(SV *sv, GV *gv)
+{
+ gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
+}
+
+IO *
+newIO(void)
+{
+ dTHR;
+ IO *io;
+ GV *iogv;
+
+ io = (IO*)NEWSV(0,0);
+ sv_upgrade((SV *)io,SVt_PVIO);
+ SvREFCNT(io) = 1;
+ SvOBJECT_on(io);
+ iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
+ if (!iogv)
+ iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
+ SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
+ return io;
+}
+
+void
+gv_check(HV *stash)
+{
+ dTHR;
+ register HE *entry;
+ register I32 i;
+ register GV *gv;
+ HV *hv;
+ GV *filegv;
+
+ if (!HvARRAY(stash))
+ return;
+ for (i = 0; i <= (I32) HvMAX(stash); i++) {
+ for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
+ if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
+ (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
+ {
+ if (hv != PL_defstash)
+ gv_check(hv); /* nested package */
+ }
+ else if (isALPHA(*HeKEY(entry))) {
+ gv = (GV*)HeVAL(entry);
+ if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
+ continue;
+ PL_curcop->cop_line = GvLINE(gv);
+ filegv = GvFILEGV(gv);
+ PL_curcop->cop_filegv = filegv;
+ if (filegv && GvMULTI(filegv)) /* Filename began with slash */
+ continue;
+ warn("Name \"%s::%s\" used only once: possible typo",
+ HvNAME(stash), GvNAME(gv));
+ }
+ }
+ }
+}
+
+GV *
+newGVgen(char *pack)
+{
+ return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)PL_gensym++),
+ TRUE, SVt_PVGV);
+}
+
+/* hopefully this is only called on local symbol table entries */
+
+GP*
+gp_ref(GP *gp)
+{
+ gp->gp_refcnt++;
+ if (gp->gp_cv) {
+ if (gp->gp_cvgen) {
+ /* multi-named GPs cannot be used for method cache */
+ SvREFCNT_dec(gp->gp_cv);
+ gp->gp_cv = Nullcv;
+ gp->gp_cvgen = 0;
+ }
+ else {
+ /* Adding a new name to a subroutine invalidates method cache */
+ PL_sub_generation++;
+ }
+ }
+ return gp;
+}
+
+void
+gp_free(GV *gv)
+{
+ GP* gp;
+ CV* cv;
+
+ if (!gv || !(gp = GvGP(gv)))
+ return;
+ if (gp->gp_refcnt == 0) {
+ warn("Attempt to free unreferenced glob pointers");
+ return;
+ }
+ if (gp->gp_cv) {
+ /* Deleting the name of a subroutine invalidates method cache */
+ PL_sub_generation++;
+ }
+ if (--gp->gp_refcnt > 0) {
+ if (gp->gp_egv == gv)
+ gp->gp_egv = 0;
+ return;
+ }
+
+ SvREFCNT_dec(gp->gp_sv);
+ SvREFCNT_dec(gp->gp_av);
+ SvREFCNT_dec(gp->gp_hv);
+ SvREFCNT_dec(gp->gp_io);
+ SvREFCNT_dec(gp->gp_cv);
+ SvREFCNT_dec(gp->gp_form);
+
+ Safefree(gp);
+ GvGP(gv) = 0;
+}
+
+#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
+#define MICROPORT
+#endif
+
+#ifdef MICROPORT /* Microport 2.4 hack */
+AV *GvAVn(gv)
+register GV *gv;
+{
+ if (GvGP(gv)->gp_av)
+ return GvGP(gv)->gp_av;
+ else
+ return GvGP(gv_AVadd(gv))->gp_av;
+}
+
+HV *GvHVn(gv)
+register GV *gv;
+{
+ if (GvGP(gv)->gp_hv)
+ return GvGP(gv)->gp_hv;
+ else
+ return GvGP(gv_HVadd(gv))->gp_hv;
+}
+#endif /* Microport 2.4 hack */
+
+#ifdef OVERLOAD
+/* Updates and caches the CV's */
+
+bool
+Gv_AMupdate(HV *stash)
+{
+ dTHR;
+ GV** gvp;
+ HV* hv;
+ GV* gv;
+ CV* cv;
+ MAGIC* mg=mg_find((SV*)stash,'c');
+ AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
+ AMT amt;
+
+ if (mg && amtp->was_ok_am == PL_amagic_generation
+ && amtp->was_ok_sub == PL_sub_generation)
+ return AMT_AMAGIC(amtp);
+ if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
+ int i;
+ for (i=1; i<NofAMmeth; i++) {
+ if (amtp->table[i]) {
+ SvREFCNT_dec(amtp->table[i]);
+ }
+ }
+ }
+ sv_unmagic((SV*)stash, 'c');
+
+ DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
+
+ amt.was_ok_am = PL_amagic_generation;
+ amt.was_ok_sub = PL_sub_generation;
+ amt.fallback = AMGfallNO;
+ amt.flags = 0;
+
+#ifdef OVERLOAD_VIA_HASH
+ gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
+ if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
+ int filled=0;
+ int i;
+ char *cp;
+ SV* sv;
+ SV** svp;
+
+ /* Work with "fallback" key, which we assume to be first in AMG_names */
+
+ if (( cp = (char *)AMG_names[0] ) &&
+ (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
+ if (SvTRUE(sv)) amt.fallback=AMGfallYES;
+ else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
+ }
+ for (i = 1; i < NofAMmeth; i++) {
+ cv = 0;
+ cp = (char *)AMG_names[i];
+
+ svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
+ if (svp && ((sv = *svp) != &PL_sv_undef)) {
+ switch (SvTYPE(sv)) {
+ default:
+ if (!SvROK(sv)) {
+ if (!SvOK(sv)) break;
+ gv = gv_fetchmethod(stash, SvPV(sv, PL_na));
+ if (gv) cv = GvCV(gv);
+ break;
+ }
+ cv = (CV*)SvRV(sv);
+ if (SvTYPE(cv) == SVt_PVCV)
+ break;
+ /* FALL THROUGH */
+ case SVt_PVHV:
+ case SVt_PVAV:
+ croak("Not a subroutine reference in overload table");
+ return FALSE;
+ case SVt_PVCV:
+ cv = (CV*)sv;
+ break;
+ case SVt_PVGV:
+ if (!(cv = GvCVu((GV*)sv)))
+ cv = sv_2cv(sv, &stash, &gv, TRUE);
+ break;
+ }
+ if (cv) filled=1;
+ else {
+ croak("Method for operation %s not found in package %.256s during blessing\n",
+ cp,HvNAME(stash));
+ return FALSE;
+ }
+ }
+#else
+ {
+ int filled = 0;
+ int i;
+ const char *cp;
+ SV* sv = NULL;
+ SV** svp;
+
+ /* Work with "fallback" key, which we assume to be first in AMG_names */
+
+ if ( cp = AMG_names[0] ) {
+ /* Try to find via inheritance. */
+ gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
+ if (gv) sv = GvSV(gv);
+
+ if (!gv) goto no_table;
+ else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
+ else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
+ }
+
+ for (i = 1; i < NofAMmeth; i++) {
+ SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i]));
+ DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n",
+ cp, HvNAME(stash)) );
+ /* don't fill the cache while looking up! */
+ gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
+ cv = 0;
+ if(gv && (cv = GvCV(gv))) {
+ if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
+ && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
+ /* GvSV contains the name of the method. */
+ GV *ngv;
+
+ DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
+ SvPV(GvSV(gv), PL_na), cp, HvNAME(stash)) );
+ if (!SvPOK(GvSV(gv))
+ || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
+ FALSE)))
+ {
+ /* Can be an import stub (created by `can'). */
+ if (GvCVGEN(gv)) {
+ croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
+ (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
+ cp, HvNAME(stash));
+ } else
+ croak("Cannot resolve method `%.256s' overloading `%s' in package `%.256s'",
+ (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
+ cp, HvNAME(stash));
+ }
+ cv = GvCV(gv = ngv);
+ }
+ DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
+ cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
+ GvNAME(CvGV(cv))) );
+ filled = 1;
+ }
+#endif
+ amt.table[i]=(CV*)SvREFCNT_inc(cv);
+ }
+ if (filled) {
+ AMT_AMAGIC_on(&amt);
+ sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
+ return TRUE;
+ }
+ }
+ /* Here we have no table: */
+ no_table:
+ AMT_AMAGIC_off(&amt);
+ sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
+ return FALSE;
+}
+
+SV*
+amagic_call(SV *left, SV *right, int method, int flags)
+{
+ dTHR;
+ MAGIC *mg;
+ CV *cv;
+ CV **cvp=NULL, **ocvp=NULL;
+ AMT *amtp, *oamtp;
+ int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
+ int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
+ HV* stash;
+ if (!(AMGf_noleft & flags) && SvAMAGIC(left)
+ && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
+ && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
+ ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
+ : (CV **) NULL))
+ && ((cv = cvp[off=method+assignshift])
+ || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
+ * usual method */
+ (fl = 1, cv = cvp[off=method])))) {
+ lr = -1; /* Call method for left argument */
+ } else {
+ if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
+ int logic;
+
+ /* look for substituted methods */
+ /* In all the covered cases we should be called with assign==0. */
+ switch (method) {
+ case inc_amg:
+ force_cpy = 1;
+ if ((cv = cvp[off=add_ass_amg])
+ || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
+ right = &PL_sv_yes; lr = -1; assign = 1;
+ }
+ break;
+ case dec_amg:
+ force_cpy = 1;
+ if ((cv = cvp[off = subtr_ass_amg])
+ || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
+ right = &PL_sv_yes; lr = -1; assign = 1;
+ }
+ break;
+ case bool__amg:
+ (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
+ break;
+ case numer_amg:
+ (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
+ break;
+ case string_amg:
+ (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
+ break;
+ case not_amg:
+ (void)((cv = cvp[off=bool__amg])
+ || (cv = cvp[off=numer_amg])
+ || (cv = cvp[off=string_amg]));
+ postpr = 1;
+ break;
+ case copy_amg:
+ {
+ /*
+ * SV* ref causes confusion with the interpreter variable of
+ * the same name
+ */
+ SV* tmpRef=SvRV(left);
+ if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
+ /*
+ * Just to be extra cautious. Maybe in some
+ * additional cases sv_setsv is safe, too.
+ */
+ SV* newref = newSVsv(tmpRef);
+ SvOBJECT_on(newref);
+ SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
+ return newref;
+ }
+ }
+ break;
+ case abs_amg:
+ if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
+ && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
+ SV* nullsv=sv_2mortal(newSViv(0));
+ if (off1==lt_amg) {
+ SV* lessp = amagic_call(left,nullsv,
+ lt_amg,AMGf_noright);
+ logic = SvTRUE(lessp);
+ } else {
+ SV* lessp = amagic_call(left,nullsv,
+ ncmp_amg,AMGf_noright);
+ logic = (SvNV(lessp) < 0);
+ }
+ if (logic) {
+ if (off==subtr_amg) {
+ right = left;
+ left = nullsv;
+ lr = 1;
+ }
+ } else {
+ return left;
+ }
+ }
+ break;
+ case neg_amg:
+ if (cv = cvp[off=subtr_amg]) {
+ right = left;
+ left = sv_2mortal(newSViv(0));
+ lr = 1;
+ }
+ break;
+ default:
+ goto not_found;
+ }
+ if (!cv) goto not_found;
+ } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
+ && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
+ && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
+ ? (amtp = (AMT*)mg->mg_ptr)->table
+ : (CV **) NULL))
+ && (cv = cvp[off=method])) { /* Method for right
+ * argument found */
+ lr=1;
+ } else if (((ocvp && oamtp->fallback > AMGfallNEVER
+ && (cvp=ocvp) && (lr = -1))
+ || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
+ && !(flags & AMGf_unary)) {
+ /* We look for substitution for
+ * comparison operations and
+ * concatenation */
+ if (method==concat_amg || method==concat_ass_amg
+ || method==repeat_amg || method==repeat_ass_amg) {
+ return NULL; /* Delegate operation to string conversion */
+ }
+ off = -1;
+ switch (method) {
+ case lt_amg:
+ case le_amg:
+ case gt_amg:
+ case ge_amg:
+ case eq_amg:
+ case ne_amg:
+ postpr = 1; off=ncmp_amg; break;
+ case slt_amg:
+ case sle_amg:
+ case sgt_amg:
+ case sge_amg:
+ case seq_amg:
+ case sne_amg:
+ postpr = 1; off=scmp_amg; break;
+ }
+ if (off != -1) cv = cvp[off];
+ if (!cv) {
+ goto not_found;
+ }
+ } else {
+ not_found: /* No method found, either report or croak */
+ if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
+ notfound = 1; lr = -1;
+ } else if (cvp && (cv=cvp[nomethod_amg])) {
+ notfound = 1; lr = 1;
+ } else {
+ SV *msg;
+ if (off==-1) off=method;
+ msg = sv_2mortal(newSVpvf(
+ "Operation `%s': no method found,%sargument %s%s%s%s",
+ AMG_names[method + assignshift],
+ (flags & AMGf_unary ? " " : "\n\tleft "),
+ SvAMAGIC(left)?
+ "in overloaded package ":
+ "has no overloaded magic",
+ SvAMAGIC(left)?
+ HvNAME(SvSTASH(SvRV(left))):
+ "",
+ SvAMAGIC(right)?
+ ",\n\tright argument in overloaded package ":
+ (flags & AMGf_unary
+ ? ""
+ : ",\n\tright argument has no overloaded magic"),
+ SvAMAGIC(right)?
+ HvNAME(SvSTASH(SvRV(right))):
+ ""));
+ if (amtp && amtp->fallback >= AMGfallYES) {
+ DEBUG_o( deb("%s", SvPVX(msg)) );
+ } else {
+ croak("%_", msg);
+ }
+ return NULL;
+ }
+ force_cpy = force_cpy || assign;
+ }
+ }
+ if (!notfound) {
+ DEBUG_o( deb(
+ "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
+ AMG_names[off],
+ method+assignshift==off? "" :
+ " (initially `",
+ method+assignshift==off? "" :
+ AMG_names[method+assignshift],
+ method+assignshift==off? "" : "')",
+ flags & AMGf_unary? "" :
+ lr==1 ? " for right argument": " for left argument",
+ flags & AMGf_unary? " for argument" : "",
+ HvNAME(stash),
+ fl? ",\n\tassignment variant used": "") );
+ }
+ /* Since we use shallow copy during assignment, we need
+ * to dublicate the contents, probably calling user-supplied
+ * version of copy operator
+ */
+ /* We need to copy in following cases:
+ * a) Assignment form was called.
+ * assignshift==1, assign==T, method + 1 == off
+ * b) Increment or decrement, called directly.
+ * assignshift==0, assign==0, method + 0 == off
+ * c) Increment or decrement, translated to assignment add/subtr.
+ * assignshift==0, assign==T,
+ * force_cpy == T
+ * d) Increment or decrement, translated to nomethod.
+ * assignshift==0, assign==0,
+ * force_cpy == T
+ * e) Assignment form translated to nomethod.
+ * assignshift==1, assign==T, method + 1 != off
+ * force_cpy == T
+ */
+ /* off is method, method+assignshift, or a result of opcode substitution.
+ * In the latter case assignshift==0, so only notfound case is important.
+ */
+ if (( (method + assignshift == off)
+ && (assign || (method == inc_amg) || (method == dec_amg)))
+ || force_cpy)
+ RvDEEPCP(left);
+ {
+ dSP;
+ BINOP myop;
+ SV* res;
+ bool oldcatch = CATCH_GET;
+
+ CATCH_SET(TRUE);
+ Zero(&myop, 1, BINOP);
+ myop.op_last = (OP *) &myop;
+ myop.op_next = Nullop;
+ myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+
+ PUSHSTACKi(PERLSI_OVERLOAD);
+ ENTER;
+ SAVEOP();
+ PL_op = (OP *) &myop;
+ if (PERLDB_SUB && PL_curstash != PL_debstash)
+ PL_op->op_private |= OPpENTERSUB_DB;
+ PUTBACK;
+ pp_pushmark(ARGS);
+
+ EXTEND(SP, notfound + 5);
+ PUSHs(lr>0? right: left);
+ PUSHs(lr>0? left: right);
+ PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
+ if (notfound) {
+ PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
+ }
+ PUSHs((SV*)cv);
+ PUTBACK;
+
+ if (PL_op = pp_entersub(ARGS))
+ CALLRUNOPS();
+ LEAVE;
+ SPAGAIN;
+
+ res=POPs;
+ POPSTACK;
+ CATCH_SET(oldcatch);
+
+ if (postpr) {
+ int ans;
+ switch (method) {
+ case le_amg:
+ case sle_amg:
+ ans=SvIV(res)<=0; break;
+ case lt_amg:
+ case slt_amg:
+ ans=SvIV(res)<0; break;
+ case ge_amg:
+ case sge_amg:
+ ans=SvIV(res)>=0; break;
+ case gt_amg:
+ case sgt_amg:
+ ans=SvIV(res)>0; break;
+ case eq_amg:
+ case seq_amg:
+ ans=SvIV(res)==0; break;
+ case ne_amg:
+ case sne_amg:
+ ans=SvIV(res)!=0; break;
+ case inc_amg:
+ case dec_amg:
+ SvSetSV(left,res); return left;
+ case not_amg:
+ ans=!SvOK(res); break;
+ }
+ return boolSV(ans);
+ } else if (method==copy_amg) {
+ if (!SvROK(res)) {
+ croak("Copy method did not return a reference");
+ }
+ return SvREFCNT_inc(SvRV(res));
+ } else {
+ return res;
+ }
+ }
+}
+#endif /* OVERLOAD */
+
diff --git a/contrib/perl5/gv.h b/contrib/perl5/gv.h
new file mode 100644
index 000000000000..8d987edbc479
--- /dev/null
+++ b/contrib/perl5/gv.h
@@ -0,0 +1,137 @@
+/* gv.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+struct gp {
+ SV * gp_sv; /* scalar value */
+ U32 gp_refcnt; /* how many globs point to this? */
+ struct io * gp_io; /* filehandle value */
+ CV * gp_form; /* format value */
+ AV * gp_av; /* array value */
+ HV * gp_hv; /* hash value */
+ GV * gp_egv; /* effective gv, if *glob */
+ CV * gp_cv; /* subroutine value */
+ U32 gp_cvgen; /* generational validity of cached gv_cv */
+ I32 gp_lastexpr; /* used by nothing_in_common() */
+ line_t gp_line; /* line first declared at (for -w) */
+ GV * gp_filegv; /* file first declared in (for -w) */
+};
+
+#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
+#define MICROPORT
+#endif
+
+#define GvXPVGV(gv) ((XPVGV*)SvANY(gv))
+
+#define GvGP(gv) (GvXPVGV(gv)->xgv_gp)
+#define GvNAME(gv) (GvXPVGV(gv)->xgv_name)
+#define GvNAMELEN(gv) (GvXPVGV(gv)->xgv_namelen)
+#define GvSTASH(gv) (GvXPVGV(gv)->xgv_stash)
+#define GvFLAGS(gv) (GvXPVGV(gv)->xgv_flags)
+
+#define GvSV(gv) (GvGP(gv)->gp_sv)
+#define GvREFCNT(gv) (GvGP(gv)->gp_refcnt)
+#define GvIO(gv) ((gv) && SvTYPE((SV*)gv) == SVt_PVGV ? GvIOp(gv) : 0)
+#define GvIOp(gv) (GvGP(gv)->gp_io)
+#define GvIOn(gv) (GvIO(gv) ? GvIOp(gv) : GvIOp(gv_IOadd(gv)))
+
+#define GvFORM(gv) (GvGP(gv)->gp_form)
+#define GvAV(gv) (GvGP(gv)->gp_av)
+
+/* This macro is deprecated. Do not use! */
+#define GvREFCNT_inc(gv) ((GV*)SvREFCNT_inc(gv)) /* DO NOT USE */
+
+#ifdef MICROPORT /* Microport 2.4 hack */
+AV *GvAVn();
+#else
+#define GvAVn(gv) (GvGP(gv)->gp_av ? \
+ GvGP(gv)->gp_av : \
+ GvGP(gv_AVadd(gv))->gp_av)
+#endif
+#define GvHV(gv) ((GvGP(gv))->gp_hv)
+
+#ifdef MICROPORT /* Microport 2.4 hack */
+HV *GvHVn();
+#else
+#define GvHVn(gv) (GvGP(gv)->gp_hv ? \
+ GvGP(gv)->gp_hv : \
+ GvGP(gv_HVadd(gv))->gp_hv)
+#endif /* Microport 2.4 hack */
+
+#define GvCV(gv) (GvGP(gv)->gp_cv)
+#define GvCVGEN(gv) (GvGP(gv)->gp_cvgen)
+#define GvCVu(gv) (GvGP(gv)->gp_cvgen ? Nullcv : GvGP(gv)->gp_cv)
+
+#define GvLASTEXPR(gv) (GvGP(gv)->gp_lastexpr)
+
+#define GvLINE(gv) (GvGP(gv)->gp_line)
+#define GvFILEGV(gv) (GvGP(gv)->gp_filegv)
+
+#define GvEGV(gv) (GvGP(gv)->gp_egv)
+#define GvENAME(gv) GvNAME(GvEGV(gv) ? GvEGV(gv) : gv)
+#define GvESTASH(gv) GvSTASH(GvEGV(gv) ? GvEGV(gv) : gv)
+
+#define GVf_INTRO 0x01
+#define GVf_MULTI 0x02
+#define GVf_ASSUMECV 0x04
+#define GVf_IMPORTED 0xF0
+#define GVf_IMPORTED_SV 0x10
+#define GVf_IMPORTED_AV 0x20
+#define GVf_IMPORTED_HV 0x40
+#define GVf_IMPORTED_CV 0x80
+
+#define GvINTRO(gv) (GvFLAGS(gv) & GVf_INTRO)
+#define GvINTRO_on(gv) (GvFLAGS(gv) |= GVf_INTRO)
+#define GvINTRO_off(gv) (GvFLAGS(gv) &= ~GVf_INTRO)
+
+#define GvMULTI(gv) (GvFLAGS(gv) & GVf_MULTI)
+#define GvMULTI_on(gv) (GvFLAGS(gv) |= GVf_MULTI)
+#define GvMULTI_off(gv) (GvFLAGS(gv) &= ~GVf_MULTI)
+
+#define GvASSUMECV(gv) (GvFLAGS(gv) & GVf_ASSUMECV)
+#define GvASSUMECV_on(gv) (GvFLAGS(gv) |= GVf_ASSUMECV)
+#define GvASSUMECV_off(gv) (GvFLAGS(gv) &= ~GVf_ASSUMECV)
+
+#define GvIMPORTED(gv) (GvFLAGS(gv) & GVf_IMPORTED)
+#define GvIMPORTED_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED)
+#define GvIMPORTED_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED)
+
+#define GvIMPORTED_SV(gv) (GvFLAGS(gv) & GVf_IMPORTED_SV)
+#define GvIMPORTED_SV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_SV)
+#define GvIMPORTED_SV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_SV)
+
+#define GvIMPORTED_AV(gv) (GvFLAGS(gv) & GVf_IMPORTED_AV)
+#define GvIMPORTED_AV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_AV)
+#define GvIMPORTED_AV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_AV)
+
+#define GvIMPORTED_HV(gv) (GvFLAGS(gv) & GVf_IMPORTED_HV)
+#define GvIMPORTED_HV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_HV)
+#define GvIMPORTED_HV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_HV)
+
+#define GvIMPORTED_CV(gv) (GvFLAGS(gv) & GVf_IMPORTED_CV)
+#define GvIMPORTED_CV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_CV)
+#define GvIMPORTED_CV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_CV)
+
+#define Nullgv Null(GV*)
+
+#define DM_UID 0x003
+#define DM_RUID 0x001
+#define DM_EUID 0x002
+#define DM_GID 0x030
+#define DM_RGID 0x010
+#define DM_EGID 0x020
+#define DM_DELAY 0x100
+
+/*
+ * symbol creation flags, for use in gv_fetchpv() and perl_get_*v()
+ */
+#define GV_ADD 0x01 /* add, if symbol not already there */
+#define GV_ADDMULTI 0x02 /* add, pretending it has been added already */
+#define GV_ADDWARN 0x04 /* add, but warn if symbol wasn't already there */
+#define GV_ADDINEVAL 0x08 /* add, as though we're doing so within an eval */
+#define GV_NOINIT 0x10 /* add, but don't init symbol, if type != PVGV */
diff --git a/contrib/perl5/h2pl/README b/contrib/perl5/h2pl/README
new file mode 100644
index 000000000000..5fe8ae7aa338
--- /dev/null
+++ b/contrib/perl5/h2pl/README
@@ -0,0 +1,71 @@
+[This file of Tom Christiansen's has been edited to change makelib to h2ph
+and .h to .ph where appropriate--law.]
+
+This directory contains files to help you convert the *.ph files generated my
+h2ph out of the perl source directory into *.pl files with all the
+indirection of the subroutine calls removed. The .ph version will be more
+safely portable, because if something isn't defined on the new system, like
+&TIOCGETP, then you'll get a fatal run-time error on the system lacking that
+function. Using the .pl version means that the subsequent scripts will give
+you a 0 $TIOCGETP and God only knows what may then happen. Still, I like the
+.pl stuff because they're faster to load.
+
+FIrst, you need to run h2ph on things like sys/ioctl.h to get stuff
+into the perl library directory, often /usr/local/lib/perl. For example,
+ # h2ph sys/ioctl.h
+takes /usr/include/sys/ioctl.h as input and writes (without i/o redirection)
+the file /usr/local/lib/perl/sys/ioctl.ph, which looks like this
+
+ eval 'sub TIOCM_RTS {0004;}';
+ eval 'sub TIOCM_ST {0010;}';
+ eval 'sub TIOCM_SR {0020;}';
+ eval 'sub TIOCM_CTS {0040;}';
+ eval 'sub TIOCM_CAR {0100;}';
+
+and much worse, rather than what Larry's ioctl.pl from the perl source dir has,
+which is:
+
+ $TIOCM_RTS = 0004;
+ $TIOCM_ST = 0010;
+ $TIOCM_SR = 0020;
+ $TIOCM_CTS = 0040;
+ $TIOCM_CAR = 0100;
+
+[Workaround for fixed bug in makedir/h2ph deleted--law.]
+
+The more complicated ioctl subs look like this:
+
+ eval 'sub TIOCGSIZE {&TIOCGWINSZ;}';
+ eval 'sub TIOCGWINSZ {&_IOR("t", 104, \'struct winsize\');}';
+ eval 'sub TIOCSETD {&_IOW("t", 1, \'int\');}';
+ eval 'sub TIOCGETP {&_IOR("t", 8,\'struct sgttyb\');}';
+
+The _IO[RW] routines use a %sizeof array, which (presumably)
+is keyed on the type name with the value being the size in bytes.
+
+To build %sizeof, try running this in this directory:
+
+ % ./getioctlsizes
+
+Which will tell you which things the %sizeof array needs
+to hold. You can try to build a sizeof.ph file with:
+
+ % ./getioctlsizes | ./mksizes > sizeof.ph
+
+Note that mksizes hardcodes the #include files for all the types, so it will
+probably require customization. Once you have sizeof.ph, install it in the
+perl library directory. Run my tcbreak script to see whether you can do
+ioctls in perl now. You'll get some kind of fatal run-time error if you
+can't. That script should be included in this directory.
+
+If this works well, now you can try to convert the *.ph files into
+*.pl files. Try this:
+
+ foreach file ( sysexits.ph sys/{errno.ph,ioctl.ph} )
+ ./mkvars $file > t/$file:r.pl
+ end
+
+The last one will be the hardest. If it works, should be able to
+run tcbreak2 and have it work the same as tcbreak.
+
+Good luck.
diff --git a/contrib/perl5/h2pl/cbreak.pl b/contrib/perl5/h2pl/cbreak.pl
new file mode 100644
index 000000000000..422185eb7b43
--- /dev/null
+++ b/contrib/perl5/h2pl/cbreak.pl
@@ -0,0 +1,34 @@
+$sgttyb_t = 'C4 S';
+
+sub cbreak {
+ &set_cbreak(1);
+}
+
+sub cooked {
+ &set_cbreak(0);
+}
+
+sub set_cbreak {
+ local($on) = @_;
+
+ require 'sizeof.ph';
+ require 'sys/ioctl.ph';
+
+ ioctl(STDIN,&TIOCGETP,$sgttyb)
+ || die "Can't ioctl TIOCGETP: $!";
+
+ @ary = unpack($sgttyb_t,$sgttyb);
+ if ($on) {
+ $ary[4] |= &CBREAK;
+ $ary[4] &= ~&ECHO;
+ } else {
+ $ary[4] &= ~&CBREAK;
+ $ary[4] |= &ECHO;
+ }
+ $sgttyb = pack($sgttyb_t,@ary);
+ ioctl(STDIN,&TIOCSETP,$sgttyb)
+ || die "Can't ioctl TIOCSETP: $!";
+
+}
+
+1;
diff --git a/contrib/perl5/h2pl/cbreak2.pl b/contrib/perl5/h2pl/cbreak2.pl
new file mode 100644
index 000000000000..8ac55a349755
--- /dev/null
+++ b/contrib/perl5/h2pl/cbreak2.pl
@@ -0,0 +1,33 @@
+$sgttyb_t = 'C4 S';
+
+sub cbreak {
+ &set_cbreak(1);
+}
+
+sub cooked {
+ &set_cbreak(0);
+}
+
+sub set_cbreak {
+ local($on) = @_;
+
+ require 'sys/ioctl.pl';
+
+ ioctl(STDIN,$TIOCGETP,$sgttyb)
+ || die "Can't ioctl TIOCGETP: $!";
+
+ @ary = unpack($sgttyb_t,$sgttyb);
+ if ($on) {
+ $ary[4] |= $CBREAK;
+ $ary[4] &= ~$ECHO;
+ } else {
+ $ary[4] &= ~$CBREAK;
+ $ary[4] |= $ECHO;
+ }
+ $sgttyb = pack($sgttyb_t,@ary);
+ ioctl(STDIN,$TIOCSETP,$sgttyb)
+ || die "Can't ioctl TIOCSETP: $!";
+
+}
+
+1;
diff --git a/contrib/perl5/h2pl/eg/sizeof.ph b/contrib/perl5/h2pl/eg/sizeof.ph
new file mode 100644
index 000000000000..285bff185910
--- /dev/null
+++ b/contrib/perl5/h2pl/eg/sizeof.ph
@@ -0,0 +1,14 @@
+$sizeof{'char'} = 1;
+$sizeof{'int'} = 4;
+$sizeof{'long'} = 4;
+$sizeof{'struct arpreq'} = 36;
+$sizeof{'struct ifconf'} = 8;
+$sizeof{'struct ifreq'} = 32;
+$sizeof{'struct ltchars'} = 6;
+$sizeof{'struct pcntl'} = 116;
+$sizeof{'struct rtentry'} = 52;
+$sizeof{'struct sgttyb'} = 6;
+$sizeof{'struct tchars'} = 6;
+$sizeof{'struct ttychars'} = 14;
+$sizeof{'struct winsize'} = 8;
+$sizeof{'struct termios'} = 132;
diff --git a/contrib/perl5/h2pl/eg/sys/errno.pl b/contrib/perl5/h2pl/eg/sys/errno.pl
new file mode 100644
index 000000000000..d9ba3be190f5
--- /dev/null
+++ b/contrib/perl5/h2pl/eg/sys/errno.pl
@@ -0,0 +1,92 @@
+$EPERM = 0x1;
+$ENOENT = 0x2;
+$ESRCH = 0x3;
+$EINTR = 0x4;
+$EIO = 0x5;
+$ENXIO = 0x6;
+$E2BIG = 0x7;
+$ENOEXEC = 0x8;
+$EBADF = 0x9;
+$ECHILD = 0xA;
+$EAGAIN = 0xB;
+$ENOMEM = 0xC;
+$EACCES = 0xD;
+$EFAULT = 0xE;
+$ENOTBLK = 0xF;
+$EBUSY = 0x10;
+$EEXIST = 0x11;
+$EXDEV = 0x12;
+$ENODEV = 0x13;
+$ENOTDIR = 0x14;
+$EISDIR = 0x15;
+$EINVAL = 0x16;
+$ENFILE = 0x17;
+$EMFILE = 0x18;
+$ENOTTY = 0x19;
+$ETXTBSY = 0x1A;
+$EFBIG = 0x1B;
+$ENOSPC = 0x1C;
+$ESPIPE = 0x1D;
+$EROFS = 0x1E;
+$EMLINK = 0x1F;
+$EPIPE = 0x20;
+$EDOM = 0x21;
+$ERANGE = 0x22;
+$EWOULDBLOCK = 0x23;
+$EINPROGRESS = 0x24;
+$EALREADY = 0x25;
+$ENOTSOCK = 0x26;
+$EDESTADDRREQ = 0x27;
+$EMSGSIZE = 0x28;
+$EPROTOTYPE = 0x29;
+$ENOPROTOOPT = 0x2A;
+$EPROTONOSUPPORT = 0x2B;
+$ESOCKTNOSUPPORT = 0x2C;
+$EOPNOTSUPP = 0x2D;
+$EPFNOSUPPORT = 0x2E;
+$EAFNOSUPPORT = 0x2F;
+$EADDRINUSE = 0x30;
+$EADDRNOTAVAIL = 0x31;
+$ENETDOWN = 0x32;
+$ENETUNREACH = 0x33;
+$ENETRESET = 0x34;
+$ECONNABORTED = 0x35;
+$ECONNRESET = 0x36;
+$ENOBUFS = 0x37;
+$EISCONN = 0x38;
+$ENOTCONN = 0x39;
+$ESHUTDOWN = 0x3A;
+$ETOOMANYREFS = 0x3B;
+$ETIMEDOUT = 0x3C;
+$ECONNREFUSED = 0x3D;
+$ELOOP = 0x3E;
+$ENAMETOOLONG = 0x3F;
+$EHOSTDOWN = 0x40;
+$EHOSTUNREACH = 0x41;
+$ENOTEMPTY = 0x42;
+$EPROCLIM = 0x43;
+$EUSERS = 0x44;
+$EDQUOT = 0x45;
+$ESTALE = 0x46;
+$EREMOTE = 0x47;
+$EDEADLK = 0x48;
+$ENOLCK = 0x49;
+$MTH_UNDEF_SQRT = 0x12C;
+$MTH_OVF_EXP = 0x12D;
+$MTH_UNDEF_LOG = 0x12E;
+$MTH_NEG_BASE = 0x12F;
+$MTH_ZERO_BASE = 0x130;
+$MTH_OVF_POW = 0x131;
+$MTH_LRG_SIN = 0x132;
+$MTH_LRG_COS = 0x133;
+$MTH_LRG_TAN = 0x134;
+$MTH_LRG_COT = 0x135;
+$MTH_OVF_TAN = 0x136;
+$MTH_OVF_COT = 0x137;
+$MTH_UNDEF_ASIN = 0x138;
+$MTH_UNDEF_ACOS = 0x139;
+$MTH_UNDEF_ATAN2 = 0x13A;
+$MTH_OVF_SINH = 0x13B;
+$MTH_OVF_COSH = 0x13C;
+$MTH_UNDEF_ZLOG = 0x13D;
+$MTH_UNDEF_ZDIV = 0x13E;
diff --git a/contrib/perl5/h2pl/eg/sys/ioctl.pl b/contrib/perl5/h2pl/eg/sys/ioctl.pl
new file mode 100644
index 000000000000..0b552caa00e6
--- /dev/null
+++ b/contrib/perl5/h2pl/eg/sys/ioctl.pl
@@ -0,0 +1,186 @@
+$_IOCTL_ = 0x1;
+$TIOCGSIZE = 0x40087468;
+$TIOCSSIZE = 0x80087467;
+$IOCPARM_MASK = 0x7F;
+$IOC_VOID = 0x20000000;
+$IOC_OUT = 0x40000000;
+$IOC_IN = 0x80000000;
+$IOC_INOUT = 0xC0000000;
+$TIOCGETD = 0x40047400;
+$TIOCSETD = 0x80047401;
+$TIOCHPCL = 0x20007402;
+$TIOCMODG = 0x40047403;
+$TIOCMODS = 0x80047404;
+$TIOCM_LE = 0x1;
+$TIOCM_DTR = 0x2;
+$TIOCM_RTS = 0x4;
+$TIOCM_ST = 0x8;
+$TIOCM_SR = 0x10;
+$TIOCM_CTS = 0x20;
+$TIOCM_CAR = 0x40;
+$TIOCM_CD = 0x40;
+$TIOCM_RNG = 0x80;
+$TIOCM_RI = 0x80;
+$TIOCM_DSR = 0x100;
+$TIOCGETP = 0x40067408;
+$TIOCSETP = 0x80067409;
+$TIOCSETN = 0x8006740A;
+$TIOCEXCL = 0x2000740D;
+$TIOCNXCL = 0x2000740E;
+$TIOCFLUSH = 0x80047410;
+$TIOCSETC = 0x80067411;
+$TIOCGETC = 0x40067412;
+$TIOCSET = 0x80047413;
+$TIOCBIS = 0x80047414;
+$TIOCBIC = 0x80047415;
+$TIOCGET = 0x40047416;
+$TANDEM = 0x1;
+$CBREAK = 0x2;
+$LCASE = 0x4;
+$ECHO = 0x8;
+$CRMOD = 0x10;
+$RAW = 0x20;
+$ODDP = 0x40;
+$EVENP = 0x80;
+$ANYP = 0xC0;
+$NLDELAY = 0x300;
+$NL0 = 0x0;
+$NL1 = 0x100;
+$NL2 = 0x200;
+$NL3 = 0x300;
+$TBDELAY = 0xC00;
+$TAB0 = 0x0;
+$TAB1 = 0x400;
+$TAB2 = 0x800;
+$XTABS = 0xC00;
+$CRDELAY = 0x3000;
+$CR0 = 0x0;
+$CR1 = 0x1000;
+$CR2 = 0x2000;
+$CR3 = 0x3000;
+$VTDELAY = 0x4000;
+$FF0 = 0x0;
+$FF1 = 0x4000;
+$BSDELAY = 0x8000;
+$BS0 = 0x0;
+$BS1 = 0x8000;
+$ALLDELAY = 0xFF00;
+$CRTBS = 0x10000;
+$PRTERA = 0x20000;
+$CRTERA = 0x40000;
+$TILDE = 0x80000;
+$MDMBUF = 0x100000;
+$LITOUT = 0x200000;
+$TOSTOP = 0x400000;
+$FLUSHO = 0x800000;
+$NOHANG = 0x1000000;
+$L001000 = 0x2000000;
+$CRTKIL = 0x4000000;
+$L004000 = 0x8000000;
+$CTLECH = 0x10000000;
+$PENDIN = 0x20000000;
+$DECCTQ = 0x40000000;
+$NOFLSH = 0x80000000;
+$TIOCCSET = 0x800E7417;
+$TIOCCGET = 0x400E7418;
+$TIOCLBIS = 0x8004747F;
+$TIOCLBIC = 0x8004747E;
+$TIOCLSET = 0x8004747D;
+$TIOCLGET = 0x4004747C;
+$LCRTBS = 0x1;
+$LPRTERA = 0x2;
+$LCRTERA = 0x4;
+$LTILDE = 0x8;
+$LMDMBUF = 0x10;
+$LLITOUT = 0x20;
+$LTOSTOP = 0x40;
+$LFLUSHO = 0x80;
+$LNOHANG = 0x100;
+$LCRTKIL = 0x400;
+$LCTLECH = 0x1000;
+$LPENDIN = 0x2000;
+$LDECCTQ = 0x4000;
+$LNOFLSH = 0x8000;
+$TIOCSBRK = 0x2000747B;
+$TIOCCBRK = 0x2000747A;
+$TIOCSDTR = 0x20007479;
+$TIOCCDTR = 0x20007478;
+$TIOCGPGRP = 0x40047477;
+$TIOCSPGRP = 0x80047476;
+$TIOCSLTC = 0x80067475;
+$TIOCGLTC = 0x40067474;
+$TIOCOUTQ = 0x40047473;
+$TIOCSTI = 0x80017472;
+$TIOCNOTTY = 0x20007471;
+$TIOCPKT = 0x80047470;
+$TIOCPKT_DATA = 0x0;
+$TIOCPKT_FLUSHREAD = 0x1;
+$TIOCPKT_FLUSHWRITE = 0x2;
+$TIOCPKT_STOP = 0x4;
+$TIOCPKT_START = 0x8;
+$TIOCPKT_NOSTOP = 0x10;
+$TIOCPKT_DOSTOP = 0x20;
+$TIOCSTOP = 0x2000746F;
+$TIOCSTART = 0x2000746E;
+$TIOCREMOTE = 0x20007469;
+$TIOCGWINSZ = 0x40087468;
+$TIOCSWINSZ = 0x80087467;
+$TIOCRESET = 0x20007466;
+$OTTYDISC = 0x0;
+$NETLDISC = 0x1;
+$NTTYDISC = 0x2;
+$FIOCLEX = 0x20006601;
+$FIONCLEX = 0x20006602;
+$FIONREAD = 0x4004667F;
+$FIONBIO = 0x8004667E;
+$FIOASYNC = 0x8004667D;
+$FIOSETOWN = 0x8004667C;
+$FIOGETOWN = 0x4004667B;
+$STPUTTABLE = 0x8004667A;
+$STGETTABLE = 0x80046679;
+$SIOCSHIWAT = 0x80047300;
+$SIOCGHIWAT = 0x40047301;
+$SIOCSLOWAT = 0x80047302;
+$SIOCGLOWAT = 0x40047303;
+$SIOCATMARK = 0x40047307;
+$SIOCSPGRP = 0x80047308;
+$SIOCGPGRP = 0x40047309;
+$SIOCADDRT = 0x8034720A;
+$SIOCDELRT = 0x8034720B;
+$SIOCSIFADDR = 0x8020690C;
+$SIOCGIFADDR = 0xC020690D;
+$SIOCSIFDSTADDR = 0x8020690E;
+$SIOCGIFDSTADDR = 0xC020690F;
+$SIOCSIFFLAGS = 0x80206910;
+$SIOCGIFFLAGS = 0xC0206911;
+$SIOCGIFBRDADDR = 0xC0206912;
+$SIOCSIFBRDADDR = 0x80206913;
+$SIOCGIFCONF = 0xC0086914;
+$SIOCGIFNETMASK = 0xC0206915;
+$SIOCSIFNETMASK = 0x80206916;
+$SIOCGIFMETRIC = 0xC0206917;
+$SIOCSIFMETRIC = 0x80206918;
+$SIOCSARP = 0x8024691E;
+$SIOCGARP = 0xC024691F;
+$SIOCDARP = 0x80246920;
+$PIXCONTINUE = 0x80747000;
+$PIXSTEP = 0x80747001;
+$PIXTERMINATE = 0x20007002;
+$PIGETFLAGS = 0x40747003;
+$PIXINHERIT = 0x80747004;
+$PIXDETACH = 0x20007005;
+$PIXGETSUBCODE = 0xC0747006;
+$PIXRDREGS = 0xC0747007;
+$PIXWRREGS = 0xC0747008;
+$PIXRDVREGS = 0xC0747009;
+$PIXWRVREGS = 0xC074700A;
+$PIXRDVSTATE = 0xC074700B;
+$PIXWRVSTATE = 0xC074700C;
+$PIXRDCREGS = 0xC074700D;
+$PIXWRCREGS = 0xC074700E;
+$PIRDSDRS = 0xC074700F;
+$PIXGETSIGACTION = 0xC0747010;
+$PIGETU = 0xC0747011;
+$PISETRWTID = 0xC0747012;
+$PIXGETTHCOUNT = 0xC0747013;
+$PIXRUN = 0x20007014;
diff --git a/contrib/perl5/h2pl/eg/sysexits.pl b/contrib/perl5/h2pl/eg/sysexits.pl
new file mode 100644
index 000000000000..f4cb777ee917
--- /dev/null
+++ b/contrib/perl5/h2pl/eg/sysexits.pl
@@ -0,0 +1,16 @@
+$EX_OK = 0x0;
+$EX__BASE = 0x40;
+$EX_USAGE = 0x40;
+$EX_DATAERR = 0x41;
+$EX_NOINPUT = 0x42;
+$EX_NOUSER = 0x43;
+$EX_NOHOST = 0x44;
+$EX_UNAVAILABLE = 0x45;
+$EX_SOFTWARE = 0x46;
+$EX_OSERR = 0x47;
+$EX_OSFILE = 0x48;
+$EX_CANTCREAT = 0x49;
+$EX_IOERR = 0x4A;
+$EX_TEMPFAIL = 0x4B;
+$EX_PROTOCOL = 0x4C;
+$EX_NOPERM = 0x4D;
diff --git a/contrib/perl5/h2pl/getioctlsizes b/contrib/perl5/h2pl/getioctlsizes
new file mode 100644
index 000000000000..403fffaf86ce
--- /dev/null
+++ b/contrib/perl5/h2pl/getioctlsizes
@@ -0,0 +1,13 @@
+#!/usr/bin/perl
+
+open (IOCTLS,'/usr/include/sys/ioctl.h') || die "ioctl open failed";
+
+while (<IOCTLS>) {
+ if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\('?\w+'?,\s*\w+,\s*([^)]+)/) {
+ $need{$2}++;
+ }
+}
+
+foreach $key ( sort keys %need ) {
+ print $key,"\n";
+}
diff --git a/contrib/perl5/h2pl/mksizes b/contrib/perl5/h2pl/mksizes
new file mode 100644
index 000000000000..cb4b8ab86ea4
--- /dev/null
+++ b/contrib/perl5/h2pl/mksizes
@@ -0,0 +1,42 @@
+#!/usr/local/bin/perl
+
+($iam = $0) =~ s%.*/%%;
+$tmp = "$iam.$$";
+open (CODE,">$tmp.c") || die "$iam: cannot create $tmp.c: $!\n";
+
+$mask = q/printf ("$sizeof{'%s'} = %d;\n"/;
+
+# write C program
+select(CODE);
+
+print <<EO_C_PROGRAM;
+#include <sys/param.h>
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <net/if_arp.h>
+#include <net/if.h>
+#include <net/route.h>
+#include <sys/ioctl.h>
+
+main() {
+EO_C_PROGRAM
+
+while ( <> ) {
+ chop;
+ printf "\t%s, \n\t\t\"%s\", sizeof(%s));\n", $mask, $_,$_;
+}
+
+print "\n}\n";
+
+close CODE;
+
+# compile C program
+
+select(STDOUT);
+
+system "cc $tmp.c -o $tmp";
+die "couldn't compile $tmp.c" if $?;
+system "./$tmp";
+die "couldn't run $tmp" if $?;
+
+unlink "$tmp.c", $tmp;
diff --git a/contrib/perl5/h2pl/mkvars b/contrib/perl5/h2pl/mkvars
new file mode 100644
index 000000000000..ffb0f0b0b9e2
--- /dev/null
+++ b/contrib/perl5/h2pl/mkvars
@@ -0,0 +1,31 @@
+#!/usr/bin/perl
+
+require 'sizeof.ph';
+
+$LIB = '/usr/local/lib/perl';
+
+foreach $include (@ARGV) {
+ printf STDERR "including %s\n", $include;
+ do $include;
+ warn "sourcing $include: $@\n" if ($@);
+ if (!open (INCLUDE,"$LIB/$include")) {
+ warn "can't open $LIB/$include: $!\n";
+ next;
+ }
+ while (<INCLUDE>) {
+ chop;
+ if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) {
+ $var = $1;
+ $val = eval "&$var;";
+ if ($@) {
+ warn "$@: $_";
+ print <<EOT;
+warn "\$$var isn't correctly set" if defined \$_main{'$var'};
+EOT
+ next;
+ }
+ ( $nval = sprintf ("%x",$val ) ) =~ tr/a-z/A-Z/;
+ printf "\$%s = 0x%s;\n", $var, $nval;
+ }
+ }
+}
diff --git a/contrib/perl5/h2pl/tcbreak b/contrib/perl5/h2pl/tcbreak
new file mode 100644
index 000000000000..2677cc982bcf
--- /dev/null
+++ b/contrib/perl5/h2pl/tcbreak
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+require 'cbreak.pl';
+
+&cbreak;
+
+$| = 1;
+
+print "gimme a char: ";
+
+$c = getc;
+
+print "$c\n";
+
+printf "you gave me `%s', which is 0x%02x\n", $c, ord($c);
+
+&cooked;
diff --git a/contrib/perl5/h2pl/tcbreak2 b/contrib/perl5/h2pl/tcbreak2
new file mode 100644
index 000000000000..fcbf92651612
--- /dev/null
+++ b/contrib/perl5/h2pl/tcbreak2
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+require 'cbreak2.pl';
+
+&cbreak;
+
+$| = 1;
+
+print "gimme a char: ";
+
+$c = getc;
+
+print "$c\n";
+
+printf "you gave me `%s', which is 0x%02x\n", $c, ord($c);
+
+&cooked;
diff --git a/contrib/perl5/handy.h b/contrib/perl5/handy.h
new file mode 100644
index 000000000000..eb26ed8deb17
--- /dev/null
+++ b/contrib/perl5/handy.h
@@ -0,0 +1,338 @@
+/* handy.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#if !defined(__STDC__)
+#ifdef NULL
+#undef NULL
+#endif
+#ifndef I286
+# define NULL 0
+#else
+# define NULL 0L
+#endif
+#endif
+
+#define Null(type) ((type)NULL)
+#define Nullch Null(char*)
+#define Nullfp Null(PerlIO*)
+#define Nullsv Null(SV*)
+
+#ifdef TRUE
+#undef TRUE
+#endif
+#ifdef FALSE
+#undef FALSE
+#endif
+#define TRUE (1)
+#define FALSE (0)
+
+
+/* XXX Configure ought to have a test for a boolean type, if I can
+ just figure out all the headers such a test needs.
+ Andy Dougherty August 1996
+*/
+/* bool is built-in for g++-2.6.3, which might be used for an extension.
+ If the extension includes <_G_config.h> before this file then
+ _G_HAVE_BOOL will be properly set. If, however, the extension includes
+ this file first, then you will have to manually set -DHAS_BOOL in
+ your command line to avoid a conflict.
+*/
+#ifdef _G_HAVE_BOOL
+# if _G_HAVE_BOOL
+# ifndef HAS_BOOL
+# define HAS_BOOL 1
+# endif
+# endif
+#endif
+
+/* The NeXT dynamic loader headers will not build with the bool macro
+ So declare them now to clear confusion.
+*/
+#ifdef NeXT
+# undef FALSE
+# undef TRUE
+ typedef enum bool { FALSE = 0, TRUE = 1 } bool;
+# define ENUM_BOOL 1
+# ifndef HAS_BOOL
+# define HAS_BOOL 1
+# endif /* !HAS_BOOL */
+#endif /* NeXT */
+
+#ifndef HAS_BOOL
+# if defined(UTS) || defined(VMS)
+# define bool int
+# else
+# define bool char
+# endif
+#endif
+
+/* XXX A note on the perl source internal type system. The
+ original intent was that I32 be *exactly* 32 bits.
+
+ Currently, we only guarantee that I32 is *at least* 32 bits.
+ Specifically, if int is 64 bits, then so is I32. (This is the case
+ for the Cray.) This has the advantage of meshing nicely with
+ standard library calls (where we pass an I32 and the library is
+ expecting an int), but the disadvantage that an I32 is not 32 bits.
+ Andy Dougherty August 1996
+
+ There is no guarantee that there is *any* integral type with
+ exactly 32 bits. It is perfectly legal for a system to have
+ sizeof(short) == sizeof(int) == sizeof(long) == 8.
+
+ Similarly, there is no guarantee that I16 and U16 have exactly 16
+ bits.
+
+ For dealing with issues that may arise from various 32/64-bit
+ systems, we will ask Configure to check out
+ SHORTSIZE == sizeof(short)
+ INTSIZE == sizeof(int)
+ LONGSIZE == sizeof(long)
+ LONGLONGSIZE == sizeof(long long) (if HAS_LONG_LONG)
+ PTRSIZE == sizeof(void *)
+ DOUBLESIZE == sizeof(double)
+ LONG_DOUBLESIZE == sizeof(long double) (if HAS_LONG_DOUBLE).
+ Most of these are currently unused, but they are mentioned here so
+ metaconfig will include the appropriate tests in Configure and
+ we can then start to consider how best to deal with long long
+ variables.
+ Andy Dougherty April 1998
+*/
+
+typedef char I8;
+typedef unsigned char U8;
+/* I8_MAX and I8_MIN constants are not defined, as I8 is an ambiguous type.
+ Please search CHAR_MAX in perl.h for further details. */
+#define U8_MAX PERL_UCHAR_MAX
+#define U8_MIN PERL_UCHAR_MIN
+
+typedef short I16;
+typedef unsigned short U16;
+#define I16_MAX PERL_SHORT_MAX
+#define I16_MIN PERL_SHORT_MIN
+#define U16_MAX PERL_USHORT_MAX
+#define U16_MIN PERL_USHORT_MIN
+
+#if LONGSIZE > 4
+ typedef int I32;
+ typedef unsigned int U32;
+# define I32_MAX PERL_INT_MAX
+# define I32_MIN PERL_INT_MIN
+# define U32_MAX PERL_UINT_MAX
+# define U32_MIN PERL_UINT_MIN
+#else
+ typedef long I32;
+ typedef unsigned long U32;
+# define I32_MAX PERL_LONG_MAX
+# define I32_MIN PERL_LONG_MIN
+# define U32_MAX PERL_ULONG_MAX
+# define U32_MIN PERL_ULONG_MIN
+#endif
+
+#define BIT_DIGITS(N) (((N)*146)/485 + 1) /* log2(10) =~ 146/485 */
+#define TYPE_DIGITS(T) BIT_DIGITS(sizeof(T) * 8)
+#define TYPE_CHARS(T) (TYPE_DIGITS(T) + 2) /* sign, NUL */
+
+#define Ctl(ch) ((ch) & 037)
+
+#define strNE(s1,s2) (strcmp(s1,s2))
+#define strEQ(s1,s2) (!strcmp(s1,s2))
+#define strLT(s1,s2) (strcmp(s1,s2) < 0)
+#define strLE(s1,s2) (strcmp(s1,s2) <= 0)
+#define strGT(s1,s2) (strcmp(s1,s2) > 0)
+#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
+#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
+#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
+
+#ifdef HAS_MEMCMP
+# define memNE(s1,s2,l) (memcmp(s1,s2,l))
+# define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
+#else
+# define memNE(s1,s2,l) (bcmp(s1,s2,l))
+# define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
+#endif
+
+/*
+ * Character classes.
+ *
+ * Unfortunately, the introduction of locales means that we
+ * can't trust isupper(), etc. to tell the truth. And when
+ * it comes to /\w+/ with tainting enabled, we *must* be able
+ * to trust our character classes.
+ *
+ * Therefore, the default tests in the text of Perl will be
+ * independent of locale. Any code that wants to depend on
+ * the current locale will use the tests that begin with "lc".
+ */
+
+#ifdef HAS_SETLOCALE /* XXX Is there a better test for this? */
+# ifndef CTYPE256
+# define CTYPE256
+# endif
+#endif
+
+#define isALNUM(c) (isALPHA(c) || isDIGIT(c) || (c) == '_')
+#define isIDFIRST(c) (isALPHA(c) || (c) == '_')
+#define isALPHA(c) (isUPPER(c) || isLOWER(c))
+#define isSPACE(c) \
+ ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) =='\r' || (c) == '\f')
+#define isDIGIT(c) ((c) >= '0' && (c) <= '9')
+#ifdef EBCDIC
+ /* In EBCDIC we do not do locales: therefore() isupper() is fine. */
+# define isUPPER(c) isupper(c)
+# define isLOWER(c) islower(c)
+# define isPRINT(c) isprint(c)
+# define toUPPER(c) toupper(c)
+# define toLOWER(c) tolower(c)
+#else
+# define isUPPER(c) ((c) >= 'A' && (c) <= 'Z')
+# define isLOWER(c) ((c) >= 'a' && (c) <= 'z')
+# define isPRINT(c) (((c) > 32 && (c) < 127) || isSPACE(c))
+# define toUPPER(c) (isLOWER(c) ? (c) - ('a' - 'A') : (c))
+# define toLOWER(c) (isUPPER(c) ? (c) + ('a' - 'A') : (c))
+#endif
+
+#ifdef USE_NEXT_CTYPE
+
+# define isALNUM_LC(c) \
+ (NXIsAlpha((unsigned int)(c)) || NXIsDigit((unsigned int)(c)) || \
+ (char)(c) == '_')
+# define isIDFIRST_LC(c) \
+ (NXIsAlpha((unsigned int)(c)) || (char)(c) == '_')
+# define isALPHA_LC(c) NXIsAlpha((unsigned int)(c))
+# define isSPACE_LC(c) NXIsSpace((unsigned int)(c))
+# define isDIGIT_LC(c) NXIsDigit((unsigned int)(c))
+# define isUPPER_LC(c) NXIsUpper((unsigned int)(c))
+# define isLOWER_LC(c) NXIsLower((unsigned int)(c))
+# define isPRINT_LC(c) NXIsPrint((unsigned int)(c))
+# define toUPPER_LC(c) NXToUpper((unsigned int)(c))
+# define toLOWER_LC(c) NXToLower((unsigned int)(c))
+
+#else /* !USE_NEXT_CTYPE */
+# if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII))
+
+# define isALNUM_LC(c) \
+ (isalpha((unsigned char)(c)) || \
+ isdigit((unsigned char)(c)) || (char)(c) == '_')
+# define isIDFIRST_LC(c) (isalpha((unsigned char)(c)) || (char)(c) == '_')
+# define isALPHA_LC(c) isalpha((unsigned char)(c))
+# define isSPACE_LC(c) isspace((unsigned char)(c))
+# define isDIGIT_LC(c) isdigit((unsigned char)(c))
+# define isUPPER_LC(c) isupper((unsigned char)(c))
+# define isLOWER_LC(c) islower((unsigned char)(c))
+# define isPRINT_LC(c) isprint((unsigned char)(c))
+# define toUPPER_LC(c) toupper((unsigned char)(c))
+# define toLOWER_LC(c) tolower((unsigned char)(c))
+
+# else
+
+# define isALNUM_LC(c) \
+ (isascii(c) && (isalpha(c) || isdigit(c) || (c) == '_'))
+# define isIDFIRST_LC(c) (isascii(c) && (isalpha(c) || (c) == '_'))
+# define isALPHA_LC(c) (isascii(c) && isalpha(c))
+# define isSPACE_LC(c) (isascii(c) && isspace(c))
+# define isDIGIT_LC(c) (isascii(c) && isdigit(c))
+# define isUPPER_LC(c) (isascii(c) && isupper(c))
+# define isLOWER_LC(c) (isascii(c) && islower(c))
+# define isPRINT_LC(c) (isascii(c) && isprint(c))
+# define toUPPER_LC(c) toupper(c)
+# define toLOWER_LC(c) tolower(c)
+
+# endif
+#endif /* USE_NEXT_CTYPE */
+
+#ifdef EBCDIC
+EXT int ebcdic_control _((int));
+# define toCTRL(c) ebcdic_control(c)
+#else
+ /* This conversion works both ways, strangely enough. */
+# define toCTRL(c) (toUPPER(c) ^ 64)
+#endif
+
+/* Line numbers are unsigned, 16 bits. */
+typedef U16 line_t;
+#ifdef lint
+#define NOLINE ((line_t)0)
+#else
+#define NOLINE ((line_t) 65535)
+#endif
+
+
+/* This looks obsolete (IZ):
+
+ XXX LEAKTEST doesn't really work in perl5. There are direct calls to
+ safemalloc() in the source, so LEAKTEST won't pick them up.
+ Further, if you try LEAKTEST, you'll also end up calling
+ Safefree, which might call safexfree() on some things that weren't
+ malloced with safexmalloc. The correct "fix" to this, if anyone
+ is interested, is to ensure that all calls go through the New and
+ Renew macros.
+ --Andy Dougherty August 1996
+*/
+
+#ifndef lint
+
+#define NEWSV(x,len) newSV(len)
+
+#ifndef LEAKTEST
+
+#define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n)*sizeof(t))))
+#define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n)*sizeof(t))))
+#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n)*sizeof(t)))), \
+ memzero((char*)(v), (n)*sizeof(t))
+#define Renew(v,n,t) \
+ (v = (t*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t))))
+#define Renewc(v,n,t,c) \
+ (v = (c*)saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t))))
+#define Safefree(d) safefree((Malloc_t)(d))
+
+#else /* LEAKTEST */
+
+#define New(x,v,n,t) (v = (t*)safexmalloc((x),(MEM_SIZE)((n)*sizeof(t))))
+#define Newc(x,v,n,t,c) (v = (c*)safexmalloc((x),(MEM_SIZE)((n)*sizeof(t))))
+#define Newz(x,v,n,t) (v = (t*)safexmalloc((x),(MEM_SIZE)((n)*sizeof(t)))), \
+ memzero((char*)(v), (n)*sizeof(t))
+#define Renew(v,n,t) \
+ (v = (t*)safexrealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t))))
+#define Renewc(v,n,t,c) \
+ (v = (c*)safexrealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t))))
+#define Safefree(d) safexfree((Malloc_t)(d))
+
+#define MAXXCOUNT 1400
+#define MAXY_SIZE 80
+#define MAXYCOUNT 16 /* (MAXY_SIZE/4 + 1) */
+extern long xcount[MAXXCOUNT];
+extern long lastxcount[MAXXCOUNT];
+extern long xycount[MAXXCOUNT][MAXYCOUNT];
+extern long lastxycount[MAXXCOUNT][MAXYCOUNT];
+
+#endif /* LEAKTEST */
+
+#define Move(s,d,n,t) (void)memmove((char*)(d),(char*)(s), (n) * sizeof(t))
+#define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
+#define Zero(d,n,t) (void)memzero((char*)(d), (n) * sizeof(t))
+
+#else /* lint */
+
+#define New(x,v,n,s) (v = Null(s *))
+#define Newc(x,v,n,s,c) (v = Null(s *))
+#define Newz(x,v,n,s) (v = Null(s *))
+#define Renew(v,n,s) (v = Null(s *))
+#define Move(s,d,n,t)
+#define Copy(s,d,n,t)
+#define Zero(d,n,t)
+#define Safefree(d) (d) = (d)
+
+#endif /* lint */
+
+#ifdef USE_STRUCT_COPY
+#define StructCopy(s,d,t) (*((t*)(d)) = *((t*)(s)))
+#else
+#define StructCopy(s,d,t) Copy(s,d,1,t)
+#endif
diff --git a/contrib/perl5/hints/3b1.sh b/contrib/perl5/hints/3b1.sh
new file mode 100644
index 000000000000..991348af3ec5
--- /dev/null
+++ b/contrib/perl5/hints/3b1.sh
@@ -0,0 +1,15 @@
+d_voidsig='undef'
+d_tosignal='int'
+gidtype='int'
+groupstype='int'
+uidtype='int'
+# Note that 'Configure' is run from 'UU', hence the strange 'ln'
+# command.
+for i in .. ../x2p
+do
+ rm -f $i/3b1cc
+ ln ../hints/3b1cc $i
+done
+echo "\nIf you want to use the 3b1 shared libraries, complete this script then" >&4
+echo "read the header in 3b1cc. [Type carriage return to continue]\c" >&4
+read vch
diff --git a/contrib/perl5/hints/3b1cc b/contrib/perl5/hints/3b1cc
new file mode 100644
index 000000000000..0001e046b8c9
--- /dev/null
+++ b/contrib/perl5/hints/3b1cc
@@ -0,0 +1,88 @@
+# To incorporate the 7300/3b1 shared library, run this script in place
+# of 'CC'.
+# You can skip this is you have the shcc program installed as cc in
+# your path.
+# First: Run 'Configure' through to the end and run 'make depend'.
+# Second: Edit 'makefile' ( not Makefile ) and set CC = 3b1cc.
+# Third: Edit 'x2p/makefile' and set CC = 3b1cc.
+#
+# Do not use '3b1cc' as the default compiler. The call to the default
+# compiler is used by 'perl' and will not be available when running
+# 'perl'.
+#
+# Note: This script omits libraries which are redundant in the shared
+# library. It is an excerpt from a grander version available upon
+# request from "zebra!vern" or "vern@zebra.alphacdc.com".
+
+CC="cc"
+LIBS=
+INCL=
+
+LD="ld"
+SHAREDLIB="/lib/crt0s.o /lib/shlib.ifile"
+
+# Local variables
+COBJS=
+LOBJS=
+TARG=
+FLAGS=
+CMD=
+
+# These are libraries which are incorporated in the shared library
+OMIT="-lmalloc"
+
+# These routines are in libc.a but not in the shared library
+if [ ! -f vsprintf.o -o ! -f doprnt.o ]
+then
+ echo "Extracting vsprintf.o from libc.a"
+ ar -x /lib/libc.a vsprintf.o doprnt.o
+fi
+
+CMD="$CC"
+while [ $# -gt 0 ]
+do
+ case $1 in
+ -c) CFLAG=$1;;
+ -o) CFLAG=$1
+ shift
+ TARG="$1";;
+ -l*) match=false
+ for i in $OMIT
+ do
+ [ "$i" = "$1" ] && match=true
+ done
+ [ "$match" != false ] || LIBS="$LIBS $1";;
+ -*) FLAGS="$FLAGS $1";;
+ *.c) COBJS="$COBJS $1";;
+ *.o) LOBJS="$LOBJS $1";;
+ *) TARG="$1";;
+ esac
+ shift
+done
+
+if [ -n "$COBJS" ]
+then
+ CMD="$CMD $FLAGS $INCL $LPATHS $LIBS $COBJS $CFLAG $TARG"
+elif [ -n "$LOBJS" ]
+then
+ LOBJS="$LOBJS vsprintf.o doprnt.o"
+ CMD="$LD -r $LOBJS $LPATHS $LIBS -o temp.o"
+ echo "\t$CMD"
+ $CMD
+ CMD="$LD -s temp.o $SHAREDLIB -o $TARG"
+ echo "\t$CMD"
+ $CMD
+ ccrslt=$?
+ if [ $ccrslt -ne 0 ]
+ then
+ exit $ccrslt
+ fi
+ CMD="rm -f temp.o"
+else
+ exit 1
+fi
+echo "\t$CMD"
+$CMD
+ccrslt=$?
+rm -f $$.c
+exit $ccrslt
diff --git a/contrib/perl5/hints/README.hints b/contrib/perl5/hints/README.hints
new file mode 100644
index 000000000000..e36bd6d1dd9e
--- /dev/null
+++ b/contrib/perl5/hints/README.hints
@@ -0,0 +1,213 @@
+=head1 NAME
+
+README.hints
+
+=head1 DESCRIPTION
+
+These files are used by Configure to set things which Configure either
+can't or doesn't guess properly. Most of these hint files have been
+tested with at least some version of perl5, but some are still left
+over from perl4.
+
+Please send any problems or suggested changes to perlbug@perl.com.
+
+Hint file naming convention: Each hint file name should have only
+one '.'. (This is for portability to non-unix file systems.) Names
+should also fit in <= 14 characters, for portability to older SVR3
+systems. File names are of the form $osname_$osvers.sh, with all '.'
+changed to '_', and all characters (such as '/') that don't belong in
+Unix filenames omitted.
+
+For example, consider Sun OS 4.1.3. Configure determines $osname=sunos
+(all names are converted to lower case) and $osvers=4.1.3. Configure
+will search for an appropriate hint file in the following order:
+
+ sunos_4_1_3.sh
+ sunos_4_1.sh
+ sunos_4.sh
+ sunos.sh
+
+If you need to create a hint file, please try to use as general a name
+as possible and include minor version differences inside case or test
+statements. For example, for IRIX 6.X, we have the following hints
+files:
+
+ irix_6_0.sh
+ irix_6_1.sh
+ irix_6.sh
+
+That is, 6.0 and 6.1 have their own special hints, but 6.2, 6.3, and
+up are all handled by the same irix_6.sh. That way, we don't have to
+make a new hint file every time the IRIX O/S is upgraded.
+
+If you need to test for specific minor version differences in your
+hints file, be sure to include a default choice. (See aix.sh for one
+example.) That way, if you write a hint file for foonix 3.2, it might
+still work without any changes when foonix 3.3 is released.
+
+Please also comment carefully on why the different hints are needed.
+That way, a future version of Configure may be able to automatically
+detect what is needed.
+
+A glossary of config.sh variables is in the file Porting/Glossary.
+
+=head1 Hint file tricks
+
+=head2 Printing critical messages
+
+[This is still experimental]
+
+If you have a *REALLY* important message that the user ought to see at
+the end of the Configure run, you can store it in the file
+'config.msg'. At the end of the Configure run, Configure will display
+the contents of this file. Currently, the only place this is used is
+in Configure itself to warn about the need to set LD_LIBRARY_PATH if
+you are building a shared libperl.so.
+
+To use this feature, just do something like the following
+
+ $cat <<EOM | $tee -a ../config.msg >&4
+
+ This is a really important message. Be sure to read it
+ before you type 'make'.
+ EOM
+
+This message will appear on the screen as the hint file is being
+processed and again at the end of Configure.
+
+Please use this sparingly.
+
+=head2 Propagating variables to config.sh
+
+Sometimes, you want an extra variable to appear in config.sh. For
+example, if your system can't compile toke.c with the optimizer on,
+you can put
+
+ toke_cflags='optimize=""'
+
+at the beginning of a line in your hints file. Configure will then
+extract that variable and place it in your config.sh file. Later,
+while compiling toke.c, the cflags shell script will eval $toke_cflags
+and hence compile toke.c without optimization.
+
+Note that for this to work, the variable you want to propagate must
+appear in the first column of the hint file. It is extracted by
+Configure with a simple sed script, so beware that surrounding case
+statements aren't any help.
+
+By contrast, if you don't want Configure to propagate your temporary
+variable, simply indent it by a leading tab in your hint file.
+
+For example, prior to 5.002, a bug in scope.c led to perl crashing
+when compiled with -O in AIX 4.1.1. The following "obvious"
+workaround in hints/aix.sh wouldn't work as expected:
+
+ case "$osvers" in
+ 4.1.1)
+ scope_cflags='optimize=""'
+ ;;
+ esac
+
+because Configure doesn't parse the surrounding 'case' statement, it
+just blindly propagates any variable that starts in the first column.
+For this particular case, that's probably harmless anyway.
+
+Three possible fixes are:
+
+=over
+
+=item 1
+
+Create an aix_4_1_1.sh hint file that contains the scope_cflags
+line and then sources the regular aix hints file for the rest of
+the information.
+
+=item 2
+
+Do the following trick:
+
+ scope_cflags='case "$osvers" in 4.1*) optimize=" ";; esac'
+
+Now when $scope_cflags is eval'd by the cflags shell script, the
+case statement is executed. Of course writing scripts to be eval'd is
+tricky, especially if there is complex quoting. Or,
+
+=item 3
+
+Write directly to Configure's temporary file UU/config.sh.
+You can do this with
+
+ case "$osvers" in
+ 4.1.1)
+ echo "scope_cflags='optimize=\"\"'" >> UU/config.sh
+ scope_cflags='optimize=""'
+ ;;
+ esac
+
+Note you have to both write the definition to the temporary
+UU/config.sh file and set the variable to the appropriate value.
+
+This is sneaky, but it works. Still, if you need anything this
+complex, perhaps you should create the separate hint file for
+aix 4.1.1.
+
+=back
+
+=head2 Call-backs
+
+=over 4
+
+=item Warning
+
+All of the following is experimental and subject to change. But it
+probably won't change much. :-)
+
+=item Compiler-related flags
+
+The settings of some things, such as optimization flags, may depend on
+the particular compiler used. For example, for ISC we have the
+following:
+
+ case "$cc" in
+ *gcc*) ccflags="$ccflags -posix"
+ ldflags="$ldflags -posix"
+ ;;
+ *) ccflags="$ccflags -Xp -D_POSIX_SOURCE"
+ ldflags="$ldflags -Xp"
+ ;;
+ esac
+
+However, the hints file is processed before the user is asked which
+compiler should be used. Thus in order for these hints to be useful,
+the user must specify sh Configure -Dcc=gcc on the command line, as
+advised by the INSTALL file.
+
+For versions of perl later than 5.004_61, this problem can
+be circumvented by the use of "call-back units". That is, the hints
+file can tuck this information away into a file UU/cc.cbu. Then,
+after Configure prompts the user for the C compiler, it will load in
+and run the UU/cc.cbu "call-back" unit. See hints/solaris_2.sh for an
+example.
+
+=item Threading-related flags
+
+Similarly, after Configure prompts the user about whether or not to
+compile Perl with threads, it will look for a "call-back" unit
+usethreads.cbu. See hints/linux.sh for an example.
+
+=item Future status
+
+I hope this "call-back" scheme is simple enough to use but powerful
+enough to deal with most situations. Still, there are certainly cases
+where it's not enough. For example, for aix we actually change
+compilers if we are using threads.
+
+I'd appreciate feedback on whether this is sufficiently general to be
+helpful, or whether we ought to simply continue to require folks to
+say things like "sh Configure -Dcc=gcc -Dusethreads" on the command line.
+
+=back
+
+Have the appropriate amount of fun :-)
+
+ Andy Dougherty doughera@lafcol.lafayette.edu
diff --git a/contrib/perl5/hints/aix.sh b/contrib/perl5/hints/aix.sh
new file mode 100644
index 000000000000..25e204893182
--- /dev/null
+++ b/contrib/perl5/hints/aix.sh
@@ -0,0 +1,102 @@
+# hints/aix.sh
+# AIX 3.x.x hints thanks to Wayne Scott <wscott@ichips.intel.com>
+# AIX 4.1 hints thanks to Christopher Chan-Nui <channui@austin.ibm.com>.
+# AIX 4.1 pthreading by Christopher Chan-Nui <channui@austin.ibm.com> and
+# Jarkko Hietaniemi <jhi@iki.fi>.
+# Merged on Mon Feb 6 10:22:35 EST 1995 by
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+
+
+# Configure finds setrgid and setruid, but they're useless. The man
+# pages state:
+# setrgid: The EPERM error code is always returned.
+# setruid: The EPERM error code is always returned. Processes cannot
+# reset only their real user IDs.
+d_setrgid='undef'
+d_setruid='undef'
+
+alignbytes=8
+
+usemymalloc='n'
+
+so="a"
+dlext="so"
+
+# Make setsockopt work correctly. See man page.
+# ccflags='-D_BSD=44'
+
+# uname -m output is too specific and not appropriate here
+case "$archname" in
+'') archname="$osname" ;;
+esac
+
+case "$osvers" in
+3*) d_fchmod=undef
+ ccflags="$ccflags -D_ALL_SOURCE"
+ ;;
+*) # These hints at least work for 4.x, possibly other systems too.
+ ccflags="$ccflags -D_ALL_SOURCE -D_ANSI_C_SOURCE -D_POSIX_SOURCE"
+ case "$cc" in
+ *gcc*) ;;
+ *) ccflags="$ccflags -qmaxmem=8192" ;;
+ esac
+ nm_opt='-B'
+ ;;
+esac
+
+# These functions don't work like Perl expects them to.
+d_setregid='undef'
+d_setreuid='undef'
+
+# Changes for dynamic linking by Wayne Scott <wscott@ichips.intel.com>
+#
+# Tell perl which symbols to export for dynamic linking.
+case "$cc" in
+*gcc*) ccdlflags='-Xlinker -bE:perl.exp' ;;
+*) ccdlflags='-bE:perl.exp' ;;
+esac
+
+# The first 3 options would not be needed if dynamic libs. could be linked
+# with the compiler instead of ld.
+# -bI:$(PERL_INC)/perl.exp Read the exported symbols from the perl binary
+# -bE:$(BASEEXT).exp Export these symbols. This file contains only one
+# symbol: boot_$(EXP) can it be auto-generated?
+case "$osvers" in
+3*)
+lddlflags='-H512 -T512 -bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -e _nostart -lc'
+ ;;
+*)
+lddlflags='-bhalt:4 -bM:SRE -bI:$(PERL_INC)/perl.exp -bE:$(BASEEXT).exp -b noentry -lc'
+
+;;
+esac
+
+if [ "X$usethreads" = "X$define" ]; then
+ ccflags="$ccflags -DNEED_PTHREAD_INIT"
+ case "$cc" in
+ xlc_r | cc_r)
+ ;;
+ cc | '')
+ cc=xlc_r # Let us be stricter.
+ ;;
+ *)
+ cat >&4 <<EOM
+Unknown C compiler '$cc'.
+For pthreads you should use the AIX C compilers xlc_r or cc_r.
+Cannot continue, aborting.
+EOM
+ exit 1
+ ;;
+ esac
+
+ # Add the POSIX threads library and the re-entrant libc.
+
+ lddlflags=`echo $lddlflags | sed 's/ -lc$/ -lpthreads -lc_r -lc/'`
+
+ # Add the c_r library to the list of libraries wanted
+ # Make sure the c_r library is before the c library or
+ # make will fail.
+ set `echo X "$libswanted "| sed -e 's/ c / c_r c /'`
+ shift
+ libswanted="$*"
+fi
diff --git a/contrib/perl5/hints/altos486.sh b/contrib/perl5/hints/altos486.sh
new file mode 100644
index 000000000000..b85f907e3478
--- /dev/null
+++ b/contrib/perl5/hints/altos486.sh
@@ -0,0 +1,3 @@
+: have heard of problems with -lc_s on Altos 486
+set `echo " $libswanted " | sed "s/ c_s / /"`
+libswanted="$*"
diff --git a/contrib/perl5/hints/amigaos.sh b/contrib/perl5/hints/amigaos.sh
new file mode 100644
index 000000000000..9d86e52bc03c
--- /dev/null
+++ b/contrib/perl5/hints/amigaos.sh
@@ -0,0 +1,51 @@
+# hints/amigaos.sh
+#
+# talk to pueschel@imsdd.meb.uni-bonn.de if you want to change this file.
+#
+# misc stuff
+archname='m68k-amigaos'
+cc='gcc'
+firstmakefile='GNUmakefile'
+usenm='true'
+
+usemymalloc='n'
+usevfork='true'
+useperlio='true'
+d_eofnblk='define'
+d_fork='undef'
+d_vfork='define'
+groupstype='int'
+
+# libs
+
+libpth="$prefix/lib /local/lib"
+glibpth="$libpth"
+xlibpth="$libpth"
+
+libswanted='gdbm m dld'
+so=' '
+
+# compiler & linker flags
+
+ccflags='-DAMIGAOS -mstackextend'
+ldflags=''
+optimize='-O2 -fomit-frame-pointer'
+dlext='o'
+cccdlflags='none'
+ccdlflags='none'
+lddlflags='-oformat a.out-amiga -r'
+
+# uncomment the following settings if you are compiling for an 68020+ system
+# and want a residentable executable instead of dynamic loading
+
+# usedl='n'
+# ccflags='-DAMIGAOS -mstackextend -m68020 -resident32'
+# ldflags='-m68020 -resident32'
+
+# AmigaOS always reports only two links to directories, even if they
+# contain subdirectories. Consequently, we use this variable to stop
+# File::Find using the link count to determine whether there are
+# subdirectories to be searched. This will generate a harmless message:
+# Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
+# Propagating recommended variable dont_use_nlink
+dont_use_nlink='define'
diff --git a/contrib/perl5/hints/apollo.sh b/contrib/perl5/hints/apollo.sh
new file mode 100644
index 000000000000..8c361aa0518c
--- /dev/null
+++ b/contrib/perl5/hints/apollo.sh
@@ -0,0 +1,51 @@
+# Info from Johann Klasek <jk@auto.tuwien.ac.at>
+# Merged by Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Last revised Fri Jun 2 11:21:27 EDT 1995
+
+# uname -a looks like
+# DomainOS newton 10.4.1 bsd4.3 425t
+
+# We want to use both BSD includes and some of the features from the
+# /sys5 includes.
+ccflags="$ccflags -A cpu,mathchip -I/usr/include -I/sys5/usr/include"
+
+# These adjustments are necessary (why?) to compile malloc.c.
+freetype='void'
+i_malloc='undef'
+malloctype='void *'
+
+# This info is left over from perl4.
+cat <<'EOF' >&4
+Some tests may fail unless you use 'chacl -B'. Also, op/stat
+test 2 may fail occasionally because Apollo doesn't guarantee
+that mtime will be equal to ctime on a newly created unmodified
+file. Finally, the sleep test will sometimes fail. See the
+sleep(3) man page to learn why.
+
+See hints/apollo.sh for hints on running h2ph.
+
+And a note on ccflags:
+
+ Lastly, while -A cpu,mathchip generates optimal code for your DN3500
+ running sr10.3, be aware that you should be using -A cpu,mathlib_sr10
+ if your perl must also run on any machines running sr10.0, sr10.1, or
+ sr10.2. The -A cpu,mathchip option generates code that doesn't work on
+ pre-sr10.3 nodes. See the cc(1) man page for more details.
+ -- Steve Vinoski
+
+EOF
+
+# Running h2ph, on the other hand, presents a challenge.
+
+#The perl header files have to be generated with following commands
+
+#sed 's|/usr/include|/sys5/usr/include|g' h2ph >h2ph.new && chmod +x h2ph.new
+#(set cdir=`pwd`; cd /sys5/usr/include; $cdir/h2ph.new sys/* )
+#(set cdir=`pwd`; cd /usr/include; $cdir/h2ph * sys/* machine/*)
+
+#The SYS5 headers (only sys) are overlayed by the BSD headers. It seems
+#all ok, but once I am going into details, a lot of limitations from
+#'h2ph' are coming up. Lines like "#define NODEV (dev_t)(-1)" result in
+#syntax errors as converted by h2ph.
+
+# Generally, h2ph might need a lot of help.
diff --git a/contrib/perl5/hints/aux_3.sh b/contrib/perl5/hints/aux_3.sh
new file mode 100644
index 000000000000..aa3150afbe7a
--- /dev/null
+++ b/contrib/perl5/hints/aux_3.sh
@@ -0,0 +1,22 @@
+# hints/aux_3.sh
+#
+# Improved by Jake Hamby <jehamby@lightside.com> to support both Apple CC
+# and GNU CC. Tested on A/UX 3.1.1 with GCC 2.6.3.
+# Now notifies of problem with version of dbm shipped with A/UX
+# Last modified
+# Sun Jan 5 11:16:41 WET 1997
+
+case "$cc" in
+*gcc*) optimize='-O2'
+ ccflags="$ccflags -D_POSIX_SOURCE"
+ echo "Setting hints for GNU CC."
+ ;;
+*) optimize='-O'
+ ccflags="$ccflags -B/usr/lib/big/ -DPARAM_NEEDS_TYPES -D_POSIX_SOURCE"
+ POSIX_cflags='ccflags="$ccflags -ZP -Du_long=U32"'
+ echo "Setting hints for Apple's CC. If you plan to use"
+ echo "GNU CC, please rerun this Configure script as:"
+ echo "./Configure -Dcc=gcc"
+ ;;
+esac
+test -r ./broken-db.msg && . ./broken-db.msg
diff --git a/contrib/perl5/hints/beos.sh b/contrib/perl5/hints/beos.sh
new file mode 100644
index 000000000000..ab752769b686
--- /dev/null
+++ b/contrib/perl5/hints/beos.sh
@@ -0,0 +1,45 @@
+# BeOS hints file
+# $Id: beos.sh,v 1.1 1998/02/16 03:51:45 dogcow Exp $
+
+if [ ! -f beos/nm ]; then mwcc -w all -o beos/nm beos/nm.c; fi
+
+prefix="/boot/home/config"
+
+cpp="mwcc -e"
+
+libpth='/boot/beos/system/lib /boot/home/config/lib'
+usrinc='/boot/develop/headers/posix'
+locinc='/boot/develop/headers/ /boot/home/config/include'
+
+libc='/boot/beos/system/lib/libroot.so'
+libs=' '
+
+d_bcmp='define'
+d_bcopy='define'
+d_bzero='define'
+d_index='define'
+#d_htonl='define' # It exists, but much hackery would be required to support.
+# a bunch of extra includes would have to be added, and it's only used at
+# one place in the non-socket perl code.
+
+#these are all in libdll.a, which my version of nm doesn't know how to parse.
+#if I can get it to both do that, and scan multiple library files, perhaps
+#these can be gotten rid of.
+
+usemymalloc='n'
+# Hopefully, Be's malloc knows better than perl's.
+
+d_link='undef'
+dont_use_nlink='define'
+# no posix (aka hard) links for us!
+
+d_syserrlst='undef'
+# the array syserrlst[] is useless for the most part.
+# large negative numbers really kind of suck in arrays.
+
+#d_socket='undef'
+# Sockets really don't work with the current version of perl and the
+# current BeOS sockets; I suspect that a new module a la GSAR's WIN32 port
+# will be required.
+
+export PATH="$PATH:$PWD/beos"
diff --git a/contrib/perl5/hints/broken-db.msg b/contrib/perl5/hints/broken-db.msg
new file mode 100644
index 000000000000..92ba0776bfca
--- /dev/null
+++ b/contrib/perl5/hints/broken-db.msg
@@ -0,0 +1,14 @@
+# Several OSs come with an old version of the DB library which fails
+# on a few of the db-recno.t tests. This file is sourced by the hints
+# files for those OSs.
+
+cat <<EOF >&4
+
+Unless you've upgraded your DB library manually you will see failures in
+db-recno tests 51, 53 and 55. The behavior these tests are checking is
+broken in the DB library which is included with the OS. You can ignore
+the errors if you're never going to use the broken functionality (recno
+databases with a modified bval), otherwise you'll have to upgrade your
+DB library or OS.
+
+EOF
diff --git a/contrib/perl5/hints/bsdos.sh b/contrib/perl5/hints/bsdos.sh
new file mode 100644
index 000000000000..c54a0c1606b0
--- /dev/null
+++ b/contrib/perl5/hints/bsdos.sh
@@ -0,0 +1,106 @@
+# hints/bsdos.sh
+#
+# hints file for BSD/OS (adapted from bsd386.sh)
+# Original by Neil Bowers <neilb@khoros.unm.edu>; Tue Oct 4 12:01:34 EDT 1994
+# Updated by Tony Sanders <sanders@bsdi.com>; Sat Aug 23 12:47:45 MDT 1997
+# Added 3.1 with ELF dynamic libraries (NOT in 3.1 yet. Estimated for 4.0)
+# SYSV IPC tested Ok so I re-enabled.
+#
+# To override the compiler on the command line:
+# ./Configure -Dcc=gcc2
+#
+# The BSD/OS distribution is built with:
+# ./Configure -des -Dbsdos_distribution=defined
+
+signal_t='void'
+d_voidsig='define'
+
+usemymalloc='n'
+
+# setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS versions.
+# See http://www.bsdi.com/bsdi-man?setuid(2)
+d_setregid='undef'
+d_setreuid='undef'
+d_setrgid='undef'
+d_setruid='undef'
+
+# we don't want to use -lnm, since exp() is busted (in 1.1 anyway)
+set `echo X "$libswanted "| sed -e 's/ nm / /'`
+shift
+libswanted="$*"
+
+# X libraries are in their own tree
+glibpth="$glibpth /usr/X11/lib"
+ldflags="$ldflags -L/usr/X11/lib"
+
+case "$optimize" in
+'') optimize='-O2' ;;
+esac
+
+case "$bsdos_distribution" in
+''|undef|false) ;;
+*)
+ d_dosuid='define'
+ d_portable='undef'
+ prefix='/usr/contrib'
+ perlpath='/usr/bin/perl5'
+ startperl='#!/usr/bin/perl5'
+ scriptdir='/usr/contrib/bin'
+ privlib='/usr/libdata/perl5'
+ man1dir='/usr/contrib/man/man1'
+ man3dir='/usr/contrib/man/man3'
+ # phlib added by BSDI -- we share the *.ph include dir with perl4
+ phlib="/usr/libdata/perl5/site_perl/$(arch)-$osname/include"
+ phlibexp="/usr/libdata/perl5/site_perl/$(arch)-$osname/include"
+ ;;
+esac
+
+case "$osvers" in
+1.0*)
+ # Avoid problems with HUGE_VAL in POSIX in 1.0's cc.
+ POSIX_cflags='ccflags="$ccflags -UHUGE_VAL"'
+ ;;
+1.1*)
+ # Use gcc2
+ case "$cc" in
+ '') cc='gcc2' ;;
+ esac
+ ;;
+2.0*|2.1*|3.0*|3.1*)
+ so='o'
+
+ # default to GCC 2.X w/shared libraries
+ case "$cc" in
+ '') cc='shlicc2'
+ cccdlflags=' ' ;; # Avoid the dreaded -fpic
+ esac
+
+ # default ld to shared library linker
+ case "$ld" in
+ '') ld='shlicc2'
+ lddlflags='-r' ;; # this one is necessary
+ esac
+
+ # Must preload the static shared libraries.
+ libswanted="Xpm Xaw Xmu Xt SM ICE Xext X11 $libswanted"
+ libswanted="rpc curses termcap $libswanted"
+ ;;
+4.0*)
+ # ELF dynamic link libraries starting in 4.0 (???)
+ useshrplib='true'
+ so='so'
+ dlext='so'
+
+ case "$cc" in
+ '') cc='cc' # cc is gcc2 in 4.0
+ cccdlflags="-fPIC"
+ ccdlflags=" " ;;
+ esac
+
+ case "$ld" in
+ '') ld='ld'
+ lddlflags="-shared -x $lddlflags" ;;
+ esac
+ ;;
+esac
+
diff --git a/contrib/perl5/hints/convexos.sh b/contrib/perl5/hints/convexos.sh
new file mode 100644
index 000000000000..9f6d702b06cc
--- /dev/null
+++ b/contrib/perl5/hints/convexos.sh
@@ -0,0 +1,12 @@
+# convexos.sh
+# Thanks to David Starks-Browning <dstarks@rc.tudelft.nl>
+# Date: Tue, 17 Jan 1995 10:45:03 -0500 (EST)
+# Subject: Re: Hints for ConvexOS 10.2
+#
+# uname -a output looks like
+# ConvexOS xxxx C38xx 10.2 convex
+# Configure may incorrectly assign $3 to $osvers.
+#
+set X $myuname
+shift
+osvers=$4
diff --git a/contrib/perl5/hints/cxux.sh b/contrib/perl5/hints/cxux.sh
new file mode 100644
index 000000000000..e3ac086e2359
--- /dev/null
+++ b/contrib/perl5/hints/cxux.sh
@@ -0,0 +1,106 @@
+#! /local/gnu/bin/bash
+# Hints for the CX/UX 7.1 operating system running on Concurrent (formerly
+# Harris) NightHawk machines. written by Tom.Horsley@mail.ccur.com
+#
+# This config is setup for dynamic linking and the Concurrent C compiler.
+
+# Check some things and print warnings if this isn't going to work...
+#
+case ${SDE_TARGET:-ELF} in
+ [Cc][Oo][Ff][Ff]|[Oo][Cc][Ss]) echo ''
+ echo '' >&2
+ echo WARNING: Do not build perl 5 with the SDE_TARGET set to >&2
+ echo generate coff object - perl 5 must be built in the ELF >&2
+ echo environment. >&2
+ echo '' >&2
+ echo '';;
+ [Ee][Ll][Ff]) : ;;
+ *) echo '' >&2
+ echo 'Unknown SDE_TARGET value: '$SDE_TARGET >&2
+ echo '' >&2 ;;
+esac
+
+case `uname -r` in
+ [789]*) : ;;
+ *) echo ''
+ echo '' >&2
+ echo WARNING: Perl 5 requires shared library support, it cannot >&2
+ echo be built on releases of CX/UX prior to 7.0 with this hints >&2
+ echo file. You\'ll have to do a separate port for the statically >&2
+ echo linked COFF environment. >&2
+ echo '' >&2
+ echo '';;
+esac
+
+# Internally at Concurrent, we use a source management tool which winds up
+# giving us read-only copies of source trees that are mostly symbolic links.
+# That upsets the perl build process when it tries to edit opcode.h and
+# embed.h or touch perly.c or perly.h, so turn those files into "real" files
+# when Configure runs. (If you already have "real" source files, this won't
+# do anything).
+#
+if [ -x /usr/local/mkreal ]
+then
+ for i in '.' '..'
+ do
+ for j in embed.h opcode.h perly.h perly.c
+ do
+ if [ -h $i/$j ]
+ then
+ ( cd $i ; /usr/local/mkreal $j ; chmod 666 $j )
+ fi
+ done
+ done
+fi
+
+# We DO NOT want -lmalloc
+#
+libswanted=`echo ' '$libswanted' ' | sed -e 's/ malloc / /'`
+
+# Stick the low-level elf library path in first.
+#
+glibpth="/usr/sde/elf/usr/lib $glibpth"
+
+# Need to use Concurrent cc for most of these options to be meaningful (if
+# you want to get this to work with gcc, you're on your own :-). Passing
+# -Bexport to the linker when linking perl is important because it leaves
+# the interpreter internal symbols visible to the shared libs that will be
+# loaded on demand (and will try to reference those symbols). The -u option
+# to drag 'sigaction' into the perl main program is to make sure it gets
+# defined for the posix shared library (for some reason sigaction is static,
+# rather than being defined in libc.so.1). The 88110compat option makes sure
+# the code will run on both 88100 and 88110 machines. The define is added to
+# trigger a work around for a compiler bug which shows up in pp.c.
+#
+cc='/bin/cc -Xa -Qtarget=M88110compat -DCXUX_BROKEN_CONSTANT_CONVERT'
+cccdlflags='-Zelf -Zpic'
+ccdlflags='-Zelf -Zlink=dynamic -Wl,-Bexport -u sigaction'
+lddlflags='-Zlink=so'
+
+# Configure imagines that it sees a pw_quota field, but it is really in a
+# different structure than the one it thinks it is looking at.
+d_pwquota='undef'
+
+# Configure sometimes finds what it believes to be ndbm header files on the
+# system and imagines that we have the NDBM library, but we really don't.
+# There is something there that once resembled ndbm, but it is purely
+# for internal use in some tool and has been hacked beyond recognition
+# (or even function :-)
+#
+i_ndbm='undef'
+
+# Don't use the perl malloc
+#
+d_mymalloc='undef'
+usemymalloc='n'
+
+cat <<'EOM' >&4
+
+WARNING: If you are using ksh to run the Configure script, you may find it
+failing in mysterious ways (such as failing to find library routines which
+are known to exist). Configure seems to push ksh beyond its limits
+sometimes. Try using env to strip unnecessary things out of the environment
+and run Configure with /sbin/sh. That sometimes seems to produce more
+accurate results.
+
+EOM
diff --git a/contrib/perl5/hints/cygwin32.sh b/contrib/perl5/hints/cygwin32.sh
new file mode 100644
index 000000000000..5853499954a7
--- /dev/null
+++ b/contrib/perl5/hints/cygwin32.sh
@@ -0,0 +1,50 @@
+#! /bin/sh
+# cygwin32.sh - hintsfile for building perl on Windows NT using the
+# Cygnus Win32 Development Kit.
+# See "http://www.cygnus.com/misc/gnu-win32/" to learn about the kit.
+#
+path_sep=\;
+exe_ext='.exe'
+firstmakefile='GNUmakefile'
+if test -f $sh.exe; then sh=$sh.exe; fi
+startsh="#!$sh"
+cc='gcc2'
+ld='ld2'
+usrinc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/include'
+libpth='/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib /gnuwin32/H-i386-cygwin32/lib'
+libs='-lcygwin -lm -lc -lkernel32'
+# dynamic lib stuff
+so='dll'
+#i_dlfcn='define'
+dlsrc='dl_cygwin32.xs'
+usedl='y'
+# flag to include the perl.exe export variable translation file cw32imp.h
+# when building extension libs
+cccdlflags='-DCYGWIN32 -DDLLIMPORT '
+# flag that signals gcc2 to build exportable perl
+ccdlflags='-buildperl '
+lddlflags='-L../.. -L/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib -lperlexp -lcygwin'
+d_voidsig='undef'
+extensions='Fcntl IO Opcode SDBM_File'
+lns='cp'
+signal_t='int'
+useposix='false'
+rd_nodata='0'
+eagain='EAGAIN'
+archname='cygwin32'
+#
+
+installbin='/usr/local/bin'
+installman1dir=''
+installman3dir=''
+installprivlib='/usr/local/lib/perl5'
+installscript='/usr/local/bin'
+
+installsitelib='/usr/local/lib/perl5/site_perl'
+libc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/lib/libc.a'
+
+perlpath='/usr/local/bin/perl'
+
+sitelib='/usr/local/lib/perl5/site_perl'
+sitelibexp='/usr/local/lib/perl5/site_perl'
+usrinc='/gnuwin32/H-i386-cygwin32/i386-cygwin32/include'
diff --git a/contrib/perl5/hints/dcosx.sh b/contrib/perl5/hints/dcosx.sh
new file mode 100644
index 000000000000..c1b0d0ac420c
--- /dev/null
+++ b/contrib/perl5/hints/dcosx.sh
@@ -0,0 +1,188 @@
+# hints/dcosx.sh
+# Last modified: Thu Jan 16 11:38:12 EST 1996
+# Stephen Zander <stephen.zander@interlock.mckesson.com>
+# hints for DC/OSx (Pyramid) & SINIX (Seimens: dc/osx rebadged)
+# Based on the hints/solaris_2.sh file
+
+# See man vfork.
+usevfork=false
+
+d_suidsafe=define
+
+# Avoid all libraries in /usr/ucblib.
+set `echo $glibpth | sed -e 's@/usr/ucblib@@'`
+glibpth="$*"
+
+# Remove bad libraries.
+# -lucb contains incompatible routines.
+set `echo " $libswanted " | sed -e 's@ ucb @ @'`
+libswanted="$*"
+
+# Here's another draft of the perl5/solaris/gcc sanity-checker.
+
+case $PATH in
+*/usr/ucb*:/usr/bin:*|*/usr/ucb*:/usr/bin) cat <<END >&2
+
+NOTE: /usr/ucb/cc does not function properly.
+Remove /usr/ucb from your PATH.
+
+END
+;;
+esac
+
+
+# Check that /dev/fd is mounted. If it is not mounted, let the
+# user know that suid scripts may not work.
+/usr/bin/df /dev/fd 2>&1 > /dev/null
+case $? in
+0) ;;
+*)
+ cat <<END >&4
+
+NOTE: Your system does not have /dev/fd mounted. If you want to
+be able to use set-uid scripts you must ask your system administrator
+to mount /dev/fd.
+
+END
+ ;;
+esac
+
+
+# See if libucb can be found in /usr/lib. If it is, warn the user
+# that this may cause problems while building Perl extensions.
+/usr/bin/ls /usr/lib/libucb* >/dev/null 2>&1
+case $? in
+0)
+ cat <<END >&4
+
+NOTE: libucb has been found in /usr/lib. libucb should reside in
+/usr/ucblib. You may have trouble while building Perl extensions.
+
+END
+;;
+esac
+
+
+# See if make(1) is GNU make(1).
+# If it is, make sure the setgid bit is not set.
+make -v > make.vers 2>&1
+if grep GNU make.vers > /dev/null 2>&1; then
+ tmp=`/usr/bin/ksh -c "whence make"`
+ case "`/usr/bin/ls -l $tmp`" in
+ ??????s*)
+ cat <<END >&2
+
+NOTE: Your PATH points to GNU make, and your GNU make has the set-group-id
+bit set. You must either rearrange your PATH to put /usr/ccs/bin before the
+GNU utilities or you must ask your system administrator to disable the
+set-group-id bit on GNU make.
+
+END
+ ;;
+ esac
+fi
+rm -f make.vers
+
+# If the C compiler is gcc:
+# - check the fixed-includes
+# - check as(1) and ld(1), they should not be GNU
+# If the C compiler is not gcc:
+# - check as(1) and ld(1), they should not be GNU
+# - increase the optimizing level to prevent object size warnings
+#
+# Watch out in case they have not set $cc.
+case "`${cc:-cc} -v 2>&1`" in
+*gcc*)
+ #
+ # Using gcc.
+ #
+ #echo Using gcc
+
+ # Get gcc to share its secrets.
+ echo 'main() { return 0; }' > try.c
+ verbose=`${cc:-cc} -v -o try try.c 2>&1`
+ rm -f try try.c
+ tmp=`echo "$verbose" | grep '^Reading' |
+ awk '{print $NF}' | sed 's/specs$/include/'`
+
+ # Determine if the fixed-includes look like they'll work.
+ # Doesn't work anymore for gcc-2.7.2.
+
+ # See if as(1) is GNU as(1). GNU as(1) won't work for this job.
+ case $verbose in
+ */usr/ccs/bin/as*) ;;
+ *)
+ cat <<END >&2
+
+NOTE: You are using GNU as(1). GNU as(1) will not build Perl.
+You must arrange to use /usr/ccs/bin/as, perhaps by setting
+GCC_EXEC_PREFIX or by including -B/usr/ccs/bin in your cc command.
+
+END
+ ;;
+ esac
+
+ # See if ld(1) is GNU ld(1). GNU ld(1) won't work for this job.
+ case $verbose in
+ */usr/ccs/bin/ld*) ;;
+ *)
+ cat <<END >&2
+
+NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl.
+You must arrange to use /usr/ccs/bin/ld, perhaps by setting
+GCC_EXEC_PREFIX or by including -B/usr/ccs/bin in your cc command.
+
+END
+ ;;
+ esac
+
+ ;; #using gcc
+*)
+ optimize='-O -K Olimit:3064'
+ #
+ # Not using gcc.
+ #
+ #echo Not using gcc
+
+ # See if as(1) is GNU as(1). GNU as(1) won't work for this job.
+ case `as --version < /dev/null 2>&1` in
+ *GNU*)
+ cat <<END >&2
+
+NOTE: You are using GNU as(1). GNU as(1) will not build Perl.
+You must arrange to use /usr/ccs/bin, perhaps by adding it to the
+beginning of your PATH.
+
+END
+ ;;
+ esac
+
+ # See if ld(1) is GNU ld(1). GNU ld(1) won't work for this job.
+ case `ld --version < /dev/null 2>&1` in
+ *GNU*)
+ cat <<END >&2
+
+NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl.
+You must arrange to use /usr/ccs/bin, perhaps by adding it to the
+beginning of your PATH
+
+END
+ ;;
+ esac
+
+ ;; #not using gcc
+esac
+
+# as --version or ld --version might dump core.
+rm -f core
+
+# DC/OSx hides certain functions in a libc that looks dynamic but isn't
+# because of this we reinclude -lc when building dynamic extenstions
+libc='/usr/ccs/lib/libc.so'
+lddlflags='-G -lc'
+
+# DC/OSx gets overenthusiastic with symbol removal when building dynamically
+ccdlflags='-Blargedynsym'
+
+# System malloc is safer when using third part libs
+usemymalloc='n'
diff --git a/contrib/perl5/hints/dec_osf.sh b/contrib/perl5/hints/dec_osf.sh
new file mode 100644
index 000000000000..a531ea8c8f74
--- /dev/null
+++ b/contrib/perl5/hints/dec_osf.sh
@@ -0,0 +1,334 @@
+# hints/dec_osf.sh
+
+# * If you want to debug perl or want to send a
+# stack trace for inclusion into an bug report, call
+# Configure with the additional argument -Doptimize=-g2
+# or uncomment this assignment to "optimize":
+#
+#optimize=-g2
+#
+# If you want both to optimise and debug with the DEC cc
+# you must have -g3, e.g. "-O4 -g3", and (re)run Configure.
+#
+# * gcc can always have both -g and optimisation on.
+#
+# * debugging optimised code, no matter what compiler
+# one is using, can be surprising and confusing because of
+# the optimisation tricks like code motion, code removal,
+# loop unrolling, and inlining. The source code and the
+# executable code simply do not agree any more while in
+# mid-execution, the optimiser only cares about the results.
+#
+# * Configure will automatically add the often quoted
+# -DDEBUGGING for you if the -g is specified.
+#
+# * There is even more optimisation available in the new
+# (GEM) DEC cc: -O5 and -fast. "man cc" will tell more about them.
+# The jury is still out whether either or neither help for Perl
+# and how much. Based on very quick testing, -fast boosts
+# raw data copy by about 5-15% (-fast brings in, among other
+# things, inlined, ahem, fast memcpy()), while on the other
+# hand searching things (index, m//, s///), seems to get slower.
+# Your mileage will vary.
+#
+# * The -std is needed because the following compiled
+# without the -std and linked with -lm
+#
+# #include <math.h>
+# #include <stdio.h>
+# int main(){short x=10,y=sqrt(x);printf("%d\n",y);}
+#
+# will in Digital UNIX 3.* and 4.0b print 0 -- and in Digital
+# UNIX 4.0{,a} dump core: Floating point exception in the printf(),
+# the y has become a signaling NaN.
+#
+# * Compilation warnings like:
+#
+# "Undefined the ANSI standard macro ..."
+#
+# can be ignored, at least while compiling the POSIX extension
+# and especially if using the sfio (the latter is not a standard
+# part of Perl, never mind if it says little to you).
+#
+
+# If using the DEC compiler we must find out the DEC compiler style:
+# the style changed between Digital UNIX (aka DEC OSF/1) 3 and
+# Digital UNIX 4. The old compiler was originally from Ultrix and
+# the MIPS company, the new compiler is originally from the VAX world
+# and it is called GEM. Many of the options we are going to use depend
+# on the compiler style.
+
+# do NOT, I repeat, *NOT* take away those leading tabs
+ # reset
+ _DEC_uname_r=
+ _DEC_cc_style=
+ # set
+ _DEC_uname_r=`uname -r`
+ # _DEC_cc_style set soon below
+# Configure Black Magic (TM)
+
+case "$cc" in
+*gcc*) ;; # pass
+*) # compile something small: taint.c is fine for this.
+ # the main point is the '-v' flag of 'cc'.
+ case "`cc -v -I. -c taint.c -o /tmp/taint$$.o 2>&1`" in
+ */gemc_cc*) # we have the new DEC GEM CC
+ _DEC_cc_style=new
+ ;;
+ *) # we have the old MIPS CC
+ _DEC_cc_style=old
+ ;;
+ esac
+ # cleanup
+ rm -f /tmp/taint$$.o
+ ;;
+esac
+
+# be nauseatingly ANSI
+case "$cc" in
+*gcc*) ccflags="$ccflags -ansi"
+ ;;
+*) ccflags="$ccflags -std"
+ ;;
+esac
+
+# for gcc the Configure knows about the -fpic:
+# position-independent code for dynamic loading
+
+# we want optimisation
+
+case "$optimize" in
+'') case "$cc" in
+ *gcc*)
+ optimize='-O3' ;;
+ *) case "$_DEC_cc_style" in
+ new) optimize='-O4'
+ ccflags="$ccflags -fprm d -ieee"
+ ;;
+ old) optimize='-O2 -Olimit 3200' ;;
+ esac
+ ccflags="$ccflags -D_INTRINSICS"
+ ;;
+ esac
+ ;;
+esac
+
+# Make glibpth agree with the compiler suite. Note that /shlib
+# is not here. That's on purpose. Even though that's where libc
+# really lives from V4.0 on, the linker (and /sbin/loader) won't
+# look there by default. The sharable /sbin utilities were all
+# built with "-Wl,-rpath,/shlib" to get around that. This makes
+# no attempt to figure out the additional location(s) searched by
+# gcc, since not all versions of gcc are easily coerced into
+# revealing that information.
+glibpth="/usr/shlib /usr/ccs/lib /usr/lib/cmplrs/cc"
+glibpth="$glibpth /usr/lib /usr/local/lib /var/shlib"
+
+# dlopen() is in libc
+libswanted="`echo $libswanted | sed -e 's/ dl / /'`"
+
+# libPW contains nothing useful for perl
+libswanted="`echo $libswanted | sed -e 's/ PW / /'`"
+
+# libnet contains nothing useful for perl here, and doesn't work
+libswanted="`echo $libswanted | sed -e 's/ net / /'`"
+
+# libbsd contains nothing used by perl that is not already in libc
+libswanted="`echo $libswanted | sed -e 's/ bsd / /'`"
+
+# libc need not be separately listed
+libswanted="`echo $libswanted | sed -e 's/ c / /'`"
+
+# ndbm is already in libc
+libswanted="`echo $libswanted | sed -e 's/ ndbm / /'`"
+
+# the basic lddlflags used always
+lddlflags='-shared -expect_unresolved "*"'
+
+# Fancy compiler suites use optimising linker as well as compiler.
+# <spider@Orb.Nashua.NH.US>
+case "$_DEC_uname_r" in
+*[123].*) # old loader
+ lddlflags="$lddlflags -O3"
+ ;;
+*) lddlflags="$lddlflags $optimize -msym"
+ # -msym: If using a sufficiently recent /sbin/loader,
+ # keep the module symbols with the modules.
+ ;;
+esac
+# Yes, the above loses if gcc does not use the system linker.
+# If that happens, let me know about it. <jhi@iki.fi>
+
+
+# If debugging or (old systems and doing shared)
+# then do not strip the lib, otherwise, strip.
+# As noted above the -DDEBUGGING is added automagically by Configure if -g.
+case "$optimize" in
+ *-g*) ;; # left intentionally blank
+*) case "$_DEC_uname_r" in
+ *[123].*)
+ case "$useshrplib" in
+ false|undef|'') lddlflags="$lddlflags -s" ;;
+ esac
+ ;;
+ *) lddlflags="$lddlflags -s"
+ ;;
+ esac
+ ;;
+esac
+
+if [ "X$usethreads" = "X$define" ]; then
+ # Threads interfaces changed with V4.0.
+ case "$_DEC_uname_r" in
+ *[123].*) libswanted="$libswanted pthreads mach exc c_r"
+ ccflags="-threads $ccflags"
+ ;;
+ *) libswanted="$libswanted pthread exc"
+ ccflags="-pthread $ccflags"
+ ;;
+ esac
+ usemymalloc='n'
+fi
+
+#
+# Make embedding in things like INN and Apache more memory friendly.
+# Keep it overridable on the Configure command line, though, so that
+# "-Uuseshrplib" prevents this default.
+#
+
+# This or the glibpth change above breaks the build. Commented out
+# for this snapshot.
+#case "$_DEC_cc_style.$useshrplib" in
+# new.) useshrplib="$define" ;;
+#esac
+
+#
+# Unset temporary variables no more needed.
+#
+
+unset _DEC_cc_style
+unset _DEC_uname_r
+
+#
+# History:
+#
+# perl5.004_57:
+#
+# 19-Dec-1997 Spider Boardman <spider@Orb.Nashua.NH.US>
+#
+# * Newer Digial UNIX compilers enforce signaling for NaN without
+# -ieee. Added -fprm d at the same time since it's friendlier for
+# embedding.
+#
+# * Fixed the library search path to match cc, ld, and /sbin/loader.
+#
+# * Default to building -Duseshrplib on newer systems. -Uuseshrplib
+# still overrides.
+#
+# * Fix -pthread additions for useshrplib. ld has no -pthread option.
+#
+#
+# perl5.004_04:
+#
+# 19-Sep-1997 Spider Boardman <spider@Orb.Nashua.NH.US>
+#
+# * libnet on Digital UNIX is for JAVA, not for sockets.
+#
+#
+# perl5.003_28:
+#
+# 22-Feb-1997 Jarkko Hietaniemi <jhi@iki.fi>
+#
+# * Restructuring Spider's suggestions.
+#
+# * Older Digital UNIXes cannot handle -Olimit ... for $lddlflags.
+#
+# * ld -s cannot be used in older Digital UNIXes when doing shared.
+#
+#
+# 21-Feb-1997 Spider Boardman <spider@Orb.Nashua.NH.US>
+#
+# * -hidden removed.
+#
+# * -DSTANDARD_C removed.
+#
+# * -D_INTRINSICS added. (that -fast does not seem to buy much confirmed)
+#
+# * odbm not in libc, only ndbm. Therefore dbm back to $libswanted.
+#
+# * -msym for the newer runtime loaders.
+#
+# * $optimize also in $lddflags.
+#
+#
+# perl5.003_27:
+#
+# 18-Feb-1997 Jarkko Hietaniemi <jhi@iki.fi>
+#
+# * unset _DEC_cc_style and more commentary on -std.
+#
+#
+# perl5.003_26:
+#
+# 15-Feb-1997 Jarkko Hietaniemi <jhi@iki.fi>
+#
+# * -std and -ansi.
+#
+#
+# perl5.003_24:
+#
+# 30-Jan-1997 Jarkko Hietaniemi <jhi@iki.fi>
+#
+# * Fixing the note on -DDEBUGGING.
+#
+# * Note on -O5 -fast.
+#
+#
+# perl5.003_23:
+#
+# 26-Jan-1997 Jarkko Hietaniemi <jhi@iki.fi>
+#
+# * Notes on how to do both optimisation and debugging.
+#
+#
+# 25-Jan-1997 Jarkko Hietaniemi <jhi@iki.fi>
+#
+# * Remove unneeded libraries from $libswanted: PW, bsd, c, dbm
+#
+# * Restructure the $lddlflags build.
+#
+# * $optimize based on which compiler we have.
+#
+#
+# perl5.003_22:
+#
+# 23-Jan-1997 Achim Bohnet <ach@rosat.mpe-garching.mpg.de>
+#
+# * Added comments 'how to create a debugging version of perl'
+#
+# * Fixed logic of this script to prevent stripping of shared
+# objects by the loader (see ld man page for -s) is debugging
+# is set via the -g switch.
+#
+#
+# 21-Jan-1997 Achim Bohnet <ach@rosat.mpe-garching.mpg.de>
+#
+# * now 'dl' is always removed from libswanted. Not only if
+# optimize is an empty string.
+#
+#
+# 17-Jan-1997 Achim Bohnet <ach@rosat.mpe-garching.mpg.de>
+#
+# * Removed 'dl' from libswanted: When the FreePort binary
+# translator for Sun binaries is installed Configure concludes
+# that it should use libdl.x.yz.fpx.so :-(
+# Because the dlopen, dlclose,... calls are in the
+# C library it not necessary at all to check for the
+# dl library. Therefore dl is removed from libswanted.
+#
+#
+# 1-Jan-1997 Achim Bohnet <ach@rosat.mpe-garching.mpg.de>
+#
+# * Set -Olimit to 3200 because perl_yylex.c got too big
+# for the optimizer.
+#
diff --git a/contrib/perl5/hints/dgux.sh b/contrib/perl5/hints/dgux.sh
new file mode 100644
index 000000000000..03b285dbd4ab
--- /dev/null
+++ b/contrib/perl5/hints/dgux.sh
@@ -0,0 +1,141 @@
+# $Id: dgux.sh,v 1.8 1996-11-29 18:16:43-05 roderick Exp $
+
+# This is a hints file for DGUX, which is Data General's Unix. It was
+# originally developed with version 5.4.3.10 of the OS, and then was
+# later updated running under version 4.11.2 (running on m88k hardware).
+# The gross features should work with versions going back to 2.nil but
+# some tweaking will probably be necessary.
+#
+# DGUX is a SVR4 derivative. It ships with gcc as the standard
+# compiler. Since version 3.0 it has shipped with Perl 4.036
+# installed in /usr/bin, which is kind of neat. Be careful when you
+# install that you don't overwrite the system version, though (by
+# answering yes to the question about installing perl as /usr/bin/perl),
+# as it would suck to try to get support if the vendor learned that you
+# were physically replacing the system binaries.
+#
+# Be aware that if you opt to use dynamic loading you'll need to set
+# your $LD_LIBRARY_PATH to include the source directory when you build,
+# test and install the software.
+#
+# -Roderick Schertler <roderick@argon.org>
+
+
+# Here are the things from some old DGUX hints files which are different
+# from what's in here now. I don't know the exact reasons that most of
+# these settings were in the hints files, presumably they can be chalked
+# up to old Configure inadequacies and changes in the OS headers and the
+# like. These settings might make a good place to start looking if you
+# have problems.
+#
+# This was specified the the 4.036 hints file. That hints file didn't
+# say what version of the OS it was developed using.
+#
+# cppstdin='/lib/cpp'
+#
+# The 4.036 and 5.001 hints files both contained these. The 5.001 hints
+# file said it was developed with version 2.01 of DGUX.
+#
+# gidtype='gid_t'
+# groupstype='gid_t'
+# uidtype='uid_t'
+# d_index='define'
+# cc='gcc'
+#
+# These were peculiar to the 5.001 hints file.
+#
+# ccflags='-D_POSIX_SOURCE -D_DGUX_SOURCE'
+#
+# # an ugly hack, since the Configure test for "gcc -P -" hangs.
+# # can't just use 'cppstdin', since our DG has a broken cppstdin :-(
+# cppstdin=`cd ..; pwd`/cppstdin
+# cpprun=`cd ..; pwd`/cppstdin
+#
+# One last note: The 5.001 hints file said "you don't want to use
+# /usr/ucb/cc" in the place at which it set cc to gcc. That in
+# particular baffles me, as I used to have 2.01 loaded and my memory
+# is telling me that even then /usr/ucb was a symlink to /usr/bin.
+
+
+# The standard system compiler is gcc, but invoking it as cc changes its
+# behavior. I have to pick one name or the other so I can get the
+# dynamic loading switches right (they vary depending on this). I'm
+# picking gcc because there's no way to get at the optimization options
+# and so on when you call it cc.
+case $cc in
+ '')
+ cc=gcc
+ case $optimize in
+ '') optimize=-O2;;
+ esac
+ ;;
+esac
+
+usevfork=true
+
+# DG has this thing set up with symlinks which point to different places
+# depending on environment variables (see elink(5)) and the compiler and
+# related tools use them to access different development environments
+# (COFF, ELF, m88k BCS and so on), see sde(5). The upshot, however, is
+# that when a normal program tries to access one of these elinks it sees
+# no such file (like stat()ting a mis-directed symlink). Setting
+# $plibpth to explicitly include the place to which the elinks point
+# allows Configure to find libraries which vary based on the development
+# environment.
+#
+# Starting with version 4.10 (the first time the OS supported Intel
+# hardware) all libraries are accessed with this mechanism.
+#
+# The default $TARGET_BINARY_INTERFACE changed with version 4.10. The
+# system now comes with a link named /usr/sde/default which points to
+# the proper entry, but older versions lacked this and used m88kdgux
+# directly.
+
+: && sde_path=${SDE_PATH:-/usr}/sde # hide from Configure
+while : # dummy loop
+do
+ if [ -n "$TARGET_BINARY_INTERFACE" ]
+ then set X "$TARGET_BINARY_INTERFACE"
+ else set X default dg m88k_dg ix86_dg m88kdgux m88kdguxelf
+ fi
+ shift
+ default_sde=$1
+ for sde
+ do
+ [ -d "$sde_path/$sde" ] && break 2
+ done
+ cat <<END >&2
+
+NOTE: I can't figure out what SDE is used by default on this machine (I
+didn't find a likely directory under $sde_path). This is bad news. If
+this is a R4.10 or newer system I'm not going to be able to find any of
+your libraries, if this system is R3.10 or older I won't be able to find
+the math library. You should re-run Configure with the environment
+variable TARGET_BINARY_INTERFACE set to the proper value for this
+machine, see sde(5) and the notes in hints/dgux.sh.
+
+END
+ sde=$default_sde
+ break
+done
+
+plibpth="$plibpth $sde_path/$sde/usr/lib"
+unset sde_path default_sde sde
+
+# Many functions (eg, gethostent(), killpg(), getpriority(), setruid()
+# dbm_*(), and plenty more) are defined in -ldgc. Usually you don't
+# need to know this (it seems that libdgc.so is searched automatically
+# by ld), but Configure needs to check it otherwise it will report all
+# those functions as missing.
+libswanted="dgc $libswanted"
+
+# Dynamic loading works using the dlopen() functions. Note that dlfcn.h
+# used to be broken, it declared _dl*() rather than dl*(). This was the
+# case up to 3.10, it has been fixed in 4.11. I'm not sure if it was
+# fixed in 4.10. If you have the older header just ignore the warnings
+# (since pointers and integers have the same format on m88k).
+usedl=true
+# For cc rather than gcc the flags would be `-K PIC' for compiling and
+# -G for loading. I haven't tested this.
+cccdlflags=-fpic
+lddlflags=-shared
diff --git a/contrib/perl5/hints/dos_djgpp.sh b/contrib/perl5/hints/dos_djgpp.sh
new file mode 100644
index 000000000000..73bae63dd2ce
--- /dev/null
+++ b/contrib/perl5/hints/dos_djgpp.sh
@@ -0,0 +1,59 @@
+# hints file for dos/djgpp v2.xx
+# Original by Laszlo Molnar <molnarl@cdata.tvnet.hu>
+
+# 971015 - archname changed from 'djgpp' to 'dos-djgpp'
+# 971210 - threads support
+
+archname='dos-djgpp'
+archobjs='djgpp.o'
+path_sep=\;
+startsh="#! /bin/sh"
+
+cc='gcc'
+ld='gcc'
+usrinc="$DJDIR/include"
+
+libpth="$DJDIR/lib"
+libc="$libpth/libc.a"
+
+so='none'
+usedl='n'
+
+firstmakefile='GNUmakefile'
+exe_ext='.exe'
+
+randbits=31
+lns='cp'
+
+usenm='true'
+
+d_link='undef' # these are empty functions in libc.a
+d_symlink='undef'
+d_fork='undef'
+d_pipe='undef'
+
+startperl='#!perl'
+
+case "X$optimize" in
+ X)
+ optimize="-O2 -malign-loops=2 -malign-jumps=2 -malign-functions=2"
+ ;;
+esac
+ldflags='-s'
+usemymalloc='n'
+timetype='time_t'
+
+prefix=$DJDIR
+privlib=$prefix/lib/perl5
+archlib=$privlib
+sitelib=$privlib/site
+sitearch=$sitelib
+
+eagain='EAGAIN'
+rd_nodata='-1'
+
+if [ "X$usethreads" = "X$define" ]; then
+ set `echo X "$libswanted "| sed -e 's/ c / gthreads c /'`
+ shift
+ libswanted="$*"
+fi
diff --git a/contrib/perl5/hints/dynix.sh b/contrib/perl5/hints/dynix.sh
new file mode 100644
index 000000000000..4bdb804f5304
--- /dev/null
+++ b/contrib/perl5/hints/dynix.sh
@@ -0,0 +1,7 @@
+# If this doesn't work, try specifying 'none' for hints.
+d_castneg=undef
+libswanted=`echo $libswanted | sed -e 's/socket /socket seq /'`
+
+# Reported by Craig Milo Rogers <Rogers@ISI.EDU>
+# Date: Tue, 30 Jan 96 15:29:26 PST
+d_casti32=undef
diff --git a/contrib/perl5/hints/dynixptx.sh b/contrib/perl5/hints/dynixptx.sh
new file mode 100644
index 000000000000..78a45e42a31e
--- /dev/null
+++ b/contrib/perl5/hints/dynixptx.sh
@@ -0,0 +1,24 @@
+# Sequent Dynix/Ptx v. 4 hints
+# Created 1996/03/15 by Brad Howerter, bhower@wgc.woodward.com
+# Use Configure -Dcc=gcc to use gcc.
+
+# cc wants -G for dynamic loading
+lddlflags='-G'
+
+# Remove inet to avoid this error in Configure, which causes Configure
+# to be unable to figure out return types:
+# dynamic linker: ./ssize: can't find libinet.so,
+# link with -lsocket instead of -linet
+
+libswanted=`echo $libswanted | sed -e 's/ inet / /'`
+
+# Configure defaults to usenm='y', which doesn't work very well
+usenm='n'
+
+# Reported by bruce@aps.org ("Bruce P. Schuck") as needed for
+# DYNIX/ptx 4.0 V4.2.1 to get socket i/o to work
+# Not defined by default in case they break other versions.
+# These probably need to be worked into a piece of code that
+# checks for the need for this setting.
+# cppflags='-Wc,+abi-socket -I/usr/local/include'
+# ccflags='-Wc,+abi-socket -I/usr/local/include'
diff --git a/contrib/perl5/hints/epix.sh b/contrib/perl5/hints/epix.sh
new file mode 100644
index 000000000000..b91537a202a1
--- /dev/null
+++ b/contrib/perl5/hints/epix.sh
@@ -0,0 +1,75 @@
+# epix.sh
+# Hint file for EP/IX on CDC RISC boxes.
+#
+# From: Stanley Donald Capelik <sd9sdc@hp100.den.mmc.com>
+# Modified by Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Last modified: Mon May 8 15:29:18 EDT 1995
+#
+# This hint file appears to be based on the svr4 hints for perl5.000,
+# with some CDC-specific additions. I've tried to updated it to
+# match the 5.001 svr4 hints, which allow for dynamic loading,
+# but I have no way of testing the resulting file.
+#
+# There were also some contradictions that I've tried to straighten
+# out, but I'm not sure I got them all right.
+#
+# Edit config.sh to change shmattype from 'char *' to 'void *'"
+
+# Use Configure -Dcc=gcc to use gcc.
+case "$cc" in
+'') cc='/bin/cc3.11'
+ test -f $cc || cc='/usr/ccs/bin/cc'
+ ;;
+esac
+
+usrinc='/svr4/usr/include'
+
+# Various things that Configure apparently doesn't get right.
+strings='/svr4/usr/include/string.h'
+timeincl='/svr4/usr/include/sys/time.h '
+libc='/svr4/usr/lib/libc.a'
+glibpth="/svr4/usr/lib /svr4/usr/lib/cmplrs/cc /usr/ccs/lib /svr4/lib /svr4/usr/ucblib $glibpth"
+osname='epix2'
+archname='epix2'
+d_suidsafe='define' # "./Configure -d" can't figure this out easilly
+d_flock='undef'
+
+# Old version had this, but I'm not sure why since the old version
+# also mucked around with libswanted. This is also definitely wrong
+# if the user is trying to use DB_File or GDBM_File.
+# libs='-lsocket -lnsl -ldbm -ldl -lc -lcrypt -lm -lucb'
+
+# We include support for using libraries in /usr/ucblib, but the setting
+# of libswanted excludes some libraries found there. You may want to
+# prevent "ucb" from being removed from libswanted and see if perl will
+# build on your system.
+ldflags='-non_shared -systype svr4 -L/svr4/usr/lib -L/svr4/usr/lib/cmplrs/cc -L/usr/ccs/lib -L/svr4/usr/ucblib'
+ccflags='-systype svr4 -D__STDC__=0 -I/svr4/usr/include -I/svr4/usr/ucbinclude'
+cppflags='-D__STDC__=0 -I/svr4/usr/include -I/svr4/usr/ucbinclude'
+
+# Don't use problematic libraries:
+
+libswanted=`echo " $libswanted " | sed -e 's/ malloc / /'` # -e 's/ ucb / /'`
+# libmalloc.a - Probably using Perl's malloc() anyway.
+# libucb.a - Remove it if you have problems ld'ing. We include it because
+# it is needed for ODBM_File and NDBM_File extensions.
+if [ -r /usr/ucblib/libucb.a ]; then # If using BSD-compat. library:
+ # Use the "native" counterparts, not the BSD emulation stuff:
+ d_bcmp='undef'; d_bcopy='undef'; d_bzero='undef'; d_safebcpy='undef'
+ d_index='undef'; d_killpg='undef'; d_getprior='undef'; d_setprior='undef'
+ d_setlinebuf='undef'; d_setregid='undef'; d_setreuid='undef'
+fi
+
+lddlflags="-G $ldflags" # Probably needed for dynamic loading
+# We _do_ want the -L paths in ldflags, but we don't want the -non_shared.
+lddlflags=`echo $lddlflags | sed 's/-non_shared//'`
+
+cat <<'EOM' >&4
+
+If you wish to use dynamic linking, you must use
+ LD_LIBRARY_PATH=`pwd`; export LD_LIBRARY_PATH
+or
+ setenv LD_LIBRARY_PATH `pwd`
+before running make.
+
+EOM
diff --git a/contrib/perl5/hints/esix4.sh b/contrib/perl5/hints/esix4.sh
new file mode 100644
index 000000000000..3d3145d25503
--- /dev/null
+++ b/contrib/perl5/hints/esix4.sh
@@ -0,0 +1,41 @@
+# hints/esix4.sh
+# Original esix4 hint file courtesy of
+# Kevin O'Gorman ( kevin@kosman.UUCP, kevin%kosman.uucp@nrc.com )
+#
+# Use Configure -Dcc=gcc to use gcc.
+case "$cc" in
+'') cc='/bin/cc'
+ test -f $cc || cc='/usr/ccs/bin/cc'
+ ;;
+esac
+ldflags='-L/usr/ccs/lib -L/usr/ucblib'
+test -d /usr/local/man || mansrc='none'
+ccflags='-I/usr/include -I/usr/ucbinclude'
+libswanted=`echo " $libswanted " | sed -e 's/ malloc / /' `
+d_index='undef'
+d_suidsafe=define
+usevfork='false'
+if test "$osvers" = "3.0"; then
+ d_gconvert='undef'
+ grep 'define[ ]*AF_OSI[ ]' /usr/include/sys/socket.h | grep '/\*[^*]*$' >/tmp/esix$$
+ if test -s /tmp/esix$$; then
+ cat <<EOM >&2
+
+WARNING: You are likely to have problems compiling the Socket extension
+unless you fix the unterminated comment for AF_OSI in the file
+/usr/include/sys/socket.h.
+
+EOM
+ fi
+ rm -f /tmp/esix$$
+fi
+
+cat <<'EOM' >&4
+
+If you wish to use dynamic linking, you must use
+ LD_LIBRARY_PATH=`pwd`; export LD_LIBRARY_PATH
+or
+ setenv LD_LIBRARY_PATH `pwd`
+before running make.
+
+EOM
diff --git a/contrib/perl5/hints/fps.sh b/contrib/perl5/hints/fps.sh
new file mode 100644
index 000000000000..7726790ac0cf
--- /dev/null
+++ b/contrib/perl5/hints/fps.sh
@@ -0,0 +1 @@
+ccflags="$ccflags -J"
diff --git a/contrib/perl5/hints/freebsd.sh b/contrib/perl5/hints/freebsd.sh
new file mode 100644
index 000000000000..0f2a5a5a6d58
--- /dev/null
+++ b/contrib/perl5/hints/freebsd.sh
@@ -0,0 +1,155 @@
+# Original based on info from
+# Carl M. Fongheiser <cmf@ins.infonet.net>
+# Date: Thu, 28 Jul 1994 19:17:05 -0500 (CDT)
+#
+# Additional 1.1.5 defines from
+# Ollivier Robert <Ollivier.Robert@keltia.frmug.fr.net>
+# Date: Wed, 28 Sep 1994 00:37:46 +0100 (MET)
+#
+# Additional 2.* defines from
+# Ollivier Robert <Ollivier.Robert@keltia.frmug.fr.net>
+# Date: Sat, 8 Apr 1995 20:53:41 +0200 (MET DST)
+#
+# Additional 2.0.5 and 2.1 defined from
+# Ollivier Robert <Ollivier.Robert@keltia.frmug.fr.net>
+# Date: Fri, 12 May 1995 14:30:38 +0200 (MET DST)
+#
+# Additional 2.2 defines from
+# Mark Murray <mark@grondar.za>
+# Date: Wed, 6 Nov 1996 09:44:58 +0200 (MET)
+#
+# Modified to ensure we replace -lc with -lc_r, and
+# to put in place-holders for various specific hints.
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Date: Tue Mar 10 16:07:00 EST 1998
+#
+# The two flags "-fpic -DPIC" are used to indicate a
+# will-be-shared object. Configure will guess the -fpic, (and the
+# -DPIC is not used by perl proper) but the full define is included to
+# be consistent with the FreeBSD general shared libs building process.
+#
+# setreuid and friends are inherently broken in all versions of FreeBSD
+# before 2.1-current (before approx date 4/15/95). It is fixed in 2.0.5
+# and what-will-be-2.1
+#
+
+case "$osvers" in
+0.*|1.0*)
+ usedl="$undef"
+ ;;
+1.1*)
+ malloctype='void *'
+ groupstype='int'
+ d_setregid='undef'
+ d_setreuid='undef'
+ d_setrgid='undef'
+ d_setruid='undef'
+ ;;
+2.0-release*)
+ d_setregid='undef'
+ d_setreuid='undef'
+ d_setrgid='undef'
+ d_setruid='undef'
+ ;;
+#
+# Trying to cover 2.0.5, 2.1-current and future 2.1/2.2
+# It does not covert all 2.1-current versions as the output of uname
+# changed a few times.
+#
+# Even though seteuid/setegid are available, they've been turned off
+# because perl isn't coded with saved set[ug]id variables in mind.
+# In addition, a small patch is requried to suidperl to avoid a security
+# problem with FreeBSD.
+#
+2.0.5*|2.0-built*|2.1*)
+ usevfork='true'
+ usemymalloc='n'
+ d_setregid='define'
+ d_setreuid='define'
+ d_setegid='undef'
+ d_seteuid='undef'
+ test -r ./broken-db.msg && . ./broken-db.msg
+ ;;
+#
+# 2.2 and above have phkmalloc(3).
+# don't use -lmalloc (maybe there's an old one from 1.1.5.1 floating around)
+2.2*)
+ usevfork='true'
+ usemymalloc='n'
+ libswanted=`echo $libswanted | sed 's/ malloc / /'`
+ d_setregid='define'
+ d_setreuid='define'
+ d_setegid='undef'
+ d_seteuid='undef'
+ ;;
+#
+# Guesses at what will be needed after 2.2
+*) usevfork='true'
+ usemymalloc='n'
+ libswanted=`echo $libswanted | sed 's/ malloc / /'`
+ ;;
+esac
+
+# Dynamic Loading flags have not changed much, so they are separated
+# out here to avoid duplicating them everywhere.
+case "$osvers" in
+0.*|1.0*) ;;
+
+3.0*) if [ -e /usr/lib/aout ]; then
+ libpth="/usr/lib/aout /usr/local/lib /usr/lib"
+ glibpth="/usr/lib/aout /usr/local/lib /usr/lib"
+ fi
+ cccdlflags='-DPIC -fpic'
+ lddlflags='-Bshareable'
+ ;;
+
+*) cccdlflags='-DPIC -fpic'
+ lddlflags="-Bshareable $lddlflags"
+ ;;
+esac
+
+cat <<'EOM' >&4
+
+Some users have reported that Configure halts when testing for
+the O_NONBLOCK symbol with a syntax error. This is apparently a
+sh error. Rerunning Configure with ksh apparently fixes the
+problem. Try
+ ksh Configure [your options]
+
+EOM
+
+# XXX EXPERIMENTAL A.D. 03/09/1998
+# XXX This script UU/usethreads.cbu will get 'called-back' by Configure
+# XXX after it has prompted the user for whether to use threads.
+cat > UU/usethreads.cbu <<'EOSH'
+case "$usethreads" in
+$define)
+ case "$osvers" in
+ 3.0*) ldflags="-pthread $ldflags"
+ ;;
+ 2.2*) if [ ! -r /usr/lib/libc_r ]; then
+ cat <<'EOM' >&4
+POSIX threads are not supported by default on FreeBSD $uname_r. Follow the
+instructions in 'man pthread' to build and install the needed libraries.
+EOM
+ exit 1
+ fi
+ set `echo X "$libswanted "| sed -e 's/ c / c_r /'`
+ shift
+ libswanted="$*"
+ # Configure will probably pick the wrong libc to use for nm
+ # scan.
+ # The safest quick-fix is just to not use nm at all.
+ usenm=false
+ ;;
+ *) cat <<'EOM' >&4
+It is not known if FreeBSD $uname_r supports POSIX threads or not. Consider
+upgrading to the latest STABLE release.
+EOM
+ exit 1
+ ;;
+ esac
+ ;;
+esac
+EOSH
+# XXX EXPERIMENTAL --end of call-back
diff --git a/contrib/perl5/hints/genix.sh b/contrib/perl5/hints/genix.sh
new file mode 100644
index 000000000000..16b6879b46b9
--- /dev/null
+++ b/contrib/perl5/hints/genix.sh
@@ -0,0 +1 @@
+i_varargs=undef
diff --git a/contrib/perl5/hints/greenhills.sh b/contrib/perl5/hints/greenhills.sh
new file mode 100644
index 000000000000..da6fcc95b041
--- /dev/null
+++ b/contrib/perl5/hints/greenhills.sh
@@ -0,0 +1 @@
+ccflags="$ccflags -X18"
diff --git a/contrib/perl5/hints/hpux.sh b/contrib/perl5/hints/hpux.sh
new file mode 100644
index 000000000000..281f289c9b36
--- /dev/null
+++ b/contrib/perl5/hints/hpux.sh
@@ -0,0 +1,206 @@
+#! /bin/sh
+
+# hints/hpux.sh
+# Perl Configure hints file for Hewlett-Packard's HP-UX 9.x and 10.x
+# (Hopefully, 7.x through 11.x.)
+#
+# This file is based on hints/hpux_9.sh, Perl Configure hints file for
+# Hewlett Packard HP-UX 9.x
+#
+# Use Configure -Dcc=gcc to use gcc.
+#
+# From: Jeff Okamoto <okamoto@corp.hp.com>
+# and
+# hints/hpux_10.sh, Perl Configure hints file for Hewlett Packard HP-UX 10.x
+# From: Giles Lean <giles@nemeton.com.au>
+# and
+# Use #define CPU_* instead of comments for >= 10.x.
+# Support PA1.2 under 10.x.
+# Distinguish between PA2.0, PA2.1, etc.
+# Distinguish between MC68020, MC68030, MC68040
+# Don't assume every OS != 10 is < 10, (e.g., 11).
+# From: Chuck Phillips <cdp@fc.hp.com>
+
+# This version: August 15, 1997
+# Current maintainer: Jeff Okamoto <okamoto@corp.hp.com>
+
+#--------------------------------------------------------------------
+# Use Configure -Dcc=gcc to use gcc.
+# Use Configure -Dprefix=/usr/local to install in /usr/local.
+#
+# You may have dynamic loading problems if the environment variable
+# LDOPTS='-a archive'. Under >= 10.x, you can instead LDOPTS='-a
+# archive_shared' to prefer archive libraries without requiring them.
+# Regardless of HPUX release, in the "libs" variable or the ext.libs
+# file, you can always give explicit path names to archive libraries
+# that may not exist on the target machine. E.g., /usr/lib/libndbm.a
+# instead of -lndbm. See also note below on ndbm.
+#
+# ALSO, bear in mind that gdbm and Berkely DB contain incompatible
+# replacements for ndbm (and dbm) routines. If you want concurrent
+# access to ndbm files, you need to make sure libndbm is linked in
+# *before* gdbm and Berkely DB. Lastly, remember to check the
+# "ext.libs" file which is *probably* messing up the order. Often,
+# you can replace ext.libs with an empty file to fix the problem.
+#
+# If you get a message about "too much defining", as may happen
+# in HPUX < 10, you might have to append a single entry to your
+# ccflags: '-Wp,-H256000'
+# NOTE: This is a single entry (-W takes the argument 'p,-H256000').
+#--------------------------------------------------------------------
+
+# Turn on the _HPUX_SOURCE flag to get many of the HP add-ons
+# regardless of compiler. For the HP ANSI C compiler, you may also
+# want to include +e to enable "long long" and "long double".
+#
+# HP compiler flags to include (if at all) *both* as part of ccflags
+# and cc itself so Configure finds (and builds) everything
+# consistently:
+# -Aa -D_HPUX_SOURCE +e
+#
+# Lastly, you may want to include the "-z" HP linker flag so that
+# reading from a NULL pointer causes a SEGV.
+ccflags="$ccflags -D_HPUX_SOURCE"
+
+# Check if you're using the bundled C compiler. This compiler doesn't support
+# ANSI C (the -Aa flag) nor can it produce shared libraries. Thus we have
+# to turn off dynamic loading.
+case "$cc" in
+'') if cc $ccflags -Aa 2>&1 | $contains 'option' >/dev/null
+ then
+ case "$usedl" in
+ '') usedl="$undef"
+ cat <<'EOM' >&4
+
+The bundled C compiler can not produce shared libraries, so you will
+not be able to use dynamic loading.
+
+EOM
+ ;;
+ esac
+ else
+ ccflags="$ccflags -Aa" # The add-on compiler supports ANSI C
+ fi
+ # For HP's ANSI C compiler, up to "+O3" is safe for everything
+ # except shared libraries (PIC code). Max safe for PIC is "+O2".
+ # Setting both causes innocuous warnings.
+ #optimize='+O3'
+ #cccdlflags='+z +O2'
+ optimize='-O'
+ ;;
+esac
+
+# Even if you use gcc, prefer the HP math library over the GNU one.
+
+case "`$cc -v 2>&1`" in
+"*gcc*" ) test -d /lib/pa1.1 && ccflags="$ccflags -L/lib/pa1.1" ;;
+esac
+
+# Determine the architecture type of this system.
+# Keep leading tab below -- Configure Black Magic -- RAM, 03/02/97
+ xxOsRevMajor=`uname -r | sed -e 's/^[^0-9]*//' | cut -d. -f1`;
+ #xxOsRevMinor=`uname -r | sed -e 's/^[^0-9]*//' | cut -d. -f2`;
+if [ "$xxOsRevMajor" -ge 10 ]
+then
+ # This system is running >= 10.x
+
+ # Tested on 10.01 PA1.x and 10.20 PA[12].x. Idea: Scan
+ # /usr/include/sys/unistd.h for matches with "#define CPU_* `getconf
+ # CPU_VERSION`" to determine CPU type. Note the part following
+ # "CPU_" is used, *NOT* the comment.
+ #
+ # ASSUMPTIONS: Numbers will continue to be defined in hex -- and in
+ # /usr/include/sys/unistd.h -- and the CPU_* #defines will be kept
+ # up to date with new CPU/OS releases.
+ xxcpu=`getconf CPU_VERSION`; # Get the number.
+ xxcpu=`printf '0x%x' $xxcpu`; # convert to hex
+ archname=`sed -n -e "s/^#[ \t]*define[ \t]*CPU_//p" /usr/include/sys/unistd.h |
+ sed -n -e "s/[ \t]*$xxcpu[ \t].*//p" |
+ sed -e s/_RISC/-RISC/ -e s/HP_// -e s/_/./`;
+else
+ # This system is running <= 9.x
+ # Tested on 9.0[57] PA and [78].0 MC680[23]0. Idea: After removing
+ # MC6888[12] from context string, use first CPU identifier.
+ #
+ # ASSUMPTION: Only CPU identifiers contain no lowercase letters.
+ archname=`getcontext | tr ' ' '\012' | grep -v '[a-z]' | grep -v MC688 |
+ sed -e 's/HP-//' -e 1q`;
+ selecttype='int *'
+fi
+
+
+# Remove bad libraries that will cause problems
+# (This doesn't remove libraries that don't actually exist)
+# -lld is unneeded (and I can't figure out what it's used for anyway)
+# -ldbm is obsolete and should not be used
+# -lBSD contains BSD-style duplicates of SVR4 routines that cause confusion
+# -lPW is obsolete and should not be used
+# The libraries crypt, malloc, ndir, and net are empty.
+# Although -lndbm should be included, it will make perl blow up if you should
+# copy the binary to a system without libndbm.sl. See ccdlflags below.
+set `echo " $libswanted " | sed -e 's@ ld @ @' -e 's@ dbm @ @' -e 's@ BSD @ @' -e 's@ PW @ @'`
+libswanted="$*"
+
+# By setting the deferred flag below, this means that if you run perl
+# on a system that does not have the required shared library that you
+# linked it with, it will die when you try to access a symbol in the
+# (missing) shared library. If you would rather know at perl startup
+# time that you are missing an important shared library, switch the
+# comments so that immediate, rather than deferred loading is
+# performed. Even with immediate loading, you can postpone errors for
+# undefined (or multiply defined) routines until actual access by
+# adding the "nonfatal" option.
+# ccdlflags="-Wl,-E -Wl,-B,immediate $ccdlflags"
+# ccdlflags="-Wl,-E -Wl,-B,immediate,-B,nonfatal $ccdlflags"
+ccdlflags="-Wl,-E -Wl,-B,deferred $ccdlflags"
+
+usemymalloc='y'
+alignbytes=8
+# For native nm, you need "-p" to produce BSD format output.
+nm_opt='-p'
+
+# When HP-UX runs a script with "#!", it sets argv[0] to the script name.
+toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"'
+
+# If your compile complains about FLT_MIN, uncomment the next line
+# POSIX_cflags='ccflags="$ccflags -DFLT_MIN=1.17549435E-38"'
+
+# Comment this out if you don't want to follow the SVR4 filesystem layout
+# that HP-UX 10.0 uses
+case "$prefix" in
+'') prefix='/opt/perl5' ;;
+esac
+
+# HP-UX can't do setuid emulation offered by Configure
+case "$d_dosuid" in
+'') d_dosuid="$undef" ;;
+esac
+
+# Date: Fri, 6 Sep 96 23:15:31 CDT
+# From: "Daniel S. Lewart" <d-lewart@uiuc.edu>
+# I looked through the gcc.info and found this:
+# * GNU CC compiled code sometimes emits warnings from the HP-UX
+# assembler of the form:
+# (warning) Use of GR3 when frame >= 8192 may cause conflict.
+# These warnings are harmless and can be safely ignored.
+
+#
+# cppstdin and cpprun need the -Aa option if you use the unbundled
+# ANSI C compiler (*not* the bundled K&R compiler or gcc)
+# [XXX this should be enabled automatically by Configure, but isn't yet.]
+# [XXX This is reported not to work. You may have to edit config.sh.
+# After running Configure, set cpprun and cppstdin in config.sh,
+# run "Configure -S" and then "make".]
+#
+case "$cppstdin" in
+'')
+ case "$ccflags" in
+ *-Aa*)
+ cpprun="${cc:-cc} -E -Aa"
+ cppstdin="$cpprun"
+ cppminus='-'
+ cpplast='-'
+ ;;
+ esac
+ ;;
+esac
diff --git a/contrib/perl5/hints/i386.sh b/contrib/perl5/hints/i386.sh
new file mode 100644
index 000000000000..0a810ffea888
--- /dev/null
+++ b/contrib/perl5/hints/i386.sh
@@ -0,0 +1 @@
+ldflags='-L/usr/ucblib'
diff --git a/contrib/perl5/hints/irix_4.sh b/contrib/perl5/hints/irix_4.sh
new file mode 100644
index 000000000000..f5883f38cb72
--- /dev/null
+++ b/contrib/perl5/hints/irix_4.sh
@@ -0,0 +1,24 @@
+#irix_4.sh
+# Last modified Fri May 5 14:06:37 EDT 1995
+optimize='-O1'
+
+# Does Configure really get these wrong? Why?
+d_voidsig=define
+d_charsprf=undef
+
+case "$cc" in
+*gcc*) ccflags="$ccflags -D_BSD_TYPES" ;;
+*) ccflags="$ccflags -ansiposix -signed" ;;
+esac
+
+# This hint due thanks Hershel Walters <walters@smd4d.wes.army.mil>
+# Date: Tue, 31 Jan 1995 16:32:53 -0600 (CST)
+# Subject: IRIX4.0.4(.5? 5.0?) problems
+# I don't know if they affect versions of perl other than 5.000 or
+# versions of IRIX other than 4.0.4.
+#
+cat <<'EOM' >&4
+If you have problems, you might have try including
+ -DSTANDARD_C -cckr
+in ccflags.
+EOM
diff --git a/contrib/perl5/hints/irix_5.sh b/contrib/perl5/hints/irix_5.sh
new file mode 100644
index 000000000000..9d6e80246c0b
--- /dev/null
+++ b/contrib/perl5/hints/irix_5.sh
@@ -0,0 +1,34 @@
+# irix_5.sh
+# Tue Jan 9 16:04:38 EST 1996
+# Add note about socket patch.
+#
+# Tue Jan 2 14:52:36 EST 1996
+# Apparently, there's a stdio bug that can lead to memory
+# corruption using perl's malloc, but not SGI's malloc.
+usemymalloc='n'
+
+ld=ld
+i_time='define'
+
+case "$cc" in
+*gcc*) ccflags="$ccflags -D_BSD_TYPES" ;;
+*) ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 4000" ;;
+esac
+
+lddlflags="-shared"
+# For some reason we don't want -lsocket -lnsl or -ldl. Can anyone
+# contribute an explanation?
+set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'`
+shift
+libswanted="$*"
+
+# Date: Fri, 22 Dec 1995 11:49:17 -0800
+# From: Matthew Black <black@csulb.edu>
+# Subject: sockets broken under IRIX 5.3? YES...how to fix
+# Anyone attempting to use perl4 or perl5 with SGI IRIX 5.3 may discover
+# that sockets are essentially broken. The syslog interface for perl also
+# fails because it uses the broken socket interface. This problem was
+# reported to SGI as bug #255347 and it can be fixed by installing
+# patchSG0000596. The patch can be downloaded from Advantage OnLine (SGI's
+# WWW server) or from the Support Advantage 9/95 Patch CDROM. Thanks to Tom
+# Christiansen and others who provided assistance.
diff --git a/contrib/perl5/hints/irix_6.sh b/contrib/perl5/hints/irix_6.sh
new file mode 100644
index 000000000000..384701ffd6de
--- /dev/null
+++ b/contrib/perl5/hints/irix_6.sh
@@ -0,0 +1,190 @@
+# hints/irix_6.sh
+#
+# original from Krishna Sethuraman, krishna@sgi.com
+#
+# Modified Mon Jul 22 14:52:25 EDT 1996
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# with help from Dean Roehrich <roehrich@cray.com>.
+# cc -n32 update info from Krishna Sethuraman, krishna@sgi.com.
+# additional update from Scott Henry, scotth@sgi.com
+
+# Futzed with by John Stoffel <jfs@fluent.com> on 4/24/1997
+# - assumes 'cc -n32' by default
+# - tries to check for various compiler versions and do the right
+# thing when it can
+# - warnings turned off (-n32 messages):
+# 1116 - non-void function should return a value
+# 1048 - cast between pointer-to-object and pointer-to-function
+# 1042 - operand types are incompatible
+
+# Tweaked by Chip Salzenberg <chip@perl.com> on 5/13/97
+# - don't assume 'cc -n32' if the n32 libm.so is missing
+
+# Threaded by Jarkko Hietaniemi <jhi@iki.fi> on 11/18/97
+# - POSIX threads knowledge by IRIX version
+
+# gcc-enabled by Kurt Starsinic <kstar@isinet.com> on 3/24/1998
+
+# Use sh Configure -Dcc='cc -n32' to try compiling with -n32.
+# or -Dcc='cc -n32 -mips3' (or -mips4) to force (non)portability
+# Don't bother with -n32 unless you have the 7.1 or later compilers.
+# But there's no quick and light-weight way to check in 6.2.
+
+# Let's assume we want to use 'cc -n32' by default, unless the
+# necessary libm is missing (which has happened at least twice)
+case "$cc" in
+'')
+ if test -f /usr/lib32/libm.so
+ then
+ cc='cc -n32'
+ fi ;;
+esac
+
+# Check for which compiler we're using
+
+case "$cc" in
+*"cc -n32"*)
+
+ # Perl 5.004_57 introduced new qsort code into pp_ctl.c that
+ # makes IRIX cc prior to 7.2.1 to emit bad code.
+ # so some serious hackery follows to set pp_ctl flags correctly.
+
+ # Check for which version of the compiler we're running
+ case "`$cc -version 2>&1`" in
+ *7.0*) # Mongoose 7.0
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1042,1048,1110,1116,1184 -OPT:Olimit=0"
+ optimize='none'
+ ;;
+ *7.1*|*7.2|*7.20) # Mongoose 7.1+
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184 -OPT:Olimit=0"
+ optimize='-O3'
+# This is a temporary fix for 5.005.
+# Leave pp_ctl_cflags line at left margin for Configure. See
+# hints/README.hints, especially the section
+# =head2 Propagating variables to config.sh
+pp_ctl_cflags='optimize=-O'
+ ;;
+ *7.*) # Mongoose 7.2.1+
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184 -OPT:Olimit=0:space=on"
+ optimize='-O3'
+ ;;
+ *6.2*) # Ragnarok 6.2
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184"
+ optimize='none'
+ ;;
+ *) # Be safe and not optimize
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184 -OPT:Olimit=0"
+ optimize='none'
+ ;;
+ esac
+
+ ld=ld
+ # perl's malloc can return improperly aligned buffer
+ usemymalloc='undef'
+ # NOTE: -L/usr/lib32 -L/lib32 are automatically selected by the linker
+ ldflags=' -L/usr/local/lib32 -L/usr/local/lib'
+ cccdlflags=' '
+ # From: David Billinghurst <David.Billinghurst@riotinto.com.au>
+ # If you get complaints about so_locations then change the following
+ # line to something like:
+ # lddlflags="-n32 -shared -check_registry /usr/lib32/so_locations"
+ lddlflags="-n32 -shared"
+ libc='/usr/lib32/libc.so'
+ plibpth='/usr/lib32 /lib32 /usr/ccs/lib'
+ nm_opt='-p'
+ nm_so_opt='-p'
+ ;;
+*gcc*)
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -D_POSIX_C_SOURCE"
+ optimize="-O3"
+ usenm='undef'
+ ;;
+*)
+ # this is needed to force the old-32 paths
+ # since the system default can be changed.
+ ccflags="$ccflags -32 -D_BSD_TYPES -D_BSD_TIME -Olimit 3100"
+ optimize='-O'
+ ;;
+esac
+
+# We don't want these libraries.
+# Socket networking is in libc, these are not installed by default,
+# and just slow perl down. (scotth@sgi.com)
+set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'`
+shift
+libswanted="$*"
+
+# I have conflicting reports about the sun, crypt, bsd, and PW
+# libraries on Irix 6.2.
+#
+# One user rerports:
+# Don't need sun crypt bsd PW under 6.2. You *may* need to link
+# with these if you want to run perl built under 6.2 on a 5.3 machine
+# (I haven't checked)
+#
+# Another user reported that if he included those libraries, a large number
+# of the tests failed (approx. 20-25) and he would get a core dump. To
+# make things worse, test results were inconsistent, i.e., some of the
+# tests would pass some times and fail at other times.
+# The safest thing to do seems to be to eliminate them.
+#
+# Actually, the only libs that you want are '-lm'. Everything else
+# you need is in libc. You do also need '-lbsd' if you choose not
+# to use the -D_BSD_* defines. Note that as of 6.2 the only
+# difference between '-lmalloc' and '-lc' malloc is the debugging
+# and control calls, which aren't used by perl. -- scotth@sgi.com
+
+set `echo X "$libswanted "|sed -e 's/ sun / /' -e 's/ crypt / /' -e 's/ bsd / /' -e 's/ PW / /' -e 's/ malloc / /'`
+shift
+libswanted="$*"
+
+if [ "X$usethreads" = "X$define" -o "X$usethreads" = "Xy" ]; then
+ if test ! -f /usr/include/pthread.h -o ! -f /usr/lib/libpthread.so; then
+ uname_r=`uname -r`
+ case "`uname -r`" in
+ 5*|6.0|6.1)
+ echo >&4 "IRIX $uname_r does not have the POSIX threads."
+ echo >&4 "You should upgrade to at least IRIX 6.2 with pthread patches."
+ echo >&4 "Cannot continue, aborting."
+ exit 1
+ ;;
+ 6.2)
+ echo >&4 ""
+cat >&4 <<EOF
+IRIX 6.2 $uname_r can have the POSIX threads.
+The following IRIX patches (or their replacements) must, however, be installed:
+
+ 1404 Irix 6.2 Posix 1003.1b man pages
+ 1645 IRIX 6.2 & 6.3 POSIX header file updates
+ 2000 Irix 6.2 Posix 1003.1b support modules
+ 2254 Pthread library fixes
+ 2401 6.2 all platform kernel rollup
+IMPORTANT:
+ Without patch 2401, a kernel bug in IRIX 6.2 will
+ cause your machine to panic and crash when running
+ threaded perl. IRIX 6.3 and up should be OK.
+
+
+Cannot continue, aborting.
+EOF
+ exit 1
+ ;;
+ 6.*|7.*)
+ echo >&4 "IRIX $uname_r should have the POSIX threads."
+ echo >&4 "But somehow you do not seem to have them installed."
+ echo >&4 "Cannot continue, aborting."
+ exit 1
+ ;;
+ esac
+ unset uname_r
+ fi
+ # -lpthread needs to come before -lc but after other libraries such
+ # as -lgdbm and such like. We assume here that -lc is present in
+ # libswanted. If that fails to be true in future, then this can be
+ # changed to add pthread to the very end of libswanted.
+ set `echo X "$libswanted "| sed -e 's/ c / pthread /'`
+ ld="${cc:-cc}"
+ shift
+ libswanted="$*"
+ usemymalloc='n'
+fi
diff --git a/contrib/perl5/hints/irix_6_0.sh b/contrib/perl5/hints/irix_6_0.sh
new file mode 100644
index 000000000000..b0a39943bd4e
--- /dev/null
+++ b/contrib/perl5/hints/irix_6_0.sh
@@ -0,0 +1,51 @@
+# irix_6.sh
+# from Krishna Sethuraman, krishna@sgi.com
+# Date: Wed Jan 18 11:40:08 EST 1995
+# added `-32' to force compilation in 32-bit mode.
+# otherwise, copied from irix_5.sh.
+
+# Perl built with this hints file under IRIX 6.0.1 passes
+# all tests (`make test').
+
+# Tue Jan 2 14:52:36 EST 1996
+# Apparently, there's a stdio bug that can lead to memory
+# corruption using perl's malloc, but not SGI's malloc.
+usemymalloc='n'
+
+ld=ld
+i_time='define'
+cc="cc -32"
+ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 3000"
+lddlflags="-32 -shared"
+
+# We don't want these libraries. Anyone know why?
+set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'`
+shift
+libswanted="$*"
+#
+# The following might be of interest if you wish to try 64-bit mode:
+# irix_6_64bit.sh
+# Krishna Sethuraman, krishna@sgi.com
+# taken from irix_5.sh . Changes from irix_5.sh:
+# Olimit and nested comments (warning 1009) no longer accepted
+# -OPT:fold_arith_limit so POSIX module will optimize
+# no 64bit versions of sun, crypt, nsl, socket, dl dso's available
+# as of IRIX 6.0.1 so omit those from libswanted line via `sed'.
+
+# perl 5 built with this hints file passes most tests (`make test').
+# Fails on op/subst test only. (built and tested under IRIX 6.0.1).
+
+# i_time='define'
+# ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -woff 1009 -OPT:fold_arith_limit=1046"
+# lddlflags="-shared"
+# set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ sun / /' -e 's/ crypt / /' -e 's/ nsl / /' -e 's/ dl / /'`
+# shift
+# libswanted="$*"
+
+if [ "X$usethreads" = "X$define" ]; then
+ echo >&4 "IRIX 6.0 does not have POSIX threads."
+ echo >&4 "You should upgrade to at least IRIX 6.3."
+ echo >&4 "Cannot continue, aborting."
+ exit 1
+fi
+
diff --git a/contrib/perl5/hints/irix_6_1.sh b/contrib/perl5/hints/irix_6_1.sh
new file mode 100644
index 000000000000..1c54f774a901
--- /dev/null
+++ b/contrib/perl5/hints/irix_6_1.sh
@@ -0,0 +1,50 @@
+# irix_6.sh
+# from Krishna Sethuraman, krishna@sgi.com
+# Date: Wed Jan 18 11:40:08 EST 1995
+# added `-32' to force compilation in 32-bit mode.
+# otherwise, copied from irix_5.sh.
+
+# Perl built with this hints file under IRIX 6.0.1 passes
+# all tests (`make test').
+
+# Tue Jan 2 14:52:36 EST 1996
+# Apparently, there's a stdio bug that can lead to memory
+# corruption using perl's malloc, but not SGI's malloc.
+usemymalloc='n'
+
+ld=ld
+i_time='define'
+cc="cc -32"
+ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 3000"
+lddlflags="-32 -shared"
+
+# We don't want these libraries. Anyone know why?
+set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'`
+shift
+libswanted="$*"
+#
+# The following might be of interest if you wish to try 64-bit mode:
+# irix_6_64bit.sh
+# Krishna Sethuraman, krishna@sgi.com
+# taken from irix_5.sh . Changes from irix_5.sh:
+# Olimit and nested comments (warning 1009) no longer accepted
+# -OPT:fold_arith_limit so POSIX module will optimize
+# no 64bit versions of sun, crypt, nsl, socket, dl dso's available
+# as of IRIX 6.0.1 so omit those from libswanted line via `sed'.
+
+# perl 5 built with this hints file passes most tests (`make test').
+# Fails on op/subst test only. (built and tested under IRIX 6.0.1).
+
+# i_time='define'
+# ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -woff 1009 -OPT:fold_arith_limit=1046"
+# lddlflags="-shared"
+# set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ sun / /' -e 's/ crypt / /' -e 's/ nsl / /' -e 's/ dl / /'`
+# shift
+# libswanted="$*"
+
+if [ "X$usethreads" = "X$define" ]; then
+ echo >&4 "IRIX 6.1 does not have POSIX threads."
+ echo >&4 "You should upgrade to at least IRIX 6.3."
+ echo >&4 "Cannot continue, aborting."
+ exit 1
+fi
diff --git a/contrib/perl5/hints/isc.sh b/contrib/perl5/hints/isc.sh
new file mode 100644
index 000000000000..cdfe91c605af
--- /dev/null
+++ b/contrib/perl5/hints/isc.sh
@@ -0,0 +1,44 @@
+# isc.sh
+# Interactive Unix Versions 3 and 4.
+# Compile perl entirely in posix mode.
+# Andy Dougherty doughera@lafcol.lafayette.edu
+# Wed Oct 5 15:57:37 EDT 1994
+#
+# Use Configure -Dcc=gcc to use gcc
+#
+
+# We don't want to explicitly mention -lc (since we're using POSIX mode.)
+# We also don't want -lx (the Xenix compatability libraries.) The only
+# thing that it seems to pick up is chsize(), which has been reported to
+# not work. chsize() can also be implemented via fcntl() in perl (if you
+# define -D_SYSV3). We'll leave in -lPW since it's harmless. Some
+# extension might eventually need it for alloca, though perl doesn't use
+# it.
+
+set `echo X "$libswanted "| sed -e 's/ c / /' -e 's/ x / /'`
+shift
+libswanted="$*"
+
+case "$cc" in
+*gcc*) ccflags="$ccflags -posix"
+ ldflags="$ldflags -posix"
+ ;;
+*) ccflags="$ccflags -Xp -D_POSIX_SOURCE"
+ ldflags="$ldflags -Xp"
+ ;;
+esac
+
+# getsockname() and getpeername() return 256 for no good reason
+ccflags="$ccflags -DBOGUS_GETNAME_RETURN=256"
+
+# rename(2) can't rename long filenames
+d_rename=undef
+
+# for ext/IPC/SysV/SysV.xs
+ccflags="$ccflags -DPERL_ISC"
+
+# You can also include -D_SYSV3 to pick up "traditionally visible"
+# symbols hidden by name-space pollution rules. This raises some
+# compilation "redefinition" warnings, but they appear harmless.
+# ccflags="$ccflags -D_SYSV3"
+
diff --git a/contrib/perl5/hints/isc_2.sh b/contrib/perl5/hints/isc_2.sh
new file mode 100644
index 000000000000..d8ca7dc63a7c
--- /dev/null
+++ b/contrib/perl5/hints/isc_2.sh
@@ -0,0 +1,25 @@
+# isc_2.sh
+# Interactive Unix Version 2.2
+# Compile perl entirely in posix mode.
+# Andy Dougherty doughera@lafcol.lafayette.edu
+# Wed Oct 5 15:57:37 EDT 1994
+#
+# Use Configure -Dcc=gcc to use gcc
+#
+set `echo X "$libswanted "| sed -e 's/ c / /'`
+shift
+libswanted="$*"
+case "$cc" in
+*gcc*) ccflags="$ccflags -posix"
+ ldflags="$ldflags -posix"
+ ;;
+*) ccflags="$ccflags -Xp -D_POSIX_SOURCE"
+ ldflags="$ldflags -Xp"
+ ;;
+esac
+# Compensate for conflicts in <net/errno.h>
+doio_cflags='ccflags="$ccflags -DENOTSOCK=103"'
+pp_sys_cflags='ccflags="$ccflags -DENOTSOCK=103"'
+
+# for ext/IPC/SysV/SysV.xs
+ccflags="$ccflags -DPERL_ISC"
diff --git a/contrib/perl5/hints/linux.sh b/contrib/perl5/hints/linux.sh
new file mode 100644
index 000000000000..545f50eb3d3d
--- /dev/null
+++ b/contrib/perl5/hints/linux.sh
@@ -0,0 +1,215 @@
+# hints/linux.sh
+# Original version by rsanders
+# Additional support by Kenneth Albanowski <kjahds@kjahds.com>
+#
+# ELF support by H.J. Lu <hjl@nynexst.com>
+# Additional info from Nigel Head <nhead@ESOC.bitnet>
+# and Kenneth Albanowski <kjahds@kjahds.com>
+#
+# Consolidated by Andy Dougherty <doughera@lafcol.lafayette.edu>
+#
+# Updated Thu Feb 8 11:56:10 EST 1996
+
+# Updated Thu May 30 10:50:22 EDT 1996 by <doughera@lafcol.lafayette.edu>
+
+# Updated Fri Jun 21 11:07:54 EDT 1996
+# NDBM support for ELF renabled by <kjahds@kjahds.com>
+
+# No version of Linux supports setuid scripts.
+d_suidsafe='undef'
+
+# perl goes into the /usr tree. See the Filesystem Standard
+# available via anonymous FTP at tsx-11.mit.edu in
+# /pub/linux/docs/linux-standards/fsstnd.
+# Allow a command line override, e.g. Configure -Dprefix=/foo/bar
+case "$prefix" in
+'') prefix='/usr' ;;
+esac
+
+# gcc-2.6.3 defines _G_HAVE_BOOL to 1, but doesn't actually supply bool.
+ccflags="-Dbool=char -DHAS_BOOL $ccflags"
+
+# BSD compatability library no longer needed
+# 'kaffe' has a /usr/lib/libnet.so which is not at all relevent for perl.
+set `echo X "$libswanted "| sed -e 's/ bsd / /' -e 's/ net / /'`
+shift
+libswanted="$*"
+
+# Configure may fail to find lstat() since it's a static/inline
+# function in <sys/stat.h>.
+d_lstat=define
+
+# Explanation?
+case "$usemymalloc" in
+'') usemymalloc='n' ;;
+esac
+
+case "$optimize" in
+'') optimize='-O2' ;;
+esac
+
+# Are we using ELF? Thanks to Kenneth Albanowski <kjahds@kjahds.com>
+# for this test.
+cat >try.c <<'EOM'
+/* Test for whether ELF binaries are produced */
+#include <fcntl.h>
+#include <stdlib.h>
+main() {
+ char buffer[4];
+ int i=open("a.out",O_RDONLY);
+ if(i==-1)
+ exit(1); /* fail */
+ if(read(i,&buffer[0],4)<4)
+ exit(1); /* fail */
+ if(buffer[0] != 127 || buffer[1] != 'E' ||
+ buffer[2] != 'L' || buffer[3] != 'F')
+ exit(1); /* fail */
+ exit(0); /* succeed (yes, it's ELF) */
+}
+EOM
+if ${cc:-gcc} try.c >/dev/null 2>&1 && ./a.out; then
+ cat <<'EOM' >&4
+
+You appear to have ELF support. I'll try to use it for dynamic loading.
+If dynamic loading doesn't work, read hints/linux.sh for further information.
+EOM
+
+#For RedHat Linux 3.0.3, you may need to fetch
+# ftp://ftp.redhat.com/pub/redhat-3.0.3/i386/updates/RPMS/ld.so-1.7.14-3.i386.rpm
+#
+
+else
+ cat <<'EOM' >&4
+
+You don't have an ELF gcc. I will use dld if possible. If you are
+using a version of DLD earlier than 3.2.6, or don't have it at all, you
+should probably upgrade. If you are forced to use 3.2.4, you should
+uncomment a couple of lines in hints/linux.sh and restart Configure so
+that shared libraries will be disallowed.
+
+EOM
+ lddlflags="-r $lddlflags"
+ # These empty values are so that Configure doesn't put in the
+ # Linux ELF values.
+ ccdlflags=' '
+ cccdlflags=' '
+ ccflags="-DOVR_DBL_DIG=14 $ccflags"
+ so='sa'
+ dlext='o'
+ nm_so_opt=' '
+ ## If you are using DLD 3.2.4 which does not support shared libs,
+ ## uncomment the next two lines:
+ #ldflags="-static"
+ #so='none'
+
+ # In addition, on some systems there is a problem with perl and NDBM
+ # which causes AnyDBM and NDBM_File to lock up. This is evidenced
+ # in the tests as AnyDBM just freezing. Apparently, this only
+ # happens on a.out systems, so we disable NDBM for all a.out linux
+ # systems. If someone can suggest a more robust test
+ # that would be appreciated.
+ #
+ # More info:
+ # Date: Wed, 7 Feb 1996 03:21:04 +0900
+ # From: Jeffrey Friedl <jfriedl@nff.ncl.omron.co.jp>
+ #
+ # I tried compiling with DBM support and sure enough things locked up
+ # just as advertised. Checking into it, I found that the lockup was
+ # during the call to dbm_open. Not *in* dbm_open -- but between the call
+ # to and the jump into.
+ #
+ # To make a long story short, making sure that the *.a and *.sa pairs of
+ # /usr/lib/lib{m,db,gdbm}.{a,sa}
+ # were perfectly in sync took care of it.
+ #
+ # This will generate a harmless Whoa There! message
+ case "$d_dbm_open" in
+ '') cat <<'EOM' >&4
+
+Disabling ndbm. This will generate a Whoa There message in Configure.
+Read hints/linux.sh for further information.
+EOM
+ # You can override this with Configure -Dd_dbm_open
+ d_dbm_open=undef
+ ;;
+ esac
+fi
+
+rm -f try.c a.out
+
+if /bin/bash -c exit; then
+ echo ''
+ echo 'You appear to have a working bash. Good.'
+else
+ cat << 'EOM' >&4
+
+*********************** Warning! *********************
+It would appear you have a defective bash shell installed. This is likely to
+give you a failure of op/exec test #5 during the test phase of the build,
+Upgrading to a recent version (1.14.4 or later) should fix the problem.
+******************************************************
+EOM
+
+fi
+
+# On SPARClinux,
+# The following csh consistently coredumped in the test directory
+# "/home/mikedlr/perl5.003_94/t", though not most other directories.
+
+#Name : csh Distribution: Red Hat Linux (Rembrandt)
+#Version : 5.2.6 Vendor: Red Hat Software
+#Release : 3 Build Date: Fri May 24 19:42:14 1996
+#Install date: Thu Jul 11 16:20:14 1996 Build Host: itchy.redhat.com
+#Group : Shells Source RPM: csh-5.2.6-3.src.rpm
+#Size : 184417
+#Description : BSD c-shell
+
+# For this reason I suggest using the much bug-fixed tcsh for globbing
+# where available.
+
+if [ ! "`csh -c 'echo $version' 2>/dev/null`" ]
+then
+ echo 'Real csh found (might break); looking for tcsh ...'
+ # Use ./UU/loc to find tcsh. (We no longer run in the hints/ directory)
+ if xxx=`./UU/loc tcsh blurfl $pth`; $test -f "$xxx"; then
+ echo "Found tcsh. I'll use it for globbing."
+ # We can't change Configure's setting of $csh, due to the way
+ # Configure handles $d_portable and commands found in $loclist.
+ # We can set the value for CSH in config.h by setting full_csh.
+ full_csh=$xxx
+ else
+ echo "Couldn't find tcsh. BEWARE: GLOBBING MIGHT BE BROKEN."
+ fi
+else
+ echo 'Your csh is really tcsh. Good.'
+fi
+
+# Shimpei Yamashita <shimpei@socrates.patnet.caltech.edu>
+# Message-Id: <33EF1634.B36B6500@pobox.com>
+#
+# MkLinux (osname=linux,archname=ppc-linux), which differs slightly from other
+# linuces, needs special flags passed in order for dynamic loading to work.
+# instead of the recommended:
+# ccdlflags='-rdynamic'
+#
+# it should be:
+# ccdlflags='-Wl,-E'
+
+# XXX EXPERIMENTAL A.D. 2/27/1998
+# XXX This script UU/usethreads.cbu will get 'called-back' by Configure
+# XXX after it has prompted the user for whether to use threads.
+cat > UU/usethreads.cbu <<'EOSH'
+case "$usethreads" in
+$define|true|[yY]*)
+ ccflags="-D_REENTRANT $ccflags"
+ # -lpthread needs to come before -lc but after other libraries such
+ # as -lgdbm and such like. We assume here that -lc is present in
+ # libswanted. If that fails to be true in future, then this can be
+ # changed to add pthread to the very end of libswanted.
+ set `echo X "$libswanted "| sed -e 's/ c / pthread c /'`
+ shift
+ libswanted="$*"
+ ;;
+esac
+EOSH
+# XXX EXPERIMENTAL --end of call-back
diff --git a/contrib/perl5/hints/lynxos.sh b/contrib/perl5/hints/lynxos.sh
new file mode 100644
index 000000000000..ddffcbe3cc79
--- /dev/null
+++ b/contrib/perl5/hints/lynxos.sh
@@ -0,0 +1,11 @@
+#
+# LynxOS hints
+#
+# These hints were submitted by:
+# Greg Seibert
+# seibert@Lynx.COM
+#
+
+cc='gcc'
+so='none'
+usemymalloc='n'
diff --git a/contrib/perl5/hints/machten.sh b/contrib/perl5/hints/machten.sh
new file mode 100644
index 000000000000..f283873699d2
--- /dev/null
+++ b/contrib/perl5/hints/machten.sh
@@ -0,0 +1,224 @@
+# machten.sh
+# This is for MachTen 4.0.3. It might work on other versions and variants too.
+#
+# Users of earlier MachTen versions might need a fixed tr from ftp.tenon.com.
+# This should be described in the MachTen release notes.
+#
+# MachTen 2.x has its own hint file.
+#
+# This file has been put together by Andy Dougherty
+# <doughera@lafcol.lafayette.edu> based on comments from lots of
+# folks, especially
+# Mark Pease <peasem@primenet.com>
+# Martijn Koster <m.koster@webcrawler.com>
+# Richard Yeh <rcyeh@cco.caltech.edu>
+#
+# For now, explicitly disable dynamic loading -- MT 4.1.1 has it,
+# but these hints do not yet support it.
+# Define NOTEDEF_MACHTEN to undo gratuitous Tenon hack to signal.h.
+# -- Dominic Dunlop <domo@computer.org> 9800802
+# Completely disable SysV IPC pending more complete support from Tenon
+# -- Dominic Dunlop <domo@computer.org> 980712
+# Use vfork and perl's malloc by default
+# -- Dominic Dunlop <domo@computer.org> 980630
+# Raise perl's stack size again; cut down reg_infty; document
+# -- Dominic Dunlop <domo@computer.org> 980619
+# Use of semctl() can crash system: disable -- Dominic Dunlop 980506
+# Raise stack size further; slight tweaks to accomodate MT 4.1
+# -- Dominic Dunlop <domo@computer.org> 980211
+# Raise perl's stack size -- Dominic Dunlop <domo@tcp.ip.lu> 970922
+# Reinstate sigsetjmp iff version is 4.0.3 or greater; use nm
+# (assumes Configure change); prune libswanted -- Dominic Dunlop 970113
+# Warn about test failure due to old Berkeley db -- Dominic Dunlop 970105
+# Do not use perl's malloc; SysV IPC OK -- Neil Cutcliffe, Tenon 961030
+# File::Find's use of link count disabled by Dominic Dunlop 960528
+# Perl's use of sigsetjmp etc. disabled by Dominic Dunlop 960521
+#
+# Comments, questions, and improvements welcome!
+#
+# MachTen 4.1.1 does support dynamic loading, but perl doesn't
+# know how to use it yet.
+usedl=${usedl:-undef}
+
+# MachTen 4.1.1 may have an unhelpful hack in /usr/include/signal.h.
+# Undo it if so.
+if grep NOTDEF_MACHTEN /usr/include/signal.h > /dev/null
+then
+ ccflags="$ccflags -DNOTDEF_MACHTEN"
+fi
+
+# Power MachTen is a real memory system and its standard malloc
+# has been optimized for this. Using this malloc instead of Perl's
+# malloc may result in significant memory savings. In particular,
+# unlike most UNIX memory allocation subsystems, MachTen's free()
+# really does return unneeded process data memory to the system.
+# However, MachTen's malloc() is woefully slow -- maybe 100 times
+# slower than perl's own, so perl's own is usually the better
+# choice. In order to use perl's malloc(), the sbrk() system call
+# must be simulated using MachTen's malloc(). See malloc.c for
+# precise details of how this is achieved. Recent improvements
+# to perl's malloc() currently crash MachTen, and so are disabled
+# by -DPLAIN_MALLOC and -DNO_FANCY_MALLOC.
+usemymalloc=${usemymalloc:-y}
+
+# Do not wrap the following long line
+malloc_cflags='ccflags="$ccflags -DPLAIN_MALLOC -DNO_FANCY_MALLOC -DUSE_PERL_SBRK"'
+
+# Note that an empty malloc_cflags appears in config.sh if perl's
+# malloc() is not used. his is harmless.
+case "$usemymalloc" in
+n) unset malloc_cflags;;
+*) ccflags="$ccflags -DHIDEMYMALLOC"
+esac
+
+# When MachTen does a fork(), it immediately copies the whole of
+# the parent process' data space for the child. This can be
+# expensive. Using vfork() where appropriate avoids this cost.
+d_vfork=${d_vfork:-define}
+
+# Specify a high level of optimization (-O3 wouldn't do much more)
+optimize=${optimize:--O2 -fomit-frame-pointer}
+
+# Make symbol table listings les voluminous
+nmopts=-gp
+
+# Set reg_infty -- the maximum allowable number of repeats in regular
+# expressions such as /a{1,$max_repeats}/, and the maximum number of
+# times /a*/ will match. Setting this too high without having a stack
+# large enough to accommodate deep recursion in the regular expression
+# engine allows perl to crash your Mac due to stack overrun if it
+# encounters a pathological regular expression. The default is a
+# compromise between capability and required stack size (see below).
+# You may override the default value from the Configure command-line
+# like this:
+#
+# Configure -Dreg_infty=16368 ...
+
+reg_infty=${reg_infty:-2047}
+
+# If you want to have many perl processes active simultaneously --
+# processing CGI forms -- for example, you should opt for a small stack.
+# For safety, you should set reg_infty no larger than the corresponding
+# value given in this table:
+#
+# Stack size reg_infty value supported
+# ---------- -------------------------
+# 128k 2**8-1 (256)
+# 256k 2**9-1 (511)
+# 512k 2**10-1 (1023)
+# 1M 2**11-1 (2047)
+# ...
+# 16M 2**15-1 (32767) (perl's default value)
+
+# This script selects a safe stack size based on the value of reg_infty
+# specified above. However, you may choose to take a risk and set
+# stack size lower: pathological regular expressions are rare in real-world
+# programs. But be aware that, if perl does encounter one, it WILL
+# crash your system. Do not set stack size lower than 96k unless
+# you want perl's installation tests ( make test ) to crash your system.
+#
+# You may override the default value from the Configure command-line
+# by specifying the required size in kilobytes like this:
+#
+# Configure -Dstack_size=96
+
+if [ "X$stack_size" = 'X' ]
+then
+ stack_size=128
+ X=`expr $reg_infty / 256`
+
+ while [ $X -gt 0 ]
+ do
+ X=`expr $X / 2`
+ stack_size=`expr $stack_size \* 2`
+ done
+ X=`expr $stack_size \* 1024`
+fi
+
+ldflags="$ldflags -Xlstack=$X"
+ccflags="$ccflags -DREG_INFTY=$reg_infty"
+
+# Install in /usr/local by default
+prefix='/usr/local'
+
+# At least on PowerMac, doubles must be aligned on 8 byte boundaries.
+# I don't know if this is true for all MachTen systems, or how to
+# determine this automatically.
+alignbytes=8
+
+# 4.0.2 and earlier had a problem with perl's use of sigsetjmp and
+# friends. Use setjmp and friends instead.
+expr "$osvers" \< "4.0.3" > /dev/null && d_sigsetjmp='undef'
+
+# System V IPC support in MachTen 4.1 is incomplete (missing msg function
+# prototypes, no ftok()), buggy (semctl(.., .., IPC_STATUS, ..) hangs
+# system), and undocumented. Claim it's not there until things improve.
+d_msg=${d_msg:-undef}
+d_sem=${d_sem:-undef}
+d_shm=${d_shm:-undef}
+
+# Get rid of some extra libs which it takes Configure a tediously
+# long time never to find on MachTen
+set `echo X "$libswanted "|sed -e 's/ net / /' -e 's/ socket / /' \
+ -e 's/ inet / /' -e 's/ nsl / /' -e 's/ nm / /' -e 's/ malloc / /' \
+ -e 's/ ld / /' -e 's/ sun / /' -e 's/ posix / /' \
+ -e 's/ cposix / /' -e 's/ crypt / /' \
+ -e 's/ ucb / /' -e 's/ bsd / /' -e 's/ BSD / /' -e 's/ PW / /'`
+shift
+libswanted="$*"
+
+# While link counts on MachTen 4.1's fast file systems work correctly,
+# on Macintosh Heirarchical File Systems, (and on HFS+)
+# MachTen always reports ony two links to directories, even if they
+# contain subdirectories. Consequently, we use this variable to stop
+# File::Find using the link count to determine whether there are
+# subdirectories to be searched. This will generate a harmless message:
+# Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
+# Propagating recommended variable dont_use_nlink
+dont_use_nlink=define
+
+cat <<EOM >&4
+
+During Configure, you may see the message
+
+*** WHOA THERE!!! ***
+ The recommended value for \$d_msg on this machine was "undef"!
+ Keep the recommended value? [y]
+
+as well as similar messages concerning \$d_sem and \$d_shm. Select the
+default answers: MachTen 4.1 appears to provide System V IPC support,
+but it is incomplete and buggy: perl should be built without it.
+
+Similarly, when you see
+
+*** WHOA THERE!!! ***
+ The recommended value for \$d_vfork on this machine was "define"!
+ Keep the recommended value? [y]
+
+select the default answer: vfork() works, and avoids expensive data
+copying.
+
+At the end of Configure, you will see a harmless message
+
+Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
+ Propagating recommended variable dont_use_nlink
+ Propagating recommended variable nmopts
+ Propagating recommended variable malloc_cflags...
+ Propagating recommended variable reg_infty
+Read the File::Find documentation for more information about dont_use_nlink
+
+Your perl will be built with a stack size of ${stack_size}k and a regular
+expression repeat count limit of $reg_infty. If you want alternative
+values, see the file hints/machten.sh for advice on how to change them.
+
+Tests
+ io/fs test 4 and
+ op/stat test 3
+may fail since MachTen may not return a useful nlinks field to stat
+on directories.
+
+EOM
+expr "$osvers" \< "4.1" >/dev/null && test -r ./broken-db.msg && \
+ . ./broken-db.msg
+
+unset stack_size X
diff --git a/contrib/perl5/hints/machten_2.sh b/contrib/perl5/hints/machten_2.sh
new file mode 100644
index 000000000000..bc7dde4e3fa0
--- /dev/null
+++ b/contrib/perl5/hints/machten_2.sh
@@ -0,0 +1,94 @@
+# machten.sh
+# This file has been put together by Mark Pease <peasem@primenet.com>
+# Comments, questions, and improvements welcome!
+#
+# MachTen does not support dynamic loading. If you wish to, you
+# can fetch, compile, and install the dld package.
+# This ought to work with the ext/DynaLoader/dl_dld.xs in the
+# perl5 package. Have fun!
+# Some possible locations for dld:
+# ftp-swiss.ai.mit.edu:pub/scm/dld-3.2.7.tar.gz
+# prep.ai.mit.edu:/pub/gnu/jacal/dld-3.2.7.tar.gz
+# ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/dld-3.2.7.tar.gz
+# tsx-11.mit.edu:/pub/linux/sources/libs/dld-3.2.7.tar.gz
+#
+# Original version was for MachTen 2.1.1.
+# Last modified by Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Tue Aug 13 12:31:01 EDT 1996
+#
+# Warning about tests which no longer fail
+# fixed by Tom Phoenix <rootbeer@teleport.com>
+# March 5, 1997
+#
+# Locale, optimization, and malloc changes by Tom Phoenix Mar 15, 1997
+#
+# groupstype change and note about t/lib/findbin.t by Tom, Mar 24, 1997
+
+# MachTen's ability to have valid filepaths beginning with "//" may
+# be causing lib/FindBin.pm to fail. I don't know how to fix it, but
+# the reader is encouraged to do so! :-) -- Tom
+
+# There seem to be some hard-to-diagnose problems under MachTen's
+# malloc, so we'll use Perl's. If you have problems which Perl's
+# malloc's diagnostics can't help you with, you may wish to use
+# MachTen's malloc after all.
+case "$usemymalloc" in
+'') usemymalloc='y' ;;
+esac
+
+# I (Tom Phoenix) don't know how to test for locales on MachTen. (If
+# you do, please fix this hints file!) But since mine didn't come
+# with locales working out of the box, I'll assume that's the case
+# for most folks.
+case "$d_setlocale" in
+'') d_setlocale=undef
+esac
+
+# MachTen doesn't have secure setid scripts
+d_suidsafe='undef'
+
+# groupstype should be gid_t, as near as I can tell, but it only
+# seems to work right when it's int.
+groupstype='int'
+
+case "$optimize" in
+'') optimize='-O2' ;;
+esac
+
+so='none'
+# These are useful only if you have DLD, but harmless otherwise.
+# Make sure gcc doesn't use -fpic.
+cccdlflags=' ' # That's an empty space.
+lddlflags='-r'
+dlext='o'
+
+# MachTen does not support POSIX enough to compile the POSIX module.
+useposix=false
+
+#MachTen might have an incomplete Berkeley DB implementation.
+i_db=$undef
+
+#MachTen versions 2.X have no hard links. This variable is used
+# by File::Find.
+# This will generate a harmless message:
+# Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
+# Propagating recommended variable dont_use_nlink
+# Without this, tests io/fs #4 and op/stat #3 will fail.
+dont_use_nlink=define
+
+cat <<'EOM' >&4
+
+During Configure, you may get two "WHOA THERE" messages, for $d_setlocale
+and $i_db being 'undef'. You may keep the undef value.
+
+At the end of Configure, you will see a harmless message
+
+Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
+ Propagating recommended variable dont_use_nlink
+
+Read the File::Find documentation for more information.
+
+It's possible that test t/lib/findbin.t will fail on some configurations
+of MachTen.
+
+EOM
diff --git a/contrib/perl5/hints/mips.sh b/contrib/perl5/hints/mips.sh
new file mode 100644
index 000000000000..bc0b7e807376
--- /dev/null
+++ b/contrib/perl5/hints/mips.sh
@@ -0,0 +1,14 @@
+perl_cflags='optimize="-g"'
+d_volatile=undef
+d_castneg=undef
+cc=cc
+glibpth="/usr/lib/cmplrs/cc $glibpth"
+groupstype=int
+nm_opt='-B'
+case $PATH in
+*bsd*:/bin:*) cat <<END >&4
+NOTE: Some people have reported having much better luck with Mips CC than
+with the BSD cc. Put /bin first in your PATH if you have difficulties.
+END
+;;
+esac
diff --git a/contrib/perl5/hints/mpc.sh b/contrib/perl5/hints/mpc.sh
new file mode 100644
index 000000000000..da6fcc95b041
--- /dev/null
+++ b/contrib/perl5/hints/mpc.sh
@@ -0,0 +1 @@
+ccflags="$ccflags -X18"
diff --git a/contrib/perl5/hints/mpeix.sh b/contrib/perl5/hints/mpeix.sh
new file mode 100644
index 000000000000..4a32b77fa262
--- /dev/null
+++ b/contrib/perl5/hints/mpeix.sh
@@ -0,0 +1,104 @@
+# The MPE/iX linker doesn't complain about unresolved symbols, and so the only
+# way to test for unresolved symbols in a program is by attempting to run it.
+# But this is slow, and fraught with problems, so the better solution is to use
+# nm.
+#
+# MPE/iX lacks a fully functional native nm, so we need to use our fake nm
+# script which will extract the symbol info from the native link editor and
+# reformat into something nm-like.
+#
+# Created for 5.003 by Mark Klein, mklein@dis.com.
+# Substantially revised for 5.004_01 by Mark Bixby, markb@cccd.edu.
+# Revised again for 5.004_69 by Mark Bixby, markb@cccd.edu.
+#
+osname='mpeix'
+osvers='5.5'
+#
+# Force Configure to use our wrapper mpeix/nm script
+#
+PATH="$PWD/mpeix:$PATH"
+nm="$PWD/mpeix/nm"
+_nm=$nm
+nm_opt='-configperl'
+usenm='true'
+#
+# Various directory locations.
+#
+prefix='/PERL/PUB'
+archname='PA-RISC1.1'
+bin="$prefix"
+installman1dir="$prefix/man/man1"
+installman3dir="$prefix/man/man3"
+man1dir="$prefix/man/man1"
+man3dir="$prefix/man/man3"
+perlpath="$prefix/PERL"
+scriptdir="$prefix"
+startperl="#!$prefix/perl"
+startsh='#!/bin/sh'
+#
+# Compiling.
+#
+cc='gcc'
+cccdlflags='none'
+ccflags='-DMPE -D_POSIX_SOURCE -D_SOCKET_SOURCE -D_POSIX_JOB_CONTROL -DIS_SOCKET_CLIB_ITSELF'
+locincpth='/usr/local/include /usr/contrib/include /BIND/PUB/include'
+optimize='-O2'
+ranlib='/bin/true'
+# Special compiling options for certain source files.
+regcomp_cflags='optimize=-O'
+toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"'
+#
+# Linking.
+#
+lddlflags='-b'
+libs='-lbind -lsvipc -lsocket -lm -lc'
+loclibpth='/usr/local/lib /usr/contrib/lib /BIND/PUB/lib'
+#
+# External functions and data items.
+#
+d_crypt='define'
+d_difftime='define'
+d_dlerror='undef'
+d_dlopen='undef'
+d_Gconvert='gcvt((x),(n),(b))'
+d_inetaton='undef'
+d_link='undef'
+d_mblen='define'
+d_mbstowcs='define'
+d_mbtowc='define'
+d_memcmp='define'
+d_memcpy='define'
+d_memmove='define'
+d_memset='define'
+d_pwage='undef'
+d_pwcomment='undef'
+d_pwgecos='undef'
+d_pwpasswd='undef'
+d_setpgid='undef'
+d_setsid='undef'
+d_setvbuf='define'
+d_statblks='undef'
+d_strchr='define'
+d_strcoll='define'
+d_strerrm='strerror(e)'
+d_strerror='define'
+d_strtod='define'
+d_strtol='define'
+d_strtoul='define'
+d_strxfrm='define'
+d_syserrlst='define'
+d_time='define'
+d_wcstombs='define'
+d_wctomb='define'
+#
+# Include files.
+#
+i_termios='undef'
+i_time='define'
+i_systime='undef'
+i_systimek='undef'
+timeincl='/usr/include/time.h'
+#
+# Data types.
+#
+timetype='time_t'
diff --git a/contrib/perl5/hints/ncr_tower.sh b/contrib/perl5/hints/ncr_tower.sh
new file mode 100644
index 000000000000..7ddb9230e909
--- /dev/null
+++ b/contrib/perl5/hints/ncr_tower.sh
@@ -0,0 +1,16 @@
+# For SysV release 2, there are no directory functions defined. To
+# prevent compile errors, acquire the functions written by Doug Gwynn.
+# They are contained in dirent.tar.gz and can be accessed from gnu
+# repositories, as well as other places.
+#
+# The following hints have been verified to work with PERL5 (001m) on
+# SysVr2 with the following caveat(s):
+# 1. Maximum User program space (MAXSPACE) must be at least 2MB.
+# 2. The directory functions mentioned above have been installed.
+#
+optimize='-O0'
+ccflags="$ccflags -W2,-Sl,1500 -W0,-Sp,350,-Ss,2500 -Wp,-Sd,30"
+d_mkdir=$undef
+usemymalloc='y'
+useposix='false'
+so='none'
diff --git a/contrib/perl5/hints/netbsd.sh b/contrib/perl5/hints/netbsd.sh
new file mode 100644
index 000000000000..71d508448a6b
--- /dev/null
+++ b/contrib/perl5/hints/netbsd.sh
@@ -0,0 +1,79 @@
+# hints/netbsd.sh
+#
+# talk to mrg@eterna.com.au if you want to change this file.
+#
+# netbsd keeps dynamic loading dl*() functions in /usr/lib/crt0.o,
+# so Configure doesn't find them (unless you abandon the nm scan).
+# this should be *just* 0.9 below as netbsd 0.9a was the first to
+# introduce shared libraries. however, they don't work/build on
+# pmax, powerpc and alpha ports correctly, yet.
+
+case "$archname" in
+'')
+ archname=`uname -m`-${osname}
+ ;;
+esac
+
+case "$osvers" in
+0.9|0.8*)
+ usedl="$undef"
+ ;;
+*)
+ case `uname -m` in
+ alpha|powerpc|pmax)
+ d_dlopen=$undef
+ ;;
+# this doesn't work (yet).
+# alpha)
+# d_dlopen=$define
+# d_dlerror=$define
+# cccdlflags="-DPIC -fPIC $cccdlflags"
+# lddlflags="-shared $lddlflags"
+# ;;
+ *)
+ d_dlopen=$define
+ d_dlerror=$define
+# we use -fPIC here because -fpic is *NOT* enough for some of the
+# extensions like Tk on some netbsd platforms (the sparc is one)
+ cccdlflags="-DPIC -fPIC $cccdlflags"
+ lddlflags="-Bforcearchive -Bshareable $lddlflags"
+ ;;
+ esac
+ ;;
+esac
+# netbsd 1.3 linker warns about setr[gu]id being deprecated.
+# (setregid, setreuid, preferred?)
+case "$osvers" in
+1.3|1.3*)
+ d_setrgid="$undef"
+ d_setruid="$undef"
+ ;;
+esac
+
+# netbsd had these but they don't really work as advertised, in the
+# versions listed below. if they are defined, then there isn't a
+# way to make perl call setuid() or setgid(). if they aren't, then
+# ($<, $>) = ($u, $u); will work (same for $(/$)). this is because
+# you can not change the real userid of a process under 4.4BSD.
+# netbsd fixed this in 1.2A.
+case "$osvers" in
+0.9*|1.0*|1.1*|1.2_*|1.2|1.2.*)
+ d_setregid="$undef"
+ d_setreuid="$undef"
+ d_setrgid="$undef"
+ d_setruid="$undef"
+ ;;
+esac
+# netbsd 1.3 linker warns about setr[gu]id being deprecated.
+# (setregid, setreuid, preferred?)
+case "$osvers" in
+1.3|1.3*)
+ d_setrgid="$undef"
+ d_setruid="$undef"
+ ;;
+esac
+
+# vfork is ok on NetBSD.
+case "$usevfork" in
+'') usevfork=true ;;
+esac
diff --git a/contrib/perl5/hints/newsos4.sh b/contrib/perl5/hints/newsos4.sh
new file mode 100644
index 000000000000..a33cb3154a31
--- /dev/null
+++ b/contrib/perl5/hints/newsos4.sh
@@ -0,0 +1,34 @@
+#
+# hints file for NEWS-OS 4.x
+#
+
+echo
+echo 'Compiling Tips:'
+echo 'When you have found that ld complains "multiple defined" error'
+echo 'on linking /lib/libdbm.a, do following instructions.'
+echo ' cd /tmp (working on /tmp)'
+echo ' cp /lib/libdbm.a dbm.o (copy current libdbm.a)'
+echo ' ar cr libdbm.a dbm.o (make archive)'
+echo ' mv /lib/libdbm.a /lib/libdbm.a.backup (backup original library)'
+echo ' cp /tmp/libdbm.a /lib (copy newer one)'
+echo ' ranlib /lib/libdbm.a (ranlib for later use)'
+echo
+
+# No shared library.
+so='none'
+# Umm.. I like gcc.
+cc='gcc'
+# Configure does not find out where is libm.
+plibpth='/usr/lib/cmplrs/cc'
+# times() returns 'struct tms'
+clocktype='struct tms'
+# getgroups(2) returns integer (not gid_t)
+groupstype='int'
+# time(3) returns long (not time_t)
+timetype='long'
+# filemode type is int (not mode_t)
+modetype='int'
+# using sprintf(3) instead of gcvt(3)
+d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+# No POSIX.
+useposix='false'
diff --git a/contrib/perl5/hints/next_3.sh b/contrib/perl5/hints/next_3.sh
new file mode 100644
index 000000000000..43340c03ad2c
--- /dev/null
+++ b/contrib/perl5/hints/next_3.sh
@@ -0,0 +1,131 @@
+# This file has been put together by Anno Siegel <siegel@zrz.TU-Berlin.DE>,
+# Andreas Koenig <k@franz.ww.TU-Berlin.DE> and Gerd Knops <gerti@BITart.com>.
+# Comments, questions, and improvements welcome!
+#
+# These hints work for NeXT 3.2 and 3.3. 3.0 has it's own
+# special hint file.
+#
+
+######################################################################
+# THE MALLOC STORY
+######################################################################
+# 1994:
+# the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails
+# with Larry's malloc on NS 3.2 due to broken sbrk()
+#
+# setting usemymalloc='n' was the solution back then. Later came
+# reports that perl would run unstable on 3.2:
+#
+# 1996:
+# From about perl5.002beta1h perl became unstable on the
+# NeXT. Intermittent coredumps were frequent on 3.2 OS. There were
+# reports, that the developer version of 3.3 didn't have problems, so it
+# seemed pretty obvious that we had to work around an malloc bug in 3.2.
+# This hints file reflects a patch to perl5.002_01 that introduces a
+# home made sbrk routine (remember, NeXT's sbrk _never_ worked). This
+# sbrk makes it possible to run perl with its own malloc. Thanks to
+# Ilya who showed me the way to his sbrk for OS/2!!
+#
+# The whole malloc desaster lead to a failing gdbm test. It is far
+# beyond my understanding, why GDBM_File breaks with the "fix", but in
+# general I consider it better to have a working perl with broken GDBM
+# than no perl at all.
+#
+# So, this hintsfile is using perl's malloc. If you want to turn
+# perl's malloc off, you need to remove '-DUSE_PERL_SBRK' and
+# '-DHIDEMYMALLOC' from the ccflags and set usemymalloc to 'n'.
+#
+# 1997:
+# From perl5.003_22 the malloc bug has no impact any more. We can run
+# a perl without a special sbrk. Apparently Chip Salzenberg, the hero
+# of 5.004 anyway, earned another trophy during Australien Open.
+#
+# use the following two lines to enable USE_PERL_SBRK. Try this if you
+# encounter intermittent core dumps:
+#ccflags='-DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC'
+#usemymalloc='y'
+# use the following two lines if you have perl5.003_22 or better and
+# do not encounter intermittent core dumps.
+
+ccflags='-DUSE_NEXT_CTYPE'
+usemymalloc='n'
+
+######################################################################
+# End of the MALLOC story
+######################################################################
+
+ldflags='-u libsys_s'
+libswanted='dbm gdbm db'
+
+lddlflags='-nostdlib -r'
+# Give cccdlflags an empty value since Configure will detect we are
+# using GNU cc and try to specify -fpic for cccdlflags.
+cccdlflags=' '
+
+######################################################################
+# MAB support
+######################################################################
+# By default we will build for all architectures your development
+# environment supports. If you only want to build for the platform
+# you are on, simply comment or remove the line below.
+#
+# If you want to build for specific architectures, change the line
+# below to something like
+#
+# archs='m68k i386'
+#
+archs=`/bin/lipo -info /usr/lib/libm.a | sed -n 's/^[^:]*:[^:]*: //p'`
+
+#
+# leave the following part alone
+#
+archcount=`echo $archs |wc -w`
+if [ $archcount -gt 1 ]
+then
+ for d in $archs
+ do
+ mabflags="$mabflags -arch $d"
+ done
+ ccflags="$ccflags $mabflags"
+ ldflags="$ldflags $mabflags"
+ lddlflags="$lddlflags $mabflags"
+ archname='next-fat'
+fi
+######################################################################
+# END MAB support
+######################################################################
+ld='cc'
+
+i_utime='undef'
+groupstype='int'
+direntrytype='struct direct'
+d_strcoll='undef'
+d_uname='define'
+#
+# At least on m68k there are situations when memcmp doesn't behave
+# as expected. So we'll use perl's memcmp.
+#
+d_sanemcmp='undef'
+# setpgid() is in the posix library, but we don't use -posix, so
+# we don't see it. ext/POSIX/POSIX.xs *does* use -posix, so
+# setpgid is still available as POSIX::setpgid.
+# See ext/POSIX/POSIX/hints/next.pl.
+d_setpgid='undef'
+d_setsid='define'
+d_tcgetpgrp='define'
+d_tcsetpgrp='define'
+
+#
+# On some NeXT machines, the timestamp put by ranlib is not correct, and
+# this may cause useless recompiles. Fix that by adding a sleep before
+# running ranlib. The '5' is an empirical number that's "long enough."
+#
+ranlib='sleep 5; /bin/ranlib'
+
+#
+# There where reports that the compiler on HPPA machines
+# fails with the -O flag on pp.c.
+# Compiling pp.c with -O for HPPA machines results in a broken perl.
+# This is true whether we're on an HPPA machine or cross-compiling
+# for one.
+pp_cflags='optimize=""'
diff --git a/contrib/perl5/hints/next_3_0.sh b/contrib/perl5/hints/next_3_0.sh
new file mode 100644
index 000000000000..b8cc2c2d9052
--- /dev/null
+++ b/contrib/perl5/hints/next_3_0.sh
@@ -0,0 +1,53 @@
+# This file has been put together by Anno Siegel <siegel@zrz.TU-Berlin.DE>
+# and Andreas Koenig <k@franz.ww.TU-Berlin.DE>. Comments, questions, and
+# improvements welcome!
+
+# This file was modified to work on NS 3.0 by Kevin White
+# <klwhite@magnus.acs.ohio-state.edu>, based on suggestions by Andreas
+# Koenig and Andy Dougherty.
+
+echo With NS 3.0 you won\'t be able to use the POSIX module. >&4
+echo Be aware that some of the tests that are run during \"make test\" >&4
+echo will fail due to the lack of POSIX support on this system. >&4
+echo >&4
+echo Also, if you have the GDBM installed, make sure the header file >&4
+echo is located at a place on the system where the C compiler will >&4
+echo find it. By default, it is placed in /usr/local/include/gdbm.h. >&4
+echo It will not be found there. Try moving it to >&4
+echo /NextDeveloper/Headers/bsd/gdbm.h. >&4
+
+ccflags='-DUSE_NEXT_CTYPE -DNEXT30_NO_ATTRIBUTE'
+POSIX_cflags='ccflags="-posix $ccflags"'
+useposix='undef'
+ldflags='-u libsys_s'
+libswanted='dbm gdbm db'
+#
+lddlflags='-r'
+# Give cccdlflags an empty value since Configure will detect we are
+# using GNU cc and try to specify -fpic for cccdlflags.
+cccdlflags=' '
+#
+i_utime='undef'
+groupstype='int'
+direntrytype='struct direct'
+d_strcoll='undef'
+# the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails
+# with Larry's malloc on NS 3.2 due to broken sbrk()
+usemymalloc='n'
+d_uname='define'
+
+# Thanks to Etienne Grossman <etienne@isr.isr.ist.utl.pt> for sending
+# the correct values for perl5.003_11 for the following 4
+# variables. For older version all four were defined.
+d_setsid='undef'
+d_tcgetpgrp='undef'
+d_tcsetpgrp='undef'
+d_setpgid='undef'
+
+#
+# On some NeXT machines, the timestamp put by ranlib is not correct, and
+# this may cause useless recompiles. Fix that by adding a sleep before
+# running ranlib. The '5' is an empirical number that's "long enough."
+# (Thanks to Andreas Koenig <k@franz.ww.tu-berlin.de>)
+ranlib='sleep 5; /bin/ranlib'
+
diff --git a/contrib/perl5/hints/next_4.sh b/contrib/perl5/hints/next_4.sh
new file mode 100644
index 000000000000..b3887e612b0f
--- /dev/null
+++ b/contrib/perl5/hints/next_4.sh
@@ -0,0 +1,95 @@
+######################################################################
+#
+# IMPORTANT: before you run 'make', you need to enter one of these two
+# lines (depending on your shell):
+# DYLD_LIBRARY_PATH=`pwd`; export DYLD_LIBRARY_PATH
+# or
+# setenv DYLD_LIBRARY_PATH `pwd`
+#
+######################################################################
+
+# Posix support has been removed from NextStep
+#
+useposix='undef'
+
+libpth='/lib /usr/lib'
+libswanted=' '
+libc='/NextLibrary/Frameworks/System.framework/System'
+
+ldflags='-dynamic -prebind'
+lddlflags='-dynamic -bundle -undefined suppress'
+ccflags='-dynamic -fno-common -DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC'
+cccdlflags='none'
+ld='cc'
+#optimize='-g -O'
+
+######################################################################
+# MAB support
+######################################################################
+# By default we will build for all architectures your development
+# environment supports. If you only want to build for the platform
+# you are on, simply comment or remove the line below.
+#
+# If you want to build for specific architectures, change the line
+# below to something like
+#
+# archs='m68k i386'
+#
+archs=`/bin/lipo -info /usr/lib/libm.a | sed -n 's/^[^:]*:[^:]*: //p'`
+
+#
+# leave the following part alone
+#
+archcount=`echo $archs |wc -w`
+if [ $archcount -gt 1 ]
+then
+ for d in $archs
+ do
+ mabflags="$mabflags -arch $d"
+ done
+ ccflags="$ccflags $mabflags"
+ ldflags="$ldflags $mabflags"
+ lddlflags="$lddlflags $mabflags"
+fi
+######################################################################
+# END MAB support
+######################################################################
+
+useshprlib='true'
+dlext='bundle'
+so='dylib'
+
+#
+# The default prefix would be '/usr/local'. But since many people are
+# likely to have still 3.3 machines on their network, we do not want
+# to overwrite possibly existing 3.3 binaries.
+# You can use Configure -Dprefix=/foo/bar to override this, or simply
+# remove the lines below.
+#
+case "$prefix" in
+'') prefix='/usr/local/OPENSTEP' ;;
+esac
+
+archname='OPENSTEP-Mach'
+
+#
+# At least on m68k there are situations when memcmp doesn't behave
+# as expected. So we'll use perl's memcmp.
+#
+d_sanemcmp='undef'
+
+d_strcoll='undef'
+i_dbm='define'
+i_utime='undef'
+groupstype='int'
+direntrytype='struct direct'
+
+usemymalloc='y'
+clocktype='int'
+
+#
+# On some NeXT machines, the timestamp put by ranlib is not correct, and
+# this may cause useless recompiles. Fix that by adding a sleep before
+# running ranlib. The '5' is an empirical number that's "long enough."
+# (Thanks to Andreas Koenig <k@franz.ww.tu-berlin.de>)
+ranlib='sleep 5; /bin/ranlib'
diff --git a/contrib/perl5/hints/openbsd.sh b/contrib/perl5/hints/openbsd.sh
new file mode 100644
index 000000000000..4c98ec8587a8
--- /dev/null
+++ b/contrib/perl5/hints/openbsd.sh
@@ -0,0 +1,51 @@
+# hints/openbsd.sh
+#
+# hints file for OpenBSD; Todd Miller <millert@openbsd.org>
+# Edited to allow Configure command-line overrides by
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+#
+
+# OpenBSD has a better malloc than perl...
+test "$usemymalloc" || usemymalloc='n'
+
+# Currently, vfork(2) is not a real win over fork(2) but this will
+# change in a future release.
+usevfork='true'
+
+# setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS versions
+# in 4.4BSD. Configure will find these but they are just emulated
+# and do not have the same semantics as in 4.3BSD.
+d_setregid='undef'
+d_setreuid='undef'
+d_setrgid='undef'
+d_setruid='undef'
+
+#
+# Not all platforms support shared libs...
+#
+case `uname -m` in
+alpha|mips|powerpc|vax)
+ d_dlopen=$undef
+ ;;
+*)
+ d_dlopen=$define
+ d_dlerror=$define
+ # we use -fPIC here because -fpic is *NOT* enough for some of the
+ # extensions like Tk on some OpenBSD platforms (ie: sparc)
+ cccdlflags="-DPIC -fPIC $cccdlflags"
+ lddlflags="-Bforcearchive -Bshareable $lddlflags"
+ ;;
+esac
+
+# OpenBSD doesn't need libcrypt but many folks keep a stub lib
+# around for old NetBSD binaries.
+libswanted=`echo $libswanted | sed 's/ crypt / /'`
+
+# Configure can't figure this out non-interactively
+d_suidsafe='define'
+
+# cc is gcc so we can do better than -O
+# Allow a command-line override, such as -Doptimize=-g
+test "$optimize" || optimize='-O2'
+
+# end
diff --git a/contrib/perl5/hints/opus.sh b/contrib/perl5/hints/opus.sh
new file mode 100644
index 000000000000..da6fcc95b041
--- /dev/null
+++ b/contrib/perl5/hints/opus.sh
@@ -0,0 +1 @@
+ccflags="$ccflags -X18"
diff --git a/contrib/perl5/hints/os2.sh b/contrib/perl5/hints/os2.sh
new file mode 100644
index 000000000000..78d370a1e939
--- /dev/null
+++ b/contrib/perl5/hints/os2.sh
@@ -0,0 +1,302 @@
+#! /bin/sh
+# hints/os2.sh
+# This file reflects the tireless work of
+# Ilya Zakharevich <ilya@math.ohio-state.edu>
+#
+# Trimmed and comments added by
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Exactly what is required beyond a standard OS/2 installation?
+# (see in README.os2)
+
+# Note that symbol extraction code gives wrong answers (sometimes?) on
+# gethostent and setsid.
+
+# Optimization (GNU make 3.74 cannot be loaded :-():
+emxload -m 30 sh.exe ls.exe tr.exe id.exe sed.exe # make.exe
+emxload -m 30 grep.exe egrep.exe fgrep.exe cat.exe rm.exe mv.exe cp.exe
+emxload -m 30 uniq.exe basename.exe sort.exe awk.exe echo.exe
+
+path_sep=\;
+
+if test -f $sh.exe; then sh=$sh.exe; fi
+
+startsh="#!$sh"
+cc='gcc'
+
+# Make denser object files and DLL
+case "X$optimize" in
+ X)
+ optimize="-O2 -fomit-frame-pointer -malign-loops=2 -malign-jumps=2 -malign-functions=2 -s"
+ ld_dll_optimize="-s"
+ ;;
+esac
+
+# Get some standard things (indented to avoid putting in config.sh):
+ oifs="$IFS"
+ IFS=" ;"
+ set $MANPATH
+ tryman="$@"
+ set $LIBRARY_PATH
+ libemx="$@"
+ set $C_INCLUDE_PATH
+ usrinc="$@"
+ IFS="$oifs"
+ tryman="`./UU/loc . /man $tryman`"
+ tryman="`echo $tryman | tr '\\\' '/'`"
+
+ # indented to avoid having it *two* times at start
+ libemx="`./UU/loc os2.a /emx/lib $libemx`"
+
+usrinc="`./UU/loc stdlib.h /emx/include $usrinc`"
+usrinc="`dirname $usrinc | tr '\\\' '/'`"
+libemx="`dirname $libemx | tr '\\\' '/'`"
+
+if test -d $tryman/man1; then
+ sysman="$tryman/man1"
+else
+ sysman="`./UU/loc . /man/man1 c:/man/man1 c:/usr/man/man1 d:/man/man1 d:/usr/man/man1 e:/man/man1 e:/usr/man/man1 f:/man/man1 f:/usr/man/man1 g:/man/man1 g:/usr/man/man1 /usr/man/man1`"
+fi
+
+emxpath="`dirname $libemx`"
+if test ! -d "$emxpath"; then
+ emxpath="`./UU/loc . /emx c:/emx d:/emx e:/emx f:/emx g:/emx h:/emx /emx`"
+fi
+
+if test ! -d "$libemx"; then
+ libemx="$emxpath/lib"
+fi
+if test ! -d "$libemx"; then
+ if test -d "$LIBRARY_PATH"; then
+ libemx="$LIBRARY_PATH"
+ else
+ libemx="`./UU/loc . X c:/emx/lib d:/emx/lib e:/emx/lib f:/emx/lib g:/emx/lib h:/emx/lib /emx/lib`"
+ fi
+fi
+
+if test ! -d "$usrinc"; then
+ if test -d "$emxpath/include"; then
+ usrinc="$emxpath/include"
+ else
+ if test -d "$C_INCLUDE_PATH"; then
+ usrinc="$C_INCLUDE_PATH"
+ else
+ usrinc="`./UU/loc . X c:/emx/include d:/emx/include e:/emx/include f:/emx/include g:/emx/include h:/emx/include /emx/include`"
+ fi
+ fi
+fi
+
+rsx="`./UU/loc rsx.exe undef $pth`"
+
+if test "$libemx" = "X"; then echo "Cannot find C library!" >&2; fi
+
+# Acute backslashitis:
+libpth="`echo \"$LIBRARY_PATH\" | tr ';\\\' ' /'`"
+libpth="$libpth $libemx/mt $libemx"
+
+set `emxrev -f emxlibcm`
+emxcrtrev=$5
+
+so='dll'
+
+# Additional definitions:
+
+firstmakefile='GNUmakefile'
+exe_ext='.exe'
+
+# We provide it
+i_dlfcn='define'
+
+aout_d_shrplib='undef'
+aout_useshrplib='false'
+aout_obj_ext='.o'
+aout_lib_ext='.a'
+aout_ar='ar'
+aout_plibext='.a'
+aout_lddlflags="-Zdll $ld_dll_optimize"
+if [ $emxcrtrev -ge 50 ]; then
+ aout_ldflags='-Zexe -Zsmall-conv -Zstack 32000'
+else
+ aout_ldflags='-Zexe -Zstack 32000'
+fi
+
+# To get into config.sh:
+aout_ldflags="$aout_ldflags"
+
+aout_d_fork='define'
+aout_ccflags='-DPERL_CORE -DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I.'
+aout_cppflags='-DPERL_CORE -DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I.'
+aout_use_clib='c'
+aout_usedl='undef'
+aout_archobjs="os2.o dl_os2.o"
+
+# variable which have different values for aout compile
+used_aout='d_shrplib useshrplib plibext lib_ext obj_ext ar plibext d_fork lddlflags ldflags ccflags use_clib usedl archobjs cppflags'
+
+if [ "$emxaout" != "" ]; then
+ d_shrplib="$aout_d_shrplib"
+ useshrplib="$aout_useshrplib"
+ obj_ext="$aout_obj_ext"
+ lib_ext="$aout_lib_ext"
+ ar="$aout_ar"
+ plibext="$aout_plibext"
+ if [ $emxcrtrev -lt 50 ]; then
+ d_fork="$aout_d_fork"
+ fi
+ lddlflags="$aout_lddlflags"
+ ldflags="$aout_ldflags"
+ ccflags="$aout_ccflags"
+ cppflags="$aout_cppflags"
+ use_clib="$aout_use_clib"
+ usedl="$aout_usedl"
+else
+ d_shrplib='define'
+ useshrplib='true'
+ obj_ext='.obj'
+ lib_ext='.lib'
+ ar='emxomfar'
+ plibext='.lib'
+ if [ $emxcrtrev -ge 50 ]; then
+ d_fork='define'
+ else
+ d_fork='undef'
+ fi
+ lddlflags="-Zdll -Zomf -Zmt -Zcrtdll $ld_dll_optimize"
+ # Recursive regmatch may eat 2.5M of stack alone.
+ ldflags='-Zexe -Zomf -Zmt -Zcrtdll -Zstack 32000'
+ if [ $emxcrtrev -ge 50 ]; then
+ ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I.'
+ else
+ ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DEMX_BAD_SBRK'
+ fi
+ use_clib='c_import'
+ usedl='define'
+fi
+
+# indented to miss config.sh
+ _ar="$ar"
+
+# To get into config.sh (should start at the beginning of line)
+# or you can put it into config.over.
+plibext="$plibext"
+# plibext is not needed anymore. Just directly set $libperl.
+libperl="libperl${plibext}"
+
+#libc="/emx/lib/st/c_import$lib_ext"
+libc="$libemx/mt/$use_clib$lib_ext"
+
+if test -r "$libemx/c_alias$lib_ext"; then
+ libnames="$libemx/c_alias$lib_ext"
+fi
+# otherwise puts -lc ???
+
+# [Maybe we should just remove c from $libswanted ?]
+
+# Test would pick up wrong rand, so we hardwire the value for random()
+libs='-lsocket -lm -lbsd'
+randbits=31
+archobjs="os2$obj_ext dl_os2$obj_ext"
+
+# Run files without extension with sh:
+EXECSHELL=sh
+
+cccdlflags='-Zdll'
+dlsrc='dl_dlopen.xs'
+ld='gcc'
+
+#cppflags='-DDOSISH -DOS2=2 -DEMBED -I.'
+
+# for speedup: (some patches to ungetc are also needed):
+# Note that without this guy tests 8 and 10 of io/tell.t fail, with it 11 fails
+
+stdstdunder=`echo "#include <stdio.h>" | cpp | egrep -c "char +\* +_ptr"`
+d_stdstdio='define'
+d_stdiobase='define'
+d_stdio_ptr_lval='define'
+d_stdio_cnt_lval='define'
+
+if test "$stdstdunder" = 0; then
+ stdio_ptr='((fp)->ptr)'
+ stdio_cnt='((fp)->rcount)'
+ stdio_base='((fp)->buffer)'
+ stdio_bufsiz='((fp)->rcount + (fp)->ptr - (fp)->buffer)'
+ ccflags="$ccflags -DMYTTYNAME"
+ myttyname='define'
+else
+ stdio_ptr='((fp)->_ptr)'
+ stdio_cnt='((fp)->_rcount)'
+ stdio_base='((fp)->_buffer)'
+ stdio_bufsiz='((fp)->_rcount + (fp)->_ptr - (fp)->_buffer)'
+fi
+
+# to put into config.sh
+myttyname="$myttyname"
+
+# To have manpages installed
+nroff='nroff.cmd'
+# above will be overwritten otherwise, indented to avoid config.sh
+ _nroff='nroff.cmd'
+
+# should be handled automatically by Configure now.
+ln='cp'
+# Will be rewritten otherwise, indented to not put in config.sh
+ _ln='cp'
+lns='cp'
+
+nm_opt='-p'
+
+####### We define these functions ourselves
+
+d_getprior='define'
+d_setprior='define'
+
+if [ "X$usethreads" = "X$define" ]; then
+ ccflags="-Zmt $ccflags"
+ cppflags="-Zmt $cppflags" # Do we really need to set this?
+ aout_ccflags="-DUSE_THREADS $aout_ccflags"
+ aout_cppflags="-DUSE_THREADS $aout_cppflags"
+ aout_lddlflags="-Zmt $aout_lddlflags"
+ aout_ldflags="-Zmt $aout_ldflags"
+fi
+
+# The next two are commented. pdksh handles #!, extproc gives no path part.
+# sharpbang='extproc '
+# shsharp='false'
+
+# Commented:
+#startsh='extproc ksh\\n#! sh'
+
+# Copy pod:
+
+cp ./README.os2 ./pod/perlos2.pod
+
+# Now install the external modules. We are in the ./hints directory.
+
+cd ./os2/OS2
+
+if ! test -d ../../ext/OS2 ; then
+ mkdir ../../ext/OS2
+fi
+
+cp -rfu * ../../ext/OS2/
+
+# Install tests:
+
+for xxx in * ; do
+ if $test -d $xxx/t; then
+ cp -uf $xxx/t/*.t ../../t/lib
+ else
+ if $test -d $xxx; then
+ cd $xxx
+ for yyy in * ; do
+ if $test -d $yyy/t; then
+ cp -uf $yyy/t/*.t ../../t/lib
+ fi
+ done
+ cd ..
+ fi
+ fi
+done
+
+
+# Now go back
+cd ../..
diff --git a/contrib/perl5/hints/os390.sh b/contrib/perl5/hints/os390.sh
new file mode 100644
index 000000000000..1cf945dca394
--- /dev/null
+++ b/contrib/perl5/hints/os390.sh
@@ -0,0 +1,56 @@
+# hints/os390.sh
+#
+# OS/390 hints by David J. Fiander <davidf@mks.com>
+#
+# OS/390 OpenEdition Release 3 Mon Sep 22 1997 thanks to:
+#
+# John Pfuntner <pfuntner@vnet.ibm.com>
+# Len Johnson <lenjay@ibm.net>
+# Bud Huff <BAHUFF@us.oracle.com>
+# Peter Prymmer <pvhp@forte.com>
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Tim Bunce <Tim.Bunce@ig.co.uk>
+#
+# as well as the authors of the aix.sh file
+#
+
+# To get ANSI C, we need to use c89, and ld doesn't exist
+cc='c89'
+ld='c89'
+# c89 hides most of the useful header stuff, _ALL_SOURCE turns it on again,
+# YYDYNAMIC ensures that the OS/390 yacc generated parser is reentrant.
+# -DEBCDIC should come from Configure.
+ccflags='-DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -DYYDYNAMIC'
+# Turning on optimization breaks perl
+optimize='none'
+
+alignbytes=8
+
+usemymalloc='n'
+
+so='a'
+
+# On OS/390, libc.a doesn't really hold anything at all,
+# so running nm on it is pretty useless.
+usenm='n'
+
+# Dynamic loading doesn't work on OS/390 quite yet
+usedl='n'
+dlext='none'
+
+# Configure can't figure this out for some reason
+d_shmatprototype='define'
+
+usenm='false'
+i_time='define'
+i_systime='define'
+
+# (from aix.sh)
+# uname -m output is too specific and not appropriate here
+# osname should come from Configure
+#
+case "$archname" in
+'') archname="$osname" ;;
+esac
+
+archobjs=ebcdic.o
diff --git a/contrib/perl5/hints/powerux.sh b/contrib/perl5/hints/powerux.sh
new file mode 100644
index 000000000000..6d6bac02ed76
--- /dev/null
+++ b/contrib/perl5/hints/powerux.sh
@@ -0,0 +1,95 @@
+# Hints for the PowerUX operating system running on Concurrent (formerly
+# Harris) NightHawk machines. Written by Tom.Horsley@mail.ccur.com
+#
+# Note: The OS is fated to change names again to PowerMAX OS, but this
+# PowerUX file should still work (I wish marketing would make up their mind
+# about the name :-).
+#
+# This config uses dynamic linking and the Concurrent C compiler. It has
+# been tested on Power PC based 6000 series machines running PowerUX.
+
+# Internally at Concurrent, we use a source management tool which winds up
+# giving us read-only copies of source trees that are mostly symbolic links.
+# That upsets the perl build process when it tries to edit opcode.h and
+# embed.h or touch perly.c or perly.h, so turn those files into "real" files
+# when Configure runs. (If you already have "real" source files, this won't
+# do anything).
+#
+if [ -x /usr/local/mkreal ]
+then
+ for i in '.' '..'
+ do
+ for j in embed.h opcode.h perly.h perly.c
+ do
+ if [ -h $i/$j ]
+ then
+ ( cd $i ; /usr/local/mkreal $j ; chmod 666 $j )
+ fi
+ done
+ done
+fi
+
+# We DO NOT want -lmalloc or -lPW, we DO need -lgen to follow -lnsl, so
+# fixup libswanted to reflect that desire (also need -lresolv if you want
+# DNS name lookup to work, which seems desirable :-).
+#
+libswanted=`echo ' '$libswanted' ' | sed -e 's/ malloc / /' -e 's/ PW / /' -e 's/ nsl / nsl gen resolv /'`
+
+# We DO NOT want /usr/ucblib in glibpth
+#
+glibpth=`echo ' '$glibpth' ' | sed -e 's@ /usr/ucblib @ @'`
+
+# Yes, csh exists, but doesn't work worth beans, if perl tries to use it,
+# the glob test fails, so just pretend it isn't there...
+#
+d_csh='undef'
+
+# Need to use Concurrent cc for most of these options to be meaningful (if you
+# want to get this to work with gcc, you're on your own :-). Passing
+# -Bexport to the linker when linking perl is important because it leaves
+# the interpreter internal symbols visible to the shared libs that will be
+# loaded on demand (and will try to reference those symbols).
+#
+cc='/bin/cc'
+cccdlflags='-Zpic'
+ccdlflags='-Zlink=dynamic -Wl,-Bexport'
+lddlflags='-Zlink=so'
+
+# Configure sometime finds what it believes to be ndbm header files on the
+# system and imagines that we have the NDBM library, but we really don't.
+# There is something there that once resembled ndbm, but it is purely
+# for internal use in some tool and has been hacked beyond recognition
+# (or even function :-)
+#
+i_ndbm='undef'
+
+# There is a bug in memcmp (which I hope will be fixed soon) which sometimes
+# fails to provide the correct compare status (it is data dependant), so just
+# pretend there is no memcmp...
+#
+d_memcmp='undef'
+
+# Due to problems with dynamic linking (which I also hope will be fixed soon)
+# you can't build a libperl.so, the core has to be in the static part of the
+# perl executable.
+#
+useshrplib='false'
+
+# PowerMAX OS has support for a few different kinds of filesystems. The
+# newer "xfs" filesystem does *not* report a reasonable value in the
+# 'nlinks' field of stat() info for directories (in fact, it is always 1).
+# Since xfs is the only filesystem which supports partitions bigger than
+# 2gig and you can't hardly buy a disk that small anymore, xfs is coming in
+# to greater and greater use, so we pretty much have no choice but to
+# abandon all hope that number of links will mean anything.
+#
+dont_use_nlink=define
+
+# Misc other flags that might be able to change, but I know these work right.
+#
+d_suidsafe='define'
+d_isascii='define'
+d_mymalloc='undef'
+usemymalloc='n'
+ssizetype='ssize_t'
+usevfork='false'
diff --git a/contrib/perl5/hints/qnx.sh b/contrib/perl5/hints/qnx.sh
new file mode 100644
index 000000000000..b53a33d7370f
--- /dev/null
+++ b/contrib/perl5/hints/qnx.sh
@@ -0,0 +1,182 @@
+#----------------------------------------------------------------
+# QNX hints
+#
+# As of perl5.004_04, all tests pass under:
+# QNX 4.23A
+# Watcom 10.6 with Beta/970211.wcc.update.tar.F
+# socket3r.lib Nov21 1996.
+#
+# As with many unix ports, this one depends on a few "standard"
+# unix utilities which are not necessarily standard for QNX.
+#
+# /bin/sh This is used heavily by Configure and then by
+# perl itself. QNX's version is fine, but Configure
+# will choke on the 16-bit version, so if you are
+# running QNX 4.22, link /bin/sh to /bin32/ksh
+# ar This is the standard unix library builder.
+# We use wlib. With Watcom 10.6, when wlib is
+# linked as "ar", it behaves like ar and all is
+# fine. Under 9.5, a cover is required. One is
+# included in ../qnx
+# nm This is used (optionally) by configure to list
+# the contents of libraries. I will generate
+# a cover function on the fly in the UU directory.
+# cpp Configure and perl need a way to invoke a C
+# preprocessor. I have created a simple cover
+# for cc which does the right thing. Without this,
+# Configure will create it's own wrapper which works,
+# but it doesn't handle some of the command line arguments
+# that perl will throw at it.
+# make You really need GNU make to compile this. GNU make
+# ships by default with QNX 4.23, but you can get it
+# from quics for earlier versions.
+#----------------------------------------------------------------
+# Outstanding Issues:
+# lib/posix.t test fails on test 17 because acos(1) != 0.
+# Resolved in 970211 Beta
+# lib/io_udp.t test hangs because of a bug in getsockname().
+# Fixed in latest BETA socket3r.lib
+# There is currently no support for dynamically linked
+# libraries.
+#----------------------------------------------------------------
+# These hints were submitted by:
+# Norton T. Allen
+# Harvard University Atmospheric Research Project
+# allen@huarp.harvard.edu
+#
+# If you have suggestions or changes, please let me know.
+#----------------------------------------------------------------
+
+echo ""
+echo "Some tests may fail. Please read the hints/qnx.sh file."
+echo ""
+
+#----------------------------------------------------------------
+# At present, all QNX systems are equivalent architectures,
+# so it is reasonable to call archname=x86-qnx rather than
+# making an unnecessary distinction between AT-qnx and PCI-qnx,
+# for example.
+#----------------------------------------------------------------
+archname='x86-qnx'
+
+#----------------------------------------------------------------
+# QNX doesn't come with a csh and the ports of tcsh I've used
+# don't work reliably:
+#----------------------------------------------------------------
+csh=''
+d_csh='undef'
+full_csh=''
+
+#----------------------------------------------------------------
+# setuid scripts are secure under QNX.
+# (Basically, the same race conditions apply, but assuming
+# the scripts are located in a secure directory, the methods
+# for exploiting the race condition are defeated because
+# the loader expands the script name fully before executing
+# the interpreter.)
+#----------------------------------------------------------------
+d_suidsafe='define'
+
+#----------------------------------------------------------------
+# difftime is implemented as a preprocessor macro, so it doesn't show
+# up in the libraries:
+#----------------------------------------------------------------
+d_difftime='define'
+
+#----------------------------------------------------------------
+# strtod is in the math library, but we can't tell Configure
+# about the math library or it will confuse the linker
+#----------------------------------------------------------------
+d_strtod='define'
+
+lib_ext='3r.lib'
+libc='/usr/lib/clib3r.lib'
+
+#----------------------------------------------------------------
+# ccflags:
+# I like to turn the warnings up high, but a few common
+# constructs make a lot of noise, so I turn those warnings off.
+# A few still remain...
+#
+# HIDEMYMALLOC is necessary if using mymalloc since it is very
+# tricky (though not impossible) to totally replace the watcom
+# malloc/free set.
+#
+# unix.h is required as a general rule for unixy applications.
+#----------------------------------------------------------------
+ccflags='-DHIDEMYMALLOC -mf -w4 -Wc,-wcd=202 -Wc,-wcd=203 -Wc,-wcd=302 -Wc,-fi=unix.h'
+
+#----------------------------------------------------------------
+# ldflags:
+# If you want debugging information, you must specify -g on the
+# link as well as the compile. If optimize != -g, you should
+# remove this.
+#----------------------------------------------------------------
+ldflags="-g -N1M"
+
+so='none'
+selecttype='fd_set *'
+
+#----------------------------------------------------------------
+# Add -lunix to list of libs. This is needed mainly so the nm
+# search will find funcs in the unix lib. Including unix.h should
+# automatically include the library without -l.
+#----------------------------------------------------------------
+libswanted="$libswanted unix"
+
+if [ -z "`which ar 2>/dev/null`" ]; then
+ cat <<-'EOF' >&4
+ I don't see an 'ar', so I'm guessing you are running
+ Watcom 9.5 or earlier. You may want to install the ar
+ cover found in the qnx subdirectory of this distribution.
+ It might reasonably be placed in /usr/local/bin.
+
+ EOF
+fi
+#----------------------------------------------------------------
+# Here is a nm script which fixes up wlib's output to look
+# something like nm's, at least enough so that Configure can
+# use it.
+#----------------------------------------------------------------
+if [ -z "`which nm 2>/dev/null`" ]; then
+ cat <<-EOF
+ Creating a quick-and-dirty nm cover for Configure to use:
+
+ EOF
+ cat >./UU/nm <<-'EOF'
+ #! /bin/sh
+ #__USAGE
+ #%C <lib> [<lib> ...]
+ # Designed to mimic Unix's nm utility to list
+ # defined symbols in a library
+ unset WLIB
+ for i in $*; do wlib $i; done |
+ awk '
+ /^ / {
+ for (i = 1; i <= NF; i++) {
+ sub("_$", "", $i)
+ print "000000 T " $i
+ }
+ }'
+ EOF
+ chmod +x ./UU/nm
+fi
+
+cppstdin=`which cpp 2>/dev/null`
+if [ -n "$cppstdin" ]; then
+ cat <<-EOF >&4
+ I found a cpp at $cppstdin and will assume it is a good
+ thing to use. If this proves to be false, there is a
+ thin cover for cpp in the qnx subdirectory of this
+ distribution which you could move into your path.
+ EOF
+ cpprun="$cppstdin"
+else
+ cat <<-EOF >&4
+
+ There is a cpp cover in the qnx subdirectory of this
+ distribution which works a little better than the
+ Configure default. You may wish to copy it to
+ /usr/local/bin or some other suitable location.
+ EOF
+fi
diff --git a/contrib/perl5/hints/sco.sh b/contrib/perl5/hints/sco.sh
new file mode 100644
index 000000000000..cef1c0c94230
--- /dev/null
+++ b/contrib/perl5/hints/sco.sh
@@ -0,0 +1,140 @@
+# sco.sh
+# Courtesy of Joel Rosi-Schwartz <j.schwartz@agonet.it>
+
+# Additional SCO version info from
+# Peter Wolfe <wolfe@teloseng.com>
+# Last revised
+# Fri Jul 19 14:54:25 EDT 1996
+# by Andy Dougherty <doughera@lafcol.lafayette.edu>
+
+# To use gcc, use sh Configure -Dcc=gcc
+# But gcc will *not* do dynamic laoding on 3.2.5,
+# for that use sh Configure -Dcc=icc
+# See below for more details.
+
+# figure out what SCO version we are. The output of uname -X is
+# something like:
+# System = SCO_SV
+# Node = xxxxx
+# Release = 3.2v5.0.0
+# KernelID = 95/08/08
+# Machine = Pentium
+# BusType = ISA
+# Serial = xxxxx
+# Users = 5-user
+# OEM# = 0
+# Origin# = 1
+# NumCPU = 1
+
+# Use /bin/uname (because Gnu may be first on the path and
+# it does not support -X) to figure out what SCO version we are:
+case `/bin/uname -X | egrep '^Release'` in
+*3.2v4.*) scorls=3 ;; # I don't know why this is 3 instead of 4 :-)
+*3.2v5.*) scorls=5 ;;
+*) scorls=3 ;; # this probabaly shouldn't happen
+esac
+
+# Try to use libintl.a since it has strcoll and strxfrm
+libswanted="intl $libswanted"
+# Try to use libdbm.nfs.a since it has dbmclose.
+#
+if test -f /usr/lib/libdbm.nfs.a ; then
+ libswanted=`echo "dbm.nfs $libswanted " | sed -e 's/ dbm / /'`
+fi
+set X $libswanted
+shift
+libswanted="$*"
+
+# We don't want Xenix cross-development libraries
+glibpth=`echo $glibpth | sed -e 's! /usr/lib/386 ! !' -e 's! /lib/386 ! !'`
+xlibpth=''
+
+case "$cc" in
+*gcc*) ccflags="$ccflags -U M_XENIX"
+ optimize="$optimize -O2"
+ ;;
+scocc) ;;
+
+# On SCO 3.2v5 both cc and icc can build dynamic load, but cc core
+# dumps if optimised, so I am only setting this up for icc.
+# It is possible that some 3.2v4.2 system have icc, I seem to
+# recall it was available as a seperate product but I have no
+# knowledge if it can do dynamic loading and if so how.
+# Joel Rosi-Schwartz
+icc)# Apparently, SCO's cc gives rather verbose warnings
+ # Set -w0 to turn them off.
+ case $scorls in
+ 3) ccflags="$ccflags -W0 -quiet -U M_XENIX" ;;
+ 5) ccflags="$ccflags -belf -w0 -U M_XENIX"
+ optimize="-O1" # -g -O1 will not work
+ # optimize="-O0" may be needed for pack test to pass.
+ lddlflags='-G -L/usr/local/lib'
+ ldflags=' -W l,-Bexport -L/usr/local/lib'
+ dlext='so'
+ dlsrc='dl_dlopen.xs'
+ usedl='define'
+ ;;
+ esac
+ ;;
+
+*) # Apparently, miniperl core dumps if -O is used.
+ case "$optimize" in
+ '') optimize=none ;;
+ esac
+ # Apparently, SCO's cc gives rather verbose warnings
+ # Set -w0 to turn them off.
+ case $scorls in
+ 3) ccflags="$ccflags -W0 -quiet -U M_XENIX" ;;
+ 5) ccflags="$ccflags -w0 -U M_XENIX -DPERL_SCO5" ;;
+ esac
+ ;;
+esac
+i_varargs=undef
+
+# I have received one report that nm extraction doesn't work if you're
+# using the scocc compiler. This system had the following 'myconfig'
+# uname='xxx xxx 3.2 2 i386 '
+# cc='scocc', optimize='-O'
+usenm='false'
+
+# If you want to use nm, you'll probably have to use nm -p. The
+# following does that for you:
+nm_opt='-p'
+
+# I have received one report that you can't include utime.h in
+# pp_sys.c. Uncomment the following line if that happens to you:
+# i_utime=undef
+
+# Apparently, some versions of SCO include both .so and .a libraries,
+# but they don't mix as they do on other ELF systems. The upshot is
+# that Configure finds -ldl (libdl.so) but 'ld' complains it can't
+# find libdl.a.
+# I don't know which systems have this feature, so I'll just remove
+# -dl from libswanted for all SCO systems until someone can figure
+# out how to get dynamic loading working on SCO.
+#
+# The output of uname -X on one such system was
+# System = SCO_SV
+# Node = xxxxx
+# Release = 3.2v5.0.0
+# KernelID = 95/08/08
+# Machine = Pentium
+# BusType = ISA
+# Serial = xxxxx
+# Users = 5-user
+# OEM# = 0
+# Origin# = 1
+# NumCPU = 1
+#
+# The 5.0.0 on the Release= line is probably the thing to watch.
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Thu Feb 1 15:06:56 EST 1996
+libswanted=`echo " $libswanted " | sed -e 's/ dl / /'`
+set X $libswanted
+shift
+libswanted="$*"
+
+# Perl 5.003_05 and later try to include both <time.h> and <sys/select.h>
+# in pp_sys.c, but that fails due to a redefinition of struct timeval.
+# This will generate a WHOA THERE. Accept the default.
+i_sysselct=$undef
diff --git a/contrib/perl5/hints/sco_2_3_0.sh b/contrib/perl5/hints/sco_2_3_0.sh
new file mode 100644
index 000000000000..146363ab3d52
--- /dev/null
+++ b/contrib/perl5/hints/sco_2_3_0.sh
@@ -0,0 +1,2 @@
+yacc='/usr/bin/yacc -Sm25000'
+i_dirent=undef
diff --git a/contrib/perl5/hints/sco_2_3_1.sh b/contrib/perl5/hints/sco_2_3_1.sh
new file mode 100644
index 000000000000..146363ab3d52
--- /dev/null
+++ b/contrib/perl5/hints/sco_2_3_1.sh
@@ -0,0 +1,2 @@
+yacc='/usr/bin/yacc -Sm25000'
+i_dirent=undef
diff --git a/contrib/perl5/hints/sco_2_3_2.sh b/contrib/perl5/hints/sco_2_3_2.sh
new file mode 100644
index 000000000000..e113a4ec65ec
--- /dev/null
+++ b/contrib/perl5/hints/sco_2_3_2.sh
@@ -0,0 +1,2 @@
+yacc='/usr/bin/yacc -Sm25000'
+libswanted=`echo " $libswanted "| sed 's/ x / /'`
diff --git a/contrib/perl5/hints/sco_2_3_3.sh b/contrib/perl5/hints/sco_2_3_3.sh
new file mode 100644
index 000000000000..6d398fccf2e2
--- /dev/null
+++ b/contrib/perl5/hints/sco_2_3_3.sh
@@ -0,0 +1,3 @@
+yacc='/usr/bin/yacc -Sm25000'
+echo "NOTE: you may have problems due to a spurious semicolon on the strerror()" >&4
+echo "macro definition in /usr/include/string.h. If so, delete the semicolon." >&4
diff --git a/contrib/perl5/hints/sco_2_3_4.sh b/contrib/perl5/hints/sco_2_3_4.sh
new file mode 100644
index 000000000000..34bcadae5f5c
--- /dev/null
+++ b/contrib/perl5/hints/sco_2_3_4.sh
@@ -0,0 +1,5 @@
+yacc='/usr/bin/yacc -Sm25000'
+ccflags="$ccflags -UM_I86"
+usemymalloc='y'
+echo "NOTE: you may have problems due to a spurious semicolon on the strerror()" >&4
+echo "macro definition in /usr/include/string.h. If so, delete the semicolon." >&4
diff --git a/contrib/perl5/hints/solaris_2.sh b/contrib/perl5/hints/solaris_2.sh
new file mode 100644
index 000000000000..856f80103f9d
--- /dev/null
+++ b/contrib/perl5/hints/solaris_2.sh
@@ -0,0 +1,441 @@
+# hints/solaris_2.sh
+# Last modified: Wed May 27 13:04:45 EDT 1998
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Based on input from lots of folks, especially
+# Dean Roehrich <roehrich@ironwood-fddi.cray.com>
+
+# If perl fails tests that involve dynamic loading of extensions, and
+# you are using gcc, be sure that you are NOT using GNU as and ld. One
+# way to do that is to invoke Configure with
+#
+# sh Configure -Dcc='gcc -B/usr/ccs/bin/'
+#
+
+# See man vfork.
+usevfork=false
+
+d_suidsafe=define
+
+# Avoid all libraries in /usr/ucblib.
+set `echo $glibpth | sed -e 's@/usr/ucblib@@'`
+glibpth="$*"
+
+# Remove bad libraries. -lucb contains incompatible routines.
+# -lld doesn't do anything useful.
+# -lmalloc can cause a problem with GNU CC & Solaris. Specifically,
+# libmalloc.a may allocate memory that is only 4 byte aligned, but
+# GNU CC on the Sparc assumes that doubles are 8 byte aligned.
+# Thanks to Hallvard B. Furuseth <h.b.furuseth@usit.uio.no>
+set `echo " $libswanted " | sed -e 's@ ld @ @' -e 's@ malloc @ @' -e 's@ ucb @ @'`
+libswanted="$*"
+
+# Look for architecture name. We want to suggest a useful default.
+case "$archname" in
+'')
+ if test -f /usr/bin/arch; then
+ archname=`/usr/bin/arch`
+ archname="${archname}-${osname}"
+ elif test -f /usr/ucb/arch; then
+ archname=`/usr/ucb/arch`
+ archname="${archname}-${osname}"
+ fi
+ ;;
+esac
+
+######################################################
+# General sanity testing. See below for excerpts from the Solaris FAQ.
+
+# From roehrich@ironwood-fddi.cray.com Wed Sep 27 12:51:46 1995
+# Date: Thu, 7 Sep 1995 16:31:40 -0500
+# From: Dean Roehrich <roehrich@ironwood-fddi.cray.com>
+# To: perl5-porters@africa.nicoh.com
+# Subject: Re: On perl5/solaris/gcc
+
+# Here's another draft of the perl5/solaris/gcc sanity-checker.
+
+case `type ${cc:-cc}` in
+*/usr/ucb/cc*) cat <<END >&4
+
+NOTE: Some people have reported problems with /usr/ucb/cc.
+If you have difficulties, please make sure the directory
+containing your C compiler is before /usr/ucb in your PATH.
+
+END
+;;
+esac
+
+
+# Check that /dev/fd is mounted. If it is not mounted, let the
+# user know that suid scripts may not work.
+/usr/bin/df /dev/fd 2>&1 > /dev/null
+case $? in
+0) ;;
+*)
+ cat <<END >&4
+
+NOTE: Your system does not have /dev/fd mounted. If you want to
+be able to use set-uid scripts you must ask your system administrator
+to mount /dev/fd.
+
+END
+ ;;
+esac
+
+
+# See if libucb can be found in /usr/lib. If it is, warn the user
+# that this may cause problems while building Perl extensions.
+/usr/bin/ls /usr/lib/libucb* >/dev/null 2>&1
+case $? in
+0)
+ cat <<END >&4
+
+NOTE: libucb has been found in /usr/lib. libucb should reside in
+/usr/ucblib. You may have trouble while building Perl extensions.
+
+END
+;;
+esac
+
+# Use shell built-in 'type' command instead of /usr/bin/which to
+# avoid possible csh start-up problems and also to use the same shell
+# we'll be using to Configure and make perl.
+# The path name is the last field in the output, but the type command
+# has an annoying array of possible outputs, e.g.:
+# make is hashed (/opt/gnu/bin/make)
+# cc is /usr/ucb/cc
+# foo not found
+# use a command like type make | awk '{print $NF}' | sed 's/[()]//g'
+
+# See if make(1) is GNU make(1).
+# If it is, make sure the setgid bit is not set.
+make -v > make.vers 2>&1
+if grep GNU make.vers > /dev/null 2>&1; then
+ tmp=`type make | awk '{print $NF}' | sed 's/[()]//g'`
+ case "`/usr/bin/ls -lL $tmp`" in
+ ??????s*)
+ cat <<END >&2
+
+NOTE: Your PATH points to GNU make, and your GNU make has the set-group-id
+bit set. You must either rearrange your PATH to put /usr/ccs/bin before the
+GNU utilities or you must ask your system administrator to disable the
+set-group-id bit on GNU make.
+
+END
+ ;;
+ esac
+fi
+rm -f make.vers
+
+# XXX EXPERIMENTAL A.D. 2/27/1998
+# XXX This script UU/cc.cbu will get 'called-back' by Configure after it
+# XXX has prompted the user for the C compiler to use.
+cat > UU/cc.cbu <<'EOSH'
+# If the C compiler is gcc:
+# - check the fixed-includes
+# - check as(1) and ld(1), they should not be GNU
+# (GNU as and ld 2.8.1 and later are reportedly ok, however.)
+# If the C compiler is not gcc:
+# - check as(1) and ld(1), they should not be GNU
+# (GNU as and ld 2.8.1 and later are reportedly ok, however.)
+#
+# Watch out in case they have not set $cc.
+
+# Get gcc to share its secrets.
+echo 'main() { return 0; }' > try.c
+ # Indent to avoid propagation to config.sh
+ verbose=`${cc:-cc} -v -o try try.c 2>&1`
+
+if echo "$verbose" | grep '^Reading specs from' >/dev/null 2>&1; then
+ #
+ # Using gcc.
+ #
+ #echo Using gcc
+
+ tmp=`echo "$verbose" | grep '^Reading' |
+ awk '{print $NF}' | sed 's/specs$/include/'`
+
+ # Determine if the fixed-includes look like they'll work.
+ # Doesn't work anymore for gcc-2.7.2.
+
+ # See if as(1) is GNU as(1). GNU as(1) won't work for this job.
+ if echo "$verbose" | grep ' /usr/ccs/bin/as ' >/dev/null 2>&1; then
+ :
+ else
+ cat <<END >&2
+
+NOTE: You are using GNU as(1). GNU as(1) will not build Perl.
+I'm arranging to use /usr/ccs/bin/as by including -B/usr/ccs/bin/
+in your ${cc:-cc} command. (Note that the trailing "/" is required.)
+
+END
+ cc="${cc:-cc} -B/usr/ccs/bin/"
+ fi
+
+ # See if ld(1) is GNU ld(1). GNU ld(1) won't work for this job.
+ # Recompute $verbose since we may have just changed $cc.
+ verbose=`${cc:-cc} -v -o try try.c 2>&1 | grep ld 2>&1`
+ if echo "$verbose" | grep ' /usr/ccs/bin/ld ' >/dev/null 2>&1; then
+ :
+ else
+ # It's not /usr/ccs/bin/ld - but it might be egcs's ld wrapper,
+ # which calls /usr/ccs/bin/ld in turn. Passing -V to it will
+ # make it show its true colors.
+
+ myld=`echo $verbose| grep ld | awk '/\/ld/ {print $1}'`
+ # This assumes that gcc's output will not change, and that
+ # /full/path/to/ld will be the first word of the output.
+
+ # all Solaris versions of ld I've seen contain the magic
+ # string used in the grep below.
+ if $myld -V 2>&1 | grep "ld: Software Generation Utilities" >/dev/null 2>&1; then
+ cat <<END >&2
+
+Aha. You're using egcs and /usr/ccs/bin/ld.
+
+END
+
+ else
+ cat <<END >&2
+
+NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl.
+I'm arranging to use /usr/ccs/bin/ld by including -B/usr/ccs/bin/
+in your ${cc:-cc} command. (Note that the trailing "/" is required.)
+
+END
+ cc="${cc:-cc} -B/usr/ccs/bin/"
+ fi
+ fi
+
+else
+ #
+ # Not using gcc.
+ #
+ #echo Not using gcc
+
+ # See if as(1) is GNU as(1). GNU as(1) won't work for this job.
+ case `as --version < /dev/null 2>&1` in
+ *GNU*)
+ cat <<END >&2
+
+NOTE: You are using GNU as(1). GNU as(1) will not build Perl.
+You must arrange to use /usr/ccs/bin/as, perhaps by adding /usr/ccs/bin
+to the beginning of your PATH.
+
+END
+ ;;
+ esac
+
+ # See if ld(1) is GNU ld(1). GNU ld(1) won't work for this job.
+ # ld --version doesn't properly report itself as a GNU tool,
+ # as of ld version 2.6, so we need to be more strict. TWP 9/5/96
+ gnu_ld=false
+ case `ld --version < /dev/null 2>&1` in
+ *GNU*|ld\ version\ 2*)
+ gnu_ld=true ;;
+ *) ;;
+ esac
+ if $gnu_ld ; then :
+ else
+ # Try to guess from path
+ case `type ld | awk '{print $NF}'` in
+ *gnu*|*GNU*|*FSF*)
+ gnu_ld=true ;;
+ esac
+ fi
+ if $gnu_ld ; then
+ cat <<END >&2
+
+NOTE: You are apparently using GNU ld(1). GNU ld(1) will not build Perl.
+You must arrange to use /usr/ccs/bin/ld, perhaps by adding /usr/ccs/bin
+to the beginning of your PATH.
+
+END
+ fi
+
+fi
+
+# as --version or ld --version might dump core.
+rm -f try try.c
+rm -f core
+
+# XXX
+EOSH
+
+if [ "X$usethreads" = "X$define" ]; then
+ ccflags="-D_REENTRANT $ccflags"
+ # -lpthread needs to come before -lc but after other libraries such
+ # as -lgdbm and such like. We assume here that -lc is present in
+ # libswanted. If that fails to be true in future, then this can be
+ # changed to add pthread to the very end of libswanted.
+ # sched_yield is in -lposix4
+ set `echo X "$libswanted "| sed -e 's/ c / posix4 pthread c /'`
+ shift
+ libswanted="$*"
+
+ # On Solaris 2.6 x86 there is a bug with sigsetjmp() and siglongjmp()
+ # when linked with the threads library, such that whatever positive value
+ # you pass to siglongjmp(), sigsetjmp() returns 1.
+ # Thanks to Simon Parsons <S.Parsons@ftel.co.uk> for this report.
+ # Sun BugID is 4117946, "sigsetjmp always returns 1 when called by
+ # siglongjmp in a MT program". As of 19980622, there is no patch
+ # available.
+ cat >try.c <<'EOM'
+ /* Test for sig(set|long)jmp bug. */
+ #include <setjmp.h>
+
+ main()
+ {
+ sigjmp_buf env;
+ int ret;
+
+ ret = sigsetjmp(env, 1);
+ if (ret) { return ret == 2; }
+ siglongjmp(env, 2);
+ }
+EOM
+ if test "`arch`" = i86pc -a "$osvers" = 2.6 \
+ && ${cc:-cc} try.c -lpthread >/dev/null 2>&1 && ./a.out; then
+ d_sigsetjmp=$undef
+ cat << 'EOM' >&2
+
+You will see a *** WHOA THERE!!! *** message from Configure for
+d_sigsetjmp. Keep the recommended value. See hints/solaris_2.sh
+for more information.
+
+EOM
+ fi
+fi
+
+# This is just a trick to include some useful notes.
+cat > /dev/null <<'End_of_Solaris_Notes'
+
+Here are some notes kindly contributed by Dean Roehrich.
+
+-----
+Generic notes about building Perl5 on Solaris:
+- Use /usr/ccs/bin/make.
+- If you use GNU make, remove its setgid bit.
+- Remove all instances of *ucb* from your path.
+- Make sure libucb is not in /usr/lib (it should be in /usr/ucblib).
+- Do not use GNU as or GNU ld, or any of GNU binutils or GNU libc.
+- Do not use /usr/ucb/cc.
+- Do not change Configure's default answers, except for the path names.
+- Do not use -lmalloc.
+- Do not build on SunOS 4 and expect it to work properly on SunOS 5.
+- /dev/fd must be mounted if you want set-uid scripts to work.
+
+
+Here are the gcc-related questions and answers from the Solaris 2 FAQ. Note
+the themes:
+ - run fixincludes
+ - run fixincludes correctly
+ - don't use GNU as or GNU ld
+
+Question 5.7 covers the __builtin_va_alist problem people are always seeing.
+Question 6.1.3 covers the GNU as and GNU ld issues which are always biting
+people.
+Question 6.9 is for those who are still trying to compile Perl4.
+
+The latest Solaris 2 FAQ can be found in the following locations:
+ rtfm.mit.edu:/pub/usenet-by-group/comp.sys.sun.admin
+ ftp.fwi.uva.nl:/pub/solaris
+
+Perl5 comes with a script in the top-level directory called "myconfig" which
+will print a summary of the configuration in your config.sh. My summary for
+Solaris 2.4 and gcc 2.6.3 follows. I have also built with gcc 2.7.0 and the
+results are identical. This configuration was generated with Configure's -d
+option (take all defaults, don't bother prompting me). All tests pass for
+Perl5.001, patch.1m.
+
+Summary of my perl5 (patchlevel 1) configuration:
+ Platform:
+ osname=solaris, osver=2.4, archname=sun4-solaris
+ uname='sunos poplar 5.4 generic_101945-27 sun4d sparc '
+ hint=recommended
+ Compiler:
+ cc='gcc', optimize='-O', ld='gcc'
+ cppflags=''
+ ccflags =''
+ ldflags =''
+ stdchar='unsigned char', d_stdstdio=define, usevfork=false
+ voidflags=15, castflags=0, d_casti32=define, d_castneg=define
+ intsize=4, alignbytes=8, usemymalloc=y, randbits=15
+ Libraries:
+ so=so
+ libpth=/lib /usr/lib /usr/ccs/lib /usr/local/lib
+ libs=-lsocket -lnsl -ldl -lm -lc -lcrypt
+ libc=/usr/lib/libc.so
+ Dynamic Linking:
+ dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef
+ cccdlflags='-fpic', ccdlflags=' ', lddlflags='-G'
+
+
+Dean
+roehrich@cray.com
+9/7/95
+
+-----------
+
+From: Casper.Dik@Holland.Sun.COM (Casper H.S. Dik - Network Security Engineer)
+Subject: Solaris 2 Frequently Asked Questions (FAQ) 1.48
+Date: 25 Jul 1995 12:20:18 GMT
+
+5.7) Why do I get __builtin_va_alist or __builtin_va_arg_incr undefined?
+
+ You're using gcc without properly installing the gcc fixed
+ include files. Or you ran fixincludes after installing gcc
+ w/o moving the gcc supplied varargs.h and stdarg.h files
+ out of the way and moving them back again later. This often
+ happens when people install gcc from a binary distribution.
+ If there's a tmp directory in gcc's include directory, fixincludes
+ didn't complete. You should have run "just-fixinc" instead.
+
+ Another possible cause is using ``gcc -I/usr/include.''
+
+6.1) Where is the C compiler or where can I get one?
+
+ [...]
+
+ 3) Gcc.
+
+ Gcc is available from the GNU archives in source and binary
+ form. Look in a directory called sparc-sun-solaris2 for
+ binaries. You need gcc 2.3.3 or later. You should not use
+ GNU as or GNU ld. Make sure you run just-fixinc if you use
+ a binary distribution. Better is to get a binary version and
+ use that to bootstrap gcc from source.
+
+ [...]
+
+ When you install gcc, don't make the mistake of installing
+ GNU binutils or GNU libc, they are not as capable as their
+ counterparts you get with Solaris 2.x.
+
+6.9) I can't get perl 4.036 to compile or run.
+
+ Run Configure, and use the solaris_2_0 hints, *don't* use
+ the solaris_2_1 hints and don't use the config.sh you may
+ already have. First you must make sure Configure and make
+ don't find /usr/ucb/cc. (It must use gcc or the native C
+ compiler: /opt/SUNWspro/bin/cc)
+
+ Some questions need a special answer.
+
+ Are your system (especially dbm) libraries compiled with gcc? [y] y
+
+ yes: gcc 2.3.3 or later uses the standard calling
+ conventions, same as Sun's C.
+
+ Any additional cc flags? [ -traditional -Dvolatile=__volatile__
+ -I/usr/ucbinclude] -traditional -Dvolatile=__volatile__
+ Remove /usr/ucbinclude.
+
+ Any additional libraries? [-lsocket -lnsl -ldbm -lmalloc -lm
+ -lucb] -lsocket -lnsl -lm
+
+ Don't include -ldbm, -lmalloc and -lucb.
+
+ Perl 5 compiled out of the box.
+
+End_of_Solaris_Notes
+
diff --git a/contrib/perl5/hints/stellar.sh b/contrib/perl5/hints/stellar.sh
new file mode 100644
index 000000000000..23e15e909123
--- /dev/null
+++ b/contrib/perl5/hints/stellar.sh
@@ -0,0 +1,2 @@
+optimize="-O0"
+ccflags="$ccflags -nw"
diff --git a/contrib/perl5/hints/sunos_4_0.sh b/contrib/perl5/hints/sunos_4_0.sh
new file mode 100644
index 000000000000..56a87bf5be3c
--- /dev/null
+++ b/contrib/perl5/hints/sunos_4_0.sh
@@ -0,0 +1,2 @@
+ccflags="$ccflags -DFPUTS_BOTCH"
+i_unistd=$undef
diff --git a/contrib/perl5/hints/sunos_4_1.sh b/contrib/perl5/hints/sunos_4_1.sh
new file mode 100644
index 000000000000..4585d793d76c
--- /dev/null
+++ b/contrib/perl5/hints/sunos_4_1.sh
@@ -0,0 +1,72 @@
+# hints/sunos_4_1.sh
+# Last modified: Wed May 27 11:00:02 EDT 1998
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+
+case "$cc" in
+*gcc*) usevfork=false
+ # GNU as and GNU ld might not work. See the INSTALL file.
+ ;;
+*) usevfork=true ;;
+esac
+
+# Configure will issue a WHOA warning. The problem is that
+# Configure finds getzname, not tzname. If you're in the System V
+# environment, you can set d_tzname='define' since tzname[] is
+# available in the System V environment.
+d_tzname='undef'
+
+# Configure will issue a WHOA warning. The problem is that unistd.h
+# contains incorrect prototypes for some functions in the usual
+# BSD-ish environment. In particular, it has
+# extern int getgroups(/* int gidsetsize, gid_t grouplist[] */);
+# but groupslist[] ought to be of type int, not gid_t.
+# This is only really a problem for perl if the
+# user is using gcc, and not running in the SysV environment.
+# The gcc fix-includes script exposes those incorrect prototypes.
+# There may be other examples as well. Volunteers are welcome to
+# track them all down :-). In the meantime, we'll just skip unistd.h
+# for SunOS in most of the code. (However, see ext/POSIX/hints/sunos_4.pl.)
+i_unistd='undef'
+
+cat << 'EOM' >&4
+
+You will probably see *** WHOA THERE!!! *** messages from Configure for
+d_tzname and i_unistd. Keep the recommended values. See
+hints/sunos_4_1.sh for more information.
+EOM
+
+# The correct setting of groupstype depends on which version of the C
+# library is used. If you are in the 'System V environment'
+# (i.e. you have /usr/5bin ahead of /usr/bin in your PATH), and
+# you use Sun's cc compiler, then you'll pick up /usr/5bin/cc, which
+# links against the C library in /usr/5lib. This library has
+# groupstype='gid_t'.
+# If you are in the normal BSDish environment, then you'll pick up
+# /usr/ucb/cc, which links against the C library in /usr/lib. That
+# library has groupstype='int'.
+#
+# If you are using gcc, it links against the C library in /usr/lib
+# independent of whether or not you are in the 'System V environment'.
+# If you want to use the System V libraries, then you need to
+# manually set groupstype='gid_t' and add explicit references to
+# /usr/5lib when Configure prompts you for where to look for libraries.
+#
+# Check if user is in a bsd or system 5 type environment
+if cat -b /dev/null 2>/dev/null
+then # bsd
+ groupstype='int'
+else # sys5
+ case "$cc" in
+ *gcc*) groupstype='int';; # gcc doesn't do anything special
+ *) groupstype='gid_t';; # /usr/5bin/cc pulls in /usr/5lib/ stuff.
+ esac
+fi
+
+# If you get the message "unresolved symbol '__lib_version' " while
+# linking, your system probably has the optional 'acc' compiler (and
+# libraries) installed, but you are using the bundled 'cc' compiler with
+# the unbundled libraries. The solution is either to use 'acc' and the
+# unbundled libraries (specifically /lib/libm.a), or 'cc' and the bundled
+# library.
+#
+# Thanks to William Setzer <William_Setzer@ncsu.edu> for this info.
diff --git a/contrib/perl5/hints/svr4.sh b/contrib/perl5/hints/svr4.sh
new file mode 100644
index 000000000000..cf6906dac78c
--- /dev/null
+++ b/contrib/perl5/hints/svr4.sh
@@ -0,0 +1,153 @@
+# svr4 hints, System V Release 4.x
+# Last modified 1996/10/25 by Tye McQueen, tye@metronet.com
+# Merged 1998/04/23 with perl5.004_04 distribution by
+# Andy Dougherty <doughera@lafayette.edu>
+
+# Use Configure -Dcc=gcc to use gcc.
+case "$cc" in
+'') cc='/bin/cc'
+ test -f $cc || cc='/usr/ccs/bin/cc'
+ ;;
+esac
+
+# We include support for using libraries in /usr/ucblib, but the setting
+# of libswanted excludes some libraries found there. If you run into
+# problems, you may have to remove "ucb" from libswanted. Just delete
+# the comment '#' from the sed command below.
+ldflags='-L/usr/ccs/lib -L/usr/ucblib'
+ccflags='-I/usr/include -I/usr/ucbinclude'
+# Don't use problematic libraries:
+libswanted=`echo " $libswanted " | sed -e 's/ malloc / /'` # -e 's/ ucb / /'`
+# libmalloc.a - Probably using Perl's malloc() anyway.
+# libucb.a - Remove it if you have problems ld'ing. We include it because
+# it is needed for ODBM_File and NDBM_File extensions.
+
+if [ -r /usr/ucblib/libucb.a ]; then # If using BSD-compat. library:
+ d_Gconvert='gcvt((x),(n),(b))' # Try gcvt() before gconvert().
+ # Use the "native" counterparts, not the BSD emulation stuff:
+ d_bcmp='undef' d_bcopy='undef' d_bzero='undef' d_safebcpy='undef'
+ d_index='undef' d_killpg='undef' d_getprior='undef' d_setprior='undef'
+ d_setlinebuf='undef'
+ # d_setregid='undef' d_setreuid='undef' # ???
+fi
+
+# UnixWare has /usr/lib/libc.so.1, /usr/lib/libc.so.1.1, and
+# /usr/ccs/lib/libc.so. Configure chooses libc.so.1.1 while it
+# appears that /usr/ccs/lib/libc.so contains more symbols:
+#
+# Try the following if you want to use nm-extraction. We'll just
+# skip the nm-extraction phase, since searching for all the different
+# library versions will be hard to keep up-to-date.
+#
+# if [ "" = "$libc" -a -f /usr/ccs/lib/libc.so -a \
+# -f /usr/lib/libc.so.1 -a -f /usr/lib/libc.so.1.1 ]; then
+# if nm -h /usr/ccs/lib/libc.so | egrep '\<_?select$' >/dev/null; then
+# if nm -h /usr/lib/libc.so.1 | egrep '\<_?select$'` >/dev/null ||
+# nm -h /usr/lib/libc.so.1.1 | egrep '\<_?select$'` >/dev/null; then
+# :
+# else
+# libc=/usr/ccs/lib/libc.so
+# fi
+# fi
+# fi
+#
+# Don't bother with nm. Just compile & link a small C program.
+case "$usenm" in
+'') usenm=false;;
+esac
+
+# Broken C-Shell tests (Thanks to Tye McQueen):
+# The OS-specific checks may be obsoleted by the this generic test.
+ sh_cnt=`sh -c 'echo /*' | wc -c`
+ csh_cnt=`csh -f -c 'glob /*' 2>/dev/null | wc -c`
+ csh_cnt=`expr 1 + $csh_cnt`
+if [ "$sh_cnt" -ne "$csh_cnt" ]; then
+ echo "You're csh has a broken 'glob', disabling..." >&2
+ d_csh='undef'
+fi
+
+# Unixware-specific problems. The undocumented -X argument to uname
+# is probably a reasonable way of detecting UnixWare.
+# UnixWare has a broken csh. (This might already be detected above).
+# In Unixware 2.1.1 the fields in FILE* got renamed!
+# Unixware 1.1 can't cast large floats to 32-bit ints.
+# Configure can't detect memcpy or memset on Unixware 2 or 7
+#
+# Leave leading tabs on the next two lines so Configure doesn't
+# propagate these variables to config.sh
+ uw_ver=`uname -v`
+ uw_isuw=`uname -X 2>&1 | grep Release`
+
+if [ "$uw_isuw" = "Release = 4.2" ]; then
+ case $uw_ver in
+ 1.1)
+ d_casti32='undef'
+ ;;
+ esac
+fi
+if [ "$uw_isuw" = "Release = 4.2MP" ]; then
+ case $uw_ver in
+ 2.1)
+ d_csh='undef'
+ d_memcpy='define'
+ d_memset='define'
+ ;;
+ 2.1.*)
+ d_csh='undef'
+ d_memcpy='define'
+ d_memset='define'
+ stdio_cnt='((fp)->__cnt)'
+ d_stdio_cnt_lval='define'
+ stdio_ptr='((fp)->__ptr)'
+ d_stdio_ptr_lval='define'
+ ;;
+ esac
+fi
+if [ "$uw_isuw" = "Release = 5" ]; then
+ case $uw_ver in
+ 7)
+ d_csh='undef'
+ d_memcpy='define'
+ d_memset='define'
+ stdio_cnt='((fp)->__cnt)'
+ d_stdio_cnt_lval='define'
+ stdio_ptr='((fp)->__ptr)'
+ d_stdio_ptr_lval='define'
+ ;;
+ esac
+fi
+# End of Unixware-specific tests.
+
+# DDE SMES Supermax Enterprise Server
+case "`uname -sm`" in
+"UNIX_SV SMES")
+ # the *grent functions are in libgen.
+ libswanted="$libswanted gen"
+ # csh is broken (also) in SMES
+ # This may already be detected by the generic test above.
+ d_csh='undef'
+ case "$cc" in
+ *gcc*) ;;
+ *) # for cc we need -K PIC (not -K pic)
+ cccdlflags="$cccdlflags -K PIC"
+ ;;
+ esac
+ ;;
+esac
+
+# Configure may fail to find lstat() since it's a static/inline function
+# in <sys/stat.h> on Unisys U6000 SVR4, UnixWare 2.x, and possibly other
+# SVR4 derivatives. (Though UnixWare has it in /usr/ccs/lib/libc.so.)
+d_lstat=define
+
+d_suidsafe='define' # "./Configure -d" can't figure this out easilly
+
+cat <<'EOM' >&4
+
+If you wish to use dynamic linking, you must use
+ LD_LIBRARY_PATH=`pwd`; export LD_LIBRARY_PATH
+or
+ setenv LD_LIBRARY_PATH `pwd`
+before running make.
+
+EOM
diff --git a/contrib/perl5/hints/ti1500.sh b/contrib/perl5/hints/ti1500.sh
new file mode 100644
index 000000000000..69482d86802d
--- /dev/null
+++ b/contrib/perl5/hints/ti1500.sh
@@ -0,0 +1 @@
+usemymalloc='n'
diff --git a/contrib/perl5/hints/titanos.sh b/contrib/perl5/hints/titanos.sh
new file mode 100644
index 000000000000..cea99f82a3a2
--- /dev/null
+++ b/contrib/perl5/hints/titanos.sh
@@ -0,0 +1,39 @@
+# Hints file (perl 4.019) for Kubota Pacific's Titan 3000 Series Machines.
+# Created by: JT McDuffie (jt@kpc.com) 26 DEC 1991
+# p5ed by: Jarkko Hietaniemi <jhi@iki.fi> Aug 27 1994
+# NOTE: You should run Configure with tcsh (yes, tcsh).
+# Comments by Andy Dougherty <doughera@lafcol.lafayette.edu> 28 Mar 1995
+alignbytes="8"
+byteorder="4321"
+castflags='0'
+gidtype='ushort'
+groupstype='unsigned short'
+intsize='4'
+usenm='true'
+nm_opt='-eh'
+malloctype='void *'
+models='none'
+ccflags="$ccflags -I/usr/include/net -DDEBUGGING -DSTANDARD_C"
+cppflags="$cppflags -I/usr/include/net -DDEBUGGING -DSTANDARD_C"
+stdchar='unsigned char'
+#
+# Apparently there are some harmful libs in Configure's $libswanted.
+# Perl5.000 had: libs='-lnsl -ldbm -lPW -lmalloc -lm'
+# Unfortunately, this line prevents users from including things like
+# -lgdbm and -ldb, which they may or may not have or want.
+# We should probably fiddle with libswanted instead of libs.
+# And even there, we should only bother to delete harmful libraries.
+# However, I don't know what they are or why they should be deleted,
+# so this will have to do for now. --AD 28 Mar 1995
+libswanted='sfio nsl dbm gdbm db PW malloc m'
+#
+# Extensions: This system can not compile POSIX. We'll let Configure
+# figure out the others.
+useposix='n'
+#
+uidtype='ushort'
+voidflags='7'
+inclwanted='/usr/include /usr/include/net'
+# Setting libpth shouldn't be needed any more.
+# libpth='/usr/lib /usr/local/lib /lib'
+pth='. /bin /usr/bin /usr/ucb /usr/local/bin /usr/X11/bin /usr/lbin /etc /usr/lib'
diff --git a/contrib/perl5/hints/ultrix_4.sh b/contrib/perl5/hints/ultrix_4.sh
new file mode 100644
index 000000000000..d8d2063b22d6
--- /dev/null
+++ b/contrib/perl5/hints/ultrix_4.sh
@@ -0,0 +1,66 @@
+# hints/ultrix_4.sh
+# Last updated by Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Fri Feb 10 10:04:51 EST 1995
+#
+# Use Configure -Dcc=gcc to use gcc.
+#
+# This used to use -g, but that pulls in -DDEBUGGING by default.
+case "$optimize" in
+'')
+ # recent versions have a working compiler.
+ case "$osvers" in
+ *4.[45]*) optimize='-O2' ;;
+ *) optimize='none' ;;
+ esac
+ ;;
+esac
+
+# Some users have reported Configure runs *much* faster if you
+# replace all occurences of /bin/sh by /bin/sh5
+# Something like:
+# sed 's!/bin/sh!/bin/sh5!g' Configure > Configure.sh5
+# Then run "sh5 Configure.sh5 [your options]"
+
+case "$myuname" in
+*risc*) cat <<EOF >&4
+Note that there is a bug in some versions of NFS on the DECStation that
+may cause utime() to work incorrectly. If so, regression test io/fs
+may fail if run under NFS. Ignore the failure.
+EOF
+esac
+
+# Compiler flags that depend on osversion:
+case "$cc" in
+*gcc*) ;;
+*)
+ case "$osvers" in
+ *4.1*) ccflags="$ccflags -DLANGUAGE_C -Olimit 3200" ;;
+ *4.2*) ccflags="$ccflags -DLANGUAGE_C -Olimit 3200"
+ # Prototypes sometimes cause compilation errors in 4.2.
+ prototype=undef
+ case "$myuname" in
+ *risc*) d_volatile=undef ;;
+ esac
+ ;;
+ *4.3*) ccflags="$ccflags -std1 -DLANGUAGE_C -Olimit 3200" ;;
+ *) ccflags="$ccflags -std -Olimit 3200" ;;
+ esac
+ ;;
+esac
+
+# Other settings that depend on $osvers:
+case "$osvers" in
+*4.1*) ;;
+*4.2*) libswanted=`echo $libswanted | sed 's/ malloc / /'` ;;
+*4.3*) ;;
+*) ranlib='ranlib' ;;
+esac
+
+# Settings that don't depend on $osvers:
+
+util_cflags='ccflags="$ccflags -DLOCALE_ENVIRON_REQUIRED"'
+groupstype='int'
+# This will cause a WHOA THERE warning, but it's accurate. The
+# configure test should be beefed up to try using the field when
+# it can't find any of the standardly-named fields.
+d_dirnamlen='define'
diff --git a/contrib/perl5/hints/umips.sh b/contrib/perl5/hints/umips.sh
new file mode 100644
index 000000000000..17d5ff46239b
--- /dev/null
+++ b/contrib/perl5/hints/umips.sh
@@ -0,0 +1,39 @@
+# hints/umips.sh
+#
+# Mips R3030 / Bruker AspectSation running RISC/os (UMIPS) 4.52
+# compiling with gcc 2.7.2
+#
+# Created Sat Aug 17 00:17:15 MET DST 1996
+# by Guenter Schmidt <gsc@bruker.de>
+#
+# uname -a output looks like this:
+# xxx xxx 4_52 umips mips
+
+# Speculative notes on getting cc to work added by
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Tue Aug 20 21:51:49 EDT 1996
+
+# Recommend the GNU C Compiler
+case "$cc" in
+'') echo 'gcc 2.7.2 (or later) is recommended. Use Configure -Dcc=gcc' >&4
+ # The test with the native compiler not succeed:
+ # `sh cflags libperl.a miniperlmain.o` miniperlmain.c
+ # CCCMD = cc -c -I/usr/local/include -I/usr/include/bsd -DLANGUAGE_C -O
+ # ccom: Error: ./mg.h, line 12: redeclaration of formal parameter, sv
+ # int (*svt_set) (SV *sv, MAGIC* mg);
+ # ------------------------------------------^
+ # ccom: Error: ./mg.h, line 12: redeclaration of formal parameter, mg
+ # This is probably a result of incomplete prototype support.
+ prototype=undef
+ ;;
+esac
+
+# POSIX support in RiscOS is not useable
+useposix='false'
+
+# Will give WHOA message, but the prototype are defined in the GCC inc dirs
+case "$cc" in
+*gcc*) d_shmatprototype='define' ;;
+esac
+
+glibpth="$glibpth /usr/lib/cmplrs/cc"
diff --git a/contrib/perl5/hints/unicos.sh b/contrib/perl5/hints/unicos.sh
new file mode 100644
index 000000000000..ab0203bec618
--- /dev/null
+++ b/contrib/perl5/hints/unicos.sh
@@ -0,0 +1,16 @@
+case `uname -r` in
+6.1*) shellflags="-m+65536" ;;
+esac
+case "$optimize" in
+'') optimize="-O1" ;;
+esac
+d_setregid='undef'
+d_setreuid='undef'
+case "$usemymalloc" in
+'') # The perl malloc.c SHOULD work says Ilya.
+ # But for the time being (5.004_68), alas, it doesn't.
+ # usemymalloc='y'
+ # ccflags="$ccflags -DNO_RCHECK"
+ usemymalloc='n'
+ ;;
+esac
diff --git a/contrib/perl5/hints/unicosmk.sh b/contrib/perl5/hints/unicosmk.sh
new file mode 100644
index 000000000000..f0b63cb0ebec
--- /dev/null
+++ b/contrib/perl5/hints/unicosmk.sh
@@ -0,0 +1,10 @@
+case "$optimize" in
+'') optimize="-O1" ;;
+esac
+d_setregid='undef'
+d_setreuid='undef'
+case "$usemymalloc" in
+'') usemymalloc='y'
+ ccflags="$ccflags -DNO_RCHECK"
+ ;;
+esac
diff --git a/contrib/perl5/hints/unisysdynix.sh b/contrib/perl5/hints/unisysdynix.sh
new file mode 100644
index 000000000000..4251ba8d4711
--- /dev/null
+++ b/contrib/perl5/hints/unisysdynix.sh
@@ -0,0 +1 @@
+d_waitpid=undef
diff --git a/contrib/perl5/hints/utekv.sh b/contrib/perl5/hints/utekv.sh
new file mode 100644
index 000000000000..95a31fdedfe9
--- /dev/null
+++ b/contrib/perl5/hints/utekv.sh
@@ -0,0 +1,12 @@
+# XD88/10 UTekV hints by Kaveh Ghazi (ghazi@caip.rutgers.edu) 2/11/92
+# Modified by Andy Dougherty <doughera@lafcol.lafayette.edu> 4 Oct. 1994
+
+# The -X18 is only if you are using the Greenhills compiler.
+ccflags="$ccflags -X18"
+
+usemymalloc='y'
+
+echo " " >&4
+echo "NOTE: You may have to take out makefile dependencies on the files in" >&4
+echo "/usr/include (i.e. /usr/include/ctype.h) or the make will fail. A" >&4
+echo "simple 'grep -v /usr/include/ makefile' should suffice." >&4
diff --git a/contrib/perl5/hints/uts.sh b/contrib/perl5/hints/uts.sh
new file mode 100644
index 000000000000..9ad72d7e9870
--- /dev/null
+++ b/contrib/perl5/hints/uts.sh
@@ -0,0 +1,2 @@
+ccflags="$ccflags -DCRIPPLED_CC"
+d_lstat=define
diff --git a/contrib/perl5/hv.c b/contrib/perl5/hv.c
new file mode 100644
index 000000000000..40bb9b8e73d6
--- /dev/null
+++ b/contrib/perl5/hv.c
@@ -0,0 +1,1226 @@
+/* hv.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "I sit beside the fire and think of all that I have seen." --Bilbo
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+static void hv_magic_check _((HV *hv, bool *needs_copy, bool *needs_store));
+#ifndef PERL_OBJECT
+static void hsplit _((HV *hv));
+static void hfreeentries _((HV *hv));
+static HE* more_he _((void));
+#endif
+
+#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
+# define ARRAY_ALLOC_BYTES(size) ( (size)*sizeof(HE*) )
+#else
+# define MALLOC_OVERHEAD 16
+# define ARRAY_ALLOC_BYTES(size) ( (size)*sizeof(HE*)*2 - MALLOC_OVERHEAD )
+#endif
+
+STATIC HE*
+new_he(void)
+{
+ HE* he;
+ if (PL_he_root) {
+ he = PL_he_root;
+ PL_he_root = HeNEXT(he);
+ return he;
+ }
+ return more_he();
+}
+
+STATIC void
+del_he(HE *p)
+{
+ HeNEXT(p) = (HE*)PL_he_root;
+ PL_he_root = p;
+}
+
+STATIC HE*
+more_he(void)
+{
+ register HE* he;
+ register HE* heend;
+ New(54, PL_he_root, 1008/sizeof(HE), HE);
+ he = PL_he_root;
+ heend = &he[1008 / sizeof(HE) - 1];
+ while (he < heend) {
+ HeNEXT(he) = (HE*)(he + 1);
+ he++;
+ }
+ HeNEXT(he) = 0;
+ return new_he();
+}
+
+STATIC HEK *
+save_hek(char *str, I32 len, U32 hash)
+{
+ char *k;
+ register HEK *hek;
+
+ New(54, k, HEK_BASESIZE + len + 1, char);
+ hek = (HEK*)k;
+ Copy(str, HEK_KEY(hek), len, char);
+ *(HEK_KEY(hek) + len) = '\0';
+ HEK_LEN(hek) = len;
+ HEK_HASH(hek) = hash;
+ return hek;
+}
+
+void
+unshare_hek(HEK *hek)
+{
+ unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
+}
+
+/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
+ * contains an SV* */
+
+SV**
+hv_fetch(HV *hv, char *key, U32 klen, I32 lval)
+{
+ register XPVHV* xhv;
+ register U32 hash;
+ register HE *entry;
+ SV *sv;
+
+ if (!hv)
+ return 0;
+
+ if (SvRMAGICAL(hv)) {
+ if (mg_find((SV*)hv,'P')) {
+ dTHR;
+ sv = sv_newmortal();
+ mg_copy((SV*)hv, sv, key, klen);
+ PL_hv_fetch_sv = sv;
+ return &PL_hv_fetch_sv;
+ }
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv,'E')) {
+ U32 i;
+ for (i = 0; i < klen; ++i)
+ if (isLOWER(key[i])) {
+ char *nkey = strupr(SvPVX(sv_2mortal(newSVpv(key,klen))));
+ SV **ret = hv_fetch(hv, nkey, klen, 0);
+ if (!ret && lval)
+ ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
+ return ret;
+ }
+ }
+#endif
+ }
+
+ xhv = (XPVHV*)SvANY(hv);
+ if (!xhv->xhv_array) {
+ if (lval
+#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
+ || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
+#endif
+ )
+ Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ else
+ return 0;
+ }
+
+ PERL_HASH(hash, key, klen);
+
+ entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ for (; entry; entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != klen)
+ continue;
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ return &HeVAL(entry);
+ }
+#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
+ if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
+ char *gotenv;
+
+ if ((gotenv = PerlEnv_getenv(key)) != Nullch) {
+ sv = newSVpv(gotenv,strlen(gotenv));
+ SvTAINTED_on(sv);
+ return hv_store(hv,key,klen,sv,hash);
+ }
+ }
+#endif
+ if (lval) { /* gonna assign to this, so it better be there */
+ sv = NEWSV(61,0);
+ return hv_store(hv,key,klen,sv,hash);
+ }
+ return 0;
+}
+
+/* returns a HE * structure with the all fields set */
+/* note that hent_val will be a mortal sv for MAGICAL hashes */
+HE *
+hv_fetch_ent(HV *hv, SV *keysv, I32 lval, register U32 hash)
+{
+ register XPVHV* xhv;
+ register char *key;
+ STRLEN klen;
+ register HE *entry;
+ SV *sv;
+
+ if (!hv)
+ return 0;
+
+ if (SvRMAGICAL(hv)) {
+ if (mg_find((SV*)hv,'P')) {
+ dTHR;
+ sv = sv_newmortal();
+ keysv = sv_2mortal(newSVsv(keysv));
+ mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
+ if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
+ char *k;
+ New(54, k, HEK_BASESIZE + sizeof(SV*), char);
+ HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
+ }
+ HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
+ HeVAL(&PL_hv_fetch_ent_mh) = sv;
+ return &PL_hv_fetch_ent_mh;
+ }
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv,'E')) {
+ U32 i;
+ key = SvPV(keysv, klen);
+ for (i = 0; i < klen; ++i)
+ if (isLOWER(key[i])) {
+ SV *nkeysv = sv_2mortal(newSVpv(key,klen));
+ (void)strupr(SvPVX(nkeysv));
+ entry = hv_fetch_ent(hv, nkeysv, 0, 0);
+ if (!entry && lval)
+ entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
+ return entry;
+ }
+ }
+#endif
+ }
+
+ xhv = (XPVHV*)SvANY(hv);
+ if (!xhv->xhv_array) {
+ if (lval
+#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
+ || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
+#endif
+ )
+ Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ else
+ return 0;
+ }
+
+ key = SvPV(keysv, klen);
+
+ if (!hash)
+ PERL_HASH(hash, key, klen);
+
+ entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ for (; entry; entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != klen)
+ continue;
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ return entry;
+ }
+#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
+ if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
+ char *gotenv;
+
+ if ((gotenv = PerlEnv_getenv(key)) != Nullch) {
+ sv = newSVpv(gotenv,strlen(gotenv));
+ SvTAINTED_on(sv);
+ return hv_store_ent(hv,keysv,sv,hash);
+ }
+ }
+#endif
+ if (lval) { /* gonna assign to this, so it better be there */
+ sv = NEWSV(61,0);
+ return hv_store_ent(hv,keysv,sv,hash);
+ }
+ return 0;
+}
+
+static void
+hv_magic_check (HV *hv, bool *needs_copy, bool *needs_store)
+{
+ MAGIC *mg = SvMAGIC(hv);
+ *needs_copy = FALSE;
+ *needs_store = TRUE;
+ while (mg) {
+ if (isUPPER(mg->mg_type)) {
+ *needs_copy = TRUE;
+ switch (mg->mg_type) {
+ case 'P':
+ case 'S':
+ *needs_store = FALSE;
+ }
+ }
+ mg = mg->mg_moremagic;
+ }
+}
+
+SV**
+hv_store(HV *hv, char *key, U32 klen, SV *val, register U32 hash)
+{
+ register XPVHV* xhv;
+ register I32 i;
+ register HE *entry;
+ register HE **oentry;
+
+ if (!hv)
+ return 0;
+
+ xhv = (XPVHV*)SvANY(hv);
+ if (SvMAGICAL(hv)) {
+ bool needs_copy;
+ bool needs_store;
+ hv_magic_check (hv, &needs_copy, &needs_store);
+ if (needs_copy) {
+ mg_copy((SV*)hv, val, key, klen);
+ if (!xhv->xhv_array && !needs_store)
+ return 0;
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv,'E')) {
+ SV *sv = sv_2mortal(newSVpv(key,klen));
+ key = strupr(SvPVX(sv));
+ hash = 0;
+ }
+#endif
+ }
+ }
+ if (!hash)
+ PERL_HASH(hash, key, klen);
+
+ if (!xhv->xhv_array)
+ Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ i = 1;
+
+ for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != klen)
+ continue;
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ SvREFCNT_dec(HeVAL(entry));
+ HeVAL(entry) = val;
+ return &HeVAL(entry);
+ }
+
+ entry = new_he();
+ if (HvSHAREKEYS(hv))
+ HeKEY_hek(entry) = share_hek(key, klen, hash);
+ else /* gotta do the real thing */
+ HeKEY_hek(entry) = save_hek(key, klen, hash);
+ HeVAL(entry) = val;
+ HeNEXT(entry) = *oentry;
+ *oentry = entry;
+
+ xhv->xhv_keys++;
+ if (i) { /* initial entry? */
+ ++xhv->xhv_fill;
+ if (xhv->xhv_keys > xhv->xhv_max)
+ hsplit(hv);
+ }
+
+ return &HeVAL(entry);
+}
+
+HE *
+hv_store_ent(HV *hv, SV *keysv, SV *val, register U32 hash)
+{
+ register XPVHV* xhv;
+ register char *key;
+ STRLEN klen;
+ register I32 i;
+ register HE *entry;
+ register HE **oentry;
+
+ if (!hv)
+ return 0;
+
+ xhv = (XPVHV*)SvANY(hv);
+ if (SvMAGICAL(hv)) {
+ dTHR;
+ bool needs_copy;
+ bool needs_store;
+ hv_magic_check (hv, &needs_copy, &needs_store);
+ if (needs_copy) {
+ bool save_taint = PL_tainted;
+ if (PL_tainting)
+ PL_tainted = SvTAINTED(keysv);
+ keysv = sv_2mortal(newSVsv(keysv));
+ mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
+ TAINT_IF(save_taint);
+ if (!xhv->xhv_array && !needs_store)
+ return Nullhe;
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv,'E')) {
+ key = SvPV(keysv, klen);
+ keysv = sv_2mortal(newSVpv(key,klen));
+ (void)strupr(SvPVX(keysv));
+ hash = 0;
+ }
+#endif
+ }
+ }
+
+ key = SvPV(keysv, klen);
+
+ if (!hash)
+ PERL_HASH(hash, key, klen);
+
+ if (!xhv->xhv_array)
+ Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ i = 1;
+
+ for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != klen)
+ continue;
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ SvREFCNT_dec(HeVAL(entry));
+ HeVAL(entry) = val;
+ return entry;
+ }
+
+ entry = new_he();
+ if (HvSHAREKEYS(hv))
+ HeKEY_hek(entry) = share_hek(key, klen, hash);
+ else /* gotta do the real thing */
+ HeKEY_hek(entry) = save_hek(key, klen, hash);
+ HeVAL(entry) = val;
+ HeNEXT(entry) = *oentry;
+ *oentry = entry;
+
+ xhv->xhv_keys++;
+ if (i) { /* initial entry? */
+ ++xhv->xhv_fill;
+ if (xhv->xhv_keys > xhv->xhv_max)
+ hsplit(hv);
+ }
+
+ return entry;
+}
+
+SV *
+hv_delete(HV *hv, char *key, U32 klen, I32 flags)
+{
+ register XPVHV* xhv;
+ register I32 i;
+ register U32 hash;
+ register HE *entry;
+ register HE **oentry;
+ SV **svp;
+ SV *sv;
+
+ if (!hv)
+ return Nullsv;
+ if (SvRMAGICAL(hv)) {
+ bool needs_copy;
+ bool needs_store;
+ hv_magic_check (hv, &needs_copy, &needs_store);
+
+ if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
+ sv = *svp;
+ mg_clear(sv);
+ if (!needs_store) {
+ if (mg_find(sv, 'p')) {
+ sv_unmagic(sv, 'p'); /* No longer an element */
+ return sv;
+ }
+ return Nullsv; /* element cannot be deleted */
+ }
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv,'E')) {
+ sv = sv_2mortal(newSVpv(key,klen));
+ key = strupr(SvPVX(sv));
+ }
+#endif
+ }
+ }
+ xhv = (XPVHV*)SvANY(hv);
+ if (!xhv->xhv_array)
+ return Nullsv;
+
+ PERL_HASH(hash, key, klen);
+
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ entry = *oentry;
+ i = 1;
+ for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != klen)
+ continue;
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ *oentry = HeNEXT(entry);
+ if (i && !*oentry)
+ xhv->xhv_fill--;
+ if (flags & G_DISCARD)
+ sv = Nullsv;
+ else
+ sv = sv_mortalcopy(HeVAL(entry));
+ if (entry == xhv->xhv_eiter)
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+ --xhv->xhv_keys;
+ return sv;
+ }
+ return Nullsv;
+}
+
+SV *
+hv_delete_ent(HV *hv, SV *keysv, I32 flags, U32 hash)
+{
+ register XPVHV* xhv;
+ register I32 i;
+ register char *key;
+ STRLEN klen;
+ register HE *entry;
+ register HE **oentry;
+ SV *sv;
+
+ if (!hv)
+ return Nullsv;
+ if (SvRMAGICAL(hv)) {
+ bool needs_copy;
+ bool needs_store;
+ hv_magic_check (hv, &needs_copy, &needs_store);
+
+ if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
+ sv = HeVAL(entry);
+ mg_clear(sv);
+ if (!needs_store) {
+ if (mg_find(sv, 'p')) {
+ sv_unmagic(sv, 'p'); /* No longer an element */
+ return sv;
+ }
+ return Nullsv; /* element cannot be deleted */
+ }
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv,'E')) {
+ key = SvPV(keysv, klen);
+ keysv = sv_2mortal(newSVpv(key,klen));
+ (void)strupr(SvPVX(keysv));
+ hash = 0;
+ }
+#endif
+ }
+ }
+ xhv = (XPVHV*)SvANY(hv);
+ if (!xhv->xhv_array)
+ return Nullsv;
+
+ key = SvPV(keysv, klen);
+
+ if (!hash)
+ PERL_HASH(hash, key, klen);
+
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ entry = *oentry;
+ i = 1;
+ for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != klen)
+ continue;
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ *oentry = HeNEXT(entry);
+ if (i && !*oentry)
+ xhv->xhv_fill--;
+ if (flags & G_DISCARD)
+ sv = Nullsv;
+ else
+ sv = sv_mortalcopy(HeVAL(entry));
+ if (entry == xhv->xhv_eiter)
+ HvLAZYDEL_on(hv);
+ else
+ hv_free_ent(hv, entry);
+ --xhv->xhv_keys;
+ return sv;
+ }
+ return Nullsv;
+}
+
+bool
+hv_exists(HV *hv, char *key, U32 klen)
+{
+ register XPVHV* xhv;
+ register U32 hash;
+ register HE *entry;
+ SV *sv;
+
+ if (!hv)
+ return 0;
+
+ if (SvRMAGICAL(hv)) {
+ if (mg_find((SV*)hv,'P')) {
+ dTHR;
+ sv = sv_newmortal();
+ mg_copy((SV*)hv, sv, key, klen);
+ magic_existspack(sv, mg_find(sv, 'p'));
+ return SvTRUE(sv);
+ }
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv,'E')) {
+ sv = sv_2mortal(newSVpv(key,klen));
+ key = strupr(SvPVX(sv));
+ }
+#endif
+ }
+
+ xhv = (XPVHV*)SvANY(hv);
+ if (!xhv->xhv_array)
+ return 0;
+
+ PERL_HASH(hash, key, klen);
+
+ entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ for (; entry; entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != klen)
+ continue;
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ return TRUE;
+ }
+ return FALSE;
+}
+
+
+bool
+hv_exists_ent(HV *hv, SV *keysv, U32 hash)
+{
+ register XPVHV* xhv;
+ register char *key;
+ STRLEN klen;
+ register HE *entry;
+ SV *sv;
+
+ if (!hv)
+ return 0;
+
+ if (SvRMAGICAL(hv)) {
+ if (mg_find((SV*)hv,'P')) {
+ dTHR; /* just for SvTRUE */
+ sv = sv_newmortal();
+ keysv = sv_2mortal(newSVsv(keysv));
+ mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
+ magic_existspack(sv, mg_find(sv, 'p'));
+ return SvTRUE(sv);
+ }
+#ifdef ENV_IS_CASELESS
+ else if (mg_find((SV*)hv,'E')) {
+ key = SvPV(keysv, klen);
+ keysv = sv_2mortal(newSVpv(key,klen));
+ (void)strupr(SvPVX(keysv));
+ hash = 0;
+ }
+#endif
+ }
+
+ xhv = (XPVHV*)SvANY(hv);
+ if (!xhv->xhv_array)
+ return 0;
+
+ key = SvPV(keysv, klen);
+ if (!hash)
+ PERL_HASH(hash, key, klen);
+
+ entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ for (; entry; entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != klen)
+ continue;
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
+ continue;
+ return TRUE;
+ }
+ return FALSE;
+}
+
+STATIC void
+hsplit(HV *hv)
+{
+ register XPVHV* xhv = (XPVHV*)SvANY(hv);
+ I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
+ register I32 newsize = oldsize * 2;
+ register I32 i;
+ register char *a = xhv->xhv_array;
+ register HE **aep;
+ register HE **bep;
+ register HE *entry;
+ register HE **oentry;
+
+ PL_nomemok = TRUE;
+#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
+ Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
+ if (!a) {
+ PL_nomemok = FALSE;
+ return;
+ }
+#else
+#define MALLOC_OVERHEAD 16
+ New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
+ if (!a) {
+ PL_nomemok = FALSE;
+ return;
+ }
+ Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
+ if (oldsize >= 64) {
+ offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize));
+ }
+ else
+ Safefree(xhv->xhv_array);
+#endif
+
+ PL_nomemok = FALSE;
+ Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
+ xhv->xhv_max = --newsize;
+ xhv->xhv_array = a;
+ aep = (HE**)a;
+
+ for (i=0; i<oldsize; i++,aep++) {
+ if (!*aep) /* non-existent */
+ continue;
+ bep = aep+oldsize;
+ for (oentry = aep, entry = *aep; entry; entry = *oentry) {
+ if ((HeHASH(entry) & newsize) != i) {
+ *oentry = HeNEXT(entry);
+ HeNEXT(entry) = *bep;
+ if (!*bep)
+ xhv->xhv_fill++;
+ *bep = entry;
+ continue;
+ }
+ else
+ oentry = &HeNEXT(entry);
+ }
+ if (!*aep) /* everything moved */
+ xhv->xhv_fill--;
+ }
+}
+
+void
+hv_ksplit(HV *hv, IV newmax)
+{
+ register XPVHV* xhv = (XPVHV*)SvANY(hv);
+ I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
+ register I32 newsize;
+ register I32 i;
+ register I32 j;
+ register char *a;
+ register HE **aep;
+ register HE *entry;
+ register HE **oentry;
+
+ newsize = (I32) newmax; /* possible truncation here */
+ if (newsize != newmax || newmax <= oldsize)
+ return;
+ while ((newsize & (1 + ~newsize)) != newsize) {
+ newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
+ }
+ if (newsize < newmax)
+ newsize *= 2;
+ if (newsize < newmax)
+ return; /* overflow detection */
+
+ a = xhv->xhv_array;
+ if (a) {
+ PL_nomemok = TRUE;
+#if defined(STRANGE_MALLOC) || defined(MYMALLOC)
+ Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
+ if (!a) {
+ PL_nomemok = FALSE;
+ return;
+ }
+#else
+ New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
+ if (!a) {
+ PL_nomemok = FALSE;
+ return;
+ }
+ Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
+ if (oldsize >= 64) {
+ offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize));
+ }
+ else
+ Safefree(xhv->xhv_array);
+#endif
+ PL_nomemok = FALSE;
+ Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
+ }
+ else {
+ Newz(0, a, ARRAY_ALLOC_BYTES(newsize), char);
+ }
+ xhv->xhv_max = --newsize;
+ xhv->xhv_array = a;
+ if (!xhv->xhv_fill) /* skip rest if no entries */
+ return;
+
+ aep = (HE**)a;
+ for (i=0; i<oldsize; i++,aep++) {
+ if (!*aep) /* non-existent */
+ continue;
+ for (oentry = aep, entry = *aep; entry; entry = *oentry) {
+ if ((j = (HeHASH(entry) & newsize)) != i) {
+ j -= i;
+ *oentry = HeNEXT(entry);
+ if (!(HeNEXT(entry) = aep[j]))
+ xhv->xhv_fill++;
+ aep[j] = entry;
+ continue;
+ }
+ else
+ oentry = &HeNEXT(entry);
+ }
+ if (!*aep) /* everything moved */
+ xhv->xhv_fill--;
+ }
+}
+
+HV *
+newHV(void)
+{
+ register HV *hv;
+ register XPVHV* xhv;
+
+ hv = (HV*)NEWSV(502,0);
+ sv_upgrade((SV *)hv, SVt_PVHV);
+ xhv = (XPVHV*)SvANY(hv);
+ SvPOK_off(hv);
+ SvNOK_off(hv);
+#ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+#endif
+ xhv->xhv_max = 7; /* start with 8 buckets */
+ xhv->xhv_fill = 0;
+ xhv->xhv_pmroot = 0;
+ (void)hv_iterinit(hv); /* so each() will start off right */
+ return hv;
+}
+
+HV *
+newHVhv(HV *ohv)
+{
+ register HV *hv;
+ register XPVHV* xhv;
+ STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
+ STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
+
+ hv = newHV();
+ while (hv_max && hv_max + 1 >= hv_fill * 2)
+ hv_max = hv_max / 2; /* Is always 2^n-1 */
+ ((XPVHV*)SvANY(hv))->xhv_max = hv_max;
+ if (!hv_fill)
+ return hv;
+
+#if 0
+ if (!SvRMAGICAL(ohv) || !mg_find((SV*)ohv,'P')) {
+ /* Quick way ???*/
+ }
+ else
+#endif
+ {
+ HE *entry;
+ I32 hv_riter = HvRITER(ohv); /* current root of iterator */
+ HE *hv_eiter = HvEITER(ohv); /* current entry of iterator */
+
+ /* Slow way */
+ hv_iterinit(hv);
+ while (entry = hv_iternext(ohv)) {
+ hv_store(hv, HeKEY(entry), HeKLEN(entry),
+ SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
+ }
+ HvRITER(ohv) = hv_riter;
+ HvEITER(ohv) = hv_eiter;
+ }
+
+ return hv;
+}
+
+void
+hv_free_ent(HV *hv, register HE *entry)
+{
+ SV *val;
+
+ if (!entry)
+ return;
+ val = HeVAL(entry);
+ if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
+ PL_sub_generation++; /* may be deletion of method from stash */
+ SvREFCNT_dec(val);
+ if (HeKLEN(entry) == HEf_SVKEY) {
+ SvREFCNT_dec(HeKEY_sv(entry));
+ Safefree(HeKEY_hek(entry));
+ }
+ else if (HvSHAREKEYS(hv))
+ unshare_hek(HeKEY_hek(entry));
+ else
+ Safefree(HeKEY_hek(entry));
+ del_he(entry);
+}
+
+void
+hv_delayfree_ent(HV *hv, register HE *entry)
+{
+ if (!entry)
+ return;
+ if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
+ PL_sub_generation++; /* may be deletion of method from stash */
+ sv_2mortal(HeVAL(entry)); /* free between statements */
+ if (HeKLEN(entry) == HEf_SVKEY) {
+ sv_2mortal(HeKEY_sv(entry));
+ Safefree(HeKEY_hek(entry));
+ }
+ else if (HvSHAREKEYS(hv))
+ unshare_hek(HeKEY_hek(entry));
+ else
+ Safefree(HeKEY_hek(entry));
+ del_he(entry);
+}
+
+void
+hv_clear(HV *hv)
+{
+ register XPVHV* xhv;
+ if (!hv)
+ return;
+ xhv = (XPVHV*)SvANY(hv);
+ hfreeentries(hv);
+ xhv->xhv_fill = 0;
+ xhv->xhv_keys = 0;
+ if (xhv->xhv_array)
+ (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
+
+ if (SvRMAGICAL(hv))
+ mg_clear((SV*)hv);
+}
+
+STATIC void
+hfreeentries(HV *hv)
+{
+ register HE **array;
+ register HE *entry;
+ register HE *oentry = Null(HE*);
+ I32 riter;
+ I32 max;
+
+ if (!hv)
+ return;
+ if (!HvARRAY(hv))
+ return;
+
+ riter = 0;
+ max = HvMAX(hv);
+ array = HvARRAY(hv);
+ entry = array[0];
+ for (;;) {
+ if (entry) {
+ oentry = entry;
+ entry = HeNEXT(entry);
+ hv_free_ent(hv, oentry);
+ }
+ if (!entry) {
+ if (++riter > max)
+ break;
+ entry = array[riter];
+ }
+ }
+ (void)hv_iterinit(hv);
+}
+
+void
+hv_undef(HV *hv)
+{
+ register XPVHV* xhv;
+ if (!hv)
+ return;
+ xhv = (XPVHV*)SvANY(hv);
+ hfreeentries(hv);
+ Safefree(xhv->xhv_array);
+ if (HvNAME(hv)) {
+ Safefree(HvNAME(hv));
+ HvNAME(hv) = 0;
+ }
+ xhv->xhv_array = 0;
+ xhv->xhv_max = 7; /* it's a normal hash */
+ xhv->xhv_fill = 0;
+ xhv->xhv_keys = 0;
+
+ if (SvRMAGICAL(hv))
+ mg_clear((SV*)hv);
+}
+
+I32
+hv_iterinit(HV *hv)
+{
+ register XPVHV* xhv;
+ HE *entry;
+
+ if (!hv)
+ croak("Bad hash");
+ xhv = (XPVHV*)SvANY(hv);
+ entry = xhv->xhv_eiter;
+#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
+ if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
+ prime_env_iter();
+#endif
+ if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
+ HvLAZYDEL_off(hv);
+ hv_free_ent(hv, entry);
+ }
+ xhv->xhv_riter = -1;
+ xhv->xhv_eiter = Null(HE*);
+ return xhv->xhv_keys; /* used to be xhv->xhv_fill before 5.004_65 */
+}
+
+HE *
+hv_iternext(HV *hv)
+{
+ register XPVHV* xhv;
+ register HE *entry;
+ HE *oldentry;
+ MAGIC* mg;
+
+ if (!hv)
+ croak("Bad hash");
+ xhv = (XPVHV*)SvANY(hv);
+ oldentry = entry = xhv->xhv_eiter;
+
+ if (SvRMAGICAL(hv) && (mg = mg_find((SV*)hv,'P'))) {
+ SV *key = sv_newmortal();
+ if (entry) {
+ sv_setsv(key, HeSVKEY_force(entry));
+ SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
+ }
+ else {
+ char *k;
+ HEK *hek;
+
+ xhv->xhv_eiter = entry = new_he(); /* one HE per MAGICAL hash */
+ Zero(entry, 1, HE);
+ Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
+ hek = (HEK*)k;
+ HeKEY_hek(entry) = hek;
+ HeKLEN(entry) = HEf_SVKEY;
+ }
+ magic_nextpack((SV*) hv,mg,key);
+ if (SvOK(key)) {
+ /* force key to stay around until next time */
+ HeSVKEY_set(entry, SvREFCNT_inc(key));
+ return entry; /* beware, hent_val is not set */
+ }
+ if (HeVAL(entry))
+ SvREFCNT_dec(HeVAL(entry));
+ Safefree(HeKEY_hek(entry));
+ del_he(entry);
+ xhv->xhv_eiter = Null(HE*);
+ return Null(HE*);
+ }
+
+ if (!xhv->xhv_array)
+ Newz(506,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
+ if (entry)
+ entry = HeNEXT(entry);
+ while (!entry) {
+ ++xhv->xhv_riter;
+ if (xhv->xhv_riter > xhv->xhv_max) {
+ xhv->xhv_riter = -1;
+ break;
+ }
+ entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
+ }
+
+ if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
+ HvLAZYDEL_off(hv);
+ hv_free_ent(hv, oldentry);
+ }
+
+ xhv->xhv_eiter = entry;
+ return entry;
+}
+
+char *
+hv_iterkey(register HE *entry, I32 *retlen)
+{
+ if (HeKLEN(entry) == HEf_SVKEY) {
+ STRLEN len;
+ char *p = SvPV(HeKEY_sv(entry), len);
+ *retlen = len;
+ return p;
+ }
+ else {
+ *retlen = HeKLEN(entry);
+ return HeKEY(entry);
+ }
+}
+
+/* unlike hv_iterval(), this always returns a mortal copy of the key */
+SV *
+hv_iterkeysv(register HE *entry)
+{
+ if (HeKLEN(entry) == HEf_SVKEY)
+ return sv_mortalcopy(HeKEY_sv(entry));
+ else
+ return sv_2mortal(newSVpv((HeKLEN(entry) ? HeKEY(entry) : ""),
+ HeKLEN(entry)));
+}
+
+SV *
+hv_iterval(HV *hv, register HE *entry)
+{
+ if (SvRMAGICAL(hv)) {
+ if (mg_find((SV*)hv,'P')) {
+ SV* sv = sv_newmortal();
+ if (HeKLEN(entry) == HEf_SVKEY)
+ mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
+ else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
+ return sv;
+ }
+ }
+ return HeVAL(entry);
+}
+
+SV *
+hv_iternextsv(HV *hv, char **key, I32 *retlen)
+{
+ HE *he;
+ if ( (he = hv_iternext(hv)) == NULL)
+ return NULL;
+ *key = hv_iterkey(he, retlen);
+ return hv_iterval(hv, he);
+}
+
+void
+hv_magic(HV *hv, GV *gv, int how)
+{
+ sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
+}
+
+char*
+sharepvn(char *sv, I32 len, U32 hash)
+{
+ return HEK_KEY(share_hek(sv, len, hash));
+}
+
+/* possibly free a shared string if no one has access to it
+ * len and hash must both be valid for str.
+ */
+void
+unsharepvn(char *str, I32 len, U32 hash)
+{
+ register XPVHV* xhv;
+ register HE *entry;
+ register HE **oentry;
+ register I32 i = 1;
+ I32 found = 0;
+
+ /* what follows is the moral equivalent of:
+ if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
+ if (--*Svp == Nullsv)
+ hv_delete(PL_strtab, str, len, G_DISCARD, hash);
+ } */
+ xhv = (XPVHV*)SvANY(PL_strtab);
+ /* assert(xhv_array != 0) */
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != len)
+ continue;
+ if (memNE(HeKEY(entry),str,len)) /* is this it? */
+ continue;
+ found = 1;
+ if (--HeVAL(entry) == Nullsv) {
+ *oentry = HeNEXT(entry);
+ if (i && !*oentry)
+ xhv->xhv_fill--;
+ Safefree(HeKEY_hek(entry));
+ del_he(entry);
+ --xhv->xhv_keys;
+ }
+ break;
+ }
+
+ if (!found)
+ warn("Attempt to free non-existent shared string");
+}
+
+/* get a (constant) string ptr from the global string table
+ * string will get added if it is not already there.
+ * len and hash must both be valid for str.
+ */
+HEK *
+share_hek(char *str, I32 len, register U32 hash)
+{
+ register XPVHV* xhv;
+ register HE *entry;
+ register HE **oentry;
+ register I32 i = 1;
+ I32 found = 0;
+
+ /* what follows is the moral equivalent of:
+
+ if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
+ hv_store(PL_strtab, str, len, Nullsv, hash);
+ */
+ xhv = (XPVHV*)SvANY(PL_strtab);
+ /* assert(xhv_array != 0) */
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != len)
+ continue;
+ if (memNE(HeKEY(entry),str,len)) /* is this it? */
+ continue;
+ found = 1;
+ break;
+ }
+ if (!found) {
+ entry = new_he();
+ HeKEY_hek(entry) = save_hek(str, len, hash);
+ HeVAL(entry) = Nullsv;
+ HeNEXT(entry) = *oentry;
+ *oentry = entry;
+ xhv->xhv_keys++;
+ if (i) { /* initial entry? */
+ ++xhv->xhv_fill;
+ if (xhv->xhv_keys > xhv->xhv_max)
+ hsplit(PL_strtab);
+ }
+ }
+
+ ++HeVAL(entry); /* use value slot as REFCNT */
+ return HeKEY_hek(entry);
+}
+
+
+
diff --git a/contrib/perl5/hv.h b/contrib/perl5/hv.h
new file mode 100644
index 000000000000..19694ac5d1df
--- /dev/null
+++ b/contrib/perl5/hv.h
@@ -0,0 +1,120 @@
+/* hv.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+typedef struct he HE;
+typedef struct hek HEK;
+
+struct he {
+ HE *hent_next;
+ HEK *hent_hek;
+ SV *hent_val;
+};
+
+struct hek {
+ U32 hek_hash;
+ I32 hek_len;
+ char hek_key[1];
+};
+
+/* This structure must match the beginning of struct xpvmg in sv.h. */
+struct xpvhv {
+ char * xhv_array; /* pointer to malloced string */
+ STRLEN xhv_fill; /* how full xhv_array currently is */
+ STRLEN xhv_max; /* subscript of last element of xhv_array */
+ IV xhv_keys; /* how many elements in the array */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* magic for scalar array */
+ HV* xmg_stash; /* class package */
+
+ I32 xhv_riter; /* current root of iterator */
+ HE *xhv_eiter; /* current entry of iterator */
+ PMOP *xhv_pmroot; /* list of pm's for this package */
+ char *xhv_name; /* name, if a symbol table */
+};
+
+#define PERL_HASH(hash,str,len) \
+ STMT_START { \
+ register char *s_PeRlHaSh = str; \
+ register I32 i_PeRlHaSh = len; \
+ register U32 hash_PeRlHaSh = 0; \
+ while (i_PeRlHaSh--) \
+ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
+ (hash) = hash_PeRlHaSh; \
+ } STMT_END
+
+
+/* these hash entry flags ride on hent_klen (for use only in magic/tied HVs) */
+#define HEf_SVKEY -2 /* hent_key is a SV* */
+
+
+#define Nullhv Null(HV*)
+#define HvARRAY(hv) ((HE**)((XPVHV*) SvANY(hv))->xhv_array)
+#define HvFILL(hv) ((XPVHV*) SvANY(hv))->xhv_fill
+#define HvMAX(hv) ((XPVHV*) SvANY(hv))->xhv_max
+#define HvKEYS(hv) ((XPVHV*) SvANY(hv))->xhv_keys
+#define HvRITER(hv) ((XPVHV*) SvANY(hv))->xhv_riter
+#define HvEITER(hv) ((XPVHV*) SvANY(hv))->xhv_eiter
+#define HvPMROOT(hv) ((XPVHV*) SvANY(hv))->xhv_pmroot
+#define HvNAME(hv) ((XPVHV*) SvANY(hv))->xhv_name
+
+#define HvSHAREKEYS(hv) (SvFLAGS(hv) & SVphv_SHAREKEYS)
+#define HvSHAREKEYS_on(hv) (SvFLAGS(hv) |= SVphv_SHAREKEYS)
+#define HvSHAREKEYS_off(hv) (SvFLAGS(hv) &= ~SVphv_SHAREKEYS)
+
+#define HvLAZYDEL(hv) (SvFLAGS(hv) & SVphv_LAZYDEL)
+#define HvLAZYDEL_on(hv) (SvFLAGS(hv) |= SVphv_LAZYDEL)
+#define HvLAZYDEL_off(hv) (SvFLAGS(hv) &= ~SVphv_LAZYDEL)
+
+#ifdef OVERLOAD
+
+/* Maybe amagical: */
+/* #define HV_AMAGICmb(hv) (SvFLAGS(hv) & (SVpgv_badAM | SVpgv_AM)) */
+
+#define HV_AMAGIC(hv) (SvFLAGS(hv) & SVpgv_AM)
+#define HV_AMAGIC_on(hv) (SvFLAGS(hv) |= SVpgv_AM)
+#define HV_AMAGIC_off(hv) (SvFLAGS(hv) &= ~SVpgv_AM)
+
+/*
+#define HV_AMAGICbad(hv) (SvFLAGS(hv) & SVpgv_badAM)
+#define HV_badAMAGIC_on(hv) (SvFLAGS(hv) |= SVpgv_badAM)
+#define HV_badAMAGIC_off(hv) (SvFLAGS(hv) &= ~SVpgv_badAM)
+*/
+
+#endif /* OVERLOAD */
+
+#define Nullhe Null(HE*)
+#define HeNEXT(he) (he)->hent_next
+#define HeKEY_hek(he) (he)->hent_hek
+#define HeKEY(he) HEK_KEY(HeKEY_hek(he))
+#define HeKEY_sv(he) (*(SV**)HeKEY(he))
+#define HeKLEN(he) HEK_LEN(HeKEY_hek(he))
+#define HeVAL(he) (he)->hent_val
+#define HeHASH(he) HEK_HASH(HeKEY_hek(he))
+#define HePV(he,lp) ((HeKLEN(he) == HEf_SVKEY) ? \
+ SvPV(HeKEY_sv(he),lp) : \
+ (((lp = HeKLEN(he)) >= 0) ? \
+ HeKEY(he) : Nullch))
+
+#define HeSVKEY(he) ((HeKEY(he) && \
+ HeKLEN(he) == HEf_SVKEY) ? \
+ HeKEY_sv(he) : Nullsv)
+
+#define HeSVKEY_force(he) (HeKEY(he) ? \
+ ((HeKLEN(he) == HEf_SVKEY) ? \
+ HeKEY_sv(he) : \
+ sv_2mortal(newSVpv(HeKEY(he), \
+ HeKLEN(he)))) : \
+ &PL_sv_undef)
+#define HeSVKEY_set(he,sv) ((HeKLEN(he) = HEf_SVKEY), (HeKEY_sv(he) = sv))
+
+#define Nullhek Null(HEK*)
+#define HEK_BASESIZE STRUCT_OFFSET(HEK, hek_key[0])
+#define HEK_HASH(hek) (hek)->hek_hash
+#define HEK_LEN(hek) (hek)->hek_len
+#define HEK_KEY(hek) (hek)->hek_key
diff --git a/contrib/perl5/installhtml b/contrib/perl5/installhtml
new file mode 100755
index 000000000000..fd11ee69f484
--- /dev/null
+++ b/contrib/perl5/installhtml
@@ -0,0 +1,584 @@
+#!./perl -w
+
+# This file should really be a extracted from a .PL
+
+use lib 'lib'; # use source library if present
+
+use Config; # for config options in the makefile
+use Getopt::Long; # for command-line parsing
+use Cwd;
+use Pod::Html;
+
+umask 022;
+
+=head1 NAME
+
+installhtml - converts a collection of POD pages to HTML format.
+
+=head1 SYNOPSIS
+
+ installhtml [--help] [--podpath=<name>:...:<name>] [--podroot=<name>]
+ [--htmldir=<name>] [--htmlroot=<name>] [--norecurse] [--recurse]
+ [--splithead=<name>,...,<name>] [--splititem=<name>,...,<name>]
+ [--libpods=<name>,...,<name>] [--verbose]
+
+=head1 DESCRIPTION
+
+I<installhtml> converts a collection of POD pages to a corresponding
+collection of HTML pages. This is primarily used to convert the pod
+pages found in the perl distribution.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<--help> help
+
+Displays the usage.
+
+=item B<--podroot> POD search path base directory
+
+The base directory to search for all .pod and .pm files to be converted.
+Default is current directory.
+
+=item B<--podpath> POD search path
+
+The list of directories to search for .pod and .pm files to be converted.
+Default is `podroot/.'.
+
+=item B<--recurse> recurse on subdirectories
+
+Whether or not to convert all .pm and .pod files found in subdirectories
+too. Default is to not recurse.
+
+=item B<--htmldir> HTML destination directory
+
+The base directory which all HTML files will be written to. This should
+be a path relative to the filesystem, not the resulting URL.
+
+=item B<--htmlroot> URL base directory
+
+The base directory which all resulting HTML files will be visible at in
+a URL. The default is `/'.
+
+=item B<--splithead> POD files to split on =head directive
+
+Colon-separated list of pod files to split by the =head directive. The
+.pod suffix is optional. These files should have names specified
+relative to podroot.
+
+=item B<--splititem> POD files to split on =item directive
+
+Colon-separated list of all pod files to split by the =item directive.
+The .pod suffix is optional. I<installhtml> does not do the actual
+split, rather it invokes I<splitpod> to do the dirty work. As with
+--splithead, these files should have names specified relative to podroot.
+
+=item B<--splitpod> Directory containing the splitpod program
+
+The directory containing the splitpod program. The default is `podroot/pod'.
+
+=item B<--libpods> library PODs for LE<lt>E<gt> links
+
+Colon-separated list of "library" pod files. This is the same list that
+will be passed to pod2html when any pod is converted.
+
+=item B<--verbose> verbose output
+
+Self-explanatory.
+
+=back
+
+=head1 EXAMPLE
+
+The following command-line is an example of the one we use to convert
+perl documentation:
+
+ ./installhtml --podpath=lib:ext:pod:vms \
+ --podroot=/usr/src/perl \
+ --htmldir=/perl/nmanual \
+ --htmlroot=/perl/nmanual \
+ --splithead=pod/perlipc \
+ --splititem=pod/perlfunc \
+ --libpods=perlfunc:perlguts:perlvar:perlrun:perlop \
+ --recurse \
+ --verbose
+
+=head1 AUTHOR
+
+Chris Hall E<lt>hallc@cs.colorado.eduE<gt>
+
+=head1 TODO
+
+=cut
+
+$usage =<<END_OF_USAGE;
+Usage: $0 --help --podpath=<name>:...:<name> --podroot=<name>
+ --htmldir=<name> --htmlroot=<name> --norecurse --recurse
+ --splithead=<name>,...,<name> --splititem=<name>,...,<name>
+ --libpods=<name>,...,<name> --verbose
+
+ --help - this message
+ --podpath - colon-separated list of directories containing .pod and
+ .pm files to be converted (. by default).
+ --podroot - filesystem base directory from which all relative paths in
+ podpath stem (default is .).
+ --htmldir - directory to store resulting html files in relative
+ to the filesystem (\$podroot/html by default).
+ --htmlroot - http-server base directory from which all relative paths
+ in podpath stem (default is /).
+ --libpods - comma-separated list of files to search for =item pod
+ directives in as targets of C<> and implicit links (empty
+ by default).
+ --norecurse - don't recurse on those subdirectories listed in podpath.
+ (default behavior).
+ --recurse - recurse on those subdirectories listed in podpath
+ --splithead - comma-separated list of .pod or .pm files to split. will
+ split each file into several smaller files at every occurrence
+ of a pod =head[1-6] directive.
+ --splititem - comma-separated list of .pod or .pm files to split using
+ splitpod.
+ --splitpod - directory where the program splitpod can be found
+ (\$podroot/pod by default).
+ --verbose - self-explanatory.
+
+END_OF_USAGE
+
+@libpods = ();
+@podpath = ( "." ); # colon-separated list of directories containing .pod
+ # and .pm files to be converted.
+$podroot = "."; # assume the pods we want are here
+$htmldir = ""; # nothing for now...
+$htmlroot = "/"; # default value
+$recurse = 0; # default behavior
+@splithead = (); # don't split any files by default
+@splititem = (); # don't split any files by default
+$splitpod = ""; # nothing for now.
+
+$verbose = 0; # whether or not to print debugging info
+
+$pod2html = "pod/pod2html";
+
+usage("") unless @ARGV;
+
+# parse the command-line
+$result = GetOptions( qw(
+ help
+ podpath=s
+ podroot=s
+ htmldir=s
+ htmlroot=s
+ libpods=s
+ recurse!
+ splithead=s
+ splititem=s
+ splitpod=s
+ verbose
+));
+usage("invalid parameters") unless $result;
+parse_command_line();
+
+
+# set these variables to appropriate values if the user didn't specify
+# values for them.
+$htmldir = "$htmlroot/html" unless $htmldir;
+$splitpod = "$podroot/pod" unless $splitpod;
+
+
+# make sure that the destination directory exists
+(mkdir($htmldir, 0755) ||
+ die "$0: cannot make directory $htmldir: $!\n") if ! -d $htmldir;
+
+
+# the following array will eventually contain files that are to be
+# ignored in the conversion process. these are files that have been
+# process by splititem or splithead and should not be converted as a
+# result.
+@ignore = ();
+
+
+# split pods. its important to do this before convert ANY pods because
+# it may effect some of the links
+@splitdirs = (); # files in these directories won't get an index
+split_on_head($podroot, $htmldir, \@splitdirs, \@ignore, @splithead);
+split_on_item($podroot, \@splitdirs, \@ignore, @splititem);
+
+
+# convert the pod pages found in @poddirs
+#warn "converting files\n" if $verbose;
+#warn "\@ignore\t= @ignore\n" if $verbose;
+foreach $dir (@podpath) {
+ installdir($dir, $recurse, $podroot, \@splitdirs, \@ignore);
+}
+
+
+# now go through and create master indices for each pod we split
+foreach $dir (@splititem) {
+ print "creating index $htmldir/$dir.html\n" if $verbose;
+ create_index("$htmldir/$dir.html", "$htmldir/$dir");
+}
+
+foreach $dir (@splithead) {
+ $dir .= ".pod" unless $dir =~ /(\.pod|\.pm)$/;
+ # let pod2html create the file
+ runpod2html($dir, 1);
+
+ # now go through and truncate after the index
+ $dir =~ /^(.*?)(\.pod|\.pm)?$/sm;
+ $file = "$htmldir/$1";
+ print "creating index $file.html\n" if $verbose;
+
+ # read in everything until what would have been the first =head
+ # directive, patching the index as we go.
+ open(H, "<$file.html") ||
+ die "$0: error opening $file.html for input: $!\n";
+ $/ = "";
+ @data = ();
+ while (<H>) {
+ last if /NAME=/;
+ s,HREF="#(.*)">,HREF="$file/$1.html">,g;
+ push @data, $_;
+ }
+ close(H);
+
+ # now rewrite the file
+ open(H, ">$file.html") ||
+ die "$0: error opening $file.html for output: $!\n";
+ print H "@data\n";
+ close(H);
+}
+
+##############################################################################
+
+
+sub usage {
+ warn "$0: @_\n" if @_;
+ die $usage;
+}
+
+
+sub parse_command_line {
+ usage() if defined $opt_help;
+ $opt_help = ""; # make -w shut up
+
+ # list of directories
+ @podpath = split(":", $opt_podpath) if defined $opt_podpath;
+
+ # lists of files
+ @splithead = split(",", $opt_splithead) if defined $opt_splithead;
+ @splititem = split(",", $opt_splititem) if defined $opt_splititem;
+ @libpods = split(",", $opt_libpods) if defined $opt_libpods;
+
+ $htmldir = $opt_htmldir if defined $opt_htmldir;
+ $htmlroot = $opt_htmlroot if defined $opt_htmlroot;
+ $podroot = $opt_podroot if defined $opt_podroot;
+ $splitpod = $opt_splitpod if defined $opt_splitpod;
+
+ $recurse = $opt_recurse if defined $opt_recurse;
+ $verbose = $opt_verbose if defined $opt_verbose;
+}
+
+
+sub absolute_path {
+ my($cwd, $path) = @_;
+ return "$cwd/$path" unless $path =~ m:/:;
+ # add cwd if path is not already an absolute path
+ $path = "$cwd/$path" if (substr($path,0,1) ne '/');
+ return $path;
+}
+
+
+sub create_index {
+ my($html, $dir) = @_;
+ my(@files, @filedata, @index, $file);
+
+ # get the list of .html files in this directory
+ opendir(DIR, $dir) ||
+ die "$0: error opening directory $dir for reading: $!\n";
+ @files = sort(grep(/\.html?$/, readdir(DIR)));
+ closedir(DIR);
+
+ open(HTML, ">$html") ||
+ die "$0: error opening $html for output: $!\n";
+
+ # for each .html file in the directory, extract the index
+ # embedded in the file and throw it into the big index.
+ print HTML "<DL COMPACT>\n";
+ foreach $file (@files) {
+ $/ = "";
+
+ open(IN, "<$dir/$file") ||
+ die "$0: error opening $dir/$file for input: $!\n";
+ @filedata = <IN>;
+ close(IN);
+
+ # pull out the NAME section
+ ($name) = grep(/NAME=/, @filedata);
+ $name =~ m,/H1>\s(\S+)\s[\s-]*(.*?)\s*$,sm;
+ print HTML qq(<A HREF="$dir/$file">);
+ print HTML "<DT>$1</A><DD>$2\n" if defined $1;
+# print HTML qq(<A HREF="$dir/$file">$1</A><BR>\n") if defined $1;
+
+ next;
+
+ @index = grep(/<!-- INDEX BEGIN -->.*<!-- INDEX END -->/s,
+ @filedata);
+ for (@index) {
+ s/<!-- INDEX BEGIN -->(\s*<!--)(.*)(-->\s*)<!-- INDEX END -->/$2/s;
+ s,#,$dir/$file#,g;
+ # print HTML "$_\n";
+ print HTML "$_\n<P><HR><P>\n";
+ }
+ }
+ print HTML "</DL>\n";
+
+ close(HTML);
+}
+
+
+sub split_on_head {
+ my($podroot, $htmldir, $splitdirs, $ignore, @splithead) = @_;
+ my($pod, $dirname, $filename);
+
+ # split the files specified in @splithead on =head[1-6] pod directives
+ print "splitting files by head.\n" if $verbose && $#splithead >= 0;
+ foreach $pod (@splithead) {
+ # figure out the directory name and filename
+ $pod =~ s,^([^/]*)$,/$1,;
+ $pod =~ m,(.*?)/(.*?)(\.pod)?$,;
+ $dirname = $1;
+ $filename = "$2.pod";
+
+ # since we are splitting this file it shouldn't be converted.
+ push(@$ignore, "$podroot/$dirname/$filename");
+
+ # split the pod
+ splitpod("$podroot/$dirname/$filename", "$podroot/$dirname", $htmldir,
+ $splitdirs);
+ }
+}
+
+
+sub split_on_item {
+ my($podroot, $splitdirs, $ignore, @splititem) = @_;
+ my($pwd, $dirname, $filename);
+
+ print "splitting files by item.\n" if $verbose && $#splititem >= 0;
+ $pwd = getcwd();
+ my $splitter = absolute_path($pwd, "$splitpod/splitpod");
+ foreach $pod (@splititem) {
+ # figure out the directory to split into
+ $pod =~ s,^([^/]*)$,/$1,;
+ $pod =~ m,(.*?)/(.*?)(\.pod)?$,;
+ $dirname = "$1/$2";
+ $filename = "$2.pod";
+
+ # since we are splitting this file it shouldn't be converted.
+ push(@$ignore, "$podroot/$dirname.pod");
+
+ # split the pod
+ push(@$splitdirs, "$podroot/$dirname");
+ if (! -d "$podroot/$dirname") {
+ mkdir("$podroot/$dirname", 0755) ||
+ die "$0: error creating directory $podroot/$dirname: $!\n";
+ }
+ chdir("$podroot/$dirname") ||
+ die "$0: error changing to directory $podroot/$dirname: $!\n";
+ die "$splitter not found. Use '-splitpod dir' option.\n"
+ unless -f $splitter;
+ system("perl", $splitter, "../$filename") &&
+ warn "$0: error running '$splitter ../$filename'"
+ ." from $podroot/$dirname";
+ }
+ chdir($pwd);
+}
+
+
+#
+# splitpod - splits a .pod file into several smaller .pod files
+# where a new file is started each time a =head[1-6] pod directive
+# is encountered in the input file.
+#
+sub splitpod {
+ my($pod, $poddir, $htmldir, $splitdirs) = @_;
+ my(@poddata, @filedata, @heads);
+ my($file, $i, $j, $prevsec, $section, $nextsec);
+
+ print "splitting $pod\n" if $verbose;
+
+ # read the file in paragraphs
+ $/ = "";
+ open(SPLITIN, "<$pod") ||
+ die "$0: error opening $pod for input: $!\n";
+ @filedata = <SPLITIN>;
+ close(SPLITIN) ||
+ die "$0: error closing $pod: $!\n";
+
+ # restore the file internally by =head[1-6] sections
+ @poddata = ();
+ for ($i = 0, $j = -1; $i <= $#filedata; $i++) {
+ $j++ if ($filedata[$i] =~ /^\s*=head[1-6]/);
+ if ($j >= 0) {
+ $poddata[$j] = "" unless defined $poddata[$j];
+ $poddata[$j] .= "\n$filedata[$i]" if $j >= 0;
+ }
+ }
+
+ # create list of =head[1-6] sections so that we can rewrite
+ # L<> links as necessary.
+ %heads = ();
+ foreach $i (0..$#poddata) {
+ $heads{htmlize($1)} = 1 if $poddata[$i] =~ /=head[1-6]\s+(.*)/;
+ }
+
+ # create a directory of a similar name and store all the
+ # files in there
+ $pod =~ s,.*/(.*),$1,; # get the last part of the name
+ $dir = $pod;
+ $dir =~ s/\.pod//g;
+ push(@$splitdirs, "$poddir/$dir");
+ mkdir("$poddir/$dir", 0755) ||
+ die "$0: could not create directory $poddir/$dir: $!\n"
+ unless -d "$poddir/$dir";
+
+ $poddata[0] =~ /^\s*=head[1-6]\s+(.*)/;
+ $section = "";
+ $nextsec = $1;
+
+ # for each section of the file create a separate pod file
+ for ($i = 0; $i <= $#poddata; $i++) {
+ # determine the "prev" and "next" links
+ $prevsec = $section;
+ $section = $nextsec;
+ if ($i < $#poddata) {
+ $poddata[$i+1] =~ /^\s*=head[1-6]\s+(.*)/;
+ $nextsec = $1;
+ } else {
+ $nextsec = "";
+ }
+
+ # determine an appropriate filename (this must correspond with
+ # what pod2html will try and guess)
+ # $poddata[$i] =~ /^\s*=head[1-6]\s+(.*)/;
+ $file = "$dir/" . htmlize($section) . ".pod";
+
+ # create the new .pod file
+ print "\tcreating $poddir/$file\n" if $verbose;
+ open(SPLITOUT, ">$poddir/$file") ||
+ die "$0: error opening $poddir/$file for output: $!\n";
+ $poddata[$i] =~ s,L<([^<>]*)>,
+ defined $heads{htmlize($1)} ? "L<$dir/$1>" : "L<$1>"
+ ,ge;
+ print SPLITOUT $poddata[$i]."\n\n";
+ print SPLITOUT "=over 4\n\n";
+ print SPLITOUT "=item *\n\nBack to L<$dir/\"$prevsec\">\n\n" if $prevsec;
+ print SPLITOUT "=item *\n\nForward to L<$dir/\"$nextsec\">\n\n" if $nextsec;
+ print SPLITOUT "=item *\n\nUp to L<$dir>\n\n";
+ print SPLITOUT "=back\n\n";
+ close(SPLITOUT) ||
+ die "$0: error closing $poddir/$file: $!\n";
+ }
+}
+
+
+#
+# installdir - takes care of converting the .pod and .pm files in the
+# current directory to .html files and then installing those.
+#
+sub installdir {
+ my($dir, $recurse, $podroot, $splitdirs, $ignore) = @_;
+ my(@dirlist, @podlist, @pmlist, $doindex);
+
+ @dirlist = (); # directories to recurse on
+ @podlist = (); # .pod files to install
+ @pmlist = (); # .pm files to install
+
+ # should files in this directory get an index?
+ $doindex = (grep($_ eq "$podroot/$dir", @$splitdirs) ? 0 : 1);
+
+ opendir(DIR, "$podroot/$dir")
+ || die "$0: error opening directory $podroot/$dir: $!\n";
+
+ # find the directories to recurse on
+ @dirlist = map { "$dir/$_" }
+ grep(-d "$podroot/$dir/$_" && !/^\.{1,2}/, readdir(DIR)) if $recurse;
+ rewinddir(DIR);
+
+ # find all the .pod files within the directory
+ @podlist = map { /^(.*)\.pod$/; "$dir/$1" }
+ grep(! -d "$podroot/$dir/$_" && /\.pod$/, readdir(DIR));
+ rewinddir(DIR);
+
+ # find all the .pm files within the directory
+ @pmlist = map { /^(.*)\.pm$/; "$dir/$1" }
+ grep(! -d "$podroot/$dir/$_" && /\.pm$/, readdir(DIR));
+
+ closedir(DIR);
+
+ # recurse on all subdirectories we kept track of
+ foreach $dir (@dirlist) {
+ installdir($dir, $recurse, $podroot, $splitdirs, $ignore);
+ }
+
+ # install all the pods we found
+ foreach $pod (@podlist) {
+ # check if we should ignore it.
+ next if grep($_ eq "$podroot/$pod.pod", @$ignore);
+
+ # check if a .pm files exists too
+ if (grep($_ eq "$pod.pm", @pmlist)) {
+ print "$0: Warning both `$podroot/$pod.pod' and "
+ . "`$podroot/$pod.pm' exist, using pod\n";
+ push(@ignore, "$pod.pm");
+ }
+ runpod2html("$pod.pod", $doindex);
+ }
+
+ # install all the .pm files we found
+ foreach $pm (@pmlist) {
+ # check if we should ignore it.
+ next if grep($_ eq "$pm.pm", @ignore);
+
+ runpod2html("$pm.pm", $doindex);
+ }
+}
+
+
+#
+# runpod2html - invokes pod2html to convert a .pod or .pm file to a .html
+# file.
+#
+sub runpod2html {
+ my($pod, $doindex) = @_;
+ my($html, $i, $dir, @dirs);
+
+ $html = $pod;
+ $html =~ s/\.(pod|pm)$/.html/g;
+
+ # make sure the destination directories exist
+ @dirs = split("/", $html);
+ $dir = "$htmldir/";
+ for ($i = 0; $i < $#dirs; $i++) {
+ if (! -d "$dir$dirs[$i]") {
+ mkdir("$dir$dirs[$i]", 0755) ||
+ die "$0: error creating directory $dir$dirs[$i]: $!\n";
+ }
+ $dir .= "$dirs[$i]/";
+ }
+
+ # invoke pod2html
+ print "$podroot/$pod => $htmldir/$html\n" if $verbose;
+#system("./pod2html",
+ Pod::Html'pod2html(
+ #Pod::Html'pod2html($pod2html,
+ "--htmlroot=$htmlroot",
+ "--podpath=".join(":", @podpath),
+ "--podroot=$podroot", "--netscape",
+ ($doindex ? "--index" : "--noindex"),
+ "--" . ($recurse ? "" : "no") . "recurse",
+ ($#libpods >= 0) ? "--libpods=" . join(":", @libpods) : "",
+ "--infile=$podroot/$pod", "--outfile=$htmldir/$html");
+ die "$0: error running $pod2html: $!\n" if $?;
+}
+
+sub htmlize { htmlify(0, @_) }
diff --git a/contrib/perl5/installman b/contrib/perl5/installman
new file mode 100755
index 000000000000..e6377204b151
--- /dev/null
+++ b/contrib/perl5/installman
@@ -0,0 +1,261 @@
+#!./perl
+BEGIN { @INC = ('lib') }
+use Config;
+use Getopt::Long;
+use File::Find;
+use File::Copy;
+use File::Path qw(mkpath);
+use ExtUtils::Packlist;
+use subs qw(unlink chmod rename link);
+use vars qw($packlist);
+require Cwd;
+
+umask 022;
+$ENV{SHELL} = 'sh' if $^O eq 'os2';
+
+$ver = $];
+$release = substr($ver,0,3); # Not used presently.
+$patchlevel = substr($ver,3,2);
+die "Patchlevel of perl ($patchlevel)",
+ "and patchlevel of config.sh ($Config{'PATCHLEVEL'}) don't match\n"
+ if $patchlevel != $Config{'PATCHLEVEL'};
+
+$usage =
+"Usage: installman --man1dir=/usr/wherever --man1ext=1
+ --man3dir=/usr/wherever --man3ext=3
+ --notify --help
+ Defaults are:
+ man1dir = $Config{'installman1dir'};
+ man1ext = $Config{'man1ext'};
+ man3dir = $Config{'installman3dir'};
+ man3ext = $Config{'man3ext'};
+ --notify (or -n) just lists commands that would be executed.\n";
+
+GetOptions( qw( man1dir=s man1ext=s man3dir=s man3ext=s notify n help))
+ || die $usage;
+die $usage if $opt_help;
+
+# These are written funny to avoid -w typo warnings.
+$man1dir = defined($opt_man1dir) ? $opt_man1dir : $Config{'installman1dir'};
+$man1ext = defined($opt_man1ext) ? $opt_man1ext : $Config{'man1ext'};
+$man3dir = defined($opt_man3dir) ? $opt_man3dir : $Config{'installman3dir'};
+$man3ext = defined($opt_man3ext) ? $opt_man3ext : $Config{'man3ext'};
+
+$notify = $opt_notify || $opt_n;
+
+#Sanity checks
+
+-x "./perl$Config{exe_ext}"
+ or warn "./perl$Config{exe_ext} not found! Have you run make?\n";
+-d $Config{'installprivlib'}
+ || warn "Perl library directory $Config{'installprivlib'} not found.
+ Have you run make install?. (Installing anyway.)\n";
+-x "t/perl$Config{exe_ext}" || warn "WARNING: You've never run 'make test'!!!",
+ " (Installing anyway.)\n";
+
+$packlist = ExtUtils::Packlist->new("$Config{installarchlib}/.packlist");
+
+# Install the main pod pages.
+runpod2man('pod', $man1dir, $man1ext);
+
+# Install the pods for library modules.
+runpod2man('lib', $man3dir, $man3ext);
+
+# Install the pods embedded in the installed scripts
+runpod2man('utils', $man1dir, $man1ext, 'c2ph');
+runpod2man('utils', $man1dir, $man1ext, 'h2ph');
+runpod2man('utils', $man1dir, $man1ext, 'h2xs');
+runpod2man('utils', $man1dir, $man1ext, 'perldoc');
+runpod2man('utils', $man1dir, $man1ext, 'perlbug');
+runpod2man('utils', $man1dir, $man1ext, 'pl2pm');
+runpod2man('utils', $man1dir, $man1ext, 'splain');
+runpod2man('x2p', $man1dir, $man1ext, 's2p');
+runpod2man('x2p', $man1dir, $man1ext, 'a2p.pod');
+runpod2man('pod', $man1dir, $man1ext, 'pod2man');
+runpod2man('pod', $man1dir, $man1ext, 'pod2html');
+
+# It would probably be better to have this page linked
+# to the c2ph man page. Or, this one could say ".so man1/c2ph.1",
+# but then it would have to pay attention to $man1dir and $man1ext.
+runpod2man('utils', $man1dir, $man1ext, 'pstruct');
+
+runpod2man('lib/ExtUtils', $man1dir, $man1ext, 'xsubpp');
+
+sub runpod2man {
+ # $script is script name if we are installing a manpage embedded
+ # in a script, undef otherwise
+ my($poddir, $mandir, $manext, $script) = @_;
+
+ my($downdir); # can't just use .. when installing xsubpp manpage
+
+ $downdir = $poddir;
+ $downdir =~ s:[^/]+:..:g;
+ my($builddir) = Cwd::getcwd();
+
+ if ($mandir eq ' ' or $mandir eq '') {
+ print STDERR "Skipping installation of ",
+ ($script ? "$poddir/$script man page" : "$poddir man pages"), ".\n";
+ return;
+ }
+
+ print STDERR "chdir $poddir\n";
+ chdir $poddir || die "Unable to cd to $poddir directory!\n$!\n";
+
+ # We insist on using the current version of pod2man in case there
+ # are enhancements or changes from previous installed versions.
+ # The error message doesn't include the '..' because the user
+ # won't be aware that we've chdir to $poddir.
+ -r "$downdir/pod/pod2man" || die "Executable pod/pod2man not found.\n";
+
+ # We want to be sure to use the current perl. We can't rely on
+ # the installed perl because it might not be actually installed
+ # yet. (The user may have set the $install* Configure variables
+ # to point to some temporary home, from which the executable gets
+ # installed by occult means.)
+ $pod2man = "$downdir/perl -I $downdir/lib $downdir/pod/pod2man --section=$manext --official";
+
+ mkpath($mandir, 1, 0777) unless $notify; # In File::Path
+ # Make a list of all the .pm and .pod files in the directory. We will
+ # always run pod2man from the lib directory and feed it the full pathname
+ # of the pod. This might be useful for pod2man someday.
+ if ($script) {
+ @modpods = ($script);
+ } else {
+ @modpods = ();
+ find(\&lsmodpods, '.');
+ }
+ foreach $mod (@modpods) {
+ $manpage = $mod;
+ my $tmp;
+ # Skip .pm files that have corresponding .pod files, and Functions.pm.
+ next if (($tmp = $mod) =~ s/\.pm$/.pod/ && -f $tmp);
+ next if ($mod eq 'Pod/Functions.pm'); #### Used only by pod itself
+
+ # Convert name from File/Basename.pm to File::Basename.3 format,
+ # if necessary.
+ $manpage =~ s#\.p(m|od)$##;
+ if ($^O eq 'os2' || $^O eq 'amigaos') {
+ $manpage =~ s#/#.#g;
+ } else {
+ $manpage =~ s#/#::#g;
+ }
+ $tmp = "${mandir}/${manpage}.tmp";
+ $manpage = "${mandir}/${manpage}.${manext}";
+ if (&cmd("$pod2man $mod > $tmp") == 0 && !$notify && -s $tmp) {
+ rename($tmp, $manpage) && next;
+ }
+ unless ($notify) {
+ unlink($tmp);
+ }
+ }
+ chdir "$builddir" || die "Unable to cd back to $builddir directory!\n$!\n";
+ print STDERR "chdir $builddir\n";
+}
+
+sub lsmodpods {
+ my $dir = $File::Find::dir;
+ my $name = $File::Find::name;
+ if (-f $_) {
+ $name =~ s#^\./##;
+ push(@modpods, $name) if ($name =~ /\.p(m|od)$/);
+ }
+}
+
+$packlist->write() unless $notify;
+print STDERR " Installation complete\n";
+
+exit 0;
+
+
+###############################################################################
+# Utility subroutines from installperl
+
+sub cmd {
+ local($cmd) = @_;
+ print STDERR " $cmd\n";
+ unless ($notify) {
+ if ($Config{d_fork}) {
+ fork ? wait : exec $cmd; # Allow user to ^C out of command.
+ }
+ else {
+ system $cmd;
+ }
+ warn "Command failed!!\n" if $?;
+ }
+ return $? != 0;
+}
+
+sub unlink {
+ local(@names) = @_;
+ my $cnt = 0;
+
+ foreach $name (@names) {
+next unless -e $name;
+chmod 0777, $name if $^O eq 'os2';
+print STDERR " unlink $name\n";
+( CORE::unlink($name) and ++$cnt
+ or warn "Couldn't unlink $name: $!\n" ) unless $notify;
+ }
+ return $cnt;
+}
+
+sub link {
+ my($from,$to) = @_;
+ my($success) = 0;
+
+ print STDERR " ln $from $to\n";
+ eval {
+ CORE::link($from, $to)
+ ? $success++
+ : ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
+ ? die "AFS" # okay inside eval {}
+ : warn "Couldn't link $from to $to: $!\n"
+ unless $notify;
+ $packlist->{$to} = { type => 'file' };
+ };
+ if ($@) {
+ File::Copy::copy($from, $to)
+ ? $success++
+ : warn "Couldn't copy $from to $to: $!\n"
+ unless $notify;
+ $packlist->{$to} = { type => 'file' };
+ }
+ $success;
+}
+
+sub rename {
+ local($from,$to) = @_;
+ if (-f $to and not unlink($to)) {
+my($i);
+for ($i = 1; $i < 50; $i++) {
+ last if CORE::rename($to, "$to.$i");
+}
+warn("Cannot rename to `$to.$i': $!"), return 0
+ if $i >= 50; # Give up!
+ }
+ link($from,$to) || return 0;
+ unlink($from);
+ $packlist->{$to} = { type => 'file' };
+}
+
+sub chmod {
+ local($mode,$name) = @_;
+
+ printf STDERR " chmod %o %s\n", $mode, $name;
+ CORE::chmod($mode,$name) || warn sprintf("Couldn't chmod %o %s: $!\n",$mode,$name)
+ unless $notify;
+}
+
+sub samepath {
+ local($p1, $p2) = @_;
+ local($dev1, $ino1, $dev2, $ino2);
+
+ if ($p1 ne $p2) {
+ ($dev1, $ino1) = stat($p1);
+ ($dev2, $ino2) = stat($p2);
+ ($dev1 == $dev2 && $ino1 == $ino2);
+ }
+ else {
+ 1;
+ }
+}
diff --git a/contrib/perl5/installperl b/contrib/perl5/installperl
new file mode 100755
index 000000000000..2db72d41aee6
--- /dev/null
+++ b/contrib/perl5/installperl
@@ -0,0 +1,600 @@
+#!./perl
+
+BEGIN {
+ require 5.004;
+ chdir '..' if !-d 'lib' and -d '..\lib';
+ @INC = 'lib';
+ $ENV{PERL5LIB} = 'lib';
+}
+
+use strict;
+use vars qw($Is_VMS $Is_W32 $Is_OS2 $nonono $versiononly $depth);
+
+BEGIN {
+ $Is_VMS = $^O eq 'VMS';
+ $Is_W32 = $^O eq 'MSWin32';
+ $Is_OS2 = $^O eq 'os2';
+ if ($Is_VMS) { eval 'use VMS::Filespec;' }
+}
+
+my $scr_ext = ($Is_VMS ? '.Com' : $Is_W32 ? '.bat' : '');
+
+use File::Find;
+use File::Compare;
+use File::Copy ();
+use File::Path ();
+use ExtUtils::Packlist;
+use Config;
+use subs qw(unlink link chmod);
+use vars qw($packlist);
+
+# override the ones in the rest of the script
+sub mkpath {
+ File::Path::mkpath(@_) unless $nonono;
+}
+
+my $mainperldir = "/usr/bin";
+my $exe_ext = $Config{exe_ext};
+
+# Allow ``make install PERLNAME=something_besides_perl'':
+my $perl = defined($ENV{PERLNAME}) ? $ENV{PERLNAME} : 'perl';
+
+while (@ARGV) {
+ $nonono = 1 if $ARGV[0] eq '-n';
+ $versiononly = 1 if $ARGV[0] eq '-v';
+ shift;
+}
+
+umask 022 unless $Is_VMS;
+
+my @scripts = qw(utils/c2ph utils/h2ph utils/h2xs utils/perlbug utils/perldoc
+ utils/pl2pm utils/splain utils/perlcc
+ x2p/s2p x2p/find2perl
+ pod/pod2man pod/pod2html pod/pod2latex pod/pod2text);
+
+if ($scr_ext) { @scripts = map { "$_$scr_ext" } @scripts; }
+
+my @pods = (<pod/*.pod>);
+
+# Specify here any .pm files that are actually architecture-dependent.
+# (Those included with XS extensions under ext/ are automatically
+# added later.)
+# Now that the default privlib has the full perl version number included,
+# we no longer have to play the trick of sticking version-specific .pm
+# files under the archlib directory.
+my %archpms = (
+ Config => 1,
+);
+
+if ($^O eq 'dos') {
+ push(@scripts,'djgpp/fixpmain');
+ $archpms{config} = $archpms{filehand} = 1;
+}
+
+if ((-e "testcompile") && (defined($ENV{'COMPILE'})))
+{
+ push(@scripts, map("$_.exe", @scripts));
+}
+
+find(sub {
+ if ("$File::Find::dir/$_" =~ m{^ext/[^/]+/(.*)\.pm$}) {
+ (my $pm = $1) =~ s{^lib/}{};
+ $archpms{$pm} = 1;
+ }
+ }, 'ext');
+
+my $ver = $];
+my $release = substr($ver,0,3); # Not used presently.
+my $patchlevel = substr($ver,3,2);
+die "Patchlevel of perl ($patchlevel)",
+ "and patchlevel of config.sh ($Config{'PATCHLEVEL'}) don't match\n"
+ if $patchlevel != $Config{'PATCHLEVEL'};
+
+# Fetch some frequently-used items from %Config
+my $installbin = $Config{installbin};
+my $installscript = $Config{installscript};
+my $installprivlib = $Config{installprivlib};
+my $installarchlib = $Config{installarchlib};
+my $installsitelib = $Config{installsitelib};
+my $installsitearch = $Config{installsitearch};
+my $installman1dir = $Config{installman1dir};
+my $man1ext = $Config{man1ext};
+my $libperl = $Config{libperl};
+# Shared library and dynamic loading suffixes.
+my $so = $Config{so};
+my $dlext = $Config{dlext};
+
+my $d_dosuid = $Config{d_dosuid};
+my $binexp = $Config{binexp};
+
+if ($Is_VMS) { # Hang in there until File::Spec hits the big time
+ foreach ( \$installbin, \$installscript, \$installprivlib,
+ \$installarchlib, \$installsitelib, \$installsitearch,
+ \$installman1dir ) {
+ $$_ = unixify($$_); $$_ =~ s:/$::;
+ }
+}
+
+# Do some quick sanity checks.
+
+if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; }
+
+ $installbin || die "No installbin directory in config.sh\n";
+-d $installbin || mkpath($installbin, 1, 0777);
+-d $installbin || $nonono || die "$installbin is not a directory\n";
+-w $installbin || $nonono || die "$installbin is not writable by you\n"
+ unless $installbin =~ m#^/afs/# || $nonono;
+
+-x 'perl' . $exe_ext || die "perl isn't executable!\n";
+-x 'suidperl' . $exe_ext|| die "suidperl isn't executable!\n" if $d_dosuid;
+
+-x 't/TEST' || $Is_W32
+ || warn "WARNING: You've never run 'make test'!!!",
+ " (Installing anyway.)\n";
+
+if ($Is_W32) {
+
+my $perldll = 'perl.' . $dlext;
+$perldll = 'perlcore.' . $dlext if $Config{'ccflags'} =~ /PERL_OBJECT/i;
+
+-f $perldll || die "No perl DLL built\n";
+
+# Install the DLL
+
+safe_unlink("$installbin/$perldll");
+copy("$perldll", "$installbin/$perldll");
+chmod(0755, "$installbin/$perldll");
+}
+
+# This will be used to store the packlist
+my $packlist = ExtUtils::Packlist->new("$installarchlib/.packlist");
+
+# First we install the version-numbered executables.
+
+if ($Is_VMS) {
+ safe_unlink("$installbin/$perl$exe_ext");
+ copy("perl$exe_ext", "$installbin/$perl$exe_ext");
+ chmod(0755, "$installbin/$perl$exe_ext");
+ safe_unlink("$installbin/${perl}shr$exe_ext");
+ copy("perlshr$exe_ext", "$installbin/${perl}shr$exe_ext");
+ chmod(0755, "$installbin/${perl}shr$exe_ext");
+}
+elsif ($^O eq 'mpeix') {
+ # MPE lacks hard links and requires that executables with special
+ # capabilities reside in the MPE namespace.
+ safe_unlink("$installbin/perl$ver$exe_ext", $Config{perlpath});
+ # Install the primary executable into the MPE namespace as perlpath.
+ copy("perl$exe_ext", $Config{perlpath});
+ chmod(0755, $Config{perlpath});
+ # Create a backup copy with the version number.
+ link($Config{perlpath}, "$installbin/perl$ver$exe_ext");
+}
+elsif ($^O ne 'dos') {
+ safe_unlink("$installbin/$perl$ver$exe_ext");
+ copy("perl$exe_ext", "$installbin/$perl$ver$exe_ext");
+ chmod(0755, "$installbin/$perl$ver$exe_ext");
+}
+else {
+ safe_unlink("$installbin/$perl.exe");
+ copy("perl.exe", "$installbin/$perl.exe");
+}
+
+safe_unlink("$installbin/s$perl$ver$exe_ext");
+if ($d_dosuid) {
+ copy("suidperl$exe_ext", "$installbin/s$perl$ver$exe_ext");
+ chmod(04711, "$installbin/s$perl$ver$exe_ext");
+}
+
+# Install library files.
+
+my ($do_installarchlib, $do_installprivlib) = (0, 0);
+
+mkpath($installprivlib, 1, 0777);
+mkpath($installarchlib, 1, 0777);
+mkpath($installsitelib, 1, 0777) if ($installsitelib);
+mkpath($installsitearch, 1, 0777) if ($installsitearch);
+
+if (chdir "lib") {
+ $do_installarchlib = ! samepath($installarchlib, '.');
+ $do_installprivlib = ! samepath($installprivlib, '.');
+ $do_installprivlib = 0 if $versiononly && !($installprivlib =~ m/\Q$]/);
+
+ if ($do_installarchlib || $do_installprivlib) {
+ find(\&installlib, '.');
+ }
+ chdir ".." || die "Can't cd back to source directory: $!\n";
+}
+else {
+ warn "Can't cd to lib to install lib files: $!\n";
+}
+
+# Install header files and libraries.
+mkpath("$installarchlib/CORE", 1, 0777);
+my @corefiles;
+if ($Is_VMS) { # We did core file selection during build
+ my $coredir = "lib/$Config{'arch'}/$]";
+ $coredir =~ tr/./_/;
+ @corefiles = <$coredir/*.*>;
+}
+else {
+ @corefiles = <*.h libperl*.*>;
+ # AIX needs perl.exp installed as well.
+ push(@corefiles,'perl.exp') if $^O eq 'aix';
+ # If they have built sperl.o...
+ push(@corefiles,'sperl.o') if -f 'sperl.o';
+}
+foreach my $file (@corefiles) {
+ # HP-UX (at least) needs to maintain execute permissions
+ # on dynamically-loadable libraries. So we do it for all.
+ copy_if_diff($file,"$installarchlib/CORE/$file")
+ and chmod($file =~ /\.(so|\Q$dlext\E)$/ ? 0555 : 0444,
+ "$installarchlib/CORE/$file");
+}
+
+# Install main perl executables
+# Make links to ordinary names if installbin directory isn't current directory.
+
+if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VMS) {
+ safe_unlink("$installbin/$perl$exe_ext", "$installbin/suid$perl$exe_ext");
+ if ($^O eq 'mpeix') {
+ # MPE doesn't support hard links, so use a symlink.
+ # We don't want another cloned copy.
+ symlink($Config{perlpath}, "$installbin/perl$exe_ext");
+ } else {
+ link("$installbin/$perl$ver$exe_ext", "$installbin/$perl$exe_ext");
+ }
+ link("$installbin/s$perl$ver$exe_ext", "$installbin/suid$perl$exe_ext")
+ if $d_dosuid;
+}
+
+# Offer to install perl in a "standard" location
+
+my $mainperl_is_instperl = 0;
+
+if (!$versiononly && !$nonono && !$Is_W32 && !$Is_VMS && -t STDIN && -t STDERR
+ && -w $mainperldir && ! samepath($mainperldir, $installbin)) {
+ my($usrbinperl) = "$mainperldir/$perl$exe_ext";
+ my($instperl) = "$installbin/$perl$exe_ext";
+ my($expinstperl) = "$binexp/$perl$exe_ext";
+
+ # First make sure $usrbinperl is not already the same as the perl we
+ # just installed.
+ if (-x $usrbinperl) {
+ # Try to be clever about mainperl being a symbolic link
+ # to binexp/perl if binexp and installbin are different.
+ $mainperl_is_instperl =
+ samepath($usrbinperl, $instperl) ||
+ samepath($usrbinperl, $expinstperl) ||
+ (($binexp ne $installbin) &&
+ (-l $usrbinperl) &&
+ ((readlink $usrbinperl) eq $expinstperl));
+ }
+ if ((! $mainperl_is_instperl) &&
+ (yn("Many scripts expect perl to be installed as $usrbinperl.\n" .
+ "Do you wish to have $usrbinperl be the same as\n" .
+ "$expinstperl? [y] ")))
+ {
+ unlink($usrbinperl);
+ ( $Config{'d_link'} eq 'define' &&
+ eval { CORE::link $instperl, $usrbinperl } ) ||
+ eval { symlink $expinstperl, $usrbinperl } ||
+ copy($instperl, $usrbinperl);
+
+ $mainperl_is_instperl = 1;
+ }
+}
+
+# Make links to ordinary names if installbin directory isn't current directory.
+
+if (!$versiononly && ! samepath($installbin, 'x2p')) {
+ safe_unlink("$installbin/a2p$exe_ext");
+ copy("x2p/a2p$exe_ext", "$installbin/a2p$exe_ext");
+ chmod(0755, "$installbin/a2p$exe_ext");
+}
+
+# cppstdin is just a script, but it is architecture-dependent, so
+# it can't safely be shared. Place it in $installbin.
+# Note that Configure doesn't build cppstin if it isn't needed, so
+# we skip this if cppstdin doesn't exist.
+if (! $versiononly && (-f 'cppstdin') && (! samepath($installbin, '.'))) {
+ safe_unlink("$installbin/cppstdin");
+ copy("cppstdin", "$installbin/cppstdin");
+ chmod(0755, "$installbin/cppstdin");
+}
+
+# Install scripts.
+
+mkpath($installscript, 1, 0777);
+
+if (! $versiononly) {
+ for (@scripts) {
+ (my $base = $_) =~ s#.*/##;
+ copy($_, "$installscript/$base");
+ chmod(0755, "$installscript/$base");
+ }
+}
+
+# pstruct should be a link to c2ph
+
+if (! $versiononly) {
+ safe_unlink("$installscript/pstruct$scr_ext");
+ if ($^O eq 'dos' or $Is_VMS) {
+ copy("$installscript/c2ph$scr_ext", "$installscript/pstruct$scr_ext");
+ } else {
+ link("$installscript/c2ph$scr_ext", "$installscript/pstruct$scr_ext");
+ }
+}
+
+# Install pod pages. Where? I guess in $installprivlib/pod.
+
+if (! $versiononly || !($installprivlib =~ m/\Q$]/)) {
+ mkpath("${installprivlib}/pod", 1, 0777);
+
+ # If Perl 5.003's perldiag.pod is there, rename it.
+ if (open POD, "${installprivlib}/pod/perldiag.pod") {
+ read POD, $_, 4000;
+ close POD;
+ # Some of Perl 5.003's diagnostic messages ended with periods.
+ if (/^=.*\.$/m) {
+ my ($from, $to) = ("${installprivlib}/pod/perldiag.pod",
+ "${installprivlib}/pod/perldiag-5.003.pod");
+ print STDERR " rename $from $to";
+ rename($from, $to)
+ or warn "Couldn't rename $from to $to: $!\n"
+ unless $nonono;
+ }
+ }
+
+ foreach my $file (@pods) {
+ # $file is a name like pod/perl.pod
+ copy_if_diff($file, "${installprivlib}/${file}");
+ }
+
+}
+
+# Check to make sure there aren't other perls around in installer's
+# path. This is probably UNIX-specific. Check all absolute directories
+# in the path except for where public executables are supposed to live.
+# Also skip $mainperl if the user opted to have it be a link to the
+# installed perl.
+
+if (!$versiononly) {
+ my ($path, @path);
+ my $dirsep = ($Is_OS2 || $Is_W32) ? ';' : ':' ;
+ ($path = $ENV{"PATH"}) =~ s:\\:/:g ;
+ @path = split(/$dirsep/, $path);
+ if ($Is_VMS) {
+ my $i = 0;
+ while (exists $ENV{'DCL$PATH' . $i}) {
+ my $dir = unixpath($ENV{'DCL$PATH' . $i}); $dir =~ s-/$--;
+ push(@path,$dir);
+ }
+ }
+ my @otherperls;
+ for (@path) {
+ next unless m,^/,;
+ # Use &samepath here because some systems have other dirs linked
+ # to $mainperldir (like SunOS)
+ next if samepath($_, $binexp);
+ next if ($mainperl_is_instperl && samepath($_, $mainperldir));
+ push(@otherperls, "$_/$perl$exe_ext")
+ if (-x "$_/$perl$exe_ext" && ! -d "$_/$perl$exe_ext");
+ }
+ if (@otherperls) {
+ print STDERR "\nWarning: $perl appears in your path in the following " .
+ "locations beyond where\nwe just installed it:\n";
+ for (@otherperls) {
+ print STDERR " ", $_, "\n";
+ }
+ print STDERR "\n";
+ }
+
+}
+
+$packlist->write() unless $nonono;
+print STDERR " Installation complete\n";
+
+exit 0;
+
+###############################################################################
+
+sub yn {
+ my($prompt) = @_;
+ my($answer);
+ my($default) = $prompt =~ m/\[([yn])\]\s*$/i;
+ print STDERR $prompt;
+ chop($answer = <STDIN>);
+ $answer = $default if $answer =~ m/^\s*$/;
+ ($answer =~ m/^[yY]/);
+}
+
+sub unlink {
+ my(@names) = @_;
+ my($cnt) = 0;
+
+ return scalar(@names) if $Is_VMS;
+
+ foreach my $name (@names) {
+ next unless -e $name;
+ chmod 0777, $name if ($Is_OS2 || $Is_W32);
+ print STDERR " unlink $name\n";
+ ( CORE::unlink($name) and ++$cnt
+ or warn "Couldn't unlink $name: $!\n" ) unless $nonono;
+ }
+ return $cnt;
+}
+
+sub safe_unlink {
+ return if $nonono or $Is_VMS;
+ my @names = @_;
+ foreach my $name (@names) {
+ next unless -e $name;
+ chmod 0777, $name if ($Is_OS2 || $Is_W32);
+ print STDERR " unlink $name\n";
+ next if CORE::unlink($name);
+ warn "Couldn't unlink $name: $!\n";
+ if ($! =~ /busy/i) {
+ print STDERR " mv $name $name.old\n";
+ safe_rename($name, "$name.old")
+ or warn "Couldn't rename $name: $!\n";
+ }
+ }
+}
+
+sub safe_rename {
+ my($from,$to) = @_;
+ if (-f $to and not unlink($to)) {
+ my($i);
+ for ($i = 1; $i < 50; $i++) {
+ last if rename($to, "$to.$i");
+ }
+ warn("Cannot rename to `$to.$i': $!"), return 0
+ if $i >= 50; # Give up!
+ }
+ link($from,$to) || return 0;
+ unlink($from);
+}
+
+sub link {
+ my($from,$to) = @_;
+ my($success) = 0;
+
+ print STDERR " ln $from $to\n";
+ eval {
+ CORE::link($from, $to)
+ ? $success++
+ : ($from =~ m#^/afs/# || $to =~ m#^/afs/#)
+ ? die "AFS" # okay inside eval {}
+ : warn "Couldn't link $from to $to: $!\n"
+ unless $nonono;
+ $packlist->{$to} = { from => $from, type => 'link' };
+ };
+ if ($@) {
+ print STDERR " creating new version of $to\n" if $Is_VMS and -e $to;
+ File::Copy::copy($from, $to)
+ ? $success++
+ : warn "Couldn't copy $from to $to: $!\n"
+ unless $nonono;
+ $packlist->{$to} = { type => 'file' };
+ }
+ $success;
+}
+
+sub chmod {
+ my($mode,$name) = @_;
+
+ return if ($^O eq 'dos');
+ printf STDERR " chmod %o %s\n", $mode, $name;
+ CORE::chmod($mode,$name)
+ || warn sprintf("Couldn't chmod %o %s: $!\n", $mode, $name)
+ unless $nonono;
+}
+
+sub copy {
+ my($from,$to) = @_;
+
+ print STDERR " cp $from $to\n";
+ print STDERR " creating new version of $to\n" if $Is_VMS and -e $to;
+ File::Copy::copy($from, $to)
+ || warn "Couldn't copy $from to $to: $!\n"
+ unless $nonono;
+ $packlist->{$to} = { type => 'file' };
+}
+
+sub samepath {
+ my($p1, $p2) = @_;
+
+ return (lc($p1) eq lc($p2)) if $Is_W32;
+
+ if ($p1 ne $p2) {
+ my($dev1, $ino1, $dev2, $ino2);
+ ($dev1, $ino1) = stat($p1);
+ ($dev2, $ino2) = stat($p2);
+ ($dev1 == $dev2 && $ino1 == $ino2);
+ }
+ else {
+ 1;
+ }
+}
+
+sub installlib {
+ my $dir = $File::Find::dir;
+ $dir =~ s#^\.(?![^/])/?##;
+ local($depth) = $dir ? "lib/$dir" : "lib";
+
+ my $name = $_;
+
+ if ($name eq 'CVS' && -d $name) {
+ $File::Find::prune = 1;
+ return;
+ }
+
+ # ignore patch backups and the .exists files.
+ return if $name =~ m{\.orig$|~$|^\.exists};
+
+ $name = "$dir/$name" if $dir ne '';
+
+ my $installlib = $installprivlib;
+ if ($dir =~ /^auto/ ||
+ ($name =~ /^(.*)\.(?:pm|pod)$/ && $archpms{$1}) ||
+ ($name =~ /^(.*)\.(?:h|lib)$/i && $Is_W32)
+ ) {
+ $installlib = $installarchlib;
+ return unless $do_installarchlib;
+ } else {
+ return unless $do_installprivlib;
+ }
+
+ if (-f $_) {
+ if (/\.(?:al|ix)$/ && !($dir =~ m[^auto/(.*)$] && $archpms{$1})) {
+ $installlib = $installprivlib;
+ #We're installing *.al and *.ix files into $installprivlib,
+ #but we have to delete old *.al and *.ix files from the 5.000
+ #distribution:
+ #This might not work because $archname might have changed.
+ unlink("$installarchlib/$name");
+ }
+ $packlist->{"$installlib/$name"} = { type => 'file' };
+ if (compare($_, "$installlib/$name") || $nonono) {
+ unlink("$installlib/$name");
+ mkpath("$installlib/$dir", 1, 0777);
+ # HP-UX (at least) needs to maintain execute permissions
+ # on dynamically-loaded libraries.
+ copy_if_diff($_, "$installlib/$name")
+ and chmod($name =~ /\.(so|$dlext)$/o ? 0555 : 0444,
+ "$installlib/$name");
+ }
+ } elsif (-d $_) {
+ mkpath("$installlib/$name", 1, 0777);
+ }
+}
+
+# Copy $from to $to, only if $from is different than $to.
+# Also preserve modification times for .a libraries.
+# On some systems, if you do
+# ranlib libperl.a
+# cp libperl.a /usr/local/lib/perl5/archlib/CORE/libperl.a
+# and then try to link against the installed libperl.a, you might
+# get an error message to the effect that the symbol table is older
+# than the library.
+# Return true if copying occurred.
+
+sub copy_if_diff {
+ my($from,$to)=@_;
+ return 1 if (($^O eq 'VMS') && (-d $from));
+ -f $from || die "$0: $from not found";
+ $packlist->{$to} = { type => 'file' };
+ if (compare($from, $to) || $nonono) {
+ safe_unlink($to); # In case we don't have write permissions.
+ if ($nonono) {
+ $from = $depth . "/" . $from if $depth;
+ }
+ copy($from, $to);
+ # Restore timestamps if it's a .a library or for OS/2.
+ if (!$nonono && ($Is_OS2 || $to =~ /\.a$/)) {
+ my ($atime, $mtime) = (stat $from)[8,9];
+ utime $atime, $mtime, $to;
+ }
+ 1;
+ }
+}
diff --git a/contrib/perl5/interp.sym b/contrib/perl5/interp.sym
new file mode 100644
index 000000000000..fbbe2a7c9c63
--- /dev/null
+++ b/contrib/perl5/interp.sym
@@ -0,0 +1,211 @@
+Argv
+Cmd
+DBcv
+DBgv
+DBline
+DBsignal
+DBsingle
+DBsub
+DBtrace
+ampergv
+archpat_auto
+argvgv
+argvoutgv
+basetime
+beginav
+bodytarget
+bostr
+cddir
+chopset
+colors
+colorset
+compcv
+compiling
+comppad
+comppad_name
+comppad_name_fill
+comppad_name_floor
+copline
+curcop
+curcopdb
+curpm
+curstack
+curstash
+curstname
+dbargs
+debdelim
+debname
+debstash
+defgv
+defoutgv
+defstash
+delaymagic
+diehook
+dirty
+dlevel
+dlmax
+doextract
+doswitches
+dowarn
+dumplvl
+e_script
+endav
+envgv
+errgv
+eval_root
+eval_start
+exitlist
+exitlistlen
+extralen
+fdpid
+filemode
+firstgv
+forkprocess
+formfeed
+formtarget
+generation
+gensym
+globalstash
+hintgv
+in_clean_all
+in_clean_objs
+in_eval
+incgv
+initav
+inplace
+bytecode_iv_overflows
+sys_intern
+last_in_gv
+last_proto
+lastfd
+lastgotoprobe
+lastscream
+lastsize
+lastspbase
+laststatval
+laststype
+leftgv
+lineary
+linestart
+localizing
+localpatches
+main_cv
+main_root
+main_start
+mainstack
+maxscream
+maxsysfd
+mess_sv
+minus_F
+minus_a
+minus_c
+minus_l
+minus_n
+minus_p
+modglobal
+modcount
+multiline
+mystrk
+nrs
+bytecode_obj_list
+bytecode_obj_list_fill
+ofmt
+ofs
+ofslen
+oldlastpm
+oldname
+op_mask
+origargc
+origargv
+origfilename
+ors
+orslen
+parsehook
+patchlevel
+pending_ident
+perldb
+perl_destruct_level
+preambled
+preambleav
+preprocess
+profiledata
+bytecode_pv
+reg_eval_set
+reg_flags
+reg_start_tmp
+reg_start_tmpl
+regbol
+regcc
+regcode
+regcompp
+regexecp
+regdata
+regdummy
+regendp
+regeol
+regflags
+regindent
+reginput
+reginterp_cnt
+reglastparen
+regnarrate
+regnaughty
+regnpar
+regcomp_parse
+regprecomp
+regprev
+regprogram
+regsawback
+regseen
+regsize
+regstartp
+regtill
+regxend
+replgv
+restartop
+rightgv
+rs
+rsfp
+rsfp_filters
+regcomp_rx
+sawampersand
+sawstudy
+sawvec
+screamfirst
+screamnext
+secondgv
+seen_zerolen
+seen_evals
+siggv
+sortcop
+sortcxix
+sortstash
+splitstr
+start_env
+statcache
+statgv
+statname
+statusvalue
+statusvalue_vms
+stdingv
+strchop
+strtab
+sub_generation
+sublex_info
+bytecode_sv
+sv_count
+sv_objcount
+sv_root
+sv_arenaroot
+tainted
+tainting
+threadnum
+thrsv
+tmps_floor
+tmps_ix
+tmps_max
+tmps_stack
+top_env
+toptarget
+unsafe
+warnhook
diff --git a/contrib/perl5/intrpvar.h b/contrib/perl5/intrpvar.h
new file mode 100644
index 000000000000..dfdcca8e1c47
--- /dev/null
+++ b/contrib/perl5/intrpvar.h
@@ -0,0 +1,218 @@
+/***********************************************/
+/* Global only to current interpreter instance */
+/***********************************************/
+
+/* Don't forget to re-run embed.pl to propagate changes! */
+
+/* The 'I' prefix is only needed for vars that need appropriate #defines
+ * generated when built with or without MULTIPLICITY. It is also used
+ * to generate the appropriate export list for win32.
+ *
+ * When building without MULTIPLICITY, these variables will be truly global.
+ *
+ * Avoid build-specific #ifdefs here, like DEBUGGING. That way,
+ * we can keep binary compatibility of the curinterp structure */
+
+/* pseudo environmental stuff */
+PERLVAR(Iorigargc, int)
+PERLVAR(Iorigargv, char **)
+PERLVAR(Ienvgv, GV *)
+PERLVAR(Isiggv, GV *)
+PERLVAR(Iincgv, GV *)
+PERLVAR(Ihintgv, GV *)
+PERLVAR(Iorigfilename, char *)
+PERLVAR(Idiehook, SV *)
+PERLVAR(Iwarnhook, SV *)
+PERLVAR(Iparsehook, SV *)
+PERLVAR(Icddir, char *) /* switches */
+PERLVAR(Iminus_c, bool)
+PERLVAR(Ipatchlevel[10],char)
+PERLVAR(Ilocalpatches, char **)
+PERLVARI(Isplitstr, char *, " ")
+PERLVAR(Ipreprocess, bool)
+PERLVAR(Iminus_n, bool)
+PERLVAR(Iminus_p, bool)
+PERLVAR(Iminus_l, bool)
+PERLVAR(Iminus_a, bool)
+PERLVAR(Iminus_F, bool)
+PERLVAR(Idoswitches, bool)
+PERLVAR(Idowarn, bool)
+PERLVAR(Idoextract, bool)
+PERLVAR(Isawampersand, bool) /* must save all match strings */
+PERLVAR(Isawstudy, bool) /* do fbm_instr on all strings */
+PERLVAR(Isawvec, bool)
+PERLVAR(Iunsafe, bool)
+PERLVAR(Iinplace, char *)
+PERLVAR(Ie_script, SV *)
+PERLVAR(Iperldb, U32)
+
+/* This value may be raised by extensions for testing purposes */
+/* 0=none, 1=full, 2=full with checks */
+PERLVARI(Iperl_destruct_level, int, 0)
+
+/* magical thingies */
+PERLVAR(Ibasetime, Time_t) /* $^T */
+PERLVAR(Iformfeed, SV *) /* $^L */
+
+
+PERLVARI(Imaxsysfd, I32, MAXSYSFD)
+ /* top fd to pass to subprocesses */
+PERLVAR(Imultiline, int) /* $*--do strings hold >1 line? */
+PERLVAR(Istatusvalue, I32) /* $? */
+#ifdef VMS
+PERLVAR(Istatusvalue_vms,U32)
+#endif
+
+/* shortcuts to various I/O objects */
+PERLVAR(Istdingv, GV *)
+PERLVAR(Idefgv, GV *)
+PERLVAR(Iargvgv, GV *)
+PERLVAR(Iargvoutgv, GV *)
+
+/* shortcuts to regexp stuff */
+/* XXX these three aren't used anywhere */
+PERLVAR(Ileftgv, GV *)
+PERLVAR(Iampergv, GV *)
+PERLVAR(Irightgv, GV *)
+
+/* this one needs to be moved to thrdvar.h and accessed via
+ * find_threadsv() when USE_THREADS */
+PERLVAR(Ireplgv, GV *)
+
+/* shortcuts to misc objects */
+PERLVAR(Ierrgv, GV *)
+
+/* shortcuts to debugging objects */
+PERLVAR(IDBgv, GV *)
+PERLVAR(IDBline, GV *)
+PERLVAR(IDBsub, GV *)
+PERLVAR(IDBsingle, SV *)
+PERLVAR(IDBtrace, SV *)
+PERLVAR(IDBsignal, SV *)
+PERLVAR(Ilineary, AV *) /* lines of script for debugger */
+PERLVAR(Idbargs, AV *) /* args to call listed by caller function */
+
+/* symbol tables */
+PERLVAR(Idebstash, HV *) /* symbol table for perldb package */
+PERLVAR(Iglobalstash, HV *) /* global keyword overrides imported here */
+PERLVAR(Icurstname, SV *) /* name of current package */
+PERLVAR(Ibeginav, AV *) /* names of BEGIN subroutines */
+PERLVAR(Iendav, AV *) /* names of END subroutines */
+PERLVAR(Iinitav, AV *) /* names of INIT subroutines */
+PERLVAR(Istrtab, HV *) /* shared string table */
+PERLVARI(Isub_generation,U32,1) /* incr to invalidate method cache */
+
+/* memory management */
+PERLVAR(Isv_count, I32) /* how many SV* are currently allocated */
+PERLVAR(Isv_objcount, I32) /* how many objects are currently allocated */
+PERLVAR(Isv_root, SV*) /* storage for SVs belonging to interp */
+PERLVAR(Isv_arenaroot, SV*) /* list of areas for garbage collection */
+
+/* funky return mechanisms */
+PERLVAR(Ilastspbase, I32)
+PERLVAR(Ilastsize, I32)
+PERLVAR(Iforkprocess, int) /* so do_open |- can return proc# */
+
+/* subprocess state */
+PERLVAR(Ifdpid, AV *) /* keep fd-to-pid mappings for my_popen */
+
+/* internal state */
+PERLVAR(Itainting, bool) /* doing taint checks */
+PERLVARI(Iop_mask, char *, NULL) /* masked operations for safe evals */
+PERLVAR(Ilast_proto, char *) /* Prototype of last sub seen. */
+
+/* trace state */
+PERLVAR(Idlevel, I32)
+PERLVARI(Idlmax, I32, 128)
+PERLVAR(Idebname, char *)
+PERLVAR(Idebdelim, char *)
+
+/* current interpreter roots */
+PERLVAR(Imain_cv, CV *)
+PERLVAR(Imain_root, OP *)
+PERLVAR(Imain_start, OP *)
+PERLVAR(Ieval_root, OP *)
+PERLVAR(Ieval_start, OP *)
+
+/* runtime control stuff */
+PERLVARI(Icurcopdb, COP *, NULL)
+PERLVARI(Icopline, line_t, NOLINE)
+
+/* statics moved here for shared library purposes */
+PERLVAR(Istrchop, SV) /* return value from chop */
+PERLVAR(Ifilemode, int) /* so nextargv() can preserve mode */
+PERLVAR(Ilastfd, int) /* what to preserve mode on */
+PERLVAR(Ioldname, char *) /* what to preserve mode on */
+PERLVAR(IArgv, char **) /* stuff to free from do_aexec, vfork safe */
+PERLVAR(ICmd, char *) /* stuff to free from do_aexec, vfork safe */
+PERLVAR(Imystrk, SV *) /* temp key string for do_each() */
+PERLVAR(Idumplvl, I32) /* indentation level on syntax tree dump */
+PERLVAR(Ioldlastpm, PMOP *) /* for saving regexp context in debugger */
+PERLVAR(Igensym, I32) /* next symbol for getsym() to define */
+PERLVAR(Ipreambled, bool)
+PERLVAR(Ipreambleav, AV *)
+PERLVARI(Ilaststatval, int, -1)
+PERLVARI(Ilaststype, I32, OP_STAT)
+PERLVAR(Imess_sv, SV *)
+
+/* XXX shouldn't these be per-thread? --GSAR */
+PERLVAR(Iors, char *) /* output record separator $\ */
+PERLVAR(Iorslen, STRLEN)
+PERLVAR(Iofmt, char *) /* output format for numbers $# */
+
+/* interpreter atexit processing */
+PERLVARI(Iexitlist, PerlExitListEntry *, NULL)
+ /* list of exit functions */
+PERLVARI(Iexitlistlen, I32, 0) /* length of same */
+PERLVAR(Imodglobal, HV *) /* per-interp module data */
+
+/* these used to be in global before 5.004_68 */
+PERLVARI(Iprofiledata, U32 *, NULL) /* table of ops, counts */
+PERLVARI(Irsfp, PerlIO * VOL, Nullfp) /* current source file pointer */
+PERLVARI(Irsfp_filters, AV *, Nullav) /* keeps active source filters */
+
+PERLVAR(Icompiling, COP) /* compiling/done executing marker */
+
+PERLVAR(Icompcv, CV *) /* currently compiling subroutine */
+PERLVAR(Icomppad, AV *) /* storage for lexically scoped temporaries */
+PERLVAR(Icomppad_name, AV *) /* variable names for "my" variables */
+PERLVAR(Icomppad_name_fill, I32) /* last "introduced" variable offset */
+PERLVAR(Icomppad_name_floor, I32) /* start of vars in innermost block */
+
+#ifdef HAVE_INTERP_INTERN
+PERLVAR(Isys_intern, struct interp_intern)
+ /* platform internals */
+#endif
+
+/* more statics moved here */
+PERLVARI(Igeneration, int, 100) /* from op.c */
+PERLVAR(IDBcv, CV *) /* from perl.c */
+PERLVAR(Iarchpat_auto, char*) /* from perl.c */
+
+PERLVARI(Iin_clean_objs,bool, FALSE) /* from sv.c */
+PERLVARI(Iin_clean_all, bool, FALSE) /* from sv.c */
+
+PERLVAR(Ilinestart, char *) /* beg. of most recently read line */
+PERLVAR(Ipending_ident, char) /* pending identifier lookup */
+PERLVAR(Isublex_info, SUBLEXINFO) /* from toke.c */
+
+#ifdef USE_THREADS
+PERLVAR(Ithrsv, SV *) /* struct perl_thread for main thread */
+PERLVARI(Ithreadnum, U32, 0) /* incremented each thread creation */
+#endif /* USE_THREADS */
+
+PERLVARI(Ibytecode_iv_overflows,int, 0) /* from bytecode.h */
+PERLVAR(Ibytecode_sv, SV *)
+PERLVAR(Ibytecode_pv, XPV)
+PERLVAR(Ibytecode_obj_list, void **)
+PERLVARI(Ibytecode_obj_list_fill, I32, -1)
+
+#ifdef PERL_OBJECT
+PERLVARI(piMem, IPerlMem*, NULL)
+PERLVARI(piENV, IPerlEnv*, NULL)
+PERLVARI(piStdIO, IPerlStdIO*, NULL)
+PERLVARI(piLIO, IPerlLIO*, NULL)
+PERLVARI(piDir, IPerlDir*, NULL)
+PERLVARI(piSock, IPerlSock*, NULL)
+PERLVARI(piProc, IPerlProc*, NULL)
+#endif
diff --git a/contrib/perl5/iperlsys.h b/contrib/perl5/iperlsys.h
new file mode 100644
index 000000000000..91389a2b7b50
--- /dev/null
+++ b/contrib/perl5/iperlsys.h
@@ -0,0 +1,930 @@
+/*
+ * iperlsys.h - Perl's interface to the system
+ *
+ * This file defines the system level functionality that perl needs.
+ *
+ * When using C, this definition is in the form of a set of macros
+ * that can be #defined to the system-level function (or a wrapper
+ * provided elsewhere).
+ *
+ * When using C++ with -DPERL_OBJECT, this definition is in the
+ * form of a set of virtual base classes which must be subclassed to
+ * provide a real implementation. The Perl Object will use instances
+ * of this implementation to use the system-level functionality.
+ *
+ * GSAR 21-JUN-98
+ */
+
+#ifndef __Inc__IPerl___
+#define __Inc__IPerl___
+
+/*
+ * PerlXXX_YYY explained - DickH and DougL @ ActiveState.com
+ *
+ * XXX := functional group
+ * YYY := stdlib/OS function name
+ *
+ * Continuing with the theme of PerlIO, all OS functionality was
+ * encapsulated into one of several interfaces.
+ *
+ * PerlIO - stdio
+ * PerlLIO - low level I/O
+ * PerlMem - malloc, realloc, free
+ * PerlDir - directory related
+ * PerlEnv - process environment handling
+ * PerlProc - process control
+ * PerlSock - socket functions
+ *
+ *
+ * The features of this are:
+ * 1. All OS dependant code is in the Perl Host and not the Perl Core.
+ * (At least this is the holy grail goal of this work)
+ * 2. The Perl Host (see perl.h for description) can provide a new and
+ * improved interface to OS functionality if required.
+ * 3. Developers can easily hook into the OS calls for instrumentation
+ * or diagnostic purposes.
+ *
+ * What was changed to do this:
+ * 1. All calls to OS functions were replaced with PerlXXX_YYY
+ *
+ */
+
+
+/*
+ Interface for perl stdio functions
+*/
+
+
+/* Clean up (or at least document) the various possible #defines.
+ This section attempts to match the 5.003_03 Configure variables
+ onto the 5.003_02 header file values.
+ I can't figure out where USE_STDIO was supposed to be set.
+ --AD
+*/
+#ifndef USE_PERLIO
+# define PERLIO_IS_STDIO
+#endif
+
+/* Below is the 5.003_02 stuff. */
+#ifdef USE_STDIO
+# ifndef PERLIO_IS_STDIO
+# define PERLIO_IS_STDIO
+# endif
+#else
+extern void PerlIO_init _((void));
+#endif
+
+#ifdef PERL_OBJECT
+
+#ifndef PerlIO
+typedef struct _PerlIO PerlIO;
+#endif
+
+class IPerlStdIO
+{
+public:
+ virtual PerlIO * Stdin(void) = 0;
+ virtual PerlIO * Stdout(void) = 0;
+ virtual PerlIO * Stderr(void) = 0;
+ virtual PerlIO * Open(const char *, const char *, int &err) = 0;
+ virtual int Close(PerlIO*, int &err) = 0;
+ virtual int Eof(PerlIO*, int &err) = 0;
+ virtual int Error(PerlIO*, int &err) = 0;
+ virtual void Clearerr(PerlIO*, int &err) = 0;
+ virtual int Getc(PerlIO*, int &err) = 0;
+ virtual char * GetBase(PerlIO *, int &err) = 0;
+ virtual int GetBufsiz(PerlIO *, int &err) = 0;
+ virtual int GetCnt(PerlIO *, int &err) = 0;
+ virtual char * GetPtr(PerlIO *, int &err) = 0;
+ virtual char * Gets(PerlIO*, char*, int, int& err) = 0;
+ virtual int Putc(PerlIO*, int, int &err) = 0;
+ virtual int Puts(PerlIO*, const char *, int &err) = 0;
+ virtual int Flush(PerlIO*, int &err) = 0;
+ virtual int Ungetc(PerlIO*,int, int &err) = 0;
+ virtual int Fileno(PerlIO*, int &err) = 0;
+ virtual PerlIO * Fdopen(int, const char *, int &err) = 0;
+ virtual PerlIO * Reopen(const char*, const char*, PerlIO*, int &err) = 0;
+ virtual SSize_t Read(PerlIO*,void *,Size_t, int &err) = 0;
+ virtual SSize_t Write(PerlIO*,const void *,Size_t, int &err) = 0;
+ virtual void SetBuf(PerlIO *, char*, int &err) = 0;
+ virtual int SetVBuf(PerlIO *, char*, int, Size_t, int &err) = 0;
+ virtual void SetCnt(PerlIO *, int, int &err) = 0;
+ virtual void SetPtrCnt(PerlIO *, char *, int, int& err) = 0;
+ virtual void Setlinebuf(PerlIO*, int &err) = 0;
+ virtual int Printf(PerlIO*, int &err, const char *,...) = 0;
+ virtual int Vprintf(PerlIO*, int &err, const char *, va_list) = 0;
+ virtual long Tell(PerlIO*, int &err) = 0;
+ virtual int Seek(PerlIO*, off_t, int, int &err) = 0;
+ virtual void Rewind(PerlIO*, int &err) = 0;
+ virtual PerlIO * Tmpfile(int &err) = 0;
+ virtual int Getpos(PerlIO*, Fpos_t *, int &err) = 0;
+ virtual int Setpos(PerlIO*, const Fpos_t *, int &err) = 0;
+ virtual void Init(int &err) = 0;
+ virtual void InitOSExtras(void* p) = 0;
+#ifdef WIN32
+ virtual int OpenOSfhandle(long osfhandle, int flags) = 0;
+ virtual int GetOSfhandle(int filenum) = 0;
+#endif
+};
+
+
+
+#ifdef USE_STDIO_PTR
+# define PerlIO_has_cntptr(f) 1
+# ifdef STDIO_CNT_LVALUE
+# define PerlIO_canset_cnt(f) 1
+# ifdef STDIO_PTR_LVALUE
+# define PerlIO_fast_gets(f) 1
+# endif
+# else
+# define PerlIO_canset_cnt(f) 0
+# endif
+#else /* USE_STDIO_PTR */
+# define PerlIO_has_cntptr(f) 0
+# define PerlIO_canset_cnt(f) 0
+#endif /* USE_STDIO_PTR */
+
+#ifndef PerlIO_fast_gets
+#define PerlIO_fast_gets(f) 0
+#endif
+
+#ifdef FILE_base
+#define PerlIO_has_base(f) 1
+#else
+#define PerlIO_has_base(f) 0
+#endif
+
+#define PerlIO_stdin() PL_piStdIO->Stdin()
+#define PerlIO_stdout() PL_piStdIO->Stdout()
+#define PerlIO_stderr() PL_piStdIO->Stderr()
+#define PerlIO_open(x,y) PL_piStdIO->Open((x),(y), ErrorNo())
+#define PerlIO_close(f) PL_piStdIO->Close((f), ErrorNo())
+#define PerlIO_eof(f) PL_piStdIO->Eof((f), ErrorNo())
+#define PerlIO_error(f) PL_piStdIO->Error((f), ErrorNo())
+#define PerlIO_clearerr(f) PL_piStdIO->Clearerr((f), ErrorNo())
+#define PerlIO_getc(f) PL_piStdIO->Getc((f), ErrorNo())
+#define PerlIO_get_base(f) PL_piStdIO->GetBase((f), ErrorNo())
+#define PerlIO_get_bufsiz(f) PL_piStdIO->GetBufsiz((f), ErrorNo())
+#define PerlIO_get_cnt(f) PL_piStdIO->GetCnt((f), ErrorNo())
+#define PerlIO_get_ptr(f) PL_piStdIO->GetPtr((f), ErrorNo())
+#define PerlIO_putc(f,c) PL_piStdIO->Putc((f),(c), ErrorNo())
+#define PerlIO_puts(f,s) PL_piStdIO->Puts((f),(s), ErrorNo())
+#define PerlIO_flush(f) PL_piStdIO->Flush((f), ErrorNo())
+#define PerlIO_gets(s, n, fp) PL_piStdIO->Gets((fp), s, n, ErrorNo())
+#define PerlIO_ungetc(f,c) PL_piStdIO->Ungetc((f),(c), ErrorNo())
+#define PerlIO_fileno(f) PL_piStdIO->Fileno((f), ErrorNo())
+#define PerlIO_fdopen(f, s) PL_piStdIO->Fdopen((f),(s), ErrorNo())
+#define PerlIO_reopen(p, m, f) PL_piStdIO->Reopen((p), (m), (f), ErrorNo())
+#define PerlIO_read(f,buf,count) \
+ (SSize_t)PL_piStdIO->Read((f), (buf), (count), ErrorNo())
+#define PerlIO_write(f,buf,count) \
+ PL_piStdIO->Write((f), (buf), (count), ErrorNo())
+#define PerlIO_setbuf(f,b) PL_piStdIO->SetBuf((f), (b), ErrorNo())
+#define PerlIO_setvbuf(f,b,t,s) PL_piStdIO->SetVBuf((f), (b), (t), (s), ErrorNo())
+#define PerlIO_set_cnt(f,c) PL_piStdIO->SetCnt((f), (c), ErrorNo())
+#define PerlIO_set_ptrcnt(f,p,c) \
+ PL_piStdIO->SetPtrCnt((f), (p), (c), ErrorNo())
+#define PerlIO_setlinebuf(f) PL_piStdIO->Setlinebuf((f), ErrorNo())
+#define PerlIO_printf fprintf
+#define PerlIO_stdoutf PL_piStdIO->Printf
+#define PerlIO_vprintf(f,fmt,a) PL_piStdIO->Vprintf((f), ErrorNo(), (fmt),a)
+#define PerlIO_tell(f) PL_piStdIO->Tell((f), ErrorNo())
+#define PerlIO_seek(f,o,w) PL_piStdIO->Seek((f),(o),(w), ErrorNo())
+#define PerlIO_getpos(f,p) PL_piStdIO->Getpos((f),(p), ErrorNo())
+#define PerlIO_setpos(f,p) PL_piStdIO->Setpos((f),(p), ErrorNo())
+#define PerlIO_rewind(f) PL_piStdIO->Rewind((f), ErrorNo())
+#define PerlIO_tmpfile() PL_piStdIO->Tmpfile(ErrorNo())
+#define PerlIO_init() PL_piStdIO->Init(ErrorNo())
+#undef init_os_extras
+#define init_os_extras() PL_piStdIO->InitOSExtras(this)
+
+#else /* PERL_OBJECT */
+
+#include "perlsdio.h"
+
+#endif /* PERL_OBJECT */
+
+#ifndef PERLIO_IS_STDIO
+#ifdef USE_SFIO
+#include "perlsfio.h"
+#endif /* USE_SFIO */
+#endif /* PERLIO_IS_STDIO */
+
+#ifndef EOF
+#define EOF (-1)
+#endif
+
+/* This is to catch case with no stdio */
+#ifndef BUFSIZ
+#define BUFSIZ 1024
+#endif
+
+#ifndef SEEK_SET
+#define SEEK_SET 0
+#endif
+
+#ifndef SEEK_CUR
+#define SEEK_CUR 1
+#endif
+
+#ifndef SEEK_END
+#define SEEK_END 2
+#endif
+
+#ifndef PerlIO
+struct _PerlIO;
+#define PerlIO struct _PerlIO
+#endif /* No PerlIO */
+
+#ifndef Fpos_t
+#define Fpos_t long
+#endif
+
+#ifndef NEXT30_NO_ATTRIBUTE
+#ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */
+#ifdef __attribute__ /* Avoid possible redefinition errors */
+#undef __attribute__
+#endif
+#define __attribute__(attr)
+#endif
+#endif
+
+#ifndef PerlIO_stdoutf
+extern int PerlIO_stdoutf _((const char *,...))
+ __attribute__((format (printf, 1, 2)));
+#endif
+#ifndef PerlIO_puts
+extern int PerlIO_puts _((PerlIO *,const char *));
+#endif
+#ifndef PerlIO_open
+extern PerlIO * PerlIO_open _((const char *,const char *));
+#endif
+#ifndef PerlIO_close
+extern int PerlIO_close _((PerlIO *));
+#endif
+#ifndef PerlIO_eof
+extern int PerlIO_eof _((PerlIO *));
+#endif
+#ifndef PerlIO_error
+extern int PerlIO_error _((PerlIO *));
+#endif
+#ifndef PerlIO_clearerr
+extern void PerlIO_clearerr _((PerlIO *));
+#endif
+#ifndef PerlIO_getc
+extern int PerlIO_getc _((PerlIO *));
+#endif
+#ifndef PerlIO_putc
+extern int PerlIO_putc _((PerlIO *,int));
+#endif
+#ifndef PerlIO_flush
+extern int PerlIO_flush _((PerlIO *));
+#endif
+#ifndef PerlIO_ungetc
+extern int PerlIO_ungetc _((PerlIO *,int));
+#endif
+#ifndef PerlIO_fileno
+extern int PerlIO_fileno _((PerlIO *));
+#endif
+#ifndef PerlIO_fdopen
+extern PerlIO * PerlIO_fdopen _((int, const char *));
+#endif
+#ifndef PerlIO_importFILE
+extern PerlIO * PerlIO_importFILE _((FILE *,int));
+#endif
+#ifndef PerlIO_exportFILE
+extern FILE * PerlIO_exportFILE _((PerlIO *,int));
+#endif
+#ifndef PerlIO_findFILE
+extern FILE * PerlIO_findFILE _((PerlIO *));
+#endif
+#ifndef PerlIO_releaseFILE
+extern void PerlIO_releaseFILE _((PerlIO *,FILE *));
+#endif
+#ifndef PerlIO_read
+extern SSize_t PerlIO_read _((PerlIO *,void *,Size_t));
+#endif
+#ifndef PerlIO_write
+extern SSize_t PerlIO_write _((PerlIO *,const void *,Size_t));
+#endif
+#ifndef PerlIO_setlinebuf
+extern void PerlIO_setlinebuf _((PerlIO *));
+#endif
+#ifndef PerlIO_printf
+extern int PerlIO_printf _((PerlIO *, const char *,...))
+ __attribute__((format (printf, 2, 3)));
+#endif
+#ifndef PerlIO_sprintf
+extern int PerlIO_sprintf _((char *, int, const char *,...))
+ __attribute__((format (printf, 3, 4)));
+#endif
+#ifndef PerlIO_vprintf
+extern int PerlIO_vprintf _((PerlIO *, const char *, va_list));
+#endif
+#ifndef PerlIO_tell
+extern long PerlIO_tell _((PerlIO *));
+#endif
+#ifndef PerlIO_seek
+extern int PerlIO_seek _((PerlIO *,off_t,int));
+#endif
+#ifndef PerlIO_rewind
+extern void PerlIO_rewind _((PerlIO *));
+#endif
+#ifndef PerlIO_has_base
+extern int PerlIO_has_base _((PerlIO *));
+#endif
+#ifndef PerlIO_has_cntptr
+extern int PerlIO_has_cntptr _((PerlIO *));
+#endif
+#ifndef PerlIO_fast_gets
+extern int PerlIO_fast_gets _((PerlIO *));
+#endif
+#ifndef PerlIO_canset_cnt
+extern int PerlIO_canset_cnt _((PerlIO *));
+#endif
+#ifndef PerlIO_get_ptr
+extern STDCHAR * PerlIO_get_ptr _((PerlIO *));
+#endif
+#ifndef PerlIO_get_cnt
+extern int PerlIO_get_cnt _((PerlIO *));
+#endif
+#ifndef PerlIO_set_cnt
+extern void PerlIO_set_cnt _((PerlIO *,int));
+#endif
+#ifndef PerlIO_set_ptrcnt
+extern void PerlIO_set_ptrcnt _((PerlIO *,STDCHAR *,int));
+#endif
+#ifndef PerlIO_get_base
+extern STDCHAR * PerlIO_get_base _((PerlIO *));
+#endif
+#ifndef PerlIO_get_bufsiz
+extern int PerlIO_get_bufsiz _((PerlIO *));
+#endif
+#ifndef PerlIO_tmpfile
+extern PerlIO * PerlIO_tmpfile _((void));
+#endif
+#ifndef PerlIO_stdin
+extern PerlIO * PerlIO_stdin _((void));
+#endif
+#ifndef PerlIO_stdout
+extern PerlIO * PerlIO_stdout _((void));
+#endif
+#ifndef PerlIO_stderr
+extern PerlIO * PerlIO_stderr _((void));
+#endif
+#ifndef PerlIO_getpos
+extern int PerlIO_getpos _((PerlIO *,Fpos_t *));
+#endif
+#ifndef PerlIO_setpos
+extern int PerlIO_setpos _((PerlIO *,const Fpos_t *));
+#endif
+
+
+/*
+ * Interface for directory functions
+ */
+
+#ifdef PERL_OBJECT
+
+class IPerlDir
+{
+public:
+ virtual int Makedir(const char *dirname, int mode, int &err) = 0;
+ virtual int Chdir(const char *dirname, int &err) = 0;
+ virtual int Rmdir(const char *dirname, int &err) = 0;
+ virtual int Close(DIR *dirp, int &err) = 0;
+ virtual DIR * Open(char *filename, int &err) = 0;
+ virtual struct direct *Read(DIR *dirp, int &err) = 0;
+ virtual void Rewind(DIR *dirp, int &err) = 0;
+ virtual void Seek(DIR *dirp, long loc, int &err) = 0;
+ virtual long Tell(DIR *dirp, int &err) = 0;
+};
+
+#define PerlDir_mkdir(name, mode) \
+ PL_piDir->Makedir((name), (mode), ErrorNo())
+#define PerlDir_chdir(name) \
+ PL_piDir->Chdir((name), ErrorNo())
+#define PerlDir_rmdir(name) \
+ PL_piDir->Rmdir((name), ErrorNo())
+#define PerlDir_close(dir) \
+ PL_piDir->Close((dir), ErrorNo())
+#define PerlDir_open(name) \
+ PL_piDir->Open((name), ErrorNo())
+#define PerlDir_read(dir) \
+ PL_piDir->Read((dir), ErrorNo())
+#define PerlDir_rewind(dir) \
+ PL_piDir->Rewind((dir), ErrorNo())
+#define PerlDir_seek(dir, loc) \
+ PL_piDir->Seek((dir), (loc), ErrorNo())
+#define PerlDir_tell(dir) \
+ PL_piDir->Tell((dir), ErrorNo())
+
+#else /* PERL_OBJECT */
+
+#define PerlDir_mkdir(name, mode) Mkdir((name), (mode))
+#ifdef VMS
+# define PerlDir_chdir(n) chdir(((n) && *(n)) ? (n) : "SYS$LOGIN")
+#else
+# define PerlDir_chdir(name) chdir((name))
+#endif
+#define PerlDir_rmdir(name) rmdir((name))
+#define PerlDir_close(dir) closedir((dir))
+#define PerlDir_open(name) opendir((name))
+#define PerlDir_read(dir) readdir((dir))
+#define PerlDir_rewind(dir) rewinddir((dir))
+#define PerlDir_seek(dir, loc) seekdir((dir), (loc))
+#define PerlDir_tell(dir) telldir((dir))
+
+#endif /* PERL_OBJECT */
+
+/*
+ Interface for perl environment functions
+*/
+
+#ifdef PERL_OBJECT
+
+class IPerlEnv
+{
+public:
+ virtual char * Getenv(const char *varname, int &err) = 0;
+ virtual int Putenv(const char *envstring, int &err) = 0;
+ virtual char * LibPath(char *patchlevel) =0;
+ virtual char * SiteLibPath(char *patchlevel) =0;
+};
+
+#define PerlEnv_putenv(str) PL_piENV->Putenv((str), ErrorNo())
+#define PerlEnv_getenv(str) PL_piENV->Getenv((str), ErrorNo())
+#ifdef WIN32
+#define PerlEnv_lib_path(str) PL_piENV->LibPath((str))
+#define PerlEnv_sitelib_path(str) PL_piENV->SiteLibPath((str))
+#endif
+
+#else /* PERL_OBJECT */
+
+#define PerlEnv_putenv(str) putenv((str))
+#define PerlEnv_getenv(str) getenv((str))
+
+#endif /* PERL_OBJECT */
+
+/*
+ Interface for perl low-level IO functions
+*/
+
+#ifdef PERL_OBJECT
+
+class IPerlLIO
+{
+public:
+ virtual int Access(const char *path, int mode, int &err) = 0;
+ virtual int Chmod(const char *filename, int pmode, int &err) = 0;
+ virtual int Chown(const char *filename, uid_t owner,
+ gid_t group, int &err) = 0;
+ virtual int Chsize(int handle, long size, int &err) = 0;
+ virtual int Close(int handle, int &err) = 0;
+ virtual int Dup(int handle, int &err) = 0;
+ virtual int Dup2(int handle1, int handle2, int &err) = 0;
+ virtual int Flock(int fd, int oper, int &err) = 0;
+ virtual int FileStat(int handle, struct stat *buffer, int &err) = 0;
+ virtual int IOCtl(int i, unsigned int u, char *data, int &err) = 0;
+ virtual int Isatty(int handle, int &err) = 0;
+ virtual long Lseek(int handle, long offset, int origin, int &err) = 0;
+ virtual int Lstat(const char *path, struct stat *buffer, int &err) = 0;
+ virtual char * Mktemp(char *Template, int &err) = 0;
+ virtual int Open(const char *filename, int oflag, int &err) = 0;
+ virtual int Open(const char *filename, int oflag,
+ int pmode, int &err) = 0;
+ virtual int Read(int handle, void *buffer,
+ unsigned int count, int &err) = 0;
+ virtual int Rename(const char *oname,
+ const char *newname, int &err) = 0;
+ virtual int Setmode(int handle, int mode, int &err) = 0;
+ virtual int NameStat(const char *path,
+ struct stat *buffer, int &err) = 0;
+ virtual char * Tmpnam(char *string, int &err) = 0;
+ virtual int Umask(int pmode, int &err) = 0;
+ virtual int Unlink(const char *filename, int &err) = 0;
+ virtual int Utime(char *filename, struct utimbuf *times, int &err) = 0;
+ virtual int Write(int handle, const void *buffer,
+ unsigned int count, int &err) = 0;
+};
+
+#define PerlLIO_access(file, mode) \
+ PL_piLIO->Access((file), (mode), ErrorNo())
+#define PerlLIO_chmod(file, mode) \
+ PL_piLIO->Chmod((file), (mode), ErrorNo())
+#define PerlLIO_chown(file, owner, group) \
+ PL_piLIO->Chown((file), (owner), (group), ErrorNo())
+#define PerlLIO_chsize(fd, size) \
+ PL_piLIO->Chsize((fd), (size), ErrorNo())
+#define PerlLIO_close(fd) \
+ PL_piLIO->Close((fd), ErrorNo())
+#define PerlLIO_dup(fd) \
+ PL_piLIO->Dup((fd), ErrorNo())
+#define PerlLIO_dup2(fd1, fd2) \
+ PL_piLIO->Dup2((fd1), (fd2), ErrorNo())
+#define PerlLIO_flock(fd, op) \
+ PL_piLIO->Flock((fd), (op), ErrorNo())
+#define PerlLIO_fstat(fd, buf) \
+ PL_piLIO->FileStat((fd), (buf), ErrorNo())
+#define PerlLIO_ioctl(fd, u, buf) \
+ PL_piLIO->IOCtl((fd), (u), (buf), ErrorNo())
+#define PerlLIO_isatty(fd) \
+ PL_piLIO->Isatty((fd), ErrorNo())
+#define PerlLIO_lseek(fd, offset, mode) \
+ PL_piLIO->Lseek((fd), (offset), (mode), ErrorNo())
+#define PerlLIO_lstat(name, buf) \
+ PL_piLIO->Lstat((name), (buf), ErrorNo())
+#define PerlLIO_mktemp(file) \
+ PL_piLIO->Mktemp((file), ErrorNo())
+#define PerlLIO_open(file, flag) \
+ PL_piLIO->Open((file), (flag), ErrorNo())
+#define PerlLIO_open3(file, flag, perm) \
+ PL_piLIO->Open((file), (flag), (perm), ErrorNo())
+#define PerlLIO_read(fd, buf, count) \
+ PL_piLIO->Read((fd), (buf), (count), ErrorNo())
+#define PerlLIO_rename(oname, newname) \
+ PL_piLIO->Rename((oname), (newname), ErrorNo())
+#define PerlLIO_setmode(fd, mode) \
+ PL_piLIO->Setmode((fd), (mode), ErrorNo())
+#define PerlLIO_stat(name, buf) \
+ PL_piLIO->NameStat((name), (buf), ErrorNo())
+#define PerlLIO_tmpnam(str) \
+ PL_piLIO->Tmpnam((str), ErrorNo())
+#define PerlLIO_umask(mode) \
+ PL_piLIO->Umask((mode), ErrorNo())
+#define PerlLIO_unlink(file) \
+ PL_piLIO->Unlink((file), ErrorNo())
+#define PerlLIO_utime(file, time) \
+ PL_piLIO->Utime((file), (time), ErrorNo())
+#define PerlLIO_write(fd, buf, count) \
+ PL_piLIO->Write((fd), (buf), (count), ErrorNo())
+
+#else /* PERL_OBJECT */
+
+#define PerlLIO_access(file, mode) access((file), (mode))
+#define PerlLIO_chmod(file, mode) chmod((file), (mode))
+#define PerlLIO_chown(file, owner, grp) chown((file), (owner), (grp))
+#define PerlLIO_chsize(fd, size) chsize((fd), (size))
+#define PerlLIO_close(fd) close((fd))
+#define PerlLIO_dup(fd) dup((fd))
+#define PerlLIO_dup2(fd1, fd2) dup2((fd1), (fd2))
+#define PerlLIO_flock(fd, op) FLOCK((fd), (op))
+#define PerlLIO_fstat(fd, buf) Fstat((fd), (buf))
+#define PerlLIO_ioctl(fd, u, buf) ioctl((fd), (u), (buf))
+#define PerlLIO_isatty(fd) isatty((fd))
+#define PerlLIO_lseek(fd, offset, mode) lseek((fd), (offset), (mode))
+#define PerlLIO_lstat(name, buf) lstat((name), (buf))
+#define PerlLIO_mktemp(file) mktemp((file))
+#define PerlLIO_mkstemp(file) mkstemp((file))
+#define PerlLIO_open(file, flag) open((file), (flag))
+#define PerlLIO_open3(file, flag, perm) open((file), (flag), (perm))
+#define PerlLIO_read(fd, buf, count) read((fd), (buf), (count))
+#define PerlLIO_rename(old, new) rename((old), (new))
+#define PerlLIO_setmode(fd, mode) setmode((fd), (mode))
+#define PerlLIO_stat(name, buf) Stat((name), (buf))
+#define PerlLIO_tmpnam(str) tmpnam((str))
+#define PerlLIO_umask(mode) umask((mode))
+#define PerlLIO_unlink(file) unlink((file))
+#define PerlLIO_utime(file, time) utime((file), (time))
+#define PerlLIO_write(fd, buf, count) write((fd), (buf), (count))
+
+#endif /* PERL_OBJECT */
+
+/*
+ Interface for perl memory allocation
+*/
+
+#ifdef PERL_OBJECT
+
+class IPerlMem
+{
+public:
+ virtual void * Malloc(size_t) = 0;
+ virtual void * Realloc(void*, size_t) = 0;
+ virtual void Free(void*) = 0;
+};
+
+#define PerlMem_malloc(size) PL_piMem->Malloc((size))
+#define PerlMem_realloc(buf, size) PL_piMem->Realloc((buf), (size))
+#define PerlMem_free(buf) PL_piMem->Free((buf))
+
+#else /* PERL_OBJECT */
+
+#define PerlMem_malloc(size) malloc((size))
+#define PerlMem_realloc(buf, size) realloc((buf), (size))
+#define PerlMem_free(buf) free((buf))
+
+#endif /* PERL_OBJECT */
+
+/*
+ Interface for perl process functions
+*/
+
+
+#ifdef PERL_OBJECT
+
+#ifndef Sighandler_t
+typedef Signal_t (*Sighandler_t) _((int));
+#endif
+#ifndef jmp_buf
+#include <setjmp.h>
+#endif
+
+class IPerlProc
+{
+public:
+ virtual void Abort(void) = 0;
+ virtual char * Crypt(const char* clear, const char* salt) = 0;
+ virtual void Exit(int status) = 0;
+ virtual void _Exit(int status) = 0;
+ virtual int Execl(const char *cmdname, const char *arg0,
+ const char *arg1, const char *arg2,
+ const char *arg3) = 0;
+ virtual int Execv(const char *cmdname, const char *const *argv) = 0;
+ virtual int Execvp(const char *cmdname, const char *const *argv) = 0;
+ virtual uid_t Getuid(void) = 0;
+ virtual uid_t Geteuid(void) = 0;
+ virtual gid_t Getgid(void) = 0;
+ virtual gid_t Getegid(void) = 0;
+ virtual char * Getlogin(void) = 0;
+ virtual int Kill(int pid, int sig) = 0;
+ virtual int Killpg(int pid, int sig) = 0;
+ virtual int PauseProc(void) = 0;
+ virtual PerlIO * Popen(const char *command, const char *mode) = 0;
+ virtual int Pclose(PerlIO *stream) = 0;
+ virtual int Pipe(int *phandles) = 0;
+ virtual int Setuid(uid_t uid) = 0;
+ virtual int Setgid(gid_t gid) = 0;
+ virtual int Sleep(unsigned int) = 0;
+ virtual int Times(struct tms *timebuf) = 0;
+ virtual int Wait(int *status) = 0;
+ virtual int Waitpid(int pid, int *status, int flags) = 0;
+ virtual Sighandler_t Signal(int sig, Sighandler_t subcode) = 0;
+#ifdef WIN32
+ virtual void GetSysMsg(char*& msg, DWORD& dwLen, DWORD dwErr) = 0;
+ virtual void FreeBuf(char* msg) = 0;
+ virtual BOOL DoCmd(char *cmd) = 0;
+ virtual int Spawn(char*cmds) = 0;
+ virtual int Spawnvp(int mode, const char *cmdname,
+ const char *const *argv) = 0;
+ virtual int ASpawn(void *vreally, void **vmark, void **vsp) = 0;
+#endif
+};
+
+#define PerlProc_abort() PL_piProc->Abort()
+#define PerlProc_crypt(c,s) PL_piProc->Crypt((c), (s))
+#define PerlProc_exit(s) PL_piProc->Exit((s))
+#define PerlProc__exit(s) PL_piProc->_Exit((s))
+#define PerlProc_execl(c, w, x, y, z) \
+ PL_piProc->Execl((c), (w), (x), (y), (z))
+
+#define PerlProc_execv(c, a) PL_piProc->Execv((c), (a))
+#define PerlProc_execvp(c, a) PL_piProc->Execvp((c), (a))
+#define PerlProc_getuid() PL_piProc->Getuid()
+#define PerlProc_geteuid() PL_piProc->Geteuid()
+#define PerlProc_getgid() PL_piProc->Getgid()
+#define PerlProc_getegid() PL_piProc->Getegid()
+#define PerlProc_getlogin() PL_piProc->Getlogin()
+#define PerlProc_kill(i, a) PL_piProc->Kill((i), (a))
+#define PerlProc_killpg(i, a) PL_piProc->Killpg((i), (a))
+#define PerlProc_pause() PL_piProc->PauseProc()
+#define PerlProc_popen(c, m) PL_piProc->Popen((c), (m))
+#define PerlProc_pclose(f) PL_piProc->Pclose((f))
+#define PerlProc_pipe(fd) PL_piProc->Pipe((fd))
+#define PerlProc_setuid(u) PL_piProc->Setuid((u))
+#define PerlProc_setgid(g) PL_piProc->Setgid((g))
+#define PerlProc_sleep(t) PL_piProc->Sleep((t))
+#define PerlProc_times(t) PL_piProc->Times((t))
+#define PerlProc_wait(t) PL_piProc->Wait((t))
+#define PerlProc_waitpid(p,s,f) PL_piProc->Waitpid((p), (s), (f))
+#define PerlProc_setjmp(b, n) Sigsetjmp((b), (n))
+#define PerlProc_longjmp(b, n) Siglongjmp((b), (n))
+#define PerlProc_signal(n, h) PL_piProc->Signal((n), (h))
+
+#ifdef WIN32
+#define PerlProc_GetSysMsg(s,l,e) \
+ PL_piProc->GetSysMsg((s), (l), (e))
+
+#define PerlProc_FreeBuf(s) PL_piProc->FreeBuf((s))
+#define PerlProc_Cmd(s) PL_piProc->DoCmd((s))
+#define do_spawn(s) PL_piProc->Spawn((s))
+#define do_spawnvp(m, c, a) PL_piProc->Spawnvp((m), (c), (a))
+#define PerlProc_aspawn(m,c,a) PL_piProc->ASpawn((m), (c), (a))
+#endif
+
+#else /* PERL_OBJECT */
+
+#define PerlProc_abort() abort()
+#define PerlProc_crypt(c,s) crypt((c), (s))
+#define PerlProc_exit(s) exit((s))
+#define PerlProc__exit(s) _exit((s))
+#define PerlProc_execl(c,w,x,y,z) \
+ execl((c), (w), (x), (y), (z))
+#define PerlProc_execv(c, a) execv((c), (a))
+#define PerlProc_execvp(c, a) execvp((c), (a))
+#define PerlProc_getuid() getuid()
+#define PerlProc_geteuid() geteuid()
+#define PerlProc_getgid() getgid()
+#define PerlProc_getegid() getegid()
+#define PerlProc_getlogin() getlogin()
+#define PerlProc_kill(i, a) kill((i), (a))
+#define PerlProc_killpg(i, a) killpg((i), (a))
+#define PerlProc_pause() Pause()
+#define PerlProc_popen(c, m) my_popen((c), (m))
+#define PerlProc_pclose(f) my_pclose((f))
+#define PerlProc_pipe(fd) pipe((fd))
+#define PerlProc_setuid(u) setuid((u))
+#define PerlProc_setgid(g) setgid((g))
+#define PerlProc_sleep(t) sleep((t))
+#define PerlProc_times(t) times((t))
+#define PerlProc_wait(t) wait((t))
+#define PerlProc_waitpid(p,s,f) waitpid((p), (s), (f))
+#define PerlProc_setjmp(b, n) Sigsetjmp((b), (n))
+#define PerlProc_longjmp(b, n) Siglongjmp((b), (n))
+#define PerlProc_signal(n, h) signal((n), (h))
+
+
+#endif /* PERL_OBJECT */
+
+/*
+ Interface for perl socket functions
+*/
+
+#ifdef PERL_OBJECT
+
+class IPerlSock
+{
+public:
+ virtual u_long Htonl(u_long hostlong) = 0;
+ virtual u_short Htons(u_short hostshort) = 0;
+ virtual u_long Ntohl(u_long netlong) = 0;
+ virtual u_short Ntohs(u_short netshort) = 0;
+ virtual SOCKET Accept(SOCKET s, struct sockaddr* addr,
+ int* addrlen, int &err) = 0;
+ virtual int Bind(SOCKET s, const struct sockaddr* name,
+ int namelen, int &err) = 0;
+ virtual int Connect(SOCKET s, const struct sockaddr* name,
+ int namelen, int &err) = 0;
+ virtual void Endhostent(int &err) = 0;
+ virtual void Endnetent(int &err) = 0;
+ virtual void Endprotoent(int &err) = 0;
+ virtual void Endservent(int &err) = 0;
+ virtual int Gethostname(char* name, int namelen, int &err) = 0;
+ virtual int Getpeername(SOCKET s, struct sockaddr* name,
+ int* namelen, int &err) = 0;
+ virtual struct hostent * Gethostbyaddr(const char* addr, int len,
+ int type, int &err) = 0;
+ virtual struct hostent * Gethostbyname(const char* name, int &err) = 0;
+ virtual struct hostent * Gethostent(int &err) = 0;
+ virtual struct netent * Getnetbyaddr(long net, int type, int &err) = 0;
+ virtual struct netent * Getnetbyname(const char *, int &err) = 0;
+ virtual struct netent * Getnetent(int &err) = 0;
+ virtual struct protoent * Getprotobyname(const char* name, int &err) = 0;
+ virtual struct protoent * Getprotobynumber(int number, int &err) = 0;
+ virtual struct protoent * Getprotoent(int &err) = 0;
+ virtual struct servent * Getservbyname(const char* name,
+ const char* proto, int &err) = 0;
+ virtual struct servent * Getservbyport(int port, const char* proto,
+ int &err) = 0;
+ virtual struct servent * Getservent(int &err) = 0;
+ virtual int Getsockname(SOCKET s, struct sockaddr* name,
+ int* namelen, int &err) = 0;
+ virtual int Getsockopt(SOCKET s, int level, int optname,
+ char* optval, int* optlen, int &err) = 0;
+ virtual unsigned long InetAddr(const char* cp, int &err) = 0;
+ virtual char * InetNtoa(struct in_addr in, int &err) = 0;
+ virtual int Listen(SOCKET s, int backlog, int &err) = 0;
+ virtual int Recv(SOCKET s, char* buf, int len,
+ int flags, int &err) = 0;
+ virtual int Recvfrom(SOCKET s, char* buf, int len, int flags,
+ struct sockaddr* from, int* fromlen, int &err) = 0;
+ virtual int Select(int nfds, char* readfds, char* writefds,
+ char* exceptfds, const struct timeval* timeout,
+ int &err) = 0;
+ virtual int Send(SOCKET s, const char* buf, int len,
+ int flags, int &err) = 0;
+ virtual int Sendto(SOCKET s, const char* buf, int len, int flags,
+ const struct sockaddr* to, int tolen, int &err) = 0;
+ virtual void Sethostent(int stayopen, int &err) = 0;
+ virtual void Setnetent(int stayopen, int &err) = 0;
+ virtual void Setprotoent(int stayopen, int &err) = 0;
+ virtual void Setservent(int stayopen, int &err) = 0;
+ virtual int Setsockopt(SOCKET s, int level, int optname,
+ const char* optval, int optlen, int &err) = 0;
+ virtual int Shutdown(SOCKET s, int how, int &err) = 0;
+ virtual SOCKET Socket(int af, int type, int protocol, int &err) = 0;
+ virtual int Socketpair(int domain, int type, int protocol,
+ int* fds, int &err) = 0;
+#ifdef WIN32
+ virtual int Closesocket(SOCKET s, int& err) = 0;
+ virtual int Ioctlsocket(SOCKET s, long cmd, u_long *argp,
+ int& err) = 0;
+#endif
+};
+
+#define PerlSock_htonl(x) PL_piSock->Htonl(x)
+#define PerlSock_htons(x) PL_piSock->Htons(x)
+#define PerlSock_ntohl(x) PL_piSock->Ntohl(x)
+#define PerlSock_ntohs(x) PL_piSock->Ntohs(x)
+#define PerlSock_accept(s, a, l) PL_piSock->Accept(s, a, l, ErrorNo())
+#define PerlSock_bind(s, n, l) PL_piSock->Bind(s, n, l, ErrorNo())
+#define PerlSock_connect(s, n, l) PL_piSock->Connect(s, n, l, ErrorNo())
+#define PerlSock_endhostent() PL_piSock->Endhostent(ErrorNo())
+#define PerlSock_endnetent() PL_piSock->Endnetent(ErrorNo())
+#define PerlSock_endprotoent() PL_piSock->Endprotoent(ErrorNo())
+#define PerlSock_endservent() PL_piSock->Endservent(ErrorNo())
+#define PerlSock_gethostbyaddr(a, l, t) PL_piSock->Gethostbyaddr(a, l, t, ErrorNo())
+#define PerlSock_gethostbyname(n) PL_piSock->Gethostbyname(n, ErrorNo())
+#define PerlSock_gethostent() PL_piSock->Gethostent(ErrorNo())
+#define PerlSock_gethostname(n, l) PL_piSock->Gethostname(n, l, ErrorNo())
+#define PerlSock_getnetbyaddr(n, t) PL_piSock->Getnetbyaddr(n, t, ErrorNo())
+#define PerlSock_getnetbyname(c) PL_piSock->Getnetbyname(c, ErrorNo())
+#define PerlSock_getnetent() PL_piSock->Getnetent(ErrorNo())
+#define PerlSock_getpeername(s, n, l) PL_piSock->Getpeername(s, n, l, ErrorNo())
+#define PerlSock_getprotobyname(n) PL_piSock->Getprotobyname(n, ErrorNo())
+#define PerlSock_getprotobynumber(n) PL_piSock->Getprotobynumber(n, ErrorNo())
+#define PerlSock_getprotoent() PL_piSock->Getprotoent(ErrorNo())
+#define PerlSock_getservbyname(n, p) PL_piSock->Getservbyname(n, p, ErrorNo())
+#define PerlSock_getservbyport(port, p) PL_piSock->Getservbyport(port, p, ErrorNo())
+#define PerlSock_getservent() PL_piSock->Getservent(ErrorNo())
+#define PerlSock_getsockname(s, n, l) PL_piSock->Getsockname(s, n, l, ErrorNo())
+#define PerlSock_getsockopt(s,l,n,v,i) PL_piSock->Getsockopt(s, l, n, v, i, ErrorNo())
+#define PerlSock_inet_addr(c) PL_piSock->InetAddr(c, ErrorNo())
+#define PerlSock_inet_ntoa(i) PL_piSock->InetNtoa(i, ErrorNo())
+#define PerlSock_listen(s, b) PL_piSock->Listen(s, b, ErrorNo())
+#define PerlSock_recv(s, b, l, f) PL_piSock->Recv(s, b, l, f, ErrorNo())
+#define PerlSock_recvfrom(s,b,l,f,from,fromlen) \
+ PL_piSock->Recvfrom(s, b, l, f, from, fromlen, ErrorNo())
+#define PerlSock_select(n, r, w, e, t) \
+ PL_piSock->Select(n, (char*)r, (char*)w, (char*)e, t, ErrorNo())
+#define PerlSock_send(s, b, l, f) PL_piSock->Send(s, b, l, f, ErrorNo())
+#define PerlSock_sendto(s, b, l, f, t, tlen) \
+ PL_piSock->Sendto(s, b, l, f, t, tlen, ErrorNo())
+#define PerlSock_sethostent(f) PL_piSock->Sethostent(f, ErrorNo())
+#define PerlSock_setnetent(f) PL_piSock->Setnetent(f, ErrorNo())
+#define PerlSock_setprotoent(f) PL_piSock->Setprotoent(f, ErrorNo())
+#define PerlSock_setservent(f) PL_piSock->Setservent(f, ErrorNo())
+#define PerlSock_setsockopt(s, l, n, v, len) \
+ PL_piSock->Setsockopt(s, l, n, v, len, ErrorNo())
+#define PerlSock_shutdown(s, h) PL_piSock->Shutdown(s, h, ErrorNo())
+#define PerlSock_socket(a, t, p) PL_piSock->Socket(a, t, p, ErrorNo())
+#define PerlSock_socketpair(a, t, p, f) PL_piSock->Socketpair(a, t, p, f, ErrorNo())
+
+#else /* PERL_OBJECT */
+
+#define PerlSock_htonl(x) htonl(x)
+#define PerlSock_htons(x) htons(x)
+#define PerlSock_ntohl(x) ntohl(x)
+#define PerlSock_ntohs(x) ntohs(x)
+#define PerlSock_accept(s, a, l) accept(s, a, l)
+#define PerlSock_bind(s, n, l) bind(s, n, l)
+#define PerlSock_connect(s, n, l) connect(s, n, l)
+
+#define PerlSock_gethostbyaddr(a, l, t) gethostbyaddr(a, l, t)
+#define PerlSock_gethostbyname(n) gethostbyname(n)
+#define PerlSock_gethostent gethostent
+#define PerlSock_endhostent endhostent
+#define PerlSock_gethostname(n, l) gethostname(n, l)
+
+#define PerlSock_getnetbyaddr(n, t) getnetbyaddr(n, t)
+#define PerlSock_getnetbyname(n) getnetbyname(n)
+#define PerlSock_getnetent getnetent
+#define PerlSock_endnetent endnetent
+#define PerlSock_getpeername(s, n, l) getpeername(s, n, l)
+
+#define PerlSock_getprotobyname(n) getprotobyname(n)
+#define PerlSock_getprotobynumber(n) getprotobynumber(n)
+#define PerlSock_getprotoent getprotoent
+#define PerlSock_endprotoent endprotoent
+
+#define PerlSock_getservbyname(n, p) getservbyname(n, p)
+#define PerlSock_getservbyport(port, p) getservbyport(port, p)
+#define PerlSock_getservent getservent
+#define PerlSock_endservent endservent
+
+#define PerlSock_getsockname(s, n, l) getsockname(s, n, l)
+#define PerlSock_getsockopt(s,l,n,v,i) getsockopt(s, l, n, v, i)
+#define PerlSock_inet_addr(c) inet_addr(c)
+#define PerlSock_inet_ntoa(i) inet_ntoa(i)
+#define PerlSock_listen(s, b) listen(s, b)
+#define PerlSock_recvfrom(s, b, l, f, from, fromlen) \
+ recvfrom(s, b, l, f, from, fromlen)
+#define PerlSock_select(n, r, w, e, t) select(n, r, w, e, t)
+#define PerlSock_send(s, b, l, f) send(s, b, l, f)
+#define PerlSock_sendto(s, b, l, f, t, tlen) \
+ sendto(s, b, l, f, t, tlen)
+#define PerlSock_sethostent(f) sethostent(f)
+#define PerlSock_setnetent(f) setnetent(f)
+#define PerlSock_setprotoent(f) setprotoent(f)
+#define PerlSock_setservent(f) setservent(f)
+#define PerlSock_setsockopt(s, l, n, v, len) \
+ setsockopt(s, l, n, v, len)
+#define PerlSock_shutdown(s, h) shutdown(s, h)
+#define PerlSock_socket(a, t, p) socket(a, t, p)
+#define PerlSock_socketpair(a, t, p, f) socketpair(a, t, p, f)
+
+
+#endif /* PERL_OBJECT */
+
+#endif /* __Inc__IPerl___ */
+
diff --git a/contrib/perl5/keywords.h b/contrib/perl5/keywords.h
new file mode 100644
index 000000000000..e8188311488e
--- /dev/null
+++ b/contrib/perl5/keywords.h
@@ -0,0 +1,250 @@
+#define KEY_NULL 0
+#define KEY___FILE__ 1
+#define KEY___LINE__ 2
+#define KEY___PACKAGE__ 3
+#define KEY___DATA__ 4
+#define KEY___END__ 5
+#define KEY_AUTOLOAD 6
+#define KEY_BEGIN 7
+#define KEY_CORE 8
+#define KEY_DESTROY 9
+#define KEY_END 10
+#define KEY_EQ 11
+#define KEY_GE 12
+#define KEY_GT 13
+#define KEY_INIT 14
+#define KEY_LE 15
+#define KEY_LT 16
+#define KEY_NE 17
+#define KEY_abs 18
+#define KEY_accept 19
+#define KEY_alarm 20
+#define KEY_and 21
+#define KEY_atan2 22
+#define KEY_bind 23
+#define KEY_binmode 24
+#define KEY_bless 25
+#define KEY_caller 26
+#define KEY_chdir 27
+#define KEY_chmod 28
+#define KEY_chomp 29
+#define KEY_chop 30
+#define KEY_chown 31
+#define KEY_chr 32
+#define KEY_chroot 33
+#define KEY_close 34
+#define KEY_closedir 35
+#define KEY_cmp 36
+#define KEY_connect 37
+#define KEY_continue 38
+#define KEY_cos 39
+#define KEY_crypt 40
+#define KEY_dbmclose 41
+#define KEY_dbmopen 42
+#define KEY_defined 43
+#define KEY_delete 44
+#define KEY_die 45
+#define KEY_do 46
+#define KEY_dump 47
+#define KEY_each 48
+#define KEY_else 49
+#define KEY_elsif 50
+#define KEY_endgrent 51
+#define KEY_endhostent 52
+#define KEY_endnetent 53
+#define KEY_endprotoent 54
+#define KEY_endpwent 55
+#define KEY_endservent 56
+#define KEY_eof 57
+#define KEY_eq 58
+#define KEY_eval 59
+#define KEY_exec 60
+#define KEY_exists 61
+#define KEY_exit 62
+#define KEY_exp 63
+#define KEY_fcntl 64
+#define KEY_fileno 65
+#define KEY_flock 66
+#define KEY_for 67
+#define KEY_foreach 68
+#define KEY_fork 69
+#define KEY_format 70
+#define KEY_formline 71
+#define KEY_ge 72
+#define KEY_getc 73
+#define KEY_getgrent 74
+#define KEY_getgrgid 75
+#define KEY_getgrnam 76
+#define KEY_gethostbyaddr 77
+#define KEY_gethostbyname 78
+#define KEY_gethostent 79
+#define KEY_getlogin 80
+#define KEY_getnetbyaddr 81
+#define KEY_getnetbyname 82
+#define KEY_getnetent 83
+#define KEY_getpeername 84
+#define KEY_getpgrp 85
+#define KEY_getppid 86
+#define KEY_getpriority 87
+#define KEY_getprotobyname 88
+#define KEY_getprotobynumber 89
+#define KEY_getprotoent 90
+#define KEY_getpwent 91
+#define KEY_getpwnam 92
+#define KEY_getpwuid 93
+#define KEY_getservbyname 94
+#define KEY_getservbyport 95
+#define KEY_getservent 96
+#define KEY_getsockname 97
+#define KEY_getsockopt 98
+#define KEY_glob 99
+#define KEY_gmtime 100
+#define KEY_goto 101
+#define KEY_grep 102
+#define KEY_gt 103
+#define KEY_hex 104
+#define KEY_if 105
+#define KEY_index 106
+#define KEY_int 107
+#define KEY_ioctl 108
+#define KEY_join 109
+#define KEY_keys 110
+#define KEY_kill 111
+#define KEY_last 112
+#define KEY_lc 113
+#define KEY_lcfirst 114
+#define KEY_le 115
+#define KEY_length 116
+#define KEY_link 117
+#define KEY_listen 118
+#define KEY_local 119
+#define KEY_localtime 120
+#define KEY_lock 121
+#define KEY_log 122
+#define KEY_lstat 123
+#define KEY_lt 124
+#define KEY_m 125
+#define KEY_map 126
+#define KEY_mkdir 127
+#define KEY_msgctl 128
+#define KEY_msgget 129
+#define KEY_msgrcv 130
+#define KEY_msgsnd 131
+#define KEY_my 132
+#define KEY_ne 133
+#define KEY_next 134
+#define KEY_no 135
+#define KEY_not 136
+#define KEY_oct 137
+#define KEY_open 138
+#define KEY_opendir 139
+#define KEY_or 140
+#define KEY_ord 141
+#define KEY_pack 142
+#define KEY_package 143
+#define KEY_pipe 144
+#define KEY_pop 145
+#define KEY_pos 146
+#define KEY_print 147
+#define KEY_printf 148
+#define KEY_prototype 149
+#define KEY_push 150
+#define KEY_q 151
+#define KEY_qq 152
+#define KEY_qr 153
+#define KEY_quotemeta 154
+#define KEY_qw 155
+#define KEY_qx 156
+#define KEY_rand 157
+#define KEY_read 158
+#define KEY_readdir 159
+#define KEY_readline 160
+#define KEY_readlink 161
+#define KEY_readpipe 162
+#define KEY_recv 163
+#define KEY_redo 164
+#define KEY_ref 165
+#define KEY_rename 166
+#define KEY_require 167
+#define KEY_reset 168
+#define KEY_return 169
+#define KEY_reverse 170
+#define KEY_rewinddir 171
+#define KEY_rindex 172
+#define KEY_rmdir 173
+#define KEY_s 174
+#define KEY_scalar 175
+#define KEY_seek 176
+#define KEY_seekdir 177
+#define KEY_select 178
+#define KEY_semctl 179
+#define KEY_semget 180
+#define KEY_semop 181
+#define KEY_send 182
+#define KEY_setgrent 183
+#define KEY_sethostent 184
+#define KEY_setnetent 185
+#define KEY_setpgrp 186
+#define KEY_setpriority 187
+#define KEY_setprotoent 188
+#define KEY_setpwent 189
+#define KEY_setservent 190
+#define KEY_setsockopt 191
+#define KEY_shift 192
+#define KEY_shmctl 193
+#define KEY_shmget 194
+#define KEY_shmread 195
+#define KEY_shmwrite 196
+#define KEY_shutdown 197
+#define KEY_sin 198
+#define KEY_sleep 199
+#define KEY_socket 200
+#define KEY_socketpair 201
+#define KEY_sort 202
+#define KEY_splice 203
+#define KEY_split 204
+#define KEY_sprintf 205
+#define KEY_sqrt 206
+#define KEY_srand 207
+#define KEY_stat 208
+#define KEY_study 209
+#define KEY_sub 210
+#define KEY_substr 211
+#define KEY_symlink 212
+#define KEY_syscall 213
+#define KEY_sysopen 214
+#define KEY_sysread 215
+#define KEY_sysseek 216
+#define KEY_system 217
+#define KEY_syswrite 218
+#define KEY_tell 219
+#define KEY_telldir 220
+#define KEY_tie 221
+#define KEY_tied 222
+#define KEY_time 223
+#define KEY_times 224
+#define KEY_tr 225
+#define KEY_truncate 226
+#define KEY_uc 227
+#define KEY_ucfirst 228
+#define KEY_umask 229
+#define KEY_undef 230
+#define KEY_unless 231
+#define KEY_unlink 232
+#define KEY_unpack 233
+#define KEY_unshift 234
+#define KEY_untie 235
+#define KEY_until 236
+#define KEY_use 237
+#define KEY_utime 238
+#define KEY_values 239
+#define KEY_vec 240
+#define KEY_wait 241
+#define KEY_waitpid 242
+#define KEY_wantarray 243
+#define KEY_warn 244
+#define KEY_while 245
+#define KEY_write 246
+#define KEY_x 247
+#define KEY_xor 248
+#define KEY_y 249
diff --git a/contrib/perl5/keywords.pl b/contrib/perl5/keywords.pl
new file mode 100755
index 000000000000..f907e3f115ca
--- /dev/null
+++ b/contrib/perl5/keywords.pl
@@ -0,0 +1,276 @@
+#!/usr/bin/perl
+
+unlink "keywords.h";
+open(KW, ">keywords.h") || die "Can't create keywords.h: $!\n";
+select KW;
+
+# Read & print data.
+
+$keynum = 0;
+while (<DATA>) {
+ chop;
+ next unless $_;
+ next if /^#/;
+ ($keyword) = split;
+ print &tab(5, "#define KEY_$keyword"), $keynum++, "\n";
+}
+
+###########################################################################
+sub tab {
+ local($l, $t) = @_;
+ $t .= "\t" x ($l - (length($t) + 1) / 8);
+ $t;
+}
+###########################################################################
+__END__
+
+NULL
+__FILE__
+__LINE__
+__PACKAGE__
+__DATA__
+__END__
+AUTOLOAD
+BEGIN
+CORE
+DESTROY
+END
+EQ
+GE
+GT
+INIT
+LE
+LT
+NE
+abs
+accept
+alarm
+and
+atan2
+bind
+binmode
+bless
+caller
+chdir
+chmod
+chomp
+chop
+chown
+chr
+chroot
+close
+closedir
+cmp
+connect
+continue
+cos
+crypt
+dbmclose
+dbmopen
+defined
+delete
+die
+do
+dump
+each
+else
+elsif
+endgrent
+endhostent
+endnetent
+endprotoent
+endpwent
+endservent
+eof
+eq
+eval
+exec
+exists
+exit
+exp
+fcntl
+fileno
+flock
+for
+foreach
+fork
+format
+formline
+ge
+getc
+getgrent
+getgrgid
+getgrnam
+gethostbyaddr
+gethostbyname
+gethostent
+getlogin
+getnetbyaddr
+getnetbyname
+getnetent
+getpeername
+getpgrp
+getppid
+getpriority
+getprotobyname
+getprotobynumber
+getprotoent
+getpwent
+getpwnam
+getpwuid
+getservbyname
+getservbyport
+getservent
+getsockname
+getsockopt
+glob
+gmtime
+goto
+grep
+gt
+hex
+if
+index
+int
+ioctl
+join
+keys
+kill
+last
+lc
+lcfirst
+le
+length
+link
+listen
+local
+localtime
+lock
+log
+lstat
+lt
+m
+map
+mkdir
+msgctl
+msgget
+msgrcv
+msgsnd
+my
+ne
+next
+no
+not
+oct
+open
+opendir
+or
+ord
+pack
+package
+pipe
+pop
+pos
+print
+printf
+prototype
+push
+q
+qq
+qr
+quotemeta
+qw
+qx
+rand
+read
+readdir
+readline
+readlink
+readpipe
+recv
+redo
+ref
+rename
+require
+reset
+return
+reverse
+rewinddir
+rindex
+rmdir
+s
+scalar
+seek
+seekdir
+select
+semctl
+semget
+semop
+send
+setgrent
+sethostent
+setnetent
+setpgrp
+setpriority
+setprotoent
+setpwent
+setservent
+setsockopt
+shift
+shmctl
+shmget
+shmread
+shmwrite
+shutdown
+sin
+sleep
+socket
+socketpair
+sort
+splice
+split
+sprintf
+sqrt
+srand
+stat
+study
+sub
+substr
+symlink
+syscall
+sysopen
+sysread
+sysseek
+system
+syswrite
+tell
+telldir
+tie
+tied
+time
+times
+tr
+truncate
+uc
+ucfirst
+umask
+undef
+unless
+unlink
+unpack
+unshift
+untie
+until
+use
+utime
+values
+vec
+wait
+waitpid
+wantarray
+warn
+while
+write
+x
+xor
+y
diff --git a/contrib/perl5/lib/AnyDBM_File.pm b/contrib/perl5/lib/AnyDBM_File.pm
new file mode 100644
index 000000000000..aff3c7cdec95
--- /dev/null
+++ b/contrib/perl5/lib/AnyDBM_File.pm
@@ -0,0 +1,92 @@
+package AnyDBM_File;
+
+use vars qw(@ISA);
+@ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA;
+
+my $mod;
+for $mod (@ISA) {
+ if (eval "require $mod") {
+ @ISA = ($mod); # if we leave @ISA alone, warnings abound
+ return 1;
+ }
+}
+
+die "No DBM package was successfully found or installed";
+#return 0;
+
+=head1 NAME
+
+AnyDBM_File - provide framework for multiple DBMs
+
+NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations
+
+=head1 SYNOPSIS
+
+ use AnyDBM_File;
+
+=head1 DESCRIPTION
+
+This module is a "pure virtual base class"--it has nothing of its own.
+It's just there to inherit from one of the various DBM packages. It
+prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See
+L<DB_File>), GDBM, SDBM (which is always there--it comes with Perl), and
+finally ODBM. This way old programs that used to use NDBM via dbmopen()
+can still do so, but new ones can reorder @ISA:
+
+ BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
+ use AnyDBM_File;
+
+Having multiple DBM implementations makes it trivial to copy database formats:
+
+ use POSIX; use NDBM_File; use DB_File;
+ tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR;
+ tie %oldhash, 'NDBM_File', $old_filename, 1, 0;
+ %newhash = %oldhash;
+
+=head2 DBM Comparisons
+
+Here's a partial table of features the different packages offer:
+
+ odbm ndbm sdbm gdbm bsd-db
+ ---- ---- ---- ---- ------
+ Linkage comes w/ perl yes yes yes yes yes
+ Src comes w/ perl no no yes no no
+ Comes w/ many unix os yes yes[0] no no no
+ Builds ok on !unix ? ? yes yes ?
+ Code Size ? ? small big big
+ Database Size ? ? small big? ok[1]
+ Speed ? ? slow ok fast
+ FTPable no no yes yes yes
+ Easy to build N/A N/A yes yes ok[2]
+ Size limits 1k 4k 1k[3] none none
+ Byte-order independent no no no no yes
+ Licensing restrictions ? ? no yes no
+
+
+=over 4
+
+=item [0]
+
+on mixed universe machines, may be in the bsd compat library,
+which is often shunned.
+
+=item [1]
+
+Can be trimmed if you compile for one access method.
+
+=item [2]
+
+See L<DB_File>.
+Requires symbolic links.
+
+=item [3]
+
+By default, but can be redefined.
+
+=back
+
+=head1 SEE ALSO
+
+dbm(3), ndbm(3), DB_File(3)
+
+=cut
diff --git a/contrib/perl5/lib/AutoLoader.pm b/contrib/perl5/lib/AutoLoader.pm
new file mode 100644
index 000000000000..666c6cacf92d
--- /dev/null
+++ b/contrib/perl5/lib/AutoLoader.pm
@@ -0,0 +1,295 @@
+package AutoLoader;
+
+use vars qw(@EXPORT @EXPORT_OK);
+
+my $is_dosish;
+my $is_vms;
+
+BEGIN {
+ require Exporter;
+ @EXPORT = ();
+ @EXPORT_OK = qw(AUTOLOAD);
+ $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32';
+ $is_vms = $^O eq 'VMS';
+}
+
+AUTOLOAD {
+ my $name;
+ # Braces used to preserve $1 et al.
+ {
+ # Try to find the autoloaded file from the package-qualified
+ # name of the sub. e.g., if the sub needed is
+ # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is
+ # something like '/usr/lib/perl5/Getopt/Long.pm', and the
+ # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'.
+ #
+ # However, if @INC is a relative path, this might not work. If,
+ # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is
+ # 'lib/Getopt/Long.pm', and we want to require
+ # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib').
+ # In this case, we simple prepend the 'auto/' and let the
+ # C<require> take care of the searching for us.
+
+ my ($pkg,$func) = $AUTOLOAD =~ /(.*)::([^:]+)$/;
+ $pkg =~ s#::#/#g;
+ if (defined($name=$INC{"$pkg.pm"})) {
+ $name =~ s#^(.*)$pkg\.pm$#$1auto/$pkg/$func.al#;
+
+ # if the file exists, then make sure that it is a
+ # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al',
+ # or './lib/auto/foo/bar.al'. This avoids C<require> searching
+ # (and failing) to find the 'lib/auto/foo/bar.al' because it
+ # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib').
+
+ if (-r $name) {
+ unless ($name =~ m|^/|) {
+ if ($is_dosish) {
+ unless ($name =~ m{^([a-z]:)?[\\/]}i) {
+ $name = "./$name";
+ }
+ }
+ elsif ($is_vms) {
+ # XXX todo by VMSmiths
+ $name = "./$name";
+ }
+ else {
+ $name = "./$name";
+ }
+ }
+ }
+ else {
+ $name = undef;
+ }
+ }
+ unless (defined $name) {
+ # let C<require> do the searching
+ $name = "auto/$AUTOLOAD.al";
+ $name =~ s#::#/#g;
+ }
+ }
+ my $save = $@;
+ eval { local $SIG{__DIE__}; require $name };
+ if ($@) {
+ if (substr($AUTOLOAD,-9) eq '::DESTROY') {
+ *$AUTOLOAD = sub {};
+ } else {
+ # The load might just have failed because the filename was too
+ # long for some old SVR3 systems which treat long names as errors.
+ # If we can succesfully truncate a long name then it's worth a go.
+ # There is a slight risk that we could pick up the wrong file here
+ # but autosplit should have warned about that when splitting.
+ if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
+ eval {local $SIG{__DIE__};require $name};
+ }
+ if ($@){
+ $@ =~ s/ at .*\n//;
+ my $error = $@;
+ require Carp;
+ Carp::croak($error);
+ }
+ }
+ }
+ $@ = $save;
+ goto &$AUTOLOAD;
+}
+
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+
+ #
+ # Export symbols, but not by accident of inheritance.
+ #
+
+ Exporter::export $pkg, $callpkg, @_ if $pkg eq 'AutoLoader';
+
+ #
+ # Try to find the autosplit index file. Eg., if the call package
+ # is POSIX, then $INC{POSIX.pm} is something like
+ # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in
+ # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that.
+ #
+ # However, if @INC is a relative path, this might not work. If,
+ # for example, @INC = ('lib'), then
+ # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require
+ # 'auto/POSIX/autosplit.ix' (without the leading 'lib').
+ #
+
+ (my $calldir = $callpkg) =~ s#::#/#g;
+ my $path = $INC{$calldir . '.pm'};
+ if (defined($path)) {
+ # Try absolute path name.
+ $path =~ s#^(.*)$calldir\.pm$#$1auto/$calldir/autosplit.ix#;
+ eval { require $path; };
+ # If that failed, try relative path with normal @INC searching.
+ if ($@) {
+ $path ="auto/$calldir/autosplit.ix";
+ eval { require $path; };
+ }
+ if ($@) {
+ my $error = $@;
+ require Carp;
+ Carp::carp($error);
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+AutoLoader - load subroutines only on demand
+
+=head1 SYNOPSIS
+
+ package Foo;
+ use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
+
+ package Bar;
+ use AutoLoader; # don't import AUTOLOAD, define our own
+ sub AUTOLOAD {
+ ...
+ $AutoLoader::AUTOLOAD = "...";
+ goto &AutoLoader::AUTOLOAD;
+ }
+
+=head1 DESCRIPTION
+
+The B<AutoLoader> module works with the B<AutoSplit> module and the
+C<__END__> token to defer the loading of some subroutines until they are
+used rather than loading them all at once.
+
+To use B<AutoLoader>, the author of a module has to place the
+definitions of subroutines to be autoloaded after an C<__END__> token.
+(See L<perldata>.) The B<AutoSplit> module can then be run manually to
+extract the definitions into individual files F<auto/funcname.al>.
+
+B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
+subroutine in is called in a client module of B<AutoLoader>,
+B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
+file with a name related to the location of the file from which the
+client module was read. As an example, if F<POSIX.pm> is located in
+F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
+subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
+the C<.al> file has the same name as the subroutine, sans package. If
+such a file exists, AUTOLOAD will read and evaluate it,
+thus (presumably) defining the needed subroutine. AUTOLOAD will then
+C<goto> the newly defined subroutine.
+
+Once this process completes for a given funtion, it is defined, so
+future calls to the subroutine will bypass the AUTOLOAD mechanism.
+
+=head2 Subroutine Stubs
+
+In order for object method lookup and/or prototype checking to operate
+correctly even when methods have not yet been defined it is necessary to
+"forward declare" each subroutine (as in C<sub NAME;>). See
+L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
+stubs", which are place holders with no code.
+
+The AutoSplit and B<AutoLoader> modules automate the creation of forward
+declarations. The AutoSplit module creates an 'index' file containing
+forward declarations of all the AutoSplit subroutines. When the
+AutoLoader module is 'use'd it loads these declarations into its callers
+package.
+
+Because of this mechanism it is important that B<AutoLoader> is always
+C<use>d and not C<require>d.
+
+=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
+
+In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
+explicitly import it:
+
+ use AutoLoader 'AUTOLOAD';
+
+=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
+
+Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
+They typically need to check for some special cases (such as constants)
+and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
+
+Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
+Instead, they should define their own AUTOLOAD subroutines along these
+lines:
+
+ use AutoLoader;
+ use Carp;
+
+ sub AUTOLOAD {
+ 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 constant $constname";
+ }
+ }
+ *$AUTOLOAD = sub { $val }; # same as: eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+ }
+
+If any module's own AUTOLOAD subroutine has no need to fallback to the
+AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
+subroutines), then that module should not use B<AutoLoader> at all.
+
+=head2 Package Lexicals
+
+Package lexicals declared with C<my> in the main block of a package
+using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
+the fact that the given scope ends at the C<__END__> marker. A module
+using such variables as package globals will not work properly under the
+B<AutoLoader>.
+
+The C<vars> pragma (see L<perlmod/"vars">) may be used in such
+situations as an alternative to explicitly qualifying all globals with
+the package namespace. Variables pre-declared with this pragma will be
+visible to any autoloaded routines (but will not be invisible outside
+the package, unfortunately).
+
+=head2 B<AutoLoader> vs. B<SelfLoader>
+
+The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
+loading of subroutines.
+
+B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
+While this avoids the use of a hierarchy of disk files and the
+associated open/close for each routine loaded, B<SelfLoader> suffers a
+startup speed disadvantage in the one-time parsing of the lines after
+C<__DATA__>, after which routines are cached. B<SelfLoader> can also
+handle multiple packages in a file.
+
+B<AutoLoader> only reads code as it is requested, and in many cases
+should be faster, but requires a machanism like B<AutoSplit> be used to
+create the individual files. L<ExtUtils::MakeMaker> will invoke
+B<AutoSplit> automatically if B<AutoLoader> is used in a module source
+file.
+
+=head1 CAVEATS
+
+AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
+old modules which use B<AutoLoader> should be changed to the new calling
+style. Typically this just means changing a require to a use, adding
+the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
+from C<@ISA>.
+
+On systems with restrictions on file name length, the file corresponding
+to a subroutine may have a shorter name that the routine itself. This
+can lead to conflicting file names. The I<AutoSplit> package warns of
+these potential conflicts when used to split a module.
+
+AutoLoader may fail to find the autosplit files (or even find the wrong
+ones) in cases where C<@INC> contains relative paths, B<and> the program
+does C<chdir>.
+
+=head1 SEE ALSO
+
+L<SelfLoader> - an autoloader that doesn't use external files.
+
+=cut
diff --git a/contrib/perl5/lib/AutoSplit.pm b/contrib/perl5/lib/AutoSplit.pm
new file mode 100644
index 000000000000..121d26154d30
--- /dev/null
+++ b/contrib/perl5/lib/AutoSplit.pm
@@ -0,0 +1,461 @@
+package AutoSplit;
+
+use Exporter ();
+use Config qw(%Config);
+use Carp qw(carp);
+use File::Basename ();
+use File::Path qw(mkpath);
+use strict;
+use vars qw(
+ $VERSION @ISA @EXPORT @EXPORT_OK
+ $Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime
+ );
+
+$VERSION = "1.0302";
+@ISA = qw(Exporter);
+@EXPORT = qw(&autosplit &autosplit_lib_modules);
+@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
+
+=head1 NAME
+
+AutoSplit - split a package for autoloading
+
+=head1 SYNOPSIS
+
+ autosplit($file, $dir, $keep, $check, $modtime);
+
+ autosplit_lib_modules(@modules);
+
+=head1 DESCRIPTION
+
+This function will split up your program into files that the AutoLoader
+module can handle. It is used by both the standard perl libraries and by
+the MakeMaker utility, to automatically configure libraries for autoloading.
+
+The C<autosplit> interface splits the specified file into a hierarchy
+rooted at the directory C<$dir>. It creates directories as needed to reflect
+class hierarchy, and creates the file F<autosplit.ix>. This file acts as
+both forward declaration of all package routines, and as timestamp for the
+last update of the hierarchy.
+
+The remaining three arguments to C<autosplit> govern other options to
+the autosplitter.
+
+=over 2
+
+=item $keep
+
+If the third argument, I<$keep>, is false, then any
+pre-existing C<*.al> files in the autoload directory are removed if
+they are no longer part of the module (obsoleted functions).
+$keep defaults to 0.
+
+=item $check
+
+The
+fourth argument, I<$check>, instructs C<autosplit> to check the module
+currently being split to ensure that it does include a C<use>
+specification for the AutoLoader module, and skips the module if
+AutoLoader is not detected.
+$check defaults to 1.
+
+=item $modtime
+
+Lastly, the I<$modtime> argument specifies
+that C<autosplit> is to check the modification time of the module
+against that of the C<autosplit.ix> file, and only split the module if
+it is newer.
+$modtime defaults to 1.
+
+=back
+
+Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
+with:
+
+ perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
+
+Defined as a Make macro, it is invoked with file and directory arguments;
+C<autosplit> will split the specified file into the specified directory and
+delete obsolete C<.al> files, after checking first that the module does use
+the AutoLoader, and ensuring that the module is not already currently split
+in its current form (the modtime test).
+
+The C<autosplit_lib_modules> form is used in the building of perl. It takes
+as input a list of files (modules) that are assumed to reside in a directory
+B<lib> relative to the current directory. Each file is sent to the
+autosplitter one at a time, to be split into the directory B<lib/auto>.
+
+In both usages of the autosplitter, only subroutines defined following the
+perl I<__END__> token are split out into separate files. Some
+routines may be placed prior to this marker to force their immediate loading
+and parsing.
+
+=head2 Multiple packages
+
+As of version 1.01 of the AutoSplit module it is possible to have
+multiple packages within a single file. Both of the following cases
+are supported:
+
+ package NAME;
+ __END__
+ sub AAA { ... }
+ package NAME::option1;
+ sub BBB { ... }
+ package NAME::option2;
+ sub BBB { ... }
+
+ package NAME;
+ __END__
+ sub AAA { ... }
+ sub NAME::option1::BBB { ... }
+ sub NAME::option2::BBB { ... }
+
+=head1 DIAGNOSTICS
+
+C<AutoSplit> will inform the user if it is necessary to create the
+top-level directory specified in the invocation. It is preferred that
+the script or installation process that invokes C<AutoSplit> have
+created the full directory path ahead of time. This warning may
+indicate that the module is being split into an incorrect path.
+
+C<AutoSplit> will warn the user of all subroutines whose name causes
+potential file naming conflicts on machines with drastically limited
+(8 characters or less) file name length. Since the subroutine name is
+used as the file name, these warnings can aid in portability to such
+systems.
+
+Warnings are issued and the file skipped if C<AutoSplit> cannot locate
+either the I<__END__> marker or a "package Name;"-style specification.
+
+C<AutoSplit> will also emit general diagnostics for inability to
+create directories or files.
+
+=cut
+
+# for portability warn about names longer than $maxlen
+$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3
+$Verbose = 1; # 0=none, 1=minimal, 2=list .al files
+$Keep = 0;
+$CheckForAutoloader = 1;
+$CheckModTime = 1;
+
+my $IndexFile = "autosplit.ix"; # file also serves as timestamp
+my $maxflen = 255;
+$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
+if (defined (&Dos::UseLFN)) {
+ $maxflen = Dos::UseLFN() ? 255 : 11;
+}
+my $Is_VMS = ($^O eq 'VMS');
+
+
+sub autosplit{
+ my($file, $autodir, $keep, $ckal, $ckmt) = @_;
+ # $file - the perl source file to be split (after __END__)
+ # $autodir - the ".../auto" dir below which to write split subs
+ # Handle optional flags:
+ $keep = $Keep unless defined $keep;
+ $ckal = $CheckForAutoloader unless defined $ckal;
+ $ckmt = $CheckModTime unless defined $ckmt;
+ autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
+}
+
+
+# This function is used during perl building/installation
+# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
+
+sub autosplit_lib_modules{
+ my(@modules) = @_; # list of Module names
+
+ while(defined($_ = shift @modules)){
+ s#::#/#g; # incase specified as ABC::XYZ
+ s|\\|/|g; # bug in ksh OS/2
+ s#^lib/##; # incase specified as lib/*.pm
+ if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
+ my ($dir,$name) = (/(.*])(.*)/);
+ $dir =~ s/.*lib[\.\]]//;
+ $dir =~ s#[\.\]]#/#g;
+ $_ = $dir . $name;
+ }
+ autosplit_file("lib/$_", "lib/auto",
+ $Keep, $CheckForAutoloader, $CheckModTime);
+ }
+ 0;
+}
+
+
+# private functions
+
+sub autosplit_file {
+ my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
+ = @_;
+ my(@outfiles);
+ local($_);
+ local($/) = "\n";
+
+ # where to write output files
+ $autodir ||= "lib/auto";
+ if ($Is_VMS) {
+ ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/$||;
+ $filename = VMS::Filespec::unixify($filename); # may have dirs
+ }
+ unless (-d $autodir){
+ mkpath($autodir,0,0755);
+ # We should never need to create the auto dir
+ # here. installperl (or similar) should have done
+ # it. Expecting it to exist is a valuable sanity check against
+ # autosplitting into some random directory by mistake.
+ print "Warning: AutoSplit had to create top-level " .
+ "$autodir unexpectedly.\n";
+ }
+
+ # allow just a package name to be used
+ $filename .= ".pm" unless ($filename =~ m/\.pm$/);
+
+ open(IN, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
+ my($pm_mod_time) = (stat($filename))[9];
+ my($autoloader_seen) = 0;
+ my($in_pod) = 0;
+ my($def_package,$last_package,$this_package,$fnr);
+ while (<IN>) {
+ # Skip pod text.
+ $fnr++;
+ $in_pod = 1 if /^=/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/);
+
+ # record last package name seen
+ $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
+ ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
+ ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
+ last if /^__END__/;
+ }
+ if ($check_for_autoloader && !$autoloader_seen){
+ print "AutoSplit skipped $filename: no AutoLoader used\n"
+ if ($Verbose>=2);
+ return 0;
+ }
+ $_ or die "Can't find __END__ in $filename\n";
+
+ $def_package or die "Can't find 'package Name;' in $filename\n";
+
+ my($modpname) = _modpname($def_package);
+
+ # this _has_ to match so we have a reasonable timestamp file
+ die "Package $def_package ($modpname.pm) does not ".
+ "match filename $filename"
+ unless ($filename =~ m/\Q$modpname.pm\E$/ or
+ ($^O eq 'dos') or ($^O eq 'MSWin32') or
+ $Is_VMS && $filename =~ m/$modpname.pm/i);
+
+ my($al_idx_file) = "$autodir/$modpname/$IndexFile";
+
+ if ($check_mod_time){
+ my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
+ if ($al_ts_time >= $pm_mod_time){
+ print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
+ if ($Verbose >= 2);
+ return undef; # one undef, not a list
+ }
+ }
+
+ print "AutoSplitting $filename ($autodir/$modpname)\n"
+ if $Verbose;
+
+ unless (-d "$autodir/$modpname"){
+ mkpath("$autodir/$modpname",0,0777);
+ }
+
+ # We must try to deal with some SVR3 systems with a limit of 14
+ # characters for file names. Sadly we *cannot* simply truncate all
+ # file names to 14 characters on these systems because we *must*
+ # create filenames which exactly match the names used by AutoLoader.pm.
+ # This is a problem because some systems silently truncate the file
+ # names while others treat long file names as an error.
+
+ my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames
+
+ my(@subnames, $subname, %proto, %package);
+ my @cache = ();
+ my $caching = 1;
+ $last_package = '';
+ while (<IN>) {
+ $fnr++;
+ $in_pod = 1 if /^=/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/);
+ # the following (tempting) old coding gives big troubles if a
+ # cut is forgotten at EOF:
+ # next if /^=\w/ .. /^=cut/;
+ if (/^package\s+([\w:]+)\s*;/) {
+ $this_package = $def_package = $1;
+ }
+ if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) {
+ print OUT "# end of $last_package\::$subname\n1;\n"
+ if $last_package;
+ $subname = $1;
+ my $proto = $2 || '';
+ if ($subname =~ s/(.*):://){
+ $this_package = $1;
+ } else {
+ $this_package = $def_package;
+ }
+ my $fq_subname = "$this_package\::$subname";
+ $package{$fq_subname} = $this_package;
+ $proto{$fq_subname} = $proto;
+ push(@subnames, $fq_subname);
+ my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
+ $modpname = _modpname($this_package);
+ mkpath("$autodir/$modpname",0,0777);
+ my($lpath) = "$autodir/$modpname/$lname.al";
+ my($spath) = "$autodir/$modpname/$sname.al";
+ my $path;
+ if (!$Is83 and open(OUT, ">$lpath")){
+ $path=$lpath;
+ print " writing $lpath\n" if ($Verbose>=2);
+ } else {
+ open(OUT, ">$spath") or die "Can't create $spath: $!\n";
+ $path=$spath;
+ print " writing $spath (with truncated name)\n"
+ if ($Verbose>=1);
+ }
+ push(@outfiles, $path);
+ print OUT <<EOT;
+# NOTE: Derived from $filename.
+# Changes made here will be lost when autosplit again.
+# See AutoSplit.pm.
+package $this_package;
+
+#line $fnr "$filename (autosplit into $path)"
+EOT
+ print OUT @cache;
+ @cache = ();
+ $caching = 0;
+ }
+ if($caching) {
+ push(@cache, $_) if @cache || /\S/;
+ } else {
+ print OUT $_;
+ }
+ if(/^\}/) {
+ if($caching) {
+ print OUT @cache;
+ @cache = ();
+ }
+ print OUT "\n";
+ $caching = 1;
+ }
+ $last_package = $this_package if defined $this_package;
+ }
+ print OUT @cache,"1;\n# end of $last_package\::$subname\n";
+ close(OUT);
+ close(IN);
+
+ if (!$keep){ # don't keep any obsolete *.al files in the directory
+ my(%outfiles);
+ # @outfiles{@outfiles} = @outfiles;
+ # perl downcases all filenames on VMS (which upcases all filenames) so
+ # we'd better downcase the sub name list too, or subs with upper case
+ # letters in them will get their .al files deleted right after they're
+ # created. (The mixed case sub name won't match the all-lowercase
+ # filename, and so be cleaned up as a scrap file)
+ if ($Is_VMS or $Is83) {
+ %outfiles = map {lc($_) => lc($_) } @outfiles;
+ } else {
+ @outfiles{@outfiles} = @outfiles;
+ }
+ my(%outdirs,@outdirs);
+ for (@outfiles) {
+ $outdirs{File::Basename::dirname($_)}||=1;
+ }
+ for my $dir (keys %outdirs) {
+ opendir(OUTDIR,$dir);
+ foreach (sort readdir(OUTDIR)){
+ next unless /\.al$/;
+ my($file) = "$dir/$_";
+ $file = lc $file if $Is83 or $Is_VMS;
+ next if $outfiles{$file};
+ print " deleting $file\n" if ($Verbose>=2);
+ my($deleted,$thistime); # catch all versions on VMS
+ do { $deleted += ($thistime = unlink $file) } while ($thistime);
+ carp "Unable to delete $file: $!" unless $deleted;
+ }
+ closedir(OUTDIR);
+ }
+ }
+
+ open(TS,">$al_idx_file") or
+ carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!";
+ print TS "# Index created by AutoSplit for $filename\n";
+ print TS "# (file acts as timestamp)\n";
+ $last_package = '';
+ for my $fqs (@subnames) {
+ my($subname) = $fqs;
+ $subname =~ s/.*:://;
+ print TS "package $package{$fqs};\n"
+ unless $last_package eq $package{$fqs};
+ print TS "sub $subname $proto{$fqs};\n";
+ $last_package = $package{$fqs};
+ }
+ print TS "1;\n";
+ close(TS);
+
+ _check_unique($filename, $Maxlen, 1, @outfiles);
+
+ @outfiles;
+}
+
+sub _modpname ($) {
+ my($package) = @_;
+ my $modpname = $package;
+ if ($^O eq 'MSWin32') {
+ $modpname =~ s#::#\\#g;
+ } else {
+ $modpname =~ s#::#/#g;
+ }
+ $modpname;
+}
+
+sub _check_unique {
+ my($filename, $maxlen, $warn, @outfiles) = @_;
+ my(%notuniq) = ();
+ my(%shorts) = ();
+ my(@toolong) = grep(
+ length(File::Basename::basename($_))
+ > $maxlen,
+ @outfiles
+ );
+
+ foreach (@toolong){
+ my($dir) = File::Basename::dirname($_);
+ my($file) = File::Basename::basename($_);
+ my($trunc) = substr($file,0,$maxlen);
+ $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
+ $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
+ "$shorts{$dir}{$trunc}, $file" : $file;
+ }
+ if (%notuniq && $warn){
+ print "$filename: some names are not unique when " .
+ "truncated to $maxlen characters:\n";
+ foreach my $dir (sort keys %notuniq){
+ print " directory $dir:\n";
+ foreach my $trunc (sort keys %{$notuniq{$dir}}) {
+ print " $shorts{$dir}{$trunc} truncate to $trunc\n";
+ }
+ }
+ }
+}
+
+1;
+__END__
+
+# test functions so AutoSplit.pm can be applied to itself:
+sub test1 ($) { "test 1\n"; }
+sub test2 ($$) { "test 2\n"; }
+sub test3 ($$$) { "test 3\n"; }
+sub testtesttesttest4_1 { "test 4\n"; }
+sub testtesttesttest4_2 { "duplicate test 4\n"; }
+sub Just::Another::test5 { "another test 5\n"; }
+sub test6 { return join ":", __FILE__,__LINE__; }
+package Yet::Another::AutoSplit;
+sub testtesttesttest4_1 ($) { "another test 4\n"; }
+sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
diff --git a/contrib/perl5/lib/Benchmark.pm b/contrib/perl5/lib/Benchmark.pm
new file mode 100644
index 000000000000..a28f510d1126
--- /dev/null
+++ b/contrib/perl5/lib/Benchmark.pm
@@ -0,0 +1,515 @@
+package Benchmark;
+
+=head1 NAME
+
+Benchmark - benchmark running times of code
+
+timethis - run a chunk of code several times
+
+timethese - run several chunks of code several times
+
+timeit - run a chunk of code and see how long it goes
+
+=head1 SYNOPSIS
+
+ timethis ($count, "code");
+
+ # Use Perl code in strings...
+ timethese($count, {
+ 'Name1' => '...code1...',
+ 'Name2' => '...code2...',
+ });
+
+ # ... or use subroutine references.
+ timethese($count, {
+ 'Name1' => sub { ...code1... },
+ 'Name2' => sub { ...code2... },
+ });
+
+ $t = timeit($count, '...other code...')
+ print "$count loops of other code took:",timestr($t),"\n";
+
+=head1 DESCRIPTION
+
+The Benchmark module encapsulates a number of routines to help you
+figure out how long it takes to execute some code.
+
+=head2 Methods
+
+=over 10
+
+=item new
+
+Returns the current time. Example:
+
+ use Benchmark;
+ $t0 = new Benchmark;
+ # ... your code here ...
+ $t1 = new Benchmark;
+ $td = timediff($t1, $t0);
+ print "the code took:",timestr($td),"\n";
+
+=item debug
+
+Enables or disable debugging by setting the C<$Benchmark::Debug> flag:
+
+ debug Benchmark 1;
+ $t = timeit(10, ' 5 ** $Global ');
+ debug Benchmark 0;
+
+=back
+
+=head2 Standard Exports
+
+The following routines will be exported into your namespace
+if you use the Benchmark module:
+
+=over 10
+
+=item timeit(COUNT, CODE)
+
+Arguments: COUNT is the number of times to run the loop, and CODE is
+the code to run. CODE may be either a code reference or a string to
+be eval'd; either way it will be run in the caller's package.
+
+Returns: a Benchmark object.
+
+=item timethis ( COUNT, CODE, [ TITLE, [ STYLE ]] )
+
+Time COUNT iterations of CODE. CODE may be a string to eval or a
+code reference; either way the CODE will run in the caller's package.
+Results will be printed to STDOUT as TITLE followed by the times.
+TITLE defaults to "timethis COUNT" if none is provided. STYLE
+determines the format of the output, as described for timestr() below.
+
+The COUNT can be zero or negative: this means the I<minimum number of
+CPU seconds> to run. A zero signifies the default of 3 seconds. For
+example to run at least for 10 seconds:
+
+ timethis(-10, $code)
+
+or to run two pieces of code tests for at least 3 seconds:
+
+ timethese(0, { test1 => '...', test2 => '...'})
+
+CPU seconds is, in UNIX terms, the user time plus the system time of
+the process itself, as opposed to the real (wallclock) time and the
+time spent by the child processes. Less than 0.1 seconds is not
+accepted (-0.01 as the count, for example, will cause a fatal runtime
+exception).
+
+Note that the CPU seconds is the B<minimum> time: CPU scheduling and
+other operating system factors may complicate the attempt so that a
+little bit more time is spent. The benchmark output will, however,
+also tell the number of C<$code> runs/second, which should be a more
+interesting number than the actually spent seconds.
+
+Returns a Benchmark object.
+
+=item timethese ( COUNT, CODEHASHREF, [ STYLE ] )
+
+The CODEHASHREF is a reference to a hash containing names as keys
+and either a string to eval or a code reference for each value.
+For each (KEY, VALUE) pair in the CODEHASHREF, this routine will
+call
+
+ timethis(COUNT, VALUE, KEY, STYLE)
+
+The routines are called in string comparison order of KEY.
+
+The COUNT can be zero or negative, see timethis().
+
+=item timediff ( T1, T2 )
+
+Returns the difference between two Benchmark times as a Benchmark
+object suitable for passing to timestr().
+
+=item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ] ] )
+
+Returns a string that formats the times in the TIMEDIFF object in
+the requested STYLE. TIMEDIFF is expected to be a Benchmark object
+similar to that returned by timediff().
+
+STYLE can be any of 'all', 'noc', 'nop' or 'auto'. 'all' shows each
+of the 5 times available ('wallclock' time, user time, system time,
+user time of children, and system time of children). 'noc' shows all
+except the two children times. 'nop' shows only wallclock and the
+two children times. 'auto' (the default) will act as 'all' unless
+the children times are both zero, in which case it acts as 'noc'.
+
+FORMAT is the L<printf(3)>-style format specifier (without the
+leading '%') to use to print the times. It defaults to '5.2f'.
+
+=back
+
+=head2 Optional Exports
+
+The following routines will be exported into your namespace
+if you specifically ask that they be imported:
+
+=over 10
+
+=item clearcache ( COUNT )
+
+Clear the cached time for COUNT rounds of the null loop.
+
+=item clearallcache ( )
+
+Clear all cached times.
+
+=item disablecache ( )
+
+Disable caching of timings for the null loop. This will force Benchmark
+to recalculate these timings for each new piece of code timed.
+
+=item enablecache ( )
+
+Enable caching of timings for the null loop. The time taken for COUNT
+rounds of the null loop will be calculated only once for each
+different COUNT used.
+
+=back
+
+=head1 NOTES
+
+The data is stored as a list of values from the time and times
+functions:
+
+ ($real, $user, $system, $children_user, $children_system)
+
+in seconds for the whole loop (not divided by the number of rounds).
+
+The timing is done using time(3) and times(3).
+
+Code is executed in the caller's package.
+
+The time of the null loop (a loop with the same
+number of rounds but empty loop body) is subtracted
+from the time of the real loop.
+
+The null loop times are cached, the key being the
+number of rounds. The caching can be controlled using
+calls like these:
+
+ clearcache($key);
+ clearallcache();
+
+ disablecache();
+ enablecache();
+
+=head1 INHERITANCE
+
+Benchmark inherits from no other class, except of course
+for Exporter.
+
+=head1 CAVEATS
+
+Comparing eval'd strings with code references will give you
+inaccurate results: a code reference will show a slower
+execution time than the equivalent eval'd string.
+
+The real time timing is done using time(2) and
+the granularity is therefore only one second.
+
+Short tests may produce negative figures because perl
+can appear to take longer to execute the empty loop
+than a short test; try:
+
+ timethis(100,'1');
+
+The system time of the null loop might be slightly
+more than the system time of the loop with the actual
+code and therefore the difference might end up being E<lt> 0.
+
+=head1 AUTHORS
+
+Jarkko Hietaniemi <F<jhi@iki.fi>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>
+
+=head1 MODIFICATION HISTORY
+
+September 8th, 1994; by Tim Bunce.
+
+March 28th, 1997; by Hugo van der Sanden: added support for code
+references and the already documented 'debug' method; revamped
+documentation.
+
+April 04-07th, 1997: by Jarkko Hietaniemi, added the run-for-some-time
+functionality.
+
+=cut
+
+# evaluate something in a clean lexical environment
+sub _doeval { eval shift }
+
+#
+# put any lexicals at file scope AFTER here
+#
+
+use Carp;
+use Exporter;
+@ISA=(Exporter);
+@EXPORT=qw(timeit timethis timethese timediff timestr);
+@EXPORT_OK=qw(clearcache clearallcache disablecache enablecache);
+
+&init;
+
+sub init {
+ $debug = 0;
+ $min_count = 4;
+ $min_cpu = 0.4;
+ $defaultfmt = '5.2f';
+ $defaultstyle = 'auto';
+ # The cache can cause a slight loss of sys time accuracy. If a
+ # user does many tests (>10) with *very* large counts (>10000)
+ # or works on a very slow machine the cache may be useful.
+ &disablecache;
+ &clearallcache;
+}
+
+sub debug { $debug = ($_[1] != 0); }
+
+sub clearcache { delete $cache{$_[0]}; }
+sub clearallcache { %cache = (); }
+sub enablecache { $cache = 1; }
+sub disablecache { $cache = 0; }
+
+# --- Functions to process the 'time' data type
+
+sub new { my @t = (time, times, @_ == 2 ? $_[1] : 0);
+ print "new=@t\n" if $debug;
+ bless \@t; }
+
+sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; }
+sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; }
+sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; }
+sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; }
+
+sub timediff {
+ my($a, $b) = @_;
+ my @r;
+ for (my $i=0; $i < @$a; ++$i) {
+ push(@r, $a->[$i] - $b->[$i]);
+ }
+ bless \@r;
+}
+
+sub timestr {
+ my($tr, $style, $f) = @_;
+ my @t = @$tr;
+ warn "bad time value (@t)" unless @t==6;
+ my($r, $pu, $ps, $cu, $cs, $n) = @t;
+ my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a);
+ $f = $defaultfmt unless defined $f;
+ # format a time in the required style, other formats may be added here
+ $style ||= $defaultstyle;
+ $style = ($ct>0) ? 'all' : 'noc' if $style eq 'auto';
+ my $s = "@t $style"; # default for unknown style
+ $s=sprintf("%2d wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)",
+ @t,$t) if $style eq 'all';
+ $s=sprintf("%2d wallclock secs (%$f usr + %$f sys = %$f CPU)",
+ $r,$pu,$ps,$pt) if $style eq 'noc';
+ $s=sprintf("%2d wallclock secs (%$f cusr + %$f csys = %$f CPU)",
+ $r,$cu,$cs,$ct) if $style eq 'nop';
+ $s .= sprintf(" @ %$f/s (n=$n)", $n / ( $pu + $ps )) if $n;
+ $s;
+}
+
+sub timedebug {
+ my($msg, $t) = @_;
+ print STDERR "$msg",timestr($t),"\n" if $debug;
+}
+
+# --- Functions implementing low-level support for timing loops
+
+sub runloop {
+ my($n, $c) = @_;
+
+ $n+=0; # force numeric now, so garbage won't creep into the eval
+ croak "negative loopcount $n" if $n<0;
+ confess "Usage: runloop(number, [string | coderef])" unless defined $c;
+ my($t0, $t1, $td); # before, after, difference
+
+ # find package of caller so we can execute code there
+ my($curpack) = caller(0);
+ my($i, $pack)= 0;
+ while (($pack) = caller(++$i)) {
+ last if $pack ne $curpack;
+ }
+
+ my ($subcode, $subref);
+ if (ref $c eq 'CODE') {
+ $subcode = "sub { for (1 .. $n) { local \$_; package $pack; &\$c; } }";
+ $subref = eval $subcode;
+ }
+ else {
+ $subcode = "sub { for (1 .. $n) { local \$_; package $pack; $c;} }";
+ $subref = _doeval($subcode);
+ }
+ croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@;
+ print STDERR "runloop $n '$subcode'\n" if $debug;
+
+ $t0 = Benchmark->new(0);
+ &$subref;
+ $t1 = Benchmark->new($n);
+ $td = &timediff($t1, $t0);
+
+ timedebug("runloop:",$td);
+ $td;
+}
+
+
+sub timeit {
+ my($n, $code) = @_;
+ my($wn, $wc, $wd);
+
+ printf STDERR "timeit $n $code\n" if $debug;
+
+ if ($cache && exists $cache{$n}) {
+ $wn = $cache{$n};
+ } else {
+ $wn = &runloop($n, '');
+ $cache{$n} = $wn;
+ }
+
+ $wc = &runloop($n, $code);
+
+ $wd = timediff($wc, $wn);
+
+ timedebug("timeit: ",$wc);
+ timedebug(" - ",$wn);
+ timedebug(" = ",$wd);
+
+ $wd;
+}
+
+
+my $default_for = 3;
+my $min_for = 0.1;
+
+sub runfor {
+ my ($code, $tmax) = @_;
+
+ if ( not defined $tmax or $tmax == 0 ) {
+ $tmax = $default_for;
+ } elsif ( $tmax < 0 ) {
+ $tmax = -$tmax;
+ }
+
+ die "runfor(..., $tmax): timelimit cannot be less than $min_for.\n"
+ if $tmax < $min_for;
+
+ my ($n, $td, $tc, $ntot, $rtot, $utot, $stot, $cutot, $cstot );
+
+ # First find the minimum $n that gives a non-zero timing.
+
+ my $nmin;
+
+ for ($n = 1, $tc = 0; $tc <= 0; $n *= 2 ) {
+ $td = timeit($n, $code);
+ $tc = $td->[1] + $td->[2];
+ }
+
+ $nmin = $n;
+
+ my $ttot = 0;
+ my $tpra = 0.05 * $tmax; # Target/time practice.
+
+ # Double $n until we have think we have practiced enough.
+ for ( $n = 1; $ttot < $tpra; $n *= 2 ) {
+ $td = timeit($n, $code);
+ $tc = $td->cpu_p;
+ $ntot += $n;
+ $rtot += $td->[0];
+ $utot += $td->[1];
+ $stot += $td->[2];
+ $ttot = $utot + $stot;
+ $cutot += $td->[3];
+ $cstot += $td->[4];
+ }
+
+ my $r;
+
+ # Then iterate towards the $tmax.
+ while ( $ttot < $tmax ) {
+ $r = $tmax / $ttot - 1; # Linear approximation.
+ $n = int( $r * $n );
+ $n = $nmin if $n < $nmin;
+ $td = timeit($n, $code);
+ $ntot += $n;
+ $rtot += $td->[0];
+ $utot += $td->[1];
+ $stot += $td->[2];
+ $ttot = $utot + $stot;
+ $cutot += $td->[3];
+ $cstot += $td->[4];
+ }
+
+ return bless [ $rtot, $utot, $stot, $cutot, $cstot, $ntot ];
+}
+
+# --- Functions implementing high-level time-then-print utilities
+
+sub n_to_for {
+ my $n = shift;
+ return $n == 0 ? $default_for : $n < 0 ? -$n : undef;
+}
+
+sub timethis{
+ my($n, $code, $title, $style) = @_;
+ my($t, $for, $forn);
+
+ if ( $n > 0 ) {
+ croak "non-integer loopcount $n, stopped" if int($n)<$n;
+ $t = timeit($n, $code);
+ $title = "timethis $n" unless defined $title;
+ } else {
+ $fort = n_to_for( $n );
+ $t = runfor($code, $fort);
+ $title = "timethis for $fort" unless defined $title;
+ $forn = $t->[-1];
+ }
+ local $| = 1;
+ $style = "" unless defined $style;
+ printf("%10s: ", $title);
+ print timestr($t, $style, $defaultfmt),"\n";
+
+ $n = $forn if defined $forn;
+
+ # A conservative warning to spot very silly tests.
+ # Don't assume that your benchmark is ok simply because
+ # you don't get this warning!
+ print " (warning: too few iterations for a reliable count)\n"
+ if $n < $min_count
+ || ($t->real < 1 && $n < 1000)
+ || $t->cpu_a < $min_cpu;
+ $t;
+}
+
+sub timethese{
+ my($n, $alt, $style) = @_;
+ die "usage: timethese(count, { 'Name1'=>'code1', ... }\n"
+ unless ref $alt eq HASH;
+ my @names = sort keys %$alt;
+ $style = "" unless defined $style;
+ print "Benchmark: ";
+ if ( $n > 0 ) {
+ croak "non-integer loopcount $n, stopped" if int($n)<$n;
+ print "timing $n iterations of";
+ } else {
+ print "running";
+ }
+ print " ", join(', ',@names);
+ unless ( $n > 0 ) {
+ my $for = n_to_for( $n );
+ print ", each for at least $for CPU seconds";
+ }
+ print "...\n";
+
+ # we could save the results in an array and produce a summary here
+ # sum, min, max, avg etc etc
+ foreach my $name (@names) {
+ timethis ($n, $alt -> {$name}, $name, $style);
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/CGI.pm b/contrib/perl5/lib/CGI.pm
new file mode 100644
index 000000000000..22d91a46c7cc
--- /dev/null
+++ b/contrib/perl5/lib/CGI.pm
@@ -0,0 +1,6102 @@
+package CGI;
+require 5.004;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+# The most recent version and complete docs are available at:
+# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
+# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+
+$CGI::revision = '$Id: CGI.pm,v 1.32 1998/05/28 21:55:43 lstein Exp lstein $';
+$CGI::VERSION='2.42';
+
+# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
+# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
+# $TempFile::TMPDIRECTORY = '/usr/tmp';
+
+# >>>>> Here are some globals that you might want to adjust <<<<<<
+sub initialize_globals {
+ # Set this to 1 to enable copious autoloader debugging messages
+ $AUTOLOAD_DEBUG = 0;
+
+ # Change this to the preferred DTD to print in start_html()
+ # or use default_dtd('text of DTD to use');
+ $DEFAULT_DTD = '-//IETF//DTD HTML//EN';
+
+ # Set this to 1 to enable NPH scripts
+ # or:
+ # 1) use CGI qw(-nph)
+ # 2) $CGI::nph(1)
+ # 3) print header(-nph=>1)
+ $NPH = 0;
+
+ # Set this to 1 to disable debugging from the
+ # command line
+ $NO_DEBUG = 0;
+
+ # Set this to 1 to make the temporary files created
+ # during file uploads safe from prying eyes
+ # or do...
+ # 1) use CGI qw(:private_tempfiles)
+ # 2) $CGI::private_tempfiles(1);
+ $PRIVATE_TEMPFILES = 0;
+
+ # Set this to a positive value to limit the size of a POSTing
+ # to a certain number of bytes:
+ $POST_MAX = -1;
+
+ # Change this to 1 to disable uploads entirely:
+ $DISABLE_UPLOADS = 0;
+
+ # Other globals that you shouldn't worry about.
+ undef $Q;
+ $BEEN_THERE = 0;
+ undef @QUERY_PARAM;
+ undef %EXPORT;
+
+ # prevent complaints by mod_perl
+ 1;
+}
+
+# ------------------ START OF THE LIBRARY ------------
+
+# make mod_perlhappy
+initialize_globals();
+
+# FIGURE OUT THE OS WE'RE RUNNING UNDER
+# Some systems support the $^O variable. If not
+# available then require() the Config library
+unless ($OS) {
+ unless ($OS = $^O) {
+ require Config;
+ $OS = $Config::Config{'osname'};
+ }
+}
+if ($OS=~/Win/i) {
+ $OS = 'WINDOWS';
+} elsif ($OS=~/vms/i) {
+ $OS = 'VMS';
+} elsif ($OS=~/^MacOS$/i) {
+ $OS = 'MACINTOSH';
+} elsif ($OS=~/os2/i) {
+ $OS = 'OS2';
+} else {
+ $OS = 'UNIX';
+}
+
+# Some OS logic. Binary mode enabled on DOS, NT and VMS
+$needs_binmode = $OS=~/^(WINDOWS|VMS|OS2)/;
+
+# This is the default class for the CGI object to use when all else fails.
+$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
+
+# This is where to look for autoloaded routines.
+$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
+
+# The path separator is a slash, backslash or semicolon, depending
+# on the paltform.
+$SL = {
+ UNIX=>'/', OS2=>'\\', WINDOWS=>'\\', MACINTOSH=>':', VMS=>'/'
+ }->{$OS};
+
+# This no longer seems to be necessary
+# Turn on NPH scripts by default when running under IIS server!
+# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
+$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
+
+# Turn on special checking for Doug MacEachern's modperl
+if (defined($ENV{'GATEWAY_INTERFACE'}) &&
+ ($MOD_PERL = $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//))
+{
+ $| = 1;
+ require Apache;
+}
+# Turn on special checking for ActiveState's PerlEx
+$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
+
+# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
+# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
+# and sometimes CR). The most popular VMS web server
+# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
+# use ASCII, so \015\012 means something different. I find this all
+# really annoying.
+$EBCDIC = "\t" ne "\011";
+if ($OS eq 'VMS') {
+ $CRLF = "\n";
+} elsif ($EBCDIC) {
+ $CRLF= "\r\n";
+} else {
+ $CRLF = "\015\012";
+}
+
+if ($needs_binmode) {
+ $CGI::DefaultClass->binmode(main::STDOUT);
+ $CGI::DefaultClass->binmode(main::STDIN);
+ $CGI::DefaultClass->binmode(main::STDERR);
+}
+
+%EXPORT_TAGS = (
+ ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
+ tt u i b blockquote pre img a address cite samp dfn html head
+ base body Link nextid title meta kbd start_html end_html
+ input Select option comment/],
+ ':html3'=>[qw/div table caption th td TR Tr sup sub strike applet Param
+ embed basefont style span layer ilayer font frameset frame script small big/],
+ ':netscape'=>[qw/blink fontsize center/],
+ ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
+ submit reset defaults radio_group popup_menu button autoEscape
+ scrolling_list image_button start_form end_form startform endform
+ start_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
+ ':cgi'=>[qw/param path_info path_translated url self_url script_name cookie dump
+ raw_cookie request_method query_string accept user_agent remote_host
+ remote_addr referer server_name server_software server_port server_protocol
+ virtual_host remote_ident auth_type http use_named_parameters
+ save_parameters restore_parameters param_fetch
+ remote_user user_name header redirect import_names put Delete Delete_all url_param/],
+ ':ssl' => [qw/https/],
+ ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
+ ':html' => [qw/:html2 :html3 :netscape/],
+ ':standard' => [qw/:html2 :html3 :form :cgi/],
+ ':push' => [qw/multipart_init multipart_start multipart_end/],
+ ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal/]
+ );
+
+# to import symbols into caller
+sub import {
+ my $self = shift;
+
+# This causes modules to clash.
+# undef %EXPORT_OK;
+# undef %EXPORT;
+
+ $self->_setup_symbols(@_);
+ my ($callpack, $callfile, $callline) = caller;
+
+ # To allow overriding, search through the packages
+ # Till we find one in which the correct subroutine is defined.
+ my @packages = ($self,@{"$self\:\:ISA"});
+ foreach $sym (keys %EXPORT) {
+ my $pck;
+ my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
+ foreach $pck (@packages) {
+ if (defined(&{"$pck\:\:$sym"})) {
+ $def = $pck;
+ last;
+ }
+ }
+ *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
+ }
+}
+
+sub compile {
+ my $pack = shift;
+ $pack->_setup_symbols('-compile',@_);
+}
+
+sub expand_tags {
+ my($tag) = @_;
+ my(@r);
+ return ($tag) unless $EXPORT_TAGS{$tag};
+ foreach (@{$EXPORT_TAGS{$tag}}) {
+ push(@r,&expand_tags($_));
+ }
+ return @r;
+}
+
+#### Method: new
+# The new routine. This will check the current environment
+# for an existing query string, and initialize itself, if so.
+####
+sub new {
+ my($class,$initializer) = @_;
+ my $self = {};
+ bless $self,ref $class || $class || $DefaultClass;
+ if ($MOD_PERL) {
+ Apache->request->register_cleanup(\&CGI::_reset_globals);
+ undef $NPH;
+ }
+ $self->_reset_globals if $PERLEX;
+ $self->init($initializer);
+ return $self;
+}
+
+# We provide a DESTROY method so that the autoloader
+# doesn't bother trying to find it.
+sub DESTROY { }
+
+#### Method: param
+# Returns the value(s)of a named parameter.
+# If invoked in a list context, returns the
+# entire list. Otherwise returns the first
+# member of the list.
+# If name is not provided, return a list of all
+# the known parameters names available.
+# If more than one argument is provided, the
+# second and subsequent arguments are used to
+# set the value of the parameter.
+####
+sub param {
+ my($self,@p) = self_or_default(@_);
+ return $self->all_parameters unless @p;
+ my($name,$value,@other);
+
+ # For compatibility between old calling style and use_named_parameters() style,
+ # we have to special case for a single parameter present.
+ if (@p > 1) {
+ ($name,$value,@other) = $self->rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p);
+ my(@values);
+
+ if (substr($p[0],0,1) eq '-' || $self->use_named_parameters) {
+ @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
+ } else {
+ foreach ($value,@other) {
+ push(@values,$_) if defined($_);
+ }
+ }
+ # If values is provided, then we set it.
+ if (@values) {
+ $self->add_parameter($name);
+ $self->{$name}=[@values];
+ }
+ } else {
+ $name = $p[0];
+ }
+
+ return () unless defined($name) && $self->{$name};
+ return wantarray ? @{$self->{$name}} : $self->{$name}->[0];
+}
+
+sub self_or_default {
+ return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
+ unless (defined($_[0]) &&
+ (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
+ ) {
+ $Q = $CGI::DefaultClass->new unless defined($Q);
+ unshift(@_,$Q);
+ }
+ return @_;
+}
+
+sub self_or_CGI {
+ local $^W=0; # prevent a warning
+ if (defined($_[0]) &&
+ (substr(ref($_[0]),0,3) eq 'CGI'
+ || UNIVERSAL::isa($_[0],'CGI'))) {
+ return @_;
+ } else {
+ return ($DefaultClass,@_);
+ }
+}
+
+########################################
+# THESE METHODS ARE MORE OR LESS PRIVATE
+# GO TO THE __DATA__ SECTION TO SEE MORE
+# PUBLIC METHODS
+########################################
+
+# Initialize the query object from the environment.
+# If a parameter list is found, this object will be set
+# to an associative array in which parameter names are keys
+# and the values are stored as lists
+# If a keyword list is found, this method creates a bogus
+# parameter list with the single parameter 'keywords'.
+
+sub init {
+ my($self,$initializer) = @_;
+ my($query_string,$meth,$content_length,$fh,@lines) = ('','','','');
+
+ # if we get called more than once, we want to initialize
+ # ourselves from the original query (which may be gone
+ # if it was read from STDIN originally.)
+ if (defined(@QUERY_PARAM) && !defined($initializer)) {
+ foreach (@QUERY_PARAM) {
+ $self->param('-name'=>$_,'-value'=>$QUERY_PARAM{$_});
+ }
+ return;
+ }
+
+ $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
+ $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
+ die "Client attempted to POST $content_length bytes, but POSTs are limited to $POST_MAX"
+ if ($POST_MAX > 0) && ($content_length > $POST_MAX);
+ $fh = to_filehandle($initializer) if $initializer;
+
+ METHOD: {
+
+ # Process multipart postings, but only if the initializer is
+ # not defined.
+ if ($meth eq 'POST'
+ && defined($ENV{'CONTENT_TYPE'})
+ && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
+ && !defined($initializer)
+ ) {
+ my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";]+)\"?/;
+ $self->read_multipart($boundary,$content_length);
+ last METHOD;
+ }
+
+ # If initializer is defined, then read parameters
+ # from it.
+ if (defined($initializer)) {
+ if (UNIVERSAL::isa($initializer,'CGI')) {
+ $query_string = $initializer->query_string;
+ last METHOD;
+ }
+ if (ref($initializer) && ref($initializer) eq 'HASH') {
+ foreach (keys %$initializer) {
+ $self->param('-name'=>$_,'-value'=>$initializer->{$_});
+ }
+ last METHOD;
+ }
+
+ if (defined($fh) && ($fh ne '')) {
+ while (<$fh>) {
+ chomp;
+ last if /^=/;
+ push(@lines,$_);
+ }
+ # massage back into standard format
+ if ("@lines" =~ /=/) {
+ $query_string=join("&",@lines);
+ } else {
+ $query_string=join("+",@lines);
+ }
+ last METHOD;
+ }
+
+ # last chance -- treat it as a string
+ $initializer = $$initializer if ref($initializer) eq 'SCALAR';
+ $query_string = $initializer;
+
+ last METHOD;
+ }
+
+ # If method is GET or HEAD, fetch the query from
+ # the environment.
+ if ($meth=~/^(GET|HEAD)$/) {
+ $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ last METHOD;
+ }
+
+ if ($meth eq 'POST') {
+ $self->read_from_client(\*STDIN,\$query_string,$content_length,0)
+ if $content_length > 0;
+ # Some people want to have their cake and eat it too!
+ # Uncomment this line to have the contents of the query string
+ # APPENDED to the POST data.
+ # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
+ last METHOD;
+ }
+
+ # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
+ # Check the command line and then the standard input for data.
+ # We use the shellwords package in order to behave the way that
+ # UN*X programmers expect.
+ $query_string = read_from_cmdline() unless $NO_DEBUG;
+ }
+
+ # We now have the query string in hand. We do slightly
+ # different things for keyword lists and parameter lists.
+ if ($query_string ne '') {
+ if ($query_string =~ /=/) {
+ $self->parse_params($query_string);
+ } else {
+ $self->add_parameter('keywords');
+ $self->{'keywords'} = [$self->parse_keywordlist($query_string)];
+ }
+ }
+
+ # Special case. Erase everything if there is a field named
+ # .defaults.
+ if ($self->param('.defaults')) {
+ undef %{$self};
+ }
+
+ # Associative array containing our defined fieldnames
+ $self->{'.fieldnames'} = {};
+ foreach ($self->param('.cgifields')) {
+ $self->{'.fieldnames'}->{$_}++;
+ }
+
+ # Clear out our default submission button flag if present
+ $self->delete('.submit');
+ $self->delete('.cgifields');
+ $self->save_request unless $initializer;
+}
+
+# FUNCTIONS TO OVERRIDE:
+# Turn a string into a filehandle
+sub to_filehandle {
+ my $thingy = shift;
+ return undef unless $thingy;
+ return $thingy if UNIVERSAL::isa($thingy,'GLOB');
+ return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
+ if (!ref($thingy)) {
+ my $caller = 1;
+ while (my $package = caller($caller++)) {
+ my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
+ return $tmp if defined(fileno($tmp));
+ }
+ }
+ return undef;
+}
+
+# send output to the browser
+sub put {
+ my($self,@p) = self_or_default(@_);
+ $self->print(@p);
+}
+
+# print to standard output (for overriding in mod_perl)
+sub print {
+ shift;
+ CORE::print(@_);
+}
+
+# unescape URL-encoded data
+sub unescape {
+ shift() if ref($_[0]);
+ my $todecode = shift;
+ return undef unless defined($todecode);
+ $todecode =~ tr/+/ /; # pluses become spaces
+ $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
+ return $todecode;
+}
+
+# URL-encode data
+sub escape {
+ shift() if ref($_[0]) || $_[0] eq $DefaultClass;
+ my $toencode = shift;
+ return undef unless defined($toencode);
+ $toencode=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
+ return $toencode;
+}
+
+sub save_request {
+ my($self) = @_;
+ # We're going to play with the package globals now so that if we get called
+ # again, we initialize ourselves in exactly the same way. This allows
+ # us to have several of these objects.
+ @QUERY_PARAM = $self->param; # save list of parameters
+ foreach (@QUERY_PARAM) {
+ $QUERY_PARAM{$_}=$self->{$_};
+ }
+}
+
+sub parse_params {
+ my($self,$tosplit) = @_;
+ my(@pairs) = split('&',$tosplit);
+ my($param,$value);
+ foreach (@pairs) {
+ ($param,$value) = split('=',$_,2);
+ $param = unescape($param);
+ $value = unescape($value);
+ $self->add_parameter($param);
+ push (@{$self->{$param}},$value);
+ }
+}
+
+sub add_parameter {
+ my($self,$param)=@_;
+ push (@{$self->{'.parameters'}},$param)
+ unless defined($self->{$param});
+}
+
+sub all_parameters {
+ my $self = shift;
+ return () unless defined($self) && $self->{'.parameters'};
+ return () unless @{$self->{'.parameters'}};
+ return @{$self->{'.parameters'}};
+}
+
+# put a filehandle into binary mode (DOS)
+sub binmode {
+ CORE::binmode($_[1]);
+}
+
+sub _make_tag_func {
+ my $tagname = shift;
+ return qq{
+ sub $tagname {
+ # handle various cases in which we're called
+ # most of this bizarre stuff is to avoid -w errors
+ shift if \$_[0] &&
+ (!ref(\$_[0]) && \$_[0] eq \$CGI::DefaultClass) ||
+ (ref(\$_[0]) &&
+ (substr(ref(\$_[0]),0,3) eq 'CGI' ||
+ UNIVERSAL::isa(\$_[0],'CGI')));
+
+ my(\$attr) = '';
+ if (ref(\$_[0]) && ref(\$_[0]) eq 'HASH') {
+ my(\@attr) = make_attributes( '',shift() );
+ \$attr = " \@attr" if \@attr;
+ }
+ my(\$tag,\$untag) = ("\U<$tagname\E\$attr>","\U</$tagname>\E");
+ return \$tag unless \@_;
+ my \@result = map { "\$tag\$_\$untag" } (ref(\$_[0]) eq 'ARRAY') ? \@{\$_[0]} : "\@_";
+ return "\@result";
+ }
+}
+}
+
+sub AUTOLOAD {
+ print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
+ my $func = &_compile;
+ goto &$func;
+}
+
+# PRIVATE SUBROUTINE
+# Smart rearrangement of parameters to allow named parameter
+# calling. We do the rearangement if:
+# 1. The first parameter begins with a -
+# 2. The use_named_parameters() method returns true
+sub rearrange {
+ my($self,$order,@param) = @_;
+ return () unless @param;
+
+ if (ref($param[0]) eq 'HASH') {
+ @param = %{$param[0]};
+ } else {
+ return @param
+ unless (defined($param[0]) && substr($param[0],0,1) eq '-')
+ || $self->use_named_parameters;
+ }
+
+ # map parameters into positional indices
+ my ($i,%pos);
+ $i = 0;
+ foreach (@$order) {
+ foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{$_} = $i; }
+ $i++;
+ }
+
+ my (@result,%leftover);
+ $#result = $#$order; # preextend
+ while (@param) {
+ my $key = uc(shift(@param));
+ $key =~ s/^\-//;
+ if (exists $pos{$key}) {
+ $result[$pos{$key}] = shift(@param);
+ } else {
+ $leftover{$key} = shift(@param);
+ }
+ }
+
+ push (@result,$self->make_attributes(\%leftover)) if %leftover;
+ @result;
+}
+
+sub _compile {
+ my($func) = $AUTOLOAD;
+ my($pack,$func_name);
+ {
+ local($1,$2); # this fixes an obscure variable suicide problem.
+ $func=~/(.+)::([^:]+)$/;
+ ($pack,$func_name) = ($1,$2);
+ $pack=~s/::SUPER$//; # fix another obscure problem
+ $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
+ unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
+
+ my($sub) = \%{"$pack\:\:SUBS"};
+ unless (%$sub) {
+ my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
+ eval "package $pack; $$auto";
+ die $@ if $@;
+ $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
+ }
+ my($code) = $sub->{$func_name};
+
+ $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
+ if (!$code) {
+ if ($EXPORT{':any'} ||
+ $EXPORT{'-any'} ||
+ $EXPORT{$func_name} ||
+ (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
+ && $EXPORT_OK{$func_name}) {
+ $code = _make_tag_func($func_name);
+ }
+ }
+ die "Undefined subroutine $AUTOLOAD\n" unless $code;
+ eval "package $pack; $code";
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ die $@;
+ }
+ }
+ delete($sub->{$func_name}); #free storage
+ return "$pack\:\:$func_name";
+}
+
+sub _reset_globals { initialize_globals(); }
+
+sub _setup_symbols {
+ my $self = shift;
+ my $compile = 0;
+ foreach (@_) {
+ $NPH++, next if /^[:-]nph$/;
+ $NO_DEBUG++, next if /^[:-]no_?[Dd]ebug$/;
+ $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
+ $EXPORT{$_}++, next if /^[:-]any$/;
+ $compile++, next if /^[:-]compile$/;
+
+ # This is probably extremely evil code -- to be deleted
+ # some day.
+ if (/^[-]autoload$/) {
+ my($pkg) = caller(1);
+ *{"${pkg}::AUTOLOAD"} = sub {
+ my($routine) = $AUTOLOAD;
+ $routine =~ s/^.*::/CGI::/;
+ &$routine;
+ };
+ next;
+ }
+
+ foreach (&expand_tags($_)) {
+ tr/a-zA-Z0-9_//cd; # don't allow weird function names
+ $EXPORT{$_}++;
+ }
+ }
+ _compile_all(keys %EXPORT) if $compile;
+}
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+
+%SUBS = (
+
+'URL_ENCODED'=> <<'END_OF_FUNC',
+sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
+END_OF_FUNC
+
+'MULTIPART' => <<'END_OF_FUNC',
+sub MULTIPART { 'multipart/form-data'; }
+END_OF_FUNC
+
+'SERVER_PUSH' => <<'END_OF_FUNC',
+sub SERVER_PUSH { 'multipart/x-mixed-replace; boundary="' . shift() . '"'; }
+END_OF_FUNC
+
+'use_named_parameters' => <<'END_OF_FUNC',
+#### Method: use_named_parameters
+# Force CGI.pm to use named parameter-style method calls
+# rather than positional parameters. The same effect
+# will happen automatically if the first parameter
+# begins with a -.
+sub use_named_parameters {
+ my($self,$use_named) = self_or_default(@_);
+ return $self->{'.named'} unless defined ($use_named);
+
+ # stupidity to avoid annoying warnings
+ return $self->{'.named'}=$use_named;
+}
+END_OF_FUNC
+
+'new_MultipartBuffer' => <<'END_OF_FUNC',
+# Create a new multipart buffer
+sub new_MultipartBuffer {
+ my($self,$boundary,$length,$filehandle) = @_;
+ return MultipartBuffer->new($self,$boundary,$length,$filehandle);
+}
+END_OF_FUNC
+
+'read_from_client' => <<'END_OF_FUNC',
+# Read data from a file handle
+sub read_from_client {
+ my($self, $fh, $buff, $len, $offset) = @_;
+ local $^W=0; # prevent a warning
+ return undef unless defined($fh);
+ return read($fh, $$buff, $len, $offset);
+}
+END_OF_FUNC
+
+'delete' => <<'END_OF_FUNC',
+#### Method: delete
+# Deletes the named parameter entirely.
+####
+sub delete {
+ my($self,$name) = self_or_default(@_);
+ delete $self->{$name};
+ delete $self->{'.fieldnames'}->{$name};
+ @{$self->{'.parameters'}}=grep($_ ne $name,$self->param());
+ return wantarray ? () : undef;
+}
+END_OF_FUNC
+
+#### Method: import_names
+# Import all parameters into the given namespace.
+# Assumes namespace 'Q' if not specified
+####
+'import_names' => <<'END_OF_FUNC',
+sub import_names {
+ my($self,$namespace,$delete) = self_or_default(@_);
+ $namespace = 'Q' unless defined($namespace);
+ die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
+ if ($delete || $MOD_PERL) {
+ # can anyone find an easier way to do this?
+ foreach (keys %{"${namespace}::"}) {
+ local *symbol = "${namespace}::${_}";
+ undef $symbol;
+ undef @symbol;
+ undef %symbol;
+ }
+ }
+ my($param,@value,$var);
+ foreach $param ($self->param) {
+ # protect against silly names
+ ($var = $param)=~tr/a-zA-Z0-9_/_/c;
+ $var =~ s/^(?=\d)/_/;
+ local *symbol = "${namespace}::$var";
+ @value = $self->param($param);
+ @symbol = @value;
+ $symbol = $value[0];
+ }
+}
+END_OF_FUNC
+
+#### Method: keywords
+# Keywords acts a bit differently. Calling it in a list context
+# returns the list of keywords.
+# Calling it in a scalar context gives you the size of the list.
+####
+'keywords' => <<'END_OF_FUNC',
+sub keywords {
+ my($self,@values) = self_or_default(@_);
+ # If values is provided, then we set it.
+ $self->{'keywords'}=[@values] if defined(@values);
+ my(@result) = defined($self->{'keywords'}) ? @{$self->{'keywords'}} : ();
+ @result;
+}
+END_OF_FUNC
+
+# These are some tie() interfaces for compatibility
+# with Steve Brenner's cgi-lib.pl routines
+'ReadParse' => <<'END_OF_FUNC',
+sub ReadParse {
+ local(*in);
+ if (@_) {
+ *in = $_[0];
+ } else {
+ my $pkg = caller();
+ *in=*{"${pkg}::in"};
+ }
+ tie(%in,CGI);
+ return scalar(keys %in);
+}
+END_OF_FUNC
+
+'PrintHeader' => <<'END_OF_FUNC',
+sub PrintHeader {
+ my($self) = self_or_default(@_);
+ return $self->header();
+}
+END_OF_FUNC
+
+'HtmlTop' => <<'END_OF_FUNC',
+sub HtmlTop {
+ my($self,@p) = self_or_default(@_);
+ return $self->start_html(@p);
+}
+END_OF_FUNC
+
+'HtmlBot' => <<'END_OF_FUNC',
+sub HtmlBot {
+ my($self,@p) = self_or_default(@_);
+ return $self->end_html(@p);
+}
+END_OF_FUNC
+
+'SplitParam' => <<'END_OF_FUNC',
+sub SplitParam {
+ my ($param) = @_;
+ my (@params) = split ("\0", $param);
+ return (wantarray ? @params : $params[0]);
+}
+END_OF_FUNC
+
+'MethGet' => <<'END_OF_FUNC',
+sub MethGet {
+ return request_method() eq 'GET';
+}
+END_OF_FUNC
+
+'MethPost' => <<'END_OF_FUNC',
+sub MethPost {
+ return request_method() eq 'POST';
+}
+END_OF_FUNC
+
+'TIEHASH' => <<'END_OF_FUNC',
+sub TIEHASH {
+ return $Q || new CGI;
+}
+END_OF_FUNC
+
+'STORE' => <<'END_OF_FUNC',
+sub STORE {
+ $_[0]->param($_[1],split("\0",$_[2]));
+}
+END_OF_FUNC
+
+'FETCH' => <<'END_OF_FUNC',
+sub FETCH {
+ return $_[0] if $_[1] eq 'CGI';
+ return undef unless defined $_[0]->param($_[1]);
+ return join("\0",$_[0]->param($_[1]));
+}
+END_OF_FUNC
+
+'FIRSTKEY' => <<'END_OF_FUNC',
+sub FIRSTKEY {
+ $_[0]->{'.iterator'}=0;
+ $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
+}
+END_OF_FUNC
+
+'NEXTKEY' => <<'END_OF_FUNC',
+sub NEXTKEY {
+ $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
+}
+END_OF_FUNC
+
+'EXISTS' => <<'END_OF_FUNC',
+sub EXISTS {
+ exists $_[0]->{$_[1]};
+}
+END_OF_FUNC
+
+'DELETE' => <<'END_OF_FUNC',
+sub DELETE {
+ $_[0]->delete($_[1]);
+}
+END_OF_FUNC
+
+'CLEAR' => <<'END_OF_FUNC',
+sub CLEAR {
+ %{$_[0]}=();
+}
+####
+END_OF_FUNC
+
+####
+# Append a new value to an existing query
+####
+'append' => <<'EOF',
+sub append {
+ my($self,@p) = @_;
+ my($name,$value) = $self->rearrange([NAME,[VALUE,VALUES]],@p);
+ my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
+ if (@values) {
+ $self->add_parameter($name);
+ push(@{$self->{$name}},@values);
+ }
+ return $self->param($name);
+}
+EOF
+
+#### Method: delete_all
+# Delete all parameters
+####
+'delete_all' => <<'EOF',
+sub delete_all {
+ my($self) = self_or_default(@_);
+ undef %{$self};
+}
+EOF
+
+'Delete' => <<'EOF',
+sub Delete {
+ my($self,@p) = self_or_default(@_);
+ $self->delete(@p);
+}
+EOF
+
+'Delete_all' => <<'EOF',
+sub Delete_all {
+ my($self,@p) = self_or_default(@_);
+ $self->delete_all(@p);
+}
+EOF
+
+#### Method: autoescape
+# If you want to turn off the autoescaping features,
+# call this method with undef as the argument
+'autoEscape' => <<'END_OF_FUNC',
+sub autoEscape {
+ my($self,$escape) = self_or_default(@_);
+ $self->{'dontescape'}=!$escape;
+}
+END_OF_FUNC
+
+
+#### Method: version
+# Return the current version
+####
+'version' => <<'END_OF_FUNC',
+sub version {
+ return $VERSION;
+}
+END_OF_FUNC
+
+'make_attributes' => <<'END_OF_FUNC',
+sub make_attributes {
+ my($self,$attr) = @_;
+ return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
+ my(@att);
+ foreach (keys %{$attr}) {
+ my($key) = $_;
+ $key=~s/^\-//; # get rid of initial - if present
+ $key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
+ push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
+ }
+ return @att;
+}
+END_OF_FUNC
+
+#### Method: url_param
+# Return a parameter in the QUERY_STRING, regardless of
+# whether this was a POST or a GET
+####
+'url_param' => <<'END_OF_FUNC',
+sub url_param {
+ my ($self,@p) = self_or_default(@_);
+ my $name = shift(@p);
+ return undef unless exists($ENV{QUERY_STRING});
+ unless (exists($self->{'.url_param'})) {
+ $self->{'.url_param'}={}; # empty hash
+ if ($ENV{QUERY_STRING} =~ /=/) {
+ my(@pairs) = split('&',$ENV{QUERY_STRING});
+ my($param,$value);
+ foreach (@pairs) {
+ ($param,$value) = split('=',$_,2);
+ $param = unescape($param);
+ $value = unescape($value);
+ push(@{$self->{'.url_param'}->{$param}},$value);
+ }
+ } else {
+ $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
+ }
+ }
+ return keys %{$self->{'.url_param'}} unless defined($name);
+ return () unless $self->{'.url_param'}->{$name};
+ return wantarray ? @{$self->{'.url_param'}->{$name}}
+ : $self->{'.url_param'}->{$name}->[0];
+}
+END_OF_FUNC
+
+#### Method: dump
+# Returns a string in which all the known parameter/value
+# pairs are represented as nested lists, mainly for the purposes
+# of debugging.
+####
+'dump' => <<'END_OF_FUNC',
+sub dump {
+ my($self) = self_or_default(@_);
+ my($param,$value,@result);
+ return '<UL></UL>' unless $self->param;
+ push(@result,"<UL>");
+ foreach $param ($self->param) {
+ my($name)=$self->escapeHTML($param);
+ push(@result,"<LI><STRONG>$param</STRONG>");
+ push(@result,"<UL>");
+ foreach $value ($self->param($param)) {
+ $value = $self->escapeHTML($value);
+ push(@result,"<LI>$value");
+ }
+ push(@result,"</UL>");
+ }
+ push(@result,"</UL>\n");
+ return join("\n",@result);
+}
+END_OF_FUNC
+
+#### Method as_string
+#
+# synonym for "dump"
+####
+'as_string' => <<'END_OF_FUNC',
+sub as_string {
+ &dump(@_);
+}
+END_OF_FUNC
+
+#### Method: save
+# Write values out to a filehandle in such a way that they can
+# be reinitialized by the filehandle form of the new() method
+####
+'save' => <<'END_OF_FUNC',
+sub save {
+ my($self,$filehandle) = self_or_default(@_);
+ $filehandle = to_filehandle($filehandle);
+ my($param);
+ local($,) = ''; # set print field separator back to a sane value
+ foreach $param ($self->param) {
+ my($escaped_param) = escape($param);
+ my($value);
+ foreach $value ($self->param($param)) {
+ print $filehandle "$escaped_param=",escape($value),"\n";
+ }
+ }
+ print $filehandle "=\n"; # end of record
+}
+END_OF_FUNC
+
+
+#### Method: save_parameters
+# An alias for save() that is a better name for exportation.
+# Only intended to be used with the function (non-OO) interface.
+####
+'save_parameters' => <<'END_OF_FUNC',
+sub save_parameters {
+ my $fh = shift;
+ return save(to_filehandle($fh));
+}
+END_OF_FUNC
+
+#### Method: restore_parameters
+# A way to restore CGI parameters from an initializer.
+# Only intended to be used with the function (non-OO) interface.
+####
+'restore_parameters' => <<'END_OF_FUNC',
+sub restore_parameters {
+ $Q = $CGI::DefaultClass->new(@_);
+}
+END_OF_FUNC
+
+#### Method: multipart_init
+# Return a Content-Type: style header for server-push
+# This has to be NPH, and it is advisable to set $| = 1
+#
+# Many thanks to Ed Jordan <ed@fidalgo.net> for this
+# contribution
+####
+'multipart_init' => <<'END_OF_FUNC',
+sub multipart_init {
+ my($self,@p) = self_or_default(@_);
+ my($boundary,@other) = $self->rearrange([BOUNDARY],@p);
+ $boundary = $boundary || '------- =_aaaaaaaaaa0';
+ $self->{'separator'} = "\n--$boundary\n";
+ $type = SERVER_PUSH($boundary);
+ return $self->header(
+ -nph => 1,
+ -type => $type,
+ (map { split "=", $_, 2 } @other),
+ ) . $self->multipart_end;
+}
+END_OF_FUNC
+
+
+#### Method: multipart_start
+# Return a Content-Type: style header for server-push, start of section
+#
+# Many thanks to Ed Jordan <ed@fidalgo.net> for this
+# contribution
+####
+'multipart_start' => <<'END_OF_FUNC',
+sub multipart_start {
+ my($self,@p) = self_or_default(@_);
+ my($type,@other) = $self->rearrange([TYPE],@p);
+ $type = $type || 'text/html';
+ return $self->header(
+ -type => $type,
+ (map { split "=", $_, 2 } @other),
+ );
+}
+END_OF_FUNC
+
+
+#### Method: multipart_end
+# Return a Content-Type: style header for server-push, end of section
+#
+# Many thanks to Ed Jordan <ed@fidalgo.net> for this
+# contribution
+####
+'multipart_end' => <<'END_OF_FUNC',
+sub multipart_end {
+ my($self,@p) = self_or_default(@_);
+ return $self->{'separator'};
+}
+END_OF_FUNC
+
+
+#### Method: header
+# Return a Content-Type: style header
+#
+####
+'header' => <<'END_OF_FUNC',
+sub header {
+ my($self,@p) = self_or_default(@_);
+ my(@header);
+
+ my($type,$status,$cookie,$target,$expires,$nph,@other) =
+ $self->rearrange([TYPE,STATUS,[COOKIE,COOKIES],TARGET,EXPIRES,NPH],@p);
+
+ $nph ||= $NPH;
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ foreach (@other) {
+ next unless my($header,$value) = /([^\s=]+)=\"?([^\"]+)\"?/;
+ ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ": $value"/e;
+ }
+
+ $type = $type || 'text/html';
+
+ # Maybe future compatibility. Maybe not.
+ my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
+ push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
+
+ push(@header,"Status: $status") if $status;
+ push(@header,"Window-Target: $target") if $target;
+ # push all the cookies -- there may be several
+ if ($cookie) {
+ my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
+ foreach (@cookie) {
+ push(@header,"Set-Cookie: " . (UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_));
+ }
+ }
+ # if the user indicates an expiration time, then we need
+ # both an Expires and a Date header (so that the browser is
+ # uses OUR clock)
+ push(@header,"Expires: " . expires($expires,'http'))
+ if $expires;
+ push(@header,"Date: " . expires(0,'http')) if $expires || $cookie;
+ push(@header,"Pragma: no-cache") if $self->cache();
+ push(@header,@other);
+ push(@header,"Content-Type: $type");
+
+ my $header = join($CRLF,@header)."${CRLF}${CRLF}";
+ if ($MOD_PERL and not $nph) {
+ my $r = Apache->request;
+ $r->send_cgi_header($header);
+ return '';
+ }
+ return $header;
+}
+END_OF_FUNC
+
+
+#### Method: cache
+# Control whether header() will produce the no-cache
+# Pragma directive.
+####
+'cache' => <<'END_OF_FUNC',
+sub cache {
+ my($self,$new_value) = self_or_default(@_);
+ $new_value = '' unless $new_value;
+ if ($new_value ne '') {
+ $self->{'cache'} = $new_value;
+ }
+ return $self->{'cache'};
+}
+END_OF_FUNC
+
+
+#### Method: redirect
+# Return a Location: style header
+#
+####
+'redirect' => <<'END_OF_FUNC',
+sub redirect {
+ my($self,@p) = self_or_default(@_);
+ my($url,$target,$cookie,$nph,@other) = $self->rearrange([[LOCATION,URI,URL],TARGET,COOKIE,NPH],@p);
+ $url = $url || $self->self_url;
+ my(@o);
+ foreach (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
+ unshift(@o,
+ '-Status'=>'302 Moved',
+ '-Location'=>$url,
+ '-nph'=>$nph);
+ unshift(@o,'-Target'=>$target) if $target;
+ unshift(@o,'-Cookie'=>$cookie) if $cookie;
+ return $self->header(@o);
+}
+END_OF_FUNC
+
+
+#### Method: start_html
+# Canned HTML header
+#
+# Parameters:
+# $title -> (optional) The title for this HTML document (-title)
+# $author -> (optional) e-mail address of the author (-author)
+# $base -> (optional) if set to true, will enter the BASE address of this document
+# for resolving relative references (-base)
+# $xbase -> (optional) alternative base at some remote location (-xbase)
+# $target -> (optional) target window to load all links into (-target)
+# $script -> (option) Javascript code (-script)
+# $no_script -> (option) Javascript <noscript> tag (-noscript)
+# $meta -> (optional) Meta information tags
+# $head -> (optional) any other elements you'd like to incorporate into the <HEAD> tag
+# (a scalar or array ref)
+# $style -> (optional) reference to an external style sheet
+# @other -> (optional) any other named parameters you'd like to incorporate into
+# the <BODY> tag.
+####
+'start_html' => <<'END_OF_FUNC',
+sub start_html {
+ my($self,@p) = &self_or_default(@_);
+ my($title,$author,$base,$xbase,$script,$noscript,$target,$meta,$head,$style,$dtd,@other) =
+ $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE,DTD],@p);
+
+ # strangely enough, the title needs to be escaped as HTML
+ # while the author needs to be escaped as a URL
+ $title = $self->escapeHTML($title || 'Untitled Document');
+ $author = $self->escape($author);
+ my(@result);
+ $dtd = $DEFAULT_DTD unless $dtd && $dtd =~ m|^-//|;
+ push(@result,qq(<!DOCTYPE HTML PUBLIC "$dtd">)) if $dtd;
+ push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
+ push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if defined $author;
+
+ if ($base || $xbase || $target) {
+ my $href = $xbase || $self->url('-path'=>1);
+ my $t = $target ? qq/ TARGET="$target"/ : '';
+ push(@result,qq/<BASE HREF="$href"$t>/);
+ }
+
+ if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
+ foreach (keys %$meta) { push(@result,qq(<META NAME="$_" CONTENT="$meta->{$_}">)); }
+ }
+
+ push(@result,ref($head) ? @$head : $head) if $head;
+
+ # handle the infrequently-used -style and -script parameters
+ push(@result,$self->_style($style)) if defined $style;
+ push(@result,$self->_script($script)) if defined $script;
+
+ # handle -noscript parameter
+ push(@result,<<END) if $noscript;
+<NOSCRIPT>
+$noscript
+</NOSCRIPT>
+END
+ ;
+ my($other) = @other ? " @other" : '';
+ push(@result,"</HEAD><BODY$other>");
+ return join("\n",@result);
+}
+END_OF_FUNC
+
+### Method: _style
+# internal method for generating a CSS style section
+####
+'_style' => <<'END_OF_FUNC',
+sub _style {
+ my ($self,$style) = @_;
+ my (@result);
+ my $type = 'text/css';
+ if (ref($style)) {
+ my($src,$code,$stype,@other) =
+ $self->rearrange([SRC,CODE,TYPE],
+ '-foo'=>'bar', # a trick to allow the '-' to be omitted
+ ref($style) eq 'ARRAY' ? @$style : %$style);
+ $type = $stype if $stype;
+ push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src;
+ push(@result,style({'type'=>$type},"<!--\n$code\n-->")) if $code;
+ } else {
+ push(@result,style({'type'=>$type},"<!--\n$style\n-->"));
+ }
+ @result;
+}
+END_OF_FUNC
+
+
+'_script' => <<'END_OF_FUNC',
+sub _script {
+ my ($self,$script) = @_;
+ my (@result);
+ my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
+ foreach $script (@scripts) {
+ my($src,$code,$language);
+ if (ref($script)) { # script is a hash
+ ($src,$code,$language) =
+ $self->rearrange([SRC,CODE,LANGUAGE],
+ '-foo'=>'bar', # a trick to allow the '-' to be omitted
+ ref($style) eq 'ARRAY' ? @$script : %$script);
+
+ } else {
+ ($src,$code,$language) = ('',$script,'JavaScript');
+ }
+ my(@satts);
+ push(@satts,'src'=>$src) if $src;
+ push(@satts,'language'=>$language || 'JavaScript');
+ $code = "<!-- Hide script\n$code\n// End script hiding -->"
+ if $code && $language=~/javascript/i;
+ $code = "<!-- Hide script\n$code\n\# End script hiding -->"
+ if $code && $language=~/perl/i;
+ push(@result,script({@satts},$code));
+ }
+ @result;
+}
+END_OF_FUNC
+
+#### Method: end_html
+# End an HTML document.
+# Trivial method for completeness. Just returns "</BODY>"
+####
+'end_html' => <<'END_OF_FUNC',
+sub end_html {
+ return "</BODY></HTML>";
+}
+END_OF_FUNC
+
+
+################################
+# METHODS USED IN BUILDING FORMS
+################################
+
+#### Method: isindex
+# Just prints out the isindex tag.
+# Parameters:
+# $action -> optional URL of script to run
+# Returns:
+# A string containing a <ISINDEX> tag
+'isindex' => <<'END_OF_FUNC',
+sub isindex {
+ my($self,@p) = self_or_default(@_);
+ my($action,@other) = $self->rearrange([ACTION],@p);
+ $action = qq/ACTION="$action"/ if $action;
+ my($other) = @other ? " @other" : '';
+ return "<ISINDEX $action$other>";
+}
+END_OF_FUNC
+
+
+#### Method: startform
+# Start a form
+# Parameters:
+# $method -> optional submission method to use (GET or POST)
+# $action -> optional URL of script to run
+# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
+'startform' => <<'END_OF_FUNC',
+sub startform {
+ my($self,@p) = self_or_default(@_);
+
+ my($method,$action,$enctype,@other) =
+ $self->rearrange([METHOD,ACTION,ENCTYPE],@p);
+
+ $method = $method || 'POST';
+ $enctype = $enctype || &URL_ENCODED;
+ $action = $action ? qq/ACTION="$action"/ : $method eq 'GET' ?
+ 'ACTION="'.$self->script_name.'"' : '';
+ my($other) = @other ? " @other" : '';
+ $self->{'.parametersToAdd'}={};
+ return qq/<FORM METHOD="$method" $action ENCTYPE="$enctype"$other>\n/;
+}
+END_OF_FUNC
+
+
+#### Method: start_form
+# synonym for startform
+'start_form' => <<'END_OF_FUNC',
+sub start_form {
+ &startform;
+}
+END_OF_FUNC
+
+
+#### Method: start_multipart_form
+# synonym for startform
+'start_multipart_form' => <<'END_OF_FUNC',
+sub start_multipart_form {
+ my($self,@p) = self_or_default(@_);
+ if ($self->use_named_parameters ||
+ (defined($param[0]) && substr($param[0],0,1) eq '-')) {
+ my(%p) = @p;
+ $p{'-enctype'}=&MULTIPART;
+ return $self->startform(%p);
+ } else {
+ my($method,$action,@other) =
+ $self->rearrange([METHOD,ACTION],@p);
+ return $self->startform($method,$action,&MULTIPART,@other);
+ }
+}
+END_OF_FUNC
+
+
+#### Method: endform
+# End a form
+'endform' => <<'END_OF_FUNC',
+sub endform {
+ my($self,@p) = self_or_default(@_);
+ return ($self->get_fields,"</FORM>");
+}
+END_OF_FUNC
+
+
+#### Method: end_form
+# synonym for endform
+'end_form' => <<'END_OF_FUNC',
+sub end_form {
+ &endform;
+}
+END_OF_FUNC
+
+
+'_textfield' => <<'END_OF_FUNC',
+sub _textfield {
+ my($self,$tag,@p) = self_or_default(@_);
+ my($name,$default,$size,$maxlength,$override,@other) =
+ $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+
+ my $current = $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $current = defined($current) ? $self->escapeHTML($current) : '';
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ my($s) = defined($size) ? qq/ SIZE=$size/ : '';
+ my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="$tag" NAME="$name" VALUE="$current"$s$m$other>/;
+}
+END_OF_FUNC
+
+#### Method: textfield
+# Parameters:
+# $name -> Name of the text field
+# $default -> Optional default value of the field if not
+# already defined.
+# $size -> Optional width of field in characaters.
+# $maxlength -> Optional maximum number of characters.
+# Returns:
+# A string containing a <INPUT TYPE="text"> field
+#
+'textfield' => <<'END_OF_FUNC',
+sub textfield {
+ my($self,@p) = self_or_default(@_);
+ $self->_textfield('text',@p);
+}
+END_OF_FUNC
+
+
+#### Method: filefield
+# Parameters:
+# $name -> Name of the file upload field
+# $size -> Optional width of field in characaters.
+# $maxlength -> Optional maximum number of characters.
+# Returns:
+# A string containing a <INPUT TYPE="text"> field
+#
+'filefield' => <<'END_OF_FUNC',
+sub filefield {
+ my($self,@p) = self_or_default(@_);
+ $self->_textfield('file',@p);
+}
+END_OF_FUNC
+
+
+#### Method: password
+# Create a "secret password" entry field
+# Parameters:
+# $name -> Name of the field
+# $default -> Optional default value of the field if not
+# already defined.
+# $size -> Optional width of field in characters.
+# $maxlength -> Optional maximum characters that can be entered.
+# Returns:
+# A string containing a <INPUT TYPE="password"> field
+#
+'password_field' => <<'END_OF_FUNC',
+sub password_field {
+ my ($self,@p) = self_or_default(@_);
+ $self->_textfield('password',@p);
+}
+END_OF_FUNC
+
+#### Method: textarea
+# Parameters:
+# $name -> Name of the text field
+# $default -> Optional default value of the field if not
+# already defined.
+# $rows -> Optional number of rows in text area
+# $columns -> Optional number of columns in text area
+# Returns:
+# A string containing a <TEXTAREA></TEXTAREA> tag
+#
+'textarea' => <<'END_OF_FUNC',
+sub textarea {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$default,$rows,$cols,$override,@other) =
+ $self->rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE]],@p);
+
+ my($current)= $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ $current = defined($current) ? $self->escapeHTML($current) : '';
+ my($r) = $rows ? " ROWS=$rows" : '';
+ my($c) = $cols ? " COLS=$cols" : '';
+ my($other) = @other ? " @other" : '';
+ return qq{<TEXTAREA NAME="$name"$r$c$other>$current</TEXTAREA>};
+}
+END_OF_FUNC
+
+
+#### Method: button
+# Create a javascript button.
+# Parameters:
+# $name -> (optional) Name for the button. (-name)
+# $value -> (optional) Value of the button when selected (and visible name) (-value)
+# $onclick -> (optional) Text of the JavaScript to run when the button is
+# clicked.
+# Returns:
+# A string containing a <INPUT TYPE="button"> tag
+####
+'button' => <<'END_OF_FUNC',
+sub button {
+ my($self,@p) = self_or_default(@_);
+
+ my($label,$value,$script,@other) = $self->rearrange([NAME,[VALUE,LABEL],
+ [ONCLICK,SCRIPT]],@p);
+
+ $label=$self->escapeHTML($label);
+ $value=$self->escapeHTML($value);
+ $script=$self->escapeHTML($script);
+
+ my($name) = '';
+ $name = qq/ NAME="$label"/ if $label;
+ $value = $value || $label;
+ my($val) = '';
+ $val = qq/ VALUE="$value"/ if $value;
+ $script = qq/ ONCLICK="$script"/ if $script;
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="button"$name$val$script$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: submit
+# Create a "submit query" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# $value -> (optional) Value of the button when selected (also doubles as label).
+# $label -> (optional) Label printed on the button(also doubles as the value).
+# Returns:
+# A string containing a <INPUT TYPE="submit"> tag
+####
+'submit' => <<'END_OF_FUNC',
+sub submit {
+ my($self,@p) = self_or_default(@_);
+
+ my($label,$value,@other) = $self->rearrange([NAME,[VALUE,LABEL]],@p);
+
+ $label=$self->escapeHTML($label);
+ $value=$self->escapeHTML($value);
+
+ my($name) = ' NAME=".submit"';
+ $name = qq/ NAME="$label"/ if defined($label);
+ $value = defined($value) ? $value : $label;
+ my($val) = '';
+ $val = qq/ VALUE="$value"/ if defined($value);
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="submit"$name$val$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: reset
+# Create a "reset" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# Returns:
+# A string containing a <INPUT TYPE="reset"> tag
+####
+'reset' => <<'END_OF_FUNC',
+sub reset {
+ my($self,@p) = self_or_default(@_);
+ my($label,@other) = $self->rearrange([NAME],@p);
+ $label=$self->escapeHTML($label);
+ my($value) = defined($label) ? qq/ VALUE="$label"/ : '';
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="reset"$value$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: defaults
+# Create a "defaults" button.
+# Parameters:
+# $name -> (optional) Name for the button.
+# Returns:
+# A string containing a <INPUT TYPE="submit" NAME=".defaults"> tag
+#
+# Note: this button has a special meaning to the initialization script,
+# and tells it to ERASE the current query string so that your defaults
+# are used again!
+####
+'defaults' => <<'END_OF_FUNC',
+sub defaults {
+ my($self,@p) = self_or_default(@_);
+
+ my($label,@other) = $self->rearrange([[NAME,VALUE]],@p);
+
+ $label=$self->escapeHTML($label);
+ $label = $label || "Defaults";
+ my($value) = qq/ VALUE="$label"/;
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="submit" NAME=".defaults"$value$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: comment
+# Create an HTML <!-- comment -->
+# Parameters: a string
+'comment' => <<'END_OF_FUNC',
+sub comment {
+ my($self,@p) = self_or_CGI(@_);
+ return "<!-- @p -->";
+}
+END_OF_FUNC
+
+#### Method: checkbox
+# Create a checkbox that is not logically linked to any others.
+# The field value is "on" when the button is checked.
+# Parameters:
+# $name -> Name of the checkbox
+# $checked -> (optional) turned on by default if true
+# $value -> (optional) value of the checkbox, 'on' by default
+# $label -> (optional) a user-readable label printed next to the box.
+# Otherwise the checkbox name is used.
+# Returns:
+# A string containing a <INPUT TYPE="checkbox"> field
+####
+'checkbox' => <<'END_OF_FUNC',
+sub checkbox {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$checked,$value,$label,$override,@other) =
+ $self->rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,[OVERRIDE,FORCE]],@p);
+
+ $value = defined $value ? $value : 'on';
+
+ if (!$override && ($self->{'.fieldnames'}->{$name} ||
+ defined $self->param($name))) {
+ $checked = grep($_ eq $value,$self->param($name)) ? ' CHECKED' : '';
+ } else {
+ $checked = $checked ? ' CHECKED' : '';
+ }
+ my($the_label) = defined $label ? $label : $name;
+ $name = $self->escapeHTML($name);
+ $value = $self->escapeHTML($value);
+ $the_label = $self->escapeHTML($the_label);
+ my($other) = @other ? " @other" : '';
+ $self->register_parameter($name);
+ return <<END;
+<INPUT TYPE="checkbox" NAME="$name" VALUE="$value"$checked$other>$the_label
+END
+}
+END_OF_FUNC
+
+
+#### Method: checkbox_group
+# Create a list of logically-linked checkboxes.
+# Parameters:
+# $name -> Common name for all the check boxes
+# $values -> A pointer to a regular array containing the
+# values for each checkbox in the group.
+# $defaults -> (optional)
+# 1. If a pointer to a regular array of checkbox values,
+# then this will be used to decide which
+# checkboxes to turn on by default.
+# 2. If a scalar, will be assumed to hold the
+# value of a single checkbox in the group to turn on.
+# $linebreak -> (optional) Set to true to place linebreaks
+# between the buttons.
+# $labels -> (optional)
+# A pointer to an associative array of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# An ARRAY containing a series of <INPUT TYPE="checkbox"> fields
+####
+'checkbox_group' => <<'END_OF_FUNC',
+sub checkbox_group {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$values,$defaults,$linebreak,$labels,$rows,$columns,
+ $rowheaders,$colheaders,$override,$nolabels,@other) =
+ $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ LINEBREAK,LABELS,ROWS,[COLUMNS,COLS],
+ ROWHEADERS,COLHEADERS,
+ [OVERRIDE,FORCE],NOLABELS],@p);
+
+ my($checked,$break,$result,$label);
+
+ my(%checked) = $self->previous_or_default($name,$defaults,$override);
+
+ $break = $linebreak ? "<BR>" : '';
+ $name=$self->escapeHTML($name);
+
+ # Create the elements
+ my(@elements,@values);
+
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+
+ my($other) = @other ? " @other" : '';
+ foreach (@values) {
+ $checked = $checked{$_} ? ' CHECKED' : '';
+ $label = '';
+ unless (defined($nolabels) && $nolabels) {
+ $label = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label = $self->escapeHTML($label);
+ }
+ $_ = $self->escapeHTML($_);
+ push(@elements,qq/<INPUT TYPE="checkbox" NAME="$name" VALUE="$_"$checked$other>${label}${break}/);
+ }
+ $self->register_parameter($name);
+ return wantarray ? @elements : join(' ',@elements)
+ unless defined($columns) || defined($rows);
+ return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
+}
+END_OF_FUNC
+
+# Escape HTML -- used internally
+'escapeHTML' => <<'END_OF_FUNC',
+sub escapeHTML {
+ my($self,$toencode) = @_;
+ $toencode = $self unless ref($self);
+ return undef unless defined($toencode);
+ return $toencode if ref($self) && $self->{'dontescape'};
+
+ $toencode=~s/&/&amp;/g;
+ $toencode=~s/\"/&quot;/g;
+ $toencode=~s/>/&gt;/g;
+ $toencode=~s/</&lt;/g;
+ return $toencode;
+}
+END_OF_FUNC
+
+# unescape HTML -- used internally
+'unescapeHTML' => <<'END_OF_FUNC',
+sub unescapeHTML {
+ my $string = ref($_[0]) ? $_[1] : $_[0];
+ return undef unless defined($string);
+ $string=~s/&amp;/&/ig;
+ $string=~s/&quot;/\"/ig;
+ $string=~s/&gt;/>/ig;
+ $string=~s/&lt;/</ig;
+ $string=~s/&#(\d+);/chr($1)/eg;
+ $string=~s/&#[xX]([0-9a-fA-F]);/chr(hex($1))/eg;
+ return $string;
+}
+END_OF_FUNC
+
+# Internal procedure - don't use
+'_tableize' => <<'END_OF_FUNC',
+sub _tableize {
+ my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
+ my($result);
+
+ if (defined($columns)) {
+ $rows = int(0.99 + @elements/$columns) unless defined($rows);
+ }
+ if (defined($rows)) {
+ $columns = int(0.99 + @elements/$rows) unless defined($columns);
+ }
+
+ # rearrange into a pretty table
+ $result = "<TABLE>";
+ my($row,$column);
+ unshift(@$colheaders,'') if defined(@$colheaders) && defined(@$rowheaders);
+ $result .= "<TR>" if defined(@{$colheaders});
+ foreach (@{$colheaders}) {
+ $result .= "<TH>$_</TH>";
+ }
+ for ($row=0;$row<$rows;$row++) {
+ $result .= "<TR>";
+ $result .= "<TH>$rowheaders->[$row]</TH>" if defined(@$rowheaders);
+ for ($column=0;$column<$columns;$column++) {
+ $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>"
+ if defined($elements[$column*$rows + $row]);
+ }
+ $result .= "</TR>";
+ }
+ $result .= "</TABLE>";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: radio_group
+# Create a list of logically-linked radio buttons.
+# Parameters:
+# $name -> Common name for all the buttons.
+# $values -> A pointer to a regular array containing the
+# values for each button in the group.
+# $default -> (optional) Value of the button to turn on by default. Pass '-'
+# to turn _nothing_ on.
+# $linebreak -> (optional) Set to true to place linebreaks
+# between the buttons.
+# $labels -> (optional)
+# A pointer to an associative array of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# An ARRAY containing a series of <INPUT TYPE="radio"> fields
+####
+'radio_group' => <<'END_OF_FUNC',
+sub radio_group {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$values,$default,$linebreak,$labels,
+ $rows,$columns,$rowheaders,$colheaders,$override,$nolabels,@other) =
+ $self->rearrange([NAME,[VALUES,VALUE],DEFAULT,LINEBREAK,LABELS,
+ ROWS,[COLUMNS,COLS],
+ ROWHEADERS,COLHEADERS,
+ [OVERRIDE,FORCE],NOLABELS],@p);
+ my($result,$checked);
+
+ if (!$override && defined($self->param($name))) {
+ $checked = $self->param($name);
+ } else {
+ $checked = $default;
+ }
+ # If no check array is specified, check the first by default
+ $checked = $values->[0] unless defined($checked) && $checked ne '';
+ $name=$self->escapeHTML($name);
+
+ my(@elements,@values);
+
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+
+ my($other) = @other ? " @other" : '';
+ foreach (@values) {
+ my($checkit) = $checked eq $_ ? ' CHECKED' : '';
+ my($break) = $linebreak ? '<BR>' : '';
+ my($label)='';
+ unless (defined($nolabels) && $nolabels) {
+ $label = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label = $self->escapeHTML($label);
+ }
+ $_=$self->escapeHTML($_);
+ push(@elements,qq/<INPUT TYPE="radio" NAME="$name" VALUE="$_"$checkit$other>${label}${break}/);
+ }
+ $self->register_parameter($name);
+ return wantarray ? @elements : join(' ',@elements)
+ unless defined($columns) || defined($rows);
+ return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
+}
+END_OF_FUNC
+
+
+#### Method: popup_menu
+# Create a popup menu.
+# Parameters:
+# $name -> Name for all the menu
+# $values -> A pointer to a regular array containing the
+# text of each menu item.
+# $default -> (optional) Default item to display
+# $labels -> (optional)
+# A pointer to an associative array of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# A string containing the definition of a popup menu.
+####
+'popup_menu' => <<'END_OF_FUNC',
+sub popup_menu {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$values,$default,$labels,$override,@other) =
+ $self->rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,[OVERRIDE,FORCE]],@p);
+ my($result,$selected);
+
+ if (!$override && defined($self->param($name))) {
+ $selected = $self->param($name);
+ } else {
+ $selected = $default;
+ }
+ $name=$self->escapeHTML($name);
+ my($other) = @other ? " @other" : '';
+
+ my(@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+
+ $result = qq/<SELECT NAME="$name"$other>\n/;
+ foreach (@values) {
+ my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ my($value) = $self->escapeHTML($_);
+ $label=$self->escapeHTML($label);
+ $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
+ }
+
+ $result .= "</SELECT>\n";
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: scrolling_list
+# Create a scrolling list.
+# Parameters:
+# $name -> name for the list
+# $values -> A pointer to a regular array containing the
+# values for each option line in the list.
+# $defaults -> (optional)
+# 1. If a pointer to a regular array of options,
+# then this will be used to decide which
+# lines to turn on by default.
+# 2. Otherwise holds the value of the single line to turn on.
+# $size -> (optional) Size of the list.
+# $multiple -> (optional) If set, allow multiple selections.
+# $labels -> (optional)
+# A pointer to an associative array of labels to print next to each checkbox
+# in the form $label{'value'}="Long explanatory label".
+# Otherwise the provided values are used as the labels.
+# Returns:
+# A string containing the definition of a scrolling list.
+####
+'scrolling_list' => <<'END_OF_FUNC',
+sub scrolling_list {
+ my($self,@p) = self_or_default(@_);
+ my($name,$values,$defaults,$size,$multiple,$labels,$override,@other)
+ = $self->rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
+ SIZE,MULTIPLE,LABELS,[OVERRIDE,FORCE]],@p);
+
+ my($result,@values);
+ @values = $self->_set_values_and_labels($values,\$labels,$name);
+
+ $size = $size || scalar(@values);
+
+ my(%selected) = $self->previous_or_default($name,$defaults,$override);
+ my($is_multiple) = $multiple ? ' MULTIPLE' : '';
+ my($has_size) = $size ? " SIZE=$size" : '';
+ my($other) = @other ? " @other" : '';
+
+ $name=$self->escapeHTML($name);
+ $result = qq/<SELECT NAME="$name"$has_size$is_multiple$other>\n/;
+ foreach (@values) {
+ my($selectit) = $selected{$_} ? 'SELECTED' : '';
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
+ $label=$self->escapeHTML($label);
+ my($value)=$self->escapeHTML($_);
+ $result .= "<OPTION $selectit VALUE=\"$value\">$label\n";
+ }
+ $result .= "</SELECT>\n";
+ $self->register_parameter($name);
+ return $result;
+}
+END_OF_FUNC
+
+
+#### Method: hidden
+# Parameters:
+# $name -> Name of the hidden field
+# @default -> (optional) Initial values of field (may be an array)
+# or
+# $default->[initial values of field]
+# Returns:
+# A string containing a <INPUT TYPE="hidden" NAME="name" VALUE="value">
+####
+'hidden' => <<'END_OF_FUNC',
+sub hidden {
+ my($self,@p) = self_or_default(@_);
+
+ # this is the one place where we departed from our standard
+ # calling scheme, so we have to special-case (darn)
+ my(@result,@value);
+ my($name,$default,$override,@other) =
+ $self->rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
+
+ my $do_override = 0;
+ if ( ref($p[0]) || substr($p[0],0,1) eq '-' || $self->use_named_parameters ) {
+ @value = ref($default) ? @{$default} : $default;
+ $do_override = $override;
+ } else {
+ foreach ($default,$override,@other) {
+ push(@value,$_) if defined($_);
+ }
+ }
+
+ # use previous values if override is not set
+ my @prev = $self->param($name);
+ @value = @prev if !$do_override && @prev;
+
+ $name=$self->escapeHTML($name);
+ foreach (@value) {
+ $_=$self->escapeHTML($_);
+ push(@result,qq/<INPUT TYPE="hidden" NAME="$name" VALUE="$_">/);
+ }
+ return wantarray ? @result : join('',@result);
+}
+END_OF_FUNC
+
+
+#### Method: image_button
+# Parameters:
+# $name -> Name of the button
+# $src -> URL of the image source
+# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
+# Returns:
+# A string containing a <INPUT TYPE="image" NAME="name" SRC="url" ALIGN="alignment">
+####
+'image_button' => <<'END_OF_FUNC',
+sub image_button {
+ my($self,@p) = self_or_default(@_);
+
+ my($name,$src,$alignment,@other) =
+ $self->rearrange([NAME,SRC,ALIGN],@p);
+
+ my($align) = $alignment ? " ALIGN=\U$alignment" : '';
+ my($other) = @other ? " @other" : '';
+ $name=$self->escapeHTML($name);
+ return qq/<INPUT TYPE="image" NAME="$name" SRC="$src"$align$other>/;
+}
+END_OF_FUNC
+
+
+#### Method: self_url
+# Returns a URL containing the current script and all its
+# param/value pairs arranged as a query. You can use this
+# to create a link that, when selected, will reinvoke the
+# script with all its state information preserved.
+####
+'self_url' => <<'END_OF_FUNC',
+sub self_url {
+ my($self,@p) = self_or_default(@_);
+ return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
+}
+END_OF_FUNC
+
+
+# This is provided as a synonym to self_url() for people unfortunate
+# enough to have incorporated it into their programs already!
+'state' => <<'END_OF_FUNC',
+sub state {
+ &self_url;
+}
+END_OF_FUNC
+
+
+#### Method: url
+# Like self_url, but doesn't return the query string part of
+# the URL.
+####
+'url' => <<'END_OF_FUNC',
+sub url {
+ my($self,@p) = self_or_default(@_);
+ my ($relative,$absolute,$full,$path_info,$query) =
+ $self->rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING']],@p);
+ my $url;
+ $full++ if !($relative || $absolute);
+
+ if ($full) {
+ my $protocol = $self->protocol();
+ $url = "$protocol://";
+ my $vh = http('host');
+ if ($vh) {
+ $url .= $vh;
+ } else {
+ $url .= server_name();
+ my $port = $self->server_port;
+ $url .= ":" . $port
+ unless (lc($protocol) eq 'http' && $port == 80)
+ || (lc($protocol) eq 'https' && $port == 443);
+ }
+ $url .= $self->script_name;
+ } elsif ($relative) {
+ ($url) = $self->script_name =~ m!([^/]+)$!;
+ } elsif ($absolute) {
+ $url = $self->script_name;
+ }
+ $url .= $self->path_info if $path_info and $self->path_info;
+ $url .= "?" . $self->query_string if $query and $self->query_string;
+ return $url;
+}
+
+END_OF_FUNC
+
+#### Method: cookie
+# Set or read a cookie from the specified name.
+# Cookie can then be passed to header().
+# Usual rules apply to the stickiness of -value.
+# Parameters:
+# -name -> name for this cookie (optional)
+# -value -> value of this cookie (scalar, array or hash)
+# -path -> paths for which this cookie is valid (optional)
+# -domain -> internet domain in which this cookie is valid (optional)
+# -secure -> if true, cookie only passed through secure channel (optional)
+# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
+####
+'cookie' => <<'END_OF_FUNC',
+sub cookie {
+ my($self,@p) = self_or_default(@_);
+ my($name,$value,$path,$domain,$secure,$expires) =
+ $self->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@p);
+
+ require CGI::Cookie;
+
+ # if no value is supplied, then we retrieve the
+ # value of the cookie, if any. For efficiency, we cache the parsed
+ # cookies in our state variables.
+ unless ( defined($value) ) {
+ $self->{'.cookies'} = CGI::Cookie->fetch
+ unless $self->{'.cookies'};
+
+ # If no name is supplied, then retrieve the names of all our cookies.
+ return () unless $self->{'.cookies'};
+ return keys %{$self->{'.cookies'}} unless $name;
+ return () unless $self->{'.cookies'}->{$name};
+ return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
+ }
+
+ # If we get here, we're creating a new cookie
+ return undef unless $name; # this is an error
+
+ my @param;
+ push(@param,'-name'=>$name);
+ push(@param,'-value'=>$value);
+ push(@param,'-domain'=>$domain) if $domain;
+ push(@param,'-path'=>$path) if $path;
+ push(@param,'-expires'=>$expires) if $expires;
+ push(@param,'-secure'=>$secure) if $secure;
+
+ return new CGI::Cookie(@param);
+}
+END_OF_FUNC
+
+# This internal routine creates an expires time exactly some number of
+# hours from the current time. It incorporates modifications from
+# Mark Fisher.
+'expire_calc' => <<'END_OF_FUNC',
+sub expire_calc {
+ my($time) = @_;
+ my(%mult) = ('s'=>1,
+ 'm'=>60,
+ 'h'=>60*60,
+ 'd'=>60*60*24,
+ 'M'=>60*60*24*30,
+ 'y'=>60*60*24*365);
+ # format for time can be in any of the forms...
+ # "now" -- expire immediately
+ # "+180s" -- in 180 seconds
+ # "+2m" -- in 2 minutes
+ # "+12h" -- in 12 hours
+ # "+1d" -- in 1 day
+ # "+3M" -- in 3 months
+ # "+2y" -- in 2 years
+ # "-3m" -- 3 minutes ago(!)
+ # If you don't supply one of these forms, we assume you are
+ # specifying the date yourself
+ my($offset);
+ if (!$time || (lc($time) eq 'now')) {
+ $offset = 0;
+ } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
+ $offset = ($mult{$2} || 1)*$1;
+ } else {
+ return $time;
+ }
+ return (time+$offset);
+}
+END_OF_FUNC
+
+# This internal routine creates date strings suitable for use in
+# cookies and HTTP headers. (They differ, unfortunately.)
+# Thanks to Fisher Mark for this.
+'expires' => <<'END_OF_FUNC',
+sub expires {
+ my($time,$format) = @_;
+ $format ||= 'http';
+
+ my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
+ my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;
+
+ # pass through preformatted dates for the sake of expire_calc()
+ $time = expire_calc($time);
+ return $time unless $time =~ /^\d+$/;
+
+ # make HTTP/cookie date string from GMT'ed time
+ # (cookies use '-' as date separator, HTTP uses ' ')
+ my($sc) = ' ';
+ $sc = '-' if $format eq "cookie";
+ my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
+ $year += 1900;
+ return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
+ $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
+}
+END_OF_FUNC
+
+'parse_keywordlist' => <<'END_OF_FUNC',
+sub parse_keywordlist {
+ my($self,$tosplit) = @_;
+ $tosplit = unescape($tosplit); # unescape the keywords
+ $tosplit=~tr/+/ /; # pluses to spaces
+ my(@keywords) = split(/\s+/,$tosplit);
+ return @keywords;
+}
+END_OF_FUNC
+
+'param_fetch' => <<'END_OF_FUNC',
+sub param_fetch {
+ my($self,@p) = self_or_default(@_);
+ my($name) = $self->rearrange([NAME],@p);
+ unless (exists($self->{$name})) {
+ $self->add_parameter($name);
+ $self->{$name} = [];
+ }
+
+ return $self->{$name};
+}
+END_OF_FUNC
+
+###############################################
+# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
+###############################################
+
+#### Method: path_info
+# Return the extra virtual path information provided
+# after the URL (if any)
+####
+'path_info' => <<'END_OF_FUNC',
+sub path_info {
+ my ($self,$info) = self_or_default(@_);
+ if (defined($info)) {
+ $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
+ $self->{'.path_info'} = $info;
+ } elsif (! defined($self->{'.path_info'}) ) {
+ $self->{'.path_info'} = defined($ENV{'PATH_INFO'}) ?
+ $ENV{'PATH_INFO'} : '';
+
+ # hack to fix broken path info in IIS
+ $self->{'.path_info'} =~ s/^\Q$ENV{'SCRIPT_NAME'}\E// if $IIS;
+
+ }
+ return $self->{'.path_info'};
+}
+END_OF_FUNC
+
+
+#### Method: request_method
+# Returns 'POST', 'GET', 'PUT' or 'HEAD'
+####
+'request_method' => <<'END_OF_FUNC',
+sub request_method {
+ return $ENV{'REQUEST_METHOD'};
+}
+END_OF_FUNC
+
+#### Method: path_translated
+# Return the physical path information provided
+# by the URL (if any)
+####
+'path_translated' => <<'END_OF_FUNC',
+sub path_translated {
+ return $ENV{'PATH_TRANSLATED'};
+}
+END_OF_FUNC
+
+
+#### Method: query_string
+# Synthesize a query string from our current
+# parameters
+####
+'query_string' => <<'END_OF_FUNC',
+sub query_string {
+ my($self) = self_or_default(@_);
+ my($param,$value,@pairs);
+ foreach $param ($self->param) {
+ my($eparam) = escape($param);
+ foreach $value ($self->param($param)) {
+ $value = escape($value);
+ push(@pairs,"$eparam=$value");
+ }
+ }
+ return join("&",@pairs);
+}
+END_OF_FUNC
+
+
+#### Method: accept
+# Without parameters, returns an array of the
+# MIME types the browser accepts.
+# With a single parameter equal to a MIME
+# type, will return undef if the browser won't
+# accept it, 1 if the browser accepts it but
+# doesn't give a preference, or a floating point
+# value between 0.0 and 1.0 if the browser
+# declares a quantitative score for it.
+# This handles MIME type globs correctly.
+####
+'accept' => <<'END_OF_FUNC',
+sub accept {
+ my($self,$search) = self_or_CGI(@_);
+ my(%prefs,$type,$pref,$pat);
+
+ my(@accept) = split(',',$self->http('accept'));
+
+ foreach (@accept) {
+ ($pref) = /q=(\d\.\d+|\d+)/;
+ ($type) = m#(\S+/[^;]+)#;
+ next unless $type;
+ $prefs{$type}=$pref || 1;
+ }
+
+ return keys %prefs unless $search;
+
+ # if a search type is provided, we may need to
+ # perform a pattern matching operation.
+ # The MIME types use a glob mechanism, which
+ # is easily translated into a perl pattern match
+
+ # First return the preference for directly supported
+ # types:
+ return $prefs{$search} if $prefs{$search};
+
+ # Didn't get it, so try pattern matching.
+ foreach (keys %prefs) {
+ next unless /\*/; # not a pattern match
+ ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
+ $pat =~ s/\*/.*/g; # turn it into a pattern
+ return $prefs{$_} if $search=~/$pat/;
+ }
+}
+END_OF_FUNC
+
+
+#### Method: user_agent
+# If called with no parameters, returns the user agent.
+# If called with one parameter, does a pattern match (case
+# insensitive) on the user agent.
+####
+'user_agent' => <<'END_OF_FUNC',
+sub user_agent {
+ my($self,$match)=self_or_CGI(@_);
+ return $self->http('user_agent') unless $match;
+ return $self->http('user_agent') =~ /$match/i;
+}
+END_OF_FUNC
+
+
+#### Method: raw_cookie
+# Returns the magic cookies for the session.
+# The cookies are not parsed or altered in any way, i.e.
+# cookies are returned exactly as given in the HTTP
+# headers. If a cookie name is given, only that cookie's
+# value is returned, otherwise the entire raw cookie
+# is returned.
+####
+'raw_cookie' => <<'END_OF_FUNC',
+sub raw_cookie {
+ my($self,$key) = self_or_CGI(@_);
+
+ require CGI::Cookie;
+
+ if (defined($key)) {
+ $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
+ unless $self->{'.raw_cookies'};
+
+ return () unless $self->{'.raw_cookies'};
+ return () unless $self->{'.raw_cookies'}->{$key};
+ return $self->{'.raw_cookies'}->{$key};
+ }
+ return $self->http('cookie') || $ENV{'COOKIE'} || '';
+}
+END_OF_FUNC
+
+#### Method: virtual_host
+# Return the name of the virtual_host, which
+# is not always the same as the server
+######
+'virtual_host' => <<'END_OF_FUNC',
+sub virtual_host {
+ my $vh = http('host') || server_name();
+ $vh =~ s/:\d+$//; # get rid of port number
+ return $vh;
+}
+END_OF_FUNC
+
+#### Method: remote_host
+# Return the name of the remote host, or its IP
+# address if unavailable. If this variable isn't
+# defined, it returns "localhost" for debugging
+# purposes.
+####
+'remote_host' => <<'END_OF_FUNC',
+sub remote_host {
+ return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
+ || 'localhost';
+}
+END_OF_FUNC
+
+
+#### Method: remote_addr
+# Return the IP addr of the remote host.
+####
+'remote_addr' => <<'END_OF_FUNC',
+sub remote_addr {
+ return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
+}
+END_OF_FUNC
+
+
+#### Method: script_name
+# Return the partial URL to this script for
+# self-referencing scripts. Also see
+# self_url(), which returns a URL with all state information
+# preserved.
+####
+'script_name' => <<'END_OF_FUNC',
+sub script_name {
+ return $ENV{'SCRIPT_NAME'} if defined($ENV{'SCRIPT_NAME'});
+ # These are for debugging
+ return "/$0" unless $0=~/^\//;
+ return $0;
+}
+END_OF_FUNC
+
+
+#### Method: referer
+# Return the HTTP_REFERER: useful for generating
+# a GO BACK button.
+####
+'referer' => <<'END_OF_FUNC',
+sub referer {
+ my($self) = self_or_CGI(@_);
+ return $self->http('referer');
+}
+END_OF_FUNC
+
+
+#### Method: server_name
+# Return the name of the server
+####
+'server_name' => <<'END_OF_FUNC',
+sub server_name {
+ return $ENV{'SERVER_NAME'} || 'localhost';
+}
+END_OF_FUNC
+
+#### Method: server_software
+# Return the name of the server software
+####
+'server_software' => <<'END_OF_FUNC',
+sub server_software {
+ return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
+}
+END_OF_FUNC
+
+#### Method: server_port
+# Return the tcp/ip port the server is running on
+####
+'server_port' => <<'END_OF_FUNC',
+sub server_port {
+ return $ENV{'SERVER_PORT'} || 80; # for debugging
+}
+END_OF_FUNC
+
+#### Method: server_protocol
+# Return the protocol (usually HTTP/1.0)
+####
+'server_protocol' => <<'END_OF_FUNC',
+sub server_protocol {
+ return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
+}
+END_OF_FUNC
+
+#### Method: http
+# Return the value of an HTTP variable, or
+# the list of variables if none provided
+####
+'http' => <<'END_OF_FUNC',
+sub http {
+ my ($self,$parameter) = self_or_CGI(@_);
+ return $ENV{$parameter} if $parameter=~/^HTTP/;
+ return $ENV{"HTTP_\U$parameter\E"} if $parameter;
+ my(@p);
+ foreach (keys %ENV) {
+ push(@p,$_) if /^HTTP/;
+ }
+ return @p;
+}
+END_OF_FUNC
+
+#### Method: https
+# Return the value of HTTPS
+####
+'https' => <<'END_OF_FUNC',
+sub https {
+ local($^W)=0;
+ my ($self,$parameter) = self_or_CGI(@_);
+ return $ENV{HTTPS} unless $parameter;
+ return $ENV{$parameter} if $parameter=~/^HTTPS/;
+ return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
+ my(@p);
+ foreach (keys %ENV) {
+ push(@p,$_) if /^HTTPS/;
+ }
+ return @p;
+}
+END_OF_FUNC
+
+#### Method: protocol
+# Return the protocol (http or https currently)
+####
+'protocol' => <<'END_OF_FUNC',
+sub protocol {
+ local($^W)=0;
+ my $self = shift;
+ return 'https' if uc($self->https()) eq 'ON';
+ return 'https' if $self->server_port == 443;
+ my $prot = $self->server_protocol;
+ my($protocol,$version) = split('/',$prot);
+ return "\L$protocol\E";
+}
+END_OF_FUNC
+
+#### Method: remote_ident
+# Return the identity of the remote user
+# (but only if his host is running identd)
+####
+'remote_ident' => <<'END_OF_FUNC',
+sub remote_ident {
+ return $ENV{'REMOTE_IDENT'};
+}
+END_OF_FUNC
+
+
+#### Method: auth_type
+# Return the type of use verification/authorization in use, if any.
+####
+'auth_type' => <<'END_OF_FUNC',
+sub auth_type {
+ return $ENV{'AUTH_TYPE'};
+}
+END_OF_FUNC
+
+
+#### Method: remote_user
+# Return the authorization name used for user
+# verification.
+####
+'remote_user' => <<'END_OF_FUNC',
+sub remote_user {
+ return $ENV{'REMOTE_USER'};
+}
+END_OF_FUNC
+
+
+#### Method: user_name
+# Try to return the remote user's name by hook or by
+# crook
+####
+'user_name' => <<'END_OF_FUNC',
+sub user_name {
+ my ($self) = self_or_CGI(@_);
+ return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
+}
+END_OF_FUNC
+
+#### Method: nph
+# Set or return the NPH global flag
+####
+'nph' => <<'END_OF_FUNC',
+sub nph {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::NPH = $param if defined($param);
+ return $CGI::NPH;
+}
+END_OF_FUNC
+
+#### Method: private_tempfiles
+# Set or return the private_tempfiles global flag
+####
+'private_tempfiles' => <<'END_OF_FUNC',
+sub private_tempfiles {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::PRIVATE_TEMPFILES = $param if defined($param);
+ return $CGI::PRIVATE_TEMPFILES;
+}
+END_OF_FUNC
+
+#### Method: default_dtd
+# Set or return the default_dtd global
+####
+'default_dtd' => <<'END_OF_FUNC',
+sub default_dtd {
+ my ($self,$param) = self_or_CGI(@_);
+ $CGI::DEFAULT_DTD = $param if defined($param);
+ return $CGI::DEFAULT_DTD;
+}
+END_OF_FUNC
+
+# -------------- really private subroutines -----------------
+'previous_or_default' => <<'END_OF_FUNC',
+sub previous_or_default {
+ my($self,$name,$defaults,$override) = @_;
+ my(%selected);
+
+ if (!$override && ($self->{'.fieldnames'}->{$name} ||
+ defined($self->param($name)) ) ) {
+ grep($selected{$_}++,$self->param($name));
+ } elsif (defined($defaults) && ref($defaults) &&
+ (ref($defaults) eq 'ARRAY')) {
+ grep($selected{$_}++,@{$defaults});
+ } else {
+ $selected{$defaults}++ if defined($defaults);
+ }
+
+ return %selected;
+}
+END_OF_FUNC
+
+'register_parameter' => <<'END_OF_FUNC',
+sub register_parameter {
+ my($self,$param) = @_;
+ $self->{'.parametersToAdd'}->{$param}++;
+}
+END_OF_FUNC
+
+'get_fields' => <<'END_OF_FUNC',
+sub get_fields {
+ my($self) = @_;
+ return $self->CGI::hidden('-name'=>'.cgifields',
+ '-values'=>[keys %{$self->{'.parametersToAdd'}}],
+ '-override'=>1);
+}
+END_OF_FUNC
+
+'read_from_cmdline' => <<'END_OF_FUNC',
+sub read_from_cmdline {
+ my($input,@words);
+ my($query_string);
+ if (@ARGV) {
+ @words = @ARGV;
+ } else {
+ require "shellwords.pl";
+ print STDERR "(offline mode: enter name=value pairs on standard input)\n";
+ chomp(@lines = <STDIN>); # remove newlines
+ $input = join(" ",@lines);
+ @words = &shellwords($input);
+ }
+ foreach (@words) {
+ s/\\=/%3D/g;
+ s/\\&/%26/g;
+ }
+
+ if ("@words"=~/=/) {
+ $query_string = join('&',@words);
+ } else {
+ $query_string = join('+',@words);
+ }
+ return $query_string;
+}
+END_OF_FUNC
+
+#####
+# subroutine: read_multipart
+#
+# Read multipart data and store it into our parameters.
+# An interesting feature is that if any of the parts is a file, we
+# create a temporary file and open up a filehandle on it so that the
+# caller can read from it if necessary.
+#####
+'read_multipart' => <<'END_OF_FUNC',
+sub read_multipart {
+ my($self,$boundary,$length,$filehandle) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length,$filehandle);
+ return unless $buffer;
+ my(%header,$body);
+ my $filenumber = 0;
+ while (!$buffer->eof) {
+ %header = $buffer->readHeader;
+ die "Malformed multipart POST\n" unless %header;
+
+ my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]*)"?/;
+
+ # Bug: Netscape doesn't escape quotation marks in file names!!!
+ my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
+
+ # add this parameter to our list
+ $self->add_parameter($param);
+
+ # If no filename specified, then just read the data and assign it
+ # to our parameter list.
+ unless ($filename) {
+ my($value) = $buffer->readBody;
+ push(@{$self->{$param}},$value);
+ next;
+ }
+
+ my ($tmpfile,$tmp,$filehandle);
+ UPLOADS: {
+ # If we get here, then we are dealing with a potentially large
+ # uploaded form. Save the data to a temporary file, then open
+ # the file for reading.
+
+ # skip the file if uploads disabled
+ if ($DISABLE_UPLOADS) {
+ while (defined($data = $buffer->read)) { }
+ last UPLOADS;
+ }
+
+ $tmpfile = new TempFile;
+ $tmp = $tmpfile->as_string;
+
+ $filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES);
+
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+ chmod 0600,$tmp; # only the owner can tamper with it
+
+ my ($data);
+ while (defined($data = $buffer->read)) {
+ print $filehandle $data;
+ }
+
+ # back up to beginning of file
+ seek($filehandle,0,0);
+ $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
+
+ # Save some information about the uploaded file where we can get
+ # at it later.
+ $self->{'.tmpfiles'}->{$filename}= {
+ name => $tmpfile,
+ info => {%header},
+ };
+ push(@{$self->{$param}},$filehandle);
+ }
+ }
+}
+END_OF_FUNC
+
+'tmpFileName' => <<'END_OF_FUNC',
+sub tmpFileName {
+ my($self,$filename) = self_or_default(@_);
+ return $self->{'.tmpfiles'}->{$filename}->{name} ?
+ $self->{'.tmpfiles'}->{$filename}->{name}->as_string
+ : '';
+}
+END_OF_FUNC
+
+'uploadInfo' => <<'END_OF_FUNC',
+sub uploadInfo {
+ my($self,$filename) = self_or_default(@_);
+ return $self->{'.tmpfiles'}->{$filename}->{info};
+}
+END_OF_FUNC
+
+# internal routine, don't use
+'_set_values_and_labels' => <<'END_OF_FUNC',
+sub _set_values_and_labels {
+ my $self = shift;
+ my ($v,$l,$n) = @_;
+ $$l = $v if ref($v) eq 'HASH' && !ref($$l);
+ return $self->param($n) if !defined($v);
+ return $v if !ref($v);
+ return ref($v) eq 'HASH' ? keys %$v : @$v;
+}
+END_OF_FUNC
+
+'_compile_all' => <<'END_OF_FUNC',
+sub _compile_all {
+ foreach (@_) {
+ next if defined(&$_);
+ $AUTOLOAD = "CGI::$_";
+ _compile();
+ }
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+;
+
+#########################################################
+# Globals and stubs for other packages that we use.
+#########################################################
+
+################### Fh -- lightweight filehandle ###############
+package Fh;
+use overload
+ '""' => \&asString,
+ 'cmp' => \&compare,
+ 'fallback'=>1;
+
+$FH='fh00000';
+
+*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
+
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+'asString' => <<'END_OF_FUNC',
+sub asString {
+ my $self = shift;
+ my $i = $$self;
+ $i=~ s/^\*(\w+::)+//; # get rid of package name
+ $i =~ s/\\(.)/$1/g;
+ return $i;
+}
+END_OF_FUNC
+
+'compare' => <<'END_OF_FUNC',
+sub compare {
+ my $self = shift;
+ my $value = shift;
+ return "$self" cmp $value;
+}
+END_OF_FUNC
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($pack,$name,$file,$delete) = @_;
+ require Fcntl unless defined &Fcntl::O_RDWR;
+ ++$FH;
+ *{$FH} = quotemeta($name);
+ sysopen($FH,$file,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL())
+ || die "CGI open of $file: $!\n";
+ unlink($file) if $delete;
+ return bless \*{$FH},$pack;
+}
+END_OF_FUNC
+
+'DESTROY' => <<'END_OF_FUNC',
+sub DESTROY {
+ my $self = shift;
+ close $self;
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+######################## MultipartBuffer ####################
+package MultipartBuffer;
+
+# how many bytes to read at a time. We use
+# a 5K buffer by default.
+$INITIAL_FILLUNIT = 1024 * 5;
+$TIMEOUT = 10*60; # 10 minute timeout
+$SPIN_LOOP_MAX = 1000; # bug fix for some Netscape servers
+$CRLF=$CGI::CRLF;
+
+#reuse the autoload function
+*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
+
+# avoid autoloader warnings
+sub DESTROY {}
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($package,$interface,$boundary,$length,$filehandle) = @_;
+ $FILLUNIT = $INITIAL_FILLUNIT;
+ my $IN;
+ if ($filehandle) {
+ my($package) = caller;
+ # force into caller's package if necessary
+ $IN = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
+ }
+ $IN = "main::STDIN" unless $IN;
+
+ $CGI::DefaultClass->binmode($IN) if $CGI::needs_binmode;
+
+ # If the user types garbage into the file upload field,
+ # then Netscape passes NOTHING to the server (not good).
+ # We may hang on this read in that case. So we implement
+ # a read timeout. If nothing is ready to read
+ # by then, we return.
+
+ # Netscape seems to be a little bit unreliable
+ # about providing boundary strings.
+ if ($boundary) {
+
+ # Under the MIME spec, the boundary consists of the
+ # characters "--" PLUS the Boundary string
+
+ # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
+ # the two extra spaces. We do a special case here on the user-agent!!!!
+ $boundary = "--$boundary" unless CGI::user_agent('MSIE 3\.0[12]; Mac');
+
+ } else { # otherwise we find it ourselves
+ my($old);
+ ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
+ $boundary = <$IN>; # BUG: This won't work correctly under mod_perl
+ $length -= length($boundary);
+ chomp($boundary); # remove the CRLF
+ $/ = $old; # restore old line separator
+ }
+
+ my $self = {LENGTH=>$length,
+ BOUNDARY=>$boundary,
+ IN=>$IN,
+ INTERFACE=>$interface,
+ BUFFER=>'',
+ };
+
+ $FILLUNIT = length($boundary)
+ if length($boundary) > $FILLUNIT;
+
+ my $retval = bless $self,ref $package || $package;
+
+ # Read the preamble and the topmost (boundary) line plus the CRLF.
+ while ($self->read(0)) { }
+ die "Malformed multipart POST\n" if $self->eof;
+
+ return $retval;
+}
+END_OF_FUNC
+
+'readHeader' => <<'END_OF_FUNC',
+sub readHeader {
+ my($self) = @_;
+ my($end);
+ my($ok) = 0;
+ my($bad) = 0;
+
+ if ($CGI::OS eq 'VMS') { # tssk, tssk: inconsistency alert!
+ local($CRLF) = "\015\012";
+ }
+
+ do {
+ $self->fillBuffer($FILLUNIT);
+ $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
+ $ok++ if $self->{BUFFER} eq '';
+ $bad++ if !$ok && $self->{LENGTH} <= 0;
+ # this was a bad idea
+ # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
+ } until $ok || $bad;
+ return () if $bad;
+
+ my($header) = substr($self->{BUFFER},0,$end+2);
+ substr($self->{BUFFER},0,$end+4) = '';
+ my %return;
+
+
+ # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
+ # (Folding Long Header Fields), 3.4.3 (Comments)
+ # and 3.4.5 (Quoted-Strings).
+
+ my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
+ $header=~s/$CRLF\s+/ /og; # merge continuation lines
+ while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
+ my ($field_name,$field_value) = ($1,$2); # avoid taintedness
+ $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
+ $return{$field_name}=$field_value;
+ }
+ return %return;
+}
+END_OF_FUNC
+
+# This reads and returns the body as a single scalar value.
+'readBody' => <<'END_OF_FUNC',
+sub readBody {
+ my($self) = @_;
+ my($data);
+ my($returnval)='';
+ while (defined($data = $self->read)) {
+ $returnval .= $data;
+ }
+ return $returnval;
+}
+END_OF_FUNC
+
+# This will read $bytes or until the boundary is hit, whichever happens
+# first. After the boundary is hit, we return undef. The next read will
+# skip over the boundary and begin reading again;
+'read' => <<'END_OF_FUNC',
+sub read {
+ my($self,$bytes) = @_;
+
+ # default number of bytes to read
+ $bytes = $bytes || $FILLUNIT;
+
+ # Fill up our internal buffer in such a way that the boundary
+ # is never split between reads.
+ $self->fillBuffer($bytes);
+
+ # Find the boundary in the buffer (it may not be there).
+ my $start = index($self->{BUFFER},$self->{BOUNDARY});
+ # protect against malformed multipart POST operations
+ die "Malformed multipart POST\n" unless ($start >= 0) || ($self->{LENGTH} > 0);
+
+ # If the boundary begins the data, then skip past it
+ # and return undef. The +2 here is a fiendish plot to
+ # remove the CR/LF pair at the end of the boundary.
+ if ($start == 0) {
+
+ # clear us out completely if we've hit the last boundary.
+ if (index($self->{BUFFER},"$self->{BOUNDARY}--")==0) {
+ $self->{BUFFER}='';
+ $self->{LENGTH}=0;
+ return undef;
+ }
+
+ # just remove the boundary.
+ substr($self->{BUFFER},0,length($self->{BOUNDARY})+2)='';
+ return undef;
+ }
+
+ my $bytesToReturn;
+ if ($start > 0) { # read up to the boundary
+ $bytesToReturn = $start > $bytes ? $bytes : $start;
+ } else { # read the requested number of bytes
+ # leave enough bytes in the buffer to allow us to read
+ # the boundary. Thanks to Kevin Hendrick for finding
+ # this one.
+ $bytesToReturn = $bytes - (length($self->{BOUNDARY})+1);
+ }
+
+ my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
+ substr($self->{BUFFER},0,$bytesToReturn)='';
+
+ # If we hit the boundary, remove the CRLF from the end.
+ return ($start > 0) ? substr($returnval,0,-2) : $returnval;
+}
+END_OF_FUNC
+
+
+# This fills up our internal buffer in such a way that the
+# boundary is never split between reads
+'fillBuffer' => <<'END_OF_FUNC',
+sub fillBuffer {
+ my($self,$bytes) = @_;
+ return unless $self->{LENGTH};
+
+ my($boundaryLength) = length($self->{BOUNDARY});
+ my($bufferLength) = length($self->{BUFFER});
+ my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
+ $bytesToRead = $self->{LENGTH} if $self->{LENGTH} < $bytesToRead;
+
+ # Try to read some data. We may hang here if the browser is screwed up.
+ my $bytesRead = $self->{INTERFACE}->read_from_client($self->{IN},
+ \$self->{BUFFER},
+ $bytesToRead,
+ $bufferLength);
+
+ # An apparent bug in the Apache server causes the read()
+ # to return zero bytes repeatedly without blocking if the
+ # remote user aborts during a file transfer. I don't know how
+ # they manage this, but the workaround is to abort if we get
+ # more than SPIN_LOOP_MAX consecutive zero reads.
+ if ($bytesRead == 0) {
+ die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
+ if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
+ } else {
+ $self->{ZERO_LOOP_COUNTER}=0;
+ }
+
+ $self->{LENGTH} -= $bytesRead;
+}
+END_OF_FUNC
+
+
+# Return true when we've finished reading
+'eof' => <<'END_OF_FUNC'
+sub eof {
+ my($self) = @_;
+ return 1 if (length($self->{BUFFER}) == 0)
+ && ($self->{LENGTH} <= 0);
+ undef;
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+####################################################################################
+################################## TEMPORARY FILES #################################
+####################################################################################
+package TempFile;
+
+$SL = $CGI::SL;
+$MAC = $CGI::OS eq 'MACINTOSH';
+my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
+unless ($TMPDIRECTORY) {
+ @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
+ "${SL}tmp","${SL}temp","${vol}${SL}Temporary Items",
+ "${SL}WWW_ROOT");
+ foreach (@TEMP) {
+ do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
+ }
+}
+
+$TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
+$SEQUENCE=0;
+$MAXTRIES = 5000;
+
+# cute feature, but overload implementation broke it
+# %OVERLOAD = ('""'=>'as_string');
+*TempFile::AUTOLOAD = \&CGI::AUTOLOAD;
+
+###############################################################################
+################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
+###############################################################################
+$AUTOLOADED_ROUTINES = ''; # prevent -w error
+$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
+%SUBS = (
+
+'new' => <<'END_OF_FUNC',
+sub new {
+ my($package) = @_;
+ my $directory;
+ my $i;
+ for ($i = 0; $i < $MAXTRIES; $i++) {
+ $directory = sprintf("${TMPDIRECTORY}${SL}CGItemp%d%04d",${$},++$SEQUENCE);
+ last if ! -f $directory;
+ }
+ return bless \$directory;
+}
+END_OF_FUNC
+
+'DESTROY' => <<'END_OF_FUNC',
+sub DESTROY {
+ my($self) = @_;
+ unlink $$self; # get rid of the file
+}
+END_OF_FUNC
+
+'as_string' => <<'END_OF_FUNC'
+sub as_string {
+ my($self) = @_;
+ return $$self;
+}
+END_OF_FUNC
+
+);
+END_OF_AUTOLOAD
+
+package CGI;
+
+# We get a whole bunch of warnings about "possibly uninitialized variables"
+# when running with the -w switch. Touch them all once to get rid of the
+# warnings. This is ugly and I hate it.
+if ($^W) {
+ $CGI::CGI = '';
+ $CGI::CGI=<<EOF;
+ $CGI::VERSION;
+ $MultipartBuffer::SPIN_LOOP_MAX;
+ $MultipartBuffer::CRLF;
+ $MultipartBuffer::TIMEOUT;
+ $MultipartBuffer::INITIAL_FILLUNIT;
+ $TempFile::SEQUENCE;
+EOF
+ ;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI - Simple Common Gateway Interface Class
+
+=head1 SYNOPSIS
+
+ # CGI script that creates a fill-out form
+ # and echoes back its values.
+
+ use CGI qw/:standard/;
+ print header,
+ start_html('A Simple Example'),
+ h1('A Simple Example'),
+ start_form,
+ "What's your name? ",textfield('name'),p,
+ "What's the combination?", p,
+ checkbox_group(-name=>'words',
+ -values=>['eenie','meenie','minie','moe'],
+ -defaults=>['eenie','minie']), p,
+ "What's your favorite color? ",
+ popup_menu(-name=>'color',
+ -values=>['red','green','blue','chartreuse']),p,
+ submit,
+ end_form,
+ hr;
+
+ if (param()) {
+ print "Your name is",em(param('name')),p,
+ "The keywords are: ",em(join(", ",param('words'))),p,
+ "Your favorite color is ",em(param('color')),
+ hr;
+ }
+
+=head1 ABSTRACT
+
+This perl library uses perl5 objects to make it easy to create Web
+fill-out forms and parse their contents. This package defines CGI
+objects, entities that contain the values of the current query string
+and other state variables. Using a CGI object's methods, you can
+examine keywords and parameters passed to your script, and create
+forms whose initial values are taken from the current query (thereby
+preserving state information). The module provides shortcut functions
+that produce boilerplate HTML, reducing typing and coding errors. It
+also provides functionality for some of the more advanced features of
+CGI scripting, including support for file uploads, cookies, cascading
+style sheets, server push, and frames.
+
+CGI.pm also provides a simple function-oriented programming style for
+those who don't need its object-oriented features.
+
+The current version of CGI.pm is available at
+
+ http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
+ ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+
+=head1 DESCRIPTION
+
+=head2 PROGRAMMING STYLE
+
+There are two styles of programming with CGI.pm, an object-oriented
+style and a function-oriented style. In the object-oriented style you
+create one or more CGI objects and then use object methods to create
+the various elements of the page. Each CGI object starts out with the
+list of named parameters that were passed to your CGI script by the
+server. You can modify the objects, save them to a file or database
+and recreate them. Because each object corresponds to the "state" of
+the CGI script, and because each object's parameter list is
+independent of the others, this allows you to save the state of the
+script and restore it later.
+
+For example, using the object oriented style, here is now you create
+a simple "Hello World" HTML page:
+
+ #!/usr/local/bin/pelr
+ use CGI; # load CGI routines
+ $q = new CGI; # create new CGI object
+ print $q->header, # create the HTTP header
+ $q->start_html('hello world'), # start the HTML
+ $q->h1('hello world'), # level 1 header
+ $q->end_html; # end the HTML
+
+In the function-oriented style, there is one default CGI object that
+you rarely deal with directly. Instead you just call functions to
+retrieve CGI parameters, create HTML tags, manage cookies, and so
+on. This provides you with a cleaner programming interface, but
+limits you to using one CGI object at a time. The following example
+prints the same page, but uses the function-oriented interface.
+The main differences are that we now need to import a set of functions
+into our name space (usually the "standard" functions), and we don't
+need to create the CGI object.
+
+ #!/usr/local/bin/pelr
+ use CGI qw/:standard/; # load standard CGI routines
+ print header, # create the HTTP header
+ start_html('hello world'), # start the HTML
+ h1('hello world'), # level 1 header
+ end_html; # end the HTML
+
+The examples in this document mainly use the object-oriented style.
+See HOW TO IMPORT FUNCTIONS for important information on
+function-oriented programming in CGI.pm
+
+=head2 CALLING CGI.PM ROUTINES
+
+Most CGI.pm routines accept several arguments, sometimes as many as 20
+optional ones! To simplify this interface, all routines use a named
+argument calling style that looks like this:
+
+ print $q->header(-type=>'image/gif',-expires=>'+3d');
+
+Each argument name is preceded by a dash. Neither case nor order
+matters in the argument list. -type, -Type, and -TYPE are all
+acceptable. In fact, only the first argument needs to begin with a
+dash. If a dash is present in the first argument, CGI.pm assumes
+dashes for the subsequent ones.
+
+You don't have to use the hyphen at allif you don't want to. After
+creating a CGI object, call the B<use_named_parameters()> method with
+a nonzero value. This will tell CGI.pm that you intend to use named
+parameters exclusively:
+
+ $query = new CGI;
+ $query->use_named_parameters(1);
+ $field = $query->radio_group('name'=>'OS',
+ 'values'=>['Unix','Windows','Macintosh'],
+ 'default'=>'Unix');
+
+Several routines are commonly called with just one argument. In the
+case of these routines you can provide the single argument without an
+argument name. header() happens to be one of these routines. In this
+case, the single argument is the document type.
+
+ print $q->header('text/html');
+
+Other such routines are documented below.
+
+Sometimes named arguments expect a scalar, sometimes a reference to an
+array, and sometimes a reference to a hash. Often, you can pass any
+type of argument and the routine will do whatever is most appropriate.
+For example, the param() routine is used to set a CGI parameter to a
+single or a multi-valued value. The two cases are shown below:
+
+ $q->param(-name=>'veggie',-value=>'tomato');
+ $q->param(-name=>'veggie',-value=>'[tomato','tomahto','potato','potahto']);
+
+A large number of routines in CGI.pm actually aren't specifically
+defined in the module, but are generated automatically as needed.
+These are the "HTML shortcuts," routines that generate HTML tags for
+use in dynamically-generated pages. HTML tags have both attributes
+(the attribute="value" pairs within the tag itself) and contents (the
+part between the opening and closing pairs.) To distinguish between
+attributes and contents, CGI.pm uses the convention of passing HTML
+attributes as a hash reference as the first argument, and the
+contents, if any, as any subsequent arguments. It works out like
+this:
+
+ Code Generated HTML
+ ---- --------------
+ h1() <H1>
+ h1('some','contents'); <H1>some contents</H1>
+ h1({-align=>left}); <H1 ALIGN="LEFT">
+ h1({-align=>left},'contents'); <H1 ALIGN="LEFT">contents</H1>
+
+HTML tags are described in more detail later.
+
+Many newcomers to CGI.pm are puzzled by the difference between the
+calling conventions for the HTML shortcuts, which require curly braces
+around the HTML tag attributes, and the calling conventions for other
+routines, which manage to generate attributes without the curly
+brackets. Don't be confused. As a convenience the curly braces are
+optional in all but the HTML shortcuts. If you like, you can use
+curly braces when calling any routine that takes named arguments. For
+example:
+
+ print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
+
+If you use the B<-w> switch, you will be warned that some CGI.pm argument
+names conflict with built-in Perl functions. The most frequent of
+these is the -values argument, used to create multi-valued menus,
+radio button clusters and the like. To get around this warning, you
+have several choices:
+
+=over 4
+
+=item 1. Use another name for the argument, if one is available. For
+example, -value is an alias for -values.
+
+=item 2. Change the capitalization, e.g. -Values
+
+=item 3. Put quotes around the argument name, e.g. '-values'
+
+=back
+
+Many routines will do something useful with a named argument that it
+doesn't recognize. For example, you can produce non-standard HTTP
+header fields by providing them as named arguments:
+
+ print $q->header(-type => 'text/html',
+ -cost => 'Three smackers',
+ -annoyance_level => 'high',
+ -complaints_to => 'bit bucket');
+
+This will produce the following nonstandard HTTP header:
+
+ HTTP/1.0 200 OK
+ Cost: Three smackers
+ Annoyance-level: high
+ Complaints-to: bit bucket
+ Content-type: text/html
+
+Notice the way that underscores are translated automatically into
+hyphens. HTML-generating routines perform a different type of
+translation.
+
+This feature allows you to keep up with the rapidly changing HTTP and
+HTML "standards".
+
+=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
+
+ $query = new CGI;
+
+This will parse the input (from both POST and GET methods) and store
+it into a perl5 object called $query.
+
+=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
+
+ $query = new CGI(INPUTFILE);
+
+If you provide a file handle to the new() method, it will read
+parameters from the file (or STDIN, or whatever). The file can be in
+any of the forms describing below under debugging (i.e. a series of
+newline delimited TAG=VALUE pairs will work). Conveniently, this type
+of file is created by the save() method (see below). Multiple records
+can be saved and restored.
+
+Perl purists will be pleased to know that this syntax accepts
+references to file handles, or even references to filehandle globs,
+which is the "official" way to pass a filehandle:
+
+ $query = new CGI(\*STDIN);
+
+You can also initialize the CGI object with a FileHandle or IO::File
+object.
+
+If you are using the function-oriented interface and want to
+initialize CGI state from a file handle, the way to do this is with
+B<restore_parameters()>. This will (re)initialize the
+default CGI object from the indicated file handle.
+
+ open (IN,"test.in") || die;
+ restore_parameters(IN);
+ close IN;
+
+You can also initialize the query object from an associative array
+reference:
+
+ $query = new CGI( {'dinosaur'=>'barney',
+ 'song'=>'I love you',
+ 'friends'=>[qw/Jessica George Nancy/]}
+ );
+
+or from a properly formatted, URL-escaped query string:
+
+ $query = new CGI('dinosaur=barney&color=purple');
+
+or from a previously existing CGI object (currently this clones the
+parameter list, but none of the other object-specific fields, such as
+autoescaping):
+
+ $old_query = new CGI;
+ $new_query = new CGI($old_query);
+
+To create an empty query, initialize it from an empty string or hash:
+
+ $empty_query = new CGI("");
+
+ -or-
+
+ $empty_query = new CGI({});
+
+=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
+
+ @keywords = $query->keywords
+
+If the script was invoked as the result of an <ISINDEX> search, the
+parsed keywords can be obtained as an array using the keywords() method.
+
+=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
+
+ @names = $query->param
+
+If the script was invoked with a parameter list
+(e.g. "name1=value1&name2=value2&name3=value3"), the param()
+method will return the parameter names as a list. If the
+script was invoked as an <ISINDEX> script, there will be a
+single parameter named 'keywords'.
+
+NOTE: As of version 1.5, the array of parameter names returned will
+be in the same order as they were submitted by the browser.
+Usually this order is the same as the order in which the
+parameters are defined in the form (however, this isn't part
+of the spec, and so isn't guaranteed).
+
+=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
+
+ @values = $query->param('foo');
+
+ -or-
+
+ $value = $query->param('foo');
+
+Pass the param() method a single argument to fetch the value of the
+named parameter. If the parameter is multivalued (e.g. from multiple
+selections in a scrolling list), you can ask to receive an array. Otherwise
+the method will return a single value.
+
+=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
+
+ $query->param('foo','an','array','of','values');
+
+This sets the value for the named parameter 'foo' to an array of
+values. This is one way to change the value of a field AFTER
+the script has been invoked once before. (Another way is with
+the -override parameter accepted by all methods that generate
+form elements.)
+
+param() also recognizes a named parameter style of calling described
+in more detail later:
+
+ $query->param(-name=>'foo',-values=>['an','array','of','values']);
+
+ -or-
+
+ $query->param(-name=>'foo',-value=>'the value');
+
+=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
+
+ $query->append(-name=>'foo',-values=>['yet','more','values']);
+
+This adds a value or list of values to the named parameter. The
+values are appended to the end of the parameter if it already exists.
+Otherwise the parameter is created. Note that this method only
+recognizes the named argument calling syntax.
+
+=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
+
+ $query->import_names('R');
+
+This creates a series of variables in the 'R' namespace. For example,
+$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
+If no namespace is given, this method will assume 'Q'.
+WARNING: don't import anything into 'main'; this is a major security
+risk!!!!
+
+In older versions, this method was called B<import()>. As of version 2.20,
+this name has been removed completely to avoid conflict with the built-in
+Perl module B<import> operator.
+
+=head2 DELETING A PARAMETER COMPLETELY:
+
+ $query->delete('foo');
+
+This completely clears a parameter. It sometimes useful for
+resetting parameters that you don't want passed down between
+script invocations.
+
+If you are using the function call interface, use "Delete()" instead
+to avoid conflicts with Perl's built-in delete operator.
+
+=head2 DELETING ALL PARAMETERS:
+
+ $query->delete_all();
+
+This clears the CGI object completely. It might be useful to ensure
+that all the defaults are taken when you create a fill-out form.
+
+Use Delete_all() instead if you are using the function call interface.
+
+=head2 DIRECT ACCESS TO THE PARAMETER LIST:
+
+ $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
+ unshift @{$q->param_fetch(-name=>'address')},'George Munster';
+
+If you need access to the parameter list in a way that isn't covered
+by the methods above, you can obtain a direct reference to it by
+calling the B<param_fetch()> method with the name of the . This
+will return an array reference to the named parameters, which you then
+can manipulate in any way you like.
+
+You can also use a named argument style using the B<-name> argument.
+
+=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
+
+ $query->save(FILEHANDLE)
+
+This will write the current state of the form to the provided
+filehandle. You can read it back in by providing a filehandle
+to the new() method. Note that the filehandle can be a file, a pipe,
+or whatever!
+
+The format of the saved file is:
+
+ NAME1=VALUE1
+ NAME1=VALUE1'
+ NAME2=VALUE2
+ NAME3=VALUE3
+ =
+
+Both name and value are URL escaped. Multi-valued CGI parameters are
+represented as repeated names. A session record is delimited by a
+single = symbol. You can write out multiple records and read them
+back in with several calls to B<new>. You can do this across several
+sessions by opening the file in append mode, allowing you to create
+primitive guest books, or to keep a history of users' queries. Here's
+a short example of creating multiple session records:
+
+ use CGI;
+
+ open (OUT,">>test.out") || die;
+ $records = 5;
+ foreach (0..$records) {
+ my $q = new CGI;
+ $q->param(-name=>'counter',-value=>$_);
+ $q->save(OUT);
+ }
+ close OUT;
+
+ # reopen for reading
+ open (IN,"test.out") || die;
+ while (!eof(IN)) {
+ my $q = new CGI(IN);
+ print $q->param('counter'),"\n";
+ }
+
+The file format used for save/restore is identical to that used by the
+Whitehead Genome Center's data exchange format "Boulderio", and can be
+manipulated and even databased using Boulderio utilities. See
+
+ http://www.genome.wi.mit.edu/genome_software/other/boulder.html
+
+for further details.
+
+If you wish to use this method from the function-oriented (non-OO)
+interface, the exported name for this method is B<save_parameters()>.
+
+=head2 USING THE FUNCTION-ORIENTED INTERFACE
+
+To use the function-oriented interface, you must specify which CGI.pm
+routines or sets of routines to import into your script's namespace.
+There is a small overhead associated with this importation, but it
+isn't much.
+
+ use CGI <list of methods>;
+
+The listed methods will be imported into the current package; you can
+call them directly without creating a CGI object first. This example
+shows how to import the B<param()> and B<header()>
+methods, and then use them directly:
+
+ use CGI 'param','header';
+ print header('text/plain');
+ $zipcode = param('zipcode');
+
+More frequently, you'll import common sets of functions by referring
+to the gropus by name. All function sets are preceded with a ":"
+character as in ":html3" (for tags defined in the HTML 3 standard).
+
+Here is a list of the function sets you can import:
+
+=over 4
+
+=item B<:cgi>
+
+Import all CGI-handling methods, such as B<param()>, B<path_info()>
+and the like.
+
+=item B<:form>
+
+Import all fill-out form generating methods, such as B<textfield()>.
+
+=item B<:html2>
+
+Import all methods that generate HTML 2.0 standard elements.
+
+=item B<:html3>
+
+Import all methods that generate HTML 3.0 proposed elements (such as
+<table>, <super> and <sub>).
+
+=item B<:netscape>
+
+Import all methods that generate Netscape-specific HTML extensions.
+
+=item B<:html>
+
+Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
+'netscape')...
+
+=item B<:standard>
+
+Import "standard" features, 'html2', 'html3', 'form' and 'cgi'.
+
+=item B<:all>
+
+Import all the available methods. For the full list, see the CGI.pm
+code, where the variable %TAGS is defined.
+
+=back
+
+If you import a function name that is not part of CGI.pm, the module
+will treat it as a new HTML tag and generate the appropriate
+subroutine. You can then use it like any other HTML tag. This is to
+provide for the rapidly-evolving HTML "standard." For example, say
+Microsoft comes out with a new tag called <GRADIENT> (which causes the
+user's desktop to be flooded with a rotating gradient fill until his
+machine reboots). You don't need to wait for a new version of CGI.pm
+to start using it immeidately:
+
+ use CGI qw/:standard :html3 gradient/;
+ print gradient({-start=>'red',-end=>'blue'});
+
+Note that in the interests of execution speed CGI.pm does B<not> use
+the standard L<Exporter> syntax for specifying load symbols. This may
+change in the future.
+
+If you import any of the state-maintaining CGI or form-generating
+methods, a default CGI object will be created and initialized
+automatically the first time you use any of the methods that require
+one to be present. This includes B<param()>, B<textfield()>,
+B<submit()> and the like. (If you need direct access to the CGI
+object, you can find it in the global variable B<$CGI::Q>). By
+importing CGI.pm methods, you can create visually elegant scripts:
+
+ use CGI qw/:standard/;
+ print
+ header,
+ start_html('Simple Script'),
+ h1('Simple Script'),
+ start_form,
+ "What's your name? ",textfield('name'),p,
+ "What's the combination?",
+ checkbox_group(-name=>'words',
+ -values=>['eenie','meenie','minie','moe'],
+ -defaults=>['eenie','moe']),p,
+ "What's your favorite color?",
+ popup_menu(-name=>'color',
+ -values=>['red','green','blue','chartreuse']),p,
+ submit,
+ end_form,
+ hr,"\n";
+
+ if (param) {
+ print
+ "Your name is ",em(param('name')),p,
+ "The keywords are: ",em(join(", ",param('words'))),p,
+ "Your favorite color is ",em(param('color')),".\n";
+ }
+ print end_html;
+
+=head2 PRAGMAS
+
+In addition to the function sets, there are a number of pragmas that
+you can import. Pragmas, which are always preceded by a hyphen,
+change the way that CGI.pm functions in various ways. Pragmas,
+function sets, and individual functions can all be imported in the
+same use() line. For example, the following use statement imports the
+standard set of functions and disables debugging mode (pragma
+-no_debug):
+
+ use CGI qw/:standard -no_debug/;
+
+The current list of pragmas is as follows:
+
+=over 4
+
+=item -any
+
+When you I<use CGI -any>, then any method that the query object
+doesn't recognize will be interpreted as a new HTML tag. This allows
+you to support the next I<ad hoc> Netscape or Microsoft HTML
+extension. This lets you go wild with new and unsupported tags:
+
+ use CGI qw(-any);
+ $q=new CGI;
+ print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
+
+Since using <cite>any</cite> causes any mistyped method name
+to be interpreted as an HTML tag, use it with care or not at
+all.
+
+=item -compile
+
+This causes the indicated autoloaded methods to be compiled up front,
+rather than deferred to later. This is useful for scripts that run
+for an extended period of time under FastCGI or mod_perl, and for
+those destined to be crunched by Malcom Beattie's Perl compiler. Use
+it in conjunction with the methods or method familes you plan to use.
+
+ use CGI qw(-compile :standard :html3);
+
+or even
+
+ use CGI qw(-compile :all);
+
+Note that using the -compile pragma in this way will always have
+the effect of importing the compiled functions into the current
+namespace. If you want to compile without importing use the
+compile() method instead (see below).
+
+=item -nph
+
+This makes CGI.pm produce a header appropriate for an NPH (no
+parsed header) script. You may need to do other things as well
+to tell the server that the script is NPH. See the discussion
+of NPH scripts below.
+
+=item -autoload
+
+This overrides the autoloader so that any function in your program
+that is not recognized is referred to CGI.pm for possible evaluation.
+This allows you to use all the CGI.pm functions without adding them to
+your symbol table, which is of concern for mod_perl users who are
+worried about memory consumption. I<Warning:> when
+I<-autoload> is in effect, you cannot use "poetry mode"
+(functions without the parenthesis). Use I<hr()> rather
+than I<hr>, or add something like I<use subs qw/hr p header/>
+to the top of your script.
+
+=item -no_debug
+
+This turns off the command-line processing features. If you want to
+run a CGI.pm script from the command line to produce HTML, and you
+don't want it pausing to request CGI parameters from standard input or
+the command line, then use this pragma:
+
+ use CGI qw(-no_debug :standard);
+
+If you'd like to process the command-line parameters but not standard
+input, this should work:
+
+ use CGI qw(-no_debug :standard);
+ restore_parameters(join('&',@ARGV));
+
+See the section on debugging for more details.
+
+=item -private_tempfiles
+
+CGI.pm can process uploaded file. Ordinarily it spools the
+uploaded file to a temporary directory, then deletes the file
+when done. However, this opens the risk of eavesdropping as
+described in the file upload section.
+Another CGI script author could peek at this data during the
+upload, even if it is confidential information. On Unix systems,
+the -private_tempfiles pragma will cause the temporary file to be unlinked as soon
+as it is opened and before any data is written into it,
+eliminating the risk of eavesdropping.
+n
+=back
+
+=head1 GENERATING DYNAMIC DOCUMENTS
+
+Most of CGI.pm's functions deal with creating documents on the fly.
+Generally you will produce the HTTP header first, followed by the
+document itself. CGI.pm provides functions for generating HTTP
+headers of various types as well as for generating HTML. For creating
+GIF images, see the GD.pm module.
+
+Each of these functions produces a fragment of HTML or HTTP which you
+can print out directly so that it displays in the browser window,
+append to a string, or save to a file for later use.
+
+=head2 CREATING A STANDARD HTTP HEADER:
+
+Normally the first thing you will do in any CGI script is print out an
+HTTP header. This tells the browser what type of document to expect,
+and gives other optional information, such as the language, expiration
+date, and whether to cache the document. The header can also be
+manipulated for special purposes, such as server push and pay per view
+pages.
+
+ print $query->header;
+
+ -or-
+
+ print $query->header('image/gif');
+
+ -or-
+
+ print $query->header('text/html','204 No response');
+
+ -or-
+
+ print $query->header(-type=>'image/gif',
+ -nph=>1,
+ -status=>'402 Payment required',
+ -expires=>'+3d',
+ -cookie=>$cookie,
+ -Cost=>'$2.00');
+
+header() returns the Content-type: header. You can provide your own
+MIME type if you choose, otherwise it defaults to text/html. An
+optional second parameter specifies the status code and a human-readable
+message. For example, you can specify 204, "No response" to create a
+script that tells the browser to do nothing at all.
+
+The last example shows the named argument style for passing arguments
+to the CGI methods using named parameters. Recognized parameters are
+B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
+parameters will be stripped of their initial hyphens and turned into
+header fields, allowing you to specify any HTTP header you desire.
+Internal underscores will be turned into hyphens:
+
+ print $query->header(-Content_length=>3002);
+
+Most browsers will not cache the output from CGI scripts. Every time
+the browser reloads the page, the script is invoked anew. You can
+change this behavior with the B<-expires> parameter. When you specify
+an absolute or relative expiration interval with this parameter, some
+browsers and proxy servers will cache the script's output until the
+indicated expiration date. The following forms are all valid for the
+-expires field:
+
+ +30s 30 seconds from now
+ +10m ten minutes from now
+ +1h one hour from now
+ -1d yesterday (i.e. "ASAP!")
+ now immediately
+ +3M in three months
+ +10y in ten years time
+ Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
+
+The B<-cookie> parameter generates a header that tells the browser to provide
+a "magic cookie" during all subsequent transactions with your script.
+Netscape cookies have a special format that includes interesting attributes
+such as expiration time. Use the cookie() method to create and retrieve
+session cookies.
+
+The B<-nph> parameter, if set to a true value, will issue the correct
+headers to work with a NPH (no-parse-header) script. This is important
+to use with certain servers, such as Microsoft Internet Explorer, which
+expect all their scripts to be NPH.
+
+=head2 GENERATING A REDIRECTION HEADER
+
+ print $query->redirect('http://somewhere.else/in/movie/land');
+
+Sometimes you don't want to produce a document yourself, but simply
+redirect the browser elsewhere, perhaps choosing a URL based on the
+time of day or the identity of the user.
+
+The redirect() function redirects the browser to a different URL. If
+you use redirection like this, you should B<not> print out a header as
+well. As of version 2.0, we produce both the unofficial Location:
+header and the official URI: header. This should satisfy most servers
+and browsers.
+
+One hint I can offer is that relative links may not work correctly
+when you generate a redirection to another document on your site.
+This is due to a well-intentioned optimization that some servers use.
+The solution to this is to use the full URL (including the http: part)
+of the document you are redirecting to.
+
+You can also use named arguments:
+
+ print $query->redirect(-uri=>'http://somewhere.else/in/movie/land',
+ -nph=>1);
+
+The B<-nph> parameter, if set to a true value, will issue the correct
+headers to work with a NPH (no-parse-header) script. This is important
+to use with certain servers, such as Microsoft Internet Explorer, which
+expect all their scripts to be NPH.
+
+=head2 CREATING THE HTML DOCUMENT HEADER
+
+ print $query->start_html(-title=>'Secrets of the Pyramids',
+ -author=>'fred@capricorn.org',
+ -base=>'true',
+ -target=>'_blank',
+ -meta=>{'keywords'=>'pharaoh secret mummy',
+ 'copyright'=>'copyright 1996 King Tut'},
+ -style=>{'src'=>'/styles/style1.css'},
+ -BGCOLOR=>'blue');
+
+After creating the HTTP header, most CGI scripts will start writing
+out an HTML document. The start_html() routine creates the top of the
+page, along with a lot of optional information that controls the
+page's appearance and behavior.
+
+This method returns a canned HTML header and the opening <BODY> tag.
+All parameters are optional. In the named parameter form, recognized
+parameters are -title, -author, -base, -xbase and -target (see below
+for the explanation). Any additional parameters you provide, such as
+the Netscape unofficial BGCOLOR attribute, are added to the <BODY>
+tag. Additional parameters must be proceeded by a hyphen.
+
+The argument B<-xbase> allows you to provide an HREF for the <BASE> tag
+different from the current location, as in
+
+ -xbase=>"http://home.mcom.com/"
+
+All relative links will be interpreted relative to this tag.
+
+The argument B<-target> allows you to provide a default target frame
+for all the links and fill-out forms on the page. See the Netscape
+documentation on frames for details of how to manipulate this.
+
+ -target=>"answer_window"
+
+All relative links will be interpreted relative to this tag.
+You add arbitrary meta information to the header with the B<-meta>
+argument. This argument expects a reference to an associative array
+containing name/value pairs of meta information. These will be turned
+into a series of header <META> tags that look something like this:
+
+ <META NAME="keywords" CONTENT="pharaoh secret mummy">
+ <META NAME="description" CONTENT="copyright 1996 King Tut">
+
+There is no support for the HTTP-EQUIV type of <META> tag. This is
+because you can modify the HTTP header directly with the B<header()>
+method. For example, if you want to send the Refresh: header, do it
+in the header() method:
+
+ print $q->header(-Refresh=>'10; URL=http://www.capricorn.com');
+
+The B<-style> tag is used to incorporate cascading stylesheets into
+your code. See the section on CASCADING STYLESHEETS for more information.
+
+You can place other arbitrary HTML elements to the <HEAD> section with the
+B<-head> tag. For example, to place the rarely-used <LINK> element in the
+head section, use this:
+
+ print $q->start_html(-head=>Link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}));
+
+To incorporate multiple HTML elements into the <HEAD> section, just pass an
+array reference:
+
+ print $q->start_html(-head=>[
+ Link({-rel=>'next',
+ -href=>'http://www.capricorn.com/s2.html'}),
+ Link({-rel=>'previous',
+ -href=>'http://www.capricorn.com/s1.html'})
+ ]
+ );
+
+JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
+B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
+to add Netscape JavaScript calls to your pages. B<-script> should
+point to a block of text containing JavaScript function definitions.
+This block will be placed within a <SCRIPT> block inside the HTML (not
+HTTP) header. The block is placed in the header in order to give your
+page a fighting chance of having all its JavaScript functions in place
+even if the user presses the stop button before the page has loaded
+completely. CGI.pm attempts to format the script in such a way that
+JavaScript-naive browsers will not choke on the code: unfortunately
+there are some browsers, such as Chimera for Unix, that get confused
+by it nevertheless.
+
+The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
+code to execute when the page is respectively opened and closed by the
+browser. Usually these parameters are calls to functions defined in the
+B<-script> field:
+
+ $query = new CGI;
+ print $query->header;
+ $JSCRIPT=<<END;
+ // Ask a silly question
+ function riddle_me_this() {
+ var r = prompt("What walks on four legs in the morning, " +
+ "two legs in the afternoon, " +
+ "and three legs in the evening?");
+ response(r);
+ }
+ // Get a silly answer
+ function response(answer) {
+ if (answer == "man")
+ alert("Right you are!");
+ else
+ alert("Wrong! Guess again.");
+ }
+ END
+ print $query->start_html(-title=>'The Riddle of the Sphinx',
+ -script=>$JSCRIPT);
+
+Use the B<-noScript> parameter to pass some HTML text that will be displayed on
+browsers that do not have JavaScript (or browsers where JavaScript is turned
+off).
+
+Netscape 3.0 recognizes several attributes of the <SCRIPT> tag,
+including LANGUAGE and SRC. The latter is particularly interesting,
+as it allows you to keep the JavaScript code in a file or CGI script
+rather than cluttering up each page with the source. To use these
+attributes pass a HASH reference in the B<-script> parameter containing
+one or more of -language, -src, or -code:
+
+ print $q->start_html(-title=>'The Riddle of the Sphinx',
+ -script=>{-language=>'JAVASCRIPT',
+ -src=>'/javascript/sphinx.js'}
+ );
+
+ print $q->(-title=>'The Riddle of the Sphinx',
+ -script=>{-language=>'PERLSCRIPT'},
+ -code=>'print "hello world!\n;"'
+ );
+
+
+A final feature allows you to incorporate multiple <SCRIPT> sections into the
+header. Just pass the list of script sections as an array reference.
+this allows you to specify different source files for different dialects
+of JavaScript. Example:
+
+ print $q-&gt;start_html(-title=&gt;'The Riddle of the Sphinx',
+ -script=&gt;[
+ { -language =&gt; 'JavaScript1.0',
+ -src =&gt; '/javascript/utilities10.js'
+ },
+ { -language =&gt; 'JavaScript1.1',
+ -src =&gt; '/javascript/utilities11.js'
+ },
+ { -language =&gt; 'JavaScript1.2',
+ -src =&gt; '/javascript/utilities12.js'
+ },
+ { -language =&gt; 'JavaScript28.2',
+ -src =&gt; '/javascript/utilities219.js'
+ }
+ ]
+ );
+ </pre>
+
+If this looks a bit extreme, take my advice and stick with straight CGI scripting.
+
+See
+
+ http://home.netscape.com/eng/mozilla/2.0/handbook/javascript/
+
+for more information about JavaScript.
+
+The old-style positional parameters are as follows:
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The title
+
+=item 2.
+
+The author's e-mail address (will create a <LINK REV="MADE"> tag if present
+
+=item 3.
+
+A 'true' flag if you want to include a <BASE> tag in the header. This
+helps resolve relative addresses to absolute ones when the document is moved,
+but makes the document hierarchy non-portable. Use with care!
+
+=item 4, 5, 6...
+
+Any other parameters you want to include in the <BODY> tag. This is a good
+place to put Netscape extensions, such as colors and wallpaper patterns.
+
+=back
+
+=head2 ENDING THE HTML DOCUMENT:
+
+ print $query->end_html
+
+This ends an HTML document by printing the </BODY></HTML> tags.
+
+=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
+
+ $myself = $query->self_url;
+ print "<A HREF=$myself>I'm talking to myself.</A>";
+
+self_url() will return a URL, that, when selected, will reinvoke
+this script with all its state information intact. This is most
+useful when you want to jump around within the document using
+internal anchors but you don't want to disrupt the current contents
+of the form(s). Something like this will do the trick.
+
+ $myself = $query->self_url;
+ print "<A HREF=$myself#table1>See table 1</A>";
+ print "<A HREF=$myself#table2>See table 2</A>";
+ print "<A HREF=$myself#yourself>See for yourself</A>";
+
+If you want more control over what's returned, using the B<url()>
+method instead.
+
+You can also retrieve the unprocessed query string with query_string():
+
+ $the_string = $query->query_string;
+
+=head2 OBTAINING THE SCRIPT'S URL
+
+ $full_url = $query->url();
+ $full_url = $query->url(-full=>1); #alternative syntax
+ $relative_url = $query->url(-relative=>1);
+ $absolute_url = $query->url(-absolute=>1);
+ $url_with_path = $query->url(-path_info=>1);
+ $url_with_path_and_query = $query->url(-path_info=>1,-query=>1);
+
+B<url()> returns the script's URL in a variety of formats. Called
+without any arguments, it returns the full form of the URL, including
+host name and port number
+
+ http://your.host.com/path/to/script.cgi
+
+You can modify this format with the following named arguments:
+
+=over 4
+
+=item B<-absolute>
+
+If true, produce an absolute URL, e.g.
+
+ /path/to/script.cgi
+
+=item B<-relative>
+
+Produce a relative URL. This is useful if you want to reinvoke your
+script with different parameters. For example:
+
+ script.cgi
+
+=item B<-full>
+
+Produce the full URL, exactly as if called without any arguments.
+This overrides the -relative and -absolute arguments.
+
+=item B<-path> (B<-path_info>)
+
+Append the additional path information to the URL. This can be
+combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
+is provided as a synonym.
+
+=item B<-query> (B<-query_string>)
+
+Append the query string to the URL. This can be combined with
+B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
+as a synonym.
+
+=back
+
+=head1 CREATING STANDARD HTML ELEMENTS:
+
+CGI.pm defines general HTML shortcut methods for most, if not all of
+the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
+HTML element and return a fragment of HTML text that you can then
+print or manipulate as you like. Each shortcut returns a fragment of
+HTML code that you can append to a string, save to a file, or, most
+commonly, print out so that it displays in the browser window.
+
+This example shows how to use the HTML methods:
+
+ $q = new CGI;
+ print $q->blockquote(
+ "Many years ago on the island of",
+ $q->a({href=>"http://crete.org/"},"Crete"),
+ "there lived a minotaur named",
+ $q->strong("Fred."),
+ ),
+ $q->hr;
+
+This results in the following HTML code (extra newlines have been
+added for readability):
+
+ <blockquote>
+ Many years ago on the island of
+ <a HREF="http://crete.org/">Crete</a> there lived
+ a minotaur named <strong>Fred.</strong>
+ </blockquote>
+ <hr>
+
+If you find the syntax for calling the HTML shortcuts awkward, you can
+import them into your namespace and dispense with the object syntax
+completely (see the next section for more details):
+
+ use CGI ':standard';
+ print blockquote(
+ "Many years ago on the island of",
+ a({href=>"http://crete.org/"},"Crete"),
+ "there lived a minotaur named",
+ strong("Fred."),
+ ),
+ hr;
+
+=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
+
+The HTML methods will accept zero, one or multiple arguments. If you
+provide no arguments, you get a single tag:
+
+ print hr; # <HR>
+
+If you provide one or more string arguments, they are concatenated
+together with spaces and placed between opening and closing tags:
+
+ print h1("Chapter","1"); # <H1>Chapter 1</H1>"
+
+If the first argument is an associative array reference, then the keys
+and values of the associative array become the HTML tag's attributes:
+
+ print a({-href=>'fred.html',-target=>'_new'},
+ "Open a new frame");
+
+ <A HREF="fred.html",TARGET="_new">Open a new frame</A>
+
+You may dispense with the dashes in front of the attribute names if
+you prefer:
+
+ print img {src=>'fred.gif',align=>'LEFT'};
+
+ <IMG ALIGN="LEFT" SRC="fred.gif">
+
+Sometimes an HTML tag attribute has no argument. For example, ordered
+lists can be marked as COMPACT. The syntax for this is an argument that
+that points to an undef string:
+
+ print ol({compact=>undef},li('one'),li('two'),li('three'));
+
+Prior to CGI.pm version 2.41, providing an empty ('') string as an
+attribute argument was the same as providing undef. However, this has
+changed in order to accomodate those who want to create tags of the form
+<IMG ALT="">. The difference is shown in these two pieces of code:
+
+ CODE RESULT
+ img({alt=>undef}) <IMG ALT>
+ img({alt=>''}) <IMT ALT="">
+
+=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
+
+One of the cool features of the HTML shortcuts is that they are
+distributive. If you give them an argument consisting of a
+B<reference> to a list, the tag will be distributed across each
+element of the list. For example, here's one way to make an ordered
+list:
+
+ print ul(
+ li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy']);
+ );
+
+This example will result in HTML output that looks like this:
+
+ <UL>
+ <LI TYPE="disc">Sneezy</LI>
+ <LI TYPE="disc">Doc</LI>
+ <LI TYPE="disc">Sleepy</LI>
+ <LI TYPE="disc">Happy</LI>
+ </UL>
+
+This is extremely useful for creating tables. For example:
+
+ print table({-border=>undef},
+ caption('When Should You Eat Your Vegetables?'),
+ Tr({-align=>CENTER,-valign=>TOP},
+ [
+ th(['Vegetable', 'Breakfast','Lunch','Dinner']),
+ td(['Tomatoes' , 'no', 'yes', 'yes']),
+ td(['Broccoli' , 'no', 'no', 'yes']),
+ td(['Onions' , 'yes','yes', 'yes'])
+ ]
+ )
+ );
+
+=head2 HTML SHORTCUTS AND LIST INTERPOLATION
+
+Consider this bit of code:
+
+ print blockquote(em('Hi'),'mom!'));
+
+It will ordinarily return the string that you probably expect, namely:
+
+ <BLOCKQUOTE><EM>Hi</EM> mom!</BLOCKQUOTE>
+
+Note the space between the element "Hi" and the element "mom!".
+CGI.pm puts the extra space there using array interpolation, which is
+controlled by the magic $" variable. Sometimes this extra space is
+not what you want, for example, when you are trying to align a series
+of images. In this case, you can simply change the value of $" to an
+empty string.
+
+ {
+ local($") = '';
+ print blockquote(em('Hi'),'mom!'));
+ }
+
+I suggest you put the code in a block as shown here. Otherwise the
+change to $" will affect all subsequent code until you explicitly
+reset it.
+
+=head2 NON-STANDARD HTML SHORTCUTS
+
+A few HTML tags don't follow the standard pattern for various
+reasons.
+
+B<comment()> generates an HTML comment (<!-- comment -->). Call it
+like
+
+ print comment('here is my comment');
+
+Because of conflicts with built-in Perl functions, the following functions
+begin with initial caps:
+
+ Select
+ Tr
+ Link
+ Delete
+
+In addition, start_html(), end_html(), start_form(), end_form(),
+start_multipart_form() and all the fill-out form tags are special.
+See their respective sections.
+
+=head1 CREATING FILL-OUT FORMS:
+
+I<General note> The various form-creating methods all return strings
+to the caller, containing the tag or tags that will create the requested
+form element. You are responsible for actually printing out these strings.
+It's set up this way so that you can place formatting tags
+around the form elements.
+
+I<Another note> The default values that you specify for the forms are only
+used the B<first> time the script is invoked (when there is no query
+string). On subsequent invocations of the script (when there is a query
+string), the former values are used even if they are blank.
+
+If you want to change the value of a field from its previous value, you have two
+choices:
+
+(1) call the param() method to set it.
+
+(2) use the -override (alias -force) parameter (a new feature in version 2.15).
+This forces the default value to be used, regardless of the previous value:
+
+ print $query->textfield(-name=>'field_name',
+ -default=>'starting value',
+ -override=>1,
+ -size=>50,
+ -maxlength=>80);
+
+I<Yet another note> By default, the text and labels of form elements are
+escaped according to HTML rules. This means that you can safely use
+"<CLICK ME>" as the label for a button. However, it also interferes with
+your ability to incorporate special HTML character sequences, such as &Aacute;,
+into your fields. If you wish to turn off automatic escaping, call the
+autoEscape() method with a false value immediately after creating the CGI object:
+
+ $query = new CGI;
+ $query->autoEscape(undef);
+
+
+=head2 CREATING AN ISINDEX TAG
+
+ print $query->isindex(-action=>$action);
+
+ -or-
+
+ print $query->isindex($action);
+
+Prints out an <ISINDEX> tag. Not very exciting. The parameter
+-action specifies the URL of the script to process the query. The
+default is to process the query with the current script.
+
+=head2 STARTING AND ENDING A FORM
+
+ print $query->startform(-method=>$method,
+ -action=>$action,
+ -encoding=>$encoding);
+ <... various form stuff ...>
+ print $query->endform;
+
+ -or-
+
+ print $query->startform($method,$action,$encoding);
+ <... various form stuff ...>
+ print $query->endform;
+
+startform() will return a <FORM> tag with the optional method,
+action and form encoding that you specify. The defaults are:
+
+ method: POST
+ action: this script
+ encoding: application/x-www-form-urlencoded
+
+endform() returns the closing </FORM> tag.
+
+Startform()'s encoding method tells the browser how to package the various
+fields of the form before sending the form to the server. Two
+values are possible:
+
+=over 4
+
+=item B<application/x-www-form-urlencoded>
+
+This is the older type of encoding used by all browsers prior to
+Netscape 2.0. It is compatible with many CGI scripts and is
+suitable for short fields containing text data. For your
+convenience, CGI.pm stores the name of this encoding
+type in B<$CGI::URL_ENCODED>.
+
+=item B<multipart/form-data>
+
+This is the newer type of encoding introduced by Netscape 2.0.
+It is suitable for forms that contain very large fields or that
+are intended for transferring binary data. Most importantly,
+it enables the "file upload" feature of Netscape 2.0 forms. For
+your convenience, CGI.pm stores the name of this encoding type
+in B<&CGI::MULTIPART>
+
+Forms that use this type of encoding are not easily interpreted
+by CGI scripts unless they use CGI.pm or another library designed
+to handle them.
+
+=back
+
+For compatibility, the startform() method uses the older form of
+encoding by default. If you want to use the newer form of encoding
+by default, you can call B<start_multipart_form()> instead of
+B<startform()>.
+
+JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
+for use with JavaScript. The -name parameter gives the
+form a name so that it can be identified and manipulated by
+JavaScript functions. -onSubmit should point to a JavaScript
+function that will be executed just before the form is submitted to your
+server. You can use this opportunity to check the contents of the form
+for consistency and completeness. If you find something wrong, you
+can put up an alert box or maybe fix things up yourself. You can
+abort the submission by returning false from this function.
+
+Usually the bulk of JavaScript functions are defined in a <SCRIPT>
+block in the HTML header and -onSubmit points to one of these function
+call. See start_html() for details.
+
+=head2 CREATING A TEXT FIELD
+
+ print $query->textfield(-name=>'field_name',
+ -default=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print $query->textfield('field_name','starting value',50,80);
+
+textfield() will return a text input field.
+
+=over 4
+
+=item B<Parameters>
+
+=item 1.
+
+The first parameter is the required name for the field (-name).
+
+=item 2.
+
+The optional second parameter is the default starting value for the field
+contents (-default).
+
+=item 3.
+
+The optional third parameter is the size of the field in
+ characters (-size).
+
+=item 4.
+
+The optional fourth parameter is the maximum number of characters the
+ field will accept (-maxlength).
+
+=back
+
+As with all these methods, the field will be initialized with its
+previous contents from earlier invocations of the script.
+When the form is processed, the value of the text field can be
+retrieved with:
+
+ $value = $query->param('foo');
+
+If you want to reset it from its initial value after the script has been
+called once, you can do so like this:
+
+ $query->param('foo',"I'm taking over this value!");
+
+NEW AS OF VERSION 2.15: If you don't want the field to take on its previous
+value, you can force its current value by using the -override (alias -force)
+parameter:
+
+ print $query->textfield(-name=>'field_name',
+ -default=>'starting value',
+ -override=>1,
+ -size=>50,
+ -maxlength=>80);
+
+JAVASCRIPTING: You can also provide B<-onChange>, B<-onFocus>,
+B<-onBlur>, B<-onMouseOver>, B<-onMouseOut> and B<-onSelect>
+parameters to register JavaScript event handlers. The onChange
+handler will be called whenever the user changes the contents of the
+text field. You can do text validation if you like. onFocus and
+onBlur are called respectively when the insertion point moves into and
+out of the text field. onSelect is called when the user changes the
+portion of the text that is selected.
+
+=head2 CREATING A BIG TEXT FIELD
+
+ print $query->textarea(-name=>'foo',
+ -default=>'starting value',
+ -rows=>10,
+ -columns=>50);
+
+ -or
+
+ print $query->textarea('foo','starting value',10,50);
+
+textarea() is just like textfield, but it allows you to specify
+rows and columns for a multiline text entry box. You can provide
+a starting value for the field, which can be long and contain
+multiple lines.
+
+JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur> ,
+B<-onMouseOver>, B<-onMouseOut>, and B<-onSelect> parameters are
+recognized. See textfield().
+
+=head2 CREATING A PASSWORD FIELD
+
+ print $query->password_field(-name=>'secret',
+ -value=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print $query->password_field('secret','starting value',50,80);
+
+password_field() is identical to textfield(), except that its contents
+will be starred out on the web page.
+
+JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
+B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
+recognized. See textfield().
+
+=head2 CREATING A FILE UPLOAD FIELD
+
+ print $query->filefield(-name=>'uploaded_file',
+ -default=>'starting value',
+ -size=>50,
+ -maxlength=>80);
+ -or-
+
+ print $query->filefield('uploaded_file','starting value',50,80);
+
+filefield() will return a file upload field for Netscape 2.0 browsers.
+In order to take full advantage of this I<you must use the new
+multipart encoding scheme> for the form. You can do this either
+by calling B<startform()> with an encoding type of B<$CGI::MULTIPART>,
+or by calling the new method B<start_multipart_form()> instead of
+vanilla B<startform()>.
+
+=over 4
+
+=item B<Parameters>
+
+=item 1.
+
+The first parameter is the required name for the field (-name).
+
+=item 2.
+
+The optional second parameter is the starting value for the field contents
+to be used as the default file name (-default).
+
+The beta2 version of Netscape 2.0 currently doesn't pay any attention
+to this field, and so the starting value will always be blank. Worse,
+the field loses its "sticky" behavior and forgets its previous
+contents. The starting value field is called for in the HTML
+specification, however, and possibly later versions of Netscape will
+honor it.
+
+=item 3.
+
+The optional third parameter is the size of the field in
+characters (-size).
+
+=item 4.
+
+The optional fourth parameter is the maximum number of characters the
+field will accept (-maxlength).
+
+=back
+
+When the form is processed, you can retrieve the entered filename
+by calling param().
+
+ $filename = $query->param('uploaded_file');
+
+In Netscape Navigator 2.0, the filename that gets returned is the full
+local filename on the B<remote user's> machine. If the remote user is
+on a Unix machine, the filename will follow Unix conventions:
+
+ /path/to/the/file
+
+On an MS-DOS/Windows and OS/2 machines, the filename will follow DOS conventions:
+
+ C:\PATH\TO\THE\FILE.MSW
+
+On a Macintosh machine, the filename will follow Mac conventions:
+
+ HD 40:Desktop Folder:Sort Through:Reminders
+
+The filename returned is also a file handle. You can read the contents
+of the file using standard Perl file reading calls:
+
+ # Read a text file and print it out
+ while (<$filename>) {
+ print;
+ }
+
+ # Copy a binary file to somewhere safe
+ open (OUTFILE,">>/usr/local/web/users/feedback");
+ while ($bytesread=read($filename,$buffer,1024)) {
+ print OUTFILE $buffer;
+ }
+
+When a file is uploaded the browser usually sends along some
+information along with it in the format of headers. The information
+usually includes the MIME content type. Future browsers may send
+other information as well (such as modification date and size). To
+retrieve this information, call uploadInfo(). It returns a reference to
+an associative array containing all the document headers.
+
+ $filename = $query->param('uploaded_file');
+ $type = $query->uploadInfo($filename)->{'Content-Type'};
+ unless ($type eq 'text/html') {
+ die "HTML FILES ONLY!";
+ }
+
+If you are using a machine that recognizes "text" and "binary" data
+modes, be sure to understand when and how to use them (see the Camel book).
+Otherwise you may find that binary files are corrupted during file uploads.
+
+JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
+B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
+recognized. See textfield() for details.
+
+=head2 CREATING A POPUP MENU
+
+ print $query->popup_menu('menu_name',
+ ['eenie','meenie','minie'],
+ 'meenie');
+
+ -or-
+
+ %labels = ('eenie'=>'your first choice',
+ 'meenie'=>'your second choice',
+ 'minie'=>'your third choice');
+ print $query->popup_menu('menu_name',
+ ['eenie','meenie','minie'],
+ 'meenie',\%labels);
+
+ -or (named parameter style)-
+
+ print $query->popup_menu(-name=>'menu_name',
+ -values=>['eenie','meenie','minie'],
+ -default=>'meenie',
+ -labels=>\%labels);
+
+popup_menu() creates a menu.
+
+=over 4
+
+=item 1.
+
+The required first argument is the menu's name (-name).
+
+=item 2.
+
+The required second argument (-values) is an array B<reference>
+containing the list of menu items in the menu. You can pass the
+method an anonymous array, as shown in the example, or a reference to
+a named array, such as "\@foo".
+
+=item 3.
+
+The optional third parameter (-default) is the name of the default
+menu choice. If not specified, the first item will be the default.
+The values of the previous choice will be maintained across queries.
+
+=item 4.
+
+The optional fourth parameter (-labels) is provided for people who
+want to use different values for the user-visible label inside the
+popup menu nd the value returned to your script. It's a pointer to an
+associative array relating menu values to user-visible labels. If you
+leave this parameter blank, the menu values will be displayed by
+default. (You can also leave a label undefined if you want to).
+
+=back
+
+When the form is processed, the selected value of the popup menu can
+be retrieved using:
+
+ $popup_menu_value = $query->param('menu_name');
+
+JAVASCRIPTING: popup_menu() recognizes the following event handlers:
+B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>, and
+B<-onBlur>. See the textfield() section for details on when these
+handlers are called.
+
+=head2 CREATING A SCROLLING LIST
+
+ print $query->scrolling_list('list_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],5,'true');
+ -or-
+
+ print $query->scrolling_list('list_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],5,'true',
+ \%labels);
+
+ -or-
+
+ print $query->scrolling_list(-name=>'list_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -default=>['eenie','moe'],
+ -size=>5,
+ -multiple=>'true',
+ -labels=>\%labels);
+
+scrolling_list() creates a scrolling list.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first and second arguments are the list name (-name) and values
+(-values). As in the popup menu, the second argument should be an
+array reference.
+
+=item 2.
+
+The optional third argument (-default) can be either a reference to a
+list containing the values to be selected by default, or can be a
+single value to select. If this argument is missing or undefined,
+then nothing is selected when the list first appears. In the named
+parameter version, you can use the synonym "-defaults" for this
+parameter.
+
+=item 3.
+
+The optional fourth argument is the size of the list (-size).
+
+=item 4.
+
+The optional fifth argument can be set to true to allow multiple
+simultaneous selections (-multiple). Otherwise only one selection
+will be allowed at a time.
+
+=item 5.
+
+The optional sixth argument is a pointer to an associative array
+containing long user-visible labels for the list items (-labels).
+If not provided, the values will be displayed.
+
+When this form is processed, all selected list items will be returned as
+a list under the parameter name 'list_name'. The values of the
+selected items can be retrieved with:
+
+ @selected = $query->param('list_name');
+
+=back
+
+JAVASCRIPTING: scrolling_list() recognizes the following event
+handlers: B<-onChange>, B<-onFocus>, B<-onMouseOver>, B<-onMouseOut>
+and B<-onBlur>. See textfield() for the description of when these
+handlers are called.
+
+=head2 CREATING A GROUP OF RELATED CHECKBOXES
+
+ print $query->checkbox_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -default=>['eenie','moe'],
+ -linebreak=>'true',
+ -labels=>\%labels);
+
+ print $query->checkbox_group('group_name',
+ ['eenie','meenie','minie','moe'],
+ ['eenie','moe'],'true',\%labels);
+
+ HTML3-COMPATIBLE BROWSERS ONLY:
+
+ print $query->checkbox_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -rows=2,-columns=>2);
+
+
+checkbox_group() creates a list of checkboxes that are related
+by the same name.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first and second arguments are the checkbox name and values,
+respectively (-name and -values). As in the popup menu, the second
+argument should be an array reference. These values are used for the
+user-readable labels printed next to the checkboxes as well as for the
+values passed to your script in the query string.
+
+=item 2.
+
+The optional third argument (-default) can be either a reference to a
+list containing the values to be checked by default, or can be a
+single value to checked. If this argument is missing or undefined,
+then nothing is selected when the list first appears.
+
+=item 3.
+
+The optional fourth argument (-linebreak) can be set to true to place
+line breaks between the checkboxes so that they appear as a vertical
+list. Otherwise, they will be strung together on a horizontal line.
+
+=item 4.
+
+The optional fifth argument is a pointer to an associative array
+relating the checkbox values to the user-visible labels that will
+be printed next to them (-labels). If not provided, the values will
+be used as the default.
+
+=item 5.
+
+B<HTML3-compatible browsers> (such as Netscape) can take advantage of
+the optional parameters B<-rows>, and B<-columns>. These parameters
+cause checkbox_group() to return an HTML3 compatible table containing
+the checkbox group formatted with the specified number of rows and
+columns. You can provide just the -columns parameter if you wish;
+checkbox_group will calculate the correct number of rows for you.
+
+To include row and column headings in the returned table, you
+can use the B<-rowheaders> and B<-colheaders> parameters. Both
+of these accept a pointer to an array of headings to use.
+The headings are just decorative. They don't reorganize the
+interpretation of the checkboxes -- they're still a single named
+unit.
+
+=back
+
+When the form is processed, all checked boxes will be returned as
+a list under the parameter name 'group_name'. The values of the
+"on" checkboxes can be retrieved with:
+
+ @turned_on = $query->param('group_name');
+
+The value returned by checkbox_group() is actually an array of button
+elements. You can capture them and use them within tables, lists,
+or in other creative ways:
+
+ @h = $query->checkbox_group(-name=>'group_name',-values=>\@values);
+ &use_in_creative_way(@h);
+
+JAVASCRIPTING: checkbox_group() recognizes the B<-onClick>
+parameter. This specifies a JavaScript code fragment or
+function call to be executed every time the user clicks on
+any of the buttons in the group. You can retrieve the identity
+of the particular button clicked on using the "this" variable.
+
+=head2 CREATING A STANDALONE CHECKBOX
+
+ print $query->checkbox(-name=>'checkbox_name',
+ -checked=>'checked',
+ -value=>'ON',
+ -label=>'CLICK ME');
+
+ -or-
+
+ print $query->checkbox('checkbox_name','checked','ON','CLICK ME');
+
+checkbox() is used to create an isolated checkbox that isn't logically
+related to any others.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first parameter is the required name for the checkbox (-name). It
+will also be used for the user-readable label printed next to the
+checkbox.
+
+=item 2.
+
+The optional second parameter (-checked) specifies that the checkbox
+is turned on by default. Synonyms are -selected and -on.
+
+=item 3.
+
+The optional third parameter (-value) specifies the value of the
+checkbox when it is checked. If not provided, the word "on" is
+assumed.
+
+=item 4.
+
+The optional fourth parameter (-label) is the user-readable label to
+be attached to the checkbox. If not provided, the checkbox name is
+used.
+
+=back
+
+The value of the checkbox can be retrieved using:
+
+ $turned_on = $query->param('checkbox_name');
+
+JAVASCRIPTING: checkbox() recognizes the B<-onClick>
+parameter. See checkbox_group() for further details.
+
+=head2 CREATING A RADIO BUTTON GROUP
+
+ print $query->radio_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie'],
+ -default=>'meenie',
+ -linebreak=>'true',
+ -labels=>\%labels);
+
+ -or-
+
+ print $query->radio_group('group_name',['eenie','meenie','minie'],
+ 'meenie','true',\%labels);
+
+
+ HTML3-COMPATIBLE BROWSERS ONLY:
+
+ print $query->radio_group(-name=>'group_name',
+ -values=>['eenie','meenie','minie','moe'],
+ -rows=2,-columns=>2);
+
+radio_group() creates a set of logically-related radio buttons
+(turning one member of the group on turns the others off)
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument is the name of the group and is required (-name).
+
+=item 2.
+
+The second argument (-values) is the list of values for the radio
+buttons. The values and the labels that appear on the page are
+identical. Pass an array I<reference> in the second argument, either
+using an anonymous array, as shown, or by referencing a named array as
+in "\@foo".
+
+=item 3.
+
+The optional third parameter (-default) is the name of the default
+button to turn on. If not specified, the first item will be the
+default. You can provide a nonexistent button name, such as "-" to
+start up with no buttons selected.
+
+=item 4.
+
+The optional fourth parameter (-linebreak) can be set to 'true' to put
+line breaks between the buttons, creating a vertical list.
+
+=item 5.
+
+The optional fifth parameter (-labels) is a pointer to an associative
+array relating the radio button values to user-visible labels to be
+used in the display. If not provided, the values themselves are
+displayed.
+
+=item 6.
+
+B<HTML3-compatible browsers> (such as Netscape) can take advantage
+of the optional
+parameters B<-rows>, and B<-columns>. These parameters cause
+radio_group() to return an HTML3 compatible table containing
+the radio group formatted with the specified number of rows
+and columns. You can provide just the -columns parameter if you
+wish; radio_group will calculate the correct number of rows
+for you.
+
+To include row and column headings in the returned table, you
+can use the B<-rowheader> and B<-colheader> parameters. Both
+of these accept a pointer to an array of headings to use.
+The headings are just decorative. They don't reorganize the
+interpetation of the radio buttons -- they're still a single named
+unit.
+
+=back
+
+When the form is processed, the selected radio button can
+be retrieved using:
+
+ $which_radio_button = $query->param('group_name');
+
+The value returned by radio_group() is actually an array of button
+elements. You can capture them and use them within tables, lists,
+or in other creative ways:
+
+ @h = $query->radio_group(-name=>'group_name',-values=>\@values);
+ &use_in_creative_way(@h);
+
+=head2 CREATING A SUBMIT BUTTON
+
+ print $query->submit(-name=>'button_name',
+ -value=>'value');
+
+ -or-
+
+ print $query->submit('button_name','value');
+
+submit() will create the query submission button. Every form
+should have one of these.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument (-name) is optional. You can give the button a
+name if you have several submission buttons in your form and you want
+to distinguish between them. The name will also be used as the
+user-visible label. Be aware that a few older browsers don't deal with this correctly and
+B<never> send back a value from a button.
+
+=item 2.
+
+The second argument (-value) is also optional. This gives the button
+a value that will be passed to your script in the query string.
+
+=back
+
+You can figure out which button was pressed by using different
+values for each one:
+
+ $which_one = $query->param('button_name');
+
+JAVASCRIPTING: radio_group() recognizes the B<-onClick>
+parameter. See checkbox_group() for further details.
+
+=head2 CREATING A RESET BUTTON
+
+ print $query->reset
+
+reset() creates the "reset" button. Note that it restores the
+form to its value from the last time the script was called,
+NOT necessarily to the defaults.
+
+=head2 CREATING A DEFAULT BUTTON
+
+ print $query->defaults('button_label')
+
+defaults() creates a button that, when invoked, will cause the
+form to be completely reset to its defaults, wiping out all the
+changes the user ever made.
+
+=head2 CREATING A HIDDEN FIELD
+
+ print $query->hidden(-name=>'hidden_name',
+ -default=>['value1','value2'...]);
+
+ -or-
+
+ print $query->hidden('hidden_name','value1','value2'...);
+
+hidden() produces a text field that can't be seen by the user. It
+is useful for passing state variable information from one invocation
+of the script to the next.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument is required and specifies the name of this
+field (-name).
+
+=item 2.
+
+The second argument is also required and specifies its value
+(-default). In the named parameter style of calling, you can provide
+a single value here or a reference to a whole list
+
+=back
+
+Fetch the value of a hidden field this way:
+
+ $hidden_value = $query->param('hidden_name');
+
+Note, that just like all the other form elements, the value of a
+hidden field is "sticky". If you want to replace a hidden field with
+some other values after the script has been called once you'll have to
+do it manually:
+
+ $query->param('hidden_name','new','values','here');
+
+=head2 CREATING A CLICKABLE IMAGE BUTTON
+
+ print $query->image_button(-name=>'button_name',
+ -src=>'/source/URL',
+ -align=>'MIDDLE');
+
+ -or-
+
+ print $query->image_button('button_name','/source/URL','MIDDLE');
+
+image_button() produces a clickable image. When it's clicked on the
+position of the click is returned to your script as "button_name.x"
+and "button_name.y", where "button_name" is the name you've assigned
+to it.
+
+JAVASCRIPTING: image_button() recognizes the B<-onClick>
+parameter. See checkbox_group() for further details.
+
+=over 4
+
+=item B<Parameters:>
+
+=item 1.
+
+The first argument (-name) is required and specifies the name of this
+field.
+
+=item 2.
+
+The second argument (-src) is also required and specifies the URL
+
+=item 3.
+The third option (-align, optional) is an alignment type, and may be
+TOP, BOTTOM or MIDDLE
+
+=back
+
+Fetch the value of the button this way:
+ $x = $query->param('button_name.x');
+ $y = $query->param('button_name.y');
+
+=head2 CREATING A JAVASCRIPT ACTION BUTTON
+
+ print $query->button(-name=>'button_name',
+ -value=>'user visible label',
+ -onClick=>"do_something()");
+
+ -or-
+
+ print $query->button('button_name',"do_something()");
+
+button() produces a button that is compatible with Netscape 2.0's
+JavaScript. When it's pressed the fragment of JavaScript code
+pointed to by the B<-onClick> parameter will be executed. On
+non-Netscape browsers this form element will probably not even
+display.
+
+=head1 NETSCAPE COOKIES
+
+Netscape browsers versions 1.1 and higher support a so-called
+"cookie" designed to help maintain state within a browser session.
+CGI.pm has several methods that support cookies.
+
+A cookie is a name=value pair much like the named parameters in a CGI
+query string. CGI scripts create one or more cookies and send
+them to the browser in the HTTP header. The browser maintains a list
+of cookies that belong to a particular Web server, and returns them
+to the CGI script during subsequent interactions.
+
+In addition to the required name=value pair, each cookie has several
+optional attributes:
+
+=over 4
+
+=item 1. an expiration time
+
+This is a time/date string (in a special GMT format) that indicates
+when a cookie expires. The cookie will be saved and returned to your
+script until this expiration date is reached if the user exits
+Netscape and restarts it. If an expiration date isn't specified, the cookie
+will remain active until the user quits Netscape.
+
+=item 2. a domain
+
+This is a partial or complete domain name for which the cookie is
+valid. The browser will return the cookie to any host that matches
+the partial domain name. For example, if you specify a domain name
+of ".capricorn.com", then Netscape will return the cookie to
+Web servers running on any of the machines "www.capricorn.com",
+"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
+must contain at least two periods to prevent attempts to match
+on top level domains like ".edu". If no domain is specified, then
+the browser will only return the cookie to servers on the host the
+cookie originated from.
+
+=item 3. a path
+
+If you provide a cookie path attribute, the browser will check it
+against your script's URL before returning the cookie. For example,
+if you specify the path "/cgi-bin", then the cookie will be returned
+to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
+and "/cgi-bin/customer_service/complain.pl", but not to the script
+"/cgi-private/site_admin.pl". By default, path is set to "/", which
+causes the cookie to be sent to any CGI script on your site.
+
+=item 4. a "secure" flag
+
+If the "secure" attribute is set, the cookie will only be sent to your
+script if the CGI request is occurring on a secure channel, such as SSL.
+
+=back
+
+The interface to Netscape cookies is the B<cookie()> method:
+
+ $cookie = $query->cookie(-name=>'sessionID',
+ -value=>'xyzzy',
+ -expires=>'+1h',
+ -path=>'/cgi-bin/database',
+ -domain=>'.capricorn.org',
+ -secure=>1);
+ print $query->header(-cookie=>$cookie);
+
+B<cookie()> creates a new cookie. Its parameters include:
+
+=over 4
+
+=item B<-name>
+
+The name of the cookie (required). This can be any string at all.
+Although Netscape limits its cookie names to non-whitespace
+alphanumeric characters, CGI.pm removes this restriction by escaping
+and unescaping cookies behind the scenes.
+
+=item B<-value>
+
+The value of the cookie. This can be any scalar value,
+array reference, or even associative array reference. For example,
+you can store an entire associative array into a cookie this way:
+
+ $cookie=$query->cookie(-name=>'family information',
+ -value=>\%childrens_ages);
+
+=item B<-path>
+
+The optional partial path for which this cookie will be valid, as described
+above.
+
+=item B<-domain>
+
+The optional partial domain for which this cookie will be valid, as described
+above.
+
+=item B<-expires>
+
+The optional expiration date for this cookie. The format is as described
+in the section on the B<header()> method:
+
+ "+1h" one hour from now
+
+=item B<-secure>
+
+If set to true, this cookie will only be used within a secure
+SSL session.
+
+=back
+
+The cookie created by cookie() must be incorporated into the HTTP
+header within the string returned by the header() method:
+
+ print $query->header(-cookie=>$my_cookie);
+
+To create multiple cookies, give header() an array reference:
+
+ $cookie1 = $query->cookie(-name=>'riddle_name',
+ -value=>"The Sphynx's Question");
+ $cookie2 = $query->cookie(-name=>'answers',
+ -value=>\%answers);
+ print $query->header(-cookie=>[$cookie1,$cookie2]);
+
+To retrieve a cookie, request it by name by calling cookie()
+method without the B<-value> parameter:
+
+ use CGI;
+ $query = new CGI;
+ %answers = $query->cookie(-name=>'answers');
+ # $query->cookie('answers') will work too!
+
+The cookie and CGI namespaces are separate. If you have a parameter
+named 'answers' and a cookie named 'answers', the values retrieved by
+param() and cookie() are independent of each other. However, it's
+simple to turn a CGI parameter into a cookie, and vice-versa:
+
+ # turn a CGI parameter into a cookie
+ $c=$q->cookie(-name=>'answers',-value=>[$q->param('answers')]);
+ # vice-versa
+ $q->param(-name=>'answers',-value=>[$q->cookie('answers')]);
+
+See the B<cookie.cgi> example script for some ideas on how to use
+cookies effectively.
+
+B<NOTE:> There appear to be some (undocumented) restrictions on
+Netscape cookies. In Netscape 2.01, at least, I haven't been able to
+set more than three cookies at a time. There may also be limits on
+the length of cookies. If you need to store a lot of information,
+it's probably better to create a unique session ID, store it in a
+cookie, and use the session ID to locate an external file/database
+saved on the server's side of the connection.
+
+=head1 WORKING WITH NETSCAPE FRAMES
+
+It's possible for CGI.pm scripts to write into several browser
+panels and windows using Netscape's frame mechanism.
+There are three techniques for defining new frames programmatically:
+
+=over 4
+
+=item 1. Create a <Frameset> document
+
+After writing out the HTTP header, instead of creating a standard
+HTML document using the start_html() call, create a <FRAMESET>
+document that defines the frames on the page. Specify your script(s)
+(with appropriate parameters) as the SRC for each of the frames.
+
+There is no specific support for creating <FRAMESET> sections
+in CGI.pm, but the HTML is very simple to write. See the frame
+documentation in Netscape's home pages for details
+
+ http://home.netscape.com/assist/net_sites/frames.html
+
+=item 2. Specify the destination for the document in the HTTP header
+
+You may provide a B<-target> parameter to the header() method:
+
+ print $q->header(-target=>'ResultsWindow');
+
+This will tell Netscape to load the output of your script into the
+frame named "ResultsWindow". If a frame of that name doesn't
+already exist, Netscape will pop up a new window and load your
+script's document into that. There are a number of magic names
+that you can use for targets. See the frame documents on Netscape's
+home pages for details.
+
+=item 3. Specify the destination for the document in the <FORM> tag
+
+You can specify the frame to load in the FORM tag itself. With
+CGI.pm it looks like this:
+
+ print $q->startform(-target=>'ResultsWindow');
+
+When your script is reinvoked by the form, its output will be loaded
+into the frame named "ResultsWindow". If one doesn't already exist
+a new window will be created.
+
+=back
+
+The script "frameset.cgi" in the examples directory shows one way to
+create pages in which the fill-out form and the response live in
+side-by-side frames.
+
+=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
+
+CGI.pm has limited support for HTML3's cascading style sheets (css).
+To incorporate a stylesheet into your document, pass the
+start_html() method a B<-style> parameter. The value of this
+parameter may be a scalar, in which case it is incorporated directly
+into a <STYLE> section, or it may be a hash reference. In the latter
+case you should provide the hash with one or more of B<-src> or
+B<-code>. B<-src> points to a URL where an externally-defined
+stylesheet can be found. B<-code> points to a scalar value to be
+incorporated into a <STYLE> section. Style definitions in B<-code>
+override similarly-named ones in B<-src>, hence the name "cascading."
+
+You may also specify the type of the stylesheet by adding the optional
+B<-type> parameter to the hash pointed to by B<-style>. If not
+specified, the style defaults to 'text/css'.
+
+To refer to a style within the body of your document, add the
+B<-class> parameter to any HTML element:
+
+ print h1({-class=>'Fancy'},'Welcome to the Party');
+
+Or define styles on the fly with the B<-style> parameter:
+
+ print h1({-style=>'Color: red;'},'Welcome to Hell');
+
+You may also use the new B<span()> element to apply a style to a
+section of text:
+
+ print span({-style=>'Color: red;'},
+ h1('Welcome to Hell'),
+ "Where did that handbasket get to?"
+ );
+
+Note that you must import the ":html3" definitions to have the
+B<span()> method available. Here's a quick and dirty example of using
+CSS's. See the CSS specification at
+http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
+
+ use CGI qw/:standard :html3/;
+
+ #here's a stylesheet incorporated directly into the page
+ $newStyle=<<END;
+ <!--
+ P.Tip {
+ margin-right: 50pt;
+ margin-left: 50pt;
+ color: red;
+ }
+ P.Alert {
+ font-size: 30pt;
+ font-family: sans-serif;
+ color: red;
+ }
+ -->
+ END
+ print header();
+ print start_html( -title=>'CGI with Style',
+ -style=>{-src=>'http://www.capricorn.com/style/st1.css',
+ -code=>$newStyle}
+ );
+ print h1('CGI with Style'),
+ p({-class=>'Tip'},
+ "Better read the cascading style sheet spec before playing with this!"),
+ span({-style=>'color: magenta'},
+ "Look Mom, no hands!",
+ p(),
+ "Whooo wee!"
+ );
+ print end_html;
+
+=head1 DEBUGGING
+
+If you are running the script
+from the command line or in the perl debugger, you can pass the script
+a list of keywords or parameter=value pairs on the command line or
+from standard input (you don't have to worry about tricking your
+script into reading from environment variables).
+You can pass keywords like this:
+
+ your_script.pl keyword1 keyword2 keyword3
+
+or this:
+
+ your_script.pl keyword1+keyword2+keyword3
+
+or this:
+
+ your_script.pl name1=value1 name2=value2
+
+or this:
+
+ your_script.pl name1=value1&name2=value2
+
+or even as newline-delimited parameters on standard input.
+
+When debugging, you can use quotes and backslashes to escape
+characters in the familiar shell manner, letting you place
+spaces and other funny characters in your parameter=value
+pairs:
+
+ your_script.pl "name1='I am a long value'" "name2=two\ words"
+
+=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
+
+The dump() method produces a string consisting of all the query's
+name/value pairs formatted nicely as a nested list. This is useful
+for debugging purposes:
+
+ print $query->dump
+
+
+Produces something that looks like:
+
+ <UL>
+ <LI>name1
+ <UL>
+ <LI>value1
+ <LI>value2
+ </UL>
+ <LI>name2
+ <UL>
+ <LI>value1
+ </UL>
+ </UL>
+
+You can pass a value of 'true' to dump() in order to get it to
+print the results out as plain text, suitable for incorporating
+into a <PRE> section.
+
+As a shortcut, as of version 1.56 you can interpolate the entire CGI
+object into a string and it will be replaced with the a nice HTML dump
+shown above:
+
+ $query=new CGI;
+ print "<H2>Current Values</H2> $query\n";
+
+=head1 FETCHING ENVIRONMENT VARIABLES
+
+Some of the more useful environment variables can be fetched
+through this interface. The methods are as follows:
+
+=over 4
+
+=item B<accept()>
+
+Return a list of MIME types that the remote browser
+accepts. If you give this method a single argument
+corresponding to a MIME type, as in
+$query->accept('text/html'), it will return a
+floating point value corresponding to the browser's
+preference for this type from 0.0 (don't want) to 1.0.
+Glob types (e.g. text/*) in the browser's accept list
+are handled correctly.
+
+=item B<raw_cookie()>
+
+Returns the HTTP_COOKIE variable, an HTTP extension implemented by
+Netscape browsers version 1.1 and higher. Cookies have a special
+format, and this method call just returns the raw form (?cookie
+dough). See cookie() for ways of setting and retrieving cooked
+cookies.
+
+Called with no parameters, raw_cookie() returns the packed cookie
+structure. You can separate it into individual cookies by splitting
+on the character sequence "; ". Called with the name of a cookie,
+retrieves the B<unescaped> form of the cookie. You can use the
+regular cookie() method to get the names, or use the raw_fetch()
+method from the CGI::Cookie module.
+
+=item B<user_agent()>
+
+Returns the HTTP_USER_AGENT variable. If you give
+this method a single argument, it will attempt to
+pattern match on it, allowing you to do something
+like $query->user_agent(netscape);
+
+=item B<path_info()>
+
+Returns additional path information from the script URL.
+E.G. fetching /cgi-bin/your_script/additional/stuff will
+result in $query->path_info() returning
+"additional/stuff".
+
+NOTE: The Microsoft Internet Information Server
+is broken with respect to additional path information. If
+you use the Perl DLL library, the IIS server will attempt to
+execute the additional path information as a Perl script.
+If you use the ordinary file associations mapping, the
+path information will be present in the environment,
+but incorrect. The best thing to do is to avoid using additional
+path information in CGI scripts destined for use with IIS.
+
+=item B<path_translated()>
+
+As per path_info() but returns the additional
+path information translated into a physical path, e.g.
+"/usr/local/etc/httpd/htdocs/additional/stuff".
+
+The Microsoft IIS is broken with respect to the translated
+path as well.
+
+=item B<remote_host()>
+
+Returns either the remote host name or IP address.
+if the former is unavailable.
+
+=item B<script_name()>
+Return the script name as a partial URL, for self-refering
+scripts.
+
+=item B<referer()>
+
+Return the URL of the page the browser was viewing
+prior to fetching your script. Not available for all
+browsers.
+
+=item B<auth_type ()>
+
+Return the authorization/verification method in use for this
+script, if any.
+
+=item B<server_name ()>
+
+Returns the name of the server, usually the machine's host
+name.
+
+=item B<virtual_host ()>
+
+When using virtual hosts, returns the name of the host that
+the browser attempted to contact
+
+=item B<server_software ()>
+
+Returns the server software and version number.
+
+=item B<remote_user ()>
+
+Return the authorization/verification name used for user
+verification, if this script is protected.
+
+=item B<user_name ()>
+
+Attempt to obtain the remote user's name, using a variety
+of different techniques. This only works with older browsers
+such as Mosaic. Netscape does not reliably report the user
+name!
+
+=item B<request_method()>
+
+Returns the method used to access your script, usually
+one of 'POST', 'GET' or 'HEAD'.
+
+=back
+
+=head1 USING NPH SCRIPTS
+
+NPH, or "no-parsed-header", scripts bypass the server completely by
+sending the complete HTTP header directly to the browser. This has
+slight performance benefits, but is of most use for taking advantage
+of HTTP extensions that are not directly supported by your server,
+such as server push and PICS headers.
+
+Servers use a variety of conventions for designating CGI scripts as
+NPH. Many Unix servers look at the beginning of the script's name for
+the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
+Internet Information Server, in contrast, try to decide whether a
+program is an NPH script by examining the first line of script output.
+
+
+CGI.pm supports NPH scripts with a special NPH mode. When in this
+mode, CGI.pm will output the necessary extra header information when
+the header() and redirect() methods are
+called.
+
+The Microsoft Internet Information Server requires NPH mode. As of version
+2.30, CGI.pm will automatically detect when the script is running under IIS
+and put itself into this mode. You do not need to do this manually, although
+it won't hurt anything if you do.
+
+There are a number of ways to put CGI.pm into NPH mode:
+
+=over 4
+
+=item In the B<use> statement
+
+Simply add the "-nph" pragmato the list of symbols to be imported into
+your script:
+
+ use CGI qw(:standard -nph)
+
+=item By calling the B<nph()> method:
+
+Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
+
+ CGI->nph(1)
+
+=item By using B<-nph> parameters in the B<header()> and B<redirect()> statements:
+
+ print $q->header(-nph=>1);
+
+=back
+
+=head1 Server Push
+
+CGI.pm provides three simple functions for producing multipart
+documents of the type needed to implement server push. These
+functions were graciously provided by Ed Jordan <ed@fidalgo.net>. To
+import these into your namespace, you must import the ":push" set.
+You are also advised to put the script into NPH mode and to set $| to
+1 to avoid buffering problems.
+
+Here is a simple script that demonstrates server push:
+
+ #!/usr/local/bin/perl
+ use CGI qw/:push -nph/;
+ $| = 1;
+ print multipart_init(-boundary=>'----------------here we go!');
+ while (1) {
+ print multipart_start(-type=>'text/plain'),
+ "The current time is ",scalar(localtime),"\n",
+ multipart_end;
+ sleep 1;
+ }
+
+This script initializes server push by calling B<multipart_init()>.
+It then enters an infinite loop in which it begins a new multipart
+section by calling B<multipart_start()>, prints the current local time,
+and ends a multipart section with B<multipart_end()>. It then sleeps
+a second, and begins again.
+
+=over 4
+
+=item multipart_init()
+
+ multipart_init(-boundary=>$boundary);
+
+Initialize the multipart system. The -boundary argument specifies
+what MIME boundary string to use to separate parts of the document.
+If not provided, CGI.pm chooses a reasonable boundary for you.
+
+=item multipart_start()
+
+ multipart_start(-type=>$type)
+
+Start a new part of the multipart document using the specified MIME
+type. If not specified, text/html is assumed.
+
+=item multipart_end()
+
+ multipart_end()
+
+End a part. You must remember to call multipart_end() once for each
+multipart_start().
+
+=back
+
+Users interested in server push applications should also have a look
+at the CGI::Push module.
+
+=head1 Avoiding Denial of Service Attacks
+
+A potential problem with CGI.pm is that, by default, it attempts to
+process form POSTings no matter how large they are. A wily hacker
+could attack your site by sending a CGI script a huge POST of many
+megabytes. CGI.pm will attempt to read the entire POST into a
+variable, growing hugely in size until it runs out of memory. While
+the script attempts to allocate the memory the system may slow down
+dramatically. This is a form of denial of service attack.
+
+Another possible attack is for the remote user to force CGI.pm to
+accept a huge file upload. CGI.pm will accept the upload and store it
+in a temporary directory even if your script doesn't expect to receive
+an uploaded file. CGI.pm will delete the file automatically when it
+terminates, but in the meantime the remote user may have filled up the
+server's disk space, causing problems for other programs.
+
+The best way to avoid denial of service attacks is to limit the amount
+of memory, CPU time and disk space that CGI scripts can use. Some Web
+servers come with built-in facilities to accomplish this. In other
+cases, you can use the shell I<limit> or I<ulimit>
+commands to put ceilings on CGI resource usage.
+
+
+CGI.pm also has some simple built-in protections against denial of
+service attacks, but you must activate them before you can use them.
+These take the form of two global variables in the CGI name space:
+
+=over 4
+
+=item B<$CGI::POST_MAX>
+
+If set to a non-negative integer, this variable puts a ceiling
+on the size of POSTings, in bytes. If CGI.pm detects a POST
+that is greater than the ceiling, it will immediately exit with an error
+message. This value will affect both ordinary POSTs and
+multipart POSTs, meaning that it limits the maximum size of file
+uploads as well. You should set this to a reasonably high
+value, such as 1 megabyte.
+
+=item B<$CGI::DISABLE_UPLOADS>
+
+If set to a non-zero value, this will disable file uploads
+completely. Other fill-out form values will work as usual.
+
+=back
+
+You can use these variables in either of two ways.
+
+=over 4
+
+=item B<1. On a script-by-script basis>
+
+Set the variable at the top of the script, right after the "use" statement:
+
+ use CGI qw/:standard/;
+ use CGI::Carp 'fatalsToBrowser';
+ $CGI::POST_MAX=1024 * 100; # max 100K posts
+ $CGI::DISABLE_UPLOADS = 1; # no uploads
+
+=item B<2. Globally for all scripts>
+
+Open up CGI.pm, find the definitions for $POST_MAX and
+$DISABLE_UPLOADS, and set them to the desired values. You'll
+find them towards the top of the file in a subroutine named
+initialize_globals().
+
+=back
+
+Since an attempt to send a POST larger than $POST_MAX bytes
+will cause a fatal error, you might want to use CGI::Carp to echo the
+fatal error message to the browser window as shown in the example
+above. Otherwise the remote user will see only a generic "Internal
+Server" error message. See the L<CGI::Carp> manual page for more
+details.
+
+=head1 COMPATIBILITY WITH CGI-LIB.PL
+
+To make it easier to port existing programs that use cgi-lib.pl
+the compatibility routine "ReadParse" is provided. Porting is
+simple:
+
+OLD VERSION
+ require "cgi-lib.pl";
+ &ReadParse;
+ print "The value of the antique is $in{antique}.\n";
+
+NEW VERSION
+ use CGI;
+ CGI::ReadParse
+ print "The value of the antique is $in{antique}.\n";
+
+CGI.pm's ReadParse() routine creates a tied variable named %in,
+which can be accessed to obtain the query variables. Like
+ReadParse, you can also provide your own variable. Infrequently
+used features of ReadParse, such as the creation of @in and $in
+variables, are not supported.
+
+Once you use ReadParse, you can retrieve the query object itself
+this way:
+
+ $q = $in{CGI};
+ print $q->textfield(-name=>'wow',
+ -value=>'does this really work?');
+
+This allows you to start using the more interesting features
+of CGI.pm without rewriting your old scripts from scratch.
+
+=head1 AUTHOR INFORMATION
+
+Copyright 1995-1997, Lincoln D. Stein. All rights reserved. It may
+be used and modified freely, but I do request that this copyright
+notice remain attached to the file. You may modify this module as you
+wish, but if you redistribute a modified version, please attach a note
+listing the modifications you have made.
+
+Address bug reports and comments to:
+lstein@genome.wi.mit.edu
+
+=head1 CREDITS
+
+Thanks very much to:
+
+=over 4
+
+=item Matt Heffron (heffron@falstaff.css.beckman.com)
+
+=item James Taylor (james.taylor@srs.gov)
+
+=item Scott Anguish <sanguish@digifix.com>
+
+=item Mike Jewell (mlj3u@virginia.edu)
+
+=item Timothy Shimmin (tes@kbs.citri.edu.au)
+
+=item Joergen Haegg (jh@axis.se)
+
+=item Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu)
+
+=item Richard Resnick (applepi1@aol.com)
+
+=item Craig Bishop (csb@barwonwater.vic.gov.au)
+
+=item Tony Curtis (tc@vcpc.univie.ac.at)
+
+=item Tim Bunce (Tim.Bunce@ig.co.uk)
+
+=item Tom Christiansen (tchrist@convex.com)
+
+=item Andreas Koenig (k@franz.ww.TU-Berlin.DE)
+
+=item Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au)
+
+=item Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu)
+
+=item Stephen Dahmen (joyfire@inxpress.net)
+
+=item Ed Jordan (ed@fidalgo.net)
+
+=item David Alan Pisoni (david@cnation.com)
+
+=item Doug MacEachern (dougm@opengroup.org)
+
+=item Robin Houston (robin@oneworld.org)
+
+=item ...and many many more...
+
+for suggestions and bug fixes.
+
+=back
+
+=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
+
+
+ #!/usr/local/bin/perl
+
+ use CGI;
+
+ $query = new CGI;
+
+ print $query->header;
+ print $query->start_html("Example CGI.pm Form");
+ print "<H1> Example CGI.pm Form</H1>\n";
+ &print_prompt($query);
+ &do_work($query);
+ &print_tail;
+ print $query->end_html;
+
+ sub print_prompt {
+ my($query) = @_;
+
+ print $query->startform;
+ print "<EM>What's your name?</EM><BR>";
+ print $query->textfield('name');
+ print $query->checkbox('Not my real name');
+
+ print "<P><EM>Where can you find English Sparrows?</EM><BR>";
+ print $query->checkbox_group(
+ -name=>'Sparrow locations',
+ -values=>[England,France,Spain,Asia,Hoboken],
+ -linebreak=>'yes',
+ -defaults=>[England,Asia]);
+
+ print "<P><EM>How far can they fly?</EM><BR>",
+ $query->radio_group(
+ -name=>'how far',
+ -values=>['10 ft','1 mile','10 miles','real far'],
+ -default=>'1 mile');
+
+ print "<P><EM>What's your favorite color?</EM> ";
+ print $query->popup_menu(-name=>'Color',
+ -values=>['black','brown','red','yellow'],
+ -default=>'red');
+
+ print $query->hidden('Reference','Monty Python and the Holy Grail');
+
+ print "<P><EM>What have you got there?</EM><BR>";
+ print $query->scrolling_list(
+ -name=>'possessions',
+ -values=>['A Coconut','A Grail','An Icon',
+ 'A Sword','A Ticket'],
+ -size=>5,
+ -multiple=>'true');
+
+ print "<P><EM>Any parting comments?</EM><BR>";
+ print $query->textarea(-name=>'Comments',
+ -rows=>10,
+ -columns=>50);
+
+ print "<P>",$query->reset;
+ print $query->submit('Action','Shout');
+ print $query->submit('Action','Scream');
+ print $query->endform;
+ print "<HR>\n";
+ }
+
+ sub do_work {
+ my($query) = @_;
+ my(@values,$key);
+
+ print "<H2>Here are the current settings in this form</H2>";
+
+ foreach $key ($query->param) {
+ print "<STRONG>$key</STRONG> -> ";
+ @values = $query->param($key);
+ print join(", ",@values),"<BR>\n";
+ }
+ }
+
+ sub print_tail {
+ print <<END;
+ <HR>
+ <ADDRESS>Lincoln D. Stein</ADDRESS><BR>
+ <A HREF="/">Home Page</A>
+ END
+ }
+
+=head1 BUGS
+
+This module has grown large and monolithic. Furthermore it's doing many
+things, such as handling URLs, parsing CGI input, writing HTML, etc., that
+are also done in the LWP modules. It should be discarded in favor of
+the CGI::* modules, but somehow I continue to work on it.
+
+Note that the code is truly contorted in order to avoid spurious
+warnings when programs are run with the B<-w> switch.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<URI::URL>, L<CGI::Request>, L<CGI::MiniSvr>,
+L<CGI::Base>, L<CGI::Form>, L<CGI::Apache>, L<CGI::Switch>,
+L<CGI::Push>, L<CGI::Fast>
+
+=cut
+
diff --git a/contrib/perl5/lib/CGI/Apache.pm b/contrib/perl5/lib/CGI/Apache.pm
new file mode 100644
index 000000000000..eed3e55c51c8
--- /dev/null
+++ b/contrib/perl5/lib/CGI/Apache.pm
@@ -0,0 +1,103 @@
+package CGI::Apache;
+use Apache ();
+use vars qw(@ISA $VERSION);
+require CGI;
+@ISA = qw(CGI);
+
+$VERSION = (qw$Revision: 1.1 $)[1];
+$CGI::DefaultClass = 'CGI::Apache';
+$CGI::Apache::AutoloadClass = 'CGI';
+
+sub import {
+ my $self = shift;
+ my ($callpack, $callfile, $callline) = caller;
+ ${"${callpack}::AutoloadClass"} = 'CGI';
+}
+
+sub new {
+ my($class) = shift;
+ my($r) = Apache->request;
+ %ENV = $r->cgi_env unless defined $ENV{GATEWAY_INTERFACE}; #PerlSetupEnv On
+ my $self = $class->SUPER::new(@_);
+ $self->{'.req'} = $r;
+ $self;
+}
+
+sub header {
+ my ($self,@rest) = CGI::self_or_default(@_);
+ my $r = $self->{'.req'};
+ $r->basic_http_header;
+ return CGI::header($self,@rest);
+}
+
+sub print {
+ my($self,@rest) = CGI::self_or_default(@_);
+ $self->{'.req'}->print(@rest);
+}
+
+sub read_from_client {
+ my($self, $fh, $buff, $len, $offset) = @_;
+ my $r = $self->{'.req'} || Apache->request;
+ return $r->read($$buff, $len, $offset);
+}
+
+sub new_MultipartBuffer {
+ my $self = shift;
+ my $new = CGI::Apache::MultipartBuffer->new($self, @_);
+ $new->{'.req'} = $self->{'.req'} || Apache->request;
+ return $new;
+}
+
+package CGI::Apache::MultipartBuffer;
+use vars qw(@ISA);
+@ISA = qw(MultipartBuffer);
+
+$CGI::Apache::MultipartBuffer::AutoloadClass = 'MultipartBuffer';
+*CGI::Apache::MultipartBuffer::read_from_client =
+ \&CGI::Apache::read_from_client;
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+CGI::Apache - Make things work with CGI.pm against Perl-Apache API
+
+=head1 SYNOPSIS
+
+ require CGI::Apache;
+
+ my $q = new Apache::CGI;
+
+ $q->print($q->header);
+
+ #do things just like you do with CGI.pm
+
+=head1 DESCRIPTION
+
+When using the Perl-Apache API, your applications are faster, but the
+enviroment is different than CGI.
+This module attempts to set-up that environment as best it can.
+
+=head1 NOTE 1
+
+This module used to be named Apache::CGI. Sorry for the confusion.
+
+=head1 NOTE 2
+
+If you're going to inherit from this class, make sure to "use" it
+after your package declaration rather than "require" it. This is
+because CGI.pm does a little magic during the import() step in order
+to make autoloading work correctly.
+
+=head1 SEE ALSO
+
+perl(1), Apache(3), CGI(3)
+
+=head1 AUTHOR
+
+Doug MacEachern E<lt>dougm@osf.orgE<gt>, hacked over by Andreas KE<ouml>nig E<lt>a.koenig@mind.deE<gt>, modified by Lincoln Stein <lt>lstein@genome.wi.mit.edu<gt>
+
+=cut
diff --git a/contrib/perl5/lib/CGI/Carp.pm b/contrib/perl5/lib/CGI/Carp.pm
new file mode 100644
index 000000000000..e20f7542b8af
--- /dev/null
+++ b/contrib/perl5/lib/CGI/Carp.pm
@@ -0,0 +1,331 @@
+package CGI::Carp;
+
+=head1 NAME
+
+B<CGI::Carp> - CGI routines for writing to the HTTPD (or other) error log
+
+=head1 SYNOPSIS
+
+ use CGI::Carp;
+
+ croak "We're outta here!";
+ confess "It was my fault: $!";
+ carp "It was your fault!";
+ warn "I'm confused";
+ die "I'm dying.\n";
+
+=head1 DESCRIPTION
+
+CGI scripts have a nasty habit of leaving warning messages in the error
+logs that are neither time stamped nor fully identified. Tracking down
+the script that caused the error is a pain. This fixes that. Replace
+the usual
+
+ use Carp;
+
+with
+
+ use CGI::Carp
+
+And the standard warn(), die (), croak(), confess() and carp() calls
+will automagically be replaced with functions that write out nicely
+time-stamped messages to the HTTP server error log.
+
+For example:
+
+ [Fri Nov 17 21:40:43 1995] test.pl: I'm confused at test.pl line 3.
+ [Fri Nov 17 21:40:43 1995] test.pl: Got an error message: Permission denied.
+ [Fri Nov 17 21:40:43 1995] test.pl: I'm dying.
+
+=head1 REDIRECTING ERROR MESSAGES
+
+By default, error messages are sent to STDERR. Most HTTPD servers
+direct STDERR to the server's error log. Some applications may wish
+to keep private error logs, distinct from the server's error log, or
+they may wish to direct error messages to STDOUT so that the browser
+will receive them.
+
+The C<carpout()> function is provided for this purpose. Since
+carpout() is not exported by default, you must import it explicitly by
+saying
+
+ use CGI::Carp qw(carpout);
+
+The carpout() function requires one argument, which should be a
+reference to an open filehandle for writing errors. It should be
+called in a C<BEGIN> block at the top of the CGI application so that
+compiler errors will be caught. Example:
+
+ BEGIN {
+ use CGI::Carp qw(carpout);
+ open(LOG, ">>/usr/local/cgi-logs/mycgi-log") or
+ die("Unable to open mycgi-log: $!\n");
+ carpout(LOG);
+ }
+
+carpout() does not handle file locking on the log for you at this point.
+
+The real STDERR is not closed -- it is moved to SAVEERR. Some
+servers, when dealing with CGI scripts, close their connection to the
+browser when the script closes STDOUT and STDERR. SAVEERR is used to
+prevent this from happening prematurely.
+
+You can pass filehandles to carpout() in a variety of ways. The "correct"
+way according to Tom Christiansen is to pass a reference to a filehandle
+GLOB:
+
+ carpout(\*LOG);
+
+This looks weird to mere mortals however, so the following syntaxes are
+accepted as well:
+
+ carpout(LOG);
+ carpout(main::LOG);
+ carpout(main'LOG);
+ carpout(\LOG);
+ carpout(\'main::LOG');
+
+ ... and so on
+
+FileHandle and other objects work as well.
+
+Use of carpout() is not great for performance, so it is recommended
+for debugging purposes or for moderate-use applications. A future
+version of this module may delay redirecting STDERR until one of the
+CGI::Carp methods is called to prevent the performance hit.
+
+=head1 MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
+
+If you want to send fatal (die, confess) errors to the browser, ask to
+import the special "fatalsToBrowser" subroutine:
+
+ use CGI::Carp qw(fatalsToBrowser);
+ die "Bad error here";
+
+Fatal errors will now be echoed to the browser as well as to the log. CGI::Carp
+arranges to send a minimal HTTP header to the browser so that even errors that
+occur in the early compile phase will be seen.
+Nonfatal errors will still be directed to the log file only (unless redirected
+with carpout).
+
+=head2 Changing the default message
+
+By default, the software error message is followed by a note to
+contact the Webmaster by e-mail with the time and date of the error.
+If this message is not to your liking, you can change it using the
+set_message() routine. This is not imported by default; you should
+import it on the use() line:
+
+ use CGI::Carp qw(fatalsToBrowser set_message);
+ set_message("It's not a bug, it's a feature!");
+
+You may also pass in a code reference in order to create a custom
+error message. At run time, your code will be called with the text
+of the error message that caused the script to die. Example:
+
+ use CGI::Carp qw(fatalsToBrowser set_message);
+ BEGIN {
+ sub handle_errors {
+ my $msg = shift;
+ print "<h1>Oh gosh</h1>";
+ print "Got an error: $msg";
+ }
+ set_message(\&handle_errors);
+ }
+
+In order to correctly intercept compile-time errors, you should call
+set_message() from within a BEGIN{} block.
+
+=head1 CHANGE LOG
+
+1.05 carpout() added and minor corrections by Marc Hedlund
+ <hedlund@best.com> on 11/26/95.
+
+1.06 fatalsToBrowser() no longer aborts for fatal errors within
+ eval() statements.
+
+1.08 set_message() added and carpout() expanded to allow for FileHandle
+ objects.
+
+1.09 set_message() now allows users to pass a code REFERENCE for
+ really custom error messages. croak and carp are now
+ exported by default. Thanks to Gunther Birznieks for the
+ patches.
+
+1.10 Patch from Chris Dean (ctdean@cogit.com) to allow
+ module to run correctly under mod_perl.
+
+=head1 AUTHORS
+
+Lincoln D. Stein <lstein@genome.wi.mit.edu>. Feel free to redistribute
+this under the Perl Artistic License.
+
+
+=head1 SEE ALSO
+
+Carp, CGI::Base, CGI::BasePlus, CGI::Request, CGI::MiniSvr, CGI::Form,
+CGI::Response
+
+=cut
+
+require 5.000;
+use Exporter;
+use Carp;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(confess croak carp);
+@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message);
+
+$main::SIG{__WARN__}=\&CGI::Carp::warn;
+$main::SIG{__DIE__}=\&CGI::Carp::die;
+$CGI::Carp::VERSION = '1.101';
+$CGI::Carp::CUSTOM_MSG = undef;
+
+# fancy import routine detects and handles 'errorWrap' specially.
+sub import {
+ my $pkg = shift;
+ my(%routines);
+ grep($routines{$_}++,@_,@EXPORT);
+ $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
+ my($oldlevel) = $Exporter::ExportLevel;
+ $Exporter::ExportLevel = 1;
+ Exporter::import($pkg,keys %routines);
+ $Exporter::ExportLevel = $oldlevel;
+}
+
+# These are the originals
+# XXX Why not just use CORE::die etc., instead of these two? GSAR
+sub realwarn { CORE::warn(@_); }
+sub realdie { CORE::die(@_); }
+
+sub id {
+ my $level = shift;
+ my($pack,$file,$line,$sub) = caller($level);
+ my($id) = $file=~m|([^/]+)$|;
+ return ($file,$line,$id);
+}
+
+sub stamp {
+ my $time = scalar(localtime);
+ my $frame = 0;
+ my ($id,$pack,$file);
+ do {
+ $id = $file;
+ ($pack,$file) = caller($frame++);
+ } until !$file;
+ ($id) = $id=~m|([^/]+)$|;
+ return "[$time] $id: ";
+}
+
+sub warn {
+ my $message = shift;
+ my($file,$line,$id) = id(1);
+ $message .= " at $file line $line.\n" unless $message=~/\n$/;
+ my $stamp = stamp;
+ $message=~s/^/$stamp/gm;
+ realwarn $message;
+}
+
+# The mod_perl package Apache::Registry loads CGI programs by calling
+# eval. These evals don't count when looking at the stack backtrace.
+sub _longmess {
+ my $message = Carp::longmess();
+ my $mod_perl = ($ENV{'GATEWAY_INTERFACE'}
+ && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-Perl\//);
+ $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
+ return( $message );
+}
+
+sub die {
+ my $message = shift;
+ my $time = scalar(localtime);
+ my($file,$line,$id) = id(1);
+ $message .= " at $file line $line.\n" unless $message=~/\n$/;
+ &fatalsToBrowser($message) if $WRAP && _longmess() !~ /eval [{\']/m;
+ my $stamp = stamp;
+ $message=~s/^/$stamp/gm;
+ realdie $message;
+}
+
+sub set_message {
+ $CGI::Carp::CUSTOM_MSG = shift;
+ return $CGI::Carp::CUSTOM_MSG;
+}
+
+# Avoid generating "subroutine redefined" warnings with the following
+# hack:
+{
+ local $^W=0;
+ eval <<EOF;
+sub confess { CGI::Carp::die Carp::longmess \@_; }
+sub croak { CGI::Carp::die Carp::shortmess \@_; }
+sub carp { CGI::Carp::warn Carp::shortmess \@_; }
+EOF
+ ;
+}
+
+# We have to be ready to accept a filehandle as a reference
+# or a string.
+sub carpout {
+ my($in) = @_;
+ my($no) = fileno(to_filehandle($in));
+ realdie "Invalid filehandle $in\n" unless defined $no;
+
+ open(SAVEERR, ">&STDERR");
+ open(STDERR, ">&$no") or
+ ( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
+}
+
+# headers
+sub fatalsToBrowser {
+ my($msg) = @_;
+ $msg=~s/>/&gt;/g;
+ $msg=~s/</&lt;/g;
+ $msg=~s/&/&amp;/g;
+ $msg=~s/\"/&quot;/g;
+ my($wm) = $ENV{SERVER_ADMIN} ?
+ qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
+ "this site's webmaster";
+ my ($outer_message) = <<END;
+For help, please send mail to $wm, giving this error message
+and the time and date of the error.
+END
+ ;
+ print STDOUT "Content-type: text/html\n\n";
+
+ if ($CUSTOM_MSG) {
+ if (ref($CUSTOM_MSG) eq 'CODE') {
+ &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
+ return;
+ } else {
+ $outer_message = $CUSTOM_MSG;
+ }
+ }
+
+ print STDOUT <<END;
+<H1>Software error:</H1>
+<CODE>$msg</CODE>
+<P>
+$outer_message;
+END
+ ;
+}
+
+# Cut and paste from CGI.pm so that we don't have the overhead of
+# always loading the entire CGI module.
+sub to_filehandle {
+ my $thingy = shift;
+ return undef unless $thingy;
+ return $thingy if UNIVERSAL::isa($thingy,'GLOB');
+ return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
+ if (!ref($thingy)) {
+ my $caller = 1;
+ while (my $package = caller($caller++)) {
+ my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
+ return $tmp if defined(fileno($tmp));
+ }
+ }
+ return undef;
+}
+
+1;
diff --git a/contrib/perl5/lib/CGI/Cookie.pm b/contrib/perl5/lib/CGI/Cookie.pm
new file mode 100644
index 000000000000..c32891a33123
--- /dev/null
+++ b/contrib/perl5/lib/CGI/Cookie.pm
@@ -0,0 +1,418 @@
+package CGI::Cookie;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+# The most recent version and complete docs are available at:
+# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
+# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+
+$CGI::Cookie::VERSION='1.06';
+
+use CGI;
+use overload '""' => \&as_string,
+ 'cmp' => \&compare,
+ 'fallback'=>1;
+
+# fetch a list of cookies from the environment and
+# return as a hash. the cookies are parsed as normal
+# escaped URL data.
+sub fetch {
+ my $class = shift;
+ my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
+ return () unless $raw_cookie;
+ return $class->parse($raw_cookie);
+}
+
+# fetch a list of cookies from the environment and
+# return as a hash. the cookie values are not unescaped
+# or altered in any way.
+sub raw_fetch {
+ my $class = shift;
+ my $raw_cookie = $ENV{HTTP_COOKIE} || $ENV{COOKIE};
+ return () unless $raw_cookie;
+ my %results;
+ my($key,$value);
+
+ my(@pairs) = split("; ",$raw_cookie);
+ foreach (@pairs) {
+ if (/^([^=]+)=(.*)/) {
+ $key = $1;
+ $value = $2;
+ }
+ else {
+ $key = $_;
+ $value = '';
+ }
+ $results{$key} = $value;
+ }
+ return \%results unless wantarray;
+ return %results;
+}
+
+sub parse {
+ my ($self,$raw_cookie) = @_;
+ my %results;
+
+ my(@pairs) = split("; ",$raw_cookie);
+ foreach (@pairs) {
+ my($key,$value) = split("=");
+ my(@values) = map CGI::unescape($_),split('&',$value);
+ $key = CGI::unescape($key);
+ $results{$key} = $self->new(-name=>$key,-value=>\@values);
+ }
+ return \%results unless wantarray;
+ return %results;
+}
+
+sub new {
+ my $class = shift;
+ $class = ref($class) if ref($class);
+ my($name,$value,$path,$domain,$secure,$expires) =
+ CGI->rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES],@_);
+
+ # Pull out our parameters.
+ my @values;
+ if (ref($value)) {
+ if (ref($value) eq 'ARRAY') {
+ @values = @$value;
+ } elsif (ref($value) eq 'HASH') {
+ @values = %$value;
+ }
+ } else {
+ @values = ($value);
+ }
+
+ bless my $self = {
+ 'name'=>$name,
+ 'value'=>[@values],
+ },$class;
+
+ # IE requires the path to be present for some reason.
+ ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path;
+
+ $self->path($path) if defined $path;
+ $self->domain($domain) if defined $domain;
+ $self->secure($secure) if defined $secure;
+ $self->expires($expires) if defined $expires;
+ return $self;
+}
+
+sub as_string {
+ my $self = shift;
+ return "" unless $self->name;
+
+ my(@constant_values,$domain,$path,$expires,$secure);
+
+ push(@constant_values,"domain=$domain") if $domain = $self->domain;
+ push(@constant_values,"path=$path") if $path = $self->path;
+ push(@constant_values,"expires=$expires") if $expires = $self->expires;
+ push(@constant_values,'secure') if $secure = $self->secure;
+
+ my($key) = CGI::escape($self->name);
+ my($cookie) = join("=",$key,join("&",map CGI::escape($_),$self->value));
+ return join("; ",$cookie,@constant_values);
+}
+
+sub compare {
+ my $self = shift;
+ my $value = shift;
+ return "$self" cmp $value;
+}
+
+# accessors
+sub name {
+ my $self = shift;
+ my $name = shift;
+ $self->{'name'} = $name if defined $name;
+ return $self->{'name'};
+}
+
+sub value {
+ my $self = shift;
+ my $value = shift;
+ $self->{'value'} = $value if defined $value;
+ return wantarray ? @{$self->{'value'}} : $self->{'value'}->[0]
+}
+
+sub domain {
+ my $self = shift;
+ my $domain = shift;
+ $self->{'domain'} = $domain if defined $domain;
+ return $self->{'domain'};
+}
+
+sub secure {
+ my $self = shift;
+ my $secure = shift;
+ $self->{'secure'} = $secure if defined $secure;
+ return $self->{'secure'};
+}
+
+sub expires {
+ my $self = shift;
+ my $expires = shift;
+ $self->{'expires'} = CGI::expires($expires,'cookie') if defined $expires;
+ return $self->{'expires'};
+}
+
+sub path {
+ my $self = shift;
+ my $path = shift;
+ $self->{'path'} = $path if defined $path;
+ return $self->{'path'};
+}
+
+1;
+
+=head1 NAME
+
+CGI::Cookie - Interface to Netscape Cookies
+
+=head1 SYNOPSIS
+
+ use CGI qw/:standard/;
+ use CGI::Cookie;
+
+ # Create new cookies and send them
+ $cookie1 = new CGI::Cookie(-name=>'ID',-value=>123456);
+ $cookie2 = new CGI::Cookie(-name=>'preferences',
+ -value=>{ font => Helvetica,
+ size => 12 }
+ );
+ print header(-cookie=>[$cookie1,$cookie2]);
+
+ # fetch existing cookies
+ %cookies = fetch CGI::Cookie;
+ $id = $cookies{'ID'}->value;
+
+ # create cookies returned from an external source
+ %cookies = parse CGI::Cookie($ENV{COOKIE});
+
+=head1 DESCRIPTION
+
+CGI::Cookie is an interface to Netscape (HTTP/1.1) cookies, an
+innovation that allows Web servers to store persistent information on
+the browser's side of the connection. Although CGI::Cookie is
+intended to be used in conjunction with CGI.pm (and is in fact used by
+it internally), you can use this module independently.
+
+For full information on cookies see
+
+ http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt
+
+=head1 USING CGI::Cookie
+
+CGI::Cookie is object oriented. Each cookie object has a name and a
+value. The name is any scalar value. The value is any scalar or
+array value (associative arrays are also allowed). Cookies also have
+several optional attributes, including:
+
+=over 4
+
+=item B<1. expiration date>
+
+The expiration date tells the browser how long to hang on to the
+cookie. If the cookie specifies an expiration date in the future, the
+browser will store the cookie information in a disk file and return it
+to the server every time the user reconnects (until the expiration
+date is reached). If the cookie species an expiration date in the
+past, the browser will remove the cookie from the disk file. If the
+expiration date is not specified, the cookie will persist only until
+the user quits the browser.
+
+=item B<2. domain>
+
+This is a partial or complete domain name for which the cookie is
+valid. The browser will return the cookie to any host that matches
+the partial domain name. For example, if you specify a domain name
+of ".capricorn.com", then Netscape will return the cookie to
+Web servers running on any of the machines "www.capricorn.com",
+"ftp.capricorn.com", "feckless.capricorn.com", etc. Domain names
+must contain at least two periods to prevent attempts to match
+on top level domains like ".edu". If no domain is specified, then
+the browser will only return the cookie to servers on the host the
+cookie originated from.
+
+=item B<3. path>
+
+If you provide a cookie path attribute, the browser will check it
+against your script's URL before returning the cookie. For example,
+if you specify the path "/cgi-bin", then the cookie will be returned
+to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
+and "/cgi-bin/customer_service/complain.pl", but not to the script
+"/cgi-private/site_admin.pl". By default, path is set to "/", which
+causes the cookie to be sent to any CGI script on your site.
+
+=item B<4. secure flag>
+
+If the "secure" attribute is set, the cookie will only be sent to your
+script if the CGI request is occurring on a secure channel, such as SSL.
+
+=back
+
+=head2 Creating New Cookies
+
+ $c = new CGI::Cookie(-name => 'foo',
+ -value => 'bar',
+ -expires => '+3M',
+ -domain => '.capricorn.com',
+ -path => '/cgi-bin/database'
+ -secure => 1
+ );
+
+Create cookies from scratch with the B<new> method. The B<-name> and
+B<-value> parameters are required. The name must be a scalar value.
+The value can be a scalar, an array reference, or a hash reference.
+(At some point in the future cookies will support one of the Perl
+object serialization protocols for full generality).
+
+B<-expires> accepts any of the relative or absolute date formats
+recognized by CGI.pm, for example "+3M" for three months in the
+future. See CGI.pm's documentation for details.
+
+B<-domain> points to a domain name or to a fully qualified host name.
+If not specified, the cookie will be returned only to the Web server
+that created it.
+
+B<-path> points to a partial URL on the current server. The cookie
+will be returned to all URLs beginning with the specified path. If
+not specified, it defaults to '/', which returns the cookie to all
+pages at your site.
+
+B<-secure> if set to a true value instructs the browser to return the
+cookie only when a cryptographic protocol is in use.
+
+=head2 Sending the Cookie to the Browser
+
+Within a CGI script you can send a cookie to the browser by creating
+one or more Set-Cookie: fields in the HTTP header. Here is a typical
+sequence:
+
+ my $c = new CGI::Cookie(-name => 'foo',
+ -value => ['bar','baz'],
+ -expires => '+3M');
+
+ print "Set-Cookie: $c\n";
+ print "Content-Type: text/html\n\n";
+
+To send more than one cookie, create several Set-Cookie: fields.
+Alternatively, you may concatenate the cookies together with "; " and
+send them in one field.
+
+If you are using CGI.pm, you send cookies by providing a -cookie
+argument to the header() method:
+
+ print header(-cookie=>$c);
+
+Mod_perl users can set cookies using the request object's header_out()
+method:
+
+ $r->header_out('Set-Cookie',$c);
+
+Internally, Cookie overloads the "" operator to call its as_string()
+method when incorporated into the HTTP header. as_string() turns the
+Cookie's internal representation into an RFC-compliant text
+representation. You may call as_string() yourself if you prefer:
+
+ print "Set-Cookie: ",$c->as_string,"\n";
+
+=head2 Recovering Previous Cookies
+
+ %cookies = fetch CGI::Cookie;
+
+B<fetch> returns an associative array consisting of all cookies
+returned by the browser. The keys of the array are the cookie names. You
+can iterate through the cookies this way:
+
+ %cookies = fetch CGI::Cookie;
+ foreach (keys %cookies) {
+ do_something($cookies{$_});
+ }
+
+In a scalar context, fetch() returns a hash reference, which may be more
+efficient if you are manipulating multiple cookies.
+
+CGI.pm uses the URL escaping methods to save and restore reserved characters
+in its cookies. If you are trying to retrieve a cookie set by a foreign server,
+this escaping method may trip you up. Use raw_fetch() instead, which has the
+same semantics as fetch(), but performs no unescaping.
+
+You may also retrieve cookies that were stored in some external
+form using the parse() class method:
+
+ $COOKIES = `cat /usr/tmp/Cookie_stash`;
+ %cookies = parse CGI::Cookie($COOKIES);
+
+=head2 Manipulating Cookies
+
+Cookie objects have a series of accessor methods to get and set cookie
+attributes. Each accessor has a similar syntax. Called without
+arguments, the accessor returns the current value of the attribute.
+Called with an argument, the accessor changes the attribute and
+returns its new value.
+
+=over 4
+
+=item B<name()>
+
+Get or set the cookie's name. Example:
+
+ $name = $c->name;
+ $new_name = $c->name('fred');
+
+=item B<value()>
+
+Get or set the cookie's value. Example:
+
+ $value = $c->value;
+ @new_value = $c->value(['a','b','c','d']);
+
+B<value()> is context sensitive. In an array context it will return
+the current value of the cookie as an array. In a scalar context it
+will return the B<first> value of a multivalued cookie.
+
+=item B<domain()>
+
+Get or set the cookie's domain.
+
+=item B<path()>
+
+Get or set the cookie's path.
+
+=item B<expires()>
+
+Get or set the cookie's expiration time.
+
+=back
+
+
+=head1 AUTHOR INFORMATION
+
+be used and modified freely, but I do request that this copyright
+notice remain attached to the file. You may modify this module as you
+wish, but if you redistribute a modified version, please attach a note
+listing the modifications you have made.
+
+Address bug reports and comments to:
+lstein@genome.wi.mit.edu
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
diff --git a/contrib/perl5/lib/CGI/Fast.pm b/contrib/perl5/lib/CGI/Fast.pm
new file mode 100644
index 000000000000..03b54072c961
--- /dev/null
+++ b/contrib/perl5/lib/CGI/Fast.pm
@@ -0,0 +1,173 @@
+package CGI::Fast;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+# The most recent version and complete docs are available at:
+# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
+# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+$CGI::Fast::VERSION='1.00a';
+
+use CGI;
+use FCGI;
+@ISA = ('CGI');
+
+# workaround for known bug in libfcgi
+while (($ignore) = each %ENV) { }
+
+# override the initialization behavior so that
+# state is NOT maintained between invocations
+sub save_request {
+ # no-op
+}
+
+# New is slightly different in that it calls FCGI's
+# accept() method.
+sub new {
+ return undef unless FCGI::accept() >= 0;
+ my($self,@param) = @_;
+ return $CGI::Q = $self->SUPER::new(@param);
+}
+
+1;
+
+=head1 NAME
+
+CGI::Fast - CGI Interface for Fast CGI
+
+=head1 SYNOPSIS
+
+ use CGI::Fast qw(:standard);
+ $COUNTER = 0;
+ while (new CGI::Fast) {
+ print header;
+ print start_html("Fast CGI Rocks");
+ print
+ h1("Fast CGI Rocks"),
+ "Invocation number ",b($COUNTER++),
+ " PID ",b($$),".",
+ hr;
+ print end_html;
+ }
+
+=head1 DESCRIPTION
+
+CGI::Fast is a subclass of the CGI object created by
+CGI.pm. It is specialized to work well with the Open Market
+FastCGI standard, which greatly speeds up CGI scripts by
+turning them into persistently running server processes. Scripts
+that perform time-consuming initialization processes, such as
+loading large modules or opening persistent database connections,
+will see large performance improvements.
+
+=head1 OTHER PIECES OF THE PUZZLE
+
+In order to use CGI::Fast you'll need a FastCGI-enabled Web
+server. Open Market's server is FastCGI-savvy. There are also
+freely redistributable FastCGI modules for NCSA httpd 1.5 and Apache.
+FastCGI-enabling modules for Microsoft Internet Information Server and
+Netscape Communications Server have been announced.
+
+In addition, you'll need a version of the Perl interpreter that has
+been linked with the FastCGI I/O library. Precompiled binaries are
+available for several platforms, including DEC Alpha, HP-UX and
+SPARC/Solaris, or you can rebuild Perl from source with patches
+provided in the FastCGI developer's kit. The FastCGI Perl interpreter
+can be used in place of your normal Perl without ill consequences.
+
+You can find FastCGI modules for Apache and NCSA httpd, precompiled
+Perl interpreters, and the FastCGI developer's kit all at URL:
+
+ http://www.fastcgi.com/
+
+=head1 WRITING FASTCGI PERL SCRIPTS
+
+FastCGI scripts are persistent: one or more copies of the script
+are started up when the server initializes, and stay around until
+the server exits or they die a natural death. After performing
+whatever one-time initialization it needs, the script enters a
+loop waiting for incoming connections, processing the request, and
+waiting some more.
+
+A typical FastCGI script will look like this:
+
+ #!/usr/local/bin/perl # must be a FastCGI version of perl!
+ use CGI::Fast;
+ &do_some_initialization();
+ while ($q = new CGI::Fast) {
+ &process_request($q);
+ }
+
+Each time there's a new request, CGI::Fast returns a
+CGI object to your loop. The rest of the time your script
+waits in the call to new(). When the server requests that
+your script be terminated, new() will return undef. You can
+of course exit earlier if you choose. A new version of the
+script will be respawned to take its place (this may be
+necessary in order to avoid Perl memory leaks in long-running
+scripts).
+
+CGI.pm's default CGI object mode also works. Just modify the loop
+this way:
+
+ while (new CGI::Fast) {
+ &process_request;
+ }
+
+Calls to header(), start_form(), etc. will all operate on the
+current request.
+
+=head1 INSTALLING FASTCGI SCRIPTS
+
+See the FastCGI developer's kit documentation for full details. On
+the Apache server, the following line must be added to srm.conf:
+
+ AddType application/x-httpd-fcgi .fcgi
+
+FastCGI scripts must end in the extension .fcgi. For each script you
+install, you must add something like the following to srm.conf:
+
+ AppClass /usr/etc/httpd/fcgi-bin/file_upload.fcgi -processes 2
+
+This instructs Apache to launch two copies of file_upload.fcgi at
+startup time.
+
+=head1 USING FASTCGI SCRIPTS AS CGI SCRIPTS
+
+Any script that works correctly as a FastCGI script will also work
+correctly when installed as a vanilla CGI script. However it will
+not see any performance benefit.
+
+=head1 CAVEATS
+
+I haven't tested this very much.
+
+=head1 AUTHOR INFORMATION
+
+be used and modified freely, but I do request that this copyright
+notice remain attached to the file. You may modify this module as you
+wish, but if you redistribute a modified version, please attach a note
+listing the modifications you have made.
+
+Address bug reports and comments to:
+lstein@genome.wi.mit.edu
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
diff --git a/contrib/perl5/lib/CGI/Push.pm b/contrib/perl5/lib/CGI/Push.pm
new file mode 100644
index 000000000000..eeec3f81108f
--- /dev/null
+++ b/contrib/perl5/lib/CGI/Push.pm
@@ -0,0 +1,313 @@
+package CGI::Push;
+
+# See the bottom of this file for the POD documentation. Search for the
+# string '=head'.
+
+# You can run this file through either pod2man or pod2html to produce pretty
+# documentation in manual or html file format (these utilities are part of the
+# Perl 5 distribution).
+
+# Copyright 1995,1996, Lincoln D. Stein. All rights reserved.
+# It may be used and modified freely, but I do request that this copyright
+# notice remain attached to the file. You may modify this module as you
+# wish, but if you redistribute a modified version, please attach a note
+# listing the modifications you have made.
+
+# The most recent version and complete docs are available at:
+# http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html
+# ftp://ftp-genome.wi.mit.edu/pub/software/WWW/
+
+$CGI::Push::VERSION='1.01';
+use CGI;
+@ISA = ('CGI');
+
+$CGI::DefaultClass = 'CGI::Push';
+$CGI::Push::AutoloadClass = 'CGI';
+
+# add do_push() and push_delay() to exported tags
+push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push','push_delay');
+
+sub do_push {
+ my ($self,@p) = CGI::self_or_default(@_);
+
+ # unbuffer output
+ $| = 1;
+ srand;
+ my ($random) = sprintf("%16.0f",rand()*1E16);
+ my ($boundary) = "----------------------------------$random";
+
+ my (@header);
+ my ($type,$callback,$delay,$last_page,$cookie,$target,$expires,@other) =
+ $self->rearrange([TYPE,NEXT_PAGE,DELAY,LAST_PAGE,[COOKIE,COOKIES],TARGET,EXPIRES],@p);
+ $type = 'text/html' unless $type;
+ $callback = \&simple_counter unless $callback && ref($callback) eq 'CODE';
+ $delay = 1 unless defined($delay);
+ $self->push_delay($delay);
+
+ my(@o);
+ foreach (@other) { push(@o,split("=")); }
+ push(@o,'-Target'=>$target) if defined($target);
+ push(@o,'-Cookie'=>$cookie) if defined($cookie);
+ push(@o,'-Type'=>"multipart/x-mixed-replace; boundary=$boundary");
+ push(@o,'-Server'=>"CGI.pm Push Module");
+ push(@o,'-Status'=>'200 OK');
+ push(@o,'-nph'=>1);
+ print $self->header(@o);
+ print "${boundary}$CGI::CRLF";
+
+ # now we enter a little loop
+ my @contents;
+ while (1) {
+ last unless (@contents = &$callback($self,++$COUNTER)) && defined($contents[0]);
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF"
+ unless $type eq 'dynamic';
+ print @contents,"$CGI::CRLF";
+ print "${boundary}$CGI::CRLF";
+ do_sleep($self->push_delay()) if $self->push_delay();
+ }
+
+ # Optional last page
+ if ($last_page && ref($last_page) eq 'CODE') {
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF" unless $type =~ /^dynamic|heterogeneous$/i;
+ print &$last_page($self,$COUNTER),"$CGI::CRLF${boundary}$CGI::CRLF";
+ }
+}
+
+sub simple_counter {
+ my ($self,$count) = @_;
+ return (
+ CGI->start_html("CGI::Push Default Counter"),
+ CGI->h1("CGI::Push Default Counter"),
+ "This page has been updated ",CGI->strong($count)," times.",
+ CGI->hr(),
+ CGI->a({'-href'=>'http://www.genome.wi.mit.edu/ftp/pub/software/WWW/cgi_docs.html'},'CGI.pm home page'),
+ CGI->end_html
+ );
+}
+
+sub do_sleep {
+ my $delay = shift;
+ if ( ($delay >= 1) && ($delay!~/\./) ){
+ sleep($delay);
+ } else {
+ select(undef,undef,undef,$delay);
+ }
+}
+
+sub push_delay {
+ my ($self,$delay) = CGI::self_or_default(@_);
+ return defined($delay) ? $self->{'.delay'} =
+ $delay : $self->{'.delay'};
+}
+
+1;
+
+=head1 NAME
+
+CGI::Push - Simple Interface to Server Push
+
+=head1 SYNOPSIS
+
+ use CGI::Push qw(:standard);
+
+ do_push(-next_page=>\&next_page,
+ -last_page=>\&last_page,
+ -delay=>0.5);
+
+ sub next_page {
+ my($q,$counter) = @_;
+ return undef if $counter >= 10;
+ return start_html('Test'),
+ h1('Visible'),"\n",
+ "This page has been called ", strong($counter)," times",
+ end_html();
+ }
+
+ sub last_page {
+ my($q,$counter) = @_;
+ return start_html('Done'),
+ h1('Finished'),
+ strong($counter),' iterations.',
+ end_html;
+ }
+
+=head1 DESCRIPTION
+
+CGI::Push is a subclass of the CGI object created by CGI.pm. It is
+specialized for server push operations, which allow you to create
+animated pages whose content changes at regular intervals.
+
+You provide CGI::Push with a pointer to a subroutine that will draw
+one page. Every time your subroutine is called, it generates a new
+page. The contents of the page will be transmitted to the browser
+in such a way that it will replace what was there beforehand. The
+technique will work with HTML pages as well as with graphics files,
+allowing you to create animated GIFs.
+
+=head1 USING CGI::Push
+
+CGI::Push adds one new method to the standard CGI suite, do_push().
+When you call this method, you pass it a reference to a subroutine
+that is responsible for drawing each new page, an interval delay, and
+an optional subroutine for drawing the last page. Other optional
+parameters include most of those recognized by the CGI header()
+method.
+
+You may call do_push() in the object oriented manner or not, as you
+prefer:
+
+ use CGI::Push;
+ $q = new CGI::Push;
+ $q->do_push(-next_page=>\&draw_a_page);
+
+ -or-
+
+ use CGI::Push qw(:standard);
+ do_push(-next_page=>\&draw_a_page);
+
+Parameters are as follows:
+
+=over 4
+
+=item -next_page
+
+ do_push(-next_page=>\&my_draw_routine);
+
+This required parameter points to a reference to a subroutine responsible for
+drawing each new page. The subroutine should expect two parameters
+consisting of the CGI object and a counter indicating the number
+of times the subroutine has been called. It should return the
+contents of the page as an B<array> of one or more items to print.
+It can return a false value (or an empty array) in order to abort the
+redrawing loop and print out the final page (if any)
+
+ sub my_draw_routine {
+ my($q,$counter) = @_;
+ return undef if $counter > 100;
+ return start_html('testing'),
+ h1('testing'),
+ "This page called $counter times";
+ }
+
+You are of course free to refer to create and use global variables
+within your draw routine in order to achieve special effects.
+
+=item -last_page
+
+This optional parameter points to a reference to the subroutine
+responsible for drawing the last page of the series. It is called
+after the -next_page routine returns a false value. The subroutine
+itself should have exactly the same calling conventions as the
+-next_page routine.
+
+=item -type
+
+This optional parameter indicates the content type of each page. It
+defaults to "text/html". Normally the module assumes that each page
+is of a homogenous MIME type. However if you provide either of the
+magic values "heterogeneous" or "dynamic" (the latter provided for the
+convenience of those who hate long parameter names), you can specify
+the MIME type -- and other header fields -- on a per-page basis. See
+"heterogeneous pages" for more details.
+
+=item -delay
+
+This indicates the delay, in seconds, between frames. Smaller delays
+refresh the page faster. Fractional values are allowed.
+
+B<If not specified, -delay will default to 1 second>
+
+=item -cookie, -target, -expires
+
+These have the same meaning as the like-named parameters in
+CGI::header().
+
+=back
+
+=head2 Heterogeneous Pages
+
+Ordinarily all pages displayed by CGI::Push share a common MIME type.
+However by providing a value of "heterogeneous" or "dynamic" in the
+do_push() -type parameter, you can specify the MIME type of each page
+on a case-by-case basis.
+
+If you use this option, you will be responsible for producing the
+HTTP header for each page. Simply modify your draw routine to
+look like this:
+
+ sub my_draw_routine {
+ my($q,$counter) = @_;
+ return header('text/html'), # note we're producing the header here
+ start_html('testing'),
+ h1('testing'),
+ "This page called $counter times";
+ }
+
+You can add any header fields that you like, but some (cookies and
+status fields included) may not be interpreted by the browser. One
+interesting effect is to display a series of pages, then, after the
+last page, to redirect the browser to a new URL. Because redirect()
+does b<not> work, the easiest way is with a -refresh header field,
+as shown below:
+
+ sub my_draw_routine {
+ my($q,$counter) = @_;
+ return undef if $counter > 10;
+ return header('text/html'), # note we're producing the header here
+ start_html('testing'),
+ h1('testing'),
+ "This page called $counter times";
+ }
+
+ sub my_last_page {
+ header(-refresh=>'5; URL=http://somewhere.else/finished.html',
+ -type=>'text/html'),
+ start_html('Moved'),
+ h1('This is the last page'),
+ 'Goodbye!'
+ hr,
+ end_html;
+ }
+
+=head2 Changing the Page Delay on the Fly
+
+If you would like to control the delay between pages on a page-by-page
+basis, call push_delay() from within your draw routine. push_delay()
+takes a single numeric argument representing the number of seconds you
+wish to delay after the current page is displayed and before
+displaying the next one. The delay may be fractional. Without
+parameters, push_delay() just returns the current delay.
+
+=head1 INSTALLING CGI::Push SCRIPTS
+
+Server push scripts B<must> be installed as no-parsed-header (NPH)
+scripts in order to work correctly. On Unix systems, this is most
+often accomplished by prefixing the script's name with "nph-".
+Recognition of NPH scripts happens automatically with WebSTAR and
+Microsoft IIS. Users of other servers should see their documentation
+for help.
+
+=head1 CAVEATS
+
+This is a new module. It hasn't been extensively tested.
+
+=head1 AUTHOR INFORMATION
+
+be used and modified freely, but I do request that this copyright
+notice remain attached to the file. You may modify this module as you
+wish, but if you redistribute a modified version, please attach a note
+listing the modifications you have made.
+
+Address bug reports and comments to:
+lstein@genome.wi.mit.edu
+
+=head1 BUGS
+
+This section intentionally left blank.
+
+=head1 SEE ALSO
+
+L<CGI::Carp>, L<CGI>
+
+=cut
+
diff --git a/contrib/perl5/lib/CGI/Switch.pm b/contrib/perl5/lib/CGI/Switch.pm
new file mode 100644
index 000000000000..8afc6a6cb347
--- /dev/null
+++ b/contrib/perl5/lib/CGI/Switch.pm
@@ -0,0 +1,71 @@
+package CGI::Switch;
+use Carp;
+use strict;
+use vars qw($VERSION @Pref);
+$VERSION = '0.06';
+@Pref = qw(CGI::Apache CGI); #default
+
+sub import {
+ my($self,@arg) = @_;
+ @Pref = @arg if @arg;
+}
+
+sub new {
+ shift;
+ my($file,$pack);
+ for $pack (@Pref) {
+ ($file = $pack) =~ s|::|/|g;
+ eval { require "$file.pm"; };
+ if ($@) {
+#XXX warn $@;
+ next;
+ } else {
+#XXX warn "Going to try $pack\->new\n";
+ my $obj;
+ eval {$obj = $pack->new(@_)};
+ if ($@) {
+#XXX warn $@;
+ } else {
+ return $obj;
+ }
+ }
+ }
+ Carp::croak "Couldn't load+construct any of @Pref\n";
+}
+
+1;
+__END__
+
+=head1 NAME
+
+CGI::Switch - Try more than one constructors and return the first object available
+
+=head1 SYNOPSIS
+
+
+ use CGISwitch;
+
+ -or-
+
+ use CGI::Switch This, That, CGI::XA, Foo, Bar, CGI;
+
+ my $q = new CGI::Switch;
+
+=head1 DESCRIPTION
+
+Per default the new() method tries to call new() in the three packages
+Apache::CGI, CGI::XA, and CGI. It returns the first CGI object it
+succeeds with.
+
+The import method allows you to set up the default order of the
+modules to be tested.
+
+=head1 SEE ALSO
+
+perl(1), Apache(3), CGI(3), CGI::XA(3)
+
+=head1 AUTHOR
+
+Andreas KE<ouml>nig E<lt>a.koenig@mind.deE<gt>
+
+=cut
diff --git a/contrib/perl5/lib/CPAN.pm b/contrib/perl5/lib/CPAN.pm
new file mode 100644
index 000000000000..b510ea2082da
--- /dev/null
+++ b/contrib/perl5/lib/CPAN.pm
@@ -0,0 +1,4368 @@
+package CPAN;
+use vars qw{$Try_autoload $Revision
+ $META $Signal $Cwd $End
+ $Suppress_readline %Dontload
+ $Frontend $Defaultsite
+ };
+
+$VERSION = '1.3901';
+
+# $Id: CPAN.pm,v 1.226 1998/07/08 22:29:29 k Exp k $
+
+# only used during development:
+$Revision = "";
+# $Revision = "[".substr(q$Revision: 1.226 $, 10)."]";
+
+use Carp ();
+use Config ();
+use Cwd ();
+use DirHandle;
+use Exporter ();
+use ExtUtils::MakeMaker ();
+use File::Basename ();
+use File::Copy ();
+use File::Find;
+use File::Path ();
+use FileHandle ();
+use Safe ();
+use Text::ParseWords ();
+use Text::Wrap;
+
+END { $End++; &cleanup; }
+
+%CPAN::DEBUG = qw(
+ CPAN 1
+ Index 2
+ InfoObj 4
+ Author 8
+ Distribution 16
+ Bundle 32
+ Module 64
+ CacheMgr 128
+ Complete 256
+ FTP 512
+ Shell 1024
+ Eval 2048
+ Config 4096
+ Tarzip 8192
+ );
+
+$CPAN::DEBUG ||= 0;
+$CPAN::Signal ||= 0;
+$CPAN::Frontend ||= "CPAN::Shell";
+$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
+
+package CPAN;
+use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term);
+use strict qw(vars);
+
+@CPAN::ISA = qw(CPAN::Debug Exporter MM); # MM will go away
+ # soonish. Already version
+ # 1.29 doesn't rely on
+ # catfile and catdir being
+ # available via
+ # inheritance. Anything else
+ # in danger?
+
+@EXPORT = qw(
+ autobundle bundle expand force get
+ install make readme recompile shell test clean
+ );
+
+#-> sub CPAN::AUTOLOAD ;
+sub AUTOLOAD {
+ my($l) = $AUTOLOAD;
+ $l =~ s/.*:://;
+ my(%EXPORT);
+ @EXPORT{@EXPORT} = '';
+ if (exists $EXPORT{$l}){
+ CPAN::Shell->$l(@_);
+ } else {
+ my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
+ if ($ok) {
+ goto &$AUTOLOAD;
+# } else {
+# $CPAN::Frontend->mywarn("Could not autoload $AUTOLOAD");
+ }
+ $CPAN::Frontend->mywarn(qq{Unknown command "$AUTOLOAD". }.
+ qq{Type ? for help.
+});
+ }
+}
+
+#-> sub CPAN::shell ;
+sub shell {
+ $Suppress_readline ||= ! -t STDIN;
+
+ my $prompt = "cpan> ";
+ local($^W) = 1;
+ unless ($Suppress_readline) {
+ require Term::ReadLine;
+# import Term::ReadLine;
+ $term = Term::ReadLine->new('CPAN Monitor');
+ $readline::rl_completion_function =
+ $readline::rl_completion_function = 'CPAN::Complete::cpl';
+ }
+
+ no strict;
+ $META->checklock();
+ my $getcwd;
+ $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
+ my $cwd = CPAN->$getcwd();
+ my $rl_avail = $Suppress_readline ? "suppressed" :
+ ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
+ "available (try ``install Bundle::CPAN'')";
+
+ $CPAN::Frontend->myprint(
+ qq{
+cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION$CPAN::Revision)
+ReadLine support $rl_avail
+
+}) unless $CPAN::Config->{'inhibit_startup_message'} ;
+ my($continuation) = "";
+ while () {
+ if ($Suppress_readline) {
+ print $prompt;
+ last unless defined ($_ = <> );
+ chomp;
+ } else {
+ last unless defined ($_ = $term->readline($prompt));
+ }
+ $_ = "$continuation$_" if $continuation;
+ s/^\s+//;
+ next if /^$/;
+ $_ = 'h' if $_ eq '?';
+ if (/^(?:q(?:uit)?|bye|exit)$/i) {
+ last;
+ } elsif (s/\\$//s) {
+ chomp;
+ $continuation = $_;
+ $prompt = " > ";
+ } elsif (/^\!/) {
+ s/^\!//;
+ my($eval) = $_;
+ package CPAN::Eval;
+ use vars qw($import_done);
+ CPAN->import(':DEFAULT') unless $import_done++;
+ CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
+ eval($eval);
+ warn $@ if $@;
+ $continuation = "";
+ $prompt = "cpan> ";
+ } elsif (/./) {
+ my(@line);
+ if ($] < 5.00322) { # parsewords had a bug until recently
+ @line = split;
+ } else {
+ eval { @line = Text::ParseWords::shellwords($_) };
+ warn($@), next if $@;
+ }
+ $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
+ my $command = shift @line;
+ eval { CPAN::Shell->$command(@line) };
+ warn $@ if $@;
+ chdir $cwd;
+ $CPAN::Frontend->myprint("\n");
+ $continuation = "";
+ $prompt = "cpan> ";
+ }
+ } continue {
+ $Signal=0;
+ }
+}
+
+package CPAN::CacheMgr;
+@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
+use File::Find;
+
+package CPAN::Config;
+import ExtUtils::MakeMaker 'neatvalue';
+use vars qw(%can $dot_cpan);
+
+%can = (
+ 'commit' => "Commit changes to disk",
+ 'defaults' => "Reload defaults from disk",
+ 'init' => "Interactive setting of all options",
+);
+
+package CPAN::FTP;
+use vars qw($Ua $Thesite $Themethod);
+@CPAN::FTP::ISA = qw(CPAN::Debug);
+
+package CPAN::Complete;
+@CPAN::Complete::ISA = qw(CPAN::Debug);
+
+package CPAN::Index;
+use vars qw($last_time $date_of_03);
+@CPAN::Index::ISA = qw(CPAN::Debug);
+$last_time ||= 0;
+$date_of_03 ||= 0;
+
+package CPAN::InfoObj;
+@CPAN::InfoObj::ISA = qw(CPAN::Debug);
+
+package CPAN::Author;
+@CPAN::Author::ISA = qw(CPAN::InfoObj);
+
+package CPAN::Distribution;
+@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
+
+package CPAN::Bundle;
+@CPAN::Bundle::ISA = qw(CPAN::Module);
+
+package CPAN::Module;
+@CPAN::Module::ISA = qw(CPAN::InfoObj);
+
+package CPAN::Shell;
+use vars qw($AUTOLOAD $redef @ISA);
+@CPAN::Shell::ISA = qw(CPAN::Debug);
+
+#-> sub CPAN::Shell::AUTOLOAD ;
+sub AUTOLOAD {
+ my($autoload) = $AUTOLOAD;
+ my $class = shift(@_);
+ # warn "autoload[$autoload] class[$class]";
+ $autoload =~ s/.*:://;
+ if ($autoload =~ /^w/) {
+ if ($CPAN::META->has_inst('CPAN::WAIT')) {
+ CPAN::WAIT->$autoload(@_);
+ } else {
+ $CPAN::Frontend->mywarn(qq{
+Commands starting with "w" require CPAN::WAIT to be installed.
+Please consider installing CPAN::WAIT to use the fulltext index.
+For this you just need to type
+ install CPAN::WAIT
+});
+ }
+ } else {
+ my $ok = CPAN::Shell->try_dot_al($AUTOLOAD);
+ if ($ok) {
+ goto &$AUTOLOAD;
+# } else {
+# $CPAN::Frontend->mywarn("Could not autoload $autoload");
+ }
+ $CPAN::Frontend->mywarn(qq{Unknown command '$autoload'. }.
+ qq{Type ? for help.
+});
+ }
+}
+
+#-> CPAN::Shell::try_dot_al
+sub try_dot_al {
+ my($class,$autoload) = @_;
+ return unless $CPAN::Try_autoload;
+ # I don't see how to re-use that from the AutoLoader...
+ my($name,$ok);
+ # Braces used to preserve $1 et al.
+ {
+ my ($pkg,$func) = $autoload =~ /(.*)::([^:]+)$/;
+ $pkg =~ s|::|/|g;
+ if (defined($name=$INC{"$pkg.pm"}))
+ {
+ $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|;
+ $name = undef unless (-r $name);
+ }
+ unless (defined $name)
+ {
+ $name = "auto/$autoload.al";
+ $name =~ s|::|/|g;
+ }
+ }
+ my $save = $@;
+ eval {local $SIG{__DIE__};require $name};
+ if ($@) {
+ if (substr($autoload,-9) eq '::DESTROY') {
+ *$autoload = sub {};
+ $ok = 1;
+ } else {
+ if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
+ eval {local $SIG{__DIE__};require $name};
+ }
+ if ($@){
+ $@ =~ s/ at .*\n//;
+ Carp::croak $@;
+ } else {
+ $ok = 1;
+ }
+ }
+ } else {
+ $ok = 1;
+ }
+ $@ = $save;
+# my $lm = Carp::longmess();
+# warn "ok[$ok] autoload[$autoload] longmess[$lm]"; # debug
+ return $ok;
+}
+
+#### autoloader is experimental
+#### to try it we have to set $Try_autoload and uncomment
+#### the use statement and uncomment the __END__ below
+#### You also need AutoSplit 1.01 available. MakeMaker will
+#### then build CPAN with all the AutoLoad stuff.
+# use AutoLoader;
+# $Try_autoload = 1;
+
+if ($CPAN::Try_autoload) {
+ my $p;
+ for $p (qw(
+ CPAN::Author CPAN::Bundle CPAN::CacheMgr CPAN::Complete
+ CPAN::Config CPAN::Debug CPAN::Distribution CPAN::FTP
+ CPAN::FTP::netrc CPAN::Index CPAN::InfoObj CPAN::Module
+ )) {
+ *{"$p\::AUTOLOAD"} = \&AutoLoader::AUTOLOAD;
+ }
+}
+
+package CPAN::Tarzip;
+use vars qw($AUTOLOAD @ISA);
+@CPAN::Tarzip::ISA = qw(CPAN::Debug);
+
+package CPAN::Queue;
+# currently only used to determine if we should or shouldn't announce
+# the availability of a new CPAN module
+sub new {
+ my($class,$mod) = @_;
+ # warn "Queue object for mod[$mod]";
+ bless {mod => $mod}, $class;
+}
+
+package CPAN;
+
+$META ||= CPAN->new; # In case we reeval ourselves we
+ # need a ||
+
+# Do this after you have set up the whole inheritance
+CPAN::Config->load unless defined $CPAN::No_Config_is_ok;
+
+1;
+
+# __END__ # uncomment this and AutoSplit version 1.01 will split it
+
+#-> sub CPAN::autobundle ;
+sub autobundle;
+#-> sub CPAN::bundle ;
+sub bundle;
+#-> sub CPAN::expand ;
+sub expand;
+#-> sub CPAN::force ;
+sub force;
+#-> sub CPAN::install ;
+sub install;
+#-> sub CPAN::make ;
+sub make;
+#-> sub CPAN::clean ;
+sub clean;
+#-> sub CPAN::test ;
+sub test;
+
+#-> sub CPAN::all ;
+sub all {
+ my($mgr,$class) = @_;
+ CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
+ CPAN::Index->reload;
+ values %{ $META->{$class} };
+}
+
+# Called by shell, not in batch mode. Not clean XXX
+#-> sub CPAN::checklock ;
+sub checklock {
+ my($self) = @_;
+ my $lockfile = MM->catfile($CPAN::Config->{cpan_home},".lock");
+ if (-f $lockfile && -M _ > 0) {
+ my $fh = FileHandle->new($lockfile);
+ my $other = <$fh>;
+ $fh->close;
+ if (defined $other && $other) {
+ chomp $other;
+ return if $$==$other; # should never happen
+ $CPAN::Frontend->mywarn(
+ qq{
+There seems to be running another CPAN process ($other). Contacting...
+});
+ if (kill 0, $other) {
+ $CPAN::Frontend->mydie(qq{Other job is running.
+You may want to kill it and delete the lockfile, maybe. On UNIX try:
+ kill $other
+ rm $lockfile
+});
+ } elsif (-w $lockfile) {
+ my($ans) =
+ ExtUtils::MakeMaker::prompt
+ (qq{Other job not responding. Shall I overwrite }.
+ qq{the lockfile? (Y/N)},"y");
+ $CPAN::Frontend->myexit("Ok, bye\n")
+ unless $ans =~ /^y/i;
+ } else {
+ Carp::croak(
+ qq{Lockfile $lockfile not writeable by you. }.
+ qq{Cannot proceed.\n}.
+ qq{ On UNIX try:\n}.
+ qq{ rm $lockfile\n}.
+ qq{ and then rerun us.\n}
+ );
+ }
+ }
+ }
+ File::Path::mkpath($CPAN::Config->{cpan_home});
+ my $fh;
+ unless ($fh = FileHandle->new(">$lockfile")) {
+ if ($! =~ /Permission/) {
+ my $incc = $INC{'CPAN/Config.pm'};
+ my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
+ $CPAN::Frontend->myprint(qq{
+
+Your configuration suggests that CPAN.pm should use a working
+directory of
+ $CPAN::Config->{cpan_home}
+Unfortunately we could not create the lock file
+ $lockfile
+due to permission problems.
+
+Please make sure that the configuration variable
+ \$CPAN::Config->{cpan_home}
+points to a directory where you can write a .lock file. You can set
+this variable in either
+ $incc
+or
+ $myincc
+
+});
+ }
+ $CPAN::Frontend->mydie("Could not open >$lockfile: $!");
+ }
+ $fh->print($$, "\n");
+ $self->{LOCK} = $lockfile;
+ $fh->close;
+ $SIG{'TERM'} = sub {
+ &cleanup;
+ $CPAN::Frontend->mydie("Got SIGTERM, leaving");
+ };
+ $SIG{'INT'} = sub {
+ # no blocks!!!
+ &cleanup if $Signal;
+ $CPAN::Frontend->mydie("Got another SIGINT") if $Signal;
+ print "Caught SIGINT\n";
+ $Signal++;
+ };
+ $SIG{'__DIE__'} = \&cleanup;
+ $self->debug("Signal handler set.") if $CPAN::DEBUG;
+}
+
+#-> sub CPAN::DESTROY ;
+sub DESTROY {
+ &cleanup; # need an eval?
+}
+
+#-> sub CPAN::cwd ;
+sub cwd {Cwd::cwd();}
+
+#-> sub CPAN::getcwd ;
+sub getcwd {Cwd::getcwd();}
+
+#-> sub CPAN::exists ;
+sub exists {
+ my($mgr,$class,$id) = @_;
+ CPAN::Index->reload;
+ ### Carp::croak "exists called without class argument" unless $class;
+ $id ||= "";
+ exists $META->{$class}{$id};
+}
+
+#-> sub CPAN::delete ;
+sub delete {
+ my($mgr,$class,$id) = @_;
+ delete $META->{$class}{$id};
+}
+
+#-> sub CPAN::has_inst
+sub has_inst {
+ my($self,$mod,$message) = @_;
+ Carp::croak("CPAN->has_inst() called without an argument")
+ unless defined $mod;
+ if (defined $message && $message eq "no") {
+ $Dontload{$mod}||=1;
+ return 0;
+ } elsif (exists $Dontload{$mod}) {
+ return 0;
+ }
+ my $file = $mod;
+ my $obj;
+ $file =~ s|::|/|g;
+ $file =~ s|/|\\|g if $^O eq 'MSWin32';
+ $file .= ".pm";
+ if ($INC{$file}) {
+# warn "$file in %INC"; #debug
+ return 1;
+ } elsif (eval { require $file }) {
+ # eval is good: if we haven't yet read the database it's
+ # perfect and if we have installed the module in the meantime,
+ # it tries again. The second require is only a NOOP returning
+ # 1 if we had success, otherwise it's retrying
+ $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n");
+ if ($mod eq "CPAN::WAIT") {
+ push @CPAN::Shell::ISA, CPAN::WAIT;
+ }
+ return 1;
+ } elsif ($mod eq "Net::FTP") {
+ warn qq{
+ Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
+ if you just type
+ install Bundle::libnet
+
+};
+ sleep 2;
+ } elsif ($mod eq "MD5"){
+ $CPAN::Frontend->myprint(qq{
+ CPAN: MD5 security checks disabled because MD5 not installed.
+ Please consider installing the MD5 module.
+
+});
+ sleep 2;
+ }
+ return 0;
+}
+
+#-> sub CPAN::instance ;
+sub instance {
+ my($mgr,$class,$id) = @_;
+ CPAN::Index->reload;
+ $id ||= "";
+ $META->{$class}{$id} ||= $class->new(ID => $id );
+}
+
+#-> sub CPAN::new ;
+sub new {
+ bless {}, shift;
+}
+
+#-> sub CPAN::cleanup ;
+sub cleanup {
+ local $SIG{__DIE__} = '';
+ my $i = 0; my $ineval = 0; my $sub;
+ while ((undef,undef,undef,$sub) = caller(++$i)) {
+ $ineval = 1, last if $sub eq '(eval)';
+ }
+ return if $ineval && !$End;
+ return unless defined $META->{'LOCK'};
+ return unless -f $META->{'LOCK'};
+ unlink $META->{'LOCK'};
+ $CPAN::Frontend->mywarn("Lockfile removed.\n");
+}
+
+package CPAN::CacheMgr;
+
+#-> sub CPAN::CacheMgr::as_string ;
+sub as_string {
+ eval { require Data::Dumper };
+ if ($@) {
+ return shift->SUPER::as_string;
+ } else {
+ return Data::Dumper::Dumper(shift);
+ }
+}
+
+#-> sub CPAN::CacheMgr::cachesize ;
+sub cachesize {
+ shift->{DU};
+}
+
+sub tidyup {
+ my($self) = @_;
+ return unless -d $self->{ID};
+ while ($self->{DU} > $self->{'MAX'} ) {
+ my($toremove) = shift @{$self->{FIFO}};
+ $CPAN::Frontend->myprint(sprintf(
+ "Deleting from cache".
+ ": $toremove (%.1f>%.1f MB)\n",
+ $self->{DU}, $self->{'MAX'})
+ );
+ return if $CPAN::Signal;
+ $self->force_clean_cache($toremove);
+ return if $CPAN::Signal;
+ }
+}
+
+#-> sub CPAN::CacheMgr::dir ;
+sub dir {
+ shift->{ID};
+}
+
+#-> sub CPAN::CacheMgr::entries ;
+sub entries {
+ my($self,$dir) = @_;
+ return unless defined $dir;
+ $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
+ $dir ||= $self->{ID};
+ my $getcwd;
+ $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
+ my($cwd) = CPAN->$getcwd();
+ chdir $dir or Carp::croak("Can't chdir to $dir: $!");
+ my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir $dir: $!");
+ my(@entries);
+ for ($dh->read) {
+ next if $_ eq "." || $_ eq "..";
+ if (-f $_) {
+ push @entries, MM->catfile($dir,$_);
+ } elsif (-d _) {
+ push @entries, MM->catdir($dir,$_);
+ } else {
+ $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
+ }
+ }
+ chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
+ sort { -M $b <=> -M $a} @entries;
+}
+
+#-> sub CPAN::CacheMgr::disk_usage ;
+sub disk_usage {
+ my($self,$dir) = @_;
+ return if exists $self->{SIZE}{$dir};
+ return if $CPAN::Signal;
+ my($Du) = 0;
+ find(
+ sub {
+ $File::Find::prune++ if $CPAN::Signal;
+ return if -l $_;
+ $Du += -s _;
+ },
+ $dir
+ );
+ return if $CPAN::Signal;
+ $self->{SIZE}{$dir} = $Du/1024/1024;
+ push @{$self->{FIFO}}, $dir;
+ $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
+ $self->{DU} += $Du/1024/1024;
+ $self->{DU};
+}
+
+#-> sub CPAN::CacheMgr::force_clean_cache ;
+sub force_clean_cache {
+ my($self,$dir) = @_;
+ return unless -e $dir;
+ $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
+ if $CPAN::DEBUG;
+ File::Path::rmtree($dir);
+ $self->{DU} -= $self->{SIZE}{$dir};
+ delete $self->{SIZE}{$dir};
+}
+
+#-> sub CPAN::CacheMgr::new ;
+sub new {
+ my $class = shift;
+ my $time = time;
+ my($debug,$t2);
+ $debug = "";
+ my $self = {
+ ID => $CPAN::Config->{'build_dir'},
+ MAX => $CPAN::Config->{'build_cache'},
+ DU => 0
+ };
+ File::Path::mkpath($self->{ID});
+ my $dh = DirHandle->new($self->{ID});
+ bless $self, $class;
+ my $e;
+ $CPAN::Frontend->myprint(
+ sprintf("Scanning cache %s for sizes\n",
+ $self->{ID}));
+ for $e ($self->entries($self->{ID})) {
+ next if $e eq ".." || $e eq ".";
+ $self->disk_usage($e);
+ return if $CPAN::Signal;
+ }
+ $self->tidyup;
+ $t2 = time;
+ $debug .= "timing of CacheMgr->new: ".($t2 - $time);
+ $time = $t2;
+ CPAN->debug($debug) if $CPAN::DEBUG;
+ $self;
+}
+
+package CPAN::Debug;
+
+#-> sub CPAN::Debug::debug ;
+sub debug {
+ my($self,$arg) = @_;
+ my($caller,$func,$line,@rest) = caller(1); # caller(0) eg
+ # Complete, caller(1)
+ # eg readline
+ ($caller) = caller(0);
+ $caller =~ s/.*:://;
+ $arg = "" unless defined $arg;
+ my $rest = join "|", map { defined $_ ? $_ : "UNDEF" } @rest;
+ if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
+ if ($arg and ref $arg) {
+ eval { require Data::Dumper };
+ if ($@) {
+ $CPAN::Frontend->myprint($arg->as_string);
+ } else {
+ $CPAN::Frontend->myprint(Data::Dumper::Dumper($arg));
+ }
+ } else {
+ $CPAN::Frontend->myprint("Debug($caller:$func,$line,[$rest]): $arg\n");
+ }
+ }
+}
+
+package CPAN::Config;
+
+#-> sub CPAN::Config::edit ;
+sub edit {
+ my($class,@args) = @_;
+ return unless @args;
+ CPAN->debug("class[$class]args[".join(" | ",@args)."]");
+ my($o,$str,$func,$args,$key_exists);
+ $o = shift @args;
+ if($can{$o}) {
+ $class->$o(@args);
+ return 1;
+ } else {
+ if (ref($CPAN::Config->{$o}) eq ARRAY) {
+ $func = shift @args;
+ $func ||= "";
+ # Let's avoid eval, it's easier to comprehend without.
+ if ($func eq "push") {
+ push @{$CPAN::Config->{$o}}, @args;
+ } elsif ($func eq "pop") {
+ pop @{$CPAN::Config->{$o}};
+ } elsif ($func eq "shift") {
+ shift @{$CPAN::Config->{$o}};
+ } elsif ($func eq "unshift") {
+ unshift @{$CPAN::Config->{$o}}, @args;
+ } elsif ($func eq "splice") {
+ splice @{$CPAN::Config->{$o}}, @args;
+ } elsif (@args) {
+ $CPAN::Config->{$o} = [@args];
+ } else {
+ $CPAN::Frontend->myprint(
+ join "",
+ " $o ",
+ ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}),
+ "\n"
+ );
+ }
+ } else {
+ $CPAN::Config->{$o} = $args[0] if defined $args[0];
+ $CPAN::Frontend->myprint(" $o " .
+ (defined $CPAN::Config->{$o} ?
+ $CPAN::Config->{$o} : "UNDEFINED"));
+ }
+ }
+}
+
+#-> sub CPAN::Config::commit ;
+sub commit {
+ my($self,$configpm) = @_;
+ unless (defined $configpm){
+ $configpm ||= $INC{"CPAN/MyConfig.pm"};
+ $configpm ||= $INC{"CPAN/Config.pm"};
+ $configpm || Carp::confess(qq{
+CPAN::Config::commit called without an argument.
+Please specify a filename where to save the configuration or try
+"o conf init" to have an interactive course through configing.
+});
+ }
+ my($mode);
+ if (-f $configpm) {
+ $mode = (stat $configpm)[2];
+ if ($mode && ! -w _) {
+ Carp::confess("$configpm is not writable");
+ }
+ }
+
+ my $msg = <<EOF unless $configpm =~ /MyConfig/;
+
+# This is CPAN.pm's systemwide configuration file. This file provides
+# defaults for users, and the values can be changed in a per-user
+# configuration file. The user-config file is being looked for as
+# ~/.cpan/CPAN/MyConfig.pm.
+
+EOF
+ $msg ||= "\n";
+ my($fh) = FileHandle->new;
+ open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
+ $fh->print(qq[$msg\$CPAN::Config = \{\n]);
+ foreach (sort keys %$CPAN::Config) {
+ $fh->print(
+ " '$_' => ",
+ ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}),
+ ",\n"
+ );
+ }
+
+ $fh->print("};\n1;\n__END__\n");
+ close $fh;
+
+ #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
+ #chmod $mode, $configpm;
+###why was that so? $self->defaults;
+ $CPAN::Frontend->myprint("commit: wrote $configpm\n");
+ 1;
+}
+
+*default = \&defaults;
+#-> sub CPAN::Config::defaults ;
+sub defaults {
+ my($self) = @_;
+ $self->unload;
+ $self->load;
+ 1;
+}
+
+sub init {
+ my($self) = @_;
+ undef $CPAN::Config->{'inhibit_startup_message'}; # lazy trick to
+ # have the least
+ # important
+ # variable
+ # undefined
+ $self->load;
+ 1;
+}
+
+#-> sub CPAN::Config::load ;
+sub load {
+ my($self) = shift;
+ my(@miss);
+ eval {require CPAN::Config;}; # We eval because of some
+ # MakeMaker problems
+ unless ($dot_cpan++){
+ unshift @INC, MM->catdir($ENV{HOME},".cpan");
+ eval {require CPAN::MyConfig;}; # where you can override
+ # system wide settings
+ shift @INC;
+ }
+ return unless @miss = $self->not_loaded;
+ # XXX better check for arrayrefs too
+ require CPAN::FirstTime;
+ my($configpm,$fh,$redo,$theycalled);
+ $redo ||= "";
+ $theycalled++ if @miss==1 && $miss[0] eq 'inhibit_startup_message';
+ if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
+ $configpm = $INC{"CPAN/Config.pm"};
+ $redo++;
+ } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
+ $configpm = $INC{"CPAN/MyConfig.pm"};
+ $redo++;
+ } else {
+ my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
+ my($configpmdir) = MM->catdir($path_to_cpan,"CPAN");
+ my($configpmtest) = MM->catfile($configpmdir,"Config.pm");
+ if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
+ if (-w $configpmtest) {
+ $configpm = $configpmtest;
+ } elsif (-w $configpmdir) {
+ #_#_# following code dumped core on me with 5.003_11, a.k.
+ unlink "$configpmtest.bak" if -f "$configpmtest.bak";
+ rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
+ my $fh = FileHandle->new;
+ if ($fh->open(">$configpmtest")) {
+ $fh->print("1;\n");
+ $configpm = $configpmtest;
+ } else {
+ # Should never happen
+ Carp::confess("Cannot open >$configpmtest");
+ }
+ }
+ }
+ unless ($configpm) {
+ $configpmdir = MM->catdir($ENV{HOME},".cpan","CPAN");
+ File::Path::mkpath($configpmdir);
+ $configpmtest = MM->catfile($configpmdir,"MyConfig.pm");
+ if (-w $configpmtest) {
+ $configpm = $configpmtest;
+ } elsif (-w $configpmdir) {
+ #_#_# following code dumped core on me with 5.003_11, a.k.
+ my $fh = FileHandle->new;
+ if ($fh->open(">$configpmtest")) {
+ $fh->print("1;\n");
+ $configpm = $configpmtest;
+ } else {
+ # Should never happen
+ Carp::confess("Cannot open >$configpmtest");
+ }
+ } else {
+ Carp::confess(qq{WARNING: CPAN.pm is unable to }.
+ qq{create a configuration file.});
+ }
+ }
+ }
+ local($") = ", ";
+ $CPAN::Frontend->myprint(qq{
+We have to reconfigure CPAN.pm due to following uninitialized parameters:
+
+@miss
+}) if $redo && ! $theycalled;
+ $CPAN::Frontend->myprint(qq{
+$configpm initialized.
+});
+ sleep 2;
+ CPAN::FirstTime::init($configpm);
+}
+
+#-> sub CPAN::Config::not_loaded ;
+sub not_loaded {
+ my(@miss);
+ for (qw(
+ cpan_home keep_source_where build_dir build_cache index_expire
+ gzip tar unzip make pager makepl_arg make_arg make_install_arg
+ urllist inhibit_startup_message ftp_proxy http_proxy no_proxy
+ )) {
+ push @miss, $_ unless defined $CPAN::Config->{$_};
+ }
+ return @miss;
+}
+
+#-> sub CPAN::Config::unload ;
+sub unload {
+ delete $INC{'CPAN/MyConfig.pm'};
+ delete $INC{'CPAN/Config.pm'};
+}
+
+*h = \&help;
+#-> sub CPAN::Config::help ;
+sub help {
+ $CPAN::Frontend->myprint(qq{
+Known options:
+ defaults reload default config values from disk
+ commit commit session changes to disk
+ init go through a dialog to set all parameters
+
+You may edit key values in the follow fashion:
+
+ o conf build_cache 15
+
+ o conf build_dir "/foo/bar"
+
+ o conf urllist shift
+
+ o conf urllist unshift ftp://ftp.foo.bar/
+
+});
+ undef; #don't reprint CPAN::Config
+}
+
+#-> sub CPAN::Config::cpl ;
+sub cpl {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ my(@words) = split " ", substr($line,0,$pos+1);
+ if (
+ defined($words[2])
+ and
+ (
+ $words[2] =~ /list$/ && @words == 3
+ ||
+ $words[2] =~ /list$/ && @words == 4 && length($word)
+ )
+ ) {
+ return grep /^\Q$word\E/, qw(splice shift unshift pop push);
+ } elsif (@words >= 4) {
+ return ();
+ }
+ my(@o_conf) = (keys %CPAN::Config::can, keys %$CPAN::Config);
+ return grep /^\Q$word\E/, @o_conf;
+}
+
+package CPAN::Shell;
+
+#-> sub CPAN::Shell::h ;
+sub h {
+ my($class,$about) = @_;
+ if (defined $about) {
+ $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
+ } else {
+ $CPAN::Frontend->myprint(q{
+command arguments description
+a string authors
+b or display bundles
+d /regex/ info distributions
+m or about modules
+i none anything of above
+
+r as reinstall recommendations
+u above uninstalled distributions
+See manpage for autobundle, recompile, force, look, etc.
+
+make make
+test modules, make test (implies make)
+install dists, bundles, make install (implies test)
+clean "r" or "u" make clean
+readme display the README file
+
+reload index|cpan load most recent indices/CPAN.pm
+h or ? display this menu
+o various set and query options
+! perl-code eval a perl command
+q quit the shell subroutine
+});
+ }
+}
+
+*help = \&h;
+
+#-> sub CPAN::Shell::a ;
+sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));}
+#-> sub CPAN::Shell::b ;
+sub b {
+ my($self,@which) = @_;
+ CPAN->debug("which[@which]") if $CPAN::DEBUG;
+ my($incdir,$bdir,$dh);
+ foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
+ $bdir = MM->catdir($incdir,"Bundle");
+ if ($dh = DirHandle->new($bdir)) { # may fail
+ my($entry);
+ for $entry ($dh->read) {
+ next if -d MM->catdir($bdir,$entry);
+ next unless $entry =~ s/\.pm$//;
+ $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
+ }
+ }
+ }
+ $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
+}
+#-> sub CPAN::Shell::d ;
+sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
+#-> sub CPAN::Shell::m ;
+sub m { $CPAN::Frontend->myprint(shift->format_result('Module',@_));}
+
+#-> sub CPAN::Shell::i ;
+sub i {
+ my($self) = shift;
+ my(@args) = @_;
+ my(@type,$type,@m);
+ @type = qw/Author Bundle Distribution Module/;
+ @args = '/./' unless @args;
+ my(@result);
+ for $type (@type) {
+ push @result, $self->expand($type,@args);
+ }
+ my $result = @result == 1 ?
+ $result[0]->as_string :
+ join "", map {$_->as_glimpse} @result;
+ $result ||= "No objects found of any type for argument @args\n";
+ $CPAN::Frontend->myprint($result);
+}
+
+#-> sub CPAN::Shell::o ;
+sub o {
+ my($self,$o_type,@o_what) = @_;
+ $o_type ||= "";
+ CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
+ if ($o_type eq 'conf') {
+ shift @o_what if @o_what && $o_what[0] eq 'help';
+ if (!@o_what) {
+ my($k,$v);
+ $CPAN::Frontend->myprint("CPAN::Config options");
+ if (exists $INC{'CPAN/Config.pm'}) {
+ $CPAN::Frontend->myprint(" from $INC{'CPAN/Config.pm'}");
+ }
+ if (exists $INC{'CPAN/MyConfig.pm'}) {
+ $CPAN::Frontend->myprint(" and $INC{'CPAN/MyConfig.pm'}");
+ }
+ $CPAN::Frontend->myprint(":\n");
+ for $k (sort keys %CPAN::Config::can) {
+ $v = $CPAN::Config::can{$k};
+ $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
+ }
+ $CPAN::Frontend->myprint("\n");
+ for $k (sort keys %$CPAN::Config) {
+ $v = $CPAN::Config->{$k};
+ if (ref $v) {
+ $CPAN::Frontend->myprint(
+ join(
+ "",
+ sprintf(
+ " %-18s\n",
+ $k
+ ),
+ map {"\t$_\n"} @{$v}
+ )
+ );
+ } else {
+ $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
+ }
+ }
+ $CPAN::Frontend->myprint("\n");
+ } elsif (!CPAN::Config->edit(@o_what)) {
+ $CPAN::Frontend->myprint(qq[Type 'o conf' to view configuration edit options\n\n]);
+ }
+ } elsif ($o_type eq 'debug') {
+ my(%valid);
+ @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
+ if (@o_what) {
+ while (@o_what) {
+ my($what) = shift @o_what;
+ if ( exists $CPAN::DEBUG{$what} ) {
+ $CPAN::DEBUG |= $CPAN::DEBUG{$what};
+ } elsif ($what =~ /^\d/) {
+ $CPAN::DEBUG = $what;
+ } elsif (lc $what eq 'all') {
+ my($max) = 0;
+ for (values %CPAN::DEBUG) {
+ $max += $_;
+ }
+ $CPAN::DEBUG = $max;
+ } else {
+ my($known) = 0;
+ for (keys %CPAN::DEBUG) {
+ next unless lc($_) eq lc($what);
+ $CPAN::DEBUG |= $CPAN::DEBUG{$_};
+ $known = 1;
+ }
+ $CPAN::Frontend->myprint("unknown argument [$what]\n")
+ unless $known;
+ }
+ }
+ } else {
+ $CPAN::Frontend->myprint("Valid options for debug are ".
+ join(", ",sort(keys %CPAN::DEBUG), 'all').
+ qq{ or a number. Completion works on the options. }.
+ qq{Case is ignored.\n\n});
+ }
+ if ($CPAN::DEBUG) {
+ $CPAN::Frontend->myprint("Options set for debugging:\n");
+ my($k,$v);
+ for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
+ $v = $CPAN::DEBUG{$k};
+ $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG;
+ }
+ } else {
+ $CPAN::Frontend->myprint("Debugging turned off completely.\n");
+ }
+ } else {
+ $CPAN::Frontend->myprint(qq{
+Known options:
+ conf set or get configuration variables
+ debug set or get debugging options
+});
+ }
+}
+
+#-> sub CPAN::Shell::reload ;
+sub reload {
+ my($self,$command,@arg) = @_;
+ $command ||= "";
+ $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
+ if ($command =~ /cpan/i) {
+ CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
+ my $fh = FileHandle->new($INC{'CPAN.pm'});
+ local($/);
+ undef $/;
+ $redef = 0;
+ local($SIG{__WARN__})
+ = sub {
+ if ( $_[0] =~ /Subroutine \w+ redefined/ ) {
+ ++$redef;
+ local($|) = 1;
+ $CPAN::Frontend->myprint(".");
+ return;
+ }
+ warn @_;
+ };
+ eval <$fh>;
+ warn $@ if $@;
+ $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
+ } elsif ($command =~ /index/) {
+ CPAN::Index->force_reload;
+ } else {
+ $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file
+index re-reads the index files
+});
+ }
+}
+
+#-> sub CPAN::Shell::_binary_extensions ;
+sub _binary_extensions {
+ my($self) = shift @_;
+ my(@result,$module,%seen,%need,$headerdone);
+ my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz$};
+ for $module ($self->expand('Module','/./')) {
+ my $file = $module->cpan_file;
+ next if $file eq "N/A";
+ next if $file =~ /^Contact Author/;
+ next if $file =~ / $isaperl /xo;
+ next unless $module->xs_file;
+ local($|) = 1;
+ $CPAN::Frontend->myprint(".");
+ push @result, $module;
+ }
+# print join " | ", @result;
+ $CPAN::Frontend->myprint("\n");
+ return @result;
+}
+
+#-> sub CPAN::Shell::recompile ;
+sub recompile {
+ my($self) = shift @_;
+ my($module,@module,$cpan_file,%dist);
+ @module = $self->_binary_extensions();
+ for $module (@module){ # we force now and compile later, so we
+ # don't do it twice
+ $cpan_file = $module->cpan_file;
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->force;
+ $dist{$cpan_file}++;
+ }
+ for $cpan_file (sort keys %dist) {
+ $CPAN::Frontend->myprint(" CPAN: Recompiling $cpan_file\n\n");
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->install;
+ $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
+ # stop a package from recompiling,
+ # e.g. IO-1.12 when we have perl5.003_10
+ }
+}
+
+#-> sub CPAN::Shell::_u_r_common ;
+sub _u_r_common {
+ my($self) = shift @_;
+ my($what) = shift @_;
+ CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
+ Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
+ Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
+ my(@args) = @_;
+ @args = '/./' unless @args;
+ my(@result,$module,%seen,%need,$headerdone,
+ $version_undefs,$version_zeroes);
+ $version_undefs = $version_zeroes = 0;
+ my $sprintf = "%-25s %9s %9s %s\n";
+ for $module ($self->expand('Module',@args)) {
+ my $file = $module->cpan_file;
+ next unless defined $file; # ??
+ my($latest) = $module->cpan_version;
+ my($inst_file) = $module->inst_file;
+ my($have);
+ return if $CPAN::Signal;
+ if ($inst_file){
+ if ($what eq "a") {
+ $have = $module->inst_version;
+ } elsif ($what eq "r") {
+ $have = $module->inst_version;
+ local($^W) = 0;
+ if ($have eq "undef"){
+ $version_undefs++;
+ } elsif ($have == 0){
+ $version_zeroes++;
+ }
+ next if $have >= $latest;
+# to be pedantic we should probably say:
+# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
+# to catch the case where CPAN has a version 0 and we have a version undef
+ } elsif ($what eq "u") {
+ next;
+ }
+ } else {
+ if ($what eq "a") {
+ next;
+ } elsif ($what eq "r") {
+ next;
+ } elsif ($what eq "u") {
+ $have = "-";
+ }
+ }
+ return if $CPAN::Signal; # this is sometimes lengthy
+ $seen{$file} ||= 0;
+ if ($what eq "a") {
+ push @result, sprintf "%s %s\n", $module->id, $have;
+ } elsif ($what eq "r") {
+ push @result, $module->id;
+ next if $seen{$file}++;
+ } elsif ($what eq "u") {
+ push @result, $module->id;
+ next if $seen{$file}++;
+ next if $file =~ /^Contact/;
+ }
+ unless ($headerdone++){
+ $CPAN::Frontend->myprint("\n");
+ $CPAN::Frontend->myprint(sprintf(
+ $sprintf,
+ "Package namespace",
+ "installed",
+ "latest",
+ "in CPAN file"
+ ));
+ }
+ $latest = substr($latest,0,8) if length($latest) > 8;
+ $have = substr($have,0,8) if length($have) > 8;
+ $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file);
+ $need{$module->id}++;
+ }
+ unless (%need) {
+ if ($what eq "u") {
+ $CPAN::Frontend->myprint("No modules found for @args\n");
+ } elsif ($what eq "r") {
+ $CPAN::Frontend->myprint("All modules are up to date for @args\n");
+ }
+ }
+ if ($what eq "r") {
+ if ($version_zeroes) {
+ my $s_has = $version_zeroes > 1 ? "s have" : " has";
+ $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
+ qq{a version number of 0\n});
+ }
+ if ($version_undefs) {
+ my $s_has = $version_undefs > 1 ? "s have" : " has";
+ $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
+ qq{parseable version number\n});
+ }
+ }
+ @result;
+}
+
+#-> sub CPAN::Shell::r ;
+sub r {
+ shift->_u_r_common("r",@_);
+}
+
+#-> sub CPAN::Shell::u ;
+sub u {
+ shift->_u_r_common("u",@_);
+}
+
+#-> sub CPAN::Shell::autobundle ;
+sub autobundle {
+ my($self) = shift;
+ my(@bundle) = $self->_u_r_common("a",@_);
+ my($todir) = MM->catdir($CPAN::Config->{'cpan_home'},"Bundle");
+ File::Path::mkpath($todir);
+ unless (-d $todir) {
+ $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
+ return;
+ }
+ my($y,$m,$d) = (localtime)[5,4,3];
+ $y+=1900;
+ $m++;
+ my($c) = 0;
+ my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
+ my($to) = MM->catfile($todir,"$me.pm");
+ while (-f $to) {
+ $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
+ $to = MM->catfile($todir,"$me.pm");
+ }
+ my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
+ $fh->print(
+ "package Bundle::$me;\n\n",
+ "\$VERSION = '0.01';\n\n",
+ "1;\n\n",
+ "__END__\n\n",
+ "=head1 NAME\n\n",
+ "Bundle::$me - Snapshot of installation on ",
+ $Config::Config{'myhostname'},
+ " on ",
+ scalar(localtime),
+ "\n\n=head1 SYNOPSIS\n\n",
+ "perl -MCPAN -e 'install Bundle::$me'\n\n",
+ "=head1 CONTENTS\n\n",
+ join("\n", @bundle),
+ "\n\n=head1 CONFIGURATION\n\n",
+ Config->myconfig,
+ "\n\n=head1 AUTHOR\n\n",
+ "This Bundle has been generated automatically ",
+ "by the autobundle routine in CPAN.pm.\n",
+ );
+ $fh->close;
+ $CPAN::Frontend->myprint("\nWrote bundle file
+ $to\n\n");
+}
+
+#-> sub CPAN::Shell::expand ;
+sub expand {
+ shift;
+ my($type,@args) = @_;
+ my($arg,@m);
+ for $arg (@args) {
+ my $regex;
+ if ($arg =~ m|^/(.*)/$|) {
+ $regex = $1;
+ }
+ my $class = "CPAN::$type";
+ my $obj;
+ if (defined $regex) {
+ for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all($class)) {
+ push @m, $obj
+ if
+ $obj->id =~ /$regex/i
+ or
+ (
+ (
+ $] < 5.00303 ### provide sort of compatibility with 5.003
+ ||
+ $obj->can('name')
+ )
+ &&
+ $obj->name =~ /$regex/i
+ );
+ }
+ } else {
+ my($xarg) = $arg;
+ if ( $type eq 'Bundle' ) {
+ $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
+ }
+ if ($CPAN::META->exists($class,$xarg)) {
+ $obj = $CPAN::META->instance($class,$xarg);
+ } elsif ($CPAN::META->exists($class,$arg)) {
+ $obj = $CPAN::META->instance($class,$arg);
+ } else {
+ next;
+ }
+ push @m, $obj;
+ }
+ }
+ return wantarray ? @m : $m[0];
+}
+
+#-> sub CPAN::Shell::format_result ;
+sub format_result {
+ my($self) = shift;
+ my($type,@args) = @_;
+ @args = '/./' unless @args;
+ my(@result) = $self->expand($type,@args);
+ my $result = @result == 1 ?
+ $result[0]->as_string :
+ join "", map {$_->as_glimpse} @result;
+ $result ||= "No objects of type $type found for argument @args\n";
+ $result;
+}
+
+# The only reason for this method is currently to have a reliable
+# debugging utility that reveals which output is going through which
+# channel. No, I don't like the colors ;-)
+sub print_ornamented {
+ my($self,$what,$ornament) = @_;
+ my $longest = 0;
+ my $ornamenting = 0; # turn the colors on
+
+ if ($ornamenting) {
+ unless (defined &color) {
+ if ($CPAN::META->has_inst("Term::ANSIColor")) {
+ import Term::ANSIColor "color";
+ } else {
+ *color = sub { return "" };
+ }
+ }
+ my $line;
+ for $line (split /\n/, $what) {
+ $longest = length($line) if length($line) > $longest;
+ }
+ my $sprintf = "%-" . $longest . "s";
+ while ($what){
+ $what =~ s/(.*\n?)//m;
+ my $line = $1;
+ last unless $line;
+ my($nl) = chomp $line ? "\n" : "";
+ # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
+ print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
+ }
+ } else {
+ print $what;
+ }
+}
+
+sub myprint {
+ my($self,$what) = @_;
+ $self->print_ornamented($what, 'bold blue on_yellow');
+}
+
+sub myexit {
+ my($self,$what) = @_;
+ $self->myprint($what);
+ exit;
+}
+
+sub mywarn {
+ my($self,$what) = @_;
+ $self->print_ornamented($what, 'bold red on_yellow');
+}
+
+sub myconfess {
+ my($self,$what) = @_;
+ $self->print_ornamented($what, 'bold red on_white');
+ Carp::confess "died";
+}
+
+sub mydie {
+ my($self,$what) = @_;
+ $self->print_ornamented($what, 'bold red on_white');
+ die "\n";
+}
+
+#-> sub CPAN::Shell::rematein ;
+# RE-adme||MA-ke||TE-st||IN-stall
+sub rematein {
+ shift;
+ my($meth,@some) = @_;
+ my $pragma = "";
+ if ($meth eq 'force') {
+ $pragma = $meth;
+ $meth = shift @some;
+ }
+ CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
+ my($s,@s);
+ foreach $s (@some) {
+ my $obj;
+ if (ref $s) {
+ $obj = $s;
+ } elsif ($s =~ m|/|) { # looks like a file
+ $obj = $CPAN::META->instance('CPAN::Distribution',$s);
+ } elsif ($s =~ m|^Bundle::|) {
+ $CPAN::META->{'CPAN::Queue'}{$s} ||= CPAN::Queue->new($s);
+ $obj = $CPAN::META->instance('CPAN::Bundle',$s);
+ } else {
+ $CPAN::META->{'CPAN::Queue'}{$s} ||= CPAN::Queue->new($s);
+ $obj = $CPAN::META->instance('CPAN::Module',$s)
+ if $CPAN::META->exists('CPAN::Module',$s);
+ }
+ if (ref $obj) {
+ CPAN->debug(
+ qq{pragma[$pragma] meth[$meth] obj[$obj] as_string\[}.
+ $obj->as_string.
+ qq{\]}
+ ) if $CPAN::DEBUG;
+ $obj->$pragma()
+ if
+ $pragma
+ &&
+ ($] < 5.00303 || $obj->can($pragma)); ###
+ ### compatibility
+ ### with
+ ### 5.003
+ if ($]>=5.00303 && $obj->can('called_for')) {
+ $obj->called_for($s);
+ }
+ $obj->$meth();
+ } elsif ($CPAN::META->exists('CPAN::Author',$s)) {
+ $obj = $CPAN::META->instance('CPAN::Author',$s);
+ $CPAN::Frontend->myprint(
+ join "",
+ "Don't be silly, you can't $meth ",
+ $obj->fullname,
+ " ;-)\n"
+ );
+ } else {
+ $CPAN::Frontend->myprint(qq{Warning: Cannot $meth $s, don\'t know what it is.
+Try the command
+
+ i /$s/
+
+to find objects with similar identifiers.
+});
+ }
+ }
+}
+
+#-> sub CPAN::Shell::force ;
+sub force { shift->rematein('force',@_); }
+#-> sub CPAN::Shell::get ;
+sub get { shift->rematein('get',@_); }
+#-> sub CPAN::Shell::readme ;
+sub readme { shift->rematein('readme',@_); }
+#-> sub CPAN::Shell::make ;
+sub make { shift->rematein('make',@_); }
+#-> sub CPAN::Shell::test ;
+sub test { shift->rematein('test',@_); }
+#-> sub CPAN::Shell::install ;
+sub install { shift->rematein('install',@_); }
+#-> sub CPAN::Shell::clean ;
+sub clean { shift->rematein('clean',@_); }
+#-> sub CPAN::Shell::look ;
+sub look { shift->rematein('look',@_); }
+
+package CPAN::FTP;
+
+#-> sub CPAN::FTP::ftp_get ;
+sub ftp_get {
+ my($class,$host,$dir,$file,$target) = @_;
+ $class->debug(
+ qq[Going to fetch file [$file] from dir [$dir]
+ on host [$host] as local [$target]\n]
+ ) if $CPAN::DEBUG;
+ my $ftp = Net::FTP->new($host);
+ return 0 unless defined $ftp;
+ $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
+ $class->debug(qq[Going to ->login("anonymous","$Config::Config{'cf_email'}")\n]);
+ unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
+ warn "Couldn't login on $host";
+ return;
+ }
+ unless ( $ftp->cwd($dir) ){
+ warn "Couldn't cwd $dir";
+ return;
+ }
+ $ftp->binary;
+ $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
+ unless ( $ftp->get($file,$target) ){
+ warn "Couldn't fetch $file from $host\n";
+ return;
+ }
+ $ftp->quit; # it's ok if this fails
+ return 1;
+}
+
+# If more accuracy is wanted/needed, Chris Leach sent me this patch...
+
+ # leach,> *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
+ # leach,> --- /tmp/cp Wed Sep 24 13:26:40 1997
+ # leach,> ***************
+ # leach,> *** 1562,1567 ****
+ # leach,> --- 1562,1580 ----
+ # leach,> return 1 if substr($url,0,4) eq "file";
+ # leach,> return 1 unless $url =~ m|://([^/]+)|;
+ # leach,> my $host = $1;
+ # leach,> + my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
+ # leach,> + if ($proxy) {
+ # leach,> + $proxy =~ m|://([^/:]+)|;
+ # leach,> + $proxy = $1;
+ # leach,> + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
+ # leach,> + if ($noproxy) {
+ # leach,> + if ($host !~ /$noproxy$/) {
+ # leach,> + $host = $proxy;
+ # leach,> + }
+ # leach,> + } else {
+ # leach,> + $host = $proxy;
+ # leach,> + }
+ # leach,> + }
+ # leach,> require Net::Ping;
+ # leach,> return 1 unless $Net::Ping::VERSION >= 2;
+ # leach,> my $p;
+
+
+# this is quite optimistic and returns one on several occasions where
+# inappropriate. But this does no harm. It would do harm if we were
+# too pessimistic (as I was before the http_proxy
+sub is_reachable {
+ my($self,$url) = @_;
+ return 1; # we can't simply roll our own, firewalls may break ping
+ return 0 unless $url;
+ return 1 if substr($url,0,4) eq "file";
+ return 1 unless $url =~ m|^(\w+)://([^/]+)|;
+ my $proxytype = $1 . "_proxy"; # ftp_proxy or http_proxy
+ my $host = $2;
+ return 1 if $CPAN::Config->{$proxytype} || $ENV{$proxytype};
+ require Net::Ping;
+ return 1 unless $Net::Ping::VERSION >= 2;
+ my $p;
+ # 1.3101 had it different: only if the first eval raised an
+ # exception we tried it with TCP. Now we are happy if icmp wins
+ # the order and return, we don't even check for $@. Thanks to
+ # thayer@uis.edu for the suggestion.
+ eval {$p = Net::Ping->new("icmp");};
+ return 1 if $p && ref($p) && $p->ping($host, 10);
+ eval {$p = Net::Ping->new("tcp");};
+ $CPAN::Frontend->mydie($@) if $@;
+ return $p->ping($host, 10);
+}
+
+#-> sub CPAN::FTP::localize ;
+# sorry for the ugly code here, I'll clean it up as soon as Net::FTP
+# is in the core
+sub localize {
+ my($self,$file,$aslocal,$force) = @_;
+ $force ||= 0;
+ Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
+ unless defined $aslocal;
+ $self->debug("file[$file] aslocal[$aslocal] force[$force]")
+ if $CPAN::DEBUG;
+
+ return $aslocal if -f $aslocal && -r _ && !($force & 1);
+ my($restore) = 0;
+ if (-f $aslocal){
+ rename $aslocal, "$aslocal.bak";
+ $restore++;
+ }
+
+ my($aslocal_dir) = File::Basename::dirname($aslocal);
+ File::Path::mkpath($aslocal_dir);
+ $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
+ qq{directory "$aslocal_dir".
+ I\'ll continue, but if you encounter problems, they may be due
+ to insufficient permissions.\n}) unless -w $aslocal_dir;
+
+ # Inheritance is not easier to manage than a few if/else branches
+ if ($CPAN::META->has_inst('LWP')) {
+ require LWP::UserAgent;
+ unless ($Ua) {
+ $Ua = LWP::UserAgent->new;
+ my($var);
+ $Ua->proxy('ftp', $var)
+ if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
+ $Ua->proxy('http', $var)
+ if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
+ $Ua->no_proxy($var)
+ if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
+ }
+ }
+
+ # Try the list of urls for each single object. We keep a record
+ # where we did get a file from
+ my(@reordered,$last);
+ $CPAN::Config->{urllist} ||= [];
+ $last = $#{$CPAN::Config->{urllist}};
+ if ($force & 2) { # local cpans probably out of date, don't reorder
+ @reordered = (0..$last);
+ } else {
+ @reordered =
+ sort {
+ (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
+ <=>
+ (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
+ or
+ defined($Thesite)
+ and
+ ($b == $Thesite)
+ <=>
+ ($a == $Thesite)
+ } 0..$last;
+
+# ((grep { substr($CPAN::Config->{urllist}[$_],0,4)
+# eq "file" } 0..$last),
+# (grep { substr($CPAN::Config->{urllist}[$_],0,4)
+# ne "file" } 0..$last));
+ }
+ my($level,@levels);
+ if ($Themethod) {
+ @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
+ } else {
+ @levels = qw/easy hard hardest/;
+ }
+ for $level (@levels) {
+ my $method = "host$level";
+ my @host_seq = $level eq "easy" ?
+ @reordered : 0..$last; # reordered has CDROM up front
+ @host_seq = (0) unless @host_seq;
+ my $ret = $self->$method(\@host_seq,$file,$aslocal);
+ if ($ret) {
+ $Themethod = $level;
+ $self->debug("level[$level]") if $CPAN::DEBUG;
+ return $ret;
+ }
+ }
+ my(@mess);
+ push @mess,
+ qq{Please check, if the URLs I found in your configuration file \(}.
+ join(", ", @{$CPAN::Config->{urllist}}).
+ qq{\) are valid. The urllist can be edited.},
+ qq{E.g. with ``o conf urllist push ftp://myurl/''};
+ $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
+ sleep 2;
+ $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
+ if ($restore) {
+ rename "$aslocal.bak", $aslocal;
+ $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
+ $self->ls($aslocal));
+ return $aslocal;
+ }
+ return;
+}
+
+sub hosteasy {
+ my($self,$host_seq,$file,$aslocal) = @_;
+ my($i);
+ HOSTEASY: for $i (@$host_seq) {
+ my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
+ unless ($self->is_reachable($url)) {
+ $CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
+ sleep 2;
+ next;
+ }
+ $url .= "/" unless substr($url,-1) eq "/";
+ $url .= $file;
+ $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
+ if ($url =~ /^file:/) {
+ my $l;
+ if ($CPAN::META->has_inst('LWP')) {
+ require URI::URL;
+ my $u = URI::URL->new($url);
+ $l = $u->path;
+ } else { # works only on Unix, is poorly constructed, but
+ # hopefully better than nothing.
+ # RFC 1738 says fileurl BNF is
+ # fileurl = "file://" [ host | "localhost" ] "/" fpath
+ # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
+ # the code
+ ($l = $url) =~ s,^file://[^/]+,,; # discard the host part
+ $l =~ s/^file://; # assume they meant file://localhost
+ }
+ if ( -f $l && -r _) {
+ $Thesite = $i;
+ return $l;
+ }
+ # Maybe mirror has compressed it?
+ if (-f "$l.gz") {
+ $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
+ CPAN::Tarzip->gunzip("$l.gz", $aslocal);
+ if ( -f $aslocal) {
+ $Thesite = $i;
+ return $aslocal;
+ }
+ }
+ }
+ if ($CPAN::META->has_inst('LWP')) {
+ $CPAN::Frontend->myprint("Fetching with LWP:
+ $url
+");
+ my $res = $Ua->mirror($url, $aslocal);
+ if ($res->is_success) {
+ $Thesite = $i;
+ return $aslocal;
+ } elsif ($url !~ /\.gz$/) {
+ my $gzurl = "$url.gz";
+ $CPAN::Frontend->myprint("Fetching with LWP:
+ $gzurl
+");
+ $res = $Ua->mirror($gzurl, "$aslocal.gz");
+ if ($res->is_success &&
+ CPAN::Tarzip->gunzip("$aslocal.gz",$aslocal)
+ ) {
+ $Thesite = $i;
+ return $aslocal;
+ } else {
+ # next HOSTEASY ;
+ }
+ } else {
+ # Alan Burlison informed me that in firewall envs Net::FTP
+ # can still succeed where LWP fails. So we do not skip
+ # Net::FTP anymore when LWP is available.
+ # next HOSTEASY ;
+ }
+ } else {
+ $self->debug("LWP not installed") if $CPAN::DEBUG;
+ }
+ if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ # that's the nice and easy way thanks to Graham
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ if ($CPAN::META->has_inst('Net::FTP')) {
+ $dir =~ s|/+|/|g;
+ $CPAN::Frontend->myprint("Fetching with Net::FTP:
+ $url
+");
+ $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
+ "aslocal[$aslocal]") if $CPAN::DEBUG;
+ if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
+ $Thesite = $i;
+ return $aslocal;
+ }
+ if ($aslocal !~ /\.gz$/) {
+ my $gz = "$aslocal.gz";
+ $CPAN::Frontend->myprint("Fetching with Net::FTP
+ $url.gz
+");
+ if (CPAN::FTP->ftp_get($host,
+ $dir,
+ "$getfile.gz",
+ $gz) &&
+ CPAN::Tarzip->gunzip($gz,$aslocal)
+ ){
+ $Thesite = $i;
+ return $aslocal;
+ }
+ }
+ # next HOSTEASY;
+ }
+ }
+ }
+}
+
+sub hosthard {
+ my($self,$host_seq,$file,$aslocal) = @_;
+
+ # Came back if Net::FTP couldn't establish connection (or
+ # failed otherwise) Maybe they are behind a firewall, but they
+ # gave us a socksified (or other) ftp program...
+
+ my($i);
+ my($aslocal_dir) = File::Basename::dirname($aslocal);
+ File::Path::mkpath($aslocal_dir);
+ HOSTHARD: for $i (@$host_seq) {
+ my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
+ unless ($self->is_reachable($url)) {
+ $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
+ next;
+ }
+ $url .= "/" unless substr($url,-1) eq "/";
+ $url .= $file;
+ my($proto,$host,$dir,$getfile);
+
+ # Courtesy Mark Conty mark_conty@cargill.com change from
+ # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ # to
+ if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
+ # proto not yet used
+ ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
+ } else {
+ next HOSTHARD; # who said, we could ftp anything except ftp?
+ }
+ $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
+ my($f,$funkyftp);
+ for $f ('lynx','ncftp') {
+ next unless exists $CPAN::Config->{$f};
+ $funkyftp = $CPAN::Config->{$f};
+ next unless defined $funkyftp;
+ next if $funkyftp =~ /^\s*$/;
+ my($want_compressed);
+ my $aslocal_uncompressed;
+ ($aslocal_uncompressed = $aslocal) =~ s/\.gz//;
+ my($source_switch) = "";
+ $source_switch = "-source" if $funkyftp =~ /\blynx$/;
+ $source_switch = "-c" if $funkyftp =~ /\bncftp$/;
+ $CPAN::Frontend->myprint(
+ qq{
+Trying with "$funkyftp $source_switch" to get
+ $url
+});
+ my($system) = "$funkyftp $source_switch '$url' > ".
+ "$aslocal_uncompressed";
+ $self->debug("system[$system]") if $CPAN::DEBUG;
+ my($wstatus);
+ if (($wstatus = system($system)) == 0
+ &&
+ -s $aslocal_uncompressed # lynx returns 0 on my
+ # system even if it fails
+ ) {
+ if ($aslocal_uncompressed ne $aslocal) {
+ # test gzip integrity
+ if (
+ CPAN::Tarzip->gtest($aslocal_uncompressed)
+ ) {
+ rename $aslocal_uncompressed, $aslocal;
+ } else {
+ CPAN::Tarzip->gzip($aslocal_uncompressed,
+ "$aslocal_uncompressed.gz");
+ }
+ $Thesite = $i;
+ return $aslocal;
+ }
+ } elsif ($url !~ /\.gz$/) {
+ my $gz = "$aslocal.gz";
+ my $gzurl = "$url.gz";
+ $CPAN::Frontend->myprint(
+ qq{
+Trying with "$funkyftp $source_switch" to get
+ $url.gz
+});
+ my($system) = "$funkyftp $source_switch '$url.gz' > ".
+ "$aslocal_uncompressed.gz";
+ $self->debug("system[$system]") if $CPAN::DEBUG;
+ my($wstatus);
+ if (($wstatus = system($system)) == 0
+ &&
+ -s "$aslocal_uncompressed.gz"
+ ) {
+ # test gzip integrity
+ if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) {
+ CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz",
+ $aslocal);
+ } else {
+ rename $aslocal_uncompressed, $aslocal;
+ }
+#line 1739
+ $Thesite = $i;
+ return $aslocal;
+ }
+ } else {
+ my $estatus = $wstatus >> 8;
+ my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : "";
+ $CPAN::Frontend->myprint(qq{
+System call "$system"
+returned status $estatus (wstat $wstatus)$size
+});
+ }
+ }
+ }
+}
+
+sub hosthardest {
+ my($self,$host_seq,$file,$aslocal) = @_;
+
+ my($i);
+ my($aslocal_dir) = File::Basename::dirname($aslocal);
+ File::Path::mkpath($aslocal_dir);
+ HOSTHARDEST: for $i (@$host_seq) {
+ unless (length $CPAN::Config->{'ftp'}) {
+ $CPAN::Frontend->myprint("No external ftp command available\n\n");
+ last HOSTHARDEST;
+ }
+ my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
+ unless ($self->is_reachable($url)) {
+ $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
+ next;
+ }
+ $url .= "/" unless substr($url,-1) eq "/";
+ $url .= $file;
+ $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
+ unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ next;
+ }
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ my($netrcfile,$fh);
+ my $timestamp = 0;
+ my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
+ $ctime,$blksize,$blocks) = stat($aslocal);
+ $timestamp = $mtime ||= 0;
+ my($netrc) = CPAN::FTP::netrc->new;
+ my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
+ my $targetfile = File::Basename::basename($aslocal);
+ my(@dialog);
+ push(
+ @dialog,
+ "lcd $aslocal_dir",
+ "cd /",
+ map("cd $_", split "/", $dir), # RFC 1738
+ "bin",
+ "get $getfile $targetfile",
+ "quit"
+ );
+ if (! $netrc->netrc) {
+ CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
+ } elsif ($netrc->hasdefault || $netrc->contains($host)) {
+ CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
+ $netrc->hasdefault,
+ $netrc->contains($host))) if $CPAN::DEBUG;
+ if ($netrc->protected) {
+ $CPAN::Frontend->myprint(qq{
+ Trying with external ftp to get
+ $url
+ As this requires some features that are not thoroughly tested, we\'re
+ not sure, that we get it right....
+
+}
+ );
+ $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
+ @dialog);
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
+ $mtime ||= 0;
+ if ($mtime > $timestamp) {
+ $CPAN::Frontend->myprint("GOT $aslocal\n");
+ $Thesite = $i;
+ return $aslocal;
+ } else {
+ $CPAN::Frontend->myprint("Hmm... Still failed!\n");
+ }
+ } else {
+ $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
+ qq{correctly protected.\n});
+ }
+ } else {
+ $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
+ nor does it have a default entry\n");
+ }
+
+ # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
+ # then and login manually to host, using e-mail as
+ # password.
+ $CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
+ unshift(
+ @dialog,
+ "open $host",
+ "user anonymous $Config::Config{'cf_email'}"
+ );
+ $self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
+ $mtime ||= 0;
+ if ($mtime > $timestamp) {
+ $CPAN::Frontend->myprint("GOT $aslocal\n");
+ $Thesite = $i;
+ return $aslocal;
+ } else {
+ $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
+ }
+ $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
+ sleep 2;
+ }
+}
+
+sub talk_ftp {
+ my($self,$command,@dialog) = @_;
+ my $fh = FileHandle->new;
+ $fh->open("|$command") or die "Couldn't open ftp: $!";
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close; # Wait for process to complete
+ my $wstatus = $?;
+ my $estatus = $wstatus >> 8;
+ $CPAN::Frontend->myprint(qq{
+Subprocess "|$command"
+ returned status $estatus (wstat $wstatus)
+}) if $wstatus;
+
+}
+
+# find2perl needs modularization, too, all the following is stolen
+# from there
+# CPAN::FTP::ls
+sub ls {
+ my($self,$name) = @_;
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
+ $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
+
+ my($perms,%user,%group);
+ my $pname = $name;
+
+ if ($blocks) {
+ $blocks = int(($blocks + 1) / 2);
+ }
+ else {
+ $blocks = int(($sizemm + 1023) / 1024);
+ }
+
+ if (-f _) { $perms = '-'; }
+ elsif (-d _) { $perms = 'd'; }
+ elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
+ elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
+ elsif (-p _) { $perms = 'p'; }
+ elsif (-S _) { $perms = 's'; }
+ else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
+
+ my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
+ my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+ my $tmpmode = $mode;
+ my $tmp = $rwx[$tmpmode & 7];
+ $tmpmode >>= 3;
+ $tmp = $rwx[$tmpmode & 7] . $tmp;
+ $tmpmode >>= 3;
+ $tmp = $rwx[$tmpmode & 7] . $tmp;
+ substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
+ substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
+ substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
+ $perms .= $tmp;
+
+ my $user = $user{$uid} || $uid; # too lazy to implement lookup
+ my $group = $group{$gid} || $gid;
+
+ my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
+ my($timeyear);
+ my($moname) = $moname[$mon];
+ if (-M _ > 365.25 / 2) {
+ $timeyear = $year + 1900;
+ }
+ else {
+ $timeyear = sprintf("%02d:%02d", $hour, $min);
+ }
+
+ sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
+ $ino,
+ $blocks,
+ $perms,
+ $nlink,
+ $user,
+ $group,
+ $sizemm,
+ $moname,
+ $mday,
+ $timeyear,
+ $pname;
+}
+
+package CPAN::FTP::netrc;
+
+sub new {
+ my($class) = @_;
+ my $file = MM->catfile($ENV{HOME},".netrc");
+
+ my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = stat($file);
+ $mode ||= 0;
+ my $protected = 0;
+
+ my($fh,@machines,$hasdefault);
+ $hasdefault = 0;
+ $fh = FileHandle->new or die "Could not create a filehandle";
+
+ if($fh->open($file)){
+ $protected = ($mode & 077) == 0;
+ local($/) = "";
+ NETRC: while (<$fh>) {
+ my(@tokens) = split " ", $_;
+ TOKEN: while (@tokens) {
+ my($t) = shift @tokens;
+ if ($t eq "default"){
+ $hasdefault++;
+ last NETRC;
+ }
+ last TOKEN if $t eq "macdef";
+ if ($t eq "machine") {
+ push @machines, shift @tokens;
+ }
+ }
+ }
+ } else {
+ $file = $hasdefault = $protected = "";
+ }
+
+ bless {
+ 'mach' => [@machines],
+ 'netrc' => $file,
+ 'hasdefault' => $hasdefault,
+ 'protected' => $protected,
+ }, $class;
+}
+
+sub hasdefault { shift->{'hasdefault'} }
+sub netrc { shift->{'netrc'} }
+sub protected { shift->{'protected'} }
+sub contains {
+ my($self,$mach) = @_;
+ for ( @{$self->{'mach'}} ) {
+ return 1 if $_ eq $mach;
+ }
+ return 0;
+}
+
+package CPAN::Complete;
+
+#-> sub CPAN::Complete::cpl ;
+sub cpl {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ $line ||= "";
+ $pos ||= 0;
+ CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ $line =~ s/^\s*//;
+ if ($line =~ s/^(force\s*)//) {
+ $pos -= length($1);
+ }
+ my @return;
+ if ($pos == 0) {
+ @return = grep(
+ /^$word/,
+ sort qw(
+ ! a b d h i m o q r u autobundle clean
+ make test install force reload look
+ )
+ );
+ } elsif ( $line !~ /^[\!abdhimorutl]/ ) {
+ @return = ();
+ } elsif ($line =~ /^a\s/) {
+ @return = cplx('CPAN::Author',$word);
+ } elsif ($line =~ /^b\s/) {
+ @return = cplx('CPAN::Bundle',$word);
+ } elsif ($line =~ /^d\s/) {
+ @return = cplx('CPAN::Distribution',$word);
+ } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) {
+ @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
+ } elsif ($line =~ /^i\s/) {
+ @return = cpl_any($word);
+ } elsif ($line =~ /^reload\s/) {
+ @return = cpl_reload($word,$line,$pos);
+ } elsif ($line =~ /^o\s/) {
+ @return = cpl_option($word,$line,$pos);
+ } else {
+ @return = ();
+ }
+ return @return;
+}
+
+#-> sub CPAN::Complete::cplx ;
+sub cplx {
+ my($class, $word) = @_;
+ grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class);
+}
+
+#-> sub CPAN::Complete::cpl_any ;
+sub cpl_any {
+ my($word) = shift;
+ return (
+ cplx('CPAN::Author',$word),
+ cplx('CPAN::Bundle',$word),
+ cplx('CPAN::Distribution',$word),
+ cplx('CPAN::Module',$word),
+ );
+}
+
+#-> sub CPAN::Complete::cpl_reload ;
+sub cpl_reload {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ my(@words) = split " ", $line;
+ CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ my(@ok) = qw(cpan index);
+ return @ok if @words == 1;
+ return grep /^\Q$word\E/, @ok if @words == 2 && $word;
+}
+
+#-> sub CPAN::Complete::cpl_option ;
+sub cpl_option {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ my(@words) = split " ", $line;
+ CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ my(@ok) = qw(conf debug);
+ return @ok if @words == 1;
+ return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
+ if (0) {
+ } elsif ($words[1] eq 'index') {
+ return ();
+ } elsif ($words[1] eq 'conf') {
+ return CPAN::Config::cpl(@_);
+ } elsif ($words[1] eq 'debug') {
+ return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
+ }
+}
+
+package CPAN::Index;
+
+#-> sub CPAN::Index::force_reload ;
+sub force_reload {
+ my($class) = @_;
+ $CPAN::Index::last_time = 0;
+ $class->reload(1);
+}
+
+#-> sub CPAN::Index::reload ;
+sub reload {
+ my($cl,$force) = @_;
+ my $time = time;
+
+ # XXX check if a newer one is available. (We currently read it
+ # from time to time)
+ for ($CPAN::Config->{index_expire}) {
+ $_ = 0.001 unless $_ > 0.001;
+ }
+ return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
+ and ! $force;
+ my($debug,$t2);
+ $last_time = $time;
+
+ my $needshort = $^O eq "dos";
+
+ $cl->rd_authindex($cl->reload_x(
+ "authors/01mailrc.txt.gz",
+ $needshort ? "01mailrc.gz" : "",
+ $force));
+ $t2 = time;
+ $debug = "timing reading 01[".($t2 - $time)."]";
+ $time = $t2;
+ return if $CPAN::Signal; # this is sometimes lengthy
+ $cl->rd_modpacks($cl->reload_x(
+ "modules/02packages.details.txt.gz",
+ $needshort ? "02packag.gz" : "",
+ $force));
+ $t2 = time;
+ $debug .= "02[".($t2 - $time)."]";
+ $time = $t2;
+ return if $CPAN::Signal; # this is sometimes lengthy
+ $cl->rd_modlist($cl->reload_x(
+ "modules/03modlist.data.gz",
+ $needshort ? "03mlist.gz" : "",
+ $force));
+ $t2 = time;
+ $debug .= "03[".($t2 - $time)."]";
+ $time = $t2;
+ CPAN->debug($debug) if $CPAN::DEBUG;
+}
+
+#-> sub CPAN::Index::reload_x ;
+sub reload_x {
+ my($cl,$wanted,$localname,$force) = @_;
+ $force |= 2; # means we're dealing with an index here
+ CPAN::Config->load; # we should guarantee loading wherever we rely
+ # on Config XXX
+ $localname ||= $wanted;
+ my $abs_wanted = MM->catfile($CPAN::Config->{'keep_source_where'},
+ $localname);
+ if (
+ -f $abs_wanted &&
+ -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
+ !($force & 1)
+ ) {
+ my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
+ $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
+ qq{day$s. I\'ll use that.});
+ return $abs_wanted;
+ } else {
+ $force |= 1; # means we're quite serious about it.
+ }
+ return CPAN::FTP->localize($wanted,$abs_wanted,$force);
+}
+
+#-> sub CPAN::Index::rd_authindex ;
+sub rd_authindex {
+ my($cl,$index_target) = @_;
+ return unless defined $index_target;
+ $CPAN::Frontend->myprint("Going to read $index_target\n");
+# my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
+# while ($_ = $fh->READLINE) {
+ # no strict 'refs';
+ local(*FH);
+ tie *FH, CPAN::Tarzip, $index_target;
+ local($/) = "\n";
+ while (<FH>) {
+ chomp;
+ my($userid,$fullname,$email) =
+ /alias\s+(\S+)\s+\"([^\"\<]+)\s+<([^\>]+)\>\"/;
+ next unless $userid && $fullname && $email;
+
+ # instantiate an author object
+ my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
+ $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
+ return if $CPAN::Signal;
+ }
+}
+
+sub userid {
+ my($self,$dist) = @_;
+ $dist = $self->{'id'} unless defined $dist;
+ my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
+ $ret;
+}
+
+#-> sub CPAN::Index::rd_modpacks ;
+sub rd_modpacks {
+ my($cl,$index_target) = @_;
+ return unless defined $index_target;
+ $CPAN::Frontend->myprint("Going to read $index_target\n");
+ my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
+ local($/) = "\n";
+ while ($_ = $fh->READLINE) {
+ last if /^\s*$/;
+ }
+ while ($_ = $fh->READLINE) {
+ chomp;
+ my($mod,$version,$dist) = split;
+### $version =~ s/^\+//;
+
+ # if it is a bundle, instatiate a bundle object
+ my($bundle,$id,$userid);
+
+ if ($mod eq 'CPAN' &&
+ ! (
+ $CPAN::META->exists('CPAN::Queue','Bundle::CPAN') ||
+ $CPAN::META->exists('CPAN::Queue','CPAN')
+ )
+ ) {
+ local($^W)= 0;
+ if ($version > $CPAN::VERSION){
+ $CPAN::Frontend->myprint(qq{
+ There\'s a new CPAN.pm version (v$version) available!
+ You might want to try
+ install Bundle::CPAN
+ reload cpan
+ without quitting the current session. It should be a seamless upgrade
+ while we are running...
+});
+ sleep 2;
+ $CPAN::Frontend->myprint(qq{\n});
+ }
+ last if $CPAN::Signal;
+ } elsif ($mod =~ /^Bundle::(.*)/) {
+ $bundle = $1;
+ }
+
+ if ($bundle){
+ $id = $CPAN::META->instance('CPAN::Bundle',$mod);
+ # Let's make it a module too, because bundles have so much
+ # in common with modules
+ $CPAN::META->instance('CPAN::Module',$mod);
+
+# This "next" makes us faster but if the job is running long, we ignore
+# rereads which is bad. So we have to be a bit slower again.
+# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
+# next;
+
+ }
+ else {
+ # instantiate a module object
+ $id = $CPAN::META->instance('CPAN::Module',$mod);
+ }
+
+ if ($id->cpan_file ne $dist){
+ $userid = $cl->userid($dist);
+ $id->set(
+ 'CPAN_USERID' => $userid,
+ 'CPAN_VERSION' => $version,
+ 'CPAN_FILE' => $dist
+ );
+ }
+
+ # instantiate a distribution object
+ unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
+ $CPAN::META->instance(
+ 'CPAN::Distribution' => $dist
+ )->set(
+ 'CPAN_USERID' => $userid
+ );
+ }
+
+ return if $CPAN::Signal;
+ }
+ undef $fh;
+}
+
+#-> sub CPAN::Index::rd_modlist ;
+sub rd_modlist {
+ my($cl,$index_target) = @_;
+ return unless defined $index_target;
+ $CPAN::Frontend->myprint("Going to read $index_target\n");
+ my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
+ my @eval;
+ local($/) = "\n";
+ while ($_ = $fh->READLINE) {
+ if (/^Date:\s+(.*)/){
+ return if $date_of_03 eq $1;
+ ($date_of_03) = $1;
+ }
+ last if /^\s*$/;
+ }
+ push @eval, $_ while $_ = $fh->READLINE;
+ undef $fh;
+ push @eval, q{CPAN::Modulelist->data;};
+ local($^W) = 0;
+ my($comp) = Safe->new("CPAN::Safe1");
+ my($eval) = join("", @eval);
+ my $ret = $comp->reval($eval);
+ Carp::confess($@) if $@;
+ return if $CPAN::Signal;
+ for (keys %$ret) {
+ my $obj = $CPAN::META->instance(CPAN::Module,$_);
+ $obj->set(%{$ret->{$_}});
+ return if $CPAN::Signal;
+ }
+}
+
+package CPAN::InfoObj;
+
+#-> sub CPAN::InfoObj::new ;
+sub new { my $this = bless {}, shift; %$this = @_; $this }
+
+#-> sub CPAN::InfoObj::set ;
+sub set {
+ my($self,%att) = @_;
+ my(%oldatt) = %$self;
+ %$self = (%oldatt, %att);
+}
+
+#-> sub CPAN::InfoObj::id ;
+sub id { shift->{'ID'} }
+
+#-> sub CPAN::InfoObj::as_glimpse ;
+sub as_glimpse {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, sprintf "%-15s %s\n", $class, $self->{ID};
+ join "", @m;
+}
+
+#-> sub CPAN::InfoObj::as_string ;
+sub as_string {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, $class, " id = $self->{ID}\n";
+ for (sort keys %$self) {
+ next if $_ eq 'ID';
+ my $extra = "";
+ if ($_ eq "CPAN_USERID") {
+ $extra .= " (".$self->author;
+ my $email; # old perls!
+ if ($email = $CPAN::META->instance(CPAN::Author,
+ $self->{$_}
+ )->email) {
+ $extra .= " <$email>";
+ } else {
+ $extra .= " <no email>";
+ }
+ $extra .= ")";
+ }
+ if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
+ push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
+ } else {
+ push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
+ }
+ }
+ join "", @m, "\n";
+}
+
+#-> sub CPAN::InfoObj::author ;
+sub author {
+ my($self) = @_;
+ $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
+}
+
+package CPAN::Author;
+
+#-> sub CPAN::Author::as_glimpse ;
+sub as_glimpse {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname;
+ join "", @m;
+}
+
+# Dead code, I would have liked to have,,, but it was never reached,,,
+#sub make {
+# my($self) = @_;
+# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
+#}
+
+#-> sub CPAN::Author::fullname ;
+sub fullname { shift->{'FULLNAME'} }
+*name = \&fullname;
+#-> sub CPAN::Author::email ;
+sub email { shift->{'EMAIL'} }
+
+package CPAN::Distribution;
+
+#-> sub CPAN::Distribution::called_for ;
+sub called_for {
+ my($self,$id) = @_;
+ $self->{'CALLED_FOR'} = $id if defined $id;
+ return $self->{'CALLED_FOR'};
+}
+
+#-> sub CPAN::Distribution::get ;
+sub get {
+ my($self) = @_;
+ EXCUSE: {
+ my @e;
+ exists $self->{'build_dir'} and push @e,
+ "Unwrapped into directory $self->{'build_dir'}";
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ }
+ my($local_file);
+ my($local_wanted) =
+ MM->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split("/",$self->{ID})
+ );
+
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ $local_file =
+ CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
+ or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
+ $self->{localfile} = $local_file;
+ my $builddir = $CPAN::META->{cachemgr}->dir;
+ $self->debug("doing chdir $builddir") if $CPAN::DEBUG;
+ chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
+ my $packagedir;
+
+ $self->debug("local_file[$local_file]") if $CPAN::DEBUG;
+ if ($CPAN::META->has_inst('MD5')) {
+ $self->debug("MD5 is installed, verifying");
+ $self->verifyMD5;
+ } else {
+ $self->debug("MD5 is NOT installed");
+ }
+ $self->debug("Removing tmp") if $CPAN::DEBUG;
+ File::Path::rmtree("tmp");
+ mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
+ chdir "tmp";
+ $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
+ if (! $local_file) {
+ Carp::croak "bad download, can't do anything :-(\n";
+ } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
+ $self->untar_me($local_file);
+ } elsif ( $local_file =~ /\.zip$/i ) {
+ $self->unzip_me($local_file);
+ } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
+ $self->pm2dir_me($local_file);
+ } else {
+ $self->{archived} = "NO";
+ }
+ chdir "..";
+ if ($self->{archived} ne 'NO') {
+ chdir "tmp";
+ # Let's check if the package has its own directory.
+ my $dh = DirHandle->new(".") or Carp::croak("Couldn't opendir .: $!");
+ my @readdir = grep $_ !~ /^\.\.?$/, $dh->read; ### MAC??
+ $dh->close;
+ my ($distdir,$packagedir);
+ if (@readdir == 1 && -d $readdir[0]) {
+ $distdir = $readdir[0];
+ $packagedir = MM->catdir($builddir,$distdir);
+ -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
+ File::Path::rmtree($packagedir);
+ rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
+ } else {
+ my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
+ $pragmatic_dir =~ s/\W_//g;
+ $pragmatic_dir++ while -d "../$pragmatic_dir";
+ $packagedir = MM->catdir($builddir,$pragmatic_dir);
+ File::Path::mkpath($packagedir);
+ my($f);
+ for $f (@readdir) { # is already without "." and ".."
+ my $to = MM->catdir($packagedir,$f);
+ rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
+ }
+ }
+ $self->{'build_dir'} = $packagedir;
+ chdir "..";
+
+ $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
+ if $CPAN::DEBUG;
+ File::Path::rmtree("tmp");
+ if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
+ $CPAN::Frontend->myprint("Going to unlink $local_file\n");
+ unlink $local_file or Carp::carp "Couldn't unlink $local_file";
+ }
+ my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
+ unless (-f $makefilepl) {
+ my($configure) = MM->catfile($packagedir,"Configure");
+ if (-f $configure) {
+ # do we have anything to do?
+ $self->{'configure'} = $configure;
+ } elsif (-f MM->catfile($packagedir,"Makefile")) {
+ $CPAN::Frontend->myprint(qq{
+Package comes with a Makefile and without a Makefile.PL.
+We\'ll try to build it with that Makefile then.
+});
+ $self->{writemakefile} = "YES";
+ sleep 2;
+ } else {
+ my $fh = FileHandle->new(">$makefilepl")
+ or Carp::croak("Could not open >$makefilepl");
+ my $cf = $self->called_for || "unknown";
+ $fh->print(
+qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
+# because there was no Makefile.PL supplied.
+# Autogenerated on: }.scalar localtime().qq{
+
+use ExtUtils::MakeMaker;
+WriteMakefile(NAME => q[$cf]);
+
+});
+ $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
+ Writing one on our own (calling it $cf)\n});
+ }
+ }
+ }
+ return $self;
+}
+
+sub untar_me {
+ my($self,$local_file) = @_;
+ $self->{archived} = "tar";
+ if (CPAN::Tarzip->untar($local_file)) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
+}
+
+sub unzip_me {
+ my($self,$local_file) = @_;
+ $self->{archived} = "zip";
+ my $system = "$CPAN::Config->{unzip} $local_file";
+ if (system($system) == 0) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
+}
+
+sub pm2dir_me {
+ my($self,$local_file) = @_;
+ $self->{archived} = "pm";
+ my $to = File::Basename::basename($local_file);
+ $to =~ s/\.(gz|Z)$//;
+ if (CPAN::Tarzip->gunzip($local_file,$to)) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
+}
+
+#-> sub CPAN::Distribution::new ;
+sub new {
+ my($class,%att) = @_;
+
+ $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
+
+ my $this = { %att };
+ return bless $this, $class;
+}
+
+#-> sub CPAN::Distribution::look ;
+sub look {
+ my($self) = @_;
+ if ( $CPAN::Config->{'shell'} ) {
+ $CPAN::Frontend->myprint(qq{
+Trying to open a subshell in the build directory...
+});
+ } else {
+ $CPAN::Frontend->myprint(qq{
+Your configuration does not define a value for subshells.
+Please define it with "o conf shell <your shell>"
+});
+ return;
+ }
+ my $dist = $self->id;
+ my $dir = $self->dir or $self->get;
+ $dir = $self->dir;
+ my $getcwd;
+ $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
+ my $pwd = CPAN->$getcwd();
+ chdir($dir);
+ $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
+ system($CPAN::Config->{'shell'}) == 0
+ or $CPAN::Frontend->mydie("Subprocess shell error");
+ chdir($pwd);
+}
+
+#-> sub CPAN::Distribution::readme ;
+sub readme {
+ my($self) = @_;
+ my($dist) = $self->id;
+ my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
+ $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
+ my($local_file);
+ my($local_wanted) =
+ MM->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ split("/","$sans.readme"),
+ );
+ $self->debug("Doing localize") if $CPAN::DEBUG;
+ $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
+ $local_wanted)
+ or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
+ my $fh_pager = FileHandle->new;
+ local($SIG{PIPE}) = "IGNORE";
+ $fh_pager->open("|$CPAN::Config->{'pager'}")
+ or die "Could not open pager $CPAN::Config->{'pager'}: $!";
+ my $fh_readme = FileHandle->new;
+ $fh_readme->open($local_file)
+ or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
+ $CPAN::Frontend->myprint(qq{
+Displaying file
+ $local_file
+with pager "$CPAN::Config->{'pager'}"
+});
+ sleep 2;
+ $fh_pager->print(<$fh_readme>);
+}
+
+#-> sub CPAN::Distribution::verifyMD5 ;
+sub verifyMD5 {
+ my($self) = @_;
+ EXCUSE: {
+ my @e;
+ $self->{MD5_STATUS} ||= "";
+ $self->{MD5_STATUS} eq "OK" and push @e, "MD5 Checksum was ok";
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ }
+ my($lc_want,$lc_file,@local,$basename);
+ @local = split("/",$self->{ID});
+ pop @local;
+ push @local, "CHECKSUMS";
+ $lc_want =
+ MM->catfile($CPAN::Config->{keep_source_where},
+ "authors", "id", @local);
+ local($") = "/";
+ if (
+ -s $lc_want
+ &&
+ $self->MD5_check_file($lc_want)
+ ) {
+ return $self->{MD5_STATUS} = "OK";
+ }
+ $lc_file = CPAN::FTP->localize("authors/id/@local",
+ $lc_want,1);
+ unless ($lc_file) {
+ $local[-1] .= ".gz";
+ $lc_file = CPAN::FTP->localize("authors/id/@local",
+ "$lc_want.gz",1);
+ if ($lc_file) {
+ $lc_file =~ s/\.gz$//;
+ CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
+ } else {
+ return;
+ }
+ }
+ $self->MD5_check_file($lc_file);
+}
+
+#-> sub CPAN::Distribution::MD5_check_file ;
+sub MD5_check_file {
+ my($self,$chk_file) = @_;
+ my($cksum,$file,$basename);
+ $file = $self->{localfile};
+ $basename = File::Basename::basename($file);
+ my $fh = FileHandle->new;
+ if (open $fh, $chk_file){
+ local($/);
+ my $eval = <$fh>;
+ close $fh;
+ my($comp) = Safe->new();
+ $cksum = $comp->reval($eval);
+ if ($@) {
+ rename $chk_file, "$chk_file.bad";
+ Carp::confess($@) if $@;
+ }
+ } else {
+ Carp::carp "Could not open $chk_file for reading";
+ }
+
+ if (exists $cksum->{$basename}{md5}) {
+ $self->debug("Found checksum for $basename:" .
+ "$cksum->{$basename}{md5}\n") if $CPAN::DEBUG;
+
+ open($fh, $file);
+ binmode $fh;
+ my $eq = $self->eq_MD5($fh,$cksum->{$basename}{'md5'});
+ $fh->close;
+ $fh = CPAN::Tarzip->TIEHANDLE($file);
+
+ unless ($eq) {
+ # had to inline it, when I tied it, the tiedness got lost on
+ # the call to eq_MD5. (Jan 1998)
+ my $md5 = MD5->new;
+ my($data,$ref);
+ $ref = \$data;
+ while ($fh->READ($ref, 4096)){
+ $md5->add($data);
+ }
+ my $hexdigest = $md5->hexdigest;
+ $eq += $hexdigest eq $cksum->{$basename}{'md5-ungz'};
+ }
+
+ if ($eq) {
+ $CPAN::Frontend->myprint("Checksum for $file ok\n");
+ return $self->{MD5_STATUS} = "OK";
+ } else {
+ $CPAN::Frontend->myprint(qq{Checksum mismatch for }.
+ qq{distribution file. }.
+ qq{Please investigate.\n\n}.
+ $self->as_string,
+ $CPAN::META->instance(
+ 'CPAN::Author',
+ $self->{CPAN_USERID}
+ )->as_string);
+ my $wrap = qq{I\'d recommend removing $file. It seems to
+be a bogus file. Maybe you have configured your \`urllist\' with a
+bad URL. Please check this array with \`o conf urllist\', and
+retry.};
+ $CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
+ $CPAN::Frontend->myprint("\n\n");
+ sleep 3;
+ return;
+ }
+ # close $fh if fileno($fh);
+ } else {
+ $self->{MD5_STATUS} ||= "";
+ if ($self->{MD5_STATUS} eq "NIL") {
+ $CPAN::Frontend->myprint(qq{
+No md5 checksum for $basename in local $chk_file.
+Removing $chk_file
+});
+ unlink $chk_file or $CPAN::Frontend->myprint("Could not unlink: $!");
+ sleep 1;
+ }
+ $self->{MD5_STATUS} = "NIL";
+ return;
+ }
+}
+
+#-> sub CPAN::Distribution::eq_MD5 ;
+sub eq_MD5 {
+ my($self,$fh,$expectMD5) = @_;
+ my $md5 = MD5->new;
+ my($data);
+ while (read($fh, $data, 4096)){
+ $md5->add($data);
+ }
+ # $md5->addfile($fh);
+ my $hexdigest = $md5->hexdigest;
+ # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
+ $hexdigest eq $expectMD5;
+}
+
+#-> sub CPAN::Distribution::force ;
+sub force {
+ my($self) = @_;
+ $self->{'force_update'}++;
+ delete $self->{'MD5_STATUS'};
+ delete $self->{'archived'};
+ delete $self->{'build_dir'};
+ delete $self->{'localfile'};
+ delete $self->{'make'};
+ delete $self->{'install'};
+ delete $self->{'unwrapped'};
+ delete $self->{'writemakefile'};
+}
+
+sub isa_perl {
+ my($self) = @_;
+ my $file = File::Basename::basename($self->id);
+ return unless $file =~ m{ ^ perl
+ (5)
+ ([._-])
+ (\d{3}(_[0-4][0-9])?)
+ \.tar[._-]gz
+ $
+ }x;
+ "$1.$3";
+}
+
+#-> sub CPAN::Distribution::perl ;
+sub perl {
+ my($self) = @_;
+ my($perl) = MM->file_name_is_absolute($^X) ? $^X : "";
+ my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
+ my $pwd = CPAN->$getcwd();
+ my $candidate = MM->catfile($pwd,$^X);
+ $perl ||= $candidate if MM->maybe_command($candidate);
+ unless ($perl) {
+ my ($component,$perl_name);
+ DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
+ PATH_COMPONENT: foreach $component (MM->path(),
+ $Config::Config{'binexp'}) {
+ next unless defined($component) && $component;
+ my($abs) = MM->catfile($component,$perl_name);
+ if (MM->maybe_command($abs)) {
+ $perl = $abs;
+ last DIST_PERLNAME;
+ }
+ }
+ }
+ }
+ $perl;
+}
+
+#-> sub CPAN::Distribution::make ;
+sub make {
+ my($self) = @_;
+ $CPAN::Frontend->myprint(sprintf "Running make for %s\n", $self->id);
+ # Emergency brake if they said install Pippi and get newest perl
+ if ($self->isa_perl) {
+ if (
+ $self->called_for ne $self->id && ! $self->{'force_update'}
+ ) {
+ $CPAN::Frontend->mydie(sprintf qq{
+The most recent version "%s" of the module "%s"
+comes with the current version of perl (%s).
+I\'ll build that only if you ask for something like
+ force install %s
+or
+ install %s
+},
+ $CPAN::META->instance(
+ 'CPAN::Module',
+ $self->called_for
+ )->cpan_version,
+ $self->called_for,
+ $self->isa_perl,
+ $self->called_for,
+ $self->id);
+ }
+ }
+ $self->get;
+ EXCUSE: {
+ my @e;
+ $self->{archived} eq "NO" and push @e,
+ "Is neither a tar nor a zip archive.";
+
+ $self->{unwrapped} eq "NO" and push @e,
+ "had problems unarchiving. Please build manually";
+
+ exists $self->{writemakefile} &&
+ $self->{writemakefile} eq "NO" and push @e,
+ "Had some problem writing Makefile";
+
+ defined $self->{'make'} and push @e,
+ "Has already been processed within this session";
+
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ }
+ $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
+ my $builddir = $self->dir;
+ chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
+ $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
+
+ my $system;
+ if ($self->{'configure'}) {
+ $system = $self->{'configure'};
+ } else {
+ my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
+ my $switch = "";
+# This needs a handler that can be turned on or off:
+# $switch = "-MExtUtils::MakeMaker ".
+# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
+# if $] > 5.00310;
+ $system = "$perl $switch Makefile.PL $CPAN::Config->{makepl_arg}";
+ }
+ unless (exists $self->{writemakefile}) {
+ local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
+ my($ret,$pid);
+ $@ = "";
+ if ($CPAN::Config->{inactivity_timeout}) {
+ eval {
+ alarm $CPAN::Config->{inactivity_timeout};
+ local $SIG{CHLD} = sub { wait };
+ if (defined($pid = fork)) {
+ if ($pid) { #parent
+ wait;
+ } else { #child
+ # note, this exec isn't necessary if
+ # inactivity_timeout is 0. On the Mac I'd
+ # suggest, we set it always to 0.
+ exec $system;
+ }
+ } else {
+ $CPAN::Frontend->myprint("Cannot fork: $!");
+ return;
+ }
+ };
+ alarm 0;
+ if ($@){
+ kill 9, $pid;
+ waitpid $pid, 0;
+ $CPAN::Frontend->myprint($@);
+ $self->{writemakefile} = "NO - $@";
+ $@ = "";
+ return;
+ }
+ } else {
+ if (0) {
+ warn "Trying to intercept the output of 'perl Makefile.PL'";
+ require IO::File;
+ # my $fh = FileHandle->new("$system 2>&1 |") or
+ my $fh = IO::File->new("$system 2>&1 |") or
+ die "Couldn't run '$system': $!";
+ local($|) = 1;
+ while (length($_ = getc($fh))) {
+ print $_; # we want to parse that some day!
+ # unfortunately we have Makefile.PLs that want to talk
+ # and we can't emulate that reliably. I think, we have
+ # to parse Makefile.PL directly
+ }
+ $ret = $fh->close;
+ unless ($ret) {
+ warn $! ? "Error during 'perl Makefile.PL' subprocess: $!" :
+ "Exit status of 'perl Makefile.PL': $?";
+ $self->{writemakefile} = "NO";
+ return;
+ }
+ } else {
+ $ret = system($system);
+ if ($ret != 0) {
+ $self->{writemakefile} = "NO";
+ return;
+ }
+ }
+ }
+ $self->{writemakefile} = "YES";
+ }
+ return if $CPAN::Signal;
+ $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
+ if (system($system) == 0) {
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $self->{'make'} = "YES";
+ } else {
+ $self->{writemakefile} = "YES";
+ $self->{'make'} = "NO";
+ $CPAN::Frontend->myprint(" $system -- NOT OK\n");
+ }
+}
+
+#-> sub CPAN::Distribution::test ;
+sub test {
+ my($self) = @_;
+ $self->make;
+ return if $CPAN::Signal;
+ $CPAN::Frontend->myprint("Running make test\n");
+ EXCUSE: {
+ my @e;
+ exists $self->{'make'} or push @e,
+ "Make had some problems, maybe interrupted? Won't test";
+
+ exists $self->{'make'} and
+ $self->{'make'} eq 'NO' and
+ push @e, "Oops, make had returned bad status";
+
+ exists $self->{'build_dir'} or push @e, "Has no own directory";
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ }
+ chdir $self->{'build_dir'} or
+ Carp::croak("Couldn't chdir to $self->{'build_dir'}");
+ $self->debug("Changed directory to $self->{'build_dir'}")
+ if $CPAN::DEBUG;
+ my $system = join " ", $CPAN::Config->{'make'}, "test";
+ if (system($system) == 0) {
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $self->{'make_test'} = "YES";
+ } else {
+ $self->{'make_test'} = "NO";
+ $CPAN::Frontend->myprint(" $system -- NOT OK\n");
+ }
+}
+
+#-> sub CPAN::Distribution::clean ;
+sub clean {
+ my($self) = @_;
+ $CPAN::Frontend->myprint("Running make clean\n");
+ EXCUSE: {
+ my @e;
+ exists $self->{'build_dir'} or push @e, "Has no own directory";
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ }
+ chdir $self->{'build_dir'} or
+ Carp::croak("Couldn't chdir to $self->{'build_dir'}");
+ $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG;
+ my $system = join " ", $CPAN::Config->{'make'}, "clean";
+ if (system($system) == 0) {
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $self->force;
+ } else {
+ # Hmmm, what to do if make clean failed?
+ }
+}
+
+#-> sub CPAN::Distribution::install ;
+sub install {
+ my($self) = @_;
+ $self->test;
+ return if $CPAN::Signal;
+ $CPAN::Frontend->myprint("Running make install\n");
+ EXCUSE: {
+ my @e;
+ exists $self->{'build_dir'} or push @e, "Has no own directory";
+
+ exists $self->{'make'} or push @e,
+ "Make had some problems, maybe interrupted? Won't install";
+
+ exists $self->{'make'} and
+ $self->{'make'} eq 'NO' and
+ push @e, "Oops, make had returned bad status";
+
+ push @e, "make test had returned bad status, ".
+ "won't install without force"
+ if exists $self->{'make_test'} and
+ $self->{'make_test'} eq 'NO' and
+ ! $self->{'force_update'};
+
+ exists $self->{'install'} and push @e,
+ $self->{'install'} eq "YES" ?
+ "Already done" : "Already tried without success";
+
+ $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
+ }
+ chdir $self->{'build_dir'} or
+ Carp::croak("Couldn't chdir to $self->{'build_dir'}");
+ $self->debug("Changed directory to $self->{'build_dir'}")
+ if $CPAN::DEBUG;
+ my $system = join(" ", $CPAN::Config->{'make'},
+ "install", $CPAN::Config->{make_install_arg});
+ my($pipe) = FileHandle->new("$system 2>&1 |");
+ my($makeout) = "";
+ while (<$pipe>){
+ $CPAN::Frontend->myprint($_);
+ $makeout .= $_;
+ }
+ $pipe->close;
+ if ($?==0) {
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+ $self->{'install'} = "YES";
+ } else {
+ $self->{'install'} = "NO";
+ $CPAN::Frontend->myprint(" $system -- NOT OK\n");
+ if ($makeout =~ /permission/s && $> > 0) {
+ $CPAN::Frontend->myprint(qq{ You may have to su }.
+ qq{to root to install the package\n});
+ }
+ }
+}
+
+#-> sub CPAN::Distribution::dir ;
+sub dir {
+ shift->{'build_dir'};
+}
+
+package CPAN::Bundle;
+
+#-> sub CPAN::Bundle::as_string ;
+sub as_string {
+ my($self) = @_;
+ $self->contains;
+ $self->{INST_VERSION} = $self->inst_version;
+ return $self->SUPER::as_string;
+}
+
+#-> sub CPAN::Bundle::contains ;
+sub contains {
+ my($self) = @_;
+ my($parsefile) = $self->inst_file;
+ my($id) = $self->id;
+ $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG;
+ unless ($parsefile) {
+ # Try to get at it in the cpan directory
+ $self->debug("no parsefile") if $CPAN::DEBUG;
+ Carp::confess "I don't know a $id" unless $self->{CPAN_FILE};
+ my $dist = $CPAN::META->instance('CPAN::Distribution',
+ $self->{CPAN_FILE});
+ $dist->get;
+ $self->debug($dist->as_string) if $CPAN::DEBUG;
+ my($todir) = $CPAN::Config->{'cpan_home'};
+ my(@me,$from,$to,$me);
+ @me = split /::/, $self->id;
+ $me[-1] .= ".pm";
+ $me = MM->catfile(@me);
+ $from = $self->find_bundle_file($dist->{'build_dir'},$me);
+ $to = MM->catfile($todir,$me);
+ File::Path::mkpath(File::Basename::dirname($to));
+ File::Copy::copy($from, $to)
+ or Carp::confess("Couldn't copy $from to $to: $!");
+ $parsefile = $to;
+ }
+ my @result;
+ my $fh = FileHandle->new;
+ local $/ = "\n";
+ open($fh,$parsefile) or die "Could not open '$parsefile': $!";
+ my $inpod = 0;
+ $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
+ while (<$fh>) {
+ $inpod = /^=(?!head1\s+CONTENTS)/ ? 0 :
+ /^=head1\s+CONTENTS/ ? 1 : $inpod;
+ next unless $inpod;
+ next if /^=/;
+ next if /^\s+$/;
+ chomp;
+ push @result, (split " ", $_, 2)[0];
+ }
+ close $fh;
+ delete $self->{STATUS};
+ $self->{CONTAINS} = join ", ", @result;
+ $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
+ @result;
+}
+
+#-> sub CPAN::Bundle::find_bundle_file
+sub find_bundle_file {
+ my($self,$where,$what) = @_;
+ $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
+ my $bu = MM->catfile($where,$what);
+ return $bu if -f $bu;
+ my $manifest = MM->catfile($where,"MANIFEST");
+ unless (-f $manifest) {
+ require ExtUtils::Manifest;
+ my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
+ my $cwd = CPAN->$getcwd();
+ chdir $where;
+ ExtUtils::Manifest::mkmanifest();
+ chdir $cwd;
+ }
+ my $fh = FileHandle->new($manifest)
+ or Carp::croak("Couldn't open $manifest: $!");
+ local($/) = "\n";
+ while (<$fh>) {
+ next if /^\s*\#/;
+ my($file) = /(\S+)/;
+ if ($file =~ m|\Q$what\E$|) {
+ $bu = $file;
+ return MM->catfile($where,$bu);
+ } elsif ($what =~ s|Bundle/||) { # retry if she managed to
+ # have no Bundle directory
+ if ($file =~ m|\Q$what\E$|) {
+ $bu = $file;
+ return MM->catfile($where,$bu);
+ }
+ }
+ }
+ Carp::croak("Couldn't find a Bundle file in $where");
+}
+
+#-> sub CPAN::Bundle::inst_file ;
+sub inst_file {
+ my($self) = @_;
+ my($me,$inst_file);
+ ($me = $self->id) =~ s/.*://;
+## my(@me,$inst_file);
+## @me = split /::/, $self->id;
+## $me[-1] .= ".pm";
+ $inst_file = MM->catfile($CPAN::Config->{'cpan_home'},
+ "Bundle", "$me.pm");
+## "Bundle", @me);
+ return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
+# $inst_file =
+ $self->SUPER::inst_file;
+# return $self->{'INST_FILE'} = $inst_file if -f $inst_file;
+# return $self->{'INST_FILE'}; # even if undefined?
+}
+
+#-> sub CPAN::Bundle::rematein ;
+sub rematein {
+ my($self,$meth) = @_;
+ $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
+ my($id) = $self->id;
+ Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
+ unless $self->inst_file || $self->{CPAN_FILE};
+ my($s);
+ for $s ($self->contains) {
+ my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
+ $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
+ if ($type eq 'CPAN::Distribution') {
+ $CPAN::Frontend->mywarn(qq{
+The Bundle }.$self->id.qq{ contains
+explicitly a file $s.
+});
+ sleep 3;
+ }
+ $CPAN::META->instance($type,$s)->$meth();
+ }
+}
+
+#sub CPAN::Bundle::xs_file
+sub xs_file {
+ # If a bundle contains another that contains an xs_file we have
+ # here, we just don't bother I suppose
+ return 0;
+}
+
+#-> sub CPAN::Bundle::force ;
+sub force { shift->rematein('force',@_); }
+#-> sub CPAN::Bundle::get ;
+sub get { shift->rematein('get',@_); }
+#-> sub CPAN::Bundle::make ;
+sub make { shift->rematein('make',@_); }
+#-> sub CPAN::Bundle::test ;
+sub test { shift->rematein('test',@_); }
+#-> sub CPAN::Bundle::install ;
+sub install {
+ my $self = shift;
+ $self->rematein('install',@_);
+ $CPAN::META->delete('CPAN::Queue',$self->id);
+}
+#-> sub CPAN::Bundle::clean ;
+sub clean { shift->rematein('clean',@_); }
+
+#-> sub CPAN::Bundle::readme ;
+sub readme {
+ my($self) = @_;
+ my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
+No File found for bundle } . $self->id . qq{\n}), return;
+ $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
+ $CPAN::META->instance('CPAN::Distribution',$file)->readme;
+}
+
+package CPAN::Module;
+
+#-> sub CPAN::Module::as_glimpse ;
+sub as_glimpse {
+ my($self) = @_;
+ my(@m);
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ push @m, sprintf("%-15s %-15s (%s)\n", $class, $self->{ID},
+ $self->cpan_file);
+ join "", @m;
+}
+
+#-> sub CPAN::Module::as_string ;
+sub as_string {
+ my($self) = @_;
+ my(@m);
+ CPAN->debug($self) if $CPAN::DEBUG;
+ my $class = ref($self);
+ $class =~ s/^CPAN:://;
+ local($^W) = 0;
+ push @m, $class, " id = $self->{ID}\n";
+ my $sprintf = " %-12s %s\n";
+ push @m, sprintf($sprintf, 'DESCRIPTION', $self->{description})
+ if $self->{description};
+ my $sprintf2 = " %-12s %s (%s)\n";
+ my($userid);
+ if ($userid = $self->{'CPAN_USERID'} || $self->{'userid'}){
+ my $author;
+ if ($author = CPAN::Shell->expand('Author',$userid)) {
+ my $email = "";
+ my $m; # old perls
+ if ($m = $author->email) {
+ $email = " <$m>";
+ }
+ push @m, sprintf(
+ $sprintf2,
+ 'CPAN_USERID',
+ $userid,
+ $author->fullname . $email
+ );
+ }
+ }
+ push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
+ if $self->{CPAN_VERSION};
+ push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
+ if $self->{CPAN_FILE};
+ my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
+ my(%statd,%stats,%statl,%stati);
+ @statd{qw,? i c a b R M S,} = qw,unknown idea
+ pre-alpha alpha beta released mature standard,;
+ @stats{qw,? m d u n,} = qw,unknown mailing-list
+ developer comp.lang.perl.* none,;
+ @statl{qw,? p c + o,} = qw,unknown perl C C++ other,;
+ @stati{qw,? f r O,} = qw,unknown functions
+ references+ties object-oriented,;
+ $statd{' '} = 'unknown';
+ $stats{' '} = 'unknown';
+ $statl{' '} = 'unknown';
+ $stati{' '} = 'unknown';
+ push @m, sprintf(
+ $sprintf3,
+ 'DSLI_STATUS',
+ $self->{statd},
+ $self->{stats},
+ $self->{statl},
+ $self->{stati},
+ $statd{$self->{statd}},
+ $stats{$self->{stats}},
+ $statl{$self->{statl}},
+ $stati{$self->{stati}}
+ ) if $self->{statd};
+ my $local_file = $self->inst_file;
+ if ($local_file) {
+ $self->{MANPAGE} ||= $self->manpage_headline($local_file);
+ }
+ my($item);
+ for $item (qw/MANPAGE CONTAINS/) {
+ push @m, sprintf($sprintf, $item, $self->{$item})
+ if exists $self->{$item};
+ }
+ push @m, sprintf($sprintf, 'INST_FILE',
+ $local_file || "(not installed)");
+ push @m, sprintf($sprintf, 'INST_VERSION',
+ $self->inst_version) if $local_file;
+ join "", @m, "\n";
+}
+
+sub manpage_headline {
+ my($self,$local_file) = @_;
+ my(@local_file) = $local_file;
+ $local_file =~ s/\.pm$/.pod/;
+ push @local_file, $local_file;
+ my(@result,$locf);
+ for $locf (@local_file) {
+ next unless -f $locf;
+ my $fh = FileHandle->new($locf)
+ or $Carp::Frontend->mydie("Couldn't open $locf: $!");
+ my $inpod = 0;
+ local $/ = "\n";
+ while (<$fh>) {
+ $inpod = /^=(?!head1\s+NAME)/ ? 0 :
+ /^=head1\s+NAME/ ? 1 : $inpod;
+ next unless $inpod;
+ next if /^=/;
+ next if /^\s+$/;
+ chomp;
+ push @result, $_;
+ }
+ close $fh;
+ last if @result;
+ }
+ join " ", @result;
+}
+
+#-> sub CPAN::Module::cpan_file ;
+sub cpan_file {
+ my $self = shift;
+ CPAN->debug($self->id) if $CPAN::DEBUG;
+ unless (defined $self->{'CPAN_FILE'}) {
+ CPAN::Index->reload;
+ }
+ if (exists $self->{'CPAN_FILE'} && defined $self->{'CPAN_FILE'}){
+ return $self->{'CPAN_FILE'};
+ } elsif (exists $self->{'userid'} && defined $self->{'userid'}) {
+ my $fullname = $CPAN::META->instance(CPAN::Author,
+ $self->{'userid'})->fullname;
+ my $email = $CPAN::META->instance(CPAN::Author,
+ $self->{'userid'})->email;
+ unless (defined $fullname && defined $email) {
+ return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
+ }
+ return "Contact Author $fullname <$email>";
+ } else {
+ return "N/A";
+ }
+}
+
+*name = \&cpan_file;
+
+#-> sub CPAN::Module::cpan_version ;
+sub cpan_version {
+ my $self = shift;
+ $self->{'CPAN_VERSION'} = 'undef'
+ unless defined $self->{'CPAN_VERSION'}; # I believe this is
+ # always a bug in the
+ # index and should be
+ # reported as such,
+ # but usually I find
+ # out such an error
+ # and do not want to
+ # provoke too many
+ # bugreports
+ $self->{'CPAN_VERSION'};
+}
+
+#-> sub CPAN::Module::force ;
+sub force {
+ my($self) = @_;
+ $self->{'force_update'}++;
+}
+
+#-> sub CPAN::Module::rematein ;
+sub rematein {
+ my($self,$meth) = @_;
+ $self->debug($self->id) if $CPAN::DEBUG;
+ my $cpan_file = $self->cpan_file;
+ if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
+ $CPAN::Frontend->mywarn(sprintf qq{
+ The module %s isn\'t available on CPAN.
+
+ Either the module has not yet been uploaded to CPAN, or it is
+ temporary unavailable. Please contact the author to find out
+ more about the status. Try ``i %s''.
+},
+ $self->id,
+ $self->id,
+ );
+ return;
+ }
+ my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
+ $pack->called_for($self->id);
+ $pack->force if exists $self->{'force_update'};
+ $pack->$meth();
+ delete $self->{'force_update'};
+}
+
+#-> sub CPAN::Module::readme ;
+sub readme { shift->rematein('readme') }
+#-> sub CPAN::Module::look ;
+sub look { shift->rematein('look') }
+#-> sub CPAN::Module::get ;
+sub get { shift->rematein('get',@_); }
+#-> sub CPAN::Module::make ;
+sub make { shift->rematein('make') }
+#-> sub CPAN::Module::test ;
+sub test { shift->rematein('test') }
+#-> sub CPAN::Module::install ;
+sub install {
+ my($self) = @_;
+ my($doit) = 0;
+ my($latest) = $self->cpan_version;
+ $latest ||= 0;
+ my($inst_file) = $self->inst_file;
+ my($have) = 0;
+ if (defined $inst_file) {
+ $have = $self->inst_version;
+ }
+ if (1){ # A block for scoping $^W, the if is just for the visual
+ # appeal
+ local($^W)=0;
+ if ($inst_file
+ &&
+ $have >= $latest
+ &&
+ not exists $self->{'force_update'}
+ ) {
+ $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
+ } else {
+ $doit = 1;
+ }
+ }
+ $self->rematein('install') if $doit;
+ $CPAN::META->delete('CPAN::Queue',$self->id);
+}
+#-> sub CPAN::Module::clean ;
+sub clean { shift->rematein('clean') }
+
+#-> sub CPAN::Module::inst_file ;
+sub inst_file {
+ my($self) = @_;
+ my($dir,@packpath);
+ @packpath = split /::/, $self->{ID};
+ $packpath[-1] .= ".pm";
+ foreach $dir (@INC) {
+ my $pmfile = MM->catfile($dir,@packpath);
+ if (-f $pmfile){
+ return $pmfile;
+ }
+ }
+ return;
+}
+
+#-> sub CPAN::Module::xs_file ;
+sub xs_file {
+ my($self) = @_;
+ my($dir,@packpath);
+ @packpath = split /::/, $self->{ID};
+ push @packpath, $packpath[-1];
+ $packpath[-1] .= "." . $Config::Config{'dlext'};
+ foreach $dir (@INC) {
+ my $xsfile = MM->catfile($dir,'auto',@packpath);
+ if (-f $xsfile){
+ return $xsfile;
+ }
+ }
+ return;
+}
+
+#-> sub CPAN::Module::inst_version ;
+sub inst_version {
+ my($self) = @_;
+ my $parsefile = $self->inst_file or return;
+ local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
+ my $have = MM->parse_version($parsefile) || "undef";
+ $have =~ s/\s+//g;
+ $have;
+}
+
+package CPAN::Tarzip;
+
+sub gzip {
+ my($class,$read,$write) = @_;
+ if ($CPAN::META->has_inst("Compress::Zlib")) {
+ my($buffer,$fhw);
+ $fhw = FileHandle->new($read)
+ or $CPAN::Frontend->mydie("Could not open $read: $!");
+ my $gz = Compress::Zlib::gzopen($write, "wb")
+ or $CPAN::Frontend->mydie("Cannot gzopen $write: $!\n");
+ $gz->gzwrite($buffer)
+ while read($fhw,$buffer,4096) > 0 ;
+ $gz->gzclose() ;
+ $fhw->close;
+ return 1;
+ } else {
+ system("$CPAN::Config->{'gzip'} -c $read > $write")==0;
+ }
+}
+
+sub gunzip {
+ my($class,$read,$write) = @_;
+ if ($CPAN::META->has_inst("Compress::Zlib")) {
+ my($buffer,$fhw);
+ $fhw = FileHandle->new(">$write")
+ or $CPAN::Frontend->mydie("Could not open >$write: $!");
+ my $gz = Compress::Zlib::gzopen($read, "rb")
+ or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
+ $fhw->print($buffer)
+ while $gz->gzread($buffer) > 0 ;
+ $CPAN::Frontend->mydie("Error reading from $read: $!\n")
+ if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
+ $gz->gzclose() ;
+ $fhw->close;
+ return 1;
+ } else {
+ system("$CPAN::Config->{'gzip'} -dc $read > $write")==0;
+ }
+}
+
+sub gtest {
+ my($class,$read) = @_;
+ if ($CPAN::META->has_inst("Compress::Zlib")) {
+ my($buffer);
+ my $gz = Compress::Zlib::gzopen($read, "rb")
+ or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
+ 1 while $gz->gzread($buffer) > 0 ;
+ $CPAN::Frontend->mydie("Error reading from $read: $!\n")
+ if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
+ $gz->gzclose() ;
+ return 1;
+ } else {
+ return system("$CPAN::Config->{'gzip'} -dt $read")==0;
+ }
+}
+
+sub TIEHANDLE {
+ my($class,$file) = @_;
+ my $ret;
+ $class->debug("file[$file]");
+ if ($CPAN::META->has_inst("Compress::Zlib")) {
+ my $gz = Compress::Zlib::gzopen($file,"rb") or
+ die "Could not gzopen $file";
+ $ret = bless {GZ => $gz}, $class;
+ } else {
+ my $pipe = "$CPAN::Config->{'gzip'} --decompress --stdout $file |";
+ my $fh = FileHandle->new($pipe) or die "Could pipe[$pipe]: $!";
+ binmode $fh;
+ $ret = bless {FH => $fh}, $class;
+ }
+ $ret;
+}
+
+sub READLINE {
+ my($self) = @_;
+ if (exists $self->{GZ}) {
+ my $gz = $self->{GZ};
+ my($line,$bytesread);
+ $bytesread = $gz->gzreadline($line);
+ return undef if $bytesread == 0;
+ return $line;
+ } else {
+ my $fh = $self->{FH};
+ return scalar <$fh>;
+ }
+}
+
+sub READ {
+ my($self,$ref,$length,$offset) = @_;
+ die "read with offset not implemented" if defined $offset;
+ if (exists $self->{GZ}) {
+ my $gz = $self->{GZ};
+ my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
+ return $byteread;
+ } else {
+ my $fh = $self->{FH};
+ return read($fh,$$ref,$length);
+ }
+}
+
+sub DESTROY {
+ my($self) = @_;
+ if (exists $self->{GZ}) {
+ my $gz = $self->{GZ};
+ $gz->gzclose();
+ } else {
+ my $fh = $self->{FH};
+ $fh->close;
+ }
+ undef $self;
+}
+
+sub untar {
+ my($class,$file) = @_;
+ # had to disable, because version 0.07 seems to be buggy
+ if (MM->maybe_command($CPAN::Config->{'gzip'})
+ &&
+ MM->maybe_command($CPAN::Config->{'tar'})) {
+ my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
+ "$file | $CPAN::Config->{tar} xvf -";
+ return system($system) == 0;
+ } elsif ($CPAN::META->has_inst("Archive::Tar")
+ &&
+ $CPAN::META->has_inst("Compress::Zlib") ) {
+ my $tar = Archive::Tar->new($file,1);
+ $tar->extract($tar->list_files); # I'm pretty sure we have nothing
+ # that isn't compressed
+ return 1;
+ } else {
+ $CPAN::Frontend->mydie(qq{
+CPAN.pm needs either both external programs tar and gzip installed or
+both the modules Archive::Tar and Compress::Zlib. Neither prerequisite
+is available. Can\'t continue.
+});
+ }
+}
+
+package CPAN;
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN - query, download and build perl modules from CPAN sites
+
+=head1 SYNOPSIS
+
+Interactive mode:
+
+ perl -MCPAN -e shell;
+
+Batch mode:
+
+ use CPAN;
+
+ autobundle, clean, install, make, recompile, test
+
+=head1 DESCRIPTION
+
+The CPAN module is designed to automate the make and install of perl
+modules and extensions. It includes some searching capabilities and
+knows how to use Net::FTP or LWP (or lynx or an external ftp client)
+to fetch the raw data from the net.
+
+Modules are fetched from one or more of the mirrored CPAN
+(Comprehensive Perl Archive Network) sites and unpacked in a dedicated
+directory.
+
+The CPAN module also supports the concept of named and versioned
+'bundles' of modules. Bundles simplify the handling of sets of
+related modules. See BUNDLES below.
+
+The package contains a session manager and a cache manager. There is
+no status retained between sessions. The session manager keeps track
+of what has been fetched, built and installed in the current
+session. The cache manager keeps track of the disk space occupied by
+the make processes and deletes excess space according to a simple FIFO
+mechanism.
+
+All methods provided are accessible in a programmer style and in an
+interactive shell style.
+
+=head2 Interactive Mode
+
+The interactive mode is entered by running
+
+ perl -MCPAN -e shell
+
+which puts you into a readline interface. You will have the most fun if
+you install Term::ReadKey and Term::ReadLine to enjoy both history and
+command completion.
+
+Once you are on the command line, type 'h' and the rest should be
+self-explanatory.
+
+The most common uses of the interactive modes are
+
+=over 2
+
+=item Searching for authors, bundles, distribution files and modules
+
+There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
+for each of the four categories and another, C<i> for any of the
+mentioned four. Each of the four entities is implemented as a class
+with slightly differing methods for displaying an object.
+
+Arguments you pass to these commands are either strings exactly matching
+the identification string of an object or regular expressions that are
+then matched case-insensitively against various attributes of the
+objects. The parser recognizes a regular expression only if you
+enclose it between two slashes.
+
+The principle is that the number of found objects influences how an
+item is displayed. If the search finds one item, the result is displayed
+as object-E<gt>as_string, but if we find more than one, we display
+each as object-E<gt>as_glimpse. E.g.
+
+ cpan> a ANDK
+ Author id = ANDK
+ EMAIL a.koenig@franz.ww.TU-Berlin.DE
+ FULLNAME Andreas König
+
+
+ cpan> a /andk/
+ Author id = ANDK
+ EMAIL a.koenig@franz.ww.TU-Berlin.DE
+ FULLNAME Andreas König
+
+
+ cpan> a /and.*rt/
+ Author ANDYD (Andy Dougherty)
+ Author MERLYN (Randal L. Schwartz)
+
+=item make, test, install, clean modules or distributions
+
+These commands take any number of arguments and investigate what is
+necessary to perform the action. If the argument is a distribution
+file name (recognized by embedded slashes), it is processed. If it is a
+module, CPAN determines the distribution file in which this module is
+included and processes that.
+
+Any C<make> or C<test> are run unconditionally. An
+
+ install <distribution_file>
+
+also is run unconditionally. But for
+
+ install <module>
+
+CPAN checks if an install is actually needed for it and prints
+I<module up to date> in the case that the distribution file containing
+the module doesnE<39>t need to be updated.
+
+CPAN also keeps track of what it has done within the current session
+and doesnE<39>t try to build a package a second time regardless if it
+succeeded or not. The C<force> command takes as a first argument the
+method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
+command from scratch.
+
+Example:
+
+ cpan> install OpenGL
+ OpenGL is up to date.
+ cpan> force install OpenGL
+ Running make
+ OpenGL-0.4/
+ OpenGL-0.4/COPYRIGHT
+ [...]
+
+A C<clean> command results in a
+
+ make clean
+
+being executed within the distribution file's working directory.
+
+=item readme, look module or distribution
+
+These two commands take only one argument, be it a module or a
+distribution file. C<readme> unconditionally runs, displaying the
+README of the associated distribution file. C<Look> gets and
+untars (if not yet done) the distribution file, changes to the
+appropriate directory and opens a subshell process in that directory.
+
+=item Signals
+
+CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
+in the cpan-shell it is intended that you can press C<^C> anytime and
+return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
+to clean up and leave the shell loop. You can emulate the effect of a
+SIGTERM by sending two consecutive SIGINTs, which usually means by
+pressing C<^C> twice.
+
+CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
+SIGALRM is used during the run of the C<perl Makefile.PL> subprocess.
+
+=back
+
+=head2 CPAN::Shell
+
+The commands that are available in the shell interface are methods in
+the package CPAN::Shell. If you enter the shell command, all your
+input is split by the Text::ParseWords::shellwords() routine which
+acts like most shells do. The first word is being interpreted as the
+method to be called and the rest of the words are treated as arguments
+to this method. Continuation lines are supported if a line ends with a
+literal backslash.
+
+=head2 autobundle
+
+C<autobundle> writes a bundle file into the
+C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
+a list of all modules that are both available from CPAN and currently
+installed within @INC. The name of the bundle file is based on the
+current date and a counter.
+
+=head2 recompile
+
+recompile() is a very special command in that it takes no argument and
+runs the make/test/install cycle with brute force over all installed
+dynamically loadable extensions (aka XS modules) with 'force' in
+effect. The primary purpose of this command is to finish a network
+installation. Imagine, you have a common source tree for two different
+architectures. You decide to do a completely independent fresh
+installation. You start on one architecture with the help of a Bundle
+file produced earlier. CPAN installs the whole Bundle for you, but
+when you try to repeat the job on the second architecture, CPAN
+responds with a C<"Foo up to date"> message for all modules. So you
+invoke CPAN's recompile on the second architecture and youE<39>re done.
+
+Another popular use for C<recompile> is to act as a rescue in case your
+perl breaks binary compatibility. If one of the modules that CPAN uses
+is in turn depending on binary compatibility (so you cannot run CPAN
+commands), then you should try the CPAN::Nox module for recovery.
+
+=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
+
+Although it may be considered internal, the class hierarchy does matter
+for both users and programmer. CPAN.pm deals with above mentioned four
+classes, and all those classes share a set of methods. A classical
+single polymorphism is in effect. A metaclass object registers all
+objects of all kinds and indexes them with a string. The strings
+referencing objects have a separated namespace (well, not completely
+separated):
+
+ Namespace Class
+
+ words containing a "/" (slash) Distribution
+ words starting with Bundle:: Bundle
+ everything else Module or Author
+
+Modules know their associated Distribution objects. They always refer
+to the most recent official release. Developers may mark their releases
+as unstable development versions (by inserting an underbar into the
+visible version number), so the really hottest and newest distribution
+file is not always the default. If a module Foo circulates on CPAN in
+both version 1.23 and 1.23_90, CPAN.pm offers a convenient way to
+install version 1.23 by saying
+
+ install Foo
+
+This would install the complete distribution file (say
+BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
+like to install version 1.23_90, you need to know where the
+distribution file resides on CPAN relative to the authors/id/
+directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
+so you would have to say
+
+ install BAR/Foo-1.23_90.tar.gz
+
+The first example will be driven by an object of the class
+CPAN::Module, the second by an object of class CPAN::Distribution.
+
+=head2 ProgrammerE<39>s interface
+
+If you do not enter the shell, the available shell commands are both
+available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
+functions in the calling package (C<install(...)>).
+
+There's currently only one class that has a stable interface -
+CPAN::Shell. All commands that are available in the CPAN shell are
+methods of the class CPAN::Shell. Each of the commands that produce
+listings of modules (C<r>, C<autobundle>, C<u>) returns a list of the
+IDs of all modules within the list.
+
+=over 2
+
+=item expand($type,@things)
+
+The IDs of all objects available within a program are strings that can
+be expanded to the corresponding real objects with the
+C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
+list of CPAN::Module objects according to the C<@things> arguments
+given. In scalar context it only returns the first element of the
+list.
+
+=item Programming Examples
+
+This enables the programmer to do operations that combine
+functionalities that are available in the shell.
+
+ # install everything that is outdated on my disk:
+ perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
+
+ # install my favorite programs if necessary:
+ for $mod (qw(Net::FTP MD5 Data::Dumper)){
+ my $obj = CPAN::Shell->expand('Module',$mod);
+ $obj->install;
+ }
+
+ # list all modules on my disk that have no VERSION number
+ for $mod (CPAN::Shell->expand("Module","/./")){
+ next unless $mod->inst_file;
+ # MakeMaker convention for undefined $VERSION:
+ next unless $mod->inst_version eq "undef";
+ print "No VERSION in ", $mod->id, "\n";
+ }
+
+=back
+
+=head2 Methods in the four
+
+=head2 Cache Manager
+
+Currently the cache manager only keeps track of the build directory
+($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
+deletes complete directories below C<build_dir> as soon as the size of
+all directories there gets bigger than $CPAN::Config->{build_cache}
+(in MB). The contents of this cache may be used for later
+re-installations that you intend to do manually, but will never be
+trusted by CPAN itself. This is due to the fact that the user might
+use these directories for building modules on different architectures.
+
+There is another directory ($CPAN::Config->{keep_source_where}) where
+the original distribution files are kept. This directory is not
+covered by the cache manager and must be controlled by the user. If
+you choose to have the same directory as build_dir and as
+keep_source_where directory, then your sources will be deleted with
+the same fifo mechanism.
+
+=head2 Bundles
+
+A bundle is just a perl module in the namespace Bundle:: that does not
+define any functions or methods. It usually only contains documentation.
+
+It starts like a perl module with a package declaration and a $VERSION
+variable. After that the pod section looks like any other pod with the
+only difference being that I<one special pod section> exists starting with
+(verbatim):
+
+ =head1 CONTENTS
+
+In this pod section each line obeys the format
+
+ Module_Name [Version_String] [- optional text]
+
+The only required part is the first field, the name of a module
+(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
+of the line is optional. The comment part is delimited by a dash just
+as in the man page header.
+
+The distribution of a bundle should follow the same convention as
+other distributions.
+
+Bundles are treated specially in the CPAN package. If you say 'install
+Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
+the modules in the CONTENTS section of the pod. You can install your
+own Bundles locally by placing a conformant Bundle file somewhere into
+your @INC path. The autobundle() command which is available in the
+shell interface does that for you by including all currently installed
+modules in a snapshot bundle file.
+
+=head2 Prerequisites
+
+If you have a local mirror of CPAN and can access all files with
+"file:" URLs, then you only need a perl better than perl5.003 to run
+this module. Otherwise Net::FTP is strongly recommended. LWP may be
+required for non-UNIX systems or if your nearest CPAN site is
+associated with an URL that is not C<ftp:>.
+
+If you have neither Net::FTP nor LWP, there is a fallback mechanism
+implemented for an external ftp command or for an external lynx
+command.
+
+=head2 Finding packages and VERSION
+
+This module presumes that all packages on CPAN
+
+=over 2
+
+=item *
+
+declare their $VERSION variable in an easy to parse manner. This
+prerequisite can hardly be relaxed because it consumes far too much
+memory to load all packages into the running program just to determine
+the $VERSION variable. Currently all programs that are dealing with
+version use something like this
+
+ perl -MExtUtils::MakeMaker -le \
+ 'print MM->parse_version($ARGV[0])' filename
+
+If you are author of a package and wonder if your $VERSION can be
+parsed, please try the above method.
+
+=item *
+
+come as compressed or gzipped tarfiles or as zip files and contain a
+Makefile.PL (well, we try to handle a bit more, but without much
+enthusiasm).
+
+=back
+
+=head2 Debugging
+
+The debugging of this module is pretty difficult, because we have
+interferences of the software producing the indices on CPAN, of the
+mirroring process on CPAN, of packaging, of configuration, of
+synchronicity, and of bugs within CPAN.pm.
+
+In interactive mode you can try "o debug" which will list options for
+debugging the various parts of the package. The output may not be very
+useful for you as it's just a by-product of my own testing, but if you
+have an idea which part of the package may have a bug, it's sometimes
+worth to give it a try and send me more specific output. You should
+know that "o debug" has built-in completion support.
+
+=head2 Floppy, Zip, and all that Jazz
+
+CPAN.pm works nicely without network too. If you maintain machines
+that are not networked at all, you should consider working with file:
+URLs. Of course, you have to collect your modules somewhere first. So
+you might use CPAN.pm to put together all you need on a networked
+machine. Then copy the $CPAN::Config->{keep_source_where} (but not
+$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
+of a personal CPAN. CPAN.pm on the non-networked machines works nicely
+with this floppy.
+
+=head1 CONFIGURATION
+
+When the CPAN module is installed, a site wide configuration file is
+created as CPAN/Config.pm. The default values defined there can be
+overridden in another configuration file: CPAN/MyConfig.pm. You can
+store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
+$HOME/.cpan is added to the search path of the CPAN module before the
+use() or require() statements.
+
+Currently the following keys in the hash reference $CPAN::Config are
+defined:
+
+ build_cache size of cache for directories to build modules
+ build_dir locally accessible directory to build modules
+ index_expire after this many days refetch index files
+ cpan_home local directory reserved for this package
+ gzip location of external program gzip
+ inactivity_timeout breaks interactive Makefile.PLs after this
+ many seconds inactivity. Set to 0 to never break.
+ inhibit_startup_message
+ if true, does not print the startup message
+ keep_source keep the source in a local directory?
+ keep_source_where directory in which to keep the source (if we do)
+ make location of external make program
+ make_arg arguments that should always be passed to 'make'
+ make_install_arg same as make_arg for 'make install'
+ makepl_arg arguments passed to 'perl Makefile.PL'
+ pager location of external program more (or any pager)
+ tar location of external program tar
+ unzip location of external program unzip
+ urllist arrayref to nearby CPAN sites (or equivalent locations)
+ wait_list arrayref to a wait server to try (See CPAN::WAIT)
+
+You can set and query each of these options interactively in the cpan
+shell with the command set defined within the C<o conf> command:
+
+=over 2
+
+=item o conf E<lt>scalar optionE<gt>
+
+prints the current value of the I<scalar option>
+
+=item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
+
+Sets the value of the I<scalar option> to I<value>
+
+=item o conf E<lt>list optionE<gt>
+
+prints the current value of the I<list option> in MakeMaker's
+neatvalue format.
+
+=item o conf E<lt>list optionE<gt> [shift|pop]
+
+shifts or pops the array in the I<list option> variable
+
+=item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
+
+works like the corresponding perl commands.
+
+=back
+
+=head2 CD-ROM support
+
+The C<urllist> parameter of the configuration table contains a list of
+URLs that are to be used for downloading. If the list contains any
+C<file> URLs, CPAN always tries to get files from there first. This
+feature is disabled for index files. So the recommendation for the
+owner of a CD-ROM with CPAN contents is: include your local, possibly
+outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
+
+ o conf urllist push file://localhost/CDROM/CPAN
+
+CPAN.pm will then fetch the index files from one of the CPAN sites
+that come at the beginning of urllist. It will later check for each
+module if there is a local copy of the most recent version.
+
+=head1 SECURITY
+
+There's no strong security layer in CPAN.pm. CPAN.pm helps you to
+install foreign, unmasked, unsigned code on your machine. We compare
+to a checksum that comes from the net just as the distribution file
+itself. If somebody has managed to tamper with the distribution file,
+they may have as well tampered with the CHECKSUMS file. Future
+development will go towards strong authentification.
+
+=head1 EXPORT
+
+Most functions in package CPAN are exported per default. The reason
+for this is that the primary use is intended for the cpan shell or for
+oneliners.
+
+=head1 BUGS
+
+We should give coverage for _all_ of the CPAN and not just the PAUSE
+part, right? In this discussion CPAN and PAUSE have become equal --
+but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus
+the clpa/, doc/, misc/, ports/, src/, scripts/.
+
+Future development should be directed towards a better integration of
+the other parts.
+
+If a Makefile.PL requires special customization of libraries, prompts
+the user for special input, etc. then you may find CPAN is not able to
+build the distribution. In that case, you should attempt the
+traditional method of building a Perl module package from a shell.
+
+=head1 AUTHOR
+
+Andreas König E<lt>a.koenig@mind.deE<gt>
+
+=head1 SEE ALSO
+
+perl(1), CPAN::Nox(3)
+
+=cut
+
diff --git a/contrib/perl5/lib/CPAN/FirstTime.pm b/contrib/perl5/lib/CPAN/FirstTime.pm
new file mode 100644
index 000000000000..aa7a55d195bc
--- /dev/null
+++ b/contrib/perl5/lib/CPAN/FirstTime.pm
@@ -0,0 +1,439 @@
+package CPAN::Mirrored::By;
+
+sub new {
+ my($self,@arg) = @_;
+ bless [@arg], $self;
+}
+sub continent { shift->[0] }
+sub country { shift->[1] }
+sub url { shift->[2] }
+
+package CPAN::FirstTime;
+
+use strict;
+use ExtUtils::MakeMaker qw(prompt);
+use FileHandle ();
+use File::Basename ();
+use File::Path ();
+use vars qw($VERSION);
+$VERSION = substr q$Revision: 1.29 $, 10;
+
+=head1 NAME
+
+CPAN::FirstTime - Utility for CPAN::Config file Initialization
+
+=head1 SYNOPSIS
+
+CPAN::FirstTime::init()
+
+=head1 DESCRIPTION
+
+The init routine asks a few questions and writes a CPAN::Config
+file. Nothing special.
+
+=cut
+
+
+sub init {
+ my($configpm) = @_;
+ use Config;
+ require CPAN::Nox;
+ eval {require CPAN::Config;};
+ $CPAN::Config ||= {};
+ local($/) = "\n";
+ local($\) = "";
+ local($|) = 1;
+
+ my($ans,$default,$local,$cont,$url,$expected_size);
+
+ #
+ # Files, directories
+ #
+
+ print qq{
+
+CPAN is the world-wide archive of perl resources. It consists of about
+100 sites that all replicate the same contents all around the globe.
+Many countries have at least one CPAN site already. The resources
+found on CPAN are easily accessible with the CPAN.pm module. If you
+want to use CPAN.pm, you have to configure it properly.
+
+If you do not want to enter a dialog now, you can answer 'no' to this
+question and I\'ll try to autoconfigure. (Note: you can revisit this
+dialog anytime later by typing 'o conf init' at the cpan prompt.)
+
+};
+
+ my $manual_conf =
+ ExtUtils::MakeMaker::prompt("Are you ready for manual configuration?",
+ "yes");
+ my $fastread;
+ {
+ local $^W;
+ if ($manual_conf =~ /^\s*y/i) {
+ $fastread = 0;
+ *prompt = \&ExtUtils::MakeMaker::prompt;
+ } else {
+ $fastread = 1;
+ *prompt = sub {
+ my($q,$a) = @_;
+ my($ret) = defined $a ? $a : "";
+ printf qq{%s [%s]\n\n}, $q, $ret;
+ $ret;
+ };
+ }
+ }
+ print qq{
+
+The following questions are intended to help you with the
+configuration. The CPAN module needs a directory of its own to cache
+important index files and maybe keep a temporary mirror of CPAN files.
+This may be a site-wide directory or a personal directory.
+
+};
+
+ my $cpan_home = $CPAN::Config->{cpan_home} || MM->catdir($ENV{HOME}, ".cpan");
+ if (-d $cpan_home) {
+ print qq{
+
+I see you already have a directory
+ $cpan_home
+Shall we use it as the general CPAN build and cache directory?
+
+};
+ } else {
+ print qq{
+
+First of all, I\'d like to create this directory. Where?
+
+};
+ }
+
+ $default = $cpan_home;
+ while ($ans = prompt("CPAN build and cache directory?",$default)) {
+ File::Path::mkpath($ans); # dies if it can't
+ if (-d $ans && -w _) {
+ last;
+ } else {
+ warn "Couldn't find directory $ans
+ or directory is not writable. Please retry.\n";
+ }
+ }
+ $CPAN::Config->{cpan_home} = $ans;
+
+ print qq{
+
+If you want, I can keep the source files after a build in the cpan
+home directory. If you choose so then future builds will take the
+files from there. If you don\'t want to keep them, answer 0 to the
+next question.
+
+};
+
+ $CPAN::Config->{keep_source_where} = MM->catdir($CPAN::Config->{cpan_home},"sources");
+ $CPAN::Config->{build_dir} = MM->catdir($CPAN::Config->{cpan_home},"build");
+
+ #
+ # Cache size, Index expire
+ #
+
+ print qq{
+
+How big should the disk cache be for keeping the build directories
+with all the intermediate files?
+
+};
+
+ $default = $CPAN::Config->{build_cache} || 10;
+ $ans = prompt("Cache size for build directory (in MB)?", $default);
+ $CPAN::Config->{build_cache} = $ans;
+
+ # XXX This the time when we refetch the index files (in days)
+ $CPAN::Config->{'index_expire'} = 1;
+
+ #
+ # External programs
+ #
+
+ print qq{
+
+The CPAN module will need a few external programs to work
+properly. Please correct me, if I guess the wrong path for a program.
+Don\'t panic if you do not have some of them, just press ENTER for
+those.
+
+};
+
+ my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'};
+ my $progname;
+ for $progname (qw/gzip tar unzip make lynx ncftp ftp/){
+ my $progcall = $progname;
+ my $path = $CPAN::Config->{$progname}
+ || $Config::Config{$progname}
+ || "";
+ if (MM->file_name_is_absolute($path)) {
+ # testing existence is not good enough, some have these exe
+ # extensions
+
+ # warn "Warning: configured $path does not exist\n" unless -e $path;
+ # $path = "";
+ } else {
+ $path = '';
+ }
+ unless ($path) {
+ # e.g. make -> nmake
+ $progcall = $Config::Config{$progname} if $Config::Config{$progname};
+ }
+
+ $path ||= find_exe($progcall,[@path]);
+ warn "Warning: $progcall not found in PATH\n" unless
+ $path; # not -e $path, because find_exe already checked that
+ $ans = prompt("Where is your $progname program?",$path) || $path;
+ $CPAN::Config->{$progname} = $ans;
+ }
+ my $path = $CPAN::Config->{'pager'} ||
+ $ENV{PAGER} || find_exe("less",[@path]) ||
+ find_exe("more",[@path]) || "more";
+ $ans = prompt("What is your favorite pager program?",$path);
+ $CPAN::Config->{'pager'} = $ans;
+ $path = $CPAN::Config->{'shell'};
+ if (MM->file_name_is_absolute($path)) {
+ warn "Warning: configured $path does not exist\n" unless -e $path;
+ $path = "";
+ }
+ $path ||= $ENV{SHELL};
+ $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only
+ $ans = prompt("What is your favorite shell?",$path);
+ $CPAN::Config->{'shell'} = $ans;
+
+ #
+ # Arguments to make etc.
+ #
+
+ print qq{
+
+Every Makefile.PL is run by perl in a separate process. Likewise we
+run \'make\' and \'make install\' in processes. If you have any parameters
+\(e.g. PREFIX, INSTALLPRIVLIB, UNINST or the like\) you want to pass to
+the calls, please specify them here.
+
+If you don\'t understand this question, just press ENTER.
+
+};
+
+ $default = $CPAN::Config->{makepl_arg} || "";
+ $CPAN::Config->{makepl_arg} =
+ prompt("Parameters for the 'perl Makefile.PL' command?",$default);
+ $default = $CPAN::Config->{make_arg} || "";
+ $CPAN::Config->{make_arg} = prompt("Parameters for the 'make' command?",$default);
+
+ $default = $CPAN::Config->{make_install_arg} || $CPAN::Config->{make_arg} || "";
+ $CPAN::Config->{make_install_arg} =
+ prompt("Parameters for the 'make install' command?",$default);
+
+ #
+ # Alarm period
+ #
+
+ print qq{
+
+Sometimes you may wish to leave the processes run by CPAN alone
+without caring about them. As sometimes the Makefile.PL contains
+question you\'re expected to answer, you can set a timer that will
+kill a 'perl Makefile.PL' process after the specified time in seconds.
+
+If you set this value to 0, these processes will wait forever. This is
+the default and recommended setting.
+
+};
+
+ $default = $CPAN::Config->{inactivity_timeout} || 0;
+ $CPAN::Config->{inactivity_timeout} =
+ prompt("Timeout for inactivity during Makefile.PL?",$default);
+
+ # Proxies
+
+ print qq{
+
+If you\'re accessing the net via proxies, you can specify them in the
+CPAN configuration or via environment variables. The variable in
+the \$CPAN::Config takes precedence.
+
+};
+
+ for (qw/ftp_proxy http_proxy no_proxy/) {
+ $default = $CPAN::Config->{$_} || $ENV{$_};
+ $CPAN::Config->{$_} = prompt("Your $_?",$default);
+ }
+
+ #
+ # MIRRORED.BY
+ #
+
+ conf_sites() unless $fastread;
+
+ unless (@{$CPAN::Config->{'wait_list'}||[]}) {
+ print qq{
+
+WAIT support is available as a Plugin. You need the CPAN::WAIT module
+to actually use it. But we need to know your favorite WAIT server. If
+you don\'t know a WAIT server near you, just press ENTER.
+
+};
+ $default = "wait://ls6.informatik.uni-dortmund.de:1404";
+ $ans = prompt("Your favorite WAIT server?\n ",$default);
+ push @{$CPAN::Config->{'wait_list'}}, $ans;
+ }
+
+ # We don't ask that now, it will be noticed in time, won't it?
+ $CPAN::Config->{'inhibit_startup_message'} = 0;
+ $CPAN::Config->{'getcwd'} = 'cwd';
+
+ print "\n\n";
+ CPAN::Config->commit($configpm);
+}
+
+sub conf_sites {
+ my $m = 'MIRRORED.BY';
+ my $mby = MM->catfile($CPAN::Config->{keep_source_where},$m);
+ File::Path::mkpath(File::Basename::dirname($mby));
+ if (-f $mby && -f $m && -M $m < -M $mby) {
+ require File::Copy;
+ File::Copy::copy($m,$mby) or die "Could not update $mby: $!";
+ }
+ if ( ! -f $mby ){
+ print qq{You have no $mby
+ I\'m trying to fetch one
+};
+ $mby = CPAN::FTP->localize($m,$mby,3);
+ } elsif (-M $mby > 30 ) {
+ print qq{Your $mby is older than 30 days,
+ I\'m trying to fetch one
+};
+ $mby = CPAN::FTP->localize($m,$mby,3);
+ }
+ read_mirrored_by($mby);
+}
+
+sub find_exe {
+ my($exe,$path) = @_;
+ my($dir);
+ #warn "in find_exe exe[$exe] path[@$path]";
+ for $dir (@$path) {
+ my $abs = MM->catfile($dir,$exe);
+ if (($abs = MM->maybe_command($abs))) {
+ return $abs;
+ }
+ }
+}
+
+sub read_mirrored_by {
+ my($local) = @_;
+ my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location);
+ my $fh = FileHandle->new;
+ $fh->open($local) or die "Couldn't open $local: $!";
+ while (<$fh>) {
+ ($host) = /^([\w\.\-]+)/ unless defined $host;
+ next unless defined $host;
+ next unless /\s+dst_(dst|location)/;
+ /location\s+=\s+\"([^\"]+)/ and @location = (split /\s*,\s*/, $1) and
+ ($continent, $country) = @location[-1,-2];
+ $continent =~ s/\s\(.*//;
+ /dst_dst\s+=\s+\"([^\"]+)/ and $dst = $1;
+ next unless $host && $dst && $continent && $country;
+ $all{$continent}{$country}{$dst} = CPAN::Mirrored::By->new($continent,$country,$dst);
+ undef $host;
+ $dst=$continent=$country="";
+ }
+ $fh->close;
+ $CPAN::Config->{urllist} ||= [];
+ if ($expected_size = @{$CPAN::Config->{urllist}}) {
+ for $url (@{$CPAN::Config->{urllist}}) {
+ # sanity check, scheme+colon, not "q" there:
+ next unless $url =~ /^\w+:\/./;
+ $all{"[From previous setup]"}{"found URL"}{$url}=CPAN::Mirrored::By->new('[From previous setup]','found URL',$url);
+ }
+ $CPAN::Config->{urllist} = [];
+ } else {
+ $expected_size = 6;
+ }
+
+ print qq{
+
+Now we need to know, where your favorite CPAN sites are located. Push
+a few sites onto the array (just in case the first on the array won\'t
+work). If you are mirroring CPAN to your local workstation, specify a
+file: URL.
+
+You can enter the number in front of the URL on the next screen, a
+file:, ftp: or http: URL, or "q" to finish selecting.
+
+};
+
+ $ans = prompt("Press RETURN to continue");
+ my $other;
+ $ans = $other = "";
+ my(%seen);
+
+ my $pipe = -t *STDIN ? "| $CPAN::Config->{'pager'}" : ">/dev/null";
+ while () {
+ my(@valid,$previous_best);
+ my $fh = FileHandle->new;
+ $fh->open($pipe);
+ {
+ my($cont,$country,$url,$item);
+ my(@cont) = sort keys %all;
+ for $cont (@cont) {
+ $fh->print(" $cont\n");
+ for $country (sort {lc $a cmp lc $b} keys %{$all{$cont}}) {
+ for $url (sort {lc $a cmp lc $b} keys %{$all{$cont}{$country}}) {
+ my $t = sprintf(
+ " %-16s (%2d) %s\n",
+ $country,
+ ++$item,
+ $url
+ );
+ if ($cont =~ /^\[/) {
+ $previous_best ||= $item;
+ }
+ push @valid, $all{$cont}{$country}{$url};
+ $fh->print($t);
+ }
+ }
+ }
+ }
+ $fh->close;
+ $previous_best ||= "";
+ $default =
+ @{$CPAN::Config->{urllist}} >=
+ $expected_size ? "q" : $previous_best;
+ $ans = prompt(
+ "\nSelect an$other ftp or file URL or a number (q to finish)",
+ $default
+ );
+ my $sel;
+ if ($ans =~ /^\d/) {
+ my $this = $valid[$ans-1];
+ my($con,$cou,$url) = ($this->continent,$this->country,$this->url);
+ push @{$CPAN::Config->{urllist}}, $url unless $seen{$url}++;
+ delete $all{$con}{$cou}{$url};
+ # print "Was a number [$ans] con[$con] cou[$cou] url[$url]\n";
+ } elsif ($ans =~ /^q/i) {
+ last;
+ } else {
+ $ans =~ s|/?$|/|; # has to end with one slash
+ $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file:
+ if ($ans =~ /^\w+:\/./) {
+ push @{$CPAN::Config->{urllist}}, $ans unless $seen{$ans}++;
+ } else {
+ print qq{"$ans" doesn\'t look like an URL at first sight.
+I\'ll ignore it for now. You can add it to lib/CPAN/Config.pm
+later and report a bug in my Makefile.PL to me (andreas koenig).
+Thanks.\n};
+ }
+ }
+ $other ||= "other";
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/CPAN/Nox.pm b/contrib/perl5/lib/CPAN/Nox.pm
new file mode 100644
index 000000000000..c4016a44ac08
--- /dev/null
+++ b/contrib/perl5/lib/CPAN/Nox.pm
@@ -0,0 +1,34 @@
+BEGIN{$CPAN::Suppress_readline=1 unless defined $CPAN::term;}
+
+use CPAN;
+
+$CPAN::META->has_inst('MD5','no');
+$CPAN::META->has_inst('LWP','no');
+$CPAN::META->has_inst('Compress::Zlib','no');
+@EXPORT = @CPAN::EXPORT;
+
+*AUTOLOAD = \&CPAN::AUTOLOAD;
+
+=head1 NAME
+
+CPAN::Nox - Wrapper around CPAN.pm without using any XS module
+
+=head1 SYNOPSIS
+
+Interactive mode:
+
+ perl -MCPAN::Nox -e shell;
+
+=head1 DESCRIPTION
+
+This package has the same functionality as CPAN.pm, but tries to
+prevent the usage of compiled extensions during it's own
+execution. It's primary purpose is a rescue in case you upgraded perl
+and broke binary compatibility somehow.
+
+=head1 SEE ALSO
+
+CPAN(3)
+
+=cut
+
diff --git a/contrib/perl5/lib/Carp.pm b/contrib/perl5/lib/Carp.pm
new file mode 100644
index 000000000000..6bac36446a7d
--- /dev/null
+++ b/contrib/perl5/lib/Carp.pm
@@ -0,0 +1,276 @@
+package Carp;
+
+=head1 NAME
+
+carp - warn of errors (from perspective of caller)
+
+cluck - warn of errors with stack backtrace
+ (not exported by default)
+
+croak - die of errors (from perspective of caller)
+
+confess - die of errors with stack backtrace
+
+=head1 SYNOPSIS
+
+ use Carp;
+ croak "We're outta here!";
+
+ use Carp qw(cluck);
+ cluck "This is how we got here!";
+
+=head1 DESCRIPTION
+
+The Carp routines are useful in your own modules because
+they act like die() or warn(), but report where the error
+was in the code they were called from. Thus if you have a
+routine Foo() that has a carp() in it, then the carp()
+will report the error as occurring where Foo() was called,
+not where carp() was called.
+
+=head2 Forcing a Stack Trace
+
+As a debugging aid, you can force Carp to treat a croak as a confess
+and a carp as a cluck across I<all> modules. In other words, force a
+detailed stack trace to be given. This can be very helpful when trying
+to understand why, or from where, a warning or error is being generated.
+
+This feature is enabled by 'importing' the non-existant symbol
+'verbose'. You would typically enable it by saying
+
+ perl -MCarp=verbose script.pl
+
+or by including the string C<MCarp=verbose> in the L<PERL5OPT>
+environment variable.
+
+=cut
+
+# This package is heavily used. Be small. Be fast. Be good.
+
+# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
+# _almost_ complete understanding of the package. Corrections and
+# comments are welcome.
+
+# The $CarpLevel variable can be set to "strip off" extra caller levels for
+# those times when Carp calls are buried inside other functions. The
+# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
+# text and function arguments should be formatted when printed.
+
+$CarpLevel = 0; # How many extra package levels to skip on carp.
+$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
+$MaxArgLen = 64; # How much of each argument to print. 0 = all.
+$MaxArgNums = 8; # How many arguments to print. 0 = all.
+$Verbose = 0; # If true then make shortmess call longmess instead
+
+require Exporter;
+@ISA = ('Exporter');
+@EXPORT = qw(confess croak carp);
+@EXPORT_OK = qw(cluck verbose);
+@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
+
+
+# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
+# then the following method will be called by the Exporter which knows
+# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
+# 'verbose'.
+
+sub export_fail {
+ shift;
+ $Verbose = shift if $_[0] eq 'verbose';
+ return @_;
+}
+
+
+# longmess() crawls all the way up the stack reporting on all the function
+# calls made. The error string, $error, is originally constructed from the
+# arguments passed into longmess() via confess(), cluck() or shortmess().
+# This gets appended with the stack trace messages which are generated for
+# each function call on the stack.
+
+sub longmess {
+ my $error = join '', @_;
+ my $mess = "";
+ my $i = 1 + $CarpLevel;
+ my ($pack,$file,$line,$sub,$hargs,$eval,$require);
+ my (@a);
+ #
+ # crawl up the stack....
+ #
+ while (do { { package DB; @a = caller($i++) } } ) {
+ # get copies of the variables returned from caller()
+ ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
+ #
+ # if the $error error string is newline terminated then it
+ # is copied into $mess. Otherwise, $mess gets set (at the end of
+ # the 'else {' section below) to one of two things. The first time
+ # through, it is set to the "$error at $file line $line" message.
+ # $error is then set to 'called' which triggers subsequent loop
+ # iterations to append $sub to $mess before appending the "$error
+ # at $file line $line" which now actually reads "called at $file line
+ # $line". Thus, the stack trace message is constructed:
+ #
+ # first time: $mess = $error at $file line $line
+ # subsequent times: $mess .= $sub $error at $file line $line
+ # ^^^^^^
+ # "called"
+ if ($error =~ m/\n$/) {
+ $mess .= $error;
+ } else {
+ # Build a string, $sub, which names the sub-routine called.
+ # This may also be "require ...", "eval '...' or "eval {...}"
+ if (defined $eval) {
+ if ($require) {
+ $sub = "require $eval";
+ } else {
+ $eval =~ s/([\\\'])/\\$1/g;
+ if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
+ substr($eval,$MaxEvalLen) = '...';
+ }
+ $sub = "eval '$eval'";
+ }
+ } elsif ($sub eq '(eval)') {
+ $sub = 'eval {...}';
+ }
+ # if there are any arguments in the sub-routine call, format
+ # them according to the format variables defined earlier in
+ # this file and join them onto the $sub sub-routine string
+ if ($hargs) {
+ # we may trash some of the args so we take a copy
+ @a = @DB::args; # must get local copy of args
+ # don't print any more than $MaxArgNums
+ if ($MaxArgNums and @a > $MaxArgNums) {
+ # cap the length of $#a and set the last element to '...'
+ $#a = $MaxArgNums;
+ $a[$#a] = "...";
+ }
+ for (@a) {
+ # set args to the string "undef" if undefined
+ $_ = "undef", next unless defined $_;
+ if (ref $_) {
+ # dunno what this is for...
+ $_ .= '';
+ s/'/\\'/g;
+ }
+ else {
+ s/'/\\'/g;
+ # terminate the string early with '...' if too long
+ substr($_,$MaxArgLen) = '...'
+ if $MaxArgLen and $MaxArgLen < length;
+ }
+ # 'quote' arg unless it looks like a number
+ $_ = "'$_'" unless /^-?[\d.]+$/;
+ # print high-end chars as 'M-<char>' or '^<char>'
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ # append ('all', 'the', 'arguments') to the $sub string
+ $sub .= '(' . join(', ', @a) . ')';
+ }
+ # here's where the error message, $mess, gets constructed
+ $mess .= "\t$sub " if $error eq "called";
+ $mess .= "$error at $file line $line\n";
+ }
+ # we don't need to print the actual error message again so we can
+ # change this to "called" so that the string "$error at $file line
+ # $line" makes sense as "called at $file line $line".
+ $error = "called";
+ }
+ # this kludge circumvents die's incorrect handling of NUL
+ my $msg = \($mess || $error);
+ $$msg =~ tr/\0//d;
+ $$msg;
+}
+
+
+# shortmess() is called by carp() and croak() to skip all the way up to
+# the top-level caller's package and report the error from there. confess()
+# and cluck() generate a full stack trace so they call longmess() to
+# generate that. In verbose mode shortmess() calls longmess() so
+# you always get a stack trace
+
+sub shortmess { # Short-circuit &longmess if called via multiple packages
+ goto &longmess if $Verbose;
+ my $error = join '', @_;
+ my ($prevpack) = caller(1);
+ my $extra = $CarpLevel;
+ my $i = 2;
+ my ($pack,$file,$line);
+ # when reporting an error, we want to report it from the context of the
+ # calling package. So what is the calling package? Within a module,
+ # there may be many calls between methods and perhaps between sub-classes
+ # and super-classes, but the user isn't interested in what happens
+ # inside the package. We start by building a hash array which keeps
+ # track of all the packages to which the calling package belongs. We
+ # do this by examining its @ISA variable. Any call from a base class
+ # method (one of our caller's @ISA packages) can be ignored
+ my %isa = ($prevpack,1);
+
+ # merge all the caller's @ISA packages into %isa.
+ @isa{@{"${prevpack}::ISA"}} = ()
+ if(defined @{"${prevpack}::ISA"});
+
+ # now we crawl up the calling stack and look at all the packages in
+ # there. For each package, we look to see if it has an @ISA and then
+ # we see if our caller features in that list. That would imply that
+ # our caller is a derived class of that package and its calls can also
+ # be ignored
+ while (($pack,$file,$line) = caller($i++)) {
+ if(defined @{$pack . "::ISA"}) {
+ my @i = @{$pack . "::ISA"};
+ my %i;
+ @i{@i} = ();
+ # merge any relevant packages into %isa
+ @isa{@i,$pack} = ()
+ if(exists $i{$prevpack} || exists $isa{$pack});
+ }
+
+ # and here's where we do the ignoring... if the package in
+ # question is one of our caller's base or derived packages then
+ # we can ignore it (skip it) and go onto the next (but note that
+ # the continue { } block below gets called every time)
+ next
+ if(exists $isa{$pack});
+
+ # Hey! We've found a package that isn't one of our caller's
+ # clan....but wait, $extra refers to the number of 'extra' levels
+ # we should skip up. If $extra > 0 then this is a false alarm.
+ # We must merge the package into the %isa hash (so we can ignore it
+ # if it pops up again), decrement $extra, and continue.
+ if ($extra-- > 0) {
+ %isa = ($pack,1);
+ @isa{@{$pack . "::ISA"}} = ()
+ if(defined @{$pack . "::ISA"});
+ }
+ else {
+ # OK! We've got a candidate package. Time to construct the
+ # relevant error message and return it. die() doesn't like
+ # to be given NUL characters (which $msg may contain) so we
+ # remove them first.
+ (my $msg = "$error at $file line $line\n") =~ tr/\0//d;
+ return $msg;
+ }
+ }
+ continue {
+ $prevpack = $pack;
+ }
+
+ # uh-oh! It looks like we crawled all the way up the stack and
+ # never found a candidate package. Oh well, let's call longmess
+ # to generate a full stack trace. We use the magical form of 'goto'
+ # so that this shortmess() function doesn't appear on the stack
+ # to further confuse longmess() about it's calling package.
+ goto &longmess;
+}
+
+
+# the following four functions call longmess() or shortmess() depending on
+# whether they should generate a full stack trace (confess() and cluck())
+# or simply report the caller's package (croak() and carp()), respectively.
+# confess() and croak() die, carp() and cluck() warn.
+
+sub croak { die shortmess @_ }
+sub confess { die longmess @_ }
+sub carp { warn shortmess @_ }
+sub cluck { warn longmess @_ }
+
+1;
diff --git a/contrib/perl5/lib/Class/Struct.pm b/contrib/perl5/lib/Class/Struct.pm
new file mode 100644
index 000000000000..8fddfbf68ef3
--- /dev/null
+++ b/contrib/perl5/lib/Class/Struct.pm
@@ -0,0 +1,484 @@
+package Class::Struct;
+
+## See POD after __END__
+
+require 5.002;
+
+use strict;
+use vars qw(@ISA @EXPORT);
+
+use Carp;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(struct);
+
+## Tested on 5.002 and 5.003 without class membership tests:
+my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95);
+
+my $print = 0;
+sub printem {
+ if (@_) { $print = shift }
+ else { $print++ }
+}
+
+{
+ package Class::Struct::Tie_ISA;
+
+ sub TIEARRAY {
+ my $class = shift;
+ return bless [], $class;
+ }
+
+ sub STORE {
+ my ($self, $index, $value) = @_;
+ Class::Struct::_subclass_error();
+ }
+
+ sub FETCH {
+ my ($self, $index) = @_;
+ $self->[$index];
+ }
+
+ sub FETCHSIZE {
+ my $self = shift;
+ return scalar(@$self);
+ }
+
+ sub DESTROY { }
+}
+
+sub struct {
+
+ # Determine parameter list structure, one of:
+ # struct( class => [ element-list ])
+ # struct( class => { element-list })
+ # struct( element-list )
+ # Latter form assumes current package name as struct name.
+
+ my ($class, @decls);
+ my $base_type = ref $_[1];
+ if ( $base_type eq 'HASH' ) {
+ $class = shift;
+ @decls = %{shift()};
+ _usage_error() if @_;
+ }
+ elsif ( $base_type eq 'ARRAY' ) {
+ $class = shift;
+ @decls = @{shift()};
+ _usage_error() if @_;
+ }
+ else {
+ $base_type = 'ARRAY';
+ $class = (caller())[0];
+ @decls = @_;
+ }
+ _usage_error() if @decls % 2 == 1;
+
+ # Ensure we are not, and will not be, a subclass.
+
+ my $isa = do {
+ no strict 'refs';
+ \@{$class . '::ISA'};
+ };
+ _subclass_error() if @$isa;
+ tie @$isa, 'Class::Struct::Tie_ISA';
+
+ # Create constructor.
+
+ croak "function 'new' already defined in package $class"
+ if do { no strict 'refs'; defined &{$class . "::new"} };
+
+ my @methods = ();
+ my %refs = ();
+ my %arrays = ();
+ my %hashes = ();
+ my %classes = ();
+ my $got_class = 0;
+ my $out = '';
+
+ $out = "{\n package $class;\n use Carp;\n sub new {\n";
+
+ my $cnt = 0;
+ my $idx = 0;
+ my( $cmt, $name, $type, $elem );
+
+ if( $base_type eq 'HASH' ){
+ $out .= " my(\$r) = {};\n";
+ $cmt = '';
+ }
+ elsif( $base_type eq 'ARRAY' ){
+ $out .= " my(\$r) = [];\n";
+ }
+ while( $idx < @decls ){
+ $name = $decls[$idx];
+ $type = $decls[$idx+1];
+ push( @methods, $name );
+ if( $base_type eq 'HASH' ){
+ $elem = "{'$name'}";
+ }
+ elsif( $base_type eq 'ARRAY' ){
+ $elem = "[$cnt]";
+ ++$cnt;
+ $cmt = " # $name";
+ }
+ if( $type =~ /^\*(.)/ ){
+ $refs{$name}++;
+ $type = $1;
+ }
+ if( $type eq '@' ){
+ $out .= " \$r->$elem = [];$cmt\n";
+ $arrays{$name}++;
+ }
+ elsif( $type eq '%' ){
+ $out .= " \$r->$elem = {};$cmt\n";
+ $hashes{$name}++;
+ }
+ elsif ( $type eq '$') {
+ $out .= " \$r->$elem = undef;$cmt\n";
+ }
+ elsif( $type =~ /^\w+(?:::\w+)*$/ ){
+ $out .= " \$r->$elem = '${type}'->new();$cmt\n";
+ $classes{$name} = $type;
+ $got_class = 1;
+ }
+ else{
+ croak "'$type' is not a valid struct element type";
+ }
+ $idx += 2;
+ }
+ $out .= " bless \$r;\n }\n";
+
+ # Create accessor methods.
+
+ my( $pre, $pst, $sel );
+ $cnt = 0;
+ foreach $name (@methods){
+ if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) {
+ carp "function '$name' already defined, overrides struct accessor method"
+ if $^W;
+ }
+ else {
+ $pre = $pst = $cmt = $sel = '';
+ if( defined $refs{$name} ){
+ $pre = "\\(";
+ $pst = ")";
+ $cmt = " # returns ref";
+ }
+ $out .= " sub $name {$cmt\n my \$r = shift;\n";
+ if( $base_type eq 'ARRAY' ){
+ $elem = "[$cnt]";
+ ++$cnt;
+ }
+ elsif( $base_type eq 'HASH' ){
+ $elem = "{'$name'}";
+ }
+ if( defined $arrays{$name} ){
+ $out .= " my \$i;\n";
+ $out .= " \@_ ? (\$i = shift) : return $pre\$r->$elem$pst;\n";
+ $sel = "->[\$i]";
+ }
+ elsif( defined $hashes{$name} ){
+ $out .= " my \$i;\n";
+ $out .= " \@_ ? (\$i = shift) : return $pre\$r->$elem$pst;\n";
+ $sel = "->{\$i}";
+ }
+ elsif( defined $classes{$name} ){
+ if ( $CHECK_CLASS_MEMBERSHIP ) {
+ $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n";
+ }
+ }
+ $out .= " croak 'Too many args to $name' if \@_ > 1;\n";
+ $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n";
+ $out .= " }\n";
+ }
+ }
+ $out .= "}\n1;\n";
+
+ print $out if $print;
+ my $result = eval $out;
+ carp $@ if $@;
+}
+
+sub _usage_error {
+ confess "struct usage error";
+}
+
+sub _subclass_error {
+ croak 'struct class cannot be a subclass (@ISA not allowed)';
+}
+
+1; # for require
+
+
+__END__
+
+=head1 NAME
+
+Class::Struct - declare struct-like datatypes as Perl classes
+
+=head1 SYNOPSIS
+
+ use Class::Struct;
+ # declare struct, based on array:
+ struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]);
+ # declare struct, based on hash:
+ struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... });
+
+ package CLASS_NAME;
+ use Class::Struct;
+ # declare struct, based on array, implicit class name:
+ struct( ELEMENT_NAME => ELEMENT_TYPE, ... );
+
+
+ package Myobj;
+ use Class::Struct;
+ # declare struct with four types of elements:
+ struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' );
+
+ $obj = new Myobj; # constructor
+
+ # scalar type accessor:
+ $element_value = $obj->s; # element value
+ $obj->s('new value'); # assign to element
+
+ # array type accessor:
+ $ary_ref = $obj->a; # reference to whole array
+ $ary_element_value = $obj->a(2); # array element value
+ $obj->a(2, 'new value'); # assign to array element
+
+ # hash type accessor:
+ $hash_ref = $obj->h; # reference to whole hash
+ $hash_element_value = $obj->h('x'); # hash element value
+ $obj->h('x', 'new value'); # assign to hash element
+
+ # class type accessor:
+ $element_value = $obj->c; # object reference
+ $obj->c->method(...); # call method of object
+ $obj->c(new My_Other_Class); # assign a new object
+
+
+=head1 DESCRIPTION
+
+C<Class::Struct> exports a single function, C<struct>.
+Given a list of element names and types, and optionally
+a class name, C<struct> creates a Perl 5 class that implements
+a "struct-like" data structure.
+
+The new class is given a constructor method, C<new>, for creating
+struct objects.
+
+Each element in the struct data has an accessor method, which is
+used to assign to the element and to fetch its value. The
+default accessor can be overridden by declaring a C<sub> of the
+same name in the package. (See Example 2.)
+
+Each element's type can be scalar, array, hash, or class.
+
+
+=head2 The C<struct()> function
+
+The C<struct> function has three forms of parameter-list.
+
+ struct( CLASS_NAME => [ ELEMENT_LIST ]);
+ struct( CLASS_NAME => { ELEMENT_LIST });
+ struct( ELEMENT_LIST );
+
+The first and second forms explicitly identify the name of the
+class being created. The third form assumes the current package
+name as the class name.
+
+An object of a class created by the first and third forms is
+based on an array, whereas an object of a class created by the
+second form is based on a hash. The array-based forms will be
+somewhat faster and smaller; the hash-based forms are more
+flexible.
+
+The class created by C<struct> must not be a subclass of another
+class other than C<UNIVERSAL>.
+
+A function named C<new> must not be explicitly defined in a class
+created by C<struct>.
+
+The I<ELEMENT_LIST> has the form
+
+ NAME => TYPE, ...
+
+Each name-type pair declares one element of the struct. Each
+element name will be defined as an accessor method unless a
+method by that name is explicitly defined; in the latter case, a
+warning is issued if the warning flag (B<-w>) is set.
+
+
+=head2 Element Types and Accessor Methods
+
+The four element types -- scalar, array, hash, and class -- are
+represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name --
+optionally preceded by a C<'*'>.
+
+The accessor method provided by C<struct> for an element depends
+on the declared type of the element.
+
+=over
+
+=item Scalar (C<'$'> or C<'*$'>)
+
+The element is a scalar, and is initialized to C<undef>.
+
+The accessor's argument, if any, is assigned to the element.
+
+If the element type is C<'$'>, the value of the element (after
+assignment) is returned. If the element type is C<'*$'>, a reference
+to the element is returned.
+
+=item Array (C<'@'> or C<'*@'>)
+
+The element is an array, initialized to C<()>.
+
+With no argument, the accessor returns a reference to the
+element's whole array.
+
+With one or two arguments, the first argument is an index
+specifying one element of the array; the second argument, if
+present, is assigned to the array element. If the element type
+is C<'@'>, the accessor returns the array element value. If the
+element type is C<'*@'>, a reference to the array element is
+returned.
+
+=item Hash (C<'%'> or C<'*%'>)
+
+The element is a hash, initialized to C<()>.
+
+With no argument, the accessor returns a reference to the
+element's whole hash.
+
+With one or two arguments, the first argument is a key specifying
+one element of the hash; the second argument, if present, is
+assigned to the hash element. If the element type is C<'%'>, the
+accessor returns the hash element value. If the element type is
+C<'*%'>, a reference to the hash element is returned.
+
+=item Class (C<'Class_Name'> or C<'*Class_Name'>)
+
+The element's value must be a reference blessed to the named
+class or to one of its subclasses. The element is initialized to
+the result of calling the C<new> constructor of the named class.
+
+The accessor's argument, if any, is assigned to the element. The
+accessor will C<croak> if this is not an appropriate object
+reference.
+
+If the element type does not start with a C<'*'>, the accessor
+returns the element value (after assignment). If the element type
+starts with a C<'*'>, a reference to the element itself is returned.
+
+=back
+
+=head1 EXAMPLES
+
+=over
+
+=item Example 1
+
+Giving a struct element a class type that is also a struct is how
+structs are nested. Here, C<timeval> represents a time (seconds and
+microseconds), and C<rusage> has two elements, each of which is of
+type C<timeval>.
+
+ use Class::Struct;
+
+ struct( rusage => {
+ ru_utime => timeval, # seconds
+ ru_stime => timeval, # microseconds
+ });
+
+ struct( timeval => [
+ tv_secs => '$',
+ tv_usecs => '$',
+ ]);
+
+ # create an object:
+ my $t = new rusage;
+ # $t->ru_utime and $t->ru_stime are objects of type timeval.
+
+ # set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec.
+ $t->ru_utime->tv_secs(100);
+ $t->ru_utime->tv_usecs(0);
+ $t->ru_stime->tv_secs(5);
+ $t->ru_stime->tv_usecs(0);
+
+
+=item Example 2
+
+An accessor function can be redefined in order to provide
+additional checking of values, etc. Here, we want the C<count>
+element always to be nonnegative, so we redefine the C<count>
+accessor accordingly.
+
+ package MyObj;
+ use Class::Struct;
+
+ # declare the struct
+ struct ( 'MyObj', { count => '$', stuff => '%' } );
+
+ # override the default accessor method for 'count'
+ sub count {
+ my $self = shift;
+ if ( @_ ) {
+ die 'count must be nonnegative' if $_[0] < 0;
+ $self->{'count'} = shift;
+ warn "Too many args to count" if @_;
+ }
+ return $self->{'count'};
+ }
+
+ package main;
+ $x = new MyObj;
+ print "\$x->count(5) = ", $x->count(5), "\n";
+ # prints '$x->count(5) = 5'
+
+ print "\$x->count = ", $x->count, "\n";
+ # prints '$x->count = 5'
+
+ print "\$x->count(-5) = ", $x->count(-5), "\n";
+ # dies due to negative argument!
+
+
+=head1 Author and Modification History
+
+
+Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02.
+
+ members() function removed.
+ Documentation corrected and extended.
+ Use of struct() in a subclass prohibited.
+ User definition of accessor allowed.
+ Treatment of '*' in element types corrected.
+ Treatment of classes as element types corrected.
+ Class name to struct() made optional.
+ Diagnostic checks added.
+
+
+Originally C<Class::Template> by Dean Roehrich.
+
+ # Template.pm --- struct/member template builder
+ # 12mar95
+ # Dean Roehrich
+ #
+ # changes/bugs fixed since 28nov94 version:
+ # - podified
+ # changes/bugs fixed since 21nov94 version:
+ # - Fixed examples.
+ # changes/bugs fixed since 02sep94 version:
+ # - Moved to Class::Template.
+ # changes/bugs fixed since 20feb94 version:
+ # - Updated to be a more proper module.
+ # - Added "use strict".
+ # - Bug in build_methods, was using @var when @$var needed.
+ # - Now using my() rather than local().
+ #
+ # Uses perl5 classes to create nested data types.
+ # This is offered as one implementation of Tom Christiansen's "structs.pl"
+ # idea.
+
+=cut
diff --git a/contrib/perl5/lib/Cwd.pm b/contrib/perl5/lib/Cwd.pm
new file mode 100644
index 000000000000..7febb0dde298
--- /dev/null
+++ b/contrib/perl5/lib/Cwd.pm
@@ -0,0 +1,385 @@
+package Cwd;
+require 5.000;
+
+=head1 NAME
+
+getcwd - get pathname of current working directory
+
+=head1 SYNOPSIS
+
+ use Cwd;
+ $dir = cwd;
+
+ use Cwd;
+ $dir = getcwd;
+
+ use Cwd;
+ $dir = fastgetcwd;
+
+ use Cwd 'chdir';
+ chdir "/tmp";
+ print $ENV{'PWD'};
+
+ use Cwd 'abs_path';
+ print abs_path($ENV{'PWD'});
+
+ use Cwd 'fast_abs_path';
+ print fast_abs_path($ENV{'PWD'});
+
+=head1 DESCRIPTION
+
+The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
+in Perl.
+
+The abs_path() function takes a single argument and returns the
+absolute pathname for that argument. It uses the same algoritm as
+getcwd(). (actually getcwd() is abs_path("."))
+
+The fastcwd() function looks the same as getcwd(), but runs faster.
+It's also more dangerous because it might conceivably chdir() you out
+of a directory that it can't chdir() you back into. If fastcwd
+encounters a problem it will return undef but will probably leave you
+in a different directory. For a measure of extra security, if
+everything appears to have worked, the fastcwd() function will check
+that it leaves you in the same directory that it started in. If it has
+changed it will C<die> with the message "Unstable directory path,
+current directory changed unexpectedly". That should never happen.
+
+The fast_abs_path() function looks the same as abs_path(), but runs faster.
+And like fastcwd() is more dangerous.
+
+The cwd() function looks the same as getcwd and fastgetcwd but is
+implemented using the most natural and safe form for the current
+architecture. For most systems it is identical to `pwd` (but without
+the trailing line terminator).
+
+It is recommended that cwd (or another *cwd() function) is used in
+I<all> code to ensure portability.
+
+If you ask to override your chdir() built-in function, then your PWD
+environment variable will be kept up to date. (See
+L<perlsub/Overriding Builtin Functions>.) Note that it will only be
+kept up to date if all packages which use chdir import it from Cwd.
+
+=cut
+
+## use strict;
+
+use Carp;
+
+$VERSION = '2.01';
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
+@EXPORT_OK = qw(chdir abs_path fast_abs_path);
+
+
+# The 'natural and safe form' for UNIX (pwd may be setuid root)
+
+sub _backtick_pwd {
+ my $cwd;
+ chop($cwd = `pwd`);
+ $cwd;
+}
+
+# Since some ports may predefine cwd internally (e.g., NT)
+# we take care not to override an existing definition for cwd().
+
+*cwd = \&_backtick_pwd unless defined &cwd;
+
+
+# By Brandon S. Allbery
+#
+# Usage: $cwd = getcwd();
+
+sub getcwd
+{
+ abs_path('.');
+}
+
+# By John Bazik
+#
+# Usage: $cwd = &fastcwd;
+#
+# This is a faster version of getcwd. It's also more dangerous because
+# you might chdir out of a directory that you can't chdir back into.
+
+# List of metachars taken from do_exec() in doio.c
+my $quoted_shell_meta = quotemeta('$&*(){}[]";\\|?<>~`'."'\n");
+
+sub fastcwd {
+ my($odev, $oino, $cdev, $cino, $tdev, $tino);
+ my(@path, $path);
+ local(*DIR);
+
+ my($orig_cdev, $orig_cino) = stat('.');
+ ($cdev, $cino) = ($orig_cdev, $orig_cino);
+ for (;;) {
+ my $direntry;
+ ($odev, $oino) = ($cdev, $cino);
+ CORE::chdir('..') || return undef;
+ ($cdev, $cino) = stat('.');
+ last if $odev == $cdev && $oino == $cino;
+ opendir(DIR, '.') || return undef;
+ for (;;) {
+ $direntry = readdir(DIR);
+ last unless defined $direntry;
+ next if $direntry eq '.';
+ next if $direntry eq '..';
+
+ ($tdev, $tino) = lstat($direntry);
+ last unless $tdev != $odev || $tino != $oino;
+ }
+ closedir(DIR);
+ return undef unless defined $direntry; # should never happen
+ unshift(@path, $direntry);
+ }
+ $path = '/' . join('/', @path);
+ # At this point $path may be tainted (if tainting) and chdir would fail.
+ # To be more useful we untaint it then check that we landed where we started.
+ $path = $1 if $path =~ /^(.*)$/; # untaint
+ CORE::chdir($path) || return undef;
+ ($cdev, $cino) = stat('.');
+ die "Unstable directory path, current directory changed unexpectedly"
+ if $cdev != $orig_cdev || $cino != $orig_cino;
+ $path;
+}
+
+
+# Keeps track of current working directory in PWD environment var
+# Usage:
+# use Cwd 'chdir';
+# chdir $newdir;
+
+my $chdir_init = 0;
+
+sub chdir_init {
+ if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos') {
+ my($dd,$di) = stat('.');
+ my($pd,$pi) = stat($ENV{'PWD'});
+ if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
+ $ENV{'PWD'} = cwd();
+ }
+ }
+ else {
+ $ENV{'PWD'} = cwd();
+ }
+ # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
+ if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
+ my($pd,$pi) = stat($2);
+ my($dd,$di) = stat($1);
+ if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
+ $ENV{'PWD'}="$2$3";
+ }
+ }
+ $chdir_init = 1;
+}
+
+sub chdir {
+ my $newdir = shift || ''; # allow for no arg (chdir to HOME dir)
+ $newdir =~ s|///*|/|g;
+ chdir_init() unless $chdir_init;
+ return 0 unless CORE::chdir $newdir;
+ if ($^O eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
+
+ if ($newdir =~ m#^/#) {
+ $ENV{'PWD'} = $newdir;
+ } else {
+ my @curdir = split(m#/#,$ENV{'PWD'});
+ @curdir = ('') unless @curdir;
+ my $component;
+ foreach $component (split(m#/#, $newdir)) {
+ next if $component eq '.';
+ pop(@curdir),next if $component eq '..';
+ push(@curdir,$component);
+ }
+ $ENV{'PWD'} = join('/',@curdir) || '/';
+ }
+ 1;
+}
+
+# Taken from Cwd.pm It is really getcwd with an optional
+# parameter instead of '.'
+#
+
+sub abs_path
+{
+ my $start = @_ ? shift : '.';
+ my($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+ unless (@cst = stat( $start ))
+ {
+ carp "stat($start): $!";
+ return '';
+ }
+ $cwd = '';
+ $dotdots = $start;
+ do
+ {
+ $dotdots .= '/..';
+ @pst = @cst;
+ unless (opendir(PARENT, $dotdots))
+ {
+ carp "opendir($dotdots): $!";
+ return '';
+ }
+ unless (@cst = stat($dotdots))
+ {
+ carp "stat($dotdots): $!";
+ closedir(PARENT);
+ return '';
+ }
+ if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
+ {
+ $dir = undef;
+ }
+ else
+ {
+ do
+ {
+ unless (defined ($dir = readdir(PARENT)))
+ {
+ carp "readdir($dotdots): $!";
+ closedir(PARENT);
+ return '';
+ }
+ $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
+ }
+ while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
+ $tst[1] != $pst[1]);
+ }
+ $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
+ closedir(PARENT);
+ } while (defined $dir);
+ chop($cwd) unless $cwd eq '/'; # drop the trailing /
+ $cwd;
+}
+
+sub fast_abs_path {
+ my $cwd = getcwd();
+ my $path = shift || '.';
+ CORE::chdir($path) || croak "Cannot chdir to $path:$!";
+ my $realpath = getcwd();
+ CORE::chdir($cwd) || croak "Cannot chdir back to $cwd:$!";
+ $realpath;
+}
+
+
+# --- PORTING SECTION ---
+
+# VMS: $ENV{'DEFAULT'} points to default directory at all times
+# 06-Mar-1996 Charles Bailey bailey@genetics.upenn.edu
+# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
+# in the process logical name table as the default device and directory
+# seen by Perl. This may not be the same as the default device
+# and directory seen by DCL after Perl exits, since the effects
+# the CRTL chdir() function persist only until Perl exits.
+
+sub _vms_cwd {
+ return $ENV{'DEFAULT'};
+}
+
+sub _vms_abs_path {
+ return $ENV{'DEFAULT'} unless @_;
+ my $path = VMS::Filespec::pathify($_[0]);
+ croak("Invalid path name $_[0]") unless defined $path;
+ return VMS::Filespec::rmsexpand($path);
+}
+
+sub _os2_cwd {
+ $ENV{'PWD'} = `cmd /c cd`;
+ chop $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+sub _win32_cwd {
+ $ENV{'PWD'} = Win32::GetCwd();
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
+*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
+ defined &Win32::GetCwd);
+
+*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
+
+sub _dos_cwd {
+ if (!defined &Dos::GetCwd) {
+ $ENV{'PWD'} = `command /c cd`;
+ chop $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ } else {
+ $ENV{'PWD'} = Dos::GetCwd();
+ }
+ return $ENV{'PWD'};
+}
+
+sub _qnx_cwd {
+ $ENV{'PWD'} = `/usr/bin/fullpath -t`;
+ chop $ENV{'PWD'};
+ return $ENV{'PWD'};
+}
+
+sub _qnx_abs_path {
+ my $path = shift || '.';
+ my $realpath=`/usr/bin/fullpath -t $path`;
+ chop $realpath;
+ return $realpath;
+}
+
+{
+ local $^W = 0; # assignments trigger 'subroutine redefined' warning
+
+ if ($^O eq 'VMS') {
+ *cwd = \&_vms_cwd;
+ *getcwd = \&_vms_cwd;
+ *fastcwd = \&_vms_cwd;
+ *fastgetcwd = \&_vms_cwd;
+ *abs_path = \&_vms_abs_path;
+ *fast_abs_path = \&_vms_abs_path;
+ }
+ elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
+ # We assume that &_NT_cwd is defined as an XSUB or in the core.
+ *cwd = \&_NT_cwd;
+ *getcwd = \&_NT_cwd;
+ *fastcwd = \&_NT_cwd;
+ *fastgetcwd = \&_NT_cwd;
+ *abs_path = \&fast_abs_path;
+ }
+ elsif ($^O eq 'os2') {
+ # sys_cwd may keep the builtin command
+ *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *getcwd = \&cwd;
+ *fastgetcwd = \&cwd;
+ *fastcwd = \&cwd;
+ *abs_path = \&fast_abs_path;
+ }
+ elsif ($^O eq 'dos') {
+ *cwd = \&_dos_cwd;
+ *getcwd = \&_dos_cwd;
+ *fastgetcwd = \&_dos_cwd;
+ *fastcwd = \&_dos_cwd;
+ *abs_path = \&fast_abs_path;
+ }
+ elsif ($^O eq 'qnx') {
+ *cwd = \&_qnx_cwd;
+ *getcwd = \&_qnx_cwd;
+ *fastgetcwd = \&_qnx_cwd;
+ *fastcwd = \&_qnx_cwd;
+ *abs_path = \&_qnx_abs_path;
+ *fast_abs_path = \&_qnx_abs_path;
+ }
+}
+
+# package main; eval join('',<DATA>) || die $@; # quick test
+
+1;
+
+__END__
+BEGIN { import Cwd qw(:DEFAULT chdir); }
+print join("\n", cwd, getcwd, fastcwd, "");
+chdir('..');
+print join("\n", cwd, getcwd, fastcwd, "");
+print "$ENV{PWD}\n";
diff --git a/contrib/perl5/lib/Devel/SelfStubber.pm b/contrib/perl5/lib/Devel/SelfStubber.pm
new file mode 100644
index 000000000000..4c2d03958033
--- /dev/null
+++ b/contrib/perl5/lib/Devel/SelfStubber.pm
@@ -0,0 +1,139 @@
+package Devel::SelfStubber;
+require SelfLoader;
+@ISA = qw(SelfLoader);
+@EXPORT = 'AUTOLOAD';
+$JUST_STUBS = 1;
+$VERSION = 1.01; sub Version {$VERSION}
+
+# Use as
+# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub(MODULE_NAME,LIB)'
+# (LIB defaults to '.') e.g.
+# perl -e 'use Devel::SelfStubber;Devel::SelfStubber->stub('Math::BigInt')'
+# would print out stubs needed if you added a __DATA__ before the subs.
+# Setting $Devel::SelfStubber::JUST_STUBS to 0 will print out the whole
+# module with the stubs entered just before the __DATA__
+
+sub _add_to_cache {
+ my($self,$fullname,$pack,$lines, $prototype) = @_;
+ push(@DATA,@{$lines});
+ if($fullname){push(@STUBS,"sub $fullname $prototype;\n")}; # stubs
+ '1;';
+}
+
+sub _package_defined {
+ my($self,$line) = @_;
+ push(@DATA,$line);
+}
+
+sub stub {
+ my($self,$module,$lib) = @_;
+ my($line,$end,$fh,$mod_file,$found_selfloader);
+ $lib ||= '.';
+ ($mod_file = $module) =~ s,::,/,g;
+
+ $mod_file = "$lib/$mod_file.pm";
+ $fh = "${module}::DATA";
+
+ open($fh,$mod_file) || die "Unable to open $mod_file";
+ while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) {
+ push(@BEFORE_DATA,$line);
+ $line =~ /use\s+SelfLoader/ && $found_selfloader++;
+ }
+ $line =~ m/^__DATA__/ || die "$mod_file doesn't contain a __DATA__ token";
+ $found_selfloader ||
+ print 'die "\'use SelfLoader;\' statement NOT FOUND!!\n"',"\n";
+ $self->_load_stubs($module);
+ if ( fileno($fh) ) {
+ $end = 1;
+ while(defined($line = <$fh>)) {
+ push(@AFTER_DATA,$line);
+ }
+ }
+ unless ($JUST_STUBS) {
+ print @BEFORE_DATA;
+ }
+ print @STUBS;
+ unless ($JUST_STUBS) {
+ print "1;\n__DATA__\n",@DATA;
+ if($end) { print "__END__\n",@AFTER_DATA; }
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Devel::SelfStubber - generate stubs for a SelfLoading module
+
+=head1 SYNOPSIS
+
+To generate just the stubs:
+
+ use Devel::SelfStubber;
+ Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');
+
+or to generate the whole module with stubs inserted correctly
+
+ use Devel::SelfStubber;
+ $Devel::SelfStubber::JUST_STUBS=0;
+ Devel::SelfStubber->stub('MODULENAME','MY_LIB_DIR');
+
+MODULENAME is the Perl module name, e.g. Devel::SelfStubber,
+NOT 'Devel/SelfStubber' or 'Devel/SelfStubber.pm'.
+
+MY_LIB_DIR defaults to '.' if not present.
+
+=head1 DESCRIPTION
+
+Devel::SelfStubber prints the stubs you need to put in the module
+before the __DATA__ token (or you can get it to print the entire
+module with stubs correctly placed). The stubs ensure that if
+a method is called, it will get loaded. They are needed specifically
+for inherited autoloaded methods.
+
+This is best explained using the following example:
+
+Assume four classes, A,B,C & D.
+
+A is the root class, B is a subclass of A, C is a subclass of B,
+and D is another subclass of A.
+
+ A
+ / \
+ B D
+ /
+ C
+
+If D calls an autoloaded method 'foo' which is defined in class A,
+then the method is loaded into class A, then executed. If C then
+calls method 'foo', and that method was reimplemented in class
+B, but set to be autoloaded, then the lookup mechanism never gets to
+the AUTOLOAD mechanism in B because it first finds the method
+already loaded in A, and so erroneously uses that. If the method
+foo had been stubbed in B, then the lookup mechanism would have
+found the stub, and correctly loaded and used the sub from B.
+
+So, for classes and subclasses to have inheritance correctly
+work with autoloading, you need to ensure stubs are loaded.
+
+The SelfLoader can load stubs automatically at module initialization
+with the statement 'SelfLoader-E<gt>load_stubs()';, but you may wish to
+avoid having the stub loading overhead associated with your
+initialization (though note that the SelfLoader::load_stubs method
+will be called sooner or later - at latest when the first sub
+is being autoloaded). In this case, you can put the sub stubs
+before the __DATA__ token. This can be done manually, but this
+module allows automatic generation of the stubs.
+
+By default it just prints the stubs, but you can set the
+global $Devel::SelfStubber::JUST_STUBS to 0 and it will
+print out the entire module with the stubs positioned correctly.
+
+At the very least, this is useful to see what the SelfLoader
+thinks are stubs - in order to ensure future versions of the
+SelfStubber remain in step with the SelfLoader, the
+SelfStubber actually uses the SelfLoader to determine which
+stubs are needed.
+
+=cut
diff --git a/contrib/perl5/lib/DirHandle.pm b/contrib/perl5/lib/DirHandle.pm
new file mode 100644
index 000000000000..047755dc17d2
--- /dev/null
+++ b/contrib/perl5/lib/DirHandle.pm
@@ -0,0 +1,72 @@
+package DirHandle;
+
+=head1 NAME
+
+DirHandle - supply object methods for directory handles
+
+=head1 SYNOPSIS
+
+ use DirHandle;
+ $d = new DirHandle ".";
+ if (defined $d) {
+ while (defined($_ = $d->read)) { something($_); }
+ $d->rewind;
+ while (defined($_ = $d->read)) { something_else($_); }
+ undef $d;
+ }
+
+=head1 DESCRIPTION
+
+The C<DirHandle> method provide an alternative interface to the
+opendir(), closedir(), readdir(), and rewinddir() functions.
+
+The only objective benefit to using C<DirHandle> is that it avoids
+namespace pollution by creating globs to hold directory handles.
+
+=cut
+
+require 5.000;
+use Carp;
+use Symbol;
+
+sub new {
+ @_ >= 1 && @_ <= 2 or croak 'usage: new DirHandle [DIRNAME]';
+ my $class = shift;
+ my $dh = gensym;
+ if (@_) {
+ DirHandle::open($dh, $_[0])
+ or return undef;
+ }
+ bless $dh, $class;
+}
+
+sub DESTROY {
+ my ($dh) = @_;
+ closedir($dh);
+}
+
+sub open {
+ @_ == 2 or croak 'usage: $dh->open(DIRNAME)';
+ my ($dh, $dirname) = @_;
+ opendir($dh, $dirname);
+}
+
+sub close {
+ @_ == 1 or croak 'usage: $dh->close()';
+ my ($dh) = @_;
+ closedir($dh);
+}
+
+sub read {
+ @_ == 1 or croak 'usage: $dh->read()';
+ my ($dh) = @_;
+ readdir($dh);
+}
+
+sub rewind {
+ @_ == 1 or croak 'usage: $dh->rewind()';
+ my ($dh) = @_;
+ rewinddir($dh);
+}
+
+1;
diff --git a/contrib/perl5/lib/English.pm b/contrib/perl5/lib/English.pm
new file mode 100644
index 000000000000..bbb6bd7b280c
--- /dev/null
+++ b/contrib/perl5/lib/English.pm
@@ -0,0 +1,178 @@
+package English;
+
+require Exporter;
+@ISA = (Exporter);
+
+=head1 NAME
+
+English - use nice English (or awk) names for ugly punctuation variables
+
+=head1 SYNOPSIS
+
+ use English;
+ ...
+ if ($ERRNO =~ /denied/) { ... }
+
+=head1 DESCRIPTION
+
+This module provides aliases for the built-in variables whose
+names no one seems to like to read. Variables with side-effects
+which get triggered just by accessing them (like $0) will still
+be affected.
+
+For those variables that have an B<awk> version, both long
+and short English alternatives are provided. For example,
+the C<$/> variable can be referred to either $RS or
+$INPUT_RECORD_SEPARATOR if you are using the English module.
+
+See L<perlvar> for a complete list of these.
+
+=cut
+
+local $^W = 0;
+
+# Grandfather $NAME import
+sub import {
+ my $this = shift;
+ my @list = @_;
+ local $Exporter::ExportLevel = 1;
+ Exporter::import($this,grep {s/^\$/*/} @list);
+}
+
+@EXPORT = qw(
+ *ARG
+ *MATCH
+ *PREMATCH
+ *POSTMATCH
+ *LAST_PAREN_MATCH
+ *INPUT_LINE_NUMBER
+ *NR
+ *INPUT_RECORD_SEPARATOR
+ *RS
+ *OUTPUT_AUTOFLUSH
+ *OUTPUT_FIELD_SEPARATOR
+ *OFS
+ *OUTPUT_RECORD_SEPARATOR
+ *ORS
+ *LIST_SEPARATOR
+ *SUBSCRIPT_SEPARATOR
+ *SUBSEP
+ *FORMAT_PAGE_NUMBER
+ *FORMAT_LINES_PER_PAGE
+ *FORMAT_LINES_LEFT
+ *FORMAT_NAME
+ *FORMAT_TOP_NAME
+ *FORMAT_LINE_BREAK_CHARACTERS
+ *FORMAT_FORMFEED
+ *CHILD_ERROR
+ *OS_ERROR
+ *ERRNO
+ *EXTENDED_OS_ERROR
+ *EVAL_ERROR
+ *PROCESS_ID
+ *PID
+ *REAL_USER_ID
+ *UID
+ *EFFECTIVE_USER_ID
+ *EUID
+ *REAL_GROUP_ID
+ *GID
+ *EFFECTIVE_GROUP_ID
+ *EGID
+ *PROGRAM_NAME
+ *PERL_VERSION
+ *ACCUMULATOR
+ *DEBUGGING
+ *SYSTEM_FD_MAX
+ *INPLACE_EDIT
+ *PERLDB
+ *BASETIME
+ *WARNING
+ *EXECUTABLE_NAME
+ *OSNAME
+);
+
+# The ground of all being. @ARG is deprecated (5.005 makes @_ lexical)
+
+ *ARG = *_ ;
+
+# Matching.
+
+ *MATCH = *& ;
+ *PREMATCH = *` ;
+ *POSTMATCH = *' ;
+ *LAST_PAREN_MATCH = *+ ;
+
+# Input.
+
+ *INPUT_LINE_NUMBER = *. ;
+ *NR = *. ;
+ *INPUT_RECORD_SEPARATOR = */ ;
+ *RS = */ ;
+
+# Output.
+
+ *OUTPUT_AUTOFLUSH = *| ;
+ *OUTPUT_FIELD_SEPARATOR = *, ;
+ *OFS = *, ;
+ *OUTPUT_RECORD_SEPARATOR = *\ ;
+ *ORS = *\ ;
+
+# Interpolation "constants".
+
+ *LIST_SEPARATOR = *" ;
+ *SUBSCRIPT_SEPARATOR = *; ;
+ *SUBSEP = *; ;
+
+# Formats
+
+ *FORMAT_PAGE_NUMBER = *% ;
+ *FORMAT_LINES_PER_PAGE = *= ;
+ *FORMAT_LINES_LEFT = *- ;
+ *FORMAT_NAME = *~ ;
+ *FORMAT_TOP_NAME = *^ ;
+ *FORMAT_LINE_BREAK_CHARACTERS = *: ;
+ *FORMAT_FORMFEED = *^L ;
+
+# Error status.
+
+ *CHILD_ERROR = *? ;
+ *OS_ERROR = *! ;
+ *ERRNO = *! ;
+ *EXTENDED_OS_ERROR = *^E ;
+ *EVAL_ERROR = *@ ;
+
+# Process info.
+
+ *PROCESS_ID = *$ ;
+ *PID = *$ ;
+ *REAL_USER_ID = *< ;
+ *UID = *< ;
+ *EFFECTIVE_USER_ID = *> ;
+ *EUID = *> ;
+ *REAL_GROUP_ID = *( ;
+ *GID = *( ;
+ *EFFECTIVE_GROUP_ID = *) ;
+ *EGID = *) ;
+ *PROGRAM_NAME = *0 ;
+
+# Internals.
+
+ *PERL_VERSION = *] ;
+ *ACCUMULATOR = *^A ;
+ *DEBUGGING = *^D ;
+ *SYSTEM_FD_MAX = *^F ;
+ *INPLACE_EDIT = *^I ;
+ *PERLDB = *^P ;
+ *BASETIME = *^T ;
+ *WARNING = *^W ;
+ *EXECUTABLE_NAME = *^X ;
+ *OSNAME = *^O ;
+
+# Deprecated.
+
+# *ARRAY_BASE = *[ ;
+# *OFMT = *# ;
+# *MULTILINE_MATCHING = ** ;
+
+1;
diff --git a/contrib/perl5/lib/Env.pm b/contrib/perl5/lib/Env.pm
new file mode 100644
index 000000000000..b0afc3b2dbf5
--- /dev/null
+++ b/contrib/perl5/lib/Env.pm
@@ -0,0 +1,77 @@
+package Env;
+
+=head1 NAME
+
+Env - perl module that imports environment variables
+
+=head1 SYNOPSIS
+
+ use Env;
+ use Env qw(PATH HOME TERM);
+
+=head1 DESCRIPTION
+
+Perl maintains environment variables in a pseudo-hash named %ENV. For
+when this access method is inconvenient, the Perl module C<Env> allows
+environment variables to be treated as simple variables.
+
+The Env::import() function ties environment variables with suitable
+names to global Perl variables with the same names. By default it
+does so with all existing environment variables (C<keys %ENV>). If
+the import function receives arguments, it takes them to be a list of
+environment variables to tie; it's okay if they don't yet exist.
+
+After an environment variable is tied, merely use it like a normal variable.
+You may access its value
+
+ @path = split(/:/, $PATH);
+
+or modify it
+
+ $PATH .= ":.";
+
+however you'd like.
+To remove a tied environment variable from
+the environment, assign it the undefined value
+
+ undef $PATH;
+
+=head1 AUTHOR
+
+Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt>
+
+=cut
+
+sub import {
+ my ($callpack) = caller(0);
+ my $pack = shift;
+ my @vars = grep /^[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
+ return unless @vars;
+
+ eval "package $callpack; use vars qw("
+ . join(' ', map { '$'.$_ } @vars) . ")";
+ die $@ if $@;
+ foreach (@vars) {
+ tie ${"${callpack}::$_"}, Env, $_;
+ }
+}
+
+sub TIESCALAR {
+ bless \($_[1]);
+}
+
+sub FETCH {
+ my ($self) = @_;
+ $ENV{$$self};
+}
+
+sub STORE {
+ my ($self, $value) = @_;
+ if (defined($value)) {
+ $ENV{$$self} = $value;
+ } else {
+ delete $ENV{$$self};
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/Exporter.pm b/contrib/perl5/lib/Exporter.pm
new file mode 100644
index 000000000000..3f42e407e0bb
--- /dev/null
+++ b/contrib/perl5/lib/Exporter.pm
@@ -0,0 +1,467 @@
+package Exporter;
+
+require 5.001;
+
+#
+# We go to a lot of trouble not to 'require Carp' at file scope,
+# because Carp requires Exporter, and something has to give.
+#
+
+$ExportLevel = 0;
+$Verbose = 0 unless $Verbose;
+
+sub export {
+
+ # First make import warnings look like they're coming from the "use".
+ local $SIG{__WARN__} = sub {
+ my $text = shift;
+ if ($text =~ s/ at \S*Exporter.pm line \d+.*\n//) {
+ require Carp;
+ local $Carp::CarpLevel = 1; # ignore package calling us too.
+ Carp::carp($text);
+ }
+ else {
+ warn $text;
+ }
+ };
+ local $SIG{__DIE__} = sub {
+ require Carp;
+ local $Carp::CarpLevel = 1; # ignore package calling us too.
+ Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
+ if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
+ };
+
+ my($pkg, $callpkg, @imports) = @_;
+ my($type, $sym, $oops);
+ *exports = *{"${pkg}::EXPORT"};
+
+ if (@imports) {
+ if (!%exports) {
+ grep(s/^&//, @exports);
+ @exports{@exports} = (1) x @exports;
+ my $ok = \@{"${pkg}::EXPORT_OK"};
+ if (@$ok) {
+ grep(s/^&//, @$ok);
+ @exports{@$ok} = (1) x @$ok;
+ }
+ }
+
+ if ($imports[0] =~ m#^[/!:]#){
+ my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
+ my $tagdata;
+ my %imports;
+ my($remove, $spec, @names, @allexports);
+ # negated first item implies starting with default set:
+ unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
+ foreach $spec (@imports){
+ $remove = $spec =~ s/^!//;
+
+ if ($spec =~ s/^://){
+ if ($spec eq 'DEFAULT'){
+ @names = @exports;
+ }
+ elsif ($tagdata = $tagsref->{$spec}) {
+ @names = @$tagdata;
+ }
+ else {
+ warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
+ ++$oops;
+ next;
+ }
+ }
+ elsif ($spec =~ m:^/(.*)/$:){
+ my $patn = $1;
+ @allexports = keys %exports unless @allexports; # only do keys once
+ @names = grep(/$patn/, @allexports); # not anchored by default
+ }
+ else {
+ @names = ($spec); # is a normal symbol name
+ }
+
+ warn "Import ".($remove ? "del":"add").": @names "
+ if $Verbose;
+
+ if ($remove) {
+ foreach $sym (@names) { delete $imports{$sym} }
+ }
+ else {
+ @imports{@names} = (1) x @names;
+ }
+ }
+ @imports = keys %imports;
+ }
+
+ foreach $sym (@imports) {
+ if (!$exports{$sym}) {
+ if ($sym =~ m/^\d/) {
+ $pkg->require_version($sym);
+ # If the version number was the only thing specified
+ # then we should act as if nothing was specified:
+ if (@imports == 1) {
+ @imports = @exports;
+ last;
+ }
+ # We need a way to emulate 'use Foo ()' but still
+ # allow an easy version check: "use Foo 1.23, ''";
+ if (@imports == 2 and !$imports[1]) {
+ @imports = ();
+ last;
+ }
+ } elsif ($sym !~ s/^&// || !$exports{$sym}) {
+ require Carp;
+ Carp::carp(qq["$sym" is not exported by the $pkg module]);
+ $oops++;
+ }
+ }
+ }
+ if ($oops) {
+ require Carp;
+ Carp::croak("Can't continue after import errors");
+ }
+ }
+ else {
+ @imports = @exports;
+ }
+
+ *fail = *{"${pkg}::EXPORT_FAIL"};
+ if (@fail) {
+ if (!%fail) {
+ # Build cache of symbols. Optimise the lookup by adding
+ # barewords twice... both with and without a leading &.
+ # (Technique could be applied to %exports cache at cost of memory)
+ my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail;
+ warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose;
+ @fail{@expanded} = (1) x @expanded;
+ }
+ my @failed;
+ foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} }
+ if (@failed) {
+ @failed = $pkg->export_fail(@failed);
+ foreach $sym (@failed) {
+ require Carp;
+ Carp::carp(qq["$sym" is not implemented by the $pkg module ],
+ "on this architecture");
+ }
+ if (@failed) {
+ require Carp;
+ Carp::croak("Can't continue after import errors");
+ }
+ }
+ }
+
+ warn "Importing into $callpkg from $pkg: ",
+ join(", ",sort @imports) if $Verbose;
+
+ foreach $sym (@imports) {
+ # shortcut for the common case of no type character
+ (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next)
+ unless $sym =~ s/^(\W)//;
+ $type = $1;
+ *{"${callpkg}::$sym"} =
+ $type eq '&' ? \&{"${pkg}::$sym"} :
+ $type eq '$' ? \${"${pkg}::$sym"} :
+ $type eq '@' ? \@{"${pkg}::$sym"} :
+ $type eq '%' ? \%{"${pkg}::$sym"} :
+ $type eq '*' ? *{"${pkg}::$sym"} :
+ do { require Carp; Carp::croak("Can't export symbol: $type$sym") };
+ }
+}
+
+sub export_to_level
+{
+ my $pkg = shift;
+ my ($level, $junk) = (shift, shift); # need to get rid of first arg
+ # we know it already.
+ my $callpkg = caller($level);
+ $pkg->export($callpkg, @_);
+}
+
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller($ExportLevel);
+ export $pkg, $callpkg, @_;
+}
+
+
+
+# Utility functions
+
+sub _push_tags {
+ my($pkg, $var, $syms) = @_;
+ my $nontag;
+ *export_tags = \%{"${pkg}::EXPORT_TAGS"};
+ push(@{"${pkg}::$var"},
+ map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) }
+ (@$syms) ? @$syms : keys %export_tags);
+ if ($nontag and $^W) {
+ # This may change to a die one day
+ require Carp;
+ Carp::carp("Some names are not tags");
+ }
+}
+
+sub export_tags { _push_tags((caller)[0], "EXPORT", \@_) }
+sub export_ok_tags { _push_tags((caller)[0], "EXPORT_OK", \@_) }
+
+
+# Default methods
+
+sub export_fail {
+ my $self = shift;
+ @_;
+}
+
+sub require_version {
+ my($self, $wanted) = @_;
+ my $pkg = ref $self || $self;
+ my $version = ${"${pkg}::VERSION"};
+ if (!$version or $version < $wanted) {
+ $version ||= "(undef)";
+ my $file = $INC{"$pkg.pm"};
+ $file &&= " ($file)";
+ require Carp;
+ Carp::croak("$pkg $wanted required--this is only version $version$file")
+ }
+ $version;
+}
+
+1;
+
+# A simple self test harness. Change 'require Carp' to 'use Carp ()' for testing.
+# package main; eval(join('',<DATA>)) or die $@ unless caller;
+__END__
+package Test;
+$INC{'Exporter.pm'} = 1;
+@ISA = qw(Exporter);
+@EXPORT = qw(A1 A2 A3 A4 A5);
+@EXPORT_OK = qw(B1 B2 B3 B4 B5);
+%EXPORT_TAGS = (T1=>[qw(A1 A2 B1 B2)], T2=>[qw(A1 A2 B3 B4)], T3=>[qw(X3)]);
+@EXPORT_FAIL = qw(B4);
+Exporter::export_ok_tags('T3', 'unknown_tag');
+sub export_fail {
+ map { "Test::$_" } @_ # edit symbols just as an example
+}
+
+package main;
+$Exporter::Verbose = 1;
+#import Test;
+#import Test qw(X3); # export ok via export_ok_tags()
+#import Test qw(:T1 !A2 /5/ !/3/ B5);
+import Test qw(:T2 !B4);
+import Test qw(:T2); # should fail
+1;
+
+=head1 NAME
+
+Exporter - Implements default import method for modules
+
+=head1 SYNOPSIS
+
+In module ModuleName.pm:
+
+ package ModuleName;
+ require Exporter;
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(...); # symbols to export by default
+ @EXPORT_OK = qw(...); # symbols to export on request
+ %EXPORT_TAGS = tag => [...]; # define names for sets of symbols
+
+In other files which wish to use ModuleName:
+
+ use ModuleName; # import default symbols into my package
+
+ use ModuleName qw(...); # import listed symbols into my package
+
+ use ModuleName (); # do not import any symbols
+
+=head1 DESCRIPTION
+
+The Exporter module implements a default C<import> method which
+many modules choose to inherit rather than implement their own.
+
+Perl automatically calls the C<import> method when processing a
+C<use> statement for a module. Modules and C<use> are documented
+in L<perlfunc> and L<perlmod>. Understanding the concept of
+modules and how the C<use> statement operates is important to
+understanding the Exporter.
+
+=head2 Selecting What To Export
+
+Do B<not> export method names!
+
+Do B<not> export anything else by default without a good reason!
+
+Exports pollute the namespace of the module user. If you must export
+try to use @EXPORT_OK in preference to @EXPORT and avoid short or
+common symbol names to reduce the risk of name clashes.
+
+Generally anything not exported is still accessible from outside the
+module using the ModuleName::item_name (or $blessed_ref-E<gt>method)
+syntax. By convention you can use a leading underscore on names to
+informally indicate that they are 'internal' and not for public use.
+
+(It is actually possible to get private functions by saying:
+
+ my $subref = sub { ... };
+ &$subref;
+
+But there's no way to call that directly as a method, since a method
+must have a name in the symbol table.)
+
+As a general rule, if the module is trying to be object oriented
+then export nothing. If it's just a collection of functions then
+@EXPORT_OK anything but use @EXPORT with caution.
+
+Other module design guidelines can be found in L<perlmod>.
+
+=head2 Specialised Import Lists
+
+If the first entry in an import list begins with !, : or / then the
+list is treated as a series of specifications which either add to or
+delete from the list of names to import. They are processed left to
+right. Specifications are in the form:
+
+ [!]name This name only
+ [!]:DEFAULT All names in @EXPORT
+ [!]:tag All names in $EXPORT_TAGS{tag} anonymous list
+ [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
+
+A leading ! indicates that matching names should be deleted from the
+list of names to import. If the first specification is a deletion it
+is treated as though preceded by :DEFAULT. If you just want to import
+extra names in addition to the default set you will still need to
+include :DEFAULT explicitly.
+
+e.g., Module.pm defines:
+
+ @EXPORT = qw(A1 A2 A3 A4 A5);
+ @EXPORT_OK = qw(B1 B2 B3 B4 B5);
+ %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
+
+ Note that you cannot use tags in @EXPORT or @EXPORT_OK.
+ Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
+
+An application using Module can say something like:
+
+ use Module qw(:DEFAULT :T2 !B3 A3);
+
+Other examples include:
+
+ use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
+ use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/);
+
+Remember that most patterns (using //) will need to be anchored
+with a leading ^, e.g., C</^EXIT/> rather than C</EXIT/>.
+
+You can say C<BEGIN { $Exporter::Verbose=1 }> to see how the
+specifications are being processed and what is actually being imported
+into modules.
+
+=head2 Exporting without using Export's import method
+
+Exporter has a special method, 'export_to_level' which is used in situations
+where you can't directly call Export's import method. The export_to_level
+method looks like:
+
+MyPackage->export_to_level($where_to_export, @what_to_export);
+
+where $where_to_export is an integer telling how far up the calling stack
+to export your symbols, and @what_to_export is an array telling what
+symbols *to* export (usually this is @_).
+
+For example, suppose that you have a module, A, which already has an
+import function:
+
+package A;
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw ($b);
+
+sub import
+{
+ $A::b = 1; # not a very useful import method
+}
+
+and you want to Export symbol $A::b back to the module that called
+package A. Since Exporter relies on the import method to work, via
+inheritance, as it stands Exporter::import() will never get called.
+Instead, say the following:
+
+package A;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw ($b);
+
+sub import
+{
+ $A::b = 1;
+ A->export_to_level(1, @_);
+}
+
+This will export the symbols one level 'above' the current package - ie: to
+the program or module that used package A.
+
+Note: Be careful not to modify '@_' at all before you call export_to_level
+- or people using your package will get very unexplained results!
+
+
+=head2 Module Version Checking
+
+The Exporter module will convert an attempt to import a number from a
+module into a call to $module_name-E<gt>require_version($value). This can
+be used to validate that the version of the module being used is
+greater than or equal to the required version.
+
+The Exporter module supplies a default require_version method which
+checks the value of $VERSION in the exporting module.
+
+Since the default require_version method treats the $VERSION number as
+a simple numeric value it will regard version 1.10 as lower than
+1.9. For this reason it is strongly recommended that you use numbers
+with at least two decimal places, e.g., 1.09.
+
+=head2 Managing Unknown Symbols
+
+In some situations you may want to prevent certain symbols from being
+exported. Typically this applies to extensions which have functions
+or constants that may not exist on some systems.
+
+The names of any symbols that cannot be exported should be listed
+in the C<@EXPORT_FAIL> array.
+
+If a module attempts to import any of these symbols the Exporter
+will give the module an opportunity to handle the situation before
+generating an error. The Exporter will call an export_fail method
+with a list of the failed symbols:
+
+ @failed_symbols = $module_name->export_fail(@failed_symbols);
+
+If the export_fail method returns an empty list then no error is
+recorded and all the requested symbols are exported. If the returned
+list is not empty then an error is generated for each symbol and the
+export fails. The Exporter provides a default export_fail method which
+simply returns the list unchanged.
+
+Uses for the export_fail method include giving better error messages
+for some symbols and performing lazy architectural checks (put more
+symbols into @EXPORT_FAIL by default and then take them out if someone
+actually tries to use them and an expensive check shows that they are
+usable on that platform).
+
+=head2 Tag Handling Utility Functions
+
+Since the symbols listed within %EXPORT_TAGS must also appear in either
+@EXPORT or @EXPORT_OK, two utility functions are provided which allow
+you to easily add tagged sets of symbols to @EXPORT or @EXPORT_OK:
+
+ %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]);
+
+ Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT
+ Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK
+
+Any names which are not tags are added to @EXPORT or @EXPORT_OK
+unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags
+names being silently added to @EXPORT or @EXPORT_OK. Future versions
+may make this a fatal error.
+
+=cut
diff --git a/contrib/perl5/lib/ExtUtils/Command.pm b/contrib/perl5/lib/ExtUtils/Command.pm
new file mode 100644
index 000000000000..2f5f1e168998
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/Command.pm
@@ -0,0 +1,211 @@
+package ExtUtils::Command;
+use strict;
+# use AutoLoader;
+use Carp;
+use File::Copy;
+use File::Compare;
+use File::Basename;
+use File::Path qw(rmtree);
+require Exporter;
+use vars qw(@ISA @EXPORT $VERSION);
+@ISA = qw(Exporter);
+@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f);
+$VERSION = '1.01';
+
+=head1 NAME
+
+ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
+
+=head1 SYNOPSIS
+
+ perl -MExtUtils::Command -e cat files... > destination
+ perl -MExtUtils::Command -e mv source... destination
+ perl -MExtUtils::Command -e cp source... destination
+ perl -MExtUtils::Command -e touch files...
+ perl -MExtUtils::Command -e rm_f file...
+ perl -MExtUtils::Command -e rm_rf directories...
+ perl -MExtUtils::Command -e mkpath directories...
+ perl -MExtUtils::Command -e eqtime source destination
+ perl -MExtUtils::Command -e chmod mode files...
+ perl -MExtUtils::Command -e test_f file
+
+=head1 DESCRIPTION
+
+The module is used in Win32 port to replace common UNIX commands.
+Most commands are wrapers on generic modules File::Path and File::Basename.
+
+=over 4
+
+=cut
+
+sub expand_wildcards
+{
+ @ARGV = map(/[\*\?]/ ? glob($_) : $_,@ARGV);
+}
+
+=item cat
+
+Concatenates all files mentioned on command line to STDOUT.
+
+=cut
+
+sub cat ()
+{
+ expand_wildcards();
+ print while (<>);
+}
+
+=item eqtime src dst
+
+Sets modified time of dst to that of src
+
+=cut
+
+sub eqtime
+{
+ my ($src,$dst) = @ARGV;
+ open(F,">$dst");
+ close(F);
+ utime((stat($src))[8,9],$dst);
+}
+
+=item rm_f files....
+
+Removes directories - recursively (even if readonly)
+
+=cut
+
+sub rm_rf
+{
+ rmtree([grep -e $_,expand_wildcards()],0,0);
+}
+
+=item rm_f files....
+
+Removes files (even if readonly)
+
+=cut
+
+sub rm_f
+{
+ foreach (expand_wildcards())
+ {
+ next unless -f $_;
+ next if unlink($_);
+ chmod(0777,$_);
+ next if unlink($_);
+ carp "Cannot delete $_:$!";
+ }
+}
+
+=item touch files ...
+
+Makes files exist, with current timestamp
+
+=cut
+
+sub touch
+{
+ expand_wildcards();
+ my $t = time;
+ while (@ARGV)
+ {
+ my $file = shift(@ARGV);
+ open(FILE,">>$file") || die "Cannot write $file:$!";
+ close(FILE);
+ utime($t,$t,$file);
+ }
+}
+
+=item mv source... destination
+
+Moves source to destination.
+Multiple sources are allowed if destination is an existing directory.
+
+=cut
+
+sub mv
+{
+ my $dst = pop(@ARGV);
+ expand_wildcards();
+ croak("Too many arguments") if (@ARGV > 1 && ! -d $dst);
+ while (@ARGV)
+ {
+ my $src = shift(@ARGV);
+ move($src,$dst);
+ }
+}
+
+=item cp source... destination
+
+Copies source to destination.
+Multiple sources are allowed if destination is an existing directory.
+
+=cut
+
+sub cp
+{
+ my $dst = pop(@ARGV);
+ expand_wildcards();
+ croak("Too many arguments") if (@ARGV > 1 && ! -d $dst);
+ while (@ARGV)
+ {
+ my $src = shift(@ARGV);
+ copy($src,$dst);
+ }
+}
+
+=item chmod mode files...
+
+Sets UNIX like permissions 'mode' on all the files.
+
+=cut
+
+sub chmod
+{
+ my $mode = shift(@ARGV);
+ chmod($mode,expand_wildcards()) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!";
+}
+
+=item mkpath directory...
+
+Creates directory, including any parent directories.
+
+=cut
+
+sub mkpath
+{
+ File::Path::mkpath([expand_wildcards()],1,0777);
+}
+
+=item test_f file
+
+Tests if a file exists
+
+=cut
+
+sub test_f
+{
+ exit !-f shift(@ARGV);
+}
+
+
+1;
+__END__
+
+=back
+
+=head1 BUGS
+
+Should probably be Auto/Self loaded.
+
+=head1 SEE ALSO
+
+ExtUtils::MakeMaker, ExtUtils::MM_Unix, ExtUtils::MM_Win32
+
+=head1 AUTHOR
+
+Nick Ing-Simmons <F<nick@ni-s.u-net.com>>.
+
+=cut
+
diff --git a/contrib/perl5/lib/ExtUtils/Embed.pm b/contrib/perl5/lib/ExtUtils/Embed.pm
new file mode 100644
index 000000000000..e41ca40e66d6
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/Embed.pm
@@ -0,0 +1,502 @@
+# $Id: Embed.pm,v 1.2501 $
+require 5.002;
+
+package ExtUtils::Embed;
+require Exporter;
+require FileHandle;
+use Config;
+use Getopt::Std;
+
+#Only when we need them
+#require ExtUtils::MakeMaker;
+#require ExtUtils::Liblist;
+
+use vars qw(@ISA @EXPORT $VERSION
+ @Extensions $Verbose $lib_ext
+ $opt_o $opt_s
+ );
+use strict;
+
+$VERSION = sprintf("%d.%02d", q$Revision: 1.2505 $ =~ /(\d+)\.(\d+)/);
+
+@ISA = qw(Exporter);
+@EXPORT = qw(&xsinit &ldopts
+ &ccopts &ccflags &ccdlflags &perl_inc
+ &xsi_header &xsi_protos &xsi_body);
+
+#let's have Miniperl borrow from us instead
+#require ExtUtils::Miniperl;
+#*canon = \&ExtUtils::Miniperl::canon;
+
+$Verbose = 0;
+$lib_ext = $Config{lib_ext} || '.a';
+
+sub is_cmd { $0 eq '-e' }
+
+sub my_return {
+ my $val = shift;
+ if(is_cmd) {
+ print $val;
+ }
+ else {
+ return $val;
+ }
+}
+
+sub is_perl_object {
+ $Config{ccflags} =~ /-DPERL_OBJECT/;
+}
+
+sub xsinit {
+ my($file, $std, $mods) = @_;
+ my($fh,@mods,%seen);
+ $file ||= "perlxsi.c";
+ my $xsinit_proto = is_perl_object() ? "CPERLarg" : "void";
+
+ if (@_) {
+ @mods = @$mods if $mods;
+ }
+ else {
+ getopts('o:s:');
+ $file = $opt_o if defined $opt_o;
+ $std = $opt_s if defined $opt_s;
+ @mods = @ARGV;
+ }
+ $std = 1 unless scalar @mods;
+
+ if ($file eq "STDOUT") {
+ $fh = \*STDOUT;
+ }
+ else {
+ $fh = new FileHandle "> $file";
+ }
+
+ push(@mods, static_ext()) if defined $std;
+ @mods = grep(!$seen{$_}++, @mods);
+
+ print $fh &xsi_header();
+ print $fh "EXTERN_C void xs_init _(($xsinit_proto));\n\n";
+ print $fh &xsi_protos(@mods);
+
+ print $fh "\nEXTERN_C void\nxs_init($xsinit_proto)\n{\n";
+ print $fh &xsi_body(@mods);
+ print $fh "}\n";
+
+}
+
+sub xsi_header {
+ return <<EOF;
+#if defined(__cplusplus) && !defined(PERL_OBJECT)
+#define is_cplusplus
+#endif
+
+#ifdef is_cplusplus
+extern "C" {
+#endif
+
+#include <EXTERN.h>
+#include <perl.h>
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#include <XSUB.h>
+#include "win32iop.h"
+#include <fcntl.h>
+#include <perlhost.h>
+#endif
+#ifdef is_cplusplus
+}
+# ifndef EXTERN_C
+# define EXTERN_C extern "C"
+# endif
+#else
+# ifndef EXTERN_C
+# define EXTERN_C extern
+# endif
+#endif
+
+EOF
+}
+
+sub xsi_protos {
+ my(@exts) = @_;
+ my(@retval,%seen);
+ my $boot_proto = is_perl_object() ?
+ "CV* cv _CPERLarg" : "CV* cv";
+ foreach $_ (@exts){
+ my($pname) = canon('/', $_);
+ my($mname, $cname);
+ ($mname = $pname) =~ s!/!::!g;
+ ($cname = $pname) =~ s!/!__!g;
+ my($ccode) = "EXTERN_C void boot_${cname} _(($boot_proto));\n";
+ next if $seen{$ccode}++;
+ push(@retval, $ccode);
+ }
+ return join '', @retval;
+}
+
+sub xsi_body {
+ my(@exts) = @_;
+ my($pname,@retval,%seen);
+ my($dl) = canon('/','DynaLoader');
+ push(@retval, "\tchar *file = __FILE__;\n");
+ push(@retval, "\tdXSUB_SYS;\n") if $] > 5.002;
+ push(@retval, "\n");
+
+ foreach $_ (@exts){
+ my($pname) = canon('/', $_);
+ my($mname, $cname, $ccode);
+ ($mname = $pname) =~ s!/!::!g;
+ ($cname = $pname) =~ s!/!__!g;
+ if ($pname eq $dl){
+ # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
+ # boot_DynaLoader is called directly in DynaLoader.pm
+ $ccode = "\t/* DynaLoader is a special case */\n\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n";
+ push(@retval, $ccode) unless $seen{$ccode}++;
+ } else {
+ $ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n";
+ push(@retval, $ccode) unless $seen{$ccode}++;
+ }
+ }
+ return join '', @retval;
+}
+
+sub static_ext {
+ unless (scalar @Extensions) {
+ @Extensions = sort split /\s+/, $Config{static_ext};
+ unshift @Extensions, qw(DynaLoader);
+ }
+ @Extensions;
+}
+
+sub ldopts {
+ require ExtUtils::MakeMaker;
+ require ExtUtils::Liblist;
+ my($std,$mods,$link_args,$path) = @_;
+ my(@mods,@link_args,@argv);
+ my($dllib,$config_libs,@potential_libs,@path);
+ local($") = ' ' unless $" eq ' ';
+ my $MM = bless {} => 'MY';
+ if (scalar @_) {
+ @link_args = @$link_args if $link_args;
+ @mods = @$mods if $mods;
+ }
+ else {
+ @argv = @ARGV;
+ #hmm
+ while($_ = shift @argv) {
+ /^-std$/ && do { $std = 1; next; };
+ /^--$/ && do { @link_args = @argv; last; };
+ /^-I(.*)/ && do { $path = $1 || shift @argv; next; };
+ push(@mods, $_);
+ }
+ }
+ $std = 1 unless scalar @link_args;
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+ push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+ my($mod,@ns,$root,$sub,$extra,$archive,@archives);
+ print STDERR "Searching (@path) for archives\n" if $Verbose;
+ foreach $mod (@mods) {
+ @ns = split(/::|\/|\\/, $mod);
+ $sub = $ns[-1];
+ $root = $MM->catdir(@ns);
+
+ print STDERR "searching for '$sub${lib_ext}'\n" if $Verbose;
+ foreach (@path) {
+ next unless -e ($archive = $MM->catdir($_,"auto",$root,"$sub$lib_ext"));
+ push @archives, $archive;
+ if(-e ($extra = $MM->catdir($_,"auto",$root,"extralibs.ld"))) {
+ local(*FH);
+ if(open(FH, $extra)) {
+ my($libs) = <FH>; chomp $libs;
+ push @potential_libs, split /\s+/, $libs;
+ }
+ else {
+ warn "Couldn't open '$extra'";
+ }
+ }
+ last;
+ }
+ }
+ #print STDERR "\@potential_libs = @potential_libs\n";
+
+ my $libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0] || "-lperl";
+
+ my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) =
+ $MM->ext(join ' ',
+ $MM->catdir("-L$Config{archlibexp}", "CORE"), " $libperl",
+ @potential_libs);
+
+ my $ld_or_bs = $bsloadlibs || $ldloadlibs;
+ print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose;
+ my $linkage = "$Config{ccdlflags} $Config{ldflags} @archives $ld_or_bs";
+ print STDERR "ldopts: '$linkage'\n" if $Verbose;
+
+ return $linkage if scalar @_;
+ my_return("$linkage\n");
+}
+
+sub ccflags {
+ my_return(" $Config{ccflags} ");
+}
+
+sub ccdlflags {
+ my_return(" $Config{ccdlflags} ");
+}
+
+sub perl_inc {
+ my_return(" -I$Config{archlibexp}/CORE ");
+}
+
+sub ccopts {
+ ccflags . perl_inc;
+}
+
+sub canon {
+ my($as, @ext) = @_;
+ foreach(@ext) {
+ # might be X::Y or lib/auto/X/Y/Y.a
+ next if s!::!/!g;
+ s:^(lib|ext)/(auto/)?::;
+ s:/\w+\.\w+$::;
+ }
+ grep(s:/:$as:, @ext) if ($as ne '/');
+ @ext;
+}
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications
+
+=head1 SYNOPSIS
+
+
+ perl -MExtUtils::Embed -e xsinit
+ perl -MExtUtils::Embed -e ldopts
+
+=head1 DESCRIPTION
+
+ExtUtils::Embed provides utility functions for embedding a Perl interpreter
+and extensions in your C/C++ applications.
+Typically, an application B<Makefile> will invoke ExtUtils::Embed
+functions while building your application.
+
+=head1 @EXPORT
+
+ExtUtils::Embed exports the following functions:
+
+xsinit(), ldopts(), ccopts(), perl_inc(), ccflags(),
+ccdlflags(), xsi_header(), xsi_protos(), xsi_body()
+
+=head1 FUNCTIONS
+
+=over
+
+=item xsinit()
+
+Generate C/C++ code for the XS initializer function.
+
+When invoked as C<`perl -MExtUtils::Embed -e xsinit --`>
+the following options are recognized:
+
+B<-o> E<lt>output filenameE<gt> (Defaults to B<perlxsi.c>)
+
+B<-o STDOUT> will print to STDOUT.
+
+B<-std> (Write code for extensions that are linked with the current Perl.)
+
+Any additional arguments are expected to be names of modules
+to generate code for.
+
+When invoked with parameters the following are accepted and optional:
+
+C<xsinit($filename,$std,[@modules])>
+
+Where,
+
+B<$filename> is equivalent to the B<-o> option.
+
+B<$std> is boolean, equivalent to the B<-std> option.
+
+B<[@modules]> is an array ref, same as additional arguments mentioned above.
+
+=item Examples
+
+
+ perl -MExtUtils::Embed -e xsinit -- -o xsinit.c Socket
+
+
+This will generate code with an B<xs_init> function that glues the perl B<Socket::bootstrap> function
+to the C B<boot_Socket> function and writes it to a file named "xsinit.c".
+
+Note that B<DynaLoader> is a special case where it must call B<boot_DynaLoader> directly.
+
+ perl -MExtUtils::Embed -e xsinit
+
+
+This will generate code for linking with B<DynaLoader> and
+each static extension found in B<$Config{static_ext}>.
+The code is written to the default file name B<perlxsi.c>.
+
+
+ perl -MExtUtils::Embed -e xsinit -- -o xsinit.c -std DBI DBD::Oracle
+
+
+Here, code is written for all the currently linked extensions along with code
+for B<DBI> and B<DBD::Oracle>.
+
+If you have a working B<DynaLoader> then there is rarely any need to statically link in any
+other extensions.
+
+=item ldopts()
+
+Output arguments for linking the Perl library and extensions to your
+application.
+
+When invoked as C<`perl -MExtUtils::Embed -e ldopts --`>
+the following options are recognized:
+
+B<-std>
+
+Output arguments for linking the Perl library and any extensions linked
+with the current Perl.
+
+B<-I> E<lt>path1:path2E<gt>
+
+Search path for ModuleName.a archives.
+Default path is B<@INC>.
+Library archives are expected to be found as
+B</some/path/auto/ModuleName/ModuleName.a>
+For example, when looking for B<Socket.a> relative to a search path,
+we should find B<auto/Socket/Socket.a>
+
+When looking for B<DBD::Oracle> relative to a search path,
+we should find B<auto/DBD/Oracle/Oracle.a>
+
+Keep in mind, you can always supply B</my/own/path/ModuleName.a>
+as an additional linker argument.
+
+B<--> E<lt>list of linker argsE<gt>
+
+Additional linker arguments to be considered.
+
+Any additional arguments found before the B<--> token
+are expected to be names of modules to generate code for.
+
+When invoked with parameters the following are accepted and optional:
+
+C<ldopts($std,[@modules],[@link_args],$path)>
+
+Where,
+
+B<$std> is boolean, equivalent to the B<-std> option.
+
+B<[@modules]> is equivalent to additional arguments found before the B<--> token.
+
+B<[@link_args]> is equivalent to arguments found after the B<--> token.
+
+B<$path> is equivalent to the B<-I> option.
+
+In addition, when ldopts is called with parameters, it will return the argument string
+rather than print it to STDOUT.
+
+=item Examples
+
+
+ perl -MExtUtils::Embed -e ldopts
+
+
+This will print arguments for linking with B<libperl.a>, B<DynaLoader> and
+extensions found in B<$Config{static_ext}>. This includes libraries
+found in B<$Config{libs}> and the first ModuleName.a library
+for each extension that is found by searching B<@INC> or the path
+specifed by the B<-I> option.
+In addition, when ModuleName.a is found, additional linker arguments
+are picked up from the B<extralibs.ld> file in the same directory.
+
+
+ perl -MExtUtils::Embed -e ldopts -- -std Socket
+
+
+This will do the same as the above example, along with printing additional arguments for linking with the B<Socket> extension.
+
+
+ perl -MExtUtils::Embed -e ldopts -- DynaLoader
+
+
+This will print arguments for linking with just the B<DynaLoader> extension
+and B<libperl.a>.
+
+
+ perl -MExtUtils::Embed -e ldopts -- -std Msql -- -L/usr/msql/lib -lmsql
+
+
+Any arguments after the second '--' token are additional linker
+arguments that will be examined for potential conflict. If there is no
+conflict, the additional arguments will be part of the output.
+
+
+=item perl_inc()
+
+For including perl header files this function simply prints:
+
+ -I$Config{archlibexp}/CORE
+
+So, rather than having to say:
+
+ perl -MConfig -e 'print "-I$Config{archlibexp}/CORE"'
+
+Just say:
+
+ perl -MExtUtils::Embed -e perl_inc
+
+=item ccflags(), ccdlflags()
+
+These functions simply print $Config{ccflags} and $Config{ccdlflags}
+
+=item ccopts()
+
+This function combines perl_inc(), ccflags() and ccdlflags() into one.
+
+=item xsi_header()
+
+This function simply returns a string defining the same B<EXTERN_C> macro as
+B<perlmain.c> along with #including B<perl.h> and B<EXTERN.h>.
+
+=item xsi_protos(@modules)
+
+This function returns a string of B<boot_$ModuleName> prototypes for each @modules.
+
+=item xsi_body(@modules)
+
+This function returns a string of calls to B<newXS()> that glue the module B<bootstrap>
+function to B<boot_ModuleName> for each @modules.
+
+B<xsinit()> uses the xsi_* functions to generate most of it's code.
+
+=back
+
+=head1 EXAMPLES
+
+For examples on how to use B<ExtUtils::Embed> for building C/C++ applications
+with embedded perl, see the eg/ directory and L<perlembed>.
+
+=head1 SEE ALSO
+
+L<perlembed>
+
+=head1 AUTHOR
+
+Doug MacEachern E<lt>F<dougm@osf.org>E<gt>
+
+Based on ideas from Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt> and
+B<minimod.pl> by Andreas Koenig E<lt>F<k@anna.in-berlin.de>E<gt> and Tim Bunce.
+
+=cut
+
diff --git a/contrib/perl5/lib/ExtUtils/Install.pm b/contrib/perl5/lib/ExtUtils/Install.pm
new file mode 100644
index 000000000000..6a5c1847accc
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/Install.pm
@@ -0,0 +1,374 @@
+package ExtUtils::Install;
+
+$VERSION = substr q$Revision: 1.28 $, 10;
+# $Date: 1998/01/25 07:08:24 $
+
+use Exporter;
+use Carp ();
+use Config qw(%Config);
+use vars qw(@ISA @EXPORT $VERSION);
+@ISA = ('Exporter');
+@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
+$Is_VMS = $^O eq 'VMS';
+
+my $splitchar = $^O eq 'VMS' ? '|' : ($^O eq 'os2' || $^O eq 'dos') ? ';' : ':';
+my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
+my $Inc_uninstall_warn_handler;
+
+#use vars qw( @EXPORT @ISA $Is_VMS );
+#use strict;
+
+sub forceunlink {
+ chmod 0666, $_[0];
+ unlink $_[0] or Carp::croak("Cannot forceunlink $_[0]: $!")
+}
+
+sub install {
+ my($hash,$verbose,$nonono,$inc_uninstall) = @_;
+ $verbose ||= 0;
+ $nonono ||= 0;
+
+ use Cwd qw(cwd);
+ use ExtUtils::MakeMaker; # to implement a MY class
+ use ExtUtils::Packlist;
+ use File::Basename qw(dirname);
+ use File::Copy qw(copy);
+ use File::Find qw(find);
+ use File::Path qw(mkpath);
+ use File::Compare qw(compare);
+
+ my(%hash) = %$hash;
+ my(%pack, $dir, $warn_permissions);
+ my($packlist) = ExtUtils::Packlist->new();
+ # -w doesn't work reliably on FAT dirs
+ $warn_permissions++ if $^O eq 'MSWin32';
+ local(*DIR);
+ for (qw/read write/) {
+ $pack{$_}=$hash{$_};
+ delete $hash{$_};
+ }
+ my($source_dir_or_file);
+ foreach $source_dir_or_file (sort keys %hash) {
+ #Check if there are files, and if yes, look if the corresponding
+ #target directory is writable for us
+ opendir DIR, $source_dir_or_file or next;
+ for (readdir DIR) {
+ next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
+ if (-w $hash{$source_dir_or_file} ||
+ mkpath($hash{$source_dir_or_file})) {
+ last;
+ } else {
+ warn "Warning: You do not have permissions to " .
+ "install into $hash{$source_dir_or_file}"
+ unless $warn_permissions++;
+ }
+ }
+ closedir DIR;
+ }
+ $packlist->read($pack{"read"}) if (-f $pack{"read"});
+ my $cwd = cwd();
+ my $umask = umask 0 unless $Is_VMS;
+
+ my($source);
+ MOD_INSTALL: foreach $source (sort keys %hash) {
+ #copy the tree to the target directory without altering
+ #timestamp and permission and remember for the .packlist
+ #file. The packlist file contains the absolute paths of the
+ #install locations. AFS users may call this a bug. We'll have
+ #to reconsider how to add the means to satisfy AFS users also.
+
+ #October 1997: we want to install .pm files into archlib if
+ #there are any files in arch. So we depend on having ./blib/arch
+ #hardcoded here.
+ my $targetroot = $hash{$source};
+ if ($source eq "blib/lib" and
+ exists $hash{"blib/arch"} and
+ directory_not_empty("blib/arch")) {
+ $targetroot = $hash{"blib/arch"};
+ print "Files found in blib/arch --> Installing files in "
+ . "blib/lib into architecture dependend library tree!\n"
+ ; #if $verbose>1;
+ }
+ chdir($source) or next;
+ find(sub {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = stat;
+ return unless -f _;
+ return if $_ eq ".exists";
+ my $targetdir = MY->catdir($targetroot,$File::Find::dir);
+ my $targetfile = MY->catfile($targetdir,$_);
+
+ my $diff = 0;
+ if ( -f $targetfile && -s _ == $size) {
+ # We have a good chance, we can skip this one
+ $diff = compare($_,$targetfile);
+ } else {
+ print "$_ differs\n" if $verbose>1;
+ $diff++;
+ }
+
+ if ($diff){
+ if (-f $targetfile){
+ forceunlink($targetfile) unless $nonono;
+ } else {
+ mkpath($targetdir,0,0755) unless $nonono;
+ print "mkpath($targetdir,0,0755)\n" if $verbose>1;
+ }
+ copy($_,$targetfile) unless $nonono;
+ print "Installing $targetfile\n";
+ utime($atime,$mtime + $Is_VMS,$targetfile) unless $nonono>1;
+ print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
+ $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
+ chmod $mode, $targetfile;
+ print "chmod($mode, $targetfile)\n" if $verbose>1;
+ } else {
+ print "Skipping $targetfile (unchanged)\n" if $verbose;
+ }
+
+ if (! defined $inc_uninstall) { # it's called
+ } elsif ($inc_uninstall == 0){
+ inc_uninstall($_,$File::Find::dir,$verbose,1); # nonono set to 1
+ } else {
+ inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
+ }
+ $packlist->{$targetfile}++;
+
+ }, ".");
+ chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
+ }
+ umask $umask unless $Is_VMS;
+ if ($pack{'write'}) {
+ $dir = dirname($pack{'write'});
+ mkpath($dir,0,0755);
+ print "Writing $pack{'write'}\n";
+ $packlist->write($pack{'write'});
+ }
+}
+
+sub directory_not_empty ($) {
+ my($dir) = @_;
+ my $files = 0;
+ find(sub {
+ return if $_ eq ".exists";
+ if (-f) {
+ $File::Find::prune++;
+ $files = 1;
+ }
+ }, $dir);
+ return $files;
+}
+
+sub install_default {
+ @_ < 2 or die "install_default should be called with 0 or 1 argument";
+ my $FULLEXT = @_ ? shift : $ARGV[0];
+ defined $FULLEXT or die "Do not know to where to write install log";
+ my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
+ my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
+ my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
+ my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
+ my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
+ my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
+ install({
+ read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
+ write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
+ $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
+ $Config{installsitearch} :
+ $Config{installsitelib},
+ $INST_ARCHLIB => $Config{installsitearch},
+ $INST_BIN => $Config{installbin} ,
+ $INST_SCRIPT => $Config{installscript},
+ $INST_MAN1DIR => $Config{installman1dir},
+ $INST_MAN3DIR => $Config{installman3dir},
+ },1,0,0);
+}
+
+sub uninstall {
+ use ExtUtils::Packlist;
+ my($fil,$verbose,$nonono) = @_;
+ die "no packlist file found: $fil" unless -f $fil;
+ # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
+ # require $my_req; # Hairy, but for the first
+ my ($packlist) = ExtUtils::Packlist->new($fil);
+ foreach (sort(keys(%$packlist))) {
+ chomp;
+ print "unlink $_\n" if $verbose;
+ forceunlink($_) unless $nonono;
+ }
+ print "unlink $fil\n" if $verbose;
+ close P;
+ forceunlink($fil) unless $nonono;
+}
+
+sub inc_uninstall {
+ my($file,$libdir,$verbose,$nonono) = @_;
+ my($dir);
+ my %seen_dir = ();
+ foreach $dir (@INC, @PERL_ENV_LIB, @Config{qw(archlibexp
+ privlibexp
+ sitearchexp
+ sitelibexp)}) {
+ next if $dir eq ".";
+ next if $seen_dir{$dir}++;
+ my($targetfile) = MY->catfile($dir,$libdir,$file);
+ next unless -f $targetfile;
+
+ # The reason why we compare file's contents is, that we cannot
+ # know, which is the file we just installed (AFS). So we leave
+ # an identical file in place
+ my $diff = 0;
+ if ( -f $targetfile && -s _ == -s $file) {
+ # We have a good chance, we can skip this one
+ $diff = compare($file,$targetfile);
+ } else {
+ print "#$file and $targetfile differ\n" if $verbose>1;
+ $diff++;
+ }
+
+ next unless $diff;
+ if ($nonono) {
+ if ($verbose) {
+ $Inc_uninstall_warn_handler ||= new ExtUtils::Install::Warn;
+ $libdir =~ s|^\./|| ; # That's just cosmetics, no need to port. It looks prettier.
+ $Inc_uninstall_warn_handler->add("$libdir/$file",$targetfile);
+ }
+ # if not verbose, we just say nothing
+ } else {
+ print "Unlinking $targetfile (shadowing?)\n";
+ forceunlink($targetfile);
+ }
+ }
+}
+
+sub pm_to_blib {
+ my($fromto,$autodir) = @_;
+
+ use File::Basename qw(dirname);
+ use File::Copy qw(copy);
+ use File::Path qw(mkpath);
+ use File::Compare qw(compare);
+ use AutoSplit;
+ # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
+ # require $my_req; # Hairy, but for the first
+
+ if (!ref($fromto) && -r $fromto)
+ {
+ # Win32 has severe command line length limitations, but
+ # can generate temporary files on-the-fly
+ # so we pass name of file here - eval it to get hash
+ open(FROMTO,"<$fromto") or die "Cannot open $fromto:$!";
+ my $str = '$fromto = {qw{'.join('',<FROMTO>).'}}';
+ eval $str;
+ close(FROMTO);
+ }
+
+ my $umask = umask 0022 unless $Is_VMS;
+ mkpath($autodir,0,0755);
+ foreach (keys %$fromto) {
+ next if -f $fromto->{$_} && -M $fromto->{$_} < -M $_;
+ unless (compare($_,$fromto->{$_})){
+ print "Skip $fromto->{$_} (unchanged)\n";
+ next;
+ }
+ if (-f $fromto->{$_}){
+ forceunlink($fromto->{$_});
+ } else {
+ mkpath(dirname($fromto->{$_}),0,0755);
+ }
+ copy($_,$fromto->{$_});
+ my($mode,$atime,$mtime) = (stat)[2,8,9];
+ utime($atime,$mtime+$Is_VMS,$fromto->{$_});
+ chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$fromto->{$_});
+ print "cp $_ $fromto->{$_}\n";
+ next unless /\.pm$/;
+ autosplit($fromto->{$_},$autodir);
+ }
+ umask $umask unless $Is_VMS;
+}
+
+package ExtUtils::Install::Warn;
+
+sub new { bless {}, shift }
+
+sub add {
+ my($self,$file,$targetfile) = @_;
+ push @{$self->{$file}}, $targetfile;
+}
+
+sub DESTROY {
+ my $self = shift;
+ my($file,$i,$plural);
+ foreach $file (sort keys %$self) {
+ $plural = @{$self->{$file}} > 1 ? "s" : "";
+ print "## Differing version$plural of $file found. You might like to\n";
+ for (0..$#{$self->{$file}}) {
+ print "rm ", $self->{$file}[$_], "\n";
+ $i++;
+ }
+ }
+ $plural = $i>1 ? "all those files" : "this file";
+ print "## Running 'make install UNINST=1' will unlink $plural for you.\n";
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Install - install files from here to there
+
+=head1 SYNOPSIS
+
+B<use ExtUtils::Install;>
+
+B<install($hashref,$verbose,$nonono);>
+
+B<uninstall($packlistfile,$verbose,$nonono);>
+
+B<pm_to_blib($hashref);>
+
+=head1 DESCRIPTION
+
+Both install() and uninstall() are specific to the way
+ExtUtils::MakeMaker handles the installation and deinstallation of
+perl modules. They are not designed as general purpose tools.
+
+install() takes three arguments. A reference to a hash, a verbose
+switch and a don't-really-do-it switch. The hash ref contains a
+mapping of directories: each key/value pair is a combination of
+directories to be copied. Key is a directory to copy from, value is a
+directory to copy to. The whole tree below the "from" directory will
+be copied preserving timestamps and permissions.
+
+There are two keys with a special meaning in the hash: "read" and
+"write". After the copying is done, install will write the list of
+target files to the file named by C<$hashref-E<gt>{write}>. If there is
+another file named by C<$hashref-E<gt>{read}>, the contents of this file will
+be merged into the written file. The read and the written file may be
+identical, but on AFS it is quite likely, people are installing to a
+different directory than the one where the files later appear.
+
+install_default() takes one or less arguments. If no arguments are
+specified, it takes $ARGV[0] as if it was specified as an argument.
+The argument is the value of MakeMaker's C<FULLEXT> key, like F<Tk/Canvas>.
+This function calls install() with the same arguments as the defaults
+the MakeMaker would use.
+
+The argumement-less form is convenient for install scripts like
+
+ perl -MExtUtils::Install -e install_default Tk/Canvas
+
+Assuming this command is executed in a directory with populated F<blib>
+directory, it will proceed as if the F<blib> was build by MakeMaker on
+this machine. This is useful for binary distributions.
+
+uninstall() takes as first argument a file containing filenames to be
+unlinked. The second argument is a verbose switch, the third is a
+no-don't-really-do-it-now switch.
+
+pm_to_blib() takes a hashref as the first argument and copies all keys
+of the hash to the corresponding values efficiently. Filenames with
+the extension pm are autosplit. Second argument is the autosplit
+directory.
+
+=cut
diff --git a/contrib/perl5/lib/ExtUtils/Installed.pm b/contrib/perl5/lib/ExtUtils/Installed.pm
new file mode 100644
index 000000000000..dda594e78432
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/Installed.pm
@@ -0,0 +1,272 @@
+package ExtUtils::Installed;
+use strict;
+use Carp qw();
+use ExtUtils::Packlist;
+use ExtUtils::MakeMaker;
+use Config;
+use File::Find;
+use File::Basename;
+use vars qw($VERSION);
+$VERSION = '0.02';
+
+sub _is_type($$$)
+{
+my ($self, $path, $type) = @_;
+return(1) if ($type eq "all");
+if ($type eq "doc")
+ {
+ return(substr($path, 0, length($Config{installman1dir}))
+ eq $Config{installman1dir}
+ ||
+ substr($path, 0, length($Config{installman3dir}))
+ eq $Config{installman3dir}
+ ? 1 : 0)
+ }
+if ($type eq "prog")
+ {
+ return(substr($path, 0, length($Config{prefix})) eq $Config{prefix}
+ &&
+ substr($path, 0, length($Config{installman1dir}))
+ ne $Config{installman1dir}
+ &&
+ substr($path, 0, length($Config{installman3dir}))
+ ne $Config{installman3dir}
+ ? 1 : 0);
+ }
+return(0);
+}
+
+sub _is_under($$;)
+{
+my ($self, $path, @under) = @_;
+$under[0] = "" if (! @under);
+foreach my $dir (@under)
+ {
+ return(1) if (substr($path, 0, length($dir)) eq $dir);
+ }
+return(0);
+}
+
+sub new($)
+{
+my ($class) = @_;
+$class = ref($class) || $class;
+my $self = {};
+
+# Read the core packlist
+$self->{Perl}{packlist} =
+ ExtUtils::Packlist->new("$Config{installarchlib}/.packlist");
+$self->{Perl}{version} = $];
+
+# Read the module packlists
+my $sub = sub
+ {
+ # Only process module .packlists
+ return if ($_) ne ".packlist" || $File::Find::dir eq $Config{installarchlib};
+
+ # Hack of the leading bits of the paths & convert to a module name
+ my $module = $File::Find::name;
+ $module =~ s!$Config{archlib}/auto/(.*)/.packlist!$1!;
+ $module =~ s!$Config{sitearch}/auto/(.*)/.packlist!$1!;
+ my $modfile = "$module.pm";
+ $module =~ s!/!::!g;
+
+ # Find the top-level module file in @INC
+ $self->{$module}{version} = '';
+ foreach my $dir (@INC)
+ {
+ my $p = MM->catfile($dir, $modfile);
+ if (-f $p)
+ {
+ $self->{$module}{version} = MM->parse_version($p);
+ last;
+ }
+ }
+
+ # Read the .packlist
+ $self->{$module}{packlist} = ExtUtils::Packlist->new($File::Find::name);
+ };
+find($sub, $Config{archlib}, $Config{sitearch});
+
+return(bless($self, $class));
+}
+
+sub modules($)
+{
+my ($self) = @_;
+return(sort(keys(%$self)));
+}
+
+sub files($$;$)
+{
+my ($self, $module, $type, @under) = @_;
+
+# Validate arguments
+Carp::croak("$module is not installed") if (! exists($self->{$module}));
+$type = "all" if (! defined($type));
+Carp::croak('type must be "all", "prog" or "doc"')
+ if ($type ne "all" && $type ne "prog" && $type ne "doc");
+
+my (@files);
+foreach my $file (keys(%{$self->{$module}{packlist}}))
+ {
+ push(@files, $file)
+ if ($self->_is_type($file, $type) && $self->_is_under($file, @under));
+ }
+return(@files);
+}
+
+sub directories($$;$)
+{
+my ($self, $module, $type, @under) = @_;
+my (%dirs);
+foreach my $file ($self->files($module, $type, @under))
+ {
+ $dirs{dirname($file)}++;
+ }
+return(sort(keys(%dirs)));
+}
+
+sub directory_tree($$;$)
+{
+my ($self, $module, $type, @under) = @_;
+my (%dirs);
+foreach my $dir ($self->directories($module, $type, @under))
+ {
+ $dirs{$dir}++;
+ my ($last) = ("");
+ while ($last ne $dir)
+ {
+ $last = $dir;
+ $dir = dirname($dir);
+ last if (! $self->_is_under($dir, @under));
+ $dirs{$dir}++;
+ }
+ }
+return(sort(keys(%dirs)));
+}
+
+sub validate($;$)
+{
+my ($self, $module, $remove) = @_;
+Carp::croak("$module is not installed") if (! exists($self->{$module}));
+return($self->{$module}{packlist}->validate($remove));
+}
+
+sub packlist($$)
+{
+my ($self, $module) = @_;
+Carp::croak("$module is not installed") if (! exists($self->{$module}));
+return($self->{$module}{packlist});
+}
+
+sub version($$)
+{
+my ($self, $module) = @_;
+Carp::croak("$module is not installed") if (! exists($self->{$module}));
+return($self->{$module}{version});
+}
+
+sub DESTROY
+{
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Installed - Inventory management of installed modules
+
+=head1 SYNOPSIS
+
+ use ExtUtils::Installed;
+ my ($inst) = ExtUtils::Installed->new();
+ my (@modules) = $inst->modules();
+ my (@missing) = $inst->validate("DBI");
+ my $all_files = $inst->files("DBI");
+ my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
+ my $all_dirs = $inst->directories("DBI");
+ my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
+ my $packlist = $inst->packlist("DBI");
+
+=head1 DESCRIPTION
+
+ExtUtils::Installed provides a standard way to find out what core and module
+files have been installed. It uses the information stored in .packlist files
+created during installation to provide this information. In addition it
+provides facilities to classify the installed files and to extract directory
+information from the .packlist files.
+
+=head1 USAGE
+
+The new() function searches for all the installed .packlists on the system, and
+stores their contents. The .packlists can be queried with the functions
+described below.
+
+=head1 FUNCTIONS
+
+=over
+
+=item new()
+
+This takes no parameters, and searches for all the installed .packlists on the
+system. The packlists are read using the ExtUtils::packlist module.
+
+=item modules()
+
+This returns a list of the names of all the installed modules. The perl 'core'
+is given the special name 'Perl'.
+
+=item files()
+
+This takes one mandatory parameter, the name of a module. It returns a list of
+all the filenames from the package. To obtain a list of core perl files, use
+the module name 'Perl'. Additional parameters are allowed. The first is one
+of the strings "prog", "man" or "all", to select either just program files,
+just manual files or all files. The remaining parameters are a list of
+directories. The filenames returned will be restricted to those under the
+specified directories.
+
+=item directories()
+
+This takes one mandatory parameter, the name of a module. It returns a list of
+all the directories from the package. Additional parameters are allowed. The
+first is one of the strings "prog", "man" or "all", to select either just
+program directories, just manual directories or all directories. The remaining
+parameters are a list of directories. The directories returned will be
+restricted to those under the specified directories. This method returns only
+the leaf directories that contain files from the specified module.
+
+=item directory_tree()
+
+This is identical in operation to directory(), except that it includes all the
+intermediate directories back up to the specified directories.
+
+=item validate()
+
+This takes one mandatory parameter, the name of a module. It checks that all
+the files listed in the modules .packlist actually exist, and returns a list of
+any missing files. If an optional second argument which evaluates to true is
+given any missing files will be removed from the .packlist
+
+=item packlist()
+
+This returns the ExtUtils::Packlist object for the specified module.
+
+=item version()
+
+This returns the version number for the specified module.
+
+=back
+
+=head1 EXAMPLE
+
+See the example in L<ExtUtils::Packlist>.
+
+=head1 AUTHOR
+
+Alan Burlison <Alan.Burlison@uk.sun.com>
+
+=cut
diff --git a/contrib/perl5/lib/ExtUtils/Liblist.pm b/contrib/perl5/lib/ExtUtils/Liblist.pm
new file mode 100644
index 000000000000..b072c1292c7f
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/Liblist.pm
@@ -0,0 +1,750 @@
+package ExtUtils::Liblist;
+use vars qw($VERSION);
+# Broken out of MakeMaker from version 4.11
+
+$VERSION = substr q$Revision: 1.25 $, 10;
+
+use Config;
+use Cwd 'cwd';
+use File::Basename;
+
+sub ext {
+ if ($^O eq 'VMS') { return &_vms_ext; }
+ elsif($^O eq 'MSWin32') { return &_win32_ext; }
+ else { return &_unix_os2_ext; }
+}
+
+sub _unix_os2_ext {
+ my($self,$potential_libs, $verbose) = @_;
+ if ($^O =~ 'os2' and $Config{libs}) {
+ # Dynamic libraries are not transitive, so we may need including
+ # the libraries linked against perl.dll again.
+
+ $potential_libs .= " " if $potential_libs;
+ $potential_libs .= $Config{libs};
+ }
+ return ("", "", "", "") unless $potential_libs;
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ my($so) = $Config{'so'};
+ my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
+
+ # compute $extralibs, $bsloadlibs and $ldloadlibs from
+ # $potential_libs
+ # this is a rewrite of Andy Dougherty's extliblist in perl
+
+ my(@searchpath); # from "-L/path" entries in $potential_libs
+ my(@libpath) = split " ", $Config{'libpth'};
+ my(@ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen);
+ my($fullname, $thislib, $thispth, @fullname);
+ my($pwd) = cwd(); # from Cwd.pm
+ my($found) = 0;
+
+ foreach $thislib (split ' ', $potential_libs){
+
+ # Handle possible linker path arguments.
+ if ($thislib =~ s/^(-[LR])//){ # save path flag type
+ my($ptype) = $1;
+ unless (-d $thislib){
+ warn "$ptype$thislib ignored, directory does not exist\n"
+ if $verbose;
+ next;
+ }
+ unless ($self->file_name_is_absolute($thislib)) {
+ warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n";
+ $thislib = $self->catdir($pwd,$thislib);
+ }
+ push(@searchpath, $thislib);
+ push(@extralibs, "$ptype$thislib");
+ push(@ldloadlibs, "$ptype$thislib");
+ next;
+ }
+
+ # Handle possible library arguments.
+ unless ($thislib =~ s/^-l//){
+ warn "Unrecognized argument in LIBS ignored: '$thislib'\n";
+ next;
+ }
+
+ my($found_lib)=0;
+ foreach $thispth (@searchpath, @libpath){
+
+ # Try to find the full name of the library. We need this to
+ # determine whether it's a dynamically-loadable library or not.
+ # This tends to be subject to various os-specific quirks.
+ # For gcc-2.6.2 on linux (March 1995), DLD can not load
+ # .sa libraries, with the exception of libm.sa, so we
+ # deliberately skip them.
+ if (@fullname =
+ $self->lsdir($thispth,"^\Qlib$thislib.$so.\E[0-9]+")){
+ # Take care that libfoo.so.10 wins against libfoo.so.9.
+ # Compare two libraries to find the most recent version
+ # number. E.g. if you have libfoo.so.9.0.7 and
+ # libfoo.so.10.1, first convert all digits into two
+ # decimal places. Then we'll add ".00" to the shorter
+ # strings so that we're comparing strings of equal length
+ # Thus we'll compare libfoo.so.09.07.00 with
+ # libfoo.so.10.01.00. Some libraries might have letters
+ # in the version. We don't know what they mean, but will
+ # try to skip them gracefully -- we'll set any letter to
+ # '0'. Finally, sort in reverse so we can take the
+ # first element.
+
+ #TODO: iterate through the directory instead of sorting
+
+ $fullname = "$thispth/" .
+ (sort { my($ma) = $a;
+ my($mb) = $b;
+ $ma =~ tr/A-Za-z/0/s;
+ $ma =~ s/\b(\d)\b/0$1/g;
+ $mb =~ tr/A-Za-z/0/s;
+ $mb =~ s/\b(\d)\b/0$1/g;
+ while (length($ma) < length($mb)) { $ma .= ".00"; }
+ while (length($mb) < length($ma)) { $mb .= ".00"; }
+ # Comparison deliberately backwards
+ $mb cmp $ma;} @fullname)[0];
+ } elsif (-f ($fullname="$thispth/lib$thislib.$so")
+ && (($Config{'dlsrc'} ne "dl_dld.xs") || ($thislib eq "m"))){
+ } elsif (-f ($fullname="$thispth/lib${thislib}_s$Config_libext")
+ && ($thislib .= "_s") ){ # we must explicitly use _s version
+ } elsif (-f ($fullname="$thispth/lib$thislib$Config_libext")){
+ } elsif (-f ($fullname="$thispth/$thislib$Config_libext")){
+ } elsif (-f ($fullname="$thispth/Slib$thislib$Config_libext")){
+ } elsif ($^O eq 'dgux'
+ && -l ($fullname="$thispth/lib$thislib$Config_libext")
+ && readlink($fullname) =~ /^elink:/) {
+ # Some of DG's libraries look like misconnected symbolic
+ # links, but development tools can follow them. (They
+ # look like this:
+ #
+ # libm.a -> elink:${SDE_PATH:-/usr}/sde/\
+ # ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a
+ #
+ # , the compilation tools expand the environment variables.)
+ } else {
+ warn "$thislib not found in $thispth\n" if $verbose;
+ next;
+ }
+ warn "'-l$thislib' found at $fullname\n" if $verbose;
+ my($fullnamedir) = dirname($fullname);
+ push @ld_run_path, $fullnamedir unless $ld_run_path_seen{$fullnamedir}++;
+ $found++;
+ $found_lib++;
+
+ # Now update library lists
+
+ # what do we know about this library...
+ my $is_dyna = ($fullname !~ /\Q$Config_libext\E$/);
+ my $in_perl = ($libs =~ /\B-l\Q$ {thislib}\E\b/s);
+
+ # Do not add it into the list if it is already linked in
+ # with the main perl executable.
+ # We have to special-case the NeXT, because math and ndbm
+ # are both in libsys_s
+ unless ($in_perl ||
+ ($Config{'osname'} eq 'next' &&
+ ($thislib eq 'm' || $thislib eq 'ndbm')) ){
+ push(@extralibs, "-l$thislib");
+ }
+
+ # We might be able to load this archive file dynamically
+ if ( ($Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0')
+ || ($Config{'dlsrc'} =~ /dl_dld/) )
+ {
+ # We push -l$thislib instead of $fullname because
+ # it avoids hardwiring a fixed path into the .bs file.
+ # Mkbootstrap will automatically add dl_findfile() to
+ # the .bs file if it sees a name in the -l format.
+ # USE THIS, when dl_findfile() is fixed:
+ # push(@bsloadlibs, "-l$thislib");
+ # OLD USE WAS while checking results against old_extliblist
+ push(@bsloadlibs, "$fullname");
+ } else {
+ if ($is_dyna){
+ # For SunOS4, do not add in this shared library if
+ # it is already linked in the main perl executable
+ push(@ldloadlibs, "-l$thislib")
+ unless ($in_perl and $^O eq 'sunos');
+ } else {
+ push(@ldloadlibs, "-l$thislib");
+ }
+ }
+ last; # found one here so don't bother looking further
+ }
+ warn "Note (probably harmless): "
+ ."No library found for -l$thislib\n"
+ unless $found_lib>0;
+ }
+ return ('','','','') unless $found;
+ ("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path));
+}
+
+sub _win32_ext {
+
+ require Text::ParseWords;
+
+ my($self, $potential_libs, $verbose) = @_;
+
+ # If user did not supply a list, we punt.
+ # (caller should probably use the list in $Config{libs})
+ return ("", "", "", "") unless $potential_libs;
+
+ my $cc = $Config{cc};
+ my $VC = 1 if $cc =~ /^cl/i;
+ my $BC = 1 if $cc =~ /^bcc/i;
+ my $GC = 1 if $cc =~ /^gcc/i;
+ my $so = $Config{'so'};
+ my $libs = $Config{'libs'};
+ my $libpth = $Config{'libpth'};
+ my $libext = $Config{'lib_ext'} || ".lib";
+
+ if ($libs and $potential_libs !~ /:nodefault/i) {
+ # If Config.pm defines a set of default libs, we always
+ # tack them on to the user-supplied list, unless the user
+ # specified :nodefault
+
+ $potential_libs .= " " if $potential_libs;
+ $potential_libs .= $libs;
+ }
+ warn "Potential libraries are '$potential_libs':\n" if $verbose;
+
+ # normalize to forward slashes
+ $libpth =~ s,\\,/,g;
+ $potential_libs =~ s,\\,/,g;
+
+ # compute $extralibs from $potential_libs
+
+ my @searchpath; # from "-L/path" in $potential_libs
+ my @libpath = Text::ParseWords::quotewords('\s+', 0, $libpth);
+ my @extralibs;
+ my $pwd = cwd(); # from Cwd.pm
+ my $lib = '';
+ my $found = 0;
+ my $search = 1;
+ my($fullname, $thislib, $thispth);
+
+ foreach (Text::ParseWords::quotewords('\s+', 0, $potential_libs)){
+
+ $thislib = $_;
+
+ # see if entry is a flag
+ if (/^:\w+$/) {
+ $search = 0 if lc eq ':nosearch';
+ $search = 1 if lc eq ':search';
+ warn "Ignoring unknown flag '$thislib'\n"
+ if $verbose and !/^:(no)?(search|default)$/i;
+ next;
+ }
+
+ # if searching is disabled, do compiler-specific translations
+ unless ($search) {
+ s/^-L/-libpath:/ if $VC;
+ s/^-l(.+)$/$1.lib/ unless $GC;
+ push(@extralibs, $_);
+ $found++;
+ next;
+ }
+
+ # handle possible linker path arguments
+ if (s/^-L// and not -d) {
+ warn "$thislib ignored, directory does not exist\n"
+ if $verbose;
+ next;
+ }
+ elsif (-d) {
+ unless ($self->file_name_is_absolute($_)) {
+ warn "Warning: '$thislib' changed to '-L$pwd/$_'\n";
+ $_ = $self->catdir($pwd,$_);
+ }
+ push(@searchpath, $_);
+ next;
+ }
+
+ # handle possible library arguments
+ if (s/^-l// and $GC and !/^lib/i) {
+ $_ = "lib$_";
+ }
+ $_ .= $libext if !/\Q$libext\E$/i;
+
+ my $secondpass = 0;
+ LOOKAGAIN:
+
+ # look for the file itself
+ if (-f) {
+ warn "'$thislib' found as '$_'\n" if $verbose;
+ $found++;
+ push(@extralibs, $_);
+ next;
+ }
+
+ my $found_lib = 0;
+ foreach $thispth (@searchpath, @libpath){
+ unless (-f ($fullname="$thispth\\$_")) {
+ warn "'$thislib' not found as '$fullname'\n" if $verbose;
+ next;
+ }
+ warn "'$thislib' found as '$fullname'\n" if $verbose;
+ $found++;
+ $found_lib++;
+ push(@extralibs, $fullname);
+ last;
+ }
+
+ # do another pass with (or without) leading 'lib' if they used -l
+ if (!$found_lib and $thislib =~ /^-l/ and !$secondpass++) {
+ if ($GC) {
+ goto LOOKAGAIN if s/^lib//i;
+ }
+ elsif (!/^lib/i) {
+ $_ = "lib$_";
+ goto LOOKAGAIN;
+ }
+ }
+
+ # give up
+ warn "Note (probably harmless): "
+ ."No library found for '$thislib'\n"
+ unless $found_lib>0;
+
+ }
+
+ return ('','','','') unless $found;
+
+ # make sure paths with spaces are properly quoted
+ @extralibs = map { (/\s/ && !/^".*"$/) ? qq["$_"] : $_ } @extralibs;
+ $lib = join(' ',@extralibs);
+
+ # normalize back to backward slashes (to help braindead tools)
+ # XXX this may break equally braindead GNU tools that don't understand
+ # backslashes, either. Seems like one can't win here. Cursed be CP/M.
+ $lib =~ s,/,\\,g;
+
+ warn "Result: $lib\n" if $verbose;
+ wantarray ? ($lib, '', $lib, '') : $lib;
+}
+
+
+sub _vms_ext {
+ my($self, $potential_libs,$verbose) = @_;
+ my(@crtls,$crtlstr);
+ my($dbgqual) = $self->{OPTIMIZE} || $Config{'optimize'} ||
+ $self->{CCFLAS} || $Config{'ccflags'};
+ @crtls = ( ($dbgqual =~ m-/Debug-i ? $Config{'dbgprefix'} : '')
+ . 'PerlShr/Share' );
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libs'});
+ push(@crtls, grep { not /\(/ } split /\s+/, $Config{'libc'});
+ # In general, we pass through the basic libraries from %Config unchanged.
+ # The one exception is that if we're building in the Perl source tree, and
+ # a library spec could be resolved via a logical name, we go to some trouble
+ # to insure that the copy in the local tree is used, rather than one to
+ # which a system-wide logical may point.
+ if ($self->{PERL_SRC}) {
+ my($lib,$locspec,$type);
+ foreach $lib (@crtls) {
+ if (($locspec,$type) = $lib =~ m-^([\w$\-]+)(/\w+)?- and $locspec =~ /perl/i) {
+ if (lc $type eq '/share') { $locspec .= $Config{'exe_ext'}; }
+ elsif (lc $type eq '/library') { $locspec .= $Config{'lib_ext'}; }
+ else { $locspec .= $Config{'obj_ext'}; }
+ $locspec = $self->catfile($self->{PERL_SRC},$locspec);
+ $lib = "$locspec$type" if -e $locspec;
+ }
+ }
+ }
+ $crtlstr = @crtls ? join(' ',@crtls) : '';
+
+ unless ($potential_libs) {
+ warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose;
+ return ('', '', $crtlstr, '');
+ }
+
+ my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj,$ldlib);
+ my $cwd = cwd();
+ my($so,$lib_ext,$obj_ext) = @Config{'so','lib_ext','obj_ext'};
+ # List of common Unix library names and there VMS equivalents
+ # (VMS equivalent of '' indicates that the library is automatially
+ # searched by the linker, and should be skipped here.)
+ my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '',
+ 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '',
+ 'socket' => '', 'X11' => 'DECW$XLIBSHR',
+ 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR',
+ 'Xmu' => 'DECW$XMULIBSHR');
+ if ($Config{'vms_cc_type'} ne 'decc') { $libmap{'curses'} = 'VAXCCURSE'; }
+
+ warn "Potential libraries are '$potential_libs'\n" if $verbose;
+
+ # First, sort out directories and library names in the input
+ foreach $lib (split ' ',$potential_libs) {
+ push(@dirs,$1), next if $lib =~ /^-L(.*)/;
+ push(@dirs,$lib), next if $lib =~ /[:>\]]$/;
+ push(@dirs,$lib), next if -d $lib;
+ push(@libs,$1), next if $lib =~ /^-l(.*)/;
+ push(@libs,$lib);
+ }
+ push(@dirs,split(' ',$Config{'libpth'}));
+
+ # Now make sure we've got VMS-syntax absolute directory specs
+ # (We don't, however, check whether someone's hidden a relative
+ # path in a logical name.)
+ foreach $dir (@dirs) {
+ unless (-d $dir) {
+ warn "Skipping nonexistent Directory $dir\n" if $verbose > 1;
+ $dir = '';
+ next;
+ }
+ warn "Resolving directory $dir\n" if $verbose;
+ if ($self->file_name_is_absolute($dir)) { $dir = $self->fixpath($dir,1); }
+ else { $dir = $self->catdir($cwd,$dir); }
+ }
+ @dirs = grep { length($_) } @dirs;
+ unshift(@dirs,''); # Check each $lib without additions first
+
+ LIB: foreach $lib (@libs) {
+ if (exists $libmap{$lib}) {
+ next unless length $libmap{$lib};
+ $lib = $libmap{$lib};
+ }
+
+ my(@variants,$variant,$name,$test,$cand);
+ my($ctype) = '';
+
+ # If we don't have a file type, consider it a possibly abbreviated name and
+ # check for common variants. We try these first to grab libraries before
+ # a like-named executable image (e.g. -lperl resolves to perlshr.exe
+ # before perl.exe).
+ if ($lib !~ /\.[^:>\]]*$/) {
+ push(@variants,"${lib}shr","${lib}rtl","${lib}lib");
+ push(@variants,"lib$lib") if $lib !~ /[:>\]]/;
+ }
+ push(@variants,$lib);
+ warn "Looking for $lib\n" if $verbose;
+ foreach $variant (@variants) {
+ foreach $dir (@dirs) {
+ my($type);
+
+ $name = "$dir$variant";
+ warn "\tChecking $name\n" if $verbose > 2;
+ if (-f ($test = VMS::Filespec::rmsexpand($name))) {
+ # It's got its own suffix, so we'll have to figure out the type
+ if ($test =~ /(?:$so|exe)$/i) { $type = 'sh'; }
+ elsif ($test =~ /(?:$lib_ext|olb)$/i) { $type = 'olb'; }
+ elsif ($test =~ /(?:$obj_ext|obj)$/i) {
+ warn "Note (probably harmless): "
+ ."Plain object file $test found in library list\n";
+ $type = 'obj';
+ }
+ else {
+ warn "Note (probably harmless): "
+ ."Unknown library type for $test; assuming shared\n";
+ $type = 'sh';
+ }
+ }
+ elsif (-f ($test = VMS::Filespec::rmsexpand($name,$so)) or
+ -f ($test = VMS::Filespec::rmsexpand($name,'.exe'))) {
+ $type = 'sh';
+ $name = $test unless $test =~ /exe;?\d*$/i;
+ }
+ elsif (not length($ctype) and # If we've got a lib already, don't bother
+ ( -f ($test = VMS::Filespec::rmsexpand($name,$lib_ext)) or
+ -f ($test = VMS::Filespec::rmsexpand($name,'.olb')))) {
+ $type = 'olb';
+ $name = $test unless $test =~ /olb;?\d*$/i;
+ }
+ elsif (not length($ctype) and # If we've got a lib already, don't bother
+ ( -f ($test = VMS::Filespec::rmsexpand($name,$obj_ext)) or
+ -f ($test = VMS::Filespec::rmsexpand($name,'.obj')))) {
+ warn "Note (probably harmless): "
+ ."Plain object file $test found in library list\n";
+ $type = 'obj';
+ $name = $test unless $test =~ /obj;?\d*$/i;
+ }
+ if (defined $type) {
+ $ctype = $type; $cand = $name;
+ last if $ctype eq 'sh';
+ }
+ }
+ if ($ctype) {
+ eval '$' . $ctype . "{'$cand'}++";
+ die "Error recording library: $@" if $@;
+ warn "\tFound as $cand (really $test), type $ctype\n" if $verbose > 1;
+ next LIB;
+ }
+ }
+ warn "Note (probably harmless): "
+ ."No library found for $lib\n";
+ }
+
+ @libs = sort keys %obj;
+ # This has to precede any other CRTLs, so just make it first
+ if ($olb{VAXCCURSE}) {
+ push(@libs,"$olb{VAXCCURSE}/Library");
+ delete $olb{VAXCCURSE};
+ }
+ push(@libs, map { "$_/Library" } sort keys %olb);
+ push(@libs, map { "$_/Share" } sort keys %sh);
+ $lib = join(' ',@libs);
+
+ $ldlib = $crtlstr ? "$lib $crtlstr" : $lib;
+ warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose;
+ wantarray ? ($lib, '', $ldlib, '') : $lib;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Liblist - determine libraries to use and how to use them
+
+=head1 SYNOPSIS
+
+C<require ExtUtils::Liblist;>
+
+C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose);>
+
+=head1 DESCRIPTION
+
+This utility takes a list of libraries in the form C<-llib1 -llib2
+-llib3> and prints out lines suitable for inclusion in an extension
+Makefile. Extra library paths may be included with the form
+C<-L/another/path> this will affect the searches for all subsequent
+libraries.
+
+It returns an array of four scalar values: EXTRALIBS, BSLOADLIBS,
+LDLOADLIBS, and LD_RUN_PATH. Some of these don't mean anything
+on VMS and Win32. See the details about those platform specifics
+below.
+
+Dependent libraries can be linked in one of three ways:
+
+=over 2
+
+=item * For static extensions
+
+by the ld command when the perl binary is linked with the extension
+library. See EXTRALIBS below.
+
+=item * For dynamic extensions
+
+by the ld command when the shared object is built/linked. See
+LDLOADLIBS below.
+
+=item * For dynamic extensions
+
+by the DynaLoader when the shared object is loaded. See BSLOADLIBS
+below.
+
+=back
+
+=head2 EXTRALIBS
+
+List of libraries that need to be linked with when linking a perl
+binary which includes this extension Only those libraries that
+actually exist are included. These are written to a file and used
+when linking perl.
+
+=head2 LDLOADLIBS and LD_RUN_PATH
+
+List of those libraries which can or must be linked into the shared
+library when created using ld. These may be static or dynamic
+libraries. LD_RUN_PATH is a colon separated list of the directories
+in LDLOADLIBS. It is passed as an environment variable to the process
+that links the shared library.
+
+=head2 BSLOADLIBS
+
+List of those libraries that are needed but can be linked in
+dynamically at run time on this platform. SunOS/Solaris does not need
+this because ld records the information (from LDLOADLIBS) into the
+object file. This list is used to create a .bs (bootstrap) file.
+
+=head1 PORTABILITY
+
+This module deals with a lot of system dependencies and has quite a
+few architecture specific B<if>s in the code.
+
+=head2 VMS implementation
+
+The version of ext() which is executed under VMS differs from the
+Unix-OS/2 version in several respects:
+
+=over 2
+
+=item *
+
+Input library and path specifications are accepted with or without the
+C<-l> and C<-L> prefices used by Unix linkers. If neither prefix is
+present, a token is considered a directory to search if it is in fact
+a directory, and a library to search for otherwise. Authors who wish
+their extensions to be portable to Unix or OS/2 should use the Unix
+prefixes, since the Unix-OS/2 version of ext() requires them.
+
+=item *
+
+Wherever possible, shareable images are preferred to object libraries,
+and object libraries to plain object files. In accordance with VMS
+naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl;
+it also looks for I<lib>lib and libI<lib> to accomodate Unix conventions
+used in some ported software.
+
+=item *
+
+For each library that is found, an appropriate directive for a linker options
+file is generated. The return values are space-separated strings of
+these directives, rather than elements used on the linker command line.
+
+=item *
+
+LDLOADLIBS contains both the libraries found based on C<$potential_libs> and
+the CRTLs, if any, specified in Config.pm. EXTRALIBS contains just those
+libraries found based on C<$potential_libs>. BSLOADLIBS and LD_RUN_PATH
+are always empty.
+
+=back
+
+In addition, an attempt is made to recognize several common Unix library
+names, and filter them out or convert them to their VMS equivalents, as
+appropriate.
+
+In general, the VMS version of ext() should properly handle input from
+extensions originally designed for a Unix or VMS environment. If you
+encounter problems, or discover cases where the search could be improved,
+please let us know.
+
+=head2 Win32 implementation
+
+The version of ext() which is executed under Win32 differs from the
+Unix-OS/2 version in several respects:
+
+=over 2
+
+=item *
+
+If C<$potential_libs> is empty, the return value will be empty.
+Otherwise, the libraries specified by C<$Config{libs}> (see Config.pm)
+will be appended to the list of C<$potential_libs>. The libraries
+will be searched for in the directories specified in C<$potential_libs>
+as well as in C<$Config{libpth}>. For each library that is found, a
+space-separated list of fully qualified library pathnames is generated.
+
+=item *
+
+Input library and path specifications are accepted with or without the
+C<-l> and C<-L> prefices used by Unix linkers.
+
+An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look
+for the libraries that follow.
+
+An entry of the form C<-lfoo> specifies the library C<foo>, which may be
+spelled differently depending on what kind of compiler you are using. If
+you are using GCC, it gets translated to C<libfoo.a>, but for other win32
+compilers, it becomes C<foo.lib>. If no files are found by those translated
+names, one more attempt is made to find them using either C<foo.a> or
+C<libfoo.lib>, depending on whether GCC or some other win32 compiler is
+being used, respectively.
+
+If neither the C<-L> or C<-l> prefix is present in an entry, the entry is
+considered a directory to search if it is in fact a directory, and a
+library to search for otherwise. The C<$Config{lib_ext}> suffix will
+be appended to any entries that are not directories and don't already have
+the suffix.
+
+Note that the C<-L> and <-l> prefixes are B<not required>, but authors
+who wish their extensions to be portable to Unix or OS/2 should use the
+prefixes, since the Unix-OS/2 version of ext() requires them.
+
+=item *
+
+Entries cannot be plain object files, as many Win32 compilers will
+not handle object files in the place of libraries.
+
+=item *
+
+Entries in C<$potential_libs> beginning with a colon and followed by
+alphanumeric characters are treated as flags. Unknown flags will be ignored.
+
+An entry that matches C</:nodefault/i> disables the appending of default
+libraries found in C<$Config{libs}> (this should be only needed very rarely).
+
+An entry that matches C</:nosearch/i> disables all searching for
+the libraries specified after it. Translation of C<-Lfoo> and
+C<-lfoo> still happens as appropriate (depending on compiler being used,
+as reflected by C<$Config{cc}>), but the entries are not verified to be
+valid files or directories.
+
+An entry that matches C</:search/i> reenables searching for
+the libraries specified after it. You can put it at the end to
+enable searching for default libraries specified by C<$Config{libs}>.
+
+=item *
+
+The libraries specified may be a mixture of static libraries and
+import libraries (to link with DLLs). Since both kinds are used
+pretty transparently on the win32 platform, we do not attempt to
+distinguish between them.
+
+=item *
+
+LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS
+and LD_RUN_PATH are always empty (this may change in future).
+
+=item *
+
+You must make sure that any paths and path components are properly
+surrounded with double-quotes if they contain spaces. For example,
+C<$potential_libs> could be (literally):
+
+ "-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib"
+
+Note how the first and last entries are protected by quotes in order
+to protect the spaces.
+
+=item *
+
+Since this module is most often used only indirectly from extension
+C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add
+a library to the build process for an extension:
+
+ LIBS => ['-lgl']
+
+When using GCC, that entry specifies that MakeMaker should first look
+for C<libgl.a> (followed by C<gl.a>) in all the locations specified by
+C<$Config{libpth}>.
+
+When using a compiler other than GCC, the above entry will search for
+C<gl.lib> (followed by C<libgl.lib>).
+
+If the library happens to be in a location not in C<$Config{libpth}>,
+you need:
+
+ LIBS => ['-Lc:\gllibs -lgl']
+
+Here is a less often used example:
+
+ LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32']
+
+This specifies a search for library C<gl> as before. If that search
+fails to find the library, it looks at the next item in the list. The
+C<:nosearch> flag will prevent searching for the libraries that follow,
+so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>,
+since GCC can use that value as is with its linker.
+
+When using the Visual C compiler, the second item is returned as
+C<-libpath:d:\mesalibs mesa.lib user32.lib>.
+
+When using the Borland compiler, the second item is returned as
+C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of
+moving the C<-Ld:\mesalibs> to the correct place in the linker
+command line.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker>
+
+=cut
+
diff --git a/contrib/perl5/lib/ExtUtils/MM_OS2.pm b/contrib/perl5/lib/ExtUtils/MM_OS2.pm
new file mode 100644
index 000000000000..8bddb42c6dd6
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/MM_OS2.pm
@@ -0,0 +1,85 @@
+package ExtUtils::MM_OS2;
+
+#use Config;
+#use Cwd;
+#use File::Basename;
+require Exporter;
+
+Exporter::import('ExtUtils::MakeMaker',
+ qw( $Verbose &neatvalue));
+
+unshift @MM::ISA, 'ExtUtils::MM_OS2';
+
+sub dlsyms {
+ my($self,%attribs) = @_;
+
+ my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
+ my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
+ my(@m);
+ (my $boot = $self->{NAME}) =~ s/:/_/g;
+
+ if (not $self->{SKIPHASH}{'dynamic'}) {
+ push(@m,"
+$self->{BASEEXT}.def: Makefile.PL
+",
+ ' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\
+ Mksymlists("NAME" => "', $self->{NAME},
+ '", "DLBASE" => "',$self->{DLBASE},
+ '", "DL_FUNCS" => ',neatvalue($funcs),
+ ', "IMPORTS" => ',neatvalue($imports),
+ ', "VERSION" => "',$self->{VERSION},
+ '", "DL_VARS" => ', neatvalue($vars), ');\'
+');
+ }
+ join('',@m);
+}
+
+sub replace_manpage_separator {
+ my($self,$man) = @_;
+ $man =~ s,/+,.,g;
+ $man;
+}
+
+sub maybe_command {
+ my($self,$file) = @_;
+ $file =~ s,[/\\]+,/,g;
+ return $file if -x $file && ! -d _;
+ return "$file.exe" if -x "$file.exe" && ! -d _;
+ return "$file.cmd" if -x "$file.cmd" && ! -d _;
+ return;
+}
+
+sub file_name_is_absolute {
+ my($self,$file) = @_;
+ $file =~ m{^([a-z]:)?[\\/]}i ;
+}
+
+sub perl_archive
+{
+ return "\$(PERL_INC)/libperl\$(LIB_EXT)";
+}
+
+sub export_list
+{
+ my ($self) = @_;
+ return "$self->{BASEEXT}.def";
+}
+
+1;
+__END__
+
+=head1 NAME
+
+ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+ use ExtUtils::MM_OS2; # Done internally by ExtUtils::MakeMaker if needed
+
+=head1 DESCRIPTION
+
+See ExtUtils::MM_Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
diff --git a/contrib/perl5/lib/ExtUtils/MM_Unix.pm b/contrib/perl5/lib/ExtUtils/MM_Unix.pm
new file mode 100644
index 000000000000..9a96504b75ab
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/MM_Unix.pm
@@ -0,0 +1,3539 @@
+package ExtUtils::MM_Unix;
+
+use Exporter ();
+use Config;
+use File::Basename qw(basename dirname fileparse);
+use DirHandle;
+use strict;
+use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_PERL_OBJECT
+ $Verbose %pm %static $Xsubpp_Version);
+
+$VERSION = substr q$Revision: 1.12601 $, 10;
+# $Id: MM_Unix.pm,v 1.126 1998/06/28 21:32:49 k Exp k $
+
+Exporter::import('ExtUtils::MakeMaker',
+ qw( $Verbose &neatvalue));
+
+$Is_OS2 = $^O eq 'os2';
+$Is_Mac = $^O eq 'MacOS';
+$Is_Win32 = $^O eq 'MSWin32';
+$Is_Dos = $^O eq 'dos';
+
+$Is_PERL_OBJECT = 1 if $Config{'ccflags'} =~ /-DPERL_OBJECT/;
+
+if ($Is_VMS = $^O eq 'VMS') {
+ require VMS::Filespec;
+ import VMS::Filespec qw( &vmsify );
+}
+
+=head1 NAME
+
+ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+C<require ExtUtils::MM_Unix;>
+
+=head1 DESCRIPTION
+
+The methods provided by this package are designed to be used in
+conjunction with ExtUtils::MakeMaker. When MakeMaker writes a
+Makefile, it creates one or more objects that inherit their methods
+from a package C<MM>. MM itself doesn't provide any methods, but it
+ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating
+specific packages take the responsibility for all the methods provided
+by MM_Unix. We are trying to reduce the number of the necessary
+overrides by defining rather primitive operations within
+ExtUtils::MM_Unix.
+
+If you are going to write a platform specific MM package, please try
+to limit the necessary overrides to primitive methods, and if it is not
+possible to do so, let's work out how to achieve that gain.
+
+If you are overriding any of these methods in your Makefile.PL (in the
+MY class), please report that to the makemaker mailing list. We are
+trying to minimize the necessary method overrides and switch to data
+driven Makefile.PLs wherever possible. In the long run less methods
+will be overridable via the MY class.
+
+=head1 METHODS
+
+The following description of methods is still under
+development. Please refer to the code for not suitably documented
+sections and complain loudly to the makemaker mailing list.
+
+Not all of the methods below are overridable in a
+Makefile.PL. Overridable methods are marked as (o). All methods are
+overridable by a platform specific MM_*.pm file (See
+L<ExtUtils::MM_VMS>) and L<ExtUtils::MM_OS2>).
+
+=head2 Preloaded methods
+
+=over 2
+
+=item canonpath
+
+No physical check on the filesystem, but a logical cleanup of a
+path. On UNIX eliminated successive slashes and successive "/.".
+
+=cut
+
+sub canonpath {
+ my($self,$path) = @_;
+ my $node = '';
+ if ( $^O eq 'qnx' && $path =~ s|^(//\d+)/|/| ) {
+ $node = $1;
+ }
+ $path =~ s|/+|/|g ; # xx////xx -> xx/xx
+ $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx
+ $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx
+ $path =~ s|/$|| unless $path eq "/"; # xx/ -> xx
+ "$node$path";
+}
+
+=item catdir
+
+Concatenate two or more directory names to form a complete path ending
+with a directory. But remove the trailing slash from the resulting
+string, because it doesn't look good, isn't necessary and confuses
+OS2. Of course, if this is the root directory, don't cut off the
+trailing slash :-)
+
+=cut
+
+# ';
+
+sub catdir {
+ my $self = shift @_;
+ my @args = @_;
+ for (@args) {
+ # append a slash to each argument unless it has one there
+ $_ .= "/" if $_ eq '' or substr($_,-1) ne "/";
+ }
+ $self->canonpath(join('', @args));
+}
+
+=item catfile
+
+Concatenate one or more directory names and a filename to form a
+complete path ending with a filename
+
+=cut
+
+sub catfile {
+ my $self = shift @_;
+ my $file = pop @_;
+ return $self->canonpath($file) unless @_;
+ my $dir = $self->catdir(@_);
+ for ($dir) {
+ $_ .= "/" unless substr($_,length($_)-1,1) eq "/";
+ }
+ return $self->canonpath($dir.$file);
+}
+
+=item curdir
+
+Returns a string representing of the current directory. "." on UNIX.
+
+=cut
+
+sub curdir {
+ return "." ;
+}
+
+=item rootdir
+
+Returns a string representing of the root directory. "/" on UNIX.
+
+=cut
+
+sub rootdir {
+ return "/";
+}
+
+=item updir
+
+Returns a string representing of the parent directory. ".." on UNIX.
+
+=cut
+
+sub updir {
+ return "..";
+}
+
+sub ExtUtils::MM_Unix::c_o ;
+sub ExtUtils::MM_Unix::clean ;
+sub ExtUtils::MM_Unix::const_cccmd ;
+sub ExtUtils::MM_Unix::const_config ;
+sub ExtUtils::MM_Unix::const_loadlibs ;
+sub ExtUtils::MM_Unix::constants ;
+sub ExtUtils::MM_Unix::depend ;
+sub ExtUtils::MM_Unix::dir_target ;
+sub ExtUtils::MM_Unix::dist ;
+sub ExtUtils::MM_Unix::dist_basics ;
+sub ExtUtils::MM_Unix::dist_ci ;
+sub ExtUtils::MM_Unix::dist_core ;
+sub ExtUtils::MM_Unix::dist_dir ;
+sub ExtUtils::MM_Unix::dist_test ;
+sub ExtUtils::MM_Unix::dlsyms ;
+sub ExtUtils::MM_Unix::dynamic ;
+sub ExtUtils::MM_Unix::dynamic_bs ;
+sub ExtUtils::MM_Unix::dynamic_lib ;
+sub ExtUtils::MM_Unix::exescan ;
+sub ExtUtils::MM_Unix::export_list ;
+sub ExtUtils::MM_Unix::extliblist ;
+sub ExtUtils::MM_Unix::file_name_is_absolute ;
+sub ExtUtils::MM_Unix::find_perl ;
+sub ExtUtils::MM_Unix::fixin ;
+sub ExtUtils::MM_Unix::force ;
+sub ExtUtils::MM_Unix::guess_name ;
+sub ExtUtils::MM_Unix::has_link_code ;
+sub ExtUtils::MM_Unix::init_dirscan ;
+sub ExtUtils::MM_Unix::init_main ;
+sub ExtUtils::MM_Unix::init_others ;
+sub ExtUtils::MM_Unix::install ;
+sub ExtUtils::MM_Unix::installbin ;
+sub ExtUtils::MM_Unix::libscan ;
+sub ExtUtils::MM_Unix::linkext ;
+sub ExtUtils::MM_Unix::lsdir ;
+sub ExtUtils::MM_Unix::macro ;
+sub ExtUtils::MM_Unix::makeaperl ;
+sub ExtUtils::MM_Unix::makefile ;
+sub ExtUtils::MM_Unix::manifypods ;
+sub ExtUtils::MM_Unix::maybe_command ;
+sub ExtUtils::MM_Unix::maybe_command_in_dirs ;
+sub ExtUtils::MM_Unix::needs_linking ;
+sub ExtUtils::MM_Unix::nicetext ;
+sub ExtUtils::MM_Unix::parse_version ;
+sub ExtUtils::MM_Unix::pasthru ;
+sub ExtUtils::MM_Unix::path ;
+sub ExtUtils::MM_Unix::perl_archive;
+sub ExtUtils::MM_Unix::perl_script ;
+sub ExtUtils::MM_Unix::perldepend ;
+sub ExtUtils::MM_Unix::pm_to_blib ;
+sub ExtUtils::MM_Unix::post_constants ;
+sub ExtUtils::MM_Unix::post_initialize ;
+sub ExtUtils::MM_Unix::postamble ;
+sub ExtUtils::MM_Unix::ppd ;
+sub ExtUtils::MM_Unix::prefixify ;
+sub ExtUtils::MM_Unix::processPL ;
+sub ExtUtils::MM_Unix::realclean ;
+sub ExtUtils::MM_Unix::replace_manpage_separator ;
+sub ExtUtils::MM_Unix::static ;
+sub ExtUtils::MM_Unix::static_lib ;
+sub ExtUtils::MM_Unix::staticmake ;
+sub ExtUtils::MM_Unix::subdir_x ;
+sub ExtUtils::MM_Unix::subdirs ;
+sub ExtUtils::MM_Unix::test ;
+sub ExtUtils::MM_Unix::test_via_harness ;
+sub ExtUtils::MM_Unix::test_via_script ;
+sub ExtUtils::MM_Unix::tool_autosplit ;
+sub ExtUtils::MM_Unix::tool_xsubpp ;
+sub ExtUtils::MM_Unix::tools_other ;
+sub ExtUtils::MM_Unix::top_targets ;
+sub ExtUtils::MM_Unix::writedoc ;
+sub ExtUtils::MM_Unix::xs_c ;
+sub ExtUtils::MM_Unix::xs_o ;
+sub ExtUtils::MM_Unix::xsubpp_version ;
+
+package ExtUtils::MM_Unix;
+
+use SelfLoader;
+
+1;
+
+__DATA__
+
+=back
+
+=head2 SelfLoaded methods
+
+=over 2
+
+=item c_o (o)
+
+Defines the suffix rules to compile different flavors of C files to
+object files.
+
+=cut
+
+sub c_o {
+# --- Translation Sections ---
+
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ my(@m);
+ push @m, '
+.c$(OBJ_EXT):
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
+';
+ push @m, '
+.C$(OBJ_EXT):
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.C
+' if $^O ne 'os2' and $^O ne 'MSWin32' and $^O ne 'dos'; #Case-specific
+ push @m, '
+.cpp$(OBJ_EXT):
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cpp
+
+.cxx$(OBJ_EXT):
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cxx
+
+.cc$(OBJ_EXT):
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cc
+';
+ join "", @m;
+}
+
+=item cflags (o)
+
+Does very much the same as the cflags script in the perl
+distribution. It doesn't return the whole compiler command line, but
+initializes all of its parts. The const_cccmd method then actually
+returns the definition of the CCCMD macro which uses these parts.
+
+=cut
+
+#'
+
+sub cflags {
+ my($self,$libperl)=@_;
+ return $self->{CFLAGS} if $self->{CFLAGS};
+ return '' unless $self->needs_linking();
+
+ my($prog, $uc, $perltype, %cflags);
+ $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ;
+ $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/;
+
+ @cflags{qw(cc ccflags optimize large split shellflags)}
+ = @Config{qw(cc ccflags optimize large split shellflags)};
+ my($optdebug) = "";
+
+ $cflags{shellflags} ||= '';
+
+ my(%map) = (
+ D => '-DDEBUGGING',
+ E => '-DEMBED',
+ DE => '-DDEBUGGING -DEMBED',
+ M => '-DEMBED -DMULTIPLICITY',
+ DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY',
+ );
+
+ if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){
+ $uc = uc($1);
+ } else {
+ $uc = ""; # avoid warning
+ }
+ $perltype = $map{$uc} ? $map{$uc} : "";
+
+ if ($uc =~ /^D/) {
+ $optdebug = "-g";
+ }
+
+
+ my($name);
+ ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
+ if ($prog = $Config::Config{$name}) {
+ # Expand hints for this extension via the shell
+ print STDOUT "Processing $name hint:\n" if $Verbose;
+ my(@o)=`cc=\"$cflags{cc}\"
+ ccflags=\"$cflags{ccflags}\"
+ optimize=\"$cflags{optimize}\"
+ perltype=\"$cflags{perltype}\"
+ optdebug=\"$cflags{optdebug}\"
+ large=\"$cflags{large}\"
+ split=\"$cflags{'split'}\"
+ eval '$prog'
+ echo cc=\$cc
+ echo ccflags=\$ccflags
+ echo optimize=\$optimize
+ echo perltype=\$perltype
+ echo optdebug=\$optdebug
+ echo large=\$large
+ echo split=\$split
+ `;
+ my($line);
+ foreach $line (@o){
+ chomp $line;
+ if ($line =~ /(.*?)=\s*(.*)\s*$/){
+ $cflags{$1} = $2;
+ print STDOUT " $1 = $2\n" if $Verbose;
+ } else {
+ print STDOUT "Unrecognised result from hint: '$line'\n";
+ }
+ }
+ }
+
+ if ($optdebug) {
+ $cflags{optimize} = $optdebug;
+ }
+
+ for (qw(ccflags optimize perltype large split)) {
+ $cflags{$_} =~ s/^\s+//;
+ $cflags{$_} =~ s/\s+/ /g;
+ $cflags{$_} =~ s/\s+$//;
+ $self->{uc $_} ||= $cflags{$_}
+ }
+
+ if ($self->{CAPI} && $Is_PERL_OBJECT == 1) {
+ $self->{CCFLAGS} =~ s/-DPERL_OBJECT(\s|$)//;
+ $self->{CCFLAGS} .= '-DPERL_CAPI';
+ if ($Is_Win32 && $Config{'cc'} =~ /^cl.exe/i) {
+ # Turn off C++ mode of the MSC compiler
+ $self->{CCFLAGS} =~ s/-TP(\s|$)//;
+ $self->{OPTIMIZE} =~ s/-TP(\s|$)//;
+ }
+ }
+ return $self->{CFLAGS} = qq{
+CCFLAGS = $self->{CCFLAGS}
+OPTIMIZE = $self->{OPTIMIZE}
+PERLTYPE = $self->{PERLTYPE}
+LARGE = $self->{LARGE}
+SPLIT = $self->{SPLIT}
+};
+
+}
+
+=item clean (o)
+
+Defines the clean target.
+
+=cut
+
+sub clean {
+# --- Cleanup and Distribution Sections ---
+
+ my($self, %attribs) = @_;
+ my(@m,$dir);
+ push(@m, '
+# Delete temporary files but do not touch installed files. We don\'t delete
+# the Makefile here so a later make realclean still has a makefile to use.
+
+clean ::
+');
+ # clean subdirectories first
+ for $dir (@{$self->{DIR}}) {
+ push @m, "\t-cd $dir && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) clean\n";
+ }
+
+ my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files
+ push(@otherfiles, $attribs{FILES}) if $attribs{FILES};
+ push(@otherfiles, qw[./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all
+ perlmain.c mon.out core so_locations pm_to_blib
+ *~ */*~ */*/*~ *$(OBJ_EXT) *$(LIB_EXT) perl.exe
+ $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def
+ $(BASEEXT).exp
+ ]);
+ push @m, "\t-$self->{RM_RF} @otherfiles\n";
+ # See realclean and ext/utils/make_ext for usage of Makefile.old
+ push(@m,
+ "\t-$self->{MV} $self->{MAKEFILE} $self->{MAKEFILE}.old \$(DEV_NULL)\n");
+ push(@m,
+ "\t$attribs{POSTOP}\n") if $attribs{POSTOP};
+ join("", @m);
+}
+
+=item const_cccmd (o)
+
+Returns the full compiler call for C programs and stores the
+definition in CONST_CCCMD.
+
+=cut
+
+sub const_cccmd {
+ my($self,$libperl)=@_;
+ return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
+ return '' unless $self->needs_linking();
+ return $self->{CONST_CCCMD} =
+ q{CCCMD = $(CC) -c $(INC) $(CCFLAGS) $(OPTIMIZE) \\
+ $(PERLTYPE) $(LARGE) $(SPLIT) $(DEFINE_VERSION) \\
+ $(XS_DEFINE_VERSION)};
+}
+
+=item const_config (o)
+
+Defines a couple of constants in the Makefile that are imported from
+%Config.
+
+=cut
+
+sub const_config {
+# --- Constants Sections ---
+
+ my($self) = shift;
+ my(@m,$m);
+ push(@m,"\n# These definitions are from config.sh (via $INC{'Config.pm'})\n");
+ push(@m,"\n# They may have been overridden via Makefile.PL or on the command line\n");
+ my(%once_only);
+ foreach $m (@{$self->{CONFIG}}){
+ # SITE*EXP macros are defined in &constants; avoid duplicates here
+ next if $once_only{$m} or $m eq 'sitelibexp' or $m eq 'sitearchexp';
+ push @m, "\U$m\E = ".$self->{uc $m}."\n";
+ $once_only{$m} = 1;
+ }
+ join('', @m);
+}
+
+=item const_loadlibs (o)
+
+Defines EXTRALIBS, LDLOADLIBS, BSLOADLIBS, LD_RUN_PATH. See
+L<ExtUtils::Liblist> for details.
+
+=cut
+
+sub const_loadlibs {
+ my($self) = shift;
+ return "" unless $self->needs_linking;
+ my @m;
+ push @m, qq{
+# $self->{NAME} might depend on some other libraries:
+# See ExtUtils::Liblist for details
+#
+};
+ my($tmp);
+ for $tmp (qw/
+ EXTRALIBS LDLOADLIBS BSLOADLIBS LD_RUN_PATH
+ /) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+ return join "", @m;
+}
+
+=item constants (o)
+
+Initializes lots of constants and .SUFFIXES and .PHONY
+
+=cut
+
+sub constants {
+ my($self) = @_;
+ my(@m,$tmp);
+
+ for $tmp (qw/
+
+ AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION
+ VERSION_SYM XS_VERSION INST_BIN INST_EXE INST_LIB
+ INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS
+ INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB
+ INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
+ PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
+ FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC
+ PERL_INC PERL FULLPERL
+
+ / ) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+ push @m, qq{
+VERSION_MACRO = VERSION
+DEFINE_VERSION = -D\$(VERSION_MACRO)=\\\"\$(VERSION)\\\"
+XS_VERSION_MACRO = XS_VERSION
+XS_DEFINE_VERSION = -D\$(XS_VERSION_MACRO)=\\\"\$(XS_VERSION)\\\"
+};
+
+ push @m, qq{
+MAKEMAKER = $INC{'ExtUtils/MakeMaker.pm'}
+MM_VERSION = $ExtUtils::MakeMaker::VERSION
+};
+
+ push @m, q{
+# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).
+# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)
+# ROOTEXT = Directory part of FULLEXT with leading slash (eg /DBD) !!! Deprecated from MM 5.32 !!!
+# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
+# DLBASE = Basename part of dynamic library. May be just equal BASEEXT.
+};
+
+ for $tmp (qw/
+ FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
+ LDFROM LINKTYPE
+ / ) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+ push @m, "
+# Handy lists of source code files:
+XS_FILES= ".join(" \\\n\t", sort keys %{$self->{XS}})."
+C_FILES = ".join(" \\\n\t", @{$self->{C}})."
+O_FILES = ".join(" \\\n\t", @{$self->{O_FILES}})."
+H_FILES = ".join(" \\\n\t", @{$self->{H}})."
+MAN1PODS = ".join(" \\\n\t", sort keys %{$self->{MAN1PODS}})."
+MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})."
+";
+
+ for $tmp (qw/
+ INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT
+ /) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+ for $tmp (qw(
+ PERM_RW PERM_RWX
+ )
+ ) {
+ my $method = lc($tmp);
+ # warn "self[$self] method[$method]";
+ push @m, "$tmp = ", $self->$method(), "\n";
+ }
+
+ push @m, q{
+.NO_CONFIG_REC: Makefile
+} if $ENV{CLEARCASE_ROOT};
+
+ # why not q{} ? -- emacs
+ push @m, qq{
+# work around a famous dec-osf make(1) feature(?):
+makemakerdflt: all
+
+.SUFFIXES: .xs .c .C .cpp .cxx .cc \$(OBJ_EXT)
+
+# Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that
+# some make implementations will delete the Makefile when we rebuild it. Because
+# we call false(1) when we rebuild it. So make(1) is not completely wrong when it
+# does so. Our milage may vary.
+# .PRECIOUS: Makefile # seems to be not necessary anymore
+
+.PHONY: all config static dynamic test linkext manifest
+
+# Where is the Config information that we are using/depend on
+CONFIGDEP = \$(PERL_ARCHLIB)/Config.pm \$(PERL_INC)/config.h
+};
+
+ my @parentdir = split(/::/, $self->{PARENT_NAME});
+ push @m, q{
+# Where to put things:
+INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{
+INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{
+
+INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{
+INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{
+};
+
+ if ($self->has_link_code()) {
+ push @m, '
+INST_STATIC = $(INST_ARCHAUTODIR)/$(BASEEXT)$(LIB_EXT)
+INST_DYNAMIC = $(INST_ARCHAUTODIR)/$(DLBASE).$(DLEXT)
+INST_BOOT = $(INST_ARCHAUTODIR)/$(BASEEXT).bs
+';
+ } else {
+ push @m, '
+INST_STATIC =
+INST_DYNAMIC =
+INST_BOOT =
+';
+ }
+
+ $tmp = $self->export_list;
+ push @m, "
+EXPORT_LIST = $tmp
+";
+ $tmp = $self->perl_archive;
+ push @m, "
+PERL_ARCHIVE = $tmp
+";
+
+# push @m, q{
+#INST_PM = }.join(" \\\n\t", sort values %{$self->{PM}}).q{
+#
+#PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{
+#};
+
+ push @m, q{
+TO_INST_PM = }.join(" \\\n\t", sort keys %{$self->{PM}}).q{
+
+PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{
+};
+
+ join('',@m);
+}
+
+=item depend (o)
+
+Same as macro for the depend attribute.
+
+=cut
+
+sub depend {
+ my($self,%attribs) = @_;
+ my(@m,$key,$val);
+ while (($key,$val) = each %attribs){
+ last unless defined $key;
+ push @m, "$key: $val\n";
+ }
+ join "", @m;
+}
+
+=item dir_target (o)
+
+Takes an array of directories that need to exist and returns a
+Makefile entry for a .exists file in these directories. Returns
+nothing, if the entry has already been processed. We're helpless
+though, if the same directory comes as $(FOO) _and_ as "bar". Both of
+them get an entry, that's why we use "::".
+
+=cut
+
+sub dir_target {
+# --- Make-Directories section (internal method) ---
+# dir_target(@array) returns a Makefile entry for the file .exists in each
+# named directory. Returns nothing, if the entry has already been processed.
+# We're helpless though, if the same directory comes as $(FOO) _and_ as "bar".
+# Both of them get an entry, that's why we use "::". I chose '$(PERL)' as the
+# prerequisite, because there has to be one, something that doesn't change
+# too often :)
+
+ my($self,@dirs) = @_;
+ my(@m,$dir,$targdir);
+ foreach $dir (@dirs) {
+ my($src) = $self->catfile($self->{PERL_INC},'perl.h');
+ my($targ) = $self->catfile($dir,'.exists');
+ # catfile may have adapted syntax of $dir to target OS, so...
+ if ($Is_VMS) { # Just remove file name; dirspec is often in macro
+ ($targdir = $targ) =~ s:/?\.exists$::;
+ }
+ else { # while elsewhere we expect to see the dir separator in $targ
+ $targdir = dirname($targ);
+ }
+ next if $self->{DIR_TARGET}{$self}{$targdir}++;
+ push @m, qq{
+$targ :: $src
+ $self->{NOECHO}\$(MKPATH) $targdir
+ $self->{NOECHO}\$(EQUALIZE_TIMESTAMP) $src $targ
+};
+ push(@m, qq{
+ -$self->{NOECHO}\$(CHMOD) \$(PERM_RWX) $targdir
+}) unless $Is_VMS;
+ }
+ join "", @m;
+}
+
+=item dist (o)
+
+Defines a lot of macros for distribution support.
+
+=cut
+
+sub dist {
+ my($self, %attribs) = @_;
+
+ my(@m);
+ # VERSION should be sanitised before use as a file name
+ my($version) = $attribs{VERSION} || '$(VERSION)';
+ my($name) = $attribs{NAME} || '$(DISTNAME)';
+ my($tar) = $attribs{TAR} || 'tar'; # eg /usr/bin/gnutar
+ my($tarflags) = $attribs{TARFLAGS} || 'cvf';
+ my($zip) = $attribs{ZIP} || 'zip'; # eg pkzip Yuck!
+ my($zipflags) = $attribs{ZIPFLAGS} || '-r';
+ my($compress) = $attribs{COMPRESS} || 'gzip --best';
+ my($suffix) = $attribs{SUFFIX} || '.gz'; # eg .gz
+ my($shar) = $attribs{SHAR} || 'shar'; # eg "shar --gzip"
+ my($preop) = $attribs{PREOP} || "$self->{NOECHO}\$(NOOP)"; # eg update MANIFEST
+ my($postop) = $attribs{POSTOP} || "$self->{NOECHO}\$(NOOP)"; # eg remove the distdir
+
+ my($to_unix) = $attribs{TO_UNIX} || ($Is_OS2
+ ? "$self->{NOECHO}"
+ . '$(TEST_F) tmp.zip && $(RM) tmp.zip;'
+ . ' $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM) tmp.zip'
+ : "$self->{NOECHO}\$(NOOP)");
+
+ my($ci) = $attribs{CI} || 'ci -u';
+ my($rcs_label)= $attribs{RCS_LABEL}|| 'rcs -Nv$(VERSION_SYM): -q';
+ my($dist_cp) = $attribs{DIST_CP} || 'best';
+ my($dist_default) = $attribs{DIST_DEFAULT} || 'tardist';
+
+ push @m, "
+DISTVNAME = ${name}-$version
+TAR = $tar
+TARFLAGS = $tarflags
+ZIP = $zip
+ZIPFLAGS = $zipflags
+COMPRESS = $compress
+SUFFIX = $suffix
+SHAR = $shar
+PREOP = $preop
+POSTOP = $postop
+TO_UNIX = $to_unix
+CI = $ci
+RCS_LABEL = $rcs_label
+DIST_CP = $dist_cp
+DIST_DEFAULT = $dist_default
+";
+ join "", @m;
+}
+
+=item dist_basics (o)
+
+Defines the targets distclean, distcheck, skipcheck, manifest.
+
+=cut
+
+sub dist_basics {
+ my($self) = shift;
+ my @m;
+ push @m, q{
+distclean :: realclean distcheck
+};
+
+ push @m, q{
+distcheck :
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=fullcheck \\
+ -e fullcheck
+};
+
+ push @m, q{
+skipcheck :
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=skipcheck \\
+ -e skipcheck
+};
+
+ push @m, q{
+manifest :
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \\
+ -e mkmanifest
+};
+ join "", @m;
+}
+
+=item dist_ci (o)
+
+Defines a check in target for RCS.
+
+=cut
+
+sub dist_ci {
+ my($self) = shift;
+ my @m;
+ push @m, q{
+ci :
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \\
+ -e "@all = keys %{ maniread() };" \\
+ -e 'print("Executing $(CI) @all\n"); system("$(CI) @all");' \\
+ -e 'print("Executing $(RCS_LABEL) ...\n"); system("$(RCS_LABEL) @all");'
+};
+ join "", @m;
+}
+
+=item dist_core (o)
+
+Defeines the targets dist, tardist, zipdist, uutardist, shdist
+
+=cut
+
+sub dist_core {
+ my($self) = shift;
+ my @m;
+ push @m, q{
+dist : $(DIST_DEFAULT)
+ }.$self->{NOECHO}.q{$(PERL) -le 'print "Warning: Makefile possibly out of date with $$vf" if ' \
+ -e '-e ($$vf="$(VERSION_FROM)") and -M $$vf < -M "}.$self->{MAKEFILE}.q{";'
+
+tardist : $(DISTVNAME).tar$(SUFFIX)
+
+zipdist : $(DISTVNAME).zip
+
+$(DISTVNAME).tar$(SUFFIX) : distdir
+ $(PREOP)
+ $(TO_UNIX)
+ $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
+ $(RM_RF) $(DISTVNAME)
+ $(COMPRESS) $(DISTVNAME).tar
+ $(POSTOP)
+
+$(DISTVNAME).zip : distdir
+ $(PREOP)
+ $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+
+uutardist : $(DISTVNAME).tar$(SUFFIX)
+ uuencode $(DISTVNAME).tar$(SUFFIX) \\
+ $(DISTVNAME).tar$(SUFFIX) > \\
+ $(DISTVNAME).tar$(SUFFIX)_uu
+
+shdist : distdir
+ $(PREOP)
+ $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+};
+ join "", @m;
+}
+
+=item dist_dir (o)
+
+Defines the scratch directory target that will hold the distribution
+before tar-ing (or shar-ing).
+
+=cut
+
+sub dist_dir {
+ my($self) = shift;
+ my @m;
+ push @m, q{
+distdir :
+ $(RM_RF) $(DISTVNAME)
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=manicopy,maniread \\
+ -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"
+};
+ join "", @m;
+}
+
+=item dist_test (o)
+
+Defines a target that produces the distribution in the
+scratchdirectory, and runs 'perl Makefile.PL; make ;make test' in that
+subdirectory.
+
+=cut
+
+sub dist_test {
+ my($self) = shift;
+ my @m;
+ push @m, q{
+disttest : distdir
+ cd $(DISTVNAME) && $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) Makefile.PL
+ cd $(DISTVNAME) && $(MAKE)
+ cd $(DISTVNAME) && $(MAKE) test
+};
+ join "", @m;
+}
+
+=item dlsyms (o)
+
+Used by AIX and VMS to define DL_FUNCS and DL_VARS and write the *.exp
+files.
+
+=cut
+
+sub dlsyms {
+ my($self,%attribs) = @_;
+
+ return '' unless ($^O eq 'aix' && $self->needs_linking() );
+
+ my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
+ my(@m);
+
+ push(@m,"
+dynamic :: $self->{BASEEXT}.exp
+
+") unless $self->{SKIPHASH}{'dynamic'}; # dynamic and static are subs, so...
+
+ push(@m,"
+static :: $self->{BASEEXT}.exp
+
+") unless $self->{SKIPHASH}{'static'}; # we avoid a warning if we tick them
+
+ push(@m,"
+$self->{BASEEXT}.exp: Makefile.PL
+",' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\
+ Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ',
+ neatvalue($funcs),', "DL_VARS" => ', neatvalue($vars), ');\'
+');
+
+ join('',@m);
+}
+
+=item dynamic (o)
+
+Defines the dynamic target.
+
+=cut
+
+sub dynamic {
+# --- Dynamic Loading Sections ---
+
+ my($self) = shift;
+ '
+## $(INST_PM) has been moved to the all: target.
+## It remains here for awhile to allow for old usage: "make dynamic"
+#dynamic :: '.$self->{MAKEFILE}.' $(INST_DYNAMIC) $(INST_BOOT) $(INST_PM)
+dynamic :: '.$self->{MAKEFILE}.' $(INST_DYNAMIC) $(INST_BOOT)
+ '.$self->{NOECHO}.'$(NOOP)
+';
+}
+
+=item dynamic_bs (o)
+
+Defines targets for bootstrap files.
+
+=cut
+
+sub dynamic_bs {
+ my($self, %attribs) = @_;
+ return '
+BOOTSTRAP =
+' unless $self->has_link_code();
+
+ return '
+BOOTSTRAP = '."$self->{BASEEXT}.bs".'
+
+# As Mkbootstrap might not write a file (if none is required)
+# we use touch to prevent make continually trying to remake it.
+# The DynaLoader only reads a non-empty file.
+$(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)/.exists
+ '.$self->{NOECHO}.'echo "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))"
+ '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \
+ -MExtUtils::Mkbootstrap \
+ -e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');"
+ '.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP)
+ $(CHMOD) $(PERM_RW) $@
+
+$(INST_BOOT): $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists
+ '."$self->{NOECHO}$self->{RM_RF}".' $(INST_BOOT)
+ -'.$self->{CP}.' $(BOOTSTRAP) $(INST_BOOT)
+ $(CHMOD) $(PERM_RW) $@
+';
+}
+
+=item dynamic_lib (o)
+
+Defines how to produce the *.so (or equivalent) files.
+
+=cut
+
+sub dynamic_lib {
+ my($self, %attribs) = @_;
+ return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code;
+
+ my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
+ my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
+ my($armaybe) = $attribs{ARMAYBE} || $self->{ARMAYBE} || ":";
+ my($ldfrom) = '$(LDFROM)';
+ $armaybe = 'ar' if ($^O eq 'dec_osf' and $armaybe eq ':');
+ my(@m);
+ push(@m,'
+# This section creates the dynamically loadable $(INST_DYNAMIC)
+# from $(OBJECT) and possibly $(MYEXTLIB).
+ARMAYBE = '.$armaybe.'
+OTHERLDFLAGS = '.$otherldflags.'
+INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
+
+$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
+');
+ if ($armaybe ne ':'){
+ $ldfrom = 'tmp$(LIB_EXT)';
+ push(@m,' $(ARMAYBE) cr '.$ldfrom.' $(OBJECT)'."\n");
+ push(@m,' $(RANLIB) '."$ldfrom\n");
+ }
+ $ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf');
+
+ # Brain dead solaris linker does not use LD_RUN_PATH?
+ # This fixes dynamic extensions which need shared libs
+ my $ldrun = '';
+ $ldrun = join ' ', map "-R$_", split /:/, $self->{LD_RUN_PATH}
+ if ($^O eq 'solaris');
+
+ # The IRIX linker also doesn't use LD_RUN_PATH
+ $ldrun = qq{-rpath "$self->{LD_RUN_PATH}"}
+ if ($^O eq 'irix' && $self->{LD_RUN_PATH});
+
+ push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom.
+ ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)');
+ push @m, '
+ $(CHMOD) $(PERM_RWX) $@
+';
+
+ push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
+ join('',@m);
+}
+
+=item exescan
+
+Deprecated method. Use libscan instead.
+
+=cut
+
+sub exescan {
+ my($self,$path) = @_;
+ $path;
+}
+
+=item extliblist
+
+Called by init_others, and calls ext ExtUtils::Liblist. See
+L<ExtUtils::Liblist> for details.
+
+=cut
+
+sub extliblist {
+ my($self,$libs) = @_;
+ require ExtUtils::Liblist;
+ $self->ext($libs, $Verbose);
+}
+
+=item file_name_is_absolute
+
+Takes as argument a path and returns true, if it is an absolute path.
+
+=cut
+
+sub file_name_is_absolute {
+ my($self,$file) = @_;
+ if ($Is_Dos){
+ $file =~ m{^([a-z]:)?[\\/]}i ;
+ }
+ else {
+ $file =~ m:^/: ;
+ }
+}
+
+=item find_perl
+
+Finds the executables PERL and FULLPERL
+
+=cut
+
+sub find_perl {
+ my($self, $ver, $names, $dirs, $trace) = @_;
+ my($name, $dir);
+ if ($trace >= 2){
+ print "Looking for perl $ver by these names:
+@$names
+in these dirs:
+@$dirs
+";
+ }
+ foreach $dir (@$dirs){
+ next unless defined $dir; # $self->{PERL_SRC} may be undefined
+ foreach $name (@$names){
+ my ($abs, $val);
+ if ($self->file_name_is_absolute($name)) { # /foo/bar
+ $abs = $name;
+ } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo
+ $abs = $self->catfile($dir, $name);
+ } else { # foo/bar
+ $abs = $self->canonpath($self->catfile($self->curdir, $name));
+ }
+ print "Checking $abs\n" if ($trace >= 2);
+ next unless $self->maybe_command($abs);
+ print "Executing $abs\n" if ($trace >= 2);
+ $val = `$abs -e 'require $ver; print "VER_OK\n" ' 2>&1`;
+ if ($val =~ /VER_OK/) {
+ print "Using PERL=$abs\n" if $trace;
+ return $abs;
+ } elsif ($trace >= 2) {
+ print "Result: `$val'\n";
+ }
+ }
+ }
+ print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
+ 0; # false and not empty
+}
+
+=back
+
+=head2 Methods to actually produce chunks of text for the Makefile
+
+The methods here are called for each MakeMaker object in the order
+specified by @ExtUtils::MakeMaker::MM_Sections.
+
+=over 2
+
+=item fixin
+
+Inserts the sharpbang or equivalent magic number to a script
+
+=cut
+
+sub fixin { # stolen from the pink Camel book, more or less
+ my($self,@files) = @_;
+ my($does_shbang) = $Config::Config{'sharpbang'} =~ /^\s*\#\!/;
+ my($file,$interpreter);
+ for $file (@files) {
+ local(*FIXIN);
+ local(*FIXOUT);
+ open(FIXIN, $file) or Carp::croak "Can't process '$file': $!";
+ local $/ = "\n";
+ chomp(my $line = <FIXIN>);
+ next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file.
+ # Now figure out the interpreter name.
+ my($cmd,$arg) = split ' ', $line, 2;
+ $cmd =~ s!^.*/!!;
+
+ # Now look (in reverse) for interpreter in absolute PATH (unless perl).
+ if ($cmd eq "perl") {
+ if ($Config{startperl} =~ m,^\#!.*/perl,) {
+ $interpreter = $Config{startperl};
+ $interpreter =~ s,^\#!,,;
+ } else {
+ $interpreter = $Config{perlpath};
+ }
+ } else {
+ my(@absdirs) = reverse grep {$self->file_name_is_absolute} $self->path;
+ $interpreter = '';
+ my($dir);
+ foreach $dir (@absdirs) {
+ if ($self->maybe_command($cmd)) {
+ warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter;
+ $interpreter = $self->catfile($dir,$cmd);
+ }
+ }
+ }
+ # Figure out how to invoke interpreter on this machine.
+
+ my($shb) = "";
+ if ($interpreter) {
+ print STDOUT "Changing sharpbang in $file to $interpreter" if $Verbose;
+ # this is probably value-free on DOSISH platforms
+ if ($does_shbang) {
+ $shb .= "$Config{'sharpbang'}$interpreter";
+ $shb .= ' ' . $arg if defined $arg;
+ $shb .= "\n";
+ }
+ $shb .= qq{
+eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
+ if 0; # not running under some shell
+} unless $Is_Win32; # this won't work on win32, so don't
+ } else {
+ warn "Can't find $cmd in PATH, $file unchanged"
+ if $Verbose;
+ next;
+ }
+
+ unless ( open(FIXOUT,">$file.new") ) {
+ warn "Can't create new $file: $!\n";
+ next;
+ }
+ my($dev,$ino,$mode) = stat FIXIN;
+ # If they override perm_rwx, we won't notice it during fixin,
+ # because fixin is run through a new instance of MakeMaker.
+ # That is why we must run another CHMOD later.
+ $mode = oct($self->perm_rwx) unless $dev;
+ chmod $mode, $file;
+
+ # Print out the new #! line (or equivalent).
+ local $\;
+ undef $/;
+ print FIXOUT $shb, <FIXIN>;
+ close FIXIN;
+ close FIXOUT;
+ # can't rename open files on some DOSISH platforms
+ unless ( rename($file, "$file.bak") ) {
+ warn "Can't rename $file to $file.bak: $!";
+ next;
+ }
+ unless ( rename("$file.new", $file) ) {
+ warn "Can't rename $file.new to $file: $!";
+ unless ( rename("$file.bak", $file) ) {
+ warn "Can't rename $file.bak back to $file either: $!";
+ warn "Leaving $file renamed as $file.bak\n";
+ }
+ next;
+ }
+ unlink "$file.bak";
+ } continue {
+ chmod oct($self->perm_rwx), $file or
+ die "Can't reset permissions for $file: $!\n";
+ system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';;
+ }
+}
+
+=item force (o)
+
+Just writes FORCE:
+
+=cut
+
+sub force {
+ my($self) = shift;
+ '# Phony target to force checking subdirectories.
+FORCE:
+ '.$self->{NOECHO}.'$(NOOP)
+';
+}
+
+=item guess_name
+
+Guess the name of this package by examining the working directory's
+name. MakeMaker calls this only if the developer has not supplied a
+NAME attribute.
+
+=cut
+
+# ';
+
+sub guess_name {
+ my($self) = @_;
+ use Cwd 'cwd';
+ my $name = basename(cwd());
+ $name =~ s|[\-_][\d\.\-]+$||; # this is new with MM 5.00, we
+ # strip minus or underline
+ # followed by a float or some such
+ print "Warning: Guessing NAME [$name] from current directory name.\n";
+ $name;
+}
+
+=item has_link_code
+
+Returns true if C, XS, MYEXTLIB or similar objects exist within this
+object that need a compiler. Does not descend into subdirectories as
+needs_linking() does.
+
+=cut
+
+sub has_link_code {
+ my($self) = shift;
+ return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE};
+ if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){
+ $self->{HAS_LINK_CODE} = 1;
+ return 1;
+ }
+ return $self->{HAS_LINK_CODE} = 0;
+}
+
+=item init_dirscan
+
+Initializes DIR, XS, PM, C, O_FILES, H, PL_FILES, MAN*PODS, EXE_FILES.
+
+=cut
+
+sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
+ my($self) = @_;
+ my($name, %dir, %xs, %c, %h, %ignore, %pl_files, %manifypods);
+ local(%pm); #the sub in find() has to see this hash
+ @ignore{qw(Makefile.PL test.pl)} = (1,1);
+ $ignore{'makefile.pl'} = 1 if $Is_VMS;
+ foreach $name ($self->lsdir($self->curdir)){
+ next if $name =~ /\#/;
+ next if $name eq $self->curdir or $name eq $self->updir or $ignore{$name};
+ next unless $self->libscan($name);
+ if (-d $name){
+ next if -l $name; # We do not support symlinks at all
+ $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
+ } elsif ($name =~ /\.xs$/){
+ my($c); ($c = $name) =~ s/\.xs$/.c/;
+ $xs{$name} = $c;
+ $c{$c} = 1;
+ } elsif ($name =~ /\.c(pp|xx|c)?$/i){ # .c .C .cpp .cxx .cc
+ $c{$name} = 1
+ unless $name =~ m/perlmain\.c/; # See MAP_TARGET
+ } elsif ($name =~ /\.h$/i){
+ $h{$name} = 1;
+ } elsif ($name =~ /\.PL$/) {
+ ($pl_files{$name} = $name) =~ s/\.PL$// ;
+ } elsif ($Is_VMS && $name =~ /\.pl$/) { # case-insensitive filesystem
+ local($/); open(PL,$name); my $txt = <PL>; close PL;
+ if ($txt =~ /Extracting \S+ \(with variable substitutions/) {
+ ($pl_files{$name} = $name) =~ s/\.pl$// ;
+ }
+ else { $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name); }
+ } elsif ($name =~ /\.(p[ml]|pod)$/){
+ $pm{$name} = $self->catfile('$(INST_LIBDIR)',$name);
+ }
+ }
+
+ # Some larger extensions often wish to install a number of *.pm/pl
+ # files into the library in various locations.
+
+ # The attribute PMLIBDIRS holds an array reference which lists
+ # subdirectories which we should search for library files to
+ # install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ]. We
+ # recursively search through the named directories (skipping any
+ # which don't exist or contain Makefile.PL files).
+
+ # For each *.pm or *.pl file found $self->libscan() is called with
+ # the default installation path in $_[1]. The return value of
+ # libscan defines the actual installation location. The default
+ # libscan function simply returns the path. The file is skipped
+ # if libscan returns false.
+
+ # The default installation location passed to libscan in $_[1] is:
+ #
+ # ./*.pm => $(INST_LIBDIR)/*.pm
+ # ./xyz/... => $(INST_LIBDIR)/xyz/...
+ # ./lib/... => $(INST_LIB)/...
+ #
+ # In this way the 'lib' directory is seen as the root of the actual
+ # perl library whereas the others are relative to INST_LIBDIR
+ # (which includes PARENT_NAME). This is a subtle distinction but one
+ # that's important for nested modules.
+
+ $self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}]
+ unless $self->{PMLIBDIRS};
+
+ #only existing directories that aren't in $dir are allowed
+
+ # Avoid $_ wherever possible:
+ # @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}};
+ my (@pmlibdirs) = @{$self->{PMLIBDIRS}};
+ my ($pmlibdir);
+ @{$self->{PMLIBDIRS}} = ();
+ foreach $pmlibdir (@pmlibdirs) {
+ -d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir;
+ }
+
+ if (@{$self->{PMLIBDIRS}}){
+ print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n"
+ if ($Verbose >= 2);
+ require File::Find;
+ File::Find::find(sub {
+ if (-d $_){
+ if ($_ eq "CVS" || $_ eq "RCS"){
+ $File::Find::prune = 1;
+ }
+ return;
+ }
+ return if /\#/;
+ my($path, $prefix) = ($File::Find::name, '$(INST_LIBDIR)');
+ my($striplibpath,$striplibname);
+ $prefix = '$(INST_LIB)' if (($striplibpath = $path) =~ s:^(\W*)lib\W:$1:i);
+ ($striplibname,$striplibpath) = fileparse($striplibpath);
+ my($inst) = $self->catfile($prefix,$striplibpath,$striplibname);
+ local($_) = $inst; # for backwards compatibility
+ $inst = $self->libscan($inst);
+ print "libscan($path) => '$inst'\n" if ($Verbose >= 2);
+ return unless $inst;
+ $pm{$path} = $inst;
+ }, @{$self->{PMLIBDIRS}});
+ }
+
+ $self->{DIR} = [sort keys %dir] unless $self->{DIR};
+ $self->{XS} = \%xs unless $self->{XS};
+ $self->{PM} = \%pm unless $self->{PM};
+ $self->{C} = [sort keys %c] unless $self->{C};
+ my(@o_files) = @{$self->{C}};
+ $self->{O_FILES} = [grep s/\.c(pp|xx|c)?$/$self->{OBJ_EXT}/i, @o_files] ;
+ $self->{H} = [sort keys %h] unless $self->{H};
+ $self->{PL_FILES} = \%pl_files unless $self->{PL_FILES};
+
+ # Set up names of manual pages to generate from pods
+ if ($self->{MAN1PODS}) {
+ } elsif ( $self->{INST_MAN1DIR} =~ /^(none|\s*)$/ ) {
+ $self->{MAN1PODS} = {};
+ } else {
+ my %manifypods = ();
+ if ( exists $self->{EXE_FILES} ) {
+ foreach $name (@{$self->{EXE_FILES}}) {
+# use FileHandle ();
+# my $fh = new FileHandle;
+ local *FH;
+ my($ispod)=0;
+# if ($fh->open("<$name")) {
+ if (open(FH,"<$name")) {
+# while (<$fh>) {
+ while (<FH>) {
+ if (/^=head1\s+\w+/) {
+ $ispod=1;
+ last;
+ }
+ }
+# $fh->close;
+ close FH;
+ } else {
+ # If it doesn't exist yet, we assume, it has pods in it
+ $ispod = 1;
+ }
+ if( $ispod ) {
+ $manifypods{$name} =
+ $self->catfile('$(INST_MAN1DIR)',
+ basename($name).'.$(MAN1EXT)');
+ }
+ }
+ }
+ $self->{MAN1PODS} = \%manifypods;
+ }
+ if ($self->{MAN3PODS}) {
+ } elsif ( $self->{INST_MAN3DIR} =~ /^(none|\s*)$/ ) {
+ $self->{MAN3PODS} = {};
+ } else {
+ my %manifypods = (); # we collect the keys first, i.e. the files
+ # we have to convert to pod
+ foreach $name (keys %{$self->{PM}}) {
+ if ($name =~ /\.pod$/ ) {
+ $manifypods{$name} = $self->{PM}{$name};
+ } elsif ($name =~ /\.p[ml]$/ ) {
+# use FileHandle ();
+# my $fh = new FileHandle;
+ local *FH;
+ my($ispod)=0;
+# $fh->open("<$name");
+ if (open(FH,"<$name")) {
+ # while (<$fh>) {
+ while (<FH>) {
+ if (/^=head1\s+\w+/) {
+ $ispod=1;
+ last;
+ }
+ }
+ # $fh->close;
+ close FH;
+ } else {
+ $ispod = 1;
+ }
+ if( $ispod ) {
+ $manifypods{$name} = $self->{PM}{$name};
+ }
+ }
+ }
+
+ # Remove "Configure.pm" and similar, if it's not the only pod listed
+ # To force inclusion, just name it "Configure.pod", or override MAN3PODS
+ foreach $name (keys %manifypods) {
+ if ($name =~ /(config|setup).*\.pm/i) {
+ delete $manifypods{$name};
+ next;
+ }
+ my($manpagename) = $name;
+ unless ($manpagename =~ s!^\W*lib\W+!!) { # everything below lib is ok
+ $manpagename = $self->catfile(split(/::/,$self->{PARENT_NAME}),$manpagename);
+ }
+ $manpagename =~ s/\.p(od|m|l)$//;
+ $manpagename = $self->replace_manpage_separator($manpagename);
+ $manifypods{$name} = $self->catfile("\$(INST_MAN3DIR)","$manpagename.\$(MAN3EXT)");
+ }
+ $self->{MAN3PODS} = \%manifypods;
+ }
+}
+
+=item init_main
+
+Initializes NAME, FULLEXT, BASEEXT, PARENT_NAME, DLBASE, PERL_SRC,
+PERL_LIB, PERL_ARCHLIB, PERL_INC, INSTALLDIRS, INST_*, INSTALL*,
+PREFIX, CONFIG, AR, AR_STATIC_ARGS, LD, OBJ_EXT, LIB_EXT, EXE_EXT, MAP_TARGET,
+LIBPERL_A, VERSION_FROM, VERSION, DISTNAME, VERSION_SYM.
+
+=cut
+
+sub init_main {
+ my($self) = @_;
+
+ # --- Initialize Module Name and Paths
+
+ # NAME = Foo::Bar::Oracle
+ # FULLEXT = Foo/Bar/Oracle
+ # BASEEXT = Oracle
+ # ROOTEXT = Directory part of FULLEXT with leading /. !!! Deprecated from MM 5.32 !!!
+ # PARENT_NAME = Foo::Bar
+### Only UNIX:
+### ($self->{FULLEXT} =
+### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket
+ $self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME});
+
+
+ # Copied from DynaLoader:
+
+ my(@modparts) = split(/::/,$self->{NAME});
+ my($modfname) = $modparts[-1];
+
+ # Some systems have restrictions on files names for DLL's etc.
+ # mod2fname returns appropriate file base name (typically truncated)
+ # It may also edit @modparts if required.
+ if (defined &DynaLoader::mod2fname) {
+ $modfname = &DynaLoader::mod2fname(\@modparts);
+ }
+
+ ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)$! ;
+
+ if (defined &DynaLoader::mod2fname) {
+ # As of 5.001m, dl_os2 appends '_'
+ $self->{DLBASE} = $modfname;
+ } else {
+ $self->{DLBASE} = '$(BASEEXT)';
+ }
+
+
+ ### ROOTEXT deprecated from MM 5.32
+### ($self->{ROOTEXT} =
+### $self->{FULLEXT}) =~ s#/?\Q$self->{BASEEXT}\E$## ; #eg. /BSD/Foo
+### $self->{ROOTEXT} = ($Is_VMS ? '' : '/') . $self->{ROOTEXT} if $self->{ROOTEXT};
+
+
+ # --- Initialize PERL_LIB, INST_LIB, PERL_SRC
+
+ # *Real* information: where did we get these two from? ...
+ my $inc_config_dir = dirname($INC{'Config.pm'});
+ my $inc_carp_dir = dirname($INC{'Carp.pm'});
+
+ unless ($self->{PERL_SRC}){
+ my($dir);
+ foreach $dir ($self->updir(),$self->catdir($self->updir(),$self->updir()),$self->catdir($self->updir(),$self->updir(),$self->updir())){
+ if (
+ -f $self->catfile($dir,"config.sh")
+ &&
+ -f $self->catfile($dir,"perl.h")
+ &&
+ -f $self->catfile($dir,"lib","Exporter.pm")
+ ) {
+ $self->{PERL_SRC}=$dir ;
+ last;
+ }
+ }
+ }
+ if ($self->{PERL_SRC}){
+ $self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib");
+ $self->{PERL_ARCHLIB} = $self->{PERL_LIB};
+ $self->{PERL_INC} = ($Is_Win32) ? $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC};
+
+ # catch a situation that has occurred a few times in the past:
+ unless (
+ -s $self->catfile($self->{PERL_SRC},'cflags')
+ or
+ $Is_VMS
+ &&
+ -s $self->catfile($self->{PERL_SRC},'perlshr_attr.opt')
+ or
+ $Is_Mac
+ or
+ $Is_Win32
+ ){
+ warn qq{
+You cannot build extensions below the perl source tree after executing
+a 'make clean' in the perl source tree.
+
+To rebuild extensions distributed with the perl source you should
+simply Configure (to include those extensions) and then build perl as
+normal. After installing perl the source tree can be deleted. It is
+not needed for building extensions by running 'perl Makefile.PL'
+usually without extra arguments.
+
+It is recommended that you unpack and build additional extensions away
+from the perl source tree.
+};
+ }
+ } else {
+ # we should also consider $ENV{PERL5LIB} here
+ $self->{PERL_LIB} ||= $Config::Config{privlibexp};
+ $self->{PERL_ARCHLIB} ||= $Config::Config{archlibexp};
+ $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
+ my $perl_h;
+ unless (-f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))){
+ die qq{
+Error: Unable to locate installed Perl libraries or Perl source code.
+
+It is recommended that you install perl in a standard location before
+building extensions. Some precompiled versions of perl do not contain
+these header files, so you cannot build extensions. In such a case,
+please build and install your perl from a fresh perl distribution. It
+usually solves this kind of problem.
+
+\(You get this message, because MakeMaker could not find "$perl_h"\)
+};
+ }
+# print STDOUT "Using header files found in $self->{PERL_INC}\n"
+# if $Verbose && $self->needs_linking();
+
+ }
+
+ # We get SITELIBEXP and SITEARCHEXP directly via
+ # Get_from_Config. When we are running standard modules, these
+ # won't matter, we will set INSTALLDIRS to "perl". Otherwise we
+ # set it to "site". I prefer that INSTALLDIRS be set from outside
+ # MakeMaker.
+ $self->{INSTALLDIRS} ||= "site";
+
+ # INST_LIB typically pre-set if building an extension after
+ # perl has been built and installed. Setting INST_LIB allows
+ # you to build directly into, say $Config::Config{privlibexp}.
+ unless ($self->{INST_LIB}){
+
+
+ ##### XXXXX We have to change this nonsense
+
+ if (defined $self->{PERL_SRC} and $self->{INSTALLDIRS} eq "perl") {
+ $self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB};
+ } else {
+ $self->{INST_LIB} = $self->catdir($self->curdir,"blib","lib");
+ }
+ }
+ $self->{INST_ARCHLIB} ||= $self->catdir($self->curdir,"blib","arch");
+ $self->{INST_BIN} ||= $self->catdir($self->curdir,'blib','bin');
+
+ # We need to set up INST_LIBDIR before init_libscan() for VMS
+ my @parentdir = split(/::/, $self->{PARENT_NAME});
+ $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)',@parentdir);
+ $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)',@parentdir);
+ $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)','auto','$(FULLEXT)');
+ $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)');
+
+ # INST_EXE is deprecated, should go away March '97
+ $self->{INST_EXE} ||= $self->catdir($self->curdir,'blib','script');
+ $self->{INST_SCRIPT} ||= $self->catdir($self->curdir,'blib','script');
+
+ # The user who requests an installation directory explicitly
+ # should not have to tell us a architecture installation directory
+ # as well. We look if a directory exists that is named after the
+ # architecture. If not we take it as a sign that it should be the
+ # same as the requested installation directory. Otherwise we take
+ # the found one.
+ # We do the same thing twice: for privlib/archlib and for sitelib/sitearch
+ my($libpair);
+ for $libpair ({l=>"privlib", a=>"archlib"}, {l=>"sitelib", a=>"sitearch"}) {
+ my $lib = "install$libpair->{l}";
+ my $Lib = uc $lib;
+ my $Arch = uc "install$libpair->{a}";
+ if( $self->{$Lib} && ! $self->{$Arch} ){
+ my($ilib) = $Config{$lib};
+ $ilib = VMS::Filespec::unixify($ilib) if $Is_VMS;
+
+ $self->prefixify($Arch,$ilib,$self->{$Lib});
+
+ unless (-d $self->{$Arch}) {
+ print STDOUT "Directory $self->{$Arch} not found, thusly\n" if $Verbose;
+ $self->{$Arch} = $self->{$Lib};
+ }
+ print STDOUT "Defaulting $Arch to $self->{$Arch}\n" if $Verbose;
+ }
+ }
+
+ # we have to look at the relation between $Config{prefix} and the
+ # requested values. We're going to set the $Config{prefix} part of
+ # all the installation path variables to literally $(PREFIX), so
+ # the user can still say make PREFIX=foo
+ my($configure_prefix) = $Config{'prefix'};
+ $configure_prefix = VMS::Filespec::unixify($configure_prefix) if $Is_VMS;
+ $self->{PREFIX} ||= $configure_prefix;
+
+
+ my($install_variable,$search_prefix,$replace_prefix);
+
+ # The rule, taken from Configure, is that if prefix contains perl,
+ # we shape the tree
+ # perlprefix/lib/ INSTALLPRIVLIB
+ # perlprefix/lib/pod/
+ # perlprefix/lib/site_perl/ INSTALLSITELIB
+ # perlprefix/bin/ INSTALLBIN
+ # perlprefix/man/ INSTALLMAN1DIR
+ # else
+ # prefix/lib/perl5/ INSTALLPRIVLIB
+ # prefix/lib/perl5/pod/
+ # prefix/lib/perl5/site_perl/ INSTALLSITELIB
+ # prefix/bin/ INSTALLBIN
+ # prefix/lib/perl5/man/ INSTALLMAN1DIR
+
+ $replace_prefix = qq[\$\(PREFIX\)];
+ for $install_variable (qw/
+ INSTALLBIN
+ INSTALLSCRIPT
+ /) {
+ $self->prefixify($install_variable,$configure_prefix,$replace_prefix);
+ }
+ $search_prefix = $configure_prefix =~ /perl/ ?
+ $self->catdir($configure_prefix,"lib") :
+ $self->catdir($configure_prefix,"lib","perl5");
+ if ($self->{LIB}) {
+ $self->{INSTALLPRIVLIB} = $self->{INSTALLSITELIB} = $self->{LIB};
+ $self->{INSTALLARCHLIB} = $self->{INSTALLSITEARCH} =
+ $self->catdir($self->{LIB},$Config{'archname'});
+ } else {
+ $replace_prefix = $self->{PREFIX} =~ /perl/ ?
+ $self->catdir(qq[\$\(PREFIX\)],"lib") :
+ $self->catdir(qq[\$\(PREFIX\)],"lib","perl5");
+ for $install_variable (qw/
+ INSTALLPRIVLIB
+ INSTALLARCHLIB
+ INSTALLSITELIB
+ INSTALLSITEARCH
+ /) {
+ $self->prefixify($install_variable,$search_prefix,$replace_prefix);
+ }
+ }
+ $search_prefix = $configure_prefix =~ /perl/ ?
+ $self->catdir($configure_prefix,"man") :
+ $self->catdir($configure_prefix,"lib","perl5","man");
+ $replace_prefix = $self->{PREFIX} =~ /perl/ ?
+ $self->catdir(qq[\$\(PREFIX\)],"man") :
+ $self->catdir(qq[\$\(PREFIX\)],"lib","perl5","man");
+ for $install_variable (qw/
+ INSTALLMAN1DIR
+ INSTALLMAN3DIR
+ /) {
+ $self->prefixify($install_variable,$search_prefix,$replace_prefix);
+ }
+
+ # Now we head at the manpages. Maybe they DO NOT want manpages
+ # installed
+ $self->{INSTALLMAN1DIR} = $Config::Config{installman1dir}
+ unless defined $self->{INSTALLMAN1DIR};
+ unless (defined $self->{INST_MAN1DIR}){
+ if ($self->{INSTALLMAN1DIR} =~ /^(none|\s*)$/){
+ $self->{INST_MAN1DIR} = $self->{INSTALLMAN1DIR};
+ } else {
+ $self->{INST_MAN1DIR} = $self->catdir($self->curdir,'blib','man1');
+ }
+ }
+ $self->{MAN1EXT} ||= $Config::Config{man1ext};
+
+ $self->{INSTALLMAN3DIR} = $Config::Config{installman3dir}
+ unless defined $self->{INSTALLMAN3DIR};
+ unless (defined $self->{INST_MAN3DIR}){
+ if ($self->{INSTALLMAN3DIR} =~ /^(none|\s*)$/){
+ $self->{INST_MAN3DIR} = $self->{INSTALLMAN3DIR};
+ } else {
+ $self->{INST_MAN3DIR} = $self->catdir($self->curdir,'blib','man3');
+ }
+ }
+ $self->{MAN3EXT} ||= $Config::Config{man3ext};
+
+
+ # Get some stuff out of %Config if we haven't yet done so
+ print STDOUT "CONFIG must be an array ref\n"
+ if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY');
+ $self->{CONFIG} = [] unless (ref $self->{CONFIG});
+ push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config);
+ push(@{$self->{CONFIG}}, 'shellflags') if $Config::Config{shellflags};
+ my(%once_only,$m);
+ foreach $m (@{$self->{CONFIG}}){
+ next if $once_only{$m};
+ print STDOUT "CONFIG key '$m' does not exist in Config.pm\n"
+ unless exists $Config::Config{$m};
+ $self->{uc $m} ||= $Config::Config{$m};
+ $once_only{$m} = 1;
+ }
+
+# This is too dangerous:
+# if ($^O eq "next") {
+# $self->{AR} = "libtool";
+# $self->{AR_STATIC_ARGS} = "-o";
+# }
+# But I leave it as a placeholder
+
+ $self->{AR_STATIC_ARGS} ||= "cr";
+
+ # These should never be needed
+ $self->{LD} ||= 'ld';
+ $self->{OBJ_EXT} ||= '.o';
+ $self->{LIB_EXT} ||= '.a';
+
+ $self->{MAP_TARGET} ||= "perl";
+
+ $self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}";
+
+ # make a simple check if we find Exporter
+ warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory
+ (Exporter.pm not found)"
+ unless -f $self->catfile("$self->{PERL_LIB}","Exporter.pm") ||
+ $self->{NAME} eq "ExtUtils::MakeMaker";
+
+ # Determine VERSION and VERSION_FROM
+ ($self->{DISTNAME}=$self->{NAME}) =~ s#(::)#-#g unless $self->{DISTNAME};
+ if ($self->{VERSION_FROM}){
+ $self->{VERSION} = $self->parse_version($self->{VERSION_FROM}) or
+ Carp::carp "WARNING: Setting VERSION via file '$self->{VERSION_FROM}' failed\n"
+ }
+
+ # strip blanks
+ if ($self->{VERSION}) {
+ $self->{VERSION} =~ s/^\s+//;
+ $self->{VERSION} =~ s/\s+$//;
+ }
+
+ $self->{VERSION} ||= "0.10";
+ ($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g;
+
+
+ # Graham Barr and Paul Marquess had some ideas how to ensure
+ # version compatibility between the *.pm file and the
+ # corresponding *.xs file. The bottomline was, that we need an
+ # XS_VERSION macro that defaults to VERSION:
+ $self->{XS_VERSION} ||= $self->{VERSION};
+
+ # --- Initialize Perl Binary Locations
+
+ # Find Perl 5. The only contract here is that both 'PERL' and 'FULLPERL'
+ # will be working versions of perl 5. miniperl has priority over perl
+ # for PERL to ensure that $(PERL) is usable while building ./ext/*
+ my ($component,@defpath);
+ foreach $component ($self->{PERL_SRC}, $self->path(), $Config::Config{binexp}) {
+ push @defpath, $component if defined $component;
+ }
+ $self->{PERL} ||=
+ $self->find_perl(5.0, [ $^X, 'miniperl','perl','perl5',"perl$]" ],
+ \@defpath, $Verbose );
+ # don't check if perl is executable, maybe they have decided to
+ # supply switches with perl
+
+ # Define 'FULLPERL' to be a non-miniperl (used in test: target)
+ ($self->{FULLPERL} = $self->{PERL}) =~ s/miniperl/perl/i
+ unless ($self->{FULLPERL});
+}
+
+=item init_others
+
+Initializes EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LIBS, LD_RUN_PATH,
+OBJECT, BOOTDEP, PERLMAINCC, LDFROM, LINKTYPE, NOOP, FIRST_MAKEFILE,
+MAKEFILE, NOECHO, RM_F, RM_RF, TEST_F, TOUCH, CP, MV, CHMOD, UMASK_NULL
+
+=cut
+
+sub init_others { # --- Initialize Other Attributes
+ my($self) = shift;
+
+ # Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS}
+ # Lets look at $self->{LIBS} carefully: It may be an anon array, a string or
+ # undefined. In any case we turn it into an anon array:
+
+ # May check $Config{libs} too, thus not empty.
+ $self->{LIBS}=[''] unless $self->{LIBS};
+
+ $self->{LIBS}=[$self->{LIBS}] if ref \$self->{LIBS} eq 'SCALAR';
+ $self->{LD_RUN_PATH} = "";
+ my($libs);
+ foreach $libs ( @{$self->{LIBS}} ){
+ $libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace
+ my(@libs) = $self->extliblist($libs);
+ if ($libs[0] or $libs[1] or $libs[2]){
+ # LD_RUN_PATH now computed by ExtUtils::Liblist
+ ($self->{EXTRALIBS}, $self->{BSLOADLIBS}, $self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs;
+ last;
+ }
+ }
+
+ if ( $self->{OBJECT} ) {
+ $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g;
+ } else {
+ # init_dirscan should have found out, if we have C files
+ $self->{OBJECT} = "";
+ $self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]};
+ }
+ $self->{OBJECT} =~ s/\n+/ \\\n\t/g;
+ $self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : "";
+ $self->{PERLMAINCC} ||= '$(CC)';
+ $self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM};
+
+ # Sanity check: don't define LINKTYPE = dynamic if we're skipping
+ # the 'dynamic' section of MM. We don't have this problem with
+ # 'static', since we either must use it (%Config says we can't
+ # use dynamic loading) or the caller asked for it explicitly.
+ if (!$self->{LINKTYPE}) {
+ $self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'}
+ ? 'static'
+ : ($Config::Config{usedl} ? 'dynamic' : 'static');
+ };
+
+ # These get overridden for VMS and maybe some other systems
+ $self->{NOOP} ||= '$(SHELL) -c true';
+ $self->{FIRST_MAKEFILE} ||= "Makefile";
+ $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
+ $self->{MAKE_APERL_FILE} ||= "Makefile.aperl";
+ $self->{NOECHO} = '@' unless defined $self->{NOECHO};
+ $self->{RM_F} ||= "rm -f";
+ $self->{RM_RF} ||= "rm -rf";
+ $self->{TOUCH} ||= "touch";
+ $self->{TEST_F} ||= "test -f";
+ $self->{CP} ||= "cp";
+ $self->{MV} ||= "mv";
+ $self->{CHMOD} ||= "chmod";
+ $self->{UMASK_NULL} ||= "umask 0";
+ $self->{DEV_NULL} ||= "> /dev/null 2>&1";
+}
+
+=item install (o)
+
+Defines the install target.
+
+=cut
+
+sub install {
+ my($self, %attribs) = @_;
+ my(@m);
+
+ push @m, q{
+install :: all pure_install doc_install
+
+install_perl :: all pure_perl_install doc_perl_install
+
+install_site :: all pure_site_install doc_site_install
+
+install_ :: install_site
+ @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
+
+pure_install :: pure_$(INSTALLDIRS)_install
+
+doc_install :: doc_$(INSTALLDIRS)_install
+ }.$self->{NOECHO}.q{echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod
+
+pure__install : pure_site_install
+ @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
+
+doc__install : doc_site_install
+ @echo INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
+
+pure_perl_install ::
+ }.$self->{NOECHO}.q{$(MOD_INSTALL) \
+ read }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \
+ write }.$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \
+ $(INST_LIB) $(INSTALLPRIVLIB) \
+ $(INST_ARCHLIB) $(INSTALLARCHLIB) \
+ $(INST_BIN) $(INSTALLBIN) \
+ $(INST_SCRIPT) $(INSTALLSCRIPT) \
+ $(INST_MAN1DIR) $(INSTALLMAN1DIR) \
+ $(INST_MAN3DIR) $(INSTALLMAN3DIR)
+ }.$self->{NOECHO}.q{$(WARN_IF_OLD_PACKLIST) \
+ }.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{
+
+
+pure_site_install ::
+ }.$self->{NOECHO}.q{$(MOD_INSTALL) \
+ read }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \
+ write }.$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{ \
+ $(INST_LIB) $(INSTALLSITELIB) \
+ $(INST_ARCHLIB) $(INSTALLSITEARCH) \
+ $(INST_BIN) $(INSTALLBIN) \
+ $(INST_SCRIPT) $(INSTALLSCRIPT) \
+ $(INST_MAN1DIR) $(INSTALLMAN1DIR) \
+ $(INST_MAN3DIR) $(INSTALLMAN3DIR)
+ }.$self->{NOECHO}.q{$(WARN_IF_OLD_PACKLIST) \
+ }.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{
+
+doc_perl_install ::
+ -}.$self->{NOECHO}.q{$(DOC_INSTALL) \
+ "Module" "$(NAME)" \
+ "installed into" "$(INSTALLPRIVLIB)" \
+ LINKTYPE "$(LINKTYPE)" \
+ VERSION "$(VERSION)" \
+ EXE_FILES "$(EXE_FILES)" \
+ >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{
+
+doc_site_install ::
+ -}.$self->{NOECHO}.q{$(DOC_INSTALL) \
+ "Module" "$(NAME)" \
+ "installed into" "$(INSTALLSITELIB)" \
+ LINKTYPE "$(LINKTYPE)" \
+ VERSION "$(VERSION)" \
+ EXE_FILES "$(EXE_FILES)" \
+ >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{
+
+};
+
+ push @m, q{
+uninstall :: uninstall_from_$(INSTALLDIRS)dirs
+
+uninstall_from_perldirs ::
+ }.$self->{NOECHO}.
+ q{$(UNINSTALL) }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{
+
+uninstall_from_sitedirs ::
+ }.$self->{NOECHO}.
+ q{$(UNINSTALL) }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{
+};
+
+ join("",@m);
+}
+
+=item installbin (o)
+
+Defines targets to install EXE_FILES.
+
+=cut
+
+sub installbin {
+ my($self) = shift;
+ return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
+ return "" unless @{$self->{EXE_FILES}};
+ my(@m, $from, $to, %fromto, @to);
+ push @m, $self->dir_target(qw[$(INST_SCRIPT)]);
+ for $from (@{$self->{EXE_FILES}}) {
+ my($path)= $self->catfile('$(INST_SCRIPT)', basename($from));
+ local($_) = $path; # for backwards compatibility
+ $to = $self->libscan($path);
+ print "libscan($from) => '$to'\n" if ($Verbose >=2);
+ $fromto{$from}=$to;
+ }
+ @to = values %fromto;
+ push(@m, qq{
+EXE_FILES = @{$self->{EXE_FILES}}
+
+} . ($Is_Win32
+ ? q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
+ -e "system qq[pl2bat.bat ].shift"
+} : q{FIXIN = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::MakeMaker \
+ -e "MY->fixin(shift)"
+}).qq{
+all :: @to
+ $self->{NOECHO}\$(NOOP)
+
+realclean ::
+ $self->{RM_F} @to
+});
+
+ while (($from,$to) = each %fromto) {
+ last unless defined $from;
+ my $todir = dirname($to);
+ push @m, "
+$to: $from $self->{MAKEFILE} " . $self->catdir($todir,'.exists') . "
+ $self->{NOECHO}$self->{RM_F} $to
+ $self->{CP} $from $to
+ \$(FIXIN) $to
+ -$self->{NOECHO}\$(CHMOD) \$(PERM_RWX) $to
+";
+ }
+ join "", @m;
+}
+
+=item libscan (o)
+
+Takes a path to a file that is found by init_dirscan and returns false
+if we don't want to include this file in the library. Mainly used to
+exclude RCS, CVS, and SCCS directories from installation.
+
+=cut
+
+# ';
+
+sub libscan {
+ my($self,$path) = @_;
+ return '' if $path =~ m:\b(RCS|CVS|SCCS)\b: ;
+ $path;
+}
+
+=item linkext (o)
+
+Defines the linkext target which in turn defines the LINKTYPE.
+
+=cut
+
+sub linkext {
+ my($self, %attribs) = @_;
+ # LINKTYPE => static or dynamic or ''
+ my($linktype) = defined $attribs{LINKTYPE} ?
+ $attribs{LINKTYPE} : '$(LINKTYPE)';
+ "
+linkext :: $linktype
+ $self->{NOECHO}\$(NOOP)
+";
+}
+
+=item lsdir
+
+Takes as arguments a directory name and a regular expression. Returns
+all entries in the directory that match the regular expression.
+
+=cut
+
+sub lsdir {
+ my($self) = shift;
+ my($dir, $regex) = @_;
+ my(@ls);
+ my $dh = new DirHandle;
+ $dh->open($dir || ".") or return ();
+ @ls = $dh->read;
+ $dh->close;
+ @ls = grep(/$regex/, @ls) if $regex;
+ @ls;
+}
+
+=item macro (o)
+
+Simple subroutine to insert the macros defined by the macro attribute
+into the Makefile.
+
+=cut
+
+sub macro {
+ my($self,%attribs) = @_;
+ my(@m,$key,$val);
+ while (($key,$val) = each %attribs){
+ last unless defined $key;
+ push @m, "$key = $val\n";
+ }
+ join "", @m;
+}
+
+=item makeaperl (o)
+
+Called by staticmake. Defines how to write the Makefile to produce a
+static new perl.
+
+By default the Makefile produced includes all the static extensions in
+the perl library. (Purified versions of library files, e.g.,
+DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.)
+
+=cut
+
+sub makeaperl {
+ my($self, %attribs) = @_;
+ my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
+ @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
+ my(@m);
+ push @m, "
+# --- MakeMaker makeaperl section ---
+MAP_TARGET = $target
+FULLPERL = $self->{FULLPERL}
+";
+ return join '', @m if $self->{PARENT};
+
+ my($dir) = join ":", @{$self->{DIR}};
+
+ unless ($self->{MAKEAPERL}) {
+ push @m, q{
+$(MAP_TARGET) :: static $(MAKE_APERL_FILE)
+ $(MAKE) -f $(MAKE_APERL_FILE) $@
+
+$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
+ }.$self->{NOECHO}.q{echo Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
+ }.$self->{NOECHO}.q{$(PERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
+ Makefile.PL DIR=}, $dir, q{ \
+ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
+ MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};
+
+ foreach (@ARGV){
+ if( /\s/ ){
+ s/=(.*)/='$1'/;
+ }
+ push @m, " \\\n\t\t$_";
+ }
+# push @m, map( " \\\n\t\t$_", @ARGV );
+ push @m, "\n";
+
+ return join '', @m;
+ }
+
+
+
+ my($cccmd, $linkcmd, $lperl);
+
+
+ $cccmd = $self->const_cccmd($libperl);
+ $cccmd =~ s/^CCCMD\s*=\s*//;
+ $cccmd =~ s/\$\(INC\)/ -I$self->{PERL_INC} /;
+ $cccmd .= " $Config::Config{cccdlflags}"
+ if ($Config::Config{useshrplib} eq 'true');
+ $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/;
+
+ # The front matter of the linkcommand...
+ $linkcmd = join ' ', "\$(CC)",
+ grep($_, @Config{qw(large split ldflags ccdlflags)});
+ $linkcmd =~ s/\s+/ /g;
+ $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,;
+
+ # Which *.a files could we make use of...
+ local(%static);
+ require File::Find;
+ File::Find::find(sub {
+ return unless m/\Q$self->{LIB_EXT}\E$/;
+ return if m/^libperl/;
+ # Skip purified versions of libraries (e.g., DynaLoader_pure_p1_c0_032.a)
+ return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure";
+
+ if( exists $self->{INCLUDE_EXT} ){
+ my $found = 0;
+ my $incl;
+ my $xx;
+
+ ($xx = $File::Find::name) =~ s,.*?/auto/,,;
+ $xx =~ s,/?$_,,;
+ $xx =~ s,/,::,g;
+
+ # Throw away anything not explicitly marked for inclusion.
+ # DynaLoader is implied.
+ foreach $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
+ if( $xx eq $incl ){
+ $found++;
+ last;
+ }
+ }
+ return unless $found;
+ }
+ elsif( exists $self->{EXCLUDE_EXT} ){
+ my $excl;
+ my $xx;
+
+ ($xx = $File::Find::name) =~ s,.*?/auto/,,;
+ $xx =~ s,/?$_,,;
+ $xx =~ s,/,::,g;
+
+ # Throw away anything explicitly marked for exclusion
+ foreach $excl (@{$self->{EXCLUDE_EXT}}){
+ return if( $xx eq $excl );
+ }
+ }
+
+ # don't include the installed version of this extension. I
+ # leave this line here, although it is not necessary anymore:
+ # I patched minimod.PL instead, so that Miniperl.pm won't
+ # enclude duplicates
+
+ # Once the patch to minimod.PL is in the distribution, I can
+ # drop it
+ return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}$:;
+ use Cwd 'cwd';
+ $static{cwd() . "/" . $_}++;
+ }, grep( -d $_, @{$searchdirs || []}) );
+
+ # We trust that what has been handed in as argument, will be buildable
+ $static = [] unless $static;
+ @static{@{$static}} = (1) x @{$static};
+
+ $extra = [] unless $extra && ref $extra eq 'ARRAY';
+ for (sort keys %static) {
+ next unless /\Q$self->{LIB_EXT}\E$/;
+ $_ = dirname($_) . "/extralibs.ld";
+ push @$extra, $_;
+ }
+
+ grep(s/^/-I/, @{$perlinc || []});
+
+ $target = "perl" unless $target;
+ $tmp = "." unless $tmp;
+
+# MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we
+# regenerate the Makefiles, MAP_STATIC and the dependencies for
+# extralibs.all are computed correctly
+ push @m, "
+MAP_LINKCMD = $linkcmd
+MAP_PERLINC = @{$perlinc || []}
+MAP_STATIC = ",
+join(" \\\n\t", reverse sort keys %static), "
+
+MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
+";
+
+ if (defined $libperl) {
+ ($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/;
+ }
+ unless ($libperl && -f $lperl) { # Ilya's code...
+ my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE";
+ $libperl ||= "libperl$self->{LIB_EXT}";
+ $libperl = "$dir/$libperl";
+ $lperl ||= "libperl$self->{LIB_EXT}";
+ $lperl = "$dir/$lperl";
+
+ if (! -f $libperl and ! -f $lperl) {
+ # We did not find a static libperl. Maybe there is a shared one?
+ if ($^O eq 'solaris' or $^O eq 'sunos') {
+ $lperl = $libperl = "$dir/$Config::Config{libperl}";
+ # SUNOS ld does not take the full path to a shared library
+ $libperl = '' if $^O eq 'sunos';
+ }
+ }
+
+ print STDOUT "Warning: $libperl not found
+ If you're going to build a static perl binary, make sure perl is installed
+ otherwise ignore this warning\n"
+ unless (-f $lperl || defined($self->{PERL_SRC}));
+ }
+
+ push @m, "
+MAP_LIBPERL = $libperl
+";
+
+ push @m, "
+\$(INST_ARCHAUTODIR)/extralibs.all: \$(INST_ARCHAUTODIR)/.exists ".join(" \\\n\t", @$extra)."
+ $self->{NOECHO}$self->{RM_F} \$\@
+ $self->{NOECHO}\$(TOUCH) \$\@
+";
+
+ my $catfile;
+ foreach $catfile (@$extra){
+ push @m, "\tcat $catfile >> \$\@\n";
+ }
+ # SUNOS ld does not take the full path to a shared library
+ my $llibperl = ($libperl)?'$(MAP_LIBPERL)':'-lperl';
+
+ # Brain dead solaris linker does not use LD_RUN_PATH?
+ # This fixes dynamic extensions which need shared libs
+ my $ldfrom = ($^O eq 'solaris')?
+ join(' ', map "-R$_", split /:/, $self->{LD_RUN_PATH}):'';
+
+push @m, "
+\$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all
+ \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom \$(MAP_STATIC) $llibperl `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS)
+ $self->{NOECHO}echo 'To install the new \"\$(MAP_TARGET)\" binary, call'
+ $self->{NOECHO}echo ' make -f $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)'
+ $self->{NOECHO}echo 'To remove the intermediate files say'
+ $self->{NOECHO}echo ' make -f $makefilename map_clean'
+
+$tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c
+";
+ push @m, "\tcd $tmp && $cccmd -I\$(PERL_INC) perlmain.c\n";
+
+ push @m, qq{
+$tmp/perlmain.c: $makefilename}, q{
+ }.$self->{NOECHO}.q{echo Writing $@
+ }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -MExtUtils::Miniperl \\
+ -e "writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)" > $@t && $(MV) $@t $@
+
+};
+ push @m, "\t",$self->{NOECHO}.q{$(PERL) $(INSTALLSCRIPT)/fixpmain
+} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0);
+
+
+ push @m, q{
+doc_inst_perl:
+ }.$self->{NOECHO}.q{echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod
+ -}.$self->{NOECHO}.q{$(DOC_INSTALL) \
+ "Perl binary" "$(MAP_TARGET)" \
+ MAP_STATIC "$(MAP_STATIC)" \
+ MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \
+ MAP_LIBPERL "$(MAP_LIBPERL)" \
+ >> }.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q{
+
+};
+
+ push @m, q{
+inst_perl: pure_inst_perl doc_inst_perl
+
+pure_inst_perl: $(MAP_TARGET)
+ }.$self->{CP}.q{ $(MAP_TARGET) }.$self->catfile('$(INSTALLBIN)','$(MAP_TARGET)').q{
+
+clean :: map_clean
+
+map_clean :
+ }.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all
+};
+
+ join '', @m;
+}
+
+=item makefile (o)
+
+Defines how to rewrite the Makefile.
+
+=cut
+
+sub makefile {
+ my($self) = shift;
+ my @m;
+ # We do not know what target was originally specified so we
+ # must force a manual rerun to be sure. But as it should only
+ # happen very rarely it is not a significant problem.
+ push @m, '
+$(OBJECT) : $(FIRST_MAKEFILE)
+' if $self->{OBJECT};
+
+ push @m, q{
+# We take a very conservative approach here, but it\'s worth it.
+# We move Makefile to Makefile.old here to avoid gnu make looping.
+}.$self->{MAKEFILE}.q{ : Makefile.PL $(CONFIGDEP)
+ }.$self->{NOECHO}.q{echo "Makefile out-of-date with respect to $?"
+ }.$self->{NOECHO}.q{echo "Cleaning current config before rebuilding Makefile..."
+ -}.$self->{NOECHO}.q{$(RM_F) }."$self->{MAKEFILE}.old".q{
+ -}.$self->{NOECHO}.q{$(MV) }."$self->{MAKEFILE} $self->{MAKEFILE}.old".q{
+ -$(MAKE) -f }.$self->{MAKEFILE}.q{.old clean $(DEV_NULL) || $(NOOP)
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL }.join(" ",map(qq["$_"],@ARGV)).q{
+ }.$self->{NOECHO}.q{echo "==> Your Makefile has been rebuilt. <=="
+ }.$self->{NOECHO}.q{echo "==> Please rerun the make command. <=="
+ false
+
+# To change behavior to :: would be nice, but would break Tk b9.02
+# so you find such a warning below the dist target.
+#}.$self->{MAKEFILE}.q{ :: $(VERSION_FROM)
+# }.$self->{NOECHO}.q{echo "Warning: Makefile possibly out of date with $(VERSION_FROM)"
+};
+
+ join "", @m;
+}
+
+=item manifypods (o)
+
+Defines targets and routines to translate the pods into manpages and
+put them into the INST_* directories.
+
+=cut
+
+sub manifypods {
+ my($self, %attribs) = @_;
+ return "\nmanifypods : pure_all\n\t$self->{NOECHO}\$(NOOP)\n" unless
+ %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}};
+ my($dist);
+ my($pod2man_exe);
+ if (defined $self->{PERL_SRC}) {
+ $pod2man_exe = $self->catfile($self->{PERL_SRC},'pod','pod2man');
+ } else {
+ $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man');
+ }
+ unless ($self->perl_script($pod2man_exe)) {
+ # No pod2man but some MAN3PODS to be installed
+ print <<END;
+
+Warning: I could not locate your pod2man program. Please make sure,
+ your pod2man program is in your PATH before you execute 'make'
+
+END
+ $pod2man_exe = "-S pod2man";
+ }
+ my(@m);
+ push @m,
+qq[POD2MAN_EXE = $pod2man_exe\n],
+qq[POD2MAN = \$(PERL) -we '%m=\@ARGV;for (keys %m){' \\\n],
+q[-e 'next if -e $$m{$$_} && -M $$m{$$_} < -M $$_ && -M $$m{$$_} < -M "],
+ $self->{MAKEFILE}, q[";' \\
+-e 'print "Manifying $$m{$$_}\n";' \\
+-e 'system(qq[$$^X ].q["-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" $(POD2MAN_EXE) ].qq[$$_>$$m{$$_}])==0 or warn "Couldn\\047t install $$m{$$_}\n";' \\
+-e 'chmod(oct($(PERM_RW))), $$m{$$_} or warn "chmod $(PERM_RW) $$m{$$_}: $$!\n";}'
+];
+ push @m, "\nmanifypods : pure_all ";
+ push @m, join " \\\n\t", keys %{$self->{MAN1PODS}}, keys %{$self->{MAN3PODS}};
+
+ push(@m,"\n");
+ if (%{$self->{MAN1PODS}} || %{$self->{MAN3PODS}}) {
+ push @m, "\t$self->{NOECHO}\$(POD2MAN) \\\n\t";
+ push @m, join " \\\n\t", %{$self->{MAN1PODS}}, %{$self->{MAN3PODS}};
+ }
+ join('', @m);
+}
+
+=item maybe_command
+
+Returns true, if the argument is likely to be a command.
+
+=cut
+
+sub maybe_command {
+ my($self,$file) = @_;
+ return $file if -x $file && ! -d $file;
+ return;
+}
+
+=item maybe_command_in_dirs
+
+method under development. Not yet used. Ask Ilya :-)
+
+=cut
+
+sub maybe_command_in_dirs { # $ver is optional argument if looking for perl
+# Ilya's suggestion. Not yet used, want to understand it first, but at least the code is here
+ my($self, $names, $dirs, $trace, $ver) = @_;
+ my($name, $dir);
+ foreach $dir (@$dirs){
+ next unless defined $dir; # $self->{PERL_SRC} may be undefined
+ foreach $name (@$names){
+ my($abs,$tryabs);
+ if ($self->file_name_is_absolute($name)) { # /foo/bar
+ $abs = $name;
+ } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # bar
+ $abs = $self->catfile($dir, $name);
+ } else { # foo/bar
+ $abs = $self->catfile($self->curdir, $name);
+ }
+ print "Checking $abs for $name\n" if ($trace >= 2);
+ next unless $tryabs = $self->maybe_command($abs);
+ print "Substituting $tryabs instead of $abs\n"
+ if ($trace >= 2 and $tryabs ne $abs);
+ $abs = $tryabs;
+ if (defined $ver) {
+ print "Executing $abs\n" if ($trace >= 2);
+ if (`$abs -e 'require $ver; print "VER_OK\n" ' 2>&1` =~ /VER_OK/) {
+ print "Using PERL=$abs\n" if $trace;
+ return $abs;
+ }
+ } else { # Do not look for perl
+ return $abs;
+ }
+ }
+ }
+}
+
+=item needs_linking (o)
+
+Does this module need linking? Looks into subdirectory objects (see
+also has_link_code())
+
+=cut
+
+sub needs_linking {
+ my($self) = shift;
+ my($child,$caller);
+ $caller = (caller(0))[3];
+ Carp::confess("Needs_linking called too early") if $caller =~ /^ExtUtils::MakeMaker::/;
+ return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING};
+ if ($self->has_link_code or $self->{MAKEAPERL}){
+ $self->{NEEDS_LINKING} = 1;
+ return 1;
+ }
+ foreach $child (keys %{$self->{CHILDREN}}) {
+ if ($self->{CHILDREN}->{$child}->needs_linking) {
+ $self->{NEEDS_LINKING} = 1;
+ return 1;
+ }
+ }
+ return $self->{NEEDS_LINKING} = 0;
+}
+
+=item nicetext
+
+misnamed method (will have to be changed). The MM_Unix method just
+returns the argument without further processing.
+
+On VMS used to insure that colons marking targets are preceded by
+space - most Unix Makes don't need this, but it's necessary under VMS
+to distinguish the target delimiter from a colon appearing as part of
+a filespec.
+
+=cut
+
+sub nicetext {
+ my($self,$text) = @_;
+ $text;
+}
+
+=item parse_version
+
+parse a file and return what you think is $VERSION in this file set to
+
+=cut
+
+sub parse_version {
+ my($self,$parsefile) = @_;
+ my $result;
+ local *FH;
+ local $/ = "\n";
+ open(FH,$parsefile) or die "Could not open '$parsefile': $!";
+ my $inpod = 0;
+ while (<FH>) {
+ $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
+ next if $inpod;
+ chop;
+ # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/;
+ next unless /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
+ my $eval = qq{
+ package ExtUtils::MakeMaker::_version;
+ no strict;
+
+ local $1$2;
+ \$$2=undef; do {
+ $_
+ }; \$$2
+ };
+ local($^W) = 0;
+ $result = eval($eval);
+ die "Could not eval '$eval' in $parsefile: $@" if $@;
+ $result = "undef" unless defined $result;
+ last;
+ }
+ close FH;
+ return $result;
+}
+
+=item parse_abstract
+
+parse a file and return what you think is the ABSTRACT
+
+=cut
+
+sub parse_abstract {
+ my($self,$parsefile) = @_;
+ my $result;
+ local *FH;
+ local $/ = "\n";
+ open(FH,$parsefile) or die "Could not open '$parsefile': $!";
+ my $inpod = 0;
+ my $package = $self->{DISTNAME};
+ $package =~ s/-/::/;
+ while (<FH>) {
+ $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
+ next if !$inpod;
+ chop;
+ next unless /^($package\s-\s)(.*)/;
+ $result = $2;
+ last;
+ }
+ close FH;
+ return $result;
+}
+
+=item pasthru (o)
+
+Defines the string that is passed to recursive make calls in
+subdirectories.
+
+=cut
+
+sub pasthru {
+ my($self) = shift;
+ my(@m,$key);
+
+ my(@pasthru);
+ my($sep) = $Is_VMS ? ',' : '';
+ $sep .= "\\\n\t";
+
+ foreach $key (qw(LIB LIBPERL_A LINKTYPE PREFIX OPTIMIZE)){
+ push @pasthru, "$key=\"\$($key)\"";
+ }
+
+ push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n";
+ join "", @m;
+}
+
+=item path
+
+Takes no argument, returns the environment variable PATH as an array.
+
+=cut
+
+sub path {
+ my($self) = @_;
+ my $path_sep = ($Is_OS2 || $Is_Dos) ? ";" : ":";
+ my $path = $ENV{PATH};
+ $path =~ s:\\:/:g if $Is_OS2;
+ my @path = split $path_sep, $path;
+ foreach(@path) { $_ = '.' if $_ eq '' }
+ @path;
+}
+
+=item perl_script
+
+Takes one argument, a file name, and returns the file name, if the
+argument is likely to be a perl script. On MM_Unix this is true for
+any ordinary, readable file.
+
+=cut
+
+sub perl_script {
+ my($self,$file) = @_;
+ return $file if -r $file && -f _;
+ return;
+}
+
+=item perldepend (o)
+
+Defines the dependency from all *.h files that come with the perl
+distribution.
+
+=cut
+
+sub perldepend {
+ my($self) = shift;
+ my(@m);
+ push @m, q{
+# Check for unpropogated config.sh changes. Should never happen.
+# We do NOT just update config.h because that is not sufficient.
+# An out of date config.h is not fatal but complains loudly!
+$(PERL_INC)/config.h: $(PERL_SRC)/config.sh
+ -}.$self->{NOECHO}.q{echo "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; false
+
+$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh
+ }.$self->{NOECHO}.q{echo "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh"
+ cd $(PERL_SRC) && $(MAKE) lib/Config.pm
+} if $self->{PERL_SRC};
+
+ return join "", @m unless $self->needs_linking;
+
+ push @m, q{
+PERL_HDRS = \
+$(PERL_INC)/EXTERN.h $(PERL_INC)/gv.h $(PERL_INC)/pp.h \
+$(PERL_INC)/INTERN.h $(PERL_INC)/handy.h $(PERL_INC)/proto.h \
+$(PERL_INC)/XSUB.h $(PERL_INC)/hv.h $(PERL_INC)/regcomp.h \
+$(PERL_INC)/av.h $(PERL_INC)/keywords.h $(PERL_INC)/regexp.h \
+$(PERL_INC)/config.h $(PERL_INC)/mg.h $(PERL_INC)/scope.h \
+$(PERL_INC)/cop.h $(PERL_INC)/op.h $(PERL_INC)/sv.h \
+$(PERL_INC)/cv.h $(PERL_INC)/opcode.h $(PERL_INC)/unixish.h \
+$(PERL_INC)/dosish.h $(PERL_INC)/patchlevel.h $(PERL_INC)/util.h \
+$(PERL_INC)/embed.h $(PERL_INC)/perl.h $(PERL_INC)/iperlsys.h \
+$(PERL_INC)/form.h $(PERL_INC)/perly.h
+
+$(OBJECT) : $(PERL_HDRS)
+} if $self->{OBJECT};
+
+ push @m, join(" ", values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}};
+
+ join "\n", @m;
+}
+
+=item ppd
+
+Defines target that creates a PPD (Perl Package Description) file
+for a binary distribution.
+
+=cut
+
+sub ppd {
+ my($self) = @_;
+ my(@m);
+ if ($self->{ABSTRACT_FROM}){
+ $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or
+ Carp::carp "WARNING: Setting ABSTRACT via file '$self->{ABSTRACT_FROM}' failed\n";
+ }
+ my ($pack_ver) = join ",", (split (/\./, $self->{VERSION}), (0) x 4) [0 .. 3];
+ push(@m, "# Creates a PPD (Perl Package Description) for a binary distribution.\n");
+ push(@m, "ppd:\n");
+ push(@m, "\t\@\$(PERL) -e \"print qq{<SOFTPKG NAME=\\\"$self->{DISTNAME}\\\" VERSION=\\\"$pack_ver\\\">\\n}");
+ push(@m, ". qq{\\t<TITLE>$self->{DISTNAME}</TITLE>\\n}");
+ my $abstract = $self->{ABSTRACT};
+ $abstract =~ s/</&lt;/g;
+ $abstract =~ s/>/&gt;/g;
+ push(@m, ". qq{\\t<ABSTRACT>$abstract</ABSTRACT>\\n}");
+ my ($author) = $self->{AUTHOR};
+ $author =~ s/@/\\@/g;
+ push(@m, ". qq{\\t<AUTHOR>$author</AUTHOR>\\n}");
+ push(@m, ". qq{\\t<IMPLEMENTATION>\\n}");
+ my ($prereq);
+ foreach $prereq (sort keys %{$self->{PREREQ_PM}}) {
+ my $pre_req = $prereq;
+ $pre_req =~ s/::/-/g;
+ push(@m, ". qq{\\t\\t<DEPENDENCY NAME=\\\"$pre_req\\\" />\\n}");
+ }
+ push(@m, ". qq{\\t\\t<OS NAME=\\\"\$(OSNAME)\\\" />\\n}");
+ my ($bin_location) = $self->{BINARY_LOCATION};
+ $bin_location =~ s/\\/\\\\/g;
+ if ($self->{PPM_INSTALL_SCRIPT}) {
+ if ($self->{PPM_INSTALL_EXEC}) {
+ push(@m, " . qq{\\t\\t<INSTALL EXEC=\\\"$self->{PPM_INSTALL_EXEC}\\\">$self->{PPM_INSTALL_SCRIPT}</INSTALL>\\n}");
+ }
+ else {
+ push(@m, " . qq{\\t\\t<INSTALL>$self->{PPM_INSTALL_SCRIPT}</INSTALL>\\n}");
+ }
+ }
+ push(@m, ". qq{\\t\\t<CODEBASE HREF=\\\"$bin_location\\\" />\\n}");
+ push(@m, ". qq{\\t</IMPLEMENTATION>\\n}");
+ push(@m, ". qq{</SOFTPKG>\\n}\" > $self->{DISTNAME}.ppd");
+
+ join("", @m);
+}
+
+=item perm_rw (o)
+
+Returns the attribute C<PERM_RW> or the string C<644>.
+Used as the string that is passed
+to the C<chmod> command to set the permissions for read/writeable files.
+MakeMaker chooses C<644> because it has turned out in the past that
+relying on the umask provokes hard-to-track bugreports.
+When the return value is used by the perl function C<chmod>, it is
+interpreted as an octal value.
+
+=cut
+
+sub perm_rw {
+ shift->{PERM_RW} || "644";
+}
+
+=item perm_rwx (o)
+
+Returns the attribute C<PERM_RWX> or the string C<755>,
+i.e. the string that is passed
+to the C<chmod> command to set the permissions for executable files.
+See also perl_rw.
+
+=cut
+
+sub perm_rwx {
+ shift->{PERM_RWX} || "755";
+}
+
+=item pm_to_blib
+
+Defines target that copies all files in the hash PM to their
+destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION>
+
+=cut
+
+sub pm_to_blib {
+ my $self = shift;
+ my($autodir) = $self->catdir('$(INST_LIB)','auto');
+ return q{
+pm_to_blib: $(TO_INST_PM)
+ }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \
+ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \
+ -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{')"
+ }.$self->{NOECHO}.q{$(TOUCH) $@
+};
+}
+
+=item post_constants (o)
+
+Returns an empty string per default. Dedicated to overrides from
+within Makefile.PL after all constants have been defined.
+
+=cut
+
+sub post_constants{
+ my($self) = shift;
+ "";
+}
+
+=item post_initialize (o)
+
+Returns an empty string per default. Used in Makefile.PLs to add some
+chunk of text to the Makefile after the object is initialized.
+
+=cut
+
+sub post_initialize {
+ my($self) = shift;
+ "";
+}
+
+=item postamble (o)
+
+Returns an empty string. Can be used in Makefile.PLs to write some
+text to the Makefile at the end.
+
+=cut
+
+sub postamble {
+ my($self) = shift;
+ "";
+}
+
+=item prefixify
+
+Check a path variable in $self from %Config, if it contains a prefix,
+and replace it with another one.
+
+Takes as arguments an attribute name, a search prefix and a
+replacement prefix. Changes the attribute in the object.
+
+=cut
+
+sub prefixify {
+ my($self,$var,$sprefix,$rprefix) = @_;
+ $self->{uc $var} ||= $Config{lc $var};
+ $self->{uc $var} = VMS::Filespec::unixpath($self->{uc $var}) if $Is_VMS;
+ $self->{uc $var} =~ s/\Q$sprefix\E/$rprefix/;
+}
+
+=item processPL (o)
+
+Defines targets to run *.PL files.
+
+=cut
+
+sub processPL {
+ my($self) = shift;
+ return "" unless $self->{PL_FILES};
+ my(@m, $plfile);
+ foreach $plfile (sort keys %{$self->{PL_FILES}}) {
+ push @m, "
+all :: $self->{PL_FILES}->{$plfile}
+ $self->{NOECHO}\$(NOOP)
+
+$self->{PL_FILES}->{$plfile} :: $plfile
+ \$(PERL) -I\$(INST_ARCHLIB) -I\$(INST_LIB) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) $plfile
+";
+ }
+ join "", @m;
+}
+
+=item realclean (o)
+
+Defines the realclean target.
+
+=cut
+
+sub realclean {
+ my($self, %attribs) = @_;
+ my(@m);
+ push(@m,'
+# Delete temporary files (via clean) and also delete installed files
+realclean purge :: clean
+');
+ # realclean subdirectories first (already cleaned)
+ my $sub = "\t-cd %s && \$(TEST_F) %s && \$(MAKE) %s realclean\n";
+ foreach(@{$self->{DIR}}){
+ push(@m, sprintf($sub,$_,"$self->{MAKEFILE}.old","-f $self->{MAKEFILE}.old"));
+ push(@m, sprintf($sub,$_,"$self->{MAKEFILE}",''));
+ }
+ push(@m, " $self->{RM_RF} \$(INST_AUTODIR) \$(INST_ARCHAUTODIR)\n");
+ if( $self->has_link_code ){
+ push(@m, " $self->{RM_F} \$(INST_DYNAMIC) \$(INST_BOOT)\n");
+ push(@m, " $self->{RM_F} \$(INST_STATIC)\n");
+ }
+ push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n")
+ if keys %{$self->{PM}};
+ my(@otherfiles) = ($self->{MAKEFILE},
+ "$self->{MAKEFILE}.old"); # Makefiles last
+ push(@otherfiles, $attribs{FILES}) if $attribs{FILES};
+ push(@m, " $self->{RM_RF} @otherfiles\n") if @otherfiles;
+ push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP};
+ join("", @m);
+}
+
+=item replace_manpage_separator
+
+Takes the name of a package, which may be a nested package, in the
+form Foo/Bar and replaces the slash with C<::>. Returns the replacement.
+
+=cut
+
+sub replace_manpage_separator {
+ my($self,$man) = @_;
+ $man =~ s,/+,::,g;
+ $man;
+}
+
+=item static (o)
+
+Defines the static target.
+
+=cut
+
+sub static {
+# --- Static Loading Sections ---
+
+ my($self) = shift;
+ '
+## $(INST_PM) has been moved to the all: target.
+## It remains here for awhile to allow for old usage: "make static"
+#static :: '.$self->{MAKEFILE}.' $(INST_STATIC) $(INST_PM)
+static :: '.$self->{MAKEFILE}.' $(INST_STATIC)
+ '.$self->{NOECHO}.'$(NOOP)
+';
+}
+
+=item static_lib (o)
+
+Defines how to produce the *.a (or equivalent) files.
+
+=cut
+
+sub static_lib {
+ my($self) = @_;
+# Come to think of it, if there are subdirs with linkcode, we still have no INST_STATIC
+# return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code;
+
+ my(@m);
+ push(@m, <<'END');
+$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)/.exists
+ $(RM_RF) $@
+END
+ # If this extension has it's own library (eg SDBM_File)
+ # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
+ push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB};
+
+ push @m,
+q{ $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
+ $(CHMOD) $(PERM_RWX) $@
+ }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld
+};
+ # Old mechanism - still available:
+ push @m,
+"\t$self->{NOECHO}".q{echo "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs
+} if $self->{PERL_SRC} && $self->{EXTRALIBS};
+ push @m, "\n";
+
+ push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
+ join('', "\n",@m);
+}
+
+=item staticmake (o)
+
+Calls makeaperl.
+
+=cut
+
+sub staticmake {
+ my($self, %attribs) = @_;
+ my(@static);
+
+ my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP}, $self->{INST_ARCHLIB});
+
+ # And as it's not yet built, we add the current extension
+ # but only if it has some C code (or XS code, which implies C code)
+ if (@{$self->{C}}) {
+ @static = $self->catfile($self->{INST_ARCHLIB},
+ "auto",
+ $self->{FULLEXT},
+ "$self->{BASEEXT}$self->{LIB_EXT}"
+ );
+ }
+
+ # Either we determine now, which libraries we will produce in the
+ # subdirectories or we do it at runtime of the make.
+
+ # We could ask all subdir objects, but I cannot imagine, why it
+ # would be necessary.
+
+ # Instead we determine all libraries for the new perl at
+ # runtime.
+ my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB});
+
+ $self->makeaperl(MAKE => $self->{MAKEFILE},
+ DIRS => \@searchdirs,
+ STAT => \@static,
+ INCL => \@perlinc,
+ TARGET => $self->{MAP_TARGET},
+ TMP => "",
+ LIBPERL => $self->{LIBPERL_A}
+ );
+}
+
+=item subdir_x (o)
+
+Helper subroutine for subdirs
+
+=cut
+
+sub subdir_x {
+ my($self, $subdir) = @_;
+ my(@m);
+ qq{
+
+subdirs ::
+ $self->{NOECHO}cd $subdir && \$(MAKE) all \$(PASTHRU)
+
+};
+}
+
+=item subdirs (o)
+
+Defines targets to process subdirectories.
+
+=cut
+
+sub subdirs {
+# --- Sub-directory Sections ---
+ my($self) = shift;
+ my(@m,$dir);
+ # This method provides a mechanism to automatically deal with
+ # subdirectories containing further Makefile.PL scripts.
+ # It calls the subdir_x() method for each subdirectory.
+ foreach $dir (@{$self->{DIR}}){
+ push(@m, $self->subdir_x($dir));
+#### print "Including $dir subdirectory\n";
+ }
+ if (@m){
+ unshift(@m, "
+# The default clean, realclean and test targets in this Makefile
+# have automatically been given entries for each subdir.
+
+");
+ } else {
+ push(@m, "\n# none")
+ }
+ join('',@m);
+}
+
+=item test (o)
+
+Defines the test targets.
+
+=cut
+
+sub test {
+# --- Test and Installation Sections ---
+
+ my($self, %attribs) = @_;
+ my $tests = $attribs{TESTS};
+ if (!$tests && -d 't') {
+ $tests = $Is_Win32 ? join(' ', <t\\*.t>) : 't/*.t';
+ }
+ # note: 'test.pl' name is also hardcoded in init_dirscan()
+ my(@m);
+ push(@m,"
+TEST_VERBOSE=0
+TEST_TYPE=test_\$(LINKTYPE)
+TEST_FILE = test.pl
+TEST_FILES = $tests
+TESTDB_SW = -d
+
+testdb :: testdb_\$(LINKTYPE)
+
+test :: \$(TEST_TYPE)
+");
+ push(@m, map("\t$self->{NOECHO}cd $_ && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) test \$(PASTHRU)\n",
+ @{$self->{DIR}}));
+ push(@m, "\t$self->{NOECHO}echo 'No tests defined for \$(NAME) extension.'\n")
+ unless $tests or -f "test.pl" or @{$self->{DIR}};
+ push(@m, "\n");
+
+ push(@m, "test_dynamic :: pure_all\n");
+ push(@m, $self->test_via_harness('$(FULLPERL)', '$(TEST_FILES)')) if $tests;
+ push(@m, $self->test_via_script('$(FULLPERL)', '$(TEST_FILE)')) if -f "test.pl";
+ push(@m, "\n");
+
+ push(@m, "testdb_dynamic :: pure_all\n");
+ push(@m, $self->test_via_script('$(FULLPERL) $(TESTDB_SW)', '$(TEST_FILE)'));
+ push(@m, "\n");
+
+ # Occasionally we may face this degenerate target:
+ push @m, "test_ : test_dynamic\n\n";
+
+ if ($self->needs_linking()) {
+ push(@m, "test_static :: pure_all \$(MAP_TARGET)\n");
+ push(@m, $self->test_via_harness('./$(MAP_TARGET)', '$(TEST_FILES)')) if $tests;
+ push(@m, $self->test_via_script('./$(MAP_TARGET)', '$(TEST_FILE)')) if -f "test.pl";
+ push(@m, "\n");
+ push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n");
+ push(@m, $self->test_via_script('./$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)'));
+ push(@m, "\n");
+ } else {
+ push @m, "test_static :: test_dynamic\n";
+ push @m, "testdb_static :: testdb_dynamic\n";
+ }
+ join("", @m);
+}
+
+=item test_via_harness (o)
+
+Helper method to write the test targets
+
+=cut
+
+sub test_via_harness {
+ my($self, $perl, $tests) = @_;
+ $perl = "PERL_DL_NONLAZY=1 $perl" unless $Is_Win32;
+ "\t$perl".q! -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;' !."$tests\n";
+}
+
+=item test_via_script (o)
+
+Other helper method for test.
+
+=cut
+
+sub test_via_script {
+ my($self, $perl, $script) = @_;
+ $perl = "PERL_DL_NONLAZY=1 $perl" unless $Is_Win32;
+ qq{\t$perl}.q{ -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) }.qq{$script
+};
+}
+
+=item tool_autosplit (o)
+
+Defines a simple perl call that runs autosplit. May be deprecated by
+pm_to_blib soon.
+
+=cut
+
+sub tool_autosplit {
+# --- Tool Sections ---
+
+ my($self, %attribs) = @_;
+ my($asl) = "";
+ $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN};
+ q{
+# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
+AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e 'use AutoSplit;}.$asl.q{autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1) ;'
+};
+}
+
+=item tools_other (o)
+
+Defines SHELL, LD, TOUCH, CP, MV, RM_F, RM_RF, CHMOD, UMASK_NULL in
+the Makefile. Also defines the perl programs MKPATH,
+WARN_IF_OLD_PACKLIST, MOD_INSTALL. DOC_INSTALL, and UNINSTALL.
+
+=cut
+
+sub tools_other {
+ my($self) = shift;
+ my @m;
+ my $bin_sh = $Config{sh} || '/bin/sh';
+ push @m, qq{
+SHELL = $bin_sh
+};
+
+ for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TEST_F TOUCH UMASK_NULL DEV_NULL/ ) {
+ push @m, "$_ = $self->{$_}\n";
+ }
+
+ push @m, q{
+# The following is a portable way to say mkdir -p
+# To see which directories are created, change the if 0 to if 1
+MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath
+
+# This helps us to minimize the effect of the .exists files A yet
+# better solution would be to have a stable file in the perl
+# distribution with a timestamp of zero. But this solution doesn't
+# need any changes to the core distribution and works with older perls
+EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime
+};
+
+
+ return join "", @m if $self->{PARENT};
+
+ push @m, q{
+# Here we warn users that an old packlist file was found somewhere,
+# and that they should call some uninstall routine
+WARN_IF_OLD_PACKLIST = $(PERL) -we 'exit unless -f $$ARGV[0];' \\
+-e 'print "WARNING: I have found an old package in\n";' \\
+-e 'print "\t$$ARGV[0].\n";' \\
+-e 'print "Please make sure the two installations are not conflicting\n";'
+
+UNINST=0
+VERBINST=1
+
+MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \
+-e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');"
+
+DOC_INSTALL = $(PERL) -e '$$\="\n\n";' \
+-e 'print "=head2 ", scalar(localtime), ": C<", shift, ">", " L<", shift, ">";' \
+-e 'print "=over 4";' \
+-e 'while (defined($$key = shift) and defined($$val = shift)){print "=item *";print "C<$$key: $$val>";}' \
+-e 'print "=back";'
+
+UNINSTALL = $(PERL) -MExtUtils::Install \
+-e 'uninstall($$ARGV[0],1,1); print "\nUninstall is deprecated. Please check the";' \
+-e 'print " packlist above carefully.\n There may be errors. Remove the";' \
+-e 'print " appropriate files manually.\n Sorry for the inconveniences.\n"'
+};
+
+ return join "", @m;
+}
+
+=item tool_xsubpp (o)
+
+Determines typemaps, xsubpp version, prototype behaviour.
+
+=cut
+
+sub tool_xsubpp {
+ my($self) = shift;
+ return "" unless $self->needs_linking;
+ my($xsdir) = $self->catdir($self->{PERL_LIB},"ExtUtils");
+ my(@tmdeps) = $self->catdir('$(XSUBPPDIR)','typemap');
+ if( $self->{TYPEMAPS} ){
+ my $typemap;
+ foreach $typemap (@{$self->{TYPEMAPS}}){
+ if( ! -f $typemap ){
+ warn "Typemap $typemap not found.\n";
+ }
+ else{
+ push(@tmdeps, $typemap);
+ }
+ }
+ }
+ push(@tmdeps, "typemap") if -f "typemap";
+ my(@tmargs) = map("-typemap $_", @tmdeps);
+ if( exists $self->{XSOPT} ){
+ unshift( @tmargs, $self->{XSOPT} );
+ }
+
+
+ my $xsubpp_version = $self->xsubpp_version($self->catfile($xsdir,"xsubpp"));
+
+ # What are the correct thresholds for version 1 && 2 Paul?
+ if ( $xsubpp_version > 1.923 ){
+ $self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG};
+ } else {
+ if (defined $self->{XSPROTOARG} && $self->{XSPROTOARG} =~ /\-prototypes/) {
+ print STDOUT qq{Warning: This extension wants to pass the switch "-prototypes" to xsubpp.
+ Your version of xsubpp is $xsubpp_version and cannot handle this.
+ Please upgrade to a more recent version of xsubpp.
+};
+ } else {
+ $self->{XSPROTOARG} = "";
+ }
+ }
+
+ $xsubpp = $self->{CAPI} ? "xsubpp -object_capi" : "xsubpp";
+
+ return qq{
+XSUBPPDIR = $xsdir
+XSUBPP = \$(XSUBPPDIR)/$xsubpp
+XSPROTOARG = $self->{XSPROTOARG}
+XSUBPPDEPS = @tmdeps
+XSUBPPARGS = @tmargs
+};
+};
+
+sub xsubpp_version
+{
+ my($self,$xsubpp) = @_;
+ return $Xsubpp_Version if defined $Xsubpp_Version; # global variable
+
+ my ($version) ;
+
+ # try to figure out the version number of the xsubpp on the system
+
+ # first try the -v flag, introduced in 1.921 & 2.000a2
+
+ return "" unless $self->needs_linking;
+
+ my $command = "$self->{PERL} -I$self->{PERL_LIB} $xsubpp -v 2>&1";
+ print "Running $command\n" if $Verbose >= 2;
+ $version = `$command` ;
+ warn "Running '$command' exits with status " . ($?>>8) if $?;
+ chop $version ;
+
+ return $Xsubpp_Version = $1 if $version =~ /^xsubpp version (.*)/ ;
+
+ # nope, then try something else
+
+ my $counter = '000';
+ my ($file) = 'temp' ;
+ $counter++ while -e "$file$counter"; # don't overwrite anything
+ $file .= $counter;
+
+ open(F, ">$file") or die "Cannot open file '$file': $!\n" ;
+ print F <<EOM ;
+MODULE = fred PACKAGE = fred
+
+int
+fred(a)
+ int a;
+EOM
+
+ close F ;
+
+ $command = "$self->{PERL} $xsubpp $file 2>&1";
+ print "Running $command\n" if $Verbose >= 2;
+ my $text = `$command` ;
+ warn "Running '$command' exits with status " . ($?>>8) if $?;
+ unlink $file ;
+
+ # gets 1.2 -> 1.92 and 2.000a1
+ return $Xsubpp_Version = $1 if $text =~ /automatically by xsubpp version ([\S]+)\s*/ ;
+
+ # it is either 1.0 or 1.1
+ return $Xsubpp_Version = 1.1 if $text =~ /^Warning: ignored semicolon/ ;
+
+ # none of the above, so 1.0
+ return $Xsubpp_Version = "1.0" ;
+}
+
+=item top_targets (o)
+
+Defines the targets all, subdirs, config, and O_FILES
+
+=cut
+
+sub top_targets {
+# --- Target Sections ---
+
+ my($self) = shift;
+ my(@m);
+ push @m, '
+#all :: config $(INST_PM) subdirs linkext manifypods
+';
+
+ push @m, '
+all :: pure_all manifypods
+ '.$self->{NOECHO}.'$(NOOP)
+'
+ unless $self->{SKIPHASH}{'all'};
+
+ push @m, '
+pure_all :: config pm_to_blib subdirs linkext
+ '.$self->{NOECHO}.'$(NOOP)
+
+subdirs :: $(MYEXTLIB)
+ '.$self->{NOECHO}.'$(NOOP)
+
+config :: '.$self->{MAKEFILE}.' $(INST_LIBDIR)/.exists
+ '.$self->{NOECHO}.'$(NOOP)
+
+config :: $(INST_ARCHAUTODIR)/.exists
+ '.$self->{NOECHO}.'$(NOOP)
+
+config :: $(INST_AUTODIR)/.exists
+ '.$self->{NOECHO}.'$(NOOP)
+';
+
+ push @m, qq{
+config :: Version_check
+ $self->{NOECHO}\$(NOOP)
+
+} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC};
+
+ push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]);
+
+ if (%{$self->{MAN1PODS}}) {
+ push @m, qq[
+config :: \$(INST_MAN1DIR)/.exists
+ $self->{NOECHO}\$(NOOP)
+
+];
+ push @m, $self->dir_target(qw[$(INST_MAN1DIR)]);
+ }
+ if (%{$self->{MAN3PODS}}) {
+ push @m, qq[
+config :: \$(INST_MAN3DIR)/.exists
+ $self->{NOECHO}\$(NOOP)
+
+];
+ push @m, $self->dir_target(qw[$(INST_MAN3DIR)]);
+ }
+
+ push @m, '
+$(O_FILES): $(H_FILES)
+' if @{$self->{O_FILES} || []} && @{$self->{H} || []};
+
+ push @m, q{
+help:
+ perldoc ExtUtils::MakeMaker
+};
+
+ push @m, q{
+Version_check:
+ }.$self->{NOECHO}.q{$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
+ -MExtUtils::MakeMaker=Version_check \
+ -e "Version_check('$(MM_VERSION)')"
+};
+
+ join('',@m);
+}
+
+=item writedoc
+
+Obsolete, depecated method. Not used since Version 5.21.
+
+=cut
+
+sub writedoc {
+# --- perllocal.pod section ---
+ my($self,$what,$name,@attribs)=@_;
+ my $time = localtime;
+ print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n";
+ print join "\n\n=item *\n\n", map("C<$_>",@attribs);
+ print "\n\n=back\n\n";
+}
+
+=item xs_c (o)
+
+Defines the suffix rules to compile XS files to C.
+
+=cut
+
+sub xs_c {
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+.xs.c:
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >$*.tc && $(MV) $*.tc $@
+';
+}
+
+=item xs_o (o)
+
+Defines suffix rules to go from XS to object files directly. This is
+only intended for broken make implementations.
+
+=cut
+
+sub xs_o { # many makes are too dumb to use xs_c then c_o
+ my($self) = shift;
+ return '' unless $self->needs_linking();
+ '
+.xs$(OBJ_EXT):
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && $(MV) xstmp.c $*.c
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
+';
+}
+
+=item perl_archive
+
+This is internal method that returns path to libperl.a equivalent
+to be linked to dynamic extensions. UNIX does not have one but OS2
+and Win32 do.
+
+=cut
+
+sub perl_archive
+{
+ return "";
+}
+
+=item export_list
+
+This is internal method that returns name of a file that is
+passed to linker to define symbols to be exported.
+UNIX does not have one but OS2 and Win32 do.
+
+=cut
+
+sub export_list
+{
+ return "";
+}
+
+
+1;
+
+=back
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker>
+
+=cut
+
+__END__
diff --git a/contrib/perl5/lib/ExtUtils/MM_VMS.pm b/contrib/perl5/lib/ExtUtils/MM_VMS.pm
new file mode 100644
index 000000000000..d7e59c2b8e73
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/MM_VMS.pm
@@ -0,0 +1,2391 @@
+# MM_VMS.pm
+# MakeMaker default methods for VMS
+# This package is inserted into @ISA of MakeMaker's MM before the
+# built-in ExtUtils::MM_Unix methods if MakeMaker.pm is run under VMS.
+#
+# Author: Charles Bailey bailey@genetics.upenn.edu
+
+package ExtUtils::MM_VMS;
+
+use Carp qw( &carp );
+use Config;
+require Exporter;
+use VMS::Filespec;
+use File::Basename;
+
+use vars qw($Revision);
+$Revision = '5.42 (31-Mar-1997)';
+
+unshift @MM::ISA, 'ExtUtils::MM_VMS';
+
+Exporter::import('ExtUtils::MakeMaker', '$Verbose', '&neatvalue');
+
+=head1 NAME
+
+ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+ use ExtUtils::MM_VMS; # Done internally by ExtUtils::MakeMaker if needed
+
+=head1 DESCRIPTION
+
+See ExtUtils::MM_Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=head2 Methods always loaded
+
+=over
+
+=item eliminate_macros
+
+Expands MM[KS]/Make macros in a text string, using the contents of
+identically named elements of C<%$self>, and returns the result
+as a file specification in Unix syntax.
+
+=cut
+
+sub eliminate_macros {
+ my($self,$path) = @_;
+ unless ($path) {
+ print "eliminate_macros('') = ||\n" if $Verbose >= 3;
+ return '';
+ }
+ my($npath) = unixify($path);
+ my($complex) = 0;
+ my($head,$macro,$tail);
+
+ # perform m##g in scalar context so it acts as an iterator
+ while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#g) {
+ if ($self->{$2}) {
+ ($head,$macro,$tail) = ($1,$2,$3);
+ if (ref $self->{$macro}) {
+ if (ref $self->{$macro} eq 'ARRAY') {
+ print "Note: expanded array macro \$($macro) in $path\n" if $Verbose;
+ $macro = join ' ', @{$self->{$macro}};
+ }
+ else {
+ print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
+ "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
+ $macro = "\cB$macro\cB";
+ $complex = 1;
+ }
+ }
+ else { ($macro = unixify($self->{$macro})) =~ s#/$##; }
+ $npath = "$head$macro$tail";
+ }
+ }
+ if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#g; }
+ print "eliminate_macros($path) = |$npath|\n" if $Verbose >= 3;
+ $npath;
+}
+
+=item fixpath
+
+Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
+in any directory specification, in order to avoid juxtaposing two
+VMS-syntax directories when MM[SK] is run. Also expands expressions which
+are all macro, so that we can tell how long the expansion is, and avoid
+overrunning DCL's command buffer when MM[KS] is running.
+
+If optional second argument has a TRUE value, then the return string is
+a VMS-syntax directory specification, if it is FALSE, the return string
+is a VMS-syntax file specification, and if it is not specified, fixpath()
+checks to see whether it matches the name of a directory in the current
+default directory, and returns a directory or file specification accordingly.
+
+=cut
+
+sub fixpath {
+ my($self,$path,$force_path) = @_;
+ unless ($path) {
+ print "eliminate_macros('') = ||\n" if $Verbose >= 3;
+ return '';
+ }
+ my($fixedpath,$prefix,$name);
+
+ if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) {
+ if ($force_path or $path =~ /(?:DIR\)|\])$/) {
+ $fixedpath = vmspath($self->eliminate_macros($path));
+ }
+ else {
+ $fixedpath = vmsify($self->eliminate_macros($path));
+ }
+ }
+ elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) {
+ my($vmspre) = $self->eliminate_macros("\$($prefix)");
+ # is it a dir or just a name?
+ $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR$/) ? vmspath($vmspre) : '';
+ $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
+ $fixedpath = vmspath($fixedpath) if $force_path;
+ }
+ else {
+ $fixedpath = $path;
+ $fixedpath = vmspath($fixedpath) if $force_path;
+ }
+ # No hints, so we try to guess
+ if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
+ $fixedpath = vmspath($fixedpath) if -d $fixedpath;
+ }
+ # Trim off root dirname if it's had other dirs inserted in front of it.
+ $fixedpath =~ s/\.000000([\]>])/$1/;
+ print "fixpath($path) = |$fixedpath|\n" if $Verbose >= 3;
+ $fixedpath;
+}
+
+=item catdir
+
+Concatenates a list of file specifications, and returns the result as a
+VMS-syntax directory specification.
+
+=cut
+
+sub catdir {
+ my($self,@dirs) = @_;
+ my($dir) = pop @dirs;
+ @dirs = grep($_,@dirs);
+ my($rslt);
+ if (@dirs) {
+ my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
+ my($spath,$sdir) = ($path,$dir);
+ $spath =~ s/.dir$//; $sdir =~ s/.dir$//;
+ $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
+ $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
+ }
+ else {
+ if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
+ else { $rslt = vmspath($dir); }
+ }
+ print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
+ $rslt;
+}
+
+=item catfile
+
+Concatenates a list of file specifications, and returns the result as a
+VMS-syntax directory specification.
+
+=cut
+
+sub catfile {
+ my($self,@files) = @_;
+ my($file) = pop @files;
+ @files = grep($_,@files);
+ my($rslt);
+ if (@files) {
+ my($path) = (@files == 1 ? $files[0] : $self->catdir(@files));
+ my($spath) = $path;
+ $spath =~ s/.dir$//;
+ if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; }
+ else {
+ $rslt = $self->eliminate_macros($spath);
+ $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
+ }
+ }
+ else { $rslt = vmsify($file); }
+ print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
+ $rslt;
+}
+
+=item wraplist
+
+Converts a list into a string wrapped at approximately 80 columns.
+
+=cut
+
+sub wraplist {
+ my($self) = shift;
+ my($line,$hlen) = ('',0);
+ my($word);
+
+ foreach $word (@_) {
+ # Perl bug -- seems to occasionally insert extra elements when
+ # traversing array (scalar(@array) doesn't show them, but
+ # foreach(@array) does) (5.00307)
+ next unless $word =~ /\w/;
+ $line .= ' ' if length($line);
+ if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; }
+ $line .= $word;
+ $hlen += length($word) + 2;
+ }
+ $line;
+}
+
+=item curdir (override)
+
+Returns a string representing of the current directory.
+
+=cut
+
+sub curdir {
+ return '[]';
+}
+
+=item rootdir (override)
+
+Returns a string representing of the root directory.
+
+=cut
+
+sub rootdir {
+ return '';
+}
+
+=item updir (override)
+
+Returns a string representing of the parent directory.
+
+=cut
+
+sub updir {
+ return '[-]';
+}
+
+package ExtUtils::MM_VMS;
+
+sub ExtUtils::MM_VMS::ext;
+sub ExtUtils::MM_VMS::guess_name;
+sub ExtUtils::MM_VMS::find_perl;
+sub ExtUtils::MM_VMS::path;
+sub ExtUtils::MM_VMS::maybe_command;
+sub ExtUtils::MM_VMS::maybe_command_in_dirs;
+sub ExtUtils::MM_VMS::perl_script;
+sub ExtUtils::MM_VMS::file_name_is_absolute;
+sub ExtUtils::MM_VMS::replace_manpage_separator;
+sub ExtUtils::MM_VMS::init_others;
+sub ExtUtils::MM_VMS::constants;
+sub ExtUtils::MM_VMS::cflags;
+sub ExtUtils::MM_VMS::const_cccmd;
+sub ExtUtils::MM_VMS::pm_to_blib;
+sub ExtUtils::MM_VMS::tool_autosplit;
+sub ExtUtils::MM_VMS::tool_xsubpp;
+sub ExtUtils::MM_VMS::xsubpp_version;
+sub ExtUtils::MM_VMS::tools_other;
+sub ExtUtils::MM_VMS::dist;
+sub ExtUtils::MM_VMS::c_o;
+sub ExtUtils::MM_VMS::xs_c;
+sub ExtUtils::MM_VMS::xs_o;
+sub ExtUtils::MM_VMS::top_targets;
+sub ExtUtils::MM_VMS::dlsyms;
+sub ExtUtils::MM_VMS::dynamic_lib;
+sub ExtUtils::MM_VMS::dynamic_bs;
+sub ExtUtils::MM_VMS::static_lib;
+sub ExtUtils::MM_VMS::manifypods;
+sub ExtUtils::MM_VMS::processPL;
+sub ExtUtils::MM_VMS::installbin;
+sub ExtUtils::MM_VMS::subdir_x;
+sub ExtUtils::MM_VMS::clean;
+sub ExtUtils::MM_VMS::realclean;
+sub ExtUtils::MM_VMS::dist_basics;
+sub ExtUtils::MM_VMS::dist_core;
+sub ExtUtils::MM_VMS::dist_dir;
+sub ExtUtils::MM_VMS::dist_test;
+sub ExtUtils::MM_VMS::install;
+sub ExtUtils::MM_VMS::perldepend;
+sub ExtUtils::MM_VMS::makefile;
+sub ExtUtils::MM_VMS::test;
+sub ExtUtils::MM_VMS::test_via_harness;
+sub ExtUtils::MM_VMS::test_via_script;
+sub ExtUtils::MM_VMS::makeaperl;
+sub ExtUtils::MM_VMS::ext;
+sub ExtUtils::MM_VMS::nicetext;
+
+#use SelfLoader;
+sub AUTOLOAD {
+ my $code;
+ if (defined fileno(DATA)) {
+ my $fh = select DATA;
+ my $o = $/; # For future reads from the file.
+ $/ = "\n__END__\n";
+ $code = <DATA>;
+ $/ = $o;
+ select $fh;
+ close DATA;
+ eval $code;
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ Carp::croak $@;
+ }
+ } else {
+ warn "AUTOLOAD called unexpectedly for $AUTOLOAD";
+ }
+ defined(&$AUTOLOAD) or die "Myloader inconsistency error";
+ goto &$AUTOLOAD;
+}
+
+1;
+
+#__DATA__
+
+
+# This isn't really an override. It's just here because ExtUtils::MM_VMS
+# appears in @MM::ISA before ExtUtils::Liblist, so if there isn't an ext()
+# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just
+# mimic inheritance here and hand off to ExtUtils::Liblist.
+sub ext {
+ ExtUtils::Liblist::ext(@_);
+}
+
+=back
+
+=head2 SelfLoaded methods
+
+Those methods which override default MM_Unix methods are marked
+"(override)", while methods unique to MM_VMS are marked "(specific)".
+For overridden methods, documentation is limited to an explanation
+of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix
+documentation for more details.
+
+=over
+
+=item guess_name (override)
+
+Try to determine name of extension being built. We begin with the name
+of the current directory. Since VMS filenames are case-insensitive,
+however, we look for a F<.pm> file whose name matches that of the current
+directory (presumably the 'main' F<.pm> file for this extension), and try
+to find a C<package> statement from which to obtain the Mixed::Case
+package name.
+
+=cut
+
+sub guess_name {
+ my($self) = @_;
+ my($defname,$defpm,@pm,%xs,$pm);
+ local *PM;
+
+ $defname = basename(fileify($ENV{'DEFAULT'}));
+ $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version
+ $defpm = $defname;
+ # Fallback in case for some reason a user has copied the files for an
+ # extension into a working directory whose name doesn't reflect the
+ # extension's name. We'll use the name of a unique .pm file, or the
+ # first .pm file with a matching .xs file.
+ if (not -e "${defpm}.pm") {
+ @pm = map { s/.pm$//; $_ } glob('*.pm');
+ if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; }
+ elsif (@pm) {
+ %xs = map { s/.xs$//; ($_,1) } glob('*.xs');
+ if (%xs) { foreach $pm (@pm) { $defpm = $pm, last if exists $xs{$pm}; } }
+ }
+ }
+ if (open(PM,"${defpm}.pm")){
+ while (<PM>) {
+ if (/^\s*package\s+([^;]+)/i) {
+ $defname = $1;
+ last;
+ }
+ }
+ print STDOUT "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t",
+ "defaulting package name to $defname\n"
+ if eof(PM);
+ close PM;
+ }
+ else {
+ print STDOUT "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t",
+ "defaulting package name to $defname\n";
+ }
+ $defname =~ s#[\d.\-_]+$##;
+ $defname;
+}
+
+=item find_perl (override)
+
+Use VMS file specification syntax and CLI commands to find and
+invoke Perl images.
+
+=cut
+
+sub find_perl {
+ my($self, $ver, $names, $dirs, $trace) = @_;
+ my($name,$dir,$vmsfile,@sdirs,@snames,@cand);
+ my($inabs) = 0;
+ # Check in relative directories first, so we pick up the current
+ # version of Perl if we're running MakeMaker as part of the main build.
+ @sdirs = sort { my($absa) = $self->file_name_is_absolute($a);
+ my($absb) = $self->file_name_is_absolute($b);
+ if ($absa && $absb) { return $a cmp $b }
+ else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); }
+ } @$dirs;
+ # Check miniperl before perl, and check names likely to contain
+ # version numbers before "generic" names, so we pick up an
+ # executable that's less likely to be from an old installation.
+ @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename
+ my($bb) = $b =~ m!([^:>\]/]+)$!;
+ my($ahasdir) = (length($a) - length($ba) > 0);
+ my($bhasdir) = (length($b) - length($bb) > 0);
+ if ($ahasdir and not $bhasdir) { return 1; }
+ elsif ($bhasdir and not $ahasdir) { return -1; }
+ else { $bb =~ /\d/ <=> $ba =~ /\d/
+ or substr($ba,0,1) cmp substr($bb,0,1)
+ or length($bb) <=> length($ba) } } @$names;
+ # Image names containing Perl version use '_' instead of '.' under VMS
+ foreach $name (@snames) { $name =~ s/\.(\d+)$/_$1/; }
+ if ($trace >= 2){
+ print "Looking for perl $ver by these names:\n";
+ print "\t@snames,\n";
+ print "in these dirs:\n";
+ print "\t@sdirs\n";
+ }
+ foreach $dir (@sdirs){
+ next unless defined $dir; # $self->{PERL_SRC} may be undefined
+ $inabs++ if $self->file_name_is_absolute($dir);
+ if ($inabs == 1) {
+ # We've covered relative dirs; everything else is an absolute
+ # dir (probably an installed location). First, we'll try potential
+ # command names, to see whether we can avoid a long MCR expression.
+ foreach $name (@snames) { push(@cand,$name) if $name =~ /^[\w\-\$]+$/; }
+ $inabs++; # Should happen above in next $dir, but just in case . . .
+ }
+ foreach $name (@snames){
+ if ($name !~ m![/:>\]]!) { push(@cand,$self->catfile($dir,$name)); }
+ else { push(@cand,$self->fixpath($name,0)); }
+ }
+ }
+ foreach $name (@cand) {
+ print "Checking $name\n" if ($trace >= 2);
+ # If it looks like a potential command, try it without the MCR
+ if ($name =~ /^[\w\-\$]+$/ &&
+ `$name -e "require $ver; print ""VER_OK\n"""` =~ /VER_OK/) {
+ print "Using PERL=$name\n" if $trace;
+ return $name;
+ }
+ next unless $vmsfile = $self->maybe_command($name);
+ $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well
+ print "Executing $vmsfile\n" if ($trace >= 2);
+ if (`MCR $vmsfile -e "require $ver; print ""VER_OK\n"""` =~ /VER_OK/) {
+ print "Using PERL=MCR $vmsfile\n" if $trace;
+ return "MCR $vmsfile";
+ }
+ }
+ print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
+ 0; # false and not empty
+}
+
+=item path (override)
+
+Translate logical name DCL$PATH as a searchlist, rather than trying
+to C<split> string value of C<$ENV{'PATH'}>.
+
+=cut
+
+sub path {
+ my(@dirs,$dir,$i);
+ while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
+ @dirs;
+}
+
+=item maybe_command (override)
+
+Follows VMS naming conventions for executable files.
+If the name passed in doesn't exactly match an executable file,
+appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
+to check for DCL procedure. If this fails, checks directories in DCL$PATH
+and finally F<Sys$System:> for an executable file having the name specified,
+with or without the F<.Exe>-equivalent suffix.
+
+=cut
+
+sub maybe_command {
+ my($self,$file) = @_;
+ return $file if -x $file && ! -d _;
+ my(@dirs) = ('');
+ my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
+ my($dir,$ext);
+ if ($file !~ m![/:>\]]!) {
+ for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
+ $dir = $ENV{"DCL\$PATH;$i"};
+ $dir .= ':' unless $dir =~ m%[\]:]$%;
+ push(@dirs,$dir);
+ }
+ push(@dirs,'Sys$System:');
+ foreach $dir (@dirs) {
+ my $sysfile = "$dir$file";
+ foreach $ext (@exts) {
+ return $file if -x "$sysfile$ext" && ! -d _;
+ }
+ }
+ }
+ return 0;
+}
+
+=item maybe_command_in_dirs (override)
+
+Uses DCL argument quoting on test command line.
+
+=cut
+
+sub maybe_command_in_dirs { # $ver is optional argument if looking for perl
+ my($self, $names, $dirs, $trace, $ver) = @_;
+ my($name, $dir);
+ foreach $dir (@$dirs){
+ next unless defined $dir; # $self->{PERL_SRC} may be undefined
+ foreach $name (@$names){
+ my($abs,$tryabs);
+ if ($self->file_name_is_absolute($name)) {
+ $abs = $name;
+ } else {
+ $abs = $self->catfile($dir, $name);
+ }
+ print "Checking $abs for $name\n" if ($trace >= 2);
+ next unless $tryabs = $self->maybe_command($abs);
+ print "Substituting $tryabs instead of $abs\n"
+ if ($trace >= 2 and $tryabs ne $abs);
+ $abs = $tryabs;
+ if (defined $ver) {
+ print "Executing $abs\n" if ($trace >= 2);
+ if (`$abs -e 'require $ver; print "VER_OK\n" ' 2>&1` =~ /VER_OK/) {
+ print "Using $abs\n" if $trace;
+ return $abs;
+ }
+ } else { # Do not look for perl
+ return $abs;
+ }
+ }
+ }
+}
+
+=item perl_script (override)
+
+If name passed in doesn't specify a readable file, appends F<.com> or
+F<.pl> and tries again, since it's customary to have file types on all files
+under VMS.
+
+=cut
+
+sub perl_script {
+ my($self,$file) = @_;
+ return $file if -r $file && ! -d _;
+ return "$file.com" if -r "$file.com";
+ return "$file.pl" if -r "$file.pl";
+ return '';
+}
+
+=item file_name_is_absolute (override)
+
+Checks for VMS directory spec as well as Unix separators.
+
+=cut
+
+sub file_name_is_absolute {
+ my($self,$file) = @_;
+ # If it's a logical name, expand it.
+ $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file};
+ $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/;
+}
+
+=item replace_manpage_separator
+
+Use as separator a character which is legal in a VMS-syntax file name.
+
+=cut
+
+sub replace_manpage_separator {
+ my($self,$man) = @_;
+ $man = unixify($man);
+ $man =~ s#/+#__#g;
+ $man;
+}
+
+=item init_others (override)
+
+Provide VMS-specific forms of various utility commands, then hand
+off to the default MM_Unix method.
+
+=cut
+
+sub init_others {
+ my($self) = @_;
+
+ $self->{NOOP} = 'Continue';
+ $self->{FIRST_MAKEFILE} ||= 'Descrip.MMS';
+ $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS';
+ $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
+ $self->{NOECHO} ||= '@ ';
+ $self->{RM_F} = '$(PERL) -e "foreach (@ARGV) { 1 while ( -d $_ ? rmdir $_ : unlink $_)}"';
+ $self->{RM_RF} = '$(PERL) "-I$(PERL_LIB)" -e "use File::Path; @dirs = map(VMS::Filespec::unixify($_),@ARGV); rmtree(\@dirs,0,0)"';
+ $self->{TOUCH} = '$(PERL) -e "$t=time; foreach (@ARGV) { -e $_ ? utime($t,$t,@ARGV) : (open(F,qq(>$_)),close F)}"';
+ $self->{CHMOD} = '$(PERL) -e "chmod @ARGV"'; # expect Unix syntax from MakeMaker
+ $self->{CP} = 'Copy/NoConfirm';
+ $self->{MV} = 'Rename/NoConfirm';
+ $self->{UMASK_NULL} = '! ';
+ &ExtUtils::MM_Unix::init_others;
+}
+
+=item constants (override)
+
+Fixes up numerous file and directory macros to insure VMS syntax
+regardless of input syntax. Also adds a few VMS-specific macros
+and makes lists of files comma-separated.
+
+=cut
+
+sub constants {
+ my($self) = @_;
+ my(@m,$def,$macro);
+
+ if ($self->{DEFINE} ne '') {
+ my(@defs) = split(/\s+/,$self->{DEFINE});
+ foreach $def (@defs) {
+ next unless $def;
+ if ($def =~ s/^-D//) { # If it was a Unix-style definition
+ $def =~ s/='(.*)'$/=$1/; # then remove shell-protection ''
+ $def =~ s/^'(.*)'$/$1/; # from entire term or argument
+ }
+ if ($def =~ /=/) {
+ $def =~ s/"/""/g; # Protect existing " from DCL
+ $def = qq["$def"]; # and quote to prevent parsing of =
+ }
+ }
+ $self->{DEFINE} = join ',',@defs;
+ }
+
+ if ($self->{OBJECT} =~ /\s/) {
+ $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g;
+ $self->{OBJECT} = $self->wraplist(map($self->fixpath($_,0),split(/,?\s+/,$self->{OBJECT})));
+ }
+ $self->{LDFROM} = $self->wraplist(map($self->fixpath($_,0),split(/,?\s+/,$self->{LDFROM})));
+
+
+ # Fix up directory specs
+ $self->{ROOTEXT} = $self->{ROOTEXT} ? $self->fixpath($self->{ROOTEXT},1)
+ : '[]';
+ foreach $macro ( qw [
+ INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB INST_EXE INSTALLPRIVLIB
+ INSTALLARCHLIB INSTALLSCRIPT INSTALLBIN PERL_LIB PERL_ARCHLIB
+ PERL_INC PERL_SRC FULLEXT INST_MAN1DIR INSTALLMAN1DIR
+ INST_MAN3DIR INSTALLMAN3DIR INSTALLSITELIB INSTALLSITEARCH
+ SITELIBEXP SITEARCHEXP ] ) {
+ next unless defined $self->{$macro};
+ $self->{$macro} = $self->fixpath($self->{$macro},1);
+ }
+ $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC},q(VMS))
+ if ($self->{PERL_SRC});
+
+
+
+ # Fix up file specs
+ foreach $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKE_APERL_FILE MYEXTLIB] ) {
+ next unless defined $self->{$macro};
+ $self->{$macro} = $self->fixpath($self->{$macro},0);
+ }
+
+ foreach $macro (qw/
+ AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION VERSION_SYM XS_VERSION
+ INST_BIN INST_EXE INST_LIB INST_ARCHLIB INST_SCRIPT PREFIX
+ INSTALLDIRS INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB
+ INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
+ PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
+ FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC PERL_VMS
+ PERL_INC PERL FULLPERL
+ / ) {
+ next unless defined $self->{$macro};
+ push @m, "$macro = $self->{$macro}\n";
+ }
+
+
+ push @m, q[
+VERSION_MACRO = VERSION
+DEFINE_VERSION = "$(VERSION_MACRO)=""$(VERSION)"""
+XS_VERSION_MACRO = XS_VERSION
+XS_DEFINE_VERSION = "$(XS_VERSION_MACRO)=""$(XS_VERSION)"""
+
+MAKEMAKER = ],$self->catfile($self->{PERL_LIB},'ExtUtils','MakeMaker.pm'),qq[
+MM_VERSION = $ExtUtils::MakeMaker::VERSION
+MM_REVISION = $ExtUtils::MakeMaker::Revision
+MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision
+
+# FULLEXT = Pathname for extension directory (eg DBD/Oracle).
+# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT.
+# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
+# DLBASE = Basename part of dynamic library. May be just equal BASEEXT.
+];
+
+ for $tmp (qw/
+ FULLEXT VERSION_FROM OBJECT LDFROM
+ / ) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = ",$self->fixpath($self->{$tmp},0),"\n";
+ }
+
+ for $tmp (qw/
+ BASEEXT PARENT_NAME DLBASE INC DEFINE LINKTYPE
+ / ) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+ for $tmp (qw/ XS MAN1PODS MAN3PODS PM /) {
+ next unless defined $self->{$tmp};
+ my(%tmp,$key);
+ for $key (keys %{$self->{$tmp}}) {
+ $tmp{$self->fixpath($key,0)} = $self->fixpath($self->{$tmp}{$key},0);
+ }
+ $self->{$tmp} = \%tmp;
+ }
+
+ for $tmp (qw/ C O_FILES H /) {
+ next unless defined $self->{$tmp};
+ my(@tmp,$val);
+ for $val (@{$self->{$tmp}}) {
+ push(@tmp,$self->fixpath($val,0));
+ }
+ $self->{$tmp} = \@tmp;
+ }
+
+ push @m,'
+
+# Handy lists of source code files:
+XS_FILES = ',$self->wraplist(sort keys %{$self->{XS}}),'
+C_FILES = ',$self->wraplist(@{$self->{C}}),'
+O_FILES = ',$self->wraplist(@{$self->{O_FILES}} ),'
+H_FILES = ',$self->wraplist(@{$self->{H}}),'
+MAN1PODS = ',$self->wraplist(sort keys %{$self->{MAN1PODS}}),'
+MAN3PODS = ',$self->wraplist(sort keys %{$self->{MAN3PODS}}),'
+
+';
+
+ for $tmp (qw/
+ INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT
+ /) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+push @m,"
+.SUFFIXES :
+.SUFFIXES : \$(OBJ_EXT) .c .cpp .cxx .xs
+
+# Here is the Config.pm that we are using/depend on
+CONFIGDEP = \$(PERL_ARCHLIB)Config.pm, \$(PERL_INC)config.h \$(VERSION_FROM)
+
+# Where to put things:
+INST_LIBDIR = $self->{INST_LIBDIR}
+INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR}
+
+INST_AUTODIR = $self->{INST_AUTODIR}
+INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}
+";
+
+ if ($self->has_link_code()) {
+ push @m,'
+INST_STATIC = $(INST_ARCHAUTODIR)$(BASEEXT)$(LIB_EXT)
+INST_DYNAMIC = $(INST_ARCHAUTODIR)$(BASEEXT).$(DLEXT)
+INST_BOOT = $(INST_ARCHAUTODIR)$(BASEEXT).bs
+';
+ } else {
+ my $shr = $Config{'dbgprefix'} . 'PERLSHR';
+ push @m,'
+INST_STATIC =
+INST_DYNAMIC =
+INST_BOOT =
+EXPORT_LIST = $(BASEEXT).opt
+PERL_ARCHIVE = ',($ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}"),'
+';
+ }
+
+ $self->{TO_INST_PM} = [ sort keys %{$self->{PM}} ];
+ $self->{PM_TO_BLIB} = [ %{$self->{PM}} ];
+ push @m,'
+TO_INST_PM = ',$self->wraplist(@{$self->{TO_INST_PM}}),'
+
+PM_TO_BLIB = ',$self->wraplist(@{$self->{PM_TO_BLIB}}),'
+';
+
+ join('',@m);
+}
+
+=item cflags (override)
+
+Bypass shell script and produce qualifiers for CC directly (but warn
+user if a shell script for this extension exists). Fold multiple
+/Defines into one, since some C compilers pay attention to only one
+instance of this qualifier on the command line.
+
+=cut
+
+sub cflags {
+ my($self,$libperl) = @_;
+ my($quals) = $self->{CCFLAGS} || $Config{'ccflags'};
+ my($definestr,$undefstr,$flagoptstr) = ('','','');
+ my($incstr) = '/Include=($(PERL_INC)';
+ my($name,$sys,@m);
+
+ ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
+ print STDOUT "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}.
+ " required to modify CC command for $self->{'BASEEXT'}\n"
+ if ($Config{$name});
+
+ if ($quals =~ / -[DIUOg]/) {
+ while ($quals =~ / -([Og])(\d*)\b/) {
+ my($type,$lvl) = ($1,$2);
+ $quals =~ s/ -$type$lvl\b\s*//;
+ if ($type eq 'g') { $flagoptstr = '/NoOptimize'; }
+ else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); }
+ }
+ while ($quals =~ / -([DIU])(\S+)/) {
+ my($type,$def) = ($1,$2);
+ $quals =~ s/ -$type$def\s*//;
+ $def =~ s/"/""/g;
+ if ($type eq 'D') { $definestr .= qq["$def",]; }
+ elsif ($type eq 'I') { $flagincstr .= ',' . $self->fixpath($def,1); }
+ else { $undefstr .= qq["$def",]; }
+ }
+ }
+ if (length $quals and $quals !~ m!/!) {
+ warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n";
+ $quals = '';
+ }
+ if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; }
+ if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; }
+ # Deal with $self->{DEFINE} here since some C compilers pay attention
+ # to only one /Define clause on command line, so we have to
+ # conflate the ones from $Config{'ccflags'} and $self->{DEFINE}
+ if ($quals =~ m:(.*)/define=\(?([^\(\/\)\s]+)\)?(.*)?:i) {
+ $quals = "$1/Define=($2," . ($self->{DEFINE} ? "$self->{DEFINE}," : '') .
+ "\$(DEFINE_VERSION),\$(XS_DEFINE_VERSION))$3";
+ }
+ else {
+ $quals .= '/Define=(' . ($self->{DEFINE} ? "$self->{DEFINE}," : '') .
+ '$(DEFINE_VERSION),$(XS_DEFINE_VERSION))';
+ }
+
+ $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb";
+# This whole section is commented out, since I don't think it's necessary (or applicable)
+# if ($libperl =~ s/^$Config{'dbgprefix'}//) { $libperl =~ s/perl([^Dd]*)\./perld$1./; }
+# if ($libperl =~ /libperl(\w+)\./i) {
+# my($type) = uc $1;
+# my(%map) = ( 'D' => 'DEBUGGING', 'E' => 'EMBED', 'M' => 'MULTIPLICITY',
+# 'DE' => 'DEBUGGING,EMBED', 'DM' => 'DEBUGGING,MULTIPLICITY',
+# 'EM' => 'EMBED,MULTIPLICITY', 'DEM' => 'DEBUGGING,EMBED,MULTIPLICITY' );
+# my($add) = join(',', grep { $quals !~ /\b$_\b/ } split(/,/,$map{$type}));
+# $quals =~ s:/define=\(([^\)]+)\):/Define=($1,$add):i if $add;
+# $self->{PERLTYPE} ||= $type;
+# }
+
+ # Likewise with $self->{INC} and /Include
+ if ($self->{'INC'}) {
+ my(@includes) = split(/\s+/,$self->{INC});
+ foreach (@includes) {
+ s/^-I//;
+ $incstr .= ', '.$self->fixpath($_,1);
+ }
+ }
+ $quals .= "$incstr)";
+ $self->{CCFLAGS} = $quals;
+
+ $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'};
+ if ($self->{OPTIMIZE} !~ m!/!) {
+ if ($self->{OPTIMIZE} =~ m!\b-g\b!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' }
+ elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) {
+ $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : '');
+ }
+ else {
+ warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE};
+ $self->{OPTIMIZE} = '/Optimize';
+ }
+ }
+
+ return $self->{CFLAGS} = qq{
+CCFLAGS = $self->{CCFLAGS}
+OPTIMIZE = $self->{OPTIMIZE}
+PERLTYPE = $self->{PERLTYPE}
+SPLIT =
+LARGE =
+};
+}
+
+=item const_cccmd (override)
+
+Adds directives to point C preprocessor to the right place when
+handling #include E<lt>sys/foo.hE<gt> directives. Also constructs CC
+command line a bit differently than MM_Unix method.
+
+=cut
+
+sub const_cccmd {
+ my($self,$libperl) = @_;
+ my(@m);
+
+ return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
+ return '' unless $self->needs_linking();
+ if ($Config{'vms_cc_type'} eq 'gcc') {
+ push @m,'
+.FIRST
+ ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]';
+ }
+ elsif ($Config{'vms_cc_type'} eq 'vaxc') {
+ push @m,'
+.FIRST
+ ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library
+ ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include';
+ }
+ else {
+ push @m,'
+.FIRST
+ ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ',
+ ($Config{'arch'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),'
+ ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include';
+ }
+
+ push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n");
+
+ $self->{CONST_CCCMD} = join('',@m);
+}
+
+=item pm_to_blib (override)
+
+DCL I<still> accepts a maximum of 255 characters on a command
+line, so we write the (potentially) long list of file names
+to a temp file, then persuade Perl to read it instead of the
+command line to find args.
+
+=cut
+
+sub pm_to_blib {
+ my($self) = @_;
+ my($line,$from,$to,@m);
+ my($autodir) = $self->catdir('$(INST_LIB)','auto');
+ my(@files) = @{$self->{PM_TO_BLIB}};
+
+ push @m, q{
+
+# Dummy target to match Unix target name; we use pm_to_blib.ts as
+# timestamp file to avoid repeated invocations under VMS
+pm_to_blib : pm_to_blib.ts
+ $(NOECHO) $(NOOP)
+
+# As always, keep under DCL's 255-char limit
+pm_to_blib.ts : $(TO_INST_PM)
+ $(NOECHO) $(PERL) -e "print '},shift(@files),q{ },shift(@files),q{'" >.MM_tmp
+};
+
+ $line = ''; # avoid uninitialized var warning
+ while ($from = shift(@files),$to = shift(@files)) {
+ $line .= " $from $to";
+ if (length($line) > 128) {
+ push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n");
+ $line = '';
+ }
+ }
+ push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line;
+
+ push(@m,q[ $(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',<STDIN>)},'].$autodir.q[')" <.MM_tmp]);
+ push(@m,qq[
+ \$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
+ \$(NOECHO) \$(TOUCH) pm_to_blib.ts
+]);
+
+ join('',@m);
+}
+
+=item tool_autosplit (override)
+
+Use VMS-style quoting on command line.
+
+=cut
+
+sub tool_autosplit{
+ my($self, %attribs) = @_;
+ my($asl) = "";
+ $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN};
+ q{
+# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
+AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use AutoSplit;}.$asl.q{ AutoSplit::autosplit($ARGV[0], $ARGV[1], 0, 1, 1) ;"
+};
+}
+
+=item tool_sxubpp (override)
+
+Use VMS-style quoting on xsubpp command line.
+
+=cut
+
+sub tool_xsubpp {
+ my($self) = @_;
+ return '' unless $self->needs_linking;
+ my($xsdir) = $self->catdir($self->{PERL_LIB},'ExtUtils');
+ # drop back to old location if xsubpp is not in new location yet
+ $xsdir = $self->catdir($self->{PERL_SRC},'ext') unless (-f $self->catfile($xsdir,'xsubpp'));
+ my(@tmdeps) = '$(XSUBPPDIR)typemap';
+ if( $self->{TYPEMAPS} ){
+ my $typemap;
+ foreach $typemap (@{$self->{TYPEMAPS}}){
+ if( ! -f $typemap ){
+ warn "Typemap $typemap not found.\n";
+ }
+ else{
+ push(@tmdeps, $self->fixpath($typemap,0));
+ }
+ }
+ }
+ push(@tmdeps, "typemap") if -f "typemap";
+ my(@tmargs) = map("-typemap $_", @tmdeps);
+ if( exists $self->{XSOPT} ){
+ unshift( @tmargs, $self->{XSOPT} );
+ }
+
+ my $xsubpp_version = $self->xsubpp_version($self->catfile($xsdir,'xsubpp'));
+
+ # What are the correct thresholds for version 1 && 2 Paul?
+ if ( $xsubpp_version > 1.923 ){
+ $self->{XSPROTOARG} = '' unless defined $self->{XSPROTOARG};
+ } else {
+ if (defined $self->{XSPROTOARG} && $self->{XSPROTOARG} =~ /\-prototypes/) {
+ print STDOUT qq{Warning: This extension wants to pass the switch "-prototypes" to xsubpp.
+ Your version of xsubpp is $xsubpp_version and cannot handle this.
+ Please upgrade to a more recent version of xsubpp.
+};
+ } else {
+ $self->{XSPROTOARG} = "";
+ }
+ }
+
+ "
+XSUBPPDIR = $xsdir
+XSUBPP = \$(PERL) \"-I\$(PERL_ARCHLIB)\" \"-I\$(PERL_LIB)\" \$(XSUBPPDIR)xsubpp
+XSPROTOARG = $self->{XSPROTOARG}
+XSUBPPDEPS = @tmdeps
+XSUBPPARGS = @tmargs
+";
+}
+
+=item xsubpp_version (override)
+
+Test xsubpp exit status according to VMS rules ($sts & 1 ==E<gt> good)
+rather than Unix rules ($sts == 0 ==E<gt> good).
+
+=cut
+
+sub xsubpp_version
+{
+ my($self,$xsubpp) = @_;
+ my ($version) ;
+ return '' unless $self->needs_linking;
+
+ # try to figure out the version number of the xsubpp on the system
+
+ # first try the -v flag, introduced in 1.921 & 2.000a2
+
+ my $command = "$self->{PERL} \"-I$self->{PERL_LIB}\" $xsubpp -v";
+ print "Running: $command\n" if $Verbose;
+ $version = `$command` ;
+ if ($?) {
+ use vmsish 'status';
+ warn "Running '$command' exits with status $?";
+ }
+ chop $version ;
+
+ return $1 if $version =~ /^xsubpp version (.*)/ ;
+
+ # nope, then try something else
+
+ my $counter = '000';
+ my ($file) = 'temp' ;
+ $counter++ while -e "$file$counter"; # don't overwrite anything
+ $file .= $counter;
+
+ local(*F);
+ open(F, ">$file") or die "Cannot open file '$file': $!\n" ;
+ print F <<EOM ;
+MODULE = fred PACKAGE = fred
+
+int
+fred(a)
+ int a;
+EOM
+
+ close F ;
+
+ $command = "$self->{PERL} $xsubpp $file";
+ print "Running: $command\n" if $Verbose;
+ my $text = `$command` ;
+ if ($?) {
+ use vmsish 'status';
+ warn "Running '$command' exits with status $?";
+ }
+ unlink $file ;
+
+ # gets 1.2 -> 1.92 and 2.000a1
+ return $1 if $text =~ /automatically by xsubpp version ([\S]+)\s*/ ;
+
+ # it is either 1.0 or 1.1
+ return 1.1 if $text =~ /^Warning: ignored semicolon/ ;
+
+ # none of the above, so 1.0
+ return "1.0" ;
+}
+
+=item tools_other (override)
+
+Adds a few MM[SK] macros, and shortens some the installatin commands,
+in order to stay under DCL's 255-character limit. Also changes
+EQUALIZE_TIMESTAMP to set revision date of target file to one second
+later than source file, since MMK interprets precisely equal revision
+dates for a source and target file as a sign that the target needs
+to be updated.
+
+=cut
+
+sub tools_other {
+ my($self) = @_;
+ qq!
+# Assumes \$(MMS) invokes MMS or MMK
+# (It is assumed in some cases later that the default makefile name
+# (Descrip.MMS for MM[SK]) is used.)
+USEMAKEFILE = /Descrip=
+USEMACROS = /Macro=(
+MACROEND = )
+MAKEFILE = Descrip.MMS
+SHELL = Posix
+TOUCH = $self->{TOUCH}
+CHMOD = $self->{CHMOD}
+CP = $self->{CP}
+MV = $self->{MV}
+RM_F = $self->{RM_F}
+RM_RF = $self->{RM_RF}
+SAY = Write Sys\$Output
+UMASK_NULL = $self->{UMASK_NULL}
+NOOP = $self->{NOOP}
+NOECHO = $self->{NOECHO}
+MKPATH = Create/Directory
+EQUALIZE_TIMESTAMP = \$(PERL) -we "open F,qq{>\$ARGV[1]};close F;utime(0,(stat(\$ARGV[0]))[9]+1,\$ARGV[1])"
+!. ($self->{PARENT} ? '' :
+qq!WARN_IF_OLD_PACKLIST = \$(PERL) -e "if (-f \$ARGV[0]){print qq[WARNING: Old package found (\$ARGV[0]); please check for collisions\\n]}"
+MOD_INSTALL = \$(PERL) "-I\$(PERL_LIB)" "-MExtUtils::Install" -e "install({split(' ',<STDIN>)},1);"
+DOC_INSTALL = \$(PERL) -e "\@ARGV=split(/\\|/,<STDIN>);print '=head2 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];while(\$key=shift && \$val=shift){print qq[=item *\\n\\nC<\$key: \$val>\\n\\n];}print qq[=back\\n\\n]"
+UNINSTALL = \$(PERL) "-I\$(PERL_LIB)" "-MExtUtils::Install" -e "uninstall(\$ARGV[0],1,1);"
+!);
+}
+
+=item dist (override)
+
+Provide VMSish defaults for some values, then hand off to
+default MM_Unix method.
+
+=cut
+
+sub dist {
+ my($self, %attribs) = @_;
+ $attribs{VERSION} ||= $self->{VERSION_SYM};
+ $attribs{NAME} ||= $self->{DISTNAME};
+ $attribs{ZIPFLAGS} ||= '-Vu';
+ $attribs{COMPRESS} ||= 'gzip';
+ $attribs{SUFFIX} ||= '-gz';
+ $attribs{SHAR} ||= 'vms_share';
+ $attribs{DIST_DEFAULT} ||= 'zipdist';
+
+ # Sanitize these for use in $(DISTVNAME) filespec
+ $attribs{VERSION} =~ s/[^\w\$]/_/g;
+ $attribs{NAME} =~ s/[^\w\$]/_/g;
+
+ return ExtUtils::MM_Unix::dist($self,%attribs);
+}
+
+=item c_o (override)
+
+Use VMS syntax on command line. In particular, $(DEFINE) and
+$(PERL_INC) have been pulled into $(CCCMD). Also use MM[SK] macros.
+
+=cut
+
+sub c_o {
+ my($self) = @_;
+ return '' unless $self->needs_linking();
+ '
+.c$(OBJ_EXT) :
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
+
+.cpp$(OBJ_EXT) :
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp
+
+.cxx$(OBJ_EXT) :
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx
+
+';
+}
+
+=item xs_c (override)
+
+Use MM[SK] macros.
+
+=cut
+
+sub xs_c {
+ my($self) = @_;
+ return '' unless $self->needs_linking();
+ '
+.xs.c :
+ $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET)
+';
+}
+
+=item xs_o (override)
+
+Use MM[SK] macros, and VMS command line for C compiler.
+
+=cut
+
+sub xs_o { # many makes are too dumb to use xs_c then c_o
+ my($self) = @_;
+ return '' unless $self->needs_linking();
+ '
+.xs$(OBJ_EXT) :
+ $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c
+ $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
+';
+}
+
+=item top_targets (override)
+
+Use VMS quoting on command line for Version_check.
+
+=cut
+
+sub top_targets {
+ my($self) = shift;
+ my(@m);
+ push @m, '
+all :: pure_all manifypods
+ $(NOECHO) $(NOOP)
+
+pure_all :: config pm_to_blib subdirs linkext
+ $(NOECHO) $(NOOP)
+
+subdirs :: $(MYEXTLIB)
+ $(NOECHO) $(NOOP)
+
+config :: $(MAKEFILE) $(INST_LIBDIR).exists
+ $(NOECHO) $(NOOP)
+
+config :: $(INST_ARCHAUTODIR).exists
+ $(NOECHO) $(NOOP)
+
+config :: $(INST_AUTODIR).exists
+ $(NOECHO) $(NOOP)
+';
+
+ push @m, q{
+config :: Version_check
+ $(NOECHO) $(NOOP)
+
+} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC};
+
+
+ push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]);
+ if (%{$self->{MAN1PODS}}) {
+ push @m, q[
+config :: $(INST_MAN1DIR).exists
+ $(NOECHO) $(NOOP)
+];
+ push @m, $self->dir_target(qw[$(INST_MAN1DIR)]);
+ }
+ if (%{$self->{MAN3PODS}}) {
+ push @m, q[
+config :: $(INST_MAN3DIR).exists
+ $(NOECHO) $(NOOP)
+];
+ push @m, $self->dir_target(qw[$(INST_MAN3DIR)]);
+ }
+
+ push @m, '
+$(O_FILES) : $(H_FILES)
+' if @{$self->{O_FILES} || []} && @{$self->{H} || []};
+
+ push @m, q{
+help :
+ perldoc ExtUtils::MakeMaker
+};
+
+ push @m, q{
+Version_check :
+ $(NOECHO) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
+ "-MExtUtils::MakeMaker=Version_check" -e "&Version_check('$(MM_VERSION)')"
+};
+
+ join('',@m);
+}
+
+=item dlsyms (override)
+
+Create VMS linker options files specifying universal symbols for this
+extension's shareable image, and listing other shareable images or
+libraries to which it should be linked.
+
+=cut
+
+sub dlsyms {
+ my($self,%attribs) = @_;
+
+ return '' unless $self->needs_linking();
+
+ my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
+ my(@m);
+
+ unless ($self->{SKIPHASH}{'dynamic'}) {
+ push(@m,'
+dynamic :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
+ $(NOECHO) $(NOOP)
+');
+ }
+
+ push(@m,'
+static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
+ $(NOECHO) $(NOOP)
+') unless $self->{SKIPHASH}{'static'};
+
+ push(@m,'
+$(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt
+ $(CP) $(MMS$SOURCE) $(MMS$TARGET)
+
+$(BASEEXT).opt : Makefile.PL
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Mksymlists;" -
+ ',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ],
+ neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars),')"
+ $(PERL) -e "print ""$(INST_STATIC)/Include=$(BASEEXT)\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)
+');
+
+ if (length $self->{LDLOADLIBS}) {
+ my($lib); my($line) = '';
+ foreach $lib (split ' ', $self->{LDLOADLIBS}) {
+ $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs
+ if (length($line) + length($lib) > 160) {
+ push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n";
+ $line = $lib . '\n';
+ }
+ else { $line .= $lib . '\n'; }
+ }
+ push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line;
+ }
+
+ join('',@m);
+
+}
+
+=item dynamic_lib (override)
+
+Use VMS Link command.
+
+=cut
+
+sub dynamic_lib {
+ my($self, %attribs) = @_;
+ return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code();
+
+ my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
+ my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
+ my $shr = $Config{'dbgprefix'} . 'PerlShr';
+ my(@m);
+ push @m,"
+
+OTHERLDFLAGS = $otherldflags
+INST_DYNAMIC_DEP = $inst_dynamic_dep
+
+";
+ push @m, '
+$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
+ $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR)
+ $(NOECHO) If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",'
+ Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option
+';
+
+ push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
+ join('',@m);
+}
+
+=item dynamic_bs (override)
+
+Use VMS-style quoting on Mkbootstrap command line.
+
+=cut
+
+sub dynamic_bs {
+ my($self, %attribs) = @_;
+ return '
+BOOTSTRAP =
+' unless $self->has_link_code();
+ '
+BOOTSTRAP = '."$self->{BASEEXT}.bs".'
+
+# As MakeMaker mkbootstrap might not write a file (if none is required)
+# we use touch to prevent make continually trying to remake it.
+# The DynaLoader only reads a non-empty file.
+$(BOOTSTRAP) : $(MAKEFILE) '."$self->{BOOTDEP}".' $(INST_ARCHAUTODIR).exists
+ $(NOECHO) $(SAY) "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))"
+ $(NOECHO) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
+ -e "use ExtUtils::Mkbootstrap; Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');"
+ $(NOECHO) $(TOUCH) $(MMS$TARGET)
+
+$(INST_BOOT) : $(BOOTSTRAP) $(INST_ARCHAUTODIR).exists
+ $(NOECHO) $(RM_RF) $(INST_BOOT)
+ - $(CP) $(BOOTSTRAP) $(INST_BOOT)
+';
+}
+
+=item static_lib (override)
+
+Use VMS commands to manipulate object library.
+
+=cut
+
+sub static_lib {
+ my($self) = @_;
+ return '' unless $self->needs_linking();
+
+ return '
+$(INST_STATIC) :
+ $(NOECHO) $(NOOP)
+' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB});
+
+ my(@m);
+ push @m,'
+# Rely on suffix rule for update action
+$(OBJECT) : $(INST_ARCHAUTODIR).exists
+
+$(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
+';
+ # If this extension has it's own library (eg SDBM_File)
+ # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
+ push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};
+
+ push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n");
+
+ # if there was a library to copy, then we can't use MMS$SOURCE_LIST,
+ # 'cause it's a library and you can't stick them in other libraries.
+ # In that case, we use $OBJECT instead and hope for the best
+ if ($self->{MYEXTLIB}) {
+ push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n");
+ } else {
+ push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
+ }
+
+ push(@m,"\t",'$(NOECHO) $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq{$(EXTRALIBS)\n};close F;"',"\n");
+ push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
+ join('',@m);
+}
+
+
+=item manifypods (override)
+
+Use VMS-style quoting on command line, and VMS logical name
+to specify fallback location at build time if we can't find pod2man.
+
+=cut
+
+
+sub manifypods {
+ my($self, %attribs) = @_;
+ return "\nmanifypods :\n\t\$(NOECHO) \$(NOOP)\n" unless %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}};
+ my($dist);
+ my($pod2man_exe);
+ if (defined $self->{PERL_SRC}) {
+ $pod2man_exe = $self->catfile($self->{PERL_SRC},'pod','pod2man');
+ } else {
+ $pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man');
+ }
+ if (not ($pod2man_exe = $self->perl_script($pod2man_exe))) {
+ # No pod2man but some MAN3PODS to be installed
+ print <<END;
+
+Warning: I could not locate your pod2man program. As a last choice,
+ I will look for the file to which the logical name POD2MAN
+ points when MMK is invoked.
+
+END
+ $pod2man_exe = "pod2man";
+ }
+ my(@m);
+ push @m,
+qq[POD2MAN_EXE = $pod2man_exe\n],
+q[POD2MAN = $(PERL) -we "%m=@ARGV;for (keys %m){" -
+-e "system(""MCR $^X $(POD2MAN_EXE) $_ >$m{$_}"");}"
+];
+ push @m, "\nmanifypods : \$(MAN1PODS) \$(MAN3PODS)\n";
+ if (%{$self->{MAN1PODS}} || %{$self->{MAN3PODS}}) {
+ my($pod);
+ foreach $pod (sort keys %{$self->{MAN1PODS}}) {
+ push @m, qq[\t\@- If F\$Search("\$(POD2MAN_EXE)").nes."" Then \$(POD2MAN) ];
+ push @m, "$pod $self->{MAN1PODS}{$pod}\n";
+ }
+ foreach $pod (sort keys %{$self->{MAN3PODS}}) {
+ push @m, qq[\t\@- If F\$Search("\$(POD2MAN_EXE)").nes."" Then \$(POD2MAN) ];
+ push @m, "$pod $self->{MAN3PODS}{$pod}\n";
+ }
+ }
+ join('', @m);
+}
+
+=item processPL (override)
+
+Use VMS-style quoting on command line.
+
+=cut
+
+sub processPL {
+ my($self) = @_;
+ return "" unless $self->{PL_FILES};
+ my(@m, $plfile);
+ foreach $plfile (sort keys %{$self->{PL_FILES}}) {
+ my $vmsplfile = vmsify($plfile);
+ my $vmsfile = vmsify($self->{PL_FILES}->{$plfile});
+ push @m, "
+all :: $vmsfile
+ \$(NOECHO) \$(NOOP)
+
+$vmsfile :: $vmsplfile
+",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $vmsplfile
+";
+ }
+ join "", @m;
+}
+
+=item installbin (override)
+
+Stay under DCL's 255 character command line limit once again by
+splitting potentially long list of files across multiple lines
+in C<realclean> target.
+
+=cut
+
+sub installbin {
+ my($self) = @_;
+ return '' unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
+ return '' unless @{$self->{EXE_FILES}};
+ my(@m, $from, $to, %fromto, @to, $line);
+ my(@exefiles) = map { vmsify($_) } @{$self->{EXE_FILES}};
+ for $from (@exefiles) {
+ my($path) = '$(INST_SCRIPT)' . basename($from);
+ local($_) = $path; # backward compatibility
+ $to = $self->libscan($path);
+ print "libscan($from) => '$to'\n" if ($Verbose >=2);
+ $fromto{$from} = vmsify($to);
+ }
+ @to = values %fromto;
+ push @m, "
+EXE_FILES = @exefiles
+
+all :: @to
+ \$(NOECHO) \$(NOOP)
+
+realclean ::
+";
+ $line = ''; #avoid unitialized var warning
+ foreach $to (@to) {
+ if (length($line) + length($to) > 80) {
+ push @m, "\t\$(RM_F) $line\n";
+ $line = $to;
+ }
+ else { $line .= " $to"; }
+ }
+ push @m, "\t\$(RM_F) $line\n\n" if $line;
+
+ while (($from,$to) = each %fromto) {
+ last unless defined $from;
+ my $todir;
+ if ($to =~ m#[/>:\]]#) { $todir = dirname($to); }
+ else { ($todir = $to) =~ s/[^\)]+$//; }
+ $todir = $self->fixpath($todir,1);
+ push @m, "
+$to : $from \$(MAKEFILE) ${todir}.exists
+ \$(CP) $from $to
+
+", $self->dir_target($todir);
+ }
+ join "", @m;
+}
+
+=item subdir_x (override)
+
+Use VMS commands to change default directory.
+
+=cut
+
+sub subdir_x {
+ my($self, $subdir) = @_;
+ my(@m,$key);
+ $subdir = $self->fixpath($subdir,1);
+ push @m, '
+
+subdirs ::
+ olddef = F$Environment("Default")
+ Set Default ',$subdir,'
+ - $(MMS)$(MMSQUALIFIERS) all $(USEMACROS)$(PASTHRU)$(MACROEND)
+ Set Default \'olddef\'
+';
+ join('',@m);
+}
+
+=item clean (override)
+
+Split potentially long list of files across multiple commands (in
+order to stay under the magic command line limit). Also use MM[SK]
+commands for handling subdirectories.
+
+=cut
+
+sub clean {
+ my($self, %attribs) = @_;
+ my(@m,$dir);
+ push @m, '
+# Delete temporary files but do not touch installed files. We don\'t delete
+# the Descrip.MMS here so that a later make realclean still has it to use.
+clean ::
+';
+ foreach $dir (@{$self->{DIR}}) { # clean subdirectories first
+ my($vmsdir) = $self->fixpath($dir,1);
+ push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)").nes."" Then \\',"\n\t",
+ '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS)$(MMSQUALIFIERS) clean`;"',"\n");
+ }
+ push @m, ' $(RM_F) *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *$(OBJ_EXT) *$(LIB_EXT) *.Opt $(BOOTSTRAP) $(BASEEXT).bso .MM_Tmp
+';
+
+ my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files
+ # Unlink realclean, $attribs{FILES} is a string here; it may contain
+ # a list or a macro that expands to a list.
+ if ($attribs{FILES}) {
+ my($word,$key,@filist);
+ if (ref $attribs{FILES} eq 'ARRAY') { @filist = @{$attribs{FILES}}; }
+ else { @filist = split /\s+/, $attribs{FILES}; }
+ foreach $word (@filist) {
+ if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') {
+ push(@otherfiles, @{$self->{$key}});
+ }
+ else { push(@otherfiles, $word); }
+ }
+ }
+ push(@otherfiles, qw[ blib $(MAKE_APERL_FILE) extralibs.ld perlmain.c pm_to_blib.ts ]);
+ push(@otherfiles,$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'));
+ my($file,$line);
+ $line = ''; #avoid unitialized var warning
+ # Occasionally files are repeated several times from different sources
+ { my(%of) = map { ($_,1) } @otherfiles; @otherfiles = keys %of; }
+
+ foreach $file (@otherfiles) {
+ $file = $self->fixpath($file);
+ if (length($line) + length($file) > 80) {
+ push @m, "\t\$(RM_RF) $line\n";
+ $line = "$file";
+ }
+ else { $line .= " $file"; }
+ }
+ push @m, "\t\$(RM_RF) $line\n" if $line;
+ push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP};
+ join('', @m);
+}
+
+=item realclean (override)
+
+Guess what we're working around? Also, use MM[SK] for subdirectories.
+
+=cut
+
+sub realclean {
+ my($self, %attribs) = @_;
+ my(@m);
+ push(@m,'
+# Delete temporary files (via clean) and also delete installed files
+realclean :: clean
+');
+ foreach(@{$self->{DIR}}){
+ my($vmsdir) = $self->fixpath($_,1);
+ push(@m, ' If F$Search("'."$vmsdir".'$(MAKEFILE)").nes."" Then \\',"\n\t",
+ '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS)$(MMSQUALIFIERS) realclean`;"',"\n");
+ }
+ push @m,' $(RM_RF) $(INST_AUTODIR) $(INST_ARCHAUTODIR)
+';
+ # We can't expand several of the MMS macros here, since they don't have
+ # corresponding %$self keys (i.e. they're defined in Descrip.MMS as a
+ # combination of macros). In order to stay below DCL's 255 char limit,
+ # we put only 2 on a line.
+ my($file,$line,$fcnt);
+ my(@files) = qw{ $(MAKEFILE) $(MAKEFILE)_old };
+ if ($self->has_link_code) {
+ push(@files,qw{ $(INST_DYNAMIC) $(INST_STATIC) $(INST_BOOT) $(OBJECT) });
+ }
+ push(@files, values %{$self->{PM}});
+ $line = ''; #avoid unitialized var warning
+ # Occasionally files are repeated several times from different sources
+ { my(%f) = map { ($_,1) } @files; @files = keys %f; }
+ foreach $file (@files) {
+ $file = $self->fixpath($file);
+ if (length($line) + length($file) > 80 || ++$fcnt >= 2) {
+ push @m, "\t\$(RM_F) $line\n";
+ $line = "$file";
+ $fcnt = 0;
+ }
+ else { $line .= " $file"; }
+ }
+ push @m, "\t\$(RM_F) $line\n" if $line;
+ if ($attribs{FILES}) {
+ my($word,$key,@filist,@allfiles);
+ if (ref $attribs{FILES} eq 'ARRAY') { @filist = @{$attribs{FILES}}; }
+ else { @filist = split /\s+/, $attribs{FILES}; }
+ foreach $word (@filist) {
+ if (($key) = $word =~ m#^\$\((.*)\)$# and ref $self->{$key} eq 'ARRAY') {
+ push(@allfiles, @{$self->{$key}});
+ }
+ else { push(@allfiles, $word); }
+ }
+ $line = '';
+ # Occasionally files are repeated several times from different sources
+ { my(%af) = map { ($_,1) } @allfiles; @allfiles = keys %af; }
+ foreach $file (@allfiles) {
+ $file = $self->fixpath($file);
+ if (length($line) + length($file) > 80) {
+ push @m, "\t\$(RM_RF) $line\n";
+ $line = "$file";
+ }
+ else { $line .= " $file"; }
+ }
+ push @m, "\t\$(RM_RF) $line\n" if $line;
+ }
+ push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP};
+ join('', @m);
+}
+
+=item dist_basics (override)
+
+Use VMS-style quoting on command line.
+
+=cut
+
+sub dist_basics {
+ my($self) = @_;
+'
+distclean :: realclean distcheck
+ $(NOECHO) $(NOOP)
+
+distcheck :
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&fullcheck\'; fullcheck()"
+
+skipcheck :
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&skipcheck\'; skipcheck()"
+
+manifest :
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&mkmanifest\'; mkmanifest()"
+';
+}
+
+=item dist_core (override)
+
+Syntax for invoking F<VMS_Share> differs from that for Unix F<shar>,
+so C<shdist> target actions are VMS-specific.
+
+=cut
+
+sub dist_core {
+ my($self) = @_;
+q[
+dist : $(DIST_DEFAULT)
+ $(NOECHO) $(PERL) -le "print 'Warning: $m older than $vf' if -e ($vf = '$(VERSION_FROM)') && -M $vf < -M ($m = '$(MAKEFILE)')"
+
+zipdist : $(DISTVNAME).zip
+ $(NOECHO) $(NOOP)
+
+$(DISTVNAME).zip : distdir
+ $(PREOP)
+ $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*;
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+
+$(DISTVNAME).tar$(SUFFIX) : distdir
+ $(PREOP)
+ $(TO_UNIX)
+ $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)]
+ $(RM_RF) $(DISTVNAME)
+ $(COMPRESS) $(DISTVNAME).tar
+ $(POSTOP)
+
+shdist : distdir
+ $(PREOP)
+ $(SHAR) [.$(DISTVNAME...]*.*; $(DISTVNAME).share
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+];
+}
+
+=item dist_dir (override)
+
+Use VMS-style quoting on command line.
+
+=cut
+
+sub dist_dir {
+ my($self) = @_;
+q{
+distdir :
+ $(RM_RF) $(DISTVNAME)
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest '/mani/';" \\
+ -e "manicopy(maniread(),'$(DISTVNAME)','$(DIST_CP)');"
+};
+}
+
+=item dist_test (override)
+
+Use VMS commands to change default directory, and use VMS-style
+quoting on command line.
+
+=cut
+
+sub dist_test {
+ my($self) = @_;
+q{
+disttest : distdir
+ startdir = F$Environment("Default")
+ Set Default [.$(DISTVNAME)]
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL
+ $(MMS)$(MMSQUALIFIERS)
+ $(MMS)$(MMSQUALIFIERS) test
+ Set Default 'startdir'
+};
+}
+
+# --- Test and Installation Sections ---
+
+=item install (override)
+
+Work around DCL's 255 character limit several times,and use
+VMS-style command line quoting in a few cases.
+
+=cut
+
+sub install {
+ my($self, %attribs) = @_;
+ my(@m,@docfiles);
+
+ if ($self->{EXE_FILES}) {
+ my($line,$file) = ('','');
+ foreach $file (@{$self->{EXE_FILES}}) {
+ $line .= "$file ";
+ if (length($line) > 128) {
+ push(@docfiles,qq[\t\$(PERL) -e "print '$line'" >>.MM_tmp\n]);
+ $line = '';
+ }
+ }
+ push(@docfiles,qq[\t\$(PERL) -e "print '$line'" >>.MM_tmp\n]) if $line;
+ }
+
+ push @m, q[
+install :: all pure_install doc_install
+ $(NOECHO) $(NOOP)
+
+install_perl :: all pure_perl_install doc_perl_install
+ $(NOECHO) $(NOOP)
+
+install_site :: all pure_site_install doc_site_install
+ $(NOECHO) $(NOOP)
+
+install_ :: install_site
+ $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
+
+pure_install :: pure_$(INSTALLDIRS)_install
+ $(NOECHO) $(NOOP)
+
+doc_install :: doc_$(INSTALLDIRS)_install
+ $(NOECHO) $(SAY) "Appending installation info to $(INSTALLARCHLIB)perllocal.pod"
+
+pure__install : pure_site_install
+ $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
+
+doc__install : doc_site_install
+ $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
+
+# This hack brought to you by DCL's 255-character command line limit
+pure_perl_install ::
+ $(NOECHO) $(PERL) -e "print 'read ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp
+ $(NOECHO) $(PERL) -e "print 'write ].$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_LIB) $(INSTALLPRIVLIB) '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLARCHLIB) '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp
+ $(MOD_INSTALL) <.MM_tmp
+ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
+ $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[
+
+# Likewise
+pure_site_install ::
+ $(NOECHO) $(PERL) -e "print 'read ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp
+ $(NOECHO) $(PERL) -e "print 'write ].$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_LIB) $(INSTALLSITELIB) '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLSITEARCH) '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp
+ $(MOD_INSTALL) <.MM_tmp
+ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
+ $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[
+
+# Ditto
+doc_perl_install ::
+ $(NOECHO) $(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLPRIVLIB)|'" >.MM_tmp
+ $(NOECHO) $(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES)|'" >>.MM_tmp
+],@docfiles,
+q% $(NOECHO) $(PERL) -e "print q[@ARGV=split(/\\|/,<STDIN>);]" >.MM2_tmp
+ $(NOECHO) $(PERL) -e "print q[print '=head2 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];]" >>.MM2_tmp
+ $(NOECHO) $(PERL) -e "print q[while(($key=shift) && ($val=shift)) ]" >>.MM2_tmp
+ $(NOECHO) $(PERL) -e "print q[{print qq[=item *\\n\\nC<$key: $val>\\n\\n];}print qq[=back\\n\\n];]" >>.MM2_tmp
+ $(NOECHO) $(PERL) .MM2_tmp <.MM_tmp >>%.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
+ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;,.MM2_tmp;
+
+# And again
+doc_site_install ::
+ $(NOECHO) $(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLSITELIB)|'" >.MM_tmp
+ $(NOECHO) $(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES)|'" >>.MM_tmp
+],@docfiles,
+q% $(NOECHO) $(PERL) -e "print q[@ARGV=split(/\\|/,<STDIN>);]" >.MM2_tmp
+ $(NOECHO) $(PERL) -e "print q[print '=head2 ',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];]" >>.MM2_tmp
+ $(NOECHO) $(PERL) -e "print q[while(($key=shift) && ($val=shift)) ]" >>.MM2_tmp
+ $(NOECHO) $(PERL) -e "print q[{print qq[=item *\\n\\nC<$key: $val>\\n\\n];}print qq[=back\\n\\n];]" >>.MM2_tmp
+ $(NOECHO) $(PERL) .MM2_tmp <.MM_tmp >>%.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
+ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;,.MM2_tmp;
+
+];
+
+ push @m, q[
+uninstall :: uninstall_from_$(INSTALLDIRS)dirs
+ $(NOECHO) $(NOOP)
+
+uninstall_from_perldirs ::
+ $(NOECHO) $(UNINSTALL) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[
+ $(NOECHO) $(SAY) "Uninstall is now deprecated and makes no actual changes."
+ $(NOECHO) $(SAY) "Please check the list above carefully for errors, and manually remove"
+ $(NOECHO) $(SAY) "the appropriate files. Sorry for the inconvenience."
+
+uninstall_from_sitedirs ::
+ $(NOECHO) $(UNINSTALL) ],$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist'),"\n",q[
+ $(NOECHO) $(SAY) "Uninstall is now deprecated and makes no actual changes."
+ $(NOECHO) $(SAY) "Please check the list above carefully for errors, and manually remove"
+ $(NOECHO) $(SAY) "the appropriate files. Sorry for the inconvenience."
+];
+
+ join('',@m);
+}
+
+=item perldepend (override)
+
+Use VMS-style syntax for files; it's cheaper to just do it directly here
+than to have the MM_Unix method call C<catfile> repeatedly. Also, if
+we have to rebuild Config.pm, use MM[SK] to do it.
+
+=cut
+
+sub perldepend {
+ my($self) = @_;
+ my(@m);
+
+ push @m, '
+$(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h, $(PERL_INC)av.h
+$(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h, $(PERL_INC)form.h
+$(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h, $(PERL_INC)keywords.h
+$(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)op.h, $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h
+$(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)proto.h
+$(OBJECT) : $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h
+$(OBJECT) : $(PERL_INC)vmsish.h, $(PERL_INC)util.h, $(PERL_INC)config.h
+$(OBJECT) : $(PERL_INC)iperlsys.h
+
+' if $self->{OBJECT};
+
+ if ($self->{PERL_SRC}) {
+ my(@macros);
+ my($mmsquals) = '$(USEMAKEFILE)[.vms]$(MAKEFILE)';
+ push(@macros,'__AXP__=1') if $Config{'arch'} eq 'VMS_AXP';
+ push(@macros,'DECC=1') if $Config{'vms_cc_type'} eq 'decc';
+ push(@macros,'GNUC=1') if $Config{'vms_cc_type'} eq 'gcc';
+ push(@macros,'SOCKET=1') if $Config{'d_has_sockets'};
+ push(@macros,qq["CC=$Config{'cc'}"]) if $Config{'cc'} =~ m!/!;
+ $mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros;
+ push(@m,q[
+# Check for unpropagated config.sh changes. Should never happen.
+# We do NOT just update config.h because that is not sufficient.
+# An out of date config.h is not fatal but complains loudly!
+$(PERL_INC)config.h : $(PERL_SRC)config.sh
+
+$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
+ $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl"
+ olddef = F$Environment("Default")
+ Set Default $(PERL_SRC)
+ $(MMS)],$mmsquals,);
+ if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) {
+ my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0));
+ $target =~ s/\Q$prefix/[/;
+ push(@m," $target");
+ }
+ else { push(@m,' $(MMS$TARGET)'); }
+ push(@m,q[
+ Set Default 'olddef'
+]);
+ }
+
+ push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
+ if %{$self->{XS}};
+
+ join('',@m);
+}
+
+=item makefile (override)
+
+Use VMS commands and quoting.
+
+=cut
+
+sub makefile {
+ my($self) = @_;
+ my(@m,@cmd);
+ # We do not know what target was originally specified so we
+ # must force a manual rerun to be sure. But as it should only
+ # happen very rarely it is not a significant problem.
+ push @m, q[
+$(OBJECT) : $(FIRST_MAKEFILE)
+] if $self->{OBJECT};
+
+ push @m,q[
+# We take a very conservative approach here, but it\'s worth it.
+# We move $(MAKEFILE) to $(MAKEFILE)_old here to avoid gnu make looping.
+$(MAKEFILE) : Makefile.PL $(CONFIGDEP)
+ $(NOECHO) $(SAY) "$(MAKEFILE) out-of-date with respect to $(MMS$SOURCE_LIST)"
+ $(NOECHO) $(SAY) "Cleaning current config before rebuilding $(MAKEFILE) ..."
+ - $(MV) $(MAKEFILE) $(MAKEFILE)_old
+ - $(MMS)$(MMSQUALIFIERS) $(USEMAKEFILE)$(MAKEFILE)_old clean
+ $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL ],join(' ',map(qq["$_"],@ARGV)),q[
+ $(NOECHO) $(SAY) "$(MAKEFILE) has been rebuilt."
+ $(NOECHO) $(SAY) "Please run $(MMS) to build the extension."
+];
+
+ join('',@m);
+}
+
+=item test (override)
+
+Use VMS commands for handling subdirectories.
+
+=cut
+
+sub test {
+ my($self, %attribs) = @_;
+ my($tests) = $attribs{TESTS} || ( -d 't' ? 't/*.t' : '');
+ my(@m);
+ push @m,"
+TEST_VERBOSE = 0
+TEST_TYPE = test_\$(LINKTYPE)
+TEST_FILE = test.pl
+TESTDB_SW = -d
+
+test :: \$(TEST_TYPE)
+ \$(NOECHO) \$(NOOP)
+
+testdb :: testdb_\$(LINKTYPE)
+ \$(NOECHO) \$(NOOP)
+
+";
+ foreach(@{$self->{DIR}}){
+ my($vmsdir) = $self->fixpath($_,1);
+ push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'",
+ '; print `$(MMS)$(MMSQUALIFIERS) $(PASTHRU2) test`'."\n");
+ }
+ push(@m, "\t\$(NOECHO) \$(SAY) \"No tests defined for \$(NAME) extension.\"\n")
+ unless $tests or -f "test.pl" or @{$self->{DIR}};
+ push(@m, "\n");
+
+ push(@m, "test_dynamic :: pure_all\n");
+ push(@m, $self->test_via_harness('$(FULLPERL)', $tests)) if $tests;
+ push(@m, $self->test_via_script('$(FULLPERL)', 'test.pl')) if -f "test.pl";
+ push(@m, "\t\$(NOECHO) \$(NOOP)\n") if (!$tests && ! -f "test.pl");
+ push(@m, "\n");
+
+ push(@m, "testdb_dynamic :: pure_all\n");
+ push(@m, $self->test_via_script('$(FULLPERL) "$(TESTDB_SW)"', '$(TEST_FILE)'));
+ push(@m, "\n");
+
+ # Occasionally we may face this degenerate target:
+ push @m, "test_ : test_dynamic\n\n";
+
+ if ($self->needs_linking()) {
+ push(@m, "test_static :: pure_all \$(MAP_TARGET)\n");
+ push(@m, $self->test_via_harness('$(MAP_TARGET)', $tests)) if $tests;
+ push(@m, $self->test_via_script('$(MAP_TARGET)', 'test.pl')) if -f 'test.pl';
+ push(@m, "\n");
+ push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n");
+ push(@m, $self->test_via_script('$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)'));
+ push(@m, "\n");
+ }
+ else {
+ push @m, "test_static :: test_dynamic\n\t\$(NOECHO) \$(NOOP)\n\n";
+ push @m, "testdb_static :: testdb_dynamic\n\t\$(NOECHO) \$(NOOP)\n";
+ }
+
+ join('',@m);
+}
+
+=item test_via_harness (override)
+
+Use VMS-style quoting on command line.
+
+=cut
+
+sub test_via_harness {
+ my($self,$perl,$tests) = @_;
+ " $perl".' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)" \\'."\n\t".
+ '-e "use Test::Harness qw(&runtests $verbose); $verbose=$(TEST_VERBOSE); runtests @ARGV;" \\'."\n\t$tests\n";
+}
+
+=item test_via_script (override)
+
+Use VMS-style quoting on command line.
+
+=cut
+
+sub test_via_script {
+ my($self,$perl,$script) = @_;
+ " $perl".' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '.$script.'
+';
+}
+
+=item makeaperl (override)
+
+Undertake to build a new set of Perl images using VMS commands. Since
+VMS does dynamic loading, it's not necessary to statically link each
+extension into the Perl image, so this isn't the normal build path.
+Consequently, it hasn't really been tested, and may well be incomplete.
+
+=cut
+
+sub makeaperl {
+ my($self, %attribs) = @_;
+ my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
+ @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
+ my(@m);
+ push @m, "
+# --- MakeMaker makeaperl section ---
+MAP_TARGET = $target
+";
+ return join '', @m if $self->{PARENT};
+
+ my($dir) = join ":", @{$self->{DIR}};
+
+ unless ($self->{MAKEAPERL}) {
+ push @m, q{
+$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
+ $(NOECHO) $(SAY) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
+ $(NOECHO) $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \
+ Makefile.PL DIR=}, $dir, q{ \
+ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
+ MAKEAPERL=1 NORECURS=1
+
+$(MAP_TARGET) :: $(MAKE_APERL_FILE)
+ $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
+};
+ push @m, map( " \\\n\t\t$_", @ARGV );
+ push @m, "\n";
+
+ return join '', @m;
+ }
+
+
+ my($linkcmd,@staticopts,@staticpkgs,$extralist,$targdir,$libperldir);
+
+ # The front matter of the linkcommand...
+ $linkcmd = join ' ', $Config{'ld'},
+ grep($_, @Config{qw(large split ldflags ccdlflags)});
+ $linkcmd =~ s/\s+/ /g;
+
+ # Which *.olb files could we make use of...
+ local(%olbs);
+ $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)";
+ require File::Find;
+ File::Find::find(sub {
+ return unless m/\Q$self->{LIB_EXT}\E$/;
+ return if m/^libperl/;
+
+ if( exists $self->{INCLUDE_EXT} ){
+ my $found = 0;
+ my $incl;
+ my $xx;
+
+ ($xx = $File::Find::name) =~ s,.*?/auto/,,;
+ $xx =~ s,/?$_,,;
+ $xx =~ s,/,::,g;
+
+ # Throw away anything not explicitly marked for inclusion.
+ # DynaLoader is implied.
+ foreach $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
+ if( $xx eq $incl ){
+ $found++;
+ last;
+ }
+ }
+ return unless $found;
+ }
+ elsif( exists $self->{EXCLUDE_EXT} ){
+ my $excl;
+ my $xx;
+
+ ($xx = $File::Find::name) =~ s,.*?/auto/,,;
+ $xx =~ s,/?$_,,;
+ $xx =~ s,/,::,g;
+
+ # Throw away anything explicitly marked for exclusion
+ foreach $excl (@{$self->{EXCLUDE_EXT}}){
+ return if( $xx eq $excl );
+ }
+ }
+
+ $olbs{$ENV{DEFAULT}} = $_;
+ }, grep( -d $_, @{$searchdirs || []}));
+
+ # We trust that what has been handed in as argument will be buildable
+ $static = [] unless $static;
+ @olbs{@{$static}} = (1) x @{$static};
+
+ $extra = [] unless $extra && ref $extra eq 'ARRAY';
+ # Sort the object libraries in inverse order of
+ # filespec length to try to insure that dependent extensions
+ # will appear before their parents, so the linker will
+ # search the parent library to resolve references.
+ # (e.g. Intuit::DWIM will precede Intuit, so unresolved
+ # references from [.intuit.dwim]dwim.obj can be found
+ # in [.intuit]intuit.olb).
+ for (sort keys %olbs) {
+ next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
+ my($dir) = $self->fixpath($_,1);
+ my($extralibs) = $dir . "extralibs.ld";
+ my($extopt) = $dir . $olbs{$_};
+ $extopt =~ s/$self->{LIB_EXT}$/.opt/;
+ if (-f $extralibs ) {
+ open LIST,$extralibs or warn $!,next;
+ push @$extra, <LIST>;
+ close LIST;
+ }
+ if (-f $extopt) {
+ open OPT,$extopt or die $!;
+ while (<OPT>) {
+ next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
+ # ExtUtils::Miniperl expects Unix paths
+ (my($pkg) = "$1_$1$self->{LIB_EXT}") =~ s#_*#/#g;
+ push @staticpkgs,$pkg;
+ }
+ push @staticopts, $extopt;
+ }
+ }
+
+ $target = "Perl$Config{'exe_ext'}" unless $target;
+ ($shrtarget,$targdir) = fileparse($target);
+ $shrtarget =~ s/^([^.]*)/$1Shr/;
+ $shrtarget = $targdir . $shrtarget;
+ $target = "Perlshr.$Config{'dlext'}" unless $target;
+ $tmp = "[]" unless $tmp;
+ $tmp = $self->fixpath($tmp,1);
+ if (@$extra) {
+ $extralist = join(' ',@$extra);
+ $extralist =~ s/[,\s\n]+/, /g;
+ }
+ else { $extralist = ''; }
+ if ($libperl) {
+ unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) {
+ print STDOUT "Warning: $libperl not found\n";
+ undef $libperl;
+ }
+ }
+ unless ($libperl) {
+ if (defined $self->{PERL_SRC}) {
+ $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}");
+ } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) {
+ } else {
+ print STDOUT "Warning: $libperl not found
+ If you're going to build a static perl binary, make sure perl is installed
+ otherwise ignore this warning\n";
+ }
+ }
+ $libperldir = $self->fixpath((fileparse($libperl))[1],1);
+
+ push @m, '
+# Fill in the target you want to produce if it\'s not perl
+MAP_TARGET = ',$self->fixpath($target,0),'
+MAP_SHRTARGET = ',$self->fixpath($shrtarget,0),"
+MAP_LINKCMD = $linkcmd
+MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '','
+# We use the linker options files created with each extension, rather than
+#specifying the object files directly on the command line.
+MAP_STATIC = ',@staticopts ? join(' ', @staticopts) : '','
+MAP_OPTS = ',@staticopts ? ','.join(',', map($_.'/Option', @staticopts)) : '',"
+MAP_EXTRA = $extralist
+MAP_LIBPERL = ",$self->fixpath($libperl,0),'
+';
+
+
+ push @m,'
+$(MAP_SHRTARGET) : $(MAP_LIBPERL) $(MAP_STATIC) ',"${libperldir}Perlshr_Attr.Opt",'
+ $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_OPTS), $(MAP_EXTRA), $(MAP_LIBPERL) ',"${libperldir}Perlshr_Attr.Opt",'
+$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt",'
+ $(MAP_LINKCMD) ',"${tmp}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
+ $(NOECHO) $(SAY) "To install the new ""$(MAP_TARGET)"" binary, say"
+ $(NOECHO) $(SAY) " $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
+ $(NOECHO) $(SAY) "To remove the intermediate files, say
+ $(NOECHO) $(SAY) " $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKEFILE) map_clean"
+';
+ push @m,'
+',"${tmp}perlmain.c",' : $(MAKEFILE)
+ $(NOECHO) $(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET)
+';
+
+ push @m, q[
+# More from the 255-char line length limit
+doc_inst_perl :
+ $(NOECHO) $(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp
+ $(NOECHO) $(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp
+ $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
+ $(NOECHO) $(PERL) -e "print 'MAP_LIBPERL|$(MAP_LIBPERL)|'" >>.MM_tmp
+ $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
+ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
+];
+
+ push @m, "
+inst_perl : pure_inst_perl doc_inst_perl
+ \$(NOECHO) \$(NOOP)
+
+pure_inst_perl : \$(MAP_TARGET)
+ $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
+ $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"
+
+clean :: map_clean
+ \$(NOECHO) \$(NOOP)
+
+map_clean :
+ \$(RM_F) ${tmp}perlmain\$(OBJ_EXT) ${tmp}perlmain.c \$(MAKEFILE)
+ \$(RM_F) ${tmp}PerlShr.Opt \$(MAP_TARGET)
+";
+
+ join '', @m;
+}
+
+# --- Output postprocessing section ---
+
+=item nicetext (override)
+
+Insure that colons marking targets are preceded by space, in order
+to distinguish the target delimiter from a colon appearing as
+part of a filespec.
+
+=cut
+
+sub nicetext {
+
+ my($self,$text) = @_;
+ $text =~ s/([^\s:])(:+\s)/$1 $2/gs;
+ $text;
+}
+
+1;
+
+=back
+
+=cut
+
+__END__
+
diff --git a/contrib/perl5/lib/ExtUtils/MM_Win32.pm b/contrib/perl5/lib/ExtUtils/MM_Win32.pm
new file mode 100644
index 000000000000..a1226b54638b
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/MM_Win32.pm
@@ -0,0 +1,823 @@
+package ExtUtils::MM_Win32;
+
+=head1 NAME
+
+ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker
+
+=head1 SYNOPSIS
+
+ use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed
+
+=head1 DESCRIPTION
+
+See ExtUtils::MM_Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=over
+
+=cut
+
+use Config;
+#use Cwd;
+use File::Basename;
+require Exporter;
+
+Exporter::import('ExtUtils::MakeMaker',
+ qw( $Verbose &neatvalue));
+
+$ENV{EMXSHELL} = 'sh'; # to run `commands`
+unshift @MM::ISA, 'ExtUtils::MM_Win32';
+
+$BORLAND = 1 if $Config{'cc'} =~ /^bcc/i;
+$GCC = 1 if $Config{'cc'} =~ /^gcc/i;
+$DMAKE = 1 if $Config{'make'} =~ /^dmake/i;
+$NMAKE = 1 if $Config{'make'} =~ /^nmake/i;
+$OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i;
+
+sub dlsyms {
+ my($self,%attribs) = @_;
+
+ my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
+ my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
+ my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
+ my(@m);
+ (my $boot = $self->{NAME}) =~ s/:/_/g;
+
+ if (not $self->{SKIPHASH}{'dynamic'}) {
+ push(@m,"
+$self->{BASEEXT}.def: Makefile.PL
+",
+ q! $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Mksymlists \\
+ -e "Mksymlists('NAME' => '!, $self->{NAME},
+ q!', 'DLBASE' => '!,$self->{DLBASE},
+ q!', 'DL_FUNCS' => !,neatvalue($funcs),
+ q!, 'IMPORTS' => !,neatvalue($imports),
+ q!, 'DL_VARS' => !, neatvalue($vars), q!);"
+!);
+ }
+ join('',@m);
+}
+
+sub replace_manpage_separator {
+ my($self,$man) = @_;
+ $man =~ s,/+,.,g;
+ $man;
+}
+
+sub maybe_command {
+ my($self,$file) = @_;
+ my @e = exists($ENV{'PATHEXT'})
+ ? split(/;/, $ENV{PATHEXT})
+ : qw(.com .exe .bat .cmd);
+ my $e = '';
+ for (@e) { $e .= "\Q$_\E|" }
+ chop $e;
+ # see if file ends in one of the known extensions
+ if ($file =~ /($e)$/i) {
+ return $file if -e $file;
+ }
+ else {
+ for (@e) {
+ return "$file$_" if -e "$file$_";
+ }
+ }
+ return;
+}
+
+sub file_name_is_absolute {
+ my($self,$file) = @_;
+ $file =~ m{^([a-z]:)?[\\/]}i ;
+}
+
+sub find_perl {
+ my($self, $ver, $names, $dirs, $trace) = @_;
+ my($name, $dir);
+ if ($trace >= 2){
+ print "Looking for perl $ver by these names:
+@$names
+in these dirs:
+@$dirs
+";
+ }
+ foreach $dir (@$dirs){
+ next unless defined $dir; # $self->{PERL_SRC} may be undefined
+ foreach $name (@$names){
+ my ($abs, $val);
+ if ($self->file_name_is_absolute($name)) { # /foo/bar
+ $abs = $name;
+ } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo
+ $abs = $self->catfile($dir, $name);
+ } else { # foo/bar
+ $abs = $self->canonpath($self->catfile($self->curdir, $name));
+ }
+ print "Checking $abs\n" if ($trace >= 2);
+ next unless $self->maybe_command($abs);
+ print "Executing $abs\n" if ($trace >= 2);
+ $val = `$abs -e "require $ver;" 2>&1`;
+ if ($? == 0) {
+ print "Using PERL=$abs\n" if $trace;
+ return $abs;
+ } elsif ($trace >= 2) {
+ print "Result: `$val'\n";
+ }
+ }
+ }
+ print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
+ 0; # false and not empty
+}
+
+sub catdir {
+ my $self = shift;
+ my @args = @_;
+ for (@args) {
+ # append a slash to each argument unless it has one there
+ $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\";
+ }
+ my $result = $self->canonpath(join('', @args));
+ $result;
+}
+
+=item catfile
+
+Concatenate one or more directory names and a filename to form a
+complete path ending with a filename
+
+=cut
+
+sub catfile {
+ my $self = shift @_;
+ my $file = pop @_;
+ return $file unless @_;
+ my $dir = $self->catdir(@_);
+ $dir =~ s/(\\\.)$//;
+ $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\";
+ return $dir.$file;
+}
+
+sub init_others
+{
+ my ($self) = @_;
+ &ExtUtils::MM_Unix::init_others;
+ $self->{'TOUCH'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e touch';
+ $self->{'CHMOD'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e chmod';
+ $self->{'CP'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e cp';
+ $self->{'RM_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_f';
+ $self->{'RM_RF'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e rm_rf';
+ $self->{'MV'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mv';
+ $self->{'NOOP'} = 'rem';
+ $self->{'TEST_F'} = '$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e test_f';
+ $self->{'LD'} = $Config{'ld'} || 'link';
+ $self->{'AR'} = $Config{'ar'} || 'lib';
+ $self->{'LDLOADLIBS'} ||= $Config{'libs'};
+ # -Lfoo must come first for Borland, so we put it in LDDLFLAGS
+ if ($BORLAND) {
+ my $libs = $self->{'LDLOADLIBS'};
+ my $libpath = '';
+ while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) {
+ $libpath .= ' ' if length $libpath;
+ $libpath .= $1;
+ }
+ $self->{'LDLOADLIBS'} = $libs;
+ $self->{'LDDLFLAGS'} ||= $Config{'lddlflags'};
+ $self->{'LDDLFLAGS'} .= " $libpath";
+ }
+ $self->{'DEV_NULL'} = '> NUL';
+ # $self->{'NOECHO'} = ''; # till we have it working
+}
+
+
+=item constants (o)
+
+Initializes lots of constants and .SUFFIXES and .PHONY
+
+=cut
+
+sub constants {
+ my($self) = @_;
+ my(@m,$tmp);
+
+ for $tmp (qw/
+
+ AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION
+ VERSION_SYM XS_VERSION INST_BIN INST_EXE INST_LIB
+ INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS
+ INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB
+ INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
+ PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
+ FIRST_MAKEFILE MAKE_APERL_FILE PERLMAINCC PERL_SRC
+ PERL_INC PERL FULLPERL
+
+ / ) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+ push @m, qq{
+VERSION_MACRO = VERSION
+DEFINE_VERSION = -D\$(VERSION_MACRO)=\\\"\$(VERSION)\\\"
+XS_VERSION_MACRO = XS_VERSION
+XS_DEFINE_VERSION = -D\$(XS_VERSION_MACRO)=\\\"\$(XS_VERSION)\\\"
+};
+
+ push @m, qq{
+MAKEMAKER = $INC{'ExtUtils\MakeMaker.pm'}
+MM_VERSION = $ExtUtils::MakeMaker::VERSION
+};
+
+ push @m, q{
+# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).
+# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)
+# ROOTEXT = Directory part of FULLEXT with leading slash (eg /DBD) !!! Deprecated from MM 5.32 !!!
+# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
+# DLBASE = Basename part of dynamic library. May be just equal BASEEXT.
+};
+
+ for $tmp (qw/
+ FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
+ LDFROM LINKTYPE
+ / ) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+ push @m, "
+# Handy lists of source code files:
+XS_FILES= ".join(" \\\n\t", sort keys %{$self->{XS}})."
+C_FILES = ".join(" \\\n\t", @{$self->{C}})."
+O_FILES = ".join(" \\\n\t", @{$self->{O_FILES}})."
+H_FILES = ".join(" \\\n\t", @{$self->{H}})."
+MAN1PODS = ".join(" \\\n\t", sort keys %{$self->{MAN1PODS}})."
+MAN3PODS = ".join(" \\\n\t", sort keys %{$self->{MAN3PODS}})."
+";
+
+ for $tmp (qw/
+ INST_MAN1DIR INSTALLMAN1DIR MAN1EXT INST_MAN3DIR INSTALLMAN3DIR MAN3EXT
+ /) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = $self->{$tmp}\n";
+ }
+
+ push @m, qq{
+.USESHELL :
+} if $DMAKE;
+
+ push @m, q{
+.NO_CONFIG_REC: Makefile
+} if $ENV{CLEARCASE_ROOT};
+
+ # why not q{} ? -- emacs
+ push @m, qq{
+# work around a famous dec-osf make(1) feature(?):
+makemakerdflt: all
+
+.SUFFIXES: .xs .c .C .cpp .cxx .cc \$(OBJ_EXT)
+
+# Nick wanted to get rid of .PRECIOUS. I don't remember why. I seem to recall, that
+# some make implementations will delete the Makefile when we rebuild it. Because
+# we call false(1) when we rebuild it. So make(1) is not completely wrong when it
+# does so. Our milage may vary.
+# .PRECIOUS: Makefile # seems to be not necessary anymore
+
+.PHONY: all config static dynamic test linkext manifest
+
+# Where is the Config information that we are using/depend on
+CONFIGDEP = \$(PERL_ARCHLIB)\\Config.pm \$(PERL_INC)\\config.h
+};
+
+ my @parentdir = split(/::/, $self->{PARENT_NAME});
+ push @m, q{
+# Where to put things:
+INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{
+INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{
+
+INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{
+INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{
+};
+
+ if ($self->has_link_code()) {
+ push @m, '
+INST_STATIC = $(INST_ARCHAUTODIR)\$(BASEEXT)$(LIB_EXT)
+INST_DYNAMIC = $(INST_ARCHAUTODIR)\$(DLBASE).$(DLEXT)
+INST_BOOT = $(INST_ARCHAUTODIR)\$(BASEEXT).bs
+';
+ } else {
+ push @m, '
+INST_STATIC =
+INST_DYNAMIC =
+INST_BOOT =
+';
+ }
+
+ $tmp = $self->export_list;
+ push @m, "
+EXPORT_LIST = $tmp
+";
+ $tmp = $self->perl_archive;
+ push @m, "
+PERL_ARCHIVE = $tmp
+";
+
+# push @m, q{
+#INST_PM = }.join(" \\\n\t", sort values %{$self->{PM}}).q{
+#
+#PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{
+#};
+
+ push @m, q{
+TO_INST_PM = }.join(" \\\n\t", sort keys %{$self->{PM}}).q{
+
+PM_TO_BLIB = }.join(" \\\n\t", %{$self->{PM}}).q{
+};
+
+ join('',@m);
+}
+
+
+sub path {
+ local $^W = 1;
+ my($self) = @_;
+ my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
+ my @path = split(';',$path);
+ foreach(@path) { $_ = '.' if $_ eq '' }
+ @path;
+}
+
+=item static_lib (o)
+
+Defines how to produce the *.a (or equivalent) files.
+
+=cut
+
+sub static_lib {
+ my($self) = @_;
+# Come to think of it, if there are subdirs with linkcode, we still have no INST_STATIC
+# return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code;
+
+ my(@m);
+ push(@m, <<'END');
+$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)\.exists
+ $(RM_RF) $@
+END
+ # If this extension has it's own library (eg SDBM_File)
+ # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
+ push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB};
+
+ push @m,
+q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")'
+ : ($GCC ? '-ru $@ $(OBJECT)'
+ : '-out:$@ $(OBJECT)')).q{
+ }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
+ $(CHMOD) 755 $@
+};
+
+# Old mechanism - still available:
+
+ push @m, "\t$self->{NOECHO}".q{echo "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs}."\n\n"
+ if $self->{PERL_SRC};
+
+ push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
+ join('', "\n",@m);
+}
+
+=item dynamic_bs (o)
+
+Defines targets for bootstrap files.
+
+=cut
+
+sub dynamic_bs {
+ my($self, %attribs) = @_;
+ return '
+BOOTSTRAP =
+' unless $self->has_link_code();
+
+ return '
+BOOTSTRAP = '."$self->{BASEEXT}.bs".'
+
+# As Mkbootstrap might not write a file (if none is required)
+# we use touch to prevent make continually trying to remake it.
+# The DynaLoader only reads a non-empty file.
+$(BOOTSTRAP): '."$self->{MAKEFILE} $self->{BOOTDEP}".' $(INST_ARCHAUTODIR)\.exists
+ '.$self->{NOECHO}.'echo "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))"
+ '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \
+ -MExtUtils::Mkbootstrap \
+ -e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');"
+ '.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP)
+ $(CHMOD) 644 $@
+
+$(INST_BOOT): $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists
+ '."$self->{NOECHO}$self->{RM_RF}".' $(INST_BOOT)
+ -'.$self->{CP}.' $(BOOTSTRAP) $(INST_BOOT)
+ $(CHMOD) 644 $@
+';
+}
+
+=item dynamic_lib (o)
+
+Defines how to produce the *.so (or equivalent) files.
+
+=cut
+
+sub dynamic_lib {
+ my($self, %attribs) = @_;
+ return '' unless $self->needs_linking(); #might be because of a subdir
+
+ return '' unless $self->has_link_code;
+
+ my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
+ my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
+ my($ldfrom) = '$(LDFROM)';
+ my(@m);
+ push(@m,'
+# This section creates the dynamically loadable $(INST_DYNAMIC)
+# from $(OBJECT) and possibly $(MYEXTLIB).
+OTHERLDFLAGS = '.$otherldflags.'
+INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
+
+$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)\.exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
+');
+ if ($GCC) {
+ push(@m,
+ q{ dlltool --def $(EXPORT_LIST) --output-exp dll.exp
+ $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp
+ dlltool --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp
+ $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp });
+ } else {
+ push(@m, $BORLAND ?
+ q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,),$(RESFILES)} :
+ q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)}
+ );
+ }
+ push @m, '
+ $(CHMOD) 755 $@
+';
+
+ push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
+ join('',@m);
+}
+
+sub perl_archive
+{
+ my ($self) = @_;
+ if($OBJ) {
+ if ($self->{CAPI} eq 'TRUE') {
+ return '$(PERL_INC)\perlCAPI$(LIB_EXT)';
+ }
+ }
+ return '$(PERL_INC)\\'.$Config{'libperl'};
+}
+
+sub export_list
+{
+ my ($self) = @_;
+ return "$self->{BASEEXT}.def";
+}
+
+=item canonpath
+
+No physical check on the filesystem, but a logical cleanup of a
+path. On UNIX eliminated successive slashes and successive "/.".
+
+=cut
+
+sub canonpath {
+ my($self,$path) = @_;
+ $path =~ s/^([a-z]:)/\u$1/;
+ $path =~ s|/|\\|g;
+ $path =~ s|(.)\\+|$1\\|g ; # xx////xx -> xx/xx
+ $path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx
+ $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx
+ $path =~ s|\\$||
+ unless $path =~ m#^([a-z]:)?\\#; # xx/ -> xx
+ $path .= '.' if $path =~ m#\\$#;
+ $path;
+}
+
+=item perl_script
+
+Takes one argument, a file name, and returns the file name, if the
+argument is likely to be a perl script. On MM_Unix this is true for
+any ordinary, readable file.
+
+=cut
+
+sub perl_script {
+ my($self,$file) = @_;
+ return "$file.pl" if -r "$file.pl" && -f _;
+ return;
+}
+
+=item pm_to_blib
+
+Defines target that copies all files in the hash PM to their
+destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION>
+
+=cut
+
+sub pm_to_blib {
+ my $self = shift;
+ my($autodir) = $self->catdir('$(INST_LIB)','auto');
+ return q{
+pm_to_blib: $(TO_INST_PM)
+ }.$self->{NOECHO}.q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" \
+ "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MExtUtils::Install \
+ -e "pm_to_blib(qw[ }.
+ ($NMAKE ? '<<pmfiles.dat'
+ : '$(mktmp,pmfiles.dat $(PM_TO_BLIB:s,\\,\\\\,)\n)').
+ q{ ],'}.$autodir.q{')"
+ }. ($NMAKE ? q{
+$(PM_TO_BLIB)
+<<
+ } : '') . $self->{NOECHO}.q{$(TOUCH) $@
+};
+}
+
+=item test_via_harness (o)
+
+Helper method to write the test targets
+
+=cut
+
+sub test_via_harness {
+ my($self, $perl, $tests) = @_;
+ "\t$perl".q! -Mblib -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e "use Test::Harness qw(&runtests $$verbose); $$verbose=$(TEST_VERBOSE); runtests @ARGV;" !."$tests\n";
+}
+
+
+=item tool_autosplit (override)
+
+Use Win32 quoting on command line.
+
+=cut
+
+sub tool_autosplit{
+ my($self, %attribs) = @_;
+ my($asl) = "";
+ $asl = "\$AutoSplit::Maxlen=$attribs{MAXLEN};" if $attribs{MAXLEN};
+ q{
+# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
+AUTOSPLITFILE = $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -MAutoSplit }.$asl.q{ -e "autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1);"
+};
+}
+
+=item tools_other (o)
+
+Win32 overrides.
+
+Defines SHELL, LD, TOUCH, CP, MV, RM_F, RM_RF, CHMOD, UMASK_NULL in
+the Makefile. Also defines the perl programs MKPATH,
+WARN_IF_OLD_PACKLIST, MOD_INSTALL. DOC_INSTALL, and UNINSTALL.
+
+=cut
+
+sub tools_other {
+ my($self) = shift;
+ my @m;
+ my $bin_sh = $Config{sh} || 'cmd /c';
+ push @m, qq{
+SHELL = $bin_sh
+} unless $DMAKE; # dmake determines its own shell
+
+ for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TEST_F TOUCH UMASK_NULL DEV_NULL/ ) {
+ push @m, "$_ = $self->{$_}\n";
+ }
+
+ push @m, q{
+# The following is a portable way to say mkdir -p
+# To see which directories are created, change the if 0 to if 1
+MKPATH = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e mkpath
+
+# This helps us to minimize the effect of the .exists files A yet
+# better solution would be to have a stable file in the perl
+# distribution with a timestamp of zero. But this solution doesn't
+# need any changes to the core distribution and works with older perls
+EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime
+};
+
+
+ return join "", @m if $self->{PARENT};
+
+ push @m, q{
+# Here we warn users that an old packlist file was found somewhere,
+# and that they should call some uninstall routine
+WARN_IF_OLD_PACKLIST = $(PERL) -lwe "exit unless -f $$ARGV[0];" \\
+-e "print 'WARNING: I have found an old package in';" \\
+-e "print ' ', $$ARGV[0], '.';" \\
+-e "print 'Please make sure the two installations are not conflicting';"
+
+UNINST=0
+VERBINST=1
+
+MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \
+-e "install({ @ARGV },'$(VERBINST)',0,'$(UNINST)');"
+
+DOC_INSTALL = $(PERL) -e "$$\=\"\n\n\";" \
+-e "print '=head2 ', scalar(localtime), ': C<', shift, '>', ' L<', shift, '>';" \
+-e "print '=over 4';" \
+-e "while (defined($$key = shift) and defined($$val = shift)) { print '=item *';print 'C<', \"$$key: $$val\", '>'; }" \
+-e "print '=back';"
+
+UNINSTALL = $(PERL) -MExtUtils::Install \
+-e "uninstall($$ARGV[0],1,1); print \"\nUninstall is deprecated. Please check the";" \
+-e "print \" packlist above carefully.\n There may be errors. Remove the\";" \
+-e "print \" appropriate files manually.\n Sorry for the inconveniences.\n\""
+};
+
+ return join "", @m;
+}
+
+=item xs_o (o)
+
+Defines suffix rules to go from XS to object files directly. This is
+only intended for broken make implementations.
+
+=cut
+
+sub xs_o { # many makes are too dumb to use xs_c then c_o
+ my($self) = shift;
+ return ''
+}
+
+=item top_targets (o)
+
+Defines the targets all, subdirs, config, and O_FILES
+
+=cut
+
+sub top_targets {
+# --- Target Sections ---
+
+ my($self) = shift;
+ my(@m);
+ push @m, '
+#all :: config $(INST_PM) subdirs linkext manifypods
+';
+
+ push @m, '
+all :: pure_all manifypods
+ '.$self->{NOECHO}.'$(NOOP)
+'
+ unless $self->{SKIPHASH}{'all'};
+
+ push @m, '
+pure_all :: config pm_to_blib subdirs linkext
+ '.$self->{NOECHO}.'$(NOOP)
+
+subdirs :: $(MYEXTLIB)
+ '.$self->{NOECHO}.'$(NOOP)
+
+config :: '.$self->{MAKEFILE}.' $(INST_LIBDIR)\.exists
+ '.$self->{NOECHO}.'$(NOOP)
+
+config :: $(INST_ARCHAUTODIR)\.exists
+ '.$self->{NOECHO}.'$(NOOP)
+
+config :: $(INST_AUTODIR)\.exists
+ '.$self->{NOECHO}.'$(NOOP)
+';
+
+ push @m, qq{
+config :: Version_check
+ $self->{NOECHO}\$(NOOP)
+
+} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC};
+
+ push @m, $self->dir_target(qw[$(INST_AUTODIR) $(INST_LIBDIR) $(INST_ARCHAUTODIR)]);
+
+ if (%{$self->{MAN1PODS}}) {
+ push @m, qq[
+config :: \$(INST_MAN1DIR)\\.exists
+ $self->{NOECHO}\$(NOOP)
+
+];
+ push @m, $self->dir_target(qw[$(INST_MAN1DIR)]);
+ }
+ if (%{$self->{MAN3PODS}}) {
+ push @m, qq[
+config :: \$(INST_MAN3DIR)\\.exists
+ $self->{NOECHO}\$(NOOP)
+
+];
+ push @m, $self->dir_target(qw[$(INST_MAN3DIR)]);
+ }
+
+ push @m, '
+$(O_FILES): $(H_FILES)
+' if @{$self->{O_FILES} || []} && @{$self->{H} || []};
+
+ push @m, q{
+help:
+ perldoc ExtUtils::MakeMaker
+};
+
+ push @m, q{
+Version_check:
+ }.$self->{NOECHO}.q{$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
+ -MExtUtils::MakeMaker=Version_check \
+ -e "Version_check('$(MM_VERSION)')"
+};
+
+ join('',@m);
+}
+
+=item manifypods (o)
+
+We don't want manpage process. XXX add pod2html support later.
+
+=cut
+
+sub manifypods {
+ my($self) = shift;
+ return "\nmanifypods :\n\t$self->{NOECHO}\$(NOOP)\n";
+}
+
+=item dist_ci (o)
+
+Same as MM_Unix version (changes command-line quoting).
+
+=cut
+
+sub dist_ci {
+ my($self) = shift;
+ my @m;
+ push @m, q{
+ci :
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=maniread \\
+ -e "@all = keys %{ maniread() };" \\
+ -e "print(\"Executing $(CI) @all\n\"); system(\"$(CI) @all\");" \\
+ -e "print(\"Executing $(RCS_LABEL) ...\n\"); system(\"$(RCS_LABEL) @all\");"
+};
+ join "", @m;
+}
+
+=item dist_core (o)
+
+Same as MM_Unix version (changes command-line quoting).
+
+=cut
+
+sub dist_core {
+ my($self) = shift;
+ my @m;
+ push @m, q{
+dist : $(DIST_DEFAULT)
+ }.$self->{NOECHO}.q{$(PERL) -le "print \"Warning: Makefile possibly out of date with $$vf\" if " \
+ -e "-e ($$vf=\"$(VERSION_FROM)\") and -M $$vf < -M \"}.$self->{MAKEFILE}.q{\";"
+
+tardist : $(DISTVNAME).tar$(SUFFIX)
+
+zipdist : $(DISTVNAME).zip
+
+$(DISTVNAME).tar$(SUFFIX) : distdir
+ $(PREOP)
+ $(TO_UNIX)
+ $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
+ $(RM_RF) $(DISTVNAME)
+ $(COMPRESS) $(DISTVNAME).tar
+ $(POSTOP)
+
+$(DISTVNAME).zip : distdir
+ $(PREOP)
+ $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+
+uutardist : $(DISTVNAME).tar$(SUFFIX)
+ uuencode $(DISTVNAME).tar$(SUFFIX) \\
+ $(DISTVNAME).tar$(SUFFIX) > \\
+ $(DISTVNAME).tar$(SUFFIX)_uu
+
+shdist : distdir
+ $(PREOP)
+ $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
+ $(RM_RF) $(DISTVNAME)
+ $(POSTOP)
+};
+ join "", @m;
+}
+
+=item pasthru (o)
+
+Defines the string that is passed to recursive make calls in
+subdirectories.
+
+=cut
+
+sub pasthru {
+ my($self) = shift;
+ return "PASTHRU = " . ($NMAKE ? "-nologo" : "");
+}
+
+
+
+1;
+__END__
+
+=back
+
+=cut
+
+
diff --git a/contrib/perl5/lib/ExtUtils/MakeMaker.pm b/contrib/perl5/lib/ExtUtils/MakeMaker.pm
new file mode 100644
index 000000000000..5b7bb0b6da04
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/MakeMaker.pm
@@ -0,0 +1,1933 @@
+BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatible with perl5.001m
+
+package ExtUtils::MakeMaker;
+
+$Version = $VERSION = "5.4301";
+$Version_OK = "5.17"; # Makefiles older than $Version_OK will die
+ # (Will be checked from MakeMaker version 4.13 onwards)
+($Revision = substr(q$Revision: 1.222 $, 10)) =~ s/\s+$//;
+
+
+
+require Exporter;
+use Config;
+use Carp ();
+#use FileHandle ();
+
+use vars qw(
+
+ @ISA @EXPORT @EXPORT_OK $AUTOLOAD
+ $ISA_TTY $Is_Mac $Is_OS2 $Is_VMS $Revision $Setup_done
+ $VERSION $Verbose $Version_OK %Config %Keep_after_flush
+ %MM_Sections %Prepend_dot_dot %Recognized_Att_Keys
+ @Get_from_Config @MM_Sections @Overridable @Parent
+
+ );
+# use strict;
+
+# &DynaLoader::mod2fname should be available to miniperl, thus
+# should be a pseudo-builtin (cmp. os2.c).
+#eval {require DynaLoader;};
+
+#
+# Set up the inheritance before we pull in the MM_* packages, because they
+# import variables and functions from here
+#
+@ISA = qw(Exporter);
+@EXPORT = qw(&WriteMakefile &writeMakefile $Verbose &prompt);
+@EXPORT_OK = qw($VERSION &Version_check &neatvalue &mkbootstrap &mksymlists
+ $Version);
+ # $Version in mixed case will go away!
+
+#
+# Dummy package MM inherits actual methods from OS-specific
+# default packages. We use this intermediate package so
+# MY::XYZ->func() can call MM->func() and get the proper
+# default routine without having to know under what OS
+# it's running.
+#
+@MM::ISA = qw[ExtUtils::MM_Unix ExtUtils::Liblist ExtUtils::MakeMaker];
+
+#
+# Setup dummy package:
+# MY exists for overriding methods to be defined within
+#
+{
+ package MY;
+ @MY::ISA = qw(MM);
+### sub AUTOLOAD { use Devel::Symdump; print Devel::Symdump->rnew->as_string; Carp::confess "hey why? $AUTOLOAD" }
+ package MM;
+ sub DESTROY {}
+}
+
+# "predeclare the package: we only load it via AUTOLOAD
+# but we have already mentioned it in @ISA
+package ExtUtils::Liblist;
+
+package ExtUtils::MakeMaker;
+#
+# Now we can pull in the friends
+#
+$Is_VMS = $^O eq 'VMS';
+$Is_OS2 = $^O eq 'os2';
+$Is_Mac = $^O eq 'MacOS';
+$Is_Win32 = $^O eq 'MSWin32';
+
+# This is for module authors to query, so they can enable 'CAPI' => 'TRUE'
+# in their Makefile.pl
+$CAPI_support = 1;
+
+require ExtUtils::MM_Unix;
+
+if ($Is_VMS) {
+ require ExtUtils::MM_VMS;
+ require VMS::Filespec; # is a noop as long as we require it within MM_VMS
+}
+if ($Is_OS2) {
+ require ExtUtils::MM_OS2;
+}
+if ($Is_Mac) {
+ require ExtUtils::MM_Mac;
+}
+if ($Is_Win32) {
+ require ExtUtils::MM_Win32;
+}
+
+# The SelfLoader would bring a lot of overhead for MakeMaker, because
+# we know for sure we will use most of the autoloaded functions once
+# we have to use one of them. So we write our own loader
+
+sub AUTOLOAD {
+ my $code;
+ if (defined fileno(DATA)) {
+ my $fh = select DATA;
+ my $o = $/; # For future reads from the file.
+ $/ = "\n__END__\n";
+ $code = <DATA>;
+ $/ = $o;
+ select $fh;
+ close DATA;
+ eval $code;
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ Carp::croak $@;
+ }
+ } else {
+ warn "AUTOLOAD called unexpectedly for $AUTOLOAD";
+ }
+ defined(&$AUTOLOAD) or die "Myloader inconsistency error";
+ goto &$AUTOLOAD;
+}
+
+# The only subroutine we do not SelfLoad is Version_Check because it's
+# called so often. Loading this minimum still requires 1.2 secs on my
+# Indy :-(
+
+sub Version_check {
+ my($checkversion) = @_;
+ die "Your Makefile was built with ExtUtils::MakeMaker v $checkversion.
+Current Version is $ExtUtils::MakeMaker::VERSION. There have been considerable
+changes in the meantime.
+Please rerun 'perl Makefile.PL' to regenerate the Makefile.\n"
+ if $checkversion < $Version_OK;
+ printf STDOUT "%s %s %s %s.\n", "Makefile built with ExtUtils::MakeMaker v",
+ $checkversion, "Current Version is", $VERSION
+ unless $checkversion == $VERSION;
+}
+
+sub warnhandler {
+ $_[0] =~ /^Use of uninitialized value/ && return;
+ $_[0] =~ /used only once/ && return;
+ $_[0] =~ /^Subroutine\s+[\w:]+\s+redefined/ && return;
+ warn @_;
+}
+
+sub ExtUtils::MakeMaker::eval_in_subdirs ;
+sub ExtUtils::MakeMaker::eval_in_x ;
+sub ExtUtils::MakeMaker::full_setup ;
+sub ExtUtils::MakeMaker::writeMakefile ;
+sub ExtUtils::MakeMaker::new ;
+sub ExtUtils::MakeMaker::check_manifest ;
+sub ExtUtils::MakeMaker::parse_args ;
+sub ExtUtils::MakeMaker::check_hints ;
+sub ExtUtils::MakeMaker::mv_all_methods ;
+sub ExtUtils::MakeMaker::skipcheck ;
+sub ExtUtils::MakeMaker::flush ;
+sub ExtUtils::MakeMaker::mkbootstrap ;
+sub ExtUtils::MakeMaker::mksymlists ;
+sub ExtUtils::MakeMaker::neatvalue ;
+sub ExtUtils::MakeMaker::selfdocument ;
+sub ExtUtils::MakeMaker::WriteMakefile ;
+sub ExtUtils::MakeMaker::prompt ($;$) ;
+
+1;
+
+__DATA__
+
+package ExtUtils::MakeMaker;
+
+sub WriteMakefile {
+ Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
+ local $SIG{__WARN__} = \&warnhandler;
+
+ unless ($Setup_done++){
+ full_setup();
+ undef &ExtUtils::MakeMaker::full_setup; #safe memory
+ }
+ my %att = @_;
+ MM->new(\%att)->flush;
+}
+
+sub prompt ($;$) {
+ my($mess,$def)=@_;
+ $ISA_TTY = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe?
+ Carp::confess("prompt function called without an argument") unless defined $mess;
+ my $dispdef = defined $def ? "[$def] " : " ";
+ $def = defined $def ? $def : "";
+ my $ans;
+ local $|=1;
+ print "$mess $dispdef";
+ if ($ISA_TTY) {
+ chomp($ans = <STDIN>);
+ } else {
+ print "$def\n";
+ }
+ return $ans || $def;
+}
+
+sub eval_in_subdirs {
+ my($self) = @_;
+ my($dir);
+ use Cwd 'cwd';
+ my $pwd = cwd();
+
+ foreach $dir (@{$self->{DIR}}){
+ my($abs) = $self->catdir($pwd,$dir);
+ $self->eval_in_x($abs);
+ }
+ chdir $pwd;
+}
+
+sub eval_in_x {
+ my($self,$dir) = @_;
+ package main;
+ chdir $dir or Carp::carp("Couldn't change to directory $dir: $!");
+# use FileHandle ();
+# my $fh = new FileHandle;
+# $fh->open("Makefile.PL") or Carp::carp("Couldn't open Makefile.PL in $dir");
+ local *FH;
+ open(FH,"Makefile.PL") or Carp::carp("Couldn't open Makefile.PL in $dir");
+# my $eval = join "", <$fh>;
+ my $eval = join "", <FH>;
+# $fh->close;
+ close FH;
+ eval $eval;
+ if ($@) {
+# if ($@ =~ /prerequisites/) {
+# die "MakeMaker WARNING: $@";
+# } else {
+# warn "WARNING from evaluation of $dir/Makefile.PL: $@";
+# }
+ warn "WARNING from evaluation of $dir/Makefile.PL: $@";
+ }
+}
+
+sub full_setup {
+ $Verbose ||= 0;
+ $^W=1;
+
+ # package name for the classes into which the first object will be blessed
+ $PACKNAME = "PACK000";
+
+ @Attrib_help = qw/
+
+ AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION LICENSE_HREF CAPI
+ C CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DL_FUNCS DL_VARS
+ EXE_FILES EXCLUDE_EXT INCLUDE_EXT NO_VC FIRST_MAKEFILE FULLPERL H
+ INC INSTALLARCHLIB INSTALLBIN INSTALLDIRS INSTALLMAN1DIR
+ INSTALLMAN3DIR INSTALLPRIVLIB INSTALLSCRIPT INSTALLSITEARCH
+ INSTALLSITELIB INST_ARCHLIB INST_BIN INST_EXE INST_LIB
+ INST_MAN1DIR INST_MAN3DIR INST_SCRIPT LDFROM LIBPERL_A LIB LIBS
+ LINKTYPE MAKEAPERL MAKEFILE MAN1PODS MAN3PODS MAP_TARGET MYEXTLIB
+ NAME NEEDS_LINKING NOECHO NORECURS OBJECT OPTIMIZE PERL PERLMAINCC
+ PERL_ARCHLIB PERL_LIB PERL_SRC PERM_RW PERM_RWX
+ PL_FILES PM PMLIBDIRS PREFIX
+ PREREQ_PM SKIP TYPEMAPS VERSION VERSION_FROM XS XSOPT XSPROTOARG
+ XS_VERSION clean depend dist dynamic_lib linkext macro realclean
+ tool_autosplit PPM_INSTALL_SCRIPT PPM_INSTALL_EXEC
+
+ IMPORTS
+
+ installpm
+ /;
+
+ # IMPORTS is used under OS/2
+
+ # ^^^ installpm is deprecated, will go about Summer 96
+
+ # @Overridable is close to @MM_Sections but not identical. The
+ # order is important. Many subroutines declare macros. These
+ # depend on each other. Let's try to collect the macros up front,
+ # then pasthru, then the rules.
+
+ # MM_Sections are the sections we have to call explicitly
+ # in Overridable we have subroutines that are used indirectly
+
+
+ @MM_Sections =
+ qw(
+
+ post_initialize const_config constants tool_autosplit tool_xsubpp
+ tools_other dist macro depend cflags const_loadlibs const_cccmd
+ post_constants
+
+ pasthru
+
+ c_o xs_c xs_o top_targets linkext dlsyms dynamic dynamic_bs
+ dynamic_lib static static_lib manifypods processPL installbin subdirs
+ clean realclean dist_basics dist_core dist_dir dist_test dist_ci
+ install force perldepend makefile staticmake test ppd
+
+ ); # loses section ordering
+
+ @Overridable = @MM_Sections;
+ push @Overridable, qw[
+
+ dir_target libscan makeaperl needs_linking perm_rw perm_rwx
+ subdir_x test_via_harness test_via_script
+
+ ];
+
+ push @MM_Sections, qw[
+
+ pm_to_blib selfdocument
+
+ ];
+
+ # Postamble needs to be the last that was always the case
+ push @MM_Sections, "postamble";
+ push @Overridable, "postamble";
+
+ # All sections are valid keys.
+ @Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections;
+
+ # we will use all these variables in the Makefile
+ @Get_from_Config =
+ qw(
+ ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc
+ lib_ext obj_ext osname osvers ranlib sitelibexp sitearchexp so exe_ext
+ );
+
+ my $item;
+ foreach $item (@Attrib_help){
+ $Recognized_Att_Keys{$item} = 1;
+ }
+ foreach $item (@Get_from_Config) {
+ $Recognized_Att_Keys{uc $item} = $Config{$item};
+ print "Attribute '\U$item\E' => '$Config{$item}'\n"
+ if ($Verbose >= 2);
+ }
+
+ #
+ # When we eval a Makefile.PL in a subdirectory, that one will ask
+ # us (the parent) for the values and will prepend "..", so that
+ # all files to be installed end up below OUR ./blib
+ #
+ %Prepend_dot_dot =
+ qw(
+
+ INST_BIN 1 INST_EXE 1 INST_LIB 1 INST_ARCHLIB 1 INST_SCRIPT
+ 1 MAP_TARGET 1 INST_MAN1DIR 1 INST_MAN3DIR 1 PERL_SRC 1
+ PERL 1 FULLPERL 1
+
+ );
+
+ my @keep = qw/
+ NEEDS_LINKING HAS_LINK_CODE
+ /;
+ @Keep_after_flush{@keep} = (1) x @keep;
+}
+
+sub writeMakefile {
+ die <<END;
+
+The extension you are trying to build apparently is rather old and
+most probably outdated. We detect that from the fact, that a
+subroutine "writeMakefile" is called, and this subroutine is not
+supported anymore since about October 1994.
+
+Please contact the author or look into CPAN (details about CPAN can be
+found in the FAQ and at http:/www.perl.com) for a more recent version
+of the extension. If you're really desperate, you can try to change
+the subroutine name from writeMakefile to WriteMakefile and rerun
+'perl Makefile.PL', but you're most probably left alone, when you do
+so.
+
+The MakeMaker team
+
+END
+}
+
+sub ExtUtils::MakeMaker::new {
+ my($class,$self) = @_;
+ my($key);
+
+ print STDOUT "MakeMaker (v$VERSION)\n" if $Verbose;
+ if (-f "MANIFEST" && ! -f "Makefile"){
+ check_manifest();
+ }
+
+ $self = {} unless (defined $self);
+
+ check_hints($self);
+
+ my(%initial_att) = %$self; # record initial attributes
+
+ my($prereq);
+ foreach $prereq (sort keys %{$self->{PREREQ_PM}}) {
+ my $eval = "use $prereq $self->{PREREQ_PM}->{$prereq}";
+ eval $eval;
+ if ($@){
+ warn "Warning: prerequisite $prereq $self->{PREREQ_PM}->{$prereq} not found";
+# Why is/was this 'delete' here? We need PREREQ_PM later to make PPDs.
+# } else {
+# delete $self->{PREREQ_PM}{$prereq};
+ }
+ }
+# if (@unsatisfied){
+# unless (defined $ExtUtils::MakeMaker::useCPAN) {
+# print qq{MakeMaker WARNING: prerequisites not found (@unsatisfied)
+# Please install these modules first and rerun 'perl Makefile.PL'.\n};
+# if ($ExtUtils::MakeMaker::hasCPAN) {
+# $ExtUtils::MakeMaker::useCPAN = prompt(qq{Should I try to use the CPAN module to fetch them for you?},"yes");
+# } else {
+# print qq{Hint: You may want to install the CPAN module to autofetch the needed modules\n};
+# $ExtUtils::MakeMaker::useCPAN=0;
+# }
+# }
+# if ($ExtUtils::MakeMaker::useCPAN) {
+# require CPAN;
+# CPAN->import(@unsatisfied);
+# } else {
+# die qq{prerequisites not found (@unsatisfied)};
+# }
+# warn qq{WARNING: prerequisites not found (@unsatisfied)};
+# }
+
+ if (defined $self->{CONFIGURE}) {
+ if (ref $self->{CONFIGURE} eq 'CODE') {
+ $self = { %$self, %{&{$self->{CONFIGURE}}}};
+ } else {
+ Carp::croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n";
+ }
+ }
+
+ # This is for old Makefiles written pre 5.00, will go away
+ if ( Carp::longmess("") =~ /runsubdirpl/s ){
+ Carp::carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n");
+ }
+
+ my $newclass = ++$PACKNAME;
+ {
+# no strict;
+ print "Blessing Object into class [$newclass]\n" if $Verbose>=2;
+ mv_all_methods("MY",$newclass);
+ bless $self, $newclass;
+ push @Parent, $self;
+ @{"$newclass\:\:ISA"} = 'MM';
+ }
+
+ if (defined $Parent[-2]){
+ $self->{PARENT} = $Parent[-2];
+ my $key;
+ for $key (keys %Prepend_dot_dot) {
+ next unless defined $self->{PARENT}{$key};
+ $self->{$key} = $self->{PARENT}{$key};
+ # PERL and FULLPERL may be command verbs instead of full
+ # file specifications under VMS. If so, don't turn them
+ # into a filespec.
+ $self->{$key} = $self->catdir("..",$self->{$key})
+ unless $self->file_name_is_absolute($self->{$key})
+ || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{$key} =~ /^[\w\-\$]+$/));
+ }
+ $self->{PARENT}->{CHILDREN}->{$newclass} = $self if $self->{PARENT};
+ } else {
+ parse_args($self,@ARGV);
+ }
+
+ $self->{NAME} ||= $self->guess_name;
+
+ ($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g;
+
+ $self->init_main();
+
+ if (! $self->{PERL_SRC} ) {
+ my($pthinks) = $self->canonpath($INC{'Config.pm'});
+ my($cthinks) = $self->catfile($Config{'archlibexp'},'Config.pm');
+ $pthinks = VMS::Filespec::vmsify($pthinks) if $Is_VMS;
+ if ($pthinks ne $cthinks &&
+ !($Is_Win32 and lc($pthinks) eq lc($cthinks))) {
+ print "Have $pthinks expected $cthinks\n";
+ if ($Is_Win32) {
+ $pthinks =~ s![/\\]Config\.pm$!!i; $pthinks =~ s!.*[/\\]!!;
+ }
+ else {
+ $pthinks =~ s!/Config\.pm$!!; $pthinks =~ s!.*/!!;
+ }
+ print STDOUT <<END;
+Your perl and your Config.pm seem to have different ideas about the architecture
+they are running on.
+Perl thinks: [$pthinks]
+Config says: [$Config{archname}]
+This may or may not cause problems. Please check your installation of perl if you
+have problems building this extension.
+END
+ }
+ }
+
+ $self->init_dirscan();
+ $self->init_others();
+
+ push @{$self->{RESULT}}, <<END;
+# This Makefile is for the $self->{NAME} extension to perl.
+#
+# It was generated automatically by MakeMaker version
+# $VERSION (Revision: $Revision) from the contents of
+# Makefile.PL. Don't edit this file, edit Makefile.PL instead.
+#
+# ANY CHANGES MADE HERE WILL BE LOST!
+#
+# MakeMaker Parameters:
+END
+
+ foreach $key (sort keys %initial_att){
+ my($v) = neatvalue($initial_att{$key});
+ $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
+ $v =~ tr/\n/ /s;
+ push @{$self->{RESULT}}, "# $key => $v";
+ }
+
+ # turn the SKIP array into a SKIPHASH hash
+ my (%skip,$skip);
+ for $skip (@{$self->{SKIP} || []}) {
+ $self->{SKIPHASH}{$skip} = 1;
+ }
+ delete $self->{SKIP}; # free memory
+
+ if ($self->{PARENT}) {
+ for (qw/install dist dist_basics dist_core dist_dir dist_test dist_ci/) {
+ $self->{SKIPHASH}{$_} = 1;
+ }
+ }
+
+ # We run all the subdirectories now. They don't have much to query
+ # from the parent, but the parent has to query them: if they need linking!
+ unless ($self->{NORECURS}) {
+ $self->eval_in_subdirs if @{$self->{DIR}};
+ }
+
+ my $section;
+ foreach $section ( @MM_Sections ){
+ print "Processing Makefile '$section' section\n" if ($Verbose >= 2);
+ my($skipit) = $self->skipcheck($section);
+ if ($skipit){
+ push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit.";
+ } else {
+ my(%a) = %{$self->{$section} || {}};
+ push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:";
+ push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a;
+ push @{$self->{RESULT}}, $self->nicetext($self->$section( %a ));
+ }
+ }
+
+ push @{$self->{RESULT}}, "\n# End.";
+ pop @Parent;
+
+ $self;
+}
+
+sub WriteEmptyMakefile {
+ if (-f 'Makefile.old') {
+ chmod 0666, 'Makefile.old';
+ unlink 'Makefile.old' or warn "unlink Makefile.old: $!";
+ }
+ rename 'Makefile', 'Makefile.old' or warn "rename Makefile Makefile.old: $!"
+ if -f 'Makefile';
+ open MF, '> Makefile' or die "open Makefile for write: $!";
+ print MF <<'EOP';
+all:
+
+clean:
+
+install:
+
+makemakerdflt:
+
+test:
+
+EOP
+ close MF or die "close Makefile for write: $!";
+}
+
+sub check_manifest {
+ print STDOUT "Checking if your kit is complete...\n";
+ require ExtUtils::Manifest;
+ $ExtUtils::Manifest::Quiet=$ExtUtils::Manifest::Quiet=1; #avoid warning
+ my(@missed)=ExtUtils::Manifest::manicheck();
+ if (@missed){
+ print STDOUT "Warning: the following files are missing in your kit:\n";
+ print "\t", join "\n\t", @missed;
+ print STDOUT "\n";
+ print STDOUT "Please inform the author.\n";
+ } else {
+ print STDOUT "Looks good\n";
+ }
+}
+
+sub parse_args{
+ my($self, @args) = @_;
+ foreach (@args){
+ unless (m/(.*?)=(.*)/){
+ help(),exit 1 if m/^help$/;
+ ++$Verbose if m/^verb/;
+ next;
+ }
+ my($name, $value) = ($1, $2);
+ if ($value =~ m/^~(\w+)?/){ # tilde with optional username
+ $value =~ s [^~(\w*)]
+ [$1 ?
+ ((getpwnam($1))[7] || "~$1") :
+ (getpwuid($>))[7]
+ ]ex;
+ }
+ $self->{uc($name)} = $value;
+ }
+
+ # catch old-style 'potential_libs' and inform user how to 'upgrade'
+ if (defined $self->{potential_libs}){
+ my($msg)="'potential_libs' => '$self->{potential_libs}' should be";
+ if ($self->{potential_libs}){
+ print STDOUT "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n";
+ } else {
+ print STDOUT "$msg deleted.\n";
+ }
+ $self->{LIBS} = [$self->{potential_libs}];
+ delete $self->{potential_libs};
+ }
+ # catch old-style 'ARMAYBE' and inform user how to 'upgrade'
+ if (defined $self->{ARMAYBE}){
+ my($armaybe) = $self->{ARMAYBE};
+ print STDOUT "ARMAYBE => '$armaybe' should be changed to:\n",
+ "\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n";
+ my(%dl) = %{$self->{dynamic_lib} || {}};
+ $self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe};
+ delete $self->{ARMAYBE};
+ }
+ if (defined $self->{LDTARGET}){
+ print STDOUT "LDTARGET should be changed to LDFROM\n";
+ $self->{LDFROM} = $self->{LDTARGET};
+ delete $self->{LDTARGET};
+ }
+ # Turn a DIR argument on the command line into an array
+ if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') {
+ # So they can choose from the command line, which extensions they want
+ # the grep enables them to have some colons too much in case they
+ # have to build a list with the shell
+ $self->{DIR} = [grep $_, split ":", $self->{DIR}];
+ }
+ # Turn a INCLUDE_EXT argument on the command line into an array
+ if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') {
+ $self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}];
+ }
+ # Turn a EXCLUDE_EXT argument on the command line into an array
+ if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') {
+ $self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}];
+ }
+ my $mmkey;
+ foreach $mmkey (sort keys %$self){
+ print STDOUT " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose;
+ print STDOUT "'$mmkey' is not a known MakeMaker parameter name.\n"
+ unless exists $Recognized_Att_Keys{$mmkey};
+ }
+ $| = 1 if $Verbose;
+}
+
+sub check_hints {
+ my($self) = @_;
+ # We allow extension-specific hints files.
+
+ return unless -d "hints";
+
+ # First we look for the best hintsfile we have
+ my(@goodhints);
+ my($hint)="${^O}_$Config{osvers}";
+ $hint =~ s/\./_/g;
+ $hint =~ s/_$//;
+ return unless $hint;
+
+ # Also try without trailing minor version numbers.
+ while (1) {
+ last if -f "hints/$hint.pl"; # found
+ } continue {
+ last unless $hint =~ s/_[^_]*$//; # nothing to cut off
+ }
+ return unless -f "hints/$hint.pl"; # really there
+
+ # execute the hintsfile:
+# use FileHandle ();
+# my $fh = new FileHandle;
+# $fh->open("hints/$hint.pl");
+ local *FH;
+ open(FH,"hints/$hint.pl");
+# @goodhints = <$fh>;
+ @goodhints = <FH>;
+# $fh->close;
+ close FH;
+ print STDOUT "Processing hints file hints/$hint.pl\n";
+ eval join('',@goodhints);
+ print STDOUT $@ if $@;
+}
+
+sub mv_all_methods {
+ my($from,$to) = @_;
+ my($method);
+ my($symtab) = \%{"${from}::"};
+# no strict;
+
+ # Here you see the *current* list of methods that are overridable
+ # from Makefile.PL via MY:: subroutines. As of VERSION 5.07 I'm
+ # still trying to reduce the list to some reasonable minimum --
+ # because I want to make it easier for the user. A.K.
+
+ foreach $method (@Overridable) {
+
+ # We cannot say "next" here. Nick might call MY->makeaperl
+ # which isn't defined right now
+
+ # Above statement was written at 4.23 time when Tk-b8 was
+ # around. As Tk-b9 only builds with 5.002something and MM 5 is
+ # standard, we try to enable the next line again. It was
+ # commented out until MM 5.23
+
+ next unless defined &{"${from}::$method"};
+
+ *{"${to}::$method"} = \&{"${from}::$method"};
+
+ # delete would do, if we were sure, nobody ever called
+ # MY->makeaperl directly
+
+ # delete $symtab->{$method};
+
+ # If we delete a method, then it will be undefined and cannot
+ # be called. But as long as we have Makefile.PLs that rely on
+ # %MY:: being intact, we have to fill the hole with an
+ # inheriting method:
+
+ eval "package MY; sub $method { shift->SUPER::$method(\@_); }";
+ }
+
+ # We have to clean out %INC also, because the current directory is
+ # changed frequently and Graham Barr prefers to get his version
+ # out of a History.pl file which is "required" so woudn't get
+ # loaded again in another extension requiring a History.pl
+
+ # With perl5.002_01 the deletion of entries in %INC caused Tk-b11
+ # to core dump in the middle of a require statement. The required
+ # file was Tk/MMutil.pm. The consequence is, we have to be
+ # extremely careful when we try to give perl a reason to reload a
+ # library with same name. The workaround prefers to drop nothing
+ # from %INC and teach the writers not to use such libraries.
+
+# my $inc;
+# foreach $inc (keys %INC) {
+# #warn "***$inc*** deleted";
+# delete $INC{$inc};
+# }
+}
+
+sub skipcheck {
+ my($self) = shift;
+ my($section) = @_;
+ if ($section eq 'dynamic') {
+ print STDOUT "Warning (non-fatal): Target 'dynamic' depends on targets ",
+ "in skipped section 'dynamic_bs'\n"
+ if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
+ print STDOUT "Warning (non-fatal): Target 'dynamic' depends on targets ",
+ "in skipped section 'dynamic_lib'\n"
+ if $self->{SKIPHASH}{dynamic_lib} && $Verbose;
+ }
+ if ($section eq 'dynamic_lib') {
+ print STDOUT "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ",
+ "targets in skipped section 'dynamic_bs'\n"
+ if $self->{SKIPHASH}{dynamic_bs} && $Verbose;
+ }
+ if ($section eq 'static') {
+ print STDOUT "Warning (non-fatal): Target 'static' depends on targets ",
+ "in skipped section 'static_lib'\n"
+ if $self->{SKIPHASH}{static_lib} && $Verbose;
+ }
+ return 'skipped' if $self->{SKIPHASH}{$section};
+ return '';
+}
+
+sub flush {
+ my $self = shift;
+ my($chunk);
+# use FileHandle ();
+# my $fh = new FileHandle;
+ local *FH;
+ print STDOUT "Writing $self->{MAKEFILE} for $self->{NAME}\n";
+
+ unlink($self->{MAKEFILE}, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : '');
+# $fh->open(">MakeMaker.tmp") or die "Unable to open MakeMaker.tmp: $!";
+ open(FH,">MakeMaker.tmp") or die "Unable to open MakeMaker.tmp: $!";
+
+ for $chunk (@{$self->{RESULT}}) {
+# print $fh "$chunk\n";
+ print FH "$chunk\n";
+ }
+
+# $fh->close;
+ close FH;
+ my($finalname) = $self->{MAKEFILE};
+ rename("MakeMaker.tmp", $finalname);
+ chmod 0644, $finalname unless $Is_VMS;
+
+ if ($self->{PARENT}) {
+ foreach (keys %$self) { # safe memory
+ delete $self->{$_} unless $Keep_after_flush{$_};
+ }
+ }
+
+ system("$Config::Config{eunicefix} $finalname") unless $Config::Config{eunicefix} eq ":";
+}
+
+# The following mkbootstrap() is only for installations that are calling
+# the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker
+# writes Makefiles, that use ExtUtils::Mkbootstrap directly.
+sub mkbootstrap {
+ die <<END;
+!!! Your Makefile has been built such a long time ago, !!!
+!!! that is unlikely to work with current MakeMaker. !!!
+!!! Please rebuild your Makefile !!!
+END
+}
+
+# Ditto for mksymlists() as of MakeMaker 5.17
+sub mksymlists {
+ die <<END;
+!!! Your Makefile has been built such a long time ago, !!!
+!!! that is unlikely to work with current MakeMaker. !!!
+!!! Please rebuild your Makefile !!!
+END
+}
+
+sub neatvalue {
+ my($v) = @_;
+ return "undef" unless defined $v;
+ my($t) = ref $v;
+ return "q[$v]" unless $t;
+ if ($t eq 'ARRAY') {
+ my(@m, $elem, @neat);
+ push @m, "[";
+ foreach $elem (@$v) {
+ push @neat, "q[$elem]";
+ }
+ push @m, join ", ", @neat;
+ push @m, "]";
+ return join "", @m;
+ }
+ return "$v" unless $t eq 'HASH';
+ my(@m, $key, $val);
+ while (($key,$val) = each %$v){
+ last unless defined $key; # cautious programming in case (undef,undef) is true
+ push(@m,"$key=>".neatvalue($val)) ;
+ }
+ return "{ ".join(', ',@m)." }";
+}
+
+sub selfdocument {
+ my($self) = @_;
+ my(@m);
+ if ($Verbose){
+ push @m, "\n# Full list of MakeMaker attribute values:";
+ foreach $key (sort keys %$self){
+ next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/;
+ my($v) = neatvalue($self->{$key});
+ $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/;
+ $v =~ tr/\n/ /s;
+ push @m, "# $key => $v";
+ }
+ }
+ join "\n", @m;
+}
+
+package ExtUtils::MakeMaker;
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::MakeMaker - create an extension Makefile
+
+=head1 SYNOPSIS
+
+C<use ExtUtils::MakeMaker;>
+
+C<WriteMakefile( ATTRIBUTE =E<gt> VALUE [, ...] );>
+
+which is really
+
+C<MM-E<gt>new(\%att)-E<gt>flush;>
+
+=head1 DESCRIPTION
+
+This utility is designed to write a Makefile for an extension module
+from a Makefile.PL. It is based on the Makefile.SH model provided by
+Andy Dougherty and the perl5-porters.
+
+It splits the task of generating the Makefile into several subroutines
+that can be individually overridden. Each subroutine returns the text
+it wishes to have written to the Makefile.
+
+MakeMaker is object oriented. Each directory below the current
+directory that contains a Makefile.PL. Is treated as a separate
+object. This makes it possible to write an unlimited number of
+Makefiles with a single invocation of WriteMakefile().
+
+=head2 How To Write A Makefile.PL
+
+The short answer is: Don't.
+
+ Always begin with h2xs.
+ Always begin with h2xs!
+ ALWAYS BEGIN WITH H2XS!
+
+even if you're not building around a header file, and even if you
+don't have an XS component.
+
+Run h2xs(1) before you start thinking about writing a module. For so
+called pm-only modules that consist of C<*.pm> files only, h2xs has
+the C<-X> switch. This will generate dummy files of all kinds that are
+useful for the module developer.
+
+The medium answer is:
+
+ use ExtUtils::MakeMaker;
+ WriteMakefile( NAME => "Foo::Bar" );
+
+The long answer is the rest of the manpage :-)
+
+=head2 Default Makefile Behaviour
+
+The generated Makefile enables the user of the extension to invoke
+
+ perl Makefile.PL # optionally "perl Makefile.PL verbose"
+ make
+ make test # optionally set TEST_VERBOSE=1
+ make install # See below
+
+The Makefile to be produced may be altered by adding arguments of the
+form C<KEY=VALUE>. E.g.
+
+ perl Makefile.PL PREFIX=/tmp/myperl5
+
+Other interesting targets in the generated Makefile are
+
+ make config # to check if the Makefile is up-to-date
+ make clean # delete local temp files (Makefile gets renamed)
+ make realclean # delete derived files (including ./blib)
+ make ci # check in all the files in the MANIFEST file
+ make dist # see below the Distribution Support section
+
+=head2 make test
+
+MakeMaker checks for the existence of a file named F<test.pl> in the
+current directory and if it exists it adds commands to the test target
+of the generated Makefile that will execute the script with the proper
+set of perl C<-I> options.
+
+MakeMaker also checks for any files matching glob("t/*.t"). It will
+add commands to the test target of the generated Makefile that execute
+all matching files via the L<Test::Harness> module with the C<-I>
+switches set correctly.
+
+=head2 make testdb
+
+A useful variation of the above is the target C<testdb>. It runs the
+test under the Perl debugger (see L<perldebug>). If the file
+F<test.pl> exists in the current directory, it is used for the test.
+
+If you want to debug some other testfile, set C<TEST_FILE> variable
+thusly:
+
+ make testdb TEST_FILE=t/mytest.t
+
+By default the debugger is called using C<-d> option to perl. If you
+want to specify some other option, set C<TESTDB_SW> variable:
+
+ make testdb TESTDB_SW=-Dx
+
+=head2 make install
+
+make alone puts all relevant files into directories that are named by
+the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR, and
+INST_MAN3DIR. All these default to something below ./blib if you are
+I<not> building below the perl source directory. If you I<are>
+building below the perl source, INST_LIB and INST_ARCHLIB default to
+ ../../lib, and INST_SCRIPT is not defined.
+
+The I<install> target of the generated Makefile copies the files found
+below each of the INST_* directories to their INSTALL*
+counterparts. Which counterparts are chosen depends on the setting of
+INSTALLDIRS according to the following table:
+
+ INSTALLDIRS set to
+ perl site
+
+ INST_ARCHLIB INSTALLARCHLIB INSTALLSITEARCH
+ INST_LIB INSTALLPRIVLIB INSTALLSITELIB
+ INST_BIN INSTALLBIN
+ INST_SCRIPT INSTALLSCRIPT
+ INST_MAN1DIR INSTALLMAN1DIR
+ INST_MAN3DIR INSTALLMAN3DIR
+
+The INSTALL... macros in turn default to their %Config
+($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts.
+
+You can check the values of these variables on your system with
+
+ perl '-V:install.*'
+
+And to check the sequence in which the library directories are
+searched by perl, run
+
+ perl -le 'print join $/, @INC'
+
+
+=head2 PREFIX and LIB attribute
+
+PREFIX and LIB can be used to set several INSTALL* attributes in one
+go. The quickest way to install a module in a non-standard place might
+be
+
+ perl Makefile.PL LIB=~/lib
+
+This will install the module's architecture-independent files into
+~/lib, the architecture-dependent files into ~/lib/$archname/auto.
+
+Another way to specify many INSTALL directories with a single
+parameter is PREFIX.
+
+ perl Makefile.PL PREFIX=~
+
+This will replace the string specified by $Config{prefix} in all
+$Config{install*} values.
+
+Note, that in both cases the tilde expansion is done by MakeMaker, not
+by perl by default, nor by make. Conflicts between parmeters LIB,
+PREFIX and the various INSTALL* arguments are resolved so that
+XXX
+
+If the user has superuser privileges, and is not working on AFS
+(Andrew File System) or relatives, then the defaults for
+INSTALLPRIVLIB, INSTALLARCHLIB, INSTALLSCRIPT, etc. will be appropriate,
+and this incantation will be the best:
+
+ perl Makefile.PL; make; make test
+ make install
+
+make install per default writes some documentation of what has been
+done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This feature
+can be bypassed by calling make pure_install.
+
+=head2 AFS users
+
+will have to specify the installation directories as these most
+probably have changed since perl itself has been installed. They will
+have to do this by calling
+
+ perl Makefile.PL INSTALLSITELIB=/afs/here/today \
+ INSTALLSCRIPT=/afs/there/now INSTALLMAN3DIR=/afs/for/manpages
+ make
+
+Be careful to repeat this procedure every time you recompile an
+extension, unless you are sure the AFS installation directories are
+still valid.
+
+=head2 Static Linking of a new Perl Binary
+
+An extension that is built with the above steps is ready to use on
+systems supporting dynamic loading. On systems that do not support
+dynamic loading, any newly created extension has to be linked together
+with the available resources. MakeMaker supports the linking process
+by creating appropriate targets in the Makefile whenever an extension
+is built. You can invoke the corresponding section of the makefile with
+
+ make perl
+
+That produces a new perl binary in the current directory with all
+extensions linked in that can be found in INST_ARCHLIB , SITELIBEXP,
+and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on
+UNIX, this is called Makefile.aperl (may be system dependent). If you
+want to force the creation of a new perl, it is recommended, that you
+delete this Makefile.aperl, so the directories are searched-through
+for linkable libraries again.
+
+The binary can be installed into the directory where perl normally
+resides on your machine with
+
+ make inst_perl
+
+To produce a perl binary with a different name than C<perl>, either say
+
+ perl Makefile.PL MAP_TARGET=myperl
+ make myperl
+ make inst_perl
+
+or say
+
+ perl Makefile.PL
+ make myperl MAP_TARGET=myperl
+ make inst_perl MAP_TARGET=myperl
+
+In any case you will be prompted with the correct invocation of the
+C<inst_perl> target that installs the new binary into INSTALLBIN.
+
+make inst_perl per default writes some documentation of what has been
+done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This
+can be bypassed by calling make pure_inst_perl.
+
+Warning: the inst_perl: target will most probably overwrite your
+existing perl binary. Use with care!
+
+Sometimes you might want to build a statically linked perl although
+your system supports dynamic loading. In this case you may explicitly
+set the linktype with the invocation of the Makefile.PL or make:
+
+ perl Makefile.PL LINKTYPE=static # recommended
+
+or
+
+ make LINKTYPE=static # works on most systems
+
+=head2 Determination of Perl Library and Installation Locations
+
+MakeMaker needs to know, or to guess, where certain things are
+located. Especially INST_LIB and INST_ARCHLIB (where to put the files
+during the make(1) run), PERL_LIB and PERL_ARCHLIB (where to read
+existing modules from), and PERL_INC (header files and C<libperl*.*>).
+
+Extensions may be built either using the contents of the perl source
+directory tree or from the installed perl library. The recommended way
+is to build extensions after you have run 'make install' on perl
+itself. You can do that in any directory on your hard disk that is not
+below the perl source tree. The support for extensions below the ext
+directory of the perl distribution is only good for the standard
+extensions that come with perl.
+
+If an extension is being built below the C<ext/> directory of the perl
+source then MakeMaker will set PERL_SRC automatically (e.g.,
+C<../..>). If PERL_SRC is defined and the extension is recognized as
+a standard extension, then other variables default to the following:
+
+ PERL_INC = PERL_SRC
+ PERL_LIB = PERL_SRC/lib
+ PERL_ARCHLIB = PERL_SRC/lib
+ INST_LIB = PERL_LIB
+ INST_ARCHLIB = PERL_ARCHLIB
+
+If an extension is being built away from the perl source then MakeMaker
+will leave PERL_SRC undefined and default to using the installed copy
+of the perl library. The other variables default to the following:
+
+ PERL_INC = $archlibexp/CORE
+ PERL_LIB = $privlibexp
+ PERL_ARCHLIB = $archlibexp
+ INST_LIB = ./blib/lib
+ INST_ARCHLIB = ./blib/arch
+
+If perl has not yet been installed then PERL_SRC can be defined on the
+command line as shown in the previous section.
+
+
+=head2 Which architecture dependent directory?
+
+If you don't want to keep the defaults for the INSTALL* macros,
+MakeMaker helps you to minimize the typing needed: the usual
+relationship between INSTALLPRIVLIB and INSTALLARCHLIB is determined
+by Configure at perl compilation time. MakeMaker supports the user who
+sets INSTALLPRIVLIB. If INSTALLPRIVLIB is set, but INSTALLARCHLIB not,
+then MakeMaker defaults the latter to be the same subdirectory of
+INSTALLPRIVLIB as Configure decided for the counterparts in %Config ,
+otherwise it defaults to INSTALLPRIVLIB. The same relationship holds
+for INSTALLSITELIB and INSTALLSITEARCH.
+
+MakeMaker gives you much more freedom than needed to configure
+internal variables and get different results. It is worth to mention,
+that make(1) also lets you configure most of the variables that are
+used in the Makefile. But in the majority of situations this will not
+be necessary, and should only be done, if the author of a package
+recommends it (or you know what you're doing).
+
+=head2 Using Attributes and Parameters
+
+The following attributes can be specified as arguments to WriteMakefile()
+or as NAME=VALUE pairs on the command line:
+
+=cut
+
+# The following "=item C" is used by the attrib_help routine
+# likewise the "=back" below. So be careful when changing it!
+
+=over 2
+
+=item C
+
+Ref to array of *.c file names. Initialised from a directory scan
+and the values portion of the XS attribute hash. This is not
+currently used by MakeMaker but may be handy in Makefile.PLs.
+
+=item CCFLAGS
+
+String that will be included in the compiler call command line between
+the arguments INC and OPTIMIZE.
+
+=item CONFIG
+
+Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from
+config.sh. MakeMaker will add to CONFIG the following values anyway:
+ar
+cc
+cccdlflags
+ccdlflags
+dlext
+dlsrc
+ld
+lddlflags
+ldflags
+libc
+lib_ext
+obj_ext
+ranlib
+sitelibexp
+sitearchexp
+so
+
+=item CONFIGURE
+
+CODE reference. The subroutine should return a hash reference. The
+hash may contain further attributes, e.g. {LIBS =E<gt> ...}, that have to
+be determined by some evaluation method.
+
+=item DEFINE
+
+Something like C<"-DHAVE_UNISTD_H">
+
+=item DIR
+
+Ref to array of subdirectories containing Makefile.PLs e.g. [ 'sdbm'
+] in ext/SDBM_File
+
+=item DISTNAME
+
+Your name for distributing the package (by tar file). This defaults to
+NAME above.
+
+=item DL_FUNCS
+
+Hashref of symbol names for routines to be made available as
+universal symbols. Each key/value pair consists of the package name
+and an array of routine names in that package. Used only under AIX
+(export lists) and VMS (linker options) at present. The routine
+names supplied will be expanded in the same way as XSUB names are
+expanded by the XS() macro. Defaults to
+
+ {"$(NAME)" => ["boot_$(NAME)" ] }
+
+e.g.
+
+ {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )],
+ "NetconfigPtr" => [ 'DESTROY'] }
+
+=item DL_VARS
+
+Array of symbol names for variables to be made available as
+universal symbols. Used only under AIX (export lists) and VMS
+(linker options) at present. Defaults to []. (e.g. [ qw(
+Foo_version Foo_numstreams Foo_tree ) ])
+
+=item EXCLUDE_EXT
+
+Array of extension names to exclude when doing a static build. This
+is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more
+details. (e.g. [ qw( Socket POSIX ) ] )
+
+This attribute may be most useful when specified as a string on the
+commandline: perl Makefile.PL EXCLUDE_EXT='Socket Safe'
+
+=item EXE_FILES
+
+Ref to array of executable files. The files will be copied to the
+INST_SCRIPT directory. Make realclean will delete them from there
+again.
+
+=item NO_VC
+
+In general any generated Makefile checks for the current version of
+MakeMaker and the version the Makefile was built under. If NO_VC is
+set, the version check is neglected. Do not write this into your
+Makefile.PL, use it interactively instead.
+
+=item FIRST_MAKEFILE
+
+The name of the Makefile to be produced. Defaults to the contents of
+MAKEFILE, but can be overridden. This is used for the second Makefile
+that will be produced for the MAP_TARGET.
+
+=item FULLPERL
+
+Perl binary able to run this extension.
+
+=item H
+
+Ref to array of *.h file names. Similar to C.
+
+=item IMPORTS
+
+IMPORTS is only used on OS/2.
+
+=item INC
+
+Include file dirs eg: C<"-I/usr/5include -I/path/to/inc">
+
+=item INCLUDE_EXT
+
+Array of extension names to be included when doing a static build.
+MakeMaker will normally build with all of the installed extensions when
+doing a static build, and that is usually the desired behavior. If
+INCLUDE_EXT is present then MakeMaker will build only with those extensions
+which are explicitly mentioned. (e.g. [ qw( Socket POSIX ) ])
+
+It is not necessary to mention DynaLoader or the current extension when
+filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then
+only DynaLoader and the current extension will be included in the build.
+
+This attribute may be most useful when specified as a string on the
+commandline: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek'
+
+=item INSTALLARCHLIB
+
+Used by 'make install', which copies files from INST_ARCHLIB to this
+directory if INSTALLDIRS is set to perl.
+
+=item INSTALLBIN
+
+Directory to install binary files (e.g. tkperl) into.
+
+=item INSTALLDIRS
+
+Determines which of the two sets of installation directories to
+choose: installprivlib and installarchlib versus installsitelib and
+installsitearch. The first pair is chosen with INSTALLDIRS=perl, the
+second with INSTALLDIRS=site. Default is site.
+
+=item INSTALLMAN1DIR
+
+This directory gets the man pages at 'make install' time. Defaults to
+$Config{installman1dir}.
+
+=item INSTALLMAN3DIR
+
+This directory gets the man pages at 'make install' time. Defaults to
+$Config{installman3dir}.
+
+=item INSTALLPRIVLIB
+
+Used by 'make install', which copies files from INST_LIB to this
+directory if INSTALLDIRS is set to perl.
+
+=item INSTALLSCRIPT
+
+Used by 'make install' which copies files from INST_SCRIPT to this
+directory.
+
+=item INSTALLSITELIB
+
+Used by 'make install', which copies files from INST_LIB to this
+directory if INSTALLDIRS is set to site (default).
+
+=item INSTALLSITEARCH
+
+Used by 'make install', which copies files from INST_ARCHLIB to this
+directory if INSTALLDIRS is set to site (default).
+
+=item INST_ARCHLIB
+
+Same as INST_LIB for architecture dependent files.
+
+=item INST_BIN
+
+Directory to put real binary files during 'make'. These will be copied
+to INSTALLBIN during 'make install'
+
+=item INST_EXE
+
+Old name for INST_SCRIPT. Deprecated. Please use INST_SCRIPT if you
+need to use it.
+
+=item INST_LIB
+
+Directory where we put library files of this extension while building
+it.
+
+=item INST_MAN1DIR
+
+Directory to hold the man pages at 'make' time
+
+=item INST_MAN3DIR
+
+Directory to hold the man pages at 'make' time
+
+=item INST_SCRIPT
+
+Directory, where executable files should be installed during
+'make'. Defaults to "./blib/bin", just to have a dummy location during
+testing. make install will copy the files in INST_SCRIPT to
+INSTALLSCRIPT.
+
+=item LDFROM
+
+defaults to "$(OBJECT)" and is used in the ld command to specify
+what files to link/load from (also see dynamic_lib below for how to
+specify ld flags)
+
+=item LIBPERL_A
+
+The filename of the perllibrary that will be used together with this
+extension. Defaults to libperl.a.
+
+=item LIB
+
+LIB can only be set at C<perl Makefile.PL> time. It has the effect of
+setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any
+
+=item LIBS
+
+An anonymous array of alternative library
+specifications to be searched for (in order) until
+at least one library is found. E.g.
+
+ 'LIBS' => ["-lgdbm", "-ldbm -lfoo", "-L/path -ldbm.nfs"]
+
+Mind, that any element of the array
+contains a complete set of arguments for the ld
+command. So do not specify
+
+ 'LIBS' => ["-ltcl", "-ltk", "-lX11"]
+
+See ODBM_File/Makefile.PL for an example, where an array is needed. If
+you specify a scalar as in
+
+ 'LIBS' => "-ltcl -ltk -lX11"
+
+MakeMaker will turn it into an array with one element.
+
+=item LINKTYPE
+
+'static' or 'dynamic' (default unless usedl=undef in
+config.sh). Should only be used to force static linking (also see
+linkext below).
+
+=item MAKEAPERL
+
+Boolean which tells MakeMaker, that it should include the rules to
+make a perl. This is handled automatically as a switch by
+MakeMaker. The user normally does not need it.
+
+=item MAKEFILE
+
+The name of the Makefile to be produced.
+
+=item MAN1PODS
+
+Hashref of pod-containing files. MakeMaker will default this to all
+EXE_FILES files that include POD directives. The files listed
+here will be converted to man pages and installed as was requested
+at Configure time.
+
+=item MAN3PODS
+
+Hashref of .pm and .pod files. MakeMaker will default this to all
+ .pod and any .pm files that include POD directives. The files listed
+here will be converted to man pages and installed as was requested
+at Configure time.
+
+=item MAP_TARGET
+
+If it is intended, that a new perl binary be produced, this variable
+may hold a name for that binary. Defaults to perl
+
+=item MYEXTLIB
+
+If the extension links to a library that it builds set this to the
+name of the library (see SDBM_File)
+
+=item NAME
+
+Perl module name for this extension (DBD::Oracle). This will default
+to the directory name but should be explicitly defined in the
+Makefile.PL.
+
+=item NEEDS_LINKING
+
+MakeMaker will figure out, if an extension contains linkable code
+anywhere down the directory tree, and will set this variable
+accordingly, but you can speed it up a very little bit, if you define
+this boolean variable yourself.
+
+=item NOECHO
+
+Defaults to C<@>. By setting it to an empty string you can generate a
+Makefile that echos all commands. Mainly used in debugging MakeMaker
+itself.
+
+=item NORECURS
+
+Boolean. Attribute to inhibit descending into subdirectories.
+
+=item OBJECT
+
+List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long
+string containing all object files, e.g. "tkpBind.o
+tkpButton.o tkpCanvas.o"
+
+=item OPTIMIZE
+
+Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is
+passed to subdirectory makes.
+
+=item PERL
+
+Perl binary for tasks that can be done by miniperl
+
+=item PERLMAINCC
+
+The call to the program that is able to compile perlmain.c. Defaults
+to $(CC).
+
+=item PERL_ARCHLIB
+
+Same as above for architecture dependent files
+
+=item PERL_LIB
+
+Directory containing the Perl library to use.
+
+=item PERL_SRC
+
+Directory containing the Perl source code (use of this should be
+avoided, it may be undefined)
+
+=item PERM_RW
+
+Desired Permission for read/writable files. Defaults to C<644>.
+See also L<MM_Unix/perm_rw>.
+
+=item PERM_RWX
+
+Desired permission for executable files. Defaults to C<755>.
+See also L<MM_Unix/perm_rwx>.
+
+=item PL_FILES
+
+Ref to hash of files to be processed as perl programs. MakeMaker
+will default to any found *.PL file (except Makefile.PL) being keys
+and the basename of the file being the value. E.g.
+
+ {'foobar.PL' => 'foobar'}
+
+The *.PL files are expected to produce output to the target files
+themselves.
+
+=item PM
+
+Hashref of .pm files and *.pl files to be installed. e.g.
+
+ {'name_of_file.pm' => '$(INST_LIBDIR)/install_as.pm'}
+
+By default this will include *.pm and *.pl and the files found in
+the PMLIBDIRS directories. Defining PM in the
+Makefile.PL will override PMLIBDIRS.
+
+=item PMLIBDIRS
+
+Ref to array of subdirectories containing library files. Defaults to
+[ 'lib', $(BASEEXT) ]. The directories will be scanned and I<any> files
+they contain will be installed in the corresponding location in the
+library. A libscan() method can be used to alter the behaviour.
+Defining PM in the Makefile.PL will override PMLIBDIRS.
+
+=item PREFIX
+
+Can be used to set the three INSTALL* attributes in one go (except for
+probably INSTALLMAN1DIR, if it is not below PREFIX according to
+%Config). They will have PREFIX as a common directory node and will
+branch from that node into lib/, lib/ARCHNAME or whatever Configure
+decided at the build time of your perl (unless you override one of
+them, of course).
+
+=item PREREQ_PM
+
+Hashref: Names of modules that need to be available to run this
+extension (e.g. Fcntl for SDBM_File) are the keys of the hash and the
+desired version is the value. If the required version number is 0, we
+only check if any version is installed already.
+
+=item SKIP
+
+Arryref. E.g. [qw(name1 name2)] skip (do not write) sections of the
+Makefile. Caution! Do not use the SKIP attribute for the neglectible
+speedup. It may seriously damage the resulting Makefile. Only use it,
+if you really need it.
+
+=item TYPEMAPS
+
+Ref to array of typemap file names. Use this when the typemaps are
+in some directory other than the current directory or when they are
+not named B<typemap>. The last typemap in the list takes
+precedence. A typemap in the current directory has highest
+precedence, even if it isn't listed in TYPEMAPS. The default system
+typemap has lowest precedence.
+
+=item VERSION
+
+Your version number for distributing the package. This defaults to
+0.1.
+
+=item VERSION_FROM
+
+Instead of specifying the VERSION in the Makefile.PL you can let
+MakeMaker parse a file to determine the version number. The parsing
+routine requires that the file named by VERSION_FROM contains one
+single line to compute the version number. The first line in the file
+that contains the regular expression
+
+ /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/
+
+will be evaluated with eval() and the value of the named variable
+B<after> the eval() will be assigned to the VERSION attribute of the
+MakeMaker object. The following lines will be parsed o.k.:
+
+ $VERSION = '1.00';
+ *VERSION = \'1.01';
+ ( $VERSION ) = '$Revision: 1.222 $ ' =~ /\$Revision:\s+([^\s]+)/;
+ $FOO::VERSION = '1.10';
+ *FOO::VERSION = \'1.11';
+
+but these will fail:
+
+ my $VERSION = '1.01';
+ local $VERSION = '1.02';
+ local $FOO::VERSION = '1.30';
+
+The file named in VERSION_FROM is not added as a dependency to
+Makefile. This is not really correct, but it would be a major pain
+during development to have to rewrite the Makefile for any smallish
+change in that file. If you want to make sure that the Makefile
+contains the correct VERSION macro after any change of the file, you
+would have to do something like
+
+ depend => { Makefile => '$(VERSION_FROM)' }
+
+See attribute C<depend> below.
+
+=item XS
+
+Hashref of .xs files. MakeMaker will default this. e.g.
+
+ {'name_of_file.xs' => 'name_of_file.c'}
+
+The .c files will automatically be included in the list of files
+deleted by a make clean.
+
+=item XSOPT
+
+String of options to pass to xsubpp. This might include C<-C++> or
+C<-extern>. Do not include typemaps here; the TYPEMAP parameter exists for
+that purpose.
+
+=item XSPROTOARG
+
+May be set to an empty string, which is identical to C<-prototypes>, or
+C<-noprototypes>. See the xsubpp documentation for details. MakeMaker
+defaults to the empty string.
+
+=item XS_VERSION
+
+Your version number for the .xs file of this package. This defaults
+to the value of the VERSION attribute.
+
+=back
+
+=head2 Additional lowercase attributes
+
+can be used to pass parameters to the methods which implement that
+part of the Makefile.
+
+=over 2
+
+=item clean
+
+ {FILES => "*.xyz foo"}
+
+=item depend
+
+ {ANY_TARGET => ANY_DEPENDECY, ...}
+
+=item dist
+
+ {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz',
+ SHAR => 'shar -m', DIST_CP => 'ln', ZIP => '/bin/zip',
+ ZIPFLAGS => '-rl', DIST_DEFAULT => 'private tardist' }
+
+If you specify COMPRESS, then SUFFIX should also be altered, as it is
+needed to tell make the target file of the compression. Setting
+DIST_CP to ln can be useful, if you need to preserve the timestamps on
+your files. DIST_CP can take the values 'cp', which copies the file,
+'ln', which links the file, and 'best' which copies symbolic links and
+links the rest. Default is 'best'.
+
+=item dynamic_lib
+
+ {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'}
+
+=item installpm
+
+Deprecated as of MakeMaker 5.23. See L<ExtUtils::MM_Unix/pm_to_blib>.
+
+=item linkext
+
+ {LINKTYPE => 'static', 'dynamic' or ''}
+
+NB: Extensions that have nothing but *.pm files had to say
+
+ {LINKTYPE => ''}
+
+with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line
+can be deleted safely. MakeMaker recognizes, when there's nothing to
+be linked.
+
+=item macro
+
+ {ANY_MACRO => ANY_VALUE, ...}
+
+=item realclean
+
+ {FILES => '$(INST_ARCHAUTODIR)/*.xyz'}
+
+=item tool_autosplit
+
+ {MAXLEN =E<gt> 8}
+
+=back
+
+=cut
+
+# bug in pod2html, so leave the =back
+
+# Don't delete this cut, MM depends on it!
+
+=head2 Overriding MakeMaker Methods
+
+If you cannot achieve the desired Makefile behaviour by specifying
+attributes you may define private subroutines in the Makefile.PL.
+Each subroutines returns the text it wishes to have written to
+the Makefile. To override a section of the Makefile you can
+either say:
+
+ sub MY::c_o { "new literal text" }
+
+or you can edit the default by saying something like:
+
+ sub MY::c_o {
+ package MY; # so that "SUPER" works right
+ my $inherited = shift->SUPER::c_o(@_);
+ $inherited =~ s/old text/new text/;
+ $inherited;
+ }
+
+If you are running experiments with embedding perl as a library into
+other applications, you might find MakeMaker is not sufficient. You'd
+better have a look at ExtUtils::Embed which is a collection of utilities
+for embedding.
+
+If you still need a different solution, try to develop another
+subroutine that fits your needs and submit the diffs to
+F<perl5-porters@perl.org> or F<comp.lang.perl.moderated> as appropriate.
+
+For a complete description of all MakeMaker methods see L<ExtUtils::MM_Unix>.
+
+Here is a simple example of how to add a new target to the generated
+Makefile:
+
+ sub MY::postamble {
+ '
+ $(MYEXTLIB): sdbm/Makefile
+ cd sdbm && $(MAKE) all
+ ';
+ }
+
+
+=head2 Hintsfile support
+
+MakeMaker.pm uses the architecture specific information from
+Config.pm. In addition it evaluates architecture specific hints files
+in a C<hints/> directory. The hints files are expected to be named
+like their counterparts in C<PERL_SRC/hints>, but with an C<.pl> file
+name extension (eg. C<next_3_2.pl>). They are simply C<eval>ed by
+MakeMaker within the WriteMakefile() subroutine, and can be used to
+execute commands as well as to include special variables. The rules
+which hintsfile is chosen are the same as in Configure.
+
+The hintsfile is eval()ed immediately after the arguments given to
+WriteMakefile are stuffed into a hash reference $self but before this
+reference becomes blessed. So if you want to do the equivalent to
+override or create an attribute you would say something like
+
+ $self->{LIBS} = ['-ldbm -lucb -lc'];
+
+=head2 Distribution Support
+
+For authors of extensions MakeMaker provides several Makefile
+targets. Most of the support comes from the ExtUtils::Manifest module,
+where additional documentation can be found.
+
+=over 4
+
+=item make distcheck
+
+reports which files are below the build directory but not in the
+MANIFEST file and vice versa. (See ExtUtils::Manifest::fullcheck() for
+details)
+
+=item make skipcheck
+
+reports which files are skipped due to the entries in the
+C<MANIFEST.SKIP> file (See ExtUtils::Manifest::skipcheck() for
+details)
+
+=item make distclean
+
+does a realclean first and then the distcheck. Note that this is not
+needed to build a new distribution as long as you are sure, that the
+MANIFEST file is ok.
+
+=item make manifest
+
+rewrites the MANIFEST file, adding all remaining files found (See
+ExtUtils::Manifest::mkmanifest() for details)
+
+=item make distdir
+
+Copies all the files that are in the MANIFEST file to a newly created
+directory with the name C<$(DISTNAME)-$(VERSION)>. If that directory
+exists, it will be removed first.
+
+=item make disttest
+
+Makes a distdir first, and runs a C<perl Makefile.PL>, a make, and
+a make test in that directory.
+
+=item make tardist
+
+First does a distdir. Then a command $(PREOP) which defaults to a null
+command, followed by $(TOUNIX), which defaults to a null command under
+UNIX, and will convert files in distribution directory to UNIX format
+otherwise. Next it runs C<tar> on that directory into a tarfile and
+deletes the directory. Finishes with a command $(POSTOP) which
+defaults to a null command.
+
+=item make dist
+
+Defaults to $(DIST_DEFAULT) which in turn defaults to tardist.
+
+=item make uutardist
+
+Runs a tardist first and uuencodes the tarfile.
+
+=item make shdist
+
+First does a distdir. Then a command $(PREOP) which defaults to a null
+command. Next it runs C<shar> on that directory into a sharfile and
+deletes the intermediate directory again. Finishes with a command
+$(POSTOP) which defaults to a null command. Note: For shdist to work
+properly a C<shar> program that can handle directories is mandatory.
+
+=item make zipdist
+
+First does a distdir. Then a command $(PREOP) which defaults to a null
+command. Runs C<$(ZIP) $(ZIPFLAGS)> on that directory into a
+zipfile. Then deletes that directory. Finishes with a command
+$(POSTOP) which defaults to a null command.
+
+=item make ci
+
+Does a $(CI) and a $(RCS_LABEL) on all files in the MANIFEST file.
+
+=back
+
+Customization of the dist targets can be done by specifying a hash
+reference to the dist attribute of the WriteMakefile call. The
+following parameters are recognized:
+
+ CI ('ci -u')
+ COMPRESS ('gzip --best')
+ POSTOP ('@ :')
+ PREOP ('@ :')
+ TO_UNIX (depends on the system)
+ RCS_LABEL ('rcs -q -Nv$(VERSION_SYM):')
+ SHAR ('shar')
+ SUFFIX ('.gz')
+ TAR ('tar')
+ TARFLAGS ('cvf')
+ ZIP ('zip')
+ ZIPFLAGS ('-r')
+
+An example:
+
+ WriteMakefile( 'dist' => { COMPRESS=>"bzip2", SUFFIX=>".bz2" })
+
+=head2 Disabling an extension
+
+If some events detected in F<Makefile.PL> imply that there is no way
+to create the Module, but this is a normal state of things, then you
+can create a F<Makefile> which does nothing, but succeeds on all the
+"usual" build targets. To do so, use
+
+ ExtUtils::MakeMaker::WriteEmptyMakefile();
+
+instead of WriteMakefile().
+
+This may be useful if other modules expect this module to be I<built>
+OK, as opposed to I<work> OK (say, this system-dependent module builds
+in a subdirectory of some other distribution, or is listed as a
+dependency in a CPAN::Bundle, but the functionality is supported by
+different means on the current architecture).
+
+=head1 SEE ALSO
+
+ExtUtils::MM_Unix, ExtUtils::Manifest, ExtUtils::testlib,
+ExtUtils::Install, ExtUtils::Embed
+
+=head1 AUTHORS
+
+Andy Dougherty <F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig
+<F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>.
+VMS support by Charles Bailey <F<bailey@genetics.upenn.edu>>. OS/2
+support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Contact the
+makemaker mailing list C<mailto:makemaker@franz.ww.tu-berlin.de>, if
+you have any questions.
+
+=cut
diff --git a/contrib/perl5/lib/ExtUtils/Manifest.pm b/contrib/perl5/lib/ExtUtils/Manifest.pm
new file mode 100644
index 000000000000..55570892f851
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/Manifest.pm
@@ -0,0 +1,408 @@
+package ExtUtils::Manifest;
+
+require Exporter;
+use Config;
+use File::Find;
+use File::Copy 'copy';
+use Carp;
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT_OK
+ $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found);
+
+$VERSION = substr(q$Revision: 1.33 $, 10);
+@ISA=('Exporter');
+@EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck',
+ 'skipcheck', 'maniread', 'manicopy');
+
+$Is_VMS = $^O eq 'VMS';
+if ($Is_VMS) { require File::Basename }
+
+$Debug = 0;
+$Verbose = 1;
+$Quiet = 0;
+$MANIFEST = 'MANIFEST';
+
+# Really cool fix from Ilya :)
+unless (defined $Config{d_link}) {
+ *ln = \&cp;
+}
+
+sub mkmanifest {
+ my $manimiss = 0;
+ my $read = maniread() or $manimiss++;
+ $read = {} if $manimiss;
+ local *M;
+ rename $MANIFEST, "$MANIFEST.bak" unless $manimiss;
+ open M, ">$MANIFEST" or die "Could not open $MANIFEST: $!";
+ my $matches = _maniskip();
+ my $found = manifind();
+ my($key,$val,$file,%all);
+ %all = (%$found, %$read);
+ $all{$MANIFEST} = ($Is_VMS ? "$MANIFEST\t\t" : '') . 'This list of files'
+ if $manimiss; # add new MANIFEST to known file list
+ foreach $file (sort keys %all) {
+ next if &$matches($file);
+ if ($Verbose){
+ warn "Added to $MANIFEST: $file\n" unless exists $read->{$file};
+ }
+ my $text = $all{$file};
+ ($file,$text) = split(/\s+/,$text,2) if $Is_VMS && $text;
+ my $tabs = (5 - (length($file)+1)/8);
+ $tabs = 1 if $tabs < 1;
+ $tabs = 0 unless $text;
+ print M $file, "\t" x $tabs, $text, "\n";
+ }
+ close M;
+}
+
+sub manifind {
+ local $found = {};
+ find(sub {return if -d $_;
+ (my $name = $File::Find::name) =~ s|./||;
+ warn "Debug: diskfile $name\n" if $Debug;
+ $name =~ s#(.*)\.$#\L$1# if $Is_VMS;
+ $found->{$name} = "";}, ".");
+ $found;
+}
+
+sub fullcheck {
+ _manicheck(3);
+}
+
+sub manicheck {
+ return @{(_manicheck(1))[0]};
+}
+
+sub filecheck {
+ return @{(_manicheck(2))[1]};
+}
+
+sub skipcheck {
+ _manicheck(6);
+}
+
+sub _manicheck {
+ my($arg) = @_;
+ my $read = maniread();
+ my $found = manifind();
+ my $file;
+ my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0);
+ my(@missfile,@missentry);
+ if ($arg & 1){
+ foreach $file (sort keys %$read){
+ warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug;
+ if ($dosnames){
+ $file = lc $file;
+ $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge;
+ $file =~ s=((\w|-)+)=substr ($1,0,8)=ge;
+ }
+ unless ( exists $found->{$file} ) {
+ warn "No such file: $file\n" unless $Quiet;
+ push @missfile, $file;
+ }
+ }
+ }
+ if ($arg & 2){
+ $read ||= {};
+ my $matches = _maniskip();
+ my $skipwarn = $arg & 4;
+ foreach $file (sort keys %$found){
+ if (&$matches($file)){
+ warn "Skipping $file\n" if $skipwarn;
+ next;
+ }
+ warn "Debug: manicheck checking from disk $file\n" if $Debug;
+ unless ( exists $read->{$file} ) {
+ warn "Not in $MANIFEST: $file\n" unless $Quiet;
+ push @missentry, $file;
+ }
+ }
+ }
+ (\@missfile,\@missentry);
+}
+
+sub maniread {
+ my ($mfile) = @_;
+ $mfile ||= $MANIFEST;
+ my $read = {};
+ local *M;
+ unless (open M, $mfile){
+ warn "$mfile: $!";
+ return $read;
+ }
+ while (<M>){
+ chomp;
+ next if /^#/;
+ if ($Is_VMS) {
+ my($file)= /^(\S+)/;
+ next unless $file;
+ my($base,$dir) = File::Basename::fileparse($file);
+ # Resolve illegal file specifications in the same way as tar
+ $dir =~ tr/./_/;
+ my(@pieces) = split(/\./,$base);
+ if (@pieces > 2) { $base = shift(@pieces) . '.' . join('_',@pieces); }
+ my $okfile = "$dir$base";
+ warn "Debug: Illegal name $file changed to $okfile\n" if $Debug;
+ $read->{"\L$okfile"}=$_;
+ }
+ else { /^(\S+)\s*(.*)/ and $read->{$1}=$2; }
+ }
+ close M;
+ $read;
+}
+
+# returns an anonymous sub that decides if an argument matches
+sub _maniskip {
+ my ($mfile) = @_;
+ my $matches = sub {0};
+ my @skip ;
+ $mfile ||= "$MANIFEST.SKIP";
+ local *M;
+ return $matches unless -f $mfile;
+ open M, $mfile or return $matches;
+ while (<M>){
+ chomp;
+ next if /^#/;
+ next if /^\s*$/;
+ push @skip, $_;
+ }
+ close M;
+ my $opts = $Is_VMS ? 'oi ' : 'o ';
+ my $sub = "\$matches = "
+ . "sub { my(\$arg)=\@_; return 1 if "
+ . join (" || ", (map {s!/!\\/!g; "\$arg =~ m/$_/$opts"} @skip), 0)
+ . " }";
+ eval $sub;
+ print "Debug: $sub\n" if $Debug;
+ $matches;
+}
+
+sub manicopy {
+ my($read,$target,$how)=@_;
+ croak "manicopy() called without target argument" unless defined $target;
+ $how ||= 'cp';
+ require File::Path;
+ require File::Basename;
+ my(%dirs,$file);
+ $target = VMS::Filespec::unixify($target) if $Is_VMS;
+ umask 0 unless $Is_VMS;
+ File::Path::mkpath([ $target ],1,$Is_VMS ? undef : 0755);
+ foreach $file (keys %$read){
+ $file = VMS::Filespec::unixify($file) if $Is_VMS;
+ if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not?
+ my $dir = File::Basename::dirname($file);
+ $dir = VMS::Filespec::unixify($dir) if $Is_VMS;
+ File::Path::mkpath(["$target/$dir"],1,$Is_VMS ? undef : 0755);
+ }
+ cp_if_diff($file, "$target/$file", $how);
+ }
+}
+
+sub cp_if_diff {
+ my($from, $to, $how)=@_;
+ -f $from or carp "$0: $from not found";
+ my($diff) = 0;
+ local(*F,*T);
+ open(F,$from) or croak "Can't read $from: $!\n";
+ if (open(T,$to)) {
+ while (<F>) { $diff++,last if $_ ne <T>; }
+ $diff++ unless eof(T);
+ close T;
+ }
+ else { $diff++; }
+ close F;
+ if ($diff) {
+ if (-e $to) {
+ unlink($to) or confess "unlink $to: $!";
+ }
+ STRICT_SWITCH: {
+ best($from,$to), last STRICT_SWITCH if $how eq 'best';
+ cp($from,$to), last STRICT_SWITCH if $how eq 'cp';
+ ln($from,$to), last STRICT_SWITCH if $how eq 'ln';
+ croak("ExtUtils::Manifest::cp_if_diff " .
+ "called with illegal how argument [$how]. " .
+ "Legal values are 'best', 'cp', and 'ln'.");
+ }
+ }
+}
+
+sub cp {
+ my ($srcFile, $dstFile) = @_;
+ my ($perm,$access,$mod) = (stat $srcFile)[2,8,9];
+ copy($srcFile,$dstFile);
+ utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile;
+ # chmod a+rX-w,go-w
+ chmod( 0444 | ( $perm & 0111 ? 0111 : 0 ), $dstFile );
+}
+
+sub ln {
+ my ($srcFile, $dstFile) = @_;
+ return &cp if $Is_VMS;
+ link($srcFile, $dstFile);
+ local($_) = $dstFile; # chmod a+r,go-w+X (except "X" only applies to u=x)
+ my $mode= 0444 | (stat)[2] & 0700;
+ if (! chmod( $mode | ( $mode & 0100 ? 0111 : 0 ), $_ )) {
+ unlink $dstFile;
+ return;
+ }
+ 1;
+}
+
+sub best {
+ my ($srcFile, $dstFile) = @_;
+ if (-l $srcFile) {
+ cp($srcFile, $dstFile);
+ } else {
+ ln($srcFile, $dstFile) or cp($srcFile, $dstFile);
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Manifest - utilities to write and check a MANIFEST file
+
+=head1 SYNOPSIS
+
+C<require ExtUtils::Manifest;>
+
+C<ExtUtils::Manifest::mkmanifest;>
+
+C<ExtUtils::Manifest::manicheck;>
+
+C<ExtUtils::Manifest::filecheck;>
+
+C<ExtUtils::Manifest::fullcheck;>
+
+C<ExtUtils::Manifest::skipcheck;>
+
+C<ExtUtild::Manifest::manifind();>
+
+C<ExtUtils::Manifest::maniread($file);>
+
+C<ExtUtils::Manifest::manicopy($read,$target,$how);>
+
+=head1 DESCRIPTION
+
+Mkmanifest() writes all files in and below the current directory to a
+file named in the global variable $ExtUtils::Manifest::MANIFEST (which
+defaults to C<MANIFEST>) in the current directory. It works similar to
+
+ find . -print
+
+but in doing so checks each line in an existing C<MANIFEST> file and
+includes any comments that are found in the existing C<MANIFEST> file
+in the new one. Anything between white space and an end of line within
+a C<MANIFEST> file is considered to be a comment. Filenames and
+comments are seperated by one or more TAB characters in the
+output. All files that match any regular expression in a file
+C<MANIFEST.SKIP> (if such a file exists) are ignored.
+
+Manicheck() checks if all the files within a C<MANIFEST> in the
+current directory really do exist. It only reports discrepancies and
+exits silently if MANIFEST and the tree below the current directory
+are in sync.
+
+Filecheck() finds files below the current directory that are not
+mentioned in the C<MANIFEST> file. An optional file C<MANIFEST.SKIP>
+will be consulted. Any file matching a regular expression in such a
+file will not be reported as missing in the C<MANIFEST> file.
+
+Fullcheck() does both a manicheck() and a filecheck().
+
+Skipcheck() lists all the files that are skipped due to your
+C<MANIFEST.SKIP> file.
+
+Manifind() retruns a hash reference. The keys of the hash are the
+files found below the current directory.
+
+Maniread($file) reads a named C<MANIFEST> file (defaults to
+C<MANIFEST> in the current directory) and returns a HASH reference
+with files being the keys and comments being the values of the HASH.
+Blank lines and lines which start with C<#> in the C<MANIFEST> file
+are discarded.
+
+I<Manicopy($read,$target,$how)> copies the files that are the keys in
+the HASH I<%$read> to the named target directory. The HASH reference
+I<$read> is typically returned by the maniread() function. This
+function is useful for producing a directory tree identical to the
+intended distribution tree. The third parameter $how can be used to
+specify a different methods of "copying". Valid values are C<cp>,
+which actually copies the files, C<ln> which creates hard links, and
+C<best> which mostly links the files but copies any symbolic link to
+make a tree without any symbolic link. Best is the default.
+
+=head1 MANIFEST.SKIP
+
+The file MANIFEST.SKIP may contain regular expressions of files that
+should be ignored by mkmanifest() and filecheck(). The regular
+expressions should appear one on each line. Blank lines and lines
+which start with C<#> are skipped. Use C<\#> if you need a regular
+expression to start with a sharp character. A typical example:
+
+ \bRCS\b
+ ^MANIFEST\.
+ ^Makefile$
+ ~$
+ \.html$
+ \.old$
+ ^blib/
+ ^MakeMaker-\d
+
+=head1 EXPORT_OK
+
+C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>,
+C<&maniread>, and C<&manicopy> are exportable.
+
+=head1 GLOBAL VARIABLES
+
+C<$ExtUtils::Manifest::MANIFEST> defaults to C<MANIFEST>. Changing it
+results in both a different C<MANIFEST> and a different
+C<MANIFEST.SKIP> file. This is useful if you want to maintain
+different distributions for different audiences (say a user version
+and a developer version including RCS).
+
+C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value,
+all functions act silently.
+
+=head1 DIAGNOSTICS
+
+All diagnostic output is sent to C<STDERR>.
+
+=over
+
+=item C<Not in MANIFEST:> I<file>
+
+is reported if a file is found, that is missing in the C<MANIFEST>
+file which is excluded by a regular expression in the file
+C<MANIFEST.SKIP>.
+
+=item C<No such file:> I<file>
+
+is reported if a file mentioned in a C<MANIFEST> file does not
+exist.
+
+=item C<MANIFEST:> I<$!>
+
+is reported if C<MANIFEST> could not be opened.
+
+=item C<Added to MANIFEST:> I<file>
+
+is reported by mkmanifest() if $Verbose is set and a file is added
+to MANIFEST. $Verbose is set to 1 by default.
+
+=back
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker> which has handy targets for most of the functionality.
+
+=head1 AUTHOR
+
+Andreas Koenig <F<koenig@franz.ww.TU-Berlin.DE>>
+
+=cut
diff --git a/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm b/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm
new file mode 100644
index 000000000000..35d5236072f4
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/Mkbootstrap.pm
@@ -0,0 +1,103 @@
+package ExtUtils::Mkbootstrap;
+
+$VERSION = substr q$Revision: 1.13 $, 10;
+# $Date: 1996/09/03 17:04:43 $
+
+use Config;
+use Exporter;
+@ISA=('Exporter');
+@EXPORT='&Mkbootstrap';
+
+sub Mkbootstrap {
+ my($baseext, @bsloadlibs)=@_;
+ @bsloadlibs = grep($_, @bsloadlibs); # strip empty libs
+
+ print STDOUT " bsloadlibs=@bsloadlibs\n" if $Verbose;
+
+ # We need DynaLoader here because we and/or the *_BS file may
+ # call dl_findfile(). We don't say `use' here because when
+ # first building perl extensions the DynaLoader will not have
+ # been built when MakeMaker gets first used.
+ require DynaLoader;
+
+ rename "$baseext.bs", "$baseext.bso"
+ if -s "$baseext.bs";
+
+ if (-f "${baseext}_BS"){
+ $_ = "${baseext}_BS";
+ package DynaLoader; # execute code as if in DynaLoader
+ local($osname, $dlsrc) = (); # avoid warnings
+ ($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)};
+ $bscode = "";
+ unshift @INC, ".";
+ require $_;
+ shift @INC;
+ }
+
+ if ($Config{'dlsrc'} =~ /^dl_dld/){
+ package DynaLoader;
+ push(@dl_resolve_using, dl_findfile('-lc'));
+ }
+
+ my(@all) = (@bsloadlibs, @DynaLoader::dl_resolve_using);
+ my($method) = '';
+ if (@all){
+ open BS, ">$baseext.bs"
+ or die "Unable to open $baseext.bs: $!";
+ print STDOUT "Writing $baseext.bs\n";
+ print STDOUT " containing: @all" if $Verbose;
+ print BS "# $baseext DynaLoader bootstrap file for $^O architecture.\n";
+ print BS "# Do not edit this file, changes will be lost.\n";
+ print BS "# This file was automatically generated by the\n";
+ print BS "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$Version).\n";
+ print BS "\@DynaLoader::dl_resolve_using = ";
+ # If @all contains names in the form -lxxx or -Lxxx then it's asking for
+ # runtime library location so we automatically add a call to dl_findfile()
+ if (" @all" =~ m/ -[lLR]/){
+ print BS " dl_findfile(qw(\n @all\n ));\n";
+ }else{
+ print BS " qw(@all);\n";
+ }
+ # write extra code if *_BS says so
+ print BS $DynaLoader::bscode if $DynaLoader::bscode;
+ print BS "\n1;\n";
+ close BS;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
+
+=head1 SYNOPSIS
+
+C<mkbootstrap>
+
+=head1 DESCRIPTION
+
+Mkbootstrap typically gets called from an extension Makefile.
+
+There is no C<*.bs> file supplied with the extension. Instead a
+C<*_BS> file which has code for the special cases, like posix for
+berkeley db on the NeXT.
+
+This file will get parsed, and produce a maybe empty
+C<@DynaLoader::dl_resolve_using> array for the current architecture.
+That will be extended by $BSLOADLIBS, which was computed by
+ExtUtils::Liblist::ext(). If this array still is empty, we do nothing,
+else we write a .bs file with an C<@DynaLoader::dl_resolve_using>
+array.
+
+The C<*_BS> file can put some code into the generated C<*.bs> file by
+placing it in C<$bscode>. This is a handy 'escape' mechanism that may
+prove useful in complex situations.
+
+If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then
+Mkbootstrap will automatically add a dl_findfile() call to the
+generated C<*.bs> file.
+
+=cut
diff --git a/contrib/perl5/lib/ExtUtils/Mksymlists.pm b/contrib/perl5/lib/ExtUtils/Mksymlists.pm
new file mode 100644
index 000000000000..0b92ca09b7ea
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/Mksymlists.pm
@@ -0,0 +1,276 @@
+package ExtUtils::Mksymlists;
+use strict qw[ subs refs ];
+# no strict 'vars'; # until filehandles are exempted
+
+use Carp;
+use Exporter;
+use vars qw( @ISA @EXPORT $VERSION );
+@ISA = 'Exporter';
+@EXPORT = '&Mksymlists';
+$VERSION = substr q$Revision: 1.17 $, 10;
+
+sub Mksymlists {
+ my(%spec) = @_;
+ my($osname) = $^O;
+
+ croak("Insufficient information specified to Mksymlists")
+ unless ( $spec{NAME} or
+ ($spec{FILE} and ($spec{DL_FUNCS} or $spec{FUNCLIST})) );
+
+ $spec{DL_VARS} = [] unless $spec{DL_VARS};
+ ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE};
+ $spec{DL_FUNCS} = { $spec{NAME} => [] }
+ unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or
+ $spec{FUNCLIST});
+ $spec{FUNCLIST} = [] unless $spec{FUNCLIST};
+ if (defined $spec{DL_FUNCS}) {
+ my($package);
+ foreach $package (keys %{$spec{DL_FUNCS}}) {
+ my($packprefix,$sym,$bootseen);
+ ($packprefix = $package) =~ s/\W/_/g;
+ foreach $sym (@{$spec{DL_FUNCS}->{$package}}) {
+ if ($sym =~ /^boot_/) {
+ push(@{$spec{FUNCLIST}},$sym);
+ $bootseen++;
+ }
+ else { push(@{$spec{FUNCLIST}},"XS_${packprefix}_$sym"); }
+ }
+ push(@{$spec{FUNCLIST}},"boot_$packprefix") unless $bootseen;
+ }
+ }
+
+# We'll need this if we ever add any OS which uses mod2fname
+# not as pseudo-builtin.
+# require DynaLoader;
+ if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) {
+ $spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]);
+ }
+
+ if ($osname eq 'aix') { _write_aix(\%spec); }
+ elsif ($osname eq 'VMS') { _write_vms(\%spec) }
+ elsif ($osname eq 'os2') { _write_os2(\%spec) }
+ elsif ($osname eq 'MSWin32') { _write_win32(\%spec) }
+ else { croak("Don't know how to create linker option file for $osname\n"); }
+}
+
+
+sub _write_aix {
+ my($data) = @_;
+
+ rename "$data->{FILE}.exp", "$data->{FILE}.exp_old";
+
+ open(EXP,">$data->{FILE}.exp")
+ or croak("Can't create $data->{FILE}.exp: $!\n");
+ print EXP join("\n",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
+ print EXP join("\n",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
+ close EXP;
+}
+
+
+sub _write_os2 {
+ my($data) = @_;
+ require Config;
+ my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : "");
+
+ if (not $data->{DLBASE}) {
+ ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
+ $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
+ }
+ rename "$data->{FILE}.def", "$data->{FILE}_def.old";
+
+ open(DEF,">$data->{FILE}.def")
+ or croak("Can't create $data->{FILE}.def: $!\n");
+ print DEF "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n";
+ print DEF "DESCRIPTION 'Perl (v$]$threaded) module $data->{NAME} v$data->{VERSION}'\n";
+ print DEF "CODE LOADONCALL\n";
+ print DEF "DATA LOADONCALL NONSHARED MULTIPLE\n";
+ print DEF "EXPORTS\n ";
+ print DEF join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
+ print DEF join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
+ if (%{$data->{IMPORTS}}) {
+ print DEF "IMPORTS\n";
+my ($name, $exp);
+while (($name, $exp)= each %{$data->{IMPORTS}}) {
+ print DEF " $name=$exp\n";
+}
+ }
+ close DEF;
+}
+
+sub _write_win32 {
+ my($data) = @_;
+
+ require Config;
+ if (not $data->{DLBASE}) {
+ ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
+ $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
+ }
+ rename "$data->{FILE}.def", "$data->{FILE}_def.old";
+
+ open(DEF,">$data->{FILE}.def")
+ or croak("Can't create $data->{FILE}.def: $!\n");
+ # put library name in quotes (it could be a keyword, like 'Alias')
+ if ($Config::Config{'cc'} !~ /^gcc/i) {
+ print DEF "LIBRARY \"$data->{DLBASE}\"\n";
+ }
+ print DEF "EXPORTS\n ";
+ my @syms;
+ # Export public symbols both with and without underscores to
+ # ensure compatibility between DLLs from different compilers
+ # NOTE: DynaLoader itself only uses the names without underscores,
+ # so this is only to cover the case when the extension DLL may be
+ # linked to directly from C. GSAR 97-07-10
+ if ($Config::Config{'cc'} =~ /^bcc/i) {
+ for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) {
+ push @syms, "_$_", "$_ = _$_";
+ }
+ }
+ else {
+ for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) {
+ push @syms, "$_", "_$_ = $_";
+ }
+ }
+ print DEF join("\n ",@syms, "\n") if @syms;
+ if (%{$data->{IMPORTS}}) {
+ print DEF "IMPORTS\n";
+ my ($name, $exp);
+ while (($name, $exp)= each %{$data->{IMPORTS}}) {
+ print DEF " $name=$exp\n";
+ }
+ }
+ close DEF;
+}
+
+
+sub _write_vms {
+ my($data) = @_;
+
+ require Config; # a reminder for once we do $^O
+ require ExtUtils::XSSymSet;
+
+ my($isvax) = $Config::Config{'arch'} =~ /VAX/i;
+ my($set) = new ExtUtils::XSSymSet;
+ my($sym);
+
+ rename "$data->{FILE}.opt", "$data->{FILE}.opt_old";
+
+ open(OPT,">$data->{FILE}.opt")
+ or croak("Can't create $data->{FILE}.opt: $!\n");
+
+ # Options file declaring universal symbols
+ # Used when linking shareable image for dynamic extension,
+ # or when linking PerlShr into which we've added this package
+ # as a static extension
+ # We don't do anything to preserve order, so we won't relax
+ # the GSMATCH criteria for a dynamic extension
+
+ foreach $sym (@{$data->{FUNCLIST}}) {
+ my $safe = $set->addsym($sym);
+ if ($isvax) { print OPT "UNIVERSAL=$safe\n" }
+ else { print OPT "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; }
+ }
+ foreach $sym (@{$data->{DL_VARS}}) {
+ my $safe = $set->addsym($sym);
+ print OPT "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
+ if ($isvax) { print OPT "UNIVERSAL=$safe\n" }
+ else { print OPT "SYMBOL_VECTOR=($safe=DATA)\n"; }
+ }
+ close OPT;
+
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Mksymlists - write linker options files for dynamic extension
+
+=head1 SYNOPSIS
+
+ use ExtUtils::Mksymlists;
+ Mksymlists({ NAME => $name ,
+ DL_VARS => [ $var1, $var2, $var3 ],
+ DL_FUNCS => { $pkg1 => [ $func1, $func2 ],
+ $pkg2 => [ $func3 ] });
+
+=head1 DESCRIPTION
+
+C<ExtUtils::Mksymlists> produces files used by the linker under some OSs
+during the creation of shared libraries for dynamic extensions. It is
+normally called from a MakeMaker-generated Makefile when the extension
+is built. The linker option file is generated by calling the function
+C<Mksymlists>, which is exported by default from C<ExtUtils::Mksymlists>.
+It takes one argument, a list of key-value pairs, in which the following
+keys are recognized:
+
+=over
+
+=item NAME
+
+This gives the name of the extension (I<e.g.> Tk::Canvas) for which
+the linker option file will be produced.
+
+=item DL_FUNCS
+
+This is identical to the DL_FUNCS attribute available via MakeMaker,
+from which it is usually taken. Its value is a reference to an
+associative array, in which each key is the name of a package, and
+each value is an a reference to an array of function names which
+should be exported by the extension. For instance, one might say
+C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ],
+Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>. The
+function names should be identical to those in the XSUB code;
+C<Mksymlists> will alter the names written to the linker option
+file to match the changes made by F<xsubpp>. In addition, if
+none of the functions in a list begin with the string B<boot_>,
+C<Mksymlists> will add a bootstrap function for that package,
+just as xsubpp does. (If a B<boot_E<lt>pkgE<gt>> function is
+present in the list, it is passed through unchanged.) If
+DL_FUNCS is not specified, it defaults to the bootstrap
+function for the extension specified in NAME.
+
+=item DL_VARS
+
+This is identical to the DL_VARS attribute available via MakeMaker,
+and, like DL_FUNCS, it is usually specified via MakeMaker. Its
+value is a reference to an array of variable names which should
+be exported by the extension.
+
+=item FILE
+
+This key can be used to specify the name of the linker option file
+(minus the OS-specific extension), if for some reason you do not
+want to use the default value, which is the last word of the NAME
+attribute (I<e.g.> for Tk::Canvas, FILE defaults to 'Canvas').
+
+=item FUNCLIST
+
+This provides an alternate means to specify function names to be
+exported from the extension. Its value is a reference to an
+array of function names to be exported by the extension. These
+names are passed through unaltered to the linker options file.
+
+=item DLBASE
+
+This item specifies the name by which the linker knows the
+extension, which may be different from the name of the
+extension itself (for instance, some linkers add an '_' to the
+name of the extension). If it is not specified, it is derived
+from the NAME attribute. It is presently used only by OS2.
+
+=back
+
+When calling C<Mksymlists>, one should always specify the NAME
+attribute. In most cases, this is all that's necessary. In
+the case of unusual extensions, however, the other attributes
+can be used to provide additional information to the linker.
+
+=head1 AUTHOR
+
+Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>>
+
+=head1 REVISION
+
+Last revised 14-Feb-1996, for Perl 5.002.
diff --git a/contrib/perl5/lib/ExtUtils/Packlist.pm b/contrib/perl5/lib/ExtUtils/Packlist.pm
new file mode 100644
index 000000000000..eeb0a5b0c1c4
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/Packlist.pm
@@ -0,0 +1,288 @@
+package ExtUtils::Packlist;
+use strict;
+use Carp qw();
+use vars qw($VERSION);
+$VERSION = '0.03';
+
+# Used for generating filehandle globs. IO::File might not be available!
+my $fhname = "FH1";
+
+sub mkfh()
+{
+no strict;
+my $fh = \*{$fhname++};
+use strict;
+return($fh);
+}
+
+sub new($$)
+{
+my ($class, $packfile) = @_;
+$class = ref($class) || $class;
+my %self;
+tie(%self, $class, $packfile);
+return(bless(\%self, $class));
+}
+
+sub TIEHASH
+{
+my ($class, $packfile) = @_;
+my $self = { packfile => $packfile };
+bless($self, $class);
+$self->read($packfile) if (defined($packfile) && -f $packfile);
+return($self);
+}
+
+sub STORE
+{
+$_[0]->{data}->{$_[1]} = $_[2];
+}
+
+sub FETCH
+{
+return($_[0]->{data}->{$_[1]});
+}
+
+sub FIRSTKEY
+{
+my $reset = scalar(keys(%{$_[0]->{data}}));
+return(each(%{$_[0]->{data}}));
+}
+
+sub NEXTKEY
+{
+return(each(%{$_[0]->{data}}));
+}
+
+sub EXISTS
+{
+return(exists($_[0]->{data}->{$_[1]}));
+}
+
+sub DELETE
+{
+return(delete($_[0]->{data}->{$_[1]}));
+}
+
+sub CLEAR
+{
+%{$_[0]->{data}} = ();
+}
+
+sub DESTROY
+{
+}
+
+sub read($;$)
+{
+my ($self, $packfile) = @_;
+$self = tied(%$self) || $self;
+
+if (defined($packfile)) { $self->{packfile} = $packfile; }
+else { $packfile = $self->{packfile}; }
+Carp::croak("No packlist filename specified") if (! defined($packfile));
+my $fh = mkfh();
+open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!");
+$self->{data} = {};
+my ($line);
+while (defined($line = <$fh>))
+ {
+ chomp $line;
+ my ($key, @kvs) = split(' ', $line);
+ $key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths
+ if (! @kvs)
+ {
+ $self->{data}->{$key} = undef;
+ }
+ else
+ {
+ my ($data) = {};
+ foreach my $kv (@kvs)
+ {
+ my ($k, $v) = split('=', $kv);
+ $data->{$k} = $v;
+ }
+ $self->{data}->{$key} = $data;
+ }
+ }
+close($fh);
+}
+
+sub write($;$)
+{
+my ($self, $packfile) = @_;
+$self = tied(%$self) || $self;
+if (defined($packfile)) { $self->{packfile} = $packfile; }
+else { $packfile = $self->{packfile}; }
+Carp::croak("No packlist filename specified") if (! defined($packfile));
+my $fh = mkfh();
+open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
+foreach my $key (sort(keys(%{$self->{data}})))
+ {
+ print $fh ("$key");
+ if (ref($self->{data}->{$key}))
+ {
+ my $data = $self->{data}->{$key};
+ foreach my $k (sort(keys(%$data)))
+ {
+ print $fh (" $k=$data->{$k}");
+ }
+ }
+ print $fh ("\n");
+ }
+close($fh);
+}
+
+sub validate($;$)
+{
+my ($self, $remove) = @_;
+$self = tied(%$self) || $self;
+my @missing;
+foreach my $key (sort(keys(%{$self->{data}})))
+ {
+ if (! -e $key)
+ {
+ push(@missing, $key);
+ delete($self->{data}{$key}) if ($remove);
+ }
+ }
+return(@missing);
+}
+
+sub packlist_file($)
+{
+my ($self) = @_;
+$self = tied(%$self) || $self;
+return($self->{packfile});
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ExtUtils::Packlist - manage .packlist files
+
+=head1 SYNOPSIS
+
+ use ExtUtils::Packlist;
+ my ($pl) = ExtUtils::Packlist->new('.packlist');
+ $pl->read('/an/old/.packlist');
+ my @missing_files = $pl->validate();
+ $pl->write('/a/new/.packlist');
+
+ $pl->{'/some/file/name'}++;
+ or
+ $pl->{'/some/other/file/name'} = { type => 'file',
+ from => '/some/file' };
+
+=head1 DESCRIPTION
+
+ExtUtils::Packlist provides a standard way to manage .packlist files.
+Functions are provided to read and write .packlist files. The original
+.packlist format is a simple list of absolute pathnames, one per line. In
+addition, this package supports an extended format, where as well as a filename
+each line may contain a list of attributes in the form of a space separated
+list of key=value pairs. This is used by the installperl script to
+differentiate between files and links, for example.
+
+=head1 USAGE
+
+The hash reference returned by the new() function can be used to examine and
+modify the contents of the .packlist. Items may be added/deleted from the
+.packlist by modifying the hash. If the value associated with a hash key is a
+scalar, the entry written to the .packlist by any subsequent write() will be a
+simple filename. If the value is a hash, the entry written will be the
+filename followed by the key=value pairs from the hash. Reading back the
+.packlist will recreate the original entries.
+
+=head1 FUNCTIONS
+
+=over
+
+=item new()
+
+This takes an optional parameter, the name of a .packlist. If the file exists,
+it will be opened and the contents of the file will be read. The new() method
+returns a reference to a hash. This hash holds an entry for each line in the
+.packlist. In the case of old-style .packlists, the value associated with each
+key is undef. In the case of new-style .packlists, the value associated with
+each key is a hash containing the key=value pairs following the filename in the
+.packlist.
+
+=item read()
+
+This takes an optional parameter, the name of the .packlist to be read. If
+no file is specified, the .packlist specified to new() will be read. If the
+.packlist does not exist, Carp::croak will be called.
+
+=item write()
+
+This takes an optional parameter, the name of the .packlist to be written. If
+no file is specified, the .packlist specified to new() will be overwritten.
+
+=item validate()
+
+This checks that every file listed in the .packlist actually exists. If an
+argument which evaluates to true is given, any missing files will be removed
+from the internal hash. The return value is a list of the missing files, which
+will be empty if they all exist.
+
+=item packlist_file()
+
+This returns the name of the associated .packlist file
+
+=back
+
+=head1 EXAMPLE
+
+Here's C<modrm>, a little utility to cleanly remove an installed module.
+
+ #!/usr/local/bin/perl -w
+
+ use strict;
+ use IO::Dir;
+ use ExtUtils::Packlist;
+ use ExtUtils::Installed;
+
+ sub emptydir($) {
+ my ($dir) = @_;
+ my $dh = IO::Dir->new($dir) || return(0);
+ my @count = $dh->read();
+ $dh->close();
+ return(@count == 2 ? 1 : 0);
+ }
+
+ # Find all the installed packages
+ print("Finding all installed modules...\n");
+ my $installed = ExtUtils::Installed->new();
+
+ foreach my $module (grep(!/^Perl$/, $installed->modules())) {
+ my $version = $installed->version($module) || "???";
+ print("Found module $module Version $version\n");
+ print("Do you want to delete $module? [n] ");
+ my $r = <STDIN>; chomp($r);
+ if ($r && $r =~ /^y/i) {
+ # Remove all the files
+ foreach my $file (sort($installed->files($module))) {
+ print("rm $file\n");
+ unlink($file);
+ }
+ my $pf = $installed->packlist($module)->packlist_file();
+ print("rm $pf\n");
+ unlink($pf);
+ foreach my $dir (sort($installed->directory_tree($module))) {
+ if (emptydir($dir)) {
+ print("rmdir $dir\n");
+ rmdir($dir);
+ }
+ }
+ }
+ }
+
+=head1 AUTHOR
+
+Alan Burlison <Alan.Burlison@uk.sun.com>
+
+=cut
diff --git a/contrib/perl5/lib/ExtUtils/inst b/contrib/perl5/lib/ExtUtils/inst
new file mode 100755
index 000000000000..cbf2d01194a0
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/inst
@@ -0,0 +1,139 @@
+#!/usr/local/bin/perl -w
+
+use strict;
+use IO::File;
+use ExtUtils::Packlist;
+use ExtUtils::Installed;
+
+use vars qw($Inst @Modules);
+
+################################################################################
+
+sub do_module($)
+{
+my ($module) = @_;
+my $help = <<EOF;
+Available commands are:
+ f [all|prog|doc] - List installed files of a given type
+ d [all|prog|doc] - List the directories used by a module
+ v - Validate the .packlist - check for missing files
+ t <tarfile> - Create a tar archive of the module
+ q - Quit the module
+EOF
+print($help);
+while (1)
+ {
+ print("$module cmd? ");
+ my $reply = <STDIN>; chomp($reply);
+ CASE:
+ {
+ $reply =~ /^f\s*/ and do
+ {
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' if (! $class);
+ my @files;
+ if (eval { @files = $Inst->files($module, $class); })
+ {
+ print("$class files in $module are:\n ",
+ join("\n ", @files), "\n");
+ last CASE;
+ }
+ else
+ { print($@); }
+ };
+ $reply =~ /^d\s*/ and do
+ {
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' if (! $class);
+ my @dirs;
+ if (eval { @dirs = $Inst->directories($module, $class); })
+ {
+ print("$class directories in $module are:\n ",
+ join("\n ", @dirs), "\n");
+ last CASE;
+ }
+ else
+ { print($@); }
+ };
+ $reply =~ /^t\s*/ and do
+ {
+ my $file = (split(' ', $reply))[1];
+ my $tmp = "/tmp/inst.$$";
+ if (my $fh = IO::File->new($tmp, "w"))
+ {
+ $fh->print(join("\n", $Inst->files($module)));
+ $fh->close();
+ system("tar cvf $file -I $tmp");
+ unlink($tmp);
+ last CASE;
+ }
+ else { print("Can't open $file: $!\n"); }
+ last CASE;
+ };
+ $reply eq 'v' and do
+ {
+ if (my @missing = $Inst->validate($module))
+ {
+ print("Files missing from $module are:\n ",
+ join("\n ", @missing), "\n");
+ }
+ else
+ {
+ print("$module has no missing files\n");
+ }
+ last CASE;
+ };
+ $reply eq 'q' and do
+ {
+ return;
+ };
+ # Default
+ print($help);
+ }
+ }
+}
+
+################################################################################
+
+sub toplevel()
+{
+my $help = <<EOF;
+Available commands are:
+ l - List all installed modules
+ m <module> - Select a module
+ q - Quit the program
+EOF
+print($help);
+while (1)
+ {
+ print("cmd? ");
+ my $reply = <STDIN>; chomp($reply);
+ CASE:
+ {
+ $reply eq 'l' and do
+ {
+ print("Installed modules are:\n ", join("\n ", @Modules), "\n");
+ last CASE;
+ };
+ $reply =~ /^m\s+/ and do
+ {
+ do_module((split(' ', $reply))[1]);
+ last CASE;
+ };
+ $reply eq 'q' and do
+ {
+ exit(0);
+ };
+ # Default
+ print($help);
+ }
+ }
+}
+
+################################################################################
+
+$Inst = ExtUtils::Installed->new();
+@Modules = $Inst->modules();
+toplevel();
+
+################################################################################
diff --git a/contrib/perl5/lib/ExtUtils/testlib.pm b/contrib/perl5/lib/ExtUtils/testlib.pm
new file mode 100644
index 000000000000..d80f2a296b4d
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/testlib.pm
@@ -0,0 +1,26 @@
+package ExtUtils::testlib;
+$VERSION = substr q$Revision: 1.11 $, 10;
+# $Id: testlib.pm,v 1.11 1996/05/31 08:27:07 k Exp $
+
+use lib qw(blib/arch blib/lib);
+1;
+__END__
+
+=head1 NAME
+
+ExtUtils::testlib - add blib/* directories to @INC
+
+=head1 SYNOPSIS
+
+C<use ExtUtils::testlib;>
+
+=head1 DESCRIPTION
+
+After an extension has been built and before it is installed it may be
+desirable to test it bypassing C<make test>. By adding
+
+ use ExtUtils::testlib;
+
+to a test program the intermediate directories used by C<make> are
+added to @INC.
+
diff --git a/contrib/perl5/lib/ExtUtils/typemap b/contrib/perl5/lib/ExtUtils/typemap
new file mode 100644
index 000000000000..28fd99c00b92
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/typemap
@@ -0,0 +1,289 @@
+# $Header$
+# 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/contrib/perl5/lib/ExtUtils/xsubpp b/contrib/perl5/lib/ExtUtils/xsubpp
new file mode 100755
index 000000000000..523dabcecac9
--- /dev/null
+++ b/contrib/perl5/lib/ExtUtils/xsubpp
@@ -0,0 +1,1512 @@
+#!./miniperl
+
+=head1 NAME
+
+xsubpp - compiler to convert Perl XS code into C code
+
+=head1 SYNOPSIS
+
+B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>] [B<-object_capi>]... file.xs
+
+=head1 DESCRIPTION
+
+I<xsubpp> will compile XS code into C code by embedding the constructs
+necessary to let C functions manipulate Perl values and creates the glue
+necessary to let Perl access those functions. The compiler uses typemaps to
+determine how to map C function parameters and variables to Perl values.
+
+The compiler will search for typemap files called I<typemap>. It will use
+the following search path to find default typemaps, with the rightmost
+typemap taking precedence.
+
+ ../../../typemap:../../typemap:../typemap:typemap
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-C++>
+
+Adds ``extern "C"'' to the C code.
+
+
+=item B<-except>
+
+Adds exception handling stubs to the C code.
+
+=item B<-typemap typemap>
+
+Indicates that a user-supplied typemap should take precedence over the
+default typemaps. This option may be used multiple times, with the last
+typemap having the highest precedence.
+
+=item B<-v>
+
+Prints the I<xsubpp> version number to standard output, then exits.
+
+=item B<-prototypes>
+
+By default I<xsubpp> will not automatically generate prototype code for
+all xsubs. This flag will enable prototypes.
+
+=item B<-noversioncheck>
+
+Disables the run time test that determines if the object file (derived
+from the C<.xs> file) and the C<.pm> files have the same version
+number.
+
+=item B<-nolinenumbers>
+
+Prevents the inclusion of `#line' directives in the output.
+
+=item B<-object_capi>
+
+Compile code as C in a PERL_OBJECT environment.
+
+back
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 AUTHOR
+
+Larry Wall
+
+=head1 MODIFICATION HISTORY
+
+See the file F<changes.pod>.
+
+=head1 SEE ALSO
+
+perl(1), perlxs(1), perlxstut(1)
+
+=cut
+
+require 5.002;
+use Cwd;
+use vars '$cplusplus';
+use vars '%v';
+
+use Config;
+
+sub Q ;
+
+# Global Constants
+
+$XSUBPP_version = "1.9507";
+
+my ($Is_VMS, $SymSet);
+if ($^O eq 'VMS') {
+ $Is_VMS = 1;
+ # Establish set of global symbols with max length 28, since xsubpp
+ # will later add the 'XS_' prefix.
+ require ExtUtils::XSSymSet;
+ $SymSet = new ExtUtils::XSSymSet 28;
+}
+
+$FH = 'File0000' ;
+
+$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n";
+
+$proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
+# mjn
+$OBJ = 1 if $Config{'ccflags'} =~ /PERL_OBJECT/i;
+
+$except = "";
+$WantPrototypes = -1 ;
+$WantVersionChk = 1 ;
+$ProtoUsed = 0 ;
+$WantLineNumbers = 1 ;
+SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
+ $flag = shift @ARGV;
+ $flag =~ s/^-// ;
+ $spat = quotemeta shift, next SWITCH if $flag eq 's';
+ $cplusplus = 1, next SWITCH if $flag eq 'C++';
+ $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes';
+ $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes';
+ $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck';
+ $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck';
+ $WantCAPI = 1, next SWITCH if $flag eq 'object_capi';
+ $except = " TRY", next SWITCH if $flag eq 'except';
+ push(@tm,shift), next SWITCH if $flag eq 'typemap';
+ $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers';
+ $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers';
+ (print "xsubpp version $XSUBPP_version\n"), exit
+ if $flag eq 'v';
+ die $usage;
+}
+if ($WantPrototypes == -1)
+ { $WantPrototypes = 0}
+else
+ { $ProtoUsed = 1 }
+
+
+@ARGV == 1 or die $usage;
+($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
+ or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)#
+ or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
+ or ($dir, $filename) = ('.', $ARGV[0]);
+chdir($dir);
+$pwd = cwd();
+
+++ $IncludedFiles{$ARGV[0]} ;
+
+my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs
+my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
+
+
+sub TrimWhitespace
+{
+ $_[0] =~ s/^\s+|\s+$//go ;
+}
+
+sub TidyType
+{
+ local ($_) = @_ ;
+
+ # rationalise any '*' by joining them into bunches and removing whitespace
+ s#\s*(\*+)\s*#$1#g;
+ s#(\*+)# $1 #g ;
+
+ # change multiple whitespace into a single space
+ s/\s+/ /g ;
+
+ # trim leading & trailing whitespace
+ TrimWhitespace($_) ;
+
+ $_ ;
+}
+
+$typemap = shift @ARGV;
+foreach $typemap (@tm) {
+ die "Can't find $typemap in $pwd\n" unless -r $typemap;
+}
+unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
+ ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
+ ../typemap typemap);
+foreach $typemap (@tm) {
+ next unless -e $typemap ;
+ # skip directories, binary files etc.
+ warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
+ unless -T $typemap ;
+ open(TYPEMAP, $typemap)
+ or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
+ $mode = 'Typemap';
+ $junk = "" ;
+ $current = \$junk;
+ while (<TYPEMAP>) {
+ next if /^\s*#/;
+ my $line_no = $. + 1;
+ if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; }
+ if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; }
+ if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; }
+ if ($mode eq 'Typemap') {
+ chomp;
+ my $line = $_ ;
+ TrimWhitespace($_) ;
+ # skip blank lines and comment lines
+ next if /^$/ or /^#/ ;
+ my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
+ warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
+ $type = TidyType($type) ;
+ $type_kind{$type} = $kind ;
+ # prototype defaults to '$'
+ $proto = "\$" unless $proto ;
+ warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
+ unless ValidProtoString($proto) ;
+ $proto_letter{$type} = C_string($proto) ;
+ }
+ elsif (/^\s/) {
+ $$current .= $_;
+ }
+ elsif ($mode eq 'Input') {
+ s/\s+$//;
+ $input_expr{$_} = '';
+ $current = \$input_expr{$_};
+ }
+ else {
+ s/\s+$//;
+ $output_expr{$_} = '';
+ $current = \$output_expr{$_};
+ }
+ }
+ close(TYPEMAP);
+}
+
+foreach $key (keys %input_expr) {
+ $input_expr{$key} =~ s/\n+$//;
+}
+
+$END = "!End!\n\n"; # "impossible" keyword (multiple newline)
+
+# Match an XS keyword
+$BLOCK_re= '\s*(' . join('|', qw(
+ REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
+ CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
+ SCOPE INTERFACE INTERFACE_MACRO C_ARGS
+ )) . "|$END)\\s*:";
+
+# Input: ($_, @line) == unparsed input.
+# Output: ($_, @line) == (rest of line, following lines).
+# Return: the matched keyword if found, otherwise 0
+sub check_keyword {
+ $_ = shift(@line) while !/\S/ && @line;
+ s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
+}
+
+
+if ($WantLineNumbers) {
+ {
+ package xsubpp::counter;
+ sub TIEHANDLE {
+ my ($class, $cfile) = @_;
+ my $buf = "";
+ $SECTION_END_MARKER = "#line --- \"$cfile\"";
+ $line_no = 1;
+ bless \$buf;
+ }
+
+ sub PRINT {
+ my $self = shift;
+ for (@_) {
+ $$self .= $_;
+ while ($$self =~ s/^([^\n]*\n)//) {
+ my $line = $1;
+ ++ $line_no;
+ $line =~ s|^\#line\s+---(?=\s)|#line $line_no|;
+ print STDOUT $line;
+ }
+ }
+ }
+
+ sub PRINTF {
+ my $self = shift;
+ my $fmt = shift;
+ $self->PRINT(sprintf($fmt, @_));
+ }
+
+ sub DESTROY {
+ # Not necessary if we're careful to end with a "\n"
+ my $self = shift;
+ print STDOUT $$self;
+ }
+ }
+
+ my $cfile = $filename;
+ $cfile =~ s/\.xs$/.c/i or $cfile .= ".c";
+ tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile);
+ select PSEUDO_STDOUT;
+}
+
+sub print_section {
+ # the "do" is required for right semantics
+ do { $_ = shift(@line) } while !/\S/ && @line;
+
+ print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n")
+ if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
+ for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
+ print "$_\n";
+ }
+ print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
+}
+
+sub merge_section {
+ my $in = '';
+
+ while (!/\S/ && @line) {
+ $_ = shift(@line);
+ }
+
+ for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
+ $in .= "$_\n";
+ }
+ chomp $in;
+ return $in;
+}
+
+sub process_keyword($)
+{
+ my($pattern) = @_ ;
+ my $kwd ;
+
+ &{"${kwd}_handler"}()
+ while $kwd = check_keyword($pattern) ;
+}
+
+sub CASE_handler {
+ blurt ("Error: `CASE:' after unconditional `CASE:'")
+ if $condnum && $cond eq '';
+ $cond = $_;
+ TrimWhitespace($cond);
+ print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
+ $_ = '' ;
+}
+
+sub INPUT_handler {
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ last if /^\s*NOT_IMPLEMENTED_YET/;
+ next unless /\S/; # skip blank lines
+
+ TrimWhitespace($_) ;
+ my $line = $_ ;
+
+ # remove trailing semicolon if no initialisation
+ s/\s*;$//g unless /[=;+].*\S/ ;
+
+ # check for optional initialisation code
+ my $var_init = '' ;
+ $var_init = $1 if s/\s*([=;+].*)$//s ;
+ $var_init =~ s/"/\\"/g;
+
+ s/\s+/ /g;
+ my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
+ or blurt("Error: invalid argument declaration '$line'"), next;
+
+ # Check for duplicate definitions
+ blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
+ if $arg_list{$var_name} ++ ;
+
+ $thisdone |= $var_name eq "THIS";
+ $retvaldone |= $var_name eq "RETVAL";
+ $var_types{$var_name} = $var_type;
+ print "\t" . &map_type($var_type);
+ $var_num = $args_match{$var_name};
+
+ $proto_arg[$var_num] = ProtoString($var_type)
+ if $var_num ;
+ if ($var_addr) {
+ $var_addr{$var_name} = 1;
+ $func_args =~ s/\b($var_name)\b/&$1/;
+ }
+ if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/) {
+ print "\t$var_name;\n";
+ } elsif ($var_init =~ /\S/) {
+ &output_init($var_type, $var_num, $var_name, $var_init);
+ } elsif ($var_num) {
+ # generate initialization code
+ &generate_init($var_type, $var_num, $var_name);
+ } else {
+ print ";\n";
+ }
+ }
+}
+
+sub OUTPUT_handler {
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
+ $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
+ next;
+ }
+ my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
+ blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
+ if $outargs{$outarg} ++ ;
+ if (!$gotRETVAL and $outarg eq 'RETVAL') {
+ # deal with RETVAL last
+ $RETVAL_code = $outcode ;
+ $gotRETVAL = 1 ;
+ next ;
+ }
+ blurt ("Error: OUTPUT $outarg not an argument"), next
+ unless defined($args_match{$outarg});
+ blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
+ unless defined $var_types{$outarg} ;
+ $var_num = $args_match{$outarg};
+ if ($outcode) {
+ print "\t$outcode\n";
+ print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
+ } else {
+ &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
+ }
+ }
+}
+
+sub C_ARGS_handler() {
+ my $in = merge_section();
+
+ TrimWhitespace($in);
+ $func_args = $in;
+}
+
+sub INTERFACE_MACRO_handler() {
+ my $in = merge_section();
+
+ TrimWhitespace($in);
+ if ($in =~ /\s/) { # two
+ ($interface_macro, $interface_macro_set) = split ' ', $in;
+ } else {
+ $interface_macro = $in;
+ $interface_macro_set = 'UNKNOWN_CVT'; # catch later
+ }
+ $interface = 1; # local
+ $Interfaces = 1; # global
+}
+
+sub INTERFACE_handler() {
+ my $in = merge_section();
+
+ TrimWhitespace($in);
+
+ foreach (split /[\s,]+/, $in) {
+ $Interfaces{$_} = $_;
+ }
+ print Q<<"EOF";
+# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
+EOF
+ $interface = 1; # local
+ $Interfaces = 1; # global
+}
+
+sub CLEANUP_handler() { print_section() }
+sub PREINIT_handler() { print_section() }
+sub INIT_handler() { print_section() }
+
+sub GetAliases
+{
+ my ($line) = @_ ;
+ my ($orig) = $line ;
+ my ($alias) ;
+ my ($value) ;
+
+ # Parse alias definitions
+ # format is
+ # alias = value alias = value ...
+
+ while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
+ $alias = $1 ;
+ $orig_alias = $alias ;
+ $value = $2 ;
+
+ # check for optional package definition in the alias
+ $alias = $Packprefix . $alias if $alias !~ /::/ ;
+
+ # check for duplicate alias name & duplicate value
+ Warn("Warning: Ignoring duplicate alias '$orig_alias'")
+ if defined $XsubAliases{$alias} ;
+
+ Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
+ if $XsubAliasValues{$value} ;
+
+ $XsubAliases = 1;
+ $XsubAliases{$alias} = $value ;
+ $XsubAliasValues{$value} = $orig_alias ;
+ }
+
+ blurt("Error: Cannot parse ALIAS definitions from '$orig'")
+ if $line ;
+}
+
+sub ALIAS_handler ()
+{
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ GetAliases($_) if $_ ;
+ }
+}
+
+sub REQUIRE_handler ()
+{
+ # the rest of the current line should contain a version number
+ my ($Ver) = $_ ;
+
+ TrimWhitespace($Ver) ;
+
+ death ("Error: REQUIRE expects a version number")
+ unless $Ver ;
+
+ # check that the version number is of the form n.n
+ death ("Error: REQUIRE: expected a number, got '$Ver'")
+ unless $Ver =~ /^\d+(\.\d*)?/ ;
+
+ death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
+ unless $XSUBPP_version >= $Ver ;
+}
+
+sub VERSIONCHECK_handler ()
+{
+ # the rest of the current line should contain either ENABLE or
+ # DISABLE
+
+ TrimWhitespace($_) ;
+
+ # check for ENABLE/DISABLE
+ death ("Error: VERSIONCHECK: ENABLE/DISABLE")
+ unless /^(ENABLE|DISABLE)/i ;
+
+ $WantVersionChk = 1 if $1 eq 'ENABLE' ;
+ $WantVersionChk = 0 if $1 eq 'DISABLE' ;
+
+}
+
+sub PROTOTYPE_handler ()
+{
+ my $specified ;
+
+ death("Error: Only 1 PROTOTYPE definition allowed per xsub")
+ if $proto_in_this_xsub ++ ;
+
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ $specified = 1 ;
+ TrimWhitespace($_) ;
+ if ($_ eq 'DISABLE') {
+ $ProtoThisXSUB = 0
+ }
+ elsif ($_ eq 'ENABLE') {
+ $ProtoThisXSUB = 1
+ }
+ else {
+ # remove any whitespace
+ s/\s+//g ;
+ death("Error: Invalid prototype '$_'")
+ unless ValidProtoString($_) ;
+ $ProtoThisXSUB = C_string($_) ;
+ }
+ }
+
+ # If no prototype specified, then assume empty prototype ""
+ $ProtoThisXSUB = 2 unless $specified ;
+
+ $ProtoUsed = 1 ;
+
+}
+
+sub SCOPE_handler ()
+{
+ death("Error: Only 1 SCOPE declaration allowed per xsub")
+ if $scope_in_this_xsub ++ ;
+
+ for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
+ next unless /\S/;
+ TrimWhitespace($_) ;
+ if ($_ =~ /^DISABLE/i) {
+ $ScopeThisXSUB = 0
+ }
+ elsif ($_ =~ /^ENABLE/i) {
+ $ScopeThisXSUB = 1
+ }
+ }
+
+}
+
+sub PROTOTYPES_handler ()
+{
+ # the rest of the current line should contain either ENABLE or
+ # DISABLE
+
+ TrimWhitespace($_) ;
+
+ # check for ENABLE/DISABLE
+ death ("Error: PROTOTYPES: ENABLE/DISABLE")
+ unless /^(ENABLE|DISABLE)/i ;
+
+ $WantPrototypes = 1 if $1 eq 'ENABLE' ;
+ $WantPrototypes = 0 if $1 eq 'DISABLE' ;
+ $ProtoUsed = 1 ;
+
+}
+
+sub INCLUDE_handler ()
+{
+ # the rest of the current line should contain a valid filename
+
+ TrimWhitespace($_) ;
+
+ death("INCLUDE: filename missing")
+ unless $_ ;
+
+ death("INCLUDE: output pipe is illegal")
+ if /^\s*\|/ ;
+
+ # simple minded recursion detector
+ death("INCLUDE loop detected")
+ if $IncludedFiles{$_} ;
+
+ ++ $IncludedFiles{$_} unless /\|\s*$/ ;
+
+ # Save the current file context.
+ push(@XSStack, {
+ type => 'file',
+ LastLine => $lastline,
+ LastLineNo => $lastline_no,
+ Line => \@line,
+ LineNo => \@line_no,
+ Filename => $filename,
+ Handle => $FH,
+ }) ;
+
+ ++ $FH ;
+
+ # open the new file
+ open ($FH, "$_") or death("Cannot open '$_': $!") ;
+
+ print Q<<"EOF" ;
+#
+#/* INCLUDE: Including '$_' from '$filename' */
+#
+EOF
+
+ $filename = $_ ;
+
+ # Prime the pump by reading the first
+ # non-blank line
+
+ # skip leading blank lines
+ while (<$FH>) {
+ last unless /^\s*$/ ;
+ }
+
+ $lastline = $_ ;
+ $lastline_no = $. ;
+
+}
+
+sub PopFile()
+{
+ return 0 unless $XSStack[-1]{type} eq 'file' ;
+
+ my $data = pop @XSStack ;
+ my $ThisFile = $filename ;
+ my $isPipe = ($filename =~ /\|\s*$/) ;
+
+ -- $IncludedFiles{$filename}
+ unless $isPipe ;
+
+ close $FH ;
+
+ $FH = $data->{Handle} ;
+ $filename = $data->{Filename} ;
+ $lastline = $data->{LastLine} ;
+ $lastline_no = $data->{LastLineNo} ;
+ @line = @{ $data->{Line} } ;
+ @line_no = @{ $data->{LineNo} } ;
+
+ if ($isPipe and $? ) {
+ -- $lastline_no ;
+ print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
+ exit 1 ;
+ }
+
+ print Q<<"EOF" ;
+#
+#/* INCLUDE: Returning to '$filename' from '$ThisFile' */
+#
+EOF
+
+ return 1 ;
+}
+
+sub ValidProtoString ($)
+{
+ my($string) = @_ ;
+
+ if ( $string =~ /^$proto_re+$/ ) {
+ return $string ;
+ }
+
+ return 0 ;
+}
+
+sub C_string ($)
+{
+ my($string) = @_ ;
+
+ $string =~ s[\\][\\\\]g ;
+ $string ;
+}
+
+sub ProtoString ($)
+{
+ my ($type) = @_ ;
+
+ $proto_letter{$type} or "\$" ;
+}
+
+sub check_cpp {
+ my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
+ if (@cpp) {
+ my ($cpp, $cpplevel);
+ for $cpp (@cpp) {
+ if ($cpp =~ /^\#\s*if/) {
+ $cpplevel++;
+ } elsif (!$cpplevel) {
+ Warn("Warning: #else/elif/endif without #if in this function");
+ print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
+ if $XSStack[-1]{type} eq 'if';
+ return;
+ } elsif ($cpp =~ /^\#\s*endif/) {
+ $cpplevel--;
+ }
+ }
+ Warn("Warning: #if without #endif in this function") if $cpplevel;
+ }
+}
+
+
+sub Q {
+ my($text) = @_;
+ $text =~ s/^#//gm;
+ $text =~ s/\[\[/{/g;
+ $text =~ s/\]\]/}/g;
+ $text;
+}
+
+open($FH, $filename) or die "cannot open $filename: $!\n";
+
+# Identify the version of xsubpp used
+print <<EOM ;
+/*
+ * This file was generated automatically by xsubpp version $XSUBPP_version from the
+ * contents of $filename. Do not edit this file, edit $filename instead.
+ *
+ * ANY CHANGES MADE HERE WILL BE LOST!
+ *
+ */
+
+EOM
+
+
+print("#line 1 \"$filename\"\n")
+ if $WantLineNumbers;
+
+while (<$FH>) {
+ last if ($Module, $Package, $Prefix) =
+ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
+
+ if ($OBJ) {
+ s/#if(?:def|\s+defined)\s+(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
+ }
+ print $_;
+}
+&Exit unless defined $_;
+
+print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
+
+$lastline = $_;
+$lastline_no = $.;
+
+# Read next xsub into @line from ($lastline, <$FH>).
+sub fetch_para {
+ # parse paragraph
+ death ("Error: Unterminated `#if/#ifdef/#ifndef'")
+ if !defined $lastline && $XSStack[-1]{type} eq 'if';
+ @line = ();
+ @line_no = () ;
+ return PopFile() if !defined $lastline;
+
+ if ($lastline =~
+ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
+ $Module = $1;
+ $Package = defined($2) ? $2 : ''; # keep -w happy
+ $Prefix = defined($3) ? $3 : ''; # keep -w happy
+ $Prefix = quotemeta $Prefix ;
+ ($Module_cname = $Module) =~ s/\W/_/g;
+ ($Packid = $Package) =~ tr/:/_/;
+ $Packprefix = $Package;
+ $Packprefix .= "::" if $Packprefix ne "";
+ $lastline = "";
+ }
+
+ for(;;) {
+ if ($lastline !~ /^\s*#/ ||
+ # CPP directives:
+ # ANSI: if ifdef ifndef elif else endif define undef
+ # line error pragma
+ # gcc: warning include_next
+ # obj-c: import
+ # others: ident (gcc notes that some cpps have this one)
+ $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
+ last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
+ push(@line, $lastline);
+ push(@line_no, $lastline_no) ;
+ }
+
+ # Read next line and continuation lines
+ last unless defined($lastline = <$FH>);
+ $lastline_no = $.;
+ my $tmp_line;
+ $lastline .= $tmp_line
+ while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
+
+ chomp $lastline;
+ $lastline =~ s/^\s+$//;
+ }
+ pop(@line), pop(@line_no) while @line && $line[-1] eq "";
+ 1;
+}
+
+PARAGRAPH:
+while (fetch_para()) {
+ # Print initial preprocessor statements and blank lines
+ while (@line && $line[0] !~ /^[^\#]/) {
+ my $line = shift(@line);
+ print $line, "\n";
+ next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
+ my $statement = $+;
+ if ($statement eq 'if') {
+ $XSS_work_idx = @XSStack;
+ push(@XSStack, {type => 'if'});
+ } else {
+ death ("Error: `$statement' with no matching `if'")
+ if $XSStack[-1]{type} ne 'if';
+ if ($XSStack[-1]{varname}) {
+ push(@InitFileCode, "#endif\n");
+ push(@BootCode, "#endif");
+ }
+
+ my(@fns) = keys %{$XSStack[-1]{functions}};
+ if ($statement ne 'endif') {
+ # Hide the functions defined in other #if branches, and reset.
+ @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
+ @{$XSStack[-1]}{qw(varname functions)} = ('', {});
+ } else {
+ my($tmp) = pop(@XSStack);
+ 0 while (--$XSS_work_idx
+ && $XSStack[$XSS_work_idx]{type} ne 'if');
+ # Keep all new defined functions
+ push(@fns, keys %{$tmp->{other_functions}});
+ @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
+ }
+ }
+ }
+
+ next PARAGRAPH unless @line;
+
+ if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
+ # We are inside an #if, but have not yet #defined its xsubpp variable.
+ print "#define $cpp_next_tmp 1\n\n";
+ push(@InitFileCode, "#if $cpp_next_tmp\n");
+ push(@BootCode, "#if $cpp_next_tmp");
+ $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
+ }
+
+ death ("Code is not inside a function"
+ ." (maybe last function was ended by a blank line "
+ ." followed by a a statement on column one?)")
+ if $line[0] =~ /^\s/;
+
+ # initialize info arrays
+ undef(%args_match);
+ undef(%var_types);
+ undef(%var_addr);
+ undef(%defaults);
+ undef($class);
+ undef($static);
+ undef($elipsis);
+ undef($wantRETVAL) ;
+ undef(%arg_list) ;
+ undef(@proto_arg) ;
+ undef($proto_in_this_xsub) ;
+ undef($scope_in_this_xsub) ;
+ undef($interface);
+ $interface_macro = 'XSINTERFACE_FUNC' ;
+ $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
+ $ProtoThisXSUB = $WantPrototypes ;
+ $ScopeThisXSUB = 0;
+
+ $_ = shift(@line);
+ while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
+ &{"${kwd}_handler"}() ;
+ next PARAGRAPH unless @line ;
+ $_ = shift(@line);
+ }
+
+ if (check_keyword("BOOT")) {
+ &check_cpp;
+ push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"")
+ if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
+ push (@BootCode, @line, "") ;
+ next PARAGRAPH ;
+ }
+
+
+ # extract return type, function name and arguments
+ ($ret_type) = TidyType($_);
+
+ # a function definition needs at least 2 lines
+ blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
+ unless @line ;
+
+ $static = 1 if $ret_type =~ s/^static\s+//;
+
+ $func_header = shift(@line);
+ blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
+ unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*$/s;
+
+ ($class, $func_name, $orig_args) = ($1, $2, $3) ;
+ $class = "$4 $class" if $4;
+ ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
+ ($clean_func_name = $func_name) =~ s/^$Prefix//;
+ $Full_func_name = "${Packid}_$clean_func_name";
+ if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); }
+
+ # Check for duplicate function definition
+ for $tmp (@XSStack) {
+ next unless defined $tmp->{functions}{$Full_func_name};
+ Warn("Warning: duplicate function definition '$clean_func_name' detected");
+ last;
+ }
+ $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
+ %XsubAliases = %XsubAliasValues = %Interfaces = ();
+ $DoSetMagic = 1;
+
+ @args = split(/\s*,\s*/, $orig_args);
+ if (defined($class)) {
+ my $arg0 = ((defined($static) or $func_name eq 'new')
+ ? "CLASS" : "THIS");
+ unshift(@args, $arg0);
+ ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
+ }
+ $orig_args =~ s/"/\\"/g;
+ $min_args = $num_args = @args;
+ foreach $i (0..$num_args-1) {
+ if ($args[$i] =~ s/\.\.\.//) {
+ $elipsis = 1;
+ $min_args--;
+ if ($args[$i] eq '' && $i == $num_args - 1) {
+ pop(@args);
+ last;
+ }
+ }
+ if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
+ $min_args--;
+ $args[$i] = $1;
+ $defaults{$args[$i]} = $2;
+ $defaults{$args[$i]} =~ s/"/\\"/g;
+ }
+ $proto_arg[$i+1] = "\$" ;
+ }
+ if (defined($class)) {
+ $func_args = join(", ", @args[1..$#args]);
+ } else {
+ $func_args = join(", ", @args);
+ }
+ @args_match{@args} = 1..@args;
+
+ $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
+ $CODE = grep(/^\s*CODE\s*:/, @line);
+ # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
+ # to set explicit return values.
+ $EXPLICIT_RETURN = ($CODE &&
+ ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
+ $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
+ $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
+
+ # print function header
+ print Q<<"EOF";
+#XS(XS_${Full_func_name})
+#[[
+# dXSARGS;
+EOF
+ print Q<<"EOF" if $ALIAS ;
+# dXSI32;
+EOF
+ print Q<<"EOF" if $INTERFACE ;
+# dXSFUNCTION($ret_type);
+EOF
+ if ($elipsis) {
+ $cond = ($min_args ? qq(items < $min_args) : 0);
+ }
+ elsif ($min_args == $num_args) {
+ $cond = qq(items != $min_args);
+ }
+ else {
+ $cond = qq(items < $min_args || items > $num_args);
+ }
+
+ print Q<<"EOF" if $except;
+# char errbuf[1024];
+# *errbuf = '\0';
+EOF
+
+ if ($ALIAS)
+ { print Q<<"EOF" if $cond }
+# if ($cond)
+# croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
+EOF
+ else
+ { print Q<<"EOF" if $cond }
+# if ($cond)
+# croak("Usage: $pname($orig_args)");
+EOF
+
+ print Q<<"EOF" if $PPCODE;
+# SP -= items;
+EOF
+
+ # Now do a block of some sort.
+
+ $condnum = 0;
+ $cond = ''; # last CASE: condidional
+ push(@line, "$END:");
+ push(@line_no, $line_no[-1]);
+ $_ = '';
+ &check_cpp;
+ while (@line) {
+ &CASE_handler if check_keyword("CASE");
+ print Q<<"EOF";
+# $except [[
+EOF
+
+ # do initialization of input variables
+ $thisdone = 0;
+ $retvaldone = 0;
+ $deferred = "";
+ %arg_list = () ;
+ $gotRETVAL = 0;
+
+ INPUT_handler() ;
+ process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ;
+
+ print Q<<"EOF" if $ScopeThisXSUB;
+# ENTER;
+# [[
+EOF
+
+ if (!$thisdone && defined($class)) {
+ if (defined($static) or $func_name eq 'new') {
+ print "\tchar *";
+ $var_types{"CLASS"} = "char *";
+ &generate_init("char *", 1, "CLASS");
+ }
+ else {
+ print "\t$class *";
+ $var_types{"THIS"} = "$class *";
+ &generate_init("$class *", 1, "THIS");
+ }
+ }
+
+ # do code
+ if (/^\s*NOT_IMPLEMENTED_YET/) {
+ print "\n\tcroak(\"$pname: not implemented yet\");\n";
+ $_ = '' ;
+ } else {
+ if ($ret_type ne "void") {
+ print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
+ if !$retvaldone;
+ $args_match{"RETVAL"} = 0;
+ $var_types{"RETVAL"} = $ret_type;
+ }
+
+ print $deferred;
+
+ process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
+
+ if (check_keyword("PPCODE")) {
+ print_section();
+ death ("PPCODE must be last thing") if @line;
+ print "\tLEAVE;\n" if $ScopeThisXSUB;
+ print "\tPUTBACK;\n\treturn;\n";
+ } elsif (check_keyword("CODE")) {
+ print_section() ;
+ } elsif (defined($class) and $func_name eq "DESTROY") {
+ print "\n\t";
+ print "delete THIS;\n";
+ } else {
+ print "\n\t";
+ if ($ret_type ne "void") {
+ print "RETVAL = ";
+ $wantRETVAL = 1;
+ }
+ if (defined($static)) {
+ if ($func_name eq 'new') {
+ $func_name = "$class";
+ } else {
+ print "${class}::";
+ }
+ } elsif (defined($class)) {
+ if ($func_name eq 'new') {
+ $func_name .= " $class";
+ } else {
+ print "THIS->";
+ }
+ }
+ $func_name =~ s/^($spat)//
+ if defined($spat);
+ $func_name = 'XSFUNCTION' if $interface;
+ print "$func_name($func_args);\n";
+ }
+ }
+
+ # do output variables
+ $gotRETVAL = 0;
+ undef $RETVAL_code ;
+ undef %outargs ;
+ process_keyword("OUTPUT|ALIAS|PROTOTYPE");
+
+ # all OUTPUT done, so now push the return value on the stack
+ if ($gotRETVAL && $RETVAL_code) {
+ print "\t$RETVAL_code\n";
+ } elsif ($gotRETVAL || $wantRETVAL) {
+ # RETVAL almost never needs SvSETMAGIC()
+ &generate_output($ret_type, 0, 'RETVAL', 0);
+ }
+
+ # do cleanup
+ process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
+
+ print Q<<"EOF" if $ScopeThisXSUB;
+# ]]
+EOF
+ print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE;
+# LEAVE;
+EOF
+
+ # print function trailer
+ print Q<<EOF;
+# ]]
+EOF
+ print Q<<EOF if $except;
+# BEGHANDLERS
+# CATCHALL
+# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
+# ENDHANDLERS
+EOF
+ if (check_keyword("CASE")) {
+ blurt ("Error: No `CASE:' at top of function")
+ unless $condnum;
+ $_ = "CASE: $_"; # Restore CASE: label
+ next;
+ }
+ last if $_ eq "$END:";
+ death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
+ }
+
+ print Q<<EOF if $except;
+# if (errbuf[0])
+# croak(errbuf);
+EOF
+
+ if ($ret_type ne "void" or $EXPLICIT_RETURN) {
+ print Q<<EOF unless $PPCODE;
+# XSRETURN(1);
+EOF
+ } else {
+ print Q<<EOF unless $PPCODE;
+# XSRETURN_EMPTY;
+EOF
+ }
+
+ print Q<<EOF;
+#]]
+#
+EOF
+
+ my $newXS = "newXS" ;
+ my $proto = "" ;
+
+ # Build the prototype string for the xsub
+ if ($ProtoThisXSUB) {
+ $newXS = "newXSproto";
+
+ if ($ProtoThisXSUB eq 2) {
+ # User has specified empty prototype
+ $proto = ', ""' ;
+ }
+ elsif ($ProtoThisXSUB ne 1) {
+ # User has specified a prototype
+ $proto = ', "' . $ProtoThisXSUB . '"';
+ }
+ else {
+ my $s = ';';
+ if ($min_args < $num_args) {
+ $s = '';
+ $proto_arg[$min_args] .= ";" ;
+ }
+ push @proto_arg, "$s\@"
+ if $elipsis ;
+
+ $proto = ', "' . join ("", @proto_arg) . '"';
+ }
+ }
+
+ if (%XsubAliases) {
+ $XsubAliases{$pname} = 0
+ unless defined $XsubAliases{$pname} ;
+ while ( ($name, $value) = each %XsubAliases) {
+ push(@InitFileCode, Q<<"EOF");
+# cv = newXS(\"$name\", XS_$Full_func_name, file);
+# XSANY.any_i32 = $value ;
+EOF
+ push(@InitFileCode, Q<<"EOF") if $proto;
+# sv_setpv((SV*)cv$proto) ;
+EOF
+ }
+ }
+ elsif ($interface) {
+ while ( ($name, $value) = each %Interfaces) {
+ $name = "$Package\::$name" unless $name =~ /::/;
+ push(@InitFileCode, Q<<"EOF");
+# cv = newXS(\"$name\", XS_$Full_func_name, file);
+# $interface_macro_set(cv,$value) ;
+EOF
+ push(@InitFileCode, Q<<"EOF") if $proto;
+# sv_setpv((SV*)cv$proto) ;
+EOF
+ }
+ }
+ else {
+ push(@InitFileCode,
+ " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
+ }
+}
+
+# print initialization routine
+if ($WantCAPI) {
+print Q<<"EOF";
+#
+##ifdef __cplusplus
+#extern "C"
+##endif
+#XS(boot__CAPI_entry)
+#[[
+# dXSARGS;
+# char* file = __FILE__;
+#
+EOF
+} else {
+print Q<<"EOF";
+##ifdef __cplusplus
+#extern "C"
+##endif
+#XS(boot_$Module_cname)
+#[[
+# dXSARGS;
+# char* file = __FILE__;
+#
+EOF
+}
+
+print Q<<"EOF" if $WantVersionChk ;
+# XS_VERSION_BOOTCHECK ;
+#
+EOF
+
+print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ;
+# {
+# CV * cv ;
+#
+EOF
+
+print @InitFileCode;
+
+print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ;
+# }
+EOF
+
+if (@BootCode)
+{
+ print "\n /* Initialisation Section */\n\n" ;
+ @line = @BootCode;
+ print_section();
+ print "\n /* End of Initialisation Section */\n\n" ;
+}
+
+print Q<<"EOF";;
+# XSRETURN_YES;
+#]]
+#
+EOF
+
+if ($WantCAPI) {
+print Q<<"EOF";
+#
+##define XSCAPI(name) void name(CV* cv, void* pPerl)
+#
+##ifdef __cplusplus
+#extern "C"
+##endif
+#XSCAPI(boot_$Module_cname)
+#[[
+# SetCPerlObj(pPerl);
+# boot__CAPI_entry(cv);
+#]]
+#
+EOF
+}
+
+warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
+ unless $ProtoUsed ;
+&Exit;
+
+sub output_init {
+ local($type, $num, $var, $init) = @_;
+ local($arg) = "ST(" . ($num - 1) . ")";
+
+ if( $init =~ /^=/ ) {
+ eval qq/print "\\t$var $init\\n"/;
+ warn $@ if $@;
+ } else {
+ if( $init =~ s/^\+// && $num ) {
+ &generate_init($type, $num, $var);
+ } else {
+ eval qq/print "\\t$var;\\n"/;
+ warn $@ if $@;
+ $init =~ s/^;//;
+ }
+ $deferred .= eval qq/"\\n\\t$init\\n"/;
+ warn $@ if $@;
+ }
+}
+
+sub Warn
+{
+ # work out the line number
+ my $line_no = $line_no[@line_no - @line -1] ;
+
+ print STDERR "@_ in $filename, line $line_no\n" ;
+}
+
+sub blurt
+{
+ Warn @_ ;
+ $errors ++
+}
+
+sub death
+{
+ Warn @_ ;
+ exit 1 ;
+}
+
+sub generate_init {
+ local($type, $num, $var) = @_;
+ local($arg) = "ST(" . ($num - 1) . ")";
+ local($argoff) = $num - 1;
+ local($ntype);
+ local($tk);
+
+ $type = TidyType($type) ;
+ blurt("Error: '$type' not in typemap"), return
+ unless defined($type_kind{$type});
+
+ ($ntype = $type) =~ s/\s*\*/Ptr/g;
+ ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
+ $tk = $type_kind{$type};
+ $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
+ $type =~ tr/:/_/;
+ blurt("Error: No INPUT definition for type '$type' found"), return
+ unless defined $input_expr{$tk} ;
+ $expr = $input_expr{$tk};
+ if ($expr =~ /DO_ARRAY_ELEM/) {
+ blurt("Error: '$subtype' not in typemap"), return
+ unless defined($type_kind{$subtype});
+ blurt("Error: No INPUT definition for type '$subtype' found"), return
+ unless defined $input_expr{$type_kind{$subtype}} ;
+ $subexpr = $input_expr{$type_kind{$subtype}};
+ $subexpr =~ s/ntype/subtype/g;
+ $subexpr =~ s/\$arg/ST(ix_$var)/g;
+ $subexpr =~ s/\n\t/\n\t\t/g;
+ $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
+ $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
+ $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
+ }
+ if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
+ $ScopeThisXSUB = 1;
+ }
+ if (defined($defaults{$var})) {
+ $expr =~ s/(\t+)/$1 /g;
+ $expr =~ s/ /\t/g;
+ eval qq/print "\\t$var;\\n"/;
+ warn $@ if $@;
+ $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
+ warn $@ if $@;
+ } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
+ eval qq/print "\\t$var;\\n"/;
+ warn $@ if $@;
+ $deferred .= eval qq/"\\n$expr;\\n"/;
+ warn $@ if $@;
+ } else {
+ eval qq/print "$expr;\\n"/;
+ warn $@ if $@;
+ }
+}
+
+sub generate_output {
+ local($type, $num, $var, $do_setmagic) = @_;
+ local($arg) = "ST(" . ($num - ($num != 0)) . ")";
+ local($argoff) = $num - 1;
+ local($ntype);
+
+ $type = TidyType($type) ;
+ if ($type =~ /^array\(([^,]*),(.*)\)/) {
+ print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
+ print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
+ } else {
+ blurt("Error: '$type' not in typemap"), return
+ unless defined($type_kind{$type});
+ blurt("Error: No OUTPUT definition for type '$type' found"), return
+ unless defined $output_expr{$type_kind{$type}} ;
+ ($ntype = $type) =~ s/\s*\*/Ptr/g;
+ $ntype =~ s/\(\)//g;
+ ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
+ $expr = $output_expr{$type_kind{$type}};
+ if ($expr =~ /DO_ARRAY_ELEM/) {
+ blurt("Error: '$subtype' not in typemap"), return
+ unless defined($type_kind{$subtype});
+ blurt("Error: No OUTPUT definition for type '$subtype' found"), return
+ unless defined $output_expr{$type_kind{$subtype}} ;
+ $subexpr = $output_expr{$type_kind{$subtype}};
+ $subexpr =~ s/ntype/subtype/g;
+ $subexpr =~ s/\$arg/ST(ix_$var)/g;
+ $subexpr =~ s/\$var/${var}[ix_$var]/g;
+ $subexpr =~ s/\n\t/\n\t\t/g;
+ $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
+ }
+ elsif ($var eq 'RETVAL') {
+ if ($expr =~ /^\t\$arg = new/) {
+ # We expect that $arg has refcnt 1, so we need to
+ # mortalize it.
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ print "\tsv_2mortal(ST(0));\n";
+ print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
+ }
+ elsif ($expr =~ /^\s*\$arg\s*=/) {
+ # We expect that $arg has refcnt >=1, so we need
+ # to mortalize it!
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ print "\tsv_2mortal(ST(0));\n";
+ print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
+ }
+ else {
+ # Just hope that the entry would safely write it
+ # over an already mortalized value. By
+ # coincidence, something like $arg = &sv_undef
+ # works too.
+ print "\tST(0) = sv_newmortal();\n";
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ # new mortals don't have set magic
+ }
+ }
+ elsif ($arg =~ /^ST\(\d+\)$/) {
+ eval "print qq\a$expr\a";
+ warn $@ if $@;
+ print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
+ }
+ }
+}
+
+sub map_type {
+ my($type) = @_;
+
+ $type =~ tr/:/_/;
+ $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
+ $type;
+}
+
+
+sub Exit {
+# If this is VMS, the exit status has meaning to the shell, so we
+# use a predictable value (SS$_Normal or SS$_Abort) rather than an
+# arbitrary number.
+# exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
+ exit ($errors ? 1 : 0);
+}
diff --git a/contrib/perl5/lib/Fatal.pm b/contrib/perl5/lib/Fatal.pm
new file mode 100644
index 000000000000..a1e5cffcf406
--- /dev/null
+++ b/contrib/perl5/lib/Fatal.pm
@@ -0,0 +1,157 @@
+package Fatal;
+
+use Carp;
+use strict;
+use vars qw( $AUTOLOAD $Debug $VERSION);
+
+$VERSION = 1.02;
+
+$Debug = 0 unless defined $Debug;
+
+sub import {
+ my $self = shift(@_);
+ my($sym, $pkg);
+ $pkg = (caller)[0];
+ foreach $sym (@_) {
+ &_make_fatal($sym, $pkg);
+ }
+};
+
+sub AUTOLOAD {
+ my $cmd = $AUTOLOAD;
+ $cmd =~ s/.*:://;
+ &_make_fatal($cmd, (caller)[0]);
+ goto &$AUTOLOAD;
+}
+
+sub fill_protos {
+ my $proto = shift;
+ my ($n, $isref, @out, @out1, $seen_semi) = -1;
+ while ($proto =~ /\S/) {
+ $n++;
+ push(@out1,[$n,@out]) if $seen_semi;
+ push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
+ push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([*\$&])//;
+ push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
+ $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
+ die "Unknown prototype letters: \"$proto\"";
+ }
+ push(@out1,[$n+1,@out]);
+ @out1;
+}
+
+sub write_invocation {
+ my ($core, $call, $name, @argvs) = @_;
+ if (@argvs == 1) { # No optional arguments
+ my @argv = @{$argvs[0]};
+ shift @argv;
+ return "\t" . one_invocation($core, $call, $name, @argv) . ";\n";
+ } else {
+ my $else = "\t";
+ my (@out, @argv, $n);
+ while (@argvs) {
+ @argv = @{shift @argvs};
+ $n = shift @argv;
+ push @out, "$ {else}if (\@_ == $n) {\n";
+ $else = "\t} els";
+ push @out,
+ "\t\treturn " . one_invocation($core, $call, $name, @argv) . ";\n";
+ }
+ push @out, <<EOC;
+ }
+ die "$name(\@_): Do not expect to get ", scalar \@_, " arguments";
+EOC
+ return join '', @out;
+ }
+}
+
+sub one_invocation {
+ my ($core, $call, $name, @argv) = @_;
+ local $" = ', ';
+ return qq{$call(@argv) || croak "Can't $name(\@_)} .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '"';
+}
+
+sub _make_fatal {
+ my($sub, $pkg) = @_;
+ my($name, $code, $sref, $real_proto, $proto, $core, $call);
+ my $ini = $sub;
+
+ $sub = "${pkg}::$sub" unless $sub =~ /::/;
+ $name = $sub;
+ $name =~ s/.*::// or $name =~ s/^&//;
+ print "# _make_fatal: sub=$sub pkg=$pkg name=$name\n" if $Debug;
+ croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
+ if (defined(&$sub)) { # user subroutine
+ $sref = \&$sub;
+ $proto = prototype $sref;
+ $call = '&$sref';
+ } elsif ($sub eq $ini) { # Stray user subroutine
+ die "$sub is not a Perl subroutine"
+ } else { # CORE subroutine
+ $proto = eval { prototype "CORE::$name" };
+ die "$name is neither a builtin, nor a Perl subroutine"
+ if $@;
+ die "Cannot make a non-overridable builtin fatal"
+ if not defined $proto;
+ $core = 1;
+ $call = "CORE::$name";
+ }
+ if (defined $proto) {
+ $real_proto = " ($proto)";
+ } else {
+ $real_proto = '';
+ $proto = '@';
+ }
+ $code = <<EOS;
+sub$real_proto {
+ local(\$", \$!) = (', ', 0);
+EOS
+ my @protos = fill_protos($proto);
+ $code .= write_invocation($core, $call, $name, @protos);
+ $code .= "}\n";
+ print $code if $Debug;
+ $code = eval($code);
+ die if $@;
+ local($^W) = 0; # to avoid: Subroutine foo redefined ...
+ no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
+ *{$sub} = $code;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Fatal - replace functions with equivalents which succeed or die
+
+=head1 SYNOPSIS
+
+ use Fatal qw(open close);
+
+ sub juggle { . . . }
+ import Fatal 'juggle';
+
+=head1 DESCRIPTION
+
+C<Fatal> provides a way to conveniently replace functions which normally
+return a false value when they fail with equivalents which halt execution
+if they are not successful. This lets you use these functions without
+having to test their return values explicitly on each call. Errors are
+reported via C<die>, so you can trap them using C<$SIG{__DIE__}> if you
+wish to take some action before the program exits.
+
+The do-or-die equivalents are set up simply by calling Fatal's
+C<import> routine, passing it the names of the functions to be
+replaced. You may wrap both user-defined functions and overridable
+CORE operators (except C<exec>, C<system> which cannot be expressed
+via prototypes) in this way.
+
+=head1 AUTHOR
+
+Lionel.Cons@cern.ch
+
+prototype updates by Ilya Zakharevich ilya@math.ohio-state.edu
+
+=cut
diff --git a/contrib/perl5/lib/File/Basename.pm b/contrib/perl5/lib/File/Basename.pm
new file mode 100644
index 000000000000..69bb1fa5fdcf
--- /dev/null
+++ b/contrib/perl5/lib/File/Basename.pm
@@ -0,0 +1,263 @@
+package File::Basename;
+
+=head1 NAME
+
+fileparse - split a pathname into pieces
+
+basename - extract just the filename from a path
+
+dirname - extract just the directory from a path
+
+=head1 SYNOPSIS
+
+ use File::Basename;
+
+ ($name,$path,$suffix) = fileparse($fullname,@suffixlist)
+ fileparse_set_fstype($os_string);
+ $basename = basename($fullname,@suffixlist);
+ $dirname = dirname($fullname);
+
+ ($name,$path,$suffix) = fileparse("lib/File/Basename.pm","\.pm");
+ fileparse_set_fstype("VMS");
+ $basename = basename("lib/File/Basename.pm",".pm");
+ $dirname = dirname("lib/File/Basename.pm");
+
+=head1 DESCRIPTION
+
+These routines allow you to parse file specifications into useful
+pieces using the syntax of different operating systems.
+
+=over 4
+
+=item fileparse_set_fstype
+
+You select the syntax via the routine fileparse_set_fstype().
+
+If the argument passed to it contains one of the substrings
+"VMS", "MSDOS", "MacOS", "AmigaOS" or "MSWin32", the file specification
+syntax of that operating system is used in future calls to
+fileparse(), basename(), and dirname(). If it contains none of
+these substrings, UNIX syntax is used. This pattern matching is
+case-insensitive. If you've selected VMS syntax, and the file
+specification you pass to one of these routines contains a "/",
+they assume you are using UNIX emulation and apply the UNIX syntax
+rules instead, for that function call only.
+
+If the argument passed to it contains one of the substrings "VMS",
+"MSDOS", "MacOS", "AmigaOS", "os2", "MSWin32" or "RISCOS", then the pattern
+matching for suffix removal is performed without regard for case,
+since those systems are not case-sensitive when opening existing files
+(though some of them preserve case on file creation).
+
+If you haven't called fileparse_set_fstype(), the syntax is chosen
+by examining the builtin variable C<$^O> according to these rules.
+
+=item fileparse
+
+The fileparse() routine divides a file specification into three
+parts: a leading B<path>, a file B<name>, and a B<suffix>. The
+B<path> contains everything up to and including the last directory
+separator in the input file specification. The remainder of the input
+file specification is then divided into B<name> and B<suffix> based on
+the optional patterns you specify in C<@suffixlist>. Each element of
+this list is interpreted as a regular expression, and is matched
+against the end of B<name>. If this succeeds, the matching portion of
+B<name> is removed and prepended to B<suffix>. By proper use of
+C<@suffixlist>, you can remove file types or versions for examination.
+
+You are guaranteed that if you concatenate B<path>, B<name>, and
+B<suffix> together in that order, the result will denote the same
+file as the input file specification.
+
+=back
+
+=head1 EXAMPLES
+
+Using UNIX file syntax:
+
+ ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
+ '\.book\d+');
+
+would yield
+
+ $base eq 'draft'
+ $path eq '/virgil/aeneid/',
+ $type eq '.book7'
+
+Similarly, using VMS syntax:
+
+ ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh',
+ '\..*');
+
+would yield
+
+ $name eq 'Rhetoric'
+ $dir eq 'Doc_Root:[Help]'
+ $type eq '.Rnh'
+
+=over
+
+=item C<basename>
+
+The basename() routine returns the first element of the list produced
+by calling fileparse() with the same arguments, except that it always
+quotes metacharacters in the given suffixes. It is provided for
+programmer compatibility with the UNIX shell command basename(1).
+
+=item C<dirname>
+
+The dirname() routine returns the directory portion of the input file
+specification. When using VMS or MacOS syntax, this is identical to the
+second element of the list produced by calling fileparse() with the same
+input file specification. (Under VMS, if there is no directory information
+in the input file specification, then the current default device and
+directory are returned.) When using UNIX or MSDOS syntax, the return
+value conforms to the behavior of the UNIX shell command dirname(1). This
+is usually the same as the behavior of fileparse(), but differs in some
+cases. For example, for the input file specification F<lib/>, fileparse()
+considers the directory name to be F<lib/>, while dirname() considers the
+directory name to be F<.>).
+
+=back
+
+=cut
+
+
+## use strict;
+use re 'taint';
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
+use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase);
+$VERSION = "2.6";
+
+
+# fileparse_set_fstype() - specify OS-based rules used in future
+# calls to routines in this package
+#
+# Currently recognized values: VMS, MSDOS, MacOS, AmigaOS, os2, RISCOS
+# Any other name uses Unix-style rules and is case-sensitive
+
+sub fileparse_set_fstype {
+ my @old = ($Fileparse_fstype, $Fileparse_igncase);
+ if (@_) {
+ $Fileparse_fstype = $_[0];
+ $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32|MSDOS)/i);
+ }
+ wantarray ? @old : $old[0];
+}
+
+# fileparse() - parse file specification
+#
+# Version 2.4 27-Sep-1996 Charles Bailey bailey@genetics.upenn.edu
+
+
+sub fileparse {
+ my($fullname,@suffices) = @_;
+ my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
+ my($dirpath,$tail,$suffix,$basename);
+ my($taint) = substr($fullname,0,0); # Is $fullname tainted?
+
+ if ($fstype =~ /^VMS/i) {
+ if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation
+ else {
+ ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/);
+ $dirpath ||= ''; # should always be defined
+ }
+ }
+ if ($fstype =~ /^MS(DOS|Win32)/i) {
+ ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/);
+ $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/;
+ }
+ elsif ($fstype =~ /^MacOS/i) {
+ ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/);
+ }
+ elsif ($fstype =~ /^AmigaOS/i) {
+ ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/);
+ $dirpath = './' unless $dirpath;
+ }
+ elsif ($fstype !~ /^VMS/i) { # default to Unix
+ ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#);
+ if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) {
+ # dev:[000000] is top of VMS tree, similar to Unix '/'
+ ($basename,$dirpath) = ('',$fullname);
+ }
+ $dirpath = './' unless $dirpath;
+ }
+
+ if (@suffices) {
+ $tail = '';
+ foreach $suffix (@suffices) {
+ my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
+ if ($basename =~ s/$pat//) {
+ $taint .= substr($suffix,0,0);
+ $tail = $1 . $tail;
+ }
+ }
+ }
+
+ $tail .= $taint if defined $tail; # avoid warning if $tail == undef
+ wantarray ? ($basename . $taint, $dirpath . $taint, $tail)
+ : $basename . $taint;
+}
+
+
+# basename() - returns first element of list returned by fileparse()
+
+sub basename {
+ my($name) = shift;
+ (fileparse($name, map("\Q$_\E",@_)))[0];
+}
+
+
+# dirname() - returns device and directory portion of file specification
+# Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS
+# filespecs except for names ending with a separator, e.g., "/xx/yy/".
+# This differs from the second element of the list returned
+# by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and
+# the last directory name if the filespec ends in a '/' or '\'), is lost.
+
+sub dirname {
+ my($basename,$dirname) = fileparse($_[0]);
+ my($fstype) = $Fileparse_fstype;
+
+ if ($fstype =~ /VMS/i) {
+ if ($_[0] =~ m#/#) { $fstype = '' }
+ else { return $dirname || $ENV{DEFAULT} }
+ }
+ if ($fstype =~ /MacOS/i) { return $dirname }
+ elsif ($fstype =~ /MSDOS/i) {
+ $dirname =~ s/([^:])[\\\/]*$/$1/;
+ unless( length($basename) ) {
+ ($basename,$dirname) = fileparse $dirname;
+ $dirname =~ s/([^:])[\\\/]*$/$1/;
+ }
+ }
+ elsif ($fstype =~ /MSWin32/i) {
+ $dirname =~ s/([^:])[\\\/]*$/$1/;
+ unless( length($basename) ) {
+ ($basename,$dirname) = fileparse $dirname;
+ $dirname =~ s/([^:])[\\\/]*$/$1/;
+ }
+ }
+ elsif ($fstype =~ /AmigaOS/i) {
+ if ( $dirname =~ /:$/) { return $dirname }
+ chop $dirname;
+ $dirname =~ s#[^:/]+$## unless length($basename);
+ }
+ else {
+ $dirname =~ s:(.)/*$:$1:;
+ unless( length($basename) ) {
+ local($File::Basename::Fileparse_fstype) = $fstype;
+ ($basename,$dirname) = fileparse $dirname;
+ $dirname =~ s:(.)/*$:$1:;
+ }
+ }
+
+ $dirname;
+}
+
+fileparse_set_fstype $^O;
+
+1;
diff --git a/contrib/perl5/lib/File/CheckTree.pm b/contrib/perl5/lib/File/CheckTree.pm
new file mode 100644
index 000000000000..dca7f6aff31a
--- /dev/null
+++ b/contrib/perl5/lib/File/CheckTree.pm
@@ -0,0 +1,151 @@
+package File::CheckTree;
+require 5.000;
+require Exporter;
+
+=head1 NAME
+
+validate - run many filetest checks on a tree
+
+=head1 SYNOPSIS
+
+ use File::CheckTree;
+
+ $warnings += validate( q{
+ /vmunix -e || die
+ /boot -e || die
+ /bin cd
+ csh -ex
+ csh !-ug
+ sh -ex
+ sh !-ug
+ /usr -d || warn "What happened to $file?\n"
+ });
+
+=head1 DESCRIPTION
+
+The validate() routine takes a single multiline string consisting of
+lines containing a filename plus a file test to try on it. (The
+file test may also be a "cd", causing subsequent relative filenames
+to be interpreted relative to that directory.) After the file test
+you may put C<|| die> to make it a fatal error if the file test fails.
+The default is C<|| warn>. The file test may optionally have a "!' prepended
+to test for the opposite condition. If you do a cd and then list some
+relative filenames, you may want to indent them slightly for readability.
+If you supply your own die() or warn() message, you can use $file to
+interpolate the filename.
+
+Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
+Only the first failed test of the bunch will produce a warning.
+
+The routine returns the number of warnings issued.
+
+=cut
+
+@ISA = qw(Exporter);
+@EXPORT = qw(validate);
+
+# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $
+
+# The validate routine takes a single multiline string consisting of
+# lines containing a filename plus a file test to try on it. (The
+# file test may also be a 'cd', causing subsequent relative filenames
+# to be interpreted relative to that directory.) After the file test
+# you may put '|| die' to make it a fatal error if the file test fails.
+# The default is '|| warn'. The file test may optionally have a ! prepended
+# to test for the opposite condition. If you do a cd and then list some
+# relative filenames, you may want to indent them slightly for readability.
+# If you supply your own "die" or "warn" message, you can use $file to
+# interpolate the filename.
+
+# Filetests may be bunched: -rwx tests for all of -r, -w and -x.
+# Only the first failed test of the bunch will produce a warning.
+
+# The routine returns the number of warnings issued.
+
+# Usage:
+# use File::CheckTree;
+# $warnings += validate('
+# /vmunix -e || die
+# /boot -e || die
+# /bin cd
+# csh -ex
+# csh !-ug
+# sh -ex
+# sh !-ug
+# /usr -d || warn "What happened to $file?\n"
+# ');
+
+sub validate {
+ local($file,$test,$warnings,$oldwarnings);
+ foreach $check (split(/\n/,$_[0])) {
+ next if $check =~ /^#/;
+ next if $check =~ /^$/;
+ ($file,$test) = split(' ',$check,2);
+ if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
+ $testlist = $2;
+ @testlist = split(//,$testlist);
+ }
+ else {
+ @testlist = ('Z');
+ }
+ $oldwarnings = $warnings;
+ foreach $one (@testlist) {
+ $this = $test;
+ $this =~ s/(-\w\b)/$1 \$file/g;
+ $this =~ s/-Z/-$one/;
+ $this .= ' || warn' unless $this =~ /\|\|/;
+ $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || valmess('$2','$1')/;
+ $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
+ eval $this;
+ last if $warnings > $oldwarnings;
+ }
+ }
+ $warnings;
+}
+
+sub valmess {
+ local($disposition,$this) = @_;
+ $file = $cwd . '/' . $file unless $file =~ m|^/|;
+ if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
+ $neg = $1;
+ $tmp = $2;
+ $tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
+ $tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
+ $tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
+ $tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
+ $tmp eq 'R' && ($mess = "$file is not readable by you.");
+ $tmp eq 'W' && ($mess = "$file is not writable by you.");
+ $tmp eq 'X' && ($mess = "$file is not executable by you.");
+ $tmp eq 'O' && ($mess = "$file is not owned by you.");
+ $tmp eq 'e' && ($mess = "$file does not exist.");
+ $tmp eq 'z' && ($mess = "$file does not have zero size.");
+ $tmp eq 's' && ($mess = "$file does not have non-zero size.");
+ $tmp eq 'f' && ($mess = "$file is not a plain file.");
+ $tmp eq 'd' && ($mess = "$file is not a directory.");
+ $tmp eq 'l' && ($mess = "$file is not a symbolic link.");
+ $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
+ $tmp eq 'S' && ($mess = "$file is not a socket.");
+ $tmp eq 'b' && ($mess = "$file is not a block special file.");
+ $tmp eq 'c' && ($mess = "$file is not a character special file.");
+ $tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
+ $tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
+ $tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
+ $tmp eq 'T' && ($mess = "$file is not a text file.");
+ $tmp eq 'B' && ($mess = "$file is not a binary file.");
+ if ($neg eq '!') {
+ $mess =~ s/ is not / should not be / ||
+ $mess =~ s/ does not / should not / ||
+ $mess =~ s/ not / /;
+ }
+ }
+ else {
+ $this =~ s/\$file/'$file'/g;
+ $mess = "Can't do $this.\n";
+ }
+ die "$mess\n" if $disposition eq 'die';
+ warn "$mess\n";
+ ++$warnings;
+}
+
+1;
+
diff --git a/contrib/perl5/lib/File/Compare.pm b/contrib/perl5/lib/File/Compare.pm
new file mode 100644
index 000000000000..2f9c45c4c60d
--- /dev/null
+++ b/contrib/perl5/lib/File/Compare.pm
@@ -0,0 +1,143 @@
+package File::Compare;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO);
+
+require Exporter;
+use Carp;
+
+$VERSION = '1.1001';
+@ISA = qw(Exporter);
+@EXPORT = qw(compare);
+@EXPORT_OK = qw(cmp);
+
+$Too_Big = 1024 * 1024 * 2;
+
+sub VERSION {
+ # Version of File::Compare
+ return $File::Compare::VERSION;
+}
+
+sub compare {
+ croak("Usage: compare( file1, file2 [, buffersize]) ")
+ unless(@_ == 2 || @_ == 3);
+
+ my $from = shift;
+ my $to = shift;
+ my $closefrom=0;
+ my $closeto=0;
+ my ($size, $fromsize, $status, $fr, $tr, $fbuf, $tbuf);
+ local(*FROM, *TO);
+ local($\) = '';
+
+ croak("from undefined") unless (defined $from);
+ croak("to undefined") unless (defined $to);
+
+ if (ref($from) &&
+ (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) {
+ *FROM = *$from;
+ } elsif (ref(\$from) eq 'GLOB') {
+ *FROM = $from;
+ } else {
+ open(FROM,"<$from") or goto fail_open1;
+ binmode FROM;
+ $closefrom = 1;
+ $fromsize = -s FROM;
+ }
+
+ if (ref($to) &&
+ (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) {
+ *TO = *$to;
+ } elsif (ref(\$to) eq 'GLOB') {
+ *TO = $to;
+ } else {
+ open(TO,"<$to") or goto fail_open2;
+ binmode TO;
+ $closeto = 1;
+ }
+
+ if ($closefrom && $closeto) {
+ # If both are opened files we know they differ if their size differ
+ goto fail_inner if $fromsize != -s TO;
+ }
+
+ if (@_) {
+ $size = shift(@_) + 0;
+ croak("Bad buffer size for compare: $size\n") unless ($size > 0);
+ } else {
+ $size = $fromsize;
+ $size = 1024 if ($size < 512);
+ $size = $Too_Big if ($size > $Too_Big);
+ }
+
+ $fbuf = '';
+ $tbuf = '';
+ while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) {
+ unless (defined($tr = read(TO,$tbuf,$fr)) and $tbuf eq $fbuf) {
+ goto fail_inner;
+ }
+ }
+ goto fail_inner if (defined($tr = read(TO,$tbuf,$size)) && $tr > 0);
+
+ close(TO) || goto fail_open2 if $closeto;
+ close(FROM) || goto fail_open1 if $closefrom;
+
+ return 0;
+
+ # All of these contortions try to preserve error messages...
+ fail_inner:
+ close(TO) || goto fail_open2 if $closeto;
+ close(FROM) || goto fail_open1 if $closefrom;
+
+ return 1;
+
+ fail_open2:
+ if ($closefrom) {
+ $status = $!;
+ $! = 0;
+ close FROM;
+ $! = $status unless $!;
+ }
+ fail_open1:
+ return -1;
+}
+
+*cmp = \&compare;
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::Compare - Compare files or filehandles
+
+=head1 SYNOPSIS
+
+ use File::Compare;
+
+ if (compare("file1","file2") == 0) {
+ print "They're equal\n";
+ }
+
+=head1 DESCRIPTION
+
+The File::Compare::compare function compares the contents of two
+sources, each of which can be a file or a file handle. It is exported
+from File::Compare by default.
+
+File::Compare::cmp is a synonym for File::Compare::compare. It is
+exported from File::Compare only by request.
+
+=head1 RETURN
+
+File::Compare::compare return 0 if the files are equal, 1 if the
+files are unequal, or -1 if an error was encountered.
+
+=head1 AUTHOR
+
+File::Compare was written by Nick Ing-Simmons.
+Its original documentation was written by Chip Salzenberg.
+
+=cut
+
diff --git a/contrib/perl5/lib/File/Copy.pm b/contrib/perl5/lib/File/Copy.pm
new file mode 100644
index 000000000000..d0b3c8977ef0
--- /dev/null
+++ b/contrib/perl5/lib/File/Copy.pm
@@ -0,0 +1,342 @@
+# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This
+# source code has been placed in the public domain by the author.
+# Please be kind and preserve the documentation.
+#
+# Additions copyright 1996 by Charles Bailey. Permission is granted
+# to distribute the revised code under the same terms as Perl itself.
+
+package File::Copy;
+
+use strict;
+use Carp;
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big
+ &copy &syscopy &cp &mv);
+
+# Note that this module implements only *part* of the API defined by
+# the File/Copy.pm module of the File-Tools-2.0 package. However, that
+# package has not yet been updated to work with Perl 5.004, and so it
+# would be a Bad Thing for the CPAN module to grab it and replace this
+# module. Therefore, we set this module's version higher than 2.0.
+$VERSION = '2.02';
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(copy move);
+@EXPORT_OK = qw(cp mv);
+
+$Too_Big = 1024 * 1024 * 2;
+
+sub _catname { # Will be replaced by File::Spec when it arrives
+ my($from, $to) = @_;
+ if (not defined &basename) {
+ require File::Basename;
+ import File::Basename 'basename';
+ }
+ if ($^O eq 'VMS') { $to = VMS::Filespec::vmspath($to) . basename($from); }
+ elsif ($^O eq 'MacOS') { $to .= ':' . basename($from); }
+ elsif ($to =~ m|\\|) { $to .= '\\' . basename($from); }
+ else { $to .= '/' . basename($from); }
+}
+
+sub copy {
+ croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
+ unless(@_ == 2 || @_ == 3);
+
+ my $from = shift;
+ my $to = shift;
+
+ my $from_a_handle = (ref($from)
+ ? (ref($from) eq 'GLOB'
+ || UNIVERSAL::isa($from, 'GLOB')
+ || UNIVERSAL::isa($from, 'IO::Handle'))
+ : (ref(\$from) eq 'GLOB'));
+ my $to_a_handle = (ref($to)
+ ? (ref($to) eq 'GLOB'
+ || UNIVERSAL::isa($to, 'GLOB')
+ || UNIVERSAL::isa($to, 'IO::Handle'))
+ : (ref(\$to) eq 'GLOB'));
+
+ if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
+ $to = _catname($from, $to);
+ }
+
+ if (defined &syscopy && \&syscopy != \&copy
+ && !$to_a_handle
+ && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles
+ && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX.
+ )
+ {
+ return syscopy($from, $to);
+ }
+
+ my $closefrom = 0;
+ my $closeto = 0;
+ my ($size, $status, $r, $buf);
+ local(*FROM, *TO);
+ local($\) = '';
+
+ if ($from_a_handle) {
+ *FROM = *$from{FILEHANDLE};
+ } else {
+ $from = "./$from" if $from =~ /^\s/;
+ open(FROM, "< $from\0") or goto fail_open1;
+ binmode FROM or die "($!,$^E)";
+ $closefrom = 1;
+ }
+
+ if ($to_a_handle) {
+ *TO = *$to{FILEHANDLE};
+ } else {
+ $to = "./$to" if $to =~ /^\s/;
+ open(TO,"> $to\0") or goto fail_open2;
+ binmode TO or die "($!,$^E)";
+ $closeto = 1;
+ }
+
+ if (@_) {
+ $size = shift(@_) + 0;
+ croak("Bad buffer size for copy: $size\n") unless ($size > 0);
+ } else {
+ $size = -s FROM;
+ $size = 1024 if ($size < 512);
+ $size = $Too_Big if ($size > $Too_Big);
+ }
+
+ $! = 0;
+ for (;;) {
+ my ($r, $w, $t);
+ defined($r = sysread(FROM, $buf, $size))
+ or goto fail_inner;
+ last unless $r;
+ for ($w = 0; $w < $r; $w += $t) {
+ $t = syswrite(TO, $buf, $r - $w, $w)
+ or goto fail_inner;
+ }
+ }
+
+ close(TO) || goto fail_open2 if $closeto;
+ close(FROM) || goto fail_open1 if $closefrom;
+
+ # Use this idiom to avoid uninitialized value warning.
+ return 1;
+
+ # All of these contortions try to preserve error messages...
+ fail_inner:
+ if ($closeto) {
+ $status = $!;
+ $! = 0;
+ close TO;
+ $! = $status unless $!;
+ }
+ fail_open2:
+ if ($closefrom) {
+ $status = $!;
+ $! = 0;
+ close FROM;
+ $! = $status unless $!;
+ }
+ fail_open1:
+ return 0;
+}
+
+sub move {
+ my($from,$to) = @_;
+ my($copied,$fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
+
+ if (-d $to && ! -d $from) {
+ $to = _catname($from, $to);
+ }
+
+ ($tosz1,$tomt1) = (stat($to))[7,9];
+ $fromsz = -s $from;
+ if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
+ # will not rename with overwrite
+ unlink $to;
+ }
+ return 1 if rename $from, $to;
+
+ ($sts,$ossts) = ($! + 0, $^E + 0);
+ # Did rename return an error even though it succeeded, because $to
+ # is on a remote NFS file system, and NFS lost the server's ack?
+ return 1 if defined($fromsz) && !-e $from && # $from disappeared
+ (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there
+ ($tosz1 != $tosz2 or $tomt1 != $tomt2) && # and changed
+ $tosz2 == $fromsz; # it's all there
+
+ ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
+ return 1 if ($copied = copy($from,$to)) && unlink($from);
+
+ ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
+ unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2;
+ ($!,$^E) = ($sts,$ossts);
+ return 0;
+}
+
+*cp = \&copy;
+*mv = \&move;
+
+# &syscopy is an XSUB under OS/2
+unless (defined &syscopy) {
+ if ($^O eq 'VMS') {
+ *syscopy = \&rmscopy;
+ } elsif ($^O eq 'mpeix') {
+ *syscopy = sub {
+ return 0 unless @_ == 2;
+ # Use the MPE cp program in order to
+ # preserve MPE file attributes.
+ return system('/bin/cp', '-f', $_[0], $_[1]) == 0;
+ };
+ } else {
+ *syscopy = \&copy;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::Copy - Copy files or filehandles
+
+=head1 SYNOPSIS
+
+ use File::Copy;
+
+ copy("file1","file2");
+ copy("Copy.pm",\*STDOUT);'
+ move("/dev1/fileA","/dev2/fileB");
+
+ use POSIX;
+ use File::Copy cp;
+
+ $n=FileHandle->new("/dev/null","r");
+ cp($n,"x");'
+
+=head1 DESCRIPTION
+
+The File::Copy module provides two basic functions, C<copy> and
+C<move>, which are useful for getting the contents of a file from
+one place to another.
+
+=over 4
+
+=item *
+
+The C<copy> function takes two
+parameters: a file to copy from and a file to copy to. Either
+argument may be a string, a FileHandle reference or a FileHandle
+glob. Obviously, if the first argument is a filehandle of some
+sort, it will be read from, and if it is a file I<name> it will
+be opened for reading. Likewise, the second argument will be
+written to (and created if need be).
+
+B<Note that passing in
+files as handles instead of names may lead to loss of information
+on some operating systems; it is recommended that you use file
+names whenever possible.> Files are opened in binary mode where
+applicable. To get a consistent behavour when copying from a
+filehandle to a file, use C<binmode> on the filehandle.
+
+An optional third parameter can be used to specify the buffer
+size used for copying. This is the number of bytes from the
+first file, that wil be held in memory at any given time, before
+being written to the second file. The default buffer size depends
+upon the file, but will generally be the whole file (up to 2Mb), or
+1k for filehandles that do not reference files (eg. sockets).
+
+You may use the syntax C<use File::Copy "cp"> to get at the
+"cp" alias for this function. The syntax is I<exactly> the same.
+
+=item *
+
+The C<move> function also takes two parameters: the current name
+and the intended name of the file to be moved. If the destination
+already exists and is a directory, and the source is not a
+directory, then the source file will be renamed into the directory
+specified by the destination.
+
+If possible, move() will simply rename the file. Otherwise, it copies
+the file to the new location and deletes the original. If an error occurs
+during this copy-and-delete process, you may be left with a (possibly partial)
+copy of the file under the destination name.
+
+You may use the "mv" alias for this function in the same way that
+you may use the "cp" alias for C<copy>.
+
+=back
+
+File::Copy also provides the C<syscopy> routine, which copies the
+file specified in the first parameter to the file specified in the
+second parameter, preserving OS-specific attributes and file
+structure. For Unix systems, this is equivalent to the simple
+C<copy> routine. For VMS systems, this calls the C<rmscopy>
+routine (see below). For OS/2 systems, this calls the C<syscopy>
+XSUB directly.
+
+=head2 Special behavior if C<syscopy> is defined (VMS and OS/2)
+
+If both arguments to C<copy> are not file handles,
+then C<copy> will perform a "system copy" of
+the input file to a new output file, in order to preserve file
+attributes, indexed file structure, I<etc.> The buffer size
+parameter is ignored. If either argument to C<copy> is a
+handle to an opened file, then data is copied using Perl
+operators, and no effort is made to preserve file attributes
+or record structure.
+
+The system copy routine may also be called directly under VMS and OS/2
+as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
+is the routine that does the actual work for syscopy).
+
+=over 4
+
+=item rmscopy($from,$to[,$date_flag])
+
+The first and second arguments may be strings, typeglobs, typeglob
+references, or objects inheriting from IO::Handle;
+they are used in all cases to obtain the
+I<filespec> of the input and output files, respectively. The
+name and type of the input file are used as defaults for the
+output file, if necessary.
+
+A new version of the output file is always created, which
+inherits the structure and RMS attributes of the input file,
+except for owner and protections (and possibly timestamps;
+see below). All data from the input file is copied to the
+output file; if either of the first two parameters to C<rmscopy>
+is a file handle, its position is unchanged. (Note that this
+means a file handle pointing to the output file will be
+associated with an old version of that file after C<rmscopy>
+returns, not the newly created version.)
+
+The third parameter is an integer flag, which tells C<rmscopy>
+how to handle timestamps. If it is E<lt> 0, none of the input file's
+timestamps are propagated to the output file. If it is E<gt> 0, then
+it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
+timestamps other than the revision date are propagated; if bit 1
+is set, the revision date is propagated. If the third parameter
+to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
+if the name or type of the output file was explicitly specified,
+then no timestamps are propagated, but if they were taken implicitly
+from the input filespec, then all timestamps other than the
+revision date are propagated. If this parameter is not supplied,
+it defaults to 0.
+
+Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs,
+it sets C<$!>, deletes the output file, and returns 0.
+
+=back
+
+=head1 RETURN
+
+All functions return 1 on success, 0 on failure.
+$! will be set if an error was encountered.
+
+=head1 AUTHOR
+
+File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
+and updated by Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> in 1996.
+
+=cut
+
diff --git a/contrib/perl5/lib/File/DosGlob.pm b/contrib/perl5/lib/File/DosGlob.pm
new file mode 100644
index 000000000000..594ee2ec8432
--- /dev/null
+++ b/contrib/perl5/lib/File/DosGlob.pm
@@ -0,0 +1,249 @@
+#!perl -w
+
+#
+# Documentation at the __END__
+#
+
+package File::DosGlob;
+
+sub doglob {
+ my $cond = shift;
+ my @retval = ();
+ #print "doglob: ", join('|', @_), "\n";
+ OUTER:
+ for my $arg (@_) {
+ local $_ = $arg;
+ my @matched = ();
+ my @globdirs = ();
+ my $head = '.';
+ my $sepchr = '/';
+ next OUTER unless defined $_ and $_ ne '';
+ # if arg is within quotes strip em and do no globbing
+ if (/^"(.*)"$/) {
+ $_ = $1;
+ if ($cond eq 'd') { push(@retval, $_) if -d $_ }
+ else { push(@retval, $_) if -e $_ }
+ next OUTER;
+ }
+ if (m|^(.*)([\\/])([^\\/]*)$|) {
+ my $tail;
+ ($head, $sepchr, $tail) = ($1,$2,$3);
+ #print "div: |$head|$sepchr|$tail|\n";
+ push (@retval, $_), next OUTER if $tail eq '';
+ if ($head =~ /[*?]/) {
+ @globdirs = doglob('d', $head);
+ push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
+ next OUTER if @globdirs;
+ }
+ $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/;
+ $_ = $tail;
+ }
+ #
+ # If file component has no wildcards, we can avoid opendir
+ unless (/[*?]/) {
+ $head = '' if $head eq '.';
+ $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
+ $head .= $_;
+ if ($cond eq 'd') { push(@retval,$head) if -d $head }
+ else { push(@retval,$head) if -e $head }
+ next OUTER;
+ }
+ opendir(D, $head) or next OUTER;
+ my @leaves = readdir D;
+ closedir D;
+ $head = '' if $head eq '.';
+ $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
+
+ # escape regex metachars but not glob chars
+ s:([].+^\-\${}[|]):\\$1:g;
+ # and convert DOS-style wildcards to regex
+ s/\*/.*/g;
+ s/\?/.?/g;
+
+ #print "regex: '$_', head: '$head'\n";
+ my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }';
+ warn($@), next OUTER if $@;
+ INNER:
+ for my $e (@leaves) {
+ next INNER if $e eq '.' or $e eq '..';
+ next INNER if $cond eq 'd' and ! -d "$head$e";
+ push(@matched, "$head$e"), next INNER if &$matchsub($e);
+ #
+ # [DOS compatibility special case]
+ # Failed, add a trailing dot and try again, but only
+ # if name does not have a dot in it *and* pattern
+ # has a dot *and* name is shorter than 9 chars.
+ #
+ if (index($e,'.') == -1 and length($e) < 9
+ and index($_,'\\.') != -1) {
+ push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
+ }
+ }
+ push @retval, @matched if @matched;
+ }
+ return @retval;
+}
+
+#
+# this can be used to override CORE::glob in a specific
+# package by saying C<use File::DosGlob 'glob';> in that
+# namespace.
+#
+
+# context (keyed by second cxix arg provided by core)
+my %iter;
+my %entries;
+
+sub glob {
+ my $pat = shift;
+ my $cxix = shift;
+ my @pat;
+
+ # glob without args defaults to $_
+ $pat = $_ unless defined $pat;
+
+ # extract patterns
+ if ($pat =~ /\s/) {
+ require Text::ParseWords;
+ @pat = Text::ParseWords::parse_line('\s+',0,$pat);
+ }
+ else {
+ push @pat, $pat;
+ }
+
+ # assume global context if not provided one
+ $cxix = '_G_' unless defined $cxix;
+ $iter{$cxix} = 0 unless exists $iter{$cxix};
+
+ # if we're just beginning, do it all first
+ if ($iter{$cxix} == 0) {
+ $entries{$cxix} = [doglob(1,@pat)];
+ }
+
+ # chuck it all out, quick or slow
+ if (wantarray) {
+ delete $iter{$cxix};
+ return @{delete $entries{$cxix}};
+ }
+ else {
+ if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
+ return shift @{$entries{$cxix}};
+ }
+ else {
+ # return undef for EOL
+ delete $iter{$cxix};
+ delete $entries{$cxix};
+ return undef;
+ }
+ }
+}
+
+sub import {
+ my $pkg = shift;
+ return unless @_;
+ my $sym = shift;
+ my $callpkg = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0));
+ *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::DosGlob - DOS like globbing and then some
+
+=head1 SYNOPSIS
+
+ require 5.004;
+
+ # override CORE::glob in current package
+ use File::DosGlob 'glob';
+
+ # override CORE::glob in ALL packages (use with extreme caution!)
+ use File::DosGlob 'GLOBAL_glob';
+
+ @perlfiles = glob "..\\pe?l/*.p?";
+ print <..\\pe?l/*.p?>;
+
+ # from the command line (overrides only in main::)
+ > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
+
+=head1 DESCRIPTION
+
+A module that implements DOS-like globbing with a few enhancements.
+It is largely compatible with perlglob.exe (the M$ setargv.obj
+version) in all but one respect--it understands wildcards in
+directory components.
+
+For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
+that it will find something like '..\lib\File/DosGlob.pm' alright).
+Note that all path components are case-insensitive, and that
+backslashes and forward slashes are both accepted, and preserved.
+You may have to double the backslashes if you are putting them in
+literally, due to double-quotish parsing of the pattern by perl.
+
+Spaces in the argument delimit distinct patterns, so
+C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
+or C<.dll>. If you want to put in literal spaces in the glob
+pattern, you can escape them with either double quotes, or backslashes.
+e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
+C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using
+C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
+of the quoting rules used.
+
+Extending it to csh patterns is left as an exercise to the reader.
+
+=head1 EXPORTS (by request only)
+
+glob()
+
+=head1 BUGS
+
+Should probably be built into the core, and needs to stop
+pandering to DOS habits. Needs a dose of optimizium too.
+
+=head1 AUTHOR
+
+Gurusamy Sarathy <gsar@umich.edu>
+
+=head1 HISTORY
+
+=over 4
+
+=item *
+
+Support for globally overriding glob() (GSAR 3-JUN-98)
+
+=item *
+
+Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
+
+=item *
+
+A few dir-vs-file optimizations result in glob importation being
+10 times faster than using perlglob.exe, and using perlglob.bat is
+only twice as slow as perlglob.exe (GSAR 28-MAY-97)
+
+=item *
+
+Several cleanups prompted by lack of compatible perlglob.exe
+under Borland (GSAR 27-MAY-97)
+
+=item *
+
+Initial version (GSAR 20-FEB-97)
+
+=back
+
+=head1 SEE ALSO
+
+perl
+
+perlglob.bat
+
+Text::ParseWords
+
+=cut
+
diff --git a/contrib/perl5/lib/File/Find.pm b/contrib/perl5/lib/File/Find.pm
new file mode 100644
index 000000000000..1305d21e6b27
--- /dev/null
+++ b/contrib/perl5/lib/File/Find.pm
@@ -0,0 +1,230 @@
+package File::Find;
+require 5.000;
+require Exporter;
+require Cwd;
+
+=head1 NAME
+
+find - traverse a file tree
+
+finddepth - traverse a directory structure depth-first
+
+=head1 SYNOPSIS
+
+ use File::Find;
+ find(\&wanted, '/foo','/bar');
+ sub wanted { ... }
+
+ use File::Find;
+ finddepth(\&wanted, '/foo','/bar');
+ sub wanted { ... }
+
+=head1 DESCRIPTION
+
+The first argument to find() is either a hash reference describing the
+operations to be performed for each file, or a code reference. If it
+is a hash reference, then the value for the key C<wanted> should be a
+code reference. This code reference is called I<the wanted()
+function> below.
+
+Currently the only other supported key for the above hash is
+C<bydepth>, in presense of which the walk over directories is
+performed depth-first. Entry point finddepth() is a shortcut for
+specifying C<{ bydepth => 1}> in the first argument of find().
+
+The wanted() function does whatever verifications you want.
+$File::Find::dir contains the current directory name, and $_ the
+current filename within that directory. $File::Find::name contains
+C<"$File::Find::dir/$_">. You are chdir()'d to $File::Find::dir when
+the function is called. The function may set $File::Find::prune to
+prune the tree.
+
+File::Find assumes that you don't alter the $_ variable. If you do then
+make sure you return it to its original value before exiting your function.
+
+This library is useful for the C<find2perl> tool, which when fed,
+
+ find2perl / -name .nfs\* -mtime +7 \
+ -exec rm -f {} \; -o -fstype nfs -prune
+
+produces something like:
+
+ sub wanted {
+ /^\.nfs.*$/ &&
+ (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+ int(-M _) > 7 &&
+ unlink($_)
+ ||
+ ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+ $dev < 0 &&
+ ($File::Find::prune = 1);
+ }
+
+Set the variable $File::Find::dont_use_nlink if you're using AFS,
+since AFS cheats.
+
+C<finddepth> is just like C<find>, except that it does a depth-first
+search.
+
+Here's another interesting wanted function. It will find all symlinks
+that don't resolve:
+
+ sub wanted {
+ -l && !-e && print "bogus link: $File::Find::name\n";
+ }
+
+=head1 BUGS
+
+There is no way to make find or finddepth follow symlinks.
+
+=cut
+
+@ISA = qw(Exporter);
+@EXPORT = qw(find finddepth);
+
+
+sub find_opt {
+ my $wanted = shift;
+ my $bydepth = $wanted->{bydepth};
+ my $cwd = $bydepth ? Cwd::fastcwd() : Cwd::cwd();
+ # Localize these rather than lexicalizing them for backwards
+ # compatibility.
+ local($topdir,$topdev,$topino,$topmode,$topnlink);
+ foreach $topdir (@_) {
+ (($topdev,$topino,$topmode,$topnlink) =
+ ($Is_VMS ? stat($topdir) : lstat($topdir)))
+ || (warn("Can't stat $topdir: $!\n"), next);
+ if (-d _) {
+ if (chdir($topdir)) {
+ $prune = 0;
+ unless ($bydepth) {
+ ($dir,$_) = ($topdir,'.');
+ $name = $topdir;
+ $wanted->{wanted}->();
+ }
+ next if $prune;
+ my $fixtopdir = $topdir;
+ $fixtopdir =~ s,/$,, ;
+ $fixtopdir =~ s/\.dir$// if $Is_VMS;
+ &finddir($wanted,$fixtopdir,$topnlink, $bydepth);
+ if ($bydepth) {
+ ($dir,$_) = ($fixtopdir,'.');
+ $name = $fixtopdir;
+ $wanted->{wanted}->();
+ }
+ }
+ else {
+ warn "Can't cd to $topdir: $!\n";
+ }
+ }
+ else {
+ require File::Basename;
+ unless (($_,$dir) = File::Basename::fileparse($topdir)) {
+ ($dir,$_) = ('.', $topdir);
+ }
+ if (chdir($dir)) {
+ $name = $topdir;
+ $wanted->{wanted}->();
+ }
+ else {
+ warn "Can't cd to $dir: $!\n";
+ }
+ }
+ chdir $cwd;
+ }
+}
+
+sub finddir {
+ my($wanted, $nlink, $bydepth);
+ local($dir, $name);
+ ($wanted, $dir, $nlink, $bydepth) = @_;
+
+ my($dev, $ino, $mode, $subcount);
+
+ # Get the list of files in the current directory.
+ opendir(DIR,'.') || (warn("Can't open $dir: $!\n"), $bydepth || return);
+ my(@filenames) = readdir(DIR);
+ closedir(DIR);
+
+ if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories.
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $name = "$dir/$_";
+ $nlink = 0;
+ $wanted->{wanted}->();
+ }
+ }
+ else { # This dir has subdirectories.
+ $subcount = $nlink - 2;
+ for (@filenames) {
+ next if $_ eq '.';
+ next if $_ eq '..';
+ $nlink = 0;
+ $prune = 0 unless $bydepth;
+ $name = "$dir/$_";
+ $wanted->{wanted}->() unless $bydepth;
+ if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs?
+
+ # Get link count and check for directoriness.
+
+ ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_));
+ # unless ($nlink || $dont_use_nlink);
+
+ if (-d _) {
+
+ # It really is a directory, so do it recursively.
+
+ --$subcount;
+ next if $prune;
+ if (chdir $_) {
+ $name =~ s/\.dir$// if $Is_VMS;
+ &finddir($wanted,$name,$nlink, $bydepth);
+ chdir '..';
+ }
+ else {
+ warn "Can't cd to $_: $!\n";
+ }
+ }
+ }
+ $wanted->{wanted}->() if $bydepth;
+ }
+ }
+}
+
+sub wrap_wanted {
+ my $wanted = shift;
+ defined &$wanted ? {wanted => $wanted} : $wanted;
+}
+
+sub find {
+ my $wanted = shift;
+ find_opt(wrap_wanted($wanted), @_);
+}
+
+sub finddepth {
+ my $wanted = wrap_wanted(shift);
+ $wanted->{bydepth} = 1;
+ find_opt($wanted, @_);
+}
+
+# These are hard-coded for now, but may move to hint files.
+if ($^O eq 'VMS') {
+ $Is_VMS = 1;
+ $dont_use_nlink = 1;
+}
+
+$dont_use_nlink = 1
+ if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32';
+
+# Set dont_use_nlink in your hint file if your system's stat doesn't
+# report the number of links in a directory as an indication
+# of the number of files.
+# See, e.g. hints/machten.sh for MachTen 2.2.
+unless ($dont_use_nlink) {
+ require Config;
+ $dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'});
+}
+
+1;
+
diff --git a/contrib/perl5/lib/File/Path.pm b/contrib/perl5/lib/File/Path.pm
new file mode 100644
index 000000000000..39f1ba17713e
--- /dev/null
+++ b/contrib/perl5/lib/File/Path.pm
@@ -0,0 +1,228 @@
+package File::Path;
+
+=head1 NAME
+
+File::Path - create or remove a series of directories
+
+=head1 SYNOPSIS
+
+C<use File::Path>
+
+C<mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);>
+
+C<rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);>
+
+=head1 DESCRIPTION
+
+The C<mkpath> function provides a convenient way to create directories, even
+if your C<mkdir> kernel call won't create more than one level of directory at
+a time. C<mkpath> takes three arguments:
+
+=over 4
+
+=item *
+
+the name of the path to create, or a reference
+to a list of paths to create,
+
+=item *
+
+a boolean value, which if TRUE will cause C<mkpath>
+to print the name of each directory as it is created
+(defaults to FALSE), and
+
+=item *
+
+the numeric mode to use when creating the directories
+(defaults to 0777)
+
+=back
+
+It returns a list of all directories (including intermediates, determined
+using the Unix '/' separator) created.
+
+Similarly, the C<rmtree> function provides a convenient way to delete a
+subtree from the directory structure, much like the Unix command C<rm -r>.
+C<rmtree> takes three arguments:
+
+=over 4
+
+=item *
+
+the root of the subtree to delete, or a reference to
+a list of roots. All of the files and directories
+below each root, as well as the roots themselves,
+will be deleted.
+
+=item *
+
+a boolean value, which if TRUE will cause C<rmtree> to
+print a message each time it examines a file, giving the
+name of the file, and indicating whether it's using C<rmdir>
+or C<unlink> to remove it, or that it's skipping it.
+(defaults to FALSE)
+
+=item *
+
+a boolean value, which if TRUE will cause C<rmtree> to
+skip any files to which you do not have delete access
+(if running under VMS) or write access (if running
+under another OS). This will change in the future when
+a criterion for 'delete permission' under OSs other
+than VMS is settled. (defaults to FALSE)
+
+=back
+
+It returns the number of files successfully deleted. Symlinks are
+treated as ordinary files.
+
+B<NOTE:> If the third parameter is not TRUE, C<rmtree> is B<unsecure>
+in the face of failure or interruption. Files and directories which
+were not deleted may be left with permissions reset to allow world
+read and write access. Note also that the occurrence of errors in
+rmtree can be determined I<only> by trapping diagnostic messages
+using C<$SIG{__WARN__}>; it is not apparent from the return value.
+Therefore, you must be extremely careful about using C<rmtree($foo,$bar,0>
+in situations where security is an issue.
+
+=head1 AUTHORS
+
+Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
+Charles Bailey <F<bailey@genetics.upenn.edu>>
+
+=head1 REVISION
+
+Current $VERSION is 1.0401.
+
+=cut
+
+use Carp;
+use File::Basename ();
+use DirHandle ();
+use Exporter ();
+use strict;
+
+use vars qw( $VERSION @ISA @EXPORT );
+$VERSION = "1.0401";
+@ISA = qw( Exporter );
+@EXPORT = qw( mkpath rmtree );
+
+my $Is_VMS = $^O eq 'VMS';
+
+# These OSes complain if you want to remove a file that you have no
+# write permission to:
+my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32'
+ || $^O eq 'amigaos');
+
+sub mkpath {
+ my($paths, $verbose, $mode) = @_;
+ # $paths -- either a path string or ref to list of paths
+ # $verbose -- optional print "mkdir $path" for each directory created
+ # $mode -- optional permissions, defaults to 0777
+ local($")="/";
+ $mode = 0777 unless defined($mode);
+ $paths = [$paths] unless ref $paths;
+ my(@created,$path);
+ foreach $path (@$paths) {
+ $path .= '/' if $^O eq 'os2' and $path =~ /^\w:$/; # feature of CRT
+ next if -d $path;
+ # Logic wants Unix paths, so go with the flow.
+ $path = VMS::Filespec::unixify($path) if $Is_VMS;
+ my $parent = File::Basename::dirname($path);
+ # Allow for creation of new logical filesystems under VMS
+ if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) {
+ push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent);
+ }
+ print "mkdir $path\n" if $verbose;
+ unless (mkdir($path,$mode)) {
+ # allow for another process to have created it meanwhile
+ croak "mkdir $path: $!" unless -d $path;
+ }
+ push(@created, $path);
+ }
+ @created;
+}
+
+sub rmtree {
+ my($roots, $verbose, $safe) = @_;
+ my(@files);
+ my($count) = 0;
+ $roots = [$roots] unless ref $roots;
+ $verbose ||= 0;
+ $safe ||= 0;
+
+ my($root);
+ foreach $root (@{$roots}) {
+ $root =~ s#/$##;
+ (undef, undef, my $rp) = lstat $root or next;
+ $rp &= 07777; # don't forget setuid, setgid, sticky bits
+ if ( -d _ ) {
+ # notabene: 0777 is for making readable in the first place,
+ # it's also intended to change it to writable in case we have
+ # to recurse in which case we are better than rm -rf for
+ # subtrees with strange permissions
+ chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+ or carp "Can't make directory $root read+writeable: $!"
+ unless $safe;
+
+ my $d = DirHandle->new($root)
+ or carp "Can't read $root: $!";
+ @files = $d->read;
+ $d->close;
+
+ # Deleting large numbers of files from VMS Files-11 filesystems
+ # is faster if done in reverse ASCIIbetical order
+ @files = reverse @files if $Is_VMS;
+ ($root = VMS::Filespec::unixify($root)) =~ s#\.dir$## if $Is_VMS;
+ @files = map("$root/$_", grep $_!~/^\.{1,2}$/,@files);
+ $count += rmtree(\@files,$verbose,$safe);
+ if ($safe &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+ print "skipped $root\n" if $verbose;
+ next;
+ }
+ chmod 0777, $root
+ or carp "Can't make directory $root writeable: $!"
+ if $force_writeable;
+ print "rmdir $root\n" if $verbose;
+ if (rmdir $root) {
+ ++$count;
+ }
+ else {
+ carp "Can't remove directory $root: $!";
+ chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+ or carp("and can't restore permissions to "
+ . sprintf("0%o",$rp) . "\n");
+ }
+ }
+ else {
+ if ($safe &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+ print "skipped $root\n" if $verbose;
+ next;
+ }
+ chmod 0666, $root
+ or carp "Can't make file $root writeable: $!"
+ if $force_writeable;
+ print "unlink $root\n" if $verbose;
+ # delete all versions under VMS
+ for (;;) {
+ unless (unlink $root) {
+ carp "Can't unlink file $root: $!";
+ if ($force_writeable) {
+ chmod $rp, $root
+ or carp("and can't restore permissions to "
+ . sprintf("0%o",$rp) . "\n");
+ }
+ last;
+ }
+ ++$count;
+ last unless $Is_VMS && lstat $root;
+ }
+ }
+ }
+
+ $count;
+}
+
+1;
diff --git a/contrib/perl5/lib/File/Spec.pm b/contrib/perl5/lib/File/Spec.pm
new file mode 100644
index 000000000000..5f3dbf5fce76
--- /dev/null
+++ b/contrib/perl5/lib/File/Spec.pm
@@ -0,0 +1,116 @@
+package File::Spec;
+
+require Exporter;
+
+@ISA = qw(Exporter);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+@EXPORT = qw(
+
+);
+@EXPORT_OK = qw($Verbose);
+
+use strict;
+use vars qw(@ISA $VERSION $Verbose);
+
+$VERSION = '0.6';
+
+$Verbose = 0;
+
+require File::Spec::Unix;
+
+
+sub load {
+ my($class,$OS) = @_;
+ if ($OS eq 'VMS') {
+ require File::Spec::VMS;
+ require VMS::Filespec;
+ 'File::Spec::VMS'
+ } elsif ($OS eq 'os2') {
+ require File::Spec::OS2;
+ 'File::Spec::OS2'
+ } elsif ($OS eq 'MacOS') {
+ require File::Spec::Mac;
+ 'File::Spec::Mac'
+ } elsif ($OS eq 'MSWin32') {
+ require File::Spec::Win32;
+ 'File::Spec::Win32'
+ } else {
+ 'File::Spec::Unix'
+ }
+}
+
+@ISA = load('File::Spec', $^O);
+
+1;
+__END__
+
+=head1 NAME
+
+File::Spec - portably perform operations on file names
+
+=head1 SYNOPSIS
+
+C<use File::Spec;>
+
+C<$x=File::Spec-E<gt>catfile('a','b','c');>
+
+which returns 'a/b/c' under Unix.
+
+=head1 DESCRIPTION
+
+This module is designed to support operations commonly performed on file
+specifications (usually called "file names", but not to be confused with the
+contents of a file, or Perl's file handles), such as concatenating several
+directory and file names into a single path, or determining whether a path
+is rooted. It is based on code directly taken from MakeMaker 5.17, code
+written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya
+Zakharevich, Paul Schinder, and others.
+
+Since these functions are different for most operating systems, each set of
+OS specific routines is available in a separate module, including:
+
+ File::Spec::Unix
+ File::Spec::Mac
+ File::Spec::OS2
+ File::Spec::Win32
+ File::Spec::VMS
+
+The module appropriate for the current OS is automatically loaded by
+File::Spec. Since some modules (like VMS) make use of OS specific
+facilities, it may not be possible to load all modules under all operating
+systems.
+
+Since File::Spec is object oriented, subroutines should not called directly,
+as in:
+
+ File::Spec::catfile('a','b');
+
+but rather as class methods:
+
+ File::Spec->catfile('a','b');
+
+For a reference of available functions, pleaes consult L<File::Spec::Unix>,
+which contains the entire set, and inherited by the modules for other
+platforms. For further information, please see L<File::Spec::Mac>,
+L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>.
+
+=head1 SEE ALSO
+
+File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, File::Spec::Win32,
+File::Spec::VMS, ExtUtils::MakeMaker
+
+=head1 AUTHORS
+
+Kenneth Albanowski <F<kjahds@kjahds.com>>, Andy Dougherty
+<F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig
+<F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. VMS
+support by Charles Bailey <F<bailey@genetics.upenn.edu>>. OS/2 support by
+Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Mac support by Paul Schinder
+<F<schinder@pobox.com>>.
+
+=cut
+
+
+1;
diff --git a/contrib/perl5/lib/File/Spec/Mac.pm b/contrib/perl5/lib/File/Spec/Mac.pm
new file mode 100644
index 000000000000..4968e24abca0
--- /dev/null
+++ b/contrib/perl5/lib/File/Spec/Mac.pm
@@ -0,0 +1,230 @@
+package File::Spec::Mac;
+
+use Exporter ();
+use Config;
+use strict;
+use File::Spec;
+use vars qw(@ISA $VERSION $Is_Mac);
+
+$VERSION = '1.0';
+
+@ISA = qw(File::Spec::Unix);
+$Is_Mac = $^O eq 'MacOS';
+
+Exporter::import('File::Spec', '$Verbose');
+
+
+=head1 NAME
+
+File::Spec::Mac - File::Spec for MacOS
+
+=head1 SYNOPSIS
+
+C<require File::Spec::Mac;>
+
+=head1 DESCRIPTION
+
+Methods for manipulating file specifications.
+
+=head1 METHODS
+
+=over 2
+
+=item canonpath
+
+On MacOS, there's nothing to be done. Returns what it's given.
+
+=cut
+
+sub canonpath {
+ my($self,$path) = @_;
+ $path;
+}
+
+=item catdir
+
+Concatenate two or more directory names to form a complete path ending with
+a directory. Put a trailing : on the end of the complete path if there
+isn't one, because that's what's done in MacPerl's environment.
+
+The fundamental requirement of this routine is that
+
+ File::Spec->catdir(split(":",$path)) eq $path
+
+But because of the nature of Macintosh paths, some additional
+possibilities are allowed to make using this routine give resonable results
+for some common situations. Here are the rules that are used. Each
+argument has its trailing ":" removed. Each argument, except the first,
+has its leading ":" removed. They are then joined together by a ":".
+
+So
+
+ File::Spec->catdir("a","b") = "a:b:"
+ File::Spec->catdir("a:",":b") = "a:b:"
+ File::Spec->catdir("a:","b") = "a:b:"
+ File::Spec->catdir("a",":b") = "a:b"
+ File::Spec->catdir("a","","b") = "a::b"
+
+etc.
+
+To get a relative path (one beginning with :), begin the first argument with :
+or put a "" as the first argument.
+
+If you don't want to worry about these rules, never allow a ":" on the ends
+of any of the arguments except at the beginning of the first.
+
+Under MacPerl, there is an additional ambiguity. Does the user intend that
+
+ File::Spec->catfile("LWP","Protocol","http.pm")
+
+be relative or absolute? There's no way of telling except by checking for the
+existance of LWP: or :LWP, and even there he may mean a dismounted volume or
+a relative path in a different directory (like in @INC). So those checks
+aren't done here. This routine will treat this as absolute.
+
+=cut
+
+# ';
+
+sub catdir {
+ shift;
+ my @args = @_;
+ $args[0] =~ s/:$//;
+ my $result = shift @args;
+ for (@args) {
+ s/:$//;
+ s/^://;
+ $result .= ":$_";
+ }
+ $result .= ":";
+ $result;
+}
+
+=item catfile
+
+Concatenate one or more directory names and a filename to form a
+complete path ending with a filename. Since this uses catdir, the
+same caveats apply. Note that the leading : is removed from the filename,
+so that
+
+ File::Spec->catfile($ENV{HOME},"file");
+
+and
+
+ File::Spec->catfile($ENV{HOME},":file");
+
+give the same answer, as one might expect.
+
+=cut
+
+sub catfile {
+ my $self = shift @_;
+ my $file = pop @_;
+ return $file unless @_;
+ my $dir = $self->catdir(@_);
+ $file =~ s/^://;
+ return $dir.$file;
+}
+
+=item curdir
+
+Returns a string representing of the current directory.
+
+=cut
+
+sub curdir {
+ return ":" ;
+}
+
+=item rootdir
+
+Returns a string representing the root directory. Under MacPerl,
+returns the name of the startup volume, since that's the closest in
+concept, although other volumes aren't rooted there. On any other
+platform returns '', since there's no common way to indicate "root
+directory" across all Macs.
+
+=cut
+
+sub rootdir {
+#
+# There's no real root directory on MacOS. If you're using MacPerl,
+# the name of the startup volume is returned, since that's the closest in
+# concept. On other platforms, simply return '', because nothing better
+# can be done.
+#
+ if($Is_Mac) {
+ require Mac::Files;
+ my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk,
+ &Mac::Files::kSystemFolderType);
+ $system =~ s/:.*$/:/;
+ return $system;
+ } else {
+ return '';
+ }
+}
+
+=item updir
+
+Returns a string representing the parent directory.
+
+=cut
+
+sub updir {
+ return "::";
+}
+
+=item file_name_is_absolute
+
+Takes as argument a path and returns true, if it is an absolute path. In
+the case where a name can be either relative or absolute (for example, a
+folder named "HD" in the current working directory on a drive named "HD"),
+relative wins. Use ":" in the appropriate place in the path if you want to
+distinguish unambiguously.
+
+=cut
+
+sub file_name_is_absolute {
+ my($self,$file) = @_;
+ if ($file =~ /:/) {
+ return ($file !~ m/^:/);
+ } else {
+ return (! -e ":$file");
+ }
+}
+
+=item path
+
+Returns the null list for the MacPerl application, since the concept is
+usually meaningless under MacOS. But if you're using the MacPerl tool under
+MPW, it gives back $ENV{Commands} suitably split, as is done in
+:lib:ExtUtils:MM_Mac.pm.
+
+=cut
+
+sub path {
+#
+# The concept is meaningless under the MacPerl application.
+# Under MPW, it has a meaning.
+#
+ my($self) = @_;
+ my @path;
+ if(exists $ENV{Commands}) {
+ @path = split /,/,$ENV{Commands};
+ } else {
+ @path = ();
+ }
+ @path;
+}
+
+=back
+
+=head1 SEE ALSO
+
+L<File::Spec>
+
+=cut
+
+1;
+__END__
+
diff --git a/contrib/perl5/lib/File/Spec/OS2.pm b/contrib/perl5/lib/File/Spec/OS2.pm
new file mode 100644
index 000000000000..d60261770281
--- /dev/null
+++ b/contrib/perl5/lib/File/Spec/OS2.pm
@@ -0,0 +1,51 @@
+package File::Spec::OS2;
+
+#use Config;
+#use Cwd;
+#use File::Basename;
+use strict;
+require Exporter;
+
+use File::Spec;
+use vars qw(@ISA);
+
+Exporter::import('File::Spec',
+ qw( $Verbose));
+
+@ISA = qw(File::Spec::Unix);
+
+$ENV{EMXSHELL} = 'sh'; # to run `commands`
+
+sub file_name_is_absolute {
+ my($self,$file) = @_;
+ $file =~ m{^([a-z]:)?[\\/]}i ;
+}
+
+sub path {
+ my($self) = @_;
+ my $path_sep = ";";
+ my $path = $ENV{PATH};
+ $path =~ s:\\:/:g;
+ my @path = split $path_sep, $path;
+ foreach(@path) { $_ = '.' if $_ eq '' }
+ @path;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+File::Spec::OS2 - methods for OS/2 file specs
+
+=head1 SYNOPSIS
+
+ use File::Spec::OS2; # Done internally by File::Spec if needed
+
+=head1 DESCRIPTION
+
+See File::Spec::Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=cut
diff --git a/contrib/perl5/lib/File/Spec/Unix.pm b/contrib/perl5/lib/File/Spec/Unix.pm
new file mode 100644
index 000000000000..77de73a216a3
--- /dev/null
+++ b/contrib/perl5/lib/File/Spec/Unix.pm
@@ -0,0 +1,197 @@
+package File::Spec::Unix;
+
+use Exporter ();
+use Config;
+use File::Basename qw(basename dirname fileparse);
+use DirHandle;
+use strict;
+use vars qw(@ISA $Is_Mac $Is_OS2 $Is_VMS $Is_Win32);
+use File::Spec;
+
+Exporter::import('File::Spec', '$Verbose');
+
+$Is_OS2 = $^O eq 'os2';
+$Is_Mac = $^O eq 'MacOS';
+$Is_Win32 = $^O eq 'MSWin32';
+
+if ($Is_VMS = $^O eq 'VMS') {
+ require VMS::Filespec;
+ import VMS::Filespec qw( &vmsify );
+}
+
+=head1 NAME
+
+File::Spec::Unix - methods used by File::Spec
+
+=head1 SYNOPSIS
+
+C<require File::Spec::Unix;>
+
+=head1 DESCRIPTION
+
+Methods for manipulating file specifications.
+
+=head1 METHODS
+
+=over 2
+
+=item canonpath
+
+No physical check on the filesystem, but a logical cleanup of a
+path. On UNIX eliminated successive slashes and successive "/.".
+
+=cut
+
+sub canonpath {
+ my($self,$path) = @_;
+ $path =~ s|/+|/|g ; # xx////xx -> xx/xx
+ $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx
+ $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx
+ $path =~ s|/$|| unless $path eq "/"; # xx/ -> xx
+ $path;
+}
+
+=item catdir
+
+Concatenate two or more directory names to form a complete path ending
+with a directory. But remove the trailing slash from the resulting
+string, because it doesn't look good, isn't necessary and confuses
+OS2. Of course, if this is the root directory, don't cut off the
+trailing slash :-)
+
+=cut
+
+# ';
+
+sub catdir {
+ shift;
+ my @args = @_;
+ for (@args) {
+ # append a slash to each argument unless it has one there
+ $_ .= "/" if $_ eq '' or substr($_,-1) ne "/";
+ }
+ my $result = join('', @args);
+ # remove a trailing slash unless we are root
+ substr($result,-1) = ""
+ if length($result) > 1 && substr($result,-1) eq "/";
+ $result;
+}
+
+=item catfile
+
+Concatenate one or more directory names and a filename to form a
+complete path ending with a filename
+
+=cut
+
+sub catfile {
+ my $self = shift @_;
+ my $file = pop @_;
+ return $file unless @_;
+ my $dir = $self->catdir(@_);
+ for ($dir) {
+ $_ .= "/" unless substr($_,length($_)-1,1) eq "/";
+ }
+ return $dir.$file;
+}
+
+=item curdir
+
+Returns a string representing of the current directory. "." on UNIX.
+
+=cut
+
+sub curdir {
+ return "." ;
+}
+
+=item rootdir
+
+Returns a string representing of the root directory. "/" on UNIX.
+
+=cut
+
+sub rootdir {
+ return "/";
+}
+
+=item updir
+
+Returns a string representing of the parent directory. ".." on UNIX.
+
+=cut
+
+sub updir {
+ return "..";
+}
+
+=item no_upwards
+
+Given a list of file names, strip out those that refer to a parent
+directory. (Does not strip symlinks, only '.', '..', and equivalents.)
+
+=cut
+
+sub no_upwards {
+ my($self) = shift;
+ return grep(!/^\.{1,2}$/, @_);
+}
+
+=item file_name_is_absolute
+
+Takes as argument a path and returns true, if it is an absolute path.
+
+=cut
+
+sub file_name_is_absolute {
+ my($self,$file) = @_;
+ $file =~ m:^/: ;
+}
+
+=item path
+
+Takes no argument, returns the environment variable PATH as an array.
+
+=cut
+
+sub path {
+ my($self) = @_;
+ my $path_sep = ":";
+ my $path = $ENV{PATH};
+ my @path = split $path_sep, $path;
+ foreach(@path) { $_ = '.' if $_ eq '' }
+ @path;
+}
+
+=item join
+
+join is the same as catfile.
+
+=cut
+
+sub join {
+ my($self) = shift @_;
+ $self->catfile(@_);
+}
+
+=item nativename
+
+TBW.
+
+=cut
+
+sub nativename {
+ my($self,$name) = shift @_;
+ $name;
+}
+
+=back
+
+=head1 SEE ALSO
+
+L<File::Spec>
+
+=cut
+
+1;
+__END__
diff --git a/contrib/perl5/lib/File/Spec/VMS.pm b/contrib/perl5/lib/File/Spec/VMS.pm
new file mode 100644
index 000000000000..c5269fd10c7a
--- /dev/null
+++ b/contrib/perl5/lib/File/Spec/VMS.pm
@@ -0,0 +1,148 @@
+
+package File::Spec::VMS;
+
+use Carp qw( &carp );
+use Config;
+require Exporter;
+use VMS::Filespec;
+use File::Basename;
+
+use File::Spec;
+use vars qw($Revision);
+$Revision = '5.3901 (6-Mar-1997)';
+
+@ISA = qw(File::Spec::Unix);
+
+Exporter::import('File::Spec', '$Verbose');
+
+=head1 NAME
+
+File::Spec::VMS - methods for VMS file specs
+
+=head1 SYNOPSIS
+
+ use File::Spec::VMS; # Done internally by File::Spec if needed
+
+=head1 DESCRIPTION
+
+See File::Spec::Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=head2 Methods always loaded
+
+=over
+
+=item catdir
+
+Concatenates a list of file specifications, and returns the result as a
+VMS-syntax directory specification.
+
+=cut
+
+sub catdir {
+ my($self,@dirs) = @_;
+ my($dir) = pop @dirs;
+ @dirs = grep($_,@dirs);
+ my($rslt);
+ if (@dirs) {
+ my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs));
+ my($spath,$sdir) = ($path,$dir);
+ $spath =~ s/.dir$//; $sdir =~ s/.dir$//;
+ $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
+ $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
+ }
+ else {
+ if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
+ else { $rslt = vmspath($dir); }
+ }
+ print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
+ $rslt;
+}
+
+=item catfile
+
+Concatenates a list of file specifications, and returns the result as a
+VMS-syntax directory specification.
+
+=cut
+
+sub catfile {
+ my($self,@files) = @_;
+ my($file) = pop @files;
+ @files = grep($_,@files);
+ my($rslt);
+ if (@files) {
+ my($path) = (@files == 1 ? $files[0] : $self->catdir(@files));
+ my($spath) = $path;
+ $spath =~ s/.dir$//;
+ if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; }
+ else {
+ $rslt = $self->eliminate_macros($spath);
+ $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file));
+ }
+ }
+ else { $rslt = vmsify($file); }
+ print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
+ $rslt;
+}
+
+=item curdir (override)
+
+Returns a string representing of the current directory.
+
+=cut
+
+sub curdir {
+ return '[]';
+}
+
+=item rootdir (override)
+
+Returns a string representing of the root directory.
+
+=cut
+
+sub rootdir {
+ return '';
+}
+
+=item updir (override)
+
+Returns a string representing of the parent directory.
+
+=cut
+
+sub updir {
+ return '[-]';
+}
+
+=item path (override)
+
+Translate logical name DCL$PATH as a searchlist, rather than trying
+to C<split> string value of C<$ENV{'PATH'}>.
+
+=cut
+
+sub path {
+ my(@dirs,$dir,$i);
+ while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
+ @dirs;
+}
+
+=item file_name_is_absolute (override)
+
+Checks for VMS directory spec as well as Unix separators.
+
+=cut
+
+sub file_name_is_absolute {
+ my($self,$file) = @_;
+ # If it's a logical name, expand it.
+ $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file};
+ $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/;
+}
+
+1;
+__END__
+
diff --git a/contrib/perl5/lib/File/Spec/Win32.pm b/contrib/perl5/lib/File/Spec/Win32.pm
new file mode 100644
index 000000000000..034a0cbc2e69
--- /dev/null
+++ b/contrib/perl5/lib/File/Spec/Win32.pm
@@ -0,0 +1,104 @@
+package File::Spec::Win32;
+
+=head1 NAME
+
+File::Spec::Win32 - methods for Win32 file specs
+
+=head1 SYNOPSIS
+
+ use File::Spec::Win32; # Done internally by File::Spec if needed
+
+=head1 DESCRIPTION
+
+See File::Spec::Unix for a documentation of the methods provided
+there. This package overrides the implementation of these methods, not
+the semantics.
+
+=over
+
+=cut
+
+#use Config;
+#use Cwd;
+use File::Basename;
+require Exporter;
+use strict;
+
+use vars qw(@ISA);
+
+use File::Spec;
+Exporter::import('File::Spec', qw( $Verbose));
+
+@ISA = qw(File::Spec::Unix);
+
+$ENV{EMXSHELL} = 'sh'; # to run `commands`
+
+sub file_name_is_absolute {
+ my($self,$file) = @_;
+ $file =~ m{^([a-z]:)?[\\/]}i ;
+}
+
+sub catdir {
+ my $self = shift;
+ my @args = @_;
+ for (@args) {
+ # append a slash to each argument unless it has one there
+ $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\";
+ }
+ my $result = $self->canonpath(join('', @args));
+ $result;
+}
+
+=item catfile
+
+Concatenate one or more directory names and a filename to form a
+complete path ending with a filename
+
+=cut
+
+sub catfile {
+ my $self = shift @_;
+ my $file = pop @_;
+ return $file unless @_;
+ my $dir = $self->catdir(@_);
+ $dir =~ s/(\\\.)$//;
+ $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\";
+ return $dir.$file;
+}
+
+sub path {
+ local $^W = 1;
+ my($self) = @_;
+ my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
+ my @path = split(';',$path);
+ foreach(@path) { $_ = '.' if $_ eq '' }
+ @path;
+}
+
+=item canonpath
+
+No physical check on the filesystem, but a logical cleanup of a
+path. On UNIX eliminated successive slashes and successive "/.".
+
+=cut
+
+sub canonpath {
+ my($self,$path) = @_;
+ $path =~ s/^([a-z]:)/\u$1/;
+ $path =~ s|/|\\|g;
+ $path =~ s|\\+|\\|g ; # xx////xx -> xx/xx
+ $path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx
+ $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx
+ $path =~ s|\\$||
+ unless $path =~ m#^([a-z]:)?\\#; # xx/ -> xx
+ $path .= '.' if $path =~ m#\\$#;
+ $path;
+}
+
+1;
+__END__
+
+=back
+
+=cut
+
diff --git a/contrib/perl5/lib/File/stat.pm b/contrib/perl5/lib/File/stat.pm
new file mode 100644
index 000000000000..f5d17f7da443
--- /dev/null
+++ b/contrib/perl5/lib/File/stat.pm
@@ -0,0 +1,113 @@
+package File::stat;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @EXPORT = qw(stat lstat);
+ @EXPORT_OK = qw( $st_dev $st_ino $st_mode
+ $st_nlink $st_uid $st_gid
+ $st_rdev $st_size
+ $st_atime $st_mtime $st_ctime
+ $st_blksize $st_blocks
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'File::stat' => [
+ map { $_ => '$' } qw{
+ dev ino mode nlink uid gid rdev size
+ atime mtime ctime blksize blocks
+ }
+];
+
+sub populate (@) {
+ return unless @_;
+ my $stob = new();
+ @$stob = (
+ $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
+ $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks )
+ = @_;
+ return $stob;
+}
+
+sub lstat ($) { populate(CORE::lstat(shift)) }
+
+sub stat ($) {
+ my $arg = shift;
+ my $st = populate(CORE::stat $arg);
+ return $st if $st;
+ no strict 'refs';
+ require Symbol;
+ return populate(CORE::stat \*{Symbol::qualify($arg)});
+}
+
+1;
+__END__
+
+=head1 NAME
+
+File::stat - by-name interface to Perl's built-in stat() functions
+
+=head1 SYNOPSIS
+
+ use File::stat;
+ $st = stat($file) or die "No $file: $!";
+ if ( ($st->mode & 0111) && $st->nlink > 1) ) {
+ print "$file is executable with lotsa links\n";
+ }
+
+ use File::stat qw(:FIELDS);
+ stat($file) or die "No $file: $!";
+ if ( ($st_mode & 0111) && $st_nlink > 1) ) {
+ print "$file is executable with lotsa links\n";
+ }
+
+=head1 DESCRIPTION
+
+This module's default exports override the core stat()
+and lstat() functions, replacing them with versions that return
+"File::stat" objects. This object has methods that
+return the similarly named structure field name from the
+stat(2) function; namely,
+dev,
+ino,
+mode,
+nlink,
+uid,
+gid,
+rdev,
+size,
+atime,
+mtime,
+ctime,
+blksize,
+and
+blocks.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your stat() and lstat() functions.) Access these fields as
+variables named with a preceding C<st_> in front their method names.
+Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
+the fields.
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/contrib/perl5/lib/FileCache.pm b/contrib/perl5/lib/FileCache.pm
new file mode 100644
index 000000000000..e1c5ec4c8a88
--- /dev/null
+++ b/contrib/perl5/lib/FileCache.pm
@@ -0,0 +1,78 @@
+package FileCache;
+
+=head1 NAME
+
+FileCache - keep more files open than the system permits
+
+=head1 SYNOPSIS
+
+ cacheout $path;
+ print $path @data;
+
+=head1 DESCRIPTION
+
+The C<cacheout> function will make sure that there's a filehandle open
+for writing available as the pathname you give it. It automatically
+closes and re-opens files if you exceed your system file descriptor
+maximum.
+
+=head1 BUGS
+
+F<sys/param.h> lies with its C<NOFILE> define on some systems,
+so you may have to set $FileCache::cacheout_maxopen yourself.
+
+=cut
+
+require 5.000;
+use Carp;
+use Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(
+ cacheout
+);
+
+# Open in their package.
+
+sub cacheout_open {
+ my $pack = caller(1);
+ open(*{$pack . '::' . $_[0]}, $_[1]);
+}
+
+sub cacheout_close {
+ my $pack = caller(1);
+ close(*{$pack . '::' . $_[0]});
+}
+
+# But only this sub name is visible to them.
+
+$cacheout_seq = 0;
+$cacheout_numopen = 0;
+
+sub cacheout {
+ ($file) = @_;
+ unless (defined $cacheout_maxopen) {
+ if (open(PARAM,'/usr/include/sys/param.h')) {
+ local ($_, $.);
+ while (<PARAM>) {
+ $cacheout_maxopen = $1 - 4
+ if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
+ }
+ close PARAM;
+ }
+ $cacheout_maxopen = 16 unless $cacheout_maxopen;
+ }
+ if (!$isopen{$file}) {
+ if (++$cacheout_numopen > $cacheout_maxopen) {
+ my @lru = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
+ splice(@lru, $cacheout_maxopen / 3);
+ $cacheout_numopen -= @lru;
+ for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
+ }
+ cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file)
+ or croak("Can't create $file: $!");
+ }
+ $isopen{$file} = ++$cacheout_seq;
+}
+
+1;
diff --git a/contrib/perl5/lib/FileHandle.pm b/contrib/perl5/lib/FileHandle.pm
new file mode 100644
index 000000000000..eec9b61f31bb
--- /dev/null
+++ b/contrib/perl5/lib/FileHandle.pm
@@ -0,0 +1,262 @@
+package FileHandle;
+
+use 5.003_11;
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+
+$VERSION = "2.00";
+
+require IO::File;
+@ISA = qw(IO::File);
+
+@EXPORT = qw(_IOFBF _IOLBF _IONBF);
+
+@EXPORT_OK = qw(
+ pipe
+
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+
+ print
+ printf
+ getline
+ getlines
+);
+
+#
+# Everything we're willing to export, we must first import.
+#
+import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK;
+
+#
+# Some people call "FileHandle::function", so all the functions
+# that were in the old FileHandle class must be imported, too.
+#
+{
+ no strict 'refs';
+
+ my %import = (
+ 'IO::Handle' =>
+ [qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets
+ eof flush error clearerr setbuf setvbuf _open_mode_string)],
+ 'IO::Seekable' =>
+ [qw(seek tell getpos setpos)],
+ 'IO::File' =>
+ [qw(new new_tmpfile open)]
+ );
+ for my $pkg (keys %import) {
+ for my $func (@{$import{$pkg}}) {
+ my $c = *{"${pkg}::$func"}{CODE}
+ or die "${pkg}::$func missing";
+ *$func = $c;
+ }
+ }
+}
+
+#
+# Specialized importer for Fcntl magic.
+#
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+ require Exporter;
+ Exporter::export($pkg, $callpkg, @_);
+
+ #
+ # If the Fcntl extension is available,
+ # export its constants.
+ #
+ eval {
+ require Fcntl;
+ Exporter::export('Fcntl', $callpkg);
+ };
+}
+
+################################################
+# This is the only exported function we define;
+# the rest come from other classes.
+#
+
+sub pipe {
+ my $r = new IO::Handle;
+ my $w = new IO::Handle;
+ CORE::pipe($r, $w) or return undef;
+ ($r, $w);
+}
+
+# Rebless standard file handles
+bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle";
+bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle";
+bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle";
+
+1;
+
+__END__
+
+=head1 NAME
+
+FileHandle - supply object methods for filehandles
+
+=head1 SYNOPSIS
+
+ use FileHandle;
+
+ $fh = new FileHandle;
+ if ($fh->open("< file")) {
+ print <$fh>;
+ $fh->close;
+ }
+
+ $fh = new FileHandle "> FOO";
+ if (defined $fh) {
+ print $fh "bar\n";
+ $fh->close;
+ }
+
+ $fh = new FileHandle "file", "r";
+ if (defined $fh) {
+ print <$fh>;
+ undef $fh; # automatically closes the file
+ }
+
+ $fh = new FileHandle "file", O_WRONLY|O_APPEND;
+ if (defined $fh) {
+ print $fh "corge\n";
+ undef $fh; # automatically closes the file
+ }
+
+ $pos = $fh->getpos;
+ $fh->setpos($pos);
+
+ $fh->setvbuf($buffer_var, _IOLBF, 1024);
+
+ ($readfh, $writefh) = FileHandle::pipe;
+
+ autoflush STDOUT 1;
+
+=head1 DESCRIPTION
+
+NOTE: This class is now a front-end to the IO::* classes.
+
+C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
+newly created symbol (see the C<Symbol> package). If it receives any
+parameters, they are passed to C<FileHandle::open>; if the open fails,
+the C<FileHandle> object is destroyed. Otherwise, it is returned to
+the caller.
+
+C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
+It requires two parameters, which are passed to C<FileHandle::fdopen>;
+if the fdopen fails, the C<FileHandle> object is destroyed.
+Otherwise, it is returned to the caller.
+
+C<FileHandle::open> accepts one parameter or two. With one parameter,
+it is just a front end for the built-in C<open> function. With two
+parameters, the first parameter is a filename that may include
+whitespace or other special characters, and the second parameter is
+the open mode, optionally followed by a file permission value.
+
+If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.)
+or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
+Perl C<open> operator.
+
+If C<FileHandle::open> is given a numeric mode, it passes that mode
+and the optional permissions value to the Perl C<sysopen> operator.
+For convenience, C<FileHandle::import> tries to import the O_XXX
+constants from the Fcntl module. If dynamic loading is not available,
+this may fail, but the rest of FileHandle will still work.
+
+C<FileHandle::fdopen> is like C<open> except that its first parameter
+is not a filename but rather a file handle name, a FileHandle object,
+or a file descriptor number.
+
+If the C functions fgetpos() and fsetpos() are available, then
+C<FileHandle::getpos> returns an opaque value that represents the
+current position of the FileHandle, and C<FileHandle::setpos> uses
+that value to return to a previously visited position.
+
+If the C function setvbuf() is available, then C<FileHandle::setvbuf>
+sets the buffering policy for the FileHandle. The calling sequence
+for the Perl function is the same as its C counterpart, including the
+macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer
+parameter specifies a scalar variable to use as a buffer. WARNING: A
+variable used as a buffer by C<FileHandle::setvbuf> must not be
+modified in any way until the FileHandle is closed or until
+C<FileHandle::setvbuf> is called again, or memory corruption may
+result!
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<FileHandle> methods, which are just front ends for the
+corresponding built-in functions:
+
+ close
+ fileno
+ getc
+ gets
+ eof
+ clearerr
+ seek
+ tell
+
+See L<perlvar> for complete descriptions of each of the following
+supported C<FileHandle> methods:
+
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+
+Furthermore, for doing normal I/O you might need these:
+
+=over
+
+=item $fh->print
+
+See L<perlfunc/print>.
+
+=item $fh->printf
+
+See L<perlfunc/printf>.
+
+=item $fh->getline
+
+This works like <$fh> described in L<perlop/"I/O Operators">
+except that it's more readable and can be safely called in an
+array context but still returns just one line.
+
+=item $fh->getlines
+
+This works like <$fh> when called in an array context to
+read all the remaining lines in a file, except that it's more readable.
+It will also croak() if accidentally called in a scalar context.
+
+=back
+
+There are many other functions available since FileHandle is descended
+from IO::File, IO::Seekable, and IO::Handle. Please see those
+respective pages for documentation on more functions.
+
+=head1 SEE ALSO
+
+The B<IO> extension,
+L<perlfunc>,
+L<perlop/"I/O Operators">.
+
+=cut
diff --git a/contrib/perl5/lib/FindBin.pm b/contrib/perl5/lib/FindBin.pm
new file mode 100644
index 000000000000..d6bd7b777e20
--- /dev/null
+++ b/contrib/perl5/lib/FindBin.pm
@@ -0,0 +1,188 @@
+# FindBin.pm
+#
+# Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+=head1 NAME
+
+FindBin - Locate directory of original perl script
+
+=head1 SYNOPSIS
+
+ use FindBin;
+ use lib "$FindBin::Bin/../lib";
+
+ or
+
+ use FindBin qw($Bin);
+ use lib "$Bin/../lib";
+
+=head1 DESCRIPTION
+
+Locates the full path to the script bin directory to allow the use
+of paths relative to the bin directory.
+
+This allows a user to setup a directory tree for some software with
+directories E<lt>rootE<gt>/bin and E<lt>rootE<gt>/lib and then the above example will allow
+the use of modules in the lib directory without knowing where the software
+tree is installed.
+
+If perl is invoked using the B<-e> option or the perl script is read from
+C<STDIN> then FindBin sets both C<$Bin> and C<$RealBin> to the current
+directory.
+
+=head1 EXPORTABLE VARIABLES
+
+ $Bin - path to bin directory from where script was invoked
+ $Script - basename of script from which perl was invoked
+ $RealBin - $Bin with all links resolved
+ $RealScript - $Script with all links resolved
+
+=head1 KNOWN BUGS
+
+if perl is invoked as
+
+ perl filename
+
+and I<filename> does not have executable rights and a program called I<filename>
+exists in the users C<$ENV{PATH}> which satisfies both B<-x> and B<-T> then FindBin
+assumes that it was invoked via the C<$ENV{PATH}>.
+
+Workaround is to invoke perl as
+
+ perl ./filename
+
+=head1 AUTHORS
+
+Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
+Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=head1 REVISION
+
+$Revision: 1.4 $
+
+=cut
+
+package FindBin;
+use Carp;
+require 5.000;
+require Exporter;
+use Cwd qw(getcwd abs_path);
+use Config;
+use File::Basename;
+
+@EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir);
+%EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]);
+@ISA = qw(Exporter);
+
+$VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.41 $ =~ /(\d+)\.(\d+)/);
+
+sub is_abs_path
+{
+ local $_ = shift if (@_);
+ if ($^O eq 'MSWin32' || $^O eq 'dos')
+ {
+ return m#^[a-z]:[\\/]#i;
+ }
+ elsif ($^O eq 'VMS')
+ {
+ # If it's a logical name, expand it.
+ $_ = $ENV{$_} while /^[\w\$\-]+$/ and $ENV{$_};
+ return m!^/! or m![<\[][^.\-\]>]! or /:[^<\[]/;
+ }
+ else
+ {
+ return m#^/#;
+ }
+}
+
+BEGIN
+{
+ *Dir = \$Bin;
+ *RealDir = \$RealBin;
+
+ if($0 eq '-e' || $0 eq '-')
+ {
+ # perl invoked with -e or script is on C<STDIN>
+
+ $Script = $RealScript = $0;
+ $Bin = $RealBin = getcwd();
+ }
+ else
+ {
+ my $script = $0;
+
+ if ($^O eq 'VMS')
+ {
+ ($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*\])(.*)/;
+ ($RealBin,$RealScript) = ($Bin,$Script);
+ }
+ else
+ {
+ my $IsWin32 = $^O eq 'MSWin32';
+ unless(($script =~ m#/# || ($IsWin32 && $script =~ m#\\#))
+ && -f $script)
+ {
+ my $dir;
+ my $pathvar = 'PATH';
+
+ foreach $dir (split(/$Config{'path_sep'}/,$ENV{$pathvar}))
+ {
+ if(-r "$dir/$script" && (!$IsWin32 || -x _))
+ {
+ $script = "$dir/$script";
+
+ if (-f $0)
+ {
+ # $script has been found via PATH but perl could have
+ # been invoked as 'perl file'. Do a dumb check to see
+ # if $script is a perl program, if not then $script = $0
+ #
+ # well we actually only check that it is an ASCII file
+ # we know its executable so it is probably a script
+ # of some sort.
+
+ $script = $0 unless(-T $script);
+ }
+ last;
+ }
+ }
+ }
+
+ croak("Cannot find current script '$0'") unless(-f $script);
+
+ # Ensure $script contains the complete path incase we C<chdir>
+
+ $script = getcwd() . "/" . $script unless is_abs_path($script);
+
+ ($Script,$Bin) = fileparse($script);
+
+ # Resolve $script if it is a link
+ while(1)
+ {
+ my $linktext = readlink($script);
+
+ ($RealScript,$RealBin) = fileparse($script);
+ last unless defined $linktext;
+
+ $script = (is_abs_path($linktext))
+ ? $linktext
+ : $RealBin . "/" . $linktext;
+ }
+
+ # Get absolute paths to directories
+ $Bin = abs_path($Bin) if($Bin);
+ $RealBin = abs_path($RealBin) if($RealBin);
+ }
+ }
+}
+
+1; # Keep require happy
+
diff --git a/contrib/perl5/lib/Getopt/Long.pm b/contrib/perl5/lib/Getopt/Long.pm
new file mode 100644
index 000000000000..1966ef3c9117
--- /dev/null
+++ b/contrib/perl5/lib/Getopt/Long.pm
@@ -0,0 +1,1381 @@
+# GetOpt::Long.pm -- Universal options parsing
+
+package Getopt::Long;
+
+# RCS Status : $Id: GetoptLong.pl,v 2.18 1998-06-14 15:02:19+02 jv Exp $
+# Author : Johan Vromans
+# Created On : Tue Sep 11 15:00:12 1990
+# Last Modified By: Johan Vromans
+# Last Modified On: Sun Jun 14 13:17:22 1998
+# Update Count : 705
+# Status : Released
+
+################ Copyright ################
+
+# This program is Copyright 1990,1998 by Johan Vromans.
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# If you do not have a copy of the GNU General Public License write to
+# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
+# MA 02139, USA.
+
+################ Module Preamble ################
+
+use strict;
+
+BEGIN {
+ require 5.004;
+ use Exporter ();
+ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ $VERSION = "2.17";
+
+ @ISA = qw(Exporter);
+ @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
+ %EXPORT_TAGS = qw();
+ @EXPORT_OK = qw();
+ use AutoLoader qw(AUTOLOAD);
+}
+
+# User visible variables.
+use vars @EXPORT, @EXPORT_OK;
+use vars qw($error $debug $major_version $minor_version);
+# Deprecated visible variables.
+use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
+ $passthrough);
+# Official invisible variables.
+use vars qw($genprefix);
+
+# Public subroutines.
+sub Configure (@);
+sub config (@); # deprecated name
+sub GetOptions;
+
+# Private subroutines.
+sub ConfigDefaults ();
+sub FindOption ($$$$$$$);
+sub Croak (@); # demand loading the real Croak
+
+################ Local Variables ################
+
+################ Resident subroutines ################
+
+sub ConfigDefaults () {
+ # Handle POSIX compliancy.
+ if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+ $genprefix = "(--|-)";
+ $autoabbrev = 0; # no automatic abbrev of options
+ $bundling = 0; # no bundling of single letter switches
+ $getopt_compat = 0; # disallow '+' to start options
+ $order = $REQUIRE_ORDER;
+ }
+ else {
+ $genprefix = "(--|-|\\+)";
+ $autoabbrev = 1; # automatic abbrev of options
+ $bundling = 0; # bundling off by default
+ $getopt_compat = 1; # allow '+' to start options
+ $order = $PERMUTE;
+ }
+ # Other configurable settings.
+ $debug = 0; # for debugging
+ $error = 0; # error tally
+ $ignorecase = 1; # ignore case when matching options
+ $passthrough = 0; # leave unrecognized options alone
+}
+
+################ Initialization ################
+
+# Values for $order. See GNU getopt.c for details.
+($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
+# Version major/minor numbers.
+($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
+
+# Set defaults.
+ConfigDefaults ();
+
+################ Package return ################
+
+1;
+
+__END__
+
+################ AutoLoading subroutines ################
+
+# RCS Status : $Id: GetoptLongAl.pl,v 2.20 1998-06-14 15:02:19+02 jv Exp $
+# Author : Johan Vromans
+# Created On : Fri Mar 27 11:50:30 1998
+# Last Modified By: Johan Vromans
+# Last Modified On: Sun Jun 14 13:54:35 1998
+# Update Count : 24
+# Status : Released
+
+sub GetOptions {
+
+ my @optionlist = @_; # local copy of the option descriptions
+ my $argend = '--'; # option list terminator
+ my %opctl = (); # table of arg.specs (long and abbrevs)
+ my %bopctl = (); # table of arg.specs (bundles)
+ my $pkg = (caller)[0]; # current context
+ # Needed if linkage is omitted.
+ my %aliases= (); # alias table
+ my @ret = (); # accum for non-options
+ my %linkage; # linkage
+ my $userlinkage; # user supplied HASH
+ my $opt; # current option
+ my $genprefix = $genprefix; # so we can call the same module many times
+ my @opctl; # the possible long option names
+
+ $error = '';
+
+ print STDERR ("GetOpt::Long $Getopt::Long::VERSION ",
+ "called from package \"$pkg\".",
+ "\n ",
+ 'GetOptionsAl $Revision: 2.20 $ ',
+ "\n ",
+ "ARGV: (@ARGV)",
+ "\n ",
+ "autoabbrev=$autoabbrev,".
+ "bundling=$bundling,",
+ "getopt_compat=$getopt_compat,",
+ "order=$order,",
+ "\n ",
+ "ignorecase=$ignorecase,",
+ "passthrough=$passthrough,",
+ "genprefix=\"$genprefix\".",
+ "\n")
+ if $debug;
+
+ # Check for ref HASH as first argument.
+ # First argument may be an object. It's OK to use this as long
+ # as it is really a hash underneath.
+ $userlinkage = undef;
+ if ( ref($optionlist[0]) and
+ "$optionlist[0]" =~ /^(?:.*\=)?HASH\([^\(]*\)$/ ) {
+ $userlinkage = shift (@optionlist);
+ print STDERR ("=> user linkage: $userlinkage\n") if $debug;
+ }
+
+ # See if the first element of the optionlist contains option
+ # starter characters.
+ if ( $optionlist[0] =~ /^\W+$/ ) {
+ $genprefix = shift (@optionlist);
+ # Turn into regexp. Needs to be parenthesized!
+ $genprefix =~ s/(\W)/\\$1/g;
+ $genprefix = "([" . $genprefix . "])";
+ }
+
+ # Verify correctness of optionlist.
+ %opctl = ();
+ %bopctl = ();
+ while ( @optionlist > 0 ) {
+ my $opt = shift (@optionlist);
+
+ # Strip leading prefix so people can specify "--foo=i" if they like.
+ $opt = $+ if $opt =~ /^$genprefix+(.*)$/s;
+
+ if ( $opt eq '<>' ) {
+ if ( (defined $userlinkage)
+ && !(@optionlist > 0 && ref($optionlist[0]))
+ && (exists $userlinkage->{$opt})
+ && ref($userlinkage->{$opt}) ) {
+ unshift (@optionlist, $userlinkage->{$opt});
+ }
+ unless ( @optionlist > 0
+ && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
+ $error .= "Option spec <> requires a reference to a subroutine\n";
+ next;
+ }
+ $linkage{'<>'} = shift (@optionlist);
+ next;
+ }
+
+ # Match option spec. Allow '?' as an alias.
+ if ( $opt !~ /^((\w+[-\w]*)(\|(\?|\w[-\w]*)?)*)?([!~+]|[=:][infse][@%]?)?$/ ) {
+ $error .= "Error in option spec: \"$opt\"\n";
+ next;
+ }
+ my ($o, $c, $a) = ($1, $5);
+ $c = '' unless defined $c;
+
+ if ( ! defined $o ) {
+ # empty -> '-' option
+ $opctl{$o = ''} = $c;
+ }
+ else {
+ # Handle alias names
+ my @o = split (/\|/, $o);
+ my $linko = $o = $o[0];
+ # Force an alias if the option name is not locase.
+ $a = $o unless $o eq lc($o);
+ $o = lc ($o)
+ if $ignorecase > 1
+ || ($ignorecase
+ && ($bundling ? length($o) > 1 : 1));
+
+ foreach ( @o ) {
+ if ( $bundling && length($_) == 1 ) {
+ $_ = lc ($_) if $ignorecase > 1;
+ if ( $c eq '!' ) {
+ $opctl{"no$_"} = $c;
+ warn ("Ignoring '!' modifier for short option $_\n");
+ $c = '';
+ }
+ $opctl{$_} = $bopctl{$_} = $c;
+ }
+ else {
+ $_ = lc ($_) if $ignorecase;
+ if ( $c eq '!' ) {
+ $opctl{"no$_"} = $c;
+ $c = '';
+ }
+ $opctl{$_} = $c;
+ }
+ if ( defined $a ) {
+ # Note alias.
+ $aliases{$_} = $a;
+ }
+ else {
+ # Set primary name.
+ $a = $_;
+ }
+ }
+ $o = $linko;
+ }
+
+ # If no linkage is supplied in the @optionlist, copy it from
+ # the userlinkage if available.
+ if ( defined $userlinkage ) {
+ unless ( @optionlist > 0 && ref($optionlist[0]) ) {
+ if ( exists $userlinkage->{$o} && ref($userlinkage->{$o}) ) {
+ print STDERR ("=> found userlinkage for \"$o\": ",
+ "$userlinkage->{$o}\n")
+ if $debug;
+ unshift (@optionlist, $userlinkage->{$o});
+ }
+ else {
+ # Do nothing. Being undefined will be handled later.
+ next;
+ }
+ }
+ }
+
+ # Copy the linkage. If omitted, link to global variable.
+ if ( @optionlist > 0 && ref($optionlist[0]) ) {
+ print STDERR ("=> link \"$o\" to $optionlist[0]\n")
+ if $debug;
+ if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
+ $linkage{$o} = shift (@optionlist);
+ }
+ elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
+ $linkage{$o} = shift (@optionlist);
+ $opctl{$o} .= '@'
+ if $opctl{$o} ne '' and $opctl{$o} !~ /\@$/;
+ $bopctl{$o} .= '@'
+ if $bundling and defined $bopctl{$o} and
+ $bopctl{$o} ne '' and $bopctl{$o} !~ /\@$/;
+ }
+ elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
+ $linkage{$o} = shift (@optionlist);
+ $opctl{$o} .= '%'
+ if $opctl{$o} ne '' and $opctl{$o} !~ /\%$/;
+ $bopctl{$o} .= '%'
+ if $bundling and defined $bopctl{$o} and
+ $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/;
+ }
+ else {
+ $error .= "Invalid option linkage for \"$opt\"\n";
+ }
+ }
+ else {
+ # Link to global $opt_XXX variable.
+ # Make sure a valid perl identifier results.
+ my $ov = $o;
+ $ov =~ s/\W/_/g;
+ if ( $c =~ /@/ ) {
+ print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
+ }
+ elsif ( $c =~ /%/ ) {
+ print STDERR ("=> link \"$o\" to \%$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$o} = \\\%".$pkg."::opt_$ov;");
+ }
+ else {
+ print STDERR ("=> link \"$o\" to \$$pkg","::opt_$ov\n")
+ if $debug;
+ eval ("\$linkage{\$o} = \\\$".$pkg."::opt_$ov;");
+ }
+ }
+ }
+
+ # Bail out if errors found.
+ die ($error) if $error;
+ $error = 0;
+
+ # Sort the possible long option names.
+ @opctl = sort(keys (%opctl)) if $autoabbrev;
+
+ # Show the options tables if debugging.
+ if ( $debug ) {
+ my ($arrow, $k, $v);
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%opctl) ) {
+ print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
+ $arrow = " ";
+ }
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%bopctl) ) {
+ print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
+ $arrow = " ";
+ }
+ }
+
+ # Process argument list
+ while ( @ARGV > 0 ) {
+
+ #### Get next argument ####
+
+ $opt = shift (@ARGV);
+ print STDERR ("=> option \"", $opt, "\"\n") if $debug;
+
+ #### Determine what we have ####
+
+ # Double dash is option list terminator.
+ if ( $opt eq $argend ) {
+ # Finish. Push back accumulated arguments and return.
+ unshift (@ARGV, @ret)
+ if $order == $PERMUTE;
+ return ($error == 0);
+ }
+
+ my $tryopt = $opt;
+ my $found; # success status
+ my $dsttype; # destination type ('@' or '%')
+ my $incr; # destination increment
+ my $key; # key (if hash type)
+ my $arg; # option argument
+
+ ($found, $opt, $arg, $dsttype, $incr, $key) =
+ FindOption ($genprefix, $argend, $opt,
+ \%opctl, \%bopctl, \@opctl, \%aliases);
+
+ if ( $found ) {
+
+ # FindOption undefines $opt in case of errors.
+ next unless defined $opt;
+
+ if ( defined $arg ) {
+ $opt = $aliases{$opt} if defined $aliases{$opt};
+
+ if ( defined $linkage{$opt} ) {
+ print STDERR ("=> ref(\$L{$opt}) -> ",
+ ref($linkage{$opt}), "\n") if $debug;
+
+ if ( ref($linkage{$opt}) eq 'SCALAR' ) {
+ if ( $incr ) {
+ print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined ${$linkage{$opt}} ) {
+ ${$linkage{$opt}} += $arg;
+ }
+ else {
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ else {
+ print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
+ if $debug;
+ ${$linkage{$opt}} = $arg;
+ }
+ }
+ elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
+ print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
+ if $debug;
+ push (@{$linkage{$opt}}, $arg);
+ }
+ elsif ( ref($linkage{$opt}) eq 'HASH' ) {
+ print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $linkage{$opt}->{$key} = $arg;
+ }
+ elsif ( ref($linkage{$opt}) eq 'CODE' ) {
+ print STDERR ("=> &L{$opt}(\"$opt\", \"$arg\")\n")
+ if $debug;
+ &{$linkage{$opt}}($opt, $arg);
+ }
+ else {
+ print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
+ "\" in linkage\n");
+ Croak ("Getopt::Long -- internal error!\n");
+ }
+ }
+ # No entry in linkage means entry in userlinkage.
+ elsif ( $dsttype eq '@' ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
+ if $debug;
+ push (@{$userlinkage->{$opt}}, $arg);
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
+ if $debug;
+ $userlinkage->{$opt} = [$arg];
+ }
+ }
+ elsif ( $dsttype eq '%' ) {
+ if ( defined $userlinkage->{$opt} ) {
+ print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
+ if $debug;
+ $userlinkage->{$opt}->{$key} = $arg;
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
+ if $debug;
+ $userlinkage->{$opt} = {$key => $arg};
+ }
+ }
+ else {
+ if ( $incr ) {
+ print STDERR ("=> \$L{$opt} += \"$arg\"\n")
+ if $debug;
+ if ( defined $userlinkage->{$opt} ) {
+ $userlinkage->{$opt} += $arg;
+ }
+ else {
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+ else {
+ print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
+ $userlinkage->{$opt} = $arg;
+ }
+ }
+ }
+ }
+
+ # Not an option. Save it if we $PERMUTE and don't have a <>.
+ elsif ( $order == $PERMUTE ) {
+ # Try non-options call-back.
+ my $cb;
+ if ( (defined ($cb = $linkage{'<>'})) ) {
+ &$cb ($tryopt);
+ }
+ else {
+ print STDERR ("=> saving \"$tryopt\" ",
+ "(not an option, may permute)\n") if $debug;
+ push (@ret, $tryopt);
+ }
+ next;
+ }
+
+ # ...otherwise, terminate.
+ else {
+ # Push this one back and exit.
+ unshift (@ARGV, $tryopt);
+ return ($error == 0);
+ }
+
+ }
+
+ # Finish.
+ if ( $order == $PERMUTE ) {
+ # Push back accumulated arguments
+ print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+ if $debug && @ret > 0;
+ unshift (@ARGV, @ret) if @ret > 0;
+ }
+
+ return ($error == 0);
+}
+
+# Option lookup.
+sub FindOption ($$$$$$$) {
+
+ # returns (1, $opt, $arg, $dsttype, $incr, $key) if okay,
+ # returns (0) otherwise.
+
+ my ($prefix, $argend, $opt, $opctl, $bopctl, $names, $aliases) = @_;
+ my $key; # hash key for a hash option
+ my $arg;
+
+ print STDERR ("=> find \"$opt\", prefix=\"$prefix\"\n") if $debug;
+
+ return (0) unless $opt =~ /^$prefix(.*)$/s;
+
+ $opt = $+;
+ my ($starter) = $1;
+
+ print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
+
+ my $optarg = undef; # value supplied with --opt=value
+ my $rest = undef; # remainder from unbundling
+
+ # If it is a long option, it may include the value.
+ if (($starter eq "--" || ($getopt_compat && !$bundling))
+ && $opt =~ /^([^=]+)=(.*)$/s ) {
+ $opt = $1;
+ $optarg = $2;
+ print STDERR ("=> option \"", $opt,
+ "\", optarg = \"$optarg\"\n") if $debug;
+ }
+
+ #### Look it up ###
+
+ my $tryopt = $opt; # option to try
+ my $optbl = $opctl; # table to look it up (long names)
+ my $type;
+ my $dsttype = '';
+ my $incr = 0;
+
+ if ( $bundling && $starter eq '-' ) {
+ # Unbundle single letter option.
+ $rest = substr ($tryopt, 1);
+ $tryopt = substr ($tryopt, 0, 1);
+ $tryopt = lc ($tryopt) if $ignorecase > 1;
+ print STDERR ("=> $starter$tryopt unbundled from ",
+ "$starter$tryopt$rest\n") if $debug;
+ $rest = undef unless $rest ne '';
+ $optbl = $bopctl; # look it up in the short names table
+
+ # If bundling == 2, long options can override bundles.
+ if ( $bundling == 2 and
+ defined ($type = $opctl->{$tryopt.$rest}) ) {
+ print STDERR ("=> $starter$tryopt rebundled to ",
+ "$starter$tryopt$rest\n") if $debug;
+ $tryopt .= $rest;
+ undef $rest;
+ }
+ }
+
+ # Try auto-abbreviation.
+ elsif ( $autoabbrev ) {
+ # Downcase if allowed.
+ $tryopt = $opt = lc ($opt) if $ignorecase;
+ # Turn option name into pattern.
+ my $pat = quotemeta ($opt);
+ # Look up in option names.
+ my @hits = grep (/^$pat/, @{$names});
+ print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
+ "out of ", scalar(@{$names}), "\n") if $debug;
+
+ # Check for ambiguous results.
+ unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
+ # See if all matches are for the same option.
+ my %hit;
+ foreach ( @hits ) {
+ $_ = $aliases->{$_} if defined $aliases->{$_};
+ $hit{$_} = 1;
+ }
+ # Now see if it really is ambiguous.
+ unless ( keys(%hit) == 1 ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " is ambiguous (",
+ join(", ", @hits), ")\n");
+ $error++;
+ undef $opt;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
+ }
+ @hits = keys(%hit);
+ }
+
+ # Complete the option name, if appropriate.
+ if ( @hits == 1 && $hits[0] ne $opt ) {
+ $tryopt = $hits[0];
+ $tryopt = lc ($tryopt) if $ignorecase;
+ print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
+ if $debug;
+ }
+ }
+
+ # Map to all lowercase if ignoring case.
+ elsif ( $ignorecase ) {
+ $tryopt = lc ($opt);
+ }
+
+ # Check validity by fetching the info.
+ $type = $optbl->{$tryopt} unless defined $type;
+ unless ( defined $type ) {
+ return (0) if $passthrough;
+ warn ("Unknown option: ", $opt, "\n");
+ $error++;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
+ }
+ # Apparently valid.
+ $opt = $tryopt;
+ print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
+
+ #### Determine argument status ####
+
+ # If it is an option w/o argument, we're almost finished with it.
+ if ( $type eq '' || $type eq '!' || $type eq '+' ) {
+ if ( defined $optarg ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " does not take an argument\n");
+ $error++;
+ undef $opt;
+ }
+ elsif ( $type eq '' || $type eq '+' ) {
+ $arg = 1; # supply explicit value
+ $incr = $type eq '+';
+ }
+ else {
+ substr ($opt, 0, 2) = ''; # strip NO prefix
+ $arg = 0; # supply explicit value
+ }
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ return (1, $opt,$arg,$dsttype,$incr,$key);
+ }
+
+ # Get mandatory status and type info.
+ my $mand;
+ ($mand, $type, $dsttype, $key) = $type =~ /^(.)(.)([@%]?)$/;
+
+ # Check if there is an option argument available.
+ if ( defined $optarg ? ($optarg eq '')
+ : !(defined $rest || @ARGV > 0) ) {
+ # Complain if this option needs an argument.
+ if ( $mand eq "=" ) {
+ return (0) if $passthrough;
+ warn ("Option ", $opt, " requires an argument\n");
+ $error++;
+ undef $opt;
+ }
+ if ( $mand eq ":" ) {
+ $arg = $type eq "s" ? '' : 0;
+ }
+ return (1, $opt,$arg,$dsttype,$incr,$key);
+ }
+
+ # Get (possibly optional) argument.
+ $arg = (defined $rest ? $rest
+ : (defined $optarg ? $optarg : shift (@ARGV)));
+
+ # Get key if this is a "name=value" pair for a hash option.
+ $key = undef;
+ if ($dsttype eq '%' && defined $arg) {
+ ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1);
+ }
+
+ #### Check if the argument is valid for this option ####
+
+ if ( $type eq "s" ) { # string
+ # A mandatory string takes anything.
+ return (1, $opt,$arg,$dsttype,$incr,$key) if $mand eq "=";
+
+ # An optional string takes almost anything.
+ return (1, $opt,$arg,$dsttype,$incr,$key)
+ if defined $optarg || defined $rest;
+ return (1, $opt,$arg,$dsttype,$incr,$key) if $arg eq "-"; # ??
+
+ # Check for option or option list terminator.
+ if ($arg eq $argend ||
+ $arg =~ /^$prefix.+/) {
+ # Push back.
+ unshift (@ARGV, $arg);
+ # Supply empty value.
+ $arg = '';
+ }
+ }
+
+ elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
+ if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) {
+ $arg = $1;
+ $rest = $2;
+ unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg !~ /^-?[0-9]+$/ ) {
+ if ( defined $optarg || $mand eq "=" ) {
+ if ( $passthrough ) {
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
+ }
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (number expected)\n");
+ $error++;
+ undef $opt;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ }
+ else {
+ # Push back.
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0;
+ }
+ }
+ }
+
+ elsif ( $type eq "f" ) { # real number, int is also ok
+ # We require at least one digit before a point or 'e',
+ # and at least one digit following the point and 'e'.
+ # [-]NN[.NN][eNN]
+ if ( $bundling && defined $rest &&
+ $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/s ) {
+ $arg = $1;
+ $rest = $+;
+ unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne '';
+ }
+ elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) {
+ if ( defined $optarg || $mand eq "=" ) {
+ if ( $passthrough ) {
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return (0);
+ }
+ warn ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (real number expected)\n");
+ $error++;
+ undef $opt;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ }
+ else {
+ # Push back.
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0.0;
+ }
+ }
+ }
+ else {
+ Croak ("GetOpt::Long internal error (Can't happen)\n");
+ }
+ return (1, $opt, $arg, $dsttype, $incr, $key);
+}
+
+# Getopt::Long Configuration.
+sub Configure (@) {
+ my (@options) = @_;
+ my $opt;
+ foreach $opt ( @options ) {
+ my $try = lc ($opt);
+ my $action = 1;
+ if ( $try =~ /^no_?(.*)$/s ) {
+ $action = 0;
+ $try = $+;
+ }
+ if ( $try eq 'default' or $try eq 'defaults' ) {
+ ConfigDefaults () if $action;
+ }
+ elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
+ $autoabbrev = $action;
+ }
+ elsif ( $try eq 'getopt_compat' ) {
+ $getopt_compat = $action;
+ }
+ elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
+ $ignorecase = $action;
+ }
+ elsif ( $try eq 'ignore_case_always' ) {
+ $ignorecase = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'bundling' ) {
+ $bundling = $action;
+ }
+ elsif ( $try eq 'bundling_override' ) {
+ $bundling = $action ? 2 : 0;
+ }
+ elsif ( $try eq 'require_order' ) {
+ $order = $action ? $REQUIRE_ORDER : $PERMUTE;
+ }
+ elsif ( $try eq 'permute' ) {
+ $order = $action ? $PERMUTE : $REQUIRE_ORDER;
+ }
+ elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
+ $passthrough = $action;
+ }
+ elsif ( $try =~ /^prefix=(.+)$/ ) {
+ $genprefix = $1;
+ # Turn into regexp. Needs to be parenthesized!
+ $genprefix = "(" . quotemeta($genprefix) . ")";
+ eval { '' =~ /$genprefix/; };
+ Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try =~ /^prefix_pattern=(.+)$/ ) {
+ $genprefix = $1;
+ # Parenthesize if needed.
+ $genprefix = "(" . $genprefix . ")"
+ unless $genprefix =~ /^\(.*\)$/;
+ eval { '' =~ /$genprefix/; };
+ Croak ("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
+ }
+ elsif ( $try eq 'debug' ) {
+ $debug = $action;
+ }
+ else {
+ Croak ("Getopt::Long: unknown config parameter \"$opt\"")
+ }
+ }
+}
+
+# Deprecated name.
+sub config (@) {
+ Configure (@_);
+}
+
+# To prevent Carp from being loaded unnecessarily.
+sub Croak (@) {
+ require 'Carp.pm';
+ $Carp::CarpLevel = 1;
+ Carp::croak(@_);
+};
+
+################ Documentation ################
+
+=head1 NAME
+
+GetOptions - extended processing of command line options
+
+=head1 SYNOPSIS
+
+ use Getopt::Long;
+ $result = GetOptions (...option-descriptions...);
+
+=head1 DESCRIPTION
+
+The Getopt::Long module implements an extended getopt function called
+GetOptions(). This function adheres to the POSIX syntax for command
+line options, with GNU extensions. In general, this means that options
+have long names instead of single letters, and are introduced with a
+double dash "--". Support for bundling of command line options, as was
+the case with the more traditional single-letter approach, is provided
+but not enabled by default. For example, the UNIX "ps" command can be
+given the command line "option"
+
+ -vax
+
+which means the combination of B<-v>, B<-a> and B<-x>. With the new
+syntax B<--vax> would be a single option, probably indicating a
+computer architecture.
+
+Command line options can be used to set values. These values can be
+specified in one of two ways:
+
+ --size 24
+ --size=24
+
+GetOptions is called with a list of option-descriptions, each of which
+consists of two elements: the option specifier and the option linkage.
+The option specifier defines the name of the option and, optionally,
+the value it can take. The option linkage is usually a reference to a
+variable that will be set when the option is used. For example, the
+following call to GetOptions:
+
+ GetOptions("size=i" => \$offset);
+
+will accept a command line option "size" that must have an integer
+value. With a command line of "--size 24" this will cause the variable
+$offset to get the value 24.
+
+Alternatively, the first argument to GetOptions may be a reference to
+a HASH describing the linkage for the options, or an object whose
+class is based on a HASH. The following call is equivalent to the
+example above:
+
+ %optctl = ("size" => \$offset);
+ GetOptions(\%optctl, "size=i");
+
+Linkage may be specified using either of the above methods, or both.
+Linkage specified in the argument list takes precedence over the
+linkage specified in the HASH.
+
+The command line options are taken from array @ARGV. Upon completion
+of GetOptions, @ARGV will contain the rest (i.e. the non-options) of
+the command line.
+
+Each option specifier designates the name of the option, optionally
+followed by an argument specifier.
+
+Options that do not take arguments will have no argument specifier.
+The option variable will be set to 1 if the option is used.
+
+For the other options, the values for argument specifiers are:
+
+=over 8
+
+=item !
+
+Option does not take an argument and may be negated, i.e. prefixed by
+"no". E.g. "foo!" will allow B<--foo> (with value 1) and B<-nofoo>
+(with value 0).
+The option variable will be set to 1, or 0 if negated.
+
+=item +
+
+Option does not take an argument and will be incremented by 1 every
+time it appears on the command line. E.g. "more+", when used with
+B<--more --more --more>, will set the option variable to 3 (provided
+it was 0 or undefined at first).
+
+The B<+> specifier is ignored if the option destination is not a SCALAR.
+
+=item =s
+
+Option takes a mandatory string argument.
+This string will be assigned to the option variable.
+Note that even if the string argument starts with B<-> or B<-->, it
+will not be considered an option on itself.
+
+=item :s
+
+Option takes an optional string argument.
+This string will be assigned to the option variable.
+If omitted, it will be assigned "" (an empty string).
+If the string argument starts with B<-> or B<-->, it
+will be considered an option on itself.
+
+=item =i
+
+Option takes a mandatory integer argument.
+This value will be assigned to the option variable.
+Note that the value may start with B<-> to indicate a negative
+value.
+
+=item :i
+
+Option takes an optional integer argument.
+This value will be assigned to the option variable.
+If omitted, the value 0 will be assigned.
+Note that the value may start with B<-> to indicate a negative
+value.
+
+=item =f
+
+Option takes a mandatory real number argument.
+This value will be assigned to the option variable.
+Note that the value may start with B<-> to indicate a negative
+value.
+
+=item :f
+
+Option takes an optional real number argument.
+This value will be assigned to the option variable.
+If omitted, the value 0 will be assigned.
+
+=back
+
+A lone dash B<-> is considered an option, the corresponding option
+name is the empty string.
+
+A double dash on itself B<--> signals end of the options list.
+
+=head2 Linkage specification
+
+The linkage specifier is optional. If no linkage is explicitly
+specified but a ref HASH is passed, GetOptions will place the value in
+the HASH. For example:
+
+ %optctl = ();
+ GetOptions (\%optctl, "size=i");
+
+will perform the equivalent of the assignment
+
+ $optctl{"size"} = 24;
+
+For array options, a reference to an array is used, e.g.:
+
+ %optctl = ();
+ GetOptions (\%optctl, "sizes=i@");
+
+with command line "-sizes 24 -sizes 48" will perform the equivalent of
+the assignment
+
+ $optctl{"sizes"} = [24, 48];
+
+For hash options (an option whose argument looks like "name=value"),
+a reference to a hash is used, e.g.:
+
+ %optctl = ();
+ GetOptions (\%optctl, "define=s%");
+
+with command line "--define foo=hello --define bar=world" will perform the
+equivalent of the assignment
+
+ $optctl{"define"} = {foo=>'hello', bar=>'world')
+
+If no linkage is explicitly specified and no ref HASH is passed,
+GetOptions will put the value in a global variable named after the
+option, prefixed by "opt_". To yield a usable Perl variable,
+characters that are not part of the syntax for variables are
+translated to underscores. For example, "--fpp-struct-return" will set
+the variable $opt_fpp_struct_return. Note that this variable resides
+in the namespace of the calling program, not necessarily B<main>.
+For example:
+
+ GetOptions ("size=i", "sizes=i@");
+
+with command line "-size 10 -sizes 24 -sizes 48" will perform the
+equivalent of the assignments
+
+ $opt_size = 10;
+ @opt_sizes = (24, 48);
+
+A lone dash B<-> is considered an option, the corresponding Perl
+identifier is $opt_ .
+
+The linkage specifier can be a reference to a scalar, a reference to
+an array, a reference to a hash or a reference to a subroutine.
+
+Note that, if your code is running under the recommended C<use strict
+'vars'> pragma, it may be helpful to declare these package variables
+via C<use vars> perhaps something like this:
+
+ use vars qw/ $opt_size @opt_sizes $opt_bar /;
+
+If a REF SCALAR is supplied, the new value is stored in the referenced
+variable. If the option occurs more than once, the previous value is
+overwritten.
+
+If a REF ARRAY is supplied, the new value is appended (pushed) to the
+referenced array.
+
+If a REF HASH is supplied, the option value should look like "key" or
+"key=value" (if the "=value" is omitted then a value of 1 is implied).
+In this case, the element of the referenced hash with the key "key"
+is assigned "value".
+
+If a REF CODE is supplied, the referenced subroutine is called with
+two arguments: the option name and the option value.
+The option name is always the true name, not an abbreviation or alias.
+
+=head2 Aliases and abbreviations
+
+The option name may actually be a list of option names, separated by
+"|"s, e.g. "foo|bar|blech=s". In this example, "foo" is the true name
+of this option. If no linkage is specified, options "foo", "bar" and
+"blech" all will set $opt_foo. For convenience, the single character
+"?" is allowed as an alias, e.g. "help|?".
+
+Option names may be abbreviated to uniqueness, depending on
+configuration option B<auto_abbrev>.
+
+=head2 Non-option call-back routine
+
+A special option specifier, E<lt>E<gt>, can be used to designate a subroutine
+to handle non-option arguments. GetOptions will immediately call this
+subroutine for every non-option it encounters in the options list.
+This subroutine gets the name of the non-option passed.
+This feature requires configuration option B<permute>, see section
+CONFIGURATION OPTIONS.
+
+See also the examples.
+
+=head2 Option starters
+
+On the command line, options can start with B<-> (traditional), B<-->
+(POSIX) and B<+> (GNU, now being phased out). The latter is not
+allowed if the environment variable B<POSIXLY_CORRECT> has been
+defined.
+
+Options that start with "--" may have an argument appended, separated
+with an "=", e.g. "--foo=bar".
+
+=head2 Return values and Errors
+
+Configuration errors and errors in the option definitions are
+signalled using C<die()> and will terminate the calling
+program unless the call to C<Getopt::Long::GetOptions()> was embedded
+in C<eval { ... }> or C<die()> was trapped using C<$SIG{__DIE__}>.
+
+A return value of 1 (true) indicates success.
+
+A return status of 0 (false) indicates that the function detected one
+or more errors during option parsing. These errors are signalled using
+C<warn()> and can be trapped with C<$SIG{__WARN__}>.
+
+Errors that can't happen are signalled using C<Carp::croak()>.
+
+=head1 COMPATIBILITY
+
+Getopt::Long::GetOptions() is the successor of
+B<newgetopt.pl> that came with Perl 4. It is fully upward compatible.
+In fact, the Perl 5 version of newgetopt.pl is just a wrapper around
+the module.
+
+If an "@" sign is appended to the argument specifier, the option is
+treated as an array. Value(s) are not set, but pushed into array
+@opt_name. If explicit linkage is supplied, this must be a reference
+to an ARRAY.
+
+If an "%" sign is appended to the argument specifier, the option is
+treated as a hash. Value(s) of the form "name=value" are set by
+setting the element of the hash %opt_name with key "name" to "value"
+(if the "=value" portion is omitted it defaults to 1). If explicit
+linkage is supplied, this must be a reference to a HASH.
+
+If configuration option B<getopt_compat> is set (see section
+CONFIGURATION OPTIONS), options that start with "+" or "-" may also
+include their arguments, e.g. "+foo=bar". This is for compatiblity
+with older implementations of the GNU "getopt" routine.
+
+If the first argument to GetOptions is a string consisting of only
+non-alphanumeric characters, it is taken to specify the option starter
+characters. Everything starting with one of these characters from the
+starter will be considered an option. B<Using a starter argument is
+strongly deprecated.>
+
+For convenience, option specifiers may have a leading B<-> or B<-->,
+so it is possible to write:
+
+ GetOptions qw(-foo=s --bar=i --ar=s);
+
+=head1 EXAMPLES
+
+If the option specifier is "one:i" (i.e. takes an optional integer
+argument), then the following situations are handled:
+
+ -one -two -> $opt_one = '', -two is next option
+ -one -2 -> $opt_one = -2
+
+Also, assume specifiers "foo=s" and "bar:s" :
+
+ -bar -xxx -> $opt_bar = '', '-xxx' is next option
+ -foo -bar -> $opt_foo = '-bar'
+ -foo -- -> $opt_foo = '--'
+
+In GNU or POSIX format, option names and values can be combined:
+
+ +foo=blech -> $opt_foo = 'blech'
+ --bar= -> $opt_bar = ''
+ --bar=-- -> $opt_bar = '--'
+
+Example of using variable references:
+
+ $ret = GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
+
+With command line options "-foo blech -bar 24 -ar xx -ar yy"
+this will result in:
+
+ $foo = 'blech'
+ $opt_bar = 24
+ @ar = ('xx','yy')
+
+Example of using the E<lt>E<gt> option specifier:
+
+ @ARGV = qw(-foo 1 bar -foo 2 blech);
+ GetOptions("foo=i", \$myfoo, "<>", \&mysub);
+
+Results:
+
+ mysub("bar") will be called (with $myfoo being 1)
+ mysub("blech") will be called (with $myfoo being 2)
+
+Compare this with:
+
+ @ARGV = qw(-foo 1 bar -foo 2 blech);
+ GetOptions("foo=i", \$myfoo);
+
+This will leave the non-options in @ARGV:
+
+ $myfoo -> 2
+ @ARGV -> qw(bar blech)
+
+=head1 CONFIGURATION OPTIONS
+
+B<GetOptions> can be configured by calling subroutine
+B<Getopt::Long::Configure>. This subroutine takes a list of quoted
+strings, each specifying a configuration option to be set, e.g.
+B<ignore_case>. Options can be reset by prefixing with B<no_>, e.g.
+B<no_ignore_case>. Case does not matter. Multiple calls to B<config>
+are possible.
+
+Previous versions of Getopt::Long used variables for the purpose of
+configuring. Although manipulating these variables still work, it
+is strongly encouraged to use the new B<config> routine. Besides, it
+is much easier.
+
+The following options are available:
+
+=over 12
+
+=item default
+
+This option causes all configuration options to be reset to their
+default values.
+
+=item auto_abbrev
+
+Allow option names to be abbreviated to uniqueness.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.
+
+=item getopt_compat
+
+Allow '+' to start options.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.
+
+=item require_order
+
+Whether non-options are allowed to be mixed with
+options.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case b<require_order> is reset.
+
+See also B<permute>, which is the opposite of B<require_order>.
+
+=item permute
+
+Whether non-options are allowed to be mixed with
+options.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<permute> is reset.
+Note that B<permute> is the opposite of B<require_order>.
+
+If B<permute> is set, this means that
+
+ -foo arg1 -bar arg2 arg3
+
+is equivalent to
+
+ -foo -bar arg1 arg2 arg3
+
+If a non-option call-back routine is specified, @ARGV will always be
+empty upon succesful return of GetOptions since all options have been
+processed, except when B<--> is used:
+
+ -foo arg1 -bar arg2 -- arg3
+
+will call the call-back routine for arg1 and arg2, and terminate
+leaving arg2 in @ARGV.
+
+If B<require_order> is set, options processing
+terminates when the first non-option is encountered.
+
+ -foo arg1 -bar arg2 arg3
+
+is equivalent to
+
+ -foo -- arg1 -bar arg2 arg3
+
+=item bundling (default: reset)
+
+Setting this variable to a non-zero value will allow single-character
+options to be bundled. To distinguish bundles from long option names,
+long options must be introduced with B<--> and single-character
+options (and bundles) with B<->. For example,
+
+ ps -vax --vax
+
+would be equivalent to
+
+ ps -v -a -x --vax
+
+provided "vax", "v", "a" and "x" have been defined to be valid
+options.
+
+Bundled options can also include a value in the bundle; for strings
+this value is the rest of the bundle, but integer and floating values
+may be combined in the bundle, e.g.
+
+ scale -h24w80
+
+is equivalent to
+
+ scale -h 24 -w 80
+
+Note: resetting B<bundling> also resets B<bundling_override>.
+
+=item bundling_override (default: reset)
+
+If B<bundling_override> is set, bundling is enabled as with
+B<bundling> but now long option names override option bundles. In the
+above example, B<-vax> would be interpreted as the option "vax", not
+the bundle "v", "a", "x".
+
+Note: resetting B<bundling_override> also resets B<bundling>.
+
+B<Note:> Using option bundling can easily lead to unexpected results,
+especially when mixing long options and bundles. Caveat emptor.
+
+=item ignore_case (default: set)
+
+If set, case is ignored when matching options.
+
+Note: resetting B<ignore_case> also resets B<ignore_case_always>.
+
+=item ignore_case_always (default: reset)
+
+When bundling is in effect, case is ignored on single-character
+options also.
+
+Note: resetting B<ignore_case_always> also resets B<ignore_case>.
+
+=item pass_through (default: reset)
+
+Unknown options are passed through in @ARGV instead of being flagged
+as errors. This makes it possible to write wrapper scripts that
+process only part of the user supplied options, and passes the
+remaining options to some other program.
+
+This can be very confusing, especially when B<permute> is also set.
+
+=item prefix
+
+The string that starts options. See also B<prefix_pattern>.
+
+=item prefix_pattern
+
+A Perl pattern that identifies the strings that introduce options.
+Default is C<(--|-|\+)> unless environment variable
+POSIXLY_CORRECT has been set, in which case it is C<(--|-)>.
+
+=item debug (default: reset)
+
+Enable copious debugging output.
+
+=back
+
+=head1 OTHER USEFUL VARIABLES
+
+=over 12
+
+=item $Getopt::Long::VERSION
+
+The version number of this Getopt::Long implementation in the format
+C<major>.C<minor>. This can be used to have Exporter check the
+version, e.g.
+
+ use Getopt::Long 3.00;
+
+You can inspect $Getopt::Long::major_version and
+$Getopt::Long::minor_version for the individual components.
+
+=item $Getopt::Long::error
+
+Internal error flag. May be incremented from a call-back routine to
+cause options parsing to fail.
+
+=back
+
+=head1 AUTHOR
+
+Johan Vromans E<lt>jvromans@squirrel.nlE<gt>
+
+=head1 COPYRIGHT AND DISCLAIMER
+
+This program is Copyright 1990,1998 by Johan Vromans.
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+If you do not have a copy of the GNU General Public License write to
+the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
+MA 02139, USA.
+
+=cut
diff --git a/contrib/perl5/lib/Getopt/Std.pm b/contrib/perl5/lib/Getopt/Std.pm
new file mode 100644
index 000000000000..c2cd1234f4cf
--- /dev/null
+++ b/contrib/perl5/lib/Getopt/Std.pm
@@ -0,0 +1,166 @@
+package Getopt::Std;
+require 5.000;
+require Exporter;
+
+=head1 NAME
+
+getopt - Process single-character switches with switch clustering
+
+getopts - Process single-character switches with switch clustering
+
+=head1 SYNOPSIS
+
+ use Getopt::Std;
+
+ getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
+ getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts
+ getopts('oif:'); # -o & -i are boolean flags, -f takes an argument
+ # Sets opt_* as a side effect.
+ getopts('oif:', \%opts); # options as above. Values in %opts
+
+=head1 DESCRIPTION
+
+The getopt() functions processes single-character switches with switch
+clustering. Pass one argument which is a string containing all switches
+that take an argument. For each switch found, sets $opt_x (where x is the
+switch name) to the value of the argument, or 1 if no argument. Switches
+which take an argument don't care whether there is a space between the
+switch and the argument.
+
+Note that, if your code is running under the recommended C<use strict
+'vars'> pragma, it may be helpful to declare these package variables
+via C<use vars> perhaps something like this:
+
+ use vars qw/ $opt_foo $opt_bar /;
+
+For those of you who don't like additional variables being created, getopt()
+and getopts() will also accept a hash reference as an optional second argument.
+Hash keys will be x (where x is the switch name) with key values the value of
+the argument or 1 if no argument is specified.
+
+=cut
+
+@ISA = qw(Exporter);
+@EXPORT = qw(getopt getopts);
+
+# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
+
+# Process single-character switches with switch clustering. Pass one argument
+# which is a string containing all switches that take an argument. For each
+# switch found, sets $opt_x (where x is the switch name) to the value of the
+# argument, or 1 if no argument. Switches which take an argument don't care
+# whether there is a space between the switch and the argument.
+
+# Usage:
+# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
+
+sub getopt ($;$) {
+ local($argumentative, $hash) = @_;
+ local($_,$first,$rest);
+ local @EXPORT;
+
+ while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ if (index($argumentative,$first) >= 0) {
+ if ($rest ne '') {
+ shift(@ARGV);
+ }
+ else {
+ shift(@ARGV);
+ $rest = shift(@ARGV);
+ }
+ if (ref $hash) {
+ $$hash{$first} = $rest;
+ }
+ else {
+ ${"opt_$first"} = $rest;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ }
+ else {
+ if (ref $hash) {
+ $$hash{$first} = 1;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ if ($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ unless (ref $hash) {
+ local $Exporter::ExportLevel = 1;
+ import Getopt::Std;
+ }
+}
+
+# Usage:
+# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
+# # side effect.
+
+sub getopts ($;$) {
+ local($argumentative, $hash) = @_;
+ local(@args,$_,$first,$rest);
+ local($errs) = 0;
+ local @EXPORT;
+
+ @args = split( / */, $argumentative );
+ while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ $pos = index($argumentative,$first);
+ if($pos >= 0) {
+ if(defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
+ shift(@ARGV);
+ if($rest eq '') {
+ ++$errs unless @ARGV;
+ $rest = shift(@ARGV);
+ }
+ if (ref $hash) {
+ $$hash{$first} = $rest;
+ }
+ else {
+ ${"opt_$first"} = $rest;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ }
+ else {
+ if (ref $hash) {
+ $$hash{$first} = 1;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ push( @EXPORT, "\$opt_$first" );
+ }
+ if($rest eq '') {
+ shift(@ARGV);
+ }
+ else {
+ $ARGV[0] = "-$rest";
+ }
+ }
+ }
+ else {
+ print STDERR "Unknown option: $first\n";
+ ++$errs;
+ if($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ unless (ref $hash) {
+ local $Exporter::ExportLevel = 1;
+ import Getopt::Std;
+ }
+ $errs == 0;
+}
+
+1;
+
diff --git a/contrib/perl5/lib/I18N/Collate.pm b/contrib/perl5/lib/I18N/Collate.pm
new file mode 100644
index 000000000000..580ca39785cd
--- /dev/null
+++ b/contrib/perl5/lib/I18N/Collate.pm
@@ -0,0 +1,189 @@
+package I18N::Collate;
+
+=head1 NAME
+
+I18N::Collate - compare 8-bit scalar data according to the current locale
+
+ ***
+
+ WARNING: starting from the Perl version 5.003_06
+ the I18N::Collate interface for comparing 8-bit scalar data
+ according to the current locale
+
+ HAS BEEN DEPRECATED
+
+ That is, please do not use it anymore for any new applications
+ and please migrate the old applications away from it because its
+ functionality was integrated into the Perl core language in the
+ release 5.003_06.
+
+ See the perllocale manual page for further information.
+
+ ***
+
+=head1 SYNOPSIS
+
+ use I18N::Collate;
+ setlocale(LC_COLLATE, 'locale-of-your-choice');
+ $s1 = new I18N::Collate "scalar_data_1";
+ $s2 = new I18N::Collate "scalar_data_2";
+
+=head1 DESCRIPTION
+
+This module provides you with objects that will collate
+according to your national character set, provided that the
+POSIX setlocale() function is supported on your system.
+
+You can compare $s1 and $s2 above with
+
+ $s1 le $s2
+
+to extract the data itself, you'll need a dereference: $$s1
+
+This module uses POSIX::setlocale(). The basic collation conversion is
+done by strxfrm() which terminates at NUL characters being a decent C
+routine. collate_xfrm() handles embedded NUL characters gracefully.
+
+The available locales depend on your operating system; try whether
+C<locale -a> shows them or man pages for "locale" or "nlsinfo" or the
+direct approach C<ls /usr/lib/nls/loc> or C<ls /usr/lib/nls> or
+C<ls /usr/lib/locale>. Not all the locales that your vendor supports
+are necessarily installed: please consult your operating system's
+documentation and possibly your local system administration. The
+locale names are probably something like C<xx_XX.(ISO)?8859-N> or
+C<xx_XX.(ISO)?8859N>, for example C<fr_CH.ISO8859-1> is the Swiss (CH)
+variant of French (fr), ISO Latin (8859) 1 (-1) which is the Western
+European character set.
+
+=cut
+
+# I18N::Collate.pm
+#
+# Author: Jarkko Hietaniemi <F<jhi@iki.fi>>
+# Helsinki University of Technology, Finland
+#
+# Acks: Guy Decoux <F<decoux@moulon.inra.fr>> understood
+# overloading magic much deeper than I and told
+# how to cut the size of this code by more than half.
+# (my first version did overload all of lt gt eq le ge cmp)
+#
+# Purpose: compare 8-bit scalar data according to the current locale
+#
+# Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm()
+#
+# Exports: setlocale 1)
+# collate_xfrm 2)
+#
+# Overloads: cmp # 3)
+#
+# Usage: use I18N::Collate;
+# setlocale(LC_COLLATE, 'locale-of-your-choice'); # 4)
+# $s1 = new I18N::Collate "scalar_data_1";
+# $s2 = new I18N::Collate "scalar_data_2";
+#
+# now you can compare $s1 and $s2: $s1 le $s2
+# to extract the data itself, you need to deref: $$s1
+#
+# Notes:
+# 1) this uses POSIX::setlocale
+# 2) the basic collation conversion is done by strxfrm() which
+# terminates at NUL characters being a decent C routine.
+# collate_xfrm handles embedded NUL characters gracefully.
+# 3) due to cmp and overload magic, lt le eq ge gt work also
+# 4) the available locales depend on your operating system;
+# try whether "locale -a" shows them or man pages for
+# "locale" or "nlsinfo" work or the more direct
+# approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls".
+# Not all the locales that your vendor supports
+# are necessarily installed: please consult your
+# operating system's documentation.
+# The locale names are probably something like
+# 'xx_XX.(ISO)?8859-N' or 'xx_XX.(ISO)?8859N',
+# for example 'fr_CH.ISO8859-1' is the Swiss (CH)
+# variant of French (fr), ISO Latin (8859) 1 (-1)
+# which is the Western European character set.
+#
+# Updated: 19961005
+#
+# ---
+
+use POSIX qw(strxfrm LC_COLLATE);
+
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(collate_xfrm setlocale LC_COLLATE);
+@EXPORT_OK = qw();
+
+use overload qw(
+fallback 1
+cmp collate_cmp
+);
+
+sub new {
+ my $new = $_[1];
+
+ if ($^W && $] >= 5.003_06) {
+ unless ($please_use_I18N_Collate_even_if_deprecated) {
+ warn <<___EOD___;
+***
+
+ WARNING: starting from the Perl version 5.003_06
+ the I18N::Collate interface for comparing 8-bit scalar data
+ according to the current locale
+
+ HAS BEEN DEPRECATED
+
+ That is, please do not use it anymore for any new applications
+ and please migrate the old applications away from it because its
+ functionality was integrated into the Perl core language in the
+ release 5.003_06.
+
+ See the perllocale manual page for further information.
+
+***
+___EOD___
+ $please_use_I18N_Collate_even_if_deprecated++;
+ }
+ }
+
+ bless \$new;
+}
+
+sub setlocale {
+ my ($category, $locale) = @_[0,1];
+
+ POSIX::setlocale($category, $locale) if (defined $category);
+ # the current $LOCALE
+ $LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || '';
+}
+
+sub C {
+ my $s = ${$_[0]};
+
+ $C->{$LOCALE}->{$s} = collate_xfrm($s)
+ unless (defined $C->{$LOCALE}->{$s}); # cache when met
+
+ $C->{$LOCALE}->{$s};
+}
+
+sub collate_xfrm {
+ my $s = $_[0];
+ my $x = '';
+
+ for (split(/(\000+)/, $s)) {
+ $x .= (/^\000/) ? $_ : strxfrm("$_\000");
+ }
+
+ $x;
+}
+
+sub collate_cmp {
+ &C($_[0]) cmp &C($_[1]);
+}
+
+# init $LOCALE
+
+&I18N::Collate::setlocale();
+
+1; # keep require happy
diff --git a/contrib/perl5/lib/IPC/Open2.pm b/contrib/perl5/lib/IPC/Open2.pm
new file mode 100644
index 000000000000..32282d62b39a
--- /dev/null
+++ b/contrib/perl5/lib/IPC/Open2.pm
@@ -0,0 +1,95 @@
+package IPC::Open2;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT);
+
+require 5.000;
+require Exporter;
+
+$VERSION = 1.01;
+@ISA = qw(Exporter);
+@EXPORT = qw(open2);
+
+=head1 NAME
+
+IPC::Open2, open2 - open a process for both reading and writing
+
+=head1 SYNOPSIS
+
+ use IPC::Open2;
+ $pid = open2(\*RDR, \*WTR, 'some cmd and args');
+ # or
+ $pid = open2(\*RDR, \*WTR, 'some', 'cmd', 'and', 'args');
+
+=head1 DESCRIPTION
+
+The open2() function spawns the given $cmd and connects $rdr for
+reading and $wtr for writing. It's what you think should work
+when you try
+
+ open(HANDLE, "|cmd args|");
+
+The write filehandle will have autoflush turned on.
+
+If $rdr is a string (that is, a bareword filehandle rather than a glob
+or a reference) and it begins with ">&", then the child will send output
+directly to that file handle. If $wtr is a string that begins with
+"<&", then WTR will be closed in the parent, and the child will read
+from it directly. In both cases, there will be a dup(2) instead of a
+pipe(2) made.
+
+open2() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open2:/>.
+
+=head1 WARNING
+
+It will not create these file handles for you. You have to do this yourself.
+So don't pass it empty variables expecting them to get filled in for you.
+
+Additionally, this is very dangerous as you may block forever.
+It assumes it's going to talk to something like B<bc>, both writing to
+it and reading from it. This is presumably safe because you "know"
+that commands like B<bc> will read a line at a time and output a line at
+a time. Programs like B<sort> that read their entire input stream first,
+however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the child process, you can't control
+what it does with pipe buffering. Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+=head1 SEE ALSO
+
+See L<IPC::Open3> for an alternative that handles STDERR as well. This
+function is really just a wrapper around open3().
+
+=cut
+
+# &open2: tom christiansen, <tchrist@convex.com>
+#
+# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
+# or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+#
+# spawn the given $cmd and connect $rdr for
+# reading and $wtr for writing. return pid
+# of child, or 0 on failure.
+#
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# a system call fails
+
+require IPC::Open3;
+
+sub open2 {
+ my ($read, $write, @cmd) = @_;
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+ return IPC::Open3::_open3('open2', scalar caller,
+ $write, $read, '>&STDERR', @cmd);
+}
+
+1
diff --git a/contrib/perl5/lib/IPC/Open3.pm b/contrib/perl5/lib/IPC/Open3.pm
new file mode 100644
index 000000000000..f1415e3ad674
--- /dev/null
+++ b/contrib/perl5/lib/IPC/Open3.pm
@@ -0,0 +1,292 @@
+package IPC::Open3;
+
+use strict;
+no strict 'refs'; # because users pass me bareword filehandles
+use vars qw($VERSION @ISA @EXPORT $Fh $Me);
+
+require 5.001;
+require Exporter;
+
+use Carp;
+use Symbol 'qualify';
+
+$VERSION = 1.0102;
+@ISA = qw(Exporter);
+@EXPORT = qw(open3);
+
+=head1 NAME
+
+IPC::Open3, open3 - open a process for reading, writing, and error handling
+
+=head1 SYNOPSIS
+
+ $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH,
+ 'some cmd and args', 'optarg', ...);
+
+=head1 DESCRIPTION
+
+Extremely similar to open2(), open3() spawns the given $cmd and
+connects RDRFH for reading, WTRFH for writing, and ERRFH for errors. If
+ERRFH is '', or the same as RDRFH, then STDOUT and STDERR of the child are
+on the same file handle. The WTRFH will have autoflush turned on.
+
+If WTRFH begins with "E<lt>&", then WTRFH will be closed in the parent, and
+the child will read from it directly. If RDRFH or ERRFH begins with
+"E<gt>&", then the child will send output directly to that file handle.
+In both cases, there will be a dup(2) instead of a pipe(2) made.
+
+If you try to read from the child's stdout writer and their stderr
+writer, you'll have problems with blocking, which means you'll
+want to use select(), which means you'll have to use sysread() instead
+of normal stuff.
+
+open3() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open3:/>.
+
+=head1 WARNING
+
+It will not create these file handles for you. You have to do this
+yourself. So don't pass it empty variables expecting them to get filled
+in for you.
+
+Additionally, this is very dangerous as you may block forever. It
+assumes it's going to talk to something like B<bc>, both writing to it
+and reading from it. This is presumably safe because you "know" that
+commands like B<bc> will read a line at a time and output a line at a
+time. Programs like B<sort> that read their entire input stream first,
+however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the child process, you can't control
+what it does with pipe buffering. Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+=cut
+
+# &open3: Marc Horowitz <marc@mit.edu>
+# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
+# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
+# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
+#
+# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
+#
+# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
+#
+# spawn the given $cmd and connect rdr for
+# reading, wtr for writing, and err for errors.
+# if err is '', or the same as rdr, then stdout and
+# stderr of the child are on the same fh. returns pid
+# of child (or dies on failure).
+
+
+# if wtr begins with '<&', then wtr will be closed in the parent, and
+# the child will read from it directly. if rdr or err begins with
+# '>&', then the child will send output directly to that fd. In both
+# cases, there will be a dup() instead of a pipe() made.
+
+
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# a system call fails
+
+$Fh = 'FHOPEN000'; # package static in case called more than once
+$Me = 'open3 (bug)'; # you should never see this, it's always localized
+
+# Fatal.pm needs to be fixed WRT prototypes.
+
+sub xfork {
+ my $pid = fork;
+ defined $pid or croak "$Me: fork failed: $!";
+ return $pid;
+}
+
+sub xpipe {
+ pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
+}
+
+# I tried using a * prototype character for the filehandle but it still
+# disallows a bearword while compiling under strict subs.
+
+sub xopen {
+ open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
+}
+
+sub xclose {
+ close $_[0] or croak "$Me: close($_[0]) failed: $!";
+}
+
+my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
+
+sub _open3 {
+ local $Me = shift;
+ my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
+ my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
+
+ $dad_wtr or croak "$Me: wtr should not be null";
+ $dad_rdr or croak "$Me: rdr should not be null";
+ $dad_err = $dad_rdr if ($dad_err eq '');
+
+ $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
+ $dup_rdr = ($dad_rdr =~ s/^[<>]&//);
+ $dup_err = ($dad_err =~ s/^[<>]&//);
+
+ # force unqualified filehandles into callers' package
+ $dad_wtr = qualify $dad_wtr, $package;
+ $dad_rdr = qualify $dad_rdr, $package;
+ $dad_err = qualify $dad_err, $package;
+
+ my $kid_rdr = ++$Fh;
+ my $kid_wtr = ++$Fh;
+ my $kid_err = ++$Fh;
+
+ xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
+ xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
+ xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
+
+ $kidpid = $do_spawn ? -1 : xfork;
+ if ($kidpid == 0) { # Kid
+ # If she wants to dup the kid's stderr onto her stdout I need to
+ # save a copy of her stdout before I put something else there.
+ if ($dad_rdr ne $dad_err && $dup_err
+ && fileno($dad_err) == fileno(STDOUT)) {
+ my $tmp = ++$Fh;
+ xopen($tmp, ">&$dad_err");
+ $dad_err = $tmp;
+ }
+
+ if ($dup_wtr) {
+ xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr);
+ } else {
+ xclose $dad_wtr;
+ xopen \*STDIN, "<&$kid_rdr";
+ xclose $kid_rdr;
+ }
+ if ($dup_rdr) {
+ xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr);
+ } else {
+ xclose $dad_rdr;
+ xopen \*STDOUT, ">&$kid_wtr";
+ xclose $kid_wtr;
+ }
+ if ($dad_rdr ne $dad_err) {
+ if ($dup_err) {
+ xopen \*STDERR, ">&$dad_err"
+ if fileno(STDERR) != fileno($dad_err);
+ } else {
+ xclose $dad_err;
+ xopen \*STDERR, ">&$kid_err";
+ xclose $kid_err;
+ }
+ } else {
+ xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
+ }
+ local($")=(" ");
+ exec @cmd
+ or croak "$Me: exec of @cmd failed";
+ } elsif ($do_spawn) {
+ # All the bookkeeping of coincidence between handles is
+ # handled in spawn_with_handles.
+
+ my @close;
+ if ($dup_wtr) {
+ $kid_rdr = $dad_wtr;
+ push @close, \*{$kid_rdr};
+ } else {
+ push @close, \*{$dad_wtr}, \*{$kid_rdr};
+ }
+ if ($dup_rdr) {
+ $kid_wtr = $dad_rdr;
+ push @close, \*{$kid_wtr};
+ } else {
+ push @close, \*{$dad_rdr}, \*{$kid_wtr};
+ }
+ if ($dad_rdr ne $dad_err) {
+ if ($dup_err) {
+ $kid_err = $dad_err ;
+ push @close, \*{$kid_err};
+ } else {
+ push @close, \*{$dad_err}, \*{$kid_err};
+ }
+ } else {
+ $kid_err = $kid_wtr;
+ }
+ require IO::Pipe;
+ $kidpid = eval {
+ spawn_with_handles( [ { mode => 'r',
+ open_as => \*{$kid_rdr},
+ handle => \*STDIN },
+ { mode => 'w',
+ open_as => \*{$kid_wtr},
+ handle => \*STDOUT },
+ { mode => 'w',
+ open_as => \*{$kid_err},
+ handle => \*STDERR },
+ ], \@close, @cmd);
+ };
+ die "$Me: $@" if $@;
+ }
+
+ xclose $kid_rdr if !$dup_wtr;
+ xclose $kid_wtr if !$dup_rdr;
+ xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
+ # If the write handle is a dup give it away entirely, close my copy
+ # of it.
+ xclose $dad_wtr if $dup_wtr;
+
+ select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
+ $kidpid;
+}
+
+sub open3 {
+ if (@_ < 4) {
+ local $" = ', ';
+ croak "open3(@_): not enough arguments";
+ }
+ return _open3 'open3', scalar caller, @_
+}
+
+sub spawn_with_handles {
+ my $fds = shift; # Fields: handle, mode, open_as
+ my $close_in_child = shift;
+ my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
+ require Fcntl;
+
+ foreach $fd (@$fds) {
+ $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
+ $saved{fileno $fd->{handle}} = $fd->{tmp_copy};
+ }
+ foreach $fd (@$fds) {
+ bless $fd->{handle}, 'IO::Handle'
+ unless eval { $fd->{handle}->isa('IO::Handle') } ;
+ # If some of handles to redirect-to coincide with handles to
+ # redirect, we need to use saved variants:
+ $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as},
+ $fd->{mode});
+ }
+ unless ($^O eq 'MSWin32') {
+ # Stderr may be redirected below, so we save the err text:
+ foreach $fd (@$close_in_child) {
+ fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
+ unless $saved{fileno $fd}; # Do not close what we redirect!
+ }
+ }
+
+ unless (@errs) {
+ $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
+ push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
+ }
+
+ foreach $fd (@$fds) {
+ $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
+ $fd->{tmp_copy}->close or croak "Can't close: $!";
+ }
+ croak join "\n", @errs if @errs;
+ return $pid;
+}
+
+1; # so require is happy
diff --git a/contrib/perl5/lib/Math/BigFloat.pm b/contrib/perl5/lib/Math/BigFloat.pm
new file mode 100644
index 000000000000..576f3410c78b
--- /dev/null
+++ b/contrib/perl5/lib/Math/BigFloat.pm
@@ -0,0 +1,327 @@
+package Math::BigFloat;
+
+use Math::BigInt;
+
+use Exporter; # just for use to be happy
+@ISA = (Exporter);
+
+use overload
+'+' => sub {new Math::BigFloat &fadd},
+'-' => sub {new Math::BigFloat
+ $_[2]? fsub($_[1],${$_[0]}) : fsub(${$_[0]},$_[1])},
+'<=>' => sub {new Math::BigFloat
+ $_[2]? fcmp($_[1],${$_[0]}) : fcmp(${$_[0]},$_[1])},
+'cmp' => sub {new Math::BigFloat
+ $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
+'*' => sub {new Math::BigFloat &fmul},
+'/' => sub {new Math::BigFloat
+ $_[2]? scalar fdiv($_[1],${$_[0]}) :
+ scalar fdiv(${$_[0]},$_[1])},
+'neg' => sub {new Math::BigFloat &fneg},
+'abs' => sub {new Math::BigFloat &fabs},
+
+qw(
+"" stringify
+0+ numify) # Order of arguments unsignificant
+;
+
+sub new {
+ my ($class) = shift;
+ my ($foo) = fnorm(shift);
+ panic("Not a number initialized to Math::BigFloat") if $foo eq "NaN";
+ bless \$foo, $class;
+}
+sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
+ # comparing to direct compilation based on
+ # stringify
+sub stringify {
+ my $n = ${$_[0]};
+
+ my $minus = ($n =~ s/^([+-])// && $1 eq '-');
+ $n =~ s/E//;
+
+ $n =~ s/([-+]\d+)$//;
+
+ my $e = $1;
+ my $ln = length($n);
+
+ if ($e > 0) {
+ $n .= "0" x $e . '.';
+ } elsif (abs($e) < $ln) {
+ substr($n, $ln + $e, 0) = '.';
+ } else {
+ $n = '.' . ("0" x (abs($e) - $ln)) . $n;
+ }
+ $n = "-$n" if $minus;
+
+ # 1 while $n =~ s/(.*\d)(\d\d\d)/$1,$2/;
+
+ return $n;
+}
+
+$div_scale = 40;
+
+# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
+
+$rnd_mode = 'even';
+
+sub fadd; sub fsub; sub fmul; sub fdiv;
+sub fneg; sub fabs; sub fcmp;
+sub fround; sub ffround;
+sub fnorm; sub fsqrt;
+
+# Convert a number to canonical string form.
+# Takes something that looks like a number and converts it to
+# the form /^[+-]\d+E[+-]\d+$/.
+sub fnorm { #(string) return fnum_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') {
+ &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6));
+ } else {
+ 'NaN';
+ }
+}
+
+# normalize number -- for internal use
+sub norm { #(mantissa, exponent) return fnum_str
+ local($_, $exp) = @_;
+ if ($_ eq 'NaN') {
+ 'NaN';
+ } else {
+ s/^([+-])0+/$1/; # strip leading zeros
+ if (length($_) == 1) {
+ '+0E+0';
+ } else {
+ $exp += length($1) if (s/(0+)$//); # strip trailing zeros
+ sprintf("%sE%+ld", $_, $exp);
+ }
+ }
+}
+
+# negation
+sub fneg { #(fnum_str) return fnum_str
+ local($_) = fnorm($_[$[]);
+ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
+ s/^H/N/;
+ $_;
+}
+
+# absolute value
+sub fabs { #(fnum_str) return fnum_str
+ local($_) = fnorm($_[$[]);
+ s/^-/+/; # mash sign
+ $_;
+}
+
+# multiplication
+sub fmul { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ &norm(Math::BigInt::bmul($xm,$ym),$xe+$ye);
+ }
+}
+
+# addition
+sub fadd { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (fnorm($_[$[]),fnorm($_[$[+1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
+ &norm(Math::BigInt::badd($ym,$xm.('0' x ($xe-$ye))),$ye);
+ }
+}
+
+# subtraction
+sub fsub { #(fnum_str, fnum_str) return fnum_str
+ fadd($_[$[],fneg($_[$[+1]));
+}
+
+# division
+# args are dividend, divisor, scale (optional)
+# result has at most max(scale, length(dividend), length(divisor)) digits
+sub fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
+{
+ local($x,$y,$scale) = (fnorm($_[$[]),fnorm($_[$[+1]),$_[$[+2]);
+ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if (length($xm)-1 > $scale);
+ $scale = length($ym)-1 if (length($ym)-1 > $scale);
+ $scale = $scale + length($ym) - length($xm);
+ &norm(&round(Math::BigInt::bdiv($xm.('0' x $scale),$ym),$ym),
+ $xe-$ye-$scale);
+ }
+}
+
+# round int $q based on fraction $r/$base using $rnd_mode
+sub round { #(int_str, int_str, int_str) return int_str
+ local($q,$r,$base) = @_;
+ if ($q eq 'NaN' || $r eq 'NaN') {
+ 'NaN';
+ } elsif ($rnd_mode eq 'trunc') {
+ $q; # just truncate
+ } else {
+ local($cmp) = Math::BigInt::bcmp(Math::BigInt::bmul($r,'+2'),$base);
+ if ( $cmp < 0 ||
+ ($cmp == 0 &&
+ ( $rnd_mode eq 'zero' ||
+ ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) ||
+ ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) ||
+ ($rnd_mode eq 'even' && $q =~ /[24680]$/) ||
+ ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) {
+ $q; # round down
+ } else {
+ Math::BigInt::badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1'));
+ # round up
+ }
+ }
+}
+
+# round the mantissa of $x to $scale digits
+sub fround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (fnorm($_[$[]),$_[$[+1]);
+ if ($x eq 'NaN' || $scale <= 0) {
+ $x;
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if (length($xm)-1 <= $scale) {
+ $x;
+ } else {
+ &norm(&round(substr($xm,$[,$scale+1),
+ "+0".substr($xm,$[+$scale+1,1),"+10"),
+ $xe+length($xm)-$scale-1);
+ }
+ }
+}
+
+# round $x at the 10 to the $scale digit place
+sub ffround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (fnorm($_[$[]),$_[$[+1]);
+ if ($x eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if ($xe >= $scale) {
+ $x;
+ } else {
+ $xe = length($xm)+$xe-$scale;
+ if ($xe < 1) {
+ '+0E+0';
+ } elsif ($xe == 1) {
+ &norm(&round('+0',"+0".substr($xm,$[+1,1),"+10"), $scale);
+ } else {
+ &norm(&round(substr($xm,$[,$xe),
+ "+0".substr($xm,$[+$xe,1),"+10"), $scale);
+ }
+ }
+ }
+}
+
+# compare 2 values returns one of undef, <0, =0, >0
+# returns undef if either or both input value are not numbers
+sub fcmp #(fnum_str, fnum_str) return cond_code
+{
+ local($x, $y) = (fnorm($_[$[]),fnorm($_[$[+1]));
+ if ($x eq "NaN" || $y eq "NaN") {
+ undef;
+ } else {
+ ord($y) <=> ord($x)
+ ||
+ ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
+ (($xe <=> $ye) * (substr($x,$[,1).'1')
+ || Math::BigInt::cmp($xm,$ym))
+ );
+ }
+}
+
+# square root by Newtons method.
+sub fsqrt { #(fnum_str[, scale]) return fnum_str
+ local($x, $scale) = (fnorm($_[$[]), $_[$[+1]);
+ if ($x eq 'NaN' || $x =~ /^-/) {
+ 'NaN';
+ } elsif ($x eq '+0E+0') {
+ '+0E+0';
+ } else {
+ local($xm, $xe) = split('E',$x);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if ($scale < length($xm)-1);
+ local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
+ while ($gs < 2*$scale) {
+ $guess = fmul(fadd($guess,fdiv($x,$guess,$gs*2)),".5");
+ $gs *= 2;
+ }
+ new Math::BigFloat &fround($guess, $scale);
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Math::BigFloat - Arbitrary length float math package
+
+=head1 SYNOPSIS
+
+ use Math::BigFloat;
+ $f = Math::BigFloat->new($string);
+
+ $f->fadd(NSTR) return NSTR addition
+ $f->fsub(NSTR) return NSTR subtraction
+ $f->fmul(NSTR) return NSTR multiplication
+ $f->fdiv(NSTR[,SCALE]) returns NSTR division to SCALE places
+ $f->fneg() return NSTR negation
+ $f->fabs() return NSTR absolute value
+ $f->fcmp(NSTR) return CODE compare undef,<0,=0,>0
+ $f->fround(SCALE) return NSTR round to SCALE digits
+ $f->ffround(SCALE) return NSTR round at SCALEth place
+ $f->fnorm() return (NSTR) normalize
+ $f->fsqrt([SCALE]) return NSTR sqrt to SCALE places
+
+=head1 DESCRIPTION
+
+All basic math operations are overloaded if you declare your big
+floats as
+
+ $float = new Math::BigFloat "2.123123123123123123123123123123123";
+
+=over 2
+
+=item number format
+
+canonical strings have the form /[+-]\d+E[+-]\d+/ . Input values can
+have inbedded whitespace.
+
+=item Error returns 'NaN'
+
+An input parameter was "Not a Number" or divide by zero or sqrt of
+negative number.
+
+=item Division is computed to
+
+C<max($div_scale,length(dividend)+length(divisor))> digits by default.
+Also used for default sqrt scale.
+
+=back
+
+=head1 BUGS
+
+The current version of this module is a preliminary version of the
+real thing that is currently (as of perl5.002) under development.
+
+=head1 AUTHOR
+
+Mark Biggar
+
+=cut
diff --git a/contrib/perl5/lib/Math/BigInt.pm b/contrib/perl5/lib/Math/BigInt.pm
new file mode 100644
index 000000000000..ef4af613c31f
--- /dev/null
+++ b/contrib/perl5/lib/Math/BigInt.pm
@@ -0,0 +1,415 @@
+package Math::BigInt;
+
+use overload
+'+' => sub {new Math::BigInt &badd},
+'-' => sub {new Math::BigInt
+ $_[2]? bsub($_[1],${$_[0]}) : bsub(${$_[0]},$_[1])},
+'<=>' => sub {new Math::BigInt
+ $_[2]? bcmp($_[1],${$_[0]}) : bcmp(${$_[0]},$_[1])},
+'cmp' => sub {new Math::BigInt
+ $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
+'*' => sub {new Math::BigInt &bmul},
+'/' => sub {new Math::BigInt
+ $_[2]? scalar bdiv($_[1],${$_[0]}) :
+ scalar bdiv(${$_[0]},$_[1])},
+'%' => sub {new Math::BigInt
+ $_[2]? bmod($_[1],${$_[0]}) : bmod(${$_[0]},$_[1])},
+'**' => sub {new Math::BigInt
+ $_[2]? bpow($_[1],${$_[0]}) : bpow(${$_[0]},$_[1])},
+'neg' => sub {new Math::BigInt &bneg},
+'abs' => sub {new Math::BigInt &babs},
+
+qw(
+"" stringify
+0+ numify) # Order of arguments unsignificant
+;
+
+$NaNOK=1;
+
+sub new {
+ my($class) = shift;
+ my($foo) = bnorm(shift);
+ die "Not a number initialized to Math::BigInt" if !$NaNOK && $foo eq "NaN";
+ bless \$foo, $class;
+}
+sub stringify { "${$_[0]}" }
+sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
+ # comparing to direct compilation based on
+ # stringify
+sub import {
+ shift;
+ return unless @_;
+ die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
+ overload::constant integer => sub {Math::BigInt->new(shift)};
+}
+
+$zero = 0;
+
+
+# normalize string form of number. Strip leading zeros. Strip any
+# white space and add a sign, if missing.
+# Strings that are not numbers result the value 'NaN'.
+
+sub bnorm { #(num_str) return num_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number
+ substr($_,$[,0) = '+' unless $1; # Add missing sign
+ s/^-0/+0/;
+ $_;
+ } else {
+ 'NaN';
+ }
+}
+
+# Convert a number from string format to internal base 100000 format.
+# Assumes normalized value as input.
+sub internal { #(num_str) return int_num_array
+ local($d) = @_;
+ ($is,$il) = (substr($d,$[,1),length($d)-2);
+ substr($d,$[,1) = '';
+ ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
+}
+
+# Convert a number from internal base 100000 format to string format.
+# This routine scribbles all over input array.
+sub external { #(int_num_array) return num_str
+ $es = shift;
+ grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad
+ &bnorm(join('', $es, reverse(@_))); # reverse concat and normalize
+}
+
+# Negate input value.
+sub bneg { #(num_str) return num_str
+ local($_) = &bnorm(@_);
+ return $_ if $_ eq '+0' or $_ eq 'NaN';
+ vec($_,0,8) ^= ord('+') ^ ord('-');
+ $_;
+}
+
+# Returns the absolute value of the input.
+sub babs { #(num_str) return num_str
+ &abs(&bnorm(@_));
+}
+
+sub abs { # post-normalized abs for internal use
+ local($_) = @_;
+ s/^-/+/;
+ $_;
+}
+
+# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
+sub bcmp { #(num_str, num_str) return cond_code
+ local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1]));
+ if ($x eq 'NaN') {
+ undef;
+ } elsif ($y eq 'NaN') {
+ undef;
+ } else {
+ &cmp($x,$y) <=> 0;
+ }
+}
+
+sub cmp { # post-normalized compare for internal use
+ local($cx, $cy) = @_;
+
+ return 0 if ($cx eq $cy);
+
+ local($sx, $sy) = (substr($cx, 0, 1), substr($cy, 0, 1));
+ local($ld);
+
+ if ($sx eq '+') {
+ return 1 if ($sy eq '-' || $cy eq '+0');
+ $ld = length($cx) - length($cy);
+ return $ld if ($ld);
+ return $cx cmp $cy;
+ } else { # $sx eq '-'
+ return -1 if ($sy eq '+');
+ $ld = length($cy) - length($cx);
+ return $ld if ($ld);
+ return $cy cmp $cx;
+ }
+}
+
+sub badd { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&bnorm($_[$[]),&bnorm($_[$[+1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } else {
+ @x = &internal($x); # convert to internal form
+ @y = &internal($y);
+ local($sx, $sy) = (shift @x, shift @y); # get signs
+ if ($sx eq $sy) {
+ &external($sx, &add(*x, *y)); # if same sign add
+ } else {
+ ($x, $y) = (&abs($x),&abs($y)); # make abs
+ if (&cmp($y,$x) > 0) {
+ &external($sy, &sub(*y, *x));
+ } else {
+ &external($sx, &sub(*x, *y));
+ }
+ }
+ }
+}
+
+sub bsub { #(num_str, num_str) return num_str
+ &badd($_[$[],&bneg($_[$[+1]));
+}
+
+# GCD -- Euclids algorithm Knuth Vol 2 pg 296
+sub bgcd { #(num_str, num_str) return num_str
+ local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ ($x, $y) = ($y,&bmod($x,$y)) while $y ne '+0';
+ $x;
+ }
+}
+
+# routine to add two base 1e5 numbers
+# stolen from Knuth Vol 2 Algorithm A pg 231
+# there are separate routines to add and sub as per Kunth pg 233
+sub add { #(int_num_array, int_num_array) return int_num_array
+ local(*x, *y) = @_;
+ $car = 0;
+ for $x (@x) {
+ last unless @y || $car;
+ $x -= 1e5 if $car = (($x += (@y ? shift(@y) : 0) + $car) >= 1e5) ? 1 : 0;
+ }
+ for $y (@y) {
+ last unless $car;
+ $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0;
+ }
+ (@x, @y, $car);
+}
+
+# subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
+sub sub { #(int_num_array, int_num_array) return int_num_array
+ local(*sx, *sy) = @_;
+ $bar = 0;
+ for $sx (@sx) {
+ last unless @sy || $bar;
+ $sx += 1e5 if $bar = (($sx -= (@sy ? shift(@sy) : 0) + $bar) < 0);
+ }
+ @sx;
+}
+
+# multiply two numbers -- stolen from Knuth Vol 2 pg 233
+sub bmul { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } else {
+ @x = &internal($x);
+ @y = &internal($y);
+ &external(&mul(*x,*y));
+ }
+}
+
+# multiply two numbers in internal representation
+# destroys the arguments, supposes that two arguments are different
+sub mul { #(*int_num_array, *int_num_array) return int_num_array
+ local(*x, *y) = (shift, shift);
+ local($signr) = (shift @x ne shift @y) ? '-' : '+';
+ @prod = ();
+ for $x (@x) {
+ ($car, $cty) = (0, $[);
+ for $y (@y) {
+ $prod = $x * $y + ($prod[$cty] || 0) + $car;
+ $prod[$cty++] =
+ $prod - ($car = int($prod * 1e-5)) * 1e5;
+ }
+ $prod[$cty] += $car if $car;
+ $x = shift @prod;
+ }
+ ($signr, @x, @prod);
+}
+
+# modulus
+sub bmod { #(num_str, num_str) return num_str
+ (&bdiv(@_))[$[+1];
+}
+
+sub bdiv { #(dividend: num_str, divisor: num_str) return num_str
+ local (*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1]));
+ return wantarray ? ('NaN','NaN') : 'NaN'
+ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
+ return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
+ @x = &internal($x); @y = &internal($y);
+ $srem = $y[$[];
+ $sr = (shift @x ne shift @y) ? '-' : '+';
+ $car = $bar = $prd = 0;
+ if (($dd = int(1e5/($y[$#y]+1))) != 1) {
+ for $x (@x) {
+ $x = $x * $dd + $car;
+ $x -= ($car = int($x * 1e-5)) * 1e5;
+ }
+ push(@x, $car); $car = 0;
+ for $y (@y) {
+ $y = $y * $dd + $car;
+ $y -= ($car = int($y * 1e-5)) * 1e5;
+ }
+ }
+ else {
+ push(@x, 0);
+ }
+ @q = (); ($v2,$v1) = @y[-2,-1];
+ while ($#x > $#y) {
+ ($u2,$u1,$u0) = @x[-3..-1];
+ $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2);
+ if ($q) {
+ ($car, $bar) = (0,0);
+ for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
+ $prd = $q * $y[$y] + $car;
+ $prd -= ($car = int($prd * 1e-5)) * 1e5;
+ $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0));
+ }
+ if ($x[$#x] < $car + $bar) {
+ $car = 0; --$q;
+ for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
+ $x[$x] -= 1e5
+ if ($car = (($x[$x] += $y[$y] + $car) > 1e5));
+ }
+ }
+ }
+ pop(@x); unshift(@q, $q);
+ }
+ if (wantarray) {
+ @d = ();
+ if ($dd != 1) {
+ $car = 0;
+ for $x (reverse @x) {
+ $prd = $car * 1e5 + $x;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd;
+ unshift(@d, $tmp);
+ }
+ }
+ else {
+ @d = @x;
+ }
+ (&external($sr, @q), &external($srem, @d, $zero));
+ } else {
+ &external($sr, @q);
+ }
+}
+
+# compute power of two numbers -- stolen from Knuth Vol 2 pg 233
+sub bpow { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } elsif ($x eq '+1') {
+ '+1';
+ } elsif ($x eq '-1') {
+ &bmod($x,2) ? '-1': '+1';
+ } elsif ($y =~ /^-/) {
+ 'NaN';
+ } elsif ($x eq '+0' && $y eq '+0') {
+ 'NaN';
+ } else {
+ @x = &internal($x);
+ local(@pow2)=@x;
+ local(@pow)=&internal("+1");
+ local($y1,$res,@tmp1,@tmp2)=(1); # need tmp to send to mul
+ while ($y ne '+0') {
+ ($y,$res)=&bdiv($y,2);
+ if ($res ne '+0') {@tmp=@pow2; @pow=&mul(*pow,*tmp);}
+ if ($y ne '+0') {@tmp=@pow2;@pow2=&mul(*pow2,*tmp);}
+ }
+ &external(@pow);
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Math::BigInt - Arbitrary size integer math package
+
+=head1 SYNOPSIS
+
+ use Math::BigInt;
+ $i = Math::BigInt->new($string);
+
+ $i->bneg return BINT negation
+ $i->babs return BINT absolute value
+ $i->bcmp(BINT) return CODE compare numbers (undef,<0,=0,>0)
+ $i->badd(BINT) return BINT addition
+ $i->bsub(BINT) return BINT subtraction
+ $i->bmul(BINT) return BINT multiplication
+ $i->bdiv(BINT) return (BINT,BINT) division (quo,rem) just quo if scalar
+ $i->bmod(BINT) return BINT modulus
+ $i->bgcd(BINT) return BINT greatest common divisor
+ $i->bnorm return BINT normalization
+
+=head1 DESCRIPTION
+
+All basic math operations are overloaded if you declare your big
+integers as
+
+ $i = new Math::BigInt '123 456 789 123 456 789';
+
+
+=over 2
+
+=item Canonical notation
+
+Big integer value are strings of the form C</^[+-]\d+$/> with leading
+zeros suppressed.
+
+=item Input
+
+Input values to these routines may be strings of the form
+C</^\s*[+-]?[\d\s]+$/>.
+
+=item Output
+
+Output values always always in canonical form
+
+=back
+
+Actual math is done in an internal format consisting of an array
+whose first element is the sign (/^[+-]$/) and whose remaining
+elements are base 100000 digits with the least significant digit first.
+The string 'NaN' is used to represent the result when input arguments
+are not numbers, as well as the result of dividing by zero.
+
+=head1 EXAMPLES
+
+ '+0' canonical zero value
+ ' -123 123 123' canonical value '-123123123'
+ '1 23 456 7890' canonical value '+1234567890'
+
+
+=head1 Autocreating constants
+
+After C<use Math::BigInt ':constant'> all the integer decimal constants
+in the given scope are converted to C<Math::BigInt>. This conversion
+happens at compile time.
+
+In particular
+
+ perl -MMath::BigInt=:constant -e 'print 2**100'
+
+print the integer value of C<2**100>. Note that without convertion of
+constants the expression 2**100 will be calculatted as floating point number.
+
+=head1 BUGS
+
+The current version of this module is a preliminary version of the
+real thing that is currently (as of perl5.002) under development.
+
+=head1 AUTHOR
+
+Mark Biggar, overloaded interface by Ilya Zakharevich.
+
+=cut
diff --git a/contrib/perl5/lib/Math/Complex.pm b/contrib/perl5/lib/Math/Complex.pm
new file mode 100644
index 000000000000..e711c1483d9e
--- /dev/null
+++ b/contrib/perl5/lib/Math/Complex.pm
@@ -0,0 +1,1775 @@
+#
+# Complex numbers and associated mathematical functions
+# -- Raphael Manfredi Since Sep 1996
+# -- Jarkko Hietaniemi Since Mar 1997
+# -- Daniel S. Lewart Since Sep 1997
+#
+
+require Exporter;
+package Math::Complex;
+
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS);
+
+my ( $i, $ip2, %logn );
+
+$VERSION = sprintf("%s", q$Id: Complex.pm,v 1.25 1998/02/05 16:07:37 jhi Exp $ =~ /(\d+\.\d+)/);
+
+@ISA = qw(Exporter);
+
+my @trig = qw(
+ pi
+ tan
+ csc cosec sec cot cotan
+ asin acos atan
+ acsc acosec asec acot acotan
+ sinh cosh tanh
+ csch cosech sech coth cotanh
+ asinh acosh atanh
+ acsch acosech asech acoth acotanh
+ );
+
+@EXPORT = (qw(
+ i Re Im rho theta arg
+ sqrt log ln
+ log10 logn cbrt root
+ cplx cplxe
+ ),
+ @trig);
+
+%EXPORT_TAGS = (
+ 'trig' => [@trig],
+);
+
+use overload
+ '+' => \&plus,
+ '-' => \&minus,
+ '*' => \&multiply,
+ '/' => \&divide,
+ '**' => \&power,
+ '<=>' => \&spaceship,
+ 'neg' => \&negate,
+ '~' => \&conjugate,
+ 'abs' => \&abs,
+ 'sqrt' => \&sqrt,
+ 'exp' => \&exp,
+ 'log' => \&log,
+ 'sin' => \&sin,
+ 'cos' => \&cos,
+ 'tan' => \&tan,
+ 'atan2' => \&atan2,
+ qw("" stringify);
+
+#
+# Package "privates"
+#
+
+my $package = 'Math::Complex'; # Package name
+my $display = 'cartesian'; # Default display format
+my $eps = 1e-14; # Epsilon
+
+#
+# Object attributes (internal):
+# cartesian [real, imaginary] -- cartesian form
+# polar [rho, theta] -- polar form
+# c_dirty cartesian form not up-to-date
+# p_dirty polar form not up-to-date
+# display display format (package's global when not set)
+#
+
+# Die on bad *make() arguments.
+
+sub _cannot_make {
+ die "@{[(caller(1))[3]]}: Cannot take $_[0] of $_[1].\n";
+}
+
+#
+# ->make
+#
+# Create a new complex number (cartesian form)
+#
+sub make {
+ my $self = bless {}, shift;
+ my ($re, $im) = @_;
+ my $rre = ref $re;
+ if ( $rre ) {
+ if ( $rre eq ref $self ) {
+ $re = Re($re);
+ } else {
+ _cannot_make("real part", $rre);
+ }
+ }
+ my $rim = ref $im;
+ if ( $rim ) {
+ if ( $rim eq ref $self ) {
+ $im = Im($im);
+ } else {
+ _cannot_make("imaginary part", $rim);
+ }
+ }
+ $self->{'cartesian'} = [ $re, $im ];
+ $self->{c_dirty} = 0;
+ $self->{p_dirty} = 1;
+ $self->display_format('cartesian');
+ return $self;
+}
+
+#
+# ->emake
+#
+# Create a new complex number (exponential form)
+#
+sub emake {
+ my $self = bless {}, shift;
+ my ($rho, $theta) = @_;
+ my $rrh = ref $rho;
+ if ( $rrh ) {
+ if ( $rrh eq ref $self ) {
+ $rho = rho($rho);
+ } else {
+ _cannot_make("rho", $rrh);
+ }
+ }
+ my $rth = ref $theta;
+ if ( $rth ) {
+ if ( $rth eq ref $self ) {
+ $theta = theta($theta);
+ } else {
+ _cannot_make("theta", $rth);
+ }
+ }
+ if ($rho < 0) {
+ $rho = -$rho;
+ $theta = ($theta <= 0) ? $theta + pi() : $theta - pi();
+ }
+ $self->{'polar'} = [$rho, $theta];
+ $self->{p_dirty} = 0;
+ $self->{c_dirty} = 1;
+ $self->display_format('polar');
+ return $self;
+}
+
+sub new { &make } # For backward compatibility only.
+
+#
+# cplx
+#
+# Creates a complex number from a (re, im) tuple.
+# This avoids the burden of writing Math::Complex->make(re, im).
+#
+sub cplx {
+ my ($re, $im) = @_;
+ return $package->make($re, defined $im ? $im : 0);
+}
+
+#
+# cplxe
+#
+# Creates a complex number from a (rho, theta) tuple.
+# This avoids the burden of writing Math::Complex->emake(rho, theta).
+#
+sub cplxe {
+ my ($rho, $theta) = @_;
+ return $package->emake($rho, defined $theta ? $theta : 0);
+}
+
+#
+# pi
+#
+# The number defined as pi = 180 degrees
+#
+use constant pi => 4 * CORE::atan2(1, 1);
+
+#
+# pit2
+#
+# The full circle
+#
+use constant pit2 => 2 * pi;
+
+#
+# pip2
+#
+# The quarter circle
+#
+use constant pip2 => pi / 2;
+
+#
+# deg1
+#
+# One degree in radians, used in stringify_polar.
+#
+
+use constant deg1 => pi / 180;
+
+#
+# uplog10
+#
+# Used in log10().
+#
+use constant uplog10 => 1 / CORE::log(10);
+
+#
+# i
+#
+# The number defined as i*i = -1;
+#
+sub i () {
+ return $i if ($i);
+ $i = bless {};
+ $i->{'cartesian'} = [0, 1];
+ $i->{'polar'} = [1, pip2];
+ $i->{c_dirty} = 0;
+ $i->{p_dirty} = 0;
+ return $i;
+}
+
+#
+# Attribute access/set routines
+#
+
+sub cartesian {$_[0]->{c_dirty} ?
+ $_[0]->update_cartesian : $_[0]->{'cartesian'}}
+sub polar {$_[0]->{p_dirty} ?
+ $_[0]->update_polar : $_[0]->{'polar'}}
+
+sub set_cartesian { $_[0]->{p_dirty}++; $_[0]->{'cartesian'} = $_[1] }
+sub set_polar { $_[0]->{c_dirty}++; $_[0]->{'polar'} = $_[1] }
+
+#
+# ->update_cartesian
+#
+# Recompute and return the cartesian form, given accurate polar form.
+#
+sub update_cartesian {
+ my $self = shift;
+ my ($r, $t) = @{$self->{'polar'}};
+ $self->{c_dirty} = 0;
+ return $self->{'cartesian'} = [$r * CORE::cos($t), $r * CORE::sin($t)];
+}
+
+#
+#
+# ->update_polar
+#
+# Recompute and return the polar form, given accurate cartesian form.
+#
+sub update_polar {
+ my $self = shift;
+ my ($x, $y) = @{$self->{'cartesian'}};
+ $self->{p_dirty} = 0;
+ return $self->{'polar'} = [0, 0] if $x == 0 && $y == 0;
+ return $self->{'polar'} = [CORE::sqrt($x*$x + $y*$y), CORE::atan2($y, $x)];
+}
+
+#
+# (plus)
+#
+# Computes z1+z2.
+#
+sub plus {
+ my ($z1, $z2, $regular) = @_;
+ my ($re1, $im1) = @{$z1->cartesian};
+ $z2 = cplx($z2) unless ref $z2;
+ my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0);
+ unless (defined $regular) {
+ $z1->set_cartesian([$re1 + $re2, $im1 + $im2]);
+ return $z1;
+ }
+ return (ref $z1)->make($re1 + $re2, $im1 + $im2);
+}
+
+#
+# (minus)
+#
+# Computes z1-z2.
+#
+sub minus {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1) = @{$z1->cartesian};
+ $z2 = cplx($z2) unless ref $z2;
+ my ($re2, $im2) = @{$z2->cartesian};
+ unless (defined $inverted) {
+ $z1->set_cartesian([$re1 - $re2, $im1 - $im2]);
+ return $z1;
+ }
+ return $inverted ?
+ (ref $z1)->make($re2 - $re1, $im2 - $im1) :
+ (ref $z1)->make($re1 - $re2, $im1 - $im2);
+
+}
+
+#
+# (multiply)
+#
+# Computes z1*z2.
+#
+sub multiply {
+ my ($z1, $z2, $regular) = @_;
+ if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) {
+ # if both polar better use polar to avoid rounding errors
+ my ($r1, $t1) = @{$z1->polar};
+ my ($r2, $t2) = @{$z2->polar};
+ my $t = $t1 + $t2;
+ if ($t > pi()) { $t -= pit2 }
+ elsif ($t <= -pi()) { $t += pit2 }
+ unless (defined $regular) {
+ $z1->set_polar([$r1 * $r2, $t]);
+ return $z1;
+ }
+ return (ref $z1)->emake($r1 * $r2, $t);
+ } else {
+ my ($x1, $y1) = @{$z1->cartesian};
+ if (ref $z2) {
+ my ($x2, $y2) = @{$z2->cartesian};
+ return (ref $z1)->make($x1*$x2-$y1*$y2, $x1*$y2+$y1*$x2);
+ } else {
+ return (ref $z1)->make($x1*$z2, $y1*$z2);
+ }
+ }
+}
+
+#
+# _divbyzero
+#
+# Die on division by zero.
+#
+sub _divbyzero {
+ my $mess = "$_[0]: Division by zero.\n";
+
+ if (defined $_[1]) {
+ $mess .= "(Because in the definition of $_[0], the divisor ";
+ $mess .= "$_[1] " unless ($_[1] eq '0');
+ $mess .= "is 0)\n";
+ }
+
+ my @up = caller(1);
+
+ $mess .= "Died at $up[1] line $up[2].\n";
+
+ die $mess;
+}
+
+#
+# (divide)
+#
+# Computes z1/z2.
+#
+sub divide {
+ my ($z1, $z2, $inverted) = @_;
+ if ($z1->{p_dirty} == 0 and ref $z2 and $z2->{p_dirty} == 0) {
+ # if both polar better use polar to avoid rounding errors
+ my ($r1, $t1) = @{$z1->polar};
+ my ($r2, $t2) = @{$z2->polar};
+ my $t;
+ if ($inverted) {
+ _divbyzero "$z2/0" if ($r1 == 0);
+ $t = $t2 - $t1;
+ if ($t > pi()) { $t -= pit2 }
+ elsif ($t <= -pi()) { $t += pit2 }
+ return (ref $z1)->emake($r2 / $r1, $t);
+ } else {
+ _divbyzero "$z1/0" if ($r2 == 0);
+ $t = $t1 - $t2;
+ if ($t > pi()) { $t -= pit2 }
+ elsif ($t <= -pi()) { $t += pit2 }
+ return (ref $z1)->emake($r1 / $r2, $t);
+ }
+ } else {
+ my ($d, $x2, $y2);
+ if ($inverted) {
+ ($x2, $y2) = @{$z1->cartesian};
+ $d = $x2*$x2 + $y2*$y2;
+ _divbyzero "$z2/0" if $d == 0;
+ return (ref $z1)->make(($x2*$z2)/$d, -($y2*$z2)/$d);
+ } else {
+ my ($x1, $y1) = @{$z1->cartesian};
+ if (ref $z2) {
+ ($x2, $y2) = @{$z2->cartesian};
+ $d = $x2*$x2 + $y2*$y2;
+ _divbyzero "$z1/0" if $d == 0;
+ my $u = ($x1*$x2 + $y1*$y2)/$d;
+ my $v = ($y1*$x2 - $x1*$y2)/$d;
+ return (ref $z1)->make($u, $v);
+ } else {
+ _divbyzero "$z1/0" if $z2 == 0;
+ return (ref $z1)->make($x1/$z2, $y1/$z2);
+ }
+ }
+ }
+}
+
+#
+# _zerotozero
+#
+# Die on zero raised to the zeroth.
+#
+sub _zerotozero {
+ my $mess = "The zero raised to the zeroth power is not defined.\n";
+
+ my @up = caller(1);
+
+ $mess .= "Died at $up[1] line $up[2].\n";
+
+ die $mess;
+}
+
+#
+# (power)
+#
+# Computes z1**z2 = exp(z2 * log z1)).
+#
+sub power {
+ my ($z1, $z2, $inverted) = @_;
+ my $z1z = $z1 == 0;
+ my $z2z = $z2 == 0;
+ _zerotozero if ($z1z and $z2z);
+ if ($inverted) {
+ return 0 if ($z2z);
+ return 1 if ($z1z or $z2 == 1);
+ } else {
+ return 0 if ($z1z);
+ return 1 if ($z2z or $z1 == 1);
+ }
+ my $w = $inverted ? CORE::exp($z1 * CORE::log($z2)) : CORE::exp($z2 * CORE::log($z1));
+ # If both arguments cartesian, return cartesian, else polar.
+ return $z1->{c_dirty} == 0 &&
+ (not ref $z2 or $z2->{c_dirty} == 0) ?
+ cplx(@{$w->cartesian}) : $w;
+}
+
+#
+# (spaceship)
+#
+# Computes z1 <=> z2.
+# Sorts on the real part first, then on the imaginary part. Thus 2-4i > 3+8i.
+#
+sub spaceship {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1) = ref $z1 ? @{$z1->cartesian} : ($z1, 0);
+ my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0);
+ my $sgn = $inverted ? -1 : 1;
+ return $sgn * ($re1 <=> $re2) if $re1 != $re2;
+ return $sgn * ($im1 <=> $im2);
+}
+
+#
+# (negate)
+#
+# Computes -z.
+#
+sub negate {
+ my ($z) = @_;
+ if ($z->{c_dirty}) {
+ my ($r, $t) = @{$z->polar};
+ $t = ($t <= 0) ? $t + pi : $t - pi;
+ return (ref $z)->emake($r, $t);
+ }
+ my ($re, $im) = @{$z->cartesian};
+ return (ref $z)->make(-$re, -$im);
+}
+
+#
+# (conjugate)
+#
+# Compute complex's conjugate.
+#
+sub conjugate {
+ my ($z) = @_;
+ if ($z->{c_dirty}) {
+ my ($r, $t) = @{$z->polar};
+ return (ref $z)->emake($r, -$t);
+ }
+ my ($re, $im) = @{$z->cartesian};
+ return (ref $z)->make($re, -$im);
+}
+
+#
+# (abs)
+#
+# Compute or set complex's norm (rho).
+#
+sub abs {
+ my ($z, $rho) = @_;
+ return $z unless ref $z;
+ if (defined $rho) {
+ $z->{'polar'} = [ $rho, ${$z->polar}[1] ];
+ $z->{p_dirty} = 0;
+ $z->{c_dirty} = 1;
+ return $rho;
+ } else {
+ return ${$z->polar}[0];
+ }
+}
+
+sub _theta {
+ my $theta = $_[0];
+
+ if ($$theta > pi()) { $$theta -= pit2 }
+ elsif ($$theta <= -pi()) { $$theta += pit2 }
+}
+
+#
+# arg
+#
+# Compute or set complex's argument (theta).
+#
+sub arg {
+ my ($z, $theta) = @_;
+ return $z unless ref $z;
+ if (defined $theta) {
+ _theta(\$theta);
+ $z->{'polar'} = [ ${$z->polar}[0], $theta ];
+ $z->{p_dirty} = 0;
+ $z->{c_dirty} = 1;
+ } else {
+ $theta = ${$z->polar}[1];
+ _theta(\$theta);
+ }
+ return $theta;
+}
+
+#
+# (sqrt)
+#
+# Compute sqrt(z).
+#
+# It is quite tempting to use wantarray here so that in list context
+# sqrt() would return the two solutions. This, however, would
+# break things like
+#
+# print "sqrt(z) = ", sqrt($z), "\n";
+#
+# The two values would be printed side by side without no intervening
+# whitespace, quite confusing.
+# Therefore if you want the two solutions use the root().
+#
+sub sqrt {
+ my ($z) = @_;
+ my ($re, $im) = ref $z ? @{$z->cartesian} : ($z, 0);
+ return $re < 0 ? cplx(0, CORE::sqrt(-$re)) : CORE::sqrt($re) if $im == 0;
+ my ($r, $t) = @{$z->polar};
+ return (ref $z)->emake(CORE::sqrt($r), $t/2);
+}
+
+#
+# cbrt
+#
+# Compute cbrt(z) (cubic root).
+#
+# Why are we not returning three values? The same answer as for sqrt().
+#
+sub cbrt {
+ my ($z) = @_;
+ return $z < 0 ? -CORE::exp(CORE::log(-$z)/3) : ($z > 0 ? CORE::exp(CORE::log($z)/3): 0)
+ unless ref $z;
+ my ($r, $t) = @{$z->polar};
+ return (ref $z)->emake(CORE::exp(CORE::log($r)/3), $t/3);
+}
+
+#
+# _rootbad
+#
+# Die on bad root.
+#
+sub _rootbad {
+ my $mess = "Root $_[0] not defined, root must be positive integer.\n";
+
+ my @up = caller(1);
+
+ $mess .= "Died at $up[1] line $up[2].\n";
+
+ die $mess;
+}
+
+#
+# root
+#
+# Computes all nth root for z, returning an array whose size is n.
+# `n' must be a positive integer.
+#
+# The roots are given by (for k = 0..n-1):
+#
+# z^(1/n) = r^(1/n) (cos ((t+2 k pi)/n) + i sin ((t+2 k pi)/n))
+#
+sub root {
+ my ($z, $n) = @_;
+ _rootbad($n) if ($n < 1 or int($n) != $n);
+ my ($r, $t) = ref $z ? @{$z->polar} : (CORE::abs($z), $z >= 0 ? 0 : pi);
+ my @root;
+ my $k;
+ my $theta_inc = pit2 / $n;
+ my $rho = $r ** (1/$n);
+ my $theta;
+ my $cartesian = ref $z && $z->{c_dirty} == 0;
+ for ($k = 0, $theta = $t / $n; $k < $n; $k++, $theta += $theta_inc) {
+ my $w = cplxe($rho, $theta);
+ # Yes, $cartesian is loop invariant.
+ push @root, $cartesian ? cplx(@{$w->cartesian}) : $w;
+ }
+ return @root;
+}
+
+#
+# Re
+#
+# Return or set Re(z).
+#
+sub Re {
+ my ($z, $Re) = @_;
+ return $z unless ref $z;
+ if (defined $Re) {
+ $z->{'cartesian'} = [ $Re, ${$z->cartesian}[1] ];
+ $z->{c_dirty} = 0;
+ $z->{p_dirty} = 1;
+ } else {
+ return ${$z->cartesian}[0];
+ }
+}
+
+#
+# Im
+#
+# Return or set Im(z).
+#
+sub Im {
+ my ($z, $Im) = @_;
+ return $z unless ref $z;
+ if (defined $Im) {
+ $z->{'cartesian'} = [ ${$z->cartesian}[0], $Im ];
+ $z->{c_dirty} = 0;
+ $z->{p_dirty} = 1;
+ } else {
+ return ${$z->cartesian}[1];
+ }
+}
+
+#
+# rho
+#
+# Return or set rho(w).
+#
+sub rho {
+ Math::Complex::abs(@_);
+}
+
+#
+# theta
+#
+# Return or set theta(w).
+#
+sub theta {
+ Math::Complex::arg(@_);
+}
+
+#
+# (exp)
+#
+# Computes exp(z).
+#
+sub exp {
+ my ($z) = @_;
+ my ($x, $y) = @{$z->cartesian};
+ return (ref $z)->emake(CORE::exp($x), $y);
+}
+
+#
+# _logofzero
+#
+# Die on logarithm of zero.
+#
+sub _logofzero {
+ my $mess = "$_[0]: Logarithm of zero.\n";
+
+ if (defined $_[1]) {
+ $mess .= "(Because in the definition of $_[0], the argument ";
+ $mess .= "$_[1] " unless ($_[1] eq '0');
+ $mess .= "is 0)\n";
+ }
+
+ my @up = caller(1);
+
+ $mess .= "Died at $up[1] line $up[2].\n";
+
+ die $mess;
+}
+
+#
+# (log)
+#
+# Compute log(z).
+#
+sub log {
+ my ($z) = @_;
+ unless (ref $z) {
+ _logofzero("log") if $z == 0;
+ return $z > 0 ? CORE::log($z) : cplx(CORE::log(-$z), pi);
+ }
+ my ($r, $t) = @{$z->polar};
+ _logofzero("log") if $r == 0;
+ if ($t > pi()) { $t -= pit2 }
+ elsif ($t <= -pi()) { $t += pit2 }
+ return (ref $z)->make(CORE::log($r), $t);
+}
+
+#
+# ln
+#
+# Alias for log().
+#
+sub ln { Math::Complex::log(@_) }
+
+#
+# log10
+#
+# Compute log10(z).
+#
+
+sub log10 {
+ return Math::Complex::log($_[0]) * uplog10;
+}
+
+#
+# logn
+#
+# Compute logn(z,n) = log(z) / log(n)
+#
+sub logn {
+ my ($z, $n) = @_;
+ $z = cplx($z, 0) unless ref $z;
+ my $logn = $logn{$n};
+ $logn = $logn{$n} = CORE::log($n) unless defined $logn; # Cache log(n)
+ return CORE::log($z) / $logn;
+}
+
+#
+# (cos)
+#
+# Compute cos(z) = (exp(iz) + exp(-iz))/2.
+#
+sub cos {
+ my ($z) = @_;
+ my ($x, $y) = @{$z->cartesian};
+ my $ey = CORE::exp($y);
+ my $ey_1 = 1 / $ey;
+ return (ref $z)->make(CORE::cos($x) * ($ey + $ey_1)/2,
+ CORE::sin($x) * ($ey_1 - $ey)/2);
+}
+
+#
+# (sin)
+#
+# Compute sin(z) = (exp(iz) - exp(-iz))/2.
+#
+sub sin {
+ my ($z) = @_;
+ my ($x, $y) = @{$z->cartesian};
+ my $ey = CORE::exp($y);
+ my $ey_1 = 1 / $ey;
+ return (ref $z)->make(CORE::sin($x) * ($ey + $ey_1)/2,
+ CORE::cos($x) * ($ey - $ey_1)/2);
+}
+
+#
+# tan
+#
+# Compute tan(z) = sin(z) / cos(z).
+#
+sub tan {
+ my ($z) = @_;
+ my $cz = CORE::cos($z);
+ _divbyzero "tan($z)", "cos($z)" if (CORE::abs($cz) < $eps);
+ return CORE::sin($z) / $cz;
+}
+
+#
+# sec
+#
+# Computes the secant sec(z) = 1 / cos(z).
+#
+sub sec {
+ my ($z) = @_;
+ my $cz = CORE::cos($z);
+ _divbyzero "sec($z)", "cos($z)" if ($cz == 0);
+ return 1 / $cz;
+}
+
+#
+# csc
+#
+# Computes the cosecant csc(z) = 1 / sin(z).
+#
+sub csc {
+ my ($z) = @_;
+ my $sz = CORE::sin($z);
+ _divbyzero "csc($z)", "sin($z)" if ($sz == 0);
+ return 1 / $sz;
+}
+
+#
+# cosec
+#
+# Alias for csc().
+#
+sub cosec { Math::Complex::csc(@_) }
+
+#
+# cot
+#
+# Computes cot(z) = cos(z) / sin(z).
+#
+sub cot {
+ my ($z) = @_;
+ my $sz = CORE::sin($z);
+ _divbyzero "cot($z)", "sin($z)" if ($sz == 0);
+ return CORE::cos($z) / $sz;
+}
+
+#
+# cotan
+#
+# Alias for cot().
+#
+sub cotan { Math::Complex::cot(@_) }
+
+#
+# acos
+#
+# Computes the arc cosine acos(z) = -i log(z + sqrt(z*z-1)).
+#
+sub acos {
+ my $z = $_[0];
+ return CORE::atan2(CORE::sqrt(1-$z*$z), $z) if (! ref $z) && CORE::abs($z) <= 1;
+ my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0);
+ my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y);
+ my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y);
+ my $alpha = ($t1 + $t2)/2;
+ my $beta = ($t1 - $t2)/2;
+ $alpha = 1 if $alpha < 1;
+ if ($beta > 1) { $beta = 1 }
+ elsif ($beta < -1) { $beta = -1 }
+ my $u = CORE::atan2(CORE::sqrt(1-$beta*$beta), $beta);
+ my $v = CORE::log($alpha + CORE::sqrt($alpha*$alpha-1));
+ $v = -$v if $y > 0 || ($y == 0 && $x < -1);
+ return $package->make($u, $v);
+}
+
+#
+# asin
+#
+# Computes the arc sine asin(z) = -i log(iz + sqrt(1-z*z)).
+#
+sub asin {
+ my $z = $_[0];
+ return CORE::atan2($z, CORE::sqrt(1-$z*$z)) if (! ref $z) && CORE::abs($z) <= 1;
+ my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0);
+ my $t1 = CORE::sqrt(($x+1)*($x+1) + $y*$y);
+ my $t2 = CORE::sqrt(($x-1)*($x-1) + $y*$y);
+ my $alpha = ($t1 + $t2)/2;
+ my $beta = ($t1 - $t2)/2;
+ $alpha = 1 if $alpha < 1;
+ if ($beta > 1) { $beta = 1 }
+ elsif ($beta < -1) { $beta = -1 }
+ my $u = CORE::atan2($beta, CORE::sqrt(1-$beta*$beta));
+ my $v = -CORE::log($alpha + CORE::sqrt($alpha*$alpha-1));
+ $v = -$v if $y > 0 || ($y == 0 && $x < -1);
+ return $package->make($u, $v);
+}
+
+#
+# atan
+#
+# Computes the arc tangent atan(z) = i/2 log((i+z) / (i-z)).
+#
+sub atan {
+ my ($z) = @_;
+ return CORE::atan2($z, 1) unless ref $z;
+ _divbyzero "atan(i)" if ( $z == i);
+ _divbyzero "atan(-i)" if (-$z == i);
+ my $log = CORE::log((i + $z) / (i - $z));
+ $ip2 = 0.5 * i unless defined $ip2;
+ return $ip2 * $log;
+}
+
+#
+# asec
+#
+# Computes the arc secant asec(z) = acos(1 / z).
+#
+sub asec {
+ my ($z) = @_;
+ _divbyzero "asec($z)", $z if ($z == 0);
+ return acos(1 / $z);
+}
+
+#
+# acsc
+#
+# Computes the arc cosecant acsc(z) = asin(1 / z).
+#
+sub acsc {
+ my ($z) = @_;
+ _divbyzero "acsc($z)", $z if ($z == 0);
+ return asin(1 / $z);
+}
+
+#
+# acosec
+#
+# Alias for acsc().
+#
+sub acosec { Math::Complex::acsc(@_) }
+
+#
+# acot
+#
+# Computes the arc cotangent acot(z) = atan(1 / z)
+#
+sub acot {
+ my ($z) = @_;
+ _divbyzero "acot(0)" if (CORE::abs($z) < $eps);
+ return ($z >= 0) ? CORE::atan2(1, $z) : CORE::atan2(-1, -$z) unless ref $z;
+ _divbyzero "acot(i)" if (CORE::abs($z - i) < $eps);
+ _logofzero "acot(-i)" if (CORE::abs($z + i) < $eps);
+ return atan(1 / $z);
+}
+
+#
+# acotan
+#
+# Alias for acot().
+#
+sub acotan { Math::Complex::acot(@_) }
+
+#
+# cosh
+#
+# Computes the hyperbolic cosine cosh(z) = (exp(z) + exp(-z))/2.
+#
+sub cosh {
+ my ($z) = @_;
+ my $ex;
+ unless (ref $z) {
+ $ex = CORE::exp($z);
+ return ($ex + 1/$ex)/2;
+ }
+ my ($x, $y) = @{$z->cartesian};
+ $ex = CORE::exp($x);
+ my $ex_1 = 1 / $ex;
+ return (ref $z)->make(CORE::cos($y) * ($ex + $ex_1)/2,
+ CORE::sin($y) * ($ex - $ex_1)/2);
+}
+
+#
+# sinh
+#
+# Computes the hyperbolic sine sinh(z) = (exp(z) - exp(-z))/2.
+#
+sub sinh {
+ my ($z) = @_;
+ my $ex;
+ unless (ref $z) {
+ $ex = CORE::exp($z);
+ return ($ex - 1/$ex)/2;
+ }
+ my ($x, $y) = @{$z->cartesian};
+ $ex = CORE::exp($x);
+ my $ex_1 = 1 / $ex;
+ return (ref $z)->make(CORE::cos($y) * ($ex - $ex_1)/2,
+ CORE::sin($y) * ($ex + $ex_1)/2);
+}
+
+#
+# tanh
+#
+# Computes the hyperbolic tangent tanh(z) = sinh(z) / cosh(z).
+#
+sub tanh {
+ my ($z) = @_;
+ my $cz = cosh($z);
+ _divbyzero "tanh($z)", "cosh($z)" if ($cz == 0);
+ return sinh($z) / $cz;
+}
+
+#
+# sech
+#
+# Computes the hyperbolic secant sech(z) = 1 / cosh(z).
+#
+sub sech {
+ my ($z) = @_;
+ my $cz = cosh($z);
+ _divbyzero "sech($z)", "cosh($z)" if ($cz == 0);
+ return 1 / $cz;
+}
+
+#
+# csch
+#
+# Computes the hyperbolic cosecant csch(z) = 1 / sinh(z).
+#
+sub csch {
+ my ($z) = @_;
+ my $sz = sinh($z);
+ _divbyzero "csch($z)", "sinh($z)" if ($sz == 0);
+ return 1 / $sz;
+}
+
+#
+# cosech
+#
+# Alias for csch().
+#
+sub cosech { Math::Complex::csch(@_) }
+
+#
+# coth
+#
+# Computes the hyperbolic cotangent coth(z) = cosh(z) / sinh(z).
+#
+sub coth {
+ my ($z) = @_;
+ my $sz = sinh($z);
+ _divbyzero "coth($z)", "sinh($z)" if ($sz == 0);
+ return cosh($z) / $sz;
+}
+
+#
+# cotanh
+#
+# Alias for coth().
+#
+sub cotanh { Math::Complex::coth(@_) }
+
+#
+# acosh
+#
+# Computes the arc hyperbolic cosine acosh(z) = log(z + sqrt(z*z-1)).
+#
+sub acosh {
+ my ($z) = @_;
+ unless (ref $z) {
+ return CORE::log($z + CORE::sqrt($z*$z-1)) if $z >= 1;
+ $z = cplx($z, 0);
+ }
+ my ($re, $im) = @{$z->cartesian};
+ if ($im == 0) {
+ return cplx(CORE::log($re + CORE::sqrt($re*$re - 1)), 0) if $re >= 1;
+ return cplx(0, CORE::atan2(CORE::sqrt(1-$re*$re), $re)) if CORE::abs($re) <= 1;
+ }
+ return CORE::log($z + CORE::sqrt($z*$z - 1));
+}
+
+#
+# asinh
+#
+# Computes the arc hyperbolic sine asinh(z) = log(z + sqrt(z*z-1))
+#
+sub asinh {
+ my ($z) = @_;
+ return CORE::log($z + CORE::sqrt($z*$z + 1));
+}
+
+#
+# atanh
+#
+# Computes the arc hyperbolic tangent atanh(z) = 1/2 log((1+z) / (1-z)).
+#
+sub atanh {
+ my ($z) = @_;
+ unless (ref $z) {
+ return CORE::log((1 + $z)/(1 - $z))/2 if CORE::abs($z) < 1;
+ $z = cplx($z, 0);
+ }
+ _divbyzero 'atanh(1)', "1 - $z" if ($z == 1);
+ _logofzero 'atanh(-1)' if ($z == -1);
+ return 0.5 * CORE::log((1 + $z) / (1 - $z));
+}
+
+#
+# asech
+#
+# Computes the hyperbolic arc secant asech(z) = acosh(1 / z).
+#
+sub asech {
+ my ($z) = @_;
+ _divbyzero 'asech(0)', $z if ($z == 0);
+ return acosh(1 / $z);
+}
+
+#
+# acsch
+#
+# Computes the hyperbolic arc cosecant acsch(z) = asinh(1 / z).
+#
+sub acsch {
+ my ($z) = @_;
+ _divbyzero 'acsch(0)', $z if ($z == 0);
+ return asinh(1 / $z);
+}
+
+#
+# acosech
+#
+# Alias for acosh().
+#
+sub acosech { Math::Complex::acsch(@_) }
+
+#
+# acoth
+#
+# Computes the arc hyperbolic cotangent acoth(z) = 1/2 log((1+z) / (z-1)).
+#
+sub acoth {
+ my ($z) = @_;
+ _divbyzero 'acoth(0)' if (CORE::abs($z) < $eps);
+ unless (ref $z) {
+ return CORE::log(($z + 1)/($z - 1))/2 if CORE::abs($z) > 1;
+ $z = cplx($z, 0);
+ }
+ _divbyzero 'acoth(1)', "$z - 1" if (CORE::abs($z - 1) < $eps);
+ _logofzero 'acoth(-1)', "1 / $z" if (CORE::abs($z + 1) < $eps);
+ return CORE::log((1 + $z) / ($z - 1)) / 2;
+}
+
+#
+# acotanh
+#
+# Alias for acot().
+#
+sub acotanh { Math::Complex::acoth(@_) }
+
+#
+# (atan2)
+#
+# Compute atan(z1/z2).
+#
+sub atan2 {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1, $re2, $im2);
+ if ($inverted) {
+ ($re1, $im1) = ref $z2 ? @{$z2->cartesian} : ($z2, 0);
+ ($re2, $im2) = @{$z1->cartesian};
+ } else {
+ ($re1, $im1) = @{$z1->cartesian};
+ ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2, 0);
+ }
+ if ($im2 == 0) {
+ return cplx(CORE::atan2($re1, $re2), 0) if $im1 == 0;
+ return cplx(($im1<=>0) * pip2, 0) if $re2 == 0;
+ }
+ my $w = atan($z1/$z2);
+ my ($u, $v) = ref $w ? @{$w->cartesian} : ($w, 0);
+ $u += pi if $re2 < 0;
+ $u -= pit2 if $u > pi;
+ return cplx($u, $v);
+}
+
+#
+# display_format
+# ->display_format
+#
+# Set (fetch if no argument) display format for all complex numbers that
+# don't happen to have overridden it via ->display_format
+#
+# When called as a method, this actually sets the display format for
+# the current object.
+#
+# Valid object formats are 'c' and 'p' for cartesian and polar. The first
+# letter is used actually, so the type can be fully spelled out for clarity.
+#
+sub display_format {
+ my $self = shift;
+ my $format = undef;
+
+ if (ref $self) { # Called as a method
+ $format = shift;
+ } else { # Regular procedure call
+ $format = $self;
+ undef $self;
+ }
+
+ if (defined $self) {
+ return defined $self->{display} ? $self->{display} : $display
+ unless defined $format;
+ return $self->{display} = $format;
+ }
+
+ return $display unless defined $format;
+ return $display = $format;
+}
+
+#
+# (stringify)
+#
+# Show nicely formatted complex number under its cartesian or polar form,
+# depending on the current display format:
+#
+# . If a specific display format has been recorded for this object, use it.
+# . Otherwise, use the generic current default for all complex numbers,
+# which is a package global variable.
+#
+sub stringify {
+ my ($z) = shift;
+ my $format;
+
+ $format = $display;
+ $format = $z->{display} if defined $z->{display};
+
+ return $z->stringify_polar if $format =~ /^p/i;
+ return $z->stringify_cartesian;
+}
+
+#
+# ->stringify_cartesian
+#
+# Stringify as a cartesian representation 'a+bi'.
+#
+sub stringify_cartesian {
+ my $z = shift;
+ my ($x, $y) = @{$z->cartesian};
+ my ($re, $im);
+
+ $x = int($x + ($x < 0 ? -1 : 1) * $eps)
+ if int(CORE::abs($x)) != int(CORE::abs($x) + $eps);
+ $y = int($y + ($y < 0 ? -1 : 1) * $eps)
+ if int(CORE::abs($y)) != int(CORE::abs($y) + $eps);
+
+ $re = "$x" if CORE::abs($x) >= $eps;
+ if ($y == 1) { $im = 'i' }
+ elsif ($y == -1) { $im = '-i' }
+ elsif (CORE::abs($y) >= $eps) { $im = $y . "i" }
+
+ my $str = '';
+ $str = $re if defined $re;
+ $str .= "+$im" if defined $im;
+ $str =~ s/\+-/-/;
+ $str =~ s/^\+//;
+ $str =~ s/([-+])1i/$1i/; # Not redundant with the above 1/-1 tests.
+ $str = '0' unless $str;
+
+ return $str;
+}
+
+
+# Helper for stringify_polar, a Greatest Common Divisor with a memory.
+
+sub _gcd {
+ my ($a, $b) = @_;
+
+ use integer;
+
+ # Loops forever if given negative inputs.
+
+ if ($b and $a > $b) { return gcd($a % $b, $b) }
+ elsif ($a and $b > $a) { return gcd($b % $a, $a) }
+ else { return $a ? $a : $b }
+}
+
+my %gcd;
+
+sub gcd {
+ my ($a, $b) = @_;
+
+ my $id = "$a $b";
+
+ unless (exists $gcd{$id}) {
+ $gcd{$id} = _gcd($a, $b);
+ $gcd{"$b $a"} = $gcd{$id};
+ }
+
+ return $gcd{$id};
+}
+
+#
+# ->stringify_polar
+#
+# Stringify as a polar representation '[r,t]'.
+#
+sub stringify_polar {
+ my $z = shift;
+ my ($r, $t) = @{$z->polar};
+ my $theta;
+
+ return '[0,0]' if $r <= $eps;
+
+ my $nt = $t / pit2;
+ $nt = ($nt - int($nt)) * pit2;
+ $nt += pit2 if $nt < 0; # Range [0, 2pi]
+
+ if (CORE::abs($nt) <= $eps) { $theta = 0 }
+ elsif (CORE::abs(pi-$nt) <= $eps) { $theta = 'pi' }
+
+ if (defined $theta) {
+ $r = int($r + ($r < 0 ? -1 : 1) * $eps)
+ if int(CORE::abs($r)) != int(CORE::abs($r) + $eps);
+ $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps)
+ if ($theta ne 'pi' and
+ int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps));
+ return "\[$r,$theta\]";
+ }
+
+ #
+ # Okay, number is not a real. Try to identify pi/n and friends...
+ #
+
+ $nt -= pit2 if $nt > pi;
+
+ if (CORE::abs($nt) >= deg1) {
+ my ($n, $k, $kpi);
+
+ for ($k = 1, $kpi = pi; $k < 10; $k++, $kpi += pi) {
+ $n = int($kpi / $nt + ($nt > 0 ? 1 : -1) * 0.5);
+ if (CORE::abs($kpi/$n - $nt) <= $eps) {
+ $n = CORE::abs($n);
+ my $gcd = gcd($k, $n);
+ if ($gcd > 1) {
+ $k /= $gcd;
+ $n /= $gcd;
+ }
+ next if $n > 360;
+ $theta = ($nt < 0 ? '-':'').
+ ($k == 1 ? 'pi':"${k}pi");
+ $theta .= '/'.$n if $n > 1;
+ last;
+ }
+ }
+ }
+
+ $theta = $nt unless defined $theta;
+
+ $r = int($r + ($r < 0 ? -1 : 1) * $eps)
+ if int(CORE::abs($r)) != int(CORE::abs($r) + $eps);
+ $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps)
+ if ($theta !~ m(^-?\d*pi/\d+$) and
+ int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps));
+
+ return "\[$r,$theta\]";
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Math::Complex - complex numbers and associated mathematical functions
+
+=head1 SYNOPSIS
+
+ use Math::Complex;
+
+ $z = Math::Complex->make(5, 6);
+ $t = 4 - 3*i + $z;
+ $j = cplxe(1, 2*pi/3);
+
+=head1 DESCRIPTION
+
+This package lets you create and manipulate complex numbers. By default,
+I<Perl> limits itself to real numbers, but an extra C<use> statement brings
+full complex support, along with a full set of mathematical functions
+typically associated with and/or extended to complex numbers.
+
+If you wonder what complex numbers are, they were invented to be able to solve
+the following equation:
+
+ x*x = -1
+
+and by definition, the solution is noted I<i> (engineers use I<j> instead since
+I<i> usually denotes an intensity, but the name does not matter). The number
+I<i> is a pure I<imaginary> number.
+
+The arithmetics with pure imaginary numbers works just like you would expect
+it with real numbers... you just have to remember that
+
+ i*i = -1
+
+so you have:
+
+ 5i + 7i = i * (5 + 7) = 12i
+ 4i - 3i = i * (4 - 3) = i
+ 4i * 2i = -8
+ 6i / 2i = 3
+ 1 / i = -i
+
+Complex numbers are numbers that have both a real part and an imaginary
+part, and are usually noted:
+
+ a + bi
+
+where C<a> is the I<real> part and C<b> is the I<imaginary> part. The
+arithmetic with complex numbers is straightforward. You have to
+keep track of the real and the imaginary parts, but otherwise the
+rules used for real numbers just apply:
+
+ (4 + 3i) + (5 - 2i) = (4 + 5) + i(3 - 2) = 9 + i
+ (2 + i) * (4 - i) = 2*4 + 4i -2i -i*i = 8 + 2i + 1 = 9 + 2i
+
+A graphical representation of complex numbers is possible in a plane
+(also called the I<complex plane>, but it's really a 2D plane).
+The number
+
+ z = a + bi
+
+is the point whose coordinates are (a, b). Actually, it would
+be the vector originating from (0, 0) to (a, b). It follows that the addition
+of two complex numbers is a vectorial addition.
+
+Since there is a bijection between a point in the 2D plane and a complex
+number (i.e. the mapping is unique and reciprocal), a complex number
+can also be uniquely identified with polar coordinates:
+
+ [rho, theta]
+
+where C<rho> is the distance to the origin, and C<theta> the angle between
+the vector and the I<x> axis. There is a notation for this using the
+exponential form, which is:
+
+ rho * exp(i * theta)
+
+where I<i> is the famous imaginary number introduced above. Conversion
+between this form and the cartesian form C<a + bi> is immediate:
+
+ a = rho * cos(theta)
+ b = rho * sin(theta)
+
+which is also expressed by this formula:
+
+ z = rho * exp(i * theta) = rho * (cos theta + i * sin theta)
+
+In other words, it's the projection of the vector onto the I<x> and I<y>
+axes. Mathematicians call I<rho> the I<norm> or I<modulus> and I<theta>
+the I<argument> of the complex number. The I<norm> of C<z> will be
+noted C<abs(z)>.
+
+The polar notation (also known as the trigonometric
+representation) is much more handy for performing multiplications and
+divisions of complex numbers, whilst the cartesian notation is better
+suited for additions and subtractions. Real numbers are on the I<x>
+axis, and therefore I<theta> is zero or I<pi>.
+
+All the common operations that can be performed on a real number have
+been defined to work on complex numbers as well, and are merely
+I<extensions> of the operations defined on real numbers. This means
+they keep their natural meaning when there is no imaginary part, provided
+the number is within their definition set.
+
+For instance, the C<sqrt> routine which computes the square root of
+its argument is only defined for non-negative real numbers and yields a
+non-negative real number (it is an application from B<R+> to B<R+>).
+If we allow it to return a complex number, then it can be extended to
+negative real numbers to become an application from B<R> to B<C> (the
+set of complex numbers):
+
+ sqrt(x) = x >= 0 ? sqrt(x) : sqrt(-x)*i
+
+It can also be extended to be an application from B<C> to B<C>,
+whilst its restriction to B<R> behaves as defined above by using
+the following definition:
+
+ sqrt(z = [r,t]) = sqrt(r) * exp(i * t/2)
+
+Indeed, a negative real number can be noted C<[x,pi]> (the modulus
+I<x> is always non-negative, so C<[x,pi]> is really C<-x>, a negative
+number) and the above definition states that
+
+ sqrt([x,pi]) = sqrt(x) * exp(i*pi/2) = [sqrt(x),pi/2] = sqrt(x)*i
+
+which is exactly what we had defined for negative real numbers above.
+The C<sqrt> returns only one of the solutions: if you want the both,
+use the C<root> function.
+
+All the common mathematical functions defined on real numbers that
+are extended to complex numbers share that same property of working
+I<as usual> when the imaginary part is zero (otherwise, it would not
+be called an extension, would it?).
+
+A I<new> operation possible on a complex number that is
+the identity for real numbers is called the I<conjugate>, and is noted
+with an horizontal bar above the number, or C<~z> here.
+
+ z = a + bi
+ ~z = a - bi
+
+Simple... Now look:
+
+ z * ~z = (a + bi) * (a - bi) = a*a + b*b
+
+We saw that the norm of C<z> was noted C<abs(z)> and was defined as the
+distance to the origin, also known as:
+
+ rho = abs(z) = sqrt(a*a + b*b)
+
+so
+
+ z * ~z = abs(z) ** 2
+
+If z is a pure real number (i.e. C<b == 0>), then the above yields:
+
+ a * a = abs(a) ** 2
+
+which is true (C<abs> has the regular meaning for real number, i.e. stands
+for the absolute value). This example explains why the norm of C<z> is
+noted C<abs(z)>: it extends the C<abs> function to complex numbers, yet
+is the regular C<abs> we know when the complex number actually has no
+imaginary part... This justifies I<a posteriori> our use of the C<abs>
+notation for the norm.
+
+=head1 OPERATIONS
+
+Given the following notations:
+
+ z1 = a + bi = r1 * exp(i * t1)
+ z2 = c + di = r2 * exp(i * t2)
+ z = <any complex or real number>
+
+the following (overloaded) operations are supported on complex numbers:
+
+ z1 + z2 = (a + c) + i(b + d)
+ z1 - z2 = (a - c) + i(b - d)
+ z1 * z2 = (r1 * r2) * exp(i * (t1 + t2))
+ z1 / z2 = (r1 / r2) * exp(i * (t1 - t2))
+ z1 ** z2 = exp(z2 * log z1)
+ ~z = a - bi
+ abs(z) = r1 = sqrt(a*a + b*b)
+ sqrt(z) = sqrt(r1) * exp(i * t/2)
+ exp(z) = exp(a) * exp(i * b)
+ log(z) = log(r1) + i*t
+ sin(z) = 1/2i (exp(i * z1) - exp(-i * z))
+ cos(z) = 1/2 (exp(i * z1) + exp(-i * z))
+ atan2(z1, z2) = atan(z1/z2)
+
+The following extra operations are supported on both real and complex
+numbers:
+
+ Re(z) = a
+ Im(z) = b
+ arg(z) = t
+ abs(z) = r
+
+ cbrt(z) = z ** (1/3)
+ log10(z) = log(z) / log(10)
+ logn(z, n) = log(z) / log(n)
+
+ tan(z) = sin(z) / cos(z)
+
+ csc(z) = 1 / sin(z)
+ sec(z) = 1 / cos(z)
+ cot(z) = 1 / tan(z)
+
+ asin(z) = -i * log(i*z + sqrt(1-z*z))
+ acos(z) = -i * log(z + i*sqrt(1-z*z))
+ atan(z) = i/2 * log((i+z) / (i-z))
+
+ acsc(z) = asin(1 / z)
+ asec(z) = acos(1 / z)
+ acot(z) = atan(1 / z) = -i/2 * log((i+z) / (z-i))
+
+ sinh(z) = 1/2 (exp(z) - exp(-z))
+ cosh(z) = 1/2 (exp(z) + exp(-z))
+ tanh(z) = sinh(z) / cosh(z) = (exp(z) - exp(-z)) / (exp(z) + exp(-z))
+
+ csch(z) = 1 / sinh(z)
+ sech(z) = 1 / cosh(z)
+ coth(z) = 1 / tanh(z)
+
+ asinh(z) = log(z + sqrt(z*z+1))
+ acosh(z) = log(z + sqrt(z*z-1))
+ atanh(z) = 1/2 * log((1+z) / (1-z))
+
+ acsch(z) = asinh(1 / z)
+ asech(z) = acosh(1 / z)
+ acoth(z) = atanh(1 / z) = 1/2 * log((1+z) / (z-1))
+
+I<arg>, I<abs>, I<log>, I<csc>, I<cot>, I<acsc>, I<acot>, I<csch>,
+I<coth>, I<acosech>, I<acotanh>, have aliases I<rho>, I<theta>, I<ln>,
+I<cosec>, I<cotan>, I<acosec>, I<acotan>, I<cosech>, I<cotanh>,
+I<acosech>, I<acotanh>, respectively. C<Re>, C<Im>, C<arg>, C<abs>,
+C<rho>, and C<theta> can be used also also mutators. The C<cbrt>
+returns only one of the solutions: if you want all three, use the
+C<root> function.
+
+The I<root> function is available to compute all the I<n>
+roots of some complex, where I<n> is a strictly positive integer.
+There are exactly I<n> such roots, returned as a list. Getting the
+number mathematicians call C<j> such that:
+
+ 1 + j + j*j = 0;
+
+is a simple matter of writing:
+
+ $j = ((root(1, 3))[1];
+
+The I<k>th root for C<z = [r,t]> is given by:
+
+ (root(z, n))[k] = r**(1/n) * exp(i * (t + 2*k*pi)/n)
+
+The I<spaceship> comparison operator, E<lt>=E<gt>, is also defined. In
+order to ensure its restriction to real numbers is conform to what you
+would expect, the comparison is run on the real part of the complex
+number first, and imaginary parts are compared only when the real
+parts match.
+
+=head1 CREATION
+
+To create a complex number, use either:
+
+ $z = Math::Complex->make(3, 4);
+ $z = cplx(3, 4);
+
+if you know the cartesian form of the number, or
+
+ $z = 3 + 4*i;
+
+if you like. To create a number using the polar form, use either:
+
+ $z = Math::Complex->emake(5, pi/3);
+ $x = cplxe(5, pi/3);
+
+instead. The first argument is the modulus, the second is the angle
+(in radians, the full circle is 2*pi). (Mnemonic: C<e> is used as a
+notation for complex numbers in the polar form).
+
+It is possible to write:
+
+ $x = cplxe(-3, pi/4);
+
+but that will be silently converted into C<[3,-3pi/4]>, since the modulus
+must be non-negative (it represents the distance to the origin in the complex
+plane).
+
+It is also possible to have a complex number as either argument of
+either the C<make> or C<emake>: the appropriate component of
+the argument will be used.
+
+ $z1 = cplx(-2, 1);
+ $z2 = cplx($z1, 4);
+
+=head1 STRINGIFICATION
+
+When printed, a complex number is usually shown under its cartesian
+form I<a+bi>, but there are legitimate cases where the polar format
+I<[r,t]> is more appropriate.
+
+By calling the routine C<Math::Complex::display_format> and supplying either
+C<"polar"> or C<"cartesian">, you override the default display format,
+which is C<"cartesian">. Not supplying any argument returns the current
+setting.
+
+This default can be overridden on a per-number basis by calling the
+C<display_format> method instead. As before, not supplying any argument
+returns the current display format for this number. Otherwise whatever you
+specify will be the new display format for I<this> particular number.
+
+For instance:
+
+ use Math::Complex;
+
+ Math::Complex::display_format('polar');
+ $j = ((root(1, 3))[1];
+ print "j = $j\n"; # Prints "j = [1,2pi/3]
+ $j->display_format('cartesian');
+ print "j = $j\n"; # Prints "j = -0.5+0.866025403784439i"
+
+The polar format attempts to emphasize arguments like I<k*pi/n>
+(where I<n> is a positive integer and I<k> an integer within [-9,+9]).
+
+=head1 USAGE
+
+Thanks to overloading, the handling of arithmetics with complex numbers
+is simple and almost transparent.
+
+Here are some examples:
+
+ use Math::Complex;
+
+ $j = cplxe(1, 2*pi/3); # $j ** 3 == 1
+ print "j = $j, j**3 = ", $j ** 3, "\n";
+ print "1 + j + j**2 = ", 1 + $j + $j**2, "\n";
+
+ $z = -16 + 0*i; # Force it to be a complex
+ print "sqrt($z) = ", sqrt($z), "\n";
+
+ $k = exp(i * 2*pi/3);
+ print "$j - $k = ", $j - $k, "\n";
+
+ $z->Re(3); # Re, Im, arg, abs,
+ $j->arg(2); # (the last two aka rho, theta)
+ # can be used also as mutators.
+
+=head1 ERRORS DUE TO DIVISION BY ZERO OR LOGARITHM OF ZERO
+
+The division (/) and the following functions
+
+ log ln log10 logn
+ tan sec csc cot
+ atan asec acsc acot
+ tanh sech csch coth
+ atanh asech acsch acoth
+
+cannot be computed for all arguments because that would mean dividing
+by zero or taking logarithm of zero. These situations cause fatal
+runtime errors looking like this
+
+ cot(0): Division by zero.
+ (Because in the definition of cot(0), the divisor sin(0) is 0)
+ Died at ...
+
+or
+
+ atanh(-1): Logarithm of zero.
+ Died at...
+
+For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>,
+C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the the
+logarithmic functions and the C<atanh>, C<acoth>, the argument cannot
+be C<1> (one). For the C<atanh>, C<acoth>, the argument cannot be
+C<-1> (minus one). For the C<atan>, C<acot>, the argument cannot be
+C<i> (the imaginary unit). For the C<atan>, C<acoth>, the argument
+cannot be C<-i> (the negative imaginary unit). For the C<tan>,
+C<sec>, C<tanh>, the argument cannot be I<pi/2 + k * pi>, where I<k>
+is any integer.
+
+Note that because we are operating on approximations of real numbers,
+these errors can happen when merely `too close' to the singularities
+listed above. For example C<tan(2*atan2(1,1)+1e-15)> will die of
+division by zero.
+
+=head1 ERRORS DUE TO INDIGESTIBLE ARGUMENTS
+
+The C<make> and C<emake> accept both real and complex arguments.
+When they cannot recognize the arguments they will die with error
+messages like the following
+
+ Math::Complex::make: Cannot take real part of ...
+ Math::Complex::make: Cannot take real part of ...
+ Math::Complex::emake: Cannot take rho of ...
+ Math::Complex::emake: Cannot take theta of ...
+
+=head1 BUGS
+
+Saying C<use Math::Complex;> exports many mathematical routines in the
+caller environment and even overrides some (C<sqrt>, C<log>).
+This is construed as a feature by the Authors, actually... ;-)
+
+All routines expect to be given real or complex numbers. Don't attempt to
+use BigFloat, since Perl has currently no rule to disambiguate a '+'
+operation (for instance) between two overloaded entities.
+
+In Cray UNICOS there is some strange numerical instability that results
+in root(), cos(), sin(), cosh(), sinh(), losing accuracy fast. Beware.
+The bug may be in UNICOS math libs, in UNICOS C compiler, in Math::Complex.
+Whatever it is, it does not manifest itself anywhere else where Perl runs.
+
+=head1 AUTHORS
+
+Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>> and
+Jarkko Hietaniemi <F<jhi@iki.fi>>.
+
+Extensive patches by Daniel S. Lewart <F<d-lewart@uiuc.edu>>.
+
+=cut
+
+1;
+
+# eof
diff --git a/contrib/perl5/lib/Math/Trig.pm b/contrib/perl5/lib/Math/Trig.pm
new file mode 100644
index 000000000000..b7b5d5d8f2bd
--- /dev/null
+++ b/contrib/perl5/lib/Math/Trig.pm
@@ -0,0 +1,419 @@
+#
+# Trigonometric functions, mostly inherited from Math::Complex.
+# -- Jarkko Hietaniemi, since April 1997
+# -- Raphael Manfredi, September 1996 (indirectly: because of Math::Complex)
+#
+
+require Exporter;
+package Math::Trig;
+
+use strict;
+
+use Math::Complex qw(:trig);
+
+use vars qw($VERSION $PACKAGE
+ @ISA
+ @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+@ISA = qw(Exporter);
+
+$VERSION = 1.00;
+
+my @angcnv = qw(rad2deg rad2grad
+ deg2rad deg2grad
+ grad2rad grad2deg);
+
+@EXPORT = (@{$Math::Complex::EXPORT_TAGS{'trig'}},
+ @angcnv);
+
+my @rdlcnv = qw(cartesian_to_cylindrical
+ cartesian_to_spherical
+ cylindrical_to_cartesian
+ cylindrical_to_spherical
+ spherical_to_cartesian
+ spherical_to_cylindrical);
+
+@EXPORT_OK = (@rdlcnv, 'great_circle_distance');
+
+%EXPORT_TAGS = ('radial' => [ @rdlcnv ]);
+
+use constant pi2 => 2 * pi;
+use constant pip2 => pi / 2;
+use constant DR => pi2/360;
+use constant RD => 360/pi2;
+use constant DG => 400/360;
+use constant GD => 360/400;
+use constant RG => 400/pi2;
+use constant GR => pi2/400;
+
+#
+# Truncating remainder.
+#
+
+sub remt ($$) {
+ # Oh yes, POSIX::fmod() would be faster. Possibly. If it is available.
+ $_[0] - $_[1] * int($_[0] / $_[1]);
+}
+
+#
+# Angle conversions.
+#
+
+sub rad2deg ($) { remt(RD * $_[0], 360) }
+
+sub deg2rad ($) { remt(DR * $_[0], pi2) }
+
+sub grad2deg ($) { remt(GD * $_[0], 360) }
+
+sub deg2grad ($) { remt(DG * $_[0], 400) }
+
+sub rad2grad ($) { remt(RG * $_[0], 400) }
+
+sub grad2rad ($) { remt(GR * $_[0], pi2) }
+
+sub cartesian_to_spherical {
+ my ( $x, $y, $z ) = @_;
+
+ my $rho = sqrt( $x * $x + $y * $y + $z * $z );
+
+ return ( $rho,
+ atan2( $y, $x ),
+ $rho ? acos( $z / $rho ) : 0 );
+}
+
+sub spherical_to_cartesian {
+ my ( $rho, $theta, $phi ) = @_;
+
+ return ( $rho * cos( $theta ) * sin( $phi ),
+ $rho * sin( $theta ) * sin( $phi ),
+ $rho * cos( $phi ) );
+}
+
+sub spherical_to_cylindrical {
+ my ( $x, $y, $z ) = spherical_to_cartesian( @_ );
+
+ return ( sqrt( $x * $x + $y * $y ), $_[1], $z );
+}
+
+sub cartesian_to_cylindrical {
+ my ( $x, $y, $z ) = @_;
+
+ return ( sqrt( $x * $x + $y * $y ), atan2( $y, $x ), $z );
+}
+
+sub cylindrical_to_cartesian {
+ my ( $rho, $theta, $z ) = @_;
+
+ return ( $rho * cos( $theta ), $rho * sin( $theta ), $z );
+}
+
+sub cylindrical_to_spherical {
+ return ( cartesian_to_spherical( cylindrical_to_cartesian( @_ ) ) );
+}
+
+sub great_circle_distance {
+ my ( $theta0, $phi0, $theta1, $phi1, $rho ) = @_;
+
+ $rho = 1 unless defined $rho; # Default to the unit sphere.
+
+ my $lat0 = pip2 - $phi0;
+ my $lat1 = pip2 - $phi1;
+
+ return $rho *
+ acos(cos( $lat0 ) * cos( $lat1 ) * cos( $theta0 - $theta1 ) +
+ sin( $lat0 ) * sin( $lat1 ) );
+}
+
+=pod
+
+=head1 NAME
+
+Math::Trig - trigonometric functions
+
+=head1 SYNOPSIS
+
+ use Math::Trig;
+
+ $x = tan(0.9);
+ $y = acos(3.7);
+ $z = asin(2.4);
+
+ $halfpi = pi/2;
+
+ $rad = deg2rad(120);
+
+=head1 DESCRIPTION
+
+C<Math::Trig> defines many trigonometric functions not defined by the
+core Perl which defines only the C<sin()> and C<cos()>. The constant
+B<pi> is also defined as are a few convenience functions for angle
+conversions.
+
+=head1 TRIGONOMETRIC FUNCTIONS
+
+The tangent
+
+=over 4
+
+=item B<tan>
+
+=back
+
+The cofunctions of the sine, cosine, and tangent (cosec/csc and cotan/cot
+are aliases)
+
+B<csc>, B<cosec>, B<sec>, B<sec>, B<cot>, B<cotan>
+
+The arcus (also known as the inverse) functions of the sine, cosine,
+and tangent
+
+B<asin>, B<acos>, B<atan>
+
+The principal value of the arc tangent of y/x
+
+B<atan2>(y, x)
+
+The arcus cofunctions of the sine, cosine, and tangent (acosec/acsc
+and acotan/acot are aliases)
+
+B<acsc>, B<acosec>, B<asec>, B<acot>, B<acotan>
+
+The hyperbolic sine, cosine, and tangent
+
+B<sinh>, B<cosh>, B<tanh>
+
+The cofunctions of the hyperbolic sine, cosine, and tangent (cosech/csch
+and cotanh/coth are aliases)
+
+B<csch>, B<cosech>, B<sech>, B<coth>, B<cotanh>
+
+The arcus (also known as the inverse) functions of the hyperbolic
+sine, cosine, and tangent
+
+B<asinh>, B<acosh>, B<atanh>
+
+The arcus cofunctions of the hyperbolic sine, cosine, and tangent
+(acsch/acosech and acoth/acotanh are aliases)
+
+B<acsch>, B<acosech>, B<asech>, B<acoth>, B<acotanh>
+
+The trigonometric constant B<pi> is also defined.
+
+$pi2 = 2 * B<pi>;
+
+=head2 ERRORS DUE TO DIVISION BY ZERO
+
+The following functions
+
+ acoth
+ acsc
+ acsch
+ asec
+ asech
+ atanh
+ cot
+ coth
+ csc
+ csch
+ sec
+ sech
+ tan
+ tanh
+
+cannot be computed for all arguments because that would mean dividing
+by zero or taking logarithm of zero. These situations cause fatal
+runtime errors looking like this
+
+ cot(0): Division by zero.
+ (Because in the definition of cot(0), the divisor sin(0) is 0)
+ Died at ...
+
+or
+
+ atanh(-1): Logarithm of zero.
+ Died at...
+
+For the C<csc>, C<cot>, C<asec>, C<acsc>, C<acot>, C<csch>, C<coth>,
+C<asech>, C<acsch>, the argument cannot be C<0> (zero). For the
+C<atanh>, C<acoth>, the argument cannot be C<1> (one). For the
+C<atanh>, C<acoth>, the argument cannot be C<-1> (minus one). For the
+C<tan>, C<sec>, C<tanh>, C<sech>, the argument cannot be I<pi/2 + k *
+pi>, where I<k> is any integer.
+
+=head2 SIMPLE (REAL) ARGUMENTS, COMPLEX RESULTS
+
+Please note that some of the trigonometric functions can break out
+from the B<real axis> into the B<complex plane>. For example
+C<asin(2)> has no definition for plain real numbers but it has
+definition for complex numbers.
+
+In Perl terms this means that supplying the usual Perl numbers (also
+known as scalars, please see L<perldata>) as input for the
+trigonometric functions might produce as output results that no more
+are simple real numbers: instead they are complex numbers.
+
+The C<Math::Trig> handles this by using the C<Math::Complex> package
+which knows how to handle complex numbers, please see L<Math::Complex>
+for more information. In practice you need not to worry about getting
+complex numbers as results because the C<Math::Complex> takes care of
+details like for example how to display complex numbers. For example:
+
+ print asin(2), "\n";
+
+should produce something like this (take or leave few last decimals):
+
+ 1.5707963267949-1.31695789692482i
+
+That is, a complex number with the real part of approximately C<1.571>
+and the imaginary part of approximately C<-1.317>.
+
+=head1 PLANE ANGLE CONVERSIONS
+
+(Plane, 2-dimensional) angles may be converted with the following functions.
+
+ $radians = deg2rad($degrees);
+ $radians = grad2rad($gradians);
+
+ $degrees = rad2deg($radians);
+ $degrees = grad2deg($gradians);
+
+ $gradians = deg2grad($degrees);
+ $gradians = rad2grad($radians);
+
+The full circle is 2 I<pi> radians or I<360> degrees or I<400> gradians.
+
+=head1 RADIAL COORDINATE CONVERSIONS
+
+B<Radial coordinate systems> are the B<spherical> and the B<cylindrical>
+systems, explained shortly in more detail.
+
+You can import radial coordinate conversion functions by using the
+C<:radial> tag:
+
+ use Math::Trig ':radial';
+
+ ($rho, $theta, $z) = cartesian_to_cylindrical($x, $y, $z);
+ ($rho, $theta, $phi) = cartesian_to_spherical($x, $y, $z);
+ ($x, $y, $z) = cylindrical_to_cartesian($rho, $theta, $z);
+ ($rho_s, $theta, $phi) = cylindrical_to_spherical($rho_c, $theta, $z);
+ ($x, $y, $z) = spherical_to_cartesian($rho, $theta, $phi);
+ ($rho_c, $theta, $z) = spherical_to_cylindrical($rho_s, $theta, $phi);
+
+B<All angles are in radians>.
+
+=head2 COORDINATE SYSTEMS
+
+B<Cartesian> coordinates are the usual rectangular I<(x, y,
+z)>-coordinates.
+
+Spherical coordinates, I<(rho, theta, pi)>, are three-dimensional
+coordinates which define a point in three-dimensional space. They are
+based on a sphere surface. The radius of the sphere is B<rho>, also
+known as the I<radial> coordinate. The angle in the I<xy>-plane
+(around the I<z>-axis) is B<theta>, also known as the I<azimuthal>
+coordinate. The angle from the I<z>-axis is B<phi>, also known as the
+I<polar> coordinate. The `North Pole' is therefore I<0, 0, rho>, and
+the `Bay of Guinea' (think of the missing big chunk of Africa) I<0,
+pi/2, rho>.
+
+B<Beware>: some texts define I<theta> and I<phi> the other way round,
+some texts define the I<phi> to start from the horizontal plane, some
+texts use I<r> in place of I<rho>.
+
+Cylindrical coordinates, I<(rho, theta, z)>, are three-dimensional
+coordinates which define a point in three-dimensional space. They are
+based on a cylinder surface. The radius of the cylinder is B<rho>,
+also known as the I<radial> coordinate. The angle in the I<xy>-plane
+(around the I<z>-axis) is B<theta>, also known as the I<azimuthal>
+coordinate. The third coordinate is the I<z>, pointing up from the
+B<theta>-plane.
+
+=head2 3-D ANGLE CONVERSIONS
+
+Conversions to and from spherical and cylindrical coordinates are
+available. Please notice that the conversions are not necessarily
+reversible because of the equalities like I<pi> angles being equal to
+I<-pi> angles.
+
+=over 4
+
+=item cartesian_to_cylindrical
+
+ ($rho, $theta, $z) = cartesian_to_cylindrical($x, $y, $z);
+
+=item cartesian_to_spherical
+
+ ($rho, $theta, $phi) = cartesian_to_spherical($x, $y, $z);
+
+=item cylindrical_to_cartesian
+
+ ($x, $y, $z) = cylindrical_to_cartesian($rho, $theta, $z);
+
+=item cylindrical_to_spherical
+
+ ($rho_s, $theta, $phi) = cylindrical_to_spherical($rho_c, $theta, $z);
+
+Notice that when C<$z> is not 0 C<$rho_s> is not equal to C<$rho_c>.
+
+=item spherical_to_cartesian
+
+ ($x, $y, $z) = spherical_to_cartesian($rho, $theta, $phi);
+
+=item spherical_to_cylindrical
+
+ ($rho_c, $theta, $z) = spherical_to_cylindrical($rho_s, $theta, $phi);
+
+Notice that when C<$z> is not 0 C<$rho_c> is not equal to C<$rho_s>.
+
+=back
+
+=head1 GREAT CIRCLE DISTANCES
+
+You can compute spherical distances, called B<great circle distances>,
+by importing the C<great_circle_distance> function:
+
+ use Math::Trig 'great_circle_distance'
+
+ $distance = great_circle_distance($theta0, $phi0, $theta1, $phi, [, $rho]);
+
+The I<great circle distance> is the shortest distance between two
+points on a sphere. The distance is in C<$rho> units. The C<$rho> is
+optional, it defaults to 1 (the unit sphere), therefore the distance
+defaults to radians.
+
+=head1 EXAMPLES
+
+To calculate the distance between London (51.3N 0.5W) and Tokyo (35.7N
+139.8E) in kilometers:
+
+ use Math::Trig qw(great_circle_distance deg2rad);
+
+ # Notice the 90 - latitude: phi zero is at the North Pole.
+ @L = (deg2rad(-0.5), deg2rad(90 - 51.3));
+ @T = (deg2rad(139.8),deg2rad(90 - 35.7));
+
+ $km = great_circle_distance(@L, @T, 6378);
+
+The answer may be off by up to 0.3% because of the irregular (slightly
+aspherical) form of the Earth.
+
+=head1 BUGS
+
+Saying C<use Math::Trig;> exports many mathematical routines in the
+caller environment and even overrides some (C<sin>, C<cos>). This is
+construed as a feature by the Authors, actually... ;-)
+
+The code is not optimized for speed, especially because we use
+C<Math::Complex> and thus go quite near complex numbers while doing
+the computations even when the arguments are not. This, however,
+cannot be completely avoided if we want things like C<asin(2)> to give
+an answer instead of giving a fatal runtime error.
+
+=head1 AUTHORS
+
+Jarkko Hietaniemi <F<jhi@iki.fi>> and
+Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>>.
+
+=cut
+
+# eof
diff --git a/contrib/perl5/lib/Net/Ping.pm b/contrib/perl5/lib/Net/Ping.pm
new file mode 100644
index 000000000000..495b82f95bb4
--- /dev/null
+++ b/contrib/perl5/lib/Net/Ping.pm
@@ -0,0 +1,550 @@
+package Net::Ping;
+
+# Author: mose@ccsn.edu (Russell Mosemann)
+#
+# Authors of the original pingecho():
+# karrer@bernina.ethz.ch (Andreas Karrer)
+# pmarquess@bfsec.bt.co.uk (Paul Marquess)
+#
+# Copyright (c) 1996 Russell Mosemann. All rights reserved. This
+# program is free software; you may redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+require 5.002;
+require Exporter;
+
+use strict;
+use vars qw(@ISA @EXPORT $VERSION
+ $def_timeout $def_proto $max_datasize);
+use FileHandle;
+use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET
+ inet_aton sockaddr_in );
+use Carp;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(pingecho);
+$VERSION = 2.02;
+
+# Constants
+
+$def_timeout = 5; # Default timeout to wait for a reply
+$def_proto = "udp"; # Default protocol to use for pinging
+$max_datasize = 1024; # Maximum data bytes in a packet
+
+# Description: The pingecho() subroutine is provided for backward
+# compatibility with the original Net::Ping. It accepts a host
+# name/IP and an optional timeout in seconds. Create a tcp ping
+# object and try pinging the host. The result of the ping is returned.
+
+sub pingecho
+{
+ my ($host, # Name or IP number of host to ping
+ $timeout # Optional timeout in seconds
+ ) = @_;
+ my ($p); # A ping object
+
+ $p = Net::Ping->new("tcp", $timeout);
+ $p->ping($host); # Going out of scope closes the connection
+}
+
+# Description: The new() method creates a new ping object. Optional
+# parameters may be specified for the protocol to use, the timeout in
+# seconds and the size in bytes of additional data which should be
+# included in the packet.
+# After the optional parameters are checked, the data is constructed
+# and a socket is opened if appropriate. The object is returned.
+
+sub new
+{
+ my ($this,
+ $proto, # Optional protocol to use for pinging
+ $timeout, # Optional timeout in seconds
+ $data_size # Optional additional bytes of data
+ ) = @_;
+ my $class = ref($this) || $this;
+ my $self = {};
+ my ($cnt, # Count through data bytes
+ $min_datasize # Minimum data bytes required
+ );
+
+ bless($self, $class);
+
+ $proto = $def_proto unless $proto; # Determine the protocol
+ croak("Protocol for ping must be \"tcp\", \"udp\" or \"icmp\"")
+ unless $proto =~ m/^(tcp|udp|icmp)$/;
+ $self->{"proto"} = $proto;
+
+ $timeout = $def_timeout unless $timeout; # Determine the timeout
+ croak("Default timeout for ping must be greater than 0 seconds")
+ if $timeout <= 0;
+ $self->{"timeout"} = $timeout;
+
+ $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
+ $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
+ croak("Data for ping must be from $min_datasize to $max_datasize bytes")
+ if ($data_size < $min_datasize) || ($data_size > $max_datasize);
+ $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte
+ $self->{"data_size"} = $data_size;
+
+ $self->{"data"} = ""; # Construct data bytes
+ for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
+ {
+ $self->{"data"} .= chr($cnt % 256);
+ }
+
+ $self->{"seq"} = 0; # For counting packets
+ if ($self->{"proto"} eq "udp") # Open a socket
+ {
+ $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
+ croak("Can't udp protocol by name");
+ $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
+ croak("Can't get udp echo port by name");
+ $self->{"fh"} = FileHandle->new();
+ socket($self->{"fh"}, &PF_INET(), &SOCK_DGRAM(),
+ $self->{"proto_num"}) ||
+ croak("udp socket error - $!");
+ }
+ elsif ($self->{"proto"} eq "icmp")
+ {
+ croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS');
+ $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
+ croak("Can't get icmp protocol by name");
+ $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
+ $self->{"fh"} = FileHandle->new();
+ socket($self->{"fh"}, &PF_INET(), &SOCK_RAW(), $self->{"proto_num"}) ||
+ croak("icmp socket error - $!");
+ }
+ elsif ($self->{"proto"} eq "tcp") # Just a file handle for now
+ {
+ $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
+ croak("Can't get tcp protocol by name");
+ $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
+ croak("Can't get tcp echo port by name");
+ $self->{"fh"} = FileHandle->new();
+ }
+
+
+ return($self);
+}
+
+# Description: Ping a host name or IP number with an optional timeout.
+# First lookup the host, and return undef if it is not found. Otherwise
+# perform the specific ping method based on the protocol. Return the
+# result of the ping.
+
+sub ping
+{
+ my ($self,
+ $host, # Name or IP number of host to ping
+ $timeout # Seconds after which ping times out
+ ) = @_;
+ my ($ip, # Packed IP number of $host
+ $ret # The return value
+ );
+
+ croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
+ $timeout = $self->{"timeout"} unless $timeout;
+ croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
+
+ $ip = inet_aton($host);
+ return(undef) unless defined($ip); # Does host exist?
+
+ if ($self->{"proto"} eq "udp")
+ {
+ $ret = $self->ping_udp($ip, $timeout);
+ }
+ elsif ($self->{"proto"} eq "icmp")
+ {
+ $ret = $self->ping_icmp($ip, $timeout);
+ }
+ elsif ($self->{"proto"} eq "tcp")
+ {
+ $ret = $self->ping_tcp($ip, $timeout);
+ }
+ else
+ {
+ croak("Unknown protocol \"$self->{proto}\" in ping()");
+ }
+ return($ret);
+}
+
+sub ping_icmp
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+
+ my $ICMP_ECHOREPLY = 0; # ICMP packet types
+ my $ICMP_ECHO = 8;
+ my $icmp_struct = "C2 S3 A"; # Structure of a minimal ICMP packet
+ my $subcode = 0; # No ICMP subcode for ECHO and ECHOREPLY
+ my $flags = 0; # No special flags when opening a socket
+ my $port = 0; # No port with ICMP
+
+ my ($saddr, # sockaddr_in with port and ip
+ $checksum, # Checksum of ICMP packet
+ $msg, # ICMP packet to send
+ $len_msg, # Length of $msg
+ $rbits, # Read bits, filehandles for reading
+ $nfound, # Number of ready filehandles found
+ $finish_time, # Time ping should be finished
+ $done, # set to 1 when we are done
+ $ret, # Return value
+ $recv_msg, # Received message including IP header
+ $from_saddr, # sockaddr_in of sender
+ $from_port, # Port packet was sent from
+ $from_ip, # Packed IP of sender
+ $from_type, # ICMP type
+ $from_subcode, # ICMP subcode
+ $from_chk, # ICMP packet checksum
+ $from_pid, # ICMP packet id
+ $from_seq, # ICMP packet sequence
+ $from_msg # ICMP message
+ );
+
+ $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
+ $checksum = 0; # No checksum for starters
+ $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode,
+ $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+ $checksum = Net::Ping->checksum($msg);
+ $msg = pack($icmp_struct . $self->{"data_size"}, $ICMP_ECHO, $subcode,
+ $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
+ $len_msg = length($msg);
+ $saddr = sockaddr_in($port, $ip);
+ send($self->{"fh"}, $msg, $flags, $saddr); # Send the message
+
+ $rbits = "";
+ vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
+ $ret = 0;
+ $done = 0;
+ $finish_time = time() + $timeout; # Must be done by this time
+ while (!$done && $timeout > 0) # Keep trying if we have time
+ {
+ $nfound = select($rbits, undef, undef, $timeout); # Wait for packet
+ $timeout = $finish_time - time(); # Get remaining time
+ if (!defined($nfound)) # Hmm, a strange error
+ {
+ $ret = undef;
+ $done = 1;
+ }
+ elsif ($nfound) # Got a packet from somewhere
+ {
+ $recv_msg = "";
+ $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, $flags);
+ ($from_port, $from_ip) = sockaddr_in($from_saddr);
+ ($from_type, $from_subcode, $from_chk,
+ $from_pid, $from_seq, $from_msg) =
+ unpack($icmp_struct . $self->{"data_size"},
+ substr($recv_msg, length($recv_msg) - $len_msg,
+ $len_msg));
+ if (($from_type == $ICMP_ECHOREPLY) &&
+ ($from_ip eq $ip) &&
+ ($from_pid == $self->{"pid"}) && # Does the packet check out?
+ ($from_seq == $self->{"seq"}))
+ {
+ $ret = 1; # It's a winner
+ $done = 1;
+ }
+ }
+ else # Oops, timed out
+ {
+ $done = 1;
+ }
+ }
+ return($ret)
+}
+
+# Description: Do a checksum on the message. Basically sum all of
+# the short words and fold the high order bits into the low order bits.
+
+sub checksum
+{
+ my ($class,
+ $msg # The message to checksum
+ ) = @_;
+ my ($len_msg, # Length of the message
+ $num_short, # The number of short words in the message
+ $short, # One short word
+ $chk # The checksum
+ );
+
+ $len_msg = length($msg);
+ $num_short = $len_msg / 2;
+ $chk = 0;
+ foreach $short (unpack("S$num_short", $msg))
+ {
+ $chk += $short;
+ } # Add the odd byte in
+ $chk += unpack("C", substr($msg, $len_msg - 1, 1)) if $len_msg % 2;
+ $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
+ return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
+}
+
+# Description: Perform a tcp echo ping. Since a tcp connection is
+# host specific, we have to open and close each connection here. We
+# can't just leave a socket open. Because of the robust nature of
+# tcp, it will take a while before it gives up trying to establish a
+# connection. Therefore, we have to set the alarm to break out of the
+# connection sooner if the timeout expires. No data bytes are actually
+# sent since the successful establishment of a connection is proof
+# enough of the reachability of the remote host. Also, tcp is
+# expensive and doesn't need our help to add to the overhead.
+
+sub ping_tcp
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+ my ($saddr, # sockaddr_in with port and ip
+ $ret # The return value
+ );
+
+ socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
+ croak("tcp socket error - $!");
+ $saddr = sockaddr_in($self->{"port_num"}, $ip);
+
+ $SIG{'ALRM'} = sub { die };
+ alarm($timeout); # Interrupt connect() if we have to
+
+ $ret = 0; # Default to unreachable
+ eval <<'EOM' ;
+ return unless connect($self->{"fh"}, $saddr);
+ $ret = 1;
+EOM
+ alarm(0);
+ $self->{"fh"}->close();
+ return($ret);
+}
+
+# Description: Perform a udp echo ping. Construct a message of
+# at least the one-byte sequence number and any additional data bytes.
+# Send the message out and wait for a message to come back. If we
+# get a message, make sure all of its parts match. If they do, we are
+# done. Otherwise go back and wait for the message until we run out
+# of time. Return the result of our efforts.
+
+sub ping_udp
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+
+ my $flags = 0; # Nothing special on open
+
+ my ($saddr, # sockaddr_in with port and ip
+ $ret, # The return value
+ $msg, # Message to be echoed
+ $finish_time, # Time ping should be finished
+ $done, # Set to 1 when we are done pinging
+ $rbits, # Read bits, filehandles for reading
+ $nfound, # Number of ready filehandles found
+ $from_saddr, # sockaddr_in of sender
+ $from_msg, # Characters echoed by $host
+ $from_port, # Port message was echoed from
+ $from_ip # Packed IP number of sender
+ );
+
+ $saddr = sockaddr_in($self->{"port_num"}, $ip);
+ $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence
+ $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any
+ send($self->{"fh"}, $msg, $flags, $saddr); # Send it
+
+ $rbits = "";
+ vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
+ $ret = 0; # Default to unreachable
+ $done = 0;
+ $finish_time = time() + $timeout; # Ping needs to be done by then
+ while (!$done && $timeout > 0)
+ {
+ $nfound = select($rbits, undef, undef, $timeout); # Wait for response
+ $timeout = $finish_time - time(); # Get remaining time
+
+ if (!defined($nfound)) # Hmm, a strange error
+ {
+ $ret = undef;
+ $done = 1;
+ }
+ elsif ($nfound) # A packet is waiting
+ {
+ $from_msg = "";
+ $from_saddr = recv($self->{"fh"}, $from_msg, 1500, $flags);
+ ($from_port, $from_ip) = sockaddr_in($from_saddr);
+ if (($from_ip eq $ip) && # Does the packet check out?
+ ($from_port == $self->{"port_num"}) &&
+ ($from_msg eq $msg))
+ {
+ $ret = 1; # It's a winner
+ $done = 1;
+ }
+ }
+ else # Oops, timed out
+ {
+ $done = 1;
+ }
+ }
+ return($ret);
+}
+
+# Description: Close the connection unless we are using the tcp
+# protocol, since it will already be closed.
+
+sub close
+{
+ my ($self) = @_;
+
+ $self->{"fh"}->close() unless $self->{"proto"} eq "tcp";
+}
+
+
+1;
+__END__
+
+=head1 NAME
+
+Net::Ping - check a remote host for reachability
+
+=head1 SYNOPSIS
+
+ use Net::Ping;
+
+ $p = Net::Ping->new();
+ print "$host is alive.\n" if $p->ping($host);
+ $p->close();
+
+ $p = Net::Ping->new("icmp");
+ foreach $host (@host_array)
+ {
+ print "$host is ";
+ print "NOT " unless $p->ping($host, 2);
+ print "reachable.\n";
+ sleep(1);
+ }
+ $p->close();
+
+ $p = Net::Ping->new("tcp", 2);
+ while ($stop_time > time())
+ {
+ print "$host not reachable ", scalar(localtime()), "\n"
+ unless $p->ping($host);
+ sleep(300);
+ }
+ undef($p);
+
+ # For backward compatibility
+ print "$host is alive.\n" if pingecho($host);
+
+=head1 DESCRIPTION
+
+This module contains methods to test the reachability of remote
+hosts on a network. A ping object is first created with optional
+parameters, a variable number of hosts may be pinged multiple
+times and then the connection is closed.
+
+You may choose one of three different protocols to use for the ping.
+With the "tcp" protocol the ping() method attempts to establish a
+connection to the remote host's echo port. If the connection is
+successfully established, the remote host is considered reachable. No
+data is actually echoed. This protocol does not require any special
+privileges but has higher overhead than the other two protocols.
+
+Specifying the "udp" protocol causes the ping() method to send a udp
+packet to the remote host's echo port. If the echoed packet is
+received from the remote host and the received packet contains the
+same data as the packet that was sent, the remote host is considered
+reachable. This protocol does not require any special privileges.
+
+If the "icmp" protocol is specified, the ping() method sends an icmp
+echo message to the remote host, which is what the UNIX ping program
+does. If the echoed message is received from the remote host and
+the echoed information is correct, the remote host is considered
+reachable. Specifying the "icmp" protocol requires that the program
+be run as root or that the program be setuid to root.
+
+=head2 Functions
+
+=over 4
+
+=item Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);
+
+Create a new ping object. All of the parameters are optional. $proto
+specifies the protocol to use when doing a ping. The current choices
+are "tcp", "udp" or "icmp". The default is "udp".
+
+If a default timeout ($def_timeout) in seconds is provided, it is used
+when a timeout is not given to the ping() method (below). The timeout
+must be greater than 0 and the default, if not specified, is 5 seconds.
+
+If the number of data bytes ($bytes) is given, that many data bytes
+are included in the ping packet sent to the remote host. The number of
+data bytes is ignored if the protocol is "tcp". The minimum (and
+default) number of data bytes is 1 if the protocol is "udp" and 0
+otherwise. The maximum number of data bytes that can be specified is
+1024.
+
+=item $p->ping($host [, $timeout]);
+
+Ping the remote host and wait for a response. $host can be either the
+hostname or the IP number of the remote host. The optional timeout
+must be greater than 0 seconds and defaults to whatever was specified
+when the ping object was created. If the hostname cannot be found or
+there is a problem with the IP number, undef is returned. Otherwise,
+1 is returned if the host is reachable and 0 if it is not. For all
+practical purposes, undef and 0 and can be treated as the same case.
+
+=item $p->close();
+
+Close the network connection for this ping object. The network
+connection is also closed by "undef $p". The network connection is
+automatically closed if the ping object goes out of scope (e.g. $p is
+local to a subroutine and you leave the subroutine).
+
+=item pingecho($host [, $timeout]);
+
+To provide backward compatibility with the previous version of
+Net::Ping, a pingecho() subroutine is available with the same
+functionality as before. pingecho() uses the tcp protocol. The
+return values and parameters are the same as described for the ping()
+method. This subroutine is obsolete and may be removed in a future
+version of Net::Ping.
+
+=back
+
+=head1 WARNING
+
+pingecho() or a ping object with the tcp protocol use alarm() to
+implement the timeout. So, don't use alarm() in your program while
+you are using pingecho() or a ping object with the tcp protocol. The
+udp and icmp protocols do not use alarm() to implement the timeout.
+
+=head1 NOTES
+
+There will be less network overhead (and some efficiency in your
+program) if you specify either the udp or the icmp protocol. The tcp
+protocol will generate 2.5 times or more traffic for each ping than
+either udp or icmp. If many hosts are pinged frequently, you may wish
+to implement a small wait (e.g. 25ms or more) between each ping to
+avoid flooding your network with packets.
+
+The icmp protocol requires that the program be run as root or that it
+be setuid to root. The tcp and udp protocols do not require special
+privileges, but not all network devices implement the echo protocol
+for tcp or udp.
+
+Local hosts should normally respond to pings within milliseconds.
+However, on a very congested network it may take up to 3 seconds or
+longer to receive an echo packet from the remote host. If the timeout
+is set too low under these conditions, it will appear that the remote
+host is not reachable (which is almost the truth).
+
+Reachability doesn't necessarily mean that the remote host is actually
+functioning beyond its ability to echo packets.
+
+Because of a lack of anything better, this module uses its own
+routines to pack and unpack ICMP packets. It would be better for a
+separate module to be written which understands all of the different
+kinds of ICMP packets.
+
+=cut
diff --git a/contrib/perl5/lib/Net/hostent.pm b/contrib/perl5/lib/Net/hostent.pm
new file mode 100644
index 000000000000..96b090dae5a0
--- /dev/null
+++ b/contrib/perl5/lib/Net/hostent.pm
@@ -0,0 +1,149 @@
+package Net::hostent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @EXPORT = qw(gethostbyname gethostbyaddr gethost);
+ @EXPORT_OK = qw(
+ $h_name @h_aliases
+ $h_addrtype $h_length
+ @h_addr_list $h_addr
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'Net::hostent' => [
+ name => '$',
+ aliases => '@',
+ addrtype => '$',
+ 'length' => '$',
+ addr_list => '@',
+];
+
+sub addr { shift->addr_list->[0] }
+
+sub populate (@) {
+ return unless @_;
+ my $hob = new();
+ $h_name = $hob->[0] = $_[0];
+ @h_aliases = @{ $hob->[1] } = split ' ', $_[1];
+ $h_addrtype = $hob->[2] = $_[2];
+ $h_length = $hob->[3] = $_[3];
+ $h_addr = $_[4];
+ @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ];
+ return $hob;
+}
+
+sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) }
+
+sub gethostbyaddr ($;$) {
+ my ($addr, $addrtype);
+ $addr = shift;
+ require Socket unless @_;
+ $addrtype = @_ ? shift : Socket::AF_INET();
+ populate(CORE::gethostbyaddr($addr, $addrtype))
+}
+
+sub gethost($) {
+ if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) {
+ require Socket;
+ &gethostbyaddr(Socket::inet_aton(shift));
+ } else {
+ &gethostbyname;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Net::hostent - by-name interface to Perl's built-in gethost*() functions
+
+=head1 SYNOPSIS
+
+ use Net::hostnet;
+
+=head1 DESCRIPTION
+
+This module's default exports override the core gethostbyname() and
+gethostbyaddr() functions, replacing them with versions that return
+"Net::hostent" objects. This object has methods that return the similarly
+named structure field name from the C's hostent structure from F<netdb.h>;
+namely name, aliases, addrtype, length, and addr_list. The aliases and
+addr_list methods return array reference, the rest scalars. The addr
+method is equivalent to the zeroth element in the addr_list array
+reference.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<h_>. Thus, C<$host_obj-E<gt>name()> corresponds to
+$h_name if you import the fields. Array references are available as
+regular array variables, so for example C<@{ $host_obj-E<gt>aliases()
+}> would be simply @h_aliases.
+
+The gethost() funtion is a simple front-end that forwards a numeric
+argument to gethostbyaddr() by way of Socket::inet_aton, and the rest
+to gethostbyname().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 EXAMPLES
+
+ use Net::hostent;
+ use Socket;
+
+ @ARGV = ('netscape.com') unless @ARGV;
+
+ for $host ( @ARGV ) {
+
+ unless ($h = gethost($host)) {
+ warn "$0: no such host: $host\n";
+ next;
+ }
+
+ printf "\n%s is %s%s\n",
+ $host,
+ lc($h->name) eq lc($host) ? "" : "*really* ",
+ $h->name;
+
+ print "\taliases are ", join(", ", @{$h->aliases}), "\n"
+ if @{$h->aliases};
+
+ if ( @{$h->addr_list} > 1 ) {
+ my $i;
+ for $addr ( @{$h->addr_list} ) {
+ printf "\taddr #%d is [%s]\n", $i++, inet_ntoa($addr);
+ }
+ } else {
+ printf "\taddress is [%s]\n", inet_ntoa($h->addr);
+ }
+
+ if ($h = gethostbyaddr($h->addr)) {
+ if (lc($h->name) ne lc($host)) {
+ printf "\tThat addr reverses to host %s!\n", $h->name;
+ $host = $h->name;
+ redo;
+ }
+ }
+ }
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/contrib/perl5/lib/Net/netent.pm b/contrib/perl5/lib/Net/netent.pm
new file mode 100644
index 000000000000..b82447cad71a
--- /dev/null
+++ b/contrib/perl5/lib/Net/netent.pm
@@ -0,0 +1,167 @@
+package Net::netent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @EXPORT = qw(getnetbyname getnetbyaddr getnet);
+ @EXPORT_OK = qw(
+ $n_name @n_aliases
+ $n_addrtype $n_net
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'Net::netent' => [
+ name => '$',
+ aliases => '@',
+ addrtype => '$',
+ net => '$',
+];
+
+sub populate (@) {
+ return unless @_;
+ my $nob = new();
+ $n_name = $nob->[0] = $_[0];
+ @n_aliases = @{ $nob->[1] } = split ' ', $_[1];
+ $n_addrtype = $nob->[2] = $_[2];
+ $n_net = $nob->[3] = $_[3];
+ return $nob;
+}
+
+sub getnetbyname ($) { populate(CORE::getnetbyname(shift)) }
+
+sub getnetbyaddr ($;$) {
+ my ($net, $addrtype);
+ $net = shift;
+ require Socket if @_;
+ $addrtype = @_ ? shift : Socket::AF_INET();
+ populate(CORE::getnetbyaddr($net, $addrtype))
+}
+
+sub getnet($) {
+ if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) {
+ require Socket;
+ &getnetbyaddr(Socket::inet_aton(shift));
+ } else {
+ &getnetbyname;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Net::netent - by-name interface to Perl's built-in getnet*() functions
+
+=head1 SYNOPSIS
+
+ use Net::netent qw(:FIELDS);
+ getnetbyname("loopback") or die "bad net";
+ printf "%s is %08X\n", $n_name, $n_net;
+
+ use Net::netent;
+
+ $n = getnetbyname("loopback") or die "bad net";
+ { # there's gotta be a better way, eh?
+ @bytes = unpack("C4", pack("N", $n->net));
+ shift @bytes while @bytes && $bytes[0] == 0;
+ }
+ printf "%s is %08X [%d.%d.%d.%d]\n", $n->name, $n->net, @bytes;
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getnetbyname() and
+getnetbyaddr() functions, replacing them with versions that return
+"Net::netent" objects. This object has methods that return the similarly
+named structure field name from the C's netent structure from F<netdb.h>;
+namely name, aliases, addrtype, and net. The aliases
+method returns an array reference, the rest scalars.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<n_>. Thus, C<$net_obj-E<gt>name()> corresponds to
+$n_name if you import the fields. Array references are available as
+regular array variables, so for example C<@{ $net_obj-E<gt>aliases()
+}> would be simply @n_aliases.
+
+The getnet() funtion is a simple front-end that forwards a numeric
+argument to getnetbyaddr(), and the rest
+to getnetbyname().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 EXAMPLES
+
+The getnet() functions do this in the Perl core:
+
+ sv_setiv(sv, (I32)nent->n_net);
+
+The gethost() functions do this in the Perl core:
+
+ sv_setpvn(sv, hent->h_addr, len);
+
+That means that the address comes back in binary for the
+host functions, and as a regular perl integer for the net ones.
+This seems a bug, but here's how to deal with it:
+
+ use strict;
+ use Socket;
+ use Net::netent;
+
+ @ARGV = ('loopback') unless @ARGV;
+
+ my($n, $net);
+
+ for $net ( @ARGV ) {
+
+ unless ($n = getnetbyname($net)) {
+ warn "$0: no such net: $net\n";
+ next;
+ }
+
+ printf "\n%s is %s%s\n",
+ $net,
+ lc($n->name) eq lc($net) ? "" : "*really* ",
+ $n->name;
+
+ print "\taliases are ", join(", ", @{$n->aliases}), "\n"
+ if @{$n->aliases};
+
+ # this is stupid; first, why is this not in binary?
+ # second, why am i going through these convolutions
+ # to make it looks right
+ {
+ my @a = unpack("C4", pack("N", $n->net));
+ shift @a while @a && $a[0] == 0;
+ printf "\taddr is %s [%d.%d.%d.%d]\n", $n->net, @a;
+ }
+
+ if ($n = getnetbyaddr($n->net)) {
+ if (lc($n->name) ne lc($net)) {
+ printf "\tThat addr reverses to net %s!\n", $n->name;
+ $net = $n->name;
+ redo;
+ }
+ }
+ }
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/contrib/perl5/lib/Net/protoent.pm b/contrib/perl5/lib/Net/protoent.pm
new file mode 100644
index 000000000000..737ff5a33bcd
--- /dev/null
+++ b/contrib/perl5/lib/Net/protoent.pm
@@ -0,0 +1,94 @@
+package Net::protoent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @EXPORT = qw(getprotobyname getprotobynumber getprotoent);
+ @EXPORT_OK = qw( $p_name @p_aliases $p_proto );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'Net::protoent' => [
+ name => '$',
+ aliases => '@',
+ proto => '$',
+];
+
+sub populate (@) {
+ return unless @_;
+ my $pob = new();
+ $p_name = $pob->[0] = $_[0];
+ @p_aliases = @{ $pob->[1] } = split ' ', $_[1];
+ $p_proto = $pob->[2] = $_[2];
+ return $pob;
+}
+
+sub getprotoent ( ) { populate(CORE::getprotoent()) }
+sub getprotobyname ($) { populate(CORE::getprotobyname(shift)) }
+sub getprotobynumber ($) { populate(CORE::getprotobynumber(shift)) }
+
+sub getproto ($;$) {
+ no strict 'refs';
+ return &{'getprotoby' . ($_[0]=~/^\d+$/ ? 'number' : 'name')}(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::protoent - by-name interface to Perl's built-in getproto*() functions
+
+=head1 SYNOPSIS
+
+ use Net::protoent;
+ $p = getprotobyname(shift || 'tcp') || die "no proto";
+ printf "proto for %s is %d, aliases are %s\n",
+ $p->name, $p->proto, "@{$p->aliases}";
+
+ use Net::protoent qw(:FIELDS);
+ getprotobyname(shift || 'tcp') || die "no proto";
+ print "proto for $p_name is $p_proto, aliases are @p_aliases\n";
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getprotoent(),
+getprotobyname(), and getnetbyport() functions, replacing them with
+versions that return "Net::protoent" objects. They take default
+second arguments of "tcp". This object has methods that return the
+similarly named structure field name from the C's protoent structure
+from F<netdb.h>; namely name, aliases, and proto. The aliases method
+returns an array reference, the rest scalars.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<p_>. Thus, C<$proto_obj-E<gt>name()> corresponds to
+$p_name if you import the fields. Array references are available as
+regular array variables, so for example C<@{ $proto_obj-E<gt>aliases()
+}> would be simply @p_aliases.
+
+The getproto() function is a simple front-end that forwards a numeric
+argument to getprotobyport(), and the rest to getprotobyname().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/contrib/perl5/lib/Net/servent.pm b/contrib/perl5/lib/Net/servent.pm
new file mode 100644
index 000000000000..fb85dd04bfa6
--- /dev/null
+++ b/contrib/perl5/lib/Net/servent.pm
@@ -0,0 +1,111 @@
+package Net::servent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @EXPORT = qw(getservbyname getservbyport getservent getserv);
+ @EXPORT_OK = qw( $s_name @s_aliases $s_port $s_proto );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'Net::servent' => [
+ name => '$',
+ aliases => '@',
+ port => '$',
+ proto => '$',
+];
+
+sub populate (@) {
+ return unless @_;
+ my $sob = new();
+ $s_name = $sob->[0] = $_[0];
+ @s_aliases = @{ $sob->[1] } = split ' ', $_[1];
+ $s_port = $sob->[2] = $_[2];
+ $s_proto = $sob->[3] = $_[3];
+ return $sob;
+}
+
+sub getservent ( ) { populate(CORE::getservent()) }
+sub getservbyname ($;$) { populate(CORE::getservbyname(shift,shift||'tcp')) }
+sub getservbyport ($;$) { populate(CORE::getservbyport(shift,shift||'tcp')) }
+
+sub getserv ($;$) {
+ no strict 'refs';
+ return &{'getservby' . ($_[0]=~/^\d+$/ ? 'port' : 'name')}(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::servent - by-name interface to Perl's built-in getserv*() functions
+
+=head1 SYNOPSIS
+
+ use Net::servent;
+ $s = getservbyname(shift || 'ftp') || die "no service";
+ printf "port for %s is %s, aliases are %s\n",
+ $s->name, $s->port, "@{$s->aliases}";
+
+ use Net::servent qw(:FIELDS);
+ getservbyname(shift || 'ftp') || die "no service";
+ print "port for $s_name is $s_port, aliases are @s_aliases\n";
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getservent(),
+getservbyname(), and
+getnetbyport() functions, replacing them with versions that return
+"Net::servent" objects. They take default second arguments of "tcp". This object has methods that return the similarly
+named structure field name from the C's servent structure from F<netdb.h>;
+namely name, aliases, port, and proto. The aliases
+method returns an array reference, the rest scalars.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<n_>. Thus, C<$serv_obj-E<gt>name()> corresponds to
+$s_name if you import the fields. Array references are available as
+regular array variables, so for example C<@{ $serv_obj-E<gt>aliases()
+}> would be simply @s_aliases.
+
+The getserv() function is a simple front-end that forwards a numeric
+argument to getservbyport(), and the rest to getservbyname().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 EXAMPLES
+
+ use Net::servent qw(:FIELDS);
+
+ while (@ARGV) {
+ my ($service, $proto) = ((split m!/!, shift), 'tcp');
+ my $valet = getserv($service, $proto);
+ unless ($valet) {
+ warn "$0: No service: $service/$proto\n"
+ next;
+ }
+ printf "service $service/$proto is port %d\n", $valet->port;
+ print "alias are @s_aliases\n" if @s_aliases;
+ }
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/contrib/perl5/lib/Pod/Functions.pm b/contrib/perl5/lib/Pod/Functions.pm
new file mode 100644
index 000000000000..3cc9b385a004
--- /dev/null
+++ b/contrib/perl5/lib/Pod/Functions.pm
@@ -0,0 +1,296 @@
+package Pod::Functions;
+
+#:vi:set ts=20
+
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
+
+%Type_Description = (
+ 'ARRAY' => 'Functions for real @ARRAYs',
+ 'Binary' => 'Functions for fixed length data or records',
+ 'File' => 'Functions for filehandles, files, or directories',
+ 'Flow' => 'Keywords related to control flow of your perl program',
+ 'HASH' => 'Functions for real %HASHes',
+ 'I/O' => 'Input and output functions',
+ 'LIST' => 'Functions for list data',
+ 'Math' => 'Numeric functions',
+ 'Misc' => 'Miscellaneous functions',
+ 'Modules' => 'Keywords related to perl modules',
+ 'Network' => 'Fetching network info',
+ 'Objects' => 'Keywords related to classes and object-orientedness',
+ 'Process' => 'Functions for processes and process groups',
+ 'Regexp' => 'Regular expressions and pattern matching',
+ 'Socket' => 'Low-level socket functions',
+ 'String' => 'Functions for SCALARs or strings',
+ 'SysV' => 'System V interprocess communication functions',
+ 'Time' => 'Time-related functions',
+ 'User' => 'Fetching user and group info',
+ 'Namespace' => 'Keywords altering or affecting scoping of identifiers',
+);
+
+@Type_Order = qw{
+ String
+ Regexp
+ Math
+ ARRAY
+ LIST
+ HASH
+ I/O
+ Binary
+ File
+ Flow
+ Namespace
+ Misc
+ Process
+ Modules
+ Objects
+ Socket
+ SysV
+ User
+ Network
+ Time
+};
+
+while (<DATA>) {
+ chomp;
+ s/#.*//;
+ next unless $_;
+ ($name, $type, $text) = split " ", $_, 3;
+ $Type{$name} = $type;
+ $Flavor{$name} = $text;
+ for $type ( split /[,\s]+/, $type ) {
+ push @{$Kinds{$type}}, $name;
+ }
+}
+
+unless (caller) {
+ foreach $type ( @Type_Order ) {
+ $list = join(", ", sort @{$Kinds{$type}});
+ $typedesc = $Type_Description{$type} . ":";
+ write;
+ }
+}
+
+format =
+
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $typedesc
+~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $typedesc
+ ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $list
+.
+
+1
+
+__DATA__
+-X File a file test (-r, -x, etc)
+abs Math absolute value function
+accept Socket accept an incoming socket connect
+alarm Process schedule a SIGALRM
+atan2 Math arctangent of Y/X
+bind Socket binds an address to a socket
+binmode I/O prepare binary files on old systems
+bless Objects create an object
+caller Flow,Namespace get context of the current subroutine call
+chdir File change your current working directory
+chmod File changes the permissions on a list of files
+chomp String remove a trailing record separator from a string
+chop String remove the last character from a string
+chown File change the owership on a list of files
+chr String get character this number represents
+chroot File make directory new root for path lookups
+close I/O close file (or pipe or socket) handle
+closedir I/O close directory handle
+connect Socket connect to a remove socket
+continue Flow optional trailing block in a while or foreach
+cos Math cosine function
+crypt String one-way passwd-style encryption
+dbmclose Objects,I/O breaks binding on a tied dbm file
+dbmopen Objects,I/O create binding on a tied dbm file
+defined Misc test whether a value, variable, or function is defined
+delete HASH deletes a value from a hash
+die I/O,Flow raise an exception or bail out
+do Flow,Modules turn a BLOCK into a TERM
+dump Misc,Flow create an immediate core dump
+each HASH retrieve the next key/value pair from a hash
+endgrent User be done using group file
+endhostent User be done using hosts file
+endnetent User be done using networks file
+endprotoent Network be done using protocols file
+endpwent User be done using passwd file
+endservent Network be done using services file
+eof I/O test a filehandle for its end
+eval Flow,Misc catch exceptions or compile code
+exec Process abandon this program to run another
+exists HASH test whether a hash key is present
+exit Flow terminate this program
+exp Math raise I<e> to a power
+fcntl File file control system all
+fileno I/O return file descriptor from filehandle
+flock I/O lock an entire file with an advisory lock
+fork Process create a new process just like this one
+format I/O declare a picture format with use by the write() function
+formline Misc internal function used for formats
+getc I/O get the next character from the filehandle
+getgrent User get next group record
+getgrgid User get group record given group user ID
+getgrnam User get group record given group name
+gethostbyaddr Network get host record given its address
+gethostbyname Network get host record given name
+gethostent Network get next hosts record
+getlogin User return who logged in at this tty
+getnetbyaddr Network get network record given its address
+getnetbyname Network get networks record given name
+getnetent Network get next networks record
+getpeername Socket find the other hend of a socket connection
+getpgrp Process get process group
+getppid Process get parent process ID
+getpriority Process get current nice value
+getprotobyname Network get protocol record given name
+getprotobynumber Network get protocol record numeric protocol
+getprotoent Network get next protocols record
+getpwent User get next passwd record
+getpwnam User get passwd record given user login name
+getpwuid User get passwd record given user ID
+getservbyname Network get services record given its name
+getservbyport Network get services record given numeric port
+getservent Network get next services record
+getsockname Socket retrieve the sockaddr for a given socket
+getsockopt Socket get socket options on a given socket
+glob File expand filenames using wildcards
+gmtime Time convert UNIX time into record or string using Greenwich time
+goto Flow create spaghetti code
+grep LIST locate elements in a list test true against a given criterion
+hex Math,String convert a string to a hexadecimal number
+import Modules,Namespace patch a module's namespace into your own
+index String find a substring within a string
+int Math get the integer portion of a number
+ioctl File system-dependent device control system call
+join LIST join a list into a string using a separator
+keys HASH retrieve list of indices from a hash
+kill Process send a signal to a process or process group
+last Flow exit a block prematurely
+lc String return lower-case version of a string
+lcfirst String return a string with just the next letter in lower case
+length String return the number of bytes in a string
+link File create a hard link in the filesytem
+listen Socket register your socket as a server
+local Misc,Namespace create a temporary value for a global variable (dynamic scoping)
+localtime Time convert UNIX time into record or string using local time
+log Math retrieve the natural logarithm for a number
+lstat File stat a symbolic link
+m// Regexp match a string with a regular expression pattern
+map LIST apply a change to a list to get back a new list with the changes
+mkdir File create a directory
+msgctl SysV SysV IPC message control operations
+msgget SysV get SysV IPC message queue
+msgrcv SysV receive a SysV IPC message from a message queue
+msgsnd SysV send a SysV IPC message to a message queue
+my Misc,Namespace declare and assign a local variable (lexical scoping)
+next Flow iterate a block prematurely
+no Modules unimport some module symbols or semantics at compile time
+package Modules,Objects,Namespace declare a separate global namespace
+prototype Flow,Misc get the prototype (if any) of a subroutine
+oct String,Math convert a string to an octal number
+open File open a file, pipe, or descriptor
+opendir File open a directory
+ord String find a character's numeric representation
+pack Binary,String convert a list into a binary representation
+pipe Process open a pair of connected filehandles
+pop ARRAY remove the last element from an array and return it
+pos Regexp find or set the offset for the last/next m//g search
+print I/O output a list to a filehandle
+printf I/O output a formatted list to a filehandle
+push ARRAY append one or more elements to an array
+q/STRING/ String singly quote a string
+qq/STRING/ String doubly quote a string
+quotemeta Regexp quote regular expression magic characters
+qw/STRING/ LIST quote a list of words
+qx/STRING/ Process backquote quote a string
+rand Math retrieve the next pseudorandom number
+read I/O,Binary fixed-length buffered input from a filehandle
+readdir I/O get a directory from a directory handle
+readlink File determine where a symbolic link is pointing
+recv Socket receive a message over a Socket
+redo Flow start this loop iteration over again
+ref Objects find out the type of thing being referenced
+rename File change a filename
+require Modules load in external functions from a library at runtime
+reset Misc clear all variables of a given name
+return Flow get out of a function early
+reverse String,LIST flip a string or a list
+rewinddir I/O reset directory handle
+rindex String right-to-left substring search
+rmdir File remove a directory
+s/// Regexp replace a pattern with a string
+scalar Misc force a scalar context
+seek I/O reposition file pointer for random-access I/O
+seekdir I/O reposition directory pointer
+select I/O reset default output or do I/O multiplexing
+semctl SysV SysV semaphore control operations
+semget SysV get set of SysV semaphores
+semop SysV SysV semaphore operations
+send Socket send a message over a socket
+setgrent User prepare group file for use
+sethostent Network prepare hosts file for use
+setnetent Network prepare networks file for use
+setpgrp Process set the process group of a process
+setpriority Process set a process's nice value
+setprotoent Network prepare protocols file for use
+setpwent User prepare passwd file for use
+setservent Network prepare services file for use
+setsockopt Socket set some socket options
+shift ARRAY remove the first element of an array, and return it
+shmctl SysV SysV shared memory operations
+shmget SysV get SysV shared memory segment identifier
+shmread SysV read SysV shared memory
+shmwrite SysV write SysV shared memory
+shutdown Socket close down just half of a socket connection
+sin Math return the sin of a number
+sleep Process block for some number of seconds
+socket Socket create a socket
+socketpair Socket create a pair of sockets
+sort LIST sort a list of values
+splice ARRAY add or remove elements anywhere in an array
+split Regexp split up a string using a regexp delimiter
+sprintf String formatted print into a string
+sqrt Math square root function
+srand Math seed the random number generator
+stat File get a file's status information
+study Regexp optimize input data for repeated searches
+sub Flow declare a subroutine, possibly anonymously
+substr String get or alter a portion of a stirng
+symlink File create a symbolic link to a file
+syscall I/O,Binary execute an arbitrary system call
+sysread I/O,Binary fixed-length unbuffered input from a filehandle
+system Process run a separate program
+syswrite I/O,Binary fixed-length unbuffered output to a filehandle
+tell I/O get current seekpointer on a filehandle
+telldir I/O get current seekpointer on a directory handle
+tie Objects bind a variable to an object class
+time Time return number of seconds since 1970
+times Process,Time return elapsed time for self and child processes
+tr/// String transliterate a string
+truncate I/O shorten a file
+uc String return upper-case version of a string
+ucfirst String return a string with just the next letter in upper case
+umask File set file creation mode mask
+undef Misc remove a variable or function definition
+unlink File remove one link to a file
+unpack Binary,LIST convert binary structure into normal perl variables
+unshift ARRAY prepend more elements to the beginning of a list
+untie Objects break a tie binding to a variable
+use Modules,Namespace load a module and import its namespace
+use Objects load in a module at compile time
+utime File set a file's last access and modify times
+values HASH return a list of the values in a hash
+vec Binary test or set particular bits in a string
+wait Process wait for any child process to die
+waitpid Process wait for a particular child process to die
+wantarray Misc,Flow get list vs array context of current subroutine call
+warn I/O print debugging info
+write I/O print a picture record
+y/// String transliterate a string
diff --git a/contrib/perl5/lib/Pod/Html.pm b/contrib/perl5/lib/Pod/Html.pm
new file mode 100644
index 000000000000..5d2e07b2af01
--- /dev/null
+++ b/contrib/perl5/lib/Pod/Html.pm
@@ -0,0 +1,1571 @@
+package Pod::Html;
+
+use Pod::Functions;
+use Getopt::Long; # package for handling command-line parameters
+require Exporter;
+use vars qw($VERSION);
+$VERSION = 1.01;
+@ISA = Exporter;
+@EXPORT = qw(pod2html htmlify);
+use Cwd;
+
+use Carp;
+
+use strict;
+
+use Config;
+
+=head1 NAME
+
+Pod::Html - module to convert pod files to HTML
+
+=head1 SYNOPSIS
+
+ use Pod::Html;
+ pod2html([options]);
+
+=head1 DESCRIPTION
+
+Converts files from pod format (see L<perlpod>) to HTML format. It
+can automatically generate indexes and cross-references, and it keeps
+a cache of things it knows how to cross-reference.
+
+=head1 ARGUMENTS
+
+Pod::Html takes the following arguments:
+
+=over 4
+
+=item help
+
+ --help
+
+Displays the usage message.
+
+=item htmlroot
+
+ --htmlroot=name
+
+Sets the base URL for the HTML files. When cross-references are made,
+the HTML root is prepended to the URL.
+
+=item infile
+
+ --infile=name
+
+Specify the pod file to convert. Input is taken from STDIN if no
+infile is specified.
+
+=item outfile
+
+ --outfile=name
+
+Specify the HTML file to create. Output goes to STDOUT if no outfile
+is specified.
+
+=item podroot
+
+ --podroot=name
+
+Specify the base directory for finding library pods.
+
+=item podpath
+
+ --podpath=name:...:name
+
+Specify which subdirectories of the podroot contain pod files whose
+HTML converted forms can be linked-to in cross-references.
+
+=item libpods
+
+ --libpods=name:...:name
+
+List of page names (eg, "perlfunc") which contain linkable C<=item>s.
+
+=item netscape
+
+ --netscape
+
+Use Netscape HTML directives when applicable.
+
+=item nonetscape
+
+ --nonetscape
+
+Do not use Netscape HTML directives (default).
+
+=item index
+
+ --index
+
+Generate an index at the top of the HTML file (default behaviour).
+
+=item noindex
+
+ --noindex
+
+Do not generate an index at the top of the HTML file.
+
+
+=item recurse
+
+ --recurse
+
+Recurse into subdirectories specified in podpath (default behaviour).
+
+=item norecurse
+
+ --norecurse
+
+Do not recurse into subdirectories specified in podpath.
+
+=item title
+
+ --title=title
+
+Specify the title of the resulting HTML file.
+
+=item verbose
+
+ --verbose
+
+Display progress messages.
+
+=back
+
+=head1 EXAMPLE
+
+ pod2html("pod2html",
+ "--podpath=lib:ext:pod:vms",
+ "--podroot=/usr/src/perl",
+ "--htmlroot=/perl/nmanual",
+ "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
+ "--recurse",
+ "--infile=foo.pod",
+ "--outfile=/perl/nmanual/foo.html");
+
+=head1 AUTHOR
+
+Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
+
+=head1 BUGS
+
+Has trouble with C<> etc in = commands.
+
+=head1 SEE ALSO
+
+L<perlpod>
+
+=head1 COPYRIGHT
+
+This program is distributed under the Artistic License.
+
+=cut
+
+my $dircache = "pod2html-dircache";
+my $itemcache = "pod2html-itemcache";
+
+my @begin_stack = (); # begin/end stack
+
+my @libpods = (); # files to search for links from C<> directives
+my $htmlroot = "/"; # http-server base directory from which all
+ # relative paths in $podpath stem.
+my $htmlfile = ""; # write to stdout by default
+my $podfile = ""; # read from stdin by default
+my @podpath = (); # list of directories containing library pods.
+my $podroot = "."; # filesystem base directory from which all
+ # relative paths in $podpath stem.
+my $recurse = 1; # recurse on subdirectories in $podpath.
+my $verbose = 0; # not verbose by default
+my $doindex = 1; # non-zero if we should generate an index
+my $listlevel = 0; # current list depth
+my @listitem = (); # stack of HTML commands to use when a =item is
+ # encountered. the top of the stack is the
+ # current list.
+my @listdata = (); # similar to @listitem, but for the text after
+ # an =item
+my @listend = (); # similar to @listitem, but the text to use to
+ # end the list.
+my $ignore = 1; # whether or not to format text. we don't
+ # format text until we hit our first pod
+ # directive.
+
+my %items_named = (); # for the multiples of the same item in perlfunc
+my @items_seen = ();
+my $netscape = 0; # whether or not to use netscape directives.
+my $title; # title to give the pod(s)
+my $top = 1; # true if we are at the top of the doc. used
+ # to prevent the first <HR> directive.
+my $paragraph; # which paragraph we're processing (used
+ # for error messages)
+my %pages = (); # associative array used to find the location
+ # of pages referenced by L<> links.
+my %sections = (); # sections within this page
+my %items = (); # associative array used to find the location
+ # of =item directives referenced by C<> links
+my $Is83; # is dos with short filenames (8.3)
+
+sub init_globals {
+$dircache = "pod2html-dircache";
+$itemcache = "pod2html-itemcache";
+
+@begin_stack = (); # begin/end stack
+
+@libpods = (); # files to search for links from C<> directives
+$htmlroot = "/"; # http-server base directory from which all
+ # relative paths in $podpath stem.
+$htmlfile = ""; # write to stdout by default
+$podfile = ""; # read from stdin by default
+@podpath = (); # list of directories containing library pods.
+$podroot = "."; # filesystem base directory from which all
+ # relative paths in $podpath stem.
+$recurse = 1; # recurse on subdirectories in $podpath.
+$verbose = 0; # not verbose by default
+$doindex = 1; # non-zero if we should generate an index
+$listlevel = 0; # current list depth
+@listitem = (); # stack of HTML commands to use when a =item is
+ # encountered. the top of the stack is the
+ # current list.
+@listdata = (); # similar to @listitem, but for the text after
+ # an =item
+@listend = (); # similar to @listitem, but the text to use to
+ # end the list.
+$ignore = 1; # whether or not to format text. we don't
+ # format text until we hit our first pod
+ # directive.
+
+@items_seen = ();
+%items_named = ();
+$netscape = 0; # whether or not to use netscape directives.
+$title = ''; # title to give the pod(s)
+$top = 1; # true if we are at the top of the doc. used
+ # to prevent the first <HR> directive.
+$paragraph = ''; # which paragraph we're processing (used
+ # for error messages)
+%sections = (); # sections within this page
+
+# These are not reinitialised here but are kept as a cache.
+# See get_cache and related cache management code.
+#%pages = (); # associative array used to find the location
+ # of pages referenced by L<> links.
+#%items = (); # associative array used to find the location
+ # of =item directives referenced by C<> links
+$Is83=$^O eq 'dos';
+}
+
+sub pod2html {
+ local(@ARGV) = @_;
+ local($/);
+ local $_;
+
+ init_globals();
+
+ $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN());
+
+ # cache of %pages and %items from last time we ran pod2html
+
+ #undef $opt_help if defined $opt_help;
+
+ # parse the command-line parameters
+ parse_command_line();
+
+ # set some variables to their default values if necessary
+ local *POD;
+ unless (@ARGV && $ARGV[0]) {
+ $podfile = "-" unless $podfile; # stdin
+ open(POD, "<$podfile")
+ || die "$0: cannot open $podfile file for input: $!\n";
+ } else {
+ $podfile = $ARGV[0]; # XXX: might be more filenames
+ *POD = *ARGV;
+ }
+ $htmlfile = "-" unless $htmlfile; # stdout
+ $htmlroot = "" if $htmlroot eq "/"; # so we don't get a //
+
+ # read the pod a paragraph at a time
+ warn "Scanning for sections in input file(s)\n" if $verbose;
+ $/ = "";
+ my @poddata = <POD>;
+ close(POD);
+
+ # scan the pod for =head[1-6] directives and build an index
+ my $index = scan_headings(\%sections, @poddata);
+
+ unless($index) {
+ warn "No pod in $podfile\n" if $verbose;
+ return;
+ }
+
+ # open the output file
+ open(HTML, ">$htmlfile")
+ || die "$0: cannot open $htmlfile file for output: $!\n";
+
+ # put a title in the HTML file
+ $title = '';
+ TITLE_SEARCH: {
+ for (my $i = 0; $i < @poddata; $i++) {
+ if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
+ for my $para ( @poddata[$i, $i+1] ) {
+ last TITLE_SEARCH if ($title) = $para =~ /(\S+\s+-+.*\S)/s;
+ }
+ }
+
+ }
+ }
+ if (!$title and $podfile =~ /\.pod$/) {
+ # probably a split pod so take first =head[12] as title
+ for (my $i = 0; $i < @poddata; $i++) {
+ last if ($title) = $poddata[$i] =~ /^=head[12]\s*(.*)/;
+ }
+ warn "adopted '$title' as title for $podfile\n"
+ if $verbose and $title;
+ }
+ if ($title) {
+ $title =~ s/\s*\(.*\)//;
+ } else {
+ warn "$0: no title for $podfile";
+ $podfile =~ /^(.*)(\.[^.\/]+)?$/;
+ $title = ($podfile eq "-" ? 'No Title' : $1);
+ warn "using $title" if $verbose;
+ }
+ print HTML <<END_OF_HEAD;
+<HTML>
+<HEAD>
+<TITLE>$title</TITLE>
+<LINK REV="made" HREF="mailto:$Config{perladmin}">
+</HEAD>
+
+<BODY>
+
+END_OF_HEAD
+
+ # load/reload/validate/cache %pages and %items
+ get_cache($dircache, $itemcache, \@podpath, $podroot, $recurse);
+
+ # scan the pod for =item directives
+ scan_items("", \%items, @poddata);
+
+ # put an index at the top of the file. note, if $doindex is 0 we
+ # still generate an index, but surround it with an html comment.
+ # that way some other program can extract it if desired.
+ $index =~ s/--+/-/g;
+ print HTML "<!-- INDEX BEGIN -->\n";
+ print HTML "<!--\n" unless $doindex;
+ print HTML $index;
+ print HTML "-->\n" unless $doindex;
+ print HTML "<!-- INDEX END -->\n\n";
+ print HTML "<HR>\n" if $doindex;
+
+ # now convert this file
+ warn "Converting input file\n" if $verbose;
+ foreach my $i (0..$#poddata) {
+ $_ = $poddata[$i];
+ $paragraph = $i+1;
+ if (/^(=.*)/s) { # is it a pod directive?
+ $ignore = 0;
+ $_ = $1;
+ if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
+ process_begin($1, $2);
+ } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
+ process_end($1, $2);
+ } elsif (/^=cut/) { # =cut
+ process_cut();
+ } elsif (/^=pod/) { # =pod
+ process_pod();
+ } else {
+ next if @begin_stack && $begin_stack[-1] ne 'html';
+
+ if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading
+ process_head($1, $2);
+ } elsif (/^=item\s*(.*\S)/sm) { # =item text
+ process_item($1);
+ } elsif (/^=over\s*(.*)/) { # =over N
+ process_over();
+ } elsif (/^=back/) { # =back
+ process_back();
+ } elsif (/^=for\s+(\S+)\s+(.*)/si) {# =for
+ process_for($1,$2);
+ } else {
+ /^=(\S*)\s*/;
+ warn "$0: $podfile: unknown pod directive '$1' in "
+ . "paragraph $paragraph. ignoring.\n";
+ }
+ }
+ $top = 0;
+ }
+ else {
+ next if $ignore;
+ next if @begin_stack && $begin_stack[-1] ne 'html';
+ my $text = $_;
+ process_text(\$text, 1);
+ print HTML "<P>\n$text";
+ }
+ }
+
+ # finish off any pending directives
+ finish_list();
+ print HTML <<END_OF_TAIL;
+</BODY>
+
+</HTML>
+END_OF_TAIL
+
+ # close the html file
+ close(HTML);
+
+ warn "Finished\n" if $verbose;
+}
+
+##############################################################################
+
+my $usage; # see below
+sub usage {
+ my $podfile = shift;
+ warn "$0: $podfile: @_\n" if @_;
+ die $usage;
+}
+
+$usage =<<END_OF_USAGE;
+Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
+ --podpath=<name>:...:<name> --podroot=<name>
+ --libpods=<name>:...:<name> --recurse --verbose --index
+ --netscape --norecurse --noindex
+
+ --flush - flushes the item and directory caches.
+ --help - prints this message.
+ --htmlroot - http-server base directory from which all relative paths
+ in podpath stem (default is /).
+ --index - generate an index at the top of the resulting html
+ (default).
+ --infile - filename for the pod to convert (input taken from stdin
+ by default).
+ --libpods - colon-separated list of pages to search for =item pod
+ directives in as targets of C<> and implicit links (empty
+ by default). note, these are not filenames, but rather
+ page names like those that appear in L<> links.
+ --netscape - will use netscape html directives when applicable.
+ --nonetscape - will not use netscape directives (default).
+ --outfile - filename for the resulting html file (output sent to
+ stdout by default).
+ --podpath - colon-separated list of directories containing library
+ pods. empty by default.
+ --podroot - filesystem base directory from which all relative paths
+ in podpath stem (default is .).
+ --noindex - don't generate an index at the top of the resulting html.
+ --norecurse - don't recurse on those subdirectories listed in podpath.
+ --recurse - recurse on those subdirectories listed in podpath
+ (default behavior).
+ --title - title that will appear in resulting html file.
+ --verbose - self-explanatory
+
+END_OF_USAGE
+
+sub parse_command_line {
+ my ($opt_flush,$opt_help,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,$opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_norecurse,$opt_recurse,$opt_title,$opt_verbose);
+ my $result = GetOptions(
+ 'flush' => \$opt_flush,
+ 'help' => \$opt_help,
+ 'htmlroot=s' => \$opt_htmlroot,
+ 'index!' => \$opt_index,
+ 'infile=s' => \$opt_infile,
+ 'libpods=s' => \$opt_libpods,
+ 'netscape!' => \$opt_netscape,
+ 'outfile=s' => \$opt_outfile,
+ 'podpath=s' => \$opt_podpath,
+ 'podroot=s' => \$opt_podroot,
+ 'norecurse' => \$opt_norecurse,
+ 'recurse!' => \$opt_recurse,
+ 'title=s' => \$opt_title,
+ 'verbose' => \$opt_verbose,
+ );
+ usage("-", "invalid parameters") if not $result;
+
+ usage("-") if defined $opt_help; # see if the user asked for help
+ $opt_help = ""; # just to make -w shut-up.
+
+ $podfile = $opt_infile if defined $opt_infile;
+ $htmlfile = $opt_outfile if defined $opt_outfile;
+
+ @podpath = split(":", $opt_podpath) if defined $opt_podpath;
+ @libpods = split(":", $opt_libpods) if defined $opt_libpods;
+
+ warn "Flushing item and directory caches\n"
+ if $opt_verbose && defined $opt_flush;
+ unlink($dircache, $itemcache) if defined $opt_flush;
+
+ $htmlroot = $opt_htmlroot if defined $opt_htmlroot;
+ $podroot = $opt_podroot if defined $opt_podroot;
+
+ $doindex = $opt_index if defined $opt_index;
+ $recurse = $opt_recurse if defined $opt_recurse;
+ $title = $opt_title if defined $opt_title;
+ $verbose = defined $opt_verbose ? 1 : 0;
+ $netscape = $opt_netscape if defined $opt_netscape;
+}
+
+
+my $saved_cache_key;
+
+sub get_cache {
+ my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
+ my @cache_key_args = @_;
+
+ # A first-level cache:
+ # Don't bother reading the cache files if they still apply
+ # and haven't changed since we last read them.
+
+ my $this_cache_key = cache_key(@cache_key_args);
+
+ return if $saved_cache_key and $this_cache_key eq $saved_cache_key;
+
+ # load the cache of %pages and %items if possible. $tests will be
+ # non-zero if successful.
+ my $tests = 0;
+ if (-f $dircache && -f $itemcache) {
+ warn "scanning for item cache\n" if $verbose;
+ $tests = load_cache($dircache, $itemcache, $podpath, $podroot);
+ }
+
+ # if we didn't succeed in loading the cache then we must (re)build
+ # %pages and %items.
+ if (!$tests) {
+ warn "scanning directories in pod-path\n" if $verbose;
+ scan_podpath($podroot, $recurse, 0);
+ }
+ $saved_cache_key = cache_key(@cache_key_args);
+}
+
+sub cache_key {
+ my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
+ return join('!', $dircache, $itemcache, $recurse,
+ @$podpath, $podroot, stat($dircache), stat($itemcache));
+}
+
+#
+# load_cache - tries to find if the caches stored in $dircache and $itemcache
+# are valid caches of %pages and %items. if they are valid then it loads
+# them and returns a non-zero value.
+#
+
+sub load_cache {
+ my($dircache, $itemcache, $podpath, $podroot) = @_;
+ my($tests);
+ local $_;
+
+ $tests = 0;
+
+ open(CACHE, "<$itemcache") ||
+ die "$0: error opening $itemcache for reading: $!\n";
+ $/ = "\n";
+
+ # is it the same podpath?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if (join(":", @$podpath) eq $_);
+
+ # is it the same podroot?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if ($podroot eq $_);
+
+ # load the cache if its good
+ if ($tests != 2) {
+ close(CACHE);
+ return 0;
+ }
+
+ warn "loading item cache\n" if $verbose;
+ while (<CACHE>) {
+ /(.*?) (.*)$/;
+ $items{$1} = $2;
+ }
+ close(CACHE);
+
+ warn "scanning for directory cache\n" if $verbose;
+ open(CACHE, "<$dircache") ||
+ die "$0: error opening $dircache for reading: $!\n";
+ $/ = "\n";
+ $tests = 0;
+
+ # is it the same podpath?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if (join(":", @$podpath) eq $_);
+
+ # is it the same podroot?
+ $_ = <CACHE>;
+ chomp($_);
+ $tests++ if ($podroot eq $_);
+
+ # load the cache if its good
+ if ($tests != 2) {
+ close(CACHE);
+ return 0;
+ }
+
+ warn "loading directory cache\n" if $verbose;
+ while (<CACHE>) {
+ /(.*?) (.*)$/;
+ $pages{$1} = $2;
+ }
+
+ close(CACHE);
+
+ return 1;
+}
+
+#
+# scan_podpath - scans the directories specified in @podpath for directories,
+# .pod files, and .pm files. it also scans the pod files specified in
+# @libpods for =item directives.
+#
+sub scan_podpath {
+ my($podroot, $recurse, $append) = @_;
+ my($pwd, $dir);
+ my($libpod, $dirname, $pod, @files, @poddata);
+
+ unless($append) {
+ %items = ();
+ %pages = ();
+ }
+
+ # scan each directory listed in @podpath
+ $pwd = getcwd();
+ chdir($podroot)
+ || die "$0: error changing to directory $podroot: $!\n";
+ foreach $dir (@podpath) {
+ scan_dir($dir, $recurse);
+ }
+
+ # scan the pods listed in @libpods for =item directives
+ foreach $libpod (@libpods) {
+ # if the page isn't defined then we won't know where to find it
+ # on the system.
+ next unless defined $pages{$libpod} && $pages{$libpod};
+
+ # if there is a directory then use the .pod and .pm files within it.
+ if ($pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+ # find all the .pod and .pm files within the directory
+ $dirname = $1;
+ opendir(DIR, $dirname) ||
+ die "$0: error opening directory $dirname: $!\n";
+ @files = grep(/(\.pod|\.pm)$/ && ! -d $_, readdir(DIR));
+ closedir(DIR);
+
+ # scan each .pod and .pm file for =item directives
+ foreach $pod (@files) {
+ open(POD, "<$dirname/$pod") ||
+ die "$0: error opening $dirname/$pod for input: $!\n";
+ @poddata = <POD>;
+ close(POD);
+
+ scan_items("$dirname/$pod", @poddata);
+ }
+
+ # use the names of files as =item directives too.
+ foreach $pod (@files) {
+ $pod =~ /^(.*)(\.pod|\.pm)$/;
+ $items{$1} = "$dirname/$1.html" if $1;
+ }
+ } elsif ($pages{$libpod} =~ /([^:]*\.pod):/ ||
+ $pages{$libpod} =~ /([^:]*\.pm):/) {
+ # scan the .pod or .pm file for =item directives
+ $pod = $1;
+ open(POD, "<$pod") ||
+ die "$0: error opening $pod for input: $!\n";
+ @poddata = <POD>;
+ close(POD);
+
+ scan_items("$pod", @poddata);
+ } else {
+ warn "$0: shouldn't be here (line ".__LINE__."\n";
+ }
+ }
+ @poddata = (); # clean-up a bit
+
+ chdir($pwd)
+ || die "$0: error changing to directory $pwd: $!\n";
+
+ # cache the item list for later use
+ warn "caching items for later use\n" if $verbose;
+ open(CACHE, ">$itemcache") ||
+ die "$0: error open $itemcache for writing: $!\n";
+
+ print CACHE join(":", @podpath) . "\n$podroot\n";
+ foreach my $key (keys %items) {
+ print CACHE "$key $items{$key}\n";
+ }
+
+ close(CACHE);
+
+ # cache the directory list for later use
+ warn "caching directories for later use\n" if $verbose;
+ open(CACHE, ">$dircache") ||
+ die "$0: error open $dircache for writing: $!\n";
+
+ print CACHE join(":", @podpath) . "\n$podroot\n";
+ foreach my $key (keys %pages) {
+ print CACHE "$key $pages{$key}\n";
+ }
+
+ close(CACHE);
+}
+
+#
+# scan_dir - scans the directory specified in $dir for subdirectories, .pod
+# files, and .pm files. notes those that it finds. this information will
+# be used later in order to figure out where the pages specified in L<>
+# links are on the filesystem.
+#
+sub scan_dir {
+ my($dir, $recurse) = @_;
+ my($t, @subdirs, @pods, $pod, $dirname, @dirs);
+ local $_;
+
+ @subdirs = ();
+ @pods = ();
+
+ opendir(DIR, $dir) ||
+ die "$0: error opening directory $dir: $!\n";
+ while (defined($_ = readdir(DIR))) {
+ if (-d "$dir/$_" && $_ ne "." && $_ ne "..") { # directory
+ $pages{$_} = "" unless defined $pages{$_};
+ $pages{$_} .= "$dir/$_:";
+ push(@subdirs, $_);
+ } elsif (/\.pod$/) { # .pod
+ s/\.pod$//;
+ $pages{$_} = "" unless defined $pages{$_};
+ $pages{$_} .= "$dir/$_.pod:";
+ push(@pods, "$dir/$_.pod");
+ } elsif (/\.pm$/) { # .pm
+ s/\.pm$//;
+ $pages{$_} = "" unless defined $pages{$_};
+ $pages{$_} .= "$dir/$_.pm:";
+ push(@pods, "$dir/$_.pm");
+ }
+ }
+ closedir(DIR);
+
+ # recurse on the subdirectories if necessary
+ if ($recurse) {
+ foreach my $subdir (@subdirs) {
+ scan_dir("$dir/$subdir", $recurse);
+ }
+ }
+}
+
+#
+# scan_headings - scan a pod file for head[1-6] tags, note the tags, and
+# build an index.
+#
+sub scan_headings {
+ my($sections, @data) = @_;
+ my($tag, $which_head, $title, $listdepth, $index);
+
+ # here we need local $ignore = 0;
+ # unfortunately, we can't have it, because $ignore is lexical
+ $ignore = 0;
+
+ $listdepth = 0;
+ $index = "";
+
+ # scan for =head directives, note their name, and build an index
+ # pointing to each of them.
+ foreach my $line (@data) {
+ if ($line =~ /^=(head)([1-6])\s+(.*)/) {
+ ($tag,$which_head, $title) = ($1,$2,$3);
+ chomp($title);
+ $$sections{htmlify(0,$title)} = 1;
+
+ while ($which_head != $listdepth) {
+ if ($which_head > $listdepth) {
+ $index .= "\n" . ("\t" x $listdepth) . "<UL>\n";
+ $listdepth++;
+ } elsif ($which_head < $listdepth) {
+ $listdepth--;
+ $index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
+ }
+ }
+
+ $index .= "\n" . ("\t" x $listdepth) . "<LI>" .
+ "<A HREF=\"#" . htmlify(0,$title) . "\">" .
+ html_escape(process_text(\$title, 0)) . "</A>";
+ }
+ }
+
+ # finish off the lists
+ while ($listdepth--) {
+ $index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
+ }
+
+ # get rid of bogus lists
+ $index =~ s,\t*<UL>\s*</UL>\n,,g;
+
+ $ignore = 1; # restore old value;
+
+ return $index;
+}
+
+#
+# scan_items - scans the pod specified by $pod for =item directives. we
+# will use this information later on in resolving C<> links.
+#
+sub scan_items {
+ my($pod, @poddata) = @_;
+ my($i, $item);
+ local $_;
+
+ $pod =~ s/\.pod$//;
+ $pod .= ".html" if $pod;
+
+ foreach $i (0..$#poddata) {
+ $_ = $poddata[$i];
+
+ # remove any formatting instructions
+ s,[A-Z]<([^<>]*)>,$1,g;
+
+ # figure out what kind of item it is and get the first word of
+ # it's name.
+ if (/^=item\s+(\w*)\s*.*$/s) {
+ if ($1 eq "*") { # bullet list
+ /\A=item\s+\*\s*(.*?)\s*\Z/s;
+ $item = $1;
+ } elsif ($1 =~ /^\d+/) { # numbered list
+ /\A=item\s+\d+\.?(.*?)\s*\Z/s;
+ $item = $1;
+ } else {
+# /\A=item\s+(.*?)\s*\Z/s;
+ /\A=item\s+(\w*)/s;
+ $item = $1;
+ }
+
+ $items{$item} = "$pod" if $item;
+ }
+ }
+}
+
+#
+# process_head - convert a pod head[1-6] tag and convert it to HTML format.
+#
+sub process_head {
+ my($tag, $heading) = @_;
+ my $firstword;
+
+ # figure out the level of the =head
+ $tag =~ /head([1-6])/;
+ my $level = $1;
+
+ # can't have a heading full of spaces and speechmarks and so on
+ $firstword = $heading; $firstword =~ s/\s*(\w+)\s.*/$1/;
+
+ print HTML "<P>\n" unless $listlevel;
+ print HTML "<HR>\n" unless $listlevel || $top;
+ print HTML "<H$level>"; # unless $listlevel;
+ #print HTML "<H$level>" unless $listlevel;
+ my $convert = $heading; process_text(\$convert, 0);
+ $convert = html_escape($convert);
+ print HTML '<A NAME="' . htmlify(0,$heading) . "\">$convert</A>";
+ print HTML "</H$level>"; # unless $listlevel;
+ print HTML "\n";
+}
+
+#
+# process_item - convert a pod item tag and convert it to HTML format.
+#
+sub process_item {
+ my $text = $_[0];
+ my($i, $quote, $name);
+
+ my $need_preamble = 0;
+ my $this_entry;
+
+
+ # lots of documents start a list without doing an =over. this is
+ # bad! but, the proper thing to do seems to be to just assume
+ # they did do an =over. so warn them once and then continue.
+ warn "$0: $podfile: unexpected =item directive in paragraph $paragraph. ignoring.\n"
+ unless $listlevel;
+ process_over() unless $listlevel;
+
+ return unless $listlevel;
+
+ # remove formatting instructions from the text
+ 1 while $text =~ s/[A-Z]<([^<>]*)>/$1/g;
+ pre_escape(\$text);
+
+ $need_preamble = $items_seen[$listlevel]++ == 0;
+
+ # check if this is the first =item after an =over
+ $i = $listlevel - 1;
+ my $need_new = $listlevel >= @listitem;
+
+ if ($text =~ /\A\*/) { # bullet
+
+ if ($need_preamble) {
+ push(@listend, "</UL>");
+ print HTML "<UL>\n";
+ }
+
+ print HTML '<LI>';
+ if ($text =~ /\A\*\s*(.+)\Z/s) {
+ print HTML '<STRONG>';
+ if ($items_named{$1}++) {
+ print HTML html_escape($1);
+ } else {
+ my $name = 'item_' . htmlify(1,$1);
+ print HTML qq(<A NAME="$name">), html_escape($1), '</A>';
+ }
+ print HTML '</STRONG>';
+ }
+
+ } elsif ($text =~ /\A[\d#]+/) { # numbered list
+
+ if ($need_preamble) {
+ push(@listend, "</OL>");
+ print HTML "<OL>\n";
+ }
+
+ print HTML '<LI>';
+ if ($text =~ /\A\d+\.?\s*(.+)\Z/s) {
+ print HTML '<STRONG>';
+ if ($items_named{$1}++) {
+ print HTML html_escape($1);
+ } else {
+ my $name = 'item_' . htmlify(0,$1);
+ print HTML qq(<A NAME="$name">), html_escape($1), '</A>';
+ }
+ print HTML '</STRONG>';
+ }
+
+ } else { # all others
+
+ if ($need_preamble) {
+ push(@listend, '</DL>');
+ print HTML "<DL>\n";
+ }
+
+ print HTML '<DT>';
+ if ($text =~ /(\S+)/) {
+ print HTML '<STRONG>';
+ if ($items_named{$1}++) {
+ print HTML html_escape($text);
+ } else {
+ my $name = 'item_' . htmlify(1,$text);
+ print HTML qq(<A NAME="$name">), html_escape($text), '</A>';
+ }
+ print HTML '</STRONG>';
+ }
+ print HTML '<DD>';
+ }
+
+ print HTML "\n";
+}
+
+#
+# process_over - process a pod over tag and start a corresponding HTML
+# list.
+#
+sub process_over {
+ # start a new list
+ $listlevel++;
+}
+
+#
+# process_back - process a pod back tag and convert it to HTML format.
+#
+sub process_back {
+ warn "$0: $podfile: unexpected =back directive in paragraph $paragraph. ignoring.\n"
+ unless $listlevel;
+ return unless $listlevel;
+
+ # close off the list. note, I check to see if $listend[$listlevel] is
+ # defined because an =item directive may have never appeared and thus
+ # $listend[$listlevel] may have never been initialized.
+ $listlevel--;
+ print HTML $listend[$listlevel] if defined $listend[$listlevel];
+ print HTML "\n";
+
+ # don't need the corresponding perl code anymore
+ pop(@listitem);
+ pop(@listdata);
+ pop(@listend);
+
+ pop(@items_seen);
+}
+
+#
+# process_cut - process a pod cut tag, thus stop ignoring pod directives.
+#
+sub process_cut {
+ $ignore = 1;
+}
+
+#
+# process_pod - process a pod pod tag, thus ignore pod directives until we see a
+# corresponding cut.
+#
+sub process_pod {
+ # no need to set $ignore to 0 cause the main loop did it
+}
+
+#
+# process_for - process a =for pod tag. if it's for html, split
+# it out verbatim, if illustration, center it, otherwise ignore it.
+#
+sub process_for {
+ my($whom, $text) = @_;
+ if ( $whom =~ /^(pod2)?html$/i) {
+ print HTML $text;
+ } elsif ($whom =~ /^illustration$/i) {
+ 1 while chomp $text;
+ for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) {
+ $text .= $ext, last if -r "$text$ext";
+ }
+ print HTML qq{<p align = "center"><img src = "$text" alt = "$text illustration"></p>};
+ }
+}
+
+#
+# process_begin - process a =begin pod tag. this pushes
+# whom we're beginning on the begin stack. if there's a
+# begin stack, we only print if it us.
+#
+sub process_begin {
+ my($whom, $text) = @_;
+ $whom = lc($whom);
+ push (@begin_stack, $whom);
+ if ( $whom =~ /^(pod2)?html$/) {
+ print HTML $text if $text;
+ }
+}
+
+#
+# process_end - process a =end pod tag. pop the
+# begin stack. die if we're mismatched.
+#
+sub process_end {
+ my($whom, $text) = @_;
+ $whom = lc($whom);
+ if ($begin_stack[-1] ne $whom ) {
+ die "Unmatched begin/end at chunk $paragraph\n"
+ }
+ pop @begin_stack;
+}
+
+#
+# process_text - handles plaintext that appears in the input pod file.
+# there may be pod commands embedded within the text so those must be
+# converted to html commands.
+#
+sub process_text {
+ my($text, $escapeQuotes) = @_;
+ my($result, $rest, $s1, $s2, $s3, $s4, $match, $bf);
+ my($podcommand, $params, $tag, $quote);
+
+ return if $ignore;
+
+ $quote = 0; # status of double-quote conversion
+ $result = "";
+ $rest = $$text;
+
+ if ($rest =~ /^\s+/) { # preformatted text, no pod directives
+ $rest =~ s/\n+\Z//;
+ $rest =~ s#.*#
+ my $line = $&;
+ 1 while $line =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
+ $line;
+ #eg;
+
+ $rest =~ s/&/&amp;/g;
+ $rest =~ s/</&lt;/g;
+ $rest =~ s/>/&gt;/g;
+ $rest =~ s/"/&quot;/g;
+
+ # try and create links for all occurrences of perl.* within
+ # the preformatted text.
+ $rest =~ s{
+ (\s*)(perl\w+)
+ }{
+ if (defined $pages{$2}) { # is a link
+ qq($1<A HREF="$htmlroot/$pages{$2}">$2</A>);
+ } elsif (defined $pages{dosify($2)}) { # is a link
+ qq($1<A HREF="$htmlroot/$pages{dosify($2)}">$2</A>);
+ } else {
+ "$1$2";
+ }
+ }xeg;
+ $rest =~ s/(<A HREF=)([^>:]*:)?([^>:]*)\.pod:([^>:]*:)?/$1$3.html/g;
+
+ my $urls = '(' . join ('|', qw{
+ http
+ telnet
+ mailto
+ news
+ gopher
+ file
+ wais
+ ftp
+ } )
+ . ')';
+
+ my $ltrs = '\w';
+ my $gunk = '/#~:.?+=&%@!\-';
+ my $punc = '.:?\-';
+ my $any = "${ltrs}${gunk}${punc}";
+
+ $rest =~ s{
+ \b # start at word boundary
+ ( # begin $1 {
+ $urls : # need resource and a colon
+ [$any] +? # followed by on or more
+ # of any valid character, but
+ # be conservative and take only
+ # what you need to....
+ ) # end $1 }
+ (?= # look-ahead non-consumptive assertion
+ [$punc]* # either 0 or more puntuation
+ [^$any] # followed by a non-url char
+ | # or else
+ $ # then end of the string
+ )
+ }{<A HREF="$1">$1</A>}igox;
+
+ $result = "<PRE>" # text should be as it is (verbatim)
+ . "$rest\n"
+ . "</PRE>\n";
+ } else { # formatted text
+ # parse through the string, stopping each time we find a
+ # pod-escape. once the string has been throughly processed
+ # we can output it.
+ while (length $rest) {
+ # check to see if there are any possible pod directives in
+ # the remaining part of the text.
+ if ($rest =~ m/[BCEIFLSZ]</) {
+ warn "\$rest\t= $rest\n" unless
+ $rest =~ /\A
+ ([^<]*?)
+ ([BCEIFLSZ]?)
+ <
+ (.*)\Z/xs;
+
+ $s1 = $1; # pure text
+ $s2 = $2; # the type of pod-escape that follows
+ $s3 = '<'; # '<'
+ $s4 = $3; # the rest of the string
+ } else {
+ $s1 = $rest;
+ $s2 = "";
+ $s3 = "";
+ $s4 = "";
+ }
+
+ if ($s3 eq '<' && $s2) { # a pod-escape
+ $result .= ($escapeQuotes ? process_puretext($s1, \$quote) : $s1);
+ $podcommand = "$s2<";
+ $rest = $s4;
+
+ # find the matching '>'
+ $match = 1;
+ $bf = 0;
+ while ($match && !$bf) {
+ $bf = 1;
+ if ($rest =~ /\A([^<>]*[BCEIFLSZ]<)(.*)\Z/s) {
+ $bf = 0;
+ $match++;
+ $podcommand .= $1;
+ $rest = $2;
+ } elsif ($rest =~ /\A([^>]*>)(.*)\Z/s) {
+ $bf = 0;
+ $match--;
+ $podcommand .= $1;
+ $rest = $2;
+ }
+ }
+
+ if ($match != 0) {
+ warn <<WARN;
+$0: $podfile: cannot find matching > for $s2 in paragraph $paragraph.
+WARN
+ $result .= substr $podcommand, 0, 2;
+ $rest = substr($podcommand, 2) . $rest;
+ next;
+ }
+
+ # pull out the parameters to the pod-escape
+ $podcommand =~ /^([BCFEILSZ]?)<(.*)>$/s;
+ $tag = $1;
+ $params = $2;
+
+ # process the text within the pod-escape so that any escapes
+ # which must occur do.
+ process_text(\$params, 0) unless $tag eq 'L';
+
+ $s1 = $params;
+ if (!$tag || $tag eq " ") { # <> : no tag
+ $s1 = "&lt;$params&gt;";
+ } elsif ($tag eq "L") { # L<> : link
+ $s1 = process_L($params);
+ } elsif ($tag eq "I" || # I<> : italicize text
+ $tag eq "B" || # B<> : bold text
+ $tag eq "F") { # F<> : file specification
+ $s1 = process_BFI($tag, $params);
+ } elsif ($tag eq "C") { # C<> : literal code
+ $s1 = process_C($params, 1);
+ } elsif ($tag eq "E") { # E<> : escape
+ $s1 = process_E($params);
+ } elsif ($tag eq "Z") { # Z<> : zero-width character
+ $s1 = process_Z($params);
+ } elsif ($tag eq "S") { # S<> : non-breaking space
+ $s1 = process_S($params);
+ } elsif ($tag eq "X") { # S<> : non-breaking space
+ $s1 = process_X($params);
+ } else {
+ warn "$0: $podfile: unhandled tag '$tag' in paragraph $paragraph\n";
+ }
+
+ $result .= "$s1";
+ } else {
+ # for pure text we must deal with implicit links and
+ # double-quotes among other things.
+ $result .= ($escapeQuotes ? process_puretext("$s1$s2$s3", \$quote) : "$s1$s2$s3");
+ $rest = $s4;
+ }
+ }
+ }
+ $$text = $result;
+}
+
+sub html_escape {
+ my $rest = $_[0];
+ $rest =~ s/&/&amp;/g;
+ $rest =~ s/</&lt;/g;
+ $rest =~ s/>/&gt;/g;
+ $rest =~ s/"/&quot;/g;
+ return $rest;
+}
+
+#
+# process_puretext - process pure text (without pod-escapes) converting
+# double-quotes and handling implicit C<> links.
+#
+sub process_puretext {
+ my($text, $quote) = @_;
+ my(@words, $result, $rest, $lead, $trail);
+
+ # convert double-quotes to single-quotes
+ $text =~ s/\A([^"]*)"/$1''/s if $$quote;
+ while ($text =~ s/\A([^"]*)["]([^"]*)["]/$1``$2''/sg) {}
+
+ $$quote = ($text =~ m/"/ ? 1 : 0);
+ $text =~ s/\A([^"]*)"/$1``/s if $$quote;
+
+ # keep track of leading and trailing white-space
+ $lead = ($text =~ /\A(\s*)/s ? $1 : "");
+ $trail = ($text =~ /(\s*)\Z/s ? $1 : "");
+
+ # collapse all white space into a single space
+ $text =~ s/\s+/ /g;
+ @words = split(" ", $text);
+
+ # process each word individually
+ foreach my $word (@words) {
+ # see if we can infer a link
+ if ($word =~ /^\w+\(/) {
+ # has parenthesis so should have been a C<> ref
+ $word = process_C($word);
+# $word =~ /^[^()]*]\(/;
+# if (defined $items{$1} && $items{$1}) {
+# $word = "\n<CODE><A HREF=\"$htmlroot/$items{$1}#item_"
+# . htmlify(0,$word)
+# . "\">$word</A></CODE>";
+# } elsif (defined $items{$word} && $items{$word}) {
+# $word = "\n<CODE><A HREF=\"$htmlroot/$items{$word}#item_"
+# . htmlify(0,$word)
+# . "\">$word</A></CODE>";
+# } else {
+# $word = "\n<CODE><A HREF=\"#item_"
+# . htmlify(0,$word)
+# . "\">$word</A></CODE>";
+# }
+ } elsif ($word =~ /^[\$\@%&*]+\w+$/) {
+ # perl variables, should be a C<> ref
+ $word = process_C($word, 1);
+ } elsif ($word =~ m,^\w+://\w,) {
+ # looks like a URL
+ $word = qq(<A HREF="$word">$word</A>);
+ } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
+ # looks like an e-mail address
+ my ($w1, $w2, $w3) = ("", $word, "");
+ ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/;
+ ($w1, $w2, $w3) = ("&lt;", $1, "&gt;$2") if $word =~ /^<(.*?)>(,?)/;
+ $word = qq($w1<A HREF="mailto:$w2">$w2</A>$w3);
+ } elsif ($word !~ /[a-z]/ && $word =~ /[A-Z]/) { # all uppercase?
+ $word = html_escape($word) if $word =~ /["&<>]/;
+ $word = "\n<FONT SIZE=-1>$word</FONT>" if $netscape;
+ } else {
+ $word = html_escape($word) if $word =~ /["&<>]/;
+ }
+ }
+
+ # build a new string based upon our conversion
+ $result = "";
+ $rest = join(" ", @words);
+ while (length($rest) > 75) {
+ if ( $rest =~ m/^(.{0,75})\s(.*?)$/o ||
+ $rest =~ m/^(\S*)\s(.*?)$/o) {
+
+ $result .= "$1\n";
+ $rest = $2;
+ } else {
+ $result .= "$rest\n";
+ $rest = "";
+ }
+ }
+ $result .= $rest if $rest;
+
+ # restore the leading and trailing white-space
+ $result = "$lead$result$trail";
+
+ return $result;
+}
+
+#
+# pre_escape - convert & in text to $amp;
+#
+sub pre_escape {
+ my($str) = @_;
+
+ $$str =~ s,&,&amp;,g;
+}
+
+#
+# dosify - convert filenames to 8.3
+#
+sub dosify {
+ my($str) = @_;
+ if ($Is83) {
+ $str = lc $str;
+ $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
+ $str =~ s/(\w+)/substr ($1,0,8)/ge;
+ }
+ return $str;
+}
+
+#
+# process_L - convert a pod L<> directive to a corresponding HTML link.
+# most of the links made are inferred rather than known about directly
+# (i.e it's not known whether the =head\d section exists in the target file,
+# or whether a .pod file exists in the case of split files). however, the
+# guessing usually works.
+#
+# Unlike the other directives, this should be called with an unprocessed
+# string, else tags in the link won't be matched.
+#
+sub process_L {
+ my($str) = @_;
+ my($s1, $s2, $linktext, $page, $page83, $section, $link); # work strings
+
+ $str =~ s/\n/ /g; # undo word-wrapped tags
+ $s1 = $str;
+ for ($s1) {
+ # LREF: a la HREF L<show this text|man/section>
+ $linktext = $1 if s:^([^|]+)\|::;
+
+ # a :: acts like a /
+ s,::,/,;
+
+ # make sure sections start with a /
+ s,^",/",g;
+ s,^,/,g if (!m,/, && / /);
+
+ # check if there's a section specified
+ if (m,^(.*?)/"?(.*?)"?$,) { # yes
+ ($page, $section) = ($1, $2);
+ } else { # no
+ ($page, $section) = ($str, "");
+ }
+
+ # check if we know that this is a section in this page
+ if (!defined $pages{$page} && defined $sections{$page}) {
+ $section = $page;
+ $page = "";
+ }
+ }
+
+ $page83=dosify($page);
+ $page=$page83 if (defined $pages{$page83});
+ if ($page eq "") {
+ $link = "#" . htmlify(0,$section);
+ $linktext = $section unless defined($linktext);
+ } elsif (!defined $pages{$page}) {
+ warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n";
+ $link = "";
+ $linktext = $page unless defined($linktext);
+ } else {
+ $linktext = ($section ? "$section" : "the $page manpage") unless defined($linktext);
+ $section = htmlify(0,$section) if $section ne "";
+
+ # if there is a directory by the name of the page, then assume that an
+ # appropriate section will exist in the subdirectory
+ if ($section ne "" && $pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
+ $link = "$htmlroot/$1/$section.html";
+
+ # since there is no directory by the name of the page, the section will
+ # have to exist within a .html of the same name. thus, make sure there
+ # is a .pod or .pm that might become that .html
+ } else {
+ $section = "#$section";
+ # check if there is a .pod with the page name
+ if ($pages{$page} =~ /([^:]*)\.pod:/) {
+ $link = "$htmlroot/$1.html$section";
+ } elsif ($pages{$page} =~ /([^:]*)\.pm:/) {
+ $link = "$htmlroot/$1.html$section";
+ } else {
+ warn "$0: $podfile: cannot resolve L$str in paragraph $paragraph: ".
+ "no .pod or .pm found\n";
+ $link = "";
+ $linktext = $section unless defined($linktext);
+ }
+ }
+ }
+
+ process_text(\$linktext, 0);
+ if ($link) {
+ $s1 = "<A HREF=\"$link\">$linktext</A>";
+ } else {
+ $s1 = "<EM>$linktext</EM>";
+ }
+ return $s1;
+}
+
+#
+# process_BFI - process any of the B<>, F<>, or I<> pod-escapes and
+# convert them to corresponding HTML directives.
+#
+sub process_BFI {
+ my($tag, $str) = @_;
+ my($s1); # work string
+ my(%repltext) = ( 'B' => 'STRONG',
+ 'F' => 'EM',
+ 'I' => 'EM');
+
+ # extract the modified text and convert to HTML
+ $s1 = "<$repltext{$tag}>$str</$repltext{$tag}>";
+ return $s1;
+}
+
+#
+# process_C - process the C<> pod-escape.
+#
+sub process_C {
+ my($str, $doref) = @_;
+ my($s1, $s2);
+
+ $s1 = $str;
+ $s1 =~ s/\([^()]*\)//g; # delete parentheses
+ $s2 = $s1;
+ $s1 =~ s/\W//g; # delete bogus characters
+ $str = html_escape($str);
+
+ # if there was a pod file that we found earlier with an appropriate
+ # =item directive, then create a link to that page.
+ if ($doref && defined $items{$s1}) {
+ $s1 = ($items{$s1} ?
+ "<A HREF=\"$htmlroot/$items{$s1}#item_" . htmlify(0,$s2) . "\">$str</A>" :
+ "<A HREF=\"#item_" . htmlify(0,$s2) . "\">$str</A>");
+ $s1 =~ s,(perl\w+/(\S+)\.html)#item_\2\b,$1,;
+ confess "s1 has space: $s1" if $s1 =~ /HREF="[^"]*\s[^"]*"/;
+ } else {
+ $s1 = "<CODE>$str</CODE>";
+ # warn "$0: $podfile: cannot resolve C<$str> in paragraph $paragraph\n" if $verbose
+ }
+
+
+ return $s1;
+}
+
+#
+# process_E - process the E<> pod directive which seems to escape a character.
+#
+sub process_E {
+ my($str) = @_;
+
+ for ($str) {
+ s,([^/].*),\&$1\;,g;
+ }
+
+ return $str;
+}
+
+#
+# process_Z - process the Z<> pod directive which really just amounts to
+# ignoring it. this allows someone to start a paragraph with an =
+#
+sub process_Z {
+ my($str) = @_;
+
+ # there is no equivalent in HTML for this so just ignore it.
+ $str = "";
+ return $str;
+}
+
+#
+# process_S - process the S<> pod directive which means to convert all
+# spaces in the string to non-breaking spaces (in HTML-eze).
+#
+sub process_S {
+ my($str) = @_;
+
+ # convert all spaces in the text to non-breaking spaces in HTML.
+ $str =~ s/ /&nbsp;/g;
+ return $str;
+}
+
+#
+# process_X - this is supposed to make an index entry. we'll just
+# ignore it.
+#
+sub process_X {
+ return '';
+}
+
+
+#
+# finish_list - finish off any pending HTML lists. this should be called
+# after the entire pod file has been read and converted.
+#
+sub finish_list {
+ while ($listlevel > 0) {
+ print HTML "</DL>\n";
+ $listlevel--;
+ }
+}
+
+#
+# htmlify - converts a pod section specification to a suitable section
+# specification for HTML. if first arg is 1, only takes 1st word.
+#
+sub htmlify {
+ my($compact, $heading) = @_;
+
+ if ($compact) {
+ $heading =~ /^(\w+)/;
+ $heading = $1;
+ }
+
+ # $heading = lc($heading);
+ $heading =~ s/[^\w\s]/_/g;
+ $heading =~ s/(\s+)/ /g;
+ $heading =~ s/^\s*(.*?)\s*$/$1/s;
+ $heading =~ s/ /_/g;
+ $heading =~ s/\A(.{32}).*\Z/$1/s;
+ $heading =~ s/\s+\Z//;
+ $heading =~ s/_{2,}/_/g;
+
+ return $heading;
+}
+
+BEGIN {
+}
+
+1;
diff --git a/contrib/perl5/lib/Pod/Text.pm b/contrib/perl5/lib/Pod/Text.pm
new file mode 100644
index 000000000000..67993db3f51e
--- /dev/null
+++ b/contrib/perl5/lib/Pod/Text.pm
@@ -0,0 +1,549 @@
+package Pod::Text;
+
+=head1 NAME
+
+Pod::Text - convert POD data to formatted ASCII text
+
+=head1 SYNOPSIS
+
+ use Pod::Text;
+
+ pod2text("perlfunc.pod");
+
+Also:
+
+ pod2text [B<-a>] [B<->I<width>] < input.pod
+
+=head1 DESCRIPTION
+
+Pod::Text is a module that can convert documentation in the POD format (such
+as can be found throughout the Perl distribution) into formatted ASCII.
+Termcap is optionally supported for boldface/underline, and can enabled via
+C<$Pod::Text::termcap=1>. If termcap has not been enabled, then backspaces
+will be used to simulate bold and underlined text.
+
+A separate F<pod2text> program is included that is primarily a wrapper for
+Pod::Text.
+
+The single function C<pod2text()> can take the optional options B<-a>
+for an alternative output format, then a B<->I<width> option with the
+max terminal width, followed by one or two arguments. The first
+should be the name of a file to read the pod from, or "E<lt>&STDIN" to read from
+STDIN. A second argument, if provided, should be a filehandle glob where
+output should be sent.
+
+=head1 AUTHOR
+
+Tom Christiansen E<lt>F<tchrist@mox.perl.com>E<gt>
+
+=head1 TODO
+
+Cleanup work. The input and output locations need to be more flexible,
+termcap shouldn't be a global variable, and the terminal speed needs to
+be properly calculated.
+
+=cut
+
+use Term::Cap;
+require Exporter;
+@ISA = Exporter;
+@EXPORT = qw(pod2text);
+
+use vars qw($VERSION);
+$VERSION = "1.0203";
+
+$termcap=0;
+
+$opt_alt_format = 0;
+
+#$use_format=1;
+
+$UNDL = "\x1b[4m";
+$INV = "\x1b[7m";
+$BOLD = "\x1b[1m";
+$NORM = "\x1b[0m";
+
+sub pod2text {
+shift if $opt_alt_format = ($_[0] eq '-a');
+
+if($termcap and !$setuptermcap) {
+ $setuptermcap=1;
+
+ my($term) = Tgetent Term::Cap { TERM => undef, OSPEED => 9600 };
+ $UNDL = $term->{'_us'};
+ $INV = $term->{'_mr'};
+ $BOLD = $term->{'_md'};
+ $NORM = $term->{'_me'};
+}
+
+$SCREEN = ($_[0] =~ /^-(\d+)/ && (shift, $1))
+ || $ENV{COLUMNS}
+ || ($ENV{TERMCAP} =~ /co#(\d+)/)[0]
+ || ($^O ne 'MSWin32' && $^O ne 'dos' && (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0])
+ || 72;
+
+@_ = ("<&STDIN") unless @_;
+local($file,*OUTPUT) = @_;
+*OUTPUT = *STDOUT if @_<2;
+
+local $: = $:;
+$: = " \n" if $opt_alt_format; # Do not break ``-L/lib/'' into ``- L/lib/''.
+
+$/ = "";
+
+$FANCY = 0;
+
+$cutting = 1;
+$DEF_INDENT = 4;
+$indent = $DEF_INDENT;
+$needspace = 0;
+$begun = "";
+
+open(IN, $file) || die "Couldn't open $file: $!";
+
+POD_DIRECTIVE: while (<IN>) {
+ if ($cutting) {
+ next unless /^=/;
+ $cutting = 0;
+ }
+ if ($begun) {
+ if (/^=end\s+$begun/) {
+ $begun = "";
+ }
+ elsif ($begun eq "text") {
+ print OUTPUT $_;
+ }
+ next;
+ }
+ 1 while s{^(.*?)(\t+)(.*)$}{
+ $1
+ . (' ' x (length($2) * 8 - length($1) % 8))
+ . $3
+ }me;
+ # Translate verbatim paragraph
+ if (/^\s/) {
+ output($_);
+ next;
+ }
+
+ if (/^=for\s+(\S+)\s*(.*)/s) {
+ if ($1 eq "text") {
+ print OUTPUT $2,"";
+ } else {
+ # ignore unknown for
+ }
+ next;
+ }
+ elsif (/^=begin\s+(\S+)\s*(.*)/s) {
+ $begun = $1;
+ if ($1 eq "text") {
+ print OUTPUT $2."";
+ }
+ next;
+ }
+
+sub prepare_for_output {
+
+ s/\s*$/\n/;
+ &init_noremap;
+
+ # need to hide E<> first; they're processed in clear_noremap
+ s/(E<[^<>]+>)/noremap($1)/ge;
+ $maxnest = 10;
+ while ($maxnest-- && /[A-Z]</) {
+ unless ($FANCY) {
+ if ($opt_alt_format) {
+ s/[BC]<(.*?)>/``$1''/sg;
+ s/F<(.*?)>/"$1"/sg;
+ } else {
+ s/C<(.*?)>/`$1'/sg;
+ }
+ } else {
+ s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/sge;
+ }
+ # s/[IF]<(.*?)>/italic($1)/ge;
+ s/I<(.*?)>/*$1*/sg;
+ # s/[CB]<(.*?)>/bold($1)/ge;
+ s/X<.*?>//sg;
+
+ # LREF: a la HREF L<show this text|man/section>
+ s:L<([^|>]+)\|[^>]+>:$1:g;
+
+ # LREF: a manpage(3f)
+ s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the $1$2 manpage:g;
+ # LREF: an =item on another manpage
+ s{
+ L<
+ ([^/]+)
+ /
+ (
+ [:\w]+
+ (\(\))?
+ )
+ >
+ } {the "$2" entry in the $1 manpage}gx;
+
+ # LREF: an =item on this manpage
+ s{
+ ((?:
+ L<
+ /
+ (
+ [:\w]+
+ (\(\))?
+ )
+ >
+ (,?\s+(and\s+)?)?
+ )+)
+ } { internal_lrefs($1) }gex;
+
+ # LREF: a =head2 (head1?), maybe on a manpage, maybe right here
+ # the "func" can disambiguate
+ s{
+ L<
+ (?:
+ ([a-zA-Z]\S+?) /
+ )?
+ "?(.*?)"?
+ >
+ }{
+ do {
+ $1 # if no $1, assume it means on this page.
+ ? "the section on \"$2\" in the $1 manpage"
+ : "the section on \"$2\""
+ }
+ }sgex;
+
+ s/[A-Z]<(.*?)>/$1/sg;
+ }
+ clear_noremap(1);
+}
+
+ &prepare_for_output;
+
+ if (s/^=//) {
+ # $needspace = 0; # Assume this.
+ # s/\n/ /g;
+ ($Cmd, $_) = split(' ', $_, 2);
+ # clear_noremap(1);
+ if ($Cmd eq 'cut') {
+ $cutting = 1;
+ }
+ elsif ($Cmd eq 'pod') {
+ $cutting = 0;
+ }
+ elsif ($Cmd eq 'head1') {
+ makespace();
+ if ($opt_alt_format) {
+ print OUTPUT "\n";
+ s/^(.+?)[ \t]*$/==== $1 ====/;
+ }
+ print OUTPUT;
+ # print OUTPUT uc($_);
+ $needspace = $opt_alt_format;
+ }
+ elsif ($Cmd eq 'head2') {
+ makespace();
+ # s/(\w+)/\u\L$1/g;
+ #print ' ' x $DEF_INDENT, $_;
+ # print "\xA7";
+ s/(\w)/\xA7 $1/ if $FANCY;
+ if ($opt_alt_format) {
+ s/^(.+?)[ \t]*$/== $1 ==/;
+ print OUTPUT "\n", $_;
+ } else {
+ print OUTPUT ' ' x ($DEF_INDENT/2), $_, "\n";
+ }
+ $needspace = $opt_alt_format;
+ }
+ elsif ($Cmd eq 'over') {
+ push(@indent,$indent);
+ $indent += ($_ + 0) || $DEF_INDENT;
+ }
+ elsif ($Cmd eq 'back') {
+ $indent = pop(@indent);
+ warn "Unmatched =back\n" unless defined $indent;
+ }
+ elsif ($Cmd eq 'item') {
+ makespace();
+ # s/\A(\s*)\*/$1\xb7/ if $FANCY;
+ # s/^(\s*\*\s+)/$1 /;
+ {
+ if (length() + 3 < $indent) {
+ my $paratag = $_;
+ $_ = <IN>;
+ if (/^=/) { # tricked!
+ local($indent) = $indent[$#index - 1] || $DEF_INDENT;
+ output($paratag);
+ redo POD_DIRECTIVE;
+ }
+ &prepare_for_output;
+ IP_output($paratag, $_);
+ } else {
+ local($indent) = $indent[$#index - 1] || $DEF_INDENT;
+ output($_, 0);
+ }
+ }
+ }
+ else {
+ warn "Unrecognized directive: $Cmd\n";
+ }
+ }
+ else {
+ # clear_noremap(1);
+ makespace();
+ output($_, 1);
+ }
+}
+
+close(IN);
+
+}
+
+#########################################################################
+
+sub makespace {
+ if ($needspace) {
+ print OUTPUT "\n";
+ $needspace = 0;
+ }
+}
+
+sub bold {
+ my $line = shift;
+ return $line if $use_format;
+ if($termcap) {
+ $line = "$BOLD$line$NORM";
+ } else {
+ $line =~ s/(.)/$1\b$1/g;
+ }
+# $line = "$BOLD$line$NORM" if $ansify;
+ return $line;
+}
+
+sub italic {
+ my $line = shift;
+ return $line if $use_format;
+ if($termcap) {
+ $line = "$UNDL$line$NORM";
+ } else {
+ $line =~ s/(.)/$1\b_/g;
+ }
+# $line = "$UNDL$line$NORM" if $ansify;
+ return $line;
+}
+
+# Fill a paragraph including underlined and overstricken chars.
+# It's not perfect for words longer than the margin, and it's probably
+# slow, but it works.
+sub fill {
+ local $_ = shift;
+ my $par = "";
+ my $indent_space = " " x $indent;
+ my $marg = $SCREEN-$indent;
+ my $line = $indent_space;
+ my $line_length;
+ foreach (split) {
+ my $word_length = length;
+ $word_length -= 2 while /\010/g; # Subtract backspaces
+
+ if ($line_length + $word_length > $marg) {
+ $par .= $line . "\n";
+ $line= $indent_space . $_;
+ $line_length = $word_length;
+ }
+ else {
+ if ($line_length) {
+ $line_length++;
+ $line .= " ";
+ }
+ $line_length += $word_length;
+ $line .= $_;
+ }
+ }
+ $par .= "$line\n" if $line;
+ $par .= "\n";
+ return $par;
+}
+
+sub IP_output {
+ local($tag, $_) = @_;
+ local($tag_indent) = $indent[$#index - 1] || $DEF_INDENT;
+ $tag_cols = $SCREEN - $tag_indent;
+ $cols = $SCREEN - $indent;
+ $tag =~ s/\s*$//;
+ s/\s+/ /g;
+ s/^ //;
+ $str = "format OUTPUT = \n"
+ . (($opt_alt_format && $tag_indent > 1)
+ ? ":" . " " x ($tag_indent - 1)
+ : " " x ($tag_indent))
+ . '@' . ('<' x ($indent - $tag_indent - 1))
+ . "^" . ("<" x ($cols - 1)) . "\n"
+ . '$tag, $_'
+ . "\n~~"
+ . (" " x ($indent-2))
+ . "^" . ("<" x ($cols - 5)) . "\n"
+ . '$_' . "\n\n.\n1";
+ #warn $str; warn "tag is $tag, _ is $_";
+ eval $str || die;
+ write OUTPUT;
+}
+
+sub output {
+ local($_, $reformat) = @_;
+ if ($reformat) {
+ $cols = $SCREEN - $indent;
+ s/\s+/ /g;
+ s/^ //;
+ $str = "format OUTPUT = \n~~"
+ . (" " x ($indent-2))
+ . "^" . ("<" x ($cols - 5)) . "\n"
+ . '$_' . "\n\n.\n1";
+ eval $str || die;
+ write OUTPUT;
+ } else {
+ s/^/' ' x $indent/gem;
+ s/^\s+\n$/\n/gm;
+ s/^ /: /s if defined($reformat) && $opt_alt_format;
+ print OUTPUT;
+ }
+}
+
+sub noremap {
+ local($thing_to_hide) = shift;
+ $thing_to_hide =~ tr/\000-\177/\200-\377/;
+ return $thing_to_hide;
+}
+
+sub init_noremap {
+ die "unmatched init" if $mapready++;
+ #mask off high bit characters in input stream
+ s/([\200-\377])/"E<".ord($1).">"/ge;
+}
+
+sub clear_noremap {
+ my $ready_to_print = $_[0];
+ die "unmatched clear" unless $mapready--;
+ tr/\200-\377/\000-\177/;
+ # now for the E<>s, which have been hidden until now
+ # otherwise the interative \w<> processing would have
+ # been hosed by the E<gt>
+ s {
+ E<
+ (
+ ( \d+ )
+ | ( [A-Za-z]+ )
+ )
+ >
+ } {
+ do {
+ defined $2
+ ? chr($2)
+ :
+ defined $HTML_Escapes{$3}
+ ? do { $HTML_Escapes{$3} }
+ : do {
+ warn "Unknown escape: E<$1> in $_";
+ "E<$1>";
+ }
+ }
+ }egx if $ready_to_print;
+}
+
+sub internal_lrefs {
+ local($_) = shift;
+ s{L</([^>]+)>}{$1}g;
+ my(@items) = split( /(?:,?\s+(?:and\s+)?)/ );
+ my $retstr = "the ";
+ my $i;
+ for ($i = 0; $i <= $#items; $i++) {
+ $retstr .= "C<$items[$i]>";
+ $retstr .= ", " if @items > 2 && $i != $#items;
+ $retstr .= " and " if $i+2 == @items;
+ }
+
+ $retstr .= " entr" . ( @items > 1 ? "ies" : "y" )
+ . " elsewhere in this document ";
+
+ return $retstr;
+
+}
+
+BEGIN {
+
+%HTML_Escapes = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "\xC1", # capital A, acute accent
+ "aacute" => "\xE1", # small a, acute accent
+ "Acirc" => "\xC2", # capital A, circumflex accent
+ "acirc" => "\xE2", # small a, circumflex accent
+ "AElig" => "\xC6", # capital AE diphthong (ligature)
+ "aelig" => "\xE6", # small ae diphthong (ligature)
+ "Agrave" => "\xC0", # capital A, grave accent
+ "agrave" => "\xE0", # small a, grave accent
+ "Aring" => "\xC5", # capital A, ring
+ "aring" => "\xE5", # small a, ring
+ "Atilde" => "\xC3", # capital A, tilde
+ "atilde" => "\xE3", # small a, tilde
+ "Auml" => "\xC4", # capital A, dieresis or umlaut mark
+ "auml" => "\xE4", # small a, dieresis or umlaut mark
+ "Ccedil" => "\xC7", # capital C, cedilla
+ "ccedil" => "\xE7", # small c, cedilla
+ "Eacute" => "\xC9", # capital E, acute accent
+ "eacute" => "\xE9", # small e, acute accent
+ "Ecirc" => "\xCA", # capital E, circumflex accent
+ "ecirc" => "\xEA", # small e, circumflex accent
+ "Egrave" => "\xC8", # capital E, grave accent
+ "egrave" => "\xE8", # small e, grave accent
+ "ETH" => "\xD0", # capital Eth, Icelandic
+ "eth" => "\xF0", # small eth, Icelandic
+ "Euml" => "\xCB", # capital E, dieresis or umlaut mark
+ "euml" => "\xEB", # small e, dieresis or umlaut mark
+ "Iacute" => "\xCD", # capital I, acute accent
+ "iacute" => "\xED", # small i, acute accent
+ "Icirc" => "\xCE", # capital I, circumflex accent
+ "icirc" => "\xEE", # small i, circumflex accent
+ "Igrave" => "\xCD", # capital I, grave accent
+ "igrave" => "\xED", # small i, grave accent
+ "Iuml" => "\xCF", # capital I, dieresis or umlaut mark
+ "iuml" => "\xEF", # small i, dieresis or umlaut mark
+ "Ntilde" => "\xD1", # capital N, tilde
+ "ntilde" => "\xF1", # small n, tilde
+ "Oacute" => "\xD3", # capital O, acute accent
+ "oacute" => "\xF3", # small o, acute accent
+ "Ocirc" => "\xD4", # capital O, circumflex accent
+ "ocirc" => "\xF4", # small o, circumflex accent
+ "Ograve" => "\xD2", # capital O, grave accent
+ "ograve" => "\xF2", # small o, grave accent
+ "Oslash" => "\xD8", # capital O, slash
+ "oslash" => "\xF8", # small o, slash
+ "Otilde" => "\xD5", # capital O, tilde
+ "otilde" => "\xF5", # small o, tilde
+ "Ouml" => "\xD6", # capital O, dieresis or umlaut mark
+ "ouml" => "\xF6", # small o, dieresis or umlaut mark
+ "szlig" => "\xDF", # small sharp s, German (sz ligature)
+ "THORN" => "\xDE", # capital THORN, Icelandic
+ "thorn" => "\xFE", # small thorn, Icelandic
+ "Uacute" => "\xDA", # capital U, acute accent
+ "uacute" => "\xFA", # small u, acute accent
+ "Ucirc" => "\xDB", # capital U, circumflex accent
+ "ucirc" => "\xFB", # small u, circumflex accent
+ "Ugrave" => "\xD9", # capital U, grave accent
+ "ugrave" => "\xF9", # small u, grave accent
+ "Uuml" => "\xDC", # capital U, dieresis or umlaut mark
+ "uuml" => "\xFC", # small u, dieresis or umlaut mark
+ "Yacute" => "\xDD", # capital Y, acute accent
+ "yacute" => "\xFD", # small y, acute accent
+ "yuml" => "\xFF", # small y, dieresis or umlaut mark
+
+ "lchevron" => "\xAB", # left chevron (double less than)
+ "rchevron" => "\xBB", # right chevron (double greater than)
+);
+}
+
+1;
diff --git a/contrib/perl5/lib/Search/Dict.pm b/contrib/perl5/lib/Search/Dict.pm
new file mode 100644
index 000000000000..9a229a7bc020
--- /dev/null
+++ b/contrib/perl5/lib/Search/Dict.pm
@@ -0,0 +1,75 @@
+package Search::Dict;
+require 5.000;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(look);
+
+=head1 NAME
+
+Search::Dict, look - search for key in dictionary file
+
+=head1 SYNOPSIS
+
+ use Search::Dict;
+ look *FILEHANDLE, $key, $dict, $fold;
+
+=head1 DESCRIPTION
+
+Sets file position in FILEHANDLE to be first line greater than or equal
+(stringwise) to I<$key>. Returns the new file position, or -1 if an error
+occurs.
+
+The flags specify dictionary order and case folding:
+
+If I<$dict> is true, search by dictionary order (ignore anything but word
+characters and whitespace).
+
+If I<$fold> is true, ignore case.
+
+=cut
+
+sub look {
+ local(*FH,$key,$dict,$fold) = @_;
+ local($_);
+ my(@stat) = stat(FH)
+ or return -1;
+ my($size, $blksize) = @stat[7,11];
+ $blksize ||= 8192;
+ $key =~ s/[^\w\s]//g if $dict;
+ $key = lc $key if $fold;
+ my($min, $max, $mid) = (0, int($size / $blksize));
+ while ($max - $min > 1) {
+ $mid = int(($max + $min) / 2);
+ seek(FH, $mid * $blksize, 0)
+ or return -1;
+ <FH> if $mid; # probably a partial line
+ $_ = <FH>;
+ chop;
+ s/[^\w\s]//g if $dict;
+ $_ = lc $_ if $fold;
+ if (defined($_) && $_ lt $key) {
+ $min = $mid;
+ }
+ else {
+ $max = $mid;
+ }
+ }
+ $min *= $blksize;
+ seek(FH,$min,0)
+ or return -1;
+ <FH> if $min;
+ for (;;) {
+ $min = tell(FH);
+ defined($_ = <FH>)
+ or last;
+ chop;
+ s/[^\w\s]//g if $dict;
+ $_ = lc $_ if $fold;
+ last if $_ ge $key;
+ }
+ seek(FH,$min,0);
+ $min;
+}
+
+1;
diff --git a/contrib/perl5/lib/SelectSaver.pm b/contrib/perl5/lib/SelectSaver.pm
new file mode 100644
index 000000000000..5f569222fcc5
--- /dev/null
+++ b/contrib/perl5/lib/SelectSaver.pm
@@ -0,0 +1,52 @@
+package SelectSaver;
+
+=head1 NAME
+
+SelectSaver - save and restore selected file handle
+
+=head1 SYNOPSIS
+
+ use SelectSaver;
+
+ {
+ my $saver = new SelectSaver(FILEHANDLE);
+ # FILEHANDLE is selected
+ }
+ # previous handle is selected
+
+ {
+ my $saver = new SelectSaver;
+ # new handle may be selected, or not
+ }
+ # previous handle is selected
+
+=head1 DESCRIPTION
+
+A C<SelectSaver> object contains a reference to the file handle that
+was selected when it was created. If its C<new> method gets an extra
+parameter, then that parameter is selected; otherwise, the selected
+file handle remains unchanged.
+
+When a C<SelectSaver> is destroyed, it re-selects the file handle
+that was selected when it was created.
+
+=cut
+
+require 5.000;
+use Carp;
+use Symbol;
+
+sub new {
+ @_ >= 1 && @_ <= 2 or croak 'usage: new SelectSaver [FILEHANDLE]';
+ my $fh = select;
+ my $self = bless [$fh], $_[0];
+ select qualify($_[1], caller) if @_ > 1;
+ $self;
+}
+
+sub DESTROY {
+ my $this = $_[0];
+ select $$this[0];
+}
+
+1;
diff --git a/contrib/perl5/lib/SelfLoader.pm b/contrib/perl5/lib/SelfLoader.pm
new file mode 100644
index 000000000000..a73f68a8c4d7
--- /dev/null
+++ b/contrib/perl5/lib/SelfLoader.pm
@@ -0,0 +1,295 @@
+package SelfLoader;
+use Carp;
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(AUTOLOAD);
+$VERSION = "1.08";
+sub Version {$VERSION}
+$DEBUG = 0;
+
+my %Cache; # private cache for all SelfLoader's client packages
+
+AUTOLOAD {
+ print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if $DEBUG;
+ my $SL_code = $Cache{$AUTOLOAD};
+ unless ($SL_code) {
+ # Maybe this pack had stubs before __DATA__, and never initialized.
+ # Or, this maybe an automatic DESTROY method call when none exists.
+ $AUTOLOAD =~ m/^(.*)::/;
+ SelfLoader->_load_stubs($1) unless exists $Cache{"${1}::<DATA"};
+ $SL_code = $Cache{$AUTOLOAD};
+ $SL_code = "sub $AUTOLOAD { }"
+ if (!$SL_code and $AUTOLOAD =~ m/::DESTROY$/);
+ croak "Undefined subroutine $AUTOLOAD" unless $SL_code;
+ }
+ print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if $DEBUG;
+ eval $SL_code;
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ croak $@;
+ }
+ defined(&$AUTOLOAD) || die "SelfLoader inconsistency error";
+ delete $Cache{$AUTOLOAD};
+ goto &$AUTOLOAD
+}
+
+sub load_stubs { shift->_load_stubs((caller)[0]) }
+
+sub _load_stubs {
+ my($self, $callpack) = @_;
+ my $fh = \*{"${callpack}::DATA"};
+ my $currpack = $callpack;
+ my($line,$name,@lines, @stubs, $protoype);
+
+ print STDERR "SelfLoader::load_stubs($callpack)\n" if $DEBUG;
+ croak("$callpack doesn't contain an __DATA__ token")
+ unless fileno($fh);
+ $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
+
+ local($/) = "\n";
+ while(defined($line = <$fh>) and $line !~ m/^__END__/) {
+ if ($line =~ m/^sub\s+([\w:]+)\s*(\([\\\$\@\%\&\*\;]*\))?/) {
+ push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
+ $protoype = $2;
+ @lines = ($line);
+ if (index($1,'::') == -1) { # simple sub name
+ $name = "${currpack}::$1";
+ } else { # sub name with package
+ $name = $1;
+ $name =~ m/^(.*)::/;
+ if (defined(&{"${1}::AUTOLOAD"})) {
+ \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
+ die 'SelfLoader Error: attempt to specify Selfloading',
+ " sub $name in non-selfloading module $1";
+ } else {
+ $self->export($1,'AUTOLOAD');
+ }
+ }
+ } elsif ($line =~ m/^package\s+([\w:]+)/) { # A package declared
+ push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
+ $self->_package_defined($line);
+ $name = '';
+ @lines = ();
+ $currpack = $1;
+ $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
+ if (defined(&{"${1}::AUTOLOAD"})) {
+ \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
+ die 'SelfLoader Error: attempt to specify Selfloading',
+ " package $currpack which already has AUTOLOAD";
+ } else {
+ $self->export($currpack,'AUTOLOAD');
+ }
+ } else {
+ push(@lines,$line);
+ }
+ }
+ close($fh) unless defined($line) && $line =~ /^__END__\s*DATA/; # __END__
+ push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
+ eval join('', @stubs) if @stubs;
+}
+
+
+sub _add_to_cache {
+ my($self,$fullname,$pack,$lines, $protoype) = @_;
+ return () unless $fullname;
+ carp("Redefining sub $fullname") if exists $Cache{$fullname};
+ $Cache{$fullname} = join('', "package $pack; ",@$lines);
+ print STDERR "SelfLoader cached $fullname: $Cache{$fullname}" if $DEBUG;
+ # return stub to be eval'd
+ defined($protoype) ? "sub $fullname $protoype;" : "sub $fullname;"
+}
+
+sub _package_defined {}
+
+1;
+__END__
+
+=head1 NAME
+
+SelfLoader - load functions only on demand
+
+=head1 SYNOPSIS
+
+ package FOOBAR;
+ use SelfLoader;
+
+ ... (initializing code)
+
+ __DATA__
+ sub {....
+
+
+=head1 DESCRIPTION
+
+This module tells its users that functions in the FOOBAR package are to be
+autoloaded from after the C<__DATA__> token. See also
+L<perlsub/"Autoloading">.
+
+=head2 The __DATA__ token
+
+The C<__DATA__> token tells the perl compiler that the perl code
+for compilation is finished. Everything after the C<__DATA__> token
+is available for reading via the filehandle FOOBAR::DATA,
+where FOOBAR is the name of the current package when the C<__DATA__>
+token is reached. This works just the same as C<__END__> does in
+package 'main', but for other modules data after C<__END__> is not
+automatically retreivable , whereas data after C<__DATA__> is.
+The C<__DATA__> token is not recognized in versions of perl prior to
+5.001m.
+
+Note that it is possible to have C<__DATA__> tokens in the same package
+in multiple files, and that the last C<__DATA__> token in a given
+package that is encountered by the compiler is the one accessible
+by the filehandle. This also applies to C<__END__> and main, i.e. if
+the 'main' program has an C<__END__>, but a module 'require'd (_not_ 'use'd)
+by that program has a 'package main;' declaration followed by an 'C<__DATA__>',
+then the C<DATA> filehandle is set to access the data after the C<__DATA__>
+in the module, _not_ the data after the C<__END__> token in the 'main'
+program, since the compiler encounters the 'require'd file later.
+
+=head2 SelfLoader autoloading
+
+The B<SelfLoader> works by the user placing the C<__DATA__>
+token I<after> perl code which needs to be compiled and
+run at 'require' time, but I<before> subroutine declarations
+that can be loaded in later - usually because they may never
+be called.
+
+The B<SelfLoader> will read from the FOOBAR::DATA filehandle to
+load in the data after C<__DATA__>, and load in any subroutine
+when it is called. The costs are the one-time parsing of the
+data after C<__DATA__>, and a load delay for the _first_
+call of any autoloaded function. The benefits (hopefully)
+are a speeded up compilation phase, with no need to load
+functions which are never used.
+
+The B<SelfLoader> will stop reading from C<__DATA__> if
+it encounters the C<__END__> token - just as you would expect.
+If the C<__END__> token is present, and is followed by the
+token DATA, then the B<SelfLoader> leaves the FOOBAR::DATA
+filehandle open on the line after that token.
+
+The B<SelfLoader> exports the C<AUTOLOAD> subroutine to the
+package using the B<SelfLoader>, and this loads the called
+subroutine when it is first called.
+
+There is no advantage to putting subroutines which will _always_
+be called after the C<__DATA__> token.
+
+=head2 Autoloading and package lexicals
+
+A 'my $pack_lexical' statement makes the variable $pack_lexical
+local _only_ to the file up to the C<__DATA__> token. Subroutines
+declared elsewhere _cannot_ see these types of variables,
+just as if you declared subroutines in the package but in another
+file, they cannot see these variables.
+
+So specifically, autoloaded functions cannot see package
+lexicals (this applies to both the B<SelfLoader> and the Autoloader).
+The C<vars> pragma provides an alternative to defining package-level
+globals that will be visible to autoloaded routines. See the documentation
+on B<vars> in the pragma section of L<perlmod>.
+
+=head2 SelfLoader and AutoLoader
+
+The B<SelfLoader> can replace the AutoLoader - just change 'use AutoLoader'
+to 'use SelfLoader' (though note that the B<SelfLoader> exports
+the AUTOLOAD function - but if you have your own AUTOLOAD and
+are using the AutoLoader too, you probably know what you're doing),
+and the C<__END__> token to C<__DATA__>. You will need perl version 5.001m
+or later to use this (version 5.001 with all patches up to patch m).
+
+There is no need to inherit from the B<SelfLoader>.
+
+The B<SelfLoader> works similarly to the AutoLoader, but picks up the
+subs from after the C<__DATA__> instead of in the 'lib/auto' directory.
+There is a maintainance gain in not needing to run AutoSplit on the module
+at installation, and a runtime gain in not needing to keep opening and
+closing files to load subs. There is a runtime loss in needing
+to parse the code after the C<__DATA__>. Details of the B<AutoLoader> and
+another view of these distinctions can be found in that module's
+documentation.
+
+=head2 __DATA__, __END__, and the FOOBAR::DATA filehandle.
+
+This section is only relevant if you want to use
+the C<FOOBAR::DATA> together with the B<SelfLoader>.
+
+Data after the C<__DATA__> token in a module is read using the
+FOOBAR::DATA filehandle. C<__END__> can still be used to denote the end
+of the C<__DATA__> section if followed by the token DATA - this is supported
+by the B<SelfLoader>. The C<FOOBAR::DATA> filehandle is left open if an
+C<__END__> followed by a DATA is found, with the filehandle positioned at
+the start of the line after the C<__END__> token. If no C<__END__> token is
+present, or an C<__END__> token with no DATA token on the same line, then
+the filehandle is closed.
+
+The B<SelfLoader> reads from wherever the current
+position of the C<FOOBAR::DATA> filehandle is, until the
+EOF or C<__END__>. This means that if you want to use
+that filehandle (and ONLY if you want to), you should either
+
+1. Put all your subroutine declarations immediately after
+the C<__DATA__> token and put your own data after those
+declarations, using the C<__END__> token to mark the end
+of subroutine declarations. You must also ensure that the B<SelfLoader>
+reads first by calling 'SelfLoader-E<gt>load_stubs();', or by using a
+function which is selfloaded;
+
+or
+
+2. You should read the C<FOOBAR::DATA> filehandle first, leaving
+the handle open and positioned at the first line of subroutine
+declarations.
+
+You could conceivably do both.
+
+=head2 Classes and inherited methods.
+
+For modules which are not classes, this section is not relevant.
+This section is only relevant if you have methods which could
+be inherited.
+
+A subroutine stub (or forward declaration) looks like
+
+ sub stub;
+
+i.e. it is a subroutine declaration without the body of the
+subroutine. For modules which are not classes, there is no real
+need for stubs as far as autoloading is concerned.
+
+For modules which ARE classes, and need to handle inherited methods,
+stubs are needed to ensure that the method inheritance mechanism works
+properly. You can load the stubs into the module at 'require' time, by
+adding the statement 'SelfLoader-E<gt>load_stubs();' to the module to do
+this.
+
+The alternative is to put the stubs in before the C<__DATA__> token BEFORE
+releasing the module, and for this purpose the C<Devel::SelfStubber>
+module is available. However this does require the extra step of ensuring
+that the stubs are in the module. If this is done I strongly recommend
+that this is done BEFORE releasing the module - it should NOT be done
+at install time in general.
+
+=head1 Multiple packages and fully qualified subroutine names
+
+Subroutines in multiple packages within the same file are supported - but you
+should note that this requires exporting the C<SelfLoader::AUTOLOAD> to
+every package which requires it. This is done automatically by the
+B<SelfLoader> when it first loads the subs into the cache, but you should
+really specify it in the initialization before the C<__DATA__> by putting
+a 'use SelfLoader' statement in each package.
+
+Fully qualified subroutine names are also supported. For example,
+
+ __DATA__
+ sub foo::bar {23}
+ package baz;
+ sub dob {32}
+
+will all be loaded correctly by the B<SelfLoader>, and the B<SelfLoader>
+will ensure that the packages 'foo' and 'baz' correctly have the
+B<SelfLoader> C<AUTOLOAD> method when the data after C<__DATA__> is first
+parsed.
+
+=cut
diff --git a/contrib/perl5/lib/Shell.pm b/contrib/perl5/lib/Shell.pm
new file mode 100644
index 000000000000..f4ef431cc54e
--- /dev/null
+++ b/contrib/perl5/lib/Shell.pm
@@ -0,0 +1,126 @@
+package Shell;
+
+use Config;
+
+sub import {
+ my $self = shift;
+ my ($callpack, $callfile, $callline) = caller;
+ my @EXPORT;
+ if (@_) {
+ @EXPORT = @_;
+ }
+ else {
+ @EXPORT = 'AUTOLOAD';
+ }
+ foreach $sym (@EXPORT) {
+ *{"${callpack}::$sym"} = \&{"Shell::$sym"};
+ }
+};
+
+AUTOLOAD {
+ my $cmd = $AUTOLOAD;
+ $cmd =~ s/^.*:://;
+ eval qq {
+ *$AUTOLOAD = sub {
+ if (\@_ < 1) {
+ `$cmd`;
+ }
+ elsif (\$Config{'archname'} eq 'os2') {
+ local(\*SAVEOUT, \*READ, \*WRITE);
+
+ open SAVEOUT, '>&STDOUT' or die;
+ pipe READ, WRITE or die;
+ open STDOUT, '>&WRITE' or die;
+ close WRITE;
+
+ my \$pid = system(1, \$cmd, \@_);
+ die "Can't execute $cmd: \$!\n" if \$pid < 0;
+
+ open STDOUT, '>&SAVEOUT' or die;
+ close SAVEOUT;
+
+ if (wantarray) {
+ my \@ret = <READ>;
+ close READ;
+ waitpid \$pid, 0;
+ \@ret;
+ }
+ else {
+ local(\$/) = undef;
+ my \$ret = <READ>;
+ close READ;
+ waitpid \$pid, 0;
+ \$ret;
+ }
+ }
+ else {
+ open(SUBPROC, "-|")
+ or exec '$cmd', \@_
+ or die "Can't exec $cmd: \$!\n";
+ if (wantarray) {
+ my \@ret = <SUBPROC>;
+ close SUBPROC; # XXX Oughta use a destructor.
+ \@ret;
+ }
+ else {
+ local(\$/) = undef;
+ my \$ret = <SUBPROC>;
+ close SUBPROC;
+ \$ret;
+ }
+ }
+ }
+ };
+ goto &$AUTOLOAD;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Shell - run shell commands transparently within perl
+
+=head1 SYNOPSIS
+
+See below.
+
+=head1 DESCRIPTION
+
+ Date: Thu, 22 Sep 94 16:18:16 -0700
+ Message-Id: <9409222318.AA17072@scalpel.netlabs.com>
+ To: perl5-porters@isu.edu
+ From: Larry Wall <lwall@scalpel.netlabs.com>
+ Subject: a new module I just wrote
+
+Here's one that'll whack your mind a little out.
+
+ #!/usr/bin/perl
+
+ use Shell;
+
+ $foo = echo("howdy", "<funny>", "world");
+ print $foo;
+
+ $passwd = cat("</etc/passwd");
+ print $passwd;
+
+ sub ps;
+ print ps -ww;
+
+ cp("/etc/passwd", "/tmp/passwd");
+
+That's maybe too gonzo. It actually exports an AUTOLOAD to the current
+package (and uncovered a bug in Beta 3, by the way). Maybe the usual
+usage should be
+
+ use Shell qw(echo cat ps cp);
+
+Larry
+
+
+=head1 AUTHOR
+
+Larry Wall
+
+=cut
diff --git a/contrib/perl5/lib/Symbol.pm b/contrib/perl5/lib/Symbol.pm
new file mode 100644
index 000000000000..5ed6b2667bf2
--- /dev/null
+++ b/contrib/perl5/lib/Symbol.pm
@@ -0,0 +1,139 @@
+package Symbol;
+
+=head1 NAME
+
+Symbol - manipulate Perl symbols and their names
+
+=head1 SYNOPSIS
+
+ use Symbol;
+
+ $sym = gensym;
+ open($sym, "filename");
+ $_ = <$sym>;
+ # etc.
+
+ ungensym $sym; # no effect
+
+ print qualify("x"), "\n"; # "Test::x"
+ print qualify("x", "FOO"), "\n" # "FOO::x"
+ print qualify("BAR::x"), "\n"; # "BAR::x"
+ print qualify("BAR::x", "FOO"), "\n"; # "BAR::x"
+ print qualify("STDOUT", "FOO"), "\n"; # "main::STDOUT" (global)
+ print qualify(\*x), "\n"; # returns \*x
+ print qualify(\*x, "FOO"), "\n"; # returns \*x
+
+ use strict refs;
+ print { qualify_to_ref $fh } "foo!\n";
+ $ref = qualify_to_ref $name, $pkg;
+
+ use Symbol qw(delete_package);
+ delete_package('Foo::Bar');
+ print "deleted\n" unless exists $Foo::{'Bar::'};
+
+
+=head1 DESCRIPTION
+
+C<Symbol::gensym> creates an anonymous glob and returns a reference
+to it. Such a glob reference can be used as a file or directory
+handle.
+
+For backward compatibility with older implementations that didn't
+support anonymous globs, C<Symbol::ungensym> is also provided.
+But it doesn't do anything.
+
+C<Symbol::qualify> turns unqualified symbol names into qualified
+variable names (e.g. "myvar" -E<gt> "MyPackage::myvar"). If it is given a
+second parameter, C<qualify> uses it as the default package;
+otherwise, it uses the package of its caller. Regardless, global
+variable names (e.g. "STDOUT", "ENV", "SIG") are always qualfied with
+"main::".
+
+Qualification applies only to symbol names (strings). References are
+left unchanged under the assumption that they are glob references,
+which are qualified by their nature.
+
+C<Symbol::qualify_to_ref> is just like C<Symbol::qualify> except that it
+returns a glob ref rather than a symbol name, so you can use the result
+even if C<use strict 'refs'> is in effect.
+
+C<Symbol::delete_package> wipes out a whole package namespace. Note
+this routine is not exported by default--you may want to import it
+explicitly.
+
+=cut
+
+BEGIN { require 5.002; }
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
+@EXPORT_OK = qw(delete_package);
+
+$VERSION = 1.02;
+
+my $genpkg = "Symbol::";
+my $genseq = 0;
+
+my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT);
+
+#
+# Note that we never _copy_ the glob; we just make a ref to it.
+# If we did copy it, then SVf_FAKE would be set on the copy, and
+# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work.
+#
+sub gensym () {
+ my $name = "GEN" . $genseq++;
+ my $ref = \*{$genpkg . $name};
+ delete $$genpkg{$name};
+ $ref;
+}
+
+sub ungensym ($) {}
+
+sub qualify ($;$) {
+ my ($name) = @_;
+ if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) {
+ my $pkg;
+ # Global names: special character, "^x", or other.
+ if ($name =~ /^([^a-z])|(\^[a-z])$/i || $global{$name}) {
+ $pkg = "main";
+ }
+ else {
+ $pkg = (@_ > 1) ? $_[1] : caller;
+ }
+ $name = $pkg . "::" . $name;
+ }
+ $name;
+}
+
+sub qualify_to_ref ($;$) {
+ return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
+}
+
+#
+# of Safe.pm lineage
+#
+sub delete_package ($) {
+ my $pkg = shift;
+
+ # expand to full symbol table name if needed
+
+ unless ($pkg =~ /^main::.*::$/) {
+ $pkg = "main$pkg" if $pkg =~ /^::/;
+ $pkg = "main::$pkg" unless $pkg =~ /^main::/;
+ $pkg .= '::' unless $pkg =~ /::$/;
+ }
+
+ my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+ my $stem_symtab = *{$stem}{HASH};
+ return unless defined $stem_symtab and exists $stem_symtab->{$leaf};
+
+ my $leaf_glob = $stem_symtab->{$leaf};
+ my $leaf_symtab = *{$leaf_glob}{HASH};
+
+ %$leaf_symtab = ();
+ delete $stem_symtab->{$leaf};
+}
+
+1;
diff --git a/contrib/perl5/lib/Sys/Hostname.pm b/contrib/perl5/lib/Sys/Hostname.pm
new file mode 100644
index 000000000000..95f9a99a7abf
--- /dev/null
+++ b/contrib/perl5/lib/Sys/Hostname.pm
@@ -0,0 +1,121 @@
+package Sys::Hostname;
+
+use Carp;
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(hostname);
+
+=head1 NAME
+
+Sys::Hostname - Try every conceivable way to get hostname
+
+=head1 SYNOPSIS
+
+ use Sys::Hostname;
+ $host = hostname;
+
+=head1 DESCRIPTION
+
+Attempts several methods of getting the system hostname and
+then caches the result. It tries C<syscall(SYS_gethostname)>,
+C<`hostname`>, C<`uname -n`>, and the file F</com/host>.
+If all that fails it C<croak>s.
+
+All nulls, returns, and newlines are removed from the result.
+
+=head1 AUTHOR
+
+David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt>
+
+Texas Instruments
+
+=cut
+
+sub hostname {
+
+ # method 1 - we already know it
+ return $host if defined $host;
+
+ if ($^O eq 'VMS') {
+
+ # method 2 - no sockets ==> return DECnet node name
+ eval { local $SIG{__DIE__}; $host = (gethostbyname('me'))[0] };
+ if ($@) { return $host = $ENV{'SYS$NODE'}; }
+
+ # method 3 - has someone else done the job already? It's common for the
+ # TCP/IP stack to advertise the hostname via a logical name. (Are
+ # there any other logicals which TCP/IP stacks use for the host name?)
+ $host = $ENV{'ARPANET_HOST_NAME'} || $ENV{'INTERNET_HOST_NAME'} ||
+ $ENV{'MULTINET_HOST_NAME'} || $ENV{'UCX$INET_HOST'} ||
+ $ENV{'TCPWARE_DOMAINNAME'} || $ENV{'NEWS_ADDRESS'};
+ return $host if $host;
+
+ # method 4 - does hostname happen to work?
+ my($rslt) = `hostname`;
+ if ($rslt !~ /IVVERB/) { ($host) = $rslt =~ /^(\S+)/; }
+ return $host if $host;
+
+ # rats!
+ $host = '';
+ Carp::croak "Cannot get host name of local machine";
+
+ }
+ elsif ($^O eq 'MSWin32') {
+ ($host) = gethostbyname('localhost');
+ chomp($host = `hostname 2> NUL`) unless defined $host;
+ return $host;
+ }
+ else { # Unix
+
+ # method 2 - syscall is preferred since it avoids tainting problems
+ eval {
+ local $SIG{__DIE__};
+ {
+ package main;
+ require "syscall.ph";
+ }
+ $host = "\0" x 65; ## preload scalar
+ syscall(&main::SYS_gethostname, $host, 65) == 0;
+ }
+
+ # method 2a - syscall using systeminfo instead of gethostname
+ # -- needed on systems like Solaris
+ || eval {
+ local $SIG{__DIE__};
+ {
+ package main;
+ require "sys/syscall.ph";
+ require "sys/systeminfo.ph";
+ }
+ $host = "\0" x 65; ## preload scalar
+ syscall(&main::SYS_systeminfo, &main::SI_HOSTNAME, $host, 65) != -1;
+ }
+
+ # method 3 - trusty old hostname command
+ || eval {
+ local $SIG{__DIE__};
+ $host = `(hostname) 2>/dev/null`; # bsdish
+ }
+
+ # method 4 - sysV uname command (may truncate)
+ || eval {
+ local $SIG{__DIE__};
+ $host = `uname -n 2>/dev/null`; ## sysVish
+ }
+
+ # method 5 - Apollo pre-SR10
+ || eval {
+ local $SIG{__DIE__};
+ ($host,$a,$b,$c,$d)=split(/[:\. ]/,`/com/host`,6);
+ }
+
+ # bummer
+ || Carp::croak "Cannot get host name of local machine";
+
+ # remove garbage
+ $host =~ tr/\0\r\n//d;
+ $host;
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/Sys/Syslog.pm b/contrib/perl5/lib/Sys/Syslog.pm
new file mode 100644
index 000000000000..e8faac71262e
--- /dev/null
+++ b/contrib/perl5/lib/Sys/Syslog.pm
@@ -0,0 +1,276 @@
+package Sys::Syslog;
+require 5.000;
+require Exporter;
+use Carp;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(openlog closelog setlogmask syslog);
+@EXPORT_OK = qw(setlogsock);
+
+use Socket;
+use Sys::Hostname;
+
+# adapted from syslog.pl
+#
+# Tom Christiansen <tchrist@convex.com>
+# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
+# NOTE: openlog now takes three arguments, just like openlog(3)
+# Modified to add UNIX domain sockets by Sean Robinson <robinson_s@sc.maricopa.edu>
+# with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list
+
+# Todo: enable connect to try all three types before failing (auto setlogsock)?
+
+=head1 NAME
+
+Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX syslog(3) calls
+
+=head1 SYNOPSIS
+
+ use Sys::Syslog; # all except setlogsock, or:
+ use Sys::Syslog qw(:DEFAULT setlogsock); # default set, plus setlogsock
+
+ setlogsock $sock_type;
+ openlog $ident, $logopt, $facility;
+ syslog $priority, $format, @args;
+ $oldmask = setlogmask $mask_priority;
+ closelog;
+
+=head1 DESCRIPTION
+
+Sys::Syslog is an interface to the UNIX C<syslog(3)> program.
+Call C<syslog()> with a string priority and a list of C<printf()> args
+just like C<syslog(3)>.
+
+Syslog provides the functions:
+
+=over
+
+=item openlog $ident, $logopt, $facility
+
+I<$ident> is prepended to every message.
+I<$logopt> contains zero or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>.
+I<$facility> specifies the part of the system
+
+=item syslog $priority, $format, @args
+
+If I<$priority> permits, logs I<($format, @args)>
+printed as by C<printf(3V)>, with the addition that I<%m>
+is replaced with C<"$!"> (the latest error message).
+
+=item setlogmask $mask_priority
+
+Sets log mask I<$mask_priority> and returns the old mask.
+
+=item setlogsock $sock_type (added in 5.004_02)
+
+Sets the socket type to be used for the next call to
+C<openlog()> or C<syslog()> and returns TRUE on success,
+undef on failure.
+
+A value of 'unix' will connect to the UNIX domain socket returned by
+C<_PATH_LOG> in F<syslog.ph>. A value of 'inet' will connect to an
+INET socket returned by getservbyname(). Any other value croaks.
+
+The default is for the INET socket to be used.
+
+=item closelog
+
+Closes the log file.
+
+=back
+
+Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
+
+=head1 EXAMPLES
+
+ openlog($program, 'cons,pid', 'user');
+ syslog('info', 'this is another test');
+ syslog('mail|warning', 'this is a better test: %d', time);
+ closelog();
+
+ syslog('debug', 'this is the last test');
+
+ setlogsock('unix');
+ openlog("$program $$", 'ndelay', 'user');
+ syslog('notice', 'fooprogram: this is really done');
+
+ setlogsock('inet');
+ $! = 55;
+ syslog('info', 'problem was %m'); # %m == $! in syslog(3)
+
+=head1 DEPENDENCIES
+
+B<Sys::Syslog> needs F<syslog.ph>, which can be created with C<h2ph>.
+
+=head1 SEE ALSO
+
+L<syslog(3)>
+
+=head1 AUTHOR
+
+Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<larry@wall.org>E<gt>.
+UNIX domain sockets added by Sean Robinson E<lt>F<robinson_s@sc.maricopa.edu>E<gt>
+with support from Tim Bunce <Tim.Bunce@ig.co.uk> and the perl5-porters mailing list.
+
+=cut
+
+require 'syslog.ph';
+
+$maskpri = &LOG_UPTO(&LOG_DEBUG);
+
+sub openlog {
+ ($ident, $logopt, $facility) = @_; # package vars
+ $lo_pid = $logopt =~ /\bpid\b/;
+ $lo_ndelay = $logopt =~ /\bndelay\b/;
+ $lo_cons = $logopt =~ /\bcons\b/;
+ $lo_nowait = $logopt =~ /\bnowait\b/;
+ &connect if $lo_ndelay;
+}
+
+sub closelog {
+ $facility = $ident = '';
+ &disconnect;
+}
+
+sub setlogmask {
+ local($oldmask) = $maskpri;
+ $maskpri = shift;
+ $oldmask;
+}
+
+sub setlogsock {
+ local($setsock) = shift;
+ &disconnect if $connected;
+ if (lc($setsock) eq 'unix') {
+ if (defined &_PATH_LOG) {
+ $sock_type = 1;
+ } else {
+ return undef;
+ }
+ } elsif (lc($setsock) eq 'inet') {
+ if (getservbyname('syslog','udp')) {
+ undef($sock_type);
+ } else {
+ return undef;
+ }
+ } else {
+ croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'";
+ }
+ return 1;
+}
+
+sub syslog {
+ local($priority) = shift;
+ local($mask) = shift;
+ local($message, $whoami);
+ local(@words, $num, $numpri, $numfac, $sum);
+ local($facility) = $facility; # may need to change temporarily.
+
+ croak "syslog: expected both priority and mask" unless $mask && $priority;
+
+ @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
+ undef $numpri;
+ undef $numfac;
+ foreach (@words) {
+ $num = &xlate($_); # Translate word to number.
+ if (/^kern$/ || $num < 0) {
+ croak "syslog: invalid level/facility: $_";
+ }
+ elsif ($num <= &LOG_PRIMASK) {
+ croak "syslog: too many levels given: $_" if defined($numpri);
+ $numpri = $num;
+ return 0 unless &LOG_MASK($numpri) & $maskpri;
+ }
+ else {
+ croak "syslog: too many facilities given: $_" if defined($numfac);
+ $facility = $_;
+ $numfac = $num;
+ }
+ }
+
+ croak "syslog: level must be given" unless defined($numpri);
+
+ if (!defined($numfac)) { # Facility not specified in this call.
+ $facility = 'user' unless $facility;
+ $numfac = &xlate($facility);
+ }
+
+ &connect unless $connected;
+
+ $whoami = $ident;
+
+ if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
+ $whoami = $1;
+ $mask = $2;
+ }
+
+ unless ($whoami) {
+ ($whoami = getlogin) ||
+ ($whoami = getpwuid($<)) ||
+ ($whoami = 'syslog');
+ }
+
+ $whoami .= "[$$]" if $lo_pid;
+
+ $mask =~ s/%m/$!/g;
+ $mask .= "\n" unless $mask =~ /\n$/;
+ $message = sprintf ($mask, @_);
+
+ $sum = $numpri + $numfac;
+ unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) {
+ if ($lo_cons) {
+ if ($pid = fork) {
+ unless ($lo_nowait) {
+ $died = waitpid($pid, 0);
+ }
+ }
+ else {
+ open(CONS,">/dev/console");
+ print CONS "<$facility.$priority>$whoami: $message\r";
+ exit if defined $pid; # if fork failed, we're parent
+ close CONS;
+ }
+ }
+ }
+}
+
+sub xlate {
+ local($name) = @_;
+ $name = uc $name;
+ $name = "LOG_$name" unless $name =~ /^LOG_/;
+ $name = "Sys::Syslog::$name";
+ defined &$name ? &$name : -1;
+}
+
+sub connect {
+ unless ($host) {
+ require Sys::Hostname;
+ my($host_uniq) = Sys::Hostname::hostname();
+ ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
+ }
+ unless ( $sock_type ) {
+ my $udp = getprotobyname('udp');
+ my $syslog = getservbyname('syslog','udp');
+ my $this = sockaddr_in($syslog, INADDR_ANY);
+ my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host");
+ socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!";
+ connect(SYSLOG,$that) || croak "connect: $!";
+ } else {
+ my $syslog = &_PATH_LOG || croak "_PATH_LOG not found in syslog.ph";
+ my $that = sockaddr_un($syslog) || croak "Can't locate $syslog";
+ socket(SYSLOG,AF_UNIX,SOCK_STREAM,0) || croak "socket: $!";
+ if (!connect(SYSLOG,$that)) {
+ socket(SYSLOG,AF_UNIX,SOCK_DGRAM,0) || croak "socket: $!";
+ connect(SYSLOG,$that) || croak "connect: $! (SOCK_DGRAM after trying SOCK_STREAM)";
+ }
+ }
+ local($old) = select(SYSLOG); $| = 1; select($old);
+ $connected = 1;
+}
+
+sub disconnect {
+ close SYSLOG;
+ $connected = 0;
+}
+
+1;
diff --git a/contrib/perl5/lib/Term/Cap.pm b/contrib/perl5/lib/Term/Cap.pm
new file mode 100644
index 000000000000..1e95ec33b69f
--- /dev/null
+++ b/contrib/perl5/lib/Term/Cap.pm
@@ -0,0 +1,410 @@
+package Term::Cap;
+use Carp;
+
+# Last updated: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
+
+# TODO:
+# support Berkeley DB termcaps
+# should probably be a .xs module
+# force $FH into callers package?
+# keep $FH in object at Tgetent time?
+
+=head1 NAME
+
+Term::Cap - Perl termcap interface
+
+=head1 SYNOPSIS
+
+ require Term::Cap;
+ $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+ $terminal->Trequire(qw/ce ku kd/);
+ $terminal->Tgoto('cm', $col, $row, $FH);
+ $terminal->Tputs('dl', $count, $FH);
+ $terminal->Tpad($string, $count, $FH);
+
+=head1 DESCRIPTION
+
+These are low-level functions to extract and use capabilities from
+a terminal capability (termcap) database.
+
+The B<Tgetent> function extracts the entry of the specified terminal
+type I<TERM> (defaults to the environment variable I<TERM>) from the
+database.
+
+It will look in the environment for a I<TERMCAP> variable. If
+found, and the value does not begin with a slash, and the terminal
+type name is the same as the environment string I<TERM>, the
+I<TERMCAP> string is used instead of reading a termcap file. If
+it does begin with a slash, the string is used as a path name of
+the termcap file to search. If I<TERMCAP> does not begin with a
+slash and name is different from I<TERM>, B<Tgetent> searches the
+files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
+in that order, unless the environment variable I<TERMPATH> exists,
+in which case it specifies a list of file pathnames (separated by
+spaces or colons) to be searched B<instead>. Whenever multiple
+files are searched and a tc field occurs in the requested entry,
+the entry it names must be found in the same file or one of the
+succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
+environment variable string it will continue the search in the
+files as above.
+
+I<OSPEED> is the terminal output bit rate (often mistakenly called
+the baud rate). I<OSPEED> can be specified as either a POSIX
+termios/SYSV termio speeds (where 9600 equals 9600) or an old
+BSD-style speeds (where 13 equals 9600).
+
+B<Tgetent> returns a blessed object reference which the user can
+then use to send the control strings to the terminal using B<Tputs>
+and B<Tgoto>. It calls C<croak> on failure.
+
+B<Tgoto> decodes a cursor addressing string with the given parameters.
+
+The output strings for B<Tputs> are cached for counts of 1 for performance.
+B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
+data and C<$self-E<gt>{xx}> is the cached version.
+
+ print $terminal->Tpad($self->{_xx}, 1);
+
+B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
+output the string to $FH if specified.
+
+The extracted termcap entry is available in the object
+as C<$self-E<gt>{TERMCAP}>.
+
+=head1 EXAMPLES
+
+ # Get terminal output speed
+ require POSIX;
+ my $termios = new POSIX::Termios;
+ $termios->getattr;
+ my $ospeed = $termios->getospeed;
+
+ # Old-style ioctl code to get ospeed:
+ # require 'ioctl.pl';
+ # ioctl(TTY,$TIOCGETP,$sgtty);
+ # ($ispeed,$ospeed) = unpack('cc',$sgtty);
+
+ # allocate and initialize a terminal structure
+ $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+
+ # require certain capabilities to be available
+ $terminal->Trequire(qw/ce ku kd/);
+
+ # Output Routines, if $FH is undefined these just return the string
+
+ # Tgoto does the % expansion stuff with the given args
+ $terminal->Tgoto('cm', $col, $row, $FH);
+
+ # Tputs doesn't do any % expansion.
+ $terminal->Tputs('dl', $count = 1, $FH);
+
+=cut
+
+# Returns a list of termcap files to check.
+sub termcap_path { ## private
+ my @termcap_path;
+ # $TERMCAP, if it's a filespec
+ push(@termcap_path, $ENV{TERMCAP})
+ if ((exists $ENV{TERMCAP}) &&
+ (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos')
+ ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/i
+ : $ENV{TERMCAP} =~ /^\//));
+ if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
+ # Add the users $TERMPATH
+ push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
+ }
+ else {
+ # Defaults
+ push(@termcap_path,
+ $ENV{'HOME'} . '/.termcap',
+ '/etc/termcap',
+ '/usr/share/misc/termcap',
+ );
+ }
+ # return the list of those termcaps that exist
+ grep(-f, @termcap_path);
+}
+
+sub Tgetent { ## public -- static method
+ my $class = shift;
+ my $self = bless shift, $class;
+ my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
+ local($termpat,$state,$first,$entry); # used inside eval
+ local $_;
+
+ # Compute PADDING factor from OSPEED (to be used by Tpad)
+ if (! $self->{OSPEED}) {
+ carp "OSPEED was not set, defaulting to 9600";
+ $self->{OSPEED} = 9600;
+ }
+ if ($self->{OSPEED} < 16) {
+ # delays for old style speeds
+ my @pad = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
+ $self->{PADDING} = $pad[$self->{OSPEED}];
+ }
+ else {
+ $self->{PADDING} = 10000 / $self->{OSPEED};
+ }
+
+ $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
+ $term = $self->{TERM}; # $term is the term type we are looking for
+
+ # $tmp_term is always the next term (possibly :tc=...:) we are looking for
+ $tmp_term = $self->{TERM};
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
+
+ my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : '');
+
+ # $entry is the extracted termcap entry
+ if (($foo !~ m:^/:) && ($foo =~ m/(^|\|)${termpat}[:|]/)) {
+ $entry = $foo;
+ }
+
+ my @termcap_path = termcap_path;
+ croak "Can't find a valid termcap file" unless @termcap_path || $entry;
+
+ $state = 1; # 0 == finished
+ # 1 == next file
+ # 2 == search again
+
+ $first = 0; # first entry (keeps term name)
+
+ $max = 32; # max :tc=...:'s
+
+ if ($entry) {
+ # ok, we're starting with $TERMCAP
+ $first++; # we're the first entry
+ # do we need to continue?
+ if ($entry =~ s/:tc=([^:]+):/:/) {
+ $tmp_term = $1;
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
+ }
+ else {
+ $state = 0; # we're already finished
+ }
+ }
+
+ # This is eval'ed inside the while loop for each file
+ $search = q{
+ while (<TERMCAP>) {
+ next if /^\\t/ || /^#/;
+ if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
+ chomp;
+ s/^[^:]*:// if $first++;
+ $state = 0;
+ while ($_ =~ s/\\\\$//) {
+ defined(my $x = <TERMCAP>) or last;
+ $_ .= $x; chomp;
+ }
+ last;
+ }
+ }
+ defined $entry or $entry = '';
+ $entry .= $_;
+ };
+
+ while ($state != 0) {
+ if ($state == 1) {
+ # get the next TERMCAP
+ $TERMCAP = shift @termcap_path
+ || croak "failed termcap lookup on $tmp_term";
+ }
+ else {
+ # do the same file again
+ # prevent endless recursion
+ $max-- || croak "failed termcap loop at $tmp_term";
+ $state = 1; # ok, maybe do a new file next time
+ }
+
+ open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
+ eval $search;
+ die $@ if $@;
+ close TERMCAP;
+
+ # If :tc=...: found then search this file again
+ $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
+ }
+
+ croak "Can't find $term" if $entry eq '';
+ $entry =~ s/:+\s*:+/:/g; # cleanup $entry
+ $entry =~ s/:+/:/g; # cleanup $entry
+ $self->{TERMCAP} = $entry; # save it
+ # print STDERR "DEBUG: $entry = ", $entry, "\n";
+
+ # Precompile $entry into the object
+ $entry =~ s/^[^:]*://;
+ foreach $field (split(/:[\s:\\]*/,$entry)) {
+ if ($field =~ /^(\w\w)$/) {
+ $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
+ # print STDERR "DEBUG: flag $1\n";
+ }
+ elsif ($field =~ /^(\w\w)\@/) {
+ $self->{'_' . $1} = "";
+ # print STDERR "DEBUG: unset $1\n";
+ }
+ elsif ($field =~ /^(\w\w)#(.*)/) {
+ $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
+ # print STDERR "DEBUG: numeric $1 = $2\n";
+ }
+ elsif ($field =~ /^(\w\w)=(.*)/) {
+ # print STDERR "DEBUG: string $1 = $2\n";
+ next if defined $self->{'_' . ($cap = $1)};
+ $_ = $2;
+ s/\\E/\033/g;
+ s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
+ s/\\n/\n/g;
+ s/\\r/\r/g;
+ s/\\t/\t/g;
+ s/\\b/\b/g;
+ s/\\f/\f/g;
+ s/\\\^/\377/g;
+ s/\^\?/\177/g;
+ s/\^(.)/pack('c',ord($1) & 31)/eg;
+ s/\\(.)/$1/g;
+ s/\377/^/g;
+ $self->{'_' . $cap} = $_;
+ }
+ # else { carp "junk in $term ignored: $field"; }
+ }
+ $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
+ $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
+ $self;
+}
+
+# $terminal->Tpad($string, $cnt, $FH);
+sub Tpad { ## public
+ my $self = shift;
+ my($string, $cnt, $FH) = @_;
+ my($decr, $ms);
+
+ if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
+ $ms = $1;
+ $ms *= $cnt if $2;
+ $string = $3;
+ $decr = $self->{PADDING};
+ if ($decr > .1) {
+ $ms += $decr / 2;
+ $string .= $self->{'_pc'} x ($ms / $decr);
+ }
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+# $terminal->Tputs($cap, $cnt, $FH);
+sub Tputs { ## public
+ my $self = shift;
+ my($cap, $cnt, $FH) = @_;
+ my $string;
+
+ if ($cnt > 1) {
+ $string = Tpad($self, $self->{'_' . $cap}, $cnt);
+ } else {
+ # cache result because Tpad can be slow
+ $string = defined $self->{$cap} ? $self->{$cap} :
+ ($self->{$cap} = Tpad($self, $self->{'_' . $cap}, 1));
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+# %% output `%'
+# %d output value as in printf %d
+# %2 output value as in printf %2d
+# %3 output value as in printf %3d
+# %. output value as in printf %c
+# %+x add x to value, then do %.
+#
+# %>xy if value > x then add y, no output
+# %r reverse order of two parameters, no output
+# %i increment by one, no output
+# %B BCD (16*(value/10)) + (value%10), no output
+#
+# %n exclusive-or all parameters with 0140 (Datamedia 2500)
+# %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
+#
+# $terminal->Tgoto($cap, $col, $row, $FH);
+sub Tgoto { ## public
+ my $self = shift;
+ my($cap, $code, $tmp, $FH) = @_;
+ my $string = $self->{'_' . $cap};
+ my $result = '';
+ my $after = '';
+ my $online = 0;
+ my @tmp = ($tmp,$code);
+ my $cnt = $code;
+
+ while ($string =~ /^([^%]*)%(.)(.*)/) {
+ $result .= $1;
+ $code = $2;
+ $string = $3;
+ if ($code eq 'd') {
+ $result .= sprintf("%d",shift(@tmp));
+ }
+ elsif ($code eq '.') {
+ $tmp = shift(@tmp);
+ if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
+ if ($online) {
+ ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
+ }
+ else {
+ ++$tmp, $after .= $self->{'_bc'};
+ }
+ }
+ $result .= sprintf("%c",$tmp);
+ $online = !$online;
+ }
+ elsif ($code eq '+') {
+ $result .= sprintf("%c",shift(@tmp)+ord($string));
+ $string = substr($string,1,99);
+ $online = !$online;
+ }
+ elsif ($code eq 'r') {
+ ($code,$tmp) = @tmp;
+ @tmp = ($tmp,$code);
+ $online = !$online;
+ }
+ elsif ($code eq '>') {
+ ($code,$tmp,$string) = unpack("CCa99",$string);
+ if ($tmp[$[] > $code) {
+ $tmp[$[] += $tmp;
+ }
+ }
+ elsif ($code eq '2') {
+ $result .= sprintf("%02d",shift(@tmp));
+ $online = !$online;
+ }
+ elsif ($code eq '3') {
+ $result .= sprintf("%03d",shift(@tmp));
+ $online = !$online;
+ }
+ elsif ($code eq 'i') {
+ ($code,$tmp) = @tmp;
+ @tmp = ($code+1,$tmp+1);
+ }
+ else {
+ return "OOPS";
+ }
+ }
+ $string = Tpad($self, $result . $string . $after, $cnt);
+ print $FH $string if $FH;
+ $string;
+}
+
+# $terminal->Trequire(qw/ce ku kd/);
+sub Trequire { ## public
+ my $self = shift;
+ my($cap,@undefined);
+ foreach $cap (@_) {
+ push(@undefined, $cap)
+ unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
+ }
+ croak "Terminal does not support: (@undefined)" if @undefined;
+}
+
+1;
+
diff --git a/contrib/perl5/lib/Term/Complete.pm b/contrib/perl5/lib/Term/Complete.pm
new file mode 100644
index 000000000000..275aadeb6514
--- /dev/null
+++ b/contrib/perl5/lib/Term/Complete.pm
@@ -0,0 +1,150 @@
+package Term::Complete;
+require 5.000;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(Complete);
+
+# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91
+
+=head1 NAME
+
+Term::Complete - Perl word completion module
+
+=head1 SYNOPSIS
+
+ $input = complete('prompt_string', \@completion_list);
+ $input = complete('prompt_string', @completion_list);
+
+=head1 DESCRIPTION
+
+This routine provides word completion on the list of words in
+the array (or array ref).
+
+The tty driver is put into raw mode using the system command
+C<stty raw -echo> and restored using C<stty -raw echo>.
+
+The following command characters are defined:
+
+=over 4
+
+=item E<lt>tabE<gt>
+
+Attempts word completion.
+Cannot be changed.
+
+=item ^D
+
+Prints completion list.
+Defined by I<$Term::Complete::complete>.
+
+=item ^U
+
+Erases the current input.
+Defined by I<$Term::Complete::kill>.
+
+=item E<lt>delE<gt>, E<lt>bsE<gt>
+
+Erases one character.
+Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
+
+=back
+
+=head1 DIAGNOSTICS
+
+Bell sounds when word completion fails.
+
+=head1 BUGS
+
+The completion charater E<lt>tabE<gt> cannot be changed.
+
+=head1 AUTHOR
+
+Wayne Thompson
+
+=cut
+
+CONFIG: {
+ $complete = "\004";
+ $kill = "\025";
+ $erase1 = "\177";
+ $erase2 = "\010";
+}
+
+sub Complete {
+ my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
+
+ $prompt = shift;
+ if (ref $_[0] || $_[0] =~ /^\*/) {
+ @cmp_lst = sort @{$_[0]};
+ }
+ else {
+ @cmp_lst = sort(@_);
+ }
+
+ system('stty raw -echo');
+ LOOP: {
+ print($prompt, $return);
+ while (($_ = getc(STDIN)) ne "\r") {
+ CASE: {
+ # (TAB) attempt completion
+ $_ eq "\t" && do {
+ @match = grep(/^$return/, @cmp_lst);
+ $l = length($test = shift(@match));
+ unless ($#match < 0) {
+ foreach $cmp (@match) {
+ until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
+ $l--;
+ }
+ }
+ print("\a");
+ }
+ print($test = substr($test, $r, $l - $r));
+ $r = length($return .= $test);
+ last CASE;
+ };
+
+ # (^D) completion list
+ $_ eq $complete && do {
+ print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
+ redo LOOP;
+ };
+
+ # (^U) kill
+ $_ eq $kill && do {
+ if ($r) {
+ undef $r;
+ undef $return;
+ print("\r\n");
+ redo LOOP;
+ }
+ last CASE;
+ };
+
+ # (DEL) || (BS) erase
+ ($_ eq $erase1 || $_ eq $erase2) && do {
+ if($r) {
+ print("\b \b");
+ chop($return);
+ $r--;
+ }
+ last CASE;
+ };
+
+ # printable char
+ ord >= 32 && do {
+ $return .= $_;
+ $r++;
+ print;
+ last CASE;
+ };
+ }
+ }
+ }
+ system('stty -raw echo');
+ print("\n");
+ $return;
+}
+
+1;
+
diff --git a/contrib/perl5/lib/Term/ReadLine.pm b/contrib/perl5/lib/Term/ReadLine.pm
new file mode 100644
index 000000000000..470226da910a
--- /dev/null
+++ b/contrib/perl5/lib/Term/ReadLine.pm
@@ -0,0 +1,365 @@
+=head1 NAME
+
+Term::ReadLine - Perl interface to various C<readline> packages. If
+no real package is found, substitutes stubs instead of basic functions.
+
+=head1 SYNOPSIS
+
+ use Term::ReadLine;
+ $term = new Term::ReadLine 'Simple Perl calc';
+ $prompt = "Enter your arithmetic expression: ";
+ $OUT = $term->OUT || STDOUT;
+ while ( defined ($_ = $term->readline($prompt)) ) {
+ $res = eval($_), "\n";
+ warn $@ if $@;
+ print $OUT $res, "\n" unless $@;
+ $term->addhistory($_) if /\S/;
+ }
+
+=head1 DESCRIPTION
+
+This package is just a front end to some other packages. At the moment
+this description is written, the only such package is Term-ReadLine,
+available on CPAN near you. The real target of this stub package is to
+set up a common interface to whatever Readline emerges with time.
+
+=head1 Minimal set of supported functions
+
+All the supported functions should be called as methods, i.e., either as
+
+ $term = new Term::ReadLine 'name';
+
+or as
+
+ $term->addhistory('row');
+
+where $term is a return value of Term::ReadLine-E<gt>Init.
+
+=over 12
+
+=item C<ReadLine>
+
+returns the actual package that executes the commands. Among possible
+values are C<Term::ReadLine::Gnu>, C<Term::ReadLine::Perl>,
+C<Term::ReadLine::Stub Exporter>.
+
+=item C<new>
+
+returns the handle for subsequent calls to following
+functions. Argument is the name of the application. Optionally can be
+followed by two arguments for C<IN> and C<OUT> filehandles. These
+arguments should be globs.
+
+=item C<readline>
+
+gets an input line, I<possibly> with actual C<readline>
+support. Trailing newline is removed. Returns C<undef> on C<EOF>.
+
+=item C<addhistory>
+
+adds the line to the history of input, from where it can be used if
+the actual C<readline> is present.
+
+=item C<IN>, $C<OUT>
+
+return the filehandles for input and output or C<undef> if C<readline>
+input and output cannot be used for Perl.
+
+=item C<MinLine>
+
+If argument is specified, it is an advice on minimal size of line to
+be included into history. C<undef> means do not include anything into
+history. Returns the old value.
+
+=item C<findConsole>
+
+returns an array with two strings that give most appropriate names for
+files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">.
+
+=item Attribs
+
+returns a reference to a hash which describes internal configuration
+of the package. Names of keys in this hash conform to standard
+conventions with the leading C<rl_> stripped.
+
+=item C<Features>
+
+Returns a reference to a hash with keys being features present in
+current implementation. Several optional features are used in the
+minimal interface: C<appname> should be present if the first argument
+to C<new> is recognized, and C<minline> should be present if
+C<MinLine> method is not dummy. C<autohistory> should be present if
+lines are put into history automatically (maybe subject to
+C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy.
+
+If C<Features> method reports a feature C<attribs> as present, the
+method C<Attribs> is not dummy.
+
+=back
+
+=head1 Additional supported functions
+
+Actually C<Term::ReadLine> can use some other package, that will
+support reacher set of commands.
+
+All these commands are callable via method interface and have names
+which conform to standard conventions with the leading C<rl_> stripped.
+
+The stub package included with the perl distribution allows some
+additional methods:
+
+=over 12
+
+=item C<tkRunning>
+
+makes Tk event loop run when waiting for user input (i.e., during
+C<readline> method).
+
+=item C<ornaments>
+
+makes the command line stand out by using termcap data. The argument
+to C<ornaments> should be 0, 1, or a string of a form
+C<"aa,bb,cc,dd">. Four components of this string should be names of
+I<terminal capacities>, first two will be issued to make the prompt
+standout, last two to make the input line standout.
+
+=item C<newTTY>
+
+takes two arguments which are input filehandle and output filehandle.
+Switches to use these filehandles.
+
+=back
+
+One can check whether the currently loaded ReadLine package supports
+these methods by checking for corresponding C<Features>.
+
+=head1 EXPORTS
+
+None
+
+=head1 ENVIRONMENT
+
+The envrironment variable C<PERL_RL> governs which ReadLine clone is
+loaded. If the value is false, a dummy interface is used. If the value
+is true, it should be tail of the name of the package to use, such as
+C<Perl> or C<Gnu>.
+
+As a special case, if the value of this variable is space-separated,
+the tail might be used to disable the ornaments by setting the tail to
+be C<o=0> or C<ornaments=0>. The head should be as described above, say
+
+If the variable is not set, or if the head of space-separated list is
+empty, the best available package is loaded.
+
+ export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments
+ export "PERL_RL= o=0" # Use best available ReadLine without ornaments
+
+(Note that processing of C<PERL_RL> for ornaments is in the discretion of the
+particular used C<Term::ReadLine::*> package).
+
+=cut
+
+package Term::ReadLine::Stub;
+@ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
+
+$DB::emacs = $DB::emacs; # To peacify -w
+*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
+
+sub ReadLine {'Term::ReadLine::Stub'}
+sub readline {
+ my $self = shift;
+ my ($in,$out,$str) = @$self;
+ print $out $rl_term_set[0], shift, $rl_term_set[1], $rl_term_set[2];
+ $self->register_Tk
+ if not $Term::ReadLine::registered and $Term::ReadLine::toloop
+ and defined &Tk::DoOneEvent;
+ #$str = scalar <$in>;
+ $str = $self->get_line;
+ print $out $rl_term_set[3];
+ # bug in 5.000: chomping empty string creats length -1:
+ chomp $str if defined $str;
+ $str;
+}
+sub addhistory {}
+
+sub findConsole {
+ my $console;
+
+ if (-e "/dev/tty") {
+ $console = "/dev/tty";
+ } elsif (-e "con" or $^O eq 'MSWin32') {
+ $console = "con";
+ } else {
+ $console = "sys\$command";
+ }
+
+ if (($^O eq 'amigaos') || ($^O eq 'beos')) {
+ $console = undef;
+ }
+ elsif ($^O eq 'os2') {
+ if ($DB::emacs) {
+ $console = undef;
+ } else {
+ $console = "/dev/con";
+ }
+ }
+
+ $consoleOUT = $console;
+ $console = "&STDIN" unless defined $console;
+ if (!defined $consoleOUT) {
+ $consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT";
+ }
+ ($console,$consoleOUT);
+}
+
+sub new {
+ die "method new called with wrong number of arguments"
+ unless @_==2 or @_==4;
+ #local (*FIN, *FOUT);
+ my ($FIN, $FOUT, $ret);
+ if (@_==2) {
+ ($console, $consoleOUT) = findConsole;
+
+ open(FIN, "<$console");
+ open(FOUT,">$consoleOUT");
+ #OUT->autoflush(1); # Conflicts with debugger?
+ $sel = select(FOUT);
+ $| = 1; # for DB::OUT
+ select($sel);
+ $ret = bless [\*FIN, \*FOUT];
+ } else { # Filehandles supplied
+ $FIN = $_[2]; $FOUT = $_[3];
+ #OUT->autoflush(1); # Conflicts with debugger?
+ $sel = select($FOUT);
+ $| = 1; # for DB::OUT
+ select($sel);
+ $ret = bless [$FIN, $FOUT];
+ }
+ if ($ret->Features->{ornaments}
+ and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) {
+ local $Term::ReadLine::termcap_nowarn = 1;
+ $ret->ornaments(1);
+ }
+ return $ret;
+}
+
+sub newTTY {
+ my ($self, $in, $out) = @_;
+ $self->[0] = $in;
+ $self->[1] = $out;
+ my $sel = select($out);
+ $| = 1; # for DB::OUT
+ select($sel);
+}
+
+sub IN { shift->[0] }
+sub OUT { shift->[1] }
+sub MinLine { undef }
+sub Attribs { {} }
+
+my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1);
+sub Features { \%features }
+
+package Term::ReadLine; # So late to allow the above code be defined?
+
+my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
+if ($which) {
+ if ($which =~ /\bgnu\b/i){
+ eval "use Term::ReadLine::Gnu;";
+ } elsif ($which =~ /\bperl\b/i) {
+ eval "use Term::ReadLine::Perl;";
+ } else {
+ eval "use Term::ReadLine::$which;";
+ }
+} elsif (defined $which and $which ne '') { # Defined but false
+ # Do nothing fancy
+} else {
+ eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
+}
+
+#require FileHandle;
+
+# To make possible switch off RL in debugger: (Not needed, work done
+# in debugger).
+
+if (defined &Term::ReadLine::Gnu::readline) {
+ @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
+} elsif (defined &Term::ReadLine::Perl::readline) {
+ @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub);
+} else {
+ @ISA = qw(Term::ReadLine::Stub);
+}
+
+package Term::ReadLine::TermCap;
+
+# Prompt-start, prompt-end, command-line-start, command-line-end
+# -- zero-width beautifies to emit around prompt and the command line.
+@rl_term_set = ("","","","");
+# string encoded:
+$rl_term_set = ',,,';
+
+sub LoadTermCap {
+ return if defined $terminal;
+
+ require Term::Cap;
+ $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
+}
+
+sub ornaments {
+ shift;
+ return $rl_term_set unless @_;
+ $rl_term_set = shift;
+ $rl_term_set ||= ',,,';
+ $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1';
+ my @ts = split /,/, $rl_term_set, 4;
+ eval { LoadTermCap };
+ unless (defined $terminal) {
+ warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn;
+ $rl_term_set = ',,,';
+ return;
+ }
+ @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts;
+ return $rl_term_set;
+}
+
+
+package Term::ReadLine::Tk;
+
+$count_handle = $count_DoOne = $count_loop = 0;
+
+sub handle {$giveup = 1; $count_handle++}
+
+sub Tk_loop {
+ # Tk->tkwait('variable',\$giveup); # needs Widget
+ $count_DoOne++, Tk::DoOneEvent(0) until $giveup;
+ $count_loop++;
+ $giveup = 0;
+}
+
+sub register_Tk {
+ my $self = shift;
+ $Term::ReadLine::registered++
+ or Tk->fileevent($self->IN,'readable',\&handle);
+}
+
+sub tkRunning {
+ $Term::ReadLine::toloop = $_[1] if @_ > 1;
+ $Term::ReadLine::toloop;
+}
+
+sub get_c {
+ my $self = shift;
+ $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
+ return getc $self->IN;
+}
+
+sub get_line {
+ my $self = shift;
+ $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent;
+ my $in = $self->IN;
+ local ($/) = "\n";
+ return scalar <$in>;
+}
+
+1;
+
diff --git a/contrib/perl5/lib/Test.pm b/contrib/perl5/lib/Test.pm
new file mode 100644
index 000000000000..6f57415efdc1
--- /dev/null
+++ b/contrib/perl5/lib/Test.pm
@@ -0,0 +1,235 @@
+use strict;
+package Test;
+use Test::Harness 1.1601 ();
+use Carp;
+use vars (qw($VERSION @ISA @EXPORT $ntest $TestLevel), #public-ish
+ qw($ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish
+$VERSION = '1.04';
+require Exporter;
+@ISA=('Exporter');
+@EXPORT= qw(&plan &ok &skip $ntest);
+
+$TestLevel = 0; # how many extra stack frames to skip
+$|=1;
+#$^W=1; ?
+$ntest=1;
+
+# Use of this variable is strongly discouraged. It is set mainly to
+# help test coverage analyzers know which test is running.
+$ENV{REGRESSION_TEST} = $0;
+
+sub plan {
+ croak "Test::plan(%args): odd number of arguments" if @_ & 1;
+ croak "Test::plan(): should not be called more than once" if $planned;
+ my $max=0;
+ for (my $x=0; $x < @_; $x+=2) {
+ my ($k,$v) = @_[$x,$x+1];
+ if ($k =~ /^test(s)?$/) { $max = $v; }
+ elsif ($k eq 'todo' or
+ $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
+ elsif ($k eq 'onfail') {
+ ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
+ $ONFAIL = $v;
+ }
+ else { carp "Test::plan(): skipping unrecognized directive '$k'" }
+ }
+ my @todo = sort { $a <=> $b } keys %todo;
+ if (@todo) {
+ print "1..$max todo ".join(' ', @todo).";\n";
+ } else {
+ print "1..$max\n";
+ }
+ ++$planned;
+}
+
+sub to_value {
+ my ($v) = @_;
+ (ref $v or '') eq 'CODE' ? $v->() : $v;
+}
+
+# STDERR is NOT used for diagnostic output which should have been
+# fixed before release. Is this appropriate?
+
+sub ok ($;$$) {
+ croak "ok: plan before you test!" if !$planned;
+ my ($pkg,$file,$line) = caller($TestLevel);
+ my $repetition = ++$history{"$file:$line"};
+ my $context = ("$file at line $line".
+ ($repetition > 1 ? " fail \#$repetition" : ''));
+ my $ok=0;
+ my $result = to_value(shift);
+ my ($expected,$diag);
+ if (@_ == 0) {
+ $ok = $result;
+ } else {
+ $expected = to_value(shift);
+ # until regex can be manipulated like objects...
+ my ($regex,$ignore);
+ if (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
+ ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
+ $ok = $result =~ /$regex/;
+ } else {
+ $ok = $result eq $expected;
+ }
+ }
+ if ($todo{$ntest}) {
+ if ($ok) {
+ print "ok $ntest # Wow! ($context)\n";
+ } else {
+ $diag = to_value(shift) if @_;
+ if (!$diag) {
+ print "not ok $ntest # (failure expected in $context)\n";
+ } else {
+ print "not ok $ntest # (failure expected: $diag)\n";
+ }
+ }
+ } else {
+ print "not " if !$ok;
+ print "ok $ntest\n";
+
+ if (!$ok) {
+ my $detail = { 'repetition' => $repetition, 'package' => $pkg,
+ 'result' => $result };
+ $$detail{expected} = $expected if defined $expected;
+ $diag = $$detail{diagnostic} = to_value(shift) if @_;
+ if (!defined $expected) {
+ if (!$diag) {
+ print STDERR "# Failed test $ntest in $context\n";
+ } else {
+ print STDERR "# Failed test $ntest in $context: $diag\n";
+ }
+ } else {
+ my $prefix = "Test $ntest";
+ print STDERR "# $prefix got: '$result' ($context)\n";
+ $prefix = ' ' x (length($prefix) - 5);
+ if (!$diag) {
+ print STDERR "# $prefix Expected: '$expected'\n";
+ } else {
+ print STDERR "# $prefix Expected: '$expected' ($diag)\n";
+ }
+ }
+ push @FAILDETAIL, $detail;
+ }
+ }
+ ++ $ntest;
+ $ok;
+}
+
+sub skip ($$;$$) {
+ if (to_value(shift)) {
+ print "ok $ntest # skip\n";
+ ++ $ntest;
+ 1;
+ } else {
+ local($TestLevel) = $TestLevel+1; #ignore this stack frame
+ &ok;
+ }
+}
+
+END {
+ $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+ Test - provides a simple framework for writing test scripts
+
+=head1 SYNOPSIS
+
+ use strict;
+ use Test;
+ BEGIN { plan tests => 13, todo => [3,4] }
+
+ ok(0); # failure
+ ok(1); # success
+
+ ok(0); # ok, expected failure (see todo list, above)
+ ok(1); # surprise success!
+
+ ok(0,1); # failure: '0' ne '1'
+ ok('broke','fixed'); # failure: 'broke' ne 'fixed'
+ ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
+
+ ok(sub { 1+1 }, 2); # success: '2' eq '2'
+ ok(sub { 1+1 }, 3); # failure: '2' ne '3'
+ ok(0, int(rand(2)); # (just kidding! :-)
+
+ my @list = (0,0);
+ ok @list, 3, "\@list=".join(',',@list); #extra diagnostics
+ ok 'segmentation fault', '/(?i)success/'; #regex match
+
+ skip($feature_is_missing, ...); #do platform specific test
+
+=head1 DESCRIPTION
+
+Test::Harness expects to see particular output when it executes tests.
+This module aims to make writing proper test scripts just a little bit
+easier (and less error prone :-).
+
+=head1 TEST TYPES
+
+=over 4
+
+=item * NORMAL TESTS
+
+These tests are expected to succeed. If they don't, something's
+screwed up!
+
+=item * SKIPPED TESTS
+
+Skip tests need a platform specific feature that might or might not be
+available. The first argument should evaluate to true if the required
+feature is NOT available. After the first argument, skip tests work
+exactly the same way as do normal tests.
+
+=item * TODO TESTS
+
+TODO tests are designed for maintaining an executable TODO list.
+These tests are expected NOT to succeed (otherwise the feature they
+test would be on the new feature list, not the TODO list).
+
+Packages should NOT be released with successful TODO tests. As soon
+as a TODO test starts working, it should be promoted to a normal test
+and the newly minted feature should be documented in the release
+notes.
+
+=back
+
+=head1 ONFAIL
+
+ BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
+
+The test failures can trigger extra diagnostics at the end of the test
+run. C<onfail> is passed an array ref of hash refs that describe each
+test failure. Each hash will contain at least the following fields:
+package, repetition, and result. (The file, line, and test number are
+not included because their correspondance to a particular test is
+fairly weak.) If the test had an expected value or a diagnostic
+string, these will also be included.
+
+This optional feature might be used simply to print out the version of
+your package and/or how to report problems. It might also be used to
+generate extremely sophisticated diagnostics for a particular test
+failure. It's not a panacea, however. Core dumps or other
+unrecoverable errors will prevent the C<onfail> hook from running.
+(It is run inside an END block.) Besides, C<onfail> is probably
+over-kill in the majority of cases. (Your test code should be simpler
+than the code it is testing, yes?)
+
+=head1 SEE ALSO
+
+L<Test::Harness> and various test coverage analysis tools.
+
+=head1 AUTHOR
+
+Copyright (C) 1998 Joshua Nathaniel Pritikin. All rights reserved.
+
+This package is free software and is provided "as is" without express
+or implied warranty. It may be used, redistributed and/or modified
+under the terms of the Perl Artistic License (see
+http://www.perl.com/perl/misc/Artistic.html)
+
+=cut
diff --git a/contrib/perl5/lib/Test/Harness.pm b/contrib/perl5/lib/Test/Harness.pm
new file mode 100644
index 000000000000..9c61d3a9ddde
--- /dev/null
+++ b/contrib/perl5/lib/Test/Harness.pm
@@ -0,0 +1,473 @@
+package Test::Harness;
+
+BEGIN {require 5.002;}
+use Exporter;
+use Benchmark;
+use Config;
+use FileHandle;
+use strict;
+
+use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
+ @ISA @EXPORT @EXPORT_OK);
+$have_devel_corestack = 0;
+
+$VERSION = "1.1602";
+
+# Some experimental versions of OS/2 build have broken $?
+my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
+
+my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR};
+
+my $tests_skipped = 0;
+my $subtests_skipped = 0;
+
+@ISA=('Exporter');
+@EXPORT= qw(&runtests);
+@EXPORT_OK= qw($verbose $switches);
+
+format STDOUT_TOP =
+Failed Test Status Wstat Total Fail Failed List of failed
+-------------------------------------------------------------------------------
+.
+
+format STDOUT =
+@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+{ $curtest->{name},
+ $curtest->{estat},
+ $curtest->{wstat},
+ $curtest->{max},
+ $curtest->{failed},
+ $curtest->{percent},
+ $curtest->{canon}
+}
+~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $curtest->{canon}
+.
+
+
+$verbose = 0;
+$switches = "-w";
+
+sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f }
+
+sub runtests {
+ my(@tests) = @_;
+ local($|) = 1;
+ my($test,$te,$ok,$next,$max,$pct,$totok,$totbonus,@failed,%failedtests);
+ my $totmax = 0;
+ my $files = 0;
+ my $bad = 0;
+ my $good = 0;
+ my $total = @tests;
+
+ # pass -I flags to children
+ my $old5lib = $ENV{PERL5LIB};
+ local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC);
+
+ if ($^O eq 'VMS') { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g }
+
+ my @dir_files = globdir $files_in_dir if defined $files_in_dir;
+ my $t_start = new Benchmark;
+ while ($test = shift(@tests)) {
+ $te = $test;
+ chop($te);
+ if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./; }
+ print "$te" . '.' x (20 - length($te));
+ my $fh = new FileHandle;
+ $fh->open($test) or print "can't open $test. $!\n";
+ my $first = <$fh>;
+ my $s = $switches;
+ $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/;
+ $fh->close or print "can't close $test. $!\n";
+ my $cmd = ($ENV{'COMPILE_TEST'})?
+"./perl -I../lib ../utils/perlcc $test -run -verbose dcf -log ./compilelog |"
+ : "$^X $s $test|";
+ $cmd = "MCR $cmd" if $^O eq 'VMS';
+ $fh->open($cmd) or print "can't run $test. $!\n";
+ $ok = $next = $max = 0;
+ @failed = ();
+ my %todo = ();
+ my $bonus = 0;
+ my $skipped = 0;
+ while (<$fh>) {
+ if( $verbose ){
+ print $_;
+ }
+ if (/^1\.\.([0-9]+) todo([\d\s]+)\;/) {
+ $max = $1;
+ for (split(/\s+/, $2)) { $todo{$_} = 1; }
+ $totmax += $max;
+ $files++;
+ $next = 1;
+ } elsif (/^1\.\.([0-9]+)/) {
+ $max = $1;
+ $totmax += $max;
+ $files++;
+ $next = 1;
+ } elsif ($max && /^(not\s+)?ok\b/) {
+ my $this = $next;
+ if (/^not ok\s*(\d*)/){
+ $this = $1 if $1 > 0;
+ if (!$todo{$this}) {
+ push @failed, $this;
+ } else {
+ $ok++;
+ $totok++;
+ }
+ } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip)?/) {
+ $this = $1 if $1 > 0;
+ $ok++;
+ $totok++;
+ $skipped++ if defined $2;
+ $bonus++, $totbonus++ if $todo{$this};
+ }
+ if ($this > $next) {
+ # warn "Test output counter mismatch [test $this]\n";
+ # no need to warn probably
+ push @failed, $next..$this-1;
+ } elsif ($this < $next) {
+ #we have seen more "ok" lines than the number suggests
+ warn "Confused test output: test $this answered after test ", $next-1, "\n";
+ $next = $this;
+ }
+ $next = $this + 1;
+ }
+ }
+ $fh->close; # must close to reap child resource values
+ my $wstatus = $ignore_exitcode ? 0 : $?; # Can trust $? ?
+ my $estatus;
+ $estatus = ($^O eq 'VMS'
+ ? eval 'use vmsish "status"; $estatus = $?'
+ : $wstatus >> 8);
+ if ($wstatus) {
+ my ($failed, $canon, $percent) = ('??', '??');
+ printf "dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n",
+ $wstatus,$wstatus;
+ print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
+ if (corestatus($wstatus)) { # until we have a wait module
+ if ($have_devel_corestack) {
+ Devel::CoreStack::stack($^X);
+ } else {
+ print "\ttest program seems to have generated a core\n";
+ }
+ }
+ $bad++;
+ if ($max) {
+ if ($next == $max + 1 and not @failed) {
+ print "\tafter all the subtests completed successfully\n";
+ $percent = 0;
+ $failed = 0; # But we do not set $canon!
+ } else {
+ push @failed, $next..$max;
+ $failed = @failed;
+ (my $txt, $canon) = canonfailed($max,@failed);
+ $percent = 100*(scalar @failed)/$max;
+ print "DIED. ",$txt;
+ }
+ }
+ $failedtests{$test} = { canon => $canon, max => $max || '??',
+ failed => $failed,
+ name => $test, percent => $percent,
+ estat => $estatus, wstat => $wstatus,
+ };
+ } elsif ($ok == $max && $next == $max+1) {
+ if ($max and $skipped + $bonus) {
+ my @msg;
+ push(@msg, "$skipped subtest".($skipped>1?'s':'')." skipped")
+ if $skipped;
+ push(@msg, "$bonus subtest".($bonus>1?'s':'').
+ " unexpectedly succeeded")
+ if $bonus;
+ print "ok, ".join(', ', @msg)."\n";
+ } elsif ($max) {
+ print "ok\n";
+ } else {
+ print "skipping test on this platform\n";
+ $tests_skipped++;
+ }
+ $good++;
+ } elsif ($max) {
+ if ($next <= $max) {
+ push @failed, $next..$max;
+ }
+ if (@failed) {
+ my ($txt, $canon) = canonfailed($max,@failed);
+ print $txt;
+ $failedtests{$test} = { canon => $canon, max => $max,
+ failed => scalar @failed,
+ name => $test, percent => 100*(scalar @failed)/$max,
+ estat => '', wstat => '',
+ };
+ } else {
+ print "Don't know which tests failed: got $ok ok, expected $max\n";
+ $failedtests{$test} = { canon => '??', max => $max,
+ failed => '??',
+ name => $test, percent => undef,
+ estat => '', wstat => '',
+ };
+ }
+ $bad++;
+ } elsif ($next == 0) {
+ print "FAILED before any test output arrived\n";
+ $bad++;
+ $failedtests{$test} = { canon => '??', max => '??',
+ failed => '??',
+ name => $test, percent => undef,
+ estat => '', wstat => '',
+ };
+ }
+ $subtests_skipped += $skipped;
+ if (defined $files_in_dir) {
+ my @new_dir_files = globdir $files_in_dir;
+ if (@new_dir_files != @dir_files) {
+ my %f;
+ @f{@new_dir_files} = (1) x @new_dir_files;
+ delete @f{@dir_files};
+ my @f = sort keys %f;
+ print "LEAKED FILES: @f\n";
+ @dir_files = @new_dir_files;
+ }
+ }
+ }
+ my $t_total = timediff(new Benchmark, $t_start);
+
+ if ($^O eq 'VMS') {
+ if (defined $old5lib) {
+ $ENV{PERL5LIB} = $old5lib;
+ } else {
+ delete $ENV{PERL5LIB};
+ }
+ }
+ my $bonusmsg = '';
+ $bonusmsg = (" ($totbonus subtest".($totbonus>1?'s':'').
+ " UNEXPECTEDLY SUCCEEDED)")
+ if $totbonus;
+ if ($tests_skipped) {
+ $bonusmsg .= ", $tests_skipped test" . ($tests_skipped != 1 ? 's' : '') .
+ ' skipped';
+ }
+ if ($subtests_skipped) {
+ $bonusmsg .= ($tests_skipped ? ', plus ' : ', ').
+ "$subtests_skipped subtest"
+ . ($subtests_skipped != 1 ? 's' : '') .
+ " skipped";
+ }
+ if ($bad == 0 && $totmax) {
+ print "All tests successful$bonusmsg.\n";
+ } elsif ($total==0){
+ die "FAILED--no tests were run for some reason.\n";
+ } elsif ($totmax==0) {
+ my $blurb = $total==1 ? "script" : "scripts";
+ die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
+ } else {
+ $pct = sprintf("%.2f", $good / $total * 100);
+ my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
+ $totmax - $totok, $totmax, 100*$totok/$totmax;
+ my $script;
+ for $script (sort keys %failedtests) {
+ $curtest = $failedtests{$script};
+ write;
+ }
+ if ($bad) {
+ $bonusmsg =~ s/^,\s*//;
+ print "$bonusmsg.\n" if $bonusmsg;
+ die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
+ }
+ }
+ printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
+
+ return ($bad == 0 && $totmax) ;
+}
+
+my $tried_devel_corestack;
+sub corestatus {
+ my($st) = @_;
+ my($ret);
+
+ eval {require 'wait.ph'};
+ if ($@) {
+ SWITCH: {
+ $ret = ($st & 0200); # Tim says, this is for 90%
+ }
+ } else {
+ $ret = WCOREDUMP($st);
+ }
+
+ eval { require Devel::CoreStack; $have_devel_corestack++ }
+ unless $tried_devel_corestack++;
+
+ $ret;
+}
+
+sub canonfailed ($@) {
+ my($max,@failed) = @_;
+ my %seen;
+ @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
+ my $failed = @failed;
+ my @result = ();
+ my @canon = ();
+ my $min;
+ my $last = $min = shift @failed;
+ my $canon;
+ if (@failed) {
+ for (@failed, $failed[-1]) { # don't forget the last one
+ if ($_ > $last+1 || $_ == $last) {
+ if ($min == $last) {
+ push @canon, $last;
+ } else {
+ push @canon, "$min-$last";
+ }
+ $min = $_;
+ }
+ $last = $_;
+ }
+ local $" = ", ";
+ push @result, "FAILED tests @canon\n";
+ $canon = "@canon";
+ } else {
+ push @result, "FAILED test $last\n";
+ $canon = $last;
+ }
+
+ push @result, "\tFailed $failed/$max tests, ";
+ push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n";
+ my $txt = join "", @result;
+ ($txt, $canon);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Test::Harness - run perl standard test scripts with statistics
+
+=head1 SYNOPSIS
+
+use Test::Harness;
+
+runtests(@tests);
+
+=head1 DESCRIPTION
+
+(By using the L<Test> module, you can write test scripts without
+knowing the exact output this module expects. However, if you need to
+know the specifics, read on!)
+
+Perl test scripts print to standard output C<"ok N"> for each single
+test, where C<N> is an increasing sequence of integers. The first line
+output by a standard test script is C<"1..M"> with C<M> being the
+number of tests that should be run within the test
+script. Test::Harness::runtests(@tests) runs all the testscripts
+named as arguments and checks standard output for the expected
+C<"ok N"> strings.
+
+After all tests have been performed, runtests() prints some
+performance statistics that are computed by the Benchmark module.
+
+=head2 The test script output
+
+Any output from the testscript to standard error is ignored and
+bypassed, thus will be seen by the user. Lines written to standard
+output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
+runtests(). All other lines are discarded.
+
+It is tolerated if the test numbers after C<ok> are omitted. In this
+case Test::Harness maintains temporarily its own counter until the
+script supplies test numbers again. So the following test script
+
+ print <<END;
+ 1..6
+ not ok
+ ok
+ not ok
+ ok
+ ok
+ END
+
+will generate
+
+ FAILED tests 1, 3, 6
+ Failed 3/6 tests, 50.00% okay
+
+The global variable $Test::Harness::verbose is exportable and can be
+used to let runtests() display the standard output of the script
+without altering the behavior otherwise.
+
+The global variable $Test::Harness::switches is exportable and can be
+used to set perl command line options used for running the test
+script(s). The default value is C<-w>.
+
+If the standard output line contains substring C< # Skip> (with
+variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
+counted as a skipped test. If the whole testscript succeeds, the
+count of skipped tests is included in the generated output.
+
+=head1 EXPORT
+
+C<&runtests> is exported by Test::Harness per default.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item C<All tests successful.\nFiles=%d, Tests=%d, %s>
+
+If all tests are successful some statistics about the performance are
+printed.
+
+=item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
+
+For any single script that has failing subtests statistics like the
+above are printed.
+
+=item C<Test returned status %d (wstat %d)>
+
+Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are
+printed in a message similar to the above.
+
+=item C<Failed 1 test, %.2f%% okay. %s>
+
+=item C<Failed %d/%d tests, %.2f%% okay. %s>
+
+If not all tests were successful, the script dies with one of the
+above messages.
+
+=back
+
+=head1 ENVIRONMENT
+
+Setting C<HARNESS_IGNORE_EXITCODE> makes harness ignore the exit status
+of child processes.
+
+If C<HARNESS_FILELEAK_IN_DIR> is set to the name of a directory, harness
+will check after each test whether new files appeared in that directory,
+and report them as
+
+ LEAKED FILES: scr.tmp 0 my.db
+
+If relative, directory name is with respect to the current directory at
+the moment runtests() was called. Putting absolute path into
+C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results.
+
+=head1 SEE ALSO
+
+L<Test> for writing test scripts and also L<Benchmark> for the
+underlying timing routines.
+
+=head1 AUTHORS
+
+Either Tim Bunce or Andreas Koenig, we don't know. What we know for
+sure is, that it was inspired by Larry Wall's TEST script that came
+with perl distributions for ages. Numerous anonymous contributors
+exist. Current maintainer is Andreas Koenig.
+
+=head1 BUGS
+
+Test::Harness uses $^X to determine the perl binary to run the tests
+with. Test scripts running via the shebang (C<#!>) line may not be
+portable because $^X is not consistent for shebang scripts across
+platforms. This is no problem when Test::Harness is run with an
+absolute path to the perl binary or when $^X can be found in the path.
+
+=cut
diff --git a/contrib/perl5/lib/Text/Abbrev.pm b/contrib/perl5/lib/Text/Abbrev.pm
new file mode 100644
index 000000000000..ae6797c81ac8
--- /dev/null
+++ b/contrib/perl5/lib/Text/Abbrev.pm
@@ -0,0 +1,87 @@
+package Text::Abbrev;
+require 5.000;
+require Exporter;
+
+=head1 NAME
+
+abbrev - create an abbreviation table from a list
+
+=head1 SYNOPSIS
+
+ use Text::Abbrev;
+ abbrev $hashref, LIST
+
+
+=head1 DESCRIPTION
+
+Stores all unambiguous truncations of each element of LIST
+as keys key in the associative array referenced to by C<$hashref>.
+The values are the original list elements.
+
+=head1 EXAMPLE
+
+ $hashref = abbrev qw(list edit send abort gripe);
+
+ %hash = abbrev qw(list edit send abort gripe);
+
+ abbrev $hashref, qw(list edit send abort gripe);
+
+ abbrev(*hash, qw(list edit send abort gripe));
+
+=cut
+
+@ISA = qw(Exporter);
+@EXPORT = qw(abbrev);
+
+# Usage:
+# &abbrev(*foo,LIST);
+# ...
+# $long = $foo{$short};
+
+sub abbrev {
+ my (%domain);
+ my ($name, $ref, $glob);
+
+ if (ref($_[0])) { # hash reference preferably
+ $ref = shift;
+ } elsif ($_[0] =~ /^\*/) { # looks like a glob (deprecated)
+ $glob = shift;
+ }
+ my @cmp = @_;
+
+ foreach $name (@_) {
+ my @extra = split(//,$name);
+ my $abbrev = shift(@extra);
+ my $len = 1;
+ my $cmp;
+ WORD: foreach $cmp (@cmp) {
+ next if $cmp eq $name;
+ while (substr($cmp,0,$len) eq $abbrev) {
+ last WORD unless @extra;
+ $abbrev .= shift(@extra);
+ ++$len;
+ }
+ }
+ $domain{$abbrev} = $name;
+ while (@extra) {
+ $abbrev .= shift(@extra);
+ $domain{$abbrev} = $name;
+ }
+ }
+ if ($ref) {
+ %$ref = %domain;
+ return;
+ } elsif ($glob) { # old style
+ local (*hash) = $glob;
+ %hash = %domain;
+ return;
+ }
+ if (wantarray) {
+ %domain;
+ } else {
+ \%domain;
+ }
+}
+
+1;
+
diff --git a/contrib/perl5/lib/Text/ParseWords.pm b/contrib/perl5/lib/Text/ParseWords.pm
new file mode 100644
index 000000000000..2414f805b569
--- /dev/null
+++ b/contrib/perl5/lib/Text/ParseWords.pm
@@ -0,0 +1,256 @@
+package Text::ParseWords;
+
+use vars qw($VERSION @ISA @EXPORT $PERL_SINGLE_QUOTE);
+$VERSION = "3.1";
+
+require 5.000;
+
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(shellwords quotewords nested_quotewords parse_line);
+@EXPORT_OK = qw(old_shellwords);
+
+
+sub shellwords {
+ local(@lines) = @_;
+ $lines[$#lines] =~ s/\s+$//;
+ return(quotewords('\s+', 0, @lines));
+}
+
+
+
+sub quotewords {
+ my($delim, $keep, @lines) = @_;
+ my($line, @words, @allwords);
+
+
+ foreach $line (@lines) {
+ @words = parse_line($delim, $keep, $line);
+ return() unless (@words || !length($line));
+ push(@allwords, @words);
+ }
+ return(@allwords);
+}
+
+
+
+sub nested_quotewords {
+ my($delim, $keep, @lines) = @_;
+ my($i, @allwords);
+
+ for ($i = 0; $i < @lines; $i++) {
+ @{$allwords[$i]} = parse_line($delim, $keep, $lines[$i]);
+ return() unless (@{$allwords[$i]} || !length($lines[$i]));
+ }
+ return(@allwords);
+}
+
+
+
+sub parse_line {
+ # We will be testing undef strings
+ local($^W) = 0;
+
+ my($delimiter, $keep, $line) = @_;
+ my($quote, $quoted, $unquoted, $delim, $word, @pieces);
+
+ while (length($line)) {
+
+ ($quote, $quoted, undef, $unquoted, $delim, undef) =
+ $line =~ m/^(["']) # a $quote
+ ((?:\\.|(?!\1)[^\\])*) # and $quoted text
+ \1 # followed by the same quote
+ ([\000-\377]*) # and the rest
+ | # --OR--
+ ^((?:\\.|[^\\"'])*?) # an $unquoted text
+ (\Z(?!\n)|$delimiter|(?!^)(?=["']))
+ # plus EOL, delimiter, or quote
+ ([\000-\377]*) # the rest
+ /x; # extended layout
+ return() unless( $quote || length($unquoted) || length($delim));
+
+ $line = $+;
+
+ if ($keep) {
+ $quoted = "$quote$quoted$quote";
+ }
+ else {
+ $unquoted =~ s/\\(.)/$1/g;
+ if (defined $quote) {
+ $quoted =~ s/\\(.)/$1/g if ($quote eq '"');
+ $quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'");
+ }
+ }
+ $word .= defined $quote ? $quoted : $unquoted;
+
+ if (length($delim)) {
+ push(@pieces, $word);
+ push(@pieces, $delim) if ($keep eq 'delimiters');
+ undef $word;
+ }
+ if (!length($line)) {
+ push(@pieces, $word);
+ }
+ }
+ return(@pieces);
+}
+
+
+
+sub old_shellwords {
+
+ # Usage:
+ # use ParseWords;
+ # @words = old_shellwords($line);
+ # or
+ # @words = old_shellwords(@lines);
+
+ local($_) = join('', @_);
+ my(@words,$snippet,$field);
+
+ s/^\s+//;
+ while ($_ ne '') {
+ $field = '';
+ for (;;) {
+ if (s/^"(([^"\\]|\\.)*)"//) {
+ ($snippet = $1) =~ s#\\(.)#$1#g;
+ }
+ elsif (/^"/) {
+ return();
+ }
+ elsif (s/^'(([^'\\]|\\.)*)'//) {
+ ($snippet = $1) =~ s#\\(.)#$1#g;
+ }
+ elsif (/^'/) {
+ return();
+ }
+ elsif (s/^\\(.)//) {
+ $snippet = $1;
+ }
+ elsif (s/^([^\s\\'"]+)//) {
+ $snippet = $1;
+ }
+ else {
+ s/^\s+//;
+ last;
+ }
+ $field .= $snippet;
+ }
+ push(@words, $field);
+ }
+ @words;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Text::ParseWords - parse text into an array of tokens or array of arrays
+
+=head1 SYNOPSIS
+
+ use Text::ParseWords;
+ @lists = &nested_quotewords($delim, $keep, @lines);
+ @words = &quotewords($delim, $keep, @lines);
+ @words = &shellwords(@lines);
+ @words = &parse_line($delim, $keep, $line);
+ @words = &old_shellwords(@lines); # DEPRECATED!
+
+=head1 DESCRIPTION
+
+The &nested_quotewords() and &quotewords() functions accept a delimiter
+(which can be a regular expression)
+and a list of lines and then breaks those lines up into a list of
+words ignoring delimiters that appear inside quotes. &quotewords()
+returns all of the tokens in a single long list, while &nested_quotewords()
+returns a list of token lists corresponding to the elements of @lines.
+&parse_line() does tokenizing on a single string. The &*quotewords()
+functions simply call &parse_lines(), so if you're only splitting
+one line you can call &parse_lines() directly and save a function
+call.
+
+The $keep argument is a boolean flag. If true, then the tokens are
+split on the specified delimiter, but all other characters (quotes,
+backslashes, etc.) are kept in the tokens. If $keep is false then the
+&*quotewords() functions remove all quotes and backslashes that are
+not themselves backslash-escaped or inside of single quotes (i.e.,
+&quotewords() tries to interpret these characters just like the Bourne
+shell). NB: these semantics are significantly different from the
+original version of this module shipped with Perl 5.000 through 5.004.
+As an additional feature, $keep may be the keyword "delimiters" which
+causes the functions to preserve the delimiters in each string as
+tokens in the token lists, in addition to preserving quote and
+backslash characters.
+
+&shellwords() is written as a special case of &quotewords(), and it
+does token parsing with whitespace as a delimiter-- similar to most
+Unix shells.
+
+=head1 EXAMPLES
+
+The sample program:
+
+ use Text::ParseWords;
+ @words = &quotewords('\s+', 0, q{this is "a test" of\ quotewords \"for you});
+ $i = 0;
+ foreach (@words) {
+ print "$i: <$_>\n";
+ $i++;
+ }
+
+produces:
+
+ 0: <this>
+ 1: <is>
+ 2: <a test>
+ 3: <of quotewords>
+ 4: <"for>
+ 5: <you>
+
+demonstrating:
+
+=over 4
+
+=item 0
+a simple word
+
+=item 1
+multiple spaces are skipped because of our $delim
+
+=item 2
+use of quotes to include a space in a word
+
+=item 3
+use of a backslash to include a space in a word
+
+=item 4
+use of a backslash to remove the special meaning of a double-quote
+
+=item 5
+another simple word (note the lack of effect of the
+backslashed double-quote)
+
+=back
+
+Replacing C<&quotewords('\s+', 0, q{this is...})>
+with C<&shellwords(q{this is...})>
+is a simpler way to accomplish the same thing.
+
+=head1 AUTHORS
+
+Maintainer is Hal Pomeranz <pomeranz@netcom.com>, 1994-1997 (Original
+author unknown). Much of the code for &parse_line() (including the
+primary regexp) from Joerk Behrends <jbehrends@multimediaproduzenten.de>.
+
+Examples section another documentation provided by John Heidemann
+<johnh@ISI.EDU>
+
+Bug reports, patches, and nagging provided by lots of folks-- thanks
+everybody! Special thanks to Michael Schwern <schwern@envirolink.org>
+for assuring me that a &nested_quotewords() would be useful, and to
+Jeff Friedl <jfriedl@yahoo-inc.com> for telling me not to worry about
+error-checking (sort of-- you had to be there).
+
+=cut
diff --git a/contrib/perl5/lib/Text/Soundex.pm b/contrib/perl5/lib/Text/Soundex.pm
new file mode 100644
index 000000000000..ddc758c94eb7
--- /dev/null
+++ b/contrib/perl5/lib/Text/Soundex.pm
@@ -0,0 +1,148 @@
+package Text::Soundex;
+require 5.000;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(&soundex $soundex_nocode);
+
+# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $
+#
+# Implementation of soundex algorithm as described by Knuth in volume
+# 3 of The Art of Computer Programming, with ideas stolen from Ian
+# Phillips <ian@pipex.net>.
+#
+# Mike Stok <Mike.Stok@meiko.concord.ma.us>, 2 March 1994.
+#
+# Knuth's test cases are:
+#
+# Euler, Ellery -> E460
+# Gauss, Ghosh -> G200
+# Hilbert, Heilbronn -> H416
+# Knuth, Kant -> K530
+# Lloyd, Ladd -> L300
+# Lukasiewicz, Lissajous -> L222
+#
+# $Log: soundex.pl,v $
+# Revision 1.2 1994/03/24 00:30:27 mike
+# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu>
+# in the way I handles leasing characters which were different but had
+# the same soundex code. This showed up comparing it with Oracle's
+# soundex output.
+#
+# Revision 1.1 1994/03/02 13:01:30 mike
+# Initial revision
+#
+#
+##############################################################################
+
+# $soundex_nocode is used to indicate a string doesn't have a soundex
+# code, I like undef other people may want to set it to 'Z000'.
+
+$soundex_nocode = undef;
+
+sub soundex
+{
+ local (@s, $f, $fc, $_) = @_;
+
+ push @s, '' unless @s; # handle no args as a single empty string
+
+ foreach (@s)
+ {
+ $_ = uc $_;
+ tr/A-Z//cd;
+
+ if ($_ eq '')
+ {
+ $_ = $soundex_nocode;
+ }
+ else
+ {
+ ($f) = /^(.)/;
+ tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/;
+ ($fc) = /^(.)/;
+ s/^$fc+//;
+ tr///cs;
+ tr/0//d;
+ $_ = $f . $_ . '000';
+ s/^(.{4}).*/$1/;
+ }
+ }
+
+ wantarray ? @s : shift @s;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Text::Soundex - Implementation of the Soundex Algorithm as Described by Knuth
+
+=head1 SYNOPSIS
+
+ use Text::Soundex;
+
+ $code = soundex $string; # get soundex code for a string
+ @codes = soundex @list; # get list of codes for list of strings
+
+ # set value to be returned for strings without soundex code
+
+ $soundex_nocode = 'Z000';
+
+=head1 DESCRIPTION
+
+This module implements the soundex algorithm as described by Donald Knuth
+in Volume 3 of B<The Art of Computer Programming>. The algorithm is
+intended to hash words (in particular surnames) into a small space using a
+simple model which approximates the sound of the word when spoken by an English
+speaker. Each word is reduced to a four character string, the first
+character being an upper case letter and the remaining three being digits.
+
+If there is no soundex code representation for a string then the value of
+C<$soundex_nocode> is returned. This is initially set to C<undef>, but
+many people seem to prefer an I<unlikely> value like C<Z000>
+(how unlikely this is depends on the data set being dealt with.) Any value
+can be assigned to C<$soundex_nocode>.
+
+In scalar context C<soundex> returns the soundex code of its first
+argument, and in array context a list is returned in which each element is the
+soundex code for the corresponding argument passed to C<soundex> e.g.
+
+ @codes = soundex qw(Mike Stok);
+
+leaves C<@codes> containing C<('M200', 'S320')>.
+
+=head1 EXAMPLES
+
+Knuth's examples of various names and the soundex codes they map to
+are listed below:
+
+ Euler, Ellery -> E460
+ Gauss, Ghosh -> G200
+ Hilbert, Heilbronn -> H416
+ Knuth, Kant -> K530
+ Lloyd, Ladd -> L300
+ Lukasiewicz, Lissajous -> L222
+
+so:
+
+ $code = soundex 'Knuth'; # $code contains 'K530'
+ @list = soundex qw(Lloyd Gauss); # @list contains 'L300', 'G200'
+
+=head1 LIMITATIONS
+
+As the soundex algorithm was originally used a B<long> time ago in the US
+it considers only the English alphabet and pronunciation.
+
+As it is mapping a large space (arbitrary length strings) onto a small
+space (single letter plus 3 digits) no inference can be made about the
+similarity of two strings which end up with the same soundex code. For
+example, both C<Hilbert> and C<Heilbronn> end up with a soundex code
+of C<H416>.
+
+=head1 AUTHOR
+
+This code was implemented by Mike Stok (C<stok@cybercom.net>) from the
+description given by Knuth. Ian Phillips (C<ian@pipex.net>) and Rich Pinder
+(C<rpinder@hsc.usc.edu>) supplied ideas and spotted mistakes.
diff --git a/contrib/perl5/lib/Text/Tabs.pm b/contrib/perl5/lib/Text/Tabs.pm
new file mode 100644
index 000000000000..acd7afb7d6fe
--- /dev/null
+++ b/contrib/perl5/lib/Text/Tabs.pm
@@ -0,0 +1,97 @@
+
+package Text::Tabs;
+
+require Exporter;
+
+@ISA = (Exporter);
+@EXPORT = qw(expand unexpand $tabstop);
+
+use vars qw($VERSION $tabstop $debug);
+$VERSION = 96.121201;
+
+use strict;
+
+BEGIN {
+ $tabstop = 8;
+ $debug = 0;
+}
+
+sub expand
+{
+ my @l = @_;
+ for $_ (@l) {
+ 1 while s/(^|\n)([^\t\n]*)(\t+)/
+ $1. $2 . (" " x
+ ($tabstop * length($3)
+ - (length($2) % $tabstop)))
+ /sex;
+ }
+ return @l if wantarray;
+ return $l[0];
+}
+
+sub unexpand
+{
+ my @l = @_;
+ my @e;
+ my $x;
+ my $line;
+ my @lines;
+ my $lastbit;
+ for $x (@l) {
+ @lines = split("\n", $x, -1);
+ for $line (@lines) {
+ $line = expand($line);
+ @e = split(/(.{$tabstop})/,$line,-1);
+ $lastbit = pop(@e);
+ $lastbit = '' unless defined $lastbit;
+ $lastbit = "\t"
+ if $lastbit eq " "x$tabstop;
+ for $_ (@e) {
+ if ($debug) {
+ my $x = $_;
+ $x =~ s/\t/^I\t/gs;
+ print "sub on '$x'\n";
+ }
+ s/ +$/\t/;
+ }
+ $line = join('',@e, $lastbit);
+ }
+ $x = join("\n", @lines);
+ }
+ return @l if wantarray;
+ return $l[0];
+}
+
+1;
+__END__
+
+
+=head1 NAME
+
+Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1)
+
+=head1 SYNOPSIS
+
+use Text::Tabs;
+
+$tabstop = 4;
+@lines_without_tabs = expand(@lines_with_tabs);
+@lines_with_tabs = unexpand(@lines_without_tabs);
+
+=head1 DESCRIPTION
+
+Text::Tabs does about what the unix utilities expand(1) and unexpand(1)
+do. Given a line with tabs in it, expand will replace the tabs with
+the appropriate number of spaces. Given a line with or without tabs in
+it, unexpand will add tabs when it can save bytes by doing so. Invisible
+compression with plain ascii!
+
+=head1 BUGS
+
+expand doesn't handle newlines very quickly -- do not feed it an
+entire document in one string. Instead feed it an array of lines.
+
+=head1 AUTHOR
+
+David Muir Sharnoff <muir@idiom.com>
diff --git a/contrib/perl5/lib/Text/Wrap.pm b/contrib/perl5/lib/Text/Wrap.pm
new file mode 100644
index 000000000000..0fe7fb93c215
--- /dev/null
+++ b/contrib/perl5/lib/Text/Wrap.pm
@@ -0,0 +1,125 @@
+package Text::Wrap;
+
+use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $columns $debug);
+use strict;
+use Exporter;
+
+$VERSION = "97.02";
+@ISA = qw(Exporter);
+@EXPORT = qw(wrap);
+@EXPORT_OK = qw($columns $tabstop fill);
+
+use Text::Tabs qw(expand unexpand $tabstop);
+
+
+BEGIN {
+ $columns = 76; # <= screen width
+ $debug = 0;
+}
+
+sub wrap
+{
+ my ($ip, $xp, @t) = @_;
+
+ my @rv;
+ my $t = expand(join(" ",@t));
+
+ my $lead = $ip;
+ my $ll = $columns - length(expand($lead)) - 1;
+ 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";
+ }
+ # recompute the leader
+ $lead = $xp;
+ $ll = $columns - length(expand($lead)) - 1;
+ $t =~ s/^\s+//;
+ }
+ print "TAIL $lead$t\n" if $debug;
+ push @rv, $lead.$t if $t ne "";
+ return join '', @rv;
+}
+
+
+sub fill
+{
+ my ($ip, $xp, @raw) = @_;
+ my @para;
+ my $pp;
+
+ for $pp (split(/\n\s+/, join("\n",@raw))) {
+ $pp =~ s/\s+/ /g;
+ my $x = wrap($ip, $xp, $pp);
+ push(@para, $x);
+ }
+
+ # if paragraph_indent is the same as line_indent,
+ # separate paragraphs with blank lines
+
+ return join ($ip eq $xp ? "\n\n" : "\n", @para);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Text::Wrap - line wrapping to form simple paragraphs
+
+=head1 SYNOPSIS
+
+ use Text::Wrap
+
+ print wrap($initial_tab, $subsequent_tab, @text);
+
+ use Text::Wrap qw(wrap $columns $tabstop fill);
+
+ $columns = 132;
+ $tabstop = 4;
+
+ print fill($initial_tab, $subsequent_tab, @text);
+ print fill("", "", `cat book`);
+
+=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.
+
+Text::Wrap::fill() is a simple multi-paragraph formatter. It formats
+each paragraph separately and then joins them together when it's done. It
+will destory any whitespace in the original text. It breaks text into
+paragraphs by looking for whitespace after a newline. In other respects
+it acts like wrap().
+
+=head1 EXAMPLE
+
+ 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.
+
+=cut
diff --git a/contrib/perl5/lib/Tie/Array.pm b/contrib/perl5/lib/Tie/Array.pm
new file mode 100644
index 000000000000..4041b00e8603
--- /dev/null
+++ b/contrib/perl5/lib/Tie/Array.pm
@@ -0,0 +1,262 @@
+package Tie::Array;
+use vars qw($VERSION);
+use strict;
+$VERSION = '1.00';
+
+# Pod documentation after __END__ below.
+
+sub DESTROY { }
+sub EXTEND { }
+sub UNSHIFT { shift->SPLICE(0,0,@_) }
+sub SHIFT { shift->SPLICE(0,1) }
+sub CLEAR { shift->STORESIZE(0) }
+
+sub PUSH
+{
+ my $obj = shift;
+ my $i = $obj->FETCHSIZE;
+ $obj->STORE($i++, shift) while (@_);
+}
+
+sub POP
+{
+ my $obj = shift;
+ my $newsize = $obj->FETCHSIZE - 1;
+ my $val;
+ if ($newsize >= 0)
+ {
+ $val = $obj->FETCH($newsize);
+ $obj->STORESIZE($newsize);
+ }
+ $val;
+}
+
+sub SPLICE
+{
+ my $obj = shift;
+ my $sz = $obj->FETCHSIZE;
+ my $off = (@_) ? shift : 0;
+ $off += $sz if ($off < 0);
+ my $len = (@_) ? shift : $sz - $off;
+ my @result;
+ for (my $i = 0; $i < $len; $i++)
+ {
+ push(@result,$obj->FETCH($off+$i));
+ }
+ if (@_ > $len)
+ {
+ # Move items up to make room
+ my $d = @_ - $len;
+ my $e = $off+$len;
+ $obj->EXTEND($sz+$d);
+ for (my $i=$sz-1; $i >= $e; $i--)
+ {
+ my $val = $obj->FETCH($i);
+ $obj->STORE($i+$d,$val);
+ }
+ }
+ elsif (@_ < $len)
+ {
+ # Move items down to close the gap
+ my $d = $len - @_;
+ my $e = $off+$len;
+ for (my $i=$off+$len; $i < $sz; $i++)
+ {
+ my $val = $obj->FETCH($i);
+ $obj->STORE($i-$d,$val);
+ }
+ $obj->STORESIZE($sz-$d);
+ }
+ for (my $i=0; $i < @_; $i++)
+ {
+ $obj->STORE($off+$i,$_[$i]);
+ }
+ return @result;
+}
+
+package Tie::StdArray;
+use vars qw(@ISA);
+@ISA = 'Tie::Array';
+
+sub TIEARRAY { bless [], $_[0] }
+sub FETCHSIZE { scalar @{$_[0]} }
+sub STORESIZE { $#{$_[0]} = $_[1]-1 }
+sub STORE { $_[0]->[$_[1]] = $_[2] }
+sub FETCH { $_[0]->[$_[1]] }
+sub CLEAR { @{$_[0]} = () }
+sub POP { pop(@{$_[0]}) }
+sub PUSH { my $o = shift; push(@$o,@_) }
+sub SHIFT { shift(@{$_[0]}) }
+sub UNSHIFT { my $o = shift; unshift(@$o,@_) }
+
+sub SPLICE
+{
+ my $ob = shift;
+ my $sz = $ob->FETCHSIZE;
+ my $off = @_ ? shift : 0;
+ $off += $sz if $off < 0;
+ my $len = @_ ? shift : $sz-$off;
+ return splice(@$ob,$off,$len,@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tie::Array - base class for tied arrays
+
+=head1 SYNOPSIS
+
+ package NewArray;
+ use Tie::Array;
+ @ISA = ('Tie::Array');
+
+ # mandatory methods
+ sub TIEARRAY { ... }
+ sub FETCH { ... }
+ sub FETCHSIZE { ... }
+
+ sub STORE { ... } # mandatory if elements writeable
+ sub STORESIZE { ... } # mandatory if elements can be added/deleted
+
+ # optional methods - for efficiency
+ sub CLEAR { ... }
+ sub PUSH { ... }
+ sub POP { ... }
+ sub SHIFT { ... }
+ sub UNSHIFT { ... }
+ sub SPLICE { ... }
+ sub EXTEND { ... }
+ sub DESTROY { ... }
+
+ package NewStdArray;
+ use Tie::Array;
+
+ @ISA = ('Tie::StdArray');
+
+ # all methods provided by default
+
+ package main;
+
+ $object = tie @somearray,Tie::NewArray;
+ $object = tie @somearray,Tie::StdArray;
+ $object = tie @somearray,Tie::NewStdArray;
+
+
+
+=head1 DESCRIPTION
+
+This module provides methods for array-tying classes. See
+L<perltie> for a list of the functions required in order to tie an array
+to a package. The basic B<Tie::Array> package provides stub C<DELETE>
+and C<EXTEND> methods, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
+C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
+C<FETCHSIZE>, C<STORESIZE>.
+
+The B<Tie::StdArray> package provides efficient methods required for tied arrays
+which are implemented as blessed references to an "inner" perl array.
+It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly
+like standard arrays, allowing for selective overloading of methods.
+
+For developers wishing to write their own tied arrays, the required methods
+are briefly defined below. See the L<perltie> section for more detailed
+descriptive, as well as example code:
+
+=over
+
+=item TIEARRAY classname, LIST
+
+The class method is invoked by the command C<tie @array, classname>. Associates
+an array instance with the specified class. C<LIST> would represent
+additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed
+to complete the association. The method should return an object of a class which
+provides the methods below.
+
+=item STORE this, index, value
+
+Store datum I<value> into I<index> for the tied array assoicated with
+object I<this>. If this makes the array larger then
+class's mapping of C<undef> should be returned for new positions.
+
+=item FETCH this, index
+
+Retrieve the datum in I<index> for the tied array assoicated with
+object I<this>.
+
+=item FETCHSIZE this
+
+Returns the total number of items in the tied array assoicated with
+object I<this>. (Equivalent to C<scalar(@array)>).
+
+=item STORESIZE this, count
+
+Sets the total number of items in the tied array assoicated with
+object I<this> to be I<count>. If this makes the array larger then
+class's mapping of C<undef> should be returned for new positions.
+If the array becomes smaller then entries beyond count should be
+deleted.
+
+=item EXTEND this, count
+
+Informative call that array is likely to grow to have I<count> entries.
+Can be used to optimize allocation. This method need do nothing.
+
+=item CLEAR this
+
+Clear (remove, delete, ...) all values from the tied array assoicated with
+object I<this>.
+
+=item DESTROY this
+
+Normal object destructor method.
+
+=item PUSH this, LIST
+
+Append elements of LIST to the array.
+
+=item POP this
+
+Remove last element of the array and return it.
+
+=item SHIFT this
+
+Remove the first element of the array (shifting other elements down)
+and return it.
+
+=item UNSHIFT this, LIST
+
+Insert LIST elements at the begining of the array, moving existing elements
+up to make room.
+
+=item SPLICE this, offset, length, LIST
+
+Perform the equivalent of C<splice> on the array.
+
+I<offset> is optional and defaults to zero, negative values count back
+from the end of the array.
+
+I<length> is optional and defaults to rest of the array.
+
+I<LIST> may be empty.
+
+Returns a list of the original I<length> elements at I<offset>.
+
+=back
+
+=head1 CAVEATS
+
+There is no support at present for tied @ISA. There is a potential conflict
+between magic entries needed to notice setting of @ISA, and those needed to
+implement 'tie'.
+
+Very little consideration has been given to the behaviour of tied arrays
+when C<$[> is not default value of zero.
+
+=head1 AUTHOR
+
+Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt>
+
+=cut
+
diff --git a/contrib/perl5/lib/Tie/Handle.pm b/contrib/perl5/lib/Tie/Handle.pm
new file mode 100644
index 000000000000..c7550530b87e
--- /dev/null
+++ b/contrib/perl5/lib/Tie/Handle.pm
@@ -0,0 +1,161 @@
+package Tie::Handle;
+
+=head1 NAME
+
+Tie::Handle - base class definitions for tied handles
+
+=head1 SYNOPSIS
+
+ package NewHandle;
+ require Tie::Handle;
+
+ @ISA = (Tie::Handle);
+
+ sub READ { ... } # Provide a needed method
+ sub TIEHANDLE { ... } # Overrides inherited method
+
+
+ package main;
+
+ tie *FH, 'NewHandle';
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for handle-tying classes. See
+L<perltie> for a list of the functions required in tying a handle to a package.
+The basic B<Tie::Handle> package provides a C<new> method, as well as methods
+C<TIESCALAR>, C<FETCH> and C<STORE>. The C<new> method is provided as a means
+of grandfathering, for classes that forget to provide their own C<TIESCALAR>
+method.
+
+For developers wishing to write their own tied-handle classes, the methods
+are summarized below. The L<perltie> section not only documents these, but
+has sample code as well:
+
+=over
+
+=item TIEHANDLE classname, LIST
+
+The method invoked by the command C<tie *glob, classname>. Associates a new
+glob instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item WRITE this, scalar, length, offset
+
+Write I<length> bytes of data from I<scalar> starting at I<offset>.
+
+=item PRINT this, LIST
+
+Print the values in I<LIST>
+
+=item PRINTF this, format, LIST
+
+Print the values in I<LIST> using I<format>
+
+=item READ this, scalar, length, offset
+
+Read I<length> bytes of data into I<scalar> starting at I<offset>.
+
+=item READLINE this
+
+Read a single line
+
+=item GETC this
+
+Get a single character
+
+=item DESTROY this
+
+Free the storage associated with the tied handle referenced by I<this>.
+This is rarely needed, as Perl manages its memory quite well. But the
+option exists, should a class wish to perform specific actions upon the
+destruction of an instance.
+
+=back
+
+=head1 MORE INFORMATION
+
+The L<perltie> section contains an example of tying handles.
+
+=cut
+
+use Carp;
+
+sub new {
+ my $pkg = shift;
+ $pkg->TIEHANDLE(@_);
+}
+
+# "Grandfather" the new, a la Tie::Hash
+
+sub TIEHANDLE {
+ my $pkg = shift;
+ if (defined &{"{$pkg}::new"}) {
+ carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"
+ if $^W;
+ $pkg->new(@_);
+ }
+ else {
+ croak "$pkg doesn't define a TIEHANDLE method";
+ }
+}
+
+sub PRINT {
+ my $self = shift;
+ if($self->can('WRITE') != \&WRITE) {
+ my $buf = join(defined $, ? $, : "",@_);
+ $buf .= $\ if defined $\;
+ $self->WRITE($buf,length($buf),0);
+ }
+ else {
+ croak ref($self)," doesn't define a PRINT method";
+ }
+}
+
+sub PRINTF {
+ my $self = shift;
+
+ if($self->can('WRITE') != \&WRITE) {
+ my $buf = sprintf(@_);
+ $self->WRITE($buf,length($buf),0);
+ }
+ else {
+ croak ref($self)," doesn't define a PRINTF method";
+ }
+}
+
+sub READLINE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a READLINE method";
+}
+
+sub GETC {
+ my $self = shift;
+
+ if($self->can('READ') != \&READ) {
+ my $buf;
+ $self->READ($buf,1);
+ return $buf;
+ }
+ else {
+ croak ref($self)," doesn't define a GETC method";
+ }
+}
+
+sub READ {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a READ method";
+}
+
+sub WRITE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a WRITE method";
+}
+
+sub CLOSE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a CLOSE method";
+}
+
+1;
diff --git a/contrib/perl5/lib/Tie/Hash.pm b/contrib/perl5/lib/Tie/Hash.pm
new file mode 100644
index 000000000000..7ed18962e9e7
--- /dev/null
+++ b/contrib/perl5/lib/Tie/Hash.pm
@@ -0,0 +1,158 @@
+package Tie::Hash;
+
+=head1 NAME
+
+Tie::Hash, Tie::StdHash - base class definitions for tied hashes
+
+=head1 SYNOPSIS
+
+ package NewHash;
+ require Tie::Hash;
+
+ @ISA = (Tie::Hash);
+
+ sub DELETE { ... } # Provides needed method
+ sub CLEAR { ... } # Overrides inherited method
+
+
+ package NewStdHash;
+ require Tie::Hash;
+
+ @ISA = (Tie::StdHash);
+
+ # All methods provided by default, define only those needing overrides
+ sub DELETE { ... }
+
+
+ package main;
+
+ tie %new_hash, 'NewHash';
+ tie %new_std_hash, 'NewStdHash';
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for hash-tying classes. See
+L<perltie> for a list of the functions required in order to tie a hash
+to a package. The basic B<Tie::Hash> package provides a C<new> method, as well
+as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> package
+provides most methods required for hashes in L<perltie>. It inherits from
+B<Tie::Hash>, and causes tied hashes to behave exactly like standard hashes,
+allowing for selective overloading of methods. The C<new> method is provided
+as grandfathering in the case a class forgets to include a C<TIEHASH> method.
+
+For developers wishing to write their own tied hashes, the required methods
+are briefly defined below. See the L<perltie> section for more detailed
+descriptive, as well as example code:
+
+=over
+
+=item TIEHASH classname, LIST
+
+The method invoked by the command C<tie %hash, classname>. Associates a new
+hash instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item STORE this, key, value
+
+Store datum I<value> into I<key> for the tied hash I<this>.
+
+=item FETCH this, key
+
+Retrieve the datum in I<key> for the tied hash I<this>.
+
+=item FIRSTKEY this
+
+Return the (key, value) pair for the first key in the hash.
+
+=item NEXTKEY this, lastkey
+
+Return the next key for the hash.
+
+=item EXISTS this, key
+
+Verify that I<key> exists with the tied hash I<this>.
+
+=item DELETE this, key
+
+Delete the key I<key> from the tied hash I<this>.
+
+=item CLEAR this
+
+Clear all values from the tied hash I<this>.
+
+=back
+
+=head1 CAVEATS
+
+The L<perltie> documentation includes a method called C<DESTROY> as
+a necessary method for tied hashes. Neither B<Tie::Hash> nor B<Tie::StdHash>
+define a default for this method. This is a standard for class packages,
+but may be omitted in favor of a simple default.
+
+=head1 MORE INFORMATION
+
+The packages relating to various DBM-related implemetations (F<DB_File>,
+F<NDBM_File>, etc.) show examples of general tied hashes, as does the
+L<Config> module. While these do not utilize B<Tie::Hash>, they serve as
+good working examples.
+
+=cut
+
+use Carp;
+
+sub new {
+ my $pkg = shift;
+ $pkg->TIEHASH(@_);
+}
+
+# Grandfather "new"
+
+sub TIEHASH {
+ my $pkg = shift;
+ if (defined &{"${pkg}::new"}) {
+ carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"
+ if $^W;
+ $pkg->new(@_);
+ }
+ else {
+ croak "$pkg doesn't define a TIEHASH method";
+ }
+}
+
+sub EXISTS {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define an EXISTS method";
+}
+
+sub CLEAR {
+ my $self = shift;
+ my $key = $self->FIRSTKEY(@_);
+ my @keys;
+
+ while (defined $key) {
+ push @keys, $key;
+ $key = $self->NEXTKEY(@_, $key);
+ }
+ foreach $key (@keys) {
+ $self->DELETE(@_, $key);
+ }
+}
+
+# The Tie::StdHash package implements standard perl hash behaviour.
+# It exists to act as a base class for classes which only wish to
+# alter some parts of their behaviour.
+
+package Tie::StdHash;
+@ISA = qw(Tie::Hash);
+
+sub TIEHASH { bless {}, $_[0] }
+sub STORE { $_[0]->{$_[1]} = $_[2] }
+sub FETCH { $_[0]->{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY { each %{$_[0]} }
+sub EXISTS { exists $_[0]->{$_[1]} }
+sub DELETE { delete $_[0]->{$_[1]} }
+sub CLEAR { %{$_[0]} = () }
+
+1;
diff --git a/contrib/perl5/lib/Tie/RefHash.pm b/contrib/perl5/lib/Tie/RefHash.pm
new file mode 100644
index 000000000000..66de2572fcd4
--- /dev/null
+++ b/contrib/perl5/lib/Tie/RefHash.pm
@@ -0,0 +1,123 @@
+package Tie::RefHash;
+
+=head1 NAME
+
+Tie::RefHash - use references as hash keys
+
+=head1 SYNOPSIS
+
+ require 5.004;
+ use Tie::RefHash;
+ tie HASHVARIABLE, 'Tie::RefHash', LIST;
+
+ untie HASHVARIABLE;
+
+=head1 DESCRIPTION
+
+This module provides the ability to use references as hash keys if
+you first C<tie> the hash variable to this module.
+
+It is implemented using the standard perl TIEHASH interface. Please
+see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
+
+=head1 EXAMPLE
+
+ use Tie::RefHash;
+ tie %h, 'Tie::RefHash';
+ $a = [];
+ $b = {};
+ $c = \*main;
+ $d = \"gunk";
+ $e = sub { 'foo' };
+ %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
+ $a->[0] = 'foo';
+ $b->{foo} = 'bar';
+ for (keys %h) {
+ print ref($_), "\n";
+ }
+
+
+=head1 AUTHOR
+
+Gurusamy Sarathy gsar@umich.edu
+
+=head1 VERSION
+
+Version 1.2 15 Dec 1996
+
+=head1 SEE ALSO
+
+perl(1), perlfunc(1), perltie(1)
+
+=cut
+
+require 5.003_11;
+use Tie::Hash;
+@ISA = qw(Tie::Hash);
+use strict;
+
+sub TIEHASH {
+ my $c = shift;
+ my $s = [];
+ bless $s, $c;
+ while (@_) {
+ $s->STORE(shift, shift);
+ }
+ return $s;
+}
+
+sub FETCH {
+ my($s, $k) = @_;
+ (ref $k) ? $s->[0]{"$k"}[1] : $s->[1]{$k};
+}
+
+sub STORE {
+ my($s, $k, $v) = @_;
+ if (ref $k) {
+ $s->[0]{"$k"} = [$k, $v];
+ }
+ else {
+ $s->[1]{$k} = $v;
+ }
+ $v;
+}
+
+sub DELETE {
+ my($s, $k) = @_;
+ (ref $k) ? delete($s->[0]{"$k"}) : delete($s->[1]{$k});
+}
+
+sub EXISTS {
+ my($s, $k) = @_;
+ (ref $k) ? exists($s->[0]{"$k"}) : exists($s->[1]{$k});
+}
+
+sub FIRSTKEY {
+ my $s = shift;
+ my $a = scalar(keys %{$s->[0]}) + scalar(keys %{$s->[1]});
+ $s->[2] = 0;
+ $s->NEXTKEY;
+}
+
+sub NEXTKEY {
+ my $s = shift;
+ my ($k, $v);
+ if (!$s->[2]) {
+ if (($k, $v) = each %{$s->[0]}) {
+ return $s->[0]{"$k"}[0];
+ }
+ else {
+ $s->[2] = 1;
+ }
+ }
+ return each %{$s->[1]};
+}
+
+sub CLEAR {
+ my $s = shift;
+ $s->[2] = 0;
+ %{$s->[0]} = ();
+ %{$s->[1]} = ();
+}
+
+1;
diff --git a/contrib/perl5/lib/Tie/Scalar.pm b/contrib/perl5/lib/Tie/Scalar.pm
new file mode 100644
index 000000000000..ef27dc1398c8
--- /dev/null
+++ b/contrib/perl5/lib/Tie/Scalar.pm
@@ -0,0 +1,138 @@
+package Tie::Scalar;
+
+=head1 NAME
+
+Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
+
+=head1 SYNOPSIS
+
+ package NewScalar;
+ require Tie::Scalar;
+
+ @ISA = (Tie::Scalar);
+
+ sub FETCH { ... } # Provide a needed method
+ sub TIESCALAR { ... } # Overrides inherited method
+
+
+ package NewStdScalar;
+ require Tie::Scalar;
+
+ @ISA = (Tie::StdScalar);
+
+ # All methods provided by default, so define only what needs be overridden
+ sub FETCH { ... }
+
+
+ package main;
+
+ tie $new_scalar, 'NewScalar';
+ tie $new_std_scalar, 'NewStdScalar';
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for scalar-tying classes. See
+L<perltie> for a list of the functions required in tying a scalar to a
+package. The basic B<Tie::Scalar> package provides a C<new> method, as well
+as methods C<TIESCALAR>, C<FETCH> and C<STORE>. The B<Tie::StdScalar>
+package provides all the methods specified in L<perltie>. It inherits from
+B<Tie::Scalar> and causes scalars tied to it to behave exactly like the
+built-in scalars, allowing for selective overloading of methods. The C<new>
+method is provided as a means of grandfathering, for classes that forget to
+provide their own C<TIESCALAR> method.
+
+For developers wishing to write their own tied-scalar classes, the methods
+are summarized below. The L<perltie> section not only documents these, but
+has sample code as well:
+
+=over
+
+=item TIESCALAR classname, LIST
+
+The method invoked by the command C<tie $scalar, classname>. Associates a new
+scalar instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item FETCH this
+
+Retrieve the value of the tied scalar referenced by I<this>.
+
+=item STORE this, value
+
+Store data I<value> in the tied scalar referenced by I<this>.
+
+=item DESTROY this
+
+Free the storage associated with the tied scalar referenced by I<this>.
+This is rarely needed, as Perl manages its memory quite well. But the
+option exists, should a class wish to perform specific actions upon the
+destruction of an instance.
+
+=back
+
+=head1 MORE INFORMATION
+
+The L<perltie> section uses a good example of tying scalars by associating
+process IDs with priority.
+
+=cut
+
+use Carp;
+
+sub new {
+ my $pkg = shift;
+ $pkg->TIESCALAR(@_);
+}
+
+# "Grandfather" the new, a la Tie::Hash
+
+sub TIESCALAR {
+ my $pkg = shift;
+ if (defined &{"{$pkg}::new"}) {
+ carp "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing"
+ if $^W;
+ $pkg->new(@_);
+ }
+ else {
+ croak "$pkg doesn't define a TIESCALAR method";
+ }
+}
+
+sub FETCH {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a FETCH method";
+}
+
+sub STORE {
+ my $pkg = ref $_[0];
+ croak "$pkg doesn't define a STORE method";
+}
+
+#
+# The Tie::StdScalar package provides scalars that behave exactly like
+# Perl's built-in scalars. Good base to inherit from, if you're only going to
+# tweak a small bit.
+#
+package Tie::StdScalar;
+@ISA = (Tie::Scalar);
+
+sub TIESCALAR {
+ my $class = shift;
+ my $instance = shift || undef;
+ return bless \$instance => $class;
+}
+
+sub FETCH {
+ return ${$_[0]};
+}
+
+sub STORE {
+ ${$_[0]} = $_[1];
+}
+
+sub DESTROY {
+ undef ${$_[0]};
+}
+
+1;
diff --git a/contrib/perl5/lib/Tie/SubstrHash.pm b/contrib/perl5/lib/Tie/SubstrHash.pm
new file mode 100644
index 000000000000..44c2140c7beb
--- /dev/null
+++ b/contrib/perl5/lib/Tie/SubstrHash.pm
@@ -0,0 +1,180 @@
+package Tie::SubstrHash;
+
+=head1 NAME
+
+Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
+
+=head1 SYNOPSIS
+
+ require Tie::SubstrHash;
+
+ tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
+
+=head1 DESCRIPTION
+
+The B<Tie::SubstrHash> package provides a hash-table-like interface to
+an array of determinate size, with constant key size and record size.
+
+Upon tying a new hash to this package, the developer must specify the
+size of the keys that will be used, the size of the value fields that the
+keys will index, and the size of the overall table (in terms of key-value
+pairs, not size in hard memory). I<These values will not change for the
+duration of the tied hash>. The newly-allocated hash table may now have
+data stored and retrieved. Efforts to store more than C<$table_size>
+elements will result in a fatal error, as will efforts to store a value
+not exactly C<$value_len> characters in length, or reference through a
+key not exactly C<$key_len> characters in length. While these constraints
+may seem excessive, the result is a hash table using much less internal
+memory than an equivalent freely-allocated hash table.
+
+=head1 CAVEATS
+
+Because the current implementation uses the table and key sizes for the
+hashing algorithm, there is no means by which to dynamically change the
+value of any of the initialization parameters.
+
+=cut
+
+use Carp;
+
+sub TIEHASH {
+ my $pack = shift;
+ my ($klen, $vlen, $tsize) = @_;
+ my $rlen = 1 + $klen + $vlen;
+ $tsize = findprime($tsize * 1.1); # Allow 10% empty.
+ $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
+ $$self[0] x= $rlen * $tsize;
+ $self;
+}
+
+sub FETCH {
+ local($self,$key) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ return undef;
+ }
+ elsif (ord($record) == 1) {
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ return substr($record, 1+$klen, $vlen);
+ }
+ &rehash;
+ }
+}
+
+sub STORE {
+ local($self,$key,$val) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ croak("Table is full") if $self[5] == $tsize;
+ croak(qq/Value "$val" is not $vlen characters long./)
+ if length($val) != $vlen;
+ my $writeoffset;
+
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ $record = "\2". $key . $val;
+ die "panic" unless length($record) == $rlen;
+ $writeoffset = $offset unless defined $writeoffset;
+ substr($$self[0], $writeoffset, $rlen) = $record;
+ ++$$self[5];
+ return;
+ }
+ elsif (ord($record) == 1) {
+ $writeoffset = $offset unless defined $writeoffset;
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ $record = "\2". $key . $val;
+ die "panic" unless length($record) == $rlen;
+ substr($$self[0], $offset, $rlen) = $record;
+ return;
+ }
+ &rehash;
+ }
+}
+
+sub DELETE {
+ local($self,$key) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ return undef;
+ }
+ elsif (ord($record) == 1) {
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ substr($$self[0], $offset, 1) = "\1";
+ return substr($record, 1+$klen, $vlen);
+ --$$self[5];
+ }
+ &rehash;
+ }
+}
+
+sub FIRSTKEY {
+ local($self) = @_;
+ $$self[6] = -1;
+ &NEXTKEY;
+}
+
+sub NEXTKEY {
+ local($self) = @_;
+ local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
+ for (++$iterix; $iterix < $tsize; ++$iterix) {
+ next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
+ $$self[6] = $iterix;
+ return substr($$self[0], $iterix * $rlen + 1, $klen);
+ }
+ $$self[6] = -1;
+ undef;
+}
+
+sub hashkey {
+ croak(qq/Key "$key" is not $klen characters long.\n/)
+ if length($key) != $klen;
+ $hash = 2;
+ for (unpack('C*', $key)) {
+ $hash = $hash * 33 + $_;
+ &_hashwrap if $hash >= 1e13;
+ }
+ &_hashwrap if $hash >= $tsize;
+ $hash = 1 unless $hash;
+ $hashbase = $hash;
+}
+
+sub _hashwrap {
+ $hash -= int($hash / $tsize) * $tsize;
+}
+
+sub rehash {
+ $hash += $hashbase;
+ $hash -= $tsize if $hash >= $tsize;
+}
+
+sub findprime {
+ use integer;
+
+ my $num = shift;
+ $num++ unless $num % 2;
+
+ $max = int sqrt $num;
+
+ NUM:
+ for (;; $num += 2) {
+ for ($i = 3; $i <= $max; $i += 2) {
+ next NUM unless $num % $i;
+ }
+ return $num;
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/Time/Local.pm b/contrib/perl5/lib/Time/Local.pm
new file mode 100644
index 000000000000..eef412d46d71
--- /dev/null
+++ b/contrib/perl5/lib/Time/Local.pm
@@ -0,0 +1,138 @@
+package Time::Local;
+require 5.000;
+require Exporter;
+use Carp;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(timegm timelocal);
+
+=head1 NAME
+
+Time::Local - efficiently compute time from local and GMT time
+
+=head1 SYNOPSIS
+
+ $time = timelocal($sec,$min,$hours,$mday,$mon,$year);
+ $time = timegm($sec,$min,$hours,$mday,$mon,$year);
+
+=head1 DESCRIPTION
+
+These routines are quite efficient and yet are always guaranteed to agree
+with localtime() and gmtime(). We manage this by caching the start times
+of any months we've seen before. If we know the start time of the month,
+we can always calculate any time within the month. The start times
+themselves are guessed by successive approximation starting at the
+current time, since most dates seen in practice are close to the
+current date. Unlike algorithms that do a binary search (calling gmtime
+once for each bit of the time value, resulting in 32 calls), this algorithm
+calls it at most 6 times, and usually only once or twice. If you hit
+the month cache, of course, it doesn't call it at all.
+
+timelocal is implemented using the same cache. We just assume that we're
+translating a GMT time, and then fudge it when we're done for the timezone
+and daylight savings arguments. The timezone is determined by examining
+the result of localtime(0) when the package is initialized. The daylight
+savings offset is currently assumed to be one hour.
+
+Both routines return -1 if the integer limit is hit. I.e. for dates
+after the 1st of January, 2038 on most machines.
+
+=cut
+
+BEGIN {
+ $SEC = 1;
+ $MIN = 60 * $SEC;
+ $HR = 60 * $MIN;
+ $DAY = 24 * $HR;
+ $epoch = (localtime(2*$DAY))[5]; # Allow for bugs near localtime == 0.
+
+ $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0;
+
+}
+
+sub timegm {
+ $ym = pack(C2, @_[5,4]);
+ $cheat = $cheat{$ym} || &cheat;
+ return -1 if $cheat<0 and $^O ne 'VMS';
+ $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY;
+}
+
+sub timelocal {
+ my $t = &timegm;
+ my $tt = $t;
+
+ my (@lt) = localtime($t);
+ my (@gt) = gmtime($t);
+ if ($t < $DAY and ($lt[5] >= 70 or $gt[5] >= 70 )) {
+ # Wrap error, too early a date
+ # Try a safer date
+ $tt = $DAY;
+ @lt = localtime($tt);
+ @gt = gmtime($tt);
+ }
+
+ my $tzsec = ($gt[1] - $lt[1]) * $MIN + ($gt[2] - $lt[2]) * $HR;
+
+ my($lday,$gday) = ($lt[7],$gt[7]);
+ if($lt[5] > $gt[5]) {
+ $tzsec -= $DAY;
+ }
+ elsif($gt[5] > $lt[5]) {
+ $tzsec += $DAY;
+ }
+ else {
+ $tzsec += ($gt[7] - $lt[7]) * $DAY;
+ }
+
+ $tzsec += $HR if($lt[8]);
+
+ $time = $t + $tzsec;
+ return -1 if $cheat<0 and $^O ne 'VMS';
+ @test = localtime($time + ($tt - $t));
+ $time -= $HR if $test[2] != $_[2];
+ $time;
+}
+
+sub cheat {
+ $year = $_[5];
+ $year -= 1900
+ if $year > 1900;
+ $month = $_[4];
+ croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0;
+ croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1;
+ croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0;
+ croak "Minute '$_[1]' out of range 0..59" if $_[1] > 59 || $_[1] < 0;
+ croak "Second '$_[0]' out of range 0..59" if $_[0] > 59 || $_[0] < 0;
+ $guess = $^T;
+ @g = gmtime($guess);
+ $year += $YearFix if $year < $epoch;
+ $lastguess = "";
+ $counter = 0;
+ while ($diff = $year - $g[5]) {
+ croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255;
+ $guess += $diff * (363 * $DAY);
+ @g = gmtime($guess);
+ if (($thisguess = "@g") eq $lastguess){
+ return -1; #date beyond this machine's integer limit
+ }
+ $lastguess = $thisguess;
+ }
+ while ($diff = $month - $g[4]) {
+ croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255;
+ $guess += $diff * (27 * $DAY);
+ @g = gmtime($guess);
+ if (($thisguess = "@g") eq $lastguess){
+ return -1; #date beyond this machine's integer limit
+ }
+ $lastguess = $thisguess;
+ }
+ @gfake = gmtime($guess-1); #still being sceptic
+ if ("@gfake" eq $lastguess){
+ return -1; #date beyond this machine's integer limit
+ }
+ $g[3]--;
+ $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAY;
+ $cheat{$ym} = $guess;
+}
+
+1;
diff --git a/contrib/perl5/lib/Time/gmtime.pm b/contrib/perl5/lib/Time/gmtime.pm
new file mode 100644
index 000000000000..c1d11d74dbb0
--- /dev/null
+++ b/contrib/perl5/lib/Time/gmtime.pm
@@ -0,0 +1,88 @@
+package Time::gmtime;
+use strict;
+use Time::tm;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
+ @ISA = qw(Exporter Time::tm);
+ @EXPORT = qw(gmtime gmctime);
+ @EXPORT_OK = qw(
+ $tm_sec $tm_min $tm_hour $tm_mday
+ $tm_mon $tm_year $tm_wday $tm_yday
+ $tm_isdst
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+ $VERSION = 1.01;
+}
+use vars @EXPORT_OK;
+
+sub populate (@) {
+ return unless @_;
+ my $tmob = Time::tm->new();
+ @$tmob = (
+ $tm_sec, $tm_min, $tm_hour, $tm_mday,
+ $tm_mon, $tm_year, $tm_wday, $tm_yday,
+ $tm_isdst )
+ = @_;
+ return $tmob;
+}
+
+sub gmtime (;$) { populate CORE::gmtime(@_ ? shift : time)}
+sub gmctime (;$) { scalar CORE::gmtime(@_ ? shift : time)}
+
+1;
+__END__
+
+=head1 NAME
+
+Time::gmtime - by-name interface to Perl's built-in gmtime() function
+
+=head1 SYNOPSIS
+
+ use Time::gmtime;
+ $gm = gmtime();
+ printf "The day in Greenwich is %s\n",
+ (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm->wday() ];
+
+ use Time::gmtime w(:FIELDS;
+ printf "The day in Greenwich is %s\n",
+ (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm_wday() ];
+
+ $now = gmctime();
+
+ use Time::gmtime;
+ use File::stat;
+ $date_string = gmctime(stat($file)->mtime);
+
+=head1 DESCRIPTION
+
+This module's default exports override the core gmtime() function,
+replacing it with a version that returns "Time::tm" objects.
+This object has methods that return the similarly named structure field
+name from the C's tm structure from F<time.h>; namely sec, min, hour,
+mday, mon, year, wday, yday, and isdst.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this
+still overrides your core functions.) Access these fields as variables
+named with a preceding C<tm_> in front their method names. Thus,
+C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields.
+
+The gmctime() funtion provides a way of getting at the
+scalar sense of the original CORE::gmtime() function.
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/contrib/perl5/lib/Time/localtime.pm b/contrib/perl5/lib/Time/localtime.pm
new file mode 100644
index 000000000000..94377525973c
--- /dev/null
+++ b/contrib/perl5/lib/Time/localtime.pm
@@ -0,0 +1,84 @@
+package Time::localtime;
+use strict;
+use Time::tm;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
+ @ISA = qw(Exporter Time::tm);
+ @EXPORT = qw(localtime ctime);
+ @EXPORT_OK = qw(
+ $tm_sec $tm_min $tm_hour $tm_mday
+ $tm_mon $tm_year $tm_wday $tm_yday
+ $tm_isdst
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+ $VERSION = 1.01;
+}
+use vars @EXPORT_OK;
+
+sub populate (@) {
+ return unless @_;
+ my $tmob = Time::tm->new();
+ @$tmob = (
+ $tm_sec, $tm_min, $tm_hour, $tm_mday,
+ $tm_mon, $tm_year, $tm_wday, $tm_yday,
+ $tm_isdst )
+ = @_;
+ return $tmob;
+}
+
+sub localtime (;$) { populate CORE::localtime(@_ ? shift : time)}
+sub ctime (;$) { scalar CORE::localtime(@_ ? shift : time) }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Time::localtime - by-name interface to Perl's built-in localtime() function
+
+=head1 SYNOPSIS
+
+ use Time::localtime;
+ printf "Year is %d\n", localtime->year() + 1900;
+
+ $now = ctime();
+
+ use Time::localtime;
+ use File::stat;
+ $date_string = ctime(stat($file)->mtime);
+
+=head1 DESCRIPTION
+
+This module's default exports override the core localtime() function,
+replacing it with a version that returns "Time::tm" objects.
+This object has methods that return the similarly named structure field
+name from the C's tm structure from F<time.h>; namely sec, min, hour,
+mday, mon, year, wday, yday, and isdst.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as
+variables named with a preceding C<tm_> in front their method names.
+Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import
+the fields.
+
+The ctime() funtion provides a way of getting at the
+scalar sense of the original CORE::localtime() function.
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/contrib/perl5/lib/Time/tm.pm b/contrib/perl5/lib/Time/tm.pm
new file mode 100644
index 000000000000..fd47ad19a954
--- /dev/null
+++ b/contrib/perl5/lib/Time/tm.pm
@@ -0,0 +1,31 @@
+package Time::tm;
+use strict;
+
+use Class::Struct qw(struct);
+struct('Time::tm' => [
+ map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst }
+]);
+
+1;
+__END__
+
+=head1 NAME
+
+Time::tm - internal object used by Time::gmtime and Time::localtime
+
+=head1 SYNOPSIS
+
+Don't use this module directly.
+
+=head1 DESCRIPTION
+
+This module is used internally as a base class by Time::localtime And
+Time::gmtime functions. It creates a Time::tm struct object which is
+addressable just like's C's tm structure from F<time.h>; namely with sec,
+min, hour, mday, mon, year, wday, yday, and isdst.
+
+This class is an internal interface only.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/contrib/perl5/lib/UNIVERSAL.pm b/contrib/perl5/lib/UNIVERSAL.pm
new file mode 100644
index 000000000000..dc02423029ed
--- /dev/null
+++ b/contrib/perl5/lib/UNIVERSAL.pm
@@ -0,0 +1,97 @@
+package UNIVERSAL;
+
+# UNIVERSAL should not contain any extra subs/methods beyond those
+# that it exists to define. The use of Exporter below is a historical
+# accident that should be fixed sometime.
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT_OK = qw(isa can);
+
+1;
+__END__
+
+=head1 NAME
+
+UNIVERSAL - base class for ALL classes (blessed references)
+
+=head1 SYNOPSIS
+
+ $io = $fd->isa("IO::Handle");
+ $sub = $obj->can('print');
+
+ $yes = UNIVERSAL::isa($ref, "HASH");
+
+=head1 DESCRIPTION
+
+C<UNIVERSAL> is the base class which all bless references will inherit from,
+see L<perlobj>
+
+C<UNIVERSAL> provides the following methods
+
+=over 4
+
+=item isa ( TYPE )
+
+C<isa> returns I<true> if C<REF> is blessed into package C<TYPE>
+or inherits from package C<TYPE>.
+
+C<isa> can be called as either a static or object method call.
+
+=item can ( METHOD )
+
+C<can> checks if the object has a method called C<METHOD>. If it does
+then a reference to the sub is returned. If it does not then I<undef>
+is returned.
+
+C<can> can be called as either a static or object method call.
+
+=item VERSION ( [ REQUIRE ] )
+
+C<VERSION> will return the value of the variable C<$VERSION> in the
+package the object is blessed into. If C<REQUIRE> is given then
+it will do a comparison and die if the package version is not
+greater than or equal to C<REQUIRE>.
+
+C<VERSION> can be called as either a static or object method call.
+
+=back
+
+The C<isa> and C<can> methods can also be called as subroutines
+
+=over 4
+
+=item UNIVERSAL::isa ( VAL, TYPE )
+
+C<isa> returns I<true> if the first argument is a reference and either
+of the following statements is true.
+
+=over 8
+
+=item
+
+C<VAL> is a blessed reference and is blessed into package C<TYPE>
+or inherits from package C<TYPE>
+
+=item
+
+C<VAL> is a reference to a C<TYPE> of perl variable (er 'HASH')
+
+=back
+
+=item UNIVERSAL::can ( VAL, METHOD )
+
+If C<VAL> is a blessed reference which has a method called C<METHOD>,
+C<can> returns a reference to the subroutine. If C<VAL> is not
+a blessed reference, or if it does not have a method C<METHOD>,
+I<undef> is returned.
+
+=back
+
+These subroutines should I<not> be imported via S<C<use UNIVERSAL qw(...)>>.
+If you want simple local access to them you can do
+
+ *isa = \&UNIVERSAL::isa;
+
+to import isa into your package.
+
+=cut
diff --git a/contrib/perl5/lib/User/grent.pm b/contrib/perl5/lib/User/grent.pm
new file mode 100644
index 000000000000..deb0a8d1be91
--- /dev/null
+++ b/contrib/perl5/lib/User/grent.pm
@@ -0,0 +1,93 @@
+package User::grent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @EXPORT = qw(getgrent getgrgid getgrnam getgr);
+ @EXPORT_OK = qw($gr_name $gr_gid $gr_passwd $gr_mem @gr_members);
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'User::grent' => [
+ name => '$',
+ passwd => '$',
+ gid => '$',
+ members => '@',
+];
+
+sub populate (@) {
+ return unless @_;
+ my $gob = new();
+ ($gr_name, $gr_passwd, $gr_gid) = @$gob[0,1,2] = @_[0,1,2];
+ @gr_members = @{$gob->[3]} = split ' ', $_[3];
+ return $gob;
+}
+
+sub getgrent ( ) { populate(CORE::getgrent()) }
+sub getgrnam ($) { populate(CORE::getgrnam(shift)) }
+sub getgrgid ($) { populate(CORE::getgrgid(shift)) }
+sub getgr ($) { ($_[0] =~ /^\d+/) ? &getgrgid : &getgrnam }
+
+1;
+__END__
+
+=head1 NAME
+
+User::grent - by-name interface to Perl's built-in getgr*() functions
+
+=head1 SYNOPSIS
+
+ use User::grent;
+ $gr = getgrgid(0) or die "No group zero";
+ if ( $gr->name eq 'wheel' && @{$gr->members} > 1 ) {
+ print "gid zero name wheel, with other members";
+ }
+
+ use User::grent qw(:FIELDS;
+ getgrgid(0) or die "No group zero";
+ if ( $gr_name eq 'wheel' && @gr_members > 1 ) {
+ print "gid zero name wheel, with other members";
+ }
+
+ $gr = getgr($whoever);
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getgrent(), getgruid(),
+and getgrnam() functions, replacing them with versions that return
+"User::grent" objects. This object has methods that return the similarly
+named structure field name from the C's passwd structure from F<grp.h>;
+namely name, passwd, gid, and members (not mem). The first three
+return scalars, the last an array reference.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as variables named
+with a preceding C<gr_>. Thus, C<$group_obj-E<gt>gid()> corresponds
+to $gr_gid if you import the fields. Array references are available as
+regular array variables, so C<@{ $group_obj-E<gt>members() }> would be
+simply @gr_members.
+
+The getpw() funtion is a simple front-end that forwards
+a numeric argument to getpwuid() and the rest to getpwnam().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/contrib/perl5/lib/User/pwent.pm b/contrib/perl5/lib/User/pwent.pm
new file mode 100644
index 000000000000..32301cadfc53
--- /dev/null
+++ b/contrib/perl5/lib/User/pwent.pm
@@ -0,0 +1,103 @@
+package User::pwent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @EXPORT = qw(getpwent getpwuid getpwnam getpw);
+ @EXPORT_OK = qw(
+ $pw_name $pw_passwd $pw_uid
+ $pw_gid $pw_quota $pw_comment
+ $pw_gecos $pw_dir $pw_shell
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# Class::Struct forbids use of @ISA
+sub import { goto &Exporter::import }
+
+use Class::Struct qw(struct);
+struct 'User::pwent' => [
+ name => '$',
+ passwd => '$',
+ uid => '$',
+ gid => '$',
+ quota => '$',
+ comment => '$',
+ gecos => '$',
+ dir => '$',
+ shell => '$',
+];
+
+sub populate (@) {
+ return unless @_;
+ my $pwob = new();
+
+ ( $pw_name, $pw_passwd, $pw_uid,
+ $pw_gid, $pw_quota, $pw_comment,
+ $pw_gecos, $pw_dir, $pw_shell, ) = @$pwob = @_;
+
+ return $pwob;
+}
+
+sub getpwent ( ) { populate(CORE::getpwent()) }
+sub getpwnam ($) { populate(CORE::getpwnam(shift)) }
+sub getpwuid ($) { populate(CORE::getpwuid(shift)) }
+sub getpw ($) { ($_[0] =~ /^\d+/) ? &getpwuid : &getpwnam }
+
+1;
+__END__
+
+=head1 NAME
+
+User::pwent - by-name interface to Perl's built-in getpw*() functions
+
+=head1 SYNOPSIS
+
+ use User::pwent;
+ $pw = getpwnam('daemon') or die "No daemon user";
+ if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?$# ) {
+ print "gid 1 on root dir";
+ }
+
+ use User::pwent qw(:FIELDS);
+ getpwnam('daemon') or die "No daemon user";
+ if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?$# ) {
+ print "gid 1 on root dir";
+ }
+
+ $pw = getpw($whoever);
+
+=head1 DESCRIPTION
+
+This module's default exports override the core getpwent(), getpwuid(),
+and getpwnam() functions, replacing them with versions that return
+"User::pwent" objects. This object has methods that return the similarly
+named structure field name from the C's passwd structure from F<pwd.h>;
+namely name, passwd, uid, gid, quota, comment, gecos, dir, and shell.
+
+You may also import all the structure fields directly into your namespace
+as regular variables using the :FIELDS import tag. (Note that this still
+overrides your core functions.) Access these fields as
+variables named with a preceding C<pw_> in front their method names.
+Thus, C<$passwd_obj-E<gt>shell()> corresponds to $pw_shell if you import
+the fields.
+
+The getpw() funtion is a simple front-end that forwards
+a numeric argument to getpwuid() and the rest to getpwnam().
+
+To access this functionality without the core overrides,
+pass the C<use> an empty import list, and then access
+function functions with their full qualified names.
+On the other hand, the built-ins are still available
+via the C<CORE::> pseudo-package.
+
+=head1 NOTE
+
+While this class is currently implemented using the Class::Struct
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/contrib/perl5/lib/abbrev.pl b/contrib/perl5/lib/abbrev.pl
new file mode 100644
index 000000000000..62975e66f326
--- /dev/null
+++ b/contrib/perl5/lib/abbrev.pl
@@ -0,0 +1,33 @@
+;# Usage:
+;# %foo = ();
+;# &abbrev(*foo,LIST);
+;# ...
+;# $long = $foo{$short};
+
+package abbrev;
+
+sub main'abbrev {
+ local(*domain) = @_;
+ shift(@_);
+ @cmp = @_;
+ local($[) = 0;
+ foreach $name (@_) {
+ @extra = split(//,$name);
+ $abbrev = shift(@extra);
+ $len = 1;
+ foreach $cmp (@cmp) {
+ next if $cmp eq $name;
+ while (@extra && substr($cmp,0,$len) eq $abbrev) {
+ $abbrev .= shift(@extra);
+ ++$len;
+ }
+ }
+ $domain{$abbrev} = $name;
+ while ($#extra >= 0) {
+ $abbrev .= shift(@extra);
+ $domain{$abbrev} = $name;
+ }
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/assert.pl b/contrib/perl5/lib/assert.pl
new file mode 100644
index 000000000000..4c9ebf20a0d3
--- /dev/null
+++ b/contrib/perl5/lib/assert.pl
@@ -0,0 +1,55 @@
+# assert.pl
+# tchrist@convex.com (Tom Christiansen)
+#
+# Usage:
+#
+# &assert('@x > @y');
+# &assert('$var > 10', $var, $othervar, @various_info);
+#
+# That is, if the first expression evals false, we blow up. The
+# rest of the args, if any, are nice to know because they will
+# be printed out by &panic, which is just the stack-backtrace
+# routine shamelessly borrowed from the perl debugger.
+
+sub assert {
+ &panic("ASSERTION BOTCHED: $_[$[]",$@) unless eval $_[$[];
+}
+
+sub panic {
+ package DB;
+
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ # stack traceback gratefully borrowed from perl debugger
+
+ local $_;
+ my $i;
+ my ($p,$f,$l,$s,$h,$a,@a,@frames);
+ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @args;
+ for (@a) {
+ if (/^StB\000/ && length($_) == length($_main{'_main'})) {
+ $_ = sprintf("%s",$_);
+ }
+ else {
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ push(@frames, "$w&$s$a from file $f line $l\n");
+ }
+ for ($i=0; $i <= $#frames; $i++) {
+ print $frames[$i];
+ }
+ exit 1;
+}
+
+1;
diff --git a/contrib/perl5/lib/autouse.pm b/contrib/perl5/lib/autouse.pm
new file mode 100644
index 000000000000..4445c6c419bd
--- /dev/null
+++ b/contrib/perl5/lib/autouse.pm
@@ -0,0 +1,157 @@
+package autouse;
+
+#use strict; # debugging only
+use 5.003_90; # ->can, for my $var
+
+$autouse::VERSION = '1.01';
+
+$autouse::DEBUG ||= 0;
+
+sub vet_import ($);
+
+sub croak {
+ require Carp;
+ Carp::croak(@_);
+}
+
+sub import {
+ my $class = @_ ? shift : 'autouse';
+ croak "usage: use $class MODULE [,SUBS...]" unless @_;
+ my $module = shift;
+
+ (my $pm = $module) =~ s{::}{/}g;
+ $pm .= '.pm';
+ if (exists $INC{$pm}) {
+ vet_import $module;
+ local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
+ # $Exporter::Verbose = 1;
+ return $module->import(map { (my $f = $_) =~ s/\(.*?\)$// } @_);
+ }
+
+ # It is not loaded: need to do real work.
+ my $callpkg = caller(0);
+ print "autouse called from $callpkg\n" if $autouse::DEBUG;
+
+ my $index;
+ for my $f (@_) {
+ my $proto;
+ $proto = $1 if (my $func = $f) =~ s/\((.*)\)$//;
+
+ my $closure_import_func = $func; # Full name
+ my $closure_func = $func; # Name inside package
+ my $index = index($func, '::');
+ if ($index == -1) {
+ $closure_import_func = "${callpkg}::$func";
+ } else {
+ $closure_func = substr $func, $index + 2;
+ croak "autouse into different package attempted"
+ unless substr($func, 0, $index) eq $module;
+ }
+
+ my $load_sub = sub {
+ unless ($INC{$pm}) {
+ eval {require $pm};
+ die if $@;
+ vet_import $module;
+ }
+ *$closure_import_func = \&{"${module}::$closure_func"};
+ print "autousing $module; "
+ ."imported $closure_func as $closure_import_func\n"
+ if $autouse::DEBUG;
+ goto &$closure_import_func;
+ };
+
+ if (defined $proto) {
+ *$closure_import_func = eval "sub ($proto) { &\$load_sub }";
+ } else {
+ *$closure_import_func = $load_sub;
+ }
+ }
+}
+
+sub vet_import ($) {
+ my $module = shift;
+ if (my $import = $module->can('import')) {
+ croak "autoused module has unique import() method"
+ unless defined(&Exporter::import)
+ && $import == \&Exporter::import;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+autouse - postpone load of modules until a function is used
+
+=head1 SYNOPSIS
+
+ use autouse 'Carp' => qw(carp croak);
+ carp "this carp was predeclared and autoused ";
+
+=head1 DESCRIPTION
+
+If the module C<Module> is already loaded, then the declaration
+
+ use autouse 'Module' => qw(func1 func2($;$) Module::func3);
+
+is equivalent to
+
+ use Module qw(func1 func2);
+
+if C<Module> defines func2() with prototype C<($;$)>, and func1() and
+func3() have no prototypes. (At least if C<Module> uses C<Exporter>'s
+C<import>, otherwise it is a fatal error.)
+
+If the module C<Module> is not loaded yet, then the above declaration
+declares functions func1() and func2() in the current package, and
+declares a function Module::func3(). When these functions are called,
+they load the package C<Module> if needed, and substitute themselves
+with the correct definitions.
+
+=head1 WARNING
+
+Using C<autouse> will move important steps of your program's execution
+from compile time to runtime. This can
+
+=over
+
+=item *
+
+Break the execution of your program if the module you C<autouse>d has
+some initialization which it expects to be done early.
+
+=item *
+
+hide bugs in your code since important checks (like correctness of
+prototypes) is moved from compile time to runtime. In particular, if
+the prototype you specified on C<autouse> line is wrong, you will not
+find it out until the corresponding function is executed. This will be
+very unfortunate for functions which are not always called (note that
+for such functions C<autouse>ing gives biggest win, for a workaround
+see below).
+
+=back
+
+To alleviate the second problem (partially) it is advised to write
+your scripts like this:
+
+ use Module;
+ use autouse Module => qw(carp($) croak(&$));
+ carp "this carp was predeclared and autoused ";
+
+The first line ensures that the errors in your argument specification
+are found early. When you ship your application you should comment
+out the first line, since it makes the second one useless.
+
+=head1 AUTHOR
+
+Ilya Zakharevich (ilya@math.ohio-state.edu)
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
diff --git a/contrib/perl5/lib/base.pm b/contrib/perl5/lib/base.pm
new file mode 100644
index 000000000000..3500cbfb8985
--- /dev/null
+++ b/contrib/perl5/lib/base.pm
@@ -0,0 +1,77 @@
+=head1 NAME
+
+base - Establish IS-A relationship with base class at compile time
+
+=head1 SYNOPSIS
+
+ package Baz;
+ use base qw(Foo Bar);
+
+=head1 DESCRIPTION
+
+Roughly similar in effect to
+
+ BEGIN {
+ require Foo;
+ require Bar;
+ push @ISA, qw(Foo Bar);
+ }
+
+Will also initialize the %FIELDS hash if one of the base classes has
+it. Multiple inheritance of %FIELDS is not supported. The 'base'
+pragma will croak if multiple base classes has a %FIELDS hash. See
+L<fields> for a description of this feature.
+
+When strict 'vars' is in scope I<base> also let you assign to @ISA
+without having to declare @ISA with the 'vars' pragma first.
+
+This module was introduced with Perl 5.004_04.
+
+=head1 SEE ALSO
+
+L<fields>
+
+=cut
+
+package base;
+
+sub import {
+ my $class = shift;
+ my $fields_base;
+
+ foreach my $base (@_) {
+ unless (defined %{"$base\::"}) {
+ eval "require $base";
+ # Only ignore "Can't locate" errors from our eval require.
+ # Other fatal errors (syntax etc) must be reported.
+ die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
+ unless (defined %{"$base\::"}) {
+ require Carp;
+ Carp::croak("Base class package \"$base\" is empty.\n",
+ "\t(Perhaps you need to 'use' the module ",
+ "which defines that package first.)");
+ }
+ }
+
+ # A simple test like (defined %{"$base\::FIELDS"}) will
+ # sometimes produce typo warnings because it would create
+ # the hash if it was not present before.
+ my $fglob;
+ if ($fglob = ${"$base\::"}{"FIELDS"} and *$fglob{HASH}) {
+ if ($fields_base) {
+ require Carp;
+ Carp::croak("Can't multiply inherit %FIELDS");
+ } else {
+ $fields_base = $base;
+ }
+ }
+ }
+ my $pkg = caller(0);
+ push @{"$pkg\::ISA"}, @_;
+ if ($fields_base) {
+ require fields;
+ fields::inherit($pkg, $fields_base);
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/bigfloat.pl b/contrib/perl5/lib/bigfloat.pl
new file mode 100644
index 000000000000..d687c784f1ca
--- /dev/null
+++ b/contrib/perl5/lib/bigfloat.pl
@@ -0,0 +1,235 @@
+package bigfloat;
+require "bigint.pl";
+# Arbitrary length float math package
+#
+# by Mark Biggar
+#
+# number format
+# canonical strings have the form /[+-]\d+E[+-]\d+/
+# Input values can have inbedded whitespace
+# Error returns
+# 'NaN' An input parameter was "Not a Number" or
+# divide by zero or sqrt of negative number
+# Division is computed to
+# max($div_scale,length(dividend)+length(divisor))
+# digits by default.
+# Also used for default sqrt scale
+
+$div_scale = 40;
+
+# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
+
+$rnd_mode = 'even';
+
+# bigfloat routines
+#
+# fadd(NSTR, NSTR) return NSTR addition
+# fsub(NSTR, NSTR) return NSTR subtraction
+# fmul(NSTR, NSTR) return NSTR multiplication
+# fdiv(NSTR, NSTR[,SCALE]) returns NSTR division to SCALE places
+# fneg(NSTR) return NSTR negation
+# fabs(NSTR) return NSTR absolute value
+# fcmp(NSTR,NSTR) return CODE compare undef,<0,=0,>0
+# fround(NSTR, SCALE) return NSTR round to SCALE digits
+# ffround(NSTR, SCALE) return NSTR round at SCALEth place
+# fnorm(NSTR) return (NSTR) normalize
+# fsqrt(NSTR[, SCALE]) return NSTR sqrt to SCALE places
+
+# Convert a number to canonical string form.
+# Takes something that looks like a number and converts it to
+# the form /^[+-]\d+E[+-]\d+$/.
+sub main'fnorm { #(string) return fnum_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/
+ && ($2 ne '' || defined($4))) {
+ my $x = defined($4) ? $4 : '';
+ &norm(($1 ? "$1$2$x" : "+$2$x"), (($x ne '') ? $6-length($x) : $6));
+ } else {
+ 'NaN';
+ }
+}
+
+# normalize number -- for internal use
+sub norm { #(mantissa, exponent) return fnum_str
+ local($_, $exp) = @_;
+ if ($_ eq 'NaN') {
+ 'NaN';
+ } else {
+ s/^([+-])0+/$1/; # strip leading zeros
+ if (length($_) == 1) {
+ '+0E+0';
+ } else {
+ $exp += length($1) if (s/(0+)$//); # strip trailing zeros
+ sprintf("%sE%+ld", $_, $exp);
+ }
+ }
+}
+
+# negation
+sub main'fneg { #(fnum_str) return fnum_str
+ local($_) = &'fnorm($_[$[]);
+ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
+ s/^H/N/;
+ $_;
+}
+
+# absolute value
+sub main'fabs { #(fnum_str) return fnum_str
+ local($_) = &'fnorm($_[$[]);
+ s/^-/+/; # mash sign
+ $_;
+}
+
+# multiplication
+sub main'fmul { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ &norm(&'bmul($xm,$ym),$xe+$ye);
+ }
+}
+
+# addition
+sub main'fadd { #(fnum_str, fnum_str) return fnum_str
+ local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
+ &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
+ }
+}
+
+# subtraction
+sub main'fsub { #(fnum_str, fnum_str) return fnum_str
+ &'fadd($_[$[],&'fneg($_[$[+1]));
+}
+
+# division
+# args are dividend, divisor, scale (optional)
+# result has at most max(scale, length(dividend), length(divisor)) digits
+sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
+{
+ local($x,$y,$scale) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]),$_[$[+2]);
+ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ local($ym,$ye) = split('E',$y);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if (length($xm)-1 > $scale);
+ $scale = length($ym)-1 if (length($ym)-1 > $scale);
+ $scale = $scale + length($ym) - length($xm);
+ &norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym),
+ $xe-$ye-$scale);
+ }
+}
+
+# round int $q based on fraction $r/$base using $rnd_mode
+sub round { #(int_str, int_str, int_str) return int_str
+ local($q,$r,$base) = @_;
+ if ($q eq 'NaN' || $r eq 'NaN') {
+ 'NaN';
+ } elsif ($rnd_mode eq 'trunc') {
+ $q; # just truncate
+ } else {
+ local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
+ if ( $cmp < 0 ||
+ ($cmp == 0 &&
+ ( $rnd_mode eq 'zero' ||
+ ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) ||
+ ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) ||
+ ($rnd_mode eq 'even' && $q =~ /[24680]$/) ||
+ ($rnd_mode eq 'odd' && $q =~ /[13579]$/) )) ) {
+ $q; # round down
+ } else {
+ &'badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1'));
+ # round up
+ }
+ }
+}
+
+# round the mantissa of $x to $scale digits
+sub main'fround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]);
+ if ($x eq 'NaN' || $scale <= 0) {
+ $x;
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if (length($xm)-1 <= $scale) {
+ $x;
+ } else {
+ &norm(&round(substr($xm,$[,$scale+1),
+ "+0".substr($xm,$[+$scale+1,1),"+10"),
+ $xe+length($xm)-$scale-1);
+ }
+ }
+}
+
+# round $x at the 10 to the $scale digit place
+sub main'ffround { #(fnum_str, scale) return fnum_str
+ local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]);
+ if ($x eq 'NaN') {
+ 'NaN';
+ } else {
+ local($xm,$xe) = split('E',$x);
+ if ($xe >= $scale) {
+ $x;
+ } else {
+ $xe = length($xm)+$xe-$scale;
+ if ($xe < 1) {
+ '+0E+0';
+ } elsif ($xe == 1) {
+ &norm(&round('+0',"+0".substr($xm,$[+1,1),"+10"), $scale);
+ } else {
+ &norm(&round(substr($xm,$[,$xe),
+ "+0".substr($xm,$[+$xe,1),"+10"), $scale);
+ }
+ }
+ }
+}
+
+# compare 2 values returns one of undef, <0, =0, >0
+# returns undef if either or both input value are not numbers
+sub main'fcmp #(fnum_str, fnum_str) return cond_code
+{
+ local($x, $y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
+ if ($x eq "NaN" || $y eq "NaN") {
+ undef;
+ } else {
+ ord($y) <=> ord($x)
+ ||
+ ( local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
+ (($xe <=> $ye) * (substr($x,$[,1).'1')
+ || &bigint'cmp($xm,$ym))
+ );
+ }
+}
+
+# square root by Newtons method.
+sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
+ local($x, $scale) = (&'fnorm($_[$[]), $_[$[+1]);
+ if ($x eq 'NaN' || $x =~ /^-/) {
+ 'NaN';
+ } elsif ($x eq '+0E+0') {
+ '+0E+0';
+ } else {
+ local($xm, $xe) = split('E',$x);
+ $scale = $div_scale if (!$scale);
+ $scale = length($xm)-1 if ($scale < length($xm)-1);
+ local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
+ while ($gs < 2*$scale) {
+ $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
+ $gs *= 2;
+ }
+ &'fround($guess, $scale);
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/bigint.pl b/contrib/perl5/lib/bigint.pl
new file mode 100644
index 000000000000..adeb17f28a93
--- /dev/null
+++ b/contrib/perl5/lib/bigint.pl
@@ -0,0 +1,285 @@
+package bigint;
+
+# arbitrary size integer math package
+#
+# by Mark Biggar
+#
+# Canonical Big integer value are strings of the form
+# /^[+-]\d+$/ with leading zeros suppressed
+# Input values to these routines may be strings of the form
+# /^\s*[+-]?[\d\s]+$/.
+# Examples:
+# '+0' canonical zero value
+# ' -123 123 123' canonical value '-123123123'
+# '1 23 456 7890' canonical value '+1234567890'
+# Output values always always in canonical form
+#
+# Actual math is done in an internal format consisting of an array
+# whose first element is the sign (/^[+-]$/) and whose remaining
+# elements are base 100000 digits with the least significant digit first.
+# The string 'NaN' is used to represent the result when input arguments
+# are not numbers, as well as the result of dividing by zero
+#
+# routines provided are:
+#
+# bneg(BINT) return BINT negation
+# babs(BINT) return BINT absolute value
+# bcmp(BINT,BINT) return CODE compare numbers (undef,<0,=0,>0)
+# badd(BINT,BINT) return BINT addition
+# bsub(BINT,BINT) return BINT subtraction
+# bmul(BINT,BINT) return BINT multiplication
+# bdiv(BINT,BINT) return (BINT,BINT) division (quo,rem) just quo if scalar
+# bmod(BINT,BINT) return BINT modulus
+# bgcd(BINT,BINT) return BINT greatest common divisor
+# bnorm(BINT) return BINT normalization
+#
+
+$zero = 0;
+
+
+# normalize string form of number. Strip leading zeros. Strip any
+# white space and add a sign, if missing.
+# Strings that are not numbers result the value 'NaN'.
+
+sub main'bnorm { #(num_str) return num_str
+ local($_) = @_;
+ s/\s+//g; # strip white space
+ if (s/^([+-]?)0*(\d+)$/$1$2/) { # test if number
+ substr($_,$[,0) = '+' unless $1; # Add missing sign
+ s/^-0/+0/;
+ $_;
+ } else {
+ 'NaN';
+ }
+}
+
+# Convert a number from string format to internal base 100000 format.
+# Assumes normalized value as input.
+sub internal { #(num_str) return int_num_array
+ local($d) = @_;
+ ($is,$il) = (substr($d,$[,1),length($d)-2);
+ substr($d,$[,1) = '';
+ ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
+}
+
+# Convert a number from internal base 100000 format to string format.
+# This routine scribbles all over input array.
+sub external { #(int_num_array) return num_str
+ $es = shift;
+ grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_); # zero pad
+ &'bnorm(join('', $es, reverse(@_))); # reverse concat and normalize
+}
+
+# Negate input value.
+sub main'bneg { #(num_str) return num_str
+ local($_) = &'bnorm(@_);
+ vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0';
+ s/^./N/ unless /^[-+]/; # works both in ASCII and EBCDIC
+ $_;
+}
+
+# Returns the absolute value of the input.
+sub main'babs { #(num_str) return num_str
+ &abs(&'bnorm(@_));
+}
+
+sub abs { # post-normalized abs for internal use
+ local($_) = @_;
+ s/^-/+/;
+ $_;
+}
+
+# Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
+sub main'bcmp { #(num_str, num_str) return cond_code
+ local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
+ if ($x eq 'NaN') {
+ undef;
+ } elsif ($y eq 'NaN') {
+ undef;
+ } else {
+ &cmp($x,$y);
+ }
+}
+
+sub cmp { # post-normalized compare for internal use
+ local($cx, $cy) = @_;
+ return 0 if ($cx eq $cy);
+
+ local($sx, $sy) = (substr($cx, 0, 1), substr($cy, 0, 1));
+ local($ld);
+
+ if ($sx eq '+') {
+ return 1 if ($sy eq '-' || $cy eq '+0');
+ $ld = length($cx) - length($cy);
+ return $ld if ($ld);
+ return $cx cmp $cy;
+ } else { # $sx eq '-'
+ return -1 if ($sy eq '+');
+ $ld = length($cy) - length($cx);
+ return $ld if ($ld);
+ return $cy cmp $cx;
+ }
+
+}
+
+sub main'badd { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } else {
+ @x = &internal($x); # convert to internal form
+ @y = &internal($y);
+ local($sx, $sy) = (shift @x, shift @y); # get signs
+ if ($sx eq $sy) {
+ &external($sx, &add(*x, *y)); # if same sign add
+ } else {
+ ($x, $y) = (&abs($x),&abs($y)); # make abs
+ if (&cmp($y,$x) > 0) {
+ &external($sy, &sub(*y, *x));
+ } else {
+ &external($sx, &sub(*x, *y));
+ }
+ }
+ }
+}
+
+sub main'bsub { #(num_str, num_str) return num_str
+ &'badd($_[$[],&'bneg($_[$[+1]));
+}
+
+# GCD -- Euclids algorithm Knuth Vol 2 pg 296
+sub main'bgcd { #(num_str, num_str) return num_str
+ local($x,$y) = (&'bnorm($_[$[]),&'bnorm($_[$[+1]));
+ if ($x eq 'NaN' || $y eq 'NaN') {
+ 'NaN';
+ } else {
+ ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0';
+ $x;
+ }
+}
+
+# routine to add two base 1e5 numbers
+# stolen from Knuth Vol 2 Algorithm A pg 231
+# there are separate routines to add and sub as per Kunth pg 233
+sub add { #(int_num_array, int_num_array) return int_num_array
+ local(*x, *y) = @_;
+ $car = 0;
+ for $x (@x) {
+ last unless @y || $car;
+ $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0;
+ }
+ for $y (@y) {
+ last unless $car;
+ $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0;
+ }
+ (@x, @y, $car);
+}
+
+# subtract base 1e5 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
+sub sub { #(int_num_array, int_num_array) return int_num_array
+ local(*sx, *sy) = @_;
+ $bar = 0;
+ for $sx (@sx) {
+ last unless @y || $bar;
+ $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0);
+ }
+ @sx;
+}
+
+# multiply two numbers -- stolen from Knuth Vol 2 pg 233
+sub main'bmul { #(num_str, num_str) return num_str
+ local(*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1]));
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($y eq 'NaN') {
+ 'NaN';
+ } else {
+ @x = &internal($x);
+ @y = &internal($y);
+ local($signr) = (shift @x ne shift @y) ? '-' : '+';
+ @prod = ();
+ for $x (@x) {
+ ($car, $cty) = (0, $[);
+ for $y (@y) {
+ $prod = $x * $y + $prod[$cty] + $car;
+ $prod[$cty++] =
+ $prod - ($car = int($prod * 1e-5)) * 1e5;
+ }
+ $prod[$cty] += $car if $car;
+ $x = shift @prod;
+ }
+ &external($signr, @x, @prod);
+ }
+}
+
+# modulus
+sub main'bmod { #(num_str, num_str) return num_str
+ (&'bdiv(@_))[$[+1];
+}
+
+sub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str
+ local (*x, *y); ($x, $y) = (&'bnorm($_[$[]), &'bnorm($_[$[+1]));
+ return wantarray ? ('NaN','NaN') : 'NaN'
+ if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
+ return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
+ @x = &internal($x); @y = &internal($y);
+ $srem = $y[$[];
+ $sr = (shift @x ne shift @y) ? '-' : '+';
+ $car = $bar = $prd = 0;
+ if (($dd = int(1e5/($y[$#y]+1))) != 1) {
+ for $x (@x) {
+ $x = $x * $dd + $car;
+ $x -= ($car = int($x * 1e-5)) * 1e5;
+ }
+ push(@x, $car); $car = 0;
+ for $y (@y) {
+ $y = $y * $dd + $car;
+ $y -= ($car = int($y * 1e-5)) * 1e5;
+ }
+ }
+ else {
+ push(@x, 0);
+ }
+ @q = (); ($v2,$v1) = @y[-2,-1];
+ while ($#x > $#y) {
+ ($u2,$u1,$u0) = @x[-3..-1];
+ $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1));
+ --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2);
+ if ($q) {
+ ($car, $bar) = (0,0);
+ for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
+ $prd = $q * $y[$y] + $car;
+ $prd -= ($car = int($prd * 1e-5)) * 1e5;
+ $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0));
+ }
+ if ($x[$#x] < $car + $bar) {
+ $car = 0; --$q;
+ for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
+ $x[$x] -= 1e5
+ if ($car = (($x[$x] += $y[$y] + $car) > 1e5));
+ }
+ }
+ }
+ pop(@x); unshift(@q, $q);
+ }
+ if (wantarray) {
+ @d = ();
+ if ($dd != 1) {
+ $car = 0;
+ for $x (reverse @x) {
+ $prd = $car * 1e5 + $x;
+ $car = $prd - ($tmp = int($prd / $dd)) * $dd;
+ unshift(@d, $tmp);
+ }
+ }
+ else {
+ @d = @x;
+ }
+ (&external($sr, @q), &external($srem, @d, $zero));
+ } else {
+ &external($sr, @q);
+ }
+}
+1;
diff --git a/contrib/perl5/lib/bigrat.pl b/contrib/perl5/lib/bigrat.pl
new file mode 100644
index 000000000000..fb436ce57081
--- /dev/null
+++ b/contrib/perl5/lib/bigrat.pl
@@ -0,0 +1,149 @@
+package bigrat;
+require "bigint.pl";
+
+# Arbitrary size rational math package
+#
+# by Mark Biggar
+#
+# Input values to these routines consist of strings of the form
+# m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|.
+# Examples:
+# "+0/1" canonical zero value
+# "3" canonical value "+3/1"
+# " -123/123 123" canonical value "-1/1001"
+# "123 456/7890" canonical value "+20576/1315"
+# Output values always include a sign and no leading zeros or
+# white space.
+# This package makes use of the bigint package.
+# The string 'NaN' is used to represent the result when input arguments
+# that are not numbers, as well as the result of dividing by zero and
+# the sqrt of a negative number.
+# Extreamly naive algorthims are used.
+#
+# Routines provided are:
+#
+# rneg(RAT) return RAT negation
+# rabs(RAT) return RAT absolute value
+# rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0)
+# radd(RAT,RAT) return RAT addition
+# rsub(RAT,RAT) return RAT subtraction
+# rmul(RAT,RAT) return RAT multiplication
+# rdiv(RAT,RAT) return RAT division
+# rmod(RAT) return (RAT,RAT) integer and fractional parts
+# rnorm(RAT) return RAT normalization
+# rsqrt(RAT, cycles) return RAT square root
+
+# Convert a number to the canonical string form m|^[+-]\d+/\d+|.
+sub main'rnorm { #(string) return rat_num
+ local($_) = @_;
+ s/\s+//g;
+ if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) {
+ &norm($1, $3 ? $3 : '+1');
+ } else {
+ 'NaN';
+ }
+}
+
+# Normalize by reducing to lowest terms
+sub norm { #(bint, bint) return rat_num
+ local($num,$dom) = @_;
+ if ($num eq 'NaN') {
+ 'NaN';
+ } elsif ($dom eq 'NaN') {
+ 'NaN';
+ } elsif ($dom =~ /^[+-]?0+$/) {
+ 'NaN';
+ } else {
+ local($gcd) = &'bgcd($num,$dom);
+ $gcd =~ s/^-/+/;
+ if ($gcd ne '+1') {
+ $num = &'bdiv($num,$gcd);
+ $dom = &'bdiv($dom,$gcd);
+ } else {
+ $num = &'bnorm($num);
+ $dom = &'bnorm($dom);
+ }
+ substr($dom,$[,1) = '';
+ "$num/$dom";
+ }
+}
+
+# negation
+sub main'rneg { #(rat_num) return rat_num
+ local($_) = &'rnorm(@_);
+ tr/-+/+-/ if ($_ ne '+0/1');
+ $_;
+}
+
+# absolute value
+sub main'rabs { #(rat_num) return $rat_num
+ local($_) = &'rnorm(@_);
+ substr($_,$[,1) = '+' unless $_ eq 'NaN';
+ $_;
+}
+
+# multipication
+sub main'rmul { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
+ &norm(&'bmul($xn,$yn),&'bmul($xd,$yd));
+}
+
+# division
+sub main'rdiv { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
+ &norm(&'bmul($xn,$yd),&'bmul($xd,$yn));
+}
+
+# addition
+sub main'radd { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
+ &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
+}
+
+# subtraction
+sub main'rsub { #(rat_num, rat_num) return rat_num
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
+ &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
+}
+
+# comparison
+sub main'rcmp { #(rat_num, rat_num) return cond_code
+ local($xn,$xd) = split('/',&'rnorm($_[$[]));
+ local($yn,$yd) = split('/',&'rnorm($_[$[+1]));
+ &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd));
+}
+
+# int and frac parts
+sub main'rmod { #(rat_num) return (rat_num,rat_num)
+ local($xn,$xd) = split('/',&'rnorm(@_));
+ local($i,$f) = &'bdiv($xn,$xd);
+ if (wantarray) {
+ ("$i/1", "$f/$xd");
+ } else {
+ "$i/1";
+ }
+}
+
+# square root by Newtons method.
+# cycles specifies the number of iterations default: 5
+sub main'rsqrt { #(fnum_str[, cycles]) return fnum_str
+ local($x, $scale) = (&'rnorm($_[$[]), $_[$[+1]);
+ if ($x eq 'NaN') {
+ 'NaN';
+ } elsif ($x =~ /^-/) {
+ 'NaN';
+ } else {
+ local($gscale, $guess) = (0, '+1/1');
+ $scale = 5 if (!$scale);
+ while ($gscale++ < $scale) {
+ $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2");
+ }
+ "$guess"; # quotes necessary due to perl bug
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/blib.pm b/contrib/perl5/lib/blib.pm
new file mode 100644
index 000000000000..1d56a58174e3
--- /dev/null
+++ b/contrib/perl5/lib/blib.pm
@@ -0,0 +1,72 @@
+package blib;
+
+=head1 NAME
+
+blib - Use MakeMaker's uninstalled version of a package
+
+=head1 SYNOPSIS
+
+ perl -Mblib script [args...]
+
+ perl -Mblib=dir script [args...]
+
+=head1 DESCRIPTION
+
+Looks for MakeMaker-like I<'blib'> directory structure starting in
+I<dir> (or current directory) and working back up to five levels of '..'.
+
+Intended for use on command line with B<-M> option as a way of testing
+arbitary scripts against an uninstalled version of a package.
+
+However it is possible to :
+
+ use blib;
+ or
+ use blib '..';
+
+etc. if you really must.
+
+=head1 BUGS
+
+Pollutes global name space for development only task.
+
+=head1 AUTHOR
+
+Nick Ing-Simmons nik@tiuk.ti.com
+
+=cut
+
+use Cwd;
+
+use vars qw($VERSION);
+$VERSION = '1.00';
+
+sub import
+{
+ my $package = shift;
+ my $dir = getcwd;
+ if ($^O eq 'VMS') { ($dir = VMS::Filespec::unixify($dir)) =~ s-/$--; }
+ if (@_)
+ {
+ $dir = shift;
+ $dir =~ s/blib$//;
+ $dir =~ s,/+$,,;
+ $dir = '.' unless ($dir);
+ die "$dir is not a directory\n" unless (-d $dir);
+ }
+ my $i = 5;
+ while ($i--)
+ {
+ my $blib = "${dir}/blib";
+ if (-d $blib && -d "$blib/arch" && -d "$blib/lib")
+ {
+ unshift(@INC,"$blib/arch","$blib/lib");
+ warn "Using $blib\n";
+ return;
+ }
+ $dir .= "/..";
+ }
+ die "Cannot find blib even in $dir\n";
+}
+
+1;
diff --git a/contrib/perl5/lib/cacheout.pl b/contrib/perl5/lib/cacheout.pl
new file mode 100644
index 000000000000..64378cffc6f0
--- /dev/null
+++ b/contrib/perl5/lib/cacheout.pl
@@ -0,0 +1,46 @@
+# Open in their package.
+
+sub cacheout'open {
+ open($_[0], $_[1]);
+}
+
+# Close as well
+
+sub cacheout'close {
+ close($_[0]);
+}
+
+# But only this sub name is visible to them.
+
+sub cacheout {
+ package cacheout;
+
+ ($file) = @_;
+ if (!$isopen{$file}) {
+ if (++$numopen > $maxopen) {
+ local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
+ splice(@lru, $maxopen / 3);
+ $numopen -= @lru;
+ for (@lru) { &close($_); delete $isopen{$_}; }
+ }
+ &open($file, ($saw{$file}++ ? '>>' : '>') . $file)
+ || die "Can't create $file: $!\n";
+ }
+ $isopen{$file} = ++$seq;
+}
+
+package cacheout;
+
+$seq = 0;
+$numopen = 0;
+
+if (open(PARAM,'/usr/include/sys/param.h')) {
+ local($_, $.);
+ while (<PARAM>) {
+ $maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
+ }
+ close PARAM;
+}
+$maxopen = 16 unless $maxopen;
+
+1;
diff --git a/contrib/perl5/lib/chat2.pl b/contrib/perl5/lib/chat2.pl
new file mode 100644
index 000000000000..094d3dff21ab
--- /dev/null
+++ b/contrib/perl5/lib/chat2.pl
@@ -0,0 +1,370 @@
+# chat.pl: chat with a server
+# Based on: V2.01.alpha.7 91/06/16
+# Randal L. Schwartz (was <merlyn@stonehenge.com>)
+# multihome additions by A.Macpherson@bnr.co.uk
+# allow for /dev/pts based systems by Joe Doupnik <JRD@CC.USU.EDU>
+
+package chat;
+
+require 'sys/socket.ph';
+
+if( defined( &main'PF_INET ) ){
+ $pf_inet = &main'PF_INET;
+ $sock_stream = &main'SOCK_STREAM;
+ local($name, $aliases, $proto) = getprotobyname( 'tcp' );
+ $tcp_proto = $proto;
+}
+else {
+ # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
+ # but who the heck would change these anyway? (:-)
+ $pf_inet = 2;
+ $sock_stream = 1;
+ $tcp_proto = 6;
+}
+
+
+$sockaddr = 'S n a4 x8';
+chop($thishost = `hostname`);
+
+# *S = symbol for current I/O, gets assigned *chatsymbol....
+$next = "chatsymbol000000"; # next one
+$nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
+
+
+## $handle = &chat'open_port("server.address",$port_number);
+## opens a named or numbered TCP server
+
+sub open_port { ## public
+ local($server, $port) = @_;
+
+ local($serveraddr,$serverproc);
+
+ # We may be multi-homed, start with 0, fixup once connexion is made
+ $thisaddr = "\0\0\0\0" ;
+ $thisproc = pack($sockaddr, 2, 0, $thisaddr);
+
+ *S = ++$next;
+ if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
+ $serveraddr = pack('C4', $1, $2, $3, $4);
+ } else {
+ local(@x) = gethostbyname($server);
+ return undef unless @x;
+ $serveraddr = $x[4];
+ }
+ $serverproc = pack($sockaddr, 2, $port, $serveraddr);
+ unless (socket(S, $pf_inet, $sock_stream, $tcp_proto)) {
+ ($!) = ($!, close(S)); # close S while saving $!
+ return undef;
+ }
+ unless (bind(S, $thisproc)) {
+ ($!) = ($!, close(S)); # close S while saving $!
+ return undef;
+ }
+ unless (connect(S, $serverproc)) {
+ ($!) = ($!, close(S)); # close S while saving $!
+ return undef;
+ }
+# We opened with the local address set to ANY, at this stage we know
+# which interface we are using. This is critical if our machine is
+# multi-homed, with IP forwarding off, so fix-up.
+ local($fam,$lport);
+ ($fam,$lport,$thisaddr) = unpack($sockaddr, getsockname(S));
+ $thisproc = pack($sockaddr, 2, 0, $thisaddr);
+# end of post-connect fixup
+ select((select(S), $| = 1)[0]);
+ $next; # return symbol for switcharound
+}
+
+## ($host, $port, $handle) = &chat'open_listen([$port_number]);
+## opens a TCP port on the current machine, ready to be listened to
+## if $port_number is absent or zero, pick a default port number
+## process must be uid 0 to listen to a low port number
+
+sub open_listen { ## public
+
+ *S = ++$next;
+ local($thisport) = shift || 0;
+ local($thisproc_local) = pack($sockaddr, 2, $thisport, $thisaddr);
+ local(*NS) = "__" . time;
+ unless (socket(NS, $pf_inet, $sock_stream, $tcp_proto)) {
+ ($!) = ($!, close(NS));
+ return undef;
+ }
+ unless (bind(NS, $thisproc_local)) {
+ ($!) = ($!, close(NS));
+ return undef;
+ }
+ unless (listen(NS, 1)) {
+ ($!) = ($!, close(NS));
+ return undef;
+ }
+ select((select(NS), $| = 1)[0]);
+ local($family, $port, @myaddr) =
+ unpack("S n C C C C x8", getsockname(NS));
+ $S{"needs_accept"} = *NS; # so expect will open it
+ (@myaddr, $port, $next); # returning this
+}
+
+## $handle = &chat'open_proc("command","arg1","arg2",...);
+## opens a /bin/sh on a pseudo-tty
+
+sub open_proc { ## public
+ local(@cmd) = @_;
+
+ *S = ++$next;
+ local(*TTY) = "__TTY" . time;
+ local($pty,$tty) = &_getpty(S,TTY);
+ die "Cannot find a new pty" unless defined $pty;
+ $pid = fork;
+ die "Cannot fork: $!" unless defined $pid;
+ unless ($pid) {
+ close STDIN; close STDOUT; close STDERR;
+ setpgrp(0,$$);
+ if (open(DEVTTY, "/dev/tty")) {
+ ioctl(DEVTTY,0x20007471,0); # XXX s/b &TIOCNOTTY
+ close DEVTTY;
+ }
+ open(STDIN,"<&TTY");
+ open(STDOUT,">&TTY");
+ open(STDERR,">&STDOUT");
+ die "Oops" unless fileno(STDERR) == 2; # sanity
+ close(S);
+ exec @cmd;
+ die "Cannot exec @cmd: $!";
+ }
+ close(TTY);
+ $next; # return symbol for switcharound
+}
+
+# $S is the read-ahead buffer
+
+## $return = &chat'expect([$handle,] $timeout_time,
+## $pat1, $body1, $pat2, $body2, ... )
+## $handle is from previous &chat'open_*().
+## $timeout_time is the time (either relative to the current time, or
+## absolute, ala time(2)) at which a timeout event occurs.
+## $pat1, $pat2, and so on are regexs which are matched against the input
+## stream. If a match is found, the entire matched string is consumed,
+## and the corresponding body eval string is evaled.
+##
+## Each pat is a regular-expression (probably enclosed in single-quotes
+## in the invocation). ^ and $ will work, respecting the current value of $*.
+## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
+## If pat is 'EOF', the body is executed if the process exits before
+## the other patterns are seen.
+##
+## Pats are scanned in the order given, so later pats can contain
+## general defaults that won't be examined unless the earlier pats
+## have failed.
+##
+## The result of eval'ing body is returned as the result of
+## the invocation. Recursive invocations are not thought
+## through, and may work only accidentally. :-)
+##
+## undef is returned if either a timeout or an eof occurs and no
+## corresponding body has been defined.
+## I/O errors of any sort are treated as eof.
+
+$nextsubname = "expectloop000000"; # used for subroutines
+
+sub expect { ## public
+ if ($_[0] =~ /$nextpat/) {
+ *S = shift;
+ }
+ local($endtime) = shift;
+
+ local($timeout,$eof) = (1,1);
+ local($caller) = caller;
+ local($rmask, $nfound, $timeleft, $thisbuf);
+ local($cases, $pattern, $action, $subname);
+ $endtime += time if $endtime < 600_000_000;
+
+ if (defined $S{"needs_accept"}) { # is it a listen socket?
+ local(*NS) = $S{"needs_accept"};
+ delete $S{"needs_accept"};
+ $S{"needs_close"} = *NS;
+ unless(accept(S,NS)) {
+ ($!) = ($!, close(S), close(NS));
+ return undef;
+ }
+ select((select(S), $| = 1)[0]);
+ }
+
+ # now see whether we need to create a new sub:
+
+ unless ($subname = $expect_subname{$caller,@_}) {
+ # nope. make a new one:
+ $expect_subname{$caller,@_} = $subname = $nextsubname++;
+
+ $cases .= <<"EDQ"; # header is funny to make everything elsif's
+sub $subname {
+ LOOP: {
+ if (0) { ; }
+EDQ
+ while (@_) {
+ ($pattern,$action) = splice(@_,0,2);
+ if ($pattern =~ /^eof$/i) {
+ $cases .= <<"EDQ";
+ elsif (\$eof) {
+ package $caller;
+ $action;
+ }
+EDQ
+ $eof = 0;
+ } elsif ($pattern =~ /^timeout$/i) {
+ $cases .= <<"EDQ";
+ elsif (\$timeout) {
+ package $caller;
+ $action;
+ }
+EDQ
+ $timeout = 0;
+ } else {
+ $pattern =~ s#/#\\/#g;
+ $cases .= <<"EDQ";
+ elsif (\$S =~ /$pattern/) {
+ \$S = \$';
+ package $caller;
+ $action;
+ }
+EDQ
+ }
+ }
+ $cases .= <<"EDQ" if $eof;
+ elsif (\$eof) {
+ undef;
+ }
+EDQ
+ $cases .= <<"EDQ" if $timeout;
+ elsif (\$timeout) {
+ undef;
+ }
+EDQ
+ $cases .= <<'ESQ';
+ else {
+ $rmask = "";
+ vec($rmask,fileno(S),1) = 1;
+ ($nfound, $rmask) =
+ select($rmask, undef, undef, $endtime - time);
+ if ($nfound) {
+ $nread = sysread(S, $thisbuf, 1024);
+ if ($nread > 0) {
+ $S .= $thisbuf;
+ } else {
+ $eof++, redo LOOP; # any error is also eof
+ }
+ } else {
+ $timeout++, redo LOOP; # timeout
+ }
+ redo LOOP;
+ }
+ }
+}
+ESQ
+ eval $cases; die "$cases:\n$@" if $@;
+ }
+ $eof = $timeout = 0;
+ do $subname();
+}
+
+## &chat'print([$handle,] @data)
+## $handle is from previous &chat'open().
+## like print $handle @data
+
+sub print { ## public
+ if ($_[0] =~ /$nextpat/) {
+ *S = shift;
+ }
+
+ local $out = join $, , @_;
+ syswrite(S, $out, length $out);
+ if( $chat'debug ){
+ print STDERR "printed:";
+ print STDERR @_;
+ }
+}
+
+## &chat'close([$handle,])
+## $handle is from previous &chat'open().
+## like close $handle
+
+sub close { ## public
+ if ($_[0] =~ /$nextpat/) {
+ *S = shift;
+ }
+ close(S);
+ if (defined $S{"needs_close"}) { # is it a listen socket?
+ local(*NS) = $S{"needs_close"};
+ delete $S{"needs_close"};
+ close(NS);
+ }
+}
+
+## @ready_handles = &chat'select($timeout, @handles)
+## select()'s the handles with a timeout value of $timeout seconds.
+## Returns an array of handles that are ready for I/O.
+## Both user handles and chat handles are supported (but beware of
+## stdio's buffering for user handles).
+
+sub select { ## public
+ local($timeout) = shift;
+ local(@handles) = @_;
+ local(%handlename) = ();
+ local(%ready) = ();
+ local($caller) = caller;
+ local($rmask) = "";
+ for (@handles) {
+ if (/$nextpat/o) { # one of ours... see if ready
+ local(*SYM) = $_;
+ if (length($SYM)) {
+ $timeout = 0; # we have a winner
+ $ready{$_}++;
+ }
+ $handlename{fileno($_)} = $_;
+ } else {
+ $handlename{fileno(/'/ ? $_ : "$caller\'$_")} = $_;
+ }
+ }
+ for (sort keys %handlename) {
+ vec($rmask, $_, 1) = 1;
+ }
+ select($rmask, undef, undef, $timeout);
+ for (sort keys %handlename) {
+ $ready{$handlename{$_}}++ if vec($rmask,$_,1);
+ }
+ sort keys %ready;
+}
+
+# ($pty,$tty) = $chat'_getpty(PTY,TTY):
+# internal procedure to get the next available pty.
+# opens pty on handle PTY, and matching tty on handle TTY.
+# returns undef if can't find a pty.
+# Modify "/dev/pty" to "/dev/pts" for Dell Unix v2.2 (aka SVR4.04). Joe Doupnik.
+
+sub _getpty { ## private
+ local($_PTY,$_TTY) = @_;
+ $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
+ $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
+ local($pty, $tty, $kind);
+ if( -e "/dev/pts000" ){ ## mods by Joe Doupnik Dec 1992
+ $kind = "pts"; ## SVR4 Streams
+ } else {
+ $kind = "pty"; ## BSD Clist stuff
+ }
+ for $bank (112..127) {
+ next unless -e sprintf("/dev/$kind%c0", $bank);
+ for $unit (48..57) {
+ $pty = sprintf("/dev/$kind%c%c", $bank, $unit);
+ open($_PTY,"+>$pty") || next;
+ select((select($_PTY), $| = 1)[0]);
+ ($tty = $pty) =~ s/pty/tty/;
+ open($_TTY,"+>$tty") || next;
+ select((select($_TTY), $| = 1)[0]);
+ system "stty nl>$tty";
+ return ($pty,$tty);
+ }
+ }
+ undef;
+}
+
+1;
diff --git a/contrib/perl5/lib/complete.pl b/contrib/perl5/lib/complete.pl
new file mode 100644
index 000000000000..539f2f779839
--- /dev/null
+++ b/contrib/perl5/lib/complete.pl
@@ -0,0 +1,111 @@
+;#
+;# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91
+;#
+;# Author: Wayne Thompson
+;#
+;# Description:
+;# This routine provides word completion.
+;# (TAB) attempts word completion.
+;# (^D) prints completion list.
+;# (These may be changed by setting $Complete'complete, etc.)
+;#
+;# Diagnostics:
+;# Bell when word completion fails.
+;#
+;# Dependencies:
+;# The tty driver is put into raw mode.
+;#
+;# Bugs:
+;#
+;# Usage:
+;# $input = &Complete('prompt_string', *completion_list);
+;# or
+;# $input = &Complete('prompt_string', @completion_list);
+;#
+
+CONFIG: {
+ package Complete;
+
+ $complete = "\004";
+ $kill = "\025";
+ $erase1 = "\177";
+ $erase2 = "\010";
+}
+
+sub Complete {
+ package Complete;
+
+ local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
+ if ($_[1] =~ /^StB\0/) {
+ ($prompt, *_) = @_;
+ }
+ else {
+ $prompt = shift(@_);
+ }
+ @cmp_lst = sort(@_);
+
+ system('stty raw -echo');
+ LOOP: {
+ print($prompt, $return);
+ while (($_ = getc(STDIN)) ne "\r") {
+ CASE: {
+ # (TAB) attempt completion
+ $_ eq "\t" && do {
+ @match = grep(/^$return/, @cmp_lst);
+ $l = length($test = shift(@match));
+ unless ($#match < 0) {
+ foreach $cmp (@match) {
+ until (substr($cmp, 0, $l) eq substr($test, 0, $l)) {
+ $l--;
+ }
+ }
+ print("\a");
+ }
+ print($test = substr($test, $r, $l - $r));
+ $r = length($return .= $test);
+ last CASE;
+ };
+
+ # (^D) completion list
+ $_ eq $complete && do {
+ print(join("\r\n", '', grep(/^$return/, @cmp_lst)), "\r\n");
+ redo LOOP;
+ };
+
+ # (^U) kill
+ $_ eq $kill && do {
+ if ($r) {
+ undef $r;
+ undef $return;
+ print("\r\n");
+ redo LOOP;
+ }
+ last CASE;
+ };
+
+ # (DEL) || (BS) erase
+ ($_ eq $erase1 || $_ eq $erase2) && do {
+ if($r) {
+ print("\b \b");
+ chop($return);
+ $r--;
+ }
+ last CASE;
+ };
+
+ # printable char
+ ord >= 32 && do {
+ $return .= $_;
+ $r++;
+ print;
+ last CASE;
+ };
+ }
+ }
+ }
+ system('stty -raw echo');
+ print("\n");
+ $return;
+}
+
+1;
diff --git a/contrib/perl5/lib/constant.pm b/contrib/perl5/lib/constant.pm
new file mode 100644
index 000000000000..464e20cd91d0
--- /dev/null
+++ b/contrib/perl5/lib/constant.pm
@@ -0,0 +1,172 @@
+package constant;
+
+$VERSION = '1.00';
+
+=head1 NAME
+
+constant - Perl pragma to declare constants
+
+=head1 SYNOPSIS
+
+ use constant BUFFER_SIZE => 4096;
+ use constant ONE_YEAR => 365.2425 * 24 * 60 * 60;
+ use constant PI => 4 * atan2 1, 1;
+ use constant DEBUGGING => 0;
+ use constant ORACLE => 'oracle@cs.indiana.edu';
+ use constant USERNAME => scalar getpwuid($<);
+ use constant USERINFO => getpwuid($<);
+
+ sub deg2rad { PI * $_[0] / 180 }
+
+ print "This line does nothing" unless DEBUGGING;
+
+=head1 DESCRIPTION
+
+This will declare a symbol to be a constant with the given scalar
+or list value.
+
+When you declare a constant such as C<PI> using the method shown
+above, each machine your script runs upon can have as many digits
+of accuracy as it can use. Also, your program will be easier to
+read, more likely to be maintained (and maintained correctly), and
+far less likely to send a space probe to the wrong planet because
+nobody noticed the one equation in which you wrote C<3.14195>.
+
+=head1 NOTES
+
+The value or values are evaluated in a list context. You may override
+this with C<scalar> as shown above.
+
+These constants do not directly interpolate into double-quotish
+strings, although you may do so indirectly. (See L<perlref> for
+details about how this works.)
+
+ print "The value of PI is @{[ PI ]}.\n";
+
+List constants are returned as lists, not as arrays.
+
+ $homedir = USERINFO[7]; # WRONG
+ $homedir = (USERINFO)[7]; # Right
+
+The use of all caps for constant names is merely a convention,
+although it is recommended in order to make constants stand out
+and to help avoid collisions with other barewords, keywords, and
+subroutine names. Constant names must begin with a letter.
+
+Constant symbols are package scoped (rather than block scoped, as
+C<use strict> is). That is, you can refer to a constant from package
+Other as C<Other::CONST>.
+
+As with all C<use> directives, defining a constant happens at
+compile time. Thus, it's probably not correct to put a constant
+declaration inside of a conditional statement (like C<if ($foo)
+{ use constant ... }>).
+
+Omitting the value for a symbol gives it the value of C<undef> in
+a scalar context or the empty list, C<()>, in a list context. This
+isn't so nice as it may sound, though, because in this case you
+must either quote the symbol name, or use a big arrow, (C<=E<gt>>),
+with nothing to point to. It is probably best to declare these
+explicitly.
+
+ use constant UNICORNS => ();
+ use constant LOGFILE => undef;
+
+The result from evaluating a list constant in a scalar context is
+not documented, and is B<not> guaranteed to be any particular value
+in the future. In particular, you should not rely upon it being
+the number of elements in the list, especially since it is not
+B<necessarily> that value in the current implementation.
+
+Magical values, tied values, and references can be made into
+constants at compile time, allowing for way cool stuff like this.
+(These error numbers aren't totally portable, alas.)
+
+ use constant E2BIG => ($! = 7);
+ print E2BIG, "\n"; # something like "Arg list too long"
+ print 0+E2BIG, "\n"; # "7"
+
+=head1 TECHNICAL NOTE
+
+In the current implementation, scalar constants are actually
+inlinable subroutines. As of version 5.004 of Perl, the appropriate
+scalar constant is inserted directly in place of some subroutine
+calls, thereby saving the overhead of a subroutine call. See
+L<perlsub/"Constant Functions"> for details about how and when this
+happens.
+
+=head1 BUGS
+
+In the current version of Perl, list constants are not inlined
+and some symbols may be redefined without generating a warning.
+
+It is not possible to have a subroutine or keyword with the same
+name as a constant. This is probably a Good Thing.
+
+Unlike constants in some languages, these cannot be overridden
+on the command line or via environment variables.
+
+You can get into trouble if you use constants in a context which
+automatically quotes barewords (as is true for any subroutine call).
+For example, you can't say C<$hash{CONSTANT}> because C<CONSTANT> will
+be interpreted as a string. Use C<$hash{CONSTANT()}> or
+C<$hash{+CONSTANT}> to prevent the bareword quoting mechanism from
+kicking in. Similarly, since the C<=E<gt>> operator quotes a bareword
+immediately to its left you have to say C<CONSTANT() =E<gt> 'value'>
+instead of C<CONSTANT =E<gt> 'value'>.
+
+=head1 AUTHOR
+
+Tom Phoenix, E<lt>F<rootbeer@teleport.com>E<gt>, with help from
+many other folks.
+
+=head1 COPYRIGHT
+
+Copyright (C) 1997, Tom Phoenix
+
+This module is free software; you can redistribute it or modify it
+under the same terms as Perl itself.
+
+=cut
+
+use strict;
+use Carp;
+use vars qw($VERSION);
+
+#=======================================================================
+
+# Some of this stuff didn't work in version 5.003, alas.
+require 5.003_96;
+
+#=======================================================================
+# import() - import symbols into user's namespace
+#
+# What we actually do is define a function in the caller's namespace
+# which returns the value. The function we create will normally
+# be inlined as a constant, thereby avoiding further sub calling
+# overhead.
+#=======================================================================
+sub import {
+ my $class = shift;
+ my $name = shift or return; # Ignore 'use constant;'
+ croak qq{Can't define "$name" as constant} .
+ qq{ (name contains invalid characters or is empty)}
+ unless $name =~ /^[^\W_0-9]\w*$/;
+
+ my $pkg = caller;
+ {
+ no strict 'refs';
+ if (@_ == 1) {
+ my $scalar = $_[0];
+ *{"${pkg}::$name"} = sub () { $scalar };
+ } elsif (@_) {
+ my @list = @_;
+ *{"${pkg}::$name"} = sub () { @list };
+ } else {
+ *{"${pkg}::$name"} = sub () { };
+ }
+ }
+
+}
+
+1;
diff --git a/contrib/perl5/lib/ctime.pl b/contrib/perl5/lib/ctime.pl
new file mode 100644
index 000000000000..14e122adda0b
--- /dev/null
+++ b/contrib/perl5/lib/ctime.pl
@@ -0,0 +1,51 @@
+;# ctime.pl is a simple Perl emulation for the well known ctime(3C) function.
+;#
+;# Waldemar Kebsch, Federal Republic of Germany, November 1988
+;# kebsch.pad@nixpbe.UUCP
+;# Modified March 1990, Feb 1991 to properly handle timezones
+;# $RCSfile: ctime.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:47 $
+;# Marion Hakanson (hakanson@cse.ogi.edu)
+;# Oregon Graduate Institute of Science and Technology
+;#
+;# usage:
+;#
+;# #include <ctime.pl> # see the -P and -I option in perl.man
+;# $Date = &ctime(time);
+
+CONFIG: {
+ package ctime;
+
+ @DoW = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
+ @MoY = ('Jan','Feb','Mar','Apr','May','Jun',
+ 'Jul','Aug','Sep','Oct','Nov','Dec');
+}
+
+sub ctime {
+ package ctime;
+
+ local($time) = @_;
+ local($[) = 0;
+ local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
+
+ # Determine what time zone is in effect.
+ # Use GMT if TZ is defined as null, local time if TZ undefined.
+ # There's no portable way to find the system default timezone.
+
+ $TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : '';
+ ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
+ ($TZ eq 'GMT') ? gmtime($time) : localtime($time);
+
+ # Hack to deal with 'PST8PDT' format of TZ
+ # Note that this can't deal with all the esoteric forms, but it
+ # does recognize the most common: [:]STDoff[DST[off][,rule]]
+
+ if($TZ=~/^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/){
+ $TZ = $isdst ? $4 : $1;
+ }
+ $TZ .= ' ' unless $TZ eq '';
+
+ $year += 1900;
+ sprintf("%s %s %2d %2d:%02d:%02d %s%4d\n",
+ $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZ, $year);
+}
+1;
diff --git a/contrib/perl5/lib/diagnostics.pm b/contrib/perl5/lib/diagnostics.pm
new file mode 100755
index 000000000000..78bf4457cba9
--- /dev/null
+++ b/contrib/perl5/lib/diagnostics.pm
@@ -0,0 +1,533 @@
+package diagnostics;
+
+=head1 NAME
+
+diagnostics - Perl compiler pragma to force verbose warning diagnostics
+
+splain - standalone program to do the same thing
+
+=head1 SYNOPSIS
+
+As a pragma:
+
+ use diagnostics;
+ use diagnostics -verbose;
+
+ enable diagnostics;
+ disable diagnostics;
+
+Aa a program:
+
+ perl program 2>diag.out
+ splain [-v] [-p] diag.out
+
+
+=head1 DESCRIPTION
+
+=head2 The C<diagnostics> Pragma
+
+This module extends the terse diagnostics normally emitted by both the
+perl compiler and the perl interpeter, augmenting them with the more
+explicative and endearing descriptions found in L<perldiag>. Like the
+other pragmata, it affects the compilation phase of your program rather
+than merely the execution phase.
+
+To use in your program as a pragma, merely invoke
+
+ use diagnostics;
+
+at the start (or near the start) of your program. (Note
+that this I<does> enable perl's B<-w> flag.) Your whole
+compilation will then be subject(ed :-) to the enhanced diagnostics.
+These still go out B<STDERR>.
+
+Due to the interaction between runtime and compiletime issues,
+and because it's probably not a very good idea anyway,
+you may not use C<no diagnostics> to turn them off at compiletime.
+However, you may control there behaviour at runtime using the
+disable() and enable() methods to turn them off and on respectively.
+
+The B<-verbose> flag first prints out the L<perldiag> introduction before
+any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
+escape sequences for pagers.
+
+=head2 The I<splain> Program
+
+While apparently a whole nuther program, I<splain> is actually nothing
+more than a link to the (executable) F<diagnostics.pm> module, as well as
+a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
+the C<use diagnostics -verbose> directive.
+The B<-p> flag is like the
+$diagnostics::PRETTY variable. Since you're post-processing with
+I<splain>, there's no sense in being able to enable() or disable() processing.
+
+Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
+
+=head1 EXAMPLES
+
+The following file is certain to trigger a few errors at both
+runtime and compiletime:
+
+ use diagnostics;
+ print NOWHERE "nothing\n";
+ print STDERR "\n\tThis message should be unadorned.\n";
+ warn "\tThis is a user warning";
+ print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
+ my $a, $b = scalar <STDIN>;
+ print "\n";
+ print $x/$y;
+
+If you prefer to run your program first and look at its problem
+afterwards, do this:
+
+ perl -w test.pl 2>test.out
+ ./splain < test.out
+
+Note that this is not in general possible in shells of more dubious heritage,
+as the theoretical
+
+ (perl -w test.pl >/dev/tty) >& test.out
+ ./splain < test.out
+
+Because you just moved the existing B<stdout> to somewhere else.
+
+If you don't want to modify your source code, but still have on-the-fly
+warnings, do this:
+
+ exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
+
+Nifty, eh?
+
+If you want to control warnings on the fly, do something like this.
+Make sure you do the C<use> first, or you won't be able to get
+at the enable() or disable() methods.
+
+ use diagnostics; # checks entire compilation phase
+ print "\ntime for 1st bogus diags: SQUAWKINGS\n";
+ print BOGUS1 'nada';
+ print "done with 1st bogus\n";
+
+ disable diagnostics; # only turns off runtime warnings
+ print "\ntime for 2nd bogus: (squelched)\n";
+ print BOGUS2 'nada';
+ print "done with 2nd bogus\n";
+
+ enable diagnostics; # turns back on runtime warnings
+ print "\ntime for 3rd bogus: SQUAWKINGS\n";
+ print BOGUS3 'nada';
+ print "done with 3rd bogus\n";
+
+ disable diagnostics;
+ print "\ntime for 4th bogus: (squelched)\n";
+ print BOGUS4 'nada';
+ print "done with 4th bogus\n";
+
+=head1 INTERNALS
+
+Diagnostic messages derive from the F<perldiag.pod> file when available at
+runtime. Otherwise, they may be embedded in the file itself when the
+splain package is built. See the F<Makefile> for details.
+
+If an extant $SIG{__WARN__} handler is discovered, it will continue
+to be honored, but only after the diagnostics::splainthis() function
+(the module's $SIG{__WARN__} interceptor) has had its way with your
+warnings.
+
+There is a $diagnostics::DEBUG variable you may set if you're desperately
+curious what sorts of things are being intercepted.
+
+ BEGIN { $diagnostics::DEBUG = 1 }
+
+
+=head1 BUGS
+
+Not being able to say "no diagnostics" is annoying, but may not be
+insurmountable.
+
+The C<-pretty> directive is called too late to affect matters.
+You have to do this instead, and I<before> you load the module.
+
+ BEGIN { $diagnostics::PRETTY = 1 }
+
+I could start up faster by delaying compilation until it should be
+needed, but this gets a "panic: top_level" when using the pragma form
+in Perl 5.001e.
+
+While it's true that this documentation is somewhat subserious, if you use
+a program named I<splain>, you should expect a bit of whimsy.
+
+=head1 AUTHOR
+
+Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
+
+=cut
+
+require 5.001;
+use Carp;
+
+use Config;
+($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
+if ($^O eq 'VMS') {
+ require VMS::Filespec;
+ $privlib = VMS::Filespec::unixify($privlib);
+ $archlib = VMS::Filespec::unixify($archlib);
+}
+@trypod = ("$archlib/pod/perldiag.pod",
+ "$privlib/pod/perldiag-$].pod",
+ "$privlib/pod/perldiag.pod");
+# handy for development testing of new warnings etc
+unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
+($PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
+
+$DEBUG ||= 0;
+my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
+
+$| = 1;
+
+local $_;
+
+CONFIG: {
+ $opt_p = $opt_d = $opt_v = $opt_f = '';
+ %HTML_2_Troff = %HTML_2_Latin_1 = %HTML_2_ASCII_7 = ();
+ %exact_duplicate = ();
+
+ unless (caller) {
+ $standalone++;
+ require Getopt::Std;
+ Getopt::Std::getopts('pdvf:')
+ or die "Usage: $0 [-v] [-p] [-f splainpod]";
+ $PODFILE = $opt_f if $opt_f;
+ $DEBUG = 2 if $opt_d;
+ $VERBOSE = $opt_v;
+ $PRETTY = $opt_p;
+ }
+
+ if (open(POD_DIAG, $PODFILE)) {
+ warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
+ last CONFIG;
+ }
+
+ if (caller) {
+ INCPATH: {
+ for $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
+ warn "Checking $file\n" if $DEBUG;
+ if (open(POD_DIAG, $file)) {
+ while (<POD_DIAG>) {
+ next unless /^__END__\s*# wish diag dbase were more accessible/;
+ print STDERR "podfile is $file\n" if $DEBUG;
+ last INCPATH;
+ }
+ }
+ }
+ }
+ } else {
+ print STDERR "podfile is <DATA>\n" if $DEBUG;
+ *POD_DIAG = *main::DATA;
+ }
+}
+if (eof(POD_DIAG)) {
+ die "couldn't find diagnostic data in $PODFILE @INC $0";
+}
+
+
+%HTML_2_Troff = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "A\\*'", # capital A, acute accent
+ # etc
+
+);
+
+%HTML_2_Latin_1 = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "\xC1" # capital A, acute accent
+
+ # etc
+);
+
+%HTML_2_ASCII_7 = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "A" # capital A, acute accent
+ # etc
+);
+
+*HTML_Escapes = do {
+ if ($standalone) {
+ $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
+ } else {
+ \%HTML_2_Latin_1;
+ }
+};
+
+*THITHER = $standalone ? *STDOUT : *STDERR;
+
+$transmo = <<EOFUNC;
+sub transmo {
+ local \$^W = 0; # recursive warnings we do NOT need!
+ study;
+EOFUNC
+
+### sub finish_compilation { # 5.001e panic: top_level for embedded version
+ print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
+ ### local
+ $RS = '';
+ local $_;
+ while (<POD_DIAG>) {
+ #s/(.*)\n//;
+ #$header = $1;
+
+ unescape();
+ if ($PRETTY) {
+ sub noop { return $_[0] } # spensive for a noop
+ sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
+ sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
+ s/[BC]<(.*?)>/bold($1)/ges;
+ s/[LIF]<(.*?)>/italic($1)/ges;
+ } else {
+ s/[BC]<(.*?)>/$1/gs;
+ s/[LIF]<(.*?)>/$1/gs;
+ }
+ unless (/^=/) {
+ if (defined $header) {
+ if ( $header eq 'DESCRIPTION' &&
+ ( /Optional warnings are enabled/
+ || /Some of these messages are generic./
+ ) )
+ {
+ next;
+ }
+ s/^/ /gm;
+ $msg{$header} .= $_;
+ }
+ next;
+ }
+ unless ( s/=item (.*)\s*\Z//) {
+
+ if ( s/=head1\sDESCRIPTION//) {
+ $msg{$header = 'DESCRIPTION'} = '';
+ }
+ next;
+ }
+
+ # strip formatting directives in =item line
+ ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g;
+
+ if ($header =~ /%[sd]/) {
+ $rhs = $lhs = $header;
+ #if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E\$/g) {
+ if ($lhs =~ s/(.*?)%d(?!%d)(.*)/\Q$1\E\\d+\Q$2\E/g) {
+ $lhs =~ s/\\%s/.*?/g;
+ } else {
+ # if i had lookbehind negations, i wouldn't have to do this \377 noise
+ $lhs =~ s/(.*?)%s/\Q$1\E.*?\377/g;
+ #$lhs =~ s/\377([^\377]*)$/\Q$1\E\$/;
+ $lhs =~ s/\377([^\377]*)$/\Q$1\E/;
+ $lhs =~ s/\377//g;
+ $lhs =~ s/\.\*\?$/.*/; # Allow %s at the end to eat it all
+ }
+ $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n";
+ } else {
+ $transmo .= " m{^\Q$header\E} && return 1;\n";
+ }
+
+ print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
+ if $msg{$header};
+
+ $msg{$header} = '';
+ }
+
+
+ close POD_DIAG unless *main::DATA eq *POD_DIAG;
+
+ die "No diagnostics?" unless %msg;
+
+ $transmo .= " return 0;\n}\n";
+ print STDERR $transmo if $DEBUG;
+ eval $transmo;
+ die $@ if $@;
+ $RS = "\n";
+### }
+
+if ($standalone) {
+ if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
+ while (defined ($error = <>)) {
+ splainthis($error) || print THITHER $error;
+ }
+ exit;
+} else {
+ $old_w = 0; $oldwarn = ''; $olddie = '';
+}
+
+sub import {
+ shift;
+ $old_w = $^W;
+ $^W = 1; # yup, clobbered the global variable; tough, if you
+ # want diags, you want diags.
+ return if $SIG{__WARN__} eq \&warn_trap;
+
+ for (@_) {
+
+ /^-d(ebug)?$/ && do {
+ $DEBUG++;
+ next;
+ };
+
+ /^-v(erbose)?$/ && do {
+ $VERBOSE++;
+ next;
+ };
+
+ /^-p(retty)?$/ && do {
+ print STDERR "$0: I'm afraid it's too late for prettiness.\n";
+ $PRETTY++;
+ next;
+ };
+
+ warn "Unknown flag: $_";
+ }
+
+ $oldwarn = $SIG{__WARN__};
+ $olddie = $SIG{__DIE__};
+ $SIG{__WARN__} = \&warn_trap;
+ $SIG{__DIE__} = \&death_trap;
+}
+
+sub enable { &import }
+
+sub disable {
+ shift;
+ $^W = $old_w;
+ return unless $SIG{__WARN__} eq \&warn_trap;
+ $SIG{__WARN__} = $oldwarn;
+ $SIG{__DIE__} = $olddie;
+}
+
+sub warn_trap {
+ my $warning = $_[0];
+ if (caller eq $WHOAMI or !splainthis($warning)) {
+ print STDERR $warning;
+ }
+ &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
+};
+
+sub death_trap {
+ my $exception = $_[0];
+
+ # See if we are coming from anywhere within an eval. If so we don't
+ # want to explain the exception because it's going to get caught.
+ my $in_eval = 0;
+ my $i = 0;
+ while (1) {
+ my $caller = (caller($i++))[3] or last;
+ if ($caller eq '(eval)') {
+ $in_eval = 1;
+ last;
+ }
+ }
+
+ splainthis($exception) unless $in_eval;
+ if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
+ &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
+
+ # We don't want to unset these if we're coming from an eval because
+ # then we've turned off diagnostics. (Actually what does this next
+ # line do? -PSeibel)
+ $SIG{__DIE__} = $SIG{__WARN__} = '' unless $in_eval;
+ local($Carp::CarpLevel) = 1;
+ confess "Uncaught exception from user code:\n\t$exception";
+ # up we go; where we stop, nobody knows, but i think we die now
+ # but i'm deeply afraid of the &$olddie guy reraising and us getting
+ # into an indirect recursion loop
+};
+
+sub splainthis {
+ local $_ = shift;
+ local $\;
+ ### &finish_compilation unless %msg;
+ s/\.?\n+$//;
+ my $orig = $_;
+ # return unless defined;
+ if ($exact_duplicate{$_}++) {
+ return 1;
+ }
+ s/, <.*?> (?:line|chunk).*$//;
+ $real = s/(.*?) at .*? (?:line|chunk) \d+.*/$1/;
+ s/^\((.*)\)$/$1/;
+ return 0 unless &transmo;
+ $orig = shorten($orig);
+ if ($old_diag{$_}) {
+ autodescribe();
+ print THITHER "$orig (#$old_diag{$_})\n";
+ $wantspace = 1;
+ } else {
+ autodescribe();
+ $old_diag{$_} = ++$count;
+ print THITHER "\n" if $wantspace;
+ $wantspace = 0;
+ print THITHER "$orig (#$old_diag{$_})\n";
+ if ($msg{$_}) {
+ print THITHER $msg{$_};
+ } else {
+ if (0 and $standalone) {
+ print THITHER " **** Error #$old_diag{$_} ",
+ ($real ? "is" : "appears to be"),
+ " an unknown diagnostic message.\n\n";
+ }
+ return 0;
+ }
+ }
+ return 1;
+}
+
+sub autodescribe {
+ if ($VERBOSE and not $count) {
+ print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
+ "\n$msg{DESCRIPTION}\n";
+ }
+}
+
+sub unescape {
+ s {
+ E<
+ ( [A-Za-z]+ )
+ >
+ } {
+ do {
+ exists $HTML_Escapes{$1}
+ ? do { $HTML_Escapes{$1} }
+ : do {
+ warn "Unknown escape: E<$1> in $_";
+ "E<$1>";
+ }
+ }
+ }egx;
+}
+
+sub shorten {
+ my $line = $_[0];
+ if (length($line) > 79 and index($line, "\n") == -1) {
+ my $space_place = rindex($line, ' ', 79);
+ if ($space_place != -1) {
+ substr($line, $space_place, 1) = "\n\t";
+ }
+ }
+ return $line;
+}
+
+
+# have to do this: RS isn't set until run time, but we're executing at compile time
+$RS = "\n";
+
+1 unless $standalone; # or it'll complain about itself
+__END__ # wish diag dbase were more accessible
diff --git a/contrib/perl5/lib/dotsh.pl b/contrib/perl5/lib/dotsh.pl
new file mode 100644
index 000000000000..877467eb9613
--- /dev/null
+++ b/contrib/perl5/lib/dotsh.pl
@@ -0,0 +1,67 @@
+#
+# @(#)dotsh.pl 03/19/94
+#
+# Author: Charles Collins
+#
+# Description:
+# This routine takes a shell script and 'dots' it into the current perl
+# environment. This makes it possible to use existing system scripts
+# to alter environment variables on the fly.
+#
+# Usage:
+# &dotsh ('ShellScript', 'DependentVariable(s)');
+#
+# where
+#
+# 'ShellScript' is the full name of the shell script to be dotted
+#
+# 'DependentVariable(s)' is an optional list of shell variables in the
+# form VARIABLE=VALUE,VARIABLE=VALUE,... that 'ShellScript' is
+# dependent upon. These variables MUST be defined using shell syntax.
+#
+# Example:
+# &dotsh ('/tmp/foo', 'arg1');
+# &dotsh ('/tmp/foo');
+# &dotsh ('/tmp/foo arg1 ... argN');
+#
+sub dotsh {
+ local(@sh) = @_;
+ local($tmp,$key,$shell,*dotsh,$command,$args,$vars) = '';
+ $dotsh = shift(@sh);
+ @dotsh = split (/\s/, $dotsh);
+ $command = shift (@dotsh);
+ $args = join (" ", @dotsh);
+ $vars = join ("\n", @sh);
+ open (_SH_ENV, "$command") || die "Could not open $dotsh!\n";
+ chop($_ = <_SH_ENV>);
+ $shell = "$1 -c" if ($_ =~ /^\#\!\s*(\S+(\/sh|\/ksh|\/zsh|\/csh))\s*$/);
+ close (_SH_ENV);
+ if (!$shell) {
+ if ($ENV{'SHELL'} =~ /\/sh$|\/ksh$|\/zsh$|\/csh$/) {
+ $shell = "$ENV{'SHELL'} -c";
+ } else {
+ print "SHELL not recognized!\nUsing /bin/sh...\n";
+ $shell = "/bin/sh -c";
+ }
+ }
+ if (length($vars) > 0) {
+ system "$shell \"$vars;. $command $args; set > /tmp/_sh_env$$\"";
+ } else {
+ system "$shell \". $command $args; set > /tmp/_sh_env$$\"";
+ }
+
+ open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n";
+ while (<_SH_ENV>) {
+ chop;
+ m/^([^=]*)=(.*)/s;
+ $ENV{$1} = $2;
+ }
+ close (_SH_ENV);
+ system "rm -f /tmp/_sh_env$$";
+
+ foreach $key (keys(%ENV)) {
+ $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
+ }
+ eval $tmp;
+}
+1;
diff --git a/contrib/perl5/lib/dumpvar.pl b/contrib/perl5/lib/dumpvar.pl
new file mode 100644
index 000000000000..32d4692d13ab
--- /dev/null
+++ b/contrib/perl5/lib/dumpvar.pl
@@ -0,0 +1,417 @@
+require 5.002; # For (defined ref)
+package dumpvar;
+
+# Needed for PrettyPrinter only:
+
+# require 5.001; # Well, it coredumps anyway undef DB in 5.000 (not now)
+
+# translate control chars to ^X - Randal Schwartz
+# Modifications to print types by Peter Gordon v1.0
+
+# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
+
+# Won't dump symbol tables and contents of debugged files by default
+
+$winsize = 80 unless defined $winsize;
+
+
+# Defaults
+
+# $globPrint = 1;
+$printUndef = 1 unless defined $printUndef;
+$tick = "auto" unless defined $tick;
+$unctrl = 'quote' unless defined $unctrl;
+$subdump = 1;
+$dumpReused = 0 unless defined $dumpReused;
+$bareStringify = 1 unless defined $bareStringify;
+
+sub main::dumpValue {
+ local %address;
+ local $^W=0;
+ (print "undef\n"), return unless defined $_[0];
+ (print &stringify($_[0]), "\n"), return unless ref $_[0];
+ dumpvar::unwrap($_[0],0);
+}
+
+# This one is good for variable names:
+
+sub unctrl {
+ local($_) = @_;
+ local($v) ;
+
+ return \$_ if ref \$_ eq "GLOB";
+ s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ $_;
+}
+
+sub stringify {
+ local($_,$noticks) = @_;
+ local($v) ;
+ my $tick = $tick;
+
+ return 'undef' unless defined $_ or not $printUndef;
+ return $_ . "" if ref \$_ eq 'GLOB';
+ $_ = &{'overload::StrVal'}($_)
+ if $bareStringify and ref $_
+ and defined %overload:: and defined &{'overload::StrVal'};
+
+ if ($tick eq 'auto') {
+ if (/[\000-\011\013-\037\177]/) {
+ $tick = '"';
+ }else {
+ $tick = "'";
+ }
+ }
+ if ($tick eq "'") {
+ s/([\'\\])/\\$1/g;
+ } elsif ($unctrl eq 'unctrl') {
+ s/([\"\\])/\\$1/g ;
+ s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
+ if $quoteHighBit;
+ } elsif ($unctrl eq 'quote') {
+ s/([\"\\\$\@])/\\$1/g if $tick eq '"';
+ s/\033/\\e/g;
+ s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
+ }
+ s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit;
+ ($noticks || /^\d+(\.\d*)?\Z/)
+ ? $_
+ : $tick . $_ . $tick;
+}
+
+sub ShortArray {
+ my $tArrayDepth = $#{$_[0]} ;
+ $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1
+ unless $arrayDepth eq '' ;
+ my $shortmore = "";
+ $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ;
+ if (!grep(ref $_, @{$_[0]})) {
+ $short = "0..$#{$_[0]} '" .
+ join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
+ return $short if length $short <= $compactDump;
+ }
+ undef;
+}
+
+sub DumpElem {
+ my $short = &stringify($_[0], ref $_[0]);
+ if ($veryCompact && ref $_[0]
+ && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) {
+ my $end = "0..$#{$v} '" .
+ join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore";
+ } elsif ($veryCompact && ref $_[0]
+ && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) {
+ my $end = 1;
+ $short = $sp . "0..$#{$v} '" .
+ join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore";
+ } else {
+ print "$short\n";
+ unwrap($_[0],$_[1]);
+ }
+}
+
+sub unwrap {
+ return if $DB::signal;
+ local($v) = shift ;
+ local($s) = shift ; # extra no of spaces
+ local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ;
+ local($tHashDepth,$tArrayDepth) ;
+
+ $sp = " " x $s ;
+ $s += 3 ;
+
+ # Check for reused addresses
+ if (ref $v) {
+ my $val = $v;
+ $val = &{'overload::StrVal'}($v)
+ if defined %overload:: and defined &{'overload::StrVal'};
+ ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
+ if (!$dumpReused && defined $address) {
+ $address{$address}++ ;
+ if ( $address{$address} > 1 ) {
+ print "${sp}-> REUSED_ADDRESS\n" ;
+ return ;
+ }
+ }
+ } elsif (ref \$v eq 'GLOB') {
+ $address = "$v" . ""; # To avoid a bug with globs
+ $address{$address}++ ;
+ if ( $address{$address} > 1 ) {
+ print "${sp}*DUMPED_GLOB*\n" ;
+ return ;
+ }
+ }
+
+ if ( UNIVERSAL::isa($v, 'HASH') ) {
+ @sortKeys = sort keys(%$v) ;
+ undef $more ;
+ $tHashDepth = $#sortKeys ;
+ $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1
+ unless $hashDepth eq '' ;
+ $more = "....\n" if $tHashDepth < $#sortKeys ;
+ $shortmore = "";
+ $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
+ $#sortKeys = $tHashDepth ;
+ if ($compactDump && !grep(ref $_, values %{$v})) {
+ #$short = $sp .
+ # (join ', ',
+# Next row core dumps during require from DB on 5.000, even with map {"_"}
+ # map {&stringify($_) . " => " . &stringify($v->{$_})}
+ # @sortKeys) . "'$shortmore";
+ $short = $sp;
+ my @keys;
+ for (@sortKeys) {
+ push @keys, &stringify($_) . " => " . &stringify($v->{$_});
+ }
+ $short .= join ', ', @keys;
+ $short .= $shortmore;
+ (print "$short\n"), return if length $short <= $compactDump;
+ }
+ for $key (@sortKeys) {
+ return if $DB::signal;
+ $value = $ {$v}{$key} ;
+ print "$sp", &stringify($key), " => ";
+ DumpElem $value, $s;
+ }
+ print "$sp empty hash\n" unless @sortKeys;
+ print "$sp$more" if defined $more ;
+ } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
+ $tArrayDepth = $#{$v} ;
+ undef $more ;
+ $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
+ unless $arrayDepth eq '' ;
+ $more = "....\n" if $tArrayDepth < $#{$v} ;
+ $shortmore = "";
+ $shortmore = " ..." if $tArrayDepth < $#{$v} ;
+ if ($compactDump && !grep(ref $_, @{$v})) {
+ if ($#$v >= 0) {
+ $short = $sp . "0..$#{$v} " .
+ join(" ",
+ map {stringify $_} @{$v}[0..$tArrayDepth])
+ . "$shortmore";
+ } else {
+ $short = $sp . "empty array";
+ }
+ (print "$short\n"), return if length $short <= $compactDump;
+ }
+ #if ($compactDump && $short = ShortArray($v)) {
+ # print "$short\n";
+ # return;
+ #}
+ for $num ($[ .. $tArrayDepth) {
+ return if $DB::signal;
+ print "$sp$num ";
+ DumpElem $v->[$num], $s;
+ }
+ print "$sp empty array\n" unless @$v;
+ print "$sp$more" if defined $more ;
+ } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
+ print "$sp-> ";
+ DumpElem $$v, $s;
+ } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
+ print "$sp-> ";
+ dumpsub (0, $v);
+ } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
+ print "$sp-> ",&stringify($$v,1),"\n";
+ if ($globPrint) {
+ $s += 3;
+ dumpglob($s, "{$$v}", $$v, 1);
+ } elsif (defined ($fileno = fileno($v))) {
+ print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
+ }
+ } elsif (ref \$v eq 'GLOB') {
+ if ($globPrint) {
+ dumpglob($s, "{$v}", $v, 1) if $globPrint;
+ } elsif (defined ($fileno = fileno(\$v))) {
+ print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
+ }
+ }
+}
+
+sub matchvar {
+ $_[0] eq $_[1] or
+ ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
+ ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
+}
+
+sub compactDump {
+ $compactDump = shift if @_;
+ $compactDump = 6*80-1 if $compactDump and $compactDump < 2;
+ $compactDump;
+}
+
+sub veryCompact {
+ $veryCompact = shift if @_;
+ compactDump(1) if !$compactDump and $veryCompact;
+ $veryCompact;
+}
+
+sub unctrlSet {
+ if (@_) {
+ my $in = shift;
+ if ($in eq 'unctrl' or $in eq 'quote') {
+ $unctrl = $in;
+ } else {
+ print "Unknown value for `unctrl'.\n";
+ }
+ }
+ $unctrl;
+}
+
+sub quote {
+ if (@_ and $_[0] eq '"') {
+ $tick = '"';
+ $unctrl = 'quote';
+ } elsif (@_ and $_[0] eq 'auto') {
+ $tick = 'auto';
+ $unctrl = 'quote';
+ } elsif (@_) { # Need to set
+ $tick = "'";
+ $unctrl = 'unctrl';
+ }
+ $tick;
+}
+
+sub dumpglob {
+ return if $DB::signal;
+ my ($off,$key, $val, $all) = @_;
+ local(*entry) = $val;
+ my $fileno;
+ if (($key !~ /^_</ or $dumpDBFiles) and defined $entry) {
+ print( (' ' x $off) . "\$", &unctrl($key), " = " );
+ DumpElem $entry, 3+$off;
+ }
+ if (($key !~ /^_</ or $dumpDBFiles) and defined @entry) {
+ print( (' ' x $off) . "\@$key = (\n" );
+ unwrap(\@entry,3+$off) ;
+ print( (' ' x $off) . ")\n" );
+ }
+ if ($key ne "main::" && $key ne "DB::" && defined %entry
+ && ($dumpPackages or $key !~ /::$/)
+ && ($key !~ /^_</ or $dumpDBFiles)
+ && !($package eq "dumpvar" and $key eq "stab")) {
+ print( (' ' x $off) . "\%$key = (\n" );
+ unwrap(\%entry,3+$off) ;
+ print( (' ' x $off) . ")\n" );
+ }
+ if (defined ($fileno = fileno(*entry))) {
+ print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
+ }
+ if ($all) {
+ if (defined &entry) {
+ dumpsub($off, $key);
+ }
+ }
+}
+
+sub dumpsub {
+ my ($off,$sub) = @_;
+ $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
+ my $subref = \&$sub;
+ my $place = $DB::sub{$sub} || (($sub = $subs{"$subref"}) && $DB::sub{$sub})
+ || ($subdump && ($sub = findsubs("$subref")) && $DB::sub{$sub});
+ $place = '???' unless defined $place;
+ print( (' ' x $off) . "&$sub in $place\n" );
+}
+
+sub findsubs {
+ return undef unless defined %DB::sub;
+ my ($addr, $name, $loc);
+ while (($name, $loc) = each %DB::sub) {
+ $addr = \&$name;
+ $subs{"$addr"} = $name;
+ }
+ $subdump = 0;
+ $subs{ shift() };
+}
+
+sub main::dumpvar {
+ my ($package,@vars) = @_;
+ local(%address,$key,$val,$^W);
+ $package .= "::" unless $package =~ /::$/;
+ *stab = *{"main::"};
+ while ($package =~ /(\w+?::)/g){
+ *stab = $ {stab}{$1};
+ }
+ local $TotalStrings = 0;
+ local $Strings = 0;
+ local $CompleteTotal = 0;
+ while (($key,$val) = each(%stab)) {
+ return if $DB::signal;
+ next if @vars && !grep( matchvar($key, $_), @vars );
+ if ($usageOnly) {
+ globUsage(\$val, $key) unless $package eq 'dumpvar' and $key eq 'stab';
+ } else {
+ dumpglob(0,$key, $val);
+ }
+ }
+ if ($usageOnly) {
+ print "String space: $TotalStrings bytes in $Strings strings.\n";
+ $CompleteTotal += $TotalStrings;
+ print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n";
+ }
+}
+
+sub scalarUsage {
+ my $size = length($_[0]);
+ $TotalStrings += $size;
+ $Strings++;
+ $size;
+}
+
+sub arrayUsage { # array ref, name
+ my $size = 0;
+ map {$size += scalarUsage($_)} @{$_[0]};
+ my $len = @{$_[0]};
+ print "\@$_[1] = $len item", ($len > 1 ? "s" : ""),
+ " (data: $size bytes)\n"
+ if defined $_[1];
+ $CompleteTotal += $size;
+ $size;
+}
+
+sub hashUsage { # hash ref, name
+ my @keys = keys %{$_[0]};
+ my @values = values %{$_[0]};
+ my $keys = arrayUsage \@keys;
+ my $values = arrayUsage \@values;
+ my $len = @keys;
+ my $total = $keys + $values;
+ print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
+ " (keys: $keys; values: $values; total: $total bytes)\n"
+ if defined $_[1];
+ $total;
+}
+
+sub globUsage { # glob ref, name
+ local *name = *{$_[0]};
+ $total = 0;
+ $total += scalarUsage $name if defined $name;
+ $total += arrayUsage \@name, $_[1] if defined @name;
+ $total += hashUsage \%name, $_[1] if defined %name and $_[1] ne "main::"
+ and $_[1] ne "DB::"; #and !($package eq "dumpvar" and $key eq "stab"));
+ $total;
+}
+
+sub packageUsage {
+ my ($package,@vars) = @_;
+ $package .= "::" unless $package =~ /::$/;
+ local *stab = *{"main::"};
+ while ($package =~ /(\w+?::)/g){
+ *stab = $ {stab}{$1};
+ }
+ local $TotalStrings = 0;
+ local $CompleteTotal = 0;
+ my ($key,$val);
+ while (($key,$val) = each(%stab)) {
+ next if @vars && !grep($key eq $_,@vars);
+ globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab';
+ }
+ print "String space: $TotalStrings.\n";
+ $CompleteTotal += $TotalStrings;
+ print "\nGrand total = $CompleteTotal bytes\n";
+}
+
+1;
+
diff --git a/contrib/perl5/lib/exceptions.pl b/contrib/perl5/lib/exceptions.pl
new file mode 100644
index 000000000000..02c4498d3211
--- /dev/null
+++ b/contrib/perl5/lib/exceptions.pl
@@ -0,0 +1,54 @@
+# exceptions.pl
+# tchrist@convex.com
+#
+# Here's a little code I use for exception handling. It's really just
+# glorfied eval/die. The way to use use it is when you might otherwise
+# exit, use &throw to raise an exception. The first enclosing &catch
+# handler looks at the exception and decides whether it can catch this kind
+# (catch takes a list of regexps to catch), and if so, it returns the one it
+# caught. If it *can't* catch it, then it will reraise the exception
+# for someone else to possibly see, or to die otherwise.
+#
+# I use oddly named variables in order to make darn sure I don't conflict
+# with my caller. I also hide in my own package, and eval the code in his.
+#
+# The EXCEPTION: prefix is so you can tell whether it's a user-raised
+# exception or a perl-raised one (eval error).
+#
+# --tom
+#
+# examples:
+# if (&catch('/$user_input/', 'regexp', 'syntax error') {
+# warn "oops try again";
+# redo;
+# }
+#
+# if ($error = &catch('&subroutine()')) { # catches anything
+#
+# &throw('bad input') if /^$/;
+
+sub catch {
+ package exception;
+ local($__code__, @__exceptions__) = @_;
+ local($__package__) = caller;
+ local($__exception__);
+
+ eval "package $__package__; $__code__";
+ if ($__exception__ = &'thrown) {
+ for (@__exceptions__) {
+ return $__exception__ if /$__exception__/;
+ }
+ &'throw($__exception__);
+ }
+}
+
+sub throw {
+ local($exception) = @_;
+ die "EXCEPTION: $exception\n";
+}
+
+sub thrown {
+ $@ =~ /^(EXCEPTION: )+(.+)/ && $2;
+}
+
+1;
diff --git a/contrib/perl5/lib/fastcwd.pl b/contrib/perl5/lib/fastcwd.pl
new file mode 100644
index 000000000000..6b452e8d788c
--- /dev/null
+++ b/contrib/perl5/lib/fastcwd.pl
@@ -0,0 +1,35 @@
+# By John Bazik
+#
+# Usage: $cwd = &fastcwd;
+#
+# This is a faster version of getcwd. It's also more dangerous because
+# you might chdir out of a directory that you can't chdir back into.
+
+sub fastcwd {
+ local($odev, $oino, $cdev, $cino, $tdev, $tino);
+ local(@path, $path);
+ local(*DIR);
+
+ ($cdev, $cino) = stat('.');
+ for (;;) {
+ ($odev, $oino) = ($cdev, $cino);
+ chdir('..');
+ ($cdev, $cino) = stat('.');
+ last if $odev == $cdev && $oino == $cino;
+ opendir(DIR, '.');
+ for (;;) {
+ $_ = readdir(DIR);
+ next if $_ eq '.';
+ next if $_ eq '..';
+
+ last unless $_;
+ ($tdev, $tino) = lstat($_);
+ last unless $tdev != $odev || $tino != $oino;
+ }
+ closedir(DIR);
+ unshift(@path, $_);
+ }
+ chdir($path = '/' . join('/', @path));
+ $path;
+}
+1;
diff --git a/contrib/perl5/lib/fields.pm b/contrib/perl5/lib/fields.pm
new file mode 100644
index 000000000000..db2eea7a39d4
--- /dev/null
+++ b/contrib/perl5/lib/fields.pm
@@ -0,0 +1,156 @@
+package fields;
+
+=head1 NAME
+
+fields - compile-time class fields
+
+=head1 SYNOPSIS
+
+ {
+ package Foo;
+ use fields qw(foo bar _private);
+ }
+ ...
+ my Foo $var = new Foo;
+ $var->{foo} = 42;
+
+ # This will generate a compile-time error.
+ $var->{zap} = 42;
+
+ {
+ package Bar;
+ use base 'Foo';
+ use fields 'bar'; # hides Foo->{bar}
+ use fields qw(baz _private); # not shared with Foo
+ }
+
+=head1 DESCRIPTION
+
+The C<fields> pragma enables compile-time verified class fields. It
+does so by updating the %FIELDS hash in the calling package.
+
+If a typed lexical variable holding a reference is used to access a
+hash element and the %FIELDS hash of the given type exists, then the
+operation is turned into an array access at compile time. The %FIELDS
+hash map from hash element names to the array indices. If the hash
+element is not present in the %FIELDS hash, then a compile-time error
+is signaled.
+
+Since the %FIELDS hash is used at compile-time, it must be set up at
+compile-time too. This is made easier with the help of the 'fields'
+and the 'base' pragma modules. The 'base' pragma will copy fields
+from base classes and the 'fields' pragma adds new fields. Field
+names that start with an underscore character are made private to a
+class and are not visible to subclasses. Inherited fields can be
+overridden but will generate a warning if used together with the C<-w>
+switch.
+
+The effect of all this is that you can have objects with named fields
+which are as compact and as fast arrays to access. This only works
+as long as the objects are accessed through properly typed variables.
+For untyped access to work you have to make sure that a reference to
+the proper %FIELDS hash is assigned to the 0'th element of the array
+object (so that the objects can be treated like an pseudo-hash). A
+constructor like this does the job:
+
+ sub new
+ {
+ my $class = shift;
+ no strict 'refs';
+ my $self = bless [\%{"$class\::FIELDS"], $class;
+ $self;
+ }
+
+
+=head1 SEE ALSO
+
+L<base>,
+L<perlref/Pseudo-hashes: Using an array as a hash>
+
+=cut
+
+use strict;
+no strict 'refs';
+use vars qw(%attr $VERSION);
+
+$VERSION = "0.02";
+
+# some constants
+sub _PUBLIC () { 1 }
+sub _PRIVATE () { 2 }
+sub _INHERITED () { 4 }
+
+# The %attr hash holds the attributes of the currently assigned fields
+# per class. The hash is indexed by class names and the hash value is
+# an array reference. The array is indexed with the field numbers
+# (minus one) and the values are integer bit masks (or undef). The
+# size of the array also indicate the next field index too assign for
+# additional fields in this class.
+
+sub import {
+ my $class = shift;
+ my $package = caller(0);
+ my $fields = \%{"$package\::FIELDS"};
+ my $fattr = ($attr{$package} ||= []);
+
+ foreach my $f (@_) {
+ if (my $fno = $fields->{$f}) {
+ require Carp;
+ if ($fattr->[$fno-1] & _INHERITED) {
+ Carp::carp("Hides field '$f' in base class") if $^W;
+ } else {
+ Carp::croak("Field name '$f' already in use");
+ }
+ }
+ $fields->{$f} = @$fattr + 1;
+ push(@$fattr, ($f =~ /^_/) ? _PRIVATE : _PUBLIC);
+ }
+}
+
+sub inherit # called by base.pm
+{
+ my($derived, $base) = @_;
+
+ if (defined %{"$derived\::FIELDS"}) {
+ require Carp;
+ Carp::croak("Inherited %FIELDS can't override existing %FIELDS");
+ } else {
+ my $base_fields = \%{"$base\::FIELDS"};
+ my $derived_fields = \%{"$derived\::FIELDS"};
+
+ $attr{$derived}[@{$attr{$base}}-1] = undef;
+ while (my($k,$v) = each %$base_fields) {
+ next if $attr{$base}[$v-1] & _PRIVATE;
+ $attr{$derived}[$v-1] = _INHERITED;
+ $derived_fields->{$k} = $v;
+ }
+ }
+
+}
+
+sub _dump # sometimes useful for debugging
+{
+ for my $pkg (sort keys %attr) {
+ print "\n$pkg";
+ if (defined @{"$pkg\::ISA"}) {
+ print " (", join(", ", @{"$pkg\::ISA"}), ")";
+ }
+ print "\n";
+ my $fields = \%{"$pkg\::FIELDS"};
+ for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
+ my $no = $fields->{$f};
+ print " $no: $f";
+ my $fattr = $attr{$pkg}[$no-1];
+ if (defined $fattr) {
+ my @a;
+ push(@a, "public") if $fattr & _PUBLIC;
+ push(@a, "private") if $fattr & _PRIVATE;
+ push(@a, "inherited") if $fattr & _INHERITED;
+ print "\t(", join(", ", @a), ")";
+ }
+ print "\n";
+ }
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/find.pl b/contrib/perl5/lib/find.pl
new file mode 100644
index 000000000000..ee5dc5d15065
--- /dev/null
+++ b/contrib/perl5/lib/find.pl
@@ -0,0 +1,47 @@
+# Usage:
+# require "find.pl";
+#
+# &find('/foo','/bar');
+#
+# sub wanted { ... }
+# where wanted does whatever you want. $dir contains the
+# current directory name, and $_ the current filename within
+# that directory. $name contains "$dir/$_". You are cd'ed
+# to $dir when the function is called. The function may
+# set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+# sub wanted {
+# /^\.nfs.*$/ &&
+# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+# int(-M _) > 7 &&
+# unlink($_)
+# ||
+# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+# $dev < 0 &&
+# ($prune = 1);
+# }
+#
+# Set the variable $dont_use_nlink if you're using AFS, since AFS cheats.
+
+use File::Find ();
+
+*name = *File::Find::name;
+*prune = *File::Find::prune;
+*dir = *File::Find::dir;
+*topdir = *File::Find::topdir;
+*topdev = *File::Find::topdev;
+*topino = *File::Find::topino;
+*topmode = *File::Find::topmode;
+*topnlink = *File::Find::topnlink;
+
+sub find {
+ &File::Find::find(\&wanted, @_);
+}
+
+1;
diff --git a/contrib/perl5/lib/finddepth.pl b/contrib/perl5/lib/finddepth.pl
new file mode 100644
index 000000000000..bfa44bb1bc9d
--- /dev/null
+++ b/contrib/perl5/lib/finddepth.pl
@@ -0,0 +1,46 @@
+# Usage:
+# require "finddepth.pl";
+#
+# &finddepth('/foo','/bar');
+#
+# sub wanted { ... }
+# where wanted does whatever you want. $dir contains the
+# current directory name, and $_ the current filename within
+# that directory. $name contains "$dir/$_". You are cd'ed
+# to $dir when the function is called. The function may
+# set $prune to prune the tree.
+#
+# This library is primarily for find2perl, which, when fed
+#
+# find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
+#
+# spits out something like this
+#
+# sub wanted {
+# /^\.nfs.*$/ &&
+# (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
+# int(-M _) > 7 &&
+# unlink($_)
+# ||
+# ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
+# $dev < 0 &&
+# ($prune = 1);
+# }
+
+
+use File::Find ();
+
+*name = *File::Find::name;
+*prune = *File::Find::prune;
+*dir = *File::Find::dir;
+*topdir = *File::Find::topdir;
+*topdev = *File::Find::topdev;
+*topino = *File::Find::topino;
+*topmode = *File::Find::topmode;
+*topnlink = *File::Find::topnlink;
+
+sub finddepth {
+ &File::Find::finddepth(\&wanted, @_);
+}
+
+1;
diff --git a/contrib/perl5/lib/flush.pl b/contrib/perl5/lib/flush.pl
new file mode 100644
index 000000000000..55002b9919c7
--- /dev/null
+++ b/contrib/perl5/lib/flush.pl
@@ -0,0 +1,23 @@
+;# Usage: &flush(FILEHANDLE)
+;# flushes the named filehandle
+
+;# Usage: &printflush(FILEHANDLE, "prompt: ")
+;# prints arguments and flushes filehandle
+
+sub flush {
+ local($old) = select(shift);
+ $| = 1;
+ print "";
+ $| = 0;
+ select($old);
+}
+
+sub printflush {
+ local($old) = select(shift);
+ $| = 1;
+ print @_;
+ $| = 0;
+ select($old);
+}
+
+1;
diff --git a/contrib/perl5/lib/ftp.pl b/contrib/perl5/lib/ftp.pl
new file mode 100644
index 000000000000..fd78162a404f
--- /dev/null
+++ b/contrib/perl5/lib/ftp.pl
@@ -0,0 +1,1077 @@
+#-*-perl-*-
+# This is a wrapper to the chat2.pl routines that make life easier
+# to do ftp type work.
+# Mostly by Lee McLoughlin <lmjm@doc.ic.ac.uk>
+# based on original version by Alan R. Martello <al@ee.pitt.edu>
+# And by A.Macpherson@bnr.co.uk for multi-homed hosts
+#
+# $Header: /a/swan/home/swan/staff/csg/lmjm/src/perl/mirror/RCS/ftp.pl,v 1.17 1993/04/21 10:06:54 lmjm Exp lmjm $
+# $Log: ftp.pl,v $
+# Revision 1.17 1993/04/21 10:06:54 lmjm
+# Send all status reports to STDERR not to STDOUT (to allow use by ftpcat).
+# Allow target file to be '-' meaning STDOUT
+# Added ftp'quote
+#
+# Revision 1.16 1993/01/28 18:59:05 lmjm
+# Allow socket arguemtns to come from main.
+# Minor cleanups - removed old comments.
+#
+# Revision 1.15 1992/11/25 21:09:30 lmjm
+# Added another REST return code.
+#
+# Revision 1.14 1992/08/12 14:33:42 lmjm
+# Fail ftp'write if out of space.
+#
+# Revision 1.13 1992/03/20 21:01:03 lmjm
+# Added in the proxy ftp code from Edwards Reed <err@cinops.xerox.com>
+# Added ftp'delete from Aaron Wohl <aw0g+@andrew.cmu.edu>
+#
+# Revision 1.12 1992/02/06 23:25:56 lmjm
+# Moved code around so can use this as a lib for both mirror and ftpmail.
+# Time out opens. In case Unix doesn't bother to.
+#
+# Revision 1.11 1991/11/27 22:05:57 lmjm
+# Match the response code number at the start of a line allowing
+# for any leading junk.
+#
+# Revision 1.10 1991/10/23 22:42:20 lmjm
+# Added better timeout code.
+# Tried to optimise file transfer
+# Moved open/close code to not leak file handles.
+# Cleaned up the alarm code.
+# Added $fatalerror to show wether the ftp link is really dead.
+#
+# Revision 1.9 1991/10/07 18:30:35 lmjm
+# Made the timeout-read code work.
+# Added restarting file gets.
+# Be more verbose if ever have to call die.
+#
+# Revision 1.8 1991/09/17 22:53:16 lmjm
+# Spot when open_data_socket fails and return a failure rather than dying.
+#
+# Revision 1.7 1991/09/12 22:40:25 lmjm
+# Added Andrew Macpherson's patches for hosts without ip forwarding.
+#
+# Revision 1.6 1991/09/06 19:53:52 lmjm
+# Relaid out the code the way I like it!
+# Changed the debuggin to produce more "appropriate" messages
+# Fixed bugs in the ordering of put and dir listing.
+# Allow for hash printing when getting files (a la ftp).
+# Added the new commands from Al.
+# Don't print passwords in debugging.
+#
+# Revision 1.5 1991/08/29 16:23:49 lmjm
+# Timeout reads from the remote ftp server.
+# No longer call die expect on fatal errors. Just return fail codes.
+# Changed returns so higher up routines can tell whats happening.
+# Get expect/accept in correct order for dir listing.
+# When ftp_show is set then print hashes every 1k transfered (like ftp).
+# Allow for stripping returns out of incoming data.
+# Save last error in a global string.
+#
+# Revision 1.4 1991/08/14 21:04:58 lmjm
+# ftp'get now copes with ungetable files.
+# ftp'expect code changed such that the string_to_print is
+# ignored and the string sent back from the remote system is printed
+# instead.
+# Implemented patches from al. Removed spuiours tracing statements.
+#
+# Revision 1.3 1991/08/09 21:32:18 lmjm
+# Allow for another ok code on cwd's
+# Rejigger the log levels
+# Send \r\n for some odd ftp daemons
+#
+# Revision 1.2 1991/08/09 18:07:37 lmjm
+# Don't print messages unless ftp_show says to.
+#
+# Revision 1.1 1991/08/08 20:31:00 lmjm
+# Initial revision
+#
+
+require 'chat2.pl'; # into main
+eval "require 'socket.ph'" || eval "require 'sys/socket.ph'"
+ || die "socket.ph missing: $!\n";
+
+
+package ftp;
+
+if( defined( &main'PF_INET ) ){
+ $pf_inet = &main'PF_INET;
+ $sock_stream = &main'SOCK_STREAM;
+ local($name, $aliases, $proto) = getprotobyname( 'tcp' );
+ $tcp_proto = $proto;
+}
+else {
+ # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
+ # but who the heck would change these anyway? (:-)
+ $pf_inet = 2;
+ $sock_stream = 1;
+ $tcp_proto = 6;
+}
+
+# If the remote ftp daemon doesn't respond within this time presume its dead
+# or something.
+$timeout = 30;
+
+# Timeout a read if I don't get data back within this many seconds
+$timeout_read = 20 * $timeout;
+
+# Timeout an open
+$timeout_open = $timeout;
+
+# This is a "global" it contains the last response from the remote ftp server
+# for use in error messages
+$ftp'response = "";
+# Also ftp'NS is the socket containing the data coming in from the remote ls
+# command.
+
+# The size of block to be read or written when talking to the remote
+# ftp server
+$ftp'ftpbufsize = 4096;
+
+# How often to print a hash out, when debugging
+$ftp'hashevery = 1024;
+# Output a newline after this many hashes to prevent outputing very long lines
+$ftp'hashnl = 70;
+
+# If a proxy connection then who am I really talking to?
+$real_site = "";
+
+# This is just a tracing aid.
+$ftp_show = 0;
+sub ftp'debug
+{
+ $ftp_show = $_[0];
+# if( $ftp_show ){
+# print STDERR "ftp debugging on\n";
+# }
+}
+
+sub ftp'set_timeout
+{
+ $timeout = $_[0];
+ $timeout_open = $timeout;
+ $timeout_read = 20 * $timeout;
+ if( $ftp_show ){
+ print STDERR "ftp timeout set to $timeout\n";
+ }
+}
+
+
+sub ftp'open_alarm
+{
+ die "timeout: open";
+}
+
+sub ftp'timed_open
+{
+ local( $site, $ftp_port, $retry_call, $attempts ) = @_;
+ local( $connect_site, $connect_port );
+ local( $res );
+
+ alarm( $timeout_open );
+
+ while( $attempts-- ){
+ if( $ftp_show ){
+ print STDERR "proxy connecting via $proxy_gateway [$proxy_ftp_port]\n" if $proxy;
+ print STDERR "Connecting to $site";
+ if( $ftp_port != 21 ){
+ print STDERR " [port $ftp_port]";
+ }
+ print STDERR "\n";
+ }
+
+ if( $proxy ) {
+ if( ! $proxy_gateway ) {
+ # if not otherwise set
+ $proxy_gateway = "internet-gateway";
+ }
+ if( $debug ) {
+ print STDERR "using proxy services of $proxy_gateway, ";
+ print STDERR "at $proxy_ftp_port\n";
+ }
+ $connect_site = $proxy_gateway;
+ $connect_port = $proxy_ftp_port;
+ $real_site = $site;
+ }
+ else {
+ $connect_site = $site;
+ $connect_port = $ftp_port;
+ }
+ if( ! &chat'open_port( $connect_site, $connect_port ) ){
+ if( $retry_call ){
+ print STDERR "Failed to connect\n" if $ftp_show;
+ next;
+ }
+ else {
+ print STDERR "proxy connection failed " if $proxy;
+ print STDERR "Cannot open ftp to $connect_site\n" if $ftp_show;
+ return 0;
+ }
+ }
+ $res = &ftp'expect( $timeout,
+ 120, "service unavailable to $site", 0,
+ 220, "ready for login to $site", 1,
+ 421, "service unavailable to $site, closing connection", 0);
+ if( ! $res ){
+ &chat'close();
+ next;
+ }
+ return 1;
+ }
+ continue {
+ print STDERR "Pausing between retries\n";
+ sleep( $retry_pause );
+ }
+ return 0;
+}
+
+sub ftp'open
+{
+ local( $site, $ftp_port, $retry_call, $attempts ) = @_;
+
+ $SIG{ 'ALRM' } = "ftp\'open_alarm";
+
+ local( $ret ) = eval "&timed_open( '$site', $ftp_port, $retry_call, $attempts )";
+ alarm( 0 );
+
+ if( $@ =~ /^timeout/ ){
+ return -1;
+ }
+ return $ret;
+}
+
+sub ftp'login
+{
+ local( $remote_user, $remote_password ) = @_;
+
+ if( $proxy ){
+ &ftp'send( "USER $remote_user\@$site" );
+ }
+ else {
+ &ftp'send( "USER $remote_user" );
+ }
+ local( $val ) =
+ &ftp'expect($timeout,
+ 230, "$remote_user logged in", 1,
+ 331, "send password for $remote_user", 2,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 530, "not logged in", 0,
+ 332, "account for login not supported", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ if( $val == 1 ){
+ return 1;
+ }
+ if( $val == 2 ){
+ # A password is needed
+ &ftp'send( "PASS $remote_password" );
+
+ $val = &ftp'expect( $timeout,
+ 230, "$remote_user logged in", 1,
+
+ 202, "command not implemented", 0,
+ 332, "account for login not supported", 0,
+
+ 530, "not logged in", 0,
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 503, "bad sequence of commands", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ if( $val == 1){
+ # Logged in
+ return 1;
+ }
+ }
+ # If I got here I failed to login
+ return 0;
+}
+
+sub ftp'close
+{
+ &ftp'quit();
+ &chat'close();
+}
+
+# Change directory
+# return 1 if successful
+# 0 on a failure
+sub ftp'cwd
+{
+ local( $dir ) = @_;
+
+ &ftp'send( "CWD $dir" );
+
+ return &ftp'expect( $timeout,
+ 200, "working directory = $dir", 1,
+ 250, "working directory = $dir", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "command not implemented", 0,
+ 530, "not logged in", 0,
+ 550, "cannot change directory", 0,
+ 421, "service unavailable, closing connection", 0 );
+}
+
+# Get a full directory listing:
+# &ftp'dir( remote LIST options )
+# Start a list goin with the given options.
+# Presuming that the remote deamon uses the ls command to generate the
+# data to send back then then you can send it some extra options (eg: -lRa)
+# return 1 if sucessful and 0 on a failure
+sub ftp'dir_open
+{
+ local( $options ) = @_;
+ local( $ret );
+
+ if( ! &ftp'open_data_socket() ){
+ return 0;
+ }
+
+ if( $options ){
+ &ftp'send( "LIST $options" );
+ }
+ else {
+ &ftp'send( "LIST" );
+ }
+
+ $ret = &ftp'expect( $timeout,
+ 150, "reading directory", 1,
+
+ 125, "data connection already open?", 0,
+
+ 450, "file unavailable", 0,
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "command not implemented", 0,
+ 530, "not logged in", 0,
+
+ 421, "service unavailable, closing connection", 0 );
+ if( ! $ret ){
+ &ftp'close_data_socket;
+ return 0;
+ }
+
+ #
+ # the data should be coming at us now
+ #
+
+ # now accept
+ accept(NS,S) || die "accept failed $!";
+
+ return 1;
+}
+
+
+# Close down reading the result of a remote ls command
+# return 1 if successful and 0 on failure
+sub ftp'dir_close
+{
+ local( $ret );
+
+ # read the close
+ #
+ $ret = &ftp'expect($timeout,
+ 226, "", 1, # transfer complete, closing connection
+ 250, "", 1, # action completed
+
+ 425, "can't open data connection", 0,
+ 426, "connection closed, transfer aborted", 0,
+ 451, "action aborted, local error", 0,
+ 421, "service unavailable, closing connection", 0);
+
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ if( ! $ret ){
+ return 0;
+ }
+
+ return 1;
+}
+
+# Quit from the remote ftp server
+# return 1 if successful and 0 on failure
+sub ftp'quit
+{
+ $site_command_check = 0;
+ @site_command_list = ();
+
+ &ftp'send("QUIT");
+
+ return &ftp'expect($timeout,
+ 221, "Goodbye", 1, # transfer complete, closing connection
+
+ 500, "error quitting??", 0);
+}
+
+sub ftp'read_alarm
+{
+ die "timeout: read";
+}
+
+sub ftp'timed_read
+{
+ alarm( $timeout_read );
+ return sysread( NS, $buf, $ftpbufsize );
+}
+
+sub ftp'read
+{
+ $SIG{ 'ALRM' } = "ftp\'read_alarm";
+
+ local( $ret ) = eval '&timed_read()';
+ alarm( 0 );
+
+ if( $@ =~ /^timeout/ ){
+ return -1;
+ }
+ return $ret;
+}
+
+# Get a remote file back into a local file.
+# If no loc_fname passed then uses rem_fname.
+# returns 1 on success and 0 on failure
+sub ftp'get
+{
+ local($rem_fname, $loc_fname, $restart ) = @_;
+
+ if ($loc_fname eq "") {
+ $loc_fname = $rem_fname;
+ }
+
+ if( ! &ftp'open_data_socket() ){
+ print STDERR "Cannot open data socket\n";
+ return 0;
+ }
+
+ if( $loc_fname ne '-' ){
+ # Find the size of the target file
+ local( $restart_at ) = &ftp'filesize( $loc_fname );
+ if( $restart && $restart_at > 0 && &ftp'restart( $restart_at ) ){
+ $restart = 1;
+ # Make sure the file can be updated
+ chmod( 0644, $loc_fname );
+ }
+ else {
+ $restart = 0;
+ unlink( $loc_fname );
+ }
+ }
+
+ &ftp'send( "RETR $rem_fname" );
+
+ local( $ret ) =
+ &ftp'expect($timeout,
+ 150, "receiving $rem_fname", 1,
+
+ 125, "data connection already open?", 0,
+
+ 450, "file unavailable", 2,
+ 550, "file unavailable", 2,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 530, "not logged in", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ if( $ret != 1 ){
+ print STDERR "Failure on RETR command\n";
+
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ return 0;
+ }
+
+ #
+ # the data should be coming at us now
+ #
+
+ # now accept
+ accept(NS,S) || die "accept failed: $!";
+
+ #
+ # open the local fname
+ # concatenate on the end if restarting, else just overwrite
+ if( !open(FH, ($restart ? '>>' : '>') . $loc_fname) ){
+ print STDERR "Cannot create local file $loc_fname\n";
+
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ return 0;
+ }
+
+# while (<NS>) {
+# print FH ;
+# }
+
+ local( $start_time ) = time;
+ local( $bytes, $lasthash, $hashes ) = (0, 0, 0);
+ while( ($len = &ftp'read()) > 0 ){
+ $bytes += $len;
+ if( $strip_cr ){
+ $ftp'buf =~ s/\r//g;
+ }
+ if( $ftp_show ){
+ while( $bytes > ($lasthash + $ftp'hashevery) ){
+ print STDERR '#';
+ $lasthash += $ftp'hashevery;
+ $hashes++;
+ if( ($hashes % $ftp'hashnl) == 0 ){
+ print STDERR "\n";
+ }
+ }
+ }
+ if( ! print FH $ftp'buf ){
+ print STDERR "\nfailed to write data";
+ return 0;
+ }
+ }
+ close( FH );
+
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ if( $len < 0 ){
+ print STDERR "\ntimed out reading data!\n";
+
+ return 0;
+ }
+
+ if( $ftp_show ){
+ if( $hashes && ($hashes % $ftp'hashnl) != 0 ){
+ print STDERR "\n";
+ }
+ local( $secs ) = (time - $start_time);
+ if( $secs <= 0 ){
+ $secs = 1; # To avoid a divide by zero;
+ }
+
+ local( $rate ) = int( $bytes / $secs );
+ print STDERR "Got $bytes bytes ($rate bytes/sec)\n";
+ }
+
+ #
+ # read the close
+ #
+
+ $ret = &ftp'expect($timeout,
+ 226, "Got file", 1, # transfer complete, closing connection
+ 250, "Got file", 1, # action completed
+
+ 110, "restart not supported", 0,
+ 425, "can't open data connection", 0,
+ 426, "connection closed, transfer aborted", 0,
+ 451, "action aborted, local error", 0,
+ 421, "service unavailable, closing connection", 0);
+
+ return $ret;
+}
+
+sub ftp'delete
+{
+ local( $rem_fname, $val ) = @_;
+
+ &ftp'send("DELE $rem_fname" );
+ $val = &ftp'expect( $timeout,
+ 250,"Deleted $rem_fname", 1,
+ 550,"Permission denied",0
+ );
+ return $val == 1;
+}
+
+sub ftp'deldir
+{
+ local( $fname ) = @_;
+
+ # not yet implemented
+ # RMD
+}
+
+# UPDATE ME!!!!!!
+# Add in the hash printing and newline conversion
+sub ftp'put
+{
+ local( $loc_fname, $rem_fname ) = @_;
+ local( $strip_cr );
+
+ if ($loc_fname eq "") {
+ $loc_fname = $rem_fname;
+ }
+
+ if( ! &ftp'open_data_socket() ){
+ return 0;
+ }
+
+ &ftp'send("STOR $rem_fname");
+
+ #
+ # the data should be coming at us now
+ #
+
+ local( $ret ) =
+ &ftp'expect($timeout,
+ 150, "sending $loc_fname", 1,
+
+ 125, "data connection already open?", 0,
+ 450, "file unavailable", 0,
+
+ 532, "need account for storing files", 0,
+ 452, "insufficient storage on system", 0,
+ 553, "file name not allowed", 0,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 530, "not logged in", 0,
+
+ 421, "service unavailable, closing connection", 0);
+
+ if( $ret != 1 ){
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ return 0;
+ }
+
+
+ #
+ # the data should be coming at us now
+ #
+
+ # now accept
+ accept(NS,S) || die "accept failed: $!";
+
+ #
+ # open the local fname
+ #
+ if( !open(FH, "<$loc_fname") ){
+ print STDERR "Cannot open local file $loc_fname\n";
+
+ # shut down our end of the socket
+ &ftp'close_data_socket;
+
+ return 0;
+ }
+
+ while (<FH>) {
+ print NS ;
+ }
+ close(FH);
+
+ # shut down our end of the socket to signal EOF
+ &ftp'close_data_socket;
+
+ #
+ # read the close
+ #
+
+ $ret = &ftp'expect($timeout,
+ 226, "file put", 1, # transfer complete, closing connection
+ 250, "file put", 1, # action completed
+
+ 110, "restart not supported", 0,
+ 425, "can't open data connection", 0,
+ 426, "connection closed, transfer aborted", 0,
+ 451, "action aborted, local error", 0,
+ 551, "page type unknown", 0,
+ 552, "storage allocation exceeded", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ if( ! $ret ){
+ print STDERR "error putting $loc_fname\n";
+ }
+ return $ret;
+}
+
+sub ftp'restart
+{
+ local( $restart_point, $ret ) = @_;
+
+ &ftp'send("REST $restart_point");
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect($timeout,
+ 350, "restarting at $restart_point", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "REST not implemented", 2,
+ 530, "not logged in", 0,
+ 554, "REST not implemented", 2,
+
+ 421, "service unavailable, closing connection", 0);
+ return $ret;
+}
+
+# Set the file transfer type
+sub ftp'type
+{
+ local( $type ) = @_;
+
+ &ftp'send("TYPE $type");
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect($timeout,
+ 200, "file type set to $type", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 504, "Invalid form or byte size for type $type", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ return $ret;
+}
+
+$site_command_check = 0;
+@site_command_list = ();
+
+# routine to query the remote server for 'SITE' commands supported
+sub ftp'site_commands
+{
+ local( $ret );
+
+ # if we havent sent a 'HELP SITE', send it now
+ if( !$site_command_check ){
+
+ $site_command_check = 1;
+
+ &ftp'send( "HELP SITE" );
+
+ # assume the line in the HELP SITE response with the 'HELP'
+ # command is the one for us
+ $ret = &ftp'expect( $timeout,
+ ".*HELP.*", "", "\$1",
+ 214, "", "0",
+ 202, "", "0" );
+
+ if( $ret eq "0" ){
+ print STDERR "No response from HELP SITE\n" if( $ftp_show );
+ }
+
+ @site_command_list = split(/\s+/, $ret);
+ }
+
+ return @site_command_list;
+}
+
+# return the pwd, or null if we can't get the pwd
+sub ftp'pwd
+{
+ local( $ret, $cwd );
+
+ &ftp'send( "PWD" );
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect( $timeout,
+ 257, "working dir is", 1,
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "PWD not implemented", 0,
+ 550, "file unavailable", 0,
+
+ 421, "service unavailable, closing connection", 0 );
+ if( $ret ){
+ if( $ftp'response =~ /^257\s"(.*)"\s.*$/ ){
+ $cwd = $1;
+ }
+ }
+ return $cwd;
+}
+
+# return 1 for success, 0 for failure
+sub ftp'mkdir
+{
+ local( $path ) = @_;
+ local( $ret );
+
+ &ftp'send( "MKD $path" );
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect( $timeout,
+ 257, "made directory $path", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "MKD not implemented", 0,
+ 530, "not logged in", 0,
+ 550, "file unavailable", 0,
+
+ 421, "service unavailable, closing connection", 0 );
+ return $ret;
+}
+
+# return 1 for success, 0 for failure
+sub ftp'chmod
+{
+ local( $path, $mode ) = @_;
+ local( $ret );
+
+ &ftp'send( sprintf( "SITE CHMOD %o $path", $mode ) );
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect( $timeout,
+ 200, "chmod $mode $path succeeded", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "CHMOD not implemented", 0,
+ 530, "not logged in", 0,
+ 550, "file unavailable", 0,
+
+ 421, "service unavailable, closing connection", 0 );
+ return $ret;
+}
+
+# rename a file
+sub ftp'rename
+{
+ local( $old_name, $new_name ) = @_;
+ local( $ret );
+
+ &ftp'send( "RNFR $old_name" );
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect( $timeout,
+ 350, "", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "RNFR not implemented", 0,
+ 530, "not logged in", 0,
+ 550, "file unavailable", 0,
+ 450, "file unavailable", 0,
+
+ 421, "service unavailable, closing connection", 0);
+
+
+ # check if the "rename from" occurred ok
+ if( $ret ) {
+ &ftp'send( "RNTO $new_name" );
+
+ #
+ # see what they say
+
+ $ret = &ftp'expect( $timeout,
+ 250, "rename $old_name to $new_name", 1,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 502, "RNTO not implemented", 0,
+ 503, "bad sequence of commands", 0,
+ 530, "not logged in", 0,
+ 532, "need account for storing files", 0,
+ 553, "file name not allowed", 0,
+
+ 421, "service unavailable, closing connection", 0);
+ }
+
+ return $ret;
+}
+
+
+sub ftp'quote
+{
+ local( $cmd ) = @_;
+
+ &ftp'send( $cmd );
+
+ return &ftp'expect( $timeout,
+ 200, "Remote '$cmd' OK", 1,
+ 500, "error in remote '$cmd'", 0 );
+}
+
+# ------------------------------------------------------------------------------
+# These are the lower level support routines
+
+sub ftp'expectgot
+{
+ ($ftp'response, $ftp'fatalerror) = @_;
+ if( $ftp_show ){
+ print STDERR "$ftp'response\n";
+ }
+}
+
+#
+# create the list of parameters for chat'expect
+#
+# ftp'expect(time_out, {value, string_to_print, return value});
+# if the string_to_print is "" then nothing is printed
+# the last response is stored in $ftp'response
+#
+# NOTE: lmjm has changed this code such that the string_to_print is
+# ignored and the string sent back from the remote system is printed
+# instead.
+#
+sub ftp'expect {
+ local( $ret );
+ local( $time_out );
+ local( $expect_args );
+
+ $ftp'response = '';
+ $ftp'fatalerror = 0;
+
+ @expect_args = ();
+
+ $time_out = shift(@_);
+
+ while( @_ ){
+ local( $code ) = shift( @_ );
+ local( $pre ) = '^';
+ if( $code =~ /^\d/ ){
+ $pre =~ "[.|\n]*^";
+ }
+ push( @expect_args, "$pre(" . $code . " .*)\\015\\n" );
+ shift( @_ );
+ push( @expect_args,
+ "&ftp'expectgot( \$1, 0 ); " . shift( @_ ) );
+ }
+
+ # Treat all unrecognised lines as continuations
+ push( @expect_args, "^(.*)\\015\\n" );
+ push( @expect_args, "&ftp'expectgot( \$1, 0 ); 100" );
+
+ # add patterns TIMEOUT and EOF
+
+ push( @expect_args, 'TIMEOUT' );
+ push( @expect_args, "&ftp'expectgot( \"timed out\", 1 ); 0" );
+
+ push( @expect_args, 'EOF' );
+ push( @expect_args, "&ftp'expectgot( \"remote server gone away\", 1 ); 0" );
+
+ if( $ftp_show > 9 ){
+ &printargs( $time_out, @expect_args );
+ }
+
+ $ret = &chat'expect( $time_out, @expect_args );
+ if( $ret == 100 ){
+ # we saw a continuation line, wait for the end
+ push( @expect_args, "^.*\n" );
+ push( @expect_args, "100" );
+
+ while( $ret == 100 ){
+ $ret = &chat'expect( $time_out, @expect_args );
+ }
+ }
+
+ return $ret;
+}
+
+#
+# opens NS for io
+#
+sub ftp'open_data_socket
+{
+ local( $ret );
+ local( $hostname );
+ local( $sockaddr, $name, $aliases, $proto, $port );
+ local( $type, $len, $thisaddr, $myaddr, $a, $b, $c, $d );
+ local( $mysockaddr, $family, $hi, $lo );
+
+
+ $sockaddr = 'S n a4 x8';
+ chop( $hostname = `hostname` );
+
+ $port = "ftp";
+
+ ($name, $aliases, $proto) = getprotobyname( 'tcp' );
+ ($name, $aliases, $port) = getservbyname( $port, 'tcp' );
+
+# ($name, $aliases, $type, $len, $thisaddr) =
+# gethostbyname( $hostname );
+ ($a,$b,$c,$d) = unpack( 'C4', $chat'thisaddr );
+
+# $this = pack( $sockaddr, &main'AF_INET, 0, $thisaddr );
+ $this = $chat'thisproc;
+
+ socket(S, $pf_inet, $sock_stream, $proto ) || die "socket: $!";
+ bind(S, $this) || die "bind: $!";
+
+ # get the port number
+ $mysockaddr = getsockname(S);
+ ($family, $port, $myaddr) = unpack( $sockaddr, $mysockaddr );
+
+ $hi = ($port >> 8) & 0x00ff;
+ $lo = $port & 0x00ff;
+
+ #
+ # we MUST do a listen before sending the port otherwise
+ # the PORT may fail
+ #
+ listen( S, 5 ) || die "listen";
+
+ &ftp'send( "PORT $a,$b,$c,$d,$hi,$lo" );
+
+ return &ftp'expect($timeout,
+ 200, "PORT command successful", 1,
+ 250, "PORT command successful", 1 ,
+
+ 500, "syntax error", 0,
+ 501, "syntax error", 0,
+ 530, "not logged in", 0,
+
+ 421, "service unavailable, closing connection", 0);
+}
+
+sub ftp'close_data_socket
+{
+ close(NS);
+}
+
+sub ftp'send
+{
+ local($send_cmd) = @_;
+ if( $send_cmd =~ /\n/ ){
+ print STDERR "ERROR, \\n in send string for $send_cmd\n";
+ }
+
+ if( $ftp_show ){
+ local( $sc ) = $send_cmd;
+
+ if( $send_cmd =~ /^PASS/){
+ $sc = "PASS <somestring>";
+ }
+ print STDERR "---> $sc\n";
+ }
+
+ &chat'print( "$send_cmd\r\n" );
+}
+
+sub ftp'printargs
+{
+ while( @_ ){
+ print STDERR shift( @_ ) . "\n";
+ }
+}
+
+sub ftp'filesize
+{
+ local( $fname ) = @_;
+
+ if( ! -f $fname ){
+ return -1;
+ }
+
+ return (stat( _ ))[ 7 ];
+
+}
+
+# make this package return true
+1;
diff --git a/contrib/perl5/lib/getcwd.pl b/contrib/perl5/lib/getcwd.pl
new file mode 100644
index 000000000000..9dd694500c65
--- /dev/null
+++ b/contrib/perl5/lib/getcwd.pl
@@ -0,0 +1,62 @@
+# By Brandon S. Allbery
+#
+# Usage: $cwd = &getcwd;
+
+sub getcwd
+{
+ local($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+ unless (@cst = stat('.'))
+ {
+ warn "stat(.): $!";
+ return '';
+ }
+ $cwd = '';
+ do
+ {
+ $dotdots .= '/' if $dotdots;
+ $dotdots .= '..';
+ @pst = @cst;
+ unless (opendir(getcwd'PARENT, $dotdots)) #'))
+ {
+ warn "opendir($dotdots): $!";
+ return '';
+ }
+ unless (@cst = stat($dotdots))
+ {
+ warn "stat($dotdots): $!";
+ closedir(getcwd'PARENT); #');
+ return '';
+ }
+ if ($pst[$[] == $cst[$[] && $pst[$[ + 1] == $cst[$[ + 1])
+ {
+ $dir = '';
+ }
+ else
+ {
+ do
+ {
+ unless (defined ($dir = readdir(getcwd'PARENT))) #'))
+ {
+ warn "readdir($dotdots): $!";
+ closedir(getcwd'PARENT); #');
+ return '';
+ }
+ unless (@tst = lstat("$dotdots/$dir"))
+ {
+ # warn "lstat($dotdots/$dir): $!";
+ # closedir(getcwd'PARENT); #');
+ # return '';
+ }
+ }
+ while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] ||
+ $tst[$[ + 1] != $pst[$[ + 1]);
+ }
+ $cwd = "$dir/$cwd";
+ closedir(getcwd'PARENT); #');
+ } while ($dir ne '');
+ chop($cwd);
+ $cwd;
+}
+
+1;
diff --git a/contrib/perl5/lib/getopt.pl b/contrib/perl5/lib/getopt.pl
new file mode 100644
index 000000000000..f871e4185011
--- /dev/null
+++ b/contrib/perl5/lib/getopt.pl
@@ -0,0 +1,41 @@
+;# $RCSfile: getopt.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:23:58 $
+
+;# Process single-character switches with switch clustering. Pass one argument
+;# which is a string containing all switches that take an argument. For each
+;# switch found, sets $opt_x (where x is the switch name) to the value of the
+;# argument, or 1 if no argument. Switches which take an argument don't care
+;# whether there is a space between the switch and the argument.
+
+;# Usage:
+;# do Getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
+
+sub Getopt {
+ local($argumentative) = @_;
+ local($_,$first,$rest);
+ local($[) = 0;
+
+ while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ if (index($argumentative,$first) >= $[) {
+ if ($rest ne '') {
+ shift(@ARGV);
+ }
+ else {
+ shift(@ARGV);
+ $rest = shift(@ARGV);
+ }
+ ${"opt_$first"} = $rest;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ if ($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/getopts.pl b/contrib/perl5/lib/getopts.pl
new file mode 100644
index 000000000000..852aae89b18d
--- /dev/null
+++ b/contrib/perl5/lib/getopts.pl
@@ -0,0 +1,49 @@
+;# getopts.pl - a better getopt.pl
+
+;# Usage:
+;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
+;# # side effect.
+
+sub Getopts {
+ local($argumentative) = @_;
+ local(@args,$_,$first,$rest);
+ local($errs) = 0;
+
+ @args = split( / */, $argumentative );
+ while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ ($first,$rest) = ($1,$2);
+ $pos = index($argumentative,$first);
+ if($pos >= 0) {
+ if($pos < $#args && $args[$pos+1] eq ':') {
+ shift(@ARGV);
+ if($rest eq '') {
+ ++$errs unless @ARGV;
+ $rest = shift(@ARGV);
+ }
+ ${"opt_$first"} = $rest;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ if($rest eq '') {
+ shift(@ARGV);
+ }
+ else {
+ $ARGV[0] = "-$rest";
+ }
+ }
+ }
+ else {
+ print STDERR "Unknown option: $first\n";
+ ++$errs;
+ if($rest ne '') {
+ $ARGV[0] = "-$rest";
+ }
+ else {
+ shift(@ARGV);
+ }
+ }
+ }
+ $errs == 0;
+}
+
+1;
diff --git a/contrib/perl5/lib/hostname.pl b/contrib/perl5/lib/hostname.pl
new file mode 100644
index 000000000000..5394c6ec693f
--- /dev/null
+++ b/contrib/perl5/lib/hostname.pl
@@ -0,0 +1,23 @@
+# From: asherman@fmrco.com (Aaron Sherman)
+
+sub hostname
+{
+ local(*P,@tmp,$hostname,$_);
+ if (open(P,"hostname 2>&1 |") && (@tmp = <P>) && close(P))
+ {
+ chop($hostname = $tmp[$#tmp]);
+ }
+ elsif (open(P,"uname -n 2>&1 |") && (@tmp = <P>) && close(P))
+ {
+ chop($hostname = $tmp[$#tmp]);
+ }
+ else
+ {
+ die "$0: Cannot get hostname from 'hostname' or 'uname -n'\n";
+ }
+ @tmp = ();
+ close P; # Just in case we failed in an odd spot....
+ $hostname;
+}
+
+1;
diff --git a/contrib/perl5/lib/importenv.pl b/contrib/perl5/lib/importenv.pl
new file mode 100644
index 000000000000..c28ffd054d4a
--- /dev/null
+++ b/contrib/perl5/lib/importenv.pl
@@ -0,0 +1,16 @@
+;# $RCSfile: importenv.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:02 $
+
+;# This file, when interpreted, pulls the environment into normal variables.
+;# Usage:
+;# require 'importenv.pl';
+;# or
+;# #include <importenv.pl>
+
+local($tmp,$key) = '';
+
+foreach $key (keys(%ENV)) {
+ $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
+}
+eval $tmp;
+
+1;
diff --git a/contrib/perl5/lib/integer.pm b/contrib/perl5/lib/integer.pm
new file mode 100644
index 000000000000..894931896fc2
--- /dev/null
+++ b/contrib/perl5/lib/integer.pm
@@ -0,0 +1,43 @@
+package integer;
+
+=head1 NAME
+
+integer - Perl pragma to compute arithmetic in integer instead of double
+
+=head1 SYNOPSIS
+
+ use integer;
+ $x = 10/3;
+ # $x is now 3, not 3.33333333333333333
+
+=head1 DESCRIPTION
+
+This tells the compiler to use integer operations
+from here to the end of the enclosing BLOCK. On many machines,
+this doesn't matter a great deal for most computations, but on those
+without floating point hardware, it can make a big difference.
+
+Note that this affects the operations, not the numbers. If you run this
+code
+
+ use integer;
+ $x = 1.5;
+ $y = $x + 1;
+ $z = -1.5;
+
+you'll be left with C<$x == 1.5>, C<$y == 2> and C<$z == -1>. The $z
+case happens because unary C<-> counts as an operation.
+
+See L<perlmod/Pragmatic Modules>.
+
+=cut
+
+sub import {
+ $^H |= 1;
+}
+
+sub unimport {
+ $^H &= ~1;
+}
+
+1;
diff --git a/contrib/perl5/lib/less.pm b/contrib/perl5/lib/less.pm
new file mode 100644
index 000000000000..b3afef0fcdc5
--- /dev/null
+++ b/contrib/perl5/lib/less.pm
@@ -0,0 +1,23 @@
+package less;
+
+=head1 NAME
+
+less - perl pragma to request less of something from the compiler
+
+=head1 SYNOPSIS
+
+ use less; # unimplemented
+
+=head1 DESCRIPTION
+
+Currently unimplemented, this may someday be a compiler directive
+to make certain trade-offs, such as perhaps
+
+ use less 'memory';
+ use less 'CPU';
+ use less 'fat';
+
+
+=cut
+
+1;
diff --git a/contrib/perl5/lib/lib.pm b/contrib/perl5/lib/lib.pm
new file mode 100644
index 000000000000..6e6e15e4ce95
--- /dev/null
+++ b/contrib/perl5/lib/lib.pm
@@ -0,0 +1,139 @@
+package lib;
+
+use vars qw(@ORIG_INC);
+use Config;
+
+my $archname = $Config{'archname'};
+
+@ORIG_INC = @INC; # take a handy copy of 'original' value
+
+
+sub import {
+ shift;
+ foreach (reverse @_) {
+ ## Ignore this if not defined.
+ next unless defined($_);
+ if ($_ eq '') {
+ require Carp;
+ Carp::carp("Empty compile time value given to use lib");
+ # at foo.pl line ...
+ }
+ if (-e && ! -d _) {
+ require Carp;
+ Carp::carp("Parameter to use lib must be directory, not file");
+ }
+ unshift(@INC, $_);
+ # Put a corresponding archlib directory infront of $_ if it
+ # looks like $_ has an archlib directory below it.
+ if (-d "$_/$archname") {
+ unshift(@INC, "$_/$archname") if -d "$_/$archname/auto";
+ unshift(@INC, "$_/$archname/$]") if -d "$_/$archname/$]/auto";
+ }
+ }
+}
+
+
+sub unimport {
+ shift;
+ my $mode = shift if $_[0] =~ m/^:[A-Z]+/;
+
+ my %names;
+ foreach(@_) {
+ ++$names{$_};
+ ++$names{"$_/$archname"} if -d "$_/$archname/auto";
+ }
+
+ if ($mode and $mode eq ':ALL') {
+ # Remove ALL instances of each named directory.
+ @INC = grep { !exists $names{$_} } @INC;
+ } else {
+ # Remove INITIAL instance(s) of each named directory.
+ @INC = grep { --$names{$_} < 0 } @INC;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+lib - manipulate @INC at compile time
+
+=head1 SYNOPSIS
+
+ use lib LIST;
+
+ no lib LIST;
+
+=head1 DESCRIPTION
+
+This is a small simple module which simplifies the manipulation of @INC
+at compile time.
+
+It is typically used to add extra directories to perl's search path so
+that later C<use> or C<require> statements will find modules which are
+not located on perl's default search path.
+
+=head2 ADDING DIRECTORIES TO @INC
+
+The parameters to C<use lib> are added to the start of the perl search
+path. Saying
+
+ use lib LIST;
+
+is I<almost> the same as saying
+
+ BEGIN { unshift(@INC, LIST) }
+
+For each directory in LIST (called $dir here) the lib module also
+checks to see if a directory called $dir/$archname/auto exists.
+If so the $dir/$archname directory is assumed to be a corresponding
+architecture specific directory and is added to @INC in front of $dir.
+
+If LIST includes both $dir and $dir/$archname then $dir/$archname will
+be added to @INC twice (if $dir/$archname/auto exists).
+
+=head2 DELETING DIRECTORIES FROM @INC
+
+You should normally only add directories to @INC. If you need to
+delete directories from @INC take care to only delete those which you
+added yourself or which you are certain are not needed by other modules
+in your script. Other modules may have added directories which they
+need for correct operation.
+
+By default the C<no lib> statement deletes the I<first> instance of
+each named directory from @INC. To delete multiple instances of the
+same name from @INC you can specify the name multiple times.
+
+To delete I<all> instances of I<all> the specified names from @INC you can
+specify ':ALL' as the first parameter of C<no lib>. For example:
+
+ no lib qw(:ALL .);
+
+For each directory in LIST (called $dir here) the lib module also
+checks to see if a directory called $dir/$archname/auto exists.
+If so the $dir/$archname directory is assumed to be a corresponding
+architecture specific directory and is also deleted from @INC.
+
+If LIST includes both $dir and $dir/$archname then $dir/$archname will
+be deleted from @INC twice (if $dir/$archname/auto exists).
+
+=head2 RESTORING ORIGINAL @INC
+
+When the lib module is first loaded it records the current value of @INC
+in an array C<@lib::ORIG_INC>. To restore @INC to that value you
+can say
+
+ @INC = @lib::ORIG_INC;
+
+
+=head1 SEE ALSO
+
+FindBin - optional module which deals with paths relative to the source file.
+
+=head1 AUTHOR
+
+Tim Bunce, 2nd June 1995.
+
+=cut
+
diff --git a/contrib/perl5/lib/locale.pm b/contrib/perl5/lib/locale.pm
new file mode 100644
index 000000000000..48213ab86cef
--- /dev/null
+++ b/contrib/perl5/lib/locale.pm
@@ -0,0 +1,33 @@
+package locale;
+
+=head1 NAME
+
+locale - Perl pragma to use and avoid POSIX locales for built-in operations
+
+=head1 SYNOPSIS
+
+ @x = sort @y; # ASCII sorting order
+ {
+ use locale;
+ @x = sort @y; # Locale-defined sorting order
+ }
+ @x = sort @y; # ASCII sorting order again
+
+=head1 DESCRIPTION
+
+This pragma tells the compiler to enable (or disable) the use of POSIX
+locales for built-in operations (LC_CTYPE for regular expressions, and
+LC_COLLATE for string comparison). Each "use locale" or "no locale"
+affects statements to the end of the enclosing BLOCK.
+
+=cut
+
+sub import {
+ $^H |= 0x800;
+}
+
+sub unimport {
+ $^H &= ~0x800;
+}
+
+1;
diff --git a/contrib/perl5/lib/look.pl b/contrib/perl5/lib/look.pl
new file mode 100644
index 000000000000..e8dc8aacb6a2
--- /dev/null
+++ b/contrib/perl5/lib/look.pl
@@ -0,0 +1,44 @@
+;# Usage: &look(*FILEHANDLE,$key,$dict,$fold)
+
+;# Sets file position in FILEHANDLE to be first line greater than or equal
+;# (stringwise) to $key. Pass flags for dictionary order and case folding.
+
+sub look {
+ local(*FH,$key,$dict,$fold) = @_;
+ local($max,$min,$mid,$_);
+ local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat(FH);
+ $blksize = 8192 unless $blksize;
+ $key =~ s/[^\w\s]//g if $dict;
+ $key = lc $key if $fold;
+ $max = int($size / $blksize);
+ while ($max - $min > 1) {
+ $mid = int(($max + $min) / 2);
+ seek(FH,$mid * $blksize,0);
+ $_ = <FH> if $mid; # probably a partial line
+ $_ = <FH>;
+ chop;
+ s/[^\w\s]//g if $dict;
+ $_ = lc $_ if $fold;
+ if ($_ lt $key) {
+ $min = $mid;
+ }
+ else {
+ $max = $mid;
+ }
+ }
+ $min *= $blksize;
+ seek(FH,$min,0);
+ <FH> if $min;
+ while (<FH>) {
+ chop;
+ s/[^\w\s]//g if $dict;
+ $_ = lc $_ if $fold;
+ last if $_ ge $key;
+ $min = tell(FH);
+ }
+ seek(FH,$min,0);
+ $min;
+}
+
+1;
diff --git a/contrib/perl5/lib/newgetopt.pl b/contrib/perl5/lib/newgetopt.pl
new file mode 100644
index 000000000000..0b7eed8bfe91
--- /dev/null
+++ b/contrib/perl5/lib/newgetopt.pl
@@ -0,0 +1,68 @@
+# newgetopt.pl -- new options parsing.
+# Now just a wrapper around the Getopt::Long module.
+# $Id: newgetopt.pl,v 1.17 1996-10-02 11:17:16+02 jv Exp $
+
+{ package newgetopt;
+
+ # Values for $order. See GNU getopt.c for details.
+ $REQUIRE_ORDER = 0;
+ $PERMUTE = 1;
+ $RETURN_IN_ORDER = 2;
+
+ # Handle POSIX compliancy.
+ if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+ $autoabbrev = 0; # no automatic abbrev of options (???)
+ $getopt_compat = 0; # disallow '+' to start options
+ $option_start = "(--|-)";
+ $order = $REQUIRE_ORDER;
+ $bundling = 0;
+ $passthrough = 0;
+ }
+ else {
+ $autoabbrev = 1; # automatic abbrev of options
+ $getopt_compat = 1; # allow '+' to start options
+ $option_start = "(--|-|\\+)";
+ $order = $PERMUTE;
+ $bundling = 0;
+ $passthrough = 0;
+ }
+
+ # Other configurable settings.
+ $debug = 0; # for debugging
+ $ignorecase = 1; # ignore case when matching options
+ $argv_end = "--"; # don't change this!
+}
+
+use Getopt::Long;
+
+################ Subroutines ################
+
+sub NGetOpt {
+
+ $Getopt::Long::debug = $newgetopt::debug
+ if defined $newgetopt::debug;
+ $Getopt::Long::autoabbrev = $newgetopt::autoabbrev
+ if defined $newgetopt::autoabbrev;
+ $Getopt::Long::getopt_compat = $newgetopt::getopt_compat
+ if defined $newgetopt::getopt_compat;
+ $Getopt::Long::option_start = $newgetopt::option_start
+ if defined $newgetopt::option_start;
+ $Getopt::Long::order = $newgetopt::order
+ if defined $newgetopt::order;
+ $Getopt::Long::bundling = $newgetopt::bundling
+ if defined $newgetopt::bundling;
+ $Getopt::Long::ignorecase = $newgetopt::ignorecase
+ if defined $newgetopt::ignorecase;
+ $Getopt::Long::ignorecase = $newgetopt::ignorecase
+ if defined $newgetopt::ignorecase;
+ $Getopt::Long::passthrough = $newgetopt::passthrough
+ if defined $newgetopt::passthrough;
+
+ &GetOptions;
+}
+
+################ Package return ################
+
+1;
+
+################ End of newgetopt.pl ################
diff --git a/contrib/perl5/lib/open2.pl b/contrib/perl5/lib/open2.pl
new file mode 100644
index 000000000000..8cf08c2e8bd1
--- /dev/null
+++ b/contrib/perl5/lib/open2.pl
@@ -0,0 +1,12 @@
+# This is a compatibility interface to IPC::Open2. New programs should
+# do
+#
+# use IPC::Open2;
+#
+# instead of
+#
+# require 'open2.pl';
+
+package main;
+use IPC::Open2 'open2';
+1
diff --git a/contrib/perl5/lib/open3.pl b/contrib/perl5/lib/open3.pl
new file mode 100644
index 000000000000..7fcc93186106
--- /dev/null
+++ b/contrib/perl5/lib/open3.pl
@@ -0,0 +1,12 @@
+# This is a compatibility interface to IPC::Open3. New programs should
+# do
+#
+# use IPC::Open3;
+#
+# instead of
+#
+# require 'open3.pl';
+
+package main;
+use IPC::Open3 'open3';
+1
diff --git a/contrib/perl5/lib/overload.pm b/contrib/perl5/lib/overload.pm
new file mode 100644
index 000000000000..43fef8ae5e0b
--- /dev/null
+++ b/contrib/perl5/lib/overload.pm
@@ -0,0 +1,1216 @@
+package overload;
+
+sub nil {}
+
+sub OVERLOAD {
+ $package = shift;
+ my %arg = @_;
+ my ($sub, $fb);
+ $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
+ *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
+ for (keys %arg) {
+ if ($_ eq 'fallback') {
+ $fb = $arg{$_};
+ } else {
+ $sub = $arg{$_};
+ if (not ref $sub and $sub !~ /::/) {
+ $ {$package . "::(" . $_} = $sub;
+ $sub = \&nil;
+ }
+ #print STDERR "Setting `$ {'package'}::\cO$_' to \\&`$sub'.\n";
+ *{$package . "::(" . $_} = \&{ $sub };
+ }
+ }
+ ${$package . "::()"} = $fb; # Make it findable too (fallback only).
+}
+
+sub import {
+ $package = (caller())[0];
+ # *{$package . "::OVERLOAD"} = \&OVERLOAD;
+ shift;
+ $package->overload::OVERLOAD(@_);
+}
+
+sub unimport {
+ $package = (caller())[0];
+ ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
+ shift;
+ for (@_) {
+ if ($_ eq 'fallback') {
+ undef $ {$package . "::()"};
+ } else {
+ delete $ {$package . "::"}{"(" . $_};
+ }
+ }
+}
+
+sub Overloaded {
+ my $package = shift;
+ $package = ref $package if ref $package;
+ $package->can('()');
+}
+
+sub ov_method {
+ my $globref = shift;
+ return undef unless $globref;
+ my $sub = \&{*$globref};
+ return $sub if $sub ne \&nil;
+ return shift->can($ {*$globref});
+}
+
+sub OverloadedStringify {
+ my $package = shift;
+ $package = ref $package if ref $package;
+ #$package->can('(""')
+ ov_method mycan($package, '(""'), $package
+ or ov_method mycan($package, '(0+'), $package
+ or ov_method mycan($package, '(bool'), $package
+ or ov_method mycan($package, '(nomethod'), $package;
+}
+
+sub Method {
+ my $package = shift;
+ $package = ref $package if ref $package;
+ #my $meth = $package->can('(' . shift);
+ ov_method mycan($package, '(' . shift), $package;
+ #return $meth if $meth ne \&nil;
+ #return $ {*{$meth}};
+}
+
+sub AddrRef {
+ my $package = ref $_[0];
+ return "$_[0]" unless $package;
+ bless $_[0], overload::Fake; # Non-overloaded package
+ my $str = "$_[0]";
+ bless $_[0], $package; # Back
+ $package . substr $str, index $str, '=';
+}
+
+sub StrVal {
+ (OverloadedStringify($_[0])) ?
+ (AddrRef(shift)) :
+ "$_[0]";
+}
+
+sub mycan { # Real can would leave stubs.
+ my ($package, $meth) = @_;
+ return \*{$package . "::$meth"} if defined &{$package . "::$meth"};
+ my $p;
+ foreach $p (@{$package . "::ISA"}) {
+ my $out = mycan($p, $meth);
+ return $out if $out;
+ }
+ return undef;
+}
+
+%constants = (
+ 'integer' => 0x1000,
+ 'float' => 0x2000,
+ 'binary' => 0x4000,
+ 'q' => 0x8000,
+ 'qr' => 0x10000,
+ );
+
+%ops = ( with_assign => "+ - * / % ** << >> x .",
+ assign => "+= -= *= /= %= **= <<= >>= x= .=",
+ str_comparison => "< <= > >= == !=",
+ '3way_comparison'=> "<=> cmp",
+ num_comparison => "lt le gt ge eq ne",
+ binary => "& | ^",
+ unary => "neg ! ~",
+ mutators => '++ --',
+ func => "atan2 cos sin exp abs log sqrt",
+ conversion => 'bool "" 0+',
+ special => 'nomethod fallback =');
+
+sub constant {
+ # Arguments: what, sub
+ while (@_) {
+ $^H{$_[0]} = $_[1];
+ $^H |= $constants{$_[0]} | 0x20000;
+ shift, shift;
+ }
+}
+
+sub remove_constant {
+ # Arguments: what, sub
+ while (@_) {
+ delete $^H{$_[0]};
+ $^H &= ~ $constants{$_[0]};
+ shift, shift;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+overload - Package for overloading perl operations
+
+=head1 SYNOPSIS
+
+ package SomeThing;
+
+ use overload
+ '+' => \&myadd,
+ '-' => \&mysub;
+ # etc
+ ...
+
+ package main;
+ $a = new SomeThing 57;
+ $b=5+$a;
+ ...
+ if (overload::Overloaded $b) {...}
+ ...
+ $strval = overload::StrVal $b;
+
+=head1 CAVEAT SCRIPTOR
+
+Overloading of operators is a subject not to be taken lightly.
+Neither its precise implementation, syntax, nor semantics are
+100% endorsed by Larry Wall. So any of these may be changed
+at some point in the future.
+
+=head1 DESCRIPTION
+
+=head2 Declaration of overloaded functions
+
+The compilation directive
+
+ package Number;
+ use overload
+ "+" => \&add,
+ "*=" => "muas";
+
+declares function Number::add() for addition, and method muas() in
+the "class" C<Number> (or one of its base classes)
+for the assignment form C<*=> of multiplication.
+
+Arguments of this directive come in (key, value) pairs. Legal values
+are values legal inside a C<&{ ... }> call, so the name of a
+subroutine, a reference to a subroutine, or an anonymous subroutine
+will all work. Note that values specified as strings are
+interpreted as methods, not subroutines. Legal keys are listed below.
+
+The subroutine C<add> will be called to execute C<$a+$b> if $a
+is a reference to an object blessed into the package C<Number>, or if $a is
+not an object from a package with defined mathemagic addition, but $b is a
+reference to a C<Number>. It can also be called in other situations, like
+C<$a+=7>, or C<$a++>. See L<MAGIC AUTOGENERATION>. (Mathemagical
+methods refer to methods triggered by an overloaded mathematical
+operator.)
+
+Since overloading respects inheritance via the @ISA hierarchy, the
+above declaration would also trigger overloading of C<+> and C<*=> in
+all the packages which inherit from C<Number>.
+
+=head2 Calling Conventions for Binary Operations
+
+The functions specified in the C<use overload ...> directive are called
+with three (in one particular case with four, see L<Last Resort>)
+arguments. If the corresponding operation is binary, then the first
+two arguments are the two arguments of the operation. However, due to
+general object calling conventions, the first argument should always be
+an object in the package, so in the situation of C<7+$a>, the
+order of the arguments is interchanged. It probably does not matter
+when implementing the addition method, but whether the arguments
+are reversed is vital to the subtraction method. The method can
+query this information by examining the third argument, which can take
+three different values:
+
+=over 7
+
+=item FALSE
+
+the order of arguments is as in the current operation.
+
+=item TRUE
+
+the arguments are reversed.
+
+=item C<undef>
+
+the current operation is an assignment variant (as in
+C<$a+=7>), but the usual function is called instead. This additional
+information can be used to generate some optimizations. Compare
+L<Calling Conventions for Mutators>.
+
+=back
+
+=head2 Calling Conventions for Unary Operations
+
+Unary operation are considered binary operations with the second
+argument being C<undef>. Thus the functions that overloads C<{"++"}>
+is called with arguments C<($a,undef,'')> when $a++ is executed.
+
+=head2 Calling Conventions for Mutators
+
+Two types of mutators have different calling conventions:
+
+=over
+
+=item C<++> and C<-->
+
+The routines which implement these operators are expected to actually
+I<mutate> their arguments. So, assuming that $obj is a reference to a
+number,
+
+ sub incr { my $n = $ {$_[0]}; ++$n; $_[0] = bless \$n}
+
+is an appropriate implementation of overloaded C<++>. Note that
+
+ sub incr { ++$ {$_[0]} ; shift }
+
+is OK if used with preincrement and with postincrement. (In the case
+of postincrement a copying will be performed, see L<Copy Constructor>.)
+
+=item C<x=> and other assignment versions
+
+There is nothing special about these methods. They may change the
+value of their arguments, and may leave it as is. The result is going
+to be assigned to the value in the left-hand-side if different from
+this value.
+
+This allows for the same method to be used as averloaded C<+=> and
+C<+>. Note that this is I<allowed>, but not recommended, since by the
+semantic of L<"Fallback"> Perl will call the method for C<+> anyway,
+if C<+=> is not overloaded.
+
+=back
+
+B<Warning.> Due to the presense of assignment versions of operations,
+routines which may be called in assignment context may create
+self-referencial structures. Currently Perl will not free self-referential
+structures until cycles are C<explicitly> broken. You may get problems
+when traversing your structures too.
+
+Say,
+
+ use overload '+' => sub { bless [ \$_[0], \$_[1] ] };
+
+is asking for trouble, since for code C<$obj += $foo> the subroutine
+is called as C<$obj = add($obj, $foo, undef)>, or C<$obj = [\$obj,
+\$foo]>. If using such a subroutine is an important optimization, one
+can overload C<+=> explicitly by a non-"optimized" version, or switch
+to non-optimized version if C<not defined $_[2]> (see
+L<Calling Conventions for Binary Operations>).
+
+Even if no I<explicit> assignment-variants of operators are present in
+the script, they may be generated by the optimizer. Say, C<",$obj,"> or
+C<',' . $obj . ','> may be both optimized to
+
+ my $tmp = ',' . $obj; $tmp .= ',';
+
+=head2 Overloadable Operations
+
+The following symbols can be specified in C<use overload> directive:
+
+=over 5
+
+=item * I<Arithmetic operations>
+
+ "+", "+=", "-", "-=", "*", "*=", "/", "/=", "%", "%=",
+ "**", "**=", "<<", "<<=", ">>", ">>=", "x", "x=", ".", ".=",
+
+For these operations a substituted non-assignment variant can be called if
+the assignment variant is not available. Methods for operations "C<+>",
+"C<->", "C<+=>", and "C<-=>" can be called to automatically generate
+increment and decrement methods. The operation "C<->" can be used to
+autogenerate missing methods for unary minus or C<abs>.
+
+See L<"MAGIC AUTOGENERATION">, L<"Calling Conventions for Mutators"> and
+L<"Calling Conventions for Binary Operations">) for details of these
+substitutions.
+
+=item * I<Comparison operations>
+
+ "<", "<=", ">", ">=", "==", "!=", "<=>",
+ "lt", "le", "gt", "ge", "eq", "ne", "cmp",
+
+If the corresponding "spaceship" variant is available, it can be
+used to substitute for the missing operation. During C<sort>ing
+arrays, C<cmp> is used to compare values subject to C<use overload>.
+
+=item * I<Bit operations>
+
+ "&", "^", "|", "neg", "!", "~",
+
+"C<neg>" stands for unary minus. If the method for C<neg> is not
+specified, it can be autogenerated using the method for
+subtraction. If the method for "C<!>" is not specified, it can be
+autogenerated using the methods for "C<bool>", or "C<\"\">", or "C<0+>".
+
+=item * I<Increment and decrement>
+
+ "++", "--",
+
+If undefined, addition and subtraction methods can be
+used instead. These operations are called both in prefix and
+postfix form.
+
+=item * I<Transcendental functions>
+
+ "atan2", "cos", "sin", "exp", "abs", "log", "sqrt",
+
+If C<abs> is unavailable, it can be autogenerated using methods
+for "E<lt>" or "E<lt>=E<gt>" combined with either unary minus or subtraction.
+
+=item * I<Boolean, string and numeric conversion>
+
+ "bool", "\"\"", "0+",
+
+If one or two of these operations are unavailable, the remaining ones can
+be used instead. C<bool> is used in the flow control operators
+(like C<while>) and for the ternary "C<?:>" operation. These functions can
+return any arbitrary Perl value. If the corresponding operation for this value
+is overloaded too, that operation will be called again with this value.
+
+=item * I<Special>
+
+ "nomethod", "fallback", "=",
+
+see L<SPECIAL SYMBOLS FOR C<use overload>>.
+
+=back
+
+See L<"Fallback"> for an explanation of when a missing method can be
+autogenerated.
+
+A computer-readable form of the above table is available in the hash
+%overload::ops, with values being space-separated lists of names:
+
+ with_assign => '+ - * / % ** << >> x .',
+ assign => '+= -= *= /= %= **= <<= >>= x= .=',
+ str_comparison => '< <= > >= == !=',
+ '3way_comparison'=> '<=> cmp',
+ num_comparison => 'lt le gt ge eq ne',
+ binary => '& | ^',
+ unary => 'neg ! ~',
+ mutators => '++ --',
+ func => 'atan2 cos sin exp abs log sqrt',
+ conversion => 'bool "" 0+',
+ special => 'nomethod fallback ='
+
+=head2 Inheritance and overloading
+
+Inheritance interacts with overloading in two ways.
+
+=over
+
+=item Strings as values of C<use overload> directive
+
+If C<value> in
+
+ use overload key => value;
+
+is a string, it is interpreted as a method name.
+
+=item Overloading of an operation is inherited by derived classes
+
+Any class derived from an overloaded class is also overloaded. The
+set of overloaded methods is the union of overloaded methods of all
+the ancestors. If some method is overloaded in several ancestor, then
+which description will be used is decided by the usual inheritance
+rules:
+
+If C<A> inherits from C<B> and C<C> (in this order), C<B> overloads
+C<+> with C<\&D::plus_sub>, and C<C> overloads C<+> by C<"plus_meth">,
+then the subroutine C<D::plus_sub> will be called to implement
+operation C<+> for an object in package C<A>.
+
+=back
+
+Note that since the value of the C<fallback> key is not a subroutine,
+its inheritance is not governed by the above rules. In the current
+implementation, the value of C<fallback> in the first overloaded
+ancestor is used, but this is accidental and subject to change.
+
+=head1 SPECIAL SYMBOLS FOR C<use overload>
+
+Three keys are recognized by Perl that are not covered by the above
+description.
+
+=head2 Last Resort
+
+C<"nomethod"> should be followed by a reference to a function of four
+parameters. If defined, it is called when the overloading mechanism
+cannot find a method for some operation. The first three arguments of
+this function coincide with the arguments for the corresponding method if
+it were found, the fourth argument is the symbol
+corresponding to the missing method. If several methods are tried,
+the last one is used. Say, C<1-$a> can be equivalent to
+
+ &nomethodMethod($a,1,1,"-")
+
+if the pair C<"nomethod" =E<gt> "nomethodMethod"> was specified in the
+C<use overload> directive.
+
+If some operation cannot be resolved, and there is no function
+assigned to C<"nomethod">, then an exception will be raised via die()--
+unless C<"fallback"> was specified as a key in C<use overload> directive.
+
+=head2 Fallback
+
+The key C<"fallback"> governs what to do if a method for a particular
+operation is not found. Three different cases are possible depending on
+the value of C<"fallback">:
+
+=over 16
+
+=item * C<undef>
+
+Perl tries to use a
+substituted method (see L<MAGIC AUTOGENERATION>). If this fails, it
+then tries to calls C<"nomethod"> value; if missing, an exception
+will be raised.
+
+=item * TRUE
+
+The same as for the C<undef> value, but no exception is raised. Instead,
+it silently reverts to what it would have done were there no C<use overload>
+present.
+
+=item * defined, but FALSE
+
+No autogeneration is tried. Perl tries to call
+C<"nomethod"> value, and if this is missing, raises an exception.
+
+=back
+
+B<Note.> C<"fallback"> inheritance via @ISA is not carved in stone
+yet, see L<"Inheritance and overloading">.
+
+=head2 Copy Constructor
+
+The value for C<"="> is a reference to a function with three
+arguments, i.e., it looks like the other values in C<use
+overload>. However, it does not overload the Perl assignment
+operator. This would go against Camel hair.
+
+This operation is called in the situations when a mutator is applied
+to a reference that shares its object with some other reference, such
+as
+
+ $a=$b;
+ ++$a;
+
+To make this change $a and not change $b, a copy of C<$$a> is made,
+and $a is assigned a reference to this new object. This operation is
+done during execution of the C<++$a>, and not during the assignment,
+(so before the increment C<$$a> coincides with C<$$b>). This is only
+done if C<++> is expressed via a method for C<'++'> or C<'+='> (or
+C<nomethod>). Note that if this operation is expressed via C<'+'>
+a nonmutator, i.e., as in
+
+ $a=$b;
+ $a=$a+1;
+
+then C<$a> does not reference a new copy of C<$$a>, since $$a does not
+appear as lvalue when the above code is executed.
+
+If the copy constructor is required during the execution of some mutator,
+but a method for C<'='> was not specified, it can be autogenerated as a
+string copy if the object is a plain scalar.
+
+=over 5
+
+=item B<Example>
+
+The actually executed code for
+
+ $a=$b;
+ Something else which does not modify $a or $b....
+ ++$a;
+
+may be
+
+ $a=$b;
+ Something else which does not modify $a or $b....
+ $a = $a->clone(undef,"");
+ $a->incr(undef,"");
+
+if $b was mathemagical, and C<'++'> was overloaded with C<\&incr>,
+C<'='> was overloaded with C<\&clone>.
+
+=back
+
+Same behaviour is triggered by C<$b = $a++>, which is consider a synonim for
+C<$b = $a; ++$a>.
+
+=head1 MAGIC AUTOGENERATION
+
+If a method for an operation is not found, and the value for C<"fallback"> is
+TRUE or undefined, Perl tries to autogenerate a substitute method for
+the missing operation based on the defined operations. Autogenerated method
+substitutions are possible for the following operations:
+
+=over 16
+
+=item I<Assignment forms of arithmetic operations>
+
+C<$a+=$b> can use the method for C<"+"> if the method for C<"+=">
+is not defined.
+
+=item I<Conversion operations>
+
+String, numeric, and boolean conversion are calculated in terms of one
+another if not all of them are defined.
+
+=item I<Increment and decrement>
+
+The C<++$a> operation can be expressed in terms of C<$a+=1> or C<$a+1>,
+and C<$a--> in terms of C<$a-=1> and C<$a-1>.
+
+=item C<abs($a)>
+
+can be expressed in terms of C<$aE<lt>0> and C<-$a> (or C<0-$a>).
+
+=item I<Unary minus>
+
+can be expressed in terms of subtraction.
+
+=item I<Negation>
+
+C<!> and C<not> can be expressed in terms of boolean conversion, or
+string or numerical conversion.
+
+=item I<Concatenation>
+
+can be expressed in terms of string conversion.
+
+=item I<Comparison operations>
+
+can be expressed in terms of its "spaceship" counterpart: either
+C<E<lt>=E<gt>> or C<cmp>:
+
+ <, >, <=, >=, ==, != in terms of <=>
+ lt, gt, le, ge, eq, ne in terms of cmp
+
+=item I<Copy operator>
+
+can be expressed in terms of an assignment to the dereferenced value, if this
+value is a scalar and not a reference.
+
+=back
+
+=head1 Losing overloading
+
+The restriction for the comparison operation is that even if, for example,
+`C<cmp>' should return a blessed reference, the autogenerated `C<lt>'
+function will produce only a standard logical value based on the
+numerical value of the result of `C<cmp>'. In particular, a working
+numeric conversion is needed in this case (possibly expressed in terms of
+other conversions).
+
+Similarly, C<.=> and C<x=> operators lose their mathemagical properties
+if the string conversion substitution is applied.
+
+When you chop() a mathemagical object it is promoted to a string and its
+mathemagical properties are lost. The same can happen with other
+operations as well.
+
+=head1 Run-time Overloading
+
+Since all C<use> directives are executed at compile-time, the only way to
+change overloading during run-time is to
+
+ eval 'use overload "+" => \&addmethod';
+
+You can also use
+
+ eval 'no overload "+", "--", "<="';
+
+though the use of these constructs during run-time is questionable.
+
+=head1 Public functions
+
+Package C<overload.pm> provides the following public functions:
+
+=over 5
+
+=item overload::StrVal(arg)
+
+Gives string value of C<arg> as in absence of stringify overloading.
+
+=item overload::Overloaded(arg)
+
+Returns true if C<arg> is subject to overloading of some operations.
+
+=item overload::Method(obj,op)
+
+Returns C<undef> or a reference to the method that implements C<op>.
+
+=back
+
+=head1 Overloading constants
+
+For some application Perl parser mangles constants too much. It is possible
+to hook into this process via overload::constant() and overload::remove_constant()
+functions.
+
+These functions take a hash as an argument. The recognized keys of this hash
+are
+
+=over 8
+
+=item integer
+
+to overload integer constants,
+
+=item float
+
+to overload floating point constants,
+
+=item binary
+
+to overload octal and hexadecimal constants,
+
+=item q
+
+to overload C<q>-quoted strings, constant pieces of C<qq>- and C<qx>-quoted
+strings and here-documents,
+
+=item qr
+
+to overload constant pieces of regular expressions.
+
+=back
+
+The corresponding values are references to functions which take three arguments:
+the first one is the I<initial> string form of the constant, the second one
+is how Perl interprets this constant, the third one is how the constant is used.
+Note that the initial string form does not
+contain string delimiters, and has backslashes in backslash-delimiter
+combinations stripped (thus the value of delimiter is not relevant for
+processing of this string). The return value of this function is how this
+constant is going to be interpreted by Perl. The third argument is undefined
+unless for overloaded C<q>- and C<qr>- constants, it is C<q> in single-quote
+context (comes from strings, regular expressions, and single-quote HERE
+documents), it is C<tr> for arguments of C<tr>/C<y> operators,
+it is C<s> for right-hand side of C<s>-operator, and it is C<qq> otherwise.
+
+Since an expression C<"ab$cd,,"> is just a shortcut for C<'ab' . $cd . ',,'>,
+it is expected that overloaded constant strings are equipped with reasonable
+overloaded catenation operator, otherwise absurd results will result.
+Similarly, negative numbers are considered as negations of positive constants.
+
+Note that it is probably meaningless to call the functions overload::constant()
+and overload::remove_constant() from anywhere but import() and unimport() methods.
+From these methods they may be called as
+
+ sub import {
+ shift;
+ return unless @_;
+ die "unknown import: @_" unless @_ == 1 and $_[0] eq ':constant';
+ overload::constant integer => sub {Math::BigInt->new(shift)};
+ }
+
+B<BUGS> Currently overloaded-ness of constants does not propagate
+into C<eval '...'>.
+
+=head1 IMPLEMENTATION
+
+What follows is subject to change RSN.
+
+The table of methods for all operations is cached in magic for the
+symbol table hash for the package. The cache is invalidated during
+processing of C<use overload>, C<no overload>, new function
+definitions, and changes in @ISA. However, this invalidation remains
+unprocessed until the next C<bless>ing into the package. Hence if you
+want to change overloading structure dynamically, you'll need an
+additional (fake) C<bless>ing to update the table.
+
+(Every SVish thing has a magic queue, and magic is an entry in that
+queue. This is how a single variable may participate in multiple
+forms of magic simultaneously. For instance, environment variables
+regularly have two forms at once: their %ENV magic and their taint
+magic. However, the magic which implements overloading is applied to
+the stashes, which are rarely used directly, thus should not slow down
+Perl.)
+
+If an object belongs to a package using overload, it carries a special
+flag. Thus the only speed penalty during arithmetic operations without
+overloading is the checking of this flag.
+
+In fact, if C<use overload> is not present, there is almost no overhead
+for overloadable operations, so most programs should not suffer
+measurable performance penalties. A considerable effort was made to
+minimize the overhead when overload is used in some package, but the
+arguments in question do not belong to packages using overload. When
+in doubt, test your speed with C<use overload> and without it. So far
+there have been no reports of substantial speed degradation if Perl is
+compiled with optimization turned on.
+
+There is no size penalty for data if overload is not used. The only
+size penalty if overload is used in some package is that I<all> the
+packages acquire a magic during the next C<bless>ing into the
+package. This magic is three-words-long for packages without
+overloading, and carries the cache tabel if the package is overloaded.
+
+Copying (C<$a=$b>) is shallow; however, a one-level-deep copying is
+carried out before any operation that can imply an assignment to the
+object $a (or $b) refers to, like C<$a++>. You can override this
+behavior by defining your own copy constructor (see L<"Copy Constructor">).
+
+It is expected that arguments to methods that are not explicitly supposed
+to be changed are constant (but this is not enforced).
+
+=head1 Metaphor clash
+
+One may wonder why the semantic of overloaded C<=> is so counterintuive.
+If it I<looks> counterintuive to you, you are subject to a metaphor
+clash.
+
+Here is a Perl object metaphor:
+
+I< object is a reference to blessed data>
+
+and an arithmetic metaphor:
+
+I< object is a thing by itself>.
+
+The I<main> problem of overloading C<=> is the fact that these metaphors
+imply different actions on the assignment C<$a = $b> if $a and $b are
+objects. Perl-think implies that $a becomes a reference to whatever
+$b was referencing. Arithmetic-think implies that the value of "object"
+$a is changed to become the value of the object $b, preserving the fact
+that $a and $b are separate entities.
+
+The difference is not relevant in the absence of mutators. After
+a Perl-way assignment an operation which mutates the data referenced by $a
+would change the data referenced by $b too. Effectively, after
+C<$a = $b> values of $a and $b become I<indistinguishable>.
+
+On the other hand, anyone who has used algebraic notation knows the
+expressive power of the arithmetic metaphor. Overloading works hard
+to enable this metaphor while preserving the Perlian way as far as
+possible. Since it is not not possible to freely mix two contradicting
+metaphors, overloading allows the arithmetic way to write things I<as
+far as all the mutators are called via overloaded access only>. The
+way it is done is described in L<Copy Constructor>.
+
+If some mutator methods are directly applied to the overloaded values,
+one may need to I<explicitly unlink> other values which references the
+same value:
+
+ $a = new Data 23;
+ ...
+ $b = $a; # $b is "linked" to $a
+ ...
+ $a = $a->clone; # Unlink $b from $a
+ $a->increment_by(4);
+
+Note that overloaded access makes this transparent:
+
+ $a = new Data 23;
+ $b = $a; # $b is "linked" to $a
+ $a += 4; # would unlink $b automagically
+
+However, it would not make
+
+ $a = new Data 23;
+ $a = 4; # Now $a is a plain 4, not 'Data'
+
+preserve "objectness" of $a. But Perl I<has> a way to make assignments
+to an object do whatever you want. It is just not the overload, but
+tie()ing interface (see L<perlfunc/tie>). Adding a FETCH() method
+which returns the object itself, and STORE() method which changes the
+value of the object, one can reproduce the arithmetic metaphor in its
+completeness, at least for variables which were tie()d from the start.
+
+(Note that a workaround for a bug may be needed, see L<"BUGS">.)
+
+=head1 Cookbook
+
+Please add examples to what follows!
+
+=head2 Two-face scalars
+
+Put this in F<two_face.pm> in your Perl library directory:
+
+ package two_face; # Scalars with separate string and
+ # numeric values.
+ sub new { my $p = shift; bless [@_], $p }
+ use overload '""' => \&str, '0+' => \&num, fallback => 1;
+ sub num {shift->[1]}
+ sub str {shift->[0]}
+
+Use it as follows:
+
+ require two_face;
+ my $seven = new two_face ("vii", 7);
+ printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1;
+ print "seven contains `i'\n" if $seven =~ /i/;
+
+(The second line creates a scalar which has both a string value, and a
+numeric value.) This prints:
+
+ seven=vii, seven=7, eight=8
+ seven contains `i'
+
+=head2 Symbolic calculator
+
+Put this in F<symbolic.pm> in your Perl library directory:
+
+ package symbolic; # Primitive symbolic calculator
+ use overload nomethod => \&wrap;
+
+ sub new { shift; bless ['n', @_] }
+ sub wrap {
+ my ($obj, $other, $inv, $meth) = @_;
+ ($obj, $other) = ($other, $obj) if $inv;
+ bless [$meth, $obj, $other];
+ }
+
+This module is very unusual as overloaded modules go: it does not
+provide any usual overloaded operators, instead it provides the L<Last
+Resort> operator C<nomethod>. In this example the corresponding
+subroutine returns an object which encupsulates operations done over
+the objects: C<new symbolic 3> contains C<['n', 3]>, C<2 + new
+symbolic 3> contains C<['+', 2, ['n', 3]]>.
+
+Here is an example of the script which "calculates" the side of
+circumscribed octagon using the above package:
+
+ require symbolic;
+ my $iter = 1; # 2**($iter+2) = 8
+ my $side = new symbolic 1;
+ my $cnt = $iter;
+
+ while ($cnt--) {
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ print "OK\n";
+
+The value of $side is
+
+ ['/', ['-', ['sqrt', ['+', 1, ['**', ['n', 1], 2]],
+ undef], 1], ['n', 1]]
+
+Note that while we obtained this value using a nice little script,
+there is no simple way to I<use> this value. In fact this value may
+be inspected in debugger (see L<perldebug>), but ony if
+C<bareStringify> B<O>ption is set, and not via C<p> command.
+
+If one attempts to print this value, then the overloaded operator
+C<""> will be called, which will call C<nomethod> operator. The
+result of this operator will be stringified again, but this result is
+again of type C<symbolic>, which will lead to an infinite loop.
+
+Add a pretty-printer method to the module F<symbolic.pm>:
+
+ sub pretty {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ $b = 'u' unless defined $b;
+ $a = $a->pretty if ref $a;
+ $b = $b->pretty if ref $b;
+ "[$meth $a $b]";
+ }
+
+Now one can finish the script by
+
+ print "side = ", $side->pretty, "\n";
+
+The method C<pretty> is doing object-to-string conversion, so it
+is natural to overload the operator C<""> using this method. However,
+inside such a method it is not necessary to pretty-print the
+I<components> $a and $b of an object. In the above subroutine
+C<"[$meth $a $b]"> is a catenation of some strings and components $a
+and $b. If these components use overloading, the catenation operator
+will look for an overloaded operator C<.>, if not present, it will
+look for an overloaded operator C<"">. Thus it is enough to use
+
+ use overload nomethod => \&wrap, '""' => \&str;
+ sub str {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ $b = 'u' unless defined $b;
+ "[$meth $a $b]";
+ }
+
+Now one can change the last line of the script to
+
+ print "side = $side\n";
+
+which outputs
+
+ side = [/ [- [sqrt [+ 1 [** [n 1 u] 2]] u] 1] [n 1 u]]
+
+and one can inspect the value in debugger using all the possible
+methods.
+
+Something is is still amiss: consider the loop variable $cnt of the
+script. It was a number, not an object. We cannot make this value of
+type C<symbolic>, since then the loop will not terminate.
+
+Indeed, to terminate the cycle, the $cnt should become false.
+However, the operator C<bool> for checking falsity is overloaded (this
+time via overloaded C<"">), and returns a long string, thus any object
+of type C<symbolic> is true. To overcome this, we need a way to
+compare an object to 0. In fact, it is easier to write a numeric
+conversion routine.
+
+Here is the text of F<symbolic.pm> with such a routine added (and
+slightly modifed str()):
+
+ package symbolic; # Primitive symbolic calculator
+ use overload
+ nomethod => \&wrap, '""' => \&str, '0+' => \&num;
+
+ sub new { shift; bless ['n', @_] }
+ sub wrap {
+ my ($obj, $other, $inv, $meth) = @_;
+ ($obj, $other) = ($other, $obj) if $inv;
+ bless [$meth, $obj, $other];
+ }
+ sub str {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ if (defined $b) {
+ "[$meth $a $b]";
+ } else {
+ "[$meth $a]";
+ }
+ }
+ my %subr = ( n => sub {$_[0]},
+ sqrt => sub {sqrt $_[0]},
+ '-' => sub {shift() - shift()},
+ '+' => sub {shift() + shift()},
+ '/' => sub {shift() / shift()},
+ '*' => sub {shift() * shift()},
+ '**' => sub {shift() ** shift()},
+ );
+ sub num {
+ my ($meth, $a, $b) = @{+shift};
+ my $subr = $subr{$meth}
+ or die "Do not know how to ($meth) in symbolic";
+ $a = $a->num if ref $a eq __PACKAGE__;
+ $b = $b->num if ref $b eq __PACKAGE__;
+ $subr->($a,$b);
+ }
+
+All the work of numeric conversion is done in %subr and num(). Of
+course, %subr is not complete, it contains only operators used in teh
+example below. Here is the extra-credit question: why do we need an
+explicit recursion in num()? (Answer is at the end of this section.)
+
+Use this module like this:
+
+ require symbolic;
+ my $iter = new symbolic 2; # 16-gon
+ my $side = new symbolic 1;
+ my $cnt = $iter;
+
+ while ($cnt) {
+ $cnt = $cnt - 1; # Mutator `--' not implemented
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ printf "%s=%f\n", $side, $side;
+ printf "pi=%f\n", $side*(2**($iter+2));
+
+It prints (without so many line breaks)
+
+ [/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1]
+ [n 1]] 2]]] 1]
+ [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]=0.198912
+ pi=3.182598
+
+The above module is very primitive. It does not implement
+mutator methods (C<++>, C<-=> and so on), does not do deep copying
+(not required without mutators!), and implements only those arithmetic
+operations which are used in the example.
+
+To implement most arithmetic operattions is easy, one should just use
+the tables of operations, and change the code which fills %subr to
+
+ my %subr = ( 'n' => sub {$_[0]} );
+ foreach my $op (split " ", $overload::ops{with_assign}) {
+ $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+ }
+ my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+ foreach my $op (split " ", "@overload::ops{ @bins }") {
+ $subr{$op} = eval "sub {shift() $op shift()}";
+ }
+ foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+ print "defining `$op'\n";
+ $subr{$op} = eval "sub {$op shift()}";
+ }
+
+Due to L<Calling Conventions for Mutators>, we do not need anything
+special to make C<+=> and friends work, except filling C<+=> entry of
+%subr, and defining a copy constructor (needed since Perl has no
+way to know that the implementation of C<'+='> does not mutate
+the argument, compare L<Copy Constructor>).
+
+To implement a copy constructor, add C<'=' => \&cpy> to C<use overload>
+line, and code (this code assumes that mutators change things one level
+deep only, so recursive copying is not needed):
+
+ sub cpy {
+ my $self = shift;
+ bless [@$self], ref $self;
+ }
+
+To make C<++> and C<--> work, we need to implement actual mutators,
+either directly, or in C<nomethod>. We continue to do things inside
+C<nomethod>, thus add
+
+ if ($meth eq '++' or $meth eq '--') {
+ @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
+ return $obj;
+ }
+
+after the first line of wrap(). This is not a most effective
+implementation, one may consider
+
+ sub inc { $_[0] = bless ['++', shift, 1]; }
+
+instead.
+
+As a final remark, note that one can fill %subr by
+
+ my %subr = ( 'n' => sub {$_[0]} );
+ foreach my $op (split " ", $overload::ops{with_assign}) {
+ $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+ }
+ my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+ foreach my $op (split " ", "@overload::ops{ @bins }") {
+ $subr{$op} = eval "sub {shift() $op shift()}";
+ }
+ foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+ $subr{$op} = eval "sub {$op shift()}";
+ }
+ $subr{'++'} = $subr{'+'};
+ $subr{'--'} = $subr{'-'};
+
+This finishes implementation of a primitive symbolic calculator in
+50 lines of Perl code. Since the numeric values of subexpressions
+are not cached, the calculator is very slow.
+
+Here is the answer for the exercise: In the case of str(), we need no
+explicit recursion since the overloaded C<.>-operator will fall back
+to an existing overloaded operator C<"">. Overloaded arithmetic
+operators I<do not> fall back to numeric conversion if C<fallback> is
+not explicitly requested. Thus without an explicit recursion num()
+would convert C<['+', $a, $b]> to C<$a + $b>, which would just rebuild
+the argument of num().
+
+If you wonder why defaults for conversion are different for str() and
+num(), note how easy it was to write the symbolic calculator. This
+simplicity is due to an appropriate choice of defaults. One extra
+note: due to teh explicit recursion num() is more fragile than sym():
+we need to explicitly check for the type of $a and $b. If componets
+$a and $b happen to be of some related type, this may lead to problems.
+
+=head2 I<Really> symbolic calculator
+
+One may wonder why we call the above calculator symbolic. The reason
+is that the actual calculation of the value of expression is postponed
+until the value is I<used>.
+
+To see it in action, add a method
+
+ sub STORE {
+ my $obj = shift;
+ $#$obj = 1;
+ @$obj->[0,1] = ('=', shift);
+ }
+
+to the package C<symbolic>. After this change one can do
+
+ my $a = new symbolic 3;
+ my $b = new symbolic 4;
+ my $c = sqrt($a**2 + $b**2);
+
+and the numeric value of $c becomes 5. However, after calling
+
+ $a->STORE(12); $b->STORE(5);
+
+the numeric value of $c becomes 13. There is no doubt now that the module
+symbolic provides a I<symbolic> calculator indeed.
+
+To hide the rough edges under the hood, provide a tie()d interface to the
+package C<symbolic> (compare with L<Metaphor clash>). Add methods
+
+ sub TIESCALAR { my $pack = shift; $pack->new(@_) }
+ sub FETCH { shift }
+ sub nop { } # Around a bug
+
+(the bug is described in L<"BUGS">). One can use this new interface as
+
+ tie $a, 'symbolic', 3;
+ tie $b, 'symbolic', 4;
+ $a->nop; $b->nop; # Around a bug
+
+ my $c = sqrt($a**2 + $b**2);
+
+Now numeric value of $c is 5. After C<$a = 12; $b = 5> the numeric value
+of $c becomes 13. To insulate the user of the module add a method
+
+ sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+
+Now
+
+ my ($a, $b);
+ symbolic->vars($a, $b);
+ my $c = sqrt($a**2 + $b**2);
+
+ $a = 3; $b = 4;
+ printf "c5 %s=%f\n", $c, $c;
+
+ $a = 12; $b = 5;
+ printf "c13 %s=%f\n", $c, $c;
+
+shows that the numeric value of $c follows changes to the values of $a
+and $b.
+
+=head1 AUTHOR
+
+Ilya Zakharevich E<lt>F<ilya@math.mps.ohio-state.edu>E<gt>.
+
+=head1 DIAGNOSTICS
+
+When Perl is run with the B<-Do> switch or its equivalent, overloading
+induces diagnostic messages.
+
+Using the C<m> command of Perl debugger (see L<perldebug>) one can
+deduce which operations are overloaded (and which ancestor triggers
+this overloading). Say, if C<eq> is overloaded, then the method C<(eq>
+is shown by debugger. The method C<()> corresponds to the C<fallback>
+key (in fact a presence of this method shows that this package has
+overloading enabled, and it is what is used by the C<Overloaded>
+function of module C<overload>).
+
+=head1 BUGS
+
+Because it is used for overloading, the per-package hash %OVERLOAD now
+has a special meaning in Perl. The symbol table is filled with names
+looking like line-noise.
+
+For the purpose of inheritance every overloaded package behaves as if
+C<fallback> is present (possibly undefined). This may create
+interesting effects if some package is not overloaded, but inherits
+from two overloaded packages.
+
+Relation between overloading and tie()ing is broken. Overloading is
+triggered or not basing on the I<previous> class of tie()d value.
+
+This happens because the presence of overloading is checked too early,
+before any tie()d access is attempted. If the FETCH()ed class of the
+tie()d value does not change, a simple workaround is to access the value
+immediately after tie()ing, so that after this call the I<previous> class
+coincides with the current one.
+
+B<Needed:> a way to fix this without a speed penalty.
+
+Barewords are not covered by overloaded string constants.
+
+This document is confusing. There are grammos and misleading language
+used in places. It would seem a total rewrite is needed.
+
+=cut
+
diff --git a/contrib/perl5/lib/perl5db.pl b/contrib/perl5/lib/perl5db.pl
new file mode 100644
index 000000000000..099a49b49f09
--- /dev/null
+++ b/contrib/perl5/lib/perl5db.pl
@@ -0,0 +1,2183 @@
+package DB;
+
+# Debugger for Perl 5.00x; perl5db.pl patch level:
+
+$VERSION = 1.0401;
+$header = "perl5db.pl version $VERSION";
+
+# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
+# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
+
+# modified Perl debugger, to be run from Emacs in perldb-mode
+# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
+# Johan Vromans -- upgrade to 4.0 pl 10
+# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
+
+#
+# This file is automatically included if you do perl -d.
+# It's probably not useful to include this yourself.
+#
+# Perl supplies the values for %sub. It effectively inserts
+# a &DB'DB(); in front of every place that can have a
+# breakpoint. Instead of a subroutine call it calls &DB::sub with
+# $DB::sub being the called subroutine. It also inserts a BEGIN
+# {require 'perl5db.pl'} before the first line.
+#
+# After each `require'd file is compiled, but before it is executed, a
+# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
+# $filename is the expanded name of the `require'd file (as found as
+# value of %INC).
+#
+# Additional services from Perl interpreter:
+#
+# if caller() is called from the package DB, it provides some
+# additional data.
+#
+# The array @{$main::{'_<'.$filename} is the line-by-line contents of
+# $filename.
+#
+# The hash %{'_<'.$filename} contains breakpoints and action (it is
+# keyed by line number), and individual entries are settable (as
+# opposed to the whole hash). Only true/false is important to the
+# interpreter, though the values used by perl5db.pl have the form
+# "$break_condition\0$action". Values are magical in numeric context.
+#
+# The scalar ${'_<'.$filename} contains "_<$filename".
+#
+# Note that no subroutine call is possible until &DB::sub is defined
+# (for subroutines defined outside of the package DB). In fact the same is
+# true if $deep is not defined.
+#
+# $Log: perldb.pl,v $
+
+#
+# At start reads $rcfile that may set important options. This file
+# may define a subroutine &afterinit that will be executed after the
+# debugger is initialized.
+#
+# After $rcfile is read reads environment variable PERLDB_OPTS and parses
+# it as a rest of `O ...' line in debugger prompt.
+#
+# The options that can be specified only at startup:
+# [To set in $rcfile, call &parse_options("optionName=new_value").]
+#
+# TTY - the TTY to use for debugging i/o.
+#
+# noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
+# uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
+# Term::Rendezvous. Current variant is to have the name of TTY in this
+# file.
+#
+# ReadLine - If false, dummy ReadLine is used, so you can debug
+# ReadLine applications.
+#
+# NonStop - if true, no i/o is performed until interrupt.
+#
+# LineInfo - file or pipe to print line number info to. If it is a
+# pipe, a short "emacs like" message is used.
+#
+# Example $rcfile: (delete leading hashes!)
+#
+# &parse_options("NonStop=1 LineInfo=db.out");
+# sub afterinit { $trace = 1; }
+#
+# The script will run without human intervention, putting trace
+# information into db.out. (If you interrupt it, you would better
+# reset LineInfo to something "interactive"!)
+#
+##################################################################
+# Changelog:
+
+# A lot of things changed after 0.94. First of all, core now informs
+# debugger about entry into XSUBs, overloaded operators, tied operations,
+# BEGIN and END. Handy with `O f=2'.
+
+# This can make debugger a little bit too verbose, please be patient
+# and report your problems promptly.
+
+# Now the option frame has 3 values: 0,1,2.
+
+# Note that if DESTROY returns a reference to the object (or object),
+# the deletion of data may be postponed until the next function call,
+# due to the need to examine the return value.
+
+# Changes: 0.95: `v' command shows versions.
+# Changes: 0.96: `v' command shows version of readline.
+# primitive completion works (dynamic variables, subs for `b' and `l',
+# options). Can `p %var'
+# Better help (`h <' now works). New commands <<, >>, {, {{.
+# {dump|print}_trace() coded (to be able to do it from <<cmd).
+# `c sub' documented.
+# At last enough magic combined to stop after the end of debuggee.
+# !! should work now (thanks to Emacs bracket matching an extra
+# `]' in a regexp is caught).
+# `L', `D' and `A' span files now (as documented).
+# Breakpoints in `require'd code are possible (used in `R').
+# Some additional words on internal work of debugger.
+# `b load filename' implemented.
+# `b postpone subr' implemented.
+# now only `q' exits debugger (overwriteable on $inhibit_exit).
+# When restarting debugger breakpoints/actions persist.
+# Buglet: When restarting debugger only one breakpoint/action per
+# autoloaded function persists.
+# Changes: 0.97: NonStop will not stop in at_exit().
+# Option AutoTrace implemented.
+# Trace printed differently if frames are printed too.
+# new `inhibitExit' option.
+# printing of a very long statement interruptible.
+# Changes: 0.98: New command `m' for printing possible methods
+# 'l -' is a synonim for `-'.
+# Cosmetic bugs in printing stack trace.
+# `frame' & 8 to print "expanded args" in stack trace.
+# Can list/break in imported subs.
+# new `maxTraceLen' option.
+# frame & 4 and frame & 8 granted.
+# new command `m'
+# nonstoppable lines do not have `:' near the line number.
+# `b compile subname' implemented.
+# Will not use $` any more.
+# `-' behaves sane now.
+# Changes: 0.99: Completion for `f', `m'.
+# `m' will remove duplicate names instead of duplicate functions.
+# `b load' strips trailing whitespace.
+# completion ignores leading `|'; takes into account current package
+# when completing a subroutine name (same for `l').
+
+####################################################################
+
+# Needed for the statement after exec():
+
+BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
+local($^W) = 0; # Switch run-time warnings off during init.
+warn ( # Do not ;-)
+ $dumpvar::hashDepth,
+ $dumpvar::arrayDepth,
+ $dumpvar::dumpDBFiles,
+ $dumpvar::dumpPackages,
+ $dumpvar::quoteHighBit,
+ $dumpvar::printUndef,
+ $dumpvar::globPrint,
+ $dumpvar::usageOnly,
+ @ARGS,
+ $Carp::CarpLevel,
+ $panic,
+ $second_time,
+ ) if 0;
+
+# Command-line + PERLLIB:
+@ini_INC = @INC;
+
+# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
+
+$trace = $signal = $single = 0; # Uninitialized warning suppression
+ # (local $^W cannot help - other packages!).
+$inhibit_exit = $option{PrintRet} = 1;
+
+@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
+ compactDump veryCompact quote HighBit undefPrint
+ globPrint PrintRet UsageOnly frame AutoTrace
+ TTY noTTY ReadLine NonStop LineInfo maxTraceLen
+ recallCommand ShellBang pager tkRunning ornaments
+ signalLevel warnLevel dieLevel inhibit_exit
+ ImmediateStop bareStringify);
+
+%optionVars = (
+ hashDepth => \$dumpvar::hashDepth,
+ arrayDepth => \$dumpvar::arrayDepth,
+ DumpDBFiles => \$dumpvar::dumpDBFiles,
+ DumpPackages => \$dumpvar::dumpPackages,
+ DumpReused => \$dumpvar::dumpReused,
+ HighBit => \$dumpvar::quoteHighBit,
+ undefPrint => \$dumpvar::printUndef,
+ globPrint => \$dumpvar::globPrint,
+ UsageOnly => \$dumpvar::usageOnly,
+ bareStringify => \$dumpvar::bareStringify,
+ frame => \$frame,
+ AutoTrace => \$trace,
+ inhibit_exit => \$inhibit_exit,
+ maxTraceLen => \$maxtrace,
+ ImmediateStop => \$ImmediateStop,
+);
+
+%optionAction = (
+ compactDump => \&dumpvar::compactDump,
+ veryCompact => \&dumpvar::veryCompact,
+ quote => \&dumpvar::quote,
+ TTY => \&TTY,
+ noTTY => \&noTTY,
+ ReadLine => \&ReadLine,
+ NonStop => \&NonStop,
+ LineInfo => \&LineInfo,
+ recallCommand => \&recallCommand,
+ ShellBang => \&shellBang,
+ pager => \&pager,
+ signalLevel => \&signalLevel,
+ warnLevel => \&warnLevel,
+ dieLevel => \&dieLevel,
+ tkRunning => \&tkRunning,
+ ornaments => \&ornaments,
+ );
+
+%optionRequire = (
+ compactDump => 'dumpvar.pl',
+ veryCompact => 'dumpvar.pl',
+ quote => 'dumpvar.pl',
+ );
+
+# These guys may be defined in $ENV{PERL5DB} :
+$rl = 1 unless defined $rl;
+$warnLevel = 1 unless defined $warnLevel;
+$dieLevel = 1 unless defined $dieLevel;
+$signalLevel = 1 unless defined $signalLevel;
+$pre = [] unless defined $pre;
+$post = [] unless defined $post;
+$pretype = [] unless defined $pretype;
+warnLevel($warnLevel);
+dieLevel($dieLevel);
+signalLevel($signalLevel);
+&pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
+&recallCommand("!") unless defined $prc;
+&shellBang("!") unless defined $psh;
+$maxtrace = 400 unless defined $maxtrace;
+
+if (-e "/dev/tty") {
+ $rcfile=".perldb";
+} else {
+ $rcfile="perldb.ini";
+}
+
+if (-f $rcfile) {
+ do "./$rcfile";
+} elsif (defined $ENV{LOGDIR} and -f "$ENV{LOGDIR}/$rcfile") {
+ do "$ENV{LOGDIR}/$rcfile";
+} elsif (defined $ENV{HOME} and -f "$ENV{HOME}/$rcfile") {
+ do "$ENV{HOME}/$rcfile";
+}
+
+if (defined $ENV{PERLDB_OPTS}) {
+ parse_options($ENV{PERLDB_OPTS});
+}
+
+if (exists $ENV{PERLDB_RESTART}) {
+ delete $ENV{PERLDB_RESTART};
+ # $restart = 1;
+ @hist = get_list('PERLDB_HIST');
+ %break_on_load = get_list("PERLDB_ON_LOAD");
+ %postponed = get_list("PERLDB_POSTPONE");
+ my @had_breakpoints= get_list("PERLDB_VISITED");
+ for (0 .. $#had_breakpoints) {
+ my %pf = get_list("PERLDB_FILE_$_");
+ $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
+ }
+ my %opt = get_list("PERLDB_OPT");
+ my ($opt,$val);
+ while (($opt,$val) = each %opt) {
+ $val =~ s/[\\\']/\\$1/g;
+ parse_options("$opt'$val'");
+ }
+ @INC = get_list("PERLDB_INC");
+ @ini_INC = @INC;
+ $pretype = [get_list("PERLDB_PRETYPE")];
+ $pre = [get_list("PERLDB_PRE")];
+ $post = [get_list("PERLDB_POST")];
+ @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
+}
+
+if ($notty) {
+ $runnonstop = 1;
+} else {
+ # Is Perl being run from Emacs?
+ $emacs = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
+ $rl = 0, shift(@main::ARGV) if $emacs;
+
+ #require Term::ReadLine;
+
+ if (-e "/dev/tty") {
+ $console = "/dev/tty";
+ } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
+ $console = "con";
+ } else {
+ $console = "sys\$command";
+ }
+
+ if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
+ $console = undef;
+ }
+
+ # Around a bug:
+ if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
+ $console = undef;
+ }
+
+ $console = $tty if defined $tty;
+
+ if (defined $console) {
+ open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN");
+ open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR")
+ || open(OUT,">&STDOUT"); # so we don't dongle stdout
+ } else {
+ open(IN,"<&STDIN");
+ open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
+ $console = 'STDIN/OUT';
+ }
+ # so open("|more") can read from STDOUT and so we don't dingle stdin
+ $IN = \*IN;
+
+ $OUT = \*OUT;
+ select($OUT);
+ $| = 1; # for DB::OUT
+ select(STDOUT);
+
+ $LINEINFO = $OUT unless defined $LINEINFO;
+ $lineinfo = $console unless defined $lineinfo;
+
+ $| = 1; # for real STDOUT
+
+ $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
+ unless ($runnonstop) {
+ print $OUT "\nLoading DB routines from $header\n";
+ print $OUT ("Emacs support ",
+ $emacs ? "enabled" : "available",
+ ".\n");
+ print $OUT "\nEnter h or `h h' for help.\n\n";
+ }
+}
+
+@ARGS = @ARGV;
+for (@args) {
+ s/\'/\\\'/g;
+ s/(.*)/'$1'/ unless /^-?[\d.]+$/;
+}
+
+if (defined &afterinit) { # May be defined in $rcfile
+ &afterinit();
+}
+
+$I_m_init = 1;
+
+############################################################ Subroutines
+
+sub DB {
+ # _After_ the perl program is compiled, $single is set to 1:
+ if ($single and not $second_time++) {
+ if ($runnonstop) { # Disable until signal
+ for ($i=0; $i <= $#stack; ) {
+ $stack[$i++] &= ~1;
+ }
+ $single = 0;
+ # return; # Would not print trace!
+ } elsif ($ImmediateStop) {
+ $ImmediateStop = 0;
+ $signal = 1;
+ }
+ }
+ $runnonstop = 0 if $single or $signal; # Disable it if interactive.
+ &save;
+ ($package, $filename, $line) = caller;
+ $filename_ini = $filename;
+ $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
+ "package $package;"; # this won't let them modify, alas
+ local(*dbline) = $main::{'_<' . $filename};
+ $max = $#dbline;
+ if (($stop,$action) = split(/\0/,$dbline{$line})) {
+ if ($stop eq '1') {
+ $signal |= 1;
+ } elsif ($stop) {
+ $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
+ $dbline{$line} =~ s/;9($|\0)/$1/;
+ }
+ }
+ my $was_signal = $signal;
+ if ($trace & 2) {
+ for (my $n = 0; $n <= $#to_watch; $n++) {
+ $evalarg = $to_watch[$n];
+ local $onetimeDump; # Do not output results
+ my ($val) = &eval; # Fix context (&eval is doing array)?
+ $val = ( (defined $val) ? "'$val'" : 'undef' );
+ if ($val ne $old_watch[$n]) {
+ $signal = 1;
+ print $OUT <<EOP;
+Watchpoint $n:\t$to_watch[$n] changed:
+ old value:\t$old_watch[$n]
+ new value:\t$val
+EOP
+ $old_watch[$n] = $val;
+ }
+ }
+ }
+ if ($trace & 4) { # User-installed watch
+ return if watchfunction($package, $filename, $line)
+ and not $single and not $was_signal and not ($trace & ~4);
+ }
+ $was_signal = $signal;
+ $signal = 0;
+ if ($single || ($trace & 1) || $was_signal) {
+ $term || &setterm;
+ if ($emacs) {
+ $position = "\032\032$filename:$line:0\n";
+ print $LINEINFO $position;
+ } elsif ($package eq 'DB::fake') {
+ print_help(<<EOP);
+Debugged program terminated. Use B<q> to quit or B<R> to restart,
+ use B<O> I<inhibit_exit> to avoid stopping after program termination,
+ B<h q>, B<h R> or B<h O> to get additional info.
+EOP
+ $package = 'main';
+ $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
+ "package $package;"; # this won't let them modify, alas
+ } else {
+ $sub =~ s/\'/::/;
+ $prefix = $sub =~ /::/ ? "" : "${'package'}::";
+ $prefix .= "$sub($filename:";
+ $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
+ if (length($prefix) > 30) {
+ $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
+ $prefix = "";
+ $infix = ":\t";
+ } else {
+ $infix = "):\t";
+ $position = "$prefix$line$infix$dbline[$line]$after";
+ }
+ if ($frame) {
+ print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
+ } else {
+ print $LINEINFO $position;
+ }
+ for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
+ last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
+ last if $signal;
+ $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
+ $incr_pos = "$prefix$i$infix$dbline[$i]$after";
+ $position .= $incr_pos;
+ if ($frame) {
+ print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
+ } else {
+ print $LINEINFO $incr_pos;
+ }
+ }
+ }
+ }
+ $evalarg = $action, &eval if $action;
+ if ($single || $was_signal) {
+ local $level = $level + 1;
+ foreach $evalarg (@$pre) {
+ &eval;
+ }
+ print $OUT $#stack . " levels deep in subroutine calls!\n"
+ if $single & 4;
+ $start = $line;
+ $incr = -1; # for backward motion.
+ @typeahead = @$pretype, @typeahead;
+ CMD:
+ while (($term || &setterm),
+ ($term_pid == $$ or &resetterm),
+ defined ($cmd=&readline(" DB" . ('<' x $level) .
+ ($#hist+1) . ('>' x $level) .
+ " "))) {
+ $single = 0;
+ $signal = 0;
+ $cmd =~ s/\\$/\n/ && do {
+ $cmd .= &readline(" cont: ");
+ redo CMD;
+ };
+ $cmd =~ /^$/ && ($cmd = $laststep);
+ push(@hist,$cmd) if length($cmd) > 1;
+ PIPE: {
+ ($i) = split(/\s+/,$cmd);
+ eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
+ $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
+ $cmd =~ /^h$/ && do {
+ print_help($help);
+ next CMD; };
+ $cmd =~ /^h\s+h$/ && do {
+ print_help($summary);
+ next CMD; };
+ $cmd =~ /^h\s+(\S)$/ && do {
+ my $asked = "\Q$1";
+ if ($help =~ /^(?:[IB]<)$asked/m) {
+ while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
+ print_help($1);
+ }
+ } else {
+ print_help("B<$asked> is not a debugger command.\n");
+ }
+ next CMD; };
+ $cmd =~ /^t$/ && do {
+ ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
+ print $OUT "Trace = " .
+ (($trace & 1) ? "on" : "off" ) . "\n";
+ next CMD; };
+ $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
+ $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
+ foreach $subname (sort(keys %sub)) {
+ if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
+ print $OUT $subname,"\n";
+ }
+ }
+ next CMD; };
+ $cmd =~ /^v$/ && do {
+ list_versions(); next CMD};
+ $cmd =~ s/^X\b/V $package/;
+ $cmd =~ /^V$/ && do {
+ $cmd = "V $package"; };
+ $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
+ local ($savout) = select($OUT);
+ $packname = $1;
+ @vars = split(' ',$2);
+ do 'dumpvar.pl' unless defined &main::dumpvar;
+ if (defined &main::dumpvar) {
+ local $frame = 0;
+ local $doret = -2;
+ &main::dumpvar($packname,@vars);
+ } else {
+ print $OUT "dumpvar.pl not available.\n";
+ }
+ select ($savout);
+ next CMD; };
+ $cmd =~ s/^x\b/ / && do { # So that will be evaled
+ $onetimeDump = 'dump'; };
+ $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
+ methods($1); next CMD};
+ $cmd =~ s/^m\b/ / && do { # So this will be evaled
+ $onetimeDump = 'methods'; };
+ $cmd =~ /^f\b\s*(.*)/ && do {
+ $file = $1;
+ $file =~ s/\s+$//;
+ if (!$file) {
+ print $OUT "The old f command is now the r command.\n";
+ print $OUT "The new f command switches filenames.\n";
+ next CMD;
+ }
+ if (!defined $main::{'_<' . $file}) {
+ if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
+ $try = substr($try,2);
+ print $OUT "Choosing $try matching `$file':\n";
+ $file = $try;
+ }}
+ }
+ if (!defined $main::{'_<' . $file}) {
+ print $OUT "No file matching `$file' is loaded.\n";
+ next CMD;
+ } elsif ($file ne $filename) {
+ *dbline = $main::{'_<' . $file};
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } else {
+ print $OUT "Already in $file.\n";
+ next CMD;
+ }
+ };
+ $cmd =~ s/^l\s+-\s*$/-/;
+ $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
+ $subname = $1;
+ $subname =~ s/\'/::/;
+ $subname = $package."::".$subname
+ unless $subname =~ /::/;
+ $subname = "main".$subname if substr($subname,0,2) eq "::";
+ @pieces = split(/:/,find_sub($subname));
+ $subrange = pop @pieces;
+ $file = join(':', @pieces);
+ if ($file ne $filename) {
+ *dbline = $main::{'_<' . $file};
+ $max = $#dbline;
+ $filename = $file;
+ }
+ if ($subrange) {
+ if (eval($subrange) < -$window) {
+ $subrange =~ s/-.*/+/;
+ }
+ $cmd = "l $subrange";
+ } else {
+ print $OUT "Subroutine $subname not found.\n";
+ next CMD;
+ } };
+ $cmd =~ /^\.$/ && do {
+ $incr = -1; # for backward motion.
+ $start = $line;
+ $filename = $filename_ini;
+ *dbline = $main::{'_<' . $filename};
+ $max = $#dbline;
+ print $LINEINFO $position;
+ next CMD };
+ $cmd =~ /^w\b\s*(\d*)$/ && do {
+ $incr = $window - 1;
+ $start = $1 if $1;
+ $start -= $preview;
+ #print $OUT 'l ' . $start . '-' . ($start + $incr);
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^-$/ && do {
+ $start -= $incr + $window + 1;
+ $start = 1 if $start <= 0;
+ $incr = $window - 1;
+ $cmd = 'l ' . ($start) . '+'; };
+ $cmd =~ /^l$/ && do {
+ $incr = $window - 1;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
+ $start = $1 if $1;
+ $incr = $2;
+ $incr = $window - 1 unless $incr;
+ $cmd = 'l ' . $start . '-' . ($start + $incr); };
+ $cmd =~ /^l\b\s*((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
+ $end = (!defined $2) ? $max : ($4 ? $4 : $2);
+ $end = $max if $end > $max;
+ $i = $2;
+ $i = $line if $i eq '.';
+ $i = 1 if $i < 1;
+ $incr = $end - $i;
+ if ($emacs) {
+ print $OUT "\032\032$filename:$i:0\n";
+ $i = $end;
+ } else {
+ for (; $i <= $end; $i++) {
+ ($stop,$action) = split(/\0/, $dbline{$i});
+ $arrow = ($i==$line
+ and $filename eq $filename_ini)
+ ? '==>'
+ : ($dbline[$i]+0 ? ':' : ' ') ;
+ $arrow .= 'b' if $stop;
+ $arrow .= 'a' if $action;
+ print $OUT "$i$arrow\t", $dbline[$i];
+ last if $signal;
+ }
+ }
+ $start = $i; # remember in case they want more
+ $start = $max if $start > $max;
+ next CMD; };
+ $cmd =~ /^D$/ && do {
+ print $OUT "Deleting all breakpoints...\n";
+ my $file;
+ for $file (keys %had_breakpoints) {
+ local *dbline = $main::{'_<' . $file};
+ my $max = $#dbline;
+ my $was;
+
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ($dbline{$i} =~ s/^\0?$//) {
+ delete $dbline{$i};
+ }
+ }
+ }
+ }
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
+ undef %had_breakpoints;
+ next CMD; };
+ $cmd =~ /^L$/ && do {
+ my $file;
+ for $file (keys %had_breakpoints) {
+ local *dbline = $main::{'_<' . $file};
+ my $max = $#dbline;
+ my $was;
+
+ for ($i = 1; $i <= $max; $i++) {
+ if (defined $dbline{$i}) {
+ print "$file:\n" unless $was++;
+ print $OUT " $i:\t", $dbline[$i];
+ ($stop,$action) = split(/\0/, $dbline{$i});
+ print $OUT " break if (", $stop, ")\n"
+ if $stop;
+ print $OUT " action: ", $action, "\n"
+ if $action;
+ last if $signal;
+ }
+ }
+ }
+ if (%postponed) {
+ print $OUT "Postponed breakpoints in subroutines:\n";
+ my $subname;
+ for $subname (keys %postponed) {
+ print $OUT " $subname\t$postponed{$subname}\n";
+ last if $signal;
+ }
+ }
+ my @have = map { # Combined keys
+ keys %{$postponed_file{$_}}
+ } keys %postponed_file;
+ if (@have) {
+ print $OUT "Postponed breakpoints in files:\n";
+ my ($file, $line);
+ for $file (keys %postponed_file) {
+ my $db = $postponed_file{$file};
+ print $OUT " $file:\n";
+ for $line (sort {$a <=> $b} keys %$db) {
+ print $OUT " $line:\n";
+ my ($stop,$action) = split(/\0/, $$db{$line});
+ print $OUT " break if (", $stop, ")\n"
+ if $stop;
+ print $OUT " action: ", $action, "\n"
+ if $action;
+ last if $signal;
+ }
+ last if $signal;
+ }
+ }
+ if (%break_on_load) {
+ print $OUT "Breakpoints on load:\n";
+ my $file;
+ for $file (keys %break_on_load) {
+ print $OUT " $file\n";
+ last if $signal;
+ }
+ }
+ if ($trace & 2) {
+ print $OUT "Watch-expressions:\n";
+ my $expr;
+ for $expr (@to_watch) {
+ print $OUT " $expr\n";
+ last if $signal;
+ }
+ }
+ next CMD; };
+ $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
+ my $file = $1; $file =~ s/\s+$//;
+ {
+ $break_on_load{$file} = 1;
+ $break_on_load{$::INC{$file}} = 1 if $::INC{$file};
+ $file .= '.pm', redo unless $file =~ /\./;
+ }
+ $had_breakpoints{$file} = 1;
+ print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
+ next CMD; };
+ $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
+ my $cond = $3 || '1';
+ my ($subname, $break) = ($2, $1 eq 'postpone');
+ $subname =~ s/\'/::/;
+ $subname = "${'package'}::" . $subname
+ unless $subname =~ /::/;
+ $subname = "main".$subname if substr($subname,0,2) eq "::";
+ $postponed{$subname} = $break
+ ? "break +0 if $cond" : "compile";
+ next CMD; };
+ $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
+ $subname = $1;
+ $cond = $2 || '1';
+ $subname =~ s/\'/::/;
+ $subname = "${'package'}::" . $subname
+ unless $subname =~ /::/;
+ $subname = "main".$subname if substr($subname,0,2) eq "::";
+ # Filename below can contain ':'
+ ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
+ $i += 0;
+ if ($i) {
+ $filename = $file;
+ *dbline = $main::{'_<' . $filename};
+ $had_breakpoints{$filename} = 1;
+ $max = $#dbline;
+ ++$i while $dbline[$i] == 0 && $i < $max;
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ } else {
+ print $OUT "Subroutine $subname not found.\n";
+ }
+ next CMD; };
+ $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
+ $i = ($1?$1:$line);
+ $cond = $2 || '1';
+ if ($dbline[$i] == 0) {
+ print $OUT "Line $i not breakable.\n";
+ } else {
+ $had_breakpoints{$filename} = 1;
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ }
+ next CMD; };
+ $cmd =~ /^d\b\s*(\d+)?/ && do {
+ $i = ($1?$1:$line);
+ $dbline{$i} =~ s/^[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ next CMD; };
+ $cmd =~ /^A$/ && do {
+ my $file;
+ for $file (keys %had_breakpoints) {
+ local *dbline = $main::{'_<' . $file};
+ my $max = $#dbline;
+ my $was;
+
+ for ($i = 1; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ }
+ }
+ next CMD; };
+ $cmd =~ /^O\s*$/ && do {
+ for (@options) {
+ &dump_option($_);
+ }
+ next CMD; };
+ $cmd =~ /^O\s*(\S.*)/ && do {
+ parse_options($1);
+ next CMD; };
+ $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
+ push @$pre, action($1);
+ next CMD; };
+ $cmd =~ /^>>\s*(.*)/ && do {
+ push @$post, action($1);
+ next CMD; };
+ $cmd =~ /^<\s*(.*)/ && do {
+ $pre = [], next CMD unless $1;
+ $pre = [action($1)];
+ next CMD; };
+ $cmd =~ /^>\s*(.*)/ && do {
+ $post = [], next CMD unless $1;
+ $post = [action($1)];
+ next CMD; };
+ $cmd =~ /^\{\{\s*(.*)/ && do {
+ push @$pretype, $1;
+ next CMD; };
+ $cmd =~ /^\{\s*(.*)/ && do {
+ $pretype = [], next CMD unless $1;
+ $pretype = [$1];
+ next CMD; };
+ $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
+ $i = $1; $j = $3;
+ if ($dbline[$i] == 0) {
+ print $OUT "Line $i may not have an action.\n";
+ } else {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ $dbline{$i} .= "\0" . action($j);
+ }
+ next CMD; };
+ $cmd =~ /^n$/ && do {
+ end_report(), next CMD if $finished and $level <= 1;
+ $single = 2;
+ $laststep = $cmd;
+ last CMD; };
+ $cmd =~ /^s$/ && do {
+ end_report(), next CMD if $finished and $level <= 1;
+ $single = 1;
+ $laststep = $cmd;
+ last CMD; };
+ $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
+ end_report(), next CMD if $finished and $level <= 1;
+ $subname = $i = $1;
+ if ($i =~ /\D/) { # subroutine name
+ $subname = $package."::".$subname
+ unless $subname =~ /::/;
+ ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
+ $i += 0;
+ if ($i) {
+ $filename = $file;
+ *dbline = $main::{'_<' . $filename};
+ $had_breakpoints{$filename}++;
+ $max = $#dbline;
+ ++$i while $dbline[$i] == 0 && $i < $max;
+ } else {
+ print $OUT "Subroutine $subname not found.\n";
+ next CMD;
+ }
+ }
+ if ($i) {
+ if ($dbline[$i] == 0) {
+ print $OUT "Line $i not breakable.\n";
+ next CMD;
+ }
+ $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
+ }
+ for ($i=0; $i <= $#stack; ) {
+ $stack[$i++] &= ~1;
+ }
+ last CMD; };
+ $cmd =~ /^r$/ && do {
+ end_report(), next CMD if $finished and $level <= 1;
+ $stack[$#stack] |= 1;
+ $doret = $option{PrintRet} ? $#stack - 1 : -2;
+ last CMD; };
+ $cmd =~ /^R$/ && do {
+ print $OUT "Warning: some settings and command-line options may be lost!\n";
+ my (@script, @flags, $cl);
+ push @flags, '-w' if $ini_warn;
+ # Put all the old includes at the start to get
+ # the same debugger.
+ for (@ini_INC) {
+ push @flags, '-I', $_;
+ }
+ # Arrange for setting the old INC:
+ set_list("PERLDB_INC", @ini_INC);
+ if ($0 eq '-e') {
+ for (1..$#{'::_<-e'}) { # The first line is PERL5DB
+ chomp ($cl = $ {'::_<-e'}[$_]);
+ push @script, '-e', $cl;
+ }
+ } else {
+ @script = $0;
+ }
+ set_list("PERLDB_HIST",
+ $term->Features->{getHistory}
+ ? $term->GetHistory : @hist);
+ my @had_breakpoints = keys %had_breakpoints;
+ set_list("PERLDB_VISITED", @had_breakpoints);
+ set_list("PERLDB_OPT", %option);
+ set_list("PERLDB_ON_LOAD", %break_on_load);
+ my @hard;
+ for (0 .. $#had_breakpoints) {
+ my $file = $had_breakpoints[$_];
+ *dbline = $main::{'_<' . $file};
+ next unless %dbline or $postponed_file{$file};
+ (push @hard, $file), next
+ if $file =~ /^\(eval \d+\)$/;
+ my @add;
+ @add = %{$postponed_file{$file}}
+ if $postponed_file{$file};
+ set_list("PERLDB_FILE_$_", %dbline, @add);
+ }
+ for (@hard) { # Yes, really-really...
+ # Find the subroutines in this eval
+ *dbline = $main::{'_<' . $_};
+ my ($quoted, $sub, %subs, $line) = quotemeta $_;
+ for $sub (keys %sub) {
+ next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
+ $subs{$sub} = [$1, $2];
+ }
+ unless (%subs) {
+ print $OUT
+ "No subroutines in $_, ignoring breakpoints.\n";
+ next;
+ }
+ LINES: for $line (keys %dbline) {
+ # One breakpoint per sub only:
+ my ($offset, $sub, $found);
+ SUBS: for $sub (keys %subs) {
+ if ($subs{$sub}->[1] >= $line # Not after the subroutine
+ and (not defined $offset # Not caught
+ or $offset < 0 )) { # or badly caught
+ $found = $sub;
+ $offset = $line - $subs{$sub}->[0];
+ $offset = "+$offset", last SUBS if $offset >= 0;
+ }
+ }
+ if (defined $offset) {
+ $postponed{$found} =
+ "break $offset if $dbline{$line}";
+ } else {
+ print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
+ }
+ }
+ }
+ set_list("PERLDB_POSTPONE", %postponed);
+ set_list("PERLDB_PRETYPE", @$pretype);
+ set_list("PERLDB_PRE", @$pre);
+ set_list("PERLDB_POST", @$post);
+ set_list("PERLDB_TYPEAHEAD", @typeahead);
+ $ENV{PERLDB_RESTART} = 1;
+ #print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
+ exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
+ print $OUT "exec failed: $!\n";
+ last CMD; };
+ $cmd =~ /^T$/ && do {
+ print_trace($OUT, 1); # skip DB
+ next CMD; };
+ $cmd =~ /^W\s*$/ && do {
+ $trace &= ~2;
+ @to_watch = @old_watch = ();
+ next CMD; };
+ $cmd =~ /^W\b\s*(.*)/s && do {
+ push @to_watch, $1;
+ $evalarg = $1;
+ my ($val) = &eval;
+ $val = (defined $val) ? "'$val'" : 'undef' ;
+ push @old_watch, $val;
+ $trace |= 2;
+ next CMD; };
+ $cmd =~ /^\/(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])/$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\a$inpat\a";
+ if ($@ ne "") {
+ print $OUT "$@";
+ next CMD;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ $incr = -1;
+ eval '
+ for (;;) {
+ ++$start;
+ $start = 1 if ($start > $max);
+ last if ($start == $end);
+ if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
+ if ($emacs) {
+ print $OUT "\032\032$filename:$start:0\n";
+ } else {
+ print $OUT "$start:\t", $dbline[$start], "\n";
+ }
+ last;
+ }
+ } ';
+ print $OUT "/$pat/: not found\n" if ($start == $end);
+ next CMD; };
+ $cmd =~ /^\?(.*)$/ && do {
+ $inpat = $1;
+ $inpat =~ s:([^\\])\?$:$1:;
+ if ($inpat ne "") {
+ eval '$inpat =~ m'."\a$inpat\a";
+ if ($@ ne "") {
+ print $OUT "$@";
+ next CMD;
+ }
+ $pat = $inpat;
+ }
+ $end = $start;
+ $incr = -1;
+ eval '
+ for (;;) {
+ --$start;
+ $start = $max if ($start <= 0);
+ last if ($start == $end);
+ if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
+ if ($emacs) {
+ print $OUT "\032\032$filename:$start:0\n";
+ } else {
+ print $OUT "$start:\t", $dbline[$start], "\n";
+ }
+ last;
+ }
+ } ';
+ print $OUT "?$pat?: not found\n" if ($start == $end);
+ next CMD; };
+ $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
+ pop(@hist) if length($cmd) > 1;
+ $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
+ $cmd = $hist[$i];
+ print $OUT $cmd;
+ redo CMD; };
+ $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
+ &system($1);
+ next CMD; };
+ $cmd =~ /^$rc([^$rc].*)$/ && do {
+ $pat = "^$1";
+ pop(@hist) if length($cmd) > 1;
+ for ($i = $#hist; $i; --$i) {
+ last if $hist[$i] =~ /$pat/;
+ }
+ if (!$i) {
+ print $OUT "No such command!\n\n";
+ next CMD;
+ }
+ $cmd = $hist[$i];
+ print $OUT $cmd;
+ redo CMD; };
+ $cmd =~ /^$sh$/ && do {
+ &system($ENV{SHELL}||"/bin/sh");
+ next CMD; };
+ $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
+ &system($ENV{SHELL}||"/bin/sh","-c",$1);
+ next CMD; };
+ $cmd =~ /^H\b\s*(-(\d+))?/ && do {
+ $end = $2?($#hist-$2):0;
+ $hist = 0 if $hist < 0;
+ for ($i=$#hist; $i>$end; $i--) {
+ print $OUT "$i: ",$hist[$i],"\n"
+ unless $hist[$i] =~ /^.?$/;
+ };
+ next CMD; };
+ $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
+ $cmd =~ s/^p\b/print {\$DB::OUT} /;
+ $cmd =~ /^=/ && do {
+ if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
+ $alias{$k}="s~$k~$v~";
+ print $OUT "$k = $v\n";
+ } elsif ($cmd =~ /^=\s*$/) {
+ foreach $k (sort keys(%alias)) {
+ if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
+ print $OUT "$k = $v\n";
+ } else {
+ print $OUT "$k\t$alias{$k}\n";
+ };
+ };
+ };
+ next CMD; };
+ $cmd =~ /^\|\|?\s*[^|]/ && do {
+ if ($pager =~ /^\|/) {
+ open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
+ open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
+ } else {
+ open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
+ }
+ unless ($piped=open(OUT,$pager)) {
+ &warn("Can't pipe output to `$pager'");
+ if ($pager =~ /^\|/) {
+ open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
+ open(STDOUT,">&SAVEOUT")
+ || &warn("Can't restore STDOUT");
+ close(SAVEOUT);
+ } else {
+ open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
+ }
+ next CMD;
+ }
+ $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
+ && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
+ $selected= select(OUT);
+ $|= 1;
+ select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
+ $cmd =~ s/^\|+\s*//;
+ redo PIPE; };
+ # XXX Local variants do not work!
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
+ $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
+ $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
+ } # PIPE:
+ $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
+ if ($onetimeDump) {
+ $onetimeDump = undef;
+ } elsif ($term_pid == $$) {
+ print $OUT "\n";
+ }
+ } continue { # CMD:
+ if ($piped) {
+ if ($pager =~ /^\|/) {
+ $?= 0; close(OUT) || &warn("Can't close DB::OUT");
+ &warn( "Pager `$pager' failed: ",
+ ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8),
+ ( $? & 128 ) ? " (core dumped)" : "",
+ ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
+ open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
+ open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
+ $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
+ # Will stop ignoring SIGPIPE if done like nohup(1)
+ # does SIGINT but Perl doesn't give us a choice.
+ } else {
+ open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
+ }
+ close(SAVEOUT);
+ select($selected), $selected= "" unless $selected eq "";
+ $piped= "";
+ }
+ } # CMD:
+ $exiting = 1 unless defined $cmd;
+ foreach $evalarg (@$post) {
+ &eval;
+ }
+ } # if ($single || $signal)
+ ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
+ ();
+}
+
+# The following code may be executed now:
+# BEGIN {warn 4}
+
+sub sub {
+ my ($al, $ret, @ret) = "";
+ if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
+ $al = " for $$sub";
+ }
+ push(@stack, $single);
+ $single &= 1;
+ $single |= 4 if $#stack == $deep;
+ ($frame & 4
+ ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
+ # Why -1? But it works! :-(
+ print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
+ : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
+ if (wantarray) {
+ @ret = &$sub;
+ $single |= pop(@stack);
+ ($frame & 4
+ ? ( (print $LINEINFO ' ' x $#stack, "out "),
+ print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
+ : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
+ if ($doret eq $#stack or $frame & 16) {
+ my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
+ print $fh ' ' x $#stack if $frame & 16;
+ print $fh "list context return from $sub:\n";
+ dumpit($fh, \@ret );
+ $doret = -2;
+ }
+ @ret;
+ } else {
+ if (defined wantarray) {
+ $ret = &$sub;
+ } else {
+ &$sub; undef $ret;
+ };
+ $single |= pop(@stack);
+ ($frame & 4
+ ? ( (print $LINEINFO ' ' x $#stack, "out "),
+ print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
+ : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
+ if ($doret eq $#stack or $frame & 16 and defined wantarray) {
+ my $fh = ($doret eq $#stack ? $OUT : $LINEINFO);
+ print $fh (' ' x $#stack) if $frame & 16;
+ print $fh (defined wantarray
+ ? "scalar context return from $sub: "
+ : "void context return from $sub\n");
+ dumpit( $fh, $ret ) if defined wantarray;
+ $doret = -2;
+ }
+ $ret;
+ }
+}
+
+sub save {
+ @saved = ($@, $!, $^E, $,, $/, $\, $^W);
+ $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
+}
+
+# The following takes its argument via $evalarg to preserve current @_
+
+sub eval {
+ my @res;
+ {
+ local (@stack) = @stack; # guard against recursive debugging
+ my $otrace = $trace;
+ my $osingle = $single;
+ my $od = $^D;
+ @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
+ $trace = $otrace;
+ $single = $osingle;
+ $^D = $od;
+ }
+ my $at = $@;
+ local $saved[0]; # Preserve the old value of $@
+ eval { &DB::save };
+ if ($at) {
+ print $OUT $at;
+ } elsif ($onetimeDump eq 'dump') {
+ dumpit($OUT, \@res);
+ } elsif ($onetimeDump eq 'methods') {
+ methods($res[0]);
+ }
+ @res;
+}
+
+sub postponed_sub {
+ my $subname = shift;
+ if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
+ my $offset = $1 || 0;
+ # Filename below can contain ':'
+ my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
+ if ($i) {
+ $i += $offset;
+ local *dbline = $main::{'_<' . $file};
+ local $^W = 0; # != 0 is magical below
+ $had_breakpoints{$file}++;
+ my $max = $#dbline;
+ ++$i until $dbline[$i] != 0 or $i >= $max;
+ $dbline{$i} = delete $postponed{$subname};
+ } else {
+ print $OUT "Subroutine $subname not found.\n";
+ }
+ return;
+ }
+ elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
+ #print $OUT "In postponed_sub for `$subname'.\n";
+}
+
+sub postponed {
+ if ($ImmediateStop) {
+ $ImmediateStop = 0;
+ $signal = 1;
+ }
+ return &postponed_sub
+ unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
+ # Cannot be done before the file is compiled
+ local *dbline = shift;
+ my $filename = $dbline;
+ $filename =~ s/^_<//;
+ $signal = 1, print $OUT "'$filename' loaded...\n"
+ if $break_on_load{$filename};
+ print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
+ return unless $postponed_file{$filename};
+ $had_breakpoints{$filename}++;
+ #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
+ my $key;
+ for $key (keys %{$postponed_file{$filename}}) {
+ $dbline{$key} = $ {$postponed_file{$filename}}{$key};
+ }
+ delete $postponed_file{$filename};
+}
+
+sub dumpit {
+ local ($savout) = select(shift);
+ my $osingle = $single;
+ my $otrace = $trace;
+ $single = $trace = 0;
+ local $frame = 0;
+ local $doret = -2;
+ unless (defined &main::dumpValue) {
+ do 'dumpvar.pl';
+ }
+ if (defined &main::dumpValue) {
+ &main::dumpValue(shift);
+ } else {
+ print $OUT "dumpvar.pl not available.\n";
+ }
+ $single = $osingle;
+ $trace = $otrace;
+ select ($savout);
+}
+
+# Tied method do not create a context, so may get wrong message:
+
+sub print_trace {
+ my $fh = shift;
+ my @sub = dump_trace($_[0] + 1, $_[1]);
+ my $short = $_[2]; # Print short report, next one for sub name
+ my $s;
+ for ($i=0; $i <= $#sub; $i++) {
+ last if $signal;
+ local $" = ', ';
+ my $args = defined $sub[$i]{args}
+ ? "(@{ $sub[$i]{args} })"
+ : '' ;
+ $args = (substr $args, 0, $maxtrace - 3) . '...'
+ if length $args > $maxtrace;
+ my $file = $sub[$i]{file};
+ $file = $file eq '-e' ? $file : "file `$file'" unless $short;
+ $s = $sub[$i]{sub};
+ $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
+ if ($short) {
+ my $sub = @_ >= 4 ? $_[3] : $s;
+ print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
+ } else {
+ print $fh "$sub[$i]{context} = $s$args" .
+ " called from $file" .
+ " line $sub[$i]{line}\n";
+ }
+ }
+}
+
+sub dump_trace {
+ my $skip = shift;
+ my $count = shift || 1e9;
+ $skip++;
+ $count += $skip;
+ my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
+ my $nothard = not $frame & 8;
+ local $frame = 0; # Do not want to trace this.
+ my $otrace = $trace;
+ $trace = 0;
+ for ($i = $skip;
+ $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
+ $i++) {
+ @a = ();
+ for $arg (@args) {
+ my $type;
+ if (not defined $arg) {
+ push @a, "undef";
+ } elsif ($nothard and tied $arg) {
+ push @a, "tied";
+ } elsif ($nothard and $type = ref $arg) {
+ push @a, "ref($type)";
+ } else {
+ local $_ = "$arg"; # Safe to stringify now - should not call f().
+ s/([\'\\])/\\$1/g;
+ s/(.*)/'$1'/s
+ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ push(@a, $_);
+ }
+ }
+ $context = $context ? '@' : (defined $context ? "\$" : '.');
+ $args = $h ? [@a] : undef;
+ $e =~ s/\n\s*\;\s*\Z// if $e;
+ $e =~ s/([\\\'])/\\$1/g if $e;
+ if ($r) {
+ $sub = "require '$e'";
+ } elsif (defined $r) {
+ $sub = "eval '$e'";
+ } elsif ($sub eq '(eval)') {
+ $sub = "eval {...}";
+ }
+ push(@sub, {context => $context, sub => $sub, args => $args,
+ file => $file, line => $line});
+ last if $signal;
+ }
+ $trace = $otrace;
+ @sub;
+}
+
+sub action {
+ my $action = shift;
+ while ($action =~ s/\\$//) {
+ #print $OUT "+ ";
+ #$action .= "\n";
+ $action .= &gets;
+ }
+ $action;
+}
+
+sub gets {
+ local($.);
+ #<IN>;
+ &readline("cont: ");
+}
+
+sub system {
+ # We save, change, then restore STDIN and STDOUT to avoid fork() since
+ # many non-Unix systems can do system() but have problems with fork().
+ open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
+ open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
+ open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
+ open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
+ system(@_);
+ open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
+ open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
+ close(SAVEIN); close(SAVEOUT);
+ &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")",
+ ( $? & 128 ) ? " (core dumped)" : "",
+ ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?;
+ $?;
+}
+
+sub setterm {
+ local $frame = 0;
+ local $doret = -2;
+ local @stack = @stack; # Prevent growth by failing `use'.
+ eval { require Term::ReadLine } or die $@;
+ if ($notty) {
+ if ($tty) {
+ open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
+ open(OUT,">$tty") or die "Cannot open TTY `$TTY' for write: $!";
+ $IN = \*IN;
+ $OUT = \*OUT;
+ my $sel = select($OUT);
+ $| = 1;
+ select($sel);
+ } else {
+ eval "require Term::Rendezvous;" or die $@;
+ my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
+ my $term_rv = new Term::Rendezvous $rv;
+ $IN = $term_rv->IN;
+ $OUT = $term_rv->OUT;
+ }
+ }
+ if (!$rl) {
+ $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
+ } else {
+ $term = new Term::ReadLine 'perldb', $IN, $OUT;
+
+ $rl_attribs = $term->Attribs;
+ $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
+ if defined $rl_attribs->{basic_word_break_characters}
+ and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
+ $rl_attribs->{special_prefixes} = '$@&%';
+ $rl_attribs->{completer_word_break_characters} .= '$@&%';
+ $rl_attribs->{completion_function} = \&db_complete;
+ }
+ $LINEINFO = $OUT unless defined $LINEINFO;
+ $lineinfo = $console unless defined $lineinfo;
+ $term->MinLine(2);
+ if ($term->Features->{setHistory} and "@hist" ne "?") {
+ $term->SetHistory(@hist);
+ }
+ ornaments($ornaments) if defined $ornaments;
+ $term_pid = $$;
+}
+
+sub resetterm { # We forked, so we need a different TTY
+ $term_pid = $$;
+ if (defined &get_fork_TTY) {
+ &get_fork_TTY;
+ } elsif (not defined $fork_TTY
+ and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
+ and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
+ # Possibly _inside_ XTERM
+ open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
+ sleep 10000000' |];
+ $fork_TTY = <XT>;
+ chomp $fork_TTY;
+ }
+ if (defined $fork_TTY) {
+ TTY($fork_TTY);
+ undef $fork_TTY;
+ } else {
+ print_help(<<EOP);
+I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
+ Define B<\$DB::fork_TTY>
+ - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
+ The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
+ On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
+ by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
+EOP
+ }
+}
+
+sub readline {
+ if (@typeahead) {
+ my $left = @typeahead;
+ my $got = shift @typeahead;
+ print $OUT "auto(-$left)", shift, $got, "\n";
+ $term->AddHistory($got)
+ if length($got) > 1 and defined $term->Features->{addHistory};
+ return $got;
+ }
+ local $frame = 0;
+ local $doret = -2;
+ $term->readline(@_);
+}
+
+sub dump_option {
+ my ($opt, $val)= @_;
+ $val = option_val($opt,'N/A');
+ $val =~ s/([\\\'])/\\$1/g;
+ printf $OUT "%20s = '%s'\n", $opt, $val;
+}
+
+sub option_val {
+ my ($opt, $default)= @_;
+ my $val;
+ if (defined $optionVars{$opt}
+ and defined $ {$optionVars{$opt}}) {
+ $val = $ {$optionVars{$opt}};
+ } elsif (defined $optionAction{$opt}
+ and defined &{$optionAction{$opt}}) {
+ $val = &{$optionAction{$opt}}();
+ } elsif (defined $optionAction{$opt}
+ and not defined $option{$opt}
+ or defined $optionVars{$opt}
+ and not defined $ {$optionVars{$opt}}) {
+ $val = $default;
+ } else {
+ $val = $option{$opt};
+ }
+ $val
+}
+
+sub parse_options {
+ local($_)= @_;
+ while ($_ ne "") {
+ s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last;
+ my ($opt,$sep) = ($1,$2);
+ my $val;
+ if ("?" eq $sep) {
+ print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
+ if /^\S/;
+ #&dump_option($opt);
+ } elsif ($sep !~ /\S/) {
+ $val = "1";
+ } elsif ($sep eq "=") {
+ s/^(\S*)($|\s+)//;
+ $val = $1;
+ } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
+ my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
+ s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
+ print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
+ $val = $1;
+ $val =~ s/\\([\\$end])/$1/g;
+ }
+ my ($option);
+ my $matches =
+ grep( /^\Q$opt/ && ($option = $_), @options );
+ $matches = grep( /^\Q$opt/i && ($option = $_), @options )
+ unless $matches;
+ print $OUT "Unknown option `$opt'\n" unless $matches;
+ print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
+ $option{$option} = $val if $matches == 1 and defined $val;
+ eval "local \$frame = 0; local \$doret = -2;
+ require '$optionRequire{$option}'"
+ if $matches == 1 and defined $optionRequire{$option} and defined $val;
+ $ {$optionVars{$option}} = $val
+ if $matches == 1
+ and defined $optionVars{$option} and defined $val;
+ & {$optionAction{$option}} ($val)
+ if $matches == 1
+ and defined $optionAction{$option}
+ and defined &{$optionAction{$option}} and defined $val;
+ &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile
+ s/^\s+//;
+ }
+}
+
+sub set_list {
+ my ($stem,@list) = @_;
+ my $val;
+ $ENV{"$ {stem}_n"} = @list;
+ for $i (0 .. $#list) {
+ $val = $list[$i];
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
+ $ENV{"$ {stem}_$i"} = $val;
+ }
+}
+
+sub get_list {
+ my $stem = shift;
+ my @list;
+ my $n = delete $ENV{"$ {stem}_n"};
+ my $val;
+ for $i (0 .. $n - 1) {
+ $val = delete $ENV{"$ {stem}_$i"};
+ $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
+ push @list, $val;
+ }
+ @list;
+}
+
+sub catch {
+ $signal = 1;
+ return; # Put nothing on the stack - malloc/free land!
+}
+
+sub warn {
+ my($msg)= join("",@_);
+ $msg .= ": $!\n" unless $msg =~ /\n$/;
+ print $OUT $msg;
+}
+
+sub TTY {
+ if (@_ and $term and $term->Features->{newTTY}) {
+ my ($in, $out) = shift;
+ if ($in =~ /,/) {
+ ($in, $out) = split /,/, $in, 2;
+ } else {
+ $out = $in;
+ }
+ open IN, $in or die "cannot open `$in' for read: $!";
+ open OUT, ">$out" or die "cannot open `$out' for write: $!";
+ $term->newTTY(\*IN, \*OUT);
+ $IN = \*IN;
+ $OUT = \*OUT;
+ return $tty = $in;
+ } elsif ($term and @_) {
+ &warn("Too late to set TTY, enabled on next `R'!\n");
+ }
+ $tty = shift if @_;
+ $tty or $console;
+}
+
+sub noTTY {
+ if ($term) {
+ &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
+ }
+ $notty = shift if @_;
+ $notty;
+}
+
+sub ReadLine {
+ if ($term) {
+ &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
+ }
+ $rl = shift if @_;
+ $rl;
+}
+
+sub tkRunning {
+ if ($ {$term->Features}{tkRunning}) {
+ return $term->tkRunning(@_);
+ } else {
+ print $OUT "tkRunning not supported by current ReadLine package.\n";
+ 0;
+ }
+}
+
+sub NonStop {
+ if ($term) {
+ &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
+ }
+ $runnonstop = shift if @_;
+ $runnonstop;
+}
+
+sub pager {
+ if (@_) {
+ $pager = shift;
+ $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
+ }
+ $pager;
+}
+
+sub shellBang {
+ if (@_) {
+ $sh = quotemeta shift;
+ $sh .= "\\b" if $sh =~ /\w$/;
+ }
+ $psh = $sh;
+ $psh =~ s/\\b$//;
+ $psh =~ s/\\(.)/$1/g;
+ &sethelp;
+ $psh;
+}
+
+sub ornaments {
+ if (defined $term) {
+ local ($warnLevel,$dieLevel) = (0, 1);
+ return '' unless $term->Features->{ornaments};
+ eval { $term->ornaments(@_) } || '';
+ } else {
+ $ornaments = shift;
+ }
+}
+
+sub recallCommand {
+ if (@_) {
+ $rc = quotemeta shift;
+ $rc .= "\\b" if $rc =~ /\w$/;
+ }
+ $prc = $rc;
+ $prc =~ s/\\b$//;
+ $prc =~ s/\\(.)/$1/g;
+ &sethelp;
+ $prc;
+}
+
+sub LineInfo {
+ return $lineinfo unless @_;
+ $lineinfo = shift;
+ my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
+ $emacs = ($stream =~ /^\|/);
+ open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
+ $LINEINFO = \*LINEINFO;
+ my $save = select($LINEINFO);
+ $| = 1;
+ select($save);
+ $lineinfo;
+}
+
+sub list_versions {
+ my %version;
+ my $file;
+ for (keys %INC) {
+ $file = $_;
+ s,\.p[lm]$,,i ;
+ s,/,::,g ;
+ s/^perl5db$/DB/;
+ s/^Term::ReadLine::readline$/readline/;
+ if (defined $ { $_ . '::VERSION' }) {
+ $version{$file} = "$ { $_ . '::VERSION' } from ";
+ }
+ $version{$file} .= $INC{$file};
+ }
+ do 'dumpvar.pl' unless defined &main::dumpValue;
+ if (defined &main::dumpValue) {
+ local $frame = 0;
+ &main::dumpValue(\%version);
+ } else {
+ print $OUT "dumpvar.pl not available.\n";
+ }
+}
+
+sub sethelp {
+ $help = "
+B<T> Stack trace.
+B<s> [I<expr>] Single step [in I<expr>].
+B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
+<B<CR>> Repeat last B<n> or B<s> command.
+B<r> Return from current subroutine.
+B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
+ at the specified position.
+B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
+B<l> I<min>B<->I<max> List lines I<min> through I<max>.
+B<l> I<line> List single I<line>.
+B<l> I<subname> List first window of lines from subroutine.
+B<l> List next window of lines.
+B<-> List previous window of lines.
+B<w> [I<line>] List window around I<line>.
+B<.> Return to the executed line.
+B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
+B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
+B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
+B<L> List all breakpoints and actions.
+B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
+B<t> Toggle trace mode.
+B<t> I<expr> Trace through execution of I<expr>.
+B<b> [I<line>] [I<condition>]
+ Set breakpoint; I<line> defaults to the current execution line;
+ I<condition> breaks if it evaluates to true, defaults to '1'.
+B<b> I<subname> [I<condition>]
+ Set breakpoint at first line of subroutine.
+B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
+B<b> B<postpone> I<subname> [I<condition>]
+ Set breakpoint at first line of subroutine after
+ it is compiled.
+B<b> B<compile> I<subname>
+ Stop after the subroutine is compiled.
+B<d> [I<line>] Delete the breakpoint for I<line>.
+B<D> Delete all breakpoints.
+B<a> [I<line>] I<command>
+ Set an action to be done before the I<line> is executed.
+ Sequence is: check for breakpoint/watchpoint, print line
+ if necessary, do action, prompt user if necessary,
+ execute expression.
+B<A> Delete all actions.
+B<W> I<expr> Add a global watch-expression.
+B<W> Delete all watch-expressions.
+B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
+ Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
+B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
+B<x> I<expr> Evals expression in array context, dumps the result.
+B<m> I<expr> Evals expression in array context, prints methods callable
+ on the first element of the result.
+B<m> I<class> Prints methods callable via the given class.
+B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
+ Set or query values of options. I<val> defaults to 1. I<opt> can
+ be abbreviated. Several options can be listed.
+ I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
+ I<pager>: program for output of \"|cmd\";
+ I<tkRunning>: run Tk while prompting (with ReadLine);
+ I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
+ I<inhibit_exit> Allows stepping off the end of the script.
+ I<ImmediateStop> Debugger should stop as early as possible.
+ The following options affect what happens with B<V>, B<X>, and B<x> commands:
+ I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
+ I<compactDump>, I<veryCompact>: change style of array and hash dump;
+ I<globPrint>: whether to print contents of globs;
+ I<DumpDBFiles>: dump arrays holding debugged files;
+ I<DumpPackages>: dump symbol tables of packages;
+ I<DumpReused>: dump contents of \"reused\" addresses;
+ I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
+ I<bareStringify>: Do not print the overload-stringified value;
+ Option I<PrintRet> affects printing of return value after B<r> command,
+ I<frame> affects printing messages on entry and exit from subroutines.
+ I<AutoTrace> affects printing messages on every possible breaking point.
+ I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
+ I<ornaments> affects screen appearance of the command line.
+ During startup options are initialized from \$ENV{PERLDB_OPTS}.
+ You can put additional initialization options I<TTY>, I<noTTY>,
+ I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
+B<<> I<expr> Define Perl command to run before each prompt.
+B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
+B<>> I<expr> Define Perl command to run after each prompt.
+B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
+B<{> I<db_command> Define debugger command to run before each prompt.
+B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
+B<$prc> I<number> Redo a previous command (default previous command).
+B<$prc> I<-number> Redo number'th-to-last command.
+B<$prc> I<pattern> Redo last command that started with I<pattern>.
+ See 'B<O> I<recallCommand>' too.
+B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
+ . ( $rc eq $sh ? "" : "
+B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
+ See 'B<O> I<shellBang>' too.
+B<H> I<-number> Display last number commands (default all).
+B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
+B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
+B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
+B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
+I<command> Execute as a perl statement in current package.
+B<v> Show versions of loaded modules.
+B<R> Pure-man-restart of debugger, some of debugger state
+ and command-line options may be lost.
+ Currently the following setting are preserved:
+ history, breakpoints and actions, debugger B<O>ptions
+ and the following command-line options: I<-w>, I<-I>, I<-e>.
+B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
+B<h h> Summary of debugger commands.
+B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
+
+";
+ $summary = <<"END_SUM";
+I<List/search source lines:> I<Control script execution:>
+ B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
+ B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
+ B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
+ B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s>
+ B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
+ B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
+I<Debugger controls:> B<L> List break/watch/actions
+ B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
+ B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint
+ B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub
+ B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
+ B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
+ B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
+ B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
+ B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
+ B<q> or B<^D> Quit B<R> Attempt a restart
+I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
+ B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
+ B<p> I<expr> Print expression (uses script's current package).
+ B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
+ B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
+ B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
+END_SUM
+ # ')}}; # Fix balance of Emacs parsing
+}
+
+sub print_help {
+ my $message = shift;
+ if (@Term::ReadLine::TermCap::rl_term_set) {
+ $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
+ $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
+ }
+ print $OUT $message;
+}
+
+sub diesignal {
+ local $frame = 0;
+ local $doret = -2;
+ $SIG{'ABRT'} = 'DEFAULT';
+ kill 'ABRT', $$ if $panic++;
+ if (defined &Carp::longmess) {
+ local $SIG{__WARN__} = '';
+ local $Carp::CarpLevel = 2; # mydie + confess
+ &warn(Carp::longmess("Signal @_"));
+ }
+ else {
+ print $DB::OUT "Got signal @_\n";
+ }
+ kill 'ABRT', $$;
+}
+
+sub dbwarn {
+ local $frame = 0;
+ local $doret = -2;
+ local $SIG{__WARN__} = '';
+ local $SIG{__DIE__} = '';
+ eval { require Carp } if defined $^S; # If error/warning during compilation,
+ # require may be broken.
+ warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
+ return unless defined &Carp::longmess;
+ my ($mysingle,$mytrace) = ($single,$trace);
+ $single = 0; $trace = 0;
+ my $mess = Carp::longmess(@_);
+ ($single,$trace) = ($mysingle,$mytrace);
+ &warn($mess);
+}
+
+sub dbdie {
+ local $frame = 0;
+ local $doret = -2;
+ local $SIG{__DIE__} = '';
+ local $SIG{__WARN__} = '';
+ my $i = 0; my $ineval = 0; my $sub;
+ if ($dieLevel > 2) {
+ local $SIG{__WARN__} = \&dbwarn;
+ &warn(@_); # Yell no matter what
+ return;
+ }
+ if ($dieLevel < 2) {
+ die @_ if $^S; # in eval propagate
+ }
+ eval { require Carp } if defined $^S; # If error/warning during compilation,
+ # require may be broken.
+ die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
+ unless defined &Carp::longmess;
+ # We do not want to debug this chunk (automatic disabling works
+ # inside DB::DB, but not in Carp).
+ my ($mysingle,$mytrace) = ($single,$trace);
+ $single = 0; $trace = 0;
+ my $mess = Carp::longmess(@_);
+ ($single,$trace) = ($mysingle,$mytrace);
+ die $mess;
+}
+
+sub warnLevel {
+ if (@_) {
+ $prevwarn = $SIG{__WARN__} unless $warnLevel;
+ $warnLevel = shift;
+ if ($warnLevel) {
+ $SIG{__WARN__} = \&DB::dbwarn;
+ } else {
+ $SIG{__WARN__} = $prevwarn;
+ }
+ }
+ $warnLevel;
+}
+
+sub dieLevel {
+ if (@_) {
+ $prevdie = $SIG{__DIE__} unless $dieLevel;
+ $dieLevel = shift;
+ if ($dieLevel) {
+ $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
+ #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
+ print $OUT "Stack dump during die enabled",
+ ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
+ if $I_m_init;
+ print $OUT "Dump printed too.\n" if $dieLevel > 2;
+ } else {
+ $SIG{__DIE__} = $prevdie;
+ print $OUT "Default die handler restored.\n";
+ }
+ }
+ $dieLevel;
+}
+
+sub signalLevel {
+ if (@_) {
+ $prevsegv = $SIG{SEGV} unless $signalLevel;
+ $prevbus = $SIG{BUS} unless $signalLevel;
+ $signalLevel = shift;
+ if ($signalLevel) {
+ $SIG{SEGV} = \&DB::diesignal;
+ $SIG{BUS} = \&DB::diesignal;
+ } else {
+ $SIG{SEGV} = $prevsegv;
+ $SIG{BUS} = $prevbus;
+ }
+ }
+ $signalLevel;
+}
+
+sub find_sub {
+ my $subr = shift;
+ return unless defined &$subr;
+ $sub{$subr} or do {
+ $subr = \&$subr; # Hard reference
+ my $s;
+ for (keys %sub) {
+ $s = $_, last if $subr eq \&$_;
+ }
+ $sub{$s} if $s;
+ }
+}
+
+sub methods {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ local %seen;
+ local %packs;
+ methods_via($class, '', 1);
+ methods_via('UNIVERSAL', 'UNIVERSAL', 0);
+}
+
+sub methods_via {
+ my $class = shift;
+ return if $packs{$class}++;
+ my $prefix = shift;
+ my $prepend = $prefix ? "via $prefix: " : '';
+ my $name;
+ for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
+ sort keys %{"$ {class}::"}) {
+ next if $seen{ $name }++;
+ print $DB::OUT "$prepend$name\n";
+ }
+ return unless shift; # Recurse?
+ for $name (@{"$ {class}::ISA"}) {
+ $prepend = $prefix ? $prefix . " -> $name" : $name;
+ methods_via($name, $prepend, 1);
+ }
+}
+
+# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
+
+BEGIN { # This does not compile, alas.
+ $IN = \*STDIN; # For bugs before DB::OUT has been opened
+ $OUT = \*STDERR; # For errors before DB::OUT has been opened
+ $sh = '!';
+ $rc = ',';
+ @hist = ('?');
+ $deep = 100; # warning if stack gets this deep
+ $window = 10;
+ $preview = 3;
+ $sub = '';
+ $SIG{INT} = \&DB::catch;
+ # This may be enabled to debug debugger:
+ #$warnLevel = 1 unless defined $warnLevel;
+ #$dieLevel = 1 unless defined $dieLevel;
+ #$signalLevel = 1 unless defined $signalLevel;
+
+ $db_stop = 0; # Compiler warning
+ $db_stop = 1 << 30;
+ $level = 0; # Level of recursive debugging
+ # @stack and $doret are needed in sub sub, which is called for DB::postponed.
+ # Triggers bug (?) in perl is we postpone this until runtime:
+ @postponed = @stack = (0);
+ $doret = -2;
+ $frame = 0;
+}
+
+BEGIN {$^W = $ini_warn;} # Switch warnings back
+
+#use Carp; # This did break, left for debuggin
+
+sub db_complete {
+ # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
+ my($text, $line, $start) = @_;
+ my ($itext, $search, $prefix, $pack) =
+ ($text, "^\Q$ {'package'}::\E([^:]+)\$");
+
+ return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
+ (map { /$search/ ? ($1) : () } keys %sub)
+ if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
+ return sort grep /^\Q$text/, values %INC # files
+ if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
+ return sort map {($_, db_complete($_ . "::", "V ", 2))}
+ grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
+ if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
+ return sort map {($_, db_complete($_ . "::", "V ", 2))}
+ grep !/^main::/,
+ grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
+ # packages
+ if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
+ and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
+ if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
+ # We may want to complete to (eval 9), so $text may be wrong
+ $prefix = length($1) - length($text);
+ $text = $1;
+ return sort
+ map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
+ }
+ if ((substr $text, 0, 1) eq '&') { # subroutines
+ $text = substr $text, 1;
+ $prefix = "&";
+ return sort map "$prefix$_",
+ grep /^\Q$text/,
+ (keys %sub),
+ (map { /$search/ ? ($1) : () }
+ keys %sub);
+ }
+ if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
+ $pack = ($1 eq 'main' ? '' : $1) . '::';
+ $prefix = (substr $text, 0, 1) . $1 . '::';
+ $text = $2;
+ my @out
+ = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
+ if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
+ return db_complete($out[0], $line, $start);
+ }
+ return sort @out;
+ }
+ if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
+ $pack = ($package eq 'main' ? '' : $package) . '::';
+ $prefix = substr $text, 0, 1;
+ $text = substr $text, 1;
+ my @out = map "$prefix$_", grep /^\Q$text/,
+ (grep /^_?[a-zA-Z]/, keys %$pack),
+ ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
+ if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
+ return db_complete($out[0], $line, $start);
+ }
+ return sort @out;
+ }
+ if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
+ my @out = grep /^\Q$text/, @options;
+ my $val = option_val($out[0], undef);
+ my $out = '? ';
+ if (not defined $val or $val =~ /[\n\r]/) {
+ # Can do nothing better
+ } elsif ($val =~ /\s/) {
+ my $found;
+ foreach $l (split //, qq/\"\'\#\|/) {
+ $out = "$l$val$l ", last if (index $val, $l) == -1;
+ }
+ } else {
+ $out = "=$val ";
+ }
+ # Default to value if one completion, to question if many
+ $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
+ return sort @out;
+ }
+ return $term->filename_list($text); # filenames
+}
+
+sub end_report {
+ print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
+}
+
+END {
+ $finished = $inhibit_exit; # So that some keys may be disabled.
+ # Do not stop in at_exit() and destructors on exit:
+ $DB::single = !$exiting && !$runnonstop;
+ DB::fake::at_exit() unless $exiting or $runnonstop;
+}
+
+package DB::fake;
+
+sub at_exit {
+ "Debugged program terminated. Use `q' to quit or `R' to restart.";
+}
+
+package DB; # Do not trace this 1; below!
+
+1;
diff --git a/contrib/perl5/lib/pwd.pl b/contrib/perl5/lib/pwd.pl
new file mode 100644
index 000000000000..beb591679e26
--- /dev/null
+++ b/contrib/perl5/lib/pwd.pl
@@ -0,0 +1,58 @@
+;# pwd.pl - keeps track of current working directory in PWD environment var
+;#
+;# $RCSfile: pwd.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:11 $
+;#
+;# $Log: pwd.pl,v $
+;#
+;# Usage:
+;# require "pwd.pl";
+;# &initpwd;
+;# ...
+;# &chdir($newdir);
+
+package pwd;
+
+sub main'initpwd {
+ if ($ENV{'PWD'}) {
+ local($dd,$di) = stat('.');
+ local($pd,$pi) = stat($ENV{'PWD'});
+ if ($di != $pi || $dd != $pd) {
+ chop($ENV{'PWD'} = `pwd`);
+ }
+ }
+ else {
+ chop($ENV{'PWD'} = `pwd`);
+ }
+ if ($ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|) {
+ local($pd,$pi) = stat($2);
+ local($dd,$di) = stat($1);
+ if ($di == $pi && $dd == $pd) {
+ $ENV{'PWD'}="$2$3";
+ }
+ }
+}
+
+sub main'chdir {
+ local($newdir) = shift;
+ $newdir =~ s|/{2,}|/|g;
+ if (chdir $newdir) {
+ if ($newdir =~ m#^/#) {
+ $ENV{'PWD'} = $newdir;
+ }
+ else {
+ local(@curdir) = split(m#/#,$ENV{'PWD'});
+ @curdir = '' unless @curdir;
+ foreach $component (split(m#/#, $newdir)) {
+ next if $component eq '.';
+ pop(@curdir),next if $component eq '..';
+ push(@curdir,$component);
+ }
+ $ENV{'PWD'} = join('/',@curdir) || '/';
+ }
+ }
+ else {
+ 0;
+ }
+}
+
+1;
diff --git a/contrib/perl5/lib/shellwords.pl b/contrib/perl5/lib/shellwords.pl
new file mode 100644
index 000000000000..1c45a5a09035
--- /dev/null
+++ b/contrib/perl5/lib/shellwords.pl
@@ -0,0 +1,48 @@
+;# shellwords.pl
+;#
+;# Usage:
+;# require 'shellwords.pl';
+;# @words = &shellwords($line);
+;# or
+;# @words = &shellwords(@lines);
+;# or
+;# @words = &shellwords; # defaults to $_ (and clobbers it)
+
+sub shellwords {
+ package shellwords;
+ local($_) = join('', @_) if @_;
+ local(@words,$snippet,$field);
+
+ s/^\s+//;
+ while ($_ ne '') {
+ $field = '';
+ for (;;) {
+ if (s/^"(([^"\\]|\\.)*)"//) {
+ ($snippet = $1) =~ s#\\(.)#$1#g;
+ }
+ elsif (/^"/) {
+ die "Unmatched double quote: $_\n";
+ }
+ elsif (s/^'(([^'\\]|\\.)*)'//) {
+ ($snippet = $1) =~ s#\\(.)#$1#g;
+ }
+ elsif (/^'/) {
+ die "Unmatched single quote: $_\n";
+ }
+ elsif (s/^\\(.)//) {
+ $snippet = $1;
+ }
+ elsif (s/^([^\s\\'"]+)//) {
+ $snippet = $1;
+ }
+ else {
+ s/^\s+//;
+ last;
+ }
+ $field .= $snippet;
+ }
+ push(@words, $field);
+ }
+ @words;
+}
+1;
diff --git a/contrib/perl5/lib/sigtrap.pm b/contrib/perl5/lib/sigtrap.pm
new file mode 100644
index 000000000000..c081123b6b4c
--- /dev/null
+++ b/contrib/perl5/lib/sigtrap.pm
@@ -0,0 +1,289 @@
+package sigtrap;
+
+=head1 NAME
+
+sigtrap - Perl pragma to enable simple signal handling
+
+=cut
+
+use Carp;
+
+$VERSION = 1.02;
+$Verbose ||= 0;
+
+sub import {
+ my $pkg = shift;
+ my $handler = \&handler_traceback;
+ my $saw_sig = 0;
+ my $untrapped = 0;
+ local $_;
+
+ Arg_loop:
+ while (@_) {
+ $_ = shift;
+ if (/^[A-Z][A-Z0-9]*$/) {
+ $saw_sig++;
+ unless ($untrapped and $SIG{$_} and $SIG{$_} ne 'DEFAULT') {
+ print "Installing handler $handler for $_\n" if $Verbose;
+ $SIG{$_} = $handler;
+ }
+ }
+ elsif ($_ eq 'normal-signals') {
+ unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM));
+ }
+ elsif ($_ eq 'error-signals') {
+ unshift @_, grep(exists $SIG{$_},
+ qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP));
+ }
+ elsif ($_ eq 'old-interface-signals') {
+ unshift @_,
+ grep(exists $SIG{$_},
+ qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP));
+ }
+ elsif ($_ eq 'stack-trace') {
+ $handler = \&handler_traceback;
+ }
+ elsif ($_ eq 'die') {
+ $handler = \&handler_die;
+ }
+ elsif ($_ eq 'handler') {
+ @_ or croak "No argument specified after 'handler'";
+ $handler = shift;
+ unless (ref $handler or $handler eq 'IGNORE'
+ or $handler eq 'DEFAULT') {
+ require Symbol;
+ $handler = Symbol::qualify($handler, (caller)[0]);
+ }
+ }
+ elsif ($_ eq 'untrapped') {
+ $untrapped = 1;
+ }
+ elsif ($_ eq 'any') {
+ $untrapped = 0;
+ }
+ elsif ($_ =~ /^\d/) {
+ $VERSION >= $_ or croak "sigtrap.pm version $_ required,"
+ . " but this is only version $VERSION";
+ }
+ else {
+ croak "Unrecognized argument $_";
+ }
+ }
+ unless ($saw_sig) {
+ @_ = qw(old-interface-signals);
+ goto Arg_loop;
+ }
+}
+
+sub handler_die {
+ croak "Caught a SIG$_[0]";
+}
+
+sub handler_traceback {
+ package DB; # To get subroutine args.
+ $SIG{'ABRT'} = DEFAULT;
+ kill 'ABRT', $$ if $panic++;
+ syswrite(STDERR, 'Caught a SIG', 12);
+ syswrite(STDERR, $_[0], length($_[0]));
+ syswrite(STDERR, ' at ', 4);
+ ($pack,$file,$line) = caller;
+ syswrite(STDERR, $file, length($file));
+ syswrite(STDERR, ' line ', 6);
+ syswrite(STDERR, $line, length($line));
+ syswrite(STDERR, "\n", 1);
+
+ # Now go for broke.
+ for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) {
+ @a = ();
+ for $arg (@args) {
+ $_ = "$arg";
+ s/([\'\\])/\\$1/g;
+ s/([^\0]*)/'$1'/
+ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ push(@a, $_);
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ $e =~ s/\n\s*\;\s*\Z// if $e;
+ $e =~ s/[\\\']/\\$1/g if $e;
+ if ($r) {
+ $s = "require '$e'";
+ } elsif (defined $r) {
+ $s = "eval '$e'";
+ } elsif ($s eq '(eval)') {
+ $s = "eval {...}";
+ }
+ $f = "file `$f'" unless $f eq '-e';
+ $mess = "$w$s$a called from $f line $l\n";
+ syswrite(STDERR, $mess, length($mess));
+ }
+ kill 'ABRT', $$;
+}
+
+1;
+
+__END__
+
+=head1 SYNOPSIS
+
+ use sigtrap;
+ use sigtrap qw(stack-trace old-interface-signals); # equivalent
+ use sigtrap qw(BUS SEGV PIPE ABRT);
+ use sigtrap qw(die INT QUIT);
+ use sigtrap qw(die normal-signals);
+ use sigtrap qw(die untrapped normal-signals);
+ use sigtrap qw(die untrapped normal-signals
+ stack-trace any error-signals);
+ use sigtrap 'handler' => \&my_handler, 'normal-signals';
+ use sigtrap qw(handler my_handler normal-signals
+ stack-trace error-signals);
+
+=head1 DESCRIPTION
+
+The B<sigtrap> pragma is a simple interface to installing signal
+handlers. You can have it install one of two handlers supplied by
+B<sigtrap> itself (one which provides a Perl stack trace and one which
+simply C<die()>s), or alternately you can supply your own handler for it
+to install. It can be told only to install a handler for signals which
+are either untrapped or ignored. It has a couple of lists of signals to
+trap, plus you can supply your own list of signals.
+
+The arguments passed to the C<use> statement which invokes B<sigtrap>
+are processed in order. When a signal name or the name of one of
+B<sigtrap>'s signal lists is encountered a handler is immediately
+installed, when an option is encountered it affects subsequently
+installed handlers.
+
+=head1 OPTIONS
+
+=head2 SIGNAL HANDLERS
+
+These options affect which handler will be used for subsequently
+installed signals.
+
+=over 4
+
+=item B<stack-trace>
+
+The handler used for subsequently installed signals outputs a Perl stack
+trace to STDERR and then tries to dump core. This is the default signal
+handler.
+
+=item B<die>
+
+The handler used for subsequently installed signals calls C<die>
+(actually C<croak>) with a message indicating which signal was caught.
+
+=item B<handler> I<your-handler>
+
+I<your-handler> will be used as the handler for subsequently installed
+signals. I<your-handler> can be any value which is valid as an
+assignment to an element of C<%SIG>.
+
+=back
+
+=head2 SIGNAL LISTS
+
+B<sigtrap> has a few built-in lists of signals to trap. They are:
+
+=over 4
+
+=item B<normal-signals>
+
+These are the signals which a program might normally expect to encounter
+and which by default cause it to terminate. They are HUP, INT, PIPE and
+TERM.
+
+=item B<error-signals>
+
+These signals usually indicate a serious problem with the Perl
+interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL,
+QUIT, SEGV, SYS and TRAP.
+
+=item B<old-interface-signals>
+
+These are the signals which were trapped by default by the old
+B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT,
+SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to
+B<sigtrap>, this list is used.
+
+=back
+
+For each of these three lists, the collection of signals set to be
+trapped is checked before trapping; if your architecture does not
+implement a particular signal, it will not be trapped but rather
+silently ignored.
+
+=head2 OTHER
+
+=over 4
+
+=item B<untrapped>
+
+This token tells B<sigtrap> to install handlers only for subsequently
+listed signals which aren't already trapped or ignored.
+
+=item B<any>
+
+This token tells B<sigtrap> to install handlers for all subsequently
+listed signals. This is the default behavior.
+
+=item I<signal>
+
+Any argument which looks like a signal name (that is,
+C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a
+handler for that name.
+
+=item I<number>
+
+Require that at least version I<number> of B<sigtrap> is being used.
+
+=back
+
+=head1 EXAMPLES
+
+Provide a stack trace for the old-interface-signals:
+
+ use sigtrap;
+
+Ditto:
+
+ use sigtrap qw(stack-trace old-interface-signals);
+
+Provide a stack trace on the 4 listed signals only:
+
+ use sigtrap qw(BUS SEGV PIPE ABRT);
+
+Die on INT or QUIT:
+
+ use sigtrap qw(die INT QUIT);
+
+Die on HUP, INT, PIPE or TERM:
+
+ use sigtrap qw(die normal-signals);
+
+Die on HUP, INT, PIPE or TERM, except don't change the behavior for
+signals which are already trapped or ignored:
+
+ use sigtrap qw(die untrapped normal-signals);
+
+Die on receipt one of an of the B<normal-signals> which is currently
+B<untrapped>, provide a stack trace on receipt of B<any> of the
+B<error-signals>:
+
+ use sigtrap qw(die untrapped normal-signals
+ stack-trace any error-signals);
+
+Install my_handler() as the handler for the B<normal-signals>:
+
+ use sigtrap 'handler', \&my_handler, 'normal-signals';
+
+Install my_handler() as the handler for the normal-signals, provide a
+Perl stack trace on receipt of one of the error-signals:
+
+ use sigtrap qw(handler my_handler normal-signals
+ stack-trace error-signals);
+
+=cut
diff --git a/contrib/perl5/lib/stat.pl b/contrib/perl5/lib/stat.pl
new file mode 100644
index 000000000000..f7c240a4b3e7
--- /dev/null
+++ b/contrib/perl5/lib/stat.pl
@@ -0,0 +1,31 @@
+;# $RCSfile: stat.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:13 $
+
+;# Usage:
+;# require 'stat.pl';
+;# @ary = stat(foo);
+;# $st_dev = @ary[$ST_DEV];
+;#
+$ST_DEV = 0 + $[;
+$ST_INO = 1 + $[;
+$ST_MODE = 2 + $[;
+$ST_NLINK = 3 + $[;
+$ST_UID = 4 + $[;
+$ST_GID = 5 + $[;
+$ST_RDEV = 6 + $[;
+$ST_SIZE = 7 + $[;
+$ST_ATIME = 8 + $[;
+$ST_MTIME = 9 + $[;
+$ST_CTIME = 10 + $[;
+$ST_BLKSIZE = 11 + $[;
+$ST_BLOCKS = 12 + $[;
+
+;# Usage:
+;# require 'stat.pl';
+;# do Stat('foo'); # sets st_* as a side effect
+;#
+sub Stat {
+ ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size,
+ $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_));
+}
+
+1;
diff --git a/contrib/perl5/lib/strict.pm b/contrib/perl5/lib/strict.pm
new file mode 100644
index 000000000000..940e8bf7ff31
--- /dev/null
+++ b/contrib/perl5/lib/strict.pm
@@ -0,0 +1,104 @@
+package strict;
+
+=head1 NAME
+
+strict - Perl pragma to restrict unsafe constructs
+
+=head1 SYNOPSIS
+
+ use strict;
+
+ use strict "vars";
+ use strict "refs";
+ use strict "subs";
+
+ use strict;
+ no strict "vars";
+
+=head1 DESCRIPTION
+
+If no import list is supplied, all possible restrictions are assumed.
+(This is the safest mode to operate in, but is sometimes too strict for
+casual programming.) Currently, there are three possible things to be
+strict about: "subs", "vars", and "refs".
+
+=over 6
+
+=item C<strict refs>
+
+This generates a runtime error if you
+use symbolic references (see L<perlref>).
+
+ use strict 'refs';
+ $ref = \$foo;
+ print $$ref; # ok
+ $ref = "foo";
+ print $$ref; # runtime error; normally ok
+
+=item C<strict vars>
+
+This generates a compile-time error if you access a variable that wasn't
+declared via C<use vars>,
+localized via C<my()> or wasn't fully qualified. Because this is to avoid
+variable suicide problems and subtle dynamic scoping issues, a merely
+local() variable isn't good enough. See L<perlfunc/my> and
+L<perlfunc/local>.
+
+ use strict 'vars';
+ $X::foo = 1; # ok, fully qualified
+ my $foo = 10; # ok, my() var
+ local $foo = 9; # blows up
+
+ package Cinna;
+ use vars qw/ $bar /; # Declares $bar in current package
+ $bar = 'HgS'; # ok, global declared via pragma
+
+The local() generated a compile-time error because you just touched a global
+name without fully qualifying it.
+
+=item C<strict subs>
+
+This disables the poetry optimization, generating a compile-time error if
+you try to use a bareword identifier that's not a subroutine, unless it
+appears in curly braces or on the left hand side of the "=E<gt>" symbol.
+
+
+ use strict 'subs';
+ $SIG{PIPE} = Plumber; # blows up
+ $SIG{PIPE} = "Plumber"; # just fine: bareword in curlies always ok
+ $SIG{PIPE} = \&Plumber; # preferred form
+
+
+
+=back
+
+See L<perlmodlib/Pragmatic Modules>.
+
+
+=cut
+
+$strict::VERSION = "1.01";
+
+my %bitmask = (
+refs => 0x00000002,
+subs => 0x00000200,
+vars => 0x00000400
+);
+
+sub bits {
+ my $bits = 0;
+ foreach my $s (@_){ $bits |= $bitmask{$s} || 0; };
+ $bits;
+}
+
+sub import {
+ shift;
+ $^H |= bits(@_ ? @_ : qw(refs subs vars));
+}
+
+sub unimport {
+ shift;
+ $^H &= ~ bits(@_ ? @_ : qw(refs subs vars));
+}
+
+1;
diff --git a/contrib/perl5/lib/subs.pm b/contrib/perl5/lib/subs.pm
new file mode 100644
index 000000000000..aa332a678583
--- /dev/null
+++ b/contrib/perl5/lib/subs.pm
@@ -0,0 +1,38 @@
+package subs;
+
+=head1 NAME
+
+subs - Perl pragma to predeclare sub names
+
+=head1 SYNOPSIS
+
+ use subs qw(frob);
+ frob 3..10;
+
+=head1 DESCRIPTION
+
+This will predeclare all the subroutine whose names are
+in the list, allowing you to use them without parentheses
+even before they're declared.
+
+Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and
+C<use subs> declarations are not BLOCK-scoped. They are thus effective
+for the entire file in which they appear. You may not rescind such
+declarations with C<no vars> or C<no subs>.
+
+See L<perlmodlib/Pragmatic Modules> and L<strict/strict subs>.
+
+=cut
+
+require 5.000;
+
+sub import {
+ my $callpack = caller;
+ my $pack = shift;
+ my @imports = @_;
+ foreach $sym (@imports) {
+ *{"${callpack}::$sym"} = \&{"${callpack}::$sym"};
+ }
+};
+
+1;
diff --git a/contrib/perl5/lib/syslog.pl b/contrib/perl5/lib/syslog.pl
new file mode 100644
index 000000000000..9e03399e4df6
--- /dev/null
+++ b/contrib/perl5/lib/syslog.pl
@@ -0,0 +1,197 @@
+#
+# syslog.pl
+#
+# $Log: syslog.pl,v $
+#
+# tom christiansen <tchrist@convex.com>
+# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
+# NOTE: openlog now takes three arguments, just like openlog(3)
+#
+# call syslog() with a string priority and a list of printf() args
+# like syslog(3)
+#
+# usage: require 'syslog.pl';
+#
+# then (put these all in a script to test function)
+#
+#
+# do openlog($program,'cons,pid','user');
+# do syslog('info','this is another test');
+# do syslog('mail|warning','this is a better test: %d', time);
+# do closelog();
+#
+# do syslog('debug','this is the last test');
+# do openlog("$program $$",'ndelay','user');
+# do syslog('notice','fooprogram: this is really done');
+#
+# $! = 55;
+# do syslog('info','problem was %m'); # %m == $! in syslog(3)
+
+package syslog;
+
+$host = 'localhost' unless $host; # set $syslog'host to change
+
+if ($] >= 5) {
+ warn "You should 'use Sys::Syslog' instead; continuing" # if $^W
+}
+
+require 'syslog.ph';
+
+ eval 'use Socket; 1' ||
+ eval { require "socket.ph" } ||
+ require "sys/socket.ph";
+
+$maskpri = &LOG_UPTO(&LOG_DEBUG);
+
+sub main'openlog {
+ ($ident, $logopt, $facility) = @_; # package vars
+ $lo_pid = $logopt =~ /\bpid\b/;
+ $lo_ndelay = $logopt =~ /\bndelay\b/;
+ $lo_cons = $logopt =~ /\bcons\b/;
+ $lo_nowait = $logopt =~ /\bnowait\b/;
+ &connect if $lo_ndelay;
+}
+
+sub main'closelog {
+ $facility = $ident = '';
+ &disconnect;
+}
+
+sub main'setlogmask {
+ local($oldmask) = $maskpri;
+ $maskpri = shift;
+ $oldmask;
+}
+
+sub main'syslog {
+ local($priority) = shift;
+ local($mask) = shift;
+ local($message, $whoami);
+ local(@words, $num, $numpri, $numfac, $sum);
+ local($facility) = $facility; # may need to change temporarily.
+
+ die "syslog: expected both priority and mask" unless $mask && $priority;
+
+ @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility".
+ undef $numpri;
+ undef $numfac;
+ foreach (@words) {
+ $num = &xlate($_); # Translate word to number.
+ if (/^kern$/ || $num < 0) {
+ die "syslog: invalid level/facility: $_\n";
+ }
+ elsif ($num <= &LOG_PRIMASK) {
+ die "syslog: too many levels given: $_\n" if defined($numpri);
+ $numpri = $num;
+ return 0 unless &LOG_MASK($numpri) & $maskpri;
+ }
+ else {
+ die "syslog: too many facilities given: $_\n" if defined($numfac);
+ $facility = $_;
+ $numfac = $num;
+ }
+ }
+
+ die "syslog: level must be given\n" unless defined($numpri);
+
+ if (!defined($numfac)) { # Facility not specified in this call.
+ $facility = 'user' unless $facility;
+ $numfac = &xlate($facility);
+ }
+
+ &connect unless $connected;
+
+ $whoami = $ident;
+
+ if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
+ $whoami = $1;
+ $mask = $2;
+ }
+
+ unless ($whoami) {
+ ($whoami = getlogin) ||
+ ($whoami = getpwuid($<)) ||
+ ($whoami = 'syslog');
+ }
+
+ $whoami .= "[$$]" if $lo_pid;
+
+ $mask =~ s/%m/$!/g;
+ $mask .= "\n" unless $mask =~ /\n$/;
+ $message = sprintf ($mask, @_);
+
+ $sum = $numpri + $numfac;
+ unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
+ if ($lo_cons) {
+ if ($pid = fork) {
+ unless ($lo_nowait) {
+ do {$died = wait;} until $died == $pid || $died < 0;
+ }
+ }
+ else {
+ open(CONS,">/dev/console");
+ print CONS "<$facility.$priority>$whoami: $message\r";
+ exit if defined $pid; # if fork failed, we're parent
+ close CONS;
+ }
+ }
+ }
+}
+
+sub xlate {
+ local($name) = @_;
+ $name = uc $name;
+ $name = "LOG_$name" unless $name =~ /^LOG_/;
+ $name = "syslog'$name";
+ defined &$name ? &$name : -1;
+}
+
+sub connect {
+ $pat = 'S n C4 x8';
+
+ $af_unix = &AF_UNIX;
+ $af_inet = &AF_INET;
+
+ $stream = &SOCK_STREAM;
+ $datagram = &SOCK_DGRAM;
+
+ ($name,$aliases,$proto) = getprotobyname('udp');
+ $udp = $proto;
+
+ ($name,$aliases,$port,$proto) = getservbyname('syslog','udp');
+ $syslog = $port;
+
+ if (chop($myname = `hostname`)) {
+ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname);
+ die "Can't lookup $myname\n" unless $name;
+ @bytes = unpack("C4",$addrs[0]);
+ }
+ else {
+ @bytes = (0,0,0,0);
+ }
+ $this = pack($pat, $af_inet, 0, @bytes);
+
+ if ($host =~ /^\d+\./) {
+ @bytes = split(/\./,$host);
+ }
+ else {
+ ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host);
+ die "Can't lookup $host\n" unless $name;
+ @bytes = unpack("C4",$addrs[0]);
+ }
+ $that = pack($pat,$af_inet,$syslog,@bytes);
+
+ socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n";
+ bind(SYSLOG,$this) || die "bind: $!\n";
+ connect(SYSLOG,$that) || die "connect: $!\n";
+
+ local($old) = select(SYSLOG); $| = 1; select($old);
+ $connected = 1;
+}
+
+sub disconnect {
+ close SYSLOG;
+ $connected = 0;
+}
+
+1;
diff --git a/contrib/perl5/lib/tainted.pl b/contrib/perl5/lib/tainted.pl
new file mode 100644
index 000000000000..6e24867a83dd
--- /dev/null
+++ b/contrib/perl5/lib/tainted.pl
@@ -0,0 +1,9 @@
+# This subroutine returns true if its argument is tainted, false otherwise.
+
+sub tainted {
+ local($@);
+ eval { kill 0 * $_[0] };
+ $@ =~ /^Insecure/;
+}
+
+1;
diff --git a/contrib/perl5/lib/termcap.pl b/contrib/perl5/lib/termcap.pl
new file mode 100644
index 000000000000..37313432fdee
--- /dev/null
+++ b/contrib/perl5/lib/termcap.pl
@@ -0,0 +1,169 @@
+;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
+;#
+;# Usage:
+;# require 'ioctl.pl';
+;# ioctl(TTY,$TIOCGETP,$foo);
+;# ($ispeed,$ospeed) = unpack('cc',$foo);
+;# require 'termcap.pl';
+;# &Tgetent('vt100'); # sets $TC{'cm'}, etc.
+;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
+;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
+;#
+sub Tgetent {
+ local($TERM) = @_;
+ local($TERMCAP,$_,$entry,$loop,$field);
+
+ warn "Tgetent: no ospeed set" unless $ospeed;
+ foreach $key (keys %TC) {
+ delete $TC{$key};
+ }
+ $TERM = $ENV{'TERM'} unless $TERM;
+ $TERM =~ s/(\W)/\\$1/g;
+ $TERMCAP = $ENV{'TERMCAP'};
+ $TERMCAP = '/etc/termcap' unless $TERMCAP;
+ if ($TERMCAP !~ m:^/:) {
+ if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
+ $TERMCAP = '/etc/termcap';
+ }
+ }
+ if ($TERMCAP =~ m:^/:) {
+ $entry = '';
+ do {
+ $loop = "
+ open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
+ while (<TERMCAP>) {
+ next if /^#/;
+ next if /^\t/;
+ if (/(^|\\|)${TERM}[:\\|]/) {
+ chop;
+ while (chop eq '\\\\') {
+ \$_ .= <TERMCAP>;
+ chop;
+ }
+ \$_ .= ':';
+ last;
+ }
+ }
+ close TERMCAP;
+ \$entry .= \$_;
+ ";
+ eval $loop;
+ } while s/:tc=([^:]+):/:/ && ($TERM = $1);
+ $TERMCAP = $entry;
+ }
+
+ foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
+ if ($field =~ /^\w\w$/) {
+ $TC{$field} = 1;
+ }
+ elsif ($field =~ /^(\w\w)#(.*)/) {
+ $TC{$1} = $2 if $TC{$1} eq '';
+ }
+ elsif ($field =~ /^(\w\w)=(.*)/) {
+ $entry = $1;
+ $_ = $2;
+ s/\\E/\033/g;
+ s/\\(200)/pack('c',0)/eg; # NUL character
+ s/\\(0\d\d)/pack('c',oct($1))/eg; # octal
+ s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg; # hex
+ s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
+ s/\\n/\n/g;
+ s/\\r/\r/g;
+ s/\\t/\t/g;
+ s/\\b/\b/g;
+ s/\\f/\f/g;
+ s/\\\^/\377/g;
+ s/\^\?/\177/g;
+ s/\^(.)/pack('c',ord($1) & 31)/eg;
+ s/\\(.)/$1/g;
+ s/\377/^/g;
+ $TC{$entry} = $_ if $TC{$entry} eq '';
+ }
+ }
+ $TC{'pc'} = "\0" if $TC{'pc'} eq '';
+ $TC{'bc'} = "\b" if $TC{'bc'} eq '';
+}
+
+@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
+
+sub Tputs {
+ local($string,$affcnt,$FH) = @_;
+ local($ms);
+ if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
+ $ms = $1;
+ $ms *= $affcnt if $2;
+ $string = $3;
+ $decr = $Tputs[$ospeed];
+ if ($decr > .1) {
+ $ms += $decr / 2;
+ $string .= $TC{'pc'} x ($ms / $decr);
+ }
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+sub Tgoto {
+ local($string) = shift(@_);
+ local($result) = '';
+ local($after) = '';
+ local($code,$tmp) = @_;
+ local(@tmp);
+ @tmp = ($tmp,$code);
+ local($online) = 0;
+ while ($string =~ /^([^%]*)%(.)(.*)/) {
+ $result .= $1;
+ $code = $2;
+ $string = $3;
+ if ($code eq 'd') {
+ $result .= sprintf("%d",shift(@tmp));
+ }
+ elsif ($code eq '.') {
+ $tmp = shift(@tmp);
+ if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
+ if ($online) {
+ ++$tmp, $after .= $TC{'up'} if $TC{'up'};
+ }
+ else {
+ ++$tmp, $after .= $TC{'bc'};
+ }
+ }
+ $result .= sprintf("%c",$tmp);
+ $online = !$online;
+ }
+ elsif ($code eq '+') {
+ $result .= sprintf("%c",shift(@tmp)+ord($string));
+ $string = substr($string,1,99);
+ $online = !$online;
+ }
+ elsif ($code eq 'r') {
+ ($code,$tmp) = @tmp;
+ @tmp = ($tmp,$code);
+ $online = !$online;
+ }
+ elsif ($code eq '>') {
+ ($code,$tmp,$string) = unpack("CCa99",$string);
+ if ($tmp[$[] > $code) {
+ $tmp[$[] += $tmp;
+ }
+ }
+ elsif ($code eq '2') {
+ $result .= sprintf("%02d",shift(@tmp));
+ $online = !$online;
+ }
+ elsif ($code eq '3') {
+ $result .= sprintf("%03d",shift(@tmp));
+ $online = !$online;
+ }
+ elsif ($code eq 'i') {
+ ($code,$tmp) = @tmp;
+ @tmp = ($code+1,$tmp+1);
+ }
+ else {
+ return "OOPS";
+ }
+ }
+ $result . $string . $after;
+}
+
+1;
diff --git a/contrib/perl5/lib/timelocal.pl b/contrib/perl5/lib/timelocal.pl
new file mode 100644
index 000000000000..ad322756e387
--- /dev/null
+++ b/contrib/perl5/lib/timelocal.pl
@@ -0,0 +1,18 @@
+;# timelocal.pl
+;#
+;# Usage:
+;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year);
+;# $time = timegm($sec,$min,$hours,$mday,$mon,$year);
+
+;# This file has been superseded by the Time::Local library module.
+;# It is implemented as a call to that module for backwards compatibility
+;# with code written for perl4; new code should use Time::Local directly.
+
+;# The current implementation shares with the original the questionable
+;# behavior of defining the timelocal() and timegm() functions in the
+;# namespace of whatever package was current when the first instance of
+;# C<require 'timelocal.pl';> was executed in a program.
+
+use Time::Local;
+
+*timelocal::cheat = \&Time::Local::cheat;
diff --git a/contrib/perl5/lib/validate.pl b/contrib/perl5/lib/validate.pl
new file mode 100644
index 000000000000..ec4a04b54367
--- /dev/null
+++ b/contrib/perl5/lib/validate.pl
@@ -0,0 +1,104 @@
+;# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $
+
+;# The validate routine takes a single multiline string consisting of
+;# lines containing a filename plus a file test to try on it. (The
+;# file test may also be a 'cd', causing subsequent relative filenames
+;# to be interpreted relative to that directory.) After the file test
+;# you may put '|| die' to make it a fatal error if the file test fails.
+;# The default is '|| warn'. The file test may optionally have a ! prepended
+;# to test for the opposite condition. If you do a cd and then list some
+;# relative filenames, you may want to indent them slightly for readability.
+;# If you supply your own "die" or "warn" message, you can use $file to
+;# interpolate the filename.
+
+;# Filetests may be bunched: -rwx tests for all of -r, -w and -x.
+;# Only the first failed test of the bunch will produce a warning.
+
+;# The routine returns the number of warnings issued.
+
+;# Usage:
+;# require "validate.pl";
+;# $warnings += do validate('
+;# /vmunix -e || die
+;# /boot -e || die
+;# /bin cd
+;# csh -ex
+;# csh !-ug
+;# sh -ex
+;# sh !-ug
+;# /usr -d || warn "What happened to $file?\n"
+;# ');
+
+sub validate {
+ local($file,$test,$warnings,$oldwarnings);
+ foreach $check (split(/\n/,$_[0])) {
+ next if $check =~ /^#/;
+ next if $check =~ /^$/;
+ ($file,$test) = split(' ',$check,2);
+ if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
+ $testlist = $2;
+ @testlist = split(//,$testlist);
+ }
+ else {
+ @testlist = ('Z');
+ }
+ $oldwarnings = $warnings;
+ foreach $one (@testlist) {
+ $this = $test;
+ $this =~ s/(-\w\b)/$1 \$file/g;
+ $this =~ s/-Z/-$one/;
+ $this .= ' || warn' unless $this =~ /\|\|/;
+ $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/;
+ $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
+ eval $this;
+ last if $warnings > $oldwarnings;
+ }
+ }
+ $warnings;
+}
+
+sub valmess {
+ local($disposition,$this) = @_;
+ $file = $cwd . '/' . $file unless $file =~ m|^/|;
+ if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
+ $neg = $1;
+ $tmp = $2;
+ $tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
+ $tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
+ $tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
+ $tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
+ $tmp eq 'R' && ($mess = "$file is not readable by you.");
+ $tmp eq 'W' && ($mess = "$file is not writable by you.");
+ $tmp eq 'X' && ($mess = "$file is not executable by you.");
+ $tmp eq 'O' && ($mess = "$file is not owned by you.");
+ $tmp eq 'e' && ($mess = "$file does not exist.");
+ $tmp eq 'z' && ($mess = "$file does not have zero size.");
+ $tmp eq 's' && ($mess = "$file does not have non-zero size.");
+ $tmp eq 'f' && ($mess = "$file is not a plain file.");
+ $tmp eq 'd' && ($mess = "$file is not a directory.");
+ $tmp eq 'l' && ($mess = "$file is not a symbolic link.");
+ $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
+ $tmp eq 'S' && ($mess = "$file is not a socket.");
+ $tmp eq 'b' && ($mess = "$file is not a block special file.");
+ $tmp eq 'c' && ($mess = "$file is not a character special file.");
+ $tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
+ $tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
+ $tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
+ $tmp eq 'T' && ($mess = "$file is not a text file.");
+ $tmp eq 'B' && ($mess = "$file is not a binary file.");
+ if ($neg eq '!') {
+ $mess =~ s/ is not / should not be / ||
+ $mess =~ s/ does not / should not / ||
+ $mess =~ s/ not / /;
+ }
+ print STDERR $mess,"\n";
+ }
+ else {
+ $this =~ s/\$file/'$file'/g;
+ print STDERR "Can't do $this.\n";
+ }
+ if ($disposition eq 'die') { exit 1; }
+ ++$warnings;
+}
+
+1;
diff --git a/contrib/perl5/lib/vars.pm b/contrib/perl5/lib/vars.pm
new file mode 100644
index 000000000000..334af9630ada
--- /dev/null
+++ b/contrib/perl5/lib/vars.pm
@@ -0,0 +1,75 @@
+package vars;
+
+require 5.002;
+
+# The following require can't be removed during maintenance
+# releases, sadly, because of the risk of buggy code that does
+# require Carp; Carp::croak "..."; without brackets dying
+# if Carp hasn't been loaded in earlier compile time. :-(
+# We'll let those bugs get found on the development track.
+require Carp if $] < 5.00450;
+
+sub import {
+ my $callpack = caller;
+ my ($pack, @imports, $sym, $ch) = @_;
+ foreach $sym (@imports) {
+ ($ch, $sym) = unpack('a1a*', $sym);
+ if ($sym =~ tr/A-Za-Z_0-9//c) {
+ # time for a more-detailed check-up
+ if ($sym =~ /::/) {
+ require Carp;
+ Carp::croak("Can't declare another package's variables");
+ } elsif ($sym =~ /^\w+[[{].*[]}]$/) {
+ require Carp;
+ Carp::croak("Can't declare individual elements of hash or array");
+ } elsif ($^W and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
+ require Carp;
+ Carp::carp("No need to declare built-in vars");
+ }
+ }
+ *{"${callpack}::$sym"} =
+ ( $ch eq "\$" ? \$ {"${callpack}::$sym"}
+ : $ch eq "\@" ? \@ {"${callpack}::$sym"}
+ : $ch eq "\%" ? \% {"${callpack}::$sym"}
+ : $ch eq "\*" ? \* {"${callpack}::$sym"}
+ : $ch eq "\&" ? \& {"${callpack}::$sym"}
+ : do {
+ require Carp;
+ Carp::croak("'$ch$sym' is not a valid variable name");
+ });
+ }
+};
+
+1;
+__END__
+
+=head1 NAME
+
+vars - Perl pragma to predeclare global variable names
+
+=head1 SYNOPSIS
+
+ use vars qw($frob @mung %seen);
+
+=head1 DESCRIPTION
+
+This will predeclare all the variables whose names are
+in the list, allowing you to use them under "use strict", and
+disabling any typo warnings.
+
+Unlike pragmas that affect the C<$^H> hints variable, the C<use vars> and
+C<use subs> declarations are not BLOCK-scoped. They are thus effective
+for the entire file in which they appear. You may not rescind such
+declarations with C<no vars> or C<no subs>.
+
+Packages such as the B<AutoLoader> and B<SelfLoader> that delay
+loading of subroutines within packages can create problems with
+package lexicals defined using C<my()>. While the B<vars> pragma
+cannot duplicate the effect of package lexicals (total transparency
+outside of the package), it can act as an acceptable substitute by
+pre-declaring global symbols, ensuring their availability to the
+later-loaded routines.
+
+See L<perlmodlib/Pragmatic Modules>.
+
+=cut
diff --git a/contrib/perl5/makeaperl.SH b/contrib/perl5/makeaperl.SH
new file mode 100755
index 000000000000..16b74350e013
--- /dev/null
+++ b/contrib/perl5/makeaperl.SH
@@ -0,0 +1,130 @@
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting makeaperl (with variable substitutions)"
+rm -f makeaperl
+$spitshell >makeaperl <<!GROK!THIS!
+$startperl
+ eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+$spitshell >>makeaperl <<'!NO!SUBS!'
+
+=head1 NAME
+
+makeaperl - create a new perl binary from static extensions
+
+=head1 SYNOPSIS
+
+C<makeaperl -l library -m makefile -o target -t tempdir [object_files] [static_extensions] [search_directories]>
+
+=head1 DESCRIPTION
+
+This utility is designed to build new perl binaries from existing
+extensions on the fly. Called without any arguments it produces a new
+binary with the name C<perl> in the current directory. Intermediate
+files are produced in C</tmp>, if that is writeable, else in the
+current directory. The most important intermediate file is a Makefile,
+that is used internally to call C<make>. The new perl binary will consist
+
+The C<-l> switch lets you specify the name of a perl library to be
+linked into the new binary. If you do not specify a library, makeaperl
+writes targets for any C<libperl*.a> it finds in the search path. The
+topmost target will be the one related to C<libperl.a>.
+
+With the C<-m> switch you can provide a name for the Makefile that
+will be written (default C</tmp/Makefile.$$>). Likewise specifies the
+C<-o> switch a name for the perl binary (default C<perl>). The C<-t>
+switch lets you determine, in which directory the intermediate files
+should be stored.
+
+All object files and static extensions following on the command line
+will be linked into the target file. If there are any directories
+specified on the command line, these directories are searched for
+C<*.a> files, and all of the found ones will be linked in, too. If
+there is no directory named, then the contents of $INC[0] are
+searched.
+
+If the command fails, there is currently no other mechanism to adjust
+the behaviour of the program than to alter the generated Makefile and
+run C<make> by hand.
+
+=head1 AUTHORS
+Tim Bunce <Tim.Bunce@ig.co.uk>, Andreas Koenig
+<koenig@franz.ww.TU-Berlin.DE>;
+
+=head2 STATUS
+First version, written 5 Feb 1995, is considered alpha.
+
+=cut
+
+use ExtUtils::MakeMaker;
+use Getopt::Long;
+use strict qw(subs refs);
+
+$Version = 1.0;
+$Verbose = 0;
+
+sub usage{
+ warn <<END;
+$0 version $Version
+
+$0: [options] [object_files] [static_extensions ...] [directories to search through]
+ -l perllibrary perl library to link from (the first libperl.a found)
+ -m makefilename name of the makefile to be written (/tmp/Makefile.\$\$)
+ -o name name for perl executable (perl)
+ -t directory directory where intermediate files reside (/tmp)
+END
+ exit 1;
+}
+
+if (-w "/tmp") {
+ $opt_t = "/tmp";
+} else {
+ $opt_t = ".";
+}
+$opt_l = '';
+$opt_m = "$opt_t/Makefile.$$";
+$opt_o = 'perl';
+
+$Getopt::Long::ignorecase=0;
+
+GetOptions('t=s', 'l=s', 'm=s', 'o=s') || die &usage;
+
+@dirs = grep -d $_, @ARGV;
+@fils = grep -f $_, @ARGV;
+
+@dirs = $INC[0] unless @dirs;
+
+open MAKE, ">$opt_m";
+MM->init_main();
+MM->init_others();
+print MAKE MM->makeaperl('MAKE' => $opt_m,
+ 'TARGET' => $opt_o,
+ 'TMP' => $opt_t,
+ 'LIBPERL' => $opt_l,
+ 'DIRS' => [@dirs],
+ 'STAT' => [@fils],
+ 'INCL' => [@dirs]
+);
+close MAKE;
+(system "make -f $opt_m") == 0 or die "$0 failed: Please check file $opt_m and run make -f $opt_m\n";
+!NO!SUBS!
+chmod 755 makeaperl
+$eunicefix makeaperl
diff --git a/contrib/perl5/makedepend.SH b/contrib/perl5/makedepend.SH
new file mode 100755
index 000000000000..efc12b00a396
--- /dev/null
+++ b/contrib/perl5/makedepend.SH
@@ -0,0 +1,203 @@
+#! /bin/sh
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+
+echo "Extracting makedepend (with variable substitutions)"
+rm -f makedepend
+$spitshell >makedepend <<!GROK!THIS!
+$startsh
+# makedepend.SH
+#
+MAKE=$make
+trnl='$trnl'
+!GROK!THIS!
+$spitshell >>makedepend <<'!NO!SUBS!'
+
+# This script should be called with
+# sh ./makedepend MAKE=$(MAKE)
+case "$1" in
+ MAKE=*) eval $1 ;;
+esac
+
+export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
+
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+
+# We need .. when we are in the x2p directory if we are using the
+# cppstdin wrapper script.
+# Put .. and . first so that we pick up the present cppstdin, not
+# an older one lying about in /usr/local/bin.
+PATH=".$path_sep..$path_sep$PATH"
+export PATH
+
+$cat /dev/null >.deptmp
+$rm -f *.c.c c/*.c.c
+if test -f Makefile; then
+ rm -f $firstmakefile
+ cp Makefile $firstmakefile
+ # On QNX, 'cp' preserves timestamp, so $firstmakefile appears
+ # to be out of date. I don't know if OS/2 has touch, so do this:
+ case "$osname" in
+ os2) ;;
+ *) $touch $firstmakefile ;;
+ esac
+fi
+mf=$firstmakefile
+if test -f $mf; then
+ defrule=`<$mf sed -n \
+ -e '/^\.c\$(OBJ_EXT):.*;/{' \
+ -e 's/\$\*\.c//' \
+ -e 's/^[^;]*;[ ]*//p' \
+ -e q \
+ -e '}' \
+ -e '/^\.c\$(OBJ_EXT): *$/{' \
+ -e N \
+ -e 's/\$\*\.c//' \
+ -e 's/^.*\n[ ]*//p' \
+ -e q \
+ -e '}'`
+fi
+case "$defrule" in
+'') defrule='$(CC) -c $(CFLAGS)' ;;
+esac
+
+: Create files in UU directory to avoid problems with long filenames
+: on systems with 14 character filename limits so file.c.c and file.c
+: might be identical
+$test -d UU || mkdir UU
+
+$MAKE clist || ($echo "Searching for .c files..."; \
+ $echo *.c | $tr ' ' $trnl | $egrep -v '\*' >.clist)
+for file in `$cat .clist`; do
+# for file in `cat /dev/null`; do
+ case "$file" in
+ *.c) filebase=`basename $file .c` ;;
+ *.y) filebase=`basename $file .y` ;;
+ esac
+ case "$file" in
+ */*) finc="-I`echo $file | sed 's#/[^/]*$##`" ;;
+ *) finc= ;;
+ esac
+ $echo "Finding dependencies for $filebase$_o."
+ ( $echo "#line 1 \"$file\""; \
+ $sed -n <$file \
+ -e "/^${filebase}_init(/q" \
+ -e '/^#line/d' \
+ -e '/^#/{' \
+ -e 's|/\*.*$||' \
+ -e 's|\\$||' \
+ -e p \
+ -e '}' ) >UU/$file.c
+ $cppstdin $finc -I. $cppflags $cppminus <UU/$file.c |
+ $sed \
+ -e '/^#.*<stdin>/d' \
+ -e '/^#.*"-"/d' \
+ -e 's#\.[0-9][0-9]*\.c#'"$file.c#" \
+ -e 's/^[ ]*#[ ]*line/#/' \
+ -e '/^# *[0-9][0-9]* *[".\/]/!d' \
+ -e 's/^.*"\(.*\)".*$/'$filebase'\$(OBJ_EXT): \1/' \
+ -e 's/^# *[0-9][0-9]* \(.*\)$/'$filebase'\$(OBJ_EXT): \1/' \
+ -e 's|: \./|: |' \
+ -e 's|\.c\.c|.c|' | \
+ $uniq | $sort | $uniq >> .deptmp
+done
+
+$sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d'
+
+$MAKE shlist || ($echo "Searching for .SH files..."; \
+ $echo *.SH | $tr ' ' $trnl | $egrep -v '\*' >.shlist)
+
+# Now extract the dependencies on makedepend.SH and Makefile.SH
+# (they should reside in the main Makefile):
+rm -f .shlist.old
+mv .shlist .shlist.old
+$egrep -v '^makedepend\.SH' <.shlist.old >.shlist
+rm -f .shlist.old
+mv .shlist .shlist.old
+$egrep -v '^Makefile\.SH' <.shlist.old >.shlist
+rm -f .shlist.old
+mv .shlist .shlist.old
+$egrep -v '^perl_exp\.SH' <.shlist.old >.shlist
+rm -f .shlist.old
+mv .shlist .shlist.old
+$egrep -v '^config_h\.SH' <.shlist.old >.shlist
+rm .shlist.old
+
+if $test -s .deptmp; then
+ for file in `cat .shlist`; do
+ $echo `$expr X$file : 'X\(.*\).SH'`: $file $TOP/config.sh \; \
+ $sh $file >> .deptmp
+ done
+ $echo "Updating $mf..."
+ $echo "# If this runs make out of memory, delete /usr/include lines." \
+ >> $mf.new
+ $sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
+ >>$mf.new
+else
+ $MAKE hlist || ($echo "Searching for .h files..."; \
+ $echo *.h | $tr ' ' $trnl | $egrep -v '\*' >.hlist)
+ $echo "You don't seem to have a proper C preprocessor. Using grep instead."
+ $egrep '^#include ' `cat .clist` `cat .hlist` >.deptmp
+ $echo "Updating $mf..."
+ <.clist $sed -n \
+ -e '/\//{' \
+ -e 's|^\(.*\)/\(.*\)\.c|\2\$(OBJ_EXT): \1/\2.c; '"$defrule \1/\2.c|p" \
+ -e d \
+ -e '}' \
+ -e 's|^\(.*\)\.c|\1\$(OBJ_EXT): \1.c|p' >> $mf.new
+ <.hlist $sed -n 's|\(.*/\)\(.*\)|s= \2= \1\2=|p' >.hsed
+ <.deptmp $sed -n 's|c:#include "\(.*\)".*$|o: \1|p' | \
+ $sed 's|^[^;]*/||' | \
+ $sed -f .hsed >> $mf.new
+ <.deptmp $sed -n 's|h:#include "\(.*\)".*$|h: \1|p' | \
+ $sed -f .hsed >> $mf.new
+ for file in `$cat .shlist`; do
+ $echo `$expr X$file : 'X\(.*\).SH'`: $file $TOP/config.sh \; \
+ $sh $file >> $mf.new
+ done
+fi
+$rm -f $mf.old
+$cp $mf $mf.old
+$rm -f $mf
+$cp $mf.new $mf
+$rm $mf.new
+$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
+$rm -rf .deptmp UU .shlist .clist .hlist .hsed
+
+!NO!SUBS!
+$eunicefix makedepend
+chmod +x makedepend
+case `pwd` in
+*SH)
+ $rm -f ../makedepend
+ ln makedepend ../makedepend
+ ;;
+esac
diff --git a/contrib/perl5/makedir.SH b/contrib/perl5/makedir.SH
new file mode 100755
index 000000000000..09908edff27d
--- /dev/null
+++ b/contrib/perl5/makedir.SH
@@ -0,0 +1,68 @@
+case $CONFIG in
+'')
+ if test ! -f config.sh; then
+ ln ../config.sh . || \
+ ln ../../config.sh . || \
+ ln ../../../config.sh . || \
+ (echo "Can't find config.sh."; exit 1)
+ fi 2>/dev/null
+ . ./config.sh
+ ;;
+esac
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting makedir (with variable substitutions)"
+rm -f makedir
+$spitshell >makedir <<!GROK!THIS!
+$startsh
+# makedir.SH
+#
+
+export PATH || (echo "OOPS, this isn't sh. Desperation time. I will feed myself to sh."; sh \$0; kill \$\$)
+
+case \$# in
+ 0)
+ $echo "makedir pathname filenameflag"
+ exit 1
+ ;;
+esac
+
+: guarantee one slash before 1st component
+case \$1 in
+ /*) ;;
+ *) set ./\$1 \$2 ;;
+esac
+
+: strip last component if it is to be a filename
+case X\$2 in
+ X1) set \`$echo \$1 | $sed 's:\(.*\)/[^/]*\$:\1:'\` ;;
+ *) set \$1 ;;
+esac
+
+: return reasonable status if nothing to be created
+if $test -d "\$1" ; then
+ exit 0
+fi
+
+list=''
+while true ; do
+ case \$1 in
+ */*)
+ list="\$1 \$list"
+ set \`echo \$1 | $sed 's:\(.*\)/:\1 :'\`
+ ;;
+ *)
+ break
+ ;;
+ esac
+done
+
+set \$list
+
+for dir do
+ $mkdir \$dir >/dev/null 2>&1
+done
+!GROK!THIS!
+$eunicefix makedir
+chmod +x makedir
diff --git a/contrib/perl5/malloc.c b/contrib/perl5/malloc.c
new file mode 100644
index 000000000000..73c4039d8006
--- /dev/null
+++ b/contrib/perl5/malloc.c
@@ -0,0 +1,1663 @@
+/* malloc.c
+ *
+ */
+
+/*
+ Here are some notes on configuring Perl's malloc.
+
+ There are two macros which serve as bulk disablers of advanced
+ features of this malloc: NO_FANCY_MALLOC, PLAIN_MALLOC (undef by
+ default). Look in the list of default values below to understand
+ their exact effect. Defining NO_FANCY_MALLOC returns malloc.c to the
+ state of the malloc in Perl 5.004. Additionally defining PLAIN_MALLOC
+ returns it to the state as of Perl 5.000.
+
+ Note that some of the settings below may be ignored in the code based
+ on values of other macros. The PERL_CORE symbol is only defined when
+ perl itself is being compiled (so malloc can make some assumptions
+ about perl's facilities being available to it).
+
+ Each config option has a short description, followed by its name,
+ default value, and a comment about the default (if applicable). Some
+ options take a precise value, while the others are just boolean.
+ The boolean ones are listed first.
+
+ # Enable code for an emergency memory pool in $^M. See perlvar.pod
+ # for a description of $^M.
+ PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && PERL_CORE)
+
+ # Enable code for printing memory statistics.
+ DEBUGGING_MSTATS (!PLAIN_MALLOC && PERL_CORE)
+
+ # Move allocation info for small buckets into separate areas.
+ # Memory optimization (especially for small allocations, of the
+ # less than 64 bytes). Since perl usually makes a large number
+ # of small allocations, this is usually a win.
+ PACK_MALLOC (!PLAIN_MALLOC && !RCHECK)
+
+ # Add one page to big powers of two when calculating bucket size.
+ # This is targeted at big allocations, as are common in image
+ # processing.
+ TWO_POT_OPTIMIZE !PLAIN_MALLOC
+
+ # Use intermediate bucket sizes between powers-of-two. This is
+ # generally a memory optimization, and a (small) speed pessimization.
+ BUCKETS_ROOT2 !NO_FANCY_MALLOC
+
+ # Do not check small deallocations for bad free(). Memory
+ # and speed optimization, error reporting pessimization.
+ IGNORE_SMALL_BAD_FREE (!NO_FANCY_MALLOC && !RCHECK)
+
+ # Use table lookup to decide in which bucket a given allocation will go.
+ SMALL_BUCKET_VIA_TABLE !NO_FANCY_MALLOC
+
+ # Use a perl-defined sbrk() instead of the (presumably broken or
+ # missing) system-supplied sbrk().
+ USE_PERL_SBRK undef
+
+ # Use system malloc() (or calloc() etc.) to emulate sbrk(). Normally
+ # only used with broken sbrk()s.
+ PERL_SBRK_VIA_MALLOC undef
+
+ # Which allocator to use if PERL_SBRK_VIA_MALLOC
+ SYSTEM_ALLOC(a) malloc(a)
+
+ # Disable memory overwrite checking with DEBUGGING. Memory and speed
+ # optimization, error reporting pessimization.
+ NO_RCHECK undef
+
+ # Enable memory overwrite checking with DEBUGGING. Memory and speed
+ # pessimization, error reporting optimization
+ RCHECK (DEBUGGING && !NO_RCHECK)
+
+ # Failed allocations bigger than this size croak (if
+ # PERL_EMERGENCY_SBRK is enabled) without touching $^M. See
+ # perlvar.pod for a description of $^M.
+ BIG_SIZE (1<<16) # 64K
+
+ # Starting from this power of two, add an extra page to the
+ # size of the bucket. This enables optimized allocations of sizes
+ # close to powers of 2. Note that the value is indexed at 0.
+ FIRST_BIG_POW2 15 # 32K, 16K is used too often
+
+ # Estimate of minimal memory footprint. malloc uses this value to
+ # request the most reasonable largest blocks of memory from the system.
+ FIRST_SBRK (48*1024)
+
+ # Round up sbrk()s to multiples of this.
+ MIN_SBRK 2048
+
+ # Round up sbrk()s to multiples of this percent of footprint.
+ MIN_SBRK_FRAC 3
+
+ # Add this much memory to big powers of two to get the bucket size.
+ PERL_PAGESIZE 4096
+
+ # This many sbrk() discontinuities should be tolerated even
+ # from the start without deciding that sbrk() is usually
+ # discontinuous.
+ SBRK_ALLOW_FAILURES 3
+
+ # This many continuous sbrk()s compensate for one discontinuous one.
+ SBRK_FAILURE_PRICE 50
+
+ # Some configurations may ask for 12-byte-or-so allocations which
+ # require 8-byte alignment (?!). In such situation one needs to
+ # define this to disable 12-byte bucket (will increase memory footprint)
+ STRICT_ALIGNMENT undef
+
+ This implementation assumes that calling PerlIO_printf() does not
+ result in any memory allocation calls (used during a panic).
+
+ */
+
+#ifndef NO_FANCY_MALLOC
+# ifndef SMALL_BUCKET_VIA_TABLE
+# define SMALL_BUCKET_VIA_TABLE
+# endif
+# ifndef BUCKETS_ROOT2
+# define BUCKETS_ROOT2
+# endif
+# ifndef IGNORE_SMALL_BAD_FREE
+# define IGNORE_SMALL_BAD_FREE
+# endif
+#endif
+
+#ifndef PLAIN_MALLOC /* Bulk enable features */
+# ifndef PACK_MALLOC
+# define PACK_MALLOC
+# endif
+# ifndef TWO_POT_OPTIMIZE
+# define TWO_POT_OPTIMIZE
+# endif
+# if defined(PERL_CORE) && !defined(PERL_EMERGENCY_SBRK)
+# define PERL_EMERGENCY_SBRK
+# endif
+# if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
+# define DEBUGGING_MSTATS
+# endif
+#endif
+
+#define MIN_BUC_POW2 (sizeof(void*) > 4 ? 3 : 2) /* Allow for 4-byte arena. */
+#define MIN_BUCKET (MIN_BUC_POW2 * BUCKETS_PER_POW2)
+
+#if !(defined(I286) || defined(atarist))
+ /* take 2k unless the block is bigger than that */
+# define LOG_OF_MIN_ARENA 11
+#else
+ /* take 16k unless the block is bigger than that
+ (80286s like large segments!), probably good on the atari too */
+# define LOG_OF_MIN_ARENA 14
+#endif
+
+#ifndef lint
+# if defined(DEBUGGING) && !defined(NO_RCHECK)
+# define RCHECK
+# endif
+# if defined(RCHECK) && defined(IGNORE_SMALL_BAD_FREE)
+# undef IGNORE_SMALL_BAD_FREE
+# endif
+/*
+ * malloc.c (Caltech) 2/21/82
+ * Chris Kingsley, kingsley@cit-20.
+ *
+ * This is a very fast storage allocator. It allocates blocks of a small
+ * number of different sizes, and keeps free lists of each size. Blocks that
+ * don't exactly fit are passed up to the next larger size. In this
+ * implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
+ * If PACK_MALLOC is defined, small blocks are 2^n bytes long.
+ * This is designed for use in a program that uses vast quantities of memory,
+ * but bombs when it runs out.
+ */
+
+#ifdef PERL_CORE
+# include "EXTERN.h"
+# include "perl.h"
+#else
+# ifdef PERL_FOR_X2P
+# include "../EXTERN.h"
+# include "../perl.h"
+# else
+# include <stdlib.h>
+# include <stdio.h>
+# include <memory.h>
+# define _(arg) arg
+# ifndef Malloc_t
+# define Malloc_t void *
+# endif
+# ifndef MEM_SIZE
+# define MEM_SIZE unsigned long
+# endif
+# ifndef LONG_MAX
+# define LONG_MAX 0x7FFFFFFF
+# endif
+# ifndef UV
+# define UV unsigned long
+# endif
+# ifndef caddr_t
+# define caddr_t char *
+# endif
+# ifndef Free_t
+# define Free_t void
+# endif
+# define Copy(s,d,n,t) (void)memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
+# define PerlEnv_getenv getenv
+# define PerlIO_printf fprintf
+# define PerlIO_stderr() stderr
+# endif
+# ifndef croak /* make depend */
+# define croak(mess, arg) warn((mess), (arg)); exit(1);
+# endif
+# ifndef warn
+# define warn(mess, arg) fprintf(stderr, (mess), (arg));
+# endif
+# ifdef DEBUG_m
+# undef DEBUG_m
+# endif
+# define DEBUG_m(a)
+# ifdef DEBUGGING
+# undef DEBUGGING
+# endif
+#endif
+
+#ifndef MUTEX_LOCK
+# define MUTEX_LOCK(l)
+#endif
+
+#ifndef MUTEX_UNLOCK
+# define MUTEX_UNLOCK(l)
+#endif
+
+#ifdef DEBUGGING
+# undef DEBUG_m
+# define DEBUG_m(a) if (PL_debug & 128) a
+#endif
+
+/* I don't much care whether these are defined in sys/types.h--LAW */
+
+#define u_char unsigned char
+#define u_int unsigned int
+
+#ifdef HAS_QUAD
+# define u_bigint UV /* Needs to eat *void. */
+#else /* needed? */
+# define u_bigint unsigned long /* Needs to eat *void. */
+#endif
+
+#define u_short unsigned short
+
+/* 286 and atarist like big chunks, which gives too much overhead. */
+#if (defined(RCHECK) || defined(I286) || defined(atarist)) && defined(PACK_MALLOC)
+# undef PACK_MALLOC
+#endif
+
+/*
+ * The description below is applicable if PACK_MALLOC is not defined.
+ *
+ * The overhead on a block is at least 4 bytes. When free, this space
+ * contains a pointer to the next free block, and the bottom two bits must
+ * be zero. When in use, the first byte is set to MAGIC, and the second
+ * byte is the size index. The remaining bytes are for alignment.
+ * If range checking is enabled and the size of the block fits
+ * in two bytes, then the top two bytes hold the size of the requested block
+ * plus the range checking words, and the header word MINUS ONE.
+ */
+union overhead {
+ union overhead *ov_next; /* when free */
+#if MEM_ALIGNBYTES > 4
+ double strut; /* alignment problems */
+#endif
+ struct {
+ u_char ovu_magic; /* magic number */
+ u_char ovu_index; /* bucket # */
+#ifdef RCHECK
+ u_short ovu_size; /* actual block size */
+ u_int ovu_rmagic; /* range magic number */
+#endif
+ } ovu;
+#define ov_magic ovu.ovu_magic
+#define ov_index ovu.ovu_index
+#define ov_size ovu.ovu_size
+#define ov_rmagic ovu.ovu_rmagic
+};
+
+#ifdef DEBUGGING
+static void botch _((char *diag, char *s));
+#endif
+static void morecore _((int bucket));
+static int findbucket _((union overhead *freep, int srchlen));
+static void add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip);
+
+#define MAGIC 0xff /* magic # on accounting info */
+#define RMAGIC 0x55555555 /* magic # on range info */
+#define RMAGIC_C 0x55 /* magic # on range info */
+
+#ifdef RCHECK
+# define RSLOP sizeof (u_int)
+# ifdef TWO_POT_OPTIMIZE
+# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2)
+# else
+# define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2)
+# endif
+#else
+# define RSLOP 0
+#endif
+
+#if !defined(PACK_MALLOC) && defined(BUCKETS_ROOT2)
+# undef BUCKETS_ROOT2
+#endif
+
+#ifdef BUCKETS_ROOT2
+# define BUCKET_TABLE_SHIFT 2
+# define BUCKET_POW2_SHIFT 1
+# define BUCKETS_PER_POW2 2
+#else
+# define BUCKET_TABLE_SHIFT MIN_BUC_POW2
+# define BUCKET_POW2_SHIFT 0
+# define BUCKETS_PER_POW2 1
+#endif
+
+#if !defined(MEM_ALIGNBYTES) || ((MEM_ALIGNBYTES > 4) && !defined(STRICT_ALIGNMENT))
+/* Figure out the alignment of void*. */
+struct aligner {
+ char c;
+ void *p;
+};
+# define ALIGN_SMALL ((int)((caddr_t)&(((struct aligner*)0)->p)))
+#else
+# define ALIGN_SMALL MEM_ALIGNBYTES
+#endif
+
+#define IF_ALIGN_8(yes,no) ((ALIGN_SMALL>4) ? (yes) : (no))
+
+#ifdef BUCKETS_ROOT2
+# define MAX_BUCKET_BY_TABLE 13
+static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] =
+ {
+ 0, 0, 0, 0, 4, 4, 8, 12, 16, 24, 32, 48, 64, 80,
+ };
+# define BUCKET_SIZE(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT)))
+# define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE \
+ ? buck_size[i] \
+ : ((1 << ((i) >> BUCKET_POW2_SHIFT)) \
+ - MEM_OVERHEAD(i) \
+ + POW2_OPTIMIZE_SURPLUS(i)))
+#else
+# define BUCKET_SIZE(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
+# define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i) + POW2_OPTIMIZE_SURPLUS(i))
+#endif
+
+
+#ifdef PACK_MALLOC
+/* In this case it is assumed that if we do sbrk() in 2K units, we
+ * will get 2K aligned arenas (at least after some initial
+ * alignment). The bucket number of the given subblock is on the start
+ * of 2K arena which contains the subblock. Several following bytes
+ * contain the magic numbers for the subblocks in the block.
+ *
+ * Sizes of chunks are powers of 2 for chunks in buckets <=
+ * MAX_PACKED, after this they are (2^n - sizeof(union overhead)) (to
+ * get alignment right).
+ *
+ * Consider an arena for 2^n with n>MAX_PACKED. We suppose that
+ * starts of all the chunks in a 2K arena are in different
+ * 2^n-byte-long chunks. If the top of the last chunk is aligned on a
+ * boundary of 2K block, this means that sizeof(union
+ * overhead)*"number of chunks" < 2^n, or sizeof(union overhead)*2K <
+ * 4^n, or n > 6 + log2(sizeof()/2)/2, since a chunk of size 2^n -
+ * overhead is used. Since this rules out n = 7 for 8 byte alignment,
+ * we specialcase allocation of the first of 16 128-byte-long chunks.
+ *
+ * Note that with the above assumption we automatically have enough
+ * place for MAGIC at the start of 2K block. Note also that we
+ * overlay union overhead over the chunk, thus the start of small chunks
+ * is immediately overwritten after freeing. */
+# define MAX_PACKED_POW2 6
+# define MAX_PACKED (MAX_PACKED_POW2 * BUCKETS_PER_POW2 + BUCKET_POW2_SHIFT)
+# define MAX_POW2_ALGO ((1<<(MAX_PACKED_POW2 + 1)) - M_OVERHEAD)
+# define TWOK_MASK ((1<<LOG_OF_MIN_ARENA) - 1)
+# define TWOK_MASKED(x) ((u_bigint)(x) & ~TWOK_MASK)
+# define TWOK_SHIFT(x) ((u_bigint)(x) & TWOK_MASK)
+# define OV_INDEXp(block) ((u_char*)(TWOK_MASKED(block)))
+# define OV_INDEX(block) (*OV_INDEXp(block))
+# define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) + \
+ (TWOK_SHIFT(block)>> \
+ (bucket>>BUCKET_POW2_SHIFT)) + \
+ (bucket >= MIN_NEEDS_SHIFT ? 1 : 0)))
+ /* A bucket can have a shift smaller than it size, we need to
+ shift its magic number so it will not overwrite index: */
+# ifdef BUCKETS_ROOT2
+# define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2 - 1) /* Shift 80 greater than chunk 64. */
+# else
+# define MIN_NEEDS_SHIFT (7*BUCKETS_PER_POW2) /* Shift 128 greater than chunk 32. */
+# endif
+# define CHUNK_SHIFT 0
+
+/* Number of active buckets of given ordinal. */
+#ifdef IGNORE_SMALL_BAD_FREE
+#define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */
+# define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
+ ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE(bucket) \
+ : n_blks[bucket] )
+#else
+# define N_BLKS(bucket) n_blks[bucket]
+#endif
+
+static u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
+ {
+# if BUCKETS_PER_POW2==1
+ 0, 0,
+ (MIN_BUC_POW2==2 ? 384 : 0),
+ 224, 120, 62, 31, 16, 8, 4, 2
+# else
+ 0, 0, 0, 0,
+ (MIN_BUC_POW2==2 ? 384 : 0), (MIN_BUC_POW2==2 ? 384 : 0), /* 4, 4 */
+ 224, 149, 120, 80, 62, 41, 31, 25, 16, 16, 8, 8, 4, 4, 2, 2
+# endif
+ };
+
+/* Shift of the first bucket with the given ordinal inside 2K chunk. */
+#ifdef IGNORE_SMALL_BAD_FREE
+# define BLK_SHIFT(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
+ ? ((1<<LOG_OF_MIN_ARENA) \
+ - BUCKET_SIZE(bucket) * N_BLKS(bucket)) \
+ : blk_shift[bucket])
+#else
+# define BLK_SHIFT(bucket) blk_shift[bucket]
+#endif
+
+static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] =
+ {
+# if BUCKETS_PER_POW2==1
+ 0, 0,
+ (MIN_BUC_POW2==2 ? 512 : 0),
+ 256, 128, 64, 64, /* 8 to 64 */
+ 16*sizeof(union overhead),
+ 8*sizeof(union overhead),
+ 4*sizeof(union overhead),
+ 2*sizeof(union overhead),
+# else
+ 0, 0, 0, 0,
+ (MIN_BUC_POW2==2 ? 512 : 0), (MIN_BUC_POW2==2 ? 512 : 0),
+ 256, 260, 128, 128, 64, 80, 64, 48, /* 8 to 96 */
+ 16*sizeof(union overhead), 16*sizeof(union overhead),
+ 8*sizeof(union overhead), 8*sizeof(union overhead),
+ 4*sizeof(union overhead), 4*sizeof(union overhead),
+ 2*sizeof(union overhead), 2*sizeof(union overhead),
+# endif
+ };
+
+#else /* !PACK_MALLOC */
+
+# define OV_MAGIC(block,bucket) (block)->ov_magic
+# define OV_INDEX(block) (block)->ov_index
+# define CHUNK_SHIFT 1
+# define MAX_PACKED -1
+#endif /* !PACK_MALLOC */
+
+#define M_OVERHEAD (sizeof(union overhead) + RSLOP)
+
+#ifdef PACK_MALLOC
+# define MEM_OVERHEAD(bucket) \
+ (bucket <= MAX_PACKED ? 0 : M_OVERHEAD)
+# ifdef SMALL_BUCKET_VIA_TABLE
+# define START_SHIFTS_BUCKET ((MAX_PACKED_POW2 + 1) * BUCKETS_PER_POW2)
+# define START_SHIFT MAX_PACKED_POW2
+# ifdef BUCKETS_ROOT2 /* Chunks of size 3*2^n. */
+# define SIZE_TABLE_MAX 80
+# else
+# define SIZE_TABLE_MAX 64
+# endif
+static char bucket_of[] =
+ {
+# ifdef BUCKETS_ROOT2 /* Chunks of size 3*2^n. */
+ /* 0 to 15 in 4-byte increments. */
+ (sizeof(void*) > 4 ? 6 : 5), /* 4/8, 5-th bucket for better reports */
+ 6, /* 8 */
+ IF_ALIGN_8(8,7), 8, /* 16/12, 16 */
+ 9, 9, 10, 10, /* 24, 32 */
+ 11, 11, 11, 11, /* 48 */
+ 12, 12, 12, 12, /* 64 */
+ 13, 13, 13, 13, /* 80 */
+ 13, 13, 13, 13 /* 80 */
+# else /* !BUCKETS_ROOT2 */
+ /* 0 to 15 in 4-byte increments. */
+ (sizeof(void*) > 4 ? 3 : 2),
+ 3,
+ 4, 4,
+ 5, 5, 5, 5,
+ 6, 6, 6, 6,
+ 6, 6, 6, 6
+# endif /* !BUCKETS_ROOT2 */
+ };
+# else /* !SMALL_BUCKET_VIA_TABLE */
+# define START_SHIFTS_BUCKET MIN_BUCKET
+# define START_SHIFT (MIN_BUC_POW2 - 1)
+# endif /* !SMALL_BUCKET_VIA_TABLE */
+#else /* !PACK_MALLOC */
+# define MEM_OVERHEAD(bucket) M_OVERHEAD
+# ifdef SMALL_BUCKET_VIA_TABLE
+# undef SMALL_BUCKET_VIA_TABLE
+# endif
+# define START_SHIFTS_BUCKET MIN_BUCKET
+# define START_SHIFT (MIN_BUC_POW2 - 1)
+#endif /* !PACK_MALLOC */
+
+/*
+ * Big allocations are often of the size 2^n bytes. To make them a
+ * little bit better, make blocks of size 2^n+pagesize for big n.
+ */
+
+#ifdef TWO_POT_OPTIMIZE
+
+# ifndef PERL_PAGESIZE
+# define PERL_PAGESIZE 4096
+# endif
+# ifndef FIRST_BIG_POW2
+# define FIRST_BIG_POW2 15 /* 32K, 16K is used too often. */
+# endif
+# define FIRST_BIG_BLOCK (1<<FIRST_BIG_POW2)
+/* If this value or more, check against bigger blocks. */
+# define FIRST_BIG_BOUND (FIRST_BIG_BLOCK - M_OVERHEAD)
+/* If less than this value, goes into 2^n-overhead-block. */
+# define LAST_SMALL_BOUND ((FIRST_BIG_BLOCK>>1) - M_OVERHEAD)
+
+# define POW2_OPTIMIZE_ADJUST(nbytes) \
+ ((nbytes >= FIRST_BIG_BOUND) ? nbytes -= PERL_PAGESIZE : 0)
+# define POW2_OPTIMIZE_SURPLUS(bucket) \
+ ((bucket >= FIRST_BIG_POW2 * BUCKETS_PER_POW2) ? PERL_PAGESIZE : 0)
+
+#else /* !TWO_POT_OPTIMIZE */
+# define POW2_OPTIMIZE_ADJUST(nbytes)
+# define POW2_OPTIMIZE_SURPLUS(bucket) 0
+#endif /* !TWO_POT_OPTIMIZE */
+
+#if defined(HAS_64K_LIMIT) && defined(PERL_CORE)
+# define BARK_64K_LIMIT(what,nbytes,size) \
+ if (nbytes > 0xffff) { \
+ PerlIO_printf(PerlIO_stderr(), \
+ "%s too large: %lx\n", what, size); \
+ my_exit(1); \
+ }
+#else /* !HAS_64K_LIMIT || !PERL_CORE */
+# define BARK_64K_LIMIT(what,nbytes,size)
+#endif /* !HAS_64K_LIMIT || !PERL_CORE */
+
+#ifndef MIN_SBRK
+# define MIN_SBRK 2048
+#endif
+
+#ifndef FIRST_SBRK
+# define FIRST_SBRK (48*1024)
+#endif
+
+/* Minimal sbrk in percents of what is already alloced. */
+#ifndef MIN_SBRK_FRAC
+# define MIN_SBRK_FRAC 3
+#endif
+
+#ifndef SBRK_ALLOW_FAILURES
+# define SBRK_ALLOW_FAILURES 3
+#endif
+
+#ifndef SBRK_FAILURE_PRICE
+# define SBRK_FAILURE_PRICE 50
+#endif
+
+#if defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)
+
+# ifndef BIG_SIZE
+# define BIG_SIZE (1<<16) /* 64K */
+# endif
+
+static char *emergency_buffer;
+static MEM_SIZE emergency_buffer_size;
+
+static Malloc_t
+emergency_sbrk(size)
+ MEM_SIZE size;
+{
+ MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
+
+ if (size >= BIG_SIZE) {
+ /* Give the possibility to recover: */
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ croak("Out of memory during \"large\" request for %i bytes", size);
+ }
+
+ if (emergency_buffer_size >= rsize) {
+ char *old = emergency_buffer;
+
+ emergency_buffer_size -= rsize;
+ emergency_buffer += rsize;
+ return old;
+ } else {
+ dTHR;
+ /* First offense, give a possibility to recover by dieing. */
+ /* No malloc involved here: */
+ GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0);
+ SV *sv;
+ char *pv;
+ int have = 0;
+
+ if (emergency_buffer_size) {
+ add_to_chain(emergency_buffer, emergency_buffer_size, 0);
+ emergency_buffer_size = 0;
+ emergency_buffer = Nullch;
+ have = 1;
+ }
+ if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0);
+ if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv)
+ || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) {
+ if (have)
+ goto do_croak;
+ return (char *)-1; /* Now die die die... */
+ }
+ /* Got it, now detach SvPV: */
+ pv = SvPV(sv, PL_na);
+ /* Check alignment: */
+ if (((UV)(pv - sizeof(union overhead))) & ((1<<LOG_OF_MIN_ARENA) - 1)) {
+ PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
+ return (char *)-1; /* die die die */
+ }
+
+ emergency_buffer = pv - sizeof(union overhead);
+ emergency_buffer_size = malloced_size(pv) + M_OVERHEAD;
+ SvPOK_off(sv);
+ SvPVX(sv) = Nullch;
+ SvCUR(sv) = SvLEN(sv) = 0;
+ }
+ do_croak:
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ croak("Out of memory during request for %i bytes", size);
+}
+
+#else /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
+# define emergency_sbrk(size) -1
+#endif /* !(defined(PERL_EMERGENCY_SBRK) && defined(PERL_CORE)) */
+
+/*
+ * nextf[i] is the pointer to the next free block of size 2^i. The
+ * smallest allocatable block is 8 bytes. The overhead information
+ * precedes the data area returned to the user.
+ */
+#define NBUCKETS (32*BUCKETS_PER_POW2 + 1)
+static union overhead *nextf[NBUCKETS];
+
+#ifdef USE_PERL_SBRK
+#define sbrk(a) Perl_sbrk(a)
+Malloc_t Perl_sbrk _((int size));
+#else
+#ifdef DONT_DECLARE_STD
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+#else
+extern Malloc_t sbrk(int);
+#endif
+#endif
+
+#ifdef DEBUGGING_MSTATS
+/*
+ * nmalloc[i] is the difference between the number of mallocs and frees
+ * for a given block size.
+ */
+static u_int nmalloc[NBUCKETS];
+static u_int sbrk_slack;
+static u_int start_slack;
+#endif
+
+static u_int goodsbrk;
+
+#ifdef DEBUGGING
+#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p)); else
+static void
+botch(char *diag, char *s)
+{
+ PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s);
+ PerlProc_abort();
+}
+#else
+#define ASSERT(p, diag)
+#endif
+
+Malloc_t
+malloc(register size_t nbytes)
+{
+ register union overhead *p;
+ register int bucket;
+ register MEM_SIZE shiftr;
+
+#if defined(DEBUGGING) || defined(RCHECK)
+ MEM_SIZE size = nbytes;
+#endif
+
+ BARK_64K_LIMIT("Allocation",nbytes,nbytes);
+#ifdef DEBUGGING
+ if ((long)nbytes < 0)
+ croak("%s", "panic: malloc");
+#endif
+
+ MUTEX_LOCK(&PL_malloc_mutex);
+ /*
+ * Convert amount of memory requested into
+ * closest block size stored in hash buckets
+ * which satisfies request. Account for
+ * space used per block for accounting.
+ */
+#ifdef PACK_MALLOC
+# ifdef SMALL_BUCKET_VIA_TABLE
+ if (nbytes == 0)
+ bucket = MIN_BUCKET;
+ else if (nbytes <= SIZE_TABLE_MAX) {
+ bucket = bucket_of[(nbytes - 1) >> BUCKET_TABLE_SHIFT];
+ } else
+# else
+ if (nbytes == 0)
+ nbytes = 1;
+ if (nbytes <= MAX_POW2_ALGO) goto do_shifts;
+ else
+# endif
+#endif
+ {
+ POW2_OPTIMIZE_ADJUST(nbytes);
+ nbytes += M_OVERHEAD;
+ nbytes = (nbytes + 3) &~ 3;
+ do_shifts:
+ shiftr = (nbytes - 1) >> START_SHIFT;
+ bucket = START_SHIFTS_BUCKET;
+ /* apart from this loop, this is O(1) */
+ while (shiftr >>= 1)
+ bucket += BUCKETS_PER_POW2;
+ }
+ /*
+ * If nothing in hash bucket right now,
+ * request more memory from the system.
+ */
+ if (nextf[bucket] == NULL)
+ morecore(bucket);
+ if ((p = nextf[bucket]) == NULL) {
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+#ifdef PERL_CORE
+ if (!PL_nomemok) {
+ PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
+ my_exit(1);
+ }
+#else
+ return (NULL);
+#endif
+ }
+
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "0x%lx: (%05lu) malloc %ld bytes\n",
+ (unsigned long)(p+1), (unsigned long)(PL_an++),
+ (long)size));
+
+ /* remove from linked list */
+#if defined(RCHECK)
+ if (((UV)p) & (MEM_ALIGNBYTES - 1))
+ PerlIO_printf(PerlIO_stderr(), "Corrupt malloc ptr 0x%lx at 0x%lx\n",
+ (unsigned long)*((int*)p),(unsigned long)p);
+#endif
+ nextf[bucket] = p->ov_next;
+#ifdef IGNORE_SMALL_BAD_FREE
+ if (bucket >= FIRST_BUCKET_WITH_CHECK)
+#endif
+ OV_MAGIC(p, bucket) = MAGIC;
+#ifndef PACK_MALLOC
+ OV_INDEX(p) = bucket;
+#endif
+#ifdef RCHECK
+ /*
+ * Record allocated size of block and
+ * bound space with magic numbers.
+ */
+ p->ov_rmagic = RMAGIC;
+ if (bucket <= MAX_SHORT_BUCKET) {
+ int i;
+
+ nbytes = size + M_OVERHEAD;
+ p->ov_size = nbytes - 1;
+ if ((i = nbytes & 3)) {
+ i = 4 - i;
+ while (i--)
+ *((char *)((caddr_t)p + nbytes - RSLOP + i)) = RMAGIC_C;
+ }
+ nbytes = (nbytes + 3) &~ 3;
+ *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
+ }
+#endif
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ return ((Malloc_t)(p + CHUNK_SHIFT));
+}
+
+static char *last_sbrk_top;
+static char *last_op; /* This arena can be easily extended. */
+static int sbrked_remains;
+static int sbrk_good = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE;
+
+#ifdef DEBUGGING_MSTATS
+static int sbrks;
+#endif
+
+struct chunk_chain_s {
+ struct chunk_chain_s *next;
+ MEM_SIZE size;
+};
+static struct chunk_chain_s *chunk_chain;
+static int n_chunks;
+static char max_bucket;
+
+/* Cutoff a piece of one of the chunks in the chain. Prefer smaller chunk. */
+static void *
+get_from_chain(MEM_SIZE size)
+{
+ struct chunk_chain_s *elt = chunk_chain, **oldp = &chunk_chain;
+ struct chunk_chain_s **oldgoodp = NULL;
+ long min_remain = LONG_MAX;
+
+ while (elt) {
+ if (elt->size >= size) {
+ long remains = elt->size - size;
+ if (remains >= 0 && remains < min_remain) {
+ oldgoodp = oldp;
+ min_remain = remains;
+ }
+ if (remains == 0) {
+ break;
+ }
+ }
+ oldp = &( elt->next );
+ elt = elt->next;
+ }
+ if (!oldgoodp) return NULL;
+ if (min_remain) {
+ void *ret = *oldgoodp;
+ struct chunk_chain_s *next = (*oldgoodp)->next;
+
+ *oldgoodp = (struct chunk_chain_s *)((char*)ret + size);
+ (*oldgoodp)->size = min_remain;
+ (*oldgoodp)->next = next;
+ return ret;
+ } else {
+ void *ret = *oldgoodp;
+ *oldgoodp = (*oldgoodp)->next;
+ n_chunks--;
+ return ret;
+ }
+}
+
+static void
+add_to_chain(void *p, MEM_SIZE size, MEM_SIZE chip)
+{
+ struct chunk_chain_s *next = chunk_chain;
+ char *cp = (char*)p;
+
+ cp += chip;
+ chunk_chain = (struct chunk_chain_s *)cp;
+ chunk_chain->size = size - chip;
+ chunk_chain->next = next;
+ n_chunks++;
+}
+
+static void *
+get_from_bigger_buckets(int bucket, MEM_SIZE size)
+{
+ int price = 1;
+ static int bucketprice[NBUCKETS];
+ while (bucket <= max_bucket) {
+ /* We postpone stealing from bigger buckets until we want it
+ often enough. */
+ if (nextf[bucket] && bucketprice[bucket]++ >= price) {
+ /* Steal it! */
+ void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT);
+ bucketprice[bucket] = 0;
+ if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) {
+ last_op = NULL; /* Disable optimization */
+ }
+ nextf[bucket] = nextf[bucket]->ov_next;
+#ifdef DEBUGGING_MSTATS
+ nmalloc[bucket]--;
+ start_slack -= M_OVERHEAD;
+#endif
+ add_to_chain(ret, (BUCKET_SIZE(bucket) +
+ POW2_OPTIMIZE_SURPLUS(bucket)),
+ size);
+ return ret;
+ }
+ bucket++;
+ }
+ return NULL;
+}
+
+static union overhead *
+getpages(int needed, int *nblksp, int bucket)
+{
+ /* Need to do (possibly expensive) system call. Try to
+ optimize it for rare calling. */
+ MEM_SIZE require = needed - sbrked_remains;
+ char *cp;
+ union overhead *ovp;
+ int slack = 0;
+
+ if (sbrk_good > 0) {
+ if (!last_sbrk_top && require < FIRST_SBRK)
+ require = FIRST_SBRK;
+ else if (require < MIN_SBRK) require = MIN_SBRK;
+
+ if (require < goodsbrk * MIN_SBRK_FRAC / 100)
+ require = goodsbrk * MIN_SBRK_FRAC / 100;
+ require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK;
+ } else {
+ require = needed;
+ last_sbrk_top = 0;
+ sbrked_remains = 0;
+ }
+
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "sbrk(%ld) for %ld-byte-long arena\n",
+ (long)require, (long) needed));
+ cp = (char *)sbrk(require);
+#ifdef DEBUGGING_MSTATS
+ sbrks++;
+#endif
+ if (cp == last_sbrk_top) {
+ /* Common case, anything is fine. */
+ sbrk_good++;
+ ovp = (union overhead *) (cp - sbrked_remains);
+ sbrked_remains = require - (needed - sbrked_remains);
+ } else if (cp == (char *)-1) { /* no more room! */
+ ovp = (union overhead *)emergency_sbrk(needed);
+ if (ovp == (union overhead *)-1)
+ return 0;
+ return ovp;
+ } else { /* Non-continuous or first sbrk(). */
+ long add = sbrked_remains;
+ char *newcp;
+
+ if (sbrked_remains) { /* Put rest into chain, we
+ cannot use it right now. */
+ add_to_chain((void*)(last_sbrk_top - sbrked_remains),
+ sbrked_remains, 0);
+ }
+
+ /* Second, check alignment. */
+ slack = 0;
+
+#ifndef atarist /* on the atari we dont have to worry about this */
+# ifndef I286 /* The sbrk(0) call on the I286 always returns the next segment */
+
+ /* CHUNK_SHIFT is 1 for PACK_MALLOC, 0 otherwise. */
+ if ((UV)cp & (0x7FF >> CHUNK_SHIFT)) { /* Not aligned. */
+ slack = (0x800 >> CHUNK_SHIFT)
+ - ((UV)cp & (0x7FF >> CHUNK_SHIFT));
+ add += slack;
+ }
+# endif
+#endif /* atarist */
+
+ if (add) {
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "sbrk(%ld) to fix non-continuous/off-page sbrk:\n\t%ld for alignement,\t%ld were assumed to come from the tail of the previous sbrk\n",
+ (long)add, (long) slack,
+ (long) sbrked_remains));
+ newcp = (char *)sbrk(add);
+#if defined(DEBUGGING_MSTATS)
+ sbrks++;
+ sbrk_slack += add;
+#endif
+ if (newcp != cp + require) {
+ /* Too bad: even rounding sbrk() is not continuous.*/
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "failed to fix bad sbrk()\n"));
+#ifdef PACK_MALLOC
+ if (slack) {
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ croak("%s", "panic: Off-page sbrk");
+ }
+#endif
+ if (sbrked_remains) {
+ /* Try again. */
+#if defined(DEBUGGING_MSTATS)
+ sbrk_slack += require;
+#endif
+ require = needed;
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "straight sbrk(%ld)\n",
+ (long)require));
+ cp = (char *)sbrk(require);
+#ifdef DEBUGGING_MSTATS
+ sbrks++;
+#endif
+ if (cp == (char *)-1)
+ return 0;
+ }
+ sbrk_good = -1; /* Disable optimization!
+ Continue with not-aligned... */
+ } else {
+ cp += slack;
+ require += sbrked_remains;
+ }
+ }
+
+ if (last_sbrk_top) {
+ sbrk_good -= SBRK_FAILURE_PRICE;
+ }
+
+ ovp = (union overhead *) cp;
+ /*
+ * Round up to minimum allocation size boundary
+ * and deduct from block count to reflect.
+ */
+
+#ifndef I286 /* Again, this should always be ok on an 80286 */
+ if ((UV)ovp & 7) {
+ ovp = (union overhead *)(((UV)ovp + 8) & ~7);
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "fixing sbrk(): %d bytes off machine alignement\n",
+ (int)((UV)ovp & 7)));
+ (*nblksp)--;
+# if defined(DEBUGGING_MSTATS)
+ /* This is only approx. if TWO_POT_OPTIMIZE: */
+ sbrk_slack += (1 << bucket);
+# endif
+ }
+#endif
+ sbrked_remains = require - needed;
+ }
+ last_sbrk_top = cp + require;
+ last_op = (char*) cp;
+#ifdef DEBUGGING_MSTATS
+ goodsbrk += require;
+#endif
+ return ovp;
+}
+
+static int
+getpages_adjacent(int require)
+{
+ if (require <= sbrked_remains) {
+ sbrked_remains -= require;
+ } else {
+ char *cp;
+
+ require -= sbrked_remains;
+ /* We do not try to optimize sbrks here, we go for place. */
+ cp = (char*) sbrk(require);
+#ifdef DEBUGGING_MSTATS
+ sbrks++;
+ goodsbrk += require;
+#endif
+ if (cp == last_sbrk_top) {
+ sbrked_remains = 0;
+ last_sbrk_top = cp + require;
+ } else {
+ if (cp == (char*)-1) { /* Out of memory */
+#ifdef DEBUGGING_MSTATS
+ goodsbrk -= require;
+#endif
+ return 0;
+ }
+ /* Report the failure: */
+ if (sbrked_remains)
+ add_to_chain((void*)(last_sbrk_top - sbrked_remains),
+ sbrked_remains, 0);
+ add_to_chain((void*)cp, require, 0);
+ sbrk_good -= SBRK_FAILURE_PRICE;
+ sbrked_remains = 0;
+ last_sbrk_top = 0;
+ last_op = 0;
+ return 0;
+ }
+ }
+
+ return 1;
+}
+
+/*
+ * Allocate more memory to the indicated bucket.
+ */
+static void
+morecore(register int bucket)
+{
+ register union overhead *ovp;
+ register int rnu; /* 2^rnu bytes will be requested */
+ int nblks; /* become nblks blocks of the desired size */
+ register MEM_SIZE siz, needed;
+
+ if (nextf[bucket])
+ return;
+ if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ croak("%s", "Out of memory during ridiculously large request");
+ }
+ if (bucket > max_bucket)
+ max_bucket = bucket;
+
+ rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT))
+ ? LOG_OF_MIN_ARENA
+ : (bucket >> BUCKET_POW2_SHIFT) );
+ /* This may be overwritten later: */
+ nblks = 1 << (rnu - (bucket >> BUCKET_POW2_SHIFT)); /* how many blocks to get */
+ needed = ((MEM_SIZE)1 << rnu) + POW2_OPTIMIZE_SURPLUS(bucket);
+ if (nextf[rnu << BUCKET_POW2_SHIFT]) { /* 2048b bucket. */
+ ovp = nextf[rnu << BUCKET_POW2_SHIFT] - 1 + CHUNK_SHIFT;
+ nextf[rnu << BUCKET_POW2_SHIFT]
+ = nextf[rnu << BUCKET_POW2_SHIFT]->ov_next;
+#ifdef DEBUGGING_MSTATS
+ nmalloc[rnu << BUCKET_POW2_SHIFT]--;
+ start_slack -= M_OVERHEAD;
+#endif
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "stealing %ld bytes from %ld arena\n",
+ (long) needed, (long) rnu << BUCKET_POW2_SHIFT));
+ } else if (chunk_chain
+ && (ovp = (union overhead*) get_from_chain(needed))) {
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "stealing %ld bytes from chain\n",
+ (long) needed));
+ } else if ( (ovp = (union overhead*)
+ get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1,
+ needed)) ) {
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "stealing %ld bytes from bigger buckets\n",
+ (long) needed));
+ } else if (needed <= sbrked_remains) {
+ ovp = (union overhead *)(last_sbrk_top - sbrked_remains);
+ sbrked_remains -= needed;
+ last_op = (char*)ovp;
+ } else
+ ovp = getpages(needed, &nblks, bucket);
+
+ if (!ovp)
+ return;
+
+ /*
+ * Add new memory allocated to that on
+ * free list for this hash bucket.
+ */
+ siz = BUCKET_SIZE(bucket);
+#ifdef PACK_MALLOC
+ *(u_char*)ovp = bucket; /* Fill index. */
+ if (bucket <= MAX_PACKED) {
+ ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
+ nblks = N_BLKS(bucket);
+# ifdef DEBUGGING_MSTATS
+ start_slack += BLK_SHIFT(bucket);
+# endif
+ } else if (bucket < LOG_OF_MIN_ARENA * BUCKETS_PER_POW2) {
+ ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket));
+ siz -= sizeof(union overhead);
+ } else ovp++; /* One chunk per block. */
+#endif /* PACK_MALLOC */
+ nextf[bucket] = ovp;
+#ifdef DEBUGGING_MSTATS
+ nmalloc[bucket] += nblks;
+ if (bucket > MAX_PACKED) {
+ start_slack += M_OVERHEAD * nblks;
+ }
+#endif
+ while (--nblks > 0) {
+ ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
+ ovp = (union overhead *)((caddr_t)ovp + siz);
+ }
+ /* Not all sbrks return zeroed memory.*/
+ ovp->ov_next = (union overhead *)NULL;
+#ifdef PACK_MALLOC
+ if (bucket == 7*BUCKETS_PER_POW2) { /* Special case, explanation is above. */
+ union overhead *n_op = nextf[7*BUCKETS_PER_POW2]->ov_next;
+ nextf[7*BUCKETS_PER_POW2] =
+ (union overhead *)((caddr_t)nextf[7*BUCKETS_PER_POW2]
+ - sizeof(union overhead));
+ nextf[7*BUCKETS_PER_POW2]->ov_next = n_op;
+ }
+#endif /* !PACK_MALLOC */
+}
+
+Free_t
+free(void *mp)
+{
+ register MEM_SIZE size;
+ register union overhead *ovp;
+ char *cp = (char*)mp;
+#ifdef PACK_MALLOC
+ u_char bucket;
+#endif
+
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "0x%lx: (%05lu) free\n",
+ (unsigned long)cp, (unsigned long)(PL_an++)));
+
+ if (cp == NULL)
+ return;
+ ovp = (union overhead *)((caddr_t)cp
+ - sizeof (union overhead) * CHUNK_SHIFT);
+#ifdef PACK_MALLOC
+ bucket = OV_INDEX(ovp);
+#endif
+#ifdef IGNORE_SMALL_BAD_FREE
+ if ((bucket >= FIRST_BUCKET_WITH_CHECK)
+ && (OV_MAGIC(ovp, bucket) != MAGIC))
+#else
+ if (OV_MAGIC(ovp, bucket) != MAGIC)
+#endif
+ {
+ static int bad_free_warn = -1;
+ if (bad_free_warn == -1) {
+ char *pbf = PerlEnv_getenv("PERL_BADFREE");
+ bad_free_warn = (pbf) ? atoi(pbf) : 1;
+ }
+ if (!bad_free_warn)
+ return;
+#ifdef RCHECK
+ warn("%s free() ignored",
+ ovp->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
+#else
+ warn("%s", "Bad free() ignored");
+#endif
+ return; /* sanity */
+ }
+ MUTEX_LOCK(&PL_malloc_mutex);
+#ifdef RCHECK
+ ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite");
+ if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
+ int i;
+ MEM_SIZE nbytes = ovp->ov_size + 1;
+
+ if ((i = nbytes & 3)) {
+ i = 4 - i;
+ while (i--) {
+ ASSERT(*((char *)((caddr_t)ovp + nbytes - RSLOP + i))
+ == RMAGIC_C, "chunk's tail overwrite");
+ }
+ }
+ nbytes = (nbytes + 3) &~ 3;
+ ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC, "chunk's tail overwrite");
+ }
+ ovp->ov_rmagic = RMAGIC - 1;
+#endif
+ ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite");
+ size = OV_INDEX(ovp);
+ ovp->ov_next = nextf[size];
+ nextf[size] = ovp;
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+}
+
+/*
+ * When a program attempts "storage compaction" as mentioned in the
+ * old malloc man page, it realloc's an already freed block. Usually
+ * this is the last block it freed; occasionally it might be farther
+ * back. We have to search all the free lists for the block in order
+ * to determine its bucket: 1st we make one pass thru the lists
+ * checking only the first block in each; if that fails we search
+ * ``reall_srchlen'' blocks in each list for a match (the variable
+ * is extern so the caller can modify it). If that fails we just copy
+ * however many bytes was given to realloc() and hope it's not huge.
+ */
+int reall_srchlen = 4; /* 4 should be plenty, -1 =>'s whole list */
+
+Malloc_t
+realloc(void *mp, size_t nbytes)
+{
+ register MEM_SIZE onb;
+ union overhead *ovp;
+ char *res;
+ int prev_bucket;
+ register int bucket;
+ int was_alloced = 0, incr;
+ char *cp = (char*)mp;
+
+#if defined(DEBUGGING) || !defined(PERL_CORE)
+ MEM_SIZE size = nbytes;
+
+ if ((long)nbytes < 0)
+ croak("%s", "panic: realloc");
+#endif
+
+ BARK_64K_LIMIT("Reallocation",nbytes,size);
+ if (!cp)
+ return malloc(nbytes);
+
+ MUTEX_LOCK(&PL_malloc_mutex);
+ ovp = (union overhead *)((caddr_t)cp
+ - sizeof (union overhead) * CHUNK_SHIFT);
+ bucket = OV_INDEX(ovp);
+#ifdef IGNORE_SMALL_BAD_FREE
+ if ((bucket < FIRST_BUCKET_WITH_CHECK)
+ || (OV_MAGIC(ovp, bucket) == MAGIC))
+#else
+ if (OV_MAGIC(ovp, bucket) == MAGIC)
+#endif
+ {
+ was_alloced = 1;
+ } else {
+ /*
+ * Already free, doing "compaction".
+ *
+ * Search for the old block of memory on the
+ * free list. First, check the most common
+ * case (last element free'd), then (this failing)
+ * the last ``reall_srchlen'' items free'd.
+ * If all lookups fail, then assume the size of
+ * the memory block being realloc'd is the
+ * smallest possible.
+ */
+ if ((bucket = findbucket(ovp, 1)) < 0 &&
+ (bucket = findbucket(ovp, reall_srchlen)) < 0)
+ bucket = 0;
+ }
+ onb = BUCKET_SIZE_REAL(bucket);
+ /*
+ * avoid the copy if same size block.
+ * We are not agressive with boundary cases. Note that it might
+ * (for a small number of cases) give false negative if
+ * both new size and old one are in the bucket for
+ * FIRST_BIG_POW2, but the new one is near the lower end.
+ *
+ * We do not try to go to 1.5 times smaller bucket so far.
+ */
+ if (nbytes > onb) incr = 1;
+ else {
+#ifdef DO_NOT_TRY_HARDER_WHEN_SHRINKING
+ if ( /* This is a little bit pessimal if PACK_MALLOC: */
+ nbytes > ( (onb >> 1) - M_OVERHEAD )
+# ifdef TWO_POT_OPTIMIZE
+ || (bucket == FIRST_BIG_POW2 && nbytes >= LAST_SMALL_BOUND )
+# endif
+ )
+#else /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
+ prev_bucket = ( (bucket > MAX_PACKED + 1)
+ ? bucket - BUCKETS_PER_POW2
+ : bucket - 1);
+ if (nbytes > BUCKET_SIZE_REAL(prev_bucket))
+#endif /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */
+ incr = 0;
+ else incr = -1;
+ }
+ if (!was_alloced
+#ifdef STRESS_REALLOC
+ || 1 /* always do it the hard way */
+#endif
+ ) goto hard_way;
+ else if (incr == 0) {
+ inplace_label:
+#ifdef RCHECK
+ /*
+ * Record new allocated size of block and
+ * bound space with magic numbers.
+ */
+ if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
+ int i, nb = ovp->ov_size + 1;
+
+ if ((i = nb & 3)) {
+ i = 4 - i;
+ while (i--) {
+ ASSERT(*((char *)((caddr_t)ovp + nb - RSLOP + i)) == RMAGIC_C, "chunk's tail overwrite");
+ }
+ }
+ nb = (nb + 3) &~ 3;
+ ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC, "chunk's tail overwrite");
+ /*
+ * Convert amount of memory requested into
+ * closest block size stored in hash buckets
+ * which satisfies request. Account for
+ * space used per block for accounting.
+ */
+ nbytes += M_OVERHEAD;
+ ovp->ov_size = nbytes - 1;
+ if ((i = nbytes & 3)) {
+ i = 4 - i;
+ while (i--)
+ *((char *)((caddr_t)ovp + nbytes - RSLOP + i))
+ = RMAGIC_C;
+ }
+ nbytes = (nbytes + 3) &~ 3;
+ *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC;
+ }
+#endif
+ res = cp;
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "0x%lx: (%05lu) realloc %ld bytes inplace\n",
+ (unsigned long)res,(unsigned long)(PL_an++),
+ (long)size));
+ } else if (incr == 1 && (cp - M_OVERHEAD == last_op)
+ && (onb > (1 << LOG_OF_MIN_ARENA))) {
+ MEM_SIZE require, newarena = nbytes, pow;
+ int shiftr;
+
+ POW2_OPTIMIZE_ADJUST(newarena);
+ newarena = newarena + M_OVERHEAD;
+ /* newarena = (newarena + 3) &~ 3; */
+ shiftr = (newarena - 1) >> LOG_OF_MIN_ARENA;
+ pow = LOG_OF_MIN_ARENA + 1;
+ /* apart from this loop, this is O(1) */
+ while (shiftr >>= 1)
+ pow++;
+ newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2);
+ require = newarena - onb - M_OVERHEAD;
+
+ if (getpages_adjacent(require)) {
+#ifdef DEBUGGING_MSTATS
+ nmalloc[bucket]--;
+ nmalloc[pow * BUCKETS_PER_POW2]++;
+#endif
+ *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */
+ goto inplace_label;
+ } else
+ goto hard_way;
+ } else {
+ hard_way:
+ MUTEX_UNLOCK(&PL_malloc_mutex);
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "0x%lx: (%05lu) realloc %ld bytes the hard way\n",
+ (unsigned long)cp,(unsigned long)(PL_an++),
+ (long)size));
+ if ((res = (char*)malloc(nbytes)) == NULL)
+ return (NULL);
+ if (cp != res) /* common optimization */
+ Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char);
+ if (was_alloced)
+ free(cp);
+ }
+ return ((Malloc_t)res);
+}
+
+/*
+ * Search ``srchlen'' elements of each free list for a block whose
+ * header starts at ``freep''. If srchlen is -1 search the whole list.
+ * Return bucket number, or -1 if not found.
+ */
+static int
+findbucket(union overhead *freep, int srchlen)
+{
+ register union overhead *p;
+ register int i, j;
+
+ for (i = 0; i < NBUCKETS; i++) {
+ j = 0;
+ for (p = nextf[i]; p && j != srchlen; p = p->ov_next) {
+ if (p == freep)
+ return (i);
+ j++;
+ }
+ }
+ return (-1);
+}
+
+Malloc_t
+calloc(register size_t elements, register size_t size)
+{
+ long sz = elements * size;
+ Malloc_t p = malloc(sz);
+
+ if (p) {
+ memset((void*)p, 0, sz);
+ }
+ return p;
+}
+
+MEM_SIZE
+malloced_size(void *p)
+{
+ union overhead *ovp = (union overhead *)
+ ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT);
+ int bucket = OV_INDEX(ovp);
+#ifdef RCHECK
+ /* The caller wants to have a complete control over the chunk,
+ disable the memory checking inside the chunk. */
+ if (bucket <= MAX_SHORT_BUCKET) {
+ MEM_SIZE size = BUCKET_SIZE_REAL(bucket);
+ ovp->ov_size = size + M_OVERHEAD - 1;
+ *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RSLOP)) = RMAGIC;
+ }
+#endif
+ return BUCKET_SIZE_REAL(bucket);
+}
+
+#ifdef DEBUGGING_MSTATS
+
+# ifdef BUCKETS_ROOT2
+# define MIN_EVEN_REPORT 6
+# else
+# define MIN_EVEN_REPORT MIN_BUCKET
+# endif
+/*
+ * mstats - print out statistics about malloc
+ *
+ * Prints two lines of numbers, one showing the length of the free list
+ * for each size category, the second showing the number of mallocs -
+ * frees for each size category.
+ */
+void
+dump_mstats(char *s)
+{
+ register int i, j;
+ register union overhead *p;
+ int topbucket=0, topbucket_ev=0, topbucket_odd=0, totfree=0, total=0;
+ u_int nfree[NBUCKETS];
+ int total_chain = 0;
+ struct chunk_chain_s* nextchain = chunk_chain;
+
+ for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
+ for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
+ ;
+ nfree[i] = j;
+ totfree += nfree[i] * BUCKET_SIZE_REAL(i);
+ total += nmalloc[i] * BUCKET_SIZE_REAL(i);
+ if (nmalloc[i]) {
+ i % 2 ? (topbucket_odd = i) : (topbucket_ev = i);
+ topbucket = i;
+ }
+ }
+ if (s)
+ PerlIO_printf(PerlIO_stderr(),
+ "Memory allocation statistics %s (buckets %ld(%ld)..%ld(%ld)\n",
+ s,
+ (long)BUCKET_SIZE_REAL(MIN_BUCKET),
+ (long)BUCKET_SIZE(MIN_BUCKET),
+ (long)BUCKET_SIZE_REAL(topbucket), (long)BUCKET_SIZE(topbucket));
+ PerlIO_printf(PerlIO_stderr(), "%8d free:", totfree);
+ for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) {
+ PerlIO_printf(PerlIO_stderr(),
+ ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
+ ? " %5d"
+ : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
+ nfree[i]);
+ }
+#ifdef BUCKETS_ROOT2
+ PerlIO_printf(PerlIO_stderr(), "\n\t ");
+ for (i = MIN_BUCKET + 1; i <= topbucket_odd; i += BUCKETS_PER_POW2) {
+ PerlIO_printf(PerlIO_stderr(),
+ ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
+ ? " %5d"
+ : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
+ nfree[i]);
+ }
+#endif
+ PerlIO_printf(PerlIO_stderr(), "\n%8d used:", total - totfree);
+ for (i = MIN_EVEN_REPORT; i <= topbucket; i += BUCKETS_PER_POW2) {
+ PerlIO_printf(PerlIO_stderr(),
+ ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
+ ? " %5d"
+ : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
+ nmalloc[i] - nfree[i]);
+ }
+#ifdef BUCKETS_ROOT2
+ PerlIO_printf(PerlIO_stderr(), "\n\t ");
+ for (i = MIN_BUCKET + 1; i <= topbucket_odd; i += BUCKETS_PER_POW2) {
+ PerlIO_printf(PerlIO_stderr(),
+ ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2)
+ ? " %5d"
+ : ((i < 12*BUCKETS_PER_POW2) ? " %3d" : " %d")),
+ nmalloc[i] - nfree[i]);
+ }
+#endif
+ while (nextchain) {
+ total_chain += nextchain->size;
+ nextchain = nextchain->next;
+ }
+ PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %d/%d:%d. Odd ends: pad+heads+chain+tail: %d+%d+%d+%d.\n",
+ goodsbrk + sbrk_slack, sbrks, sbrk_good, sbrk_slack,
+ start_slack, total_chain, sbrked_remains);
+}
+#else
+void
+dump_mstats(char *s)
+{
+}
+#endif
+#endif /* lint */
+
+
+#ifdef USE_PERL_SBRK
+
+# ifdef NeXT
+# define PERL_SBRK_VIA_MALLOC
+# endif
+
+# ifdef __MACHTEN_PPC__
+# define PERL_SBRK_VIA_MALLOC
+/*
+ * MachTen's malloc() returns a buffer aligned on a two-byte boundary.
+ * While this is adequate, it may slow down access to longer data
+ * types by forcing multiple memory accesses. It also causes
+ * complaints when RCHECK is in force. So we allocate six bytes
+ * more than we need to, and return an address rounded up to an
+ * eight-byte boundary.
+ *
+ * 980701 Dominic Dunlop <domo@computer.org>
+ */
+# define SYSTEM_ALLOC(a) ((void *)(((unsigned)malloc((a)+6)+6)&~7))
+# endif
+
+# ifdef PERL_SBRK_VIA_MALLOC
+# if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)
+# undef malloc /* Expose names that */
+# undef calloc /* HIDEMYMALLOC hides */
+# undef realloc
+# undef free
+# else
+# include "Error: -DPERL_SBRK_VIA_MALLOC needs -D(HIDE|EMBED)MYMALLOC"
+# endif
+
+/* it may seem schizophrenic to use perl's malloc and let it call system */
+/* malloc, the reason for that is only the 3.2 version of the OS that had */
+/* frequent core dumps within nxzonefreenolock. This sbrk routine put an */
+/* end to the cores */
+
+# ifndef SYSTEM_ALLOC
+# define SYSTEM_ALLOC(a) malloc(a)
+# endif
+
+# endif /* PERL_SBRK_VIA_MALLOC */
+
+static IV Perl_sbrk_oldchunk;
+static long Perl_sbrk_oldsize;
+
+# define PERLSBRK_32_K (1<<15)
+# define PERLSBRK_64_K (1<<16)
+
+Malloc_t
+Perl_sbrk(size)
+int size;
+{
+ IV got;
+ int small, reqsize;
+
+ if (!size) return 0;
+#ifdef PERL_CORE
+ reqsize = size; /* just for the DEBUG_m statement */
+#endif
+#ifdef PACK_MALLOC
+ size = (size + 0x7ff) & ~0x7ff;
+#endif
+ if (size <= Perl_sbrk_oldsize) {
+ got = Perl_sbrk_oldchunk;
+ Perl_sbrk_oldchunk += size;
+ Perl_sbrk_oldsize -= size;
+ } else {
+ if (size >= PERLSBRK_32_K) {
+ small = 0;
+ } else {
+ size = PERLSBRK_64_K;
+ small = 1;
+ }
+ got = (IV)SYSTEM_ALLOC(size);
+#ifdef PACK_MALLOC
+ got = (got + 0x7ff) & ~0x7ff;
+#endif
+ if (small) {
+ /* Chunk is small, register the rest for future allocs. */
+ Perl_sbrk_oldchunk = got + reqsize;
+ Perl_sbrk_oldsize = size - reqsize;
+ }
+ }
+
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
+ size, reqsize, Perl_sbrk_oldsize, got));
+
+ return (void *)got;
+}
+
+#endif /* ! defined USE_PERL_SBRK */
diff --git a/contrib/perl5/mg.c b/contrib/perl5/mg.c
new file mode 100644
index 000000000000..9dfbd4ffb19c
--- /dev/null
+++ b/contrib/perl5/mg.c
@@ -0,0 +1,1984 @@
+/* mg.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "Sam sat on the ground and put his head in his hands. 'I wish I had never
+ * come here, and I don't want to see no more magic,' he said, and fell silent."
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+# ifndef NGROUPS
+# define NGROUPS 32
+# endif
+#endif
+
+/*
+ * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
+ */
+
+#ifdef PERL_OBJECT
+
+#define VTBL this->*vtbl
+
+#else
+struct magic_state {
+ SV* mgs_sv;
+ U32 mgs_flags;
+};
+typedef struct magic_state MGS;
+
+static void restore_magic _((void *p));
+#define VTBL *vtbl
+
+#endif
+
+STATIC void
+save_magic(MGS *mgs, SV *sv)
+{
+ assert(SvMAGICAL(sv));
+
+ mgs->mgs_sv = sv;
+ mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
+ SAVEDESTRUCTOR(restore_magic, mgs);
+
+ SvMAGICAL_off(sv);
+ SvREADONLY_off(sv);
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+}
+
+STATIC void
+restore_magic(void *p)
+{
+ MGS* mgs = (MGS*)p;
+ SV* sv = mgs->mgs_sv;
+
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
+ {
+ if (mgs->mgs_flags)
+ SvFLAGS(sv) |= mgs->mgs_flags;
+ else
+ mg_magical(sv);
+ if (SvGMAGICAL(sv))
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
+ }
+}
+
+void
+mg_magical(SV *sv)
+{
+ MAGIC* mg;
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ if (vtbl) {
+ if ((vtbl->svt_get != NULL) && !(mg->mg_flags & MGf_GSKIP))
+ SvGMAGICAL_on(sv);
+ if (vtbl->svt_set)
+ SvSMAGICAL_on(sv);
+ if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || (vtbl->svt_clear != NULL))
+ SvRMAGICAL_on(sv);
+ }
+ }
+}
+
+int
+mg_get(SV *sv)
+{
+ MGS mgs;
+ MAGIC* mg;
+ MAGIC** mgp;
+ int mgp_valid = 0;
+
+ ENTER;
+ save_magic(&mgs, sv);
+
+ mgp = &SvMAGIC(sv);
+ while ((mg = *mgp) != 0) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ if (!(mg->mg_flags & MGf_GSKIP) && vtbl && (vtbl->svt_get != NULL)) {
+ (VTBL->svt_get)(sv, mg);
+ /* Ignore this magic if it's been deleted */
+ if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) &&
+ (mg->mg_flags & MGf_GSKIP))
+ mgs.mgs_flags = 0;
+ }
+ /* Advance to next magic (complicated by possible deletion) */
+ if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) {
+ mgp = &mg->mg_moremagic;
+ mgp_valid = 1;
+ }
+ else
+ mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
+ }
+
+ LEAVE;
+ return 0;
+}
+
+int
+mg_set(SV *sv)
+{
+ MGS mgs;
+ MAGIC* mg;
+ MAGIC* nextmg;
+
+ ENTER;
+ save_magic(&mgs, sv);
+
+ for (mg = SvMAGIC(sv); mg; mg = nextmg) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ nextmg = mg->mg_moremagic; /* it may delete itself */
+ if (mg->mg_flags & MGf_GSKIP) {
+ mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
+ mgs.mgs_flags = 0;
+ }
+ if (vtbl && (vtbl->svt_set != NULL))
+ (VTBL->svt_set)(sv, mg);
+ }
+
+ LEAVE;
+ return 0;
+}
+
+U32
+mg_length(SV *sv)
+{
+ MAGIC* mg;
+ char *junk;
+ STRLEN len;
+
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ if (vtbl && (vtbl->svt_len != NULL)) {
+ MGS mgs;
+
+ ENTER;
+ save_magic(&mgs, sv);
+ /* omit MGf_GSKIP -- not changed here */
+ len = (VTBL->svt_len)(sv, mg);
+ LEAVE;
+ return len;
+ }
+ }
+
+ junk = SvPV(sv, len);
+ return len;
+}
+
+I32
+mg_size(SV *sv)
+{
+ MAGIC* mg;
+ I32 len;
+
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ if (vtbl && (vtbl->svt_len != NULL)) {
+ MGS mgs;
+ ENTER;
+ /* omit MGf_GSKIP -- not changed here */
+ len = (VTBL->svt_len)(sv, mg);
+ LEAVE;
+ return len;
+ }
+ }
+
+ switch(SvTYPE(sv)) {
+ case SVt_PVAV:
+ len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
+ return len;
+ case SVt_PVHV:
+ /* FIXME */
+ default:
+ croak("Size magic not implemented");
+ break;
+ }
+ return 0;
+}
+
+int
+mg_clear(SV *sv)
+{
+ MGS mgs;
+ MAGIC* mg;
+
+ ENTER;
+ save_magic(&mgs, sv);
+
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ /* omit GSKIP -- never set here */
+
+ if (vtbl && (vtbl->svt_clear != NULL))
+ (VTBL->svt_clear)(sv, mg);
+ }
+
+ LEAVE;
+ return 0;
+}
+
+MAGIC*
+mg_find(SV *sv, int type)
+{
+ MAGIC* mg;
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ if (mg->mg_type == type)
+ return mg;
+ }
+ return 0;
+}
+
+int
+mg_copy(SV *sv, SV *nsv, char *key, I32 klen)
+{
+ int count = 0;
+ MAGIC* mg;
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ if (isUPPER(mg->mg_type)) {
+ sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen);
+ count++;
+ }
+ }
+ return count;
+}
+
+int
+mg_free(SV *sv)
+{
+ MAGIC* mg;
+ MAGIC* moremagic;
+ for (mg = SvMAGIC(sv); mg; mg = moremagic) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ moremagic = mg->mg_moremagic;
+ if (vtbl && (vtbl->svt_free != NULL))
+ (VTBL->svt_free)(sv, mg);
+ if (mg->mg_ptr && mg->mg_type != 'g')
+ if (mg->mg_len >= 0)
+ Safefree(mg->mg_ptr);
+ else if (mg->mg_len == HEf_SVKEY)
+ SvREFCNT_dec((SV*)mg->mg_ptr);
+ if (mg->mg_flags & MGf_REFCOUNTED)
+ SvREFCNT_dec(mg->mg_obj);
+ Safefree(mg);
+ }
+ SvMAGIC(sv) = 0;
+ return 0;
+}
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+#include <signal.h>
+#endif
+
+U32
+magic_len(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ register I32 paren;
+ register char *s;
+ register I32 i;
+ register REGEXP *rx;
+ char *t;
+
+ switch (*mg->mg_ptr) {
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': case '&':
+ if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
+ paren = atoi(mg->mg_ptr);
+ getparen:
+ if (paren <= rx->nparens &&
+ (s = rx->startp[paren]) &&
+ (t = rx->endp[paren]))
+ {
+ i = t - s;
+ if (i >= 0)
+ return i;
+ }
+ }
+ return 0;
+ case '+':
+ if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
+ paren = rx->lastparen;
+ if (paren)
+ goto getparen;
+ }
+ return 0;
+ case '`':
+ if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
+ if ((s = rx->subbeg) && rx->startp[0]) {
+ i = rx->startp[0] - s;
+ if (i >= 0)
+ return i;
+ }
+ }
+ return 0;
+ case '\'':
+ if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
+ if (rx->subend && (s = rx->endp[0])) {
+ i = rx->subend - s;
+ if (i >= 0)
+ return i;
+ }
+ }
+ return 0;
+ case ',':
+ return (STRLEN)PL_ofslen;
+ case '\\':
+ return (STRLEN)PL_orslen;
+ }
+ magic_get(sv,mg);
+ if (!SvPOK(sv) && SvNIOK(sv))
+ sv_2pv(sv, &PL_na);
+ if (SvPOK(sv))
+ return SvCUR(sv);
+ return 0;
+}
+
+int
+magic_get(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ register I32 paren;
+ register char *s;
+ register I32 i;
+ register REGEXP *rx;
+ char *t;
+
+ switch (*mg->mg_ptr) {
+ case '\001': /* ^A */
+ sv_setsv(sv, PL_bodytarget);
+ break;
+ case '\004': /* ^D */
+ sv_setiv(sv, (IV)(PL_debug & 32767));
+ break;
+ case '\005': /* ^E */
+#ifdef VMS
+ {
+# include <descrip.h>
+# include <starlet.h>
+ char msg[255];
+ $DESCRIPTOR(msgdsc,msg);
+ sv_setnv(sv,(double) vaxc$errno);
+ if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
+ sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
+ else
+ sv_setpv(sv,"");
+ }
+#else
+#ifdef OS2
+ if (!(_emx_env & 0x200)) { /* Under DOS */
+ sv_setnv(sv, (double)errno);
+ sv_setpv(sv, errno ? Strerror(errno) : "");
+ } else {
+ if (errno != errno_isOS2)
+ Perl_rc = _syserrno();
+ sv_setnv(sv, (double)Perl_rc);
+ sv_setpv(sv, os2error(Perl_rc));
+ }
+#else
+#ifdef WIN32
+ {
+ DWORD dwErr = GetLastError();
+ sv_setnv(sv, (double)dwErr);
+ if (dwErr)
+ {
+#ifdef PERL_OBJECT
+ char *sMsg;
+ DWORD dwLen;
+ PerlProc_GetSysMsg(sMsg, dwLen, dwErr);
+ sv_setpvn(sv, sMsg, dwLen);
+ PerlProc_FreeBuf(sMsg);
+#else
+ win32_str_os_error(sv, dwErr);
+#endif
+ }
+ else
+ sv_setpv(sv, "");
+ SetLastError(dwErr);
+ }
+#else
+ sv_setnv(sv, (double)errno);
+ sv_setpv(sv, errno ? Strerror(errno) : "");
+#endif
+#endif
+#endif
+ SvNOK_on(sv); /* what a wonderful hack! */
+ break;
+ case '\006': /* ^F */
+ sv_setiv(sv, (IV)PL_maxsysfd);
+ break;
+ case '\010': /* ^H */
+ sv_setiv(sv, (IV)PL_hints);
+ break;
+ case '\011': /* ^I */ /* NOT \t in EBCDIC */
+ if (PL_inplace)
+ sv_setpv(sv, PL_inplace);
+ else
+ sv_setsv(sv, &PL_sv_undef);
+ break;
+ case '\017': /* ^O */
+ sv_setpv(sv, PL_osname);
+ break;
+ case '\020': /* ^P */
+ sv_setiv(sv, (IV)PL_perldb);
+ break;
+ case '\023': /* ^S */
+ {
+ dTHR;
+ if (PL_lex_state != LEX_NOTPARSING)
+ SvOK_off(sv);
+ else if (PL_in_eval)
+ sv_setiv(sv, 1);
+ else
+ sv_setiv(sv, 0);
+ }
+ break;
+ case '\024': /* ^T */
+#ifdef BIG_TIME
+ sv_setnv(sv, PL_basetime);
+#else
+ sv_setiv(sv, (IV)PL_basetime);
+#endif
+ break;
+ case '\027': /* ^W */
+ sv_setiv(sv, (IV)PL_dowarn);
+ break;
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': case '&':
+ if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
+ /*
+ * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
+ * XXX Does the new way break anything?
+ */
+ paren = atoi(mg->mg_ptr);
+ getparen:
+ if (paren <= rx->nparens &&
+ (s = rx->startp[paren]) &&
+ (t = rx->endp[paren]))
+ {
+ i = t - s;
+ getrx:
+ if (i >= 0) {
+ bool was_tainted;
+ if (PL_tainting) {
+ was_tainted = PL_tainted;
+ PL_tainted = FALSE;
+ }
+ sv_setpvn(sv,s,i);
+ if (PL_tainting)
+ PL_tainted = (was_tainted || RX_MATCH_TAINTED(rx));
+ break;
+ }
+ }
+ }
+ sv_setsv(sv,&PL_sv_undef);
+ break;
+ case '+':
+ if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
+ paren = rx->lastparen;
+ if (paren)
+ goto getparen;
+ }
+ sv_setsv(sv,&PL_sv_undef);
+ break;
+ case '`':
+ if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
+ if ((s = rx->subbeg) && rx->startp[0]) {
+ i = rx->startp[0] - s;
+ goto getrx;
+ }
+ }
+ sv_setsv(sv,&PL_sv_undef);
+ break;
+ case '\'':
+ if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
+ if (rx->subend && (s = rx->endp[0])) {
+ i = rx->subend - s;
+ goto getrx;
+ }
+ }
+ sv_setsv(sv,&PL_sv_undef);
+ break;
+ case '.':
+#ifndef lint
+ if (GvIO(PL_last_in_gv)) {
+ sv_setiv(sv, (IV)IoLINES(GvIO(PL_last_in_gv)));
+ }
+#endif
+ break;
+ case '?':
+ {
+ sv_setiv(sv, (IV)STATUS_CURRENT);
+#ifdef COMPLEX_STATUS
+ LvTARGOFF(sv) = PL_statusvalue;
+ LvTARGLEN(sv) = PL_statusvalue_vms;
+#endif
+ }
+ break;
+ case '^':
+ s = IoTOP_NAME(GvIOp(PL_defoutgv));
+ if (s)
+ sv_setpv(sv,s);
+ else {
+ sv_setpv(sv,GvENAME(PL_defoutgv));
+ sv_catpv(sv,"_TOP");
+ }
+ break;
+ case '~':
+ s = IoFMT_NAME(GvIOp(PL_defoutgv));
+ if (!s)
+ s = GvENAME(PL_defoutgv);
+ sv_setpv(sv,s);
+ break;
+#ifndef lint
+ case '=':
+ sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
+ break;
+ case '-':
+ sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
+ break;
+ case '%':
+ sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
+ break;
+#endif
+ case ':':
+ break;
+ case '/':
+ break;
+ case '[':
+ WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
+ break;
+ case '|':
+ sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
+ break;
+ case ',':
+ sv_setpvn(sv,PL_ofs,PL_ofslen);
+ break;
+ case '\\':
+ sv_setpvn(sv,PL_ors,PL_orslen);
+ break;
+ case '#':
+ sv_setpv(sv,PL_ofmt);
+ break;
+ case '!':
+#ifdef VMS
+ sv_setnv(sv, (double)((errno == EVMSERR) ? vaxc$errno : errno));
+ sv_setpv(sv, errno ? Strerror(errno) : "");
+#else
+ {
+ int saveerrno = errno;
+ sv_setnv(sv, (double)errno);
+#ifdef OS2
+ if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
+ else
+#endif
+ sv_setpv(sv, errno ? Strerror(errno) : "");
+ errno = saveerrno;
+ }
+#endif
+ SvNOK_on(sv); /* what a wonderful hack! */
+ break;
+ case '<':
+ sv_setiv(sv, (IV)PL_uid);
+ break;
+ case '>':
+ sv_setiv(sv, (IV)PL_euid);
+ break;
+ case '(':
+ sv_setiv(sv, (IV)PL_gid);
+ sv_setpvf(sv, "%Vd", (IV)PL_gid);
+ goto add_groups;
+ case ')':
+ sv_setiv(sv, (IV)PL_egid);
+ sv_setpvf(sv, "%Vd", (IV)PL_egid);
+ add_groups:
+#ifdef HAS_GETGROUPS
+ {
+ Groups_t gary[NGROUPS];
+ i = getgroups(NGROUPS,gary);
+ while (--i >= 0)
+ sv_catpvf(sv, " %Vd", (IV)gary[i]);
+ }
+#endif
+ SvIOK_on(sv); /* what a wonderful hack! */
+ break;
+ case '*':
+ break;
+ case '0':
+ break;
+#ifdef USE_THREADS
+ case '@':
+ sv_setsv(sv, thr->errsv);
+ break;
+#endif /* USE_THREADS */
+ }
+ return 0;
+}
+
+int
+magic_getuvar(SV *sv, MAGIC *mg)
+{
+ struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
+
+ if (uf && uf->uf_val)
+ (*uf->uf_val)(uf->uf_index, sv);
+ return 0;
+}
+
+int
+magic_setenv(SV *sv, MAGIC *mg)
+{
+ register char *s;
+ char *ptr;
+ STRLEN len, klen;
+ I32 i;
+
+ s = SvPV(sv,len);
+ ptr = MgPV(mg,klen);
+ my_setenv(ptr, s);
+
+#ifdef DYNAMIC_ENV_FETCH
+ /* We just undefd an environment var. Is a replacement */
+ /* waiting in the wings? */
+ if (!len) {
+ SV **valp;
+ if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
+ s = SvPV(*valp, len);
+ }
+#endif
+
+#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
+ /* And you'll never guess what the dog had */
+ /* in its mouth... */
+ if (PL_tainting) {
+ MgTAINTEDDIR_off(mg);
+#ifdef VMS
+ if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
+ char pathbuf[256], eltbuf[256], *cp, *elt = s;
+ struct stat sbuf;
+ int i = 0, j = 0;
+
+ do { /* DCL$PATH may be a search list */
+ while (1) { /* as may dev portion of any element */
+ if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
+ if ( *(cp+1) == '.' || *(cp+1) == '-' ||
+ cando_by_name(S_IWUSR,0,elt) ) {
+ MgTAINTEDDIR_on(mg);
+ return 0;
+ }
+ }
+ if ((cp = strchr(elt, ':')) != Nullch)
+ *cp = '\0';
+ if (my_trnlnm(elt, eltbuf, j++))
+ elt = eltbuf;
+ else
+ break;
+ }
+ j = 0;
+ } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
+ }
+#endif /* VMS */
+ if (s && klen == 4 && strEQ(ptr,"PATH")) {
+ char *strend = s + len;
+
+ while (s < strend) {
+ char tmpbuf[256];
+ struct stat st;
+ s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
+ s, strend, ':', &i);
+ s++;
+ if (i >= sizeof tmpbuf /* too long -- assume the worst */
+ || *tmpbuf != '/'
+ || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
+ MgTAINTEDDIR_on(mg);
+ return 0;
+ }
+ }
+ }
+ }
+#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
+
+ return 0;
+}
+
+int
+magic_clearenv(SV *sv, MAGIC *mg)
+{
+ my_setenv(MgPV(mg,PL_na),Nullch);
+ return 0;
+}
+
+int
+magic_set_all_env(SV *sv, MAGIC *mg)
+{
+#if defined(VMS)
+ die("Can't make list assignment to %%ENV on this system");
+#else
+ dTHR;
+ if (PL_localizing) {
+ HE* entry;
+ 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));
+ }
+ }
+#endif
+ return 0;
+}
+
+int
+magic_clear_all_env(SV *sv, MAGIC *mg)
+{
+#if defined(VMS)
+ die("Can't make list assignment to %%ENV on this system");
+#else
+#ifdef WIN32
+ char *envv = GetEnvironmentStrings();
+ char *cur = envv;
+ STRLEN len;
+ while (*cur) {
+ char *end = strchr(cur,'=');
+ if (end && end != cur) {
+ *end = '\0';
+ my_setenv(cur,Nullch);
+ *end = '=';
+ cur += strlen(end+1)+1;
+ }
+ else if ((len = strlen(cur)))
+ cur += len+1;
+ }
+ FreeEnvironmentStrings(envv);
+#else
+ I32 i;
+
+ if (environ == PL_origenviron)
+ New(901, environ, 1, char*);
+ else
+ for (i = 0; environ[i]; i++)
+ Safefree(environ[i]);
+ environ[0] = Nullch;
+
+#endif
+#endif
+ return 0;
+}
+
+int
+magic_getsig(SV *sv, MAGIC *mg)
+{
+ I32 i;
+ /* Are we fetching a signal entry? */
+ i = whichsig(MgPV(mg,PL_na));
+ if (i) {
+ if(psig_ptr[i])
+ sv_setsv(sv,psig_ptr[i]);
+ else {
+ Sighandler_t sigstate = rsignal_state(i);
+
+ /* cache state so we don't fetch it again */
+ if(sigstate == SIG_IGN)
+ sv_setpv(sv,"IGNORE");
+ else
+ sv_setsv(sv,&PL_sv_undef);
+ psig_ptr[i] = SvREFCNT_inc(sv);
+ SvTEMP_off(sv);
+ }
+ }
+ return 0;
+}
+int
+magic_clearsig(SV *sv, MAGIC *mg)
+{
+ I32 i;
+ /* Are we clearing a signal entry? */
+ i = whichsig(MgPV(mg,PL_na));
+ if (i) {
+ if(psig_ptr[i]) {
+ SvREFCNT_dec(psig_ptr[i]);
+ psig_ptr[i]=0;
+ }
+ if(psig_name[i]) {
+ SvREFCNT_dec(psig_name[i]);
+ psig_name[i]=0;
+ }
+ }
+ return 0;
+}
+
+int
+magic_setsig(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ register char *s;
+ I32 i;
+ SV** svp;
+
+ s = MgPV(mg,PL_na);
+ if (*s == '_') {
+ if (strEQ(s,"__DIE__"))
+ svp = &PL_diehook;
+ else if (strEQ(s,"__WARN__"))
+ svp = &PL_warnhook;
+ else if (strEQ(s,"__PARSE__"))
+ svp = &PL_parsehook;
+ else
+ croak("No such hook: %s", s);
+ i = 0;
+ if (*svp) {
+ SvREFCNT_dec(*svp);
+ *svp = 0;
+ }
+ }
+ else {
+ i = whichsig(s); /* ...no, a brick */
+ if (!i) {
+ if (PL_dowarn || strEQ(s,"ALARM"))
+ warn("No such signal: SIG%s", s);
+ return 0;
+ }
+ SvREFCNT_dec(psig_name[i]);
+ SvREFCNT_dec(psig_ptr[i]);
+ psig_ptr[i] = SvREFCNT_inc(sv);
+ SvTEMP_off(sv); /* Make sure it doesn't go away on us */
+ psig_name[i] = newSVpv(s, strlen(s));
+ SvREADONLY_on(psig_name[i]);
+ }
+ if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
+ if (i)
+ (void)rsignal(i, PL_sighandlerp);
+ else
+ *svp = SvREFCNT_inc(sv);
+ return 0;
+ }
+ s = SvPV_force(sv,PL_na);
+ if (strEQ(s,"IGNORE")) {
+ if (i)
+ (void)rsignal(i, SIG_IGN);
+ else
+ *svp = 0;
+ }
+ else if (strEQ(s,"DEFAULT") || !*s) {
+ if (i)
+ (void)rsignal(i, SIG_DFL);
+ else
+ *svp = 0;
+ }
+ else {
+ /*
+ * We should warn if HINT_STRICT_REFS, but without
+ * access to a known hint bit in a known OP, we can't
+ * tell whether HINT_STRICT_REFS is in force or not.
+ */
+ if (!strchr(s,':') && !strchr(s,'\''))
+ sv_setpv(sv, form("main::%s", s));
+ if (i)
+ (void)rsignal(i, PL_sighandlerp);
+ else
+ *svp = SvREFCNT_inc(sv);
+ }
+ return 0;
+}
+
+int
+magic_setisa(SV *sv, MAGIC *mg)
+{
+ PL_sub_generation++;
+ return 0;
+}
+
+#ifdef OVERLOAD
+
+int
+magic_setamagic(SV *sv, MAGIC *mg)
+{
+ /* HV_badAMAGIC_on(Sv_STASH(sv)); */
+ PL_amagic_generation++;
+
+ return 0;
+}
+#endif /* OVERLOAD */
+
+int
+magic_getnkeys(SV *sv, MAGIC *mg)
+{
+ HV *hv = (HV*)LvTARG(sv);
+ HE *entry;
+ I32 i = 0;
+
+ if (hv) {
+ (void) hv_iterinit(hv);
+ if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
+ i = HvKEYS(hv);
+ else {
+ /*SUPPRESS 560*/
+ while (entry = hv_iternext(hv)) {
+ i++;
+ }
+ }
+ }
+
+ sv_setiv(sv, (IV)i);
+ return 0;
+}
+
+int
+magic_setnkeys(SV *sv, MAGIC *mg)
+{
+ if (LvTARG(sv)) {
+ hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
+ }
+ return 0;
+}
+
+/* caller is responsible for stack switching/cleanup */
+STATIC int
+magic_methcall(MAGIC *mg, char *meth, I32 flags, int n, SV *val)
+{
+ dSP;
+
+ PUSHMARK(SP);
+ EXTEND(SP, n);
+ PUSHs(mg->mg_obj);
+ if (n > 1) {
+ if (mg->mg_ptr) {
+ if (mg->mg_len >= 0)
+ PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
+ else if (mg->mg_len == HEf_SVKEY)
+ PUSHs((SV*)mg->mg_ptr);
+ }
+ else if (mg->mg_type == 'p') {
+ PUSHs(sv_2mortal(newSViv(mg->mg_len)));
+ }
+ }
+ if (n > 2) {
+ PUSHs(val);
+ }
+ PUTBACK;
+
+ return perl_call_method(meth, flags);
+}
+
+STATIC int
+magic_methpack(SV *sv, MAGIC *mg, char *meth)
+{
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+ PUSHSTACKi(PERLSI_MAGIC);
+
+ if (magic_methcall(mg, meth, G_SCALAR, 2, NULL)) {
+ sv_setsv(sv, *PL_stack_sp--);
+ }
+
+ POPSTACK;
+ FREETMPS;
+ LEAVE;
+ return 0;
+}
+
+int
+magic_getpack(SV *sv, MAGIC *mg)
+{
+ magic_methpack(sv,mg,"FETCH");
+ if (mg->mg_ptr)
+ mg->mg_flags |= MGf_GSKIP;
+ return 0;
+}
+
+int
+magic_setpack(SV *sv, MAGIC *mg)
+{
+ dSP;
+ ENTER;
+ PUSHSTACKi(PERLSI_MAGIC);
+ magic_methcall(mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
+ POPSTACK;
+ LEAVE;
+ return 0;
+}
+
+int
+magic_clearpack(SV *sv, MAGIC *mg)
+{
+ return magic_methpack(sv,mg,"DELETE");
+}
+
+
+U32
+magic_sizepack(SV *sv, MAGIC *mg)
+{
+ dSP;
+ U32 retval = 0;
+
+ ENTER;
+ SAVETMPS;
+ PUSHSTACKi(PERLSI_MAGIC);
+ if (magic_methcall(mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
+ sv = *PL_stack_sp--;
+ retval = (U32) SvIV(sv)-1;
+ }
+ POPSTACK;
+ FREETMPS;
+ LEAVE;
+ return retval;
+}
+
+int magic_wipepack(SV *sv, MAGIC *mg)
+{
+ dSP;
+
+ ENTER;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ XPUSHs(mg->mg_obj);
+ PUTBACK;
+ perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
+ POPSTACK;
+ LEAVE;
+ return 0;
+}
+
+int
+magic_nextpack(SV *sv, MAGIC *mg, SV *key)
+{
+ dSP;
+ char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
+
+ ENTER;
+ SAVETMPS;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP, 2);
+ PUSHs(mg->mg_obj);
+ if (SvOK(key))
+ PUSHs(key);
+ PUTBACK;
+
+ if (perl_call_method(meth, G_SCALAR))
+ sv_setsv(key, *PL_stack_sp--);
+
+ POPSTACK;
+ FREETMPS;
+ LEAVE;
+ return 0;
+}
+
+int
+magic_existspack(SV *sv, MAGIC *mg)
+{
+ return magic_methpack(sv,mg,"EXISTS");
+}
+
+int
+magic_setdbline(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ OP *o;
+ I32 i;
+ GV* gv;
+ SV** svp;
+
+ gv = PL_DBline;
+ i = SvTRUE(sv);
+ svp = av_fetch(GvAV(gv),
+ atoi(MgPV(mg,PL_na)), FALSE);
+ if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
+ o->op_private = i;
+ else
+ warn("Can't break at that line\n");
+ return 0;
+}
+
+int
+magic_getarylen(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
+ return 0;
+}
+
+int
+magic_setarylen(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
+ return 0;
+}
+
+int
+magic_getpos(SV *sv, MAGIC *mg)
+{
+ SV* lsv = LvTARG(sv);
+
+ if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
+ mg = mg_find(lsv, 'g');
+ if (mg && mg->mg_len >= 0) {
+ dTHR;
+ sv_setiv(sv, mg->mg_len + PL_curcop->cop_arybase);
+ return 0;
+ }
+ }
+ (void)SvOK_off(sv);
+ return 0;
+}
+
+int
+magic_setpos(SV *sv, MAGIC *mg)
+{
+ SV* lsv = LvTARG(sv);
+ SSize_t pos;
+ STRLEN len;
+
+ mg = 0;
+
+ if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
+ mg = mg_find(lsv, 'g');
+ if (!mg) {
+ if (!SvOK(sv))
+ return 0;
+ sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
+ mg = mg_find(lsv, 'g');
+ }
+ else if (!SvOK(sv)) {
+ mg->mg_len = -1;
+ return 0;
+ }
+ len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
+
+ WITH_THR(pos = SvIV(sv) - PL_curcop->cop_arybase);
+ if (pos < 0) {
+ pos += len;
+ if (pos < 0)
+ pos = 0;
+ }
+ else if (pos > len)
+ pos = len;
+ mg->mg_len = pos;
+ mg->mg_flags &= ~MGf_MINMATCH;
+
+ return 0;
+}
+
+int
+magic_getglob(SV *sv, MAGIC *mg)
+{
+ if (SvFAKE(sv)) { /* FAKE globs can get coerced */
+ SvFAKE_off(sv);
+ gv_efullname3(sv,((GV*)sv), "*");
+ SvFAKE_on(sv);
+ }
+ else
+ gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
+ return 0;
+}
+
+int
+magic_setglob(SV *sv, MAGIC *mg)
+{
+ register char *s;
+ GV* gv;
+
+ if (!SvOK(sv))
+ return 0;
+ s = SvPV(sv, PL_na);
+ if (*s == '*' && s[1])
+ s++;
+ gv = gv_fetchpv(s,TRUE, SVt_PVGV);
+ if (sv == (SV*)gv)
+ return 0;
+ if (GvGP(sv))
+ gp_free((GV*)sv);
+ GvGP(sv) = gp_ref(GvGP(gv));
+ return 0;
+}
+
+int
+magic_getsubstr(SV *sv, MAGIC *mg)
+{
+ STRLEN len;
+ SV *lsv = LvTARG(sv);
+ char *tmps = SvPV(lsv,len);
+ I32 offs = LvTARGOFF(sv);
+ I32 rem = LvTARGLEN(sv);
+
+ if (offs > len)
+ offs = len;
+ if (rem + offs > len)
+ rem = len - offs;
+ sv_setpvn(sv, tmps + offs, (STRLEN)rem);
+ return 0;
+}
+
+int
+magic_setsubstr(SV *sv, MAGIC *mg)
+{
+ STRLEN len;
+ char *tmps = SvPV(sv,len);
+ sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+ return 0;
+}
+
+int
+magic_gettaint(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ TAINT_IF((mg->mg_len & 1) ||
+ (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */
+ return 0;
+}
+
+int
+magic_settaint(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ if (PL_localizing) {
+ if (PL_localizing == 1)
+ mg->mg_len <<= 1;
+ else
+ mg->mg_len >>= 1;
+ }
+ else if (PL_tainted)
+ mg->mg_len |= 1;
+ else
+ mg->mg_len &= ~1;
+ return 0;
+}
+
+int
+magic_getvec(SV *sv, MAGIC *mg)
+{
+ SV *lsv = LvTARG(sv);
+ unsigned char *s;
+ unsigned long retnum;
+ STRLEN lsvlen;
+ I32 len;
+ I32 offset;
+ I32 size;
+
+ if (!lsv) {
+ SvOK_off(sv);
+ return 0;
+ }
+ s = (unsigned char *) SvPV(lsv, lsvlen);
+ offset = LvTARGOFF(sv);
+ size = LvTARGLEN(sv);
+ len = (offset + size + 7) / 8;
+
+ /* Copied from pp_vec() */
+
+ if (len > lsvlen) {
+ if (size <= 8)
+ retnum = 0;
+ else {
+ offset >>= 3;
+ if (size == 16) {
+ if (offset >= lsvlen)
+ retnum = 0;
+ else
+ retnum = (unsigned long) s[offset] << 8;
+ }
+ else if (size == 32) {
+ if (offset >= lsvlen)
+ retnum = 0;
+ else if (offset + 1 >= lsvlen)
+ retnum = (unsigned long) s[offset] << 24;
+ else if (offset + 2 >= lsvlen)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16);
+ else
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8);
+ }
+ }
+ }
+ else if (size < 8)
+ retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
+ else {
+ offset >>= 3;
+ if (size == 8)
+ retnum = s[offset];
+ else if (size == 16)
+ retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
+ else if (size == 32)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8) + s[offset+3];
+ }
+
+ sv_setuv(sv, (UV)retnum);
+ return 0;
+}
+
+int
+magic_setvec(SV *sv, MAGIC *mg)
+{
+ do_vecset(sv); /* XXX slurp this routine */
+ return 0;
+}
+
+int
+magic_getdefelem(SV *sv, MAGIC *mg)
+{
+ SV *targ = Nullsv;
+ if (LvTARGLEN(sv)) {
+ if (mg->mg_obj) {
+ SV *ahv = LvTARG(sv);
+ if (SvTYPE(ahv) == SVt_PVHV) {
+ HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
+ if (he)
+ targ = HeVAL(he);
+ }
+ else {
+ SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
+ if (svp)
+ targ = *svp;
+ }
+ }
+ else {
+ AV* av = (AV*)LvTARG(sv);
+ if ((I32)LvTARGOFF(sv) <= AvFILL(av))
+ targ = AvARRAY(av)[LvTARGOFF(sv)];
+ }
+ if (targ && targ != &PL_sv_undef) {
+ dTHR; /* just for SvREFCNT_dec */
+ /* somebody else defined it for us */
+ SvREFCNT_dec(LvTARG(sv));
+ LvTARG(sv) = SvREFCNT_inc(targ);
+ LvTARGLEN(sv) = 0;
+ SvREFCNT_dec(mg->mg_obj);
+ mg->mg_obj = Nullsv;
+ mg->mg_flags &= ~MGf_REFCOUNTED;
+ }
+ }
+ else
+ targ = LvTARG(sv);
+ sv_setsv(sv, targ ? targ : &PL_sv_undef);
+ return 0;
+}
+
+int
+magic_setdefelem(SV *sv, MAGIC *mg)
+{
+ if (LvTARGLEN(sv))
+ vivify_defelem(sv);
+ if (LvTARG(sv)) {
+ sv_setsv(LvTARG(sv), sv);
+ SvSETMAGIC(LvTARG(sv));
+ }
+ return 0;
+}
+
+void
+vivify_defelem(SV *sv)
+{
+ dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/
+ MAGIC *mg;
+ SV *value = Nullsv;
+
+ if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
+ return;
+ if (mg->mg_obj) {
+ SV *ahv = LvTARG(sv);
+ if (SvTYPE(ahv) == SVt_PVHV) {
+ HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
+ if (he)
+ value = HeVAL(he);
+ }
+ else {
+ SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
+ if (svp)
+ value = *svp;
+ }
+ if (!value || value == &PL_sv_undef)
+ croak(no_helem, SvPV(mg->mg_obj, PL_na));
+ }
+ else {
+ AV* av = (AV*)LvTARG(sv);
+ if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
+ LvTARG(sv) = Nullsv; /* array can't be extended */
+ else {
+ SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
+ if (!svp || (value = *svp) == &PL_sv_undef)
+ croak(no_aelem, (I32)LvTARGOFF(sv));
+ }
+ }
+ (void)SvREFCNT_inc(value);
+ SvREFCNT_dec(LvTARG(sv));
+ LvTARG(sv) = value;
+ LvTARGLEN(sv) = 0;
+ SvREFCNT_dec(mg->mg_obj);
+ mg->mg_obj = Nullsv;
+ mg->mg_flags &= ~MGf_REFCOUNTED;
+}
+
+int
+magic_setmglob(SV *sv, MAGIC *mg)
+{
+ mg->mg_len = -1;
+ SvSCREAM_off(sv);
+ return 0;
+}
+
+int
+magic_setbm(SV *sv, MAGIC *mg)
+{
+ sv_unmagic(sv, 'B');
+ SvVALID_off(sv);
+ return 0;
+}
+
+int
+magic_setfm(SV *sv, MAGIC *mg)
+{
+ sv_unmagic(sv, 'f');
+ SvCOMPILED_off(sv);
+ return 0;
+}
+
+int
+magic_setuvar(SV *sv, MAGIC *mg)
+{
+ struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
+
+ if (uf && uf->uf_set)
+ (*uf->uf_set)(uf->uf_index, sv);
+ return 0;
+}
+
+int
+magic_freeregexp(SV *sv, MAGIC *mg)
+{
+ regexp *re = (regexp *)mg->mg_obj;
+ ReREFCNT_dec(re);
+ return 0;
+}
+
+#ifdef USE_LOCALE_COLLATE
+int
+magic_setcollxfrm(SV *sv, MAGIC *mg)
+{
+ /*
+ * René Descartes said "I think not."
+ * and vanished with a faint plop.
+ */
+ if (mg->mg_ptr) {
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ mg->mg_len = -1;
+ }
+ return 0;
+}
+#endif /* USE_LOCALE_COLLATE */
+
+int
+magic_set(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ register char *s;
+ I32 i;
+ STRLEN len;
+ switch (*mg->mg_ptr) {
+ case '\001': /* ^A */
+ sv_setsv(PL_bodytarget, sv);
+ break;
+ case '\004': /* ^D */
+ PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
+ DEBUG_x(dump_all());
+ break;
+ case '\005': /* ^E */
+#ifdef VMS
+ set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+#else
+#ifdef WIN32
+ SetLastError( SvIV(sv) );
+#else
+ /* will anyone ever use this? */
+ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
+#endif
+#endif
+ break;
+ case '\006': /* ^F */
+ PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ break;
+ case '\010': /* ^H */
+ PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ break;
+ case '\011': /* ^I */ /* NOT \t in EBCDIC */
+ if (PL_inplace)
+ Safefree(PL_inplace);
+ if (SvOK(sv))
+ PL_inplace = savepv(SvPV(sv,PL_na));
+ else
+ PL_inplace = Nullch;
+ break;
+ case '\017': /* ^O */
+ if (PL_osname)
+ Safefree(PL_osname);
+ if (SvOK(sv))
+ PL_osname = savepv(SvPV(sv,PL_na));
+ else
+ PL_osname = Nullch;
+ break;
+ case '\020': /* ^P */
+ PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ break;
+ case '\024': /* ^T */
+#ifdef BIG_TIME
+ PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
+#else
+ PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+#endif
+ break;
+ case '\027': /* ^W */
+ PL_dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ break;
+ case '.':
+ if (PL_localizing) {
+ if (PL_localizing == 1)
+ save_sptr((SV**)&PL_last_in_gv);
+ }
+ else if (SvOK(sv) && GvIO(PL_last_in_gv))
+ IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
+ break;
+ case '^':
+ Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
+ IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,PL_na));
+ 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_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
+ break;
+ case '=':
+ IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ break;
+ case '-':
+ IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
+ IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
+ break;
+ case '%':
+ IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ break;
+ case '|':
+ {
+ IO *io = GvIOp(PL_defoutgv);
+ if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
+ IoFLAGS(io) &= ~IOf_FLUSH;
+ else {
+ if (!(IoFLAGS(io) & IOf_FLUSH)) {
+ PerlIO *ofp = IoOFP(io);
+ if (ofp)
+ (void)PerlIO_flush(ofp);
+ IoFLAGS(io) |= IOf_FLUSH;
+ }
+ }
+ }
+ break;
+ case '*':
+ i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ PL_multiline = (i != 0);
+ break;
+ case '/':
+ SvREFCNT_dec(PL_nrs);
+ PL_nrs = newSVsv(sv);
+ SvREFCNT_dec(PL_rs);
+ PL_rs = SvREFCNT_inc(PL_nrs);
+ break;
+ case '\\':
+ if (PL_ors)
+ Safefree(PL_ors);
+ if (SvOK(sv) || SvGMAGICAL(sv))
+ PL_ors = savepv(SvPV(sv,PL_orslen));
+ else {
+ PL_ors = Nullch;
+ PL_orslen = 0;
+ }
+ break;
+ case ',':
+ if (PL_ofs)
+ Safefree(PL_ofs);
+ PL_ofs = savepv(SvPV(sv, PL_ofslen));
+ break;
+ case '#':
+ if (PL_ofmt)
+ Safefree(PL_ofmt);
+ PL_ofmt = savepv(SvPV(sv,PL_na));
+ break;
+ case '[':
+ PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ break;
+ case '?':
+#ifdef COMPLEX_STATUS
+ if (PL_localizing == 2) {
+ PL_statusvalue = LvTARGOFF(sv);
+ PL_statusvalue_vms = LvTARGLEN(sv);
+ }
+ else
+#endif
+#ifdef VMSISH_STATUS
+ if (VMSISH_STATUS)
+ STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
+ else
+#endif
+ STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ break;
+ case '!':
+ SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
+ (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
+ break;
+ case '<':
+ PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ if (PL_delaymagic) {
+ PL_delaymagic |= DM_RUID;
+ break; /* don't do magic till later */
+ }
+#ifdef HAS_SETRUID
+ (void)setruid((Uid_t)PL_uid);
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
+#else
+#ifdef HAS_SETRESUID
+ (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
+#else
+ if (PL_uid == PL_euid) /* special case $< = $> */
+ (void)PerlProc_setuid(PL_uid);
+ else {
+ PL_uid = (I32)PerlProc_getuid();
+ croak("setruid() not implemented");
+ }
+#endif
+#endif
+#endif
+ PL_uid = (I32)PerlProc_getuid();
+ PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
+ break;
+ case '>':
+ PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ if (PL_delaymagic) {
+ PL_delaymagic |= DM_EUID;
+ break; /* don't do magic till later */
+ }
+#ifdef HAS_SETEUID
+ (void)seteuid((Uid_t)PL_euid);
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
+#else
+#ifdef HAS_SETRESUID
+ (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
+#else
+ if (PL_euid == PL_uid) /* special case $> = $< */
+ PerlProc_setuid(PL_euid);
+ else {
+ PL_euid = (I32)PerlProc_geteuid();
+ croak("seteuid() not implemented");
+ }
+#endif
+#endif
+#endif
+ PL_euid = (I32)PerlProc_geteuid();
+ PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
+ break;
+ case '(':
+ PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ if (PL_delaymagic) {
+ PL_delaymagic |= DM_RGID;
+ break; /* don't do magic till later */
+ }
+#ifdef HAS_SETRGID
+ (void)setrgid((Gid_t)PL_gid);
+#else
+#ifdef HAS_SETREGID
+ (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
+#else
+#ifdef HAS_SETRESGID
+ (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
+#else
+ if (PL_gid == PL_egid) /* special case $( = $) */
+ (void)PerlProc_setgid(PL_gid);
+ else {
+ PL_gid = (I32)PerlProc_getgid();
+ croak("setrgid() not implemented");
+ }
+#endif
+#endif
+#endif
+ PL_gid = (I32)PerlProc_getgid();
+ PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
+ break;
+ case ')':
+#ifdef HAS_SETGROUPS
+ {
+ char *p = SvPV(sv, PL_na);
+ Groups_t gary[NGROUPS];
+
+ SET_NUMERIC_STANDARD();
+ while (isSPACE(*p))
+ ++p;
+ PL_egid = I_V(atof(p));
+ for (i = 0; i < NGROUPS; ++i) {
+ while (*p && !isSPACE(*p))
+ ++p;
+ while (isSPACE(*p))
+ ++p;
+ if (!*p)
+ break;
+ gary[i] = I_V(atof(p));
+ }
+ if (i)
+ (void)setgroups(i, gary);
+ }
+#else /* HAS_SETGROUPS */
+ PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+#endif /* HAS_SETGROUPS */
+ if (PL_delaymagic) {
+ PL_delaymagic |= DM_EGID;
+ break; /* don't do magic till later */
+ }
+#ifdef HAS_SETEGID
+ (void)setegid((Gid_t)PL_egid);
+#else
+#ifdef HAS_SETREGID
+ (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
+#else
+#ifdef HAS_SETRESGID
+ (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
+#else
+ if (PL_egid == PL_gid) /* special case $) = $( */
+ (void)PerlProc_setgid(PL_egid);
+ else {
+ PL_egid = (I32)PerlProc_getegid();
+ croak("setegid() not implemented");
+ }
+#endif
+#endif
+#endif
+ PL_egid = (I32)PerlProc_getegid();
+ PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
+ break;
+ case ':':
+ PL_chopset = SvPV_force(sv,PL_na);
+ break;
+ case '0':
+ if (!PL_origalen) {
+ s = PL_origargv[0];
+ s += strlen(s);
+ /* See if all the arguments are contiguous in memory */
+ for (i = 1; i < PL_origargc; i++) {
+ if (PL_origargv[i] == s + 1
+#ifdef OS2
+ || PL_origargv[i] == s + 2
+#endif
+ )
+ s += strlen(++s); /* this one is ok too */
+ else
+ break;
+ }
+ /* can grab env area too? */
+ if (PL_origenviron && (PL_origenviron[0] == s + 1
+#ifdef OS2
+ || (PL_origenviron[0] == s + 9 && (s += 8))
+#endif
+ )) {
+ my_setenv("NoNe SuCh", Nullch);
+ /* force copy of environment */
+ for (i = 0; PL_origenviron[i]; i++)
+ if (PL_origenviron[i] == s + 1)
+ s += strlen(++s);
+ else
+ break;
+ }
+ PL_origalen = s - PL_origargv[0];
+ }
+ s = SvPV_force(sv,len);
+ i = len;
+ if (i >= PL_origalen) {
+ i = PL_origalen;
+ /* don't allow system to limit $0 seen by script */
+ /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
+ Copy(s, PL_origargv[0], i, char);
+ s = PL_origargv[0]+i;
+ *s = '\0';
+ }
+ else {
+ Copy(s, PL_origargv[0], i, char);
+ s = PL_origargv[0]+i;
+ *s++ = '\0';
+ while (++i < PL_origalen)
+ *s++ = ' ';
+ s = PL_origargv[0]+i;
+ for (i = 1; i < PL_origargc; i++)
+ PL_origargv[i] = Nullch;
+ }
+ break;
+#ifdef USE_THREADS
+ case '@':
+ sv_setsv(thr->errsv, sv);
+ break;
+#endif /* USE_THREADS */
+ }
+ return 0;
+}
+
+#ifdef USE_THREADS
+int
+magic_mutexfree(SV *sv, MAGIC *mg)
+{
+ dTHR;
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n",
+ (unsigned long)thr, (unsigned long)sv);)
+ if (MgOWNER(mg))
+ croak("panic: magic_mutexfree");
+ MUTEX_DESTROY(MgMUTEXP(mg));
+ COND_DESTROY(MgCONDP(mg));
+ SvREFCNT_dec(sv);
+ return 0;
+}
+#endif /* USE_THREADS */
+
+I32
+whichsig(char *sig)
+{
+ register char **sigv;
+
+ for (sigv = sig_name+1; *sigv; sigv++)
+ if (strEQ(sig,*sigv))
+ return sig_num[sigv - sig_name];
+#ifdef SIGCLD
+ if (strEQ(sig,"CHLD"))
+ return SIGCLD;
+#endif
+#ifdef SIGCHLD
+ if (strEQ(sig,"CLD"))
+ return SIGCHLD;
+#endif
+ return 0;
+}
+
+static SV* sig_sv;
+
+STATIC void
+unwind_handler_stack(void *p)
+{
+ dTHR;
+ U32 flags = *(U32*)p;
+
+ if (flags & 1)
+ PL_savestack_ix -= 5; /* Unprotect save in progress. */
+ /* cxstack_ix-- Not needed, die already unwound it. */
+ if (flags & 64)
+ SvREFCNT_dec(sig_sv);
+}
+
+Signal_t
+sighandler(int sig)
+{
+ dSP;
+ GV *gv = Nullgv;
+ HV *st;
+ SV *sv, *tSv = PL_Sv;
+ CV *cv = Nullcv;
+ OP *myop = PL_op;
+ U32 flags = 0;
+ I32 o_save_i = PL_savestack_ix, type;
+ XPV *tXpv = PL_Xpv;
+
+ if (PL_savestack_ix + 15 <= PL_savestack_max)
+ flags |= 1;
+ if (PL_markstack_ptr < PL_markstack_max - 2)
+ flags |= 4;
+ if (PL_retstack_ix < PL_retstack_max - 2)
+ flags |= 8;
+ if (PL_scopestack_ix < PL_scopestack_max - 3)
+ flags |= 16;
+
+ if (!psig_ptr[sig])
+ die("Signal SIG%s received, but no signal handler set.\n",
+ sig_name[sig]);
+
+ /* Max number of items pushed there is 3*n or 4. We cannot fix
+ infinity, so we fix 4 (in fact 5): */
+ if (flags & 1) {
+ PL_savestack_ix += 5; /* Protect save in progress. */
+ o_save_i = PL_savestack_ix;
+ SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags);
+ }
+ if (flags & 4)
+ PL_markstack_ptr++; /* Protect mark. */
+ if (flags & 8) {
+ PL_retstack_ix++;
+ PL_retstack[PL_retstack_ix] = NULL;
+ }
+ if (flags & 16)
+ PL_scopestack_ix += 1;
+ /* sv_2cv is too complicated, try a simpler variant first: */
+ if (!SvROK(psig_ptr[sig]) || !(cv = (CV*)SvRV(psig_ptr[sig]))
+ || SvTYPE(cv) != SVt_PVCV)
+ cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
+
+ if (!cv || !CvROOT(cv)) {
+ if (PL_dowarn)
+ warn("SIG%s handler \"%s\" not defined.\n",
+ sig_name[sig], (gv ? GvENAME(gv)
+ : ((cv && CvGV(cv))
+ ? GvENAME(CvGV(cv))
+ : "__ANON__")));
+ goto cleanup;
+ }
+
+ if(psig_name[sig]) {
+ sv = SvREFCNT_inc(psig_name[sig]);
+ flags |= 64;
+ sig_sv = sv;
+ } else {
+ sv = sv_newmortal();
+ sv_setpv(sv,sig_name[sig]);
+ }
+
+ PUSHSTACKi(PERLSI_SIGNAL);
+ PUSHMARK(SP);
+ PUSHs(sv);
+ PUTBACK;
+
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ POPSTACK;
+cleanup:
+ if (flags & 1)
+ PL_savestack_ix -= 8; /* Unprotect save in progress. */
+ if (flags & 4)
+ PL_markstack_ptr--;
+ if (flags & 8)
+ PL_retstack_ix--;
+ if (flags & 16)
+ PL_scopestack_ix -= 1;
+ if (flags & 64)
+ SvREFCNT_dec(sv);
+ PL_op = myop; /* Apparently not needed... */
+
+ PL_Sv = tSv; /* Restore global temporaries. */
+ PL_Xpv = tXpv;
+ return;
+}
+
+
diff --git a/contrib/perl5/mg.h b/contrib/perl5/mg.h
new file mode 100644
index 000000000000..16efdb5d7a29
--- /dev/null
+++ b/contrib/perl5/mg.h
@@ -0,0 +1,45 @@
+/* mg.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifdef STRUCT_MGVTBL_DEFINITION
+STRUCT_MGVTBL_DEFINITION;
+#else
+struct mgvtbl {
+ int (CPERLscope(*svt_get)) _((SV *sv, MAGIC* mg));
+ int (CPERLscope(*svt_set)) _((SV *sv, MAGIC* mg));
+ U32 (CPERLscope(*svt_len)) _((SV *sv, MAGIC* mg));
+ int (CPERLscope(*svt_clear)) _((SV *sv, MAGIC* mg));
+ int (CPERLscope(*svt_free)) _((SV *sv, MAGIC* mg));
+};
+#endif
+
+struct magic {
+ MAGIC* mg_moremagic;
+ MGVTBL* mg_virtual; /* pointer to magic functions */
+ U16 mg_private;
+ char mg_type;
+ U8 mg_flags;
+ SV* mg_obj;
+ char* mg_ptr;
+ I32 mg_len;
+};
+
+#define MGf_TAINTEDDIR 1
+#define MGf_REFCOUNTED 2
+#define MGf_GSKIP 4
+
+#define MGf_MINMATCH 1
+
+#define MgTAINTEDDIR(mg) (mg->mg_flags & MGf_TAINTEDDIR)
+#define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR)
+#define MgTAINTEDDIR_off(mg) (mg->mg_flags &= ~MGf_TAINTEDDIR)
+
+#define MgPV(mg,lp) (((lp = (mg)->mg_len) == HEf_SVKEY) ? \
+ SvPV((SV*)((mg)->mg_ptr),lp) : \
+ (mg)->mg_ptr)
diff --git a/contrib/perl5/minimod.pl b/contrib/perl5/minimod.pl
new file mode 100644
index 000000000000..82760ee63d0e
--- /dev/null
+++ b/contrib/perl5/minimod.pl
@@ -0,0 +1,139 @@
+# minimod.PL writes the contents of miniperlmain.c into the module
+# ExtUtils::Miniperl for later perusal (when the perl source is
+# deleted)
+#
+# It also writes the subroutine writemain(), which takes as its
+# arguments module names that shall be statically linked into perl.
+#
+# Authors: Andreas Koenig <k@franz.ww.TU-Berlin.DE>, Tim Bunce
+# <Tim.Bunce@ig.co.uk>
+#
+# Version 1.0, Feb 2nd 1995 by Andreas Koenig
+
+print <<'END';
+# This File keeps the contents of miniperlmain.c.
+#
+# It was generated automatically by minimod.PL from the contents
+# of miniperlmain.c. Don't edit this file!
+#
+# ANY CHANGES MADE HERE WILL BE LOST!
+#
+
+
+package ExtUtils::Miniperl;
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(&writemain);
+
+$head= <<'EOF!HEAD';
+END
+
+open MINI, "miniperlmain.c";
+while (<MINI>) {
+ last if /Do not delete this line--writemain depends on it/;
+ print;
+}
+
+print <<'END';
+EOF!HEAD
+$tail=<<'EOF!TAIL';
+END
+
+while (<MINI>) {
+ print unless /dXSUB_SYS/;
+}
+close MINI;
+
+print <<'END';
+EOF!TAIL
+
+sub writemain{
+ my(@exts) = @_;
+
+ my($pname);
+ my($dl) = canon('/','DynaLoader');
+ print $head;
+
+ foreach $_ (@exts){
+ my($pname) = canon('/', $_);
+ my($mname, $cname);
+ ($mname = $pname) =~ s!/!::!g;
+ ($cname = $pname) =~ s!/!__!g;
+ print "EXTERN_C void boot_${cname} _((CV* cv));\n";
+ }
+
+ my ($tail1,$tail2) = ( $tail =~ /\A(.*\n)(\s*\}.*)\Z/s );
+ print $tail1;
+
+ print "\tchar *file = __FILE__;\n";
+ print "\tdXSUB_SYS;\n" if $] > 5.002;
+
+ foreach $_ (@exts){
+ my($pname) = canon('/', $_);
+ my($mname, $cname, $ccode);
+ ($mname = $pname) =~ s!/!::!g;
+ ($cname = $pname) =~ s!/!__!g;
+ print "\t{\n";
+ if ($pname eq $dl){
+ # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
+ # boot_DynaLoader is called directly in DynaLoader.pm
+ $ccode = "\t/* DynaLoader is a special case */\n
+\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n";
+ print $ccode unless $SEEN{$ccode}++;
+ } else {
+ $ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n";
+ print $ccode unless $SEEN{$ccode}++;
+ }
+ print "\t}\n";
+ }
+ print $tail2;
+}
+
+sub canon{
+ my($as, @ext) = @_;
+ foreach(@ext){
+ # might be X::Y or lib/auto/X/Y/Y.a
+ next if s!::!/!g;
+ s:^(lib|ext)/(auto/)?::;
+ s:/\w+\.\w+$::;
+ }
+ grep(s:/:$as:, @ext) if ($as ne '/');
+ @ext;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+ExtUtils::Miniperl, writemain - write the C code for perlmain.c
+
+=head1 SYNOPSIS
+
+C<use ExtUtils::Miniperl;>
+
+C<writemain(@directories);>
+
+=head1 DESCRIPTION
+
+This whole module is written when perl itself is built from a script
+called minimod.PL. In case you want to patch it, please patch
+minimod.PL in the perl distribution instead.
+
+writemain() takes an argument list of directories containing archive
+libraries that relate to perl modules and should be linked into a new
+perl binary. It writes to STDOUT a corresponding perlmain.c file that
+is a plain C file containing all the bootstrap code to make the
+modules associated with the libraries available from within perl.
+
+The typical usage is from within a Makefile generated by
+ExtUtils::MakeMaker. So under normal circumstances you won't have to
+deal with this module directly.
+
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker>
+
+=cut
+
+END
diff --git a/contrib/perl5/miniperlmain.c b/contrib/perl5/miniperlmain.c
new file mode 100644
index 000000000000..4eb1dcdd6fdf
--- /dev/null
+++ b/contrib/perl5/miniperlmain.c
@@ -0,0 +1,65 @@
+/*
+ * "The Road goes ever on and on, down from the door where it began."
+ */
+
+#ifdef OEMVS
+#pragma runopts(HEAP(1M,32K,ANYWHERE,KEEP,8K,4K))
+#endif
+
+
+#include "EXTERN.h"
+#include "perl.h"
+
+static void xs_init _((void));
+static PerlInterpreter *my_perl;
+
+int
+main(int argc, char **argv, char **env)
+{
+ int exitstatus;
+
+#ifdef PERL_GLOBAL_STRUCT
+#define PERLVAR(var,type) /**/
+#define PERLVARI(var,type,init) PL_Vars.var = init;
+#define PERLVARIC(var,type,init) PL_Vars.var = init;
+#include "perlvars.h"
+#undef PERLVAR
+#undef PERLVARI
+#undef PERLVARIC
+#endif
+
+ PERL_SYS_INIT(&argc,&argv);
+
+ 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) {
+ exitstatus = perl_run( my_perl );
+ }
+
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+
+ PERL_SYS_TERM();
+
+ exit( exitstatus );
+ return exitstatus;
+}
+
+/* Register any extra external extensions */
+
+/* Do not delete this line--writemain depends on it */
+
+static void
+xs_init(void)
+{
+ dXSUB_SYS;
+}
diff --git a/contrib/perl5/mv-if-diff b/contrib/perl5/mv-if-diff
new file mode 100644
index 000000000000..4a85b9839227
--- /dev/null
+++ b/contrib/perl5/mv-if-diff
@@ -0,0 +1,15 @@
+: mv-if-diff file1 file2
+: move file1 to file2 if file1 and file2 are different.
+
+if test $# -lt 2 ; then
+ echo "usage: $0 file1 file2"
+ echo "move file1 to file2 if file1 and file2 are different."
+ exit 1
+fi
+if cmp $1 $2 >/dev/null 2>&1; then
+ echo "File $2 not changed."
+ rm -f $1
+else
+ rm -f $2
+ mv $1 $2
+fi
diff --git a/contrib/perl5/myconfig b/contrib/perl5/myconfig
new file mode 100755
index 000000000000..c143aea6e8d5
--- /dev/null
+++ b/contrib/perl5/myconfig
@@ -0,0 +1,43 @@
+#!/bin/sh
+
+# This script is designed to provide a handy summary of the configuration
+# information being used to build perl. This is especially useful if you
+# are requesting help from comp.lang.perl.misc on usenet or via mail.
+
+if test -f config.sh; then TOP=.;
+elif test -f ../config.sh; then TOP=..;
+elif test -f ../../config.sh; then TOP=../..;
+elif test -f ../../../config.sh; then TOP=../../..;
+elif test -f ../../../../config.sh; then TOP=../../../..;
+else
+ echo "Can't find the perl config.sh file produced by Configure"; exit 1
+fi
+. $TOP/config.sh
+
+# Note that the text lines /^Summary of/ .. /^\s*$/ are copied into Config.pm.
+
+$spitshell <<!GROK!THIS!
+Summary of my $package ($baserev patchlevel $PATCHLEVEL subversion $SUBVERSION) configuration:
+ Platform:
+ osname=$osname, osvers=$osvers, archname=$archname
+ uname='$myuname'
+ hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction
+ usethreads=$usethreads useperlio=$useperlio d_sfio=$d_sfio
+ Compiler:
+ cc='$cc', optimize='$optimize', gccversion=$gccversion
+ cppflags='$cppflags'
+ ccflags ='$ccflags'
+ stdchar='$stdchar', d_stdstdio=$d_stdstdio, usevfork=$usevfork
+ intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize
+ d_longlong=$d_longlong, longlongsize=$longlongsize, d_longdbl=$d_longdbl, longdblsize=$longdblsize
+ alignbytes=$alignbytes, usemymalloc=$usemymalloc, prototype=$prototype
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+ libs=$libs
+ libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+ cccdlflags='$cccdlflags', lddlflags='$lddlflags'
+
+!GROK!THIS!
diff --git a/contrib/perl5/nostdio.h b/contrib/perl5/nostdio.h
new file mode 100644
index 000000000000..256a638c9a7c
--- /dev/null
+++ b/contrib/perl5/nostdio.h
@@ -0,0 +1,26 @@
+/* This is an 1st attempt to stop other include files pulling
+ in real <stdio.h>.
+ A more ambitious set of possible symbols can be found in
+ sfio.h (inside an _cplusplus gard).
+*/
+#if !defined(_STDIO_H) && !defined(FILE) && !defined(_STDIO_INCLUDED) && !defined(__STDIO_LOADED)
+#define _STDIO_H
+#define _STDIO_INCLUDED
+#define __STDIO_LOADED
+struct _FILE;
+#define FILE struct _FILE
+#endif
+
+#define _CANNOT "CANNOT"
+
+#undef stdin
+#undef stdout
+#undef stderr
+#undef getc
+#undef putc
+#undef clearerr
+#undef fflush
+#undef feof
+#undef ferror
+#undef fileno
+
diff --git a/contrib/perl5/objXSUB.h b/contrib/perl5/objXSUB.h
new file mode 100644
index 000000000000..d548d205e787
--- /dev/null
+++ b/contrib/perl5/objXSUB.h
@@ -0,0 +1,2055 @@
+#ifndef __objXSUB_h__
+#define __objXSUB_h__
+
+/* Varibles */
+
+#undef PL_Sv
+#define PL_Sv pPerl->PL_Sv
+#undef PL_Xpv
+#define PL_Xpv pPerl->PL_Xpv
+#undef PL_av_fetch_sv
+#define PL_av_fetch_sv pPerl->PL_av_fetch_sv
+#undef PL_bodytarget
+#define PL_bodytarget pPerl->PL_bodytarget
+#undef PL_bostr
+#define PL_bostr pPerl->PL_bostr
+#undef PL_chopset
+#define PL_chopset pPerl->PL_chopset
+#undef PL_colors
+#define PL_colors pPerl->PL_colors
+#undef PL_colorset
+#define PL_colorset pPerl->PL_colorset
+#undef PL_curcop
+#define PL_curcop pPerl->PL_curcop
+#undef PL_curpad
+#define PL_curpad pPerl->PL_curpad
+#undef PL_curpm
+#define PL_curpm pPerl->PL_curpm
+#undef PL_curstack
+#define PL_curstack pPerl->PL_curstack
+#undef PL_curstackinfo
+#define PL_curstackinfo pPerl->PL_curstackinfo
+#undef PL_curstash
+#define PL_curstash pPerl->PL_curstash
+#undef PL_defoutgv
+#define PL_defoutgv pPerl->PL_defoutgv
+#undef PL_defstash
+#define PL_defstash pPerl->PL_defstash
+#undef PL_delaymagic
+#define PL_delaymagic pPerl->PL_delaymagic
+#undef PL_dirty
+#define PL_dirty pPerl->PL_dirty
+#undef PL_extralen
+#define PL_extralen pPerl->PL_extralen
+#undef PL_firstgv
+#define PL_firstgv pPerl->PL_firstgv
+#undef PL_formtarget
+#define PL_formtarget pPerl->PL_formtarget
+#undef PL_hv_fetch_ent_mh
+#define PL_hv_fetch_ent_mh pPerl->PL_hv_fetch_ent_mh
+#undef PL_hv_fetch_sv
+#define PL_hv_fetch_sv pPerl->PL_hv_fetch_sv
+#undef PL_in_eval
+#define PL_in_eval pPerl->PL_in_eval
+#undef PL_last_in_gv
+#define PL_last_in_gv pPerl->PL_last_in_gv
+#undef PL_lastgotoprobe
+#define PL_lastgotoprobe pPerl->PL_lastgotoprobe
+#undef PL_lastscream
+#define PL_lastscream pPerl->PL_lastscream
+#undef PL_localizing
+#define PL_localizing pPerl->PL_localizing
+#undef PL_mainstack
+#define PL_mainstack pPerl->PL_mainstack
+#undef PL_markstack
+#define PL_markstack pPerl->PL_markstack
+#undef PL_markstack_max
+#define PL_markstack_max pPerl->PL_markstack_max
+#undef PL_markstack_ptr
+#define PL_markstack_ptr pPerl->PL_markstack_ptr
+#undef PL_maxscream
+#define PL_maxscream pPerl->PL_maxscream
+#undef PL_modcount
+#define PL_modcount pPerl->PL_modcount
+#undef PL_nrs
+#define PL_nrs pPerl->PL_nrs
+#undef PL_ofs
+#define PL_ofs pPerl->PL_ofs
+#undef PL_ofslen
+#define PL_ofslen pPerl->PL_ofslen
+#undef PL_op
+#define PL_op pPerl->PL_op
+#undef PL_opsave
+#define PL_opsave pPerl->PL_opsave
+#undef PL_reg_eval_set
+#define PL_reg_eval_set pPerl->PL_reg_eval_set
+#undef PL_reg_flags
+#define PL_reg_flags pPerl->PL_reg_flags
+#undef PL_reg_start_tmp
+#define PL_reg_start_tmp pPerl->PL_reg_start_tmp
+#undef PL_reg_start_tmpl
+#define PL_reg_start_tmpl pPerl->PL_reg_start_tmpl
+#undef PL_regbol
+#define PL_regbol pPerl->PL_regbol
+#undef PL_regcc
+#define PL_regcc pPerl->PL_regcc
+#undef PL_regcode
+#define PL_regcode pPerl->PL_regcode
+#undef PL_regcomp_parse
+#define PL_regcomp_parse pPerl->PL_regcomp_parse
+#undef PL_regcomp_rx
+#define PL_regcomp_rx pPerl->PL_regcomp_rx
+#undef PL_regcompp
+#define PL_regcompp pPerl->PL_regcompp
+#undef PL_regdata
+#define PL_regdata pPerl->PL_regdata
+#undef PL_regdummy
+#define PL_regdummy pPerl->PL_regdummy
+#undef PL_regendp
+#define PL_regendp pPerl->PL_regendp
+#undef PL_regeol
+#define PL_regeol pPerl->PL_regeol
+#undef PL_regexecp
+#define PL_regexecp pPerl->PL_regexecp
+#undef PL_regflags
+#define PL_regflags pPerl->PL_regflags
+#undef PL_regindent
+#define PL_regindent pPerl->PL_regindent
+#undef PL_reginput
+#define PL_reginput pPerl->PL_reginput
+#undef PL_reginterp_cnt
+#define PL_reginterp_cnt pPerl->PL_reginterp_cnt
+#undef PL_reglastparen
+#define PL_reglastparen pPerl->PL_reglastparen
+#undef PL_regnarrate
+#define PL_regnarrate pPerl->PL_regnarrate
+#undef PL_regnaughty
+#define PL_regnaughty pPerl->PL_regnaughty
+#undef PL_regnpar
+#define PL_regnpar pPerl->PL_regnpar
+#undef PL_regprecomp
+#define PL_regprecomp pPerl->PL_regprecomp
+#undef PL_regprev
+#define PL_regprev pPerl->PL_regprev
+#undef PL_regprogram
+#define PL_regprogram pPerl->PL_regprogram
+#undef PL_regsawback
+#define PL_regsawback pPerl->PL_regsawback
+#undef PL_regseen
+#define PL_regseen pPerl->PL_regseen
+#undef PL_regsize
+#define PL_regsize pPerl->PL_regsize
+#undef PL_regstartp
+#define PL_regstartp pPerl->PL_regstartp
+#undef PL_regtill
+#define PL_regtill pPerl->PL_regtill
+#undef PL_regxend
+#define PL_regxend pPerl->PL_regxend
+#undef PL_restartop
+#define PL_restartop pPerl->PL_restartop
+#undef PL_retstack
+#define PL_retstack pPerl->PL_retstack
+#undef PL_retstack_ix
+#define PL_retstack_ix pPerl->PL_retstack_ix
+#undef PL_retstack_max
+#define PL_retstack_max pPerl->PL_retstack_max
+#undef PL_rs
+#define PL_rs pPerl->PL_rs
+#undef PL_savestack
+#define PL_savestack pPerl->PL_savestack
+#undef PL_savestack_ix
+#define PL_savestack_ix pPerl->PL_savestack_ix
+#undef PL_savestack_max
+#define PL_savestack_max pPerl->PL_savestack_max
+#undef PL_scopestack
+#define PL_scopestack pPerl->PL_scopestack
+#undef PL_scopestack_ix
+#define PL_scopestack_ix pPerl->PL_scopestack_ix
+#undef PL_scopestack_max
+#define PL_scopestack_max pPerl->PL_scopestack_max
+#undef PL_screamfirst
+#define PL_screamfirst pPerl->PL_screamfirst
+#undef PL_screamnext
+#define PL_screamnext pPerl->PL_screamnext
+#undef PL_secondgv
+#define PL_secondgv pPerl->PL_secondgv
+#undef PL_seen_evals
+#define PL_seen_evals pPerl->PL_seen_evals
+#undef PL_seen_zerolen
+#define PL_seen_zerolen pPerl->PL_seen_zerolen
+#undef PL_sortcop
+#define PL_sortcop pPerl->PL_sortcop
+#undef PL_sortcxix
+#define PL_sortcxix pPerl->PL_sortcxix
+#undef PL_sortstash
+#define PL_sortstash pPerl->PL_sortstash
+#undef PL_stack_base
+#define PL_stack_base pPerl->PL_stack_base
+#undef PL_stack_max
+#define PL_stack_max pPerl->PL_stack_max
+#undef PL_stack_sp
+#define PL_stack_sp pPerl->PL_stack_sp
+#undef PL_start_env
+#define PL_start_env pPerl->PL_start_env
+#undef PL_statbuf
+#define PL_statbuf pPerl->PL_statbuf
+#undef PL_statcache
+#define PL_statcache pPerl->PL_statcache
+#undef PL_statgv
+#define PL_statgv pPerl->PL_statgv
+#undef PL_statname
+#define PL_statname pPerl->PL_statname
+#undef PL_tainted
+#define PL_tainted pPerl->PL_tainted
+#undef PL_timesbuf
+#define PL_timesbuf pPerl->PL_timesbuf
+#undef PL_tmps_floor
+#define PL_tmps_floor pPerl->PL_tmps_floor
+#undef PL_tmps_ix
+#define PL_tmps_ix pPerl->PL_tmps_ix
+#undef PL_tmps_max
+#define PL_tmps_max pPerl->PL_tmps_max
+#undef PL_tmps_stack
+#define PL_tmps_stack pPerl->PL_tmps_stack
+#undef PL_top_env
+#define PL_top_env pPerl->PL_top_env
+#undef PL_toptarget
+#define PL_toptarget pPerl->PL_toptarget
+#undef PL_Argv
+#define PL_Argv pPerl->PL_Argv
+#undef PL_Cmd
+#define PL_Cmd pPerl->PL_Cmd
+#undef PL_DBcv
+#define PL_DBcv pPerl->PL_DBcv
+#undef PL_DBgv
+#define PL_DBgv pPerl->PL_DBgv
+#undef PL_DBline
+#define PL_DBline pPerl->PL_DBline
+#undef PL_DBsignal
+#define PL_DBsignal pPerl->PL_DBsignal
+#undef PL_DBsingle
+#define PL_DBsingle pPerl->PL_DBsingle
+#undef PL_DBsub
+#define PL_DBsub pPerl->PL_DBsub
+#undef PL_DBtrace
+#define PL_DBtrace pPerl->PL_DBtrace
+#undef PL_ampergv
+#define PL_ampergv pPerl->PL_ampergv
+#undef PL_archpat_auto
+#define PL_archpat_auto pPerl->PL_archpat_auto
+#undef PL_argvgv
+#define PL_argvgv pPerl->PL_argvgv
+#undef PL_argvoutgv
+#define PL_argvoutgv pPerl->PL_argvoutgv
+#undef PL_basetime
+#define PL_basetime pPerl->PL_basetime
+#undef PL_beginav
+#define PL_beginav pPerl->PL_beginav
+#undef PL_cddir
+#define PL_cddir pPerl->PL_cddir
+#undef PL_compcv
+#define PL_compcv pPerl->PL_compcv
+#undef PL_compiling
+#define PL_compiling pPerl->PL_compiling
+#undef PL_comppad
+#define PL_comppad pPerl->PL_comppad
+#undef PL_comppad_name
+#define PL_comppad_name pPerl->PL_comppad_name
+#undef PL_comppad_name_fill
+#define PL_comppad_name_fill pPerl->PL_comppad_name_fill
+#undef PL_comppad_name_floor
+#define PL_comppad_name_floor pPerl->PL_comppad_name_floor
+#undef PL_copline
+#define PL_copline pPerl->PL_copline
+#undef PL_curcopdb
+#define PL_curcopdb pPerl->PL_curcopdb
+#undef PL_curstname
+#define PL_curstname pPerl->PL_curstname
+#undef PL_dbargs
+#define PL_dbargs pPerl->PL_dbargs
+#undef PL_debdelim
+#define PL_debdelim pPerl->PL_debdelim
+#undef PL_debname
+#define PL_debname pPerl->PL_debname
+#undef PL_debstash
+#define PL_debstash pPerl->PL_debstash
+#undef PL_defgv
+#define PL_defgv pPerl->PL_defgv
+#undef PL_diehook
+#define PL_diehook pPerl->PL_diehook
+#undef PL_dlevel
+#define PL_dlevel pPerl->PL_dlevel
+#undef PL_dlmax
+#define PL_dlmax pPerl->PL_dlmax
+#undef PL_doextract
+#define PL_doextract pPerl->PL_doextract
+#undef PL_doswitches
+#define PL_doswitches pPerl->PL_doswitches
+#undef PL_dowarn
+#define PL_dowarn pPerl->PL_dowarn
+#undef PL_dumplvl
+#define PL_dumplvl pPerl->PL_dumplvl
+#undef PL_e_script
+#define PL_e_script pPerl->PL_e_script
+#undef PL_endav
+#define PL_endav pPerl->PL_endav
+#undef PL_envgv
+#define PL_envgv pPerl->PL_envgv
+#undef PL_errgv
+#define PL_errgv pPerl->PL_errgv
+#undef PL_eval_root
+#define PL_eval_root pPerl->PL_eval_root
+#undef PL_eval_start
+#define PL_eval_start pPerl->PL_eval_start
+#undef PL_exitlist
+#define PL_exitlist pPerl->PL_exitlist
+#undef PL_exitlistlen
+#define PL_exitlistlen pPerl->PL_exitlistlen
+#undef PL_fdpid
+#define PL_fdpid pPerl->PL_fdpid
+#undef PL_filemode
+#define PL_filemode pPerl->PL_filemode
+#undef PL_forkprocess
+#define PL_forkprocess pPerl->PL_forkprocess
+#undef PL_formfeed
+#define PL_formfeed pPerl->PL_formfeed
+#undef PL_generation
+#define PL_generation pPerl->PL_generation
+#undef PL_gensym
+#define PL_gensym pPerl->PL_gensym
+#undef PL_globalstash
+#define PL_globalstash pPerl->PL_globalstash
+#undef PL_hintgv
+#define PL_hintgv pPerl->PL_hintgv
+#undef PL_in_clean_all
+#define PL_in_clean_all pPerl->PL_in_clean_all
+#undef PL_in_clean_objs
+#define PL_in_clean_objs pPerl->PL_in_clean_objs
+#undef PL_incgv
+#define PL_incgv pPerl->PL_incgv
+#undef PL_initav
+#define PL_initav pPerl->PL_initav
+#undef PL_inplace
+#define PL_inplace pPerl->PL_inplace
+#undef PL_last_proto
+#define PL_last_proto pPerl->PL_last_proto
+#undef PL_lastfd
+#define PL_lastfd pPerl->PL_lastfd
+#undef PL_lastsize
+#define PL_lastsize pPerl->PL_lastsize
+#undef PL_lastspbase
+#define PL_lastspbase pPerl->PL_lastspbase
+#undef PL_laststatval
+#define PL_laststatval pPerl->PL_laststatval
+#undef PL_laststype
+#define PL_laststype pPerl->PL_laststype
+#undef PL_leftgv
+#define PL_leftgv pPerl->PL_leftgv
+#undef PL_lineary
+#define PL_lineary pPerl->PL_lineary
+#undef PL_linestart
+#define PL_linestart pPerl->PL_linestart
+#undef PL_localpatches
+#define PL_localpatches pPerl->PL_localpatches
+#undef PL_main_cv
+#define PL_main_cv pPerl->PL_main_cv
+#undef PL_main_root
+#define PL_main_root pPerl->PL_main_root
+#undef PL_main_start
+#define PL_main_start pPerl->PL_main_start
+#undef PL_maxsysfd
+#define PL_maxsysfd pPerl->PL_maxsysfd
+#undef PL_mess_sv
+#define PL_mess_sv pPerl->PL_mess_sv
+#undef PL_minus_F
+#define PL_minus_F pPerl->PL_minus_F
+#undef PL_minus_a
+#define PL_minus_a pPerl->PL_minus_a
+#undef PL_minus_c
+#define PL_minus_c pPerl->PL_minus_c
+#undef PL_minus_l
+#define PL_minus_l pPerl->PL_minus_l
+#undef PL_minus_n
+#define PL_minus_n pPerl->PL_minus_n
+#undef PL_minus_p
+#define PL_minus_p pPerl->PL_minus_p
+#undef PL_modglobal
+#define PL_modglobal pPerl->PL_modglobal
+#undef PL_multiline
+#define PL_multiline pPerl->PL_multiline
+#undef PL_mystrk
+#define PL_mystrk pPerl->PL_mystrk
+#undef PL_ofmt
+#define PL_ofmt pPerl->PL_ofmt
+#undef PL_oldlastpm
+#define PL_oldlastpm pPerl->PL_oldlastpm
+#undef PL_oldname
+#define PL_oldname pPerl->PL_oldname
+#undef PL_op_mask
+#define PL_op_mask pPerl->PL_op_mask
+#undef PL_origargc
+#define PL_origargc pPerl->PL_origargc
+#undef PL_origargv
+#define PL_origargv pPerl->PL_origargv
+#undef PL_origfilename
+#define PL_origfilename pPerl->PL_origfilename
+#undef PL_ors
+#define PL_ors pPerl->PL_ors
+#undef PL_orslen
+#define PL_orslen pPerl->PL_orslen
+#undef PL_parsehook
+#define PL_parsehook pPerl->PL_parsehook
+#undef PL_patchlevel
+#define PL_patchlevel pPerl->PL_patchlevel
+#undef PL_pending_ident
+#define PL_pending_ident pPerl->PL_pending_ident
+#undef PL_perl_destruct_level
+#define PL_perl_destruct_level pPerl->PL_perl_destruct_level
+#undef PL_perldb
+#define PL_perldb pPerl->PL_perldb
+#undef PL_preambleav
+#define PL_preambleav pPerl->PL_preambleav
+#undef PL_preambled
+#define PL_preambled pPerl->PL_preambled
+#undef PL_preprocess
+#define PL_preprocess pPerl->PL_preprocess
+#undef PL_profiledata
+#define PL_profiledata pPerl->PL_profiledata
+#undef PL_replgv
+#define PL_replgv pPerl->PL_replgv
+#undef PL_rightgv
+#define PL_rightgv pPerl->PL_rightgv
+#undef PL_rsfp
+#define PL_rsfp pPerl->PL_rsfp
+#undef PL_rsfp_filters
+#define PL_rsfp_filters pPerl->PL_rsfp_filters
+#undef PL_sawampersand
+#define PL_sawampersand pPerl->PL_sawampersand
+#undef PL_sawstudy
+#define PL_sawstudy pPerl->PL_sawstudy
+#undef PL_sawvec
+#define PL_sawvec pPerl->PL_sawvec
+#undef PL_siggv
+#define PL_siggv pPerl->PL_siggv
+#undef PL_splitstr
+#define PL_splitstr pPerl->PL_splitstr
+#undef PL_statusvalue
+#define PL_statusvalue pPerl->PL_statusvalue
+#undef PL_statusvalue_vms
+#define PL_statusvalue_vms pPerl->PL_statusvalue_vms
+#undef PL_stdingv
+#define PL_stdingv pPerl->PL_stdingv
+#undef PL_strchop
+#define PL_strchop pPerl->PL_strchop
+#undef PL_strtab
+#define PL_strtab pPerl->PL_strtab
+#undef PL_sub_generation
+#define PL_sub_generation pPerl->PL_sub_generation
+#undef PL_sublex_info
+#define PL_sublex_info pPerl->PL_sublex_info
+#undef PL_sv_arenaroot
+#define PL_sv_arenaroot pPerl->PL_sv_arenaroot
+#undef PL_sv_count
+#define PL_sv_count pPerl->PL_sv_count
+#undef PL_sv_objcount
+#define PL_sv_objcount pPerl->PL_sv_objcount
+#undef PL_sv_root
+#define PL_sv_root pPerl->PL_sv_root
+#undef PL_sys_intern
+#define PL_sys_intern pPerl->PL_sys_intern
+#undef PL_tainting
+#define PL_tainting pPerl->PL_tainting
+#undef PL_threadnum
+#define PL_threadnum pPerl->PL_threadnum
+#undef PL_thrsv
+#define PL_thrsv pPerl->PL_thrsv
+#undef PL_unsafe
+#define PL_unsafe pPerl->PL_unsafe
+#undef PL_warnhook
+#define PL_warnhook pPerl->PL_warnhook
+#undef PL_No
+#define PL_No pPerl->PL_No
+#undef PL_Yes
+#define PL_Yes pPerl->PL_Yes
+#undef PL_amagic_generation
+#define PL_amagic_generation pPerl->PL_amagic_generation
+#undef PL_an
+#define PL_an pPerl->PL_an
+#undef PL_bufend
+#define PL_bufend pPerl->PL_bufend
+#undef PL_bufptr
+#define PL_bufptr pPerl->PL_bufptr
+#undef PL_collation_ix
+#define PL_collation_ix pPerl->PL_collation_ix
+#undef PL_collation_name
+#define PL_collation_name pPerl->PL_collation_name
+#undef PL_collation_standard
+#define PL_collation_standard pPerl->PL_collation_standard
+#undef PL_collxfrm_base
+#define PL_collxfrm_base pPerl->PL_collxfrm_base
+#undef PL_collxfrm_mult
+#define PL_collxfrm_mult pPerl->PL_collxfrm_mult
+#undef PL_cop_seqmax
+#define PL_cop_seqmax pPerl->PL_cop_seqmax
+#undef PL_cryptseen
+#define PL_cryptseen pPerl->PL_cryptseen
+#undef PL_cshlen
+#define PL_cshlen pPerl->PL_cshlen
+#undef PL_cshname
+#define PL_cshname pPerl->PL_cshname
+#undef PL_curinterp
+#define PL_curinterp pPerl->PL_curinterp
+#undef PL_curthr
+#define PL_curthr pPerl->PL_curthr
+#undef PL_debug
+#define PL_debug pPerl->PL_debug
+#undef PL_do_undump
+#define PL_do_undump pPerl->PL_do_undump
+#undef PL_egid
+#define PL_egid pPerl->PL_egid
+#undef PL_error_count
+#define PL_error_count pPerl->PL_error_count
+#undef PL_euid
+#define PL_euid pPerl->PL_euid
+#undef PL_eval_cond
+#define PL_eval_cond pPerl->PL_eval_cond
+#undef PL_eval_mutex
+#define PL_eval_mutex pPerl->PL_eval_mutex
+#undef PL_eval_owner
+#define PL_eval_owner pPerl->PL_eval_owner
+#undef PL_evalseq
+#define PL_evalseq pPerl->PL_evalseq
+#undef PL_expect
+#define PL_expect pPerl->PL_expect
+#undef PL_gid
+#define PL_gid pPerl->PL_gid
+#undef PL_he_root
+#define PL_he_root pPerl->PL_he_root
+#undef PL_hexdigit
+#define PL_hexdigit pPerl->PL_hexdigit
+#undef PL_hints
+#define PL_hints pPerl->PL_hints
+#undef PL_in_my
+#define PL_in_my pPerl->PL_in_my
+#undef PL_in_my_stash
+#define PL_in_my_stash pPerl->PL_in_my_stash
+#undef PL_last_lop
+#define PL_last_lop pPerl->PL_last_lop
+#undef PL_last_lop_op
+#define PL_last_lop_op pPerl->PL_last_lop_op
+#undef PL_last_uni
+#define PL_last_uni pPerl->PL_last_uni
+#undef PL_lex_brackets
+#define PL_lex_brackets pPerl->PL_lex_brackets
+#undef PL_lex_brackstack
+#define PL_lex_brackstack pPerl->PL_lex_brackstack
+#undef PL_lex_casemods
+#define PL_lex_casemods pPerl->PL_lex_casemods
+#undef PL_lex_casestack
+#define PL_lex_casestack pPerl->PL_lex_casestack
+#undef PL_lex_defer
+#define PL_lex_defer pPerl->PL_lex_defer
+#undef PL_lex_dojoin
+#define PL_lex_dojoin pPerl->PL_lex_dojoin
+#undef PL_lex_expect
+#define PL_lex_expect pPerl->PL_lex_expect
+#undef PL_lex_fakebrack
+#define PL_lex_fakebrack pPerl->PL_lex_fakebrack
+#undef PL_lex_formbrack
+#define PL_lex_formbrack pPerl->PL_lex_formbrack
+#undef PL_lex_inpat
+#define PL_lex_inpat pPerl->PL_lex_inpat
+#undef PL_lex_inwhat
+#define PL_lex_inwhat pPerl->PL_lex_inwhat
+#undef PL_lex_op
+#define PL_lex_op pPerl->PL_lex_op
+#undef PL_lex_repl
+#define PL_lex_repl pPerl->PL_lex_repl
+#undef PL_lex_starts
+#define PL_lex_starts pPerl->PL_lex_starts
+#undef PL_lex_state
+#define PL_lex_state pPerl->PL_lex_state
+#undef PL_lex_stuff
+#define PL_lex_stuff pPerl->PL_lex_stuff
+#undef PL_linestr
+#define PL_linestr pPerl->PL_linestr
+#undef PL_malloc_mutex
+#define PL_malloc_mutex pPerl->PL_malloc_mutex
+#undef PL_max_intro_pending
+#define PL_max_intro_pending pPerl->PL_max_intro_pending
+#undef PL_maxo
+#define PL_maxo pPerl->PL_maxo
+#undef PL_min_intro_pending
+#define PL_min_intro_pending pPerl->PL_min_intro_pending
+#undef PL_multi_close
+#define PL_multi_close pPerl->PL_multi_close
+#undef PL_multi_end
+#define PL_multi_end pPerl->PL_multi_end
+#undef PL_multi_open
+#define PL_multi_open pPerl->PL_multi_open
+#undef PL_multi_start
+#define PL_multi_start pPerl->PL_multi_start
+#undef PL_na
+#define PL_na pPerl->PL_na
+#undef PL_nexttoke
+#define PL_nexttoke pPerl->PL_nexttoke
+#undef PL_nexttype
+#define PL_nexttype pPerl->PL_nexttype
+#undef PL_nextval
+#define PL_nextval pPerl->PL_nextval
+#undef PL_nice_chunk
+#define PL_nice_chunk pPerl->PL_nice_chunk
+#undef PL_nice_chunk_size
+#define PL_nice_chunk_size pPerl->PL_nice_chunk_size
+#undef PL_ninterps
+#define PL_ninterps pPerl->PL_ninterps
+#undef PL_nomemok
+#define PL_nomemok pPerl->PL_nomemok
+#undef PL_nthreads
+#define PL_nthreads pPerl->PL_nthreads
+#undef PL_nthreads_cond
+#define PL_nthreads_cond pPerl->PL_nthreads_cond
+#undef PL_numeric_local
+#define PL_numeric_local pPerl->PL_numeric_local
+#undef PL_numeric_name
+#define PL_numeric_name pPerl->PL_numeric_name
+#undef PL_numeric_standard
+#define PL_numeric_standard pPerl->PL_numeric_standard
+#undef PL_oldbufptr
+#define PL_oldbufptr pPerl->PL_oldbufptr
+#undef PL_oldoldbufptr
+#define PL_oldoldbufptr pPerl->PL_oldoldbufptr
+#undef PL_op_seqmax
+#define PL_op_seqmax pPerl->PL_op_seqmax
+#undef PL_origalen
+#define PL_origalen pPerl->PL_origalen
+#undef PL_origenviron
+#define PL_origenviron pPerl->PL_origenviron
+#undef PL_osname
+#define PL_osname pPerl->PL_osname
+#undef PL_pad_reset_pending
+#define PL_pad_reset_pending pPerl->PL_pad_reset_pending
+#undef PL_padix
+#define PL_padix pPerl->PL_padix
+#undef PL_padix_floor
+#define PL_padix_floor pPerl->PL_padix_floor
+#undef PL_patleave
+#define PL_patleave pPerl->PL_patleave
+#undef PL_pidstatus
+#define PL_pidstatus pPerl->PL_pidstatus
+#undef PL_runops
+#define PL_runops pPerl->PL_runops
+#undef PL_sh_path
+#define PL_sh_path pPerl->PL_sh_path
+#undef PL_sighandlerp
+#define PL_sighandlerp pPerl->PL_sighandlerp
+#undef PL_specialsv_list
+#define PL_specialsv_list pPerl->PL_specialsv_list
+#undef PL_subline
+#define PL_subline pPerl->PL_subline
+#undef PL_subname
+#define PL_subname pPerl->PL_subname
+#undef PL_sv_mutex
+#define PL_sv_mutex pPerl->PL_sv_mutex
+#undef PL_sv_no
+#define PL_sv_no pPerl->PL_sv_no
+#undef PL_sv_undef
+#define PL_sv_undef pPerl->PL_sv_undef
+#undef PL_sv_yes
+#define PL_sv_yes pPerl->PL_sv_yes
+#undef PL_svref_mutex
+#define PL_svref_mutex pPerl->PL_svref_mutex
+#undef PL_thisexpr
+#define PL_thisexpr pPerl->PL_thisexpr
+#undef PL_thr_key
+#define PL_thr_key pPerl->PL_thr_key
+#undef PL_threads_mutex
+#define PL_threads_mutex pPerl->PL_threads_mutex
+#undef PL_threadsv_names
+#define PL_threadsv_names pPerl->PL_threadsv_names
+#undef PL_tokenbuf
+#define PL_tokenbuf pPerl->PL_tokenbuf
+#undef PL_uid
+#define PL_uid pPerl->PL_uid
+#undef PL_xiv_arenaroot
+#define PL_xiv_arenaroot pPerl->PL_xiv_arenaroot
+#undef PL_xiv_root
+#define PL_xiv_root pPerl->PL_xiv_root
+#undef PL_xnv_root
+#define PL_xnv_root pPerl->PL_xnv_root
+#undef PL_xpv_root
+#define PL_xpv_root pPerl->PL_xpv_root
+#undef PL_xrv_root
+#define PL_xrv_root pPerl->PL_xrv_root
+
+/* Functions */
+
+#undef amagic_call
+#define amagic_call pPerl->Perl_amagic_call
+#undef Perl_GetVars
+#define Perl_GetVars pPerl->Perl_GetVars
+#undef Gv_AMupdate
+#define Gv_AMupdate pPerl->Perl_Gv_AMupdate
+#undef append_elem
+#define append_elem pPerl->Perl_append_elem
+#undef append_list
+#define append_list pPerl->Perl_append_list
+#undef apply
+#define apply pPerl->Perl_apply
+#undef assertref
+#define assertref pPerl->Perl_assertref
+#undef av_clear
+#define av_clear pPerl->Perl_av_clear
+#undef av_extend
+#define av_extend pPerl->Perl_av_extend
+#undef av_fake
+#define av_fake pPerl->Perl_av_fake
+#undef av_fetch
+#define av_fetch pPerl->Perl_av_fetch
+#undef av_fill
+#define av_fill pPerl->Perl_av_fill
+#undef av_len
+#define av_len pPerl->Perl_av_len
+#undef av_make
+#define av_make pPerl->Perl_av_make
+#undef av_pop
+#define av_pop pPerl->Perl_av_pop
+#undef av_push
+#define av_push pPerl->Perl_av_push
+#undef av_reify
+#define av_reify pPerl->Perl_av_reify
+#undef av_shift
+#define av_shift pPerl->Perl_av_shift
+#undef av_store
+#define av_store pPerl->Perl_av_store
+#undef av_undef
+#define av_undef pPerl->Perl_av_undef
+#undef av_unshift
+#define av_unshift pPerl->Perl_av_unshift
+#undef avhv_exists_ent
+#define avhv_exists_ent pPerl->Perl_avhv_exists_ent
+#undef avhv_fetch_ent
+#define avhv_fetch_ent pPerl->Perl_avhv_fetch_ent
+#undef avhv_iternext
+#define avhv_iternext pPerl->Perl_avhv_iternext
+#undef avhv_iterval
+#define avhv_iterval pPerl->Perl_avhv_iterval
+#undef avhv_keys
+#define avhv_keys pPerl->Perl_avhv_keys
+#undef bind_match
+#define bind_match pPerl->Perl_bind_match
+#undef block_end
+#define block_end pPerl->Perl_block_end
+#undef block_gimme
+#define block_gimme pPerl->Perl_block_gimme
+#undef block_start
+#define block_start pPerl->Perl_block_start
+#undef byterun
+#define byterun pPerl->Perl_byterun
+#undef call_list
+#define call_list pPerl->Perl_call_list
+#undef cando
+#define cando pPerl->Perl_cando
+#undef cast_ulong
+#define cast_ulong pPerl->Perl_cast_ulong
+#undef checkcomma
+#define checkcomma pPerl->Perl_checkcomma
+#undef check_uni
+#define check_uni pPerl->Perl_check_uni
+#undef ck_concat
+#define ck_concat pPerl->Perl_ck_concat
+#undef ck_delete
+#define ck_delete pPerl->Perl_ck_delete
+#undef ck_eof
+#define ck_eof pPerl->Perl_ck_eof
+#undef ck_eval
+#define ck_eval pPerl->Perl_ck_eval
+#undef ck_exec
+#define ck_exec pPerl->Perl_ck_exec
+#undef ck_formline
+#define ck_formline pPerl->Perl_ck_formline
+#undef ck_ftst
+#define ck_ftst pPerl->Perl_ck_ftst
+#undef ck_fun
+#define ck_fun pPerl->Perl_ck_fun
+#undef ck_glob
+#define ck_glob pPerl->Perl_ck_glob
+#undef ck_grep
+#define ck_grep pPerl->Perl_ck_grep
+#undef ck_gvconst
+#define ck_gvconst pPerl->Perl_ck_gvconst
+#undef ck_index
+#define ck_index pPerl->Perl_ck_index
+#undef ck_lengthconst
+#define ck_lengthconst pPerl->Perl_ck_lengthconst
+#undef ck_lfun
+#define ck_lfun pPerl->Perl_ck_lfun
+#undef ck_listiob
+#define ck_listiob pPerl->Perl_ck_listiob
+#undef ck_match
+#define ck_match pPerl->Perl_ck_match
+#undef ck_null
+#define ck_null pPerl->Perl_ck_null
+#undef ck_repeat
+#define ck_repeat pPerl->Perl_ck_repeat
+#undef ck_require
+#define ck_require pPerl->Perl_ck_require
+#undef ck_retarget
+#define ck_retarget pPerl->Perl_ck_retarget
+#undef ck_rfun
+#define ck_rfun pPerl->Perl_ck_rfun
+#undef ck_rvconst
+#define ck_rvconst pPerl->Perl_ck_rvconst
+#undef ck_select
+#define ck_select pPerl->Perl_ck_select
+#undef ck_shift
+#define ck_shift pPerl->Perl_ck_shift
+#undef ck_sort
+#define ck_sort pPerl->Perl_ck_sort
+#undef ck_spair
+#define ck_spair pPerl->Perl_ck_spair
+#undef ck_split
+#define ck_split pPerl->Perl_ck_split
+#undef ck_subr
+#define ck_subr pPerl->Perl_ck_subr
+#undef ck_svconst
+#define ck_svconst pPerl->Perl_ck_svconst
+#undef ck_trunc
+#define ck_trunc pPerl->Perl_ck_trunc
+#undef condpair_magic
+#define condpair_magic pPerl->Perl_condpair_magic
+#undef convert
+#define convert pPerl->Perl_convert
+#undef cpytill
+#define cpytill pPerl->Perl_cpytill
+#undef croak
+#define croak pPerl->Perl_croak
+#undef cv_ckproto
+#define cv_ckproto pPerl->Perl_cv_ckproto
+#undef cv_clone
+#define cv_clone pPerl->Perl_cv_clone
+#undef cv_const_sv
+#define cv_const_sv pPerl->Perl_cv_const_sv
+#undef cv_undef
+#define cv_undef pPerl->Perl_cv_undef
+#undef cx_dump
+#define cx_dump pPerl->Perl_cx_dump
+#undef cxinc
+#define cxinc pPerl->Perl_cxinc
+#undef deb
+#define deb pPerl->Perl_deb
+#undef deb_growlevel
+#define deb_growlevel pPerl->Perl_deb_growlevel
+#undef debprofdump
+#define debprofdump pPerl->Perl_debprofdump
+#undef debop
+#define debop pPerl->Perl_debop
+#undef debstack
+#define debstack pPerl->Perl_debstack
+#undef debstackptrs
+#define debstackptrs pPerl->Perl_debstackptrs
+#undef delimcpy
+#define delimcpy pPerl->Perl_delimcpy
+#undef deprecate
+#define deprecate pPerl->Perl_deprecate
+#undef die
+#define die pPerl->Perl_die
+#undef die_where
+#define die_where pPerl->Perl_die_where
+#undef dopoptoeval
+#define dopoptoeval pPerl->Perl_dopoptoeval
+#undef dounwind
+#define dounwind pPerl->Perl_dounwind
+#undef do_aexec
+#define do_aexec pPerl->Perl_do_aexec
+#undef do_binmode
+#define do_binmode pPerl->Perl_do_binmode
+#undef do_chomp
+#define do_chomp pPerl->Perl_do_chomp
+#undef do_chop
+#define do_chop pPerl->Perl_do_chop
+#undef do_close
+#define do_close pPerl->Perl_do_close
+#undef do_eof
+#define do_eof pPerl->Perl_do_eof
+#undef do_exec
+#define do_exec pPerl->Perl_do_exec
+#undef do_execfree
+#define do_execfree pPerl->Perl_do_execfree
+#undef do_join
+#define do_join pPerl->Perl_do_join
+#undef do_kv
+#define do_kv pPerl->Perl_do_kv
+#undef do_open
+#define do_open pPerl->Perl_do_open
+#undef do_pipe
+#define do_pipe pPerl->Perl_do_pipe
+#undef do_print
+#define do_print pPerl->Perl_do_print
+#undef do_readline
+#define do_readline pPerl->Perl_do_readline
+#undef do_seek
+#define do_seek pPerl->Perl_do_seek
+#undef do_sprintf
+#define do_sprintf pPerl->Perl_do_sprintf
+#undef do_sysseek
+#define do_sysseek pPerl->Perl_do_sysseek
+#undef do_tell
+#define do_tell pPerl->Perl_do_tell
+#undef do_trans
+#define do_trans pPerl->Perl_do_trans
+#undef do_vecset
+#define do_vecset pPerl->Perl_do_vecset
+#undef do_vop
+#define do_vop pPerl->Perl_do_vop
+#undef dowantarray
+#define dowantarray pPerl->Perl_dowantarray
+#undef dump_all
+#define dump_all pPerl->Perl_dump_all
+#undef dump_eval
+#define dump_eval pPerl->Perl_dump_eval
+#undef dump_fds
+#define dump_fds pPerl->Perl_dump_fds
+#undef dump_form
+#define dump_form pPerl->Perl_dump_form
+#undef dump_gv
+#define dump_gv pPerl->Perl_dump_gv
+#undef dump_mstats
+#define dump_mstats pPerl->Perl_dump_mstats
+#undef dump_op
+#define dump_op pPerl->Perl_dump_op
+#undef dump_pm
+#define dump_pm pPerl->Perl_dump_pm
+#undef dump_packsubs
+#define dump_packsubs pPerl->Perl_dump_packsubs
+#undef dump_sub
+#define dump_sub pPerl->Perl_dump_sub
+#undef fbm_compile
+#define fbm_compile pPerl->Perl_fbm_compile
+#undef fbm_instr
+#define fbm_instr pPerl->Perl_fbm_instr
+#undef filter_add
+#define filter_add pPerl->Perl_filter_add
+#undef filter_del
+#define filter_del pPerl->Perl_filter_del
+#undef filter_read
+#define filter_read pPerl->Perl_filter_read
+#undef find_threadsv
+#define find_threadsv pPerl->Perl_find_threadsv
+#undef find_script
+#define find_script pPerl->Perl_find_script
+#undef force_ident
+#define force_ident pPerl->Perl_force_ident
+#undef force_list
+#define force_list pPerl->Perl_force_list
+#undef force_next
+#define force_next pPerl->Perl_force_next
+#undef force_word
+#define force_word pPerl->Perl_force_word
+#undef form
+#define form pPerl->Perl_form
+#undef fold_constants
+#define fold_constants pPerl->Perl_fold_constants
+#undef fprintf
+#define fprintf pPerl->fprintf
+#undef free_tmps
+#define free_tmps pPerl->Perl_free_tmps
+#undef gen_constant_list
+#define gen_constant_list pPerl->Perl_gen_constant_list
+#undef get_op_descs
+#define get_op_descs pPerl->Perl_get_op_descs
+#undef get_op_names
+#define get_op_names pPerl->Perl_get_op_names
+#undef get_no_modify
+#define get_no_modify pPerl->Perl_get_no_modify
+#undef get_opargs
+#define get_opargs pPerl->Perl_get_opargs
+#undef get_specialsv_list
+#define get_specialsv_list pPerl->Perl_get_specialsv_list
+#undef gp_free
+#define gp_free pPerl->Perl_gp_free
+#undef gp_ref
+#define gp_ref pPerl->Perl_gp_ref
+#undef gv_AVadd
+#define gv_AVadd pPerl->Perl_gv_AVadd
+#undef gv_HVadd
+#define gv_HVadd pPerl->Perl_gv_HVadd
+#undef gv_IOadd
+#define gv_IOadd pPerl->Perl_gv_IOadd
+#undef gv_autoload4
+#define gv_autoload4 pPerl->Perl_gv_autoload4
+#undef gv_check
+#define gv_check pPerl->Perl_gv_check
+#undef gv_efullname
+#define gv_efullname pPerl->Perl_gv_efullname
+#undef gv_efullname3
+#define gv_efullname3 pPerl->Perl_gv_efullname3
+#undef gv_fetchfile
+#define gv_fetchfile pPerl->Perl_gv_fetchfile
+#undef gv_fetchmeth
+#define gv_fetchmeth pPerl->Perl_gv_fetchmeth
+#undef gv_fetchmethod
+#define gv_fetchmethod pPerl->Perl_gv_fetchmethod
+#undef gv_fetchmethod_autoload
+#define gv_fetchmethod_autoload pPerl->Perl_gv_fetchmethod_autoload
+#undef gv_fetchpv
+#define gv_fetchpv pPerl->Perl_gv_fetchpv
+#undef gv_fullname
+#define gv_fullname pPerl->Perl_gv_fullname
+#undef gv_fullname3
+#define gv_fullname3 pPerl->Perl_gv_fullname3
+#undef gv_init
+#define gv_init pPerl->Perl_gv_init
+#undef gv_stashpv
+#define gv_stashpv pPerl->Perl_gv_stashpv
+#undef gv_stashpvn
+#define gv_stashpvn pPerl->Perl_gv_stashpvn
+#undef gv_stashsv
+#define gv_stashsv pPerl->Perl_gv_stashsv
+#undef he_delayfree
+#define he_delayfree pPerl->Perl_he_delayfree
+#undef he_free
+#define he_free pPerl->Perl_he_free
+#undef hoistmust
+#define hoistmust pPerl->Perl_hoistmust
+#undef hv_clear
+#define hv_clear pPerl->Perl_hv_clear
+#undef hv_delayfree_ent
+#define hv_delayfree_ent pPerl->Perl_hv_delayfree_ent
+#undef hv_delete
+#define hv_delete pPerl->Perl_hv_delete
+#undef hv_delete_ent
+#define hv_delete_ent pPerl->Perl_hv_delete_ent
+#undef hv_exists
+#define hv_exists pPerl->Perl_hv_exists
+#undef hv_exists_ent
+#define hv_exists_ent pPerl->Perl_hv_exists_ent
+#undef hv_fetch
+#define hv_fetch pPerl->Perl_hv_fetch
+#undef hv_fetch_ent
+#define hv_fetch_ent pPerl->Perl_hv_fetch_ent
+#undef hv_free_ent
+#define hv_free_ent pPerl->Perl_hv_free_ent
+#undef hv_iterinit
+#define hv_iterinit pPerl->Perl_hv_iterinit
+#undef hv_iterkey
+#define hv_iterkey pPerl->Perl_hv_iterkey
+#undef hv_iterkeysv
+#define hv_iterkeysv pPerl->Perl_hv_iterkeysv
+#undef hv_iternext
+#define hv_iternext pPerl->Perl_hv_iternext
+#undef hv_iternextsv
+#define hv_iternextsv pPerl->Perl_hv_iternextsv
+#undef hv_iterval
+#define hv_iterval pPerl->Perl_hv_iterval
+#undef hv_ksplit
+#define hv_ksplit pPerl->Perl_hv_ksplit
+#undef hv_magic
+#define hv_magic pPerl->Perl_hv_magic
+#undef hv_store
+#define hv_store pPerl->Perl_hv_store
+#undef hv_store_ent
+#define hv_store_ent pPerl->Perl_hv_store_ent
+#undef hv_undef
+#define hv_undef pPerl->Perl_hv_undef
+#undef ibcmp
+#define ibcmp pPerl->Perl_ibcmp
+#undef ibcmp_locale
+#define ibcmp_locale pPerl->Perl_ibcmp_locale
+#undef incpush
+#define incpush pPerl->incpush
+#undef incline
+#define incline pPerl->incline
+#undef incl_perldb
+#define incl_perldb pPerl->incl_perldb
+#undef ingroup
+#define ingroup pPerl->Perl_ingroup
+#undef init_stacks
+#define init_stacks pPerl->Perl_init_stacks
+#undef instr
+#define instr pPerl->Perl_instr
+#undef intro_my
+#define intro_my pPerl->Perl_intro_my
+#undef intuit_method
+#define intuit_method pPerl->intuit_method
+#undef intuit_more
+#define intuit_more pPerl->Perl_intuit_more
+#undef invert
+#define invert pPerl->Perl_invert
+#undef io_close
+#define io_close pPerl->Perl_io_close
+#undef ioctl
+#define ioctl pPerl->ioctl
+#undef jmaybe
+#define jmaybe pPerl->Perl_jmaybe
+#undef keyword
+#define keyword pPerl->Perl_keyword
+#undef leave_scope
+#define leave_scope pPerl->Perl_leave_scope
+#undef lex_end
+#define lex_end pPerl->Perl_lex_end
+#undef lex_start
+#define lex_start pPerl->Perl_lex_start
+#undef linklist
+#define linklist pPerl->Perl_linklist
+#undef list
+#define list pPerl->Perl_list
+#undef listkids
+#define listkids pPerl->Perl_listkids
+#undef lop
+#define lop pPerl->lop
+#undef localize
+#define localize pPerl->Perl_localize
+#undef looks_like_number
+#define looks_like_number pPerl->Perl_looks_like_number
+#undef magic_clear_all_env
+#define magic_clear_all_env pPerl->Perl_magic_clear_all_env
+#undef magic_clearenv
+#define magic_clearenv pPerl->Perl_magic_clearenv
+#undef magic_clearpack
+#define magic_clearpack pPerl->Perl_magic_clearpack
+#undef magic_clearsig
+#define magic_clearsig pPerl->Perl_magic_clearsig
+#undef magic_existspack
+#define magic_existspack pPerl->Perl_magic_existspack
+#undef magic_freeregexp
+#define magic_freeregexp pPerl->Perl_magic_freeregexp
+#undef magic_get
+#define magic_get pPerl->Perl_magic_get
+#undef magic_getarylen
+#define magic_getarylen pPerl->Perl_magic_getarylen
+#undef magic_getdefelem
+#define magic_getdefelem pPerl->Perl_magic_getdefelem
+#undef magic_getpack
+#define magic_getpack pPerl->Perl_magic_getpack
+#undef magic_getglob
+#define magic_getglob pPerl->Perl_magic_getglob
+#undef magic_getnkeys
+#define magic_getnkeys pPerl->Perl_magic_getnkeys
+#undef magic_getpos
+#define magic_getpos pPerl->Perl_magic_getpos
+#undef magic_getsig
+#define magic_getsig pPerl->Perl_magic_getsig
+#undef magic_getsubstr
+#define magic_getsubstr pPerl->Perl_magic_getsubstr
+#undef magic_gettaint
+#define magic_gettaint pPerl->Perl_magic_gettaint
+#undef magic_getuvar
+#define magic_getuvar pPerl->Perl_magic_getuvar
+#undef magic_getvec
+#define magic_getvec pPerl->Perl_magic_getvec
+#undef magic_len
+#define magic_len pPerl->Perl_magic_len
+#undef magic_methpack
+#define magic_methpack pPerl->magic_methpack
+#undef magic_mutexfree
+#define magic_mutexfree pPerl->Perl_magic_mutexfree
+#undef magic_nextpack
+#define magic_nextpack pPerl->Perl_magic_nextpack
+#undef magic_set
+#define magic_set pPerl->Perl_magic_set
+#undef magic_set_all_env
+#define magic_set_all_env pPerl->Perl_magic_set_all_env
+#undef magic_setamagic
+#define magic_setamagic pPerl->Perl_magic_setamagic
+#undef magic_setarylen
+#define magic_setarylen pPerl->Perl_magic_setarylen
+#undef magic_setbm
+#define magic_setbm pPerl->Perl_magic_setbm
+#undef magic_setcollxfrm
+#define magic_setcollxfrm pPerl->Perl_magic_setcollxfrm
+#undef magic_setdbline
+#define magic_setdbline pPerl->Perl_magic_setdbline
+#undef magic_setdefelem
+#define magic_setdefelem pPerl->Perl_magic_setdefelem
+#undef magic_setenv
+#define magic_setenv pPerl->Perl_magic_setenv
+#undef magic_setfm
+#define magic_setfm pPerl->Perl_magic_setfm
+#undef magic_setisa
+#define magic_setisa pPerl->Perl_magic_setisa
+#undef magic_setglob
+#define magic_setglob pPerl->Perl_magic_setglob
+#undef magic_setmglob
+#define magic_setmglob pPerl->Perl_magic_setmglob
+#undef magic_setnkeys
+#define magic_setnkeys pPerl->Perl_magic_setnkeys
+#undef magic_setpack
+#define magic_setpack pPerl->Perl_magic_setpack
+#undef magic_setpos
+#define magic_setpos pPerl->Perl_magic_setpos
+#undef magic_setsig
+#define magic_setsig pPerl->Perl_magic_setsig
+#undef magic_setsubstr
+#define magic_setsubstr pPerl->Perl_magic_setsubstr
+#undef magic_settaint
+#define magic_settaint pPerl->Perl_magic_settaint
+#undef magic_setuvar
+#define magic_setuvar pPerl->Perl_magic_setuvar
+#undef magic_setvec
+#define magic_setvec pPerl->Perl_magic_setvec
+#undef magic_sizepack
+#define magic_sizepack pPerl->Perl_magic_sizepack
+#undef magic_unchain
+#define magic_unchain pPerl->Perl_magic_unchain
+#undef magic_wipepack
+#define magic_wipepack pPerl->Perl_magic_wipepack
+#undef magicname
+#define magicname pPerl->Perl_magicname
+#undef malloced_size
+#define malloced_size pPerl->Perl_malloced_size
+#undef markstack_grow
+#define markstack_grow pPerl->Perl_markstack_grow
+#undef mem_collxfrm
+#define mem_collxfrm pPerl->Perl_mem_collxfrm
+#undef mess
+#define mess pPerl->Perl_mess
+#undef mg_clear
+#define mg_clear pPerl->Perl_mg_clear
+#undef mg_copy
+#define mg_copy pPerl->Perl_mg_copy
+#undef mg_find
+#define mg_find pPerl->Perl_mg_find
+#undef mg_free
+#define mg_free pPerl->Perl_mg_free
+#undef mg_get
+#define mg_get pPerl->Perl_mg_get
+#undef mg_magical
+#define mg_magical pPerl->Perl_mg_magical
+#undef mg_length
+#define mg_length pPerl->Perl_mg_length
+#undef mg_set
+#define mg_set pPerl->Perl_mg_set
+#undef mg_size
+#define mg_size pPerl->Perl_mg_size
+#undef missingterm
+#define missingterm pPerl->missingterm
+#undef mod
+#define mod pPerl->Perl_mod
+#undef modkids
+#define modkids pPerl->Perl_modkids
+#undef moreswitches
+#define moreswitches pPerl->Perl_moreswitches
+#undef more_sv
+#define more_sv pPerl->more_sv
+#undef more_xiv
+#define more_xiv pPerl->more_xiv
+#undef more_xnv
+#define more_xnv pPerl->more_xnv
+#undef more_xpv
+#define more_xpv pPerl->more_xpv
+#undef more_xrv
+#define more_xrv pPerl->more_xrv
+#undef my
+#define my pPerl->Perl_my
+#undef my_bcopy
+#define my_bcopy pPerl->Perl_my_bcopy
+#undef my_bzero
+#define my_bzero pPerl->Perl_my_bzero
+#undef my_chsize
+#define my_chsize pPerl->Perl_my_chsize
+#undef my_exit
+#define my_exit pPerl->Perl_my_exit
+#undef my_failure_exit
+#define my_failure_exit pPerl->Perl_my_failure_exit
+#undef my_htonl
+#define my_htonl pPerl->Perl_my_htonl
+#undef my_lstat
+#define my_lstat pPerl->Perl_my_lstat
+#undef my_memcmp
+#define my_memcmp pPerl->my_memcmp
+#undef my_ntohl
+#define my_ntohl pPerl->Perl_my_ntohl
+#undef my_pclose
+#define my_pclose pPerl->Perl_my_pclose
+#undef my_popen
+#define my_popen pPerl->Perl_my_popen
+#undef my_setenv
+#define my_setenv pPerl->Perl_my_setenv
+#undef my_stat
+#define my_stat pPerl->Perl_my_stat
+#undef my_swap
+#define my_swap pPerl->Perl_my_swap
+#undef my_unexec
+#define my_unexec pPerl->Perl_my_unexec
+#undef newANONLIST
+#define newANONLIST pPerl->Perl_newANONLIST
+#undef newANONHASH
+#define newANONHASH pPerl->Perl_newANONHASH
+#undef newANONSUB
+#define newANONSUB pPerl->Perl_newANONSUB
+#undef newASSIGNOP
+#define newASSIGNOP pPerl->Perl_newASSIGNOP
+#undef newCONDOP
+#define newCONDOP pPerl->Perl_newCONDOP
+#undef newCONSTSUB
+#define newCONSTSUB pPerl->Perl_newCONSTSUB
+#undef newFORM
+#define newFORM pPerl->Perl_newFORM
+#undef newFOROP
+#define newFOROP pPerl->Perl_newFOROP
+#undef newLOGOP
+#define newLOGOP pPerl->Perl_newLOGOP
+#undef newLOOPEX
+#define newLOOPEX pPerl->Perl_newLOOPEX
+#undef newLOOPOP
+#define newLOOPOP pPerl->Perl_newLOOPOP
+#undef newMETHOD
+#define newMETHOD pPerl->Perl_newMETHOD
+#undef newNULLLIST
+#define newNULLLIST pPerl->Perl_newNULLLIST
+#undef newOP
+#define newOP pPerl->Perl_newOP
+#undef newPROG
+#define newPROG pPerl->Perl_newPROG
+#undef newRANGE
+#define newRANGE pPerl->Perl_newRANGE
+#undef newSLICEOP
+#define newSLICEOP pPerl->Perl_newSLICEOP
+#undef newSTATEOP
+#define newSTATEOP pPerl->Perl_newSTATEOP
+#undef newSUB
+#define newSUB pPerl->Perl_newSUB
+#undef newXS
+#define newXS pPerl->Perl_newXS
+#undef newAV
+#define newAV pPerl->Perl_newAV
+#undef newAVREF
+#define newAVREF pPerl->Perl_newAVREF
+#undef newBINOP
+#define newBINOP pPerl->Perl_newBINOP
+#undef newCVREF
+#define newCVREF pPerl->Perl_newCVREF
+#undef newCVOP
+#define newCVOP pPerl->Perl_newCVOP
+#undef newGVOP
+#define newGVOP pPerl->Perl_newGVOP
+#undef newGVgen
+#define newGVgen pPerl->Perl_newGVgen
+#undef newGVREF
+#define newGVREF pPerl->Perl_newGVREF
+#undef newHVREF
+#define newHVREF pPerl->Perl_newHVREF
+#undef newHV
+#define newHV pPerl->Perl_newHV
+#undef newHVhv
+#define newHVhv pPerl->Perl_newHVhv
+#undef newIO
+#define newIO pPerl->Perl_newIO
+#undef newLISTOP
+#define newLISTOP pPerl->Perl_newLISTOP
+#undef newPMOP
+#define newPMOP pPerl->Perl_newPMOP
+#undef newPVOP
+#define newPVOP pPerl->Perl_newPVOP
+#undef newRV
+#define newRV pPerl->Perl_newRV
+#undef newRV_noinc
+#undef Perl_newRV_noinc
+#define newRV_noinc pPerl->Perl_newRV_noinc
+#undef newSV
+#define newSV pPerl->Perl_newSV
+#undef newSVREF
+#define newSVREF pPerl->Perl_newSVREF
+#undef newSVOP
+#define newSVOP pPerl->Perl_newSVOP
+#undef newSViv
+#define newSViv pPerl->Perl_newSViv
+#undef newSVnv
+#define newSVnv pPerl->Perl_newSVnv
+#undef newSVpv
+#define newSVpv pPerl->Perl_newSVpv
+#undef newSVpvf
+#define newSVpvf pPerl->Perl_newSVpvf
+#undef newSVpvn
+#define newSVpvn pPerl->Perl_newSVpvn
+#undef newSVrv
+#define newSVrv pPerl->Perl_newSVrv
+#undef newSVsv
+#define newSVsv pPerl->Perl_newSVsv
+#undef newUNOP
+#define newUNOP pPerl->Perl_newUNOP
+#undef newWHILEOP
+#define newWHILEOP pPerl->Perl_newWHILEOP
+#undef new_struct_thread
+#define new_struct_thread pPerl->Perl_new_struct_thread
+#undef new_stackinfo
+#define new_stackinfo pPerl->Perl_new_stackinfo
+#undef new_sv
+#define new_sv pPerl->new_sv
+#undef new_xnv
+#define new_xnv pPerl->new_xnv
+#undef new_xpv
+#define new_xpv pPerl->new_xpv
+#undef nextargv
+#define nextargv pPerl->Perl_nextargv
+#undef nextchar
+#define nextchar pPerl->nextchar
+#undef ninstr
+#define ninstr pPerl->Perl_ninstr
+#undef no_fh_allowed
+#define no_fh_allowed pPerl->Perl_no_fh_allowed
+#undef no_op
+#define no_op pPerl->Perl_no_op
+#undef package
+#define package pPerl->Perl_package
+#undef pad_alloc
+#define pad_alloc pPerl->Perl_pad_alloc
+#undef pad_allocmy
+#define pad_allocmy pPerl->Perl_pad_allocmy
+#undef pad_findmy
+#define pad_findmy pPerl->Perl_pad_findmy
+#undef op_const_sv
+#define op_const_sv pPerl->Perl_op_const_sv
+#undef op_free
+#define op_free pPerl->Perl_op_free
+#undef oopsCV
+#define oopsCV pPerl->Perl_oopsCV
+#undef oopsAV
+#define oopsAV pPerl->Perl_oopsAV
+#undef oopsHV
+#define oopsHV pPerl->Perl_oopsHV
+#undef opendir
+#define opendir pPerl->opendir
+#undef pad_leavemy
+#define pad_leavemy pPerl->Perl_pad_leavemy
+#undef pad_sv
+#define pad_sv pPerl->Perl_pad_sv
+#undef pad_findlex
+#define pad_findlex pPerl->pad_findlex
+#undef pad_free
+#define pad_free pPerl->Perl_pad_free
+#undef pad_reset
+#define pad_reset pPerl->Perl_pad_reset
+#undef pad_swipe
+#define pad_swipe pPerl->Perl_pad_swipe
+#undef peep
+#define peep pPerl->Perl_peep
+#undef perl_atexit
+#define perl_atexit pPerl->perl_atexit
+#undef perl_call_argv
+#define perl_call_argv pPerl->perl_call_argv
+#undef perl_call_method
+#define perl_call_method pPerl->perl_call_method
+#undef perl_call_pv
+#define perl_call_pv pPerl->perl_call_pv
+#undef perl_call_sv
+#define perl_call_sv pPerl->perl_call_sv
+#undef perl_callargv
+#define perl_callargv pPerl->perl_callargv
+#undef perl_callpv
+#define perl_callpv pPerl->perl_callpv
+#undef perl_callsv
+#define perl_callsv pPerl->perl_callsv
+#undef perl_eval_pv
+#define perl_eval_pv pPerl->perl_eval_pv
+#undef perl_eval_sv
+#define perl_eval_sv pPerl->perl_eval_sv
+#undef perl_get_sv
+#define perl_get_sv pPerl->perl_get_sv
+#undef perl_get_av
+#define perl_get_av pPerl->perl_get_av
+#undef perl_get_hv
+#define perl_get_hv pPerl->perl_get_hv
+#undef perl_get_cv
+#define perl_get_cv pPerl->perl_get_cv
+#undef perl_init_i18nl10n
+#define perl_init_i18nl10n pPerl->perl_init_i18nl10n
+#undef perl_init_i18nl14n
+#define perl_init_i18nl14n pPerl->perl_init_i18nl14n
+#undef perl_new_collate
+#define perl_new_collate pPerl->perl_new_collate
+#undef perl_new_ctype
+#define perl_new_ctype pPerl->perl_new_ctype
+#undef perl_new_numeric
+#define perl_new_numeric pPerl->perl_new_numeric
+#undef perl_set_numeric_local
+#define perl_set_numeric_local pPerl->perl_set_numeric_local
+#undef perl_set_numeric_standard
+#define perl_set_numeric_standard pPerl->perl_set_numeric_standard
+#undef perl_require_pv
+#define perl_require_pv pPerl->perl_require_pv
+#undef pidgone
+#define pidgone pPerl->Perl_pidgone
+#undef pmflag
+#define pmflag pPerl->Perl_pmflag
+#undef pmruntime
+#define pmruntime pPerl->Perl_pmruntime
+#undef pmtrans
+#define pmtrans pPerl->Perl_pmtrans
+#undef pop_return
+#define pop_return pPerl->Perl_pop_return
+#undef pop_scope
+#define pop_scope pPerl->Perl_pop_scope
+#undef prepend_elem
+#define prepend_elem pPerl->Perl_prepend_elem
+#undef push_return
+#define push_return pPerl->Perl_push_return
+#undef push_scope
+#define push_scope pPerl->Perl_push_scope
+#undef pregcomp
+#define pregcomp pPerl->Perl_pregcomp
+#undef ref
+#define ref pPerl->Perl_ref
+#undef refkids
+#define refkids pPerl->Perl_refkids
+#undef regexec_flags
+#define regexec_flags pPerl->Perl_regexec_flags
+#undef pregexec
+#define pregexec pPerl->Perl_pregexec
+#undef pregfree
+#define pregfree pPerl->Perl_pregfree
+#undef regdump
+#define regdump pPerl->Perl_regdump
+#undef regnext
+#define regnext pPerl->Perl_regnext
+#undef regnoderegnext
+#define regnoderegnext pPerl->regnoderegnext
+#undef regprop
+#define regprop pPerl->Perl_regprop
+#undef repeatcpy
+#define repeatcpy pPerl->Perl_repeatcpy
+#undef rninstr
+#define rninstr pPerl->Perl_rninstr
+#undef rsignal
+#define rsignal pPerl->Perl_rsignal
+#undef rsignal_restore
+#define rsignal_restore pPerl->Perl_rsignal_restore
+#undef rsignal_save
+#define rsignal_save pPerl->Perl_rsignal_save
+#undef rsignal_state
+#define rsignal_state pPerl->Perl_rsignal_state
+#undef run
+#define run pPerl->Perl_run
+#undef rxres_free
+#define rxres_free pPerl->Perl_rxres_free
+#undef rxres_restore
+#define rxres_restore pPerl->Perl_rxres_restore
+#undef rxres_save
+#define rxres_save pPerl->Perl_rxres_save
+#undef safefree
+#define safefree pPerl->Perl_safefree
+#undef safecalloc
+#define safecalloc pPerl->Perl_safecalloc
+#undef safemalloc
+#define safemalloc pPerl->Perl_safemalloc
+#undef saferealloc
+#define saferealloc pPerl->Perl_saferealloc
+#undef safexcalloc
+#define safexcalloc pPerl->Perl_safexcalloc
+#undef safexfree
+#define safexfree pPerl->Perl_safexfree
+#undef safexmalloc
+#define safexmalloc pPerl->Perl_safexmalloc
+#undef safexrealloc
+#define safexrealloc pPerl->Perl_safexrealloc
+#undef same_dirent
+#define same_dirent pPerl->Perl_same_dirent
+#undef savepv
+#define savepv pPerl->Perl_savepv
+#undef savepvn
+#define savepvn pPerl->Perl_savepvn
+#undef savestack_grow
+#define savestack_grow pPerl->Perl_savestack_grow
+#undef save_aelem
+#define save_aelem pPerl->Perl_save_aelem
+#undef save_aptr
+#define save_aptr pPerl->Perl_save_aptr
+#undef save_ary
+#define save_ary pPerl->Perl_save_ary
+#undef save_clearsv
+#define save_clearsv pPerl->Perl_save_clearsv
+#undef save_delete
+#define save_delete pPerl->Perl_save_delete
+#undef save_destructor
+#define save_destructor pPerl->Perl_save_destructor
+#undef save_freesv
+#define save_freesv pPerl->Perl_save_freesv
+#undef save_freeop
+#define save_freeop pPerl->Perl_save_freeop
+#undef save_freepv
+#define save_freepv pPerl->Perl_save_freepv
+#undef save_gp
+#define save_gp pPerl->Perl_save_gp
+#undef save_hash
+#define save_hash pPerl->Perl_save_hash
+#undef save_helem
+#define save_helem pPerl->Perl_save_helem
+#undef save_hints
+#define save_hints pPerl->Perl_save_hints
+#undef save_hptr
+#define save_hptr pPerl->Perl_save_hptr
+#undef save_I16
+#define save_I16 pPerl->Perl_save_I16
+#undef save_I32
+#define save_I32 pPerl->Perl_save_I32
+#undef save_int
+#define save_int pPerl->Perl_save_int
+#undef save_item
+#define save_item pPerl->Perl_save_item
+#undef save_iv
+#define save_iv pPerl->Perl_save_iv
+#undef save_list
+#define save_list pPerl->Perl_save_list
+#undef save_long
+#define save_long pPerl->Perl_save_long
+#undef save_nogv
+#define save_nogv pPerl->Perl_save_nogv
+#undef save_op
+#define save_op pPerl->Perl_save_op
+#undef save_scalar
+#define save_scalar pPerl->Perl_save_scalar
+#undef save_pptr
+#define save_pptr pPerl->Perl_save_pptr
+#undef save_sptr
+#define save_sptr pPerl->Perl_save_sptr
+#undef save_svref
+#define save_svref pPerl->Perl_save_svref
+#undef save_threadsv
+#define save_threadsv pPerl->Perl_save_threadsv
+#undef sawparens
+#define sawparens pPerl->Perl_sawparens
+#undef scalar
+#define scalar pPerl->Perl_scalar
+#undef scalarkids
+#define scalarkids pPerl->Perl_scalarkids
+#undef scalarseq
+#define scalarseq pPerl->Perl_scalarseq
+#undef scalarvoid
+#define scalarvoid pPerl->Perl_scalarvoid
+#undef scan_const
+#define scan_const pPerl->Perl_scan_const
+#undef scan_formline
+#define scan_formline pPerl->Perl_scan_formline
+#undef scan_ident
+#define scan_ident pPerl->Perl_scan_ident
+#undef scan_inputsymbol
+#define scan_inputsymbol pPerl->Perl_scan_inputsymbol
+#undef scan_heredoc
+#define scan_heredoc pPerl->Perl_scan_heredoc
+#undef scan_hex
+#define scan_hex pPerl->Perl_scan_hex
+#undef scan_num
+#define scan_num pPerl->Perl_scan_num
+#undef scan_oct
+#define scan_oct pPerl->Perl_scan_oct
+#undef scan_pat
+#define scan_pat pPerl->Perl_scan_pat
+#undef scan_str
+#define scan_str pPerl->Perl_scan_str
+#undef scan_subst
+#define scan_subst pPerl->Perl_scan_subst
+#undef scan_trans
+#define scan_trans pPerl->Perl_scan_trans
+#undef scope
+#define scope pPerl->Perl_scope
+#undef screaminstr
+#define screaminstr pPerl->Perl_screaminstr
+#undef setdefout
+#define setdefout pPerl->Perl_setdefout
+#undef setenv_getix
+#define setenv_getix pPerl->Perl_setenv_getix
+#undef share_hek
+#define share_hek pPerl->Perl_share_hek
+#undef sharepvn
+#define sharepvn pPerl->Perl_sharepvn
+#undef sighandler
+#define sighandler pPerl->Perl_sighandler
+#undef skipspace
+#define skipspace pPerl->Perl_skipspace
+#undef stack_grow
+#define stack_grow pPerl->Perl_stack_grow
+#undef start_subparse
+#define start_subparse pPerl->Perl_start_subparse
+#undef sub_crush_depth
+#define sub_crush_depth pPerl->Perl_sub_crush_depth
+#undef sublex_done
+#define sublex_done pPerl->Perl_sublex_done
+#undef sublex_start
+#define sublex_start pPerl->Perl_sublex_start
+#undef sv_2bool
+#define sv_2bool pPerl->Perl_sv_2bool
+#undef sv_2cv
+#define sv_2cv pPerl->Perl_sv_2cv
+#undef sv_2io
+#define sv_2io pPerl->Perl_sv_2io
+#undef sv_2iv
+#define sv_2iv pPerl->Perl_sv_2iv
+#undef sv_2mortal
+#define sv_2mortal pPerl->Perl_sv_2mortal
+#undef sv_2nv
+#define sv_2nv pPerl->Perl_sv_2nv
+#undef sv_2pv
+#define sv_2pv pPerl->Perl_sv_2pv
+#undef sv_2uv
+#define sv_2uv pPerl->Perl_sv_2uv
+#undef sv_add_arena
+#define sv_add_arena pPerl->Perl_sv_add_arena
+#undef sv_backoff
+#define sv_backoff pPerl->Perl_sv_backoff
+#undef sv_bless
+#define sv_bless pPerl->Perl_sv_bless
+#undef sv_catpv
+#define sv_catpv pPerl->Perl_sv_catpv
+#undef sv_catpvf
+#define sv_catpvf pPerl->Perl_sv_catpvf
+#undef sv_catpvn
+#define sv_catpvn pPerl->Perl_sv_catpvn
+#undef sv_catsv
+#define sv_catsv pPerl->Perl_sv_catsv
+#undef sv_chop
+#define sv_chop pPerl->Perl_sv_chop
+#undef sv_clean_all
+#define sv_clean_all pPerl->Perl_sv_clean_all
+#undef sv_clean_objs
+#define sv_clean_objs pPerl->Perl_sv_clean_objs
+#undef sv_clear
+#define sv_clear pPerl->Perl_sv_clear
+#undef sv_cmp
+#define sv_cmp pPerl->Perl_sv_cmp
+#undef sv_cmp_locale
+#define sv_cmp_locale pPerl->Perl_sv_cmp_locale
+#undef sv_collxfrm
+#define sv_collxfrm pPerl->Perl_sv_collxfrm
+#undef sv_compile_2op
+#define sv_compile_2op pPerl->Perl_sv_compile_2op
+#undef sv_dec
+#define sv_dec pPerl->Perl_sv_dec
+#undef sv_derived_from
+#define sv_derived_from pPerl->Perl_sv_derived_from
+#undef sv_dump
+#define sv_dump pPerl->Perl_sv_dump
+#undef sv_eq
+#define sv_eq pPerl->Perl_sv_eq
+#undef sv_free
+#define sv_free pPerl->Perl_sv_free
+#undef sv_free_arenas
+#define sv_free_arenas pPerl->Perl_sv_free_arenas
+#undef sv_gets
+#define sv_gets pPerl->Perl_sv_gets
+#undef sv_grow
+#define sv_grow pPerl->Perl_sv_grow
+#undef sv_inc
+#define sv_inc pPerl->Perl_sv_inc
+#undef sv_insert
+#define sv_insert pPerl->Perl_sv_insert
+#undef sv_isa
+#define sv_isa pPerl->Perl_sv_isa
+#undef sv_isobject
+#define sv_isobject pPerl->Perl_sv_isobject
+#undef sv_iv
+#define sv_iv pPerl->Perl_sv_iv
+#undef sv_len
+#define sv_len pPerl->Perl_sv_len
+#undef sv_magic
+#define sv_magic pPerl->Perl_sv_magic
+#undef sv_mortalcopy
+#define sv_mortalcopy pPerl->Perl_sv_mortalcopy
+#undef sv_newmortal
+#define sv_newmortal pPerl->Perl_sv_newmortal
+#undef sv_newref
+#define sv_newref pPerl->Perl_sv_newref
+#undef sv_nv
+#define sv_nv pPerl->Perl_sv_nv
+#undef sv_peek
+#define sv_peek pPerl->Perl_sv_peek
+#undef sv_pvn
+#define sv_pvn pPerl->Perl_sv_pvn
+#undef sv_pvn_force
+#define sv_pvn_force pPerl->Perl_sv_pvn_force
+#undef sv_reftype
+#define sv_reftype pPerl->Perl_sv_reftype
+#undef sv_replace
+#define sv_replace pPerl->Perl_sv_replace
+#undef sv_report_used
+#define sv_report_used pPerl->Perl_sv_report_used
+#undef sv_reset
+#define sv_reset pPerl->Perl_sv_reset
+#undef sv_setiv
+#define sv_setiv pPerl->Perl_sv_setiv
+#undef sv_setnv
+#define sv_setnv pPerl->Perl_sv_setnv
+#undef sv_setpv
+#define sv_setpv pPerl->Perl_sv_setpv
+#undef sv_setpvf
+#define sv_setpvf pPerl->Perl_sv_setpvf
+#undef sv_setpviv
+#define sv_setpviv pPerl->Perl_sv_setpviv
+#undef sv_setpvn
+#define sv_setpvn pPerl->Perl_sv_setpvn
+#undef sv_setref_iv
+#define sv_setref_iv pPerl->Perl_sv_setref_iv
+#undef sv_setref_nv
+#define sv_setref_nv pPerl->Perl_sv_setref_nv
+#undef sv_setref_pv
+#define sv_setref_pv pPerl->Perl_sv_setref_pv
+#undef sv_setref_pvn
+#define sv_setref_pvn pPerl->Perl_sv_setref_pvn
+#undef sv_setsv
+#define sv_setsv pPerl->Perl_sv_setsv
+#undef sv_setuv
+#define sv_setuv pPerl->Perl_sv_setuv
+#undef sv_taint
+#define sv_taint pPerl->Perl_sv_taint
+#undef sv_tainted
+#define sv_tainted pPerl->Perl_sv_tainted
+#undef sv_true
+#define sv_true pPerl->Perl_sv_true
+#undef sv_unmagic
+#define sv_unmagic pPerl->Perl_sv_unmagic
+#undef sv_unref
+#define sv_unref pPerl->Perl_sv_unref
+#undef sv_untaint
+#define sv_untaint pPerl->Perl_sv_untaint
+#undef sv_upgrade
+#define sv_upgrade pPerl->Perl_sv_upgrade
+#undef sv_usepvn
+#define sv_usepvn pPerl->Perl_sv_usepvn
+#undef sv_uv
+#define sv_uv pPerl->Perl_sv_uv
+#undef sv_vcatpvfn
+#define sv_vcatpvfn pPerl->Perl_sv_vcatpvfn
+#undef sv_vsetpvfn
+#define sv_vsetpvfn pPerl->Perl_sv_vsetpvfn
+#undef taint_env
+#define taint_env pPerl->Perl_taint_env
+#undef taint_not
+#define taint_not pPerl->Perl_taint_not
+#undef taint_proper
+#define taint_proper pPerl->Perl_taint_proper
+#undef too_few_arguments
+#define too_few_arguments pPerl->Perl_too_few_arguments
+#undef too_many_arguments
+#define too_many_arguments pPerl->Perl_too_many_arguments
+#undef unlnk
+#define unlnk pPerl->Perl_unlnk
+#undef unlock_condpair
+#define unlock_condpair pPerl->Perl_unlock_condpair
+#undef unshare_hek
+#define unshare_hek pPerl->Perl_unshare_hek
+#undef unsharepvn
+#define unsharepvn pPerl->Perl_unsharepvn
+#undef utilize
+#define utilize pPerl->Perl_utilize
+#undef vivify_defelem
+#define vivify_defelem pPerl->Perl_vivify_defelem
+#undef vivify_ref
+#define vivify_ref pPerl->Perl_vivify_ref
+#undef wait4pid
+#define wait4pid pPerl->Perl_wait4pid
+#undef warn
+#define warn pPerl->Perl_warn
+#undef watch
+#define watch pPerl->Perl_watch
+#undef whichsig
+#define whichsig pPerl->Perl_whichsig
+#undef yyerror
+#define yyerror pPerl->Perl_yyerror
+#undef yylex
+#define yylex pPerl->Perl_yylex
+#undef yyparse
+#define yyparse pPerl->Perl_yyparse
+#undef yywarn
+#define yywarn pPerl->Perl_yywarn
+
+
+#undef PL_piMem
+#define PL_piMem (pPerl->PL_piMem)
+#undef PL_piENV
+#define PL_piENV (pPerl->PL_piENV)
+#undef PL_piStdIO
+#define PL_piStdIO (pPerl->PL_piStdIO)
+#undef PL_piLIO
+#define PL_piLIO (pPerl->PL_piLIO)
+#undef PL_piDir
+#define PL_piDir (pPerl->PL_piDir)
+#undef PL_piSock
+#define PL_piSock (pPerl->PL_piSock)
+#undef PL_piProc
+#define PL_piProc (pPerl->PL_piProc)
+
+#ifndef NO_XSLOCKS
+#undef closedir
+#undef opendir
+#undef stdin
+#undef stdout
+#undef stderr
+#undef feof
+#undef ferror
+#undef fgetpos
+#undef ioctl
+#undef getlogin
+#undef setjmp
+#undef getc
+#undef ungetc
+#undef fileno
+
+#define mkdir PerlDir_mkdir
+#define chdir PerlDir_chdir
+#define rmdir PerlDir_rmdir
+#define closedir PerlDir_close
+#define opendir PerlDir_open
+#define readdir PerlDir_read
+#define rewinddir PerlDir_rewind
+#define seekdir PerlDir_seek
+#define telldir PerlDir_tell
+#define putenv PerlEnv_putenv
+#define getenv PerlEnv_getenv
+#define stdin PerlIO_stdin()
+#define stdout PerlIO_stdout()
+#define stderr PerlIO_stderr()
+#define fopen PerlIO_open
+#define fclose PerlIO_close
+#define feof PerlIO_eof
+#define ferror PerlIO_error
+#define fclearerr PerlIO_clearerr
+#define getc PerlIO_getc
+#define fputc(c, f) PerlIO_putc(f,c)
+#define fputs(s, f) PerlIO_puts(f,s)
+#define fflush PerlIO_flush
+#define ungetc(c, f) PerlIO_ungetc((f),(c))
+#define fileno PerlIO_fileno
+#define fdopen PerlIO_fdopen
+#define freopen PerlIO_reopen
+#define fread(b,s,c,f) PerlIO_read((f),(b),(s*c))
+#define fwrite(b,s,c,f) PerlIO_write((f),(b),(s*c))
+#define setbuf PerlIO_setbuf
+#define setvbuf PerlIO_setvbuf
+#define setlinebuf PerlIO_setlinebuf
+#define stdoutf PerlIO_stdoutf
+#define vfprintf PerlIO_vprintf
+#define ftell PerlIO_tell
+#define fseek PerlIO_seek
+#define fgetpos PerlIO_getpos
+#define fsetpos PerlIO_setpos
+#define frewind PerlIO_rewind
+#define tmpfile PerlIO_tmpfile
+#define access PerlLIO_access
+#define chmod PerlLIO_chmod
+#define chsize PerlLIO_chsize
+#define close PerlLIO_close
+#define dup PerlLIO_dup
+#define dup2 PerlLIO_dup2
+#define flock PerlLIO_flock
+#define fstat PerlLIO_fstat
+#define ioctl PerlLIO_ioctl
+#define isatty PerlLIO_isatty
+#define lseek PerlLIO_lseek
+#define lstat PerlLIO_lstat
+#define mktemp PerlLIO_mktemp
+#define open PerlLIO_open
+#define read PerlLIO_read
+#define rename PerlLIO_rename
+#define setmode PerlLIO_setmode
+#define stat PerlLIO_stat
+#define tmpnam PerlLIO_tmpnam
+#define umask PerlLIO_umask
+#define unlink PerlLIO_unlink
+#define utime PerlLIO_utime
+#define write PerlLIO_write
+#define malloc PerlMem_malloc
+#define realloc PerlMem_realloc
+#define free PerlMem_free
+#define abort PerlProc_abort
+#define exit PerlProc_exit
+#define _exit PerlProc__exit
+#define execl PerlProc_execl
+#define execv PerlProc_execv
+#define execvp PerlProc_execvp
+#define getuid PerlProc_getuid
+#define geteuid PerlProc_geteuid
+#define getgid PerlProc_getgid
+#define getegid PerlProc_getegid
+#define getlogin PerlProc_getlogin
+#define kill PerlProc_kill
+#define killpg PerlProc_killpg
+#define pause PerlProc_pause
+#define popen PerlProc_popen
+#define pclose PerlProc_pclose
+#define pipe PerlProc_pipe
+#define setuid PerlProc_setuid
+#define setgid PerlProc_setgid
+#define sleep PerlProc_sleep
+#define times PerlProc_times
+#define wait PerlProc_wait
+#define setjmp PerlProc_setjmp
+#define longjmp PerlProc_longjmp
+#define signal PerlProc_signal
+#define htonl PerlSock_htonl
+#define htons PerlSock_htons
+#define ntohs PerlSock_ntohl
+#define ntohl PerlSock_ntohs
+#define accept PerlSock_accept
+#define bind PerlSock_bind
+#define connect PerlSock_connect
+#define endhostent PerlSock_endhostent
+#define endnetent PerlSock_endnetent
+#define endprotoent PerlSock_endprotoent
+#define endservent PerlSock_endservent
+#define gethostbyaddr PerlSock_gethostbyaddr
+#define gethostbyname PerlSock_gethostbyname
+#define gethostent PerlSock_gethostent
+#define gethostname PerlSock_gethostname
+#define getnetbyaddr PerlSock_getnetbyaddr
+#define getnetbyname PerlSock_getnetbyname
+#define getnetent PerlSock_getnetent
+#define getpeername PerlSock_getpeername
+#define getprotobyname PerlSock_getprotobyname
+#define getprotobynumber PerlSock_getprotobynumber
+#define getprotoent PerlSock_getprotoent
+#define getservbyname PerlSock_getservbyname
+#define getservbyport PerlSock_getservbyport
+#define getservent PerlSock_getservent
+#define getsockname PerlSock_getsockname
+#define getsockopt PerlSock_getsockopt
+#define inet_addr PerlSock_inet_addr
+#define inet_ntoa PerlSock_inet_ntoa
+#define listen PerlSock_listen
+#define recvfrom PerlSock_recvfrom
+#define select PerlSock_select
+#define send PerlSock_send
+#define sendto PerlSock_sendto
+#define sethostent PerlSock_sethostent
+#define setnetent PerlSock_setnetent
+#define setprotoent PerlSock_setprotoent
+#define setservent PerlSock_setservent
+#define setsockopt PerlSock_setsockopt
+#define shutdown PerlSock_shutdown
+#define socket PerlSock_socket
+#define socketpair PerlSock_socketpair
+#endif /* NO_XSLOCKS */
+
+#undef PERL_OBJECT_THIS
+#define PERL_OBJECT_THIS pPerl
+#undef PERL_OBJECT_THIS_
+#define PERL_OBJECT_THIS_ pPerl,
+
+#undef SAVEDESTRUCTOR
+#define SAVEDESTRUCTOR(f,p) \
+ pPerl->Perl_save_destructor((FUNC_NAME_TO_PTR(f)),(p))
+
+#ifdef WIN32
+
+#ifndef WIN32IO_IS_STDIO
+#undef errno
+#define errno ErrorNo()
+#endif
+
+#undef ErrorNo
+#define ErrorNo pPerl->ErrorNo
+#undef NtCrypt
+#define NtCrypt pPerl->NtCrypt
+#undef NtGetLib
+#define NtGetLib pPerl->NtGetLib
+#undef NtGetArchLib
+#define NtGetArchLib pPerl->NtGetArchLib
+#undef NtGetSiteLib
+#define NtGetSiteLib pPerl->NtGetSiteLib
+#undef NtGetBin
+#define NtGetBin pPerl->NtGetBin
+#undef NtGetDebugScriptStr
+#define NtGetDebugScriptStr pPerl->NtGetDebugScriptStr
+#endif /* WIN32 */
+
+#endif /* __objXSUB_h__ */
+
diff --git a/contrib/perl5/objpp.h b/contrib/perl5/objpp.h
new file mode 100644
index 000000000000..e0c2f24ff12b
--- /dev/null
+++ b/contrib/perl5/objpp.h
@@ -0,0 +1,1463 @@
+#ifndef __Objpp_h__
+#define __Objpp_h__
+
+#undef amagic_call
+#define amagic_call CPerlObj::Perl_amagic_call
+#undef Gv_AMupdate
+#define Gv_AMupdate CPerlObj::Perl_Gv_AMupdate
+#undef add_data
+#define add_data CPerlObj::add_data
+#undef ao
+#define ao CPerlObj::ao
+#undef append_elem
+#define append_elem CPerlObj::Perl_append_elem
+#undef append_list
+#define append_list CPerlObj::Perl_append_list
+#undef apply
+#define apply CPerlObj::Perl_apply
+#undef asIV
+#define asIV CPerlObj::asIV
+#undef asUV
+#define asUV CPerlObj::asUV
+#undef assertref
+#define assertref CPerlObj::Perl_assertref
+#undef av_clear
+#define av_clear CPerlObj::Perl_av_clear
+#undef av_extend
+#define av_extend CPerlObj::Perl_av_extend
+#undef av_fake
+#define av_fake CPerlObj::Perl_av_fake
+#undef av_fetch
+#define av_fetch CPerlObj::Perl_av_fetch
+#undef av_fill
+#define av_fill CPerlObj::Perl_av_fill
+#undef av_len
+#define av_len CPerlObj::Perl_av_len
+#undef av_make
+#define av_make CPerlObj::Perl_av_make
+#undef av_pop
+#define av_pop CPerlObj::Perl_av_pop
+#undef av_push
+#define av_push CPerlObj::Perl_av_push
+#undef av_shift
+#define av_shift CPerlObj::Perl_av_shift
+#undef av_reify
+#define av_reify CPerlObj::Perl_av_reify
+#undef av_store
+#define av_store CPerlObj::Perl_av_store
+#undef av_undef
+#define av_undef CPerlObj::Perl_av_undef
+#undef av_unshift
+#define av_unshift CPerlObj::Perl_av_unshift
+#undef avhv_keys
+#define avhv_keys CPerlObj::Perl_avhv_keys
+#undef avhv_fetch_ent
+#define avhv_fetch_ent CPerlObj::Perl_avhv_fetch_ent
+#undef avhv_exists_ent
+#define avhv_exists_ent CPerlObj::Perl_avhv_exists_ent
+#undef avhv_index_sv
+#define avhv_index_sv CPerlObj::avhv_index_sv
+#undef avhv_iternext
+#define avhv_iternext CPerlObj::Perl_avhv_iternext
+#undef avhv_iterval
+#define avhv_iterval CPerlObj::Perl_avhv_iterval
+#undef bad_type
+#define bad_type CPerlObj::bad_type
+#undef bind_match
+#define bind_match CPerlObj::Perl_bind_match
+#undef block_end
+#define block_end CPerlObj::Perl_block_end
+#undef block_gimme
+#define block_gimme CPerlObj::Perl_block_gimme
+#undef block_start
+#define block_start CPerlObj::Perl_block_start
+#undef bset_obj_store
+#define bset_obj_store CPerlObj::Perl_bset_obj_store
+#undef byterun
+#define byterun CPerlObj::Perl_byterun
+#undef call_list
+#define call_list CPerlObj::Perl_call_list
+#undef cando
+#define cando CPerlObj::Perl_cando
+#undef cast_ulong
+#define cast_ulong CPerlObj::cast_ulong
+#undef checkcomma
+#define checkcomma CPerlObj::Perl_checkcomma
+#undef check_uni
+#define check_uni CPerlObj::Perl_check_uni
+#undef ck_anoncode
+#define ck_anoncode CPerlObj::Perl_ck_anoncode
+#undef ck_bitop
+#define ck_bitop CPerlObj::Perl_ck_bitop
+#undef ck_concat
+#define ck_concat CPerlObj::Perl_ck_concat
+#undef ck_delete
+#define ck_delete CPerlObj::Perl_ck_delete
+#undef ck_eof
+#define ck_eof CPerlObj::Perl_ck_eof
+#undef ck_eval
+#define ck_eval CPerlObj::Perl_ck_eval
+#undef ck_exec
+#define ck_exec CPerlObj::Perl_ck_exec
+#undef ck_exists
+#define ck_exists CPerlObj::Perl_ck_exists
+#undef ck_formline
+#define ck_formline CPerlObj::Perl_ck_formline
+#undef ck_ftst
+#define ck_ftst CPerlObj::Perl_ck_ftst
+#undef ck_fun
+#define ck_fun CPerlObj::Perl_ck_fun
+#undef ck_fun_locale
+#define ck_fun_locale CPerlObj::Perl_ck_fun_locale
+#undef ck_glob
+#define ck_glob CPerlObj::Perl_ck_glob
+#undef ck_grep
+#define ck_grep CPerlObj::Perl_ck_grep
+#undef ck_gvconst
+#define ck_gvconst CPerlObj::Perl_ck_gvconst
+#undef ck_index
+#define ck_index CPerlObj::Perl_ck_index
+#undef ck_lengthconst
+#define ck_lengthconst CPerlObj::Perl_ck_lengthconst
+#undef ck_lfun
+#define ck_lfun CPerlObj::Perl_ck_lfun
+#undef ck_listiob
+#define ck_listiob CPerlObj::Perl_ck_listiob
+#undef ck_match
+#define ck_match CPerlObj::Perl_ck_match
+#undef ck_null
+#define ck_null CPerlObj::Perl_ck_null
+#undef ck_repeat
+#define ck_repeat CPerlObj::Perl_ck_repeat
+#undef ck_require
+#define ck_require CPerlObj::Perl_ck_require
+#undef ck_retarget
+#define ck_retarget CPerlObj::Perl_ck_retarget
+#undef ck_rfun
+#define ck_rfun CPerlObj::Perl_ck_rfun
+#undef ck_rvconst
+#define ck_rvconst CPerlObj::Perl_ck_rvconst
+#undef ck_scmp
+#define ck_scmp CPerlObj::Perl_ck_scmp
+#undef ck_select
+#define ck_select CPerlObj::Perl_ck_select
+#undef ck_shift
+#define ck_shift CPerlObj::Perl_ck_shift
+#undef ck_sort
+#define ck_sort CPerlObj::Perl_ck_sort
+#undef ck_spair
+#define ck_spair CPerlObj::Perl_ck_spair
+#undef ck_split
+#define ck_split CPerlObj::Perl_ck_split
+#undef ck_subr
+#define ck_subr CPerlObj::Perl_ck_subr
+#undef ck_svconst
+#define ck_svconst CPerlObj::Perl_ck_svconst
+#undef ck_trunc
+#define ck_trunc CPerlObj::Perl_ck_trunc
+#undef convert
+#define convert CPerlObj::Perl_convert
+#undef cpytill
+#define cpytill CPerlObj::Perl_cpytill
+#undef croak
+#define croak CPerlObj::Perl_croak
+#undef cv_ckproto
+#define cv_ckproto CPerlObj::Perl_cv_ckproto
+#undef cv_clone
+#define cv_clone CPerlObj::Perl_cv_clone
+#undef cv_clone2
+#define cv_clone2 CPerlObj::cv_clone2
+#undef cv_const_sv
+#define cv_const_sv CPerlObj::Perl_cv_const_sv
+#undef cv_undef
+#define cv_undef CPerlObj::Perl_cv_undef
+#undef cx_dump
+#define cx_dump CPerlObj::Perl_cx_dump
+#undef cxinc
+#define cxinc CPerlObj::Perl_cxinc
+#undef deb
+#define deb CPerlObj::Perl_deb
+#undef deb_growlevel
+#define deb_growlevel CPerlObj::Perl_deb_growlevel
+#undef debop
+#define debop CPerlObj::Perl_debop
+#undef debstackptrs
+#define debstackptrs CPerlObj::Perl_debstackptrs
+#undef debprof
+#define debprof CPerlObj::debprof
+#undef debprofdump
+#define debprofdump CPerlObj::Perl_debprofdump
+#undef debstack
+#define debstack CPerlObj::Perl_debstack
+#undef del_sv
+#define del_sv CPerlObj::del_sv
+#undef del_xiv
+#define del_xiv CPerlObj::del_xiv
+#undef del_xnv
+#define del_xnv CPerlObj::del_xnv
+#undef del_xpv
+#define del_xpv CPerlObj::del_xpv
+#undef del_xrv
+#define del_xrv CPerlObj::del_xrv
+#undef delimcpy
+#define delimcpy CPerlObj::Perl_delimcpy
+#undef depcom
+#define depcom CPerlObj::depcom
+#undef deprecate
+#define deprecate CPerlObj::Perl_deprecate
+#undef die
+#define die CPerlObj::Perl_die
+#undef die_where
+#define die_where CPerlObj::Perl_die_where
+#undef div128
+#define div128 CPerlObj::div128
+#undef doencodes
+#define doencodes CPerlObj::doencodes
+#undef doeval
+#define doeval CPerlObj::doeval
+#undef doform
+#define doform CPerlObj::doform
+#undef dofindlabel
+#define dofindlabel CPerlObj::Perl_dofindlabel
+#undef doparseform
+#define doparseform CPerlObj::doparseform
+#undef dopoptoeval
+#define dopoptoeval CPerlObj::Perl_dopoptoeval
+#undef dopoptolabel
+#define dopoptolabel CPerlObj::dopoptolabel
+#undef dopoptoloop
+#define dopoptoloop CPerlObj::dopoptoloop
+#undef dopoptosub
+#define dopoptosub CPerlObj::dopoptosub
+#undef dopoptosub_at
+#define dopoptosub_at CPerlObj::dopoptosub_at
+#undef dounwind
+#define dounwind CPerlObj::Perl_dounwind
+#undef do_aexec
+#define do_aexec CPerlObj::Perl_do_aexec
+#undef do_aspawn
+#define do_aspawn CPerlObj::do_aspawn
+#undef do_binmode
+#define do_binmode CPerlObj::Perl_do_binmode
+#undef do_chop
+#define do_chop CPerlObj::Perl_do_chop
+#undef do_close
+#define do_close CPerlObj::Perl_do_close
+#undef do_eof
+#define do_eof CPerlObj::Perl_do_eof
+#undef do_exec
+#define do_exec CPerlObj::Perl_do_exec
+#undef do_execfree
+#define do_execfree CPerlObj::Perl_do_execfree
+#undef do_ipcctl
+#define do_ipcctl CPerlObj::Perl_do_ipcctl
+#undef do_ipcget
+#define do_ipcget CPerlObj::Perl_do_ipcget
+#undef do_join
+#define do_join CPerlObj::Perl_do_join
+#undef do_kv
+#define do_kv CPerlObj::Perl_do_kv
+#undef do_msgrcv
+#define do_msgrcv CPerlObj::Perl_do_msgrcv
+#undef do_msgsnd
+#define do_msgsnd CPerlObj::Perl_do_msgsnd
+#undef do_open
+#define do_open CPerlObj::Perl_do_open
+#undef do_pipe
+#define do_pipe CPerlObj::Perl_do_pipe
+#undef do_print
+#define do_print CPerlObj::Perl_do_print
+#undef do_readline
+#define do_readline CPerlObj::Perl_do_readline
+#undef do_chomp
+#define do_chomp CPerlObj::Perl_do_chomp
+#undef do_seek
+#define do_seek CPerlObj::Perl_do_seek
+#undef do_semop
+#define do_semop CPerlObj::Perl_do_semop
+#undef do_shmio
+#define do_shmio CPerlObj::Perl_do_shmio
+#undef do_sprintf
+#define do_sprintf CPerlObj::Perl_do_sprintf
+#undef do_sysseek
+#define do_sysseek CPerlObj::Perl_do_sysseek
+#undef do_tell
+#define do_tell CPerlObj::Perl_do_tell
+#undef do_trans
+#define do_trans CPerlObj::Perl_do_trans
+#undef do_vecset
+#define do_vecset CPerlObj::Perl_do_vecset
+#undef do_vop
+#define do_vop CPerlObj::Perl_do_vop
+#undef do_clean_all
+#define do_clean_all CPerlObj::do_clean_all
+#undef do_clean_named_objs
+#define do_clean_named_objs CPerlObj::do_clean_named_objs
+#undef do_clean_objs
+#define do_clean_objs CPerlObj::do_clean_objs
+#undef do_report_used
+#define do_report_used CPerlObj::do_report_used
+#undef docatch
+#define docatch CPerlObj::docatch
+#undef dowantarray
+#define dowantarray CPerlObj::Perl_dowantarray
+#undef dump
+#define dump CPerlObj::dump
+#undef dump_all
+#define dump_all CPerlObj::Perl_dump_all
+#undef dump_eval
+#define dump_eval CPerlObj::Perl_dump_eval
+#undef dump_fds
+#define dump_fds CPerlObj::Perl_dump_fds
+#undef dump_form
+#define dump_form CPerlObj::Perl_dump_form
+#undef dump_gv
+#define dump_gv CPerlObj::Perl_dump_gv
+#undef dump_mstats
+#define dump_mstats CPerlObj::Perl_dump_mstats
+#undef dump_op
+#define dump_op CPerlObj::Perl_dump_op
+#undef dump_pm
+#define dump_pm CPerlObj::Perl_dump_pm
+#undef dump_packsubs
+#define dump_packsubs CPerlObj::Perl_dump_packsubs
+#undef dump_sub
+#define dump_sub CPerlObj::Perl_dump_sub
+#undef dumpuntil
+#define dumpuntil CPerlObj::dumpuntil
+#undef fbm_compile
+#define fbm_compile CPerlObj::Perl_fbm_compile
+#undef fbm_instr
+#define fbm_instr CPerlObj::Perl_fbm_instr
+#undef filter_add
+#define filter_add CPerlObj::Perl_filter_add
+#undef filter_del
+#define filter_del CPerlObj::Perl_filter_del
+#undef filter_gets
+#define filter_gets CPerlObj::filter_gets
+#undef filter_read
+#define filter_read CPerlObj::Perl_filter_read
+#undef find_beginning
+#define find_beginning CPerlObj::find_beginning
+#undef find_script
+#define find_script CPerlObj::Perl_find_script
+#undef forbid_setid
+#define forbid_setid CPerlObj::forbid_setid
+#undef force_ident
+#define force_ident CPerlObj::Perl_force_ident
+#undef force_list
+#define force_list CPerlObj::Perl_force_list
+#undef force_next
+#define force_next CPerlObj::Perl_force_next
+#undef force_word
+#define force_word CPerlObj::Perl_force_word
+#undef force_version
+#define force_version CPerlObj::force_version
+#undef form
+#define form CPerlObj::Perl_form
+#undef fold_constants
+#define fold_constants CPerlObj::Perl_fold_constants
+#undef fprintf
+#define fprintf CPerlObj::fprintf
+#undef free_tmps
+#define free_tmps CPerlObj::Perl_free_tmps
+#undef gen_constant_list
+#define gen_constant_list CPerlObj::Perl_gen_constant_list
+#undef get_db_sub
+#define get_db_sub CPerlObj::get_db_sub
+#undef get_op_descs
+#define get_op_descs CPerlObj::Perl_get_op_descs
+#undef get_op_names
+#define get_op_names CPerlObj::Perl_get_op_names
+#undef get_no_modify
+#define get_no_modify CPerlObj::Perl_get_no_modify
+#undef get_opargs
+#define get_opargs CPerlObj::Perl_get_opargs
+#undef get_specialsv_list
+#define get_specialsv_list CPerlObj::Perl_get_specialsv_list
+#undef getlogin
+#define getlogin CPerlObj::getlogin
+#undef gp_free
+#define gp_free CPerlObj::Perl_gp_free
+#undef gp_ref
+#define gp_ref CPerlObj::Perl_gp_ref
+#undef gv_autoload4
+#define gv_autoload4 CPerlObj::Perl_gv_autoload4
+#undef gv_AVadd
+#define gv_AVadd CPerlObj::Perl_gv_AVadd
+#undef gv_HVadd
+#define gv_HVadd CPerlObj::Perl_gv_HVadd
+#undef gv_IOadd
+#define gv_IOadd CPerlObj::Perl_gv_IOadd
+#undef gv_check
+#define gv_check CPerlObj::Perl_gv_check
+#undef gv_efullname
+#define gv_efullname CPerlObj::Perl_gv_efullname
+#undef gv_efullname3
+#define gv_efullname3 CPerlObj::Perl_gv_efullname3
+#undef gv_ename
+#define gv_ename CPerlObj::gv_ename
+#undef gv_fetchfile
+#define gv_fetchfile CPerlObj::Perl_gv_fetchfile
+#undef gv_fetchmeth
+#define gv_fetchmeth CPerlObj::Perl_gv_fetchmeth
+#undef gv_fetchmethod
+#define gv_fetchmethod CPerlObj::Perl_gv_fetchmethod
+#undef gv_fetchmethod_autoload
+#define gv_fetchmethod_autoload CPerlObj::Perl_gv_fetchmethod_autoload
+#undef gv_fetchpv
+#define gv_fetchpv CPerlObj::Perl_gv_fetchpv
+#undef gv_fullname
+#define gv_fullname CPerlObj::Perl_gv_fullname
+#undef gv_fullname3
+#define gv_fullname3 CPerlObj::Perl_gv_fullname3
+#undef gv_init
+#define gv_init CPerlObj::Perl_gv_init
+#undef gv_init_sv
+#define gv_init_sv CPerlObj::gv_init_sv
+#undef gv_stashpv
+#define gv_stashpv CPerlObj::Perl_gv_stashpv
+#undef gv_stashpvn
+#define gv_stashpvn CPerlObj::Perl_gv_stashpvn
+#undef gv_stashsv
+#define gv_stashsv CPerlObj::Perl_gv_stashsv
+#undef he_delayfree
+#define he_delayfree CPerlObj::Perl_he_delayfree
+#undef he_free
+#define he_free CPerlObj::Perl_he_free
+#undef hfreeentries
+#define hfreeentries CPerlObj::hfreeentries
+#undef hoistmust
+#define hoistmust CPerlObj::Perl_hoistmust
+#undef hsplit
+#define hsplit CPerlObj::hsplit
+#undef hv_clear
+#define hv_clear CPerlObj::Perl_hv_clear
+#undef hv_delayfree_ent
+#define hv_delayfree_ent CPerlObj::Perl_hv_delayfree_ent
+#undef hv_delete
+#define hv_delete CPerlObj::Perl_hv_delete
+#undef hv_delete_ent
+#define hv_delete_ent CPerlObj::Perl_hv_delete_ent
+#undef hv_exists
+#define hv_exists CPerlObj::Perl_hv_exists
+#undef hv_exists_ent
+#define hv_exists_ent CPerlObj::Perl_hv_exists_ent
+#undef hv_free_ent
+#define hv_free_ent CPerlObj::Perl_hv_free_ent
+#undef hv_fetch
+#define hv_fetch CPerlObj::Perl_hv_fetch
+#undef hv_fetch_ent
+#define hv_fetch_ent CPerlObj::Perl_hv_fetch_ent
+#undef hv_iterinit
+#define hv_iterinit CPerlObj::Perl_hv_iterinit
+#undef hv_iterkey
+#define hv_iterkey CPerlObj::Perl_hv_iterkey
+#undef hv_iterkeysv
+#define hv_iterkeysv CPerlObj::Perl_hv_iterkeysv
+#undef hv_iternext
+#define hv_iternext CPerlObj::Perl_hv_iternext
+#undef hv_iternextsv
+#define hv_iternextsv CPerlObj::Perl_hv_iternextsv
+#undef hv_iterval
+#define hv_iterval CPerlObj::Perl_hv_iterval
+#undef hv_ksplit
+#define hv_ksplit CPerlObj::Perl_hv_ksplit
+#undef hv_magic
+#define hv_magic CPerlObj::Perl_hv_magic
+#undef hv_store
+#define hv_store CPerlObj::Perl_hv_store
+#undef hv_store_ent
+#define hv_store_ent CPerlObj::Perl_hv_store_ent
+#undef hv_undef
+#define hv_undef CPerlObj::Perl_hv_undef
+#undef ibcmp
+#define ibcmp CPerlObj::Perl_ibcmp
+#undef ibcmp_locale
+#define ibcmp_locale CPerlObj::Perl_ibcmp_locale
+#undef incpush
+#define incpush CPerlObj::incpush
+#undef incline
+#define incline CPerlObj::incline
+#undef incl_perldb
+#define incl_perldb CPerlObj::incl_perldb
+#undef ingroup
+#define ingroup CPerlObj::Perl_ingroup
+#undef init_debugger
+#define init_debugger CPerlObj::init_debugger
+#undef init_ids
+#define init_ids CPerlObj::init_ids
+#undef init_interp
+#define init_interp CPerlObj::init_interp
+#undef init_main_thread
+#define init_main_thread CPerlObj::init_main_thread
+#undef init_main_stash
+#define init_main_stash CPerlObj::init_main_stash
+#undef init_lexer
+#define init_lexer CPerlObj::init_lexer
+#undef init_perllib
+#define init_perllib CPerlObj::init_perllib
+#undef init_predump_symbols
+#define init_predump_symbols CPerlObj::init_predump_symbols
+#undef init_postdump_symbols
+#define init_postdump_symbols CPerlObj::init_postdump_symbols
+#undef init_stacks
+#define init_stacks CPerlObj::Perl_init_stacks
+#undef intro_my
+#define intro_my CPerlObj::Perl_intro_my
+#undef nuke_stacks
+#define nuke_stacks CPerlObj::nuke_stacks
+#undef instr
+#define instr CPerlObj::Perl_instr
+#undef intuit_method
+#define intuit_method CPerlObj::intuit_method
+#undef intuit_more
+#define intuit_more CPerlObj::Perl_intuit_more
+#undef invert
+#define invert CPerlObj::Perl_invert
+#undef io_close
+#define io_close CPerlObj::Perl_io_close
+#undef is_an_int
+#define is_an_int CPerlObj::is_an_int
+#undef isa_lookup
+#define isa_lookup CPerlObj::isa_lookup
+#undef jmaybe
+#define jmaybe CPerlObj::Perl_jmaybe
+#undef keyword
+#define keyword CPerlObj::Perl_keyword
+#undef leave_scope
+#define leave_scope CPerlObj::Perl_leave_scope
+#undef lex_end
+#define lex_end CPerlObj::Perl_lex_end
+#undef lex_start
+#define lex_start CPerlObj::Perl_lex_start
+#undef linklist
+#define linklist CPerlObj::Perl_linklist
+#undef list
+#define list CPerlObj::Perl_list
+#undef list_assignment
+#define list_assignment CPerlObj::list_assignment
+#undef listkids
+#define listkids CPerlObj::Perl_listkids
+#undef lop
+#define lop CPerlObj::lop
+#undef localize
+#define localize CPerlObj::Perl_localize
+#undef looks_like_number
+#define looks_like_number CPerlObj::Perl_looks_like_number
+#undef magic_clearenv
+#define magic_clearenv CPerlObj::Perl_magic_clearenv
+#undef magic_clear_all_env
+#define magic_clear_all_env CPerlObj::Perl_magic_clear_all_env
+#undef magic_clearpack
+#define magic_clearpack CPerlObj::Perl_magic_clearpack
+#undef magic_clearsig
+#define magic_clearsig CPerlObj::Perl_magic_clearsig
+#undef magic_existspack
+#define magic_existspack CPerlObj::Perl_magic_existspack
+#undef magic_freeregexp
+#define magic_freeregexp CPerlObj::Perl_magic_freeregexp
+#undef magic_get
+#define magic_get CPerlObj::Perl_magic_get
+#undef magic_getarylen
+#define magic_getarylen CPerlObj::Perl_magic_getarylen
+#undef magic_getdefelem
+#define magic_getdefelem CPerlObj::Perl_magic_getdefelem
+#undef magic_getpack
+#define magic_getpack CPerlObj::Perl_magic_getpack
+#undef magic_getglob
+#define magic_getglob CPerlObj::Perl_magic_getglob
+#undef magic_getnkeys
+#define magic_getnkeys CPerlObj::Perl_magic_getnkeys
+#undef magic_getpos
+#define magic_getpos CPerlObj::Perl_magic_getpos
+#undef magic_getsig
+#define magic_getsig CPerlObj::Perl_magic_getsig
+#undef magic_getsubstr
+#define magic_getsubstr CPerlObj::Perl_magic_getsubstr
+#undef magic_gettaint
+#define magic_gettaint CPerlObj::Perl_magic_gettaint
+#undef magic_getuvar
+#define magic_getuvar CPerlObj::Perl_magic_getuvar
+#undef magic_getvec
+#define magic_getvec CPerlObj::Perl_magic_getvec
+#undef magic_len
+#define magic_len CPerlObj::Perl_magic_len
+#undef magic_methcall
+#define magic_methcall CPerlObj::magic_methcall
+#undef magic_methpack
+#define magic_methpack CPerlObj::magic_methpack
+#undef magic_nextpack
+#define magic_nextpack CPerlObj::Perl_magic_nextpack
+#undef magic_set
+#define magic_set CPerlObj::Perl_magic_set
+#undef magic_set_all_env
+#define magic_set_all_env CPerlObj::Perl_magic_set_all_env
+#undef magic_setamagic
+#define magic_setamagic CPerlObj::Perl_magic_setamagic
+#undef magic_setarylen
+#define magic_setarylen CPerlObj::Perl_magic_setarylen
+#undef magic_setbm
+#define magic_setbm CPerlObj::Perl_magic_setbm
+#undef magic_setcollxfrm
+#define magic_setcollxfrm CPerlObj::Perl_magic_setcollxfrm
+#undef magic_setdbline
+#define magic_setdbline CPerlObj::Perl_magic_setdbline
+#undef magic_setdefelem
+#define magic_setdefelem CPerlObj::Perl_magic_setdefelem
+#undef magic_setenv
+#define magic_setenv CPerlObj::Perl_magic_setenv
+#undef magic_setfm
+#define magic_setfm CPerlObj::Perl_magic_setfm
+#undef magic_setisa
+#define magic_setisa CPerlObj::Perl_magic_setisa
+#undef magic_setglob
+#define magic_setglob CPerlObj::Perl_magic_setglob
+#undef magic_setmglob
+#define magic_setmglob CPerlObj::Perl_magic_setmglob
+#undef magic_setnkeys
+#define magic_setnkeys CPerlObj::Perl_magic_setnkeys
+#undef magic_setpack
+#define magic_setpack CPerlObj::Perl_magic_setpack
+#undef magic_setpos
+#define magic_setpos CPerlObj::Perl_magic_setpos
+#undef magic_setsig
+#define magic_setsig CPerlObj::Perl_magic_setsig
+#undef magic_setsubstr
+#define magic_setsubstr CPerlObj::Perl_magic_setsubstr
+#undef magic_settaint
+#define magic_settaint CPerlObj::Perl_magic_settaint
+#undef magic_setuvar
+#define magic_setuvar CPerlObj::Perl_magic_setuvar
+#undef magic_setvec
+#define magic_setvec CPerlObj::Perl_magic_setvec
+#undef magic_sizepack
+#define magic_sizepack CPerlObj::Perl_magic_sizepack
+#undef magic_unchain
+#define magic_unchain CPerlObj::Perl_magic_unchain
+#undef magic_wipepack
+#define magic_wipepack CPerlObj::Perl_magic_wipepack
+#undef magicname
+#define magicname CPerlObj::Perl_magicname
+#undef malloced_size
+#define malloced_size CPerlObj::Perl_malloced_size
+#undef markstack_grow
+#define markstack_grow CPerlObj::Perl_markstack_grow
+#undef markstack_ptr
+#define markstack_ptr CPerlObj::Perl_markstack_ptr
+#undef mess
+#define mess CPerlObj::Perl_mess
+#undef mess_alloc
+#define mess_alloc CPerlObj::mess_alloc
+#undef mem_collxfrm
+#define mem_collxfrm CPerlObj::Perl_mem_collxfrm
+#undef mg_clear
+#define mg_clear CPerlObj::Perl_mg_clear
+#undef mg_copy
+#define mg_copy CPerlObj::Perl_mg_copy
+#undef mg_find
+#define mg_find CPerlObj::Perl_mg_find
+#undef mg_free
+#define mg_free CPerlObj::Perl_mg_free
+#undef mg_get
+#define mg_get CPerlObj::Perl_mg_get
+#undef mg_length
+#define mg_length CPerlObj::Perl_mg_length
+#undef mg_magical
+#define mg_magical CPerlObj::Perl_mg_magical
+#undef mg_set
+#define mg_set CPerlObj::Perl_mg_set
+#undef mg_size
+#define mg_size CPerlObj::Perl_mg_size
+#undef missingterm
+#define missingterm CPerlObj::missingterm
+#undef mod
+#define mod CPerlObj::Perl_mod
+#undef modkids
+#define modkids CPerlObj::Perl_modkids
+#undef moreswitches
+#define moreswitches CPerlObj::Perl_moreswitches
+#undef more_sv
+#define more_sv CPerlObj::more_sv
+#undef more_xiv
+#define more_xiv CPerlObj::more_xiv
+#undef more_xnv
+#define more_xnv CPerlObj::more_xnv
+#undef more_xpv
+#define more_xpv CPerlObj::more_xpv
+#undef more_xrv
+#define more_xrv CPerlObj::more_xrv
+#undef mstats
+#define mstats CPerlObj::mstats
+#undef mul128
+#define mul128 CPerlObj::mul128
+#undef my
+#define my CPerlObj::Perl_my
+#undef my_bcopy
+#define my_bcopy CPerlObj::Perl_my_bcopy
+#undef my_bzero
+#define my_bzero CPerlObj::Perl_my_bzero
+#undef my_exit
+#define my_exit CPerlObj::Perl_my_exit
+#undef my_exit_jump
+#define my_exit_jump CPerlObj::my_exit_jump
+#undef my_failure_exit
+#define my_failure_exit CPerlObj::Perl_my_failure_exit
+#undef my_lstat
+#define my_lstat CPerlObj::Perl_my_lstat
+#undef my_memcmp
+#define my_memcmp CPerlObj::Perl_my_memcmp
+#undef my_memset
+#define my_memset CPerlObj::Perl_my_memset
+#undef my_pclose
+#define my_pclose CPerlObj::Perl_my_pclose
+#undef my_popen
+#define my_popen CPerlObj::Perl_my_popen
+#undef my_safemalloc
+#define my_safemalloc CPerlObj::my_safemalloc
+#undef my_setenv
+#define my_setenv CPerlObj::Perl_my_setenv
+#undef my_stat
+#define my_stat CPerlObj::Perl_my_stat
+#undef my_swap
+#define my_swap CPerlObj::my_swap
+#undef my_htonl
+#define my_htonl CPerlObj::my_htonl
+#undef my_ntohl
+#define my_ntohl CPerlObj::my_ntohl
+#undef my_unexec
+#define my_unexec CPerlObj::Perl_my_unexec
+#undef newANONLIST
+#define newANONLIST CPerlObj::Perl_newANONLIST
+#undef newANONHASH
+#define newANONHASH CPerlObj::Perl_newANONHASH
+#undef newANONSUB
+#define newANONSUB CPerlObj::Perl_newANONSUB
+#undef newASSIGNOP
+#define newASSIGNOP CPerlObj::Perl_newASSIGNOP
+#undef newCONDOP
+#define newCONDOP CPerlObj::Perl_newCONDOP
+#undef newCONSTSUB
+#define newCONSTSUB CPerlObj::Perl_newCONSTSUB
+#undef newDEFSVOP
+#define newDEFSVOP CPerlObj::newDEFSVOP
+#undef newFORM
+#define newFORM CPerlObj::Perl_newFORM
+#undef newFOROP
+#define newFOROP CPerlObj::Perl_newFOROP
+#undef newLOGOP
+#define newLOGOP CPerlObj::Perl_newLOGOP
+#undef newLOOPEX
+#define newLOOPEX CPerlObj::Perl_newLOOPEX
+#undef newLOOPOP
+#define newLOOPOP CPerlObj::Perl_newLOOPOP
+#undef newMETHOD
+#define newMETHOD CPerlObj::Perl_newMETHOD
+#undef newNULLLIST
+#define newNULLLIST CPerlObj::Perl_newNULLLIST
+#undef newOP
+#define newOP CPerlObj::Perl_newOP
+#undef newPROG
+#define newPROG CPerlObj::Perl_newPROG
+#undef newRANGE
+#define newRANGE CPerlObj::Perl_newRANGE
+#undef newSLICEOP
+#define newSLICEOP CPerlObj::Perl_newSLICEOP
+#undef newSTATEOP
+#define newSTATEOP CPerlObj::Perl_newSTATEOP
+#undef newSUB
+#define newSUB CPerlObj::Perl_newSUB
+#undef newXS
+#define newXS CPerlObj::Perl_newXS
+#undef newXSUB
+#define newXSUB CPerlObj::Perl_newXSUB
+#undef newAV
+#define newAV CPerlObj::Perl_newAV
+#undef newAVREF
+#define newAVREF CPerlObj::Perl_newAVREF
+#undef newBINOP
+#define newBINOP CPerlObj::Perl_newBINOP
+#undef newCVREF
+#define newCVREF CPerlObj::Perl_newCVREF
+#undef newCVOP
+#define newCVOP CPerlObj::Perl_newCVOP
+#undef newGVOP
+#define newGVOP CPerlObj::Perl_newGVOP
+#undef newGVgen
+#define newGVgen CPerlObj::Perl_newGVgen
+#undef newGVREF
+#define newGVREF CPerlObj::Perl_newGVREF
+#undef newHVREF
+#define newHVREF CPerlObj::Perl_newHVREF
+#undef newHV
+#define newHV CPerlObj::Perl_newHV
+#undef newHVhv
+#define newHVhv CPerlObj::Perl_newHVhv
+#undef newIO
+#define newIO CPerlObj::Perl_newIO
+#undef newLISTOP
+#define newLISTOP CPerlObj::Perl_newLISTOP
+#undef newPMOP
+#define newPMOP CPerlObj::Perl_newPMOP
+#undef newPVOP
+#define newPVOP CPerlObj::Perl_newPVOP
+#undef newRV
+#define newRV CPerlObj::Perl_newRV
+#undef Perl_newRV_noinc
+#define Perl_newRV_noinc CPerlObj::Perl_newRV_noinc
+#undef newSV
+#define newSV CPerlObj::Perl_newSV
+#undef newSVREF
+#define newSVREF CPerlObj::Perl_newSVREF
+#undef newSVOP
+#define newSVOP CPerlObj::Perl_newSVOP
+#undef newSViv
+#define newSViv CPerlObj::Perl_newSViv
+#undef newSVnv
+#define newSVnv CPerlObj::Perl_newSVnv
+#undef newSVpv
+#define newSVpv CPerlObj::Perl_newSVpv
+#undef newSVpvf
+#define newSVpvf CPerlObj::Perl_newSVpvf
+#undef newSVpvn
+#define newSVpvn CPerlObj::Perl_newSVpvn
+#undef newSVrv
+#define newSVrv CPerlObj::Perl_newSVrv
+#undef newSVsv
+#define newSVsv CPerlObj::Perl_newSVsv
+#undef newUNOP
+#define newUNOP CPerlObj::Perl_newUNOP
+#undef newWHILEOP
+#define newWHILEOP CPerlObj::Perl_newWHILEOP
+#undef new_constant
+#define new_constant CPerlObj::new_constant
+#undef new_logop
+#define new_logop CPerlObj::new_logop
+#undef new_stackinfo
+#define new_stackinfo CPerlObj::Perl_new_stackinfo
+#undef new_sv
+#define new_sv CPerlObj::new_sv
+#undef new_xiv
+#define new_xiv CPerlObj::new_xiv
+#undef new_xnv
+#define new_xnv CPerlObj::new_xnv
+#undef new_xpv
+#define new_xpv CPerlObj::new_xpv
+#undef new_xrv
+#define new_xrv CPerlObj::new_xrv
+#undef nextargv
+#define nextargv CPerlObj::Perl_nextargv
+#undef nextchar
+#define nextchar CPerlObj::nextchar
+#undef ninstr
+#define ninstr CPerlObj::Perl_ninstr
+#undef not_a_number
+#define not_a_number CPerlObj::not_a_number
+#undef no_fh_allowed
+#define no_fh_allowed CPerlObj::Perl_no_fh_allowed
+#undef no_op
+#define no_op CPerlObj::Perl_no_op
+#undef null
+#define null CPerlObj::null
+#undef profiledata
+#define profiledata CPerlObj::Perl_profiledata
+#undef package
+#define package CPerlObj::Perl_package
+#undef pad_alloc
+#define pad_alloc CPerlObj::Perl_pad_alloc
+#undef pad_allocmy
+#define pad_allocmy CPerlObj::Perl_pad_allocmy
+#undef pad_findmy
+#define pad_findmy CPerlObj::Perl_pad_findmy
+#undef op_const_sv
+#define op_const_sv CPerlObj::Perl_op_const_sv
+#undef op_free
+#define op_free CPerlObj::Perl_op_free
+#undef oopsCV
+#define oopsCV CPerlObj::Perl_oopsCV
+#undef oopsAV
+#define oopsAV CPerlObj::Perl_oopsAV
+#undef oopsHV
+#define oopsHV CPerlObj::Perl_oopsHV
+#undef open_script
+#define open_script CPerlObj::open_script
+#undef pad_leavemy
+#define pad_leavemy CPerlObj::Perl_pad_leavemy
+#undef pad_sv
+#define pad_sv CPerlObj::Perl_pad_sv
+#undef pad_findlex
+#define pad_findlex CPerlObj::pad_findlex
+#undef pad_free
+#define pad_free CPerlObj::Perl_pad_free
+#undef pad_reset
+#define pad_reset CPerlObj::Perl_pad_reset
+#undef pad_swipe
+#define pad_swipe CPerlObj::Perl_pad_swipe
+#undef peep
+#define peep CPerlObj::Perl_peep
+#undef perl_call_argv
+#define perl_call_argv CPerlObj::perl_call_argv
+#undef perl_call_method
+#define perl_call_method CPerlObj::perl_call_method
+#undef perl_call_pv
+#define perl_call_pv CPerlObj::perl_call_pv
+#undef perl_call_sv
+#define perl_call_sv CPerlObj::perl_call_sv
+#undef perl_callargv
+#define perl_callargv CPerlObj::perl_callargv
+#undef perl_callpv
+#define perl_callpv CPerlObj::perl_callpv
+#undef perl_callsv
+#define perl_callsv CPerlObj::perl_callsv
+#undef perl_eval_pv
+#define perl_eval_pv CPerlObj::perl_eval_pv
+#undef perl_eval_sv
+#define perl_eval_sv CPerlObj::perl_eval_sv
+#undef perl_get_sv
+#define perl_get_sv CPerlObj::perl_get_sv
+#undef perl_get_av
+#define perl_get_av CPerlObj::perl_get_av
+#undef perl_get_hv
+#define perl_get_hv CPerlObj::perl_get_hv
+#undef perl_get_cv
+#define perl_get_cv CPerlObj::perl_get_cv
+#undef Perl_GetVars
+#define Perl_GetVars CPerlObj::Perl_GetVars
+#undef perl_init_fold
+#define perl_init_fold CPerlObj::perl_init_fold
+#undef perl_init_i18nl10n
+#define perl_init_i18nl10n CPerlObj::perl_init_i18nl10n
+#undef perl_init_i18nl14n
+#define perl_init_i18nl14n CPerlObj::perl_init_i18nl14n
+#undef perl_new_collate
+#define perl_new_collate CPerlObj::perl_new_collate
+#undef perl_new_ctype
+#define perl_new_ctype CPerlObj::perl_new_ctype
+#undef perl_new_numeric
+#define perl_new_numeric CPerlObj::perl_new_numeric
+#undef perl_set_numeric_standard
+#define perl_set_numeric_standard CPerlObj::perl_set_numeric_standard
+#undef perl_set_numeric_local
+#define perl_set_numeric_local CPerlObj::perl_set_numeric_local
+#undef perl_require_pv
+#define perl_require_pv CPerlObj::perl_require_pv
+#undef perl_thread
+#define perl_thread CPerlObj::perl_thread
+#undef pidgone
+#define pidgone CPerlObj::Perl_pidgone
+#undef pmflag
+#define pmflag CPerlObj::Perl_pmflag
+#undef pmruntime
+#define pmruntime CPerlObj::Perl_pmruntime
+#undef pmtrans
+#define pmtrans CPerlObj::Perl_pmtrans
+#undef pop_return
+#define pop_return CPerlObj::Perl_pop_return
+#undef pop_scope
+#define pop_scope CPerlObj::Perl_pop_scope
+#undef prepend_elem
+#define prepend_elem CPerlObj::Perl_prepend_elem
+#undef provide_ref
+#define provide_ref CPerlObj::Perl_provide_ref
+#undef push_return
+#define push_return CPerlObj::Perl_push_return
+#undef push_scope
+#define push_scope CPerlObj::Perl_push_scope
+#undef pregcomp
+#define pregcomp CPerlObj::Perl_pregcomp
+#undef qsortsv
+#define qsortsv CPerlObj::qsortsv
+#undef ref
+#define ref CPerlObj::Perl_ref
+#undef refkids
+#define refkids CPerlObj::Perl_refkids
+#undef regdump
+#define regdump CPerlObj::Perl_regdump
+#undef rsignal
+#define rsignal CPerlObj::Perl_rsignal
+#undef rsignal_restore
+#define rsignal_restore CPerlObj::Perl_rsignal_restore
+#undef rsignal_save
+#define rsignal_save CPerlObj::Perl_rsignal_save
+#undef rsignal_state
+#define rsignal_state CPerlObj::Perl_rsignal_state
+#undef pregexec
+#define pregexec CPerlObj::Perl_pregexec
+#undef pregfree
+#define pregfree CPerlObj::Perl_pregfree
+#undef re_croak2
+#define re_croak2 CPerlObj::re_croak2
+#undef refto
+#define refto CPerlObj::refto
+#undef reg
+#define reg CPerlObj::reg
+#undef reg_node
+#define reg_node CPerlObj::reg_node
+#undef reganode
+#define reganode CPerlObj::reganode
+#undef regatom
+#define regatom CPerlObj::regatom
+#undef regbranch
+#define regbranch CPerlObj::regbranch
+#undef regc
+#define regc CPerlObj::regc
+#undef regcurly
+#define regcurly CPerlObj::regcurly
+#undef regcppush
+#define regcppush CPerlObj::regcppush
+#undef regcppop
+#define regcppop CPerlObj::regcppop
+#undef regclass
+#define regclass CPerlObj::regclass
+#undef regexec_flags
+#define regexec_flags CPerlObj::Perl_regexec_flags
+#undef reginclass
+#define reginclass CPerlObj::reginclass
+#undef reginsert
+#define reginsert CPerlObj::reginsert
+#undef regmatch
+#define regmatch CPerlObj::regmatch
+#undef regnext
+#define regnext CPerlObj::Perl_regnext
+#undef regoptail
+#define regoptail CPerlObj::regoptail
+#undef regpiece
+#define regpiece CPerlObj::regpiece
+#undef regprop
+#define regprop CPerlObj::Perl_regprop
+#undef regrepeat
+#define regrepeat CPerlObj::regrepeat
+#undef regrepeat_hard
+#define regrepeat_hard CPerlObj::regrepeat_hard
+#undef regset
+#define regset CPerlObj::regset
+#undef regtail
+#define regtail CPerlObj::regtail
+#undef regtry
+#define regtry CPerlObj::regtry
+#undef regwhite
+#define regwhite CPerlObj::regwhite
+#undef repeatcpy
+#define repeatcpy CPerlObj::Perl_repeatcpy
+#undef restore_expect
+#define restore_expect CPerlObj::restore_expect
+#undef restore_lex_expect
+#define restore_lex_expect CPerlObj::restore_lex_expect
+#undef restore_magic
+#define restore_magic CPerlObj::restore_magic
+#undef restore_rsfp
+#define restore_rsfp CPerlObj::restore_rsfp
+#undef rninstr
+#define rninstr CPerlObj::Perl_rninstr
+#undef runops_standard
+#define runops_standard CPerlObj::Perl_runops_standard
+#undef runops_debug
+#define runops_debug CPerlObj::Perl_runops_debug
+#undef rxres_free
+#define rxres_free CPerlObj::Perl_rxres_free
+#undef rxres_restore
+#define rxres_restore CPerlObj::Perl_rxres_restore
+#undef rxres_save
+#define rxres_save CPerlObj::Perl_rxres_save
+#ifndef MYMALLOC
+#undef safefree
+#define safefree CPerlObj::Perl_safefree
+#undef safecalloc
+#define safecalloc CPerlObj::Perl_safecalloc
+#undef safemalloc
+#define safemalloc CPerlObj::Perl_safemalloc
+#undef saferealloc
+#define saferealloc CPerlObj::Perl_saferealloc
+#endif /* MYMALLOC */
+#undef same_dirent
+#define same_dirent CPerlObj::same_dirent
+#undef savepv
+#define savepv CPerlObj::Perl_savepv
+#undef savepvn
+#define savepvn CPerlObj::Perl_savepvn
+#undef savestack_grow
+#define savestack_grow CPerlObj::Perl_savestack_grow
+#undef save_aelem
+#define save_aelem CPerlObj::Perl_save_aelem
+#undef save_aptr
+#define save_aptr CPerlObj::Perl_save_aptr
+#undef save_ary
+#define save_ary CPerlObj::Perl_save_ary
+#undef save_clearsv
+#define save_clearsv CPerlObj::Perl_save_clearsv
+#undef save_delete
+#define save_delete CPerlObj::Perl_save_delete
+#undef save_destructor
+#define save_destructor CPerlObj::Perl_save_destructor
+#undef save_freesv
+#define save_freesv CPerlObj::Perl_save_freesv
+#undef save_freeop
+#define save_freeop CPerlObj::Perl_save_freeop
+#undef save_freepv
+#define save_freepv CPerlObj::Perl_save_freepv
+#undef save_gp
+#define save_gp CPerlObj::Perl_save_gp
+#undef save_hash
+#define save_hash CPerlObj::Perl_save_hash
+#undef save_hek
+#define save_hek CPerlObj::save_hek
+#undef save_helem
+#define save_helem CPerlObj::Perl_save_helem
+#undef save_hints
+#define save_hints CPerlObj::Perl_save_hints
+#undef save_hptr
+#define save_hptr CPerlObj::Perl_save_hptr
+#undef save_I16
+#define save_I16 CPerlObj::Perl_save_I16
+#undef save_I32
+#define save_I32 CPerlObj::Perl_save_I32
+#undef save_int
+#define save_int CPerlObj::Perl_save_int
+#undef save_item
+#define save_item CPerlObj::Perl_save_item
+#undef save_iv
+#define save_iv CPerlObj::Perl_save_iv
+#undef save_lines
+#define save_lines CPerlObj::save_lines
+#undef save_list
+#define save_list CPerlObj::Perl_save_list
+#undef save_long
+#define save_long CPerlObj::Perl_save_long
+#undef save_magic
+#define save_magic CPerlObj::save_magic
+#undef save_nogv
+#define save_nogv CPerlObj::Perl_save_nogv
+#undef save_op
+#define save_op CPerlObj::Perl_save_op
+#undef save_scalar
+#define save_scalar CPerlObj::Perl_save_scalar
+#undef save_scalar_at
+#define save_scalar_at CPerlObj::save_scalar_at
+#undef save_pptr
+#define save_pptr CPerlObj::Perl_save_pptr
+#undef save_sptr
+#define save_sptr CPerlObj::Perl_save_sptr
+#undef save_svref
+#define save_svref CPerlObj::Perl_save_svref
+#undef save_threadsv
+#define save_threadsv CPerlObj::Perl_save_threadsv
+#undef sawparens
+#define sawparens CPerlObj::Perl_sawparens
+#undef scalar
+#define scalar CPerlObj::Perl_scalar
+#undef scalarboolean
+#define scalarboolean CPerlObj::scalarboolean
+#undef scalarkids
+#define scalarkids CPerlObj::Perl_scalarkids
+#undef scalarseq
+#define scalarseq CPerlObj::Perl_scalarseq
+#undef scalarvoid
+#define scalarvoid CPerlObj::Perl_scalarvoid
+#undef scan_commit
+#define scan_commit CPerlObj::scan_commit
+#undef scan_const
+#define scan_const CPerlObj::Perl_scan_const
+#undef scan_formline
+#define scan_formline CPerlObj::Perl_scan_formline
+#undef scan_ident
+#define scan_ident CPerlObj::Perl_scan_ident
+#undef scan_inputsymbol
+#define scan_inputsymbol CPerlObj::Perl_scan_inputsymbol
+#undef scan_heredoc
+#define scan_heredoc CPerlObj::Perl_scan_heredoc
+#undef scan_hex
+#define scan_hex CPerlObj::Perl_scan_hex
+#undef scan_num
+#define scan_num CPerlObj::Perl_scan_num
+#undef scan_oct
+#define scan_oct CPerlObj::Perl_scan_oct
+#undef scan_pat
+#define scan_pat CPerlObj::Perl_scan_pat
+#undef scan_str
+#define scan_str CPerlObj::Perl_scan_str
+#undef scan_subst
+#define scan_subst CPerlObj::Perl_scan_subst
+#undef scan_trans
+#define scan_trans CPerlObj::Perl_scan_trans
+#undef scan_word
+#define scan_word CPerlObj::Perl_scan_word
+#undef scope
+#define scope CPerlObj::Perl_scope
+#undef screaminstr
+#define screaminstr CPerlObj::Perl_screaminstr
+#undef seed
+#define seed CPerlObj::seed
+#undef setdefout
+#define setdefout CPerlObj::Perl_setdefout
+#undef setenv_getix
+#define setenv_getix CPerlObj::Perl_setenv_getix
+#undef sharepvn
+#define sharepvn CPerlObj::Perl_sharepvn
+#undef set_csh
+#define set_csh CPerlObj::set_csh
+#undef sighandler
+#define sighandler CPerlObj::Perl_sighandler
+#undef share_hek
+#define share_hek CPerlObj::Perl_share_hek
+#undef skipspace
+#define skipspace CPerlObj::Perl_skipspace
+#undef sortcv
+#define sortcv CPerlObj::sortcv
+#ifndef PERL_OBJECT
+#undef stack_base
+#define stack_base CPerlObj::Perl_stack_base
+#endif
+#undef stack_grow
+#define stack_grow CPerlObj::Perl_stack_grow
+#undef start_subparse
+#define start_subparse CPerlObj::Perl_start_subparse
+#undef study_chunk
+#define study_chunk CPerlObj::study_chunk
+#undef sub_crush_depth
+#define sub_crush_depth CPerlObj::Perl_sub_crush_depth
+#undef sublex_done
+#define sublex_done CPerlObj::sublex_done
+#undef sublex_push
+#define sublex_push CPerlObj::sublex_push
+#undef sublex_start
+#define sublex_start CPerlObj::sublex_start
+#undef sv_2bool
+#define sv_2bool CPerlObj::Perl_sv_2bool
+#undef sv_2cv
+#define sv_2cv CPerlObj::Perl_sv_2cv
+#undef sv_2io
+#define sv_2io CPerlObj::Perl_sv_2io
+#undef sv_2iv
+#define sv_2iv CPerlObj::Perl_sv_2iv
+#undef sv_2uv
+#define sv_2uv CPerlObj::Perl_sv_2uv
+#undef sv_2mortal
+#define sv_2mortal CPerlObj::Perl_sv_2mortal
+#undef sv_2nv
+#define sv_2nv CPerlObj::Perl_sv_2nv
+#undef sv_2pv
+#define sv_2pv CPerlObj::Perl_sv_2pv
+#undef sv_add_arena
+#define sv_add_arena CPerlObj::Perl_sv_add_arena
+#undef sv_backoff
+#define sv_backoff CPerlObj::Perl_sv_backoff
+#undef sv_bless
+#define sv_bless CPerlObj::Perl_sv_bless
+#undef sv_catpv
+#define sv_catpv CPerlObj::Perl_sv_catpv
+#undef sv_catpv_mg
+#define sv_catpv_mg CPerlObj::Perl_sv_catpv_mg
+#undef sv_catpvf
+#define sv_catpvf CPerlObj::Perl_sv_catpvf
+#undef sv_catpvf_mg
+#define sv_catpvf_mg CPerlObj::Perl_sv_catpvf_mg
+#undef sv_catpvn
+#define sv_catpvn CPerlObj::Perl_sv_catpvn
+#undef sv_catpvn_mg
+#define sv_catpvn_mg CPerlObj::Perl_sv_catpvn_mg
+#undef sv_catsv
+#define sv_catsv CPerlObj::Perl_sv_catsv
+#undef sv_catsv_mg
+#define sv_catsv_mg CPerlObj::Perl_sv_catsv_mg
+#undef sv_check_thinkfirst
+#define sv_check_thinkfirst CPerlObj::sv_check_thinkfirst
+#undef sv_chop
+#define sv_chop CPerlObj::Perl_sv_chop
+#undef sv_clean_all
+#define sv_clean_all CPerlObj::Perl_sv_clean_all
+#undef sv_clean_objs
+#define sv_clean_objs CPerlObj::Perl_sv_clean_objs
+#undef sv_clear
+#define sv_clear CPerlObj::Perl_sv_clear
+#undef sv_cmp
+#define sv_cmp CPerlObj::Perl_sv_cmp
+#undef sv_cmp_locale
+#define sv_cmp_locale CPerlObj::Perl_sv_cmp_locale
+#undef sv_collxfrm
+#define sv_collxfrm CPerlObj::Perl_sv_collxfrm
+#undef sv_compile_2op
+#define sv_compile_2op CPerlObj::Perl_sv_compile_2op
+#undef sv_dec
+#define sv_dec CPerlObj::Perl_sv_dec
+#undef sv_derived_from
+#define sv_derived_from CPerlObj::Perl_sv_derived_from
+#undef sv_dump
+#define sv_dump CPerlObj::Perl_sv_dump
+#undef sv_eq
+#define sv_eq CPerlObj::Perl_sv_eq
+#undef sv_free
+#define sv_free CPerlObj::Perl_sv_free
+#undef sv_free_arenas
+#define sv_free_arenas CPerlObj::Perl_sv_free_arenas
+#undef sv_gets
+#define sv_gets CPerlObj::Perl_sv_gets
+#undef sv_grow
+#define sv_grow CPerlObj::Perl_sv_grow
+#undef sv_inc
+#define sv_inc CPerlObj::Perl_sv_inc
+#undef sv_insert
+#define sv_insert CPerlObj::Perl_sv_insert
+#undef sv_isa
+#define sv_isa CPerlObj::Perl_sv_isa
+#undef sv_isobject
+#define sv_isobject CPerlObj::Perl_sv_isobject
+#undef sv_iv
+#define sv_iv CPerlObj::Perl_sv_iv
+#undef sv_len
+#define sv_len CPerlObj::Perl_sv_len
+#undef sv_magic
+#define sv_magic CPerlObj::Perl_sv_magic
+#undef sv_mortalcopy
+#define sv_mortalcopy CPerlObj::Perl_sv_mortalcopy
+#undef sv_mortalgrow
+#define sv_mortalgrow CPerlObj::sv_mortalgrow
+#undef sv_newmortal
+#define sv_newmortal CPerlObj::Perl_sv_newmortal
+#undef sv_newref
+#define sv_newref CPerlObj::Perl_sv_newref
+#undef sv_nv
+#define sv_nv CPerlObj::Perl_sv_nv
+#undef sv_peek
+#define sv_peek CPerlObj::Perl_sv_peek
+#undef sv_pvn
+#define sv_pvn CPerlObj::Perl_sv_pvn
+#undef sv_pvn_force
+#define sv_pvn_force CPerlObj::Perl_sv_pvn_force
+#undef sv_reftype
+#define sv_reftype CPerlObj::Perl_sv_reftype
+#undef sv_replace
+#define sv_replace CPerlObj::Perl_sv_replace
+#undef sv_report_used
+#define sv_report_used CPerlObj::Perl_sv_report_used
+#undef sv_reset
+#define sv_reset CPerlObj::Perl_sv_reset
+#undef sv_setiv
+#define sv_setiv CPerlObj::Perl_sv_setiv
+#undef sv_setiv_mg
+#define sv_setiv_mg CPerlObj::Perl_sv_setiv_mg
+#undef sv_setnv
+#define sv_setnv CPerlObj::Perl_sv_setnv
+#undef sv_setnv_mg
+#define sv_setnv_mg CPerlObj::Perl_sv_setnv_mg
+#undef sv_setuv
+#define sv_setuv CPerlObj::Perl_sv_setuv
+#undef sv_setuv_mg
+#define sv_setuv_mg CPerlObj::Perl_sv_setuv_mg
+#undef sv_setref_iv
+#define sv_setref_iv CPerlObj::Perl_sv_setref_iv
+#undef sv_setref_nv
+#define sv_setref_nv CPerlObj::Perl_sv_setref_nv
+#undef sv_setref_pv
+#define sv_setref_pv CPerlObj::Perl_sv_setref_pv
+#undef sv_setref_pvn
+#define sv_setref_pvn CPerlObj::Perl_sv_setref_pvn
+#undef sv_setpv
+#define sv_setpv CPerlObj::Perl_sv_setpv
+#undef sv_setpv_mg
+#define sv_setpv_mg CPerlObj::Perl_sv_setpv_mg
+#undef sv_setpvf
+#define sv_setpvf CPerlObj::Perl_sv_setpvf
+#undef sv_setpvf_mg
+#define sv_setpvf_mg CPerlObj::Perl_sv_setpvf_mg
+#undef sv_setpviv
+#define sv_setpviv CPerlObj::Perl_sv_setpviv
+#undef sv_setpviv_mg
+#define sv_setpviv_mg CPerlObj::Perl_sv_setpviv_mg
+#undef sv_setpvn
+#define sv_setpvn CPerlObj::Perl_sv_setpvn
+#undef sv_setpvn_mg
+#define sv_setpvn_mg CPerlObj::Perl_sv_setpvn_mg
+#undef sv_setsv
+#define sv_setsv CPerlObj::Perl_sv_setsv
+#undef sv_setsv_mg
+#define sv_setsv_mg CPerlObj::Perl_sv_setsv_mg
+#undef sv_taint
+#define sv_taint CPerlObj::Perl_sv_taint
+#undef sv_tainted
+#define sv_tainted CPerlObj::Perl_sv_tainted
+#undef sv_true
+#define sv_true CPerlObj::Perl_sv_true
+#undef sv_unglob
+#define sv_unglob CPerlObj::sv_unglob
+#undef sv_unmagic
+#define sv_unmagic CPerlObj::Perl_sv_unmagic
+#undef sv_unref
+#define sv_unref CPerlObj::Perl_sv_unref
+#undef sv_untaint
+#define sv_untaint CPerlObj::Perl_sv_untaint
+#undef sv_upgrade
+#define sv_upgrade CPerlObj::Perl_sv_upgrade
+#undef sv_usepvn
+#define sv_usepvn CPerlObj::Perl_sv_usepvn
+#undef sv_usepvn_mg
+#define sv_usepvn_mg CPerlObj::Perl_sv_usepvn_mg
+#undef sv_uv
+#define sv_uv CPerlObj::Perl_sv_uv
+#undef sv_vcatpvfn
+#define sv_vcatpvfn CPerlObj::Perl_sv_vcatpvfn
+#undef sv_vsetpvfn
+#define sv_vsetpvfn CPerlObj::Perl_sv_vsetpvfn
+#undef taint_env
+#define taint_env CPerlObj::Perl_taint_env
+#undef taint_not
+#define taint_not CPerlObj::Perl_taint_not
+#undef taint_proper
+#define taint_proper CPerlObj::Perl_taint_proper
+#undef tokeq
+#define tokeq CPerlObj::tokeq
+#undef too_few_arguments
+#define too_few_arguments CPerlObj::Perl_too_few_arguments
+#undef too_many_arguments
+#define too_many_arguments CPerlObj::Perl_too_many_arguments
+#undef unlnk
+#define unlnk CPerlObj::unlnk
+#undef unsharepvn
+#define unsharepvn CPerlObj::Perl_unsharepvn
+#undef unshare_hek
+#define unshare_hek CPerlObj::Perl_unshare_hek
+#undef unwind_handler_stack
+#define unwind_handler_stack CPerlObj::unwind_handler_stack
+#undef usage
+#define usage CPerlObj::usage
+#undef utilize
+#define utilize CPerlObj::Perl_utilize
+#undef validate_suid
+#define validate_suid CPerlObj::validate_suid
+#undef visit
+#define visit CPerlObj::visit
+#undef vivify_defelem
+#define vivify_defelem CPerlObj::Perl_vivify_defelem
+#undef vivify_ref
+#define vivify_ref CPerlObj::Perl_vivify_ref
+#undef wait4pid
+#define wait4pid CPerlObj::Perl_wait4pid
+#undef warn
+#define warn CPerlObj::Perl_warn
+#undef watch
+#define watch CPerlObj::Perl_watch
+#undef whichsig
+#define whichsig CPerlObj::Perl_whichsig
+#undef win32_textfilter
+#define win32_textfilter CPerlObj::win32_textfilter
+#undef yyerror
+#define yyerror CPerlObj::Perl_yyerror
+#undef yylex
+#define yylex CPerlObj::Perl_yylex
+#undef yyparse
+#define yyparse CPerlObj::Perl_yyparse
+#undef yywarn
+#define yywarn CPerlObj::Perl_yywarn
+#undef yydestruct
+#define yydestruct CPerlObj::Perl_yydestruct
+
+#define new_he CPerlObj::new_he
+#define more_he CPerlObj::more_he
+#define del_he CPerlObj::del_he
+
+#if defined(WIN32) && !defined(WIN32IO_IS_STDIO)
+#undef errno
+#define errno CPerlObj::ErrorNo()
+
+#endif /* WIN32 */
+
+#endif /* __Objpp_h__ */
diff --git a/contrib/perl5/op.c b/contrib/perl5/op.c
new file mode 100644
index 000000000000..421a0939c0e3
--- /dev/null
+++ b/contrib/perl5/op.c
@@ -0,0 +1,5112 @@
+/* op.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
+ * our Mr. Bilbo's first cousin on the mother's side (her mother being the
+ * youngest of the Old Took's daughters); and Mr. Drogo was his second
+ * cousin. So Mr. Frodo is his first *and* second cousin, once removed
+ * either way, as the saying is, if you follow me." --the Gaffer
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef PERL_OBJECT
+#define CHECKCALL this->*check
+#else
+#define CHECKCALL *check
+#endif
+
+/*
+ * In the following definition, the ", Nullop" is just to make the compiler
+ * think the expression is of the right type: croak actually does a Siglongjmp.
+ */
+#define CHECKOP(type,o) \
+ ((PL_op_mask && PL_op_mask[type]) \
+ ? ( op_free((OP*)o), \
+ croak("%s trapped by operation mask", op_desc[type]), \
+ Nullop ) \
+ : (CHECKCALL[type])((OP*)o))
+
+static bool scalar_mod_type _((OP *o, I32 type));
+#ifndef PERL_OBJECT
+static I32 list_assignment _((OP *o));
+static void bad_type _((I32 n, char *t, char *name, OP *kid));
+static OP *modkids _((OP *o, I32 type));
+static OP *no_fh_allowed _((OP *o));
+static OP *scalarboolean _((OP *o));
+static OP *too_few_arguments _((OP *o, char* name));
+static OP *too_many_arguments _((OP *o, char* name));
+static void null _((OP* o));
+static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
+ CV* startcv, I32 cx_ix));
+static OP *newDEFSVOP _((void));
+static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
+#endif
+
+STATIC char*
+gv_ename(GV *gv)
+{
+ SV* tmpsv = sv_newmortal();
+ gv_efullname3(tmpsv, gv, Nullch);
+ return SvPV(tmpsv,PL_na);
+}
+
+STATIC OP *
+no_fh_allowed(OP *o)
+{
+ yyerror(form("Missing comma after first argument to %s function",
+ op_desc[o->op_type]));
+ return o;
+}
+
+STATIC OP *
+too_few_arguments(OP *o, char *name)
+{
+ yyerror(form("Not enough arguments for %s", name));
+ return o;
+}
+
+STATIC OP *
+too_many_arguments(OP *o, char *name)
+{
+ yyerror(form("Too many arguments for %s", name));
+ return o;
+}
+
+STATIC void
+bad_type(I32 n, char *t, char *name, OP *kid)
+{
+ yyerror(form("Type of arg %d to %s must be %s (not %s)",
+ (int)n, name, t, op_desc[kid->op_type]));
+}
+
+void
+assertref(OP *o)
+{
+ int type = o->op_type;
+ if (type != OP_AELEM && type != OP_HELEM && type != OP_GELEM) {
+ yyerror(form("Can't use subscript on %s", op_desc[type]));
+ if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) {
+ dTHR;
+ SV *msg = sv_2mortal(
+ newSVpvf("(Did you mean $ or @ instead of %c?)\n",
+ type == OP_ENTERSUB ? '&' : '%'));
+ if (PL_in_eval & 2)
+ warn("%_", msg);
+ else if (PL_in_eval)
+ sv_catsv(GvSV(PL_errgv), msg);
+ else
+ PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
+ }
+ }
+}
+
+/* "register" allocation */
+
+PADOFFSET
+pad_allocmy(char *name)
+{
+ dTHR;
+ PADOFFSET off;
+ SV *sv;
+
+ if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) {
+ if (!isPRINT(name[1])) {
+ name[3] = '\0';
+ name[2] = toCTRL(name[1]);
+ name[1] = '^';
+ }
+ croak("Can't use global %s in \"my\"",name);
+ }
+ if (PL_dowarn && AvFILLp(PL_comppad_name) >= 0) {
+ SV **svp = AvARRAY(PL_comppad_name);
+ for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_floor; off--) {
+ if ((sv = svp[off])
+ && sv != &PL_sv_undef
+ && SvIVX(sv) == 999999999 /* var is in open scope */
+ && strEQ(name, SvPVX(sv)))
+ {
+ warn("\"my\" variable %s masks earlier declaration in same scope", name);
+ break;
+ }
+ }
+ }
+ off = pad_alloc(OP_PADSV, SVs_PADMY);
+ sv = NEWSV(1102,0);
+ sv_upgrade(sv, SVt_PVNV);
+ sv_setpv(sv, name);
+ if (PL_in_my_stash) {
+ if (*name != '$')
+ croak("Can't declare class for non-scalar %s in \"my\"",name);
+ SvOBJECT_on(sv);
+ (void)SvUPGRADE(sv, SVt_PVMG);
+ SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
+ PL_sv_objcount++;
+ }
+ av_store(PL_comppad_name, off, sv);
+ SvNVX(sv) = (double)999999999;
+ SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
+ if (!PL_min_intro_pending)
+ PL_min_intro_pending = off;
+ PL_max_intro_pending = off;
+ if (*name == '@')
+ av_store(PL_comppad, off, (SV*)newAV());
+ else if (*name == '%')
+ av_store(PL_comppad, off, (SV*)newHV());
+ SvPADMY_on(PL_curpad[off]);
+ return off;
+}
+
+STATIC PADOFFSET
+pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
+{
+ dTHR;
+ CV *cv;
+ I32 off;
+ SV *sv;
+ register I32 i;
+ register PERL_CONTEXT *cx;
+ int saweval;
+
+ for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
+ AV *curlist = CvPADLIST(cv);
+ SV **svp = av_fetch(curlist, 0, FALSE);
+ AV *curname;
+
+ if (!svp || *svp == &PL_sv_undef)
+ continue;
+ curname = (AV*)*svp;
+ svp = AvARRAY(curname);
+ for (off = AvFILLp(curname); off > 0; off--) {
+ if ((sv = svp[off]) &&
+ sv != &PL_sv_undef &&
+ seq <= SvIVX(sv) &&
+ seq > I_32(SvNVX(sv)) &&
+ strEQ(SvPVX(sv), name))
+ {
+ I32 depth;
+ AV *oldpad;
+ SV *oldsv;
+
+ depth = CvDEPTH(cv);
+ if (!depth) {
+ if (newoff) {
+ if (SvFAKE(sv))
+ continue;
+ return 0; /* don't clone from inactive stack frame */
+ }
+ depth = 1;
+ }
+ oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
+ oldsv = *av_fetch(oldpad, off, TRUE);
+ if (!newoff) { /* Not a mere clone operation. */
+ SV *namesv = NEWSV(1103,0);
+ newoff = pad_alloc(OP_PADSV, SVs_PADMY);
+ sv_upgrade(namesv, SVt_PVNV);
+ sv_setpv(namesv, name);
+ av_store(PL_comppad_name, newoff, namesv);
+ SvNVX(namesv) = (double)PL_curcop->cop_seq;
+ SvIVX(namesv) = 999999999; /* A ref, intro immediately */
+ SvFAKE_on(namesv); /* A ref, not a real var */
+ if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
+ /* "It's closures all the way down." */
+ CvCLONE_on(PL_compcv);
+ if (cv == startcv) {
+ if (CvANON(PL_compcv))
+ oldsv = Nullsv; /* no need to keep ref */
+ }
+ else {
+ CV *bcv;
+ for (bcv = startcv;
+ bcv && bcv != cv && !CvCLONE(bcv);
+ bcv = CvOUTSIDE(bcv)) {
+ if (CvANON(bcv))
+ CvCLONE_on(bcv);
+ else {
+ if (PL_dowarn && !CvUNIQUE(cv))
+ warn(
+ "Variable \"%s\" may be unavailable",
+ name);
+ break;
+ }
+ }
+ }
+ }
+ else if (!CvUNIQUE(PL_compcv)) {
+ if (PL_dowarn && !SvFAKE(sv) && !CvUNIQUE(cv))
+ warn("Variable \"%s\" will not stay shared", name);
+ }
+ }
+ av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
+ return newoff;
+ }
+ }
+ }
+
+ /* Nothing in current lexical context--try eval's context, if any.
+ * This is necessary to let the perldb get at lexically scoped variables.
+ * XXX This will also probably interact badly with eval tree caching.
+ */
+
+ saweval = 0;
+ for (i = cx_ix; i >= 0; i--) {
+ cx = &cxstack[i];
+ switch (cx->cx_type) {
+ default:
+ if (i == 0 && saweval) {
+ seq = cxstack[saweval].blk_oldcop->cop_seq;
+ return pad_findlex(name, newoff, seq, PL_main_cv, 0);
+ }
+ break;
+ case CXt_EVAL:
+ switch (cx->blk_eval.old_op_type) {
+ case OP_ENTEREVAL:
+ saweval = i;
+ break;
+ case OP_REQUIRE:
+ /* require must have its own scope */
+ return 0;
+ }
+ break;
+ case CXt_SUB:
+ if (!saweval)
+ return 0;
+ cv = cx->blk_sub.cv;
+ if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
+ saweval = i; /* so we know where we were called from */
+ continue;
+ }
+ seq = cxstack[saweval].blk_oldcop->cop_seq;
+ return pad_findlex(name, newoff, seq, cv, i-1);
+ }
+ }
+
+ return 0;
+}
+
+PADOFFSET
+pad_findmy(char *name)
+{
+ dTHR;
+ I32 off;
+ I32 pendoff = 0;
+ SV *sv;
+ SV **svp = AvARRAY(PL_comppad_name);
+ U32 seq = PL_cop_seqmax;
+
+#ifdef USE_THREADS
+ /*
+ * Special case to get lexical (and hence per-thread) @_.
+ * XXX I need to find out how to tell at parse-time whether use
+ * of @_ should refer to a lexical (from a sub) or defgv (global
+ * scope and maybe weird sub-ish things like formats). See
+ * startsub in perly.y. It's possible that @_ could be lexical
+ * (at least from subs) even in non-threaded perl.
+ */
+ if (strEQ(name, "@_"))
+ return 0; /* success. (NOT_IN_PAD indicates failure) */
+#endif /* USE_THREADS */
+
+ /* The one we're looking for is probably just before comppad_name_fill. */
+ for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
+ if ((sv = svp[off]) &&
+ sv != &PL_sv_undef &&
+ (!SvIVX(sv) ||
+ (seq <= SvIVX(sv) &&
+ seq > I_32(SvNVX(sv)))) &&
+ strEQ(SvPVX(sv), name))
+ {
+ if (SvIVX(sv))
+ return (PADOFFSET)off;
+ pendoff = off; /* this pending def. will override import */
+ }
+ }
+
+ /* See if it's in a nested scope */
+ off = pad_findlex(name, 0, seq, CvOUTSIDE(PL_compcv), cxstack_ix);
+ if (off) {
+ /* If there is a pending local definition, this new alias must die */
+ if (pendoff)
+ SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
+ return off; /* pad_findlex returns 0 for failure...*/
+ }
+ return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
+}
+
+void
+pad_leavemy(I32 fill)
+{
+ I32 off;
+ SV **svp = AvARRAY(PL_comppad_name);
+ SV *sv;
+ if (PL_min_intro_pending && fill < PL_min_intro_pending) {
+ for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
+ if ((sv = svp[off]) && sv != &PL_sv_undef)
+ warn("%s never introduced", SvPVX(sv));
+ }
+ }
+ /* "Deintroduce" my variables that are leaving with this scope. */
+ for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
+ if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == 999999999)
+ SvIVX(sv) = PL_cop_seqmax;
+ }
+}
+
+PADOFFSET
+pad_alloc(I32 optype, U32 tmptype)
+{
+ dTHR;
+ SV *sv;
+ I32 retval;
+
+ if (AvARRAY(PL_comppad) != PL_curpad)
+ croak("panic: pad_alloc");
+ if (PL_pad_reset_pending)
+ pad_reset();
+ if (tmptype & SVs_PADMY) {
+ do {
+ sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
+ } while (SvPADBUSY(sv)); /* need a fresh one */
+ retval = AvFILLp(PL_comppad);
+ }
+ else {
+ SV **names = AvARRAY(PL_comppad_name);
+ SSize_t names_fill = AvFILLp(PL_comppad_name);
+ for (;;) {
+ /*
+ * "foreach" index vars temporarily become aliases to non-"my"
+ * values. Thus we must skip, not just pad values that are
+ * marked as current pad values, but also those with names.
+ */
+ if (++PL_padix <= names_fill &&
+ (sv = names[PL_padix]) && sv != &PL_sv_undef)
+ continue;
+ sv = *av_fetch(PL_comppad, PL_padix, TRUE);
+ if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)))
+ break;
+ }
+ retval = PL_padix;
+ }
+ SvFLAGS(sv) |= tmptype;
+ PL_curpad = AvARRAY(PL_comppad);
+#ifdef USE_THREADS
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx alloc %ld for %s\n",
+ (unsigned long) thr, (unsigned long) PL_curpad,
+ (long) retval, op_name[optype]));
+#else
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx alloc %ld for %s\n",
+ (unsigned long) PL_curpad,
+ (long) retval, op_name[optype]));
+#endif /* USE_THREADS */
+ return (PADOFFSET)retval;
+}
+
+SV *
+pad_sv(PADOFFSET po)
+{
+ dTHR;
+#ifdef USE_THREADS
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx sv %d\n",
+ (unsigned long) thr, (unsigned long) PL_curpad, po));
+#else
+ if (!po)
+ croak("panic: pad_sv po");
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx sv %d\n",
+ (unsigned long) PL_curpad, po));
+#endif /* USE_THREADS */
+ return PL_curpad[po]; /* eventually we'll turn this into a macro */
+}
+
+void
+pad_free(PADOFFSET po)
+{
+ dTHR;
+ if (!PL_curpad)
+ return;
+ if (AvARRAY(PL_comppad) != PL_curpad)
+ croak("panic: pad_free curpad");
+ if (!po)
+ croak("panic: pad_free po");
+#ifdef USE_THREADS
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n",
+ (unsigned long) thr, (unsigned long) PL_curpad, po));
+#else
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx free %d\n",
+ (unsigned long) PL_curpad, po));
+#endif /* USE_THREADS */
+ if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef)
+ SvPADTMP_off(PL_curpad[po]);
+ if ((I32)po < PL_padix)
+ PL_padix = po - 1;
+}
+
+void
+pad_swipe(PADOFFSET po)
+{
+ dTHR;
+ if (AvARRAY(PL_comppad) != PL_curpad)
+ croak("panic: pad_swipe curpad");
+ if (!po)
+ croak("panic: pad_swipe po");
+#ifdef USE_THREADS
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n",
+ (unsigned long) thr, (unsigned long) PL_curpad, po));
+#else
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx swipe %d\n",
+ (unsigned long) PL_curpad, po));
+#endif /* USE_THREADS */
+ SvPADTMP_off(PL_curpad[po]);
+ PL_curpad[po] = NEWSV(1107,0);
+ SvPADTMP_on(PL_curpad[po]);
+ if ((I32)po < PL_padix)
+ PL_padix = po - 1;
+}
+
+/* XXX pad_reset() is currently disabled because it results in serious bugs.
+ * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
+ * on the stack by OPs that use them, there are several ways to get an alias
+ * to a shared TARG. Such an alias will change randomly and unpredictably.
+ * We avoid doing this until we can think of a Better Way.
+ * GSAR 97-10-29 */
+void
+pad_reset(void)
+{
+#ifdef USE_BROKEN_PAD_RESET
+ dTHR;
+ register I32 po;
+
+ if (AvARRAY(PL_comppad) != PL_curpad)
+ croak("panic: pad_reset curpad");
+#ifdef USE_THREADS
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n",
+ (unsigned long) thr, (unsigned long) PL_curpad));
+#else
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx reset\n",
+ (unsigned long) PL_curpad));
+#endif /* USE_THREADS */
+ if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
+ for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
+ if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
+ SvPADTMP_off(PL_curpad[po]);
+ }
+ PL_padix = PL_padix_floor;
+ }
+#endif
+ PL_pad_reset_pending = FALSE;
+}
+
+#ifdef USE_THREADS
+/* find_threadsv is not reentrant */
+PADOFFSET
+find_threadsv(char *name)
+{
+ dTHR;
+ char *p;
+ PADOFFSET key;
+ SV **svp;
+ /* We currently only handle names of a single character */
+ p = strchr(PL_threadsv_names, *name);
+ if (!p)
+ return NOT_IN_PAD;
+ key = p - PL_threadsv_names;
+ svp = av_fetch(thr->threadsv, key, FALSE);
+ if (!svp) {
+ SV *sv = NEWSV(0, 0);
+ av_store(thr->threadsv, key, sv);
+ thr->threadsvp = AvARRAY(thr->threadsv);
+ /*
+ * Some magic variables used to be automagically initialised
+ * in gv_fetchpv. Those which are now per-thread magicals get
+ * initialised here instead.
+ */
+ switch (*name) {
+ case '_':
+ break;
+ case ';':
+ sv_setpv(sv, "\034");
+ sv_magic(sv, 0, 0, name, 1);
+ break;
+ case '&':
+ case '`':
+ case '\'':
+ PL_sawampersand = TRUE;
+ SvREADONLY_on(sv);
+ /* FALL THROUGH */
+
+ /* XXX %! tied to Errno.pm needs to be added here.
+ * See gv_fetchpv(). */
+ /* case '!': */
+
+ default:
+ sv_magic(sv, 0, 0, name, 1);
+ }
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "find_threadsv: new SV %p for $%s%c\n",
+ sv, (*name < 32) ? "^" : "",
+ (*name < 32) ? toCTRL(*name) : *name));
+ }
+ return key;
+}
+#endif /* USE_THREADS */
+
+/* Destructor */
+
+void
+op_free(OP *o)
+{
+ register OP *kid, *nextkid;
+
+ if (!o || o->op_seq == (U16)-1)
+ return;
+
+ if (o->op_flags & OPf_KIDS) {
+ for (kid = cUNOPo->op_first; kid; kid = nextkid) {
+ nextkid = kid->op_sibling; /* Get before next freeing kid */
+ op_free(kid);
+ }
+ }
+
+ switch (o->op_type) {
+ case OP_NULL:
+ o->op_targ = 0; /* Was holding old type, if any. */
+ break;
+ case OP_ENTEREVAL:
+ o->op_targ = 0; /* Was holding hints. */
+ break;
+#ifdef USE_THREADS
+ case OP_ENTERITER:
+ if (!(o->op_flags & OPf_SPECIAL))
+ break;
+ /* FALL THROUGH */
+ case OP_THREADSV:
+ o->op_targ = 0; /* Was holding index into thr->threadsv AV. */
+ break;
+#endif /* USE_THREADS */
+ default:
+ if (!(o->op_flags & OPf_REF)
+ || (check[o->op_type] != FUNC_NAME_TO_PTR(ck_ftst)))
+ break;
+ /* FALL THROUGH */
+ case OP_GVSV:
+ case OP_GV:
+ case OP_AELEMFAST:
+ SvREFCNT_dec(cGVOPo->op_gv);
+ break;
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ Safefree(cCOPo->cop_label);
+ SvREFCNT_dec(cCOPo->cop_filegv);
+ break;
+ case OP_CONST:
+ SvREFCNT_dec(cSVOPo->op_sv);
+ break;
+ case OP_GOTO:
+ case OP_NEXT:
+ case OP_LAST:
+ case OP_REDO:
+ if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
+ break;
+ /* FALL THROUGH */
+ case OP_TRANS:
+ Safefree(cPVOPo->op_pv);
+ break;
+ case OP_SUBST:
+ op_free(cPMOPo->op_pmreplroot);
+ /* FALL THROUGH */
+ case OP_PUSHRE:
+ case OP_MATCH:
+ case OP_QR:
+ ReREFCNT_dec(cPMOPo->op_pmregexp);
+ break;
+ }
+
+ if (o->op_targ > 0)
+ pad_free(o->op_targ);
+
+ Safefree(o);
+}
+
+STATIC void
+null(OP *o)
+{
+ if (o->op_type != OP_NULL && o->op_type != OP_THREADSV && o->op_targ > 0)
+ pad_free(o->op_targ);
+ o->op_targ = o->op_type;
+ o->op_type = OP_NULL;
+ o->op_ppaddr = ppaddr[OP_NULL];
+}
+
+/* Contextualizers */
+
+#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
+
+OP *
+linklist(OP *o)
+{
+ register OP *kid;
+
+ if (o->op_next)
+ return o->op_next;
+
+ /* establish postfix order */
+ if (cUNOPo->op_first) {
+ o->op_next = LINKLIST(cUNOPo->op_first);
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ kid->op_next = LINKLIST(kid->op_sibling);
+ else
+ kid->op_next = o;
+ }
+ }
+ else
+ o->op_next = o;
+
+ return o->op_next;
+}
+
+OP *
+scalarkids(OP *o)
+{
+ OP *kid;
+ if (o && o->op_flags & OPf_KIDS) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ scalar(kid);
+ }
+ return o;
+}
+
+STATIC OP *
+scalarboolean(OP *o)
+{
+ if (PL_dowarn &&
+ o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
+ dTHR;
+ line_t oldline = PL_curcop->cop_line;
+
+ if (PL_copline != NOLINE)
+ PL_curcop->cop_line = PL_copline;
+ warn("Found = in conditional, should be ==");
+ PL_curcop->cop_line = oldline;
+ }
+ return scalar(o);
+}
+
+OP *
+scalar(OP *o)
+{
+ OP *kid;
+
+ /* assumes no premature commitment */
+ if (!o || (o->op_flags & OPf_WANT) || PL_error_count
+ || o->op_type == OP_RETURN)
+ return o;
+
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
+
+ switch (o->op_type) {
+ case OP_REPEAT:
+ if (o->op_private & OPpREPEAT_DOLIST)
+ null(((LISTOP*)cBINOPo->op_first)->op_first);
+ scalar(cBINOPo->op_first);
+ break;
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ scalar(kid);
+ break;
+ case OP_SPLIT:
+ if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
+ if (!kPMOP->op_pmreplroot)
+ deprecate("implicit split to @_");
+ }
+ /* FALL THROUGH */
+ case OP_MATCH:
+ case OP_QR:
+ case OP_SUBST:
+ case OP_NULL:
+ default:
+ if (o->op_flags & OPf_KIDS) {
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+ scalar(kid);
+ }
+ break;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ kid = cLISTOPo->op_first;
+ scalar(kid);
+ while (kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ scalarvoid(kid);
+ else
+ scalar(kid);
+ }
+ WITH_THR(PL_curcop = &PL_compiling);
+ break;
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ case OP_LIST:
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ scalarvoid(kid);
+ else
+ scalar(kid);
+ }
+ WITH_THR(PL_curcop = &PL_compiling);
+ break;
+ }
+ return o;
+}
+
+OP *
+scalarvoid(OP *o)
+{
+ OP *kid;
+ char* useless = 0;
+ SV* sv;
+
+ /* assumes no premature commitment */
+ if (!o || (o->op_flags & OPf_WANT) == OPf_WANT_LIST || PL_error_count
+ || o->op_type == OP_RETURN)
+ return o;
+
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+
+ switch (o->op_type) {
+ default:
+ if (!(opargs[o->op_type] & OA_FOLDCONST))
+ break;
+ /* FALL THROUGH */
+ case OP_REPEAT:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ goto func_ops;
+ case OP_SUBSTR:
+ if (o->op_private == 4)
+ break;
+ /* FALL THROUGH */
+ case OP_GVSV:
+ case OP_WANTARRAY:
+ case OP_GV:
+ case OP_PADSV:
+ case OP_PADAV:
+ case OP_PADHV:
+ case OP_PADANY:
+ case OP_AV2ARYLEN:
+ case OP_REF:
+ case OP_REFGEN:
+ case OP_SREFGEN:
+ case OP_DEFINED:
+ case OP_HEX:
+ case OP_OCT:
+ case OP_LENGTH:
+ case OP_VEC:
+ case OP_INDEX:
+ case OP_RINDEX:
+ case OP_SPRINTF:
+ case OP_AELEM:
+ case OP_AELEMFAST:
+ case OP_ASLICE:
+ case OP_HELEM:
+ case OP_HSLICE:
+ case OP_UNPACK:
+ case OP_PACK:
+ case OP_JOIN:
+ case OP_LSLICE:
+ case OP_ANONLIST:
+ case OP_ANONHASH:
+ case OP_SORT:
+ case OP_REVERSE:
+ case OP_RANGE:
+ case OP_FLIP:
+ case OP_FLOP:
+ case OP_CALLER:
+ case OP_FILENO:
+ case OP_EOF:
+ case OP_TELL:
+ case OP_GETSOCKNAME:
+ case OP_GETPEERNAME:
+ case OP_READLINK:
+ case OP_TELLDIR:
+ case OP_GETPPID:
+ case OP_GETPGRP:
+ case OP_GETPRIORITY:
+ case OP_TIME:
+ case OP_TMS:
+ case OP_LOCALTIME:
+ case OP_GMTIME:
+ case OP_GHBYNAME:
+ case OP_GHBYADDR:
+ case OP_GHOSTENT:
+ case OP_GNBYNAME:
+ case OP_GNBYADDR:
+ case OP_GNETENT:
+ case OP_GPBYNAME:
+ case OP_GPBYNUMBER:
+ case OP_GPROTOENT:
+ case OP_GSBYNAME:
+ case OP_GSBYPORT:
+ case OP_GSERVENT:
+ case OP_GPWNAM:
+ case OP_GPWUID:
+ case OP_GGRNAM:
+ case OP_GGRGID:
+ case OP_GETLOGIN:
+ func_ops:
+ if (!(o->op_private & OPpLVAL_INTRO))
+ useless = op_desc[o->op_type];
+ break;
+
+ case OP_RV2GV:
+ case OP_RV2SV:
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if (!(o->op_private & OPpLVAL_INTRO) &&
+ (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
+ useless = "a variable";
+ break;
+
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ WITH_THR(PL_curcop = ((COP*)o)); /* for warning below */
+ break;
+
+ case OP_CONST:
+ sv = cSVOPo->op_sv;
+ if (PL_dowarn) {
+ useless = "a constant";
+ if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
+ useless = 0;
+ else if (SvPOK(sv)) {
+ if (strnEQ(SvPVX(sv), "di", 2) ||
+ strnEQ(SvPVX(sv), "ds", 2) ||
+ strnEQ(SvPVX(sv), "ig", 2))
+ useless = 0;
+ }
+ }
+ null(o); /* don't execute a constant */
+ SvREFCNT_dec(sv); /* don't even remember it */
+ break;
+
+ case OP_POSTINC:
+ o->op_type = OP_PREINC; /* pre-increment is faster */
+ o->op_ppaddr = ppaddr[OP_PREINC];
+ break;
+
+ case OP_POSTDEC:
+ o->op_type = OP_PREDEC; /* pre-decrement is faster */
+ o->op_ppaddr = ppaddr[OP_PREDEC];
+ break;
+
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ scalarvoid(kid);
+ break;
+
+ case OP_NULL:
+ if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
+ WITH_THR(PL_curcop = ((COP*)o)); /* for warning below */
+ if (o->op_flags & OPf_STACKED)
+ break;
+ /* FALL THROUGH */
+ case OP_ENTERTRY:
+ case OP_ENTER:
+ case OP_SCALAR:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ /* FALL THROUGH */
+ case OP_SCOPE:
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ case OP_LEAVELOOP:
+ case OP_LINESEQ:
+ case OP_LIST:
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ scalarvoid(kid);
+ break;
+ case OP_ENTEREVAL:
+ scalarkids(o);
+ break;
+ case OP_REQUIRE:
+ /* all requires must return a boolean value */
+ o->op_flags &= ~OPf_WANT;
+ return scalar(o);
+ case OP_SPLIT:
+ if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
+ if (!kPMOP->op_pmreplroot)
+ deprecate("implicit split to @_");
+ }
+ break;
+ }
+ if (useless && PL_dowarn)
+ warn("Useless use of %s in void context", useless);
+ return o;
+}
+
+OP *
+listkids(OP *o)
+{
+ OP *kid;
+ if (o && o->op_flags & OPf_KIDS) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ list(kid);
+ }
+ return o;
+}
+
+OP *
+list(OP *o)
+{
+ OP *kid;
+
+ /* assumes no premature commitment */
+ if (!o || (o->op_flags & OPf_WANT) || PL_error_count
+ || o->op_type == OP_RETURN)
+ return o;
+
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
+
+ switch (o->op_type) {
+ case OP_FLOP:
+ case OP_REPEAT:
+ list(cBINOPo->op_first);
+ break;
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ list(kid);
+ break;
+ default:
+ case OP_MATCH:
+ case OP_QR:
+ case OP_SUBST:
+ case OP_NULL:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
+ list(cBINOPo->op_first);
+ return gen_constant_list(o);
+ }
+ case OP_LIST:
+ listkids(o);
+ break;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ kid = cLISTOPo->op_first;
+ list(kid);
+ while (kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ scalarvoid(kid);
+ else
+ list(kid);
+ }
+ WITH_THR(PL_curcop = &PL_compiling);
+ break;
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ scalarvoid(kid);
+ else
+ list(kid);
+ }
+ WITH_THR(PL_curcop = &PL_compiling);
+ break;
+ case OP_REQUIRE:
+ /* all requires must return a boolean value */
+ o->op_flags &= ~OPf_WANT;
+ return scalar(o);
+ }
+ return o;
+}
+
+OP *
+scalarseq(OP *o)
+{
+ OP *kid;
+
+ if (o) {
+ if (o->op_type == OP_LINESEQ ||
+ o->op_type == OP_SCOPE ||
+ o->op_type == OP_LEAVE ||
+ o->op_type == OP_LEAVETRY)
+ {
+ dTHR;
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
+ if (kid->op_sibling) {
+ scalarvoid(kid);
+ }
+ }
+ PL_curcop = &PL_compiling;
+ }
+ o->op_flags &= ~OPf_PARENS;
+ if (PL_hints & HINT_BLOCK_SCOPE)
+ o->op_flags |= OPf_PARENS;
+ }
+ else
+ o = newOP(OP_STUB, 0);
+ return o;
+}
+
+STATIC OP *
+modkids(OP *o, I32 type)
+{
+ OP *kid;
+ if (o && o->op_flags & OPf_KIDS) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ mod(kid, type);
+ }
+ return o;
+}
+
+OP *
+mod(OP *o, I32 type)
+{
+ dTHR;
+ OP *kid;
+ SV *sv;
+
+ if (!o || PL_error_count)
+ return o;
+
+ switch (o->op_type) {
+ case OP_UNDEF:
+ PL_modcount++;
+ return o;
+ case OP_CONST:
+ if (!(o->op_private & (OPpCONST_ARYBASE)))
+ goto nomod;
+ if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
+ PL_compiling.cop_arybase = (I32)SvIV(((SVOP*)PL_eval_start)->op_sv);
+ PL_eval_start = 0;
+ }
+ else if (!type) {
+ SAVEI32(PL_compiling.cop_arybase);
+ PL_compiling.cop_arybase = 0;
+ }
+ else if (type == OP_REFGEN)
+ goto nomod;
+ else
+ croak("That use of $[ is unsupported");
+ break;
+ case OP_STUB:
+ if (o->op_flags & OPf_PARENS)
+ break;
+ goto nomod;
+ case OP_ENTERSUB:
+ if ((type == OP_UNDEF || type == OP_REFGEN) &&
+ !(o->op_flags & OPf_STACKED)) {
+ o->op_type = OP_RV2CV; /* entersub => rv2cv */
+ o->op_ppaddr = ppaddr[OP_RV2CV];
+ assert(cUNOPo->op_first->op_type == OP_NULL);
+ null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
+ break;
+ }
+ /* FALL THROUGH */
+ default:
+ nomod:
+ /* grep, foreach, subcalls, refgen */
+ if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
+ break;
+ yyerror(form("Can't modify %s in %s",
+ op_desc[o->op_type],
+ type ? op_desc[type] : "local"));
+ return o;
+
+ case OP_PREINC:
+ case OP_PREDEC:
+ case OP_POW:
+ case OP_MULTIPLY:
+ case OP_DIVIDE:
+ case OP_MODULO:
+ case OP_REPEAT:
+ case OP_ADD:
+ case OP_SUBTRACT:
+ case OP_CONCAT:
+ case OP_LEFT_SHIFT:
+ case OP_RIGHT_SHIFT:
+ case OP_BIT_AND:
+ case OP_BIT_XOR:
+ case OP_BIT_OR:
+ case OP_I_MULTIPLY:
+ case OP_I_DIVIDE:
+ case OP_I_MODULO:
+ case OP_I_ADD:
+ case OP_I_SUBTRACT:
+ if (!(o->op_flags & OPf_STACKED))
+ goto nomod;
+ PL_modcount++;
+ break;
+
+ case OP_COND_EXPR:
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ mod(kid, type);
+ break;
+
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if (!type && cUNOPo->op_first->op_type != OP_GV)
+ croak("Can't localize through a reference");
+ if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
+ PL_modcount = 10000;
+ return o; /* Treat \(@foo) like ordinary list. */
+ }
+ /* FALL THROUGH */
+ case OP_RV2GV:
+ if (scalar_mod_type(o, type))
+ goto nomod;
+ ref(cUNOPo->op_first, o->op_type);
+ /* FALL THROUGH */
+ case OP_AASSIGN:
+ case OP_ASLICE:
+ case OP_HSLICE:
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ case OP_REFGEN:
+ case OP_CHOMP:
+ PL_modcount = 10000;
+ break;
+ case OP_RV2SV:
+ if (!type && cUNOPo->op_first->op_type != OP_GV)
+ croak("Can't localize through a reference");
+ ref(cUNOPo->op_first, o->op_type);
+ /* FALL THROUGH */
+ case OP_GV:
+ case OP_AV2ARYLEN:
+ PL_hints |= HINT_BLOCK_SCOPE;
+ case OP_SASSIGN:
+ case OP_AELEMFAST:
+ PL_modcount++;
+ break;
+
+ case OP_PADAV:
+ case OP_PADHV:
+ PL_modcount = 10000;
+ if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
+ return o; /* Treat \(@foo) like ordinary list. */
+ if (scalar_mod_type(o, type))
+ goto nomod;
+ /* FALL THROUGH */
+ case OP_PADSV:
+ PL_modcount++;
+ if (!type)
+ croak("Can't localize lexical variable %s",
+ SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), PL_na));
+ break;
+
+#ifdef USE_THREADS
+ case OP_THREADSV:
+ PL_modcount++; /* XXX ??? */
+ break;
+#endif /* USE_THREADS */
+
+ case OP_PUSHMARK:
+ break;
+
+ case OP_KEYS:
+ if (type != OP_SASSIGN)
+ goto nomod;
+ goto lvalue_func;
+ case OP_SUBSTR:
+ if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
+ goto nomod;
+ /* FALL THROUGH */
+ case OP_POS:
+ case OP_VEC:
+ lvalue_func:
+ pad_free(o->op_targ);
+ o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
+ assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
+ if (o->op_flags & OPf_KIDS)
+ mod(cBINOPo->op_first->op_sibling, type);
+ break;
+
+ case OP_AELEM:
+ case OP_HELEM:
+ ref(cBINOPo->op_first, o->op_type);
+ if (type == OP_ENTERSUB &&
+ !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
+ o->op_private |= OPpLVAL_DEFER;
+ PL_modcount++;
+ break;
+
+ case OP_SCOPE:
+ case OP_LEAVE:
+ case OP_ENTER:
+ if (o->op_flags & OPf_KIDS)
+ mod(cLISTOPo->op_last, type);
+ break;
+
+ case OP_NULL:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ if (o->op_targ != OP_LIST) {
+ mod(cBINOPo->op_first, type);
+ break;
+ }
+ /* FALL THROUGH */
+ case OP_LIST:
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ mod(kid, type);
+ break;
+ }
+ o->op_flags |= OPf_MOD;
+
+ if (type == OP_AASSIGN || type == OP_SASSIGN)
+ o->op_flags |= OPf_SPECIAL|OPf_REF;
+ else if (!type) {
+ o->op_private |= OPpLVAL_INTRO;
+ o->op_flags &= ~OPf_SPECIAL;
+ PL_hints |= HINT_BLOCK_SCOPE;
+ }
+ else if (type != OP_GREPSTART && type != OP_ENTERSUB)
+ o->op_flags |= OPf_REF;
+ return o;
+}
+
+static bool
+scalar_mod_type(OP *o, I32 type)
+{
+ switch (type) {
+ case OP_SASSIGN:
+ if (o->op_type == OP_RV2GV)
+ return FALSE;
+ /* FALL THROUGH */
+ case OP_PREINC:
+ case OP_PREDEC:
+ case OP_POSTINC:
+ case OP_POSTDEC:
+ case OP_I_PREINC:
+ case OP_I_PREDEC:
+ case OP_I_POSTINC:
+ case OP_I_POSTDEC:
+ case OP_POW:
+ case OP_MULTIPLY:
+ case OP_DIVIDE:
+ case OP_MODULO:
+ case OP_REPEAT:
+ case OP_ADD:
+ case OP_SUBTRACT:
+ case OP_I_MULTIPLY:
+ case OP_I_DIVIDE:
+ case OP_I_MODULO:
+ case OP_I_ADD:
+ case OP_I_SUBTRACT:
+ case OP_LEFT_SHIFT:
+ case OP_RIGHT_SHIFT:
+ case OP_BIT_AND:
+ case OP_BIT_XOR:
+ case OP_BIT_OR:
+ case OP_CONCAT:
+ case OP_SUBST:
+ case OP_TRANS:
+ case OP_READ:
+ case OP_SYSREAD:
+ case OP_RECV:
+ case OP_ANDASSIGN: /* may work later */
+ case OP_ORASSIGN: /* may work later */
+ return TRUE;
+ default:
+ return FALSE;
+ }
+}
+
+OP *
+refkids(OP *o, I32 type)
+{
+ OP *kid;
+ if (o && o->op_flags & OPf_KIDS) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ ref(kid, type);
+ }
+ return o;
+}
+
+OP *
+ref(OP *o, I32 type)
+{
+ OP *kid;
+
+ if (!o || PL_error_count)
+ return o;
+
+ switch (o->op_type) {
+ case OP_ENTERSUB:
+ if ((type == OP_DEFINED || type == OP_LOCK) &&
+ !(o->op_flags & OPf_STACKED)) {
+ o->op_type = OP_RV2CV; /* entersub => rv2cv */
+ o->op_ppaddr = ppaddr[OP_RV2CV];
+ assert(cUNOPo->op_first->op_type == OP_NULL);
+ null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
+ o->op_flags |= OPf_SPECIAL;
+ }
+ break;
+
+ case OP_COND_EXPR:
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ ref(kid, type);
+ break;
+ case OP_RV2SV:
+ ref(cUNOPo->op_first, o->op_type);
+ /* FALL THROUGH */
+ case OP_PADSV:
+ if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
+ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
+ o->op_flags |= OPf_MOD;
+ }
+ break;
+
+ case OP_THREADSV:
+ o->op_flags |= OPf_MOD; /* XXX ??? */
+ break;
+
+ case OP_RV2AV:
+ case OP_RV2HV:
+ o->op_flags |= OPf_REF;
+ /* FALL THROUGH */
+ case OP_RV2GV:
+ ref(cUNOPo->op_first, o->op_type);
+ break;
+
+ case OP_PADAV:
+ case OP_PADHV:
+ o->op_flags |= OPf_REF;
+ break;
+
+ case OP_SCALAR:
+ case OP_NULL:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ ref(cBINOPo->op_first, type);
+ break;
+ case OP_AELEM:
+ case OP_HELEM:
+ ref(cBINOPo->op_first, o->op_type);
+ if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
+ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
+ o->op_flags |= OPf_MOD;
+ }
+ break;
+
+ case OP_SCOPE:
+ case OP_LEAVE:
+ case OP_ENTER:
+ case OP_LIST:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ ref(cLISTOPo->op_last, type);
+ break;
+ default:
+ break;
+ }
+ return scalar(o);
+
+}
+
+OP *
+my(OP *o)
+{
+ OP *kid;
+ I32 type;
+
+ if (!o || PL_error_count)
+ return o;
+
+ type = o->op_type;
+ if (type == OP_LIST) {
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ my(kid);
+ } else if (type == OP_UNDEF) {
+ return o;
+ } else if (type != OP_PADSV &&
+ type != OP_PADAV &&
+ type != OP_PADHV &&
+ type != OP_PUSHMARK)
+ {
+ yyerror(form("Can't declare %s in my", op_desc[o->op_type]));
+ return o;
+ }
+ o->op_flags |= OPf_MOD;
+ o->op_private |= OPpLVAL_INTRO;
+ return o;
+}
+
+OP *
+sawparens(OP *o)
+{
+ if (o)
+ o->op_flags |= OPf_PARENS;
+ return o;
+}
+
+OP *
+bind_match(I32 type, OP *left, OP *right)
+{
+ OP *o;
+
+ if (PL_dowarn &&
+ (left->op_type == OP_RV2AV ||
+ left->op_type == OP_RV2HV ||
+ left->op_type == OP_PADAV ||
+ left->op_type == OP_PADHV)) {
+ char *desc = op_desc[(right->op_type == OP_SUBST ||
+ right->op_type == OP_TRANS)
+ ? right->op_type : OP_MATCH];
+ char *sample = ((left->op_type == OP_RV2AV ||
+ left->op_type == OP_PADAV)
+ ? "@array" : "%hash");
+ warn("Applying %s to %s will act on scalar(%s)", desc, sample, sample);
+ }
+
+ if (right->op_type == OP_MATCH ||
+ right->op_type == OP_SUBST ||
+ right->op_type == OP_TRANS) {
+ right->op_flags |= OPf_STACKED;
+ if (right->op_type != OP_MATCH)
+ left = mod(left, right->op_type);
+ if (right->op_type == OP_TRANS)
+ o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+ else
+ o = prepend_elem(right->op_type, scalar(left), right);
+ if (type == OP_NOT)
+ return newUNOP(OP_NOT, 0, scalar(o));
+ return o;
+ }
+ else
+ return bind_match(type, left,
+ pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
+}
+
+OP *
+invert(OP *o)
+{
+ if (!o)
+ return o;
+ /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
+ return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
+}
+
+OP *
+scope(OP *o)
+{
+ if (o) {
+ if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
+ o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
+ o->op_type = OP_LEAVE;
+ o->op_ppaddr = ppaddr[OP_LEAVE];
+ }
+ else {
+ if (o->op_type == OP_LINESEQ) {
+ OP *kid;
+ o->op_type = OP_SCOPE;
+ o->op_ppaddr = ppaddr[OP_SCOPE];
+ kid = ((LISTOP*)o)->op_first;
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){
+ SvREFCNT_dec(((COP*)kid)->cop_filegv);
+ null(kid);
+ }
+ }
+ else
+ o = newLISTOP(OP_SCOPE, 0, o, Nullop);
+ }
+ }
+ return o;
+}
+
+void
+save_hints(void)
+{
+ SAVEI32(PL_hints);
+ SAVESPTR(GvHV(PL_hintgv));
+ GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
+ SAVEFREESV(GvHV(PL_hintgv));
+}
+
+int
+block_start(int full)
+{
+ dTHR;
+ int retval = PL_savestack_ix;
+
+ SAVEI32(PL_comppad_name_floor);
+ if (full) {
+ if ((PL_comppad_name_fill = AvFILLp(PL_comppad_name)) > 0)
+ PL_comppad_name_floor = PL_comppad_name_fill;
+ else
+ PL_comppad_name_floor = 0;
+ }
+ SAVEI32(PL_min_intro_pending);
+ SAVEI32(PL_max_intro_pending);
+ PL_min_intro_pending = 0;
+ SAVEI32(PL_comppad_name_fill);
+ SAVEI32(PL_padix_floor);
+ PL_padix_floor = PL_padix;
+ PL_pad_reset_pending = FALSE;
+ SAVEHINTS();
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ return retval;
+}
+
+OP*
+block_end(I32 floor, OP *seq)
+{
+ dTHR;
+ int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
+ OP* retval = scalarseq(seq);
+ LEAVE_SCOPE(floor);
+ PL_pad_reset_pending = FALSE;
+ if (needblockscope)
+ PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
+ pad_leavemy(PL_comppad_name_fill);
+ PL_cop_seqmax++;
+ return retval;
+}
+
+STATIC OP *
+newDEFSVOP(void)
+{
+#ifdef USE_THREADS
+ OP *o = newOP(OP_THREADSV, 0);
+ o->op_targ = find_threadsv("_");
+ return o;
+#else
+ return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
+#endif /* USE_THREADS */
+}
+
+void
+newPROG(OP *o)
+{
+ dTHR;
+ if (PL_in_eval) {
+ PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & 4) ? OPf_SPECIAL : 0), o);
+ PL_eval_start = linklist(PL_eval_root);
+ PL_eval_root->op_next = 0;
+ peep(PL_eval_start);
+ }
+ else {
+ if (!o)
+ return;
+ PL_main_root = scope(sawparens(scalarvoid(o)));
+ PL_curcop = &PL_compiling;
+ PL_main_start = LINKLIST(PL_main_root);
+ PL_main_root->op_next = 0;
+ peep(PL_main_start);
+ PL_compcv = 0;
+
+ /* Register with debugger */
+ if (PERLDB_INTER) {
+ CV *cv = perl_get_cv("DB::postponed", FALSE);
+ if (cv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs((SV*)PL_compiling.cop_filegv);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
+ }
+ }
+}
+
+OP *
+localize(OP *o, I32 lex)
+{
+ if (o->op_flags & OPf_PARENS)
+ list(o);
+ else {
+ if (PL_dowarn && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
+ char *s;
+ for (s = PL_bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ;
+ if (*s == ';' || *s == '=')
+ warn("Parens missing around \"%s\" list", lex ? "my" : "local");
+ }
+ }
+ PL_in_my = FALSE;
+ PL_in_my_stash = Nullhv;
+ if (lex)
+ return my(o);
+ else
+ return mod(o, OP_NULL); /* a bit kludgey */
+}
+
+OP *
+jmaybe(OP *o)
+{
+ if (o->op_type == OP_LIST) {
+ OP *o2;
+#ifdef USE_THREADS
+ o2 = newOP(OP_THREADSV, 0);
+ o2->op_targ = find_threadsv(";");
+#else
+ o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
+#endif /* USE_THREADS */
+ o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
+ }
+ return o;
+}
+
+OP *
+fold_constants(register OP *o)
+{
+ dTHR;
+ register OP *curop;
+ I32 type = o->op_type;
+ SV *sv;
+
+ if (opargs[type] & OA_RETSCALAR)
+ scalar(o);
+ if (opargs[type] & OA_TARGET)
+ o->op_targ = pad_alloc(type, SVs_PADTMP);
+
+ if ((opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
+ o->op_ppaddr = ppaddr[type = ++(o->op_type)];
+
+ if (!(opargs[type] & OA_FOLDCONST))
+ goto nope;
+
+ switch (type) {
+ case OP_SPRINTF:
+ case OP_UCFIRST:
+ case OP_LCFIRST:
+ case OP_UC:
+ case OP_LC:
+ case OP_SLT:
+ case OP_SGT:
+ case OP_SLE:
+ case OP_SGE:
+ case OP_SCMP:
+
+ if (o->op_private & OPpLOCALE)
+ goto nope;
+ }
+
+ if (PL_error_count)
+ goto nope; /* Don't try to run w/ errors */
+
+ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
+ if (curop->op_type != OP_CONST &&
+ curop->op_type != OP_LIST &&
+ curop->op_type != OP_SCALAR &&
+ curop->op_type != OP_NULL &&
+ curop->op_type != OP_PUSHMARK) {
+ goto nope;
+ }
+ }
+
+ curop = LINKLIST(o);
+ o->op_next = 0;
+ PL_op = curop;
+ CALLRUNOPS();
+ sv = *(PL_stack_sp--);
+ if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
+ pad_swipe(o->op_targ);
+ else if (SvTEMP(sv)) { /* grab mortal temp? */
+ (void)SvREFCNT_inc(sv);
+ SvTEMP_off(sv);
+ }
+ op_free(o);
+ if (type == OP_RV2GV)
+ return newGVOP(OP_GV, 0, (GV*)sv);
+ else {
+ /* try to smush double to int, but don't smush -2.0 to -2 */
+ if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
+ type != OP_NEGATE)
+ {
+ IV iv = SvIV(sv);
+ if ((double)iv == SvNV(sv)) {
+ SvREFCNT_dec(sv);
+ sv = newSViv(iv);
+ }
+ else
+ SvIOK_off(sv); /* undo SvIV() damage */
+ }
+ return newSVOP(OP_CONST, 0, sv);
+ }
+
+ nope:
+ if (!(opargs[type] & OA_OTHERINT))
+ return o;
+
+ if (!(PL_hints & HINT_INTEGER)) {
+ if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS))
+ return o;
+
+ for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
+ if (curop->op_type == OP_CONST) {
+ if (SvIOK(((SVOP*)curop)->op_sv))
+ continue;
+ return o;
+ }
+ if (opargs[curop->op_type] & OA_RETINTEGER)
+ continue;
+ return o;
+ }
+ o->op_ppaddr = ppaddr[++(o->op_type)];
+ }
+
+ return o;
+}
+
+OP *
+gen_constant_list(register OP *o)
+{
+ dTHR;
+ register OP *curop;
+ I32 oldtmps_floor = PL_tmps_floor;
+
+ list(o);
+ if (PL_error_count)
+ return o; /* Don't attempt to run with errors */
+
+ PL_op = curop = LINKLIST(o);
+ o->op_next = 0;
+ pp_pushmark(ARGS);
+ CALLRUNOPS();
+ PL_op = curop;
+ pp_anonlist(ARGS);
+ PL_tmps_floor = oldtmps_floor;
+
+ o->op_type = OP_RV2AV;
+ o->op_ppaddr = ppaddr[OP_RV2AV];
+ curop = ((UNOP*)o)->op_first;
+ ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
+ op_free(curop);
+ linklist(o);
+ return list(o);
+}
+
+OP *
+convert(I32 type, I32 flags, OP *o)
+{
+ OP *kid;
+ OP *last = 0;
+
+ if (!o || o->op_type != OP_LIST)
+ o = newLISTOP(OP_LIST, 0, o, Nullop);
+ else
+ o->op_flags &= ~OPf_WANT;
+
+ if (!(opargs[type] & OA_MARK))
+ null(cLISTOPo->op_first);
+
+ o->op_type = type;
+ o->op_ppaddr = ppaddr[type];
+ o->op_flags |= flags;
+
+ o = CHECKOP(type, o);
+ if (o->op_type != type)
+ return o;
+
+ if (cLISTOPo->op_children < 7) {
+ /* XXX do we really need to do this if we're done appending?? */
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ last = kid;
+ cLISTOPo->op_last = last; /* in case check substituted last arg */
+ }
+
+ return fold_constants(o);
+}
+
+/* List constructors */
+
+OP *
+append_elem(I32 type, OP *first, OP *last)
+{
+ if (!first)
+ return last;
+
+ if (!last)
+ return first;
+
+ if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS)
+ return newLISTOP(type, 0, first, last);
+
+ if (first->op_flags & OPf_KIDS)
+ ((LISTOP*)first)->op_last->op_sibling = last;
+ else {
+ first->op_flags |= OPf_KIDS;
+ ((LISTOP*)first)->op_first = last;
+ }
+ ((LISTOP*)first)->op_last = last;
+ ((LISTOP*)first)->op_children++;
+ return first;
+}
+
+OP *
+append_list(I32 type, LISTOP *first, LISTOP *last)
+{
+ if (!first)
+ return (OP*)last;
+
+ if (!last)
+ return (OP*)first;
+
+ if (first->op_type != type)
+ return prepend_elem(type, (OP*)first, (OP*)last);
+
+ if (last->op_type != type)
+ return append_elem(type, (OP*)first, (OP*)last);
+
+ first->op_last->op_sibling = last->op_first;
+ first->op_last = last->op_last;
+ first->op_children += last->op_children;
+ if (first->op_children)
+ last->op_flags |= OPf_KIDS;
+
+ Safefree(last);
+ return (OP*)first;
+}
+
+OP *
+prepend_elem(I32 type, OP *first, OP *last)
+{
+ if (!first)
+ return last;
+
+ if (!last)
+ return first;
+
+ if (last->op_type == type) {
+ if (type == OP_LIST) { /* already a PUSHMARK there */
+ first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
+ ((LISTOP*)last)->op_first->op_sibling = first;
+ }
+ else {
+ if (!(last->op_flags & OPf_KIDS)) {
+ ((LISTOP*)last)->op_last = first;
+ last->op_flags |= OPf_KIDS;
+ }
+ first->op_sibling = ((LISTOP*)last)->op_first;
+ ((LISTOP*)last)->op_first = first;
+ }
+ ((LISTOP*)last)->op_children++;
+ return last;
+ }
+
+ return newLISTOP(type, 0, first, last);
+}
+
+/* Constructors */
+
+OP *
+newNULLLIST(void)
+{
+ return newOP(OP_STUB, 0);
+}
+
+OP *
+force_list(OP *o)
+{
+ if (!o || o->op_type != OP_LIST)
+ o = newLISTOP(OP_LIST, 0, o, Nullop);
+ null(o);
+ return o;
+}
+
+OP *
+newLISTOP(I32 type, I32 flags, OP *first, OP *last)
+{
+ LISTOP *listop;
+
+ Newz(1101, listop, 1, LISTOP);
+
+ listop->op_type = type;
+ listop->op_ppaddr = ppaddr[type];
+ listop->op_children = (first != 0) + (last != 0);
+ listop->op_flags = flags;
+
+ if (!last && first)
+ last = first;
+ else if (!first && last)
+ first = last;
+ else if (first)
+ first->op_sibling = last;
+ listop->op_first = first;
+ listop->op_last = last;
+ if (type == OP_LIST) {
+ OP* pushop;
+ pushop = newOP(OP_PUSHMARK, 0);
+ pushop->op_sibling = first;
+ listop->op_first = pushop;
+ listop->op_flags |= OPf_KIDS;
+ if (!last)
+ listop->op_last = pushop;
+ }
+ else if (listop->op_children)
+ listop->op_flags |= OPf_KIDS;
+
+ return (OP*)listop;
+}
+
+OP *
+newOP(I32 type, I32 flags)
+{
+ OP *o;
+ Newz(1101, o, 1, OP);
+ o->op_type = type;
+ o->op_ppaddr = ppaddr[type];
+ o->op_flags = flags;
+
+ o->op_next = o;
+ o->op_private = 0 + (flags >> 8);
+ if (opargs[type] & OA_RETSCALAR)
+ scalar(o);
+ if (opargs[type] & OA_TARGET)
+ o->op_targ = pad_alloc(type, SVs_PADTMP);
+ return CHECKOP(type, o);
+}
+
+OP *
+newUNOP(I32 type, I32 flags, OP *first)
+{
+ UNOP *unop;
+
+ if (!first)
+ first = newOP(OP_STUB, 0);
+ if (opargs[type] & OA_MARK)
+ first = force_list(first);
+
+ Newz(1101, unop, 1, UNOP);
+ unop->op_type = type;
+ unop->op_ppaddr = ppaddr[type];
+ unop->op_first = first;
+ unop->op_flags = flags | OPf_KIDS;
+ unop->op_private = 1 | (flags >> 8);
+ unop = (UNOP*) CHECKOP(type, unop);
+ if (unop->op_next)
+ return (OP*)unop;
+
+ return fold_constants((OP *) unop);
+}
+
+OP *
+newBINOP(I32 type, I32 flags, OP *first, OP *last)
+{
+ BINOP *binop;
+ Newz(1101, binop, 1, BINOP);
+
+ if (!first)
+ first = newOP(OP_NULL, 0);
+
+ binop->op_type = type;
+ binop->op_ppaddr = ppaddr[type];
+ binop->op_first = first;
+ binop->op_flags = flags | OPf_KIDS;
+ if (!last) {
+ last = first;
+ binop->op_private = 1 | (flags >> 8);
+ }
+ else {
+ binop->op_private = 2 | (flags >> 8);
+ first->op_sibling = last;
+ }
+
+ binop = (BINOP*)CHECKOP(type, binop);
+ if (binop->op_next)
+ return (OP*)binop;
+
+ binop->op_last = last = binop->op_first->op_sibling;
+
+ return fold_constants((OP *)binop);
+}
+
+OP *
+pmtrans(OP *o, OP *expr, OP *repl)
+{
+ SV *tstr = ((SVOP*)expr)->op_sv;
+ SV *rstr = ((SVOP*)repl)->op_sv;
+ STRLEN tlen;
+ STRLEN rlen;
+ register U8 *t = (U8*)SvPV(tstr, tlen);
+ register U8 *r = (U8*)SvPV(rstr, rlen);
+ register I32 i;
+ register I32 j;
+ I32 Delete;
+ I32 complement;
+ I32 squash;
+ register short *tbl;
+
+ tbl = (short*)cPVOPo->op_pv;
+ complement = o->op_private & OPpTRANS_COMPLEMENT;
+ Delete = o->op_private & OPpTRANS_DELETE;
+ squash = o->op_private & OPpTRANS_SQUASH;
+
+ if (complement) {
+ Zero(tbl, 256, short);
+ for (i = 0; i < tlen; i++)
+ tbl[t[i]] = -1;
+ for (i = 0, j = 0; i < 256; i++) {
+ if (!tbl[i]) {
+ if (j >= rlen) {
+ if (Delete)
+ tbl[i] = -2;
+ else if (rlen)
+ tbl[i] = r[j-1];
+ else
+ tbl[i] = i;
+ }
+ else
+ tbl[i] = r[j++];
+ }
+ }
+ }
+ else {
+ if (!rlen && !Delete) {
+ r = t; rlen = tlen;
+ if (!squash)
+ o->op_private |= OPpTRANS_COUNTONLY;
+ }
+ for (i = 0; i < 256; i++)
+ tbl[i] = -1;
+ for (i = 0, j = 0; i < tlen; i++,j++) {
+ if (j >= rlen) {
+ if (Delete) {
+ if (tbl[t[i]] == -1)
+ tbl[t[i]] = -2;
+ continue;
+ }
+ --j;
+ }
+ if (tbl[t[i]] == -1)
+ tbl[t[i]] = r[j];
+ }
+ }
+ op_free(expr);
+ op_free(repl);
+
+ return o;
+}
+
+OP *
+newPMOP(I32 type, I32 flags)
+{
+ dTHR;
+ PMOP *pmop;
+
+ Newz(1101, pmop, 1, PMOP);
+ pmop->op_type = type;
+ pmop->op_ppaddr = ppaddr[type];
+ pmop->op_flags = flags;
+ pmop->op_private = 0 | (flags >> 8);
+
+ if (PL_hints & HINT_RE_TAINT)
+ pmop->op_pmpermflags |= PMf_RETAINT;
+ if (PL_hints & HINT_LOCALE)
+ pmop->op_pmpermflags |= PMf_LOCALE;
+ pmop->op_pmflags = pmop->op_pmpermflags;
+
+ /* link into pm list */
+ if (type != OP_TRANS && PL_curstash) {
+ pmop->op_pmnext = HvPMROOT(PL_curstash);
+ HvPMROOT(PL_curstash) = pmop;
+ }
+
+ return (OP*)pmop;
+}
+
+OP *
+pmruntime(OP *o, OP *expr, OP *repl)
+{
+ dTHR;
+ PMOP *pm;
+ LOGOP *rcop;
+ I32 repl_has_vars = 0;
+
+ if (o->op_type == OP_TRANS)
+ return pmtrans(o, expr, repl);
+
+ PL_hints |= HINT_BLOCK_SCOPE;
+ pm = (PMOP*)o;
+
+ if (expr->op_type == OP_CONST) {
+ STRLEN plen;
+ SV *pat = ((SVOP*)expr)->op_sv;
+ char *p = SvPV(pat, plen);
+ if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
+ sv_setpvn(pat, "\\s+", 3);
+ p = SvPV(pat, plen);
+ pm->op_pmflags |= PMf_SKIPWHITE;
+ }
+ pm->op_pmregexp = CALLREGCOMP(p, p + plen, pm);
+ if (strEQ("\\s+", pm->op_pmregexp->precomp))
+ pm->op_pmflags |= PMf_WHITE;
+ op_free(expr);
+ }
+ else {
+ if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
+ expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
+ ? OP_REGCRESET
+ : OP_REGCMAYBE),0,expr);
+
+ Newz(1101, rcop, 1, LOGOP);
+ rcop->op_type = OP_REGCOMP;
+ rcop->op_ppaddr = ppaddr[OP_REGCOMP];
+ rcop->op_first = scalar(expr);
+ rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
+ ? (OPf_SPECIAL | OPf_KIDS)
+ : OPf_KIDS);
+ rcop->op_private = 1;
+ rcop->op_other = o;
+
+ /* establish postfix order */
+ if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
+ LINKLIST(expr);
+ rcop->op_next = expr;
+ ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
+ }
+ else {
+ rcop->op_next = LINKLIST(expr);
+ expr->op_next = (OP*)rcop;
+ }
+
+ prepend_elem(o->op_type, scalar((OP*)rcop), o);
+ }
+
+ if (repl) {
+ OP *curop;
+ if (pm->op_pmflags & PMf_EVAL)
+ curop = 0;
+#ifdef USE_THREADS
+ else if (repl->op_type == OP_THREADSV
+ && strchr("&`'123456789+",
+ PL_threadsv_names[repl->op_targ]))
+ {
+ curop = 0;
+ }
+#endif /* USE_THREADS */
+ else if (repl->op_type == OP_CONST)
+ curop = repl;
+ else {
+ OP *lastop = 0;
+ for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
+ if (opargs[curop->op_type] & OA_DANGEROUS) {
+#ifdef USE_THREADS
+ if (curop->op_type == OP_THREADSV) {
+ repl_has_vars = 1;
+ if (strchr("&`'123456789+", curop->op_private))
+ break;
+ }
+#else
+ if (curop->op_type == OP_GV) {
+ GV *gv = ((GVOP*)curop)->op_gv;
+ repl_has_vars = 1;
+ if (strchr("&`'123456789+", *GvENAME(gv)))
+ break;
+ }
+#endif /* USE_THREADS */
+ else if (curop->op_type == OP_RV2CV)
+ break;
+ else if (curop->op_type == OP_RV2SV ||
+ curop->op_type == OP_RV2AV ||
+ curop->op_type == OP_RV2HV ||
+ curop->op_type == OP_RV2GV) {
+ if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
+ break;
+ }
+ else if (curop->op_type == OP_PADSV ||
+ curop->op_type == OP_PADAV ||
+ curop->op_type == OP_PADHV ||
+ curop->op_type == OP_PADANY) {
+ repl_has_vars = 1;
+ }
+ else if (curop->op_type == OP_PUSHRE)
+ ; /* Okay here, dangerous in newASSIGNOP */
+ else
+ break;
+ }
+ lastop = curop;
+ }
+ }
+ if (curop == repl
+ && !(repl_has_vars
+ && (!pm->op_pmregexp
+ || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
+ pm->op_pmflags |= PMf_CONST; /* const for long enough */
+ pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
+ prepend_elem(o->op_type, scalar(repl), o);
+ }
+ else {
+ if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
+ pm->op_pmflags |= PMf_MAYBE_CONST;
+ pm->op_pmpermflags |= PMf_MAYBE_CONST;
+ }
+ Newz(1101, rcop, 1, LOGOP);
+ rcop->op_type = OP_SUBSTCONT;
+ rcop->op_ppaddr = ppaddr[OP_SUBSTCONT];
+ rcop->op_first = scalar(repl);
+ rcop->op_flags |= OPf_KIDS;
+ rcop->op_private = 1;
+ rcop->op_other = o;
+
+ /* establish postfix order */
+ rcop->op_next = LINKLIST(repl);
+ repl->op_next = (OP*)rcop;
+
+ pm->op_pmreplroot = scalar((OP*)rcop);
+ pm->op_pmreplstart = LINKLIST(rcop);
+ rcop->op_next = 0;
+ }
+ }
+
+ return (OP*)pm;
+}
+
+OP *
+newSVOP(I32 type, I32 flags, SV *sv)
+{
+ SVOP *svop;
+ Newz(1101, svop, 1, SVOP);
+ svop->op_type = type;
+ svop->op_ppaddr = ppaddr[type];
+ svop->op_sv = sv;
+ svop->op_next = (OP*)svop;
+ svop->op_flags = flags;
+ if (opargs[type] & OA_RETSCALAR)
+ scalar((OP*)svop);
+ if (opargs[type] & OA_TARGET)
+ svop->op_targ = pad_alloc(type, SVs_PADTMP);
+ return CHECKOP(type, svop);
+}
+
+OP *
+newGVOP(I32 type, I32 flags, GV *gv)
+{
+ dTHR;
+ GVOP *gvop;
+ Newz(1101, gvop, 1, GVOP);
+ gvop->op_type = type;
+ gvop->op_ppaddr = ppaddr[type];
+ gvop->op_gv = (GV*)SvREFCNT_inc(gv);
+ gvop->op_next = (OP*)gvop;
+ gvop->op_flags = flags;
+ if (opargs[type] & OA_RETSCALAR)
+ scalar((OP*)gvop);
+ if (opargs[type] & OA_TARGET)
+ gvop->op_targ = pad_alloc(type, SVs_PADTMP);
+ return CHECKOP(type, gvop);
+}
+
+OP *
+newPVOP(I32 type, I32 flags, char *pv)
+{
+ PVOP *pvop;
+ Newz(1101, pvop, 1, PVOP);
+ pvop->op_type = type;
+ pvop->op_ppaddr = ppaddr[type];
+ pvop->op_pv = pv;
+ pvop->op_next = (OP*)pvop;
+ pvop->op_flags = flags;
+ if (opargs[type] & OA_RETSCALAR)
+ scalar((OP*)pvop);
+ if (opargs[type] & OA_TARGET)
+ pvop->op_targ = pad_alloc(type, SVs_PADTMP);
+ return CHECKOP(type, pvop);
+}
+
+void
+package(OP *o)
+{
+ dTHR;
+ SV *sv;
+
+ save_hptr(&PL_curstash);
+ save_item(PL_curstname);
+ if (o) {
+ STRLEN len;
+ char *name;
+ sv = cSVOPo->op_sv;
+ name = SvPV(sv, len);
+ PL_curstash = gv_stashpvn(name,len,TRUE);
+ sv_setpvn(PL_curstname, name, len);
+ op_free(o);
+ }
+ else {
+ sv_setpv(PL_curstname,"<none>");
+ PL_curstash = Nullhv;
+ }
+ PL_copline = NOLINE;
+ PL_expect = XSTATE;
+}
+
+void
+utilize(int aver, I32 floor, OP *version, OP *id, OP *arg)
+{
+ OP *pack;
+ OP *meth;
+ OP *rqop;
+ OP *imop;
+ OP *veop;
+
+ if (id->op_type != OP_CONST)
+ croak("Module name must be constant");
+
+ veop = Nullop;
+
+ if(version != Nullop) {
+ SV *vesv = ((SVOP*)version)->op_sv;
+
+ if (arg == Nullop && !SvNIOK(vesv)) {
+ arg = version;
+ }
+ else {
+ OP *pack;
+ OP *meth;
+
+ if (version->op_type != OP_CONST || !SvNIOK(vesv))
+ croak("Version number must be constant number");
+
+ /* Make copy of id so we don't free it twice */
+ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+
+ /* Fake up a method call to VERSION */
+ meth = newSVOP(OP_CONST, 0, newSVpv("VERSION", 7));
+ veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, pack, list(version)),
+ newUNOP(OP_METHOD, 0, meth)));
+ }
+ }
+
+ /* Fake up an import/unimport */
+ if (arg && arg->op_type == OP_STUB)
+ imop = arg; /* no import on explicit () */
+ else if(SvNIOK(((SVOP*)id)->op_sv)) {
+ imop = Nullop; /* use 5.0; */
+ }
+ else {
+ /* Make copy of id so we don't free it twice */
+ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+ meth = newSVOP(OP_CONST, 0,
+ aver
+ ? newSVpv("import", 6)
+ : newSVpv("unimport", 8)
+ );
+ imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, pack, list(arg)),
+ newUNOP(OP_METHOD, 0, meth)));
+ }
+
+ /* Fake up a require */
+ rqop = newUNOP(OP_REQUIRE, 0, id);
+
+ /* Fake up the BEGIN {}, which does its thing immediately. */
+ newSUB(floor,
+ newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)),
+ Nullop,
+ append_elem(OP_LINESEQ,
+ append_elem(OP_LINESEQ,
+ newSTATEOP(0, Nullch, rqop),
+ newSTATEOP(0, Nullch, veop)),
+ newSTATEOP(0, Nullch, imop) ));
+
+ PL_copline = NOLINE;
+ PL_expect = XSTATE;
+}
+
+OP *
+newSLICEOP(I32 flags, OP *subscript, OP *listval)
+{
+ return newBINOP(OP_LSLICE, flags,
+ list(force_list(subscript)),
+ list(force_list(listval)) );
+}
+
+STATIC I32
+list_assignment(register OP *o)
+{
+ if (!o)
+ return TRUE;
+
+ if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
+ o = cUNOPo->op_first;
+
+ if (o->op_type == OP_COND_EXPR) {
+ I32 t = list_assignment(cCONDOPo->op_first->op_sibling);
+ I32 f = list_assignment(cCONDOPo->op_first->op_sibling->op_sibling);
+
+ if (t && f)
+ return TRUE;
+ if (t || f)
+ yyerror("Assignment to both a list and a scalar");
+ return FALSE;
+ }
+
+ if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
+ o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
+ o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
+ return TRUE;
+
+ if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
+ return TRUE;
+
+ if (o->op_type == OP_RV2SV)
+ return FALSE;
+
+ return FALSE;
+}
+
+OP *
+newASSIGNOP(I32 flags, OP *left, I32 optype, OP *right)
+{
+ OP *o;
+
+ if (optype) {
+ if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
+ return newLOGOP(optype, 0,
+ mod(scalar(left), optype),
+ newUNOP(OP_SASSIGN, 0, scalar(right)));
+ }
+ else {
+ return newBINOP(optype, OPf_STACKED,
+ mod(scalar(left), optype), scalar(right));
+ }
+ }
+
+ if (list_assignment(left)) {
+ dTHR;
+ PL_modcount = 0;
+ PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
+ left = mod(left, OP_AASSIGN);
+ if (PL_eval_start)
+ PL_eval_start = 0;
+ else {
+ op_free(left);
+ op_free(right);
+ return Nullop;
+ }
+ o = newBINOP(OP_AASSIGN, flags,
+ list(force_list(right)),
+ list(force_list(left)) );
+ o->op_private = 0 | (flags >> 8);
+ if (!(left->op_private & OPpLVAL_INTRO)) {
+ OP *curop;
+ OP *lastop = o;
+ PL_generation++;
+ for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
+ if (opargs[curop->op_type] & OA_DANGEROUS) {
+ if (curop->op_type == OP_GV) {
+ GV *gv = ((GVOP*)curop)->op_gv;
+ if (gv == PL_defgv || SvCUR(gv) == PL_generation)
+ break;
+ SvCUR(gv) = PL_generation;
+ }
+ else if (curop->op_type == OP_PADSV ||
+ curop->op_type == OP_PADAV ||
+ curop->op_type == OP_PADHV ||
+ curop->op_type == OP_PADANY) {
+ SV **svp = AvARRAY(PL_comppad_name);
+ SV *sv = svp[curop->op_targ];
+ if (SvCUR(sv) == PL_generation)
+ break;
+ SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
+ }
+ else if (curop->op_type == OP_RV2CV)
+ break;
+ else if (curop->op_type == OP_RV2SV ||
+ curop->op_type == OP_RV2AV ||
+ curop->op_type == OP_RV2HV ||
+ curop->op_type == OP_RV2GV) {
+ if (lastop->op_type != OP_GV) /* funny deref? */
+ break;
+ }
+ else if (curop->op_type == OP_PUSHRE) {
+ if (((PMOP*)curop)->op_pmreplroot) {
+ GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
+ if (gv == PL_defgv || SvCUR(gv) == PL_generation)
+ break;
+ SvCUR(gv) = PL_generation;
+ }
+ }
+ else
+ break;
+ }
+ lastop = curop;
+ }
+ if (curop != o)
+ o->op_private = OPpASSIGN_COMMON;
+ }
+ if (right && right->op_type == OP_SPLIT) {
+ OP* tmpop;
+ if ((tmpop = ((LISTOP*)right)->op_first) &&
+ tmpop->op_type == OP_PUSHRE)
+ {
+ PMOP *pm = (PMOP*)tmpop;
+ if (left->op_type == OP_RV2AV &&
+ !(left->op_private & OPpLVAL_INTRO) &&
+ !(o->op_private & OPpASSIGN_COMMON) )
+ {
+ tmpop = ((UNOP*)left)->op_first;
+ if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
+ pm->op_pmreplroot = (OP*)((GVOP*)tmpop)->op_gv;
+ pm->op_pmflags |= PMf_ONCE;
+ tmpop = cUNOPo->op_first; /* to list (nulled) */
+ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
+ tmpop->op_sibling = Nullop; /* don't free split */
+ right->op_next = tmpop->op_next; /* fix starting loc */
+ op_free(o); /* blow off assign */
+ right->op_flags &= ~OPf_WANT;
+ /* "I don't know and I don't care." */
+ return right;
+ }
+ }
+ else {
+ if (PL_modcount < 10000 &&
+ ((LISTOP*)right)->op_last->op_type == OP_CONST)
+ {
+ SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
+ if (SvIVX(sv) == 0)
+ sv_setiv(sv, PL_modcount+1);
+ }
+ }
+ }
+ }
+ return o;
+ }
+ if (!right)
+ right = newOP(OP_UNDEF, 0);
+ if (right->op_type == OP_READLINE) {
+ right->op_flags |= OPf_STACKED;
+ return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
+ }
+ else {
+ PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
+ o = newBINOP(OP_SASSIGN, flags,
+ scalar(right), mod(scalar(left), OP_SASSIGN) );
+ if (PL_eval_start)
+ PL_eval_start = 0;
+ else {
+ op_free(o);
+ return Nullop;
+ }
+ }
+ return o;
+}
+
+OP *
+newSTATEOP(I32 flags, char *label, OP *o)
+{
+ dTHR;
+ U32 seq = intro_my();
+ register COP *cop;
+
+ Newz(1101, cop, 1, COP);
+ if (PERLDB_LINE && PL_curcop->cop_line && PL_curstash != PL_debstash) {
+ cop->op_type = OP_DBSTATE;
+ cop->op_ppaddr = ppaddr[ OP_DBSTATE ];
+ }
+ else {
+ cop->op_type = OP_NEXTSTATE;
+ cop->op_ppaddr = ppaddr[ OP_NEXTSTATE ];
+ }
+ cop->op_flags = flags;
+ cop->op_private = 0 | (flags >> 8);
+#ifdef NATIVE_HINTS
+ cop->op_private |= NATIVE_HINTS;
+#endif
+ cop->op_next = (OP*)cop;
+
+ if (label) {
+ cop->cop_label = label;
+ PL_hints |= HINT_BLOCK_SCOPE;
+ }
+ cop->cop_seq = seq;
+ cop->cop_arybase = PL_curcop->cop_arybase;
+
+ if (PL_copline == NOLINE)
+ cop->cop_line = PL_curcop->cop_line;
+ else {
+ cop->cop_line = PL_copline;
+ PL_copline = NOLINE;
+ }
+ cop->cop_filegv = (GV*)SvREFCNT_inc(PL_curcop->cop_filegv);
+ cop->cop_stash = PL_curstash;
+
+ if (PERLDB_LINE && PL_curstash != PL_debstash) {
+ SV **svp = av_fetch(GvAV(PL_curcop->cop_filegv),(I32)cop->cop_line, FALSE);
+ if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
+ (void)SvIOK_on(*svp);
+ SvIVX(*svp) = 1;
+ SvSTASH(*svp) = (HV*)cop;
+ }
+ }
+
+ return prepend_elem(OP_LINESEQ, (OP*)cop, o);
+}
+
+/* "Introduce" my variables to visible status. */
+U32
+intro_my(void)
+{
+ SV **svp;
+ SV *sv;
+ I32 i;
+
+ if (! PL_min_intro_pending)
+ return PL_cop_seqmax;
+
+ svp = AvARRAY(PL_comppad_name);
+ for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
+ if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
+ SvIVX(sv) = 999999999; /* Don't know scope end yet. */
+ SvNVX(sv) = (double)PL_cop_seqmax;
+ }
+ }
+ PL_min_intro_pending = 0;
+ PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
+ return PL_cop_seqmax++;
+}
+
+OP *
+newLOGOP(I32 type, I32 flags, OP *first, OP *other)
+{
+ return new_logop(type, flags, &first, &other);
+}
+
+STATIC OP *
+new_logop(I32 type, I32 flags, OP** firstp, OP** otherp)
+{
+ dTHR;
+ LOGOP *logop;
+ OP *o;
+ OP *first = *firstp;
+ OP *other = *otherp;
+
+ if (type == OP_XOR) /* Not short circuit, but here by precedence. */
+ return newBINOP(type, flags, scalar(first), scalar(other));
+
+ scalarboolean(first);
+ /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
+ if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
+ if (type == OP_AND || type == OP_OR) {
+ if (type == OP_AND)
+ type = OP_OR;
+ else
+ type = OP_AND;
+ o = first;
+ first = *firstp = cUNOPo->op_first;
+ if (o->op_next)
+ first->op_next = o->op_next;
+ cUNOPo->op_first = Nullop;
+ op_free(o);
+ }
+ }
+ if (first->op_type == OP_CONST) {
+ if (PL_dowarn && (first->op_private & OPpCONST_BARE))
+ warn("Probable precedence problem on %s", op_desc[type]);
+ if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
+ op_free(first);
+ *firstp = Nullop;
+ return other;
+ }
+ else {
+ op_free(other);
+ *otherp = Nullop;
+ return first;
+ }
+ }
+ else if (first->op_type == OP_WANTARRAY) {
+ if (type == OP_AND)
+ list(other);
+ else
+ scalar(other);
+ }
+ else if (PL_dowarn && (first->op_flags & OPf_KIDS)) {
+ OP *k1 = ((UNOP*)first)->op_first;
+ OP *k2 = k1->op_sibling;
+ OPCODE warnop = 0;
+ switch (first->op_type)
+ {
+ case OP_NULL:
+ if (k2 && k2->op_type == OP_READLINE
+ && (k2->op_flags & OPf_STACKED)
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
+ warnop = k2->op_type;
+ break;
+
+ case OP_SASSIGN:
+ if (k1->op_type == OP_READDIR
+ || k1->op_type == OP_GLOB
+ || k1->op_type == OP_EACH)
+ warnop = k1->op_type;
+ break;
+ }
+ if (warnop) {
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+ warn("Value of %s%s can be \"0\"; test with defined()",
+ op_desc[warnop],
+ ((warnop == OP_READLINE || warnop == OP_GLOB)
+ ? " construct" : "() operator"));
+ PL_curcop->cop_line = oldline;
+ }
+ }
+
+ if (!other)
+ return first;
+
+ if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
+ other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
+
+ Newz(1101, logop, 1, LOGOP);
+
+ logop->op_type = type;
+ logop->op_ppaddr = ppaddr[type];
+ logop->op_first = first;
+ logop->op_flags = flags | OPf_KIDS;
+ logop->op_other = LINKLIST(other);
+ logop->op_private = 1 | (flags >> 8);
+
+ /* establish postfix order */
+ logop->op_next = LINKLIST(first);
+ first->op_next = (OP*)logop;
+ first->op_sibling = other;
+
+ o = newUNOP(OP_NULL, 0, (OP*)logop);
+ other->op_next = o;
+
+ return o;
+}
+
+OP *
+newCONDOP(I32 flags, OP *first, OP *trueop, OP *falseop)
+{
+ dTHR;
+ CONDOP *condop;
+ OP *o;
+
+ if (!falseop)
+ return newLOGOP(OP_AND, 0, first, trueop);
+ if (!trueop)
+ return newLOGOP(OP_OR, 0, first, falseop);
+
+ scalarboolean(first);
+ if (first->op_type == OP_CONST) {
+ if (SvTRUE(((SVOP*)first)->op_sv)) {
+ op_free(first);
+ op_free(falseop);
+ return trueop;
+ }
+ else {
+ op_free(first);
+ op_free(trueop);
+ return falseop;
+ }
+ }
+ else if (first->op_type == OP_WANTARRAY) {
+ list(trueop);
+ scalar(falseop);
+ }
+ Newz(1101, condop, 1, CONDOP);
+
+ condop->op_type = OP_COND_EXPR;
+ condop->op_ppaddr = ppaddr[OP_COND_EXPR];
+ condop->op_first = first;
+ condop->op_flags = flags | OPf_KIDS;
+ condop->op_true = LINKLIST(trueop);
+ condop->op_false = LINKLIST(falseop);
+ condop->op_private = 1 | (flags >> 8);
+
+ /* establish postfix order */
+ condop->op_next = LINKLIST(first);
+ first->op_next = (OP*)condop;
+
+ first->op_sibling = trueop;
+ trueop->op_sibling = falseop;
+ o = newUNOP(OP_NULL, 0, (OP*)condop);
+
+ trueop->op_next = o;
+ falseop->op_next = o;
+
+ return o;
+}
+
+OP *
+newRANGE(I32 flags, OP *left, OP *right)
+{
+ dTHR;
+ CONDOP *condop;
+ OP *flip;
+ OP *flop;
+ OP *o;
+
+ Newz(1101, condop, 1, CONDOP);
+
+ condop->op_type = OP_RANGE;
+ condop->op_ppaddr = ppaddr[OP_RANGE];
+ condop->op_first = left;
+ condop->op_flags = OPf_KIDS;
+ condop->op_true = LINKLIST(left);
+ condop->op_false = LINKLIST(right);
+ condop->op_private = 1 | (flags >> 8);
+
+ left->op_sibling = right;
+
+ condop->op_next = (OP*)condop;
+ flip = newUNOP(OP_FLIP, flags, (OP*)condop);
+ flop = newUNOP(OP_FLOP, 0, flip);
+ o = newUNOP(OP_NULL, 0, flop);
+ linklist(flop);
+
+ left->op_next = flip;
+ right->op_next = flop;
+
+ condop->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
+ sv_upgrade(PAD_SV(condop->op_targ), SVt_PVNV);
+ flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
+ sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
+
+ flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
+ flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
+
+ flip->op_next = o;
+ if (!flip->op_private || !flop->op_private)
+ linklist(o); /* blow off optimizer unless constant */
+
+ return o;
+}
+
+OP *
+newLOOPOP(I32 flags, I32 debuggable, OP *expr, OP *block)
+{
+ dTHR;
+ OP* listop;
+ OP* o;
+ int once = block && block->op_flags & OPf_SPECIAL &&
+ (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
+
+ if (expr) {
+ if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
+ return block; /* do {} while 0 does once */
+ if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+ || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
+ expr = newUNOP(OP_DEFINED, 0,
+ newASSIGNOP(0, newDEFSVOP(), 0, expr) );
+ } else if (expr->op_flags & OPf_KIDS) {
+ OP *k1 = ((UNOP*)expr)->op_first;
+ OP *k2 = (k1) ? k1->op_sibling : NULL;
+ switch (expr->op_type) {
+ case OP_NULL:
+ if (k2 && k2->op_type == OP_READLINE
+ && (k2->op_flags & OPf_STACKED)
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+
+ case OP_SASSIGN:
+ if (k1->op_type == OP_READDIR
+ || k1->op_type == OP_GLOB
+ || k1->op_type == OP_EACH)
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+ }
+ }
+ }
+
+ listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
+ o = new_logop(OP_AND, 0, &expr, &listop);
+
+ if (listop)
+ ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
+
+ if (once && o != listop)
+ o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
+
+ if (o == listop)
+ o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
+
+ o->op_flags |= flags;
+ o = scope(o);
+ o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
+ return o;
+}
+
+OP *
+newWHILEOP(I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
+{
+ dTHR;
+ OP *redo;
+ OP *next = 0;
+ OP *listop;
+ OP *o;
+ OP *condop;
+
+ if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+ || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
+ expr = newUNOP(OP_DEFINED, 0,
+ newASSIGNOP(0, newDEFSVOP(), 0, expr) );
+ } else if (expr && (expr->op_flags & OPf_KIDS)) {
+ OP *k1 = ((UNOP*)expr)->op_first;
+ OP *k2 = (k1) ? k1->op_sibling : NULL;
+ switch (expr->op_type) {
+ case OP_NULL:
+ if (k2 && k2->op_type == OP_READLINE
+ && (k2->op_flags & OPf_STACKED)
+ && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+
+ case OP_SASSIGN:
+ if (k1->op_type == OP_READDIR
+ || k1->op_type == OP_GLOB
+ || k1->op_type == OP_EACH)
+ expr = newUNOP(OP_DEFINED, 0, expr);
+ break;
+ }
+ }
+
+ if (!block)
+ block = newOP(OP_NULL, 0);
+
+ if (cont)
+ next = LINKLIST(cont);
+ if (expr) {
+ cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
+ if ((line_t)whileline != NOLINE) {
+ PL_copline = whileline;
+ cont = append_elem(OP_LINESEQ, cont,
+ newSTATEOP(0, Nullch, Nullop));
+ }
+ }
+
+ listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
+ redo = LINKLIST(listop);
+
+ if (expr) {
+ PL_copline = whileline;
+ scalar(listop);
+ o = new_logop(OP_AND, 0, &expr, &listop);
+ if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
+ op_free(expr); /* oops, it's a while (0) */
+ op_free((OP*)loop);
+ return Nullop; /* listop already freed by new_logop */
+ }
+ if (listop)
+ ((LISTOP*)listop)->op_last->op_next = condop =
+ (o == listop ? redo : LINKLIST(o));
+ if (!next)
+ next = condop;
+ }
+ else
+ o = listop;
+
+ if (!loop) {
+ Newz(1101,loop,1,LOOP);
+ loop->op_type = OP_ENTERLOOP;
+ loop->op_ppaddr = ppaddr[OP_ENTERLOOP];
+ loop->op_private = 0;
+ loop->op_next = (OP*)loop;
+ }
+
+ o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
+
+ loop->op_redoop = redo;
+ loop->op_lastop = o;
+
+ if (next)
+ loop->op_nextop = next;
+ else
+ loop->op_nextop = o;
+
+ o->op_flags |= flags;
+ o->op_private |= (flags >> 8);
+ return o;
+}
+
+OP *
+newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
+{
+ LOOP *loop;
+ OP *wop;
+ int padoff = 0;
+ I32 iterflags = 0;
+
+ if (sv) {
+ if (sv->op_type == OP_RV2SV) { /* symbol table variable */
+ sv->op_type = OP_RV2GV;
+ sv->op_ppaddr = ppaddr[OP_RV2GV];
+ }
+ else if (sv->op_type == OP_PADSV) { /* private variable */
+ padoff = sv->op_targ;
+ op_free(sv);
+ sv = Nullop;
+ }
+ else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
+ padoff = sv->op_targ;
+ iterflags |= OPf_SPECIAL;
+ op_free(sv);
+ sv = Nullop;
+ }
+ else
+ croak("Can't use %s for loop variable", op_desc[sv->op_type]);
+ }
+ else {
+#ifdef USE_THREADS
+ padoff = find_threadsv("_");
+ iterflags |= OPf_SPECIAL;
+#else
+ sv = newGVOP(OP_GV, 0, PL_defgv);
+#endif
+ }
+ if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
+ expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
+ iterflags |= OPf_STACKED;
+ }
+ else if (expr->op_type == OP_NULL &&
+ (expr->op_flags & OPf_KIDS) &&
+ ((BINOP*)expr)->op_first->op_type == OP_FLOP)
+ {
+ /* Basically turn for($x..$y) into the same as for($x,$y), but we
+ * set the STACKED flag to indicate that these values are to be
+ * treated as min/max values by 'pp_iterinit'.
+ */
+ UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
+ CONDOP* range = (CONDOP*) flip->op_first;
+ OP* left = range->op_first;
+ OP* right = left->op_sibling;
+ LISTOP* listop;
+
+ range->op_flags &= ~OPf_KIDS;
+ range->op_first = Nullop;
+
+ listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
+ listop->op_first->op_next = range->op_true;
+ left->op_next = range->op_false;
+ right->op_next = (OP*)listop;
+ listop->op_next = listop->op_first;
+
+ op_free(expr);
+ expr = (OP*)(listop);
+ null(expr);
+ iterflags |= OPf_STACKED;
+ }
+ else {
+ expr = mod(force_list(expr), OP_GREPSTART);
+ }
+
+
+ loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
+ append_elem(OP_LIST, expr, scalar(sv))));
+ assert(!loop->op_next);
+ Renew(loop, 1, LOOP);
+ loop->op_targ = padoff;
+ wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
+ PL_copline = forline;
+ return newSTATEOP(0, label, wop);
+}
+
+OP*
+newLOOPEX(I32 type, OP *label)
+{
+ dTHR;
+ OP *o;
+ 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)
+ : ""));
+ }
+ op_free(label);
+ }
+ else {
+ if (label->op_type == OP_ENTERSUB)
+ label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
+ o = newUNOP(type, OPf_STACKED, label);
+ }
+ PL_hints |= HINT_BLOCK_SCOPE;
+ return o;
+}
+
+void
+cv_undef(CV *cv)
+{
+ dTHR;
+#ifdef USE_THREADS
+ if (CvMUTEXP(cv)) {
+ MUTEX_DESTROY(CvMUTEXP(cv));
+ Safefree(CvMUTEXP(cv));
+ CvMUTEXP(cv) = 0;
+ }
+#endif /* USE_THREADS */
+
+ if (!CvXSUB(cv) && CvROOT(cv)) {
+#ifdef USE_THREADS
+ if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
+ croak("Can't undef active subroutine");
+#else
+ if (CvDEPTH(cv))
+ croak("Can't undef active subroutine");
+#endif /* USE_THREADS */
+ ENTER;
+
+ SAVESPTR(PL_curpad);
+ PL_curpad = 0;
+
+ if (!CvCLONED(cv))
+ op_free(CvROOT(cv));
+ CvROOT(cv) = Nullop;
+ LEAVE;
+ }
+ SvPOK_off((SV*)cv); /* forget prototype */
+ CvFLAGS(cv) = 0;
+ SvREFCNT_dec(CvGV(cv));
+ CvGV(cv) = Nullgv;
+ SvREFCNT_dec(CvOUTSIDE(cv));
+ CvOUTSIDE(cv) = Nullcv;
+ if (CvPADLIST(cv)) {
+ /* may be during global destruction */
+ if (SvREFCNT(CvPADLIST(cv))) {
+ I32 i = AvFILLp(CvPADLIST(cv));
+ while (i >= 0) {
+ SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
+ SV* sv = svp ? *svp : Nullsv;
+ if (!sv)
+ continue;
+ if (sv == (SV*)PL_comppad_name)
+ PL_comppad_name = Nullav;
+ else if (sv == (SV*)PL_comppad) {
+ PL_comppad = Nullav;
+ PL_curpad = Null(SV**);
+ }
+ SvREFCNT_dec(sv);
+ }
+ SvREFCNT_dec((SV*)CvPADLIST(cv));
+ }
+ CvPADLIST(cv) = Nullav;
+ }
+}
+
+#ifdef DEBUG_CLOSURES
+STATIC void
+cv_dump(cv)
+CV* cv;
+{
+ CV *outside = CvOUTSIDE(cv);
+ AV* padlist = CvPADLIST(cv);
+ AV* pad_name;
+ AV* pad;
+ SV** pname;
+ SV** ppad;
+ I32 ix;
+
+ PerlIO_printf(Perl_debug_log, "\tCV=0x%lx (%s), OUTSIDE=0x%lx (%s)\n",
+ cv,
+ (CvANON(cv) ? "ANON"
+ : (cv == PL_main_cv) ? "MAIN"
+ : CvUNIQUE(outside) ? "UNIQUE"
+ : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
+ outside,
+ (!outside ? "null"
+ : CvANON(outside) ? "ANON"
+ : (outside == PL_main_cv) ? "MAIN"
+ : CvUNIQUE(outside) ? "UNIQUE"
+ : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
+
+ if (!padlist)
+ return;
+
+ pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
+ pad = (AV*)*av_fetch(padlist, 1, FALSE);
+ pname = AvARRAY(pad_name);
+ ppad = AvARRAY(pad);
+
+ for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
+ if (SvPOK(pname[ix]))
+ PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n",
+ ix, ppad[ix],
+ SvFAKE(pname[ix]) ? "FAKE " : "",
+ SvPVX(pname[ix]),
+ (long)I_32(SvNVX(pname[ix])),
+ (long)SvIVX(pname[ix]));
+ }
+}
+#endif /* DEBUG_CLOSURES */
+
+STATIC CV *
+cv_clone2(CV *proto, CV *outside)
+{
+ dTHR;
+ AV* av;
+ I32 ix;
+ AV* protopadlist = CvPADLIST(proto);
+ AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
+ AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
+ SV** pname = AvARRAY(protopad_name);
+ SV** ppad = AvARRAY(protopad);
+ I32 fname = AvFILLp(protopad_name);
+ I32 fpad = AvFILLp(protopad);
+ AV* comppadlist;
+ CV* cv;
+
+ assert(!CvUNIQUE(proto));
+
+ ENTER;
+ SAVESPTR(PL_curpad);
+ SAVESPTR(PL_comppad);
+ SAVESPTR(PL_comppad_name);
+ SAVESPTR(PL_compcv);
+
+ cv = PL_compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)cv, SvTYPE(proto));
+ CvCLONED_on(cv);
+ if (CvANON(proto))
+ CvANON_on(cv);
+
+#ifdef USE_THREADS
+ New(666, CvMUTEXP(cv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(cv));
+ CvOWNER(cv) = 0;
+#endif /* USE_THREADS */
+ CvFILEGV(cv) = CvFILEGV(proto);
+ CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
+ CvSTASH(cv) = CvSTASH(proto);
+ CvROOT(cv) = CvROOT(proto);
+ CvSTART(cv) = CvSTART(proto);
+ if (outside)
+ CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
+
+ if (SvPOK(proto))
+ sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
+
+ PL_comppad_name = newAV();
+ for (ix = fname; ix >= 0; ix--)
+ av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
+
+ PL_comppad = newAV();
+
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, (SV*)PL_comppad_name);
+ av_store(comppadlist, 1, (SV*)PL_comppad);
+ CvPADLIST(cv) = comppadlist;
+ av_fill(PL_comppad, AvFILLp(protopad));
+ PL_curpad = AvARRAY(PL_comppad);
+
+ av = newAV(); /* will be @_ */
+ av_extend(av, 0);
+ av_store(PL_comppad, 0, (SV*)av);
+ AvFLAGS(av) = AVf_REIFY;
+
+ for (ix = fpad; ix > 0; ix--) {
+ SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
+ if (namesv && namesv != &PL_sv_undef) {
+ char *name = SvPVX(namesv); /* XXX */
+ if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
+ I32 off = pad_findlex(name, ix, SvIVX(namesv),
+ CvOUTSIDE(cv), cxstack_ix);
+ if (!off)
+ PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
+ else if (off != ix)
+ croak("panic: cv_clone: %s", name);
+ }
+ else { /* our own lexical */
+ SV* sv;
+ if (*name == '&') {
+ /* anon code -- we'll come back for it */
+ sv = SvREFCNT_inc(ppad[ix]);
+ }
+ else if (*name == '@')
+ sv = (SV*)newAV();
+ else if (*name == '%')
+ sv = (SV*)newHV();
+ else
+ sv = NEWSV(0,0);
+ if (!SvPADBUSY(sv))
+ SvPADMY_on(sv);
+ PL_curpad[ix] = sv;
+ }
+ }
+ else {
+ SV* sv = NEWSV(0,0);
+ SvPADTMP_on(sv);
+ PL_curpad[ix] = sv;
+ }
+ }
+
+ /* Now that vars are all in place, clone nested closures. */
+
+ for (ix = fpad; ix > 0; ix--) {
+ SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
+ if (namesv
+ && namesv != &PL_sv_undef
+ && !(SvFLAGS(namesv) & SVf_FAKE)
+ && *SvPVX(namesv) == '&'
+ && CvCLONE(ppad[ix]))
+ {
+ CV *kid = cv_clone2((CV*)ppad[ix], cv);
+ SvREFCNT_dec(ppad[ix]);
+ CvCLONE_on(kid);
+ SvPADMY_on(kid);
+ PL_curpad[ix] = (SV*)kid;
+ }
+ }
+
+#ifdef DEBUG_CLOSURES
+ PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
+ cv_dump(outside);
+ PerlIO_printf(Perl_debug_log, " from:\n");
+ cv_dump(proto);
+ PerlIO_printf(Perl_debug_log, " to:\n");
+ cv_dump(cv);
+#endif
+
+ LEAVE;
+ return cv;
+}
+
+CV *
+cv_clone(CV *proto)
+{
+ return cv_clone2(proto, CvOUTSIDE(proto));
+}
+
+void
+cv_ckproto(CV *cv, GV *gv, char *p)
+{
+ if ((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) {
+ SV* msg = sv_newmortal();
+ SV* name = Nullsv;
+
+ if (gv)
+ gv_efullname3(name = sv_newmortal(), gv, Nullch);
+ sv_setpv(msg, "Prototype mismatch:");
+ if (name)
+ sv_catpvf(msg, " sub %_", name);
+ if (SvPOK(cv))
+ sv_catpvf(msg, " (%s)", SvPVX(cv));
+ sv_catpv(msg, " vs ");
+ if (p)
+ sv_catpvf(msg, "(%s)", p);
+ else
+ sv_catpv(msg, "none");
+ warn("%_", msg);
+ }
+}
+
+SV *
+cv_const_sv(CV *cv)
+{
+ if (!cv || !SvPOK(cv) || SvCUR(cv))
+ return Nullsv;
+ return op_const_sv(CvSTART(cv), cv);
+}
+
+SV *
+op_const_sv(OP *o, CV *cv)
+{
+ SV *sv = Nullsv;
+
+ if(!o)
+ return Nullsv;
+
+ if(o->op_type == OP_LINESEQ && cLISTOPo->op_first)
+ o = cLISTOPo->op_first->op_sibling;
+
+ for (; o; o = o->op_next) {
+ OPCODE type = o->op_type;
+
+ if(sv && o->op_next == o)
+ return sv;
+ if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
+ continue;
+ if (type == OP_LEAVESUB || type == OP_RETURN)
+ break;
+ if (sv)
+ return Nullsv;
+ if (type == OP_CONST)
+ sv = cSVOPo->op_sv;
+ else if (type == OP_PADSV && cv) {
+ AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
+ sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
+ if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
+ return Nullsv;
+ }
+ else
+ return Nullsv;
+ }
+ if (sv)
+ SvREADONLY_on(sv);
+ return sv;
+}
+
+CV *
+newSUB(I32 floor, OP *o, OP *proto, OP *block)
+{
+ dTHR;
+ char *name = o ? SvPVx(cSVOPo->op_sv, PL_na) : 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;
+ register CV *cv=0;
+ I32 ix;
+
+ if (o)
+ SAVEFREEOP(o);
+ if (proto)
+ SAVEFREEOP(proto);
+
+ if (SvTYPE(gv) != SVt_PVGV) { /* Prototype now, and had
+ maximum a prototype before. */
+ if (SvTYPE(gv) > SVt_NULL) {
+ if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1))
+ warn("Runaway prototype");
+ cv_ckproto((CV*)gv, NULL, ps);
+ }
+ if (ps)
+ sv_setpv((SV*)gv, ps);
+ else
+ sv_setiv((SV*)gv, -1);
+ SvREFCNT_dec(PL_compcv);
+ cv = PL_compcv = NULL;
+ PL_sub_generation++;
+ goto noblock;
+ }
+
+ if (!name || GvCVGEN(gv))
+ cv = Nullcv;
+ else if (cv = GvCV(gv)) {
+ cv_ckproto(cv, gv, ps);
+ /* already defined (or promised)? */
+ if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
+ SV* const_sv;
+ bool const_changed = TRUE;
+ if (!block) {
+ /* just a "sub foo;" when &foo is already defined */
+ SAVEFREESV(PL_compcv);
+ goto done;
+ }
+ /* ahem, death to those who redefine active sort subs */
+ if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
+ croak("Can't redefine active sort subroutine %s", name);
+ if(const_sv = cv_const_sv(cv))
+ const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
+ if ((const_sv && const_changed) || PL_dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
+ && HvNAME(GvSTASH(CvGV(cv)))
+ && strEQ(HvNAME(GvSTASH(CvGV(cv))),
+ "autouse"))) {
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+ warn(const_sv ? "Constant subroutine %s redefined"
+ : "Subroutine %s redefined", name);
+ PL_curcop->cop_line = oldline;
+ }
+ SvREFCNT_dec(cv);
+ cv = Nullcv;
+ }
+ }
+ if (cv) { /* must reuse cv if autoloaded */
+ cv_undef(cv);
+ CvFLAGS(cv) = CvFLAGS(PL_compcv);
+ CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
+ CvOUTSIDE(PL_compcv) = 0;
+ CvPADLIST(cv) = CvPADLIST(PL_compcv);
+ CvPADLIST(PL_compcv) = 0;
+ if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
+ CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
+ SvREFCNT_dec(PL_compcv);
+ }
+ else {
+ cv = PL_compcv;
+ if (name) {
+ GvCV(gv) = cv;
+ GvCVGEN(gv) = 0;
+ PL_sub_generation++;
+ }
+ }
+ CvGV(cv) = (GV*)SvREFCNT_inc(gv);
+ CvFILEGV(cv) = PL_curcop->cop_filegv;
+ CvSTASH(cv) = PL_curstash;
+#ifdef USE_THREADS
+ CvOWNER(cv) = 0;
+ if (!CvMUTEXP(cv))
+ New(666, CvMUTEXP(cv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(cv));
+#endif /* USE_THREADS */
+
+ if (ps)
+ sv_setpv((SV*)cv, ps);
+
+ if (PL_error_count) {
+ op_free(block);
+ block = Nullop;
+ if (name) {
+ char *s = strrchr(name, ':');
+ s = s ? s+1 : name;
+ if (strEQ(s, "BEGIN")) {
+ char *not_safe =
+ "BEGIN not safe after errors--compilation aborted";
+ if (PL_in_eval & 4)
+ croak(not_safe);
+ else {
+ /* force display of errors found but not reported */
+ sv_catpv(ERRSV, not_safe);
+ croak("%s", SvPVx(ERRSV, PL_na));
+ }
+ }
+ }
+ }
+ if (!block) {
+ noblock:
+ PL_copline = NOLINE;
+ LEAVE_SCOPE(floor);
+ return cv;
+ }
+
+ if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
+ av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
+
+ if (CvCLONE(cv)) {
+ SV **namep = AvARRAY(PL_comppad_name);
+ for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
+ SV *namesv;
+
+ if (SvIMMORTAL(PL_curpad[ix]))
+ continue;
+ /*
+ * The only things that a clonable function needs in its
+ * pad are references to outer lexicals and anonymous subs.
+ * The rest are created anew during cloning.
+ */
+ if (!((namesv = namep[ix]) != Nullsv &&
+ namesv != &PL_sv_undef &&
+ (SvFAKE(namesv) ||
+ *SvPVX(namesv) == '&')))
+ {
+ SvREFCNT_dec(PL_curpad[ix]);
+ PL_curpad[ix] = Nullsv;
+ }
+ }
+ }
+ else {
+ AV *av = newAV(); /* Will be @_ */
+ av_extend(av, 0);
+ av_store(PL_comppad, 0, (SV*)av);
+ AvFLAGS(av) = AVf_REIFY;
+
+ for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
+ if (SvIMMORTAL(PL_curpad[ix]))
+ continue;
+ if (!SvPADMY(PL_curpad[ix]))
+ SvPADTMP_on(PL_curpad[ix]);
+ }
+ }
+
+ CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvSTART(cv) = LINKLIST(CvROOT(cv));
+ CvROOT(cv)->op_next = 0;
+ peep(CvSTART(cv));
+
+ if (name) {
+ char *s;
+
+ if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
+ SV *sv = NEWSV(0,0);
+ SV *tmpstr = sv_newmortal();
+ GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
+ CV *cv;
+ HV *hv;
+
+ sv_setpvf(sv, "%_:%ld-%ld",
+ GvSV(PL_curcop->cop_filegv),
+ (long)PL_subline, (long)PL_curcop->cop_line);
+ gv_efullname3(tmpstr, gv, Nullch);
+ hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
+ hv = GvHVn(db_postponed);
+ if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
+ && (cv = GvCV(db_postponed))) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(tmpstr);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
+ }
+
+ if ((s = strrchr(name,':')))
+ s++;
+ else
+ s = name;
+ if (strEQ(s, "BEGIN")) {
+ I32 oldscope = PL_scopestack_ix;
+ ENTER;
+ SAVESPTR(PL_compiling.cop_filegv);
+ SAVEI16(PL_compiling.cop_line);
+ save_svref(&PL_rs);
+ sv_setsv(PL_rs, PL_nrs);
+
+ if (!PL_beginav)
+ PL_beginav = newAV();
+ DEBUG_x( dump_sub(gv) );
+ av_push(PL_beginav, (SV *)cv);
+ GvCV(gv) = 0;
+ call_list(oldscope, PL_beginav);
+
+ PL_curcop = &PL_compiling;
+ LEAVE;
+ }
+ else if (strEQ(s, "END") && !PL_error_count) {
+ if (!PL_endav)
+ PL_endav = newAV();
+ av_unshift(PL_endav, 1);
+ av_store(PL_endav, 0, (SV *)cv);
+ GvCV(gv) = 0;
+ }
+ else if (strEQ(s, "INIT") && !PL_error_count) {
+ if (!PL_initav)
+ PL_initav = newAV();
+ av_push(PL_initav, SvREFCNT_inc(cv));
+ GvCV(gv) = 0;
+ }
+ }
+
+ done:
+ PL_copline = NOLINE;
+ LEAVE_SCOPE(floor);
+ return cv;
+}
+
+void
+newCONSTSUB(HV *stash, char *name, SV *sv)
+{
+ dTHR;
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if(stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+ start_subparse(FALSE, 0),
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+
+CV *
+newXS(char *name, void (*subaddr) (CV * _CPERLproto), char *filename)
+{
+ dTHR;
+ GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
+ register CV *cv;
+
+ if (cv = (name ? GvCV(gv) : Nullcv)) {
+ if (GvCVGEN(gv)) {
+ /* just a cached method */
+ SvREFCNT_dec(cv);
+ cv = 0;
+ }
+ else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
+ /* already defined (or promised) */
+ if (PL_dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
+ && HvNAME(GvSTASH(CvGV(cv)))
+ && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+ warn("Subroutine %s redefined",name);
+ PL_curcop->cop_line = oldline;
+ }
+ SvREFCNT_dec(cv);
+ cv = 0;
+ }
+ }
+
+ if (cv) /* must reuse cv if autoloaded */
+ cv_undef(cv);
+ else {
+ cv = (CV*)NEWSV(1105,0);
+ sv_upgrade((SV *)cv, SVt_PVCV);
+ if (name) {
+ GvCV(gv) = cv;
+ GvCVGEN(gv) = 0;
+ PL_sub_generation++;
+ }
+ }
+ CvGV(cv) = (GV*)SvREFCNT_inc(gv);
+#ifdef USE_THREADS
+ New(666, CvMUTEXP(cv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(cv));
+ CvOWNER(cv) = 0;
+#endif /* USE_THREADS */
+ CvFILEGV(cv) = gv_fetchfile(filename);
+ CvXSUB(cv) = subaddr;
+
+ if (name) {
+ char *s = strrchr(name,':');
+ if (s)
+ s++;
+ else
+ s = name;
+ if (strEQ(s, "BEGIN")) {
+ if (!PL_beginav)
+ PL_beginav = newAV();
+ av_push(PL_beginav, (SV *)cv);
+ GvCV(gv) = 0;
+ }
+ else if (strEQ(s, "END")) {
+ if (!PL_endav)
+ PL_endav = newAV();
+ av_unshift(PL_endav, 1);
+ av_store(PL_endav, 0, (SV *)cv);
+ GvCV(gv) = 0;
+ }
+ else if (strEQ(s, "INIT")) {
+ if (!PL_initav)
+ PL_initav = newAV();
+ av_push(PL_initav, (SV *)cv);
+ }
+ }
+ else
+ CvANON_on(cv);
+
+ return cv;
+}
+
+void
+newFORM(I32 floor, OP *o, OP *block)
+{
+ dTHR;
+ register CV *cv;
+ char *name;
+ GV *gv;
+ I32 ix;
+
+ if (o)
+ name = SvPVx(cSVOPo->op_sv, PL_na);
+ else
+ name = "STDOUT";
+ gv = gv_fetchpv(name,TRUE, SVt_PVFM);
+ GvMULTI_on(gv);
+ if (cv = GvFORM(gv)) {
+ if (PL_dowarn) {
+ line_t oldline = PL_curcop->cop_line;
+
+ PL_curcop->cop_line = PL_copline;
+ warn("Format %s redefined",name);
+ PL_curcop->cop_line = oldline;
+ }
+ SvREFCNT_dec(cv);
+ }
+ cv = PL_compcv;
+ GvFORM(gv) = cv;
+ CvGV(cv) = (GV*)SvREFCNT_inc(gv);
+ CvFILEGV(cv) = PL_curcop->cop_filegv;
+
+ for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
+ if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
+ SvPADTMP_on(PL_curpad[ix]);
+ }
+
+ CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
+ CvSTART(cv) = LINKLIST(CvROOT(cv));
+ CvROOT(cv)->op_next = 0;
+ peep(CvSTART(cv));
+ op_free(o);
+ PL_copline = NOLINE;
+ LEAVE_SCOPE(floor);
+}
+
+OP *
+newANONLIST(OP *o)
+{
+ return newUNOP(OP_REFGEN, 0,
+ mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
+}
+
+OP *
+newANONHASH(OP *o)
+{
+ return newUNOP(OP_REFGEN, 0,
+ mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
+}
+
+OP *
+newANONSUB(I32 floor, OP *proto, OP *block)
+{
+ return newUNOP(OP_REFGEN, 0,
+ newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, proto, block)));
+}
+
+OP *
+oopsAV(OP *o)
+{
+ switch (o->op_type) {
+ case OP_PADSV:
+ o->op_type = OP_PADAV;
+ o->op_ppaddr = ppaddr[OP_PADAV];
+ return ref(newUNOP(OP_RV2AV, 0, scalar(o)), OP_RV2AV);
+
+ case OP_RV2SV:
+ o->op_type = OP_RV2AV;
+ o->op_ppaddr = ppaddr[OP_RV2AV];
+ ref(o, OP_RV2AV);
+ break;
+
+ default:
+ warn("oops: oopsAV");
+ break;
+ }
+ return o;
+}
+
+OP *
+oopsHV(OP *o)
+{
+ switch (o->op_type) {
+ case OP_PADSV:
+ case OP_PADAV:
+ o->op_type = OP_PADHV;
+ o->op_ppaddr = ppaddr[OP_PADHV];
+ return ref(newUNOP(OP_RV2HV, 0, scalar(o)), OP_RV2HV);
+
+ case OP_RV2SV:
+ case OP_RV2AV:
+ o->op_type = OP_RV2HV;
+ o->op_ppaddr = ppaddr[OP_RV2HV];
+ ref(o, OP_RV2HV);
+ break;
+
+ default:
+ warn("oops: oopsHV");
+ break;
+ }
+ return o;
+}
+
+OP *
+newAVREF(OP *o)
+{
+ if (o->op_type == OP_PADANY) {
+ o->op_type = OP_PADAV;
+ o->op_ppaddr = ppaddr[OP_PADAV];
+ return o;
+ }
+ return newUNOP(OP_RV2AV, 0, scalar(o));
+}
+
+OP *
+newGVREF(I32 type, OP *o)
+{
+ if (type == OP_MAPSTART)
+ return newUNOP(OP_NULL, 0, o);
+ return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
+}
+
+OP *
+newHVREF(OP *o)
+{
+ if (o->op_type == OP_PADANY) {
+ o->op_type = OP_PADHV;
+ o->op_ppaddr = ppaddr[OP_PADHV];
+ return o;
+ }
+ return newUNOP(OP_RV2HV, 0, scalar(o));
+}
+
+OP *
+oopsCV(OP *o)
+{
+ croak("NOT IMPL LINE %d",__LINE__);
+ /* STUB */
+ return o;
+}
+
+OP *
+newCVREF(I32 flags, OP *o)
+{
+ return newUNOP(OP_RV2CV, flags, scalar(o));
+}
+
+OP *
+newSVREF(OP *o)
+{
+ if (o->op_type == OP_PADANY) {
+ o->op_type = OP_PADSV;
+ o->op_ppaddr = ppaddr[OP_PADSV];
+ return o;
+ }
+ else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
+ o->op_flags |= OPpDONE_SVREF;
+ return o;
+ }
+ return newUNOP(OP_RV2SV, 0, scalar(o));
+}
+
+/* Check routines. */
+
+OP *
+ck_anoncode(OP *o)
+{
+ PADOFFSET ix;
+ SV* name;
+
+ name = NEWSV(1106,0);
+ sv_upgrade(name, SVt_PVNV);
+ sv_setpvn(name, "&", 1);
+ SvIVX(name) = -1;
+ SvNVX(name) = 1;
+ ix = pad_alloc(o->op_type, SVs_PADMY);
+ av_store(PL_comppad_name, ix, name);
+ av_store(PL_comppad, ix, cSVOPo->op_sv);
+ SvPADMY_on(cSVOPo->op_sv);
+ cSVOPo->op_sv = Nullsv;
+ cSVOPo->op_targ = ix;
+ return o;
+}
+
+OP *
+ck_bitop(OP *o)
+{
+ o->op_private = PL_hints;
+ return o;
+}
+
+OP *
+ck_concat(OP *o)
+{
+ if (cUNOPo->op_first->op_type == OP_CONCAT)
+ o->op_flags |= OPf_STACKED;
+ return o;
+}
+
+OP *
+ck_spair(OP *o)
+{
+ if (o->op_flags & OPf_KIDS) {
+ OP* newop;
+ OP* kid;
+ OPCODE type = o->op_type;
+ o = modkids(ck_fun(o), type);
+ kid = cUNOPo->op_first;
+ newop = kUNOP->op_first->op_sibling;
+ if (newop &&
+ (newop->op_sibling ||
+ !(opargs[newop->op_type] & OA_RETSCALAR) ||
+ newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
+ newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
+
+ return o;
+ }
+ op_free(kUNOP->op_first);
+ kUNOP->op_first = newop;
+ }
+ o->op_ppaddr = ppaddr[++o->op_type];
+ return ck_fun(o);
+}
+
+OP *
+ck_delete(OP *o)
+{
+ o = ck_fun(o);
+ o->op_private = 0;
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPo->op_first;
+ if (kid->op_type == OP_HSLICE)
+ o->op_private |= OPpSLICE;
+ else if (kid->op_type != OP_HELEM)
+ croak("%s argument is not a HASH element or slice",
+ op_desc[o->op_type]);
+ null(kid);
+ }
+ return o;
+}
+
+OP *
+ck_eof(OP *o)
+{
+ I32 type = o->op_type;
+
+ if (o->op_flags & OPf_KIDS) {
+ if (cLISTOPo->op_first->op_type == OP_STUB) {
+ op_free(o);
+ o = newUNOP(type, OPf_SPECIAL,
+ newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
+ }
+ return ck_fun(o);
+ }
+ return o;
+}
+
+OP *
+ck_eval(OP *o)
+{
+ PL_hints |= HINT_BLOCK_SCOPE;
+ if (o->op_flags & OPf_KIDS) {
+ SVOP *kid = (SVOP*)cUNOPo->op_first;
+
+ if (!kid) {
+ o->op_flags &= ~OPf_KIDS;
+ null(o);
+ }
+ else if (kid->op_type == OP_LINESEQ) {
+ LOGOP *enter;
+
+ kid->op_next = o->op_next;
+ cUNOPo->op_first = 0;
+ op_free(o);
+
+ Newz(1101, enter, 1, LOGOP);
+ enter->op_type = OP_ENTERTRY;
+ enter->op_ppaddr = ppaddr[OP_ENTERTRY];
+ enter->op_private = 0;
+
+ /* establish postfix order */
+ enter->op_next = (OP*)enter;
+
+ o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
+ o->op_type = OP_LEAVETRY;
+ o->op_ppaddr = ppaddr[OP_LEAVETRY];
+ enter->op_other = o;
+ return o;
+ }
+ else
+ scalar((OP*)kid);
+ }
+ else {
+ op_free(o);
+ o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
+ }
+ o->op_targ = (PADOFFSET)PL_hints;
+ return o;
+}
+
+OP *
+ck_exec(OP *o)
+{
+ OP *kid;
+ if (o->op_flags & OPf_STACKED) {
+ o = ck_fun(o);
+ kid = cUNOPo->op_first->op_sibling;
+ if (kid->op_type == OP_RV2GV)
+ null(kid);
+ }
+ else
+ o = listkids(o);
+ return o;
+}
+
+OP *
+ck_exists(OP *o)
+{
+ o = ck_fun(o);
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPo->op_first;
+ if (kid->op_type != OP_HELEM)
+ croak("%s argument is not a HASH element", op_desc[o->op_type]);
+ null(kid);
+ }
+ return o;
+}
+
+OP *
+ck_gvconst(register OP *o)
+{
+ o = fold_constants(o);
+ if (o->op_type == OP_CONST)
+ o->op_type = OP_GV;
+ return o;
+}
+
+OP *
+ck_rvconst(register OP *o)
+{
+ dTHR;
+ SVOP *kid = (SVOP*)cUNOPo->op_first;
+
+ o->op_private |= (PL_hints & HINT_STRICT_REFS);
+ if (kid->op_type == OP_CONST) {
+ char *name;
+ int iscv;
+ GV *gv;
+
+ name = SvPV(kid->op_sv, PL_na);
+ if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
+ char *badthing = Nullch;
+ switch (o->op_type) {
+ case OP_RV2SV:
+ badthing = "a SCALAR";
+ break;
+ case OP_RV2AV:
+ badthing = "an ARRAY";
+ break;
+ case OP_RV2HV:
+ badthing = "a HASH";
+ break;
+ }
+ if (badthing)
+ croak(
+ "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
+ name, badthing);
+ }
+ /*
+ * This is a little tricky. We only want to add the symbol if we
+ * didn't add it in the lexer. Otherwise we get duplicate strict
+ * warnings. But if we didn't add it in the lexer, we must at
+ * least pretend like we wanted to add it even if it existed before,
+ * or we get possible typo warnings. OPpCONST_ENTERED says
+ * whether the lexer already added THIS instance of this symbol.
+ */
+ iscv = (o->op_type == OP_RV2CV) * 2;
+ do {
+ gv = gv_fetchpv(name,
+ iscv | !(kid->op_private & OPpCONST_ENTERED),
+ iscv
+ ? SVt_PVCV
+ : o->op_type == OP_RV2SV
+ ? SVt_PV
+ : o->op_type == OP_RV2AV
+ ? SVt_PVAV
+ : o->op_type == OP_RV2HV
+ ? SVt_PVHV
+ : SVt_PVGV);
+ } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
+ if (gv) {
+ kid->op_type = OP_GV;
+ SvREFCNT_dec(kid->op_sv);
+ kid->op_sv = SvREFCNT_inc(gv);
+ }
+ }
+ return o;
+}
+
+OP *
+ck_ftst(OP *o)
+{
+ dTHR;
+ I32 type = o->op_type;
+
+ if (o->op_flags & OPf_REF)
+ return o;
+
+ if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
+ SVOP *kid = (SVOP*)cUNOPo->op_first;
+
+ if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ OP *newop = newGVOP(type, OPf_REF,
+ gv_fetchpv(SvPVx(kid->op_sv, PL_na), TRUE, SVt_PVIO));
+ op_free(o);
+ return newop;
+ }
+ }
+ else {
+ op_free(o);
+ if (type == OP_FTTTY)
+ return newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
+ SVt_PVIO));
+ else
+ return newUNOP(type, 0, newDEFSVOP());
+ }
+ return o;
+}
+
+OP *
+ck_fun(OP *o)
+{
+ dTHR;
+ register OP *kid;
+ OP **tokid;
+ OP *sibl;
+ I32 numargs = 0;
+ int type = o->op_type;
+ register I32 oa = opargs[type] >> OASHIFT;
+
+ if (o->op_flags & OPf_STACKED) {
+ if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
+ oa &= ~OA_OPTIONAL;
+ else
+ return no_fh_allowed(o);
+ }
+
+ if (o->op_flags & OPf_KIDS) {
+ tokid = &cLISTOPo->op_first;
+ kid = cLISTOPo->op_first;
+ if (kid->op_type == OP_PUSHMARK ||
+ kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)
+ {
+ tokid = &kid->op_sibling;
+ kid = kid->op_sibling;
+ }
+ if (!kid && opargs[type] & OA_DEFGV)
+ *tokid = kid = newDEFSVOP();
+
+ while (oa && kid) {
+ numargs++;
+ sibl = kid->op_sibling;
+ switch (oa & 7) {
+ case OA_SCALAR:
+ scalar(kid);
+ break;
+ case OA_LIST:
+ if (oa < 16) {
+ kid = 0;
+ continue;
+ }
+ else
+ list(kid);
+ break;
+ case OA_AVREF:
+ if (kid->op_type == OP_CONST &&
+ (kid->op_private & OPpCONST_BARE)) {
+ char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na);
+ OP *newop = newAVREF(newGVOP(OP_GV, 0,
+ gv_fetchpv(name, TRUE, SVt_PVAV) ));
+ if (PL_dowarn)
+ warn("Array @%s missing the @ in argument %ld of %s()",
+ name, (long)numargs, op_desc[type]);
+ op_free(kid);
+ kid = newop;
+ kid->op_sibling = sibl;
+ *tokid = kid;
+ }
+ else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
+ bad_type(numargs, "array", op_desc[o->op_type], kid);
+ mod(kid, type);
+ break;
+ case OA_HVREF:
+ if (kid->op_type == OP_CONST &&
+ (kid->op_private & OPpCONST_BARE)) {
+ char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na);
+ OP *newop = newHVREF(newGVOP(OP_GV, 0,
+ gv_fetchpv(name, TRUE, SVt_PVHV) ));
+ if (PL_dowarn)
+ warn("Hash %%%s missing the %% in argument %ld of %s()",
+ name, (long)numargs, op_desc[type]);
+ op_free(kid);
+ kid = newop;
+ kid->op_sibling = sibl;
+ *tokid = kid;
+ }
+ else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
+ bad_type(numargs, "hash", op_desc[o->op_type], kid);
+ mod(kid, type);
+ break;
+ case OA_CVREF:
+ {
+ OP *newop = newUNOP(OP_NULL, 0, kid);
+ kid->op_sibling = 0;
+ linklist(kid);
+ newop->op_next = newop;
+ kid = newop;
+ kid->op_sibling = sibl;
+ *tokid = kid;
+ }
+ break;
+ case OA_FILEREF:
+ if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
+ 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,
+ SVt_PVIO) );
+ op_free(kid);
+ kid = newop;
+ }
+ else {
+ kid->op_sibling = 0;
+ kid = newUNOP(OP_RV2GV, 0, scalar(kid));
+ }
+ kid->op_sibling = sibl;
+ *tokid = kid;
+ }
+ scalar(kid);
+ break;
+ case OA_SCALARREF:
+ mod(scalar(kid), type);
+ break;
+ }
+ oa >>= 4;
+ tokid = &kid->op_sibling;
+ kid = kid->op_sibling;
+ }
+ o->op_private |= numargs;
+ if (kid)
+ return too_many_arguments(o,op_desc[o->op_type]);
+ listkids(o);
+ }
+ else if (opargs[type] & OA_DEFGV) {
+ op_free(o);
+ return newUNOP(type, 0, newDEFSVOP());
+ }
+
+ if (oa) {
+ while (oa & OA_OPTIONAL)
+ oa >>= 4;
+ if (oa && oa != OA_LIST)
+ return too_few_arguments(o,op_desc[o->op_type]);
+ }
+ return o;
+}
+
+OP *
+ck_glob(OP *o)
+{
+ GV *gv;
+
+ if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
+ append_elem(OP_GLOB, o, newDEFSVOP());
+
+ if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
+ gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
+
+ if (gv && GvIMPORTED_CV(gv)) {
+ static int glob_index;
+
+ append_elem(OP_GLOB, o,
+ newSVOP(OP_CONST, 0, newSViv(glob_index++)));
+ o->op_type = OP_LIST;
+ o->op_ppaddr = ppaddr[OP_LIST];
+ cLISTOPo->op_first->op_type = OP_PUSHMARK;
+ cLISTOPo->op_first->op_ppaddr = ppaddr[OP_PUSHMARK];
+ o = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, o,
+ scalar(newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0, gv)))));
+ o = newUNOP(OP_NULL, 0, ck_subr(o));
+ o->op_targ = OP_GLOB; /* hint at what it used to be */
+ return o;
+ }
+ gv = newGVgen("main");
+ gv_IOadd(gv);
+ append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
+ scalarkids(o);
+ return ck_fun(o);
+}
+
+OP *
+ck_grep(OP *o)
+{
+ LOGOP *gwop;
+ OP *kid;
+ OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
+
+ o->op_ppaddr = ppaddr[OP_GREPSTART];
+ Newz(1101, gwop, 1, LOGOP);
+
+ if (o->op_flags & OPf_STACKED) {
+ OP* k;
+ o = ck_sort(o);
+ kid = cLISTOPo->op_first->op_sibling;
+ for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
+ kid = k;
+ }
+ kid->op_next = (OP*)gwop;
+ o->op_flags &= ~OPf_STACKED;
+ }
+ kid = cLISTOPo->op_first->op_sibling;
+ if (type == OP_MAPWHILE)
+ list(kid);
+ else
+ scalar(kid);
+ o = ck_fun(o);
+ if (PL_error_count)
+ return o;
+ kid = cLISTOPo->op_first->op_sibling;
+ if (kid->op_type != OP_NULL)
+ croak("panic: ck_grep");
+ kid = kUNOP->op_first;
+
+ gwop->op_type = type;
+ gwop->op_ppaddr = ppaddr[type];
+ gwop->op_first = listkids(o);
+ gwop->op_flags |= OPf_KIDS;
+ gwop->op_private = 1;
+ gwop->op_other = LINKLIST(kid);
+ gwop->op_targ = pad_alloc(type, SVs_PADTMP);
+ kid->op_next = (OP*)gwop;
+
+ kid = cLISTOPo->op_first->op_sibling;
+ if (!kid || !kid->op_sibling)
+ return too_few_arguments(o,op_desc[o->op_type]);
+ for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
+ mod(kid, OP_GREPSTART);
+
+ return (OP*)gwop;
+}
+
+OP *
+ck_index(OP *o)
+{
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ if (kid && kid->op_type == OP_CONST)
+ fbm_compile(((SVOP*)kid)->op_sv, 0);
+ }
+ return ck_fun(o);
+}
+
+OP *
+ck_lengthconst(OP *o)
+{
+ /* XXX length optimization goes here */
+ return ck_fun(o);
+}
+
+OP *
+ck_lfun(OP *o)
+{
+ OPCODE type = o->op_type;
+ return modkids(ck_fun(o), type);
+}
+
+OP *
+ck_rfun(OP *o)
+{
+ OPCODE type = o->op_type;
+ return refkids(ck_fun(o), type);
+}
+
+OP *
+ck_listiob(OP *o)
+{
+ register OP *kid;
+
+ kid = cLISTOPo->op_first;
+ if (!kid) {
+ o = force_list(o);
+ kid = cLISTOPo->op_first;
+ }
+ if (kid->op_type == OP_PUSHMARK)
+ kid = kid->op_sibling;
+ if (kid && o->op_flags & OPf_STACKED)
+ kid = kid->op_sibling;
+ else if (kid && !kid->op_sibling) { /* print HANDLE; */
+ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
+ o->op_flags |= OPf_STACKED; /* make it a filehandle */
+ kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
+ cLISTOPo->op_first->op_sibling = kid;
+ cLISTOPo->op_last = kid;
+ kid = kid->op_sibling;
+ }
+ }
+
+ if (!kid)
+ append_elem(o->op_type, o, newDEFSVOP());
+
+ o = listkids(o);
+
+ o->op_private = 0;
+#ifdef USE_LOCALE
+ if (PL_hints & HINT_LOCALE)
+ o->op_private |= OPpLOCALE;
+#endif
+
+ return o;
+}
+
+OP *
+ck_fun_locale(OP *o)
+{
+ o = ck_fun(o);
+
+ o->op_private = 0;
+#ifdef USE_LOCALE
+ if (PL_hints & HINT_LOCALE)
+ o->op_private |= OPpLOCALE;
+#endif
+
+ return o;
+}
+
+OP *
+ck_scmp(OP *o)
+{
+ o->op_private = 0;
+#ifdef USE_LOCALE
+ if (PL_hints & HINT_LOCALE)
+ o->op_private |= OPpLOCALE;
+#endif
+
+ return o;
+}
+
+OP *
+ck_match(OP *o)
+{
+ o->op_private |= OPpRUNTIME;
+ return o;
+}
+
+OP *
+ck_null(OP *o)
+{
+ return o;
+}
+
+OP *
+ck_repeat(OP *o)
+{
+ if (cBINOPo->op_first->op_flags & OPf_PARENS) {
+ o->op_private |= OPpREPEAT_DOLIST;
+ cBINOPo->op_first = force_list(cBINOPo->op_first);
+ }
+ else
+ scalar(o);
+ return o;
+}
+
+OP *
+ck_require(OP *o)
+{
+ if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
+ SVOP *kid = (SVOP*)cUNOPo->op_first;
+
+ if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+ char *s;
+ for (s = SvPVX(kid->op_sv); *s; s++) {
+ if (*s == ':' && s[1] == ':') {
+ *s = '/';
+ Move(s+2, s+1, strlen(s+2)+1, char);
+ --SvCUR(kid->op_sv);
+ }
+ }
+ sv_catpvn(kid->op_sv, ".pm", 3);
+ }
+ }
+ return ck_fun(o);
+}
+
+OP *
+ck_retarget(OP *o)
+{
+ croak("NOT IMPL LINE %d",__LINE__);
+ /* STUB */
+ return o;
+}
+
+OP *
+ck_select(OP *o)
+{
+ OP* kid;
+ if (o->op_flags & OPf_KIDS) {
+ kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ if (kid && kid->op_sibling) {
+ o->op_type = OP_SSELECT;
+ o->op_ppaddr = ppaddr[OP_SSELECT];
+ o = ck_fun(o);
+ return fold_constants(o);
+ }
+ }
+ o = ck_fun(o);
+ kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ if (kid && kid->op_type == OP_RV2GV)
+ kid->op_private &= ~HINT_STRICT_REFS;
+ return o;
+}
+
+OP *
+ck_shift(OP *o)
+{
+ I32 type = o->op_type;
+
+ if (!(o->op_flags & OPf_KIDS)) {
+ OP *argop;
+
+ op_free(o);
+#ifdef USE_THREADS
+ if (!CvUNIQUE(PL_compcv)) {
+ argop = newOP(OP_PADAV, OPf_REF);
+ argop->op_targ = 0; /* PL_curpad[0] is @_ */
+ }
+ else {
+ argop = newUNOP(OP_RV2AV, 0,
+ scalar(newGVOP(OP_GV, 0,
+ gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
+ }
+#else
+ argop = newUNOP(OP_RV2AV, 0,
+ scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
+ PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
+#endif /* USE_THREADS */
+ return newUNOP(type, 0, scalar(argop));
+ }
+ return scalar(modkids(ck_fun(o), type));
+}
+
+OP *
+ck_sort(OP *o)
+{
+ o->op_private = 0;
+#ifdef USE_LOCALE
+ if (PL_hints & HINT_LOCALE)
+ o->op_private |= OPpLOCALE;
+#endif
+
+ if (o->op_flags & OPf_STACKED) {
+ OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ OP *k;
+ kid = kUNOP->op_first; /* get past rv2gv */
+
+ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
+ linklist(kid);
+ if (kid->op_type == OP_SCOPE) {
+ k = kid->op_next;
+ kid->op_next = 0;
+ }
+ else if (kid->op_type == OP_LEAVE) {
+ if (o->op_type == OP_SORT) {
+ null(kid); /* wipe out leave */
+ kid->op_next = kid;
+
+ for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
+ if (k->op_next == kid)
+ k->op_next = 0;
+ }
+ }
+ else
+ kid->op_next = 0; /* just disconnect the leave */
+ k = kLISTOP->op_first;
+ }
+ peep(k);
+
+ kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+ null(kid); /* wipe out rv2gv */
+ if (o->op_type == OP_SORT)
+ kid->op_next = kid;
+ else
+ kid->op_next = k;
+ o->op_flags |= OPf_SPECIAL;
+ }
+ }
+
+ return o;
+}
+
+OP *
+ck_split(OP *o)
+{
+ register OP *kid;
+
+ if (o->op_flags & OPf_STACKED)
+ return no_fh_allowed(o);
+
+ kid = cLISTOPo->op_first;
+ if (kid->op_type != OP_NULL)
+ croak("panic: ck_split");
+ kid = kid->op_sibling;
+ op_free(cLISTOPo->op_first);
+ cLISTOPo->op_first = kid;
+ if (!kid) {
+ cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1));
+ cLISTOPo->op_last = kid; /* There was only one element previously */
+ }
+
+ if (kid->op_type != OP_MATCH) {
+ OP *sibl = kid->op_sibling;
+ kid->op_sibling = 0;
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
+ if (cLISTOPo->op_first == cLISTOPo->op_last)
+ cLISTOPo->op_last = kid;
+ cLISTOPo->op_first = kid;
+ kid->op_sibling = sibl;
+ }
+
+ kid->op_type = OP_PUSHRE;
+ kid->op_ppaddr = ppaddr[OP_PUSHRE];
+ scalar(kid);
+
+ if (!kid->op_sibling)
+ append_elem(OP_SPLIT, o, newDEFSVOP());
+
+ kid = kid->op_sibling;
+ scalar(kid);
+
+ if (!kid->op_sibling)
+ append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
+
+ kid = kid->op_sibling;
+ scalar(kid);
+
+ if (kid->op_sibling)
+ return too_many_arguments(o,op_desc[o->op_type]);
+
+ return o;
+}
+
+OP *
+ck_subr(OP *o)
+{
+ dTHR;
+ OP *prev = ((cUNOPo->op_first->op_sibling)
+ ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
+ OP *o2 = prev->op_sibling;
+ OP *cvop;
+ char *proto = 0;
+ CV *cv = 0;
+ GV *namegv = 0;
+ int optional = 0;
+ I32 arg = 0;
+
+ for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
+ if (cvop->op_type == OP_RV2CV) {
+ SVOP* tmpop;
+ o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
+ null(cvop); /* disable rv2cv */
+ tmpop = (SVOP*)((UNOP*)cvop)->op_first;
+ if (tmpop->op_type == OP_GV) {
+ 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);
+ }
+ }
+ }
+ o->op_private |= (PL_hints & HINT_STRICT_REFS);
+ if (PERLDB_SUB && PL_curstash != PL_debstash)
+ o->op_private |= OPpENTERSUB_DB;
+ while (o2 != cvop) {
+ if (proto) {
+ switch (*proto) {
+ case '\0':
+ return too_many_arguments(o, gv_ename(namegv));
+ case ';':
+ optional = 1;
+ proto++;
+ continue;
+ case '$':
+ proto++;
+ arg++;
+ scalar(o2);
+ break;
+ case '%':
+ case '@':
+ list(o2);
+ arg++;
+ break;
+ case '&':
+ proto++;
+ arg++;
+ if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
+ bad_type(arg, "block", gv_ename(namegv), o2);
+ break;
+ case '*':
+ proto++;
+ arg++;
+ if (o2->op_type == OP_RV2GV)
+ goto wrapref;
+ {
+ OP* kid = o2;
+ OP* sib = kid->op_sibling;
+ kid->op_sibling = 0;
+ o2 = newUNOP(OP_RV2GV, 0, kid);
+ o2->op_sibling = sib;
+ prev->op_sibling = o2;
+ }
+ goto wrapref;
+ case '\\':
+ proto++;
+ arg++;
+ switch (*proto++) {
+ case '*':
+ if (o2->op_type != OP_RV2GV)
+ bad_type(arg, "symbol", gv_ename(namegv), o2);
+ goto wrapref;
+ case '&':
+ if (o2->op_type != OP_RV2CV)
+ bad_type(arg, "sub", gv_ename(namegv), o2);
+ goto wrapref;
+ case '$':
+ if (o2->op_type != OP_RV2SV
+ && o2->op_type != OP_PADSV
+ && o2->op_type != OP_THREADSV)
+ {
+ bad_type(arg, "scalar", gv_ename(namegv), o2);
+ }
+ goto wrapref;
+ case '@':
+ if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
+ bad_type(arg, "array", gv_ename(namegv), o2);
+ goto wrapref;
+ case '%':
+ if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
+ bad_type(arg, "hash", gv_ename(namegv), o2);
+ wrapref:
+ {
+ OP* kid = o2;
+ OP* sib = kid->op_sibling;
+ kid->op_sibling = 0;
+ o2 = newUNOP(OP_REFGEN, 0, kid);
+ o2->op_sibling = sib;
+ prev->op_sibling = o2;
+ }
+ break;
+ default: goto oops;
+ }
+ break;
+ case ' ':
+ proto++;
+ continue;
+ default:
+ oops:
+ croak("Malformed prototype for %s: %s",
+ gv_ename(namegv), SvPV((SV*)cv, PL_na));
+ }
+ }
+ else
+ list(o2);
+ mod(o2, OP_ENTERSUB);
+ prev = o2;
+ o2 = o2->op_sibling;
+ }
+ if (proto && !optional &&
+ (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
+ return too_few_arguments(o, gv_ename(namegv));
+ return o;
+}
+
+OP *
+ck_svconst(OP *o)
+{
+ SvREADONLY_on(cSVOPo->op_sv);
+ return o;
+}
+
+OP *
+ck_trunc(OP *o)
+{
+ if (o->op_flags & OPf_KIDS) {
+ SVOP *kid = (SVOP*)cUNOPo->op_first;
+
+ if (kid->op_type == OP_NULL)
+ kid = (SVOP*)kid->op_sibling;
+ if (kid &&
+ kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE))
+ o->op_flags |= OPf_SPECIAL;
+ }
+ return ck_fun(o);
+}
+
+/* A peephole optimizer. We visit the ops in the order they're to execute. */
+
+void
+peep(register OP *o)
+{
+ dTHR;
+ register OP* oldop = 0;
+ if (!o || o->op_seq)
+ return;
+ ENTER;
+ SAVEOP();
+ SAVESPTR(PL_curcop);
+ for (; o; o = o->op_next) {
+ if (o->op_seq)
+ break;
+ if (!PL_op_seqmax)
+ PL_op_seqmax++;
+ PL_op = o;
+ switch (o->op_type) {
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ PL_curcop = ((COP*)o); /* for warnings */
+ o->op_seq = PL_op_seqmax++;
+ break;
+
+ case OP_CONCAT:
+ case OP_CONST:
+ case OP_JOIN:
+ case OP_UC:
+ case OP_UCFIRST:
+ case OP_LC:
+ case OP_LCFIRST:
+ case OP_QUOTEMETA:
+ if (o->op_next && o->op_next->op_type == OP_STRINGIFY)
+ null(o->op_next);
+ o->op_seq = PL_op_seqmax++;
+ break;
+ case OP_STUB:
+ if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
+ o->op_seq = PL_op_seqmax++;
+ break; /* Scalar stub must produce undef. List stub is noop */
+ }
+ goto nothin;
+ case OP_NULL:
+ if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
+ PL_curcop = ((COP*)o);
+ goto nothin;
+ case OP_SCALAR:
+ case OP_LINESEQ:
+ case OP_SCOPE:
+ nothin:
+ if (oldop && o->op_next) {
+ oldop->op_next = o->op_next;
+ continue;
+ }
+ o->op_seq = PL_op_seqmax++;
+ break;
+
+ case OP_GV:
+ if (o->op_next->op_type == OP_RV2SV) {
+ if (!(o->op_next->op_private & OPpDEREF)) {
+ null(o->op_next);
+ o->op_private |= o->op_next->op_private & OPpLVAL_INTRO;
+ o->op_next = o->op_next->op_next;
+ o->op_type = OP_GVSV;
+ o->op_ppaddr = ppaddr[OP_GVSV];
+ }
+ }
+ else if (o->op_next->op_type == OP_RV2AV) {
+ OP* pop = o->op_next->op_next;
+ IV i;
+ if (pop->op_type == OP_CONST &&
+ (PL_op = pop->op_next) &&
+ pop->op_next->op_type == OP_AELEM &&
+ !(pop->op_next->op_private &
+ (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
+ (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
+ <= 255 &&
+ i >= 0)
+ {
+ SvREFCNT_dec(((SVOP*)pop)->op_sv);
+ null(o->op_next);
+ null(pop->op_next);
+ null(pop);
+ o->op_flags |= pop->op_next->op_flags & OPf_MOD;
+ o->op_next = pop->op_next->op_next;
+ o->op_type = OP_AELEMFAST;
+ o->op_ppaddr = ppaddr[OP_AELEMFAST];
+ o->op_private = (U8)i;
+ GvAVn(((GVOP*)o)->op_gv);
+ }
+ }
+ o->op_seq = PL_op_seqmax++;
+ break;
+
+ case OP_PADAV:
+ if (o->op_next->op_type == OP_RV2AV
+ && (o->op_next->op_flags & OPf_REF))
+ {
+ null(o->op_next);
+ o->op_next = o->op_next->op_next;
+ }
+ break;
+
+ case OP_PADHV:
+ if (o->op_next->op_type == OP_RV2HV
+ && (o->op_next->op_flags & OPf_REF))
+ {
+ null(o->op_next);
+ o->op_next = o->op_next->op_next;
+ }
+ break;
+
+ case OP_MAPWHILE:
+ case OP_GREPWHILE:
+ case OP_AND:
+ case OP_OR:
+ o->op_seq = PL_op_seqmax++;
+ while (cLOGOP->op_other->op_type == OP_NULL)
+ cLOGOP->op_other = cLOGOP->op_other->op_next;
+ peep(cLOGOP->op_other);
+ break;
+
+ case OP_COND_EXPR:
+ o->op_seq = PL_op_seqmax++;
+ peep(cCONDOP->op_true);
+ peep(cCONDOP->op_false);
+ break;
+
+ case OP_ENTERLOOP:
+ o->op_seq = PL_op_seqmax++;
+ peep(cLOOP->op_redoop);
+ peep(cLOOP->op_nextop);
+ peep(cLOOP->op_lastop);
+ break;
+
+ case OP_QR:
+ case OP_MATCH:
+ case OP_SUBST:
+ o->op_seq = PL_op_seqmax++;
+ peep(cPMOP->op_pmreplstart);
+ break;
+
+ case OP_EXEC:
+ o->op_seq = PL_op_seqmax++;
+ if (PL_dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) {
+ if (o->op_next->op_sibling &&
+ o->op_next->op_sibling->op_type != OP_EXIT &&
+ o->op_next->op_sibling->op_type != OP_WARN &&
+ o->op_next->op_sibling->op_type != OP_DIE) {
+ line_t oldline = PL_curcop->cop_line;
+
+ PL_curcop->cop_line = ((COP*)o->op_next)->cop_line;
+ warn("Statement unlikely to be reached");
+ warn("(Maybe you meant system() when you said exec()?)\n");
+ PL_curcop->cop_line = oldline;
+ }
+ }
+ break;
+
+ case OP_HELEM: {
+ UNOP *rop;
+ SV *lexname;
+ GV **fields;
+ SV **svp, **indsvp;
+ I32 ind;
+ char *key;
+ STRLEN keylen;
+
+ if (o->op_private & (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO)
+ || ((BINOP*)o)->op_last->op_type != OP_CONST)
+ break;
+ rop = (UNOP*)((BINOP*)o)->op_first;
+ if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
+ break;
+ lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
+ if (!SvOBJECT(lexname))
+ break;
+ fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ if (!fields || !GvHV(*fields))
+ break;
+ svp = &((SVOP*)((BINOP*)o)->op_last)->op_sv;
+ key = SvPV(*svp, keylen);
+ 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)));
+ }
+ ind = SvIV(*indsvp);
+ if (ind < 1)
+ croak("Bad index while coercing array into hash");
+ rop->op_type = OP_RV2AV;
+ rop->op_ppaddr = ppaddr[OP_RV2AV];
+ o->op_type = OP_AELEM;
+ o->op_ppaddr = ppaddr[OP_AELEM];
+ SvREFCNT_dec(*svp);
+ *svp = newSViv(ind);
+ break;
+ }
+
+ default:
+ o->op_seq = PL_op_seqmax++;
+ break;
+ }
+ oldop = o;
+ }
+ LEAVE;
+}
diff --git a/contrib/perl5/op.h b/contrib/perl5/op.h
new file mode 100644
index 000000000000..75e674e143fd
--- /dev/null
+++ b/contrib/perl5/op.h
@@ -0,0 +1,322 @@
+/* op.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * The fields of BASEOP are:
+ * op_next Pointer to next ppcode to execute after this one.
+ * (Top level pre-grafted op points to first op,
+ * but this is replaced when op is grafted in, when
+ * this op will point to the real next op, and the new
+ * parent takes over role of remembering starting op.)
+ * op_ppaddr Pointer to current ppcode's function.
+ * op_type The type of the operation.
+ * op_flags Flags common to all operations. See OPf_* below.
+ * op_private Flags peculiar to a particular operation (BUT,
+ * by default, set to the number of children until
+ * the operation is privatized by a check routine,
+ * which may or may not check number of children).
+ */
+
+typedef U32 PADOFFSET;
+#define NOT_IN_PAD ((PADOFFSET) -1)
+
+#ifdef DEBUGGING_OPS
+#define OPCODE opcode
+#else
+#define OPCODE U16
+#endif
+
+#ifdef BASEOP_DEFINITION
+#define BASEOP BASEOP_DEFINITION
+#else
+#define BASEOP \
+ OP* op_next; \
+ OP* op_sibling; \
+ OP* (CPERLscope(*op_ppaddr))_((ARGSproto)); \
+ PADOFFSET op_targ; \
+ OPCODE op_type; \
+ U16 op_seq; \
+ U8 op_flags; \
+ U8 op_private;
+#endif
+
+#define OP_GIMME(op,dfl) \
+ (((op)->op_flags & OPf_WANT) == OPf_WANT_VOID ? G_VOID : \
+ ((op)->op_flags & OPf_WANT) == OPf_WANT_SCALAR ? G_SCALAR : \
+ ((op)->op_flags & OPf_WANT) == OPf_WANT_LIST ? G_ARRAY : \
+ dfl)
+
+#define GIMME_V OP_GIMME(PL_op, block_gimme())
+
+/* Public flags */
+
+#define OPf_WANT 3 /* Mask for "want" bits: */
+#define OPf_WANT_VOID 1 /* Want nothing */
+#define OPf_WANT_SCALAR 2 /* Want single value */
+#define OPf_WANT_LIST 3 /* Want list of any length */
+#define OPf_KIDS 4 /* There is a firstborn child. */
+#define OPf_PARENS 8 /* This operator was parenthesized. */
+ /* (Or block needs explicit scope entry.) */
+#define OPf_REF 16 /* Certified reference. */
+ /* (Return container, not containee). */
+#define OPf_MOD 32 /* Will modify (lvalue). */
+#define OPf_STACKED 64 /* Some arg is arriving on the stack. */
+#define OPf_SPECIAL 128 /* Do something weird for this op: */
+ /* On local LVAL, don't init local value. */
+ /* On OP_SORT, subroutine is inlined. */
+ /* On OP_NOT, inversion was implicit. */
+ /* On OP_LEAVE, don't restore curpm. */
+ /* On truncate, we truncate filehandle */
+ /* On control verbs, we saw no label */
+ /* On flipflop, we saw ... instead of .. */
+ /* On UNOPs, saw bare parens, e.g. eof(). */
+ /* On OP_ENTERSUB || OP_NULL, saw a "do". */
+ /* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */
+ /* On OP_ENTERITER, loop var is per-thread */
+
+/* old names; don't use in new code, but don't break them, either */
+#define OPf_LIST OPf_WANT_LIST
+#define OPf_KNOW OPf_WANT
+#define GIMME \
+ (PL_op->op_flags & OPf_WANT \
+ ? ((PL_op->op_flags & OPf_WANT) == OPf_WANT_LIST \
+ ? G_ARRAY \
+ : G_SCALAR) \
+ : dowantarray())
+
+/* Private for lvalues */
+#define OPpLVAL_INTRO 128 /* Lvalue must be localized */
+
+/* Private for OP_AASSIGN */
+#define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */
+
+/* Private for OP_SASSIGN */
+#define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */
+
+/* Private for OP_MATCH and OP_SUBST{,CONST} */
+#define OPpRUNTIME 64 /* Pattern coming in on the stack */
+
+/* Private for OP_TRANS */
+#define OPpTRANS_COUNTONLY 8
+#define OPpTRANS_SQUASH 16
+#define OPpTRANS_DELETE 32
+#define OPpTRANS_COMPLEMENT 64
+
+/* Private for OP_REPEAT */
+#define OPpREPEAT_DOLIST 64 /* List replication. */
+
+/* Private for OP_ENTERSUB, OP_RV2?V, OP_?ELEM */
+#define OPpDEREF (32|64) /* Want ref to something: */
+#define OPpDEREF_AV 32 /* Want ref to AV. */
+#define OPpDEREF_HV 64 /* Want ref to HV. */
+#define OPpDEREF_SV (32|64) /* Want ref to SV. */
+ /* OP_ENTERSUB only */
+#define OPpENTERSUB_DB 16 /* Debug subroutine. */
+#define OPpENTERSUB_AMPER 8 /* Used & form to call. */
+ /* OP_?ELEM only */
+#define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */
+ /* for OP_RV2?V, lower bits carry hints */
+
+/* Private for OP_CONST */
+#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */
+#define OPpCONST_ARYBASE 32 /* Was a $[ translated to constant. */
+#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */
+
+/* Private for OP_FLIP/FLOP */
+#define OPpFLIP_LINENUM 64 /* Range arg potentially a line num. */
+
+/* Private for OP_LIST */
+#define OPpLIST_GUESSED 64 /* Guessed that pushmark was needed. */
+
+/* Private for OP_DELETE */
+#define OPpSLICE 64 /* Operating on a list of keys */
+
+/* Private for OP_SORT, OP_PRTF, OP_SPRINTF, string cmp'n, and case changers */
+#define OPpLOCALE 64 /* Use locale */
+
+/* Private for OP_THREADSV */
+#define OPpDONE_SVREF 64 /* Been through newSVREF once */
+
+struct op {
+ BASEOP
+};
+
+struct unop {
+ BASEOP
+ OP * op_first;
+};
+
+struct binop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+};
+
+struct logop {
+ BASEOP
+ OP * op_first;
+ OP * op_other;
+};
+
+struct condop {
+ BASEOP
+ OP * op_first;
+ OP * op_true;
+ OP * op_false;
+};
+
+struct listop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+ U32 op_children;
+};
+
+struct pmop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+ U32 op_children;
+ OP * op_pmreplroot;
+ OP * op_pmreplstart;
+ PMOP * op_pmnext; /* list of all scanpats */
+ REGEXP * op_pmregexp; /* compiled expression */
+ U16 op_pmflags;
+ U16 op_pmpermflags;
+ U8 op_pmdynflags;
+};
+
+#define PMdf_USED 0x01 /* pm has been used once already */
+#define PMdf_TAINTED 0x02 /* pm compiled from tainted pattern */
+
+#define PMf_RETAINT 0x0001 /* taint $1 etc. if target tainted */
+#define PMf_ONCE 0x0002 /* use pattern only once per reset */
+#define PMf_REVERSED 0x0004 /* Should be matched right->left */
+#define PMf_MAYBE_CONST 0x0008 /* replacement contains variables */
+#define PMf_SKIPWHITE 0x0010 /* skip leading whitespace for split */
+#define PMf_WHITE 0x0020 /* pattern is \s+ */
+#define PMf_CONST 0x0040 /* subst replacement is constant */
+#define PMf_KEEP 0x0080 /* keep 1st runtime pattern forever */
+#define PMf_GLOBAL 0x0100 /* pattern had a g modifier */
+#define PMf_CONTINUE 0x0200 /* don't reset pos() if //g fails */
+#define PMf_EVAL 0x0400 /* evaluating replacement as expr */
+#define PMf_LOCALE 0x0800 /* use locale for character types */
+#define PMf_MULTILINE 0x1000 /* assume multiple lines */
+#define PMf_SINGLELINE 0x2000 /* assume single line */
+#define PMf_FOLD 0x4000 /* case insensitivity */
+#define PMf_EXTENDED 0x8000 /* chuck embedded whitespace */
+
+/* mask of bits stored in regexp->reganch */
+#define PMf_COMPILETIME (PMf_MULTILINE|PMf_SINGLELINE|PMf_LOCALE|PMf_FOLD|PMf_EXTENDED)
+
+struct svop {
+ BASEOP
+ SV * op_sv;
+};
+
+struct gvop {
+ BASEOP
+ GV * op_gv;
+};
+
+struct pvop {
+ BASEOP
+ char * op_pv;
+};
+
+struct loop {
+ BASEOP
+ OP * op_first;
+ OP * op_last;
+ U32 op_children;
+ OP * op_redoop;
+ OP * op_nextop;
+ OP * op_lastop;
+};
+
+#define cUNOP ((UNOP*)PL_op)
+#define cBINOP ((BINOP*)PL_op)
+#define cLISTOP ((LISTOP*)PL_op)
+#define cLOGOP ((LOGOP*)PL_op)
+#define cCONDOP ((CONDOP*)PL_op)
+#define cPMOP ((PMOP*)PL_op)
+#define cSVOP ((SVOP*)PL_op)
+#define cGVOP ((GVOP*)PL_op)
+#define cPVOP ((PVOP*)PL_op)
+#define cCOP ((COP*)PL_op)
+#define cLOOP ((LOOP*)PL_op)
+
+#define cUNOPo ((UNOP*)o)
+#define cBINOPo ((BINOP*)o)
+#define cLISTOPo ((LISTOP*)o)
+#define cLOGOPo ((LOGOP*)o)
+#define cCONDOPo ((CONDOP*)o)
+#define cPMOPo ((PMOP*)o)
+#define cSVOPo ((SVOP*)o)
+#define cGVOPo ((GVOP*)o)
+#define cPVOPo ((PVOP*)o)
+#define cCVOPo ((CVOP*)o)
+#define cCOPo ((COP*)o)
+#define cLOOPo ((LOOP*)o)
+
+#define kUNOP ((UNOP*)kid)
+#define kBINOP ((BINOP*)kid)
+#define kLISTOP ((LISTOP*)kid)
+#define kLOGOP ((LOGOP*)kid)
+#define kCONDOP ((CONDOP*)kid)
+#define kPMOP ((PMOP*)kid)
+#define kSVOP ((SVOP*)kid)
+#define kGVOP ((GVOP*)kid)
+#define kPVOP ((PVOP*)kid)
+#define kCOP ((COP*)kid)
+#define kLOOP ((LOOP*)kid)
+
+#define Nullop Null(OP*)
+
+/* Lowest byte of opargs */
+#define OA_MARK 1
+#define OA_FOLDCONST 2
+#define OA_RETSCALAR 4
+#define OA_TARGET 8
+#define OA_RETINTEGER 16
+#define OA_OTHERINT 32
+#define OA_DANGEROUS 64
+#define OA_DEFGV 128
+
+/* The next 4 bits encode op class information */
+#define OA_CLASS_MASK (15 << 8)
+
+#define OA_BASEOP (0 << 8)
+#define OA_UNOP (1 << 8)
+#define OA_BINOP (2 << 8)
+#define OA_LOGOP (3 << 8)
+#define OA_CONDOP (4 << 8)
+#define OA_LISTOP (5 << 8)
+#define OA_PMOP (6 << 8)
+#define OA_SVOP (7 << 8)
+#define OA_GVOP (8 << 8)
+#define OA_PVOP (9 << 8)
+#define OA_LOOP (10 << 8)
+#define OA_COP (11 << 8)
+#define OA_BASEOP_OR_UNOP (12 << 8)
+#define OA_FILESTATOP (13 << 8)
+#define OA_LOOPEXOP (14 << 8)
+
+#define OASHIFT 12
+
+/* Remaining nybbles of opargs */
+#define OA_SCALAR 1
+#define OA_LIST 2
+#define OA_AVREF 3
+#define OA_HVREF 4
+#define OA_CVREF 5
+#define OA_FILEREF 6
+#define OA_SCALARREF 7
+#define OA_OPTIONAL 8
+
diff --git a/contrib/perl5/opcode.h b/contrib/perl5/opcode.h
new file mode 100644
index 000000000000..8f4f00b72070
--- /dev/null
+++ b/contrib/perl5/opcode.h
@@ -0,0 +1,2525 @@
+#define pp_i_preinc pp_preinc
+#define pp_i_predec pp_predec
+#define pp_i_postinc pp_postinc
+#define pp_i_postdec pp_postdec
+
+typedef enum {
+ OP_NULL, /* 0 */
+ OP_STUB, /* 1 */
+ OP_SCALAR, /* 2 */
+ OP_PUSHMARK, /* 3 */
+ OP_WANTARRAY, /* 4 */
+ OP_CONST, /* 5 */
+ OP_GVSV, /* 6 */
+ OP_GV, /* 7 */
+ OP_GELEM, /* 8 */
+ OP_PADSV, /* 9 */
+ OP_PADAV, /* 10 */
+ OP_PADHV, /* 11 */
+ OP_PADANY, /* 12 */
+ OP_PUSHRE, /* 13 */
+ OP_RV2GV, /* 14 */
+ OP_RV2SV, /* 15 */
+ OP_AV2ARYLEN, /* 16 */
+ OP_RV2CV, /* 17 */
+ OP_ANONCODE, /* 18 */
+ OP_PROTOTYPE, /* 19 */
+ OP_REFGEN, /* 20 */
+ OP_SREFGEN, /* 21 */
+ OP_REF, /* 22 */
+ OP_BLESS, /* 23 */
+ OP_BACKTICK, /* 24 */
+ OP_GLOB, /* 25 */
+ OP_READLINE, /* 26 */
+ OP_RCATLINE, /* 27 */
+ OP_REGCMAYBE, /* 28 */
+ OP_REGCRESET, /* 29 */
+ OP_REGCOMP, /* 30 */
+ OP_MATCH, /* 31 */
+ OP_QR, /* 32 */
+ OP_SUBST, /* 33 */
+ OP_SUBSTCONT, /* 34 */
+ OP_TRANS, /* 35 */
+ OP_SASSIGN, /* 36 */
+ OP_AASSIGN, /* 37 */
+ OP_CHOP, /* 38 */
+ OP_SCHOP, /* 39 */
+ OP_CHOMP, /* 40 */
+ OP_SCHOMP, /* 41 */
+ OP_DEFINED, /* 42 */
+ OP_UNDEF, /* 43 */
+ OP_STUDY, /* 44 */
+ OP_POS, /* 45 */
+ OP_PREINC, /* 46 */
+ OP_I_PREINC, /* 47 */
+ OP_PREDEC, /* 48 */
+ OP_I_PREDEC, /* 49 */
+ OP_POSTINC, /* 50 */
+ OP_I_POSTINC, /* 51 */
+ OP_POSTDEC, /* 52 */
+ OP_I_POSTDEC, /* 53 */
+ OP_POW, /* 54 */
+ OP_MULTIPLY, /* 55 */
+ OP_I_MULTIPLY, /* 56 */
+ OP_DIVIDE, /* 57 */
+ OP_I_DIVIDE, /* 58 */
+ OP_MODULO, /* 59 */
+ OP_I_MODULO, /* 60 */
+ OP_REPEAT, /* 61 */
+ OP_ADD, /* 62 */
+ OP_I_ADD, /* 63 */
+ OP_SUBTRACT, /* 64 */
+ OP_I_SUBTRACT, /* 65 */
+ OP_CONCAT, /* 66 */
+ OP_STRINGIFY, /* 67 */
+ OP_LEFT_SHIFT, /* 68 */
+ OP_RIGHT_SHIFT, /* 69 */
+ OP_LT, /* 70 */
+ OP_I_LT, /* 71 */
+ OP_GT, /* 72 */
+ OP_I_GT, /* 73 */
+ OP_LE, /* 74 */
+ OP_I_LE, /* 75 */
+ OP_GE, /* 76 */
+ OP_I_GE, /* 77 */
+ OP_EQ, /* 78 */
+ OP_I_EQ, /* 79 */
+ OP_NE, /* 80 */
+ OP_I_NE, /* 81 */
+ OP_NCMP, /* 82 */
+ OP_I_NCMP, /* 83 */
+ OP_SLT, /* 84 */
+ OP_SGT, /* 85 */
+ OP_SLE, /* 86 */
+ OP_SGE, /* 87 */
+ OP_SEQ, /* 88 */
+ OP_SNE, /* 89 */
+ OP_SCMP, /* 90 */
+ OP_BIT_AND, /* 91 */
+ OP_BIT_XOR, /* 92 */
+ OP_BIT_OR, /* 93 */
+ OP_NEGATE, /* 94 */
+ OP_I_NEGATE, /* 95 */
+ OP_NOT, /* 96 */
+ OP_COMPLEMENT, /* 97 */
+ OP_ATAN2, /* 98 */
+ OP_SIN, /* 99 */
+ OP_COS, /* 100 */
+ OP_RAND, /* 101 */
+ OP_SRAND, /* 102 */
+ OP_EXP, /* 103 */
+ OP_LOG, /* 104 */
+ OP_SQRT, /* 105 */
+ OP_INT, /* 106 */
+ OP_HEX, /* 107 */
+ OP_OCT, /* 108 */
+ OP_ABS, /* 109 */
+ OP_LENGTH, /* 110 */
+ OP_SUBSTR, /* 111 */
+ OP_VEC, /* 112 */
+ OP_INDEX, /* 113 */
+ OP_RINDEX, /* 114 */
+ OP_SPRINTF, /* 115 */
+ OP_FORMLINE, /* 116 */
+ OP_ORD, /* 117 */
+ OP_CHR, /* 118 */
+ OP_CRYPT, /* 119 */
+ OP_UCFIRST, /* 120 */
+ OP_LCFIRST, /* 121 */
+ OP_UC, /* 122 */
+ OP_LC, /* 123 */
+ OP_QUOTEMETA, /* 124 */
+ OP_RV2AV, /* 125 */
+ OP_AELEMFAST, /* 126 */
+ OP_AELEM, /* 127 */
+ OP_ASLICE, /* 128 */
+ OP_EACH, /* 129 */
+ OP_VALUES, /* 130 */
+ OP_KEYS, /* 131 */
+ OP_DELETE, /* 132 */
+ OP_EXISTS, /* 133 */
+ OP_RV2HV, /* 134 */
+ OP_HELEM, /* 135 */
+ OP_HSLICE, /* 136 */
+ OP_UNPACK, /* 137 */
+ OP_PACK, /* 138 */
+ OP_SPLIT, /* 139 */
+ OP_JOIN, /* 140 */
+ OP_LIST, /* 141 */
+ OP_LSLICE, /* 142 */
+ OP_ANONLIST, /* 143 */
+ OP_ANONHASH, /* 144 */
+ OP_SPLICE, /* 145 */
+ OP_PUSH, /* 146 */
+ OP_POP, /* 147 */
+ OP_SHIFT, /* 148 */
+ OP_UNSHIFT, /* 149 */
+ OP_SORT, /* 150 */
+ OP_REVERSE, /* 151 */
+ OP_GREPSTART, /* 152 */
+ OP_GREPWHILE, /* 153 */
+ OP_MAPSTART, /* 154 */
+ OP_MAPWHILE, /* 155 */
+ OP_RANGE, /* 156 */
+ OP_FLIP, /* 157 */
+ OP_FLOP, /* 158 */
+ OP_AND, /* 159 */
+ OP_OR, /* 160 */
+ OP_XOR, /* 161 */
+ OP_COND_EXPR, /* 162 */
+ OP_ANDASSIGN, /* 163 */
+ OP_ORASSIGN, /* 164 */
+ OP_METHOD, /* 165 */
+ OP_ENTERSUB, /* 166 */
+ OP_LEAVESUB, /* 167 */
+ OP_CALLER, /* 168 */
+ OP_WARN, /* 169 */
+ OP_DIE, /* 170 */
+ OP_RESET, /* 171 */
+ OP_LINESEQ, /* 172 */
+ OP_NEXTSTATE, /* 173 */
+ OP_DBSTATE, /* 174 */
+ OP_UNSTACK, /* 175 */
+ OP_ENTER, /* 176 */
+ OP_LEAVE, /* 177 */
+ OP_SCOPE, /* 178 */
+ OP_ENTERITER, /* 179 */
+ OP_ITER, /* 180 */
+ OP_ENTERLOOP, /* 181 */
+ OP_LEAVELOOP, /* 182 */
+ OP_RETURN, /* 183 */
+ OP_LAST, /* 184 */
+ OP_NEXT, /* 185 */
+ OP_REDO, /* 186 */
+ OP_DUMP, /* 187 */
+ OP_GOTO, /* 188 */
+ OP_EXIT, /* 189 */
+ OP_OPEN, /* 190 */
+ OP_CLOSE, /* 191 */
+ OP_PIPE_OP, /* 192 */
+ OP_FILENO, /* 193 */
+ OP_UMASK, /* 194 */
+ OP_BINMODE, /* 195 */
+ OP_TIE, /* 196 */
+ OP_UNTIE, /* 197 */
+ OP_TIED, /* 198 */
+ OP_DBMOPEN, /* 199 */
+ OP_DBMCLOSE, /* 200 */
+ OP_SSELECT, /* 201 */
+ OP_SELECT, /* 202 */
+ OP_GETC, /* 203 */
+ OP_READ, /* 204 */
+ OP_ENTERWRITE, /* 205 */
+ OP_LEAVEWRITE, /* 206 */
+ OP_PRTF, /* 207 */
+ OP_PRINT, /* 208 */
+ OP_SYSOPEN, /* 209 */
+ OP_SYSSEEK, /* 210 */
+ OP_SYSREAD, /* 211 */
+ OP_SYSWRITE, /* 212 */
+ OP_SEND, /* 213 */
+ OP_RECV, /* 214 */
+ OP_EOF, /* 215 */
+ OP_TELL, /* 216 */
+ OP_SEEK, /* 217 */
+ OP_TRUNCATE, /* 218 */
+ OP_FCNTL, /* 219 */
+ OP_IOCTL, /* 220 */
+ OP_FLOCK, /* 221 */
+ OP_SOCKET, /* 222 */
+ OP_SOCKPAIR, /* 223 */
+ OP_BIND, /* 224 */
+ OP_CONNECT, /* 225 */
+ OP_LISTEN, /* 226 */
+ OP_ACCEPT, /* 227 */
+ OP_SHUTDOWN, /* 228 */
+ OP_GSOCKOPT, /* 229 */
+ OP_SSOCKOPT, /* 230 */
+ OP_GETSOCKNAME, /* 231 */
+ OP_GETPEERNAME, /* 232 */
+ OP_LSTAT, /* 233 */
+ OP_STAT, /* 234 */
+ OP_FTRREAD, /* 235 */
+ OP_FTRWRITE, /* 236 */
+ OP_FTREXEC, /* 237 */
+ OP_FTEREAD, /* 238 */
+ OP_FTEWRITE, /* 239 */
+ OP_FTEEXEC, /* 240 */
+ OP_FTIS, /* 241 */
+ OP_FTEOWNED, /* 242 */
+ OP_FTROWNED, /* 243 */
+ OP_FTZERO, /* 244 */
+ OP_FTSIZE, /* 245 */
+ OP_FTMTIME, /* 246 */
+ OP_FTATIME, /* 247 */
+ OP_FTCTIME, /* 248 */
+ OP_FTSOCK, /* 249 */
+ OP_FTCHR, /* 250 */
+ OP_FTBLK, /* 251 */
+ OP_FTFILE, /* 252 */
+ OP_FTDIR, /* 253 */
+ OP_FTPIPE, /* 254 */
+ OP_FTLINK, /* 255 */
+ OP_FTSUID, /* 256 */
+ OP_FTSGID, /* 257 */
+ OP_FTSVTX, /* 258 */
+ OP_FTTTY, /* 259 */
+ OP_FTTEXT, /* 260 */
+ OP_FTBINARY, /* 261 */
+ OP_CHDIR, /* 262 */
+ OP_CHOWN, /* 263 */
+ OP_CHROOT, /* 264 */
+ OP_UNLINK, /* 265 */
+ OP_CHMOD, /* 266 */
+ OP_UTIME, /* 267 */
+ OP_RENAME, /* 268 */
+ OP_LINK, /* 269 */
+ OP_SYMLINK, /* 270 */
+ OP_READLINK, /* 271 */
+ OP_MKDIR, /* 272 */
+ OP_RMDIR, /* 273 */
+ OP_OPEN_DIR, /* 274 */
+ OP_READDIR, /* 275 */
+ OP_TELLDIR, /* 276 */
+ OP_SEEKDIR, /* 277 */
+ OP_REWINDDIR, /* 278 */
+ OP_CLOSEDIR, /* 279 */
+ OP_FORK, /* 280 */
+ OP_WAIT, /* 281 */
+ OP_WAITPID, /* 282 */
+ OP_SYSTEM, /* 283 */
+ OP_EXEC, /* 284 */
+ OP_KILL, /* 285 */
+ OP_GETPPID, /* 286 */
+ OP_GETPGRP, /* 287 */
+ OP_SETPGRP, /* 288 */
+ OP_GETPRIORITY, /* 289 */
+ OP_SETPRIORITY, /* 290 */
+ OP_TIME, /* 291 */
+ OP_TMS, /* 292 */
+ OP_LOCALTIME, /* 293 */
+ OP_GMTIME, /* 294 */
+ OP_ALARM, /* 295 */
+ OP_SLEEP, /* 296 */
+ OP_SHMGET, /* 297 */
+ OP_SHMCTL, /* 298 */
+ OP_SHMREAD, /* 299 */
+ OP_SHMWRITE, /* 300 */
+ OP_MSGGET, /* 301 */
+ OP_MSGCTL, /* 302 */
+ OP_MSGSND, /* 303 */
+ OP_MSGRCV, /* 304 */
+ OP_SEMGET, /* 305 */
+ OP_SEMCTL, /* 306 */
+ OP_SEMOP, /* 307 */
+ OP_REQUIRE, /* 308 */
+ OP_DOFILE, /* 309 */
+ OP_ENTEREVAL, /* 310 */
+ OP_LEAVEEVAL, /* 311 */
+ OP_ENTERTRY, /* 312 */
+ OP_LEAVETRY, /* 313 */
+ OP_GHBYNAME, /* 314 */
+ OP_GHBYADDR, /* 315 */
+ OP_GHOSTENT, /* 316 */
+ OP_GNBYNAME, /* 317 */
+ OP_GNBYADDR, /* 318 */
+ OP_GNETENT, /* 319 */
+ OP_GPBYNAME, /* 320 */
+ OP_GPBYNUMBER, /* 321 */
+ OP_GPROTOENT, /* 322 */
+ OP_GSBYNAME, /* 323 */
+ OP_GSBYPORT, /* 324 */
+ OP_GSERVENT, /* 325 */
+ OP_SHOSTENT, /* 326 */
+ OP_SNETENT, /* 327 */
+ OP_SPROTOENT, /* 328 */
+ OP_SSERVENT, /* 329 */
+ OP_EHOSTENT, /* 330 */
+ OP_ENETENT, /* 331 */
+ OP_EPROTOENT, /* 332 */
+ OP_ESERVENT, /* 333 */
+ OP_GPWNAM, /* 334 */
+ OP_GPWUID, /* 335 */
+ OP_GPWENT, /* 336 */
+ OP_SPWENT, /* 337 */
+ OP_EPWENT, /* 338 */
+ OP_GGRNAM, /* 339 */
+ OP_GGRGID, /* 340 */
+ OP_GGRENT, /* 341 */
+ OP_SGRENT, /* 342 */
+ OP_EGRENT, /* 343 */
+ OP_GETLOGIN, /* 344 */
+ OP_SYSCALL, /* 345 */
+ OP_LOCK, /* 346 */
+ OP_THREADSV, /* 347 */
+ OP_max
+} opcode;
+
+#define MAXO 348
+
+#ifndef DOINIT
+EXT char *op_name[];
+#else
+EXT char *op_name[] = {
+ "null",
+ "stub",
+ "scalar",
+ "pushmark",
+ "wantarray",
+ "const",
+ "gvsv",
+ "gv",
+ "gelem",
+ "padsv",
+ "padav",
+ "padhv",
+ "padany",
+ "pushre",
+ "rv2gv",
+ "rv2sv",
+ "av2arylen",
+ "rv2cv",
+ "anoncode",
+ "prototype",
+ "refgen",
+ "srefgen",
+ "ref",
+ "bless",
+ "backtick",
+ "glob",
+ "readline",
+ "rcatline",
+ "regcmaybe",
+ "regcreset",
+ "regcomp",
+ "match",
+ "qr",
+ "subst",
+ "substcont",
+ "trans",
+ "sassign",
+ "aassign",
+ "chop",
+ "schop",
+ "chomp",
+ "schomp",
+ "defined",
+ "undef",
+ "study",
+ "pos",
+ "preinc",
+ "i_preinc",
+ "predec",
+ "i_predec",
+ "postinc",
+ "i_postinc",
+ "postdec",
+ "i_postdec",
+ "pow",
+ "multiply",
+ "i_multiply",
+ "divide",
+ "i_divide",
+ "modulo",
+ "i_modulo",
+ "repeat",
+ "add",
+ "i_add",
+ "subtract",
+ "i_subtract",
+ "concat",
+ "stringify",
+ "left_shift",
+ "right_shift",
+ "lt",
+ "i_lt",
+ "gt",
+ "i_gt",
+ "le",
+ "i_le",
+ "ge",
+ "i_ge",
+ "eq",
+ "i_eq",
+ "ne",
+ "i_ne",
+ "ncmp",
+ "i_ncmp",
+ "slt",
+ "sgt",
+ "sle",
+ "sge",
+ "seq",
+ "sne",
+ "scmp",
+ "bit_and",
+ "bit_xor",
+ "bit_or",
+ "negate",
+ "i_negate",
+ "not",
+ "complement",
+ "atan2",
+ "sin",
+ "cos",
+ "rand",
+ "srand",
+ "exp",
+ "log",
+ "sqrt",
+ "int",
+ "hex",
+ "oct",
+ "abs",
+ "length",
+ "substr",
+ "vec",
+ "index",
+ "rindex",
+ "sprintf",
+ "formline",
+ "ord",
+ "chr",
+ "crypt",
+ "ucfirst",
+ "lcfirst",
+ "uc",
+ "lc",
+ "quotemeta",
+ "rv2av",
+ "aelemfast",
+ "aelem",
+ "aslice",
+ "each",
+ "values",
+ "keys",
+ "delete",
+ "exists",
+ "rv2hv",
+ "helem",
+ "hslice",
+ "unpack",
+ "pack",
+ "split",
+ "join",
+ "list",
+ "lslice",
+ "anonlist",
+ "anonhash",
+ "splice",
+ "push",
+ "pop",
+ "shift",
+ "unshift",
+ "sort",
+ "reverse",
+ "grepstart",
+ "grepwhile",
+ "mapstart",
+ "mapwhile",
+ "range",
+ "flip",
+ "flop",
+ "and",
+ "or",
+ "xor",
+ "cond_expr",
+ "andassign",
+ "orassign",
+ "method",
+ "entersub",
+ "leavesub",
+ "caller",
+ "warn",
+ "die",
+ "reset",
+ "lineseq",
+ "nextstate",
+ "dbstate",
+ "unstack",
+ "enter",
+ "leave",
+ "scope",
+ "enteriter",
+ "iter",
+ "enterloop",
+ "leaveloop",
+ "return",
+ "last",
+ "next",
+ "redo",
+ "dump",
+ "goto",
+ "exit",
+ "open",
+ "close",
+ "pipe_op",
+ "fileno",
+ "umask",
+ "binmode",
+ "tie",
+ "untie",
+ "tied",
+ "dbmopen",
+ "dbmclose",
+ "sselect",
+ "select",
+ "getc",
+ "read",
+ "enterwrite",
+ "leavewrite",
+ "prtf",
+ "print",
+ "sysopen",
+ "sysseek",
+ "sysread",
+ "syswrite",
+ "send",
+ "recv",
+ "eof",
+ "tell",
+ "seek",
+ "truncate",
+ "fcntl",
+ "ioctl",
+ "flock",
+ "socket",
+ "sockpair",
+ "bind",
+ "connect",
+ "listen",
+ "accept",
+ "shutdown",
+ "gsockopt",
+ "ssockopt",
+ "getsockname",
+ "getpeername",
+ "lstat",
+ "stat",
+ "ftrread",
+ "ftrwrite",
+ "ftrexec",
+ "fteread",
+ "ftewrite",
+ "fteexec",
+ "ftis",
+ "fteowned",
+ "ftrowned",
+ "ftzero",
+ "ftsize",
+ "ftmtime",
+ "ftatime",
+ "ftctime",
+ "ftsock",
+ "ftchr",
+ "ftblk",
+ "ftfile",
+ "ftdir",
+ "ftpipe",
+ "ftlink",
+ "ftsuid",
+ "ftsgid",
+ "ftsvtx",
+ "fttty",
+ "fttext",
+ "ftbinary",
+ "chdir",
+ "chown",
+ "chroot",
+ "unlink",
+ "chmod",
+ "utime",
+ "rename",
+ "link",
+ "symlink",
+ "readlink",
+ "mkdir",
+ "rmdir",
+ "open_dir",
+ "readdir",
+ "telldir",
+ "seekdir",
+ "rewinddir",
+ "closedir",
+ "fork",
+ "wait",
+ "waitpid",
+ "system",
+ "exec",
+ "kill",
+ "getppid",
+ "getpgrp",
+ "setpgrp",
+ "getpriority",
+ "setpriority",
+ "time",
+ "tms",
+ "localtime",
+ "gmtime",
+ "alarm",
+ "sleep",
+ "shmget",
+ "shmctl",
+ "shmread",
+ "shmwrite",
+ "msgget",
+ "msgctl",
+ "msgsnd",
+ "msgrcv",
+ "semget",
+ "semctl",
+ "semop",
+ "require",
+ "dofile",
+ "entereval",
+ "leaveeval",
+ "entertry",
+ "leavetry",
+ "ghbyname",
+ "ghbyaddr",
+ "ghostent",
+ "gnbyname",
+ "gnbyaddr",
+ "gnetent",
+ "gpbyname",
+ "gpbynumber",
+ "gprotoent",
+ "gsbyname",
+ "gsbyport",
+ "gservent",
+ "shostent",
+ "snetent",
+ "sprotoent",
+ "sservent",
+ "ehostent",
+ "enetent",
+ "eprotoent",
+ "eservent",
+ "gpwnam",
+ "gpwuid",
+ "gpwent",
+ "spwent",
+ "epwent",
+ "ggrnam",
+ "ggrgid",
+ "ggrent",
+ "sgrent",
+ "egrent",
+ "getlogin",
+ "syscall",
+ "lock",
+ "threadsv",
+};
+#endif
+
+#ifndef DOINIT
+EXT char *op_desc[];
+#else
+EXT char *op_desc[] = {
+ "null operation",
+ "stub",
+ "scalar",
+ "pushmark",
+ "wantarray",
+ "constant item",
+ "scalar variable",
+ "glob value",
+ "glob elem",
+ "private variable",
+ "private array",
+ "private hash",
+ "private something",
+ "push regexp",
+ "ref-to-glob cast",
+ "scalar deref",
+ "array length",
+ "subroutine deref",
+ "anonymous subroutine",
+ "subroutine prototype",
+ "reference constructor",
+ "scalar ref constructor",
+ "reference-type operator",
+ "bless",
+ "backticks",
+ "glob",
+ "<HANDLE>",
+ "append I/O operator",
+ "regexp comp once",
+ "regexp reset interpolation flag",
+ "regexp compilation",
+ "pattern match",
+ "pattern quote",
+ "substitution",
+ "substitution cont",
+ "character translation",
+ "scalar assignment",
+ "list assignment",
+ "chop",
+ "scalar chop",
+ "safe chop",
+ "scalar safe chop",
+ "defined operator",
+ "undef operator",
+ "study",
+ "match position",
+ "preincrement",
+ "integer preincrement",
+ "predecrement",
+ "integer predecrement",
+ "postincrement",
+ "integer postincrement",
+ "postdecrement",
+ "integer postdecrement",
+ "exponentiation",
+ "multiplication",
+ "integer multiplication",
+ "division",
+ "integer division",
+ "modulus",
+ "integer modulus",
+ "repeat",
+ "addition",
+ "integer addition",
+ "subtraction",
+ "integer subtraction",
+ "concatenation",
+ "string",
+ "left bitshift",
+ "right bitshift",
+ "numeric lt",
+ "integer lt",
+ "numeric gt",
+ "integer gt",
+ "numeric le",
+ "integer le",
+ "numeric ge",
+ "integer ge",
+ "numeric eq",
+ "integer eq",
+ "numeric ne",
+ "integer ne",
+ "spaceship operator",
+ "integer spaceship",
+ "string lt",
+ "string gt",
+ "string le",
+ "string ge",
+ "string eq",
+ "string ne",
+ "string comparison",
+ "bitwise and",
+ "bitwise xor",
+ "bitwise or",
+ "negate",
+ "integer negate",
+ "not",
+ "1's complement",
+ "atan2",
+ "sin",
+ "cos",
+ "rand",
+ "srand",
+ "exp",
+ "log",
+ "sqrt",
+ "int",
+ "hex",
+ "oct",
+ "abs",
+ "length",
+ "substr",
+ "vec",
+ "index",
+ "rindex",
+ "sprintf",
+ "formline",
+ "ord",
+ "chr",
+ "crypt",
+ "upper case first",
+ "lower case first",
+ "upper case",
+ "lower case",
+ "quote metachars",
+ "array deref",
+ "known array element",
+ "array element",
+ "array slice",
+ "each",
+ "values",
+ "keys",
+ "delete",
+ "exists operator",
+ "hash deref",
+ "hash elem",
+ "hash slice",
+ "unpack",
+ "pack",
+ "split",
+ "join",
+ "list",
+ "list slice",
+ "anonymous list",
+ "anonymous hash",
+ "splice",
+ "push",
+ "pop",
+ "shift",
+ "unshift",
+ "sort",
+ "reverse",
+ "grep",
+ "grep iterator",
+ "map",
+ "map iterator",
+ "flipflop",
+ "range (or flip)",
+ "range (or flop)",
+ "logical and",
+ "logical or",
+ "logical xor",
+ "conditional expression",
+ "logical and assignment",
+ "logical or assignment",
+ "method lookup",
+ "subroutine entry",
+ "subroutine exit",
+ "caller",
+ "warn",
+ "die",
+ "reset",
+ "line sequence",
+ "next statement",
+ "debug next statement",
+ "unstack",
+ "block entry",
+ "block exit",
+ "block",
+ "foreach loop entry",
+ "foreach loop iterator",
+ "loop entry",
+ "loop exit",
+ "return",
+ "last",
+ "next",
+ "redo",
+ "dump",
+ "goto",
+ "exit",
+ "open",
+ "close",
+ "pipe",
+ "fileno",
+ "umask",
+ "binmode",
+ "tie",
+ "untie",
+ "tied",
+ "dbmopen",
+ "dbmclose",
+ "select system call",
+ "select",
+ "getc",
+ "read",
+ "write",
+ "write exit",
+ "printf",
+ "print",
+ "sysopen",
+ "sysseek",
+ "sysread",
+ "syswrite",
+ "send",
+ "recv",
+ "eof",
+ "tell",
+ "seek",
+ "truncate",
+ "fcntl",
+ "ioctl",
+ "flock",
+ "socket",
+ "socketpair",
+ "bind",
+ "connect",
+ "listen",
+ "accept",
+ "shutdown",
+ "getsockopt",
+ "setsockopt",
+ "getsockname",
+ "getpeername",
+ "lstat",
+ "stat",
+ "-R",
+ "-W",
+ "-X",
+ "-r",
+ "-w",
+ "-x",
+ "-e",
+ "-O",
+ "-o",
+ "-z",
+ "-s",
+ "-M",
+ "-A",
+ "-C",
+ "-S",
+ "-c",
+ "-b",
+ "-f",
+ "-d",
+ "-p",
+ "-l",
+ "-u",
+ "-g",
+ "-k",
+ "-t",
+ "-T",
+ "-B",
+ "chdir",
+ "chown",
+ "chroot",
+ "unlink",
+ "chmod",
+ "utime",
+ "rename",
+ "link",
+ "symlink",
+ "readlink",
+ "mkdir",
+ "rmdir",
+ "opendir",
+ "readdir",
+ "telldir",
+ "seekdir",
+ "rewinddir",
+ "closedir",
+ "fork",
+ "wait",
+ "waitpid",
+ "system",
+ "exec",
+ "kill",
+ "getppid",
+ "getpgrp",
+ "setpgrp",
+ "getpriority",
+ "setpriority",
+ "time",
+ "times",
+ "localtime",
+ "gmtime",
+ "alarm",
+ "sleep",
+ "shmget",
+ "shmctl",
+ "shmread",
+ "shmwrite",
+ "msgget",
+ "msgctl",
+ "msgsnd",
+ "msgrcv",
+ "semget",
+ "semctl",
+ "semop",
+ "require",
+ "do 'file'",
+ "eval string",
+ "eval exit",
+ "eval block",
+ "eval block exit",
+ "gethostbyname",
+ "gethostbyaddr",
+ "gethostent",
+ "getnetbyname",
+ "getnetbyaddr",
+ "getnetent",
+ "getprotobyname",
+ "getprotobynumber",
+ "getprotoent",
+ "getservbyname",
+ "getservbyport",
+ "getservent",
+ "sethostent",
+ "setnetent",
+ "setprotoent",
+ "setservent",
+ "endhostent",
+ "endnetent",
+ "endprotoent",
+ "endservent",
+ "getpwnam",
+ "getpwuid",
+ "getpwent",
+ "setpwent",
+ "endpwent",
+ "getgrnam",
+ "getgrgid",
+ "getgrent",
+ "setgrent",
+ "endgrent",
+ "getlogin",
+ "syscall",
+ "lock",
+ "per-thread variable",
+};
+#endif
+
+#ifndef PERL_OBJECT
+START_EXTERN_C
+
+OP * ck_anoncode _((OP* o));
+OP * ck_bitop _((OP* o));
+OP * ck_concat _((OP* o));
+OP * ck_delete _((OP* o));
+OP * ck_eof _((OP* o));
+OP * ck_eval _((OP* o));
+OP * ck_exec _((OP* o));
+OP * ck_exists _((OP* o));
+OP * ck_ftst _((OP* o));
+OP * ck_fun _((OP* o));
+OP * ck_fun_locale _((OP* o));
+OP * ck_glob _((OP* o));
+OP * ck_grep _((OP* o));
+OP * ck_index _((OP* o));
+OP * ck_lengthconst _((OP* o));
+OP * ck_lfun _((OP* o));
+OP * ck_listiob _((OP* o));
+OP * ck_match _((OP* o));
+OP * ck_null _((OP* o));
+OP * ck_repeat _((OP* o));
+OP * ck_require _((OP* o));
+OP * ck_rfun _((OP* o));
+OP * ck_rvconst _((OP* o));
+OP * ck_scmp _((OP* o));
+OP * ck_select _((OP* o));
+OP * ck_shift _((OP* o));
+OP * ck_sort _((OP* o));
+OP * ck_spair _((OP* o));
+OP * ck_split _((OP* o));
+OP * ck_subr _((OP* o));
+OP * ck_svconst _((OP* o));
+OP * ck_trunc _((OP* o));
+
+OP * pp_null _((ARGSproto));
+OP * pp_stub _((ARGSproto));
+OP * pp_scalar _((ARGSproto));
+OP * pp_pushmark _((ARGSproto));
+OP * pp_wantarray _((ARGSproto));
+OP * pp_const _((ARGSproto));
+OP * pp_gvsv _((ARGSproto));
+OP * pp_gv _((ARGSproto));
+OP * pp_gelem _((ARGSproto));
+OP * pp_padsv _((ARGSproto));
+OP * pp_padav _((ARGSproto));
+OP * pp_padhv _((ARGSproto));
+OP * pp_padany _((ARGSproto));
+OP * pp_pushre _((ARGSproto));
+OP * pp_rv2gv _((ARGSproto));
+OP * pp_rv2sv _((ARGSproto));
+OP * pp_av2arylen _((ARGSproto));
+OP * pp_rv2cv _((ARGSproto));
+OP * pp_anoncode _((ARGSproto));
+OP * pp_prototype _((ARGSproto));
+OP * pp_refgen _((ARGSproto));
+OP * pp_srefgen _((ARGSproto));
+OP * pp_ref _((ARGSproto));
+OP * pp_bless _((ARGSproto));
+OP * pp_backtick _((ARGSproto));
+OP * pp_glob _((ARGSproto));
+OP * pp_readline _((ARGSproto));
+OP * pp_rcatline _((ARGSproto));
+OP * pp_regcmaybe _((ARGSproto));
+OP * pp_regcreset _((ARGSproto));
+OP * pp_regcomp _((ARGSproto));
+OP * pp_match _((ARGSproto));
+OP * pp_qr _((ARGSproto));
+OP * pp_subst _((ARGSproto));
+OP * pp_substcont _((ARGSproto));
+OP * pp_trans _((ARGSproto));
+OP * pp_sassign _((ARGSproto));
+OP * pp_aassign _((ARGSproto));
+OP * pp_chop _((ARGSproto));
+OP * pp_schop _((ARGSproto));
+OP * pp_chomp _((ARGSproto));
+OP * pp_schomp _((ARGSproto));
+OP * pp_defined _((ARGSproto));
+OP * pp_undef _((ARGSproto));
+OP * pp_study _((ARGSproto));
+OP * pp_pos _((ARGSproto));
+OP * pp_preinc _((ARGSproto));
+OP * pp_i_preinc _((ARGSproto));
+OP * pp_predec _((ARGSproto));
+OP * pp_i_predec _((ARGSproto));
+OP * pp_postinc _((ARGSproto));
+OP * pp_i_postinc _((ARGSproto));
+OP * pp_postdec _((ARGSproto));
+OP * pp_i_postdec _((ARGSproto));
+OP * pp_pow _((ARGSproto));
+OP * pp_multiply _((ARGSproto));
+OP * pp_i_multiply _((ARGSproto));
+OP * pp_divide _((ARGSproto));
+OP * pp_i_divide _((ARGSproto));
+OP * pp_modulo _((ARGSproto));
+OP * pp_i_modulo _((ARGSproto));
+OP * pp_repeat _((ARGSproto));
+OP * pp_add _((ARGSproto));
+OP * pp_i_add _((ARGSproto));
+OP * pp_subtract _((ARGSproto));
+OP * pp_i_subtract _((ARGSproto));
+OP * pp_concat _((ARGSproto));
+OP * pp_stringify _((ARGSproto));
+OP * pp_left_shift _((ARGSproto));
+OP * pp_right_shift _((ARGSproto));
+OP * pp_lt _((ARGSproto));
+OP * pp_i_lt _((ARGSproto));
+OP * pp_gt _((ARGSproto));
+OP * pp_i_gt _((ARGSproto));
+OP * pp_le _((ARGSproto));
+OP * pp_i_le _((ARGSproto));
+OP * pp_ge _((ARGSproto));
+OP * pp_i_ge _((ARGSproto));
+OP * pp_eq _((ARGSproto));
+OP * pp_i_eq _((ARGSproto));
+OP * pp_ne _((ARGSproto));
+OP * pp_i_ne _((ARGSproto));
+OP * pp_ncmp _((ARGSproto));
+OP * pp_i_ncmp _((ARGSproto));
+OP * pp_slt _((ARGSproto));
+OP * pp_sgt _((ARGSproto));
+OP * pp_sle _((ARGSproto));
+OP * pp_sge _((ARGSproto));
+OP * pp_seq _((ARGSproto));
+OP * pp_sne _((ARGSproto));
+OP * pp_scmp _((ARGSproto));
+OP * pp_bit_and _((ARGSproto));
+OP * pp_bit_xor _((ARGSproto));
+OP * pp_bit_or _((ARGSproto));
+OP * pp_negate _((ARGSproto));
+OP * pp_i_negate _((ARGSproto));
+OP * pp_not _((ARGSproto));
+OP * pp_complement _((ARGSproto));
+OP * pp_atan2 _((ARGSproto));
+OP * pp_sin _((ARGSproto));
+OP * pp_cos _((ARGSproto));
+OP * pp_rand _((ARGSproto));
+OP * pp_srand _((ARGSproto));
+OP * pp_exp _((ARGSproto));
+OP * pp_log _((ARGSproto));
+OP * pp_sqrt _((ARGSproto));
+OP * pp_int _((ARGSproto));
+OP * pp_hex _((ARGSproto));
+OP * pp_oct _((ARGSproto));
+OP * pp_abs _((ARGSproto));
+OP * pp_length _((ARGSproto));
+OP * pp_substr _((ARGSproto));
+OP * pp_vec _((ARGSproto));
+OP * pp_index _((ARGSproto));
+OP * pp_rindex _((ARGSproto));
+OP * pp_sprintf _((ARGSproto));
+OP * pp_formline _((ARGSproto));
+OP * pp_ord _((ARGSproto));
+OP * pp_chr _((ARGSproto));
+OP * pp_crypt _((ARGSproto));
+OP * pp_ucfirst _((ARGSproto));
+OP * pp_lcfirst _((ARGSproto));
+OP * pp_uc _((ARGSproto));
+OP * pp_lc _((ARGSproto));
+OP * pp_quotemeta _((ARGSproto));
+OP * pp_rv2av _((ARGSproto));
+OP * pp_aelemfast _((ARGSproto));
+OP * pp_aelem _((ARGSproto));
+OP * pp_aslice _((ARGSproto));
+OP * pp_each _((ARGSproto));
+OP * pp_values _((ARGSproto));
+OP * pp_keys _((ARGSproto));
+OP * pp_delete _((ARGSproto));
+OP * pp_exists _((ARGSproto));
+OP * pp_rv2hv _((ARGSproto));
+OP * pp_helem _((ARGSproto));
+OP * pp_hslice _((ARGSproto));
+OP * pp_unpack _((ARGSproto));
+OP * pp_pack _((ARGSproto));
+OP * pp_split _((ARGSproto));
+OP * pp_join _((ARGSproto));
+OP * pp_list _((ARGSproto));
+OP * pp_lslice _((ARGSproto));
+OP * pp_anonlist _((ARGSproto));
+OP * pp_anonhash _((ARGSproto));
+OP * pp_splice _((ARGSproto));
+OP * pp_push _((ARGSproto));
+OP * pp_pop _((ARGSproto));
+OP * pp_shift _((ARGSproto));
+OP * pp_unshift _((ARGSproto));
+OP * pp_sort _((ARGSproto));
+OP * pp_reverse _((ARGSproto));
+OP * pp_grepstart _((ARGSproto));
+OP * pp_grepwhile _((ARGSproto));
+OP * pp_mapstart _((ARGSproto));
+OP * pp_mapwhile _((ARGSproto));
+OP * pp_range _((ARGSproto));
+OP * pp_flip _((ARGSproto));
+OP * pp_flop _((ARGSproto));
+OP * pp_and _((ARGSproto));
+OP * pp_or _((ARGSproto));
+OP * pp_xor _((ARGSproto));
+OP * pp_cond_expr _((ARGSproto));
+OP * pp_andassign _((ARGSproto));
+OP * pp_orassign _((ARGSproto));
+OP * pp_method _((ARGSproto));
+OP * pp_entersub _((ARGSproto));
+OP * pp_leavesub _((ARGSproto));
+OP * pp_caller _((ARGSproto));
+OP * pp_warn _((ARGSproto));
+OP * pp_die _((ARGSproto));
+OP * pp_reset _((ARGSproto));
+OP * pp_lineseq _((ARGSproto));
+OP * pp_nextstate _((ARGSproto));
+OP * pp_dbstate _((ARGSproto));
+OP * pp_unstack _((ARGSproto));
+OP * pp_enter _((ARGSproto));
+OP * pp_leave _((ARGSproto));
+OP * pp_scope _((ARGSproto));
+OP * pp_enteriter _((ARGSproto));
+OP * pp_iter _((ARGSproto));
+OP * pp_enterloop _((ARGSproto));
+OP * pp_leaveloop _((ARGSproto));
+OP * pp_return _((ARGSproto));
+OP * pp_last _((ARGSproto));
+OP * pp_next _((ARGSproto));
+OP * pp_redo _((ARGSproto));
+OP * pp_dump _((ARGSproto));
+OP * pp_goto _((ARGSproto));
+OP * pp_exit _((ARGSproto));
+OP * pp_open _((ARGSproto));
+OP * pp_close _((ARGSproto));
+OP * pp_pipe_op _((ARGSproto));
+OP * pp_fileno _((ARGSproto));
+OP * pp_umask _((ARGSproto));
+OP * pp_binmode _((ARGSproto));
+OP * pp_tie _((ARGSproto));
+OP * pp_untie _((ARGSproto));
+OP * pp_tied _((ARGSproto));
+OP * pp_dbmopen _((ARGSproto));
+OP * pp_dbmclose _((ARGSproto));
+OP * pp_sselect _((ARGSproto));
+OP * pp_select _((ARGSproto));
+OP * pp_getc _((ARGSproto));
+OP * pp_read _((ARGSproto));
+OP * pp_enterwrite _((ARGSproto));
+OP * pp_leavewrite _((ARGSproto));
+OP * pp_prtf _((ARGSproto));
+OP * pp_print _((ARGSproto));
+OP * pp_sysopen _((ARGSproto));
+OP * pp_sysseek _((ARGSproto));
+OP * pp_sysread _((ARGSproto));
+OP * pp_syswrite _((ARGSproto));
+OP * pp_send _((ARGSproto));
+OP * pp_recv _((ARGSproto));
+OP * pp_eof _((ARGSproto));
+OP * pp_tell _((ARGSproto));
+OP * pp_seek _((ARGSproto));
+OP * pp_truncate _((ARGSproto));
+OP * pp_fcntl _((ARGSproto));
+OP * pp_ioctl _((ARGSproto));
+OP * pp_flock _((ARGSproto));
+OP * pp_socket _((ARGSproto));
+OP * pp_sockpair _((ARGSproto));
+OP * pp_bind _((ARGSproto));
+OP * pp_connect _((ARGSproto));
+OP * pp_listen _((ARGSproto));
+OP * pp_accept _((ARGSproto));
+OP * pp_shutdown _((ARGSproto));
+OP * pp_gsockopt _((ARGSproto));
+OP * pp_ssockopt _((ARGSproto));
+OP * pp_getsockname _((ARGSproto));
+OP * pp_getpeername _((ARGSproto));
+OP * pp_lstat _((ARGSproto));
+OP * pp_stat _((ARGSproto));
+OP * pp_ftrread _((ARGSproto));
+OP * pp_ftrwrite _((ARGSproto));
+OP * pp_ftrexec _((ARGSproto));
+OP * pp_fteread _((ARGSproto));
+OP * pp_ftewrite _((ARGSproto));
+OP * pp_fteexec _((ARGSproto));
+OP * pp_ftis _((ARGSproto));
+OP * pp_fteowned _((ARGSproto));
+OP * pp_ftrowned _((ARGSproto));
+OP * pp_ftzero _((ARGSproto));
+OP * pp_ftsize _((ARGSproto));
+OP * pp_ftmtime _((ARGSproto));
+OP * pp_ftatime _((ARGSproto));
+OP * pp_ftctime _((ARGSproto));
+OP * pp_ftsock _((ARGSproto));
+OP * pp_ftchr _((ARGSproto));
+OP * pp_ftblk _((ARGSproto));
+OP * pp_ftfile _((ARGSproto));
+OP * pp_ftdir _((ARGSproto));
+OP * pp_ftpipe _((ARGSproto));
+OP * pp_ftlink _((ARGSproto));
+OP * pp_ftsuid _((ARGSproto));
+OP * pp_ftsgid _((ARGSproto));
+OP * pp_ftsvtx _((ARGSproto));
+OP * pp_fttty _((ARGSproto));
+OP * pp_fttext _((ARGSproto));
+OP * pp_ftbinary _((ARGSproto));
+OP * pp_chdir _((ARGSproto));
+OP * pp_chown _((ARGSproto));
+OP * pp_chroot _((ARGSproto));
+OP * pp_unlink _((ARGSproto));
+OP * pp_chmod _((ARGSproto));
+OP * pp_utime _((ARGSproto));
+OP * pp_rename _((ARGSproto));
+OP * pp_link _((ARGSproto));
+OP * pp_symlink _((ARGSproto));
+OP * pp_readlink _((ARGSproto));
+OP * pp_mkdir _((ARGSproto));
+OP * pp_rmdir _((ARGSproto));
+OP * pp_open_dir _((ARGSproto));
+OP * pp_readdir _((ARGSproto));
+OP * pp_telldir _((ARGSproto));
+OP * pp_seekdir _((ARGSproto));
+OP * pp_rewinddir _((ARGSproto));
+OP * pp_closedir _((ARGSproto));
+OP * pp_fork _((ARGSproto));
+OP * pp_wait _((ARGSproto));
+OP * pp_waitpid _((ARGSproto));
+OP * pp_system _((ARGSproto));
+OP * pp_exec _((ARGSproto));
+OP * pp_kill _((ARGSproto));
+OP * pp_getppid _((ARGSproto));
+OP * pp_getpgrp _((ARGSproto));
+OP * pp_setpgrp _((ARGSproto));
+OP * pp_getpriority _((ARGSproto));
+OP * pp_setpriority _((ARGSproto));
+OP * pp_time _((ARGSproto));
+OP * pp_tms _((ARGSproto));
+OP * pp_localtime _((ARGSproto));
+OP * pp_gmtime _((ARGSproto));
+OP * pp_alarm _((ARGSproto));
+OP * pp_sleep _((ARGSproto));
+OP * pp_shmget _((ARGSproto));
+OP * pp_shmctl _((ARGSproto));
+OP * pp_shmread _((ARGSproto));
+OP * pp_shmwrite _((ARGSproto));
+OP * pp_msgget _((ARGSproto));
+OP * pp_msgctl _((ARGSproto));
+OP * pp_msgsnd _((ARGSproto));
+OP * pp_msgrcv _((ARGSproto));
+OP * pp_semget _((ARGSproto));
+OP * pp_semctl _((ARGSproto));
+OP * pp_semop _((ARGSproto));
+OP * pp_require _((ARGSproto));
+OP * pp_dofile _((ARGSproto));
+OP * pp_entereval _((ARGSproto));
+OP * pp_leaveeval _((ARGSproto));
+OP * pp_entertry _((ARGSproto));
+OP * pp_leavetry _((ARGSproto));
+OP * pp_ghbyname _((ARGSproto));
+OP * pp_ghbyaddr _((ARGSproto));
+OP * pp_ghostent _((ARGSproto));
+OP * pp_gnbyname _((ARGSproto));
+OP * pp_gnbyaddr _((ARGSproto));
+OP * pp_gnetent _((ARGSproto));
+OP * pp_gpbyname _((ARGSproto));
+OP * pp_gpbynumber _((ARGSproto));
+OP * pp_gprotoent _((ARGSproto));
+OP * pp_gsbyname _((ARGSproto));
+OP * pp_gsbyport _((ARGSproto));
+OP * pp_gservent _((ARGSproto));
+OP * pp_shostent _((ARGSproto));
+OP * pp_snetent _((ARGSproto));
+OP * pp_sprotoent _((ARGSproto));
+OP * pp_sservent _((ARGSproto));
+OP * pp_ehostent _((ARGSproto));
+OP * pp_enetent _((ARGSproto));
+OP * pp_eprotoent _((ARGSproto));
+OP * pp_eservent _((ARGSproto));
+OP * pp_gpwnam _((ARGSproto));
+OP * pp_gpwuid _((ARGSproto));
+OP * pp_gpwent _((ARGSproto));
+OP * pp_spwent _((ARGSproto));
+OP * pp_epwent _((ARGSproto));
+OP * pp_ggrnam _((ARGSproto));
+OP * pp_ggrgid _((ARGSproto));
+OP * pp_ggrent _((ARGSproto));
+OP * pp_sgrent _((ARGSproto));
+OP * pp_egrent _((ARGSproto));
+OP * pp_getlogin _((ARGSproto));
+OP * pp_syscall _((ARGSproto));
+OP * pp_lock _((ARGSproto));
+OP * pp_threadsv _((ARGSproto));
+
+END_EXTERN_C
+#endif /* PERL_OBJECT */
+
+#ifndef DOINIT
+EXT OP * (CPERLscope(*ppaddr)[])(ARGSproto);
+#else
+#ifndef PERL_OBJECT
+EXT OP * (CPERLscope(*ppaddr)[])(ARGSproto) = {
+ pp_null,
+ pp_stub,
+ pp_scalar,
+ pp_pushmark,
+ pp_wantarray,
+ pp_const,
+ pp_gvsv,
+ pp_gv,
+ pp_gelem,
+ pp_padsv,
+ pp_padav,
+ pp_padhv,
+ pp_padany,
+ pp_pushre,
+ pp_rv2gv,
+ pp_rv2sv,
+ pp_av2arylen,
+ pp_rv2cv,
+ pp_anoncode,
+ pp_prototype,
+ pp_refgen,
+ pp_srefgen,
+ pp_ref,
+ pp_bless,
+ pp_backtick,
+ pp_glob,
+ pp_readline,
+ pp_rcatline,
+ pp_regcmaybe,
+ pp_regcreset,
+ pp_regcomp,
+ pp_match,
+ pp_qr,
+ pp_subst,
+ pp_substcont,
+ pp_trans,
+ pp_sassign,
+ pp_aassign,
+ pp_chop,
+ pp_schop,
+ pp_chomp,
+ pp_schomp,
+ pp_defined,
+ pp_undef,
+ pp_study,
+ pp_pos,
+ pp_preinc,
+ pp_i_preinc,
+ pp_predec,
+ pp_i_predec,
+ pp_postinc,
+ pp_i_postinc,
+ pp_postdec,
+ pp_i_postdec,
+ pp_pow,
+ pp_multiply,
+ pp_i_multiply,
+ pp_divide,
+ pp_i_divide,
+ pp_modulo,
+ pp_i_modulo,
+ pp_repeat,
+ pp_add,
+ pp_i_add,
+ pp_subtract,
+ pp_i_subtract,
+ pp_concat,
+ pp_stringify,
+ pp_left_shift,
+ pp_right_shift,
+ pp_lt,
+ pp_i_lt,
+ pp_gt,
+ pp_i_gt,
+ pp_le,
+ pp_i_le,
+ pp_ge,
+ pp_i_ge,
+ pp_eq,
+ pp_i_eq,
+ pp_ne,
+ pp_i_ne,
+ pp_ncmp,
+ pp_i_ncmp,
+ pp_slt,
+ pp_sgt,
+ pp_sle,
+ pp_sge,
+ pp_seq,
+ pp_sne,
+ pp_scmp,
+ pp_bit_and,
+ pp_bit_xor,
+ pp_bit_or,
+ pp_negate,
+ pp_i_negate,
+ pp_not,
+ pp_complement,
+ pp_atan2,
+ pp_sin,
+ pp_cos,
+ pp_rand,
+ pp_srand,
+ pp_exp,
+ pp_log,
+ pp_sqrt,
+ pp_int,
+ pp_hex,
+ pp_oct,
+ pp_abs,
+ pp_length,
+ pp_substr,
+ pp_vec,
+ pp_index,
+ pp_rindex,
+ pp_sprintf,
+ pp_formline,
+ pp_ord,
+ pp_chr,
+ pp_crypt,
+ pp_ucfirst,
+ pp_lcfirst,
+ pp_uc,
+ pp_lc,
+ pp_quotemeta,
+ pp_rv2av,
+ pp_aelemfast,
+ pp_aelem,
+ pp_aslice,
+ pp_each,
+ pp_values,
+ pp_keys,
+ pp_delete,
+ pp_exists,
+ pp_rv2hv,
+ pp_helem,
+ pp_hslice,
+ pp_unpack,
+ pp_pack,
+ pp_split,
+ pp_join,
+ pp_list,
+ pp_lslice,
+ pp_anonlist,
+ pp_anonhash,
+ pp_splice,
+ pp_push,
+ pp_pop,
+ pp_shift,
+ pp_unshift,
+ pp_sort,
+ pp_reverse,
+ pp_grepstart,
+ pp_grepwhile,
+ pp_mapstart,
+ pp_mapwhile,
+ pp_range,
+ pp_flip,
+ pp_flop,
+ pp_and,
+ pp_or,
+ pp_xor,
+ pp_cond_expr,
+ pp_andassign,
+ pp_orassign,
+ pp_method,
+ pp_entersub,
+ pp_leavesub,
+ pp_caller,
+ pp_warn,
+ pp_die,
+ pp_reset,
+ pp_lineseq,
+ pp_nextstate,
+ pp_dbstate,
+ pp_unstack,
+ pp_enter,
+ pp_leave,
+ pp_scope,
+ pp_enteriter,
+ pp_iter,
+ pp_enterloop,
+ pp_leaveloop,
+ pp_return,
+ pp_last,
+ pp_next,
+ pp_redo,
+ pp_dump,
+ pp_goto,
+ pp_exit,
+ pp_open,
+ pp_close,
+ pp_pipe_op,
+ pp_fileno,
+ pp_umask,
+ pp_binmode,
+ pp_tie,
+ pp_untie,
+ pp_tied,
+ pp_dbmopen,
+ pp_dbmclose,
+ pp_sselect,
+ pp_select,
+ pp_getc,
+ pp_read,
+ pp_enterwrite,
+ pp_leavewrite,
+ pp_prtf,
+ pp_print,
+ pp_sysopen,
+ pp_sysseek,
+ pp_sysread,
+ pp_syswrite,
+ pp_send,
+ pp_recv,
+ pp_eof,
+ pp_tell,
+ pp_seek,
+ pp_truncate,
+ pp_fcntl,
+ pp_ioctl,
+ pp_flock,
+ pp_socket,
+ pp_sockpair,
+ pp_bind,
+ pp_connect,
+ pp_listen,
+ pp_accept,
+ pp_shutdown,
+ pp_gsockopt,
+ pp_ssockopt,
+ pp_getsockname,
+ pp_getpeername,
+ pp_lstat,
+ pp_stat,
+ pp_ftrread,
+ pp_ftrwrite,
+ pp_ftrexec,
+ pp_fteread,
+ pp_ftewrite,
+ pp_fteexec,
+ pp_ftis,
+ pp_fteowned,
+ pp_ftrowned,
+ pp_ftzero,
+ pp_ftsize,
+ pp_ftmtime,
+ pp_ftatime,
+ pp_ftctime,
+ pp_ftsock,
+ pp_ftchr,
+ pp_ftblk,
+ pp_ftfile,
+ pp_ftdir,
+ pp_ftpipe,
+ pp_ftlink,
+ pp_ftsuid,
+ pp_ftsgid,
+ pp_ftsvtx,
+ pp_fttty,
+ pp_fttext,
+ pp_ftbinary,
+ pp_chdir,
+ pp_chown,
+ pp_chroot,
+ pp_unlink,
+ pp_chmod,
+ pp_utime,
+ pp_rename,
+ pp_link,
+ pp_symlink,
+ pp_readlink,
+ pp_mkdir,
+ pp_rmdir,
+ pp_open_dir,
+ pp_readdir,
+ pp_telldir,
+ pp_seekdir,
+ pp_rewinddir,
+ pp_closedir,
+ pp_fork,
+ pp_wait,
+ pp_waitpid,
+ pp_system,
+ pp_exec,
+ pp_kill,
+ pp_getppid,
+ pp_getpgrp,
+ pp_setpgrp,
+ pp_getpriority,
+ pp_setpriority,
+ pp_time,
+ pp_tms,
+ pp_localtime,
+ pp_gmtime,
+ pp_alarm,
+ pp_sleep,
+ pp_shmget,
+ pp_shmctl,
+ pp_shmread,
+ pp_shmwrite,
+ pp_msgget,
+ pp_msgctl,
+ pp_msgsnd,
+ pp_msgrcv,
+ pp_semget,
+ pp_semctl,
+ pp_semop,
+ pp_require,
+ pp_dofile,
+ pp_entereval,
+ pp_leaveeval,
+ pp_entertry,
+ pp_leavetry,
+ pp_ghbyname,
+ pp_ghbyaddr,
+ pp_ghostent,
+ pp_gnbyname,
+ pp_gnbyaddr,
+ pp_gnetent,
+ pp_gpbyname,
+ pp_gpbynumber,
+ pp_gprotoent,
+ pp_gsbyname,
+ pp_gsbyport,
+ pp_gservent,
+ pp_shostent,
+ pp_snetent,
+ pp_sprotoent,
+ pp_sservent,
+ pp_ehostent,
+ pp_enetent,
+ pp_eprotoent,
+ pp_eservent,
+ pp_gpwnam,
+ pp_gpwuid,
+ pp_gpwent,
+ pp_spwent,
+ pp_epwent,
+ pp_ggrnam,
+ pp_ggrgid,
+ pp_ggrent,
+ pp_sgrent,
+ pp_egrent,
+ pp_getlogin,
+ pp_syscall,
+ pp_lock,
+ pp_threadsv,
+};
+#endif /* PERL_OBJECT */
+#endif
+
+#ifndef DOINIT
+EXT OP * (CPERLscope(*check)[]) _((OP *op));
+#else
+#ifndef PERL_OBJECT
+EXT OP * (CPERLscope(*check)[]) _((OP *op)) = {
+ ck_null, /* null */
+ ck_null, /* stub */
+ ck_fun, /* scalar */
+ ck_null, /* pushmark */
+ ck_null, /* wantarray */
+ ck_svconst, /* const */
+ ck_null, /* gvsv */
+ ck_null, /* gv */
+ ck_null, /* gelem */
+ ck_null, /* padsv */
+ ck_null, /* padav */
+ ck_null, /* padhv */
+ ck_null, /* padany */
+ ck_null, /* pushre */
+ ck_rvconst, /* rv2gv */
+ ck_rvconst, /* rv2sv */
+ ck_null, /* av2arylen */
+ ck_rvconst, /* rv2cv */
+ ck_anoncode, /* anoncode */
+ ck_null, /* prototype */
+ ck_spair, /* refgen */
+ ck_null, /* srefgen */
+ ck_fun, /* ref */
+ ck_fun, /* bless */
+ ck_null, /* backtick */
+ ck_glob, /* glob */
+ ck_null, /* readline */
+ ck_null, /* rcatline */
+ ck_fun, /* regcmaybe */
+ ck_fun, /* regcreset */
+ ck_null, /* regcomp */
+ ck_match, /* match */
+ ck_match, /* qr */
+ ck_null, /* subst */
+ ck_null, /* substcont */
+ ck_null, /* trans */
+ ck_null, /* sassign */
+ ck_null, /* aassign */
+ ck_spair, /* chop */
+ ck_null, /* schop */
+ ck_spair, /* chomp */
+ ck_null, /* schomp */
+ ck_rfun, /* defined */
+ ck_lfun, /* undef */
+ ck_fun, /* study */
+ ck_lfun, /* pos */
+ ck_lfun, /* preinc */
+ ck_lfun, /* i_preinc */
+ ck_lfun, /* predec */
+ ck_lfun, /* i_predec */
+ ck_lfun, /* postinc */
+ ck_lfun, /* i_postinc */
+ ck_lfun, /* postdec */
+ ck_lfun, /* i_postdec */
+ ck_null, /* pow */
+ ck_null, /* multiply */
+ ck_null, /* i_multiply */
+ ck_null, /* divide */
+ ck_null, /* i_divide */
+ ck_null, /* modulo */
+ ck_null, /* i_modulo */
+ ck_repeat, /* repeat */
+ ck_null, /* add */
+ ck_null, /* i_add */
+ ck_null, /* subtract */
+ ck_null, /* i_subtract */
+ ck_concat, /* concat */
+ ck_fun, /* stringify */
+ ck_bitop, /* left_shift */
+ ck_bitop, /* right_shift */
+ ck_null, /* lt */
+ ck_null, /* i_lt */
+ ck_null, /* gt */
+ ck_null, /* i_gt */
+ ck_null, /* le */
+ ck_null, /* i_le */
+ ck_null, /* ge */
+ ck_null, /* i_ge */
+ ck_null, /* eq */
+ ck_null, /* i_eq */
+ ck_null, /* ne */
+ ck_null, /* i_ne */
+ ck_null, /* ncmp */
+ ck_null, /* i_ncmp */
+ ck_scmp, /* slt */
+ ck_scmp, /* sgt */
+ ck_scmp, /* sle */
+ ck_scmp, /* sge */
+ ck_null, /* seq */
+ ck_null, /* sne */
+ ck_scmp, /* scmp */
+ ck_bitop, /* bit_and */
+ ck_bitop, /* bit_xor */
+ ck_bitop, /* bit_or */
+ ck_null, /* negate */
+ ck_null, /* i_negate */
+ ck_null, /* not */
+ ck_bitop, /* complement */
+ ck_fun, /* atan2 */
+ ck_fun, /* sin */
+ ck_fun, /* cos */
+ ck_fun, /* rand */
+ ck_fun, /* srand */
+ ck_fun, /* exp */
+ ck_fun, /* log */
+ ck_fun, /* sqrt */
+ ck_fun, /* int */
+ ck_fun, /* hex */
+ ck_fun, /* oct */
+ ck_fun, /* abs */
+ ck_lengthconst, /* length */
+ ck_fun, /* substr */
+ ck_fun, /* vec */
+ ck_index, /* index */
+ ck_index, /* rindex */
+ ck_fun_locale, /* sprintf */
+ ck_fun, /* formline */
+ ck_fun, /* ord */
+ ck_fun, /* chr */
+ ck_fun, /* crypt */
+ ck_fun_locale, /* ucfirst */
+ ck_fun_locale, /* lcfirst */
+ ck_fun_locale, /* uc */
+ ck_fun_locale, /* lc */
+ ck_fun, /* quotemeta */
+ ck_rvconst, /* rv2av */
+ ck_null, /* aelemfast */
+ ck_null, /* aelem */
+ ck_null, /* aslice */
+ ck_fun, /* each */
+ ck_fun, /* values */
+ ck_fun, /* keys */
+ ck_delete, /* delete */
+ ck_exists, /* exists */
+ ck_rvconst, /* rv2hv */
+ ck_null, /* helem */
+ ck_null, /* hslice */
+ ck_fun, /* unpack */
+ ck_fun, /* pack */
+ ck_split, /* split */
+ ck_fun, /* join */
+ ck_null, /* list */
+ ck_null, /* lslice */
+ ck_fun, /* anonlist */
+ ck_fun, /* anonhash */
+ ck_fun, /* splice */
+ ck_fun, /* push */
+ ck_shift, /* pop */
+ ck_shift, /* shift */
+ ck_fun, /* unshift */
+ ck_sort, /* sort */
+ ck_fun, /* reverse */
+ ck_grep, /* grepstart */
+ ck_null, /* grepwhile */
+ ck_grep, /* mapstart */
+ ck_null, /* mapwhile */
+ ck_null, /* range */
+ ck_null, /* flip */
+ ck_null, /* flop */
+ ck_null, /* and */
+ ck_null, /* or */
+ ck_null, /* xor */
+ ck_null, /* cond_expr */
+ ck_null, /* andassign */
+ ck_null, /* orassign */
+ ck_null, /* method */
+ ck_subr, /* entersub */
+ ck_null, /* leavesub */
+ ck_fun, /* caller */
+ ck_fun, /* warn */
+ ck_fun, /* die */
+ ck_fun, /* reset */
+ ck_null, /* lineseq */
+ ck_null, /* nextstate */
+ ck_null, /* dbstate */
+ ck_null, /* unstack */
+ ck_null, /* enter */
+ ck_null, /* leave */
+ ck_null, /* scope */
+ ck_null, /* enteriter */
+ ck_null, /* iter */
+ ck_null, /* enterloop */
+ ck_null, /* leaveloop */
+ ck_null, /* return */
+ ck_null, /* last */
+ ck_null, /* next */
+ ck_null, /* redo */
+ ck_null, /* dump */
+ ck_null, /* goto */
+ ck_fun, /* exit */
+ ck_fun, /* open */
+ ck_fun, /* close */
+ ck_fun, /* pipe_op */
+ ck_fun, /* fileno */
+ ck_fun, /* umask */
+ ck_fun, /* binmode */
+ ck_fun, /* tie */
+ ck_fun, /* untie */
+ ck_fun, /* tied */
+ ck_fun, /* dbmopen */
+ ck_fun, /* dbmclose */
+ ck_select, /* sselect */
+ ck_select, /* select */
+ ck_eof, /* getc */
+ ck_fun, /* read */
+ ck_fun, /* enterwrite */
+ ck_null, /* leavewrite */
+ ck_listiob, /* prtf */
+ ck_listiob, /* print */
+ ck_fun, /* sysopen */
+ ck_fun, /* sysseek */
+ ck_fun, /* sysread */
+ ck_fun, /* syswrite */
+ ck_fun, /* send */
+ ck_fun, /* recv */
+ ck_eof, /* eof */
+ ck_fun, /* tell */
+ ck_fun, /* seek */
+ ck_trunc, /* truncate */
+ ck_fun, /* fcntl */
+ ck_fun, /* ioctl */
+ ck_fun, /* flock */
+ ck_fun, /* socket */
+ ck_fun, /* sockpair */
+ ck_fun, /* bind */
+ ck_fun, /* connect */
+ ck_fun, /* listen */
+ ck_fun, /* accept */
+ ck_fun, /* shutdown */
+ ck_fun, /* gsockopt */
+ ck_fun, /* ssockopt */
+ ck_fun, /* getsockname */
+ ck_fun, /* getpeername */
+ ck_ftst, /* lstat */
+ ck_ftst, /* stat */
+ ck_ftst, /* ftrread */
+ ck_ftst, /* ftrwrite */
+ ck_ftst, /* ftrexec */
+ ck_ftst, /* fteread */
+ ck_ftst, /* ftewrite */
+ ck_ftst, /* fteexec */
+ ck_ftst, /* ftis */
+ ck_ftst, /* fteowned */
+ ck_ftst, /* ftrowned */
+ ck_ftst, /* ftzero */
+ ck_ftst, /* ftsize */
+ ck_ftst, /* ftmtime */
+ ck_ftst, /* ftatime */
+ ck_ftst, /* ftctime */
+ ck_ftst, /* ftsock */
+ ck_ftst, /* ftchr */
+ ck_ftst, /* ftblk */
+ ck_ftst, /* ftfile */
+ ck_ftst, /* ftdir */
+ ck_ftst, /* ftpipe */
+ ck_ftst, /* ftlink */
+ ck_ftst, /* ftsuid */
+ ck_ftst, /* ftsgid */
+ ck_ftst, /* ftsvtx */
+ ck_ftst, /* fttty */
+ ck_ftst, /* fttext */
+ ck_ftst, /* ftbinary */
+ ck_fun, /* chdir */
+ ck_fun, /* chown */
+ ck_fun, /* chroot */
+ ck_fun, /* unlink */
+ ck_fun, /* chmod */
+ ck_fun, /* utime */
+ ck_fun, /* rename */
+ ck_fun, /* link */
+ ck_fun, /* symlink */
+ ck_fun, /* readlink */
+ ck_fun, /* mkdir */
+ ck_fun, /* rmdir */
+ ck_fun, /* open_dir */
+ ck_fun, /* readdir */
+ ck_fun, /* telldir */
+ ck_fun, /* seekdir */
+ ck_fun, /* rewinddir */
+ ck_fun, /* closedir */
+ ck_null, /* fork */
+ ck_null, /* wait */
+ ck_fun, /* waitpid */
+ ck_exec, /* system */
+ ck_exec, /* exec */
+ ck_fun, /* kill */
+ ck_null, /* getppid */
+ ck_fun, /* getpgrp */
+ ck_fun, /* setpgrp */
+ ck_fun, /* getpriority */
+ ck_fun, /* setpriority */
+ ck_null, /* time */
+ ck_null, /* tms */
+ ck_fun, /* localtime */
+ ck_fun, /* gmtime */
+ ck_fun, /* alarm */
+ ck_fun, /* sleep */
+ ck_fun, /* shmget */
+ ck_fun, /* shmctl */
+ ck_fun, /* shmread */
+ ck_fun, /* shmwrite */
+ ck_fun, /* msgget */
+ ck_fun, /* msgctl */
+ ck_fun, /* msgsnd */
+ ck_fun, /* msgrcv */
+ ck_fun, /* semget */
+ ck_fun, /* semctl */
+ ck_fun, /* semop */
+ ck_require, /* require */
+ ck_fun, /* dofile */
+ ck_eval, /* entereval */
+ ck_null, /* leaveeval */
+ ck_null, /* entertry */
+ ck_null, /* leavetry */
+ ck_fun, /* ghbyname */
+ ck_fun, /* ghbyaddr */
+ ck_null, /* ghostent */
+ ck_fun, /* gnbyname */
+ ck_fun, /* gnbyaddr */
+ ck_null, /* gnetent */
+ ck_fun, /* gpbyname */
+ ck_fun, /* gpbynumber */
+ ck_null, /* gprotoent */
+ ck_fun, /* gsbyname */
+ ck_fun, /* gsbyport */
+ ck_null, /* gservent */
+ ck_fun, /* shostent */
+ ck_fun, /* snetent */
+ ck_fun, /* sprotoent */
+ ck_fun, /* sservent */
+ ck_null, /* ehostent */
+ ck_null, /* enetent */
+ ck_null, /* eprotoent */
+ ck_null, /* eservent */
+ ck_fun, /* gpwnam */
+ ck_fun, /* gpwuid */
+ ck_null, /* gpwent */
+ ck_null, /* spwent */
+ ck_null, /* epwent */
+ ck_fun, /* ggrnam */
+ ck_fun, /* ggrgid */
+ ck_null, /* ggrent */
+ ck_null, /* sgrent */
+ ck_null, /* egrent */
+ ck_null, /* getlogin */
+ ck_fun, /* syscall */
+ ck_rfun, /* lock */
+ ck_null, /* threadsv */
+};
+#endif /* PERL_OBJECT */
+#endif
+
+#ifndef DOINIT
+EXT U32 opargs[];
+#else
+EXT U32 opargs[] = {
+ 0x00000000, /* null */
+ 0x00000000, /* stub */
+ 0x00001c04, /* scalar */
+ 0x00000004, /* pushmark */
+ 0x00000014, /* wantarray */
+ 0x00000704, /* const */
+ 0x00000844, /* gvsv */
+ 0x00000844, /* gv */
+ 0x00011240, /* gelem */
+ 0x00000044, /* padsv */
+ 0x00000040, /* padav */
+ 0x00000040, /* padhv */
+ 0x00000040, /* padany */
+ 0x00000640, /* pushre */
+ 0x00000144, /* rv2gv */
+ 0x00000144, /* rv2sv */
+ 0x00000114, /* av2arylen */
+ 0x00000140, /* rv2cv */
+ 0x00000700, /* anoncode */
+ 0x00001c04, /* prototype */
+ 0x00002101, /* refgen */
+ 0x00001106, /* srefgen */
+ 0x00009c8c, /* ref */
+ 0x00091504, /* bless */
+ 0x00000c08, /* backtick */
+ 0x00099508, /* glob */
+ 0x00000c08, /* readline */
+ 0x00000c08, /* rcatline */
+ 0x00001104, /* regcmaybe */
+ 0x00001104, /* regcreset */
+ 0x00001304, /* regcomp */
+ 0x00000640, /* match */
+ 0x00000604, /* qr */
+ 0x00001654, /* subst */
+ 0x00000354, /* substcont */
+ 0x00001914, /* trans */
+ 0x00000004, /* sassign */
+ 0x00022208, /* aassign */
+ 0x00002c0d, /* chop */
+ 0x00009c8c, /* schop */
+ 0x00002c0d, /* chomp */
+ 0x00009c8c, /* schomp */
+ 0x00009c94, /* defined */
+ 0x00009c04, /* undef */
+ 0x00009c84, /* study */
+ 0x00009c8c, /* pos */
+ 0x00001164, /* preinc */
+ 0x00001154, /* i_preinc */
+ 0x00001164, /* predec */
+ 0x00001154, /* i_predec */
+ 0x0000116c, /* postinc */
+ 0x0000115c, /* i_postinc */
+ 0x0000116c, /* postdec */
+ 0x0000115c, /* i_postdec */
+ 0x0001120e, /* pow */
+ 0x0001122e, /* multiply */
+ 0x0001121e, /* i_multiply */
+ 0x0001122e, /* divide */
+ 0x0001121e, /* i_divide */
+ 0x0001123e, /* modulo */
+ 0x0001121e, /* i_modulo */
+ 0x00012209, /* repeat */
+ 0x0001122e, /* add */
+ 0x0001121e, /* i_add */
+ 0x0001122e, /* subtract */
+ 0x0001121e, /* i_subtract */
+ 0x0001120e, /* concat */
+ 0x0000150e, /* stringify */
+ 0x0001120e, /* left_shift */
+ 0x0001120e, /* right_shift */
+ 0x00011236, /* lt */
+ 0x00011216, /* i_lt */
+ 0x00011236, /* gt */
+ 0x00011216, /* i_gt */
+ 0x00011236, /* le */
+ 0x00011216, /* i_le */
+ 0x00011236, /* ge */
+ 0x00011216, /* i_ge */
+ 0x00011236, /* eq */
+ 0x00011216, /* i_eq */
+ 0x00011236, /* ne */
+ 0x00011216, /* i_ne */
+ 0x0001123e, /* ncmp */
+ 0x0001121e, /* i_ncmp */
+ 0x00011216, /* slt */
+ 0x00011216, /* sgt */
+ 0x00011216, /* sle */
+ 0x00011216, /* sge */
+ 0x00011216, /* seq */
+ 0x00011216, /* sne */
+ 0x0001121e, /* scmp */
+ 0x0001120e, /* bit_and */
+ 0x0001120e, /* bit_xor */
+ 0x0001120e, /* bit_or */
+ 0x0000112e, /* negate */
+ 0x0000111e, /* i_negate */
+ 0x00001116, /* not */
+ 0x0000110e, /* complement */
+ 0x0001150e, /* atan2 */
+ 0x00009c8e, /* sin */
+ 0x00009c8e, /* cos */
+ 0x00009c0c, /* rand */
+ 0x00009c04, /* srand */
+ 0x00009c8e, /* exp */
+ 0x00009c8e, /* log */
+ 0x00009c8e, /* sqrt */
+ 0x00009c8e, /* int */
+ 0x00009c8e, /* hex */
+ 0x00009c8e, /* oct */
+ 0x00009c8e, /* abs */
+ 0x00009c9c, /* length */
+ 0x0991150c, /* substr */
+ 0x0011151c, /* vec */
+ 0x0091151c, /* index */
+ 0x0091151c, /* rindex */
+ 0x0002150f, /* sprintf */
+ 0x00021505, /* formline */
+ 0x00009c9e, /* ord */
+ 0x00009c8e, /* chr */
+ 0x0001150e, /* crypt */
+ 0x00009c8e, /* ucfirst */
+ 0x00009c8e, /* lcfirst */
+ 0x00009c8e, /* uc */
+ 0x00009c8e, /* lc */
+ 0x00009c8e, /* quotemeta */
+ 0x00000148, /* rv2av */
+ 0x00013804, /* aelemfast */
+ 0x00013204, /* aelem */
+ 0x00023501, /* aslice */
+ 0x00004c08, /* each */
+ 0x00004c08, /* values */
+ 0x00004c08, /* keys */
+ 0x00001c00, /* delete */
+ 0x00001c14, /* exists */
+ 0x00000148, /* rv2hv */
+ 0x00014204, /* helem */
+ 0x00024501, /* hslice */
+ 0x00011500, /* unpack */
+ 0x0002150d, /* pack */
+ 0x00111508, /* split */
+ 0x0002150d, /* join */
+ 0x00002501, /* list */
+ 0x00224200, /* lslice */
+ 0x00002505, /* anonlist */
+ 0x00002505, /* anonhash */
+ 0x02993501, /* splice */
+ 0x0002351d, /* push */
+ 0x00003c14, /* pop */
+ 0x00003c04, /* shift */
+ 0x0002351d, /* unshift */
+ 0x0002d501, /* sort */
+ 0x00002509, /* reverse */
+ 0x00025541, /* grepstart */
+ 0x00000348, /* grepwhile */
+ 0x00025541, /* mapstart */
+ 0x00000348, /* mapwhile */
+ 0x00011400, /* range */
+ 0x00011100, /* flip */
+ 0x00000100, /* flop */
+ 0x00000300, /* and */
+ 0x00000300, /* or */
+ 0x00011306, /* xor */
+ 0x00000440, /* cond_expr */
+ 0x00000304, /* andassign */
+ 0x00000304, /* orassign */
+ 0x00000140, /* method */
+ 0x00002149, /* entersub */
+ 0x00000100, /* leavesub */
+ 0x00009c08, /* caller */
+ 0x0000251d, /* warn */
+ 0x0000255d, /* die */
+ 0x00009c14, /* reset */
+ 0x00000500, /* lineseq */
+ 0x00000b04, /* nextstate */
+ 0x00000b04, /* dbstate */
+ 0x00000004, /* unstack */
+ 0x00000000, /* enter */
+ 0x00000500, /* leave */
+ 0x00000500, /* scope */
+ 0x00000a40, /* enteriter */
+ 0x00000000, /* iter */
+ 0x00000a40, /* enterloop */
+ 0x00000200, /* leaveloop */
+ 0x00002541, /* return */
+ 0x00000e44, /* last */
+ 0x00000e44, /* next */
+ 0x00000e44, /* redo */
+ 0x00000e44, /* dump */
+ 0x00000e44, /* goto */
+ 0x00009c44, /* exit */
+ 0x0009651c, /* open */
+ 0x0000ec14, /* close */
+ 0x00066514, /* pipe_op */
+ 0x00006c1c, /* fileno */
+ 0x00009c1c, /* umask */
+ 0x00006c04, /* binmode */
+ 0x00217555, /* tie */
+ 0x00007c14, /* untie */
+ 0x00007c04, /* tied */
+ 0x00114514, /* dbmopen */
+ 0x00004c14, /* dbmclose */
+ 0x01111508, /* sselect */
+ 0x0000e50c, /* select */
+ 0x0000ec0c, /* getc */
+ 0x0917651d, /* read */
+ 0x0000ec54, /* enterwrite */
+ 0x00000100, /* leavewrite */
+ 0x0002e515, /* prtf */
+ 0x0002e515, /* print */
+ 0x09116504, /* sysopen */
+ 0x00116504, /* sysseek */
+ 0x0917651d, /* sysread */
+ 0x0911651d, /* syswrite */
+ 0x0911651d, /* send */
+ 0x0117651d, /* recv */
+ 0x0000ec14, /* eof */
+ 0x0000ec0c, /* tell */
+ 0x00116504, /* seek */
+ 0x00011514, /* truncate */
+ 0x0011650c, /* fcntl */
+ 0x0011650c, /* ioctl */
+ 0x0001651c, /* flock */
+ 0x01116514, /* socket */
+ 0x11166514, /* sockpair */
+ 0x00016514, /* bind */
+ 0x00016514, /* connect */
+ 0x00016514, /* listen */
+ 0x0006651c, /* accept */
+ 0x0001651c, /* shutdown */
+ 0x00116514, /* gsockopt */
+ 0x01116514, /* ssockopt */
+ 0x00006c14, /* getsockname */
+ 0x00006c14, /* getpeername */
+ 0x00006d80, /* lstat */
+ 0x00006d80, /* stat */
+ 0x00006d94, /* ftrread */
+ 0x00006d94, /* ftrwrite */
+ 0x00006d94, /* ftrexec */
+ 0x00006d94, /* fteread */
+ 0x00006d94, /* ftewrite */
+ 0x00006d94, /* fteexec */
+ 0x00006d94, /* ftis */
+ 0x00006d94, /* fteowned */
+ 0x00006d94, /* ftrowned */
+ 0x00006d94, /* ftzero */
+ 0x00006d9c, /* ftsize */
+ 0x00006d8c, /* ftmtime */
+ 0x00006d8c, /* ftatime */
+ 0x00006d8c, /* ftctime */
+ 0x00006d94, /* ftsock */
+ 0x00006d94, /* ftchr */
+ 0x00006d94, /* ftblk */
+ 0x00006d94, /* ftfile */
+ 0x00006d94, /* ftdir */
+ 0x00006d94, /* ftpipe */
+ 0x00006d94, /* ftlink */
+ 0x00006d94, /* ftsuid */
+ 0x00006d94, /* ftsgid */
+ 0x00006d94, /* ftsvtx */
+ 0x00006d14, /* fttty */
+ 0x00006d94, /* fttext */
+ 0x00006d94, /* ftbinary */
+ 0x00009c1c, /* chdir */
+ 0x0000251d, /* chown */
+ 0x00009c9c, /* chroot */
+ 0x0000259d, /* unlink */
+ 0x0000251d, /* chmod */
+ 0x0000251d, /* utime */
+ 0x0001151c, /* rename */
+ 0x0001151c, /* link */
+ 0x0001151c, /* symlink */
+ 0x00009c8c, /* readlink */
+ 0x0001151c, /* mkdir */
+ 0x00009c9c, /* rmdir */
+ 0x00016514, /* open_dir */
+ 0x00006c00, /* readdir */
+ 0x00006c0c, /* telldir */
+ 0x00016504, /* seekdir */
+ 0x00006c04, /* rewinddir */
+ 0x00006c14, /* closedir */
+ 0x0000001c, /* fork */
+ 0x0000001c, /* wait */
+ 0x0001151c, /* waitpid */
+ 0x0002951d, /* system */
+ 0x0002955d, /* exec */
+ 0x0000255d, /* kill */
+ 0x0000001c, /* getppid */
+ 0x00009c1c, /* getpgrp */
+ 0x0009951c, /* setpgrp */
+ 0x0001151c, /* getpriority */
+ 0x0011151c, /* setpriority */
+ 0x0000001c, /* time */
+ 0x00000000, /* tms */
+ 0x00009c08, /* localtime */
+ 0x00009c08, /* gmtime */
+ 0x00009c9c, /* alarm */
+ 0x00009c1c, /* sleep */
+ 0x0011151d, /* shmget */
+ 0x0011151d, /* shmctl */
+ 0x0111151d, /* shmread */
+ 0x0111151d, /* shmwrite */
+ 0x0001151d, /* msgget */
+ 0x0011151d, /* msgctl */
+ 0x0011151d, /* msgsnd */
+ 0x1111151d, /* msgrcv */
+ 0x0011151d, /* semget */
+ 0x0111151d, /* semctl */
+ 0x0001151d, /* semop */
+ 0x00009cc0, /* require */
+ 0x00001140, /* dofile */
+ 0x00001c40, /* entereval */
+ 0x00001100, /* leaveeval */
+ 0x00000300, /* entertry */
+ 0x00000500, /* leavetry */
+ 0x00001c00, /* ghbyname */
+ 0x00011500, /* ghbyaddr */
+ 0x00000000, /* ghostent */
+ 0x00001c00, /* gnbyname */
+ 0x00011500, /* gnbyaddr */
+ 0x00000000, /* gnetent */
+ 0x00001c00, /* gpbyname */
+ 0x00001500, /* gpbynumber */
+ 0x00000000, /* gprotoent */
+ 0x00011500, /* gsbyname */
+ 0x00011500, /* gsbyport */
+ 0x00000000, /* gservent */
+ 0x00001c14, /* shostent */
+ 0x00001c14, /* snetent */
+ 0x00001c14, /* sprotoent */
+ 0x00001c14, /* sservent */
+ 0x00000014, /* ehostent */
+ 0x00000014, /* enetent */
+ 0x00000014, /* eprotoent */
+ 0x00000014, /* eservent */
+ 0x00001c00, /* gpwnam */
+ 0x00001c00, /* gpwuid */
+ 0x00000000, /* gpwent */
+ 0x00000014, /* spwent */
+ 0x00000014, /* epwent */
+ 0x00001c00, /* ggrnam */
+ 0x00001c00, /* ggrgid */
+ 0x00000000, /* ggrent */
+ 0x00000014, /* sgrent */
+ 0x00000014, /* egrent */
+ 0x0000000c, /* getlogin */
+ 0x0002151d, /* syscall */
+ 0x00001c04, /* lock */
+ 0x00000044, /* threadsv */
+};
+#endif
diff --git a/contrib/perl5/opcode.pl b/contrib/perl5/opcode.pl
new file mode 100755
index 000000000000..f2ed795fd40f
--- /dev/null
+++ b/contrib/perl5/opcode.pl
@@ -0,0 +1,703 @@
+#!/usr/bin/perl
+
+unlink "opcode.h";
+open(OC, ">opcode.h") || die "Can't create opcode.h: $!\n";
+select OC;
+
+# Read data.
+
+while (<DATA>) {
+ chop;
+ next unless $_;
+ next if /^#/;
+ ($key, $desc, $check, $flags, $args) = split(/\t+/, $_, 5);
+
+ warn qq[Description "$desc" duplicates $seen{$desc}\n] if $seen{$desc};
+ die qq[Opcode "$key" duplicates $seen{$key}\n] if $seen{$key};
+ $seen{$desc} = qq[description of opcode "$key"];
+ $seen{$key} = qq[opcode "$key"];
+
+ push(@ops, $key);
+ $desc{$key} = $desc;
+ $check{$key} = $check;
+ $ckname{$check}++;
+ $flags{$key} = $flags;
+ $args{$key} = $args;
+}
+
+# Emit defines.
+
+$i = 0;
+print <<"END";
+#define pp_i_preinc pp_preinc
+#define pp_i_predec pp_predec
+#define pp_i_postinc pp_postinc
+#define pp_i_postdec pp_postdec
+
+typedef enum {
+END
+for (@ops) {
+ print "\t", &tab(3,"OP_\U$_,"), "/* ", $i++, " */\n";
+}
+print "\t", &tab(3,"OP_max"), "\n";
+print "} opcode;\n";
+print "\n#define MAXO ", scalar @ops, "\n\n";
+
+# Emit op names and descriptions.
+
+print <<END;
+#ifndef DOINIT
+EXT char *op_name[];
+#else
+EXT char *op_name[] = {
+END
+
+for (@ops) {
+ print qq(\t"$_",\n);
+}
+
+print <<END;
+};
+#endif
+
+END
+
+print <<END;
+#ifndef DOINIT
+EXT char *op_desc[];
+#else
+EXT char *op_desc[] = {
+END
+
+for (@ops) {
+ print qq(\t"$desc{$_}",\n);
+}
+
+print <<END;
+};
+#endif
+
+#ifndef PERL_OBJECT
+START_EXTERN_C
+
+END
+
+# Emit function declarations.
+
+for (sort keys %ckname) {
+ print "OP *\t", &tab(3,$_),"_((OP* o));\n";
+}
+
+print "\n";
+
+for (@ops) {
+ print "OP *\t", &tab(3, "pp_$_"), "_((ARGSproto));\n";
+}
+
+# Emit ppcode switch array.
+
+print <<END;
+
+END_EXTERN_C
+#endif /* PERL_OBJECT */
+
+#ifndef DOINIT
+EXT OP * (CPERLscope(*ppaddr)[])(ARGSproto);
+#else
+#ifndef PERL_OBJECT
+EXT OP * (CPERLscope(*ppaddr)[])(ARGSproto) = {
+END
+
+for (@ops) {
+ print "\tpp_$_,\n";
+}
+
+print <<END;
+};
+#endif /* PERL_OBJECT */
+#endif
+
+END
+
+# Emit check routines.
+
+print <<END;
+#ifndef DOINIT
+EXT OP * (CPERLscope(*check)[]) _((OP *op));
+#else
+#ifndef PERL_OBJECT
+EXT OP * (CPERLscope(*check)[]) _((OP *op)) = {
+END
+
+for (@ops) {
+ print "\t", &tab(3, "$check{$_},"), "/* $_ */\n";
+}
+
+print <<END;
+};
+#endif /* PERL_OBJECT */
+#endif
+
+END
+
+# Emit allowed argument types.
+
+print <<END;
+#ifndef DOINIT
+EXT U32 opargs[];
+#else
+EXT U32 opargs[] = {
+END
+
+%argnum = (
+ S, 1, # scalar
+ L, 2, # list
+ A, 3, # array value
+ H, 4, # hash value
+ C, 5, # code value
+ F, 6, # file value
+ R, 7, # scalar reference
+);
+
+%opclass = (
+ '0', 0, # baseop
+ '1', 1, # unop
+ '2', 2, # binop
+ '|', 3, # logop
+ '?', 4, # condop
+ '@', 5, # listop
+ '/', 6, # pmop
+ '$', 7, # svop
+ '*', 8, # gvop
+ '"', 9, # pvop
+ '{', 10, # loop
+ ';', 11, # cop
+ '%', 12, # baseop_or_unop
+ '-', 13, # filestatop
+ '}', 14, # loopexop
+);
+
+for (@ops) {
+ $argsum = 0;
+ $flags = $flags{$_};
+ $argsum |= 1 if $flags =~ /m/; # needs stack mark
+ $argsum |= 2 if $flags =~ /f/; # fold constants
+ $argsum |= 4 if $flags =~ /s/; # always produces scalar
+ $argsum |= 8 if $flags =~ /t/; # needs target scalar
+ $argsum |= 16 if $flags =~ /i/; # always produces integer
+ $argsum |= 32 if $flags =~ /I/; # has corresponding int op
+ $argsum |= 64 if $flags =~ /d/; # danger, unknown side effects
+ $argsum |= 128 if $flags =~ /u/; # defaults to $_
+
+ $flags =~ /([\W\d_])/ or die qq[Opcode "$_" has no class indicator];
+ $argsum |= $opclass{$1} << 8;
+ $mul = 4096; # 2 ^ OASHIFT
+ for $arg (split(' ',$args{$_})) {
+ $argnum = ($arg =~ s/\?//) ? 8 : 0;
+ $argnum += $argnum{$arg};
+ $argsum += $argnum * $mul;
+ $mul <<= 4;
+ }
+ $argsum = sprintf("0x%08x", $argsum);
+ print "\t", &tab(3, "$argsum,"), "/* $_ */\n";
+}
+
+print <<END;
+};
+#endif
+END
+
+close OC or die "Error closing opcode.h: $!";
+
+unlink "pp_proto.h";
+open PP, '>pp_proto.h' or die "Error creating pp_proto.h: $!";
+for (@ops) {
+ next if /^i_(pre|post)(inc|dec)$/;
+ print PP "PPDEF(pp_$_)\n";
+}
+
+close PP or die "Error closing pp_proto.h: $!";
+
+###########################################################################
+sub tab {
+ local($l, $t) = @_;
+ $t .= "\t" x ($l - (length($t) + 1) / 8);
+ $t;
+}
+###########################################################################
+__END__
+
+# Nothing.
+
+null null operation ck_null 0
+stub stub ck_null 0
+scalar scalar ck_fun s% S
+
+# Pushy stuff.
+
+pushmark pushmark ck_null s0
+wantarray wantarray ck_null is0
+
+const constant item ck_svconst s$
+
+gvsv scalar variable ck_null ds*
+gv glob value ck_null ds*
+gelem glob elem ck_null d2 S S
+padsv private variable ck_null ds0
+padav private array ck_null d0
+padhv private hash ck_null d0
+padany private something ck_null d0
+
+pushre push regexp ck_null d/
+
+# References and stuff.
+
+rv2gv ref-to-glob cast ck_rvconst ds1
+rv2sv scalar deref ck_rvconst ds1
+av2arylen array length ck_null is1
+rv2cv subroutine deref ck_rvconst d1
+anoncode anonymous subroutine ck_anoncode $
+prototype subroutine prototype ck_null s% S
+refgen reference constructor ck_spair m1 L
+srefgen scalar ref constructor ck_null fs1 S
+ref reference-type operator ck_fun stu% S?
+bless bless ck_fun s@ S S?
+
+# Pushy I/O.
+
+backtick backticks ck_null t%
+# glob defaults its first arg to $_
+glob glob ck_glob t@ S? S?
+readline <HANDLE> ck_null t%
+rcatline append I/O operator ck_null t%
+
+# Bindable operators.
+
+regcmaybe regexp comp once ck_fun s1 S
+regcreset regexp reset interpolation flag ck_fun s1 S
+regcomp regexp compilation ck_null s| S
+match pattern match ck_match d/
+qr pattern quote ck_match s/
+subst substitution ck_null dis/ S
+substcont substitution cont ck_null dis|
+trans character translation ck_null is" S
+
+# Lvalue operators.
+# sassign is special-cased for op class
+
+sassign scalar assignment ck_null s0
+aassign list assignment ck_null t2 L L
+
+chop chop ck_spair mts% L
+schop scalar chop ck_null stu% S?
+chomp safe chop ck_spair mts% L
+schomp scalar safe chop ck_null stu% S?
+defined defined operator ck_rfun isu% S?
+undef undef operator ck_lfun s% S?
+study study ck_fun su% S?
+pos match position ck_lfun stu% S?
+
+preinc preincrement ck_lfun dIs1 S
+i_preinc integer preincrement ck_lfun dis1 S
+predec predecrement ck_lfun dIs1 S
+i_predec integer predecrement ck_lfun dis1 S
+postinc postincrement ck_lfun dIst1 S
+i_postinc integer postincrement ck_lfun dist1 S
+postdec postdecrement ck_lfun dIst1 S
+i_postdec integer postdecrement ck_lfun dist1 S
+
+# Ordinary operators.
+
+pow exponentiation ck_null fst2 S S
+
+multiply multiplication ck_null Ifst2 S S
+i_multiply integer multiplication ck_null ifst2 S S
+divide division ck_null Ifst2 S S
+i_divide integer division ck_null ifst2 S S
+modulo modulus ck_null Iifst2 S S
+i_modulo integer modulus ck_null ifst2 S S
+repeat repeat ck_repeat mt2 L S
+
+add addition ck_null Ifst2 S S
+i_add integer addition ck_null ifst2 S S
+subtract subtraction ck_null Ifst2 S S
+i_subtract integer subtraction ck_null ifst2 S S
+concat concatenation ck_concat fst2 S S
+stringify string ck_fun fst@ S
+
+left_shift left bitshift ck_bitop fst2 S S
+right_shift right bitshift ck_bitop fst2 S S
+
+lt numeric lt ck_null Iifs2 S S
+i_lt integer lt ck_null ifs2 S S
+gt numeric gt ck_null Iifs2 S S
+i_gt integer gt ck_null ifs2 S S
+le numeric le ck_null Iifs2 S S
+i_le integer le ck_null ifs2 S S
+ge numeric ge ck_null Iifs2 S S
+i_ge integer ge ck_null ifs2 S S
+eq numeric eq ck_null Iifs2 S S
+i_eq integer eq ck_null ifs2 S S
+ne numeric ne ck_null Iifs2 S S
+i_ne integer ne ck_null ifs2 S S
+ncmp spaceship operator ck_null Iifst2 S S
+i_ncmp integer spaceship ck_null ifst2 S S
+
+slt string lt ck_scmp ifs2 S S
+sgt string gt ck_scmp ifs2 S S
+sle string le ck_scmp ifs2 S S
+sge string ge ck_scmp ifs2 S S
+seq string eq ck_null ifs2 S S
+sne string ne ck_null ifs2 S S
+scmp string comparison ck_scmp ifst2 S S
+
+bit_and bitwise and ck_bitop fst2 S S
+bit_xor bitwise xor ck_bitop fst2 S S
+bit_or bitwise or ck_bitop fst2 S S
+
+negate negate ck_null Ifst1 S
+i_negate integer negate ck_null ifst1 S
+not not ck_null ifs1 S
+complement 1's complement ck_bitop fst1 S
+
+# High falutin' math.
+
+atan2 atan2 ck_fun fst@ S S
+sin sin ck_fun fstu% S?
+cos cos ck_fun fstu% S?
+rand rand ck_fun st% S?
+srand srand ck_fun s% S?
+exp exp ck_fun fstu% S?
+log log ck_fun fstu% S?
+sqrt sqrt ck_fun fstu% S?
+
+# Lowbrow math.
+
+int int ck_fun fstu% S?
+hex hex ck_fun fstu% S?
+oct oct ck_fun fstu% S?
+abs abs ck_fun fstu% S?
+
+# String stuff.
+
+length length ck_lengthconst istu% S?
+substr substr ck_fun st@ S S S? S?
+vec vec ck_fun ist@ S S S
+
+index index ck_index ist@ S S S?
+rindex rindex ck_index ist@ S S S?
+
+sprintf sprintf ck_fun_locale mfst@ S L
+formline formline ck_fun ms@ S L
+ord ord ck_fun ifstu% S?
+chr chr ck_fun fstu% S?
+crypt crypt ck_fun fst@ S S
+ucfirst upper case first ck_fun_locale fstu% S?
+lcfirst lower case first ck_fun_locale fstu% S?
+uc upper case ck_fun_locale fstu% S?
+lc lower case ck_fun_locale fstu% S?
+quotemeta quote metachars ck_fun fstu% S?
+
+# Arrays.
+
+rv2av array deref ck_rvconst dt1
+aelemfast known array element ck_null s* A S
+aelem array element ck_null s2 A S
+aslice array slice ck_null m@ A L
+
+# Hashes.
+
+each each ck_fun t% H
+values values ck_fun t% H
+keys keys ck_fun t% H
+delete delete ck_delete % S
+exists exists operator ck_exists is% S
+rv2hv hash deref ck_rvconst dt1
+helem hash elem ck_null s2@ H S
+hslice hash slice ck_null m@ H L
+
+# Explosives and implosives.
+
+unpack unpack ck_fun @ S S
+pack pack ck_fun mst@ S L
+split split ck_split t@ S S S
+join join ck_fun mst@ S L
+
+# List operators.
+
+list list ck_null m@ L
+lslice list slice ck_null 2 H L L
+anonlist anonymous list ck_fun ms@ L
+anonhash anonymous hash ck_fun ms@ L
+
+splice splice ck_fun m@ A S? S? L
+push push ck_fun imst@ A L
+pop pop ck_shift si% A
+shift shift ck_shift s% A
+unshift unshift ck_fun imst@ A L
+sort sort ck_sort m@ C? L
+reverse reverse ck_fun mt@ L
+
+grepstart grep ck_grep dm@ C L
+grepwhile grep iterator ck_null dt|
+
+mapstart map ck_grep dm@ C L
+mapwhile map iterator ck_null dt|
+
+# Range stuff.
+
+range flipflop ck_null ? S S
+flip range (or flip) ck_null 1 S S
+flop range (or flop) ck_null 1
+
+# Control.
+
+and logical and ck_null |
+or logical or ck_null |
+xor logical xor ck_null fs| S S
+cond_expr conditional expression ck_null d?
+andassign logical and assignment ck_null s|
+orassign logical or assignment ck_null s|
+
+method method lookup ck_null d1
+entersub subroutine entry ck_subr dmt1 L
+leavesub subroutine exit ck_null 1
+caller caller ck_fun t% S?
+warn warn ck_fun imst@ L
+die die ck_fun dimst@ L
+reset reset ck_fun is% S?
+
+lineseq line sequence ck_null @
+nextstate next statement ck_null s;
+dbstate debug next statement ck_null s;
+unstack unstack ck_null s0
+enter block entry ck_null 0
+leave block exit ck_null @
+scope block ck_null @
+enteriter foreach loop entry ck_null d{
+iter foreach loop iterator ck_null 0
+enterloop loop entry ck_null d{
+leaveloop loop exit ck_null 2
+return return ck_null dm@ L
+last last ck_null ds}
+next next ck_null ds}
+redo redo ck_null ds}
+dump dump ck_null ds}
+goto goto ck_null ds}
+exit exit ck_fun ds% S?
+
+#nswitch numeric switch ck_null d
+#cswitch character switch ck_null d
+
+# I/O.
+
+open open ck_fun ist@ F S?
+close close ck_fun is% F?
+pipe_op pipe ck_fun is@ F F
+
+fileno fileno ck_fun ist% F
+umask umask ck_fun ist% S?
+binmode binmode ck_fun s% F
+
+tie tie ck_fun idms@ R S L
+untie untie ck_fun is% R
+tied tied ck_fun s% R
+dbmopen dbmopen ck_fun is@ H S S
+dbmclose dbmclose ck_fun is% H
+
+sselect select system call ck_select t@ S S S S
+select select ck_select st@ F?
+
+getc getc ck_eof st% F?
+read read ck_fun imst@ F R S S?
+enterwrite write ck_fun dis% F?
+leavewrite write exit ck_null 1
+
+prtf printf ck_listiob ims@ F? L
+print print ck_listiob ims@ F? L
+
+sysopen sysopen ck_fun s@ F S S S?
+sysseek sysseek ck_fun s@ F S S
+sysread sysread ck_fun imst@ F R S S?
+syswrite syswrite ck_fun imst@ F S S S?
+
+send send ck_fun imst@ F S S S?
+recv recv ck_fun imst@ F R S S
+
+eof eof ck_eof is% F?
+tell tell ck_fun st% F?
+seek seek ck_fun s@ F S S
+# truncate really behaves as if it had both "S S" and "F S"
+truncate truncate ck_trunc is@ S S
+
+fcntl fcntl ck_fun st@ F S S
+ioctl ioctl ck_fun st@ F S S
+flock flock ck_fun ist@ F S
+
+# Sockets.
+
+socket socket ck_fun is@ F S S S
+sockpair socketpair ck_fun is@ F F S S S
+
+bind bind ck_fun is@ F S
+connect connect ck_fun is@ F S
+listen listen ck_fun is@ F S
+accept accept ck_fun ist@ F F
+shutdown shutdown ck_fun ist@ F S
+
+gsockopt getsockopt ck_fun is@ F S S
+ssockopt setsockopt ck_fun is@ F S S S
+
+getsockname getsockname ck_fun is% F
+getpeername getpeername ck_fun is% F
+
+# Stat calls.
+
+lstat lstat ck_ftst u- F
+stat stat ck_ftst u- F
+ftrread -R ck_ftst isu- F
+ftrwrite -W ck_ftst isu- F
+ftrexec -X ck_ftst isu- F
+fteread -r ck_ftst isu- F
+ftewrite -w ck_ftst isu- F
+fteexec -x ck_ftst isu- F
+ftis -e ck_ftst isu- F
+fteowned -O ck_ftst isu- F
+ftrowned -o ck_ftst isu- F
+ftzero -z ck_ftst isu- F
+ftsize -s ck_ftst istu- F
+ftmtime -M ck_ftst stu- F
+ftatime -A ck_ftst stu- F
+ftctime -C ck_ftst stu- F
+ftsock -S ck_ftst isu- F
+ftchr -c ck_ftst isu- F
+ftblk -b ck_ftst isu- F
+ftfile -f ck_ftst isu- F
+ftdir -d ck_ftst isu- F
+ftpipe -p ck_ftst isu- F
+ftlink -l ck_ftst isu- F
+ftsuid -u ck_ftst isu- F
+ftsgid -g ck_ftst isu- F
+ftsvtx -k ck_ftst isu- F
+fttty -t ck_ftst is- F
+fttext -T ck_ftst isu- F
+ftbinary -B ck_ftst isu- F
+
+# File calls.
+
+chdir chdir ck_fun ist% S?
+chown chown ck_fun imst@ L
+chroot chroot ck_fun istu% S?
+unlink unlink ck_fun imstu@ L
+chmod chmod ck_fun imst@ L
+utime utime ck_fun imst@ L
+rename rename ck_fun ist@ S S
+link link ck_fun ist@ S S
+symlink symlink ck_fun ist@ S S
+readlink readlink ck_fun stu% S?
+mkdir mkdir ck_fun ist@ S S
+rmdir rmdir ck_fun istu% S?
+
+# Directory calls.
+
+open_dir opendir ck_fun is@ F S
+readdir readdir ck_fun % F
+telldir telldir ck_fun st% F
+seekdir seekdir ck_fun s@ F S
+rewinddir rewinddir ck_fun s% F
+closedir closedir ck_fun is% F
+
+# Process control.
+
+fork fork ck_null ist0
+wait wait ck_null ist0
+waitpid waitpid ck_fun ist@ S S
+system system ck_exec imst@ S? L
+exec exec ck_exec dimst@ S? L
+kill kill ck_fun dimst@ L
+getppid getppid ck_null ist0
+getpgrp getpgrp ck_fun ist% S?
+setpgrp setpgrp ck_fun ist@ S? S?
+getpriority getpriority ck_fun ist@ S S
+setpriority setpriority ck_fun ist@ S S S
+
+# Time calls.
+
+time time ck_null ist0
+tms times ck_null 0
+localtime localtime ck_fun t% S?
+gmtime gmtime ck_fun t% S?
+alarm alarm ck_fun istu% S?
+sleep sleep ck_fun ist% S?
+
+# Shared memory.
+
+shmget shmget ck_fun imst@ S S S
+shmctl shmctl ck_fun imst@ S S S
+shmread shmread ck_fun imst@ S S S S
+shmwrite shmwrite ck_fun imst@ S S S S
+
+# Message passing.
+
+msgget msgget ck_fun imst@ S S
+msgctl msgctl ck_fun imst@ S S S
+msgsnd msgsnd ck_fun imst@ S S S
+msgrcv msgrcv ck_fun imst@ S S S S S
+
+# Semaphores.
+
+semget semget ck_fun imst@ S S S
+semctl semctl ck_fun imst@ S S S S
+semop semop ck_fun imst@ S S
+
+# Eval.
+
+require require ck_require du% S?
+dofile do 'file' ck_fun d1 S
+entereval eval string ck_eval d% S
+leaveeval eval exit ck_null 1 S
+#evalonce eval constant string ck_null d1 S
+entertry eval block ck_null |
+leavetry eval block exit ck_null @
+
+# Get system info.
+
+ghbyname gethostbyname ck_fun % S
+ghbyaddr gethostbyaddr ck_fun @ S S
+ghostent gethostent ck_null 0
+gnbyname getnetbyname ck_fun % S
+gnbyaddr getnetbyaddr ck_fun @ S S
+gnetent getnetent ck_null 0
+gpbyname getprotobyname ck_fun % S
+gpbynumber getprotobynumber ck_fun @ S
+gprotoent getprotoent ck_null 0
+gsbyname getservbyname ck_fun @ S S
+gsbyport getservbyport ck_fun @ S S
+gservent getservent ck_null 0
+shostent sethostent ck_fun is% S
+snetent setnetent ck_fun is% S
+sprotoent setprotoent ck_fun is% S
+sservent setservent ck_fun is% S
+ehostent endhostent ck_null is0
+enetent endnetent ck_null is0
+eprotoent endprotoent ck_null is0
+eservent endservent ck_null is0
+gpwnam getpwnam ck_fun % S
+gpwuid getpwuid ck_fun % S
+gpwent getpwent ck_null 0
+spwent setpwent ck_null is0
+epwent endpwent ck_null is0
+ggrnam getgrnam ck_fun % S
+ggrgid getgrgid ck_fun % S
+ggrent getgrent ck_null 0
+sgrent setgrent ck_null is0
+egrent endgrent ck_null is0
+getlogin getlogin ck_null st0
+
+# Miscellaneous.
+
+syscall syscall ck_fun imst@ S L
+
+# For multi-threading
+lock lock ck_rfun s% S
+threadsv per-thread variable ck_null ds0
diff --git a/contrib/perl5/patchlevel.h b/contrib/perl5/patchlevel.h
new file mode 100644
index 000000000000..2245b1f2a758
--- /dev/null
+++ b/contrib/perl5/patchlevel.h
@@ -0,0 +1,51 @@
+#ifndef __PATCHLEVEL_H_INCLUDED__
+#define PATCHLEVEL 5
+#undef SUBVERSION /* OS/390 has a SUBVERSION in a system header */
+#define SUBVERSION 2
+
+/*
+ local_patches -- list of locally applied less-than-subversion patches.
+ If you're distributing such a patch, please give it a name and a
+ one-line description, placed just before the last NULL in the array
+ below. If your patch fixes a bug in the perlbug database, please
+ mention the bugid. If your patch *IS* dependent on a prior patch,
+ please place your applied patch line after its dependencies. This
+ will help tracking of patch dependencies.
+
+ Please edit the hunk of diff which adds your patch to this list,
+ to remove context lines which would give patch problems. For instance,
+ if the original context diff is
+ *** patchlevel.h.orig <date here>
+ --- patchlevel.h <date here>
+ *** 38,43 ***
+ --- 38,44 ---
+ ,"FOO1235 - some patch"
+ ,"BAR3141 - another patch"
+ ,"BAZ2718 - and another patch"
+ + ,"MINE001 - my new patch"
+ ,NULL
+ };
+
+ please change it to
+ *** patchlevel.h.orig <date here>
+ --- patchlevel.h <date here>
+ *** 41,43 ***
+ --- 41,44 ---
+ + ,"MINE001 - my new patch"
+ };
+
+ (Note changes to line numbers as well as removal of context lines.)
+ This will prevent patch from choking if someone has previously
+ applied different patches than you.
+ */
+static char *local_patches[] = {
+ NULL
+ ,NULL
+};
+
+/* Initial space prevents this variable from being inserted in config.sh */
+# define LOCAL_PATCH_COUNT \
+ (sizeof(local_patches)/sizeof(local_patches[0])-2)
+
+# define __PATCHLEVEL_H_INCLUDED__
+#endif
diff --git a/contrib/perl5/perl.c b/contrib/perl5/perl.c
new file mode 100644
index 000000000000..e76d83afdfd8
--- /dev/null
+++ b/contrib/perl5/perl.c
@@ -0,0 +1,2983 @@
+/* perl.c
+ *
+ * Copyright (c) 1987-1998 Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "patchlevel.h"
+
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+
+#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
+char *getenv _((char *)); /* Usually in <stdlib.h> */
+#endif
+
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
+#ifdef IAMSUID
+#ifndef DOSUID
+#define DOSUID
+#endif
+#endif
+
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+#ifdef DOSUID
+#undef DOSUID
+#endif
+#endif
+
+#ifdef PERL_OBJECT
+static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
+#else
+static void find_beginning _((void));
+static void forbid_setid _((char *));
+static void incpush _((char *, int));
+static void init_interp _((void));
+static void init_ids _((void));
+static void init_debugger _((void));
+static void init_lexer _((void));
+static void init_main_stash _((void));
+#ifdef USE_THREADS
+static struct perl_thread * init_main_thread _((void));
+#endif /* USE_THREADS */
+static void init_perllib _((void));
+static void init_postdump_symbols _((int, char **, char **));
+static void init_predump_symbols _((void));
+static void my_exit_jump _((void)) __attribute__((noreturn));
+static void nuke_stacks _((void));
+static void open_script _((char *, bool, SV *, int *fd));
+static void usage _((char *));
+static void validate_suid _((char *, char*, int));
+static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
+#endif
+
+#ifdef PERL_OBJECT
+CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
+ IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
+{
+ CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
+ if(pPerl != NULL)
+ pPerl->Init();
+
+ return pPerl;
+}
+#else
+PerlInterpreter *
+perl_alloc(void)
+{
+ PerlInterpreter *sv_interp;
+
+ PL_curinterp = 0;
+ New(53, sv_interp, 1, PerlInterpreter);
+ return sv_interp;
+}
+#endif /* PERL_OBJECT */
+
+void
+#ifdef PERL_OBJECT
+CPerlObj::perl_construct(void)
+#else
+perl_construct(register PerlInterpreter *sv_interp)
+#endif
+{
+#ifdef USE_THREADS
+ int i;
+#ifndef FAKE_THREADS
+ struct perl_thread *thr;
+#endif /* FAKE_THREADS */
+#endif /* USE_THREADS */
+
+#ifndef PERL_OBJECT
+ if (!(PL_curinterp = sv_interp))
+ return;
+#endif
+
+#ifdef MULTIPLICITY
+ ++PL_ninterps;
+ Zero(sv_interp, 1, PerlInterpreter);
+#endif
+
+ /* Init the real globals (and main thread)? */
+ if (!PL_linestr) {
+#ifdef USE_THREADS
+
+ INIT_THREADS;
+#ifdef ALLOC_THREAD_KEY
+ ALLOC_THREAD_KEY;
+#else
+ if (pthread_key_create(&PL_thr_key, 0))
+ croak("panic: pthread_key_create");
+#endif
+ MUTEX_INIT(&PL_sv_mutex);
+ /*
+ * Safe to use basic SV functions from now on (though
+ * not things like mortals or tainting yet).
+ */
+ MUTEX_INIT(&PL_eval_mutex);
+ COND_INIT(&PL_eval_cond);
+ MUTEX_INIT(&PL_threads_mutex);
+ COND_INIT(&PL_nthreads_cond);
+#ifdef EMULATE_ATOMIC_REFCOUNTS
+ MUTEX_INIT(&PL_svref_mutex);
+#endif /* EMULATE_ATOMIC_REFCOUNTS */
+
+ thr = init_main_thread();
+#endif /* USE_THREADS */
+
+ PL_linestr = NEWSV(65,79);
+ sv_upgrade(PL_linestr,SVt_PVIV);
+
+ if (!SvREADONLY(&PL_sv_undef)) {
+ /* set read-only and try to insure than we wont see REFCNT==0
+ very often */
+
+ SvREADONLY_on(&PL_sv_undef);
+ SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
+
+ sv_setpv(&PL_sv_no,PL_No);
+ SvNV(&PL_sv_no);
+ SvREADONLY_on(&PL_sv_no);
+ SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
+
+ sv_setpv(&PL_sv_yes,PL_Yes);
+ SvNV(&PL_sv_yes);
+ SvREADONLY_on(&PL_sv_yes);
+ SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
+ }
+
+#ifdef PERL_OBJECT
+ /* TODO: */
+ /* PL_sighandlerp = sighandler; */
+#else
+ PL_sighandlerp = sighandler;
+#endif
+ PL_pidstatus = newHV();
+
+#ifdef MSDOS
+ /*
+ * There is no way we can refer to them from Perl so close them to save
+ * space. The other alternative would be to provide STDAUX and STDPRN
+ * filehandles.
+ */
+ (void)fclose(stdaux);
+ (void)fclose(stdprn);
+#endif
+ }
+
+ PL_nrs = newSVpv("\n", 1);
+ PL_rs = SvREFCNT_inc(PL_nrs);
+
+ init_stacks(ARGS);
+#ifdef MULTIPLICITY
+ init_interp();
+ PL_perl_destruct_level = 1;
+#else
+ if (PL_perl_destruct_level > 0)
+ init_interp();
+#endif
+
+ init_ids();
+ PL_lex_state = LEX_NOTPARSING;
+
+ PL_start_env.je_prev = NULL;
+ PL_start_env.je_ret = -1;
+ PL_start_env.je_mustcatch = TRUE;
+ PL_top_env = &PL_start_env;
+ STATUS_ALL_SUCCESS;
+
+ SET_NUMERIC_STANDARD();
+#if defined(SUBVERSION) && SUBVERSION > 0
+ sprintf(PL_patchlevel, "%7.5f", (double) 5
+ + ((double) PATCHLEVEL / (double) 1000)
+ + ((double) SUBVERSION / (double) 100000));
+#else
+ sprintf(PL_patchlevel, "%5.3f", (double) 5 +
+ ((double) PATCHLEVEL / (double) 1000));
+#endif
+
+#if defined(LOCAL_PATCH_COUNT)
+ PL_localpatches = local_patches; /* For possible -v */
+#endif
+
+ PerlIO_init(); /* Hook to IO system */
+
+ PL_fdpid = newAV(); /* for remembering popen pids by fd */
+ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
+
+ DEBUG( {
+ New(51,PL_debname,128,char);
+ New(52,PL_debdelim,128,char);
+ } )
+
+ ENTER;
+}
+
+void
+#ifdef PERL_OBJECT
+CPerlObj::perl_destruct(void)
+#else
+perl_destruct(register PerlInterpreter *sv_interp)
+#endif
+{
+ dTHR;
+ int destruct_level; /* 0=none, 1=full, 2=full with checks */
+ I32 last_sv_count;
+ HV *hv;
+#ifdef USE_THREADS
+ Thread t;
+#endif /* USE_THREADS */
+
+#ifndef PERL_OBJECT
+ if (!(PL_curinterp = sv_interp))
+ return;
+#endif
+
+#ifdef USE_THREADS
+#ifndef FAKE_THREADS
+ /* Pass 1 on any remaining threads: detach joinables, join zombies */
+ retry_cleanup:
+ MUTEX_LOCK(&PL_threads_mutex);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: waiting for %d threads...\n",
+ PL_nthreads - 1));
+ for (t = thr->next; t != thr; t = t->next) {
+ MUTEX_LOCK(&t->mutex);
+ switch (ThrSTATE(t)) {
+ AV *av;
+ case THRf_ZOMBIE:
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: joining zombie %p\n", t));
+ ThrSETSTATE(t, THRf_DEAD);
+ MUTEX_UNLOCK(&t->mutex);
+ PL_nthreads--;
+ /*
+ * The SvREFCNT_dec below may take a long time (e.g. av
+ * may contain an object scalar whose destructor gets
+ * called) so we have to unlock threads_mutex and start
+ * all over again.
+ */
+ MUTEX_UNLOCK(&PL_threads_mutex);
+ JOIN(t, &av);
+ SvREFCNT_dec((SV*)av);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: joined zombie %p OK\n", t));
+ goto retry_cleanup;
+ case THRf_R_JOINABLE:
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: detaching thread %p\n", t));
+ ThrSETSTATE(t, THRf_R_DETACHED);
+ /*
+ * We unlock threads_mutex and t->mutex in the opposite order
+ * from which we locked them just so that DETACH won't
+ * deadlock if it panics. It's only a breach of good style
+ * not a bug since they are unlocks not locks.
+ */
+ MUTEX_UNLOCK(&PL_threads_mutex);
+ DETACH(t);
+ MUTEX_UNLOCK(&t->mutex);
+ goto retry_cleanup;
+ default:
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: ignoring %p (state %u)\n",
+ t, ThrSTATE(t)));
+ MUTEX_UNLOCK(&t->mutex);
+ /* fall through and out */
+ }
+ }
+ /* We leave the above "Pass 1" loop with threads_mutex still locked */
+
+ /* Pass 2 on remaining threads: wait for the thread count to drop to one */
+ while (PL_nthreads > 1)
+ {
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "perl_destruct: final wait for %d threads\n",
+ PL_nthreads - 1));
+ COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
+ }
+ /* At this point, we're the last thread */
+ MUTEX_UNLOCK(&PL_threads_mutex);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
+ MUTEX_DESTROY(&PL_threads_mutex);
+ COND_DESTROY(&PL_nthreads_cond);
+#endif /* !defined(FAKE_THREADS) */
+#endif /* USE_THREADS */
+
+ destruct_level = PL_perl_destruct_level;
+#ifdef DEBUGGING
+ {
+ char *s;
+ if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
+ int i = atoi(s);
+ if (destruct_level < i)
+ destruct_level = i;
+ }
+ }
+#endif
+
+ LEAVE;
+ FREETMPS;
+
+#ifdef MULTIPLICITY
+ --PL_ninterps;
+#endif
+
+ /* We must account for everything. */
+
+ /* Destroy the main CV and syntax tree */
+ if (PL_main_root) {
+ PL_curpad = AvARRAY(PL_comppad);
+ op_free(PL_main_root);
+ PL_main_root = Nullop;
+ }
+ PL_curcop = &PL_compiling;
+ PL_main_start = Nullop;
+ SvREFCNT_dec(PL_main_cv);
+ PL_main_cv = Nullcv;
+
+ if (PL_sv_objcount) {
+ /*
+ * Try to destruct global references. We do this first so that the
+ * destructors and destructees still exist. Some sv's might remain.
+ * Non-referenced objects are on their own.
+ */
+
+ PL_dirty = TRUE;
+ sv_clean_objs();
+ }
+
+ /* unhook hooks which will soon be, or use, destroyed data */
+ SvREFCNT_dec(PL_warnhook);
+ PL_warnhook = Nullsv;
+ SvREFCNT_dec(PL_diehook);
+ PL_diehook = Nullsv;
+ SvREFCNT_dec(PL_parsehook);
+ PL_parsehook = Nullsv;
+
+ /* call exit list functions */
+ while (PL_exitlistlen-- > 0)
+ PL_exitlist[PL_exitlistlen].fn(PERL_OBJECT_THIS_ PL_exitlist[PL_exitlistlen].ptr);
+
+ Safefree(PL_exitlist);
+
+ if (destruct_level == 0){
+
+ DEBUG_P(debprofdump());
+
+ /* The exit() function will do everything that needs doing. */
+ return;
+ }
+
+ /* loosen bonds of global variables */
+
+ if(PL_rsfp) {
+ (void)PerlIO_close(PL_rsfp);
+ PL_rsfp = Nullfp;
+ }
+
+ /* Filters for program text */
+ SvREFCNT_dec(PL_rsfp_filters);
+ PL_rsfp_filters = Nullav;
+
+ /* switches */
+ PL_preprocess = FALSE;
+ PL_minus_n = FALSE;
+ PL_minus_p = FALSE;
+ PL_minus_l = FALSE;
+ PL_minus_a = FALSE;
+ PL_minus_F = FALSE;
+ PL_doswitches = FALSE;
+ PL_dowarn = FALSE;
+ PL_doextract = FALSE;
+ PL_sawampersand = FALSE; /* must save all match strings */
+ PL_sawstudy = FALSE; /* do fbm_instr on all strings */
+ PL_sawvec = FALSE;
+ PL_unsafe = FALSE;
+
+ Safefree(PL_inplace);
+ PL_inplace = Nullch;
+
+ if (PL_e_script) {
+ SvREFCNT_dec(PL_e_script);
+ PL_e_script = Nullsv;
+ }
+
+ /* magical thingies */
+
+ Safefree(PL_ofs); /* $, */
+ PL_ofs = Nullch;
+
+ Safefree(PL_ors); /* $\ */
+ PL_ors = Nullch;
+
+ SvREFCNT_dec(PL_rs); /* $/ */
+ PL_rs = Nullsv;
+
+ SvREFCNT_dec(PL_nrs); /* $/ helper */
+ PL_nrs = Nullsv;
+
+ PL_multiline = 0; /* $* */
+
+ SvREFCNT_dec(PL_statname);
+ PL_statname = Nullsv;
+ PL_statgv = Nullgv;
+
+ /* defgv, aka *_ should be taken care of elsewhere */
+
+ /* clean up after study() */
+ SvREFCNT_dec(PL_lastscream);
+ PL_lastscream = Nullsv;
+ Safefree(PL_screamfirst);
+ PL_screamfirst = 0;
+ Safefree(PL_screamnext);
+ PL_screamnext = 0;
+
+ /* startup and shutdown function lists */
+ SvREFCNT_dec(PL_beginav);
+ SvREFCNT_dec(PL_endav);
+ SvREFCNT_dec(PL_initav);
+ PL_beginav = Nullav;
+ PL_endav = Nullav;
+ PL_initav = Nullav;
+
+ /* shortcuts just get cleared */
+ PL_envgv = Nullgv;
+ PL_siggv = Nullgv;
+ PL_incgv = Nullgv;
+ PL_hintgv = Nullgv;
+ PL_errgv = Nullgv;
+ PL_argvgv = Nullgv;
+ PL_argvoutgv = Nullgv;
+ PL_stdingv = Nullgv;
+ PL_last_in_gv = Nullgv;
+ PL_replgv = Nullgv;
+
+ /* reset so print() ends up where we expect */
+ setdefout(Nullgv);
+
+ /* Prepare to destruct main symbol table. */
+
+ hv = PL_defstash;
+ PL_defstash = 0;
+ SvREFCNT_dec(hv);
+
+ FREETMPS;
+ if (destruct_level >= 2) {
+ if (PL_scopestack_ix != 0)
+ warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
+ (long)PL_scopestack_ix);
+ if (PL_savestack_ix != 0)
+ warn("Unbalanced saves: %ld more saves than restores\n",
+ (long)PL_savestack_ix);
+ if (PL_tmps_floor != -1)
+ warn("Unbalanced tmps: %ld more allocs than frees\n",
+ (long)PL_tmps_floor + 1);
+ if (cxstack_ix != -1)
+ warn("Unbalanced context: %ld more PUSHes than POPs\n",
+ (long)cxstack_ix + 1);
+ }
+
+ /* Now absolutely destruct everything, somehow or other, loops or no. */
+ last_sv_count = 0;
+ SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
+ while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
+ last_sv_count = PL_sv_count;
+ sv_clean_all();
+ }
+ SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
+ SvFLAGS(PL_strtab) |= SVt_PVHV;
+
+ /* Destruct the global string table. */
+ {
+ /* Yell and reset the HeVAL() slots that are still holding refcounts,
+ * so that sv_free() won't fail on them.
+ */
+ I32 riter;
+ I32 max;
+ HE *hent;
+ HE **array;
+
+ riter = 0;
+ max = HvMAX(PL_strtab);
+ array = HvARRAY(PL_strtab);
+ hent = array[0];
+ for (;;) {
+ if (hent) {
+ warn("Unbalanced string table refcount: (%d) for \"%s\"",
+ HeVAL(hent) - Nullsv, HeKEY(hent));
+ HeVAL(hent) = Nullsv;
+ hent = HeNEXT(hent);
+ }
+ if (!hent) {
+ if (++riter > max)
+ break;
+ hent = array[riter];
+ }
+ }
+ }
+ SvREFCNT_dec(PL_strtab);
+
+ if (PL_sv_count != 0)
+ warn("Scalars leaked: %ld\n", (long)PL_sv_count);
+
+ sv_free_arenas();
+
+ /* No SVs have survived, need to clean out */
+ PL_linestr = NULL;
+ PL_pidstatus = Nullhv;
+ Safefree(PL_origfilename);
+ Safefree(PL_archpat_auto);
+ Safefree(PL_reg_start_tmp);
+ Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
+ Safefree(PL_op_mask);
+ nuke_stacks();
+ PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
+
+ DEBUG_P(debprofdump());
+#ifdef USE_THREADS
+ MUTEX_DESTROY(&PL_sv_mutex);
+ MUTEX_DESTROY(&PL_eval_mutex);
+ COND_DESTROY(&PL_eval_cond);
+
+ /* As the penultimate thing, free the non-arena SV for thrsv */
+ Safefree(SvPVX(PL_thrsv));
+ Safefree(SvANY(PL_thrsv));
+ Safefree(PL_thrsv);
+ PL_thrsv = Nullsv;
+#endif /* USE_THREADS */
+
+ /* As the absolutely last thing, free the non-arena SV for mess() */
+
+ if (PL_mess_sv) {
+ /* it could have accumulated taint magic */
+ if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
+ MAGIC* mg;
+ MAGIC* moremagic;
+ for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
+ moremagic = mg->mg_moremagic;
+ if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
+ Safefree(mg->mg_ptr);
+ Safefree(mg);
+ }
+ }
+ /* we know that type >= SVt_PV */
+ SvOOK_off(PL_mess_sv);
+ Safefree(SvPVX(PL_mess_sv));
+ Safefree(SvANY(PL_mess_sv));
+ Safefree(PL_mess_sv);
+ PL_mess_sv = Nullsv;
+ }
+}
+
+void
+#ifdef PERL_OBJECT
+CPerlObj::perl_free(void)
+#else
+perl_free(PerlInterpreter *sv_interp)
+#endif
+{
+#ifdef PERL_OBJECT
+ Safefree(this);
+#else
+ if (!(PL_curinterp = sv_interp))
+ return;
+ Safefree(sv_interp);
+#endif
+}
+
+void
+#ifdef PERL_OBJECT
+CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
+#else
+perl_atexit(void (*fn) (void *), void *ptr)
+#endif
+{
+ Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
+ PL_exitlist[PL_exitlistlen].fn = fn;
+ PL_exitlist[PL_exitlistlen].ptr = ptr;
+ ++PL_exitlistlen;
+}
+
+int
+#ifdef PERL_OBJECT
+CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
+#else
+perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
+#endif
+{
+ dTHR;
+ register SV *sv;
+ register char *s;
+ char *scriptname = NULL;
+ VOL bool dosearch = FALSE;
+ char *validarg = "";
+ I32 oldscope;
+ AV* comppadlist;
+ dJMPENV;
+ int ret;
+ int fdscript = -1;
+
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+#ifdef IAMSUID
+#undef IAMSUID
+ croak("suidperl is no longer needed since the kernel can now execute\n\
+setuid perl scripts securely.\n");
+#endif
+#endif
+
+#ifndef PERL_OBJECT
+ if (!(PL_curinterp = sv_interp))
+ return 255;
+#endif
+
+#if defined(NeXT) && defined(__DYNAMIC__)
+ _dyld_lookup_and_bind
+ ("__environ", (unsigned long *) &environ_pointer, NULL);
+#endif /* environ */
+
+ PL_origargv = argv;
+ PL_origargc = argc;
+#ifndef VMS /* VMS doesn't have environ array */
+ PL_origenviron = environ;
+#endif
+
+ if (PL_do_undump) {
+
+ /* Come here if running an undumped a.out. */
+
+ PL_origfilename = savepv(argv[0]);
+ PL_do_undump = FALSE;
+ cxstack_ix = -1; /* start label stack again */
+ init_ids();
+ init_postdump_symbols(argc,argv,env);
+ return 0;
+ }
+
+ if (PL_main_root) {
+ PL_curpad = AvARRAY(PL_comppad);
+ op_free(PL_main_root);
+ PL_main_root = Nullop;
+ }
+ PL_main_start = Nullop;
+ SvREFCNT_dec(PL_main_cv);
+ PL_main_cv = Nullcv;
+
+ time(&PL_basetime);
+ oldscope = PL_scopestack_ix;
+
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 1:
+ STATUS_ALL_FAILURE;
+ /* FALL THROUGH */
+ case 2:
+ /* my_exit() was called */
+ while (PL_scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
+ PL_curstash = PL_defstash;
+ if (PL_endav)
+ call_list(oldscope, PL_endav);
+ JMPENV_POP;
+ return STATUS_NATIVE_EXPORT;
+ case 3:
+ JMPENV_POP;
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
+ return 1;
+ }
+
+ sv_setpvn(PL_linestr,"",0);
+ sv = newSVpv("",0); /* first used for -I flags */
+ SAVEFREESV(sv);
+ init_main_stash();
+
+ for (argc--,argv++; argc > 0; argc--,argv++) {
+ if (argv[0][0] != '-' || !argv[0][1])
+ break;
+#ifdef DOSUID
+ if (*validarg)
+ validarg = " PHOOEY ";
+ else
+ validarg = argv[0];
+#endif
+ s = argv[0]+1;
+ reswitch:
+ switch (*s) {
+ case ' ':
+ case '0':
+ case 'F':
+ case 'a':
+ case 'c':
+ case 'd':
+ case 'D':
+ case 'h':
+ case 'i':
+ case 'l':
+ case 'M':
+ case 'm':
+ case 'n':
+ case 'p':
+ case 's':
+ case 'u':
+ case 'U':
+ case 'v':
+ case 'w':
+ if (s = moreswitches(s))
+ goto reswitch;
+ break;
+
+ case 'T':
+ PL_tainting = TRUE;
+ s++;
+ goto reswitch;
+
+ case 'e':
+ if (PL_euid != PL_uid || PL_egid != PL_gid)
+ croak("No -e allowed in setuid scripts");
+ if (!PL_e_script) {
+ PL_e_script = newSVpv("",0);
+ filter_add(read_e_script, NULL);
+ }
+ if (*++s)
+ sv_catpv(PL_e_script, s);
+ else if (argv[1]) {
+ sv_catpv(PL_e_script, argv[1]);
+ argc--,argv++;
+ }
+ else
+ croak("No code specified for -e");
+ sv_catpv(PL_e_script, "\n");
+ break;
+
+ case 'I': /* -I handled both here and in moreswitches() */
+ forbid_setid("-I");
+ if (!*++s && (s=argv[1]) != Nullch) {
+ argc--,argv++;
+ }
+ while (s && isSPACE(*s))
+ ++s;
+ if (s && *s) {
+ char *e, *p;
+ for (e = s; *e && !isSPACE(*e); e++) ;
+ p = savepvn(s, e-s);
+ incpush(p, TRUE);
+ sv_catpv(sv,"-I");
+ sv_catpv(sv,p);
+ sv_catpv(sv," ");
+ Safefree(p);
+ } /* XXX else croak? */
+ break;
+ case 'P':
+ forbid_setid("-P");
+ PL_preprocess = TRUE;
+ s++;
+ goto reswitch;
+ case 'S':
+ forbid_setid("-S");
+ dosearch = TRUE;
+ s++;
+ goto reswitch;
+ case 'V':
+ if (!PL_preambleav)
+ PL_preambleav = newAV();
+ av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
+ if (*++s != ':') {
+ PL_Sv = newSVpv("print myconfig();",0);
+#ifdef VMS
+ sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
+#else
+ sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
+#endif
+#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
+ sv_catpv(PL_Sv,"\" Compile-time options:");
+# ifdef DEBUGGING
+ sv_catpv(PL_Sv," DEBUGGING");
+# endif
+# ifdef NO_EMBED
+ sv_catpv(PL_Sv," NO_EMBED");
+# endif
+# ifdef MULTIPLICITY
+ sv_catpv(PL_Sv," MULTIPLICITY");
+# endif
+ sv_catpv(PL_Sv,"\\n\",");
+#endif
+#if defined(LOCAL_PATCH_COUNT)
+ if (LOCAL_PATCH_COUNT > 0) {
+ int i;
+ sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
+ for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
+ if (PL_localpatches[i])
+ sv_catpvf(PL_Sv,"\" \\t%s\\n\",",PL_localpatches[i]);
+ }
+ }
+#endif
+ sv_catpvf(PL_Sv,"\" Built under %s\\n\"",OSNAME);
+#ifdef __DATE__
+# ifdef __TIME__
+ sv_catpvf(PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
+# else
+ sv_catpvf(PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
+# endif
+#endif
+ sv_catpv(PL_Sv, "; \
+$\"=\"\\n \"; \
+@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
+print \" \\%ENV:\\n @env\\n\" if @env; \
+print \" \\@INC:\\n @INC\\n\";");
+ }
+ else {
+ PL_Sv = newSVpv("config_vars(qw(",0);
+ sv_catpv(PL_Sv, ++s);
+ sv_catpv(PL_Sv, "))");
+ s += strlen(s);
+ }
+ av_push(PL_preambleav, PL_Sv);
+ scriptname = BIT_BUCKET; /* don't look for script or read stdin */
+ goto reswitch;
+ case 'x':
+ PL_doextract = TRUE;
+ s++;
+ if (*s)
+ PL_cddir = savepv(s);
+ break;
+ case 0:
+ break;
+ case '-':
+ if (!*++s || isSPACE(*s)) {
+ argc--,argv++;
+ goto switch_end;
+ }
+ /* catch use of gnu style long options */
+ if (strEQ(s, "version")) {
+ s = "v";
+ goto reswitch;
+ }
+ if (strEQ(s, "help")) {
+ s = "h";
+ goto reswitch;
+ }
+ s--;
+ /* FALL THROUGH */
+ default:
+ croak("Unrecognized switch: -%s (-h will show valid options)",s);
+ }
+ }
+ switch_end:
+
+ if (!PL_tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
+ while (s && *s) {
+ while (isSPACE(*s))
+ s++;
+ if (*s == '-') {
+ s++;
+ if (isSPACE(*s))
+ continue;
+ }
+ if (!*s)
+ break;
+ if (!strchr("DIMUdmw", *s))
+ croak("Illegal switch in PERL5OPT: -%c", *s);
+ s = moreswitches(s);
+ }
+ }
+
+ if (!scriptname)
+ scriptname = argv[0];
+ if (PL_e_script) {
+ argc++,argv--;
+ scriptname = BIT_BUCKET; /* don't look for script or read stdin */
+ }
+ else if (scriptname == Nullch) {
+#ifdef MSDOS
+ if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
+ moreswitches("h");
+#endif
+ scriptname = "-";
+ }
+
+ init_perllib();
+
+ open_script(scriptname,dosearch,sv,&fdscript);
+
+ validate_suid(validarg, scriptname,fdscript);
+
+ if (PL_doextract)
+ find_beginning();
+
+ PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)PL_compcv, SVt_PVCV);
+ CvUNIQUE_on(PL_compcv);
+
+ PL_comppad = newAV();
+ av_push(PL_comppad, Nullsv);
+ PL_curpad = AvARRAY(PL_comppad);
+ PL_comppad_name = newAV();
+ PL_comppad_name_fill = 0;
+ PL_min_intro_pending = 0;
+ PL_padix = 0;
+#ifdef USE_THREADS
+ av_store(PL_comppad_name, 0, newSVpv("@_", 2));
+ PL_curpad[0] = (SV*)newAV();
+ SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
+ CvOWNER(PL_compcv) = 0;
+ New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(PL_compcv));
+#endif /* USE_THREADS */
+
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, (SV*)PL_comppad_name);
+ av_store(comppadlist, 1, (SV*)PL_comppad);
+ CvPADLIST(PL_compcv) = comppadlist;
+
+ boot_core_UNIVERSAL();
+
+ if (xsinit)
+ (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
+#if defined(VMS) || defined(WIN32) || defined(DJGPP)
+ init_os_extras();
+#endif
+
+ init_predump_symbols();
+ /* init_postdump_symbols not currently designed to be called */
+ /* more than once (ENV isn't cleared first, for example) */
+ /* But running with -u leaves %ENV & @ARGV undefined! XXX */
+ if (!PL_do_undump)
+ init_postdump_symbols(argc,argv,env);
+
+ init_lexer();
+
+ /* now parse the script */
+
+ SETERRNO(0,SS$_NORMAL);
+ PL_error_count = 0;
+ if (yyparse() || PL_error_count) {
+ if (PL_minus_c)
+ croak("%s had compilation errors.\n", PL_origfilename);
+ else {
+ croak("Execution of %s aborted due to compilation errors.\n",
+ PL_origfilename);
+ }
+ }
+ PL_curcop->cop_line = 0;
+ PL_curstash = PL_defstash;
+ PL_preprocess = FALSE;
+ if (PL_e_script) {
+ SvREFCNT_dec(PL_e_script);
+ PL_e_script = Nullsv;
+ }
+
+ /* now that script is parsed, we can modify record separator */
+ SvREFCNT_dec(PL_rs);
+ PL_rs = SvREFCNT_inc(PL_nrs);
+ sv_setsv(perl_get_sv("/", TRUE), PL_rs);
+ if (PL_do_undump)
+ my_unexec();
+
+ if (PL_dowarn)
+ gv_check(PL_defstash);
+
+ LEAVE;
+ FREETMPS;
+
+#ifdef MYMALLOC
+ if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
+ dump_mstats("after compilation:");
+#endif
+
+ ENTER;
+ PL_restartop = 0;
+ JMPENV_POP;
+ return 0;
+}
+
+int
+#ifdef PERL_OBJECT
+CPerlObj::perl_run(void)
+#else
+perl_run(PerlInterpreter *sv_interp)
+#endif
+{
+ dSP;
+ I32 oldscope;
+ dJMPENV;
+ int ret;
+
+#ifndef PERL_OBJECT
+ if (!(PL_curinterp = sv_interp))
+ return 255;
+#endif
+
+ oldscope = PL_scopestack_ix;
+
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 1:
+ cxstack_ix = -1; /* start context stack again */
+ break;
+ case 2:
+ /* my_exit() was called */
+ while (PL_scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
+ PL_curstash = PL_defstash;
+ if (PL_endav)
+ call_list(oldscope, PL_endav);
+#ifdef MYMALLOC
+ if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
+ dump_mstats("after execution: ");
+#endif
+ JMPENV_POP;
+ return STATUS_NATIVE_EXPORT;
+ case 3:
+ if (!PL_restartop) {
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ FREETMPS;
+ JMPENV_POP;
+ return 1;
+ }
+ POPSTACK_TO(PL_mainstack);
+ break;
+ }
+
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
+ PL_sawampersand ? "Enabling" : "Omitting"));
+
+ if (!PL_restartop) {
+ DEBUG_x(dump_all());
+ DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+ DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
+ (unsigned long) thr));
+
+ if (PL_minus_c) {
+ PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
+ my_exit(0);
+ }
+ if (PERLDB_SINGLE && PL_DBsingle)
+ sv_setiv(PL_DBsingle, 1);
+ if (PL_initav)
+ call_list(oldscope, PL_initav);
+ }
+
+ /* do it */
+
+ if (PL_restartop) {
+ PL_op = PL_restartop;
+ PL_restartop = 0;
+ CALLRUNOPS();
+ }
+ else if (PL_main_start) {
+ CvDEPTH(PL_main_cv) = 1;
+ PL_op = PL_main_start;
+ CALLRUNOPS();
+ }
+
+ my_exit(0);
+ /* NOTREACHED */
+ return 0;
+}
+
+SV*
+perl_get_sv(char *name, I32 create)
+{
+ GV *gv;
+#ifdef USE_THREADS
+ if (name[1] == '\0' && !isALPHA(name[0])) {
+ PADOFFSET tmp = find_threadsv(name);
+ if (tmp != NOT_IN_PAD) {
+ dTHR;
+ return THREADSV(tmp);
+ }
+ }
+#endif /* USE_THREADS */
+ gv = gv_fetchpv(name, create, SVt_PV);
+ if (gv)
+ return GvSV(gv);
+ return Nullsv;
+}
+
+AV*
+perl_get_av(char *name, I32 create)
+{
+ GV* gv = gv_fetchpv(name, create, SVt_PVAV);
+ if (create)
+ return GvAVn(gv);
+ if (gv)
+ return GvAV(gv);
+ return Nullav;
+}
+
+HV*
+perl_get_hv(char *name, I32 create)
+{
+ GV* gv = gv_fetchpv(name, create, SVt_PVHV);
+ if (create)
+ return GvHVn(gv);
+ if (gv)
+ return GvHV(gv);
+ return Nullhv;
+}
+
+CV*
+perl_get_cv(char *name, I32 create)
+{
+ GV* gv = gv_fetchpv(name, create, SVt_PVCV);
+ if (create && !GvCVu(gv))
+ return newSUB(start_subparse(FALSE, 0),
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ Nullop,
+ Nullop);
+ if (gv)
+ return GvCVu(gv);
+ return Nullcv;
+}
+
+/* Be sure to refetch the stack pointer after calling these routines. */
+
+I32
+perl_call_argv(char *sub_name, I32 flags, register char **argv)
+
+ /* See G_* flags in cop.h */
+ /* null terminated arg list */
+{
+ dSP;
+
+ PUSHMARK(SP);
+ if (argv) {
+ while (*argv) {
+ XPUSHs(sv_2mortal(newSVpv(*argv,0)));
+ argv++;
+ }
+ PUTBACK;
+ }
+ return perl_call_pv(sub_name, flags);
+}
+
+I32
+perl_call_pv(char *sub_name, I32 flags)
+ /* name of the subroutine */
+ /* See G_* flags in cop.h */
+{
+ return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
+}
+
+I32
+perl_call_method(char *methname, I32 flags)
+ /* name of the subroutine */
+ /* See G_* flags in cop.h */
+{
+ dSP;
+ OP myop;
+ if (!PL_op)
+ PL_op = &myop;
+ XPUSHs(sv_2mortal(newSVpv(methname,0)));
+ PUTBACK;
+ pp_method(ARGS);
+ if(PL_op == &myop)
+ PL_op = Nullop;
+ return perl_call_sv(*PL_stack_sp--, flags);
+}
+
+/* May be called with any of a CV, a GV, or an SV containing the name. */
+I32
+perl_call_sv(SV *sv, I32 flags)
+
+ /* See G_* flags in cop.h */
+{
+ dSP;
+ LOGOP myop; /* fake syntax tree node */
+ I32 oldmark;
+ I32 retval;
+ I32 oldscope;
+ bool oldcatch = CATCH_GET;
+ dJMPENV;
+ int ret;
+ OP* oldop = PL_op;
+
+ if (flags & G_DISCARD) {
+ ENTER;
+ SAVETMPS;
+ }
+
+ Zero(&myop, 1, LOGOP);
+ myop.op_next = Nullop;
+ if (!(flags & G_NOARGS))
+ myop.op_flags |= OPf_STACKED;
+ myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
+ (flags & G_ARRAY) ? OPf_WANT_LIST :
+ OPf_WANT_SCALAR);
+ SAVEOP();
+ PL_op = (OP*)&myop;
+
+ EXTEND(PL_stack_sp, 1);
+ *++PL_stack_sp = sv;
+ oldmark = TOPMARK;
+ oldscope = PL_scopestack_ix;
+
+ if (PERLDB_SUB && PL_curstash != PL_debstash
+ /* Handle first BEGIN of -d. */
+ && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
+ /* Try harder, since this may have been a sighandler, thus
+ * curstash may be meaningless. */
+ && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
+ && !(flags & G_NODEBUG))
+ PL_op->op_private |= OPpENTERSUB_DB;
+
+ if (flags & G_EVAL) {
+ cLOGOP->op_other = PL_op;
+ PL_markstack_ptr--;
+ /* we're trying to emulate pp_entertry() here */
+ {
+ register PERL_CONTEXT *cx;
+ I32 gimme = GIMME_V;
+
+ ENTER;
+ SAVETMPS;
+
+ push_return(PL_op->op_next);
+ PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
+ PUSHEVAL(cx, 0, 0);
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
+
+ PL_in_eval = 1;
+ if (flags & G_KEEPERR)
+ PL_in_eval |= 4;
+ else
+ sv_setpv(ERRSV,"");
+ }
+ PL_markstack_ptr++;
+
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
+ break;
+ case 1:
+ STATUS_ALL_FAILURE;
+ /* FALL THROUGH */
+ case 2:
+ /* my_exit() was called */
+ PL_curstash = PL_defstash;
+ FREETMPS;
+ JMPENV_POP;
+ if (PL_statusvalue)
+ croak("Callback called exit");
+ my_exit_jump();
+ /* NOTREACHED */
+ case 3:
+ if (PL_restartop) {
+ PL_op = PL_restartop;
+ PL_restartop = 0;
+ break;
+ }
+ PL_stack_sp = PL_stack_base + oldmark;
+ if (flags & G_ARRAY)
+ retval = 0;
+ else {
+ retval = 1;
+ *++PL_stack_sp = &PL_sv_undef;
+ }
+ goto cleanup;
+ }
+ }
+ else
+ CATCH_SET(TRUE);
+
+ if (PL_op == (OP*)&myop)
+ PL_op = pp_entersub(ARGS);
+ if (PL_op)
+ CALLRUNOPS();
+ retval = PL_stack_sp - (PL_stack_base + oldmark);
+ if ((flags & G_EVAL) && !(flags & G_KEEPERR))
+ sv_setpv(ERRSV,"");
+
+ cleanup:
+ if (flags & G_EVAL) {
+ if (PL_scopestack_ix > oldscope) {
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
+ register PERL_CONTEXT *cx;
+ I32 optype;
+
+ POPBLOCK(cx,newpm);
+ POPEVAL(cx);
+ pop_return();
+ PL_curpm = newpm;
+ LEAVE;
+ }
+ JMPENV_POP;
+ }
+ else
+ CATCH_SET(oldcatch);
+
+ if (flags & G_DISCARD) {
+ PL_stack_sp = PL_stack_base + oldmark;
+ retval = 0;
+ FREETMPS;
+ LEAVE;
+ }
+ PL_op = oldop;
+ return retval;
+}
+
+/* Eval a string. The G_EVAL flag is always assumed. */
+
+I32
+perl_eval_sv(SV *sv, I32 flags)
+
+ /* See G_* flags in cop.h */
+{
+ dSP;
+ UNOP myop; /* fake syntax tree node */
+ I32 oldmark = SP - PL_stack_base;
+ I32 retval;
+ I32 oldscope;
+ dJMPENV;
+ int ret;
+ OP* oldop = PL_op;
+
+ if (flags & G_DISCARD) {
+ ENTER;
+ SAVETMPS;
+ }
+
+ SAVEOP();
+ PL_op = (OP*)&myop;
+ Zero(PL_op, 1, UNOP);
+ EXTEND(PL_stack_sp, 1);
+ *++PL_stack_sp = sv;
+ oldscope = PL_scopestack_ix;
+
+ if (!(flags & G_NOARGS))
+ myop.op_flags = OPf_STACKED;
+ myop.op_next = Nullop;
+ myop.op_type = OP_ENTEREVAL;
+ myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
+ (flags & G_ARRAY) ? OPf_WANT_LIST :
+ OPf_WANT_SCALAR);
+ if (flags & G_KEEPERR)
+ myop.op_flags |= OPf_SPECIAL;
+
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
+ break;
+ case 1:
+ STATUS_ALL_FAILURE;
+ /* FALL THROUGH */
+ case 2:
+ /* my_exit() was called */
+ PL_curstash = PL_defstash;
+ FREETMPS;
+ JMPENV_POP;
+ if (PL_statusvalue)
+ croak("Callback called exit");
+ my_exit_jump();
+ /* NOTREACHED */
+ case 3:
+ if (PL_restartop) {
+ PL_op = PL_restartop;
+ PL_restartop = 0;
+ break;
+ }
+ PL_stack_sp = PL_stack_base + oldmark;
+ if (flags & G_ARRAY)
+ retval = 0;
+ else {
+ retval = 1;
+ *++PL_stack_sp = &PL_sv_undef;
+ }
+ goto cleanup;
+ }
+
+ if (PL_op == (OP*)&myop)
+ PL_op = pp_entereval(ARGS);
+ if (PL_op)
+ CALLRUNOPS();
+ retval = PL_stack_sp - (PL_stack_base + oldmark);
+ if (!(flags & G_KEEPERR))
+ sv_setpv(ERRSV,"");
+
+ cleanup:
+ JMPENV_POP;
+ if (flags & G_DISCARD) {
+ PL_stack_sp = PL_stack_base + oldmark;
+ retval = 0;
+ FREETMPS;
+ LEAVE;
+ }
+ PL_op = oldop;
+ return retval;
+}
+
+SV*
+perl_eval_pv(char *p, I32 croak_on_error)
+{
+ dSP;
+ SV* sv = newSVpv(p, 0);
+
+ PUSHMARK(SP);
+ perl_eval_sv(sv, G_SCALAR);
+ SvREFCNT_dec(sv);
+
+ SPAGAIN;
+ sv = POPs;
+ PUTBACK;
+
+ if (croak_on_error && SvTRUE(ERRSV))
+ croak(SvPVx(ERRSV, PL_na));
+
+ return sv;
+}
+
+/* Require a module. */
+
+void
+perl_require_pv(char *pv)
+{
+ SV* sv;
+ dSP;
+ PUSHSTACKi(PERLSI_REQUIRE);
+ PUTBACK;
+ sv = sv_newmortal();
+ sv_setpv(sv, "require '");
+ sv_catpv(sv, pv);
+ sv_catpv(sv, "'");
+ perl_eval_sv(sv, G_DISCARD);
+ SPAGAIN;
+ POPSTACK;
+}
+
+void
+magicname(char *sym, char *name, I32 namlen)
+{
+ register GV *gv;
+
+ if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
+ sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
+}
+
+STATIC void
+usage(char *name) /* XXX move this out into a module ? */
+
+{
+ /* This message really ought to be max 23 lines.
+ * Removed -h because the user already knows that opton. Others? */
+
+ static char *usage_msg[] = {
+"-0[octal] specify record separator (\\0, if no argument)",
+"-a autosplit mode with -n or -p (splits $_ into @F)",
+"-c check syntax only (runs BEGIN and END blocks)",
+"-d[:debugger] run scripts under debugger",
+"-D[number/list] set debugging flags (argument is a bit mask or flags)",
+"-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
+"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
+"-i[extension] edit <> files in place (make backup if extension supplied)",
+"-Idirectory specify @INC/#include directory (may be used more than once)",
+"-l[octal] enable line ending processing, specifies line terminator",
+"-[mM][-]module.. executes `use/no module...' before executing your script.",
+"-n assume 'while (<>) { ... }' loop around your script",
+"-p assume loop like -n but print line also like sed",
+"-P run script through C preprocessor before compilation",
+"-s enable some switch parsing for switches after script name",
+"-S look for the script using PATH environment variable",
+"-T turn on tainting checks",
+"-u dump core after parsing script",
+"-U allow unsafe operations",
+"-v print version number, patchlevel plus VERY IMPORTANT perl info",
+"-V[:variable] print perl configuration information",
+"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
+"-x[directory] strip off text before #!perl line and perhaps cd to directory",
+"\n",
+NULL
+};
+ char **p = usage_msg;
+
+ printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
+ while (*p)
+ printf("\n %s", *p++);
+}
+
+/* This routine handles any switches that can be given during run */
+
+char *
+moreswitches(char *s)
+{
+ I32 numlen;
+ U32 rschar;
+
+ switch (*s) {
+ case '0':
+ {
+ dTHR;
+ rschar = scan_oct(s, 4, &numlen);
+ SvREFCNT_dec(PL_nrs);
+ if (rschar & ~((U8)~0))
+ PL_nrs = &PL_sv_undef;
+ else if (!rschar && numlen >= 2)
+ PL_nrs = newSVpv("", 0);
+ else {
+ char ch = rschar;
+ PL_nrs = newSVpv(&ch, 1);
+ }
+ return s + numlen;
+ }
+ case 'F':
+ PL_minus_F = TRUE;
+ PL_splitstr = savepv(s + 1);
+ s += strlen(s);
+ return s;
+ case 'a':
+ PL_minus_a = TRUE;
+ s++;
+ return s;
+ case 'c':
+ PL_minus_c = TRUE;
+ s++;
+ return s;
+ case 'd':
+ forbid_setid("-d");
+ s++;
+ if (*s == ':' || *s == '=') {
+ my_setenv("PERL5DB", form("use Devel::%s;", ++s));
+ s += strlen(s);
+ }
+ if (!PL_perldb) {
+ PL_perldb = PERLDB_ALL;
+ init_debugger();
+ }
+ return s;
+ case 'D':
+#ifdef DEBUGGING
+ forbid_setid("-D");
+ if (isALPHA(s[1])) {
+ static char debopts[] = "psltocPmfrxuLHXDS";
+ char *d;
+
+ for (s++; *s && (d = strchr(debopts,*s)); s++)
+ PL_debug |= 1 << (d - debopts);
+ }
+ else {
+ PL_debug = atoi(s+1);
+ for (s++; isDIGIT(*s); s++) ;
+ }
+ PL_debug |= 0x80000000;
+#else
+ warn("Recompile perl with -DDEBUGGING to use -D switch\n");
+ for (s++; isALNUM(*s); s++) ;
+#endif
+ /*SUPPRESS 530*/
+ return s;
+ case 'h':
+ usage(PL_origargv[0]);
+ PerlProc_exit(0);
+ case 'i':
+ if (PL_inplace)
+ Safefree(PL_inplace);
+ PL_inplace = savepv(s+1);
+ /*SUPPRESS 530*/
+ for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
+ if (*s) {
+ *s++ = '\0';
+ if (*s == '-') /* Additional switches on #! line. */
+ s++;
+ }
+ return s;
+ case 'I': /* -I handled both here and in parse_perl() */
+ forbid_setid("-I");
+ ++s;
+ while (*s && isSPACE(*s))
+ ++s;
+ if (*s) {
+ char *e, *p;
+ for (e = s; *e && !isSPACE(*e); e++) ;
+ p = savepvn(s, e-s);
+ incpush(p, TRUE);
+ Safefree(p);
+ s = e;
+ }
+ else
+ croak("No space allowed after -I");
+ return s;
+ case 'l':
+ PL_minus_l = TRUE;
+ s++;
+ if (PL_ors)
+ Safefree(PL_ors);
+ if (isDIGIT(*s)) {
+ PL_ors = savepv("\n");
+ PL_orslen = 1;
+ *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
+ s += numlen;
+ }
+ else {
+ dTHR;
+ if (RsPARA(PL_nrs)) {
+ PL_ors = "\n\n";
+ PL_orslen = 2;
+ }
+ else
+ PL_ors = SvPV(PL_nrs, PL_orslen);
+ PL_ors = savepvn(PL_ors, PL_orslen);
+ }
+ return s;
+ case 'M':
+ forbid_setid("-M"); /* XXX ? */
+ /* FALL THROUGH */
+ case 'm':
+ forbid_setid("-m"); /* XXX ? */
+ if (*++s) {
+ char *start;
+ SV *sv;
+ char *use = "use ";
+ /* -M-foo == 'no foo' */
+ if (*s == '-') { use = "no "; ++s; }
+ sv = newSVpv(use,0);
+ start = s;
+ /* We allow -M'Module qw(Foo Bar)' */
+ while(isALNUM(*s) || *s==':') ++s;
+ if (*s != '=') {
+ sv_catpv(sv, start);
+ if (*(start-1) == 'm') {
+ if (*s != '\0')
+ croak("Can't use '%c' after -mname", *s);
+ sv_catpv( sv, " ()");
+ }
+ } else {
+ sv_catpvn(sv, start, s-start);
+ sv_catpv(sv, " split(/,/,q{");
+ sv_catpv(sv, ++s);
+ sv_catpv(sv, "})");
+ }
+ s += strlen(s);
+ if (PL_preambleav == NULL)
+ PL_preambleav = newAV();
+ av_push(PL_preambleav, sv);
+ }
+ else
+ croak("No space allowed after -%c", *(s-1));
+ return s;
+ case 'n':
+ PL_minus_n = TRUE;
+ s++;
+ return s;
+ case 'p':
+ PL_minus_p = TRUE;
+ s++;
+ return s;
+ case 's':
+ forbid_setid("-s");
+ PL_doswitches = TRUE;
+ s++;
+ return s;
+ case 'T':
+ if (!PL_tainting)
+ croak("Too late for \"-T\" option");
+ s++;
+ return s;
+ case 'u':
+ PL_do_undump = TRUE;
+ s++;
+ return s;
+ case 'U':
+ PL_unsafe = TRUE;
+ s++;
+ return s;
+ case 'v':
+#if defined(SUBVERSION) && SUBVERSION > 0
+ printf("\nThis is perl, version 5.%03d_%02d built for %s",
+ PATCHLEVEL, SUBVERSION, ARCHNAME);
+#else
+ printf("\nThis is perl, version %s built for %s",
+ PL_patchlevel, ARCHNAME);
+#endif
+#if defined(LOCAL_PATCH_COUNT)
+ if (LOCAL_PATCH_COUNT > 0)
+ printf("\n(with %d registered patch%s, see perl -V for more detail)",
+ LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
+#endif
+
+ printf("\n\nCopyright 1987-1998, Larry Wall\n");
+#ifdef MSDOS
+ printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
+#endif
+#ifdef DJGPP
+ printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
+ printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
+#endif
+#ifdef OS2
+ printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
+ "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
+#endif
+#ifdef atarist
+ printf("atariST series port, ++jrb bammi@cadence.com\n");
+#endif
+#ifdef __BEOS__
+ printf("BeOS port Copyright Tom Spindler, 1997-1998\n");
+#endif
+#ifdef MPE
+ printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n");
+#endif
+#ifdef OEMVS
+ printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n");
+#endif
+#ifdef BINARY_BUILD_NOTICE
+ BINARY_BUILD_NOTICE;
+#endif
+ printf("\n\
+Perl may be copied only under the terms of either the Artistic License or the\n\
+GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
+Complete documentation for Perl, including FAQ lists, should be found on\n\
+this system using `man perl' or `perldoc perl'. If you have access to the\n\
+Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
+ PerlProc_exit(0);
+ case 'w':
+ PL_dowarn = TRUE;
+ s++;
+ return s;
+ case '*':
+ case ' ':
+ if (s[1] == '-') /* Additional switches on #! line. */
+ return s+2;
+ break;
+ case '-':
+ case 0:
+#ifdef WIN32
+ case '\r':
+#endif
+ case '\n':
+ case '\t':
+ break;
+#ifdef ALTERNATE_SHEBANG
+ case 'S': /* OS/2 needs -S on "extproc" line. */
+ break;
+#endif
+ case 'P':
+ if (PL_preprocess)
+ return s+1;
+ /* FALL THROUGH */
+ default:
+ croak("Can't emulate -%.1s on #! line",s);
+ }
+ return Nullch;
+}
+
+/* compliments of Tom Christiansen */
+
+/* unexec() can be found in the Gnu emacs distribution */
+/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
+
+void
+my_unexec(void)
+{
+#ifdef UNEXEC
+ SV* prog;
+ SV* file;
+ int status = 1;
+ extern int etext;
+
+ prog = newSVpv(BIN_EXP, 0);
+ sv_catpv(prog, "/perl");
+ file = newSVpv(PL_origfilename, 0);
+ sv_catpv(file, ".perldump");
+
+ unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
+ /* unexec prints msg to stderr in case of failure */
+ PerlProc_exit(status);
+#else
+# ifdef VMS
+# include <lib$routines.h>
+ lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
+# else
+ ABORT(); /* for use with undump */
+# endif
+#endif
+}
+
+/* initialize curinterp */
+STATIC void
+init_interp(void)
+{
+
+#ifdef PERL_OBJECT /* XXX kludge */
+#define I_REINIT \
+ STMT_START { \
+ PL_chopset = " \n-"; \
+ PL_copline = NOLINE; \
+ PL_curcop = &PL_compiling;\
+ PL_curcopdb = NULL; \
+ PL_dbargs = 0; \
+ PL_dlmax = 128; \
+ PL_laststatval = -1; \
+ PL_laststype = OP_STAT; \
+ PL_maxscream = -1; \
+ PL_maxsysfd = MAXSYSFD; \
+ PL_statname = Nullsv; \
+ PL_tmps_floor = -1; \
+ PL_tmps_ix = -1; \
+ PL_op_mask = NULL; \
+ PL_dlmax = 128; \
+ PL_laststatval = -1; \
+ PL_laststype = OP_STAT; \
+ PL_mess_sv = Nullsv; \
+ PL_splitstr = " "; \
+ PL_generation = 100; \
+ PL_exitlist = NULL; \
+ PL_exitlistlen = 0; \
+ PL_regindent = 0; \
+ PL_in_clean_objs = FALSE; \
+ PL_in_clean_all = FALSE; \
+ PL_profiledata = NULL; \
+ PL_rsfp = Nullfp; \
+ PL_rsfp_filters = Nullav; \
+ } STMT_END
+ I_REINIT;
+#else
+# ifdef MULTIPLICITY
+# define PERLVAR(var,type)
+# define PERLVARI(var,type,init) PL_curinterp->var = init;
+# define PERLVARIC(var,type,init) PL_curinterp->var = init;
+# include "intrpvar.h"
+# ifndef USE_THREADS
+# include "thrdvar.h"
+# endif
+# undef PERLVAR
+# undef PERLVARI
+# undef PERLVARIC
+# else
+# define PERLVAR(var,type)
+# define PERLVARI(var,type,init) PL_##var = init;
+# define PERLVARIC(var,type,init) PL_##var = init;
+# include "intrpvar.h"
+# ifndef USE_THREADS
+# include "thrdvar.h"
+# endif
+# undef PERLVAR
+# undef PERLVARI
+# undef PERLVARIC
+# endif
+#endif
+
+}
+
+STATIC void
+init_main_stash(void)
+{
+ dTHR;
+ GV *gv;
+
+ /* Note that strtab is a rather special HV. Assumptions are made
+ about not iterating on it, and not adding tie magic to it.
+ It is properly deallocated in perl_destruct() */
+ PL_strtab = newHV();
+ HvSHAREKEYS_off(PL_strtab); /* mandatory */
+ hv_ksplit(PL_strtab, 512);
+
+ PL_curstash = PL_defstash = newHV();
+ PL_curstname = newSVpv("main",4);
+ gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
+ SvREFCNT_dec(GvHV(gv));
+ GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
+ SvREADONLY_on(gv);
+ HvNAME(PL_defstash) = savepv("main");
+ PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
+ GvMULTI_on(PL_incgv);
+ PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
+ GvMULTI_on(PL_hintgv);
+ PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
+ PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
+ GvMULTI_on(PL_errgv);
+ PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
+ GvMULTI_on(PL_replgv);
+ (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
+ sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
+ sv_setpvn(ERRSV, "", 0);
+ PL_curstash = PL_defstash;
+ PL_compiling.cop_stash = PL_defstash;
+ PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
+ PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
+ /* We must init $/ before switches are processed. */
+ sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
+}
+
+STATIC void
+open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
+{
+ dTHR;
+ register char *s;
+
+ *fdscript = -1;
+
+ if (PL_e_script) {
+ PL_origfilename = savepv("-e");
+ }
+ else {
+ /* if find_script() returns, it returns a malloc()-ed value */
+ PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
+
+ if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
+ char *s = scriptname + 8;
+ *fdscript = atoi(s);
+ while (isDIGIT(*s))
+ s++;
+ if (*s) {
+ scriptname = savepv(s + 1);
+ Safefree(PL_origfilename);
+ PL_origfilename = scriptname;
+ }
+ }
+ }
+
+ PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
+ if (strEQ(PL_origfilename,"-"))
+ scriptname = "";
+ if (*fdscript >= 0) {
+ PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ if (PL_rsfp)
+ fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
+#endif
+ }
+ else if (PL_preprocess) {
+ char *cpp_cfg = CPPSTDIN;
+ SV *cpp = newSVpv("",0);
+ SV *cmd = NEWSV(0,0);
+
+ if (strEQ(cpp_cfg, "cppstdin"))
+ sv_catpvf(cpp, "%s/", BIN_EXP);
+ sv_catpv(cpp, cpp_cfg);
+
+ sv_catpv(sv,"-I");
+ sv_catpv(sv,PRIVLIB_EXP);
+
+#ifdef MSDOS
+ sv_setpvf(cmd, "\
+sed %s -e \"/^[^#]/b\" \
+ -e \"/^#[ ]*include[ ]/b\" \
+ -e \"/^#[ ]*define[ ]/b\" \
+ -e \"/^#[ ]*if[ ]/b\" \
+ -e \"/^#[ ]*ifdef[ ]/b\" \
+ -e \"/^#[ ]*ifndef[ ]/b\" \
+ -e \"/^#[ ]*else/b\" \
+ -e \"/^#[ ]*elif[ ]/b\" \
+ -e \"/^#[ ]*undef[ ]/b\" \
+ -e \"/^#[ ]*endif/b\" \
+ -e \"s/^#.*//\" \
+ %s | %_ -C %_ %s",
+ (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
+#else
+ sv_setpvf(cmd, "\
+%s %s -e '/^[^#]/b' \
+ -e '/^#[ ]*include[ ]/b' \
+ -e '/^#[ ]*define[ ]/b' \
+ -e '/^#[ ]*if[ ]/b' \
+ -e '/^#[ ]*ifdef[ ]/b' \
+ -e '/^#[ ]*ifndef[ ]/b' \
+ -e '/^#[ ]*else/b' \
+ -e '/^#[ ]*elif[ ]/b' \
+ -e '/^#[ ]*undef[ ]/b' \
+ -e '/^#[ ]*endif/b' \
+ -e 's/^[ ]*#.*//' \
+ %s | %_ -C %_ %s",
+#ifdef LOC_SED
+ LOC_SED,
+#else
+ "sed",
+#endif
+ (PL_doextract ? "-e '1,/^#/d\n'" : ""),
+#endif
+ scriptname, cpp, sv, CPPMINUS);
+ PL_doextract = FALSE;
+#ifdef IAMSUID /* actually, this is caught earlier */
+ if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
+#ifdef HAS_SETEUID
+ (void)seteuid(PL_uid); /* musn't stay setuid root */
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid((Uid_t)-1, PL_uid);
+#else
+#ifdef HAS_SETRESUID
+ (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
+#else
+ PerlProc_setuid(PL_uid);
+#endif
+#endif
+#endif
+ if (PerlProc_geteuid() != PL_uid)
+ croak("Can't do seteuid!\n");
+ }
+#endif /* IAMSUID */
+ PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
+ SvREFCNT_dec(cmd);
+ SvREFCNT_dec(cpp);
+ }
+ else if (!*scriptname) {
+ forbid_setid("program input from stdin");
+ PL_rsfp = PerlIO_stdin();
+ }
+ else {
+ PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ if (PL_rsfp)
+ fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
+#endif
+ }
+ if (!PL_rsfp) {
+#ifdef DOSUID
+#ifndef IAMSUID /* in case script is not readable before setuid */
+ if (PL_euid &&
+ PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
+ PL_statbuf.st_mode & (S_ISUID|S_ISGID))
+ {
+ /* try again */
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
+ croak("Can't do setuid\n");
+ }
+#endif
+#endif
+ croak("Can't open perl script \"%s\": %s\n",
+ SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
+ }
+}
+
+STATIC void
+validate_suid(char *validarg, char *scriptname, int fdscript)
+{
+ int which;
+
+ /* do we need to emulate setuid on scripts? */
+
+ /* This code is for those BSD systems that have setuid #! scripts disabled
+ * in the kernel because of a security problem. Merely defining DOSUID
+ * in perl will not fix that problem, but if you have disabled setuid
+ * scripts in the kernel, this will attempt to emulate setuid and setgid
+ * on scripts that have those now-otherwise-useless bits set. The setuid
+ * root version must be called suidperl or sperlN.NNN. If regular perl
+ * discovers that it has opened a setuid script, it calls suidperl with
+ * the same argv that it had. If suidperl finds that the script it has
+ * just opened is NOT setuid root, it sets the effective uid back to the
+ * uid. We don't just make perl setuid root because that loses the
+ * effective uid we had before invoking perl, if it was different from the
+ * uid.
+ *
+ * DOSUID must be defined in both perl and suidperl, and IAMSUID must
+ * be defined in suidperl only. suidperl must be setuid root. The
+ * Configure script will set this up for you if you want it.
+ */
+
+#ifdef DOSUID
+ dTHR;
+ char *s, *s2;
+
+ if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
+ croak("Can't stat script \"%s\"",PL_origfilename);
+ if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
+ I32 len;
+
+#ifdef IAMSUID
+#ifndef HAS_SETREUID
+ /* On this access check to make sure the directories are readable,
+ * there is actually a small window that the user could use to make
+ * filename point to an accessible directory. So there is a faint
+ * chance that someone could execute a setuid script down in a
+ * non-accessible directory. I don't know what to do about that.
+ * But I don't think it's too important. The manual lies when
+ * it says access() is useful in setuid programs.
+ */
+ if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
+ croak("Permission denied");
+#else
+ /* If we can swap euid and uid, then we can determine access rights
+ * with a simple stat of the file, and then compare device and
+ * inode to make sure we did stat() on the same file we opened.
+ * Then we just have to make sure he or she can execute it.
+ */
+ {
+ struct stat tmpstatbuf;
+
+ if (
+#ifdef HAS_SETREUID
+ setreuid(PL_euid,PL_uid) < 0
+#else
+# if HAS_SETRESUID
+ setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
+# endif
+#endif
+ || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
+ croak("Can't swap uid and euid"); /* really paranoid */
+ if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
+ croak("Permission denied"); /* testing full pathname here */
+ if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
+ tmpstatbuf.st_ino != PL_statbuf.st_ino) {
+ (void)PerlIO_close(PL_rsfp);
+ if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
+ PerlIO_printf(PL_rsfp,
+"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
+(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
+ (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
+ (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
+ SvPVX(GvSV(PL_curcop->cop_filegv)),
+ (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
+ (void)PerlProc_pclose(PL_rsfp);
+ }
+ croak("Permission denied\n");
+ }
+ if (
+#ifdef HAS_SETREUID
+ setreuid(PL_uid,PL_euid) < 0
+#else
+# if defined(HAS_SETRESUID)
+ setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
+# endif
+#endif
+ || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
+ croak("Can't reswap uid and euid");
+ if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
+ croak("Permission denied\n");
+ }
+#endif /* HAS_SETREUID */
+#endif /* IAMSUID */
+
+ if (!S_ISREG(PL_statbuf.st_mode))
+ croak("Permission denied");
+ if (PL_statbuf.st_mode & S_IWOTH)
+ croak("Setuid/gid script is writable by world");
+ 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 */
+ croak("No #! line");
+ s = SvPV(PL_linestr,PL_na)+2;
+ if (*s == ' ') s++;
+ while (!isSPACE(*s)) s++;
+ for (s2 = s; (s2 > SvPV(PL_linestr,PL_na)+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");
+ while (*s == ' ' || *s == '\t') s++;
+ /*
+ * #! arg must be what we saw above. They can invoke it by
+ * mentioning suidperl explicitly, but they may not add any strange
+ * arguments beyond what #! says if they do invoke suidperl that way.
+ */
+ len = strlen(validarg);
+ if (strEQ(validarg," PHOOEY ") ||
+ strnNE(s,validarg,len) || !isSPACE(s[len]))
+ croak("Args must match #! line");
+
+#ifndef IAMSUID
+ if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
+ PL_euid == PL_statbuf.st_uid)
+ if (!PL_do_undump)
+ croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
+#endif /* IAMSUID */
+
+ if (PL_euid) { /* oops, we're not the setuid root perl */
+ (void)PerlIO_close(PL_rsfp);
+#ifndef IAMSUID
+ /* try again */
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
+#endif
+ croak("Can't do setuid\n");
+ }
+
+ if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
+#ifdef HAS_SETEGID
+ (void)setegid(PL_statbuf.st_gid);
+#else
+#ifdef HAS_SETREGID
+ (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
+#else
+#ifdef HAS_SETRESGID
+ (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
+#else
+ PerlProc_setgid(PL_statbuf.st_gid);
+#endif
+#endif
+#endif
+ if (PerlProc_getegid() != PL_statbuf.st_gid)
+ croak("Can't do setegid!\n");
+ }
+ if (PL_statbuf.st_mode & S_ISUID) {
+ if (PL_statbuf.st_uid != PL_euid)
+#ifdef HAS_SETEUID
+ (void)seteuid(PL_statbuf.st_uid); /* all that for this */
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
+#else
+#ifdef HAS_SETRESUID
+ (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
+#else
+ PerlProc_setuid(PL_statbuf.st_uid);
+#endif
+#endif
+#endif
+ if (PerlProc_geteuid() != PL_statbuf.st_uid)
+ croak("Can't do seteuid!\n");
+ }
+ else if (PL_uid) { /* oops, mustn't run as root */
+#ifdef HAS_SETEUID
+ (void)seteuid((Uid_t)PL_uid);
+#else
+#ifdef HAS_SETREUID
+ (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
+#else
+#ifdef HAS_SETRESUID
+ (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
+#else
+ PerlProc_setuid((Uid_t)PL_uid);
+#endif
+#endif
+#endif
+ if (PerlProc_geteuid() != PL_uid)
+ croak("Can't do seteuid!\n");
+ }
+ init_ids();
+ if (!cando(S_IXUSR,TRUE,&PL_statbuf))
+ croak("Permission denied\n"); /* they can't do this */
+ }
+#ifdef IAMSUID
+ else if (PL_preprocess)
+ croak("-P not allowed for setuid/setgid script\n");
+ else if (fdscript >= 0)
+ croak("fd script not allowed in suidperl\n");
+ else
+ croak("Script is not setuid/setgid in suidperl\n");
+
+ /* We absolutely must clear out any saved ids here, so we */
+ /* exec the real perl, substituting fd script for scriptname. */
+ /* (We pass script name as "subdir" of fd, which perl will grok.) */
+ PerlIO_rewind(PL_rsfp);
+ PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
+ if (!PL_origargv[which])
+ croak("Permission denied");
+ PL_origargv[which] = savepv(form("/dev/fd/%d/%s",
+ PerlIO_fileno(PL_rsfp), PL_origargv[which]));
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
+#endif
+ PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
+ croak("Can't do setuid\n");
+#endif /* IAMSUID */
+#else /* !DOSUID */
+ if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
+#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+ dTHR;
+ PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
+ if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+ ||
+ (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+ )
+ if (!PL_do_undump)
+ croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
+#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
+ /* not set-id, must be wrapped */
+ }
+#endif /* DOSUID */
+}
+
+STATIC void
+find_beginning(void)
+{
+ register char *s, *s2;
+
+ /* skip forward in input to the real script? */
+
+ forbid_setid("-x");
+ while (PL_doextract) {
+ if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
+ croak("No Perl script found in input\n");
+ if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
+ PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
+ PL_doextract = FALSE;
+ while (*s && !(isSPACE (*s) || *s == '#')) s++;
+ s2 = s;
+ while (*s == ' ' || *s == '\t') s++;
+ if (*s++ == '-') {
+ while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
+ if (strnEQ(s2-4,"perl",4))
+ /*SUPPRESS 530*/
+ while (s = moreswitches(s)) ;
+ }
+ if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
+ croak("Can't chdir to %s",PL_cddir);
+ }
+ }
+}
+
+
+STATIC void
+init_ids(void)
+{
+ PL_uid = (int)PerlProc_getuid();
+ PL_euid = (int)PerlProc_geteuid();
+ PL_gid = (int)PerlProc_getgid();
+ PL_egid = (int)PerlProc_getegid();
+#ifdef VMS
+ PL_uid |= PL_gid << 16;
+ PL_euid |= PL_egid << 16;
+#endif
+ PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
+}
+
+STATIC void
+forbid_setid(char *s)
+{
+ if (PL_euid != PL_uid)
+ croak("No %s allowed while running setuid", s);
+ if (PL_egid != PL_gid)
+ croak("No %s allowed while running setgid", s);
+}
+
+STATIC void
+init_debugger(void)
+{
+ dTHR;
+ PL_curstash = PL_debstash;
+ PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
+ AvREAL_off(PL_dbargs);
+ PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
+ PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
+ PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
+ PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
+ sv_setiv(PL_DBsingle, 0);
+ PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
+ sv_setiv(PL_DBtrace, 0);
+ PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
+ sv_setiv(PL_DBsignal, 0);
+ PL_curstash = PL_defstash;
+}
+
+#ifndef STRESS_REALLOC
+#define REASONABLE(size) (size)
+#else
+#define REASONABLE(size) (1) /* unreasonable */
+#endif
+
+void
+init_stacks(ARGSproto)
+{
+ /* start with 128-item stack and 8K cxstack */
+ PL_curstackinfo = new_stackinfo(REASONABLE(128),
+ REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
+ PL_curstackinfo->si_type = PERLSI_MAIN;
+ PL_curstack = PL_curstackinfo->si_stack;
+ PL_mainstack = PL_curstack; /* remember in case we switch stacks */
+
+ PL_stack_base = AvARRAY(PL_curstack);
+ PL_stack_sp = PL_stack_base;
+ PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
+
+ New(50,PL_tmps_stack,REASONABLE(128),SV*);
+ PL_tmps_floor = -1;
+ PL_tmps_ix = -1;
+ PL_tmps_max = REASONABLE(128);
+
+ New(54,PL_markstack,REASONABLE(32),I32);
+ PL_markstack_ptr = PL_markstack;
+ PL_markstack_max = PL_markstack + REASONABLE(32);
+
+ SET_MARKBASE;
+
+ New(54,PL_scopestack,REASONABLE(32),I32);
+ PL_scopestack_ix = 0;
+ PL_scopestack_max = REASONABLE(32);
+
+ New(54,PL_savestack,REASONABLE(128),ANY);
+ PL_savestack_ix = 0;
+ PL_savestack_max = REASONABLE(128);
+
+ New(54,PL_retstack,REASONABLE(16),OP*);
+ PL_retstack_ix = 0;
+ PL_retstack_max = REASONABLE(16);
+}
+
+#undef REASONABLE
+
+STATIC void
+nuke_stacks(void)
+{
+ dTHR;
+ while (PL_curstackinfo->si_next)
+ PL_curstackinfo = PL_curstackinfo->si_next;
+ while (PL_curstackinfo) {
+ PERL_SI *p = PL_curstackinfo->si_prev;
+ /* curstackinfo->si_stack got nuked by sv_free_arenas() */
+ Safefree(PL_curstackinfo->si_cxstack);
+ Safefree(PL_curstackinfo);
+ PL_curstackinfo = p;
+ }
+ Safefree(PL_tmps_stack);
+ Safefree(PL_markstack);
+ Safefree(PL_scopestack);
+ Safefree(PL_savestack);
+ Safefree(PL_retstack);
+ DEBUG( {
+ Safefree(PL_debname);
+ Safefree(PL_debdelim);
+ } )
+}
+
+#ifndef PERL_OBJECT
+static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
+#endif
+
+STATIC void
+init_lexer(void)
+{
+#ifdef PERL_OBJECT
+ PerlIO *tmpfp;
+#endif
+ tmpfp = PL_rsfp;
+ PL_rsfp = Nullfp;
+ lex_start(PL_linestr);
+ PL_rsfp = tmpfp;
+ PL_subname = newSVpv("main",4);
+}
+
+STATIC void
+init_predump_symbols(void)
+{
+ dTHR;
+ GV *tmpgv;
+ GV *othergv;
+
+ sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
+ PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
+ GvMULTI_on(PL_stdingv);
+ IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
+ tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
+ GvMULTI_on(tmpgv);
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
+
+ tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
+ GvMULTI_on(tmpgv);
+ IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
+ setdefout(tmpgv);
+ tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
+ GvMULTI_on(tmpgv);
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
+
+ othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
+ GvMULTI_on(othergv);
+ IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
+ tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
+ GvMULTI_on(tmpgv);
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
+
+ PL_statname = NEWSV(66,0); /* last filename we did stat on */
+
+ if (!PL_osname)
+ PL_osname = savepv(OSNAME);
+}
+
+STATIC void
+init_postdump_symbols(register int argc, register char **argv, register char **env)
+{
+ dTHR;
+ char *s;
+ SV *sv;
+ GV* tmpgv;
+
+ argc--,argv++; /* skip name of script */
+ if (PL_doswitches) {
+ for (; argc > 0 && **argv == '-'; argc--,argv++) {
+ if (!argv[0][1])
+ break;
+ if (argv[0][1] == '-') {
+ argc--,argv++;
+ break;
+ }
+ if (s = strchr(argv[0], '=')) {
+ *s++ = '\0';
+ sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
+ }
+ else
+ sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
+ }
+ }
+ PL_toptarget = NEWSV(0,0);
+ sv_upgrade(PL_toptarget, SVt_PVFM);
+ sv_setpvn(PL_toptarget, "", 0);
+ PL_bodytarget = NEWSV(0,0);
+ sv_upgrade(PL_bodytarget, SVt_PVFM);
+ sv_setpvn(PL_bodytarget, "", 0);
+ PL_formtarget = PL_bodytarget;
+
+ TAINT;
+ if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
+ sv_setpv(GvSV(tmpgv),PL_origfilename);
+ magicname("0", "0", 1);
+ }
+ if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
+ sv_setpv(GvSV(tmpgv),PL_origargv[0]);
+ if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
+ GvMULTI_on(PL_argvgv);
+ (void)gv_AVadd(PL_argvgv);
+ av_clear(GvAVn(PL_argvgv));
+ for (; argc > 0; argc--,argv++) {
+ av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
+ }
+ }
+ if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
+ HV *hv;
+ GvMULTI_on(PL_envgv);
+ hv = GvHVn(PL_envgv);
+ hv_magic(hv, PL_envgv, 'E');
+#ifndef VMS /* VMS doesn't have environ array */
+ /* Note that if the supplied env parameter is actually a copy
+ of the global environ then it may now point to free'd memory
+ if the environment has been modified since. To avoid this
+ problem we treat env==NULL as meaning 'use the default'
+ */
+ if (!env)
+ env = environ;
+ if (env != environ)
+ environ[0] = Nullch;
+ for (; *env; env++) {
+ if (!(s = strchr(*env,'=')))
+ continue;
+ *s++ = '\0';
+#if defined(MSDOS)
+ (void)strupr(*env);
+#endif
+ sv = newSVpv(s--,0);
+ (void)hv_store(hv, *env, s - *env, sv, 0);
+ *s = '=';
+#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
+ /* Sins of the RTL. See note in my_setenv(). */
+ (void)PerlEnv_putenv(savepv(*env));
+#endif
+ }
+#endif
+#ifdef DYNAMIC_ENV_FETCH
+ HvNAME(hv) = savepv(ENV_HV_NAME);
+#endif
+ }
+ TAINT_NOT;
+ if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
+}
+
+STATIC void
+init_perllib(void)
+{
+ char *s;
+ if (!PL_tainting) {
+#ifndef VMS
+ s = PerlEnv_getenv("PERL5LIB");
+ if (s)
+ incpush(s, TRUE);
+ else
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE);
+#else /* VMS */
+ /* Treat PERL5?LIB as a possible search list logical name -- the
+ * "natural" VMS idiom for a Unix path string. We allow each
+ * element to be a set of |-separated directories for compatibility.
+ */
+ char buf[256];
+ int idx = 0;
+ if (my_trnlnm("PERL5LIB",buf,0))
+ do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ else
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
+#endif /* VMS */
+ }
+
+/* Use the ~-expanded versions of APPLLIB (undocumented),
+ ARCHLIB PRIVLIB SITEARCH and SITELIB
+*/
+#ifdef APPLLIB_EXP
+ incpush(APPLLIB_EXP, TRUE);
+#endif
+
+#ifdef ARCHLIB_EXP
+ incpush(ARCHLIB_EXP, FALSE);
+#endif
+#ifndef PRIVLIB_EXP
+#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
+#endif
+#if defined(WIN32)
+ incpush(PRIVLIB_EXP, TRUE);
+#else
+ incpush(PRIVLIB_EXP, FALSE);
+#endif
+
+#ifdef SITEARCH_EXP
+ incpush(SITEARCH_EXP, FALSE);
+#endif
+#ifdef SITELIB_EXP
+#if defined(WIN32)
+ incpush(SITELIB_EXP, TRUE);
+#else
+ incpush(SITELIB_EXP, FALSE);
+#endif
+#endif
+ if (!PL_tainting)
+ incpush(".", FALSE);
+}
+
+#if defined(DOSISH)
+# define PERLLIB_SEP ';'
+#else
+# if defined(VMS)
+# define PERLLIB_SEP '|'
+# else
+# define PERLLIB_SEP ':'
+# endif
+#endif
+#ifndef PERLLIB_MANGLE
+# define PERLLIB_MANGLE(s,n) (s)
+#endif
+
+STATIC void
+incpush(char *p, int addsubdirs)
+{
+ SV *subdir = Nullsv;
+
+ if (!p)
+ return;
+
+ if (addsubdirs) {
+ subdir = sv_newmortal();
+ if (!PL_archpat_auto) {
+ STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
+ + sizeof("//auto"));
+ New(55, PL_archpat_auto, len, char);
+ sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
+#ifdef VMS
+ for (len = sizeof(ARCHNAME) + 2;
+ PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
+ if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
+#endif
+ }
+ }
+
+ /* Break at all separators */
+ while (p && *p) {
+ SV *libdir = NEWSV(55,0);
+ char *s;
+
+ /* skip any consecutive separators */
+ while ( *p == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* av_push(GvAVn(PL_incgv), newSVpv(".", 1)); */
+ p++;
+ }
+
+ if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
+ sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
+ (STRLEN)(s - p));
+ p = s + 1;
+ }
+ else {
+ sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
+ p = Nullch; /* break out */
+ }
+
+ /*
+ * BEFORE pushing libdir onto @INC we may first push version- and
+ * archname-specific sub-directories.
+ */
+ if (addsubdirs) {
+ struct stat tmpstatbuf;
+#ifdef VMS
+ char *unix;
+ STRLEN len;
+
+ if ((unix = tounixspec_ts(SvPV(libdir,PL_na),Nullch)) != Nullch) {
+ len = strlen(unix);
+ while (unix[len-1] == '/') len--; /* Cosmetic */
+ sv_usepvn(libdir,unix,len);
+ }
+ else
+ PerlIO_printf(PerlIO_stderr(),
+ "Failed to unixify @INC element \"%s\"\n",
+ SvPV(libdir,PL_na));
+#endif
+ /* .../archname/version if -d .../archname/version/auto */
+ sv_setsv(subdir, libdir);
+ sv_catpv(subdir, PL_archpat_auto);
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(PL_incgv),
+ newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+
+ /* .../archname if -d .../archname/auto */
+ sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
+ strlen(PL_patchlevel) + 1, "", 0);
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(PL_incgv),
+ newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ }
+
+ /* finally push this lib directory on the end of @INC */
+ av_push(GvAVn(PL_incgv), libdir);
+ }
+}
+
+#ifdef USE_THREADS
+STATIC struct perl_thread *
+init_main_thread()
+{
+ struct perl_thread *thr;
+ XPV *xpv;
+
+ Newz(53, thr, 1, struct perl_thread);
+ PL_curcop = &PL_compiling;
+ thr->cvcache = newHV();
+ thr->threadsv = newAV();
+ /* thr->threadsvp is set when find_threadsv is called */
+ thr->specific = newAV();
+ thr->errhv = newHV();
+ thr->flags = THRf_R_JOINABLE;
+ MUTEX_INIT(&thr->mutex);
+ /* Handcraft thrsv similarly to mess_sv */
+ New(53, PL_thrsv, 1, SV);
+ Newz(53, xpv, 1, XPV);
+ SvFLAGS(PL_thrsv) = SVt_PV;
+ SvANY(PL_thrsv) = (void*)xpv;
+ SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
+ SvPVX(PL_thrsv) = (char*)thr;
+ SvCUR_set(PL_thrsv, sizeof(thr));
+ SvLEN_set(PL_thrsv, sizeof(thr));
+ *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
+ thr->oursv = PL_thrsv;
+ PL_chopset = " \n-";
+
+ MUTEX_LOCK(&PL_threads_mutex);
+ PL_nthreads++;
+ thr->tid = 0;
+ thr->next = thr;
+ thr->prev = thr;
+ MUTEX_UNLOCK(&PL_threads_mutex);
+
+#ifdef HAVE_THREAD_INTERN
+ init_thread_intern(thr);
+#endif
+
+#ifdef SET_THREAD_SELF
+ SET_THREAD_SELF(thr);
+#else
+ thr->self = pthread_self();
+#endif /* SET_THREAD_SELF */
+ SET_THR(thr);
+
+ /*
+ * These must come after the SET_THR because sv_setpvn does
+ * SvTAINT and the taint fields require dTHR.
+ */
+ PL_toptarget = NEWSV(0,0);
+ sv_upgrade(PL_toptarget, SVt_PVFM);
+ sv_setpvn(PL_toptarget, "", 0);
+ PL_bodytarget = NEWSV(0,0);
+ sv_upgrade(PL_bodytarget, SVt_PVFM);
+ sv_setpvn(PL_bodytarget, "", 0);
+ PL_formtarget = PL_bodytarget;
+ thr->errsv = newSVpv("", 0);
+ (void) find_threadsv("@"); /* Ensure $@ is initialised early */
+
+ 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;
+
+ return thr;
+}
+#endif /* USE_THREADS */
+
+void
+call_list(I32 oldscope, AV *paramList)
+{
+ dTHR;
+ line_t oldline = PL_curcop->cop_line;
+ STRLEN len;
+ dJMPENV;
+ int ret;
+
+ while (AvFILL(paramList) >= 0) {
+ CV *cv = (CV*)av_shift(paramList);
+
+ SAVEFREESV(cv);
+
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0: {
+ SV* atsv = ERRSV;
+ PUSHMARK(PL_stack_sp);
+ perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
+ (void)SvPV(atsv, len);
+ if (len) {
+ JMPENV_POP;
+ PL_curcop = &PL_compiling;
+ PL_curcop->cop_line = oldline;
+ if (paramList == PL_beginav)
+ sv_catpv(atsv, "BEGIN failed--compilation aborted");
+ else
+ sv_catpv(atsv, "END failed--cleanup aborted");
+ while (PL_scopestack_ix > oldscope)
+ LEAVE;
+ croak("%s", SvPVX(atsv));
+ }
+ }
+ break;
+ case 1:
+ STATUS_ALL_FAILURE;
+ /* FALL THROUGH */
+ case 2:
+ /* my_exit() was called */
+ while (PL_scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
+ PL_curstash = PL_defstash;
+ if (PL_endav)
+ call_list(oldscope, PL_endav);
+ JMPENV_POP;
+ PL_curcop = &PL_compiling;
+ PL_curcop->cop_line = oldline;
+ if (PL_statusvalue) {
+ if (paramList == PL_beginav)
+ croak("BEGIN failed--compilation aborted");
+ else
+ croak("END failed--cleanup aborted");
+ }
+ my_exit_jump();
+ /* NOTREACHED */
+ case 3:
+ if (!PL_restartop) {
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ FREETMPS;
+ break;
+ }
+ JMPENV_POP;
+ PL_curcop = &PL_compiling;
+ PL_curcop->cop_line = oldline;
+ JMPENV_JUMP(3);
+ }
+ JMPENV_POP;
+ }
+}
+
+void
+my_exit(U32 status)
+{
+ dTHR;
+
+ DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
+ thr, (unsigned long) status));
+ switch (status) {
+ case 0:
+ STATUS_ALL_SUCCESS;
+ break;
+ case 1:
+ STATUS_ALL_FAILURE;
+ break;
+ default:
+ STATUS_NATIVE_SET(status);
+ break;
+ }
+ my_exit_jump();
+}
+
+void
+my_failure_exit(void)
+{
+#ifdef VMS
+ if (vaxc$errno & 1) {
+ if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
+ STATUS_NATIVE_SET(44);
+ }
+ else {
+ if (!vaxc$errno && errno) /* unlikely */
+ STATUS_NATIVE_SET(44);
+ else
+ STATUS_NATIVE_SET(vaxc$errno);
+ }
+#else
+ int exitstatus;
+ if (errno & 255)
+ STATUS_POSIX_SET(errno);
+ else {
+ exitstatus = STATUS_POSIX >> 8;
+ if (exitstatus & 255)
+ STATUS_POSIX_SET(exitstatus);
+ else
+ STATUS_POSIX_SET(255);
+ }
+#endif
+ my_exit_jump();
+}
+
+STATIC void
+my_exit_jump(void)
+{
+ dSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+
+ if (PL_e_script) {
+ SvREFCNT_dec(PL_e_script);
+ PL_e_script = Nullsv;
+ }
+
+ POPSTACK_TO(PL_mainstack);
+ if (cxstack_ix >= 0) {
+ if (cxstack_ix > 0)
+ dounwind(0);
+ POPBLOCK(cx,PL_curpm);
+ LEAVE;
+ }
+
+ JMPENV_JUMP(2);
+}
+
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#endif /* PERL_OBJECT */
+
+#include "XSUB.h"
+
+static I32
+#ifdef PERL_OBJECT
+read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
+#else
+read_e_script(int idx, SV *buf_sv, int maxlen)
+#endif
+{
+ char *p, *nl;
+ p = SvPVX(PL_e_script);
+ nl = strchr(p, '\n');
+ nl = (nl) ? nl+1 : SvEND(PL_e_script);
+ if (nl-p == 0) {
+ filter_del(read_e_script);
+ return 0;
+ }
+ sv_catpvn(buf_sv, p, nl-p);
+ sv_chop(PL_e_script, nl);
+ return 1;
+}
+
+
diff --git a/contrib/perl5/perl.h b/contrib/perl5/perl.h
new file mode 100644
index 000000000000..6a063b8c0f49
--- /dev/null
+++ b/contrib/perl5/perl.h
@@ -0,0 +1,2452 @@
+/* perl.h
+ *
+ * Copyright (c) 1987-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+#ifndef H_PERL
+#define H_PERL 1
+#define OVERLOAD
+
+#ifdef PERL_FOR_X2P
+/*
+ * This file is being used for x2p stuff.
+ * Above symbol is defined via -D in 'x2p/Makefile.SH'
+ * Decouple x2p stuff from some of perls more extreme eccentricities.
+ */
+#undef EMBED
+#undef NO_EMBED
+#define NO_EMBED
+#undef MULTIPLICITY
+#undef USE_STDIO
+#define USE_STDIO
+#endif /* PERL_FOR_X2P */
+
+#ifdef PERL_OBJECT
+
+/* PERL_OBJECT explained - DickH and DougL @ ActiveState.com
+
+Defining PERL_OBJECT turns on creation of a C++ object that
+contains all writable core perl global variables and functions.
+Stated another way, all necessary global variables and functions
+are members of a big C++ object. This object's class is CPerlObj.
+This allows a Perl Host to have multiple, independent perl
+interpreters in the same process space. This is very important on
+Win32 systems as the overhead of process creation is quite high --
+this could be even higher than the script compile and execute time
+for small scripts.
+
+The perl executable implementation on Win32 is composed of perl.exe
+(the Perl Host) and perlX.dll. (the Perl Core). This allows the
+same Perl Core to easily be embedded in other applications that use
+the perl interpreter.
+
++-----------+
+| Perl Host |
++-----------+
+ ^
+ |
+ v
++-----------+ +-----------+
+| Perl Core |<->| Extension |
++-----------+ +-----------+ ...
+
+Defining PERL_OBJECT has the following effects:
+
+PERL CORE
+1. CPerlObj is defined (this is the PERL_OBJECT)
+2. all static functions that needed to access either global
+variables or functions needed are made member functions
+3. all writable static variables are made member variables
+4. all global variables and functions are defined as:
+ #define var CPerlObj::Perl_var
+ #define func CPerlObj::Perl_func
+ * these are in objpp.h
+This necessitated renaming some local variables and functions that
+had the same name as a global variable or function. This was
+probably a _good_ thing anyway.
+
+
+EXTENSIONS
+1. Access to global variables and perl functions is through a
+pointer to the PERL_OBJECT. This pointer type is CPerlObj*. This is
+made transparent to extension developers by the following macros:
+ #define var pPerl->Perl_var
+ #define func pPerl->Perl_func
+ * these are done in objXSUB.h
+This requires that the extension be compiled as C++, which means
+that the code must be ANSI C and not K&R C. For K&R extensions,
+please see the C API notes located in Win32/GenCAPI.pl. This script
+creates a perlCAPI.lib that provides a K & R compatible C interface
+to the PERL_OBJECT.
+2. Local variables and functions cannot have the same name as perl's
+variables or functions since the macros will redefine these. Look for
+this if you get some strange error message and it does not look like
+the code that you had written. This often happens with variables that
+are local to a function.
+
+PERL HOST
+1. The perl host is linked with perlX.lib to get perl_alloc. This
+function will return a pointer to CPerlObj (the PERL_OBJECT). It
+takes pointers to the various PerlXXX_YYY interfaces (see iperlsys.h
+for more information on this).
+2. The perl host calls the same functions as normally would be
+called in setting up and running a perl script, except that the
+functions are now member functions of the PERL_OBJECT.
+
+*/
+
+
+class CPerlObj;
+
+#define STATIC
+#define CPERLscope(x) CPerlObj::x
+#define CPERLproto CPerlObj *
+#define _CPERLproto ,CPERLproto
+#define CPERLarg CPerlObj *pPerl
+#define CPERLarg_ CPERLarg,
+#define _CPERLarg ,CPERLarg
+#define PERL_OBJECT_THIS this
+#define _PERL_OBJECT_THIS ,this
+#define PERL_OBJECT_THIS_ this,
+#define CALLRUNOPS (this->*PL_runops)
+#define CALLREGCOMP (this->*PL_regcompp)
+#define CALLREGEXEC (this->*PL_regexecp)
+
+#else /* !PERL_OBJECT */
+
+#define STATIC static
+#define CPERLscope(x) x
+#define CPERLproto
+#define _CPERLproto
+#define CPERLarg void
+#define CPERLarg_
+#define _CPERLarg
+#define PERL_OBJECT_THIS
+#define _PERL_OBJECT_THIS
+#define PERL_OBJECT_THIS_
+#define CALLRUNOPS PL_runops
+#define CALLREGCOMP (*PL_regcompp)
+#define CALLREGEXEC (*PL_regexecp)
+
+#endif /* PERL_OBJECT */
+
+#define VOIDUSED 1
+#include "config.h"
+
+#include "embed.h"
+
+#undef START_EXTERN_C
+#undef END_EXTERN_C
+#undef EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C
+#endif
+
+#ifdef OP_IN_REGISTER
+# ifdef __GNUC__
+# define stringify_immed(s) #s
+# define stringify(s) stringify_immed(s)
+#ifdef EMBED
+register struct op *Perl_op asm(stringify(OP_IN_REGISTER));
+#else
+register struct op *op asm(stringify(OP_IN_REGISTER));
+#endif
+# endif
+#endif
+
+/*
+ * STMT_START { statements; } STMT_END;
+ * can be used as a single statement, as in
+ * if (x) STMT_START { ... } STMT_END; else ...
+ *
+ * Trying to select a version that gives no warnings...
+ */
+#if !(defined(STMT_START) && defined(STMT_END))
+# if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(__cplusplus)
+# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
+# define STMT_END )
+# else
+ /* Now which other defined()s do we need here ??? */
+# if (VOIDFLAGS) && (defined(sun) || defined(__sun__))
+# define STMT_START if (1)
+# define STMT_END else (void)0
+# else
+# define STMT_START do
+# define STMT_END while (0)
+# endif
+# endif
+#endif
+
+#define NOOP (void)0
+
+#define WITH_THR(s) STMT_START { dTHR; s; } STMT_END
+
+/*
+ * SOFT_CAST can be used for args to prototyped functions to retain some
+ * type checking; it only casts if the compiler does not know prototypes.
+ */
+#if defined(CAN_PROTOTYPE) && defined(DEBUGGING_COMPILE)
+#define SOFT_CAST(type)
+#else
+#define SOFT_CAST(type) (type)
+#endif
+
+#ifndef BYTEORDER /* Should never happen -- byteorder is in config.h */
+# define BYTEORDER 0x1234
+#endif
+
+/* Overall memory policy? */
+#ifndef CONSERVATIVE
+# define LIBERAL 1
+#endif
+
+/*
+ * The following contortions are brought to you on behalf of all the
+ * standards, semi-standards, de facto standards, not-so-de-facto standards
+ * of the world, as well as all the other botches anyone ever thought of.
+ * The basic theory is that if we work hard enough here, the rest of the
+ * code can be a lot prettier. Well, so much for theory. Sorry, Henry...
+ */
+
+/* define this once if either system, instead of cluttering up the src */
+#if defined(MSDOS) || defined(atarist) || defined(WIN32)
+#define DOSISH 1
+#endif
+
+#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus)
+# define STANDARD_C 1
+#endif
+
+#if defined(__cplusplus) || defined(WIN32) || defined(__sgi) || defined(OS2) || defined(__DGUX)
+# define DONT_DECLARE_STD 1
+#endif
+
+#if defined(HASVOLATILE) || defined(STANDARD_C)
+# ifdef __cplusplus
+# define VOL // to temporarily suppress warnings
+# else
+# define VOL volatile
+# endif
+#else
+# define VOL
+#endif
+
+#define TAINT (PL_tainted = TRUE)
+#define TAINT_NOT (PL_tainted = FALSE)
+#define TAINT_IF(c) if (c) { PL_tainted = TRUE; }
+#define TAINT_ENV() if (PL_tainting) { taint_env(); }
+#define TAINT_PROPER(s) if (PL_tainting) { taint_proper(no_security, s); }
+
+/* XXX All process group stuff is handled in pp_sys.c. Should these
+ defines move there? If so, I could simplify this a lot. --AD 9/96.
+*/
+/* Process group stuff changed from traditional BSD to POSIX.
+ perlfunc.pod documents the traditional BSD-style syntax, so we'll
+ try to preserve that, if possible.
+*/
+#ifdef HAS_SETPGID
+# define BSD_SETPGRP(pid, pgrp) setpgid((pid), (pgrp))
+#else
+# if defined(HAS_SETPGRP) && defined(USE_BSD_SETPGRP)
+# define BSD_SETPGRP(pid, pgrp) setpgrp((pid), (pgrp))
+# else
+# ifdef HAS_SETPGRP2 /* DG/UX */
+# define BSD_SETPGRP(pid, pgrp) setpgrp2((pid), (pgrp))
+# endif
+# endif
+#endif
+#if defined(BSD_SETPGRP) && !defined(HAS_SETPGRP)
+# define HAS_SETPGRP /* Well, effectively it does . . . */
+#endif
+
+/* getpgid isn't POSIX, but at least Solaris and Linux have it, and it makes
+ our life easier :-) so we'll try it.
+*/
+#ifdef HAS_GETPGID
+# define BSD_GETPGRP(pid) getpgid((pid))
+#else
+# if defined(HAS_GETPGRP) && defined(USE_BSD_GETPGRP)
+# define BSD_GETPGRP(pid) getpgrp((pid))
+# else
+# ifdef HAS_GETPGRP2 /* DG/UX */
+# define BSD_GETPGRP(pid) getpgrp2((pid))
+# endif
+# endif
+#endif
+#if defined(BSD_GETPGRP) && !defined(HAS_GETPGRP)
+# define HAS_GETPGRP /* Well, effectively it does . . . */
+#endif
+
+/* These are not exact synonyms, since setpgrp() and getpgrp() may
+ have different behaviors, but perl.h used to define USE_BSDPGRP
+ (prior to 5.003_05) so some extension might depend on it.
+*/
+#if defined(USE_BSD_SETPGRP) || defined(USE_BSD_GETPGRP)
+# ifndef USE_BSDPGRP
+# define USE_BSDPGRP
+# endif
+#endif
+
+#ifndef _TYPES_ /* If types.h defines this it's easy. */
+# ifndef major /* Does everyone's types.h define this? */
+# include <sys/types.h>
+# endif
+#endif
+
+#ifdef __cplusplus
+# ifndef I_STDARG
+# define I_STDARG 1
+# endif
+#endif
+
+#ifdef I_STDARG
+# include <stdarg.h>
+#else
+# ifdef I_VARARGS
+# include <varargs.h>
+# endif
+#endif
+
+#include "iperlsys.h"
+
+#ifdef USE_NEXT_CTYPE
+
+#if NX_CURRENT_COMPILER_RELEASE >= 400
+#include <objc/NXCType.h>
+#else /* NX_CURRENT_COMPILER_RELEASE < 400 */
+#include <appkit/NXCType.h>
+#endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */
+
+#else /* !USE_NEXT_CTYPE */
+#include <ctype.h>
+#endif /* USE_NEXT_CTYPE */
+
+#ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */
+#undef METHOD
+#endif
+
+#ifdef I_LOCALE
+# include <locale.h>
+#endif
+
+#if !defined(NO_LOCALE) && defined(HAS_SETLOCALE)
+# define USE_LOCALE
+# if !defined(NO_LOCALE_COLLATE) && defined(LC_COLLATE) \
+ && defined(HAS_STRXFRM)
+# define USE_LOCALE_COLLATE
+# endif
+# if !defined(NO_LOCALE_CTYPE) && defined(LC_CTYPE)
+# define USE_LOCALE_CTYPE
+# endif
+# if !defined(NO_LOCALE_NUMERIC) && defined(LC_NUMERIC)
+# define USE_LOCALE_NUMERIC
+# endif
+#endif /* !NO_LOCALE && HAS_SETLOCALE */
+
+#include <setjmp.h>
+
+#ifdef I_SYS_PARAM
+# ifdef PARAM_NEEDS_TYPES
+# include <sys/types.h>
+# endif
+# include <sys/param.h>
+#endif
+
+
+/* Use all the "standard" definitions? */
+#if defined(STANDARD_C) && defined(I_STDLIB)
+# include <stdlib.h>
+#endif
+
+#define MEM_SIZE Size_t
+
+/* This comes after <stdlib.h> so we don't try to change the standard
+ * library prototypes; we'll use our own in proto.h instead. */
+
+#ifdef MYMALLOC
+
+# ifdef HIDEMYMALLOC
+# define malloc Mymalloc
+# define calloc Mycalloc
+# define realloc Myrealloc
+# define free Myfree
+Malloc_t Mymalloc _((MEM_SIZE nbytes));
+Malloc_t Mycalloc _((MEM_SIZE elements, MEM_SIZE size));
+Malloc_t Myrealloc _((Malloc_t where, MEM_SIZE nbytes));
+Free_t Myfree _((Malloc_t where));
+# endif
+# ifdef EMBEDMYMALLOC
+# define malloc Perl_malloc
+# define calloc Perl_calloc
+# define realloc Perl_realloc
+/* VMS' external symbols are case-insensitive, and there's already a */
+/* perl_free in perl.h */
+#ifdef VMS
+# define free Perl_myfree
+#else
+# define free Perl_free
+#endif
+Malloc_t Perl_malloc _((MEM_SIZE nbytes));
+Malloc_t Perl_calloc _((MEM_SIZE elements, MEM_SIZE size));
+Malloc_t Perl_realloc _((Malloc_t where, MEM_SIZE nbytes));
+#ifdef VMS
+Free_t Perl_myfree _((Malloc_t where));
+#else
+Free_t Perl_free _((Malloc_t where));
+#endif
+# endif
+
+# undef safemalloc
+# undef safecalloc
+# undef saferealloc
+# undef safefree
+# define safemalloc malloc
+# define safecalloc calloc
+# define saferealloc realloc
+# define safefree free
+
+#endif /* MYMALLOC */
+
+#if defined(STANDARD_C) && defined(I_STDDEF)
+# include <stddef.h>
+# define STRUCT_OFFSET(s,m) offsetof(s,m)
+#else
+# define STRUCT_OFFSET(s,m) (Size_t)(&(((s *)0)->m))
+#endif
+
+#if defined(I_STRING) || defined(__cplusplus)
+# include <string.h>
+#else
+# include <strings.h>
+#endif
+
+#if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr)
+#define strchr index
+#define strrchr rindex
+#endif
+
+#ifdef I_MEMORY
+# include <memory.h>
+#endif
+
+#ifdef HAS_MEMCPY
+# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
+# ifndef memcpy
+ extern char * memcpy _((char*, char*, int));
+# endif
+# endif
+#else
+# ifndef memcpy
+# ifdef HAS_BCOPY
+# define memcpy(d,s,l) bcopy(s,d,l)
+# else
+# define memcpy(d,s,l) my_bcopy(s,d,l)
+# endif
+# endif
+#endif /* HAS_MEMCPY */
+
+#ifdef HAS_MEMSET
+# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
+# ifndef memset
+ extern char *memset _((char*, int, int));
+# endif
+# endif
+#else
+# define memset(d,c,l) my_memset(d,c,l)
+#endif /* HAS_MEMSET */
+
+#if !defined(HAS_MEMMOVE) && !defined(memmove)
+# if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
+# define memmove(d,s,l) bcopy(s,d,l)
+# else
+# if defined(HAS_MEMCPY) && defined(HAS_SAFE_MEMCPY)
+# define memmove(d,s,l) memcpy(d,s,l)
+# else
+# define memmove(d,s,l) my_bcopy(s,d,l)
+# endif
+# endif
+#endif
+
+#if defined(mips) && defined(ultrix) && !defined(__STDC__)
+# undef HAS_MEMCMP
+#endif
+
+#if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP)
+# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
+# ifndef memcmp
+ extern int memcmp _((char*, char*, int));
+# endif
+# endif
+# ifdef BUGGY_MSC
+ # pragma function(memcmp)
+# endif
+#else
+# ifndef memcmp
+# define memcmp my_memcmp
+# endif
+#endif /* HAS_MEMCMP && HAS_SANE_MEMCMP */
+
+#ifndef memzero
+# ifdef HAS_MEMSET
+# define memzero(d,l) memset(d,0,l)
+# else
+# ifdef HAS_BZERO
+# define memzero(d,l) bzero(d,l)
+# else
+# define memzero(d,l) my_bzero(d,l)
+# endif
+# endif
+#endif
+
+#ifndef HAS_BCMP
+# ifndef bcmp
+# define bcmp(s1,s2,l) memcmp(s1,s2,l)
+# endif
+#endif /* !HAS_BCMP */
+
+#ifdef I_NETINET_IN
+# include <netinet/in.h>
+#endif
+
+#ifdef I_ARPA_INET
+# include <arpa/inet.h>
+#endif
+
+#if defined(SF_APPEND) && defined(USE_SFIO) && defined(I_SFIO)
+/* <sfio.h> defines SF_APPEND and <sys/stat.h> might define SF_APPEND
+ * (the neo-BSD seem to do this). */
+# undef SF_APPEND
+#endif
+
+#ifdef I_SYS_STAT
+# include <sys/stat.h>
+#endif
+
+/* The stat macros for Amdahl UTS, Unisoft System V/88 (and derivatives
+ like UTekV) are broken, sometimes giving false positives. Undefine
+ them here and let the code below set them to proper values.
+
+ The ghs macro stands for GreenHills Software C-1.8.5 which
+ is the C compiler for sysV88 and the various derivatives.
+ This header file bug is corrected in gcc-2.5.8 and later versions.
+ --Kaveh Ghazi (ghazi@noc.rutgers.edu) 10/3/94. */
+
+#if defined(uts) || (defined(m88k) && defined(ghs))
+# undef S_ISDIR
+# undef S_ISCHR
+# undef S_ISBLK
+# undef S_ISREG
+# undef S_ISFIFO
+# undef S_ISLNK
+#endif
+
+#ifdef I_TIME
+# include <time.h>
+#endif
+
+#ifdef I_SYS_TIME
+# ifdef I_SYS_TIME_KERNEL
+# define KERNEL
+# endif
+# include <sys/time.h>
+# ifdef I_SYS_TIME_KERNEL
+# undef KERNEL
+# endif
+#endif
+
+#if defined(HAS_TIMES) && defined(I_SYS_TIMES)
+# include <sys/times.h>
+#endif
+
+#if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR))
+# undef HAS_STRERROR
+#endif
+
+#include <errno.h>
+#ifdef HAS_SOCKET
+# ifdef I_NET_ERRNO
+# include <net/errno.h>
+# endif
+#endif
+
+#ifdef VMS
+# define SETERRNO(errcode,vmserrcode) \
+ STMT_START { \
+ set_errno(errcode); \
+ set_vaxc_errno(vmserrcode); \
+ } STMT_END
+#else
+# define SETERRNO(errcode,vmserrcode) errno = (errcode)
+#endif
+
+#ifdef USE_THREADS
+# define ERRSV (thr->errsv)
+# define ERRHV (thr->errhv)
+# define DEFSV THREADSV(0)
+# define SAVE_DEFSV save_threadsv(0)
+#else
+# define ERRSV GvSV(PL_errgv)
+# define ERRHV GvHV(PL_errgv)
+# define DEFSV GvSV(PL_defgv)
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif /* USE_THREADS */
+
+#ifndef errno
+ extern int errno; /* ANSI allows errno to be an lvalue expr */
+#endif
+
+#ifdef HAS_STRERROR
+# ifdef VMS
+ char *strerror _((int,...));
+# else
+#ifndef DONT_DECLARE_STD
+ char *strerror _((int));
+#endif
+# endif
+# ifndef Strerror
+# define Strerror strerror
+# endif
+#else
+# ifdef HAS_SYS_ERRLIST
+ extern int sys_nerr;
+ extern char *sys_errlist[];
+# ifndef Strerror
+# define Strerror(e) \
+ ((e) < 0 || (e) >= sys_nerr ? "(unknown)" : sys_errlist[e])
+# endif
+# endif
+#endif
+
+#ifdef I_SYS_IOCTL
+# ifndef _IOCTL_
+# include <sys/ioctl.h>
+# endif
+#endif
+
+#if defined(mc300) || defined(mc500) || defined(mc700) || defined(mc6000)
+# ifdef HAS_SOCKETPAIR
+# undef HAS_SOCKETPAIR
+# endif
+# ifdef I_NDBM
+# undef I_NDBM
+# endif
+#endif
+
+#if INTSIZE == 2
+# define htoni htons
+# define ntohi ntohs
+#else
+# define htoni htonl
+# define ntohi ntohl
+#endif
+
+/* Configure already sets Direntry_t */
+#if defined(I_DIRENT)
+# include <dirent.h>
+# if defined(NeXT) && defined(I_SYS_DIR) /* NeXT needs dirent + sys/dir.h */
+# include <sys/dir.h>
+# endif
+#else
+# ifdef I_SYS_NDIR
+# include <sys/ndir.h>
+# else
+# ifdef I_SYS_DIR
+# ifdef hp9000s500
+# include <ndir.h> /* may be wrong in the future */
+# else
+# include <sys/dir.h>
+# endif
+# endif
+# endif
+#endif
+
+#ifdef FPUTS_BOTCH
+/* work around botch in SunOS 4.0.1 and 4.0.2 */
+# ifndef fputs
+# define fputs(sv,fp) fprintf(fp,"%s",sv)
+# endif
+#endif
+
+/*
+ * The following gobbledygook brought to you on behalf of __STDC__.
+ * (I could just use #ifndef __STDC__, but this is more bulletproof
+ * in the face of half-implementations.)
+ */
+
+#ifndef S_IFMT
+# ifdef _S_IFMT
+# define S_IFMT _S_IFMT
+# else
+# define S_IFMT 0170000
+# endif
+#endif
+
+#ifndef S_ISDIR
+# define S_ISDIR(m) ((m & S_IFMT) == S_IFDIR)
+#endif
+
+#ifndef S_ISCHR
+# define S_ISCHR(m) ((m & S_IFMT) == S_IFCHR)
+#endif
+
+#ifndef S_ISBLK
+# ifdef S_IFBLK
+# define S_ISBLK(m) ((m & S_IFMT) == S_IFBLK)
+# else
+# define S_ISBLK(m) (0)
+# endif
+#endif
+
+#ifndef S_ISREG
+# define S_ISREG(m) ((m & S_IFMT) == S_IFREG)
+#endif
+
+#ifndef S_ISFIFO
+# ifdef S_IFIFO
+# define S_ISFIFO(m) ((m & S_IFMT) == S_IFIFO)
+# else
+# define S_ISFIFO(m) (0)
+# endif
+#endif
+
+#ifndef S_ISLNK
+# ifdef _S_ISLNK
+# define S_ISLNK(m) _S_ISLNK(m)
+# else
+# ifdef _S_IFLNK
+# define S_ISLNK(m) ((m & S_IFMT) == _S_IFLNK)
+# else
+# ifdef S_IFLNK
+# define S_ISLNK(m) ((m & S_IFMT) == S_IFLNK)
+# else
+# define S_ISLNK(m) (0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef S_ISSOCK
+# ifdef _S_ISSOCK
+# define S_ISSOCK(m) _S_ISSOCK(m)
+# else
+# ifdef _S_IFSOCK
+# define S_ISSOCK(m) ((m & S_IFMT) == _S_IFSOCK)
+# else
+# ifdef S_IFSOCK
+# define S_ISSOCK(m) ((m & S_IFMT) == S_IFSOCK)
+# else
+# define S_ISSOCK(m) (0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef S_IRUSR
+# ifdef S_IREAD
+# define S_IRUSR S_IREAD
+# define S_IWUSR S_IWRITE
+# define S_IXUSR S_IEXEC
+# else
+# define S_IRUSR 0400
+# define S_IWUSR 0200
+# define S_IXUSR 0100
+# endif
+# define S_IRGRP (S_IRUSR>>3)
+# define S_IWGRP (S_IWUSR>>3)
+# define S_IXGRP (S_IXUSR>>3)
+# define S_IROTH (S_IRUSR>>6)
+# define S_IWOTH (S_IWUSR>>6)
+# define S_IXOTH (S_IXUSR>>6)
+#endif
+
+#ifndef S_ISUID
+# define S_ISUID 04000
+#endif
+
+#ifndef S_ISGID
+# define S_ISGID 02000
+#endif
+
+#ifdef ff_next
+# undef ff_next
+#endif
+
+#if defined(cray) || defined(gould) || defined(i860) || defined(pyr)
+# define SLOPPYDIVIDE
+#endif
+
+#ifdef UV
+#undef UV
+#endif
+
+/* XXX QUAD stuff is not currently supported on most systems.
+ Specifically, perl internals don't support long long. Among
+ the many problems is that some compilers support long long,
+ but the underlying library functions (such as sprintf) don't.
+ Some things do work (such as quad pack/unpack on convex);
+ also some systems use long long for the fpos_t typedef. That
+ seems to work too.
+
+ The IV type is supposed to be long enough to hold any integral
+ value or a pointer.
+ --Andy Dougherty August 1996
+*/
+
+#ifdef cray
+# define Quad_t int
+#else
+# ifdef convex
+# define Quad_t long long
+# else
+# if LONGSIZE == 8
+# define Quad_t long
+# endif
+# endif
+#endif
+
+/* XXX Experimental set-up for long long. Just add -DUSE_LONG_LONG
+ to your ccflags. --Andy Dougherty 4/1998
+*/
+#ifdef USE_LONG_LONG
+# if defined(HAS_LONG_LONG) && LONGLONGSIZE == 8
+# define Quad_t long long
+# endif
+#endif
+
+#ifdef Quad_t
+# define HAS_QUAD
+ typedef Quad_t IV;
+ typedef unsigned Quad_t UV;
+# define IV_MAX PERL_QUAD_MAX
+# define IV_MIN PERL_QUAD_MIN
+# define UV_MAX PERL_UQUAD_MAX
+# define UV_MIN PERL_UQUAD_MIN
+#else
+ typedef long IV;
+ typedef unsigned long UV;
+# define IV_MAX PERL_LONG_MAX
+# define IV_MIN PERL_LONG_MIN
+# define UV_MAX PERL_ULONG_MAX
+# define UV_MIN PERL_ULONG_MIN
+#endif
+
+/* Previously these definitions used hardcoded figures.
+ * It is hoped these formula are more portable, although
+ * no data one way or another is presently known to me.
+ * The "PERL_" names are used because these calculated constants
+ * do not meet the ANSI requirements for LONG_MAX, etc., which
+ * need to be constants acceptable to #if - kja
+ * define PERL_LONG_MAX 2147483647L
+ * define PERL_LONG_MIN (-LONG_MAX - 1)
+ * define PERL ULONG_MAX 4294967295L
+ */
+
+#ifdef I_LIMITS /* Needed for cast_xxx() functions below. */
+# include <limits.h>
+#else
+#ifdef I_VALUES
+# include <values.h>
+#endif
+#endif
+
+/*
+ * Try to figure out max and min values for the integral types. THE CORRECT
+ * SOLUTION TO THIS MESS: ADAPT enquire.c FROM GCC INTO CONFIGURE. The
+ * following hacks are used if neither limits.h or values.h provide them:
+ * U<TYPE>_MAX: for types >= int: ~(unsigned TYPE)0
+ * for types < int: (unsigned TYPE)~(unsigned)0
+ * The argument to ~ must be unsigned so that later signed->unsigned
+ * conversion can't modify the value's bit pattern (e.g. -0 -> +0),
+ * and it must not be smaller than int because ~ does integral promotion.
+ * <type>_MAX: (<type>) (U<type>_MAX >> 1)
+ * <type>_MIN: -<type>_MAX - <is_twos_complement_architecture: (3 & -1) == 3>.
+ * The latter is a hack which happens to work on some machines but
+ * does *not* catch any random system, or things like integer types
+ * with NaN if that is possible.
+ *
+ * All of the types are explicitly cast to prevent accidental loss of
+ * numeric range, and in the hope that they will be less likely to confuse
+ * over-eager optimizers.
+ *
+ */
+
+#define PERL_UCHAR_MIN ((unsigned char)0)
+
+#ifdef UCHAR_MAX
+# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
+#else
+# ifdef MAXUCHAR
+# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
+# else
+# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
+# endif
+#endif
+
+/*
+ * CHAR_MIN and CHAR_MAX are not included here, as the (char) type may be
+ * ambiguous. It may be equivalent to (signed char) or (unsigned char)
+ * depending on local options. Until Configure detects this (or at least
+ * detects whether the "signed" keyword is available) the CHAR ranges
+ * will not be included. UCHAR functions normally.
+ * - kja
+ */
+
+#define PERL_USHORT_MIN ((unsigned short)0)
+
+#ifdef USHORT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
+#else
+# ifdef MAXUSHORT
+# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
+# else
+# ifdef USHRT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
+# else
+# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
+# endif
+# endif
+#endif
+
+#ifdef SHORT_MAX
+# define PERL_SHORT_MAX ((short)SHORT_MAX)
+#else
+# ifdef MAXSHORT /* Often used in <values.h> */
+# define PERL_SHORT_MAX ((short)MAXSHORT)
+# else
+# ifdef SHRT_MAX
+# define PERL_SHORT_MAX ((short)SHRT_MAX)
+# else
+# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifdef SHORT_MIN
+# define PERL_SHORT_MIN ((short)SHORT_MIN)
+#else
+# ifdef MINSHORT
+# define PERL_SHORT_MIN ((short)MINSHORT)
+# else
+# ifdef SHRT_MIN
+# define PERL_SHORT_MIN ((short)SHRT_MIN)
+# else
+# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#ifdef UINT_MAX
+# define PERL_UINT_MAX ((unsigned int)UINT_MAX)
+#else
+# ifdef MAXUINT
+# define PERL_UINT_MAX ((unsigned int)MAXUINT)
+# else
+# define PERL_UINT_MAX (~(unsigned int)0)
+# endif
+#endif
+
+#define PERL_UINT_MIN ((unsigned int)0)
+
+#ifdef INT_MAX
+# define PERL_INT_MAX ((int)INT_MAX)
+#else
+# ifdef MAXINT /* Often used in <values.h> */
+# define PERL_INT_MAX ((int)MAXINT)
+# else
+# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
+# endif
+#endif
+
+#ifdef INT_MIN
+# define PERL_INT_MIN ((int)INT_MIN)
+#else
+# ifdef MININT
+# define PERL_INT_MIN ((int)MININT)
+# else
+# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
+# endif
+#endif
+
+#ifdef ULONG_MAX
+# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
+#else
+# ifdef MAXULONG
+# define PERL_ULONG_MAX ((unsigned long)MAXULONG)
+# else
+# define PERL_ULONG_MAX (~(unsigned long)0)
+# endif
+#endif
+
+#define PERL_ULONG_MIN ((unsigned long)0L)
+
+#ifdef LONG_MAX
+# define PERL_LONG_MAX ((long)LONG_MAX)
+#else
+# ifdef MAXLONG /* Often used in <values.h> */
+# define PERL_LONG_MAX ((long)MAXLONG)
+# else
+# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
+# endif
+#endif
+
+#ifdef LONG_MIN
+# define PERL_LONG_MIN ((long)LONG_MIN)
+#else
+# ifdef MINLONG
+# define PERL_LONG_MIN ((long)MINLONG)
+# else
+# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
+# endif
+#endif
+
+#ifdef HAS_QUAD
+
+# ifdef UQUAD_MAX
+# define PERL_UQUAD_MAX ((UV)UQUAD_MAX)
+# else
+# define PERL_UQUAD_MAX (~(UV)0)
+# endif
+
+# define PERL_UQUAD_MIN ((UV)0)
+
+# ifdef QUAD_MAX
+# define PERL_QUAD_MAX ((IV)QUAD_MAX)
+# else
+# define PERL_QUAD_MAX ((IV) (PERL_UQUAD_MAX >> 1))
+# endif
+
+# ifdef QUAD_MIN
+# define PERL_QUAD_MIN ((IV)QUAD_MIN)
+# else
+# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
+# endif
+
+#endif
+
+typedef MEM_SIZE STRLEN;
+
+typedef struct op OP;
+typedef struct cop COP;
+typedef struct unop UNOP;
+typedef struct binop BINOP;
+typedef struct listop LISTOP;
+typedef struct logop LOGOP;
+typedef struct condop CONDOP;
+typedef struct pmop PMOP;
+typedef struct svop SVOP;
+typedef struct gvop GVOP;
+typedef struct pvop PVOP;
+typedef struct loop LOOP;
+
+typedef struct Outrec Outrec;
+typedef struct interpreter PerlInterpreter;
+#ifndef __BORLANDC__
+typedef struct ff FF; /* XXX not defined anywhere, should go? */
+#endif
+typedef struct sv SV;
+typedef struct av AV;
+typedef struct hv HV;
+typedef struct cv CV;
+typedef struct regexp REGEXP;
+typedef struct gp GP;
+typedef struct gv GV;
+typedef struct io IO;
+typedef struct context PERL_CONTEXT;
+typedef struct block BLOCK;
+
+typedef struct magic MAGIC;
+typedef struct xrv XRV;
+typedef struct xpv XPV;
+typedef struct xpviv XPVIV;
+typedef struct xpvuv XPVUV;
+typedef struct xpvnv XPVNV;
+typedef struct xpvmg XPVMG;
+typedef struct xpvlv XPVLV;
+typedef struct xpvav XPVAV;
+typedef struct xpvhv XPVHV;
+typedef struct xpvgv XPVGV;
+typedef struct xpvcv XPVCV;
+typedef struct xpvbm XPVBM;
+typedef struct xpvfm XPVFM;
+typedef struct xpvio XPVIO;
+typedef struct mgvtbl MGVTBL;
+typedef union any ANY;
+
+#include "handy.h"
+
+#ifdef PERL_OBJECT
+typedef I32 (*filter_t) _((CPerlObj*, int, SV *, int));
+#else
+typedef I32 (*filter_t) _((int, SV *, int));
+#endif
+
+#define FILTER_READ(idx, sv, len) filter_read(idx, sv, len)
+#define FILTER_DATA(idx) (AvARRAY(PL_rsfp_filters)[idx])
+#define FILTER_ISREADER(idx) (idx >= AvFILLp(PL_rsfp_filters))
+
+#ifdef DOSISH
+# if defined(OS2)
+# include "os2ish.h"
+# else
+# include "dosish.h"
+# endif
+#else
+# if defined(VMS)
+# include "vmsish.h"
+# else
+# if defined(PLAN9)
+# include "./plan9/plan9ish.h"
+# else
+# if defined(MPE)
+# include "mpeix/mpeixish.h"
+# else
+# include "unixish.h"
+# endif
+# endif
+# endif
+#endif
+
+#ifndef FUNC_NAME_TO_PTR
+#define FUNC_NAME_TO_PTR(name) name
+#endif
+
+/*
+ * USE_THREADS needs to be after unixish.h as <pthread.h> includes
+ * <sys/signal.h> which defines NSIG - which will stop inclusion of <signal.h>
+ * this results in many functions being undeclared which bothers C++
+ * May make sense to have threads after "*ish.h" anyway
+ */
+
+#ifdef USE_THREADS
+ /* pending resolution of licensing issues, we avoid the erstwhile
+ * atomic.h everywhere */
+# define EMULATE_ATOMIC_REFCOUNTS
+
+# ifdef FAKE_THREADS
+# include "fakethr.h"
+# else
+# ifdef WIN32
+# include <win32thread.h>
+# else
+# ifdef OS2
+# include "os2thread.h"
+# else
+# include <pthread.h>
+typedef pthread_t perl_os_thread;
+typedef pthread_mutex_t perl_mutex;
+typedef pthread_cond_t perl_cond;
+typedef pthread_key_t perl_key;
+# endif /* OS2 */
+# endif /* WIN32 */
+# endif /* FAKE_THREADS */
+#endif /* USE_THREADS */
+
+
+
+#ifdef VMS
+# define STATUS_NATIVE PL_statusvalue_vms
+# define STATUS_NATIVE_EXPORT \
+ ((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms)
+# define STATUS_NATIVE_SET(n) \
+ STMT_START { \
+ PL_statusvalue_vms = (n); \
+ if ((I32)PL_statusvalue_vms == -1) \
+ PL_statusvalue = -1; \
+ else if (PL_statusvalue_vms & STS$M_SUCCESS) \
+ PL_statusvalue = 0; \
+ else if ((PL_statusvalue_vms & STS$M_SEVERITY) == 0) \
+ PL_statusvalue = 1 << 8; \
+ else \
+ PL_statusvalue = (PL_statusvalue_vms & STS$M_SEVERITY) << 8; \
+ } STMT_END
+# define STATUS_POSIX PL_statusvalue
+# ifdef VMSISH_STATUS
+# define STATUS_CURRENT (VMSISH_STATUS ? STATUS_NATIVE : STATUS_POSIX)
+# else
+# define STATUS_CURRENT STATUS_POSIX
+# endif
+# define STATUS_POSIX_SET(n) \
+ STMT_START { \
+ PL_statusvalue = (n); \
+ if (PL_statusvalue != -1) { \
+ PL_statusvalue &= 0xFFFF; \
+ PL_statusvalue_vms = PL_statusvalue ? 44 : 1; \
+ } \
+ else PL_statusvalue_vms = -1; \
+ } STMT_END
+# define STATUS_ALL_SUCCESS (PL_statusvalue = 0, PL_statusvalue_vms = 1)
+# define STATUS_ALL_FAILURE (PL_statusvalue = 1, PL_statusvalue_vms = 44)
+#else
+# define STATUS_NATIVE STATUS_POSIX
+# define STATUS_NATIVE_EXPORT STATUS_POSIX
+# define STATUS_NATIVE_SET STATUS_POSIX_SET
+# define STATUS_POSIX PL_statusvalue
+# define STATUS_POSIX_SET(n) \
+ STMT_START { \
+ PL_statusvalue = (n); \
+ if (PL_statusvalue != -1) \
+ PL_statusvalue &= 0xFFFF; \
+ } STMT_END
+# define STATUS_CURRENT STATUS_POSIX
+# define STATUS_ALL_SUCCESS (PL_statusvalue = 0)
+# define STATUS_ALL_FAILURE (PL_statusvalue = 1)
+#endif
+
+/* Some unistd.h's give a prototype for pause() even though
+ HAS_PAUSE ends up undefined. This causes the #define
+ below to be rejected by the compmiler. Sigh.
+*/
+#ifdef HAS_PAUSE
+#define Pause pause
+#else
+#define Pause() sleep((32767<<16)+32767)
+#endif
+
+#ifndef IOCPARM_LEN
+# ifdef IOCPARM_MASK
+ /* on BSDish systes we're safe */
+# define IOCPARM_LEN(x) (((x) >> 16) & IOCPARM_MASK)
+# else
+ /* otherwise guess at what's safe */
+# define IOCPARM_LEN(x) 256
+# endif
+#endif
+
+#ifdef UNION_ANY_DEFINITION
+UNION_ANY_DEFINITION;
+#else
+union any {
+ void* any_ptr;
+ I32 any_i32;
+ IV any_iv;
+ long any_long;
+ void (CPERLscope(*any_dptr)) _((void*));
+};
+#endif
+
+#ifdef USE_THREADS
+#define ARGSproto struct perl_thread *thr
+#else
+#define ARGSproto void
+#endif /* USE_THREADS */
+
+/* Work around some cygwin32 problems with importing global symbols */
+#if defined(CYGWIN32) && defined(DLLIMPORT)
+# include "cw32imp.h"
+#endif
+
+#include "regexp.h"
+#include "sv.h"
+#include "util.h"
+#include "form.h"
+#include "gv.h"
+#include "cv.h"
+#include "opcode.h"
+#include "op.h"
+#include "cop.h"
+#include "av.h"
+#include "hv.h"
+#include "mg.h"
+#include "scope.h"
+#include "bytecode.h"
+#include "byterun.h"
+
+/* Current curly descriptor */
+typedef struct curcur CURCUR;
+struct curcur {
+ int parenfloor; /* how far back to strip paren data */
+ int cur; /* how many instances of scan we've matched */
+ int min; /* the minimal number of scans to match */
+ int max; /* the maximal number of scans to match */
+ int minmod; /* whether to work our way up or down */
+ regnode * scan; /* the thing to match */
+ regnode * next; /* what has to match after it */
+ char * lastloc; /* where we started matching this scan */
+ CURCUR * oldcc; /* current curly before we started this one */
+};
+
+typedef struct _sublex_info SUBLEXINFO;
+struct _sublex_info {
+ I32 super_state; /* lexer state to save */
+ I32 sub_inwhat; /* "lex_inwhat" to use */
+ OP *sub_op; /* "lex_op" to use */
+};
+
+#ifdef PERL_OBJECT
+struct magic_state {
+ SV* mgs_sv;
+ U32 mgs_flags;
+};
+typedef struct magic_state MGS;
+
+typedef struct {
+ I32 len_min;
+ I32 len_delta;
+ I32 pos_min;
+ I32 pos_delta;
+ SV *last_found;
+ I32 last_end; /* min value, <0 unless valid. */
+ I32 last_start_min;
+ I32 last_start_max;
+ SV **longest; /* Either &l_fixed, or &l_float. */
+ SV *longest_fixed;
+ I32 offset_fixed;
+ SV *longest_float;
+ I32 offset_float_min;
+ I32 offset_float_max;
+ I32 flags;
+} scan_data_t;
+
+typedef I32 CHECKPOINT;
+#endif /* PERL_OBJECT */
+
+/* work around some libPW problems */
+#ifdef DOINIT
+EXT char Error[1];
+#endif
+
+#if defined(iAPX286) || defined(M_I286) || defined(I80286)
+# define I286
+#endif
+
+#if defined(htonl) && !defined(HAS_HTONL)
+#define HAS_HTONL
+#endif
+#if defined(htons) && !defined(HAS_HTONS)
+#define HAS_HTONS
+#endif
+#if defined(ntohl) && !defined(HAS_NTOHL)
+#define HAS_NTOHL
+#endif
+#if defined(ntohs) && !defined(HAS_NTOHS)
+#define HAS_NTOHS
+#endif
+#ifndef HAS_HTONL
+#if (BYTEORDER & 0xffff) != 0x4321
+#define HAS_HTONS
+#define HAS_HTONL
+#define HAS_NTOHS
+#define HAS_NTOHL
+#define MYSWAP
+#define htons my_swap
+#define htonl my_htonl
+#define ntohs my_swap
+#define ntohl my_ntohl
+#endif
+#else
+#if (BYTEORDER & 0xffff) == 0x4321
+#undef HAS_HTONS
+#undef HAS_HTONL
+#undef HAS_NTOHS
+#undef HAS_NTOHL
+#endif
+#endif
+
+/*
+ * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
+ * -DWS
+ */
+#if BYTEORDER != 0x1234
+# define HAS_VTOHL
+# define HAS_VTOHS
+# define HAS_HTOVL
+# define HAS_HTOVS
+# if BYTEORDER == 0x4321
+# define vtohl(x) ((((x)&0xFF)<<24) \
+ +(((x)>>24)&0xFF) \
+ +(((x)&0x0000FF00)<<8) \
+ +(((x)&0x00FF0000)>>8) )
+# define vtohs(x) ((((x)&0xFF)<<8) + (((x)>>8)&0xFF))
+# define htovl(x) vtohl(x)
+# define htovs(x) vtohs(x)
+# endif
+ /* otherwise default to functions in util.c */
+#endif
+
+#ifdef CASTNEGFLOAT
+#define U_S(what) ((U16)(what))
+#define U_I(what) ((unsigned int)(what))
+#define U_L(what) ((U32)(what))
+#else
+EXTERN_C U32 cast_ulong _((double));
+#define U_S(what) ((U16)cast_ulong((double)(what)))
+#define U_I(what) ((unsigned int)cast_ulong((double)(what)))
+#define U_L(what) (cast_ulong((double)(what)))
+#endif
+
+#ifdef CASTI32
+#define I_32(what) ((I32)(what))
+#define I_V(what) ((IV)(what))
+#define U_V(what) ((UV)(what))
+#else
+START_EXTERN_C
+I32 cast_i32 _((double));
+IV cast_iv _((double));
+UV cast_uv _((double));
+END_EXTERN_C
+#define I_32(what) (cast_i32((double)(what)))
+#define I_V(what) (cast_iv((double)(what)))
+#define U_V(what) (cast_uv((double)(what)))
+#endif
+
+struct Outrec {
+ I32 o_lines;
+ char *o_str;
+ U32 o_len;
+};
+
+#ifndef MAXSYSFD
+# define MAXSYSFD 2
+#endif
+
+#ifndef TMPPATH
+# define TMPPATH "/tmp/perl-eXXXXXX"
+#endif
+
+#ifndef __cplusplus
+Uid_t getuid _((void));
+Uid_t geteuid _((void));
+Gid_t getgid _((void));
+Gid_t getegid _((void));
+#endif
+
+#ifdef DEBUGGING
+#ifndef Perl_debug_log
+#define Perl_debug_log PerlIO_stderr()
+#endif
+#undef YYDEBUG
+#define YYDEBUG 1
+#define DEB(a) a
+#define DEBUG(a) if (PL_debug) a
+#define DEBUG_p(a) if (PL_debug & 1) a
+#define DEBUG_s(a) if (PL_debug & 2) a
+#define DEBUG_l(a) if (PL_debug & 4) a
+#define DEBUG_t(a) if (PL_debug & 8) a
+#define DEBUG_o(a) if (PL_debug & 16) a
+#define DEBUG_c(a) if (PL_debug & 32) a
+#define DEBUG_P(a) if (PL_debug & 64) a
+#define DEBUG_m(a) if (PL_curinterp && PL_debug & 128) a
+#define DEBUG_f(a) if (PL_debug & 256) a
+#define DEBUG_r(a) if (PL_debug & 512) a
+#define DEBUG_x(a) if (PL_debug & 1024) a
+#define DEBUG_u(a) if (PL_debug & 2048) a
+#define DEBUG_L(a) if (PL_debug & 4096) a
+#define DEBUG_H(a) if (PL_debug & 8192) a
+#define DEBUG_X(a) if (PL_debug & 16384) a
+#define DEBUG_D(a) if (PL_debug & 32768) a
+# ifdef USE_THREADS
+# define DEBUG_S(a) if (PL_debug & (1<<16)) a
+# else
+# define DEBUG_S(a)
+# endif
+#else
+#define DEB(a)
+#define DEBUG(a)
+#define DEBUG_p(a)
+#define DEBUG_s(a)
+#define DEBUG_l(a)
+#define DEBUG_t(a)
+#define DEBUG_o(a)
+#define DEBUG_c(a)
+#define DEBUG_P(a)
+#define DEBUG_m(a)
+#define DEBUG_f(a)
+#define DEBUG_r(a)
+#define DEBUG_x(a)
+#define DEBUG_u(a)
+#define DEBUG_S(a)
+#define DEBUG_H(a)
+#define DEBUG_X(a)
+#define DEBUG_D(a)
+#define DEBUG_S(a)
+#endif
+#define YYMAXDEPTH 300
+
+#ifndef assert /* <assert.h> might have been included somehow */
+#define assert(what) DEB( { \
+ if (!(what)) { \
+ croak("Assertion failed: file \"%s\", line %d", \
+ __FILE__, __LINE__); \
+ PerlProc_exit(1); \
+ }})
+#endif
+
+struct ufuncs {
+ I32 (*uf_val)_((IV, SV*));
+ I32 (*uf_set)_((IV, SV*));
+ IV uf_index;
+};
+
+/* Fix these up for __STDC__ */
+#ifndef DONT_DECLARE_STD
+char *mktemp _((char*));
+double atof _((const char*));
+#endif
+
+#ifndef STANDARD_C
+/* All of these are in stdlib.h or time.h for ANSI C */
+Time_t time();
+struct tm *gmtime(), *localtime();
+#ifdef OEMVS
+char *(strchr)(), *(strrchr)();
+char *(strcpy)(), *(strcat)();
+#else
+char *strchr(), *strrchr();
+char *strcpy(), *strcat();
+#endif
+#endif /* ! STANDARD_C */
+
+
+#ifdef I_MATH
+# include <math.h>
+#else
+START_EXTERN_C
+ double exp _((double));
+ double log _((double));
+ double log10 _((double));
+ double sqrt _((double));
+ double frexp _((double,int*));
+ double ldexp _((double,int));
+ double modf _((double,double*));
+ double sin _((double));
+ double cos _((double));
+ double atan2 _((double,double));
+ double pow _((double,double));
+END_EXTERN_C
+#endif
+
+#ifndef __cplusplus
+# ifdef __NeXT__ /* or whatever catches all NeXTs */
+char *crypt (); /* Maybe more hosts will need the unprototyped version */
+# else
+# if !defined(WIN32) || !defined(HAVE_DES_FCRYPT)
+char *crypt _((const char*, const char*));
+# endif /* !WIN32 && !HAVE_CRYPT_SOURCE */
+# endif /* !__NeXT__ */
+# ifndef DONT_DECLARE_STD
+# ifndef getenv
+char *getenv _((const char*));
+# endif /* !getenv */
+Off_t lseek _((int,Off_t,int));
+# endif /* !DONT_DECLARE_STD */
+char *getlogin _((void));
+#endif /* !__cplusplus */
+
+#ifdef UNLINK_ALL_VERSIONS /* Currently only makes sense for VMS */
+#define UNLINK unlnk
+I32 unlnk _((char*));
+#else
+#define UNLINK unlink
+#endif
+
+#ifndef HAS_SETREUID
+# ifdef HAS_SETRESUID
+# define setreuid(r,e) setresuid(r,e,(Uid_t)-1)
+# define HAS_SETREUID
+# endif
+#endif
+#ifndef HAS_SETREGID
+# ifdef HAS_SETRESGID
+# define setregid(r,e) setresgid(r,e,(Gid_t)-1)
+# define HAS_SETREGID
+# endif
+#endif
+
+typedef Signal_t (*Sighandler_t) _((int));
+
+#ifdef HAS_SIGACTION
+typedef struct sigaction Sigsave_t;
+#else
+typedef Sighandler_t Sigsave_t;
+#endif
+
+#define SCAN_DEF 0
+#define SCAN_TR 1
+#define SCAN_REPL 2
+
+#ifdef DEBUGGING
+# ifndef register
+# define register
+# endif
+# define PAD_SV(po) pad_sv(po)
+# define RUNOPS_DEFAULT runops_debug
+#else
+# define PAD_SV(po) PL_curpad[po]
+# define RUNOPS_DEFAULT runops_standard
+#endif
+
+#ifdef MYMALLOC
+# define MALLOC_INIT MUTEX_INIT(&PL_malloc_mutex)
+# define MALLOC_TERM MUTEX_DESTROY(&PL_malloc_mutex)
+#else
+# define MALLOC_INIT
+# define MALLOC_TERM
+#endif
+
+
+/*
+ * These need prototyping here because <proto.h> isn't
+ * included until after runops is initialised.
+ */
+
+#ifndef PERL_OBJECT
+typedef int runops_proc_t _((void));
+int runops_standard _((void));
+#ifdef DEBUGGING
+int runops_debug _((void));
+#endif
+#endif /* PERL_OBJECT */
+
+/* _ (for $_) must be first in the following list (DEFSV requires it) */
+#define THREADSV_NAMES "_123456789&`'+/.,\\\";^-%=|~:\001\005!@"
+
+/* VMS doesn't use environ array and NeXT has problems with crt0.o globals */
+#if !defined(VMS) && !(defined(NeXT) && defined(__DYNAMIC__))
+#if !defined(DONT_DECLARE_STD) \
+ || (defined(__svr4__) && defined(__GNUC__) && defined(sun)) \
+ || defined(__sgi) || defined(__DGUX)
+extern char ** environ; /* environment variables supplied via exec */
+#endif
+#else
+# if defined(NeXT) && defined(__DYNAMIC__)
+
+# include <mach-o/dyld.h>
+EXT char *** environ_pointer;
+# define environ (*environ_pointer)
+# endif
+#endif /* environ processing */
+
+
+/* for tmp use in stupid debuggers */
+EXT int * di;
+EXT short * ds;
+EXT char * dc;
+
+/* handy constants */
+EXTCONST char warn_uninit[]
+ INIT("Use of uninitialized value");
+EXTCONST char warn_nosemi[]
+ INIT("Semicolon seems to be missing");
+EXTCONST char warn_reserved[]
+ INIT("Unquoted string \"%s\" may clash with future reserved word");
+EXTCONST char warn_nl[]
+ INIT("Unsuccessful %s on filename containing newline");
+EXTCONST char no_wrongref[]
+ INIT("Can't use %s ref as %s ref");
+EXTCONST char no_symref[]
+ INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use");
+EXTCONST char no_usym[]
+ INIT("Can't use an undefined value as %s reference");
+EXTCONST char no_aelem[]
+ INIT("Modification of non-creatable array value attempted, subscript %d");
+EXTCONST char no_helem[]
+ INIT("Modification of non-creatable hash value attempted, subscript \"%s\"");
+EXTCONST char no_modify[]
+ INIT("Modification of a read-only value attempted");
+EXTCONST char no_mem[]
+ INIT("Out of memory!\n");
+EXTCONST char no_security[]
+ INIT("Insecure dependency in %s%s");
+EXTCONST char no_sock_func[]
+ INIT("Unsupported socket function \"%s\" called");
+EXTCONST char no_dir_func[]
+ INIT("Unsupported directory function \"%s\" called");
+EXTCONST char no_func[]
+ INIT("The %s function is unimplemented");
+EXTCONST char no_myglob[]
+ INIT("\"my\" variable %s can't be in a package");
+
+#ifdef DOINIT
+EXT char *sig_name[] = { SIG_NAME };
+EXT int sig_num[] = { SIG_NUM };
+EXT SV * psig_ptr[sizeof(sig_num)/sizeof(*sig_num)];
+EXT SV * psig_name[sizeof(sig_num)/sizeof(*sig_num)];
+#else
+EXT char *sig_name[];
+EXT int sig_num[];
+EXT SV * psig_ptr[];
+EXT SV * psig_name[];
+#endif
+
+/* fast case folding tables */
+
+#ifdef DOINIT
+#ifdef EBCDIC
+EXT unsigned char fold[] = { /* fast EBCDIC case folding table */
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 65, 66, 67, 68, 69, 70, 71,
+ 72, 73, 74, 75, 76, 77, 78, 79,
+ 80, 81, 82, 83, 84, 85, 86, 87,
+ 88, 89, 90, 91, 92, 93, 94, 95,
+ 96, 97, 98, 99, 100, 101, 102, 103,
+ 104, 105, 106, 107, 108, 109, 110, 111,
+ 112, 113, 114, 115, 116, 117, 118, 119,
+ 120, 121, 122, 123, 124, 125, 126, 127,
+ 128, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 138, 139, 140, 141, 142, 143,
+ 144, 'J', 'K', 'L', 'M', 'N', 'O', 'P',
+ 'Q', 'R', 154, 155, 156, 157, 158, 159,
+ 160, 161, 'S', 'T', 'U', 'V', 'W', 'X',
+ 'Y', 'Z', 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 202, 203, 204, 205, 206, 207,
+ 208, 'j', 'k', 'l', 'm', 'n', 'o', 'p',
+ 'q', 'r', 218, 219, 220, 221, 222, 223,
+ 224, 225, 's', 't', 'u', 'v', 'w', 'x',
+ 'y', 'z', 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
+};
+#else /* ascii rather than ebcdic */
+EXTCONST unsigned char fold[] = {
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
+ 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
+ 'x', 'y', 'z', 91, 92, 93, 94, 95,
+ 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
+ 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
+ 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
+ 128, 129, 130, 131, 132, 133, 134, 135,
+ 136, 137, 138, 139, 140, 141, 142, 143,
+ 144, 145, 146, 147, 148, 149, 150, 151,
+ 152, 153, 154, 155, 156, 157, 158, 159,
+ 160, 161, 162, 163, 164, 165, 166, 167,
+ 168, 169, 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 193, 194, 195, 196, 197, 198, 199,
+ 200, 201, 202, 203, 204, 205, 206, 207,
+ 208, 209, 210, 211, 212, 213, 214, 215,
+ 216, 217, 218, 219, 220, 221, 222, 223,
+ 224, 225, 226, 227, 228, 229, 230, 231,
+ 232, 233, 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
+};
+#endif /* !EBCDIC */
+#else
+EXTCONST unsigned char fold[];
+#endif
+
+#ifdef DOINIT
+EXT unsigned char fold_locale[] = {
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
+ 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
+ 'x', 'y', 'z', 91, 92, 93, 94, 95,
+ 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
+ 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
+ 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
+ 128, 129, 130, 131, 132, 133, 134, 135,
+ 136, 137, 138, 139, 140, 141, 142, 143,
+ 144, 145, 146, 147, 148, 149, 150, 151,
+ 152, 153, 154, 155, 156, 157, 158, 159,
+ 160, 161, 162, 163, 164, 165, 166, 167,
+ 168, 169, 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 193, 194, 195, 196, 197, 198, 199,
+ 200, 201, 202, 203, 204, 205, 206, 207,
+ 208, 209, 210, 211, 212, 213, 214, 215,
+ 216, 217, 218, 219, 220, 221, 222, 223,
+ 224, 225, 226, 227, 228, 229, 230, 231,
+ 232, 233, 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
+};
+#else
+EXT unsigned char fold_locale[];
+#endif
+
+#ifdef DOINIT
+#ifdef EBCDIC
+EXT unsigned char freq[] = {/* EBCDIC frequencies for mixed English/C */
+ 1, 2, 84, 151, 154, 155, 156, 157,
+ 165, 246, 250, 3, 158, 7, 18, 29,
+ 40, 51, 62, 73, 85, 96, 107, 118,
+ 129, 140, 147, 148, 149, 150, 152, 153,
+ 255, 6, 8, 9, 10, 11, 12, 13,
+ 14, 15, 24, 25, 26, 27, 28, 226,
+ 29, 30, 31, 32, 33, 43, 44, 45,
+ 46, 47, 48, 49, 50, 76, 77, 78,
+ 79, 80, 81, 82, 83, 84, 85, 86,
+ 87, 94, 95, 234, 181, 233, 187, 190,
+ 180, 96, 97, 98, 99, 100, 101, 102,
+ 104, 112, 182, 174, 236, 232, 229, 103,
+ 228, 226, 114, 115, 116, 117, 118, 119,
+ 120, 121, 122, 235, 176, 230, 194, 162,
+ 130, 131, 132, 133, 134, 135, 136, 137,
+ 138, 139, 201, 205, 163, 217, 220, 224,
+ 5, 248, 227, 244, 242, 255, 241, 231,
+ 240, 253, 16, 197, 19, 20, 21, 187,
+ 23, 169, 210, 245, 237, 249, 247, 239,
+ 168, 252, 34, 196, 36, 37, 38, 39,
+ 41, 42, 251, 254, 238, 223, 221, 213,
+ 225, 177, 52, 53, 54, 55, 56, 57,
+ 58, 59, 60, 61, 63, 64, 65, 66,
+ 67, 68, 69, 70, 71, 72, 74, 75,
+ 205, 208, 186, 202, 200, 218, 198, 179,
+ 178, 214, 88, 89, 90, 91, 92, 93,
+ 217, 166, 170, 207, 199, 209, 206, 204,
+ 160, 212, 105, 106, 108, 109, 110, 111,
+ 203, 113, 216, 215, 192, 175, 193, 243,
+ 172, 161, 123, 124, 125, 126, 127, 128,
+ 222, 219, 211, 195, 188, 193, 185, 184,
+ 191, 183, 141, 142, 143, 144, 145, 146
+};
+#else /* ascii rather than ebcdic */
+EXTCONST unsigned char freq[] = { /* letter frequencies for mixed English/C */
+ 1, 2, 84, 151, 154, 155, 156, 157,
+ 165, 246, 250, 3, 158, 7, 18, 29,
+ 40, 51, 62, 73, 85, 96, 107, 118,
+ 129, 140, 147, 148, 149, 150, 152, 153,
+ 255, 182, 224, 205, 174, 176, 180, 217,
+ 233, 232, 236, 187, 235, 228, 234, 226,
+ 222, 219, 211, 195, 188, 193, 185, 184,
+ 191, 183, 201, 229, 181, 220, 194, 162,
+ 163, 208, 186, 202, 200, 218, 198, 179,
+ 178, 214, 166, 170, 207, 199, 209, 206,
+ 204, 160, 212, 216, 215, 192, 175, 173,
+ 243, 172, 161, 190, 203, 189, 164, 230,
+ 167, 248, 227, 244, 242, 255, 241, 231,
+ 240, 253, 169, 210, 245, 237, 249, 247,
+ 239, 168, 252, 251, 254, 238, 223, 221,
+ 213, 225, 177, 197, 171, 196, 159, 4,
+ 5, 6, 8, 9, 10, 11, 12, 13,
+ 14, 15, 16, 17, 19, 20, 21, 22,
+ 23, 24, 25, 26, 27, 28, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 41, 42, 43, 44, 45, 46, 47, 48,
+ 49, 50, 52, 53, 54, 55, 56, 57,
+ 58, 59, 60, 61, 63, 64, 65, 66,
+ 67, 68, 69, 70, 71, 72, 74, 75,
+ 76, 77, 78, 79, 80, 81, 82, 83,
+ 86, 87, 88, 89, 90, 91, 92, 93,
+ 94, 95, 97, 98, 99, 100, 101, 102,
+ 103, 104, 105, 106, 108, 109, 110, 111,
+ 112, 113, 114, 115, 116, 117, 119, 120,
+ 121, 122, 123, 124, 125, 126, 127, 128,
+ 130, 131, 132, 133, 134, 135, 136, 137,
+ 138, 139, 141, 142, 143, 144, 145, 146
+};
+#endif
+#else
+EXTCONST unsigned char freq[];
+#endif
+
+#ifdef DEBUGGING
+#ifdef DOINIT
+EXTCONST char* block_type[] = {
+ "NULL",
+ "SUB",
+ "EVAL",
+ "LOOP",
+ "SUBST",
+ "BLOCK",
+};
+#else
+EXTCONST char* block_type[];
+#endif
+#endif
+
+/*****************************************************************************/
+/* This lexer/parser stuff is currently global since yacc is hard to reenter */
+/*****************************************************************************/
+/* XXX This needs to be revisited, since BEGIN makes yacc re-enter... */
+
+#include "perly.h"
+
+#define LEX_NOTPARSING 11 /* borrowed from toke.c */
+
+typedef enum {
+ XOPERATOR,
+ XTERM,
+ XREF,
+ XSTATE,
+ XBLOCK,
+ XTERMBLOCK
+} expectation;
+
+
+ /* Note: the lowest 8 bits are reserved for
+ stuffing into op->op_private */
+#define HINT_INTEGER 0x00000001
+#define HINT_STRICT_REFS 0x00000002
+
+#define HINT_BLOCK_SCOPE 0x00000100
+#define HINT_STRICT_SUBS 0x00000200
+#define HINT_STRICT_VARS 0x00000400
+#define HINT_LOCALE 0x00000800
+
+#define HINT_NEW_INTEGER 0x00001000
+#define HINT_NEW_FLOAT 0x00002000
+#define HINT_NEW_BINARY 0x00004000
+#define HINT_NEW_STRING 0x00008000
+#define HINT_NEW_RE 0x00010000
+#define HINT_LOCALIZE_HH 0x00020000 /* %^H needs to be copied */
+
+#define HINT_RE_TAINT 0x00100000
+#define HINT_RE_EVAL 0x00200000
+
+/* Various states of an input record separator SV (rs, nrs) */
+#define RsSNARF(sv) (! SvOK(sv))
+#define RsSIMPLE(sv) (SvOK(sv) && SvCUR(sv))
+#define RsPARA(sv) (SvOK(sv) && ! SvCUR(sv))
+#define RsRECORD(sv) (SvROK(sv) && (SvIV(SvRV(sv)) > 0))
+
+/* Enable variables which are pointers to functions */
+#ifdef PERL_OBJECT
+typedef regexp*(CPerlObj::*regcomp_t) _((char* exp, char* xend, PMOP* pm));
+typedef I32 (CPerlObj::*regexec_t) _((regexp* prog, char* stringarg,
+ char* strend, char* strbeg,
+ I32 minend, SV* screamer, void* data,
+ U32 flags));
+#else
+typedef regexp*(*regcomp_t) _((char* exp, char* xend, PMOP* pm));
+typedef I32 (*regexec_t) _((regexp* prog, char* stringarg, char* strend, char*
+ strbeg, I32 minend, SV* screamer, void* data,
+ U32 flags));
+
+#endif
+
+/* Set up PERLVAR macros for populating structs */
+#define PERLVAR(var,type) type var;
+#define PERLVARI(var,type,init) type var;
+#define PERLVARIC(var,type,init) type var;
+
+/* Interpreter exitlist entry */
+typedef struct exitlistentry {
+#ifdef PERL_OBJECT
+ void (*fn) _((CPerlObj*, void*));
+#else
+ void (*fn) _((void*));
+#endif
+ void *ptr;
+} PerlExitListEntry;
+
+#ifdef PERL_OBJECT
+extern "C" CPerlObj* perl_alloc _((IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*));
+
+typedef int (CPerlObj::*runops_proc_t) _((void));
+#undef EXT
+#define EXT
+#undef EXTCONST
+#define EXTCONST
+#undef INIT
+#define INIT(x)
+
+class CPerlObj {
+public:
+ CPerlObj(IPerlMem*, IPerlEnv*, IPerlStdIO*, IPerlLIO*, IPerlDir*, IPerlSock*, IPerlProc*);
+ void Init(void);
+ void* operator new(size_t nSize, IPerlMem *pvtbl);
+#endif /* PERL_OBJECT */
+
+#ifdef PERL_GLOBAL_STRUCT
+struct perl_vars {
+#include "perlvars.h"
+};
+
+#ifdef PERL_CORE
+EXT struct perl_vars PL_Vars;
+EXT struct perl_vars *PL_VarsPtr INIT(&PL_Vars);
+#else /* PERL_CORE */
+#if !defined(__GNUC__) || !defined(WIN32)
+EXT
+#endif /* WIN32 */
+struct perl_vars *PL_VarsPtr;
+#define PL_Vars (*((PL_VarsPtr) ? PL_VarsPtr : (PL_VarsPtr = Perl_GetVars())))
+#endif /* PERL_CORE */
+#endif /* PERL_GLOBAL_STRUCT */
+
+#ifdef MULTIPLICITY
+/* If we have multiple interpreters define a struct
+ holding variables which must be per-interpreter
+ If we don't have threads anything that would have
+ be per-thread is per-interpreter.
+*/
+
+struct interpreter {
+#ifndef USE_THREADS
+#include "thrdvar.h"
+#endif
+#include "intrpvar.h"
+};
+
+#else
+struct interpreter {
+ char broiled;
+};
+#endif
+
+#ifdef USE_THREADS
+/* If we have threads define a struct with all the variables
+ * that have to be per-thread
+ */
+
+
+struct perl_thread {
+#include "thrdvar.h"
+};
+
+typedef struct perl_thread *Thread;
+
+#else
+typedef void *Thread;
+#endif
+
+/* Done with PERLVAR macros for now ... */
+#undef PERLVAR
+#undef PERLVARI
+#undef PERLVARIC
+
+#include "thread.h"
+#include "pp.h"
+#include "proto.h"
+
+#ifdef EMBED
+#define Perl_sv_setptrobj(rv,ptr,name) Perl_sv_setref_iv(rv,name,(IV)ptr)
+#define Perl_sv_setptrref(rv,ptr) Perl_sv_setref_iv(rv,Nullch,(IV)ptr)
+#else
+#define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,(IV)ptr)
+#define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,(IV)ptr)
+#endif
+
+/* The following must follow proto.h as #defines mess up syntax */
+
+#include "embedvar.h"
+
+/* Now include all the 'global' variables
+ * If we don't have threads or multiple interpreters
+ * these include variables that would have been their struct-s
+ */
+
+#define PERLVAR(var,type) EXT type PL_##var;
+#define PERLVARI(var,type,init) EXT type PL_##var INIT(init);
+#define PERLVARIC(var,type,init) EXTCONST type PL_##var INIT(init);
+
+#ifndef PERL_GLOBAL_STRUCT
+#include "perlvars.h"
+#endif
+
+#ifndef MULTIPLICITY
+
+# include "intrpvar.h"
+# ifndef USE_THREADS
+# include "thrdvar.h"
+# endif
+
+#endif
+
+#ifdef PERL_OBJECT
+/*
+ * The following is a buffer where new variables must
+ * be defined to maintain binary compatibility with PERL_OBJECT
+ * for 5.005
+ */
+PERLVAR(object_compatibility[30], char)
+};
+
+#include "objpp.h"
+#ifdef DOINIT
+#include "INTERN.h"
+#else
+#include "EXTERN.h"
+#endif
+#endif /* PERL_OBJECT */
+
+
+#undef PERLVAR
+#undef PERLVARI
+#undef PERLVARIC
+
+#if defined(HASATTRIBUTE) && defined(WIN32)
+/*
+ * This provides a layer of functions and macros to ensure extensions will
+ * get to use the same RTL functions as the core.
+ * It has to go here or #define of printf messes up __attribute__
+ * stuff in proto.h
+ */
+#ifndef PERL_OBJECT
+# include <win32iop.h>
+#endif /* PERL_OBJECT */
+#endif /* WIN32 */
+
+#ifdef DOINIT
+
+EXT MGVTBL vtbl_sv = {magic_get,
+ magic_set,
+ magic_len,
+ 0, 0};
+EXT MGVTBL vtbl_env = {0, magic_set_all_env,
+ 0, magic_clear_all_env,
+ 0};
+EXT MGVTBL vtbl_envelem = {0, magic_setenv,
+ 0, magic_clearenv,
+ 0};
+EXT MGVTBL vtbl_sig = {0, 0, 0, 0, 0};
+EXT MGVTBL vtbl_sigelem = {magic_getsig,
+ magic_setsig,
+ 0, magic_clearsig,
+ 0};
+EXT MGVTBL vtbl_pack = {0, 0, magic_sizepack, magic_wipepack,
+ 0};
+EXT MGVTBL vtbl_packelem = {magic_getpack,
+ magic_setpack,
+ 0, magic_clearpack,
+ 0};
+EXT MGVTBL vtbl_dbline = {0, magic_setdbline,
+ 0, 0, 0};
+EXT MGVTBL vtbl_isa = {0, magic_setisa,
+ 0, magic_setisa,
+ 0};
+EXT MGVTBL vtbl_isaelem = {0, magic_setisa,
+ 0, 0, 0};
+EXT MGVTBL vtbl_arylen = {magic_getarylen,
+ magic_setarylen,
+ 0, 0, 0};
+EXT MGVTBL vtbl_glob = {magic_getglob,
+ magic_setglob,
+ 0, 0, 0};
+EXT MGVTBL vtbl_mglob = {0, magic_setmglob,
+ 0, 0, 0};
+EXT MGVTBL vtbl_nkeys = {magic_getnkeys,
+ magic_setnkeys,
+ 0, 0, 0};
+EXT MGVTBL vtbl_taint = {magic_gettaint,magic_settaint,
+ 0, 0, 0};
+EXT MGVTBL vtbl_substr = {magic_getsubstr, magic_setsubstr,
+ 0, 0, 0};
+EXT MGVTBL vtbl_vec = {magic_getvec,
+ magic_setvec,
+ 0, 0, 0};
+EXT MGVTBL vtbl_pos = {magic_getpos,
+ magic_setpos,
+ 0, 0, 0};
+EXT MGVTBL vtbl_bm = {0, magic_setbm,
+ 0, 0, 0};
+EXT MGVTBL vtbl_fm = {0, magic_setfm,
+ 0, 0, 0};
+EXT MGVTBL vtbl_uvar = {magic_getuvar,
+ magic_setuvar,
+ 0, 0, 0};
+#ifdef USE_THREADS
+EXT MGVTBL vtbl_mutex = {0, 0, 0, 0, magic_mutexfree};
+#endif /* USE_THREADS */
+EXT MGVTBL vtbl_defelem = {magic_getdefelem,magic_setdefelem,
+ 0, 0, 0};
+
+EXT MGVTBL vtbl_regexp = {0,0,0,0, magic_freeregexp};
+
+#ifdef USE_LOCALE_COLLATE
+EXT MGVTBL vtbl_collxfrm = {0,
+ magic_setcollxfrm,
+ 0, 0, 0};
+#endif
+
+#ifdef OVERLOAD
+EXT MGVTBL vtbl_amagic = {0, magic_setamagic,
+ 0, 0, magic_setamagic};
+EXT MGVTBL vtbl_amagicelem = {0, magic_setamagic,
+ 0, 0, magic_setamagic};
+#endif /* OVERLOAD */
+
+#else /* !DOINIT */
+
+EXT MGVTBL vtbl_sv;
+EXT MGVTBL vtbl_env;
+EXT MGVTBL vtbl_envelem;
+EXT MGVTBL vtbl_sig;
+EXT MGVTBL vtbl_sigelem;
+EXT MGVTBL vtbl_pack;
+EXT MGVTBL vtbl_packelem;
+EXT MGVTBL vtbl_dbline;
+EXT MGVTBL vtbl_isa;
+EXT MGVTBL vtbl_isaelem;
+EXT MGVTBL vtbl_arylen;
+EXT MGVTBL vtbl_glob;
+EXT MGVTBL vtbl_mglob;
+EXT MGVTBL vtbl_nkeys;
+EXT MGVTBL vtbl_taint;
+EXT MGVTBL vtbl_substr;
+EXT MGVTBL vtbl_vec;
+EXT MGVTBL vtbl_pos;
+EXT MGVTBL vtbl_bm;
+EXT MGVTBL vtbl_fm;
+EXT MGVTBL vtbl_uvar;
+
+#ifdef USE_THREADS
+EXT MGVTBL vtbl_mutex;
+#endif /* USE_THREADS */
+
+EXT MGVTBL vtbl_defelem;
+EXT MGVTBL vtbl_regexp;
+
+#ifdef USE_LOCALE_COLLATE
+EXT MGVTBL vtbl_collxfrm;
+#endif
+
+#ifdef OVERLOAD
+EXT MGVTBL vtbl_amagic;
+EXT MGVTBL vtbl_amagicelem;
+#endif /* OVERLOAD */
+
+#endif /* !DOINIT */
+
+#ifdef OVERLOAD
+
+#define NofAMmeth 58
+#ifdef DOINIT
+EXTCONST char * AMG_names[NofAMmeth] = {
+ "fallback", "abs", /* "fallback" should be the first. */
+ "bool", "nomethod",
+ "\"\"", "0+",
+ "+", "+=",
+ "-", "-=",
+ "*", "*=",
+ "/", "/=",
+ "%", "%=",
+ "**", "**=",
+ "<<", "<<=",
+ ">>", ">>=",
+ "&", "&=",
+ "|", "|=",
+ "^", "^=",
+ "<", "<=",
+ ">", ">=",
+ "==", "!=",
+ "<=>", "cmp",
+ "lt", "le",
+ "gt", "ge",
+ "eq", "ne",
+ "!", "~",
+ "++", "--",
+ "atan2", "cos",
+ "sin", "exp",
+ "log", "sqrt",
+ "x", "x=",
+ ".", ".=",
+ "=", "neg"
+};
+#else
+EXTCONST char * AMG_names[NofAMmeth];
+#endif /* def INITAMAGIC */
+
+struct am_table {
+ long was_ok_sub;
+ long was_ok_am;
+ U32 flags;
+ CV* table[NofAMmeth];
+ long fallback;
+};
+struct am_table_short {
+ long was_ok_sub;
+ long was_ok_am;
+ U32 flags;
+};
+typedef struct am_table AMT;
+typedef struct am_table_short AMTS;
+
+#define AMGfallNEVER 1
+#define AMGfallNO 2
+#define AMGfallYES 3
+
+#define AMTf_AMAGIC 1
+#define AMT_AMAGIC(amt) ((amt)->flags & AMTf_AMAGIC)
+#define AMT_AMAGIC_on(amt) ((amt)->flags |= AMTf_AMAGIC)
+#define AMT_AMAGIC_off(amt) ((amt)->flags &= ~AMTf_AMAGIC)
+
+enum {
+ fallback_amg, abs_amg,
+ bool__amg, nomethod_amg,
+ string_amg, numer_amg,
+ add_amg, add_ass_amg,
+ subtr_amg, subtr_ass_amg,
+ mult_amg, mult_ass_amg,
+ div_amg, div_ass_amg,
+ modulo_amg, modulo_ass_amg,
+ pow_amg, pow_ass_amg,
+ lshift_amg, lshift_ass_amg,
+ rshift_amg, rshift_ass_amg,
+ band_amg, band_ass_amg,
+ bor_amg, bor_ass_amg,
+ bxor_amg, bxor_ass_amg,
+ lt_amg, le_amg,
+ gt_amg, ge_amg,
+ eq_amg, ne_amg,
+ ncmp_amg, scmp_amg,
+ slt_amg, sle_amg,
+ sgt_amg, sge_amg,
+ seq_amg, sne_amg,
+ not_amg, compl_amg,
+ inc_amg, dec_amg,
+ atan2_amg, cos_amg,
+ sin_amg, exp_amg,
+ log_amg, sqrt_amg,
+ repeat_amg, repeat_ass_amg,
+ concat_amg, concat_ass_amg,
+ copy_amg, neg_amg
+};
+
+/*
+ * some compilers like to redefine cos et alia as faster
+ * (and less accurate?) versions called F_cos et cetera (Quidquid
+ * latine dictum sit, altum viditur.) This trick collides with
+ * the Perl overloading (amg). The following #defines fool both.
+ */
+
+#ifdef _FASTMATH
+# ifdef atan2
+# define F_atan2_amg atan2_amg
+# endif
+# ifdef cos
+# define F_cos_amg cos_amg
+# endif
+# ifdef exp
+# define F_exp_amg exp_amg
+# endif
+# ifdef log
+# define F_log_amg log_amg
+# endif
+# ifdef pow
+# define F_pow_amg pow_amg
+# endif
+# ifdef sin
+# define F_sin_amg sin_amg
+# endif
+# ifdef sqrt
+# define F_sqrt_amg sqrt_amg
+# endif
+#endif /* _FASTMATH */
+
+#endif /* OVERLOAD */
+
+#define PERLDB_ALL 0x3f /* No _NONAME, _GOTO */
+#define PERLDBf_SUB 0x01 /* Debug sub enter/exit. */
+#define PERLDBf_LINE 0x02 /* Keep line #. */
+#define PERLDBf_NOOPT 0x04 /* Switch off optimizations. */
+#define PERLDBf_INTER 0x08 /* Preserve more data for
+ later inspections. */
+#define PERLDBf_SUBLINE 0x10 /* Keep subr source lines. */
+#define PERLDBf_SINGLE 0x20 /* Start with single-step on. */
+#define PERLDBf_NONAME 0x40 /* For _SUB: no name of the subr. */
+#define PERLDBf_GOTO 0x80 /* Report goto: call DB::goto. */
+
+#define PERLDB_SUB (PL_perldb && (PL_perldb & PERLDBf_SUB))
+#define PERLDB_LINE (PL_perldb && (PL_perldb & PERLDBf_LINE))
+#define PERLDB_NOOPT (PL_perldb && (PL_perldb & PERLDBf_NOOPT))
+#define PERLDB_INTER (PL_perldb && (PL_perldb & PERLDBf_INTER))
+#define PERLDB_SUBLINE (PL_perldb && (PL_perldb & PERLDBf_SUBLINE))
+#define PERLDB_SINGLE (PL_perldb && (PL_perldb & PERLDBf_SINGLE))
+#define PERLDB_SUB_NN (PL_perldb && (PL_perldb & (PERLDBf_NONAME)))
+#define PERLDB_GOTO (PL_perldb && (PL_perldb & PERLDBf_GOTO))
+
+
+#ifdef USE_LOCALE_NUMERIC
+
+#define SET_NUMERIC_STANDARD() \
+ STMT_START { \
+ if (! PL_numeric_standard) \
+ perl_set_numeric_standard(); \
+ } STMT_END
+
+#define SET_NUMERIC_LOCAL() \
+ STMT_START { \
+ if (! PL_numeric_local) \
+ perl_set_numeric_local(); \
+ } STMT_END
+
+#else /* !USE_LOCALE_NUMERIC */
+
+#define SET_NUMERIC_STANDARD() /**/
+#define SET_NUMERIC_LOCAL() /**/
+
+#endif /* !USE_LOCALE_NUMERIC */
+
+#if !defined(PERLIO_IS_STDIO) && defined(HASATTRIBUTE)
+/*
+ * Now we have __attribute__ out of the way
+ * Remap printf
+ */
+#define printf PerlIO_stdoutf
+#endif
+
+#ifndef PERL_SCRIPT_MODE
+#define PERL_SCRIPT_MODE "r"
+#endif
+
+/*
+ * nice_chunk and nice_chunk size need to be set
+ * and queried under the protection of sv_mutex
+ */
+#define offer_nice_chunk(chunk, chunk_size) do { \
+ LOCK_SV_MUTEX; \
+ if (!PL_nice_chunk) { \
+ PL_nice_chunk = (char*)(chunk); \
+ PL_nice_chunk_size = (chunk_size); \
+ } \
+ else { \
+ Safefree(chunk); \
+ } \
+ UNLOCK_SV_MUTEX; \
+ } while (0)
+
+#ifdef HAS_SEM
+# include <sys/ipc.h>
+# include <sys/sem.h>
+# ifndef HAS_UNION_SEMUN /* Provide the union semun. */
+ union semun {
+ int val;
+ struct semid_ds *buf;
+ unsigned short *array;
+ };
+# endif
+# ifdef USE_SEMCTL_SEMUN
+# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun)
+# else
+# ifdef USE_SEMCTL_SEMID_DS
+# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun.buf)
+# endif
+# endif
+# ifndef Semctl /* Place our bets on the semun horse. */
+# define Semctl(id, num, cmd, semun) semctl(id, num, cmd, semun)
+# endif
+#endif
+
+#endif /* Include guard */
diff --git a/contrib/perl5/perl_exp.SH b/contrib/perl5/perl_exp.SH
new file mode 100755
index 000000000000..b8b2907024cd
--- /dev/null
+++ b/contrib/perl5/perl_exp.SH
@@ -0,0 +1,113 @@
+#!/bin/sh
+#
+# Written: Nov 1994 Wayne Scott <wscott@ichips.intel.com>
+#
+# Updated: 1997-8 Jarkko Hietaniemi <jhi@iki.fi>
+#
+# Create the export list for perl.
+# Needed by AIX to do dynamic linking.
+#
+# This simple program relies on 'global.sym' and few other *.sym files
+# and the *var*.h files being up to date with all of the global
+# symbols that a dynamic link library might want to access.
+#
+# Most symbols have a Perl_ or PL_prefix because that's what embed.h
+# sticks in front of them.
+#
+# AIX requires the list of external symbols (variables or functions)
+# that are made available for another executable object file the import.
+# The list is called the export file and it is a simple text file.
+# The first line must be
+#!
+# That is, hash-bang, pound-shout, however you want to call it.
+# The remainder of the file are the names of the symbols, one per line.
+# The file is then given to the system loader (cc/xlc command line)
+# as -bE:export.file.
+
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+
+echo "Extracting perl.exp"
+
+rm -f perl.exp
+echo "#!" > perl.exp
+
+# No compat3 since 5.004_50.
+# perlio.sym will added below if needed.
+syms="global.sym interp.sym thread.sym"
+
+sed -n '/^[A-Za-z]/ s/^/Perl_/p' $syms >> perl.exp
+
+sed -n 's/^PERLVAR.*(G\([^[,]*\).*/PL_\1/p' perlvars.h >> perl.exp
+sed -n 's/^PERLVAR.*(I\([^[,]*\).*/PL_\1/p' intrpvar.h >> perl.exp
+sed -n 's/^PERLVAR.*(T\([^[,]*\).*/PL_\1/p' thrdvar.h >> perl.exp
+
+#
+# If we use the PerlIO abstraction layer, add its symbols
+#
+
+if [ $useperlio = "define" ]
+then
+ grep '^[A-Za-z]' perlio.sym >> perl.exp
+fi
+
+#
+# Extra globals not included above (including a few that might
+# not actually be defined, but there's no harm in that).
+#
+
+cat <<END >> perl.exp
+perl_init_i18nl10n
+perl_init_i18nl14n
+perl_new_collate
+perl_new_ctype
+perl_new_numeric
+perl_set_numeric_local
+perl_set_numeric_standard
+perl_alloc
+perl_construct
+perl_destruct
+perl_free
+perl_parse
+perl_run
+perl_get_sv
+perl_get_av
+perl_get_hv
+perl_get_cv
+perl_call_argv
+perl_call_pv
+perl_call_method
+perl_call_sv
+perl_eval_pv
+perl_eval_sv
+perl_require_pv
+Mymalloc
+Mycalloc
+Myremalloc
+Myfree
+Perl_malloc
+Perl_calloc
+Perl_realloc
+Perl_free
+END
+
+# The shebang line nicely sorts as the first one.
+sort -o perl.exp -u perl.exp
+
+# eof
diff --git a/contrib/perl5/perlio.c b/contrib/perl5/perlio.c
new file mode 100644
index 000000000000..314881e57eab
--- /dev/null
+++ b/contrib/perl5/perlio.c
@@ -0,0 +1,619 @@
+/* perlio.c
+ *
+ * Copyright (c) 1996, Nick Ing-Simmons
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#define VOIDUSED 1
+#include "config.h"
+
+#define PERLIO_NOT_STDIO 0
+#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
+#define PerlIO FILE
+#endif
+/*
+ * This file provides those parts of PerlIO abstraction
+ * which are not #defined in iperlsys.h.
+ * Which these are depends on various Configure #ifdef's
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef PERLIO_IS_STDIO
+
+void
+PerlIO_init(void)
+{
+ /* Does nothing (yet) except force this file to be included
+ in perl binary. That allows this file to force inclusion
+ of other functions that may be required by loadable
+ extensions e.g. for FileHandle::tmpfile
+ */
+}
+
+#undef PerlIO_tmpfile
+PerlIO *
+PerlIO_tmpfile(void)
+{
+ return tmpfile();
+}
+
+#else /* PERLIO_IS_STDIO */
+
+#ifdef USE_SFIO
+
+#undef HAS_FSETPOS
+#undef HAS_FGETPOS
+
+/* This section is just to make sure these functions
+ get pulled in from libsfio.a
+*/
+
+#undef PerlIO_tmpfile
+PerlIO *
+PerlIO_tmpfile()
+{
+ return sftmp(0);
+}
+
+void
+PerlIO_init()
+{
+ /* Force this file to be included in perl binary. Which allows
+ * this file to force inclusion of other functions that may be
+ * required by loadable extensions e.g. for FileHandle::tmpfile
+ */
+
+ /* Hack
+ * sfio does its own 'autoflush' on stdout in common cases.
+ * Flush results in a lot of lseek()s to regular files and
+ * lot of small writes to pipes.
+ */
+ sfset(sfstdout,SF_SHARE,0);
+}
+
+#else /* USE_SFIO */
+
+/* Implement all the PerlIO interface using stdio.
+ - this should be only file to include <stdio.h>
+*/
+
+#undef PerlIO_stderr
+PerlIO *
+PerlIO_stderr()
+{
+ return (PerlIO *) stderr;
+}
+
+#undef PerlIO_stdin
+PerlIO *
+PerlIO_stdin()
+{
+ return (PerlIO *) stdin;
+}
+
+#undef PerlIO_stdout
+PerlIO *
+PerlIO_stdout()
+{
+ return (PerlIO *) stdout;
+}
+
+#undef PerlIO_fast_gets
+int
+PerlIO_fast_gets(f)
+PerlIO *f;
+{
+#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+ return 1;
+#else
+ return 0;
+#endif
+}
+
+#undef PerlIO_has_cntptr
+int
+PerlIO_has_cntptr(f)
+PerlIO *f;
+{
+#if defined(USE_STDIO_PTR)
+ return 1;
+#else
+ return 0;
+#endif
+}
+
+#undef PerlIO_canset_cnt
+int
+PerlIO_canset_cnt(f)
+PerlIO *f;
+{
+#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
+ return 1;
+#else
+ return 0;
+#endif
+}
+
+#undef PerlIO_set_cnt
+void
+PerlIO_set_cnt(f,cnt)
+PerlIO *f;
+int cnt;
+{
+ if (cnt < -1)
+ warn("Setting cnt to %d\n",cnt);
+#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
+ FILE_cnt(f) = cnt;
+#else
+ croak("Cannot set 'cnt' of FILE * on this system");
+#endif
+}
+
+#undef PerlIO_set_ptrcnt
+void
+PerlIO_set_ptrcnt(f,ptr,cnt)
+PerlIO *f;
+STDCHAR *ptr;
+int cnt;
+{
+#ifdef FILE_bufsiz
+ STDCHAR *e = FILE_base(f) + FILE_bufsiz(f);
+ int ec = e - ptr;
+ if (ptr > e + 1)
+ warn("Setting ptr %p > end+1 %p\n", ptr, e + 1);
+ if (cnt != ec)
+ warn("Setting cnt to %d, ptr implies %d\n",cnt,ec);
+#endif
+#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE)
+ FILE_ptr(f) = ptr;
+#else
+ croak("Cannot set 'ptr' of FILE * on this system");
+#endif
+#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
+ FILE_cnt(f) = cnt;
+#else
+ croak("Cannot set 'cnt' of FILE * on this system");
+#endif
+}
+
+#undef PerlIO_get_cnt
+int
+PerlIO_get_cnt(f)
+PerlIO *f;
+{
+#ifdef FILE_cnt
+ return FILE_cnt(f);
+#else
+ croak("Cannot get 'cnt' of FILE * on this system");
+ return -1;
+#endif
+}
+
+#undef PerlIO_get_bufsiz
+int
+PerlIO_get_bufsiz(f)
+PerlIO *f;
+{
+#ifdef FILE_bufsiz
+ return FILE_bufsiz(f);
+#else
+ croak("Cannot get 'bufsiz' of FILE * on this system");
+ return -1;
+#endif
+}
+
+#undef PerlIO_get_ptr
+STDCHAR *
+PerlIO_get_ptr(f)
+PerlIO *f;
+{
+#ifdef FILE_ptr
+ return FILE_ptr(f);
+#else
+ croak("Cannot get 'ptr' of FILE * on this system");
+ return NULL;
+#endif
+}
+
+#undef PerlIO_get_base
+STDCHAR *
+PerlIO_get_base(f)
+PerlIO *f;
+{
+#ifdef FILE_base
+ return FILE_base(f);
+#else
+ croak("Cannot get 'base' of FILE * on this system");
+ return NULL;
+#endif
+}
+
+#undef PerlIO_has_base
+int
+PerlIO_has_base(f)
+PerlIO *f;
+{
+#ifdef FILE_base
+ return 1;
+#else
+ return 0;
+#endif
+}
+
+#undef PerlIO_puts
+int
+PerlIO_puts(f,s)
+PerlIO *f;
+const char *s;
+{
+ return fputs(s,f);
+}
+
+#undef PerlIO_open
+PerlIO *
+PerlIO_open(path,mode)
+const char *path;
+const char *mode;
+{
+ return fopen(path,mode);
+}
+
+#undef PerlIO_fdopen
+PerlIO *
+PerlIO_fdopen(fd,mode)
+int fd;
+const char *mode;
+{
+ return fdopen(fd,mode);
+}
+
+#undef PerlIO_reopen
+PerlIO *
+PerlIO_reopen(name, mode, f)
+const char *name;
+const char *mode;
+PerlIO *f;
+{
+ return freopen(name,mode,f);
+}
+
+#undef PerlIO_close
+int
+PerlIO_close(f)
+PerlIO *f;
+{
+ return fclose(f);
+}
+
+#undef PerlIO_eof
+int
+PerlIO_eof(f)
+PerlIO *f;
+{
+ return feof(f);
+}
+
+#undef PerlIO_getname
+char *
+PerlIO_getname(f,buf)
+PerlIO *f;
+char *buf;
+{
+#ifdef VMS
+ return fgetname(f,buf);
+#else
+ croak("Don't know how to get file name");
+ return NULL;
+#endif
+}
+
+#undef PerlIO_getc
+int
+PerlIO_getc(f)
+PerlIO *f;
+{
+ return fgetc(f);
+}
+
+#undef PerlIO_error
+int
+PerlIO_error(f)
+PerlIO *f;
+{
+ return ferror(f);
+}
+
+#undef PerlIO_clearerr
+void
+PerlIO_clearerr(f)
+PerlIO *f;
+{
+ clearerr(f);
+}
+
+#undef PerlIO_flush
+int
+PerlIO_flush(f)
+PerlIO *f;
+{
+ return Fflush(f);
+}
+
+#undef PerlIO_fileno
+int
+PerlIO_fileno(f)
+PerlIO *f;
+{
+ return fileno(f);
+}
+
+#undef PerlIO_setlinebuf
+void
+PerlIO_setlinebuf(f)
+PerlIO *f;
+{
+#ifdef HAS_SETLINEBUF
+ setlinebuf(f);
+#else
+# ifdef __BORLANDC__ /* Borland doesn't like NULL size for _IOLBF */
+ setvbuf(f, Nullch, _IOLBF, BUFSIZ);
+# else
+ setvbuf(f, Nullch, _IOLBF, 0);
+# endif
+#endif
+}
+
+#undef PerlIO_putc
+int
+PerlIO_putc(f,ch)
+PerlIO *f;
+int ch;
+{
+ return putc(ch,f);
+}
+
+#undef PerlIO_ungetc
+int
+PerlIO_ungetc(f,ch)
+PerlIO *f;
+int ch;
+{
+ return ungetc(ch,f);
+}
+
+#undef PerlIO_read
+SSize_t
+PerlIO_read(f,buf,count)
+PerlIO *f;
+void *buf;
+Size_t count;
+{
+ return fread(buf,1,count,f);
+}
+
+#undef PerlIO_write
+SSize_t
+PerlIO_write(f,buf,count)
+PerlIO *f;
+const void *buf;
+Size_t count;
+{
+ return fwrite1(buf,1,count,f);
+}
+
+#undef PerlIO_vprintf
+int
+PerlIO_vprintf(f,fmt,ap)
+PerlIO *f;
+const char *fmt;
+va_list ap;
+{
+ return vfprintf(f,fmt,ap);
+}
+
+
+#undef PerlIO_tell
+long
+PerlIO_tell(f)
+PerlIO *f;
+{
+ return ftell(f);
+}
+
+#undef PerlIO_seek
+int
+PerlIO_seek(f,offset,whence)
+PerlIO *f;
+off_t offset;
+int whence;
+{
+ return fseek(f,offset,whence);
+}
+
+#undef PerlIO_rewind
+void
+PerlIO_rewind(f)
+PerlIO *f;
+{
+ rewind(f);
+}
+
+#undef PerlIO_printf
+int
+PerlIO_printf(PerlIO *f,const char *fmt,...)
+{
+ va_list ap;
+ int result;
+ va_start(ap,fmt);
+ result = vfprintf(f,fmt,ap);
+ va_end(ap);
+ return result;
+}
+
+#undef PerlIO_stdoutf
+int
+PerlIO_stdoutf(const char *fmt,...)
+{
+ va_list ap;
+ int result;
+ va_start(ap,fmt);
+ result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap);
+ va_end(ap);
+ return result;
+}
+
+#undef PerlIO_tmpfile
+PerlIO *
+PerlIO_tmpfile()
+{
+ return tmpfile();
+}
+
+#undef PerlIO_importFILE
+PerlIO *
+PerlIO_importFILE(f,fl)
+FILE *f;
+int fl;
+{
+ return f;
+}
+
+#undef PerlIO_exportFILE
+FILE *
+PerlIO_exportFILE(f,fl)
+PerlIO *f;
+int fl;
+{
+ return f;
+}
+
+#undef PerlIO_findFILE
+FILE *
+PerlIO_findFILE(f)
+PerlIO *f;
+{
+ return f;
+}
+
+#undef PerlIO_releaseFILE
+void
+PerlIO_releaseFILE(p,f)
+PerlIO *p;
+FILE *f;
+{
+}
+
+void
+PerlIO_init()
+{
+ /* Does nothing (yet) except force this file to be included
+ in perl binary. That allows this file to force inclusion
+ of other functions that may be required by loadable
+ extensions e.g. for FileHandle::tmpfile
+ */
+}
+
+#endif /* USE_SFIO */
+#endif /* PERLIO_IS_STDIO */
+
+#ifndef HAS_FSETPOS
+#undef PerlIO_setpos
+int
+PerlIO_setpos(f,pos)
+PerlIO *f;
+const Fpos_t *pos;
+{
+ return PerlIO_seek(f,*pos,0);
+}
+#else
+#ifndef PERLIO_IS_STDIO
+#undef PerlIO_setpos
+int
+PerlIO_setpos(f,pos)
+PerlIO *f;
+const Fpos_t *pos;
+{
+ return fsetpos(f, pos);
+}
+#endif
+#endif
+
+#ifndef HAS_FGETPOS
+#undef PerlIO_getpos
+int
+PerlIO_getpos(f,pos)
+PerlIO *f;
+Fpos_t *pos;
+{
+ *pos = PerlIO_tell(f);
+ return 0;
+}
+#else
+#ifndef PERLIO_IS_STDIO
+#undef PerlIO_getpos
+int
+PerlIO_getpos(f,pos)
+PerlIO *f;
+Fpos_t *pos;
+{
+ return fgetpos(f, pos);
+}
+#endif
+#endif
+
+#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF)
+
+int
+vprintf(pat, args)
+char *pat, *args;
+{
+ _doprnt(pat, args, stdout);
+ return 0; /* wrong, but perl doesn't use the return value */
+}
+
+int
+vfprintf(fd, pat, args)
+FILE *fd;
+char *pat, *args;
+{
+ _doprnt(pat, args, fd);
+ return 0; /* wrong, but perl doesn't use the return value */
+}
+
+#endif
+
+#ifndef PerlIO_vsprintf
+int
+PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
+{
+ int val = vsprintf(s, fmt, ap);
+ if (n >= 0)
+ {
+ if (strlen(s) >= (STRLEN)n)
+ {
+ PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n");
+ my_exit(1);
+ }
+ }
+ return val;
+}
+#endif
+
+#ifndef PerlIO_sprintf
+int
+PerlIO_sprintf(char *s, int n, const char *fmt,...)
+{
+ va_list ap;
+ int result;
+ va_start(ap,fmt);
+ result = PerlIO_vsprintf(s, n, fmt, ap);
+ va_end(ap);
+ return result;
+}
+#endif
+
diff --git a/contrib/perl5/perlio.h b/contrib/perl5/perlio.h
new file mode 100644
index 000000000000..e699a3eafed0
--- /dev/null
+++ b/contrib/perl5/perlio.h
@@ -0,0 +1 @@
+#include "iperlsys.h"
diff --git a/contrib/perl5/perlio.sym b/contrib/perl5/perlio.sym
new file mode 100644
index 000000000000..d7a345c4ccba
--- /dev/null
+++ b/contrib/perl5/perlio.sym
@@ -0,0 +1,49 @@
+# Symbols which arise as part of the PerlIO abstraction
+
+PerlIO_stderr
+PerlIO_stderr
+PerlIO_stdin
+PerlIO_stdout
+PerlIO_fast_gets
+PerlIO_has_cntptr
+PerlIO_canset_cnt
+PerlIO_set_cnt
+PerlIO_set_ptrcnt
+PerlIO_get_cnt
+PerlIO_get_bufsiz
+PerlIO_get_ptr
+PerlIO_get_base
+PerlIO_has_base
+PerlIO_puts
+PerlIO_open
+PerlIO_fdopen
+PerlIO_reopen
+PerlIO_close
+PerlIO_eof
+PerlIO_getname
+PerlIO_getc
+PerlIO_error
+PerlIO_clearerr
+PerlIO_flush
+PerlIO_fileno
+PerlIO_setlinebuf
+PerlIO_putc
+PerlIO_ungetc
+PerlIO_read
+PerlIO_write
+PerlIO_vprintf
+PerlIO_tell
+PerlIO_seek
+PerlIO_rewind
+PerlIO_printf
+PerlIO_stdoutf
+PerlIO_tmpfile
+PerlIO_importFILE
+PerlIO_exportFILE
+PerlIO_findFILE
+PerlIO_releaseFILE
+PerlIO_init
+PerlIO_setpos
+PerlIO_getpos
+PerlIO_vsprintf
+PerlIO_sprintf
diff --git a/contrib/perl5/perlsdio.h b/contrib/perl5/perlsdio.h
new file mode 100644
index 000000000000..efc52e1cd42a
--- /dev/null
+++ b/contrib/perl5/perlsdio.h
@@ -0,0 +1,322 @@
+/*
+ * Although we may not want stdio to be used including <stdio.h> here
+ * avoids issues where stdio.h has strange side effects
+ */
+#include <stdio.h>
+
+#ifdef PERLIO_IS_STDIO
+/*
+ * Make this as close to original stdio as possible.
+ */
+#define PerlIO FILE
+#define PerlIO_stderr() stderr
+#define PerlIO_stdout() stdout
+#define PerlIO_stdin() stdin
+
+#define PerlIO_printf fprintf
+#define PerlIO_stdoutf printf
+#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a)
+#define PerlIO_write(f,buf,count) fwrite1(buf,1,count,f)
+#define PerlIO_open fopen
+#define PerlIO_fdopen fdopen
+#define PerlIO_reopen freopen
+#define PerlIO_close(f) fclose(f)
+#define PerlIO_puts(f,s) fputs(s,f)
+#define PerlIO_putc(f,c) fputc(c,f)
+#if defined(VMS)
+# if defined(__DECC)
+ /* Unusual definition of ungetc() here to accomodate fast_sv_gets()'
+ * belief that it can mix getc/ungetc with reads from stdio buffer */
+ int decc$ungetc(int __c, FILE *__stream);
+# define PerlIO_ungetc(f,c) ((c) == EOF ? EOF : \
+ ((*(f) && !((*(f))->_flag & _IONBF) && \
+ ((*(f))->_ptr > (*(f))->_base)) ? \
+ ((*(f))->_cnt++, *(--(*(f))->_ptr) = (c)) : decc$ungetc(c,f)))
+# else
+# define PerlIO_ungetc(f,c) ungetc(c,f)
+# endif
+ /* Work around bug in DECCRTL/AXP (DECC v5.x) and some versions of old
+ * VAXCRTL which causes read from a pipe after EOF has been returned
+ * once to hang.
+ */
+# define PerlIO_getc(f) \
+ (feof(f) ? EOF : getc(f))
+# define PerlIO_read(f,buf,count) \
+ (feof(f) ? 0 : (SSize_t)fread(buf,1,count,f))
+#else
+# define PerlIO_ungetc(f,c) ungetc(c,f)
+# define PerlIO_getc(f) getc(f)
+# define PerlIO_read(f,buf,count) (SSize_t)fread(buf,1,count,f)
+#endif
+#define PerlIO_eof(f) feof(f)
+#define PerlIO_getname(f,b) fgetname(f,b)
+#define PerlIO_error(f) ferror(f)
+#define PerlIO_fileno(f) fileno(f)
+#define PerlIO_clearerr(f) clearerr(f)
+#define PerlIO_flush(f) Fflush(f)
+#define PerlIO_tell(f) ftell(f)
+#if defined(VMS) && !defined(__DECC)
+ /* Old VAXC RTL doesn't reset EOF on seek; Perl folk seem to expect this */
+# define PerlIO_seek(f,o,w) (((f) && (*f) && ((*f)->_flag &= ~_IOEOF)),fseek(f,o,w))
+#else
+# define PerlIO_seek(f,o,w) fseek(f,o,w)
+#endif
+#ifdef HAS_FGETPOS
+#define PerlIO_getpos(f,p) fgetpos(f,p)
+#endif
+#ifdef HAS_FSETPOS
+#define PerlIO_setpos(f,p) fsetpos(f,p)
+#endif
+
+#define PerlIO_rewind(f) rewind(f)
+#define PerlIO_tmpfile() tmpfile()
+
+#define PerlIO_importFILE(f,fl) (f)
+#define PerlIO_exportFILE(f,fl) (f)
+#define PerlIO_findFILE(f) (f)
+#define PerlIO_releaseFILE(p,f) ((void) 0)
+
+#ifdef HAS_SETLINEBUF
+#define PerlIO_setlinebuf(f) setlinebuf(f);
+#else
+#define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0);
+#endif
+
+/* Now our interface to Configure's FILE_xxx macros */
+
+#ifdef USE_STDIO_PTR
+#define PerlIO_has_cntptr(f) 1
+#define PerlIO_get_ptr(f) FILE_ptr(f)
+#define PerlIO_get_cnt(f) FILE_cnt(f)
+
+#ifdef STDIO_CNT_LVALUE
+#define PerlIO_canset_cnt(f) 1
+#ifdef STDIO_PTR_LVALUE
+#define PerlIO_fast_gets(f) 1
+#endif
+#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c))
+#else
+#define PerlIO_canset_cnt(f) 0
+#define PerlIO_set_cnt(f,c) abort()
+#endif
+
+#ifdef STDIO_PTR_LVALUE
+#define PerlIO_set_ptrcnt(f,p,c) (FILE_ptr(f) = (p), PerlIO_set_cnt(f,c))
+#else
+#define PerlIO_set_ptrcnt(f,p,c) abort()
+#endif
+
+#else /* USE_STDIO_PTR */
+
+#define PerlIO_has_cntptr(f) 0
+#define PerlIO_canset_cnt(f) 0
+#define PerlIO_get_cnt(f) (abort(),0)
+#define PerlIO_get_ptr(f) (abort(),(void *)0)
+#define PerlIO_set_cnt(f,c) abort()
+#define PerlIO_set_ptrcnt(f,p,c) abort()
+
+#endif /* USE_STDIO_PTR */
+
+#ifndef PerlIO_fast_gets
+#define PerlIO_fast_gets(f) 0
+#endif
+
+
+#ifdef FILE_base
+#define PerlIO_has_base(f) 1
+#define PerlIO_get_base(f) FILE_base(f)
+#define PerlIO_get_bufsiz(f) FILE_bufsiz(f)
+#else
+#define PerlIO_has_base(f) 0
+#define PerlIO_get_base(f) (abort(),(void *)0)
+#define PerlIO_get_bufsiz(f) (abort(),0)
+#endif
+#else /* PERLIO_IS_STDIO */
+#ifdef PERL_CORE
+#ifndef PERLIO_NOT_STDIO
+#define PERLIO_NOT_STDIO 1
+#endif
+#endif
+#ifdef PERLIO_NOT_STDIO
+#if PERLIO_NOT_STDIO
+/*
+ * Strong denial of stdio - make all stdio calls (we can think of) errors
+ */
+#include "nostdio.h"
+#undef fprintf
+#undef tmpfile
+#undef fclose
+#undef fopen
+#undef vfprintf
+#undef fgetc
+#undef fputc
+#undef fputs
+#undef ungetc
+#undef fread
+#undef fwrite
+#undef fgetpos
+#undef fseek
+#undef fsetpos
+#undef ftell
+#undef rewind
+#undef fdopen
+#undef popen
+#undef pclose
+#undef getw
+#undef putw
+#undef freopen
+#undef setbuf
+#undef setvbuf
+#undef fscanf
+#undef fgets
+#undef getc_unlocked
+#undef putc_unlocked
+#define fprintf _CANNOT _fprintf_
+#define stdin _CANNOT _stdin_
+#define stdout _CANNOT _stdout_
+#define stderr _CANNOT _stderr_
+#define tmpfile() _CANNOT _tmpfile_
+#define fclose(f) _CANNOT _fclose_
+#define fflush(f) _CANNOT _fflush_
+#define fopen(p,m) _CANNOT _fopen_
+#define freopen(p,m,f) _CANNOT _freopen_
+#define setbuf(f,b) _CANNOT _setbuf_
+#define setvbuf(f,b,x,s) _CANNOT _setvbuf_
+#define fscanf _CANNOT _fscanf_
+#define vfprintf(f,fmt,a) _CANNOT _vfprintf_
+#define fgetc(f) _CANNOT _fgetc_
+#define fgets(s,n,f) _CANNOT _fgets_
+#define fputc(c,f) _CANNOT _fputc_
+#define fputs(s,f) _CANNOT _fputs_
+#define getc(f) _CANNOT _getc_
+#define putc(c,f) _CANNOT _putc_
+#define ungetc(c,f) _CANNOT _ungetc_
+#define fread(b,s,c,f) _CANNOT _fread_
+#define fwrite(b,s,c,f) _CANNOT _fwrite_
+#define fgetpos(f,p) _CANNOT _fgetpos_
+#define fseek(f,o,w) _CANNOT _fseek_
+#define fsetpos(f,p) _CANNOT _fsetpos_
+#define ftell(f) _CANNOT _ftell_
+#define rewind(f) _CANNOT _rewind_
+#define clearerr(f) _CANNOT _clearerr_
+#define feof(f) _CANNOT _feof_
+#define ferror(f) _CANNOT _ferror_
+#define __filbuf(f) _CANNOT __filbuf_
+#define __flsbuf(c,f) _CANNOT __flsbuf_
+#define _filbuf(f) _CANNOT _filbuf_
+#define _flsbuf(c,f) _CANNOT _flsbuf_
+#define fdopen(fd,p) _CANNOT _fdopen_
+#define fileno(f) _CANNOT _fileno_
+#define flockfile(f) _CANNOT _flockfile_
+#define ftrylockfile(f) _CANNOT _ftrylockfile_
+#define funlockfile(f) _CANNOT _funlockfile_
+#define getc_unlocked(f) _CANNOT _getc_unlocked_
+#define putc_unlocked(c,f) _CANNOT _putc_unlocked_
+#define popen(c,m) _CANNOT _popen_
+#define getw(f) _CANNOT _getw_
+#define putw(v,f) _CANNOT _putw_
+#define pclose(f) _CANNOT _pclose_
+
+#else /* if PERLIO_NOT_STDIO */
+/*
+ * PERLIO_NOT_STDIO defined as 0
+ * Declares that both PerlIO and stdio can be used
+ */
+#endif /* if PERLIO_NOT_STDIO */
+#else /* ifdef PERLIO_NOT_STDIO */
+/*
+ * PERLIO_NOT_STDIO not defined
+ * This is "source level" stdio compatibility mode.
+ */
+#include "nostdio.h"
+#undef FILE
+#define FILE PerlIO
+#undef fprintf
+#undef tmpfile
+#undef fclose
+#undef fopen
+#undef vfprintf
+#undef fgetc
+#undef getc_unlocked
+#undef fputc
+#undef putc_unlocked
+#undef fputs
+#undef ungetc
+#undef fread
+#undef fwrite
+#undef fgetpos
+#undef fseek
+#undef fsetpos
+#undef ftell
+#undef rewind
+#undef fdopen
+#undef popen
+#undef pclose
+#undef getw
+#undef putw
+#undef freopen
+#undef setbuf
+#undef setvbuf
+#undef fscanf
+#undef fgets
+#define fprintf PerlIO_printf
+#define stdin PerlIO_stdin()
+#define stdout PerlIO_stdout()
+#define stderr PerlIO_stderr()
+#define tmpfile() PerlIO_tmpfile()
+#define fclose(f) PerlIO_close(f)
+#define fflush(f) PerlIO_flush(f)
+#define fopen(p,m) PerlIO_open(p,m)
+#define vfprintf(f,fmt,a) PerlIO_vprintf(f,fmt,a)
+#define fgetc(f) PerlIO_getc(f)
+#define fputc(c,f) PerlIO_putc(f,c)
+#define fputs(s,f) PerlIO_puts(f,s)
+#define getc(f) PerlIO_getc(f)
+#ifdef getc_unlocked
+#undef getc_unlocked
+#endif
+#define getc_unlocked(f) PerlIO_getc(f)
+#define putc(c,f) PerlIO_putc(f,c)
+#ifdef putc_unlocked
+#undef putc_unlocked
+#endif
+#define putc_unlocked(c,f) PerlIO_putc(c,f)
+#define ungetc(c,f) PerlIO_ungetc(f,c)
+#if 0
+/* return values of read/write need work */
+#define fread(b,s,c,f) PerlIO_read(f,b,(s*c))
+#define fwrite(b,s,c,f) PerlIO_write(f,b,(s*c))
+#else
+#define fread(b,s,c,f) _CANNOT fread
+#define fwrite(b,s,c,f) _CANNOT fwrite
+#endif
+#define fgetpos(f,p) PerlIO_getpos(f,p)
+#define fseek(f,o,w) PerlIO_seek(f,o,w)
+#define fsetpos(f,p) PerlIO_setpos(f,p)
+#define ftell(f) PerlIO_tell(f)
+#define rewind(f) PerlIO_rewind(f)
+#define clearerr(f) PerlIO_clearerr(f)
+#define feof(f) PerlIO_eof(f)
+#define ferror(f) PerlIO_error(f)
+#define fdopen(fd,p) PerlIO_fdopen(fd,p)
+#define fileno(f) PerlIO_fileno(f)
+#define popen(c,m) my_popen(c,m)
+#define pclose(f) my_pclose(f)
+
+#define __filbuf(f) _CANNOT __filbuf_
+#define _filbuf(f) _CANNOT _filbuf_
+#define __flsbuf(c,f) _CANNOT __flsbuf_
+#define _flsbuf(c,f) _CANNOT _flsbuf_
+#define getw(f) _CANNOT _getw_
+#define putw(v,f) _CANNOT _putw_
+#define flockfile(f) _CANNOT _flockfile_
+#define ftrylockfile(f) _CANNOT _ftrylockfile_
+#define funlockfile(f) _CANNOT _funlockfile_
+#define freopen(p,m,f) _CANNOT _freopen_
+#define setbuf(f,b) _CANNOT _setbuf_
+#define setvbuf(f,b,x,s) _CANNOT _setvbuf_
+#define fscanf _CANNOT _fscanf_
+#define fgets(s,n,f) _CANNOT _fgets_
+
+#endif /* ifdef PERLIO_NOT_STDIO */
+#endif /* PERLIO_IS_STDIO */
diff --git a/contrib/perl5/perlsfio.h b/contrib/perl5/perlsfio.h
new file mode 100644
index 000000000000..8c9387fbd0c9
--- /dev/null
+++ b/contrib/perl5/perlsfio.h
@@ -0,0 +1,58 @@
+/* The next #ifdef should be redundant if Configure behaves ... */
+#ifdef I_SFIO
+#include <sfio.h>
+#endif
+
+extern Sfio_t* _stdopen _ARG_((int, const char*));
+extern int _stdprintf _ARG_((const char*, ...));
+
+#define PerlIO Sfio_t
+#define PerlIO_stderr() sfstderr
+#define PerlIO_stdout() sfstdout
+#define PerlIO_stdin() sfstdin
+
+#define PerlIO_printf sfprintf
+#define PerlIO_stdoutf _stdprintf
+#define PerlIO_vprintf(f,fmt,a) sfvprintf(f,fmt,a)
+#define PerlIO_read(f,buf,count) sfread(f,buf,count)
+#define PerlIO_write(f,buf,count) sfwrite(f,buf,count)
+#define PerlIO_open(path,mode) sfopen(NULL,path,mode)
+#define PerlIO_fdopen(fd,mode) _stdopen(fd,mode)
+#define PerlIO_close(f) sfclose(f)
+#define PerlIO_puts(f,s) sfputr(f,s,-1)
+#define PerlIO_putc(f,c) sfputc(f,c)
+#define PerlIO_ungetc(f,c) sfungetc(f,c)
+#define PerlIO_sprintf sfsprintf
+#define PerlIO_getc(f) sfgetc(f)
+#define PerlIO_eof(f) sfeof(f)
+#define PerlIO_error(f) sferror(f)
+#define PerlIO_fileno(f) sffileno(f)
+#define PerlIO_clearerr(f) sfclrerr(f)
+#define PerlIO_flush(f) sfsync(f)
+#define PerlIO_tell(f) sftell(f)
+#define PerlIO_seek(f,o,w) sfseek(f,o,w)
+#define PerlIO_rewind(f) (void) sfseek((f),0L,0)
+#define PerlIO_tmpfile() sftmp(0)
+
+#define PerlIO_importFILE(f,fl) croak("Import from FILE * unimplemeted")
+#define PerlIO_exportFILE(f,fl) croak("Export to FILE * unimplemeted")
+#define PerlIO_findFILE(f) NULL
+#define PerlIO_releaseFILE(p,f) croak("Release of FILE * unimplemeted")
+
+#define PerlIO_setlinebuf(f) sfset(f,SF_LINE,1)
+
+/* Now our interface to equivalent of Configure's FILE_xxx macros */
+
+#define PerlIO_has_cntptr(f) 1
+#define PerlIO_get_ptr(f) ((f)->next)
+#define PerlIO_get_cnt(f) ((f)->endr - (f)->next)
+#define PerlIO_canset_cnt(f) 1
+#define PerlIO_fast_gets(f) 1
+#define PerlIO_set_ptrcnt(f,p,c) ((f)->next = (p))
+#define PerlIO_set_cnt(f,c) 1
+
+#define PerlIO_has_base(f) 1
+#define PerlIO_get_base(f) ((f)->data)
+#define PerlIO_get_bufsiz(f) ((f)->endr - (f)->data)
+
+
diff --git a/contrib/perl5/perlsh b/contrib/perl5/perlsh
new file mode 100644
index 000000000000..63662d6c6a15
--- /dev/null
+++ b/contrib/perl5/perlsh
@@ -0,0 +1,15 @@
+#!/usr/bin/perl
+
+# Poor man's perl shell.
+
+# Simply type two carriage returns every time you want to evaluate.
+# Note that it must be a complete perl statement--don't type double
+# carriage return in the middle of a loop.
+
+$/ = "\n\n"; # set paragraph mode
+$SHlinesep = "\n";
+while (defined($SHcmd = <>)) {
+ $/ = $SHlinesep;
+ eval $SHcmd; print $@ || "\n";
+ $SHlinesep = $/; $/ = '';
+}
diff --git a/contrib/perl5/perlvars.h b/contrib/perl5/perlvars.h
new file mode 100644
index 000000000000..4e9d3b86896a
--- /dev/null
+++ b/contrib/perl5/perlvars.h
@@ -0,0 +1,180 @@
+/****************/
+/* Truly global */
+/****************/
+
+/* Don't forget to re-run embed.pl to propagate changes! */
+
+/* This file describes the "global" variables used by perl
+ * This used to be in perl.h directly but we want to abstract out into
+ * distinct files which are per-thread, per-interpreter or really global,
+ * and how they're initialized.
+ *
+ * The 'G' prefix is only needed for vars that need appropriate #defines
+ * generated when built with or without EMBED. It is also used to generate
+ * the appropriate export list for win32.
+ *
+ * Avoid build-specific #ifdefs here, like DEBUGGING. That way,
+ * we can keep binary compatibility of the curinterp structure */
+
+
+/* global state */
+PERLVAR(Gcurinterp, PerlInterpreter *)
+ /* currently running interpreter */
+#ifdef USE_THREADS
+PERLVAR(Gthr_key, perl_key) /* For per-thread struct perl_thread* */
+PERLVAR(Gsv_mutex, perl_mutex) /* Mutex for allocating SVs in sv.c */
+PERLVAR(Gmalloc_mutex, perl_mutex) /* Mutex for malloc */
+PERLVAR(Geval_mutex, perl_mutex) /* Mutex for doeval */
+PERLVAR(Geval_cond, perl_cond) /* Condition variable for doeval */
+PERLVAR(Geval_owner, struct perl_thread *)
+ /* Owner thread for doeval */
+PERLVAR(Gnthreads, int) /* Number of threads currently */
+PERLVAR(Gthreads_mutex, perl_mutex) /* Mutex for nthreads and thread list */
+PERLVAR(Gnthreads_cond, perl_cond) /* Condition variable for nthreads */
+PERLVAR(Gsvref_mutex, perl_mutex) /* Mutex for SvREFCNT_{inc,dec} */
+PERLVARI(Gthreadsv_names,char *, THREADSV_NAMES)
+#ifdef FAKE_THREADS
+PERLVAR(Gcurthr, struct perl_thread *)
+ /* Currently executing (fake) thread */
+#endif
+#endif /* USE_THREADS */
+
+PERLVAR(Gninterps, int) /* number of active interpreters */
+
+PERLVAR(Guid, int) /* current real user id */
+PERLVAR(Geuid, int) /* current effective user id */
+PERLVAR(Ggid, int) /* current real group id */
+PERLVAR(Gegid, int) /* current effective group id */
+PERLVAR(Gnomemok, bool) /* let malloc context handle nomem */
+PERLVAR(Gan, U32) /* malloc sequence number */
+PERLVAR(Gcop_seqmax, U32) /* statement sequence number */
+PERLVAR(Gop_seqmax, U16) /* op sequence number */
+PERLVAR(Gevalseq, U32) /* eval sequence number */
+PERLVAR(Gorigenviron, char **)
+PERLVAR(Gorigalen, U32)
+PERLVAR(Gpidstatus, HV *) /* pid-to-status mappings for waitpid */
+PERLVARI(Gmaxo, int, MAXO) /* maximum number of ops */
+PERLVAR(Gosname, char *) /* operating system */
+PERLVARI(Gsh_path, char *, SH_PATH)/* full path of shell */
+PERLVAR(Gsighandlerp, Sighandler_t)
+
+PERLVAR(Gxiv_arenaroot, XPV*) /* list of allocated xiv areas */
+PERLVAR(Gxiv_root, IV *) /* free xiv list--shared by interpreters */
+PERLVAR(Gxnv_root, double *) /* free xnv list--shared by interpreters */
+PERLVAR(Gxrv_root, XRV *) /* free xrv list--shared by interpreters */
+PERLVAR(Gxpv_root, XPV *) /* free xpv list--shared by interpreters */
+PERLVAR(Ghe_root, HE *) /* free he list--shared by interpreters */
+PERLVAR(Gnice_chunk, char *) /* a nice chunk of memory to reuse */
+PERLVAR(Gnice_chunk_size, U32) /* how nice the chunk of memory is */
+
+#ifdef PERL_OBJECT
+PERLVARI(Grunops, runops_proc_t, FUNC_NAME_TO_PTR(RUNOPS_DEFAULT))
+#else
+PERLVARI(Grunops, runops_proc_t *, RUNOPS_DEFAULT)
+#endif
+
+PERLVAR(Gtokenbuf[256], char)
+PERLVAR(Gna, STRLEN) /* for use in SvPV when length is
+ Not Applicable */
+
+PERLVAR(Gsv_undef, SV)
+PERLVAR(Gsv_no, SV)
+PERLVAR(Gsv_yes, SV)
+#ifdef CSH
+PERLVARI(Gcshname, char *, CSH)
+PERLVAR(Gcshlen, I32)
+#endif
+
+PERLVAR(Glex_state, U32) /* next token is determined */
+PERLVAR(Glex_defer, U32) /* state after determined token */
+PERLVAR(Glex_expect, expectation) /* expect after determined token */
+PERLVAR(Glex_brackets, I32) /* bracket count */
+PERLVAR(Glex_formbrack, I32) /* bracket count at outer format level */
+PERLVAR(Glex_fakebrack, I32) /* outer bracket is mere delimiter */
+PERLVAR(Glex_casemods, I32) /* casemod count */
+PERLVAR(Glex_dojoin, I32) /* doing an array interpolation */
+PERLVAR(Glex_starts, I32) /* how many interps done on level */
+PERLVAR(Glex_stuff, SV *) /* runtime pattern from m// or s/// */
+PERLVAR(Glex_repl, SV *) /* runtime replacement from s/// */
+PERLVAR(Glex_op, OP *) /* extra info to pass back on op */
+PERLVAR(Glex_inpat, OP *) /* in pattern $) and $| are special */
+PERLVAR(Glex_inwhat, I32) /* what kind of quoting are we in */
+PERLVAR(Glex_brackstack,char *) /* what kind of brackets to pop */
+PERLVAR(Glex_casestack, char *) /* what kind of case mods in effect */
+
+/* What we know when we're in LEX_KNOWNEXT state. */
+PERLVAR(Gnextval[5], YYSTYPE) /* value of next token, if any */
+PERLVAR(Gnexttype[5], I32) /* type of next token */
+PERLVAR(Gnexttoke, I32)
+
+PERLVAR(Glinestr, SV *)
+PERLVAR(Gbufptr, char *)
+PERLVAR(Goldbufptr, char *)
+PERLVAR(Goldoldbufptr, char *)
+PERLVAR(Gbufend, char *)
+PERLVARI(Gexpect,expectation, XSTATE) /* how to interpret ambiguous tokens */
+
+PERLVAR(Gmulti_start, I32) /* 1st line of multi-line string */
+PERLVAR(Gmulti_end, I32) /* last line of multi-line string */
+PERLVAR(Gmulti_open, I32) /* delimiter of said string */
+PERLVAR(Gmulti_close, I32) /* delimiter of said string */
+
+PERLVAR(Gerror_count, I32) /* how many errors so far, max 10 */
+PERLVAR(Gsubline, I32) /* line this subroutine began on */
+PERLVAR(Gsubname, SV *) /* name of current subroutine */
+
+PERLVAR(Gmin_intro_pending, I32) /* start of vars to introduce */
+PERLVAR(Gmax_intro_pending, I32) /* end of vars to introduce */
+PERLVAR(Gpadix, I32) /* max used index in current "register" pad */
+PERLVAR(Gpadix_floor, I32) /* how low may inner block reset padix */
+PERLVAR(Gpad_reset_pending, I32) /* reset pad on next attempted alloc */
+
+PERLVAR(Gthisexpr, I32) /* name id for nothing_in_common() */
+PERLVAR(Glast_uni, char *) /* position of last named-unary op */
+PERLVAR(Glast_lop, char *) /* position of last list operator */
+PERLVAR(Glast_lop_op, OPCODE) /* last list operator */
+PERLVAR(Gin_my, bool) /* we're compiling a "my" declaration */
+PERLVAR(Gin_my_stash, HV *) /* declared class of this "my" declaration */
+#ifdef FCRYPT
+PERLVAR(Gcryptseen, I32) /* has fast crypt() been initialized? */
+#endif
+
+PERLVAR(Ghints, U32) /* pragma-tic compile-time flags */
+
+PERLVAR(Gdo_undump, bool) /* -u or dump seen? */
+PERLVAR(Gdebug, VOL U32) /* flags given to -D switch */
+
+
+#ifdef OVERLOAD
+
+PERLVAR(Gamagic_generation, long)
+
+#endif
+
+#ifdef USE_LOCALE_COLLATE
+PERLVAR(Gcollation_ix, U32) /* Collation generation index */
+PERLVAR(Gcollation_name,char *) /* Name of current collation */
+PERLVARI(Gcollation_standard, bool, TRUE)
+ /* Assume simple collation */
+PERLVAR(Gcollxfrm_base, Size_t) /* Basic overhead in *xfrm() */
+PERLVARI(Gcollxfrm_mult,Size_t, 2) /* Expansion factor in *xfrm() */
+#endif /* USE_LOCALE_COLLATE */
+
+#ifdef USE_LOCALE_NUMERIC
+
+PERLVAR(Gnumeric_name, char *) /* Name of current numeric locale */
+PERLVARI(Gnumeric_standard, bool, TRUE)
+ /* Assume simple numerics */
+PERLVARI(Gnumeric_local, bool, TRUE)
+ /* Assume local numerics */
+
+#endif /* !USE_LOCALE_NUMERIC */
+
+/* constants (these are not literals to facilitate pointer comparisons) */
+PERLVARIC(GYes, char *, "1")
+PERLVARIC(GNo, char *, "")
+PERLVARIC(Ghexdigit, char *, "0123456789abcdef0123456789ABCDEFx")
+PERLVARIC(Gpatleave, char *, "\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}")
+
+PERLVAR(Gspecialsv_list[4],SV *) /* from byterun.h */
+
diff --git a/contrib/perl5/perly.c b/contrib/perl5/perly.c
new file mode 100644
index 000000000000..7a53d4b6f2f6
--- /dev/null
+++ b/contrib/perl5/perly.c
@@ -0,0 +1,2366 @@
+#ifndef lint
+static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
+#endif
+#define YYBYACC 1
+#line 16 "perly.y"
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef PERL_OBJECT
+static void
+Dep(CPerlObj *pPerl)
+{
+ pPerl->deprecate("\"do\" to call subroutines");
+}
+#define dep() Dep(this)
+#else
+static void
+dep(void)
+{
+ deprecate("\"do\" to call subroutines");
+}
+#endif
+
+#line 30 "perly.y"
+#define YYERRCODE 256
+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,
+ 13, 13, 13, 13, 26, 26, 27, 27, 28, 29,
+ 30, 31, 32, 44, 44, 1, 1, 1, 1, 3,
+ 38, 38, 46, 4, 5, 6, 39, 40, 40, 41,
+ 41, 47, 47, 49, 48, 16, 16, 16, 25, 25,
+ 25, 36, 36, 36, 36, 36, 36, 36, 50, 36,
+ 37, 37, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 33, 33,
+ 34, 34, 34, 2, 2, 43, 23, 18, 19, 20,
+ 21, 22, 35, 35, 35, 35,
+};
+short yylen[] = { 2,
+ 0, 2, 4, 0, 4, 0, 0, 2, 2, 2,
+ 1, 2, 3, 1, 1, 3, 3, 3, 3, 3,
+ 0, 2, 6, 7, 7, 0, 2, 8, 8, 10,
+ 9, 8, 11, 3, 0, 1, 0, 1, 1, 1,
+ 1, 1, 1, 0, 1, 1, 1, 1, 1, 4,
+ 1, 0, 5, 0, 0, 0, 1, 0, 1, 1,
+ 1, 3, 2, 0, 7, 3, 3, 1, 2, 3,
+ 1, 3, 5, 6, 3, 5, 2, 4, 0, 5,
+ 1, 1, 3, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 5, 3, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 3, 2, 3, 2,
+ 4, 3, 4, 1, 5, 1, 4, 5, 4, 1,
+ 1, 1, 5, 6, 5, 6, 5, 4, 5, 1,
+ 1, 3, 4, 3, 2, 2, 4, 5, 4, 5,
+ 4, 5, 1, 2, 2, 1, 2, 2, 2, 1,
+ 3, 1, 3, 4, 4, 6, 1, 1, 0, 1,
+ 0, 1, 2, 1, 1, 1, 2, 2, 2, 2,
+ 2, 2, 1, 1, 1, 1,
+};
+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,
+ 55, 55, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 164, 165, 0,
+ 0, 0, 0, 0, 0, 0, 0, 12, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 10, 0, 0,
+ 0, 0, 120, 122, 0, 0, 0, 0, 158, 51,
+ 0, 57, 0, 62, 0, 7, 173, 176, 175, 174,
+ 0, 0, 0, 0, 0, 0, 4, 4, 4, 4,
+ 4, 4, 0, 0, 0, 0, 0, 147, 0, 0,
+ 0, 0, 77, 0, 171, 0, 136, 0, 0, 0,
+ 0, 0, 167, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 110, 0, 168, 169, 170, 172, 0,
+ 0, 34, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 102, 103, 0, 0, 0, 0,
+ 0, 0, 0, 0, 13, 0, 50, 59, 0, 0,
+ 0, 75, 0, 0, 79, 0, 0, 0, 0, 0,
+ 0, 0, 4, 151, 153, 0, 0, 0, 0, 0,
+ 0, 0, 112, 0, 134, 0, 0, 109, 27, 0,
+ 0, 19, 0, 0, 0, 0, 66, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 81, 0, 0, 82, 0, 0, 0,
+ 0, 0, 0, 0, 132, 0, 0, 61, 60, 53,
+ 0, 3, 0, 155, 0, 0, 113, 0, 42, 0,
+ 43, 0, 0, 0, 0, 166, 0, 0, 36, 41,
+ 0, 0, 0, 154, 163, 78, 0, 137, 0, 139,
+ 0, 111, 0, 0, 0, 0, 0, 141, 0, 0,
+ 0, 119, 0, 117, 0, 128, 0, 133, 0, 76,
+ 0, 80, 0, 0, 0, 0, 0, 0, 0, 0,
+ 73, 138, 140, 127, 0, 125, 0, 0, 142, 118,
+ 0, 123, 129, 115, 65, 156, 6, 0, 0, 0,
+ 0, 0, 0, 0, 0, 126, 124, 74, 7, 28,
+ 29, 0, 0, 24, 25, 0, 32, 0, 0, 0,
+ 22, 0, 0, 0, 31, 5, 0, 30, 0, 0,
+ 33, 0, 23,
+};
+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,
+};
+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,
+ 0, 0, 13, 20, 24, 25, -34, 2099, 27, 28,
+ 29, 1021, 965, -23, 1084, 1348, -217, 0, 0, -23,
+ 2099, 2099, 2099, 2099, 2099, 2099, 1404, 0, 2099, 2099,
+ 1460, -23, -23, -23, -23, 2099, -206, 0, 335, 3814,
+ -73, -68, 0, 0, -47, 40, 32, 61, 0, 0,
+ -39, 0, -157, 0, -145, 0, 0, 0, 0, 0,
+ 2099, 73, 2099, 825, -39, -157, 0, 0, 0, 0,
+ 0, 0, 75, 3814, 78, 1519, 965, 0, 825, 0,
+ -73, 61, 0, 2099, 0, 77, 0, 825, -16, -9,
+ -51, 2099, 0, 61, 87, 87, 87, -86, -86, 33,
+ -40, 87, 87, 0, -81, 0, 0, 0, 0, 825,
+ -39, 0, 2099, 2099, 2099, 2099, 2099, 2099, 2099, 2099,
+ 2099, 2099, 2099, 2099, 2099, 2099, 2099, 2099, 2099, 2099,
+ 2099, 2099, 2099, 2099, 0, 0, 30, 2099, 2099, 2099,
+ 2099, 2099, 2099, 1694, 0, 2099, 0, 0, -49, -118,
+ 189, 0, 2099, 353, 0, -39, 2099, 2099, 2099, 2099,
+ 104, 1753, 0, 0, 0, -24, 8, 85, 2099, 61,
+ 1809, 1865, 0, 23, 0, 2099, 54, 0, 0, -269,
+ -269, 0, -269, -269, -269, -151, 0, -43, 1121, 825,
+ 673, 50, 363, 3814, 1233, 2459, 3640, 2309, 266, -82,
+ 87, 87, 2099, 0, 1928, 2099, 0, 111, 51, 12,
+ 76, 14, 90, 39, 0, -22, 3814, 0, 0, 0,
+ 2099, 0, 121, 0, 2099, 2099, 0, -269, 0, 124,
+ 0, 125, -269, 126, 130, 0, 112, 335, 0, 0,
+ 131, 136, 2099, 0, 0, 0, -14, 0, 1, 0,
+ 4, 0, 133, 2099, 55, 2099, 49, 0, 6, 197,
+ 2099, 0, 89, 0, 94, 0, 100, 0, 144, 0,
+ 1175, 0, 92, 92, 92, 92, 2099, 92, 2099, 171,
+ 0, 0, 0, 0, 202, 0, 3900, 108, 0, 0,
+ 188, 0, 0, 0, 0, 0, 0, -206, -206, -238,
+ -238, 199, -206, 211, 92, 0, 0, 0, 0, 0,
+ 0, 92, 241, 0, 0, 92, 0, 1753, -206, 326,
+ 0, 2099, -206, 256, 0, 0, 259, 0, 92, 92,
+ 0, -238, 0,
+};
+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,
+ 0, 0, 0, 0, 0, 0, 0, 2228, 426, 0,
+ 0, 2833, 2876, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 59, 0, -10, 2038,
+ 2952, 2995, 0, 0, 2274, 2140, 0, 200, 0, 0,
+ 0, 0, -44, 0, 0, 0, 0, 0, 0, 0,
+ 2421, 0, 0, 105, 0, 198, 0, 0, 0, 0,
+ 0, 0, 0, 3753, 0, 0, 319, 0, 3505, 525,
+ 586, 2510, 0, 0, 0, 2185, 0, 3541, 2952, 0,
+ 0, 2421, 0, 2553, 3112, 3150, 3188, -37, 3069, 2597,
+ 0, 3231, 3269, 0, 0, 0, 0, 0, 0, 3584,
+ 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, 2673, 0, 0, 0, 0,
+ 909, 0, 319, 0, 0, 0, 320, 0, 0, 0,
+ 0, 306, 0, 0, 0, 0, 325, 0, 0, 2789,
+ 0, 0, 0, 0, 0, 0, 2716, 0, 0, -5,
+ 22, 0, 68, 69, 70, 702, 0, 0, 3741, 1296,
+ 1560, 3386, 3424, 3796, 0, 3703, 3660, 3622, 1616, 3467,
+ 3305, 3348, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 3809, 0, 0, 0,
+ 309, 0, 0, 0, 0, 2421, 0, 79, 0, 0,
+ 0, 0, 330, 0, 0, 0, 0, 84, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 319, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 317, 0,
+ 0, 0, 0, 0, 0, 0, 1982, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 59, 59, 154,
+ 154, 0, 59, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 340, 59, 909,
+ 0, 0, 59, 0, 0, 0, 0, 0, 0, 0,
+ 0, 154, 0,
+};
+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,
+ 86, 208, -45, -169, 987, 0, 0, 0, 0, 308,
+ 0, -271, 0, 0, 0, 0, 0, 0, 0, 0,
+};
+#define YYTABLESIZE 4293
+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,
+ 15, 84, 121, 93, 112, 18, 150, 342, 343, 122,
+ 150, 312, 124, 131, 313, 182, 319, 135, 15, 169,
+ 363, 275, 97, 18, 171, 104, 340, 341, 26, 98,
+ 271, 347, 39, 99, 100, 62, 105, 106, 107, 235,
+ 293, 141, 295, 23, 170, 173, 205, 355, 58, 174,
+ 39, 358, 112, 23, 187, 188, 189, 190, 191, 192,
+ 175, 26, 196, 197, 26, 26, 26, 297, 26, 23,
+ 26, 26, 178, 26, 176, 200, 169, 318, 16, 17,
+ 20, 180, 183, 112, 193, 203, 201, 26, 194, 38,
+ 236, 321, 26, 206, 40, 276, 16, 17, 20, 210,
+ 211, 213, 214, 215, 216, 217, 218, 38, 251, 62,
+ 168, 310, 15, 292, 284, 149, 149, 282, 149, 26,
+ 291, 307, 233, 21, 239, 240, 241, 242, 243, 244,
+ 246, 300, 149, 149, 303, 304, 305, 149, 294, 197,
+ 306, 308, 150, 258, 211, 332, 211, 168, 268, 316,
+ 273, 26, 296, 26, 26, 277, 21, 279, 281, 21,
+ 21, 21, 283, 21, 309, 21, 21, 149, 21, 4,
+ 5, 6, 325, 7, 8, 299, 154, 155, 19, 150,
+ 302, 335, 21, 322, 327, 148, 149, 21, 323, 287,
+ 357, 289, 290, 163, 324, 314, 164, 167, 338, 165,
+ 166, 167, 337, 87, 104, 104, 104, 104, 88, 346,
+ 68, 104, 112, 104, 21, 148, 149, 112, 2, 104,
+ 104, 104, 104, 148, 149, 350, 148, 149, 68, 104,
+ 104, 101, 104, 104, 104, 104, 104, 104, 104, 348,
+ 315, 104, 148, 149, 148, 149, 21, 197, 21, 21,
+ 352, 44, 148, 149, 44, 44, 44, 234, 44, 320,
+ 44, 44, 68, 44, 336, 258, 359, 148, 149, 360,
+ 148, 149, 148, 149, 148, 149, 52, 44, 148, 149,
+ 148, 149, 44, 252, 26, 26, 26, 26, 26, 26,
+ 58, 26, 26, 26, 26, 26, 26, 26, 26, 26,
+ 26, 26, 26, 26, 69, 148, 149, 26, 26, 44,
+ 26, 26, 26, 26, 26, 148, 149, 148, 149, 26,
+ 26, 26, 26, 26, 26, 163, 168, 26, 164, 161,
+ 37, 165, 166, 167, 35, 162, 26, 159, 26, 26,
+ 40, 44, 148, 149, 44, 37, 149, 149, 149, 149,
+ 35, 21, 96, 149, 77, 149, 148, 149, 150, 212,
+ 354, 149, 149, 254, 334, 164, 255, 265, 165, 166,
+ 167, 149, 149, 186, 149, 149, 149, 149, 149, 21,
+ 21, 21, 21, 21, 21, 157, 21, 21, 21, 21,
+ 21, 21, 21, 21, 21, 21, 21, 21, 21, 148,
+ 149, 0, 21, 21, 0, 21, 21, 21, 21, 21,
+ 0, 0, 0, 168, 21, 21, 21, 21, 21, 21,
+ 356, 0, 21, 168, 4, 5, 6, 0, 7, 8,
+ 0, 21, 0, 21, 21, 0, 150, 0, 0, 150,
+ 0, 68, 68, 68, 68, 150, 0, 0, 68, 0,
+ 0, 0, 0, 150, 150, 150, 0, 0, 150, 0,
+ 0, 0, 0, 148, 149, 0, 68, 68, 148, 149,
+ 0, 0, 0, 0, 44, 44, 44, 44, 44, 44,
+ 0, 44, 44, 44, 0, 0, 150, 44, 150, 0,
+ 44, 44, 44, 44, 0, 0, 0, 44, 44, 0,
+ 44, 44, 44, 44, 44, 0, 0, 0, 0, 44,
+ 44, 44, 44, 44, 44, 0, 0, 44, 150, 0,
+ 0, 0, 152, 153, 154, 155, 44, 173, 44, 44,
+ 173, 173, 173, 0, 173, 157, 173, 173, 157, 173,
+ 162, 163, 0, 0, 164, 0, 0, 165, 166, 167,
+ 0, 0, 157, 157, 0, 0, 0, 157, 173, 0,
+ 0, 4, 5, 6, 0, 7, 8, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 143, 144, 145, 146,
+ 0, 0, 0, 147, 0, 157, 0, 157, 174, 0,
+ 0, 174, 174, 174, 0, 174, 114, 174, 174, 114,
+ 174, 148, 149, 151, 0, 0, 0, 0, 0, 152,
+ 153, 154, 155, 114, 114, 0, 0, 157, 114, 174,
+ 173, 154, 156, 158, 159, 160, 161, 162, 163, 0,
+ 0, 164, 0, 0, 165, 166, 167, 0, 163, 0,
+ 0, 164, 0, 0, 165, 166, 167, 52, 114, 0,
+ 62, 64, 50, 0, 57, 0, 65, 60, 0, 59,
+ 0, 0, 0, 0, 0, 0, 0, 150, 150, 150,
+ 150, 0, 0, 58, 150, 0, 150, 0, 63, 0,
+ 0, 174, 150, 150, 150, 150, 329, 330, 331, 0,
+ 333, 0, 150, 150, 0, 150, 150, 150, 150, 150,
+ 150, 150, 0, 0, 150, 61, 0, 150, 150, 150,
+ 0, 0, 67, 0, 0, 67, 0, 349, 0, 0,
+ 0, 0, 0, 0, 351, 0, 0, 0, 353, 0,
+ 67, 0, 0, 168, 0, 0, 0, 23, 0, 0,
+ 53, 361, 362, 0, 0, 0, 0, 0, 0, 0,
+ 0, 173, 173, 173, 173, 173, 0, 173, 173, 173,
+ 0, 0, 0, 173, 67, 150, 157, 157, 157, 157,
+ 0, 0, 0, 157, 173, 157, 173, 173, 173, 173,
+ 173, 157, 157, 157, 157, 173, 173, 173, 173, 173,
+ 173, 157, 157, 173, 157, 157, 157, 157, 157, 157,
+ 157, 0, 173, 157, 173, 173, 157, 157, 157, 0,
+ 0, 0, 174, 174, 174, 174, 174, 0, 174, 174,
+ 174, 0, 0, 0, 174, 0, 0, 114, 114, 114,
+ 114, 0, 0, 0, 114, 174, 114, 174, 174, 174,
+ 174, 174, 114, 114, 114, 114, 174, 174, 174, 174,
+ 174, 174, 114, 114, 174, 114, 114, 114, 114, 114,
+ 114, 114, 0, 174, 114, 174, 174, 114, 114, 114,
+ 22, 24, 25, 26, 27, 28, 0, 29, 30, 31,
+ 0, 0, 0, 32, 0, 168, 33, 34, 35, 36,
+ 0, 0, 0, 37, 38, 0, 39, 40, 41, 42,
+ 43, 0, 0, 0, 0, 44, 45, 46, 47, 48,
+ 49, 44, 0, 51, 44, 44, 44, 150, 44, 0,
+ 44, 44, 54, 44, 55, 56, 0, 0, 67, 152,
+ 0, 154, 155, 0, 0, 0, 0, 44, 0, 0,
+ 0, 0, 44, 67, 67, 67, 67, 162, 163, 0,
+ 67, 164, 0, 0, 165, 166, 167, 108, 0, 0,
+ 117, 0, 0, 0, 0, 0, 0, 52, 67, 44,
+ 62, 64, 50, 0, 57, 0, 65, 60, 0, 59,
+ 0, 0, 92, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 177, 0, 63, 114,
+ 115, 44, 0, 0, 44, 0, 123, 0, 0, 0,
+ 185, 0, 0, 0, 0, 0, 0, 0, 136, 137,
+ 138, 139, 0, 52, 0, 61, 62, 64, 50, 0,
+ 57, 0, 65, 60, 0, 59, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 63, 0, 209, 23, 0, 0,
+ 53, 0, 0, 199, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 61, 0, 154, 155, 0, 52, 0, 0, 62,
+ 64, 50, 0, 57, 249, 65, 60, 0, 59, 162,
+ 163, 257, 0, 164, 0, 0, 165, 166, 167, 0,
+ 0, 0, 0, 23, 0, 0, 53, 63, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 44, 44, 44, 44, 44, 44,
+ 0, 44, 44, 44, 61, 0, 0, 44, 0, 0,
+ 44, 44, 44, 44, 0, 0, 0, 44, 44, 0,
+ 44, 44, 44, 44, 44, 0, 0, 0, 0, 44,
+ 44, 44, 44, 44, 44, 0, 23, 44, 0, 53,
+ 0, 168, 0, 0, 0, 326, 44, 0, 44, 44,
+ 0, 110, 25, 26, 27, 28, 88, 29, 30, 31,
+ 0, 0, 0, 32, 0, 0, 0, 157, 0, 0,
+ 0, 0, 0, 150, 38, 0, 39, 40, 41, 42,
+ 43, 0, 0, 0, 0, 44, 45, 46, 47, 48,
+ 49, 0, 0, 51, 0, 168, 0, 0, 0, 0,
+ 0, 0, 54, 0, 55, 56, 0, 24, 25, 26,
+ 27, 28, 0, 29, 30, 31, 0, 0, 0, 32,
+ 286, 0, 0, 0, 0, 157, 0, 150, 0, 0,
+ 38, 0, 39, 40, 41, 42, 43, 0, 0, 0,
+ 0, 44, 45, 46, 47, 48, 49, 0, 0, 51,
+ 0, 0, 0, 168, 0, 0, 0, 0, 54, 0,
+ 55, 56, 0, 0, 0, 0, 88, 0, 0, 88,
+ 116, 25, 26, 27, 28, 0, 29, 30, 31, 0,
+ 0, 0, 32, 88, 88, 150, 0, 0, 88, 0,
+ 0, 0, 0, 38, 0, 39, 40, 41, 42, 43,
+ 0, 0, 0, 0, 44, 45, 46, 47, 48, 49,
+ 52, 0, 51, 62, 64, 50, 0, 57, 88, 65,
+ 60, 54, 59, 55, 56, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 120, 152, 153, 154,
+ 155, 63, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 158, 159, 160, 161, 162, 163, 0, 0, 164,
+ 0, 0, 165, 166, 167, 0, 52, 0, 61, 62,
+ 64, 50, 0, 57, 130, 65, 60, 0, 59, 0,
+ 0, 0, 0, 0, 0, 151, 0, 0, 0, 0,
+ 0, 152, 153, 154, 155, 0, 0, 63, 0, 0,
+ 0, 0, 0, 53, 156, 158, 159, 160, 161, 162,
+ 163, 0, 0, 164, 0, 0, 165, 166, 167, 0,
+ 0, 0, 52, 0, 61, 62, 64, 50, 0, 57,
+ 0, 65, 60, 0, 59, 0, 0, 0, 0, 0,
+ 0, 0, 0, 151, 0, 0, 0, 0, 0, 152,
+ 153, 154, 155, 63, 0, 0, 0, 0, 0, 53,
+ 0, 0, 156, 158, 159, 160, 161, 162, 163, 0,
+ 0, 164, 0, 0, 165, 166, 167, 0, 0, 0,
+ 61, 52, 134, 0, 62, 64, 50, 0, 57, 195,
+ 65, 60, 0, 59, 0, 0, 0, 88, 88, 88,
+ 88, 0, 0, 0, 88, 0, 88, 0, 0, 0,
+ 0, 0, 63, 88, 0, 53, 0, 0, 0, 0,
+ 0, 0, 88, 88, 0, 88, 88, 88, 88, 88,
+ 89, 0, 0, 89, 24, 25, 26, 27, 28, 61,
+ 29, 30, 31, 0, 0, 0, 32, 89, 89, 0,
+ 0, 0, 89, 0, 0, 0, 0, 38, 0, 39,
+ 40, 41, 42, 43, 0, 0, 0, 0, 44, 45,
+ 46, 47, 48, 49, 53, 0, 51, 0, 0, 0,
+ 0, 0, 89, 0, 0, 54, 90, 55, 56, 90,
+ 24, 25, 26, 27, 28, 0, 29, 30, 31, 0,
+ 0, 0, 32, 90, 90, 0, 0, 0, 90, 0,
+ 0, 0, 0, 38, 0, 39, 40, 41, 42, 43,
+ 0, 0, 0, 0, 44, 45, 46, 47, 48, 49,
+ 0, 0, 51, 0, 0, 0, 0, 0, 90, 0,
+ 0, 54, 0, 55, 56, 0, 24, 25, 26, 27,
+ 28, 0, 29, 30, 31, 0, 52, 0, 32, 62,
+ 64, 50, 0, 57, 245, 65, 60, 0, 59, 38,
+ 0, 39, 40, 41, 42, 43, 0, 0, 0, 0,
+ 44, 45, 46, 47, 48, 49, 0, 63, 51, 0,
+ 0, 0, 0, 0, 0, 0, 0, 54, 0, 55,
+ 56, 0, 0, 0, 0, 24, 25, 26, 27, 28,
+ 0, 29, 30, 31, 61, 52, 0, 32, 62, 64,
+ 50, 0, 57, 0, 65, 60, 0, 59, 38, 0,
+ 39, 40, 41, 42, 43, 0, 0, 0, 0, 44,
+ 45, 46, 47, 48, 49, 0, 63, 51, 0, 53,
+ 0, 0, 0, 0, 0, 0, 54, 0, 55, 56,
+ 0, 89, 89, 89, 89, 0, 0, 0, 89, 0,
+ 89, 52, 0, 61, 62, 64, 50, 0, 57, 278,
+ 65, 60, 0, 59, 0, 0, 89, 89, 0, 89,
+ 89, 89, 89, 89, 0, 0, 0, 0, 0, 0,
+ 0, 0, 63, 0, 0, 0, 0, 0, 53, 0,
+ 0, 0, 0, 0, 0, 0, 0, 90, 90, 90,
+ 90, 0, 0, 0, 90, 0, 90, 52, 0, 61,
+ 62, 64, 50, 0, 57, 280, 65, 60, 0, 59,
+ 0, 0, 90, 90, 0, 90, 90, 90, 90, 90,
+ 0, 0, 0, 0, 0, 0, 0, 0, 63, 0,
+ 0, 0, 0, 0, 53, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 24, 25, 26, 27, 28, 61, 29, 30, 31, 0,
+ 52, 0, 32, 62, 64, 50, 0, 57, 288, 65,
+ 60, 0, 59, 38, 0, 39, 40, 41, 42, 43,
+ 0, 0, 0, 0, 44, 45, 46, 47, 48, 49,
+ 53, 63, 51, 0, 0, 0, 0, 0, 0, 0,
+ 0, 54, 0, 55, 56, 0, 0, 0, 22, 24,
+ 25, 26, 27, 28, 0, 29, 30, 31, 61, 0,
+ 0, 32, 95, 0, 0, 95, 0, 0, 0, 0,
+ 0, 0, 38, 0, 39, 40, 41, 42, 43, 95,
+ 95, 0, 0, 44, 45, 46, 47, 48, 49, 0,
+ 0, 51, 0, 53, 0, 0, 0, 0, 0, 0,
+ 54, 0, 55, 56, 0, 24, 25, 26, 27, 28,
+ 0, 29, 30, 31, 95, 0, 0, 32, 71, 0,
+ 0, 71, 0, 0, 0, 0, 0, 0, 38, 0,
+ 39, 40, 41, 42, 43, 71, 71, 0, 0, 44,
+ 45, 46, 47, 48, 49, 0, 0, 51, 0, 0,
+ 0, 0, 0, 0, 0, 0, 54, 0, 55, 56,
+ 0, 24, 25, 26, 27, 28, 0, 29, 30, 31,
+ 71, 52, 0, 32, 62, 64, 50, 0, 57, 0,
+ 65, 60, 0, 59, 38, 0, 39, 40, 41, 42,
+ 43, 0, 0, 0, 0, 44, 45, 46, 47, 48,
+ 49, 0, 63, 51, 0, 0, 0, 0, 0, 0,
+ 0, 0, 54, 0, 55, 56, 0, 0, 0, 0,
+ 131, 0, 0, 131, 24, 25, 26, 27, 28, 61,
+ 29, 30, 31, 0, 0, 0, 32, 131, 131, 0,
+ 0, 0, 131, 0, 0, 0, 0, 38, 0, 39,
+ 40, 41, 42, 43, 0, 0, 0, 0, 44, 45,
+ 46, 47, 48, 49, 53, 157, 51, 0, 157, 0,
+ 131, 0, 131, 0, 0, 54, 0, 55, 56, 0,
+ 0, 0, 157, 157, 0, 0, 0, 157, 0, 0,
+ 0, 0, 0, 95, 95, 95, 95, 0, 0, 0,
+ 95, 0, 131, 0, 0, 0, 0, 0, 143, 0,
+ 0, 143, 0, 0, 0, 157, 0, 157, 95, 95,
+ 0, 95, 0, 0, 0, 143, 143, 0, 0, 0,
+ 143, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 157, 0, 71,
+ 71, 71, 71, 0, 116, 0, 71, 116, 0, 0,
+ 143, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 116, 116, 0, 71, 71, 116, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 143, 0, 0, 0, 0, 24, 25, 26, 27, 28,
+ 0, 29, 30, 31, 116, 0, 116, 32, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 38, 0,
+ 39, 40, 41, 42, 43, 0, 0, 0, 0, 44,
+ 45, 46, 47, 48, 49, 0, 0, 51, 0, 168,
+ 0, 0, 0, 0, 0, 0, 54, 0, 55, 56,
+ 0, 131, 131, 131, 131, 0, 0, 0, 131, 0,
+ 131, 0, 0, 0, 0, 0, 131, 131, 131, 131,
+ 0, 150, 0, 0, 0, 0, 131, 131, 0, 131,
+ 131, 131, 131, 131, 131, 131, 0, 0, 131, 0,
+ 0, 131, 131, 131, 0, 0, 157, 157, 157, 157,
+ 0, 159, 0, 157, 159, 157, 0, 0, 0, 0,
+ 0, 157, 157, 157, 157, 0, 0, 0, 159, 159,
+ 0, 157, 157, 159, 157, 157, 157, 157, 157, 157,
+ 157, 0, 0, 157, 0, 0, 157, 157, 157, 143,
+ 143, 143, 143, 0, 0, 0, 143, 0, 143, 0,
+ 0, 0, 0, 159, 143, 143, 143, 143, 0, 0,
+ 0, 0, 0, 0, 143, 143, 0, 143, 143, 143,
+ 143, 143, 143, 143, 0, 0, 143, 0, 0, 143,
+ 143, 143, 0, 159, 0, 116, 116, 116, 116, 168,
+ 160, 0, 116, 0, 116, 0, 0, 0, 0, 0,
+ 116, 116, 116, 116, 0, 0, 0, 160, 160, 0,
+ 116, 116, 160, 116, 116, 116, 116, 116, 116, 116,
+ 0, 150, 116, 0, 0, 116, 116, 116, 0, 0,
+ 0, 0, 0, 145, 0, 152, 153, 154, 155, 0,
+ 160, 0, 160, 0, 0, 0, 0, 0, 0, 0,
+ 145, 145, 161, 162, 163, 145, 0, 164, 0, 0,
+ 165, 166, 167, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 160, 0, 0, 0, 0, 108, 0, 0,
+ 108, 0, 0, 145, 0, 145, 0, 0, 0, 0,
+ 0, 0, 0, 0, 108, 108, 0, 0, 0, 108,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 145, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 108,
+ 0, 0, 159, 159, 159, 159, 0, 0, 0, 159,
+ 0, 159, 0, 0, 0, 0, 0, 159, 159, 159,
+ 159, 0, 0, 69, 0, 0, 69, 159, 159, 108,
+ 159, 159, 159, 159, 159, 159, 159, 0, 0, 159,
+ 69, 69, 159, 159, 159, 69, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 152, 153, 154, 155, 0,
+ 0, 0, 0, 0, 0, 0, 107, 0, 0, 107,
+ 159, 160, 161, 162, 163, 69, 0, 164, 0, 0,
+ 165, 166, 167, 107, 107, 0, 0, 0, 107, 0,
+ 0, 160, 160, 160, 160, 0, 0, 0, 160, 0,
+ 160, 0, 0, 0, 0, 69, 160, 160, 160, 160,
+ 0, 0, 0, 0, 0, 0, 160, 160, 107, 160,
+ 160, 160, 160, 160, 160, 160, 0, 0, 160, 0,
+ 0, 160, 160, 160, 145, 145, 145, 145, 0, 72,
+ 0, 145, 0, 145, 0, 0, 0, 0, 107, 145,
+ 145, 145, 145, 0, 0, 0, 72, 72, 0, 145,
+ 145, 72, 145, 145, 145, 145, 145, 145, 145, 0,
+ 0, 145, 0, 0, 145, 145, 145, 0, 108, 108,
+ 108, 108, 0, 146, 0, 108, 146, 108, 0, 72,
+ 0, 72, 0, 108, 108, 108, 108, 0, 0, 0,
+ 146, 146, 0, 108, 108, 146, 108, 108, 108, 108,
+ 108, 108, 108, 0, 0, 108, 0, 0, 108, 108,
+ 108, 72, 0, 0, 0, 0, 159, 90, 90, 159,
+ 0, 0, 0, 0, 0, 146, 0, 0, 0, 103,
+ 0, 0, 0, 159, 159, 111, 90, 119, 159, 0,
+ 0, 0, 90, 0, 69, 69, 69, 69, 0, 0,
+ 0, 69, 0, 69, 90, 90, 90, 90, 0, 69,
+ 69, 69, 69, 0, 0, 0, 0, 0, 159, 69,
+ 69, 0, 69, 69, 69, 69, 69, 69, 69, 0,
+ 0, 69, 0, 0, 69, 69, 69, 107, 107, 107,
+ 107, 0, 114, 0, 107, 114, 107, 0, 0, 111,
+ 0, 0, 107, 107, 107, 107, 0, 0, 0, 114,
+ 114, 0, 107, 107, 114, 107, 107, 107, 107, 107,
+ 107, 107, 0, 0, 107, 0, 0, 107, 107, 107,
+ 0, 0, 0, 0, 0, 121, 0, 0, 121, 0,
+ 0, 0, 0, 0, 114, 0, 0, 0, 0, 0,
+ 0, 0, 121, 121, 0, 0, 0, 121, 0, 237,
+ 72, 72, 72, 72, 0, 0, 0, 72, 0, 72,
+ 0, 0, 0, 0, 0, 72, 72, 72, 72, 0,
+ 0, 0, 0, 266, 0, 72, 72, 121, 72, 72,
+ 72, 72, 72, 72, 72, 0, 0, 72, 0, 0,
+ 72, 72, 72, 0, 146, 146, 146, 146, 0, 105,
+ 0, 146, 105, 146, 0, 0, 0, 0, 0, 146,
+ 146, 146, 146, 0, 0, 0, 105, 105, 0, 146,
+ 146, 105, 146, 146, 146, 146, 146, 146, 146, 0,
+ 0, 146, 0, 0, 146, 146, 146, 159, 159, 159,
+ 159, 0, 99, 0, 159, 99, 159, 0, 0, 0,
+ 0, 105, 159, 159, 159, 159, 0, 0, 0, 99,
+ 99, 0, 159, 159, 99, 159, 159, 159, 159, 159,
+ 159, 159, 0, 0, 159, 0, 0, 159, 159, 159,
+ 100, 0, 0, 100, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 99, 0, 0, 100, 100, 0,
+ 0, 0, 100, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 114, 114, 114, 114, 0, 101, 0,
+ 114, 101, 114, 0, 0, 0, 0, 0, 114, 114,
+ 114, 114, 100, 0, 0, 101, 101, 0, 114, 114,
+ 101, 114, 114, 114, 114, 114, 114, 114, 0, 0,
+ 114, 0, 0, 114, 114, 114, 121, 121, 121, 121,
+ 0, 97, 0, 121, 97, 121, 0, 0, 0, 0,
+ 101, 121, 121, 121, 121, 0, 0, 0, 97, 97,
+ 0, 121, 121, 97, 121, 121, 121, 121, 121, 121,
+ 121, 0, 0, 121, 0, 0, 121, 121, 121, 98,
+ 0, 0, 98, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 97, 0, 0, 98, 98, 0, 0,
+ 0, 98, 0, 0, 0, 0, 0, 0, 0, 0,
+ 105, 105, 105, 105, 0, 96, 0, 105, 96, 105,
+ 0, 0, 0, 0, 0, 105, 105, 105, 105, 0,
+ 0, 98, 96, 96, 0, 105, 105, 96, 105, 105,
+ 105, 105, 105, 105, 105, 0, 0, 105, 0, 0,
+ 0, 0, 0, 99, 99, 99, 99, 0, 84, 0,
+ 99, 84, 99, 0, 0, 0, 0, 96, 99, 99,
+ 99, 99, 0, 0, 0, 84, 84, 0, 99, 99,
+ 84, 99, 99, 99, 99, 99, 99, 99, 0, 0,
+ 0, 100, 100, 100, 100, 0, 85, 0, 100, 85,
+ 100, 0, 0, 0, 0, 0, 100, 100, 100, 100,
+ 84, 0, 0, 85, 85, 0, 100, 100, 85, 100,
+ 100, 100, 100, 100, 100, 100, 0, 0, 0, 101,
+ 101, 101, 101, 0, 86, 0, 101, 86, 101, 0,
+ 0, 0, 0, 0, 101, 101, 101, 101, 85, 0,
+ 0, 86, 86, 0, 101, 101, 86, 101, 101, 101,
+ 101, 101, 101, 101, 0, 0, 0, 0, 0, 0,
+ 0, 0, 97, 97, 97, 97, 0, 87, 0, 97,
+ 87, 97, 0, 0, 0, 0, 86, 97, 97, 97,
+ 97, 0, 0, 0, 87, 87, 0, 97, 97, 87,
+ 97, 97, 97, 97, 97, 97, 97, 0, 0, 0,
+ 98, 98, 98, 98, 0, 148, 0, 98, 148, 98,
+ 0, 0, 0, 0, 0, 98, 98, 98, 98, 87,
+ 0, 0, 148, 148, 0, 98, 98, 148, 98, 98,
+ 98, 98, 98, 98, 98, 0, 96, 96, 96, 96,
+ 0, 135, 0, 96, 135, 96, 0, 0, 0, 0,
+ 0, 96, 96, 96, 96, 0, 0, 148, 135, 135,
+ 0, 96, 96, 135, 96, 96, 96, 96, 96, 96,
+ 96, 0, 0, 0, 0, 0, 0, 0, 0, 84,
+ 84, 84, 84, 0, 106, 0, 84, 106, 84, 0,
+ 0, 0, 0, 135, 84, 84, 84, 84, 0, 0,
+ 0, 106, 106, 0, 84, 84, 106, 84, 84, 84,
+ 84, 84, 84, 84, 0, 0, 0, 85, 85, 85,
+ 85, 0, 91, 0, 85, 91, 85, 0, 0, 0,
+ 0, 0, 85, 85, 85, 85, 106, 0, 0, 91,
+ 91, 0, 85, 85, 91, 85, 85, 85, 85, 85,
+ 85, 0, 0, 0, 0, 86, 86, 86, 86, 0,
+ 93, 0, 86, 93, 86, 0, 0, 0, 0, 0,
+ 86, 86, 0, 86, 91, 0, 0, 93, 93, 0,
+ 86, 86, 93, 86, 86, 86, 86, 86, 86, 0,
+ 168, 0, 0, 0, 0, 0, 0, 0, 87, 87,
+ 87, 87, 0, 94, 0, 87, 94, 87, 0, 0,
+ 0, 0, 93, 87, 87, 0, 0, 0, 0, 0,
+ 94, 94, 150, 87, 87, 94, 87, 87, 87, 87,
+ 87, 87, 0, 0, 0, 0, 148, 148, 148, 148,
+ 0, 92, 0, 148, 92, 148, 0, 0, 0, 0,
+ 0, 148, 148, 144, 0, 94, 144, 0, 92, 92,
+ 0, 148, 148, 92, 148, 148, 148, 148, 148, 0,
+ 144, 144, 135, 135, 135, 135, 0, 0, 0, 135,
+ 0, 135, 0, 0, 0, 0, 0, 135, 135, 0,
+ 0, 0, 0, 92, 0, 0, 83, 135, 135, 83,
+ 135, 135, 135, 135, 135, 144, 0, 0, 0, 70,
+ 0, 0, 70, 83, 83, 106, 106, 106, 106, 0,
+ 0, 0, 106, 0, 106, 0, 70, 70, 0, 0,
+ 106, 106, 0, 0, 0, 0, 157, 0, 0, 0,
+ 106, 106, 0, 106, 106, 106, 106, 106, 83, 0,
+ 0, 0, 0, 91, 91, 91, 91, 0, 0, 0,
+ 91, 70, 91, 0, 168, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 91, 91,
+ 0, 91, 91, 91, 91, 0, 152, 153, 154, 155,
+ 0, 93, 93, 93, 93, 0, 150, 0, 93, 0,
+ 93, 0, 160, 161, 162, 163, 0, 0, 164, 0,
+ 0, 165, 166, 167, 0, 0, 93, 93, 0, 93,
+ 93, 93, 157, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 94, 94, 94, 94, 0, 0,
+ 0, 94, 0, 94, 0, 0, 0, 0, 0, 0,
+ 168, 0, 0, 0, 0, 0, 0, 0, 0, 94,
+ 94, 0, 94, 94, 0, 0, 0, 0, 0, 0,
+ 0, 0, 92, 92, 92, 92, 0, 0, 0, 92,
+ 0, 0, 150, 0, 144, 144, 144, 144, 0, 0,
+ 0, 144, 0, 0, 0, 0, 94, 92, 92, 0,
+ 92, 0, 0, 0, 104, 0, 0, 0, 109, 144,
+ 144, 118, 0, 0, 0, 0, 0, 0, 125, 126,
+ 127, 128, 129, 0, 0, 132, 133, 83, 83, 83,
+ 83, 0, 140, 0, 83, 0, 0, 0, 0, 0,
+ 70, 70, 70, 70, 0, 0, 0, 70, 0, 0,
+ 0, 0, 83, 83, 151, 0, 0, 0, 0, 184,
+ 152, 153, 154, 155, 0, 70, 70, 0, 0, 0,
+ 0, 0, 0, 156, 158, 159, 160, 161, 162, 163,
+ 0, 0, 164, 0, 0, 165, 166, 167, 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, 219, 220, 221,
+ 222, 223, 224, 225, 226, 227, 228, 229, 230, 231,
+ 232, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 151, 0, 247, 0, 0, 0, 152, 153, 154, 155,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 158, 159, 160, 161, 162, 163, 0, 0, 164, 0,
+ 0, 165, 166, 167, 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, 301, 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, 317,
+};
+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,
+ 41, 59, 46, 40, 43, 41, 123, 276, 277, 257,
+ 123, 41, 51, 57, 41, 91, 41, 61, 59, 123,
+ 362, 44, 40, 59, 123, 93, 328, 329, 0, 40,
+ 192, 333, 41, 40, 40, 36, 40, 40, 40, 40,
+ 59, 278, 59, 123, 91, 123, 122, 349, 123, 40,
+ 59, 353, 91, 123, 97, 98, 99, 100, 101, 102,
+ 59, 33, 106, 107, 36, 37, 38, 59, 40, 123,
+ 42, 43, 260, 45, 44, 114, 123, 59, 41, 41,
+ 41, 257, 40, 122, 40, 125, 40, 59, 41, 41,
+ 91, 291, 64, 91, 41, 41, 59, 59, 59, 143,
+ 144, 145, 146, 147, 148, 149, 150, 59, 257, 36,
+ 91, 273, 59, 93, 91, 41, 298, 125, 44, 91,
+ 40, 40, 123, 0, 168, 169, 170, 171, 172, 173,
+ 174, 41, 58, 59, 41, 41, 41, 63, 93, 183,
+ 41, 41, 123, 187, 188, 307, 190, 91, 192, 125,
+ 193, 123, 93, 125, 126, 199, 33, 201, 202, 36,
+ 37, 38, 206, 40, 59, 42, 43, 93, 45, 266,
+ 267, 268, 59, 270, 271, 251, 289, 290, 257, 123,
+ 256, 41, 59, 125, 123, 297, 298, 64, 125, 233,
+ 352, 235, 236, 306, 125, 93, 309, 314, 41, 312,
+ 313, 314, 125, 257, 272, 273, 274, 275, 262, 41,
+ 41, 279, 251, 281, 91, 297, 298, 256, 0, 287,
+ 288, 289, 290, 297, 298, 339, 297, 298, 59, 297,
+ 298, 296, 300, 301, 302, 303, 304, 305, 306, 59,
+ 284, 309, 297, 298, 297, 298, 123, 291, 125, 126,
+ 40, 33, 297, 298, 36, 37, 38, 258, 40, 93,
+ 42, 43, 93, 45, 93, 309, 41, 297, 298, 41,
+ 297, 298, 297, 298, 297, 298, 123, 59, 297, 298,
+ 297, 298, 64, 125, 256, 257, 258, 259, 260, 261,
+ 123, 263, 264, 265, 266, 267, 268, 269, 270, 271,
+ 272, 273, 274, 275, 348, 297, 298, 279, 280, 91,
+ 282, 283, 284, 285, 286, 297, 298, 297, 298, 291,
+ 292, 293, 294, 295, 296, 306, 91, 299, 309, 41,
+ 41, 312, 313, 314, 59, 41, 308, 59, 310, 311,
+ 41, 123, 297, 298, 126, 59, 272, 273, 274, 275,
+ 41, 8, 32, 279, 13, 281, 297, 298, 123, 144,
+ 348, 287, 288, 41, 309, 309, 44, 190, 312, 313,
+ 314, 297, 298, 96, 300, 301, 302, 303, 304, 256,
+ 257, 258, 259, 260, 261, 63, 263, 264, 265, 266,
+ 267, 268, 269, 270, 271, 272, 273, 274, 275, 297,
+ 298, -1, 279, 280, -1, 282, 283, 284, 285, 286,
+ -1, -1, -1, 91, 291, 292, 293, 294, 295, 296,
+ 125, -1, 299, 91, 266, 267, 268, -1, 270, 271,
+ -1, 308, -1, 310, 311, -1, 41, -1, -1, 44,
+ -1, 272, 273, 274, 275, 123, -1, -1, 279, -1,
+ -1, -1, -1, 58, 59, 123, -1, -1, 63, -1,
+ -1, -1, -1, 297, 298, -1, 297, 298, 297, 298,
+ -1, -1, -1, -1, 256, 257, 258, 259, 260, 261,
+ -1, 263, 264, 265, -1, -1, 91, 269, 93, -1,
+ 272, 273, 274, 275, -1, -1, -1, 279, 280, -1,
+ 282, 283, 284, 285, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, 295, 296, -1, -1, 299, 123, -1,
+ -1, -1, 287, 288, 289, 290, 308, 33, 310, 311,
+ 36, 37, 38, -1, 40, 41, 42, 43, 44, 45,
+ 305, 306, -1, -1, 309, -1, -1, 312, 313, 314,
+ -1, -1, 58, 59, -1, -1, -1, 63, 64, -1,
+ -1, 266, 267, 268, -1, 270, 271, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
+ -1, -1, -1, 279, -1, 91, -1, 93, 33, -1,
+ -1, 36, 37, 38, -1, 40, 41, 42, 43, 44,
+ 45, 297, 298, 281, -1, -1, -1, -1, -1, 287,
+ 288, 289, 290, 58, 59, -1, -1, 123, 63, 64,
+ 126, 289, 300, 301, 302, 303, 304, 305, 306, -1,
+ -1, 309, -1, -1, 312, 313, 314, -1, 306, -1,
+ -1, 309, -1, -1, 312, 313, 314, 33, 93, -1,
+ 36, 37, 38, -1, 40, -1, 42, 43, -1, 45,
+ -1, -1, -1, -1, -1, -1, -1, 272, 273, 274,
+ 275, -1, -1, 59, 279, -1, 281, -1, 64, -1,
+ -1, 126, 287, 288, 289, 290, 304, 305, 306, -1,
+ 308, -1, 297, 298, -1, 300, 301, 302, 303, 304,
+ 305, 306, -1, -1, 309, 91, -1, 312, 313, 314,
+ -1, -1, 41, -1, -1, 44, -1, 335, -1, -1,
+ -1, -1, -1, -1, 342, -1, -1, -1, 346, -1,
+ 59, -1, -1, 91, -1, -1, -1, 123, -1, -1,
+ 126, 359, 360, -1, -1, -1, -1, -1, -1, -1,
+ -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ -1, -1, -1, 269, 93, 123, 272, 273, 274, 275,
+ -1, -1, -1, 279, 280, 281, 282, 283, 284, 285,
+ 286, 287, 288, 289, 290, 291, 292, 293, 294, 295,
+ 296, 297, 298, 299, 300, 301, 302, 303, 304, 305,
+ 306, -1, 308, 309, 310, 311, 312, 313, 314, -1,
+ -1, -1, 257, 258, 259, 260, 261, -1, 263, 264,
+ 265, -1, -1, -1, 269, -1, -1, 272, 273, 274,
+ 275, -1, -1, -1, 279, 280, 281, 282, 283, 284,
+ 285, 286, 287, 288, 289, 290, 291, 292, 293, 294,
+ 295, 296, 297, 298, 299, 300, 301, 302, 303, 304,
+ 305, 306, -1, 308, 309, 310, 311, 312, 313, 314,
+ 256, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ -1, -1, -1, 269, -1, 91, 272, 273, 274, 275,
+ -1, -1, -1, 279, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, 33, -1, 299, 36, 37, 38, 123, 40, -1,
+ 42, 43, 308, 45, 310, 311, -1, -1, 13, 287,
+ -1, 289, 290, -1, -1, -1, -1, 59, -1, -1,
+ -1, -1, 64, 272, 273, 274, 275, 305, 306, -1,
+ 279, 309, -1, -1, 312, 313, 314, 42, -1, -1,
+ 45, -1, -1, -1, -1, -1, -1, 33, 297, 91,
+ 36, 37, 38, -1, 40, -1, 42, 43, -1, 45,
+ -1, -1, 26, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 81, -1, 64, 43,
+ 44, 123, -1, -1, 126, -1, 50, -1, -1, -1,
+ 95, -1, -1, -1, -1, -1, -1, -1, 62, 63,
+ 64, 65, -1, 33, -1, 91, 36, 37, 38, -1,
+ 40, -1, 42, 43, -1, 45, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 64, -1, 141, 123, -1, -1,
+ 126, -1, -1, 107, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 91, -1, 289, 290, -1, 33, -1, -1, 36,
+ 37, 38, -1, 40, 179, 42, 43, -1, 45, 305,
+ 306, 186, -1, 309, -1, -1, 312, 313, 314, -1,
+ -1, -1, -1, 123, -1, -1, 126, 64, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 256, 257, 258, 259, 260, 261,
+ -1, 263, 264, 265, 91, -1, -1, 269, -1, -1,
+ 272, 273, 274, 275, -1, -1, -1, 279, 280, -1,
+ 282, 283, 284, 285, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, 295, 296, -1, 123, 299, -1, 126,
+ -1, 91, -1, -1, -1, 41, 308, -1, 310, 311,
+ -1, 257, 258, 259, 260, 261, 262, 263, 264, 265,
+ -1, -1, -1, 269, -1, -1, -1, 63, -1, -1,
+ -1, -1, -1, 123, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, -1, -1, 299, -1, 91, -1, -1, -1, -1,
+ -1, -1, 308, -1, 310, 311, -1, 257, 258, 259,
+ 260, 261, -1, 263, 264, 265, -1, -1, -1, 269,
+ 58, -1, -1, -1, -1, 63, -1, 123, -1, -1,
+ 280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
+ -1, 291, 292, 293, 294, 295, 296, -1, -1, 299,
+ -1, -1, -1, 91, -1, -1, -1, -1, 308, -1,
+ 310, 311, -1, -1, -1, -1, 41, -1, -1, 44,
+ 257, 258, 259, 260, 261, -1, 263, 264, 265, -1,
+ -1, -1, 269, 58, 59, 123, -1, -1, 63, -1,
+ -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
+ -1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
+ 33, -1, 299, 36, 37, 38, -1, 40, 93, 42,
+ 43, 308, 45, 310, 311, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 59, 287, 288, 289,
+ 290, 64, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 301, 302, 303, 304, 305, 306, -1, -1, 309,
+ -1, -1, 312, 313, 314, -1, 33, -1, 91, 36,
+ 37, 38, -1, 40, 41, 42, 43, -1, 45, -1,
+ -1, -1, -1, -1, -1, 281, -1, -1, -1, -1,
+ -1, 287, 288, 289, 290, -1, -1, 64, -1, -1,
+ -1, -1, -1, 126, 300, 301, 302, 303, 304, 305,
+ 306, -1, -1, 309, -1, -1, 312, 313, 314, -1,
+ -1, -1, 33, -1, 91, 36, 37, 38, -1, 40,
+ -1, 42, 43, -1, 45, -1, -1, -1, -1, -1,
+ -1, -1, -1, 281, -1, -1, -1, -1, -1, 287,
+ 288, 289, 290, 64, -1, -1, -1, -1, -1, 126,
+ -1, -1, 300, 301, 302, 303, 304, 305, 306, -1,
+ -1, 309, -1, -1, 312, 313, 314, -1, -1, -1,
+ 91, 33, 93, -1, 36, 37, 38, -1, 40, 41,
+ 42, 43, -1, 45, -1, -1, -1, 272, 273, 274,
+ 275, -1, -1, -1, 279, -1, 281, -1, -1, -1,
+ -1, -1, 64, 288, -1, 126, -1, -1, -1, -1,
+ -1, -1, 297, 298, -1, 300, 301, 302, 303, 304,
+ 41, -1, -1, 44, 257, 258, 259, 260, 261, 91,
+ 263, 264, 265, -1, -1, -1, 269, 58, 59, -1,
+ -1, -1, 63, -1, -1, -1, -1, 280, -1, 282,
+ 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
+ 293, 294, 295, 296, 126, -1, 299, -1, -1, -1,
+ -1, -1, 93, -1, -1, 308, 41, 310, 311, 44,
+ 257, 258, 259, 260, 261, -1, 263, 264, 265, -1,
+ -1, -1, 269, 58, 59, -1, -1, -1, 63, -1,
+ -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
+ -1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
+ -1, -1, 299, -1, -1, -1, -1, -1, 93, -1,
+ -1, 308, -1, 310, 311, -1, 257, 258, 259, 260,
+ 261, -1, 263, 264, 265, -1, 33, -1, 269, 36,
+ 37, 38, -1, 40, 41, 42, 43, -1, 45, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, 295, 296, -1, 64, 299, -1,
+ -1, -1, -1, -1, -1, -1, -1, 308, -1, 310,
+ 311, -1, -1, -1, -1, 257, 258, 259, 260, 261,
+ -1, 263, 264, 265, 91, 33, -1, 269, 36, 37,
+ 38, -1, 40, -1, 42, 43, -1, 45, 280, -1,
+ 282, 283, 284, 285, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, 295, 296, -1, 64, 299, -1, 126,
+ -1, -1, -1, -1, -1, -1, 308, -1, 310, 311,
+ -1, 272, 273, 274, 275, -1, -1, -1, 279, -1,
+ 281, 33, -1, 91, 36, 37, 38, -1, 40, 41,
+ 42, 43, -1, 45, -1, -1, 297, 298, -1, 300,
+ 301, 302, 303, 304, -1, -1, -1, -1, -1, -1,
+ -1, -1, 64, -1, -1, -1, -1, -1, 126, -1,
+ -1, -1, -1, -1, -1, -1, -1, 272, 273, 274,
+ 275, -1, -1, -1, 279, -1, 281, 33, -1, 91,
+ 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
+ -1, -1, 297, 298, -1, 300, 301, 302, 303, 304,
+ -1, -1, -1, -1, -1, -1, -1, -1, 64, -1,
+ -1, -1, -1, -1, 126, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 257, 258, 259, 260, 261, 91, 263, 264, 265, -1,
+ 33, -1, 269, 36, 37, 38, -1, 40, 41, 42,
+ 43, -1, 45, 280, -1, 282, 283, 284, 285, 286,
+ -1, -1, -1, -1, 291, 292, 293, 294, 295, 296,
+ 126, 64, 299, -1, -1, -1, -1, -1, -1, -1,
+ -1, 308, -1, 310, 311, -1, -1, -1, 256, 257,
+ 258, 259, 260, 261, -1, 263, 264, 265, 91, -1,
+ -1, 269, 41, -1, -1, 44, -1, -1, -1, -1,
+ -1, -1, 280, -1, 282, 283, 284, 285, 286, 58,
+ 59, -1, -1, 291, 292, 293, 294, 295, 296, -1,
+ -1, 299, -1, 126, -1, -1, -1, -1, -1, -1,
+ 308, -1, 310, 311, -1, 257, 258, 259, 260, 261,
+ -1, 263, 264, 265, 93, -1, -1, 269, 41, -1,
+ -1, 44, -1, -1, -1, -1, -1, -1, 280, -1,
+ 282, 283, 284, 285, 286, 58, 59, -1, -1, 291,
+ 292, 293, 294, 295, 296, -1, -1, 299, -1, -1,
+ -1, -1, -1, -1, -1, -1, 308, -1, 310, 311,
+ -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ 93, 33, -1, 269, 36, 37, 38, -1, 40, -1,
+ 42, 43, -1, 45, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, -1, 64, 299, -1, -1, -1, -1, -1, -1,
+ -1, -1, 308, -1, 310, 311, -1, -1, -1, -1,
+ 41, -1, -1, 44, 257, 258, 259, 260, 261, 91,
+ 263, 264, 265, -1, -1, -1, 269, 58, 59, -1,
+ -1, -1, 63, -1, -1, -1, -1, 280, -1, 282,
+ 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
+ 293, 294, 295, 296, 126, 41, 299, -1, 44, -1,
+ 91, -1, 93, -1, -1, 308, -1, 310, 311, -1,
+ -1, -1, 58, 59, -1, -1, -1, 63, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
+ 279, -1, 123, -1, -1, -1, -1, -1, 41, -1,
+ -1, 44, -1, -1, -1, 91, -1, 93, 297, 298,
+ -1, 300, -1, -1, -1, 58, 59, -1, -1, -1,
+ 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 123, -1, 272,
+ 273, 274, 275, -1, 41, -1, 279, 44, -1, -1,
+ 93, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 58, 59, -1, 297, 298, 63, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 123, -1, -1, -1, -1, 257, 258, 259, 260, 261,
+ -1, 263, 264, 265, 91, -1, 93, 269, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 280, -1,
+ 282, 283, 284, 285, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, 295, 296, -1, -1, 299, -1, 91,
+ -1, -1, -1, -1, -1, -1, 308, -1, 310, 311,
+ -1, 272, 273, 274, 275, -1, -1, -1, 279, -1,
+ 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
+ -1, 123, -1, -1, -1, -1, 297, 298, -1, 300,
+ 301, 302, 303, 304, 305, 306, -1, -1, 309, -1,
+ -1, 312, 313, 314, -1, -1, 272, 273, 274, 275,
+ -1, 41, -1, 279, 44, 281, -1, -1, -1, -1,
+ -1, 287, 288, 289, 290, -1, -1, -1, 58, 59,
+ -1, 297, 298, 63, 300, 301, 302, 303, 304, 305,
+ 306, -1, -1, 309, -1, -1, 312, 313, 314, 272,
+ 273, 274, 275, -1, -1, -1, 279, -1, 281, -1,
+ -1, -1, -1, 93, 287, 288, 289, 290, -1, -1,
+ -1, -1, -1, -1, 297, 298, -1, 300, 301, 302,
+ 303, 304, 305, 306, -1, -1, 309, -1, -1, 312,
+ 313, 314, -1, 123, -1, 272, 273, 274, 275, 91,
+ 41, -1, 279, -1, 281, -1, -1, -1, -1, -1,
+ 287, 288, 289, 290, -1, -1, -1, 58, 59, -1,
+ 297, 298, 63, 300, 301, 302, 303, 304, 305, 306,
+ -1, 123, 309, -1, -1, 312, 313, 314, -1, -1,
+ -1, -1, -1, 41, -1, 287, 288, 289, 290, -1,
+ 91, -1, 93, -1, -1, -1, -1, -1, -1, -1,
+ 58, 59, 304, 305, 306, 63, -1, 309, -1, -1,
+ 312, 313, 314, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 123, -1, -1, -1, -1, 41, -1, -1,
+ 44, -1, -1, 91, -1, 93, -1, -1, -1, -1,
+ -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 123, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 93,
+ -1, -1, 272, 273, 274, 275, -1, -1, -1, 279,
+ -1, 281, -1, -1, -1, -1, -1, 287, 288, 289,
+ 290, -1, -1, 41, -1, -1, 44, 297, 298, 123,
+ 300, 301, 302, 303, 304, 305, 306, -1, -1, 309,
+ 58, 59, 312, 313, 314, 63, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, -1, -1, -1, -1, -1, 41, -1, -1, 44,
+ 302, 303, 304, 305, 306, 93, -1, 309, -1, -1,
+ 312, 313, 314, 58, 59, -1, -1, -1, 63, -1,
+ -1, 272, 273, 274, 275, -1, -1, -1, 279, -1,
+ 281, -1, -1, -1, -1, 123, 287, 288, 289, 290,
+ -1, -1, -1, -1, -1, -1, 297, 298, 93, 300,
+ 301, 302, 303, 304, 305, 306, -1, -1, 309, -1,
+ -1, 312, 313, 314, 272, 273, 274, 275, -1, 41,
+ -1, 279, -1, 281, -1, -1, -1, -1, 123, 287,
+ 288, 289, 290, -1, -1, -1, 58, 59, -1, 297,
+ 298, 63, 300, 301, 302, 303, 304, 305, 306, -1,
+ -1, 309, -1, -1, 312, 313, 314, -1, 272, 273,
+ 274, 275, -1, 41, -1, 279, 44, 281, -1, 91,
+ -1, 93, -1, 287, 288, 289, 290, -1, -1, -1,
+ 58, 59, -1, 297, 298, 63, 300, 301, 302, 303,
+ 304, 305, 306, -1, -1, 309, -1, -1, 312, 313,
+ 314, 123, -1, -1, -1, -1, 41, 25, 26, 44,
+ -1, -1, -1, -1, -1, 93, -1, -1, -1, 37,
+ -1, -1, -1, 58, 59, 43, 44, 45, 63, -1,
+ -1, -1, 50, -1, 272, 273, 274, 275, -1, -1,
+ -1, 279, -1, 281, 62, 63, 64, 65, -1, 287,
+ 288, 289, 290, -1, -1, -1, -1, -1, 93, 297,
+ 298, -1, 300, 301, 302, 303, 304, 305, 306, -1,
+ -1, 309, -1, -1, 312, 313, 314, 272, 273, 274,
+ 275, -1, 41, -1, 279, 44, 281, -1, -1, 107,
+ -1, -1, 287, 288, 289, 290, -1, -1, -1, 58,
+ 59, -1, 297, 298, 63, 300, 301, 302, 303, 304,
+ 305, 306, -1, -1, 309, -1, -1, 312, 313, 314,
+ -1, -1, -1, -1, -1, 41, -1, -1, 44, -1,
+ -1, -1, -1, -1, 93, -1, -1, -1, -1, -1,
+ -1, -1, 58, 59, -1, -1, -1, 63, -1, 167,
+ 272, 273, 274, 275, -1, -1, -1, 279, -1, 281,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, -1, -1, 191, -1, 297, 298, 93, 300, 301,
+ 302, 303, 304, 305, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, -1, 272, 273, 274, 275, -1, 41,
+ -1, 279, 44, 281, -1, -1, -1, -1, -1, 287,
+ 288, 289, 290, -1, -1, -1, 58, 59, -1, 297,
+ 298, 63, 300, 301, 302, 303, 304, 305, 306, -1,
+ -1, 309, -1, -1, 312, 313, 314, 272, 273, 274,
+ 275, -1, 41, -1, 279, 44, 281, -1, -1, -1,
+ -1, 93, 287, 288, 289, 290, -1, -1, -1, 58,
+ 59, -1, 297, 298, 63, 300, 301, 302, 303, 304,
+ 305, 306, -1, -1, 309, -1, -1, 312, 313, 314,
+ 41, -1, -1, 44, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 93, -1, -1, 58, 59, -1,
+ -1, -1, 63, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, 41, -1,
+ 279, 44, 281, -1, -1, -1, -1, -1, 287, 288,
+ 289, 290, 93, -1, -1, 58, 59, -1, 297, 298,
+ 63, 300, 301, 302, 303, 304, 305, 306, -1, -1,
+ 309, -1, -1, 312, 313, 314, 272, 273, 274, 275,
+ -1, 41, -1, 279, 44, 281, -1, -1, -1, -1,
+ 93, 287, 288, 289, 290, -1, -1, -1, 58, 59,
+ -1, 297, 298, 63, 300, 301, 302, 303, 304, 305,
+ 306, -1, -1, 309, -1, -1, 312, 313, 314, 41,
+ -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 93, -1, -1, 58, 59, -1, -1,
+ -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
+ 272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, 93, 58, 59, -1, 297, 298, 63, 300, 301,
+ 302, 303, 304, 305, 306, -1, -1, 309, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, 41, -1,
+ 279, 44, 281, -1, -1, -1, -1, 93, 287, 288,
+ 289, 290, -1, -1, -1, 58, 59, -1, 297, 298,
+ 63, 300, 301, 302, 303, 304, 305, 306, -1, -1,
+ -1, 272, 273, 274, 275, -1, 41, -1, 279, 44,
+ 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
+ 93, -1, -1, 58, 59, -1, 297, 298, 63, 300,
+ 301, 302, 303, 304, 305, 306, -1, -1, -1, 272,
+ 273, 274, 275, -1, 41, -1, 279, 44, 281, -1,
+ -1, -1, -1, -1, 287, 288, 289, 290, 93, -1,
+ -1, 58, 59, -1, 297, 298, 63, 300, 301, 302,
+ 303, 304, 305, 306, -1, -1, -1, -1, -1, -1,
+ -1, -1, 272, 273, 274, 275, -1, 41, -1, 279,
+ 44, 281, -1, -1, -1, -1, 93, 287, 288, 289,
+ 290, -1, -1, -1, 58, 59, -1, 297, 298, 63,
+ 300, 301, 302, 303, 304, 305, 306, -1, -1, -1,
+ 272, 273, 274, 275, -1, 41, -1, 279, 44, 281,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, 93,
+ -1, -1, 58, 59, -1, 297, 298, 63, 300, 301,
+ 302, 303, 304, 305, 306, -1, 272, 273, 274, 275,
+ -1, 41, -1, 279, 44, 281, -1, -1, -1, -1,
+ -1, 287, 288, 289, 290, -1, -1, 93, 58, 59,
+ -1, 297, 298, 63, 300, 301, 302, 303, 304, 305,
+ 306, -1, -1, -1, -1, -1, -1, -1, -1, 272,
+ 273, 274, 275, -1, 41, -1, 279, 44, 281, -1,
+ -1, -1, -1, 93, 287, 288, 289, 290, -1, -1,
+ -1, 58, 59, -1, 297, 298, 63, 300, 301, 302,
+ 303, 304, 305, 306, -1, -1, -1, 272, 273, 274,
+ 275, -1, 41, -1, 279, 44, 281, -1, -1, -1,
+ -1, -1, 287, 288, 289, 290, 93, -1, -1, 58,
+ 59, -1, 297, 298, 63, 300, 301, 302, 303, 304,
+ 305, -1, -1, -1, -1, 272, 273, 274, 275, -1,
+ 41, -1, 279, 44, 281, -1, -1, -1, -1, -1,
+ 287, 288, -1, 290, 93, -1, -1, 58, 59, -1,
+ 297, 298, 63, 300, 301, 302, 303, 304, 305, -1,
+ 91, -1, -1, -1, -1, -1, -1, -1, 272, 273,
+ 274, 275, -1, 41, -1, 279, 44, 281, -1, -1,
+ -1, -1, 93, 287, 288, -1, -1, -1, -1, -1,
+ 58, 59, 123, 297, 298, 63, 300, 301, 302, 303,
+ 304, 305, -1, -1, -1, -1, 272, 273, 274, 275,
+ -1, 41, -1, 279, 44, 281, -1, -1, -1, -1,
+ -1, 287, 288, 41, -1, 93, 44, -1, 58, 59,
+ -1, 297, 298, 63, 300, 301, 302, 303, 304, -1,
+ 58, 59, 272, 273, 274, 275, -1, -1, -1, 279,
+ -1, 281, -1, -1, -1, -1, -1, 287, 288, -1,
+ -1, -1, -1, 93, -1, -1, 41, 297, 298, 44,
+ 300, 301, 302, 303, 304, 93, -1, -1, -1, 41,
+ -1, -1, 44, 58, 59, 272, 273, 274, 275, -1,
+ -1, -1, 279, -1, 281, -1, 58, 59, -1, -1,
+ 287, 288, -1, -1, -1, -1, 63, -1, -1, -1,
+ 297, 298, -1, 300, 301, 302, 303, 304, 93, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
+ 279, 93, 281, -1, 91, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 297, 298,
+ -1, 300, 301, 302, 303, -1, 287, 288, 289, 290,
+ -1, 272, 273, 274, 275, -1, 123, -1, 279, -1,
+ 281, -1, 303, 304, 305, 306, -1, -1, 309, -1,
+ -1, 312, 313, 314, -1, -1, 297, 298, -1, 300,
+ 301, 302, 63, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
+ -1, 279, -1, 281, -1, -1, -1, -1, -1, -1,
+ 91, -1, -1, -1, -1, -1, -1, -1, -1, 297,
+ 298, -1, 300, 301, -1, -1, -1, -1, -1, -1,
+ -1, -1, 272, 273, 274, 275, -1, -1, -1, 279,
+ -1, -1, 123, -1, 272, 273, 274, 275, -1, -1,
+ -1, 279, -1, -1, -1, -1, 30, 297, 298, -1,
+ 300, -1, -1, -1, 38, -1, -1, -1, 42, 297,
+ 298, 45, -1, -1, -1, -1, -1, -1, 52, 53,
+ 54, 55, 56, -1, -1, 59, 60, 272, 273, 274,
+ 275, -1, 66, -1, 279, -1, -1, -1, -1, -1,
+ 272, 273, 274, 275, -1, -1, -1, 279, -1, -1,
+ -1, -1, 297, 298, 281, -1, -1, -1, -1, 93,
+ 287, 288, 289, 290, -1, 297, 298, -1, -1, -1,
+ -1, -1, -1, 300, 301, 302, 303, 304, 305, 306,
+ -1, -1, 309, -1, -1, 312, 313, 314, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 151, 152, 153,
+ 154, 155, 156, 157, 158, 159, 160, 161, 162, 163,
+ 164, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 281, -1, 176, -1, -1, -1, 287, 288, 289, 290,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 301, 302, 303, 304, 305, 306, -1, -1, 309, -1,
+ -1, 312, 313, 314, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 255, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 286,
+};
+#define YYFINAL 1
+#ifndef YYDEBUG
+#define YYDEBUG 0
+#endif
+#define YYMAXTOKEN 314
+#if YYDEBUG
+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,
+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,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,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,"WORD","METHOD","FUNCMETH","THING",
+"PMFUNC","PRIVATEREF","FUNC0SUB","UNIOPSUB","LSTOPSUB","LABEL","FORMAT","SUB",
+"ANONSUB","PACKAGE","USE","WHILE","UNTIL","IF","UNLESS","ELSE","ELSIF",
+"CONTINUE","FOR","LOOPEX","DOTDOT","FUNC0","FUNC1","FUNC","UNIOP","LSTOP",
+"RELOP","EQOP","MULOP","ADDOP","DOLSHARP","DO","HASHBRACK","NOAMP","LOCAL","MY",
+"OROP","ANDOP","NOTOP","ASSIGNOP","OROR","ANDAND","BITOROP","BITANDOP",
+"SHIFTOP","MATCHOP","UMINUS","REFGEN","POWOP","PREINC","PREDEC","POSTINC",
+"POSTDEC","ARROW",
+};
+char *yyrule[] = {
+"$accept : prog",
+"$$1 :",
+"prog : $$1 lineseq",
+"block : '{' remember lineseq '}'",
+"remember :",
+"mblock : '{' mremember lineseq '}'",
+"mremember :",
+"lineseq :",
+"lineseq : lineseq decl",
+"lineseq : lineseq line",
+"line : label cond",
+"line : loop",
+"line : label ';'",
+"line : label sideff ';'",
+"sideff : error",
+"sideff : expr",
+"sideff : expr IF expr",
+"sideff : expr UNLESS expr",
+"sideff : expr WHILE expr",
+"sideff : expr UNTIL iexpr",
+"sideff : expr FOR expr",
+"else :",
+"else : ELSE mblock",
+"else : ELSIF '(' mexpr ')' mblock else",
+"cond : IF '(' remember mexpr ')' mblock else",
+"cond : UNLESS '(' remember miexpr ')' mblock else",
+"cont :",
+"cont : CONTINUE block",
+"loop : label WHILE '(' remember mtexpr ')' mblock cont",
+"loop : label UNTIL '(' remember miexpr ')' mblock cont",
+"loop : label FOR MY remember my_scalar '(' mexpr ')' mblock cont",
+"loop : label FOR scalar '(' remember mexpr ')' mblock cont",
+"loop : label FOR '(' remember mexpr ')' mblock cont",
+"loop : label FOR '(' remember mnexpr ';' mtexpr ';' mnexpr ')' mblock",
+"loop : label block cont",
+"nexpr :",
+"nexpr : sideff",
+"texpr :",
+"texpr : expr",
+"iexpr : expr",
+"mexpr : expr",
+"mnexpr : nexpr",
+"mtexpr : texpr",
+"miexpr : iexpr",
+"label :",
+"label : LABEL",
+"decl : format",
+"decl : subrout",
+"decl : package",
+"decl : use",
+"format : FORMAT startformsub formname block",
+"formname : WORD",
+"formname :",
+"subrout : SUB startsub subname proto subbody",
+"startsub :",
+"startanonsub :",
+"startformsub :",
+"subname : WORD",
+"proto :",
+"proto : THING",
+"subbody : block",
+"subbody : ';'",
+"package : PACKAGE WORD ';'",
+"package : PACKAGE ';'",
+"$$2 :",
+"use : USE startsub $$2 WORD WORD listexpr ';'",
+"expr : expr ANDOP expr",
+"expr : expr OROP expr",
+"expr : argexpr",
+"argexpr : argexpr ','",
+"argexpr : argexpr ',' term",
+"argexpr : term",
+"listop : LSTOP indirob argexpr",
+"listop : FUNC '(' indirob expr ')'",
+"listop : term ARROW method '(' listexprcom ')'",
+"listop : METHOD indirob listexpr",
+"listop : FUNCMETH indirob '(' listexprcom ')'",
+"listop : LSTOP listexpr",
+"listop : FUNC '(' listexprcom ')'",
+"$$3 :",
+"listop : LSTOPSUB startanonsub block $$3 listexpr",
+"method : METHOD",
+"method : scalar",
+"term : term ASSIGNOP term",
+"term : term POWOP term",
+"term : term MULOP term",
+"term : term ADDOP term",
+"term : term SHIFTOP term",
+"term : term RELOP term",
+"term : term EQOP term",
+"term : term BITANDOP term",
+"term : term BITOROP term",
+"term : term DOTDOT term",
+"term : term ANDAND term",
+"term : term OROR term",
+"term : term '?' term ':' term",
+"term : term MATCHOP term",
+"term : '-' term",
+"term : '+' term",
+"term : '!' term",
+"term : '~' term",
+"term : REFGEN term",
+"term : term POSTINC",
+"term : term POSTDEC",
+"term : PREINC term",
+"term : PREDEC term",
+"term : local term",
+"term : '(' expr ')'",
+"term : '(' ')'",
+"term : '[' expr ']'",
+"term : '[' ']'",
+"term : HASHBRACK expr ';' '}'",
+"term : HASHBRACK ';' '}'",
+"term : ANONSUB startanonsub proto block",
+"term : scalar",
+"term : star '{' expr ';' '}'",
+"term : star",
+"term : scalar '[' expr ']'",
+"term : term ARROW '[' expr ']'",
+"term : term '[' expr ']'",
+"term : hsh",
+"term : ary",
+"term : arylen",
+"term : scalar '{' expr ';' '}'",
+"term : term ARROW '{' expr ';' '}'",
+"term : term '{' expr ';' '}'",
+"term : '(' expr ')' '[' expr ']'",
+"term : '(' ')' '[' expr ']'",
+"term : ary '[' expr ']'",
+"term : ary '{' expr ';' '}'",
+"term : THING",
+"term : amper",
+"term : amper '(' ')'",
+"term : amper '(' expr ')'",
+"term : NOAMP WORD listexpr",
+"term : DO term",
+"term : DO block",
+"term : DO WORD '(' ')'",
+"term : DO WORD '(' expr ')'",
+"term : DO scalar '(' ')'",
+"term : DO scalar '(' expr ')'",
+"term : term ARROW '(' ')'",
+"term : term ARROW '(' expr ')'",
+"term : LOOPEX",
+"term : LOOPEX term",
+"term : NOTOP argexpr",
+"term : UNIOP",
+"term : UNIOP block",
+"term : UNIOP term",
+"term : UNIOPSUB term",
+"term : FUNC0",
+"term : FUNC0 '(' ')'",
+"term : FUNC0SUB",
+"term : FUNC1 '(' ')'",
+"term : FUNC1 '(' expr ')'",
+"term : PMFUNC '(' term ')'",
+"term : PMFUNC '(' term ',' term ')'",
+"term : WORD",
+"term : listop",
+"listexpr :",
+"listexpr : argexpr",
+"listexprcom :",
+"listexprcom : expr",
+"listexprcom : expr ','",
+"local : LOCAL",
+"local : MY",
+"my_scalar : scalar",
+"amper : '&' indirob",
+"scalar : '$' indirob",
+"ary : '@' indirob",
+"hsh : '%' indirob",
+"arylen : DOLSHARP indirob",
+"star : '*' indirob",
+"indirob : WORD",
+"indirob : scalar",
+"indirob : block",
+"indirob : PRIVATEREF",
+};
+#endif
+#define yyclearin (yychar=(-1))
+#define yyerrok (yyerrflag=0)
+#ifdef YYSTACKSIZE
+#ifndef YYMAXDEPTH
+#define YYMAXDEPTH YYSTACKSIZE
+#endif
+#else
+#ifdef YYMAXDEPTH
+#define YYSTACKSIZE YYMAXDEPTH
+#else
+#define YYSTACKSIZE 500
+#define YYMAXDEPTH 500
+#endif
+#endif
+int yydebug;
+int yynerrs;
+int yyerrflag;
+int yychar;
+short *yyssp;
+YYSTYPE *yyvsp;
+YYSTYPE yyval;
+YYSTYPE yylval;
+#line 643 "perly.y"
+ /* PROGRAM */
+#line 1353 "perly.c"
+#define YYABORT goto yyabort
+#define YYACCEPT goto yyaccept
+#define YYERROR goto yyerrlab
+
+struct ysv {
+ short* yyss;
+ YYSTYPE* yyvs;
+ int oldyydebug;
+ int oldyynerrs;
+ int oldyyerrflag;
+ int oldyychar;
+ YYSTYPE oldyyval;
+ YYSTYPE oldyylval;
+};
+
+void
+yydestruct(void *ptr)
+{
+ struct ysv* ysave = (struct ysv*)ptr;
+ if (ysave->yyss) Safefree(ysave->yyss);
+ if (ysave->yyvs) Safefree(ysave->yyvs);
+ yydebug = ysave->oldyydebug;
+ yynerrs = ysave->oldyynerrs;
+ yyerrflag = ysave->oldyyerrflag;
+ yychar = ysave->oldyychar;
+ yyval = ysave->oldyyval;
+ yylval = ysave->oldyylval;
+ Safefree(ysave);
+}
+
+int
+yyparse(void)
+{
+ register int yym, yyn, yystate;
+ register short *yyssp;
+ register YYSTYPE *yyvsp;
+ short* yyss;
+ YYSTYPE* yyvs;
+ unsigned yystacksize = YYSTACKSIZE;
+ int retval = 0;
+#if YYDEBUG
+ register char *yys;
+#ifndef __cplusplus
+ extern char *getenv();
+#endif
+#endif
+
+ struct ysv *ysave;
+ New(73, ysave, 1, struct ysv);
+ SAVEDESTRUCTOR(yydestruct, ysave);
+ ysave->oldyydebug = yydebug;
+ ysave->oldyynerrs = yynerrs;
+ ysave->oldyyerrflag = yyerrflag;
+ ysave->oldyychar = yychar;
+ ysave->oldyyval = yyval;
+ ysave->oldyylval = yylval;
+
+#if YYDEBUG
+ if (yys = getenv("YYDEBUG"))
+ {
+ yyn = *yys;
+ if (yyn >= '0' && yyn <= '9')
+ yydebug = yyn - '0';
+ }
+#endif
+
+ yynerrs = 0;
+ yyerrflag = 0;
+ yychar = (-1);
+
+ /*
+ ** Initialize private stacks (yyparse may be called from an action)
+ */
+ New(73, yyss, yystacksize, short);
+ New(73, yyvs, yystacksize, YYSTYPE);
+ ysave->yyss = yyss;
+ ysave->yyvs = yyvs;
+ if (!yyvs || !yyss)
+ goto yyoverflow;
+
+ yyssp = yyss;
+ yyvsp = yyvs;
+ *yyssp = yystate = 0;
+
+yyloop:
+ if (yyn = yydefred[yystate]) goto yyreduce;
+ if (yychar < 0)
+ {
+ if ((yychar = yylex()) < 0) yychar = 0;
+#if YYDEBUG
+ if (yydebug)
+ {
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate,
+ yychar, yys);
+ }
+#endif
+ }
+ if ((yyn = yysindex[yystate]) && (yyn += yychar) >= 0 &&
+ yyn <= YYTABLESIZE && yycheck[yyn] == yychar)
+ {
+#if YYDEBUG
+ if (yydebug)
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n",
+ yystate, yytable[yyn]);
+#endif
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+ /*
+ ** reallocate and recover. Note that pointers
+ ** have to be reset, or bad things will happen
+ */
+ int yyps_index = (yyssp - yyss);
+ int yypv_index = (yyvsp - yyvs);
+ yystacksize += YYSTACKSIZE;
+ ysave->yyvs = yyvs =
+ (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE));
+ ysave->yyss = yyss =
+ (short*)realloc((char*)yyss,yystacksize * sizeof(short));
+ if (!yyvs || !yyss)
+ goto yyoverflow;
+ yyssp = yyss + yyps_index;
+ yyvsp = yyvs + yypv_index;
+ }
+ *++yyssp = yystate = yytable[yyn];
+ *++yyvsp = yylval;
+ yychar = (-1);
+ if (yyerrflag > 0) --yyerrflag;
+ goto yyloop;
+ }
+ if ((yyn = yyrindex[yystate]) && (yyn += yychar) >= 0 &&
+ yyn <= YYTABLESIZE && yycheck[yyn] == yychar)
+ {
+ yyn = yytable[yyn];
+ goto yyreduce;
+ }
+ if (yyerrflag) goto yyinrecovery;
+#ifdef lint
+ goto yynewerror;
+#endif
+yynewerror:
+ yyerror("syntax error");
+#ifdef lint
+ goto yyerrlab;
+#endif
+yyerrlab:
+ ++yynerrs;
+yyinrecovery:
+ if (yyerrflag < 3)
+ {
+ yyerrflag = 3;
+ for (;;)
+ {
+ if ((yyn = yysindex[*yyssp]) && (yyn += YYERRCODE) >= 0 &&
+ yyn <= YYTABLESIZE && yycheck[yyn] == YYERRCODE)
+ {
+#if YYDEBUG
+ if (yydebug)
+ PerlIO_printf(Perl_debug_log,
+ "yydebug: state %d, error recovery shifting to state %d\n",
+ *yyssp, yytable[yyn]);
+#endif
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+ /*
+ ** reallocate and recover. Note that pointers
+ ** have to be reset, or bad things will happen
+ */
+ int yyps_index = (yyssp - yyss);
+ int yypv_index = (yyvsp - yyvs);
+ yystacksize += YYSTACKSIZE;
+ ysave->yyvs = yyvs = (YYSTYPE*)realloc((char*)yyvs,
+ yystacksize * sizeof(YYSTYPE));
+ ysave->yyss = yyss = (short*)realloc((char*)yyss,
+ yystacksize * sizeof(short));
+ if (!yyvs || !yyss)
+ goto yyoverflow;
+ yyssp = yyss + yyps_index;
+ yyvsp = yyvs + yypv_index;
+ }
+ *++yyssp = yystate = yytable[yyn];
+ *++yyvsp = yylval;
+ goto yyloop;
+ }
+ else
+ {
+#if YYDEBUG
+ if (yydebug)
+ PerlIO_printf(Perl_debug_log,
+ "yydebug: error recovery discarding state %d\n",
+ *yyssp);
+#endif
+ if (yyssp <= yyss) goto yyabort;
+ --yyssp;
+ --yyvsp;
+ }
+ }
+ }
+ else
+ {
+ if (yychar == 0) goto yyabort;
+#if YYDEBUG
+ if (yydebug)
+ {
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+ PerlIO_printf(Perl_debug_log,
+ "yydebug: state %d, error recovery discards token %d (%s)\n",
+ yystate, yychar, yys);
+ }
+#endif
+ yychar = (-1);
+ goto yyloop;
+ }
+yyreduce:
+#if YYDEBUG
+ if (yydebug)
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n",
+ yystate, yyn, yyrule[yyn]);
+#endif
+ yym = yylen[yyn];
+ yyval = yyvsp[1-yym];
+ switch (yyn)
+ {
+case 1:
+#line 94 "perly.y"
+{
+#if defined(YYDEBUG) && defined(DEBUGGING)
+ yydebug = (PL_debug & 1);
+#endif
+ PL_expect = XSTATE;
+ }
+break;
+case 2:
+#line 101 "perly.y"
+{ newPROG(yyvsp[0].opval); }
+break;
+case 3:
+#line 105 "perly.y"
+{ if (PL_copline > (line_t)yyvsp[-3].ival)
+ PL_copline = yyvsp[-3].ival;
+ yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
+break;
+case 4:
+#line 111 "perly.y"
+{ yyval.ival = block_start(TRUE); }
+break;
+case 5:
+#line 115 "perly.y"
+{ if (PL_copline > (line_t)yyvsp[-3].ival)
+ PL_copline = yyvsp[-3].ival;
+ yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
+break;
+case 6:
+#line 121 "perly.y"
+{ yyval.ival = block_start(FALSE); }
+break;
+case 7:
+#line 125 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 8:
+#line 127 "perly.y"
+{ yyval.opval = yyvsp[-1].opval; }
+break;
+case 9:
+#line 129 "perly.y"
+{ yyval.opval = append_list(OP_LINESEQ,
+ (LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval);
+ PL_pad_reset_pending = TRUE;
+ if (yyvsp[-1].opval && yyvsp[0].opval) PL_hints |= HINT_BLOCK_SCOPE; }
+break;
+case 10:
+#line 136 "perly.y"
+{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
+break;
+case 12:
+#line 139 "perly.y"
+{ if (yyvsp[-1].pval != Nullch) {
+ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
+ }
+ else {
+ yyval.opval = Nullop;
+ PL_copline = NOLINE;
+ }
+ PL_expect = XSTATE; }
+break;
+case 13:
+#line 148 "perly.y"
+{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval);
+ PL_expect = XSTATE; }
+break;
+case 14:
+#line 153 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 15:
+#line 155 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 16:
+#line 157 "perly.y"
+{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
+break;
+case 17:
+#line 159 "perly.y"
+{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
+break;
+case 18:
+#line 161 "perly.y"
+{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
+break;
+case 19:
+#line 163 "perly.y"
+{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);}
+break;
+case 20:
+#line 165 "perly.y"
+{ yyval.opval = newFOROP(0, Nullch, yyvsp[-1].ival,
+ Nullop, yyvsp[0].opval, yyvsp[-2].opval, Nullop); }
+break;
+case 21:
+#line 170 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 22:
+#line 172 "perly.y"
+{ yyval.opval = scope(yyvsp[0].opval); }
+break;
+case 23:
+#line 174 "perly.y"
+{ PL_copline = yyvsp[-5].ival;
+ yyval.opval = newSTATEOP(0, Nullch,
+ newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval));
+ PL_hints |= HINT_BLOCK_SCOPE; }
+break;
+case 24:
+#line 181 "perly.y"
+{ PL_copline = yyvsp[-6].ival;
+ yyval.opval = block_end(yyvsp[-4].ival,
+ newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
+break;
+case 25:
+#line 185 "perly.y"
+{ PL_copline = yyvsp[-6].ival;
+ yyval.opval = block_end(yyvsp[-4].ival,
+ newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
+break;
+case 26:
+#line 191 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 27:
+#line 193 "perly.y"
+{ yyval.opval = scope(yyvsp[0].opval); }
+break;
+case 28:
+#line 197 "perly.y"
+{ PL_copline = yyvsp[-6].ival;
+ yyval.opval = block_end(yyvsp[-4].ival,
+ newSTATEOP(0, yyvsp[-7].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
+break;
+case 29:
+#line 203 "perly.y"
+{ PL_copline = yyvsp[-6].ival;
+ yyval.opval = block_end(yyvsp[-4].ival,
+ newSTATEOP(0, yyvsp[-7].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
+break;
+case 30:
+#line 209 "perly.y"
+{ yyval.opval = block_end(yyvsp[-6].ival,
+ newFOROP(0, yyvsp[-9].pval, yyvsp[-8].ival, yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
+break;
+case 31:
+#line 212 "perly.y"
+{ yyval.opval = block_end(yyvsp[-4].ival,
+ newFOROP(0, yyvsp[-8].pval, yyvsp[-7].ival, mod(yyvsp[-6].opval, OP_ENTERLOOP),
+ yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
+break;
+case 32:
+#line 216 "perly.y"
+{ yyval.opval = block_end(yyvsp[-4].ival,
+ newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
+break;
+case 33:
+#line 220 "perly.y"
+{ OP *forop = append_elem(OP_LINESEQ,
+ scalar(yyvsp[-6].opval),
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ yyvsp[-9].ival, scalar(yyvsp[-4].opval),
+ yyvsp[0].opval, scalar(yyvsp[-2].opval)));
+ PL_copline = yyvsp[-9].ival;
+ yyval.opval = block_end(yyvsp[-7].ival, newSTATEOP(0, yyvsp[-10].pval, forop)); }
+break;
+case 34:
+#line 228 "perly.y"
+{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
+break;
+case 35:
+#line 234 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 37:
+#line 239 "perly.y"
+{ (void)scan_num("1"); yyval.opval = yylval.opval; }
+break;
+case 39:
+#line 244 "perly.y"
+{ yyval.opval = invert(scalar(yyvsp[0].opval)); }
+break;
+case 40:
+#line 248 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 41:
+#line 252 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 42:
+#line 256 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 43:
+#line 260 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 44:
+#line 264 "perly.y"
+{ yyval.pval = Nullch; }
+break;
+case 46:
+#line 269 "perly.y"
+{ yyval.ival = 0; }
+break;
+case 47:
+#line 271 "perly.y"
+{ yyval.ival = 0; }
+break;
+case 48:
+#line 273 "perly.y"
+{ yyval.ival = 0; }
+break;
+case 49:
+#line 275 "perly.y"
+{ yyval.ival = 0; }
+break;
+case 50:
+#line 279 "perly.y"
+{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
+break;
+case 51:
+#line 282 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 52:
+#line 283 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 53:
+#line 287 "perly.y"
+{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
+break;
+case 54:
+#line 291 "perly.y"
+{ yyval.ival = start_subparse(FALSE, 0); }
+break;
+case 55:
+#line 295 "perly.y"
+{ yyval.ival = start_subparse(FALSE, CVf_ANON); }
+break;
+case 56:
+#line 299 "perly.y"
+{ yyval.ival = start_subparse(TRUE, 0); }
+break;
+case 57:
+#line 302 "perly.y"
+{ char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, PL_na);
+ if (strEQ(name, "BEGIN") || strEQ(name, "END")
+ || strEQ(name, "INIT"))
+ CvUNIQUE_on(PL_compcv);
+ yyval.opval = yyvsp[0].opval; }
+break;
+case 58:
+#line 310 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 60:
+#line 314 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 61:
+#line 315 "perly.y"
+{ yyval.opval = Nullop; PL_expect = XSTATE; }
+break;
+case 62:
+#line 319 "perly.y"
+{ package(yyvsp[-1].opval); }
+break;
+case 63:
+#line 321 "perly.y"
+{ package(Nullop); }
+break;
+case 64:
+#line 325 "perly.y"
+{ CvUNIQUE_on(PL_compcv); /* It's a BEGIN {} */ }
+break;
+case 65:
+#line 327 "perly.y"
+{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
+break;
+case 66:
+#line 331 "perly.y"
+{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
+break;
+case 67:
+#line 333 "perly.y"
+{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
+break;
+case 69:
+#line 338 "perly.y"
+{ yyval.opval = yyvsp[-1].opval; }
+break;
+case 70:
+#line 340 "perly.y"
+{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
+break;
+case 72:
+#line 345 "perly.y"
+{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); }
+break;
+case 73:
+#line 348 "perly.y"
+{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); }
+break;
+case 74:
+#line 351 "perly.y"
+{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval),
+ newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
+break;
+case 75:
+#line 356 "perly.y"
+{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval),
+ newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); }
+break;
+case 76:
+#line 361 "perly.y"
+{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval),
+ newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); }
+break;
+case 77:
+#line 366 "perly.y"
+{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
+break;
+case 78:
+#line 368 "perly.y"
+{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
+break;
+case 79:
+#line 370 "perly.y"
+{ yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); }
+break;
+case 80:
+#line 372 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); }
+break;
+case 83:
+#line 382 "perly.y"
+{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
+break;
+case 84:
+#line 384 "perly.y"
+{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
+break;
+case 85:
+#line 386 "perly.y"
+{ if (yyvsp[-1].ival != OP_REPEAT)
+ scalar(yyvsp[-2].opval);
+ yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); }
+break;
+case 86:
+#line 390 "perly.y"
+{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
+break;
+case 87:
+#line 392 "perly.y"
+{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
+break;
+case 88:
+#line 394 "perly.y"
+{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
+break;
+case 89:
+#line 396 "perly.y"
+{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
+break;
+case 90:
+#line 398 "perly.y"
+{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
+break;
+case 91:
+#line 400 "perly.y"
+{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
+break;
+case 92:
+#line 402 "perly.y"
+{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
+break;
+case 93:
+#line 404 "perly.y"
+{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
+break;
+case 94:
+#line 406 "perly.y"
+{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
+break;
+case 95:
+#line 408 "perly.y"
+{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
+break;
+case 96:
+#line 410 "perly.y"
+{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
+break;
+case 97:
+#line 413 "perly.y"
+{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
+break;
+case 98:
+#line 415 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 99:
+#line 417 "perly.y"
+{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
+break;
+case 100:
+#line 419 "perly.y"
+{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
+break;
+case 101:
+#line 421 "perly.y"
+{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
+break;
+case 102:
+#line 423 "perly.y"
+{ yyval.opval = newUNOP(OP_POSTINC, 0,
+ mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
+break;
+case 103:
+#line 426 "perly.y"
+{ yyval.opval = newUNOP(OP_POSTDEC, 0,
+ mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
+break;
+case 104:
+#line 429 "perly.y"
+{ yyval.opval = newUNOP(OP_PREINC, 0,
+ mod(scalar(yyvsp[0].opval), OP_PREINC)); }
+break;
+case 105:
+#line 432 "perly.y"
+{ yyval.opval = newUNOP(OP_PREDEC, 0,
+ mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
+break;
+case 106:
+#line 435 "perly.y"
+{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
+break;
+case 107:
+#line 437 "perly.y"
+{ yyval.opval = sawparens(yyvsp[-1].opval); }
+break;
+case 108:
+#line 439 "perly.y"
+{ yyval.opval = sawparens(newNULLLIST()); }
+break;
+case 109:
+#line 441 "perly.y"
+{ yyval.opval = newANONLIST(yyvsp[-1].opval); }
+break;
+case 110:
+#line 443 "perly.y"
+{ yyval.opval = newANONLIST(Nullop); }
+break;
+case 111:
+#line 445 "perly.y"
+{ yyval.opval = newANONHASH(yyvsp[-2].opval); }
+break;
+case 112:
+#line 447 "perly.y"
+{ yyval.opval = newANONHASH(Nullop); }
+break;
+case 113:
+#line 449 "perly.y"
+{ yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
+break;
+case 114:
+#line 451 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 115:
+#line 453 "perly.y"
+{ yyval.opval = newBINOP(OP_GELEM, 0, yyvsp[-4].opval, scalar(yyvsp[-2].opval)); }
+break;
+case 116:
+#line 455 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 117:
+#line 457 "perly.y"
+{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
+break;
+case 118:
+#line 459 "perly.y"
+{ yyval.opval = newBINOP(OP_AELEM, 0,
+ ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
+ scalar(yyvsp[-1].opval));}
+break;
+case 119:
+#line 463 "perly.y"
+{ assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0,
+ ref(newAVREF(yyvsp[-3].opval),OP_RV2AV),
+ scalar(yyvsp[-1].opval));}
+break;
+case 120:
+#line 467 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 121:
+#line 469 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 122:
+#line 471 "perly.y"
+{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
+break;
+case 123:
+#line 473 "perly.y"
+{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
+ PL_expect = XOPERATOR; }
+break;
+case 124:
+#line 476 "perly.y"
+{ yyval.opval = newBINOP(OP_HELEM, 0,
+ ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
+ jmaybe(yyvsp[-2].opval));
+ PL_expect = XOPERATOR; }
+break;
+case 125:
+#line 481 "perly.y"
+{ assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0,
+ ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
+ jmaybe(yyvsp[-2].opval));
+ PL_expect = XOPERATOR; }
+break;
+case 126:
+#line 486 "perly.y"
+{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
+break;
+case 127:
+#line 488 "perly.y"
+{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
+break;
+case 128:
+#line 490 "perly.y"
+{ yyval.opval = prepend_elem(OP_ASLICE,
+ newOP(OP_PUSHMARK, 0),
+ newLISTOP(OP_ASLICE, 0,
+ list(yyvsp[-1].opval),
+ ref(yyvsp[-3].opval, OP_ASLICE))); }
+break;
+case 129:
+#line 496 "perly.y"
+{ yyval.opval = prepend_elem(OP_HSLICE,
+ newOP(OP_PUSHMARK, 0),
+ newLISTOP(OP_HSLICE, 0,
+ list(yyvsp[-2].opval),
+ ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)));
+ PL_expect = XOPERATOR; }
+break;
+case 130:
+#line 503 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 131:
+#line 505 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
+break;
+case 132:
+#line 507 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
+break;
+case 133:
+#line 509 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); }
+break;
+case 134:
+#line 512 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
+break;
+case 135:
+#line 515 "perly.y"
+{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); }
+break;
+case 136:
+#line 517 "perly.y"
+{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
+break;
+case 137:
+#line 519 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB,
+ OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ scalar(newCVREF(
+ (OPpENTERSUB_AMPER<<8),
+ scalar(yyvsp[-2].opval)
+ )),Nullop)); dep();}
+break;
+case 138:
+#line 527 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB,
+ OPf_SPECIAL|OPf_STACKED,
+ append_elem(OP_LIST,
+ yyvsp[-1].opval,
+ scalar(newCVREF(
+ (OPpENTERSUB_AMPER<<8),
+ scalar(yyvsp[-3].opval)
+ )))); dep();}
+break;
+case 139:
+#line 536 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();}
+break;
+case 140:
+#line 540 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ yyvsp[-1].opval,
+ scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();}
+break;
+case 141:
+#line 545 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newCVREF(0, scalar(yyvsp[-3].opval))); }
+break;
+case 142:
+#line 548 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, yyvsp[-1].opval,
+ newCVREF(0, scalar(yyvsp[-4].opval)))); }
+break;
+case 143:
+#line 552 "perly.y"
+{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
+ PL_hints |= HINT_BLOCK_SCOPE; }
+break;
+case 144:
+#line 555 "perly.y"
+{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
+break;
+case 145:
+#line 557 "perly.y"
+{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
+break;
+case 146:
+#line 559 "perly.y"
+{ yyval.opval = newOP(yyvsp[0].ival, 0); }
+break;
+case 147:
+#line 561 "perly.y"
+{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
+break;
+case 148:
+#line 563 "perly.y"
+{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
+break;
+case 149:
+#line 565 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
+break;
+case 150:
+#line 568 "perly.y"
+{ yyval.opval = newOP(yyvsp[0].ival, 0); }
+break;
+case 151:
+#line 570 "perly.y"
+{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
+break;
+case 152:
+#line 572 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ scalar(yyvsp[0].opval)); }
+break;
+case 153:
+#line 575 "perly.y"
+{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
+break;
+case 154:
+#line 577 "perly.y"
+{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
+break;
+case 155:
+#line 579 "perly.y"
+{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
+break;
+case 156:
+#line 581 "perly.y"
+{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
+break;
+case 159:
+#line 587 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 160:
+#line 589 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 161:
+#line 593 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 162:
+#line 595 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 163:
+#line 597 "perly.y"
+{ yyval.opval = yyvsp[-1].opval; }
+break;
+case 164:
+#line 600 "perly.y"
+{ yyval.ival = 0; }
+break;
+case 165:
+#line 601 "perly.y"
+{ yyval.ival = 1; }
+break;
+case 166:
+#line 605 "perly.y"
+{ PL_in_my = 0; yyval.opval = my(yyvsp[0].opval); }
+break;
+case 167:
+#line 609 "perly.y"
+{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
+break;
+case 168:
+#line 613 "perly.y"
+{ yyval.opval = newSVREF(yyvsp[0].opval); }
+break;
+case 169:
+#line 617 "perly.y"
+{ yyval.opval = newAVREF(yyvsp[0].opval); }
+break;
+case 170:
+#line 621 "perly.y"
+{ yyval.opval = newHVREF(yyvsp[0].opval); }
+break;
+case 171:
+#line 625 "perly.y"
+{ yyval.opval = newAVREF(yyvsp[0].opval); }
+break;
+case 172:
+#line 629 "perly.y"
+{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
+break;
+case 173:
+#line 633 "perly.y"
+{ yyval.opval = scalar(yyvsp[0].opval); }
+break;
+case 174:
+#line 635 "perly.y"
+{ yyval.opval = scalar(yyvsp[0].opval); }
+break;
+case 175:
+#line 637 "perly.y"
+{ yyval.opval = scope(yyvsp[0].opval); }
+break;
+case 176:
+#line 640 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+#line 2270 "perly.c"
+ }
+ yyssp -= yym;
+ yystate = *yyssp;
+ yyvsp -= yym;
+ yym = yylhs[yyn];
+ if (yystate == 0 && yym == 0)
+ {
+#if YYDEBUG
+ if (yydebug)
+ PerlIO_printf(Perl_debug_log,
+ "yydebug: after reduction, shifting from state 0 to state %d\n",
+ YYFINAL);
+#endif
+ yystate = YYFINAL;
+ *++yyssp = YYFINAL;
+ *++yyvsp = yyval;
+ if (yychar < 0)
+ {
+ if ((yychar = yylex()) < 0) yychar = 0;
+#if YYDEBUG
+ if (yydebug)
+ {
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
+ YYFINAL, yychar, yys);
+ }
+#endif
+ }
+ if (yychar == 0) goto yyaccept;
+ goto yyloop;
+ }
+ if ((yyn = yygindex[yym]) && (yyn += yystate) >= 0 &&
+ yyn <= YYTABLESIZE && yycheck[yyn] == yystate)
+ yystate = yytable[yyn];
+ else
+ yystate = yydgoto[yym];
+#if YYDEBUG
+ if (yydebug)
+ PerlIO_printf(Perl_debug_log,
+ "yydebug: after reduction, shifting from state %d to state %d\n",
+ *yyssp, yystate);
+#endif
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+ /*
+ ** reallocate and recover. Note that pointers
+ ** have to be reset, or bad things will happen
+ */
+ int yyps_index = (yyssp - yyss);
+ int yypv_index = (yyvsp - yyvs);
+ yystacksize += YYSTACKSIZE;
+ ysave->yyvs = yyvs =
+ (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE));
+ ysave->yyss = yyss =
+ (short*)realloc((char*)yyss,yystacksize * sizeof(short));
+ if (!yyvs || !yyss)
+ goto yyoverflow;
+ yyssp = yyss + yyps_index;
+ yyvsp = yyvs + yypv_index;
+ }
+ *++yyssp = yystate;
+ *++yyvsp = yyval;
+ goto yyloop;
+yyoverflow:
+ yyerror("Out of memory for yacc stack");
+yyabort:
+ retval = 1;
+yyaccept:
+ return retval;
+}
diff --git a/contrib/perl5/perly.fixer b/contrib/perl5/perly.fixer
new file mode 100755
index 000000000000..afe1a383cfa5
--- /dev/null
+++ b/contrib/perl5/perly.fixer
@@ -0,0 +1,208 @@
+#!/bin/sh
+
+# Fix up yacc output to allow dynamic allocation. Since perly.c
+# is now provided with the perl source, this should not be necessary.
+#
+# However, if the user wishes to use byacc, or wishes to try another
+# compiler compiler (e.g. bison or yacc), this script will get run.
+# See makefile run_byacc target for more details.
+#
+# Currently, only byacc version 1.8 is fully supported.
+#
+# Hacks to make it work with Interactive's SysVr3 Version 2.2
+# doughera@lafvax.lafayette.edu (Andy Dougherty) 3/23/91
+#
+# Additional information to make the BSD section work with SunOS 4.0.2
+# tdinger@East.Sun.COM (Tom Dinger) 4/15/1991
+
+input=$1
+output=$2
+tmp=/tmp/f$$
+
+if grep 'yaccpar 1.8 (Berkeley)' $input >/dev/null 2>&1; then
+ cp $input $output
+ if test -f perly_c.diff; then
+ patch -F3 $output <perly_c.diff
+ rm -rf $input
+ fi
+ exit
+elif grep 'yaccpar 1.9 (Berkeley)' $input >/dev/null 2>&1; then
+ if test -f perly.c.dif9; then
+ patch -F3 $output <perly.c.dif9
+ rm -rf $input
+ exit 0
+ else
+ echo "Diffs from byacc-1.9 are not available."
+ echo "If you wish to proceed anyway, do"
+ echo "cp $input $output"
+ echo "cp y.tab.h perly.h"
+ echo "and re-run make. Otherwise, I will use the old perly.c"
+ touch perly.c
+ # Exit with error status to stop make.
+ exit 1
+ fi
+fi
+
+plan="unknown"
+
+echo ""
+echo "Warning: the yacc you have used is not directly supported by perl."
+echo "The perly.fixer script will attempt to make some changes to the generated"
+echo "file. The changes may be incomplete and that might lead to problems later"
+echo "(especially with complex scripts). You may need to apply the changes"
+echo "embedded in perl.fixer (and/or perly_c.dif*) by hand."
+echo ""
+
+# Below, we check for various characteristic yaccpar outputs.
+
+# Test for BSD 4.3 version.
+# Also tests for the SunOS 4.0.2 version
+egrep 'YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];
+short[ ]*yys\[ *YYMAXDEPTH *\] *;
+yyps *= *&yys\[ *-1 *\];
+yypv *= *&yyv\[ *-1 *\];
+if *\( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp 2>/dev/null
+
+set `wc -l $tmp`
+if test "$1" = "5"; then
+ plan="bsd43"
+fi
+
+if test "$plan" = "unknown"; then
+ # Test for ISC 2.2 version (probably generic SysVr3).
+egrep 'YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];
+int[ ]*yys\[ *YYMAXDEPTH *\] *;
+yyps *= *&yys\[ *-1 *\];
+yypv *= *&yyv\[ *-1 *\];
+if *\( *\+\+yy_ps *>= *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp 2>/dev/null
+
+ set `wc -l $tmp`
+ if test "$1" = "5"; then
+ plan="isc"
+ fi
+fi
+
+# ------
+
+case "$plan" in
+ ##################################################################
+ # The SunOS 4.0.2 version has the comparison fixed already.
+ # Also added are out of memory checks (makes porting the generated
+ # code easier) For most systems, it can't hurt. -- TD
+ "bsd43")
+ echo "Attempting to path perly.c to allow dynamic yacc stack allocation"
+ echo "Assuming bsd4.3 yaccpar"
+ cat >$tmp <<'END'
+/YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];/c\
+int yymaxdepth = YYMAXDEPTH;\
+YYSTYPE *yyv; /* where the values are stored */\
+short *yys;\
+short *maxyyps;
+
+/short[ ]*yys\[ *YYMAXDEPTH *\] *;/d
+
+/yyps *= *&yys\[ *-1 *\];/d
+
+/yypv *= *&yyv\[ *-1 *\];/c\
+\ if (!yyv) {\
+\ New(73, yyv, yymaxdepth, YYSTYPE);\
+\ New(73, yys, yymaxdepth, short);\
+\ if ( !yyv || !yys ) {\
+\ yyerror( "out of memory" );\
+\ return(1);\
+\ }\
+\ maxyyps = &yys[yymaxdepth];\
+\ }\
+\ yyps = &yys[-1];\
+\ yypv = &yyv[-1];
+
+
+/if *( *\+\+yyps *>=* *&yys\[ *YYMAXDEPTH *\] *)/c\
+\ if( ++yyps >= maxyyps ) {\
+\ int tv = yypv - yyv;\
+\ int ts = yyps - yys;\
+\
+\ yymaxdepth *= 2;\
+\ Renew(yyv, yymaxdepth, YYSTYPE);\
+\ Renew(yys, yymaxdepth, short);\
+\ if ( !yyv || !yys ) {\
+\ yyerror( "yacc stack overflow" );\
+\ return(1);\
+\ }\
+\ yyps = yys + ts;\
+\ yypv = yyv + tv;\
+\ maxyyps = &yys[yymaxdepth];\
+\ }
+
+/yacc stack overflow.*}/d
+/yacc stack overflow/,/}/d
+END
+ if sed -f $tmp <$input >$output
+ then echo "The edit seems to have been applied okay."
+ else echo "The edit seems to have failed!"
+ fi
+ ;;
+
+ #######################################################
+ "isc") # Interactive Systems 2.2 version
+ echo "Attempting to path perly.c to allow dynamic yacc stack allocation"
+ echo "Assuming Interactive SysVr3 2.2 yaccpar"
+ # Easier to simply put whole script here than to modify the
+ # bsd script with sed.
+ # Main changes: yaccpar sometimes uses yy_ps and yy_pv
+ # which are local register variables.
+ # if(++yyps > YYMAXDEPTH) had opening brace on next line.
+ # I've kept that brace in along with a call to yyerror if
+ # realloc fails. (Actually, I just don't know how to do
+ # multi-line matches in sed.)
+ cat > $tmp << 'END'
+/YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];/c\
+int yymaxdepth = YYMAXDEPTH;\
+YYSTYPE *yyv; /* where the values are stored */\
+int *yys;\
+int *maxyyps;
+
+/int[ ]*yys\[ *YYMAXDEPTH *\] *;/d
+
+/yyps *= *&yys\[ *-1 *\];/d
+
+/yypv *= *&yyv\[ *-1 *\];/c\
+\ if (!yyv) {\
+\ New(73, yyv, yymaxdepth, YYSTYPE);\
+\ New(73, yys, yymaxdepth, int);\
+\ maxyyps = &yys[yymaxdepth];\
+\ }\
+\ yyps = &yys[-1];\
+\ yypv = &yyv[-1];
+
+/if *( *\+\+yy_ps *>= *&yys\[ *YYMAXDEPTH *\] *)/c\
+\ if( ++yy_ps >= maxyyps ) {\
+\ int tv = yy_pv - yyv;\
+\ int ts = yy_ps - yys;\
+\
+\ yymaxdepth *= 2;\
+\ Renew(yyv, yymaxdepth, YYSTYPE);\
+\ Renew(yys, yymaxdepth, int);\
+\ yy_ps = yyps = yys + ts;\
+\ yy_pv = yypv = yyv + tv;\
+\ maxyyps = &yys[yymaxdepth];\
+\ }\
+\ if (yyv == NULL || yys == NULL)
+END
+ if sed -f $tmp < $input > $output
+ then echo "The edit seems to have been applied okay."
+ else echo "The edit seems to have failed!"
+ fi
+ ;;
+
+ ######################################################
+ # Plan still unknown
+ *)
+ echo "Unable to patch perly.c to allow dynamic yacc stack allocation (plan=$plan)"
+ # just do minimal change to write $output from $input
+ sed -e 's/Received token/ *** Received token/' $input >$output
+ ;;
+esac
+
+echo ""
+rm -rf $tmp $input
diff --git a/contrib/perl5/perly.h b/contrib/perl5/perly.h
new file mode 100644
index 000000000000..c1f7806e3f0e
--- /dev/null
+++ b/contrib/perl5/perly.h
@@ -0,0 +1,65 @@
+#define WORD 257
+#define METHOD 258
+#define FUNCMETH 259
+#define THING 260
+#define PMFUNC 261
+#define PRIVATEREF 262
+#define FUNC0SUB 263
+#define UNIOPSUB 264
+#define LSTOPSUB 265
+#define LABEL 266
+#define FORMAT 267
+#define SUB 268
+#define ANONSUB 269
+#define PACKAGE 270
+#define USE 271
+#define WHILE 272
+#define UNTIL 273
+#define IF 274
+#define UNLESS 275
+#define ELSE 276
+#define ELSIF 277
+#define CONTINUE 278
+#define FOR 279
+#define LOOPEX 280
+#define DOTDOT 281
+#define FUNC0 282
+#define FUNC1 283
+#define FUNC 284
+#define UNIOP 285
+#define LSTOP 286
+#define RELOP 287
+#define EQOP 288
+#define MULOP 289
+#define ADDOP 290
+#define DOLSHARP 291
+#define DO 292
+#define HASHBRACK 293
+#define NOAMP 294
+#define LOCAL 295
+#define MY 296
+#define OROP 297
+#define ANDOP 298
+#define NOTOP 299
+#define ASSIGNOP 300
+#define OROR 301
+#define ANDAND 302
+#define BITOROP 303
+#define BITANDOP 304
+#define SHIFTOP 305
+#define MATCHOP 306
+#define UMINUS 307
+#define REFGEN 308
+#define POWOP 309
+#define PREINC 310
+#define PREDEC 311
+#define POSTINC 312
+#define POSTDEC 313
+#define ARROW 314
+typedef union {
+ I32 ival;
+ char *pval;
+ OP *opval;
+ GV *gvval;
+} YYSTYPE;
+extern YYSTYPE yylval;
diff --git a/contrib/perl5/perly.y b/contrib/perl5/perly.y
new file mode 100644
index 000000000000..e016cf431d0b
--- /dev/null
+++ b/contrib/perl5/perly.y
@@ -0,0 +1,643 @@
+/* perly.y
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * 'I see,' laughed Strider. 'I look foul and feel fair. Is that it?
+ * All that is gold does not glitter, not all those who wander are lost.'
+ */
+
+%{
+#include "EXTERN.h"
+#include "perl.h"
+
+static void
+dep(void)
+{
+ deprecate("\"do\" to call subroutines");
+}
+
+%}
+
+%start prog
+
+%{
+#ifndef OEMVS
+%}
+
+%union {
+ I32 ival;
+ char *pval;
+ OP *opval;
+ GV *gvval;
+}
+
+%{
+#endif /* OEMVS */
+%}
+
+%token <ival> '{' ')'
+
+%token <opval> WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF
+%token <opval> FUNC0SUB UNIOPSUB LSTOPSUB
+%token <pval> LABEL
+%token <ival> FORMAT SUB ANONSUB PACKAGE USE
+%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE FOR
+%token <ival> LOOPEX DOTDOT
+%token <ival> FUNC0 FUNC1 FUNC UNIOP LSTOP
+%token <ival> RELOP EQOP MULOP ADDOP
+%token <ival> DOLSHARP DO HASHBRACK NOAMP
+%token LOCAL MY
+
+%type <ival> prog decl local format startsub startanonsub startformsub
+%type <ival> remember mremember '&'
+%type <opval> block mblock lineseq line loop cond else
+%type <opval> expr term scalar ary hsh arylen star amper sideff
+%type <opval> argexpr nexpr texpr iexpr mexpr mnexpr mtexpr miexpr
+%type <opval> listexpr listexprcom indirob listop method
+%type <opval> formname subname proto subbody cont my_scalar
+%type <pval> label
+
+%left <ival> OROP
+%left ANDOP
+%right NOTOP
+%nonassoc LSTOP LSTOPSUB
+%left ','
+%right <ival> ASSIGNOP
+%right '?' ':'
+%nonassoc DOTDOT
+%left OROR
+%left ANDAND
+%left <ival> BITOROP
+%left <ival> BITANDOP
+%nonassoc EQOP
+%nonassoc RELOP
+%nonassoc UNIOP UNIOPSUB
+%left <ival> SHIFTOP
+%left ADDOP
+%left MULOP
+%left <ival> MATCHOP
+%right '!' '~' UMINUS REFGEN
+%right <ival> POWOP
+%nonassoc PREINC PREDEC POSTINC POSTDEC
+%left ARROW
+%left '('
+
+%% /* RULES */
+
+prog : /* NULL */
+ {
+#if defined(YYDEBUG) && defined(DEBUGGING)
+ yydebug = (PL_debug & 1);
+#endif
+ PL_expect = XSTATE;
+ }
+ /*CONTINUED*/ lineseq
+ { newPROG($2); }
+ ;
+
+block : '{' remember lineseq '}'
+ { if (PL_copline > (line_t)$1)
+ PL_copline = $1;
+ $$ = block_end($2, $3); }
+ ;
+
+remember: /* NULL */ /* start a full lexical scope */
+ { $$ = block_start(TRUE); }
+ ;
+
+mblock : '{' mremember lineseq '}'
+ { if (PL_copline > (line_t)$1)
+ PL_copline = $1;
+ $$ = block_end($2, $3); }
+ ;
+
+mremember: /* NULL */ /* start a partial lexical scope */
+ { $$ = block_start(FALSE); }
+ ;
+
+lineseq : /* NULL */
+ { $$ = Nullop; }
+ | lineseq decl
+ { $$ = $1; }
+ | lineseq line
+ { $$ = append_list(OP_LINESEQ,
+ (LISTOP*)$1, (LISTOP*)$2);
+ PL_pad_reset_pending = TRUE;
+ if ($1 && $2) PL_hints |= HINT_BLOCK_SCOPE; }
+ ;
+
+line : label cond
+ { $$ = newSTATEOP(0, $1, $2); }
+ | loop /* loops add their own labels */
+ | label ';'
+ { if ($1 != Nullch) {
+ $$ = newSTATEOP(0, $1, newOP(OP_NULL, 0));
+ }
+ else {
+ $$ = Nullop;
+ PL_copline = NOLINE;
+ }
+ PL_expect = XSTATE; }
+ | label sideff ';'
+ { $$ = newSTATEOP(0, $1, $2);
+ PL_expect = XSTATE; }
+ ;
+
+sideff : error
+ { $$ = Nullop; }
+ | expr
+ { $$ = $1; }
+ | expr IF expr
+ { $$ = newLOGOP(OP_AND, 0, $3, $1); }
+ | expr UNLESS expr
+ { $$ = newLOGOP(OP_OR, 0, $3, $1); }
+ | expr WHILE expr
+ { $$ = newLOOPOP(OPf_PARENS, 1, scalar($3), $1); }
+ | expr UNTIL iexpr
+ { $$ = newLOOPOP(OPf_PARENS, 1, $3, $1);}
+ | expr FOR expr
+ { $$ = newFOROP(0, Nullch, $2,
+ Nullop, $3, $1, Nullop); }
+ ;
+
+else : /* NULL */
+ { $$ = Nullop; }
+ | ELSE mblock
+ { $$ = scope($2); }
+ | ELSIF '(' mexpr ')' mblock else
+ { PL_copline = $1;
+ $$ = newSTATEOP(0, Nullch,
+ newCONDOP(0, $3, scope($5), $6));
+ PL_hints |= HINT_BLOCK_SCOPE; }
+ ;
+
+cond : IF '(' remember mexpr ')' mblock else
+ { PL_copline = $1;
+ $$ = block_end($3,
+ newCONDOP(0, $4, scope($6), $7)); }
+ | UNLESS '(' remember miexpr ')' mblock else
+ { PL_copline = $1;
+ $$ = block_end($3,
+ newCONDOP(0, $4, scope($6), $7)); }
+ ;
+
+cont : /* NULL */
+ { $$ = Nullop; }
+ | CONTINUE block
+ { $$ = scope($2); }
+ ;
+
+loop : label WHILE '(' remember mtexpr ')' mblock cont
+ { PL_copline = $2;
+ $$ = block_end($4,
+ newSTATEOP(0, $1,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ $2, $5, $7, $8))); }
+ | label UNTIL '(' remember miexpr ')' mblock cont
+ { PL_copline = $2;
+ $$ = block_end($4,
+ newSTATEOP(0, $1,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ $2, $5, $7, $8))); }
+ | label FOR MY remember my_scalar '(' mexpr ')' mblock cont
+ { $$ = block_end($4,
+ newFOROP(0, $1, $2, $5, $7, $9, $10)); }
+ | label FOR scalar '(' remember mexpr ')' mblock cont
+ { $$ = block_end($5,
+ newFOROP(0, $1, $2, mod($3, OP_ENTERLOOP),
+ $6, $8, $9)); }
+ | label FOR '(' remember mexpr ')' mblock cont
+ { $$ = block_end($4,
+ newFOROP(0, $1, $2, Nullop, $5, $7, $8)); }
+ | label FOR '(' remember mnexpr ';' mtexpr ';' mnexpr ')' mblock
+ /* basically fake up an initialize-while lineseq */
+ { OP *forop = append_elem(OP_LINESEQ,
+ scalar($5),
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ $2, scalar($7),
+ $11, scalar($9)));
+ PL_copline = $2;
+ $$ = block_end($4, newSTATEOP(0, $1, forop)); }
+ | label block cont /* a block is a loop that happens once */
+ { $$ = newSTATEOP(0, $1,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ NOLINE, Nullop, $2, $3)); }
+ ;
+
+nexpr : /* NULL */
+ { $$ = Nullop; }
+ | sideff
+ ;
+
+texpr : /* NULL means true */
+ { (void)scan_num("1"); $$ = yylval.opval; }
+ | expr
+ ;
+
+iexpr : expr
+ { $$ = invert(scalar($1)); }
+ ;
+
+mexpr : expr
+ { $$ = $1; intro_my(); }
+ ;
+
+mnexpr : nexpr
+ { $$ = $1; intro_my(); }
+ ;
+
+mtexpr : texpr
+ { $$ = $1; intro_my(); }
+ ;
+
+miexpr : iexpr
+ { $$ = $1; intro_my(); }
+ ;
+
+label : /* empty */
+ { $$ = Nullch; }
+ | LABEL
+ ;
+
+decl : format
+ { $$ = 0; }
+ | subrout
+ { $$ = 0; }
+ | package
+ { $$ = 0; }
+ | use
+ { $$ = 0; }
+ ;
+
+format : FORMAT startformsub formname block
+ { newFORM($2, $3, $4); }
+ ;
+
+formname: WORD { $$ = $1; }
+ | /* NULL */ { $$ = Nullop; }
+ ;
+
+subrout : SUB startsub subname proto subbody
+ { newSUB($2, $3, $4, $5); }
+ ;
+
+startsub: /* NULL */ /* start a regular subroutine scope */
+ { $$ = start_subparse(FALSE, 0); }
+ ;
+
+startanonsub: /* NULL */ /* start an anonymous subroutine scope */
+ { $$ = start_subparse(FALSE, CVf_ANON); }
+ ;
+
+startformsub: /* NULL */ /* start a format subroutine scope */
+ { $$ = start_subparse(TRUE, 0); }
+ ;
+
+subname : WORD { char *name = SvPV(((SVOP*)$1)->op_sv, PL_na);
+ if (strEQ(name, "BEGIN") || strEQ(name, "END")
+ || strEQ(name, "INIT"))
+ CvUNIQUE_on(PL_compcv);
+ $$ = $1; }
+ ;
+
+proto : /* NULL */
+ { $$ = Nullop; }
+ | THING
+ ;
+
+subbody : block { $$ = $1; }
+ | ';' { $$ = Nullop; PL_expect = XSTATE; }
+ ;
+
+package : PACKAGE WORD ';'
+ { package($2); }
+ | PACKAGE ';'
+ { package(Nullop); }
+ ;
+
+use : USE startsub
+ { CvUNIQUE_on(PL_compcv); /* It's a BEGIN {} */ }
+ WORD WORD listexpr ';'
+ { utilize($1, $2, $4, $5, $6); }
+ ;
+
+expr : expr ANDOP expr
+ { $$ = newLOGOP(OP_AND, 0, $1, $3); }
+ | expr OROP expr
+ { $$ = newLOGOP($2, 0, $1, $3); }
+ | argexpr
+ ;
+
+argexpr : argexpr ','
+ { $$ = $1; }
+ | argexpr ',' term
+ { $$ = append_elem(OP_LIST, $1, $3); }
+ | term
+ ;
+
+listop : LSTOP indirob argexpr
+ { $$ = convert($1, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF($1,$2), $3) ); }
+ | FUNC '(' indirob expr ')'
+ { $$ = convert($1, OPf_STACKED,
+ prepend_elem(OP_LIST, newGVREF($1,$3), $4) ); }
+ | term ARROW method '(' listexprcom ')'
+ { $$ = convert(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, scalar($1), $5),
+ newUNOP(OP_METHOD, 0, $3))); }
+ | METHOD indirob listexpr
+ { $$ = convert(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, $2, $3),
+ newUNOP(OP_METHOD, 0, $1))); }
+ | FUNCMETH indirob '(' listexprcom ')'
+ { $$ = convert(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, $2, $4),
+ newUNOP(OP_METHOD, 0, $1))); }
+ | LSTOP listexpr
+ { $$ = convert($1, 0, $2); }
+ | FUNC '(' listexprcom ')'
+ { $$ = convert($1, 0, $3); }
+ | LSTOPSUB startanonsub block
+ { $3 = newANONSUB($2, 0, $3); }
+ listexpr %prec LSTOP
+ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, $3, $5), $1)); }
+ ;
+
+method : METHOD
+ | scalar
+ ;
+
+term : term ASSIGNOP term
+ { $$ = newASSIGNOP(OPf_STACKED, $1, $2, $3); }
+ | term POWOP term
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
+ | term MULOP term
+ { if ($2 != OP_REPEAT)
+ scalar($1);
+ $$ = newBINOP($2, 0, $1, scalar($3)); }
+ | term ADDOP term
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
+ | term SHIFTOP term
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
+ | term RELOP term
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
+ | term EQOP term
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
+ | term BITANDOP term
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
+ | term BITOROP term
+ { $$ = newBINOP($2, 0, scalar($1), scalar($3)); }
+ | term DOTDOT term
+ { $$ = newRANGE($2, scalar($1), scalar($3));}
+ | term ANDAND term
+ { $$ = newLOGOP(OP_AND, 0, $1, $3); }
+ | term OROR term
+ { $$ = newLOGOP(OP_OR, 0, $1, $3); }
+ | term '?' term ':' term
+ { $$ = newCONDOP(0, $1, $3, $5); }
+ | term MATCHOP term
+ { $$ = bind_match($2, $1, $3); }
+
+ | '-' term %prec UMINUS
+ { $$ = newUNOP(OP_NEGATE, 0, scalar($2)); }
+ | '+' term %prec UMINUS
+ { $$ = $2; }
+ | '!' term
+ { $$ = newUNOP(OP_NOT, 0, scalar($2)); }
+ | '~' term
+ { $$ = newUNOP(OP_COMPLEMENT, 0, scalar($2));}
+ | REFGEN term
+ { $$ = newUNOP(OP_REFGEN, 0, mod($2,OP_REFGEN)); }
+ | term POSTINC
+ { $$ = newUNOP(OP_POSTINC, 0,
+ mod(scalar($1), OP_POSTINC)); }
+ | term POSTDEC
+ { $$ = newUNOP(OP_POSTDEC, 0,
+ mod(scalar($1), OP_POSTDEC)); }
+ | PREINC term
+ { $$ = newUNOP(OP_PREINC, 0,
+ mod(scalar($2), OP_PREINC)); }
+ | PREDEC term
+ { $$ = newUNOP(OP_PREDEC, 0,
+ mod(scalar($2), OP_PREDEC)); }
+ | local term %prec UNIOP
+ { $$ = localize($2,$1); }
+ | '(' expr ')'
+ { $$ = sawparens($2); }
+ | '(' ')'
+ { $$ = sawparens(newNULLLIST()); }
+ | '[' expr ']' %prec '('
+ { $$ = newANONLIST($2); }
+ | '[' ']' %prec '('
+ { $$ = newANONLIST(Nullop); }
+ | HASHBRACK expr ';' '}' %prec '('
+ { $$ = newANONHASH($2); }
+ | HASHBRACK ';' '}' %prec '('
+ { $$ = newANONHASH(Nullop); }
+ | ANONSUB startanonsub proto block %prec '('
+ { $$ = newANONSUB($2, $3, $4); }
+ | scalar %prec '('
+ { $$ = $1; }
+ | star '{' expr ';' '}'
+ { $$ = newBINOP(OP_GELEM, 0, $1, scalar($3)); }
+ | star %prec '('
+ { $$ = $1; }
+ | scalar '[' expr ']' %prec '('
+ { $$ = newBINOP(OP_AELEM, 0, oopsAV($1), scalar($3)); }
+ | term ARROW '[' expr ']' %prec '('
+ { $$ = newBINOP(OP_AELEM, 0,
+ ref(newAVREF($1),OP_RV2AV),
+ scalar($4));}
+ | term '[' expr ']' %prec '('
+ { assertref($1); $$ = newBINOP(OP_AELEM, 0,
+ ref(newAVREF($1),OP_RV2AV),
+ scalar($3));}
+ | hsh %prec '('
+ { $$ = $1; }
+ | ary %prec '('
+ { $$ = $1; }
+ | arylen %prec '('
+ { $$ = newUNOP(OP_AV2ARYLEN, 0, ref($1, OP_AV2ARYLEN));}
+ | scalar '{' expr ';' '}' %prec '('
+ { $$ = newBINOP(OP_HELEM, 0, oopsHV($1), jmaybe($3));
+ PL_expect = XOPERATOR; }
+ | term ARROW '{' expr ';' '}' %prec '('
+ { $$ = newBINOP(OP_HELEM, 0,
+ ref(newHVREF($1),OP_RV2HV),
+ jmaybe($4));
+ PL_expect = XOPERATOR; }
+ | term '{' expr ';' '}' %prec '('
+ { assertref($1); $$ = newBINOP(OP_HELEM, 0,
+ ref(newHVREF($1),OP_RV2HV),
+ jmaybe($3));
+ PL_expect = XOPERATOR; }
+ | '(' expr ')' '[' expr ']' %prec '('
+ { $$ = newSLICEOP(0, $5, $2); }
+ | '(' ')' '[' expr ']' %prec '('
+ { $$ = newSLICEOP(0, $4, Nullop); }
+ | ary '[' expr ']' %prec '('
+ { $$ = prepend_elem(OP_ASLICE,
+ newOP(OP_PUSHMARK, 0),
+ newLISTOP(OP_ASLICE, 0,
+ list($3),
+ ref($1, OP_ASLICE))); }
+ | ary '{' expr ';' '}' %prec '('
+ { $$ = prepend_elem(OP_HSLICE,
+ newOP(OP_PUSHMARK, 0),
+ newLISTOP(OP_HSLICE, 0,
+ list($3),
+ ref(oopsHV($1), OP_HSLICE)));
+ PL_expect = XOPERATOR; }
+ | THING %prec '('
+ { $$ = $1; }
+ | amper
+ { $$ = newUNOP(OP_ENTERSUB, 0, scalar($1)); }
+ | amper '(' ')'
+ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar($1)); }
+ | amper '(' expr ')'
+ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, $3, scalar($1))); }
+ | NOAMP WORD listexpr
+ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, $3, scalar($2))); }
+ | DO term %prec UNIOP
+ { $$ = newUNOP(OP_DOFILE, 0, scalar($2)); }
+ | DO block %prec '('
+ { $$ = newUNOP(OP_NULL, OPf_SPECIAL, scope($2)); }
+ | DO WORD '(' ')'
+ { $$ = newUNOP(OP_ENTERSUB,
+ OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ scalar(newCVREF(
+ (OPpENTERSUB_AMPER<<8),
+ scalar($2)
+ )),Nullop)); dep();}
+ | DO WORD '(' expr ')'
+ { $$ = newUNOP(OP_ENTERSUB,
+ OPf_SPECIAL|OPf_STACKED,
+ append_elem(OP_LIST,
+ $4,
+ scalar(newCVREF(
+ (OPpENTERSUB_AMPER<<8),
+ scalar($2)
+ )))); dep();}
+ | DO scalar '(' ')'
+ { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ scalar(newCVREF(0,scalar($2))), Nullop)); dep();}
+ | DO scalar '(' expr ')'
+ { $$ = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
+ prepend_elem(OP_LIST,
+ $4,
+ scalar(newCVREF(0,scalar($2))))); dep();}
+ | term ARROW '(' ')' %prec '('
+ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newCVREF(0, scalar($1))); }
+ | term ARROW '(' expr ')' %prec '('
+ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, $4,
+ newCVREF(0, scalar($1)))); }
+ | LOOPEX
+ { $$ = newOP($1, OPf_SPECIAL);
+ PL_hints |= HINT_BLOCK_SCOPE; }
+ | LOOPEX term
+ { $$ = newLOOPEX($1,$2); }
+ | NOTOP argexpr
+ { $$ = newUNOP(OP_NOT, 0, scalar($2)); }
+ | UNIOP
+ { $$ = newOP($1, 0); }
+ | UNIOP block
+ { $$ = newUNOP($1, 0, $2); }
+ | UNIOP term
+ { $$ = newUNOP($1, 0, $2); }
+ | UNIOPSUB term
+ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, $2, scalar($1))); }
+ | FUNC0
+ { $$ = newOP($1, 0); }
+ | FUNC0 '(' ')'
+ { $$ = newOP($1, 0); }
+ | FUNC0SUB
+ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ scalar($1)); }
+ | FUNC1 '(' ')'
+ { $$ = newOP($1, OPf_SPECIAL); }
+ | FUNC1 '(' expr ')'
+ { $$ = newUNOP($1, 0, $3); }
+ | PMFUNC '(' term ')'
+ { $$ = pmruntime($1, $3, Nullop); }
+ | PMFUNC '(' term ',' term ')'
+ { $$ = pmruntime($1, $3, $5); }
+ | WORD
+ | listop
+ ;
+
+listexpr: /* NULL */
+ { $$ = Nullop; }
+ | argexpr
+ { $$ = $1; }
+ ;
+
+listexprcom: /* NULL */
+ { $$ = Nullop; }
+ | expr
+ { $$ = $1; }
+ | expr ','
+ { $$ = $1; }
+ ;
+
+local : LOCAL { $$ = 0; }
+ | MY { $$ = 1; }
+ ;
+
+my_scalar: scalar
+ { PL_in_my = 0; $$ = my($1); }
+ ;
+
+amper : '&' indirob
+ { $$ = newCVREF($1,$2); }
+ ;
+
+scalar : '$' indirob
+ { $$ = newSVREF($2); }
+ ;
+
+ary : '@' indirob
+ { $$ = newAVREF($2); }
+ ;
+
+hsh : '%' indirob
+ { $$ = newHVREF($2); }
+ ;
+
+arylen : DOLSHARP indirob
+ { $$ = newAVREF($2); }
+ ;
+
+star : '*' indirob
+ { $$ = newGVREF(0,$2); }
+ ;
+
+indirob : WORD
+ { $$ = scalar($1); }
+ | scalar
+ { $$ = scalar($1); }
+ | block
+ { $$ = scope($1); }
+
+ | PRIVATEREF
+ { $$ = $1; }
+ ;
+
+%% /* PROGRAM */
diff --git a/contrib/perl5/perly_c.diff b/contrib/perl5/perly_c.diff
new file mode 100644
index 000000000000..aa0555b034d3
--- /dev/null
+++ b/contrib/perl5/perly_c.diff
@@ -0,0 +1,444 @@
+*** perly.c.orig Tue Jul 28 15:02:41 1998
+--- perly.c Tue Jul 28 15:14:54 1998
+***************
+*** 7,11 ****
+--- 7,19 ----
+ #include "perl.h"
+
++ #ifdef PERL_OBJECT
+ static void
++ Dep(CPerlObj *pPerl)
++ {
++ pPerl->deprecate("\"do\" to call subroutines");
++ }
++ #define dep() Dep(this)
++ #else
++ static void
+ dep(void)
+ {
+***************
+*** 12,86 ****
+ deprecate("\"do\" to call subroutines");
+ }
+
+ #line 30 "perly.y"
+- #ifndef OEMVS
+- #line 33 "perly.y"
+- typedef union {
+- I32 ival;
+- char *pval;
+- OP *opval;
+- GV *gvval;
+- } YYSTYPE;
+- #line 41 "perly.y"
+- #endif /* OEMVS */
+- #line 27 "y.tab.c"
+- #define WORD 257
+- #define METHOD 258
+- #define FUNCMETH 259
+- #define THING 260
+- #define PMFUNC 261
+- #define PRIVATEREF 262
+- #define FUNC0SUB 263
+- #define UNIOPSUB 264
+- #define LSTOPSUB 265
+- #define LABEL 266
+- #define FORMAT 267
+- #define SUB 268
+- #define ANONSUB 269
+- #define PACKAGE 270
+- #define USE 271
+- #define WHILE 272
+- #define UNTIL 273
+- #define IF 274
+- #define UNLESS 275
+- #define ELSE 276
+- #define ELSIF 277
+- #define CONTINUE 278
+- #define FOR 279
+- #define LOOPEX 280
+- #define DOTDOT 281
+- #define FUNC0 282
+- #define FUNC1 283
+- #define FUNC 284
+- #define UNIOP 285
+- #define LSTOP 286
+- #define RELOP 287
+- #define EQOP 288
+- #define MULOP 289
+- #define ADDOP 290
+- #define DOLSHARP 291
+- #define DO 292
+- #define HASHBRACK 293
+- #define NOAMP 294
+- #define LOCAL 295
+- #define MY 296
+- #define OROP 297
+- #define ANDOP 298
+- #define NOTOP 299
+- #define ASSIGNOP 300
+- #define OROR 301
+- #define ANDAND 302
+- #define BITOROP 303
+- #define BITANDOP 304
+- #define SHIFTOP 305
+- #define MATCHOP 306
+- #define UMINUS 307
+- #define REFGEN 308
+- #define POWOP 309
+- #define PREINC 310
+- #define PREDEC 311
+- #define POSTINC 312
+- #define POSTDEC 313
+- #define ARROW 314
+ #define YYERRCODE 256
+ short yylhs[] = { -1,
+--- 20,26 ----
+ deprecate("\"do\" to call subroutines");
+ }
++ #endif
+
+ #line 30 "perly.y"
+ #define YYERRCODE 256
+ short yylhs[] = { -1,
+***************
+*** 1345,1365 ****
+ YYSTYPE yyval;
+ YYSTYPE yylval;
+- short yyss[YYSTACKSIZE];
+- YYSTYPE yyvs[YYSTACKSIZE];
+- #define yystacksize YYSTACKSIZE
+ #line 643 "perly.y"
+ /* PROGRAM */
+! #line 1353 "y.tab.c"
+ #define YYABORT goto yyabort
+ #define YYACCEPT goto yyaccept
+ #define YYERROR goto yyerrlab
+ int
+! yyparse()
+ {
+ register int yym, yyn, yystate;
+ #if YYDEBUG
+ register char *yys;
+ extern char *getenv();
+
+ if (yys = getenv("YYDEBUG"))
+ {
+--- 1285,1349 ----
+ YYSTYPE yyval;
+ YYSTYPE yylval;
+ #line 643 "perly.y"
+ /* PROGRAM */
+! #line 1353 "perly.c"
+ #define YYABORT goto yyabort
+ #define YYACCEPT goto yyaccept
+ #define YYERROR goto yyerrlab
++
++ struct ysv {
++ short* yyss;
++ YYSTYPE* yyvs;
++ int oldyydebug;
++ int oldyynerrs;
++ int oldyyerrflag;
++ int oldyychar;
++ YYSTYPE oldyyval;
++ YYSTYPE oldyylval;
++ };
++
++ void
++ yydestruct(void *ptr)
++ {
++ struct ysv* ysave = (struct ysv*)ptr;
++ if (ysave->yyss) Safefree(ysave->yyss);
++ if (ysave->yyvs) Safefree(ysave->yyvs);
++ yydebug = ysave->oldyydebug;
++ yynerrs = ysave->oldyynerrs;
++ yyerrflag = ysave->oldyyerrflag;
++ yychar = ysave->oldyychar;
++ yyval = ysave->oldyyval;
++ yylval = ysave->oldyylval;
++ Safefree(ysave);
++ }
++
+ int
+! yyparse(void)
+ {
+ register int yym, yyn, yystate;
++ register short *yyssp;
++ register YYSTYPE *yyvsp;
++ short* yyss;
++ YYSTYPE* yyvs;
++ unsigned yystacksize = YYSTACKSIZE;
++ int retval = 0;
+ #if YYDEBUG
+ register char *yys;
++ #ifndef __cplusplus
+ extern char *getenv();
++ #endif
++ #endif
+
++ struct ysv *ysave;
++ New(73, ysave, 1, struct ysv);
++ SAVEDESTRUCTOR(yydestruct, ysave);
++ ysave->oldyydebug = yydebug;
++ ysave->oldyynerrs = yynerrs;
++ ysave->oldyyerrflag = yyerrflag;
++ ysave->oldyychar = yychar;
++ ysave->oldyyval = yyval;
++ ysave->oldyylval = yylval;
++
++ #if YYDEBUG
+ if (yys = getenv("YYDEBUG"))
+ {
+***************
+*** 1374,1377 ****
+--- 1358,1371 ----
+ yychar = (-1);
+
++ /*
++ ** Initialize private stacks (yyparse may be called from an action)
++ */
++ New(73, yyss, yystacksize, short);
++ New(73, yyvs, yystacksize, YYSTYPE);
++ ysave->yyss = yyss;
++ ysave->yyvs = yyvs;
++ if (!yyvs || !yyss)
++ goto yyoverflow;
++
+ yyssp = yyss;
+ yyvsp = yyvs;
+***************
+*** 1389,1393 ****
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! printf("yydebug: state %d, reading %d (%s)\n", yystate,
+ yychar, yys);
+ }
+--- 1383,1387 ----
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate,
+ yychar, yys);
+ }
+***************
+*** 1399,1403 ****
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: state %d, shifting to state %d\n",
+ yystate, yytable[yyn]);
+ #endif
+--- 1393,1397 ----
+ #if YYDEBUG
+ if (yydebug)
+! PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n",
+ yystate, yytable[yyn]);
+ #endif
+***************
+*** 1404,1408 ****
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+! goto yyoverflow;
+ }
+ *++yyssp = yystate = yytable[yyn];
+--- 1398,1416 ----
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+! /*
+! ** reallocate and recover. Note that pointers
+! ** have to be reset, or bad things will happen
+! */
+! int yyps_index = (yyssp - yyss);
+! int yypv_index = (yyvsp - yyvs);
+! yystacksize += YYSTACKSIZE;
+! ysave->yyvs = yyvs =
+! (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE));
+! ysave->yyss = yyss =
+! (short*)realloc((char*)yyss,yystacksize * sizeof(short));
+! if (!yyvs || !yyss)
+! goto yyoverflow;
+! yyssp = yyss + yyps_index;
+! yyvsp = yyvs + yypv_index;
+ }
+ *++yyssp = yystate = yytable[yyn];
+***************
+*** 1440,1449 ****
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: state %d, error recovery shifting\
+! to state %d\n", *yyssp, yytable[yyn]);
+ #endif
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+! goto yyoverflow;
+ }
+ *++yyssp = yystate = yytable[yyn];
+--- 1448,1472 ----
+ #if YYDEBUG
+ if (yydebug)
+! PerlIO_printf(Perl_debug_log,
+! "yydebug: state %d, error recovery shifting to state %d\n",
+! *yyssp, yytable[yyn]);
+ #endif
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+! /*
+! ** reallocate and recover. Note that pointers
+! ** have to be reset, or bad things will happen
+! */
+! int yyps_index = (yyssp - yyss);
+! int yypv_index = (yyvsp - yyvs);
+! yystacksize += YYSTACKSIZE;
+! ysave->yyvs = yyvs = (YYSTYPE*)realloc((char*)yyvs,
+! yystacksize * sizeof(YYSTYPE));
+! ysave->yyss = yyss = (short*)realloc((char*)yyss,
+! yystacksize * sizeof(short));
+! if (!yyvs || !yyss)
+! goto yyoverflow;
+! yyssp = yyss + yyps_index;
+! yyvsp = yyvs + yypv_index;
+ }
+ *++yyssp = yystate = yytable[yyn];
+***************
+*** 1455,1460 ****
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: error recovery discarding state %d\n",
+! *yyssp);
+ #endif
+ if (yyssp <= yyss) goto yyabort;
+--- 1478,1484 ----
+ #if YYDEBUG
+ if (yydebug)
+! PerlIO_printf(Perl_debug_log,
+! "yydebug: error recovery discarding state %d\n",
+! *yyssp);
+ #endif
+ if (yyssp <= yyss) goto yyabort;
+***************
+*** 1473,1478 ****
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! printf("yydebug: state %d, error recovery discards token %d (%s)\n",
+! yystate, yychar, yys);
+ }
+ #endif
+--- 1497,1503 ----
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! PerlIO_printf(Perl_debug_log,
+! "yydebug: state %d, error recovery discards token %d (%s)\n",
+! yystate, yychar, yys);
+ }
+ #endif
+***************
+*** 1483,1487 ****
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: state %d, reducing by rule %d (%s)\n",
+ yystate, yyn, yyrule[yyn]);
+ #endif
+--- 1508,1512 ----
+ #if YYDEBUG
+ if (yydebug)
+! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n",
+ yystate, yyn, yyrule[yyn]);
+ #endif
+***************
+*** 2267,2271 ****
+ { yyval.opval = yyvsp[0].opval; }
+ break;
+! #line 2270 "y.tab.c"
+ }
+ yyssp -= yym;
+--- 2292,2296 ----
+ { yyval.opval = yyvsp[0].opval; }
+ break;
+! #line 2270 "perly.c"
+ }
+ yyssp -= yym;
+***************
+*** 2277,2282 ****
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: after reduction, shifting from state 0 to\
+! state %d\n", YYFINAL);
+ #endif
+ yystate = YYFINAL;
+--- 2302,2308 ----
+ #if YYDEBUG
+ if (yydebug)
+! PerlIO_printf(Perl_debug_log,
+! "yydebug: after reduction, shifting from state 0 to state %d\n",
+! YYFINAL);
+ #endif
+ yystate = YYFINAL;
+***************
+*** 2292,2296 ****
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! printf("yydebug: state %d, reading %d (%s)\n",
+ YYFINAL, yychar, yys);
+ }
+--- 2318,2322 ----
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
+ YYFINAL, yychar, yys);
+ }
+***************
+*** 2307,2316 ****
+ #if YYDEBUG
+ if (yydebug)
+! printf("yydebug: after reduction, shifting from state %d \
+! to state %d\n", *yyssp, yystate);
+ #endif
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+! goto yyoverflow;
+ }
+ *++yyssp = yystate;
+--- 2333,2357 ----
+ #if YYDEBUG
+ if (yydebug)
+! PerlIO_printf(Perl_debug_log,
+! "yydebug: after reduction, shifting from state %d to state %d\n",
+! *yyssp, yystate);
+ #endif
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+! /*
+! ** reallocate and recover. Note that pointers
+! ** have to be reset, or bad things will happen
+! */
+! int yyps_index = (yyssp - yyss);
+! int yypv_index = (yyvsp - yyvs);
+! yystacksize += YYSTACKSIZE;
+! ysave->yyvs = yyvs =
+! (YYSTYPE*)realloc((char*)yyvs,yystacksize * sizeof(YYSTYPE));
+! ysave->yyss = yyss =
+! (short*)realloc((char*)yyss,yystacksize * sizeof(short));
+! if (!yyvs || !yyss)
+! goto yyoverflow;
+! yyssp = yyss + yyps_index;
+! yyvsp = yyvs + yypv_index;
+ }
+ *++yyssp = yystate;
+***************
+*** 2318,2325 ****
+ goto yyloop;
+ yyoverflow:
+! yyerror("yacc stack overflow");
+ yyabort:
+! return (1);
+ yyaccept:
+! return (0);
+ }
+--- 2359,2366 ----
+ goto yyloop;
+ yyoverflow:
+! yyerror("Out of memory for yacc stack");
+ yyabort:
+! retval = 1;
+ yyaccept:
+! return retval;
+ }
diff --git a/contrib/perl5/pod/Makefile b/contrib/perl5/pod/Makefile
new file mode 100644
index 000000000000..9187c840ef08
--- /dev/null
+++ b/contrib/perl5/pod/Makefile
@@ -0,0 +1,286 @@
+CONVERTERS = pod2html pod2latex pod2man pod2text checkpods
+
+HTMLROOT = / # Change this to fix cross-references in HTML
+POD2HTML = pod2html \
+ --htmlroot=$(HTMLROOT) \
+ --podroot=.. --podpath=pod:lib:ext:vms \
+ --libpods=perlfunc:perlguts:perlvar:perlrun:perlop
+
+all: $(CONVERTERS) man
+
+converters: $(CONVERTERS)
+
+PERL = ../miniperl
+REALPERL = ../perl
+
+POD = \
+ perl.pod \
+ perldelta.pod \
+ perldata.pod \
+ perlsyn.pod \
+ perlop.pod \
+ perlre.pod \
+ perlrun.pod \
+ perlfunc.pod \
+ perlvar.pod \
+ perlsub.pod \
+ perlmod.pod \
+ perlmodlib.pod \
+ perlmodinstall.pod \
+ perlform.pod \
+ perllocale.pod \
+ perlref.pod \
+ perldsc.pod \
+ perllol.pod \
+ perltoot.pod \
+ perlobj.pod \
+ perltie.pod \
+ perlbot.pod \
+ perlipc.pod \
+ perldebug.pod \
+ perldiag.pod \
+ perlsec.pod \
+ perltrap.pod \
+ perlport.pod \
+ perlstyle.pod \
+ perlpod.pod \
+ perlbook.pod \
+ perlembed.pod \
+ perlapio.pod \
+ perlxs.pod \
+ perlxstut.pod \
+ perlguts.pod \
+ perlcall.pod \
+ perlfaq.pod \
+ perlfaq1.pod \
+ perlfaq2.pod \
+ perlfaq3.pod \
+ perlfaq4.pod \
+ perlfaq5.pod \
+ perlfaq6.pod \
+ perlfaq7.pod \
+ perlfaq8.pod \
+ perlfaq9.pod \
+ perltoc.pod
+
+MAN = \
+ perl.man \
+ perldelta.man \
+ perldata.man \
+ perlsyn.man \
+ perlop.man \
+ perlre.man \
+ perlrun.man \
+ perlfunc.man \
+ perlvar.man \
+ perlsub.man \
+ perlmod.man \
+ perlmodlib.man \
+ perlmodinstall.man \
+ perlform.man \
+ perllocale.man \
+ perlref.man \
+ perldsc.man \
+ perllol.man \
+ perltoot.man \
+ perlobj.man \
+ perltie.man \
+ perlbot.man \
+ perlipc.man \
+ perldebug.man \
+ perldiag.man \
+ perlsec.man \
+ perltrap.man \
+ perlport.man \
+ perlstyle.man \
+ perlpod.man \
+ perlbook.man \
+ perlembed.man \
+ perlapio.man \
+ perlxs.man \
+ perlxstut.man \
+ perlguts.man \
+ perlcall.man \
+ perlfaq.man \
+ perlfaq1.man \
+ perlfaq2.man \
+ perlfaq3.man \
+ perlfaq4.man \
+ perlfaq5.man \
+ perlfaq6.man \
+ perlfaq7.man \
+ perlfaq8.man \
+ perlfaq9.man \
+ perltoc.man
+
+HTML = \
+ perl.html \
+ perldelta.html \
+ perldata.html \
+ perlsyn.html \
+ perlop.html \
+ perlre.html \
+ perlrun.html \
+ perlfunc.html \
+ perlvar.html \
+ perlsub.html \
+ perlmod.html \
+ perlmodlib.html \
+ perlmodinstall.html \
+ perlform.html \
+ perllocale.html \
+ perlref.html \
+ perldsc.html \
+ perllol.html \
+ perltoot.html \
+ perlobj.html \
+ perltie.html \
+ perlbot.html \
+ perlipc.html \
+ perldebug.html \
+ perldiag.html \
+ perlsec.html \
+ perltrap.html \
+ perlport.html \
+ perlstyle.html \
+ perlpod.html \
+ perlbook.html \
+ perlembed.html \
+ perlapio.html \
+ perlxs.html \
+ perlxstut.html \
+ perlguts.html \
+ perlcall.html \
+ perlfaq.html \
+ perlfaq1.html \
+ perlfaq2.html \
+ perlfaq3.html \
+ perlfaq4.html \
+ perlfaq5.html \
+ perlfaq6.html \
+ perlfaq7.html \
+ perlfaq8.html \
+ perlfaq9.html
+# not perltoc.html
+
+TEX = \
+ perl.tex \
+ perldelta.tex \
+ perldata.tex \
+ perlsyn.tex \
+ perlop.tex \
+ perlre.tex \
+ perlrun.tex \
+ perlfunc.tex \
+ perlvar.tex \
+ perlsub.tex \
+ perlmod.tex \
+ perlmodlib.tex \
+ perlmodinstall.tex \
+ perlform.tex \
+ perllocale.tex \
+ perlref.tex \
+ perldsc.tex \
+ perllol.tex \
+ perltoot.tex \
+ perlobj.tex \
+ perltie.tex \
+ perlbot.tex \
+ perlipc.tex \
+ perldebug.tex \
+ perldiag.tex \
+ perlsec.tex \
+ perltrap.tex \
+ perlport.tex \
+ perlstyle.tex \
+ perlpod.tex \
+ perlbook.tex \
+ perlembed.tex \
+ perlapio.tex \
+ perlxs.tex \
+ perlxstut.tex \
+ perlguts.tex \
+ perlcall.tex \
+ perlfaq.tex \
+ perlfaq1.tex \
+ perlfaq2.tex \
+ perlfaq3.tex \
+ perlfaq4.tex \
+ perlfaq5.tex \
+ perlfaq6.tex \
+ perlfaq7.tex \
+ perlfaq8.tex \
+ perlfaq9.tex \
+ perltoc.tex
+
+man: pod2man $(MAN)
+
+html: pod2html $(HTML)
+
+tex: pod2latex $(TEX)
+
+toc:
+ $(PERL) -I../lib buildtoc >perltoc.pod
+
+.SUFFIXES: .pm .pod
+
+.SUFFIXES: .man
+
+.pm.man: pod2man
+ $(PERL) -I../lib pod2man $*.pm >$*.man
+
+.pod.man: pod2man
+ $(PERL) -I../lib pod2man $*.pod >$*.man
+
+.SUFFIXES: .html
+
+.pm.html: pod2html
+ $(PERL) -I../lib $(POD2HTML) --infile=$*.pm --outfile=$*.html
+
+.pod.html: pod2html
+ $(PERL) -I../lib $(POD2HTML) --infile=$*.pod --outfile=$*.html
+
+.SUFFIXES: .tex
+
+.pm.tex: pod2latex
+ $(PERL) -I../lib pod2latex $*.pm
+
+.pod.tex: pod2latex
+ $(PERL) -I../lib pod2latex $*.pod
+
+clean:
+ rm -f $(MAN)
+ rm -f $(HTML)
+ rm -f $(TEX)
+ rm -f pod2html-*cache
+ rm -f *.aux *.log *.exe
+
+realclean: clean
+ rm -f $(CONVERTERS)
+
+distclean: realclean
+
+check: checkpods
+ @echo "checking..."; \
+ $(PERL) -I../lib checkpods $(POD)
+
+# Dependencies.
+pod2latex: pod2latex.PL ../lib/Config.pm
+ $(PERL) -I../lib pod2latex.PL
+
+pod2html: pod2html.PL ../lib/Config.pm
+ $(PERL) -I ../lib pod2html.PL
+
+pod2man: pod2man.PL ../lib/Config.pm
+ $(PERL) -I ../lib pod2man.PL
+
+pod2text: pod2text.PL ../lib/Config.pm
+ $(PERL) -I ../lib pod2text.PL
+
+checkpods: checkpods.PL ../lib/Config.pm
+ $(PERL) -I ../lib checkpods.PL
+
+compile: all
+ $(REALPERL) -I../lib ../utils/perlcc -regex 's/$$/.exe/' pod2latex pod2man pod2text checkpods -prog -verbose dcf -log ../compilelog;
+
+
diff --git a/contrib/perl5/pod/buildtoc b/contrib/perl5/pod/buildtoc
new file mode 100644
index 000000000000..80ca2ec55cc6
--- /dev/null
+++ b/contrib/perl5/pod/buildtoc
@@ -0,0 +1,241 @@
+use File::Find;
+use Cwd;
+use Text::Wrap;
+
+sub output ($);
+
+@pods = qw(
+ perl perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5
+ perlfaq6 perlfaq7 perlfaq8 perlfaq9 perldelta perldata
+ perlsyn perlop perlre perlrun perlfunc perlvar perlsub
+ perlmod perlmodlib perlmodinstall perlform perllocale perlref perldsc
+ perllol perltoot perlobj perltie perlbot perlipc perldebug
+ perldiag perlsec perltrap perlport perlstyle perlpod perlbook
+ perlembed perlapio perlxs perlxstut perlguts perlcall
+ perlhist
+ );
+
+for (@pods) { s/$/.pod/ }
+
+$/ = '';
+@ARGV = @pods;
+
+($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
+
+ =head1 NAME
+
+ perltoc - perl documentation table of contents
+
+ =head1 DESCRIPTION
+
+ This page provides a brief table of contents for the rest of the Perl
+ documentation set. It is meant to be scanned quickly or grepped
+ through to locate the proper section you're looking for.
+
+ =head1 BASIC DOCUMENTATION
+
+EOPOD2B
+#' make emacs happy
+
+podset(@pods);
+
+find \&getpods => qw(../lib ../ext);
+
+sub getpods {
+ if (/\.p(od|m)$/) {
+ # Skip .pm files that have corresponding .pod files, and Functions.pm.
+ return if /(.*)\.pm$/ && -f "$1.pod";
+ my $file = $File::Find::name;
+ return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
+
+ die "tut $name" if $file =~ /TUT/;
+ unless (open (F, "< $_\0")) {
+ warn "bogus <$file>: $!";
+ system "ls", "-l", $file;
+ }
+ else {
+ my $line;
+ while ($line = <F>) {
+ if ($line =~ /^=head1\s+NAME\b/) {
+ push @modpods, $file;
+ #warn "GOOD $file\n";
+ return;
+ }
+ }
+ warn "EVIL $file\n";
+ }
+ }
+}
+
+die "no pods" unless @modpods;
+
+for (@modpods) {
+ #($name) = /(\w+)\.p(m|od)$/;
+ $name = path2modname($_);
+ if ($name =~ /^[a-z]/) {
+ push @pragmata, $_;
+ } else {
+ if ($done{$name}++) {
+ # warn "already did $_\n";
+ next;
+ }
+ push @modules, $_;
+ push @modname, $name;
+ }
+}
+
+($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
+
+
+
+ =head1 PRAGMA DOCUMENTATION
+
+EOPOD2B
+
+podset(sort @pragmata);
+
+($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
+
+
+
+ =head1 MODULE DOCUMENTATION
+
+EOPOD2B
+
+podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
+
+($_= <<EOPOD2B) =~ s/^\t//gm;
+
+
+ =head1 AUXILIARY DOCUMENTATION
+
+ Here should be listed all the extra programs' documentation, but they
+ don't all have manual pages yet:
+
+ =item a2p
+
+ =item s2p
+
+ =item find2perl
+
+ =item h2ph
+
+ =item c2ph
+
+ =item h2xs
+
+ =item xsubpp
+
+ =item pod2man
+
+ =item wrapsuid
+
+
+ =head1 AUTHOR
+
+ Larry Wall <F<larry\@wall.org>>, with the help of oodles
+ of other folks.
+
+
+EOPOD2B
+output $_;
+output "\n"; # flush $LINE
+exit;
+
+sub podset {
+ local @ARGV = @_;
+
+ while(<>) {
+ if (s/^=head1 (NAME)\s*/=head2 /) {
+ $pod = path2modname($ARGV);
+ unitem();
+ unhead2();
+ output "\n \n\n=head2 ";
+ $_ = <>;
+ if ( /^\s*$pod\b/ ) {
+ s/$pod\.pm/$pod/; # '.pm' in NAME !?
+ output $_;
+ } else {
+ s/^/$pod, /;
+ output $_;
+ }
+ next;
+ }
+ if (s/^=head1 (.*)/=item $1/) {
+ unitem(); unhead2();
+ output $_; nl(); next;
+ }
+ if (s/^=head2 (.*)/=item $1/) {
+ unitem();
+ output "=over\n\n" unless $inhead2;
+ $inhead2 = 1;
+ output $_; nl(); next;
+
+ }
+ if (s/^=item ([^=].*)\n/$1/) {
+ next if $pod eq 'perldiag';
+ s/^\s*\*\s*$// && next;
+ s/^\s*\*\s*//;
+ s/\s+$//;
+ next if /^[\d.]+$/;
+ next if $pod eq 'perlmodlib' && /^ftp:/;
+ ##print "=over\n\n" unless $initem;
+ output ", " if $initem;
+ $initem = 1;
+ s/\.$//;
+ s/^-X\b/-I<X>/;
+ output $_; next;
+ }
+ }
+}
+
+sub path2modname {
+ local $_ = shift;
+ s/\.p(m|od)$//;
+ s-.*?/(lib|ext)/--;
+ s-/-::-g;
+ s/(\w+)::\1/$1/;
+ return $_;
+}
+
+sub unhead2 {
+ if ($inhead2) {
+ output "\n\n=back\n\n";
+ }
+ $inhead2 = 0;
+ $initem = 0;
+}
+
+sub unitem {
+ if ($initem) {
+ output "\n\n";
+ ##print "\n\n=back\n\n";
+ }
+ $initem = 0;
+}
+
+sub nl {
+ output "\n";
+}
+
+my $NEWLINE; # how many newlines have we seen recently
+my $LINE; # what remains to be printed
+
+sub output ($) {
+ for (split /(\n)/, shift) {
+ if ($_ eq "\n") {
+ if ($LINE) {
+ print wrap('', '', $LINE);
+ $LINE = '';
+ }
+ if ($NEWLINE < 2) {
+ print;
+ $NEWLINE++;
+ }
+ }
+ elsif (/\S/ && length) {
+ $LINE .= $_;
+ $NEWLINE = 0;
+ }
+ }
+}
diff --git a/contrib/perl5/pod/checkpods.PL b/contrib/perl5/pod/checkpods.PL
new file mode 100644
index 000000000000..92b7ae6e4c12
--- /dev/null
+++ b/contrib/perl5/pod/checkpods.PL
@@ -0,0 +1,85 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+# From roderick@gate.netThu Sep 5 17:19:30 1996
+# Date: Thu, 05 Sep 1996 00:11:22 -0400
+# From: Roderick Schertler <roderick@gate.net>
+# To: perl5-porters@africa.nicoh.com
+# Subject: POD lines with only spaces
+#
+# There are some places in the documentation where a POD directive is
+# ignored because the line before it contains whitespace (and so the
+# directive doesn't start a paragraph). This patch adds a way to check
+# for these to the pod Makefile (though it isn't made part of the build
+# process, which would be a good idea), and fixes those places where the
+# problem currently exists.
+#
+# Version 1.00 Original.
+# Version 1.01 Andy Dougherty <doughera@lafcol.lafayette.edu>
+# Trivial modifications to output format for easier auto-parsing
+# Broke it out as a separate function to avoid nasty
+# Make/Shell/Perl quoting problems, and also to make it easier
+# to grow. Someone will probably want to rewrite in terms of
+# some sort of Pod::Checker module. Or something. Consider this
+# a placeholder for the future.
+# Version 1.02 Roderick Schertler <roderick@argon.org>
+# Check for pod directives following any kind of unempty line, not
+# just lines of whitespace.
+
+@directive = qw(head1 head2 item over back cut pod for begin end);
+@directive{@directive} = (1) x @directive;
+
+$exit = $last_unempty = 0;
+while (<>) {
+ chomp;
+ if (/^=(\S+)/ && $directive{$1} && $last_unempty) {
+ printf "%s: line %5d, no blank line preceeding directive =%s\n",
+ $ARGV, $., $1;
+ $exit = 1;
+ }
+ $last_unempty = ($_ ne '');
+ if (eof) {
+ close(ARGV);
+ $last_unempty = 0;
+ }
+}
+exit $exit
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/pod/perl.pod b/contrib/perl5/pod/perl.pod
new file mode 100644
index 000000000000..0b9e9fa68045
--- /dev/null
+++ b/contrib/perl5/pod/perl.pod
@@ -0,0 +1,319 @@
+=head1 NAME
+
+perl - Practical Extraction and Report Language
+
+=head1 SYNOPSIS
+
+B<perl> S<[ B<-sTuU> ]>
+ S<[ B<-hv> ] [ B<-V>[:I<configvar>] ]>
+ S<[ B<-cw> ] [ B<-d>[:I<debugger>] ] [ B<-D>[I<number/list>] ]>
+ S<[ B<-pna> ] [ B<-F>I<pattern> ] [ B<-l>[I<octal>] ] [ B<-0>[I<octal>] ]>
+ S<[ B<-I>I<dir> ] [ B<-m>[B<->]I<module> ] [ B<-M>[B<->]I<'module...'> ]>
+ S<[ B<-P> ]>
+ S<[ B<-S> ]>
+ S<[ B<-x>[I<dir>] ]>
+ S<[ B<-i>[I<extension>] ]>
+ S<[ B<-e> I<'command'> ] [ B<--> ] [ I<programfile> ] [ I<argument> ]...>
+
+For ease of access, the Perl manual has been split up into a number
+of sections:
+
+ perl Perl overview (this section)
+ perldelta Perl changes since previous version
+ perlfaq Perl frequently asked questions
+ perltoc Perl documentation table of contents
+
+ perldata Perl data structures
+ perlsyn Perl syntax
+ perlop Perl operators and precedence
+ perlre Perl regular expressions
+ perlrun Perl execution and options
+ perlfunc Perl builtin functions
+ perlvar Perl predefined variables
+ perlsub Perl subroutines
+ perlmod Perl modules: how they work
+ perlmodlib Perl modules: how to write and use
+ perlmodinstall Perl modules: how to install from CPAN
+ perlform Perl formats
+ perllocale Perl locale support
+
+ perlref Perl references
+ perldsc Perl data structures intro
+ perllol Perl data structures: lists of lists
+ perltoot Perl OO tutorial
+ perlobj Perl objects
+ perltie Perl objects hidden behind simple variables
+ perlbot Perl OO tricks and examples
+ perlipc Perl interprocess communication
+
+ perldebug Perl debugging
+ perldiag Perl diagnostic messages
+ perlsec Perl security
+ perltrap Perl traps for the unwary
+ perlport Perl portability guide
+ perlstyle Perl style guide
+
+ perlpod Perl plain old documentation
+ perlbook Perl book information
+
+ perlembed Perl ways to embed perl in your C or C++ application
+ perlapio Perl internal IO abstraction interface
+ perlxs Perl XS application programming interface
+ perlxstut Perl XS tutorial
+ perlguts Perl internal functions for those doing extensions
+ perlcall Perl calling conventions from C
+
+ perlhist Perl history records
+
+(If you're intending to read these straight through for the first time,
+the suggested order will tend to reduce the number of forward references.)
+
+By default, all of the above manpages are installed in the
+F</usr/local/man/> directory.
+
+Extensive additional documentation for Perl modules is available. The
+default configuration for perl will place this additional documentation
+in the F</usr/local/lib/perl5/man> directory (or else in the F<man>
+subdirectory of the Perl library directory). Some of this additional
+documentation is distributed standard with Perl, but you'll also find
+documentation for third-party modules there.
+
+You should be able to view Perl's documentation with your man(1)
+program by including the proper directories in the appropriate start-up
+files, or in the MANPATH environment variable. To find out where the
+configuration has installed the manpages, type:
+
+ perl -V:man.dir
+
+If the directories have a common stem, such as F</usr/local/man/man1>
+and F</usr/local/man/man3>, you need only to add that stem
+(F</usr/local/man>) to your man(1) configuration files or your MANPATH
+environment variable. If they do not share a stem, you'll have to add
+both stems.
+
+If that doesn't work for some reason, you can still use the
+supplied F<perldoc> script to view module information. You might
+also look into getting a replacement man program.
+
+If something strange has gone wrong with your program and you're not
+sure where you should look for help, try the B<-w> switch first. It
+will often point out exactly where the trouble is.
+
+=head1 DESCRIPTION
+
+Perl is a language optimized for scanning arbitrary
+text files, extracting information from those text files, and printing
+reports based on that information. It's also a good language for many
+system management tasks. The language is intended to be practical
+(easy to use, efficient, complete) rather than beautiful (tiny,
+elegant, minimal).
+
+Perl combines (in the author's opinion, anyway) some of the best
+features of C, B<sed>, B<awk>, and B<sh>, so people familiar with
+those languages should have little difficulty with it. (Language
+historians will also note some vestiges of B<csh>, Pascal, and even
+BASIC-PLUS.) Expression syntax corresponds quite closely to C
+expression syntax. Unlike most Unix utilities, Perl does not
+arbitrarily limit the size of your data--if you've got the memory,
+Perl can slurp in your whole file as a single string. Recursion is of
+unlimited depth. And the tables used by hashes (previously called
+"associative arrays") grow as necessary to prevent degraded
+performance. Perl uses sophisticated pattern matching techniques to
+scan large amounts of data very quickly. Although optimized for
+scanning text, Perl can also deal with binary data, and can make dbm
+files look like hashes. Setuid Perl scripts are safer than C programs
+through a dataflow tracing mechanism which prevents many stupid
+security holes.
+
+If you have a problem that would ordinarily use B<sed> or B<awk> or
+B<sh>, but it exceeds their capabilities or must run a little faster,
+and you don't want to write the silly thing in C, then Perl may be for
+you. There are also translators to turn your B<sed> and B<awk>
+scripts into Perl scripts.
+
+But wait, there's more...
+
+Perl version 5 is nearly a complete rewrite, and provides
+the following additional benefits:
+
+=over 5
+
+=item * Many usability enhancements
+
+It is now possible to write much more readable Perl code (even within
+regular expressions). Formerly cryptic variable names can be replaced
+by mnemonic identifiers. Error messages are more informative, and the
+optional warnings will catch many of the mistakes a novice might make.
+This cannot be stressed enough. Whenever you get mysterious behavior,
+try the B<-w> switch!!! Whenever you don't get mysterious behavior,
+try using B<-w> anyway.
+
+=item * Simplified grammar
+
+The new yacc grammar is one half the size of the old one. Many of the
+arbitrary grammar rules have been regularized. The number of reserved
+words has been cut by 2/3. Despite this, nearly all old Perl scripts
+will continue to work unchanged.
+
+=item * Lexical scoping
+
+Perl variables may now be declared within a lexical scope, like "auto"
+variables in C. Not only is this more efficient, but it contributes
+to better privacy for "programming in the large". Anonymous
+subroutines exhibit deep binding of lexical variables (closures).
+
+=item * Arbitrarily nested data structures
+
+Any scalar value, including any array element, may now contain a
+reference to any other variable or subroutine. You can easily create
+anonymous variables and subroutines. Perl manages your reference
+counts for you.
+
+=item * Modularity and reusability
+
+The Perl library is now defined in terms of modules which can be easily
+shared among various packages. A package may choose to import all or a
+portion of a module's published interface. Pragmas (that is, compiler
+directives) are defined and used by the same mechanism.
+
+=item * Object-oriented programming
+
+A package can function as a class. Dynamic multiple inheritance and
+virtual methods are supported in a straightforward manner and with very
+little new syntax. Filehandles may now be treated as objects.
+
+=item * Embeddable and Extensible
+
+Perl may now be embedded easily in your C or C++ application, and can
+either call or be called by your routines through a documented
+interface. The XS preprocessor is provided to make it easy to glue
+your C or C++ routines into Perl. Dynamic loading of modules is
+supported, and Perl itself can be made into a dynamic library.
+
+=item * POSIX compliant
+
+A major new module is the POSIX module, which provides access to all
+available POSIX routines and definitions, via object classes where
+appropriate.
+
+=item * Package constructors and destructors
+
+The new BEGIN and END blocks provide means to capture control as
+a package is being compiled, and after the program exits. As a
+degenerate case they work just like awk's BEGIN and END when you
+use the B<-p> or B<-n> switches.
+
+=item * Multiple simultaneous DBM implementations
+
+A Perl program may now access DBM, NDBM, SDBM, GDBM, and Berkeley DB
+files from the same script simultaneously. In fact, the old dbmopen
+interface has been generalized to allow any variable to be tied
+to an object class which defines its access methods.
+
+=item * Subroutine definitions may now be autoloaded
+
+In fact, the AUTOLOAD mechanism also allows you to define any arbitrary
+semantics for undefined subroutine calls. It's not for just autoloading.
+
+=item * Regular expression enhancements
+
+You can now specify nongreedy quantifiers. You can now do grouping
+without creating a backreference. You can now write regular expressions
+with embedded whitespace and comments for readability. A consistent
+extensibility mechanism has been added that is upwardly compatible with
+all old regular expressions.
+
+=item * Innumerable Unbundled Modules
+
+The Comprehensive Perl Archive Network described in L<perlmodlib>
+contains hundreds of plug-and-play modules full of reusable code.
+See F<http://www.perl.com/CPAN> for a site near you.
+
+=item * Compilability
+
+While not yet in full production mode, a working perl-to-C compiler
+does exist. It can generate portable byte code, simple C, or
+optimized C code.
+
+=back
+
+Okay, that's I<definitely> enough hype.
+
+=head1 ENVIRONMENT
+
+See L<perlrun>.
+
+=head1 AUTHOR
+
+Larry Wall <F<larry@wall.org>>, with the help of oodles of other folks.
+
+If your Perl success stories and testimonials may be of help to others
+who wish to advocate the use of Perl in their applications,
+or if you wish to simply express your gratitude to Larry and the
+Perl developers, please write to <F<perl-thanks@perl.org>>.
+
+=head1 FILES
+
+ "/tmp/perl-e$$" temporary file for -e commands
+ "@INC" locations of perl libraries
+
+=head1 SEE ALSO
+
+ a2p awk to perl translator
+
+ s2p sed to perl translator
+
+=head1 DIAGNOSTICS
+
+The B<-w> switch produces some lovely diagnostics.
+
+See L<perldiag> for explanations of all Perl's diagnostics. The C<use
+diagnostics> pragma automatically turns Perl's normally terse warnings
+and errors into these longer forms.
+
+Compilation errors will tell you the line number of the error, with an
+indication of the next token or token type that was to be examined.
+(In the case of a script passed to Perl via B<-e> switches, each
+B<-e> is counted as one line.)
+
+Setuid scripts have additional constraints that can produce error
+messages such as "Insecure dependency". See L<perlsec>.
+
+Did we mention that you should definitely consider using the B<-w>
+switch?
+
+=head1 BUGS
+
+The B<-w> switch is not mandatory.
+
+Perl is at the mercy of your machine's definitions of various
+operations such as type casting, atof(), and floating-point
+output with sprintf().
+
+If your stdio requires a seek or eof between reads and writes on a
+particular stream, so does Perl. (This doesn't apply to sysread()
+and syswrite().)
+
+While none of the built-in data types have any arbitrary size limits
+(apart from memory size), there are still a few arbitrary limits: a
+given variable name may not be longer than 255 characters, and no
+component of your PATH may be longer than 255 if you use B<-S>. A regular
+expression may not compile to more than 32767 bytes internally.
+
+You may mail your bug reports (be sure to include full configuration
+information as output by the myconfig program in the perl source tree,
+or by C<perl -V>) to <F<perlbug@perl.com>>.
+If you've succeeded in compiling perl, the perlbug script in the utils/
+subdirectory can be used to help mail in a bug report.
+
+Perl actually stands for Pathologically Eclectic Rubbish Lister, but
+don't tell anyone I said that.
+
+=head1 NOTES
+
+The Perl motto is "There's more than one way to do it." Divining
+how many more is left as an exercise to the reader.
+
+The three principal virtues of a programmer are Laziness,
+Impatience, and Hubris. See the Camel Book for why.
+
diff --git a/contrib/perl5/pod/perl5004delta.pod b/contrib/perl5/pod/perl5004delta.pod
new file mode 100644
index 000000000000..f1b6c8f0961d
--- /dev/null
+++ b/contrib/perl5/pod/perl5004delta.pod
@@ -0,0 +1,1609 @@
+=head1 NAME
+
+perldelta - what's new for perl5.004
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.003 release (as
+documented in I<Programming Perl>, second edition--the Camel Book) and
+this one.
+
+=head1 Supported Environments
+
+Perl5.004 builds out of the box on Unix, Plan 9, LynxOS, VMS, OS/2,
+QNX, AmigaOS, and Windows NT. Perl runs on Windows 95 as well, but it
+cannot be built there, for lack of a reasonable command interpreter.
+
+=head1 Core Changes
+
+Most importantly, many bugs were fixed, including several security
+problems. See the F<Changes> file in the distribution for details.
+
+=head2 List assignment to %ENV works
+
+C<%ENV = ()> and C<%ENV = @list> now work as expected (except on VMS
+where it generates a fatal error).
+
+=head2 "Can't locate Foo.pm in @INC" error now lists @INC
+
+=head2 Compilation option: Binary compatibility with 5.003
+
+There is a new Configure question that asks if you want to maintain
+binary compatibility with Perl 5.003. If you choose binary
+compatibility, you do not have to recompile your extensions, but you
+might have symbol conflicts if you embed Perl in another application,
+just as in the 5.003 release. By default, binary compatibility
+is preserved at the expense of symbol table pollution.
+
+=head2 $PERL5OPT environment variable
+
+You may now put Perl options in the $PERL5OPT environment variable.
+Unless Perl is running with taint checks, it will interpret this
+variable as if its contents had appeared on a "#!perl" line at the
+beginning of your script, except that hyphens are optional. PERL5OPT
+may only be used to set the following switches: B<-[DIMUdmw]>.
+
+=head2 Limitations on B<-M>, B<-m>, and B<-T> options
+
+The C<-M> and C<-m> options are no longer allowed on the C<#!> line of
+a script. If a script needs a module, it should invoke it with the
+C<use> pragma.
+
+The B<-T> option is also forbidden on the C<#!> line of a script,
+unless it was present on the Perl command line. Due to the way C<#!>
+works, this usually means that B<-T> must be in the first argument.
+Thus:
+
+ #!/usr/bin/perl -T -w
+
+will probably work for an executable script invoked as C<scriptname>,
+while:
+
+ #!/usr/bin/perl -w -T
+
+will probably fail under the same conditions. (Non-Unix systems will
+probably not follow this rule.) But C<perl scriptname> is guaranteed
+to fail, since then there is no chance of B<-T> being found on the
+command line before it is found on the C<#!> line.
+
+=head2 More precise warnings
+
+If you removed the B<-w> option from your Perl 5.003 scripts because it
+made Perl too verbose, we recommend that you try putting it back when
+you upgrade to Perl 5.004. Each new perl version tends to remove some
+undesirable warnings, while adding new warnings that may catch bugs in
+your scripts.
+
+=head2 Deprecated: Inherited C<AUTOLOAD> for non-methods
+
+Before Perl 5.004, C<AUTOLOAD> functions were looked up as methods
+(using the C<@ISA> hierarchy), even when the function to be autoloaded
+was called as a plain function (e.g. C<Foo::bar()>), not a method
+(e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>).
+
+Perl 5.005 will use method lookup only for methods' C<AUTOLOAD>s.
+However, there is a significant base of existing code that may be using
+the old behavior. So, as an interim step, Perl 5.004 issues an optional
+warning when a non-method uses an inherited C<AUTOLOAD>.
+
+The simple rule is: Inheritance will not work when autoloading
+non-methods. The simple fix for old code is: In any module that used to
+depend on inheriting C<AUTOLOAD> for non-methods from a base class named
+C<BaseClass>, execute C<*AUTOLOAD = \&BaseClass::AUTOLOAD> during startup.
+
+=head2 Previously deprecated %OVERLOAD is no longer usable
+
+Using %OVERLOAD to define overloading was deprecated in 5.003.
+Overloading is now defined using the overload pragma. %OVERLOAD is
+still used internally but should not be used by Perl scripts. See
+L<overload> for more details.
+
+=head2 Subroutine arguments created only when they're modified
+
+In Perl 5.004, nonexistent array and hash elements used as subroutine
+parameters are brought into existence only if they are actually
+assigned to (via C<@_>).
+
+Earlier versions of Perl vary in their handling of such arguments.
+Perl versions 5.002 and 5.003 always brought them into existence.
+Perl versions 5.000 and 5.001 brought them into existence only if
+they were not the first argument (which was almost certainly a bug).
+Earlier versions of Perl never brought them into existence.
+
+For example, given this code:
+
+ undef @a; undef %a;
+ sub show { print $_[0] };
+ sub change { $_[0]++ };
+ show($a[2]);
+ change($a{b});
+
+After this code executes in Perl 5.004, $a{b} exists but $a[2] does
+not. In Perl 5.002 and 5.003, both $a{b} and $a[2] would have existed
+(but $a[2]'s value would have been undefined).
+
+=head2 Group vector changeable with C<$)>
+
+The C<$)> special variable has always (well, in Perl 5, at least)
+reflected not only the current effective group, but also the group list
+as returned by the C<getgroups()> C function (if there is one).
+However, until this release, there has not been a way to call the
+C<setgroups()> C function from Perl.
+
+In Perl 5.004, assigning to C<$)> is exactly symmetrical with examining
+it: The first number in its string value is used as the effective gid;
+if there are any numbers after the first one, they are passed to the
+C<setgroups()> C function (if there is one).
+
+=head2 Fixed parsing of $$<digit>, &$<digit>, etc.
+
+Perl versions before 5.004 misinterpreted any type marker followed by
+"$" and a digit. For example, "$$0" was incorrectly taken to mean
+"${$}0" instead of "${$0}". This bug is (mostly) fixed in Perl 5.004.
+
+However, the developers of Perl 5.004 could not fix this bug completely,
+because at least two widely-used modules depend on the old meaning of
+"$$0" in a string. So Perl 5.004 still interprets "$$<digit>" in the
+old (broken) way inside strings; but it generates this message as a
+warning. And in Perl 5.005, this special treatment will cease.
+
+=head2 Fixed localization of $<digit>, $&, etc.
+
+Perl versions before 5.004 did not always properly localize the
+regex-related special variables. Perl 5.004 does localize them, as
+the documentation has always said it should. This may result in $1,
+$2, etc. no longer being set where existing programs use them.
+
+=head2 No resetting of $. on implicit close
+
+The documentation for Perl 5.0 has always stated that C<$.> is I<not>
+reset when an already-open file handle is reopened with no intervening
+call to C<close>. Due to a bug, perl versions 5.000 through 5.003
+I<did> reset C<$.> under that circumstance; Perl 5.004 does not.
+
+=head2 C<wantarray> may return undef
+
+The C<wantarray> operator returns true if a subroutine is expected to
+return a list, and false otherwise. In Perl 5.004, C<wantarray> can
+also return the undefined value if a subroutine's return value will
+not be used at all, which allows subroutines to avoid a time-consuming
+calculation of a return value if it isn't going to be used.
+
+=head2 C<eval EXPR> determines value of EXPR in scalar context
+
+Perl (version 5) used to determine the value of EXPR inconsistently,
+sometimes incorrectly using the surrounding context for the determination.
+Now, the value of EXPR (before being parsed by eval) is always determined in
+a scalar context. Once parsed, it is executed as before, by providing
+the context that the scope surrounding the eval provided. This change
+makes the behavior Perl4 compatible, besides fixing bugs resulting from
+the inconsistent behavior. This program:
+
+ @a = qw(time now is time);
+ print eval @a;
+ print '|', scalar eval @a;
+
+used to print something like "timenowis881399109|4", but now (and in perl4)
+prints "4|4".
+
+=head2 Changes to tainting checks
+
+A bug in previous versions may have failed to detect some insecure
+conditions when taint checks are turned on. (Taint checks are used
+in setuid or setgid scripts, or when explicitly turned on with the
+C<-T> invocation option.) Although it's unlikely, this may cause a
+previously-working script to now fail -- which should be construed
+as a blessing, since that indicates a potentially-serious security
+hole was just plugged.
+
+The new restrictions when tainting include:
+
+=over
+
+=item No glob() or <*>
+
+These operators may spawn the C shell (csh), which cannot be made
+safe. This restriction will be lifted in a future version of Perl
+when globbing is implemented without the use of an external program.
+
+=item No spawning if tainted $CDPATH, $ENV, $BASH_ENV
+
+These environment variables may alter the behavior of spawned programs
+(especially shells) in ways that subvert security. So now they are
+treated as dangerous, in the manner of $IFS and $PATH.
+
+=item No spawning if tainted $TERM doesn't look like a terminal name
+
+Some termcap libraries do unsafe things with $TERM. However, it would be
+unnecessarily harsh to treat all $TERM values as unsafe, since only shell
+metacharacters can cause trouble in $TERM. So a tainted $TERM is
+considered to be safe if it contains only alphanumerics, underscores,
+dashes, and colons, and unsafe if it contains other characters (including
+whitespace).
+
+=back
+
+=head2 New Opcode module and revised Safe module
+
+A new Opcode module supports the creation, manipulation and
+application of opcode masks. The revised Safe module has a new API
+and is implemented using the new Opcode module. Please read the new
+Opcode and Safe documentation.
+
+=head2 Embedding improvements
+
+In older versions of Perl it was not possible to create more than one
+Perl interpreter instance inside a single process without leaking like a
+sieve and/or crashing. The bugs that caused this behavior have all been
+fixed. However, you still must take care when embedding Perl in a C
+program. See the updated perlembed manpage for tips on how to manage
+your interpreters.
+
+=head2 Internal change: FileHandle class based on IO::* classes
+
+File handles are now stored internally as type IO::Handle. The
+FileHandle module is still supported for backwards compatibility, but
+it is now merely a front end to the IO::* modules -- specifically,
+IO::Handle, IO::Seekable, and IO::File. We suggest, but do not
+require, that you use the IO::* modules in new code.
+
+In harmony with this change, C<*GLOB{FILEHANDLE}> is now just a
+backward-compatible synonym for C<*GLOB{IO}>.
+
+=head2 Internal change: PerlIO abstraction interface
+
+It is now possible to build Perl with AT&T's sfio IO package
+instead of stdio. See L<perlapio> for more details, and
+the F<INSTALL> file for how to use it.
+
+=head2 New and changed syntax
+
+=over
+
+=item $coderef->(PARAMS)
+
+A subroutine reference may now be suffixed with an arrow and a
+(possibly empty) parameter list. This syntax denotes a call of the
+referenced subroutine, with the given parameters (if any).
+
+This new syntax follows the pattern of S<C<$hashref-E<gt>{FOO}>> and
+S<C<$aryref-E<gt>[$foo]>>: You may now write S<C<&$subref($foo)>> as
+S<C<$subref-E<gt>($foo)>>. All of these arrow terms may be chained;
+thus, S<C<&{$table-E<gt>{FOO}}($bar)>> may now be written
+S<C<$table-E<gt>{FOO}-E<gt>($bar)>>.
+
+=back
+
+=head2 New and changed builtin constants
+
+=over
+
+=item __PACKAGE__
+
+The current package name at compile time, or the undefined value if
+there is no current package (due to a C<package;> directive). Like
+C<__FILE__> and C<__LINE__>, C<__PACKAGE__> does I<not> interpolate
+into strings.
+
+=back
+
+=head2 New and changed builtin variables
+
+=over
+
+=item $^E
+
+Extended error message on some platforms. (Also known as
+$EXTENDED_OS_ERROR if you C<use English>).
+
+=item $^H
+
+The current set of syntax checks enabled by C<use strict>. See the
+documentation of C<strict> for more details. Not actually new, but
+newly documented.
+Because it is intended for internal use by Perl core components,
+there is no C<use English> long name for this variable.
+
+=item $^M
+
+By default, running out of memory it is not trappable. However, if
+compiled for this, Perl may use the contents of C<$^M> as an emergency
+pool after die()ing with this message. Suppose that your Perl were
+compiled with -DPERL_EMERGENCY_SBRK and used Perl's malloc. Then
+
+ $^M = 'a' x (1<<16);
+
+would allocate a 64K buffer for use when in emergency.
+See the F<INSTALL> file for information on how to enable this option.
+As a disincentive to casual use of this advanced feature,
+there is no C<use English> long name for this variable.
+
+=back
+
+=head2 New and changed builtin functions
+
+=over
+
+=item delete on slices
+
+This now works. (e.g. C<delete @ENV{'PATH', 'MANPATH'}>)
+
+=item flock
+
+is now supported on more platforms, prefers fcntl to lockf when
+emulating, and always flushes before (un)locking.
+
+=item printf and sprintf
+
+Perl now implements these functions itself; it doesn't use the C
+library function sprintf() any more, except for floating-point
+numbers, and even then only known flags are allowed. As a result, it
+is now possible to know which conversions and flags will work, and
+what they will do.
+
+The new conversions in Perl's sprintf() are:
+
+ %i a synonym for %d
+ %p a pointer (the address of the Perl value, in hexadecimal)
+ %n special: *stores* the number of characters output so far
+ into the next variable in the parameter list
+
+The new flags that go between the C<%> and the conversion are:
+
+ # prefix octal with "0", hex with "0x"
+ h interpret integer as C type "short" or "unsigned short"
+ V interpret integer as Perl's standard integer type
+
+Also, where a number would appear in the flags, an asterisk ("*") may
+be used instead, in which case Perl uses the next item in the
+parameter list as the given number (that is, as the field width or
+precision). If a field width obtained through "*" is negative, it has
+the same effect as the '-' flag: left-justification.
+
+See L<perlfunc/sprintf> for a complete list of conversion and flags.
+
+=item keys as an lvalue
+
+As an lvalue, C<keys> allows you to increase the number of hash buckets
+allocated for the given hash. This can gain you a measure of efficiency if
+you know the hash is going to get big. (This is similar to pre-extending
+an array by assigning a larger number to $#array.) If you say
+
+ keys %hash = 200;
+
+then C<%hash> will have at least 200 buckets allocated for it. These
+buckets will be retained even if you do C<%hash = ()>; use C<undef
+%hash> if you want to free the storage while C<%hash> is still in scope.
+You can't shrink the number of buckets allocated for the hash using
+C<keys> in this way (but you needn't worry about doing this by accident,
+as trying has no effect).
+
+=item my() in Control Structures
+
+You can now use my() (with or without the parentheses) in the control
+expressions of control structures such as:
+
+ while (defined(my $line = <>)) {
+ $line = lc $line;
+ } continue {
+ print $line;
+ }
+
+ if ((my $answer = <STDIN>) =~ /^y(es)?$/i) {
+ user_agrees();
+ } elsif ($answer =~ /^n(o)?$/i) {
+ user_disagrees();
+ } else {
+ chomp $answer;
+ die "`$answer' is neither `yes' nor `no'";
+ }
+
+Also, you can declare a foreach loop control variable as lexical by
+preceding it with the word "my". For example, in:
+
+ foreach my $i (1, 2, 3) {
+ some_function();
+ }
+
+$i is a lexical variable, and the scope of $i extends to the end of
+the loop, but not beyond it.
+
+Note that you still cannot use my() on global punctuation variables
+such as $_ and the like.
+
+=item pack() and unpack()
+
+A new format 'w' represents a BER compressed integer (as defined in
+ASN.1). Its format is a sequence of one or more bytes, each of which
+provides seven bits of the total value, with the most significant
+first. Bit eight of each byte is set, except for the last byte, in
+which bit eight is clear.
+
+If 'p' or 'P' are given undef as values, they now generate a NULL
+pointer.
+
+Both pack() and unpack() now fail when their templates contain invalid
+types. (Invalid types used to be ignored.)
+
+=item sysseek()
+
+The new sysseek() operator is a variant of seek() that sets and gets the
+file's system read/write position, using the lseek(2) system call. It is
+the only reliable way to seek before using sysread() or syswrite(). Its
+return value is the new position, or the undefined value on failure.
+
+=item use VERSION
+
+If the first argument to C<use> is a number, it is treated as a version
+number instead of a module name. If the version of the Perl interpreter
+is less than VERSION, then an error message is printed and Perl exits
+immediately. Because C<use> occurs at compile time, this check happens
+immediately during the compilation process, unlike C<require VERSION>,
+which waits until runtime for the check. This is often useful if you
+need to check the current Perl version before C<use>ing library modules
+which have changed in incompatible ways from older versions of Perl.
+(We try not to do this more than we have to.)
+
+=item use Module VERSION LIST
+
+If the VERSION argument is present between Module and LIST, then the
+C<use> will call the VERSION method in class Module with the given
+version as an argument. The default VERSION method, inherited from
+the UNIVERSAL class, croaks if the given version is larger than the
+value of the variable $Module::VERSION. (Note that there is not a
+comma after VERSION!)
+
+This version-checking mechanism is similar to the one currently used
+in the Exporter module, but it is faster and can be used with modules
+that don't use the Exporter. It is the recommended method for new
+code.
+
+=item prototype(FUNCTION)
+
+Returns the prototype of a function as a string (or C<undef> if the
+function has no prototype). FUNCTION is a reference to or the name of the
+function whose prototype you want to retrieve.
+(Not actually new; just never documented before.)
+
+=item srand
+
+The default seed for C<srand>, which used to be C<time>, has been changed.
+Now it's a heady mix of difficult-to-predict system-dependent values,
+which should be sufficient for most everyday purposes.
+
+Previous to version 5.004, calling C<rand> without first calling C<srand>
+would yield the same sequence of random numbers on most or all machines.
+Now, when perl sees that you're calling C<rand> and haven't yet called
+C<srand>, it calls C<srand> with the default seed. You should still call
+C<srand> manually if your code might ever be run on a pre-5.004 system,
+of course, or if you want a seed other than the default.
+
+=item $_ as Default
+
+Functions documented in the Camel to default to $_ now in
+fact do, and all those that do are so documented in L<perlfunc>.
+
+=item C<m//gc> does not reset search position on failure
+
+The C<m//g> match iteration construct has always reset its target
+string's search position (which is visible through the C<pos> operator)
+when a match fails; as a result, the next C<m//g> match after a failure
+starts again at the beginning of the string. With Perl 5.004, this
+reset may be disabled by adding the "c" (for "continue") modifier,
+i.e. C<m//gc>. This feature, in conjunction with the C<\G> zero-width
+assertion, makes it possible to chain matches together. See L<perlop>
+and L<perlre>.
+
+=item C<m//x> ignores whitespace before ?*+{}
+
+The C<m//x> construct has always been intended to ignore all unescaped
+whitespace. However, before Perl 5.004, whitespace had the effect of
+escaping repeat modifiers like "*" or "?"; for example, C</a *b/x> was
+(mis)interpreted as C</a\*b/x>. This bug has been fixed in 5.004.
+
+=item nested C<sub{}> closures work now
+
+Prior to the 5.004 release, nested anonymous functions didn't work
+right. They do now.
+
+=item formats work right on changing lexicals
+
+Just like anonymous functions that contain lexical variables
+that change (like a lexical index variable for a C<foreach> loop),
+formats now work properly. For example, this silently failed
+before (printed only zeros), but is fine now:
+
+ my $i;
+ foreach $i ( 1 .. 10 ) {
+ write;
+ }
+ format =
+ my i is @#
+ $i
+ .
+
+However, it still fails (without a warning) if the foreach is within a
+subroutine:
+
+ my $i;
+ sub foo {
+ foreach $i ( 1 .. 10 ) {
+ write;
+ }
+ }
+ foo;
+ format =
+ my i is @#
+ $i
+ .
+
+=back
+
+=head2 New builtin methods
+
+The C<UNIVERSAL> package automatically contains the following methods that
+are inherited by all other classes:
+
+=over
+
+=item isa(CLASS)
+
+C<isa> returns I<true> if its object is blessed into a subclass of C<CLASS>
+
+C<isa> is also exportable and can be called as a sub with two arguments. This
+allows the ability to check what a reference points to. Example:
+
+ use UNIVERSAL qw(isa);
+
+ if(isa($ref, 'ARRAY')) {
+ ...
+ }
+
+=item can(METHOD)
+
+C<can> checks to see if its object has a method called C<METHOD>,
+if it does then a reference to the sub is returned; if it does not then
+I<undef> is returned.
+
+=item VERSION( [NEED] )
+
+C<VERSION> returns the version number of the class (package). If the
+NEED argument is given then it will check that the current version (as
+defined by the $VERSION variable in the given package) not less than
+NEED; it will die if this is not the case. This method is normally
+called as a class method. This method is called automatically by the
+C<VERSION> form of C<use>.
+
+ use A 1.2 qw(some imported subs);
+ # implies:
+ A->VERSION(1.2);
+
+=back
+
+B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and
+C<isa> uses a very similar method and caching strategy. This may cause
+strange effects if the Perl code dynamically changes @ISA in any package.
+
+You may add other methods to the UNIVERSAL class via Perl or XS code.
+You do not need to C<use UNIVERSAL> in order to make these methods
+available to your program. This is necessary only if you wish to
+have C<isa> available as a plain subroutine in the current package.
+
+=head2 TIEHANDLE now supported
+
+See L<perltie> for other kinds of tie()s.
+
+=over
+
+=item TIEHANDLE classname, LIST
+
+This is the constructor for the class. That means it is expected to
+return an object of some sort. The reference can be used to
+hold some internal information.
+
+ sub TIEHANDLE {
+ print "<shout>\n";
+ my $i;
+ return bless \$i, shift;
+ }
+
+=item PRINT this, LIST
+
+This method will be triggered every time the tied handle is printed to.
+Beyond its self reference it also expects the list that was passed to
+the print function.
+
+ sub PRINT {
+ $r = shift;
+ $$r++;
+ return print join( $, => map {uc} @_), $\;
+ }
+
+=item PRINTF this, LIST
+
+This method will be triggered every time the tied handle is printed to
+with the C<printf()> function.
+Beyond its self reference it also expects the format and list that was
+passed to the printf function.
+
+ sub PRINTF {
+ shift;
+ my $fmt = shift;
+ print sprintf($fmt, @_)."\n";
+ }
+
+=item READ this LIST
+
+This method will be called when the handle is read from via the C<read>
+or C<sysread> functions.
+
+ sub READ {
+ $r = shift;
+ my($buf,$len,$offset) = @_;
+ print "READ called, \$buf=$buf, \$len=$len, \$offset=$offset";
+ }
+
+=item READLINE this
+
+This method will be called when the handle is read from. The method
+should return undef when there is no more data.
+
+ sub READLINE {
+ $r = shift;
+ return "PRINT called $$r times\n"
+ }
+
+=item GETC this
+
+This method will be called when the C<getc> function is called.
+
+ sub GETC { print "Don't GETC, Get Perl"; return "a"; }
+
+=item DESTROY this
+
+As with the other types of ties, this method will be called when the
+tied handle is about to be destroyed. This is useful for debugging and
+possibly for cleaning up.
+
+ sub DESTROY {
+ print "</shout>\n";
+ }
+
+=back
+
+=head2 Malloc enhancements
+
+If perl is compiled with the malloc included with the perl distribution
+(that is, if C<perl -V:d_mymalloc> is 'define') then you can print
+memory statistics at runtime by running Perl thusly:
+
+ env PERL_DEBUG_MSTATS=2 perl your_script_here
+
+The value of 2 means to print statistics after compilation and on
+exit; with a value of 1, the statistics are printed only on exit.
+(If you want the statistics at an arbitrary time, you'll need to
+install the optional module Devel::Peek.)
+
+Three new compilation flags are recognized by malloc.c. (They have no
+effect if perl is compiled with system malloc().)
+
+=over
+
+=item -DPERL_EMERGENCY_SBRK
+
+If this macro is defined, running out of memory need not be a fatal
+error: a memory pool can allocated by assigning to the special
+variable C<$^M>. See L<"$^M">.
+
+=item -DPACK_MALLOC
+
+Perl memory allocation is by bucket with sizes close to powers of two.
+Because of these malloc overhead may be big, especially for data of
+size exactly a power of two. If C<PACK_MALLOC> is defined, perl uses
+a slightly different algorithm for small allocations (up to 64 bytes
+long), which makes it possible to have overhead down to 1 byte for
+allocations which are powers of two (and appear quite often).
+
+Expected memory savings (with 8-byte alignment in C<alignbytes>) is
+about 20% for typical Perl usage. Expected slowdown due to additional
+malloc overhead is in fractions of a percent (hard to measure, because
+of the effect of saved memory on speed).
+
+=item -DTWO_POT_OPTIMIZE
+
+Similarly to C<PACK_MALLOC>, this macro improves allocations of data
+with size close to a power of two; but this works for big allocations
+(starting with 16K by default). Such allocations are typical for big
+hashes and special-purpose scripts, especially image processing.
+
+On recent systems, the fact that perl requires 2M from system for 1M
+allocation will not affect speed of execution, since the tail of such
+a chunk is not going to be touched (and thus will not require real
+memory). However, it may result in a premature out-of-memory error.
+So if you will be manipulating very large blocks with sizes close to
+powers of two, it would be wise to define this macro.
+
+Expected saving of memory is 0-100% (100% in applications which
+require most memory in such 2**n chunks); expected slowdown is
+negligible.
+
+=back
+
+=head2 Miscellaneous efficiency enhancements
+
+Functions that have an empty prototype and that do nothing but return
+a fixed value are now inlined (e.g. C<sub PI () { 3.14159 }>).
+
+Each unique hash key is only allocated once, no matter how many hashes
+have an entry with that key. So even if you have 100 copies of the
+same hash, the hash keys never have to be reallocated.
+
+=head1 Support for More Operating Systems
+
+Support for the following operating systems is new in Perl 5.004.
+
+=head2 Win32
+
+Perl 5.004 now includes support for building a "native" perl under
+Windows NT, using the Microsoft Visual C++ compiler (versions 2.0
+and above) or the Borland C++ compiler (versions 5.02 and above).
+The resulting perl can be used under Windows 95 (if it
+is installed in the same directory locations as it got installed
+in Windows NT). This port includes support for perl extension
+building tools like L<MakeMaker> and L<h2xs>, so that many extensions
+available on the Comprehensive Perl Archive Network (CPAN) can now be
+readily built under Windows NT. See http://www.perl.com/ for more
+information on CPAN and F<README.win32> in the perl distribution for more
+details on how to get started with building this port.
+
+There is also support for building perl under the Cygwin32 environment.
+Cygwin32 is a set of GNU tools that make it possible to compile and run
+many UNIX programs under Windows NT by providing a mostly UNIX-like
+interface for compilation and execution. See F<README.cygwin32> in the
+perl distribution for more details on this port and how to obtain the
+Cygwin32 toolkit.
+
+=head2 Plan 9
+
+See F<README.plan9> in the perl distribution.
+
+=head2 QNX
+
+See F<README.qnx> in the perl distribution.
+
+=head2 AmigaOS
+
+See F<README.amigaos> in the perl distribution.
+
+=head1 Pragmata
+
+Six new pragmatic modules exist:
+
+=over
+
+=item use autouse MODULE => qw(sub1 sub2 sub3)
+
+Defers C<require MODULE> until someone calls one of the specified
+subroutines (which must be exported by MODULE). This pragma should be
+used with caution, and only when necessary.
+
+=item use blib
+
+=item use blib 'dir'
+
+Looks for MakeMaker-like I<'blib'> directory structure starting in
+I<dir> (or current directory) and working back up to five levels of
+parent directories.
+
+Intended for use on command line with B<-M> option as a way of testing
+arbitrary scripts against an uninstalled version of a package.
+
+=item use constant NAME => VALUE
+
+Provides a convenient interface for creating compile-time constants,
+See L<perlsub/"Constant Functions">.
+
+=item use locale
+
+Tells the compiler to enable (or disable) the use of POSIX locales for
+builtin operations.
+
+When C<use locale> is in effect, the current LC_CTYPE locale is used
+for regular expressions and case mapping; LC_COLLATE for string
+ordering; and LC_NUMERIC for numeric formating in printf and sprintf
+(but B<not> in print). LC_NUMERIC is always used in write, since
+lexical scoping of formats is problematic at best.
+
+Each C<use locale> or C<no locale> affects statements to the end of
+the enclosing BLOCK or, if not inside a BLOCK, to the end of the
+current file. Locales can be switched and queried with
+POSIX::setlocale().
+
+See L<perllocale> for more information.
+
+=item use ops
+
+Disable unsafe opcodes, or any named opcodes, when compiling Perl code.
+
+=item use vmsish
+
+Enable VMS-specific language features. Currently, there are three
+VMS-specific features available: 'status', which makes C<$?> and
+C<system> return genuine VMS status values instead of emulating POSIX;
+'exit', which makes C<exit> take a genuine VMS status value instead of
+assuming that C<exit 1> is an error; and 'time', which makes all times
+relative to the local time zone, in the VMS tradition.
+
+=back
+
+=head1 Modules
+
+=head2 Required Updates
+
+Though Perl 5.004 is compatible with almost all modules that work
+with Perl 5.003, there are a few exceptions:
+
+ Module Required Version for Perl 5.004
+ ------ -------------------------------
+ Filter Filter-1.12
+ LWP libwww-perl-5.08
+ Tk Tk400.202 (-w makes noise)
+
+Also, the majordomo mailing list program, version 1.94.1, doesn't work
+with Perl 5.004 (nor with perl 4), because it executes an invalid
+regular expression. This bug is fixed in majordomo version 1.94.2.
+
+=head2 Installation directories
+
+The I<installperl> script now places the Perl source files for
+extensions in the architecture-specific library directory, which is
+where the shared libraries for extensions have always been. This
+change is intended to allow administrators to keep the Perl 5.004
+library directory unchanged from a previous version, without running
+the risk of binary incompatibility between extensions' Perl source and
+shared libraries.
+
+=head2 Module information summary
+
+Brand new modules, arranged by topic rather than strictly
+alphabetically:
+
+ CGI.pm Web server interface ("Common Gateway Interface")
+ CGI/Apache.pm Support for Apache's Perl module
+ CGI/Carp.pm Log server errors with helpful context
+ CGI/Fast.pm Support for FastCGI (persistent server process)
+ CGI/Push.pm Support for server push
+ CGI/Switch.pm Simple interface for multiple server types
+
+ CPAN Interface to Comprehensive Perl Archive Network
+ CPAN::FirstTime Utility for creating CPAN configuration file
+ CPAN::Nox Runs CPAN while avoiding compiled extensions
+
+ IO.pm Top-level interface to IO::* classes
+ IO/File.pm IO::File extension Perl module
+ IO/Handle.pm IO::Handle extension Perl module
+ IO/Pipe.pm IO::Pipe extension Perl module
+ IO/Seekable.pm IO::Seekable extension Perl module
+ IO/Select.pm IO::Select extension Perl module
+ IO/Socket.pm IO::Socket extension Perl module
+
+ Opcode.pm Disable named opcodes when compiling Perl code
+
+ ExtUtils/Embed.pm Utilities for embedding Perl in C programs
+ ExtUtils/testlib.pm Fixes up @INC to use just-built extension
+
+ FindBin.pm Find path of currently executing program
+
+ Class/Struct.pm Declare struct-like datatypes as Perl classes
+ File/stat.pm By-name interface to Perl's builtin stat
+ Net/hostent.pm By-name interface to Perl's builtin gethost*
+ Net/netent.pm By-name interface to Perl's builtin getnet*
+ Net/protoent.pm By-name interface to Perl's builtin getproto*
+ Net/servent.pm By-name interface to Perl's builtin getserv*
+ Time/gmtime.pm By-name interface to Perl's builtin gmtime
+ Time/localtime.pm By-name interface to Perl's builtin localtime
+ Time/tm.pm Internal object for Time::{gm,local}time
+ User/grent.pm By-name interface to Perl's builtin getgr*
+ User/pwent.pm By-name interface to Perl's builtin getpw*
+
+ Tie/RefHash.pm Base class for tied hashes with references as keys
+
+ UNIVERSAL.pm Base class for *ALL* classes
+
+=head2 Fcntl
+
+New constants in the existing Fcntl modules are now supported,
+provided that your operating system happens to support them:
+
+ F_GETOWN F_SETOWN
+ O_ASYNC O_DEFER O_DSYNC O_FSYNC O_SYNC
+ O_EXLOCK O_SHLOCK
+
+These constants are intended for use with the Perl operators sysopen()
+and fcntl() and the basic database modules like SDBM_File. For the
+exact meaning of these and other Fcntl constants please refer to your
+operating system's documentation for fcntl() and open().
+
+In addition, the Fcntl module now provides these constants for use
+with the Perl operator flock():
+
+ LOCK_SH LOCK_EX LOCK_NB LOCK_UN
+
+These constants are defined in all environments (because where there is
+no flock() system call, Perl emulates it). However, for historical
+reasons, these constants are not exported unless they are explicitly
+requested with the ":flock" tag (e.g. C<use Fcntl ':flock'>).
+
+=head2 IO
+
+The IO module provides a simple mechanism to load all of the IO modules at one
+go. Currently this includes:
+
+ IO::Handle
+ IO::Seekable
+ IO::File
+ IO::Pipe
+ IO::Socket
+
+For more information on any of these modules, please see its
+respective documentation.
+
+=head2 Math::Complex
+
+The Math::Complex module has been totally rewritten, and now supports
+more operations. These are overloaded:
+
+ + - * / ** <=> neg ~ abs sqrt exp log sin cos atan2 "" (stringify)
+
+And these functions are now exported:
+
+ pi i Re Im arg
+ log10 logn ln cbrt root
+ tan
+ csc sec cot
+ asin acos atan
+ acsc asec acot
+ sinh cosh tanh
+ csch sech coth
+ asinh acosh atanh
+ acsch asech acoth
+ cplx cplxe
+
+=head2 Math::Trig
+
+This new module provides a simpler interface to parts of Math::Complex for
+those who need trigonometric functions only for real numbers.
+
+=head2 DB_File
+
+There have been quite a few changes made to DB_File. Here are a few of
+the highlights:
+
+=over
+
+=item *
+
+Fixed a handful of bugs.
+
+=item *
+
+By public demand, added support for the standard hash function exists().
+
+=item *
+
+Made it compatible with Berkeley DB 1.86.
+
+=item *
+
+Made negative subscripts work with RECNO interface.
+
+=item *
+
+Changed the default flags from O_RDWR to O_CREAT|O_RDWR and the default
+mode from 0640 to 0666.
+
+=item *
+
+Made DB_File automatically import the open() constants (O_RDWR,
+O_CREAT etc.) from Fcntl, if available.
+
+=item *
+
+Updated documentation.
+
+=back
+
+Refer to the HISTORY section in DB_File.pm for a complete list of
+changes. Everything after DB_File 1.01 has been added since 5.003.
+
+=head2 Net::Ping
+
+Major rewrite - support added for both udp echo and real icmp pings.
+
+=head2 Object-oriented overrides for builtin operators
+
+Many of the Perl builtins returning lists now have
+object-oriented overrides. These are:
+
+ File::stat
+ Net::hostent
+ Net::netent
+ Net::protoent
+ Net::servent
+ Time::gmtime
+ Time::localtime
+ User::grent
+ User::pwent
+
+For example, you can now say
+
+ use File::stat;
+ use User::pwent;
+ $his = (stat($filename)->st_uid == pwent($whoever)->pw_uid);
+
+=head1 Utility Changes
+
+=head2 pod2html
+
+=over
+
+=item Sends converted HTML to standard output
+
+The I<pod2html> utility included with Perl 5.004 is entirely new.
+By default, it sends the converted HTML to its standard output,
+instead of writing it to a file like Perl 5.003's I<pod2html> did.
+Use the B<--outfile=FILENAME> option to write to a file.
+
+=back
+
+=head2 xsubpp
+
+=over
+
+=item C<void> XSUBs now default to returning nothing
+
+Due to a documentation/implementation bug in previous versions of
+Perl, XSUBs with a return type of C<void> have actually been
+returning one value. Usually that value was the GV for the XSUB,
+but sometimes it was some already freed or reused value, which would
+sometimes lead to program failure.
+
+In Perl 5.004, if an XSUB is declared as returning C<void>, it
+actually returns no value, i.e. an empty list (though there is a
+backward-compatibility exception; see below). If your XSUB really
+does return an SV, you should give it a return type of C<SV *>.
+
+For backward compatibility, I<xsubpp> tries to guess whether a
+C<void> XSUB is really C<void> or if it wants to return an C<SV *>.
+It does so by examining the text of the XSUB: if I<xsubpp> finds
+what looks like an assignment to C<ST(0)>, it assumes that the
+XSUB's return type is really C<SV *>.
+
+=back
+
+=head1 C Language API Changes
+
+=over
+
+=item C<gv_fetchmethod> and C<perl_call_sv>
+
+The C<gv_fetchmethod> function finds a method for an object, just like
+in Perl 5.003. The GV it returns may be a method cache entry.
+However, in Perl 5.004, method cache entries are not visible to users;
+therefore, they can no longer be passed directly to C<perl_call_sv>.
+Instead, you should use the C<GvCV> macro on the GV to extract its CV,
+and pass the CV to C<perl_call_sv>.
+
+The most likely symptom of passing the result of C<gv_fetchmethod> to
+C<perl_call_sv> is Perl's producing an "Undefined subroutine called"
+error on the I<second> call to a given method (since there is no cache
+on the first call).
+
+=item C<perl_eval_pv>
+
+A new function handy for eval'ing strings of Perl code inside C code.
+This function returns the value from the eval statement, which can
+be used instead of fetching globals from the symbol table. See
+L<perlguts>, L<perlembed> and L<perlcall> for details and examples.
+
+=item Extended API for manipulating hashes
+
+Internal handling of hash keys has changed. The old hashtable API is
+still fully supported, and will likely remain so. The additions to the
+API allow passing keys as C<SV*>s, so that C<tied> hashes can be given
+real scalars as keys rather than plain strings (nontied hashes still
+can only use strings as keys). New extensions must use the new hash
+access functions and macros if they wish to use C<SV*> keys. These
+additions also make it feasible to manipulate C<HE*>s (hash entries),
+which can be more efficient. See L<perlguts> for details.
+
+=back
+
+=head1 Documentation Changes
+
+Many of the base and library pods were updated. These
+new pods are included in section 1:
+
+=over
+
+=item L<perldelta>
+
+This document.
+
+=item L<perlfaq>
+
+Frequently asked questions.
+
+=item L<perllocale>
+
+Locale support (internationalization and localization).
+
+=item L<perltoot>
+
+Tutorial on Perl OO programming.
+
+=item L<perlapio>
+
+Perl internal IO abstraction interface.
+
+=item L<perlmodlib>
+
+Perl module library and recommended practice for module creation.
+Extracted from L<perlmod> (which is much smaller as a result).
+
+=item L<perldebug>
+
+Although not new, this has been massively updated.
+
+=item L<perlsec>
+
+Although not new, this has been massively updated.
+
+=back
+
+=head1 New Diagnostics
+
+Several new conditions will trigger warnings that were
+silent before. Some only affect certain platforms.
+The following new warnings and errors outline these.
+These messages are classified as follows (listed in
+increasing order of desperation):
+
+ (W) A warning (optional).
+ (D) A deprecation (optional).
+ (S) A severe warning (mandatory).
+ (F) A fatal error (trappable).
+ (P) An internal error you should never see (trappable).
+ (X) A very fatal error (nontrappable).
+ (A) An alien error message (not generated by Perl).
+
+=over
+
+=item "my" variable %s masks earlier declaration in same scope
+
+(W) A lexical variable has been redeclared in the same scope, effectively
+eliminating all access to the previous instance. This is almost always
+a typographical error. Note that the earlier variable will still exist
+until the end of the scope or until all closure referents to it are
+destroyed.
+
+=item %s argument is not a HASH element or slice
+
+(F) The argument to delete() must be either a hash element, such as
+
+ $foo{$bar}
+ $ref->[12]->{"susie"}
+
+or a hash slice, such as
+
+ @foo{$bar, $baz, $xyzzy}
+ @{$ref->[12]}{"susie", "queue"}
+
+=item Allocation too large: %lx
+
+(X) You can't allocate more than 64K on an MS-DOS machine.
+
+=item Allocation too large
+
+(F) You can't allocate more than 2^31+"small amount" bytes.
+
+=item Applying %s to %s will act on scalar(%s)
+
+(W) The pattern match (//), substitution (s///), and transliteration (tr///)
+operators work on scalar values. If you apply one of them to an array
+or a hash, it will convert the array or hash to a scalar value -- the
+length of an array, or the population info of a hash -- and then work on
+that scalar value. This is probably not what you meant to do. See
+L<perlfunc/grep> and L<perlfunc/map> for alternatives.
+
+=item Attempt to free nonexistent shared string
+
+(P) Perl maintains a reference counted internal table of strings to
+optimize the storage and access of hash keys and other strings. This
+indicates someone tried to decrement the reference count of a string
+that can no longer be found in the table.
+
+=item Attempt to use reference as lvalue in substr
+
+(W) You supplied a reference as the first argument to substr() used
+as an lvalue, which is pretty strange. Perhaps you forgot to
+dereference it first. See L<perlfunc/substr>.
+
+=item Bareword "%s" refers to nonexistent package
+
+(W) You used a qualified bareword of the form C<Foo::>, but
+the compiler saw no other uses of that namespace before that point.
+Perhaps you need to predeclare a package?
+
+=item Can't redefine active sort subroutine %s
+
+(F) Perl optimizes the internal handling of sort subroutines and keeps
+pointers into them. You tried to redefine one such sort subroutine when it
+was currently active, which is not allowed. If you really want to do
+this, you should write C<sort { &func } @x> instead of C<sort func @x>.
+
+=item Can't use bareword ("%s") as %s ref while "strict refs" in use
+
+(F) Only hard references are allowed by "strict refs". Symbolic references
+are disallowed. See L<perlref>.
+
+=item Cannot resolve method `%s' overloading `%s' in package `%s'
+
+(P) Internal error trying to resolve overloading specified by a method
+name (as opposed to a subroutine reference).
+
+=item Constant subroutine %s redefined
+
+(S) You redefined a subroutine which had previously been eligible for
+inlining. See L<perlsub/"Constant Functions"> for commentary and
+workarounds.
+
+=item Constant subroutine %s undefined
+
+(S) You undefined a subroutine which had previously been eligible for
+inlining. See L<perlsub/"Constant Functions"> for commentary and
+workarounds.
+
+=item Copy method did not return a reference
+
+(F) The method which overloads "=" is buggy. See L<overload/Copy Constructor>.
+
+=item Died
+
+(F) You passed die() an empty string (the equivalent of C<die "">) or
+you called it with no args and both C<$@> and C<$_> were empty.
+
+=item Exiting pseudo-block via %s
+
+(W) You are exiting a rather special block construct (like a sort block or
+subroutine) by unconventional means, such as a goto, or a loop control
+statement. See L<perlfunc/sort>.
+
+=item Identifier too long
+
+(F) Perl limits identifiers (names for variables, functions, etc.) to
+252 characters for simple names, somewhat more for compound names (like
+C<$A::B>). You've exceeded Perl's limits. Future versions of Perl are
+likely to eliminate these arbitrary limitations.
+
+=item Illegal character %s (carriage return)
+
+(F) A carriage return character was found in the input. This is an
+error, and not a warning, because carriage return characters can break
+multi-line strings, including here documents (e.g., C<print E<lt>E<lt>EOF;>).
+
+=item Illegal switch in PERL5OPT: %s
+
+(X) The PERL5OPT environment variable may only be used to set the
+following switches: B<-[DIMUdmw]>.
+
+=item Integer overflow in hex number
+
+(S) The literal hex number you have specified is too big for your
+architecture. On a 32-bit architecture the largest hex literal is
+0xFFFFFFFF.
+
+=item Integer overflow in octal number
+
+(S) The literal octal number you have specified is too big for your
+architecture. On a 32-bit architecture the largest octal literal is
+037777777777.
+
+=item internal error: glob failed
+
+(P) Something went wrong with the external program(s) used for C<glob>
+and C<E<lt>*.cE<gt>>. This may mean that your csh (C shell) is
+broken. If so, you should change all of the csh-related variables in
+config.sh: If you have tcsh, make the variables refer to it as if it
+were csh (e.g. C<full_csh='/usr/bin/tcsh'>); otherwise, make them all
+empty (except that C<d_csh> should be C<'undef'>) so that Perl will
+think csh is missing. In either case, after editing config.sh, run
+C<./Configure -S> and rebuild Perl.
+
+=item Invalid conversion in %s: "%s"
+
+(W) Perl does not understand the given format conversion.
+See L<perlfunc/sprintf>.
+
+=item Invalid type in pack: '%s'
+
+(F) The given character is not a valid pack type. See L<perlfunc/pack>.
+
+=item Invalid type in unpack: '%s'
+
+(F) The given character is not a valid unpack type. See L<perlfunc/unpack>.
+
+=item Name "%s::%s" used only once: possible typo
+
+(W) Typographical errors often show up as unique variable names.
+If you had a good reason for having a unique name, then just mention
+it again somehow to suppress the message (the C<use vars> pragma is
+provided for just this purpose).
+
+=item Null picture in formline
+
+(F) The first argument to formline must be a valid format picture
+specification. It was found to be empty, which probably means you
+supplied it an uninitialized value. See L<perlform>.
+
+=item Offset outside string
+
+(F) You tried to do a read/write/send/recv operation with an offset
+pointing outside the buffer. This is difficult to imagine.
+The sole exception to this is that C<sysread()>ing past the buffer
+will extend the buffer and zero pad the new area.
+
+=item Out of memory!
+
+(X|F) The malloc() function returned 0, indicating there was insufficient
+remaining memory (or virtual memory) to satisfy the request.
+
+The request was judged to be small, so the possibility to trap it
+depends on the way Perl was compiled. By default it is not trappable.
+However, if compiled for this, Perl may use the contents of C<$^M> as
+an emergency pool after die()ing with this message. In this case the
+error is trappable I<once>.
+
+=item Out of memory during request for %s
+
+(F) The malloc() function returned 0, indicating there was insufficient
+remaining memory (or virtual memory) to satisfy the request. However,
+the request was judged large enough (compile-time default is 64K), so
+a possibility to shut down by trapping this error is granted.
+
+=item panic: frexp
+
+(P) The library function frexp() failed, making printf("%f") impossible.
+
+=item Possible attempt to put comments in qw() list
+
+(W) qw() lists contain items separated by whitespace; as with literal
+strings, comment characters are not ignored, but are instead treated
+as literal data. (You may have used different delimiters than the
+parentheses shown here; braces are also frequently used.)
+
+You probably wrote something like this:
+
+ @list = qw(
+ a # a comment
+ b # another comment
+ );
+
+when you should have written this:
+
+ @list = qw(
+ a
+ b
+ );
+
+If you really want comments, build your list the
+old-fashioned way, with quotes and commas:
+
+ @list = (
+ 'a', # a comment
+ 'b', # another comment
+ );
+
+=item Possible attempt to separate words with commas
+
+(W) qw() lists contain items separated by whitespace; therefore commas
+aren't needed to separate the items. (You may have used different
+delimiters than the parentheses shown here; braces are also frequently
+used.)
+
+You probably wrote something like this:
+
+ qw! a, b, c !;
+
+which puts literal commas into some of the list items. Write it without
+commas if you don't want them to appear in your data:
+
+ qw! a b c !;
+
+=item Scalar value @%s{%s} better written as $%s{%s}
+
+(W) You've used a hash slice (indicated by @) to select a single element of
+a hash. Generally it's better to ask for a scalar value (indicated by $).
+The difference is that C<$foo{&bar}> always behaves like a scalar, both when
+assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves
+like a list when you assign to it, and provides a list context to its
+subscript, which can do weird things if you're expecting only one subscript.
+
+=item Stub found while resolving method `%s' overloading `%s' in package `%s'
+
+(P) Overloading resolution over @ISA tree may be broken by importing stubs.
+Stubs should never be implicitely created, but explicit calls to C<can>
+may break this.
+
+=item Too late for "B<-T>" option
+
+(X) The #! line (or local equivalent) in a Perl script contains the
+B<-T> option, but Perl was not invoked with B<-T> in its argument
+list. This is an error because, by the time Perl discovers a B<-T> in
+a script, it's too late to properly taint everything from the
+environment. So Perl gives up.
+
+=item untie attempted while %d inner references still exist
+
+(W) A copy of the object returned from C<tie> (or C<tied>) was still
+valid when C<untie> was called.
+
+=item Unrecognized character %s
+
+(F) The Perl parser has no idea what to do with the specified character
+in your Perl script (or eval). Perhaps you tried to run a compressed
+script, a binary program, or a directory as a Perl program.
+
+=item Unsupported function fork
+
+(F) Your version of executable does not support forking.
+
+Note that under some systems, like OS/2, there may be different flavors of
+Perl executables, some of which may support fork, some not. Try changing
+the name you call Perl by to C<perl_>, C<perl__>, and so on.
+
+=item Use of "$$<digit>" to mean "${$}<digit>" is deprecated
+
+(D) Perl versions before 5.004 misinterpreted any type marker followed
+by "$" and a digit. For example, "$$0" was incorrectly taken to mean
+"${$}0" instead of "${$0}". This bug is (mostly) fixed in Perl 5.004.
+
+However, the developers of Perl 5.004 could not fix this bug completely,
+because at least two widely-used modules depend on the old meaning of
+"$$0" in a string. So Perl 5.004 still interprets "$$<digit>" in the
+old (broken) way inside strings; but it generates this message as a
+warning. And in Perl 5.005, this special treatment will cease.
+
+=item Value of %s can be "0"; test with defined()
+
+(W) In a conditional expression, you used <HANDLE>, <*> (glob), C<each()>,
+or C<readdir()> as a boolean value. Each of these constructs can return a
+value of "0"; that would make the conditional expression false, which is
+probably not what you intended. When using these constructs in conditional
+expressions, test their values with the C<defined> operator.
+
+=item Variable "%s" may be unavailable
+
+(W) An inner (nested) I<anonymous> subroutine is inside a I<named>
+subroutine, and outside that is another subroutine; and the anonymous
+(innermost) subroutine is referencing a lexical variable defined in
+the outermost subroutine. For example:
+
+ sub outermost { my $a; sub middle { sub { $a } } }
+
+If the anonymous subroutine is called or referenced (directly or
+indirectly) from the outermost subroutine, it will share the variable
+as you would expect. But if the anonymous subroutine is called or
+referenced when the outermost subroutine is not active, it will see
+the value of the shared variable as it was before and during the
+*first* call to the outermost subroutine, which is probably not what
+you want.
+
+In these circumstances, it is usually best to make the middle
+subroutine anonymous, using the C<sub {}> syntax. Perl has specific
+support for shared variables in nested anonymous subroutines; a named
+subroutine in between interferes with this feature.
+
+=item Variable "%s" will not stay shared
+
+(W) An inner (nested) I<named> subroutine is referencing a lexical
+variable defined in an outer subroutine.
+
+When the inner subroutine is called, it will probably see the value of
+the outer subroutine's variable as it was before and during the
+*first* call to the outer subroutine; in this case, after the first
+call to the outer subroutine is complete, the inner and outer
+subroutines will no longer share a common value for the variable. In
+other words, the variable will no longer be shared.
+
+Furthermore, if the outer subroutine is anonymous and references a
+lexical variable outside itself, then the outer and inner subroutines
+will I<never> share the given variable.
+
+This problem can usually be solved by making the inner subroutine
+anonymous, using the C<sub {}> syntax. When inner anonymous subs that
+reference variables in outer subroutines are called or referenced,
+they are automatically rebound to the current values of such
+variables.
+
+=item Warning: something's wrong
+
+(W) You passed warn() an empty string (the equivalent of C<warn "">) or
+you called it with no args and C<$_> was empty.
+
+=item Ill-formed logical name |%s| in prime_env_iter
+
+(W) A warning peculiar to VMS. A logical name was encountered when preparing
+to iterate over %ENV which violates the syntactic rules governing logical
+names. Since it cannot be translated normally, it is skipped, and will not
+appear in %ENV. This may be a benign occurrence, as some software packages
+might directly modify logical name tables and introduce nonstandard names,
+or it may indicate that a logical name table has been corrupted.
+
+=item Got an error from DosAllocMem
+
+(P) An error peculiar to OS/2. Most probably you're using an obsolete
+version of Perl, and this should not happen anyway.
+
+=item Malformed PERLLIB_PREFIX
+
+(F) An error peculiar to OS/2. PERLLIB_PREFIX should be of the form
+
+ prefix1;prefix2
+
+or
+
+ prefix1 prefix2
+
+with nonempty prefix1 and prefix2. If C<prefix1> is indeed a prefix
+of a builtin library search path, prefix2 is substituted. The error
+may appear if components are not found, or are too long. See
+"PERLLIB_PREFIX" in F<README.os2>.
+
+=item PERL_SH_DIR too long
+
+(F) An error peculiar to OS/2. PERL_SH_DIR is the directory to find the
+C<sh>-shell in. See "PERL_SH_DIR" in F<README.os2>.
+
+=item Process terminated by SIG%s
+
+(W) This is a standard message issued by OS/2 applications, while *nix
+applications die in silence. It is considered a feature of the OS/2
+port. One can easily disable this by appropriate sighandlers, see
+L<perlipc/"Signals">. See also "Process terminated by SIGTERM/SIGINT"
+in F<README.os2>.
+
+=back
+
+=head1 BUGS
+
+If you find what you think is a bug, you might check the headers of
+recently posted articles in the comp.lang.perl.misc newsgroup.
+There may also be information at http://www.perl.com/perl/, the Perl
+Home Page.
+
+If you believe you have an unreported bug, please run the B<perlbug>
+program included with your release. Make sure you trim your bug down
+to a tiny but sufficient test case. Your bug report, along with the
+output of C<perl -V>, will be sent off to <F<perlbug@perl.com>> to be
+analysed by the Perl porting team.
+
+=head1 SEE ALSO
+
+The F<Changes> file for exhaustive details on what changed.
+
+The F<INSTALL> file for how to build Perl. This file has been
+significantly updated for 5.004, so even veteran users should
+look through it.
+
+The F<README> file for general stuff.
+
+The F<Copying> file for copyright information.
+
+=head1 HISTORY
+
+Constructed by Tom Christiansen, grabbing material with permission
+from innumerable contributors, with kibitzing by more than a few Perl
+porters.
+
+Last update: Wed May 14 11:14:09 EDT 1997
diff --git a/contrib/perl5/pod/perlapio.pod b/contrib/perl5/pod/perlapio.pod
new file mode 100644
index 000000000000..90475a9543f4
--- /dev/null
+++ b/contrib/perl5/pod/perlapio.pod
@@ -0,0 +1,274 @@
+=head1 NAME
+
+perlapio - perl's IO abstraction interface.
+
+=head1 SYNOPSIS
+
+ PerlIO *PerlIO_stdin(void);
+ PerlIO *PerlIO_stdout(void);
+ PerlIO *PerlIO_stderr(void);
+
+ PerlIO *PerlIO_open(const char *,const char *);
+ int PerlIO_close(PerlIO *);
+
+ int PerlIO_stdoutf(const char *,...)
+ int PerlIO_puts(PerlIO *,const char *);
+ int PerlIO_putc(PerlIO *,int);
+ int PerlIO_write(PerlIO *,const void *,size_t);
+ int PerlIO_printf(PerlIO *, const char *,...);
+ int PerlIO_vprintf(PerlIO *, const char *, va_list);
+ int PerlIO_flush(PerlIO *);
+
+ int PerlIO_eof(PerlIO *);
+ int PerlIO_error(PerlIO *);
+ void PerlIO_clearerr(PerlIO *);
+
+ int PerlIO_getc(PerlIO *);
+ int PerlIO_ungetc(PerlIO *,int);
+ int PerlIO_read(PerlIO *,void *,size_t);
+
+ int PerlIO_fileno(PerlIO *);
+ PerlIO *PerlIO_fdopen(int, const char *);
+ PerlIO *PerlIO_importFILE(FILE *, int flags);
+ FILE *PerlIO_exportFILE(PerlIO *, int flags);
+ FILE *PerlIO_findFILE(PerlIO *);
+ void PerlIO_releaseFILE(PerlIO *,FILE *);
+
+ void PerlIO_setlinebuf(PerlIO *);
+
+ long PerlIO_tell(PerlIO *);
+ int PerlIO_seek(PerlIO *,off_t,int);
+ int PerlIO_getpos(PerlIO *,Fpos_t *)
+ int PerlIO_setpos(PerlIO *,Fpos_t *)
+ void PerlIO_rewind(PerlIO *);
+
+ int PerlIO_has_base(PerlIO *);
+ int PerlIO_has_cntptr(PerlIO *);
+ int PerlIO_fast_gets(PerlIO *);
+ int PerlIO_canset_cnt(PerlIO *);
+
+ char *PerlIO_get_ptr(PerlIO *);
+ int PerlIO_get_cnt(PerlIO *);
+ void PerlIO_set_cnt(PerlIO *,int);
+ void PerlIO_set_ptrcnt(PerlIO *,char *,int);
+ char *PerlIO_get_base(PerlIO *);
+ int PerlIO_get_bufsiz(PerlIO *);
+
+=head1 DESCRIPTION
+
+Perl's source code should use the above functions instead of those
+defined in ANSI C's I<stdio.h>. The perl headers will C<#define> them to
+the I/O mechanism selected at Configure time.
+
+The functions are modeled on those in I<stdio.h>, but parameter order
+has been "tidied up a little".
+
+=over 4
+
+=item B<PerlIO *>
+
+This takes the place of FILE *. Like FILE * it should be treated as
+opaque (it is probably safe to assume it is a pointer to something).
+
+=item B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()>
+
+Use these rather than C<stdin>, C<stdout>, C<stderr>. They are written
+to look like "function calls" rather than variables because this makes
+it easier to I<make them> function calls if platform cannot export data
+to loaded modules, or if (say) different "threads" might have different
+values.
+
+=item B<PerlIO_open(path, mode)>, B<PerlIO_fdopen(fd,mode)>
+
+These correspond to fopen()/fdopen() arguments are the same.
+
+=item B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)>
+
+These are fprintf()/vfprintf() equivalents.
+
+=item B<PerlIO_stdoutf(fmt,...)>
+
+This is printf() equivalent. printf is #defined to this function,
+so it is (currently) legal to use C<printf(fmt,...)> in perl sources.
+
+=item B<PerlIO_read(f,buf,count)>, B<PerlIO_write(f,buf,count)>
+
+These correspond to fread() and fwrite(). Note that arguments
+are different, there is only one "count" and order has
+"file" first.
+
+=item B<PerlIO_close(f)>
+
+=item B<PerlIO_puts(f,s)>, B<PerlIO_putc(f,c)>
+
+These correspond to fputs() and fputc().
+Note that arguments have been revised to have "file" first.
+
+=item B<PerlIO_ungetc(f,c)>
+
+This corresponds to ungetc().
+Note that arguments have been revised to have "file" first.
+
+=item B<PerlIO_getc(f)>
+
+This corresponds to getc().
+
+=item B<PerlIO_eof(f)>
+
+This corresponds to feof().
+
+=item B<PerlIO_error(f)>
+
+This corresponds to ferror().
+
+=item B<PerlIO_fileno(f)>
+
+This corresponds to fileno(), note that on some platforms,
+the meaning of "fileno" may not match Unix.
+
+=item B<PerlIO_clearerr(f)>
+
+This corresponds to clearerr(), i.e., clears 'eof' and 'error'
+flags for the "stream".
+
+=item B<PerlIO_flush(f)>
+
+This corresponds to fflush().
+
+=item B<PerlIO_tell(f)>
+
+This corresponds to ftell().
+
+=item B<PerlIO_seek(f,o,w)>
+
+This corresponds to fseek().
+
+=item B<PerlIO_getpos(f,p)>, B<PerlIO_setpos(f,p)>
+
+These correspond to fgetpos() and fsetpos(). If platform does not
+have the stdio calls then they are implemented in terms of PerlIO_tell()
+and PerlIO_seek().
+
+=item B<PerlIO_rewind(f)>
+
+This corresponds to rewind(). Note may be redefined
+in terms of PerlIO_seek() at some point.
+
+=item B<PerlIO_tmpfile()>
+
+This corresponds to tmpfile(), i.e., returns an anonymous
+PerlIO which will automatically be deleted when closed.
+
+=back
+
+=head2 Co-existence with stdio
+
+There is outline support for co-existence of PerlIO with stdio.
+Obviously if PerlIO is implemented in terms of stdio there is
+no problem. However if perlio is implemented on top of (say) sfio
+then mechanisms must exist to create a FILE * which can be passed
+to library code which is going to use stdio calls.
+
+=over 4
+
+=item B<PerlIO_importFILE(f,flags)>
+
+Used to get a PerlIO * from a FILE *.
+May need additional arguments, interface under review.
+
+=item B<PerlIO_exportFILE(f,flags)>
+
+Given an PerlIO * return a 'native' FILE * suitable for
+passing to code expecting to be compiled and linked with
+ANSI C I<stdio.h>.
+
+The fact that such a FILE * has been 'exported' is recorded,
+and may affect future PerlIO operations on the original
+PerlIO *.
+
+=item B<PerlIO_findFILE(f)>
+
+Returns previously 'exported' FILE * (if any).
+Place holder until interface is fully defined.
+
+=item B<PerlIO_releaseFILE(p,f)>
+
+Calling PerlIO_releaseFILE informs PerlIO that all use
+of FILE * is complete. It is removed from list of 'exported'
+FILE *s, and associated PerlIO * should revert to original
+behaviour.
+
+=item B<PerlIO_setlinebuf(f)>
+
+This corresponds to setlinebuf(). Use is deprecated pending
+further discussion. (Perl core uses it I<only> when "dumping";
+it has nothing to do with $| auto-flush.)
+
+=back
+
+In addition to user API above there is an "implementation" interface
+which allows perl to get at internals of PerlIO.
+The following calls correspond to the various FILE_xxx macros determined
+by Configure. This section is really of interest to only those
+concerned with detailed perl-core behaviour or implementing a
+PerlIO mapping.
+
+=over 4
+
+=item B<PerlIO_has_cntptr(f)>
+
+Implementation can return pointer to current position in the "buffer" and
+a count of bytes available in the buffer.
+
+=item B<PerlIO_get_ptr(f)>
+
+Return pointer to next readable byte in buffer.
+
+=item B<PerlIO_get_cnt(f)>
+
+Return count of readable bytes in the buffer.
+
+=item B<PerlIO_canset_cnt(f)>
+
+Implementation can adjust its idea of number of
+bytes in the buffer.
+
+=item B<PerlIO_fast_gets(f)>
+
+Implementation has all the interfaces required to
+allow perl's fast code to handle <FILE> mechanism.
+
+ PerlIO_fast_gets(f) = PerlIO_has_cntptr(f) && \
+ PerlIO_canset_cnt(f) && \
+ `Can set pointer into buffer'
+
+=item B<PerlIO_set_ptrcnt(f,p,c)>
+
+Set pointer into buffer, and a count of bytes still in the
+buffer. Should be used only to set
+pointer to within range implied by previous calls
+to C<PerlIO_get_ptr> and C<PerlIO_get_cnt>.
+
+=item B<PerlIO_set_cnt(f,c)>
+
+Obscure - set count of bytes in the buffer. Deprecated.
+Currently used in only doio.c to force count < -1 to -1.
+Perhaps should be PerlIO_set_empty or similar.
+This call may actually do nothing if "count" is deduced from pointer
+and a "limit".
+
+=item B<PerlIO_has_base(f)>
+
+Implementation has a buffer, and can return pointer
+to whole buffer and its size. Used by perl for B<-T> / B<-B> tests.
+Other uses would be very obscure...
+
+=item B<PerlIO_get_base(f)>
+
+Return I<start> of buffer.
+
+=item B<PerlIO_get_bufsiz(f)>
+
+Return I<total size> of buffer.
+
+=back
diff --git a/contrib/perl5/pod/perlbook.pod b/contrib/perl5/pod/perlbook.pod
new file mode 100644
index 000000000000..76763cd8be1f
--- /dev/null
+++ b/contrib/perl5/pod/perlbook.pod
@@ -0,0 +1,16 @@
+=head1 NAME
+
+perlbook - Perl book information
+
+=head1 DESCRIPTION
+
+The Camel Book, officially known as I<Programming Perl, Second Edition>,
+by Larry Wall et al, is the definitive reference work covering nearly
+all of Perl. You can order it and other Perl books from O'Reilly &
+Associates, 1-800-998-9938. Local/overseas is +1 707 829 0515. If you
+can locate an O'Reilly order form, you can also fax to +1 707 829 0104.
+If you're web-connected, you can even mosey on over to http://www.ora.com/
+for an online order form.
+
+Other Perl books from various publishers and authors
+can be found listed in L<perlfaq3>.
diff --git a/contrib/perl5/pod/perlbot.pod b/contrib/perl5/pod/perlbot.pod
new file mode 100644
index 000000000000..bc4e4da1f775
--- /dev/null
+++ b/contrib/perl5/pod/perlbot.pod
@@ -0,0 +1,527 @@
+=head1 NAME
+
+perlbot - Bag'o Object Tricks (the BOT)
+
+=head1 DESCRIPTION
+
+The following collection of tricks and hints is intended to whet curious
+appetites about such things as the use of instance variables and the
+mechanics of object and class relationships. The reader is encouraged to
+consult relevant textbooks for discussion of Object Oriented definitions and
+methodology. This is not intended as a tutorial for object-oriented
+programming or as a comprehensive guide to Perl's object oriented features,
+nor should it be construed as a style guide.
+
+The Perl motto still holds: There's more than one way to do it.
+
+=head1 OO SCALING TIPS
+
+=over 5
+
+=item 1
+
+Do not attempt to verify the type of $self. That'll break if the class is
+inherited, when the type of $self is valid but its package isn't what you
+expect. See rule 5.
+
+=item 2
+
+If an object-oriented (OO) or indirect-object (IO) syntax was used, then the
+object is probably the correct type and there's no need to become paranoid
+about it. Perl isn't a paranoid language anyway. If people subvert the OO
+or IO syntax then they probably know what they're doing and you should let
+them do it. See rule 1.
+
+=item 3
+
+Use the two-argument form of bless(). Let a subclass use your constructor.
+See L<INHERITING A CONSTRUCTOR>.
+
+=item 4
+
+The subclass is allowed to know things about its immediate superclass, the
+superclass is allowed to know nothing about a subclass.
+
+=item 5
+
+Don't be trigger happy with inheritance. A "using", "containing", or
+"delegation" relationship (some sort of aggregation, at least) is often more
+appropriate. See L<OBJECT RELATIONSHIPS>, L<USING RELATIONSHIP WITH SDBM>,
+and L<"DELEGATION">.
+
+=item 6
+
+The object is the namespace. Make package globals accessible via the
+object. This will remove the guess work about the symbol's home package.
+See L<CLASS CONTEXT AND THE OBJECT>.
+
+=item 7
+
+IO syntax is certainly less noisy, but it is also prone to ambiguities that
+can cause difficult-to-find bugs. Allow people to use the sure-thing OO
+syntax, even if you don't like it.
+
+=item 8
+
+Do not use function-call syntax on a method. You're going to be bitten
+someday. Someone might move that method into a superclass and your code
+will be broken. On top of that you're feeding the paranoia in rule 2.
+
+=item 9
+
+Don't assume you know the home package of a method. You're making it
+difficult for someone to override that method. See L<THINKING OF CODE REUSE>.
+
+=back
+
+=head1 INSTANCE VARIABLES
+
+An anonymous array or anonymous hash can be used to hold instance
+variables. Named parameters are also demonstrated.
+
+ package Foo;
+
+ sub new {
+ my $type = shift;
+ my %params = @_;
+ my $self = {};
+ $self->{'High'} = $params{'High'};
+ $self->{'Low'} = $params{'Low'};
+ bless $self, $type;
+ }
+
+
+ package Bar;
+
+ sub new {
+ my $type = shift;
+ my %params = @_;
+ my $self = [];
+ $self->[0] = $params{'Left'};
+ $self->[1] = $params{'Right'};
+ bless $self, $type;
+ }
+
+ package main;
+
+ $a = Foo->new( 'High' => 42, 'Low' => 11 );
+ print "High=$a->{'High'}\n";
+ print "Low=$a->{'Low'}\n";
+
+ $b = Bar->new( 'Left' => 78, 'Right' => 40 );
+ print "Left=$b->[0]\n";
+ print "Right=$b->[1]\n";
+
+=head1 SCALAR INSTANCE VARIABLES
+
+An anonymous scalar can be used when only one instance variable is needed.
+
+ package Foo;
+
+ sub new {
+ my $type = shift;
+ my $self;
+ $self = shift;
+ bless \$self, $type;
+ }
+
+ package main;
+
+ $a = Foo->new( 42 );
+ print "a=$$a\n";
+
+
+=head1 INSTANCE VARIABLE INHERITANCE
+
+This example demonstrates how one might inherit instance variables from a
+superclass for inclusion in the new class. This requires calling the
+superclass's constructor and adding one's own instance variables to the new
+object.
+
+ package Bar;
+
+ sub new {
+ my $type = shift;
+ my $self = {};
+ $self->{'buz'} = 42;
+ bless $self, $type;
+ }
+
+ package Foo;
+ @ISA = qw( Bar );
+
+ sub new {
+ my $type = shift;
+ my $self = Bar->new;
+ $self->{'biz'} = 11;
+ bless $self, $type;
+ }
+
+ package main;
+
+ $a = Foo->new;
+ print "buz = ", $a->{'buz'}, "\n";
+ print "biz = ", $a->{'biz'}, "\n";
+
+
+
+=head1 OBJECT RELATIONSHIPS
+
+The following demonstrates how one might implement "containing" and "using"
+relationships between objects.
+
+ package Bar;
+
+ sub new {
+ my $type = shift;
+ my $self = {};
+ $self->{'buz'} = 42;
+ bless $self, $type;
+ }
+
+ package Foo;
+
+ sub new {
+ my $type = shift;
+ my $self = {};
+ $self->{'Bar'} = Bar->new;
+ $self->{'biz'} = 11;
+ bless $self, $type;
+ }
+
+ package main;
+
+ $a = Foo->new;
+ print "buz = ", $a->{'Bar'}->{'buz'}, "\n";
+ print "biz = ", $a->{'biz'}, "\n";
+
+
+
+=head1 OVERRIDING SUPERCLASS METHODS
+
+The following example demonstrates how to override a superclass method and
+then call the overridden method. The B<SUPER> pseudo-class allows the
+programmer to call an overridden superclass method without actually knowing
+where that method is defined.
+
+ package Buz;
+ sub goo { print "here's the goo\n" }
+
+ package Bar; @ISA = qw( Buz );
+ sub google { print "google here\n" }
+
+ package Baz;
+ sub mumble { print "mumbling\n" }
+
+ package Foo;
+ @ISA = qw( Bar Baz );
+
+ sub new {
+ my $type = shift;
+ bless [], $type;
+ }
+ sub grr { print "grumble\n" }
+ sub goo {
+ my $self = shift;
+ $self->SUPER::goo();
+ }
+ sub mumble {
+ my $self = shift;
+ $self->SUPER::mumble();
+ }
+ sub google {
+ my $self = shift;
+ $self->SUPER::google();
+ }
+
+ package main;
+
+ $foo = Foo->new;
+ $foo->mumble;
+ $foo->grr;
+ $foo->goo;
+ $foo->google;
+
+
+=head1 USING RELATIONSHIP WITH SDBM
+
+This example demonstrates an interface for the SDBM class. This creates a
+"using" relationship between the SDBM class and the new class Mydbm.
+
+ package Mydbm;
+
+ require SDBM_File;
+ require Tie::Hash;
+ @ISA = qw( Tie::Hash );
+
+ sub TIEHASH {
+ my $type = shift;
+ my $ref = SDBM_File->new(@_);
+ bless {'dbm' => $ref}, $type;
+ }
+ sub FETCH {
+ my $self = shift;
+ my $ref = $self->{'dbm'};
+ $ref->FETCH(@_);
+ }
+ sub STORE {
+ my $self = shift;
+ if (defined $_[0]){
+ my $ref = $self->{'dbm'};
+ $ref->STORE(@_);
+ } else {
+ die "Cannot STORE an undefined key in Mydbm\n";
+ }
+ }
+
+ package main;
+ use Fcntl qw( O_RDWR O_CREAT );
+
+ tie %foo, "Mydbm", "Sdbm", O_RDWR|O_CREAT, 0640;
+ $foo{'bar'} = 123;
+ print "foo-bar = $foo{'bar'}\n";
+
+ tie %bar, "Mydbm", "Sdbm2", O_RDWR|O_CREAT, 0640;
+ $bar{'Cathy'} = 456;
+ print "bar-Cathy = $bar{'Cathy'}\n";
+
+=head1 THINKING OF CODE REUSE
+
+One strength of Object-Oriented languages is the ease with which old code
+can use new code. The following examples will demonstrate first how one can
+hinder code reuse and then how one can promote code reuse.
+
+This first example illustrates a class which uses a fully-qualified method
+call to access the "private" method BAZ(). The second example will show
+that it is impossible to override the BAZ() method.
+
+ package FOO;
+
+ sub new {
+ my $type = shift;
+ bless {}, $type;
+ }
+ sub bar {
+ my $self = shift;
+ $self->FOO::private::BAZ;
+ }
+
+ package FOO::private;
+
+ sub BAZ {
+ print "in BAZ\n";
+ }
+
+ package main;
+
+ $a = FOO->new;
+ $a->bar;
+
+Now we try to override the BAZ() method. We would like FOO::bar() to call
+GOOP::BAZ(), but this cannot happen because FOO::bar() explicitly calls
+FOO::private::BAZ().
+
+ package FOO;
+
+ sub new {
+ my $type = shift;
+ bless {}, $type;
+ }
+ sub bar {
+ my $self = shift;
+ $self->FOO::private::BAZ;
+ }
+
+ package FOO::private;
+
+ sub BAZ {
+ print "in BAZ\n";
+ }
+
+ package GOOP;
+ @ISA = qw( FOO );
+ sub new {
+ my $type = shift;
+ bless {}, $type;
+ }
+
+ sub BAZ {
+ print "in GOOP::BAZ\n";
+ }
+
+ package main;
+
+ $a = GOOP->new;
+ $a->bar;
+
+To create reusable code we must modify class FOO, flattening class
+FOO::private. The next example shows a reusable class FOO which allows the
+method GOOP::BAZ() to be used in place of FOO::BAZ().
+
+ package FOO;
+
+ sub new {
+ my $type = shift;
+ bless {}, $type;
+ }
+ sub bar {
+ my $self = shift;
+ $self->BAZ;
+ }
+
+ sub BAZ {
+ print "in BAZ\n";
+ }
+
+ package GOOP;
+ @ISA = qw( FOO );
+
+ sub new {
+ my $type = shift;
+ bless {}, $type;
+ }
+ sub BAZ {
+ print "in GOOP::BAZ\n";
+ }
+
+ package main;
+
+ $a = GOOP->new;
+ $a->bar;
+
+=head1 CLASS CONTEXT AND THE OBJECT
+
+Use the object to solve package and class context problems. Everything a
+method needs should be available via the object or should be passed as a
+parameter to the method.
+
+A class will sometimes have static or global data to be used by the
+methods. A subclass may want to override that data and replace it with new
+data. When this happens the superclass may not know how to find the new
+copy of the data.
+
+This problem can be solved by using the object to define the context of the
+method. Let the method look in the object for a reference to the data. The
+alternative is to force the method to go hunting for the data ("Is it in my
+class, or in a subclass? Which subclass?"), and this can be inconvenient
+and will lead to hackery. It is better just to let the object tell the
+method where that data is located.
+
+ package Bar;
+
+ %fizzle = ( 'Password' => 'XYZZY' );
+
+ sub new {
+ my $type = shift;
+ my $self = {};
+ $self->{'fizzle'} = \%fizzle;
+ bless $self, $type;
+ }
+
+ sub enter {
+ my $self = shift;
+
+ # Don't try to guess if we should use %Bar::fizzle
+ # or %Foo::fizzle. The object already knows which
+ # we should use, so just ask it.
+ #
+ my $fizzle = $self->{'fizzle'};
+
+ print "The word is ", $fizzle->{'Password'}, "\n";
+ }
+
+ package Foo;
+ @ISA = qw( Bar );
+
+ %fizzle = ( 'Password' => 'Rumple' );
+
+ sub new {
+ my $type = shift;
+ my $self = Bar->new;
+ $self->{'fizzle'} = \%fizzle;
+ bless $self, $type;
+ }
+
+ package main;
+
+ $a = Bar->new;
+ $b = Foo->new;
+ $a->enter;
+ $b->enter;
+
+=head1 INHERITING A CONSTRUCTOR
+
+An inheritable constructor should use the second form of bless() which allows
+blessing directly into a specified class. Notice in this example that the
+object will be a BAR not a FOO, even though the constructor is in class FOO.
+
+ package FOO;
+
+ sub new {
+ my $type = shift;
+ my $self = {};
+ bless $self, $type;
+ }
+
+ sub baz {
+ print "in FOO::baz()\n";
+ }
+
+ package BAR;
+ @ISA = qw(FOO);
+
+ sub baz {
+ print "in BAR::baz()\n";
+ }
+
+ package main;
+
+ $a = BAR->new;
+ $a->baz;
+
+=head1 DELEGATION
+
+Some classes, such as SDBM_File, cannot be effectively subclassed because
+they create foreign objects. Such a class can be extended with some sort of
+aggregation technique such as the "using" relationship mentioned earlier or
+by delegation.
+
+The following example demonstrates delegation using an AUTOLOAD() function to
+perform message-forwarding. This will allow the Mydbm object to behave
+exactly like an SDBM_File object. The Mydbm class could now extend the
+behavior by adding custom FETCH() and STORE() methods, if this is desired.
+
+ package Mydbm;
+
+ require SDBM_File;
+ require Tie::Hash;
+ @ISA = qw(Tie::Hash);
+
+ sub TIEHASH {
+ my $type = shift;
+ my $ref = SDBM_File->new(@_);
+ bless {'delegate' => $ref};
+ }
+
+ sub AUTOLOAD {
+ my $self = shift;
+
+ # The Perl interpreter places the name of the
+ # message in a variable called $AUTOLOAD.
+
+ # DESTROY messages should never be propagated.
+ return if $AUTOLOAD =~ /::DESTROY$/;
+
+ # Remove the package name.
+ $AUTOLOAD =~ s/^Mydbm:://;
+
+ # Pass the message to the delegate.
+ $self->{'delegate'}->$AUTOLOAD(@_);
+ }
+
+ package main;
+ use Fcntl qw( O_RDWR O_CREAT );
+
+ tie %foo, "Mydbm", "adbm", O_RDWR|O_CREAT, 0640;
+ $foo{'bar'} = 123;
+ print "foo-bar = $foo{'bar'}\n";
diff --git a/contrib/perl5/pod/perlcall.pod b/contrib/perl5/pod/perlcall.pod
new file mode 100644
index 000000000000..c239cfe3240d
--- /dev/null
+++ b/contrib/perl5/pod/perlcall.pod
@@ -0,0 +1,1959 @@
+=head1 NAME
+
+perlcall - Perl calling conventions from C
+
+=head1 DESCRIPTION
+
+The purpose of this document is to show you how to call Perl subroutines
+directly from C, i.e., how to write I<callbacks>.
+
+Apart from discussing the C interface provided by Perl for writing
+callbacks the document uses a series of examples to show how the
+interface actually works in practice. In addition some techniques for
+coding callbacks are covered.
+
+Examples where callbacks are necessary include
+
+=over 5
+
+=item * An Error Handler
+
+You have created an XSUB interface to an application's C API.
+
+A fairly common feature in applications is to allow you to define a C
+function that will be called whenever something nasty occurs. What we
+would like is to be able to specify a Perl subroutine that will be
+called instead.
+
+=item * An Event Driven Program
+
+The classic example of where callbacks are used is when writing an
+event driven program like for an X windows application. In this case
+you register functions to be called whenever specific events occur,
+e.g., a mouse button is pressed, the cursor moves into a window or a
+menu item is selected.
+
+=back
+
+Although the techniques described here are applicable when embedding
+Perl in a C program, this is not the primary goal of this document.
+There are other details that must be considered and are specific to
+embedding Perl. For details on embedding Perl in C refer to
+L<perlembed>.
+
+Before you launch yourself head first into the rest of this document,
+it would be a good idea to have read the following two documents -
+L<perlxs> and L<perlguts>.
+
+=head1 THE PERL_CALL FUNCTIONS
+
+Although this stuff is easier to explain using examples, you first need
+be aware of a few important definitions.
+
+Perl has a number of C functions that allow you to call Perl
+subroutines. They are
+
+ I32 perl_call_sv(SV* sv, I32 flags) ;
+ I32 perl_call_pv(char *subname, I32 flags) ;
+ I32 perl_call_method(char *methname, I32 flags) ;
+ I32 perl_call_argv(char *subname, I32 flags, register char **argv) ;
+
+The key function is I<perl_call_sv>. All the other functions are
+fairly simple wrappers which make it easier to call Perl subroutines in
+special cases. At the end of the day they will all call I<perl_call_sv>
+to invoke the Perl subroutine.
+
+All the I<perl_call_*> functions have a C<flags> parameter which is
+used to pass a bit mask of options to Perl. This bit mask operates
+identically for each of the functions. The settings available in the
+bit mask are discussed in L<FLAG VALUES>.
+
+Each of the functions will now be discussed in turn.
+
+=over 5
+
+=item B<perl_call_sv>
+
+I<perl_call_sv> takes two parameters, the first, C<sv>, is an SV*.
+This allows you to specify the Perl subroutine to be called either as a
+C string (which has first been converted to an SV) or a reference to a
+subroutine. The section, I<Using perl_call_sv>, shows how you can make
+use of I<perl_call_sv>.
+
+=item B<perl_call_pv>
+
+The function, I<perl_call_pv>, is similar to I<perl_call_sv> except it
+expects its first parameter to be a C char* which identifies the Perl
+subroutine you want to call, e.g., C<perl_call_pv("fred", 0)>. If the
+subroutine you want to call is in another package, just include the
+package name in the string, e.g., C<"pkg::fred">.
+
+=item B<perl_call_method>
+
+The function I<perl_call_method> is used to call a method from a Perl
+class. The parameter C<methname> corresponds to the name of the method
+to be called. Note that the class that the method belongs to is passed
+on the Perl stack rather than in the parameter list. This class can be
+either the name of the class (for a static method) or a reference to an
+object (for a virtual method). See L<perlobj> for more information on
+static and virtual methods and L<Using perl_call_method> for an example
+of using I<perl_call_method>.
+
+=item B<perl_call_argv>
+
+I<perl_call_argv> calls the Perl subroutine specified by the C string
+stored in the C<subname> parameter. It also takes the usual C<flags>
+parameter. The final parameter, C<argv>, consists of a NULL terminated
+list of C strings to be passed as parameters to the Perl subroutine.
+See I<Using perl_call_argv>.
+
+=back
+
+All the functions return an integer. This is a count of the number of
+items returned by the Perl subroutine. The actual items returned by the
+subroutine are stored on the Perl stack.
+
+As a general rule you should I<always> check the return value from
+these functions. Even if you are expecting only a particular number of
+values to be returned from the Perl subroutine, there is nothing to
+stop someone from doing something unexpected - don't say you haven't
+been warned.
+
+=head1 FLAG VALUES
+
+The C<flags> parameter in all the I<perl_call_*> functions is a bit mask
+which can consist of any combination of the symbols defined below,
+OR'ed together.
+
+
+=head2 G_VOID
+
+Calls the Perl subroutine in a void context.
+
+This flag has 2 effects:
+
+=over 5
+
+=item 1.
+
+It indicates to the subroutine being called that it is executing in
+a void context (if it executes I<wantarray> the result will be the
+undefined value).
+
+=item 2.
+
+It ensures that nothing is actually returned from the subroutine.
+
+=back
+
+The value returned by the I<perl_call_*> function indicates how many
+items have been returned by the Perl subroutine - in this case it will
+be 0.
+
+
+=head2 G_SCALAR
+
+Calls the Perl subroutine in a scalar context. This is the default
+context flag setting for all the I<perl_call_*> functions.
+
+This flag has 2 effects:
+
+=over 5
+
+=item 1.
+
+It indicates to the subroutine being called that it is executing in a
+scalar context (if it executes I<wantarray> the result will be false).
+
+=item 2.
+
+It ensures that only a scalar is actually returned from the subroutine.
+The subroutine can, of course, ignore the I<wantarray> and return a
+list anyway. If so, then only the last element of the list will be
+returned.
+
+=back
+
+The value returned by the I<perl_call_*> function indicates how many
+items have been returned by the Perl subroutine - in this case it will
+be either 0 or 1.
+
+If 0, then you have specified the G_DISCARD flag.
+
+If 1, then the item actually returned by the Perl subroutine will be
+stored on the Perl stack - the section I<Returning a Scalar> shows how
+to access this value on the stack. Remember that regardless of how
+many items the Perl subroutine returns, only the last one will be
+accessible from the stack - think of the case where only one value is
+returned as being a list with only one element. Any other items that
+were returned will not exist by the time control returns from the
+I<perl_call_*> function. The section I<Returning a list in a scalar
+context> shows an example of this behavior.
+
+
+=head2 G_ARRAY
+
+Calls the Perl subroutine in a list context.
+
+As with G_SCALAR, this flag has 2 effects:
+
+=over 5
+
+=item 1.
+
+It indicates to the subroutine being called that it is executing in an
+array context (if it executes I<wantarray> the result will be true).
+
+
+=item 2.
+
+It ensures that all items returned from the subroutine will be
+accessible when control returns from the I<perl_call_*> function.
+
+=back
+
+The value returned by the I<perl_call_*> function indicates how many
+items have been returned by the Perl subroutine.
+
+If 0, then you have specified the G_DISCARD flag.
+
+If not 0, then it will be a count of the number of items returned by
+the subroutine. These items will be stored on the Perl stack. The
+section I<Returning a list of values> gives an example of using the
+G_ARRAY flag and the mechanics of accessing the returned items from the
+Perl stack.
+
+=head2 G_DISCARD
+
+By default, the I<perl_call_*> functions place the items returned from
+by the Perl subroutine on the stack. If you are not interested in
+these items, then setting this flag will make Perl get rid of them
+automatically for you. Note that it is still possible to indicate a
+context to the Perl subroutine by using either G_SCALAR or G_ARRAY.
+
+If you do not set this flag then it is I<very> important that you make
+sure that any temporaries (i.e., parameters passed to the Perl
+subroutine and values returned from the subroutine) are disposed of
+yourself. The section I<Returning a Scalar> gives details of how to
+dispose of these temporaries explicitly and the section I<Using Perl to
+dispose of temporaries> discusses the specific circumstances where you
+can ignore the problem and let Perl deal with it for you.
+
+=head2 G_NOARGS
+
+Whenever a Perl subroutine is called using one of the I<perl_call_*>
+functions, it is assumed by default that parameters are to be passed to
+the subroutine. If you are not passing any parameters to the Perl
+subroutine, you can save a bit of time by setting this flag. It has
+the effect of not creating the C<@_> array for the Perl subroutine.
+
+Although the functionality provided by this flag may seem
+straightforward, it should be used only if there is a good reason to do
+so. The reason for being cautious is that even if you have specified
+the G_NOARGS flag, it is still possible for the Perl subroutine that
+has been called to think that you have passed it parameters.
+
+In fact, what can happen is that the Perl subroutine you have called
+can access the C<@_> array from a previous Perl subroutine. This will
+occur when the code that is executing the I<perl_call_*> function has
+itself been called from another Perl subroutine. The code below
+illustrates this
+
+ sub fred
+ { print "@_\n" }
+
+ sub joe
+ { &fred }
+
+ &joe(1,2,3) ;
+
+This will print
+
+ 1 2 3
+
+What has happened is that C<fred> accesses the C<@_> array which
+belongs to C<joe>.
+
+
+=head2 G_EVAL
+
+It is possible for the Perl subroutine you are calling to terminate
+abnormally, e.g., by calling I<die> explicitly or by not actually
+existing. By default, when either of these events occurs, the
+process will terminate immediately. If you want to trap this
+type of event, specify the G_EVAL flag. It will put an I<eval { }>
+around the subroutine call.
+
+Whenever control returns from the I<perl_call_*> function you need to
+check the C<$@> variable as you would in a normal Perl script.
+
+The value returned from the I<perl_call_*> function is dependent on
+what other flags have been specified and whether an error has
+occurred. Here are all the different cases that can occur:
+
+=over 5
+
+=item *
+
+If the I<perl_call_*> function returns normally, then the value
+returned is as specified in the previous sections.
+
+=item *
+
+If G_DISCARD is specified, the return value will always be 0.
+
+=item *
+
+If G_ARRAY is specified I<and> an error has occurred, the return value
+will always be 0.
+
+=item *
+
+If G_SCALAR is specified I<and> an error has occurred, the return value
+will be 1 and the value on the top of the stack will be I<undef>. This
+means that if you have already detected the error by checking C<$@> and
+you want the program to continue, you must remember to pop the I<undef>
+from the stack.
+
+=back
+
+See I<Using G_EVAL> for details on using G_EVAL.
+
+=head2 G_KEEPERR
+
+You may have noticed that using the G_EVAL flag described above will
+B<always> clear the C<$@> variable and set it to a string describing
+the error iff there was an error in the called code. This unqualified
+resetting of C<$@> can be problematic in the reliable identification of
+errors using the C<eval {}> mechanism, because the possibility exists
+that perl will call other code (end of block processing code, for
+example) between the time the error causes C<$@> to be set within
+C<eval {}>, and the subsequent statement which checks for the value of
+C<$@> gets executed in the user's script.
+
+This scenario will mostly be applicable to code that is meant to be
+called from within destructors, asynchronous callbacks, signal
+handlers, C<__DIE__> or C<__WARN__> hooks, and C<tie> functions. In
+such situations, you will not want to clear C<$@> at all, but simply to
+append any new errors to any existing value of C<$@>.
+
+The G_KEEPERR flag is meant to be used in conjunction with G_EVAL in
+I<perl_call_*> functions that are used to implement such code. This flag
+has no effect when G_EVAL is not used.
+
+When G_KEEPERR is used, any errors in the called code will be prefixed
+with the string "\t(in cleanup)", and appended to the current value
+of C<$@>.
+
+The G_KEEPERR flag was introduced in Perl version 5.002.
+
+See I<Using G_KEEPERR> for an example of a situation that warrants the
+use of this flag.
+
+=head2 Determining the Context
+
+As mentioned above, you can determine the context of the currently
+executing subroutine in Perl with I<wantarray>. The equivalent test
+can be made in C by using the C<GIMME_V> macro, which returns
+C<G_ARRAY> if you have been called in an array context, C<G_SCALAR> if
+in a scalar context, or C<G_VOID> if in a void context (i.e. the
+return value will not be used). An older version of this macro is
+called C<GIMME>; in a void context it returns C<G_SCALAR> instead of
+C<G_VOID>. An example of using the C<GIMME_V> macro is shown in
+section I<Using GIMME_V>.
+
+=head1 KNOWN PROBLEMS
+
+This section outlines all known problems that exist in the
+I<perl_call_*> functions.
+
+=over 5
+
+=item 1.
+
+If you are intending to make use of both the G_EVAL and G_SCALAR flags
+in your code, use a version of Perl greater than 5.000. There is a bug
+in version 5.000 of Perl which means that the combination of these two
+flags will not work as described in the section I<FLAG VALUES>.
+
+Specifically, if the two flags are used when calling a subroutine and
+that subroutine does not call I<die>, the value returned by
+I<perl_call_*> will be wrong.
+
+
+=item 2.
+
+In Perl 5.000 and 5.001 there is a problem with using I<perl_call_*> if
+the Perl sub you are calling attempts to trap a I<die>.
+
+The symptom of this problem is that the called Perl sub will continue
+to completion, but whenever it attempts to pass control back to the
+XSUB, the program will immediately terminate.
+
+For example, say you want to call this Perl sub
+
+ sub fred
+ {
+ eval { die "Fatal Error" ; }
+ print "Trapped error: $@\n"
+ if $@ ;
+ }
+
+via this XSUB
+
+ void
+ Call_fred()
+ CODE:
+ PUSHMARK(SP) ;
+ perl_call_pv("fred", G_DISCARD|G_NOARGS) ;
+ fprintf(stderr, "back in Call_fred\n") ;
+
+When C<Call_fred> is executed it will print
+
+ Trapped error: Fatal Error
+
+As control never returns to C<Call_fred>, the C<"back in Call_fred">
+string will not get printed.
+
+To work around this problem, you can either upgrade to Perl 5.002 or
+higher, or use the G_EVAL flag with I<perl_call_*> as shown below
+
+ void
+ Call_fred()
+ CODE:
+ PUSHMARK(SP) ;
+ perl_call_pv("fred", G_EVAL|G_DISCARD|G_NOARGS) ;
+ fprintf(stderr, "back in Call_fred\n") ;
+
+=back
+
+
+
+=head1 EXAMPLES
+
+Enough of the definition talk, let's have a few examples.
+
+Perl provides many macros to assist in accessing the Perl stack.
+Wherever possible, these macros should always be used when interfacing
+to Perl internals. We hope this should make the code less vulnerable
+to any changes made to Perl in the future.
+
+Another point worth noting is that in the first series of examples I
+have made use of only the I<perl_call_pv> function. This has been done
+to keep the code simpler and ease you into the topic. Wherever
+possible, if the choice is between using I<perl_call_pv> and
+I<perl_call_sv>, you should always try to use I<perl_call_sv>. See
+I<Using perl_call_sv> for details.
+
+=head2 No Parameters, Nothing returned
+
+This first trivial example will call a Perl subroutine, I<PrintUID>, to
+print out the UID of the process.
+
+ sub PrintUID
+ {
+ print "UID is $<\n" ;
+ }
+
+and here is a C function to call it
+
+ static void
+ call_PrintUID()
+ {
+ dSP ;
+
+ PUSHMARK(SP) ;
+ perl_call_pv("PrintUID", G_DISCARD|G_NOARGS) ;
+ }
+
+Simple, eh.
+
+A few points to note about this example.
+
+=over 5
+
+=item 1.
+
+Ignore C<dSP> and C<PUSHMARK(SP)> for now. They will be discussed in
+the next example.
+
+=item 2.
+
+We aren't passing any parameters to I<PrintUID> so G_NOARGS can be
+specified.
+
+=item 3.
+
+We aren't interested in anything returned from I<PrintUID>, so
+G_DISCARD is specified. Even if I<PrintUID> was changed to
+return some value(s), having specified G_DISCARD will mean that they
+will be wiped by the time control returns from I<perl_call_pv>.
+
+=item 4.
+
+As I<perl_call_pv> is being used, the Perl subroutine is specified as a
+C string. In this case the subroutine name has been 'hard-wired' into the
+code.
+
+=item 5.
+
+Because we specified G_DISCARD, it is not necessary to check the value
+returned from I<perl_call_pv>. It will always be 0.
+
+=back
+
+=head2 Passing Parameters
+
+Now let's make a slightly more complex example. This time we want to
+call a Perl subroutine, C<LeftString>, which will take 2 parameters - a
+string (C<$s>) and an integer (C<$n>). The subroutine will simply
+print the first C<$n> characters of the string.
+
+So the Perl subroutine would look like this
+
+ sub LeftString
+ {
+ my($s, $n) = @_ ;
+ print substr($s, 0, $n), "\n" ;
+ }
+
+The C function required to call I<LeftString> would look like this.
+
+ static void
+ call_LeftString(a, b)
+ char * a ;
+ int b ;
+ {
+ dSP ;
+
+ ENTER ;
+ SAVETMPS ;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sv_2mortal(newSVpv(a, 0)));
+ XPUSHs(sv_2mortal(newSViv(b)));
+ PUTBACK ;
+
+ perl_call_pv("LeftString", G_DISCARD);
+
+ FREETMPS ;
+ LEAVE ;
+ }
+
+Here are a few notes on the C function I<call_LeftString>.
+
+=over 5
+
+=item 1.
+
+Parameters are passed to the Perl subroutine using the Perl stack.
+This is the purpose of the code beginning with the line C<dSP> and
+ending with the line C<PUTBACK>. The C<dSP> declares a local copy
+of the stack pointer. This local copy should B<always> be accessed
+as C<SP>.
+
+=item 2.
+
+If you are going to put something onto the Perl stack, you need to know
+where to put it. This is the purpose of the macro C<dSP> - it declares
+and initializes a I<local> copy of the Perl stack pointer.
+
+All the other macros which will be used in this example require you to
+have used this macro.
+
+The exception to this rule is if you are calling a Perl subroutine
+directly from an XSUB function. In this case it is not necessary to
+use the C<dSP> macro explicitly - it will be declared for you
+automatically.
+
+=item 3.
+
+Any parameters to be pushed onto the stack should be bracketed by the
+C<PUSHMARK> and C<PUTBACK> macros. The purpose of these two macros, in
+this context, is to count the number of parameters you are
+pushing automatically. Then whenever Perl is creating the C<@_> array for the
+subroutine, it knows how big to make it.
+
+The C<PUSHMARK> macro tells Perl to make a mental note of the current
+stack pointer. Even if you aren't passing any parameters (like the
+example shown in the section I<No Parameters, Nothing returned>) you
+must still call the C<PUSHMARK> macro before you can call any of the
+I<perl_call_*> functions - Perl still needs to know that there are no
+parameters.
+
+The C<PUTBACK> macro sets the global copy of the stack pointer to be
+the same as our local copy. If we didn't do this I<perl_call_pv>
+wouldn't know where the two parameters we pushed were - remember that
+up to now all the stack pointer manipulation we have done is with our
+local copy, I<not> the global copy.
+
+=item 4.
+
+The only flag specified this time is G_DISCARD. Because we are passing 2
+parameters to the Perl subroutine this time, we have not specified
+G_NOARGS.
+
+=item 5.
+
+Next, we come to XPUSHs. This is where the parameters actually get
+pushed onto the stack. In this case we are pushing a string and an
+integer.
+
+See L<perlguts/"XSUBs and the Argument Stack"> for details
+on how the XPUSH macros work.
+
+=item 6.
+
+Because we created temporary values (by means of sv_2mortal() calls)
+we will have to tidy up the Perl stack and dispose of mortal SVs.
+
+This is the purpose of
+
+ ENTER ;
+ SAVETMPS ;
+
+at the start of the function, and
+
+ FREETMPS ;
+ LEAVE ;
+
+at the end. The C<ENTER>/C<SAVETMPS> pair creates a boundary for any
+temporaries we create. This means that the temporaries we get rid of
+will be limited to those which were created after these calls.
+
+The C<FREETMPS>/C<LEAVE> pair will get rid of any values returned by
+the Perl subroutine (see next example), plus it will also dump the
+mortal SVs we have created. Having C<ENTER>/C<SAVETMPS> at the
+beginning of the code makes sure that no other mortals are destroyed.
+
+Think of these macros as working a bit like using C<{> and C<}> in Perl
+to limit the scope of local variables.
+
+See the section I<Using Perl to dispose of temporaries> for details of
+an alternative to using these macros.
+
+=item 7.
+
+Finally, I<LeftString> can now be called via the I<perl_call_pv>
+function.
+
+=back
+
+=head2 Returning a Scalar
+
+Now for an example of dealing with the items returned from a Perl
+subroutine.
+
+Here is a Perl subroutine, I<Adder>, that takes 2 integer parameters
+and simply returns their sum.
+
+ sub Adder
+ {
+ my($a, $b) = @_ ;
+ $a + $b ;
+ }
+
+Because we are now concerned with the return value from I<Adder>, the C
+function required to call it is now a bit more complex.
+
+ static void
+ call_Adder(a, b)
+ int a ;
+ int b ;
+ {
+ dSP ;
+ int count ;
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sv_2mortal(newSViv(a)));
+ XPUSHs(sv_2mortal(newSViv(b)));
+ PUTBACK ;
+
+ count = perl_call_pv("Adder", G_SCALAR);
+
+ SPAGAIN ;
+
+ if (count != 1)
+ croak("Big trouble\n") ;
+
+ printf ("The sum of %d and %d is %d\n", a, b, POPi) ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ }
+
+Points to note this time are
+
+=over 5
+
+=item 1.
+
+The only flag specified this time was G_SCALAR. That means the C<@_>
+array will be created and that the value returned by I<Adder> will
+still exist after the call to I<perl_call_pv>.
+
+=item 2.
+
+The purpose of the macro C<SPAGAIN> is to refresh the local copy of the
+stack pointer. This is necessary because it is possible that the memory
+allocated to the Perl stack has been reallocated whilst in the
+I<perl_call_pv> call.
+
+If you are making use of the Perl stack pointer in your code you must
+always refresh the local copy using SPAGAIN whenever you make use
+of the I<perl_call_*> functions or any other Perl internal function.
+
+=item 3.
+
+Although only a single value was expected to be returned from I<Adder>,
+it is still good practice to check the return code from I<perl_call_pv>
+anyway.
+
+Expecting a single value is not quite the same as knowing that there
+will be one. If someone modified I<Adder> to return a list and we
+didn't check for that possibility and take appropriate action the Perl
+stack would end up in an inconsistent state. That is something you
+I<really> don't want to happen ever.
+
+=item 4.
+
+The C<POPi> macro is used here to pop the return value from the stack.
+In this case we wanted an integer, so C<POPi> was used.
+
+
+Here is the complete list of POP macros available, along with the types
+they return.
+
+ POPs SV
+ POPp pointer
+ POPn double
+ POPi integer
+ POPl long
+
+=item 5.
+
+The final C<PUTBACK> is used to leave the Perl stack in a consistent
+state before exiting the function. This is necessary because when we
+popped the return value from the stack with C<POPi> it updated only our
+local copy of the stack pointer. Remember, C<PUTBACK> sets the global
+stack pointer to be the same as our local copy.
+
+=back
+
+
+=head2 Returning a list of values
+
+Now, let's extend the previous example to return both the sum of the
+parameters and the difference.
+
+Here is the Perl subroutine
+
+ sub AddSubtract
+ {
+ my($a, $b) = @_ ;
+ ($a+$b, $a-$b) ;
+ }
+
+and this is the C function
+
+ static void
+ call_AddSubtract(a, b)
+ int a ;
+ int b ;
+ {
+ dSP ;
+ int count ;
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sv_2mortal(newSViv(a)));
+ XPUSHs(sv_2mortal(newSViv(b)));
+ PUTBACK ;
+
+ count = perl_call_pv("AddSubtract", G_ARRAY);
+
+ SPAGAIN ;
+
+ if (count != 2)
+ croak("Big trouble\n") ;
+
+ printf ("%d - %d = %d\n", a, b, POPi) ;
+ printf ("%d + %d = %d\n", a, b, POPi) ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ }
+
+If I<call_AddSubtract> is called like this
+
+ call_AddSubtract(7, 4) ;
+
+then here is the output
+
+ 7 - 4 = 3
+ 7 + 4 = 11
+
+Notes
+
+=over 5
+
+=item 1.
+
+We wanted array context, so G_ARRAY was used.
+
+=item 2.
+
+Not surprisingly C<POPi> is used twice this time because we were
+retrieving 2 values from the stack. The important thing to note is that
+when using the C<POP*> macros they come off the stack in I<reverse>
+order.
+
+=back
+
+=head2 Returning a list in a scalar context
+
+Say the Perl subroutine in the previous section was called in a scalar
+context, like this
+
+ static void
+ call_AddSubScalar(a, b)
+ int a ;
+ int b ;
+ {
+ dSP ;
+ int count ;
+ int i ;
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sv_2mortal(newSViv(a)));
+ XPUSHs(sv_2mortal(newSViv(b)));
+ PUTBACK ;
+
+ count = perl_call_pv("AddSubtract", G_SCALAR);
+
+ SPAGAIN ;
+
+ printf ("Items Returned = %d\n", count) ;
+
+ for (i = 1 ; i <= count ; ++i)
+ printf ("Value %d = %d\n", i, POPi) ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ }
+
+The other modification made is that I<call_AddSubScalar> will print the
+number of items returned from the Perl subroutine and their value (for
+simplicity it assumes that they are integer). So if
+I<call_AddSubScalar> is called
+
+ call_AddSubScalar(7, 4) ;
+
+then the output will be
+
+ Items Returned = 1
+ Value 1 = 3
+
+In this case the main point to note is that only the last item in the
+list is returned from the subroutine, I<AddSubtract> actually made it back to
+I<call_AddSubScalar>.
+
+
+=head2 Returning Data from Perl via the parameter list
+
+It is also possible to return values directly via the parameter list -
+whether it is actually desirable to do it is another matter entirely.
+
+The Perl subroutine, I<Inc>, below takes 2 parameters and increments
+each directly.
+
+ sub Inc
+ {
+ ++ $_[0] ;
+ ++ $_[1] ;
+ }
+
+and here is a C function to call it.
+
+ static void
+ call_Inc(a, b)
+ int a ;
+ int b ;
+ {
+ dSP ;
+ int count ;
+ SV * sva ;
+ SV * svb ;
+
+ ENTER ;
+ SAVETMPS;
+
+ sva = sv_2mortal(newSViv(a)) ;
+ svb = sv_2mortal(newSViv(b)) ;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sva);
+ XPUSHs(svb);
+ PUTBACK ;
+
+ count = perl_call_pv("Inc", G_DISCARD);
+
+ if (count != 0)
+ croak ("call_Inc: expected 0 values from 'Inc', got %d\n",
+ count) ;
+
+ printf ("%d + 1 = %d\n", a, SvIV(sva)) ;
+ printf ("%d + 1 = %d\n", b, SvIV(svb)) ;
+
+ FREETMPS ;
+ LEAVE ;
+ }
+
+To be able to access the two parameters that were pushed onto the stack
+after they return from I<perl_call_pv> it is necessary to make a note
+of their addresses - thus the two variables C<sva> and C<svb>.
+
+The reason this is necessary is that the area of the Perl stack which
+held them will very likely have been overwritten by something else by
+the time control returns from I<perl_call_pv>.
+
+
+
+
+=head2 Using G_EVAL
+
+Now an example using G_EVAL. Below is a Perl subroutine which computes
+the difference of its 2 parameters. If this would result in a negative
+result, the subroutine calls I<die>.
+
+ sub Subtract
+ {
+ my ($a, $b) = @_ ;
+
+ die "death can be fatal\n" if $a < $b ;
+
+ $a - $b ;
+ }
+
+and some C to call it
+
+ static void
+ call_Subtract(a, b)
+ int a ;
+ int b ;
+ {
+ dSP ;
+ int count ;
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sv_2mortal(newSViv(a)));
+ XPUSHs(sv_2mortal(newSViv(b)));
+ PUTBACK ;
+
+ count = perl_call_pv("Subtract", G_EVAL|G_SCALAR);
+
+ SPAGAIN ;
+
+ /* Check the eval first */
+ if (SvTRUE(ERRSV))
+ {
+ printf ("Uh oh - %s\n", SvPV(ERRSV, PL_na)) ;
+ POPs ;
+ }
+ else
+ {
+ if (count != 1)
+ croak("call_Subtract: wanted 1 value from 'Subtract', got %d\n",
+ count) ;
+
+ printf ("%d - %d = %d\n", a, b, POPi) ;
+ }
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ }
+
+If I<call_Subtract> is called thus
+
+ call_Subtract(4, 5)
+
+the following will be printed
+
+ Uh oh - death can be fatal
+
+Notes
+
+=over 5
+
+=item 1.
+
+We want to be able to catch the I<die> so we have used the G_EVAL
+flag. Not specifying this flag would mean that the program would
+terminate immediately at the I<die> statement in the subroutine
+I<Subtract>.
+
+=item 2.
+
+The code
+
+ if (SvTRUE(ERRSV))
+ {
+ printf ("Uh oh - %s\n", SvPV(ERRSV, PL_na)) ;
+ POPs ;
+ }
+
+is the direct equivalent of this bit of Perl
+
+ print "Uh oh - $@\n" if $@ ;
+
+C<PL_errgv> is a perl global of type C<GV *> that points to the
+symbol table entry containing the error. C<ERRSV> therefore
+refers to the C equivalent of C<$@>.
+
+=item 3.
+
+Note that the stack is popped using C<POPs> in the block where
+C<SvTRUE(ERRSV)> is true. This is necessary because whenever a
+I<perl_call_*> function invoked with G_EVAL|G_SCALAR returns an error,
+the top of the stack holds the value I<undef>. Because we want the
+program to continue after detecting this error, it is essential that
+the stack is tidied up by removing the I<undef>.
+
+=back
+
+
+=head2 Using G_KEEPERR
+
+Consider this rather facetious example, where we have used an XS
+version of the call_Subtract example above inside a destructor:
+
+ package Foo;
+ sub new { bless {}, $_[0] }
+ sub Subtract {
+ my($a,$b) = @_;
+ die "death can be fatal" if $a < $b ;
+ $a - $b;
+ }
+ sub DESTROY { call_Subtract(5, 4); }
+ sub foo { die "foo dies"; }
+
+ package main;
+ eval { Foo->new->foo };
+ print "Saw: $@" if $@; # should be, but isn't
+
+This example will fail to recognize that an error occurred inside the
+C<eval {}>. Here's why: the call_Subtract code got executed while perl
+was cleaning up temporaries when exiting the eval block, and because
+call_Subtract is implemented with I<perl_call_pv> using the G_EVAL
+flag, it promptly reset C<$@>. This results in the failure of the
+outermost test for C<$@>, and thereby the failure of the error trap.
+
+Appending the G_KEEPERR flag, so that the I<perl_call_pv> call in
+call_Subtract reads:
+
+ count = perl_call_pv("Subtract", G_EVAL|G_SCALAR|G_KEEPERR);
+
+will preserve the error and restore reliable error handling.
+
+=head2 Using perl_call_sv
+
+In all the previous examples I have 'hard-wired' the name of the Perl
+subroutine to be called from C. Most of the time though, it is more
+convenient to be able to specify the name of the Perl subroutine from
+within the Perl script.
+
+Consider the Perl code below
+
+ sub fred
+ {
+ print "Hello there\n" ;
+ }
+
+ CallSubPV("fred") ;
+
+Here is a snippet of XSUB which defines I<CallSubPV>.
+
+ void
+ CallSubPV(name)
+ char * name
+ CODE:
+ PUSHMARK(SP) ;
+ perl_call_pv(name, G_DISCARD|G_NOARGS) ;
+
+That is fine as far as it goes. The thing is, the Perl subroutine
+can be specified as only a string. For Perl 4 this was adequate,
+but Perl 5 allows references to subroutines and anonymous subroutines.
+This is where I<perl_call_sv> is useful.
+
+The code below for I<CallSubSV> is identical to I<CallSubPV> except
+that the C<name> parameter is now defined as an SV* and we use
+I<perl_call_sv> instead of I<perl_call_pv>.
+
+ void
+ CallSubSV(name)
+ SV * name
+ CODE:
+ PUSHMARK(SP) ;
+ perl_call_sv(name, G_DISCARD|G_NOARGS) ;
+
+Because we are using an SV to call I<fred> the following can all be used
+
+ CallSubSV("fred") ;
+ CallSubSV(\&fred) ;
+ $ref = \&fred ;
+ CallSubSV($ref) ;
+ CallSubSV( sub { print "Hello there\n" } ) ;
+
+As you can see, I<perl_call_sv> gives you much greater flexibility in
+how you can specify the Perl subroutine.
+
+You should note that if it is necessary to store the SV (C<name> in the
+example above) which corresponds to the Perl subroutine so that it can
+be used later in the program, it not enough just to store a copy of the
+pointer to the SV. Say the code above had been like this
+
+ static SV * rememberSub ;
+
+ void
+ SaveSub1(name)
+ SV * name
+ CODE:
+ rememberSub = name ;
+
+ void
+ CallSavedSub1()
+ CODE:
+ PUSHMARK(SP) ;
+ perl_call_sv(rememberSub, G_DISCARD|G_NOARGS) ;
+
+The reason this is wrong is that by the time you come to use the
+pointer C<rememberSub> in C<CallSavedSub1>, it may or may not still refer
+to the Perl subroutine that was recorded in C<SaveSub1>. This is
+particularly true for these cases
+
+ SaveSub1(\&fred) ;
+ CallSavedSub1() ;
+
+ SaveSub1( sub { print "Hello there\n" } ) ;
+ CallSavedSub1() ;
+
+By the time each of the C<SaveSub1> statements above have been executed,
+the SV*s which corresponded to the parameters will no longer exist.
+Expect an error message from Perl of the form
+
+ Can't use an undefined value as a subroutine reference at ...
+
+for each of the C<CallSavedSub1> lines.
+
+Similarly, with this code
+
+ $ref = \&fred ;
+ SaveSub1($ref) ;
+ $ref = 47 ;
+ CallSavedSub1() ;
+
+you can expect one of these messages (which you actually get is dependent on
+the version of Perl you are using)
+
+ Not a CODE reference at ...
+ Undefined subroutine &main::47 called ...
+
+The variable C<$ref> may have referred to the subroutine C<fred>
+whenever the call to C<SaveSub1> was made but by the time
+C<CallSavedSub1> gets called it now holds the number C<47>. Because we
+saved only a pointer to the original SV in C<SaveSub1>, any changes to
+C<$ref> will be tracked by the pointer C<rememberSub>. This means that
+whenever C<CallSavedSub1> gets called, it will attempt to execute the
+code which is referenced by the SV* C<rememberSub>. In this case
+though, it now refers to the integer C<47>, so expect Perl to complain
+loudly.
+
+A similar but more subtle problem is illustrated with this code
+
+ $ref = \&fred ;
+ SaveSub1($ref) ;
+ $ref = \&joe ;
+ CallSavedSub1() ;
+
+This time whenever C<CallSavedSub1> get called it will execute the Perl
+subroutine C<joe> (assuming it exists) rather than C<fred> as was
+originally requested in the call to C<SaveSub1>.
+
+To get around these problems it is necessary to take a full copy of the
+SV. The code below shows C<SaveSub2> modified to do that
+
+ static SV * keepSub = (SV*)NULL ;
+
+ void
+ SaveSub2(name)
+ SV * name
+ CODE:
+ /* Take a copy of the callback */
+ if (keepSub == (SV*)NULL)
+ /* First time, so create a new SV */
+ keepSub = newSVsv(name) ;
+ else
+ /* Been here before, so overwrite */
+ SvSetSV(keepSub, name) ;
+
+ void
+ CallSavedSub2()
+ CODE:
+ PUSHMARK(SP) ;
+ perl_call_sv(keepSub, G_DISCARD|G_NOARGS) ;
+
+To avoid creating a new SV every time C<SaveSub2> is called,
+the function first checks to see if it has been called before. If not,
+then space for a new SV is allocated and the reference to the Perl
+subroutine, C<name> is copied to the variable C<keepSub> in one
+operation using C<newSVsv>. Thereafter, whenever C<SaveSub2> is called
+the existing SV, C<keepSub>, is overwritten with the new value using
+C<SvSetSV>.
+
+=head2 Using perl_call_argv
+
+Here is a Perl subroutine which prints whatever parameters are passed
+to it.
+
+ sub PrintList
+ {
+ my(@list) = @_ ;
+
+ foreach (@list) { print "$_\n" }
+ }
+
+and here is an example of I<perl_call_argv> which will call
+I<PrintList>.
+
+ static char * words[] = {"alpha", "beta", "gamma", "delta", NULL} ;
+
+ static void
+ call_PrintList()
+ {
+ dSP ;
+
+ perl_call_argv("PrintList", G_DISCARD, words) ;
+ }
+
+Note that it is not necessary to call C<PUSHMARK> in this instance.
+This is because I<perl_call_argv> will do it for you.
+
+=head2 Using perl_call_method
+
+Consider the following Perl code
+
+ {
+ package Mine ;
+
+ sub new
+ {
+ my($type) = shift ;
+ bless [@_]
+ }
+
+ sub Display
+ {
+ my ($self, $index) = @_ ;
+ print "$index: $$self[$index]\n" ;
+ }
+
+ sub PrintID
+ {
+ my($class) = @_ ;
+ print "This is Class $class version 1.0\n" ;
+ }
+ }
+
+It implements just a very simple class to manage an array. Apart from
+the constructor, C<new>, it declares methods, one static and one
+virtual. The static method, C<PrintID>, prints out simply the class
+name and a version number. The virtual method, C<Display>, prints out a
+single element of the array. Here is an all Perl example of using it.
+
+ $a = new Mine ('red', 'green', 'blue') ;
+ $a->Display(1) ;
+ PrintID Mine;
+
+will print
+
+ 1: green
+ This is Class Mine version 1.0
+
+Calling a Perl method from C is fairly straightforward. The following
+things are required
+
+=over 5
+
+=item *
+
+a reference to the object for a virtual method or the name of the class
+for a static method.
+
+=item *
+
+the name of the method.
+
+=item *
+
+any other parameters specific to the method.
+
+=back
+
+Here is a simple XSUB which illustrates the mechanics of calling both
+the C<PrintID> and C<Display> methods from C.
+
+ void
+ call_Method(ref, method, index)
+ SV * ref
+ char * method
+ int index
+ CODE:
+ PUSHMARK(SP);
+ XPUSHs(ref);
+ XPUSHs(sv_2mortal(newSViv(index))) ;
+ PUTBACK;
+
+ perl_call_method(method, G_DISCARD) ;
+
+ void
+ call_PrintID(class, method)
+ char * class
+ char * method
+ CODE:
+ PUSHMARK(SP);
+ XPUSHs(sv_2mortal(newSVpv(class, 0))) ;
+ PUTBACK;
+
+ perl_call_method(method, G_DISCARD) ;
+
+
+So the methods C<PrintID> and C<Display> can be invoked like this
+
+ $a = new Mine ('red', 'green', 'blue') ;
+ call_Method($a, 'Display', 1) ;
+ call_PrintID('Mine', 'PrintID') ;
+
+The only thing to note is that in both the static and virtual methods,
+the method name is not passed via the stack - it is used as the first
+parameter to I<perl_call_method>.
+
+=head2 Using GIMME_V
+
+Here is a trivial XSUB which prints the context in which it is
+currently executing.
+
+ void
+ PrintContext()
+ CODE:
+ I32 gimme = GIMME_V;
+ if (gimme == G_VOID)
+ printf ("Context is Void\n") ;
+ else if (gimme == G_SCALAR)
+ printf ("Context is Scalar\n") ;
+ else
+ printf ("Context is Array\n") ;
+
+and here is some Perl to test it
+
+ PrintContext ;
+ $a = PrintContext ;
+ @a = PrintContext ;
+
+The output from that will be
+
+ Context is Void
+ Context is Scalar
+ Context is Array
+
+=head2 Using Perl to dispose of temporaries
+
+In the examples given to date, any temporaries created in the callback
+(i.e., parameters passed on the stack to the I<perl_call_*> function or
+values returned via the stack) have been freed by one of these methods
+
+=over 5
+
+=item *
+
+specifying the G_DISCARD flag with I<perl_call_*>.
+
+=item *
+
+explicitly disposed of using the C<ENTER>/C<SAVETMPS> -
+C<FREETMPS>/C<LEAVE> pairing.
+
+=back
+
+There is another method which can be used, namely letting Perl do it
+for you automatically whenever it regains control after the callback
+has terminated. This is done by simply not using the
+
+ ENTER ;
+ SAVETMPS ;
+ ...
+ FREETMPS ;
+ LEAVE ;
+
+sequence in the callback (and not, of course, specifying the G_DISCARD
+flag).
+
+If you are going to use this method you have to be aware of a possible
+memory leak which can arise under very specific circumstances. To
+explain these circumstances you need to know a bit about the flow of
+control between Perl and the callback routine.
+
+The examples given at the start of the document (an error handler and
+an event driven program) are typical of the two main sorts of flow
+control that you are likely to encounter with callbacks. There is a
+very important distinction between them, so pay attention.
+
+In the first example, an error handler, the flow of control could be as
+follows. You have created an interface to an external library.
+Control can reach the external library like this
+
+ perl --> XSUB --> external library
+
+Whilst control is in the library, an error condition occurs. You have
+previously set up a Perl callback to handle this situation, so it will
+get executed. Once the callback has finished, control will drop back to
+Perl again. Here is what the flow of control will be like in that
+situation
+
+ perl --> XSUB --> external library
+ ...
+ error occurs
+ ...
+ external library --> perl_call --> perl
+ |
+ perl <-- XSUB <-- external library <-- perl_call <----+
+
+After processing of the error using I<perl_call_*> is completed,
+control reverts back to Perl more or less immediately.
+
+In the diagram, the further right you go the more deeply nested the
+scope is. It is only when control is back with perl on the extreme
+left of the diagram that you will have dropped back to the enclosing
+scope and any temporaries you have left hanging around will be freed.
+
+In the second example, an event driven program, the flow of control
+will be more like this
+
+ perl --> XSUB --> event handler
+ ...
+ event handler --> perl_call --> perl
+ |
+ event handler <-- perl_call <----+
+ ...
+ event handler --> perl_call --> perl
+ |
+ event handler <-- perl_call <----+
+ ...
+ event handler --> perl_call --> perl
+ |
+ event handler <-- perl_call <----+
+
+In this case the flow of control can consist of only the repeated
+sequence
+
+ event handler --> perl_call --> perl
+
+for practically the complete duration of the program. This means that
+control may I<never> drop back to the surrounding scope in Perl at the
+extreme left.
+
+So what is the big problem? Well, if you are expecting Perl to tidy up
+those temporaries for you, you might be in for a long wait. For Perl
+to dispose of your temporaries, control must drop back to the
+enclosing scope at some stage. In the event driven scenario that may
+never happen. This means that as time goes on, your program will
+create more and more temporaries, none of which will ever be freed. As
+each of these temporaries consumes some memory your program will
+eventually consume all the available memory in your system - kapow!
+
+So here is the bottom line - if you are sure that control will revert
+back to the enclosing Perl scope fairly quickly after the end of your
+callback, then it isn't absolutely necessary to dispose explicitly of
+any temporaries you may have created. Mind you, if you are at all
+uncertain about what to do, it doesn't do any harm to tidy up anyway.
+
+
+=head2 Strategies for storing Callback Context Information
+
+
+Potentially one of the trickiest problems to overcome when designing a
+callback interface can be figuring out how to store the mapping between
+the C callback function and the Perl equivalent.
+
+To help understand why this can be a real problem first consider how a
+callback is set up in an all C environment. Typically a C API will
+provide a function to register a callback. This will expect a pointer
+to a function as one of its parameters. Below is a call to a
+hypothetical function C<register_fatal> which registers the C function
+to get called when a fatal error occurs.
+
+ register_fatal(cb1) ;
+
+The single parameter C<cb1> is a pointer to a function, so you must
+have defined C<cb1> in your code, say something like this
+
+ static void
+ cb1()
+ {
+ printf ("Fatal Error\n") ;
+ exit(1) ;
+ }
+
+Now change that to call a Perl subroutine instead
+
+ static SV * callback = (SV*)NULL;
+
+ static void
+ cb1()
+ {
+ dSP ;
+
+ PUSHMARK(SP) ;
+
+ /* Call the Perl sub to process the callback */
+ perl_call_sv(callback, G_DISCARD) ;
+ }
+
+
+ void
+ register_fatal(fn)
+ SV * fn
+ CODE:
+ /* Remember the Perl sub */
+ if (callback == (SV*)NULL)
+ callback = newSVsv(fn) ;
+ else
+ SvSetSV(callback, fn) ;
+
+ /* register the callback with the external library */
+ register_fatal(cb1) ;
+
+where the Perl equivalent of C<register_fatal> and the callback it
+registers, C<pcb1>, might look like this
+
+ # Register the sub pcb1
+ register_fatal(\&pcb1) ;
+
+ sub pcb1
+ {
+ die "I'm dying...\n" ;
+ }
+
+The mapping between the C callback and the Perl equivalent is stored in
+the global variable C<callback>.
+
+This will be adequate if you ever need to have only one callback
+registered at any time. An example could be an error handler like the
+code sketched out above. Remember though, repeated calls to
+C<register_fatal> will replace the previously registered callback
+function with the new one.
+
+Say for example you want to interface to a library which allows asynchronous
+file i/o. In this case you may be able to register a callback whenever
+a read operation has completed. To be of any use we want to be able to
+call separate Perl subroutines for each file that is opened. As it
+stands, the error handler example above would not be adequate as it
+allows only a single callback to be defined at any time. What we
+require is a means of storing the mapping between the opened file and
+the Perl subroutine we want to be called for that file.
+
+Say the i/o library has a function C<asynch_read> which associates a C
+function C<ProcessRead> with a file handle C<fh> - this assumes that it
+has also provided some routine to open the file and so obtain the file
+handle.
+
+ asynch_read(fh, ProcessRead)
+
+This may expect the C I<ProcessRead> function of this form
+
+ void
+ ProcessRead(fh, buffer)
+ int fh ;
+ char * buffer ;
+ {
+ ...
+ }
+
+To provide a Perl interface to this library we need to be able to map
+between the C<fh> parameter and the Perl subroutine we want called. A
+hash is a convenient mechanism for storing this mapping. The code
+below shows a possible implementation
+
+ static HV * Mapping = (HV*)NULL ;
+
+ void
+ asynch_read(fh, callback)
+ int fh
+ SV * callback
+ CODE:
+ /* If the hash doesn't already exist, create it */
+ if (Mapping == (HV*)NULL)
+ Mapping = newHV() ;
+
+ /* Save the fh -> callback mapping */
+ hv_store(Mapping, (char*)&fh, sizeof(fh), newSVsv(callback), 0) ;
+
+ /* Register with the C Library */
+ asynch_read(fh, asynch_read_if) ;
+
+and C<asynch_read_if> could look like this
+
+ static void
+ asynch_read_if(fh, buffer)
+ int fh ;
+ char * buffer ;
+ {
+ dSP ;
+ SV ** sv ;
+
+ /* Get the callback associated with fh */
+ sv = hv_fetch(Mapping, (char*)&fh , sizeof(fh), FALSE) ;
+ if (sv == (SV**)NULL)
+ croak("Internal error...\n") ;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sv_2mortal(newSViv(fh))) ;
+ XPUSHs(sv_2mortal(newSVpv(buffer, 0))) ;
+ PUTBACK ;
+
+ /* Call the Perl sub */
+ perl_call_sv(*sv, G_DISCARD) ;
+ }
+
+For completeness, here is C<asynch_close>. This shows how to remove
+the entry from the hash C<Mapping>.
+
+ void
+ asynch_close(fh)
+ int fh
+ CODE:
+ /* Remove the entry from the hash */
+ (void) hv_delete(Mapping, (char*)&fh, sizeof(fh), G_DISCARD) ;
+
+ /* Now call the real asynch_close */
+ asynch_close(fh) ;
+
+So the Perl interface would look like this
+
+ sub callback1
+ {
+ my($handle, $buffer) = @_ ;
+ }
+
+ # Register the Perl callback
+ asynch_read($fh, \&callback1) ;
+
+ asynch_close($fh) ;
+
+The mapping between the C callback and Perl is stored in the global
+hash C<Mapping> this time. Using a hash has the distinct advantage that
+it allows an unlimited number of callbacks to be registered.
+
+What if the interface provided by the C callback doesn't contain a
+parameter which allows the file handle to Perl subroutine mapping? Say
+in the asynchronous i/o package, the callback function gets passed only
+the C<buffer> parameter like this
+
+ void
+ ProcessRead(buffer)
+ char * buffer ;
+ {
+ ...
+ }
+
+Without the file handle there is no straightforward way to map from the
+C callback to the Perl subroutine.
+
+In this case a possible way around this problem is to predefine a
+series of C functions to act as the interface to Perl, thus
+
+ #define MAX_CB 3
+ #define NULL_HANDLE -1
+ typedef void (*FnMap)() ;
+
+ struct MapStruct {
+ FnMap Function ;
+ SV * PerlSub ;
+ int Handle ;
+ } ;
+
+ static void fn1() ;
+ static void fn2() ;
+ static void fn3() ;
+
+ static struct MapStruct Map [MAX_CB] =
+ {
+ { fn1, NULL, NULL_HANDLE },
+ { fn2, NULL, NULL_HANDLE },
+ { fn3, NULL, NULL_HANDLE }
+ } ;
+
+ static void
+ Pcb(index, buffer)
+ int index ;
+ char * buffer ;
+ {
+ dSP ;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sv_2mortal(newSVpv(buffer, 0))) ;
+ PUTBACK ;
+
+ /* Call the Perl sub */
+ perl_call_sv(Map[index].PerlSub, G_DISCARD) ;
+ }
+
+ static void
+ fn1(buffer)
+ char * buffer ;
+ {
+ Pcb(0, buffer) ;
+ }
+
+ static void
+ fn2(buffer)
+ char * buffer ;
+ {
+ Pcb(1, buffer) ;
+ }
+
+ static void
+ fn3(buffer)
+ char * buffer ;
+ {
+ Pcb(2, buffer) ;
+ }
+
+ void
+ array_asynch_read(fh, callback)
+ int fh
+ SV * callback
+ CODE:
+ int index ;
+ int null_index = MAX_CB ;
+
+ /* Find the same handle or an empty entry */
+ for (index = 0 ; index < MAX_CB ; ++index)
+ {
+ if (Map[index].Handle == fh)
+ break ;
+
+ if (Map[index].Handle == NULL_HANDLE)
+ null_index = index ;
+ }
+
+ if (index == MAX_CB && null_index == MAX_CB)
+ croak ("Too many callback functions registered\n") ;
+
+ if (index == MAX_CB)
+ index = null_index ;
+
+ /* Save the file handle */
+ Map[index].Handle = fh ;
+
+ /* Remember the Perl sub */
+ if (Map[index].PerlSub == (SV*)NULL)
+ Map[index].PerlSub = newSVsv(callback) ;
+ else
+ SvSetSV(Map[index].PerlSub, callback) ;
+
+ asynch_read(fh, Map[index].Function) ;
+
+ void
+ array_asynch_close(fh)
+ int fh
+ CODE:
+ int index ;
+
+ /* Find the file handle */
+ for (index = 0; index < MAX_CB ; ++ index)
+ if (Map[index].Handle == fh)
+ break ;
+
+ if (index == MAX_CB)
+ croak ("could not close fh %d\n", fh) ;
+
+ Map[index].Handle = NULL_HANDLE ;
+ SvREFCNT_dec(Map[index].PerlSub) ;
+ Map[index].PerlSub = (SV*)NULL ;
+
+ asynch_close(fh) ;
+
+In this case the functions C<fn1>, C<fn2>, and C<fn3> are used to
+remember the Perl subroutine to be called. Each of the functions holds
+a separate hard-wired index which is used in the function C<Pcb> to
+access the C<Map> array and actually call the Perl subroutine.
+
+There are some obvious disadvantages with this technique.
+
+Firstly, the code is considerably more complex than with the previous
+example.
+
+Secondly, there is a hard-wired limit (in this case 3) to the number of
+callbacks that can exist simultaneously. The only way to increase the
+limit is by modifying the code to add more functions and then
+recompiling. None the less, as long as the number of functions is
+chosen with some care, it is still a workable solution and in some
+cases is the only one available.
+
+To summarize, here are a number of possible methods for you to consider
+for storing the mapping between C and the Perl callback
+
+=over 5
+
+=item 1. Ignore the problem - Allow only 1 callback
+
+For a lot of situations, like interfacing to an error handler, this may
+be a perfectly adequate solution.
+
+=item 2. Create a sequence of callbacks - hard wired limit
+
+If it is impossible to tell from the parameters passed back from the C
+callback what the context is, then you may need to create a sequence of C
+callback interface functions, and store pointers to each in an array.
+
+=item 3. Use a parameter to map to the Perl callback
+
+A hash is an ideal mechanism to store the mapping between C and Perl.
+
+=back
+
+
+=head2 Alternate Stack Manipulation
+
+
+Although I have made use of only the C<POP*> macros to access values
+returned from Perl subroutines, it is also possible to bypass these
+macros and read the stack using the C<ST> macro (See L<perlxs> for a
+full description of the C<ST> macro).
+
+Most of the time the C<POP*> macros should be adequate, the main
+problem with them is that they force you to process the returned values
+in sequence. This may not be the most suitable way to process the
+values in some cases. What we want is to be able to access the stack in
+a random order. The C<ST> macro as used when coding an XSUB is ideal
+for this purpose.
+
+The code below is the example given in the section I<Returning a list
+of values> recoded to use C<ST> instead of C<POP*>.
+
+ static void
+ call_AddSubtract2(a, b)
+ int a ;
+ int b ;
+ {
+ dSP ;
+ I32 ax ;
+ int count ;
+
+ ENTER ;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sv_2mortal(newSViv(a)));
+ XPUSHs(sv_2mortal(newSViv(b)));
+ PUTBACK ;
+
+ count = perl_call_pv("AddSubtract", G_ARRAY);
+
+ SPAGAIN ;
+ SP -= count ;
+ ax = (SP - PL_stack_base) + 1 ;
+
+ if (count != 2)
+ croak("Big trouble\n") ;
+
+ printf ("%d + %d = %d\n", a, b, SvIV(ST(0))) ;
+ printf ("%d - %d = %d\n", a, b, SvIV(ST(1))) ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ }
+
+Notes
+
+=over 5
+
+=item 1.
+
+Notice that it was necessary to define the variable C<ax>. This is
+because the C<ST> macro expects it to exist. If we were in an XSUB it
+would not be necessary to define C<ax> as it is already defined for
+you.
+
+=item 2.
+
+The code
+
+ SPAGAIN ;
+ SP -= count ;
+ ax = (SP - PL_stack_base) + 1 ;
+
+sets the stack up so that we can use the C<ST> macro.
+
+=item 3.
+
+Unlike the original coding of this example, the returned
+values are not accessed in reverse order. So C<ST(0)> refers to the
+first value returned by the Perl subroutine and C<ST(count-1)>
+refers to the last.
+
+=back
+
+=head2 Creating and calling an anonymous subroutine in C
+
+As we've already shown, C<perl_call_sv> can be used to invoke an
+anonymous subroutine. However, our example showed how Perl script
+invoking an XSUB to preform this operation. Let's see how it can be
+done inside our C code:
+
+ ...
+
+ SV *cvrv = perl_eval_pv("sub { print 'You will not find me cluttering any namespace!' }", TRUE);
+
+ ...
+
+ perl_call_sv(cvrv, G_VOID|G_NOARGS);
+
+C<perl_eval_pv> is used to compile the anonymous subroutine, which
+will be the return value as well (read more about C<perl_eval_pv> in
+L<perlguts/perl_eval_pv>). Once this code reference is in hand, it
+can be mixed in with all the previous examples we've shown.
+
+=head1 SEE ALSO
+
+L<perlxs>, L<perlguts>, L<perlembed>
+
+=head1 AUTHOR
+
+Paul Marquess <F<pmarquess@bfsec.bt.co.uk>>
+
+Special thanks to the following people who assisted in the creation of
+the document.
+
+Jeff Okamoto, Tim Bunce, Nick Gianniotis, Steve Kelem, Gurusamy Sarathy
+and Larry Wall.
+
+=head1 DATE
+
+Version 1.3, 14th Apr 1997
diff --git a/contrib/perl5/pod/perldata.pod b/contrib/perl5/pod/perldata.pod
new file mode 100644
index 000000000000..58c11234b421
--- /dev/null
+++ b/contrib/perl5/pod/perldata.pod
@@ -0,0 +1,603 @@
+=head1 NAME
+
+perldata - Perl data types
+
+=head1 DESCRIPTION
+
+=head2 Variable names
+
+Perl has three data structures: scalars, arrays of scalars, and
+associative arrays of scalars, known as "hashes". Normal arrays are
+indexed by number, starting with 0. (Negative subscripts count from
+the end.) Hash arrays are indexed by string.
+
+Values are usually referred to by name (or through a named reference).
+The first character of the name tells you to what sort of data
+structure it refers. The rest of the name tells you the particular
+value to which it refers. Most often, it consists of a single
+I<identifier>, that is, a string beginning with a letter or underscore,
+and containing letters, underscores, and digits. In some cases, it
+may be a chain of identifiers, separated by C<::> (or by C<'>, but
+that's deprecated); all but the last are interpreted as names of
+packages, to locate the namespace in which to look
+up the final identifier (see L<perlmod/Packages> for details).
+It's possible to substitute for a simple identifier an expression
+that produces a reference to the value at runtime; this is
+described in more detail below, and in L<perlref>.
+
+There are also special variables whose names don't follow these
+rules, so that they don't accidentally collide with one of your
+normal variables. Strings that match parenthesized parts of a
+regular expression are saved under names containing only digits after
+the C<$> (see L<perlop> and L<perlre>). In addition, several special
+variables that provide windows into the inner working of Perl have names
+containing punctuation characters (see L<perlvar>).
+
+Scalar values are always named with '$', even when referring to a scalar
+that is part of an array. It works like the English word "the". Thus
+we have:
+
+ $days # the simple scalar value "days"
+ $days[28] # the 29th element of array @days
+ $days{'Feb'} # the 'Feb' value from hash %days
+ $#days # the last index of array @days
+
+but entire arrays or array slices are denoted by '@', which works much like
+the word "these" or "those":
+
+ @days # ($days[0], $days[1],... $days[n])
+ @days[3,4,5] # same as @days[3..5]
+ @days{'a','c'} # same as ($days{'a'},$days{'c'})
+
+and entire hashes are denoted by '%':
+
+ %days # (key1, val1, key2, val2 ...)
+
+In addition, subroutines are named with an initial '&', though this is
+optional when it's otherwise unambiguous (just as "do" is often
+redundant in English). Symbol table entries can be named with an
+initial '*', but you don't really care about that yet.
+
+Every variable type has its own namespace. You can, without fear of
+conflict, use the same name for a scalar variable, an array, or a hash
+(or, for that matter, a filehandle, a subroutine name, or a label).
+This means that $foo and @foo are two different variables. It also
+means that C<$foo[1]> is a part of @foo, not a part of $foo. This may
+seem a bit weird, but that's okay, because it is weird.
+
+Because variable and array references always start with '$', '@', or '%',
+the "reserved" words aren't in fact reserved with respect to variable
+names. (They ARE reserved with respect to labels and filehandles,
+however, which don't have an initial special character. You can't have
+a filehandle named "log", for instance. Hint: you could say
+C<open(LOG,'logfile')> rather than C<open(log,'logfile')>. Using uppercase
+filehandles also improves readability and protects you from conflict
+with future reserved words.) Case I<IS> significant--"FOO", "Foo", and
+"foo" are all different names. Names that start with a letter or
+underscore may also contain digits and underscores.
+
+It is possible to replace such an alphanumeric name with an expression
+that returns a reference to an object of that type. For a description
+of this, see L<perlref>.
+
+Names that start with a digit may contain only more digits. Names
+that do not start with a letter, underscore, or digit are limited to
+one character, e.g., C<$%> or C<$$>. (Most of these one character names
+have a predefined significance to Perl. For instance, C<$$> is the
+current process id.)
+
+=head2 Context
+
+The interpretation of operations and values in Perl sometimes depends
+on the requirements of the context around the operation or value.
+There are two major contexts: scalar and list. Certain operations
+return list values in contexts wanting a list, and scalar values
+otherwise. (If this is true of an operation it will be mentioned in
+the documentation for that operation.) In other words, Perl overloads
+certain operations based on whether the expected return value is
+singular or plural. (Some words in English work this way, like "fish"
+and "sheep".)
+
+In a reciprocal fashion, an operation provides either a scalar or a
+list context to each of its arguments. For example, if you say
+
+ int( <STDIN> )
+
+the integer operation provides a scalar context for the E<lt>STDINE<gt>
+operator, which responds by reading one line from STDIN and passing it
+back to the integer operation, which will then find the integer value
+of that line and return that. If, on the other hand, you say
+
+ sort( <STDIN> )
+
+then the sort operation provides a list context for E<lt>STDINE<gt>, which
+will proceed to read every line available up to the end of file, and
+pass that list of lines back to the sort routine, which will then
+sort those lines and return them as a list to whatever the context
+of the sort was.
+
+Assignment is a little bit special in that it uses its left argument to
+determine the context for the right argument. Assignment to a scalar
+evaluates the righthand side in a scalar context, while assignment to
+an array or array slice evaluates the righthand side in a list
+context. Assignment to a list also evaluates the righthand side in a
+list context.
+
+User defined subroutines may choose to care whether they are being
+called in a scalar or list context, but most subroutines do not
+need to care, because scalars are automatically interpolated into
+lists. See L<perlfunc/wantarray>.
+
+=head2 Scalar values
+
+All data in Perl is a scalar or an array of scalars or a hash of scalars.
+Scalar variables may contain various kinds of singular data, such as
+numbers, strings, and references. In general, conversion from one form to
+another is transparent. (A scalar may not contain multiple values, but
+may contain a reference to an array or hash containing multiple values.)
+Because of the automatic conversion of scalars, operations, and functions
+that return scalars don't need to care (and, in fact, can't care) whether
+the context is looking for a string or a number.
+
+Scalars aren't necessarily one thing or another. There's no place to
+declare a scalar variable to be of type "string", or of type "number", or
+type "filehandle", or anything else. Perl is a contextually polymorphic
+language whose scalars can be strings, numbers, or references (which
+includes objects). While strings and numbers are considered pretty
+much the same thing for nearly all purposes, references are strongly-typed
+uncastable pointers with builtin reference-counting and destructor
+invocation.
+
+A scalar value is interpreted as TRUE in the Boolean sense if it is not
+the null string or the number 0 (or its string equivalent, "0"). The
+Boolean context is just a special kind of scalar context.
+
+There are actually two varieties of null scalars: defined and
+undefined. Undefined null scalars are returned when there is no real
+value for something, such as when there was an error, or at end of
+file, or when you refer to an uninitialized variable or element of an
+array. An undefined null scalar may become defined the first time you
+use it as if it were defined, but prior to that you can use the
+defined() operator to determine whether the value is defined or not.
+
+To find out whether a given string is a valid nonzero number, it's usually
+enough to test it against both numeric 0 and also lexical "0" (although
+this will cause B<-w> noises). That's because strings that aren't
+numbers count as 0, just as they do in B<awk>:
+
+ if ($str == 0 && $str ne "0") {
+ warn "That doesn't look like a number";
+ }
+
+That's usually preferable because otherwise you won't treat IEEE notations
+like C<NaN> or C<Infinity> properly. At other times you might prefer to
+use the POSIX::strtod function or a regular expression to check whether
+data is numeric. See L<perlre> for details on regular expressions.
+
+ warn "has nondigits" if /\D/;
+ warn "not a natural number" unless /^\d+$/; # rejects -3
+ warn "not an integer" unless /^-?\d+$/; # rejects +3
+ warn "not an integer" unless /^[+-]?\d+$/;
+ warn "not a decimal number" unless /^-?\d+\.?\d*$/; # rejects .2
+ warn "not a decimal number" unless /^-?(?:\d+(?:\.\d*)?|\.\d+)$/;
+ warn "not a C float"
+ unless /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
+
+The length of an array is a scalar value. You may find the length of
+array @days by evaluating C<$#days>, as in B<csh>. (Actually, it's not
+the length of the array, it's the subscript of the last element, because
+there is (ordinarily) a 0th element.) Assigning to C<$#days> changes the
+length of the array. Shortening an array by this method destroys
+intervening values. Lengthening an array that was previously shortened
+I<NO LONGER> recovers the values that were in those elements. (It used to
+in Perl 4, but we had to break this to make sure destructors were
+called when expected.) You can also gain some miniscule measure of efficiency by
+pre-extending an array that is going to get big. (You can also extend
+an array by assigning to an element that is off the end of the array.)
+You can truncate an array down to nothing by assigning the null list ()
+to it. The following are equivalent:
+
+ @whatever = ();
+ $#whatever = -1;
+
+If you evaluate a named array in a scalar context, it returns the length of
+the array. (Note that this is not true of lists, which return the
+last value, like the C comma operator, nor of built-in functions, which return
+whatever they feel like returning.) The following is always true:
+
+ scalar(@whatever) == $#whatever - $[ + 1;
+
+Version 5 of Perl changed the semantics of C<$[>: files that don't set
+the value of C<$[> no longer need to worry about whether another
+file changed its value. (In other words, use of C<$[> is deprecated.)
+So in general you can assume that
+
+ scalar(@whatever) == $#whatever + 1;
+
+Some programmers choose to use an explicit conversion so nothing's
+left to doubt:
+
+ $element_count = scalar(@whatever);
+
+If you evaluate a hash in a scalar context, it returns a value that is
+true if and only if the hash contains any key/value pairs. (If there
+are any key/value pairs, the value returned is a string consisting of
+the number of used buckets and the number of allocated buckets, separated
+by a slash. This is pretty much useful only to find out whether Perl's
+(compiled in) hashing algorithm is performing poorly on your data set.
+For example, you stick 10,000 things in a hash, but evaluating %HASH in
+scalar context reveals "1/16", which means only one out of sixteen buckets
+has been touched, and presumably contains all 10,000 of your items. This
+isn't supposed to happen.)
+
+You can preallocate space for a hash by assigning to the keys() function.
+This rounds up the allocated bucked to the next power of two:
+
+ keys(%users) = 1000; # allocate 1024 buckets
+
+=head2 Scalar value constructors
+
+Numeric literals are specified in any of the customary floating point or
+integer formats:
+
+ 12345
+ 12345.67
+ .23E-10
+ 0xffff # hex
+ 0377 # octal
+ 4_294_967_296 # underline for legibility
+
+String literals are usually delimited by either single or double
+quotes. They work much like shell quotes: double-quoted string
+literals are subject to backslash and variable substitution;
+single-quoted strings are not (except for "C<\'>" and "C<\\>").
+The usual Unix backslash rules apply for making characters such as
+newline, tab, etc., as well as some more exotic forms. See
+L<perlop/Quote and Quotelike Operators> for a list.
+
+Octal or hex representations in string literals (e.g. '0xffff') are not
+automatically converted to their integer representation. The hex() and
+oct() functions make these conversions for you. See L<perlfunc/hex> and
+L<perlfunc/oct> for more details.
+
+You can also embed newlines directly in your strings, i.e., they can end
+on a different line than they begin. This is nice, but if you forget
+your trailing quote, the error will not be reported until Perl finds
+another line containing the quote character, which may be much further
+on in the script. Variable substitution inside strings is limited to
+scalar variables, arrays, and array slices. (In other words,
+names beginning with $ or @, followed by an optional bracketed
+expression as a subscript.) The following code segment prints out "The
+price is $Z<>100."
+
+ $Price = '$100'; # not interpreted
+ print "The price is $Price.\n"; # interpreted
+
+As in some shells, you can put curly brackets around the name to
+delimit it from following alphanumerics. In fact, an identifier
+within such curlies is forced to be a string, as is any single
+identifier within a hash subscript. Our earlier example,
+
+ $days{'Feb'}
+
+can be written as
+
+ $days{Feb}
+
+and the quotes will be assumed automatically. But anything more complicated
+in the subscript will be interpreted as an expression.
+
+Note that a
+single-quoted string must be separated from a preceding word by a
+space, because single quote is a valid (though deprecated) character in
+a variable name (see L<perlmod/Packages>).
+
+Three special literals are __FILE__, __LINE__, and __PACKAGE__, which
+represent the current filename, line number, and package name at that
+point in your program. They may be used only as separate tokens; they
+will not be interpolated into strings. If there is no current package
+(due to an empty C<package;> directive), __PACKAGE__ is the undefined value.
+
+The tokens __END__ and __DATA__ may be used to indicate the logical end
+of the script before the actual end of file. Any following text is
+ignored, but may be read via a DATA filehandle: main::DATA for __END__,
+or PACKNAME::DATA (where PACKNAME is the current package) for __DATA__.
+The two control characters ^D and ^Z are synonyms for __END__ (or
+__DATA__ in a module). See L<SelfLoader> for more description of
+__DATA__, and an example of its use. Note that you cannot read from the
+DATA filehandle in a BEGIN block: the BEGIN block is executed as soon as
+it is seen (during compilation), at which point the corresponding
+__DATA__ (or __END__) token has not yet been seen.
+
+A word that has no other interpretation in the grammar will
+be treated as if it were a quoted string. These are known as
+"barewords". As with filehandles and labels, a bareword that consists
+entirely of lowercase letters risks conflict with future reserved
+words, and if you use the B<-w> switch, Perl will warn you about any
+such words. Some people may wish to outlaw barewords entirely. If you
+say
+
+ use strict 'subs';
+
+then any bareword that would NOT be interpreted as a subroutine call
+produces a compile-time error instead. The restriction lasts to the
+end of the enclosing block. An inner block may countermand this
+by saying C<no strict 'subs'>.
+
+Array variables are interpolated into double-quoted strings by joining all
+the elements of the array with the delimiter specified in the C<$">
+variable (C<$LIST_SEPARATOR> in English), space by default. The following
+are equivalent:
+
+ $temp = join($",@ARGV);
+ system "echo $temp";
+
+ system "echo @ARGV";
+
+Within search patterns (which also undergo double-quotish substitution)
+there is a bad ambiguity: Is C</$foo[bar]/> to be interpreted as
+C</${foo}[bar]/> (where C<[bar]> is a character class for the regular
+expression) or as C</${foo[bar]}/> (where C<[bar]> is the subscript to array
+@foo)? If @foo doesn't otherwise exist, then it's obviously a
+character class. If @foo exists, Perl takes a good guess about C<[bar]>,
+and is almost always right. If it does guess wrong, or if you're just
+plain paranoid, you can force the correct interpretation with curly
+brackets as above.
+
+A line-oriented form of quoting is based on the shell "here-doc"
+syntax. Following a C<E<lt>E<lt>> you specify a string to terminate
+the quoted material, and all lines following the current line down to
+the terminating string are the value of the item. The terminating
+string may be either an identifier (a word), or some quoted text. If
+quoted, the type of quotes you use determines the treatment of the
+text, just as in regular quoting. An unquoted identifier works like
+double quotes. There must be no space between the C<E<lt>E<lt>> and
+the identifier. (If you put a space it will be treated as a null
+identifier, which is valid, and matches the first empty line.) The
+terminating string must appear by itself (unquoted and with no
+surrounding whitespace) on the terminating line.
+
+ print <<EOF;
+ The price is $Price.
+ EOF
+
+ print <<"EOF"; # same as above
+ The price is $Price.
+ EOF
+
+ print <<`EOC`; # execute commands
+ echo hi there
+ echo lo there
+ EOC
+
+ print <<"foo", <<"bar"; # you can stack them
+ I said foo.
+ foo
+ I said bar.
+ bar
+
+ myfunc(<<"THIS", 23, <<'THAT');
+ Here's a line
+ or two.
+ THIS
+ and here's another.
+ THAT
+
+Just don't forget that you have to put a semicolon on the end
+to finish the statement, as Perl doesn't know you're not going to
+try to do this:
+
+ print <<ABC
+ 179231
+ ABC
+ + 20;
+
+
+=head2 List value constructors
+
+List values are denoted by separating individual values by commas
+(and enclosing the list in parentheses where precedence requires it):
+
+ (LIST)
+
+In a context not requiring a list value, the value of the list
+literal is the value of the final element, as with the C comma operator.
+For example,
+
+ @foo = ('cc', '-E', $bar);
+
+assigns the entire list value to array foo, but
+
+ $foo = ('cc', '-E', $bar);
+
+assigns the value of variable bar to variable foo. Note that the value
+of an actual array in a scalar context is the length of the array; the
+following assigns the value 3 to $foo:
+
+ @foo = ('cc', '-E', $bar);
+ $foo = @foo; # $foo gets 3
+
+You may have an optional comma before the closing parenthesis of a
+list literal, so that you can say:
+
+ @foo = (
+ 1,
+ 2,
+ 3,
+ );
+
+LISTs do automatic interpolation of sublists. That is, when a LIST is
+evaluated, each element of the list is evaluated in a list context, and
+the resulting list value is interpolated into LIST just as if each
+individual element were a member of LIST. Thus arrays and hashes lose their
+identity in a LIST--the list
+
+ (@foo,@bar,&SomeSub,%glarch)
+
+contains all the elements of @foo followed by all the elements of @bar,
+followed by all the elements returned by the subroutine named SomeSub
+called in a list context, followed by the key/value pairs of %glarch.
+To make a list reference that does I<NOT> interpolate, see L<perlref>.
+
+The null list is represented by (). Interpolating it in a list
+has no effect. Thus ((),(),()) is equivalent to (). Similarly,
+interpolating an array with no elements is the same as if no
+array had been interpolated at that point.
+
+A list value may also be subscripted like a normal array. You must
+put the list in parentheses to avoid ambiguity. For example:
+
+ # Stat returns list value.
+ $time = (stat($file))[8];
+
+ # SYNTAX ERROR HERE.
+ $time = stat($file)[8]; # OOPS, FORGOT PARENTHESES
+
+ # Find a hex digit.
+ $hexdigit = ('a','b','c','d','e','f')[$digit-10];
+
+ # A "reverse comma operator".
+ return (pop(@foo),pop(@foo))[0];
+
+You may assign to C<undef> in a list. This is useful for throwing
+away some of the return values of a function:
+
+ ($dev, $ino, undef, undef, $uid, $gid) = stat($file);
+
+Lists may be assigned to if and only if each element of the list
+is legal to assign to:
+
+ ($a, $b, $c) = (1, 2, 3);
+
+ ($map{'red'}, $map{'blue'}, $map{'green'}) = (0x00f, 0x0f0, 0xf00);
+
+Array assignment in a scalar context returns the number of elements
+produced by the expression on the right side of the assignment:
+
+ $x = (($foo,$bar) = (3,2,1)); # set $x to 3, not 2
+ $x = (($foo,$bar) = f()); # set $x to f()'s return count
+
+This is very handy when you want to do a list assignment in a Boolean
+context, because most list functions return a null list when finished,
+which when assigned produces a 0, which is interpreted as FALSE.
+
+The final element may be an array or a hash:
+
+ ($a, $b, @rest) = split;
+ my($a, $b, %rest) = @_;
+
+You can actually put an array or hash anywhere in the list, but the first one
+in the list will soak up all the values, and anything after it will get
+a null value. This may be useful in a local() or my().
+
+A hash literal contains pairs of values to be interpreted
+as a key and a value:
+
+ # same as map assignment above
+ %map = ('red',0x00f,'blue',0x0f0,'green',0xf00);
+
+While literal lists and named arrays are usually interchangeable, that's
+not the case for hashes. Just because you can subscript a list value like
+a normal array does not mean that you can subscript a list value as a
+hash. Likewise, hashes included as parts of other lists (including
+parameters lists and return lists from functions) always flatten out into
+key/value pairs. That's why it's good to use references sometimes.
+
+It is often more readable to use the C<=E<gt>> operator between key/value
+pairs. The C<=E<gt>> operator is mostly just a more visually distinctive
+synonym for a comma, but it also arranges for its left-hand operand to be
+interpreted as a string--if it's a bareword that would be a legal identifier.
+This makes it nice for initializing hashes:
+
+ %map = (
+ red => 0x00f,
+ blue => 0x0f0,
+ green => 0xf00,
+ );
+
+or for initializing hash references to be used as records:
+
+ $rec = {
+ witch => 'Mable the Merciless',
+ cat => 'Fluffy the Ferocious',
+ date => '10/31/1776',
+ };
+
+or for using call-by-named-parameter to complicated functions:
+
+ $field = $query->radio_group(
+ name => 'group_name',
+ values => ['eenie','meenie','minie'],
+ default => 'meenie',
+ linebreak => 'true',
+ labels => \%labels
+ );
+
+Note that just because a hash is initialized in that order doesn't
+mean that it comes out in that order. See L<perlfunc/sort> for examples
+of how to arrange for an output ordering.
+
+=head2 Typeglobs and Filehandles
+
+Perl uses an internal type called a I<typeglob> to hold an entire
+symbol table entry. The type prefix of a typeglob is a C<*>, because
+it represents all types. This used to be the preferred way to
+pass arrays and hashes by reference into a function, but now that
+we have real references, this is seldom needed.
+
+The main use of typeglobs in modern Perl is create symbol table aliases.
+This assignment:
+
+ *this = *that;
+
+makes $this an alias for $that, @this an alias for @that, %this an alias
+for %that, &this an alias for &that, etc. Much safer is to use a reference.
+This:
+
+ local *Here::blue = \$There::green;
+
+temporarily makes $Here::blue an alias for $There::green, but doesn't
+make @Here::blue an alias for @There::green, or %Here::blue an alias for
+%There::green, etc. See L<perlmod/"Symbol Tables"> for more examples
+of this. Strange though this may seem, this is the basis for the whole
+module import/export system.
+
+Another use for typeglobs is to to pass filehandles into a function or
+to create new filehandles. If you need to use a typeglob to save away
+a filehandle, do it this way:
+
+ $fh = *STDOUT;
+
+or perhaps as a real reference, like this:
+
+ $fh = \*STDOUT;
+
+See L<perlsub> for examples of using these as indirect filehandles
+in functions.
+
+Typeglobs are also a way to create a local filehandle using the local()
+operator. These last until their block is exited, but may be passed back.
+For example:
+
+ sub newopen {
+ my $path = shift;
+ local *FH; # not my!
+ open (FH, $path) or return undef;
+ return *FH;
+ }
+ $fh = newopen('/etc/passwd');
+
+Now that we have the *foo{THING} notation, typeglobs aren't used as much
+for filehandle manipulations, although they're still needed to pass brand
+new file and directory handles into or out of functions. That's because
+*HANDLE{IO} only works if HANDLE has already been used as a handle.
+In other words, *FH can be used to create new symbol table entries,
+but *foo{THING} cannot.
+
+Another way to create anonymous filehandles is with the IO::Handle
+module and its ilk. These modules have the advantage of not hiding
+different types of the same name during the local(). See the bottom of
+L<perlfunc/open()> for an example.
+
+See L<perlref>, L<perlsub>, and L<perlmod/"Symbol Tables"> for more
+discussion on typeglobs and the *foo{THING} syntax.
diff --git a/contrib/perl5/pod/perldebug.pod b/contrib/perl5/pod/perldebug.pod
new file mode 100644
index 000000000000..7a6e814fb120
--- /dev/null
+++ b/contrib/perl5/pod/perldebug.pod
@@ -0,0 +1,1661 @@
+=head1 NAME
+
+perldebug - Perl debugging
+
+=head1 DESCRIPTION
+
+First of all, have you tried using the B<-w> switch?
+
+=head1 The Perl Debugger
+
+"As soon as we started programming, we found to our
+surprise that it wasn't as easy to get programs right
+as we had thought. Debugging had to be discovered.
+I can remember the exact instant when I realized that
+a large part of my life from then on was going to be
+spent in finding mistakes in my own programs."
+
+I< --Maurice Wilkes, 1949>
+
+If you invoke Perl with the B<-d> switch, your script runs under the
+Perl source debugger. This works like an interactive Perl
+environment, prompting for debugger commands that let you examine
+source code, set breakpoints, get stack backtraces, change the values of
+variables, etc. This is so convenient that you often fire up
+the debugger all by itself just to test out Perl constructs
+interactively to see what they do. For example:
+
+ perl -d -e 42
+
+In Perl, the debugger is not a separate program as it usually is in the
+typical compiled environment. Instead, the B<-d> flag tells the compiler
+to insert source information into the parse trees it's about to hand off
+to the interpreter. That means your code must first compile correctly
+for the debugger to work on it. Then when the interpreter starts up, it
+preloads a Perl library file containing the debugger itself.
+
+The program will halt I<right before> the first run-time executable
+statement (but see below regarding compile-time statements) and ask you
+to enter a debugger command. Contrary to popular expectations, whenever
+the debugger halts and shows you a line of code, it always displays the
+line it's I<about> to execute, rather than the one it has just executed.
+
+Any command not recognized by the debugger is directly executed
+(C<eval>'d) as Perl code in the current package. (The debugger uses the
+DB package for its own state information.)
+
+Leading white space before a command would cause the debugger to think
+it's I<NOT> a debugger command but for Perl, so be careful not to do
+that.
+
+=head2 Debugger Commands
+
+The debugger understands the following commands:
+
+=over 12
+
+=item h [command]
+
+Prints out a help message.
+
+If you supply another debugger command as an argument to the C<h> command,
+it prints out the description for just that command. The special
+argument of C<h h> produces a more compact help listing, designed to fit
+together on one screen.
+
+If the output of the C<h> command (or any command, for that matter) scrolls
+past your screen, either precede the command with a leading pipe symbol so
+it's run through your pager, as in
+
+ DB> |h
+
+You may change the pager which is used via C<O pager=...> command.
+
+=item p expr
+
+Same as C<print {$DB::OUT} expr> in the current package. In particular,
+because this is just Perl's own B<print> function, this means that nested
+data structures and objects are not dumped, unlike with the C<x> command.
+
+The C<DB::OUT> filehandle is opened to F</dev/tty>, regardless of
+where STDOUT may be redirected to.
+
+=item x expr
+
+Evaluates its expression in list context and dumps out the result
+in a pretty-printed fashion. Nested data structures are printed out
+recursively, unlike the C<print> function.
+
+The details of printout are governed by multiple C<O>ptions.
+
+=item V [pkg [vars]]
+
+Display all (or some) variables in package (defaulting to the C<main>
+package) using a data pretty-printer (hashes show their keys and values so
+you see what's what, control characters are made printable, etc.). Make
+sure you don't put the type specifier (like C<$>) there, just the symbol
+names, like this:
+
+ V DB filename line
+
+Use C<~pattern> and C<!pattern> for positive and negative regexps.
+
+Nested data structures are printed out in a legible fashion, unlike
+the C<print> function.
+
+The details of printout are governed by multiple C<O>ptions.
+
+=item X [vars]
+
+Same as C<V currentpackage [vars]>.
+
+=item T
+
+Produce a stack backtrace. See below for details on its output.
+
+=item s [expr]
+
+Single step. Executes until it reaches the beginning of another
+statement, descending into subroutine calls. If an expression is
+supplied that includes function calls, it too will be single-stepped.
+
+=item n [expr]
+
+Next. Executes over subroutine calls, until it reaches the beginning
+of the next statement. If an expression is supplied that includes
+function calls, those functions will be executed with stops before
+each statement.
+
+=item E<lt>CRE<gt>
+
+Repeat last C<n> or C<s> command.
+
+=item c [line|sub]
+
+Continue, optionally inserting a one-time-only breakpoint
+at the specified line or subroutine.
+
+=item l
+
+List next window of lines.
+
+=item l min+incr
+
+List C<incr+1> lines starting at C<min>.
+
+=item l min-max
+
+List lines C<min> through C<max>. C<l -> is synonymous to C<->.
+
+=item l line
+
+List a single line.
+
+=item l subname
+
+List first window of lines from subroutine.
+
+=item -
+
+List previous window of lines.
+
+=item w [line]
+
+List window (a few lines) around the current line.
+
+=item .
+
+Return debugger pointer to the last-executed line and
+print it out.
+
+=item f filename
+
+Switch to viewing a different file or eval statement. If C<filename>
+is not a full filename as found in values of %INC, it is considered as
+a regexp.
+
+=item /pattern/
+
+Search forwards for pattern; final / is optional.
+
+=item ?pattern?
+
+Search backwards for pattern; final ? is optional.
+
+=item L
+
+List all breakpoints and actions.
+
+=item S [[!]pattern]
+
+List subroutine names [not] matching pattern.
+
+=item t
+
+Toggle trace mode (see also C<AutoTrace> C<O>ption).
+
+=item t expr
+
+Trace through execution of expr. For example:
+
+ $ perl -de 42
+ Stack dump during die enabled outside of evals.
+
+ Loading DB routines from perl5db.pl patch level 0.94
+ Emacs support available.
+
+ Enter h or `h h' for help.
+
+ main::(-e:1): 0
+ DB<1> sub foo { 14 }
+
+ DB<2> sub bar { 3 }
+
+ DB<3> t print foo() * bar()
+ main::((eval 172):3): print foo() + bar();
+ main::foo((eval 168):2):
+ main::bar((eval 170):2):
+ 42
+
+or, with the C<O>ption C<frame=2> set,
+
+ DB<4> O f=2
+ frame = '2'
+ DB<5> t print foo() * bar()
+ 3: foo() * bar()
+ entering main::foo
+ 2: sub foo { 14 };
+ exited main::foo
+ entering main::bar
+ 2: sub bar { 3 };
+ exited main::bar
+ 42
+
+=item b [line] [condition]
+
+Set a breakpoint. If line is omitted, sets a breakpoint on the line
+that is about to be executed. If a condition is specified, it's
+evaluated each time the statement is reached and a breakpoint is taken
+only if the condition is true. Breakpoints may be set on only lines
+that begin an executable statement. Conditions don't use B<if>:
+
+ b 237 $x > 30
+ b 237 ++$count237 < 11
+ b 33 /pattern/i
+
+=item b subname [condition]
+
+Set a breakpoint at the first line of the named subroutine.
+
+=item b postpone subname [condition]
+
+Set breakpoint at first line of subroutine after it is compiled.
+
+=item b load filename
+
+Set breakpoint at the first executed line of the file. Filename should
+be a full name as found in values of %INC.
+
+=item b compile subname
+
+Sets breakpoint at the first statement executed after the subroutine
+is compiled.
+
+=item d [line]
+
+Delete a breakpoint at the specified line. If line is omitted, deletes
+the breakpoint on the line that is about to be executed.
+
+=item D
+
+Delete all installed breakpoints.
+
+=item a [line] command
+
+Set an action to be done before the line is executed.
+The sequence of steps taken by the debugger is
+
+ 1. check for a breakpoint at this line
+ 2. print the line if necessary (tracing)
+ 3. do any actions associated with that line
+ 4. prompt user if at a breakpoint or in single-step
+ 5. evaluate line
+
+For example, this will print out $foo every time line
+53 is passed:
+
+ a 53 print "DB FOUND $foo\n"
+
+=item A
+
+Delete all installed actions.
+
+=item W [expr]
+
+Add a global watch-expression.
+
+=item W
+
+Delete all watch-expressions.
+
+=item O [opt[=val]] [opt"val"] [opt?]...
+
+Set or query values of options. val defaults to 1. opt can
+be abbreviated. Several options can be listed.
+
+=over 12
+
+=item C<recallCommand>, C<ShellBang>
+
+The characters used to recall command or spawn shell. By
+default, these are both set to C<!>.
+
+=item C<pager>
+
+Program to use for output of pager-piped commands (those
+beginning with a C<|> character.) By default,
+C<$ENV{PAGER}> will be used.
+
+=item C<tkRunning>
+
+Run Tk while prompting (with ReadLine).
+
+=item C<signalLevel>, C<warnLevel>, C<dieLevel>
+
+Level of verbosity. By default the debugger is in a sane verbose mode,
+thus it will print backtraces on all the warnings and die-messages
+which are going to be printed out, and will print a message when
+interesting uncaught signals arrive.
+
+To disable this behaviour, set these values to 0. If C<dieLevel> is 2,
+then the messages which will be caught by surrounding C<eval> are also
+printed.
+
+=item C<AutoTrace>
+
+Trace mode (similar to C<t> command, but can be put into
+C<PERLDB_OPTS>).
+
+=item C<LineInfo>
+
+File or pipe to print line number info to. If it is a pipe (say,
+C<|visual_perl_db>), then a short, "emacs like" message is used.
+
+=item C<inhibit_exit>
+
+If 0, allows I<stepping off> the end of the script.
+
+=item C<PrintRet>
+
+affects printing of return value after C<r> command.
+
+=item C<ornaments>
+
+affects screen appearance of the command line (see L<Term::ReadLine>).
+
+=item C<frame>
+
+affects printing messages on entry and exit from subroutines. If
+C<frame & 2> is false, messages are printed on entry only. (Printing
+on exit may be useful if inter(di)spersed with other messages.)
+
+If C<frame & 4>, arguments to functions are printed as well as the
+context and caller info. If C<frame & 8>, overloaded C<stringify> and
+C<tie>d C<FETCH> are enabled on the printed arguments. If C<frame &
+16>, the return value from the subroutine is printed as well.
+
+The length at which the argument list is truncated is governed by the
+next option:
+
+=item C<maxTraceLen>
+
+length at which the argument list is truncated when C<frame> option's
+bit 4 is set.
+
+=back
+
+The following options affect what happens with C<V>, C<X>, and C<x>
+commands:
+
+=over 12
+
+=item C<arrayDepth>, C<hashDepth>
+
+Print only first N elements ('' for all).
+
+=item C<compactDump>, C<veryCompact>
+
+Change style of array and hash dump. If C<compactDump>, short array
+may be printed on one line.
+
+=item C<globPrint>
+
+Whether to print contents of globs.
+
+=item C<DumpDBFiles>
+
+Dump arrays holding debugged files.
+
+=item C<DumpPackages>
+
+Dump symbol tables of packages.
+
+=item C<DumpReused>
+
+Dump contents of "reused" addresses.
+
+=item C<quote>, C<HighBit>, C<undefPrint>
+
+Change style of string dump. Default value of C<quote> is C<auto>, one
+can enable either double-quotish dump, or single-quotish by setting it
+to C<"> or C<'>. By default, characters with high bit set are printed
+I<as is>.
+
+=item C<UsageOnly>
+
+I<very> rudimentally per-package memory usage dump. Calculates total
+size of strings in variables in the package.
+
+=back
+
+During startup options are initialized from C<$ENV{PERLDB_OPTS}>.
+You can put additional initialization options C<TTY>, C<noTTY>,
+C<ReadLine>, and C<NonStop> there.
+
+Example rc file:
+
+ &parse_options("NonStop=1 LineInfo=db.out AutoTrace");
+
+The script will run without human intervention, putting trace information
+into the file I<db.out>. (If you interrupt it, you would better reset
+C<LineInfo> to something "interactive"!)
+
+=over 12
+
+=item C<TTY>
+
+The TTY to use for debugging I/O.
+
+=item C<noTTY>
+
+If set, goes in C<NonStop> mode, and would not connect to a TTY. If
+interrupt (or if control goes to debugger via explicit setting of
+$DB::signal or $DB::single from the Perl script), connects to a TTY
+specified by the C<TTY> option at startup, or to a TTY found at
+runtime using C<Term::Rendezvous> module of your choice.
+
+This module should implement a method C<new> which returns an object
+with two methods: C<IN> and C<OUT>, returning two filehandles to use
+for debugging input and output correspondingly. Method C<new> may
+inspect an argument which is a value of C<$ENV{PERLDB_NOTTY}> at
+startup, or is C<"/tmp/perldbtty$$"> otherwise.
+
+=item C<ReadLine>
+
+If false, readline support in debugger is disabled, so you can debug
+ReadLine applications.
+
+=item C<NonStop>
+
+If set, debugger goes into noninteractive mode until interrupted, or
+programmatically by setting $DB::signal or $DB::single.
+
+=back
+
+Here's an example of using the C<$ENV{PERLDB_OPTS}> variable:
+
+ $ PERLDB_OPTS="N f=2" perl -d myprogram
+
+will run the script C<myprogram> without human intervention, printing
+out the call tree with entry and exit points. Note that C<N f=2> is
+equivalent to C<NonStop=1 frame=2>. Note also that at the moment when
+this documentation was written all the options to the debugger could
+be uniquely abbreviated by the first letter (with exception of
+C<Dump*> options).
+
+Other examples may include
+
+ $ PERLDB_OPTS="N f A L=listing" perl -d myprogram
+
+- runs script noninteractively, printing info on each entry into a
+subroutine and each executed line into the file F<listing>. (If you
+interrupt it, you would better reset C<LineInfo> to something
+"interactive"!)
+
+
+ $ env "PERLDB_OPTS=R=0 TTY=/dev/ttyc" perl -d myprogram
+
+may be useful for debugging a program which uses C<Term::ReadLine>
+itself. Do not forget detach shell from the TTY in the window which
+corresponds to F</dev/ttyc>, say, by issuing a command like
+
+ $ sleep 1000000
+
+See L<"Debugger Internals"> below for more details.
+
+=item E<lt> [ command ]
+
+Set an action (Perl command) to happen before every debugger prompt.
+A multi-line command may be entered by backslashing the newlines. If
+C<command> is missing, resets the list of actions.
+
+=item E<lt>E<lt> command
+
+Add an action (Perl command) to happen before every debugger prompt.
+A multi-line command may be entered by backslashing the newlines.
+
+=item E<gt> command
+
+Set an action (Perl command) to happen after the prompt when you've
+just given a command to return to executing the script. A multi-line
+command may be entered by backslashing the newlines. If C<command> is
+missing, resets the list of actions.
+
+=item E<gt>E<gt> command
+
+Adds an action (Perl command) to happen after the prompt when you've
+just given a command to return to executing the script. A multi-line
+command may be entered by backslashing the newlines.
+
+=item { [ command ]
+
+Set an action (debugger command) to happen before every debugger prompt.
+A multi-line command may be entered by backslashing the newlines. If
+C<command> is missing, resets the list of actions.
+
+=item {{ command
+
+Add an action (debugger command) to happen before every debugger prompt.
+A multi-line command may be entered by backslashing the newlines.
+
+=item ! number
+
+Redo a previous command (default previous command).
+
+=item ! -number
+
+Redo number'th-to-last command.
+
+=item ! pattern
+
+Redo last command that started with pattern.
+See C<O recallCommand>, too.
+
+=item !! cmd
+
+Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)
+See C<O shellBang> too.
+
+=item H -number
+
+Display last n commands. Only commands longer than one character are
+listed. If number is omitted, lists them all.
+
+=item q or ^D
+
+Quit. ("quit" doesn't work for this.) This is the only supported way
+to exit the debugger, though typing C<exit> twice may do it too.
+
+Set an C<O>ption C<inhibit_exit> to 0 if you want to be able to I<step
+off> the end the script. You may also need to set C<$finished> to 0 at
+some moment if you want to step through global destruction.
+
+=item R
+
+Restart the debugger by B<exec>ing a new session. It tries to maintain
+your history across this, but internal settings and command line options
+may be lost.
+
+Currently the following setting are preserved: history, breakpoints,
+actions, debugger C<O>ptions, and the following command line
+options: B<-w>, B<-I>, and B<-e>.
+
+=item |dbcmd
+
+Run debugger command, piping DB::OUT to current pager.
+
+=item ||dbcmd
+
+Same as C<|dbcmd> but DB::OUT is temporarily B<select>ed as well.
+Often used with commands that would otherwise produce long
+output, such as
+
+ |V main
+
+=item = [alias value]
+
+Define a command alias, like
+
+ = quit q
+
+or list current aliases.
+
+=item command
+
+Execute command as a Perl statement. A missing semicolon will be
+supplied.
+
+=item m expr
+
+The expression is evaluated, and the methods which may be applied to
+the result are listed.
+
+=item m package
+
+The methods which may be applied to objects in the C<package> are listed.
+
+=back
+
+=head2 Debugger input/output
+
+=over 8
+
+=item Prompt
+
+The debugger prompt is something like
+
+ DB<8>
+
+or even
+
+ DB<<17>>
+
+where that number is the command number, which you'd use to access with
+the builtin B<csh>-like history mechanism, e.g., C<!17> would repeat
+command number 17. The number of angle brackets indicates the depth of
+the debugger. You could get more than one set of brackets, for example, if
+you'd already at a breakpoint and then printed out the result of a
+function call that itself also has a breakpoint, or you step into an
+expression via C<s/n/t expression> command.
+
+=item Multiline commands
+
+If you want to enter a multi-line command, such as a subroutine
+definition with several statements, or a format, you may escape the
+newline that would normally end the debugger command with a backslash.
+Here's an example:
+
+ DB<1> for (1..4) { \
+ cont: print "ok\n"; \
+ cont: }
+ ok
+ ok
+ ok
+ ok
+
+Note that this business of escaping a newline is specific to interactive
+commands typed into the debugger.
+
+=item Stack backtrace
+
+Here's an example of what a stack backtrace via C<T> command might
+look like:
+
+ $ = main::infested called from file `Ambulation.pm' line 10
+ @ = Ambulation::legs(1, 2, 3, 4) called from file `camel_flea' line 7
+ $ = main::pests('bactrian', 4) called from file `camel_flea' line 4
+
+The left-hand character up there tells whether the function was called
+in a scalar or list context (we bet you can tell which is which). What
+that says is that you were in the function C<main::infested> when you ran
+the stack dump, and that it was called in a scalar context from line 10
+of the file I<Ambulation.pm>, but without any arguments at all, meaning
+it was called as C<&infested>. The next stack frame shows that the
+function C<Ambulation::legs> was called in a list context from the
+I<camel_flea> file with four arguments. The last stack frame shows that
+C<main::pests> was called in a scalar context, also from I<camel_flea>,
+but from line 4.
+
+Note that if you execute C<T> command from inside an active C<use>
+statement, the backtrace will contain both C<require>
+frame and an C<eval>) frame.
+
+=item Listing
+
+Listing given via different flavors of C<l> command looks like this:
+
+ DB<<13>> l
+ 101: @i{@i} = ();
+ 102:b @isa{@i,$pack} = ()
+ 103 if(exists $i{$prevpack} || exists $isa{$pack});
+ 104 }
+ 105
+ 106 next
+ 107==> if(exists $isa{$pack});
+ 108
+ 109:a if ($extra-- > 0) {
+ 110: %isa = ($pack,1);
+
+Note that the breakable lines are marked with C<:>, lines with
+breakpoints are marked by C<b>, with actions by C<a>, and the
+next executed line is marked by C<==E<gt>>.
+
+=item Frame listing
+
+When C<frame> option is set, debugger would print entered (and
+optionally exited) subroutines in different styles.
+
+What follows is the start of the listing of
+
+ env "PERLDB_OPTS=f=n N" perl -d -V
+
+for different values of C<n>:
+
+=over 4
+
+=item 1
+
+ entering main::BEGIN
+ entering Config::BEGIN
+ Package lib/Exporter.pm.
+ Package lib/Carp.pm.
+ Package lib/Config.pm.
+ entering Config::TIEHASH
+ entering Exporter::import
+ entering Exporter::export
+ entering Config::myconfig
+ entering Config::FETCH
+ entering Config::FETCH
+ entering Config::FETCH
+ entering Config::FETCH
+
+=item 2
+
+ entering main::BEGIN
+ entering Config::BEGIN
+ Package lib/Exporter.pm.
+ Package lib/Carp.pm.
+ exited Config::BEGIN
+ Package lib/Config.pm.
+ entering Config::TIEHASH
+ exited Config::TIEHASH
+ entering Exporter::import
+ entering Exporter::export
+ exited Exporter::export
+ exited Exporter::import
+ exited main::BEGIN
+ entering Config::myconfig
+ entering Config::FETCH
+ exited Config::FETCH
+ entering Config::FETCH
+ exited Config::FETCH
+ entering Config::FETCH
+
+=item 4
+
+ in $=main::BEGIN() from /dev/nul:0
+ in $=Config::BEGIN() from lib/Config.pm:2
+ Package lib/Exporter.pm.
+ Package lib/Carp.pm.
+ Package lib/Config.pm.
+ in $=Config::TIEHASH('Config') from lib/Config.pm:644
+ in $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0
+ in $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from li
+ in @=Config::myconfig() from /dev/nul:0
+ in $=Config::FETCH(ref(Config), 'package') from lib/Config.pm:574
+ in $=Config::FETCH(ref(Config), 'baserev') from lib/Config.pm:574
+ in $=Config::FETCH(ref(Config), 'PATCHLEVEL') from lib/Config.pm:574
+ in $=Config::FETCH(ref(Config), 'SUBVERSION') from lib/Config.pm:574
+ in $=Config::FETCH(ref(Config), 'osname') from lib/Config.pm:574
+ in $=Config::FETCH(ref(Config), 'osvers') from lib/Config.pm:574
+
+=item 6
+
+ in $=main::BEGIN() from /dev/nul:0
+ in $=Config::BEGIN() from lib/Config.pm:2
+ Package lib/Exporter.pm.
+ Package lib/Carp.pm.
+ out $=Config::BEGIN() from lib/Config.pm:0
+ Package lib/Config.pm.
+ in $=Config::TIEHASH('Config') from lib/Config.pm:644
+ out $=Config::TIEHASH('Config') from lib/Config.pm:644
+ in $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0
+ in $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/
+ out $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/
+ out $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0
+ out $=main::BEGIN() from /dev/nul:0
+ in @=Config::myconfig() from /dev/nul:0
+ in $=Config::FETCH(ref(Config), 'package') from lib/Config.pm:574
+ out $=Config::FETCH(ref(Config), 'package') from lib/Config.pm:574
+ in $=Config::FETCH(ref(Config), 'baserev') from lib/Config.pm:574
+ out $=Config::FETCH(ref(Config), 'baserev') from lib/Config.pm:574
+ in $=Config::FETCH(ref(Config), 'PATCHLEVEL') from lib/Config.pm:574
+ out $=Config::FETCH(ref(Config), 'PATCHLEVEL') from lib/Config.pm:574
+ in $=Config::FETCH(ref(Config), 'SUBVERSION') from lib/Config.pm:574
+
+=item 14
+
+ in $=main::BEGIN() from /dev/nul:0
+ in $=Config::BEGIN() from lib/Config.pm:2
+ Package lib/Exporter.pm.
+ Package lib/Carp.pm.
+ out $=Config::BEGIN() from lib/Config.pm:0
+ Package lib/Config.pm.
+ in $=Config::TIEHASH('Config') from lib/Config.pm:644
+ out $=Config::TIEHASH('Config') from lib/Config.pm:644
+ in $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0
+ in $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/E
+ out $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/E
+ out $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/nul:0
+ out $=main::BEGIN() from /dev/nul:0
+ in @=Config::myconfig() from /dev/nul:0
+ in $=Config::FETCH('Config=HASH(0x1aa444)', 'package') from lib/Config.pm:574
+ out $=Config::FETCH('Config=HASH(0x1aa444)', 'package') from lib/Config.pm:574
+ in $=Config::FETCH('Config=HASH(0x1aa444)', 'baserev') from lib/Config.pm:574
+ out $=Config::FETCH('Config=HASH(0x1aa444)', 'baserev') from lib/Config.pm:574
+
+=item 30
+
+ in $=CODE(0x15eca4)() from /dev/null:0
+ in $=CODE(0x182528)() from lib/Config.pm:2
+ Package lib/Exporter.pm.
+ out $=CODE(0x182528)() from lib/Config.pm:0
+ scalar context return from CODE(0x182528): undef
+ Package lib/Config.pm.
+ in $=Config::TIEHASH('Config') from lib/Config.pm:628
+ out $=Config::TIEHASH('Config') from lib/Config.pm:628
+ scalar context return from Config::TIEHASH: empty hash
+ in $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/null:0
+ in $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/Exporter.pm:171
+ out $=Exporter::export('Config', 'main', 'myconfig', 'config_vars') from lib/Exporter.pm:171
+ scalar context return from Exporter::export: ''
+ out $=Exporter::import('Config', 'myconfig', 'config_vars') from /dev/null:0
+ scalar context return from Exporter::import: ''
+
+
+=back
+
+In all the cases indentation of lines shows the call tree, if bit 2 of
+C<frame> is set, then a line is printed on exit from a subroutine as
+well, if bit 4 is set, then the arguments are printed as well as the
+caller info, if bit 8 is set, the arguments are printed even if they
+are tied or references, if bit 16 is set, the return value is printed
+as well.
+
+When a package is compiled, a line like this
+
+ Package lib/Carp.pm.
+
+is printed with proper indentation.
+
+=back
+
+=head2 Debugging compile-time statements
+
+If you have any compile-time executable statements (code within a BEGIN
+block or a C<use> statement), these will C<NOT> be stopped by debugger,
+although C<require>s will (and compile-time statements can be traced
+with C<AutoTrace> option set in C<PERLDB_OPTS>). From your own Perl
+code, however, you can
+transfer control back to the debugger using the following statement,
+which is harmless if the debugger is not running:
+
+ $DB::single = 1;
+
+If you set C<$DB::single> to the value 2, it's equivalent to having
+just typed the C<n> command, whereas a value of 1 means the C<s>
+command. The C<$DB::trace> variable should be set to 1 to simulate
+having typed the C<t> command.
+
+Another way to debug compile-time code is to start debugger, set a
+breakpoint on I<load> of some module thusly
+
+ DB<7> b load f:/perllib/lib/Carp.pm
+ Will stop on load of `f:/perllib/lib/Carp.pm'.
+
+and restart debugger by C<R> command (if possible). One can use C<b
+compile subname> for the same purpose.
+
+=head2 Debugger Customization
+
+Most probably you do not want to modify the debugger, it contains enough
+hooks to satisfy most needs. You may change the behaviour of debugger
+from the debugger itself, using C<O>ptions, from the command line via
+C<PERLDB_OPTS> environment variable, and from I<customization files>.
+
+You can do some customization by setting up a F<.perldb> file which
+contains initialization code. For instance, you could make aliases
+like these (the last one is one people expect to be there):
+
+ $DB::alias{'len'} = 's/^len(.*)/p length($1)/';
+ $DB::alias{'stop'} = 's/^stop (at|in)/b/';
+ $DB::alias{'ps'} = 's/^ps\b/p scalar /';
+ $DB::alias{'quit'} = 's/^quit(\s*)/exit\$/';
+
+One changes options from F<.perldb> file via calls like this one;
+
+ parse_options("NonStop=1 LineInfo=db.out AutoTrace=1 frame=2");
+
+(the code is executed in the package C<DB>). Note that F<.perldb> is
+processed before processing C<PERLDB_OPTS>. If F<.perldb> defines the
+subroutine C<afterinit>, it is called after all the debugger
+initialization ends. F<.perldb> may be contained in the current
+directory, or in the C<LOGDIR>/C<HOME> directory.
+
+If you want to modify the debugger, copy F<perl5db.pl> from the Perl
+library to another name and modify it as necessary. You'll also want
+to set your C<PERL5DB> environment variable to say something like this:
+
+ BEGIN { require "myperl5db.pl" }
+
+As the last resort, one can use C<PERL5DB> to customize debugger by
+directly setting internal variables or calling debugger functions.
+
+=head2 Readline Support
+
+As shipped, the only command line history supplied is a simplistic one
+that checks for leading exclamation points. However, if you install
+the Term::ReadKey and Term::ReadLine modules from CPAN, you will
+have full editing capabilities much like GNU I<readline>(3) provides.
+Look for these in the F<modules/by-module/Term> directory on CPAN.
+
+A rudimentary command line completion is also available.
+Unfortunately, the names of lexical variables are not available for
+completion.
+
+=head2 Editor Support for Debugging
+
+If you have GNU B<emacs> installed on your system, it can interact with
+the Perl debugger to provide an integrated software development
+environment reminiscent of its interactions with C debuggers.
+
+Perl is also delivered with a start file for making B<emacs> act like a
+syntax-directed editor that understands (some of) Perl's syntax. Look in
+the I<emacs> directory of the Perl source distribution.
+
+(Historically, a similar setup for interacting with B<vi> and the
+X11 window system had also been available, but at the time of this
+writing, no debugger support for B<vi> currently exists.)
+
+=head2 The Perl Profiler
+
+If you wish to supply an alternative debugger for Perl to run, just
+invoke your script with a colon and a package argument given to the B<-d>
+flag. One of the most popular alternative debuggers for Perl is
+B<DProf>, the Perl profiler. As of this writing, B<DProf> is not
+included with the standard Perl distribution, but it is expected to
+be included soon, for certain values of "soon".
+
+Meanwhile, you can fetch the Devel::Dprof module from CPAN. Assuming
+it's properly installed on your system, to profile your Perl program in
+the file F<mycode.pl>, just type:
+
+ perl -d:DProf mycode.pl
+
+When the script terminates the profiler will dump the profile information
+to a file called F<tmon.out>. A tool like B<dprofpp> (also supplied with
+the Devel::DProf package) can be used to interpret the information which is
+in that profile.
+
+=head2 Debugger support in perl
+
+When you call the B<caller> function (see L<perlfunc/caller>) from the
+package DB, Perl sets the array @DB::args to contain the arguments the
+corresponding stack frame was called with.
+
+If perl is run with B<-d> option, the following additional features
+are enabled (cf. L<perlvar/$^P>):
+
+=over
+
+=item *
+
+Perl inserts the contents of C<$ENV{PERL5DB}> (or C<BEGIN {require
+'perl5db.pl'}> if not present) before the first line of the
+application.
+
+=item *
+
+The array C<@{"_E<lt>$filename"}> is the line-by-line contents of
+$filename for all the compiled files. Same for C<eval>ed strings which
+contain subroutines, or which are currently executed. The C<$filename>
+for C<eval>ed strings looks like C<(eval 34)>.
+
+=item *
+
+The hash C<%{"_E<lt>$filename"}> contains breakpoints and action (it is
+keyed by line number), and individual entries are settable (as opposed
+to the whole hash). Only true/false is important to Perl, though the
+values used by F<perl5db.pl> have the form
+C<"$break_condition\0$action">. Values are magical in numeric context:
+they are zeros if the line is not breakable.
+
+Same for evaluated strings which contain subroutines, or which are
+currently executed. The $filename for C<eval>ed strings looks like
+C<(eval 34)>.
+
+=item *
+
+The scalar C<${"_E<lt>$filename"}> contains C<"_E<lt>$filename">. Same for
+evaluated strings which contain subroutines, or which are currently
+executed. The $filename for C<eval>ed strings looks like C<(eval
+34)>.
+
+=item *
+
+After each C<require>d file is compiled, but before it is executed,
+C<DB::postponed(*{"_E<lt>$filename"})> is called (if subroutine
+C<DB::postponed> exists). Here the $filename is the expanded name of
+the C<require>d file (as found in values of %INC).
+
+=item *
+
+After each subroutine C<subname> is compiled existence of
+C<$DB::postponed{subname}> is checked. If this key exists,
+C<DB::postponed(subname)> is called (if subroutine C<DB::postponed>
+exists).
+
+=item *
+
+A hash C<%DB::sub> is maintained, with keys being subroutine names,
+values having the form C<filename:startline-endline>. C<filename> has
+the form C<(eval 31)> for subroutines defined inside C<eval>s.
+
+=item *
+
+When execution of the application reaches a place that can have
+a breakpoint, a call to C<DB::DB()> is performed if any one of
+variables $DB::trace, $DB::single, or $DB::signal is true. (Note that
+these variables are not C<local>izable.) This feature is disabled when
+the control is inside C<DB::DB()> or functions called from it (unless
+C<$^D & (1E<lt>E<lt>30)>).
+
+=item *
+
+When execution of the application reaches a subroutine call, a call
+to C<&DB::sub>(I<args>) is performed instead, with C<$DB::sub> being
+the name of the called subroutine. (Unless the subroutine is compiled
+in the package C<DB>.)
+
+=back
+
+Note that if C<&DB::sub> needs some external data to be setup for it
+to work, no subroutine call is possible until this is done. For the
+standard debugger C<$DB::deep> (how many levels of recursion deep into
+the debugger you can go before a mandatory break) gives an example of
+such a dependency.
+
+The minimal working debugger consists of one line
+
+ sub DB::DB {}
+
+which is quite handy as contents of C<PERL5DB> environment
+variable:
+
+ env "PERL5DB=sub DB::DB {}" perl -d your-script
+
+Another (a little bit more useful) minimal debugger can be created
+with the only line being
+
+ sub DB::DB {print ++$i; scalar <STDIN>}
+
+This debugger would print the sequential number of encountered
+statement, and would wait for your C<CR> to continue.
+
+The following debugger is quite functional:
+
+ {
+ package DB;
+ sub DB {}
+ sub sub {print ++$i, " $sub\n"; &$sub}
+ }
+
+It prints the sequential number of subroutine call and the name of the
+called subroutine. Note that C<&DB::sub> should be compiled into the
+package C<DB>.
+
+=head2 Debugger Internals
+
+At the start, the debugger reads your rc file (F<./.perldb> or
+F<~/.perldb> under Unix), which can set important options. This file may
+define a subroutine C<&afterinit> to be executed after the debugger is
+initialized.
+
+After the rc file is read, the debugger reads environment variable
+PERLDB_OPTS and parses it as a rest of C<O ...> line in debugger prompt.
+
+It also maintains magical internal variables, such as C<@DB::dbline>,
+C<%DB::dbline>, which are aliases for C<@{"::_<current_file"}>
+C<%{"::_<current_file"}>. Here C<current_file> is the currently
+selected (with the debugger's C<f> command, or by flow of execution)
+file.
+
+Some functions are provided to simplify customization. See L<"Debugger
+Customization"> for description of C<DB::parse_options(string)>. The
+function C<DB::dump_trace(skip[, count])> skips the specified number
+of frames, and returns a list containing info about the caller
+frames (all if C<count> is missing). Each entry is a hash with keys
+C<context> (C<$> or C<@>), C<sub> (subroutine name, or info about
+eval), C<args> (C<undef> or a reference to an array), C<file>, and
+C<line>.
+
+The function C<DB::print_trace(FH, skip[, count[, short]])> prints
+formatted info about caller frames. The last two functions may be
+convenient as arguments to C<E<lt>>, C<E<lt>E<lt>> commands.
+
+=head2 Other resources
+
+You did try the B<-w> switch, didn't you?
+
+=head2 BUGS
+
+You cannot get the stack frame information or otherwise debug functions
+that were not compiled by Perl, such as C or C++ extensions.
+
+If you alter your @_ arguments in a subroutine (such as with B<shift>
+or B<pop>, the stack backtrace will not show the original values.
+
+=head1 Debugging Perl memory usage
+
+Perl is I<very> frivolous with memory. There is a saying that to
+estimate memory usage of Perl, assume a reasonable algorithm of
+allocation, and multiply your estimages by 10. This is not absolutely
+true, but may give you a good grasp of what happens.
+
+Say, an integer cannot take less than 20 bytes of memory, a float
+cannot take less than 24 bytes, a string cannot take less than 32
+bytes (all these examples assume 32-bit architectures, the result are
+much worse on 64-bit architectures). If a variable is accessed in two
+of three different ways (which require an integer, a float, or a
+string), the memory footprint may increase by another 20 bytes. A
+sloppy malloc() implementation will make these numbers yet more.
+
+On the opposite end of the scale, a declaration like
+
+ sub foo;
+
+may take (on some versions of perl) up to 500 bytes of memory.
+
+Off-the-cuff anecdotal estimates of a code bloat give a factor around
+8. This means that the compiled form of reasonable (commented
+indented etc.) code will take approximately 8 times more than the
+disk space the code takes.
+
+There are two Perl-specific ways to analyze the memory usage:
+$ENV{PERL_DEBUG_MSTATS} and B<-DL> switch. First one is available
+only if perl is compiled with Perl's malloc(), the second one only if
+Perl compiled with C<-DDEBUGGING> (as with giving C<-D optimise=-g>
+option to F<Configure>).
+
+=head2 Using C<$ENV{PERL_DEBUG_MSTATS}>
+
+If your perl is using Perl's malloc(), and compiled with correct
+switches (this is the default), then it will print memory usage
+statistics after compiling your code (if C<$ENV{PERL_DEBUG_MSTATS}> >
+1), and before termination of the script (if
+C<$ENV{PERL_DEBUG_MSTATS}> >= 1). The report format is similar to one
+in the following example:
+
+ env PERL_DEBUG_MSTATS=2 perl -e "require Carp"
+ Memory allocation statistics after compilation: (buckets 4(4)..8188(8192)
+ 14216 free: 130 117 28 7 9 0 2 2 1 0 0
+ 437 61 36 0 5
+ 60924 used: 125 137 161 55 7 8 6 16 2 0 1
+ 74 109 304 84 20
+ Total sbrk(): 77824/21:119. Odd ends: pad+heads+chain+tail: 0+636+0+2048.
+ Memory allocation statistics after execution: (buckets 4(4)..8188(8192)
+ 30888 free: 245 78 85 13 6 2 1 3 2 0 1
+ 315 162 39 42 11
+ 175816 used: 265 176 1112 111 26 22 11 27 2 1 1
+ 196 178 1066 798 39
+ Total sbrk(): 215040/47:145. Odd ends: pad+heads+chain+tail: 0+2192+0+6144.
+
+It is possible to ask for such a statistic at arbitrary moment by
+usind Devel::Peek::mstats() (module Devel::Peek is available on CPAN).
+
+Here is the explanation of different parts of the format:
+
+=over
+
+=item C<buckets SMALLEST(APPROX)..GREATEST(APPROX)>
+
+Perl's malloc() uses bucketed allocations. Every request is rounded
+up to the closest bucket size available, and a bucket of these size is
+taken from the pool of the buckets of this size.
+
+The above line describes limits of buckets currently in use. Each
+bucket has two sizes: memory footprint, and the maximal size of user
+data which may be put into this bucket. Say, in the above example the
+smallest bucket is both sizes 4. The biggest bucket has usable size
+8188, and the memory footprint 8192.
+
+With debugging Perl some buckets may have negative usable size. This
+means that these buckets cannot (and will not) be used. For greater
+buckets the memory footprint may be one page greater than a power of
+2. In such a case the corresponding power of two is printed instead
+in the C<APPROX> field above.
+
+=item Free/Used
+
+The following 1 or 2 rows of numbers correspond to the number of
+buckets of each size between C<SMALLEST> and C<GREATEST>. In the
+first row the sizes (memory footprints) of buckets are powers of two
+(or possibly one page greater). In the second row (if present) the
+memory footprints of the buckets are between memory footprints of two
+buckets "above".
+
+Say, with the above example the memory footprints are (with current
+algorith)
+
+ free: 8 16 32 64 128 256 512 1024 2048 4096 8192
+ 4 12 24 48 80
+
+With non-C<DEBUGGING> perl the buckets starting from C<128>-long ones
+have 4-byte overhead, thus 8192-long bucket may take up to
+8188-byte-long allocations.
+
+=item C<Total sbrk(): SBRKed/SBRKs:CONTINUOUS>
+
+The first two fields give the total amount of memory perl sbrk()ed,
+and number of sbrk()s used. The third number is what perl thinks
+about continuity of returned chunks. As far as this number is
+positive, malloc() will assume that it is probable that sbrk() will
+provide continuous memory.
+
+The amounts sbrk()ed by external libraries is not counted.
+
+=item C<pad: 0>
+
+The amount of sbrk()ed memory needed to keep buckets aligned.
+
+=item C<heads: 2192>
+
+While memory overhead of bigger buckets is kept inside the bucket, for
+smaller buckets it is kept in separate areas. This field gives the
+total size of these areas.
+
+=item C<chain: 0>
+
+malloc() may want to subdivide a bigger bucket into smaller buckets.
+If only a part of the deceased-bucket is left non-subdivided, the rest
+is kept as an element of a linked list. This field gives the total
+size of these chunks.
+
+=item C<tail: 6144>
+
+To minimize amount of sbrk()s malloc() asks for more memory. This
+field gives the size of the yet-unused part, which is sbrk()ed, but
+never touched.
+
+=back
+
+=head2 Example of using B<-DL> switch
+
+Below we show how to analyse memory usage by
+
+ do 'lib/auto/POSIX/autosplit.ix';
+
+The file in question contains a header and 146 lines similar to
+
+ sub getcwd ;
+
+B<Note:> I<the discussion below supposes 32-bit architecture. In the
+newer versions of perl the memory usage of the constructs discussed
+here is much improved, but the story discussed below is a real-life
+story. This story is very terse, and assumes more than cursory
+knowledge of Perl internals.>
+
+Here is the itemized list of Perl allocations performed during parsing
+of this file:
+
+ !!! "after" at test.pl line 3.
+ Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+
+ 0 02 13752 . . . . 294 . . . . . . . . . . 4
+ 0 54 5545 . . 8 124 16 . . . 1 1 . . . . . 3
+ 5 05 32 . . . . . . . 1 . . . . . . . .
+ 6 02 7152 . . . . . . . . . . 149 . . . . .
+ 7 02 3600 . . . . . 150 . . . . . . . . . .
+ 7 03 64 . -1 . 1 . . 2 . . . . . . . . .
+ 7 04 7056 . . . . . . . . . . . . . . . 7
+ 7 17 38404 . . . . . . . 1 . . 442 149 . . 147 .
+ 9 03 2078 17 249 32 . . . . 2 . . . . . . . .
+
+
+To see this list insert two C<warn('!...')> statements around the call:
+
+ warn('!');
+ do 'lib/auto/POSIX/autosplit.ix';
+ warn('!!! "after"');
+
+and run it with B<-DL> option. The first warn() will print memory
+allocation info before the parsing of the file, and will memorize the
+statistics at this point (we ignore what it prints). The second warn()
+will print increments w.r.t. this memorized statistics. This is the
+above printout.
+
+Different I<Id>s on the left correspond to different subsystems of
+perl interpreter, they are just first argument given to perl memory
+allocation API New(). To find what C<9 03> means C<grep> the perl
+source for C<903>. You will see that it is F<util.c>, function
+savepvn(). This function is used to store a copy of existing chunk of
+memory. Using C debugger, one can see that it is called either
+directly from gv_init(), or via sv_magic(), and gv_init() is called
+from gv_fetchpv() - which is called from newSUB().
+
+B<Note:> to reach this place in debugger and skip all the calls to
+savepvn during the compilation of the main script, set a C breakpoint
+in Perl_warn(), C<continue> this point is reached, I<then> set
+breakpoint in Perl_savepvn(). Note that you may need to skip a
+handful of Perl_savepvn() which do not correspond to mass production
+of CVs (there are more C<903> allocations than 146 similar lines of
+F<lib/auto/POSIX/autosplit.ix>). Note also that C<Perl_> prefixes are
+added by macroization code in perl header files to avoid conflicts
+with external libraries.
+
+Anyway, we see that C<903> ids correspond to creation of globs, twice
+per glob - for glob name, and glob stringification magic.
+
+Here are explanations for other I<Id>s above:
+
+=over
+
+=item C<717>
+
+is for creation of bigger C<XPV*> structures. In the above case it
+creates 3 C<AV> per subroutine, one for a list of lexical variable
+names, one for a scratchpad (which contains lexical variables and
+C<targets>), and one for the array of scratchpads needed for
+recursion.
+
+It also creates a C<GV> and a C<CV> per subroutine (all called from
+start_subparse()).
+
+=item C<002>
+
+Creates C array corresponding to the C<AV> of scratchpads, and the
+scratchpad itself (the first fake entry of this scratchpad is created
+though the subroutine itself is not defined yet).
+
+It also creates C arrays to keep data for the stash (this is one HV,
+but it grows, thus there are 4 big allocations: the big chunks are not
+freeed, but are kept as additional arenas for C<SV> allocations).
+
+=item C<054>
+
+creates a C<HEK> for the name of the glob for the subroutine (this
+name is a key in a I<stash>).
+
+Big allocations with this I<Id> correspond to allocations of new
+arenas to keep C<HE>.
+
+=item C<602>
+
+creates a C<GP> for the glob for the subroutine.
+
+=item C<702>
+
+creates the C<MAGIC> for the glob for the subroutine.
+
+=item C<704>
+
+creates I<arenas> which keep SVs.
+
+=back
+
+=head2 B<-DL> details
+
+If Perl is run with B<-DL> option, then warn()s which start with `!'
+behave specially. They print a list of I<categories> of memory
+allocations, and statistics of allocations of different sizes for
+these categories.
+
+If warn() string starts with
+
+=over
+
+=item C<!!!>
+
+print changed categories only, print the differences in counts of allocations;
+
+=item C<!!>
+
+print grown categories only; print the absolute values of counts, and totals;
+
+=item C<!>
+
+print nonempty categories, print the absolute values of counts and totals.
+
+=back
+
+=head2 Limitations of B<-DL> statistic
+
+If an extension or an external library does not use Perl API to
+allocate memory, these allocations are not counted.
+
+=head1 Debugging regular expressions
+
+There are two ways to enable debugging output for regular expressions.
+
+If your perl is compiled with C<-DDEBUGGING>, you may use the
+B<-Dr> flag on the command line.
+
+Otherwise, one can C<use re 'debug'>, which has effects both at
+compile time, and at run time (and is I<not> lexically scoped).
+
+=head2 Compile-time output
+
+The debugging output for the compile time looks like this:
+
+ compiling RE `[bc]d(ef*g)+h[ij]k$'
+ size 43 first at 1
+ 1: ANYOF(11)
+ 11: EXACT <d>(13)
+ 13: CURLYX {1,32767}(27)
+ 15: OPEN1(17)
+ 17: EXACT <e>(19)
+ 19: STAR(22)
+ 20: EXACT <f>(0)
+ 22: EXACT <g>(24)
+ 24: CLOSE1(26)
+ 26: WHILEM(0)
+ 27: NOTHING(28)
+ 28: EXACT <h>(30)
+ 30: ANYOF(40)
+ 40: EXACT <k>(42)
+ 42: EOL(43)
+ 43: END(0)
+ anchored `de' at 1 floating `gh' at 3..2147483647 (checking floating)
+ stclass `ANYOF' minlen 7
+
+The first line shows the pre-compiled form of the regexp, and the
+second shows the size of the compiled form (in arbitrary units,
+usually 4-byte words) and the label I<id> of the first node which
+does a match.
+
+The last line (split into two lines in the above) contains the optimizer
+info. In the example shown, the optimizer found that the match
+should contain a substring C<de> at the offset 1, and substring C<gh>
+at some offset between 3 and infinity. Moreover, when checking for
+these substrings (to abandon impossible matches quickly) it will check
+for the substring C<gh> before checking for the substring C<de>. The
+optimizer may also use the knowledge that the match starts (at the
+C<first> I<id>) with a character class, and the match cannot be
+shorter than 7 chars.
+
+The fields of interest which may appear in the last line are
+
+=over
+
+=item C<anchored> I<STRING> C<at> I<POS>
+
+=item C<floating> I<STRING> C<at> I<POS1..POS2>
+
+see above;
+
+=item C<matching floating/anchored>
+
+which substring to check first;
+
+=item C<minlen>
+
+the minimal length of the match;
+
+=item C<stclass> I<TYPE>
+
+The type of the first matching node.
+
+=item C<noscan>
+
+which advises to not scan for the found substrings;
+
+=item C<isall>
+
+which says that the optimizer info is in fact all that the regular
+expression contains (thus one does not need to enter the RE engine at
+all);
+
+=item C<GPOS>
+
+if the pattern contains C<\G>;
+
+=item C<plus>
+
+if the pattern starts with a repeated char (as in C<x+y>);
+
+=item C<implicit>
+
+if the pattern starts with C<.*>;
+
+=item C<with eval>
+
+if the pattern contain eval-groups (see L<perlre/(?{ code })>);
+
+=item C<anchored(TYPE)>
+
+if the pattern may
+match only at a handful of places (with C<TYPE> being
+C<BOL>, C<MBOL>, or C<GPOS>, see the table below).
+
+=back
+
+If a substring is known to match at end-of-line only, it may be
+followed by C<$>, as in C<floating `k'$>.
+
+The optimizer-specific info is used to avoid entering (a slow) RE
+engine on strings which will definitely not match. If C<isall> flag
+is set, a call to the RE engine may be avoided even when optimizer
+found an appropriate place for the match.
+
+The rest of the output contains the list of I<nodes> of the compiled
+form of the RE. Each line has format
+
+C< >I<id>: I<TYPE> I<OPTIONAL-INFO> (I<next-id>)
+
+=head2 Types of nodes
+
+Here is the list of possible types with short descriptions:
+
+ # TYPE arg-description [num-args] [longjump-len] DESCRIPTION
+
+ # Exit points
+ END no End of program.
+ SUCCEED no Return from a subroutine, basically.
+
+ # Anchors:
+ BOL no Match "" at beginning of line.
+ MBOL no Same, assuming multiline.
+ SBOL no Same, assuming singleline.
+ EOS no Match "" at end of string.
+ EOL no Match "" at end of line.
+ MEOL no Same, assuming multiline.
+ SEOL no Same, assuming singleline.
+ BOUND no Match "" at any word boundary
+ BOUNDL no Match "" at any word boundary
+ NBOUND no Match "" at any word non-boundary
+ NBOUNDL no Match "" at any word non-boundary
+ GPOS no Matches where last m//g left off.
+
+ # [Special] alternatives
+ ANY no Match any one character (except newline).
+ SANY no Match any one character.
+ ANYOF sv Match character in (or not in) this class.
+ ALNUM no Match any alphanumeric character
+ ALNUML no Match any alphanumeric char in locale
+ NALNUM no Match any non-alphanumeric character
+ NALNUML no Match any non-alphanumeric char in locale
+ SPACE no Match any whitespace character
+ SPACEL no Match any whitespace char in locale
+ NSPACE no Match any non-whitespace character
+ NSPACEL no Match any non-whitespace char in locale
+ DIGIT no Match any numeric character
+ NDIGIT no Match any non-numeric character
+
+ # BRANCH The set of branches constituting a single choice are hooked
+ # together with their "next" pointers, since precedence prevents
+ # anything being concatenated to any individual branch. The
+ # "next" pointer of the last BRANCH in a choice points to the
+ # thing following the whole choice. This is also where the
+ # final "next" pointer of each individual branch points; each
+ # branch starts with the operand node of a BRANCH node.
+ #
+ BRANCH node Match this alternative, or the next...
+
+ # BACK Normal "next" pointers all implicitly point forward; BACK
+ # exists to make loop structures possible.
+ # not used
+ BACK no Match "", "next" ptr points backward.
+
+ # Literals
+ EXACT sv Match this string (preceded by length).
+ EXACTF sv Match this string, folded (prec. by length).
+ EXACTFL sv Match this string, folded in locale (w/len).
+
+ # Do nothing
+ NOTHING no Match empty string.
+ # A variant of above which delimits a group, thus stops optimizations
+ TAIL no Match empty string. Can jump here from outside.
+
+ # STAR,PLUS '?', and complex '*' and '+', are implemented as circular
+ # BRANCH structures using BACK. Simple cases (one character
+ # per match) are implemented with STAR and PLUS for speed
+ # and to minimize recursive plunges.
+ #
+ STAR node Match this (simple) thing 0 or more times.
+ PLUS node Match this (simple) thing 1 or more times.
+
+ CURLY sv 2 Match this simple thing {n,m} times.
+ CURLYN no 2 Match next-after-this simple thing
+ # {n,m} times, set parenths.
+ CURLYM no 2 Match this medium-complex thing {n,m} times.
+ CURLYX sv 2 Match this complex thing {n,m} times.
+
+ # This terminator creates a loop structure for CURLYX
+ WHILEM no Do curly processing and see if rest matches.
+
+ # OPEN,CLOSE,GROUPP ...are numbered at compile time.
+ OPEN num 1 Mark this point in input as start of #n.
+ CLOSE num 1 Analogous to OPEN.
+
+ REF num 1 Match some already matched string
+ REFF num 1 Match already matched string, folded
+ REFFL num 1 Match already matched string, folded in loc.
+
+ # grouping assertions
+ IFMATCH off 1 2 Succeeds if the following matches.
+ UNLESSM off 1 2 Fails if the following matches.
+ SUSPEND off 1 1 "Independent" sub-RE.
+ IFTHEN off 1 1 Switch, should be preceeded by switcher .
+ GROUPP num 1 Whether the group matched.
+
+ # Support for long RE
+ LONGJMP off 1 1 Jump far away.
+ BRANCHJ off 1 1 BRANCH with long offset.
+
+ # The heavy worker
+ EVAL evl 1 Execute some Perl code.
+
+ # Modifiers
+ MINMOD no Next operator is not greedy.
+ LOGICAL no Next opcode should set the flag only.
+
+ # This is not used yet
+ RENUM off 1 1 Group with independently numbered parens.
+
+ # This is not really a node, but an optimized away piece of a "long" node.
+ # To simplify debugging output, we mark it as if it were a node
+ OPTIMIZED off Placeholder for dump.
+
+=head2 Run-time output
+
+First of all, when doing a match, one may get no run-time output even
+if debugging is enabled. this means that the RE engine was never
+entered, all of the job was done by the optimizer.
+
+If RE engine was entered, the output may look like this:
+
+ Matching `[bc]d(ef*g)+h[ij]k$' against `abcdefg__gh__'
+ Setting an EVAL scope, savestack=3
+ 2 <ab> <cdefg__gh_> | 1: ANYOF
+ 3 <abc> <defg__gh_> | 11: EXACT <d>
+ 4 <abcd> <efg__gh_> | 13: CURLYX {1,32767}
+ 4 <abcd> <efg__gh_> | 26: WHILEM
+ 0 out of 1..32767 cc=effff31c
+ 4 <abcd> <efg__gh_> | 15: OPEN1
+ 4 <abcd> <efg__gh_> | 17: EXACT <e>
+ 5 <abcde> <fg__gh_> | 19: STAR
+ EXACT <f> can match 1 times out of 32767...
+ Setting an EVAL scope, savestack=3
+ 6 <bcdef> <g__gh__> | 22: EXACT <g>
+ 7 <bcdefg> <__gh__> | 24: CLOSE1
+ 7 <bcdefg> <__gh__> | 26: WHILEM
+ 1 out of 1..32767 cc=effff31c
+ Setting an EVAL scope, savestack=12
+ 7 <bcdefg> <__gh__> | 15: OPEN1
+ 7 <bcdefg> <__gh__> | 17: EXACT <e>
+ restoring \1 to 4(4)..7
+ failed, try continuation...
+ 7 <bcdefg> <__gh__> | 27: NOTHING
+ 7 <bcdefg> <__gh__> | 28: EXACT <h>
+ failed...
+ failed...
+
+The most significant information in the output is about the particular I<node>
+of the compiled RE which is currently being tested against the target string.
+The format of these lines is
+
+C< >I<STRING-OFFSET> <I<PRE-STRING>> <I<POST-STRING>> |I<ID>: I<TYPE>
+
+The I<TYPE> info is indented with respect to the backtracking level.
+Other incidental information appears interspersed within.
+
+=cut
diff --git a/contrib/perl5/pod/perldelta.pod b/contrib/perl5/pod/perldelta.pod
new file mode 100644
index 000000000000..a3c6b6cc057a
--- /dev/null
+++ b/contrib/perl5/pod/perldelta.pod
@@ -0,0 +1,919 @@
+=head1 NAME
+
+perldelta - what's new for perl5.005
+
+=head1 DESCRIPTION
+
+This document describes differences between the 5.004 release and this one.
+
+=head1 About the new versioning system
+
+Perl is now developed on two tracks: a maintenance track that makes
+small, safe updates to released production versions with emphasis on
+compatibility; and a development track that pursues more aggressive
+evolution. Maintenance releases (which should be considered production
+quality) have subversion numbers that run from C<1> to C<49>, and
+development releases (which should be considered "alpha" quality) run
+from C<50> to C<99>.
+
+Perl 5.005 is the combined product of the new dual-track development
+scheme.
+
+=head1 Incompatible Changes
+
+=head2 WARNING: This version is not binary compatible with Perl 5.004.
+
+Starting with Perl 5.004_50 there were many deep and far-reaching changes
+to the language internals. If you have dynamically loaded extensions
+that you built under perl 5.003 or 5.004, you can continue to use them
+with 5.004, but you will need to rebuild and reinstall those extensions
+to use them 5.005. See L<INSTALL> for detailed instructions on how to
+upgrade.
+
+=head2 Default installation structure has changed
+
+The new Configure defaults are designed to allow a smooth upgrade from
+5.004 to 5.005, but you should read L<INSTALL> for a detailed
+discussion of the changes in order to adapt them to your system.
+
+=head2 Perl Source Compatibility
+
+When none of the experimental features are enabled, there should be
+very few user-visible Perl source compatibility issues.
+
+If threads are enabled, then some caveats apply. C<@_> and C<$_> become
+lexical variables. The effect of this should be largely transparent to
+the user, but there are some boundary conditions under which user will
+need to be aware of the issues. For example, C<local(@_)> results in
+a "Can't localize lexical variable @_ ..." message. This may be enabled
+in a future version.
+
+Some new keywords have been introduced. These are generally expected to
+have very little impact on compatibility. See L<New C<INIT> keyword>,
+L<New C<lock> keyword>, and L<New C<qr//> operator>.
+
+Certain barewords are now reserved. Use of these will provoke a warning
+if you have asked for them with the C<-w> switch.
+See L<C<our> is now a reserved word>.
+
+=head2 C Source Compatibility
+
+There have been a large number of changes in the internals to support
+the new features in this release.
+
+=over 4
+
+=item Core sources now require ANSI C compiler
+
+An ANSI C compiler is now B<required> to build perl. See F<INSTALL>.
+
+=item All Perl global variables must now be referenced with an explicit prefix
+
+All Perl global variables that are visible for use by extensions now
+have a C<PL_> prefix. New extensions should C<not> refer to perl globals
+by their unqualified names. To preserve sanity, we provide limited
+backward compatibility for globals that are being widely used like
+C<sv_undef> and C<na> (which should now be written as C<PL_sv_undef>,
+C<PL_na> etc.)
+
+If you find that your XS extension does not compile anymore because a
+perl global is not visible, try adding a C<PL_> prefix to the global
+and rebuild.
+
+It is strongly recommended that all functions in the Perl API that don't
+begin with C<perl> be referenced with a C<Perl_> prefix. The bare function
+names without the C<Perl_> prefix are supported with macros, but this
+support may cease in a future release.
+
+See L<perlguts/API LISTING>.
+
+=item Enabling threads has source compatibility issues
+
+Perl built with threading enabled requires extensions to use the new
+C<dTHR> macro to initialize the handle to access per-thread data.
+If you see a compiler error that talks about the variable C<thr> not
+being declared (when building a module that has XS code), you need
+to add C<dTHR;> at the beginning of the block that elicited the error.
+
+The API function C<perl_get_sv("@",FALSE)> should be used instead of
+directly accessing perl globals as C<GvSV(errgv)>. The API call is
+backward compatible with existing perls and provides source compatibility
+with threading is enabled.
+
+See L<API Changes for more information>.
+
+=back
+
+=head2 Binary Compatibility
+
+This version is NOT binary compatible with older versions. All extensions
+will need to be recompiled. Further binaries built with threads enabled
+are incompatible with binaries built without. This should largely be
+transparent to the user, as all binary incompatible configurations have
+their own unique architecture name, and extension binaries get installed at
+unique locations. This allows coexistence of several configurations in
+the same directory hierarchy. See F<INSTALL>.
+
+=head2 Security fixes may affect compatibility
+
+A few taint leaks and taint omissions have been corrected. This may lead
+to "failure" of scripts that used to work with older versions. Compiling
+with -DINCOMPLETE_TAINTS provides a perl with minimal amounts of changes
+to the tainting behavior. But note that the resulting perl will have
+known insecurities.
+
+Oneliners with the C<-e> switch do not create temporary files anymore.
+
+=head2 Relaxed new mandatory warnings introduced in 5.004
+
+Many new warnings that were introduced in 5.004 have been made
+optional. Some of these warnings are still present, but perl's new
+features make them less often a problem. See L<New Diagnostics>.
+
+=head2 Licensing
+
+Perl has a new Social Contract for contributors. See F<Porting/Contract>.
+
+The license included in much of the Perl documentation has changed.
+Most of the Perl documentation was previously under the implicit GNU
+General Public License or the Artistic License (at the user's choice).
+Now much of the documentation unambigously states the terms under which
+it may be distributed. Those terms are in general much less restrictive
+than the GNU GPL. See L<perl> and the individual perl man pages listed
+therein.
+
+=head1 Core Changes
+
+
+=head2 Threads
+
+WARNING: Threading is considered an B<experimental> feature. Details of the
+implementation may change without notice. There are known limitations
+and some bugs. These are expected to be fixed in future versions.
+
+See L<README.threads>.
+
+=head2 Compiler
+
+WARNING: The Compiler and related tools are considered B<experimental>.
+Features may change without notice, and there are known limitations
+and bugs. Since the compiler is fully external to perl, the default
+configuration will build and install it.
+
+The Compiler produces three different types of transformations of a
+perl program. The C backend generates C code that captures perl's state
+just before execution begins. It eliminates the compile-time overheads
+of the regular perl interpreter, but the run-time performance remains
+comparatively the same. The CC backend generates optimized C code
+equivalent to the code path at run-time. The CC backend has greater
+potential for big optimizations, but only a few optimizations are
+implemented currently. The Bytecode backend generates a platform
+independent bytecode representation of the interpreter's state
+just before execution. Thus, the Bytecode back end also eliminates
+much of the compilation overhead of the interpreter.
+
+The compiler comes with several valuable utilities.
+
+C<B::Lint> is an experimental module to detect and warn about suspicious
+code, especially the cases that the C<-w> switch does not detect.
+
+C<B::Deparse> can be used to demystify perl code, and understand
+how perl optimizes certain constructs.
+
+C<B::Xref> generates cross reference reports of all definition and use
+of variables, subroutines and formats in a program.
+
+C<B::Showlex> show the lexical variables used by a subroutine or file
+at a glance.
+
+C<perlcc> is a simple frontend for compiling perl.
+
+See C<ext/B/README>, L<B>, and the respective compiler modules.
+
+=head2 Regular Expressions
+
+Perl's regular expression engine has been seriously overhauled, and
+many new constructs are supported. Several bugs have been fixed.
+
+Here is an itemized summary:
+
+=over 4
+
+=item Many new and improved optimizations
+
+Changes in the RE engine:
+
+ Unneeded nodes removed;
+ Substrings merged together;
+ New types of nodes to process (SUBEXPR)* and similar expressions
+ quickly, used if the SUBEXPR has no side effects and matches
+ strings of the same length;
+ Better optimizations by lookup for constant substrings;
+ Better search for constants substrings anchored by $ ;
+
+Changes in Perl code using RE engine:
+
+ More optimizations to s/longer/short/;
+ study() was not working;
+ /blah/ may be optimized to an analogue of index() if $& $` $' not seen;
+ Unneeded copying of matched-against string removed;
+ Only matched part of the string is copying if $` $' were not seen;
+
+=item Many bug fixes
+
+Note that only the major bug fixes are listed here. See F<Changes> for others.
+
+ Backtracking might not restore start of $3.
+ No feedback if max count for * or + on "complex" subexpression
+ was reached, similarly (but at compile time) for {3,34567}
+ Primitive restrictions on max count introduced to decrease a
+ possibility of a segfault;
+ (ZERO-LENGTH)* could segfault;
+ (ZERO-LENGTH)* was prohibited;
+ Long REs were not allowed;
+ /RE/g could skip matches at the same position after a
+ zero-length match;
+
+=item New regular expression constructs
+
+The following new syntax elements are supported:
+
+ (?<=RE)
+ (?<!RE)
+ (?{ CODE })
+ (?i-x)
+ (?i:RE)
+ (?(COND)YES_RE|NO_RE)
+ (?>RE)
+ \z
+
+=item New operator for precompiled regular expressions
+
+See L<New C<qr//> operator>.
+
+=item Other improvements
+
+ Better debugging output (possibly with colors),
+ even from non-debugging Perl;
+ RE engine code now looks like C, not like assembler;
+ Behaviour of RE modifiable by `use re' directive;
+ Improved documentation;
+ Test suite significantly extended;
+ Syntax [:^upper:] etc., reserved inside character classes;
+
+=item Incompatible changes
+
+ (?i) localized inside enclosing group;
+ $( is not interpolated into RE any more;
+ /RE/g may match at the same position (with non-zero length)
+ after a zero-length match (bug fix).
+
+=back
+
+See L<perlre> and L<perlop>.
+
+=head2 Improved malloc()
+
+See banner at the beginning of C<malloc.c> for details.
+
+=head2 Quicksort is internally implemented
+
+Perl now contains its own highly optimized qsort() routine. The new qsort()
+is resistant to inconsistent comparison functions, so Perl's C<sort()> will
+not provoke coredumps any more when given poorly written sort subroutines.
+(Some C library C<qsort()>s that were being used before used to have this
+problem.) In our testing, the new C<qsort()> required the minimal number
+of pair-wise compares on average, among all known C<qsort()> implementations.
+
+See C<perlfunc/sort>.
+
+=head2 Reliable signals
+
+Perl's signal handling is susceptible to random crashes, because signals
+arrive asynchronously, and the Perl runtime is not reentrant at arbitrary
+times.
+
+However, one experimental implementation of reliable signals is available
+when threads are enabled. See C<Thread::Signal>. Also see F<INSTALL> for
+how to build a Perl capable of threads.
+
+=head2 Reliable stack pointers
+
+The internals now reallocate the perl stack only at predictable times.
+In particular, magic calls never trigger reallocations of the stack,
+because all reentrancy of the runtime is handled using a "stack of stacks".
+This should improve reliability of cached stack pointers in the internals
+and in XSUBs.
+
+=head2 More generous treatment of carriage returns
+
+Perl used to complain if it encountered literal carriage returns in
+scripts. Now they are mostly treated like whitespace within program text.
+Inside string literals and here documents, literal carriage returns are
+ignored if they occur paired with newlines, or get interpreted as newlines
+if they stand alone. This behavior means that literal carriage returns
+in files should be avoided. You can get the older, more compatible (but
+less generous) behavior by defining the preprocessor symbol
+C<PERL_STRICT_CR> when building perl. Of course, all this has nothing
+whatever to do with how escapes like C<\r> are handled within strings.
+
+Note that this doesn't somehow magically allow you to keep all text files
+in DOS format. The generous treatment only applies to files that perl
+itself parses. If your C compiler doesn't allow carriage returns in
+files, you may still be unable to build modules that need a C compiler.
+
+=head2 Memory leaks
+
+C<substr>, C<pos> and C<vec> don't leak memory anymore when used in lvalue
+context. Many small leaks that impacted applications that embed multiple
+interpreters have been fixed.
+
+=head2 Better support for multiple interpreters
+
+The build-time option C<-DMULTIPLICITY> has had many of the details
+reworked. Some previously global variables that should have been
+per-interpreter now are. With care, this allows interpreters to call
+each other. See the C<PerlInterp> extension on CPAN.
+
+=head2 Behavior of local() on array and hash elements is now well-defined
+
+See L<perlsub/"Temporary Values via local()">.
+
+=head2 C<%!> is transparently tied to the L<Errno> module
+
+See L<perlvar>, and L<Errno>.
+
+=head2 Pseudo-hashes are supported
+
+See L<perlref>.
+
+=head2 C<EXPR foreach EXPR> is supported
+
+See L<perlsyn>.
+
+=head2 Keywords can be globally overridden
+
+See L<perlsub>.
+
+=head2 C<$^E> is meaningful on Win32
+
+See L<perlvar>.
+
+=head2 C<foreach (1..1000000)> optimized
+
+C<foreach (1..1000000)> is now optimized into a counting loop. It does
+not try to allocate a 1000000-size list anymore.
+
+=head2 C<Foo::> can be used as implicitly quoted package name
+
+Barewords caused unintuitive behavior when a subroutine with the same
+name as a package happened to be defined. Thus, C<new Foo @args>,
+use the result of the call to C<Foo()> instead of C<Foo> being treated
+as a literal. The recommended way to write barewords in the indirect
+object slot is C<new Foo:: @args>. Note that the method C<new()> is
+called with a first argument of C<Foo>, not C<Foo::> when you do that.
+
+=head2 C<exists $Foo::{Bar::}> tests existence of a package
+
+It was impossible to test for the existence of a package without
+actually creating it before. Now C<exists $Foo::{Bar::}> can be
+used to test if the C<Foo::Bar> namespace has been created.
+
+=head2 Better locale support
+
+See L<perllocale>.
+
+=head2 Experimental support for 64-bit platforms
+
+Perl5 has always had 64-bit support on systems with 64-bit longs.
+Starting with 5.005, the beginnings of experimental support for systems
+with 32-bit long and 64-bit 'long long' integers has been added.
+If you add -DUSE_LONG_LONG to your ccflags in config.sh (or manually
+define it in perl.h) then perl will be built with 'long long' support.
+There will be many compiler warnings, and the resultant perl may not
+work on all systems. There are many other issues related to
+third-party extensions and libraries. This option exists to allow
+people to work on those issues.
+
+=head2 prototype() returns useful results on builtins
+
+See L<perlfunc/prototype>.
+
+=head2 Extended support for exception handling
+
+C<die()> now accepts a reference value, and C<$@> gets set to that
+value in exception traps. This makes it possible to propagate
+exception objects. This is an undocumented B<experimental> feature.
+
+=head2 Re-blessing in DESTROY() supported for chaining DESTROY() methods
+
+See L<perlobj/Destructors>.
+
+=head2 All C<printf> format conversions are handled internally
+
+See L<perlfunc/printf>.
+
+=head2 New C<INIT> keyword
+
+C<INIT> subs are like C<BEGIN> and C<END>, but they get run just before
+the perl runtime begins execution. e.g., the Perl Compiler makes use of
+C<INIT> blocks to initialize and resolve pointers to XSUBs.
+
+=head2 New C<lock> keyword
+
+The C<lock> keyword is the fundamental synchronization primitive
+in threaded perl. When threads are not enabled, it is currently a noop.
+
+To minimize impact on source compatibility this keyword is "weak", i.e., any
+user-defined subroutine of the same name overrides it, unless a C<use Thread>
+has been seen.
+
+=head2 New C<qr//> operator
+
+The C<qr//> operator, which is syntactically similar to the other quote-like
+operators, is used to create precompiled regular expressions. This compiled
+form can now be explicitly passed around in variables, and interpolated in
+other regular expressions. See L<perlop>.
+
+=head2 C<our> is now a reserved word
+
+Calling a subroutine with the name C<our> will now provoke a warning when
+using the C<-w> switch.
+
+=head2 Tied arrays are now fully supported
+
+See L<Tie::Array>.
+
+=head2 Tied handles support is better
+
+Several missing hooks have been added. There is also a new base class for
+TIEARRAY implementations. See L<Tie::Array>.
+
+=head2 4th argument to substr
+
+substr() can now both return and replace in one operation. The optional
+4th argument is the replacement string. See L<perlfunc/substr>.
+
+=head2 Negative LENGTH argument to splice
+
+splice() with a negative LENGTH argument now work similar to what the
+LENGTH did for substr(). Previously a negative LENGTH was treated as
+0. See L<perlfunc/splice>.
+
+=head2 Magic lvalues are now more magical
+
+When you say something like C<substr($x, 5) = "hi">, the scalar returned
+by substr() is special, in that any modifications to it affect $x.
+(This is called a 'magic lvalue' because an 'lvalue' is something on
+the left side of an assignment.) Normally, this is exactly what you
+would expect to happen, but Perl uses the same magic if you use substr(),
+pos(), or vec() in a context where they might be modified, like taking
+a reference with C<\> or as an argument to a sub that modifies C<@_>.
+In previous versions, this 'magic' only went one way, but now changes
+to the scalar the magic refers to ($x in the above example) affect the
+magic lvalue too. For instance, this code now acts differently:
+
+ $x = "hello";
+ sub printit {
+ $x = "g'bye";
+ print $_[0], "\n";
+ }
+ printit(substr($x, 0, 5));
+
+In previous versions, this would print "hello", but it now prints "g'bye".
+
+=head2 E<lt>E<gt> now reads in records
+
+If C<$/> is a referenence to an integer, or a scalar that holds an integer,
+E<lt>E<gt> will read in records instead of lines. For more info, see
+L<perlvar/$/>.
+
+=head1 Supported Platforms
+
+Configure has many incremental improvements. Site-wide policy for building
+perl can now be made persistent, via Policy.sh. Configure also records
+the command-line arguments used in F<config.sh>.
+
+=head2 New Platforms
+
+BeOS is now supported. See L<README.beos>.
+
+DOS is now supported under the DJGPP tools. See L<README.dos>.
+
+MPE/iX is now supported. See L<README.mpeix>.
+
+MVS (OS390) is now supported. See L<README.os390>.
+
+=head2 Changes in existing support
+
+Win32 support has been vastly enhanced. Support for Perl Object, a C++
+encapsulation of Perl. GCC and EGCS are now supported on Win32.
+See F<README.win32>, aka L<perlwin32>.
+
+VMS configuration system has been rewritten. See L<README.vms>.
+
+The hints files for most Unix platforms have seen incremental improvements.
+
+=head1 Modules and Pragmata
+
+=head2 New Modules
+
+=over
+
+=item B
+
+Perl compiler and tools. See L<B>.
+
+=item Data::Dumper
+
+A module to pretty print Perl data. See L<Data::Dumper>.
+
+=item Errno
+
+A module to look up errors more conveniently. See L<Errno>.
+
+=item File::Spec
+
+A portable API for file operations.
+
+=item ExtUtils::Installed
+
+Query and manage installed modules.
+
+=item ExtUtils::Packlist
+
+Manipulate .packlist files.
+
+=item Fatal
+
+Make functions/builtins succeed or die.
+
+=item IPC::SysV
+
+Constants and other support infrastructure for System V IPC operations
+in perl.
+
+=item Test
+
+A framework for writing testsuites.
+
+=item Tie::Array
+
+Base class for tied arrays.
+
+=item Tie::Handle
+
+Base class for tied handles.
+
+=item Thread
+
+Perl thread creation, manipulation, and support.
+
+=item attrs
+
+Set subroutine attributes.
+
+=item fields
+
+Compile-time class fields.
+
+=item re
+
+Various pragmata to control behavior of regular expressions.
+
+=back
+
+=head2 Changes in existing modules
+
+=over
+
+=item CGI
+
+CGI has been updated to version 2.42.
+
+=item POSIX
+
+POSIX now has its own platform-specific hints files.
+
+=item DB_File
+
+DB_File supports version 2.x of Berkeley DB. See C<ext/DB_File/Changes>.
+
+=item MakeMaker
+
+MakeMaker now supports writing empty makefiles, provides a way to
+specify that site umask() policy should be honored. There is also
+better support for manipulation of .packlist files, and getting
+information about installed modules.
+
+Extensions that have both architecture-dependent and
+architecture-independent files are now always installed completely in
+the architecture-dependent locations. Previously, the shareable parts
+were shared both across architectures and across perl versions and were
+therefore liable to be overwritten with newer versions that might have
+subtle incompatibilities.
+
+=item CPAN
+
+See <perlmodinstall> and L<CPAN>.
+
+=item Cwd
+
+Cwd::cwd is faster on most platforms.
+
+=item Benchmark
+
+Keeps better time.
+
+=back
+
+=head1 Utility Changes
+
+C<h2ph> and related utilities have been vastly overhauled.
+
+C<perlcc>, a new experimental front end for the compiler is available.
+
+The crude GNU C<configure> emulator is now called C<configure.gnu> to
+avoid trampling on C<Configure> under case-insensitive filesystems.
+
+C<perldoc> used to be rather slow. The slower features are now optional.
+In particular, case-insensitive searches need the C<-i> switch, and
+recursive searches need C<-r>. You can set these switches in the
+C<PERLDOC> environment variable to get the old behavior.
+
+=head1 Documentation Changes
+
+Config.pm now has a glossary of variables.
+
+F<Porting/patching.pod> has detailed instructions on how to create and
+submit patches for perl.
+
+L<perlport> specifies guidelines on how to write portably.
+
+L<perlmodinstall> describes how to fetch and install modules from C<CPAN>
+sites.
+
+Some more Perl traps are documented now. See L<perltrap>.
+
+=head1 New Diagnostics
+
+=over
+
+=item Ambiguous call resolved as CORE::%s(), qualify as such or use &
+
+(W) A subroutine you have declared has the same name as a Perl keyword,
+and you have used the name without qualification for calling one or the
+other. Perl decided to call the builtin because the subroutine is
+not imported.
+
+To force interpretation as a subroutine call, either put an ampersand
+before the subroutine name, or qualify the name with its package.
+Alternatively, you can import the subroutine (or pretend that it's
+imported with the C<use subs> pragma).
+
+To silently interpret it as the Perl operator, use the C<CORE::> prefix
+on the operator (e.g. C<CORE::log($x)>) or by declaring the subroutine
+to be an object method (see L<attrs>).
+
+=item Bad index while coercing array into hash
+
+(F) The index looked up in the hash found as the 0'th element of a
+pseudo-hash is not legal. Index values must be at 1 or greater.
+See L<perlref>.
+
+=item Bareword "%s" refers to nonexistent package
+
+(W) You used a qualified bareword of the form C<Foo::>, but
+the compiler saw no other uses of that namespace before that point.
+Perhaps you need to predeclare a package?
+
+=item Can't call method "%s" on an undefined value
+
+(F) You used the syntax of a method call, but the slot filled by the
+object reference or package name contains an undefined value.
+Something like this will reproduce the error:
+
+ $BADREF = 42;
+ process $BADREF 1,2,3;
+ $BADREF->process(1,2,3);
+
+=item Can't coerce array into hash
+
+(F) You used an array where a hash was expected, but the array has no
+information on how to map from keys to array indices. You can do that
+only with arrays that have a hash reference at index 0.
+
+=item Can't goto subroutine from an eval-string
+
+(F) The "goto subroutine" call can't be used to jump out of an eval "string".
+(You can use it to jump out of an eval {BLOCK}, but you probably don't want to.)
+
+=item Can't localize pseudo-hash element
+
+(F) You said something like C<local $ar-E<gt>{'key'}>, where $ar is
+a reference to a pseudo-hash. That hasn't been implemented yet, but
+you can get a similar effect by localizing the corresponding array
+element directly -- C<local $ar-E<gt>[$ar-E<gt>[0]{'key'}]>.
+
+=item Can't use %%! because Errno.pm is not available
+
+(F) The first time the %! hash is used, perl automatically loads the
+Errno.pm module. The Errno module is expected to tie the %! hash to
+provide symbolic names for C<$!> errno values.
+
+=item Cannot find an opnumber for "%s"
+
+(F) A string of a form C<CORE::word> was given to prototype(), but
+there is no builtin with the name C<word>.
+
+=item Character class syntax [. .] is reserved for future extensions
+
+(W) Within regular expression character classes ([]) the syntax beginning
+with "[." and ending with ".]" is reserved for future extensions.
+If you need to represent those character sequences inside a regular
+expression character class, just quote the square brackets with the
+backslash: "\[." and ".\]".
+
+=item Character class syntax [: :] is reserved for future extensions
+
+(W) Within regular expression character classes ([]) the syntax beginning
+with "[:" and ending with ":]" is reserved for future extensions.
+If you need to represent those character sequences inside a regular
+expression character class, just quote the square brackets with the
+backslash: "\[:" and ":\]".
+
+=item Character class syntax [= =] is reserved for future extensions
+
+(W) Within regular expression character classes ([]) the syntax
+beginning with "[=" and ending with "=]" is reserved for future extensions.
+If you need to represent those character sequences inside a regular
+expression character class, just quote the square brackets with the
+backslash: "\[=" and "=\]".
+
+=item %s: Eval-group in insecure regular expression
+
+(F) Perl detected tainted data when trying to compile a regular expression
+that contains the C<(?{ ... })> zero-width assertion, which is unsafe.
+See L<perlre/(?{ code })>, and L<perlsec>.
+
+=item %s: Eval-group not allowed, use re 'eval'
+
+(F) A regular expression contained the C<(?{ ... })> zero-width assertion,
+but that construct is only allowed when the C<use re 'eval'> pragma is
+in effect. See L<perlre/(?{ code })>.
+
+=item %s: Eval-group not allowed at run time
+
+(F) Perl tried to compile a regular expression containing the C<(?{ ... })>
+zero-width assertion at run time, as it would when the pattern contains
+interpolated values. Since that is a security risk, it is not allowed.
+If you insist, you may still do this by explicitly building the pattern
+from an interpolated string at run time and using that in an eval().
+See L<perlre/(?{ code })>.
+
+=item Explicit blessing to '' (assuming package main)
+
+(W) You are blessing a reference to a zero length string. This has
+the effect of blessing the reference into the package main. This is
+usually not what you want. Consider providing a default target
+package, e.g. bless($ref, $p or 'MyPackage');
+
+=item Illegal hex digit ignored
+
+(W) You may have tried to use a character other than 0 - 9 or A - F in a
+hexadecimal number. Interpretation of the hexadecimal number stopped
+before the illegal character.
+
+=item No such array field
+
+(F) You tried to access an array as a hash, but the field name used is
+not defined. The hash at index 0 should map all valid field names to
+array indices for that to work.
+
+=item No such field "%s" in variable %s of type %s
+
+(F) You tried to access a field of a typed variable where the type
+does not know about the field name. The field names are looked up in
+the %FIELDS hash in the type package at compile time. The %FIELDS hash
+is usually set up with the 'fields' pragma.
+
+=item Out of memory during ridiculously large request
+
+(F) You can't allocate more than 2^31+"small amount" bytes. This error
+is most likely to be caused by a typo in the Perl program. e.g., C<$arr[time]>
+instead of C<$arr[$time]>.
+
+=item Range iterator outside integer range
+
+(F) One (or both) of the numeric arguments to the range operator ".."
+are outside the range which can be represented by integers internally.
+One possible workaround is to force Perl to use magical string
+increment by prepending "0" to your numbers.
+
+=item Recursive inheritance detected while looking for method '%s' in package '%s'
+
+(F) More than 100 levels of inheritance were encountered while invoking a
+method. Probably indicates an unintended loop in your inheritance hierarchy.
+
+=item Reference found where even-sized list expected
+
+(W) You gave a single reference where Perl was expecting a list with
+an even number of elements (for assignment to a hash). This
+usually means that you used the anon hash constructor when you meant
+to use parens. In any case, a hash requires key/value B<pairs>.
+
+ %hash = { one => 1, two => 2, }; # WRONG
+ %hash = [ qw/ an anon array / ]; # WRONG
+ %hash = ( one => 1, two => 2, ); # right
+ %hash = qw( one 1 two 2 ); # also fine
+
+=item Undefined value assigned to typeglob
+
+(W) An undefined value was assigned to a typeglob, a la C<*foo = undef>.
+This does nothing. It's possible that you really mean C<undef *foo>.
+
+=item Use of reserved word "%s" is deprecated
+
+(D) The indicated bareword is a reserved word. Future versions of perl
+may use it as a keyword, so you're better off either explicitly quoting
+the word in a manner appropriate for its context of use, or using a
+different name altogether. The warning can be suppressed for subroutine
+names by either adding a C<&> prefix, or using a package qualifier,
+e.g. C<&our()>, or C<Foo::our()>.
+
+=item perl: warning: Setting locale failed.
+
+(S) The whole warning message will look something like:
+
+ perl: warning: Setting locale failed.
+ perl: warning: Please check that your locale settings:
+ LC_ALL = "En_US",
+ LANG = (unset)
+ are supported and installed on your system.
+ perl: warning: Falling back to the standard locale ("C").
+
+Exactly what were the failed locale settings varies. In the above the
+settings were that the LC_ALL was "En_US" and the LANG had no value.
+This error means that Perl detected that you and/or your system
+administrator have set up the so-called variable system but Perl could
+not use those settings. This was not dead serious, fortunately: there
+is a "default locale" called "C" that Perl can and will use, the
+script will be run. Before you really fix the problem, however, you
+will get the same error message each time you run Perl. How to really
+fix the problem can be found in L<perllocale> section B<LOCALE PROBLEMS>.
+
+=back
+
+
+=head1 Obsolete Diagnostics
+
+=over
+
+=item Can't mktemp()
+
+(F) The mktemp() routine failed for some reason while trying to process
+a B<-e> switch. Maybe your /tmp partition is full, or clobbered.
+
+=item Can't write to temp file for B<-e>: %s
+
+(F) The write routine failed for some reason while trying to process
+a B<-e> switch. Maybe your /tmp partition is full, or clobbered.
+
+=item Cannot open temporary file
+
+(F) The create routine failed for some reason while trying to process
+a B<-e> switch. Maybe your /tmp partition is full, or clobbered.
+
+=back
+
+=head1 BUGS
+
+If you find what you think is a bug, you might check the headers of
+recently posted articles in the comp.lang.perl.misc newsgroup.
+There may also be information at http://www.perl.com/perl/, the Perl
+Home Page.
+
+If you believe you have an unreported bug, please run the B<perlbug>
+program included with your release. Make sure you trim your bug down
+to a tiny but sufficient test case. Your bug report, along with the
+output of C<perl -V>, will be sent off to <F<perlbug@perl.com>> to be
+analysed by the Perl porting team.
+
+=head1 SEE ALSO
+
+The F<Changes> file for exhaustive details on what changed.
+
+The F<INSTALL> file for how to build Perl.
+
+The F<README> file for general stuff.
+
+The F<Artistic> and F<Copying> files for copyright information.
+
+=head1 HISTORY
+
+Written by Gurusamy Sarathy <F<gsar@umich.edu>>, with many contributions
+from The Perl Porters.
+
+Send omissions or corrections to <F<perlbug@perl.com>>.
+
+=cut
diff --git a/contrib/perl5/pod/perldiag.pod b/contrib/perl5/pod/perldiag.pod
new file mode 100644
index 000000000000..8d213235a885
--- /dev/null
+++ b/contrib/perl5/pod/perldiag.pod
@@ -0,0 +1,3125 @@
+=head1 NAME
+
+perldiag - various Perl diagnostics
+
+=head1 DESCRIPTION
+
+These messages are classified as follows (listed in increasing order of
+desperation):
+
+ (W) A warning (optional).
+ (D) A deprecation (optional).
+ (S) A severe warning (mandatory).
+ (F) A fatal error (trappable).
+ (P) An internal error you should never see (trappable).
+ (X) A very fatal error (nontrappable).
+ (A) An alien error message (not generated by Perl).
+
+Optional warnings are enabled by using the B<-w> switch. Warnings may
+be captured by setting C<$SIG{__WARN__}> to a reference to a routine that
+will be called on each warning instead of printing it. See L<perlvar>.
+Trappable errors may be trapped using the eval operator. See
+L<perlfunc/eval>.
+
+Some of these messages are generic. Spots that vary are denoted with a %s,
+just as in a printf format. Note that some messages start with a %s!
+The symbols C<"%(-?@> sort before the letters, while C<[> and C<\> sort after.
+
+=over 4
+
+=item "my" variable %s can't be in a package
+
+(F) Lexically scoped variables aren't in a package, so it doesn't make sense
+to try to declare one with a package qualifier on the front. Use local()
+if you want to localize a package variable.
+
+=item "my" variable %s masks earlier declaration in same scope
+
+(W) A lexical variable has been redeclared in the same scope, effectively
+eliminating all access to the previous instance. This is almost always
+a typographical error. Note that the earlier variable will still exist
+until the end of the scope or until all closure referents to it are
+destroyed.
+
+=item "no" not allowed in expression
+
+(F) The "no" keyword is recognized and executed at compile time, and returns
+no useful value. See L<perlmod>.
+
+=item "use" not allowed in expression
+
+(F) The "use" keyword is recognized and executed at compile time, and returns
+no useful value. See L<perlmod>.
+
+=item % may only be used in unpack
+
+(F) You can't pack a string by supplying a checksum, because the
+checksumming process loses information, and you can't go the other
+way. See L<perlfunc/unpack>.
+
+=item %s (...) interpreted as function
+
+(W) You've run afoul of the rule that says that any list operator followed
+by parentheses turns into a function, with all the list operators arguments
+found inside the parentheses. See L<perlop/Terms and List Operators (Leftward)>.
+
+=item %s argument is not a HASH element
+
+(F) The argument to exists() must be a hash element, such as
+
+ $foo{$bar}
+ $ref->[12]->{"susie"}
+
+=item %s argument is not a HASH element or slice
+
+(F) The argument to delete() must be either a hash element, such as
+
+ $foo{$bar}
+ $ref->[12]->{"susie"}
+
+or a hash slice, such as
+
+ @foo{$bar, $baz, $xyzzy}
+ @{$ref->[12]}{"susie", "queue"}
+
+=item %s did not return a true value
+
+(F) A required (or used) file must return a true value to indicate that
+it compiled correctly and ran its initialization code correctly. It's
+traditional to end such a file with a "1;", though any true value would
+do. See L<perlfunc/require>.
+
+=item %s found where operator expected
+
+(S) The Perl lexer knows whether to expect a term or an operator. If it
+sees what it knows to be a term when it was expecting to see an operator,
+it gives you this warning. Usually it indicates that an operator or
+delimiter was omitted, such as a semicolon.
+
+=item %s had compilation errors
+
+(F) The final summary message when a C<perl -c> fails.
+
+=item %s has too many errors
+
+(F) The parser has given up trying to parse the program after 10 errors.
+Further error messages would likely be uninformative.
+
+=item %s matches null string many times
+
+(W) The pattern you've specified would be an infinite loop if the
+regular expression engine didn't specifically check for that. See L<perlre>.
+
+=item %s never introduced
+
+(S) The symbol in question was declared but somehow went out of scope
+before it could possibly have been used.
+
+=item %s syntax OK
+
+(F) The final summary message when a C<perl -c> succeeds.
+
+=item %s: Command not found
+
+(A) You've accidentally run your script through B<csh> instead
+of Perl. Check the #! line, or manually feed your script into
+Perl yourself.
+
+=item %s: Expression syntax
+
+(A) You've accidentally run your script through B<csh> instead
+of Perl. Check the #! line, or manually feed your script into
+Perl yourself.
+
+=item %s: Undefined variable
+
+(A) You've accidentally run your script through B<csh> instead
+of Perl. Check the #! line, or manually feed your script into
+Perl yourself.
+
+=item %s: not found
+
+(A) You've accidentally run your script through the Bourne shell
+instead of Perl. Check the #! line, or manually feed your script
+into Perl yourself.
+
+=item (Missing semicolon on previous line?)
+
+(S) This is an educated guess made in conjunction with the message "%s
+found where operator expected". Don't automatically put a semicolon on
+the previous line just because you saw this message.
+
+=item B<-P> not allowed for setuid/setgid script
+
+(F) The script would have to be opened by the C preprocessor by name,
+which provides a race condition that breaks security.
+
+=item C<-T> and C<-B> not implemented on filehandles
+
+(F) Perl can't peek at the stdio buffer of filehandles when it doesn't
+know about your kind of stdio. You'll have to use a filename instead.
+
+=item C<-p> destination: %s
+
+(F) An error occurred during the implicit output invoked by the C<-p>
+command-line switch. (This output goes to STDOUT unless you've
+redirected it with select().)
+
+=item 500 Server error
+
+See Server error.
+
+=item ?+* follows nothing in regexp
+
+(F) You started a regular expression with a quantifier. Backslash it
+if you meant it literally. See L<perlre>.
+
+=item @ outside of string
+
+(F) You had a pack template that specified an absolute position outside
+the string being unpacked. See L<perlfunc/pack>.
+
+=item accept() on closed fd
+
+(W) You tried to do an accept on a closed socket. Did you forget to check
+the return value of your socket() call? See L<perlfunc/accept>.
+
+=item Allocation too large: %lx
+
+(X) You can't allocate more than 64K on an MS-DOS machine.
+
+=item Applying %s to %s will act on scalar(%s)
+
+(W) The pattern match (//), substitution (s///), and transliteration (tr///)
+operators work on scalar values. If you apply one of them to an array
+or a hash, it will convert the array or hash to a scalar value -- the
+length of an array, or the population info of a hash -- and then work on
+that scalar value. This is probably not what you meant to do. See
+L<perlfunc/grep> and L<perlfunc/map> for alternatives.
+
+=item Arg too short for msgsnd
+
+(F) msgsnd() requires a string at least as long as sizeof(long).
+
+=item Ambiguous use of %s resolved as %s
+
+(W)(S) You said something that may not be interpreted the way
+you thought. Normally it's pretty easy to disambiguate it by supplying
+a missing quote, operator, parenthesis pair or declaration.
+
+=item Ambiguous call resolved as CORE::%s(), qualify as such or use &
+
+(W) A subroutine you have declared has the same name as a Perl keyword,
+and you have used the name without qualification for calling one or the
+other. Perl decided to call the builtin because the subroutine is
+not imported.
+
+To force interpretation as a subroutine call, either put an ampersand
+before the subroutine name, or qualify the name with its package.
+Alternatively, you can import the subroutine (or pretend that it's
+imported with the C<use subs> pragma).
+
+To silently interpret it as the Perl operator, use the C<CORE::> prefix
+on the operator (e.g. C<CORE::log($x)>) or by declaring the subroutine
+to be an object method (see L<attrs>).
+
+=item Args must match #! line
+
+(F) The setuid emulator requires that the arguments Perl was invoked
+with match the arguments specified on the #! line. Since some systems
+impose a one-argument limit on the #! line, try combining switches;
+for example, turn C<-w -U> into C<-wU>.
+
+=item Argument "%s" isn't numeric%s
+
+(W) The indicated string was fed as an argument to an operator that
+expected a numeric value instead. If you're fortunate the message
+will identify which operator was so unfortunate.
+
+=item Array @%s missing the @ in argument %d of %s()
+
+(D) Really old Perl let you omit the @ on array names in some spots. This
+is now heavily deprecated.
+
+=item assertion botched: %s
+
+(P) The malloc package that comes with Perl had an internal failure.
+
+=item Assertion failed: file "%s"
+
+(P) A general assertion failed. The file in question must be examined.
+
+=item Assignment to both a list and a scalar
+
+(F) If you assign to a conditional operator, the 2nd and 3rd arguments
+must either both be scalars or both be lists. Otherwise Perl won't
+know which context to supply to the right side.
+
+=item Attempt to free non-arena SV: 0x%lx
+
+(P) All SV objects are supposed to be allocated from arenas that will
+be garbage collected on exit. An SV was discovered to be outside any
+of those arenas.
+
+=item Attempt to free nonexistent shared string
+
+(P) Perl maintains a reference counted internal table of strings to
+optimize the storage and access of hash keys and other strings. This
+indicates someone tried to decrement the reference count of a string
+that can no longer be found in the table.
+
+=item Attempt to free temp prematurely
+
+(W) Mortalized values are supposed to be freed by the free_tmps()
+routine. This indicates that something else is freeing the SV before
+the free_tmps() routine gets a chance, which means that the free_tmps()
+routine will be freeing an unreferenced scalar when it does try to free
+it.
+
+=item Attempt to free unreferenced glob pointers
+
+(P) The reference counts got screwed up on symbol aliases.
+
+=item Attempt to free unreferenced scalar
+
+(W) Perl went to decrement the reference count of a scalar to see if it
+would go to 0, and discovered that it had already gone to 0 earlier,
+and should have been freed, and in fact, probably was freed. This
+could indicate that SvREFCNT_dec() was called too many times, or that
+SvREFCNT_inc() was called too few times, or that the SV was mortalized
+when it shouldn't have been, or that memory has been corrupted.
+
+=item Attempt to pack pointer to temporary value
+
+(W) You tried to pass a temporary value (like the result of a
+function, or a computed expression) to the "p" pack() template. This
+means the result contains a pointer to a location that could become
+invalid anytime, even before the end of the current statement. Use
+literals or global values as arguments to the "p" pack() template to
+avoid this warning.
+
+=item Attempt to use reference as lvalue in substr
+
+(W) You supplied a reference as the first argument to substr() used
+as an lvalue, which is pretty strange. Perhaps you forgot to
+dereference it first. See L<perlfunc/substr>.
+
+=item Bad arg length for %s, is %d, should be %d
+
+(F) You passed a buffer of the wrong size to one of msgctl(), semctl() or
+shmctl(). In C parlance, the correct sizes are, respectively,
+S<sizeof(struct msqid_ds *)>, S<sizeof(struct semid_ds *)>, and
+S<sizeof(struct shmid_ds *)>.
+
+=item Bad filehandle: %s
+
+(F) A symbol was passed to something wanting a filehandle, but the symbol
+has no filehandle associated with it. Perhaps you didn't do an open(), or
+did it in another package.
+
+=item Bad free() ignored
+
+(S) An internal routine called free() on something that had never been
+malloc()ed in the first place. Mandatory, but can be disabled by
+setting environment variable C<PERL_BADFREE> to 1.
+
+This message can be quite often seen with DB_File on systems with
+"hard" dynamic linking, like C<AIX> and C<OS/2>. It is a bug of
+C<Berkeley DB> which is left unnoticed if C<DB> uses I<forgiving>
+system malloc().
+
+=item Bad hash
+
+(P) One of the internal hash routines was passed a null HV pointer.
+
+=item Bad index while coercing array into hash
+
+(F) The index looked up in the hash found as the 0'th element of a
+pseudo-hash is not legal. Index values must be at 1 or greater.
+See L<perlref>.
+
+=item Bad name after %s::
+
+(F) You started to name a symbol by using a package prefix, and then didn't
+finish the symbol. In particular, you can't interpolate outside of quotes,
+so
+
+ $var = 'myvar';
+ $sym = mypack::$var;
+
+is not the same as
+
+ $var = 'myvar';
+ $sym = "mypack::$var";
+
+=item Bad symbol for array
+
+(P) An internal request asked to add an array entry to something that
+wasn't a symbol table entry.
+
+=item Bad symbol for filehandle
+
+(P) An internal request asked to add a filehandle entry to something that
+wasn't a symbol table entry.
+
+=item Bad symbol for hash
+
+(P) An internal request asked to add a hash entry to something that
+wasn't a symbol table entry.
+
+=item Badly placed ()'s
+
+(A) You've accidentally run your script through B<csh> instead
+of Perl. Check the #! line, or manually feed your script into
+Perl yourself.
+
+=item Bareword "%s" not allowed while "strict subs" in use
+
+(F) With "strict subs" in use, a bareword is only allowed as a
+subroutine identifier, in curly braces or to the left of the "=>" symbol.
+Perhaps you need to predeclare a subroutine?
+
+=item Bareword "%s" refers to nonexistent package
+
+(W) You used a qualified bareword of the form C<Foo::>, but
+the compiler saw no other uses of that namespace before that point.
+Perhaps you need to predeclare a package?
+
+=item BEGIN failed--compilation aborted
+
+(F) An untrapped exception was raised while executing a BEGIN subroutine.
+Compilation stops immediately and the interpreter is exited.
+
+=item BEGIN not safe after errors--compilation aborted
+
+(F) Perl found a C<BEGIN {}> subroutine (or a C<use> directive, which
+implies a C<BEGIN {}>) after one or more compilation errors had
+already occurred. Since the intended environment for the C<BEGIN {}>
+could not be guaranteed (due to the errors), and since subsequent code
+likely depends on its correct operation, Perl just gave up.
+
+=item bind() on closed fd
+
+(W) You tried to do a bind on a closed socket. Did you forget to check
+the return value of your socket() call? See L<perlfunc/bind>.
+
+=item Bizarre copy of %s in %s
+
+(P) Perl detected an attempt to copy an internal value that is not copiable.
+
+=item Callback called exit
+
+(F) A subroutine invoked from an external package via perl_call_sv()
+exited by calling exit.
+
+=item Can't "goto" outside a block
+
+(F) A "goto" statement was executed to jump out of what might look
+like a block, except that it isn't a proper block. This usually
+occurs if you tried to jump out of a sort() block or subroutine, which
+is a no-no. See L<perlfunc/goto>.
+
+=item Can't "goto" into the middle of a foreach loop
+
+(F) A "goto" statement was executed to jump into the middle of a
+foreach loop. You can't get there from here. See L<perlfunc/goto>.
+
+=item Can't "last" outside a block
+
+(F) A "last" statement was executed to break out of the current block,
+except that there's this itty bitty problem called there isn't a
+current block. Note that an "if" or "else" block doesn't count as a
+"loopish" block, as doesn't a block given to sort(). You can usually double
+the curlies to get the same effect though, because the inner curlies
+will be considered a block that loops once. See L<perlfunc/last>.
+
+=item Can't "next" outside a block
+
+(F) A "next" statement was executed to reiterate the current block, but
+there isn't a current block. Note that an "if" or "else" block doesn't
+count as a "loopish" block, as doesn't a block given to sort(). You can
+usually double the curlies to get the same effect though, because the inner
+curlies will be considered a block that loops once. See L<perlfunc/next>.
+
+=item Can't "redo" outside a block
+
+(F) A "redo" statement was executed to restart the current block, but
+there isn't a current block. Note that an "if" or "else" block doesn't
+count as a "loopish" block, as doesn't a block given to sort(). You can
+usually double the curlies to get the same effect though, because the inner
+curlies will be considered a block that loops once. See L<perlfunc/redo>.
+
+=item Can't bless non-reference value
+
+(F) Only hard references may be blessed. This is how Perl "enforces"
+encapsulation of objects. See L<perlobj>.
+
+=item Can't break at that line
+
+(S) A warning intended to only be printed while running within the debugger, indicating
+the line number specified wasn't the location of a statement that could
+be stopped at.
+
+=item Can't call method "%s" in empty package "%s"
+
+(F) You called a method correctly, and it correctly indicated a package
+functioning as a class, but that package doesn't have ANYTHING defined
+in it, let alone methods. See L<perlobj>.
+
+=item Can't call method "%s" on unblessed reference
+
+(F) A method call must know in what package it's supposed to run. It
+ordinarily finds this out from the object reference you supply, but
+you didn't supply an object reference in this case. A reference isn't
+an object reference until it has been blessed. See L<perlobj>.
+
+=item Can't call method "%s" without a package or object reference
+
+(F) You used the syntax of a method call, but the slot filled by the
+object reference or package name contains an expression that returns
+a defined value which is neither an object reference nor a package name.
+Something like this will reproduce the error:
+
+ $BADREF = 42;
+ process $BADREF 1,2,3;
+ $BADREF->process(1,2,3);
+
+=item Can't call method "%s" on an undefined value
+
+(F) You used the syntax of a method call, but the slot filled by the
+object reference or package name contains an undefined value.
+Something like this will reproduce the error:
+
+ $BADREF = undef;
+ process $BADREF 1,2,3;
+ $BADREF->process(1,2,3);
+
+=item Can't chdir to %s
+
+(F) You called C<perl -x/foo/bar>, but C</foo/bar> is not a directory
+that you can chdir to, possibly because it doesn't exist.
+
+=item Can't coerce %s to integer in %s
+
+(F) Certain types of SVs, in particular real symbol table entries
+(typeglobs), can't be forced to stop being what they are. So you can't
+say things like:
+
+ *foo += 1;
+
+You CAN say
+
+ $foo = *foo;
+ $foo += 1;
+
+but then $foo no longer contains a glob.
+
+=item Can't coerce %s to number in %s
+
+(F) Certain types of SVs, in particular real symbol table entries
+(typeglobs), can't be forced to stop being what they are.
+
+=item Can't coerce %s to string in %s
+
+(F) Certain types of SVs, in particular real symbol table entries
+(typeglobs), can't be forced to stop being what they are.
+
+=item Can't coerce array into hash
+
+(F) You used an array where a hash was expected, but the array has no
+information on how to map from keys to array indices. You can do that
+only with arrays that have a hash reference at index 0.
+
+=item Can't create pipe mailbox
+
+(P) An error peculiar to VMS. The process is suffering from exhausted quotas
+or other plumbing problems.
+
+=item Can't declare %s in my
+
+(F) Only scalar, array, and hash variables may be declared as lexical variables.
+They must have ordinary identifiers as names.
+
+=item Can't do inplace edit on %s: %s
+
+(S) The creation of the new file failed for the indicated reason.
+
+=item Can't do inplace edit without backup
+
+(F) You're on a system such as MS-DOS that gets confused if you try reading
+from a deleted (but still opened) file. You have to say C<-i.bak>, or some
+such.
+
+=item Can't do inplace edit: %s E<gt> 14 characters
+
+(S) There isn't enough room in the filename to make a backup name for the file.
+
+=item Can't do inplace edit: %s is not a regular file
+
+(S) You tried to use the B<-i> switch on a special file, such as a file in
+/dev, or a FIFO. The file was ignored.
+
+=item Can't do setegid!
+
+(P) The setegid() call failed for some reason in the setuid emulator
+of suidperl.
+
+=item Can't do seteuid!
+
+(P) The setuid emulator of suidperl failed for some reason.
+
+=item Can't do setuid
+
+(F) This typically means that ordinary perl tried to exec suidperl to
+do setuid emulation, but couldn't exec it. It looks for a name of the
+form sperl5.000 in the same directory that the perl executable resides
+under the name perl5.000, typically /usr/local/bin on Unix machines.
+If the file is there, check the execute permissions. If it isn't, ask
+your sysadmin why he and/or she removed it.
+
+=item Can't do waitpid with flags
+
+(F) This machine doesn't have either waitpid() or wait4(), so only waitpid()
+without flags is emulated.
+
+=item Can't do {n,m} with n E<gt> m
+
+(F) Minima must be less than or equal to maxima. If you really want
+your regexp to match something 0 times, just put {0}. See L<perlre>.
+
+=item Can't emulate -%s on #! line
+
+(F) The #! line specifies a switch that doesn't make sense at this point.
+For example, it'd be kind of silly to put a B<-x> on the #! line.
+
+=item Can't exec "%s": %s
+
+(W) An system(), exec(), or piped open call could not execute the named
+program for the indicated reason. Typical reasons include: the permissions
+were wrong on the file, the file wasn't found in C<$ENV{PATH}>, the
+executable in question was compiled for another architecture, or the
+#! line in a script points to an interpreter that can't be run for
+similar reasons. (Or maybe your system doesn't support #! at all.)
+
+=item Can't exec %s
+
+(F) Perl was trying to execute the indicated program for you because that's
+what the #! line said. If that's not what you wanted, you may need to
+mention "perl" on the #! line somewhere.
+
+=item Can't execute %s
+
+(F) You used the B<-S> switch, but the copies of the script to execute found
+in the PATH did not have correct permissions.
+
+=item Can't find %s on PATH, '.' not in PATH
+
+(F) You used the B<-S> switch, but the script to execute could not be found
+in the PATH, or at least not with the correct permissions. The script
+exists in the current directory, but PATH prohibits running it.
+
+=item Can't find %s on PATH
+
+(F) You used the B<-S> switch, but the script to execute could not be found
+in the PATH.
+
+=item Can't find label %s
+
+(F) You said to goto a label that isn't mentioned anywhere that it's possible
+for us to go to. See L<perlfunc/goto>.
+
+=item Can't find string terminator %s anywhere before EOF
+
+(F) Perl strings can stretch over multiple lines. This message means that
+the closing delimiter was omitted. Because bracketed quotes count nesting
+levels, the following is missing its final parenthesis:
+
+ print q(The character '(' starts a side comment.);
+
+If you're getting this error from a here-document, you may have
+included unseen whitespace before or after your closing tag. A good
+programmer's editor will have a way to help you find these characters.
+
+=item Can't fork
+
+(F) A fatal error occurred while trying to fork while opening a pipeline.
+
+=item Can't get filespec - stale stat buffer?
+
+(S) A warning peculiar to VMS. This arises because of the difference between
+access checks under VMS and under the Unix model Perl assumes. Under VMS,
+access checks are done by filename, rather than by bits in the stat buffer, so
+that ACLs and other protections can be taken into account. Unfortunately, Perl
+assumes that the stat buffer contains all the necessary information, and passes
+it, instead of the filespec, to the access checking routine. It will try to
+retrieve the filespec using the device name and FID present in the stat buffer,
+but this works only if you haven't made a subsequent call to the CRTL stat()
+routine, because the device name is overwritten with each call. If this warning
+appears, the name lookup failed, and the access checking routine gave up and
+returned FALSE, just to be conservative. (Note: The access checking routine
+knows about the Perl C<stat> operator and file tests, so you shouldn't ever
+see this warning in response to a Perl command; it arises only if some internal
+code takes stat buffers lightly.)
+
+=item Can't get pipe mailbox device name
+
+(P) An error peculiar to VMS. After creating a mailbox to act as a pipe, Perl
+can't retrieve its name for later use.
+
+=item Can't get SYSGEN parameter value for MAXBUF
+
+(P) An error peculiar to VMS. Perl asked $GETSYI how big you want your
+mailbox buffers to be, and didn't get an answer.
+
+=item Can't goto subroutine outside a subroutine
+
+(F) The deeply magical "goto subroutine" call can only replace one subroutine
+call for another. It can't manufacture one out of whole cloth. In general
+you should be calling it out of only an AUTOLOAD routine anyway. See
+L<perlfunc/goto>.
+
+=item Can't goto subroutine from an eval-string
+
+(F) The "goto subroutine" call can't be used to jump out of an eval "string".
+(You can use it to jump out of an eval {BLOCK}, but you probably don't want to.)
+
+=item Can't localize through a reference
+
+(F) You said something like C<local $$ref>, which Perl can't currently
+handle, because when it goes to restore the old value of whatever $ref
+pointed to after the scope of the local() is finished, it can't be
+sure that $ref will still be a reference.
+
+=item Can't localize lexical variable %s
+
+(F) You used local on a variable name that was previously declared as a
+lexical variable using "my". This is not allowed. If you want to
+localize a package variable of the same name, qualify it with the
+package name.
+
+=item Can't localize pseudo-hash element
+
+(F) You said something like C<local $ar-E<gt>{'key'}>, where $ar is
+a reference to a pseudo-hash. That hasn't been implemented yet, but
+you can get a similar effect by localizing the corresponding array
+element directly -- C<local $ar-E<gt>[$ar-E<gt>[0]{'key'}]>.
+
+=item Can't locate auto/%s.al in @INC
+
+(F) A function (or method) was called in a package which allows autoload,
+but there is no function to autoload. Most probable causes are a misprint
+in a function/method name or a failure to C<AutoSplit> the file, say, by
+doing C<make install>.
+
+=item Can't locate %s in @INC
+
+(F) You said to do (or require, or use) a file that couldn't be found
+in any of the libraries mentioned in @INC. Perhaps you need to set the
+PERL5LIB or PERL5OPT environment variable to say where the extra library
+is, or maybe the script needs to add the library name to @INC. Or maybe
+you just misspelled the name of the file. See L<perlfunc/require>.
+
+=item Can't locate object method "%s" via package "%s"
+
+(F) You called a method correctly, and it correctly indicated a package
+functioning as a class, but that package doesn't define that particular
+method, nor does any of its base classes. See L<perlobj>.
+
+=item Can't locate package %s for @%s::ISA
+
+(W) The @ISA array contained the name of another package that doesn't seem
+to exist.
+
+=item Can't make list assignment to \%ENV on this system
+
+(F) List assignment to %ENV is not supported on some systems, notably VMS.
+
+=item Can't modify %s in %s
+
+(F) You aren't allowed to assign to the item indicated, or otherwise try to
+change it, such as with an auto-increment.
+
+=item Can't modify nonexistent substring
+
+(P) The internal routine that does assignment to a substr() was handed
+a NULL.
+
+=item Can't msgrcv to read-only var
+
+(F) The target of a msgrcv must be modifiable to be used as a receive
+buffer.
+
+=item Can't open %s: %s
+
+(S) The implicit opening of a file through use of the C<E<lt>E<gt>>
+filehandle, either implicitly under the C<-n> or C<-p> command-line
+switches, or explicitly, failed for the indicated reason. Usually this
+is because you don't have read permission for a file which you named
+on the command line.
+
+=item Can't open bidirectional pipe
+
+(W) You tried to say C<open(CMD, "|cmd|")>, which is not supported. You can
+try any of several modules in the Perl library to do this, such as
+IPC::Open2. Alternately, direct the pipe's output to a file using "E<gt>",
+and then read it in under a different file handle.
+
+=item Can't open error file %s as stderr
+
+(F) An error peculiar to VMS. Perl does its own command line redirection, and
+couldn't open the file specified after '2E<gt>' or '2E<gt>E<gt>' on the
+command line for writing.
+
+=item Can't open input file %s as stdin
+
+(F) An error peculiar to VMS. Perl does its own command line redirection, and
+couldn't open the file specified after 'E<lt>' on the command line for reading.
+
+=item Can't open output file %s as stdout
+
+(F) An error peculiar to VMS. Perl does its own command line redirection, and
+couldn't open the file specified after 'E<gt>' or 'E<gt>E<gt>' on the command
+line for writing.
+
+=item Can't open output pipe (name: %s)
+
+(P) An error peculiar to VMS. Perl does its own command line redirection, and
+couldn't open the pipe into which to send data destined for stdout.
+
+=item Can't open perl script "%s": %s
+
+(F) The script you specified can't be opened for the indicated reason.
+
+=item Can't redefine active sort subroutine %s
+
+(F) Perl optimizes the internal handling of sort subroutines and keeps
+pointers into them. You tried to redefine one such sort subroutine when it
+was currently active, which is not allowed. If you really want to do
+this, you should write C<sort { &func } @x> instead of C<sort func @x>.
+
+=item Can't rename %s to %s: %s, skipping file
+
+(S) The rename done by the B<-i> switch failed for some reason, probably because
+you don't have write permission to the directory.
+
+=item Can't reopen input pipe (name: %s) in binary mode
+
+(P) An error peculiar to VMS. Perl thought stdin was a pipe, and tried to
+reopen it to accept binary data. Alas, it failed.
+
+=item Can't reswap uid and euid
+
+(P) The setreuid() call failed for some reason in the setuid emulator
+of suidperl.
+
+=item Can't return outside a subroutine
+
+(F) The return statement was executed in mainline code, that is, where
+there was no subroutine call to return out of. See L<perlsub>.
+
+=item Can't stat script "%s"
+
+(P) For some reason you can't fstat() the script even though you have
+it open already. Bizarre.
+
+=item Can't swap uid and euid
+
+(P) The setreuid() call failed for some reason in the setuid emulator
+of suidperl.
+
+=item Can't take log of %g
+
+(F) For ordinary real numbers, you can't take the logarithm of a
+negative number or zero. There's a Math::Complex package that comes
+standard with Perl, though, if you really want to do that for
+the negative numbers.
+
+=item Can't take sqrt of %g
+
+(F) For ordinary real numbers, you can't take the square root of a
+negative number. There's a Math::Complex package that comes standard
+with Perl, though, if you really want to do that.
+
+=item Can't undef active subroutine
+
+(F) You can't undefine a routine that's currently running. You can,
+however, redefine it while it's running, and you can even undef the
+redefined subroutine while the old routine is running. Go figure.
+
+=item Can't unshift
+
+(F) You tried to unshift an "unreal" array that can't be unshifted, such
+as the main Perl stack.
+
+=item Can't upgrade that kind of scalar
+
+(P) The internal sv_upgrade routine adds "members" to an SV, making
+it into a more specialized kind of SV. The top several SV types are
+so specialized, however, that they cannot be interconverted. This
+message indicates that such a conversion was attempted.
+
+=item Can't upgrade to undef
+
+(P) The undefined SV is the bottom of the totem pole, in the scheme
+of upgradability. Upgrading to undef indicates an error in the
+code calling sv_upgrade.
+
+=item Can't use %%! because Errno.pm is not available
+
+(F) The first time the %! hash is used, perl automatically loads the
+Errno.pm module. The Errno module is expected to tie the %! hash to
+provide symbolic names for C<$!> errno values.
+
+=item Can't use "my %s" in sort comparison
+
+(F) The global variables $a and $b are reserved for sort comparisons.
+You mentioned $a or $b in the same line as the E<lt>=E<gt> or cmp operator,
+and the variable had earlier been declared as a lexical variable.
+Either qualify the sort variable with the package name, or rename the
+lexical variable.
+
+=item Can't use %s for loop variable
+
+(F) Only a simple scalar variable may be used as a loop variable on a foreach.
+
+=item Can't use %s ref as %s ref
+
+(F) You've mixed up your reference types. You have to dereference a
+reference of the type needed. You can use the ref() function to
+test the type of the reference, if need be.
+
+=item Can't use \1 to mean $1 in expression
+
+(W) In an ordinary expression, backslash is a unary operator that creates
+a reference to its argument. The use of backslash to indicate a backreference
+to a matched substring is valid only as part of a regular expression pattern.
+Trying to do this in ordinary Perl code produces a value that prints
+out looking like SCALAR(0xdecaf). Use the $1 form instead.
+
+=item Can't use bareword ("%s") as %s ref while \"strict refs\" in use
+
+(F) Only hard references are allowed by "strict refs". Symbolic references
+are disallowed. See L<perlref>.
+
+=item Can't use string ("%s") as %s ref while "strict refs" in use
+
+(F) Only hard references are allowed by "strict refs". Symbolic references
+are disallowed. See L<perlref>.
+
+=item Can't use an undefined value as %s reference
+
+(F) A value used as either a hard reference or a symbolic reference must
+be a defined value. This helps to delurk some insidious errors.
+
+=item Can't use global %s in "my"
+
+(F) You tried to declare a magical variable as a lexical variable. This is
+not allowed, because the magic can be tied to only one location (namely
+the global variable) and it would be incredibly confusing to have
+variables in your program that looked like magical variables but
+weren't.
+
+=item Can't use subscript on %s
+
+(F) The compiler tried to interpret a bracketed expression as a
+subscript. But to the left of the brackets was an expression that
+didn't look like an array reference, or anything else subscriptable.
+
+=item Can't x= to read-only value
+
+(F) You tried to repeat a constant value (often the undefined value) with
+an assignment operator, which implies modifying the value itself.
+Perhaps you need to copy the value to a temporary, and repeat that.
+
+=item Cannot find an opnumber for "%s"
+
+(F) A string of a form C<CORE::word> was given to prototype(), but
+there is no builtin with the name C<word>.
+
+=item Cannot resolve method `%s' overloading `%s' in package `%s'
+
+(F|P) Error resolving overloading specified by a method name (as
+opposed to a subroutine reference): no such method callable via the
+package. If method name is C<???>, this is an internal error.
+
+=item Character class syntax [. .] is reserved for future extensions
+
+(W) Within regular expression character classes ([]) the syntax beginning
+with "[." and ending with ".]" is reserved for future extensions.
+If you need to represent those character sequences inside a regular
+expression character class, just quote the square brackets with the
+backslash: "\[." and ".\]".
+
+=item Character class syntax [: :] is reserved for future extensions
+
+(W) Within regular expression character classes ([]) the syntax beginning
+with "[:" and ending with ":]" is reserved for future extensions.
+If you need to represent those character sequences inside a regular
+expression character class, just quote the square brackets with the
+backslash: "\[:" and ":\]".
+
+=item Character class syntax [= =] is reserved for future extensions
+
+(W) Within regular expression character classes ([]) the syntax
+beginning with "[=" and ending with "=]" is reserved for future extensions.
+If you need to represent those character sequences inside a regular
+expression character class, just quote the square brackets with the
+backslash: "\[=" and "=\]".
+
+=item chmod: mode argument is missing initial 0
+
+(W) A novice will sometimes say
+
+ chmod 777, $filename
+
+not realizing that 777 will be interpreted as a decimal number, equivalent
+to 01411. Octal constants are introduced with a leading 0 in Perl, as in C.
+
+=item Close on unopened file E<lt>%sE<gt>
+
+(W) You tried to close a filehandle that was never opened.
+
+=item Compilation failed in require
+
+(F) Perl could not compile a file specified in a C<require> statement.
+Perl uses this generic message when none of the errors that it encountered
+were severe enough to halt compilation immediately.
+
+=item Complex regular subexpression recursion limit (%d) exceeded
+
+(W) The regular expression engine uses recursion in complex situations
+where back-tracking is required. Recursion depth is limited to 32766,
+or perhaps less in architectures where the stack cannot grow
+arbitrarily. ("Simple" and "medium" situations are handled without
+recursion and are not subject to a limit.) Try shortening the string
+under examination; looping in Perl code (e.g. with C<while>) rather
+than in the regular expression engine; or rewriting the regular
+expression so that it is simpler or backtracks less. (See L<perlbook>
+for information on I<Mastering Regular Expressions>.)
+
+=item connect() on closed fd
+
+(W) You tried to do a connect on a closed socket. Did you forget to check
+the return value of your socket() call? See L<perlfunc/connect>.
+
+=item Constant subroutine %s redefined
+
+(S) You redefined a subroutine which had previously been eligible for
+inlining. See L<perlsub/"Constant Functions"> for commentary and
+workarounds.
+
+=item Constant subroutine %s undefined
+
+(S) You undefined a subroutine which had previously been eligible for
+inlining. See L<perlsub/"Constant Functions"> for commentary and
+workarounds.
+
+=item Copy method did not return a reference
+
+(F) The method which overloads "=" is buggy. See L<overload/Copy Constructor>.
+
+=item Corrupt malloc ptr 0x%lx at 0x%lx
+
+(P) The malloc package that comes with Perl had an internal failure.
+
+=item corrupted regexp pointers
+
+(P) The regular expression engine got confused by what the regular
+expression compiler gave it.
+
+=item corrupted regexp program
+
+(P) The regular expression engine got passed a regexp program without
+a valid magic number.
+
+=item Deep recursion on subroutine "%s"
+
+(W) This subroutine has called itself (directly or indirectly) 100
+times more than it has returned. This probably indicates an infinite
+recursion, unless you're writing strange benchmark programs, in which
+case it indicates something else.
+
+=item Delimiter for here document is too long
+
+(F) In a here document construct like C<E<lt>E<lt>FOO>, the label
+C<FOO> is too long for Perl to handle. You have to be seriously
+twisted to write code that triggers this error.
+
+=item Did you mean &%s instead?
+
+(W) You probably referred to an imported subroutine &FOO as $FOO or some such.
+
+=item Did you mean $ or @ instead of %?
+
+(W) You probably said %hash{$key} when you meant $hash{$key} or @hash{@keys}.
+On the other hand, maybe you just meant %hash and got carried away.
+
+=item Died
+
+(F) You passed die() an empty string (the equivalent of C<die "">) or
+you called it with no args and both C<$@> and C<$_> were empty.
+
+=item Do you need to predeclare %s?
+
+(S) This is an educated guess made in conjunction with the message "%s
+found where operator expected". It often means a subroutine or module
+name is being referenced that hasn't been declared yet. This may be
+because of ordering problems in your file, or because of a missing
+"sub", "package", "require", or "use" statement. If you're
+referencing something that isn't defined yet, you don't actually have
+to define the subroutine or package before the current location. You
+can use an empty "sub foo;" or "package FOO;" to enter a "forward"
+declaration.
+
+=item Don't know how to handle magic of type '%s'
+
+(P) The internal handling of magical variables has been cursed.
+
+=item do_study: out of memory
+
+(P) This should have been caught by safemalloc() instead.
+
+=item Duplicate free() ignored
+
+(S) An internal routine called free() on something that had already
+been freed.
+
+=item elseif should be elsif
+
+(S) There is no keyword "elseif" in Perl because Larry thinks it's
+ugly. Your code will be interpreted as an attempt to call a method
+named "elseif" for the class returned by the following block. This is
+unlikely to be what you want.
+
+=item END failed--cleanup aborted
+
+(F) An untrapped exception was raised while executing an END subroutine.
+The interpreter is immediately exited.
+
+=item Error converting file specification %s
+
+(F) An error peculiar to VMS. Because Perl may have to deal with file
+specifications in either VMS or Unix syntax, it converts them to a
+single form when it must operate on them directly. Either you've
+passed an invalid file specification to Perl, or you've found a
+case the conversion routines don't handle. Drat.
+
+=item %s: Eval-group in insecure regular expression
+
+(F) Perl detected tainted data when trying to compile a regular expression
+that contains the C<(?{ ... })> zero-width assertion, which is unsafe.
+See L<perlre/(?{ code })>, and L<perlsec>.
+
+=item %s: Eval-group not allowed, use re 'eval'
+
+(F) A regular expression contained the C<(?{ ... })> zero-width assertion,
+but that construct is only allowed when the C<use re 'eval'> pragma is
+in effect. See L<perlre/(?{ code })>.
+
+=item %s: Eval-group not allowed at run time
+
+(F) Perl tried to compile a regular expression containing the C<(?{ ... })>
+zero-width assertion at run time, as it would when the pattern contains
+interpolated values. Since that is a security risk, it is not allowed.
+If you insist, you may still do this by explicitly building the pattern
+from an interpolated string at run time and using that in an eval().
+See L<perlre/(?{ code })>.
+
+=item Excessively long <> operator
+
+(F) The contents of a <> operator may not exceed the maximum size of a
+Perl identifier. If you're just trying to glob a long list of
+filenames, try using the glob() operator, or put the filenames into a
+variable and glob that.
+
+=item Execution of %s aborted due to compilation errors
+
+(F) The final summary message when a Perl compilation fails.
+
+=item Exiting eval via %s
+
+(W) You are exiting an eval by unconventional means, such as
+a goto, or a loop control statement.
+
+=item Exiting pseudo-block via %s
+
+(W) You are exiting a rather special block construct (like a sort block or
+subroutine) by unconventional means, such as a goto, or a loop control
+statement. See L<perlfunc/sort>.
+
+=item Exiting subroutine via %s
+
+(W) You are exiting a subroutine by unconventional means, such as
+a goto, or a loop control statement.
+
+=item Exiting substitution via %s
+
+(W) You are exiting a substitution by unconventional means, such as
+a return, a goto, or a loop control statement.
+
+=item Explicit blessing to '' (assuming package main)
+
+(W) You are blessing a reference to a zero length string. This has
+the effect of blessing the reference into the package main. This is
+usually not what you want. Consider providing a default target
+package, e.g. bless($ref, $p or 'MyPackage');
+
+=item Fatal VMS error at %s, line %d
+
+(P) An error peculiar to VMS. Something untoward happened in a VMS system
+service or RTL routine; Perl's exit status should provide more details. The
+filename in "at %s" and the line number in "line %d" tell you which section of
+the Perl source code is distressed.
+
+=item fcntl is not implemented
+
+(F) Your machine apparently doesn't implement fcntl(). What is this, a
+PDP-11 or something?
+
+=item Filehandle %s never opened
+
+(W) An I/O operation was attempted on a filehandle that was never initialized.
+You need to do an open() or a socket() call, or call a constructor from
+the FileHandle package.
+
+=item Filehandle %s opened for only input
+
+(W) You tried to write on a read-only filehandle. If you
+intended it to be a read-write filehandle, you needed to open it with
+"+E<lt>" or "+E<gt>" or "+E<gt>E<gt>" instead of with "E<lt>" or nothing. If
+you intended only to write the file, use "E<gt>" or "E<gt>E<gt>". See
+L<perlfunc/open>.
+
+=item Filehandle opened for only input
+
+(W) You tried to write on a read-only filehandle. If you
+intended it to be a read-write filehandle, you needed to open it with
+"+E<lt>" or "+E<gt>" or "+E<gt>E<gt>" instead of with "E<lt>" or nothing. If
+you intended only to write the file, use "E<gt>" or "E<gt>E<gt>". See
+L<perlfunc/open>.
+
+=item Final $ should be \$ or $name
+
+(F) You must now decide whether the final $ in a string was meant to be
+a literal dollar sign, or was meant to introduce a variable name
+that happens to be missing. So you have to put either the backslash or
+the name.
+
+=item Final @ should be \@ or @name
+
+(F) You must now decide whether the final @ in a string was meant to be
+a literal "at" sign, or was meant to introduce a variable name
+that happens to be missing. So you have to put either the backslash or
+the name.
+
+=item Format %s redefined
+
+(W) You redefined a format. To suppress this warning, say
+
+ {
+ local $^W = 0;
+ eval "format NAME =...";
+ }
+
+=item Format not terminated
+
+(F) A format must be terminated by a line with a solitary dot. Perl got
+to the end of your file without finding such a line.
+
+=item Found = in conditional, should be ==
+
+(W) You said
+
+ if ($foo = 123)
+
+when you meant
+
+ if ($foo == 123)
+
+(or something like that).
+
+=item gdbm store returned %d, errno %d, key "%s"
+
+(S) A warning from the GDBM_File extension that a store failed.
+
+=item gethostent not implemented
+
+(F) Your C library apparently doesn't implement gethostent(), probably
+because if it did, it'd feel morally obligated to return every hostname
+on the Internet.
+
+=item get{sock,peer}name() on closed fd
+
+(W) You tried to get a socket or peer socket name on a closed socket.
+Did you forget to check the return value of your socket() call?
+
+=item getpwnam returned invalid UIC %#o for user "%s"
+
+(S) A warning peculiar to VMS. The call to C<sys$getuai> underlying the
+C<getpwnam> operator returned an invalid UIC.
+
+
+=item Glob not terminated
+
+(F) The lexer saw a left angle bracket in a place where it was expecting
+a term, so it's looking for the corresponding right angle bracket, and not
+finding it. Chances are you left some needed parentheses out earlier in
+the line, and you really meant a "less than".
+
+=item Global symbol "%s" requires explicit package name
+
+(F) You've said "use strict vars", which indicates that all variables
+must either be lexically scoped (using "my"), or explicitly qualified to
+say which package the global variable is in (using "::").
+
+=item goto must have label
+
+(F) Unlike with "next" or "last", you're not allowed to goto an
+unspecified destination. See L<perlfunc/goto>.
+
+=item Had to create %s unexpectedly
+
+(S) A routine asked for a symbol from a symbol table that ought to have
+existed already, but for some reason it didn't, and had to be created on
+an emergency basis to prevent a core dump.
+
+=item Hash %%s missing the % in argument %d of %s()
+
+(D) Really old Perl let you omit the % on hash names in some spots. This
+is now heavily deprecated.
+
+=item Identifier too long
+
+(F) Perl limits identifiers (names for variables, functions, etc.) to
+about 250 characters for simple names, and somewhat more for compound
+names (like C<$A::B>). You've exceeded Perl's limits. Future
+versions of Perl are likely to eliminate these arbitrary limitations.
+
+=item Ill-formed logical name |%s| in prime_env_iter
+
+(W) A warning peculiar to VMS. A logical name was encountered when preparing
+to iterate over %ENV which violates the syntactic rules governing logical
+names. Because it cannot be translated normally, it is skipped, and will not
+appear in %ENV. This may be a benign occurrence, as some software packages
+might directly modify logical name tables and introduce nonstandard names,
+or it may indicate that a logical name table has been corrupted.
+
+=item Illegal character %s (carriage return)
+
+(F) A carriage return character was found in the input. This is an
+error, and not a warning, because carriage return characters can break
+multi-line strings, including here documents (e.g., C<print E<lt>E<lt>EOF;>).
+
+Under Unix, this error is usually caused by executing Perl code --
+either the main program, a module, or an eval'd string -- that was
+transferred over a network connection from a non-Unix system without
+properly converting the text file format.
+
+Under systems that use something other than '\n' to delimit lines of
+text, this error can also be caused by reading Perl code from a file
+handle that is in binary mode (as set by the C<binmode> operator).
+
+In either case, the Perl code in question will probably need to be
+converted with something like C<s/\x0D\x0A?/\n/g> before it can be
+executed.
+
+=item Illegal division by zero
+
+(F) You tried to divide a number by 0. Either something was wrong in your
+logic, or you need to put a conditional in to guard against meaningless input.
+
+=item Illegal modulus zero
+
+(F) You tried to divide a number by 0 to get the remainder. Most numbers
+don't take to this kindly.
+
+=item Illegal octal digit
+
+(F) You used an 8 or 9 in a octal number.
+
+=item Illegal octal digit ignored
+
+(W) You may have tried to use an 8 or 9 in a octal number. Interpretation
+of the octal number stopped before the 8 or 9.
+
+=item Illegal hex digit ignored
+
+(W) You may have tried to use a character other than 0 - 9 or A - F in a
+hexadecimal number. Interpretation of the hexadecimal number stopped
+before the illegal character.
+
+=item Illegal switch in PERL5OPT: %s
+
+(X) The PERL5OPT environment variable may only be used to set the
+following switches: B<-[DIMUdmw]>.
+
+=item In string, @%s now must be written as \@%s
+
+(F) It used to be that Perl would try to guess whether you wanted an
+array interpolated or a literal @. It did this when the string was first
+used at runtime. Now strings are parsed at compile time, and ambiguous
+instances of @ must be disambiguated, either by prepending a backslash to
+indicate a literal, or by declaring (or using) the array within the
+program before the string (lexically). (Someday it will simply assume
+that an unbackslashed @ interpolates an array.)
+
+=item Insecure dependency in %s
+
+(F) You tried to do something that the tainting mechanism didn't like.
+The tainting mechanism is turned on when you're running setuid or setgid,
+or when you specify B<-T> to turn it on explicitly. The tainting mechanism
+labels all data that's derived directly or indirectly from the user,
+who is considered to be unworthy of your trust. If any such data is
+used in a "dangerous" operation, you get this error. See L<perlsec>
+for more information.
+
+=item Insecure directory in %s
+
+(F) You can't use system(), exec(), or a piped open in a setuid or setgid
+script if C<$ENV{PATH}> contains a directory that is writable by the world.
+See L<perlsec>.
+
+=item Insecure $ENV{%s} while running %s
+
+(F) You can't use system(), exec(), or a piped open in a setuid or
+setgid script if any of C<$ENV{PATH}>, C<$ENV{IFS}>, C<$ENV{CDPATH}>,
+C<$ENV{ENV}> or C<$ENV{BASH_ENV}> are derived from data supplied (or
+potentially supplied) by the user. The script must set the path to a
+known value, using trustworthy data. See L<perlsec>.
+
+=item Integer overflow in hex number
+
+(S) The literal hex number you have specified is too big for your
+architecture. On a 32-bit architecture the largest hex literal is
+0xFFFFFFFF.
+
+=item Integer overflow in octal number
+
+(S) The literal octal number you have specified is too big for your
+architecture. On a 32-bit architecture the largest octal literal is
+037777777777.
+
+=item Internal inconsistency in tracking vforks
+
+(S) A warning peculiar to VMS. Perl keeps track of the number
+of times you've called C<fork> and C<exec>, to determine
+whether the current call to C<exec> should affect the current
+script or a subprocess (see L<perlvms/exec>). Somehow, this count
+has become scrambled, so Perl is making a guess and treating
+this C<exec> as a request to terminate the Perl script
+and execute the specified command.
+
+=item internal disaster in regexp
+
+(P) Something went badly wrong in the regular expression parser.
+
+=item internal error: glob failed
+
+(P) Something went wrong with the external program(s) used for C<glob>
+and C<E<lt>*.cE<gt>>. This may mean that your csh (C shell) is
+broken. If so, you should change all of the csh-related variables in
+config.sh: If you have tcsh, make the variables refer to it as if it
+were csh (e.g. C<full_csh='/usr/bin/tcsh'>); otherwise, make them all
+empty (except that C<d_csh> should be C<'undef'>) so that Perl will
+think csh is missing. In either case, after editing config.sh, run
+C<./Configure -S> and rebuild Perl.
+
+=item internal urp in regexp at /%s/
+
+(P) Something went badly awry in the regular expression parser.
+
+=item invalid [] range in regexp
+
+(F) The range specified in a character class had a minimum character
+greater than the maximum character. See L<perlre>.
+
+=item Invalid conversion in %s: "%s"
+
+(W) Perl does not understand the given format conversion.
+See L<perlfunc/sprintf>.
+
+=item Invalid type in pack: '%s'
+
+(F) The given character is not a valid pack type. See L<perlfunc/pack>.
+(W) The given character is not a valid pack type but used to be silently
+ignored.
+
+=item Invalid type in unpack: '%s'
+
+(F) The given character is not a valid unpack type. See L<perlfunc/unpack>.
+(W) The given character is not a valid unpack type but used to be silently
+ignored.
+
+=item ioctl is not implemented
+
+(F) Your machine apparently doesn't implement ioctl(), which is pretty
+strange for a machine that supports C.
+
+=item junk on end of regexp
+
+(P) The regular expression parser is confused.
+
+=item Label not found for "last %s"
+
+(F) You named a loop to break out of, but you're not currently in a
+loop of that name, not even if you count where you were called from.
+See L<perlfunc/last>.
+
+=item Label not found for "next %s"
+
+(F) You named a loop to continue, but you're not currently in a loop of
+that name, not even if you count where you were called from. See
+L<perlfunc/last>.
+
+=item Label not found for "redo %s"
+
+(F) You named a loop to restart, but you're not currently in a loop of
+that name, not even if you count where you were called from. See
+L<perlfunc/last>.
+
+=item listen() on closed fd
+
+(W) You tried to do a listen on a closed socket. Did you forget to check
+the return value of your socket() call? See L<perlfunc/listen>.
+
+=item Method for operation %s not found in package %s during blessing
+
+(F) An attempt was made to specify an entry in an overloading table that
+doesn't resolve to a valid subroutine. See L<overload>.
+
+=item Might be a runaway multi-line %s string starting on line %d
+
+(S) An advisory indicating that the previous error may have been caused
+by a missing delimiter on a string or pattern, because it eventually
+ended earlier on the current line.
+
+=item Misplaced _ in number
+
+(W) An underline in a decimal constant wasn't on a 3-digit boundary.
+
+=item Missing $ on loop variable
+
+(F) Apparently you've been programming in B<csh> too much. Variables are always
+mentioned with the $ in Perl, unlike in the shells, where it can vary from
+one line to the next.
+
+=item Missing comma after first argument to %s function
+
+(F) While certain functions allow you to specify a filehandle or an
+"indirect object" before the argument list, this ain't one of them.
+
+=item Missing operator before %s?
+
+(S) This is an educated guess made in conjunction with the message "%s
+found where operator expected". Often the missing operator is a comma.
+
+=item Missing right bracket
+
+(F) The lexer counted more opening curly brackets (braces) than closing ones.
+As a general rule, you'll find it's missing near the place you were last
+editing.
+
+=item Modification of a read-only value attempted
+
+(F) You tried, directly or indirectly, to change the value of a
+constant. You didn't, of course, try "2 = 1", because the compiler
+catches that. But an easy way to do the same thing is:
+
+ sub mod { $_[0] = 1 }
+ mod(2);
+
+Another way is to assign to a substr() that's off the end of the string.
+
+=item Modification of non-creatable array value attempted, subscript %d
+
+(F) You tried to make an array value spring into existence, and the
+subscript was probably negative, even counting from end of the array
+backwards.
+
+=item Modification of non-creatable hash value attempted, subscript "%s"
+
+(P) You tried to make a hash value spring into existence, and it couldn't
+be created for some peculiar reason.
+
+=item Module name must be constant
+
+(F) Only a bare module name is allowed as the first argument to a "use".
+
+=item msg%s not implemented
+
+(F) You don't have System V message IPC on your system.
+
+=item Multidimensional syntax %s not supported
+
+(W) Multidimensional arrays aren't written like C<$foo[1,2,3]>. They're written
+like C<$foo[1][2][3]>, as in C.
+
+=item Name "%s::%s" used only once: possible typo
+
+(W) Typographical errors often show up as unique variable names.
+If you had a good reason for having a unique name, then just mention
+it again somehow to suppress the message. The C<use vars> pragma is
+provided for just this purpose.
+
+=item Negative length
+
+(F) You tried to do a read/write/send/recv operation with a buffer length
+that is less than 0. This is difficult to imagine.
+
+=item nested *?+ in regexp
+
+(F) You can't quantify a quantifier without intervening parentheses. So
+things like ** or +* or ?* are illegal.
+
+Note, however, that the minimal matching quantifiers, C<*?>, C<+?>, and C<??> appear
+to be nested quantifiers, but aren't. See L<perlre>.
+
+=item No #! line
+
+(F) The setuid emulator requires that scripts have a well-formed #! line
+even on machines that don't support the #! construct.
+
+=item No %s allowed while running setuid
+
+(F) Certain operations are deemed to be too insecure for a setuid or setgid
+script to even be allowed to attempt. Generally speaking there will be
+another way to do what you want that is, if not secure, at least securable.
+See L<perlsec>.
+
+=item No B<-e> allowed in setuid scripts
+
+(F) A setuid script can't be specified by the user.
+
+=item No comma allowed after %s
+
+(F) A list operator that has a filehandle or "indirect object" is not
+allowed to have a comma between that and the following arguments.
+Otherwise it'd be just another one of the arguments.
+
+One possible cause for this is that you expected to have imported a
+constant to your name space with B<use> or B<import> while no such
+importing took place, it may for example be that your operating system
+does not support that particular constant. Hopefully you did use an
+explicit import list for the constants you expect to see, please see
+L<perlfunc/use> and L<perlfunc/import>. While an explicit import list
+would probably have caught this error earlier it naturally does not
+remedy the fact that your operating system still does not support that
+constant. Maybe you have a typo in the constants of the symbol import
+list of B<use> or B<import> or in the constant name at the line where
+this error was triggered?
+
+=item No command into which to pipe on command line
+
+(F) An error peculiar to VMS. Perl handles its own command line redirection,
+and found a '|' at the end of the command line, so it doesn't know where you
+want to pipe the output from this command.
+
+=item No DB::DB routine defined
+
+(F) The currently executing code was compiled with the B<-d> switch,
+but for some reason the perl5db.pl file (or some facsimile thereof)
+didn't define a routine to be called at the beginning of each
+statement. Which is odd, because the file should have been required
+automatically, and should have blown up the require if it didn't parse
+right.
+
+=item No dbm on this machine
+
+(P) This is counted as an internal error, because every machine should
+supply dbm nowadays, because Perl comes with SDBM. See L<SDBM_File>.
+
+=item No DBsub routine
+
+(F) The currently executing code was compiled with the B<-d> switch,
+but for some reason the perl5db.pl file (or some facsimile thereof)
+didn't define a DB::sub routine to be called at the beginning of each
+ordinary subroutine call.
+
+=item No error file after 2E<gt> or 2E<gt>E<gt> on command line
+
+(F) An error peculiar to VMS. Perl handles its own command line redirection,
+and found a '2E<gt>' or a '2E<gt>E<gt>' on the command line, but can't find
+the name of the file to which to write data destined for stderr.
+
+=item No input file after E<lt> on command line
+
+(F) An error peculiar to VMS. Perl handles its own command line redirection,
+and found a 'E<lt>' on the command line, but can't find the name of the file
+from which to read data for stdin.
+
+=item No output file after E<gt> on command line
+
+(F) An error peculiar to VMS. Perl handles its own command line redirection,
+and found a lone 'E<gt>' at the end of the command line, so it doesn't know
+where you wanted to redirect stdout.
+
+=item No output file after E<gt> or E<gt>E<gt> on command line
+
+(F) An error peculiar to VMS. Perl handles its own command line redirection,
+and found a 'E<gt>' or a 'E<gt>E<gt>' on the command line, but can't find the
+name of the file to which to write data destined for stdout.
+
+=item No Perl script found in input
+
+(F) You called C<perl -x>, but no line was found in the file beginning
+with #! and containing the word "perl".
+
+=item No setregid available
+
+(F) Configure didn't find anything resembling the setregid() call for
+your system.
+
+=item No setreuid available
+
+(F) Configure didn't find anything resembling the setreuid() call for
+your system.
+
+=item No space allowed after B<-I>
+
+(F) The argument to B<-I> must follow the B<-I> immediately with no
+intervening space.
+
+=item No such array field
+
+(F) You tried to access an array as a hash, but the field name used is
+not defined. The hash at index 0 should map all valid field names to
+array indices for that to work.
+
+=item No such field "%s" in variable %s of type %s
+
+(F) You tried to access a field of a typed variable where the type
+does not know about the field name. The field names are looked up in
+the %FIELDS hash in the type package at compile time. The %FIELDS hash
+is usually set up with the 'fields' pragma.
+
+=item No such pipe open
+
+(P) An error peculiar to VMS. The internal routine my_pclose() tried to
+close a pipe which hadn't been opened. This should have been caught earlier as
+an attempt to close an unopened filehandle.
+
+=item No such signal: SIG%s
+
+(W) You specified a signal name as a subscript to %SIG that was not recognized.
+Say C<kill -l> in your shell to see the valid signal names on your system.
+
+=item Not a CODE reference
+
+(F) Perl was trying to evaluate a reference to a code value (that is, a
+subroutine), but found a reference to something else instead. You can
+use the ref() function to find out what kind of ref it really was.
+See also L<perlref>.
+
+=item Not a format reference
+
+(F) I'm not sure how you managed to generate a reference to an anonymous
+format, but this indicates you did, and that it didn't exist.
+
+=item Not a GLOB reference
+
+(F) Perl was trying to evaluate a reference to a "typeglob" (that is,
+a symbol table entry that looks like C<*foo>), but found a reference to
+something else instead. You can use the ref() function to find out
+what kind of ref it really was. See L<perlref>.
+
+=item Not a HASH reference
+
+(F) Perl was trying to evaluate a reference to a hash value, but
+found a reference to something else instead. You can use the ref()
+function to find out what kind of ref it really was. See L<perlref>.
+
+=item Not a perl script
+
+(F) The setuid emulator requires that scripts have a well-formed #! line
+even on machines that don't support the #! construct. The line must
+mention perl.
+
+=item Not a SCALAR reference
+
+(F) Perl was trying to evaluate a reference to a scalar value, but
+found a reference to something else instead. You can use the ref()
+function to find out what kind of ref it really was. See L<perlref>.
+
+=item Not a subroutine reference
+
+(F) Perl was trying to evaluate a reference to a code value (that is, a
+subroutine), but found a reference to something else instead. You can
+use the ref() function to find out what kind of ref it really was.
+See also L<perlref>.
+
+=item Not a subroutine reference in overload table
+
+(F) An attempt was made to specify an entry in an overloading table that
+doesn't somehow point to a valid subroutine. See L<overload>.
+
+=item Not an ARRAY reference
+
+(F) Perl was trying to evaluate a reference to an array value, but
+found a reference to something else instead. You can use the ref()
+function to find out what kind of ref it really was. See L<perlref>.
+
+=item Not enough arguments for %s
+
+(F) The function requires more arguments than you specified.
+
+=item Not enough format arguments
+
+(W) A format specified more picture fields than the next line supplied.
+See L<perlform>.
+
+=item Null filename used
+
+(F) You can't require the null filename, especially because on many machines
+that means the current directory! See L<perlfunc/require>.
+
+=item Null picture in formline
+
+(F) The first argument to formline must be a valid format picture
+specification. It was found to be empty, which probably means you
+supplied it an uninitialized value. See L<perlform>.
+
+=item NULL OP IN RUN
+
+(P) Some internal routine called run() with a null opcode pointer.
+
+=item Null realloc
+
+(P) An attempt was made to realloc NULL.
+
+=item NULL regexp argument
+
+(P) The internal pattern matching routines blew it big time.
+
+=item NULL regexp parameter
+
+(P) The internal pattern matching routines are out of their gourd.
+
+=item Number too long
+
+(F) Perl limits the representation of decimal numbers in programs to about
+about 250 characters. You've exceeded that length. Future versions of
+Perl are likely to eliminate this arbitrary limitation. In the meantime,
+try using scientific notation (e.g. "1e6" instead of "1_000_000").
+
+=item Odd number of elements in hash assignment
+
+(S) You specified an odd number of elements to initialize a hash, which
+is odd, because hashes come in key/value pairs.
+
+=item Offset outside string
+
+(F) You tried to do a read/write/send/recv operation with an offset
+pointing outside the buffer. This is difficult to imagine.
+The sole exception to this is that C<sysread()>ing past the buffer
+will extend the buffer and zero pad the new area.
+
+=item oops: oopsAV
+
+(S) An internal warning that the grammar is screwed up.
+
+=item oops: oopsHV
+
+(S) An internal warning that the grammar is screwed up.
+
+=item Operation `%s': no method found, %s
+
+(F) An attempt was made to perform an overloaded operation for which
+no handler was defined. While some handlers can be autogenerated in
+terms of other handlers, there is no default handler for any
+operation, unless C<fallback> overloading key is specified to be
+true. See L<overload>.
+
+=item Operator or semicolon missing before %s
+
+(S) You used a variable or subroutine call where the parser was
+expecting an operator. The parser has assumed you really meant
+to use an operator, but this is highly likely to be incorrect.
+For example, if you say "*foo *foo" it will be interpreted as
+if you said "*foo * 'foo'".
+
+=item Out of memory for yacc stack
+
+(F) The yacc parser wanted to grow its stack so it could continue parsing,
+but realloc() wouldn't give it more memory, virtual or otherwise.
+
+=item Out of memory during request for %s
+
+(X|F) The malloc() function returned 0, indicating there was insufficient
+remaining memory (or virtual memory) to satisfy the request.
+
+The request was judged to be small, so the possibility to trap it
+depends on the way perl was compiled. By default it is not trappable.
+However, if compiled for this, Perl may use the contents of C<$^M> as
+an emergency pool after die()ing with this message. In this case the
+error is trappable I<once>.
+
+=item Out of memory during "large" request for %s
+
+(F) The malloc() function returned 0, indicating there was insufficient
+remaining memory (or virtual memory) to satisfy the request. However,
+the request was judged large enough (compile-time default is 64K), so
+a possibility to shut down by trapping this error is granted.
+
+=item Out of memory during ridiculously large request
+
+(F) You can't allocate more than 2^31+"small amount" bytes. This error
+is most likely to be caused by a typo in the Perl program. e.g., C<$arr[time]>
+instead of C<$arr[$time]>.
+
+=item page overflow
+
+(W) A single call to write() produced more lines than can fit on a page.
+See L<perlform>.
+
+=item panic: ck_grep
+
+(P) Failed an internal consistency check trying to compile a grep.
+
+=item panic: ck_split
+
+(P) Failed an internal consistency check trying to compile a split.
+
+=item panic: corrupt saved stack index
+
+(P) The savestack was requested to restore more localized values than there
+are in the savestack.
+
+=item panic: die %s
+
+(P) We popped the context stack to an eval context, and then discovered
+it wasn't an eval context.
+
+=item panic: do_match
+
+(P) The internal pp_match() routine was called with invalid operational data.
+
+=item panic: do_split
+
+(P) Something terrible went wrong in setting up for the split.
+
+=item panic: do_subst
+
+(P) The internal pp_subst() routine was called with invalid operational data.
+
+=item panic: do_trans
+
+(P) The internal do_trans() routine was called with invalid operational data.
+
+=item panic: frexp
+
+(P) The library function frexp() failed, making printf("%f") impossible.
+
+=item panic: goto
+
+(P) We popped the context stack to a context with the specified label,
+and then discovered it wasn't a context we know how to do a goto in.
+
+=item panic: INTERPCASEMOD
+
+(P) The lexer got into a bad state at a case modifier.
+
+=item panic: INTERPCONCAT
+
+(P) The lexer got into a bad state parsing a string with brackets.
+
+=item panic: last
+
+(P) We popped the context stack to a block context, and then discovered
+it wasn't a block context.
+
+=item panic: leave_scope clearsv
+
+(P) A writable lexical variable became read-only somehow within the scope.
+
+=item panic: leave_scope inconsistency
+
+(P) The savestack probably got out of sync. At least, there was an
+invalid enum on the top of it.
+
+=item panic: malloc
+
+(P) Something requested a negative number of bytes of malloc.
+
+=item panic: mapstart
+
+(P) The compiler is screwed up with respect to the map() function.
+
+=item panic: null array
+
+(P) One of the internal array routines was passed a null AV pointer.
+
+=item panic: pad_alloc
+
+(P) The compiler got confused about which scratch pad it was allocating
+and freeing temporaries and lexicals from.
+
+=item panic: pad_free curpad
+
+(P) The compiler got confused about which scratch pad it was allocating
+and freeing temporaries and lexicals from.
+
+=item panic: pad_free po
+
+(P) An invalid scratch pad offset was detected internally.
+
+=item panic: pad_reset curpad
+
+(P) The compiler got confused about which scratch pad it was allocating
+and freeing temporaries and lexicals from.
+
+=item panic: pad_sv po
+
+(P) An invalid scratch pad offset was detected internally.
+
+=item panic: pad_swipe curpad
+
+(P) The compiler got confused about which scratch pad it was allocating
+and freeing temporaries and lexicals from.
+
+=item panic: pad_swipe po
+
+(P) An invalid scratch pad offset was detected internally.
+
+=item panic: pp_iter
+
+(P) The foreach iterator got called in a non-loop context frame.
+
+=item panic: realloc
+
+(P) Something requested a negative number of bytes of realloc.
+
+=item panic: restartop
+
+(P) Some internal routine requested a goto (or something like it), and
+didn't supply the destination.
+
+=item panic: return
+
+(P) We popped the context stack to a subroutine or eval context, and
+then discovered it wasn't a subroutine or eval context.
+
+=item panic: scan_num
+
+(P) scan_num() got called on something that wasn't a number.
+
+=item panic: sv_insert
+
+(P) The sv_insert() routine was told to remove more string than there
+was string.
+
+=item panic: top_env
+
+(P) The compiler attempted to do a goto, or something weird like that.
+
+=item panic: yylex
+
+(P) The lexer got into a bad state while processing a case modifier.
+
+=item Parentheses missing around "%s" list
+
+(W) You said something like
+
+ my $foo, $bar = @_;
+
+when you meant
+
+ my ($foo, $bar) = @_;
+
+Remember that "my" and "local" bind closer than comma.
+
+=item Perl %3.3f required--this is only version %s, stopped
+
+(F) The module in question uses features of a version of Perl more recent
+than the currently running version. How long has it been since you upgraded,
+anyway? See L<perlfunc/require>.
+
+=item Permission denied
+
+(F) The setuid emulator in suidperl decided you were up to no good.
+
+=item pid %d not a child
+
+(W) A warning peculiar to VMS. Waitpid() was asked to wait for a process which
+isn't a subprocess of the current process. While this is fine from VMS'
+perspective, it's probably not what you intended.
+
+=item POSIX getpgrp can't take an argument
+
+(F) Your C compiler uses POSIX getpgrp(), which takes no argument, unlike
+the BSD version, which takes a pid.
+
+=item Possible attempt to put comments in qw() list
+
+(W) qw() lists contain items separated by whitespace; as with literal
+strings, comment characters are not ignored, but are instead treated
+as literal data. (You may have used different delimiters than the
+parentheses shown here; braces are also frequently used.)
+
+You probably wrote something like this:
+
+ @list = qw(
+ a # a comment
+ b # another comment
+ );
+
+when you should have written this:
+
+ @list = qw(
+ a
+ b
+ );
+
+If you really want comments, build your list the
+old-fashioned way, with quotes and commas:
+
+ @list = (
+ 'a', # a comment
+ 'b', # another comment
+ );
+
+=item Possible attempt to separate words with commas
+
+(W) qw() lists contain items separated by whitespace; therefore commas
+aren't needed to separate the items. (You may have used different
+delimiters than the parentheses shown here; braces are also frequently
+used.)
+
+You probably wrote something like this:
+
+ qw! a, b, c !;
+
+which puts literal commas into some of the list items. Write it without
+commas if you don't want them to appear in your data:
+
+ qw! a b c !;
+
+=item Possible memory corruption: %s overflowed 3rd argument
+
+(F) An ioctl() or fcntl() returned more than Perl was bargaining for.
+Perl guesses a reasonable buffer size, but puts a sentinel byte at the
+end of the buffer just in case. This sentinel byte got clobbered, and
+Perl assumes that memory is now corrupted. See L<perlfunc/ioctl>.
+
+=item Precedence problem: open %s should be open(%s)
+
+(S) The old irregular construct
+
+ open FOO || die;
+
+is now misinterpreted as
+
+ open(FOO || die);
+
+because of the strict regularization of Perl 5's grammar into unary
+and list operators. (The old open was a little of both.) You must
+put parentheses around the filehandle, or use the new "or" operator
+instead of "||".
+
+=item print on closed filehandle %s
+
+(W) The filehandle you're printing on got itself closed sometime before now.
+Check your logic flow.
+
+=item printf on closed filehandle %s
+
+(W) The filehandle you're writing to got itself closed sometime before now.
+Check your logic flow.
+
+=item Probable precedence problem on %s
+
+(W) The compiler found a bareword where it expected a conditional,
+which often indicates that an || or && was parsed as part of the
+last argument of the previous construct, for example:
+
+ open FOO || die;
+
+=item Prototype mismatch: %s vs %s
+
+(S) The subroutine being declared or defined had previously been declared
+or defined with a different function prototype.
+
+=item Range iterator outside integer range
+
+(F) One (or both) of the numeric arguments to the range operator ".."
+are outside the range which can be represented by integers internally.
+One possible workaround is to force Perl to use magical string
+increment by prepending "0" to your numbers.
+
+=item Read on closed filehandle E<lt>%sE<gt>
+
+(W) The filehandle you're reading from got itself closed sometime before now.
+Check your logic flow.
+
+=item Reallocation too large: %lx
+
+(F) You can't allocate more than 64K on an MS-DOS machine.
+
+=item Recompile perl with B<-D>DEBUGGING to use B<-D> switch
+
+(F) You can't use the B<-D> option unless the code to produce the
+desired output is compiled into Perl, which entails some overhead,
+which is why it's currently left out of your copy.
+
+=item Recursive inheritance detected in package '%s'
+
+(F) More than 100 levels of inheritance were used. Probably indicates
+an unintended loop in your inheritance hierarchy.
+
+=item Recursive inheritance detected while looking for method '%s' in package '%s'
+
+(F) More than 100 levels of inheritance were encountered while invoking a
+method. Probably indicates an unintended loop in your inheritance hierarchy.
+
+=item Reference found where even-sized list expected
+
+(W) You gave a single reference where Perl was expecting a list with
+an even number of elements (for assignment to a hash). This
+usually means that you used the anon hash constructor when you meant
+to use parens. In any case, a hash requires key/value B<pairs>.
+
+ %hash = { one => 1, two => 2, }; # WRONG
+ %hash = [ qw/ an anon array / ]; # WRONG
+ %hash = ( one => 1, two => 2, ); # right
+ %hash = qw( one 1 two 2 ); # also fine
+
+=item Reference miscount in sv_replace()
+
+(W) The internal sv_replace() function was handed a new SV with a
+reference count of other than 1.
+
+=item regexp *+ operand could be empty
+
+(F) The part of the regexp subject to either the * or + quantifier
+could match an empty string.
+
+=item regexp memory corruption
+
+(P) The regular expression engine got confused by what the regular
+expression compiler gave it.
+
+=item regexp out of space
+
+(P) A "can't happen" error, because safemalloc() should have caught it earlier.
+
+=item regexp too big
+
+(F) The current implementation of regular expressions uses shorts as
+address offsets within a string. Unfortunately this means that if
+the regular expression compiles to longer than 32767, it'll blow up.
+Usually when you want a regular expression this big, there is a better
+way to do it with multiple statements. See L<perlre>.
+
+=item Reversed %s= operator
+
+(W) You wrote your assignment operator backwards. The = must always
+comes last, to avoid ambiguity with subsequent unary operators.
+
+=item Runaway format
+
+(F) Your format contained the ~~ repeat-until-blank sequence, but it
+produced 200 lines at once, and the 200th line looked exactly like the
+199th line. Apparently you didn't arrange for the arguments to exhaust
+themselves, either by using ^ instead of @ (for scalar variables), or by
+shifting or popping (for array variables). See L<perlform>.
+
+=item Scalar value @%s[%s] better written as $%s[%s]
+
+(W) You've used an array slice (indicated by @) to select a single element of
+an array. Generally it's better to ask for a scalar value (indicated by $).
+The difference is that C<$foo[&bar]> always behaves like a scalar, both when
+assigning to it and when evaluating its argument, while C<@foo[&bar]> behaves
+like a list when you assign to it, and provides a list context to its
+subscript, which can do weird things if you're expecting only one subscript.
+
+On the other hand, if you were actually hoping to treat the array
+element as a list, you need to look into how references work, because
+Perl will not magically convert between scalars and lists for you. See
+L<perlref>.
+
+=item Scalar value @%s{%s} better written as $%s{%s}
+
+(W) You've used a hash slice (indicated by @) to select a single element of
+a hash. Generally it's better to ask for a scalar value (indicated by $).
+The difference is that C<$foo{&bar}> always behaves like a scalar, both when
+assigning to it and when evaluating its argument, while C<@foo{&bar}> behaves
+like a list when you assign to it, and provides a list context to its
+subscript, which can do weird things if you're expecting only one subscript.
+
+On the other hand, if you were actually hoping to treat the hash
+element as a list, you need to look into how references work, because
+Perl will not magically convert between scalars and lists for you. See
+L<perlref>.
+
+=item Script is not setuid/setgid in suidperl
+
+(F) Oddly, the suidperl program was invoked on a script without a setuid
+or setgid bit set. This doesn't make much sense.
+
+=item Search pattern not terminated
+
+(F) The lexer couldn't find the final delimiter of a // or m{}
+construct. Remember that bracketing delimiters count nesting level.
+Missing the leading C<$> from a variable C<$m> may cause this error.
+
+=item %sseek() on unopened file
+
+(W) You tried to use the seek() or sysseek() function on a filehandle that
+was either never opened or has since been closed.
+
+=item select not implemented
+
+(F) This machine doesn't implement the select() system call.
+
+=item sem%s not implemented
+
+(F) You don't have System V semaphore IPC on your system.
+
+=item semi-panic: attempt to dup freed string
+
+(S) The internal newSVsv() routine was called to duplicate a scalar
+that had previously been marked as free.
+
+=item Semicolon seems to be missing
+
+(W) A nearby syntax error was probably caused by a missing semicolon,
+or possibly some other missing operator, such as a comma.
+
+=item Send on closed socket
+
+(W) The filehandle you're sending to got itself closed sometime before now.
+Check your logic flow.
+
+=item Sequence (? incomplete
+
+(F) A regular expression ended with an incomplete extension (?.
+See L<perlre>.
+
+=item Sequence (?#... not terminated
+
+(F) A regular expression comment must be terminated by a closing
+parenthesis. Embedded parentheses aren't allowed. See L<perlre>.
+
+=item Sequence (?%s...) not implemented
+
+(F) A proposed regular expression extension has the character reserved
+but has not yet been written. See L<perlre>.
+
+=item Sequence (?%s...) not recognized
+
+(F) You used a regular expression extension that doesn't make sense.
+See L<perlre>.
+
+=item Server error
+
+Also known as "500 Server error".
+
+B<This is a CGI error, not a Perl error>.
+
+You need to make sure your script is executable, is accessible by the user
+CGI is running the script under (which is probably not the user account you
+tested it under), does not rely on any environment variables (like PATH)
+from the user it isn't running under, and isn't in a location where the CGI
+server can't find it, basically, more or less. Please see the following
+for more information:
+
+ http://www.perl.com/perl/faq/idiots-guide.html
+ http://www.perl.com/perl/faq/perl-cgi-faq.html
+ ftp://rtfm.mit.edu/pub/usenet/news.answers/www/cgi-faq
+ http://hoohoo.ncsa.uiuc.edu/cgi/interface.html
+ http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html
+
+=item setegid() not implemented
+
+(F) You tried to assign to C<$)>, and your operating system doesn't support
+the setegid() system call (or equivalent), or at least Configure didn't
+think so.
+
+=item seteuid() not implemented
+
+(F) You tried to assign to C<$E<gt>>, and your operating system doesn't support
+the seteuid() system call (or equivalent), or at least Configure didn't
+think so.
+
+=item setrgid() not implemented
+
+(F) You tried to assign to C<$(>, and your operating system doesn't support
+the setrgid() system call (or equivalent), or at least Configure didn't
+think so.
+
+=item setruid() not implemented
+
+(F) You tried to assign to C<$E<lt>>, and your operating system doesn't support
+the setruid() system call (or equivalent), or at least Configure didn't
+think so.
+
+=item Setuid/gid script is writable by world
+
+(F) The setuid emulator won't run a script that is writable by the world,
+because the world might have written on it already.
+
+=item shm%s not implemented
+
+(F) You don't have System V shared memory IPC on your system.
+
+=item shutdown() on closed fd
+
+(W) You tried to do a shutdown on a closed socket. Seems a bit superfluous.
+
+=item SIG%s handler "%s" not defined
+
+(W) The signal handler named in %SIG doesn't, in fact, exist. Perhaps you
+put it into the wrong package?
+
+=item sort is now a reserved word
+
+(F) An ancient error message that almost nobody ever runs into anymore.
+But before sort was a keyword, people sometimes used it as a filehandle.
+
+=item Sort subroutine didn't return a numeric value
+
+(F) A sort comparison routine must return a number. You probably blew
+it by not using C<E<lt>=E<gt>> or C<cmp>, or by not using them correctly.
+See L<perlfunc/sort>.
+
+=item Sort subroutine didn't return single value
+
+(F) A sort comparison subroutine may not return a list value with more
+or less than one element. See L<perlfunc/sort>.
+
+=item Split loop
+
+(P) The split was looping infinitely. (Obviously, a split shouldn't iterate
+more times than there are characters of input, which is what happened.)
+See L<perlfunc/split>.
+
+=item Stat on unopened file E<lt>%sE<gt>
+
+(W) You tried to use the stat() function (or an equivalent file test)
+on a filehandle that was either never opened or has since been closed.
+
+=item Statement unlikely to be reached
+
+(W) You did an exec() with some statement after it other than a die().
+This is almost always an error, because exec() never returns unless
+there was a failure. You probably wanted to use system() instead,
+which does return. To suppress this warning, put the exec() in a block
+by itself.
+
+=item Stub found while resolving method `%s' overloading `%s' in package `%s'
+
+(P) Overloading resolution over @ISA tree may be broken by importation stubs.
+Stubs should never be implicitely created, but explicit calls to C<can>
+may break this.
+
+=item Subroutine %s redefined
+
+(W) You redefined a subroutine. To suppress this warning, say
+
+ {
+ local $^W = 0;
+ eval "sub name { ... }";
+ }
+
+=item Substitution loop
+
+(P) The substitution was looping infinitely. (Obviously, a
+substitution shouldn't iterate more times than there are characters of
+input, which is what happened.) See the discussion of substitution in
+L<perlop/"Quote and Quote-like Operators">.
+
+=item Substitution pattern not terminated
+
+(F) The lexer couldn't find the interior delimiter of a s/// or s{}{}
+construct. Remember that bracketing delimiters count nesting level.
+Missing the leading C<$> from variable C<$s> may cause this error.
+
+=item Substitution replacement not terminated
+
+(F) The lexer couldn't find the final delimiter of a s/// or s{}{}
+construct. Remember that bracketing delimiters count nesting level.
+Missing the leading C<$> from variable C<$s> may cause this error.
+
+=item substr outside of string
+
+(S),(W) You tried to reference a substr() that pointed outside of a
+string. That is, the absolute value of the offset was larger than the
+length of the string. See L<perlfunc/substr>. This warning is
+mandatory if substr is used in an lvalue context (as the left hand side
+of an assignment or as a subroutine argument for example).
+
+=item suidperl is no longer needed since %s
+
+(F) Your Perl was compiled with B<-D>SETUID_SCRIPTS_ARE_SECURE_NOW, but a
+version of the setuid emulator somehow got run anyway.
+
+=item syntax error
+
+(F) Probably means you had a syntax error. Common reasons include:
+
+ A keyword is misspelled.
+ A semicolon is missing.
+ A comma is missing.
+ An opening or closing parenthesis is missing.
+ An opening or closing brace is missing.
+ A closing quote is missing.
+
+Often there will be another error message associated with the syntax
+error giving more information. (Sometimes it helps to turn on B<-w>.)
+The error message itself often tells you where it was in the line when
+it decided to give up. Sometimes the actual error is several tokens
+before this, because Perl is good at understanding random input.
+Occasionally the line number may be misleading, and once in a blue moon
+the only way to figure out what's triggering the error is to call
+C<perl -c> repeatedly, chopping away half the program each time to see
+if the error went away. Sort of the cybernetic version of S<20 questions>.
+
+=item syntax error at line %d: `%s' unexpected
+
+(A) You've accidentally run your script through the Bourne shell
+instead of Perl. Check the #! line, or manually feed your script
+into Perl yourself.
+
+=item System V %s is not implemented on this machine
+
+(F) You tried to do something with a function beginning with "sem",
+"shm", or "msg" but that System V IPC is not implemented in your
+machine. In some machines the functionality can exist but be
+unconfigured. Consult your system support.
+
+=item Syswrite on closed filehandle
+
+(W) The filehandle you're writing to got itself closed sometime before now.
+Check your logic flow.
+
+=item Target of goto is too deeply nested
+
+(F) You tried to use C<goto> to reach a label that was too deeply
+nested for Perl to reach. Perl is doing you a favor by refusing.
+
+=item tell() on unopened file
+
+(W) You tried to use the tell() function on a filehandle that was either
+never opened or has since been closed.
+
+=item Test on unopened file E<lt>%sE<gt>
+
+(W) You tried to invoke a file test operator on a filehandle that isn't
+open. Check your logic. See also L<perlfunc/-X>.
+
+=item That use of $[ is unsupported
+
+(F) Assignment to C<$[> is now strictly circumscribed, and interpreted as
+a compiler directive. You may say only one of
+
+ $[ = 0;
+ $[ = 1;
+ ...
+ local $[ = 0;
+ local $[ = 1;
+ ...
+
+This is to prevent the problem of one module changing the array base
+out from under another module inadvertently. See L<perlvar/$[>.
+
+=item The %s function is unimplemented
+
+The function indicated isn't implemented on this architecture, according
+to the probings of Configure.
+
+=item The crypt() function is unimplemented due to excessive paranoia
+
+(F) Configure couldn't find the crypt() function on your machine,
+probably because your vendor didn't supply it, probably because they
+think the U.S. Government thinks it's a secret, or at least that they
+will continue to pretend that it is. And if you quote me on that, I
+will deny it.
+
+=item The stat preceding C<-l _> wasn't an lstat
+
+(F) It makes no sense to test the current stat buffer for symbolic linkhood
+if the last stat that wrote to the stat buffer already went past
+the symlink to get to the real file. Use an actual filename instead.
+
+=item times not implemented
+
+(F) Your version of the C library apparently doesn't do times(). I suspect
+you're not running on Unix.
+
+=item Too few args to syscall
+
+(F) There has to be at least one argument to syscall() to specify the
+system call to call, silly dilly.
+
+=item Too late for "B<-T>" option
+
+(X) The #! line (or local equivalent) in a Perl script contains the
+B<-T> option, but Perl was not invoked with B<-T> in its command line.
+This is an error because, by the time Perl discovers a B<-T> in a
+script, it's too late to properly taint everything from the environment.
+So Perl gives up.
+
+If the Perl script is being executed as a command using the #!
+mechanism (or its local equivalent), this error can usually be fixed
+by editing the #! line so that the B<-T> option is a part of Perl's
+first argument: e.g. change C<perl -n -T> to C<perl -T -n>.
+
+If the Perl script is being executed as C<perl scriptname>, then the
+B<-T> option must appear on the command line: C<perl -T scriptname>.
+
+=item Too late for "-%s" option
+
+(X) The #! line (or local equivalent) in a Perl script contains the
+B<-M> or B<-m> option. This is an error because B<-M> and B<-m> options
+are not intended for use inside scripts. Use the C<use> pragma instead.
+
+=item Too many ('s
+
+=item Too many )'s
+
+(A) You've accidentally run your script through B<csh> instead
+of Perl. Check the #! line, or manually feed your script into
+Perl yourself.
+
+=item Too many args to syscall
+
+(F) Perl supports a maximum of only 14 args to syscall().
+
+=item Too many arguments for %s
+
+(F) The function requires fewer arguments than you specified.
+
+=item trailing \ in regexp
+
+(F) The regular expression ends with an unbackslashed backslash. Backslash
+it. See L<perlre>.
+
+=item Transliteration pattern not terminated
+
+(F) The lexer couldn't find the interior delimiter of a tr/// or tr[][]
+or y/// or y[][] construct. Missing the leading C<$> from variables
+C<$tr> or C<$y> may cause this error.
+
+=item Transliteration replacement not terminated
+
+(F) The lexer couldn't find the final delimiter of a tr/// or tr[][]
+construct.
+
+=item truncate not implemented
+
+(F) Your machine doesn't implement a file truncation mechanism that
+Configure knows about.
+
+=item Type of arg %d to %s must be %s (not %s)
+
+(F) This function requires the argument in that position to be of a
+certain type. Arrays must be @NAME or C<@{EXPR}>. Hashes must be
+%NAME or C<%{EXPR}>. No implicit dereferencing is allowed--use the
+{EXPR} forms as an explicit dereference. See L<perlref>.
+
+=item umask: argument is missing initial 0
+
+(W) A umask of 222 is incorrect. It should be 0222, because octal
+literals always start with 0 in Perl, as in C.
+
+=item umask not implemented
+
+(F) Your machine doesn't implement the umask function and you tried
+to use it to restrict permissions for yourself (EXPR & 0700).
+
+=item Unable to create sub named "%s"
+
+(F) You attempted to create or access a subroutine with an illegal name.
+
+=item Unbalanced context: %d more PUSHes than POPs
+
+(W) The exit code detected an internal inconsistency in how many execution
+contexts were entered and left.
+
+=item Unbalanced saves: %d more saves than restores
+
+(W) The exit code detected an internal inconsistency in how many
+values were temporarily localized.
+
+=item Unbalanced scopes: %d more ENTERs than LEAVEs
+
+(W) The exit code detected an internal inconsistency in how many blocks
+were entered and left.
+
+=item Unbalanced tmps: %d more allocs than frees
+
+(W) The exit code detected an internal inconsistency in how many mortal
+scalars were allocated and freed.
+
+=item Undefined format "%s" called
+
+(F) The format indicated doesn't seem to exist. Perhaps it's really in
+another package? See L<perlform>.
+
+=item Undefined sort subroutine "%s" called
+
+(F) The sort comparison routine specified doesn't seem to exist. Perhaps
+it's in a different package? See L<perlfunc/sort>.
+
+=item Undefined subroutine &%s called
+
+(F) The subroutine indicated hasn't been defined, or if it was, it
+has since been undefined.
+
+=item Undefined subroutine called
+
+(F) The anonymous subroutine you're trying to call hasn't been defined,
+or if it was, it has since been undefined.
+
+=item Undefined subroutine in sort
+
+(F) The sort comparison routine specified is declared but doesn't seem to
+have been defined yet. See L<perlfunc/sort>.
+
+=item Undefined top format "%s" called
+
+(F) The format indicated doesn't seem to exist. Perhaps it's really in
+another package? See L<perlform>.
+
+=item Undefined value assigned to typeglob
+
+(W) An undefined value was assigned to a typeglob, a la C<*foo = undef>.
+This does nothing. It's possible that you really mean C<undef *foo>.
+
+=item unexec of %s into %s failed!
+
+(F) The unexec() routine failed for some reason. See your local FSF
+representative, who probably put it there in the first place.
+
+=item Unknown BYTEORDER
+
+(F) There are no byte-swapping functions for a machine with this byte order.
+
+=item unmatched () in regexp
+
+(F) Unbackslashed parentheses must always be balanced in regular
+expressions. If you're a vi user, the % key is valuable for finding
+the matching parenthesis. See L<perlre>.
+
+=item Unmatched right bracket
+
+(F) The lexer counted more closing curly brackets (braces) than opening
+ones, so you're probably missing an opening bracket. As a general
+rule, you'll find the missing one (so to speak) near the place you were
+last editing.
+
+=item unmatched [] in regexp
+
+(F) The brackets around a character class must match. If you wish to
+include a closing bracket in a character class, backslash it or put it first.
+See L<perlre>.
+
+=item Unquoted string "%s" may clash with future reserved word
+
+(W) You used a bareword that might someday be claimed as a reserved word.
+It's best to put such a word in quotes, or capitalize it somehow, or insert
+an underbar into it. You might also declare it as a subroutine.
+
+=item Unrecognized character %s
+
+(F) The Perl parser has no idea what to do with the specified character
+in your Perl script (or eval). Perhaps you tried to run a compressed
+script, a binary program, or a directory as a Perl program.
+
+=item Unrecognized signal name "%s"
+
+(F) You specified a signal name to the kill() function that was not recognized.
+Say C<kill -l> in your shell to see the valid signal names on your system.
+
+=item Unrecognized switch: -%s (-h will show valid options)
+
+(F) You specified an illegal option to Perl. Don't do that.
+(If you think you didn't do that, check the #! line to see if it's
+supplying the bad switch on your behalf.)
+
+=item Unsuccessful %s on filename containing newline
+
+(W) A file operation was attempted on a filename, and that operation
+failed, PROBABLY because the filename contained a newline, PROBABLY
+because you forgot to chop() or chomp() it off. See L<perlfunc/chomp>.
+
+=item Unsupported directory function "%s" called
+
+(F) Your machine doesn't support opendir() and readdir().
+
+=item Unsupported function fork
+
+(F) Your version of executable does not support forking.
+
+Note that under some systems, like OS/2, there may be different flavors of
+Perl executables, some of which may support fork, some not. Try changing
+the name you call Perl by to C<perl_>, C<perl__>, and so on.
+
+=item Unsupported function %s
+
+(F) This machine doesn't implement the indicated function, apparently.
+At least, Configure doesn't think so.
+
+=item Unsupported socket function "%s" called
+
+(F) Your machine doesn't support the Berkeley socket mechanism, or at
+least that's what Configure thought.
+
+=item Unterminated E<lt>E<gt> operator
+
+(F) The lexer saw a left angle bracket in a place where it was expecting
+a term, so it's looking for the corresponding right angle bracket, and not
+finding it. Chances are you left some needed parentheses out earlier in
+the line, and you really meant a "less than".
+
+=item Use of "$$<digit>" to mean "${$}<digit>" is deprecated
+
+(D) Perl versions before 5.004 misinterpreted any type marker followed
+by "$" and a digit. For example, "$$0" was incorrectly taken to mean
+"${$}0" instead of "${$0}". This bug is (mostly) fixed in Perl 5.004.
+
+However, the developers of Perl 5.004 could not fix this bug completely,
+because at least two widely-used modules depend on the old meaning of
+"$$0" in a string. So Perl 5.004 still interprets "$$<digit>" in the
+old (broken) way inside strings; but it generates this message as a
+warning. And in Perl 5.005, this special treatment will cease.
+
+=item Use of $# is deprecated
+
+(D) This was an ill-advised attempt to emulate a poorly defined B<awk> feature.
+Use an explicit printf() or sprintf() instead.
+
+=item Use of $* is deprecated
+
+(D) This variable magically turned on multi-line pattern matching, both for
+you and for any luckless subroutine that you happen to call. You should
+use the new C<//m> and C<//s> modifiers now to do that without the dangerous
+action-at-a-distance effects of C<$*>.
+
+=item Use of %s in printf format not supported
+
+(F) You attempted to use a feature of printf that is accessible from
+only C. This usually means there's a better way to do it in Perl.
+
+=item Use of bare E<lt>E<lt> to mean E<lt>E<lt>"" is deprecated
+
+(D) You are now encouraged to use the explicitly quoted form if you
+wish to use an empty line as the terminator of the here-document.
+
+=item Use of implicit split to @_ is deprecated
+
+(D) It makes a lot of work for the compiler when you clobber a
+subroutine's argument list, so it's better if you assign the results of
+a split() explicitly to an array (or list).
+
+=item Use of inherited AUTOLOAD for non-method %s() is deprecated
+
+(D) As an (ahem) accidental feature, C<AUTOLOAD> subroutines are looked
+up as methods (using the C<@ISA> hierarchy) even when the subroutines to
+be autoloaded were called as plain functions (e.g. C<Foo::bar()>), not
+as methods (e.g. C<Foo-E<gt>bar()> or C<$obj-E<gt>bar()>).
+
+This bug will be rectified in Perl 5.005, which will use method lookup
+only for methods' C<AUTOLOAD>s. However, there is a significant base
+of existing code that may be using the old behavior. So, as an
+interim step, Perl 5.004 issues an optional warning when non-methods
+use inherited C<AUTOLOAD>s.
+
+The simple rule is: Inheritance will not work when autoloading
+non-methods. The simple fix for old code is: In any module that used to
+depend on inheriting C<AUTOLOAD> for non-methods from a base class named
+C<BaseClass>, execute C<*AUTOLOAD = \&BaseClass::AUTOLOAD> during startup.
+
+In code that currently says C<use AutoLoader; @ISA = qw(AutoLoader);> you
+should remove AutoLoader from @ISA and change C<use AutoLoader;> to
+C<use AutoLoader 'AUTOLOAD';>.
+
+=item Use of reserved word "%s" is deprecated
+
+(D) The indicated bareword is a reserved word. Future versions of perl
+may use it as a keyword, so you're better off either explicitly quoting
+the word in a manner appropriate for its context of use, or using a
+different name altogether. The warning can be suppressed for subroutine
+names by either adding a C<&> prefix, or using a package qualifier,
+e.g. C<&our()>, or C<Foo::our()>.
+
+=item Use of %s is deprecated
+
+(D) The construct indicated is no longer recommended for use, generally
+because there's a better way to do it, and also because the old way has
+bad side effects.
+
+=item Use of uninitialized value
+
+(W) An undefined value was used as if it were already defined. It was
+interpreted as a "" or a 0, but maybe it was a mistake. To suppress this
+warning assign an initial value to your variables.
+
+=item Useless use of "re" pragma
+
+(W) You did C<use re;> without any arguments. That isn't very useful.
+
+=item Useless use of %s in void context
+
+(W) You did something without a side effect in a context that does nothing
+with the return value, such as a statement that doesn't return a value
+from a block, or the left side of a scalar comma operator. Very often
+this points not to stupidity on your part, but a failure of Perl to parse
+your program the way you thought it would. For example, you'd get this
+if you mixed up your C precedence with Python precedence and said
+
+ $one, $two = 1, 2;
+
+when you meant to say
+
+ ($one, $two) = (1, 2);
+
+Another common error is to use ordinary parentheses to construct a list
+reference when you should be using square or curly brackets, for
+example, if you say
+
+ $array = (1,2);
+
+when you should have said
+
+ $array = [1,2];
+
+The square brackets explicitly turn a list value into a scalar value,
+while parentheses do not. So when a parenthesized list is evaluated in
+a scalar context, the comma is treated like C's comma operator, which
+throws away the left argument, which is not what you want. See
+L<perlref> for more on this.
+
+=item untie attempted while %d inner references still exist
+
+(W) A copy of the object returned from C<tie> (or C<tied>) was still
+valid when C<untie> was called.
+
+=item Value of %s can be "0"; test with defined()
+
+(W) In a conditional expression, you used <HANDLE>, <*> (glob), C<each()>,
+or C<readdir()> as a boolean value. Each of these constructs can return a
+value of "0"; that would make the conditional expression false, which is
+probably not what you intended. When using these constructs in conditional
+expressions, test their values with the C<defined> operator.
+
+=item Variable "%s" is not imported%s
+
+(F) While "use strict" in effect, you referred to a global variable
+that you apparently thought was imported from another module, because
+something else of the same name (usually a subroutine) is exported
+by that module. It usually means you put the wrong funny character
+on the front of your variable.
+
+=item Variable "%s" may be unavailable
+
+(W) An inner (nested) I<anonymous> subroutine is inside a I<named>
+subroutine, and outside that is another subroutine; and the anonymous
+(innermost) subroutine is referencing a lexical variable defined in
+the outermost subroutine. For example:
+
+ sub outermost { my $a; sub middle { sub { $a } } }
+
+If the anonymous subroutine is called or referenced (directly or
+indirectly) from the outermost subroutine, it will share the variable
+as you would expect. But if the anonymous subroutine is called or
+referenced when the outermost subroutine is not active, it will see
+the value of the shared variable as it was before and during the
+*first* call to the outermost subroutine, which is probably not what
+you want.
+
+In these circumstances, it is usually best to make the middle
+subroutine anonymous, using the C<sub {}> syntax. Perl has specific
+support for shared variables in nested anonymous subroutines; a named
+subroutine in between interferes with this feature.
+
+=item Variable "%s" will not stay shared
+
+(W) An inner (nested) I<named> subroutine is referencing a lexical
+variable defined in an outer subroutine.
+
+When the inner subroutine is called, it will probably see the value of
+the outer subroutine's variable as it was before and during the
+*first* call to the outer subroutine; in this case, after the first
+call to the outer subroutine is complete, the inner and outer
+subroutines will no longer share a common value for the variable. In
+other words, the variable will no longer be shared.
+
+Furthermore, if the outer subroutine is anonymous and references a
+lexical variable outside itself, then the outer and inner subroutines
+will I<never> share the given variable.
+
+This problem can usually be solved by making the inner subroutine
+anonymous, using the C<sub {}> syntax. When inner anonymous subs that
+reference variables in outer subroutines are called or referenced,
+they are automatically rebound to the current values of such
+variables.
+
+=item Variable syntax
+
+(A) You've accidentally run your script through B<csh> instead
+of Perl. Check the #! line, or manually feed your script into
+Perl yourself.
+
+=item perl: warning: Setting locale failed.
+
+(S) The whole warning message will look something like:
+
+ perl: warning: Setting locale failed.
+ perl: warning: Please check that your locale settings:
+ LC_ALL = "En_US",
+ LANG = (unset)
+ are supported and installed on your system.
+ perl: warning: Falling back to the standard locale ("C").
+
+Exactly what were the failed locale settings varies. In the above the
+settings were that the LC_ALL was "En_US" and the LANG had no value.
+This error means that Perl detected that you and/or your system
+administrator have set up the so-called variable system but Perl could
+not use those settings. This was not dead serious, fortunately: there
+is a "default locale" called "C" that Perl can and will use, the
+script will be run. Before you really fix the problem, however, you
+will get the same error message each time you run Perl. How to really
+fix the problem can be found in L<perllocale> section B<LOCALE PROBLEMS>.
+
+=item Warning: something's wrong
+
+(W) You passed warn() an empty string (the equivalent of C<warn "">) or
+you called it with no args and C<$_> was empty.
+
+=item Warning: unable to close filehandle %s properly
+
+(S) The implicit close() done by an open() got an error indication on the
+close(). This usually indicates your file system ran out of disk space.
+
+=item Warning: Use of "%s" without parentheses is ambiguous
+
+(S) You wrote a unary operator followed by something that looks like a
+binary operator that could also have been interpreted as a term or
+unary operator. For instance, if you know that the rand function
+has a default argument of 1.0, and you write
+
+ rand + 5;
+
+you may THINK you wrote the same thing as
+
+ rand() + 5;
+
+but in actual fact, you got
+
+ rand(+5);
+
+So put in parentheses to say what you really mean.
+
+=item Write on closed filehandle
+
+(W) The filehandle you're writing to got itself closed sometime before now.
+Check your logic flow.
+
+=item X outside of string
+
+(F) You had a pack template that specified a relative position before
+the beginning of the string being unpacked. See L<perlfunc/pack>.
+
+=item x outside of string
+
+(F) You had a pack template that specified a relative position after
+the end of the string being unpacked. See L<perlfunc/pack>.
+
+=item Xsub "%s" called in sort
+
+(F) The use of an external subroutine as a sort comparison is not yet supported.
+
+=item Xsub called in sort
+
+(F) The use of an external subroutine as a sort comparison is not yet supported.
+
+=item You can't use C<-l> on a filehandle
+
+(F) A filehandle represents an opened file, and when you opened the file it
+already went past any symlink you are presumably trying to look for.
+Use a filename instead.
+
+=item YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!
+
+(F) And you probably never will, because you probably don't have the
+sources to your kernel, and your vendor probably doesn't give a rip
+about what you want. Your best bet is to use the wrapsuid script in
+the eg directory to put a setuid C wrapper around your script.
+
+=item You need to quote "%s"
+
+(W) You assigned a bareword as a signal handler name. Unfortunately, you
+already have a subroutine of that name declared, which means that Perl 5
+will try to call the subroutine when the assignment is executed, which is
+probably not what you want. (If it IS what you want, put an & in front.)
+
+=item [gs]etsockopt() on closed fd
+
+(W) You tried to get or set a socket option on a closed socket.
+Did you forget to check the return value of your socket() call?
+See L<perlfunc/getsockopt>.
+
+=item \1 better written as $1
+
+(W) Outside of patterns, backreferences live on as variables. The use
+of backslashes is grandfathered on the right-hand side of a
+substitution, but stylistically it's better to use the variable form
+because other Perl programmers will expect it, and it works better
+if there are more than 9 backreferences.
+
+=item '|' and 'E<lt>' may not both be specified on command line
+
+(F) An error peculiar to VMS. Perl does its own command line redirection, and
+found that STDIN was a pipe, and that you also tried to redirect STDIN using
+'E<lt>'. Only one STDIN stream to a customer, please.
+
+=item '|' and 'E<gt>' may not both be specified on command line
+
+(F) An error peculiar to VMS. Perl does its own command line redirection, and
+thinks you tried to redirect stdout both to a file and into a pipe to another
+command. You need to choose one or the other, though nothing's stopping you
+from piping into a program or Perl script which 'splits' output into two
+streams, such as
+
+ open(OUT,">$ARGV[0]") or die "Can't write to $ARGV[0]: $!";
+ while (<STDIN>) {
+ print;
+ print OUT;
+ }
+ close OUT;
+
+=item Got an error from DosAllocMem
+
+(P) An error peculiar to OS/2. Most probably you're using an obsolete
+version of Perl, and this should not happen anyway.
+
+=item Malformed PERLLIB_PREFIX
+
+(F) An error peculiar to OS/2. PERLLIB_PREFIX should be of the form
+
+ prefix1;prefix2
+
+or
+
+ prefix1 prefix2
+
+with nonempty prefix1 and prefix2. If C<prefix1> is indeed a prefix
+of a builtin library search path, prefix2 is substituted. The error
+may appear if components are not found, or are too long. See
+"PERLLIB_PREFIX" in F<README.os2>.
+
+=item PERL_SH_DIR too long
+
+(F) An error peculiar to OS/2. PERL_SH_DIR is the directory to find the
+C<sh>-shell in. See "PERL_SH_DIR" in F<README.os2>.
+
+=item Process terminated by SIG%s
+
+(W) This is a standard message issued by OS/2 applications, while *nix
+applications die in silence. It is considered a feature of the OS/2
+port. One can easily disable this by appropriate sighandlers, see
+L<perlipc/"Signals">. See also "Process terminated by SIGTERM/SIGINT"
+in F<README.os2>.
+
+=back
+
diff --git a/contrib/perl5/pod/perldsc.pod b/contrib/perl5/pod/perldsc.pod
new file mode 100644
index 000000000000..d0cc33573610
--- /dev/null
+++ b/contrib/perl5/pod/perldsc.pod
@@ -0,0 +1,832 @@
+=head1 NAME
+
+perldsc - Perl Data Structures Cookbook
+
+=head1 DESCRIPTION
+
+The single feature most sorely lacking in the Perl programming language
+prior to its 5.0 release was complex data structures. Even without direct
+language support, some valiant programmers did manage to emulate them, but
+it was hard work and not for the faint of heart. You could occasionally
+get away with the C<$m{$LoL,$b}> notation borrowed from I<awk> in which the
+keys are actually more like a single concatenated string C<"$LoL$b">, but
+traversal and sorting were difficult. More desperate programmers even
+hacked Perl's internal symbol table directly, a strategy that proved hard
+to develop and maintain--to put it mildly.
+
+The 5.0 release of Perl let us have complex data structures. You
+may now write something like this and all of a sudden, you'd have a array
+with three dimensions!
+
+ for $x (1 .. 10) {
+ for $y (1 .. 10) {
+ for $z (1 .. 10) {
+ $LoL[$x][$y][$z] =
+ $x ** $y + $z;
+ }
+ }
+ }
+
+Alas, however simple this may appear, underneath it's a much more
+elaborate construct than meets the eye!
+
+How do you print it out? Why can't you say just C<print @LoL>? How do
+you sort it? How can you pass it to a function or get one of these back
+from a function? Is is an object? Can you save it to disk to read
+back later? How do you access whole rows or columns of that matrix? Do
+all the values have to be numeric?
+
+As you see, it's quite easy to become confused. While some small portion
+of the blame for this can be attributed to the reference-based
+implementation, it's really more due to a lack of existing documentation with
+examples designed for the beginner.
+
+This document is meant to be a detailed but understandable treatment of the
+many different sorts of data structures you might want to develop. It
+should also serve as a cookbook of examples. That way, when you need to
+create one of these complex data structures, you can just pinch, pilfer, or
+purloin a drop-in example from here.
+
+Let's look at each of these possible constructs in detail. There are separate
+sections on each of the following:
+
+=over 5
+
+=item * arrays of arrays
+
+=item * hashes of arrays
+
+=item * arrays of hashes
+
+=item * hashes of hashes
+
+=item * more elaborate constructs
+
+=back
+
+But for now, let's look at general issues common to all
+these types of data structures.
+
+=head1 REFERENCES
+
+The most important thing to understand about all data structures in Perl
+-- including multidimensional arrays--is that even though they might
+appear otherwise, Perl C<@ARRAY>s and C<%HASH>es are all internally
+one-dimensional. They can hold only scalar values (meaning a string,
+number, or a reference). They cannot directly contain other arrays or
+hashes, but instead contain I<references> to other arrays or hashes.
+
+You can't use a reference to a array or hash in quite the same way that you
+would a real array or hash. For C or C++ programmers unused to
+distinguishing between arrays and pointers to the same, this can be
+confusing. If so, just think of it as the difference between a structure
+and a pointer to a structure.
+
+You can (and should) read more about references in the perlref(1) man
+page. Briefly, references are rather like pointers that know what they
+point to. (Objects are also a kind of reference, but we won't be needing
+them right away--if ever.) This means that when you have something which
+looks to you like an access to a two-or-more-dimensional array and/or hash,
+what's really going on is that the base type is
+merely a one-dimensional entity that contains references to the next
+level. It's just that you can I<use> it as though it were a
+two-dimensional one. This is actually the way almost all C
+multidimensional arrays work as well.
+
+ $list[7][12] # array of arrays
+ $list[7]{string} # array of hashes
+ $hash{string}[7] # hash of arrays
+ $hash{string}{'another string'} # hash of hashes
+
+Now, because the top level contains only references, if you try to print
+out your array in with a simple print() function, you'll get something
+that doesn't look very nice, like this:
+
+ @LoL = ( [2, 3], [4, 5, 7], [0] );
+ print $LoL[1][2];
+ 7
+ print @LoL;
+ ARRAY(0x83c38)ARRAY(0x8b194)ARRAY(0x8b1d0)
+
+
+That's because Perl doesn't (ever) implicitly dereference your variables.
+If you want to get at the thing a reference is referring to, then you have
+to do this yourself using either prefix typing indicators, like
+C<${$blah}>, C<@{$blah}>, C<@{$blah[$i]}>, or else postfix pointer arrows,
+like C<$a-E<gt>[3]>, C<$h-E<gt>{fred}>, or even C<$ob-E<gt>method()-E<gt>[3]>.
+
+=head1 COMMON MISTAKES
+
+The two most common mistakes made in constructing something like
+an array of arrays is either accidentally counting the number of
+elements or else taking a reference to the same memory location
+repeatedly. Here's the case where you just get the count instead
+of a nested array:
+
+ for $i (1..10) {
+ @list = somefunc($i);
+ $LoL[$i] = @list; # WRONG!
+ }
+
+That's just the simple case of assigning a list to a scalar and getting
+its element count. If that's what you really and truly want, then you
+might do well to consider being a tad more explicit about it, like this:
+
+ for $i (1..10) {
+ @list = somefunc($i);
+ $counts[$i] = scalar @list;
+ }
+
+Here's the case of taking a reference to the same memory location
+again and again:
+
+ for $i (1..10) {
+ @list = somefunc($i);
+ $LoL[$i] = \@list; # WRONG!
+ }
+
+So, what's the big problem with that? It looks right, doesn't it?
+After all, I just told you that you need an array of references, so by
+golly, you've made me one!
+
+Unfortunately, while this is true, it's still broken. All the references
+in @LoL refer to the I<very same place>, and they will therefore all hold
+whatever was last in @list! It's similar to the problem demonstrated in
+the following C program:
+
+ #include <pwd.h>
+ main() {
+ struct passwd *getpwnam(), *rp, *dp;
+ rp = getpwnam("root");
+ dp = getpwnam("daemon");
+
+ printf("daemon name is %s\nroot name is %s\n",
+ dp->pw_name, rp->pw_name);
+ }
+
+Which will print
+
+ daemon name is daemon
+ root name is daemon
+
+The problem is that both C<rp> and C<dp> are pointers to the same location
+in memory! In C, you'd have to remember to malloc() yourself some new
+memory. In Perl, you'll want to use the array constructor C<[]> or the
+hash constructor C<{}> instead. Here's the right way to do the preceding
+broken code fragments:
+
+ for $i (1..10) {
+ @list = somefunc($i);
+ $LoL[$i] = [ @list ];
+ }
+
+The square brackets make a reference to a new array with a I<copy>
+of what's in @list at the time of the assignment. This is what
+you want.
+
+Note that this will produce something similar, but it's
+much harder to read:
+
+ for $i (1..10) {
+ @list = 0 .. $i;
+ @{$LoL[$i]} = @list;
+ }
+
+Is it the same? Well, maybe so--and maybe not. The subtle difference
+is that when you assign something in square brackets, you know for sure
+it's always a brand new reference with a new I<copy> of the data.
+Something else could be going on in this new case with the C<@{$LoL[$i]}}>
+dereference on the left-hand-side of the assignment. It all depends on
+whether C<$LoL[$i]> had been undefined to start with, or whether it
+already contained a reference. If you had already populated @LoL with
+references, as in
+
+ $LoL[3] = \@another_list;
+
+Then the assignment with the indirection on the left-hand-side would
+use the existing reference that was already there:
+
+ @{$LoL[3]} = @list;
+
+Of course, this I<would> have the "interesting" effect of clobbering
+@another_list. (Have you ever noticed how when a programmer says
+something is "interesting", that rather than meaning "intriguing",
+they're disturbingly more apt to mean that it's "annoying",
+"difficult", or both? :-)
+
+So just remember always to use the array or hash constructors with C<[]>
+or C<{}>, and you'll be fine, although it's not always optimally
+efficient.
+
+Surprisingly, the following dangerous-looking construct will
+actually work out fine:
+
+ for $i (1..10) {
+ my @list = somefunc($i);
+ $LoL[$i] = \@list;
+ }
+
+That's because my() is more of a run-time statement than it is a
+compile-time declaration I<per se>. This means that the my() variable is
+remade afresh each time through the loop. So even though it I<looks> as
+though you stored the same variable reference each time, you actually did
+not! This is a subtle distinction that can produce more efficient code at
+the risk of misleading all but the most experienced of programmers. So I
+usually advise against teaching it to beginners. In fact, except for
+passing arguments to functions, I seldom like to see the gimme-a-reference
+operator (backslash) used much at all in code. Instead, I advise
+beginners that they (and most of the rest of us) should try to use the
+much more easily understood constructors C<[]> and C<{}> instead of
+relying upon lexical (or dynamic) scoping and hidden reference-counting to
+do the right thing behind the scenes.
+
+In summary:
+
+ $LoL[$i] = [ @list ]; # usually best
+ $LoL[$i] = \@list; # perilous; just how my() was that list?
+ @{ $LoL[$i] } = @list; # way too tricky for most programmers
+
+
+=head1 CAVEAT ON PRECEDENCE
+
+Speaking of things like C<@{$LoL[$i]}>, the following are actually the
+same thing:
+
+ $listref->[2][2] # clear
+ $$listref[2][2] # confusing
+
+That's because Perl's precedence rules on its five prefix dereferencers
+(which look like someone swearing: C<$ @ * % &>) make them bind more
+tightly than the postfix subscripting brackets or braces! This will no
+doubt come as a great shock to the C or C++ programmer, who is quite
+accustomed to using C<*a[i]> to mean what's pointed to by the I<i'th>
+element of C<a>. That is, they first take the subscript, and only then
+dereference the thing at that subscript. That's fine in C, but this isn't C.
+
+The seemingly equivalent construct in Perl, C<$$listref[$i]> first does
+the deref of C<$listref>, making it take $listref as a reference to an
+array, and then dereference that, and finally tell you the I<i'th> value
+of the array pointed to by $LoL. If you wanted the C notion, you'd have to
+write C<${$LoL[$i]}> to force the C<$LoL[$i]> to get evaluated first
+before the leading C<$> dereferencer.
+
+=head1 WHY YOU SHOULD ALWAYS C<use strict>
+
+If this is starting to sound scarier than it's worth, relax. Perl has
+some features to help you avoid its most common pitfalls. The best
+way to avoid getting confused is to start every program like this:
+
+ #!/usr/bin/perl -w
+ use strict;
+
+This way, you'll be forced to declare all your variables with my() and
+also disallow accidental "symbolic dereferencing". Therefore if you'd done
+this:
+
+ my $listref = [
+ [ "fred", "barney", "pebbles", "bambam", "dino", ],
+ [ "homer", "bart", "marge", "maggie", ],
+ [ "george", "jane", "elroy", "judy", ],
+ ];
+
+ print $listref[2][2];
+
+The compiler would immediately flag that as an error I<at compile time>,
+because you were accidentally accessing C<@listref>, an undeclared
+variable, and it would thereby remind you to write instead:
+
+ print $listref->[2][2]
+
+=head1 DEBUGGING
+
+Before version 5.002, the standard Perl debugger didn't do a very nice job of
+printing out complex data structures. With 5.002 or above, the
+debugger includes several new features, including command line editing as
+well as the C<x> command to dump out complex data structures. For
+example, given the assignment to $LoL above, here's the debugger output:
+
+ DB<1> x $LoL
+ $LoL = ARRAY(0x13b5a0)
+ 0 ARRAY(0x1f0a24)
+ 0 'fred'
+ 1 'barney'
+ 2 'pebbles'
+ 3 'bambam'
+ 4 'dino'
+ 1 ARRAY(0x13b558)
+ 0 'homer'
+ 1 'bart'
+ 2 'marge'
+ 3 'maggie'
+ 2 ARRAY(0x13b540)
+ 0 'george'
+ 1 'jane'
+ 2 'elroy'
+ 3 'judy'
+
+=head1 CODE EXAMPLES
+
+Presented with little comment (these will get their own manpages someday)
+here are short code examples illustrating access of various
+types of data structures.
+
+=head1 LISTS OF LISTS
+
+=head2 Declaration of a LIST OF LISTS
+
+ @LoL = (
+ [ "fred", "barney" ],
+ [ "george", "jane", "elroy" ],
+ [ "homer", "marge", "bart" ],
+ );
+
+=head2 Generation of a LIST OF LISTS
+
+ # reading from file
+ while ( <> ) {
+ push @LoL, [ split ];
+ }
+
+ # calling a function
+ for $i ( 1 .. 10 ) {
+ $LoL[$i] = [ somefunc($i) ];
+ }
+
+ # using temp vars
+ for $i ( 1 .. 10 ) {
+ @tmp = somefunc($i);
+ $LoL[$i] = [ @tmp ];
+ }
+
+ # add to an existing row
+ push @{ $LoL[0] }, "wilma", "betty";
+
+=head2 Access and Printing of a LIST OF LISTS
+
+ # one element
+ $LoL[0][0] = "Fred";
+
+ # another element
+ $LoL[1][1] =~ s/(\w)/\u$1/;
+
+ # print the whole thing with refs
+ for $aref ( @LoL ) {
+ print "\t [ @$aref ],\n";
+ }
+
+ # print the whole thing with indices
+ for $i ( 0 .. $#LoL ) {
+ print "\t [ @{$LoL[$i]} ],\n";
+ }
+
+ # print the whole thing one at a time
+ for $i ( 0 .. $#LoL ) {
+ for $j ( 0 .. $#{ $LoL[$i] } ) {
+ print "elt $i $j is $LoL[$i][$j]\n";
+ }
+ }
+
+=head1 HASHES OF LISTS
+
+=head2 Declaration of a HASH OF LISTS
+
+ %HoL = (
+ flintstones => [ "fred", "barney" ],
+ jetsons => [ "george", "jane", "elroy" ],
+ simpsons => [ "homer", "marge", "bart" ],
+ );
+
+=head2 Generation of a HASH OF LISTS
+
+ # reading from file
+ # flintstones: fred barney wilma dino
+ while ( <> ) {
+ next unless s/^(.*?):\s*//;
+ $HoL{$1} = [ split ];
+ }
+
+ # reading from file; more temps
+ # flintstones: fred barney wilma dino
+ while ( $line = <> ) {
+ ($who, $rest) = split /:\s*/, $line, 2;
+ @fields = split ' ', $rest;
+ $HoL{$who} = [ @fields ];
+ }
+
+ # calling a function that returns a list
+ for $group ( "simpsons", "jetsons", "flintstones" ) {
+ $HoL{$group} = [ get_family($group) ];
+ }
+
+ # likewise, but using temps
+ for $group ( "simpsons", "jetsons", "flintstones" ) {
+ @members = get_family($group);
+ $HoL{$group} = [ @members ];
+ }
+
+ # append new members to an existing family
+ push @{ $HoL{"flintstones"} }, "wilma", "betty";
+
+=head2 Access and Printing of a HASH OF LISTS
+
+ # one element
+ $HoL{flintstones}[0] = "Fred";
+
+ # another element
+ $HoL{simpsons}[1] =~ s/(\w)/\u$1/;
+
+ # print the whole thing
+ foreach $family ( keys %HoL ) {
+ print "$family: @{ $HoL{$family} }\n"
+ }
+
+ # print the whole thing with indices
+ foreach $family ( keys %HoL ) {
+ print "family: ";
+ foreach $i ( 0 .. $#{ $HoL{$family} } ) {
+ print " $i = $HoL{$family}[$i]";
+ }
+ print "\n";
+ }
+
+ # print the whole thing sorted by number of members
+ foreach $family ( sort { @{$HoL{$b}} <=> @{$HoL{$a}} } keys %HoL ) {
+ print "$family: @{ $HoL{$family} }\n"
+ }
+
+ # print the whole thing sorted by number of members and name
+ foreach $family ( sort {
+ @{$HoL{$b}} <=> @{$HoL{$a}}
+ ||
+ $a cmp $b
+ } keys %HoL )
+ {
+ print "$family: ", join(", ", sort @{ $HoL{$family} }), "\n";
+ }
+
+=head1 LISTS OF HASHES
+
+=head2 Declaration of a LIST OF HASHES
+
+ @LoH = (
+ {
+ Lead => "fred",
+ Friend => "barney",
+ },
+ {
+ Lead => "george",
+ Wife => "jane",
+ Son => "elroy",
+ },
+ {
+ Lead => "homer",
+ Wife => "marge",
+ Son => "bart",
+ }
+ );
+
+=head2 Generation of a LIST OF HASHES
+
+ # reading from file
+ # format: LEAD=fred FRIEND=barney
+ while ( <> ) {
+ $rec = {};
+ for $field ( split ) {
+ ($key, $value) = split /=/, $field;
+ $rec->{$key} = $value;
+ }
+ push @LoH, $rec;
+ }
+
+
+ # reading from file
+ # format: LEAD=fred FRIEND=barney
+ # no temp
+ while ( <> ) {
+ push @LoH, { split /[\s+=]/ };
+ }
+
+ # calling a function that returns a key,value list, like
+ # "lead","fred","daughter","pebbles"
+ while ( %fields = getnextpairset() ) {
+ push @LoH, { %fields };
+ }
+
+ # likewise, but using no temp vars
+ while (<>) {
+ push @LoH, { parsepairs($_) };
+ }
+
+ # add key/value to an element
+ $LoH[0]{pet} = "dino";
+ $LoH[2]{pet} = "santa's little helper";
+
+=head2 Access and Printing of a LIST OF HASHES
+
+ # one element
+ $LoH[0]{lead} = "fred";
+
+ # another element
+ $LoH[1]{lead} =~ s/(\w)/\u$1/;
+
+ # print the whole thing with refs
+ for $href ( @LoH ) {
+ print "{ ";
+ for $role ( keys %$href ) {
+ print "$role=$href->{$role} ";
+ }
+ print "}\n";
+ }
+
+ # print the whole thing with indices
+ for $i ( 0 .. $#LoH ) {
+ print "$i is { ";
+ for $role ( keys %{ $LoH[$i] } ) {
+ print "$role=$LoH[$i]{$role} ";
+ }
+ print "}\n";
+ }
+
+ # print the whole thing one at a time
+ for $i ( 0 .. $#LoH ) {
+ for $role ( keys %{ $LoH[$i] } ) {
+ print "elt $i $role is $LoH[$i]{$role}\n";
+ }
+ }
+
+=head1 HASHES OF HASHES
+
+=head2 Declaration of a HASH OF HASHES
+
+ %HoH = (
+ flintstones => {
+ lead => "fred",
+ pal => "barney",
+ },
+ jetsons => {
+ lead => "george",
+ wife => "jane",
+ "his boy" => "elroy",
+ },
+ simpsons => {
+ lead => "homer",
+ wife => "marge",
+ kid => "bart",
+ },
+ );
+
+=head2 Generation of a HASH OF HASHES
+
+ # reading from file
+ # flintstones: lead=fred pal=barney wife=wilma pet=dino
+ while ( <> ) {
+ next unless s/^(.*?):\s*//;
+ $who = $1;
+ for $field ( split ) {
+ ($key, $value) = split /=/, $field;
+ $HoH{$who}{$key} = $value;
+ }
+
+
+ # reading from file; more temps
+ while ( <> ) {
+ next unless s/^(.*?):\s*//;
+ $who = $1;
+ $rec = {};
+ $HoH{$who} = $rec;
+ for $field ( split ) {
+ ($key, $value) = split /=/, $field;
+ $rec->{$key} = $value;
+ }
+ }
+
+ # calling a function that returns a key,value hash
+ for $group ( "simpsons", "jetsons", "flintstones" ) {
+ $HoH{$group} = { get_family($group) };
+ }
+
+ # likewise, but using temps
+ for $group ( "simpsons", "jetsons", "flintstones" ) {
+ %members = get_family($group);
+ $HoH{$group} = { %members };
+ }
+
+ # append new members to an existing family
+ %new_folks = (
+ wife => "wilma",
+ pet => "dino",
+ );
+
+ for $what (keys %new_folks) {
+ $HoH{flintstones}{$what} = $new_folks{$what};
+ }
+
+=head2 Access and Printing of a HASH OF HASHES
+
+ # one element
+ $HoH{flintstones}{wife} = "wilma";
+
+ # another element
+ $HoH{simpsons}{lead} =~ s/(\w)/\u$1/;
+
+ # print the whole thing
+ foreach $family ( keys %HoH ) {
+ print "$family: { ";
+ for $role ( keys %{ $HoH{$family} } ) {
+ print "$role=$HoH{$family}{$role} ";
+ }
+ print "}\n";
+ }
+
+ # print the whole thing somewhat sorted
+ foreach $family ( sort keys %HoH ) {
+ print "$family: { ";
+ for $role ( sort keys %{ $HoH{$family} } ) {
+ print "$role=$HoH{$family}{$role} ";
+ }
+ print "}\n";
+ }
+
+
+ # print the whole thing sorted by number of members
+ foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$a}} } keys %HoH ) {
+ print "$family: { ";
+ for $role ( sort keys %{ $HoH{$family} } ) {
+ print "$role=$HoH{$family}{$role} ";
+ }
+ print "}\n";
+ }
+
+ # establish a sort order (rank) for each role
+ $i = 0;
+ for ( qw(lead wife son daughter pal pet) ) { $rank{$_} = ++$i }
+
+ # now print the whole thing sorted by number of members
+ foreach $family ( sort { keys %{ $HoH{$b} } <=> keys %{ $HoH{$a} } } keys %HoH ) {
+ print "$family: { ";
+ # and print these according to rank order
+ for $role ( sort { $rank{$a} <=> $rank{$b} } keys %{ $HoH{$family} } ) {
+ print "$role=$HoH{$family}{$role} ";
+ }
+ print "}\n";
+ }
+
+
+=head1 MORE ELABORATE RECORDS
+
+=head2 Declaration of MORE ELABORATE RECORDS
+
+Here's a sample showing how to create and use a record whose fields are of
+many different sorts:
+
+ $rec = {
+ TEXT => $string,
+ SEQUENCE => [ @old_values ],
+ LOOKUP => { %some_table },
+ THATCODE => \&some_function,
+ THISCODE => sub { $_[0] ** $_[1] },
+ HANDLE => \*STDOUT,
+ };
+
+ print $rec->{TEXT};
+
+ print $rec->{LIST}[0];
+ $last = pop @ { $rec->{SEQUENCE} };
+
+ print $rec->{LOOKUP}{"key"};
+ ($first_k, $first_v) = each %{ $rec->{LOOKUP} };
+
+ $answer = $rec->{THATCODE}->($arg);
+ $answer = $rec->{THISCODE}->($arg1, $arg2);
+
+ # careful of extra block braces on fh ref
+ print { $rec->{HANDLE} } "a string\n";
+
+ use FileHandle;
+ $rec->{HANDLE}->autoflush(1);
+ $rec->{HANDLE}->print(" a string\n");
+
+=head2 Declaration of a HASH OF COMPLEX RECORDS
+
+ %TV = (
+ flintstones => {
+ series => "flintstones",
+ nights => [ qw(monday thursday friday) ],
+ members => [
+ { name => "fred", role => "lead", age => 36, },
+ { name => "wilma", role => "wife", age => 31, },
+ { name => "pebbles", role => "kid", age => 4, },
+ ],
+ },
+
+ jetsons => {
+ series => "jetsons",
+ nights => [ qw(wednesday saturday) ],
+ members => [
+ { name => "george", role => "lead", age => 41, },
+ { name => "jane", role => "wife", age => 39, },
+ { name => "elroy", role => "kid", age => 9, },
+ ],
+ },
+
+ simpsons => {
+ series => "simpsons",
+ nights => [ qw(monday) ],
+ members => [
+ { name => "homer", role => "lead", age => 34, },
+ { name => "marge", role => "wife", age => 37, },
+ { name => "bart", role => "kid", age => 11, },
+ ],
+ },
+ );
+
+=head2 Generation of a HASH OF COMPLEX RECORDS
+
+ # reading from file
+ # this is most easily done by having the file itself be
+ # in the raw data format as shown above. perl is happy
+ # to parse complex data structures if declared as data, so
+ # sometimes it's easiest to do that
+
+ # here's a piece by piece build up
+ $rec = {};
+ $rec->{series} = "flintstones";
+ $rec->{nights} = [ find_days() ];
+
+ @members = ();
+ # assume this file in field=value syntax
+ while (<>) {
+ %fields = split /[\s=]+/;
+ push @members, { %fields };
+ }
+ $rec->{members} = [ @members ];
+
+ # now remember the whole thing
+ $TV{ $rec->{series} } = $rec;
+
+ ###########################################################
+ # now, you might want to make interesting extra fields that
+ # include pointers back into the same data structure so if
+ # change one piece, it changes everywhere, like for examples
+ # if you wanted a {kids} field that was an array reference
+ # to a list of the kids' records without having duplicate
+ # records and thus update problems.
+ ###########################################################
+ foreach $family (keys %TV) {
+ $rec = $TV{$family}; # temp pointer
+ @kids = ();
+ for $person ( @{ $rec->{members} } ) {
+ if ($person->{role} =~ /kid|son|daughter/) {
+ push @kids, $person;
+ }
+ }
+ # REMEMBER: $rec and $TV{$family} point to same data!!
+ $rec->{kids} = [ @kids ];
+ }
+
+ # you copied the list, but the list itself contains pointers
+ # to uncopied objects. this means that if you make bart get
+ # older via
+
+ $TV{simpsons}{kids}[0]{age}++;
+
+ # then this would also change in
+ print $TV{simpsons}{members}[2]{age};
+
+ # because $TV{simpsons}{kids}[0] and $TV{simpsons}{members}[2]
+ # both point to the same underlying anonymous hash table
+
+ # print the whole thing
+ foreach $family ( keys %TV ) {
+ print "the $family";
+ print " is on during @{ $TV{$family}{nights} }\n";
+ print "its members are:\n";
+ for $who ( @{ $TV{$family}{members} } ) {
+ print " $who->{name} ($who->{role}), age $who->{age}\n";
+ }
+ print "it turns out that $TV{$family}{lead} has ";
+ print scalar ( @{ $TV{$family}{kids} } ), " kids named ";
+ print join (", ", map { $_->{name} } @{ $TV{$family}{kids} } );
+ print "\n";
+ }
+
+=head1 Database Ties
+
+You cannot easily tie a multilevel data structure (such as a hash of
+hashes) to a dbm file. The first problem is that all but GDBM and
+Berkeley DB have size limitations, but beyond that, you also have problems
+with how references are to be represented on disk. One experimental
+module that does partially attempt to address this need is the MLDBM
+module. Check your nearest CPAN site as described in L<perlmodlib> for
+source code to MLDBM.
+
+=head1 SEE ALSO
+
+perlref(1), perllol(1), perldata(1), perlobj(1)
+
+=head1 AUTHOR
+
+Tom Christiansen <F<tchrist@perl.com>>
+
+Last update:
+Wed Oct 23 04:57:50 MET DST 1996
diff --git a/contrib/perl5/pod/perlembed.pod b/contrib/perl5/pod/perlembed.pod
new file mode 100644
index 000000000000..c09d6e33cb52
--- /dev/null
+++ b/contrib/perl5/pod/perlembed.pod
@@ -0,0 +1,1029 @@
+=head1 NAME
+
+perlembed - how to embed perl in your C program
+
+=head1 DESCRIPTION
+
+=head2 PREAMBLE
+
+Do you want to:
+
+=over 5
+
+=item B<Use C from Perl?>
+
+Read L<perlxstut>, L<perlxs>, L<h2xs>, and L<perlguts>.
+
+=item B<Use a Unix program from Perl?>
+
+Read about back-quotes and about C<system> and C<exec> in L<perlfunc>.
+
+=item B<Use Perl from Perl?>
+
+Read about L<perlfunc/do> and L<perlfunc/eval> and L<perlfunc/require>
+and L<perlfunc/use>.
+
+=item B<Use C from C?>
+
+Rethink your design.
+
+=item B<Use Perl from C?>
+
+Read on...
+
+=back
+
+=head2 ROADMAP
+
+=over 5
+
+L<Compiling your C program>
+
+L<Adding a Perl interpreter to your C program>
+
+L<Calling a Perl subroutine from your C program>
+
+L<Evaluating a Perl statement from your C program>
+
+L<Performing Perl pattern matches and substitutions from your C program>
+
+L<Fiddling with the Perl stack from your C program>
+
+L<Maintaining a persistent interpreter>
+
+L<Maintaining multiple interpreter instances>
+
+L<Using Perl modules, which themselves use C libraries, from your C program>
+
+L<Embedding Perl under Win32>
+
+=back
+
+=head2 Compiling your C program
+
+If you have trouble compiling the scripts in this documentation,
+you're not alone. The cardinal rule: COMPILE THE PROGRAMS IN EXACTLY
+THE SAME WAY THAT YOUR PERL WAS COMPILED. (Sorry for yelling.)
+
+Also, every C program that uses Perl must link in the I<perl library>.
+What's that, you ask? Perl is itself written in C; the perl library
+is the collection of compiled C programs that were used to create your
+perl executable (I</usr/bin/perl> or equivalent). (Corollary: you
+can't use Perl from your C program unless Perl has been compiled on
+your machine, or installed properly--that's why you shouldn't blithely
+copy Perl executables from machine to machine without also copying the
+I<lib> directory.)
+
+When you use Perl from C, your C program will--usually--allocate,
+"run", and deallocate a I<PerlInterpreter> object, which is defined by
+the perl library.
+
+If your copy of Perl is recent enough to contain this documentation
+(version 5.002 or later), then the perl library (and I<EXTERN.h> and
+I<perl.h>, which you'll also need) will reside in a directory
+that looks like this:
+
+ /usr/local/lib/perl5/your_architecture_here/CORE
+
+or perhaps just
+
+ /usr/local/lib/perl5/CORE
+
+or maybe something like
+
+ /usr/opt/perl5/CORE
+
+Execute this statement for a hint about where to find CORE:
+
+ perl -MConfig -e 'print $Config{archlib}'
+
+Here's how you'd compile the example in the next section,
+L<Adding a Perl interpreter to your C program>, on my Linux box:
+
+ % gcc -O2 -Dbool=char -DHAS_BOOL -I/usr/local/include
+ -I/usr/local/lib/perl5/i586-linux/5.003/CORE
+ -L/usr/local/lib/perl5/i586-linux/5.003/CORE
+ -o interp interp.c -lperl -lm
+
+(That's all one line.) On my DEC Alpha running old 5.003_05, the
+incantation is a bit different:
+
+ % cc -O2 -Olimit 2900 -DSTANDARD_C -I/usr/local/include
+ -I/usr/local/lib/perl5/alpha-dec_osf/5.00305/CORE
+ -L/usr/local/lib/perl5/alpha-dec_osf/5.00305/CORE -L/usr/local/lib
+ -D__LANGUAGE_C__ -D_NO_PROTO -o interp interp.c -lperl -lm
+
+How can you figure out what to add? Assuming your Perl is post-5.001,
+execute a C<perl -V> command and pay special attention to the "cc" and
+"ccflags" information.
+
+You'll have to choose the appropriate compiler (I<cc>, I<gcc>, et al.) for
+your machine: C<perl -MConfig -e 'print $Config{cc}'> will tell you what
+to use.
+
+You'll also have to choose the appropriate library directory
+(I</usr/local/lib/...>) for your machine. If your compiler complains
+that certain functions are undefined, or that it can't locate
+I<-lperl>, then you need to change the path following the C<-L>. If it
+complains that it can't find I<EXTERN.h> and I<perl.h>, you need to
+change the path following the C<-I>.
+
+You may have to add extra libraries as well. Which ones?
+Perhaps those printed by
+
+ perl -MConfig -e 'print $Config{libs}'
+
+Provided your perl binary was properly configured and installed the
+B<ExtUtils::Embed> module will determine all of this information for
+you:
+
+ % cc -o interp interp.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
+
+If the B<ExtUtils::Embed> module isn't part of your Perl distribution,
+you can retrieve it from
+http://www.perl.com/perl/CPAN/modules/by-module/ExtUtils::Embed. (If
+this documentation came from your Perl distribution, then you're
+running 5.004 or better and you already have it.)
+
+The B<ExtUtils::Embed> kit on CPAN also contains all source code for
+the examples in this document, tests, additional examples and other
+information you may find useful.
+
+=head2 Adding a Perl interpreter to your C program
+
+In a sense, perl (the C program) is a good example of embedding Perl
+(the language), so I'll demonstrate embedding with I<miniperlmain.c>,
+included in the source distribution. Here's a bastardized, nonportable
+version of I<miniperlmain.c> containing the essentials of embedding:
+
+ #include <EXTERN.h> /* from the Perl distribution */
+ #include <perl.h> /* from the Perl distribution */
+
+ static PerlInterpreter *my_perl; /*** The Perl interpreter ***/
+
+ int main(int argc, char **argv, char **env)
+ {
+ my_perl = perl_alloc();
+ perl_construct(my_perl);
+ perl_parse(my_perl, NULL, argc, argv, (char **)NULL);
+ perl_run(my_perl);
+ perl_destruct(my_perl);
+ perl_free(my_perl);
+ }
+
+Notice that we don't use the C<env> pointer. Normally handed to
+C<perl_parse> as its final argument, C<env> here is replaced by
+C<NULL>, which means that the current environment will be used.
+
+Now compile this program (I'll call it I<interp.c>) into an executable:
+
+ % cc -o interp interp.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
+
+After a successful compilation, you'll be able to use I<interp> just
+like perl itself:
+
+ % interp
+ print "Pretty Good Perl \n";
+ print "10890 - 9801 is ", 10890 - 9801;
+ <CTRL-D>
+ Pretty Good Perl
+ 10890 - 9801 is 1089
+
+or
+
+ % interp -e 'printf("%x", 3735928559)'
+ deadbeef
+
+You can also read and execute Perl statements from a file while in the
+midst of your C program, by placing the filename in I<argv[1]> before
+calling I<perl_run>.
+
+=head2 Calling a Perl subroutine from your C program
+
+To call individual Perl subroutines, you can use any of the B<perl_call_*>
+functions documented in L<perlcall>.
+In this example we'll use C<perl_call_argv>.
+
+That's shown below, in a program I'll call I<showtime.c>.
+
+ #include <EXTERN.h>
+ #include <perl.h>
+
+ static PerlInterpreter *my_perl;
+
+ int main(int argc, char **argv, char **env)
+ {
+ char *args[] = { NULL };
+ my_perl = perl_alloc();
+ perl_construct(my_perl);
+
+ perl_parse(my_perl, NULL, argc, argv, NULL);
+
+ /*** skipping perl_run() ***/
+
+ perl_call_argv("showtime", G_DISCARD | G_NOARGS, args);
+
+ perl_destruct(my_perl);
+ perl_free(my_perl);
+ }
+
+where I<showtime> is a Perl subroutine that takes no arguments (that's the
+I<G_NOARGS>) and for which I'll ignore the return value (that's the
+I<G_DISCARD>). Those flags, and others, are discussed in L<perlcall>.
+
+I'll define the I<showtime> subroutine in a file called I<showtime.pl>:
+
+ print "I shan't be printed.";
+
+ sub showtime {
+ print time;
+ }
+
+Simple enough. Now compile and run:
+
+ % cc -o showtime showtime.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
+
+ % showtime showtime.pl
+ 818284590
+
+yielding the number of seconds that elapsed between January 1, 1970
+(the beginning of the Unix epoch), and the moment I began writing this
+sentence.
+
+In this particular case we don't have to call I<perl_run>, but in
+general it's considered good practice to ensure proper initialization
+of library code, including execution of all object C<DESTROY> methods
+and package C<END {}> blocks.
+
+If you want to pass arguments to the Perl subroutine, you can add
+strings to the C<NULL>-terminated C<args> list passed to
+I<perl_call_argv>. For other data types, or to examine return values,
+you'll need to manipulate the Perl stack. That's demonstrated in the
+last section of this document: L<Fiddling with the Perl stack from
+your C program>.
+
+=head2 Evaluating a Perl statement from your C program
+
+Perl provides two API functions to evaluate pieces of Perl code.
+These are L<perlguts/perl_eval_sv> and L<perlguts/perl_eval_pv>.
+
+Arguably, these are the only routines you'll ever need to execute
+snippets of Perl code from within your C program. Your code can be as
+long as you wish; it can contain multiple statements; it can employ
+L<perlfunc/use>, L<perlfunc/require>, and L<perlfunc/do> to
+include external Perl files.
+
+I<perl_eval_pv> lets us evaluate individual Perl strings, and then
+extract variables for coercion into C types. The following program,
+I<string.c>, executes three Perl strings, extracting an C<int> from
+the first, a C<float> from the second, and a C<char *> from the third.
+
+ #include <EXTERN.h>
+ #include <perl.h>
+
+ static PerlInterpreter *my_perl;
+
+ main (int argc, char **argv, char **env)
+ {
+ char *embedding[] = { "", "-e", "0" };
+
+ my_perl = perl_alloc();
+ perl_construct( my_perl );
+
+ perl_parse(my_perl, NULL, 3, embedding, NULL);
+ perl_run(my_perl);
+
+ /** Treat $a as an integer **/
+ perl_eval_pv("$a = 3; $a **= 2", TRUE);
+ printf("a = %d\n", SvIV(perl_get_sv("a", FALSE)));
+
+ /** Treat $a as a float **/
+ perl_eval_pv("$a = 3.14; $a **= 2", TRUE);
+ printf("a = %f\n", SvNV(perl_get_sv("a", FALSE)));
+
+ /** 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));
+
+ perl_destruct(my_perl);
+ perl_free(my_perl);
+ }
+
+All of those strange functions with I<sv> in their names help convert Perl scalars to C types. They're described in L<perlguts>.
+
+If you compile and run I<string.c>, you'll see the results of using
+I<SvIV()> to create an C<int>, I<SvNV()> to create a C<float>, and
+I<SvPV()> to create a string:
+
+ a = 9
+ a = 9.859600
+ a = Just Another Perl Hacker
+
+In the example above, we've created a global variable to temporarily
+store the computed value of our eval'd expression. It is also
+possible and in most cases a better strategy to fetch the return value
+from I<perl_eval_pv()> instead. Example:
+
+ ...
+ SV *val = perl_eval_pv("reverse 'rekcaH lreP rehtonA tsuJ'", TRUE);
+ printf("%s\n", SvPV(val,PL_na));
+ ...
+
+This way, we avoid namespace pollution by not creating global
+variables and we've simplified our code as well.
+
+=head2 Performing Perl pattern matches and substitutions from your C program
+
+The I<perl_eval_sv()> function lets us evaluate strings of Perl code, so we can
+define some functions that use it to "specialize" in matches and
+substitutions: I<match()>, I<substitute()>, and I<matches()>.
+
+ I32 match(SV *string, char *pattern);
+
+Given a string and a pattern (e.g., C<m/clasp/> or C</\b\w*\b/>, which
+in your C program might appear as "/\\b\\w*\\b/"), match()
+returns 1 if the string matches the pattern and 0 otherwise.
+
+ int substitute(SV **string, char *pattern);
+
+Given a pointer to an C<SV> and an C<=~> operation (e.g.,
+C<s/bob/robert/g> or C<tr[A-Z][a-z]>), substitute() modifies the string
+within the C<AV> at according to the operation, returning the number of substitutions
+made.
+
+ int matches(SV *string, char *pattern, AV **matches);
+
+Given an C<SV>, a pattern, and a pointer to an empty C<AV>,
+matches() evaluates C<$string =~ $pattern> in an array context, and
+fills in I<matches> with the array elements, returning the number of matches found.
+
+Here's a sample program, I<match.c>, that uses all three (long lines have
+been wrapped here):
+
+ #include <EXTERN.h>
+ #include <perl.h>
+
+ /** my_perl_eval_sv(code, error_check)
+ ** kinda like perl_eval_sv(),
+ ** but we pop the return value off the stack
+ **/
+ SV* my_perl_eval_sv(SV *sv, I32 croak_on_error)
+ {
+ dSP;
+ SV* retval;
+
+ PUSHMARK(SP);
+ perl_eval_sv(sv, G_SCALAR);
+
+ SPAGAIN;
+ retval = POPs;
+ PUTBACK;
+
+ if (croak_on_error && SvTRUE(ERRSV))
+ croak(SvPVx(ERRSV, PL_na));
+
+ return retval;
+ }
+
+ /** match(string, pattern)
+ **
+ ** Used for matches in a scalar context.
+ **
+ ** Returns 1 if the match was successful; 0 otherwise.
+ **/
+
+ I32 match(SV *string, char *pattern)
+ {
+ SV *command = NEWSV(1099, 0), *retval;
+
+ sv_setpvf(command, "my $string = '%s'; $string =~ %s",
+ SvPV(string,PL_na), pattern);
+
+ retval = my_perl_eval_sv(command, TRUE);
+ SvREFCNT_dec(command);
+
+ return SvIV(retval);
+ }
+
+ /** substitute(string, pattern)
+ **
+ ** Used for =~ operations that modify their left-hand side (s/// and tr///)
+ **
+ ** Returns the number of successful matches, and
+ ** modifies the input string if there were any.
+ **/
+
+ I32 substitute(SV **string, char *pattern)
+ {
+ SV *command = NEWSV(1099, 0), *retval;
+
+ sv_setpvf(command, "$string = '%s'; ($string =~ %s)",
+ SvPV(*string,PL_na), pattern);
+
+ retval = my_perl_eval_sv(command, TRUE);
+ SvREFCNT_dec(command);
+
+ *string = perl_get_sv("string", FALSE);
+ return SvIV(retval);
+ }
+
+ /** matches(string, pattern, matches)
+ **
+ ** Used for matches in an array context.
+ **
+ ** Returns the number of matches,
+ ** and fills in **matches with the matching substrings
+ **/
+
+ I32 matches(SV *string, char *pattern, AV **match_list)
+ {
+ SV *command = NEWSV(1099, 0);
+ I32 num_matches;
+
+ sv_setpvf(command, "my $string = '%s'; @array = ($string =~ %s)",
+ SvPV(string,PL_na), pattern);
+
+ my_perl_eval_sv(command, TRUE);
+ SvREFCNT_dec(command);
+
+ *match_list = perl_get_av("array", FALSE);
+ num_matches = av_len(*match_list) + 1; /** assume $[ is 0 **/
+
+ return num_matches;
+ }
+
+ main (int argc, char **argv, char **env)
+ {
+ PerlInterpreter *my_perl = perl_alloc();
+ char *embedding[] = { "", "-e", "0" };
+ AV *match_list;
+ I32 num_matches, i;
+ SV *text = NEWSV(1099,0);
+
+ perl_construct(my_perl);
+ perl_parse(my_perl, NULL, 3, embedding, NULL);
+
+ sv_setpv(text, "When he is at a convenience store and the bill comes to some amount like 76 cents, Maynard is aware that there is something he *should* do, something that will enable him to get back a quarter, but he has no idea *what*. He fumbles through his red squeezey changepurse and gives the boy three extra pennies with his dollar, hoping that he might luck into the correct amount. The boy gives him back two of his own pennies and then the big shiny quarter that is his prize. -RICHH");
+
+ if (match(text, "m/quarter/")) /** Does text contain 'quarter'? **/
+ printf("match: Text contains the word 'quarter'.\n\n");
+ else
+ printf("match: Text doesn't contain the word 'quarter'.\n\n");
+
+ if (match(text, "m/eighth/")) /** Does text contain 'eighth'? **/
+ printf("match: Text contains the word 'eighth'.\n\n");
+ else
+ printf("match: Text doesn't contain the word 'eighth'.\n\n");
+
+ /** Match all occurrences of /wi../ **/
+ num_matches = matches(text, "m/(wi..)/g", &match_list);
+ 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("\n");
+
+ /** Remove all vowels from text **/
+ num_matches = substitute(&text, "s/[aeiou]//gi");
+ 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));
+ }
+
+ /** Attempt a substitution **/
+ if (!substitute(&text, "s/Perl/C/")) {
+ printf("substitute: s/Perl/C...No substitution made.\n\n");
+ }
+
+ SvREFCNT_dec(text);
+ PL_perl_destruct_level = 1;
+ perl_destruct(my_perl);
+ perl_free(my_perl);
+ }
+
+which produces the output (again, long lines have been wrapped here)
+
+ match: Text contains the word 'quarter'.
+
+ match: Text doesn't contain the word 'eighth'.
+
+ matches: m/(wi..)/g found 2 matches...
+ match: will
+ match: with
+
+ substitute: s/[aeiou]//gi...139 substitutions made.
+ Now text is: Whn h s t cnvnnc str nd th bll cms t sm mnt lk 76 cnts,
+ Mynrd s wr tht thr s smthng h *shld* d, smthng tht wll nbl hm t gt bck
+ qrtr, bt h hs n d *wht*. H fmbls thrgh hs rd sqzy chngprs nd gvs th by
+ thr xtr pnns wth hs dllr, hpng tht h mght lck nt th crrct mnt. Th by gvs
+ hm bck tw f hs wn pnns nd thn th bg shny qrtr tht s hs prz. -RCHH
+
+ substitute: s/Perl/C...No substitution made.
+
+=head2 Fiddling with the Perl stack from your C program
+
+When trying to explain stacks, most computer science textbooks mumble
+something about spring-loaded columns of cafeteria plates: the last
+thing you pushed on the stack is the first thing you pop off. That'll
+do for our purposes: your C program will push some arguments onto "the Perl
+stack", shut its eyes while some magic happens, and then pop the
+results--the return value of your Perl subroutine--off the stack.
+
+First you'll need to know how to convert between C types and Perl
+types, with newSViv() and sv_setnv() and newAV() and all their
+friends. They're described in L<perlguts>.
+
+Then you'll need to know how to manipulate the Perl stack. That's
+described in L<perlcall>.
+
+Once you've understood those, embedding Perl in C is easy.
+
+Because C has no builtin function for integer exponentiation, let's
+make Perl's ** operator available to it (this is less useful than it
+sounds, because Perl implements ** with C's I<pow()> function). First
+I'll create a stub exponentiation function in I<power.pl>:
+
+ sub expo {
+ my ($a, $b) = @_;
+ return $a ** $b;
+ }
+
+Now I'll create a C program, I<power.c>, with a function
+I<PerlPower()> that contains all the perlguts necessary to push the
+two arguments into I<expo()> and to pop the return value out. Take a
+deep breath...
+
+ #include <EXTERN.h>
+ #include <perl.h>
+
+ static PerlInterpreter *my_perl;
+
+ static void
+ PerlPower(int a, int b)
+ {
+ dSP; /* initialize stack pointer */
+ ENTER; /* everything created after here */
+ SAVETMPS; /* ...is a temporary variable. */
+ PUSHMARK(SP); /* remember the stack pointer */
+ XPUSHs(sv_2mortal(newSViv(a))); /* push the base onto the stack */
+ XPUSHs(sv_2mortal(newSViv(b))); /* push the exponent onto stack */
+ PUTBACK; /* make local stack pointer global */
+ perl_call_pv("expo", G_SCALAR); /* call the function */
+ SPAGAIN; /* refresh stack pointer */
+ /* pop the return value from stack */
+ printf ("%d to the %dth power is %d.\n", a, b, POPi);
+ PUTBACK;
+ FREETMPS; /* free that return value */
+ LEAVE; /* ...and the XPUSHed "mortal" args.*/
+ }
+
+ int main (int argc, char **argv, char **env)
+ {
+ char *my_argv[] = { "", "power.pl" };
+
+ my_perl = perl_alloc();
+ perl_construct( my_perl );
+
+ perl_parse(my_perl, NULL, 2, my_argv, (char **)NULL);
+ perl_run(my_perl);
+
+ PerlPower(3, 4); /*** Compute 3 ** 4 ***/
+
+ perl_destruct(my_perl);
+ perl_free(my_perl);
+ }
+
+
+
+Compile and run:
+
+ % cc -o power power.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
+
+ % power
+ 3 to the 4th power is 81.
+
+=head2 Maintaining a persistent interpreter
+
+When developing interactive and/or potentially long-running
+applications, it's a good idea to maintain a persistent interpreter
+rather than allocating and constructing a new interpreter multiple
+times. The major reason is speed: since Perl will only be loaded into
+memory once.
+
+However, you have to be more cautious with namespace and variable
+scoping when using a persistent interpreter. In previous examples
+we've been using global variables in the default package C<main>. We
+knew exactly what code would be run, and assumed we could avoid
+variable collisions and outrageous symbol table growth.
+
+Let's say your application is a server that will occasionally run Perl
+code from some arbitrary file. Your server has no way of knowing what
+code it's going to run. Very dangerous.
+
+If the file is pulled in by C<perl_parse()>, compiled into a newly
+constructed interpreter, and subsequently cleaned out with
+C<perl_destruct()> afterwards, you're shielded from most namespace
+troubles.
+
+One way to avoid namespace collisions in this scenario is to translate
+the filename into a guaranteed-unique package name, and then compile
+the code into that package using L<perlfunc/eval>. In the example
+below, each file will only be compiled once. Or, the application
+might choose to clean out the symbol table associated with the file
+after it's no longer needed. Using L<perlcall/perl_call_argv>, We'll
+call the subroutine C<Embed::Persistent::eval_file> which lives in the
+file C<persistent.pl> and pass the filename and boolean cleanup/cache
+flag as arguments.
+
+Note that the process will continue to grow for each file that it
+uses. In addition, there might be C<AUTOLOAD>ed subroutines and other
+conditions that cause Perl's symbol table to grow. You might want to
+add some logic that keeps track of the process size, or restarts
+itself after a certain number of requests, to ensure that memory
+consumption is minimized. You'll also want to scope your variables
+with L<perlfunc/my> whenever possible.
+
+
+ package Embed::Persistent;
+ #persistent.pl
+
+ use strict;
+ use vars '%Cache';
+ use Symbol qw(delete_package);
+
+ sub valid_package_name {
+ my($string) = @_;
+ $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
+ # second pass only for words starting with a digit
+ $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
+
+ # Dress it up as a real package name
+ $string =~ s|/|::|g;
+ return "Embed" . $string;
+ }
+
+ sub eval_file {
+ my($filename, $delete) = @_;
+ my $package = valid_package_name($filename);
+ my $mtime = -M $filename;
+ if(defined $Cache{$package}{mtime}
+ &&
+ $Cache{$package}{mtime} <= $mtime)
+ {
+ # we have compiled this subroutine already,
+ # it has not been updated on disk, nothing left to do
+ print STDERR "already compiled $package->handler\n";
+ }
+ else {
+ local *FH;
+ open FH, $filename or die "open '$filename' $!";
+ local($/) = undef;
+ my $sub = <FH>;
+ close FH;
+
+ #wrap the code into a subroutine inside our unique package
+ my $eval = qq{package $package; sub handler { $sub; }};
+ {
+ # hide our variables within this block
+ my($filename,$mtime,$package,$sub);
+ eval $eval;
+ }
+ die $@ if $@;
+
+ #cache it unless we're cleaning out each time
+ $Cache{$package}{mtime} = $mtime unless $delete;
+ }
+
+ eval {$package->handler;};
+ die $@ if $@;
+
+ delete_package($package) if $delete;
+
+ #take a look if you want
+ #print Devel::Symdump->rnew($package)->as_string, $/;
+ }
+
+ 1;
+
+ __END__
+
+ /* persistent.c */
+ #include <EXTERN.h>
+ #include <perl.h>
+
+ /* 1 = clean out filename's symbol table after each request, 0 = don't */
+ #ifndef DO_CLEAN
+ #define DO_CLEAN 0
+ #endif
+
+ static PerlInterpreter *perl = NULL;
+
+ int
+ main(int argc, char **argv, char **env)
+ {
+ char *embedding[] = { "", "persistent.pl" };
+ char *args[] = { "", DO_CLEAN, NULL };
+ char filename [1024];
+ int exitstatus = 0;
+
+ if((perl = perl_alloc()) == NULL) {
+ fprintf(stderr, "no memory!");
+ exit(1);
+ }
+ perl_construct(perl);
+
+ exitstatus = perl_parse(perl, NULL, 2, embedding, NULL);
+
+ if(!exitstatus) {
+ exitstatus = perl_run(perl);
+
+ while(printf("Enter file name: ") && gets(filename)) {
+
+ /* call the subroutine, passing it the filename as an argument */
+ args[0] = filename;
+ perl_call_argv("Embed::Persistent::eval_file",
+ G_DISCARD | G_EVAL, args);
+
+ /* check $@ */
+ if(SvTRUE(ERRSV))
+ fprintf(stderr, "eval error: %s\n", SvPV(ERRSV,PL_na));
+ }
+ }
+
+ PL_perl_destruct_level = 0;
+ perl_destruct(perl);
+ perl_free(perl);
+ exit(exitstatus);
+ }
+
+Now compile:
+
+ % cc -o persistent persistent.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
+
+Here's a example script file:
+
+ #test.pl
+ my $string = "hello";
+ foo($string);
+
+ sub foo {
+ print "foo says: @_\n";
+ }
+
+Now run:
+
+ % persistent
+ Enter file name: test.pl
+ foo says: hello
+ Enter file name: test.pl
+ already compiled Embed::test_2epl->handler
+ foo says: hello
+ Enter file name: ^C
+
+=head2 Maintaining multiple interpreter instances
+
+Some rare applications will need to create more than one interpreter
+during a session. Such an application might sporadically decide to
+release any resources associated with the interpreter.
+
+The program must take care to ensure that this takes place I<before>
+the next interpreter is constructed. By default, the global variable
+C<PL_perl_destruct_level> is set to C<0>, since extra cleaning isn't
+needed when a program has only one interpreter.
+
+Setting C<PL_perl_destruct_level> to C<1> makes everything squeaky clean:
+
+ PL_perl_destruct_level = 1;
+
+ while(1) {
+ ...
+ /* reset global variables here with PL_perl_destruct_level = 1 */
+ perl_construct(my_perl);
+ ...
+ /* clean and reset _everything_ during perl_destruct */
+ perl_destruct(my_perl);
+ perl_free(my_perl);
+ ...
+ /* let's go do it again! */
+ }
+
+When I<perl_destruct()> is called, the interpreter's syntax parse tree
+and symbol tables are cleaned up, and global variables are reset.
+
+Now suppose we have more than one interpreter instance running at the
+same time. This is feasible, but only if you used the
+C<-DMULTIPLICITY> flag when building Perl. By default, that sets
+C<PL_perl_destruct_level> to C<1>.
+
+Let's give it a try:
+
+
+ #include <EXTERN.h>
+ #include <perl.h>
+
+ /* we're going to embed two interpreters */
+ /* we're going to embed two interpreters */
+
+ #define SAY_HELLO "-e", "print qq(Hi, I'm $^X\n)"
+
+ int main(int argc, char **argv, char **env)
+ {
+ PerlInterpreter
+ *one_perl = perl_alloc(),
+ *two_perl = perl_alloc();
+ char *one_args[] = { "one_perl", SAY_HELLO };
+ char *two_args[] = { "two_perl", SAY_HELLO };
+
+ perl_construct(one_perl);
+ perl_construct(two_perl);
+
+ perl_parse(one_perl, NULL, 3, one_args, (char **)NULL);
+ perl_parse(two_perl, NULL, 3, two_args, (char **)NULL);
+
+ perl_run(one_perl);
+ perl_run(two_perl);
+
+ perl_destruct(one_perl);
+ perl_destruct(two_perl);
+
+ perl_free(one_perl);
+ perl_free(two_perl);
+ }
+
+
+Compile as usual:
+
+ % cc -o multiplicity multiplicity.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
+
+Run it, Run it:
+
+ % multiplicity
+ Hi, I'm one_perl
+ Hi, I'm two_perl
+
+=head2 Using Perl modules, which themselves use C libraries, from your C program
+
+If you've played with the examples above and tried to embed a script
+that I<use()>s a Perl module (such as I<Socket>) which itself uses a C or C++ library,
+this probably happened:
+
+
+ Can't load module Socket, dynamic loading not available in this perl.
+ (You may need to build a new perl executable which either supports
+ dynamic loading or has the Socket module statically linked into it.)
+
+
+What's wrong?
+
+Your interpreter doesn't know how to communicate with these extensions
+on its own. A little glue will help. Up until now you've been
+calling I<perl_parse()>, handing it NULL for the second argument:
+
+ perl_parse(my_perl, NULL, argc, my_argv, NULL);
+
+That's where the glue code can be inserted to create the initial contact between
+Perl and linked C/C++ routines. Let's take a look some pieces of I<perlmain.c>
+to see how Perl does this:
+
+
+ #ifdef __cplusplus
+ # define EXTERN_C extern "C"
+ #else
+ # define EXTERN_C extern
+ #endif
+
+ static void xs_init _((void));
+
+ EXTERN_C void boot_DynaLoader _((CV* cv));
+ EXTERN_C void boot_Socket _((CV* cv));
+
+
+ EXTERN_C void
+ xs_init()
+ {
+ char *file = __FILE__;
+ /* DynaLoader is a special case */
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+ newXS("Socket::bootstrap", boot_Socket, file);
+ }
+
+Simply put: for each extension linked with your Perl executable
+(determined during its initial configuration on your
+computer or when adding a new extension),
+a Perl subroutine is created to incorporate the extension's
+routines. Normally, that subroutine is named
+I<Module::bootstrap()> and is invoked when you say I<use Module>. In
+turn, this hooks into an XSUB, I<boot_Module>, which creates a Perl
+counterpart for each of the extension's XSUBs. Don't worry about this
+part; leave that to the I<xsubpp> and extension authors. If your
+extension is dynamically loaded, DynaLoader creates I<Module::bootstrap()>
+for you on the fly. In fact, if you have a working DynaLoader then there
+is rarely any need to link in any other extensions statically.
+
+
+Once you have this code, slap it into the second argument of I<perl_parse()>:
+
+
+ perl_parse(my_perl, xs_init, argc, my_argv, NULL);
+
+
+Then compile:
+
+ % cc -o interp interp.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
+
+ % interp
+ use Socket;
+ use SomeDynamicallyLoadedModule;
+
+ print "Now I can use extensions!\n"'
+
+B<ExtUtils::Embed> can also automate writing the I<xs_init> glue code.
+
+ % perl -MExtUtils::Embed -e xsinit -- -o perlxsi.c
+ % cc -c perlxsi.c `perl -MExtUtils::Embed -e ccopts`
+ % cc -c interp.c `perl -MExtUtils::Embed -e ccopts`
+ % cc -o interp perlxsi.o interp.o `perl -MExtUtils::Embed -e ldopts`
+
+Consult L<perlxs> and L<perlguts> for more details.
+
+=head1 Embedding Perl under Win32
+
+At the time of this writing (5.004), there are two versions of Perl
+which run under Win32. (The two versions are merging in 5.005.)
+Interfacing to ActiveState's Perl library is quite different from the
+examples in this documentation, as significant changes were made to
+the internal Perl API. However, it is possible to embed ActiveState's
+Perl runtime. For details, see the Perl for Win32 FAQ at
+http://www.perl.com/perl/faq/win32/Perl_for_Win32_FAQ.html.
+
+With the "official" Perl version 5.004 or higher, all the examples
+within this documentation will compile and run untouched, although
+the build process is slightly different between Unix and Win32.
+
+For starters, backticks don't work under the Win32 native command shell.
+The ExtUtils::Embed kit on CPAN ships with a script called
+B<genmake>, which generates a simple makefile to build a program from
+a single C source file. It can be used like this:
+
+ C:\ExtUtils-Embed\eg> perl genmake interp.c
+ C:\ExtUtils-Embed\eg> nmake
+ C:\ExtUtils-Embed\eg> interp -e "print qq{I'm embedded in Win32!\n}"
+
+You may wish to use a more robust environment such as the Microsoft
+Developer Studio. In this case, run this to generate perlxsi.c:
+
+ perl -MExtUtils::Embed -e xsinit
+
+Create a new project and Insert -> Files into Project: perlxsi.c,
+perl.lib, and your own source files, e.g. interp.c. Typically you'll
+find perl.lib in B<C:\perl\lib\CORE>, if not, you should see the
+B<CORE> directory relative to C<perl -V:archlib>. The studio will
+also need this path so it knows where to find Perl include files.
+This path can be added via the Tools -> Options -> Directories menu.
+Finally, select Build -> Build interp.exe and you're ready to go.
+
+=head1 MORAL
+
+You can sometimes I<write faster code> in C, but
+you can always I<write code faster> in Perl. Because you can use
+each from the other, combine them as you wish.
+
+
+=head1 AUTHOR
+
+Jon Orwant <F<orwant@tpj.com>> and Doug MacEachern
+<F<dougm@osf.org>>, with small contributions from Tim Bunce, Tom
+Christiansen, Guy Decoux, Hallvard Furuseth, Dov Grobgeld, and Ilya
+Zakharevich.
+
+Doug MacEachern has an article on embedding in Volume 1, Issue 4 of
+The Perl Journal (http://tpj.com). Doug is also the developer of the
+most widely-used Perl embedding: the mod_perl system
+(perl.apache.org), which embeds Perl in the Apache web server.
+Oracle, Binary Evolution, ActiveState, and Ben Sugars's nsapi_perl
+have used this model for Oracle, Netscape and Internet Information
+Server Perl plugins.
+
+July 22, 1998
+
+=head1 COPYRIGHT
+
+Copyright (C) 1995, 1996, 1997, 1998 Doug MacEachern and Jon Orwant. All
+Rights Reserved.
+
+Permission is granted to make and distribute verbatim copies of this
+documentation provided the copyright notice and this permission notice are
+preserved on all copies.
+
+Permission is granted to copy and distribute modified versions of this
+documentation under the conditions for verbatim copying, provided also
+that they are marked clearly as modified versions, that the authors'
+names and title are unchanged (though subtitles and additional
+authors' names may be added), and that the entire resulting derived
+work is distributed under the terms of a permission notice identical
+to this one.
+
+Permission is granted to copy and distribute translations of this
+documentation into another language, under the above conditions for
+modified versions.
diff --git a/contrib/perl5/pod/perlfaq.pod b/contrib/perl5/pod/perlfaq.pod
new file mode 100644
index 000000000000..e6be112008be
--- /dev/null
+++ b/contrib/perl5/pod/perlfaq.pod
@@ -0,0 +1,172 @@
+=head1 NAME
+
+perlfaq - frequently asked questions about Perl ($Date: 1998/08/05 12:09:32 $)
+
+=head1 DESCRIPTION
+
+This document is structured into the following sections:
+
+=over
+
+=item perlfaq: Structural overview of the FAQ.
+
+This document.
+
+=item L<perlfaq1>: General Questions About Perl
+
+Very general, high-level information about Perl.
+
+=item L<perlfaq2>: Obtaining and Learning about Perl
+
+Where to find source and documentation to Perl, support,
+and related matters.
+
+=item L<perlfaq3>: Programming Tools
+
+Programmer tools and programming support.
+
+=item L<perlfaq4>: Data Manipulation
+
+Manipulating numbers, dates, strings, arrays, hashes, and
+miscellaneous data issues.
+
+=item L<perlfaq5>: Files and Formats
+
+I/O and the "f" issues: filehandles, flushing, formats and footers.
+
+=item L<perlfaq6>: Regexps
+
+Pattern matching and regular expressions.
+
+=item L<perlfaq7>: General Perl Language Issues
+
+General Perl language issues that don't clearly fit into any of the
+other sections.
+
+=item L<perlfaq8>: System Interaction
+
+Interprocess communication (IPC), control over the user-interface
+(keyboard, screen and pointing devices).
+
+=item L<perlfaq9>: Networking
+
+Networking, the Internet, and a few on the web.
+
+=back
+
+=head2 Where to get this document
+
+This document is posted regularly to comp.lang.perl.announce and
+several other related newsgroups. It is available in a variety of
+formats from CPAN in the /CPAN/doc/FAQs/FAQ/ directory, or on the web
+at http://www.perl.com/perl/faq/ .
+
+=head2 How to contribute to this document
+
+You may mail corrections, additions, and suggestions to
+perlfaq-suggestions@perl.com . This alias should not be
+used to I<ask> FAQs. It's for fixing the current FAQ.
+
+=head2 What will happen if you mail your Perl programming problems to the authors
+
+Your questions will probably go unread, unless they're suggestions of
+new questions to add to the FAQ, in which case they should have gone
+to the perlfaq-suggestions@perl.com instead.
+
+You should have read section 2 of this faq. There you would have
+learned that comp.lang.perl.misc is the appropriate place to go for
+free advice. If your question is really important and you require a
+prompt and correct answer, you should hire a consultant.
+
+=head1 Credits
+
+When I first began the Perl FAQ in the late 80s, I never realized it
+would have grown to over a hundred pages, nor that Perl would ever become
+so popular and widespread. This document could not have been written
+without the tremendous help provided by Larry Wall and the rest of the
+Perl Porters.
+
+=head1 Author and Copyright Information
+
+Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+=head2 Bundled Distributions
+
+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 I<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.
+
+=head2 Disclaimer
+
+This information is offered in good faith and in the hope that it may
+be of use, but is not guaranteed to be correct, up to date, or suitable
+for any particular purpose whatsoever. The authors accept no liability
+in respect of this information or its use.
+
+=head1 Changes
+
+=over 4
+
+=item 22/June/98
+
+Significant changes throughout in preparation for the 5.005
+release.
+
+=item 24/April/97
+
+Style and whitespace changes from Chip, new question on reading one
+character at a time from a terminal using POSIX from Tom.
+
+=item 23/April/97
+
+Added http://www.oasis.leo.org/perl/ to L<perlfaq2>. Style fix to
+L<perlfaq3>. Added floating point precision, fixed complex number
+arithmetic, cross-references, caveat for Text::Wrap, alternative
+answer for initial capitalizing, fixed incorrect regexp, added example
+of Tie::IxHash to L<perlfaq4>. Added example of passing and storing
+filehandles, added commify to L<perlfaq5>. Restored variable suicide,
+and added mass commenting to L<perlfaq7>. Added Net::Telnet, fixed
+backticks, added reader/writer pair to telnet question, added FindBin,
+grouped module questions together in L<perlfaq8>. Expanded caveats
+for the simple URL extractor, gave LWP example, added CGI security
+question, expanded on the mail address answer in L<perlfaq9>.
+
+=item 25/March/97
+
+Added more info to the binary distribution section of L<perlfaq2>.
+Added Net::Telnet to L<perlfaq6>. Fixed typos in L<perlfaq8>. Added
+mail sending example to L<perlfaq9>. Added Merlyn's columns to
+L<perlfaq2>.
+
+=item 18/March/97
+
+Added the DATE to the NAME section, indicating which sections have
+changed.
+
+Mentioned SIGPIPE and L<perlipc> in the forking open answer in
+L<perlfaq8>.
+
+Fixed description of a regular expression in L<perlfaq4>.
+
+=item 17/March/97 Version
+
+Various typos fixed throughout.
+
+Added new question on Perl BNF on L<perlfaq7>.
+
+=item Initial Release: 11/March/97
+
+This is the initial release of version 3 of the FAQ; consequently there
+have been no changes since its initial release.
+
+=back
diff --git a/contrib/perl5/pod/perlfaq1.pod b/contrib/perl5/pod/perlfaq1.pod
new file mode 100644
index 000000000000..5a95f19c793e
--- /dev/null
+++ b/contrib/perl5/pod/perlfaq1.pod
@@ -0,0 +1,268 @@
+=head1 NAME
+
+perlfaq1 - General Questions About Perl ($Revision: 1.15 $, $Date: 1998/08/05 11:52:24 $)
+
+=head1 DESCRIPTION
+
+This section of the FAQ answers very general, high-level questions
+about Perl.
+
+=head2 What is Perl?
+
+Perl is a high-level programming language with an eclectic heritage
+written by Larry Wall and a cast of thousands. It derives from the
+ubiquitous C programming language and to a lesser extent from sed,
+awk, the Unix shell, and at least a dozen other tools and languages.
+Perl's process, file, and text manipulation facilities make it
+particularly well-suited for tasks involving quick prototyping, system
+utilities, software tools, system management tasks, database access,
+graphical programming, networking, and world wide web programming.
+These strengths make it especially popular with system administrators
+and CGI script authors, but mathematicians, geneticists, journalists,
+and even managers also use Perl. Maybe you should, too.
+
+=head2 Who supports Perl? Who develops it? Why is it free?
+
+The original culture of the pre-populist Internet and the deeply-held
+beliefs of Perl's author, Larry Wall, gave rise to the free and open
+distribution policy of perl. Perl is supported by its users. The
+core, the standard Perl library, the optional modules, and the
+documentation you're reading now were all written by volunteers. See
+the personal note at the end of the README file in the perl source
+distribution for more details. See L<perlhist> (new as of 5.005)
+for Perl's milestone releases.
+
+In particular, the core development team (known as the Perl
+Porters) are a rag-tag band of highly altruistic individuals
+committed to producing better software for free than you
+could hope to purchase for money. You may snoop on pending
+developments via news://genetics.upenn.edu/perl.porters-gw/ and
+http://www.frii.com/~gnat/perl/porters/summary.html.
+
+While the GNU project includes Perl in its distributions, there's no
+such thing as "GNU Perl". Perl is not produced nor maintained by the
+Free Software Foundation. Perl's licensing terms are also more open
+than GNU software's tend to be.
+
+You can get commercial support of Perl if you wish, although for most
+users the informal support will more than suffice. See the answer to
+"Where can I buy a commercial version of perl?" for more information.
+
+=head2 Which version of Perl should I use?
+
+You should definitely use version 5. Version 4 is old, limited, and
+no longer maintained; its last patch (4.036) was in 1992. The most
+recent production release is 5.005_01. Further references to the Perl
+language in this document refer to this production release unless
+otherwise specified. There may be one or more official bug fixes for
+5.005_01 by the time you read this, and also perhaps some experimental
+versions on the way to the next release.
+
+=head2 What are perl4 and perl5?
+
+Perl4 and perl5 are informal names for different versions of the Perl
+programming language. It's easier to say "perl5" than it is to say
+"the 5(.004) release of Perl", but some people have interpreted this
+to mean there's a language called "perl5", which isn't the case.
+Perl5 is merely the popular name for the fifth major release (October 1994),
+while perl4 was the fourth major release (March 1991). There was also a
+perl1 (in January 1988), a perl2 (June 1988), and a perl3 (October 1989).
+
+The 5.0 release is, essentially, a complete rewrite of the perl source
+code from the ground up. It has been modularized, object-oriented,
+tweaked, trimmed, and optimized until it almost doesn't look like the
+old code. However, the interface is mostly the same, and compatibility
+with previous releases is very high.
+
+To avoid the "what language is perl5?" confusion, some people prefer to
+simply use "perl" to refer to the latest version of perl and avoid using
+"perl5" altogether. It's not really that big a deal, though.
+
+See L<perlhist> for a history of Perl revisions.
+
+=head2 How stable is Perl?
+
+Production releases, which incorporate bug fixes and new functionality,
+are widely tested before release. Since the 5.000 release, we have
+averaged only about one production release per year.
+
+Larry and the Perl development team occasionally make changes to the
+internal core of the language, but all possible efforts are made toward
+backward compatibility. While not quite all perl4 scripts run flawlessly
+under perl5, an update to perl should nearly never invalidate a program
+written for an earlier version of perl (barring accidental bug fixes
+and the rare new keyword).
+
+=head2 Is Perl difficult to learn?
+
+No, Perl is easy to start learning -- and easy to keep learning. It looks
+like most programming languages you're likely to have experience
+with, so if you've ever written an C program, an awk script, a shell
+script, or even BASIC program, you're already part way there.
+
+Most tasks only require a small subset of the Perl language. One of
+the guiding mottos for Perl development is "there's more than one way
+to do it" (TMTOWTDI, sometimes pronounced "tim toady"). Perl's
+learning curve is therefore shallow (easy to learn) and long (there's
+a whole lot you can do if you really want).
+
+Finally, Perl is (frequently) an interpreted language. This means
+that you can write your programs and test them without an intermediate
+compilation step, allowing you to experiment and test/debug quickly
+and easily. This ease of experimentation flattens the learning curve
+even more.
+
+Things that make Perl easier to learn: Unix experience, almost any kind
+of programming experience, an understanding of regular expressions, and
+the ability to understand other people's code. If there's something you
+need to do, then it's probably already been done, and a working example is
+usually available for free. Don't forget the new perl modules, either.
+They're discussed in Part 3 of this FAQ, along with the CPAN, which is
+discussed in Part 2.
+
+=head2 How does Perl compare with other languages like Java, Python, REXX, Scheme, or Tcl?
+
+Favorably in some areas, unfavorably in others. Precisely which areas
+are good and bad is often a personal choice, so asking this question
+on Usenet runs a strong risk of starting an unproductive Holy War.
+
+Probably the best thing to do is try to write equivalent code to do a
+set of tasks. These languages have their own newsgroups in which you
+can learn about (but hopefully not argue about) them.
+
+=head2 Can I do [task] in Perl?
+
+Perl is flexible and extensible enough for you to use on almost any
+task, from one-line file-processing tasks to complex systems. For
+many people, Perl serves as a great replacement for shell scripting.
+For others, it serves as a convenient, high-level replacement for most
+of what they'd program in low-level languages like C or C++. It's
+ultimately up to you (and possibly your management ...) which tasks
+you'll use Perl for and which you won't.
+
+If you have a library that provides an API, you can make any component
+of it available as just another Perl function or variable using a Perl
+extension written in C or C++ and dynamically linked into your main
+perl interpreter. You can also go the other direction, and write your
+main program in C or C++, and then link in some Perl code on the fly,
+to create a powerful application.
+
+That said, there will always be small, focused, special-purpose
+languages dedicated to a specific problem domain that are simply more
+convenient for certain kinds of problems. Perl tries to be all things
+to all people, but nothing special to anyone. Examples of specialized
+languages that come to mind include prolog and matlab.
+
+=head2 When shouldn't I program in Perl?
+
+When your manager forbids it -- but do consider replacing them :-).
+
+Actually, one good reason is when you already have an existing
+application written in another language that's all done (and done
+well), or you have an application language specifically designed for a
+certain task (e.g. prolog, make).
+
+For various reasons, Perl is probably not well-suited for real-time
+embedded systems, low-level operating systems development work like
+device drivers or context-switching code, complex multithreaded
+shared-memory applications, or extremely large applications. You'll
+notice that perl is not itself written in Perl.
+
+The new native-code compiler for Perl may reduce the limitations given
+in the previous statement to some degree, but understand that Perl
+remains fundamentally a dynamically typed language, and not a
+statically typed one. You certainly won't be chastized if you don't
+trust nuclear-plant or brain-surgery monitoring code to it. And
+Larry will sleep easier, too -- Wall Street programs not
+withstanding. :-)
+
+=head2 What's the difference between "perl" and "Perl"?
+
+One bit. Oh, you weren't talking ASCII? :-) Larry now uses "Perl" to
+signify the language proper and "perl" the implementation of it,
+i.e. the current interpreter. Hence Tom's quip that "Nothing but perl
+can parse Perl." You may or may not choose to follow this usage. For
+example, parallelism means "awk and perl" and "Python and Perl" look
+ok, while "awk and Perl" and "Python and perl" do not.
+
+=head2 Is it a Perl program or a Perl script?
+
+It doesn't matter.
+
+In "standard terminology" a I<program> has been compiled to physical
+machine code once, and can then be be run multiple times, whereas a
+I<script> must be translated by a program each time it's used. Perl
+programs, however, are usually neither strictly compiled nor strictly
+interpreted. They can be compiled to a byte code form (something of a
+Perl virtual machine) or to completely different languages, like C or
+assembly language. You can't tell just by looking whether the source
+is destined for a pure interpreter, a parse-tree interpreter, a byte
+code interpreter, or a native-code compiler, so it's hard to give a
+definitive answer here.
+
+=head2 What is a JAPH?
+
+These are the "just another perl hacker" signatures that some people
+sign their postings with. About 100 of the of the earlier ones are
+available from http://www.perl.com/CPAN/misc/japh .
+
+=head2 Where can I get a list of Larry Wall witticisms?
+
+Over a hundred quips by Larry, from postings of his or source code,
+can be found at http://www.perl.com/CPAN/misc/lwall-quotes .
+
+=head2 How can I convince my sysadmin/supervisor/employees to use version (5/5.005/Perl instead of some other language)?
+
+If your manager or employees are wary of unsupported software, or
+software which doesn't officially ship with your Operating System, you
+might try to appeal to their self-interest. If programmers can be
+more productive using and utilizing Perl constructs, functionality,
+simplicity, and power, then the typical manager/supervisor/employee
+may be persuaded. Regarding using Perl in general, it's also
+sometimes helpful to point out that delivery times may be reduced
+using Perl, as compared to other languages.
+
+If you have a project which has a bottleneck, especially in terms of
+translation or testing, Perl almost certainly will provide a viable,
+and quick solution. In conjunction with any persuasion effort, you
+should not fail to point out that Perl is used, quite extensively, and
+with extremely reliable and valuable results, at many large computer
+software and/or hardware companies throughout the world. In fact,
+many Unix vendors now ship Perl by default, and support is usually
+just a news-posting away, if you can't find the answer in the
+I<comprehensive> documentation, including this FAQ.
+
+If you face reluctance to upgrading from an older version of perl,
+then point out that version 4 is utterly unmaintained and unsupported
+by the Perl Development Team. Another big sell for Perl5 is the large
+number of modules and extensions which greatly reduce development time
+for any given task. Also mention that the difference between version
+4 and version 5 of Perl is like the difference between awk and C++.
+(Well, ok, maybe not quite that distinct, but you get the idea.) If
+you want support and a reasonable guarantee that what you're
+developing will continue to work in the future, then you have to run
+the supported version. That probably means running the 5.005 release,
+although 5.004 isn't that bad (it's just one year and one release
+behind). Several important bugs were fixed from the 5.000 through
+5.003 versions, though, so try upgrading past them if possible.
+
+Of particular note is the massive bughunt for buffer overflow
+problems that went into the 5.004 release. All releases prior to
+that, including perl4, are considered insecure and should be upgraded
+as soon as possible.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+When included as an integrated part of the Standard Distribution
+of Perl or of its documentation (printed or otherwise), this works is
+covered under Perl's Artistic Licence. For separate distributions of
+all or part of this FAQ outside of that, see L<perlfaq>.
+
+Irrespective of its distribution, all code examples here are public
+domain. You are permitted and encouraged to use this code and any
+derivatives thereof in your own programs for fun or for profit as you
+see fit. A simple comment in the code giving credit to the FAQ would
+be courteous but is not required.
diff --git a/contrib/perl5/pod/perlfaq2.pod b/contrib/perl5/pod/perlfaq2.pod
new file mode 100644
index 000000000000..918e9369ae71
--- /dev/null
+++ b/contrib/perl5/pod/perlfaq2.pod
@@ -0,0 +1,499 @@
+=head1 NAME
+
+perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.25 $, $Date: 1998/08/05 11:47:25 $)
+
+=head1 DESCRIPTION
+
+This section of the FAQ answers questions about where to find
+source and documentation for Perl, support, and
+related matters.
+
+=head2 What machines support Perl? Where do I get it?
+
+The standard release of Perl (the one maintained by the perl
+development team) is distributed only in source code form. You
+can find this at http://www.perl.com/CPAN/src/latest.tar.gz, which
+in standard Internet format (a gzipped archive in POSIX tar format).
+
+Perl builds and runs on a bewildering number of platforms. Virtually
+all known and current Unix derivatives are supported (Perl's native
+platform), as are proprietary systems like VMS, DOS, OS/2, Windows,
+QNX, BeOS, and the Amiga. There are also the beginnings of support
+for MPE/iX.
+
+Binary distributions for some proprietary platforms, including
+Apple systems can be found http://www.perl.com/CPAN/ports/ directory.
+Because these are not part of the standard distribution, they may
+and in fact do differ from the base Perl port in a variety of ways.
+You'll have to check their respective release notes to see just
+what the differences are. These differences can be either positive
+(e.g. extensions for the features of the particular platform that
+are not supported in the source release of perl) or negative (e.g.
+might be based upon a less current source release of perl).
+
+A useful FAQ for Win32 Perl users is
+http://www.endcontsw.com/people/evangelo/Perl_for_Win32_FAQ.html
+
+=head2 How can I get a binary version of Perl?
+
+If you don't have a C compiler because for whatever reasons your
+vendor did not include one with your system, the best thing to do is
+grab a binary version of gcc from the net and use that to compile perl
+with. CPAN only has binaries for systems that are terribly hard to
+get free compilers for, not for Unix systems.
+
+Your first stop should be http://www.perl.com/CPAN/ports to see what
+information is already available. A simple installation guide for
+MS-DOS is available at http://www.cs.ruu.nl/~piet/perl5dos.html , and
+similarly for Windows 3.1 at http://www.cs.ruu.nl/~piet/perlwin3.html
+.
+
+=head2 I don't have a C compiler on my system. How can I compile perl?
+
+Since you don't have a C compiler, you're doomed and your vendor
+should be sacrificed to the Sun gods. But that doesn't help you.
+
+What you need to do is get a binary version of gcc for your system
+first. Consult the Usenet FAQs for your operating system for
+information on where to get such a binary version.
+
+=head2 I copied the Perl binary from one machine to another, but scripts don't work.
+
+That's probably because you forgot libraries, or library paths differ.
+You really should build the whole distribution on the machine it will
+eventually live on, and then type C<make install>. Most other
+approaches are doomed to failure.
+
+One simple way to check that things are in the right place is to print out
+the hard-coded @INC which perl is looking for.
+
+ perl -e 'print join("\n",@INC)'
+
+If this command lists any paths which don't exist on your system, then you
+may need to move the appropriate libraries to these locations, or create
+symlinks, aliases, or shortcuts appropriately.
+
+You might also want to check out L<perlfaq8/"How do I keep my own
+module/library directory?">.
+
+=head2 I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed. How do I make it work?
+
+Read the F<INSTALL> file, which is part of the source distribution.
+It describes in detail how to cope with most idiosyncracies that the
+Configure script can't work around for any given system or
+architecture.
+
+=head2 What modules and extensions are available for Perl? What is CPAN? What does CPAN/src/... mean?
+
+CPAN stands for Comprehensive Perl Archive Network, a huge archive
+replicated on dozens of machines all over the world. CPAN contains
+source code, non-native ports, documentation, scripts, and many
+third-party modules and extensions, designed for everything from
+commercial database interfaces to keyboard/screen control to web
+walking and CGI scripts. The master machine for CPAN is
+ftp://ftp.funet.fi/pub/languages/perl/CPAN/, but you can use the
+address http://www.perl.com/CPAN/CPAN.html to fetch a copy from a
+"site near you". See http://www.perl.com/CPAN (without a slash at the
+end) for how this process works.
+
+CPAN/path/... is a naming convention for files available on CPAN
+sites. CPAN indicates the base directory of a CPAN mirror, and the
+rest of the path is the path from that directory to the file. For
+instance, if you're using ftp://ftp.funet.fi/pub/languages/perl/CPAN
+as your CPAN site, the file CPAN/misc/japh file is downloadable as
+ftp://ftp.funet.fi/pub/languages/perl/CPAN/misc/japh .
+
+Considering that there are hundreds of existing modules in the
+archive, one probably exists to do nearly anything you can think of.
+Current categories under CPAN/modules/by-category/ include perl core
+modules; development support; operating system interfaces; networking,
+devices, and interprocess communication; data type utilities; database
+interfaces; user interfaces; interfaces to other languages; filenames,
+file systems, and file locking; internationalization and locale; world
+wide web support; server and daemon utilities; archiving and
+compression; image manipulation; mail and news; control flow
+utilities; filehandle and I/O; Microsoft Windows modules; and
+miscellaneous modules.
+
+=head2 Is there an ISO or ANSI certified version of Perl?
+
+Certainly not. Larry expects that he'll be certified before Perl is.
+
+=head2 Where can I get information on Perl?
+
+The complete Perl documentation is available with the perl distribution.
+If you have perl installed locally, you probably have the documentation
+installed as well: type C<man perl> if you're on a system resembling Unix.
+This will lead you to other important man pages, including how to set your
+$MANPATH. If you're not on a Unix system, access to the documentation
+will be different; for example, it might be only in HTML format. But all
+proper perl installations have fully-accessible documentation.
+
+You might also try C<perldoc perl> in case your system doesn't
+have a proper man command, or it's been misinstalled. If that doesn't
+work, try looking in /usr/local/lib/perl5/pod for documentation.
+
+If all else fails, consult the CPAN/doc directory, which contains the
+complete documentation in various formats, including native pod,
+troff, html, and plain text. There's also a web page at
+http://www.perl.com/perl/info/documentation.html that might help.
+
+Many good books have been written about Perl -- see the section below
+for more details.
+
+=head2 What are the Perl newsgroups on USENET? Where do I post questions?
+
+The now defunct comp.lang.perl newsgroup has been superseded by the
+following groups:
+
+ comp.lang.perl.announce Moderated announcement group
+ comp.lang.perl.misc Very busy group about Perl in general
+ comp.lang.perl.moderated Moderated discussion group
+ comp.lang.perl.modules Use and development of Perl modules
+ comp.lang.perl.tk Using Tk (and X) from Perl
+
+ comp.infosystems.www.authoring.cgi Writing CGI scripts for the Web.
+
+Actually, the moderated group hasn't passed yet, but we're
+keeping our fingers crossed.
+
+There is also USENET gateway to the mailing list used by the crack
+Perl development team (perl5-porters) at
+news://news.perl.com/perl.porters-gw/ .
+
+=head2 Where should I post source code?
+
+You should post source code to whichever group is most appropriate,
+but feel free to cross-post to comp.lang.perl.misc. If you want to
+cross-post to alt.sources, please make sure it follows their posting
+standards, including setting the Followup-To header line to NOT
+include alt.sources; see their FAQ for details.
+
+If you're just looking for software, first use Alta Vista, Deja News, and
+search CPAN. This is faster and more productive than just posting
+a request.
+
+=head2 Perl Books
+
+A number of books on Perl and/or CGI programming are available. A few of
+these are good, some are ok, but many aren't worth your money. Tom
+Christiansen maintains a list of these books, some with extensive
+reviews, at http://www.perl.com/perl/critiques/index.html.
+
+The incontestably definitive reference book on Perl, written by
+the creator of Perl, is now in its second edition:
+
+ Programming Perl (the "Camel Book"):
+ Authors: Larry Wall, Tom Christiansen, and Randal Schwartz
+ ISBN 1-56592-149-6 (English)
+ ISBN 4-89052-384-7 (Japanese)
+ URL: http://www.oreilly.com/catalog/pperl2/
+ (French, German, Italian, and Hungarian translations also
+ available)
+
+The companion volume to the Camel containing thousands
+of real-world examples, mini-tutorials, and complete programs
+(first premiering at the 1998 Perl Conference), is:
+
+ The Perl Cookbook (the "Ram Book"):
+ Authors: Tom Christiansen and Nathan Torkington,
+ with Foreword by Larry Wall
+ ISBN: 1-56592-243-3
+ URL: http://perl.oreilly.com/cookbook/
+
+If you're already a hard-core systems programmer, then the Camel Book
+might suffice for you to learn Perl from. But if you're not, check
+out:
+
+ Learning Perl (the "Llama Book"):
+ Authors: Randal Schwartz and Tom Christiansen
+ with Foreword by Larry Wall
+ ISBN: 1-56592-284-0
+ URL: http://www.oreilly.com/catalog/lperl2/
+
+Despite the picture at the URL above, the second edition of "Llama
+Book" really has a blue cover, and is updated for the 5.004 release
+of Perl. Various foreign language editions are available, including
+I<Learning Perl on Win32 Systems> (the Gecko Book).
+
+If you're not an accidental programmer, but a more serious and possibly
+even degreed computer scientist who doesn't need as much hand-holding as
+we try to provide in the Llama or its defurred cousin the Gecko, please
+check out the delightful book, I<Perl: The Programmer's Companion>,
+written by Nigel Chapman.
+
+You can order O'Reilly books directly from O'Reilly & Associates,
+1-800-998-9938. Local/overseas is 1-707-829-0515. If you can
+locate an O'Reilly order form, you can also fax to 1-707-829-0104.
+See http://www.ora.com/ on the Web.
+
+What follows is a list of the books that the FAQ authors found personally
+useful. Your mileage may (but, we hope, probably won't) vary.
+
+Recommended books on (or muchly on) Perl follow; those marked with
+a star may be ordered from O'Reilly.
+
+=over
+
+=item References
+
+ *Programming Perl
+ by Larry Wall, Tom Christiansen, and Randal L. Schwartz
+
+ *Perl 5 Desktop Reference
+ By Johan Vromans
+
+=item Tutorials
+
+ *Learning Perl [2nd edition]
+ by Randal L. Schwartz and Tom Christiansen
+ with foreword by Larry Wall
+
+ *Learning Perl on Win32 Systems
+ by Randal L. Schwartz, Erik Olson, and Tom Christiansen,
+ with foreword by Larry Wall
+
+ Perl: The Programmer's Companion
+ by Nigel Chapman
+
+ Cross-Platform Perl
+ by Eric F. Johnson
+
+ MacPerl: Power and Ease
+ by Vicki Brown and Chris Nandor, foreword by Matthias Neeracher
+
+=item Task-Oriented
+
+ *The Perl Cookbook
+ by Tom Christiansen and Nathan Torkington
+ with foreword by Larry Wall
+
+ Perl5 Interactive Course [2nd edition]
+ by Jon Orwant
+
+ *Advanced Perl Programming
+ by Sriram Srinivasan
+
+ Effective Perl Programming
+ by Joseph Hall
+
+=item Special Topics
+
+ *Mastering Regular Expressions
+ by Jeffrey Friedl
+
+ How to Set up and Maintain a World Wide Web Site [2nd edition]
+ by Lincoln Stein
+
+=back
+
+=head2 Perl in Magazines
+
+The first and only periodical devoted to All Things Perl, I<The
+Perl Journal> contains tutorials, demonstrations, case studies,
+announcements, contests, and much more. TPJ has columns on web
+development, databases, Win32 Perl, graphical programming, regular
+expressions, and networking, and sponsors the Obfuscated Perl
+Contest. It is published quarterly under the gentle hand of its
+editor, Jon Orwant. See http://www.tpj.com/ or send mail to
+subscriptions@tpj.com.
+
+Beyond this, magazines that frequently carry high-quality articles
+on Perl are I<Web Techniques> (see http://www.webtechniques.com/),
+I<Performance Computing> (http://www.performance-computing.com/), and Usenix's
+newsletter/magazine to its members, I<login:>, at http://www.usenix.org/.
+Randal's Web Technique's columns are available on the web at
+http://www.stonehenge.com/merlyn/WebTechniques/.
+
+=head2 Perl on the Net: FTP and WWW Access
+
+To get the best (and possibly cheapest) performance, pick a site from
+the list below and use it to grab the complete list of mirror sites.
+From there you can find the quickest site for you. Remember, the
+following list is I<not> the complete list of CPAN mirrors.
+
+ http://www.perl.com/CPAN (redirects to another mirror)
+ http://www.perl.org/CPAN
+ ftp://ftp.funet.fi/pub/languages/perl/CPAN/
+ http://www.cs.ruu.nl/pub/PERL/CPAN/
+ ftp://ftp.cs.colorado.edu/pub/perl/CPAN/
+
+=head2 What mailing lists are there for perl?
+
+Most of the major modules (tk, CGI, libwww-perl) have their own
+mailing lists. Consult the documentation that came with the module for
+subscription information. The following are a list of mailing lists
+related to perl itself.
+
+If you subscribe to a mailing list, it behooves you to know how to
+unsubscribe from it. Strident pleas to the list itself to get you off
+will not be favorably received.
+
+=over 4
+
+=item MacPerl
+
+There is a mailing list for discussing Macintosh Perl. Contact
+"mac-perl-request@iis.ee.ethz.ch".
+
+Also see Matthias Neeracher's (the creator and maintainer of MacPerl)
+webpage at http://www.iis.ee.ethz.ch/~neeri/macintosh/perl.html for
+many links to interesting MacPerl sites, and the applications/MPW
+tools, precompiled.
+
+=item Perl5-Porters
+
+The core development team have a mailing list for discussing fixes and
+changes to the language. Send mail to
+"perl5-porters-request@perl.org" with help in the body of the message
+for information on subscribing.
+
+=item NTPerl
+
+This list is used to discuss issues involving Win32 Perl 5 (Windows NT
+and Win95). Subscribe by mailing ListManager@ActiveWare.com with the
+message body:
+
+ subscribe Perl-Win32-Users
+
+The list software, also written in perl, will automatically determine
+your address, and subscribe you automatically. To unsubscribe, mail
+the following in the message body to the same address like so:
+
+ unsubscribe Perl-Win32-Users
+
+You can also check http://www.activeware.com/ and select "Mailing Lists"
+to join or leave this list.
+
+=item Perl-Packrats
+
+Discussion related to archiving of perl materials, particularly the
+Comprehensive Perl Archive Network (CPAN). Subscribe by emailing
+majordomo@cis.ufl.edu:
+
+ subscribe perl-packrats
+
+The list software, also written in perl, will automatically determine
+your address, and subscribe you automatically. To unsubscribe, simple
+prepend the same command with an "un", and mail to the same address
+like so:
+
+ unsubscribe perl-packrats
+
+=back
+
+=head2 Archives of comp.lang.perl.misc
+
+Have you tried Deja News or Alta Vista?
+
+ftp.cis.ufl.edu:/pub/perl/comp.lang.perl.*/monthly has an almost
+complete collection dating back to 12/89 (missing 08/91 through
+12/93). They are kept as one large file for each month.
+
+You'll probably want more a sophisticated query and retrieval mechanism
+than a file listing, preferably one that allows you to retrieve
+articles using a fast-access indices, keyed on at least author, date,
+subject, thread (as in "trn") and probably keywords. The best
+solution the FAQ authors know of is the MH pick command, but it is
+very slow to select on 18000 articles.
+
+If you have, or know where can be found, the missing sections, please
+let perlfaq-suggestions@perl.com know.
+
+=head2 Where can I buy a commercial version of Perl?
+
+In a sense, Perl already I<is> commercial software: It has a licence
+that you can grab and carefully read to your manager. It is
+distributed in releases and comes in well-defined packages. There is a
+very large user community and an extensive literature. The
+comp.lang.perl.* newsgroups and several of the mailing lists provide
+free answers to your questions in near real-time. Perl has
+traditionally been supported by Larry, dozens of software designers
+and developers, and thousands of programmers, all working for free
+to create a useful thing to make life better for everyone.
+
+However, these answers may not suffice for managers who require a
+purchase order from a company whom they can sue should anything go
+wrong. Or maybe they need very serious hand-holding and contractual
+obligations. Shrink-wrapped CDs with perl on them are available from
+several sources if that will help.
+
+Or you can purchase a real support contract. Although Cygnus historically
+provided this service, they no longer sell support contracts for Perl.
+Instead, the Paul Ingram Group will be taking up the slack through The
+Perl Clinic. The following is a commercial from them:
+
+"Do you need professional support for Perl and/or Oraperl? Do you need
+a support contract with defined levels of service? Do you want to pay
+only for what you need?
+
+"The Paul Ingram Group has provided quality software development and
+support services to some of the world's largest corporations for ten
+years. We are now offering the same quality support services for Perl
+at The Perl Clinic. This service is led by Tim Bunce, an active perl
+porter since 1994 and well known as the author and maintainer of the
+DBI, DBD::Oracle, and Oraperl modules and author/co-maintainer of The
+Perl 5 Module List. We also offer Oracle users support for Perl5
+Oraperl and related modules (which Oracle is planning to ship as part
+of Oracle Web Server 3). 20% of the profit from our Perl support work
+will be donated to The Perl Institute."
+
+For more information, contact the The Perl Clinic:
+
+ Tel: +44 1483 424424
+ Fax: +44 1483 419419
+ Web: http://www.perl.co.uk/
+ Email: perl-support-info@perl.co.uk or Tim.Bunce@ig.co.uk
+
+See also www.perl.com for updates on training and support.
+
+=head2 Where do I send bug reports?
+
+If you are reporting a bug in the perl interpreter or the modules
+shipped with perl, use the I<perlbug> program in the perl distribution or
+mail your report to perlbug@perl.com.
+
+If you are posting a bug with a non-standard port (see the answer to
+"What platforms is Perl available for?"), a binary distribution, or a
+non-standard module (such as Tk, CGI, etc), then please see the
+documentation that came with it to determine the correct place to post
+bugs.
+
+Read the perlbug(1) man page (perl5.004 or later) for more information.
+
+=head2 What is perl.com? perl.org? The Perl Institute?
+
+The perl.com domain is managed by Tom Christiansen, who created it as a
+public service long before perl.org came about. Despite the name, it's a
+pretty non-commercial site meant to be a clearinghouse for information
+about all things Perlian, accepting no paid advertisements, bouncy
+happy gifs, or silly java applets on its pages. The Perl Home Page at
+http://www.perl.com/ is currently hosted on a T3 line courtesy of Songline
+Systems, a software-oriented subsidiary of O'Reilly and Associates.
+
+perl.org is the official vehicle for The Perl Institute. The motto of
+TPI is "helping people help Perl help people" (or something like
+that). It's a non-profit organization supporting development,
+documentation, and dissemination of perl.
+
+=head2 How do I learn about object-oriented Perl programming?
+
+L<perltoot> (distributed with 5.004 or later) is a good place to start.
+Also, L<perlobj>, L<perlref>, and L<perlmod> are useful references,
+while L<perlbot> has some excellent tips and tricks.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+When included as an integrated part of the Standard Distribution
+of Perl or of its documentation (printed or otherwise), this works is
+covered under Perl's Artistic Licence. For separate distributions of
+all or part of this FAQ outside of that, see L<perlfaq>.
+
+Irrespective of its distribution, all code examples here are public
+domain. You are permitted and encouraged to use this code and any
+derivatives thereof in your own programs for fun or for profit as you
+see fit. A simple comment in the code giving credit to the FAQ would
+be courteous but is not required.
diff --git a/contrib/perl5/pod/perlfaq3.pod b/contrib/perl5/pod/perlfaq3.pod
new file mode 100644
index 000000000000..d06f2bef7aaa
--- /dev/null
+++ b/contrib/perl5/pod/perlfaq3.pod
@@ -0,0 +1,595 @@
+=head1 NAME
+
+perlfaq3 - Programming Tools ($Revision: 1.29 $, $Date: 1998/08/05 11:57:04 $)
+
+=head1 DESCRIPTION
+
+This section of the FAQ answers questions related to programmer tools
+and programming support.
+
+=head2 How do I do (anything)?
+
+Have you looked at CPAN (see L<perlfaq2>)? The chances are that
+someone has already written a module that can solve your problem.
+Have you read the appropriate man pages? Here's a brief index:
+
+ Basics perldata, perlvar, perlsyn, perlop, perlsub
+ Execution perlrun, perldebug
+ Functions perlfunc
+ Objects perlref, perlmod, perlobj, perltie
+ Data Structures perlref, perllol, perldsc
+ Modules perlmod, perlmodlib, perlsub
+ Regexps perlre, perlfunc, perlop, perllocale
+ Moving to perl5 perltrap, perl
+ Linking w/C perlxstut, perlxs, perlcall, perlguts, perlembed
+ Various http://www.perl.com/CPAN/doc/FMTEYEWTK/index.html
+ (not a man-page but still useful)
+
+L<perltoc> provides a crude table of contents for the perl man page set.
+
+=head2 How can I use Perl interactively?
+
+The typical approach uses the Perl debugger, described in the
+perldebug(1) man page, on an ``empty'' program, like this:
+
+ perl -de 42
+
+Now just type in any legal Perl code, and it will be immediately
+evaluated. You can also examine the symbol table, get stack
+backtraces, check variable values, set breakpoints, and other
+operations typically found in symbolic debuggers.
+
+=head2 Is there a Perl shell?
+
+In general, no. The Shell.pm module (distributed with perl) makes
+perl try commands which aren't part of the Perl language as shell
+commands. perlsh from the source distribution is simplistic and
+uninteresting, but may still be what you want.
+
+=head2 How do I debug my Perl programs?
+
+Have you used C<-w>? It enables warnings for dubious practices.
+
+Have you tried C<use strict>? It prevents you from using symbolic
+references, makes you predeclare any subroutines that you call as bare
+words, and (probably most importantly) forces you to predeclare your
+variables with C<my> or C<use vars>.
+
+Did you check the returns of each and every system call? The operating
+system (and thus Perl) tells you whether they worked or not, and if not
+why.
+
+ open(FH, "> /etc/cantwrite")
+ or die "Couldn't write to /etc/cantwrite: $!\n";
+
+Did you read L<perltrap>? It's full of gotchas for old and new Perl
+programmers, and even has sections for those of you who are upgrading
+from languages like I<awk> and I<C>.
+
+Have you tried the Perl debugger, described in L<perldebug>? You can
+step through your program and see what it's doing and thus work out
+why what it's doing isn't what it should be doing.
+
+=head2 How do I profile my Perl programs?
+
+You should get the Devel::DProf module from CPAN, and also use
+Benchmark.pm from the standard distribution. Benchmark lets you time
+specific portions of your code, while Devel::DProf gives detailed
+breakdowns of where your code spends its time.
+
+Here's a sample use of Benchmark:
+
+ use Benchmark;
+
+ @junk = `cat /etc/motd`;
+ $count = 10_000;
+
+ timethese($count, {
+ 'map' => sub { my @a = @junk;
+ map { s/a/b/ } @a;
+ return @a
+ },
+ 'for' => sub { my @a = @junk;
+ local $_;
+ for (@a) { s/a/b/ };
+ return @a },
+ });
+
+This is what it prints (on one machine--your results will be dependent
+on your hardware, operating system, and the load on your machine):
+
+ Benchmark: timing 10000 iterations of for, map...
+ for: 4 secs ( 3.97 usr 0.01 sys = 3.98 cpu)
+ map: 6 secs ( 4.97 usr 0.00 sys = 4.97 cpu)
+
+=head2 How do I cross-reference my Perl programs?
+
+The B::Xref module, shipped with the new, alpha-release Perl compiler
+(not the general distribution prior to the 5.005 release), can be used
+to generate cross-reference reports for Perl programs.
+
+ perl -MO=Xref[,OPTIONS] scriptname.plx
+
+=head2 Is there a pretty-printer (formatter) for Perl?
+
+There is no program that will reformat Perl as much as indent(1) does
+for C. The complex feedback between the scanner and the parser (this
+feedback is what confuses the vgrind and emacs programs) makes it
+challenging at best to write a stand-alone Perl parser.
+
+Of course, if you simply follow the guidelines in L<perlstyle>, you
+shouldn't need to reformat. The habit of formatting your code as you
+write it will help prevent bugs. Your editor can and should help you
+with this. The perl-mode for emacs can provide a remarkable amount of
+help with most (but not all) code, and even less programmable editors
+can provide significant assistance.
+
+If you are used to using I<vgrind> program for printing out nice code
+to a laser printer, you can take a stab at this using
+http://www.perl.com/CPAN/doc/misc/tips/working.vgrind.entry, but the
+results are not particularly satisfying for sophisticated code.
+
+=head2 Is there a ctags for Perl?
+
+There's a simple one at
+http://www.perl.com/CPAN/authors/id/TOMC/scripts/ptags.gz which may do
+the trick.
+
+=head2 Where can I get Perl macros for vi?
+
+For a complete version of Tom Christiansen's vi configuration file,
+see http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/toms.exrc,
+the standard benchmark file for vi emulators. This runs best with nvi,
+the current version of vi out of Berkeley, which incidentally can be built
+with an embedded Perl interpreter -- see http://www.perl.com/CPAN/src/misc.
+
+=head2 Where can I get perl-mode for emacs?
+
+Since Emacs version 19 patchlevel 22 or so, there have been both a
+perl-mode.el and support for the perl debugger built in. These should
+come with the standard Emacs 19 distribution.
+
+In the perl source directory, you'll find a directory called "emacs",
+which contains a cperl-mode that color-codes keywords, provides
+context-sensitive help, and other nifty things.
+
+Note that the perl-mode of emacs will have fits with C<"main'foo">
+(single quote), and mess up the indentation and hilighting. You
+should be using C<"main::foo"> in new Perl code anyway, so this
+shouldn't be an issue.
+
+=head2 How can I use curses with Perl?
+
+The Curses module from CPAN provides a dynamically loadable object
+module interface to a curses library. A small demo can be found at the
+directory http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/rep;
+this program repeats a command and updates the screen as needed, rendering
+B<rep ps axu> similar to B<top>.
+
+=head2 How can I use X or Tk with Perl?
+
+Tk is a completely Perl-based, object-oriented interface to the Tk toolkit
+that doesn't force you to use Tcl just to get at Tk. Sx is an interface
+to the Athena Widget set. Both are available from CPAN. See the
+directory http://www.perl.com/CPAN/modules/by-category/08_User_Interfaces/
+
+Invaluable for Perl/Tk programming are: the Perl/Tk FAQ at
+http://w4.lns.cornell.edu/~pvhp/ptk/ptkTOC.html , the Perl/Tk Reference
+Guide available at
+http://www.perl.com/CPAN-local/authors/Stephen_O_Lidie/ , and the
+online manpages at
+http://www-users.cs.umn.edu/~amundson/perl/perltk/toc.html .
+
+=head2 How can I generate simple menus without using CGI or Tk?
+
+The http://www.perl.com/CPAN/authors/id/SKUNZ/perlmenu.v4.0.tar.gz
+module, which is curses-based, can help with this.
+
+=head2 What is undump?
+
+See the next questions.
+
+=head2 How can I make my Perl program run faster?
+
+The best way to do this is to come up with a better algorithm. This
+can often make a dramatic difference. Chapter 8 in the Camel has some
+efficiency tips in it you might want to look at. Jon Bentley's book
+``Programming Pearls'' (that's not a misspelling!) has some good tips
+on optimization, too. Advice on benchmarking boils down to: benchmark
+and profile to make sure you're optimizing the right part, look for
+better algorithms instead of microtuning your code, and when all else
+fails consider just buying faster hardware.
+
+A different approach is to autoload seldom-used Perl code. See the
+AutoSplit and AutoLoader modules in the standard distribution for
+that. Or you could locate the bottleneck and think about writing just
+that part in C, the way we used to take bottlenecks in C code and
+write them in assembler. Similar to rewriting in C is the use of
+modules that have critical sections written in C (for instance, the
+PDL module from CPAN).
+
+In some cases, it may be worth it to use the backend compiler to
+produce byte code (saving compilation time) or compile into C, which
+will certainly save compilation time and sometimes a small amount (but
+not much) execution time. See the question about compiling your Perl
+programs for more on the compiler--the wins aren't as obvious as you'd
+hope.
+
+If you're currently linking your perl executable to a shared I<libc.so>,
+you can often gain a 10-25% performance benefit by rebuilding it to
+link with a static libc.a instead. This will make a bigger perl
+executable, but your Perl programs (and programmers) may thank you for
+it. See the F<INSTALL> file in the source distribution for more
+information.
+
+Unsubstantiated reports allege that Perl interpreters that use sfio
+outperform those that don't (for IO intensive applications). To try
+this, see the F<INSTALL> file in the source distribution, especially
+the ``Selecting File IO mechanisms'' section.
+
+The undump program was an old attempt to speed up your Perl program
+by storing the already-compiled form to disk. This is no longer
+a viable option, as it only worked on a few architectures, and
+wasn't a good solution anyway.
+
+=head2 How can I make my Perl program take less memory?
+
+When it comes to time-space tradeoffs, Perl nearly always prefers to
+throw memory at a problem. Scalars in Perl use more memory than
+strings in C, arrays take more that, and hashes use even more. While
+there's still a lot to be done, recent releases have been addressing
+these issues. For example, as of 5.004, duplicate hash keys are
+shared amongst all hashes using them, so require no reallocation.
+
+In some cases, using substr() or vec() to simulate arrays can be
+highly beneficial. For example, an array of a thousand booleans will
+take at least 20,000 bytes of space, but it can be turned into one
+125-byte bit vector for a considerable memory savings. The standard
+Tie::SubstrHash module can also help for certain types of data
+structure. If you're working with specialist data structures
+(matrices, for instance) modules that implement these in C may use
+less memory than equivalent Perl modules.
+
+Another thing to try is learning whether your Perl was compiled with
+the system malloc or with Perl's builtin malloc. Whichever one it
+is, try using the other one and see whether this makes a difference.
+Information about malloc is in the F<INSTALL> file in the source
+distribution. You can find out whether you are using perl's malloc by
+typing C<perl -V:usemymalloc>.
+
+=head2 Is it unsafe to return a pointer to local data?
+
+No, Perl's garbage collection system takes care of this.
+
+ sub makeone {
+ my @a = ( 1 .. 10 );
+ return \@a;
+ }
+
+ for $i ( 1 .. 10 ) {
+ push @many, makeone();
+ }
+
+ print $many[4][5], "\n";
+
+ print "@many\n";
+
+=head2 How can I free an array or hash so my program shrinks?
+
+You can't. On most operating systems, memory allocated to a program
+can never be returned to the system. That's why long-running programs
+sometimes re-exec themselves. Some operating systems (notably, FreeBSD)
+allegedly reclaim large chunks of memory that is no longer used, but
+it doesn't appear to happen with Perl (yet). The Mac appears to be the
+only platform that will reliably (albeit, slowly) return memory to the OS.
+
+However, judicious use of my() on your variables will help make sure
+that they go out of scope so that Perl can free up their storage for
+use in other parts of your program. A global variable, of course, never
+goes out of scope, so you can't get its space automatically reclaimed,
+although undef()ing and/or delete()ing it will achieve the same effect.
+In general, memory allocation and de-allocation isn't something you can
+or should be worrying about much in Perl, but even this capability
+(preallocation of data types) is in the works.
+
+=head2 How can I make my CGI script more efficient?
+
+Beyond the normal measures described to make general Perl programs
+faster or smaller, a CGI program has additional issues. It may be run
+several times per second. Given that each time it runs it will need
+to be re-compiled and will often allocate a megabyte or more of system
+memory, this can be a killer. Compiling into C B<isn't going to help
+you> because the process start-up overhead is where the bottleneck is.
+
+There are two popular ways to avoid this overhead. One solution
+involves running the Apache HTTP server (available from
+http://www.apache.org/) with either of the mod_perl or mod_fastcgi
+plugin modules.
+
+With mod_perl and the Apache::Registry module (distributed with
+mod_perl), httpd will run with an embedded Perl interpreter which
+pre-compiles your script and then executes it within the same address
+space without forking. The Apache extension also gives Perl access to
+the internal server API, so modules written in Perl can do just about
+anything a module written in C can. For more on mod_perl, see
+http://perl.apache.org/
+
+With the FCGI module (from CPAN), a Perl executable compiled with sfio
+(see the F<INSTALL> file in the distribution) and the mod_fastcgi
+module (available from http://www.fastcgi.com/) each of your perl
+scripts becomes a permanent CGI daemon process.
+
+Both of these solutions can have far-reaching effects on your system
+and on the way you write your CGI scripts, so investigate them with
+care.
+
+See http://www.perl.com/CPAN/modules/by-category/15_World_Wide_Web_HTML_HTTP_CGI/ .
+
+A non-free, commerical product, ``The Velocity Engine for Perl'',
+(http://www.binevolve.com/ or http://www.binevolve.com/bine/vep) might
+also be worth looking at. It will allow you to increase the performance
+of your perl scripts, upto 25 times faster than normal CGI perl by
+running in persistent perl mode, or 4 to 5 times faster without any
+modification to your existing CGI scripts. Fully functional evaluation
+copies are available from the web site.
+
+=head2 How can I hide the source for my Perl program?
+
+Delete it. :-) Seriously, there are a number of (mostly
+unsatisfactory) solutions with varying levels of ``security''.
+
+First of all, however, you I<can't> take away read permission, because
+the source code has to be readable in order to be compiled and
+interpreted. (That doesn't mean that a CGI script's source is
+readable by people on the web, though, only by people with access to
+the filesystem) So you have to leave the permissions at the socially
+friendly 0755 level.
+
+Some people regard this as a security problem. If your program does
+insecure things, and relies on people not knowing how to exploit those
+insecurities, it is not secure. It is often possible for someone to
+determine the insecure things and exploit them without viewing the
+source. Security through obscurity, the name for hiding your bugs
+instead of fixing them, is little security indeed.
+
+You can try using encryption via source filters (Filter::* from CPAN),
+but crackers might be able to decrypt it. You can try using the byte
+code compiler and interpreter described below, but crackers might be
+able to de-compile it. You can try using the native-code compiler
+described below, but crackers might be able to disassemble it. These
+pose varying degrees of difficulty to people wanting to get at your
+code, but none can definitively conceal it (this is true of every
+language, not just Perl).
+
+If you're concerned about people profiting from your code, then the
+bottom line is that nothing but a restrictive licence will give you
+legal security. License your software and pepper it with threatening
+statements like ``This is unpublished proprietary software of XYZ Corp.
+Your access to it does not give you permission to use it blah blah
+blah.'' We are not lawyers, of course, so you should see a lawyer if
+you want to be sure your licence's wording will stand up in court.
+
+=head2 How can I compile my Perl program into byte code or C?
+
+Malcolm Beattie has written a multifunction backend compiler,
+available from CPAN, that can do both these things. It is included
+in the perl5.005 release, but is still considered experimental.
+This means it's fun to play with if you're a programmer but not
+really for people looking for turn-key solutions.
+
+Merely compiling into C does not in and of itself guarantee that your
+code will run very much faster. That's because except for lucky cases
+where a lot of native type inferencing is possible, the normal Perl
+run time system is still present and so your program will take just as
+long to run and be just as big. Most programs save little more than
+compilation time, leaving execution no more than 10-30% faster. A few
+rare programs actually benefit significantly (like several times
+faster), but this takes some tweaking of your code.
+
+You'll probably be astonished to learn that the current version of the
+compiler generates a compiled form of your script whose executable is
+just as big as the original perl executable, and then some. That's
+because as currently written, all programs are prepared for a full
+eval() statement. You can tremendously reduce this cost by building a
+shared I<libperl.so> library and linking against that. See the
+F<INSTALL> podfile in the perl source distribution for details. If
+you link your main perl binary with this, it will make it miniscule.
+For example, on one author's system, F</usr/bin/perl> is only 11k in
+size!
+
+In general, the compiler will do nothing to make a Perl program smaller,
+faster, more portable, or more secure. In fact, it will usually hurt
+all of those. The executable will be bigger, your VM system may take
+longer to load the whole thing, the binary is fragile and hard to fix,
+and compilation never stopped software piracy in the form of crackers,
+viruses, or bootleggers. The real advantage of the compiler is merely
+packaging, and once you see the size of what it makes (well, unless
+you use a shared I<libperl.so>), you'll probably want a complete
+Perl install anyway.
+
+=head2 How can I get C<#!perl> to work on [MS-DOS,NT,...]?
+
+For OS/2 just use
+
+ extproc perl -S -your_switches
+
+as the first line in C<*.cmd> file (C<-S> due to a bug in cmd.exe's
+`extproc' handling). For DOS one should first invent a corresponding
+batch file, and codify it in C<ALTERNATIVE_SHEBANG> (see the
+F<INSTALL> file in the source distribution for more information).
+
+The Win95/NT installation, when using the ActiveState port of Perl,
+will modify the Registry to associate the C<.pl> extension with the
+perl interpreter. If you install another port (Gurusaramy Sarathy's
+is the recommended Win95/NT port), or (eventually) build your own
+Win95/NT Perl using WinGCC, then you'll have to modify the Registry
+yourself.
+
+Macintosh perl scripts will have the the appropriate Creator and
+Type, so that double-clicking them will invoke the perl application.
+
+I<IMPORTANT!>: Whatever you do, PLEASE don't get frustrated, and just
+throw the perl interpreter into your cgi-bin directory, in order to
+get your scripts working for a web server. This is an EXTREMELY big
+security risk. Take the time to figure out how to do it correctly.
+
+=head2 Can I write useful perl programs on the command line?
+
+Yes. Read L<perlrun> for more information. Some examples follow.
+(These assume standard Unix shell quoting rules.)
+
+ # sum first and last fields
+ perl -lane 'print $F[0] + $F[-1]' *
+
+ # identify text files
+ perl -le 'for(@ARGV) {print if -f && -T _}' *
+
+ # remove (most) comments from C program
+ perl -0777 -pe 's{/\*.*?\*/}{}gs' foo.c
+
+ # make file a month younger than today, defeating reaper daemons
+ perl -e '$X=24*60*60; utime(time(),time() + 30 * $X,@ARGV)' *
+
+ # find first unused uid
+ perl -le '$i++ while getpwuid($i); print $i'
+
+ # display reasonable manpath
+ echo $PATH | perl -nl -072 -e '
+ s![^/+]*$!man!&&-d&&!$s{$_}++&&push@m,$_;END{print"@m"}'
+
+Ok, the last one was actually an obfuscated perl entry. :-)
+
+=head2 Why don't perl one-liners work on my DOS/Mac/VMS system?
+
+The problem is usually that the command interpreters on those systems
+have rather different ideas about quoting than the Unix shells under
+which the one-liners were created. On some systems, you may have to
+change single-quotes to double ones, which you must I<NOT> do on Unix
+or Plan9 systems. You might also have to change a single % to a %%.
+
+For example:
+
+ # Unix
+ perl -e 'print "Hello world\n"'
+
+ # DOS, etc.
+ perl -e "print \"Hello world\n\""
+
+ # Mac
+ print "Hello world\n"
+ (then Run "Myscript" or Shift-Command-R)
+
+ # VMS
+ perl -e "print ""Hello world\n"""
+
+The problem is that none of this is reliable: it depends on the
+command interpreter. Under Unix, the first two often work. Under DOS,
+it's entirely possible neither works. If 4DOS was the command shell,
+you'd probably have better luck like this:
+
+ perl -e "print <Ctrl-x>"Hello world\n<Ctrl-x>""
+
+Under the Mac, it depends which environment you are using. The MacPerl
+shell, or MPW, is much like Unix shells in its support for several
+quoting variants, except that it makes free use of the Mac's non-ASCII
+characters as control characters.
+
+There is no general solution to all of this. It is a mess, pure and
+simple. Sucks to be away from Unix, huh? :-)
+
+[Some of this answer was contributed by Kenneth Albanowski.]
+
+=head2 Where can I learn about CGI or Web programming in Perl?
+
+For modules, get the CGI or LWP modules from CPAN. For textbooks,
+see the two especially dedicated to web stuff in the question on
+books. For problems and questions related to the web, like ``Why
+do I get 500 Errors'' or ``Why doesn't it run from the browser right
+when it runs fine on the command line'', see these sources:
+
+ WWW Security FAQ
+ http://www.w3.org/Security/Faq/
+
+ Web FAQ
+ http://www.boutell.com/faq/
+
+ CGI FAQ
+ http://www.webthing.com/page.cgi/cgifaq
+
+ HTTP Spec
+ http://www.w3.org/pub/WWW/Protocols/HTTP/
+
+ HTML Spec
+ http://www.w3.org/TR/REC-html40/
+ http://www.w3.org/pub/WWW/MarkUp/
+
+ CGI Spec
+ http://www.w3.org/CGI/
+
+ CGI Security FAQ
+ http://www.go2net.com/people/paulp/cgi-security/safe-cgi.txt
+
+
+=head2 Where can I learn about object-oriented Perl programming?
+
+L<perltoot> is a good place to start, and you can use L<perlobj> and
+L<perlbot> for reference. Perltoot didn't come out until the 5.004
+release, but you can get a copy (in pod, html, or postscript) from
+http://www.perl.com/CPAN/doc/FMTEYEWTK/ .
+
+=head2 Where can I learn about linking C with Perl? [h2xs, xsubpp]
+
+If you want to call C from Perl, start with L<perlxstut>,
+moving on to L<perlxs>, L<xsubpp>, and L<perlguts>. If you want to
+call Perl from C, then read L<perlembed>, L<perlcall>, and
+L<perlguts>. Don't forget that you can learn a lot from looking at
+how the authors of existing extension modules wrote their code and
+solved their problems.
+
+=head2 I've read perlembed, perlguts, etc., but I can't embed perl in
+my C program, what am I doing wrong?
+
+Download the ExtUtils::Embed kit from CPAN and run `make test'. If
+the tests pass, read the pods again and again and again. If they
+fail, see L<perlbug> and send a bugreport with the output of
+C<make test TEST_VERBOSE=1> along with C<perl -V>.
+
+=head2 When I tried to run my script, I got this message. What does it
+mean?
+
+L<perldiag> has a complete list of perl's error messages and warnings,
+with explanatory text. You can also use the splain program (distributed
+with perl) to explain the error messages:
+
+ perl program 2>diag.out
+ splain [-v] [-p] diag.out
+
+or change your program to explain the messages for you:
+
+ use diagnostics;
+
+or
+
+ use diagnostics -verbose;
+
+=head2 What's MakeMaker?
+
+This module (part of the standard perl distribution) is designed to
+write a Makefile for an extension module from a Makefile.PL. For more
+information, see L<ExtUtils::MakeMaker>.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+When included as an integrated part of the Standard Distribution
+of Perl or of its documentation (printed or otherwise), this works is
+covered under Perl's Artistic Licence. For separate distributions of
+all or part of this FAQ outside of that, see L<perlfaq>.
+
+Irrespective of its distribution, all code examples here are public
+domain. You are permitted and encouraged to use this code and any
+derivatives thereof in your own programs for fun or for profit as you
+see fit. A simple comment in the code giving credit to the FAQ would
+be courteous but is not required.
diff --git a/contrib/perl5/pod/perlfaq4.pod b/contrib/perl5/pod/perlfaq4.pod
new file mode 100644
index 000000000000..633f5f109b7d
--- /dev/null
+++ b/contrib/perl5/pod/perlfaq4.pod
@@ -0,0 +1,1358 @@
+=head1 NAME
+
+perlfaq4 - Data Manipulation ($Revision: 1.26 $, $Date: 1998/08/05 12:04:00 $)
+
+=head1 DESCRIPTION
+
+The section of the FAQ answers question related to the manipulation
+of data as numbers, dates, strings, arrays, hashes, and miscellaneous
+data issues.
+
+=head1 Data: Numbers
+
+=head2 Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)?
+
+The infinite set that a mathematician thinks of as the real numbers can
+only be approximate on a computer, since the computer only has a finite
+number of bits to store an infinite number of, um, numbers.
+
+Internally, your computer represents floating-point numbers in binary.
+Floating-point numbers read in from a file or appearing as literals
+in your program are converted from their decimal floating-point
+representation (eg, 19.95) to the internal binary representation.
+
+However, 19.95 can't be precisely represented as a binary
+floating-point number, just like 1/3 can't be exactly represented as a
+decimal floating-point number. The computer's binary representation
+of 19.95, therefore, isn't exactly 19.95.
+
+When a floating-point number gets printed, the binary floating-point
+representation is converted back to decimal. These decimal numbers
+are displayed in either the format you specify with printf(), or the
+current output format for numbers (see L<perlvar/"$#"> if you use
+print. C<$#> has a different default value in Perl5 than it did in
+Perl4. Changing C<$#> yourself is deprecated.
+
+This affects B<all> computer languages that represent decimal
+floating-point numbers in binary, not just Perl. Perl provides
+arbitrary-precision decimal numbers with the Math::BigFloat module
+(part of the standard Perl distribution), but mathematical operations
+are consequently slower.
+
+To get rid of the superfluous digits, just use a format (eg,
+C<printf("%.2f", 19.95)>) to get the required precision.
+See L<perlop/"Floating-point Arithmetic">.
+
+=head2 Why isn't my octal data interpreted correctly?
+
+Perl only understands octal and hex numbers as such when they occur
+as literals in your program. If they are read in from somewhere and
+assigned, no automatic conversion takes place. You must explicitly
+use oct() or hex() if you want the values converted. oct() interprets
+both hex ("0x350") numbers and octal ones ("0350" or even without the
+leading "0", like "377"), while hex() only converts hexadecimal ones,
+with or without a leading "0x", like "0x255", "3A", "ff", or "deadbeef".
+
+This problem shows up most often when people try using chmod(), mkdir(),
+umask(), or sysopen(), which all want permissions in octal.
+
+ chmod(644, $file); # WRONG -- perl -w catches this
+ chmod(0644, $file); # right
+
+=head2 Does perl have a round function? What about ceil() and floor()? Trig functions?
+
+Remember that int() merely truncates toward 0. For rounding to a
+certain number of digits, sprintf() or printf() is usually the easiest
+route.
+
+ printf("%.3f", 3.1415926535); # prints 3.142
+
+The POSIX module (part of the standard perl distribution) implements
+ceil(), floor(), and a number of other mathematical and trigonometric
+functions.
+
+ use POSIX;
+ $ceil = ceil(3.5); # 4
+ $floor = floor(3.5); # 3
+
+In 5.000 to 5.003 Perls, trigonometry was done in the Math::Complex
+module. With 5.004, the Math::Trig module (part of the standard perl
+distribution) implements the trigonometric functions. Internally it
+uses the Math::Complex module and some functions can break out from
+the real axis into the complex plane, for example the inverse sine of
+2.
+
+Rounding in financial applications can have serious implications, and
+the rounding method used should be specified precisely. In these
+cases, it probably pays not to trust whichever system rounding is
+being used by Perl, but to instead implement the rounding function you
+need yourself.
+
+=head2 How do I convert bits into ints?
+
+To turn a string of 1s and 0s like C<10110110> into a scalar containing
+its binary value, use the pack() function (documented in
+L<perlfunc/"pack">):
+
+ $decimal = pack('B8', '10110110');
+
+Here's an example of going the other way:
+
+ $binary_string = join('', unpack('B*', "\x29"));
+
+=head2 How do I multiply matrices?
+
+Use the Math::Matrix or Math::MatrixReal modules (available from CPAN)
+or the PDL extension (also available from CPAN).
+
+=head2 How do I perform an operation on a series of integers?
+
+To call a function on each element in an array, and collect the
+results, use:
+
+ @results = map { my_func($_) } @array;
+
+For example:
+
+ @triple = map { 3 * $_ } @single;
+
+To call a function on each element of an array, but ignore the
+results:
+
+ foreach $iterator (@array) {
+ &my_func($iterator);
+ }
+
+To call a function on each integer in a (small) range, you B<can> use:
+
+ @results = map { &my_func($_) } (5 .. 25);
+
+but you should be aware that the C<..> operator creates an array of
+all integers in the range. This can take a lot of memory for large
+ranges. Instead use:
+
+ @results = ();
+ for ($i=5; $i < 500_005; $i++) {
+ push(@results, &my_func($i));
+ }
+
+=head2 How can I output Roman numerals?
+
+Get the http://www.perl.com/CPAN/modules/by-module/Roman module.
+
+=head2 Why aren't my random numbers random?
+
+The short explanation is that you're getting pseudorandom numbers, not
+random ones, because computers are good at being predictable and bad
+at being random (despite appearances caused by bugs in your programs
+:-). A longer explanation is available on
+http://www.perl.com/CPAN/doc/FMTEYEWTK/random, courtesy of Tom
+Phoenix. John von Neumann said, ``Anyone who attempts to generate
+random numbers by deterministic means is, of course, living in a state
+of sin.''
+
+You should also check out the Math::TrulyRandom module from CPAN. It
+uses the imperfections in your system's timer to generate random
+numbers, but this takes quite a while. If you want a better
+pseudorandom generator than comes with your operating system, look at
+``Numerical Recipes in C'' at http://nr.harvard.edu/nr/bookc.html .
+
+=head1 Data: Dates
+
+=head2 How do I find the week-of-the-year/day-of-the-year?
+
+The day of the year is in the array returned by localtime() (see
+L<perlfunc/"localtime">):
+
+ $day_of_year = (localtime(time()))[7];
+
+or more legibly (in 5.004 or higher):
+
+ use Time::localtime;
+ $day_of_year = localtime(time())->yday;
+
+You can find the week of the year by dividing this by 7:
+
+ $week_of_year = int($day_of_year / 7);
+
+Of course, this believes that weeks start at zero. The Date::Calc
+module from CPAN has a lot of date calculation functions, including
+day of the year, week of the year, and so on. Note that not
+all business consider ``week 1'' to be the same; for example,
+American business often consider the first week with a Monday
+in it to be Work Week #1, despite ISO 8601, which consider
+WW1 to be the frist week with a Thursday in it.
+
+=head2 How can I compare two dates and find the difference?
+
+If you're storing your dates as epoch seconds then simply subtract one
+from the other. If you've got a structured date (distinct year, day,
+month, hour, minute, seconds values) then use one of the Date::Manip
+and Date::Calc modules from CPAN.
+
+=head2 How can I take a string and turn it into epoch seconds?
+
+If it's a regular enough string that it always has the same format,
+you can split it up and pass the parts to C<timelocal> in the standard
+Time::Local module. Otherwise, you should look into the Date::Calc
+and Date::Manip modules from CPAN.
+
+=head2 How can I find the Julian Day?
+
+Neither Date::Manip nor Date::Calc deal with Julian days. Instead,
+there is an example of Julian date calculation that should help you in
+http://www.perl.com/CPAN/authors/David_Muir_Sharnoff/modules/Time/JulianDay.pm.gz
+.
+
+=head2 Does Perl have a year 2000 problem? Is Perl Y2K compliant?
+
+Short answer: No, Perl does not have a Year 2000 problem. Yes,
+Perl is Y2K compliant. The programmers you're hired to use it,
+however, probably are not.
+
+Long answer: Perl is just as Y2K compliant as your pencil--no more,
+and no less. The date and time functions supplied with perl (gmtime
+and localtime) supply adequate information to determine the year well
+beyond 2000 (2038 is when trouble strikes for 32-bit machines). The
+year returned by these functions when used in an array context is the
+year minus 1900. For years between 1910 and 1999 this I<happens> to
+be a 2-digit decimal number. To avoid the year 2000 problem simply do
+not treat the year as a 2-digit number. It isn't.
+
+When gmtime() and localtime() are used in scalar context they return
+a timestamp string that contains a fully-expanded year. For example,
+C<$timestamp = gmtime(1005613200)> sets $timestamp to "Tue Nov 13 01:00:00
+2001". There's no year 2000 problem here.
+
+That doesn't mean that Perl can't be used to create non-Y2K compliant
+programs. It can. But so can your pencil. It's the fault of the user,
+not the language. At the risk of inflaming the NRA: ``Perl doesn't
+break Y2K, people do.'' See http://language.perl.com/news/y2k.html for
+a longer exposition.
+
+=head1 Data: Strings
+
+=head2 How do I validate input?
+
+The answer to this question is usually a regular expression, perhaps
+with auxiliary logic. See the more specific questions (numbers, mail
+addresses, etc.) for details.
+
+=head2 How do I unescape a string?
+
+It depends just what you mean by ``escape''. URL escapes are dealt
+with in L<perlfaq9>. Shell escapes with the backslash (C<\>)
+character are removed with:
+
+ s/\\(.)/$1/g;
+
+This won't expand C<"\n"> or C<"\t"> or any other special escapes.
+
+=head2 How do I remove consecutive pairs of characters?
+
+To turn C<"abbcccd"> into C<"abccd">:
+
+ s/(.)\1/$1/g;
+
+=head2 How do I expand function calls in a string?
+
+This is documented in L<perlref>. In general, this is fraught with
+quoting and readability problems, but it is possible. To interpolate
+a subroutine call (in list context) into a string:
+
+ print "My sub returned @{[mysub(1,2,3)]} that time.\n";
+
+If you prefer scalar context, similar chicanery is also useful for
+arbitrary expressions:
+
+ print "That yields ${\($n + 5)} widgets\n";
+
+Version 5.004 of Perl had a bug that gave list context to the
+expression in C<${...}>, but this is fixed in version 5.005.
+
+See also ``How can I expand variables in text strings?'' in this
+section of the FAQ.
+
+=head2 How do I find matching/nesting anything?
+
+This isn't something that can be done in one regular expression, no
+matter how complicated. To find something between two single
+characters, a pattern like C</x([^x]*)x/> will get the intervening
+bits in $1. For multiple ones, then something more like
+C</alpha(.*?)omega/> would be needed. But none of these deals with
+nested patterns, nor can they. For that you'll have to write a
+parser.
+
+If you are serious about writing a parser, there are a number of
+modules or oddities that will make your life a lot easier. There is
+the CPAN module Parse::RecDescent, the standard module Text::Balanced,
+the byacc program, and Mark-Jason Dominus's excellent I<py> tool at
+http://www.plover.com/~mjd/perl/py/ .
+
+One simple destructive, inside-out approach that you might try is to
+pull out the smallest nesting parts one at a time:
+
+ while (s//BEGIN((?:(?!BEGIN)(?!END).)*)END/gs) {
+ # do something with $1
+ }
+
+=head2 How do I reverse a string?
+
+Use reverse() in scalar context, as documented in
+L<perlfunc/reverse>.
+
+ $reversed = reverse $string;
+
+=head2 How do I expand tabs in a string?
+
+You can do it yourself:
+
+ 1 while $string =~ s/\t+/' ' x (length($&) * 8 - length($`) % 8)/e;
+
+Or you can just use the Text::Tabs module (part of the standard perl
+distribution).
+
+ use Text::Tabs;
+ @expanded_lines = expand(@lines_with_tabs);
+
+=head2 How do I reformat a paragraph?
+
+Use Text::Wrap (part of the standard perl distribution):
+
+ use Text::Wrap;
+ print wrap("\t", ' ', @paragraphs);
+
+The paragraphs you give to Text::Wrap should not contain embedded
+newlines. Text::Wrap doesn't justify the lines (flush-right).
+
+=head2 How can I access/change the first N letters of a string?
+
+There are many ways. If you just want to grab a copy, use
+substr():
+
+ $first_byte = substr($a, 0, 1);
+
+If you want to modify part of a string, the simplest way is often to
+use substr() as an lvalue:
+
+ substr($a, 0, 3) = "Tom";
+
+Although those with a pattern matching kind of thought process will
+likely prefer:
+
+ $a =~ s/^.../Tom/;
+
+=head2 How do I change the Nth occurrence of something?
+
+You have to keep track of N yourself. For example, let's say you want
+to change the fifth occurrence of C<"whoever"> or C<"whomever"> into
+C<"whosoever"> or C<"whomsoever">, case insensitively.
+
+ $count = 0;
+ s{((whom?)ever)}{
+ ++$count == 5 # is it the 5th?
+ ? "${2}soever" # yes, swap
+ : $1 # renege and leave it there
+ }igex;
+
+In the more general case, you can use the C</g> modifier in a C<while>
+loop, keeping count of matches.
+
+ $WANT = 3;
+ $count = 0;
+ while (/(\w+)\s+fish\b/gi) {
+ if (++$count == $WANT) {
+ print "The third fish is a $1 one.\n";
+ # Warning: don't `last' out of this loop
+ }
+ }
+
+That prints out: C<"The third fish is a red one."> You can also use a
+repetition count and repeated pattern like this:
+
+ /(?:\w+\s+fish\s+){2}(\w+)\s+fish/i;
+
+=head2 How can I count the number of occurrences of a substring within a string?
+
+There are a number of ways, with varying efficiency: If you want a
+count of a certain single character (X) within a string, you can use the
+C<tr///> function like so:
+
+ $string = "ThisXlineXhasXsomeXx'sXinXit":
+ $count = ($string =~ tr/X//);
+ print "There are $count X charcters in the string";
+
+This is fine if you are just looking for a single character. However,
+if you are trying to count multiple character substrings within a
+larger string, C<tr///> won't work. What you can do is wrap a while()
+loop around a global pattern match. For example, let's count negative
+integers:
+
+ $string = "-9 55 48 -2 23 -76 4 14 -44";
+ while ($string =~ /-\d+/g) { $count++ }
+ print "There are $count negative numbers in the string";
+
+=head2 How do I capitalize all the words on one line?
+
+To make the first letter of each word upper case:
+
+ $line =~ s/\b(\w)/\U$1/g;
+
+This has the strange effect of turning "C<don't do it>" into "C<Don'T
+Do It>". Sometimes you might want this, instead (Suggested by Brian
+Foy):
+
+ $string =~ s/ (
+ (^\w) #at the beginning of the line
+ | # or
+ (\s\w) #preceded by whitespace
+ )
+ /\U$1/xg;
+ $string =~ /([\w']+)/\u\L$1/g;
+
+To make the whole line upper case:
+
+ $line = uc($line);
+
+To force each word to be lower case, with the first letter upper case:
+
+ $line =~ s/(\w+)/\u\L$1/g;
+
+You can (and probably should) enable locale awareness of those
+characters by placing a C<use locale> pragma in your program.
+See L<perllocale> for endless details on locales.
+
+=head2 How can I split a [character] delimited string except when inside
+[character]? (Comma-separated files)
+
+Take the example case of trying to split a string that is comma-separated
+into its different fields. (We'll pretend you said comma-separated, not
+comma-delimited, which is different and almost never what you mean.) You
+can't use C<split(/,/)> because you shouldn't split if the comma is inside
+quotes. For example, take a data line like this:
+
+ SAR001,"","Cimetrix, Inc","Bob Smith","CAM",N,8,1,0,7,"Error, Core Dumped"
+
+Due to the restriction of the quotes, this is a fairly complex
+problem. Thankfully, we have Jeffrey Friedl, author of a highly
+recommended book on regular expressions, to handle these for us. He
+suggests (assuming your string is contained in $text):
+
+ @new = ();
+ push(@new, $+) while $text =~ m{
+ "([^\"\\]*(?:\\.[^\"\\]*)*)",? # groups the phrase inside the quotes
+ | ([^,]+),?
+ | ,
+ }gx;
+ push(@new, undef) if substr($text,-1,1) eq ',';
+
+If you want to represent quotation marks inside a
+quotation-mark-delimited field, escape them with backslashes (eg,
+C<"like \"this\"">. Unescaping them is a task addressed earlier in
+this section.
+
+Alternatively, the Text::ParseWords module (part of the standard perl
+distribution) lets you say:
+
+ use Text::ParseWords;
+ @new = quotewords(",", 0, $text);
+
+=head2 How do I strip blank space from the beginning/end of a string?
+
+Although the simplest approach would seem to be:
+
+ $string =~ s/^\s*(.*?)\s*$/$1/;
+
+This is unneccesarily slow, destructive, and fails with embedded newlines.
+It is much better faster to do this in two steps:
+
+ $string =~ s/^\s+//;
+ $string =~ s/\s+$//;
+
+Or more nicely written as:
+
+ for ($string) {
+ s/^\s+//;
+ s/\s+$//;
+ }
+
+This idiom takes advantage of the C<foreach> loop's aliasing
+behavior to factor out common code. You can do this
+on several strings at once, or arrays, or even the
+values of a hash if you use a slide:
+
+ # trim whitespace in the scalar, the array,
+ # and all the values in the hash
+ foreach ($scalar, @array, @hash{keys %hash}) {
+ s/^\s+//;
+ s/\s+$//;
+ }
+
+=head2 How do I extract selected columns from a string?
+
+Use substr() or unpack(), both documented in L<perlfunc>.
+If you prefer thinking in terms of columns instead of widths,
+you can use this kind of thing:
+
+ # determine the unpack format needed to split Linux ps output
+ # arguments are cut columns
+ my $fmt = cut2fmt(8, 14, 20, 26, 30, 34, 41, 47, 59, 63, 67, 72);
+
+ sub cut2fmt {
+ my(@positions) = @_;
+ my $template = '';
+ my $lastpos = 1;
+ for my $place (@positions) {
+ $template .= "A" . ($place - $lastpos) . " ";
+ $lastpos = $place;
+ }
+ $template .= "A*";
+ return $template;
+ }
+
+=head2 How do I find the soundex value of a string?
+
+Use the standard Text::Soundex module distributed with perl.
+
+=head2 How can I expand variables in text strings?
+
+Let's assume that you have a string like:
+
+ $text = 'this has a $foo in it and a $bar';
+
+If those were both global variables, then this would
+suffice:
+
+ $text =~ s/\$(\w+)/${$1}/g;
+
+But since they are probably lexicals, or at least, they could
+be, you'd have to do this:
+
+ $text =~ s/(\$\w+)/$1/eeg;
+ die if $@; # needed on /ee, not /e
+
+It's probably better in the general case to treat those
+variables as entries in some special hash. For example:
+
+ %user_defs = (
+ foo => 23,
+ bar => 19,
+ );
+ $text =~ s/\$(\w+)/$user_defs{$1}/g;
+
+See also ``How do I expand function calls in a string?'' in this section
+of the FAQ.
+
+=head2 What's wrong with always quoting "$vars"?
+
+The problem is that those double-quotes force stringification,
+coercing numbers and references into strings, even when you
+don't want them to be.
+
+If you get used to writing odd things like these:
+
+ print "$var"; # BAD
+ $new = "$old"; # BAD
+ somefunc("$var"); # BAD
+
+You'll be in trouble. Those should (in 99.8% of the cases) be
+the simpler and more direct:
+
+ print $var;
+ $new = $old;
+ somefunc($var);
+
+Otherwise, besides slowing you down, you're going to break code when
+the thing in the scalar is actually neither a string nor a number, but
+a reference:
+
+ func(\@array);
+ sub func {
+ my $aref = shift;
+ my $oref = "$aref"; # WRONG
+ }
+
+You can also get into subtle problems on those few operations in Perl
+that actually do care about the difference between a string and a
+number, such as the magical C<++> autoincrement operator or the
+syscall() function.
+
+Stringification also destroys arrays.
+
+ @lines = `command`;
+ print "@lines"; # WRONG - extra blanks
+ print @lines; # right
+
+=head2 Why don't my <<HERE documents work?
+
+Check for these three things:
+
+=over 4
+
+=item 1. There must be no space after the << part.
+
+=item 2. There (probably) should be a semicolon at the end.
+
+=item 3. You can't (easily) have any space in front of the tag.
+
+=back
+
+If you want to indent the text in the here document, you
+can do this:
+
+ # all in one
+ ($VAR = <<HERE_TARGET) =~ s/^\s+//gm;
+ your text
+ goes here
+ HERE_TARGET
+
+But the HERE_TARGET must still be flush against the margin.
+If you want that indented also, you'll have to quote
+in the indentation.
+
+ ($quote = <<' FINIS') =~ s/^\s+//gm;
+ ...we will have peace, when you and all your works have
+ perished--and the works of your dark master to whom you
+ would deliver us. You are a liar, Saruman, and a corrupter
+ of men's hearts. --Theoden in /usr/src/perl/taint.c
+ FINIS
+ $quote =~ s/\s*--/\n--/;
+
+A nice general-purpose fixer-upper function for indented here documents
+follows. It expects to be called with a here document as its argument.
+It looks to see whether each line begins with a common substring, and
+if so, strips that off. Otherwise, it takes the amount of leading
+white space found on the first line and removes that much off each
+subsequent line.
+
+ sub fix {
+ local $_ = shift;
+ my ($white, $leader); # common white space and common leading string
+ if (/^\s*(?:([^\w\s]+)(\s*).*\n)(?:\s*\1\2?.*\n)+$/) {
+ ($white, $leader) = ($2, quotemeta($1));
+ } else {
+ ($white, $leader) = (/^(\s+)/, '');
+ }
+ s/^\s*?$leader(?:$white)?//gm;
+ return $_;
+ }
+
+This works with leading special strings, dynamically determined:
+
+ $remember_the_main = fix<<' MAIN_INTERPRETER_LOOP';
+ @@@ int
+ @@@ runops() {
+ @@@ SAVEI32(runlevel);
+ @@@ runlevel++;
+ @@@ while ( op = (*op->op_ppaddr)() ) ;
+ @@@ TAINT_NOT;
+ @@@ return 0;
+ @@@ }
+ MAIN_INTERPRETER_LOOP
+
+Or with a fixed amount of leading white space, with remaining
+indentation correctly preserved:
+
+ $poem = fix<<EVER_ON_AND_ON;
+ Now far ahead the Road has gone,
+ And I must follow, if I can,
+ Pursuing it with eager feet,
+ Until it joins some larger way
+ Where many paths and errands meet.
+ And whither then? I cannot say.
+ --Bilbo in /usr/src/perl/pp_ctl.c
+ EVER_ON_AND_ON
+
+=head1 Data: Arrays
+
+=head2 What is the difference between $array[1] and @array[1]?
+
+The former is a scalar value, the latter an array slice, which makes
+it a list with one (scalar) value. You should use $ when you want a
+scalar value (most of the time) and @ when you want a list with one
+scalar value in it (very, very rarely; nearly never, in fact).
+
+Sometimes it doesn't make a difference, but sometimes it does.
+For example, compare:
+
+ $good[0] = `some program that outputs several lines`;
+
+with
+
+ @bad[0] = `same program that outputs several lines`;
+
+The B<-w> flag will warn you about these matters.
+
+=head2 How can I extract just the unique elements of an array?
+
+There are several possible ways, depending on whether the array is
+ordered and whether you wish to preserve the ordering.
+
+=over 4
+
+=item a) If @in is sorted, and you want @out to be sorted:
+(this assumes all true values in the array)
+
+ $prev = 'nonesuch';
+ @out = grep($_ ne $prev && ($prev = $_), @in);
+
+This is nice in that it doesn't use much extra memory, simulating
+uniq(1)'s behavior of removing only adjacent duplicates. It's less
+nice in that it won't work with false values like undef, 0, or "";
+"0 but true" is ok, though.
+
+=item b) If you don't know whether @in is sorted:
+
+ undef %saw;
+ @out = grep(!$saw{$_}++, @in);
+
+=item c) Like (b), but @in contains only small integers:
+
+ @out = grep(!$saw[$_]++, @in);
+
+=item d) A way to do (b) without any loops or greps:
+
+ undef %saw;
+ @saw{@in} = ();
+ @out = sort keys %saw; # remove sort if undesired
+
+=item e) Like (d), but @in contains only small positive integers:
+
+ undef @ary;
+ @ary[@in] = @in;
+ @out = @ary;
+
+=back
+
+=head2 How can I tell whether a list or array contains a certain element?
+
+Hearing the word "in" is an I<in>dication that you probably should have
+used a hash, not a list or array, to store your data. Hashes are
+designed to answer this question quickly and efficiently. Arrays aren't.
+
+That being said, there are several ways to approach this. If you
+are going to make this query many times over arbitrary string values,
+the fastest way is probably to invert the original array and keep an
+associative array lying about whose keys are the first array's values.
+
+ @blues = qw/azure cerulean teal turquoise lapis-lazuli/;
+ undef %is_blue;
+ for (@blues) { $is_blue{$_} = 1 }
+
+Now you can check whether $is_blue{$some_color}. It might have been a
+good idea to keep the blues all in a hash in the first place.
+
+If the values are all small integers, you could use a simple indexed
+array. This kind of an array will take up less space:
+
+ @primes = (2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31);
+ undef @is_tiny_prime;
+ for (@primes) { $is_tiny_prime[$_] = 1; }
+
+Now you check whether $is_tiny_prime[$some_number].
+
+If the values in question are integers instead of strings, you can save
+quite a lot of space by using bit strings instead:
+
+ @articles = ( 1..10, 150..2000, 2017 );
+ undef $read;
+ for (@articles) { vec($read,$_,1) = 1 }
+
+Now check whether C<vec($read,$n,1)> is true for some C<$n>.
+
+Please do not use
+
+ $is_there = grep $_ eq $whatever, @array;
+
+or worse yet
+
+ $is_there = grep /$whatever/, @array;
+
+These are slow (checks every element even if the first matches),
+inefficient (same reason), and potentially buggy (what if there are
+regexp characters in $whatever?).
+
+=head2 How do I compute the difference of two arrays? How do I compute the intersection of two arrays?
+
+Use a hash. Here's code to do both and more. It assumes that
+each element is unique in a given array:
+
+ @union = @intersection = @difference = ();
+ %count = ();
+ foreach $element (@array1, @array2) { $count{$element}++ }
+ foreach $element (keys %count) {
+ push @union, $element;
+ push @{ $count{$element} > 1 ? \@intersection : \@difference }, $element;
+ }
+
+=head2 How do I find the first array element for which a condition is true?
+
+You can use this if you care about the index:
+
+ for ($i=0; $i < @array; $i++) {
+ if ($array[$i] eq "Waldo") {
+ $found_index = $i;
+ last;
+ }
+ }
+
+Now C<$found_index> has what you want.
+
+=head2 How do I handle linked lists?
+
+In general, you usually don't need a linked list in Perl, since with
+regular arrays, you can push and pop or shift and unshift at either end,
+or you can use splice to add and/or remove arbitrary number of elements at
+arbitrary points. Both pop and shift are both O(1) operations on perl's
+dynamic arrays. In the absence of shifts and pops, push in general
+needs to reallocate on the order every log(N) times, and unshift will
+need to copy pointers each time.
+
+If you really, really wanted, you could use structures as described in
+L<perldsc> or L<perltoot> and do just what the algorithm book tells you
+to do.
+
+=head2 How do I handle circular lists?
+
+Circular lists could be handled in the traditional fashion with linked
+lists, or you could just do something like this with an array:
+
+ unshift(@array, pop(@array)); # the last shall be first
+ push(@array, shift(@array)); # and vice versa
+
+=head2 How do I shuffle an array randomly?
+
+Use this:
+
+ # fisher_yates_shuffle( \@array ) :
+ # generate a random permutation of @array in place
+ sub fisher_yates_shuffle {
+ my $array = shift;
+ my $i;
+ for ($i = @$array; --$i; ) {
+ my $j = int rand ($i+1);
+ next if $i == $j;
+ @$array[$i,$j] = @$array[$j,$i];
+ }
+ }
+
+ fisher_yates_shuffle( \@array ); # permutes @array in place
+
+You've probably seen shuffling algorithms that works using splice,
+randomly picking another element to swap the current element with:
+
+ srand;
+ @new = ();
+ @old = 1 .. 10; # just a demo
+ while (@old) {
+ push(@new, splice(@old, rand @old, 1));
+ }
+
+This is bad because splice is already O(N), and since you do it N times,
+you just invented a quadratic algorithm; that is, O(N**2). This does
+not scale, although Perl is so efficient that you probably won't notice
+this until you have rather largish arrays.
+
+=head2 How do I process/modify each element of an array?
+
+Use C<for>/C<foreach>:
+
+ for (@lines) {
+ s/foo/bar/; # change that word
+ y/XZ/ZX/; # swap those letters
+ }
+
+Here's another; let's compute spherical volumes:
+
+ for (@volumes = @radii) { # @volumes has changed parts
+ $_ **= 3;
+ $_ *= (4/3) * 3.14159; # this will be constant folded
+ }
+
+If you want to do the same thing to modify the values of the hash,
+you may not use the C<values> function, oddly enough. You need a slice:
+
+ for $orbit ( @orbits{keys %orbits} ) {
+ ($orbit **= 3) *= (4/3) * 3.14159;
+ }
+
+=head2 How do I select a random element from an array?
+
+Use the rand() function (see L<perlfunc/rand>):
+
+ # at the top of the program:
+ srand; # not needed for 5.004 and later
+
+ # then later on
+ $index = rand @array;
+ $element = $array[$index];
+
+Make sure you I<only call srand once per program, if then>.
+If you are calling it more than once (such as before each
+call to rand), you're almost certainly doing something wrong.
+
+=head2 How do I permute N elements of a list?
+
+Here's a little program that generates all permutations
+of all the words on each line of input. The algorithm embodied
+in the permute() function should work on any list:
+
+ #!/usr/bin/perl -n
+ # tsc-permute: permute each word of input
+ permute([split], []);
+ sub permute {
+ my @items = @{ $_[0] };
+ my @perms = @{ $_[1] };
+ unless (@items) {
+ print "@perms\n";
+ } else {
+ my(@newitems,@newperms,$i);
+ foreach $i (0 .. $#items) {
+ @newitems = @items;
+ @newperms = @perms;
+ unshift(@newperms, splice(@newitems, $i, 1));
+ permute([@newitems], [@newperms]);
+ }
+ }
+ }
+
+=head2 How do I sort an array by (anything)?
+
+Supply a comparison function to sort() (described in L<perlfunc/sort>):
+
+ @list = sort { $a <=> $b } @list;
+
+The default sort function is cmp, string comparison, which would
+sort C<(1, 2, 10)> into C<(1, 10, 2)>. C<E<lt>=E<gt>>, used above, is
+the numerical comparison operator.
+
+If you have a complicated function needed to pull out the part you
+want to sort on, then don't do it inside the sort function. Pull it
+out first, because the sort BLOCK can be called many times for the
+same element. Here's an example of how to pull out the first word
+after the first number on each item, and then sort those words
+case-insensitively.
+
+ @idx = ();
+ for (@data) {
+ ($item) = /\d+\s*(\S+)/;
+ push @idx, uc($item);
+ }
+ @sorted = @data[ sort { $idx[$a] cmp $idx[$b] } 0 .. $#idx ];
+
+Which could also be written this way, using a trick
+that's come to be known as the Schwartzian Transform:
+
+ @sorted = map { $_->[0] }
+ sort { $a->[1] cmp $b->[1] }
+ map { [ $_, uc((/\d+\s*(\S+)/ )[0] ] } @data;
+
+If you need to sort on several fields, the following paradigm is useful.
+
+ @sorted = sort { field1($a) <=> field1($b) ||
+ field2($a) cmp field2($b) ||
+ field3($a) cmp field3($b)
+ } @data;
+
+This can be conveniently combined with precalculation of keys as given
+above.
+
+See http://www.perl.com/CPAN/doc/FMTEYEWTK/sort.html for more about
+this approach.
+
+See also the question below on sorting hashes.
+
+=head2 How do I manipulate arrays of bits?
+
+Use pack() and unpack(), or else vec() and the bitwise operations.
+
+For example, this sets $vec to have bit N set if $ints[N] was set:
+
+ $vec = '';
+ foreach(@ints) { vec($vec,$_,1) = 1 }
+
+And here's how, given a vector in $vec, you can
+get those bits into your @ints array:
+
+ sub bitvec_to_list {
+ my $vec = shift;
+ my @ints;
+ # Find null-byte density then select best algorithm
+ if ($vec =~ tr/\0// / length $vec > 0.95) {
+ use integer;
+ my $i;
+ # This method is faster with mostly null-bytes
+ while($vec =~ /[^\0]/g ) {
+ $i = -9 + 8 * pos $vec;
+ push @ints, $i if vec($vec, ++$i, 1);
+ push @ints, $i if vec($vec, ++$i, 1);
+ push @ints, $i if vec($vec, ++$i, 1);
+ push @ints, $i if vec($vec, ++$i, 1);
+ push @ints, $i if vec($vec, ++$i, 1);
+ push @ints, $i if vec($vec, ++$i, 1);
+ push @ints, $i if vec($vec, ++$i, 1);
+ push @ints, $i if vec($vec, ++$i, 1);
+ }
+ } else {
+ # This method is a fast general algorithm
+ use integer;
+ my $bits = unpack "b*", $vec;
+ push @ints, 0 if $bits =~ s/^(\d)// && $1;
+ push @ints, pos $bits while($bits =~ /1/g);
+ }
+ return \@ints;
+ }
+
+This method gets faster the more sparse the bit vector is.
+(Courtesy of Tim Bunce and Winfried Koenig.)
+
+=head2 Why does defined() return true on empty arrays and hashes?
+
+See L<perlfunc/defined> in the 5.004 release or later of Perl.
+
+=head1 Data: Hashes (Associative Arrays)
+
+=head2 How do I process an entire hash?
+
+Use the each() function (see L<perlfunc/each>) if you don't care
+whether it's sorted:
+
+ while ( ($key, $value) = each %hash) {
+ print "$key = $value\n";
+ }
+
+If you want it sorted, you'll have to use foreach() on the result of
+sorting the keys as shown in an earlier question.
+
+=head2 What happens if I add or remove keys from a hash while iterating over it?
+
+Don't do that.
+
+=head2 How do I look up a hash element by value?
+
+Create a reverse hash:
+
+ %by_value = reverse %by_key;
+ $key = $by_value{$value};
+
+That's not particularly efficient. It would be more space-efficient
+to use:
+
+ while (($key, $value) = each %by_key) {
+ $by_value{$value} = $key;
+ }
+
+If your hash could have repeated values, the methods above will only
+find one of the associated keys. This may or may not worry you.
+
+=head2 How can I know how many entries are in a hash?
+
+If you mean how many keys, then all you have to do is
+take the scalar sense of the keys() function:
+
+ $num_keys = scalar keys %hash;
+
+In void context it just resets the iterator, which is faster
+for tied hashes.
+
+=head2 How do I sort a hash (optionally by value instead of key)?
+
+Internally, hashes are stored in a way that prevents you from imposing
+an order on key-value pairs. Instead, you have to sort a list of the
+keys or values:
+
+ @keys = sort keys %hash; # sorted by key
+ @keys = sort {
+ $hash{$a} cmp $hash{$b}
+ } keys %hash; # and by value
+
+Here we'll do a reverse numeric sort by value, and if two keys are
+identical, sort by length of key, and if that fails, by straight ASCII
+comparison of the keys (well, possibly modified by your locale -- see
+L<perllocale>).
+
+ @keys = sort {
+ $hash{$b} <=> $hash{$a}
+ ||
+ length($b) <=> length($a)
+ ||
+ $a cmp $b
+ } keys %hash;
+
+=head2 How can I always keep my hash sorted?
+
+You can look into using the DB_File module and tie() using the
+$DB_BTREE hash bindings as documented in L<DB_File/"In Memory Databases">.
+The Tie::IxHash module from CPAN might also be instructive.
+
+=head2 What's the difference between "delete" and "undef" with hashes?
+
+Hashes are pairs of scalars: the first is the key, the second is the
+value. The key will be coerced to a string, although the value can be
+any kind of scalar: string, number, or reference. If a key C<$key> is
+present in the array, C<exists($key)> will return true. The value for
+a given key can be C<undef>, in which case C<$array{$key}> will be
+C<undef> while C<$exists{$key}> will return true. This corresponds to
+(C<$key>, C<undef>) being in the hash.
+
+Pictures help... here's the C<%ary> table:
+
+ keys values
+ +------+------+
+ | a | 3 |
+ | x | 7 |
+ | d | 0 |
+ | e | 2 |
+ +------+------+
+
+And these conditions hold
+
+ $ary{'a'} is true
+ $ary{'d'} is false
+ defined $ary{'d'} is true
+ defined $ary{'a'} is true
+ exists $ary{'a'} is true (perl5 only)
+ grep ($_ eq 'a', keys %ary) is true
+
+If you now say
+
+ undef $ary{'a'}
+
+your table now reads:
+
+
+ keys values
+ +------+------+
+ | a | undef|
+ | x | 7 |
+ | d | 0 |
+ | e | 2 |
+ +------+------+
+
+and these conditions now hold; changes in caps:
+
+ $ary{'a'} is FALSE
+ $ary{'d'} is false
+ defined $ary{'d'} is true
+ defined $ary{'a'} is FALSE
+ exists $ary{'a'} is true (perl5 only)
+ grep ($_ eq 'a', keys %ary) is true
+
+Notice the last two: you have an undef value, but a defined key!
+
+Now, consider this:
+
+ delete $ary{'a'}
+
+your table now reads:
+
+ keys values
+ +------+------+
+ | x | 7 |
+ | d | 0 |
+ | e | 2 |
+ +------+------+
+
+and these conditions now hold; changes in caps:
+
+ $ary{'a'} is false
+ $ary{'d'} is false
+ defined $ary{'d'} is true
+ defined $ary{'a'} is false
+ exists $ary{'a'} is FALSE (perl5 only)
+ grep ($_ eq 'a', keys %ary) is FALSE
+
+See, the whole entry is gone!
+
+=head2 Why don't my tied hashes make the defined/exists distinction?
+
+They may or may not implement the EXISTS() and DEFINED() methods
+differently. For example, there isn't the concept of undef with hashes
+that are tied to DBM* files. This means the true/false tables above
+will give different results when used on such a hash. It also means
+that exists and defined do the same thing with a DBM* file, and what
+they end up doing is not what they do with ordinary hashes.
+
+=head2 How do I reset an each() operation part-way through?
+
+Using C<keys %hash> in scalar context returns the number of keys in
+the hash I<and> resets the iterator associated with the hash. You may
+need to do this if you use C<last> to exit a loop early so that when you
+re-enter it, the hash iterator has been reset.
+
+=head2 How can I get the unique keys from two hashes?
+
+First you extract the keys from the hashes into arrays, and then solve
+the uniquifying the array problem described above. For example:
+
+ %seen = ();
+ for $element (keys(%foo), keys(%bar)) {
+ $seen{$element}++;
+ }
+ @uniq = keys %seen;
+
+Or more succinctly:
+
+ @uniq = keys %{{%foo,%bar}};
+
+Or if you really want to save space:
+
+ %seen = ();
+ while (defined ($key = each %foo)) {
+ $seen{$key}++;
+ }
+ while (defined ($key = each %bar)) {
+ $seen{$key}++;
+ }
+ @uniq = keys %seen;
+
+=head2 How can I store a multidimensional array in a DBM file?
+
+Either stringify the structure yourself (no fun), or else
+get the MLDBM (which uses Data::Dumper) module from CPAN and layer
+it on top of either DB_File or GDBM_File.
+
+=head2 How can I make my hash remember the order I put elements into it?
+
+Use the Tie::IxHash from CPAN.
+
+ use Tie::IxHash;
+ tie(%myhash, Tie::IxHash);
+ for ($i=0; $i<20; $i++) {
+ $myhash{$i} = 2*$i;
+ }
+ @keys = keys %myhash;
+ # @keys = (0,1,2,3,...)
+
+=head2 Why does passing a subroutine an undefined element in a hash create it?
+
+If you say something like:
+
+ somefunc($hash{"nonesuch key here"});
+
+Then that element "autovivifies"; that is, it springs into existence
+whether you store something there or not. That's because functions
+get scalars passed in by reference. If somefunc() modifies C<$_[0]>,
+it has to be ready to write it back into the caller's version.
+
+This has been fixed as of perl5.004.
+
+Normally, merely accessing a key's value for a nonexistent key does
+I<not> cause that key to be forever there. This is different than
+awk's behavior.
+
+=head2 How can I make the Perl equivalent of a C structure/C++ class/hash or array of hashes or arrays?
+
+Use references (documented in L<perlref>). Examples of complex data
+structures are given in L<perldsc> and L<perllol>. Examples of
+structures and object-oriented classes are in L<perltoot>.
+
+=head2 How can I use a reference as a hash key?
+
+You can't do this directly, but you could use the standard Tie::Refhash
+module distributed with perl.
+
+=head1 Data: Misc
+
+=head2 How do I handle binary data correctly?
+
+Perl is binary clean, so this shouldn't be a problem. For example,
+this works fine (assuming the files are found):
+
+ if (`cat /vmunix` =~ /gzip/) {
+ print "Your kernel is GNU-zip enabled!\n";
+ }
+
+On some systems, however, you have to play tedious games with "text"
+versus "binary" files. See L<perlfunc/"binmode">.
+
+If you're concerned about 8-bit ASCII data, then see L<perllocale>.
+
+If you want to deal with multibyte characters, however, there are
+some gotchas. See the section on Regular Expressions.
+
+=head2 How do I determine whether a scalar is a number/whole/integer/float?
+
+Assuming that you don't care about IEEE notations like "NaN" or
+"Infinity", you probably just want to use a regular expression.
+
+ warn "has nondigits" if /\D/;
+ warn "not a natural number" unless /^\d+$/; # rejects -3
+ warn "not an integer" unless /^-?\d+$/; # rejects +3
+ warn "not an integer" unless /^[+-]?\d+$/;
+ warn "not a decimal number" unless /^-?\d+\.?\d*$/; # rejects .2
+ warn "not a decimal number" unless /^-?(?:\d+(?:\.\d*)?|\.\d+)$/;
+ warn "not a C float"
+ unless /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
+
+If you're on a POSIX system, Perl's supports the C<POSIX::strtod>
+function. Its semantics are somewhat cumbersome, so here's a C<getnum>
+wrapper function for more convenient access. This function takes
+a string and returns the number it found, or C<undef> for input that
+isn't a C float. The C<is_numeric> function is a front end to C<getnum>
+if you just want to say, ``Is this a float?''
+
+ sub getnum {
+ use POSIX qw(strtod);
+ my $str = shift;
+ $str =~ s/^\s+//;
+ $str =~ s/\s+$//;
+ $! = 0;
+ my($num, $unparsed) = strtod($str);
+ if (($str eq '') || ($unparsed != 0) || $!) {
+ return undef;
+ } else {
+ return $num;
+ }
+ }
+
+ sub is_numeric { defined &getnum }
+
+Or you could check out
+http://www.perl.com/CPAN/modules/by-module/String/String-Scanf-1.1.tar.gz
+instead. The POSIX module (part of the standard Perl distribution)
+provides the C<strtol> and C<strtod> for converting strings to double
+and longs, respectively.
+
+=head2 How do I keep persistent data across program calls?
+
+For some specific applications, you can use one of the DBM modules.
+See L<AnyDBM_File>. More generically, you should consult the
+FreezeThaw, Storable, or Class::Eroot modules from CPAN.
+
+=head2 How do I print out or copy a recursive data structure?
+
+The Data::Dumper module on CPAN is nice for printing out
+data structures, and FreezeThaw for copying them. For example:
+
+ use FreezeThaw qw(freeze thaw);
+ $new = thaw freeze $old;
+
+Where $old can be (a reference to) any kind of data structure you'd like.
+It will be deeply copied.
+
+=head2 How do I define methods for every class/object?
+
+Use the UNIVERSAL class (see L<UNIVERSAL>).
+
+=head2 How do I verify a credit card checksum?
+
+Get the Business::CreditCard module from CPAN.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+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 I<outside>
+of that package require that special arrangements be made with
+copyright holder.
+
+Irrespective of its distribution, all code examples in this file
+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.
diff --git a/contrib/perl5/pod/perlfaq5.pod b/contrib/perl5/pod/perlfaq5.pod
new file mode 100644
index 000000000000..98e706afadd3
--- /dev/null
+++ b/contrib/perl5/pod/perlfaq5.pod
@@ -0,0 +1,1074 @@
+=head1 NAME
+
+perlfaq5 - Files and Formats ($Revision: 1.24 $, $Date: 1998/07/05 15:07:20 $)
+
+=head1 DESCRIPTION
+
+This section deals with I/O and the "f" issues: filehandles, flushing,
+formats, and footers.
+
+=head2 How do I flush/unbuffer an output filehandle? Why must I do this?
+
+The C standard I/O library (stdio) normally buffers characters sent to
+devices. This is done for efficiency reasons, so that there isn't a
+system call for each byte. Any time you use print() or write() in
+Perl, you go though this buffering. syswrite() circumvents stdio and
+buffering.
+
+In most stdio implementations, the type of output buffering and the size of
+the buffer varies according to the type of device. Disk files are block
+buffered, often with a buffer size of more than 2k. Pipes and sockets
+are often buffered with a buffer size between 1/2 and 2k. Serial devices
+(e.g. modems, terminals) are normally line-buffered, and stdio sends
+the entire line when it gets the newline.
+
+Perl does not support truly unbuffered output (except insofar as you can
+C<syswrite(OUT, $char, 1)>). What it does instead support is "command
+buffering", in which a physical write is performed after every output
+command. This isn't as hard on your system as unbuffering, but does
+get the output where you want it when you want it.
+
+If you expect characters to get to your device when you print them there,
+you'll want to autoflush its handle.
+Use select() and the C<$|> variable to control autoflushing
+(see L<perlvar/$|> and L<perlfunc/select>):
+
+ $old_fh = select(OUTPUT_HANDLE);
+ $| = 1;
+ select($old_fh);
+
+Or using the traditional idiom:
+
+ select((select(OUTPUT_HANDLE), $| = 1)[0]);
+
+Or if don't mind slowly loading several thousand lines of module code
+just because you're afraid of the C<$|> variable:
+
+ use FileHandle;
+ open(DEV, "+</dev/tty"); # ceci n'est pas une pipe
+ DEV->autoflush(1);
+
+or the newer IO::* modules:
+
+ use IO::Handle;
+ open(DEV, ">/dev/printer"); # but is this?
+ DEV->autoflush(1);
+
+or even this:
+
+ use IO::Socket; # this one is kinda a pipe?
+ $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.com',
+ PeerPort => 'http(80)',
+ Proto => 'tcp');
+ die "$!" unless $sock;
+
+ $sock->autoflush();
+ print $sock "GET / HTTP/1.0" . "\015\012" x 2;
+ $document = join('', <$sock>);
+ print "DOC IS: $document\n";
+
+Note the bizarrely hardcoded carriage return and newline in their octal
+equivalents. This is the ONLY way (currently) to assure a proper flush
+on all platforms, including Macintosh. That the way things work in
+network programming: you really should specify the exact bit pattern
+on the network line terminator. In practice, C<"\n\n"> often works,
+but this is not portable.
+
+See L<perlfaq9> for other examples of fetching URLs over the web.
+
+=head2 How do I change one line in a file/delete a line in a file/insert a line in the middle of a file/append to the beginning of a file?
+
+Although humans have an easy time thinking of a text file as being a
+sequence of lines that operates much like a stack of playing cards --
+or punch cards -- computers usually see the text file as a sequence of
+bytes. In general, there's no direct way for Perl to seek to a
+particular line of a file, insert text into a file, or remove text
+from a file.
+
+(There are exceptions in special circumstances. You can add or remove at
+the very end of the file. Another is replacing a sequence of bytes with
+another sequence of the same length. Another is using the C<$DB_RECNO>
+array bindings as documented in L<DB_File>. Yet another is manipulating
+files with all lines the same length.)
+
+The general solution is to create a temporary copy of the text file with
+the changes you want, then copy that over the original. This assumes
+no locking.
+
+ $old = $file;
+ $new = "$file.tmp.$$";
+ $bak = "$file.bak";
+
+ open(OLD, "< $old") or die "can't open $old: $!";
+ open(NEW, "> $new") or die "can't open $new: $!";
+
+ # Correct typos, preserving case
+ while (<OLD>) {
+ s/\b(p)earl\b/${1}erl/i;
+ (print NEW $_) or die "can't write to $new: $!";
+ }
+
+ close(OLD) or die "can't close $old: $!";
+ close(NEW) or die "can't close $new: $!";
+
+ rename($old, $bak) or die "can't rename $old to $bak: $!";
+ rename($new, $old) or die "can't rename $new to $old: $!";
+
+Perl can do this sort of thing for you automatically with the C<-i>
+command-line switch or the closely-related C<$^I> variable (see
+L<perlrun> for more details). Note that
+C<-i> may require a suffix on some non-Unix systems; see the
+platform-specific documentation that came with your port.
+
+ # Renumber a series of tests from the command line
+ perl -pi -e 's/(^\s+test\s+)\d+/ $1 . ++$count /e' t/op/taint.t
+
+ # form a script
+ local($^I, @ARGV) = ('.bak', glob("*.c"));
+ while (<>) {
+ if ($. == 1) {
+ print "This line should appear at the top of each file\n";
+ }
+ s/\b(p)earl\b/${1}erl/i; # Correct typos, preserving case
+ print;
+ close ARGV if eof; # Reset $.
+ }
+
+If you need to seek to an arbitrary line of a file that changes
+infrequently, you could build up an index of byte positions of where
+the line ends are in the file. If the file is large, an index of
+every tenth or hundredth line end would allow you to seek and read
+fairly efficiently. If the file is sorted, try the look.pl library
+(part of the standard perl distribution).
+
+In the unique case of deleting lines at the end of a file, you
+can use tell() and truncate(). The following code snippet deletes
+the last line of a file without making a copy or reading the
+whole file into memory:
+
+ open (FH, "+< $file");
+ while ( <FH> ) { $addr = tell(FH) unless eof(FH) }
+ truncate(FH, $addr);
+
+Error checking is left as an exercise for the reader.
+
+=head2 How do I count the number of lines in a file?
+
+One fairly efficient way is to count newlines in the file. The
+following program uses a feature of tr///, as documented in L<perlop>.
+If your text file doesn't end with a newline, then it's not really a
+proper text file, so this may report one fewer line than you expect.
+
+ $lines = 0;
+ open(FILE, $filename) or die "Can't open `$filename': $!";
+ while (sysread FILE, $buffer, 4096) {
+ $lines += ($buffer =~ tr/\n//);
+ }
+ close FILE;
+
+This assumes no funny games with newline translations.
+
+=head2 How do I make a temporary file name?
+
+Use the C<new_tmpfile> class method from the IO::File module to get a
+filehandle opened for reading and writing. Use this if you don't
+need to know the file's name.
+
+ use IO::File;
+ $fh = IO::File->new_tmpfile()
+ or die "Unable to make new temporary file: $!";
+
+Or you can use the C<tmpnam> function from the POSIX module to get a
+filename that you then open yourself. Use this if you do need to know
+the file's name.
+
+ use Fcntl;
+ use POSIX qw(tmpnam);
+
+ # try new temporary filenames until we get one that didn't already
+ # exist; the check should be unnecessary, but you can't be too careful
+ do { $name = tmpnam() }
+ until sysopen(FH, $name, O_RDWR|O_CREAT|O_EXCL);
+
+ # install atexit-style handler so that when we exit or die,
+ # we automatically delete this temporary file
+ END { unlink($name) or die "Couldn't unlink $name : $!" }
+
+ # now go on to use the file ...
+
+If you're committed to doing this by hand, use the process ID and/or
+the current time-value. If you need to have many temporary files in
+one process, use a counter:
+
+ BEGIN {
+ use Fcntl;
+ my $temp_dir = -d '/tmp' ? '/tmp' : $ENV{TMP} || $ENV{TEMP};
+ my $base_name = sprintf("%s/%d-%d-0000", $temp_dir, $$, time());
+ sub temp_file {
+ local *FH;
+ my $count = 0;
+ until (defined(fileno(FH)) || $count++ > 100) {
+ $base_name =~ s/-(\d+)$/"-" . (1 + $1)/e;
+ sysopen(FH, $base_name, O_WRONLY|O_EXCL|O_CREAT);
+ }
+ if (defined(fileno(FH))
+ return (*FH, $base_name);
+ } else {
+ return ();
+ }
+ }
+ }
+
+=head2 How can I manipulate fixed-record-length files?
+
+The most efficient way is using pack() and unpack(). This is faster than
+using substr() when take many, many strings. It is slower for just a few.
+
+Here is a sample chunk of code to break up and put back together again
+some fixed-format input lines, in this case from the output of a normal,
+Berkeley-style ps:
+
+ # sample input line:
+ # 15158 p5 T 0:00 perl /home/tchrist/scripts/now-what
+ $PS_T = 'A6 A4 A7 A5 A*';
+ open(PS, "ps|");
+ print scalar <PS>;
+ while (<PS>) {
+ ($pid, $tt, $stat, $time, $command) = unpack($PS_T, $_);
+ for $var (qw!pid tt stat time command!) {
+ print "$var: <$$var>\n";
+ }
+ print 'line=', pack($PS_T, $pid, $tt, $stat, $time, $command),
+ "\n";
+ }
+
+We've used C<$$var> in a way that forbidden by C<use strict 'refs'>.
+That is, we've promoted a string to a scalar variable reference using
+symbolic references. This is ok in small programs, but doesn't scale
+well. It also only works on global variables, not lexicals.
+
+=head2 How can I make a filehandle local to a subroutine? How do I pass filehandles between subroutines? How do I make an array of filehandles?
+
+The fastest, simplest, and most direct way is to localize the typeglob
+of the filehandle in question:
+
+ local *TmpHandle;
+
+Typeglobs are fast (especially compared with the alternatives) and
+reasonably easy to use, but they also have one subtle drawback. If you
+had, for example, a function named TmpHandle(), or a variable named
+%TmpHandle, you just hid it from yourself.
+
+ sub findme {
+ local *HostFile;
+ open(HostFile, "</etc/hosts") or die "no /etc/hosts: $!";
+ local $_; # <- VERY IMPORTANT
+ while (<HostFile>) {
+ print if /\b127\.(0\.0\.)?1\b/;
+ }
+ # *HostFile automatically closes/disappears here
+ }
+
+Here's how to use this in a loop to open and store a bunch of
+filehandles. We'll use as values of the hash an ordered
+pair to make it easy to sort the hash in insertion order.
+
+ @names = qw(motd termcap passwd hosts);
+ my $i = 0;
+ foreach $filename (@names) {
+ local *FH;
+ open(FH, "/etc/$filename") || die "$filename: $!";
+ $file{$filename} = [ $i++, *FH ];
+ }
+
+ # Using the filehandles in the array
+ foreach $name (sort { $file{$a}[0] <=> $file{$b}[0] } keys %file) {
+ my $fh = $file{$name}[1];
+ my $line = <$fh>;
+ print "$name $. $line";
+ }
+
+For passing filehandles to functions, the easiest way is to
+prefer them with a star, as in func(*STDIN). See L<perlfaq7/"Passing
+Filehandles"> for details.
+
+If you want to create many, anonymous handles, you should check out the
+Symbol, FileHandle, or IO::Handle (etc.) modules. Here's the equivalent
+code with Symbol::gensym, which is reasonably light-weight:
+
+ foreach $filename (@names) {
+ use Symbol;
+ my $fh = gensym();
+ open($fh, "/etc/$filename") || die "open /etc/$filename: $!";
+ $file{$filename} = [ $i++, $fh ];
+ }
+
+Or here using the semi-object-oriented FileHandle, which certainly isn't
+light-weight:
+
+ use FileHandle;
+
+ foreach $filename (@names) {
+ my $fh = FileHandle->new("/etc/$filename") or die "$filename: $!";
+ $file{$filename} = [ $i++, $fh ];
+ }
+
+Please understand that whether the filehandle happens to be a (probably
+localized) typeglob or an anonymous handle from one of the modules,
+in no way affects the bizarre rules for managing indirect handles.
+See the next question.
+
+=head2 How can I use a filehandle indirectly?
+
+An indirect filehandle is using something other than a symbol
+in a place that a filehandle is expected. Here are ways
+to get those:
+
+ $fh = SOME_FH; # bareword is strict-subs hostile
+ $fh = "SOME_FH"; # strict-refs hostile; same package only
+ $fh = *SOME_FH; # typeglob
+ $fh = \*SOME_FH; # ref to typeglob (bless-able)
+ $fh = *SOME_FH{IO}; # blessed IO::Handle from *SOME_FH typeglob
+
+Or to use the C<new> method from the FileHandle or IO modules to
+create an anonymous filehandle, store that in a scalar variable,
+and use it as though it were a normal filehandle.
+
+ use FileHandle;
+ $fh = FileHandle->new();
+
+ use IO::Handle; # 5.004 or higher
+ $fh = IO::Handle->new();
+
+Then use any of those as you would a normal filehandle. Anywhere that
+Perl is expecting a filehandle, an indirect filehandle may be used
+instead. An indirect filehandle is just a scalar variable that contains
+a filehandle. Functions like C<print>, C<open>, C<seek>, or the functions or
+the C<E<lt>FHE<gt>> diamond operator will accept either a read filehandle
+or a scalar variable containing one:
+
+ ($ifh, $ofh, $efh) = (*STDIN, *STDOUT, *STDERR);
+ print $ofh "Type it: ";
+ $got = <$ifh>
+ print $efh "What was that: $got";
+
+Of you're passing a filehandle to a function, you can write
+the function in two ways:
+
+ sub accept_fh {
+ my $fh = shift;
+ print $fh "Sending to indirect filehandle\n";
+ }
+
+Or it can localize a typeglob and use the filehandle directly:
+
+ sub accept_fh {
+ local *FH = shift;
+ print FH "Sending to localized filehandle\n";
+ }
+
+Both styles work with either objects or typeglobs of real filehandles.
+(They might also work with strings under some circumstances, but this
+is risky.)
+
+ accept_fh(*STDOUT);
+ accept_fh($handle);
+
+In the examples above, we assigned the filehandle to a scalar variable
+before using it. That is because only simple scalar variables,
+not expressions or subscripts into hashes or arrays, can be used with
+built-ins like C<print>, C<printf>, or the diamond operator. These are
+illegal and won't even compile:
+
+ @fd = (*STDIN, *STDOUT, *STDERR);
+ print $fd[1] "Type it: "; # WRONG
+ $got = <$fd[0]> # WRONG
+ print $fd[2] "What was that: $got"; # WRONG
+
+With C<print> and C<printf>, you get around this by using a block and
+an expression where you would place the filehandle:
+
+ print { $fd[1] } "funny stuff\n";
+ printf { $fd[1] } "Pity the poor %x.\n", 3_735_928_559;
+ # Pity the poor deadbeef.
+
+That block is a proper block like any other, so you can put more
+complicated code there. This sends the message out to one of two places:
+
+ $ok = -x "/bin/cat";
+ print { $ok ? $fd[1] : $fd[2] } "cat stat $ok\n";
+ print { $fd[ 1+ ($ok || 0) ] } "cat stat $ok\n";
+
+This approach of treating C<print> and C<printf> like object methods
+calls doesn't work for the diamond operator. That's because it's a
+real operator, not just a function with a comma-less argument. Assuming
+you've been storing typeglobs in your structure as we did above, you
+can use the built-in function named C<readline> to reads a record just
+as C<E<lt>E<gt>> does. Given the initialization shown above for @fd, this
+would work, but only because readline() require a typeglob. It doesn't
+work with objects or strings, which might be a bug we haven't fixed yet.
+
+ $got = readline($fd[0]);
+
+Let it be noted that the flakiness of indirect filehandles is not
+related to whether they're strings, typeglobs, objects, or anything else.
+It's the syntax of the fundamental operators. Playing the object
+game doesn't help you at all here.
+
+=head2 How can I set up a footer format to be used with write()?
+
+There's no builtin way to do this, but L<perlform> has a couple of
+techniques to make it possible for the intrepid hacker.
+
+=head2 How can I write() into a string?
+
+See L<perlform> for an swrite() function.
+
+=head2 How can I output my numbers with commas added?
+
+This one will do it for you:
+
+ sub commify {
+ local $_ = shift;
+ 1 while s/^(-?\d+)(\d{3})/$1,$2/;
+ return $_;
+ }
+
+ $n = 23659019423.2331;
+ print "GOT: ", commify($n), "\n";
+
+ GOT: 23,659,019,423.2331
+
+You can't just:
+
+ s/^(-?\d+)(\d{3})/$1,$2/g;
+
+because you have to put the comma in and then recalculate your
+position.
+
+Alternatively, this commifies all numbers in a line regardless of
+whether they have decimal portions, are preceded by + or -, or
+whatever:
+
+ # from Andrew Johnson <ajohnson@gpu.srv.ualberta.ca>
+ sub commify {
+ my $input = shift;
+ $input = reverse $input;
+ $input =~ s<(\d\d\d)(?=\d)(?!\d*\.)><$1,>g;
+ return reverse $input;
+ }
+
+=head2 How can I translate tildes (~) in a filename?
+
+Use the E<lt>E<gt> (glob()) operator, documented in L<perlfunc>. This
+requires that you have a shell installed that groks tildes, meaning
+csh or tcsh or (some versions of) ksh, and thus may have portability
+problems. The Glob::KGlob module (available from CPAN) gives more
+portable glob functionality.
+
+Within Perl, you may use this directly:
+
+ $filename =~ s{
+ ^ ~ # find a leading tilde
+ ( # save this in $1
+ [^/] # a non-slash character
+ * # repeated 0 or more times (0 means me)
+ )
+ }{
+ $1
+ ? (getpwnam($1))[7]
+ : ( $ENV{HOME} || $ENV{LOGDIR} )
+ }ex;
+
+=head2 How come when I open a file read-write it wipes it out?
+
+Because you're using something like this, which truncates the file and
+I<then> gives you read-write access:
+
+ open(FH, "+> /path/name"); # WRONG (almost always)
+
+Whoops. You should instead use this, which will fail if the file
+doesn't exist. Using "E<gt>" always clobbers or creates.
+Using "E<lt>" never does either. The "+" doesn't change this.
+
+Here are examples of many kinds of file opens. Those using sysopen()
+all assume
+
+ use Fcntl;
+
+To open file for reading:
+
+ open(FH, "< $path") || die $!;
+ sysopen(FH, $path, O_RDONLY) || die $!;
+
+To open file for writing, create new file if needed or else truncate old file:
+
+ open(FH, "> $path") || die $!;
+ sysopen(FH, $path, O_WRONLY|O_TRUNC|O_CREAT) || die $!;
+ sysopen(FH, $path, O_WRONLY|O_TRUNC|O_CREAT, 0666) || die $!;
+
+To open file for writing, create new file, file must not exist:
+
+ sysopen(FH, $path, O_WRONLY|O_EXCL|O_CREAT) || die $!;
+ sysopen(FH, $path, O_WRONLY|O_EXCL|O_CREAT, 0666) || die $!;
+
+To open file for appending, create if necessary:
+
+ open(FH, ">> $path") || die $!;
+ sysopen(FH, $path, O_WRONLY|O_APPEND|O_CREAT) || die $!;
+ sysopen(FH, $path, O_WRONLY|O_APPEND|O_CREAT, 0666) || die $!;
+
+To open file for appending, file must exist:
+
+ sysopen(FH, $path, O_WRONLY|O_APPEND) || die $!;
+
+To open file for update, file must exist:
+
+ open(FH, "+< $path") || die $!;
+ sysopen(FH, $path, O_RDWR) || die $!;
+
+To open file for update, create file if necessary:
+
+ sysopen(FH, $path, O_RDWR|O_CREAT) || die $!;
+ sysopen(FH, $path, O_RDWR|O_CREAT, 0666) || die $!;
+
+To open file for update, file must not exist:
+
+ sysopen(FH, $path, O_RDWR|O_EXCL|O_CREAT) || die $!;
+ sysopen(FH, $path, O_RDWR|O_EXCL|O_CREAT, 0666) || die $!;
+
+To open a file without blocking, creating if necessary:
+
+ sysopen(FH, "/tmp/somefile", O_WRONLY|O_NDELAY|O_CREAT)
+ or die "can't open /tmp/somefile: $!":
+
+Be warned that neither creation nor deletion of files is guaranteed to
+be an atomic operation over NFS. That is, two processes might both
+successful create or unlink the same file! Therefore O_EXCL
+isn't so exclusive as you might wish.
+
+=head2 Why do I sometimes get an "Argument list too long" when I use <*>?
+
+The C<E<lt>E<gt>> operator performs a globbing operation (see above).
+By default glob() forks csh(1) to do the actual glob expansion, but
+csh can't handle more than 127 items and so gives the error message
+C<Argument list too long>. People who installed tcsh as csh won't
+have this problem, but their users may be surprised by it.
+
+To get around this, either do the glob yourself with C<Dirhandle>s and
+patterns, or use a module like Glob::KGlob, one that doesn't use the
+shell to do globbing.
+
+=head2 Is there a leak/bug in glob()?
+
+Due to the current implementation on some operating systems, when you
+use the glob() function or its angle-bracket alias in a scalar
+context, you may cause a leak and/or unpredictable behavior. It's
+best therefore to use glob() only in list context.
+
+=head2 How can I open a file with a leading "E<gt>" or trailing blanks?
+
+Normally perl ignores trailing blanks in filenames, and interprets
+certain leading characters (or a trailing "|") to mean something
+special. To avoid this, you might want to use a routine like this.
+It makes incomplete pathnames into explicit relative ones, and tacks a
+trailing null byte on the name to make perl leave it alone:
+
+ sub safe_filename {
+ local $_ = shift;
+ return m#^/#
+ ? "$_\0"
+ : "./$_\0";
+ }
+
+ $fn = safe_filename("<<<something really wicked ");
+ open(FH, "> $fn") or "couldn't open $fn: $!";
+
+You could also use the sysopen() function (see L<perlfunc/sysopen>).
+
+=head2 How can I reliably rename a file?
+
+Well, usually you just use Perl's rename() function. But that may
+not work everywhere, in particular, renaming files across file systems.
+If your operating system supports a mv(1) program or its moral equivalent,
+this works:
+
+ rename($old, $new) or system("mv", $old, $new);
+
+It may be more compelling to use the File::Copy module instead. You
+just copy to the new file to the new name (checking return values),
+then delete the old one. This isn't really the same semantics as a
+real rename(), though, which preserves metainformation like
+permissions, timestamps, inode info, etc.
+
+The newer version of File::Copy export a move() function.
+
+=head2 How can I lock a file?
+
+Perl's builtin flock() function (see L<perlfunc> for details) will call
+flock(2) if that exists, fcntl(2) if it doesn't (on perl version 5.004 and
+later), and lockf(3) if neither of the two previous system calls exists.
+On some systems, it may even use a different form of native locking.
+Here are some gotchas with Perl's flock():
+
+=over 4
+
+=item 1
+
+Produces a fatal error if none of the three system calls (or their
+close equivalent) exists.
+
+=item 2
+
+lockf(3) does not provide shared locking, and requires that the
+filehandle be open for writing (or appending, or read/writing).
+
+=item 3
+
+Some versions of flock() can't lock files over a network (e.g. on NFS
+file systems), so you'd need to force the use of fcntl(2) when you
+build Perl. See the flock entry of L<perlfunc>, and the F<INSTALL>
+file in the source distribution for information on building Perl to do
+this.
+
+=back
+
+=head2 What can't I just open(FH, ">file.lock")?
+
+A common bit of code B<NOT TO USE> is this:
+
+ sleep(3) while -e "file.lock"; # PLEASE DO NOT USE
+ open(LCK, "> file.lock"); # THIS BROKEN CODE
+
+This is a classic race condition: you take two steps to do something
+which must be done in one. That's why computer hardware provides an
+atomic test-and-set instruction. In theory, this "ought" to work:
+
+ sysopen(FH, "file.lock", O_WRONLY|O_EXCL|O_CREAT)
+ or die "can't open file.lock: $!":
+
+except that lamentably, file creation (and deletion) is not atomic
+over NFS, so this won't work (at least, not every time) over the net.
+Various schemes involving involving link() have been suggested, but
+these tend to involve busy-wait, which is also subdesirable.
+
+=head2 I still don't get locking. I just want to increment the number in the file. How can I do this?
+
+Didn't anyone ever tell you web-page hit counters were useless?
+They don't count number of hits, they're a waste of time, and they serve
+only to stroke the writer's vanity. Better to pick a random number.
+It's more realistic.
+
+Anyway, this is what you can do if you can't help yourself.
+
+ use Fcntl;
+ sysopen(FH, "numfile", O_RDWR|O_CREAT) or die "can't open numfile: $!";
+ flock(FH, 2) or die "can't flock numfile: $!";
+ $num = <FH> || 0;
+ seek(FH, 0, 0) or die "can't rewind numfile: $!";
+ truncate(FH, 0) or die "can't truncate numfile: $!";
+ (print FH $num+1, "\n") or die "can't write numfile: $!";
+ # DO NOT UNLOCK THIS UNTIL YOU CLOSE
+ close FH or die "can't close numfile: $!";
+
+Here's a much better web-page hit counter:
+
+ $hits = int( (time() - 850_000_000) / rand(1_000) );
+
+If the count doesn't impress your friends, then the code might. :-)
+
+=head2 How do I randomly update a binary file?
+
+If you're just trying to patch a binary, in many cases something as
+simple as this works:
+
+ perl -i -pe 's{window manager}{window mangler}g' /usr/bin/emacs
+
+However, if you have fixed sized records, then you might do something more
+like this:
+
+ $RECSIZE = 220; # size of record, in bytes
+ $recno = 37; # which record to update
+ open(FH, "+<somewhere") || die "can't update somewhere: $!";
+ seek(FH, $recno * $RECSIZE, 0);
+ read(FH, $record, $RECSIZE) == $RECSIZE || die "can't read record $recno: $!";
+ # munge the record
+ seek(FH, $recno * $RECSIZE, 0);
+ print FH $record;
+ close FH;
+
+Locking and error checking are left as an exercise for the reader.
+Don't forget them, or you'll be quite sorry.
+
+=head2 How do I get a file's timestamp in perl?
+
+If you want to retrieve the time at which the file was last read,
+written, or had its meta-data (owner, etc) changed, you use the B<-M>,
+B<-A>, or B<-C> filetest operations as documented in L<perlfunc>. These
+retrieve the age of the file (measured against the start-time of your
+program) in days as a floating point number. To retrieve the "raw"
+time in seconds since the epoch, you would call the stat function,
+then use localtime(), gmtime(), or POSIX::strftime() to convert this
+into human-readable form.
+
+Here's an example:
+
+ $write_secs = (stat($file))[9];
+ printf "file %s updated at %s\n", $file,
+ scalar localtime($write_secs);
+
+If you prefer something more legible, use the File::stat module
+(part of the standard distribution in version 5.004 and later):
+
+ use File::stat;
+ use Time::localtime;
+ $date_string = ctime(stat($file)->mtime);
+ print "file $file updated at $date_string\n";
+
+Error checking is left as an exercise for the reader.
+
+=head2 How do I set a file's timestamp in perl?
+
+You use the utime() function documented in L<perlfunc/utime>.
+By way of example, here's a little program that copies the
+read and write times from its first argument to all the rest
+of them.
+
+ if (@ARGV < 2) {
+ die "usage: cptimes timestamp_file other_files ...\n";
+ }
+ $timestamp = shift;
+ ($atime, $mtime) = (stat($timestamp))[8,9];
+ utime $atime, $mtime, @ARGV;
+
+Error checking is left as an exercise for the reader.
+
+Note that utime() currently doesn't work correctly with Win95/NT
+ports. A bug has been reported. Check it carefully before using
+it on those platforms.
+
+=head2 How do I print to more than one file at once?
+
+If you only have to do this once, you can do this:
+
+ for $fh (FH1, FH2, FH3) { print $fh "whatever\n" }
+
+To connect up to one filehandle to several output filehandles, it's
+easiest to use the tee(1) program if you have it, and let it take care
+of the multiplexing:
+
+ open (FH, "| tee file1 file2 file3");
+
+Or even:
+
+ # make STDOUT go to three files, plus original STDOUT
+ open (STDOUT, "| tee file1 file2 file3") or die "Teeing off: $!\n";
+ print "whatever\n" or die "Writing: $!\n";
+ close(STDOUT) or die "Closing: $!\n";
+
+Otherwise you'll have to write your own multiplexing print
+function -- or your own tee program -- or use Tom Christiansen's,
+at http://www.perl.com/CPAN/authors/id/TOMC/scripts/tct.gz, which is
+written in Perl and offers much greater functionality
+than the stock version.
+
+=head2 How can I read in a file by paragraphs?
+
+Use the C<$\> variable (see L<perlvar> for details). You can either
+set it to C<""> to eliminate empty paragraphs (C<"abc\n\n\n\ndef">,
+for instance, gets treated as two paragraphs and not three), or
+C<"\n\n"> to accept empty paragraphs.
+
+=head2 How can I read a single character from a file? From the keyboard?
+
+You can use the builtin C<getc()> function for most filehandles, but
+it won't (easily) work on a terminal device. For STDIN, either use
+the Term::ReadKey module from CPAN, or use the sample code in
+L<perlfunc/getc>.
+
+If your system supports POSIX, you can use the following code, which
+you'll note turns off echo processing as well.
+
+ #!/usr/bin/perl -w
+ use strict;
+ $| = 1;
+ for (1..4) {
+ my $got;
+ print "gimme: ";
+ $got = getone();
+ print "--> $got\n";
+ }
+ exit;
+
+ BEGIN {
+ use POSIX qw(:termios_h);
+
+ my ($term, $oterm, $echo, $noecho, $fd_stdin);
+
+ $fd_stdin = fileno(STDIN);
+
+ $term = POSIX::Termios->new();
+ $term->getattr($fd_stdin);
+ $oterm = $term->getlflag();
+
+ $echo = ECHO | ECHOK | ICANON;
+ $noecho = $oterm & ~$echo;
+
+ sub cbreak {
+ $term->setlflag($noecho);
+ $term->setcc(VTIME, 1);
+ $term->setattr($fd_stdin, TCSANOW);
+ }
+
+ sub cooked {
+ $term->setlflag($oterm);
+ $term->setcc(VTIME, 0);
+ $term->setattr($fd_stdin, TCSANOW);
+ }
+
+ sub getone {
+ my $key = '';
+ cbreak();
+ sysread(STDIN, $key, 1);
+ cooked();
+ return $key;
+ }
+
+ }
+
+ END { cooked() }
+
+The Term::ReadKey module from CPAN may be easier to use:
+
+ use Term::ReadKey;
+ open(TTY, "</dev/tty");
+ print "Gimme a char: ";
+ ReadMode "raw";
+ $key = ReadKey 0, *TTY;
+ ReadMode "normal";
+ printf "\nYou said %s, char number %03d\n",
+ $key, ord $key;
+
+For DOS systems, Dan Carson <dbc@tc.fluke.COM> reports the following:
+
+To put the PC in "raw" mode, use ioctl with some magic numbers gleaned
+from msdos.c (Perl source file) and Ralf Brown's interrupt list (comes
+across the net every so often):
+
+ $old_ioctl = ioctl(STDIN,0,0); # Gets device info
+ $old_ioctl &= 0xff;
+ ioctl(STDIN,1,$old_ioctl | 32); # Writes it back, setting bit 5
+
+Then to read a single character:
+
+ sysread(STDIN,$c,1); # Read a single character
+
+And to put the PC back to "cooked" mode:
+
+ ioctl(STDIN,1,$old_ioctl); # Sets it back to cooked mode.
+
+So now you have $c. If C<ord($c) == 0>, you have a two byte code, which
+means you hit a special key. Read another byte with C<sysread(STDIN,$c,1)>,
+and that value tells you what combination it was according to this
+table:
+
+ # PC 2-byte keycodes = ^@ + the following:
+
+ # HEX KEYS
+ # --- ----
+ # 0F SHF TAB
+ # 10-19 ALT QWERTYUIOP
+ # 1E-26 ALT ASDFGHJKL
+ # 2C-32 ALT ZXCVBNM
+ # 3B-44 F1-F10
+ # 47-49 HOME,UP,PgUp
+ # 4B LEFT
+ # 4D RIGHT
+ # 4F-53 END,DOWN,PgDn,Ins,Del
+ # 54-5D SHF F1-F10
+ # 5E-67 CTR F1-F10
+ # 68-71 ALT F1-F10
+ # 73-77 CTR LEFT,RIGHT,END,PgDn,HOME
+ # 78-83 ALT 1234567890-=
+ # 84 CTR PgUp
+
+This is all trial and error I did a long time ago, I hope I'm reading the
+file that worked.
+
+=head2 How can I tell if there's a character waiting on a filehandle?
+
+The very first thing you should do is look into getting the Term::ReadKey
+extension from CPAN. It now even has limited support for closed, proprietary
+(read: not open systems, not POSIX, not Unix, etc) systems.
+
+You should also check out the Frequently Asked Questions list in
+comp.unix.* for things like this: the answer is essentially the same.
+It's very system dependent. Here's one solution that works on BSD
+systems:
+
+ sub key_ready {
+ my($rin, $nfd);
+ vec($rin, fileno(STDIN), 1) = 1;
+ return $nfd = select($rin,undef,undef,0);
+ }
+
+If you want to find out how many characters are waiting,
+there's also the FIONREAD ioctl call to be looked at.
+
+The I<h2ph> tool that comes with Perl tries to convert C include
+files to Perl code, which can be C<require>d. FIONREAD ends
+up defined as a function in the I<sys/ioctl.ph> file:
+
+ require 'sys/ioctl.ph';
+
+ $size = pack("L", 0);
+ ioctl(FH, FIONREAD(), $size) or die "Couldn't call ioctl: $!\n";
+ $size = unpack("L", $size);
+
+If I<h2ph> wasn't installed or doesn't work for you, you can
+I<grep> the include files by hand:
+
+ % grep FIONREAD /usr/include/*/*
+ /usr/include/asm/ioctls.h:#define FIONREAD 0x541B
+
+Or write a small C program using the editor of champions:
+
+ % cat > fionread.c
+ #include <sys/ioctl.h>
+ main() {
+ printf("%#08x\n", FIONREAD);
+ }
+ ^D
+ % cc -o fionread fionread
+ % ./fionread
+ 0x4004667f
+
+And then hard-code it, leaving porting as an exercise to your successor.
+
+ $FIONREAD = 0x4004667f; # XXX: opsys dependent
+
+ $size = pack("L", 0);
+ ioctl(FH, $FIONREAD, $size) or die "Couldn't call ioctl: $!\n";
+ $size = unpack("L", $size);
+
+FIONREAD requires a filehandle connected to a stream, meaning sockets,
+pipes, and tty devices work, but I<not> files.
+
+=head2 How do I do a C<tail -f> in perl?
+
+First try
+
+ seek(GWFILE, 0, 1);
+
+The statement C<seek(GWFILE, 0, 1)> doesn't change the current position,
+but it does clear the end-of-file condition on the handle, so that the
+next <GWFILE> makes Perl try again to read something.
+
+If that doesn't work (it relies on features of your stdio implementation),
+then you need something more like this:
+
+ for (;;) {
+ for ($curpos = tell(GWFILE); <GWFILE>; $curpos = tell(GWFILE)) {
+ # search for some stuff and put it into files
+ }
+ # sleep for a while
+ seek(GWFILE, $curpos, 0); # seek to where we had been
+ }
+
+If this still doesn't work, look into the POSIX module. POSIX defines
+the clearerr() method, which can remove the end of file condition on a
+filehandle. The method: read until end of file, clearerr(), read some
+more. Lather, rinse, repeat.
+
+=head2 How do I dup() a filehandle in Perl?
+
+If you check L<perlfunc/open>, you'll see that several of the ways
+to call open() should do the trick. For example:
+
+ open(LOG, ">>/tmp/logfile");
+ open(STDERR, ">&LOG");
+
+Or even with a literal numeric descriptor:
+
+ $fd = $ENV{MHCONTEXTFD};
+ open(MHCONTEXT, "<&=$fd"); # like fdopen(3S)
+
+Note that "E<lt>&STDIN" makes a copy, but "E<lt>&=STDIN" make
+an alias. That means if you close an aliased handle, all
+aliases become inaccessible. This is not true with
+a copied one.
+
+Error checking, as always, has been left as an exercise for the reader.
+
+=head2 How do I close a file descriptor by number?
+
+This should rarely be necessary, as the Perl close() function is to be
+used for things that Perl opened itself, even if it was a dup of a
+numeric descriptor, as with MHCONTEXT above. But if you really have
+to, you may be able to do this:
+
+ require 'sys/syscall.ph';
+ $rc = syscall(&SYS_close, $fd + 0); # must force numeric
+ die "can't sysclose $fd: $!" unless $rc == -1;
+
+=head2 Why can't I use "C:\temp\foo" in DOS paths? What doesn't `C:\temp\foo.exe` work?
+
+Whoops! You just put a tab and a formfeed into that filename!
+Remember that within double quoted strings ("like\this"), the
+backslash is an escape character. The full list of these is in
+L<perlop/Quote and Quote-like Operators>. Unsurprisingly, you don't
+have a file called "c:(tab)emp(formfeed)oo" or
+"c:(tab)emp(formfeed)oo.exe" on your DOS filesystem.
+
+Either single-quote your strings, or (preferably) use forward slashes.
+Since all DOS and Windows versions since something like MS-DOS 2.0 or so
+have treated C</> and C<\> the same in a path, you might as well use the
+one that doesn't clash with Perl -- or the POSIX shell, ANSI C and C++,
+awk, Tcl, Java, or Python, just to mention a few.
+
+=head2 Why doesn't glob("*.*") get all the files?
+
+Because even on non-Unix ports, Perl's glob function follows standard
+Unix globbing semantics. You'll need C<glob("*")> to get all (non-hidden)
+files. This makes glob() portable.
+
+=head2 Why does Perl let me delete read-only files? Why does C<-i> clobber protected files? Isn't this a bug in Perl?
+
+This is elaborately and painstakingly described in the "Far More Than
+You Ever Wanted To Know" in
+http://www.perl.com/CPAN/doc/FMTEYEWTK/file-dir-perms .
+
+The executive summary: learn how your filesystem works. The
+permissions on a file say what can happen to the data in that file.
+The permissions on a directory say what can happen to the list of
+files in that directory. If you delete a file, you're removing its
+name from the directory (so the operation depends on the permissions
+of the directory, not of the file). If you try to write to the file,
+the permissions of the file govern whether you're allowed to.
+
+=head2 How do I select a random line from a file?
+
+Here's an algorithm from the Camel Book:
+
+ srand;
+ rand($.) < 1 && ($line = $_) while <>;
+
+This has a significant advantage in space over reading the whole
+file in. A simple proof by induction is available upon
+request if you doubt its correctness.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+When included as an integrated part of the Standard Distribution
+of Perl or of its documentation (printed or otherwise), this works is
+covered under Perl's Artistic Licence. For separate distributions of
+all or part of this FAQ outside of that, see L<perlfaq>.
+
+Irrespective of its distribution, all code examples here are public
+domain. You are permitted and encouraged to use this code and any
+derivatives thereof in your own programs for fun or for profit as you
+see fit. A simple comment in the code giving credit to the FAQ would
+be courteous but is not required.
diff --git a/contrib/perl5/pod/perlfaq6.pod b/contrib/perl5/pod/perlfaq6.pod
new file mode 100644
index 000000000000..488a27c83ae7
--- /dev/null
+++ b/contrib/perl5/pod/perlfaq6.pod
@@ -0,0 +1,626 @@
+=head1 NAME
+
+perlfaq6 - Regexps ($Revision: 1.22 $, $Date: 1998/07/16 14:01:07 $)
+
+=head1 DESCRIPTION
+
+This section is surprisingly small because the rest of the FAQ is
+littered with answers involving regular expressions. For example,
+decoding a URL and checking whether something is a number are handled
+with regular expressions, but those answers are found elsewhere in
+this document (in the section on Data and the Networking one on
+networking, to be precise).
+
+=head2 How can I hope to use regular expressions without creating illegible and unmaintainable code?
+
+Three techniques can make regular expressions maintainable and
+understandable.
+
+=over 4
+
+=item Comments Outside the Regexp
+
+Describe what you're doing and how you're doing it, using normal Perl
+comments.
+
+ # turn the line into the first word, a colon, and the
+ # number of characters on the rest of the line
+ s/^(\w+)(.*)/ lc($1) . ":" . length($2) /meg;
+
+=item Comments Inside the Regexp
+
+The C</x> modifier causes whitespace to be ignored in a regexp pattern
+(except in a character class), and also allows you to use normal
+comments there, too. As you can imagine, whitespace and comments help
+a lot.
+
+C</x> lets you turn this:
+
+ s{<(?:[^>'"]*|".*?"|'.*?')+>}{}gs;
+
+into this:
+
+ s{ < # opening angle bracket
+ (?: # Non-backreffing grouping paren
+ [^>'"] * # 0 or more things that are neither > nor ' nor "
+ | # or else
+ ".*?" # a section between double quotes (stingy match)
+ | # or else
+ '.*?' # a section between single quotes (stingy match)
+ ) + # all occurring one or more times
+ > # closing angle bracket
+ }{}gsx; # replace with nothing, i.e. delete
+
+It's still not quite so clear as prose, but it is very useful for
+describing the meaning of each part of the pattern.
+
+=item Different Delimiters
+
+While we normally think of patterns as being delimited with C</>
+characters, they can be delimited by almost any character. L<perlre>
+describes this. For example, the C<s///> above uses braces as
+delimiters. Selecting another delimiter can avoid quoting the
+delimiter within the pattern:
+
+ s/\/usr\/local/\/usr\/share/g; # bad delimiter choice
+ s#/usr/local#/usr/share#g; # better
+
+=back
+
+=head2 I'm having trouble matching over more than one line. What's wrong?
+
+Either you don't have more than one line in the string you're looking at
+(probably), or else you aren't using the correct modifier(s) on your
+pattern (possibly).
+
+There are many ways to get multiline data into a string. If you want
+it to happen automatically while reading input, you'll want to set $/
+(probably to '' for paragraphs or C<undef> for the whole file) to
+allow you to read more than one line at a time.
+
+Read L<perlre> to help you decide which of C</s> and C</m> (or both)
+you might want to use: C</s> allows dot to include newline, and C</m>
+allows caret and dollar to match next to a newline, not just at the
+end of the string. You do need to make sure that you've actually
+got a multiline string in there.
+
+For example, this program detects duplicate words, even when they span
+line breaks (but not paragraph ones). For this example, we don't need
+C</s> because we aren't using dot in a regular expression that we want
+to cross line boundaries. Neither do we need C</m> because we aren't
+wanting caret or dollar to match at any point inside the record next
+to newlines. But it's imperative that $/ be set to something other
+than the default, or else we won't actually ever have a multiline
+record read in.
+
+ $/ = ''; # read in more whole paragraph, not just one line
+ while ( <> ) {
+ while ( /\b([\w'-]+)(\s+\1)+\b/gi ) { # word starts alpha
+ print "Duplicate $1 at paragraph $.\n";
+ }
+ }
+
+Here's code that finds sentences that begin with "From " (which would
+be mangled by many mailers):
+
+ $/ = ''; # read in more whole paragraph, not just one line
+ while ( <> ) {
+ while ( /^From /gm ) { # /m makes ^ match next to \n
+ print "leading from in paragraph $.\n";
+ }
+ }
+
+Here's code that finds everything between START and END in a paragraph:
+
+ undef $/; # read in whole file, not just one line or paragraph
+ while ( <> ) {
+ while ( /START(.*?)END/sm ) { # /s makes . cross line boundaries
+ print "$1\n";
+ }
+ }
+
+=head2 How can I pull out lines between two patterns that are themselves on different lines?
+
+You can use Perl's somewhat exotic C<..> operator (documented in
+L<perlop>):
+
+ perl -ne 'print if /START/ .. /END/' file1 file2 ...
+
+If you wanted text and not lines, you would use
+
+ perl -0777 -pe 'print "$1\n" while /START(.*?)END/gs' file1 file2 ...
+
+But if you want nested occurrences of C<START> through C<END>, you'll
+run up against the problem described in the question in this section
+on matching balanced text.
+
+Here's another example of using C<..>:
+
+ while (<>) {
+ $in_header = 1 .. /^$/;
+ $in_body = /^$/ .. eof();
+ # now choose between them
+ } continue {
+ reset if eof(); # fix $.
+ }
+
+=head2 I put a regular expression into $/ but it didn't work. What's wrong?
+
+$/ must be a string, not a regular expression. Awk has to be better
+for something. :-)
+
+Actually, you could do this if you don't mind reading the whole file
+into memory:
+
+ undef $/;
+ @records = split /your_pattern/, <FH>;
+
+The Net::Telnet module (available from CPAN) has the capability to
+wait for a pattern in the input stream, or timeout if it doesn't
+appear within a certain time.
+
+ ## Create a file with three lines.
+ open FH, ">file";
+ print FH "The first line\nThe second line\nThe third line\n";
+ close FH;
+
+ ## Get a read/write filehandle to it.
+ $fh = new FileHandle "+<file";
+
+ ## Attach it to a "stream" object.
+ use Net::Telnet;
+ $file = new Net::Telnet (-fhopen => $fh);
+
+ ## Search for the second line and print out the third.
+ $file->waitfor('/second line\n/');
+ print $file->getline;
+
+=head2 How do I substitute case insensitively on the LHS, but preserving case on the RHS?
+
+It depends on what you mean by "preserving case". The following
+script makes the substitution have the same case, letter by letter, as
+the original. If the substitution has more characters than the string
+being substituted, the case of the last character is used for the rest
+of the substitution.
+
+ # Original by Nathan Torkington, massaged by Jeffrey Friedl
+ #
+ sub preserve_case($$)
+ {
+ my ($old, $new) = @_;
+ my ($state) = 0; # 0 = no change; 1 = lc; 2 = uc
+ my ($i, $oldlen, $newlen, $c) = (0, length($old), length($new));
+ my ($len) = $oldlen < $newlen ? $oldlen : $newlen;
+
+ for ($i = 0; $i < $len; $i++) {
+ if ($c = substr($old, $i, 1), $c =~ /[\W\d_]/) {
+ $state = 0;
+ } elsif (lc $c eq $c) {
+ substr($new, $i, 1) = lc(substr($new, $i, 1));
+ $state = 1;
+ } else {
+ substr($new, $i, 1) = uc(substr($new, $i, 1));
+ $state = 2;
+ }
+ }
+ # finish up with any remaining new (for when new is longer than old)
+ if ($newlen > $oldlen) {
+ if ($state == 1) {
+ substr($new, $oldlen) = lc(substr($new, $oldlen));
+ } elsif ($state == 2) {
+ substr($new, $oldlen) = uc(substr($new, $oldlen));
+ }
+ }
+ return $new;
+ }
+
+ $a = "this is a TEsT case";
+ $a =~ s/(test)/preserve_case($1, "success")/gie;
+ print "$a\n";
+
+This prints:
+
+ this is a SUcCESS case
+
+=head2 How can I make C<\w> match national character sets?
+
+See L<perllocale>.
+
+=head2 How can I match a locale-smart version of C</[a-zA-Z]/>?
+
+One alphabetic character would be C</[^\W\d_]/>, no matter what locale
+you're in. Non-alphabetics would be C</[\W\d_]/> (assuming you don't
+consider an underscore a letter).
+
+=head2 How can I quote a variable to use in a regexp?
+
+The Perl parser will expand $variable and @variable references in
+regular expressions unless the delimiter is a single quote. Remember,
+too, that the right-hand side of a C<s///> substitution is considered
+a double-quoted string (see L<perlop> for more details). Remember
+also that any regexp special characters will be acted on unless you
+precede the substitution with \Q. Here's an example:
+
+ $string = "to die?";
+ $lhs = "die?";
+ $rhs = "sleep no more";
+
+ $string =~ s/\Q$lhs/$rhs/;
+ # $string is now "to sleep no more"
+
+Without the \Q, the regexp would also spuriously match "di".
+
+=head2 What is C</o> really for?
+
+Using a variable in a regular expression match forces a re-evaluation
+(and perhaps recompilation) each time through. The C</o> modifier
+locks in the regexp the first time it's used. This always happens in a
+constant regular expression, and in fact, the pattern was compiled
+into the internal format at the same time your entire program was.
+
+Use of C</o> is irrelevant unless variable interpolation is used in
+the pattern, and if so, the regexp engine will neither know nor care
+whether the variables change after the pattern is evaluated the I<very
+first> time.
+
+C</o> is often used to gain an extra measure of efficiency by not
+performing subsequent evaluations when you know it won't matter
+(because you know the variables won't change), or more rarely, when
+you don't want the regexp to notice if they do.
+
+For example, here's a "paragrep" program:
+
+ $/ = ''; # paragraph mode
+ $pat = shift;
+ while (<>) {
+ print if /$pat/o;
+ }
+
+=head2 How do I use a regular expression to strip C style comments from a file?
+
+While this actually can be done, it's much harder than you'd think.
+For example, this one-liner
+
+ perl -0777 -pe 's{/\*.*?\*/}{}gs' foo.c
+
+will work in many but not all cases. You see, it's too simple-minded for
+certain kinds of C programs, in particular, those with what appear to be
+comments in quoted strings. For that, you'd need something like this,
+created by Jeffrey Friedl:
+
+ $/ = undef;
+ $_ = <>;
+ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|\n+|.[^/"'\\]*)#$2#g;
+ print;
+
+This could, of course, be more legibly written with the C</x> modifier, adding
+whitespace and comments.
+
+=head2 Can I use Perl regular expressions to match balanced text?
+
+Although Perl regular expressions are more powerful than "mathematical"
+regular expressions, because they feature conveniences like backreferences
+(C<\1> and its ilk), they still aren't powerful enough. You still need
+to use non-regexp techniques to parse balanced text, such as the text
+enclosed between matching parentheses or braces, for example.
+
+An elaborate subroutine (for 7-bit ASCII only) to pull out balanced
+and possibly nested single chars, like C<`> and C<'>, C<{> and C<}>,
+or C<(> and C<)> can be found in
+http://www.perl.com/CPAN/authors/id/TOMC/scripts/pull_quotes.gz .
+
+The C::Scan module from CPAN contains such subs for internal usage,
+but they are undocumented.
+
+=head2 What does it mean that regexps are greedy? How can I get around it?
+
+Most people mean that greedy regexps match as much as they can.
+Technically speaking, it's actually the quantifiers (C<?>, C<*>, C<+>,
+C<{}>) that are greedy rather than the whole pattern; Perl prefers local
+greed and immediate gratification to overall greed. To get non-greedy
+versions of the same quantifiers, use (C<??>, C<*?>, C<+?>, C<{}?>).
+
+An example:
+
+ $s1 = $s2 = "I am very very cold";
+ $s1 =~ s/ve.*y //; # I am cold
+ $s2 =~ s/ve.*?y //; # I am very cold
+
+Notice how the second substitution stopped matching as soon as it
+encountered "y ". The C<*?> quantifier effectively tells the regular
+expression engine to find a match as quickly as possible and pass
+control on to whatever is next in line, like you would if you were
+playing hot potato.
+
+=head2 How do I process each word on each line?
+
+Use the split function:
+
+ while (<>) {
+ foreach $word ( split ) {
+ # do something with $word here
+ }
+ }
+
+Note that this isn't really a word in the English sense; it's just
+chunks of consecutive non-whitespace characters.
+
+To work with only alphanumeric sequences, you might consider
+
+ while (<>) {
+ foreach $word (m/(\w+)/g) {
+ # do something with $word here
+ }
+ }
+
+=head2 How can I print out a word-frequency or line-frequency summary?
+
+To do this, you have to parse out each word in the input stream. We'll
+pretend that by word you mean chunk of alphabetics, hyphens, or
+apostrophes, rather than the non-whitespace chunk idea of a word given
+in the previous question:
+
+ while (<>) {
+ while ( /(\b[^\W_\d][\w'-]+\b)/g ) { # misses "`sheep'"
+ $seen{$1}++;
+ }
+ }
+ while ( ($word, $count) = each %seen ) {
+ print "$count $word\n";
+ }
+
+If you wanted to do the same thing for lines, you wouldn't need a
+regular expression:
+
+ while (<>) {
+ $seen{$_}++;
+ }
+ while ( ($line, $count) = each %seen ) {
+ print "$count $line";
+ }
+
+If you want these output in a sorted order, see the section on Hashes.
+
+=head2 How can I do approximate matching?
+
+See the module String::Approx available from CPAN.
+
+=head2 How do I efficiently match many regular expressions at once?
+
+The following is super-inefficient:
+
+ while (<FH>) {
+ foreach $pat (@patterns) {
+ if ( /$pat/ ) {
+ # do something
+ }
+ }
+ }
+
+Instead, you either need to use one of the experimental Regexp extension
+modules from CPAN (which might well be overkill for your purposes),
+or else put together something like this, inspired from a routine
+in Jeffrey Friedl's book:
+
+ sub _bm_build {
+ my $condition = shift;
+ my @regexp = @_; # this MUST not be local(); need my()
+ my $expr = join $condition => map { "m/\$regexp[$_]/o" } (0..$#regexp);
+ my $match_func = eval "sub { $expr }";
+ die if $@; # propagate $@; this shouldn't happen!
+ return $match_func;
+ }
+
+ sub bm_and { _bm_build('&&', @_) }
+ sub bm_or { _bm_build('||', @_) }
+
+ $f1 = bm_and qw{
+ xterm
+ (?i)window
+ };
+
+ $f2 = bm_or qw{
+ \b[Ff]ree\b
+ \bBSD\B
+ (?i)sys(tem)?\s*[V5]\b
+ };
+
+ # feed me /etc/termcap, prolly
+ while ( <> ) {
+ print "1: $_" if &$f1;
+ print "2: $_" if &$f2;
+ }
+
+=head2 Why don't word-boundary searches with C<\b> work for me?
+
+Two common misconceptions are that C<\b> is a synonym for C<\s+>, and
+that it's the edge between whitespace characters and non-whitespace
+characters. Neither is correct. C<\b> is the place between a C<\w>
+character and a C<\W> character (that is, C<\b> is the edge of a
+"word"). It's a zero-width assertion, just like C<^>, C<$>, and all
+the other anchors, so it doesn't consume any characters. L<perlre>
+describes the behaviour of all the regexp metacharacters.
+
+Here are examples of the incorrect application of C<\b>, with fixes:
+
+ "two words" =~ /(\w+)\b(\w+)/; # WRONG
+ "two words" =~ /(\w+)\s+(\w+)/; # right
+
+ " =matchless= text" =~ /\b=(\w+)=\b/; # WRONG
+ " =matchless= text" =~ /=(\w+)=/; # right
+
+Although they may not do what you thought they did, C<\b> and C<\B>
+can still be quite useful. For an example of the correct use of
+C<\b>, see the example of matching duplicate words over multiple
+lines.
+
+An example of using C<\B> is the pattern C<\Bis\B>. This will find
+occurrences of "is" on the insides of words only, as in "thistle", but
+not "this" or "island".
+
+=head2 Why does using $&, $`, or $' slow my program down?
+
+Because once Perl sees that you need one of these variables anywhere
+in the program, it has to provide them on each and every pattern
+match. The same mechanism that handles these provides for the use of
+$1, $2, etc., so you pay the same price for each regexp that contains
+capturing parentheses. But if you never use $&, etc., in your script,
+then regexps I<without> capturing parentheses won't be penalized. So
+avoid $&, $', and $` if you can, but if you can't (and some algorithms
+really appreciate them), once you've used them once, use them at will,
+because you've already paid the price.
+
+=head2 What good is C<\G> in a regular expression?
+
+The notation C<\G> is used in a match or substitution in conjunction the
+C</g> modifier (and ignored if there's no C</g>) to anchor the regular
+expression to the point just past where the last match occurred, i.e. the
+pos() point.
+
+For example, suppose you had a line of text quoted in standard mail
+and Usenet notation, (that is, with leading C<E<gt>> characters), and
+you want change each leading C<E<gt>> into a corresponding C<:>. You
+could do so in this way:
+
+ s/^(>+)/':' x length($1)/gem;
+
+Or, using C<\G>, the much simpler (and faster):
+
+ s/\G>/:/g;
+
+A more sophisticated use might involve a tokenizer. The following
+lex-like example is courtesy of Jeffrey Friedl. It did not work in
+5.003 due to bugs in that release, but does work in 5.004 or better.
+(Note the use of C</c>, which prevents a failed match with C</g> from
+resetting the search position back to the beginning of the string.)
+
+ while (<>) {
+ chomp;
+ PARSER: {
+ m/ \G( \d+\b )/gcx && do { print "number: $1\n"; redo; };
+ m/ \G( \w+ )/gcx && do { print "word: $1\n"; redo; };
+ m/ \G( \s+ )/gcx && do { print "space: $1\n"; redo; };
+ m/ \G( [^\w\d]+ )/gcx && do { print "other: $1\n"; redo; };
+ }
+ }
+
+Of course, that could have been written as
+
+ while (<>) {
+ chomp;
+ PARSER: {
+ if ( /\G( \d+\b )/gcx {
+ print "number: $1\n";
+ redo PARSER;
+ }
+ if ( /\G( \w+ )/gcx {
+ print "word: $1\n";
+ redo PARSER;
+ }
+ if ( /\G( \s+ )/gcx {
+ print "space: $1\n";
+ redo PARSER;
+ }
+ if ( /\G( [^\w\d]+ )/gcx {
+ print "other: $1\n";
+ redo PARSER;
+ }
+ }
+ }
+
+But then you lose the vertical alignment of the regular expressions.
+
+=head2 Are Perl regexps DFAs or NFAs? Are they POSIX compliant?
+
+While it's true that Perl's regular expressions resemble the DFAs
+(deterministic finite automata) of the egrep(1) program, they are in
+fact implemented as NFAs (non-deterministic finite automata) to allow
+backtracking and backreferencing. And they aren't POSIX-style either,
+because those guarantee worst-case behavior for all cases. (It seems
+that some people prefer guarantees of consistency, even when what's
+guaranteed is slowness.) See the book "Mastering Regular Expressions"
+(from O'Reilly) by Jeffrey Friedl for all the details you could ever
+hope to know on these matters (a full citation appears in
+L<perlfaq2>).
+
+=head2 What's wrong with using grep or map in a void context?
+
+Both grep and map build a return list, regardless of their context.
+This means you're making Perl go to the trouble of building up a
+return list that you then just ignore. That's no way to treat a
+programming language, you insensitive scoundrel!
+
+=head2 How can I match strings with multibyte characters?
+
+This is hard, and there's no good way. Perl does not directly support
+wide characters. It pretends that a byte and a character are
+synonymous. The following set of approaches was offered by Jeffrey
+Friedl, whose article in issue #5 of The Perl Journal talks about this
+very matter.
+
+Let's suppose you have some weird Martian encoding where pairs of
+ASCII uppercase letters encode single Martian letters (i.e. the two
+bytes "CV" make a single Martian letter, as do the two bytes "SG",
+"VS", "XX", etc.). Other bytes represent single characters, just like
+ASCII.
+
+So, the string of Martian "I am CVSGXX!" uses 12 bytes to encode the
+nine characters 'I', ' ', 'a', 'm', ' ', 'CV', 'SG', 'XX', '!'.
+
+Now, say you want to search for the single character C</GX/>. Perl
+doesn't know about Martian, so it'll find the two bytes "GX" in the "I
+am CVSGXX!" string, even though that character isn't there: it just
+looks like it is because "SG" is next to "XX", but there's no real
+"GX". This is a big problem.
+
+Here are a few ways, all painful, to deal with it:
+
+ $martian =~ s/([A-Z][A-Z])/ $1 /g; # Make sure adjacent ``martian'' bytes
+ # are no longer adjacent.
+ print "found GX!\n" if $martian =~ /GX/;
+
+Or like this:
+
+ @chars = $martian =~ m/([A-Z][A-Z]|[^A-Z])/g;
+ # above is conceptually similar to: @chars = $text =~ m/(.)/g;
+ #
+ foreach $char (@chars) {
+ print "found GX!\n", last if $char eq 'GX';
+ }
+
+Or like this:
+
+ while ($martian =~ m/\G([A-Z][A-Z]|.)/gs) { # \G probably unneeded
+ print "found GX!\n", last if $1 eq 'GX';
+ }
+
+Or like this:
+
+ die "sorry, Perl doesn't (yet) have Martian support )-:\n";
+
+In addition, a sample program which converts half-width to full-width
+katakana (in Shift-JIS or EUC encoding) is available from CPAN as
+
+=for Tom make it so
+
+There are many double- (and multi-) byte encodings commonly used these
+days. Some versions of these have 1-, 2-, 3-, and 4-byte characters,
+all mixed.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+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 I<outside>
+of that package require that special arrangements be made with
+copyright holder.
+
+Irrespective of its distribution, all code examples in this file
+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.
diff --git a/contrib/perl5/pod/perlfaq7.pod b/contrib/perl5/pod/perlfaq7.pod
new file mode 100644
index 000000000000..e1bccc883f4b
--- /dev/null
+++ b/contrib/perl5/pod/perlfaq7.pod
@@ -0,0 +1,816 @@
+=head1 NAME
+
+perlfaq7 - Perl Language Issues ($Revision: 1.21 $, $Date: 1998/06/22 15:20:07 $)
+
+=head1 DESCRIPTION
+
+This section deals with general Perl language issues that don't
+clearly fit into any of the other sections.
+
+=head2 Can I get a BNF/yacc/RE for the Perl language?
+
+There is no BNF, but you can paw your way through the yacc grammar in
+perly.y in the source distribution if you're particularly brave. The
+grammar relies on very smart tokenizing code, so be prepared to
+venture into toke.c as well.
+
+In the words of Chaim Frenkel: "Perl's grammar can not be reduced to BNF.
+The work of parsing perl is distributed between yacc, the lexer, smoke
+and mirrors."
+
+=head2 What are all these $@%* punctuation signs, and how do I know when to use them?
+
+They are type specifiers, as detailed in L<perldata>:
+
+ $ for scalar values (number, string or reference)
+ @ for arrays
+ % for hashes (associative arrays)
+ * for all types of that symbol name. In version 4 you used them like
+ pointers, but in modern perls you can just use references.
+
+While there are a few places where you don't actually need these type
+specifiers, you should always use them.
+
+A couple of others that you're likely to encounter that aren't
+really type specifiers are:
+
+ <> are used for inputting a record from a filehandle.
+ \ takes a reference to something.
+
+Note that E<lt>FILEE<gt> is I<neither> the type specifier for files
+nor the name of the handle. It is the C<E<lt>E<gt>> operator applied
+to the handle FILE. It reads one line (well, record - see
+L<perlvar/$/>) from the handle FILE in scalar context, or I<all> lines
+in list context. When performing open, close, or any other operation
+besides C<E<lt>E<gt>> on files, or even talking about the handle, do
+I<not> use the brackets. These are correct: C<eof(FH)>, C<seek(FH, 0,
+2)> and "copying from STDIN to FILE".
+
+=head2 Do I always/never have to quote my strings or use semicolons and commas?
+
+Normally, a bareword doesn't need to be quoted, but in most cases
+probably should be (and must be under C<use strict>). But a hash key
+consisting of a simple word (that isn't the name of a defined
+subroutine) and the left-hand operand to the C<=E<gt>> operator both
+count as though they were quoted:
+
+ This is like this
+ ------------ ---------------
+ $foo{line} $foo{"line"}
+ bar => stuff "bar" => stuff
+
+The final semicolon in a block is optional, as is the final comma in a
+list. Good style (see L<perlstyle>) says to put them in except for
+one-liners:
+
+ if ($whoops) { exit 1 }
+ @nums = (1, 2, 3);
+
+ if ($whoops) {
+ exit 1;
+ }
+ @lines = (
+ "There Beren came from mountains cold",
+ "And lost he wandered under leaves",
+ );
+
+=head2 How do I skip some return values?
+
+One way is to treat the return values as a list and index into it:
+
+ $dir = (getpwnam($user))[7];
+
+Another way is to use undef as an element on the left-hand-side:
+
+ ($dev, $ino, undef, undef, $uid, $gid) = stat($file);
+
+=head2 How do I temporarily block warnings?
+
+The C<$^W> variable (documented in L<perlvar>) controls
+runtime warnings for a block:
+
+ {
+ local $^W = 0; # temporarily turn off warnings
+ $a = $b + $c; # I know these might be undef
+ }
+
+Note that like all the punctuation variables, you cannot currently
+use my() on C<$^W>, only local().
+
+A new C<use warnings> pragma is in the works to provide finer control
+over all this. The curious should check the perl5-porters mailing list
+archives for details.
+
+=head2 What's an extension?
+
+A way of calling compiled C code from Perl. Reading L<perlxstut>
+is a good place to learn more about extensions.
+
+=head2 Why do Perl operators have different precedence than C operators?
+
+Actually, they don't. All C operators that Perl copies have the same
+precedence in Perl as they do in C. The problem is with operators that C
+doesn't have, especially functions that give a list context to everything
+on their right, eg print, chmod, exec, and so on. Such functions are
+called "list operators" and appear as such in the precedence table in
+L<perlop>.
+
+A common mistake is to write:
+
+ unlink $file || die "snafu";
+
+This gets interpreted as:
+
+ unlink ($file || die "snafu");
+
+To avoid this problem, either put in extra parentheses or use the
+super low precedence C<or> operator:
+
+ (unlink $file) || die "snafu";
+ unlink $file or die "snafu";
+
+The "English" operators (C<and>, C<or>, C<xor>, and C<not>)
+deliberately have precedence lower than that of list operators for
+just such situations as the one above.
+
+Another operator with surprising precedence is exponentiation. It
+binds more tightly even than unary minus, making C<-2**2> product a
+negative not a positive four. It is also right-associating, meaning
+that C<2**3**2> is two raised to the ninth power, not eight squared.
+
+Although it has the same precedence as in C, Perl's C<?:> operator
+produces an lvalue. This assigns $x to either $a or $b, depending
+on the trueness of $maybe:
+
+ ($maybe ? $a : $b) = $x;
+
+=head2 How do I declare/create a structure?
+
+In general, you don't "declare" a structure. Just use a (probably
+anonymous) hash reference. See L<perlref> and L<perldsc> for details.
+Here's an example:
+
+ $person = {}; # new anonymous hash
+ $person->{AGE} = 24; # set field AGE to 24
+ $person->{NAME} = "Nat"; # set field NAME to "Nat"
+
+If you're looking for something a bit more rigorous, try L<perltoot>.
+
+=head2 How do I create a module?
+
+A module is a package that lives in a file of the same name. For
+example, the Hello::There module would live in Hello/There.pm. For
+details, read L<perlmod>. You'll also find L<Exporter> helpful. If
+you're writing a C or mixed-language module with both C and Perl, then
+you should study L<perlxstut>.
+
+Here's a convenient template you might wish you use when starting your
+own module. Make sure to change the names appropriately.
+
+ package Some::Module; # assumes Some/Module.pm
+
+ use strict;
+
+ BEGIN {
+ use Exporter ();
+ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+ ## set the version for version checking; uncomment to use
+ ## $VERSION = 1.00;
+
+ # if using RCS/CVS, this next line may be preferred,
+ # but beware two-digit versions.
+ $VERSION = do{my@r=q$Revision: 1.21 $=~/\d+/g;sprintf '%d.'.'%02d'x$#r,@r};
+
+ @ISA = qw(Exporter);
+ @EXPORT = qw(&func1 &func2 &func3);
+ %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
+
+ # your exported package globals go here,
+ # as well as any optionally exported functions
+ @EXPORT_OK = qw($Var1 %Hashit);
+ }
+ use vars @EXPORT_OK;
+
+ # non-exported package globals go here
+ use vars qw( @more $stuff );
+
+ # initialize package globals, first exported ones
+ $Var1 = '';
+ %Hashit = ();
+
+ # then the others (which are still accessible as $Some::Module::stuff)
+ $stuff = '';
+ @more = ();
+
+ # all file-scoped lexicals must be created before
+ # the functions below that use them.
+
+ # file-private lexicals go here
+ my $priv_var = '';
+ my %secret_hash = ();
+
+ # here's a file-private function as a closure,
+ # callable as &$priv_func; it cannot be prototyped.
+ my $priv_func = sub {
+ # stuff goes here.
+ };
+
+ # make all your functions, whether exported or not;
+ # remember to put something interesting in the {} stubs
+ sub func1 {} # no prototype
+ sub func2() {} # proto'd void
+ sub func3($$) {} # proto'd to 2 scalars
+
+ # this one isn't exported, but could be called!
+ sub func4(\%) {} # proto'd to 1 hash ref
+
+ END { } # module clean-up code here (global destructor)
+
+ 1; # modules must return true
+
+=head2 How do I create a class?
+
+See L<perltoot> for an introduction to classes and objects, as well as
+L<perlobj> and L<perlbot>.
+
+=head2 How can I tell if a variable is tainted?
+
+See L<perlsec/"Laundering and Detecting Tainted Data">. Here's an
+example (which doesn't use any system calls, because the kill()
+is given no processes to signal):
+
+ sub is_tainted {
+ return ! eval { join('',@_), kill 0; 1; };
+ }
+
+This is not C<-w> clean, however. There is no C<-w> clean way to
+detect taintedness - take this as a hint that you should untaint
+all possibly-tainted data.
+
+=head2 What's a closure?
+
+Closures are documented in L<perlref>.
+
+I<Closure> is a computer science term with a precise but
+hard-to-explain meaning. Closures are implemented in Perl as anonymous
+subroutines with lasting references to lexical variables outside their
+own scopes. These lexicals magically refer to the variables that were
+around when the subroutine was defined (deep binding).
+
+Closures make sense in any programming language where you can have the
+return value of a function be itself a function, as you can in Perl.
+Note that some languages provide anonymous functions but are not
+capable of providing proper closures; the Python language, for
+example. For more information on closures, check out any textbook on
+functional programming. Scheme is a language that not only supports
+but encourages closures.
+
+Here's a classic function-generating function:
+
+ sub add_function_generator {
+ return sub { shift + shift };
+ }
+
+ $add_sub = add_function_generator();
+ $sum = $add_sub->(4,5); # $sum is 9 now.
+
+The closure works as a I<function template> with some customization
+slots left out to be filled later. The anonymous subroutine returned
+by add_function_generator() isn't technically a closure because it
+refers to no lexicals outside its own scope.
+
+Contrast this with the following make_adder() function, in which the
+returned anonymous function contains a reference to a lexical variable
+outside the scope of that function itself. Such a reference requires
+that Perl return a proper closure, thus locking in for all time the
+value that the lexical had when the function was created.
+
+ sub make_adder {
+ my $addpiece = shift;
+ return sub { shift + $addpiece };
+ }
+
+ $f1 = make_adder(20);
+ $f2 = make_adder(555);
+
+Now C<&$f1($n)> is always 20 plus whatever $n you pass in, whereas
+C<&$f2($n)> is always 555 plus whatever $n you pass in. The $addpiece
+in the closure sticks around.
+
+Closures are often used for less esoteric purposes. For example, when
+you want to pass in a bit of code into a function:
+
+ my $line;
+ timeout( 30, sub { $line = <STDIN> } );
+
+If the code to execute had been passed in as a string, C<'$line =
+E<lt>STDINE<gt>'>, there would have been no way for the hypothetical
+timeout() function to access the lexical variable $line back in its
+caller's scope.
+
+=head2 What is variable suicide and how can I prevent it?
+
+Variable suicide is when you (temporarily or permanently) lose the
+value of a variable. It is caused by scoping through my() and local()
+interacting with either closures or aliased foreach() interator
+variables and subroutine arguments. It used to be easy to
+inadvertently lose a variable's value this way, but now it's much
+harder. Take this code:
+
+ my $f = "foo";
+ sub T {
+ while ($i++ < 3) { my $f = $f; $f .= "bar"; print $f, "\n" }
+ }
+ T;
+ print "Finally $f\n";
+
+The $f that has "bar" added to it three times should be a new C<$f>
+(C<my $f> should create a new local variable each time through the
+loop). It isn't, however. This is a bug, and will be fixed.
+
+=head2 How can I pass/return a {Function, FileHandle, Array, Hash, Method, Regexp}?
+
+With the exception of regexps, you need to pass references to these
+objects. See L<perlsub/"Pass by Reference"> for this particular
+question, and L<perlref> for information on references.
+
+=over 4
+
+=item Passing Variables and Functions
+
+Regular variables and functions are quite easy: just pass in a
+reference to an existing or anonymous variable or function:
+
+ func( \$some_scalar );
+
+ func( \$some_array );
+ func( [ 1 .. 10 ] );
+
+ func( \%some_hash );
+ func( { this => 10, that => 20 } );
+
+ func( \&some_func );
+ func( sub { $_[0] ** $_[1] } );
+
+=item Passing Filehandles
+
+To pass filehandles to subroutines, use the C<*FH> or C<\*FH> notations.
+These are "typeglobs" - see L<perldata/"Typeglobs and Filehandles">
+and especially L<perlsub/"Pass by Reference"> for more information.
+
+Here's an excerpt:
+
+If you're passing around filehandles, you could usually just use the bare
+typeglob, like *STDOUT, but typeglobs references would be better because
+they'll still work properly under C<use strict 'refs'>. For example:
+
+ splutter(\*STDOUT);
+ sub splutter {
+ my $fh = shift;
+ print $fh "her um well a hmmm\n";
+ }
+
+ $rec = get_rec(\*STDIN);
+ sub get_rec {
+ my $fh = shift;
+ return scalar <$fh>;
+ }
+
+If you're planning on generating new filehandles, you could do this:
+
+ sub openit {
+ my $name = shift;
+ local *FH;
+ return open (FH, $path) ? *FH : undef;
+ }
+ $fh = openit('< /etc/motd');
+ print <$fh>;
+
+=item Passing Regexps
+
+To pass regexps around, you'll need to either use one of the highly
+experimental regular expression modules from CPAN (Nick Ing-Simmons's
+Regexp or Ilya Zakharevich's Devel::Regexp), pass around strings
+and use an exception-trapping eval, or else be be very, very clever.
+Here's an example of how to pass in a string to be regexp compared:
+
+ sub compare($$) {
+ my ($val1, $regexp) = @_;
+ my $retval = eval { $val =~ /$regexp/ };
+ die if $@;
+ return $retval;
+ }
+
+ $match = compare("old McDonald", q/d.*D/);
+
+Make sure you never say something like this:
+
+ return eval "\$val =~ /$regexp/"; # WRONG
+
+or someone can sneak shell escapes into the regexp due to the double
+interpolation of the eval and the double-quoted string. For example:
+
+ $pattern_of_evil = 'danger ${ system("rm -rf * &") } danger';
+
+ eval "\$string =~ /$pattern_of_evil/";
+
+Those preferring to be very, very clever might see the O'Reilly book,
+I<Mastering Regular Expressions>, by Jeffrey Friedl. Page 273's
+Build_MatchMany_Function() is particularly interesting. A complete
+citation of this book is given in L<perlfaq2>.
+
+=item Passing Methods
+
+To pass an object method into a subroutine, you can do this:
+
+ call_a_lot(10, $some_obj, "methname")
+ sub call_a_lot {
+ my ($count, $widget, $trick) = @_;
+ for (my $i = 0; $i < $count; $i++) {
+ $widget->$trick();
+ }
+ }
+
+Or you can use a closure to bundle up the object and its method call
+and arguments:
+
+ my $whatnot = sub { $some_obj->obfuscate(@args) };
+ func($whatnot);
+ sub func {
+ my $code = shift;
+ &$code();
+ }
+
+You could also investigate the can() method in the UNIVERSAL class
+(part of the standard perl distribution).
+
+=back
+
+=head2 How do I create a static variable?
+
+As with most things in Perl, TMTOWTDI. What is a "static variable" in
+other languages could be either a function-private variable (visible
+only within a single function, retaining its value between calls to
+that function), or a file-private variable (visible only to functions
+within the file it was declared in) in Perl.
+
+Here's code to implement a function-private variable:
+
+ BEGIN {
+ my $counter = 42;
+ sub prev_counter { return --$counter }
+ sub next_counter { return $counter++ }
+ }
+
+Now prev_counter() and next_counter() share a private variable $counter
+that was initialized at compile time.
+
+To declare a file-private variable, you'll still use a my(), putting
+it at the outer scope level at the top of the file. Assume this is in
+file Pax.pm:
+
+ package Pax;
+ my $started = scalar(localtime(time()));
+
+ sub begun { return $started }
+
+When C<use Pax> or C<require Pax> loads this module, the variable will
+be initialized. It won't get garbage-collected the way most variables
+going out of scope do, because the begun() function cares about it,
+but no one else can get it. It is not called $Pax::started because
+its scope is unrelated to the package. It's scoped to the file. You
+could conceivably have several packages in that same file all
+accessing the same private variable, but another file with the same
+package couldn't get to it.
+
+See L<perlsub/"Peristent Private Variables"> for details.
+
+=head2 What's the difference between dynamic and lexical (static) scoping? Between local() and my()?
+
+C<local($x)> saves away the old value of the global variable C<$x>,
+and assigns a new value for the duration of the subroutine, I<which is
+visible in other functions called from that subroutine>. This is done
+at run-time, so is called dynamic scoping. local() always affects global
+variables, also called package variables or dynamic variables.
+
+C<my($x)> creates a new variable that is only visible in the current
+subroutine. This is done at compile-time, so is called lexical or
+static scoping. my() always affects private variables, also called
+lexical variables or (improperly) static(ly scoped) variables.
+
+For instance:
+
+ sub visible {
+ print "var has value $var\n";
+ }
+
+ sub dynamic {
+ local $var = 'local'; # new temporary value for the still-global
+ visible(); # variable called $var
+ }
+
+ sub lexical {
+ my $var = 'private'; # new private variable, $var
+ visible(); # (invisible outside of sub scope)
+ }
+
+ $var = 'global';
+
+ visible(); # prints global
+ dynamic(); # prints local
+ lexical(); # prints global
+
+Notice how at no point does the value "private" get printed. That's
+because $var only has that value within the block of the lexical()
+function, and it is hidden from called subroutine.
+
+In summary, local() doesn't make what you think of as private, local
+variables. It gives a global variable a temporary value. my() is
+what you're looking for if you want private variables.
+
+See L<perlsub/"Private Variables via my()"> and L<perlsub/"Temporary
+Values via local()"> for excruciating details.
+
+=head2 How can I access a dynamic variable while a similarly named lexical is in scope?
+
+You can do this via symbolic references, provided you haven't set
+C<use strict "refs">. So instead of $var, use C<${'var'}>.
+
+ local $var = "global";
+ my $var = "lexical";
+
+ print "lexical is $var\n";
+
+ no strict 'refs';
+ print "global is ${'var'}\n";
+
+If you know your package, you can just mention it explicitly, as in
+$Some_Pack::var. Note that the notation $::var is I<not> the dynamic
+$var in the current package, but rather the one in the C<main>
+package, as though you had written $main::var. Specifying the package
+directly makes you hard-code its name, but it executes faster and
+avoids running afoul of C<use strict "refs">.
+
+=head2 What's the difference between deep and shallow binding?
+
+In deep binding, lexical variables mentioned in anonymous subroutines
+are the same ones that were in scope when the subroutine was created.
+In shallow binding, they are whichever variables with the same names
+happen to be in scope when the subroutine is called. Perl always uses
+deep binding of lexical variables (i.e., those created with my()).
+However, dynamic variables (aka global, local, or package variables)
+are effectively shallowly bound. Consider this just one more reason
+not to use them. See the answer to L<"What's a closure?">.
+
+=head2 Why doesn't "my($foo) = <FILE>;" work right?
+
+C<my()> and C<local()> give list context to the right hand side
+of C<=>. The E<lt>FHE<gt> read operation, like so many of Perl's
+functions and operators, can tell which context it was called in and
+behaves appropriately. In general, the scalar() function can help.
+This function does nothing to the data itself (contrary to popular myth)
+but rather tells its argument to behave in whatever its scalar fashion is.
+If that function doesn't have a defined scalar behavior, this of course
+doesn't help you (such as with sort()).
+
+To enforce scalar context in this particular case, however, you need
+merely omit the parentheses:
+
+ local($foo) = <FILE>; # WRONG
+ local($foo) = scalar(<FILE>); # ok
+ local $foo = <FILE>; # right
+
+You should probably be using lexical variables anyway, although the
+issue is the same here:
+
+ my($foo) = <FILE>; # WRONG
+ my $foo = <FILE>; # right
+
+=head2 How do I redefine a builtin function, operator, or method?
+
+Why do you want to do that? :-)
+
+If you want to override a predefined function, such as open(),
+then you'll have to import the new definition from a different
+module. See L<perlsub/"Overriding Builtin Functions">. There's
+also an example in L<perltoot/"Class::Template">.
+
+If you want to overload a Perl operator, such as C<+> or C<**>,
+then you'll want to use the C<use overload> pragma, documented
+in L<overload>.
+
+If you're talking about obscuring method calls in parent classes,
+see L<perltoot/"Overridden Methods">.
+
+=head2 What's the difference between calling a function as &foo and foo()?
+
+When you call a function as C<&foo>, you allow that function access to
+your current @_ values, and you by-pass prototypes. That means that
+the function doesn't get an empty @_, it gets yours! While not
+strictly speaking a bug (it's documented that way in L<perlsub>), it
+would be hard to consider this a feature in most cases.
+
+When you call your function as C<&foo()>, then you I<do> get a new @_,
+but prototyping is still circumvented.
+
+Normally, you want to call a function using C<foo()>. You may only
+omit the parentheses if the function is already known to the compiler
+because it already saw the definition (C<use> but not C<require>),
+or via a forward reference or C<use subs> declaration. Even in this
+case, you get a clean @_ without any of the old values leaking through
+where they don't belong.
+
+=head2 How do I create a switch or case statement?
+
+This is explained in more depth in the L<perlsyn>. Briefly, there's
+no official case statement, because of the variety of tests possible
+in Perl (numeric comparison, string comparison, glob comparison,
+regexp matching, overloaded comparisons, ...). Larry couldn't decide
+how best to do this, so he left it out, even though it's been on the
+wish list since perl1.
+
+The general answer is to write a construct like this:
+
+ for ($variable_to_test) {
+ if (/pat1/) { } # do something
+ elsif (/pat2/) { } # do something else
+ elsif (/pat3/) { } # do something else
+ else { } # default
+ }
+
+Here's a simple example of a switch based on pattern matching, this
+time lined up in a way to make it look more like a switch statement.
+We'll do a multi-way conditional based on the type of reference stored
+in $whatchamacallit:
+
+ SWITCH: for (ref $whatchamacallit) {
+
+ /^$/ && die "not a reference";
+
+ /SCALAR/ && do {
+ print_scalar($$ref);
+ last SWITCH;
+ };
+
+ /ARRAY/ && do {
+ print_array(@$ref);
+ last SWITCH;
+ };
+
+ /HASH/ && do {
+ print_hash(%$ref);
+ last SWITCH;
+ };
+
+ /CODE/ && do {
+ warn "can't print function ref";
+ last SWITCH;
+ };
+
+ # DEFAULT
+
+ warn "User defined type skipped";
+
+ }
+
+See C<perlsyn/"Basic BLOCKs and Switch Statements"> for many other
+examples in this style.
+
+Sometimes you should change the positions of the constant and the variable.
+For example, let's say you wanted to test which of many answers you were
+given, but in a case-insensitive way that also allows abbreviations.
+You can use the following technique if the strings all start with
+different characters, or if you want to arrange the matches so that
+one takes precedence over another, as C<"SEND"> has precedence over
+C<"STOP"> here:
+
+ chomp($answer = <>);
+ if ("SEND" =~ /^\Q$answer/i) { print "Action is send\n" }
+ elsif ("STOP" =~ /^\Q$answer/i) { print "Action is stop\n" }
+ elsif ("ABORT" =~ /^\Q$answer/i) { print "Action is abort\n" }
+ elsif ("LIST" =~ /^\Q$answer/i) { print "Action is list\n" }
+ elsif ("EDIT" =~ /^\Q$answer/i) { print "Action is edit\n" }
+
+A totally different approach is to create a hash of function references.
+
+ my %commands = (
+ "happy" => \&joy,
+ "sad", => \&sullen,
+ "done" => sub { die "See ya!" },
+ "mad" => \&angry,
+ );
+
+ print "How are you? ";
+ chomp($string = <STDIN>);
+ if ($commands{$string}) {
+ $commands{$string}->();
+ } else {
+ print "No such command: $string\n";
+ }
+
+=head2 How can I catch accesses to undefined variables/functions/methods?
+
+The AUTOLOAD method, discussed in L<perlsub/"Autoloading"> and
+L<perltoot/"AUTOLOAD: Proxy Methods">, lets you capture calls to
+undefined functions and methods.
+
+When it comes to undefined variables that would trigger a warning
+under C<-w>, you can use a handler to trap the pseudo-signal
+C<__WARN__> like this:
+
+ $SIG{__WARN__} = sub {
+
+ for ( $_[0] ) { # voici un switch statement
+
+ /Use of uninitialized value/ && do {
+ # promote warning to a fatal
+ die $_;
+ };
+
+ # other warning cases to catch could go here;
+
+ warn $_;
+ }
+
+ };
+
+=head2 Why can't a method included in this same file be found?
+
+Some possible reasons: your inheritance is getting confused, you've
+misspelled the method name, or the object is of the wrong type. Check
+out L<perltoot> for details on these. You may also use C<print
+ref($object)> to find out the class C<$object> was blessed into.
+
+Another possible reason for problems is because you've used the
+indirect object syntax (eg, C<find Guru "Samy">) on a class name
+before Perl has seen that such a package exists. It's wisest to make
+sure your packages are all defined before you start using them, which
+will be taken care of if you use the C<use> statement instead of
+C<require>. If not, make sure to use arrow notation (eg,
+C<Guru-E<gt>find("Samy")>) instead. Object notation is explained in
+L<perlobj>.
+
+Make sure to read about creating modules in L<perlmod> and
+the perils of indirect objects in L<perlobj/"WARNING">.
+
+=head2 How can I find out my current package?
+
+If you're just a random program, you can do this to find
+out what the currently compiled package is:
+
+ my $packname = __PACKAGE__;
+
+But if you're a method and you want to print an error message
+that includes the kind of object you were called on (which is
+not necessarily the same as the one in which you were compiled):
+
+ sub amethod {
+ my $self = shift;
+ my $class = ref($self) || $self;
+ warn "called me from a $class object";
+ }
+
+=head2 How can I comment out a large block of perl code?
+
+Use embedded POD to discard it:
+
+ # program is here
+
+ =for nobody
+ This paragraph is commented out
+
+ # program continues
+
+ =begin comment text
+
+ all of this stuff
+
+ here will be ignored
+ by everyone
+
+ =end comment text
+
+ =cut
+
+This can't go just anywhere. You have to put a pod directive where
+the parser is expecting a new statement, not just in the middle
+of an expression or some other arbitrary yacc grammar production.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+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 I<outside>
+of that package require that special arrangements be made with
+copyright holder.
+
+Irrespective of its distribution, all code examples in this file
+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.
diff --git a/contrib/perl5/pod/perlfaq8.pod b/contrib/perl5/pod/perlfaq8.pod
new file mode 100644
index 000000000000..c4036ff35d6f
--- /dev/null
+++ b/contrib/perl5/pod/perlfaq8.pod
@@ -0,0 +1,1075 @@
+=head1 NAME
+
+perlfaq8 - System Interaction ($Revision: 1.26 $, $Date: 1998/08/05 12:20:28 $)
+
+=head1 DESCRIPTION
+
+This section of the Perl FAQ covers questions involving operating
+system interaction. This involves interprocess communication (IPC),
+control over the user-interface (keyboard, screen and pointing
+devices), and most anything else not related to data manipulation.
+
+Read the FAQs and documentation specific to the port of perl to your
+operating system (eg, L<perlvms>, L<perlplan9>, ...). These should
+contain more detailed information on the vagaries of your perl.
+
+=head2 How do I find out which operating system I'm running under?
+
+The $^O variable ($OSNAME if you use English) contains the operating
+system that your perl binary was built for.
+
+=head2 How come exec() doesn't return?
+
+Because that's what it does: it replaces your currently running
+program with a different one. If you want to keep going (as is
+probably the case if you're asking this question) use system()
+instead.
+
+=head2 How do I do fancy stuff with the keyboard/screen/mouse?
+
+How you access/control keyboards, screens, and pointing devices
+("mice") is system-dependent. Try the following modules:
+
+=over 4
+
+=item Keyboard
+
+ Term::Cap Standard perl distribution
+ Term::ReadKey CPAN
+ Term::ReadLine::Gnu CPAN
+ Term::ReadLine::Perl CPAN
+ Term::Screen CPAN
+
+=item Screen
+
+ Term::Cap Standard perl distribution
+ Curses CPAN
+ Term::ANSIColor CPAN
+
+=item Mouse
+
+ Tk CPAN
+
+=back
+
+Some of these specific cases are shown below.
+
+=head2 How do I print something out in color?
+
+In general, you don't, because you don't know whether
+the recipient has a color-aware display device. If you
+know that they have an ANSI terminal that understands
+color, you can use the Term::ANSIColor module from CPAN:
+
+ use Term::ANSIColor;
+ print color("red"), "Stop!\n", color("reset");
+ print color("green"), "Go!\n", color("reset");
+
+Or like this:
+
+ use Term::ANSIColor qw(:constants);
+ print RED, "Stop!\n", RESET;
+ print GREEN, "Go!\n", RESET;
+
+=head2 How do I read just one key without waiting for a return key?
+
+Controlling input buffering is a remarkably system-dependent matter.
+If most systems, you can just use the B<stty> command as shown in
+L<perlfunc/getc>, but as you see, that's already getting you into
+portability snags.
+
+ open(TTY, "+</dev/tty") or die "no tty: $!";
+ system "stty cbreak </dev/tty >/dev/tty 2>&1";
+ $key = getc(TTY); # perhaps this works
+ # OR ELSE
+ sysread(TTY, $key, 1); # probably this does
+ system "stty -cbreak </dev/tty >/dev/tty 2>&1";
+
+The Term::ReadKey module from CPAN offers an easy-to-use interface that
+should be more efficient than shelling out to B<stty> for each key.
+It even includes limited support for Windows.
+
+ use Term::ReadKey;
+ ReadMode('cbreak');
+ $key = ReadKey(0);
+ ReadMode('normal');
+
+However, that requires that you have a working C compiler and can use it
+to build and install a CPAN module. Here's a solution using
+the standard POSIX module, which is already on your systems (assuming
+your system supports POSIX).
+
+ use HotKey;
+ $key = readkey();
+
+And here's the HotKey module, which hides the somewhat mystifying calls
+to manipulate the POSIX termios structures.
+
+ # HotKey.pm
+ package HotKey;
+
+ @ISA = qw(Exporter);
+ @EXPORT = qw(cbreak cooked readkey);
+
+ use strict;
+ use POSIX qw(:termios_h);
+ my ($term, $oterm, $echo, $noecho, $fd_stdin);
+
+ $fd_stdin = fileno(STDIN);
+ $term = POSIX::Termios->new();
+ $term->getattr($fd_stdin);
+ $oterm = $term->getlflag();
+
+ $echo = ECHO | ECHOK | ICANON;
+ $noecho = $oterm & ~$echo;
+
+ sub cbreak {
+ $term->setlflag($noecho); # ok, so i don't want echo either
+ $term->setcc(VTIME, 1);
+ $term->setattr($fd_stdin, TCSANOW);
+ }
+
+ sub cooked {
+ $term->setlflag($oterm);
+ $term->setcc(VTIME, 0);
+ $term->setattr($fd_stdin, TCSANOW);
+ }
+
+ sub readkey {
+ my $key = '';
+ cbreak();
+ sysread(STDIN, $key, 1);
+ cooked();
+ return $key;
+ }
+
+ END { cooked() }
+
+ 1;
+
+=head2 How do I check whether input is ready on the keyboard?
+
+The easiest way to do this is to read a key in nonblocking mode with the
+Term::ReadKey module from CPAN, passing it an argument of -1 to indicate
+not to block:
+
+ use Term::ReadKey;
+
+ ReadMode('cbreak');
+
+ if (defined ($char = ReadKey(-1)) ) {
+ # input was waiting and it was $char
+ } else {
+ # no input was waiting
+ }
+
+ ReadMode('normal'); # restore normal tty settings
+
+=head2 How do I clear the screen?
+
+If you only have to so infrequently, use C<system>:
+
+ system("clear");
+
+If you have to do this a lot, save the clear string
+so you can print it 100 times without calling a program
+100 times:
+
+ $clear_string = `clear`;
+ print $clear_string;
+
+If you're planning on doing other screen manipulations, like cursor
+positions, etc, you might wish to use Term::Cap module:
+
+ use Term::Cap;
+ $terminal = Term::Cap->Tgetent( {OSPEED => 9600} );
+ $clear_string = $terminal->Tputs('cl');
+
+=head2 How do I get the screen size?
+
+If you have Term::ReadKey module installed from CPAN,
+you can use it to fetch the width and height in characters
+and in pixels:
+
+ use Term::ReadKey;
+ ($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize();
+
+This is more portable than the raw C<ioctl>, but not as
+illustrative:
+
+ require 'sys/ioctl.ph';
+ die "no TIOCGWINSZ " unless defined &TIOCGWINSZ;
+ open(TTY, "+</dev/tty") or die "No tty: $!";
+ unless (ioctl(TTY, &TIOCGWINSZ, $winsize='')) {
+ die sprintf "$0: ioctl TIOCGWINSZ (%08x: $!)\n", &TIOCGWINSZ;
+ }
+ ($row, $col, $xpixel, $ypixel) = unpack('S4', $winsize);
+ print "(row,col) = ($row,$col)";
+ print " (xpixel,ypixel) = ($xpixel,$ypixel)" if $xpixel || $ypixel;
+ print "\n";
+
+=head2 How do I ask the user for a password?
+
+(This question has nothing to do with the web. See a different
+FAQ for that.)
+
+There's an example of this in L<perlfunc/crypt>). First, you put
+the terminal into "no echo" mode, then just read the password
+normally. You may do this with an old-style ioctl() function, POSIX
+terminal control (see L<POSIX>, and Chapter 7 of the Camel), or a call
+to the B<stty> program, with varying degrees of portability.
+
+You can also do this for most systems using the Term::ReadKey module
+from CPAN, which is easier to use and in theory more portable.
+
+ use Term::ReadKey;
+
+ ReadMode('noecho');
+ $password = ReadLine(0);
+
+=head2 How do I read and write the serial port?
+
+This depends on which operating system your program is running on. In
+the case of Unix, the serial ports will be accessible through files in
+/dev; on other systems, the devices names will doubtless differ.
+Several problem areas common to all device interaction are the
+following
+
+=over 4
+
+=item lockfiles
+
+Your system may use lockfiles to control multiple access. Make sure
+you follow the correct protocol. Unpredictable behaviour can result
+from multiple processes reading from one device.
+
+=item open mode
+
+If you expect to use both read and write operations on the device,
+you'll have to open it for update (see L<perlfunc/"open"> for
+details). You may wish to open it without running the risk of
+blocking by using sysopen() and C<O_RDWR|O_NDELAY|O_NOCTTY> from the
+Fcntl module (part of the standard perl distribution). See
+L<perlfunc/"sysopen"> for more on this approach.
+
+=item end of line
+
+Some devices will be expecting a "\r" at the end of each line rather
+than a "\n". In some ports of perl, "\r" and "\n" are different from
+their usual (Unix) ASCII values of "\012" and "\015". You may have to
+give the numeric values you want directly, using octal ("\015"), hex
+("0x0D"), or as a control-character specification ("\cM").
+
+ print DEV "atv1\012"; # wrong, for some devices
+ print DEV "atv1\015"; # right, for some devices
+
+Even though with normal text files, a "\n" will do the trick, there is
+still no unified scheme for terminating a line that is portable
+between Unix, DOS/Win, and Macintosh, except to terminate I<ALL> line
+ends with "\015\012", and strip what you don't need from the output.
+This applies especially to socket I/O and autoflushing, discussed
+next.
+
+=item flushing output
+
+If you expect characters to get to your device when you print() them,
+you'll want to autoflush that filehandle. You can use select()
+and the C<$|> variable to control autoflushing (see L<perlvar/$|>
+and L<perlfunc/select>):
+
+ $oldh = select(DEV);
+ $| = 1;
+ select($oldh);
+
+You'll also see code that does this without a temporary variable, as in
+
+ select((select(DEV), $| = 1)[0]);
+
+Or if you don't mind pulling in a few thousand lines
+of code just because you're afraid of a little $| variable:
+
+ use IO::Handle;
+ DEV->autoflush(1);
+
+As mentioned in the previous item, this still doesn't work when using
+socket I/O between Unix and Macintosh. You'll need to hardcode your
+line terminators, in that case.
+
+=item non-blocking input
+
+If you are doing a blocking read() or sysread(), you'll have to
+arrange for an alarm handler to provide a timeout (see
+L<perlfunc/alarm>). If you have a non-blocking open, you'll likely
+have a non-blocking read, which means you may have to use a 4-arg
+select() to determine whether I/O is ready on that device (see
+L<perlfunc/"select">.
+
+=back
+
+While trying to read from his caller-id box, the notorious Jamie Zawinski
+<jwz@netscape.com>, after much gnashing of teeth and fighting with sysread,
+sysopen, POSIX's tcgetattr business, and various other functions that
+go bump in the night, finally came up with this:
+
+ sub open_modem {
+ use IPC::Open2;
+ my $stty = `/bin/stty -g`;
+ open2( \*MODEM_IN, \*MODEM_OUT, "cu -l$modem_device -s2400 2>&1");
+ # starting cu hoses /dev/tty's stty settings, even when it has
+ # been opened on a pipe...
+ system("/bin/stty $stty");
+ $_ = <MODEM_IN>;
+ chop;
+ if ( !m/^Connected/ ) {
+ print STDERR "$0: cu printed `$_' instead of `Connected'\n";
+ }
+ }
+
+
+=head2 How do I decode encrypted password files?
+
+You spend lots and lots of money on dedicated hardware, but this is
+bound to get you talked about.
+
+Seriously, you can't if they are Unix password files - the Unix
+password system employs one-way encryption. It's more like hashing than
+encryption. The best you can check is whether something else hashes to
+the same string. You can't turn a hash back into the original string.
+Programs like Crack
+can forcibly (and intelligently) try to guess passwords, but don't
+(can't) guarantee quick success.
+
+If you're worried about users selecting bad passwords, you should
+proactively check when they try to change their password (by modifying
+passwd(1), for example).
+
+=head2 How do I start a process in the background?
+
+You could use
+
+ system("cmd &")
+
+or you could use fork as documented in L<perlfunc/"fork">, with
+further examples in L<perlipc>. Some things to be aware of, if you're
+on a Unix-like system:
+
+=over 4
+
+=item STDIN, STDOUT, and STDERR are shared
+
+Both the main process and the backgrounded one (the "child" process)
+share the same STDIN, STDOUT and STDERR filehandles. If both try to
+access them at once, strange things can happen. You may want to close
+or reopen these for the child. You can get around this with
+C<open>ing a pipe (see L<perlfunc/"open">) but on some systems this
+means that the child process cannot outlive the parent.
+
+=item Signals
+
+You'll have to catch the SIGCHLD signal, and possibly SIGPIPE too.
+SIGCHLD is sent when the backgrounded process finishes. SIGPIPE is
+sent when you write to a filehandle whose child process has closed (an
+untrapped SIGPIPE can cause your program to silently die). This is
+not an issue with C<system("cmd&")>.
+
+=item Zombies
+
+You have to be prepared to "reap" the child process when it finishes
+
+ $SIG{CHLD} = sub { wait };
+
+See L<perlipc/"Signals"> for other examples of code to do this.
+Zombies are not an issue with C<system("prog &")>.
+
+=back
+
+=head2 How do I trap control characters/signals?
+
+You don't actually "trap" a control character. Instead, that character
+generates a signal which is sent to your terminal's currently
+foregrounded process group, which you then trap in your process.
+Signals are documented in L<perlipc/"Signals"> and chapter 6 of the Camel.
+
+Be warned that very few C libraries are re-entrant. Therefore, if you
+attempt to print() in a handler that got invoked during another stdio
+operation your internal structures will likely be in an
+inconsistent state, and your program will dump core. You can
+sometimes avoid this by using syswrite() instead of print().
+
+Unless you're exceedingly careful, the only safe things to do inside a
+signal handler are: set a variable and exit. And in the first case,
+you should only set a variable in such a way that malloc() is not
+called (eg, by setting a variable that already has a value).
+
+For example:
+
+ $Interrupted = 0; # to ensure it has a value
+ $SIG{INT} = sub {
+ $Interrupted++;
+ syswrite(STDERR, "ouch\n", 5);
+ }
+
+However, because syscalls restart by default, you'll find that if
+you're in a "slow" call, such as E<lt>FHE<gt>, read(), connect(), or
+wait(), that the only way to terminate them is by "longjumping" out;
+that is, by raising an exception. See the time-out handler for a
+blocking flock() in L<perlipc/"Signals"> or chapter 6 of the Camel.
+
+=head2 How do I modify the shadow password file on a Unix system?
+
+If perl was installed correctly, and your shadow library was written
+properly, the getpw*() functions described in L<perlfunc> should in
+theory provide (read-only) access to entries in the shadow password
+file. To change the file, make a new shadow password file (the format
+varies from system to system - see L<passwd(5)> for specifics) and use
+pwd_mkdb(8) to install it (see L<pwd_mkdb(5)> for more details).
+
+=head2 How do I set the time and date?
+
+Assuming you're running under sufficient permissions, you should be
+able to set the system-wide date and time by running the date(1)
+program. (There is no way to set the time and date on a per-process
+basis.) This mechanism will work for Unix, MS-DOS, Windows, and NT;
+the VMS equivalent is C<set time>.
+
+However, if all you want to do is change your timezone, you can
+probably get away with setting an environment variable:
+
+ $ENV{TZ} = "MST7MDT"; # unixish
+ $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}="-5" # vms
+ system "trn comp.lang.perl.misc";
+
+=head2 How can I sleep() or alarm() for under a second?
+
+If you want finer granularity than the 1 second that the sleep()
+function provides, the easiest way is to use the select() function as
+documented in L<perlfunc/"select">. If your system has itimers and
+syscall() support, you can check out the old example in
+http://www.perl.com/CPAN/doc/misc/ancient/tutorial/eg/itimers.pl .
+
+=head2 How can I measure time under a second?
+
+In general, you may not be able to. The Time::HiRes module (available
+from CPAN) provides this functionality for some systems.
+
+In general, you may not be able to. But if your system supports both the
+syscall() function in Perl as well as a system call like gettimeofday(2),
+then you may be able to do something like this:
+
+ require 'sys/syscall.ph';
+
+ $TIMEVAL_T = "LL";
+
+ $done = $start = pack($TIMEVAL_T, ());
+
+ syscall( &SYS_gettimeofday, $start, 0)) != -1
+ or die "gettimeofday: $!";
+
+ ##########################
+ # DO YOUR OPERATION HERE #
+ ##########################
+
+ syscall( &SYS_gettimeofday, $done, 0) != -1
+ or die "gettimeofday: $!";
+
+ @start = unpack($TIMEVAL_T, $start);
+ @done = unpack($TIMEVAL_T, $done);
+
+ # fix microseconds
+ for ($done[1], $start[1]) { $_ /= 1_000_000 }
+
+ $delta_time = sprintf "%.4f", ($done[0] + $done[1] )
+ -
+ ($start[0] + $start[1] );
+
+=head2 How can I do an atexit() or setjmp()/longjmp()? (Exception handling)
+
+Release 5 of Perl added the END block, which can be used to simulate
+atexit(). Each package's END block is called when the program or
+thread ends (see L<perlmod> manpage for more details).
+
+For example, you can use this to make sure your filter program
+managed to finish its output without filling up the disk:
+
+ END {
+ close(STDOUT) || die "stdout close failed: $!";
+ }
+
+The END block isn't called when untrapped signals kill the program, though, so if
+you use END blocks you should also use
+
+ use sigtrap qw(die normal-signals);
+
+Perl's exception-handling mechanism is its eval() operator. You can
+use eval() as setjmp and die() as longjmp. For details of this, see
+the section on signals, especially the time-out handler for a blocking
+flock() in L<perlipc/"Signals"> and chapter 6 of the Camel.
+
+If exception handling is all you're interested in, try the
+exceptions.pl library (part of the standard perl distribution).
+
+If you want the atexit() syntax (and an rmexit() as well), try the
+AtExit module available from CPAN.
+
+=head2 Why doesn't my sockets program work under System V (Solaris)? What does the error message "Protocol not supported" mean?
+
+Some Sys-V based systems, notably Solaris 2.X, redefined some of the
+standard socket constants. Since these were constant across all
+architectures, they were often hardwired into perl code. The proper
+way to deal with this is to "use Socket" to get the correct values.
+
+Note that even though SunOS and Solaris are binary compatible, these
+values are different. Go figure.
+
+=head2 How can I call my system's unique C functions from Perl?
+
+In most cases, you write an external module to do it - see the answer
+to "Where can I learn about linking C with Perl? [h2xs, xsubpp]".
+However, if the function is a system call, and your system supports
+syscall(), you can use the syscall function (documented in
+L<perlfunc>).
+
+Remember to check the modules that came with your distribution, and
+CPAN as well - someone may already have written a module to do it.
+
+=head2 Where do I get the include files to do ioctl() or syscall()?
+
+Historically, these would be generated by the h2ph tool, part of the
+standard perl distribution. This program converts cpp(1) directives
+in C header files to files containing subroutine definitions, like
+&SYS_getitimer, which you can use as arguments to your functions.
+It doesn't work perfectly, but it usually gets most of the job done.
+Simple files like F<errno.h>, F<syscall.h>, and F<socket.h> were fine,
+but the hard ones like F<ioctl.h> nearly always need to hand-edited.
+Here's how to install the *.ph files:
+
+ 1. become super-user
+ 2. cd /usr/include
+ 3. h2ph *.h */*.h
+
+If your system supports dynamic loading, for reasons of portability and
+sanity you probably ought to use h2xs (also part of the standard perl
+distribution). This tool converts C header files to Perl extensions.
+See L<perlxstut> for how to get started with h2xs.
+
+If your system doesn't support dynamic loading, you still probably
+ought to use h2xs. See L<perlxstut> and L<ExtUtils::MakeMaker> for
+more information (in brief, just use B<make perl> instead of a plain
+B<make> to rebuild perl with a new static extension).
+
+=head2 Why do setuid perl scripts complain about kernel problems?
+
+Some operating systems have bugs in the kernel that make setuid
+scripts inherently insecure. Perl gives you a number of options
+(described in L<perlsec>) to work around such systems.
+
+=head2 How can I open a pipe both to and from a command?
+
+The IPC::Open2 module (part of the standard perl distribution) is an
+easy-to-use approach that internally uses pipe(), fork(), and exec() to do
+the job. Make sure you read the deadlock warnings in its documentation,
+though (see L<IPC::Open2>). See L<perlipc/"Bidirectional Communication
+with Another Process"> and L<perlipc/"Bidirectional Communication with
+Yourself">
+
+You may also use the IPC::Open3 module (part of the standard perl
+distribution), but be warned that it has a different order of
+arguments from IPC::Open2 (see L<IPC::Open3>).
+
+=head2 Why can't I get the output of a command with system()?
+
+You're confusing the purpose of system() and backticks (``). system()
+runs a command and returns exit status information (as a 16 bit value:
+the low 7 bits are the signal the process died from, if any, and
+the high 8 bits are the actual exit value). Backticks (``) run a
+command and return what it sent to STDOUT.
+
+ $exit_status = system("mail-users");
+ $output_string = `ls`;
+
+=head2 How can I capture STDERR from an external command?
+
+There are three basic ways of running external commands:
+
+ system $cmd; # using system()
+ $output = `$cmd`; # using backticks (``)
+ open (PIPE, "cmd |"); # using open()
+
+With system(), both STDOUT and STDERR will go the same place as the
+script's versions of these, unless the command redirects them.
+Backticks and open() read B<only> the STDOUT of your command.
+
+With any of these, you can change file descriptors before the call:
+
+ open(STDOUT, ">logfile");
+ system("ls");
+
+or you can use Bourne shell file-descriptor redirection:
+
+ $output = `$cmd 2>some_file`;
+ open (PIPE, "cmd 2>some_file |");
+
+You can also use file-descriptor redirection to make STDERR a
+duplicate of STDOUT:
+
+ $output = `$cmd 2>&1`;
+ open (PIPE, "cmd 2>&1 |");
+
+Note that you I<cannot> simply open STDERR to be a dup of STDOUT
+in your Perl program and avoid calling the shell to do the redirection.
+This doesn't work:
+
+ open(STDERR, ">&STDOUT");
+ $alloutput = `cmd args`; # stderr still escapes
+
+This fails because the open() makes STDERR go to where STDOUT was
+going at the time of the open(). The backticks then make STDOUT go to
+a string, but don't change STDERR (which still goes to the old
+STDOUT).
+
+Note that you I<must> use Bourne shell (sh(1)) redirection syntax in
+backticks, not csh(1)! Details on why Perl's system() and backtick
+and pipe opens all use the Bourne shell are in
+http://www.perl.com/CPAN/doc/FMTEYEWTK/versus/csh.whynot .
+To capture a command's STDERR and STDOUT together:
+
+ $output = `cmd 2>&1`; # either with backticks
+ $pid = open(PH, "cmd 2>&1 |"); # or with an open pipe
+ while (<PH>) { } # plus a read
+
+To capture a command's STDOUT but discard its STDERR:
+
+ $output = `cmd 2>/dev/null`; # either with backticks
+ $pid = open(PH, "cmd 2>/dev/null |"); # or with an open pipe
+ while (<PH>) { } # plus a read
+
+To capture a command's STDERR but discard its STDOUT:
+
+ $output = `cmd 2>&1 1>/dev/null`; # either with backticks
+ $pid = open(PH, "cmd 2>&1 1>/dev/null |"); # or with an open pipe
+ while (<PH>) { } # plus a read
+
+To exchange a command's STDOUT and STDERR in order to capture the STDERR
+but leave its STDOUT to come out our old STDERR:
+
+ $output = `cmd 3>&1 1>&2 2>&3 3>&-`; # either with backticks
+ $pid = open(PH, "cmd 3>&1 1>&2 2>&3 3>&-|");# or with an open pipe
+ while (<PH>) { } # plus a read
+
+To read both a command's STDOUT and its STDERR separately, it's easiest
+and safest to redirect them separately to files, and then read from those
+files when the program is done:
+
+ system("program args 1>/tmp/program.stdout 2>/tmp/program.stderr");
+
+Ordering is important in all these examples. That's because the shell
+processes file descriptor redirections in strictly left to right order.
+
+ system("prog args 1>tmpfile 2>&1");
+ system("prog args 2>&1 1>tmpfile");
+
+The first command sends both standard out and standard error to the
+temporary file. The second command sends only the old standard output
+there, and the old standard error shows up on the old standard out.
+
+=head2 Why doesn't open() return an error when a pipe open fails?
+
+It does, but probably not how you expect it to. On systems that
+follow the standard fork()/exec() paradigm (such as Unix), it works like
+this: open() causes a fork(). In the parent, open() returns with the
+process ID of the child. The child exec()s the command to be piped
+to/from. The parent can't know whether the exec() was successful or
+not - all it can return is whether the fork() succeeded or not. To
+find out if the command succeeded, you have to catch SIGCHLD and
+wait() to get the exit status. You should also catch SIGPIPE if
+you're writing to the child -- you may not have found out the exec()
+failed by the time you write. This is documented in L<perlipc>.
+
+On systems that follow the spawn() paradigm, open() I<might> do what
+you expect - unless perl uses a shell to start your command. In this
+case the fork()/exec() description still applies.
+
+=head2 What's wrong with using backticks in a void context?
+
+Strictly speaking, nothing. Stylistically speaking, it's not a good
+way to write maintainable code because backticks have a (potentially
+humungous) return value, and you're ignoring it. It's may also not be very
+efficient, because you have to read in all the lines of output, allocate
+memory for them, and then throw it away. Too often people are lulled
+to writing:
+
+ `cp file file.bak`;
+
+And now they think "Hey, I'll just always use backticks to run programs."
+Bad idea: backticks are for capturing a program's output; the system()
+function is for running programs.
+
+Consider this line:
+
+ `cat /etc/termcap`;
+
+You haven't assigned the output anywhere, so it just wastes memory
+(for a little while). Plus you forgot to check C<$?> to see whether
+the program even ran correctly. Even if you wrote
+
+ print `cat /etc/termcap`;
+
+In most cases, this could and probably should be written as
+
+ system("cat /etc/termcap") == 0
+ or die "cat program failed!";
+
+Which will get the output quickly (as its generated, instead of only
+at the end) and also check the return value.
+
+system() also provides direct control over whether shell wildcard
+processing may take place, whereas backticks do not.
+
+=head2 How can I call backticks without shell processing?
+
+This is a bit tricky. Instead of writing
+
+ @ok = `grep @opts '$search_string' @filenames`;
+
+You have to do this:
+
+ my @ok = ();
+ if (open(GREP, "-|")) {
+ while (<GREP>) {
+ chomp;
+ push(@ok, $_);
+ }
+ close GREP;
+ } else {
+ exec 'grep', @opts, $search_string, @filenames;
+ }
+
+Just as with system(), no shell escapes happen when you exec() a list.
+
+There are more examples of this L<perlipc/"Safe Pipe Opens">.
+
+=head2 Why can't my script read from STDIN after I gave it EOF (^D on Unix, ^Z on MS-DOS)?
+
+Because some stdio's set error and eof flags that need clearing. The
+POSIX module defines clearerr() that you can use. That is the
+technically correct way to do it. Here are some less reliable
+workarounds:
+
+=over 4
+
+=item 1
+
+Try keeping around the seekpointer and go there, like this:
+
+ $where = tell(LOG);
+ seek(LOG, $where, 0);
+
+=item 2
+
+If that doesn't work, try seeking to a different part of the file and
+then back.
+
+=item 3
+
+If that doesn't work, try seeking to a different part of
+the file, reading something, and then seeking back.
+
+=item 4
+
+If that doesn't work, give up on your stdio package and use sysread.
+
+=back
+
+=head2 How can I convert my shell script to perl?
+
+Learn Perl and rewrite it. Seriously, there's no simple converter.
+Things that are awkward to do in the shell are easy to do in Perl, and
+this very awkwardness is what would make a shell->perl converter
+nigh-on impossible to write. By rewriting it, you'll think about what
+you're really trying to do, and hopefully will escape the shell's
+pipeline datastream paradigm, which while convenient for some matters,
+causes many inefficiencies.
+
+=head2 Can I use perl to run a telnet or ftp session?
+
+Try the Net::FTP, TCP::Client, and Net::Telnet modules (available from
+CPAN). http://www.perl.com/CPAN/scripts/netstuff/telnet.emul.shar
+will also help for emulating the telnet protocol, but Net::Telnet is
+quite probably easier to use..
+
+If all you want to do is pretend to be telnet but don't need
+the initial telnet handshaking, then the standard dual-process
+approach will suffice:
+
+ use IO::Socket; # new in 5.004
+ $handle = IO::Socket::INET->new('www.perl.com:80')
+ || die "can't connect to port 80 on www.perl.com: $!";
+ $handle->autoflush(1);
+ if (fork()) { # XXX: undef means failure
+ select($handle);
+ print while <STDIN>; # everything from stdin to socket
+ } else {
+ print while <$handle>; # everything from socket to stdout
+ }
+ close $handle;
+ exit;
+
+=head2 How can I write expect in Perl?
+
+Once upon a time, there was a library called chat2.pl (part of the
+standard perl distribution), which never really got finished. If you
+find it somewhere, I<don't use it>. These days, your best bet is to
+look at the Expect module available from CPAN, which also requires two
+other modules from CPAN, IO::Pty and IO::Stty.
+
+=head2 Is there a way to hide perl's command line from programs such as "ps"?
+
+First of all note that if you're doing this for security reasons (to
+avoid people seeing passwords, for example) then you should rewrite
+your program so that critical information is never given as an
+argument. Hiding the arguments won't make your program completely
+secure.
+
+To actually alter the visible command line, you can assign to the
+variable $0 as documented in L<perlvar>. This won't work on all
+operating systems, though. Daemon programs like sendmail place their
+state there, as in:
+
+ $0 = "orcus [accepting connections]";
+
+=head2 I {changed directory, modified my environment} in a perl script. How come the change disappeared when I exited the script? How do I get my changes to be visible?
+
+=over 4
+
+=item Unix
+
+In the strictest sense, it can't be done -- the script executes as a
+different process from the shell it was started from. Changes to a
+process are not reflected in its parent, only in its own children
+created after the change. There is shell magic that may allow you to
+fake it by eval()ing the script's output in your shell; check out the
+comp.unix.questions FAQ for details.
+
+=back
+
+=head2 How do I close a process's filehandle without waiting for it to complete?
+
+Assuming your system supports such things, just send an appropriate signal
+to the process (see L<perlfunc/"kill">. It's common to first send a TERM
+signal, wait a little bit, and then send a KILL signal to finish it off.
+
+=head2 How do I fork a daemon process?
+
+If by daemon process you mean one that's detached (disassociated from
+its tty), then the following process is reported to work on most
+Unixish systems. Non-Unix users should check their Your_OS::Process
+module for other solutions.
+
+=over 4
+
+=item *
+
+Open /dev/tty and use the the TIOCNOTTY ioctl on it. See L<tty(4)>
+for details. Or better yet, you can just use the POSIX::setsid()
+function, so you don't have to worry about process groups.
+
+=item *
+
+Change directory to /
+
+=item *
+
+Reopen STDIN, STDOUT, and STDERR so they're not connected to the old
+tty.
+
+=item *
+
+Background yourself like this:
+
+ fork && exit;
+
+=back
+
+=head2 How do I make my program run with sh and csh?
+
+See the F<eg/nih> script (part of the perl source distribution).
+
+=head2 How do I find out if I'm running interactively or not?
+
+Good question. Sometimes C<-t STDIN> and C<-t STDOUT> can give clues,
+sometimes not.
+
+ if (-t STDIN && -t STDOUT) {
+ print "Now what? ";
+ }
+
+On POSIX systems, you can test whether your own process group matches
+the current process group of your controlling terminal as follows:
+
+ use POSIX qw/getpgrp tcgetpgrp/;
+ open(TTY, "/dev/tty") or die $!;
+ $tpgrp = tcgetpgrp(TTY);
+ $pgrp = getpgrp();
+ if ($tpgrp == $pgrp) {
+ print "foreground\n";
+ } else {
+ print "background\n";
+ }
+
+=head2 How do I timeout a slow event?
+
+Use the alarm() function, probably in conjunction with a signal
+handler, as documented L<perlipc/"Signals"> and chapter 6 of the
+Camel. You may instead use the more flexible Sys::AlarmCall module
+available from CPAN.
+
+=head2 How do I set CPU limits?
+
+Use the BSD::Resource module from CPAN.
+
+=head2 How do I avoid zombies on a Unix system?
+
+Use the reaper code from L<perlipc/"Signals"> to call wait() when a
+SIGCHLD is received, or else use the double-fork technique described
+in L<perlfunc/fork>.
+
+=head2 How do I use an SQL database?
+
+There are a number of excellent interfaces to SQL databases. See the
+DBD::* modules available from
+http://www.perl.com/CPAN/modules/dbperl/DBD .
+A lot of information on this can be found at
+http://www.hermetica.com/technologia/perl/DBI/index.html .
+
+=head2 How do I make a system() exit on control-C?
+
+You can't. You need to imitate the system() call (see L<perlipc> for
+sample code) and then have a signal handler for the INT signal that
+passes the signal on to the subprocess. Or you can check for it:
+
+ $rc = system($cmd);
+ if ($rc & 127) { die "signal death" }
+
+=head2 How do I open a file without blocking?
+
+If you're lucky enough to be using a system that supports
+non-blocking reads (most Unixish systems do), you need only to use the
+O_NDELAY or O_NONBLOCK flag from the Fcntl module in conjunction with
+sysopen():
+
+ use Fcntl;
+ sysopen(FH, "/tmp/somefile", O_WRONLY|O_NDELAY|O_CREAT, 0644)
+ or die "can't open /tmp/somefile: $!":
+
+=head2 How do I install a CPAN module?
+
+The easiest way is to have the CPAN module do it for you. This module
+comes with perl version 5.004 and later. To manually install the CPAN
+module, or any well-behaved CPAN module for that matter, follow these
+steps:
+
+=over 4
+
+=item 1
+
+Unpack the source into a temporary area.
+
+=item 2
+
+ perl Makefile.PL
+
+=item 3
+
+ make
+
+=item 4
+
+ make test
+
+=item 5
+
+ make install
+
+=back
+
+If your version of perl is compiled without dynamic loading, then you
+just need to replace step 3 (B<make>) with B<make perl> and you will
+get a new F<perl> binary with your extension linked in.
+
+See L<ExtUtils::MakeMaker> for more details on building extensions.
+See also the next question.
+
+=head2 What's the difference between require and use?
+
+Perl offers several different ways to include code from one file into
+another. Here are the deltas between the various inclusion constructs:
+
+ 1) do $file is like eval `cat $file`, except the former:
+ 1.1: searches @INC and updates %INC.
+ 1.2: bequeaths an *unrelated* lexical scope on the eval'ed code.
+
+ 2) require $file is like do $file, except the former:
+ 2.1: checks for redundant loading, skipping already loaded files.
+ 2.2: raises an exception on failure to find, compile, or execute $file.
+
+ 3) require Module is like require "Module.pm", except the former:
+ 3.1: translates each "::" into your system's directory separator.
+ 3.2: primes the parser to disambiguate class Module as an indirect object.
+
+ 4) use Module is like require Module, except the former:
+ 4.1: loads the module at compile time, not run-time.
+ 4.2: imports symbols and semantics from that package to the current one.
+
+In general, you usually want C<use> and a proper Perl module.
+
+=head2 How do I keep my own module/library directory?
+
+When you build modules, use the PREFIX option when generating
+Makefiles:
+
+ perl Makefile.PL PREFIX=/u/mydir/perl
+
+then either set the PERL5LIB environment variable before you run
+scripts that use the modules/libraries (see L<perlrun>) or say
+
+ use lib '/u/mydir/perl';
+
+See Perl's L<lib> for more information.
+
+=head2 How do I add the directory my program lives in to the module/library search path?
+
+ use FindBin;
+ use lib "$FindBin::Bin";
+ use your_own_modules;
+
+=head2 How do I add a directory to my include path at runtime?
+
+Here are the suggested ways of modifying your include path:
+
+ the PERLLIB environment variable
+ the PERL5LIB environment variable
+ the perl -Idir commpand line flag
+ the use lib pragma, as in
+ use lib "$ENV{HOME}/myown_perllib";
+
+The latter is particularly useful because it knows about machine
+dependent architectures. The lib.pm pragmatic module was first
+included with the 5.002 release of Perl.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+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 I<outside>
+of that package require that special arrangements be made with
+copyright holder.
+
+Irrespective of its distribution, all code examples in this file
+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.
diff --git a/contrib/perl5/pod/perlfaq9.pod b/contrib/perl5/pod/perlfaq9.pod
new file mode 100644
index 000000000000..330158b77b48
--- /dev/null
+++ b/contrib/perl5/pod/perlfaq9.pod
@@ -0,0 +1,552 @@
+=head1 NAME
+
+perlfaq9 - Networking ($Revision: 1.20 $, $Date: 1998/06/22 18:31:09 $)
+
+=head1 DESCRIPTION
+
+This section deals with questions related to networking, the internet,
+and a few on the web.
+
+=head2 My CGI script runs from the command line but not the browser. (500 Server Error)
+
+If you can demonstrate that you've read the following FAQs and that
+your problem isn't something simple that can be easily answered, you'll
+probably receive a courteous and useful reply to your question if you
+post it on comp.infosystems.www.authoring.cgi (if it's something to do
+with HTTP, HTML, or the CGI protocols). Questions that appear to be Perl
+questions but are really CGI ones that are posted to comp.lang.perl.misc
+may not be so well received.
+
+The useful FAQs and related documents are:
+
+ CGI FAQ
+ http://www.webthing.com/page.cgi/cgifaq
+
+ Web FAQ
+ http://www.boutell.com/faq/
+
+ WWW Security FAQ
+ http://www.w3.org/Security/Faq/
+
+ HTTP Spec
+ http://www.w3.org/pub/WWW/Protocols/HTTP/
+
+ HTML Spec
+ http://www.w3.org/TR/REC-html40/
+ http://www.w3.org/pub/WWW/MarkUp/
+
+ CGI Spec
+ http://www.w3.org/CGI/
+
+ CGI Security FAQ
+ http://www.go2net.com/people/paulp/cgi-security/safe-cgi.txt
+
+=head2 How can I get better error messages from a CGI program?
+
+Use the CGI::Carp module. It replaces C<warn> and C<die>, plus the
+normal Carp modules C<carp>, C<croak>, and C<confess> functions with
+more verbose and safer versions. It still sends them to the normal
+server error log.
+
+ use CGI::Carp;
+ warn "This is a complaint";
+ die "But this one is serious";
+
+The following use of CGI::Carp also redirects errors to a file of your choice,
+placed in a BEGIN block to catch compile-time warnings as well:
+
+ BEGIN {
+ use CGI::Carp qw(carpout);
+ open(LOG, ">>/var/local/cgi-logs/mycgi-log")
+ or die "Unable to append to mycgi-log: $!\n";
+ carpout(*LOG);
+ }
+
+You can even arrange for fatal errors to go back to the client browser,
+which is nice for your own debugging, but might confuse the end user.
+
+ use CGI::Carp qw(fatalsToBrowser);
+ die "Bad error here";
+
+Even if the error happens before you get the HTTP header out, the module
+will try to take care of this to avoid the dreaded server 500 errors.
+Normal warnings still go out to the server error log (or wherever
+you've sent them with C<carpout>) with the application name and date
+stamp prepended.
+
+=head2 How do I remove HTML from a string?
+
+The most correct way (albeit not the fastest) is to use HTML::Parse
+from CPAN (part of the libwww-perl distribution, which is a must-have
+module for all web hackers).
+
+Many folks attempt a simple-minded regular expression approach, like
+C<s/E<lt>.*?E<gt>//g>, but that fails in many cases because the tags
+may continue over line breaks, they may contain quoted angle-brackets,
+or HTML comment may be present. Plus folks forget to convert
+entities, like C<&lt;> for example.
+
+Here's one "simple-minded" approach, that works for most files:
+
+ #!/usr/bin/perl -p0777
+ s/<(?:[^>'"]*|(['"]).*?\1)*>//gs
+
+If you want a more complete solution, see the 3-stage striphtml
+program in
+http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/striphtml.gz
+.
+
+Here are some tricky cases that you should think about when picking
+a solution:
+
+ <IMG SRC = "foo.gif" ALT = "A > B">
+
+ <IMG SRC = "foo.gif"
+ ALT = "A > B">
+
+ <!-- <A comment> -->
+
+ <script>if (a<b && a>c)</script>
+
+ <# Just data #>
+
+ <![INCLUDE CDATA [ >>>>>>>>>>>> ]]>
+
+If HTML comments include other tags, those solutions would also break
+on text like this:
+
+ <!-- This section commented out.
+ <B>You can't see me!</B>
+ -->
+
+=head2 How do I extract URLs?
+
+A quick but imperfect approach is
+
+ #!/usr/bin/perl -n00
+ # qxurl - tchrist@perl.com
+ print "$2\n" while m{
+ < \s*
+ A \s+ HREF \s* = \s* (["']) (.*?) \1
+ \s* >
+ }gsix;
+
+This version does not adjust relative URLs, understand alternate
+bases, deal with HTML comments, deal with HREF and NAME attributes in
+the same tag, or accept URLs themselves as arguments. It also runs
+about 100x faster than a more "complete" solution using the LWP suite
+of modules, such as the
+http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/xurl.gz
+program.
+
+=head2 How do I download a file from the user's machine? How do I open a file on another machine?
+
+In the context of an HTML form, you can use what's known as
+B<multipart/form-data> encoding. The CGI.pm module (available from
+CPAN) supports this in the start_multipart_form() method, which isn't
+the same as the startform() method.
+
+=head2 How do I make a pop-up menu in HTML?
+
+Use the B<E<lt>SELECTE<gt>> and B<E<lt>OPTIONE<gt>> tags. The CGI.pm
+module (available from CPAN) supports this widget, as well as many
+others, including some that it cleverly synthesizes on its own.
+
+=head2 How do I fetch an HTML file?
+
+One approach, if you have the lynx text-based HTML browser installed
+on your system, is this:
+
+ $html_code = `lynx -source $url`;
+ $text_data = `lynx -dump $url`;
+
+The libwww-perl (LWP) modules from CPAN provide a more powerful way to
+do this. They work through proxies, and don't require lynx:
+
+ # simplest version
+ use LWP::Simple;
+ $content = get($URL);
+
+ # or print HTML from a URL
+ use LWP::Simple;
+ getprint "http://www.sn.no/libwww-perl/";
+
+ # or print ASCII from HTML from a URL
+ use LWP::Simple;
+ use HTML::Parse;
+ use HTML::FormatText;
+ my ($html, $ascii);
+ $html = get("http://www.perl.com/");
+ defined $html
+ or die "Can't fetch HTML from http://www.perl.com/";
+ $ascii = HTML::FormatText->new->format(parse_html($html));
+ print $ascii;
+
+=head2 How do I automate an HTML form submission?
+
+If you're submitting values using the GET method, create a URL and encode
+the form using the C<query_form> method:
+
+ use LWP::Simple;
+ use URI::URL;
+
+ my $url = url('http://www.perl.com/cgi-bin/cpan_mod');
+ $url->query_form(module => 'DB_File', readme => 1);
+ $content = get($url);
+
+If you're using the POST method, create your own user agent and encode
+the content appropriately.
+
+ use HTTP::Request::Common qw(POST);
+ use LWP::UserAgent;
+
+ $ua = LWP::UserAgent->new();
+ my $req = POST 'http://www.perl.com/cgi-bin/cpan_mod',
+ [ module => 'DB_File', readme => 1 ];
+ $content = $ua->request($req)->as_string;
+
+=head2 How do I decode or create those %-encodings on the web?
+
+Here's an example of decoding:
+
+ $string = "http://altavista.digital.com/cgi-bin/query?pg=q&what=news&fmt=.&q=%2Bcgi-bin+%2Bperl.exe";
+ $string =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge;
+
+Encoding is a bit harder, because you can't just blindly change
+all the non-alphanumunder character (C<\W>) into their hex escapes.
+It's important that characters with special meaning like C</> and C<?>
+I<not> be translated. Probably the easiest way to get this right is
+to avoid reinventing the wheel and just use the URI::Escape module,
+which is part of the libwww-perl package (LWP) available from CPAN.
+
+=head2 How do I redirect to another page?
+
+Instead of sending back a C<Content-Type> as the headers of your
+reply, send back a C<Location:> header. Officially this should be a
+C<URI:> header, so the CGI.pm module (available from CPAN) sends back
+both:
+
+ Location: http://www.domain.com/newpage
+ URI: http://www.domain.com/newpage
+
+Note that relative URLs in these headers can cause strange effects
+because of "optimizations" that servers do.
+
+ $url = "http://www.perl.com/CPAN/";
+ print "Location: $url\n\n";
+ exit;
+
+To be correct to the spec, each of those C<"\n">
+should really each be C<"\015\012">, but unless you're
+stuck on MacOS, you probably won't notice.
+
+=head2 How do I put a password on my web pages?
+
+That depends. You'll need to read the documentation for your web
+server, or perhaps check some of the other FAQs referenced above.
+
+=head2 How do I edit my .htpasswd and .htgroup files with Perl?
+
+The HTTPD::UserAdmin and HTTPD::GroupAdmin modules provide a
+consistent OO interface to these files, regardless of how they're
+stored. Databases may be text, dbm, Berkley DB or any database with a
+DBI compatible driver. HTTPD::UserAdmin supports files used by the
+`Basic' and `Digest' authentication schemes. Here's an example:
+
+ use HTTPD::UserAdmin ();
+ HTTPD::UserAdmin
+ ->new(DB => "/foo/.htpasswd")
+ ->add($username => $password);
+
+=head2 How do I make sure users can't enter values into a form that cause my CGI script to do bad things?
+
+Read the CGI security FAQ, at
+http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html, and the
+Perl/CGI FAQ at
+http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html.
+
+In brief: use tainting (see L<perlsec>), which makes sure that data
+from outside your script (eg, CGI parameters) are never used in
+C<eval> or C<system> calls. In addition to tainting, never use the
+single-argument form of system() or exec(). Instead, supply the
+command and arguments as a list, which prevents shell globbing.
+
+=head2 How do I parse a mail header?
+
+For a quick-and-dirty solution, try this solution derived
+from page 222 of the 2nd edition of "Programming Perl":
+
+ $/ = '';
+ $header = <MSG>;
+ $header =~ s/\n\s+/ /g; # merge continuation lines
+ %head = ( UNIX_FROM_LINE, split /^([-\w]+):\s*/m, $header );
+
+That solution doesn't do well if, for example, you're trying to
+maintain all the Received lines. A more complete approach is to use
+the Mail::Header module from CPAN (part of the MailTools package).
+
+=head2 How do I decode a CGI form?
+
+You use a standard module, probably CGI.pm. Under no circumstances
+should you attempt to do so by hand!
+
+You'll see a lot of CGI programs that blindly read from STDIN the number
+of bytes equal to CONTENT_LENGTH for POSTs, or grab QUERY_STRING for
+decoding GETs. These programs are very poorly written. They only work
+sometimes. They typically forget to check the return value of the read()
+system call, which is a cardinal sin. They don't handle HEAD requests.
+They don't handle multipart forms used for file uploads. They don't deal
+with GET/POST combinations where query fields are in more than one place.
+They don't deal with keywords in the query string.
+
+In short, they're bad hacks. Resist them at all costs. Please do not be
+tempted to reinvent the wheel. Instead, use the CGI.pm or CGI_Lite.pm
+(available from CPAN), or if you're trapped in the module-free land
+of perl1 .. perl4, you might look into cgi-lib.pl (available from
+http://www.bio.cam.ac.uk/web/form.html).
+
+Make sure you know whether to use a GET or a POST in your form.
+GETs should only be used for something that doesn't update the server.
+Otherwise you can get mangled databases and repeated feedback mail
+messages. The fancy word for this is ``idempotency''. This simply
+means that there should be no difference between making a GET request
+for a particular URL once or multiple times. This is because the
+HTTP protocol definition says that a GET request may be cached by the
+browser, or server, or an intervening proxy. POST requests cannot be
+cached, because each request is independent and matters. Typically,
+POST requests change or depend on state on the server (query or update
+a database, send mail, or purchase a computer).
+
+=head2 How do I check a valid mail address?
+
+You can't, at least, not in real time. Bummer, eh?
+
+Without sending mail to the address and seeing whether there's a human
+on the other hand to answer you, you cannot determine whether a mail
+address is valid. Even if you apply the mail header standard, you
+can have problems, because there are deliverable addresses that aren't
+RFC-822 (the mail header standard) compliant, and addresses that aren't
+deliverable which are compliant.
+
+Many are tempted to try to eliminate many frequently-invalid
+mail addresses with a simple regexp, such as
+C</^[\w.-]+\@([\w.-]\.)+\w+$/>. It's a very bad idea. However,
+this also throws out many valid ones, and says nothing about
+potential deliverability, so is not suggested. Instead, see
+http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/ckaddr.gz ,
+which actually checks against the full RFC spec (except for nested
+comments), looks for addresses you may not wish to accept mail to
+(say, Bill Clinton or your postmaster), and then makes sure that the
+hostname given can be looked up in the DNS MX records. It's not fast,
+but it works for what it tries to do.
+
+Our best advice for verifying a person's mail address is to have them
+enter their address twice, just as you normally do to change a password.
+This usually weeds out typos. If both versions match, send
+mail to that address with a personal message that looks somewhat like:
+
+ Dear someuser@host.com,
+
+ Please confirm the mail address you gave us Wed May 6 09:38:41
+ MDT 1998 by replying to this message. Include the string
+ "Rumpelstiltskin" in that reply, but spelled in reverse; that is,
+ start with "Nik...". Once this is done, your confirmed address will
+ be entered into our records.
+
+If you get the message back and they've followed your directions,
+you can be reasonably assured that it's real.
+
+A related strategy that's less open to forgery is to give them a PIN
+(personal ID number). Record the address and PIN (best that it be a
+random one) for later processing. In the mail you send, ask them to
+include the PIN in their reply. But if it bounces, or the message is
+included via a ``vacation'' script, it'll be there anyway. So it's
+best to ask them to mail back a slight alteration of the PIN, such as
+with the characters reversed, one added or subtracted to each digit, etc.
+
+=head2 How do I decode a MIME/BASE64 string?
+
+The MIME-tools package (available from CPAN) handles this and a lot
+more. Decoding BASE64 becomes as simple as:
+
+ use MIME::base64;
+ $decoded = decode_base64($encoded);
+
+A more direct approach is to use the unpack() function's "u"
+format after minor transliterations:
+
+ tr#A-Za-z0-9+/##cd; # remove non-base64 chars
+ tr#A-Za-z0-9+/# -_#; # convert to uuencoded format
+ $len = pack("c", 32 + 0.75*length); # compute length byte
+ print unpack("u", $len . $_); # uudecode and print
+
+=head2 How do I return the user's mail address?
+
+On systems that support getpwuid, the $E<lt> variable and the
+Sys::Hostname module (which is part of the standard perl distribution),
+you can probably try using something like this:
+
+ use Sys::Hostname;
+ $address = sprintf('%s@%s', getpwuid($<), hostname);
+
+Company policies on mail address can mean that this generates addresses
+that the company's mail system will not accept, so you should ask for
+users' mail addresses when this matters. Furthermore, not all systems
+on which Perl runs are so forthcoming with this information as is Unix.
+
+The Mail::Util module from CPAN (part of the MailTools package) provides a
+mailaddress() function that tries to guess the mail address of the user.
+It makes a more intelligent guess than the code above, using information
+given when the module was installed, but it could still be incorrect.
+Again, the best way is often just to ask the user.
+
+=head2 How do I send mail?
+
+Use the C<sendmail> program directly:
+
+ open(SENDMAIL, "|/usr/lib/sendmail -oi -t -odq")
+ or die "Can't fork for sendmail: $!\n";
+ print SENDMAIL <<"EOF";
+ From: User Originating Mail <me\@host>
+ To: Final Destination <you\@otherhost>
+ Subject: A relevant subject line
+
+ Body of the message goes here, in as many lines as you like.
+ EOF
+ close(SENDMAIL) or warn "sendmail didn't close nicely";
+
+The B<-oi> option prevents sendmail from interpreting a line consisting
+of a single dot as "end of message". The B<-t> option says to use the
+headers to decide who to send the message to, and B<-odq> says to put
+the message into the queue. This last option means your message won't
+be immediately delivered, so leave it out if you want immediate
+delivery.
+
+Or use the CPAN module Mail::Mailer:
+
+ use Mail::Mailer;
+
+ $mailer = Mail::Mailer->new();
+ $mailer->open({ From => $from_address,
+ To => $to_address,
+ Subject => $subject,
+ })
+ or die "Can't open: $!\n";
+ print $mailer $body;
+ $mailer->close();
+
+The Mail::Internet module uses Net::SMTP which is less Unix-centric than
+Mail::Mailer, but less reliable. Avoid raw SMTP commands. There
+are many reasons to use a mail transport agent like sendmail. These
+include queueing, MX records, and security.
+
+=head2 How do I read mail?
+
+Use the Mail::Folder module from CPAN
+(part of the MailFolder package) or the Mail::Internet module from
+CPAN (also part of the MailTools package).
+
+ # sending mail
+ use Mail::Internet;
+ use Mail::Header;
+ # say which mail host to use
+ $ENV{SMTPHOSTS} = 'mail.frii.com';
+ # create headers
+ $header = new Mail::Header;
+ $header->add('From', 'gnat@frii.com');
+ $header->add('Subject', 'Testing');
+ $header->add('To', 'gnat@frii.com');
+ # create body
+ $body = 'This is a test, ignore';
+ # create mail object
+ $mail = new Mail::Internet(undef, Header => $header, Body => \[$body]);
+ # send it
+ $mail->smtpsend or die;
+
+Often a module is overkill, though. Here's a mail sorter.
+
+ #!/usr/bin/perl
+ # bysub1 - simple sort by subject
+ my(@msgs, @sub);
+ my $msgno = -1;
+ $/ = ''; # paragraph reads
+ while (<>) {
+ if (/^From/m) {
+ /^Subject:\s*(?:Re:\s*)*(.*)/mi;
+ $sub[++$msgno] = lc($1) || '';
+ }
+ $msgs[$msgno] .= $_;
+ }
+ for my $i (sort { $sub[$a] cmp $sub[$b] || $a <=> $b } (0 .. $#msgs)) {
+ print $msgs[$i];
+ }
+
+Or more succinctly,
+
+ #!/usr/bin/perl -n00
+ # bysub2 - awkish sort-by-subject
+ BEGIN { $msgno = -1 }
+ $sub[++$msgno] = (/^Subject:\s*(?:Re:\s*)*(.*)/mi)[0] if /^From/m;
+ $msg[$msgno] .= $_;
+ END { print @msg[ sort { $sub[$a] cmp $sub[$b] || $a <=> $b } (0 .. $#msg) ] }
+
+=head2 How do I find out my hostname/domainname/IP address?
+
+The normal way to find your own hostname is to call the C<`hostname`>
+program. While sometimes expedient, this has some problems, such as
+not knowing whether you've got the canonical name or not. It's one of
+those tradeoffs of convenience versus portability.
+
+The Sys::Hostname module (part of the standard perl distribution) will
+give you the hostname after which you can find out the IP address
+(assuming you have working DNS) with a gethostbyname() call.
+
+ use Socket;
+ use Sys::Hostname;
+ my $host = hostname();
+ my $addr = inet_ntoa(scalar(gethostbyname($name)) || 'localhost');
+
+Probably the simplest way to learn your DNS domain name is to grok
+it out of /etc/resolv.conf, at least under Unix. Of course, this
+assumes several things about your resolv.conf configuration, including
+that it exists.
+
+(We still need a good DNS domain name-learning method for non-Unix
+systems.)
+
+=head2 How do I fetch a news article or the active newsgroups?
+
+Use the Net::NNTP or News::NNTPClient modules, both available from CPAN.
+This can make tasks like fetching the newsgroup list as simple as:
+
+ perl -MNews::NNTPClient
+ -e 'print News::NNTPClient->new->list("newsgroups")'
+
+=head2 How do I fetch/put an FTP file?
+
+LWP::Simple (available from CPAN) can fetch but not put. Net::FTP (also
+available from CPAN) is more complex but can put as well as fetch.
+
+=head2 How can I do RPC in Perl?
+
+A DCE::RPC module is being developed (but is not yet available), and
+will be released as part of the DCE-Perl package (available from
+CPAN). No ONC::RPC module is known.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997, 1998 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+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 I<outside>
+of that package require that special arrangements be made with
+copyright holder.
+
+Irrespective of its distribution, all code examples in this file
+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.
diff --git a/contrib/perl5/pod/perlform.pod b/contrib/perl5/pod/perlform.pod
new file mode 100644
index 000000000000..6b65e0430310
--- /dev/null
+++ b/contrib/perl5/pod/perlform.pod
@@ -0,0 +1,337 @@
+=head1 NAME
+
+perlform - Perl formats
+
+=head1 DESCRIPTION
+
+Perl has a mechanism to help you generate simple reports and charts. To
+facilitate this, Perl helps you code up your output page close to how it
+will look when it's printed. It can keep track of things like how many
+lines are on a page, what page you're on, when to print page headers,
+etc. Keywords are borrowed from FORTRAN: format() to declare and write()
+to execute; see their entries in L<perlfunc>. Fortunately, the layout is
+much more legible, more like BASIC's PRINT USING statement. Think of it
+as a poor man's nroff(1).
+
+Formats, like packages and subroutines, are declared rather than
+executed, so they may occur at any point in your program. (Usually it's
+best to keep them all together though.) They have their own namespace
+apart from all the other "types" in Perl. This means that if you have a
+function named "Foo", it is not the same thing as having a format named
+"Foo". However, the default name for the format associated with a given
+filehandle is the same as the name of the filehandle. Thus, the default
+format for STDOUT is named "STDOUT", and the default format for filehandle
+TEMP is named "TEMP". They just look the same. They aren't.
+
+Output record formats are declared as follows:
+
+ format NAME =
+ FORMLIST
+ .
+
+If name is omitted, format "STDOUT" is defined. FORMLIST consists of
+a sequence of lines, each of which may be one of three types:
+
+=over 4
+
+=item 1.
+
+A comment, indicated by putting a '#' in the first column.
+
+=item 2.
+
+A "picture" line giving the format for one output line.
+
+=item 3.
+
+An argument line supplying values to plug into the previous picture line.
+
+=back
+
+Picture lines are printed exactly as they look, except for certain fields
+that substitute values into the line. Each field in a picture line starts
+with either "@" (at) or "^" (caret). These lines do not undergo any kind
+of variable interpolation. The at field (not to be confused with the array
+marker @) is the normal kind of field; the other kind, caret fields, are used
+to do rudimentary multi-line text block filling. The length of the field
+is supplied by padding out the field with multiple "E<lt>", "E<gt>", or "|"
+characters to specify, respectively, left justification, right
+justification, or centering. If the variable would exceed the width
+specified, it is truncated.
+
+As an alternate form of right justification, you may also use "#"
+characters (with an optional ".") to specify a numeric field. This way
+you can line up the decimal points. If any value supplied for these
+fields contains a newline, only the text up to the newline is printed.
+Finally, the special field "@*" can be used for printing multi-line,
+nontruncated values; it should appear by itself on a line.
+
+The values are specified on the following line in the same order as
+the picture fields. The expressions providing the values should be
+separated by commas. The expressions are all evaluated in a list context
+before the line is processed, so a single list expression could produce
+multiple list elements. The expressions may be spread out to more than
+one line if enclosed in braces. If so, the opening brace must be the first
+token on the first line. If an expression evaluates to a number with a
+decimal part, and if the corresponding picture specifies that the decimal
+part should appear in the output (that is, any picture except multiple "#"
+characters B<without> an embedded "."), the character used for the decimal
+point is B<always> determined by the current LC_NUMERIC locale. This
+means that, if, for example, the run-time environment happens to specify a
+German locale, "," will be used instead of the default ".". See
+L<perllocale> and L<"WARNINGS"> for more information.
+
+Picture fields that begin with ^ rather than @ are treated specially.
+With a # field, the field is blanked out if the value is undefined. For
+other field types, the caret enables a kind of fill mode. Instead of an
+arbitrary expression, the value supplied must be a scalar variable name
+that contains a text string. Perl puts as much text as it can into the
+field, and then chops off the front of the string so that the next time
+the variable is referenced, more of the text can be printed. (Yes, this
+means that the variable itself is altered during execution of the write()
+call, and is not returned.) Normally you would use a sequence of fields
+in a vertical stack to print out a block of text. You might wish to end
+the final field with the text "...", which will appear in the output if
+the text was too long to appear in its entirety. You can change which
+characters are legal to break on by changing the variable C<$:> (that's
+$FORMAT_LINE_BREAK_CHARACTERS if you're using the English module) to a
+list of the desired characters.
+
+Using caret fields can produce variable length records. If the text
+to be formatted is short, you can suppress blank lines by putting a
+"~" (tilde) character anywhere in the line. The tilde will be translated
+to a space upon output. If you put a second tilde contiguous to the
+first, the line will be repeated until all the fields on the line are
+exhausted. (If you use a field of the at variety, the expression you
+supply had better not give the same value every time forever!)
+
+Top-of-form processing is by default handled by a format with the
+same name as the current filehandle with "_TOP" concatenated to it.
+It's triggered at the top of each page. See L<perlfunc/write>.
+
+Examples:
+
+ # a report on the /etc/passwd file
+ format STDOUT_TOP =
+ Passwd File
+ Name Login Office Uid Gid Home
+ ------------------------------------------------------------------
+ .
+ format STDOUT =
+ @<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<<
+ $name, $login, $office,$uid,$gid, $home
+ .
+
+
+ # a report from a bug report form
+ format STDOUT_TOP =
+ Bug Reports
+ @<<<<<<<<<<<<<<<<<<<<<<< @||| @>>>>>>>>>>>>>>>>>>>>>>>
+ $system, $%, $date
+ ------------------------------------------------------------------
+ .
+ format STDOUT =
+ Subject: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $subject
+ Index: @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $index, $description
+ Priority: @<<<<<<<<<< Date: @<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $priority, $date, $description
+ From: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $from, $description
+ Assigned to: @<<<<<<<<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $programmer, $description
+ ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $description
+ ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $description
+ ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $description
+ ~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $description
+ ~ ^<<<<<<<<<<<<<<<<<<<<<<<...
+ $description
+ .
+
+It is possible to intermix print()s with write()s on the same output
+channel, but you'll have to handle C<$-> (C<$FORMAT_LINES_LEFT>)
+yourself.
+
+=head2 Format Variables
+
+The current format name is stored in the variable C<$~> (C<$FORMAT_NAME>),
+and the current top of form format name is in C<$^> (C<$FORMAT_TOP_NAME>).
+The current output page number is stored in C<$%> (C<$FORMAT_PAGE_NUMBER>),
+and the number of lines on the page is in C<$=> (C<$FORMAT_LINES_PER_PAGE>).
+Whether to autoflush output on this handle is stored in C<$|>
+(C<$OUTPUT_AUTOFLUSH>). The string output before each top of page (except
+the first) is stored in C<$^L> (C<$FORMAT_FORMFEED>). These variables are
+set on a per-filehandle basis, so you'll need to select() into a different
+one to affect them:
+
+ select((select(OUTF),
+ $~ = "My_Other_Format",
+ $^ = "My_Top_Format"
+ )[0]);
+
+Pretty ugly, eh? It's a common idiom though, so don't be too surprised
+when you see it. You can at least use a temporary variable to hold
+the previous filehandle: (this is a much better approach in general,
+because not only does legibility improve, you now have intermediary
+stage in the expression to single-step the debugger through):
+
+ $ofh = select(OUTF);
+ $~ = "My_Other_Format";
+ $^ = "My_Top_Format";
+ select($ofh);
+
+If you use the English module, you can even read the variable names:
+
+ use English;
+ $ofh = select(OUTF);
+ $FORMAT_NAME = "My_Other_Format";
+ $FORMAT_TOP_NAME = "My_Top_Format";
+ select($ofh);
+
+But you still have those funny select()s. So just use the FileHandle
+module. Now, you can access these special variables using lowercase
+method names instead:
+
+ use FileHandle;
+ format_name OUTF "My_Other_Format";
+ format_top_name OUTF "My_Top_Format";
+
+Much better!
+
+=head1 NOTES
+
+Because the values line may contain arbitrary expressions (for at fields,
+not caret fields), you can farm out more sophisticated processing
+to other functions, like sprintf() or one of your own. For example:
+
+ format Ident =
+ @<<<<<<<<<<<<<<<
+ &commify($n)
+ .
+
+To get a real at or caret into the field, do this:
+
+ format Ident =
+ I have an @ here.
+ "@"
+ .
+
+To center a whole line of text, do something like this:
+
+ format Ident =
+ @|||||||||||||||||||||||||||||||||||||||||||||||
+ "Some text line"
+ .
+
+There is no builtin way to say "float this to the right hand side
+of the page, however wide it is." You have to specify where it goes.
+The truly desperate can generate their own format on the fly, based
+on the current number of columns, and then eval() it:
+
+ $format = "format STDOUT = \n"
+ . '^' . '<' x $cols . "\n"
+ . '$entry' . "\n"
+ . "\t^" . "<" x ($cols-8) . "~~\n"
+ . '$entry' . "\n"
+ . ".\n";
+ print $format if $Debugging;
+ eval $format;
+ die $@ if $@;
+
+Which would generate a format looking something like this:
+
+ format STDOUT =
+ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $entry
+ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
+ $entry
+ .
+
+Here's a little program that's somewhat like fmt(1):
+
+ format =
+ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
+ $_
+
+ .
+
+ $/ = '';
+ while (<>) {
+ s/\s*\n\s*/ /g;
+ write;
+ }
+
+=head2 Footers
+
+While $FORMAT_TOP_NAME contains the name of the current header format,
+there is no corresponding mechanism to automatically do the same thing
+for a footer. Not knowing how big a format is going to be until you
+evaluate it is one of the major problems. It's on the TODO list.
+
+Here's one strategy: If you have a fixed-size footer, you can get footers
+by checking $FORMAT_LINES_LEFT before each write() and print the footer
+yourself if necessary.
+
+Here's another strategy: Open a pipe to yourself, using C<open(MYSELF, "|-")>
+(see L<perlfunc/open()>) and always write() to MYSELF instead of STDOUT.
+Have your child process massage its STDIN to rearrange headers and footers
+however you like. Not very convenient, but doable.
+
+=head2 Accessing Formatting Internals
+
+For low-level access to the formatting mechanism. you may use formline()
+and access C<$^A> (the $ACCUMULATOR variable) directly.
+
+For example:
+
+ $str = formline <<'END', 1,2,3;
+ @<<< @||| @>>>
+ END
+
+ print "Wow, I just stored `$^A' in the accumulator!\n";
+
+Or to make an swrite() subroutine, which is to write() what sprintf()
+is to printf(), do this:
+
+ use Carp;
+ sub swrite {
+ croak "usage: swrite PICTURE ARGS" unless @_;
+ my $format = shift;
+ $^A = "";
+ formline($format,@_);
+ return $^A;
+ }
+
+ $string = swrite(<<'END', 1, 2, 3);
+ Check me out
+ @<<< @||| @>>>
+ END
+ print $string;
+
+=head1 WARNINGS
+
+The lone dot that ends a format can also prematurely end a mail
+message passing through a misconfigured Internet mailer (and based on
+experience, such misconfiguration is the rule, not the exception). So
+when sending format code through mail, you should indent it so that
+the format-ending dot is not on the left margin; this will prevent
+SMTP cutoff.
+
+Lexical variables (declared with "my") are not visible within a
+format unless the format is declared within the scope of the lexical
+variable. (They weren't visible at all before version 5.001.)
+
+Formats are the only part of Perl that unconditionally use information
+from a program's locale; if a program's environment specifies an
+LC_NUMERIC locale, it is always used to specify the decimal point
+character in formatted output. Perl ignores all other aspects of locale
+handling unless the C<use locale> pragma is in effect. Formatted output
+cannot be controlled by C<use locale> because the pragma is tied to the
+block structure of the program, and, for historical reasons, formats
+exist outside that block structure. See L<perllocale> for further
+discussion of locale handling.
diff --git a/contrib/perl5/pod/perlfunc.pod b/contrib/perl5/pod/perlfunc.pod
new file mode 100644
index 000000000000..4eac093b0e02
--- /dev/null
+++ b/contrib/perl5/pod/perlfunc.pod
@@ -0,0 +1,4440 @@
+=head1 NAME
+
+perlfunc - Perl builtin functions
+
+=head1 DESCRIPTION
+
+The functions in this section can serve as terms in an expression.
+They fall into two major categories: list operators and named unary
+operators. These differ in their precedence relationship with a
+following comma. (See the precedence table in L<perlop>.) List
+operators take more than one argument, while unary operators can never
+take more than one argument. Thus, a comma terminates the argument of
+a unary operator, but merely separates the arguments of a list
+operator. A unary operator generally provides a scalar context to its
+argument, while a list operator may provide either scalar and list
+contexts for its arguments. If it does both, the scalar arguments will
+be first, and the list argument will follow. (Note that there can ever
+be only one list argument.) For instance, splice() has three scalar
+arguments followed by a list.
+
+In the syntax descriptions that follow, list operators that expect a
+list (and provide list context for the elements of the list) are shown
+with LIST as an argument. Such a list may consist of any combination
+of scalar arguments or list values; the list values will be included
+in the list as if each individual element were interpolated at that
+point in the list, forming a longer single-dimensional list value.
+Elements of the LIST should be separated by commas.
+
+Any function in the list below may be used either with or without
+parentheses around its arguments. (The syntax descriptions omit the
+parentheses.) If you use the parentheses, the simple (but occasionally
+surprising) rule is this: It I<LOOKS> like a function, therefore it I<IS> a
+function, and precedence doesn't matter. Otherwise it's a list
+operator or unary operator, and precedence does matter. And whitespace
+between the function and left parenthesis doesn't count--so you need to
+be careful sometimes:
+
+ print 1+2+4; # Prints 7.
+ print(1+2) + 4; # Prints 3.
+ print (1+2)+4; # Also prints 3!
+ print +(1+2)+4; # Prints 7.
+ print ((1+2)+4); # Prints 7.
+
+If you run Perl with the B<-w> switch it can warn you about this. For
+example, the third line above produces:
+
+ print (...) interpreted as function at - line 1.
+ Useless use of integer addition in void context at - line 1.
+
+For functions that can be used in either a scalar or list context,
+nonabortive failure is generally indicated in a scalar context by
+returning the undefined value, and in a list context by returning the
+null list.
+
+Remember the following important rule: There is B<no rule> that relates
+the behavior of an expression in list context to its behavior in scalar
+context, or vice versa. It might do two totally different things.
+Each operator and function decides which sort of value it would be most
+appropriate to return in a scalar context. Some operators return the
+length of the list that would have been returned in list context. Some
+operators return the first value in the list. Some operators return the
+last value in the list. Some operators return a count of successful
+operations. In general, they do what you want, unless you want
+consistency.
+
+An named array in scalar context is quite different from what would at
+first glance appear to be a list in scalar context. You can't get a list
+like C<(1,2,3)> into being in scalar context, because the compiler knows
+the context at compile time. It would generate the scalar comma operator
+there, not the list construction version of the comma. That means it
+was never a list to start with.
+
+In general, functions in Perl that serve as wrappers for system calls
+of the same name (like chown(2), fork(2), closedir(2), etc.) all return
+true when they succeed and C<undef> otherwise, as is usually mentioned
+in the descriptions below. This is different from the C interfaces,
+which return C<-1> on failure. Exceptions to this rule are C<wait()>,
+C<waitpid()>, and C<syscall()>. System calls also set the special C<$!>
+variable on failure. Other functions do not, except accidentally.
+
+=head2 Perl Functions by Category
+
+Here are Perl's functions (including things that look like
+functions, like some keywords and named operators)
+arranged by category. Some functions appear in more
+than one place.
+
+=over
+
+=item Functions for SCALARs or strings
+
+C<chomp>, C<chop>, C<chr>, C<crypt>, C<hex>, C<index>, C<lc>, C<lcfirst>,
+C<length>, C<oct>, C<ord>, C<pack>, C<q/STRING/>, C<qq/STRING/>, C<reverse>,
+C<rindex>, C<sprintf>, C<substr>, C<tr///>, C<uc>, C<ucfirst>, C<y///>
+
+=item Regular expressions and pattern matching
+
+C<m//>, C<pos>, C<quotemeta>, C<s///>, C<split>, C<study>, C<qr//>
+
+=item Numeric functions
+
+C<abs>, C<atan2>, C<cos>, C<exp>, C<hex>, C<int>, C<log>, C<oct>, C<rand>,
+C<sin>, C<sqrt>, C<srand>
+
+=item Functions for real @ARRAYs
+
+C<pop>, C<push>, C<shift>, C<splice>, C<unshift>
+
+=item Functions for list data
+
+C<grep>, C<join>, C<map>, C<qw/STRING/>, C<reverse>, C<sort>, C<unpack>
+
+=item Functions for real %HASHes
+
+C<delete>, C<each>, C<exists>, C<keys>, C<values>
+
+=item Input and output functions
+
+C<binmode>, C<close>, C<closedir>, C<dbmclose>, C<dbmopen>, C<die>, C<eof>,
+C<fileno>, C<flock>, C<format>, C<getc>, C<print>, C<printf>, C<read>,
+C<readdir>, C<rewinddir>, C<seek>, C<seekdir>, C<select>, C<syscall>,
+C<sysread>, C<sysseek>, C<syswrite>, C<tell>, C<telldir>, C<truncate>,
+C<warn>, C<write>
+
+=item Functions for fixed length data or records
+
+C<pack>, C<read>, C<syscall>, C<sysread>, C<syswrite>, C<unpack>, C<vec>
+
+=item Functions for filehandles, files, or directories
+
+C<-I<X>>, C<chdir>, C<chmod>, C<chown>, C<chroot>, C<fcntl>, C<glob>,
+C<ioctl>, C<link>, C<lstat>, C<mkdir>, C<open>, C<opendir>, C<readlink>,
+C<rename>, C<rmdir>, C<stat>, C<symlink>, C<umask>, C<unlink>, C<utime>
+
+=item Keywords related to the control flow of your perl program
+
+C<caller>, C<continue>, C<die>, C<do>, C<dump>, C<eval>, C<exit>,
+C<goto>, C<last>, C<next>, C<redo>, C<return>, C<sub>, C<wantarray>
+
+=item Keywords related to scoping
+
+C<caller>, C<import>, C<local>, C<my>, C<package>, C<use>
+
+=item Miscellaneous functions
+
+C<defined>, C<dump>, C<eval>, C<formline>, C<local>, C<my>, C<reset>,
+C<scalar>, C<undef>, C<wantarray>
+
+=item Functions for processes and process groups
+
+C<alarm>, C<exec>, C<fork>, C<getpgrp>, C<getppid>, C<getpriority>, C<kill>,
+C<pipe>, C<qx/STRING/>, C<setpgrp>, C<setpriority>, C<sleep>, C<system>,
+C<times>, C<wait>, C<waitpid>
+
+=item Keywords related to perl modules
+
+C<do>, C<import>, C<no>, C<package>, C<require>, C<use>
+
+=item Keywords related to classes and object-orientedness
+
+C<bless>, C<dbmclose>, C<dbmopen>, C<package>, C<ref>, C<tie>, C<tied>,
+C<untie>, C<use>
+
+=item Low-level socket functions
+
+C<accept>, C<bind>, C<connect>, C<getpeername>, C<getsockname>,
+C<getsockopt>, C<listen>, C<recv>, C<send>, C<setsockopt>, C<shutdown>,
+C<socket>, C<socketpair>
+
+=item System V interprocess communication functions
+
+C<msgctl>, C<msgget>, C<msgrcv>, C<msgsnd>, C<semctl>, C<semget>, C<semop>,
+C<shmctl>, C<shmget>, C<shmread>, C<shmwrite>
+
+=item Fetching user and group info
+
+C<endgrent>, C<endhostent>, C<endnetent>, C<endpwent>, C<getgrent>,
+C<getgrgid>, C<getgrnam>, C<getlogin>, C<getpwent>, C<getpwnam>,
+C<getpwuid>, C<setgrent>, C<setpwent>
+
+=item Fetching network info
+
+C<endprotoent>, C<endservent>, C<gethostbyaddr>, C<gethostbyname>,
+C<gethostent>, C<getnetbyaddr>, C<getnetbyname>, C<getnetent>,
+C<getprotobyname>, C<getprotobynumber>, C<getprotoent>,
+C<getservbyname>, C<getservbyport>, C<getservent>, C<sethostent>,
+C<setnetent>, C<setprotoent>, C<setservent>
+
+=item Time-related functions
+
+C<gmtime>, C<localtime>, C<time>, C<times>
+
+=item Functions new in perl5
+
+C<abs>, C<bless>, C<chomp>, C<chr>, C<exists>, C<formline>, C<glob>,
+C<import>, C<lc>, C<lcfirst>, C<map>, C<my>, C<no>, C<prototype>, C<qx>,
+C<qw>, C<readline>, C<readpipe>, C<ref>, C<sub*>, C<sysopen>, C<tie>,
+C<tied>, C<uc>, C<ucfirst>, C<untie>, C<use>
+
+* - C<sub> was a keyword in perl4, but in perl5 it is an
+operator, which can be used in expressions.
+
+=item Functions obsoleted in perl5
+
+C<dbmclose>, C<dbmopen>
+
+=back
+
+=head2 Alphabetical Listing of Perl Functions
+
+=over 8
+
+=item I<-X> FILEHANDLE
+
+=item I<-X> EXPR
+
+=item I<-X>
+
+A file test, where X is one of the letters listed below. This unary
+operator takes one argument, either a filename or a filehandle, and
+tests the associated file to see if something is true about it. If the
+argument is omitted, tests C<$_>, except for C<-t>, which tests STDIN.
+Unless otherwise documented, it returns C<1> for TRUE and C<''> for FALSE, or
+the undefined value if the file doesn't exist. Despite the funny
+names, precedence is the same as any other named unary operator, and
+the argument may be parenthesized like any other unary operator. The
+operator may be any of:
+X<-r>X<-w>X<-x>X<-o>X<-R>X<-W>X<-X>X<-O>X<-e>X<-z>X<-s>X<-f>X<-d>X<-l>X<-p>
+X<-S>X<-b>X<-c>X<-t>X<-u>X<-g>X<-k>X<-T>X<-B>X<-M>X<-A>X<-C>
+
+ -r File is readable by effective uid/gid.
+ -w File is writable by effective uid/gid.
+ -x File is executable by effective uid/gid.
+ -o File is owned by effective uid.
+
+ -R File is readable by real uid/gid.
+ -W File is writable by real uid/gid.
+ -X File is executable by real uid/gid.
+ -O File is owned by real uid.
+
+ -e File exists.
+ -z File has zero size.
+ -s File has nonzero size (returns size).
+
+ -f File is a plain file.
+ -d File is a directory.
+ -l File is a symbolic link.
+ -p File is a named pipe (FIFO), or Filehandle is a pipe.
+ -S File is a socket.
+ -b File is a block special file.
+ -c File is a character special file.
+ -t Filehandle is opened to a tty.
+
+ -u File has setuid bit set.
+ -g File has setgid bit set.
+ -k File has sticky bit set.
+
+ -T File is a text file.
+ -B File is a binary file (opposite of -T).
+
+ -M Age of file in days when script started.
+ -A Same for access time.
+ -C Same for inode change time.
+
+The interpretation of the file permission operators C<-r>, C<-R>, C<-w>,
+C<-W>, C<-x>, and C<-X> is based solely on the mode of the file and the
+uids and gids of the user. There may be other reasons you can't actually
+read, write, or execute the file, such as AFS access control lists. Also note that, for the superuser,
+C<-r>, C<-R>, C<-w>, and C<-W> always return C<1>, and C<-x> and C<-X> return
+C<1> if any execute bit is set in the mode. Scripts run by the superuser may
+thus need to do a C<stat()> to determine the actual mode of the
+file, or temporarily set the uid to something else.
+
+Example:
+
+ while (<>) {
+ chop;
+ next unless -f $_; # ignore specials
+ #...
+ }
+
+Note that C<-s/a/b/> does not do a negated substitution. Saying
+C<-exp($foo)> still works as expected, however--only single letters
+following a minus are interpreted as file tests.
+
+The C<-T> and C<-B> switches work as follows. The first block or so of the
+file is examined for odd characters such as strange control codes or
+characters with the high bit set. If too many strange characters (E<gt>30%)
+are found, it's a C<-B> file, otherwise it's a C<-T> file. Also, any file
+containing null in the first block is considered a binary file. If C<-T>
+or C<-B> is used on a filehandle, the current stdio buffer is examined
+rather than the first block. Both C<-T> and C<-B> return TRUE on a null
+file, or a file at EOF when testing a filehandle. Because you have to
+read a file to do the C<-T> test, on most occasions you want to use a C<-f>
+against the file first, as in C<next unless -f $file && -T $file>.
+
+If any of the file tests (or either the C<stat()> or C<lstat()> operators) are given
+the special filehandle consisting of a solitary underline, then the stat
+structure of the previous file test (or stat operator) is used, saving
+a system call. (This doesn't work with C<-t>, and you need to remember
+that lstat() and C<-l> will leave values in the stat structure for the
+symbolic link, not the real file.) Example:
+
+ print "Can do.\n" if -r $a || -w _ || -x _;
+
+ stat($filename);
+ print "Readable\n" if -r _;
+ print "Writable\n" if -w _;
+ print "Executable\n" if -x _;
+ print "Setuid\n" if -u _;
+ print "Setgid\n" if -g _;
+ print "Sticky\n" if -k _;
+ print "Text\n" if -T _;
+ print "Binary\n" if -B _;
+
+=item abs VALUE
+
+=item abs
+
+Returns the absolute value of its argument.
+If VALUE is omitted, uses C<$_>.
+
+=item accept NEWSOCKET,GENERICSOCKET
+
+Accepts an incoming socket connect, just as the accept(2) system call
+does. Returns the packed address if it succeeded, FALSE otherwise.
+See example in L<perlipc/"Sockets: Client/Server Communication">.
+
+=item alarm SECONDS
+
+=item alarm
+
+Arranges to have a SIGALRM delivered to this process after the
+specified number of seconds have elapsed. If SECONDS is not specified,
+the value stored in C<$_> is used. (On some machines,
+unfortunately, the elapsed time may be up to one second less than you
+specified because of how seconds are counted.) Only one timer may be
+counting at once. Each call disables the previous timer, and an
+argument of C<0> may be supplied to cancel the previous timer without
+starting a new one. The returned value is the amount of time remaining
+on the previous timer.
+
+For delays of finer granularity than one second, you may use Perl's
+C<syscall()> interface to access setitimer(2) if your system supports it,
+or else see L</select()>. It is usually a mistake to intermix C<alarm()>
+and C<sleep()> calls.
+
+If you want to use C<alarm()> to time out a system call you need to use an
+C<eval()>/C<die()> pair. You can't rely on the alarm causing the system call to
+fail with C<$!> set to C<EINTR> because Perl sets up signal handlers to
+restart system calls on some systems. Using C<eval()>/C<die()> always works,
+modulo the caveats given in L<perlipc/"Signals">.
+
+ eval {
+ local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
+ alarm $timeout;
+ $nread = sysread SOCKET, $buffer, $size;
+ alarm 0;
+ };
+ if ($@) {
+ die unless $@ eq "alarm\n"; # propagate unexpected errors
+ # timed out
+ }
+ else {
+ # didn't
+ }
+
+=item atan2 Y,X
+
+Returns the arctangent of Y/X in the range -PI to PI.
+
+For the tangent operation, you may use the C<POSIX::tan()>
+function, or use the familiar relation:
+
+ sub tan { sin($_[0]) / cos($_[0]) }
+
+=item bind SOCKET,NAME
+
+Binds a network address to a socket, just as the bind system call
+does. Returns TRUE if it succeeded, FALSE otherwise. NAME should be a
+packed address of the appropriate type for the socket. See the examples in
+L<perlipc/"Sockets: Client/Server Communication">.
+
+=item binmode FILEHANDLE
+
+Arranges for the file to be read or written in "binary" mode in operating
+systems that distinguish between binary and text files. Files that are
+not in binary mode have CR LF sequences translated to LF on input and LF
+translated to CR LF on output. Binmode has no effect under Unix; in MS-DOS
+and similarly archaic systems, it may be imperative--otherwise your
+MS-DOS-damaged C library may mangle your file. The key distinction between
+systems that need C<binmode()> and those that don't is their text file
+formats. Systems like Unix, MacOS, and Plan9 that delimit lines with a single
+character, and that encode that character in C as C<"\n">, do not need
+C<binmode()>. The rest need it. If FILEHANDLE is an expression, the value
+is taken as the name of the filehandle.
+
+=item bless REF,CLASSNAME
+
+=item bless REF
+
+This function tells the thingy referenced by REF that it is now
+an object in the CLASSNAME package--or the current package if no CLASSNAME
+is specified, which is often the case. It returns the reference for
+convenience, because a C<bless()> is often the last thing in a constructor.
+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.
+
+=item caller EXPR
+
+=item caller
+
+Returns the context of the current subroutine call. In scalar context,
+returns the caller's package name if there is a caller, that is, if
+we're in a subroutine or C<eval()> or C<require()>, and the undefined value
+otherwise. In list context, returns
+
+ ($package, $filename, $line) = caller;
+
+With EXPR, it returns some extra information that the debugger uses to
+print a stack trace. The value of EXPR indicates how many call frames
+to go back before the current one.
+
+ ($package, $filename, $line, $subroutine,
+ $hasargs, $wantarray, $evaltext, $is_require) = caller($i);
+
+Here C<$subroutine> may be C<"(eval)"> if the frame is not a subroutine
+call, but an C<eval()>. In such a case additional elements C<$evaltext> and
+C<$is_require> are set: C<$is_require> is true if the frame is created by a
+C<require> or C<use> statement, C<$evaltext> contains the text of the
+C<eval EXPR> statement. In particular, for a C<eval BLOCK> statement,
+C<$filename> is C<"(eval)">, but C<$evaltext> is undefined. (Note also that
+each C<use> statement creates a C<require> frame inside an C<eval EXPR>)
+frame.
+
+Furthermore, when called from within the DB package, caller returns more
+detailed information: it sets the list variable C<@DB::args> to be the
+arguments with which the subroutine was invoked.
+
+Be aware that the optimizer might have optimized call frames away before
+C<caller()> had a chance to get the information. That means that C<caller(N)>
+might not return information about the call frame you expect it do, for
+C<N E<gt> 1>. In particular, C<@DB::args> might have information from the
+previous time C<caller()> was called.
+
+=item chdir EXPR
+
+Changes the working directory to EXPR, if possible. If EXPR is
+omitted, changes to home directory. Returns TRUE upon success, FALSE
+otherwise. See example under C<die()>.
+
+=item chmod LIST
+
+Changes the permissions of a list of files. The first element of the
+list must be the numerical mode, which should probably be an octal
+number, and which definitely should I<not> a string of octal digits:
+C<0644> is okay, C<'0644'> is not. Returns the number of files
+successfully changed. See also L</oct>, if all you have is a string.
+
+ $cnt = chmod 0755, 'foo', 'bar';
+ chmod 0755, @executables;
+ $mode = '0644'; chmod $mode, 'foo'; # !!! sets mode to
+ # --w----r-T
+ $mode = '0644'; chmod oct($mode), 'foo'; # this is better
+ $mode = 0644; chmod $mode, 'foo'; # this is best
+
+=item chomp VARIABLE
+
+=item chomp LIST
+
+=item chomp
+
+This is a slightly safer version of L</chop>. It removes any
+line ending that corresponds to the current value of C<$/> (also known as
+$INPUT_RECORD_SEPARATOR in the C<English> module). It returns the total
+number of characters removed from all its arguments. It's often used to
+remove the newline from the end of an input record when you're worried
+that the final record may be missing its newline. When in paragraph mode
+(C<$/ = "">), it removes all trailing newlines from the string. If
+VARIABLE is omitted, it chomps C<$_>. Example:
+
+ while (<>) {
+ chomp; # avoid \n on last field
+ @array = split(/:/);
+ # ...
+ }
+
+You can actually chomp anything that's an lvalue, including an assignment:
+
+ chomp($cwd = `pwd`);
+ chomp($answer = <STDIN>);
+
+If you chomp a list, each element is chomped, and the total number of
+characters removed is returned.
+
+=item chop VARIABLE
+
+=item chop LIST
+
+=item chop
+
+Chops off the last character of a string and returns the character
+chopped. It's used primarily to remove the newline from the end of an
+input record, but is much more efficient than C<s/\n//> because it neither
+scans nor copies the string. If VARIABLE is omitted, chops C<$_>.
+Example:
+
+ while (<>) {
+ chop; # avoid \n on last field
+ @array = split(/:/);
+ #...
+ }
+
+You can actually chop anything that's an lvalue, including an assignment:
+
+ chop($cwd = `pwd`);
+ chop($answer = <STDIN>);
+
+If you chop a list, each element is chopped. Only the value of the
+last C<chop()> is returned.
+
+Note that C<chop()> returns the last character. To return all but the last
+character, use C<substr($string, 0, -1)>.
+
+=item chown LIST
+
+Changes the owner (and group) of a list of files. The first two
+elements of the list must be the I<NUMERICAL> uid and gid, in that order.
+Returns the number of files successfully changed.
+
+ $cnt = chown $uid, $gid, 'foo', 'bar';
+ chown $uid, $gid, @filenames;
+
+Here's an example that looks up nonnumeric uids in the passwd file:
+
+ print "User: ";
+ chop($user = <STDIN>);
+ print "Files: ";
+ chop($pattern = <STDIN>);
+
+ ($login,$pass,$uid,$gid) = getpwnam($user)
+ or die "$user not in passwd file";
+
+ @ary = glob($pattern); # expand filenames
+ chown $uid, $gid, @ary;
+
+On most systems, you are not allowed to change the ownership of the
+file unless you're the superuser, although you should be able to change
+the group to any of your secondary groups. On insecure systems, these
+restrictions may be relaxed, but this is not a portable assumption.
+
+=item chr NUMBER
+
+=item chr
+
+Returns the character represented by that NUMBER in the character set.
+For example, C<chr(65)> is C<"A"> in ASCII. For the reverse, use L</ord>.
+
+If NUMBER is omitted, uses C<$_>.
+
+=item chroot FILENAME
+
+=item chroot
+
+This function works like the system call by the same name: it makes the
+named directory the new root directory for all further pathnames that
+begin with a C<"/"> by your process and all its children. (It doesn't
+change your current working directory, which is unaffected.) For security
+reasons, this call is restricted to the superuser. If FILENAME is
+omitted, does a C<chroot()> to C<$_>.
+
+=item close FILEHANDLE
+
+=item close
+
+Closes the file or pipe associated with the file handle, returning TRUE
+only if stdio successfully flushes buffers and closes the system file
+descriptor. Closes the currently selected filehandle if the argument
+is omitted.
+
+You don't have to close FILEHANDLE if you are immediately going to do
+another C<open()> on it, because C<open()> will close it for you. (See
+C<open()>.) However, an explicit C<close()> on an input file resets the line
+counter (C<$.>), while the implicit close done by C<open()> does not.
+
+If the file handle came from a piped open C<close()> will additionally
+return FALSE if one of the other system calls involved fails or if the
+program exits with non-zero status. (If the only problem was that the
+program exited non-zero C<$!> will be set to C<0>.) Also, closing a pipe
+waits for the process executing on the pipe to complete, in case you
+want to look at the output of the pipe afterwards. Closing a pipe
+explicitly also puts the exit status value of the command into C<$?>.
+
+Example:
+
+ open(OUTPUT, '|sort >foo') # pipe to sort
+ or die "Can't start sort: $!";
+ #... # print stuff to output
+ close OUTPUT # wait for sort to finish
+ or warn $! ? "Error closing sort pipe: $!"
+ : "Exit status $? from sort";
+ open(INPUT, 'foo') # get sort's results
+ or die "Can't open 'foo' for input: $!";
+
+FILEHANDLE may be an expression whose value can be used as an indirect
+filehandle, usually the real filehandle name.
+
+=item closedir DIRHANDLE
+
+Closes a directory opened by C<opendir()> and returns the success of that
+system call.
+
+DIRHANDLE may be an expression whose value can be used as an indirect
+dirhandle, usually the real dirhandle name.
+
+=item connect SOCKET,NAME
+
+Attempts to connect to a remote socket, just as the connect system call
+does. Returns TRUE if it succeeded, FALSE otherwise. NAME should be a
+packed address of the appropriate type for the socket. See the examples in
+L<perlipc/"Sockets: Client/Server Communication">.
+
+=item continue BLOCK
+
+Actually a flow control statement rather than a function. If there is a
+C<continue> BLOCK attached to a BLOCK (typically in a C<while> or
+C<foreach>), it is always executed just before the conditional is about to
+be evaluated again, just like the third part of a C<for> loop in C. Thus
+it can be used to increment a loop variable, even when the loop has been
+continued via the C<next> statement (which is similar to the C C<continue>
+statement).
+
+C<last>, C<next>, or C<redo> may appear within a C<continue>
+block. C<last> and C<redo> will behave as if they had been executed within
+the main block. So will C<next>, but since it will execute a C<continue>
+block, it may be more entertaining.
+
+ while (EXPR) {
+ ### redo always comes here
+ do_something;
+ } continue {
+ ### next always comes here
+ do_something_else;
+ # then back the top to re-check EXPR
+ }
+ ### last always comes here
+
+Omitting the C<continue> section is semantically equivalent to using an
+empty one, logically enough. In that case, C<next> goes directly back
+to check the condition at the top of the loop.
+
+=item cos EXPR
+
+Returns the cosine of EXPR (expressed in radians). If EXPR is omitted,
+takes cosine of C<$_>.
+
+For the inverse cosine operation, you may use the C<POSIX::acos()>
+function, or use this relation:
+
+ sub acos { atan2( sqrt(1 - $_[0] * $_[0]), $_[0] ) }
+
+=item crypt PLAINTEXT,SALT
+
+Encrypts a string exactly like the crypt(3) function in the C library
+(assuming that you actually have a version there that has not been
+extirpated as a potential munition). This can prove useful for checking
+the password file for lousy passwords, amongst other things. Only the
+guys wearing white hats should do this.
+
+Note that C<crypt()> is intended to be a one-way function, much like breaking
+eggs to make an omelette. There is no (known) corresponding decrypt
+function. As a result, this function isn't all that useful for
+cryptography. (For that, see your nearby CPAN mirror.)
+
+Here's an example that makes sure that whoever runs this program knows
+their own password:
+
+ $pwd = (getpwuid($<))[1];
+ $salt = substr($pwd, 0, 2);
+
+ system "stty -echo";
+ print "Password: ";
+ chop($word = <STDIN>);
+ print "\n";
+ system "stty echo";
+
+ if (crypt($word, $salt) ne $pwd) {
+ die "Sorry...\n";
+ } else {
+ print "ok\n";
+ }
+
+Of course, typing in your own password to whoever asks you
+for it is unwise.
+
+=item dbmclose HASH
+
+[This function has been superseded by the C<untie()> function.]
+
+Breaks the binding between a DBM file and a hash.
+
+=item dbmopen HASH,DBNAME,MODE
+
+[This function has been superseded by the C<tie()> function.]
+
+This binds a dbm(3), ndbm(3), sdbm(3), gdbm(3), or Berkeley DB file to a
+hash. HASH is the name of the hash. (Unlike normal C<open()>, the first
+argument is I<NOT> a filehandle, even though it looks like one). DBNAME
+is the name of the database (without the F<.dir> or F<.pag> extension if
+any). If the database does not exist, it is created with protection
+specified by MODE (as modified by the C<umask()>). If your system supports
+only the older DBM functions, you may perform only one C<dbmopen()> in your
+program. In older versions of Perl, if your system had neither DBM nor
+ndbm, calling C<dbmopen()> produced a fatal error; it now falls back to
+sdbm(3).
+
+If you don't have write access to the DBM file, you can only read hash
+variables, not set them. If you want to test whether you can write,
+either use file tests or try setting a dummy hash entry inside an C<eval()>,
+which will trap the error.
+
+Note that functions such as C<keys()> and C<values()> may return huge lists
+when used on large DBM files. You may prefer to use the C<each()>
+function to iterate over large DBM files. Example:
+
+ # print out history file offsets
+ dbmopen(%HIST,'/usr/lib/news/history',0666);
+ while (($key,$val) = each %HIST) {
+ print $key, ' = ', unpack('L',$val), "\n";
+ }
+ dbmclose(%HIST);
+
+See also L<AnyDBM_File> for a more general description of the pros and
+cons of the various dbm approaches, as well as L<DB_File> for a particularly
+rich implementation.
+
+=item defined EXPR
+
+=item defined
+
+Returns a Boolean value telling whether EXPR has a value other than
+the undefined value C<undef>. If EXPR is not present, C<$_> will be
+checked.
+
+Many operations return C<undef> to indicate failure, end of file,
+system error, uninitialized variable, and other exceptional
+conditions. This function allows you to distinguish C<undef> from
+other values. (A simple Boolean test will not distinguish among
+C<undef>, zero, the empty string, and C<"0">, which are all equally
+false.) Note that since C<undef> is a valid scalar, its presence
+doesn't I<necessarily> indicate an exceptional condition: C<pop()>
+returns C<undef> when its argument is an empty array, I<or> when the
+element to return happens to be C<undef>.
+
+You may also use C<defined()> to check whether a subroutine exists, by
+saying C<defined &func> without parentheses. On the other hand, use
+of C<defined()> upon aggregates (hashes and arrays) is not guaranteed to
+produce intuitive results, and should probably be avoided.
+
+When used on a hash element, it tells you whether the value is defined,
+not whether the key exists in the hash. Use L</exists> for the latter
+purpose.
+
+Examples:
+
+ print if defined $switch{'D'};
+ print "$val\n" while defined($val = pop(@ary));
+ die "Can't readlink $sym: $!"
+ unless defined($value = readlink $sym);
+ sub foo { defined &$bar ? &$bar(@_) : die "No bar"; }
+ $debugging = 0 unless defined $debugging;
+
+Note: Many folks tend to overuse C<defined()>, and then are surprised to
+discover that the number C<0> and C<""> (the zero-length string) are, in fact,
+defined values. For example, if you say
+
+ "ab" =~ /a(.*)b/;
+
+The pattern match succeeds, and C<$1> is defined, despite the fact that it
+matched "nothing". But it didn't really match nothing--rather, it
+matched something that happened to be C<0> characters long. This is all
+very above-board and honest. When a function returns an undefined value,
+it's an admission that it couldn't give you an honest answer. So you
+should use C<defined()> only when you're questioning the integrity of what
+you're trying to do. At other times, a simple comparison to C<0> or C<""> is
+what you want.
+
+Currently, using C<defined()> on an entire array or hash reports whether
+memory for that aggregate has ever been allocated. So an array you set
+to the empty list appears undefined initially, and one that once was full
+and that you then set to the empty list still appears defined. You
+should instead use a simple test for size:
+
+ if (@an_array) { print "has array elements\n" }
+ if (%a_hash) { print "has hash members\n" }
+
+Using C<undef()> on these, however, does clear their memory and then report
+them as not defined anymore, but you shouldn't do that unless you don't
+plan to use them again, because it saves time when you load them up
+again to have memory already ready to be filled. The normal way to
+free up space used by an aggregate is to assign the empty list.
+
+This counterintuitive behavior of C<defined()> on aggregates may be
+changed, fixed, or broken in a future release of Perl.
+
+See also L</undef>, L</exists>, L</ref>.
+
+=item delete EXPR
+
+Deletes the specified key(s) and their associated values from a hash.
+For each key, returns the deleted value associated with that key, or
+the undefined value if there was no such key. Deleting from C<$ENV{}>
+modifies the environment. Deleting from a hash tied to a DBM file
+deletes the entry from the DBM file. (But deleting from a C<tie()>d hash
+doesn't necessarily return anything.)
+
+The following deletes all the values of a hash:
+
+ foreach $key (keys %HASH) {
+ delete $HASH{$key};
+ }
+
+And so does this:
+
+ delete @HASH{keys %HASH}
+
+(But both of these are slower than just assigning the empty list, or
+using C<undef()>.) Note that the EXPR can be arbitrarily complicated as
+long as the final operation is a hash element lookup or hash slice:
+
+ delete $ref->[$x][$y]{$key};
+ delete @{$ref->[$x][$y]}{$key1, $key2, @morekeys};
+
+=item die LIST
+
+Outside an C<eval()>, prints the value of LIST to C<STDERR> and exits with
+the current value of C<$!> (errno). If C<$!> is C<0>, exits with the value of
+C<($? E<gt>E<gt> 8)> (backtick `command` status). If C<($? E<gt>E<gt> 8)>
+is C<0>, exits with C<255>. Inside an C<eval(),> the error message is stuffed into
+C<$@> and the C<eval()> is terminated with the undefined value. This makes
+C<die()> the way to raise an exception.
+
+Equivalent examples:
+
+ die "Can't cd to spool: $!\n" unless chdir '/usr/spool/news';
+ chdir '/usr/spool/news' or die "Can't cd to spool: $!\n"
+
+If the value of EXPR does not end in a newline, the current script line
+number and input line number (if any) are also printed, and a newline
+is supplied. Hint: sometimes appending C<", stopped"> to your message
+will cause it to make better sense when the string C<"at foo line 123"> is
+appended. Suppose you are running script "canasta".
+
+ die "/etc/games is no good";
+ die "/etc/games is no good, stopped";
+
+produce, respectively
+
+ /etc/games is no good at canasta line 123.
+ /etc/games is no good, stopped at canasta line 123.
+
+See also C<exit()> and C<warn()>.
+
+If LIST is empty and C<$@> already contains a value (typically from a
+previous eval) that value is reused after appending C<"\t...propagated">.
+This is useful for propagating exceptions:
+
+ eval { ... };
+ die unless $@ =~ /Expected exception/;
+
+If C<$@> is empty then the string C<"Died"> is used.
+
+You can arrange for a callback to be run just before the C<die()> does
+its deed, by setting the C<$SIG{__DIE__}> hook. The associated handler
+will be called with the error text and can change the error message, if
+it sees fit, by calling C<die()> again. See L<perlvar/$SIG{expr}> for details on
+setting C<%SIG> entries, and L<"eval BLOCK"> for some examples.
+
+Note that the C<$SIG{__DIE__}> hook is called even inside eval()ed
+blocks/strings. If one wants the hook to do nothing in such
+situations, put
+
+ die @_ if $^S;
+
+as the first line of the handler (see L<perlvar/$^S>).
+
+=item do BLOCK
+
+Not really a function. Returns the value of the last command in the
+sequence of commands indicated by BLOCK. When modified by a loop
+modifier, executes the BLOCK once before testing the loop condition.
+(On other statements the loop modifiers test the conditional first.)
+
+=item do SUBROUTINE(LIST)
+
+A deprecated form of subroutine call. See L<perlsub>.
+
+=item do EXPR
+
+Uses the value of EXPR as a filename and executes the contents of the
+file as a Perl script. Its primary use is to include subroutines
+from a Perl subroutine library.
+
+ do 'stat.pl';
+
+is just like
+
+ scalar eval `cat stat.pl`;
+
+except that it's more efficient and concise, keeps track of the
+current filename for error messages, and searches all the B<-I>
+libraries if the file isn't in the current directory (see also the @INC
+array in L<perlvar/Predefined Names>). It is also different in how
+code evaluated with C<do FILENAME> doesn't see lexicals in the enclosing
+scope like C<eval STRING> does. It's the same, however, in that it does
+reparse the file every time you call it, so you probably don't want to
+do this inside a loop.
+
+If C<do> cannot read the file, it returns undef and sets C<$!> to the
+error. If C<do> can read the file but cannot compile it, it
+returns undef and sets an error message in C<$@>. If the file is
+successfully compiled, C<do> returns the value of the last expression
+evaluated.
+
+Note that inclusion of library modules is better done with the
+C<use()> and C<require()> operators, which also do automatic error checking
+and raise an exception if there's a problem.
+
+You might like to use C<do> to read in a program configuration
+file. Manual error checking can be done this way:
+
+ # read in config files: system first, then user
+ for $file ("/share/prog/defaults.rc",
+ "$ENV{HOME}/.someprogrc") {
+ unless ($return = do $file) {
+ warn "couldn't parse $file: $@" if $@;
+ warn "couldn't do $file: $!" unless defined $return;
+ warn "couldn't run $file" unless $return;
+ }
+ }
+
+=item dump LABEL
+
+This causes an immediate core dump. Primarily this is so that you can
+use the B<undump> program to turn your core dump into an executable binary
+after having initialized all your variables at the beginning of the
+program. When the new binary is executed it will begin by executing a
+C<goto LABEL> (with all the restrictions that C<goto> suffers). Think of
+it as a goto with an intervening core dump and reincarnation. If C<LABEL>
+is omitted, restarts the program from the top. WARNING: Any files
+opened at the time of the dump will NOT be open any more when the
+program is reincarnated, with possible resulting confusion on the part
+of Perl. See also B<-u> option in L<perlrun>.
+
+Example:
+
+ #!/usr/bin/perl
+ require 'getopt.pl';
+ require 'stat.pl';
+ %days = (
+ 'Sun' => 1,
+ 'Mon' => 2,
+ 'Tue' => 3,
+ 'Wed' => 4,
+ 'Thu' => 5,
+ 'Fri' => 6,
+ 'Sat' => 7,
+ );
+
+ dump QUICKSTART if $ARGV[0] eq '-d';
+
+ QUICKSTART:
+ Getopt('f');
+
+This operator is largely obsolete, partly because it's very hard to
+convert a core file into an executable, and because the real perl-to-C
+compiler has superseded it.
+
+=item each HASH
+
+When called in list context, returns a 2-element list consisting of the
+key and value for the next element of a hash, so that you can iterate over
+it. When called in scalar context, returns the key for only the "next"
+element in the hash. (Note: Keys may be C<"0"> or C<"">, which are logically
+false; you may wish to avoid constructs like C<while ($k = each %foo) {}>
+for this reason.)
+
+Entries are returned in an apparently random order. When the hash is
+entirely read, a null array is returned in list context (which when
+assigned produces a FALSE (C<0>) value), and C<undef> in
+scalar context. The next call to C<each()> after that will start iterating
+again. There is a single iterator for each hash, shared by all C<each()>,
+C<keys()>, and C<values()> function calls in the program; it can be reset by
+reading all the elements from the hash, or by evaluating C<keys HASH> or
+C<values HASH>. If you add or delete elements of a hash while you're
+iterating over it, you may get entries skipped or duplicated, so don't.
+
+The following prints out your environment like the printenv(1) program,
+only in a different order:
+
+ while (($key,$value) = each %ENV) {
+ print "$key=$value\n";
+ }
+
+See also C<keys()> and C<values()>.
+
+=item eof FILEHANDLE
+
+=item eof ()
+
+=item eof
+
+Returns 1 if the next read on FILEHANDLE will return end of file, or if
+FILEHANDLE is not open. FILEHANDLE may be an expression whose value
+gives the real filehandle. (Note that this function actually
+reads a character and then C<ungetc()>s it, so isn't very useful in an
+interactive context.) Do not read from a terminal file (or call
+C<eof(FILEHANDLE)> on it) after end-of-file is reached. Filetypes such
+as terminals may lose the end-of-file condition if you do.
+
+An C<eof> without an argument uses the last file read as argument.
+Using C<eof()> with empty parentheses is very different. It indicates the pseudo file formed of
+the files listed on the command line, i.e., C<eof()> is reasonable to
+use inside a C<while (E<lt>E<gt>)> loop to detect the end of only the
+last file. Use C<eof(ARGV)> or eof without the parentheses to test
+I<EACH> file in a while (E<lt>E<gt>) loop. Examples:
+
+ # reset line numbering on each input file
+ while (<>) {
+ next if /^\s*#/; # skip comments
+ print "$.\t$_";
+ } continue {
+ close ARGV if eof; # Not eof()!
+ }
+
+ # insert dashes just before last line of last file
+ while (<>) {
+ if (eof()) { # check for end of current file
+ print "--------------\n";
+ close(ARGV); # close or break; is needed if we
+ # are reading from the terminal
+ }
+ print;
+ }
+
+Practical hint: you almost never need to use C<eof> in Perl, because the
+input operators return false values when they run out of data, or if there
+was an error.
+
+=item eval EXPR
+
+=item eval BLOCK
+
+In the first form, the return value of EXPR is parsed and executed as if it
+were a little Perl program. The value of the expression (which is itself
+determined within scalar context) is first parsed, and if there weren't any
+errors, executed in the context of the current Perl program, so that any
+variable settings or subroutine and format definitions remain afterwards.
+Note that the value is parsed every time the eval executes. If EXPR is
+omitted, evaluates C<$_>. This form is typically used to delay parsing
+and subsequent execution of the text of EXPR until run time.
+
+In the second form, the code within the BLOCK is parsed only once--at the
+same time the code surrounding the eval itself was parsed--and executed
+within the context of the current Perl program. This form is typically
+used to trap exceptions more efficiently than the first (see below), while
+also providing the benefit of checking the code within BLOCK at compile
+time.
+
+The final semicolon, if any, may be omitted from the value of EXPR or within
+the BLOCK.
+
+In both forms, the value returned is the value of the last expression
+evaluated inside the mini-program; a return statement may be also used, just
+as with subroutines. The expression providing the return value is evaluated
+in void, scalar, or list context, depending on the context of the eval itself.
+See L</wantarray> for more on how the evaluation context can be determined.
+
+If there is a syntax error or runtime error, or a C<die()> statement is
+executed, an undefined value is returned by C<eval()>, and C<$@> is set to the
+error message. If there was no error, C<$@> is guaranteed to be a null
+string. Beware that using C<eval()> neither silences perl from printing
+warnings to STDERR, nor does it stuff the text of warning messages into C<$@>.
+To do either of those, you have to use the C<$SIG{__WARN__}> facility. See
+L</warn> and L<perlvar>.
+
+Note that, because C<eval()> traps otherwise-fatal errors, it is useful for
+determining whether a particular feature (such as C<socket()> or C<symlink()>)
+is implemented. It is also Perl's exception trapping mechanism, where
+the die operator is used to raise exceptions.
+
+If the code to be executed doesn't vary, you may use the eval-BLOCK
+form to trap run-time errors without incurring the penalty of
+recompiling each time. The error, if any, is still returned in C<$@>.
+Examples:
+
+ # make divide-by-zero nonfatal
+ eval { $answer = $a / $b; }; warn $@ if $@;
+
+ # same thing, but less efficient
+ eval '$answer = $a / $b'; warn $@ if $@;
+
+ # a compile-time error
+ eval { $answer = }; # WRONG
+
+ # a run-time error
+ eval '$answer ='; # sets $@
+
+When using the C<eval{}> form as an exception trap in libraries, you may
+wish not to trigger any C<__DIE__> hooks that user code may have
+installed. You can use the C<local $SIG{__DIE__}> construct for this
+purpose, as shown in this example:
+
+ # a very private exception trap for divide-by-zero
+ eval { local $SIG{'__DIE__'}; $answer = $a / $b; };
+ warn $@ if $@;
+
+This is especially significant, given that C<__DIE__> hooks can call
+C<die()> again, which has the effect of changing their error messages:
+
+ # __DIE__ hooks may modify error messages
+ {
+ local $SIG{'__DIE__'} =
+ sub { (my $x = $_[0]) =~ s/foo/bar/g; die $x };
+ eval { die "foo lives here" };
+ print $@ if $@; # prints "bar lives here"
+ }
+
+With an C<eval()>, you should be especially careful to remember what's
+being looked at when:
+
+ eval $x; # CASE 1
+ eval "$x"; # CASE 2
+
+ eval '$x'; # CASE 3
+ eval { $x }; # CASE 4
+
+ eval "\$$x++"; # CASE 5
+ $$x++; # CASE 6
+
+Cases 1 and 2 above behave identically: they run the code contained in
+the variable C<$x>. (Although case 2 has misleading double quotes making
+the reader wonder what else might be happening (nothing is).) Cases 3
+and 4 likewise behave in the same way: they run the code C<'$x'>, which
+does nothing but return the value of C<$x>. (Case 4 is preferred for
+purely visual reasons, but it also has the advantage of compiling at
+compile-time instead of at run-time.) Case 5 is a place where
+normally you I<WOULD> like to use double quotes, except that in this
+particular situation, you can just use symbolic references instead, as
+in case 6.
+
+=item exec LIST
+
+=item exec PROGRAM LIST
+
+The C<exec()> function executes a system command I<AND NEVER RETURNS> -
+use C<system()> instead of C<exec()> if you want it to return. It fails and
+returns FALSE only if the command does not exist I<and> it is executed
+directly instead of via your system's command shell (see below).
+
+Since it's a common mistake to use C<exec()> instead of C<system()>, Perl
+warns you if there is a following statement which isn't C<die()>, C<warn()>,
+or C<exit()> (if C<-w> is set - but you always do that). If you
+I<really> want to follow an C<exec()> with some other statement, you
+can use one of these styles to avoid the warning:
+
+ exec ('foo') or print STDERR "couldn't exec foo: $!";
+ { exec ('foo') }; print STDERR "couldn't exec foo: $!";
+
+If there is more than one argument in LIST, or if LIST is an array
+with more than one value, calls execvp(3) with the arguments in LIST.
+If there is only one scalar argument or an array with one element in it,
+the argument is checked for shell metacharacters, and if there are any,
+the entire argument is passed to the system's command shell for parsing
+(this is C</bin/sh -c> on Unix platforms, but varies on other platforms).
+If there are no shell metacharacters in the argument, it is split into
+words and passed directly to C<execvp()>, which is more efficient. Note:
+C<exec()> and C<system()> do not flush your output buffer, so you may need to
+set C<$|> to avoid lost output. Examples:
+
+ exec '/bin/echo', 'Your arguments are: ', @ARGV;
+ exec "sort $outfile | uniq";
+
+If you don't really want to execute the first argument, but want to lie
+to the program you are executing about its own name, you can specify
+the program you actually want to run as an "indirect object" (without a
+comma) in front of the LIST. (This always forces interpretation of the
+LIST as a multivalued list, even if there is only a single scalar in
+the list.) Example:
+
+ $shell = '/bin/csh';
+ exec $shell '-sh'; # pretend it's a login shell
+
+or, more directly,
+
+ exec {'/bin/csh'} '-sh'; # pretend it's a login shell
+
+When the arguments get executed via the system shell, results will
+be subject to its quirks and capabilities. See L<perlop/"`STRING`">
+for details.
+
+Using an indirect object with C<exec()> or C<system()> is also more secure.
+This usage forces interpretation of the arguments as a multivalued list,
+even if the list had just one argument. That way you're safe from the
+shell expanding wildcards or splitting up words with whitespace in them.
+
+ @args = ( "echo surprise" );
+
+ system @args; # subject to shell escapes
+ # if @args == 1
+ system { $args[0] } @args; # safe even with one-arg list
+
+The first version, the one without the indirect object, ran the I<echo>
+program, passing it C<"surprise"> an argument. The second version
+didn't--it tried to run a program literally called I<"echo surprise">,
+didn't find it, and set C<$?> to a non-zero value indicating failure.
+
+Note that C<exec()> will not call your C<END> blocks, nor will it call
+any C<DESTROY> methods in your objects.
+
+=item exists EXPR
+
+Returns TRUE if the specified hash key exists in its hash array, even
+if the corresponding value is undefined.
+
+ print "Exists\n" if exists $array{$key};
+ print "Defined\n" if defined $array{$key};
+ print "True\n" if $array{$key};
+
+A hash element can be TRUE only if it's defined, and defined if
+it exists, but the reverse doesn't necessarily hold true.
+
+Note that the EXPR can be arbitrarily complicated as long as the final
+operation is a hash key lookup:
+
+ if (exists $ref->{"A"}{"B"}{$key}) { ... }
+
+Although the last element will not spring into existence just because its
+existence was tested, intervening ones will. Thus C<$ref-E<gt>{"A"}>
+C<$ref-E<gt>{"B"}> will spring into existence due to the existence
+test for a $key element. This autovivification may be fixed in a later
+release.
+
+=item exit EXPR
+
+Evaluates EXPR and exits immediately with that value. (Actually, it
+calls any defined C<END> routines first, but the C<END> routines may not
+abort the exit. Likewise any object destructors that need to be called
+are called before exit.) Example:
+
+ $ans = <STDIN>;
+ exit 0 if $ans =~ /^[Xx]/;
+
+See also C<die()>. If EXPR is omitted, exits with C<0> status. The only
+universally portable values for EXPR are C<0> for success and C<1> for error;
+all other values are subject to unpredictable interpretation depending
+on the environment in which the Perl program is running.
+
+You shouldn't use C<exit()> to abort a subroutine if there's any chance that
+someone might want to trap whatever error happened. Use C<die()> instead,
+which can be trapped by an C<eval()>.
+
+All C<END{}> blocks are run at exit time. See L<perlsub> for details.
+
+=item exp EXPR
+
+=item exp
+
+Returns I<e> (the natural logarithm base) to the power of EXPR.
+If EXPR is omitted, gives C<exp($_)>.
+
+=item fcntl FILEHANDLE,FUNCTION,SCALAR
+
+Implements the fcntl(2) function. You'll probably have to say
+
+ use Fcntl;
+
+first to get the correct constant definitions. Argument processing and
+value return works just like C<ioctl()> below.
+For example:
+
+ use Fcntl;
+ fcntl($filehandle, F_GETFL, $packed_return_buffer)
+ or die "can't fcntl F_GETFL: $!";
+
+You don't have to check for C<defined()> on the return from
+C<fnctl()>. Like C<ioctl()>, it maps a C<0> return from the system
+call into "C<0> but true" in Perl. This string is true in
+boolean context and C<0> in numeric context. It is also
+exempt from the normal B<-w> warnings on improper numeric
+conversions.
+
+Note that C<fcntl()> will produce a fatal error if used on a machine that
+doesn't implement fcntl(2).
+
+=item fileno FILEHANDLE
+
+Returns the file descriptor for a filehandle. This is useful for
+constructing bitmaps for C<select()> and low-level POSIX tty-handling
+operations. If FILEHANDLE is an expression, the value is taken as
+an indirect filehandle, generally its name.
+
+You can use this to find out whether two handles refer to the
+same underlying descriptor:
+
+ if (fileno(THIS) == fileno(THAT)) {
+ print "THIS and THAT are dups\n";
+ }
+
+=item flock FILEHANDLE,OPERATION
+
+Calls flock(2), or an emulation of it, on FILEHANDLE. Returns TRUE for
+success, FALSE on failure. Produces a fatal error if used on a machine
+that doesn't implement flock(2), fcntl(2) locking, or lockf(3). C<flock()>
+is Perl's portable file locking interface, although it locks only entire
+files, not records.
+
+On many platforms (including most versions or clones of Unix), locks
+established by C<flock()> are B<merely advisory>. Such discretionary locks
+are more flexible, but offer fewer guarantees. This means that files
+locked with C<flock()> may be modified by programs that do not also use
+C<flock()>. Windows NT and OS/2 are among the platforms which
+enforce mandatory locking. See your local documentation for details.
+
+OPERATION is one of LOCK_SH, LOCK_EX, or LOCK_UN, possibly combined with
+LOCK_NB. These constants are traditionally valued 1, 2, 8 and 4, but
+you can use the symbolic names if import them from the Fcntl module,
+either individually, or as a group using the ':flock' tag. LOCK_SH
+requests a shared lock, LOCK_EX requests an exclusive lock, and LOCK_UN
+releases a previously requested lock. If LOCK_NB is added to LOCK_SH or
+LOCK_EX then C<flock()> will return immediately rather than blocking
+waiting for the lock (check the return status to see if you got it).
+
+To avoid the possibility of mis-coordination, Perl flushes FILEHANDLE
+before (un)locking it.
+
+Note that the emulation built with lockf(3) doesn't provide shared
+locks, and it requires that FILEHANDLE be open with write intent. These
+are the semantics that lockf(3) implements. Most (all?) systems
+implement lockf(3) in terms of fcntl(2) locking, though, so the
+differing semantics shouldn't bite too many people.
+
+Note also that some versions of C<flock()> cannot lock things over the
+network; you would need to use the more system-specific C<fcntl()> for
+that. If you like you can force Perl to ignore your system's flock(2)
+function, and so provide its own fcntl(2)-based emulation, by passing
+the switch C<-Ud_flock> to the F<Configure> program when you configure
+perl.
+
+Here's a mailbox appender for BSD systems.
+
+ use Fcntl ':flock'; # import LOCK_* constants
+
+ sub lock {
+ flock(MBOX,LOCK_EX);
+ # and, in case someone appended
+ # while we were waiting...
+ seek(MBOX, 0, 2);
+ }
+
+ sub unlock {
+ flock(MBOX,LOCK_UN);
+ }
+
+ open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}")
+ or die "Can't open mailbox: $!";
+
+ lock();
+ print MBOX $msg,"\n\n";
+ unlock();
+
+See also L<DB_File> for other flock() examples.
+
+=item fork
+
+Does a fork(2) system call. Returns the child pid to the parent process,
+C<0> to the child process, or C<undef> if the fork is unsuccessful.
+
+Note: unflushed buffers remain unflushed in both processes, which means
+you may need to set C<$|> ($AUTOFLUSH in English) or call the C<autoflush()>
+method of C<IO::Handle> to avoid duplicate output.
+
+If you C<fork()> without ever waiting on your children, you will accumulate
+zombies:
+
+ $SIG{CHLD} = sub { wait };
+
+There's also the double-fork trick (error checking on
+C<fork()> returns omitted);
+
+ unless ($pid = fork) {
+ unless (fork) {
+ exec "what you really wanna do";
+ die "no exec";
+ # ... or ...
+ ## (some_perl_code_here)
+ exit 0;
+ }
+ exit 0;
+ }
+ waitpid($pid,0);
+
+See also L<perlipc> for more examples of forking and reaping
+moribund children.
+
+Note that if your forked child inherits system file descriptors like
+STDIN and STDOUT that are actually connected by a pipe or socket, even
+if you exit, then the remote server (such as, say, httpd or rsh) won't think
+you're done. You should reopen those to F</dev/null> if it's any issue.
+
+=item format
+
+Declare a picture format for use by the C<write()> function. For
+example:
+
+ format Something =
+ Test: @<<<<<<<< @||||| @>>>>>
+ $str, $%, '$' . int($num)
+ .
+
+ $str = "widget";
+ $num = $cost/$quantity;
+ $~ = 'Something';
+ write;
+
+See L<perlform> for many details and examples.
+
+=item formline PICTURE,LIST
+
+This is an internal function used by C<format>s, though you may call it,
+too. It formats (see L<perlform>) a list of values according to the
+contents of PICTURE, placing the output into the format output
+accumulator, C<$^A> (or C<$ACCUMULATOR> in English).
+Eventually, when a C<write()> is done, the contents of
+C<$^A> are written to some filehandle, but you could also read C<$^A>
+yourself and then set C<$^A> back to C<"">. Note that a format typically
+does one C<formline()> per line of form, but the C<formline()> function itself
+doesn't care how many newlines are embedded in the PICTURE. This means
+that the C<~> and C<~~> tokens will treat the entire PICTURE as a single line.
+You may therefore need to use multiple formlines to implement a single
+record format, just like the format compiler.
+
+Be careful if you put double quotes around the picture, because an "C<@>"
+character may be taken to mean the beginning of an array name.
+C<formline()> always returns TRUE. See L<perlform> for other examples.
+
+=item getc FILEHANDLE
+
+=item getc
+
+Returns the next character from the input file attached to FILEHANDLE,
+or the undefined value at end of file, or if there was an error. If
+FILEHANDLE is omitted, reads from STDIN. This is not particularly
+efficient. It cannot be used to get unbuffered single-characters,
+however. For that, try something more like:
+
+ if ($BSD_STYLE) {
+ system "stty cbreak </dev/tty >/dev/tty 2>&1";
+ }
+ else {
+ system "stty", '-icanon', 'eol', "\001";
+ }
+
+ $key = getc(STDIN);
+
+ if ($BSD_STYLE) {
+ system "stty -cbreak </dev/tty >/dev/tty 2>&1";
+ }
+ else {
+ system "stty", 'icanon', 'eol', '^@'; # ASCII null
+ }
+ print "\n";
+
+Determination of whether $BSD_STYLE should be set
+is left as an exercise to the reader.
+
+The C<POSIX::getattr()> function can do this more portably on systems
+purporting POSIX compliance.
+See also the C<Term::ReadKey> module from your nearest CPAN site;
+details on CPAN can be found on L<perlmod/CPAN>.
+
+=item getlogin
+
+Implements the C library function of the same name, which on most
+systems returns the current login from F</etc/utmp>, if any. If null,
+use C<getpwuid()>.
+
+ $login = getlogin || getpwuid($<) || "Kilroy";
+
+Do not consider C<getlogin()> for authentication: it is not as
+secure as C<getpwuid()>.
+
+=item getpeername SOCKET
+
+Returns the packed sockaddr address of other end of the SOCKET connection.
+
+ use Socket;
+ $hersockaddr = getpeername(SOCK);
+ ($port, $iaddr) = unpack_sockaddr_in($hersockaddr);
+ $herhostname = gethostbyaddr($iaddr, AF_INET);
+ $herstraddr = inet_ntoa($iaddr);
+
+=item getpgrp PID
+
+Returns the current process group for the specified PID. Use
+a PID of C<0> to get the current process group for the
+current process. Will raise an exception if used on a machine that
+doesn't implement getpgrp(2). If PID is omitted, returns process
+group of current process. Note that the POSIX version of C<getpgrp()>
+does not accept a PID argument, so only C<PID==0> is truly portable.
+
+=item getppid
+
+Returns the process id of the parent process.
+
+=item getpriority WHICH,WHO
+
+Returns the current priority for a process, a process group, or a user.
+(See L<getpriority(2)>.) Will raise a fatal exception if used on a
+machine that doesn't implement getpriority(2).
+
+=item getpwnam NAME
+
+=item getgrnam NAME
+
+=item gethostbyname NAME
+
+=item getnetbyname NAME
+
+=item getprotobyname NAME
+
+=item getpwuid UID
+
+=item getgrgid GID
+
+=item getservbyname NAME,PROTO
+
+=item gethostbyaddr ADDR,ADDRTYPE
+
+=item getnetbyaddr ADDR,ADDRTYPE
+
+=item getprotobynumber NUMBER
+
+=item getservbyport PORT,PROTO
+
+=item getpwent
+
+=item getgrent
+
+=item gethostent
+
+=item getnetent
+
+=item getprotoent
+
+=item getservent
+
+=item setpwent
+
+=item setgrent
+
+=item sethostent STAYOPEN
+
+=item setnetent STAYOPEN
+
+=item setprotoent STAYOPEN
+
+=item setservent STAYOPEN
+
+=item endpwent
+
+=item endgrent
+
+=item endhostent
+
+=item endnetent
+
+=item endprotoent
+
+=item endservent
+
+These routines perform the same functions as their counterparts in the
+system library. In list context, the return values from the
+various get routines are as follows:
+
+ ($name,$passwd,$uid,$gid,
+ $quota,$comment,$gcos,$dir,$shell,$expire) = getpw*
+ ($name,$passwd,$gid,$members) = getgr*
+ ($name,$aliases,$addrtype,$length,@addrs) = gethost*
+ ($name,$aliases,$addrtype,$net) = getnet*
+ ($name,$aliases,$proto) = getproto*
+ ($name,$aliases,$port,$proto) = getserv*
+
+(If the entry doesn't exist you get a null list.)
+
+In scalar context, you get the name, unless the function was a
+lookup by name, in which case you get the other thing, whatever it is.
+(If the entry doesn't exist you get the undefined value.) For example:
+
+ $uid = getpwnam($name);
+ $name = getpwuid($num);
+ $name = getpwent();
+ $gid = getgrnam($name);
+ $name = getgrgid($num;
+ $name = getgrent();
+ #etc.
+
+In I<getpw*()> the fields C<$quota>, C<$comment>, and C<$expire> are special
+cases in the sense that in many systems they are unsupported. If the
+C<$quota> is unsupported, it is an empty scalar. If it is supported, it
+usually encodes the disk quota. If the C<$comment> field is unsupported,
+it is an empty scalar. If it is supported it usually encodes some
+administrative comment about the user. In some systems the $quota
+field may be C<$change> or C<$age>, fields that have to do with password
+aging. In some systems the C<$comment> field may be C<$class>. The C<$expire>
+field, if present, encodes the expiration period of the account or the
+password. For the availability and the exact meaning of these fields
+in your system, please consult your getpwnam(3) documentation and your
+F<pwd.h> file. You can also find out from within Perl which meaning
+your C<$quota> and C<$comment> fields have and whether you have the C<$expire>
+field by using the C<Config> module and the values C<d_pwquota>, C<d_pwage>,
+C<d_pwchange>, C<d_pwcomment>, and C<d_pwexpire>.
+
+The C<$members> value returned by I<getgr*()> is a space separated list of
+the login names of the members of the group.
+
+For the I<gethost*()> functions, if the C<h_errno> variable is supported in
+C, it will be returned to you via C<$?> if the function call fails. The
+C<@addrs> value returned by a successful call is a list of the raw
+addresses returned by the corresponding system library call. In the
+Internet domain, each address is four bytes long and you can unpack it
+by saying something like:
+
+ ($a,$b,$c,$d) = unpack('C4',$addr[0]);
+
+If you get tired of remembering which element of the return list contains
+which return value, by-name interfaces are also provided in modules:
+C<File::stat>, C<Net::hostent>, C<Net::netent>, C<Net::protoent>, C<Net::servent>,
+C<Time::gmtime>, C<Time::localtime>, and C<User::grent>. These override the
+normal built-in, replacing them with versions that return objects with
+the appropriate names for each field. For example:
+
+ use File::stat;
+ use User::pwent;
+ $is_his = (stat($filename)->uid == pwent($whoever)->uid);
+
+Even though it looks like they're the same method calls (uid),
+they aren't, because a C<File::stat> object is different from a C<User::pwent> object.
+
+=item getsockname SOCKET
+
+Returns the packed sockaddr address of this end of the SOCKET connection.
+
+ use Socket;
+ $mysockaddr = getsockname(SOCK);
+ ($port, $myaddr) = unpack_sockaddr_in($mysockaddr);
+
+=item getsockopt SOCKET,LEVEL,OPTNAME
+
+Returns the socket option requested, or undef if there is an error.
+
+=item glob EXPR
+
+=item glob
+
+Returns the value of EXPR with filename expansions such as the standard Unix shell F</bin/sh> would
+do. This is the internal function implementing the C<E<lt>*.cE<gt>>
+operator, but you can use it directly. If EXPR is omitted, C<$_> is used.
+The C<E<lt>*.cE<gt>> operator is discussed in more detail in
+L<perlop/"I/O Operators">.
+
+=item gmtime EXPR
+
+Converts a time as returned by the time function to a 9-element array
+with the time localized for the standard Greenwich time zone.
+Typically used as follows:
+
+ # 0 1 2 3 4 5 6 7 8
+ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
+ gmtime(time);
+
+All array elements are numeric, and come straight out of a struct tm.
+In particular this means that C<$mon> has the range C<0..11> and C<$wday> has
+the range C<0..6> with sunday as day C<0>. Also, C<$year> is the number of
+years since 1900, that is, C<$year> is C<123> in year 2023, I<not> simply the last two digits of the year.
+
+If EXPR is omitted, does C<gmtime(time())>.
+
+In scalar context, returns the ctime(3) value:
+
+ $now_string = gmtime; # e.g., "Thu Oct 13 04:54:34 1994"
+
+Also see the C<timegm()> function provided by the C<Time::Local> module,
+and the strftime(3) function available via the POSIX module.
+
+This scalar value is B<not> locale dependent, see L<perllocale>, but
+instead a Perl builtin. Also see the C<Time::Local> module, and the
+strftime(3) and mktime(3) function available via the POSIX module. To
+get somewhat similar but locale dependent date strings, set up your
+locale environment variables appropriately (please see L<perllocale>)
+and try for example:
+
+ use POSIX qw(strftime);
+ $now_string = strftime "%a %b %e %H:%M:%S %Y", gmtime;
+
+Note that the C<%a> and C<%b>, the short forms of the day of the week
+and the month of the year, may not necessarily be three characters wide.
+
+=item goto LABEL
+
+=item goto EXPR
+
+=item goto &NAME
+
+The C<goto-LABEL> form finds the statement labeled with LABEL and resumes
+execution there. It may not be used to go into any construct that
+requires initialization, such as a subroutine or a C<foreach> loop. It
+also can't be used to go into a construct that is optimized away,
+or to get out of a block or subroutine given to C<sort()>.
+It can be used to go almost anywhere else within the dynamic scope,
+including out of subroutines, but it's usually better to use some other
+construct such as C<last> or C<die()>. The author of Perl has never felt the
+need to use this form of C<goto> (in Perl, that is--C is another matter).
+
+The C<goto-EXPR> form expects a label name, whose scope will be resolved
+dynamically. This allows for computed C<goto>s per FORTRAN, but isn't
+necessarily recommended if you're optimizing for maintainability:
+
+ goto ("FOO", "BAR", "GLARCH")[$i];
+
+The C<goto-&NAME> form is highly magical, and substitutes a call to the
+named subroutine for the currently running subroutine. This is used by
+C<AUTOLOAD> subroutines that wish to load another subroutine and then
+pretend that the other subroutine had been called in the first place
+(except that any modifications to C<@_> in the current subroutine are
+propagated to the other subroutine.) After the C<goto>, not even C<caller()>
+will be able to tell that this routine was called first.
+
+=item grep BLOCK LIST
+
+=item grep EXPR,LIST
+
+This is similar in spirit to, but not the same as, grep(1)
+and its relatives. In particular, it is not limited to using
+regular expressions.
+
+Evaluates the BLOCK or EXPR for each element of LIST (locally setting
+C<$_> to each element) and returns the list value consisting of those
+elements for which the expression evaluated to TRUE. In a scalar
+context, returns the number of times the expression was TRUE.
+
+ @foo = grep(!/^#/, @bar); # weed out comments
+
+or equivalently,
+
+ @foo = grep {!/^#/} @bar; # weed out comments
+
+Note that, because C<$_> is a reference into the list value, it can be used
+to modify the elements of the array. While this is useful and
+supported, it can cause bizarre results if the LIST is not a named
+array. Similarly, grep returns aliases into the original list,
+much like the way that a for loop's index variable aliases the list
+elements. That is, modifying an element of a list returned by grep
+(for example, in a C<foreach>, C<map()> or another C<grep()>)
+actually modifies the element in the original list.
+
+See also L</map> for an array composed of the results of the BLOCK or EXPR.
+
+=item hex EXPR
+
+=item hex
+
+Interprets EXPR as a hex string and returns the corresponding
+value. (To convert strings that might start with either 0 or 0x
+see L</oct>.) If EXPR is omitted, uses C<$_>.
+
+ print hex '0xAf'; # prints '175'
+ print hex 'aF'; # same
+
+=item import
+
+There is no builtin C<import()> function. It is just an ordinary
+method (subroutine) defined (or inherited) by modules that wish to export
+names to another module. The C<use()> function calls the C<import()> method
+for the package used. See also L</use()>, L<perlmod>, and L<Exporter>.
+
+=item index STR,SUBSTR,POSITION
+
+=item index STR,SUBSTR
+
+Returns the position of the first occurrence of SUBSTR in STR at or after
+POSITION. If POSITION is omitted, starts searching from the beginning of
+the string. The return value is based at C<0> (or whatever you've set the C<$[>
+variable to--but don't do that). If the substring is not found, returns
+one less than the base, ordinarily C<-1>.
+
+=item int EXPR
+
+=item int
+
+Returns the integer portion of EXPR. If EXPR is omitted, uses C<$_>.
+You should not use this for rounding, because it truncates
+towards C<0>, and because machine representations of floating point
+numbers can sometimes produce counterintuitive results. Usually C<sprintf()> or C<printf()>,
+or the C<POSIX::floor> or C<POSIX::ceil> functions, would serve you better.
+
+=item ioctl FILEHANDLE,FUNCTION,SCALAR
+
+Implements the ioctl(2) function. You'll probably have to say
+
+ require "ioctl.ph"; # probably in /usr/local/lib/perl/ioctl.ph
+
+first to get the correct function definitions. If F<ioctl.ph> doesn't
+exist or doesn't have the correct definitions you'll have to roll your
+own, based on your C header files such as F<E<lt>sys/ioctl.hE<gt>>.
+(There is a Perl script called B<h2ph> that comes with the Perl kit that
+may help you in this, but it's nontrivial.) SCALAR will be read and/or
+written depending on the FUNCTION--a pointer to the string value of SCALAR
+will be passed as the third argument of the actual C<ioctl()> call. (If SCALAR
+has no string value but does have a numeric value, that value will be
+passed rather than a pointer to the string value. To guarantee this to be
+TRUE, add a C<0> to the scalar before using it.) The C<pack()> and C<unpack()>
+functions are useful for manipulating the values of structures used by
+C<ioctl()>. The following example sets the erase character to DEL.
+
+ require 'ioctl.ph';
+ $getp = &TIOCGETP;
+ die "NO TIOCGETP" if $@ || !$getp;
+ $sgttyb_t = "ccccs"; # 4 chars and a short
+ if (ioctl(STDIN,$getp,$sgttyb)) {
+ @ary = unpack($sgttyb_t,$sgttyb);
+ $ary[2] = 127;
+ $sgttyb = pack($sgttyb_t,@ary);
+ ioctl(STDIN,&TIOCSETP,$sgttyb)
+ || die "Can't ioctl: $!";
+ }
+
+The return value of C<ioctl()> (and C<fcntl()>) is as follows:
+
+ if OS returns: then Perl returns:
+ -1 undefined value
+ 0 string "0 but true"
+ anything else that number
+
+Thus Perl returns TRUE on success and FALSE on failure, yet you can
+still easily determine the actual value returned by the operating
+system:
+
+ ($retval = ioctl(...)) || ($retval = -1);
+ printf "System returned %d\n", $retval;
+
+The special string "C<0> but true" is excempt from B<-w> complaints
+about improper numeric conversions.
+
+=item join EXPR,LIST
+
+Joins the separate strings of LIST into a single string with
+fields separated by the value of EXPR, and returns the string.
+Example:
+
+ $_ = join(':', $login,$passwd,$uid,$gid,$gcos,$home,$shell);
+
+See L</split>.
+
+=item keys HASH
+
+Returns a list consisting of all the keys of the named hash. (In a
+scalar context, returns the number of keys.) The keys are returned in
+an apparently random order, but it is the same order as either the
+C<values()> or C<each()> function produces (given that the hash has not been
+modified). As a side effect, it resets HASH's iterator.
+
+Here is yet another way to print your environment:
+
+ @keys = keys %ENV;
+ @values = values %ENV;
+ while ($#keys >= 0) {
+ print pop(@keys), '=', pop(@values), "\n";
+ }
+
+or how about sorted by key:
+
+ foreach $key (sort(keys %ENV)) {
+ print $key, '=', $ENV{$key}, "\n";
+ }
+
+To sort an array by value, you'll need to use a C<sort()> function.
+Here's a descending numeric sort of a hash by its values:
+
+ foreach $key (sort { $hash{$b} <=> $hash{$a} } keys %hash) {
+ printf "%4d %s\n", $hash{$key}, $key;
+ }
+
+As an lvalue C<keys()> allows you to increase the number of hash buckets
+allocated for the given hash. This can gain you a measure of efficiency if
+you know the hash is going to get big. (This is similar to pre-extending
+an array by assigning a larger number to $#array.) If you say
+
+ keys %hash = 200;
+
+then C<%hash> will have at least 200 buckets allocated for it--256 of them, in fact, since
+it rounds up to the next power of two. These
+buckets will be retained even if you do C<%hash = ()>, use C<undef
+%hash> if you want to free the storage while C<%hash> is still in scope.
+You can't shrink the number of buckets allocated for the hash using
+C<keys()> in this way (but you needn't worry about doing this by accident,
+as trying has no effect).
+
+=item kill LIST
+
+Sends a signal to a list of processes. The first element of
+the list must be the signal to send. Returns the number of
+processes successfully signaled.
+
+ $cnt = kill 1, $child1, $child2;
+ kill 9, @goners;
+
+Unlike in the shell, in Perl if the I<SIGNAL> is negative, it kills
+process groups instead of processes. (On System V, a negative I<PROCESS>
+number will also kill process groups, but that's not portable.) That
+means you usually want to use positive not negative signals. You may also
+use a signal name in quotes. See L<perlipc/"Signals"> for details.
+
+=item last LABEL
+
+=item last
+
+The C<last> command is like the C<break> statement in C (as used in
+loops); it immediately exits the loop in question. If the LABEL is
+omitted, the command refers to the innermost enclosing loop. The
+C<continue> block, if any, is not executed:
+
+ LINE: while (<STDIN>) {
+ last LINE if /^$/; # exit when done with header
+ #...
+ }
+
+See also L</continue> for an illustration of how C<last>, C<next>, and
+C<redo> work.
+
+=item lc EXPR
+
+=item lc
+
+Returns an lowercased version of EXPR. This is the internal function
+implementing the C<\L> escape in double-quoted strings.
+Respects current C<LC_CTYPE> locale if C<use locale> in force. See L<perllocale>.
+
+If EXPR is omitted, uses C<$_>.
+
+=item lcfirst EXPR
+
+=item lcfirst
+
+Returns the value of EXPR with the first character lowercased. This is
+the internal function implementing the C<\l> escape in double-quoted strings.
+Respects current C<LC_CTYPE> locale if C<use locale> in force. See L<perllocale>.
+
+If EXPR is omitted, uses C<$_>.
+
+=item length EXPR
+
+=item length
+
+Returns the length in bytes of the value of EXPR. If EXPR is
+omitted, returns length of C<$_>.
+
+=item link OLDFILE,NEWFILE
+
+Creates a new filename linked to the old filename. Returns TRUE for
+success, FALSE otherwise.
+
+=item listen SOCKET,QUEUESIZE
+
+Does the same thing that the listen system call does. Returns TRUE if
+it succeeded, FALSE otherwise. See example in L<perlipc/"Sockets: Client/Server Communication">.
+
+=item local EXPR
+
+A local modifies the listed variables to be local to the enclosing
+block, file, or eval. If more than one value is listed, the list must
+be placed in parentheses. See L<perlsub/"Temporary Values via local()">
+for details, including issues with tied arrays and hashes.
+
+You really probably want to be using C<my()> instead, because C<local()> isn't
+what most people think of as "local". See L<perlsub/"Private Variables
+via my()"> for details.
+
+=item localtime EXPR
+
+Converts a time as returned by the time function to a 9-element array
+with the time analyzed for the local time zone. Typically used as
+follows:
+
+ # 0 1 2 3 4 5 6 7 8
+ ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
+ localtime(time);
+
+All array elements are numeric, and come straight out of a struct tm.
+In particular this means that C<$mon> has the range C<0..11> and C<$wday> has
+the range C<0..6> with sunday as day C<0>. Also, C<$year> is the number of
+years since 1900, that is, C<$year> is C<123> in year 2023, and I<not> simply the last two digits of the year.
+
+If EXPR is omitted, uses the current time (C<localtime(time)>).
+
+In scalar context, returns the ctime(3) value:
+
+ $now_string = localtime; # e.g., "Thu Oct 13 04:54:34 1994"
+
+This scalar value is B<not> locale dependent, see L<perllocale>, but
+instead a Perl builtin. Also see the C<Time::Local> module, and the
+strftime(3) and mktime(3) function available via the POSIX module. To
+get somewhat similar but locale dependent date strings, set up your
+locale environment variables appropriately (please see L<perllocale>)
+and try for example:
+
+ use POSIX qw(strftime);
+ $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime;
+
+Note that the C<%a> and C<%b>, the short forms of the day of the week
+and the month of the year, may not necessarily be three characters wide.
+
+=item log EXPR
+
+=item log
+
+Returns the natural logarithm (base I<e>) of EXPR. If EXPR is omitted, returns log
+of C<$_>.
+
+=item lstat FILEHANDLE
+
+=item lstat EXPR
+
+=item lstat
+
+Does the same thing as the C<stat()> function (including setting the
+special C<_> filehandle) but stats a symbolic link instead of the file
+the symbolic link points to. If symbolic links are unimplemented on
+your system, a normal C<stat()> is done.
+
+If EXPR is omitted, stats C<$_>.
+
+=item m//
+
+The match operator. See L<perlop>.
+
+=item map BLOCK LIST
+
+=item map EXPR,LIST
+
+Evaluates the BLOCK or EXPR for each element of LIST (locally setting C<$_> to each
+element) and returns the list value composed of the results of each such
+evaluation. Evaluates BLOCK or EXPR in a list context, so each element of LIST
+may produce zero, one, or more elements in the returned value.
+
+ @chars = map(chr, @nums);
+
+translates a list of numbers to the corresponding characters. And
+
+ %hash = map { getkey($_) => $_ } @array;
+
+is just a funny way to write
+
+ %hash = ();
+ foreach $_ (@array) {
+ $hash{getkey($_)} = $_;
+ }
+
+Note that, because C<$_> is a reference into the list value, it can be used
+to modify the elements of the array. While this is useful and
+supported, it can cause bizarre results if the LIST is not a named
+array. See also L</grep> for an array composed of those items of the
+original list for which the BLOCK or EXPR evaluates to true.
+
+=item mkdir FILENAME,MODE
+
+Creates the directory specified by FILENAME, with permissions specified
+by MODE (as modified by umask). If it succeeds it returns TRUE, otherwise
+it returns FALSE and sets C<$!> (errno).
+
+=item msgctl ID,CMD,ARG
+
+Calls the System V IPC function msgctl(2). You'll probably have to say
+
+ use IPC::SysV;
+
+first to get the correct constant definitions. If CMD is C<IPC_STAT>,
+then ARG must be a variable which will hold the returned C<msqid_ds>
+structure. Returns like C<ioctl()>: the undefined value for error, "C<0> but
+true" for zero, or the actual return value otherwise. See also
+C<IPC::SysV> and C<IPC::Semaphore::Msg> documentation.
+
+=item msgget KEY,FLAGS
+
+Calls the System V IPC function msgget(2). Returns the message queue
+id, or the undefined value if there is an error. See also C<IPC::SysV>
+and C<IPC::SysV::Msg> documentation.
+
+=item msgsnd ID,MSG,FLAGS
+
+Calls the System V IPC function msgsnd to send the message MSG to the
+message queue ID. MSG must begin with the long integer message type,
+which may be created with C<pack("l", $type)>. Returns TRUE if
+successful, or FALSE if there is an error. See also C<IPC::SysV>
+and C<IPC::SysV::Msg> documentation.
+
+=item msgrcv ID,VAR,SIZE,TYPE,FLAGS
+
+Calls the System V IPC function msgrcv to receive a message from
+message queue ID into variable VAR with a maximum message size of
+SIZE. Note that if a message is received, the message type will be
+the first thing in VAR, and the maximum length of VAR is SIZE plus the
+size of the message type. Returns TRUE if successful, or FALSE if
+there is an error. See also C<IPC::SysV> and C<IPC::SysV::Msg> documentation.
+
+=item my EXPR
+
+A C<my()> declares the listed variables to be local (lexically) to the
+enclosing block, file, or C<eval()>. If
+more than one value is listed, the list must be placed in parentheses. See
+L<perlsub/"Private Variables via my()"> for details.
+
+=item next LABEL
+
+=item next
+
+The C<next> command is like the C<continue> statement in C; it starts
+the next iteration of the loop:
+
+ LINE: while (<STDIN>) {
+ next LINE if /^#/; # discard comments
+ #...
+ }
+
+Note that if there were a C<continue> block on the above, it would get
+executed even on discarded lines. If the LABEL is omitted, the command
+refers to the innermost enclosing loop.
+
+See also L</continue> for an illustration of how C<last>, C<next>, and
+C<redo> work.
+
+=item no Module LIST
+
+See the L</use> function, which C<no> is the opposite of.
+
+=item oct EXPR
+
+=item oct
+
+Interprets EXPR as an octal string and returns the corresponding
+value. (If EXPR happens to start off with C<0x>, interprets it as
+a hex string instead.) The following will handle decimal, octal, and
+hex in the standard Perl or C notation:
+
+ $val = oct($val) if $val =~ /^0/;
+
+If EXPR is omitted, uses C<$_>. This function is commonly used when
+a string such as C<644> needs to be converted into a file mode, for
+example. (Although perl will automatically convert strings into
+numbers as needed, this automatic conversion assumes base 10.)
+
+=item open FILEHANDLE,EXPR
+
+=item open FILEHANDLE
+
+Opens the file whose filename is given by EXPR, and associates it with
+FILEHANDLE. If FILEHANDLE is an expression, its value is used as the
+name of the real filehandle wanted. If EXPR is omitted, the scalar
+variable of the same name as the FILEHANDLE contains the filename.
+(Note that lexical variables--those declared with C<my()>--will not work
+for this purpose; so if you're using C<my()>, specify EXPR in your call
+to open.)
+
+If the filename begins with C<'E<lt>'> or nothing, the file is opened for input.
+If the filename begins with C<'E<gt>'>, the file is truncated and opened for
+output, being created if necessary. If the filename begins with C<'E<gt>E<gt>'>,
+the file is opened for appending, again being created if necessary.
+You can put a C<'+'> in front of the C<'E<gt>'> or C<'E<lt>'> to indicate that
+you want both read and write access to the file; thus C<'+E<lt>'> is almost
+always preferred for read/write updates--the C<'+E<gt>'> mode would clobber the
+file first. You can't usually use either read-write mode for updating
+textfiles, since they have variable length records. See the B<-i>
+switch in L<perlrun> for a better approach.
+
+The prefix and the filename may be separated with spaces.
+These various prefixes correspond to the fopen(3) modes of C<'r'>, C<'r+'>, C<'w'>,
+C<'w+'>, C<'a'>, and C<'a+'>.
+
+If the filename begins with C<'|'>, the filename is interpreted as a
+command to which output is to be piped, and if the filename ends with a
+C<'|'>, the filename is interpreted See L<perlipc/"Using open() for IPC">
+for more examples of this. (You are not allowed to C<open()> to a command
+that pipes both in I<and> out, but see L<IPC::Open2>, L<IPC::Open3>,
+and L<perlipc/"Bidirectional Communication"> for alternatives.)
+
+Opening C<'-'> opens STDIN and opening C<'E<gt>-'> opens STDOUT. Open returns
+nonzero upon success, the undefined value otherwise. If the C<open()>
+involved a pipe, the return value happens to be the pid of the
+subprocess.
+
+If you're unfortunate enough to be running Perl on a system that
+distinguishes between text files and binary files (modern operating
+systems don't care), then you should check out L</binmode> for tips for
+dealing with this. The key distinction between systems that need C<binmode()>
+and those that don't is their text file formats. Systems like Unix, MacOS, and
+Plan9, which delimit lines with a single character, and which encode that
+character in C as C<"\n">, do not need C<binmode()>. The rest need it.
+
+When opening a file, it's usually a bad idea to continue normal execution
+if the request failed, so C<open()> is frequently used in connection with
+C<die()>. Even if C<die()> won't do what you want (say, in a CGI script,
+where you want to make a nicely formatted error message (but there are
+modules that can help with that problem)) you should always check
+the return value from opening a file. The infrequent exception is when
+working with an unopened filehandle is actually what you want to do.
+
+Examples:
+
+ $ARTICLE = 100;
+ open ARTICLE or die "Can't find article $ARTICLE: $!\n";
+ while (<ARTICLE>) {...
+
+ open(LOG, '>>/usr/spool/news/twitlog'); # (log is reserved)
+ # if the open fails, output is discarded
+
+ open(DBASE, '+<dbase.mine') # open for update
+ or die "Can't open 'dbase.mine' for update: $!";
+
+ open(ARTICLE, "caesar <$article |") # decrypt article
+ or die "Can't start caesar: $!";
+
+ open(EXTRACT, "|sort >/tmp/Tmp$$") # $$ is our process id
+ or die "Can't start sort: $!";
+
+ # process argument list of files along with any includes
+
+ foreach $file (@ARGV) {
+ process($file, 'fh00');
+ }
+
+ sub process {
+ my($filename, $input) = @_;
+ $input++; # this is a string increment
+ unless (open($input, $filename)) {
+ print STDERR "Can't open $filename: $!\n";
+ return;
+ }
+
+ local $_;
+ while (<$input>) { # note use of indirection
+ if (/^#include "(.*)"/) {
+ process($1, $input);
+ next;
+ }
+ #... # whatever
+ }
+ }
+
+You may also, in the Bourne shell tradition, specify an EXPR beginning
+with C<'E<gt>&'>, in which case the rest of the string is interpreted as the
+name of a filehandle (or file descriptor, if numeric) to be
+duped and opened. You may use C<&> after C<E<gt>>, C<E<gt>E<gt>>, C<E<lt>>, C<+E<gt>>,
+C<+E<gt>E<gt>>, and C<+E<lt>>. The
+mode you specify should match the mode of the original filehandle.
+(Duping a filehandle does not take into account any existing contents of
+stdio buffers.)
+Here is a script that saves, redirects, and restores STDOUT and
+STDERR:
+
+ #!/usr/bin/perl
+ open(OLDOUT, ">&STDOUT");
+ open(OLDERR, ">&STDERR");
+
+ open(STDOUT, ">foo.out") || die "Can't redirect stdout";
+ open(STDERR, ">&STDOUT") || die "Can't dup stdout";
+
+ select(STDERR); $| = 1; # make unbuffered
+ select(STDOUT); $| = 1; # make unbuffered
+
+ print STDOUT "stdout 1\n"; # this works for
+ print STDERR "stderr 1\n"; # subprocesses too
+
+ close(STDOUT);
+ close(STDERR);
+
+ open(STDOUT, ">&OLDOUT");
+ open(STDERR, ">&OLDERR");
+
+ print STDOUT "stdout 2\n";
+ print STDERR "stderr 2\n";
+
+
+If you specify C<'E<lt>&=N'>, where C<N> is a number, then Perl will do an
+equivalent of C's C<fdopen()> of that file descriptor; this is more
+parsimonious of file descriptors. For example:
+
+ open(FILEHANDLE, "<&=$fd")
+
+If you open a pipe on the command C<'-'>, i.e., either C<'|-'> or C<'-|'>, then
+there is an implicit fork done, and the return value of open is the pid
+of the child within the parent process, and C<0> within the child
+process. (Use C<defined($pid)> to determine whether the open was successful.)
+The filehandle behaves normally for the parent, but i/o to that
+filehandle is piped from/to the STDOUT/STDIN of the child process.
+In the child process the filehandle isn't opened--i/o happens from/to
+the new STDOUT or STDIN. Typically this is used like the normal
+piped open when you want to exercise more control over just how the
+pipe command gets executed, such as when you are running setuid, and
+don't want to have to scan shell commands for metacharacters.
+The following pairs are more or less equivalent:
+
+ open(FOO, "|tr '[a-z]' '[A-Z]'");
+ open(FOO, "|-") || exec 'tr', '[a-z]', '[A-Z]';
+
+ open(FOO, "cat -n '$file'|");
+ open(FOO, "-|") || exec 'cat', '-n', $file;
+
+See L<perlipc/"Safe Pipe Opens"> for more examples of this.
+
+NOTE: On any operation that may do a fork, any unflushed buffers remain
+unflushed in both processes, which means you may need to set C<$|> to
+avoid duplicate output.
+
+Closing any piped filehandle causes the parent process to wait for the
+child to finish, and returns the status value in C<$?>.
+
+The filename passed to open will have leading and trailing
+whitespace deleted, and the normal redirection characters
+honored. This property, known as "magic open",
+can often be used to good effect. A user could specify a filename of
+F<"rsh cat file |">, or you could change certain filenames as needed:
+
+ $filename =~ s/(.*\.gz)\s*$/gzip -dc < $1|/;
+ open(FH, $filename) or die "Can't open $filename: $!";
+
+However, to open a file with arbitrary weird characters in it, it's
+necessary to protect any leading and trailing whitespace:
+
+ $file =~ s#^(\s)#./$1#;
+ open(FOO, "< $file\0");
+
+If you want a "real" C C<open()> (see L<open(2)> on your system), then you
+should use the C<sysopen()> function, which involves no such magic. This is
+another way to protect your filenames from interpretation. For example:
+
+ use IO::Handle;
+ sysopen(HANDLE, $path, O_RDWR|O_CREAT|O_EXCL)
+ or die "sysopen $path: $!";
+ $oldfh = select(HANDLE); $| = 1; select($oldfh);
+ print HANDLE "stuff $$\n");
+ seek(HANDLE, 0, 0);
+ print "File contains: ", <HANDLE>;
+
+Using the constructor from the C<IO::Handle> package (or one of its
+subclasses, such as C<IO::File> or C<IO::Socket>), you can generate anonymous
+filehandles that have the scope of whatever variables hold references to
+them, and automatically close whenever and however you leave that scope:
+
+ use IO::File;
+ #...
+ sub read_myfile_munged {
+ my $ALL = shift;
+ my $handle = new IO::File;
+ open($handle, "myfile") or die "myfile: $!";
+ $first = <$handle>
+ or return (); # Automatically closed here.
+ mung $first or die "mung failed"; # Or here.
+ return $first, <$handle> if $ALL; # Or here.
+ $first; # Or here.
+ }
+
+See L</seek()> for some details about mixing reading and writing.
+
+=item opendir DIRHANDLE,EXPR
+
+Opens a directory named EXPR for processing by C<readdir()>, C<telldir()>,
+C<seekdir()>, C<rewinddir()>, and C<closedir()>. Returns TRUE if successful.
+DIRHANDLEs have their own namespace separate from FILEHANDLEs.
+
+=item ord EXPR
+
+=item ord
+
+Returns the numeric ascii value of the first character of EXPR. If
+EXPR is omitted, uses C<$_>. For the reverse, see L</chr>.
+
+=item pack TEMPLATE,LIST
+
+Takes an array or list of values and packs it into a binary structure,
+returning the string containing the structure. The TEMPLATE is a
+sequence of characters that give the order and type of values, as
+follows:
+
+ A An ascii string, will be space padded.
+ a An ascii string, will be null padded.
+ b A bit string (ascending bit order, like vec()).
+ B A bit string (descending bit order).
+ h A hex string (low nybble first).
+ H A hex string (high nybble first).
+
+ c A signed char value.
+ C An unsigned char value.
+
+ s A signed short value.
+ S An unsigned short value.
+ (This 'short' is _exactly_ 16 bits, which may differ from
+ what a local C compiler calls 'short'.)
+
+ i A signed integer value.
+ I An unsigned integer value.
+ (This 'integer' is _at_least_ 32 bits wide. Its exact
+ size depends on what a local C compiler calls 'int',
+ and may even be larger than the 'long' described in
+ the next item.)
+
+ l A signed long value.
+ L An unsigned long value.
+ (This 'long' is _exactly_ 32 bits, which may differ from
+ what a local C compiler calls 'long'.)
+
+ n A short in "network" (big-endian) order.
+ N A long in "network" (big-endian) order.
+ v A short in "VAX" (little-endian) order.
+ V A long in "VAX" (little-endian) order.
+ (These 'shorts' and 'longs' are _exactly_ 16 bits and
+ _exactly_ 32 bits, respectively.)
+
+ f A single-precision float in the native format.
+ d A double-precision float in the native format.
+
+ p A pointer to a null-terminated string.
+ P A pointer to a structure (fixed-length string).
+
+ u A uuencoded string.
+
+ w A BER compressed integer. Its bytes represent an unsigned
+ integer in base 128, most significant digit first, with as
+ few digits as possible. Bit eight (the high bit) is set
+ on each byte except the last.
+
+ x A null byte.
+ X Back up a byte.
+ @ Null fill to absolute position.
+
+Each letter may optionally be followed by a number giving a repeat
+count. With all types except C<"a">, C<"A">, C<"b">, C<"B">, C<"h">, C<"H">, and C<"P"> the
+pack function will gobble up that many values from the LIST. A C<*> for the
+repeat count means to use however many items are left. The C<"a"> and C<"A">
+types gobble just one value, but pack it as a string of length count,
+padding with nulls or spaces as necessary. (When unpacking, C<"A"> strips
+trailing spaces and nulls, but C<"a"> does not.) Likewise, the C<"b"> and C<"B">
+fields pack a string that many bits long. The C<"h"> and C<"H"> fields pack a
+string that many nybbles long. The C<"p"> type packs a pointer to a null-
+terminated string. You are responsible for ensuring the string is not a
+temporary value (which can potentially get deallocated before you get
+around to using the packed result). The C<"P"> packs a pointer to a structure
+of the size indicated by the length. A NULL pointer is created if the
+corresponding value for C<"p"> or C<"P"> is C<undef>.
+Real numbers (floats and doubles) are
+in the native machine format only; due to the multiplicity of floating
+formats around, and the lack of a standard "network" representation, no
+facility for interchange has been made. This means that packed floating
+point data written on one machine may not be readable on another - even if
+both use IEEE floating point arithmetic (as the endian-ness of the memory
+representation is not part of the IEEE spec). Note that Perl uses doubles
+internally for all numeric calculation, and converting from double into
+float and thence back to double again will lose precision (i.e.,
+C<unpack("f", pack("f", $foo)>) will not in general equal C<$foo>).
+
+Examples:
+
+ $foo = pack("cccc",65,66,67,68);
+ # foo eq "ABCD"
+ $foo = pack("c4",65,66,67,68);
+ # same thing
+
+ $foo = pack("ccxxcc",65,66,67,68);
+ # foo eq "AB\0\0CD"
+
+ $foo = pack("s2",1,2);
+ # "\1\0\2\0" on little-endian
+ # "\0\1\0\2" on big-endian
+
+ $foo = pack("a4","abcd","x","y","z");
+ # "abcd"
+
+ $foo = pack("aaaa","abcd","x","y","z");
+ # "axyz"
+
+ $foo = pack("a14","abcdefg");
+ # "abcdefg\0\0\0\0\0\0\0"
+
+ $foo = pack("i9pl", gmtime);
+ # a real struct tm (on my system anyway)
+
+ sub bintodec {
+ unpack("N", pack("B32", substr("0" x 32 . shift, -32)));
+ }
+
+The same template may generally also be used in the unpack function.
+
+=item package
+
+=item package NAMESPACE
+
+Declares the compilation unit as being in the given namespace. The scope
+of the package declaration is from the declaration itself through the end of
+the enclosing block (the same scope as the C<local()> operator). All further
+unqualified dynamic identifiers will be in this namespace. A package
+statement affects only dynamic variables--including those you've used
+C<local()> on--but I<not> lexical variables created with C<my()>. Typically it
+would be the first declaration in a file to be included by the C<require>
+or C<use> operator. You can switch into a package in more than one place;
+it merely influences which symbol table is used by the compiler for the
+rest of that block. You can refer to variables and filehandles in other
+packages by prefixing the identifier with the package name and a double
+colon: C<$Package::Variable>. If the package name is null, the C<main>
+package as assumed. That is, C<$::sail> is equivalent to C<$main::sail>.
+
+If NAMESPACE is omitted, then there is no current package, and all
+identifiers must be fully qualified or lexicals. This is stricter
+than C<use strict>, since it also extends to function names.
+
+See L<perlmod/"Packages"> for more information about packages, modules,
+and classes. See L<perlsub> for other scoping issues.
+
+=item pipe READHANDLE,WRITEHANDLE
+
+Opens a pair of connected pipes like the corresponding system call.
+Note that if you set up a loop of piped processes, deadlock can occur
+unless you are very careful. In addition, note that Perl's pipes use
+stdio buffering, so you may need to set C<$|> to flush your WRITEHANDLE
+after each command, depending on the application.
+
+See L<IPC::Open2>, L<IPC::Open3>, and L<perlipc/"Bidirectional Communication">
+for examples of such things.
+
+=item pop ARRAY
+
+=item pop
+
+Pops and returns the last value of the array, shortening the array by
+1. Has a similar effect to
+
+ $tmp = $ARRAY[$#ARRAY--];
+
+If there are no elements in the array, returns the undefined value.
+If ARRAY is omitted, pops the
+C<@ARGV> array in the main program, and the C<@_> array in subroutines, just
+like C<shift()>.
+
+=item pos SCALAR
+
+=item pos
+
+Returns the offset of where the last C<m//g> search left off for the variable
+is in question (C<$_> is used when the variable is not specified). May be
+modified to change that offset. Such modification will also influence
+the C<\G> zero-width assertion in regular expressions. See L<perlre> and
+L<perlop>.
+
+=item print FILEHANDLE LIST
+
+=item print LIST
+
+=item print
+
+Prints a string or a comma-separated list of strings. Returns TRUE
+if successful. FILEHANDLE may be a scalar variable name, in which case
+the variable contains the name of or a reference to the filehandle, thus introducing one
+level of indirection. (NOTE: If FILEHANDLE is a variable and the next
+token is a term, it may be misinterpreted as an operator unless you
+interpose a C<+> or put parentheses around the arguments.) If FILEHANDLE is
+omitted, prints by default to standard output (or to the last selected
+output channel--see L</select>). If LIST is also omitted, prints C<$_> to
+the currently selected output channel. To set the default output channel to something other than
+STDOUT use the select operation. Note that, because print takes a
+LIST, anything in the LIST is evaluated in list context, and any
+subroutine that you call will have one or more of its expressions
+evaluated in list context. Also be careful not to follow the print
+keyword with a left parenthesis unless you want the corresponding right
+parenthesis to terminate the arguments to the print--interpose a C<+> or
+put parentheses around all the arguments.
+
+Note that if you're storing FILEHANDLES in an array or other expression,
+you will have to use a block returning its value instead:
+
+ print { $files[$i] } "stuff\n";
+ print { $OK ? STDOUT : STDERR } "stuff\n";
+
+=item printf FILEHANDLE FORMAT, LIST
+
+=item printf FORMAT, LIST
+
+Equivalent to C<print FILEHANDLE sprintf(FORMAT, LIST)>, except that C<$\>
+(the output record separator) is not appended. The first argument
+of the list will be interpreted as the C<printf()> format. If C<use locale> is
+in effect, the character used for the decimal point in formatted real numbers
+is affected by the LC_NUMERIC locale. See L<perllocale>.
+
+Don't fall into the trap of using a C<printf()> when a simple
+C<print()> would do. The C<print()> is more efficient and less
+error prone.
+
+=item prototype FUNCTION
+
+Returns the prototype of a function as a string (or C<undef> if the
+function has no prototype). FUNCTION is a reference to, or the name of,
+the function whose prototype you want to retrieve.
+
+If FUNCTION is a string starting with C<CORE::>, the rest is taken as
+a name for Perl builtin. If builtin is not I<overridable> (such as
+C<qw//>) or its arguments cannot be expressed by a prototype (such as
+C<system()>) - in other words, the builtin does not behave like a Perl
+function - returns C<undef>. Otherwise, the string describing the
+equivalent prototype is returned.
+
+=item push ARRAY,LIST
+
+Treats ARRAY as a stack, and pushes the values of LIST
+onto the end of ARRAY. The length of ARRAY increases by the length of
+LIST. Has the same effect as
+
+ for $value (LIST) {
+ $ARRAY[++$#ARRAY] = $value;
+ }
+
+but is more efficient. Returns the new number of elements in the array.
+
+=item q/STRING/
+
+=item qq/STRING/
+
+=item qr/STRING/
+
+=item qx/STRING/
+
+=item qw/STRING/
+
+Generalized quotes. See L<perlop>.
+
+=item quotemeta EXPR
+
+=item quotemeta
+
+Returns the value of EXPR with all non-alphanumeric
+characters backslashed. (That is, all characters not matching
+C</[A-Za-z_0-9]/> will be preceded by a backslash in the
+returned string, regardless of any locale settings.)
+This is the internal function implementing
+the C<\Q> escape in double-quoted strings.
+
+If EXPR is omitted, uses C<$_>.
+
+=item rand EXPR
+
+=item rand
+
+Returns a random fractional number greater than or equal to C<0> and less
+than the value of EXPR. (EXPR should be positive.) If EXPR is
+omitted, the value C<1> is used. Automatically calls C<srand()> unless
+C<srand()> has already been called. See also C<srand()>.
+
+(Note: If your rand function consistently returns numbers that are too
+large or too small, then your version of Perl was probably compiled
+with the wrong number of RANDBITS.)
+
+=item read FILEHANDLE,SCALAR,LENGTH,OFFSET
+
+=item read FILEHANDLE,SCALAR,LENGTH
+
+Attempts to read LENGTH bytes of data into variable SCALAR from the
+specified FILEHANDLE. Returns the number of bytes actually read,
+C<0> at end of file, or undef if there was an error. SCALAR will be grown
+or shrunk to the length actually read. An OFFSET may be specified to
+place the read data at some other place than the beginning of the
+string. This call is actually implemented in terms of stdio's fread(3)
+call. To get a true read(2) system call, see C<sysread()>.
+
+=item readdir DIRHANDLE
+
+Returns the next directory entry for a directory opened by C<opendir()>.
+If used in list context, returns all the rest of the entries in the
+directory. If there are no more entries, returns an undefined value in
+scalar context or a null list in list context.
+
+If you're planning to filetest the return values out of a C<readdir()>, you'd
+better prepend the directory in question. Otherwise, because we didn't
+C<chdir()> there, it would have been testing the wrong file.
+
+ opendir(DIR, $some_dir) || die "can't opendir $some_dir: $!";
+ @dots = grep { /^\./ && -f "$some_dir/$_" } readdir(DIR);
+ closedir DIR;
+
+=item readline EXPR
+
+Reads from the filehandle whose typeglob is contained in EXPR. In scalar context, a single line
+is read and returned. In list context, reads until end-of-file is
+reached and returns a list of lines (however you've defined lines
+with C<$/> or C<$INPUT_RECORD_SEPARATOR>).
+This is the internal function implementing the C<E<lt>EXPRE<gt>>
+operator, but you can use it directly. The C<E<lt>EXPRE<gt>>
+operator is discussed in more detail in L<perlop/"I/O Operators">.
+
+ $line = <STDIN>;
+ $line = readline(*STDIN); # same thing
+
+=item readlink EXPR
+
+=item readlink
+
+Returns the value of a symbolic link, if symbolic links are
+implemented. If not, gives a fatal error. If there is some system
+error, returns the undefined value and sets C<$!> (errno). If EXPR is
+omitted, uses C<$_>.
+
+=item readpipe EXPR
+
+EXPR is executed as a system command.
+The collected standard output of the command is returned.
+In scalar context, it comes back as a single (potentially
+multi-line) string. In list context, returns a list of lines
+(however you've defined lines with C<$/> or C<$INPUT_RECORD_SEPARATOR>).
+This is the internal function implementing the C<qx/EXPR/>
+operator, but you can use it directly. The C<qx/EXPR/>
+operator is discussed in more detail in L<perlop/"I/O Operators">.
+
+=item recv SOCKET,SCALAR,LEN,FLAGS
+
+Receives a message on a socket. Attempts to receive LENGTH bytes of
+data into variable SCALAR from the specified SOCKET filehandle.
+Actually does a C C<recvfrom()>, so that it can return the address of the
+sender. Returns the undefined value if there's an error. SCALAR will
+be grown or shrunk to the length actually read. Takes the same flags
+as the system call of the same name.
+See L<perlipc/"UDP: Message Passing"> for examples.
+
+=item redo LABEL
+
+=item redo
+
+The C<redo> command restarts the loop block without evaluating the
+conditional again. The C<continue> block, if any, is not executed. If
+the LABEL is omitted, the command refers to the innermost enclosing
+loop. This command is normally used by programs that want to lie to
+themselves about what was just input:
+
+ # a simpleminded Pascal comment stripper
+ # (warning: assumes no { or } in strings)
+ LINE: while (<STDIN>) {
+ while (s|({.*}.*){.*}|$1 |) {}
+ s|{.*}| |;
+ if (s|{.*| |) {
+ $front = $_;
+ while (<STDIN>) {
+ if (/}/) { # end of comment?
+ s|^|$front\{|;
+ redo LINE;
+ }
+ }
+ }
+ print;
+ }
+
+See also L</continue> for an illustration of how C<last>, C<next>, and
+C<redo> work.
+
+=item ref EXPR
+
+=item ref
+
+Returns a TRUE value if EXPR is a reference, FALSE otherwise. If EXPR
+is not specified, C<$_> will be used. The value returned depends on the
+type of thing the reference is a reference to.
+Builtin types include:
+
+ REF
+ SCALAR
+ ARRAY
+ HASH
+ CODE
+ GLOB
+
+If the referenced object has been blessed into a package, then that package
+name is returned instead. You can think of C<ref()> as a C<typeof()> operator.
+
+ if (ref($r) eq "HASH") {
+ print "r is a reference to a hash.\n";
+ }
+ if (!ref($r)) {
+ print "r is not a reference at all.\n";
+ }
+
+See also L<perlref>.
+
+=item rename OLDNAME,NEWNAME
+
+Changes the name of a file. Returns C<1> for success, C<0> otherwise. Will
+not work across file system boundaries.
+
+=item require EXPR
+
+=item require
+
+Demands some semantics specified by EXPR, or by C<$_> if EXPR is not
+supplied. If EXPR is numeric, demands that the current version of Perl
+(C<$]> or $PERL_VERSION) be equal or greater than EXPR.
+
+Otherwise, demands that a library file be included if it hasn't already
+been included. The file is included via the do-FILE mechanism, which is
+essentially just a variety of C<eval()>. Has semantics similar to the following
+subroutine:
+
+ sub require {
+ my($filename) = @_;
+ return 1 if $INC{$filename};
+ my($realfilename,$result);
+ ITER: {
+ foreach $prefix (@INC) {
+ $realfilename = "$prefix/$filename";
+ if (-f $realfilename) {
+ $result = do $realfilename;
+ last ITER;
+ }
+ }
+ die "Can't find $filename in \@INC";
+ }
+ die $@ if $@;
+ die "$filename did not return true value" unless $result;
+ $INC{$filename} = $realfilename;
+ return $result;
+ }
+
+Note that the file will not be included twice under the same specified
+name. The file must return TRUE as the last statement to indicate
+successful execution of any initialization code, so it's customary to
+end such a file with "C<1;>" unless you're sure it'll return TRUE
+otherwise. But it's better just to put the "C<1;>", in case you add more
+statements.
+
+If EXPR is a bareword, the require assumes a "F<.pm>" extension and
+replaces "F<::>" with "F</>" in the filename for you,
+to make it easy to load standard modules. This form of loading of
+modules does not risk altering your namespace.
+
+In other words, if you try this:
+
+ require Foo::Bar; # a splendid bareword
+
+The require function will actually look for the "F<Foo/Bar.pm>" file in the
+directories specified in the C<@INC> array.
+
+But if you try this:
+
+ $class = 'Foo::Bar';
+ require $class; # $class is not a bareword
+ #or
+ require "Foo::Bar"; # not a bareword because of the ""
+
+The require function will look for the "F<Foo::Bar>" file in the @INC array and
+will complain about not finding "F<Foo::Bar>" there. In this case you can do:
+
+ eval "require $class";
+
+For a yet-more-powerful import facility, see L</use> and L<perlmod>.
+
+=item reset EXPR
+
+=item reset
+
+Generally used in a C<continue> block at the end of a loop to clear
+variables and reset C<??> searches so that they work again. The
+expression is interpreted as a list of single characters (hyphens
+allowed for ranges). All variables and arrays beginning with one of
+those letters are reset to their pristine state. If the expression is
+omitted, one-match searches (C<?pattern?>) are reset to match again. Resets
+only variables or searches in the current package. Always returns
+1. Examples:
+
+ reset 'X'; # reset all X variables
+ reset 'a-z'; # reset lower case variables
+ reset; # just reset ?? searches
+
+Resetting C<"A-Z"> is not recommended because you'll wipe out your
+C<@ARGV> and C<@INC> arrays and your C<%ENV> hash. Resets only package variables--lexical variables
+are unaffected, but they clean themselves up on scope exit anyway,
+so you'll probably want to use them instead. See L</my>.
+
+=item return EXPR
+
+=item return
+
+Returns from a subroutine, C<eval()>, or C<do FILE> with the value
+given in EXPR. Evaluation of EXPR may be in list, scalar, or void
+context, depending on how the return value will be used, and the context
+may vary from one execution to the next (see C<wantarray()>). If no EXPR
+is given, returns an empty list in list context, an undefined value in
+scalar context, or nothing in a void context.
+
+(Note that in the absence of a return, a subroutine, eval, or do FILE
+will automatically return the value of the last expression evaluated.)
+
+=item reverse LIST
+
+In list context, returns a list value consisting of the elements
+of LIST in the opposite order. In scalar context, concatenates the
+elements of LIST, and returns a string value consisting of those bytes,
+but in the opposite order.
+
+ print reverse <>; # line tac, last line first
+
+ undef $/; # for efficiency of <>
+ print scalar reverse <>; # byte tac, last line tsrif
+
+This operator is also handy for inverting a hash, although there are some
+caveats. If a value is duplicated in the original hash, only one of those
+can be represented as a key in the inverted hash. Also, this has to
+unwind one hash and build a whole new one, which may take some time
+on a large hash.
+
+ %by_name = reverse %by_address; # Invert the hash
+
+=item rewinddir DIRHANDLE
+
+Sets the current position to the beginning of the directory for the
+C<readdir()> routine on DIRHANDLE.
+
+=item rindex STR,SUBSTR,POSITION
+
+=item rindex STR,SUBSTR
+
+Works just like index except that it returns the position of the LAST
+occurrence of SUBSTR in STR. If POSITION is specified, returns the
+last occurrence at or before that position.
+
+=item rmdir FILENAME
+
+=item rmdir
+
+Deletes the directory specified by FILENAME if that directory is empty. If it
+succeeds it returns TRUE, otherwise it returns FALSE and sets C<$!> (errno). If
+FILENAME is omitted, uses C<$_>.
+
+=item s///
+
+The substitution operator. See L<perlop>.
+
+=item scalar EXPR
+
+Forces EXPR to be interpreted in scalar context and returns the value
+of EXPR.
+
+ @counts = ( scalar @a, scalar @b, scalar @c );
+
+There is no equivalent operator to force an expression to
+be interpolated in list context because it's in practice never
+needed. If you really wanted to do so, however, you could use
+the construction C<@{[ (some expression) ]}>, but usually a simple
+C<(some expression)> suffices.
+
+=item seek FILEHANDLE,POSITION,WHENCE
+
+Sets FILEHANDLE's position, just like the C<fseek()> call of C<stdio()>.
+FILEHANDLE may be an expression whose value gives the name of the
+filehandle. The values for WHENCE are C<0> to set the new position to
+POSITION, C<1> to set it to the current position plus POSITION, and C<2> to
+set it to EOF plus POSITION (typically negative). For WHENCE you may
+use the constants C<SEEK_SET>, C<SEEK_CUR>, and C<SEEK_END> from either the
+C<IO::Seekable> or the POSIX module. Returns C<1> upon success, C<0> otherwise.
+
+If you want to position file for C<sysread()> or C<syswrite()>, don't use
+C<seek()> -- buffering makes its effect on the file's system position
+unpredictable and non-portable. Use C<sysseek()> instead.
+
+On some systems you have to do a seek whenever you switch between reading
+and writing. Amongst other things, this may have the effect of calling
+stdio's clearerr(3). A WHENCE of C<1> (C<SEEK_CUR>) is useful for not moving
+the file position:
+
+ seek(TEST,0,1);
+
+This is also useful for applications emulating C<tail -f>. Once you hit
+EOF on your read, and then sleep for a while, you might have to stick in a
+seek() to reset things. The C<seek()> doesn't change the current position,
+but it I<does> clear the end-of-file condition on the handle, so that the
+next C<E<lt>FILEE<gt>> makes Perl try again to read something. We hope.
+
+If that doesn't work (some stdios are particularly cantankerous), then
+you may need something more like this:
+
+ for (;;) {
+ for ($curpos = tell(FILE); $_ = <FILE>;
+ $curpos = tell(FILE)) {
+ # search for some stuff and put it into files
+ }
+ sleep($for_a_while);
+ seek(FILE, $curpos, 0);
+ }
+
+=item seekdir DIRHANDLE,POS
+
+Sets the current position for the C<readdir()> routine on DIRHANDLE. POS
+must be a value returned by C<telldir()>. Has the same caveats about
+possible directory compaction as the corresponding system library
+routine.
+
+=item select FILEHANDLE
+
+=item select
+
+Returns the currently selected filehandle. Sets the current default
+filehandle for output, if FILEHANDLE is supplied. This has two
+effects: first, a C<write()> or a C<print()> without a filehandle will
+default to this FILEHANDLE. Second, references to variables related to
+output will refer to this output channel. For example, if you have to
+set the top of form format for more than one output channel, you might
+do the following:
+
+ select(REPORT1);
+ $^ = 'report1_top';
+ select(REPORT2);
+ $^ = 'report2_top';
+
+FILEHANDLE may be an expression whose value gives the name of the
+actual filehandle. Thus:
+
+ $oldfh = select(STDERR); $| = 1; select($oldfh);
+
+Some programmers may prefer to think of filehandles as objects with
+methods, preferring to write the last example as:
+
+ use IO::Handle;
+ STDERR->autoflush(1);
+
+=item select RBITS,WBITS,EBITS,TIMEOUT
+
+This calls the select(2) system call with the bit masks specified, which
+can be constructed using C<fileno()> and C<vec()>, along these lines:
+
+ $rin = $win = $ein = '';
+ vec($rin,fileno(STDIN),1) = 1;
+ vec($win,fileno(STDOUT),1) = 1;
+ $ein = $rin | $win;
+
+If you want to select on many filehandles you might wish to write a
+subroutine:
+
+ sub fhbits {
+ my(@fhlist) = split(' ',$_[0]);
+ my($bits);
+ for (@fhlist) {
+ vec($bits,fileno($_),1) = 1;
+ }
+ $bits;
+ }
+ $rin = fhbits('STDIN TTY SOCK');
+
+The usual idiom is:
+
+ ($nfound,$timeleft) =
+ select($rout=$rin, $wout=$win, $eout=$ein, $timeout);
+
+or to block until something becomes ready just do this
+
+ $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef);
+
+Most systems do not bother to return anything useful in C<$timeleft>, so
+calling select() in scalar context just returns C<$nfound>.
+
+Any of the bit masks can also be undef. The timeout, if specified, is
+in seconds, which may be fractional. Note: not all implementations are
+capable of returning theC<$timeleft>. If not, they always return
+C<$timeleft> equal to the supplied C<$timeout>.
+
+You can effect a sleep of 250 milliseconds this way:
+
+ select(undef, undef, undef, 0.25);
+
+B<WARNING>: One should not attempt to mix buffered I/O (like C<read()>
+or E<lt>FHE<gt>) with C<select()>, except as permitted by POSIX, and even
+then only on POSIX systems. You have to use C<sysread()> instead.
+
+=item semctl ID,SEMNUM,CMD,ARG
+
+Calls the System V IPC function C<semctl()>. You'll probably have to say
+
+ use IPC::SysV;
+
+first to get the correct constant definitions. If CMD is IPC_STAT or
+GETALL, then ARG must be a variable which will hold the returned
+semid_ds structure or semaphore value array. Returns like C<ioctl()>: the
+undefined value for error, "C<0> but true" for zero, or the actual return
+value otherwise. See also C<IPC::SysV> and C<IPC::Semaphore> documentation.
+
+=item semget KEY,NSEMS,FLAGS
+
+Calls the System V IPC function semget. Returns the semaphore id, or
+the undefined value if there is an error. See also C<IPC::SysV> and
+C<IPC::SysV::Semaphore> documentation.
+
+=item semop KEY,OPSTRING
+
+Calls the System V IPC function semop to perform semaphore operations
+such as signaling and waiting. OPSTRING must be a packed array of
+semop structures. Each semop structure can be generated with
+C<pack("sss", $semnum, $semop, $semflag)>. The number of semaphore
+operations is implied by the length of OPSTRING. Returns TRUE if
+successful, or FALSE if there is an error. As an example, the
+following code waits on semaphore C<$semnum> of semaphore id C<$semid>:
+
+ $semop = pack("sss", $semnum, -1, 0);
+ die "Semaphore trouble: $!\n" unless semop($semid, $semop);
+
+To signal the semaphore, replace C<-1> with C<1>. See also C<IPC::SysV>
+and C<IPC::SysV::Semaphore> documentation.
+
+=item send SOCKET,MSG,FLAGS,TO
+
+=item send SOCKET,MSG,FLAGS
+
+Sends a message on a socket. Takes the same flags as the system call
+of the same name. On unconnected sockets you must specify a
+destination to send TO, in which case it does a C C<sendto()>. Returns
+the number of characters sent, or the undefined value if there is an
+error.
+See L<perlipc/"UDP: Message Passing"> for examples.
+
+=item setpgrp PID,PGRP
+
+Sets the current process group for the specified PID, C<0> for the current
+process. Will produce a fatal error if used on a machine that doesn't
+implement setpgrp(2). If the arguments are omitted, it defaults to
+C<0,0>. Note that the POSIX version of C<setpgrp()> does not accept any
+arguments, so only setpgrp C<0,0> is portable.
+
+=item setpriority WHICH,WHO,PRIORITY
+
+Sets the current priority for a process, a process group, or a user.
+(See setpriority(2).) Will produce a fatal error if used on a machine
+that doesn't implement setpriority(2).
+
+=item setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL
+
+Sets the socket option requested. Returns undefined if there is an
+error. OPTVAL may be specified as C<undef> if you don't want to pass an
+argument.
+
+=item shift ARRAY
+
+=item shift
+
+Shifts the first value of the array off and returns it, shortening the
+array by 1 and moving everything down. If there are no elements in the
+array, returns the undefined value. If ARRAY is omitted, shifts the
+C<@_> array within the lexical scope of subroutines and formats, and the
+C<@ARGV> array at file scopes or within the lexical scopes established by
+the C<eval ''>, C<BEGIN {}>, C<END {}>, and C<INIT {}> constructs.
+See also C<unshift()>, C<push()>, and C<pop()>. C<Shift()> and C<unshift()> do the
+same thing to the left end of an array that C<pop()> and C<push()> do to the
+right end.
+
+=item shmctl ID,CMD,ARG
+
+Calls the System V IPC function shmctl. You'll probably have to say
+
+ use IPC::SysV;
+
+first to get the correct constant definitions. If CMD is C<IPC_STAT>,
+then ARG must be a variable which will hold the returned C<shmid_ds>
+structure. Returns like ioctl: the undefined value for error, "C<0> but
+true" for zero, or the actual return value otherwise.
+See also C<IPC::SysV> documentation.
+
+=item shmget KEY,SIZE,FLAGS
+
+Calls the System V IPC function shmget. Returns the shared memory
+segment id, or the undefined value if there is an error.
+See also C<IPC::SysV> documentation.
+
+=item shmread ID,VAR,POS,SIZE
+
+=item shmwrite ID,STRING,POS,SIZE
+
+Reads or writes the System V shared memory segment ID starting at
+position POS for size SIZE by attaching to it, copying in/out, and
+detaching from it. When reading, VAR must be a variable that will
+hold the data read. When writing, if STRING is too long, only SIZE
+bytes are used; if STRING is too short, nulls are written to fill out
+SIZE bytes. Return TRUE if successful, or FALSE if there is an error.
+See also C<IPC::SysV> documentation.
+
+=item shutdown SOCKET,HOW
+
+Shuts down a socket connection in the manner indicated by HOW, which
+has the same interpretation as in the system call of the same name.
+
+ shutdown(SOCKET, 0); # I/we have stopped reading data
+ shutdown(SOCKET, 1); # I/we have stopped writing data
+ shutdown(SOCKET, 2); # I/we have stopped using this socket
+
+This is useful with sockets when you want to tell the other
+side you're done writing but not done reading, or vice versa.
+It's also a more insistent form of close because it also
+disables the filedescriptor in any forked copies in other
+processes.
+
+=item sin EXPR
+
+=item sin
+
+Returns the sine of EXPR (expressed in radians). If EXPR is omitted,
+returns sine of C<$_>.
+
+For the inverse sine operation, you may use the C<POSIX::asin()>
+function, or use this relation:
+
+ sub asin { atan2($_[0], sqrt(1 - $_[0] * $_[0])) }
+
+=item sleep EXPR
+
+=item sleep
+
+Causes the script to sleep for EXPR seconds, or forever if no EXPR.
+May be interrupted if the process receives a signal such as C<SIGALRM>.
+Returns the number of seconds actually slept. You probably cannot
+mix C<alarm()> and C<sleep()> calls, because C<sleep()> is often implemented
+using C<alarm()>.
+
+On some older systems, it may sleep up to a full second less than what
+you requested, depending on how it counts seconds. Most modern systems
+always sleep the full amount. They may appear to sleep longer than that,
+however, because your process might not be scheduled right away in a
+busy multitasking system.
+
+For delays of finer granularity than one second, you may use Perl's
+C<syscall()> interface to access setitimer(2) if your system supports it,
+or else see L</select()> above.
+
+See also the POSIX module's C<sigpause()> function.
+
+=item socket SOCKET,DOMAIN,TYPE,PROTOCOL
+
+Opens a socket of the specified kind and attaches it to filehandle
+SOCKET. DOMAIN, TYPE, and PROTOCOL are specified the same as for the
+system call of the same name. You should "C<use Socket;>" first to get
+the proper definitions imported. See the example in L<perlipc/"Sockets: Client/Server Communication">.
+
+=item socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL
+
+Creates an unnamed pair of sockets in the specified domain, of the
+specified type. DOMAIN, TYPE, and PROTOCOL are specified the same as
+for the system call of the same name. If unimplemented, yields a fatal
+error. Returns TRUE if successful.
+
+Some systems defined C<pipe()> in terms of C<socketpair()>, in which a call
+to C<pipe(Rdr, Wtr)> is essentially:
+
+ use Socket;
+ socketpair(Rdr, Wtr, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
+ shutdown(Rdr, 1); # no more writing for reader
+ shutdown(Wtr, 0); # no more reading for writer
+
+See L<perlipc> for an example of socketpair use.
+
+=item sort SUBNAME LIST
+
+=item sort BLOCK LIST
+
+=item sort LIST
+
+Sorts the LIST and returns the sorted list value. If SUBNAME or BLOCK
+is omitted, C<sort()>s in standard string comparison order. If SUBNAME is
+specified, it gives the name of a subroutine that returns an integer
+less than, equal to, or greater than C<0>, depending on how the elements
+of the array are to be ordered. (The C<E<lt>=E<gt>> and C<cmp>
+operators are extremely useful in such routines.) SUBNAME may be a
+scalar variable name (unsubscripted), in which case the value provides
+the name of (or a reference to) the actual subroutine to use. In place
+of a SUBNAME, you can provide a BLOCK as an anonymous, in-line sort
+subroutine.
+
+In the interests of efficiency the normal calling code for subroutines is
+bypassed, with the following effects: the subroutine may not be a
+recursive subroutine, and the two elements to be compared are passed into
+the subroutine not via C<@_> but as the package global variables C<$a> and
+C<$b> (see example below). They are passed by reference, so don't
+modify C<$a> and C<$b>. And don't try to declare them as lexicals either.
+
+You also cannot exit out of the sort block or subroutine using any of the
+loop control operators described in L<perlsyn> or with C<goto()>.
+
+When C<use locale> is in effect, C<sort LIST> sorts LIST according to the
+current collation locale. See L<perllocale>.
+
+Examples:
+
+ # sort lexically
+ @articles = sort @files;
+
+ # same thing, but with explicit sort routine
+ @articles = sort {$a cmp $b} @files;
+
+ # now case-insensitively
+ @articles = sort {uc($a) cmp uc($b)} @files;
+
+ # same thing in reversed order
+ @articles = sort {$b cmp $a} @files;
+
+ # sort numerically ascending
+ @articles = sort {$a <=> $b} @files;
+
+ # sort numerically descending
+ @articles = sort {$b <=> $a} @files;
+
+ # sort using explicit subroutine name
+ sub byage {
+ $age{$a} <=> $age{$b}; # presuming numeric
+ }
+ @sortedclass = sort byage @class;
+
+ # this sorts the %age hash by value instead of key
+ # using an in-line function
+ @eldest = sort { $age{$b} <=> $age{$a} } keys %age;
+
+ sub backwards { $b cmp $a; }
+ @harry = ('dog','cat','x','Cain','Abel');
+ @george = ('gone','chased','yz','Punished','Axed');
+ print sort @harry;
+ # prints AbelCaincatdogx
+ print sort backwards @harry;
+ # prints xdogcatCainAbel
+ print sort @george, 'to', @harry;
+ # prints AbelAxedCainPunishedcatchaseddoggonetoxyz
+
+ # inefficiently sort by descending numeric compare using
+ # the first integer after the first = sign, or the
+ # whole record case-insensitively otherwise
+
+ @new = sort {
+ ($b =~ /=(\d+)/)[0] <=> ($a =~ /=(\d+)/)[0]
+ ||
+ uc($a) cmp uc($b)
+ } @old;
+
+ # same thing, but much more efficiently;
+ # we'll build auxiliary indices instead
+ # for speed
+ @nums = @caps = ();
+ for (@old) {
+ push @nums, /=(\d+)/;
+ push @caps, uc($_);
+ }
+
+ @new = @old[ sort {
+ $nums[$b] <=> $nums[$a]
+ ||
+ $caps[$a] cmp $caps[$b]
+ } 0..$#old
+ ];
+
+ # same thing using a Schwartzian Transform (no temps)
+ @new = map { $_->[0] }
+ sort { $b->[1] <=> $a->[1]
+ ||
+ $a->[2] cmp $b->[2]
+ } map { [$_, /=(\d+)/, uc($_)] } @old;
+
+If you're using strict, you I<MUST NOT> declare C<$a>
+and C<$b> as lexicals. They are package globals. That means
+if you're in the C<main> package, it's
+
+ @articles = sort {$main::b <=> $main::a} @files;
+
+or just
+
+ @articles = sort {$::b <=> $::a} @files;
+
+but if you're in the C<FooPack> package, it's
+
+ @articles = sort {$FooPack::b <=> $FooPack::a} @files;
+
+The comparison function is required to behave. If it returns
+inconsistent results (sometimes saying C<$x[1]> is less than C<$x[2]> and
+sometimes saying the opposite, for example) the results are not
+well-defined.
+
+=item splice ARRAY,OFFSET,LENGTH,LIST
+
+=item splice ARRAY,OFFSET,LENGTH
+
+=item splice ARRAY,OFFSET
+
+Removes the elements designated by OFFSET and LENGTH from an array, and
+replaces them with the elements of LIST, if any. In list context,
+returns the elements removed from the array. In scalar context,
+returns the last element removed, or C<undef> if no elements are
+removed. The array grows or shrinks as necessary.
+If OFFSET is negative then it start that far from the end of the array.
+If LENGTH is omitted, removes everything from OFFSET onward.
+If LENGTH is negative, leave that many elements off the end of the array.
+The following equivalences hold (assuming C<$[ == 0>):
+
+ push(@a,$x,$y) splice(@a,@a,0,$x,$y)
+ pop(@a) splice(@a,-1)
+ shift(@a) splice(@a,0,1)
+ unshift(@a,$x,$y) splice(@a,0,0,$x,$y)
+ $a[$x] = $y splice(@a,$x,1,$y)
+
+Example, assuming array lengths are passed before arrays:
+
+ sub aeq { # compare two list values
+ my(@a) = splice(@_,0,shift);
+ my(@b) = splice(@_,0,shift);
+ return 0 unless @a == @b; # same len?
+ while (@a) {
+ return 0 if pop(@a) ne pop(@b);
+ }
+ return 1;
+ }
+ if (&aeq($len,@foo[1..$len],0+@bar,@bar)) { ... }
+
+=item split /PATTERN/,EXPR,LIMIT
+
+=item split /PATTERN/,EXPR
+
+=item split /PATTERN/
+
+=item split
+
+Splits a string into an array of strings, and returns it. By default,
+empty leading fields are preserved, and empty trailing ones are deleted.
+
+If not in list context, returns the number of fields found and splits into
+the C<@_> array. (In list context, you can force the split into C<@_> by
+using C<??> as the pattern delimiters, but it still returns the list
+value.) The use of implicit split to C<@_> is deprecated, however, because
+it clobbers your subroutine arguments.
+
+If EXPR is omitted, splits the C<$_> string. If PATTERN is also omitted,
+splits on whitespace (after skipping any leading whitespace). Anything
+matching PATTERN is taken to be a delimiter separating the fields. (Note
+that the delimiter may be longer than one character.)
+
+If LIMIT is specified and positive, splits into no more than that
+many fields (though it may split into fewer). If LIMIT is unspecified
+or zero, trailing null fields are stripped (which potential users
+of C<pop()> would do well to remember). If LIMIT is negative, it is
+treated as if an arbitrarily large LIMIT had been specified.
+
+A pattern matching the null string (not to be confused with
+a null pattern C<//>, which is just one member of the set of patterns
+matching a null string) will split the value of EXPR into separate
+characters at each point it matches that way. For example:
+
+ print join(':', split(/ */, 'hi there'));
+
+produces the output 'h:i:t:h:e:r:e'.
+
+The LIMIT parameter can be used to split a line partially
+
+ ($login, $passwd, $remainder) = split(/:/, $_, 3);
+
+When assigning to a list, if LIMIT is omitted, Perl supplies a LIMIT
+one larger than the number of variables in the list, to avoid
+unnecessary work. For the list above LIMIT would have been 4 by
+default. In time critical applications it behooves you not to split
+into more fields than you really need.
+
+If the PATTERN contains parentheses, additional array elements are
+created from each matching substring in the delimiter.
+
+ split(/([,-])/, "1-10,20", 3);
+
+produces the list value
+
+ (1, '-', 10, ',', 20)
+
+If you had the entire header of a normal Unix email message in C<$header>,
+you could split it up into fields and their values this way:
+
+ $header =~ s/\n\s+/ /g; # fix continuation lines
+ %hdrs = (UNIX_FROM => split /^(\S*?):\s*/m, $header);
+
+The pattern C</PATTERN/> may be replaced with an expression to specify
+patterns that vary at runtime. (To do runtime compilation only once,
+use C</$variable/o>.)
+
+As a special case, specifying a PATTERN of space (C<' '>) will split on
+white space just as C<split()> with no arguments does. Thus, C<split(' ')> can
+be used to emulate B<awk>'s default behavior, whereas C<split(/ /)>
+will give you as many null initial fields as there are leading spaces.
+A C<split()> on C</\s+/> is like a C<split(' ')> except that any leading
+whitespace produces a null first field. A C<split()> with no arguments
+really does a C<split(' ', $_)> internally.
+
+Example:
+
+ open(PASSWD, '/etc/passwd');
+ while (<PASSWD>) {
+ ($login, $passwd, $uid, $gid,
+ $gcos, $home, $shell) = split(/:/);
+ #...
+ }
+
+(Note that C<$shell> above will still have a newline on it. See L</chop>,
+L</chomp>, and L</join>.)
+
+=item sprintf FORMAT, LIST
+
+Returns a string formatted by the usual C<printf()> conventions of the
+C library function C<sprintf()>. See L<sprintf(3)> or L<printf(3)>
+on your system for an explanation of the general principles.
+
+Perl does its own C<sprintf()> formatting -- it emulates the C
+function C<sprintf()>, but it doesn't use it (except for floating-point
+numbers, and even then only the standard modifiers are allowed). As a
+result, any non-standard extensions in your local C<sprintf()> are not
+available from Perl.
+
+Perl's C<sprintf()> permits the following universally-known conversions:
+
+ %% a percent sign
+ %c a character with the given number
+ %s a string
+ %d a signed integer, in decimal
+ %u an unsigned integer, in decimal
+ %o an unsigned integer, in octal
+ %x an unsigned integer, in hexadecimal
+ %e a floating-point number, in scientific notation
+ %f a floating-point number, in fixed decimal notation
+ %g a floating-point number, in %e or %f notation
+
+In addition, Perl permits the following widely-supported conversions:
+
+ %X like %x, but using upper-case letters
+ %E like %e, but using an upper-case "E"
+ %G like %g, but with an upper-case "E" (if applicable)
+ %p a pointer (outputs the Perl value's address in hexadecimal)
+ %n special: *stores* the number of characters output so far
+ into the next variable in the parameter list
+
+Finally, for backward (and we do mean "backward") compatibility, Perl
+permits these unnecessary but widely-supported conversions:
+
+ %i a synonym for %d
+ %D a synonym for %ld
+ %U a synonym for %lu
+ %O a synonym for %lo
+ %F a synonym for %f
+
+Perl permits the following universally-known flags between the C<%>
+and the conversion letter:
+
+ space prefix positive number with a space
+ + prefix positive number with a plus sign
+ - left-justify within the field
+ 0 use zeros, not spaces, to right-justify
+ # prefix non-zero octal with "0", non-zero hex with "0x"
+ number minimum field width
+ .number "precision": digits after decimal point for
+ floating-point, max length for string, minimum length
+ for integer
+ l interpret integer as C type "long" or "unsigned long"
+ h interpret integer as C type "short" or "unsigned short"
+
+There is also one Perl-specific flag:
+
+ V interpret integer as Perl's standard integer type
+
+Where a number would appear in the flags, an asterisk ("C<*>") may be
+used instead, in which case Perl uses the next item in the parameter
+list as the given number (that is, as the field width or precision).
+If a field width obtained through "C<*>" is negative, it has the same
+effect as the "C<->" flag: left-justification.
+
+If C<use locale> is in effect, the character used for the decimal
+point in formatted real numbers is affected by the LC_NUMERIC locale.
+See L<perllocale>.
+
+=item sqrt EXPR
+
+=item sqrt
+
+Return the square root of EXPR. If EXPR is omitted, returns square
+root of C<$_>.
+
+=item srand EXPR
+
+=item srand
+
+Sets the random number seed for the C<rand()> operator. If EXPR is
+omitted, uses a semi-random value based on the current time and process
+ID, among other things. In versions of Perl prior to 5.004 the default
+seed was just the current C<time()>. This isn't a particularly good seed,
+so many old programs supply their own seed value (often C<time ^ $$> or
+C<time ^ ($$ + ($$ E<lt>E<lt> 15))>), but that isn't necessary any more.
+
+In fact, it's usually not necessary to call C<srand()> at all, because if
+it is not called explicitly, it is called implicitly at the first use of
+the C<rand()> operator. However, this was not the case in version of Perl
+before 5.004, so if your script will run under older Perl versions, it
+should call C<srand()>.
+
+Note that you need something much more random than the default seed for
+cryptographic purposes. Checksumming the compressed output of one or more
+rapidly changing operating system status programs is the usual method. For
+example:
+
+ srand (time ^ $$ ^ unpack "%L*", `ps axww | gzip`);
+
+If you're particularly concerned with this, see the C<Math::TrulyRandom>
+module in CPAN.
+
+Do I<not> call C<srand()> multiple times in your program unless you know
+exactly what you're doing and why you're doing it. The point of the
+function is to "seed" the C<rand()> function so that C<rand()> can produce
+a different sequence each time you run your program. Just do it once at the
+top of your program, or you I<won't> get random numbers out of C<rand()>!
+
+Frequently called programs (like CGI scripts) that simply use
+
+ time ^ $$
+
+for a seed can fall prey to the mathematical property that
+
+ a^b == (a+1)^(b+1)
+
+one-third of the time. So don't do that.
+
+=item stat FILEHANDLE
+
+=item stat EXPR
+
+=item stat
+
+Returns a 13-element list giving the status info for a file, either
+the file opened via FILEHANDLE, or named by EXPR. If EXPR is omitted,
+it stats C<$_>. Returns a null list if the stat fails. Typically used
+as follows:
+
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = stat($filename);
+
+Not all fields are supported on all filesystem types. Here are the
+meaning of the fields:
+
+ 0 dev device number of filesystem
+ 1 ino inode number
+ 2 mode file mode (type and permissions)
+ 3 nlink number of (hard) links to the file
+ 4 uid numeric user ID of file's owner
+ 5 gid numeric group ID of file's owner
+ 6 rdev the device identifier (special files only)
+ 7 size total size of file, in bytes
+ 8 atime last access time since the epoch
+ 9 mtime last modify time since the epoch
+ 10 ctime inode change time (NOT creation time!) since the epoch
+ 11 blksize preferred block size for file system I/O
+ 12 blocks actual number of blocks allocated
+
+(The epoch was at 00:00 January 1, 1970 GMT.)
+
+If stat is passed the special filehandle consisting of an underline, no
+stat is done, but the current contents of the stat structure from the
+last stat or filetest are returned. Example:
+
+ if (-x $file && (($d) = stat(_)) && $d < 0) {
+ print "$file is executable NFS file\n";
+ }
+
+(This works on machines only for which the device number is negative under NFS.)
+
+In scalar context, C<stat()> returns a boolean value indicating success
+or failure, and, if successful, sets the information associated with
+the special filehandle C<_>.
+
+=item study SCALAR
+
+=item study
+
+Takes extra time to study SCALAR (C<$_> if unspecified) in anticipation of
+doing many pattern matches on the string before it is next modified.
+This may or may not save time, depending on the nature and number of
+patterns you are searching on, and on the distribution of character
+frequencies in the string to be searched -- you probably want to compare
+run times with and without it to see which runs faster. Those loops
+which scan for many short constant strings (including the constant
+parts of more complex patterns) will benefit most. You may have only
+one C<study()> active at a time -- if you study a different scalar the first
+is "unstudied". (The way C<study()> works is this: a linked list of every
+character in the string to be searched is made, so we know, for
+example, where all the C<'k'> characters are. From each search string,
+the rarest character is selected, based on some static frequency tables
+constructed from some C programs and English text. Only those places
+that contain this "rarest" character are examined.)
+
+For example, here is a loop that inserts index producing entries
+before any line containing a certain pattern:
+
+ while (<>) {
+ study;
+ print ".IX foo\n" if /\bfoo\b/;
+ print ".IX bar\n" if /\bbar\b/;
+ print ".IX blurfl\n" if /\bblurfl\b/;
+ # ...
+ print;
+ }
+
+In searching for C</\bfoo\b/>, only those locations in C<$_> that contain C<"f">
+will be looked at, because C<"f"> is rarer than C<"o">. In general, this is
+a big win except in pathological cases. The only question is whether
+it saves you more time than it took to build the linked list in the
+first place.
+
+Note that if you have to look for strings that you don't know till
+runtime, you can build an entire loop as a string and C<eval()> that to
+avoid recompiling all your patterns all the time. Together with
+undefining C<$/> to input entire files as one record, this can be very
+fast, often faster than specialized programs like fgrep(1). The following
+scans a list of files (C<@files>) for a list of words (C<@words>), and prints
+out the names of those files that contain a match:
+
+ $search = 'while (<>) { study;';
+ foreach $word (@words) {
+ $search .= "++\$seen{\$ARGV} if /\\b$word\\b/;\n";
+ }
+ $search .= "}";
+ @ARGV = @files;
+ undef $/;
+ eval $search; # this screams
+ $/ = "\n"; # put back to normal input delimiter
+ foreach $file (sort keys(%seen)) {
+ print $file, "\n";
+ }
+
+=item sub BLOCK
+
+=item sub NAME
+
+=item sub NAME BLOCK
+
+This is subroutine definition, not a real function I<per se>. With just a
+NAME (and possibly prototypes), it's just a forward declaration. Without
+a NAME, it's an anonymous function declaration, and does actually return a
+value: the CODE ref of the closure you just created. See L<perlsub> and
+L<perlref> for details.
+
+=item substr EXPR,OFFSET,LEN,REPLACEMENT
+
+=item substr EXPR,OFFSET,LEN
+
+=item substr EXPR,OFFSET
+
+Extracts a substring out of EXPR and returns it. First character is at
+offset C<0>, or whatever you've set C<$[> to (but don't do that).
+If OFFSET is negative (or more precisely, less than C<$[>), starts
+that far from the end of the string. If LEN is omitted, returns
+everything to the end of the string. If LEN is negative, leaves that
+many characters off the end of the string.
+
+If you specify a substring that is partly outside the string, the part
+within the string is returned. If the substring is totally outside
+the string a warning is produced.
+
+You can use the C<substr()> function
+as an lvalue, in which case EXPR must be an lvalue. If you assign
+something shorter than LEN, the string will shrink, and if you assign
+something longer than LEN, the string will grow to accommodate it. To
+keep the string the same length you may need to pad or chop your value
+using C<sprintf()>.
+
+An alternative to using C<substr()> as an lvalue is to specify the
+replacement string as the 4th argument. This allows you to replace
+parts of the EXPR and return what was there before in one operation.
+
+=item symlink OLDFILE,NEWFILE
+
+Creates a new filename symbolically linked to the old filename.
+Returns C<1> for success, C<0> otherwise. On systems that don't support
+symbolic links, produces a fatal error at run time. To check for that,
+use eval:
+
+ $symlink_exists = eval { symlink("",""); 1 };
+
+=item syscall LIST
+
+Calls the system call specified as the first element of the list,
+passing the remaining elements as arguments to the system call. If
+unimplemented, produces a fatal error. The arguments are interpreted
+as follows: if a given argument is numeric, the argument is passed as
+an int. If not, the pointer to the string value is passed. You are
+responsible to make sure a string is pre-extended long enough to
+receive any result that might be written into a string. You can't use a
+string literal (or other read-only string) as an argument to C<syscall()>
+because Perl has to assume that any string pointer might be written
+through. If your
+integer arguments are not literals and have never been interpreted in a
+numeric context, you may need to add C<0> to them to force them to look
+like numbers. This emulates the C<syswrite()> function (or vice versa):
+
+ require 'syscall.ph'; # may need to run h2ph
+ $s = "hi there\n";
+ syscall(&SYS_write, fileno(STDOUT), $s, length $s);
+
+Note that Perl supports passing of up to only 14 arguments to your system call,
+which in practice should usually suffice.
+
+Syscall returns whatever value returned by the system call it calls.
+If the system call fails, C<syscall()> returns C<-1> and sets C<$!> (errno).
+Note that some system calls can legitimately return C<-1>. The proper
+way to handle such calls is to assign C<$!=0;> before the call and
+check the value of C<$!> if syscall returns C<-1>.
+
+There's a problem with C<syscall(&SYS_pipe)>: it returns the file
+number of the read end of the pipe it creates. There is no way
+to retrieve the file number of the other end. You can avoid this
+problem by using C<pipe()> instead.
+
+=item sysopen FILEHANDLE,FILENAME,MODE
+
+=item sysopen FILEHANDLE,FILENAME,MODE,PERMS
+
+Opens the file whose filename is given by FILENAME, and associates it
+with FILEHANDLE. If FILEHANDLE is an expression, its value is used as
+the name of the real filehandle wanted. This function calls the
+underlying operating system's C<open()> function with the parameters
+FILENAME, MODE, PERMS.
+
+The possible values and flag bits of the MODE parameter are
+system-dependent; they are available via the standard module C<Fcntl>.
+For historical reasons, some values work on almost every system
+supported by perl: zero means read-only, one means write-only, and two
+means read/write. We know that these values do I<not> work under
+OS/390 Unix and on the Macintosh; you probably don't want to use them
+in new code.
+
+If the file named by FILENAME does not exist and the C<open()> call creates
+it (typically because MODE includes the C<O_CREAT> flag), then the value of
+PERMS specifies the permissions of the newly created file. If you omit
+the PERMS argument to C<sysopen()>, Perl uses the octal value C<0666>.
+These permission values need to be in octal, and are modified by your
+process's current C<umask>. The C<umask> value is a number representing
+disabled permissions bits--if your C<umask> were C<027> (group can't write;
+others can't read, write, or execute), then passing C<sysopen()> C<0666> would
+create a file with mode C<0640> (C<0666 &~ 027> is C<0640>).
+
+If you find this C<umask()> talk confusing, here's some advice: supply a
+creation mode of C<0666> for regular files and one of C<0777> for directories
+(in C<mkdir()>) and executable files. This gives users the freedom of
+choice: if they want protected files, they might choose process umasks
+of C<022>, C<027>, or even the particularly antisocial mask of C<077>. Programs
+should rarely if ever make policy decisions better left to the user.
+The exception to this is when writing files that should be kept private:
+mail files, web browser cookies, I<.rhosts> files, and so on. In short,
+seldom if ever use C<0644> as argument to C<sysopen()> because that takes
+away the user's option to have a more permissive umask. Better to omit it.
+
+The C<IO::File> module provides a more object-oriented approach, if you're
+into that kind of thing.
+
+=item sysread FILEHANDLE,SCALAR,LENGTH,OFFSET
+
+=item sysread FILEHANDLE,SCALAR,LENGTH
+
+Attempts to read LENGTH bytes of data into variable SCALAR from the
+specified FILEHANDLE, using the system call read(2). It bypasses
+stdio, so mixing this with other kinds of reads, C<print()>, C<write()>,
+C<seek()>, or C<tell()> can cause confusion because stdio usually buffers
+data. Returns the number of bytes actually read, C<0> at end of file,
+or undef if there was an error. SCALAR will be grown or shrunk so that
+the last byte actually read is the last byte of the scalar after the read.
+
+An OFFSET may be specified to place the read data at some place in the
+string other than the beginning. A negative OFFSET specifies
+placement at that many bytes counting backwards from the end of the
+string. A positive OFFSET greater than the length of SCALAR results
+in the string being padded to the required size with C<"\0"> bytes before
+the result of the read is appended.
+
+=item sysseek FILEHANDLE,POSITION,WHENCE
+
+Sets FILEHANDLE's system position using the system call lseek(2). It
+bypasses stdio, so mixing this with reads (other than C<sysread()>),
+C<print()>, C<write()>, C<seek()>, or C<tell()> may cause confusion. FILEHANDLE may
+be an expression whose value gives the name of the filehandle. The
+values for WHENCE are C<0> to set the new position to POSITION, C<1> to set
+the it to the current position plus POSITION, and C<2> to set it to EOF
+plus POSITION (typically negative). For WHENCE, you may use the
+constants C<SEEK_SET>, C<SEEK_CUR>, and C<SEEK_END> from either the C<IO::Seekable>
+or the POSIX module.
+
+Returns the new position, or the undefined value on failure. A position
+of zero is returned as the string "C<0> but true"; thus C<sysseek()> returns
+TRUE on success and FALSE on failure, yet you can still easily determine
+the new position.
+
+=item system LIST
+
+=item system PROGRAM LIST
+
+Does exactly the same thing as "C<exec LIST>" except that a fork is done
+first, and the parent process waits for the child process to complete.
+Note that argument processing varies depending on the number of
+arguments. If there is more than one argument in LIST, or if LIST is
+an array with more than one value, starts the program given by the
+first element of the list with arguments given by the rest of the list.
+If there is only one scalar argument, the argument is
+checked for shell metacharacters, and if there are any, the entire
+argument is passed to the system's command shell for parsing (this is
+C</bin/sh -c> on Unix platforms, but varies on other platforms). If
+there are no shell metacharacters in the argument, it is split into
+words and passed directly to C<execvp()>, which is more efficient.
+
+The return value is the exit status of the program as
+returned by the C<wait()> call. To get the actual exit value divide by
+256. See also L</exec>. This is I<NOT> what you want to use to capture
+the output from a command, for that you should use merely backticks or
+C<qx//>, as described in L<perlop/"`STRING`">.
+
+Like C<exec()>, C<system()> allows you to lie to a program about its name if
+you use the "C<system PROGRAM LIST>" syntax. Again, see L</exec>.
+
+Because C<system()> and backticks block C<SIGINT> and C<SIGQUIT>, killing the
+program they're running doesn't actually interrupt your program.
+
+ @args = ("command", "arg1", "arg2");
+ system(@args) == 0
+ or die "system @args failed: $?"
+
+You can check all the failure possibilities by inspecting
+C<$?> like this:
+
+ $exit_value = $? >> 8;
+ $signal_num = $? & 127;
+ $dumped_core = $? & 128;
+
+When the arguments get executed via the system shell, results
+and return codes will be subject to its quirks and capabilities.
+See L<perlop/"`STRING`"> and L</exec> for details.
+
+=item syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET
+
+=item syswrite FILEHANDLE,SCALAR,LENGTH
+
+Attempts to write LENGTH bytes of data from variable SCALAR to the
+specified FILEHANDLE, using the system call write(2). It bypasses
+stdio, so mixing this with reads (other than C<sysread())>, C<print()>,
+C<write()>, C<seek()>, or C<tell()> may cause confusion because stdio usually
+buffers data. Returns the number of bytes actually written, or C<undef>
+if there was an error. If the LENGTH is greater than the available
+data in the SCALAR after the OFFSET, only as much data as is available
+will be written.
+
+An OFFSET may be specified to write the data from some part of the
+string other than the beginning. A negative OFFSET specifies writing
+that many bytes counting backwards from the end of the string. In the
+case the SCALAR is empty you can use OFFSET but only zero offset.
+
+=item tell FILEHANDLE
+
+=item tell
+
+Returns the current position for FILEHANDLE. FILEHANDLE may be an
+expression whose value gives the name of the actual filehandle. If
+FILEHANDLE is omitted, assumes the file last read.
+
+=item telldir DIRHANDLE
+
+Returns the current position of the C<readdir()> routines on DIRHANDLE.
+Value may be given to C<seekdir()> to access a particular location in a
+directory. Has the same caveats about possible directory compaction as
+the corresponding system library routine.
+
+=item tie VARIABLE,CLASSNAME,LIST
+
+This function binds a variable to a package class that will provide the
+implementation for the variable. VARIABLE is the name of the variable
+to be enchanted. CLASSNAME is the name of a class implementing objects
+of correct type. Any additional arguments are passed to the "C<new()>"
+method of the class (meaning C<TIESCALAR>, C<TIEARRAY>, or C<TIEHASH>).
+Typically these are arguments such as might be passed to the C<dbm_open()>
+function of C. The object returned by the "C<new()>" method is also
+returned by the C<tie()> function, which would be useful if you want to
+access other methods in CLASSNAME.
+
+Note that functions such as C<keys()> and C<values()> may return huge lists
+when used on large objects, like DBM files. You may prefer to use the
+C<each()> function to iterate over such. Example:
+
+ # print out history file offsets
+ use NDBM_File;
+ tie(%HIST, 'NDBM_File', '/usr/lib/news/history', 1, 0);
+ while (($key,$val) = each %HIST) {
+ print $key, ' = ', unpack('L',$val), "\n";
+ }
+ untie(%HIST);
+
+A class implementing a hash should have the following methods:
+
+ TIEHASH classname, LIST
+ DESTROY this
+ FETCH this, key
+ STORE this, key, value
+ DELETE this, key
+ EXISTS this, key
+ FIRSTKEY this
+ NEXTKEY this, lastkey
+
+A class implementing an ordinary array should have the following methods:
+
+ TIEARRAY classname, LIST
+ DESTROY this
+ FETCH this, key
+ STORE this, key, value
+ [others TBD]
+
+A class implementing a scalar should have the following methods:
+
+ TIESCALAR classname, LIST
+ DESTROY this
+ FETCH this,
+ STORE this, value
+
+Unlike C<dbmopen()>, the C<tie()> function will not use or require a module
+for you--you need to do that explicitly yourself. See L<DB_File>
+or the F<Config> module for interesting C<tie()> implementations.
+
+For further details see L<perltie>, L<tied VARIABLE>.
+
+=item tied VARIABLE
+
+Returns a reference to the object underlying VARIABLE (the same value
+that was originally returned by the C<tie()> call that bound the variable
+to a package.) Returns the undefined value if VARIABLE isn't tied to a
+package.
+
+=item time
+
+Returns the number of non-leap seconds since whatever time the system
+considers to be the epoch (that's 00:00:00, January 1, 1904 for MacOS,
+and 00:00:00 UTC, January 1, 1970 for most other systems).
+Suitable for feeding to C<gmtime()> and C<localtime()>.
+
+=item times
+
+Returns a four-element list giving the user and system times, in
+seconds, for this process and the children of this process.
+
+ ($user,$system,$cuser,$csystem) = times;
+
+=item tr///
+
+The transliteration operator. Same as C<y///>. See L<perlop>.
+
+=item truncate FILEHANDLE,LENGTH
+
+=item truncate EXPR,LENGTH
+
+Truncates the file opened on FILEHANDLE, or named by EXPR, to the
+specified length. Produces a fatal error if truncate isn't implemented
+on your system. Returns TRUE if successful, the undefined value
+otherwise.
+
+=item uc EXPR
+
+=item uc
+
+Returns an uppercased version of EXPR. This is the internal function
+implementing the C<\U> escape in double-quoted strings.
+Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>.
+
+If EXPR is omitted, uses C<$_>.
+
+=item ucfirst EXPR
+
+=item ucfirst
+
+Returns the value of EXPR with the first character uppercased. This is
+the internal function implementing the C<\u> escape in double-quoted strings.
+Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>.
+
+If EXPR is omitted, uses C<$_>.
+
+=item umask EXPR
+
+=item umask
+
+Sets the umask for the process to EXPR and returns the previous value.
+If EXPR is omitted, merely returns the current umask.
+
+If umask(2) is not implemented on your system and you are trying to
+restrict access for I<yourself> (i.e., (EXPR & 0700) > 0), produces a
+fatal error at run time. If umask(2) is not implemented and you are
+not trying to restrict access for yourself, returns C<undef>.
+
+Remember that a umask is a number, usually given in octal; it is I<not> a
+string of octal digits. See also L</oct>, if all you have is a string.
+
+=item undef EXPR
+
+=item undef
+
+Undefines the value of EXPR, which must be an lvalue. Use only on a
+scalar value, an array (using "C<@>"), a hash (using "C<%>"), a subroutine
+(using "C<&>"), or a typeglob (using "<*>"). (Saying C<undef $hash{$key}>
+will probably not do what you expect on most predefined variables or
+DBM list values, so don't do that; see L<delete>.) Always returns the
+undefined value. You can omit the EXPR, in which case nothing is
+undefined, but you still get an undefined value that you could, for
+instance, return from a subroutine, assign to a variable or pass as a
+parameter. Examples:
+
+ undef $foo;
+ undef $bar{'blurfl'}; # Compare to: delete $bar{'blurfl'};
+ undef @ary;
+ undef %hash;
+ undef &mysub;
+ undef *xyz; # destroys $xyz, @xyz, %xyz, &xyz, etc.
+ return (wantarray ? (undef, $errmsg) : undef) if $they_blew_it;
+ select undef, undef, undef, 0.25;
+ ($a, $b, undef, $c) = &foo; # Ignore third value returned
+
+Note that this is a unary operator, not a list operator.
+
+=item unlink LIST
+
+=item unlink
+
+Deletes a list of files. Returns the number of files successfully
+deleted.
+
+ $cnt = unlink 'a', 'b', 'c';
+ unlink @goners;
+ unlink <*.bak>;
+
+Note: C<unlink()> will not delete directories unless you are superuser and
+the B<-U> flag is supplied to Perl. Even if these conditions are
+met, be warned that unlinking a directory can inflict damage on your
+filesystem. Use C<rmdir()> instead.
+
+If LIST is omitted, uses C<$_>.
+
+=item unpack TEMPLATE,EXPR
+
+C<Unpack()> does the reverse of C<pack()>: it takes a string representing a
+structure and expands it out into a list value, returning the array
+value. (In scalar context, it returns merely the first value
+produced.) The TEMPLATE has the same format as in the C<pack()> function.
+Here's a subroutine that does substring:
+
+ sub substr {
+ my($what,$where,$howmuch) = @_;
+ unpack("x$where a$howmuch", $what);
+ }
+
+and then there's
+
+ sub ordinal { unpack("c",$_[0]); } # same as ord()
+
+In addition, you may prefix a field with a %E<lt>numberE<gt> to indicate that
+you want a E<lt>numberE<gt>-bit checksum of the items instead of the items
+themselves. Default is a 16-bit checksum. For example, the following
+computes the same number as the System V sum program:
+
+ while (<>) {
+ $checksum += unpack("%16C*", $_);
+ }
+ $checksum %= 65536;
+
+The following efficiently counts the number of set bits in a bit vector:
+
+ $setbits = unpack("%32b*", $selectmask);
+
+=item untie VARIABLE
+
+Breaks the binding between a variable and a package. (See C<tie()>.)
+
+=item unshift ARRAY,LIST
+
+Does the opposite of a C<shift()>. Or the opposite of a C<push()>,
+depending on how you look at it. Prepends list to the front of the
+array, and returns the new number of elements in the array.
+
+ unshift(ARGV, '-e') unless $ARGV[0] =~ /^-/;
+
+Note the LIST is prepended whole, not one element at a time, so the
+prepended elements stay in the same order. Use C<reverse()> to do the
+reverse.
+
+=item use Module LIST
+
+=item use Module
+
+=item use Module VERSION LIST
+
+=item use VERSION
+
+Imports some semantics into the current package from the named module,
+generally by aliasing certain subroutine or variable names into your
+package. It is exactly equivalent to
+
+ BEGIN { require Module; import Module LIST; }
+
+except that Module I<must> be a bareword.
+
+If the first argument to C<use> is a number, it is treated as a version
+number instead of a module name. If the version of the Perl interpreter
+is less than VERSION, then an error message is printed and Perl exits
+immediately. This is often useful if you need to check the current
+Perl version before C<use>ing library modules that have changed in
+incompatible ways from older versions of Perl. (We try not to do
+this more than we have to.)
+
+The C<BEGIN> forces the C<require> and C<import()> to happen at compile time. The
+C<require> makes sure the module is loaded into memory if it hasn't been
+yet. The C<import()> is not a builtin--it's just an ordinary static method
+call into the "C<Module>" package to tell the module to import the list of
+features back into the current package. The module can implement its
+C<import()> method any way it likes, though most modules just choose to
+derive their C<import()> method via inheritance from the C<Exporter> class that
+is defined in the C<Exporter> module. See L<Exporter>. If no C<import()>
+method can be found then the error is currently silently ignored. This
+may change to a fatal error in a future version.
+
+If you don't want your namespace altered, explicitly supply an empty list:
+
+ use Module ();
+
+That is exactly equivalent to
+
+ BEGIN { require Module }
+
+If the VERSION argument is present between Module and LIST, then the
+C<use> will call the VERSION method in class Module with the given
+version as an argument. The default VERSION method, inherited from
+the Universal class, croaks if the given version is larger than the
+value of the variable C<$Module::VERSION>. (Note that there is not a
+comma after VERSION!)
+
+Because this is a wide-open interface, pragmas (compiler directives)
+are also implemented this way. Currently implemented pragmas are:
+
+ use integer;
+ use diagnostics;
+ use sigtrap qw(SEGV BUS);
+ use strict qw(subs vars refs);
+ use subs qw(afunc blurfl);
+
+Some of these these pseudo-modules import semantics into the current
+block scope (like C<strict> or C<integer>, unlike ordinary modules,
+which import symbols into the current package (which are effective
+through the end of the file).
+
+There's a corresponding "C<no>" command that unimports meanings imported
+by C<use>, i.e., it calls C<unimport Module LIST> instead of C<import()>.
+
+ no integer;
+ no strict 'refs';
+
+If no C<unimport()> method can be found the call fails with a fatal error.
+
+See L<perlmod> for a list of standard modules and pragmas.
+
+=item utime LIST
+
+Changes the access and modification times on each file of a list of
+files. The first two elements of the list must be the NUMERICAL access
+and modification times, in that order. Returns the number of files
+successfully changed. The inode modification time of each file is set
+to the current time. This code has the same effect as the "C<touch>"
+command if the files already exist:
+
+ #!/usr/bin/perl
+ $now = time;
+ utime $now, $now, @ARGV;
+
+=item values HASH
+
+Returns a list consisting of all the values of the named hash. (In a
+scalar context, returns the number of values.) The values are
+returned in an apparently random order, but it is the same order as
+either the C<keys()> or C<each()> function would produce on the same hash.
+As a side effect, it resets HASH's iterator. See also C<keys()>, C<each()>,
+and C<sort()>.
+
+=item vec EXPR,OFFSET,BITS
+
+Treats the string in EXPR as a vector of unsigned integers, and
+returns the value of the bit field specified by OFFSET. BITS specifies
+the number of bits that are reserved for each entry in the bit
+vector. This must be a power of two from 1 to 32. C<vec()> may also be
+assigned to, in which case parentheses are needed to give the expression
+the correct precedence as in
+
+ vec($image, $max_x * $x + $y, 8) = 3;
+
+Vectors created with C<vec()> can also be manipulated with the logical
+operators C<|>, C<&>, and C<^>, which will assume a bit vector operation is
+desired when both operands are strings.
+
+The following code will build up an ASCII string saying C<'PerlPerlPerl'>.
+The comments show the string after each step. Note that this code works
+in the same way on big-endian or little-endian machines.
+
+ my $foo = '';
+ vec($foo, 0, 32) = 0x5065726C; # 'Perl'
+ vec($foo, 2, 16) = 0x5065; # 'PerlPe'
+ vec($foo, 3, 16) = 0x726C; # 'PerlPerl'
+ vec($foo, 8, 8) = 0x50; # 'PerlPerlP'
+ vec($foo, 9, 8) = 0x65; # 'PerlPerlPe'
+ vec($foo, 20, 4) = 2; # 'PerlPerlPe' . "\x02"
+ vec($foo, 21, 4) = 7; # 'PerlPerlPer'
+ # 'r' is "\x72"
+ vec($foo, 45, 2) = 3; # 'PerlPerlPer' . "\x0c"
+ vec($foo, 93, 1) = 1; # 'PerlPerlPer' . "\x2c"
+ vec($foo, 94, 1) = 1; # 'PerlPerlPerl'
+ # 'l' is "\x6c"
+
+To transform a bit vector into a string or array of 0's and 1's, use these:
+
+ $bits = unpack("b*", $vector);
+ @bits = split(//, unpack("b*", $vector));
+
+If you know the exact length in bits, it can be used in place of the C<*>.
+
+=item wait
+
+Waits for a child process to terminate and returns the pid of the
+deceased process, or C<-1> if there are no child processes. The status is
+returned in C<$?>.
+
+=item waitpid PID,FLAGS
+
+Waits for a particular child process to terminate and returns the pid
+of the deceased process, or C<-1> if there is no such child process. The
+status is returned in C<$?>. If you say
+
+ use POSIX ":sys_wait_h";
+ #...
+ waitpid(-1,&WNOHANG);
+
+then you can do a non-blocking wait for any process. Non-blocking wait
+is available on machines supporting either the waitpid(2) or
+wait4(2) system calls. However, waiting for a particular pid with
+FLAGS of C<0> is implemented everywhere. (Perl emulates the system call
+by remembering the status values of processes that have exited but have
+not been harvested by the Perl script yet.)
+
+See L<perlipc> for other examples.
+
+=item wantarray
+
+Returns TRUE if the context of the currently executing subroutine is
+looking for a list value. Returns FALSE if the context is looking
+for a scalar. Returns the undefined value if the context is looking
+for no value (void context).
+
+ return unless defined wantarray; # don't bother doing more
+ my @a = complex_calculation();
+ return wantarray ? @a : "@a";
+
+=item warn LIST
+
+Produces a message on STDERR just like C<die()>, but doesn't exit or throw
+an exception.
+
+If LIST is empty and C<$@> already contains a value (typically from a
+previous eval) that value is used after appending C<"\t...caught">
+to C<$@>. This is useful for staying almost, but not entirely similar to
+C<die()>.
+
+If C<$@> is empty then the string C<"Warning: Something's wrong"> is used.
+
+No message is printed if there is a C<$SIG{__WARN__}> handler
+installed. It is the handler's responsibility to deal with the message
+as it sees fit (like, for instance, converting it into a C<die()>). Most
+handlers must therefore make arrangements to actually display the
+warnings that they are not prepared to deal with, by calling C<warn()>
+again in the handler. Note that this is quite safe and will not
+produce an endless loop, since C<__WARN__> hooks are not called from
+inside one.
+
+You will find this behavior is slightly different from that of
+C<$SIG{__DIE__}> handlers (which don't suppress the error text, but can
+instead call C<die()> again to change it).
+
+Using a C<__WARN__> handler provides a powerful way to silence all
+warnings (even the so-called mandatory ones). An example:
+
+ # wipe out *all* compile-time warnings
+ BEGIN { $SIG{'__WARN__'} = sub { warn $_[0] if $DOWARN } }
+ my $foo = 10;
+ my $foo = 20; # no warning about duplicate my $foo,
+ # but hey, you asked for it!
+ # no compile-time or run-time warnings before here
+ $DOWARN = 1;
+
+ # run-time warnings enabled after here
+ warn "\$foo is alive and $foo!"; # does show up
+
+See L<perlvar> for details on setting C<%SIG> entries, and for more
+examples.
+
+=item write FILEHANDLE
+
+=item write EXPR
+
+=item write
+
+Writes a formatted record (possibly multi-line) to the specified FILEHANDLE,
+using the format associated with that file. By default the format for
+a file is the one having the same name as the filehandle, but the
+format for the current output channel (see the C<select()> function) may be set
+explicitly by assigning the name of the format to the C<$~> variable.
+
+Top of form processing is handled automatically: if there is
+insufficient room on the current page for the formatted record, the
+page is advanced by writing a form feed, a special top-of-page format
+is used to format the new page header, and then the record is written.
+By default the top-of-page format is the name of the filehandle with
+"_TOP" appended, but it may be dynamically set to the format of your
+choice by assigning the name to the C<$^> variable while the filehandle is
+selected. The number of lines remaining on the current page is in
+variable C<$->, which can be set to C<0> to force a new page.
+
+If FILEHANDLE is unspecified, output goes to the current default output
+channel, which starts out as STDOUT but may be changed by the
+C<select()> operator. If the FILEHANDLE is an EXPR, then the expression
+is evaluated and the resulting string is used to look up the name of
+the FILEHANDLE at run time. For more on formats, see L<perlform>.
+
+Note that write is I<NOT> the opposite of C<read()>. Unfortunately.
+
+=item y///
+
+The transliteration operator. Same as C<tr///>. See L<perlop>.
+
+=back
diff --git a/contrib/perl5/pod/perlguts.pod b/contrib/perl5/pod/perlguts.pod
new file mode 100644
index 000000000000..20a07d38540d
--- /dev/null
+++ b/contrib/perl5/pod/perlguts.pod
@@ -0,0 +1,3557 @@
+=head1 NAME
+
+perlguts - Perl's Internal Functions
+
+=head1 DESCRIPTION
+
+This document attempts to describe some of the internal functions of the
+Perl executable. It is far from complete and probably contains many errors.
+Please refer any questions or comments to the author below.
+
+=head1 Variables
+
+=head2 Datatypes
+
+Perl has three typedefs that handle Perl's three main data types:
+
+ SV Scalar Value
+ AV Array Value
+ HV Hash Value
+
+Each typedef has specific routines that manipulate the various data types.
+
+=head2 What is an "IV"?
+
+Perl uses a special typedef IV which is a simple integer type that is
+guaranteed to be large enough to hold a pointer (as well as an integer).
+
+Perl also uses two special typedefs, I32 and I16, which will always be at
+least 32-bits and 16-bits long, respectively.
+
+=head2 Working with SVs
+
+An SV can be created and loaded with one command. There are four types of
+values that can be loaded: an integer value (IV), a double (NV), a string,
+(PV), and another scalar (SV).
+
+The six routines are:
+
+ SV* newSViv(IV);
+ SV* newSVnv(double);
+ SV* newSVpv(char*, int);
+ SV* newSVpvn(char*, int);
+ SV* newSVpvf(const char*, ...);
+ SV* newSVsv(SV*);
+
+To change the value of an *already-existing* SV, there are seven routines:
+
+ void sv_setiv(SV*, IV);
+ void sv_setuv(SV*, UV);
+ void sv_setnv(SV*, double);
+ void sv_setpv(SV*, char*);
+ void sv_setpvn(SV*, char*, int)
+ void sv_setpvf(SV*, const char*, ...);
+ void sv_setpvfn(SV*, const char*, STRLEN, va_list *, SV **, I32, bool);
+ void sv_setsv(SV*, SV*);
+
+Notice that you can choose to specify the length of the string to be
+assigned by using C<sv_setpvn>, C<newSVpvn>, or C<newSVpv>, or you may
+allow Perl to calculate the length by using C<sv_setpv> or by specifying
+0 as the second argument to C<newSVpv>. Be warned, though, that Perl will
+determine the string's length by using C<strlen>, which depends on the
+string terminating with a NUL character.
+
+The arguments of C<sv_setpvf> are processed like C<sprintf>, and the
+formatted output becomes the value.
+
+C<sv_setpvfn> is an analogue of C<vsprintf>, but it allows you to specify
+either a pointer to a variable argument list or the address and length of
+an array of SVs. The last argument points to a boolean; on return, if that
+boolean is true, then locale-specific information has been used to format
+the string, and the string's contents are therefore untrustworty (see
+L<perlsec>). This pointer may be NULL if that information is not
+important. Note that this function requires you to specify the length of
+the format.
+
+The C<sv_set*()> functions are not generic enough to operate on values
+that have "magic". See L<Magic Virtual Tables> later in this document.
+
+All SVs that contain strings should be terminated with a NUL character.
+If it is not NUL-terminated there is a risk of
+core dumps and corruptions from code which passes the string to C
+functions or system calls which expect a NUL-terminated string.
+Perl's own functions typically add a trailing NUL for this reason.
+Nevertheless, you should be very careful when you pass a string stored
+in an SV to a C function or system call.
+
+To access the actual value that an SV points to, you can use the macros:
+
+ SvIV(SV*)
+ SvNV(SV*)
+ SvPV(SV*, STRLEN len)
+
+which will automatically coerce the actual scalar type into an IV, double,
+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,
+however, that Perl allows arbitrary strings of data that may both contain
+NULs and might not be terminated by a NUL.
+
+If you want to know if the scalar value is TRUE, you can use:
+
+ SvTRUE(SV*)
+
+Although Perl will automatically grow strings for you, if you need to force
+Perl to allocate more memory for your SV, you can use the macro
+
+ SvGROW(SV*, STRLEN newlen)
+
+which will determine if more memory needs to be allocated. If so, it will
+call the function C<sv_grow>. Note that C<SvGROW> can only increase, not
+decrease, the allocated memory of an SV and that it does not automatically
+add a byte for the a trailing NUL (perl's own string functions typically do
+C<SvGROW(sv, len + 1)>).
+
+If you have an SV and want to know what kind of data Perl thinks is stored
+in it, you can use the following macros to check the type of SV you have.
+
+ SvIOK(SV*)
+ SvNOK(SV*)
+ SvPOK(SV*)
+
+You can get and set the current length of the string stored in an SV with
+the following macros:
+
+ SvCUR(SV*)
+ SvCUR_set(SV*, I32 val)
+
+You can also get a pointer to the end of the string stored in the SV
+with the macro:
+
+ SvEND(SV*)
+
+But note that these last three macros are valid only if C<SvPOK()> is true.
+
+If you want to append something to the end of string stored in an C<SV*>,
+you can use the following functions:
+
+ void sv_catpv(SV*, char*);
+ void sv_catpvn(SV*, char*, int);
+ void sv_catpvf(SV*, const char*, ...);
+ void sv_catpvfn(SV*, const char*, STRLEN, va_list *, SV **, I32, bool);
+ void sv_catsv(SV*, SV*);
+
+The first function calculates the length of the string to be appended by
+using C<strlen>. In the second, you specify the length of the string
+yourself. The third function processes its arguments like C<sprintf> and
+appends the formatted output. The fourth function works like C<vsprintf>.
+You can specify the address and length of an array of SVs instead of the
+va_list argument. The fifth function extends the string stored in the first
+SV with the string stored in the second SV. It also forces the second SV
+to be interpreted as a string.
+
+The C<sv_cat*()> functions are not generic enough to operate on values that
+have "magic". See L<Magic Virtual Tables> later in this document.
+
+If you know the name of a scalar variable, you can get a pointer to its SV
+by using the following:
+
+ SV* perl_get_sv("package::varname", FALSE);
+
+This returns NULL if the variable does not exist.
+
+If you want to know if this variable (or any other SV) is actually C<defined>,
+you can call:
+
+ SvOK(SV*)
+
+The scalar C<undef> value is stored in an SV instance called C<PL_sv_undef>. Its
+address can be used whenever an C<SV*> is needed.
+
+There are also the two values C<PL_sv_yes> and C<PL_sv_no>, which contain Boolean
+TRUE and FALSE values, respectively. Like C<PL_sv_undef>, their addresses can
+be used whenever an C<SV*> is needed.
+
+Do not be fooled into thinking that C<(SV *) 0> is the same as C<&PL_sv_undef>.
+Take this code:
+
+ SV* sv = (SV*) 0;
+ if (I-am-to-return-a-real-value) {
+ sv = sv_2mortal(newSViv(42));
+ }
+ sv_setsv(ST(0), sv);
+
+This code tries to return a new SV (which contains the value 42) if it should
+return a real value, or undef otherwise. Instead it has returned a NULL
+pointer which, somewhere down the line, will cause a segmentation violation,
+bus error, or just weird results. Change the zero to C<&PL_sv_undef> in the first
+line and all will be well.
+
+To free an SV that you've created, call C<SvREFCNT_dec(SV*)>. Normally this
+call is not necessary (see L<Reference Counts and Mortality>).
+
+=head2 What's Really Stored in an SV?
+
+Recall that the usual method of determining the type of scalar you have is
+to use C<Sv*OK> macros. Because a scalar can be both a number and a string,
+usually these macros will always return TRUE and calling the C<Sv*V>
+macros will do the appropriate conversion of string to integer/double or
+integer/double to string.
+
+If you I<really> need to know if you have an integer, double, or string
+pointer in an SV, you can use the following three macros instead:
+
+ SvIOKp(SV*)
+ SvNOKp(SV*)
+ SvPOKp(SV*)
+
+These will tell you if you truly have an integer, double, or string pointer
+stored in your SV. The "p" stands for private.
+
+In general, though, it's best to use the C<Sv*V> macros.
+
+=head2 Working with AVs
+
+There are two ways to create and load an AV. The first method creates an
+empty AV:
+
+ AV* newAV();
+
+The second method both creates the AV and initially populates it with SVs:
+
+ AV* av_make(I32 num, SV **ptr);
+
+The second argument points to an array containing C<num> C<SV*>'s. Once the
+AV has been created, the SVs can be destroyed, if so desired.
+
+Once the AV has been created, the following operations are possible on AVs:
+
+ void av_push(AV*, SV*);
+ SV* av_pop(AV*);
+ SV* av_shift(AV*);
+ void av_unshift(AV*, I32 num);
+
+These should be familiar operations, with the exception of C<av_unshift>.
+This routine adds C<num> elements at the front of the array with the C<undef>
+value. You must then use C<av_store> (described below) to assign values
+to these new elements.
+
+Here are some other functions:
+
+ I32 av_len(AV*);
+ SV** av_fetch(AV*, I32 key, I32 lval);
+ SV** av_store(AV*, I32 key, SV* val);
+
+The C<av_len> function returns the highest index value in array (just
+like $#array in Perl). If the array is empty, -1 is returned. The
+C<av_fetch> function returns the value at index C<key>, but if C<lval>
+is non-zero, then C<av_fetch> will store an undef value at that index.
+The C<av_store> function stores the value C<val> at index C<key>, and does
+not increment the reference count of C<val>. Thus the caller is responsible
+for taking care of that, and if C<av_store> returns NULL, the caller will
+have to decrement the reference count to avoid a memory leak. Note that
+C<av_fetch> and C<av_store> both return C<SV**>'s, not C<SV*>'s as their
+return value.
+
+ void av_clear(AV*);
+ void av_undef(AV*);
+ void av_extend(AV*, I32 key);
+
+The C<av_clear> function deletes all the elements in the AV* array, but
+does not actually delete the array itself. The C<av_undef> function will
+delete all the elements in the array plus the array itself. The
+C<av_extend> function extends the array so that it contains C<key>
+elements. If C<key> is less than the current length of the array, then
+nothing is done.
+
+If you know the name of an array variable, you can get a pointer to its AV
+by using the following:
+
+ AV* perl_get_av("package::varname", FALSE);
+
+This returns NULL if the variable does not exist.
+
+See L<Understanding the Magic of Tied Hashes and Arrays> for more
+information on how to use the array access functions on tied arrays.
+
+=head2 Working with HVs
+
+To create an HV, you use the following routine:
+
+ HV* newHV();
+
+Once the HV has been created, the following operations are possible on HVs:
+
+ SV** hv_store(HV*, char* key, U32 klen, SV* val, U32 hash);
+ SV** hv_fetch(HV*, char* key, U32 klen, I32 lval);
+
+The C<klen> parameter is the length of the key being passed in (Note that
+you cannot pass 0 in as a value of C<klen> to tell Perl to measure the
+length of the key). The C<val> argument contains the SV pointer to the
+scalar being stored, and C<hash> is the precomputed hash value (zero if
+you want C<hv_store> to calculate it for you). The C<lval> parameter
+indicates whether this fetch is actually a part of a store operation, in
+which case a new undefined value will be added to the HV with the supplied
+key and C<hv_fetch> will return as if the value had already existed.
+
+Remember that C<hv_store> and C<hv_fetch> return C<SV**>'s and not just
+C<SV*>. To access the scalar value, you must first dereference the return
+value. However, you should check to make sure that the return value is
+not NULL before dereferencing it.
+
+These two functions check if a hash table entry exists, and deletes it.
+
+ bool hv_exists(HV*, char* key, U32 klen);
+ SV* hv_delete(HV*, char* key, U32 klen, I32 flags);
+
+If C<flags> does not include the C<G_DISCARD> flag then C<hv_delete> will
+create and return a mortal copy of the deleted value.
+
+And more miscellaneous functions:
+
+ void hv_clear(HV*);
+ void hv_undef(HV*);
+
+Like their AV counterparts, C<hv_clear> deletes all the entries in the hash
+table but does not actually delete the hash table. The C<hv_undef> deletes
+both the entries and the hash table itself.
+
+Perl keeps the actual data in linked list of structures with a typedef of HE.
+These contain the actual key and value pointers (plus extra administrative
+overhead). The key is a string pointer; the value is an C<SV*>. However,
+once you have an C<HE*>, to get the actual key and value, use the routines
+specified below.
+
+ I32 hv_iterinit(HV*);
+ /* Prepares starting point to traverse hash table */
+ HE* hv_iternext(HV*);
+ /* Get the next entry, and return a pointer to a
+ structure that has both the key and value */
+ char* hv_iterkey(HE* entry, I32* retlen);
+ /* Get the key from an HE structure and also return
+ the length of the key string */
+ SV* hv_iterval(HV*, HE* entry);
+ /* Return a SV pointer to the value of the HE
+ structure */
+ SV* hv_iternextsv(HV*, char** key, I32* retlen);
+ /* This convenience routine combines hv_iternext,
+ hv_iterkey, and hv_iterval. The key and retlen
+ arguments are return values for the key and its
+ length. The value is returned in the SV* argument */
+
+If you know the name of a hash variable, you can get a pointer to its HV
+by using the following:
+
+ HV* perl_get_hv("package::varname", FALSE);
+
+This returns NULL if the variable does not exist.
+
+The hash algorithm is defined in the C<PERL_HASH(hash, key, klen)> macro:
+
+ i = klen;
+ hash = 0;
+ s = key;
+ while (i--)
+ hash = hash * 33 + *s++;
+
+See L<Understanding the Magic of Tied Hashes and Arrays> for more
+information on how to use the hash access functions on tied hashes.
+
+=head2 Hash API Extensions
+
+Beginning with version 5.004, the following functions are also supported:
+
+ HE* hv_fetch_ent (HV* tb, SV* key, I32 lval, U32 hash);
+ HE* hv_store_ent (HV* tb, SV* key, SV* val, U32 hash);
+
+ bool hv_exists_ent (HV* tb, SV* key, U32 hash);
+ SV* hv_delete_ent (HV* tb, SV* key, I32 flags, U32 hash);
+
+ SV* hv_iterkeysv (HE* entry);
+
+Note that these functions take C<SV*> keys, which simplifies writing
+of extension code that deals with hash structures. These functions
+also allow passing of C<SV*> keys to C<tie> functions without forcing
+you to stringify the keys (unlike the previous set of functions).
+
+They also return and accept whole hash entries (C<HE*>), making their
+use more efficient (since the hash number for a particular string
+doesn't have to be recomputed every time). See L<API LISTING> later in
+this document for detailed descriptions.
+
+The following macros must always be used to access the contents of hash
+entries. Note that the arguments to these macros must be simple
+variables, since they may get evaluated more than once. See
+L<API LISTING> later in this document for detailed descriptions of these
+macros.
+
+ HePV(HE* he, STRLEN len)
+ HeVAL(HE* he)
+ HeHASH(HE* he)
+ HeSVKEY(HE* he)
+ HeSVKEY_force(HE* he)
+ HeSVKEY_set(HE* he, SV* sv)
+
+These two lower level macros are defined, but must only be used when
+dealing with keys that are not C<SV*>s:
+
+ HeKEY(HE* he)
+ HeKLEN(HE* he)
+
+Note that both C<hv_store> and C<hv_store_ent> do not increment the
+reference count of the stored C<val>, which is the caller's responsibility.
+If these functions return a NULL value, the caller will usually have to
+decrement the reference count of C<val> to avoid a memory leak.
+
+=head2 References
+
+References are a special type of scalar that point to other data types
+(including references).
+
+To create a reference, use either of the following functions:
+
+ SV* newRV_inc((SV*) thing);
+ SV* newRV_noinc((SV*) thing);
+
+The C<thing> argument can be any of an C<SV*>, C<AV*>, or C<HV*>. The
+functions are identical except that C<newRV_inc> increments the reference
+count of the C<thing>, while C<newRV_noinc> does not. For historical
+reasons, C<newRV> is a synonym for C<newRV_inc>.
+
+Once you have a reference, you can use the following macro to dereference
+the reference:
+
+ SvRV(SV*)
+
+then call the appropriate routines, casting the returned C<SV*> to either an
+C<AV*> or C<HV*>, if required.
+
+To determine if an SV is a reference, you can use the following macro:
+
+ SvROK(SV*)
+
+To discover what type of value the reference refers to, use the following
+macro and then check the return value.
+
+ SvTYPE(SvRV(SV*))
+
+The most useful types that will be returned are:
+
+ SVt_IV Scalar
+ SVt_NV Scalar
+ SVt_PV Scalar
+ SVt_RV Scalar
+ SVt_PVAV Array
+ SVt_PVHV Hash
+ SVt_PVCV Code
+ SVt_PVGV Glob (possible a file handle)
+ SVt_PVMG Blessed or Magical Scalar
+
+ See the sv.h header file for more details.
+
+=head2 Blessed References and Class Objects
+
+References are also used to support object-oriented programming. In the
+OO lexicon, an object is simply a reference that has been blessed into a
+package (or class). Once blessed, the programmer may now use the reference
+to access the various methods in the class.
+
+A reference can be blessed into a package with the following function:
+
+ SV* sv_bless(SV* sv, HV* stash);
+
+The C<sv> argument must be a reference. The C<stash> argument specifies
+which class the reference will belong to. See
+L<Stashes and Globs> for information on converting class names into stashes.
+
+/* Still under construction */
+
+Upgrades rv to reference if not already one. Creates new SV for rv to
+point to. If C<classname> is non-null, the SV is blessed into the specified
+class. SV is returned.
+
+ SV* newSVrv(SV* rv, char* classname);
+
+Copies integer or double into an SV whose reference is C<rv>. SV is blessed
+if C<classname> is non-null.
+
+ SV* sv_setref_iv(SV* rv, char* classname, IV iv);
+ SV* sv_setref_nv(SV* rv, char* classname, NV iv);
+
+Copies the pointer value (I<the address, not the string!>) into an SV whose
+reference is rv. SV is blessed if C<classname> is non-null.
+
+ SV* sv_setref_pv(SV* rv, char* classname, PV iv);
+
+Copies string into an SV whose reference is C<rv>. Set length to 0 to let
+Perl calculate the string length. SV is blessed if C<classname> is non-null.
+
+ SV* sv_setref_pvn(SV* rv, char* classname, PV iv, int length);
+
+Tests whether the SV is blessed into the specified class. It does not
+check inheritance relationships.
+
+ int sv_isa(SV* sv, char* name);
+
+Tests whether the SV is a reference to a blessed object.
+
+ int sv_isobject(SV* sv);
+
+Tests whether the SV is derived from the specified class. SV can be either
+a reference to a blessed object or a string containing a class name. This
+is the function implementing the C<UNIVERSAL::isa> functionality.
+
+ bool sv_derived_from(SV* sv, char* name);
+
+To check if you've got an object derived from a specific class you have
+to write:
+
+ if (sv_isobject(sv) && sv_derived_from(sv, class)) { ... }
+
+=head2 Creating New Variables
+
+To create a new Perl variable with an undef value which can be accessed from
+your Perl script, use the following routines, depending on the variable type.
+
+ SV* perl_get_sv("package::varname", TRUE);
+ AV* perl_get_av("package::varname", TRUE);
+ HV* perl_get_hv("package::varname", TRUE);
+
+Notice the use of TRUE as the second parameter. The new variable can now
+be set, using the routines appropriate to the data type.
+
+There are additional macros whose values may be bitwise OR'ed with the
+C<TRUE> argument to enable certain extra features. Those bits are:
+
+ GV_ADDMULTI Marks the variable as multiply defined, thus preventing the
+ "Name <varname> used only once: possible typo" warning.
+ GV_ADDWARN Issues the warning "Had to create <varname> unexpectedly" if
+ the variable did not exist before the function was called.
+
+If you do not specify a package name, the variable is created in the current
+package.
+
+=head2 Reference Counts and Mortality
+
+Perl uses an reference count-driven garbage collection mechanism. SVs,
+AVs, or HVs (xV for short in the following) start their life with a
+reference count of 1. If the reference count of an xV ever drops to 0,
+then it will be destroyed and its memory made available for reuse.
+
+This normally doesn't happen at the Perl level unless a variable is
+undef'ed or the last variable holding a reference to it is changed or
+overwritten. At the internal level, however, reference counts can be
+manipulated with the following macros:
+
+ int SvREFCNT(SV* sv);
+ SV* SvREFCNT_inc(SV* sv);
+ void SvREFCNT_dec(SV* sv);
+
+However, there is one other function which manipulates the reference
+count of its argument. The C<newRV_inc> function, you will recall,
+creates a reference to the specified argument. As a side effect,
+it increments the argument's reference count. If this is not what
+you want, use C<newRV_noinc> instead.
+
+For example, imagine you want to return a reference from an XSUB function.
+Inside the XSUB routine, you create an SV which initially has a reference
+count of one. Then you call C<newRV_inc>, passing it the just-created SV.
+This returns the reference as a new SV, but the reference count of the
+SV you passed to C<newRV_inc> has been incremented to two. Now you
+return the reference from the XSUB routine and forget about the SV.
+But Perl hasn't! Whenever the returned reference is destroyed, the
+reference count of the original SV is decreased to one and nothing happens.
+The SV will hang around without any way to access it until Perl itself
+terminates. This is a memory leak.
+
+The correct procedure, then, is to use C<newRV_noinc> instead of
+C<newRV_inc>. Then, if and when the last reference is destroyed,
+the reference count of the SV will go to zero and it will be destroyed,
+stopping any memory leak.
+
+There are some convenience functions available that can help with the
+destruction of xVs. These functions introduce the concept of "mortality".
+An xV that is mortal has had its reference count marked to be decremented,
+but not actually decremented, until "a short time later". Generally the
+term "short time later" means a single Perl statement, such as a call to
+an XSUB function. The actual determinant for when mortal xVs have their
+reference count decremented depends on two macros, SAVETMPS and FREETMPS.
+See L<perlcall> and L<perlxs> for more details on these macros.
+
+"Mortalization" then is at its simplest a deferred C<SvREFCNT_dec>.
+However, if you mortalize a variable twice, the reference count will
+later be decremented twice.
+
+You should be careful about creating mortal variables. Strange things
+can happen if you make the same value mortal within multiple contexts,
+or if you make a variable mortal multiple times.
+
+To create a mortal variable, use the functions:
+
+ SV* sv_newmortal()
+ SV* sv_2mortal(SV*)
+ SV* sv_mortalcopy(SV*)
+
+The first call creates a mortal SV, the second converts an existing
+SV to a mortal SV (and thus defers a call to C<SvREFCNT_dec>), and the
+third creates a mortal copy of an existing SV.
+
+The mortal routines are not just for SVs -- AVs and HVs can be
+made mortal by passing their address (type-casted to C<SV*>) to the
+C<sv_2mortal> or C<sv_mortalcopy> routines.
+
+=head2 Stashes and Globs
+
+A "stash" is a hash that contains all of the different objects that
+are contained within a package. Each key of the stash is a symbol
+name (shared by all the different types of objects that have the same
+name), and each value in the hash table is a GV (Glob Value). This GV
+in turn contains references to the various objects of that name,
+including (but not limited to) the following:
+
+ Scalar Value
+ Array Value
+ Hash Value
+ I/O Handle
+ Format
+ Subroutine
+
+There is a single stash called "PL_defstash" that holds the items that exist
+in the "main" package. To get at the items in other packages, append the
+string "::" to the package name. The items in the "Foo" package are in
+the stash "Foo::" in PL_defstash. The items in the "Bar::Baz" package are
+in the stash "Baz::" in "Bar::"'s stash.
+
+To get the stash pointer for a particular package, use the function:
+
+ HV* gv_stashpv(char* name, I32 create)
+ HV* gv_stashsv(SV*, I32 create)
+
+The first function takes a literal string, the second uses the string stored
+in the SV. Remember that a stash is just a hash table, so you get back an
+C<HV*>. The C<create> flag will create a new package if it is set.
+
+The name that C<gv_stash*v> wants is the name of the package whose symbol table
+you want. The default package is called C<main>. If you have multiply nested
+packages, pass their names to C<gv_stash*v>, separated by C<::> as in the Perl
+language itself.
+
+Alternately, if you have an SV that is a blessed reference, you can find
+out the stash pointer by using:
+
+ HV* SvSTASH(SvRV(SV*));
+
+then use the following to get the package name itself:
+
+ char* HvNAME(HV* stash);
+
+If you need to bless or re-bless an object you can use the following
+function:
+
+ SV* sv_bless(SV*, HV* stash)
+
+where the first argument, an C<SV*>, must be a reference, and the second
+argument is a stash. The returned C<SV*> can now be used in the same way
+as any other SV.
+
+For more information on references and blessings, consult L<perlref>.
+
+=head2 Double-Typed SVs
+
+Scalar variables normally contain only one type of value, an integer,
+double, pointer, or reference. Perl will automatically convert the
+actual scalar data from the stored type into the requested type.
+
+Some scalar variables contain more than one type of scalar data. For
+example, the variable C<$!> contains either the numeric value of C<errno>
+or its string equivalent from either C<strerror> or C<sys_errlist[]>.
+
+To force multiple data values into an SV, you must do two things: use the
+C<sv_set*v> routines to add the additional scalar type, then set a flag
+so that Perl will believe it contains more than one type of data. The
+four macros to set the flags are:
+
+ SvIOK_on
+ SvNOK_on
+ SvPOK_on
+ SvROK_on
+
+The particular macro you must use depends on which C<sv_set*v> routine
+you called first. This is because every C<sv_set*v> routine turns on
+only the bit for the particular type of data being set, and turns off
+all the rest.
+
+For example, to create a new Perl variable called "dberror" that contains
+both the numeric and descriptive string error values, you could use the
+following code:
+
+ extern int dberror;
+ extern char *dberror_list;
+
+ SV* sv = perl_get_sv("dberror", TRUE);
+ sv_setiv(sv, (IV) dberror);
+ sv_setpv(sv, dberror_list[dberror]);
+ SvIOK_on(sv);
+
+If the order of C<sv_setiv> and C<sv_setpv> had been reversed, then the
+macro C<SvPOK_on> would need to be called instead of C<SvIOK_on>.
+
+=head2 Magic Variables
+
+[This section still under construction. Ignore everything here. Post no
+bills. Everything not permitted is forbidden.]
+
+Any SV may be magical, that is, it has special features that a normal
+SV does not have. These features are stored in the SV structure in a
+linked list of C<struct magic>'s, typedef'ed to C<MAGIC>.
+
+ struct magic {
+ MAGIC* mg_moremagic;
+ MGVTBL* mg_virtual;
+ U16 mg_private;
+ char mg_type;
+ U8 mg_flags;
+ SV* mg_obj;
+ char* mg_ptr;
+ I32 mg_len;
+ };
+
+Note this is current as of patchlevel 0, and could change at any time.
+
+=head2 Assigning Magic
+
+Perl adds magic to an SV using the sv_magic function:
+
+ void sv_magic(SV* sv, SV* obj, int how, char* name, I32 namlen);
+
+The C<sv> argument is a pointer to the SV that is to acquire a new magical
+feature.
+
+If C<sv> is not already magical, Perl uses the C<SvUPGRADE> macro to
+set the C<SVt_PVMG> flag for the C<sv>. Perl then continues by adding
+it to the beginning of the linked list of magical features. Any prior
+entry of the same type of magic is deleted. Note that this can be
+overridden, and multiple instances of the same type of magic can be
+associated with an SV.
+
+The C<name> and C<namlen> arguments are used to associate a string with
+the magic, typically the name of a variable. C<namlen> is stored in the
+C<mg_len> field and if C<name> is non-null and C<namlen> >= 0 a malloc'd
+copy of the name is stored in C<mg_ptr> field.
+
+The sv_magic function uses C<how> to determine which, if any, predefined
+"Magic Virtual Table" should be assigned to the C<mg_virtual> field.
+See the "Magic Virtual Table" section below. The C<how> argument is also
+stored in the C<mg_type> field.
+
+The C<obj> argument is stored in the C<mg_obj> field of the C<MAGIC>
+structure. If it is not the same as the C<sv> argument, the reference
+count of the C<obj> object is incremented. If it is the same, or if
+the C<how> argument is "#", or if it is a NULL pointer, then C<obj> is
+merely stored, without the reference count being incremented.
+
+There is also a function to add magic to an C<HV>:
+
+ void hv_magic(HV *hv, GV *gv, int how);
+
+This simply calls C<sv_magic> and coerces the C<gv> argument into an C<SV>.
+
+To remove the magic from an SV, call the function sv_unmagic:
+
+ void sv_unmagic(SV *sv, int type);
+
+The C<type> argument should be equal to the C<how> value when the C<SV>
+was initially made magical.
+
+=head2 Magic Virtual Tables
+
+The C<mg_virtual> field in the C<MAGIC> structure is a pointer to a
+C<MGVTBL>, which is a structure of function pointers and stands for
+"Magic Virtual Table" to handle the various operations that might be
+applied to that variable.
+
+The C<MGVTBL> has five pointers to the following routine types:
+
+ int (*svt_get)(SV* sv, MAGIC* mg);
+ int (*svt_set)(SV* sv, MAGIC* mg);
+ U32 (*svt_len)(SV* sv, MAGIC* mg);
+ int (*svt_clear)(SV* sv, MAGIC* mg);
+ int (*svt_free)(SV* sv, MAGIC* mg);
+
+This MGVTBL structure is set at compile-time in C<perl.h> and there are
+currently 19 types (or 21 with overloading turned on). These different
+structures contain pointers to various routines that perform additional
+actions depending on which function is being called.
+
+ Function pointer Action taken
+ ---------------- ------------
+ svt_get Do something after the value of the SV is retrieved.
+ svt_set Do something after the SV is assigned a value.
+ svt_len Report on the SV's length.
+ svt_clear Clear something the SV represents.
+ svt_free Free any extra storage associated with the SV.
+
+For instance, the MGVTBL structure called C<vtbl_sv> (which corresponds
+to an C<mg_type> of '\0') contains:
+
+ { magic_get, magic_set, magic_len, 0, 0 }
+
+Thus, when an SV is determined to be magical and of type '\0', if a get
+operation is being performed, the routine C<magic_get> is called. All
+the various routines for the various magical types begin with C<magic_>.
+
+The current kinds of Magic Virtual Tables are:
+
+ mg_type MGVTBL Type of magic
+ ------- ------ ----------------------------
+ \0 vtbl_sv Special scalar variable
+ A vtbl_amagic %OVERLOAD hash
+ a vtbl_amagicelem %OVERLOAD hash element
+ c (none) Holds overload table (AMT) on stash
+ B vtbl_bm Boyer-Moore (fast string search)
+ E vtbl_env %ENV hash
+ e vtbl_envelem %ENV hash element
+ f vtbl_fm Formline ('compiled' format)
+ g vtbl_mglob m//g target / study()ed string
+ I vtbl_isa @ISA array
+ i vtbl_isaelem @ISA array element
+ k vtbl_nkeys scalar(keys()) lvalue
+ L (none) Debugger %_<filename
+ l vtbl_dbline Debugger %_<filename element
+ o vtbl_collxfrm Locale transformation
+ P vtbl_pack Tied array or hash
+ p vtbl_packelem Tied array or hash element
+ q vtbl_packelem Tied scalar or handle
+ S vtbl_sig %SIG hash
+ s vtbl_sigelem %SIG hash element
+ t vtbl_taint Taintedness
+ U vtbl_uvar Available for use by extensions
+ v vtbl_vec vec() lvalue
+ x vtbl_substr substr() lvalue
+ y vtbl_defelem Shadow "foreach" iterator variable /
+ smart parameter vivification
+ * vtbl_glob GV (typeglob)
+ # vtbl_arylen Array length ($#ary)
+ . vtbl_pos pos() lvalue
+ ~ (none) Available for use by extensions
+
+When an uppercase and lowercase letter both exist in the table, then the
+uppercase letter is used to represent some kind of composite type (a list
+or a hash), and the lowercase letter is used to represent an element of
+that composite type.
+
+The '~' and 'U' magic types are defined specifically for use by
+extensions and will not be used by perl itself. Extensions can use
+'~' magic to 'attach' private information to variables (typically
+objects). This is especially useful because there is no way for
+normal perl code to corrupt this private information (unlike using
+extra elements of a hash object).
+
+Similarly, 'U' magic can be used much like tie() to call a C function
+any time a scalar's value is used or changed. The C<MAGIC>'s
+C<mg_ptr> field points to a C<ufuncs> structure:
+
+ struct ufuncs {
+ I32 (*uf_val)(IV, SV*);
+ I32 (*uf_set)(IV, SV*);
+ IV uf_index;
+ };
+
+When the SV is read from or written to, the C<uf_val> or C<uf_set>
+function will be called with C<uf_index> as the first arg and a
+pointer to the SV as the second.
+
+Note that because multiple extensions may be using '~' or 'U' magic,
+it is important for extensions to take extra care to avoid conflict.
+Typically only using the magic on objects blessed into the same class
+as the extension is sufficient. For '~' magic, it may also be
+appropriate to add an I32 'signature' at the top of the private data
+area and check that.
+
+Also note that the C<sv_set*()> and C<sv_cat*()> functions described
+earlier do B<not> invoke 'set' magic on their targets. This must
+be done by the user either by calling the C<SvSETMAGIC()> macro after
+calling these functions, or by using one of the C<sv_set*_mg()> or
+C<sv_cat*_mg()> functions. Similarly, generic C code must call the
+C<SvGETMAGIC()> macro to invoke any 'get' magic if they use an SV
+obtained from external sources in functions that don't handle magic.
+L<API LISTING> later in this document identifies such functions.
+For example, calls to the C<sv_cat*()> functions typically need to be
+followed by C<SvSETMAGIC()>, but they don't need a prior C<SvGETMAGIC()>
+since their implementation handles 'get' magic.
+
+=head2 Finding Magic
+
+ MAGIC* mg_find(SV*, int type); /* Finds the magic pointer of that type */
+
+This routine returns a pointer to the C<MAGIC> structure stored in the SV.
+If the SV does not have that magical feature, C<NULL> is returned. Also,
+if the SV is not of type SVt_PVMG, Perl may core dump.
+
+ int mg_copy(SV* sv, SV* nsv, char* key, STRLEN klen);
+
+This routine checks to see what types of magic C<sv> has. If the mg_type
+field is an uppercase letter, then the mg_obj is copied to C<nsv>, but
+the mg_type field is changed to be the lowercase letter.
+
+=head2 Understanding the Magic of Tied Hashes and Arrays
+
+Tied hashes and arrays are magical beasts of the 'P' magic type.
+
+WARNING: As of the 5.004 release, proper usage of the array and hash
+access functions requires understanding a few caveats. Some
+of these caveats are actually considered bugs in the API, to be fixed
+in later releases, and are bracketed with [MAYCHANGE] below. If
+you find yourself actually applying such information in this section, be
+aware that the behavior may change in the future, umm, without warning.
+
+The C<av_store> function, when given a tied array argument, merely
+copies the magic of the array onto the value to be "stored", using
+C<mg_copy>. It may also return NULL, indicating that the value did not
+actually need to be stored in the array. [MAYCHANGE] After a call to
+C<av_store> on a tied array, the caller will usually need to call
+C<mg_set(val)> to actually invoke the perl level "STORE" method on the
+TIEARRAY object. If C<av_store> did return NULL, a call to
+C<SvREFCNT_dec(val)> will also be usually necessary to avoid a memory
+leak. [/MAYCHANGE]
+
+The previous paragraph is applicable verbatim to tied hash access using the
+C<hv_store> and C<hv_store_ent> functions as well.
+
+C<av_fetch> and the corresponding hash functions C<hv_fetch> and
+C<hv_fetch_ent> actually return an undefined mortal value whose magic
+has been initialized using C<mg_copy>. Note the value so returned does not
+need to be deallocated, as it is already mortal. [MAYCHANGE] But you will
+need to call C<mg_get()> on the returned value in order to actually invoke
+the perl level "FETCH" method on the underlying TIE object. Similarly,
+you may also call C<mg_set()> on the return value after possibly assigning
+a suitable value to it using C<sv_setsv>, which will invoke the "STORE"
+method on the TIE object. [/MAYCHANGE]
+
+[MAYCHANGE]
+In other words, the array or hash fetch/store functions don't really
+fetch and store actual values in the case of tied arrays and hashes. They
+merely call C<mg_copy> to attach magic to the values that were meant to be
+"stored" or "fetched". Later calls to C<mg_get> and C<mg_set> actually
+do the job of invoking the TIE methods on the underlying objects. Thus
+the magic mechanism currently implements a kind of lazy access to arrays
+and hashes.
+
+Currently (as of perl version 5.004), use of the hash and array access
+functions requires the user to be aware of whether they are operating on
+"normal" hashes and arrays, or on their tied variants. The API may be
+changed to provide more transparent access to both tied and normal data
+types in future versions.
+[/MAYCHANGE]
+
+You would do well to understand that the TIEARRAY and TIEHASH interfaces
+are mere sugar to invoke some perl method calls while using the uniform hash
+and array syntax. The use of this sugar imposes some overhead (typically
+about two to four extra opcodes per FETCH/STORE operation, in addition to
+the creation of all the mortal variables required to invoke the methods).
+This overhead will be comparatively small if the TIE methods are themselves
+substantial, but if they are only a few statements long, the overhead
+will not be insignificant.
+
+=head2 Localizing changes
+
+Perl has a very handy construction
+
+ {
+ local $var = 2;
+ ...
+ }
+
+This construction is I<approximately> equivalent to
+
+ {
+ my $oldvar = $var;
+ $var = 2;
+ ...
+ $var = $oldvar;
+ }
+
+The biggest difference is that the first construction would
+reinstate the initial value of $var, irrespective of how control exits
+the block: C<goto>, C<return>, C<die>/C<eval> etc. It is a little bit
+more efficient as well.
+
+There is a way to achieve a similar task from C via Perl API: create a
+I<pseudo-block>, and arrange for some changes to be automatically
+undone at the end of it, either explicit, or via a non-local exit (via
+die()). A I<block>-like construct is created by a pair of
+C<ENTER>/C<LEAVE> macros (see L<perlcall/EXAMPLE/"Returning a
+Scalar">). Such a construct may be created specially for some
+important localized task, or an existing one (like boundaries of
+enclosing Perl subroutine/block, or an existing pair for freeing TMPs)
+may be used. (In the second case the overhead of additional
+localization must be almost negligible.) Note that any XSUB is
+automatically enclosed in an C<ENTER>/C<LEAVE> pair.
+
+Inside such a I<pseudo-block> the following service is available:
+
+=over
+
+=item C<SAVEINT(int i)>
+
+=item C<SAVEIV(IV i)>
+
+=item C<SAVEI32(I32 i)>
+
+=item C<SAVELONG(long i)>
+
+These macros arrange things to restore the value of integer variable
+C<i> at the end of enclosing I<pseudo-block>.
+
+=item C<SAVESPTR(s)>
+
+=item C<SAVEPPTR(p)>
+
+These macros arrange things to restore the value of pointers C<s> and
+C<p>. C<s> must be a pointer of a type which survives conversion to
+C<SV*> and back, C<p> should be able to survive conversion to C<char*>
+and back.
+
+=item C<SAVEFREESV(SV *sv)>
+
+The refcount of C<sv> would be decremented at the end of
+I<pseudo-block>. This is similar to C<sv_2mortal>, which should (?) be
+used instead.
+
+=item C<SAVEFREEOP(OP *op)>
+
+The C<OP *> is op_free()ed at the end of I<pseudo-block>.
+
+=item C<SAVEFREEPV(p)>
+
+The chunk of memory which is pointed to by C<p> is Safefree()ed at the
+end of I<pseudo-block>.
+
+=item C<SAVECLEARSV(SV *sv)>
+
+Clears a slot in the current scratchpad which corresponds to C<sv> at
+the end of I<pseudo-block>.
+
+=item C<SAVEDELETE(HV *hv, char *key, I32 length)>
+
+The key C<key> of C<hv> is deleted at the end of I<pseudo-block>. The
+string pointed to by C<key> is Safefree()ed. If one has a I<key> in
+short-lived storage, the corresponding string may be reallocated like
+this:
+
+ SAVEDELETE(PL_defstash, savepv(tmpbuf), strlen(tmpbuf));
+
+=item C<SAVEDESTRUCTOR(f,p)>
+
+At the end of I<pseudo-block> the function C<f> is called with the
+only argument (of type C<void*>) C<p>.
+
+=item C<SAVESTACK_POS()>
+
+The current offset on the Perl internal stack (cf. C<SP>) is restored
+at the end of I<pseudo-block>.
+
+=back
+
+The following API list contains functions, thus one needs to
+provide pointers to the modifiable data explicitly (either C pointers,
+or Perlish C<GV *>s). Where the above macros take C<int>, a similar
+function takes C<int *>.
+
+=over
+
+=item C<SV* save_scalar(GV *gv)>
+
+Equivalent to Perl code C<local $gv>.
+
+=item C<AV* save_ary(GV *gv)>
+
+=item C<HV* save_hash(GV *gv)>
+
+Similar to C<save_scalar>, but localize C<@gv> and C<%gv>.
+
+=item C<void save_item(SV *item)>
+
+Duplicates the current value of C<SV>, on the exit from the current
+C<ENTER>/C<LEAVE> I<pseudo-block> will restore the value of C<SV>
+using the stored value.
+
+=item C<void save_list(SV **sarg, I32 maxsarg)>
+
+A variant of C<save_item> which takes multiple arguments via an array
+C<sarg> of C<SV*> of length C<maxsarg>.
+
+=item C<SV* save_svref(SV **sptr)>
+
+Similar to C<save_scalar>, but will reinstate a C<SV *>.
+
+=item C<void save_aptr(AV **aptr)>
+
+=item C<void save_hptr(HV **hptr)>
+
+Similar to C<save_svref>, but localize C<AV *> and C<HV *>.
+
+=back
+
+The C<Alias> module implements localization of the basic types within the
+I<caller's scope>. People who are interested in how to localize things in
+the containing scope should take a look there too.
+
+=head1 Subroutines
+
+=head2 XSUBs and the Argument Stack
+
+The XSUB mechanism is a simple way for Perl programs to access C subroutines.
+An XSUB routine will have a stack that contains the arguments from the Perl
+program, and a way to map from the Perl data structures to a C equivalent.
+
+The stack arguments are accessible through the C<ST(n)> macro, which returns
+the C<n>'th stack argument. Argument 0 is the first argument passed in the
+Perl subroutine call. These arguments are C<SV*>, and can be used anywhere
+an C<SV*> is used.
+
+Most of the time, output from the C routine can be handled through use of
+the RETVAL and OUTPUT directives. However, there are some cases where the
+argument stack is not already long enough to handle all the return values.
+An example is the POSIX tzname() call, which takes no arguments, but returns
+two, the local time zone's standard and summer time abbreviations.
+
+To handle this situation, the PPCODE directive is used and the stack is
+extended using the macro:
+
+ EXTEND(SP, num);
+
+where C<SP> is the macro that represents the local copy of the stack pointer,
+and C<num> is the number of elements the stack should be extended by.
+
+Now that there is room on the stack, values can be pushed on it using the
+macros to push IVs, doubles, strings, and SV pointers respectively:
+
+ PUSHi(IV)
+ PUSHn(double)
+ PUSHp(char*, I32)
+ PUSHs(SV*)
+
+And now the Perl program calling C<tzname>, the two values will be assigned
+as in:
+
+ ($standard_abbrev, $summer_abbrev) = POSIX::tzname;
+
+An alternate (and possibly simpler) method to pushing values on the stack is
+to use the macros:
+
+ XPUSHi(IV)
+ XPUSHn(double)
+ XPUSHp(char*, I32)
+ XPUSHs(SV*)
+
+These macros automatically adjust the stack for you, if needed. Thus, you
+do not need to call C<EXTEND> to extend the stack.
+
+For more information, consult L<perlxs> and L<perlxstut>.
+
+=head2 Calling Perl Routines from within C Programs
+
+There are four routines that can be used to call a Perl subroutine from
+within a C program. These four are:
+
+ I32 perl_call_sv(SV*, I32);
+ I32 perl_call_pv(char*, I32);
+ I32 perl_call_method(char*, I32);
+ I32 perl_call_argv(char*, I32, register char**);
+
+The routine most often used is C<perl_call_sv>. The C<SV*> argument
+contains either the name of the Perl subroutine to be called, or a
+reference to the subroutine. The second argument consists of flags
+that control the context in which the subroutine is called, whether
+or not the subroutine is being passed arguments, how errors should be
+trapped, and how to treat return values.
+
+All four routines return the number of arguments that the subroutine returned
+on the Perl stack.
+
+When using any of these routines (except C<perl_call_argv>), the programmer
+must manipulate the Perl stack. These include the following macros and
+functions:
+
+ dSP
+ SP
+ PUSHMARK()
+ PUTBACK
+ SPAGAIN
+ ENTER
+ SAVETMPS
+ FREETMPS
+ LEAVE
+ XPUSH*()
+ POP*()
+
+For a detailed description of calling conventions from C to Perl,
+consult L<perlcall>.
+
+=head2 Memory Allocation
+
+It is suggested that you use the version of malloc that is distributed
+with Perl. It keeps pools of various sizes of unallocated memory in
+order to satisfy allocation requests more quickly. However, on some
+platforms, it may cause spurious malloc or free errors.
+
+ New(x, pointer, number, type);
+ Newc(x, pointer, number, type, cast);
+ Newz(x, pointer, number, type);
+
+These three macros are used to initially allocate memory.
+
+The first argument C<x> was a "magic cookie" that was used to keep track
+of who called the macro, to help when debugging memory problems. However,
+the current code makes no use of this feature (most Perl developers now
+use run-time memory checkers), so this argument can be any number.
+
+The second argument C<pointer> should be the name of a variable that will
+point to the newly allocated memory.
+
+The third and fourth arguments C<number> and C<type> specify how many of
+the specified type of data structure should be allocated. The argument
+C<type> is passed to C<sizeof>. The final argument to C<Newc>, C<cast>,
+should be used if the C<pointer> argument is different from the C<type>
+argument.
+
+Unlike the C<New> and C<Newc> macros, the C<Newz> macro calls C<memzero>
+to zero out all the newly allocated memory.
+
+ Renew(pointer, number, type);
+ Renewc(pointer, number, type, cast);
+ Safefree(pointer)
+
+These three macros are used to change a memory buffer size or to free a
+piece of memory no longer needed. The arguments to C<Renew> and C<Renewc>
+match those of C<New> and C<Newc> with the exception of not needing the
+"magic cookie" argument.
+
+ Move(source, dest, number, type);
+ Copy(source, dest, number, type);
+ Zero(dest, number, type);
+
+These three macros are used to move, copy, or zero out previously allocated
+memory. The C<source> and C<dest> arguments point to the source and
+destination starting points. Perl will move, copy, or zero out C<number>
+instances of the size of the C<type> data structure (using the C<sizeof>
+function).
+
+=head2 PerlIO
+
+The most recent development releases of Perl has been experimenting with
+removing Perl's dependency on the "normal" standard I/O suite and allowing
+other stdio implementations to be used. This involves creating a new
+abstraction layer that then calls whichever implementation of stdio Perl
+was compiled with. All XSUBs should now use the functions in the PerlIO
+abstraction layer and not make any assumptions about what kind of stdio
+is being used.
+
+For a complete description of the PerlIO abstraction, consult L<perlapio>.
+
+=head2 Putting a C value on Perl stack
+
+A lot of opcodes (this is an elementary operation in the internal perl
+stack machine) put an SV* on the stack. However, as an optimization
+the corresponding SV is (usually) not recreated each time. The opcodes
+reuse specially assigned SVs (I<target>s) which are (as a corollary)
+not constantly freed/created.
+
+Each of the targets is created only once (but see
+L<Scratchpads and recursion> below), and when an opcode needs to put
+an integer, a double, or a string on stack, it just sets the
+corresponding parts of its I<target> and puts the I<target> on stack.
+
+The macro to put this target on stack is C<PUSHTARG>, and it is
+directly used in some opcodes, as well as indirectly in zillions of
+others, which use it via C<(X)PUSH[pni]>.
+
+=head2 Scratchpads
+
+The question remains on when the SVs which are I<target>s for opcodes
+are created. The answer is that they are created when the current unit --
+a subroutine or a file (for opcodes for statements outside of
+subroutines) -- is compiled. During this time a special anonymous Perl
+array is created, which is called a scratchpad for the current
+unit.
+
+A scratchpad keeps SVs which are lexicals for the current unit and are
+targets for opcodes. One can deduce that an SV lives on a scratchpad
+by looking on its flags: lexicals have C<SVs_PADMY> set, and
+I<target>s have C<SVs_PADTMP> set.
+
+The correspondence between OPs and I<target>s is not 1-to-1. Different
+OPs in the compile tree of the unit can use the same target, if this
+would not conflict with the expected life of the temporary.
+
+=head2 Scratchpads and recursion
+
+In fact it is not 100% true that a compiled unit contains a pointer to
+the scratchpad AV. In fact it contains a pointer to an AV of
+(initially) one element, and this element is the scratchpad AV. Why do
+we need an extra level of indirection?
+
+The answer is B<recursion>, and maybe (sometime soon) B<threads>. Both
+these can create several execution pointers going into the same
+subroutine. For the subroutine-child not write over the temporaries
+for the subroutine-parent (lifespan of which covers the call to the
+child), the parent and the child should have different
+scratchpads. (I<And> the lexicals should be separate anyway!)
+
+So each subroutine is born with an array of scratchpads (of length 1).
+On each entry to the subroutine it is checked that the current
+depth of the recursion is not more than the length of this array, and
+if it is, new scratchpad is created and pushed into the array.
+
+The I<target>s on this scratchpad are C<undef>s, but they are already
+marked with correct flags.
+
+=head1 Compiled code
+
+=head2 Code tree
+
+Here we describe the internal form your code is converted to by
+Perl. Start with a simple example:
+
+ $a = $b + $c;
+
+This is converted to a tree similar to this one:
+
+ assign-to
+ / \
+ + $a
+ / \
+ $b $c
+
+(but slightly more complicated). This tree reflects the way Perl
+parsed your code, but has nothing to do with the execution order.
+There is an additional "thread" going through the nodes of the tree
+which shows the order of execution of the nodes. In our simplified
+example above it looks like:
+
+ $b ---> $c ---> + ---> $a ---> assign-to
+
+But with the actual compile tree for C<$a = $b + $c> it is different:
+some nodes I<optimized away>. As a corollary, though the actual tree
+contains more nodes than our simplified example, the execution order
+is the same as in our example.
+
+=head2 Examining the tree
+
+If you have your perl compiled for debugging (usually done with C<-D
+optimize=-g> on C<Configure> command line), you may examine the
+compiled tree by specifying C<-Dx> on the Perl command line. The
+output takes several lines per node, and for C<$b+$c> it looks like
+this:
+
+ 5 TYPE = add ===> 6
+ TARG = 1
+ FLAGS = (SCALAR,KIDS)
+ {
+ TYPE = null ===> (4)
+ (was rv2sv)
+ FLAGS = (SCALAR,KIDS)
+ {
+ 3 TYPE = gvsv ===> 4
+ FLAGS = (SCALAR)
+ GV = main::b
+ }
+ }
+ {
+ TYPE = null ===> (5)
+ (was rv2sv)
+ FLAGS = (SCALAR,KIDS)
+ {
+ 4 TYPE = gvsv ===> 5
+ FLAGS = (SCALAR)
+ GV = main::c
+ }
+ }
+
+This tree has 5 nodes (one per C<TYPE> specifier), only 3 of them are
+not optimized away (one per number in the left column). The immediate
+children of the given node correspond to C<{}> pairs on the same level
+of indentation, thus this listing corresponds to the tree:
+
+ add
+ / \
+ null null
+ | |
+ gvsv gvsv
+
+The execution order is indicated by C<===E<gt>> marks, thus it is C<3
+4 5 6> (node C<6> is not included into above listing), i.e.,
+C<gvsv gvsv add whatever>.
+
+=head2 Compile pass 1: check routines
+
+The tree is created by the I<pseudo-compiler> while yacc code feeds it
+the constructions it recognizes. Since yacc works bottom-up, so does
+the first pass of perl compilation.
+
+What makes this pass interesting for perl developers is that some
+optimization may be performed on this pass. This is optimization by
+so-called I<check routines>. The correspondence between node names
+and corresponding check routines is described in F<opcode.pl> (do not
+forget to run C<make regen_headers> if you modify this file).
+
+A check routine is called when the node is fully constructed except
+for the execution-order thread. Since at this time there are no
+back-links to the currently constructed node, one can do most any
+operation to the top-level node, including freeing it and/or creating
+new nodes above/below it.
+
+The check routine returns the node which should be inserted into the
+tree (if the top-level node was not modified, check routine returns
+its argument).
+
+By convention, check routines have names C<ck_*>. They are usually
+called from C<new*OP> subroutines (or C<convert>) (which in turn are
+called from F<perly.y>).
+
+=head2 Compile pass 1a: constant folding
+
+Immediately after the check routine is called the returned node is
+checked for being compile-time executable. If it is (the value is
+judged to be constant) it is immediately executed, and a I<constant>
+node with the "return value" of the corresponding subtree is
+substituted instead. The subtree is deleted.
+
+If constant folding was not performed, the execution-order thread is
+created.
+
+=head2 Compile pass 2: context propagation
+
+When a context for a part of compile tree is known, it is propagated
+down through the tree. At this time the context can have 5 values
+(instead of 2 for runtime context): void, boolean, scalar, list, and
+lvalue. In contrast with the pass 1 this pass is processed from top
+to bottom: a node's context determines the context for its children.
+
+Additional context-dependent optimizations are performed at this time.
+Since at this moment the compile tree contains back-references (via
+"thread" pointers), nodes cannot be free()d now. To allow
+optimized-away nodes at this stage, such nodes are null()ified instead
+of free()ing (i.e. their type is changed to OP_NULL).
+
+=head2 Compile pass 3: peephole optimization
+
+After the compile tree for a subroutine (or for an C<eval> or a file)
+is created, an additional pass over the code is performed. This pass
+is neither top-down or bottom-up, but in the execution order (with
+additional complications for conditionals). These optimizations are
+done in the subroutine peep(). Optimizations performed at this stage
+are subject to the same restrictions as in the pass 2.
+
+=head1 API LISTING
+
+This is a listing of functions, macros, flags, and variables that may be
+useful to extension writers or that may be found while reading other
+extensions.
+
+Note that all Perl API global variables must be referenced with the C<PL_>
+prefix. Some macros are provided for compatibility with the older,
+unadorned names, but this support will be removed in a future release.
+
+It is strongly recommended that all Perl API functions that don't begin
+with C<perl> be referenced with an explicit C<Perl_> prefix.
+
+The sort order of the listing is case insensitive, with any
+occurrences of '_' ignored for the the purpose of sorting.
+
+=over 8
+
+=item av_clear
+
+Clears an array, making it empty. Does not free the memory used by the
+array itself.
+
+ void av_clear (AV* ar)
+
+=item av_extend
+
+Pre-extend an array. The C<key> is the index to which the array should be
+extended.
+
+ void av_extend (AV* ar, I32 key)
+
+=item av_fetch
+
+Returns the SV at the specified index in the array. The C<key> is the
+index. If C<lval> is set then the fetch will be part of a store. Check
+that the return value is non-null before dereferencing it to a C<SV*>.
+
+See L<Understanding the Magic of Tied Hashes and Arrays> for more
+information on how to use this function on tied arrays.
+
+ SV** av_fetch (AV* ar, I32 key, I32 lval)
+
+=item AvFILL
+
+Same as C<av_len()>. Deprecated, use C<av_len()> instead.
+
+=item av_len
+
+Returns the highest index in the array. Returns -1 if the array is empty.
+
+ I32 av_len (AV* ar)
+
+=item av_make
+
+Creates a new AV and populates it with a list of SVs. The SVs are copied
+into the array, so they may be freed after the call to av_make. The new AV
+will have a reference count of 1.
+
+ AV* av_make (I32 size, SV** svp)
+
+=item av_pop
+
+Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array is
+empty.
+
+ SV* av_pop (AV* ar)
+
+=item av_push
+
+Pushes an SV onto the end of the array. The array will grow automatically
+to accommodate the addition.
+
+ void av_push (AV* ar, SV* val)
+
+=item av_shift
+
+Shifts an SV off the beginning of the array.
+
+ SV* av_shift (AV* ar)
+
+=item av_store
+
+Stores an SV in an array. The array index is specified as C<key>. The
+return value will be NULL if the operation failed or if the value did not
+need to be actually stored within the array (as in the case of tied arrays).
+Otherwise it can be dereferenced to get the original C<SV*>. Note that the
+caller is responsible for suitably incrementing the reference count of C<val>
+before the call, and decrementing it if the function returned NULL.
+
+See L<Understanding the Magic of Tied Hashes and Arrays> for more
+information on how to use this function on tied arrays.
+
+ SV** av_store (AV* ar, I32 key, SV* val)
+
+=item av_undef
+
+Undefines the array. Frees the memory used by the array itself.
+
+ void av_undef (AV* ar)
+
+=item av_unshift
+
+Unshift the given number of C<undef> values onto the beginning of the
+array. The array will grow automatically to accommodate the addition.
+You must then use C<av_store> to assign values to these new elements.
+
+ void av_unshift (AV* ar, I32 num)
+
+=item CLASS
+
+Variable which is setup by C<xsubpp> to indicate the class name for a C++ XS
+constructor. This is always a C<char*>. See C<THIS> and
+L<perlxs/"Using XS With C++">.
+
+=item Copy
+
+The XSUB-writer's interface to the C C<memcpy> function. The C<s> is the
+source, C<d> is the destination, C<n> is the number of items, and C<t> is
+the type. May fail on overlapping copies. See also C<Move>.
+
+ void Copy( s, d, n, t )
+
+=item croak
+
+This is the XSUB-writer's interface to Perl's C<die> function. Use this
+function the same way you use the C C<printf> function. See C<warn>.
+
+=item CvSTASH
+
+Returns the stash of the CV.
+
+ HV* CvSTASH( SV* sv )
+
+=item PL_DBsingle
+
+When Perl is run in debugging mode, with the B<-d> switch, this SV is a
+boolean which indicates whether subs are being single-stepped.
+Single-stepping is automatically turned on after every step. This is the C
+variable which corresponds to Perl's $DB::single variable. See C<PL_DBsub>.
+
+=item PL_DBsub
+
+When Perl is run in debugging mode, with the B<-d> switch, this GV contains
+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 )
+
+=item PL_DBtrace
+
+Trace variable used when Perl is run in debugging mode, with the B<-d>
+switch. This is the C variable which corresponds to Perl's $DB::trace
+variable. See C<PL_DBsingle>.
+
+=item dMARK
+
+Declare a stack marker variable, C<mark>, for the XSUB. See C<MARK> and
+C<dORIGMARK>.
+
+=item dORIGMARK
+
+Saves the original stack mark for the XSUB. See C<ORIGMARK>.
+
+=item PL_dowarn
+
+The C variable which corresponds to Perl's $^W warning variable.
+
+=item dSP
+
+Declares a local copy of perl's stack pointer for the XSUB, available via
+the C<SP> macro. See C<SP>.
+
+=item dXSARGS
+
+Sets up stack and mark pointers for an XSUB, calling dSP and dMARK. This is
+usually handled automatically by C<xsubpp>. Declares the C<items> variable
+to indicate the number of items on the stack.
+
+=item dXSI32
+
+Sets up the C<ix> variable for an XSUB which has aliases. This is usually
+handled automatically by C<xsubpp>.
+
+=item do_binmode
+
+Switches filehandle to binmode. C<iotype> is what C<IoTYPE(io)> would
+contain.
+
+ do_binmode(fp, iotype, TRUE);
+
+=item ENTER
+
+Opening bracket on a callback. See C<LEAVE> and L<perlcall>.
+
+ ENTER;
+
+=item EXTEND
+
+Used to extend the argument stack for an XSUB's return values.
+
+ EXTEND( sp, int x )
+
+=item fbm_compile
+
+Analyses the string in order to make fast searches on it using fbm_instr() --
+the Boyer-Moore algorithm.
+
+ void fbm_compile(SV* sv, U32 flags)
+
+=item fbm_instr
+
+Returns the location of the SV in the string delimited by C<str> and
+C<strend>. It returns C<Nullch> if the string can't be found. The
+C<sv> does not have to be fbm_compiled, but the search will not be as
+fast then.
+
+ char* fbm_instr(char *str, char *strend, SV *sv, U32 flags)
+
+=item FREETMPS
+
+Closing bracket for temporaries on a callback. See C<SAVETMPS> and
+L<perlcall>.
+
+ FREETMPS;
+
+=item G_ARRAY
+
+Used to indicate array context. See C<GIMME_V>, C<GIMME> and L<perlcall>.
+
+=item G_DISCARD
+
+Indicates that arguments returned from a callback should be discarded. See
+L<perlcall>.
+
+=item G_EVAL
+
+Used to force a Perl C<eval> wrapper around a callback. See L<perlcall>.
+
+=item GIMME
+
+A backward-compatible version of C<GIMME_V> which can only return
+C<G_SCALAR> or C<G_ARRAY>; in a void context, it returns C<G_SCALAR>.
+
+=item GIMME_V
+
+The XSUB-writer's equivalent to Perl's C<wantarray>. Returns
+C<G_VOID>, C<G_SCALAR> or C<G_ARRAY> for void, scalar or array
+context, respectively.
+
+=item G_NOARGS
+
+Indicates that no arguments are being sent to a callback. See L<perlcall>.
+
+=item G_SCALAR
+
+Used to indicate scalar context. See C<GIMME_V>, C<GIMME>, and L<perlcall>.
+
+=item gv_fetchmeth
+
+Returns the glob with the given C<name> and a defined subroutine or
+C<NULL>. The glob lives in the given C<stash>, or in the stashes
+accessible via @ISA and @UNIVERSAL.
+
+The argument C<level> should be either 0 or -1. If C<level==0>, as a
+side-effect creates a glob with the given C<name> in the given
+C<stash> which in the case of success contains an alias for the
+subroutine, and sets up caching info for this glob. Similarly for all
+the searched stashes.
+
+This function grants C<"SUPER"> token as a postfix of the stash name.
+
+The GV returned from C<gv_fetchmeth> may be a method cache entry,
+which is not visible to Perl code. So when calling C<perl_call_sv>,
+you should not use the GV directly; instead, you should use the
+method's CV, which can be obtained from the GV with the C<GvCV> macro.
+
+ GV* gv_fetchmeth (HV* stash, char* name, STRLEN len, I32 level)
+
+=item gv_fetchmethod
+
+=item gv_fetchmethod_autoload
+
+Returns the glob which contains the subroutine to call to invoke the
+method on the C<stash>. In fact in the presense of autoloading this may
+be the glob for "AUTOLOAD". In this case the corresponding variable
+$AUTOLOAD is already setup.
+
+The third parameter of C<gv_fetchmethod_autoload> determines whether AUTOLOAD
+lookup is performed if the given method is not present: non-zero means
+yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. Calling
+C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload> with a
+non-zero C<autoload> parameter.
+
+These functions grant C<"SUPER"> token as a prefix of the method name.
+
+Note that if you want to keep the returned glob for a long time, you
+need to check for it being "AUTOLOAD", since at the later time the call
+may load a different subroutine due to $AUTOLOAD changing its value.
+Use the glob created via a side effect to do this.
+
+These functions have the same side-effects and as C<gv_fetchmeth> with
+C<level==0>. C<name> should be writable if contains C<':'> or C<'\''>.
+The warning against passing the GV returned by C<gv_fetchmeth> to
+C<perl_call_sv> apply equally to these functions.
+
+ GV* gv_fetchmethod (HV* stash, char* name)
+ GV* gv_fetchmethod_autoload (HV* stash, char* name, I32 autoload)
+
+=item G_VOID
+
+Used to indicate void context. See C<GIMME_V> and L<perlcall>.
+
+=item gv_stashpv
+
+Returns a pointer to the stash for a specified package. If C<create> is set
+then the package will be created if it does not already exist. If C<create>
+is not set and the package does not exist then NULL is returned.
+
+ HV* gv_stashpv (char* name, I32 create)
+
+=item gv_stashsv
+
+Returns a pointer to the stash for a specified package. See C<gv_stashpv>.
+
+ HV* gv_stashsv (SV* sv, I32 create)
+
+=item GvSV
+
+Return the SV from the GV.
+
+=item HEf_SVKEY
+
+This flag, used in the length slot of hash entries and magic
+structures, specifies the structure contains a C<SV*> pointer where a
+C<char*> pointer is to be expected. (For information only--not to be used).
+
+=item HeHASH
+
+Returns the computed hash stored in the hash entry.
+
+ U32 HeHASH(HE* he)
+
+=item HeKEY
+
+Returns the actual pointer stored in the key slot of the hash entry.
+The pointer may be either C<char*> or C<SV*>, depending on the value of
+C<HeKLEN()>. Can be assigned to. The C<HePV()> or C<HeSVKEY()> macros
+are usually preferable for finding the value of a key.
+
+ char* HeKEY(HE* he)
+
+=item HeKLEN
+
+If this is negative, and amounts to C<HEf_SVKEY>, it indicates the entry
+holds an C<SV*> key. Otherwise, holds the actual length of the key.
+Can be assigned to. The C<HePV()> macro is usually preferable for finding
+key lengths.
+
+ int HeKLEN(HE* he)
+
+=item HePV
+
+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
+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
+this document.
+
+ char* HePV(HE* he, STRLEN len)
+
+=item HeSVKEY
+
+Returns the key as an C<SV*>, or C<Nullsv> if the hash entry
+does not contain an C<SV*> key.
+
+ HeSVKEY(HE* he)
+
+=item HeSVKEY_force
+
+Returns the key as an C<SV*>. Will create and return a temporary
+mortal C<SV*> if the hash entry contains only a C<char*> key.
+
+ HeSVKEY_force(HE* he)
+
+=item HeSVKEY_set
+
+Sets the key to a given C<SV*>, taking care to set the appropriate flags
+to indicate the presence of an C<SV*> key, and returns the same C<SV*>.
+
+ HeSVKEY_set(HE* he, SV* sv)
+
+=item HeVAL
+
+Returns the value slot (type C<SV*>) stored in the hash entry.
+
+ HeVAL(HE* he)
+
+=item hv_clear
+
+Clears a hash, making it empty.
+
+ void hv_clear (HV* tb)
+
+=item hv_delayfree_ent
+
+Releases a hash entry, such as while iterating though the hash, but
+delays actual freeing of key and value until the end of the current
+statement (or thereabouts) with C<sv_2mortal>. See C<hv_iternext>
+and C<hv_free_ent>.
+
+ void hv_delayfree_ent (HV* hv, HE* entry)
+
+=item hv_delete
+
+Deletes a key/value pair in the hash. The value SV is removed from the hash
+and returned to the caller. The C<klen> is the length of the key. The
+C<flags> value will normally be zero; if set to G_DISCARD then NULL will be
+returned.
+
+ SV* hv_delete (HV* tb, char* key, U32 klen, I32 flags)
+
+=item hv_delete_ent
+
+Deletes a key/value pair in the hash. The value SV is removed from the hash
+and returned to the caller. The C<flags> value will normally be zero; if set
+to G_DISCARD then NULL will be returned. C<hash> can be a valid precomputed
+hash value, or 0 to ask for it to be computed.
+
+ SV* hv_delete_ent (HV* tb, SV* key, I32 flags, U32 hash)
+
+=item hv_exists
+
+Returns a boolean indicating whether the specified hash key exists. The
+C<klen> is the length of the key.
+
+ bool hv_exists (HV* tb, char* key, U32 klen)
+
+=item hv_exists_ent
+
+Returns a boolean indicating whether the specified hash key exists. C<hash>
+can be a valid precomputed hash value, or 0 to ask for it to be computed.
+
+ bool hv_exists_ent (HV* tb, SV* key, U32 hash)
+
+=item hv_fetch
+
+Returns the SV which corresponds to the specified key in the hash. The
+C<klen> is the length of the key. If C<lval> is set then the fetch will be
+part of a store. Check that the return value is non-null before
+dereferencing it to a C<SV*>.
+
+See L<Understanding the Magic of Tied Hashes and Arrays> for more
+information on how to use this function on tied hashes.
+
+ SV** hv_fetch (HV* tb, char* key, U32 klen, I32 lval)
+
+=item hv_fetch_ent
+
+Returns the hash entry which corresponds to the specified key in the hash.
+C<hash> must be a valid precomputed hash number for the given C<key>, or
+0 if you want the function to compute it. IF C<lval> is set then the
+fetch will be part of a store. Make sure the return value is non-null
+before accessing it. The return value when C<tb> is a tied hash
+is a pointer to a static location, so be sure to make a copy of the
+structure if you need to store it somewhere.
+
+See L<Understanding the Magic of Tied Hashes and Arrays> for more
+information on how to use this function on tied hashes.
+
+ HE* hv_fetch_ent (HV* tb, SV* key, I32 lval, U32 hash)
+
+=item hv_free_ent
+
+Releases a hash entry, such as while iterating though the hash. See
+C<hv_iternext> and C<hv_delayfree_ent>.
+
+ void hv_free_ent (HV* hv, HE* entry)
+
+=item hv_iterinit
+
+Prepares a starting point to traverse a hash table.
+
+ I32 hv_iterinit (HV* tb)
+
+Returns the number of keys in the hash (i.e. the same as C<HvKEYS(tb)>).
+The return value is currently only meaningful for hashes without tie
+magic.
+
+NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number
+of hash buckets that happen to be in use. If you still need that
+esoteric value, you can get it through the macro C<HvFILL(tb)>.
+
+=item hv_iterkey
+
+Returns the key from the current position of the hash iterator. See
+C<hv_iterinit>.
+
+ char* hv_iterkey (HE* entry, I32* retlen)
+
+=item hv_iterkeysv
+
+Returns the key as an C<SV*> from the current position of the hash
+iterator. The return value will always be a mortal copy of the
+key. Also see C<hv_iterinit>.
+
+ SV* hv_iterkeysv (HE* entry)
+
+=item hv_iternext
+
+Returns entries from a hash iterator. See C<hv_iterinit>.
+
+ HE* hv_iternext (HV* tb)
+
+=item hv_iternextsv
+
+Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
+operation.
+
+ SV* hv_iternextsv (HV* hv, char** key, I32* retlen)
+
+=item hv_iterval
+
+Returns the value from the current position of the hash iterator. See
+C<hv_iterkey>.
+
+ SV* hv_iterval (HV* tb, HE* entry)
+
+=item hv_magic
+
+Adds magic to a hash. See C<sv_magic>.
+
+ void hv_magic (HV* hv, GV* gv, int how)
+
+=item HvNAME
+
+Returns the package name of a stash. See C<SvSTASH>, C<CvSTASH>.
+
+ char* HvNAME (HV* stash)
+
+=item hv_store
+
+Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
+the length of the key. The C<hash> parameter is the precomputed hash
+value; if it is zero then Perl will compute it. The return value will be
+NULL if the operation failed or if the value did not need to be actually
+stored within the hash (as in the case of tied hashes). Otherwise it can
+be dereferenced to get the original C<SV*>. Note that the caller is
+responsible for suitably incrementing the reference count of C<val>
+before the call, and decrementing it if the function returned NULL.
+
+See L<Understanding the Magic of Tied Hashes and Arrays> for more
+information on how to use this function on tied hashes.
+
+ SV** hv_store (HV* tb, char* key, U32 klen, SV* val, U32 hash)
+
+=item hv_store_ent
+
+Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
+parameter is the precomputed hash value; if it is zero then Perl will
+compute it. The return value is the new hash entry so created. It will be
+NULL if the operation failed or if the value did not need to be actually
+stored within the hash (as in the case of tied hashes). Otherwise the
+contents of the return value can be accessed using the C<He???> macros
+described here. Note that the caller is responsible for suitably
+incrementing the reference count of C<val> before the call, and decrementing
+it if the function returned NULL.
+
+See L<Understanding the Magic of Tied Hashes and Arrays> for more
+information on how to use this function on tied hashes.
+
+ HE* hv_store_ent (HV* tb, SV* key, SV* val, U32 hash)
+
+=item hv_undef
+
+Undefines the hash.
+
+ void hv_undef (HV* tb)
+
+=item isALNUM
+
+Returns a boolean indicating whether the C C<char> is an ascii alphanumeric
+character or digit.
+
+ int isALNUM (char c)
+
+=item isALPHA
+
+Returns a boolean indicating whether the C C<char> is an ascii alphabetic
+character.
+
+ int isALPHA (char c)
+
+=item isDIGIT
+
+Returns a boolean indicating whether the C C<char> is an ascii digit.
+
+ int isDIGIT (char c)
+
+=item isLOWER
+
+Returns a boolean indicating whether the C C<char> is a lowercase character.
+
+ int isLOWER (char c)
+
+=item isSPACE
+
+Returns a boolean indicating whether the C C<char> is whitespace.
+
+ int isSPACE (char c)
+
+=item isUPPER
+
+Returns a boolean indicating whether the C C<char> is an uppercase character.
+
+ int isUPPER (char c)
+
+=item items
+
+Variable which is setup by C<xsubpp> to indicate the number of items on the
+stack. See L<perlxs/"Variable-length Parameter Lists">.
+
+=item ix
+
+Variable which is setup by C<xsubpp> to indicate which of an XSUB's aliases
+was used to invoke it. See L<perlxs/"The ALIAS: Keyword">.
+
+=item LEAVE
+
+Closing bracket on a callback. See C<ENTER> and L<perlcall>.
+
+ LEAVE;
+
+=item looks_like_number
+
+Test if an the content of an SV looks like a number (or is a number).
+
+ int looks_like_number(SV*)
+
+
+=item MARK
+
+Stack marker variable for the XSUB. See C<dMARK>.
+
+=item mg_clear
+
+Clear something magical that the SV represents. See C<sv_magic>.
+
+ int mg_clear (SV* sv)
+
+=item mg_copy
+
+Copies the magic from one SV to another. See C<sv_magic>.
+
+ int mg_copy (SV *, SV *, char *, STRLEN)
+
+=item mg_find
+
+Finds the magic pointer for type matching the SV. See C<sv_magic>.
+
+ MAGIC* mg_find (SV* sv, int type)
+
+=item mg_free
+
+Free any magic storage used by the SV. See C<sv_magic>.
+
+ int mg_free (SV* sv)
+
+=item mg_get
+
+Do magic after a value is retrieved from the SV. See C<sv_magic>.
+
+ int mg_get (SV* sv)
+
+=item mg_len
+
+Report on the SV's length. See C<sv_magic>.
+
+ U32 mg_len (SV* sv)
+
+=item mg_magical
+
+Turns on the magical status of an SV. See C<sv_magic>.
+
+ void mg_magical (SV* sv)
+
+=item mg_set
+
+Do magic after a value is assigned to the SV. See C<sv_magic>.
+
+ int mg_set (SV* sv)
+
+=item Move
+
+The XSUB-writer's interface to the C C<memmove> function. The C<s> is the
+source, C<d> is the destination, C<n> is the number of items, and C<t> is
+the type. Can do overlapping moves. See also C<Copy>.
+
+ void Move( s, d, n, t )
+
+=item PL_na
+
+A variable which may be used with C<SvPV> to tell Perl to calculate the
+string length.
+
+=item New
+
+The XSUB-writer's interface to the C C<malloc> function.
+
+ void* New( x, void *ptr, int size, type )
+
+=item newAV
+
+Creates a new AV. The reference count is set to 1.
+
+ AV* newAV (void)
+
+=item Newc
+
+The XSUB-writer's interface to the C C<malloc> function, with cast.
+
+ void* Newc( x, void *ptr, int size, type, cast )
+
+=item newCONSTSUB
+
+Creates a constant sub equivalent to Perl C<sub FOO () { 123 }>
+which is eligible for inlining at compile-time.
+
+ void newCONSTSUB(HV* stash, char* name, SV* sv)
+
+=item newHV
+
+Creates a new HV. The reference count is set to 1.
+
+ HV* newHV (void)
+
+=item newRV_inc
+
+Creates an RV wrapper for an SV. The reference count for the original SV is
+incremented.
+
+ SV* newRV_inc (SV* ref)
+
+For historical reasons, "newRV" is a synonym for "newRV_inc".
+
+=item newRV_noinc
+
+Creates an RV wrapper for an SV. The reference count for the original
+SV is B<not> incremented.
+
+ SV* newRV_noinc (SV* ref)
+
+=item NEWSV
+
+Creates a new SV. A non-zero C<len> parameter indicates the number of
+bytes of preallocated string space the SV should have. An extra byte
+for a tailing NUL is also reserved. (SvPOK is not set for the SV even
+if string space is allocated.) The reference count for the new SV is
+set to 1. C<id> is an integer id between 0 and 1299 (used to identify
+leaks).
+
+ SV* NEWSV (int id, STRLEN len)
+
+=item newSViv
+
+Creates a new SV and copies an integer into it. The reference count for the
+SV is set to 1.
+
+ SV* newSViv (IV i)
+
+=item newSVnv
+
+Creates a new SV and copies a double into it. The reference count for the
+SV is set to 1.
+
+ SV* newSVnv (NV i)
+
+=item newSVpv
+
+Creates a new SV and copies a string into it. The reference count for the
+SV is set to 1. If C<len> is zero then Perl will compute the length.
+
+ SV* newSVpv (char* s, STRLEN len)
+
+=item newSVpvf
+
+Creates a new SV an initialize it with the string formatted like
+C<sprintf>.
+
+ SV* newSVpvf(const char* pat, ...);
+
+=item newSVpvn
+
+Creates a new SV and copies a string into it. The reference count for the
+SV is set to 1. If C<len> is zero then Perl will create a zero length
+string.
+
+ SV* newSVpvn (char* s, STRLEN len)
+
+=item newSVrv
+
+Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
+it will be upgraded to one. If C<classname> is non-null then the new SV will
+be blessed in the specified package. The new SV is returned and its
+reference count is 1.
+
+ SV* newSVrv (SV* rv, char* classname)
+
+=item newSVsv
+
+Creates a new SV which is an exact duplicate of the original SV.
+
+ SV* newSVsv (SV* old)
+
+=item newXS
+
+Used by C<xsubpp> to hook up XSUBs as Perl subs.
+
+=item newXSproto
+
+Used by C<xsubpp> to hook up XSUBs as Perl subs. Adds Perl prototypes to
+the subs.
+
+=item Newz
+
+The XSUB-writer's interface to the C C<malloc> function. The allocated
+memory is zeroed with C<memzero>.
+
+ void* Newz( x, void *ptr, int size, type )
+
+=item Nullav
+
+Null AV pointer.
+
+=item Nullch
+
+Null character pointer.
+
+=item Nullcv
+
+Null CV pointer.
+
+=item Nullhv
+
+Null HV pointer.
+
+=item Nullsv
+
+Null SV pointer.
+
+=item ORIGMARK
+
+The original stack mark for the XSUB. See C<dORIGMARK>.
+
+=item perl_alloc
+
+Allocates a new Perl interpreter. See L<perlembed>.
+
+=item perl_call_argv
+
+Performs a callback to the specified Perl sub. See L<perlcall>.
+
+ I32 perl_call_argv (char* subname, I32 flags, char** argv)
+
+=item perl_call_method
+
+Performs a callback to the specified Perl method. The blessed object must
+be on the stack. See L<perlcall>.
+
+ I32 perl_call_method (char* methname, I32 flags)
+
+=item perl_call_pv
+
+Performs a callback to the specified Perl sub. See L<perlcall>.
+
+ I32 perl_call_pv (char* subname, I32 flags)
+
+=item perl_call_sv
+
+Performs a callback to the Perl sub whose name is in the SV. See
+L<perlcall>.
+
+ I32 perl_call_sv (SV* sv, I32 flags)
+
+=item perl_construct
+
+Initializes a new Perl interpreter. See L<perlembed>.
+
+=item perl_destruct
+
+Shuts down a Perl interpreter. See L<perlembed>.
+
+=item perl_eval_sv
+
+Tells Perl to C<eval> the string in the SV.
+
+ I32 perl_eval_sv (SV* sv, I32 flags)
+
+=item perl_eval_pv
+
+Tells Perl to C<eval> the given string and return an SV* result.
+
+ SV* perl_eval_pv (char* p, I32 croak_on_error)
+
+=item perl_free
+
+Releases a Perl interpreter. See L<perlembed>.
+
+=item perl_get_av
+
+Returns the AV of the specified Perl array. If C<create> is set and the
+Perl variable does not exist then it will be created. If C<create> is not
+set and the variable does not exist then NULL is returned.
+
+ AV* perl_get_av (char* name, I32 create)
+
+=item perl_get_cv
+
+Returns the CV of the specified Perl sub. If C<create> is set and the Perl
+variable does not exist then it will be created. If C<create> is not
+set and the variable does not exist then NULL is returned.
+
+ CV* perl_get_cv (char* name, I32 create)
+
+=item perl_get_hv
+
+Returns the HV of the specified Perl hash. If C<create> is set and the Perl
+variable does not exist then it will be created. If C<create> is not
+set and the variable does not exist then NULL is returned.
+
+ HV* perl_get_hv (char* name, I32 create)
+
+=item perl_get_sv
+
+Returns the SV of the specified Perl scalar. If C<create> is set and the
+Perl variable does not exist then it will be created. If C<create> is not
+set and the variable does not exist then NULL is returned.
+
+ SV* perl_get_sv (char* name, I32 create)
+
+=item perl_parse
+
+Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
+
+=item perl_require_pv
+
+Tells Perl to C<require> a module.
+
+ void perl_require_pv (char* pv)
+
+=item perl_run
+
+Tells a Perl interpreter to run. See L<perlembed>.
+
+=item POPi
+
+Pops an integer off the stack.
+
+ int POPi()
+
+=item POPl
+
+Pops a long off the stack.
+
+ long POPl()
+
+=item POPp
+
+Pops a string off the stack.
+
+ char* POPp()
+
+=item POPn
+
+Pops a double off the stack.
+
+ double POPn()
+
+=item POPs
+
+Pops an SV off the stack.
+
+ SV* POPs()
+
+=item PUSHMARK
+
+Opening bracket for arguments on a callback. See C<PUTBACK> and L<perlcall>.
+
+ PUSHMARK(p)
+
+=item PUSHi
+
+Push an integer onto the stack. The stack must have room for this element.
+Handles 'set' magic. See C<XPUSHi>.
+
+ void PUSHi(int d)
+
+=item PUSHn
+
+Push a double onto the stack. The stack must have room for this element.
+Handles 'set' magic. See C<XPUSHn>.
+
+ void PUSHn(double d)
+
+=item PUSHp
+
+Push a string onto the stack. The stack must have room for this element.
+The C<len> indicates the length of the string. Handles 'set' magic. See
+C<XPUSHp>.
+
+ void PUSHp(char *c, int len )
+
+=item PUSHs
+
+Push an SV onto the stack. The stack must have room for this element. Does
+not handle 'set' magic. See C<XPUSHs>.
+
+ void PUSHs(sv)
+
+=item PUSHu
+
+Push an unsigned integer onto the stack. The stack must have room for
+this element. See C<XPUSHu>.
+
+ void PUSHu(unsigned int d)
+
+
+=item PUTBACK
+
+Closing bracket for XSUB arguments. This is usually handled by C<xsubpp>.
+See C<PUSHMARK> and L<perlcall> for other uses.
+
+ PUTBACK;
+
+=item Renew
+
+The XSUB-writer's interface to the C C<realloc> function.
+
+ void* Renew( void *ptr, int size, type )
+
+=item Renewc
+
+The XSUB-writer's interface to the C C<realloc> function, with cast.
+
+ void* Renewc( void *ptr, int size, type, cast )
+
+=item RETVAL
+
+Variable which is setup by C<xsubpp> to hold the return value for an XSUB.
+This is always the proper type for the XSUB.
+See L<perlxs/"The RETVAL Variable">.
+
+=item safefree
+
+The XSUB-writer's interface to the C C<free> function.
+
+=item safemalloc
+
+The XSUB-writer's interface to the C C<malloc> function.
+
+=item saferealloc
+
+The XSUB-writer's interface to the C C<realloc> function.
+
+=item savepv
+
+Copy a string to a safe spot. This does not use an SV.
+
+ char* savepv (char* sv)
+
+=item savepvn
+
+Copy a string to a safe spot. The C<len> indicates number of bytes to
+copy. This does not use an SV.
+
+ char* savepvn (char* sv, I32 len)
+
+=item SAVETMPS
+
+Opening bracket for temporaries on a callback. See C<FREETMPS> and
+L<perlcall>.
+
+ SAVETMPS;
+
+=item SP
+
+Stack pointer. This is usually handled by C<xsubpp>. See C<dSP> and
+C<SPAGAIN>.
+
+=item SPAGAIN
+
+Refetch the stack pointer. Used after a callback. See L<perlcall>.
+
+ SPAGAIN;
+
+=item ST
+
+Used to access elements on the XSUB's stack.
+
+ SV* ST(int x)
+
+=item strEQ
+
+Test two strings to see if they are equal. Returns true or false.
+
+ int strEQ( char *s1, char *s2 )
+
+=item strGE
+
+Test two strings to see if the first, C<s1>, is greater than or equal to the
+second, C<s2>. Returns true or false.
+
+ int strGE( char *s1, char *s2 )
+
+=item strGT
+
+Test two strings to see if the first, C<s1>, is greater than the second,
+C<s2>. Returns true or false.
+
+ int strGT( char *s1, char *s2 )
+
+=item strLE
+
+Test two strings to see if the first, C<s1>, is less than or equal to the
+second, C<s2>. Returns true or false.
+
+ int strLE( char *s1, char *s2 )
+
+=item strLT
+
+Test two strings to see if the first, C<s1>, is less than the second,
+C<s2>. Returns true or false.
+
+ int strLT( char *s1, char *s2 )
+
+=item strNE
+
+Test two strings to see if they are different. Returns true or false.
+
+ int strNE( char *s1, char *s2 )
+
+=item strnEQ
+
+Test two strings to see if they are equal. The C<len> parameter indicates
+the number of bytes to compare. Returns true or false.
+
+ int strnEQ( char *s1, char *s2 )
+
+=item strnNE
+
+Test two strings to see if they are different. The C<len> parameter
+indicates the number of bytes to compare. Returns true or false.
+
+ int strnNE( char *s1, char *s2, int len )
+
+=item sv_2mortal
+
+Marks an SV as mortal. The SV will be destroyed when the current context
+ends.
+
+ SV* sv_2mortal (SV* sv)
+
+=item sv_bless
+
+Blesses an SV into a specified package. The SV must be an RV. The package
+must be designated by its stash (see C<gv_stashpv()>). The reference count
+of the SV is unaffected.
+
+ SV* sv_bless (SV* sv, HV* stash)
+
+=item sv_catpv
+
+Concatenates the string onto the end of the string which is in the SV.
+Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+
+ void sv_catpv (SV* sv, char* ptr)
+
+=item sv_catpv_mg
+
+Like C<sv_catpv>, but also handles 'set' magic.
+
+ void sv_catpvn (SV* sv, char* ptr)
+
+=item sv_catpvn
+
+Concatenates the string onto the end of the string which is in the SV. The
+C<len> indicates number of bytes to copy. Handles 'get' magic, but not
+'set' magic. See C<sv_catpvn_mg>.
+
+ void sv_catpvn (SV* sv, char* ptr, STRLEN len)
+
+=item sv_catpvn_mg
+
+Like C<sv_catpvn>, but also handles 'set' magic.
+
+ void sv_catpvn_mg (SV* sv, char* ptr, STRLEN len)
+
+=item sv_catpvf
+
+Processes its arguments like C<sprintf> and appends the formatted output
+to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
+typically be called after calling this function to handle 'set' magic.
+
+ void sv_catpvf (SV* sv, const char* pat, ...)
+
+=item sv_catpvf_mg
+
+Like C<sv_catpvf>, but also handles 'set' magic.
+
+ void sv_catpvf_mg (SV* sv, const char* pat, ...)
+
+=item sv_catsv
+
+Concatenates the string from SV C<ssv> onto the end of the string in SV
+C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
+
+ void sv_catsv (SV* dsv, SV* ssv)
+
+=item sv_catsv_mg
+
+Like C<sv_catsv>, but also handles 'set' magic.
+
+ void sv_catsv_mg (SV* dsv, SV* ssv)
+
+=item sv_chop
+
+Efficient removal of characters from the beginning of the string
+buffer. SvPOK(sv) must be true and the C<ptr> must be a pointer to
+somewhere inside the string buffer. The C<ptr> becomes the first
+character of the adjusted string.
+
+ void sv_chop(SV* sv, char *ptr)
+
+
+=item sv_cmp
+
+Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
+string in C<sv1> is less than, equal to, or greater than the string in
+C<sv2>.
+
+ I32 sv_cmp (SV* sv1, SV* sv2)
+
+=item SvCUR
+
+Returns the length of the string which is in the SV. See C<SvLEN>.
+
+ int SvCUR (SV* sv)
+
+=item SvCUR_set
+
+Set the length of the string which is in the SV. See C<SvCUR>.
+
+ void SvCUR_set (SV* sv, int val )
+
+=item sv_dec
+
+Auto-decrement of the value in the SV.
+
+ void sv_dec (SV* sv)
+
+=item sv_derived_from
+
+Returns a boolean indicating whether the SV is a subclass of the
+specified class.
+
+ int sv_derived_from(SV* sv, char* class)
+
+=item sv_derived_from
+
+Returns a boolean indicating whether the SV is derived from the specified
+class. This is the function that implements C<UNIVERSAL::isa>. It works
+for class names as well as for objects.
+
+ bool sv_derived_from _((SV* sv, char* name));
+
+=item SvEND
+
+Returns a pointer to the last character in the string which is in the SV.
+See C<SvCUR>. Access the character as
+
+ char* SvEND(sv)
+
+=item sv_eq
+
+Returns a boolean indicating whether the strings in the two SVs are
+identical.
+
+ I32 sv_eq (SV* sv1, SV* sv2)
+
+=item SvGETMAGIC
+
+Invokes C<mg_get> on an SV if it has 'get' magic. This macro evaluates
+its argument more than once.
+
+ void SvGETMAGIC( SV *sv )
+
+=item SvGROW
+
+Expands the character buffer in the SV so that it has room for the
+indicated number of bytes (remember to reserve space for an extra
+trailing NUL character). Calls C<sv_grow> to perform the expansion if
+necessary. Returns a pointer to the character buffer.
+
+ char* SvGROW( SV* sv, int len )
+
+=item sv_grow
+
+Expands the character buffer in the SV. This will use C<sv_unref> and will
+upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
+Use C<SvGROW>.
+
+=item sv_inc
+
+Auto-increment of the value in the SV.
+
+ void sv_inc (SV* sv)
+
+=item sv_insert
+
+Inserts a string at the specified offset/length within the SV.
+Similar to the Perl substr() function.
+
+ void sv_insert(SV *sv, STRLEN offset, STRLEN len,
+ char *str, STRLEN strlen)
+
+=item SvIOK
+
+Returns a boolean indicating whether the SV contains an integer.
+
+ int SvIOK (SV* SV)
+
+=item SvIOK_off
+
+Unsets the IV status of an SV.
+
+ void SvIOK_off (SV* sv)
+
+=item SvIOK_on
+
+Tells an SV that it is an integer.
+
+ void SvIOK_on (SV* sv)
+
+=item SvIOK_only
+
+Tells an SV that it is an integer and disables all other OK bits.
+
+ void SvIOK_only (SV* sv)
+
+=item SvIOKp
+
+Returns a boolean indicating whether the SV contains an integer. Checks the
+B<private> setting. Use C<SvIOK>.
+
+ int SvIOKp (SV* SV)
+
+=item sv_isa
+
+Returns a boolean indicating whether the SV is blessed into the specified
+class. This does not check for subtypes; use C<sv_derived_from> to verify
+an inheritance relationship.
+
+ int sv_isa (SV* sv, char* name)
+
+=item sv_isobject
+
+Returns a boolean indicating whether the SV is an RV pointing to a blessed
+object. If the SV is not an RV, or if the object is not blessed, then this
+will return false.
+
+ int sv_isobject (SV* sv)
+
+=item SvIV
+
+Returns the integer which is in the SV.
+
+ int SvIV (SV* sv)
+
+=item SvIVX
+
+Returns the integer which is stored in the SV.
+
+ int SvIVX (SV* sv)
+
+=item SvLEN
+
+Returns the size of the string buffer in the SV. See C<SvCUR>.
+
+ int SvLEN (SV* sv)
+
+=item sv_len
+
+Returns the length of the string in the SV. Use C<SvCUR>.
+
+ STRLEN sv_len (SV* sv)
+
+=item sv_magic
+
+Adds magic to an SV.
+
+ void sv_magic (SV* sv, SV* obj, int how, char* name, I32 namlen)
+
+=item sv_mortalcopy
+
+Creates a new SV which is a copy of the original SV. The new SV is marked
+as mortal.
+
+ SV* sv_mortalcopy (SV* oldsv)
+
+=item sv_newmortal
+
+Creates a new SV which is mortal. The reference count of the SV is set to 1.
+
+ SV* sv_newmortal (void)
+
+=item SvNIOK
+
+Returns a boolean indicating whether the SV contains a number, integer or
+double.
+
+ int SvNIOK (SV* SV)
+
+=item SvNIOK_off
+
+Unsets the NV/IV status of an SV.
+
+ void SvNIOK_off (SV* sv)
+
+=item SvNIOKp
+
+Returns a boolean indicating whether the SV contains a number, integer or
+double. Checks the B<private> setting. Use C<SvNIOK>.
+
+ int SvNIOKp (SV* SV)
+
+=item PL_sv_no
+
+This is the C<false> SV. See C<PL_sv_yes>. Always refer to this as C<&PL_sv_no>.
+
+=item SvNOK
+
+Returns a boolean indicating whether the SV contains a double.
+
+ int SvNOK (SV* SV)
+
+=item SvNOK_off
+
+Unsets the NV status of an SV.
+
+ void SvNOK_off (SV* sv)
+
+=item SvNOK_on
+
+Tells an SV that it is a double.
+
+ void SvNOK_on (SV* sv)
+
+=item SvNOK_only
+
+Tells an SV that it is a double and disables all other OK bits.
+
+ void SvNOK_only (SV* sv)
+
+=item SvNOKp
+
+Returns a boolean indicating whether the SV contains a double. Checks the
+B<private> setting. Use C<SvNOK>.
+
+ int SvNOKp (SV* SV)
+
+=item SvNV
+
+Returns the double which is stored in the SV.
+
+ double SvNV (SV* sv)
+
+=item SvNVX
+
+Returns the double which is stored in the SV.
+
+ double SvNVX (SV* sv)
+
+=item SvOK
+
+Returns a boolean indicating whether the value is an SV.
+
+ int SvOK (SV* sv)
+
+=item SvOOK
+
+Returns a boolean indicating whether the SvIVX is a valid offset value
+for the SvPVX. This hack is used internally to speed up removal of
+characters from the beginning of a SvPV. When SvOOK is true, then the
+start of the allocated string buffer is really (SvPVX - SvIVX).
+
+ int SvOOK(SV* sv)
+
+=item SvPOK
+
+Returns a boolean indicating whether the SV contains a character string.
+
+ int SvPOK (SV* SV)
+
+=item SvPOK_off
+
+Unsets the PV status of an SV.
+
+ void SvPOK_off (SV* sv)
+
+=item SvPOK_on
+
+Tells an SV that it is a string.
+
+ void SvPOK_on (SV* sv)
+
+=item SvPOK_only
+
+Tells an SV that it is a string and disables all other OK bits.
+
+ void SvPOK_only (SV* sv)
+
+=item SvPOKp
+
+Returns a boolean indicating whether the SV contains a character string.
+Checks the B<private> setting. Use C<SvPOK>.
+
+ int SvPOKp (SV* SV)
+
+=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.
+
+ char* SvPV (SV* sv, int len )
+
+=item SvPV_force
+
+Like <SvPV> but will force the SV into becoming a string (SvPOK). You
+want force if you are going to update the SvPVX directly.
+
+ char* SvPV_force(SV* sv, int len)
+
+
+=item SvPVX
+
+Returns a pointer to the string in the SV. The SV must contain a string.
+
+ char* SvPVX (SV* sv)
+
+=item SvREFCNT
+
+Returns the value of the object's reference count.
+
+ int SvREFCNT (SV* sv)
+
+=item SvREFCNT_dec
+
+Decrements the reference count of the given SV.
+
+ void SvREFCNT_dec (SV* sv)
+
+=item SvREFCNT_inc
+
+Increments the reference count of the given SV.
+
+ void SvREFCNT_inc (SV* sv)
+
+=item SvROK
+
+Tests if the SV is an RV.
+
+ int SvROK (SV* sv)
+
+=item SvROK_off
+
+Unsets the RV status of an SV.
+
+ void SvROK_off (SV* sv)
+
+=item SvROK_on
+
+Tells an SV that it is an RV.
+
+ void SvROK_on (SV* sv)
+
+=item SvRV
+
+Dereferences an RV to return the SV.
+
+ SV* SvRV (SV* sv)
+
+=item SvSETMAGIC
+
+Invokes C<mg_set> on an SV if it has 'set' magic. This macro evaluates
+its argument more than once.
+
+ void SvSETMAGIC( SV *sv )
+
+=item sv_setiv
+
+Copies an integer into the given SV. Does not handle 'set' magic.
+See C<sv_setiv_mg>.
+
+ void sv_setiv (SV* sv, IV num)
+
+=item sv_setiv_mg
+
+Like C<sv_setiv>, but also handles 'set' magic.
+
+ void sv_setiv_mg (SV* sv, IV num)
+
+=item sv_setnv
+
+Copies a double into the given SV. Does not handle 'set' magic.
+See C<sv_setnv_mg>.
+
+ void sv_setnv (SV* sv, double num)
+
+=item sv_setnv_mg
+
+Like C<sv_setnv>, but also handles 'set' magic.
+
+ void sv_setnv_mg (SV* sv, double num)
+
+=item sv_setpv
+
+Copies a string into an SV. The string must be null-terminated.
+Does not handle 'set' magic. See C<sv_setpv_mg>.
+
+ void sv_setpv (SV* sv, char* ptr)
+
+=item sv_setpv_mg
+
+Like C<sv_setpv>, but also handles 'set' magic.
+
+ void sv_setpv_mg (SV* sv, char* ptr)
+
+=item sv_setpviv
+
+Copies an integer into the given SV, also updating its string value.
+Does not handle 'set' magic. See C<sv_setpviv_mg>.
+
+ void sv_setpviv (SV* sv, IV num)
+
+=item sv_setpviv_mg
+
+Like C<sv_setpviv>, but also handles 'set' magic.
+
+ void sv_setpviv_mg (SV* sv, IV num)
+
+=item sv_setpvn
+
+Copies a string into an SV. The C<len> parameter indicates the number of
+bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
+
+ void sv_setpvn (SV* sv, char* ptr, STRLEN len)
+
+=item sv_setpvn_mg
+
+Like C<sv_setpvn>, but also handles 'set' magic.
+
+ void sv_setpvn_mg (SV* sv, char* ptr, STRLEN len)
+
+=item sv_setpvf
+
+Processes its arguments like C<sprintf> and sets an SV to the formatted
+output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
+
+ void sv_setpvf (SV* sv, const char* pat, ...)
+
+=item sv_setpvf_mg
+
+Like C<sv_setpvf>, but also handles 'set' magic.
+
+ void sv_setpvf_mg (SV* sv, const char* pat, ...)
+
+=item sv_setref_iv
+
+Copies an integer into a new SV, optionally blessing the SV. The C<rv>
+argument will be upgraded to an RV. That RV will be modified to point to
+the new SV. The C<classname> argument indicates the package for the
+blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+will be returned and will have a reference count of 1.
+
+ SV* sv_setref_iv (SV *rv, char *classname, IV iv)
+
+=item sv_setref_nv
+
+Copies a double into a new SV, optionally blessing the SV. The C<rv>
+argument will be upgraded to an RV. That RV will be modified to point to
+the new SV. The C<classname> argument indicates the package for the
+blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+will be returned and will have a reference count of 1.
+
+ SV* sv_setref_nv (SV *rv, char *classname, double nv)
+
+=item sv_setref_pv
+
+Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
+argument will be upgraded to an RV. That RV will be modified to point to
+the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
+into the SV. The C<classname> argument indicates the package for the
+blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+will be returned and will have a reference count of 1.
+
+ SV* sv_setref_pv (SV *rv, char *classname, void* pv)
+
+Do not use with integral Perl types such as HV, AV, SV, CV, because those
+objects will become corrupted by the pointer copy process.
+
+Note that C<sv_setref_pvn> copies the string while this copies the pointer.
+
+=item sv_setref_pvn
+
+Copies a string into a new SV, optionally blessing the SV. The length of the
+string must be specified with C<n>. The C<rv> argument will be upgraded to
+an RV. That RV will be modified to point to the new SV. The C<classname>
+argument indicates the package for the blessing. Set C<classname> to
+C<Nullch> to avoid the blessing. The new SV will be returned and will have
+a reference count of 1.
+
+ SV* sv_setref_pvn (SV *rv, char *classname, char* pv, I32 n)
+
+Note that C<sv_setref_pv> copies the pointer while this copies the string.
+
+=item SvSetSV
+
+Calls C<sv_setsv> if dsv is not the same as ssv. May evaluate arguments
+more than once.
+
+ void SvSetSV (SV* dsv, SV* ssv)
+
+=item SvSetSV_nosteal
+
+Calls a non-destructive version of C<sv_setsv> if dsv is not the same as ssv.
+May evaluate arguments more than once.
+
+ void SvSetSV_nosteal (SV* dsv, SV* ssv)
+
+=item sv_setsv
+
+Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
+The source SV may be destroyed if it is mortal. Does not handle 'set' magic.
+See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and C<sv_setsv_mg>.
+
+ void sv_setsv (SV* dsv, SV* ssv)
+
+=item sv_setsv_mg
+
+Like C<sv_setsv>, but also handles 'set' magic.
+
+ void sv_setsv_mg (SV* dsv, SV* ssv)
+
+=item sv_setuv
+
+Copies an unsigned integer into the given SV. Does not handle 'set' magic.
+See C<sv_setuv_mg>.
+
+ void sv_setuv (SV* sv, UV num)
+
+=item sv_setuv_mg
+
+Like C<sv_setuv>, but also handles 'set' magic.
+
+ void sv_setuv_mg (SV* sv, UV num)
+
+=item SvSTASH
+
+Returns the stash of the SV.
+
+ HV* SvSTASH (SV* sv)
+
+=item SvTAINT
+
+Taints an SV if tainting is enabled
+
+ void SvTAINT (SV* sv)
+
+=item SvTAINTED
+
+Checks to see if an SV is tainted. Returns TRUE if it is, FALSE if not.
+
+ int SvTAINTED (SV* sv)
+
+=item SvTAINTED_off
+
+Untaints an SV. Be I<very> careful with this routine, as it short-circuits
+some of Perl's fundamental security features. XS module authors should
+not use this function unless they fully understand all the implications
+of unconditionally untainting the value. Untainting should be done in
+the standard perl fashion, via a carefully crafted regexp, rather than
+directly untainting variables.
+
+ void SvTAINTED_off (SV* sv)
+
+=item SvTAINTED_on
+
+Marks an SV as tainted.
+
+ void SvTAINTED_on (SV* sv)
+
+=item SVt_IV
+
+Integer type flag for scalars. See C<svtype>.
+
+=item SVt_PV
+
+Pointer type flag for scalars. See C<svtype>.
+
+=item SVt_PVAV
+
+Type flag for arrays. See C<svtype>.
+
+=item SVt_PVCV
+
+Type flag for code refs. See C<svtype>.
+
+=item SVt_PVHV
+
+Type flag for hashes. See C<svtype>.
+
+=item SVt_PVMG
+
+Type flag for blessed scalars. See C<svtype>.
+
+=item SVt_NV
+
+Double type flag for scalars. See C<svtype>.
+
+=item SvTRUE
+
+Returns a boolean indicating whether Perl would evaluate the SV as true or
+false, defined or undefined. Does not handle 'get' magic.
+
+ int SvTRUE (SV* sv)
+
+=item SvTYPE
+
+Returns the type of the SV. See C<svtype>.
+
+ svtype SvTYPE (SV* sv)
+
+=item svtype
+
+An enum of flags for Perl types. These are found in the file B<sv.h> in the
+C<svtype> enum. Test these flags with the C<SvTYPE> macro.
+
+=item PL_sv_undef
+
+This is the C<undef> SV. Always refer to this as C<&PL_sv_undef>.
+
+=item sv_unref
+
+Unsets the RV status of the SV, and decrements the reference count of
+whatever was being referenced by the RV. This can almost be thought of
+as a reversal of C<newSVrv>. See C<SvROK_off>.
+
+ void sv_unref (SV* sv)
+
+=item SvUPGRADE
+
+Used to upgrade an SV to a more complex form. Uses C<sv_upgrade> to perform
+the upgrade if necessary. See C<svtype>.
+
+ bool SvUPGRADE (SV* sv, svtype mt)
+
+=item sv_upgrade
+
+Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See C<svtype>.
+
+=item sv_usepvn
+
+Tells an SV to use C<ptr> to find its string value. Normally the string is
+stored inside the SV but sv_usepvn allows the SV to use an outside string.
+The C<ptr> should point to memory that was allocated by C<malloc>. The
+string length, C<len>, must be supplied. This function will realloc the
+memory pointed to by C<ptr>, so that pointer should not be freed or used by
+the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
+See C<sv_usepvn_mg>.
+
+ void sv_usepvn (SV* sv, char* ptr, STRLEN len)
+
+=item sv_usepvn_mg
+
+Like C<sv_usepvn>, but also handles 'set' magic.
+
+ void sv_usepvn_mg (SV* sv, char* ptr, STRLEN len)
+
+=item sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
+
+Processes its arguments like C<vsprintf> and appends the formatted output
+to an SV. Uses an array of SVs if the C style variable argument list is
+missing (NULL). Indicates if locale information has been used for formatting.
+
+ void sv_catpvfn _((SV* sv, const char* pat, STRLEN patlen,
+ va_list *args, SV **svargs, I32 svmax,
+ bool *used_locale));
+
+=item sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
+
+Works like C<vcatpvfn> but copies the text into the SV instead of
+appending it.
+
+ void sv_setpvfn _((SV* sv, const char* pat, STRLEN patlen,
+ va_list *args, SV **svargs, I32 svmax,
+ bool *used_locale));
+
+=item SvUV
+
+Returns the unsigned integer which is in the SV.
+
+ UV SvUV(SV* sv)
+
+=item SvUVX
+
+Returns the unsigned integer which is stored in the SV.
+
+ UV SvUVX(SV* sv)
+
+=item PL_sv_yes
+
+This is the C<true> SV. See C<PL_sv_no>. Always refer to this as C<&PL_sv_yes>.
+
+=item THIS
+
+Variable which is setup by C<xsubpp> to designate the object in a C++ XSUB.
+This is always the proper type for the C++ object. See C<CLASS> and
+L<perlxs/"Using XS With C++">.
+
+=item toLOWER
+
+Converts the specified character to lowercase.
+
+ int toLOWER (char c)
+
+=item toUPPER
+
+Converts the specified character to uppercase.
+
+ int toUPPER (char c)
+
+=item warn
+
+This is the XSUB-writer's interface to Perl's C<warn> function. Use this
+function the same way you use the C C<printf> function. See C<croak()>.
+
+=item XPUSHi
+
+Push an integer onto the stack, extending the stack if necessary. Handles
+'set' magic. See C<PUSHi>.
+
+ XPUSHi(int d)
+
+=item XPUSHn
+
+Push a double onto the stack, extending the stack if necessary. Handles 'set'
+magic. See C<PUSHn>.
+
+ XPUSHn(double d)
+
+=item XPUSHp
+
+Push a string onto the stack, extending the stack if necessary. The C<len>
+indicates the length of the string. Handles 'set' magic. See C<PUSHp>.
+
+ XPUSHp(char *c, int len)
+
+=item XPUSHs
+
+Push an SV onto the stack, extending the stack if necessary. Does not
+handle 'set' magic. See C<PUSHs>.
+
+ XPUSHs(sv)
+
+=item XPUSHu
+
+Push an unsigned integer onto the stack, extending the stack if
+necessary. See C<PUSHu>.
+
+=item XS
+
+Macro to declare an XSUB and its C parameter list. This is handled by
+C<xsubpp>.
+
+=item XSRETURN
+
+Return from XSUB, indicating number of items on the stack. This is usually
+handled by C<xsubpp>.
+
+ XSRETURN(int x)
+
+=item XSRETURN_EMPTY
+
+Return an empty list from an XSUB immediately.
+
+ XSRETURN_EMPTY;
+
+=item XSRETURN_IV
+
+Return an integer from an XSUB immediately. Uses C<XST_mIV>.
+
+ XSRETURN_IV(IV v)
+
+=item XSRETURN_NO
+
+Return C<&PL_sv_no> from an XSUB immediately. Uses C<XST_mNO>.
+
+ XSRETURN_NO;
+
+=item XSRETURN_NV
+
+Return an double from an XSUB immediately. Uses C<XST_mNV>.
+
+ XSRETURN_NV(NV v)
+
+=item XSRETURN_PV
+
+Return a copy of a string from an XSUB immediately. Uses C<XST_mPV>.
+
+ XSRETURN_PV(char *v)
+
+=item XSRETURN_UNDEF
+
+Return C<&PL_sv_undef> from an XSUB immediately. Uses C<XST_mUNDEF>.
+
+ XSRETURN_UNDEF;
+
+=item XSRETURN_YES
+
+Return C<&PL_sv_yes> from an XSUB immediately. Uses C<XST_mYES>.
+
+ XSRETURN_YES;
+
+=item XST_mIV
+
+Place an integer into the specified position C<i> on the stack. The value is
+stored in a new mortal SV.
+
+ XST_mIV( int i, IV v )
+
+=item XST_mNV
+
+Place a double into the specified position C<i> on the stack. The value is
+stored in a new mortal SV.
+
+ XST_mNV( int i, NV v )
+
+=item XST_mNO
+
+Place C<&PL_sv_no> into the specified position C<i> on the stack.
+
+ XST_mNO( int i )
+
+=item XST_mPV
+
+Place a copy of a string into the specified position C<i> on the stack. The
+value is stored in a new mortal SV.
+
+ XST_mPV( int i, char *v )
+
+=item XST_mUNDEF
+
+Place C<&PL_sv_undef> into the specified position C<i> on the stack.
+
+ XST_mUNDEF( int i )
+
+=item XST_mYES
+
+Place C<&PL_sv_yes> into the specified position C<i> on the stack.
+
+ XST_mYES( int i )
+
+=item XS_VERSION
+
+The version identifier for an XS module. This is usually handled
+automatically by C<ExtUtils::MakeMaker>. See C<XS_VERSION_BOOTCHECK>.
+
+=item XS_VERSION_BOOTCHECK
+
+Macro to verify that a PM module's $VERSION variable matches the XS module's
+C<XS_VERSION> variable. This is usually handled automatically by
+C<xsubpp>. See L<perlxs/"The VERSIONCHECK: Keyword">.
+
+=item Zero
+
+The XSUB-writer's interface to the C C<memzero> function. The C<d> is the
+destination, C<n> is the number of items, and C<t> is the type.
+
+ void Zero( d, n, t )
+
+=back
+
+=head1 AUTHORS
+
+Until May 1997, this document was maintained by Jeff Okamoto
+<okamoto@corp.hp.com>. It is now maintained as part of Perl itself.
+
+With lots of help and suggestions from Dean Roehrich, Malcolm Beattie,
+Andreas Koenig, Paul Hudson, Ilya Zakharevich, Paul Marquess, Neil
+Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer,
+Stephen McCamant, and Gurusamy Sarathy.
+
+API Listing originally by Dean Roehrich <roehrich@cray.com>.
diff --git a/contrib/perl5/pod/perlhist.pod b/contrib/perl5/pod/perlhist.pod
new file mode 100644
index 000000000000..9ed8b6f52e68
--- /dev/null
+++ b/contrib/perl5/pod/perlhist.pod
@@ -0,0 +1,518 @@
+=pod
+
+=head1 NAME
+
+perlhist - the Perl history records
+
+=for RCS
+#
+# $Id: perlhist.pod,v 1.48 1998/08/03 08:50:12 jhi Exp $
+#
+=end RCS
+
+=head1 DESCRIPTION
+
+This document aims to record the Perl source code releases.
+
+=head1 INTRODUCTION
+
+Perl history in brief, by Larry Wall:
+
+ Perl 0 introduced Perl to my officemates.
+ Perl 1 introduced Perl to the world, and changed /\(...\|...\)/ to
+ /(...|...)/. \(Dan Faigin still hasn't forgiven me. :-\)
+ Perl 2 introduced Henry Spencer's regular expression package.
+ Perl 3 introduced the ability to handle binary data (embedded nulls).
+ Perl 4 introduced the first Camel book. Really. We mostly just
+ switched version numbers so the book could refer to 4.000.
+ Perl 5 introduced everything else, including the ability to
+ introduce everything else.
+
+=head1 THE KEEPERS OF THE PUMPKIN
+
+Larry Wall, Andy Dougherty, Tom Christiansen, Charles Bailey, Nick
+Ing-Simmons, Chip Salzenberg, Tim Bunce, Malcolm Beattie, Gurusamy
+Sarathy, Graham Barr.
+
+=head2 PUMPKIN?
+
+[from Porting/pumpkin.pod in the Perl source code distribution]
+
+Chip Salzenberg gets credit for that, with a nod to his cow orker,
+David Croy. We had passed around various names (baton, token, hot
+potato) but none caught on. Then, Chip asked:
+
+[begin quote]
+
+ Who has the patch pumpkin?
+
+To explain: David Croy once told me once that at a previous job,
+there was one tape drive and multiple systems that used it for backups.
+But instead of some high-tech exclusion software, they used a low-tech
+method to prevent multiple simultaneous backups: a stuffed pumpkin.
+No one was allowed to make backups unless they had the "backup pumpkin".
+
+[end quote]
+
+The name has stuck. The holder of the pumpkin is sometimes called
+the pumpking (keeping the source afloat?) or the pumpkineer (pulling
+the strings?).
+
+=head1 THE RECORDS
+
+ Pump- Release Date Notes
+ king (by no means
+ comprehensive,
+ see Changes*
+ for details)
+ ===========================================================================
+
+ Larry 0 Classified. Don't ask.
+
+ Larry 1.000 1987-Dec-18
+
+ 1.001..10 1988-Jan-30
+ 1.011..14 1988-Feb-02
+
+ Larry 2.000 1988-Jun-05
+
+ 2.001 1988-Jun-28
+
+ Larry 3.000 1989-Oct-18
+
+ 3.001 1989-Oct-26
+ 3.002..4 1989-Nov-11
+ 3.005 1989-Nov-18
+ 3.006..8 1989-Dec-22
+ 3.009..13 1990-Mar-02
+ 3.014 1990-Mar-13
+ 3.015 1990-Mar-14
+ 3.016..18 1990-Mar-28
+ 3.019..27 1990-Aug-10 User subs.
+ 3.028 1990-Aug-14
+ 3.029..36 1990-Oct-17
+ 3.037 1990-Oct-20
+ 3.040 1990-Nov-10
+ 3.041 1990-Nov-13
+ 3.042..43 1990-Jan-??
+ 3.044 1991-Jan-12
+
+ Larry 4.000 1991-Mar-21
+
+ 4.001..3 1991-Apr-12
+ 4.004..9 1991-Jun-07
+ 4.010 1991-Jun-10
+ 4.011..18 1991-Nov-05
+ 4.019 1991-Nov-11 Stable.
+ 4.020..33 1992-Jun-08
+ 4.034 1992-Jun-11
+ 4.035 1992-Jun-23
+ Larry 4.036 1993-Feb-05 Very stable.
+
+ 5.000alpha1 1993-Jul-31
+ 5.000alpha2 1993-Aug-16
+ 5.000alpha3 1993-Oct-10
+ 5.000alpha4 1993-???-??
+ 5.000alpha5 1993-???-??
+ 5.000alpha6 1994-Mar-18
+ 5.003alpha7 1994-Mar-25
+ Andy 5.000alpha8 1994-Apr-04
+ Larry 5.000alpha9 1994-May-05 ext appears.
+ 5.000alpha10 1994-???-??
+ 5.000alpha11 1994-???-??
+ Andy 5.000a11a 1994-Jul-07 To fit 14.
+ 5.000a11b 1994-Jul-14
+ 5.000a11c 1994-Jul-19
+ 5.000a11d 1994-Jul-22
+ Larry 5.000alpha12 1994-???-??
+ Andy 5.000a12a 1994-Aug-08
+ 5.000a12b 1994-Aug-15
+ 5.000a12c 1994-Aug-22
+ 5.000a12d 1994-Aug-22
+ 5.000a12e 1994-Aug-22
+ 5.000a12f 1994-Aug-24
+ 5.000a12g 1994-Aug-24
+ 5.000a12h 1994-Aug-24
+ Larry 5.000beta1 1994-???-??
+ Andy 5.000b1a 1994-???-??
+ Larry 5.000beta2 1994-Sep-14 Core slushified.
+ Andy 5.000b2a 1994-Sep-14
+ 5.000b2b 1994-Sep-17
+ 5.000b2c 1994-Sep-17
+ Larry 5.000beta3 1994-Sep-??
+ Andy 5.000b3a 1994-Sep-18
+ 5.000b3b 1994-Sep-22
+ 5.000b3c 1994-Sep-23
+ 5.000b3d 1994-Sep-27
+ 5.000b3e 1994-Sep-28
+ 5.000b3f 1994-Sep-30
+ 5.000b3g 1994-Oct-04
+ Andy 5.000b3h 1994-Oct-07
+
+ Larry 5.000 1994-Oct-18
+
+ Andy 5.000a 1994-Dec-19
+ 5.000b 1995-Jan-18
+ 5.000c 1995-Jan-18
+ 5.000d 1995-Jan-18
+ 5.000e 1995-Jan-18
+ 5.000f 1995-Jan-18
+ 5.000g 1995-Jan-18
+ 5.000h 1995-Jan-18
+ 5.000i 1995-Jan-26
+ 5.000j 1995-Feb-07
+ 5.000k 1995-Feb-11
+ 5.000l 1995-Feb-21
+ 5.000m 1995-???-??
+ 5.000n 1995-Mar-07
+
+ Larry 5.001 1995-Mar-13
+
+ Andy 5.001a 1995-Mar-15
+ 5.001b 1995-Mar-31
+ 5.001c 1995-Apr-07
+ 5.001d 1995-Apr-14
+ 5.001e 1995-Apr-18 Stable.
+ 5.001f 1995-May-31
+ 5.001g 1995-May-25
+ 5.001h 1995-May-25
+ 5.001i 1995-May-30
+ 5.001j 1995-Jun-05
+ 5.001k 1995-Jun-06
+ 5.001l 1995-Jun-06 Stable.
+ 5.001m 1995-Jul-02 Very stable.
+ 5.001n 1995-Oct-31 Very unstable.
+ 5.002beta1 1995-Nov-21
+ 5.002b1a 1995-Nov-??
+ 5.002b1b 1995-Dec-04
+ 5.002b1c 1995-Dec-04
+ 5.002b1d 1995-Dec-04
+ 5.002b1e 1995-Dec-08
+ 5.002b1f 1995-Dec-08
+ Tom 5.002b1g 1995-Dec-21 Doc release.
+ Andy 5.002b1h 1996-Jan-05
+ 5.002b2 1996-Jan-14
+ Larry 5.002b3 1996-Feb-02
+ Andy 5.002gamma 1996-Feb-11
+ Larry 5.002delta 1996-Feb-27
+
+ Larry 5.002 1996-Feb-29 Prototypes.
+
+ Charles 5.002_01 1996-Mar-25
+
+ 5.003 1996-Jun-25 Security release.
+
+ 5.003_01 1996-Jul-31
+ Nick 5.003_02 1996-Aug-10
+ Andy 5.003_03 1996-Aug-28
+ 5.003_04 1996-Sep-02
+ 5.003_05 1996-Sep-12
+ 5.003_06 1996-Oct-07
+ 5.003_07 1996-Oct-10
+ Chip 5.003_08 1996-Nov-19
+ 5.003_09 1996-Nov-26
+ 5.003_10 1996-Nov-29
+ 5.003_11 1996-Dec-06
+ 5.003_12 1996-Dec-19
+ 5.003_13 1996-Dec-20
+ 5.003_14 1996-Dec-23
+ 5.003_15 1996-Dec-23
+ 5.003_16 1996-Dec-24
+ 5.003_17 1996-Dec-27
+ 5.003_18 1996-Dec-31
+ 5.003_19 1997-Jan-04
+ 5.003_20 1997-Jan-07
+ 5.003_21 1997-Jan-15
+ 5.003_22 1997-Jan-16
+ 5.003_23 1997-Jan-25
+ 5.003_24 1997-Jan-29
+ 5.003_25 1997-Feb-04
+ 5.003_26 1997-Feb-10
+ 5.003_27 1997-Feb-18
+ 5.003_28 1997-Feb-21
+ 5.003_90 1997-Feb-25 Ramping up to the 5.004 release.
+ 5.003_91 1997-Mar-01
+ 5.003_92 1997-Mar-06
+ 5.003_93 1997-Mar-10
+ 5.003_94 1997-Mar-22
+ 5.003_95 1997-Mar-25
+ 5.003_96 1997-Apr-01
+ 5.003_97 1997-Apr-03 Fairly widely used.
+ 5.003_97a 1997-Apr-05
+ 5.003_97b 1997-Apr-08
+ 5.003_97c 1997-Apr-10
+ 5.003_97d 1997-Apr-13
+ 5.003_97e 1997-Apr-15
+ 5.003_97f 1997-Apr-17
+ 5.003_97g 1997-Apr-18
+ 5.003_97h 1997-Apr-24
+ 5.003_97i 1997-Apr-25
+ 5.003_97j 1997-Apr-28
+ 5.003_98 1997-Apr-30
+ 5.003_99 1997-May-01
+ 5.003_99a 1997-May-09
+ p54rc1 1997-May-12 Release Candidates.
+ p54rc2 1997-May-14
+
+ Chip 5.004 1997-May-15 A major maintenance release.
+
+ Tim 5.004_01 1997-Jun-13 The 5.004 maintenance track.
+ 5.004_02 1997-Aug-07
+ 5.004_03 1997-Sep-05
+ 5.004_04 1997-Oct-15
+ 5.004m5t1 1998-Mar-04 Maintenance Trials (for 5.004_05).
+ 5.004_04-m2 1997-May-01
+ 5.004_04-m3 1998-May-15
+ 5.004_04-m4 1998-May-19
+ 5.004_04-MT5 1998-Jul-21
+
+ Malcolm 5.004_50 1997-Sep-09 The 5.005 development track.
+ 5.004_51 1997-Oct-02
+ 5.004_52 1997-Oct-15
+ 5.004_53 1997-Oct-16
+ 5.004_54 1997-Nov-14
+ 5.004_55 1997-Nov-25
+ 5.004_56 1997-Dec-18
+ 5.004_57 1998-Feb-03
+ 5.004_58 1998-Feb-06
+ 5.004_59 1998-Feb-13
+ 5.004_60 1998-Feb-20
+ 5.004_61 1998-Feb-27
+ 5.004_62 1998-Mar-06
+ 5.004_63 1998-Mar-17
+ 5.004_64 1998-Apr-03
+ 5.004_65 1998-May-15
+ 5.004_66 1998-May-29
+ Sarathy 5.004_67 1998-Jun-15
+ 5.004_68 1998-Jun-23
+ 5.004_69 1998-Jun-29
+ 5.004_70 1998-Jul-06
+ 5.004_71 1998-Jul-09
+ 5.004_72 1998-Jul-12
+ 5.004_73 1998-Jul-13
+ 5.004_74 1998-Jul-14 5.005 beta candidate.
+ 5.004_75 1998-Jul-15 5.005 beta1.
+ 5.004_76 1998-Jul-21 5.005 beta2.
+ 5.005 1998-Jul-22 Oneperl.
+
+ Sarathy 5.005_01 1998-Jul-27 The 5.005 maintenance track.
+ 5.005_02-T1 1998-Aug-02
+ 5.005_02-T2 1998-Aug-05
+ 5.005_02 1998-Aug-08
+ Graham 5.005_03 1998-
+
+ Sarathy 5.005_50 1998-Jul-26 The 5.006 development track.
+
+=head2 SELECTED RELEASE SIZES
+
+For example the notation "core: 212 29" in the release 1.000 means that
+it had in the core 212 kilobytes, in 29 files. The "core".."doc" are
+explained below.
+
+ release core lib ext t doc
+ ======================================================================
+
+ 1.000 212 29 - - - - 38 51 62 3
+ 1.014 219 29 - - - - 39 52 68 4
+ 2.000 309 31 2 3 - - 55 57 92 4
+ 2.001 312 31 2 3 - - 55 57 94 4
+ 3.000 508 36 24 11 - - 79 73 156 5
+ 3.044 645 37 61 20 - - 90 74 190 6
+ 4.000 635 37 59 20 - - 91 75 198 4
+ 4.019 680 37 85 29 - - 98 76 199 4
+ 4.036 709 37 89 30 - - 98 76 208 5
+ 5.000alpha2 785 50 114 32 - - 112 86 209 5
+ 5.000alpha3 801 50 117 33 - - 121 87 209 5
+ 5.000alpha9 1022 56 149 43 116 29 125 90 217 6
+ 5.000a12h 978 49 140 49 205 46 152 97 228 9
+ 5.000b3h 1035 53 232 70 216 38 162 94 218 21
+ 5.000 1038 53 250 76 216 38 154 92 536 62
+ 5.001m 1071 54 388 82 240 38 159 95 544 29
+ 5.002 1121 54 661 101 287 43 155 94 847 35
+ 5.003 1129 54 680 102 291 43 166 100 853 35
+ 5.003_07 1231 60 748 106 396 53 213 137 976 39
+ 5.004 1351 60 1230 136 408 51 355 161 1587 55
+ 5.004_01 1356 60 1258 138 410 51 358 161 1587 55
+ 5.004_04 1375 60 1294 139 413 51 394 162 1629 55
+ 5.004_51 1401 61 1260 140 413 53 358 162 1594 56
+ 5.004_53 1422 62 1295 141 438 70 394 162 1637 56
+ 5.004_56 1501 66 1301 140 447 74 408 165 1648 57
+ 5.004_59 1555 72 1317 142 448 74 424 171 1678 58
+ 5.004_62 1602 77 1327 144 629 92 428 173 1674 58
+ 5.004_65 1626 77 1358 146 615 92 446 179 1698 60
+ 5.004_68 1856 74 1382 152 619 92 463 187 1784 60
+ 5.004_70 1863 75 1456 154 675 92 494 194 1809 60
+ 5.004_73 1874 76 1467 152 762 102 506 196 1883 61
+ 5.004_75 1877 76 1467 152 770 103 508 196 1896 62
+ 5.005 1896 76 1469 152 795 103 509 197 1945 63
+
+The "core"..."doc" mean the following files from the Perl source code
+distribution. The glob notation ** means recursively, (.) means
+regular files.
+
+ core *.[hcy]
+ lib lib/**/*.p[ml]
+ ext ext/**/*.{[hcyt],xs,pm}
+ t t/**/*(.)
+ doc {README*,INSTALL,*[_.]man{,.?},pod/**/*.pod}
+
+Here are some statistics for the other subdirectories and one file in
+the Perl source distribution for somewhat more selected releases.
+
+ ======================================================================
+ Legend: kB #
+
+ 1.014 2.001 3.044 4.000 4.019 4.036
+
+ atarist - - - - - - - - - - 113 31
+ Configure 31 1 37 1 62 1 73 1 83 1 86 1
+ eg - - 34 28 47 39 47 39 47 39 47 39
+ emacs - - - - - - 67 4 67 4 67 4
+ h2pl - - - - 12 12 12 12 12 12 12 12
+ hints - - - - - - - - 5 42 11 56
+ msdos - - - - 41 13 57 15 58 15 60 15
+ os2 - - - - 63 22 81 29 81 29 113 31
+ usub - - - - 21 16 25 7 43 8 43 8
+ x2p 103 17 104 17 137 17 147 18 152 19 154 19
+
+ ======================================================================
+
+ 5.000a2 5.000a12h 5.000b3h 5.000 5.001m 5.002 5.003
+
+ atarist 113 31 113 31 - - - - - - - - - -
+ bench - - 0 1 - - - - - - - - - -
+ Bugs 2 5 26 1 - - - - - - - - - -
+ dlperl 40 5 - - - - - - - - - - - -
+ do 127 71 - - - - - - - - - - - -
+ Configure - - 153 1 159 1 160 1 180 1 201 1 201 1
+ Doc - - 26 1 75 7 11 1 11 1 - - - -
+ eg 79 58 53 44 51 43 54 44 54 44 54 44 54 44
+ emacs 67 4 104 6 104 6 104 1 104 6 108 1 108 1
+ h2pl 12 12 12 12 12 12 12 12 12 12 12 12 12 12
+ hints 11 56 12 46 18 48 18 48 44 56 73 59 77 60
+ msdos 60 15 60 15 - - - - - - - - - -
+ os2 113 31 113 31 - - - - - - 84 17 56 10
+ U - - 62 8 112 42 - - - - - - - -
+ usub 43 8 - - - - - - - - - - - -
+ utils - - - - - - - - - - 87 7 88 7
+ vms - - 80 7 123 9 184 15 304 20 500 24 475 26
+ x2p 171 22 171 21 162 20 162 20 279 20 280 20 280 20
+
+ ======================================================================
+
+ 5.003_07 5.004 5.004_04 5.004_62 5.004_65 5.004_68
+
+ beos - - - - - - - - 1 1 1 1
+ Configure 217 1 225 1 225 1 240 1 248 1 256 1
+ cygwin32 - - 23 5 23 5 23 5 24 5 24 5
+ djgpp - - - - - - 14 5 14 5 14 5
+ eg 54 44 81 62 81 62 81 62 81 62 81 62
+ emacs 143 1 194 1 204 1 212 2 212 2 212 2
+ h2pl 12 12 12 12 12 12 12 12 12 12 12 12
+ hints 90 62 129 69 132 71 144 72 151 74 155 74
+ os2 117 42 121 42 127 42 127 44 129 44 129 44
+ plan9 79 15 82 15 82 15 82 15 82 15 82 15
+ Porting 51 1 94 2 109 4 203 6 234 8 241 9
+ qnx - - 1 2 1 2 1 2 1 2 1 2
+ utils 97 7 112 8 118 8 124 8 156 9 159 9
+ vms 505 27 518 34 524 34 538 34 569 34 569 34
+ win32 - - 285 33 378 36 470 39 493 39 575 41
+ x2p 280 19 281 19 281 19 281 19 282 19 281 19
+
+ ======================================================================
+
+ 5.004_70 5.004_73 5.004_75 5.005
+
+ beos 1 1 1 1 1 1 1 1
+ Configure 256 1 256 1 264 1 264 1
+ cygwin32 24 5 24 5 24 5 24 5
+ djgpp 14 5 14 5 14 5 14 5
+ eg 86 65 86 65 86 65 86 65
+ emacs 262 2 262 2 262 2 262 2
+ h2pl 12 12 12 12 12 12 12 12
+ hints 157 74 157 74 159 74 160 74
+ mpeix - - - - 5 3 5 3
+ os2 129 44 139 44 142 44 143 44
+ plan9 82 15 82 15 82 15 82 15
+ Porting 241 9 253 9 259 10 264 12
+ qnx 1 2 1 2 1 2 1 2
+ utils 160 9 160 9 160 9 160 9
+ vms 570 34 572 34 573 34 575 34
+ win32 577 41 585 41 585 41 587 41
+ x2p 281 19 281 19 281 19 281 19
+
+=head2 SELECTED PATCH SIZES
+
+The "diff lines kb" means that for example the patch 5.003_08, to be
+applied on top of the 5.003_07 (or whatever was before the 5.003_08)
+added lines for 110 kilobytes, it removed lines for 19 kilobytes, and
+changed lines for 424 kilobytes. Just the lines themselves are
+counted, not their context. The "+ - !" become from the diff(1)s
+context diff output format.
+
+ Pump- Release Date diff lines kB
+ king + - !
+ ===========================================================================
+
+ Chip 5.003_08 1996-Nov-19 110 19 424
+ 5.003_09 1996-Nov-26 38 9 248
+ 5.003_10 1996-Nov-29 29 2 27
+ 5.003_11 1996-Dec-06 73 12 165
+ 5.003_12 1996-Dec-19 275 6 436
+ 5.003_13 1996-Dec-20 95 1 56
+ 5.003_14 1996-Dec-23 23 7 333
+ 5.003_15 1996-Dec-23 0 0 1
+ 5.003_16 1996-Dec-24 12 3 50
+ 5.003_17 1996-Dec-27 19 1 14
+ 5.003_18 1996-Dec-31 21 1 32
+ 5.003_19 1997-Jan-04 80 3 85
+ 5.003_20 1997-Jan-07 18 1 146
+ 5.003_21 1997-Jan-15 38 10 221
+ 5.003_22 1997-Jan-16 4 0 18
+ 5.003_23 1997-Jan-25 71 15 119
+ 5.003_24 1997-Jan-29 426 1 20
+ 5.003_25 1997-Feb-04 21 8 169
+ 5.003_26 1997-Feb-10 16 1 15
+ 5.003_27 1997-Feb-18 32 10 38
+ 5.003_28 1997-Feb-21 58 4 66
+ 5.003_90 1997-Feb-25 22 2 34
+ 5.003_91 1997-Mar-01 37 1 39
+ 5.003_92 1997-Mar-06 16 3 69
+ 5.003_93 1997-Mar-10 12 3 15
+ 5.003_94 1997-Mar-22 407 7 200
+ 5.003_95 1997-Mar-25 41 1 37
+ 5.003_96 1997-Apr-01 283 5 261
+ 5.003_97 1997-Apr-03 13 2 34
+ 5.003_97a 1997-Apr-05 57 1 27
+ 5.003_97b 1997-Apr-08 14 1 20
+ 5.003_97c 1997-Apr-10 20 1 16
+ 5.003_97d 1997-Apr-13 8 0 16
+ 5.003_97e 1997-Apr-15 15 4 46
+ 5.003_97f 1997-Apr-17 7 1 33
+ 5.003_97g 1997-Apr-18 6 1 42
+ 5.003_97h 1997-Apr-24 23 3 68
+ 5.003_97i 1997-Apr-25 23 1 31
+ 5.003_97j 1997-Apr-28 36 1 49
+ 5.003_98 1997-Apr-30 171 12 539
+ 5.003_99 1997-May-01 6 0 7
+ 5.003_99a 1997-May-09 36 2 61
+ p54rc1 1997-May-12 8 1 11
+ p54rc2 1997-May-14 6 0 40
+
+ 5.004 1997-May-15 4 0 4
+
+ Tim 5.004_01 1997-Jun-13 222 14 57
+ 5.004_02 1997-Aug-07 112 16 119
+ 5.004_03 1997-Sep-05 109 0 17
+ 5.004_04 1997-Oct-15 66 8 173
+
+=head1 THE KEEPERS OF THE RECORDS
+
+Jarkko Hietaniemi <F<jhi@iki.fi>>.
+
+Thanks to the collective memory of the Perlfolk. In addition to the
+Keepers of the Pumpkin also Alan Champion, Andreas König, John
+Macdonald, Matthias Neeracher, Michael Peppler, Randal Schwartz, and
+Paul D. Smith sent corrections and additions.
+
+=cut
diff --git a/contrib/perl5/pod/perlipc.pod b/contrib/perl5/pod/perlipc.pod
new file mode 100644
index 000000000000..59c5ad9f0154
--- /dev/null
+++ b/contrib/perl5/pod/perlipc.pod
@@ -0,0 +1,1443 @@
+=head1 NAME
+
+perlipc - Perl interprocess communication (signals, fifos, pipes, safe subprocesses, sockets, and semaphores)
+
+=head1 DESCRIPTION
+
+The basic IPC facilities of Perl are built out of the good old Unix
+signals, named pipes, pipe opens, the Berkeley socket routines, and SysV
+IPC calls. Each is used in slightly different situations.
+
+=head1 Signals
+
+Perl uses a simple signal handling model: the %SIG hash contains names or
+references of user-installed signal handlers. These handlers will be called
+with an argument which is the name of the signal that triggered it. A
+signal may be generated intentionally from a particular keyboard sequence like
+control-C or control-Z, sent to you from another process, or
+triggered automatically by the kernel when special events transpire, like
+a child process exiting, your process running out of stack space, or
+hitting file size limit.
+
+For example, to trap an interrupt signal, set up a handler like this.
+Do as little as you possibly can in your handler; notice how all we do is
+set a global variable and then raise an exception. That's because on most
+systems, libraries are not re-entrant; particularly, memory allocation and
+I/O routines are not. That means that doing nearly I<anything> in your
+handler could in theory trigger a memory fault and subsequent core dump.
+
+ sub catch_zap {
+ my $signame = shift;
+ $shucks++;
+ die "Somebody sent me a SIG$signame";
+ }
+ $SIG{INT} = 'catch_zap'; # could fail in modules
+ $SIG{INT} = \&catch_zap; # best strategy
+
+The names of the signals are the ones listed out by C<kill -l> on your
+system, or you can retrieve them from the Config module. Set up an
+@signame list indexed by number to get the name and a %signo table
+indexed by name to get the number:
+
+ use Config;
+ defined $Config{sig_name} || die "No sigs?";
+ foreach $name (split(' ', $Config{sig_name})) {
+ $signo{$name} = $i;
+ $signame[$i] = $name;
+ $i++;
+ }
+
+So to check whether signal 17 and SIGALRM were the same, do just this:
+
+ print "signal #17 = $signame[17]\n";
+ if ($signo{ALRM}) {
+ print "SIGALRM is $signo{ALRM}\n";
+ }
+
+You may also choose to assign the strings C<'IGNORE'> or C<'DEFAULT'> as
+the handler, in which case Perl will try to discard the signal or do the
+default thing. Some signals can be neither trapped nor ignored, such as
+the KILL and STOP (but not the TSTP) signals. One strategy for
+temporarily ignoring signals is to use a local() statement, which will be
+automatically restored once your block is exited. (Remember that local()
+values are "inherited" by functions called from within that block.)
+
+ sub precious {
+ local $SIG{INT} = 'IGNORE';
+ &more_functions;
+ }
+ sub more_functions {
+ # interrupts still ignored, for now...
+ }
+
+Sending a signal to a negative process ID means that you send the signal
+to the entire Unix process-group. This code sends a hang-up signal to all
+processes in the current process group (and sets $SIG{HUP} to IGNORE so
+it doesn't kill itself):
+
+ {
+ local $SIG{HUP} = 'IGNORE';
+ kill HUP => -$$;
+ # snazzy writing of: kill('HUP', -$$)
+ }
+
+Another interesting signal to send is signal number zero. This doesn't
+actually affect another process, but instead checks whether it's alive
+or has changed its UID.
+
+ unless (kill 0 => $kid_pid) {
+ warn "something wicked happened to $kid_pid";
+ }
+
+You might also want to employ anonymous functions for simple signal
+handlers:
+
+ $SIG{INT} = sub { die "\nOutta here!\n" };
+
+But that will be problematic for the more complicated handlers that need
+to reinstall themselves. Because Perl's signal mechanism is currently
+based on the signal(3) function from the C library, you may sometimes be so
+misfortunate as to run on systems where that function is "broken", that
+is, it behaves in the old unreliable SysV way rather than the newer, more
+reasonable BSD and POSIX fashion. So you'll see defensive people writing
+signal handlers like this:
+
+ sub REAPER {
+ $waitedpid = wait;
+ # loathe sysV: it makes us not only reinstate
+ # the handler, but place it after the wait
+ $SIG{CHLD} = \&REAPER;
+ }
+ $SIG{CHLD} = \&REAPER;
+ # now do something that forks...
+
+or even the more elaborate:
+
+ use POSIX ":sys_wait_h";
+ sub REAPER {
+ my $child;
+ while ($child = waitpid(-1,WNOHANG)) {
+ $Kid_Status{$child} = $?;
+ }
+ $SIG{CHLD} = \&REAPER; # still loathe sysV
+ }
+ $SIG{CHLD} = \&REAPER;
+ # do something that forks...
+
+Signal handling is also used for timeouts in Unix, While safely
+protected within an C<eval{}> block, you set a signal handler to trap
+alarm signals and then schedule to have one delivered to you in some
+number of seconds. Then try your blocking operation, clearing the alarm
+when it's done but not before you've exited your C<eval{}> block. If it
+goes off, you'll use die() to jump out of the block, much as you might
+using longjmp() or throw() in other languages.
+
+Here's an example:
+
+ eval {
+ local $SIG{ALRM} = sub { die "alarm clock restart" };
+ alarm 10;
+ flock(FH, 2); # blocking write lock
+ alarm 0;
+ };
+ if ($@ and $@ !~ /alarm clock restart/) { die }
+
+For more complex signal handling, you might see the standard POSIX
+module. Lamentably, this is almost entirely undocumented, but
+the F<t/lib/posix.t> file from the Perl source distribution has some
+examples in it.
+
+=head1 Named Pipes
+
+A named pipe (often referred to as a FIFO) is an old Unix IPC
+mechanism for processes communicating on the same machine. It works
+just like a regular, connected anonymous pipes, except that the
+processes rendezvous using a filename and don't have to be related.
+
+To create a named pipe, use the Unix command mknod(1) or on some
+systems, mkfifo(1). These may not be in your normal path.
+
+ # system return val is backwards, so && not ||
+ #
+ $ENV{PATH} .= ":/etc:/usr/etc";
+ if ( system('mknod', $path, 'p')
+ && system('mkfifo', $path) )
+ {
+ die "mk{nod,fifo} $path failed";
+ }
+
+
+A fifo is convenient when you want to connect a process to an unrelated
+one. When you open a fifo, the program will block until there's something
+on the other end.
+
+For example, let's say you'd like to have your F<.signature> file be a
+named pipe that has a Perl program on the other end. Now every time any
+program (like a mailer, news reader, finger program, etc.) tries to read
+from that file, the reading program will block and your program will
+supply the new signature. We'll use the pipe-checking file test B<-p>
+to find out whether anyone (or anything) has accidentally removed our fifo.
+
+ chdir; # go home
+ $FIFO = '.signature';
+ $ENV{PATH} .= ":/etc:/usr/games";
+
+ while (1) {
+ unless (-p $FIFO) {
+ unlink $FIFO;
+ system('mknod', $FIFO, 'p')
+ && die "can't mknod $FIFO: $!";
+ }
+
+ # next line blocks until there's a reader
+ open (FIFO, "> $FIFO") || die "can't write $FIFO: $!";
+ print FIFO "John Smith (smith\@host.org)\n", `fortune -s`;
+ close FIFO;
+ sleep 2; # to avoid dup signals
+ }
+
+=head2 WARNING
+
+By installing Perl code to deal with signals, you're exposing yourself
+to danger from two things. First, few system library functions are
+re-entrant. If the signal interrupts while Perl is executing one function
+(like malloc(3) or printf(3)), and your signal handler then calls the
+same function again, you could get unpredictable behavior--often, a
+core dump. Second, Perl isn't itself re-entrant at the lowest levels.
+If the signal interrupts Perl while Perl is changing its own internal
+data structures, similarly unpredictable behaviour may result.
+
+There are two things you can do, knowing this: be paranoid or be
+pragmatic. The paranoid approach is to do as little as possible in your
+signal handler. Set an existing integer variable that already has a
+value, and return. This doesn't help you if you're in a slow system call,
+which will just restart. That means you have to C<die> to longjump(3) out
+of the handler. Even this is a little cavalier for the true paranoiac,
+who avoids C<die> in a handler because the system I<is> out to get you.
+The pragmatic approach is to say ``I know the risks, but prefer the
+convenience'', and to do anything you want in your signal handler,
+prepared to clean up core dumps now and again.
+
+To forbid signal handlers altogether would bars you from
+many interesting programs, including virtually everything in this manpage,
+since you could no longer even write SIGCHLD handlers. Their dodginess
+is expected to be addresses in the 5.005 release.
+
+
+=head1 Using open() for IPC
+
+Perl's basic open() statement can also be used for unidirectional interprocess
+communication by either appending or prepending a pipe symbol to the second
+argument to open(). Here's how to start something up in a child process you
+intend to write to:
+
+ open(SPOOLER, "| cat -v | lpr -h 2>/dev/null")
+ || die "can't fork: $!";
+ local $SIG{PIPE} = sub { die "spooler pipe broke" };
+ print SPOOLER "stuff\n";
+ close SPOOLER || die "bad spool: $! $?";
+
+And here's how to start up a child process you intend to read from:
+
+ open(STATUS, "netstat -an 2>&1 |")
+ || die "can't fork: $!";
+ while (<STATUS>) {
+ next if /^(tcp|udp)/;
+ print;
+ }
+ close STATUS || die "bad netstat: $! $?";
+
+If one can be sure that a particular program is a Perl script that is
+expecting filenames in @ARGV, the clever programmer can write something
+like this:
+
+ % program f1 "cmd1|" - f2 "cmd2|" f3 < tmpfile
+
+and irrespective of which shell it's called from, the Perl program will
+read from the file F<f1>, the process F<cmd1>, standard input (F<tmpfile>
+in this case), the F<f2> file, the F<cmd2> command, and finally the F<f3>
+file. Pretty nifty, eh?
+
+You might notice that you could use backticks for much the
+same effect as opening a pipe for reading:
+
+ print grep { !/^(tcp|udp)/ } `netstat -an 2>&1`;
+ die "bad netstat" if $?;
+
+While this is true on the surface, it's much more efficient to process the
+file one line or record at a time because then you don't have to read the
+whole thing into memory at once. It also gives you finer control of the
+whole process, letting you to kill off the child process early if you'd
+like.
+
+Be careful to check both the open() and the close() return values. If
+you're I<writing> to a pipe, you should also trap SIGPIPE. Otherwise,
+think of what happens when you start up a pipe to a command that doesn't
+exist: the open() will in all likelihood succeed (it only reflects the
+fork()'s success), but then your output will fail--spectacularly. Perl
+can't know whether the command worked because your command is actually
+running in a separate process whose exec() might have failed. Therefore,
+while readers of bogus commands return just a quick end of file, writers
+to bogus command will trigger a signal they'd better be prepared to
+handle. Consider:
+
+ open(FH, "|bogus") or die "can't fork: $!";
+ print FH "bang\n" or die "can't write: $!";
+ close FH or die "can't close: $!";
+
+That won't blow up until the close, and it will blow up with a SIGPIPE.
+To catch it, you could use this:
+
+ $SIG{PIPE} = 'IGNORE';
+ open(FH, "|bogus") or die "can't fork: $!";
+ print FH "bang\n" or die "can't write: $!";
+ close FH or die "can't close: status=$?";
+
+=head2 Filehandles
+
+Both the main process and any child processes it forks share the same
+STDIN, STDOUT, and STDERR filehandles. If both processes try to access
+them at once, strange things can happen. You'll certainly want to any
+stdio flush output buffers before forking. You may also want to close
+or reopen the filehandles for the child. You can get around this by
+opening your pipe with open(), but on some systems this means that the
+child process cannot outlive the parent.
+
+=head2 Background Processes
+
+You can run a command in the background with:
+
+ system("cmd &");
+
+The command's STDOUT and STDERR (and possibly STDIN, depending on your
+shell) will be the same as the parent's. You won't need to catch
+SIGCHLD because of the double-fork taking place (see below for more
+details).
+
+=head2 Complete Dissociation of Child from Parent
+
+In some cases (starting server processes, for instance) you'll want to
+complete dissociate the child process from the parent. The easiest
+way is to use:
+
+ use POSIX qw(setsid);
+ setsid() or die "Can't start a new session: $!";
+
+However, you may not be on POSIX. The following process is reported
+to work on most Unixish systems. Non-Unix users should check their
+Your_OS::Process module for other solutions.
+
+=over 4
+
+=item *
+
+Open /dev/tty and use the TIOCNOTTY ioctl on it. See L<tty(4)>
+for details.
+
+=item *
+
+Change directory to /
+
+=item *
+
+Reopen STDIN, STDOUT, and STDERR so they're not connected to the old
+tty.
+
+=item *
+
+Background yourself like this:
+
+ fork && exit;
+
+=item *
+
+Ignore hangup signals in case you're running on a shell that doesn't
+automatically no-hup you:
+
+ $SIG{HUP} = 'IGNORE'; # or whatever you'd like
+
+=back
+
+=head2 Safe Pipe Opens
+
+Another interesting approach to IPC is making your single program go
+multiprocess and communicate between (or even amongst) yourselves. The
+open() function will accept a file argument of either C<"-|"> or C<"|-">
+to do a very interesting thing: it forks a child connected to the
+filehandle you've opened. The child is running the same program as the
+parent. This is useful for safely opening a file when running under an
+assumed UID or GID, for example. If you open a pipe I<to> minus, you can
+write to the filehandle you opened and your kid will find it in his
+STDIN. If you open a pipe I<from> minus, you can read from the filehandle
+you opened whatever your kid writes to his STDOUT.
+
+ use English;
+ my $sleep_count = 0;
+
+ do {
+ $pid = open(KID_TO_WRITE, "|-");
+ unless (defined $pid) {
+ warn "cannot fork: $!";
+ die "bailing out" if $sleep_count++ > 6;
+ sleep 10;
+ }
+ } until defined $pid;
+
+ if ($pid) { # parent
+ print KID_TO_WRITE @some_data;
+ close(KID_TO_WRITE) || warn "kid exited $?";
+ } else { # child
+ ($EUID, $EGID) = ($UID, $GID); # suid progs only
+ open (FILE, "> /safe/file")
+ || die "can't open /safe/file: $!";
+ while (<STDIN>) {
+ print FILE; # child's STDIN is parent's KID
+ }
+ exit; # don't forget this
+ }
+
+Another common use for this construct is when you need to execute
+something without the shell's interference. With system(), it's
+straightforward, but you can't use a pipe open or backticks safely.
+That's because there's no way to stop the shell from getting its hands on
+your arguments. Instead, use lower-level control to call exec() directly.
+
+Here's a safe backtick or pipe open for read:
+
+ # add error processing as above
+ $pid = open(KID_TO_READ, "-|");
+
+ if ($pid) { # parent
+ while (<KID_TO_READ>) {
+ # do something interesting
+ }
+ close(KID_TO_READ) || warn "kid exited $?";
+
+ } else { # child
+ ($EUID, $EGID) = ($UID, $GID); # suid only
+ exec($program, @options, @args)
+ || die "can't exec program: $!";
+ # NOTREACHED
+ }
+
+
+And here's a safe pipe open for writing:
+
+ # add error processing as above
+ $pid = open(KID_TO_WRITE, "|-");
+ $SIG{ALRM} = sub { die "whoops, $program pipe broke" };
+
+ if ($pid) { # parent
+ for (@data) {
+ print KID_TO_WRITE;
+ }
+ close(KID_TO_WRITE) || warn "kid exited $?";
+
+ } else { # child
+ ($EUID, $EGID) = ($UID, $GID);
+ exec($program, @options, @args)
+ || die "can't exec program: $!";
+ # NOTREACHED
+ }
+
+Note that these operations are full Unix forks, which means they may not be
+correctly implemented on alien systems. Additionally, these are not true
+multithreading. If you'd like to learn more about threading, see the
+F<modules> file mentioned below in the SEE ALSO section.
+
+=head2 Bidirectional Communication with Another Process
+
+While this works reasonably well for unidirectional communication, what
+about bidirectional communication? The obvious thing you'd like to do
+doesn't actually work:
+
+ open(PROG_FOR_READING_AND_WRITING, "| some program |")
+
+and if you forget to use the B<-w> flag, then you'll miss out
+entirely on the diagnostic message:
+
+ Can't do bidirectional pipe at -e line 1.
+
+If you really want to, you can use the standard open2() library function
+to catch both ends. There's also an open3() for tridirectional I/O so you
+can also catch your child's STDERR, but doing so would then require an
+awkward select() loop and wouldn't allow you to use normal Perl input
+operations.
+
+If you look at its source, you'll see that open2() uses low-level
+primitives like Unix pipe() and exec() calls to create all the connections.
+While it might have been slightly more efficient by using socketpair(), it
+would have then been even less portable than it already is. The open2()
+and open3() functions are unlikely to work anywhere except on a Unix
+system or some other one purporting to be POSIX compliant.
+
+Here's an example of using open2():
+
+ use FileHandle;
+ use IPC::Open2;
+ $pid = open2(*Reader, *Writer, "cat -u -n" );
+ Writer->autoflush(); # default here, actually
+ print Writer "stuff\n";
+ $got = <Reader>;
+
+The problem with this is that Unix buffering is really going to
+ruin your day. Even though your C<Writer> filehandle is auto-flushed,
+and the process on the other end will get your data in a timely manner,
+you can't usually do anything to force it to give it back to you
+in a similarly quick fashion. In this case, we could, because we
+gave I<cat> a B<-u> flag to make it unbuffered. But very few Unix
+commands are designed to operate over pipes, so this seldom works
+unless you yourself wrote the program on the other end of the
+double-ended pipe.
+
+A solution to this is the nonstandard F<Comm.pl> library. It uses
+pseudo-ttys to make your program behave more reasonably:
+
+ require 'Comm.pl';
+ $ph = open_proc('cat -n');
+ for (1..10) {
+ print $ph "a line\n";
+ print "got back ", scalar <$ph>;
+ }
+
+This way you don't have to have control over the source code of the
+program you're using. The F<Comm> library also has expect()
+and interact() functions. Find the library (and we hope its
+successor F<IPC::Chat>) at your nearest CPAN archive as detailed
+in the SEE ALSO section below.
+
+The newer Expect.pm module from CPAN also addresses this kind of thing.
+This module requires two other modules from CPAN: IO::Pty and IO::Stty.
+It sets up a pseudo-terminal to interact with programs that insist on
+using talking to the terminal device driver. If your system is
+amongst those supported, this may be your best bet.
+
+=head2 Bidirectional Communication with Yourself
+
+If you want, you may make low-level pipe() and fork()
+to stitch this together by hand. This example only
+talks to itself, but you could reopen the appropriate
+handles to STDIN and STDOUT and call other processes.
+
+ #!/usr/bin/perl -w
+ # pipe1 - bidirectional communication using two pipe pairs
+ # designed for the socketpair-challenged
+ use IO::Handle; # thousands of lines just for autoflush :-(
+ pipe(PARENT_RDR, CHILD_WTR); # XXX: failure?
+ pipe(CHILD_RDR, PARENT_WTR); # XXX: failure?
+ CHILD_WTR->autoflush(1);
+ PARENT_WTR->autoflush(1);
+
+ if ($pid = fork) {
+ close PARENT_RDR; close PARENT_WTR;
+ print CHILD_WTR "Parent Pid $$ is sending this\n";
+ chomp($line = <CHILD_RDR>);
+ print "Parent Pid $$ just read this: `$line'\n";
+ close CHILD_RDR; close CHILD_WTR;
+ waitpid($pid,0);
+ } else {
+ die "cannot fork: $!" unless defined $pid;
+ close CHILD_RDR; close CHILD_WTR;
+ chomp($line = <PARENT_RDR>);
+ print "Child Pid $$ just read this: `$line'\n";
+ print PARENT_WTR "Child Pid $$ is sending this\n";
+ close PARENT_RDR; close PARENT_WTR;
+ exit;
+ }
+
+But you don't actually have to make two pipe calls. If you
+have the socketpair() system call, it will do this all for you.
+
+ #!/usr/bin/perl -w
+ # pipe2 - bidirectional communication using socketpair
+ # "the best ones always go both ways"
+
+ use Socket;
+ use IO::Handle; # thousands of lines just for autoflush :-(
+ # We say AF_UNIX because although *_LOCAL is the
+ # POSIX 1003.1g form of the constant, many machines
+ # still don't have it.
+ socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
+ or die "socketpair: $!";
+
+ CHILD->autoflush(1);
+ PARENT->autoflush(1);
+
+ if ($pid = fork) {
+ close PARENT;
+ print CHILD "Parent Pid $$ is sending this\n";
+ chomp($line = <CHILD>);
+ print "Parent Pid $$ just read this: `$line'\n";
+ close CHILD;
+ waitpid($pid,0);
+ } else {
+ die "cannot fork: $!" unless defined $pid;
+ close CHILD;
+ chomp($line = <PARENT>);
+ print "Child Pid $$ just read this: `$line'\n";
+ print PARENT "Child Pid $$ is sending this\n";
+ close PARENT;
+ exit;
+ }
+
+=head1 Sockets: Client/Server Communication
+
+While not limited to Unix-derived operating systems (e.g., WinSock on PCs
+provides socket support, as do some VMS libraries), you may not have
+sockets on your system, in which case this section probably isn't going to do
+you much good. With sockets, you can do both virtual circuits (i.e., TCP
+streams) and datagrams (i.e., UDP packets). You may be able to do even more
+depending on your system.
+
+The Perl function calls for dealing with sockets have the same names as
+the corresponding system calls in C, but their arguments tend to differ
+for two reasons: first, Perl filehandles work differently than C file
+descriptors. Second, Perl already knows the length of its strings, so you
+don't need to pass that information.
+
+One of the major problems with old socket code in Perl was that it used
+hard-coded values for some of the constants, which severely hurt
+portability. If you ever see code that does anything like explicitly
+setting C<$AF_INET = 2>, you know you're in for big trouble: An
+immeasurably superior approach is to use the C<Socket> module, which more
+reliably grants access to various constants and functions you'll need.
+
+If you're not writing a server/client for an existing protocol like
+NNTP or SMTP, you should give some thought to how your server will
+know when the client has finished talking, and vice-versa. Most
+protocols are based on one-line messages and responses (so one party
+knows the other has finished when a "\n" is received) or multi-line
+messages and responses that end with a period on an empty line
+("\n.\n" terminates a message/response).
+
+=head2 Internet Line Terminators
+
+The Internet line terminator is "\015\012". Under ASCII variants of
+Unix, that could usually be written as "\r\n", but under other systems,
+"\r\n" might at times be "\015\015\012", "\012\012\015", or something
+completely different. The standards specify writing "\015\012" to be
+conformant (be strict in what you provide), but they also recommend
+accepting a lone "\012" on input (but be lenient in what you require).
+We haven't always been very good about that in the code in this manpage,
+but unless you're on a Mac, you'll probably be ok.
+
+=head2 Internet TCP Clients and Servers
+
+Use Internet-domain sockets when you want to do client-server
+communication that might extend to machines outside of your own system.
+
+Here's a sample TCP client using Internet-domain sockets:
+
+ #!/usr/bin/perl -w
+ use strict;
+ use Socket;
+ my ($remote,$port, $iaddr, $paddr, $proto, $line);
+
+ $remote = shift || 'localhost';
+ $port = shift || 2345; # random port
+ if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
+ die "No port" unless $port;
+ $iaddr = inet_aton($remote) || die "no host: $remote";
+ $paddr = sockaddr_in($port, $iaddr);
+
+ $proto = getprotobyname('tcp');
+ socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ connect(SOCK, $paddr) || die "connect: $!";
+ while (defined($line = <SOCK>)) {
+ print $line;
+ }
+
+ close (SOCK) || die "close: $!";
+ exit;
+
+And here's a corresponding server to go along with it. We'll
+leave the address as INADDR_ANY so that the kernel can choose
+the appropriate interface on multihomed hosts. If you want sit
+on a particular interface (like the external side of a gateway
+or firewall machine), you should fill this in with your real address
+instead.
+
+ #!/usr/bin/perl -Tw
+ use strict;
+ BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
+ use Socket;
+ use Carp;
+ $EOL = "\015\012";
+
+ sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }
+
+ my $port = shift || 2345;
+ my $proto = getprotobyname('tcp');
+ $port = $1 if $port =~ /(\d+)/; # untaint port number
+
+ socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
+ pack("l", 1)) || die "setsockopt: $!";
+ bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
+ listen(Server,SOMAXCONN) || die "listen: $!";
+
+ logmsg "server started on port $port";
+
+ my $paddr;
+
+ $SIG{CHLD} = \&REAPER;
+
+ for ( ; $paddr = accept(Client,Server); close Client) {
+ my($port,$iaddr) = sockaddr_in($paddr);
+ my $name = gethostbyaddr($iaddr,AF_INET);
+
+ logmsg "connection from $name [",
+ inet_ntoa($iaddr), "]
+ at port $port";
+
+ print Client "Hello there, $name, it's now ",
+ scalar localtime, $EOL;
+ }
+
+And here's a multithreaded version. It's multithreaded in that
+like most typical servers, it spawns (forks) a slave server to
+handle the client request so that the master server can quickly
+go back to service a new client.
+
+ #!/usr/bin/perl -Tw
+ use strict;
+ BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
+ use Socket;
+ use Carp;
+ $EOL = "\015\012";
+
+ sub spawn; # forward declaration
+ sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }
+
+ my $port = shift || 2345;
+ my $proto = getprotobyname('tcp');
+ $port = $1 if $port =~ /(\d+)/; # untaint port number
+
+ socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
+ pack("l", 1)) || die "setsockopt: $!";
+ bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
+ listen(Server,SOMAXCONN) || die "listen: $!";
+
+ logmsg "server started on port $port";
+
+ my $waitedpid = 0;
+ my $paddr;
+
+ sub REAPER {
+ $waitedpid = wait;
+ $SIG{CHLD} = \&REAPER; # loathe sysV
+ logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
+ }
+
+ $SIG{CHLD} = \&REAPER;
+
+ for ( $waitedpid = 0;
+ ($paddr = accept(Client,Server)) || $waitedpid;
+ $waitedpid = 0, close Client)
+ {
+ next if $waitedpid and not $paddr;
+ my($port,$iaddr) = sockaddr_in($paddr);
+ my $name = gethostbyaddr($iaddr,AF_INET);
+
+ logmsg "connection from $name [",
+ inet_ntoa($iaddr), "]
+ at port $port";
+
+ spawn sub {
+ print "Hello there, $name, it's now ", scalar localtime, $EOL;
+ exec '/usr/games/fortune' # XXX: `wrong' line terminators
+ or confess "can't exec fortune: $!";
+ };
+
+ }
+
+ sub spawn {
+ my $coderef = shift;
+
+ unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
+ confess "usage: spawn CODEREF";
+ }
+
+ my $pid;
+ if (!defined($pid = fork)) {
+ logmsg "cannot fork: $!";
+ return;
+ } elsif ($pid) {
+ logmsg "begat $pid";
+ return; # I'm the parent
+ }
+ # else I'm the child -- go spawn
+
+ open(STDIN, "<&Client") || die "can't dup client to stdin";
+ open(STDOUT, ">&Client") || die "can't dup client to stdout";
+ ## open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";
+ exit &$coderef();
+ }
+
+This server takes the trouble to clone off a child version via fork() for
+each incoming request. That way it can handle many requests at once,
+which you might not always want. Even if you don't fork(), the listen()
+will allow that many pending connections. Forking servers have to be
+particularly careful about cleaning up their dead children (called
+"zombies" in Unix parlance), because otherwise you'll quickly fill up your
+process table.
+
+We suggest that you use the B<-T> flag to use taint checking (see L<perlsec>)
+even if we aren't running setuid or setgid. This is always a good idea
+for servers and other programs run on behalf of someone else (like CGI
+scripts), because it lessens the chances that people from the outside will
+be able to compromise your system.
+
+Let's look at another TCP client. This one connects to the TCP "time"
+service on a number of different machines and shows how far their clocks
+differ from the system on which it's being run:
+
+ #!/usr/bin/perl -w
+ use strict;
+ use Socket;
+
+ my $SECS_of_70_YEARS = 2208988800;
+ sub ctime { scalar localtime(shift) }
+
+ my $iaddr = gethostbyname('localhost');
+ my $proto = getprotobyname('tcp');
+ my $port = getservbyname('time', 'tcp');
+ my $paddr = sockaddr_in(0, $iaddr);
+ my($host);
+
+ $| = 1;
+ printf "%-24s %8s %s\n", "localhost", 0, ctime(time());
+
+ foreach $host (@ARGV) {
+ printf "%-24s ", $host;
+ my $hisiaddr = inet_aton($host) || die "unknown host";
+ my $hispaddr = sockaddr_in($port, $hisiaddr);
+ socket(SOCKET, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
+ connect(SOCKET, $hispaddr) || die "bind: $!";
+ my $rtime = ' ';
+ read(SOCKET, $rtime, 4);
+ close(SOCKET);
+ my $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ;
+ printf "%8d %s\n", $histime - time, ctime($histime);
+ }
+
+=head2 Unix-Domain TCP Clients and Servers
+
+That's fine for Internet-domain clients and servers, but what about local
+communications? While you can use the same setup, sometimes you don't
+want to. Unix-domain sockets are local to the current host, and are often
+used internally to implement pipes. Unlike Internet domain sockets, Unix
+domain sockets can show up in the file system with an ls(1) listing.
+
+ % ls -l /dev/log
+ srw-rw-rw- 1 root 0 Oct 31 07:23 /dev/log
+
+You can test for these with Perl's B<-S> file test:
+
+ unless ( -S '/dev/log' ) {
+ die "something's wicked with the print system";
+ }
+
+Here's a sample Unix-domain client:
+
+ #!/usr/bin/perl -w
+ use Socket;
+ use strict;
+ my ($rendezvous, $line);
+
+ $rendezvous = shift || '/tmp/catsock';
+ socket(SOCK, PF_UNIX, SOCK_STREAM, 0) || die "socket: $!";
+ connect(SOCK, sockaddr_un($rendezvous)) || die "connect: $!";
+ while (defined($line = <SOCK>)) {
+ print $line;
+ }
+ exit;
+
+And here's a corresponding server. You don't have to worry about silly
+network terminators here because Unix domain sockets are guaranteed
+to be on the localhost, and thus everything works right.
+
+ #!/usr/bin/perl -Tw
+ use strict;
+ use Socket;
+ use Carp;
+
+ BEGIN { $ENV{PATH} = '/usr/ucb:/bin' }
+ sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }
+
+ my $NAME = '/tmp/catsock';
+ my $uaddr = sockaddr_un($NAME);
+ my $proto = getprotobyname('tcp');
+
+ socket(Server,PF_UNIX,SOCK_STREAM,0) || die "socket: $!";
+ unlink($NAME);
+ bind (Server, $uaddr) || die "bind: $!";
+ listen(Server,SOMAXCONN) || die "listen: $!";
+
+ logmsg "server started on $NAME";
+
+ my $waitedpid;
+
+ sub REAPER {
+ $waitedpid = wait;
+ $SIG{CHLD} = \&REAPER; # loathe sysV
+ logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
+ }
+
+ $SIG{CHLD} = \&REAPER;
+
+
+ for ( $waitedpid = 0;
+ accept(Client,Server) || $waitedpid;
+ $waitedpid = 0, close Client)
+ {
+ next if $waitedpid;
+ logmsg "connection on $NAME";
+ spawn sub {
+ print "Hello there, it's now ", scalar localtime, "\n";
+ exec '/usr/games/fortune' or die "can't exec fortune: $!";
+ };
+ }
+
+As you see, it's remarkably similar to the Internet domain TCP server, so
+much so, in fact, that we've omitted several duplicate functions--spawn(),
+logmsg(), ctime(), and REAPER()--which are exactly the same as in the
+other server.
+
+So why would you ever want to use a Unix domain socket instead of a
+simpler named pipe? Because a named pipe doesn't give you sessions. You
+can't tell one process's data from another's. With socket programming,
+you get a separate session for each client: that's why accept() takes two
+arguments.
+
+For example, let's say that you have a long running database server daemon
+that you want folks from the World Wide Web to be able to access, but only
+if they go through a CGI interface. You'd have a small, simple CGI
+program that does whatever checks and logging you feel like, and then acts
+as a Unix-domain client and connects to your private server.
+
+=head1 TCP Clients with IO::Socket
+
+For those preferring a higher-level interface to socket programming, the
+IO::Socket module provides an object-oriented approach. IO::Socket is
+included as part of the standard Perl distribution as of the 5.004
+release. If you're running an earlier version of Perl, just fetch
+IO::Socket from CPAN, where you'll also find find modules providing easy
+interfaces to the following systems: DNS, FTP, Ident (RFC 931), NIS and
+NISPlus, NNTP, Ping, POP3, SMTP, SNMP, SSLeay, Telnet, and Time--just
+to name a few.
+
+=head2 A Simple Client
+
+Here's a client that creates a TCP connection to the "daytime"
+service at port 13 of the host name "localhost" and prints out everything
+that the server there cares to provide.
+
+ #!/usr/bin/perl -w
+ use IO::Socket;
+ $remote = IO::Socket::INET->new(
+ Proto => "tcp",
+ PeerAddr => "localhost",
+ PeerPort => "daytime(13)",
+ )
+ or die "cannot connect to daytime port at localhost";
+ while ( <$remote> ) { print }
+
+When you run this program, you should get something back that
+looks like this:
+
+ Wed May 14 08:40:46 MDT 1997
+
+Here are what those parameters to the C<new> constructor mean:
+
+=over
+
+=item C<Proto>
+
+This is which protocol to use. In this case, the socket handle returned
+will be connected to a TCP socket, because we want a stream-oriented
+connection, that is, one that acts pretty much like a plain old file.
+Not all sockets are this of this type. For example, the UDP protocol
+can be used to make a datagram socket, used for message-passing.
+
+=item C<PeerAddr>
+
+This is the name or Internet address of the remote host the server is
+running on. We could have specified a longer name like C<"www.perl.com">,
+or an address like C<"204.148.40.9">. For demonstration purposes, we've
+used the special hostname C<"localhost">, which should always mean the
+current machine you're running on. The corresponding Internet address
+for localhost is C<"127.1">, if you'd rather use that.
+
+=item C<PeerPort>
+
+This is the service name or port number we'd like to connect to.
+We could have gotten away with using just C<"daytime"> on systems with a
+well-configured system services file,[FOOTNOTE: The system services file
+is in I</etc/services> under Unix] but just in case, we've specified the
+port number (13) in parentheses. Using just the number would also have
+worked, but constant numbers make careful programmers nervous.
+
+=back
+
+Notice how the return value from the C<new> constructor is used as
+a filehandle in the C<while> loop? That's what's called an indirect
+filehandle, a scalar variable containing a filehandle. You can use
+it the same way you would a normal filehandle. For example, you
+can read one line from it this way:
+
+ $line = <$handle>;
+
+all remaining lines from is this way:
+
+ @lines = <$handle>;
+
+and send a line of data to it this way:
+
+ print $handle "some data\n";
+
+=head2 A Webget Client
+
+Here's a simple client that takes a remote host to fetch a document
+from, and then a list of documents to get from that host. This is a
+more interesting client than the previous one because it first sends
+something to the server before fetching the server's response.
+
+ #!/usr/bin/perl -w
+ use IO::Socket;
+ unless (@ARGV > 1) { die "usage: $0 host document ..." }
+ $host = shift(@ARGV);
+ $EOL = "\015\012";
+ $BLANK = $EOL x 2;
+ foreach $document ( @ARGV ) {
+ $remote = IO::Socket::INET->new( Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => "http(80)",
+ );
+ unless ($remote) { die "cannot connect to http daemon on $host" }
+ $remote->autoflush(1);
+ print $remote "GET $document HTTP/1.0" . $BLANK;
+ while ( <$remote> ) { print }
+ close $remote;
+ }
+
+The web server handing the "http" service, which is assumed to be at
+its standard port, number 80. If your the web server you're trying to
+connect to is at a different port (like 1080 or 8080), you should specify
+as the named-parameter pair, C<PeerPort =E<gt> 8080>. The C<autoflush>
+method is used on the socket because otherwise the system would buffer
+up the output we sent it. (If you're on a Mac, you'll also need to
+change every C<"\n"> in your code that sends data over the network to
+be a C<"\015\012"> instead.)
+
+Connecting to the server is only the first part of the process: once you
+have the connection, you have to use the server's language. Each server
+on the network has its own little command language that it expects as
+input. The string that we send to the server starting with "GET" is in
+HTTP syntax. In this case, we simply request each specified document.
+Yes, we really are making a new connection for each document, even though
+it's the same host. That's the way you always used to have to speak HTTP.
+Recent versions of web browsers may request that the remote server leave
+the connection open a little while, but the server doesn't have to honor
+such a request.
+
+Here's an example of running that program, which we'll call I<webget>:
+
+ % webget www.perl.com /guanaco.html
+ HTTP/1.1 404 File Not Found
+ Date: Thu, 08 May 1997 18:02:32 GMT
+ Server: Apache/1.2b6
+ Connection: close
+ Content-type: text/html
+
+ <HEAD><TITLE>404 File Not Found</TITLE></HEAD>
+ <BODY><H1>File Not Found</H1>
+ The requested URL /guanaco.html was not found on this server.<P>
+ </BODY>
+
+Ok, so that's not very interesting, because it didn't find that
+particular document. But a long response wouldn't have fit on this page.
+
+For a more fully-featured version of this program, you should look to
+the I<lwp-request> program included with the LWP modules from CPAN.
+
+=head2 Interactive Client with IO::Socket
+
+Well, that's all fine if you want to send one command and get one answer,
+but what about setting up something fully interactive, somewhat like
+the way I<telnet> works? That way you can type a line, get the answer,
+type a line, get the answer, etc.
+
+This client is more complicated than the two we've done so far, but if
+you're on a system that supports the powerful C<fork> call, the solution
+isn't that rough. Once you've made the connection to whatever service
+you'd like to chat with, call C<fork> to clone your process. Each of
+these two identical process has a very simple job to do: the parent
+copies everything from the socket to standard output, while the child
+simultaneously copies everything from standard input to the socket.
+To accomplish the same thing using just one process would be I<much>
+harder, because it's easier to code two processes to do one thing than it
+is to code one process to do two things. (This keep-it-simple principle
+a cornerstones of the Unix philosophy, and good software engineering as
+well, which is probably why it's spread to other systems.)
+
+Here's the code:
+
+ #!/usr/bin/perl -w
+ use strict;
+ use IO::Socket;
+ my ($host, $port, $kidpid, $handle, $line);
+
+ unless (@ARGV == 2) { die "usage: $0 host port" }
+ ($host, $port) = @ARGV;
+
+ # create a tcp connection to the specified host and port
+ $handle = IO::Socket::INET->new(Proto => "tcp",
+ PeerAddr => $host,
+ PeerPort => $port)
+ or die "can't connect to port $port on $host: $!";
+
+ $handle->autoflush(1); # so output gets there right away
+ print STDERR "[Connected to $host:$port]\n";
+
+ # split the program into two processes, identical twins
+ die "can't fork: $!" unless defined($kidpid = fork());
+
+ # the if{} block runs only in the parent process
+ if ($kidpid) {
+ # copy the socket to standard output
+ while (defined ($line = <$handle>)) {
+ print STDOUT $line;
+ }
+ kill("TERM", $kidpid); # send SIGTERM to child
+ }
+ # the else{} block runs only in the child process
+ else {
+ # copy standard input to the socket
+ while (defined ($line = <STDIN>)) {
+ print $handle $line;
+ }
+ }
+
+The C<kill> function in the parent's C<if> block is there to send a
+signal to our child process (current running in the C<else> block)
+as soon as the remote server has closed its end of the connection.
+
+If the remote server sends data a byte at time, and you need that
+data immediately without waiting for a newline (which might not happen),
+you may wish to replace the C<while> loop in the parent with the
+following:
+
+ my $byte;
+ while (sysread($handle, $byte, 1) == 1) {
+ print STDOUT $byte;
+ }
+
+Making a system call for each byte you want to read is not very efficient
+(to put it mildly) but is the simplest to explain and works reasonably
+well.
+
+=head1 TCP Servers with IO::Socket
+
+As always, setting up a server is little bit more involved than running a client.
+The model is that the server creates a special kind of socket that
+does nothing but listen on a particular port for incoming connections.
+It does this by calling the C<IO::Socket::INET-E<gt>new()> method with
+slightly different arguments than the client did.
+
+=over
+
+=item Proto
+
+This is which protocol to use. Like our clients, we'll
+still specify C<"tcp"> here.
+
+=item LocalPort
+
+We specify a local
+port in the C<LocalPort> argument, which we didn't do for the client.
+This is service name or port number for which you want to be the
+server. (Under Unix, ports under 1024 are restricted to the
+superuser.) In our sample, we'll use port 9000, but you can use
+any port that's not currently in use on your system. If you try
+to use one already in used, you'll get an "Address already in use"
+message. Under Unix, the C<netstat -a> command will show
+which services current have servers.
+
+=item Listen
+
+The C<Listen> parameter is set to the maximum number of
+pending connections we can accept until we turn away incoming clients.
+Think of it as a call-waiting queue for your telephone.
+The low-level Socket module has a special symbol for the system maximum, which
+is SOMAXCONN.
+
+=item Reuse
+
+The C<Reuse> parameter is needed so that we restart our server
+manually without waiting a few minutes to allow system buffers to
+clear out.
+
+=back
+
+Once the generic server socket has been created using the parameters
+listed above, the server then waits for a new client to connect
+to it. The server blocks in the C<accept> method, which eventually an
+bidirectional connection to the remote client. (Make sure to autoflush
+this handle to circumvent buffering.)
+
+To add to user-friendliness, our server prompts the user for commands.
+Most servers don't do this. Because of the prompt without a newline,
+you'll have to use the C<sysread> variant of the interactive client above.
+
+This server accepts one of five different commands, sending output
+back to the client. Note that unlike most network servers, this one
+only handles one incoming client at a time. Multithreaded servers are
+covered in Chapter 6 of the Camel as well as later in this manpage.
+
+Here's the code. We'll
+
+ #!/usr/bin/perl -w
+ use IO::Socket;
+ use Net::hostent; # for OO version of gethostbyaddr
+
+ $PORT = 9000; # pick something not in use
+
+ $server = IO::Socket::INET->new( Proto => 'tcp',
+ LocalPort => $PORT,
+ Listen => SOMAXCONN,
+ Reuse => 1);
+
+ die "can't setup server" unless $server;
+ print "[Server $0 accepting clients]\n";
+
+ while ($client = $server->accept()) {
+ $client->autoflush(1);
+ print $client "Welcome to $0; type help for command list.\n";
+ $hostinfo = gethostbyaddr($client->peeraddr);
+ printf "[Connect from %s]\n", $hostinfo->name || $client->peerhost;
+ print $client "Command? ";
+ while ( <$client>) {
+ next unless /\S/; # blank line
+ if (/quit|exit/i) { last; }
+ elsif (/date|time/i) { printf $client "%s\n", scalar localtime; }
+ elsif (/who/i ) { print $client `who 2>&1`; }
+ elsif (/cookie/i ) { print $client `/usr/games/fortune 2>&1`; }
+ elsif (/motd/i ) { print $client `cat /etc/motd 2>&1`; }
+ else {
+ print $client "Commands: quit date who cookie motd\n";
+ }
+ } continue {
+ print $client "Command? ";
+ }
+ close $client;
+ }
+
+=head1 UDP: Message Passing
+
+Another kind of client-server setup is one that uses not connections, but
+messages. UDP communications involve much lower overhead but also provide
+less reliability, as there are no promises that messages will arrive at
+all, let alone in order and unmangled. Still, UDP offers some advantages
+over TCP, including being able to "broadcast" or "multicast" to a whole
+bunch of destination hosts at once (usually on your local subnet). If you
+find yourself overly concerned about reliability and start building checks
+into your message system, then you probably should use just TCP to start
+with.
+
+Here's a UDP program similar to the sample Internet TCP client given
+earlier. However, instead of checking one host at a time, the UDP version
+will check many of them asynchronously by simulating a multicast and then
+using select() to do a timed-out wait for I/O. To do something similar
+with TCP, you'd have to use a different socket handle for each host.
+
+ #!/usr/bin/perl -w
+ use strict;
+ use Socket;
+ use Sys::Hostname;
+
+ my ( $count, $hisiaddr, $hispaddr, $histime,
+ $host, $iaddr, $paddr, $port, $proto,
+ $rin, $rout, $rtime, $SECS_of_70_YEARS);
+
+ $SECS_of_70_YEARS = 2208988800;
+
+ $iaddr = gethostbyname(hostname());
+ $proto = getprotobyname('udp');
+ $port = getservbyname('time', 'udp');
+ $paddr = sockaddr_in(0, $iaddr); # 0 means let kernel pick
+
+ socket(SOCKET, PF_INET, SOCK_DGRAM, $proto) || die "socket: $!";
+ bind(SOCKET, $paddr) || die "bind: $!";
+
+ $| = 1;
+ printf "%-12s %8s %s\n", "localhost", 0, scalar localtime time;
+ $count = 0;
+ for $host (@ARGV) {
+ $count++;
+ $hisiaddr = inet_aton($host) || die "unknown host";
+ $hispaddr = sockaddr_in($port, $hisiaddr);
+ defined(send(SOCKET, 0, 0, $hispaddr)) || die "send $host: $!";
+ }
+
+ $rin = '';
+ vec($rin, fileno(SOCKET), 1) = 1;
+
+ # timeout after 10.0 seconds
+ while ($count && select($rout = $rin, undef, undef, 10.0)) {
+ $rtime = '';
+ ($hispaddr = recv(SOCKET, $rtime, 4, 0)) || die "recv: $!";
+ ($port, $hisiaddr) = sockaddr_in($hispaddr);
+ $host = gethostbyaddr($hisiaddr, AF_INET);
+ $histime = unpack("N", $rtime) - $SECS_of_70_YEARS ;
+ printf "%-12s ", $host;
+ printf "%8d %s\n", $histime - time, scalar localtime($histime);
+ $count--;
+ }
+
+=head1 SysV IPC
+
+While System V IPC isn't so widely used as sockets, it still has some
+interesting uses. You can't, however, effectively use SysV IPC or
+Berkeley mmap() to have shared memory so as to share a variable amongst
+several processes. That's because Perl would reallocate your string when
+you weren't wanting it to.
+
+Here's a small example showing shared memory usage.
+
+ use IPC::SysV qw(IPC_PRIVATE IPC_RMID S_IRWXU S_IRWXG S_IRWXO);
+
+ $size = 2000;
+ $key = shmget(IPC_PRIVATE, $size, S_IRWXU|S_IRWXG|S_IRWXO) || die "$!";
+ print "shm key $key\n";
+
+ $message = "Message #1";
+ shmwrite($key, $message, 0, 60) || die "$!";
+ print "wrote: '$message'\n";
+ shmread($key, $buff, 0, 60) || die "$!";
+ print "read : '$buff'\n";
+
+ # the buffer of shmread is zero-character end-padded.
+ substr($buff, index($buff, "\0")) = '';
+ print "un" unless $buff eq $message;
+ print "swell\n";
+
+ print "deleting shm $key\n";
+ shmctl($key, IPC_RMID, 0) || die "$!";
+
+Here's an example of a semaphore:
+
+ use IPC::SysV qw(IPC_CREAT);
+
+ $IPC_KEY = 1234;
+ $key = semget($IPC_KEY, 10, 0666 | IPC_CREAT ) || die "$!";
+ print "shm key $key\n";
+
+Put this code in a separate file to be run in more than one process.
+Call the file F<take>:
+
+ # create a semaphore
+
+ $IPC_KEY = 1234;
+ $key = semget($IPC_KEY, 0 , 0 );
+ die if !defined($key);
+
+ $semnum = 0;
+ $semflag = 0;
+
+ # 'take' semaphore
+ # wait for semaphore to be zero
+ $semop = 0;
+ $opstring1 = pack("sss", $semnum, $semop, $semflag);
+
+ # Increment the semaphore count
+ $semop = 1;
+ $opstring2 = pack("sss", $semnum, $semop, $semflag);
+ $opstring = $opstring1 . $opstring2;
+
+ semop($key,$opstring) || die "$!";
+
+Put this code in a separate file to be run in more than one process.
+Call this file F<give>:
+
+ # 'give' the semaphore
+ # run this in the original process and you will see
+ # that the second process continues
+
+ $IPC_KEY = 1234;
+ $key = semget($IPC_KEY, 0, 0);
+ die if !defined($key);
+
+ $semnum = 0;
+ $semflag = 0;
+
+ # Decrement the semaphore count
+ $semop = -1;
+ $opstring = pack("sss", $semnum, $semop, $semflag);
+
+ semop($key,$opstring) || die "$!";
+
+The SysV IPC code above was written long ago, and it's definitely
+clunky looking. For a more modern look, see the IPC::SysV module
+which is included with Perl starting from Perl 5.005.
+
+=head1 NOTES
+
+Most of these routines quietly but politely return C<undef> when they
+fail instead of causing your program to die right then and there due to
+an uncaught exception. (Actually, some of the new I<Socket> conversion
+functions croak() on bad arguments.) It is therefore essential to
+check return values from these functions. Always begin your socket
+programs this way for optimal success, and don't forget to add B<-T>
+taint checking flag to the #! line for servers:
+
+ #!/usr/bin/perl -Tw
+ use strict;
+ use sigtrap;
+ use Socket;
+
+=head1 BUGS
+
+All these routines create system-specific portability problems. As noted
+elsewhere, Perl is at the mercy of your C libraries for much of its system
+behaviour. It's probably safest to assume broken SysV semantics for
+signals and to stick with simple TCP and UDP socket operations; e.g., don't
+try to pass open file descriptors over a local UDP datagram socket if you
+want your code to stand a chance of being portable.
+
+As mentioned in the signals section, because few vendors provide C
+libraries that are safely re-entrant, the prudent programmer will do
+little else within a handler beyond setting a numeric variable that
+already exists; or, if locked into a slow (restarting) system call,
+using die() to raise an exception and longjmp(3) out. In fact, even
+these may in some cases cause a core dump. It's probably best to avoid
+signals except where they are absolutely inevitable. This
+will be addressed in a future release of Perl.
+
+=head1 AUTHOR
+
+Tom Christiansen, with occasional vestiges of Larry Wall's original
+version and suggestions from the Perl Porters.
+
+=head1 SEE ALSO
+
+There's a lot more to networking than this, but this should get you
+started.
+
+For intrepid programmers, the indispensable textbook is I<Unix Network
+Programming> by W. Richard Stevens (published by Addison-Wesley). Note
+that most books on networking address networking from the perspective of
+a C programmer; translation to Perl is left as an exercise for the reader.
+
+The IO::Socket(3) manpage describes the object library, and the Socket(3)
+manpage describes the low-level interface to sockets. Besides the obvious
+functions in L<perlfunc>, you should also check out the F<modules> file
+at your nearest CPAN site. (See L<perlmodlib> or best yet, the F<Perl
+FAQ> for a description of what CPAN is and where to get it.)
+
+Section 5 of the F<modules> file is devoted to "Networking, Device Control
+(modems), and Interprocess Communication", and contains numerous unbundled
+modules numerous networking modules, Chat and Expect operations, CGI
+programming, DCE, FTP, IPC, NNTP, Proxy, Ptty, RPC, SNMP, SMTP, Telnet,
+Threads, and ToolTalk--just to name a few.
diff --git a/contrib/perl5/pod/perllocale.pod b/contrib/perl5/pod/perllocale.pod
new file mode 100644
index 000000000000..4401be205354
--- /dev/null
+++ b/contrib/perl5/pod/perllocale.pod
@@ -0,0 +1,976 @@
+=head1 NAME
+
+perllocale - Perl locale handling (internationalization and localization)
+
+=head1 DESCRIPTION
+
+Perl supports language-specific notions of data such as "is this
+a letter", "what is the uppercase equivalent of this letter", and
+"which of these letters comes first". These are important issues,
+especially for languages other than English--but also for English: it
+would be naE<iuml>ve to imagine that C<A-Za-z> defines all the "letters"
+needed to write in English. Perl is also aware that some character other
+than '.' may be preferred as a decimal point, and that output date
+representations may be language-specific. The process of making an
+application take account of its users' preferences in such matters is
+called B<internationalization> (often abbreviated as B<i18n>); telling
+such an application about a particular set of preferences is known as
+B<localization> (B<l10n>).
+
+Perl can understand language-specific data via the standardized (ISO C,
+XPG4, POSIX 1.c) method called "the locale system". The locale system is
+controlled per application using one pragma, one function call, and
+several environment variables.
+
+B<NOTE>: This feature is new in Perl 5.004, and does not apply unless an
+application specifically requests it--see L<Backward compatibility>.
+The one exception is that write() now B<always> uses the current locale
+- see L<"NOTES">.
+
+=head1 PREPARING TO USE LOCALES
+
+If Perl applications are to understand and present your data
+correctly according a locale of your choice, B<all> of the following
+must be true:
+
+=over 4
+
+=item *
+
+B<Your operating system must support the locale system>. If it does,
+you should find that the setlocale() function is a documented part of
+its C library.
+
+=item *
+
+B<Definitions for locales that you use must be installed>. You, or
+your system administrator, must make sure that this is the case. The
+available locales, the location in which they are kept, and the manner
+in which they are installed all vary from system to system. Some systems
+provide only a few, hard-wired locales and do not allow more to be
+added. Others allow you to add "canned" locales provided by the system
+supplier. Still others allow you or the system administrator to define
+and add arbitrary locales. (You may have to ask your supplier to
+provide canned locales that are not delivered with your operating
+system.) Read your system documentation for further illumination.
+
+=item *
+
+B<Perl must believe that the locale system is supported>. If it does,
+C<perl -V:d_setlocale> will say that the value for C<d_setlocale> is
+C<define>.
+
+=back
+
+If you want a Perl application to process and present your data
+according to a particular locale, the application code should include
+the S<C<use locale>> pragma (see L<The use locale pragma>) where
+appropriate, and B<at least one> of the following must be true:
+
+=over 4
+
+=item *
+
+B<The locale-determining environment variables (see L<"ENVIRONMENT">)
+must be correctly set up> at the time the application is started, either
+by yourself or by whoever set up your system account.
+
+=item *
+
+B<The application must set its own locale> using the method described in
+L<The setlocale function>.
+
+=back
+
+=head1 USING LOCALES
+
+=head2 The use locale pragma
+
+By default, Perl ignores the current locale. The S<C<use locale>>
+pragma tells Perl to use the current locale for some operations:
+
+=over 4
+
+=item *
+
+B<The comparison operators> (C<lt>, C<le>, C<cmp>, C<ge>, and C<gt>) and
+the POSIX string collation functions strcoll() and strxfrm() use
+C<LC_COLLATE>. sort() is also affected if used without an
+explicit comparison function, because it uses C<cmp> by default.
+
+B<Note:> C<eq> and C<ne> are unaffected by locale: they always
+perform a byte-by-byte comparison of their scalar operands. What's
+more, if C<cmp> finds that its operands are equal according to the
+collation sequence specified by the current locale, it goes on to
+perform a byte-by-byte comparison, and only returns I<0> (equal) if the
+operands are bit-for-bit identical. If you really want to know whether
+two strings--which C<eq> and C<cmp> may consider different--are equal
+as far as collation in the locale is concerned, see the discussion in
+L<Category LC_COLLATE: Collation>.
+
+=item *
+
+B<Regular expressions and case-modification functions> (uc(), lc(),
+ucfirst(), and lcfirst()) use C<LC_CTYPE>
+
+=item *
+
+B<The formatting functions> (printf(), sprintf() and write()) use
+C<LC_NUMERIC>
+
+=item *
+
+B<The POSIX date formatting function> (strftime()) uses C<LC_TIME>.
+
+=back
+
+C<LC_COLLATE>, C<LC_CTYPE>, and so on, are discussed further in L<LOCALE
+CATEGORIES>.
+
+The default behavior is restored with the S<C<no locale>> pragma, or
+upon reaching the end of block enclosing C<use locale>.
+
+The string result of any operation that uses locale
+information is tainted, as it is possible for a locale to be
+untrustworthy. See L<"SECURITY">.
+
+=head2 The setlocale function
+
+You can switch locales as often as you wish at run time with the
+POSIX::setlocale() function:
+
+ # This functionality not usable prior to Perl 5.004
+ require 5.004;
+
+ # Import locale-handling tool set from POSIX module.
+ # This example uses: setlocale -- the function call
+ # LC_CTYPE -- explained below
+ use POSIX qw(locale_h);
+
+ # query and save the old locale
+ $old_locale = setlocale(LC_CTYPE);
+
+ setlocale(LC_CTYPE, "fr_CA.ISO8859-1");
+ # LC_CTYPE now in locale "French, Canada, codeset ISO 8859-1"
+
+ setlocale(LC_CTYPE, "");
+ # LC_CTYPE now reset to default defined by LC_ALL/LC_CTYPE/LANG
+ # environment variables. See below for documentation.
+
+ # restore the old locale
+ setlocale(LC_CTYPE, $old_locale);
+
+The first argument of setlocale() gives the B<category>, the second the
+B<locale>. The category tells in what aspect of data processing you
+want to apply locale-specific rules. Category names are discussed in
+L<LOCALE CATEGORIES> and L<"ENVIRONMENT">. The locale is the name of a
+collection of customization information corresponding to a particular
+combination of language, country or territory, and codeset. Read on for
+hints on the naming of locales: not all systems name locales as in the
+example.
+
+If no second argument is provided and the category is something else
+than LC_ALL, the function returns a string naming the current locale
+for the category. You can use this value as the second argument in a
+subsequent call to setlocale().
+
+If no second argument is provided and the category is LC_ALL, the
+result is implementation-dependent. It may be a string of
+concatenated locales names (separator also implementation-dependent)
+or a single locale name. Please consult your L<setlocale(3)> for
+details.
+
+If a second argument is given and it corresponds to a valid locale,
+the locale for the category is set to that value, and the function
+returns the now-current locale value. You can then use this in yet
+another call to setlocale(). (In some implementations, the return
+value may sometimes differ from the value you gave as the second
+argument--think of it as an alias for the value you gave.)
+
+As the example shows, if the second argument is an empty string, the
+category's locale is returned to the default specified by the
+corresponding environment variables. Generally, this results in a
+return to the default that was in force when Perl started up: changes
+to the environment made by the application after startup may or may not
+be noticed, depending on your system's C library.
+
+If the second argument does not correspond to a valid locale, the locale
+for the category is not changed, and the function returns I<undef>.
+
+For further information about the categories, consult L<setlocale(3)>.
+
+=head2 Finding locales
+
+For locales available in your system, consult also L<setlocale(3)> to
+see whether it leads to the list of available locales (search for the
+I<SEE ALSO> section). If that fails, try the following command lines:
+
+ locale -a
+
+ nlsinfo
+
+ ls /usr/lib/nls/loc
+
+ ls /usr/lib/locale
+
+ ls /usr/lib/nls
+
+and see whether they list something resembling these
+
+ en_US.ISO8859-1 de_DE.ISO8859-1 ru_RU.ISO8859-5
+ en_US.iso88591 de_DE.iso88591 ru_RU.iso88595
+ en_US de_DE ru_RU
+ en de ru
+ english german russian
+ english.iso88591 german.iso88591 russian.iso88595
+ english.roman8 russian.koi8r
+
+Sadly, even though the calling interface for setlocale() has
+been standardized, names of locales and the directories where the
+configuration resides have not been. The basic form of the name is
+I<language_country/territory>B<.>I<codeset>, but the latter parts after
+I<language> are not always present. The I<language> and I<country> are
+usually from the standards B<ISO 3166> and B<ISO 639>, the two-letter
+abbreviations for the countries and the languages of the world,
+respectively. The I<codeset> part often mentions some B<ISO 8859>
+character set, the Latin codesets. For example, C<ISO 8859-1> is the
+so-called "Western codeset" that can be used to encode most Western
+European languages. Again, there are several ways to write even the
+name of that one standard. Lamentably.
+
+Two special locales are worth particular mention: "C" and "POSIX".
+Currently these are effectively the same locale: the difference is
+mainly that the first one is defined by the C standard, the second by
+the POSIX standard. They define the B<default locale> in which
+every program starts in the absence of locale information in its
+environment. (The I<default> default locale, if you will.) Its language
+is (American) English and its character codeset ASCII.
+
+B<NOTE>: Not all systems have the "POSIX" locale (not all systems are
+POSIX-conformant), so use "C" when you need explicitly to specify this
+default locale.
+
+=head2 LOCALE PROBLEMS
+
+You may encounter the following warning message at Perl startup:
+
+ perl: warning: Setting locale failed.
+ perl: warning: Please check that your locale settings:
+ LC_ALL = "En_US",
+ LANG = (unset)
+ are supported and installed on your system.
+ perl: warning: Falling back to the standard locale ("C").
+
+This means that your locale settings had LC_ALL set to "En_US" and
+LANG exists but has no value. Perl tried to believe you but could not.
+Instead, Perl gave up and fell back to the "C" locale, the default locale
+that is supposed to work no matter what. This usually means your locale
+settings were wrong, they mention locales your system has never heard
+of, or the locale installation in your system has problems (for example,
+some system files are broken or missing). There are quick and temporary
+fixes to these problems, as well as more thorough and lasting fixes.
+
+=head2 Temporarily fixing locale problems
+
+The two quickest fixes are either to render Perl silent about any
+locale inconsistencies or to run Perl under the default locale "C".
+
+Perl's moaning about locale problems can be silenced by setting the
+environment variable PERL_BADLANG to a non-zero value, for example
+"1". This method really just sweeps the problem under the carpet: you
+tell Perl to shut up even when Perl sees that something is wrong. Do
+not be surprised if later something locale-dependent misbehaves.
+
+Perl can be run under the "C" locale by setting the environment
+variable LC_ALL to "C". This method is perhaps a bit more civilized
+than the PERL_BADLANG approach, but setting LC_ALL (or
+other locale variables) may affect other programs as well, not just
+Perl. In particular, external programs run from within Perl will see
+these changes. If you make the new settings permanent (read on), all
+programs you run see the changes. See L<ENVIRONMENT> for for
+the full list of relevant environment variables and L<USING LOCALES>
+for their effects in Perl. Effects in other programs are
+easily deducible. For example, the variable LC_COLLATE may well affect
+your B<sort> program (or whatever the program that arranges `records'
+alphabetically in your system is called).
+
+You can test out changing these variables temporarily, and if the
+new settings seem to help, put those settings into your shell startup
+files. Consult your local documentation for the exact details. For in
+Bourne-like shells (B<sh>, B<ksh>, B<bash>, B<zsh>):
+
+ LC_ALL=en_US.ISO8859-1
+ export LC_ALL
+
+This assumes that we saw the locale "en_US.ISO8859-1" using the commands
+discussed above. We decided to try that instead of the above faulty
+locale "En_US"--and in Cshish shells (B<csh>, B<tcsh>)
+
+ setenv LC_ALL en_US.ISO8859-1
+
+If you do not know what shell you have, consult your local
+helpdesk or the equivalent.
+
+=head2 Permanently fixing locale problems
+
+The slower but superior fixes are when you may be able to yourself
+fix the misconfiguration of your own environment variables. The
+mis(sing)configuration of the whole system's locales usually requires
+the help of your friendly system administrator.
+
+First, see earlier in this document about L<Finding locales>. That tells
+how to find which locales are really supported--and more importantly,
+installed--on your system. In our example error message, environment
+variables affecting the locale are listed in the order of decreasing
+importance (and unset variables do not matter). Therefore, having
+LC_ALL set to "En_US" must have been the bad choice, as shown by the
+error message. First try fixing locale settings listed first.
+
+Second, if using the listed commands you see something B<exactly>
+(prefix matches do not count and case usually counts) like "En_US"
+without the quotes, then you should be okay because you are using a
+locale name that should be installed and available in your system.
+In this case, see L<Fixing system locale configuration>.
+
+=head2 Permanently fixing your locale configuration
+
+This is when you see something like:
+
+ perl: warning: Please check that your locale settings:
+ LC_ALL = "En_US",
+ LANG = (unset)
+ are supported and installed on your system.
+
+but then cannot see that "En_US" listed by the above-mentioned
+commands. You may see things like "en_US.ISO8859-1", but that isn't
+the same. In this case, try running under a locale
+that you can list and which somehow matches what you tried. The
+rules for matching locale names are a bit vague because
+standardization is weak in this area. See again the L<Finding
+locales> about general rules.
+
+=head2 Permanently fixing system locale configuration
+
+Contact a system administrator (preferably your own) and report the exact
+error message you get, and ask them to read this same documentation you
+are now reading. They should be able to check whether there is something
+wrong with the locale configuration of the system. The L<Finding locales>
+section is unfortunately a bit vague about the exact commands and places
+because these things are not that standardized.
+
+=head2 The localeconv function
+
+The POSIX::localeconv() function allows you to get particulars of the
+locale-dependent numeric formatting information specified by the current
+C<LC_NUMERIC> and C<LC_MONETARY> locales. (If you just want the name of
+the current locale for a particular category, use POSIX::setlocale()
+with a single parameter--see L<The setlocale function>.)
+
+ use POSIX qw(locale_h);
+
+ # Get a reference to a hash of locale-dependent info
+ $locale_values = localeconv();
+
+ # Output sorted list of the values
+ for (sort keys %$locale_values) {
+ printf "%-20s = %s\n", $_, $locale_values->{$_}
+ }
+
+localeconv() takes no arguments, and returns B<a reference to> a hash.
+The keys of this hash are variable names for formatting, such as
+C<decimal_point> and C<thousands_sep>. The values are the
+corresponding, er, values. See L<POSIX (3)/localeconv> for a longer
+example listing the categories an implementation might be expected to
+provide; some provide more and others fewer. You don't need an
+explicit C<use locale>, because localeconv() always observes the
+current locale.
+
+Here's a simple-minded example program that rewrites its command-line
+parameters as integers correctly formatted in the current locale:
+
+ # See comments in previous example
+ require 5.004;
+ use POSIX qw(locale_h);
+
+ # Get some of locale's numeric formatting parameters
+ my ($thousands_sep, $grouping) =
+ @{localeconv()}{'thousands_sep', 'grouping'};
+
+ # Apply defaults if values are missing
+ $thousands_sep = ',' unless $thousands_sep;
+
+ # grouping and mon_grouping are packed lists
+ # of small integers (characters) telling the
+ # grouping (thousand_seps and mon_thousand_seps
+ # being the group dividers) of numbers and
+ # monetary quantities. The integers' meanings:
+ # 255 means no more grouping, 0 means repeat
+ # the previous grouping, 1-254 means use that
+ # as the current grouping. Grouping goes from
+ # right to left (low to high digits). In the
+ # below we cheat slightly by never using anything
+ # else than the first grouping (whatever that is).
+ if ($grouping) {
+ @grouping = unpack("C*", $grouping);
+ } else {
+ @grouping = (3);
+ }
+
+ # Format command line params for current locale
+ for (@ARGV) {
+ $_ = int; # Chop non-integer part
+ 1 while
+ s/(\d)(\d{$grouping[0]}($|$thousands_sep))/$1$thousands_sep$2/;
+ print "$_";
+ }
+ print "\n";
+
+=head1 LOCALE CATEGORIES
+
+The following subsections describe basic locale categories. Beyond these,
+some combination categories allow manipulation of more than one
+basic category at a time. See L<"ENVIRONMENT"> for a discussion of these.
+
+=head2 Category LC_COLLATE: Collation
+
+In the scope of S<C<use locale>>, Perl looks to the C<LC_COLLATE>
+environment variable to determine the application's notions on collation
+(ordering) of characters. For example, 'b' follows 'a' in Latin
+alphabets, but where do 'E<aacute>' and 'E<aring>' belong? And while
+'color' follows 'chocolate' in English, what about in Spanish?
+
+The following collations all make sense and you may meet any of them
+if you "use locale".
+
+ A B C D E a b c d e
+ A a B b C c D d D e
+ a A b B c C d D e E
+ a b c d e A B C D E
+
+Here is a code snippet to tell what alphanumeric
+characters are in the current locale, in that locale's order:
+
+ use locale;
+ print +(sort grep /\w/, map { chr() } 0..255), "\n";
+
+Compare this with the characters that you see and their order if you
+state explicitly that the locale should be ignored:
+
+ no locale;
+ print +(sort grep /\w/, map { chr() } 0..255), "\n";
+
+This machine-native collation (which is what you get unless S<C<use
+locale>> has appeared earlier in the same block) must be used for
+sorting raw binary data, whereas the locale-dependent collation of the
+first example is useful for natural text.
+
+As noted in L<USING LOCALES>, C<cmp> compares according to the current
+collation locale when C<use locale> is in effect, but falls back to a
+byte-by-byte comparison for strings that the locale says are equal. You
+can use POSIX::strcoll() if you don't want this fall-back:
+
+ use POSIX qw(strcoll);
+ $equal_in_locale =
+ !strcoll("space and case ignored", "SpaceAndCaseIgnored");
+
+$equal_in_locale will be true if the collation locale specifies a
+dictionary-like ordering that ignores space characters completely and
+which folds case.
+
+If you have a single string that you want to check for "equality in
+locale" against several others, you might think you could gain a little
+efficiency by using POSIX::strxfrm() in conjunction with C<eq>:
+
+ use POSIX qw(strxfrm);
+ $xfrm_string = strxfrm("Mixed-case string");
+ print "locale collation ignores spaces\n"
+ if $xfrm_string eq strxfrm("Mixed-casestring");
+ print "locale collation ignores hyphens\n"
+ if $xfrm_string eq strxfrm("Mixedcase string");
+ print "locale collation ignores case\n"
+ if $xfrm_string eq strxfrm("mixed-case string");
+
+strxfrm() takes a string and maps it into a transformed string for use
+in byte-by-byte comparisons against other transformed strings during
+collation. "Under the hood", locale-affected Perl comparison operators
+call strxfrm() for both operands, then do a byte-by-byte
+comparison of the transformed strings. By calling strxfrm() explicitly
+and using a non locale-affected comparison, the example attempts to save
+a couple of transformations. But in fact, it doesn't save anything: Perl
+magic (see L<perlguts/Magic Variables>) creates the transformed version of a
+string the first time it's needed in a comparison, then keeps this version around
+in case it's needed again. An example rewritten the easy way with
+C<cmp> runs just about as fast. It also copes with null characters
+embedded in strings; if you call strxfrm() directly, it treats the first
+null it finds as a terminator. don't expect the transformed strings
+it produces to be portable across systems--or even from one revision
+of your operating system to the next. In short, don't call strxfrm()
+directly: let Perl do it for you.
+
+Note: C<use locale> isn't shown in some of these examples because it isn't
+needed: strcoll() and strxfrm() exist only to generate locale-dependent
+results, and so always obey the current C<LC_COLLATE> locale.
+
+=head2 Category LC_CTYPE: Character Types
+
+In the scope of S<C<use locale>>, Perl obeys the C<LC_CTYPE> locale
+setting. This controls the application's notion of which characters are
+alphabetic. This affects Perl's C<\w> regular expression metanotation,
+which stands for alphanumeric characters--that is, alphabetic and
+numeric characters. (Consult L<perlre> for more information about
+regular expressions.) Thanks to C<LC_CTYPE>, depending on your locale
+setting, characters like 'E<aelig>', 'E<eth>', 'E<szlig>', and
+'E<oslash>' may be understood as C<\w> characters.
+
+The C<LC_CTYPE> locale also provides the map used in transliterating
+characters between lower and uppercase. This affects the case-mapping
+functions--lc(), lcfirst, uc(), and ucfirst(); case-mapping
+interpolation with C<\l>, C<\L>, C<\u>, or C<\U> in double-quoted strings
+and C<s///> substitutions; and case-independent regular expression
+pattern matching using the C<i> modifier.
+
+Finally, C<LC_CTYPE> affects the POSIX character-class test
+functions--isalpha(), islower(), and so on. For example, if you move
+from the "C" locale to a 7-bit Scandinavian one, you may find--possibly
+to your surprise--that "|" moves from the ispunct() class to isalpha().
+
+B<Note:> A broken or malicious C<LC_CTYPE> locale definition may result
+in clearly ineligible characters being considered to be alphanumeric by
+your application. For strict matching of (mundane) letters and
+digits--for example, in command strings--locale-aware applications
+should use C<\w> inside a C<no locale> block. See L<"SECURITY">.
+
+=head2 Category LC_NUMERIC: Numeric Formatting
+
+In the scope of S<C<use locale>>, Perl obeys the C<LC_NUMERIC> locale
+information, which controls an application's idea of how numbers should
+be formatted for human readability by the printf(), sprintf(), and
+write() functions. String-to-numeric conversion by the POSIX::strtod()
+function is also affected. In most implementations the only effect is to
+change the character used for the decimal point--perhaps from '.' to ','.
+These functions aren't aware of such niceties as thousands separation and
+so on. (See L<The localeconv function> if you care about these things.)
+
+Output produced by print() is B<never> affected by the
+current locale: it is independent of whether C<use locale> or C<no
+locale> is in effect, and corresponds to what you'd get from printf()
+in the "C" locale. The same is true for Perl's internal conversions
+between numeric and string formats:
+
+ use POSIX qw(strtod);
+ use locale;
+
+ $n = 5/2; # Assign numeric 2.5 to $n
+
+ $a = " $n"; # Locale-independent conversion to string
+
+ print "half five is $n\n"; # Locale-independent output
+
+ printf "half five is %g\n", $n; # Locale-dependent output
+
+ print "DECIMAL POINT IS COMMA\n"
+ if $n == (strtod("2,5"))[0]; # Locale-dependent conversion
+
+=head2 Category LC_MONETARY: Formatting of monetary amounts
+
+The C standard defines the C<LC_MONETARY> category, but no function
+that is affected by its contents. (Those with experience of standards
+committees will recognize that the working group decided to punt on the
+issue.) Consequently, Perl takes no notice of it. If you really want
+to use C<LC_MONETARY>, you can query its contents--see L<The localeconv
+function>--and use the information that it returns in your application's
+own formatting of currency amounts. However, you may well find that
+the information, voluminous and complex though it may be, still does not
+quite meet your requirements: currency formatting is a hard nut to crack.
+
+=head2 LC_TIME
+
+Output produced by POSIX::strftime(), which builds a formatted
+human-readable date/time string, is affected by the current C<LC_TIME>
+locale. Thus, in a French locale, the output produced by the C<%B>
+format element (full month name) for the first month of the year would
+be "janvier". Here's how to get a list of long month names in the
+current locale:
+
+ use POSIX qw(strftime);
+ for (0..11) {
+ $long_month_name[$_] =
+ strftime("%B", 0, 0, 0, 1, $_, 96);
+ }
+
+Note: C<use locale> isn't needed in this example: as a function that
+exists only to generate locale-dependent results, strftime() always
+obeys the current C<LC_TIME> locale.
+
+=head2 Other categories
+
+The remaining locale category, C<LC_MESSAGES> (possibly supplemented
+by others in particular implementations) is not currently used by
+Perl--except possibly to affect the behavior of library functions called
+by extensions outside the standard Perl distribution.
+
+=head1 SECURITY
+
+Although the main discussion of Perl security issues can be found in
+L<perlsec>, a discussion of Perl's locale handling would be incomplete
+if it did not draw your attention to locale-dependent security issues.
+Locales--particularly on systems that allow unprivileged users to
+build their own locales--are untrustworthy. A malicious (or just plain
+broken) locale can make a locale-aware application give unexpected
+results. Here are a few possibilities:
+
+=over 4
+
+=item *
+
+Regular expression checks for safe file names or mail addresses using
+C<\w> may be spoofed by an C<LC_CTYPE> locale that claims that
+characters such as "E<gt>" and "|" are alphanumeric.
+
+=item *
+
+String interpolation with case-mapping, as in, say, C<$dest =
+"C:\U$name.$ext">, may produce dangerous results if a bogus LC_CTYPE
+case-mapping table is in effect.
+
+=item *
+
+If the decimal point character in the C<LC_NUMERIC> locale is
+surreptitiously changed from a dot to a comma, C<sprintf("%g",
+0.123456e3)> produces a string result of "123,456". Many people would
+interpret this as one hundred and twenty-three thousand, four hundred
+and fifty-six.
+
+=item *
+
+A sneaky C<LC_COLLATE> locale could result in the names of students with
+"D" grades appearing ahead of those with "A"s.
+
+=item *
+
+An application that takes the trouble to use information in
+C<LC_MONETARY> may format debits as if they were credits and vice versa
+if that locale has been subverted. Or it might make payments in US
+dollars instead of Hong Kong dollars.
+
+=item *
+
+The date and day names in dates formatted by strftime() could be
+manipulated to advantage by a malicious user able to subvert the
+C<LC_DATE> locale. ("Look--it says I wasn't in the building on
+Sunday.")
+
+=back
+
+Such dangers are not peculiar to the locale system: any aspect of an
+application's environment which may be modified maliciously presents
+similar challenges. Similarly, they are not specific to Perl: any
+programming language that allows you to write programs that take
+account of their environment exposes you to these issues.
+
+Perl cannot protect you from all possibilities shown in the
+examples--there is no substitute for your own vigilance--but, when
+C<use locale> is in effect, Perl uses the tainting mechanism (see
+L<perlsec>) to mark string results that become locale-dependent, and
+which may be untrustworthy in consequence. Here is a summary of the
+tainting behavior of operators and functions that may be affected by
+the locale:
+
+=over 4
+
+=item B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>):
+
+Scalar true/false (or less/equal/greater) result is never tainted.
+
+=item B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or C<\U>)
+
+Result string containing interpolated material is tainted if
+C<use locale> is in effect.
+
+=item B<Matching operator> (C<m//>):
+
+Scalar true/false result never tainted.
+
+Subpatterns, either delivered as a list-context result or as $1 etc.
+are tainted if C<use locale> is in effect, and the subpattern regular
+expression contains C<\w> (to match an alphanumeric character), C<\W>
+(non-alphanumeric character), C<\s> (white-space character), or C<\S>
+(non white-space character). The matched-pattern variable, $&, $`
+(pre-match), $' (post-match), and $+ (last match) are also tainted if
+C<use locale> is in effect and the regular expression contains C<\w>,
+C<\W>, C<\s>, or C<\S>.
+
+=item B<Substitution operator> (C<s///>):
+
+Has the same behavior as the match operator. Also, the left
+operand of C<=~> becomes tainted when C<use locale> in effect
+if modified as a result of a substitution based on a regular
+expression match involving C<\w>, C<\W>, C<\s>, or C<\S>; or of
+case-mapping with C<\l>, C<\L>,C<\u> or C<\U>.
+
+=item B<In-memory formatting function> (sprintf()):
+
+Result is tainted if "use locale" is in effect.
+
+=item B<Output formatting functions> (printf() and write()):
+
+Success/failure result is never tainted.
+
+=item B<Case-mapping functions> (lc(), lcfirst(), uc(), ucfirst()):
+
+Results are tainted if C<use locale> is in effect.
+
+=item B<POSIX locale-dependent functions> (localeconv(), strcoll(),
+strftime(), strxfrm()):
+
+Results are never tainted.
+
+=item B<POSIX character class tests> (isalnum(), isalpha(), isdigit(),
+isgraph(), islower(), isprint(), ispunct(), isspace(), isupper(),
+isxdigit()):
+
+True/false results are never tainted.
+
+=back
+
+Three examples illustrate locale-dependent tainting.
+The first program, which ignores its locale, won't run: a value taken
+directly from the command line may not be used to name an output file
+when taint checks are enabled.
+
+ #/usr/local/bin/perl -T
+ # Run with taint checking
+
+ # Command line sanity check omitted...
+ $tainted_output_file = shift;
+
+ open(F, ">$tainted_output_file")
+ or warn "Open of $untainted_output_file failed: $!\n";
+
+The program can be made to run by "laundering" the tainted value through
+a regular expression: the second example--which still ignores locale
+information--runs, creating the file named on its command line
+if it can.
+
+ #/usr/local/bin/perl -T
+
+ $tainted_output_file = shift;
+ $tainted_output_file =~ m%[\w/]+%;
+ $untainted_output_file = $&;
+
+ open(F, ">$untainted_output_file")
+ or warn "Open of $untainted_output_file failed: $!\n";
+
+Compare this with a similar but locale-aware program:
+
+ #/usr/local/bin/perl -T
+
+ $tainted_output_file = shift;
+ use locale;
+ $tainted_output_file =~ m%[\w/]+%;
+ $localized_output_file = $&;
+
+ open(F, ">$localized_output_file")
+ or warn "Open of $localized_output_file failed: $!\n";
+
+This third program fails to run because $& is tainted: it is the result
+of a match involving C<\w> while C<use locale> is in effect.
+
+=head1 ENVIRONMENT
+
+=over 12
+
+=item PERL_BADLANG
+
+A string that can suppress Perl's warning about failed locale settings
+at startup. Failure can occur if the locale support in the operating
+system is lacking (broken) in some way--or if you mistyped the name of
+a locale when you set up your environment. If this environment variable
+is absent, or has a value that does not evaluate to integer zero--that
+is, "0" or ""--Perl will complain about locale setting failures.
+
+B<NOTE>: PERL_BADLANG only gives you a way to hide the warning message.
+The message tells about some problem in your system's locale support,
+and you should investigate what the problem is.
+
+=back
+
+The following environment variables are not specific to Perl: They are
+part of the standardized (ISO C, XPG4, POSIX 1.c) setlocale() method
+for controlling an application's opinion on data.
+
+=over 12
+
+=item LC_ALL
+
+C<LC_ALL> is the "override-all" locale environment variable. If
+set, it overrides all the rest of the locale environment variables.
+
+=item LC_CTYPE
+
+In the absence of C<LC_ALL>, C<LC_CTYPE> chooses the character type
+locale. In the absence of both C<LC_ALL> and C<LC_CTYPE>, C<LANG>
+chooses the character type locale.
+
+=item LC_COLLATE
+
+In the absence of C<LC_ALL>, C<LC_COLLATE> chooses the collation
+(sorting) locale. In the absence of both C<LC_ALL> and C<LC_COLLATE>,
+C<LANG> chooses the collation locale.
+
+=item LC_MONETARY
+
+In the absence of C<LC_ALL>, C<LC_MONETARY> chooses the monetary
+formatting locale. In the absence of both C<LC_ALL> and C<LC_MONETARY>,
+C<LANG> chooses the monetary formatting locale.
+
+=item LC_NUMERIC
+
+In the absence of C<LC_ALL>, C<LC_NUMERIC> chooses the numeric format
+locale. In the absence of both C<LC_ALL> and C<LC_NUMERIC>, C<LANG>
+chooses the numeric format.
+
+=item LC_TIME
+
+In the absence of C<LC_ALL>, C<LC_TIME> chooses the date and time
+formatting locale. In the absence of both C<LC_ALL> and C<LC_TIME>,
+C<LANG> chooses the date and time formatting locale.
+
+=item LANG
+
+C<LANG> is the "catch-all" locale environment variable. If it is set, it
+is used as the last resort after the overall C<LC_ALL> and the
+category-specific C<LC_...>.
+
+=back
+
+=head1 NOTES
+
+=head2 Backward compatibility
+
+Versions of Perl prior to 5.004 B<mostly> ignored locale information,
+generally behaving as if something similar to the C<"C"> locale were
+always in force, even if the program environment suggested otherwise
+(see L<The setlocale function>). By default, Perl still behaves this
+way for backward compatibility. If you want a Perl application to pay
+attention to locale information, you B<must> use the S<C<use locale>>
+pragma (see L<The use locale Pragma>) to instruct it to do so.
+
+Versions of Perl from 5.002 to 5.003 did use the C<LC_CTYPE>
+information if available; that is, C<\w> did understand what
+were the letters according to the locale environment variables.
+The problem was that the user had no control over the feature:
+if the C library supported locales, Perl used them.
+
+=head2 I18N:Collate obsolete
+
+In versions of Perl prior to 5.004, per-locale collation was possible
+using the C<I18N::Collate> library module. This module is now mildly
+obsolete and should be avoided in new applications. The C<LC_COLLATE>
+functionality is now integrated into the Perl core language: One can
+use locale-specific scalar data completely normally with C<use locale>,
+so there is no longer any need to juggle with the scalar references of
+C<I18N::Collate>.
+
+=head2 Sort speed and memory use impacts
+
+Comparing and sorting by locale is usually slower than the default
+sorting; slow-downs of two to four times have been observed. It will
+also consume more memory: once a Perl scalar variable has participated
+in any string comparison or sorting operation obeying the locale
+collation rules, it will take 3-15 times more memory than before. (The
+exact multiplier depends on the string's contents, the operating system
+and the locale.) These downsides are dictated more by the operating
+system's implementation of the locale system than by Perl.
+
+=head2 write() and LC_NUMERIC
+
+Formats are the only part of Perl that unconditionally use information
+from a program's locale; if a program's environment specifies an
+LC_NUMERIC locale, it is always used to specify the decimal point
+character in formatted output. Formatted output cannot be controlled by
+C<use locale> because the pragma is tied to the block structure of the
+program, and, for historical reasons, formats exist outside that block
+structure.
+
+=head2 Freely available locale definitions
+
+There is a large collection of locale definitions at
+C<ftp://dkuug.dk/i18n/WG15-collection>. You should be aware that it is
+unsupported, and is not claimed to be fit for any purpose. If your
+system allows installation of arbitrary locales, you may find the
+definitions useful as they are, or as a basis for the development of
+your own locales.
+
+=head2 I18n and l10n
+
+"Internationalization" is often abbreviated as B<i18n> because its first
+and last letters are separated by eighteen others. (You may guess why
+the internalin ... internaliti ... i18n tends to get abbreviated.) In
+the same way, "localization" is often abbreviated to B<l10n>.
+
+=head2 An imperfect standard
+
+Internationalization, as defined in the C and POSIX standards, can be
+criticized as incomplete, ungainly, and having too large a granularity.
+(Locales apply to a whole process, when it would arguably be more useful
+to have them apply to a single thread, window group, or whatever.) They
+also have a tendency, like standards groups, to divide the world into
+nations, when we all know that the world can equally well be divided
+into bankers, bikers, gamers, and so on. But, for now, it's the only
+standard we've got. This may be construed as a bug.
+
+=head1 BUGS
+
+=head2 Broken systems
+
+In certain systems, the operating system's locale support
+is broken and cannot be fixed or used by Perl. Such deficiencies can
+and will result in mysterious hangs and/or Perl core dumps when the
+C<use locale> is in effect. When confronted with such a system,
+please report in excruciating detail to <F<perlbug@perl.com>>, and
+complain to your vendor: bug fixes may exist for these problems
+in your operating system. Sometimes such bug fixes are called an
+operating system upgrade.
+
+=head1 SEE ALSO
+
+L<POSIX (3)/isalnum>
+
+L<POSIX (3)/isalpha>
+
+L<POSIX (3)/isdigit>
+
+L<POSIX (3)/isgraph>
+
+L<POSIX (3)/islower>
+
+L<POSIX (3)/isprint>,
+
+L<POSIX (3)/ispunct>
+
+L<POSIX (3)/isspace>
+
+L<POSIX (3)/isupper>,
+
+L<POSIX (3)/isxdigit>
+
+L<POSIX (3)/localeconv>
+
+L<POSIX (3)/setlocale>,
+
+L<POSIX (3)/strcoll>
+
+L<POSIX (3)/strftime>
+
+L<POSIX (3)/strtod>,
+
+L<POSIX (3)/strxfrm>
+
+=head1 HISTORY
+
+Jarkko Hietaniemi's original F<perli18n.pod> heavily hacked by Dominic
+Dunlop, assisted by the perl5-porters. Prose worked over a bit by
+Tom Christiansen.
+
+Last update: Thu Jun 11 08:44:13 MDT 1998
diff --git a/contrib/perl5/pod/perllol.pod b/contrib/perl5/pod/perllol.pod
new file mode 100644
index 000000000000..0e6796b50f67
--- /dev/null
+++ b/contrib/perl5/pod/perllol.pod
@@ -0,0 +1,303 @@
+=head1 NAME
+
+perlLoL - Manipulating Lists of Lists in Perl
+
+=head1 DESCRIPTION
+
+=head1 Declaration and Access of Lists of Lists
+
+The simplest thing to build is a list of lists (sometimes called an array
+of arrays). It's reasonably easy to understand, and almost everything
+that applies here will also be applicable later on with the fancier data
+structures.
+
+A list of lists, or an array of an array if you would, is just a regular
+old array @LoL that you can get at with two subscripts, like C<$LoL[3][2]>. Here's
+a declaration of the array:
+
+ # assign to our array a list of list references
+ @LoL = (
+ [ "fred", "barney" ],
+ [ "george", "jane", "elroy" ],
+ [ "homer", "marge", "bart" ],
+ );
+
+ print $LoL[2][2];
+ bart
+
+Now you should be very careful that the outer bracket type
+is a round one, that is, a parenthesis. That's because you're assigning to
+an @list, so you need parentheses. If you wanted there I<not> to be an @LoL,
+but rather just a reference to it, you could do something more like this:
+
+ # assign a reference to list of list references
+ $ref_to_LoL = [
+ [ "fred", "barney", "pebbles", "bambam", "dino", ],
+ [ "homer", "bart", "marge", "maggie", ],
+ [ "george", "jane", "alroy", "judy", ],
+ ];
+
+ print $ref_to_LoL->[2][2];
+
+Notice that the outer bracket type has changed, and so our access syntax
+has also changed. That's because unlike C, in perl you can't freely
+interchange arrays and references thereto. $ref_to_LoL is a reference to an
+array, whereas @LoL is an array proper. Likewise, C<$LoL[2]> is not an
+array, but an array ref. So how come you can write these:
+
+ $LoL[2][2]
+ $ref_to_LoL->[2][2]
+
+instead of having to write these:
+
+ $LoL[2]->[2]
+ $ref_to_LoL->[2]->[2]
+
+Well, that's because the rule is that on adjacent brackets only (whether
+square or curly), you are free to omit the pointer dereferencing arrow.
+But you cannot do so for the very first one if it's a scalar containing
+a reference, which means that $ref_to_LoL always needs it.
+
+=head1 Growing Your Own
+
+That's all well and good for declaration of a fixed data structure,
+but what if you wanted to add new elements on the fly, or build
+it up entirely from scratch?
+
+First, let's look at reading it in from a file. This is something like
+adding a row at a time. We'll assume that there's a flat file in which
+each line is a row and each word an element. If you're trying to develop an
+@LoL list containing all these, here's the right way to do that:
+
+ while (<>) {
+ @tmp = split;
+ push @LoL, [ @tmp ];
+ }
+
+You might also have loaded that from a function:
+
+ for $i ( 1 .. 10 ) {
+ $LoL[$i] = [ somefunc($i) ];
+ }
+
+Or you might have had a temporary variable sitting around with the
+list in it.
+
+ for $i ( 1 .. 10 ) {
+ @tmp = somefunc($i);
+ $LoL[$i] = [ @tmp ];
+ }
+
+It's very important that you make sure to use the C<[]> list reference
+constructor. That's because this will be very wrong:
+
+ $LoL[$i] = @tmp;
+
+You see, assigning a named list like that to a scalar just counts the
+number of elements in @tmp, which probably isn't what you want.
+
+If you are running under C<use strict>, you'll have to add some
+declarations to make it happy:
+
+ use strict;
+ my(@LoL, @tmp);
+ while (<>) {
+ @tmp = split;
+ push @LoL, [ @tmp ];
+ }
+
+Of course, you don't need the temporary array to have a name at all:
+
+ while (<>) {
+ push @LoL, [ split ];
+ }
+
+You also don't have to use push(). You could just make a direct assignment
+if you knew where you wanted to put it:
+
+ my (@LoL, $i, $line);
+ for $i ( 0 .. 10 ) {
+ $line = <>;
+ $LoL[$i] = [ split ' ', $line ];
+ }
+
+or even just
+
+ my (@LoL, $i);
+ for $i ( 0 .. 10 ) {
+ $LoL[$i] = [ split ' ', <> ];
+ }
+
+You should in general be leery of using potential list functions
+in a scalar context without explicitly stating such.
+This would be clearer to the casual reader:
+
+ my (@LoL, $i);
+ for $i ( 0 .. 10 ) {
+ $LoL[$i] = [ split ' ', scalar(<>) ];
+ }
+
+If you wanted to have a $ref_to_LoL variable as a reference to an array,
+you'd have to do something like this:
+
+ while (<>) {
+ push @$ref_to_LoL, [ split ];
+ }
+
+Now you can add new rows. What about adding new columns? If you're
+dealing with just matrices, it's often easiest to use simple assignment:
+
+ for $x (1 .. 10) {
+ for $y (1 .. 10) {
+ $LoL[$x][$y] = func($x, $y);
+ }
+ }
+
+ for $x ( 3, 7, 9 ) {
+ $LoL[$x][20] += func2($x);
+ }
+
+It doesn't matter whether those elements are already
+there or not: it'll gladly create them for you, setting
+intervening elements to C<undef> as need be.
+
+If you wanted just to append to a row, you'd have
+to do something a bit funnier looking:
+
+ # add new columns to an existing row
+ push @{ $LoL[0] }, "wilma", "betty";
+
+Notice that I I<couldn't> say just:
+
+ push $LoL[0], "wilma", "betty"; # WRONG!
+
+In fact, that wouldn't even compile. How come? Because the argument
+to push() must be a real array, not just a reference to such.
+
+=head1 Access and Printing
+
+Now it's time to print your data structure out. How
+are you going to do that? Well, if you want only one
+of the elements, it's trivial:
+
+ print $LoL[0][0];
+
+If you want to print the whole thing, though, you can't
+say
+
+ print @LoL; # WRONG
+
+because you'll get just references listed, and perl will never
+automatically dereference things for you. Instead, you have to
+roll yourself a loop or two. This prints the whole structure,
+using the shell-style for() construct to loop across the outer
+set of subscripts.
+
+ for $aref ( @LoL ) {
+ print "\t [ @$aref ],\n";
+ }
+
+If you wanted to keep track of subscripts, you might do this:
+
+ for $i ( 0 .. $#LoL ) {
+ print "\t elt $i is [ @{$LoL[$i]} ],\n";
+ }
+
+or maybe even this. Notice the inner loop.
+
+ for $i ( 0 .. $#LoL ) {
+ for $j ( 0 .. $#{$LoL[$i]} ) {
+ print "elt $i $j is $LoL[$i][$j]\n";
+ }
+ }
+
+As you can see, it's getting a bit complicated. That's why
+sometimes is easier to take a temporary on your way through:
+
+ for $i ( 0 .. $#LoL ) {
+ $aref = $LoL[$i];
+ for $j ( 0 .. $#{$aref} ) {
+ print "elt $i $j is $LoL[$i][$j]\n";
+ }
+ }
+
+Hmm... that's still a bit ugly. How about this:
+
+ for $i ( 0 .. $#LoL ) {
+ $aref = $LoL[$i];
+ $n = @$aref - 1;
+ for $j ( 0 .. $n ) {
+ print "elt $i $j is $LoL[$i][$j]\n";
+ }
+ }
+
+=head1 Slices
+
+If you want to get at a slice (part of a row) in a multidimensional
+array, you're going to have to do some fancy subscripting. That's
+because while we have a nice synonym for single elements via the
+pointer arrow for dereferencing, no such convenience exists for slices.
+(Remember, of course, that you can always write a loop to do a slice
+operation.)
+
+Here's how to do one operation using a loop. We'll assume an @LoL
+variable as before.
+
+ @part = ();
+ $x = 4;
+ for ($y = 7; $y < 13; $y++) {
+ push @part, $LoL[$x][$y];
+ }
+
+That same loop could be replaced with a slice operation:
+
+ @part = @{ $LoL[4] } [ 7..12 ];
+
+but as you might well imagine, this is pretty rough on the reader.
+
+Ah, but what if you wanted a I<two-dimensional slice>, such as having
+$x run from 4..8 and $y run from 7 to 12? Hmm... here's the simple way:
+
+ @newLoL = ();
+ for ($startx = $x = 4; $x <= 8; $x++) {
+ for ($starty = $y = 7; $y <= 12; $y++) {
+ $newLoL[$x - $startx][$y - $starty] = $LoL[$x][$y];
+ }
+ }
+
+We can reduce some of the looping through slices
+
+ for ($x = 4; $x <= 8; $x++) {
+ push @newLoL, [ @{ $LoL[$x] } [ 7..12 ] ];
+ }
+
+If you were into Schwartzian Transforms, you would probably
+have selected map for that
+
+ @newLoL = map { [ @{ $LoL[$_] } [ 7..12 ] ] } 4 .. 8;
+
+Although if your manager accused of seeking job security (or rapid
+insecurity) through inscrutable code, it would be hard to argue. :-)
+If I were you, I'd put that in a function:
+
+ @newLoL = splice_2D( \@LoL, 4 => 8, 7 => 12 );
+ sub splice_2D {
+ my $lrr = shift; # ref to list of list refs!
+ my ($x_lo, $x_hi,
+ $y_lo, $y_hi) = @_;
+
+ return map {
+ [ @{ $lrr->[$_] } [ $y_lo .. $y_hi ] ]
+ } $x_lo .. $x_hi;
+ }
+
+
+=head1 SEE ALSO
+
+perldata(1), perlref(1), perldsc(1)
+
+=head1 AUTHOR
+
+Tom Christiansen <F<tchrist@perl.com>>
+
+Last update: Thu Jun 4 16:16:23 MDT 1998
diff --git a/contrib/perl5/pod/perlmod.pod b/contrib/perl5/pod/perlmod.pod
new file mode 100644
index 000000000000..6da31dee3c96
--- /dev/null
+++ b/contrib/perl5/pod/perlmod.pod
@@ -0,0 +1,375 @@
+=head1 NAME
+
+perlmod - Perl modules (packages and symbol tables)
+
+=head1 DESCRIPTION
+
+=head2 Packages
+
+Perl provides a mechanism for alternative namespaces to protect packages
+from stomping on each other's variables. In fact, there's really no such
+thing as a global variable in Perl (although some identifiers default
+to the main package instead of the current one). The package statement
+declares the compilation unit as
+being in the given namespace. The scope of the package declaration
+is from the declaration itself through the end of the enclosing block,
+C<eval>, C<sub>, or end of file, whichever comes first (the same scope
+as the my() and local() operators). All further unqualified dynamic
+identifiers will be in this namespace. A package statement only affects
+dynamic variables--including those you've used local() on--but
+I<not> lexical variables created with my(). Typically it would be
+the first declaration in a file to be included by the C<require> or
+C<use> operator. You can switch into a package in more than one place;
+it merely influences which symbol table is used by the compiler for the
+rest of that block. You can refer to variables and filehandles in other
+packages by prefixing the identifier with the package name and a double
+colon: C<$Package::Variable>. If the package name is null, the C<main>
+package is assumed. That is, C<$::sail> is equivalent to C<$main::sail>.
+
+The old package delimiter was a single quote, but double colon is now the
+preferred delimiter, in part because it's more readable to humans, and
+in part because it's more readable to B<emacs> macros. It also makes C++
+programmers feel like they know what's going on--as opposed to using the
+single quote as separator, which was there to make Ada programmers feel
+like they knew what's going on. Because the old-fashioned syntax is still
+supported for backwards compatibility, if you try to use a string like
+C<"This is $owner's house">, you'll be accessing C<$owner::s>; that is,
+the $s variable in package C<owner>, which is probably not what you meant.
+Use braces to disambiguate, as in C<"This is ${owner}'s house">.
+
+Packages may be nested inside other packages: C<$OUTER::INNER::var>. This
+implies nothing about the order of name lookups, however. All symbols
+are either local to the current package, or must be fully qualified
+from the outer package name down. For instance, there is nowhere
+within package C<OUTER> that C<$INNER::var> refers to C<$OUTER::INNER::var>.
+It would treat package C<INNER> as a totally separate global package.
+
+Only identifiers starting with letters (or underscore) are stored in a
+package's symbol table. All other symbols are kept in package C<main>,
+including all of the punctuation variables like $_. In addition, when
+unqualified, the identifiers STDIN, STDOUT, STDERR, ARGV, ARGVOUT, ENV,
+INC, and SIG are forced to be in package C<main>, even when used for other
+purposes than their builtin one. Note also that, if you have a package
+called C<m>, C<s>, or C<y>, then you can't use the qualified form of an
+identifier because it will be interpreted instead as a pattern match,
+a substitution, or a transliteration.
+
+(Variables beginning with underscore used to be forced into package
+main, but we decided it was more useful for package writers to be able
+to use leading underscore to indicate private variables and method names.
+$_ is still global though.)
+
+Eval()ed strings are compiled in the package in which the eval() was
+compiled. (Assignments to C<$SIG{}>, however, assume the signal
+handler specified is in the C<main> package. Qualify the signal handler
+name if you wish to have a signal handler in a package.) For an
+example, examine F<perldb.pl> in the Perl library. It initially switches
+to the C<DB> package so that the debugger doesn't interfere with variables
+in the script you are trying to debug. At various points, however, it
+temporarily switches back to the C<main> package to evaluate various
+expressions in the context of the C<main> package (or wherever you came
+from). See L<perldebug>.
+
+The special symbol C<__PACKAGE__> contains the current package, but cannot
+(easily) be used to construct variables.
+
+See L<perlsub> for other scoping issues related to my() and local(),
+and L<perlref> regarding closures.
+
+=head2 Symbol Tables
+
+The symbol table for a package happens to be stored in the hash of that
+name with two colons appended. The main symbol table's name is thus
+C<%main::>, or C<%::> for short. Likewise symbol table for the nested
+package mentioned earlier is named C<%OUTER::INNER::>.
+
+The value in each entry of the hash is what you are referring to when you
+use the C<*name> typeglob notation. In fact, the following have the same
+effect, though the first is more efficient because it does the symbol
+table lookups at compile time:
+
+ local *main::foo = *main::bar;
+ local $main::{foo} = $main::{bar};
+
+You can use this to print out all the variables in a package, for
+instance. The standard F<dumpvar.pl> library and the CPAN module
+Devel::Symdump make use of this.
+
+Assignment to a typeglob performs an aliasing operation, i.e.,
+
+ *dick = *richard;
+
+causes variables, subroutines, formats, and file and directory handles
+accessible via the identifier C<richard> also to be accessible via the
+identifier C<dick>. If you want to alias only a particular variable or
+subroutine, you can assign a reference instead:
+
+ *dick = \$richard;
+
+Which makes $richard and $dick the same variable, but leaves
+@richard and @dick as separate arrays. Tricky, eh?
+
+This mechanism may be used to pass and return cheap references
+into or from subroutines if you won't want to copy the whole
+thing. It only works when assigning to dynamic variables, not
+lexicals.
+
+ %some_hash = (); # can't be my()
+ *some_hash = fn( \%another_hash );
+ sub fn {
+ local *hashsym = shift;
+ # now use %hashsym normally, and you
+ # will affect the caller's %another_hash
+ my %nhash = (); # do what you want
+ return \%nhash;
+ }
+
+On return, the reference will overwrite the hash slot in the
+symbol table specified by the *some_hash typeglob. This
+is a somewhat tricky way of passing around references cheaply
+when you won't want to have to remember to dereference variables
+explicitly.
+
+Another use of symbol tables is for making "constant" scalars.
+
+ *PI = \3.14159265358979;
+
+Now you cannot alter $PI, which is probably a good thing all in all.
+This isn't the same as a constant subroutine, which is subject to
+optimization at compile-time. This isn't. A constant subroutine is one
+prototyped to take no arguments and to return a constant expression.
+See L<perlsub> for details on these. The C<use constant> pragma is a
+convenient shorthand for these.
+
+You can say C<*foo{PACKAGE}> and C<*foo{NAME}> to find out what name and
+package the *foo symbol table entry comes from. This may be useful
+in a subroutine that gets passed typeglobs as arguments:
+
+ sub identify_typeglob {
+ my $glob = shift;
+ print 'You gave me ', *{$glob}{PACKAGE}, '::', *{$glob}{NAME}, "\n";
+ }
+ identify_typeglob *foo;
+ identify_typeglob *bar::baz;
+
+This prints
+
+ You gave me main::foo
+ You gave me bar::baz
+
+The *foo{THING} notation can also be used to obtain references to the
+individual elements of *foo, see L<perlref>.
+
+=head2 Package Constructors and Destructors
+
+There are two special subroutine definitions that function as package
+constructors and destructors. These are the C<BEGIN> and C<END>
+routines. The C<sub> is optional for these routines.
+
+A C<BEGIN> subroutine is executed as soon as possible, that is, the moment
+it is completely defined, even before the rest of the containing file
+is parsed. You may have multiple C<BEGIN> blocks within a file--they
+will execute in order of definition. Because a C<BEGIN> block executes
+immediately, it can pull in definitions of subroutines and such from other
+files in time to be visible to the rest of the file. Once a C<BEGIN>
+has run, it is immediately undefined and any code it used is returned to
+Perl's memory pool. This means you can't ever explicitly call a C<BEGIN>.
+
+An C<END> subroutine is executed as late as possible, that is, when
+the interpreter is being exited, even if it is exiting as a result of
+a die() function. (But not if it's polymorphing into another program
+via C<exec>, or being blown out of the water by a signal--you have to
+trap that yourself (if you can).) You may have multiple C<END> blocks
+within a file--they will execute in reverse order of definition; that is:
+last in, first out (LIFO).
+
+Inside an C<END> subroutine, C<$?> contains the value that the script is
+going to pass to C<exit()>. You can modify C<$?> to change the exit
+value of the script. Beware of changing C<$?> by accident (e.g. by
+running something via C<system>).
+
+Note that when you use the B<-n> and B<-p> switches to Perl, C<BEGIN> and
+C<END> work just as they do in B<awk>, as a degenerate case. As currently
+implemented (and subject to change, since its inconvenient at best),
+both C<BEGIN> I<and> C<END> blocks are run when you use the B<-c> switch
+for a compile-only syntax check, although your main code is not.
+
+=head2 Perl Classes
+
+There is no special class syntax in Perl, but a package may function
+as a class if it provides subroutines to act as methods. Such a
+package may also derive some of its methods from another class (package)
+by listing the other package name in its global @ISA array (which
+must be a package global, not a lexical).
+
+For more on this, see L<perltoot> and L<perlobj>.
+
+=head2 Perl Modules
+
+A module is just a package that is defined in a library file of
+the same name, and is designed to be reusable. It may do this by
+providing a mechanism for exporting some of its symbols into the symbol
+table of any package using it. Or it may function as a class
+definition and make its semantics available implicitly through method
+calls on the class and its objects, without explicit exportation of any
+symbols. Or it can do a little of both.
+
+For example, to start a normal module called Some::Module, create
+a file called Some/Module.pm and start with this template:
+
+ package Some::Module; # assumes Some/Module.pm
+
+ use strict;
+
+ BEGIN {
+ use Exporter ();
+ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+ # set the version for version checking
+ $VERSION = 1.00;
+ # if using RCS/CVS, this may be preferred
+ $VERSION = do { my @r = (q$Revision: 2.21 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
+
+ @ISA = qw(Exporter);
+ @EXPORT = qw(&func1 &func2 &func4);
+ %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
+
+ # your exported package globals go here,
+ # as well as any optionally exported functions
+ @EXPORT_OK = qw($Var1 %Hashit &func3);
+ }
+ use vars @EXPORT_OK;
+
+ # non-exported package globals go here
+ use vars qw(@more $stuff);
+
+ # initalize package globals, first exported ones
+ $Var1 = '';
+ %Hashit = ();
+
+ # then the others (which are still accessible as $Some::Module::stuff)
+ $stuff = '';
+ @more = ();
+
+ # all file-scoped lexicals must be created before
+ # the functions below that use them.
+
+ # file-private lexicals go here
+ my $priv_var = '';
+ my %secret_hash = ();
+
+ # here's a file-private function as a closure,
+ # callable as &$priv_func; it cannot be prototyped.
+ my $priv_func = sub {
+ # stuff goes here.
+ };
+
+ # make all your functions, whether exported or not;
+ # remember to put something interesting in the {} stubs
+ sub func1 {} # no prototype
+ sub func2() {} # proto'd void
+ sub func3($$) {} # proto'd to 2 scalars
+
+ # this one isn't exported, but could be called!
+ sub func4(\%) {} # proto'd to 1 hash ref
+
+ END { } # module clean-up code here (global destructor)
+
+Then go on to declare and use your variables in functions
+without any qualifications.
+See L<Exporter> and the L<perlmodlib> for details on
+mechanics and style issues in module creation.
+
+Perl modules are included into your program by saying
+
+ use Module;
+
+or
+
+ use Module LIST;
+
+This is exactly equivalent to
+
+ BEGIN { require Module; import Module; }
+
+or
+
+ BEGIN { require Module; import Module LIST; }
+
+As a special case
+
+ use Module ();
+
+is exactly equivalent to
+
+ BEGIN { require Module; }
+
+All Perl module files have the extension F<.pm>. C<use> assumes this so
+that you don't have to spell out "F<Module.pm>" in quotes. This also
+helps to differentiate new modules from old F<.pl> and F<.ph> files.
+Module names are also capitalized unless they're functioning as pragmas,
+"Pragmas" are in effect compiler directives, and are sometimes called
+"pragmatic modules" (or even "pragmata" if you're a classicist).
+
+The two statements:
+
+ require SomeModule;
+ require "SomeModule.pm";
+
+differ from each other in two ways. In the first case, any double
+colons in the module name, such as C<Some::Module>, are translated
+into your system's directory separator, usually "/". The second
+case does not, and would have to be specified literally. The other difference
+is that seeing the first C<require> clues in the compiler that uses of
+indirect object notation involving "SomeModule", as in C<$ob = purge SomeModule>,
+are method calls, not function calls. (Yes, this really can make a difference.)
+
+Because the C<use> statement implies a C<BEGIN> block, the importation
+of semantics happens at the moment the C<use> statement is compiled,
+before the rest of the file is compiled. This is how it is able
+to function as a pragma mechanism, and also how modules are able to
+declare subroutines that are then visible as list operators for
+the rest of the current file. This will not work if you use C<require>
+instead of C<use>. With require you can get into this problem:
+
+ require Cwd; # make Cwd:: accessible
+ $here = Cwd::getcwd();
+
+ use Cwd; # import names from Cwd::
+ $here = getcwd();
+
+ require Cwd; # make Cwd:: accessible
+ $here = getcwd(); # oops! no main::getcwd()
+
+In general, C<use Module ()> is recommended over C<require Module>,
+because it determines module availability at compile time, not in the
+middle of your program's execution. An exception would be if two modules
+each tried to C<use> each other, and each also called a function from
+that other module. In that case, it's easy to use C<require>s instead.
+
+Perl packages may be nested inside other package names, so we can have
+package names containing C<::>. But if we used that package name
+directly as a filename it would makes for unwieldy or impossible
+filenames on some systems. Therefore, if a module's name is, say,
+C<Text::Soundex>, then its definition is actually found in the library
+file F<Text/Soundex.pm>.
+
+Perl modules always have a F<.pm> file, but there may also be dynamically
+linked executables or autoloaded subroutine definitions associated with
+the module. If so, these will be entirely transparent to the user of
+the module. It is the responsibility of the F<.pm> file to load (or
+arrange to autoload) any additional functionality. The POSIX module
+happens to do both dynamic loading and autoloading, but the user can
+say just C<use POSIX> to get it all.
+
+For more information on writing extension modules, see L<perlxstut>
+and L<perlguts>.
+
+=head1 SEE ALSO
+
+See L<perlmodlib> for general style issues related to building Perl
+modules and classes as well as descriptions of the standard library and
+CPAN, L<Exporter> for how Perl's standard import/export mechanism works,
+L<perltoot> for an in-depth tutorial on creating classes, L<perlobj>
+for a hard-core reference document on objects, and L<perlsub> for an
+explanation of functions and scoping.
diff --git a/contrib/perl5/pod/perlmodinstall.pod b/contrib/perl5/pod/perlmodinstall.pod
new file mode 100644
index 000000000000..1c65f1c3e18d
--- /dev/null
+++ b/contrib/perl5/pod/perlmodinstall.pod
@@ -0,0 +1,410 @@
+=head1 NAME
+
+perlmodinstall - Installing CPAN Modules
+
+=head1 DESCRIPTION
+
+You can think of a module as the fundamental unit of reusable Perl
+code; see L<perlmod> for details. Whenever anyone creates a chunk of
+Perl code that they think will be useful to the world, they register
+as a Perl developer at http://www.perl.com/CPAN/modules/04pause.html
+so that they can then upload their code to the CPAN. The CPAN is the
+Comprehensive Perl Archive Network and can be accessed at
+http://www.perl.com/CPAN/.
+
+This documentation is for people who want to download CPAN modules
+and install them on their own computer.
+
+=head2 PREAMBLE
+
+You have a file ending in .tar.gz (or, less often, .zip). You know
+there's a tasty module inside. There are four steps you must now
+take:
+
+=over 5
+
+=item B<DECOMPRESS> the file
+
+=item B<UNPACK> the file into a directory
+
+=item B<BUILD> the module (sometimes unnecessary)
+
+=item B<INSTALL> the module.
+
+=back
+
+Here's how to perform each step for each operating system. This is
+I<not> a substitute for reading the README and INSTALL files that
+might have come with your module!
+
+Also note that these instructions are tailored for installing the
+module into your system's repository of Perl modules. But you can
+install modules into any directory you wish. For instance, where I
+say C<perl Makefile.PL>, you can substitute C<perl
+Makefile.PL PREFIX=/my/perl_directory> to install the modules
+into C</my/perl_directory>. Then you can use the modules
+from your Perl programs with C<use lib
+"/my/perl_directory/lib/site_perl";> or sometimes just C<use
+"/my/perl_directory";>.
+
+=over 4
+
+=item *
+
+B<If you're on Unix,>
+
+You can use Andreas Koenig's CPAN module
+( http://www.perl.com/CPAN/modules/by-module/CPAN )
+to automate the following steps, from DECOMPRESS through INSTALL.
+
+A. DECOMPRESS
+
+Decompress the file with C<gzip -d yourmodule.tar.gz>
+
+You can get gzip from ftp://prep.ai.mit.edu/pub/gnu.
+
+Or, you can combine this step with the next to save disk space:
+
+ gzip -dc yourmodule.tar.gz | tar -xof -
+
+B. UNPACK
+
+Unpack the result with C<tar -xof yourmodule.tar>
+
+C. BUILD
+
+Go into the newly-created directory and type:
+
+ perl Makefile.PL
+ make
+ make test
+
+D. INSTALL
+
+While still in that directory, type:
+
+ make install
+
+Make sure you have the appropriate permissions to install the module
+in your Perl 5 library directory. Often, you'll need to be root.
+
+That's all you need to do on Unix systems with dynamic linking.
+Most Unix systems have dynamic linking -- if yours doesn't, or if for
+another reason you have a statically-linked perl, B<and> the
+module requires compilation, you'll need to build a new Perl binary
+that includes the module. Again, you'll probably need to be root.
+
+=item *
+
+B<If you're running Windows 95 or NT with the ActiveState port of Perl>
+
+ A. DECOMPRESS
+
+You can use the shareware Winzip ( http://www.winzip.com ) to
+decompress and unpack modules.
+
+ B. UNPACK
+
+If you used WinZip, this was already done for you.
+
+ C. BUILD
+
+Does the module require compilation (i.e. does it have files
+that end in .xs, .c, .h, .y, .cc, .cxx, or .C)? If it does, you're on
+your own. You can try compiling it yourself if you have a C compiler.
+If you're successful, consider uploading the resulting binary to the
+CPAN for others to use. If it doesn't, go to INSTALL.
+
+ D. INSTALL
+
+Copy the module into your Perl's I<lib> directory. That'll be one
+of the directories you see when you type
+
+ perl -e 'print "@INC"'
+
+=item *
+
+B<If you're running Windows 95 or NT with the core Windows distribution of Perl,>
+
+ A. DECOMPRESS
+
+When you download the module, make sure it ends in either
+C<.tar.gz> or C<.zip>. Windows browsers sometimes
+download C<.tar.gz> files as C<_tar.tar>, because
+early versions of Windows prohibited more than one dot in a filename.
+
+You can use the shareware WinZip ( http://www.winzip.com ) to
+decompress and unpack modules.
+
+Or, you can use InfoZip's C<unzip> utility (
+http://www.cdrom.com/pub/infozip/Info-Zip.html ) to uncompress
+C<.zip> files; type C<unzip yourmodule.zip> in
+your shell.
+
+Or, if you have a working C<tar> and C<gzip>, you can
+type
+
+ gzip -cd yourmodule.tar.gz | tar xvf -
+
+in the shell to decompress C<yourmodule.tar.gz>. This will
+UNPACK your module as well.
+
+ B. UNPACK
+
+All of the methods in DECOMPRESS will have done this for you.
+
+ C. BUILD
+
+Go into the newly-created directory and type:
+
+ perl Makefile.PL
+ dmake
+ dmake test
+
+Depending on your perl configuration, C<dmake> might not be
+available. You might have to substitute whatever C<perl
+-V:make> says. (Usually, that will be C<nmake> or
+C<make>.)
+
+ D. INSTALL
+
+While still in that directory, type:
+
+ dmake install
+
+=item *
+
+B<If you're using a Macintosh,>
+
+A. DECOMPRESS
+
+You can either use StuffIt Expander ( http://www.aladdinsys.com/ ) in
+combination with I<DropStuff with Expander Enhancer>
+(shareware), or the freeware MacGzip (
+http://persephone.cps.unizar.es/general/gente/spd/gzip/gzip.html ).
+
+B. UNPACK
+
+If you're using DropStuff or Stuffit, you can just extract the tar
+archive. Otherwise, you can use the freeware I<suntar> (
+http://www.cirfid.unibo.it/~speranza ).
+
+C. BUILD
+
+Does the module require compilation?
+
+1. If it does,
+
+Overview: You need MPW and a combination of new and old CodeWarrior
+compilers for MPW and libraries. Makefiles created for building under
+MPW use the Metrowerks compilers. It's most likely possible to build
+without other compilers, but it has not been done successfully, to our
+knowledge. Read the documentation in MacPerl: Power and Ease (
+http://www.ptf.com/macperl/ ) on porting/building extensions, or find
+an existing precompiled binary, or hire someone to build it for you.
+
+Or, ask someone on the mac-perl mailing list (mac-perl@iis.ee.ethz.ch)
+to build it for you. To subscribe to the mac-perl mailing list, send
+mail to mac-perl-request@iis.ee.ethz.ch.
+
+2. If the module doesn't require compilation, go to INSTALL.
+
+D. INSTALL
+
+Make sure the newlines for the modules are in Mac format, not Unix format.
+Move the files manually into the correct folders.
+
+Move the files to their final destination: This will
+most likely be in C<$ENV{MACPERL}site_lib:> (i.e.,
+C<HD:MacPerl folder:site_lib:>). You can add new paths to
+the default C<@INC> in the Preferences menu item in the
+MacPerl application (C<$ENV{MACPERL}site_lib:> is added
+automagically). Create whatever directory structures are required
+(i.e., for C<Some::Module>, create
+C<$ENV{MACPERL}site_lib:Some:> and put
+C<Module.pm> in that directory).
+
+Run the following script (or something like it):
+
+ #!perl -w
+ use AutoSplit;
+ my $dir = "${MACPERL}site_perl";
+ autosplit("$dir:Some:Module.pm", "$dir:auto", 0, 1, 1);
+
+Eventually there should be a way to automate the installation process; some
+solutions exist, but none are ready for the general public yet.
+
+=item *
+
+B<If you're on the DJGPP port of DOS,>
+
+ A. DECOMPRESS
+
+djtarx ( ftp://ftp.simtel.net/pub/simtelnet/gnu/djgpp/v2/ )
+will both uncompress and unpack.
+
+ B. UNPACK
+
+See above.
+
+ C. BUILD
+
+Go into the newly-created directory and type:
+
+ perl Makefile.PL
+ make
+ make test
+
+You will need the packages mentioned in C<Readme.dos>
+in the Perl distribution.
+
+ D. INSTALL
+
+While still in that directory, type:
+
+ make install
+
+You will need the packages mentioned in Readme.dos in the Perl distribution.
+
+=item *
+
+B<If you're on OS/2,>
+
+Get the EMX development suite and gzip/tar, from either Hobbes (
+http://hobbes.nmsu.edu ) or Leo ( http://www.leo.org ), and then follow
+the instructions for Unix.
+
+=item *
+
+B<If you're on VMS,>
+
+When downloading from CPAN, save your file with a C<.tgz>
+extension instead of C<.tar.gz>. All other periods in the
+filename should be replaced with underscores. For example,
+C<Your-Module-1.33.tar.gz> should be downloaded as
+C<Your-Module-1_33.tgz>.
+
+A. DECOMPRESS
+
+Type
+
+ gzip -d Your-Module.tgz
+
+or, for zipped modules, type
+
+ unzip Your-Module.zip
+
+Executables for gzip, zip, and VMStar ( Alphas:
+http://www.openvms.digital.com/cd/000TOOLS/ALPHA/ and Vaxen:
+http://www.openvms.digital.com/cd/000TOOLS/VAX/ ).
+
+gzip and tar
+are also available at ftp://ftp.digital.com/pub/VMS.
+
+Note that GNU's gzip/gunzip is not the same as Info-ZIP's zip/unzip
+package. The former is a simple compression tool; the latter permits
+creation of multi-file archives.
+
+B. UNPACK
+
+If you're using VMStar:
+
+ VMStar xf Your-Module.tar
+
+Or, if you're fond of VMS command syntax:
+
+ tar/extract/verbose Your_Module.tar
+
+C. BUILD
+
+Make sure you have MMS (from Digital) or the freeware MMK ( available from MadGoat at http://www.madgoat.com ). Then type this to create the
+DESCRIP.MMS for the module:
+
+ perl Makefile.PL
+
+Now you're ready to build:
+
+ mms
+ mms test
+
+Substitute C<mmk> for C<mms> above if you're using MMK.
+
+D. INSTALL
+
+Type
+
+ mms install
+
+Substitute C<mmk> for C<mms> above if you're using MMK.
+
+=item *
+
+B<If you're on MVS>,
+
+Introduce the .tar.gz file into an HFS as binary; don't translate from
+ASCII to EBCDIC.
+
+A. DECOMPRESS
+
+ Decompress the file with C<gzip -d yourmodule.tar.gz>
+
+ You can get gzip from
+ http://www.s390.ibm.com/products/oe/bpxqp1.html.
+
+B. UNPACK
+
+Unpack the result with
+
+ pax -o to=IBM-1047,from=ISO8859-1 -r < yourmodule.tar
+
+The BUILD and INSTALL steps are identical to those for Unix. Some
+modules generate Makefiles that work better with GNU make, which is
+available from http://www.mks.com/s390/gnu/index.htm.
+
+=back
+
+=head1 HEY
+
+If you have any suggested changes for this page, let me know. Please
+don't send me mail asking for help on how to install your modules.
+There are too many modules, and too few Orwants, for me to be able to
+answer or even acknowledge all your questions. Contact the module
+author instead, or post to comp.lang.perl.modules, or ask someone
+familiar with Perl on your operating system.
+
+=head1 AUTHOR
+
+Jon Orwant
+
+orwant@tpj.com
+
+The Perl Journal, http://tpj.com
+
+with invaluable help from Brandon Allbery, Charles Bailey, Graham
+Barr, Dominic Dunlop, Jarkko Hietaniemi, Ben Holzman, Tom Horsley,
+Nick Ing-Simmons, Tuomas J. Lukka, Laszlo Molnar, Chris Nandor, Alan
+Olsen, Peter Prymmer, Gurusamy Sarathy, Christoph Spalinger, Dan
+Sugalski, Larry Virden, and Ilya Zakharevich.
+
+July 22, 1998
+
+=head1 COPYRIGHT
+
+Copyright (C) 1998 Jon Orwant. All Rights Reserved.
+
+Permission is granted to make and distribute verbatim copies of this
+documentation provided the copyright notice and this permission notice are
+preserved on all copies.
+
+Permission is granted to copy and distribute modified versions of this
+documentation under the conditions for verbatim copying, provided also
+that they are marked clearly as modified versions, that the authors'
+names and title are unchanged (though subtitles and additional
+authors' names may be added), and that the entire resulting derived
+work is distributed under the terms of a permission notice identical
+to this one.
+
+Permission is granted to copy and distribute translations of this
+documentation into another language, under the above conditions for
+modified versions.
+
diff --git a/contrib/perl5/pod/perlmodlib.pod b/contrib/perl5/pod/perlmodlib.pod
new file mode 100644
index 000000000000..5d0e5b048a9f
--- /dev/null
+++ b/contrib/perl5/pod/perlmodlib.pod
@@ -0,0 +1,1102 @@
+=head1 NAME
+
+perlmodlib - constructing new Perl modules and finding existing ones
+
+=head1 DESCRIPTION
+
+=head1 THE PERL MODULE LIBRARY
+
+A number of modules are included the Perl distribution. These are
+described below, and all end in F<.pm>. You may also discover files in
+the library directory that end in either F<.pl> or F<.ph>. These are old
+libraries supplied so that old programs that use them still run. The
+F<.pl> files will all eventually be converted into standard modules, and
+the F<.ph> files made by B<h2ph> will probably end up as extension modules
+made by B<h2xs>. (Some F<.ph> values may already be available through the
+POSIX module.) The B<pl2pm> file in the distribution may help in your
+conversion, but it's just a mechanical process and therefore far from
+bulletproof.
+
+=head2 Pragmatic Modules
+
+They work somewhat like pragmas in that they tend to affect the compilation of
+your program, and thus will usually work well only when used within a
+C<use>, or C<no>. Most of these are locally scoped, so an inner BLOCK
+may countermand any of these by saying:
+
+ no integer;
+ no strict 'refs';
+
+which lasts until the end of that BLOCK.
+
+Unlike the pragmas that effect the C<$^H> hints variable, the C<use
+vars> and C<use subs> declarations are not BLOCK-scoped. They allow
+you to predeclare a variables or subroutines within a particular
+I<file> rather than just a block. Such declarations are effective
+for the entire file for which they were declared. You cannot rescind
+them with C<no vars> or C<no subs>.
+
+The following pragmas are defined (and have their own documentation).
+
+=over 12
+
+=item use autouse MODULE => qw(sub1 sub2 sub3)
+
+Defers C<require MODULE> until someone calls one of the specified
+subroutines (which must be exported by MODULE). This pragma should be
+used with caution, and only when necessary.
+
+=item blib
+
+manipulate @INC at compile time to use MakeMaker's uninstalled version
+of a package
+
+=item diagnostics
+
+force verbose warning diagnostics
+
+=item integer
+
+compute arithmetic in integer instead of double
+
+=item less
+
+request less of something from the compiler
+
+=item lib
+
+manipulate @INC at compile time
+
+=item locale
+
+use or ignore current locale for builtin operations (see L<perllocale>)
+
+=item ops
+
+restrict named opcodes when compiling or running Perl code
+
+=item overload
+
+overload basic Perl operations
+
+=item re
+
+alter behaviour of regular expressions
+
+=item sigtrap
+
+enable simple signal handling
+
+=item strict
+
+restrict unsafe constructs
+
+=item subs
+
+predeclare sub names
+
+=item vmsish
+
+adopt certain VMS-specific behaviors
+
+=item vars
+
+predeclare global variable names
+
+=back
+
+=head2 Standard Modules
+
+Standard, bundled modules are all expected to behave in a well-defined
+manner with respect to namespace pollution because they use the
+Exporter module. See their own documentation for details.
+
+=over 12
+
+=item AnyDBM_File
+
+provide framework for multiple DBMs
+
+=item AutoLoader
+
+load functions only on demand
+
+=item AutoSplit
+
+split a package for autoloading
+
+=item Benchmark
+
+benchmark running times of code
+
+=item CPAN
+
+interface to Comprehensive Perl Archive Network
+
+=item CPAN::FirstTime
+
+create a CPAN configuration file
+
+=item CPAN::Nox
+
+run CPAN while avoiding compiled extensions
+
+=item Carp
+
+warn of errors (from perspective of caller)
+
+=item Class::Struct
+
+declare struct-like datatypes
+
+=item Config
+
+access Perl configuration information
+
+=item Cwd
+
+get pathname of current working directory
+
+=item DB_File
+
+access to Berkeley DB
+
+=item Devel::SelfStubber
+
+generate stubs for a SelfLoading module
+
+=item DirHandle
+
+supply object methods for directory handles
+
+=item DynaLoader
+
+dynamically load C libraries into Perl code
+
+=item English
+
+use nice English (or awk) names for ugly punctuation variables
+
+=item Env
+
+import environment variables
+
+=item Exporter
+
+implements default import method for modules
+
+=item ExtUtils::Embed
+
+utilities for embedding Perl in C/C++ applications
+
+=item ExtUtils::Install
+
+install files from here to there
+
+=item ExtUtils::Liblist
+
+determine libraries to use and how to use them
+
+=item ExtUtils::MM_OS2
+
+methods to override Unix behaviour in ExtUtils::MakeMaker
+
+=item ExtUtils::MM_Unix
+
+methods used by ExtUtils::MakeMaker
+
+=item ExtUtils::MM_VMS
+
+methods to override Unix behaviour in ExtUtils::MakeMaker
+
+=item ExtUtils::MakeMaker
+
+create an extension Makefile
+
+=item ExtUtils::Manifest
+
+utilities to write and check a MANIFEST file
+
+=item ExtUtils::Mkbootstrap
+
+make a bootstrap file for use by DynaLoader
+
+=item ExtUtils::Mksymlists
+
+write linker options files for dynamic extension
+
+=item ExtUtils::testlib
+
+add blib/* directories to @INC
+
+=item Fatal
+
+make errors in builtins or Perl functions fatal
+
+=item Fcntl
+
+load the C Fcntl.h defines
+
+=item File::Basename
+
+split a pathname into pieces
+
+=item File::CheckTree
+
+run many filetest checks on a tree
+
+=item File::Compare
+
+compare files or filehandles
+
+=item File::Copy
+
+copy files or filehandles
+
+=item File::Find
+
+traverse a file tree
+
+=item File::Path
+
+create or remove a series of directories
+
+=item File::stat
+
+by-name interface to Perl's builtin stat() functions
+
+=item FileCache
+
+keep more files open than the system permits
+
+=item FileHandle
+
+supply object methods for filehandles
+
+=item FindBin
+
+locate directory of original Perl script
+
+=item GDBM_File
+
+access to the gdbm library
+
+=item Getopt::Long
+
+extended processing of command line options
+
+=item Getopt::Std
+
+process single-character switches with switch clustering
+
+=item I18N::Collate
+
+compare 8-bit scalar data according to the current locale
+
+=item IO
+
+load various IO modules
+
+=item IO::File
+
+supply object methods for filehandles
+
+=item IO::Handle
+
+supply object methods for I/O handles
+
+=item IO::Pipe
+
+supply object methods for pipes
+
+=item IO::Seekable
+
+supply seek based methods for I/O objects
+
+=item IO::Select
+
+OO interface to the select system call
+
+=item IO::Socket
+
+object interface to socket communications
+
+=item IPC::Open2
+
+open a process for both reading and writing
+
+=item IPC::Open3
+
+open a process for reading, writing, and error handling
+
+=item Math::BigFloat
+
+arbitrary length float math package
+
+=item Math::BigInt
+
+arbitrary size integer math package
+
+=item Math::Complex
+
+complex numbers and associated mathematical functions
+
+=item Math::Trig
+
+simple interface to parts of Math::Complex for those who
+need trigonometric functions only for real numbers
+
+=item NDBM_File
+
+tied access to ndbm files
+
+=item Net::Ping
+
+Hello, anybody home?
+
+=item Net::hostent
+
+by-name interface to Perl's builtin gethost*() functions
+
+=item Net::netent
+
+by-name interface to Perl's builtin getnet*() functions
+
+=item Net::protoent
+
+by-name interface to Perl's builtin getproto*() functions
+
+=item Net::servent
+
+by-name interface to Perl's builtin getserv*() functions
+
+=item Opcode
+
+disable named opcodes when compiling or running Perl code
+
+=item Pod::Text
+
+convert POD data to formatted ASCII text
+
+=item POSIX
+
+interface to IEEE Standard 1003.1
+
+=item SDBM_File
+
+tied access to sdbm files
+
+=item Safe
+
+compile and execute code in restricted compartments
+
+=item Search::Dict
+
+search for key in dictionary file
+
+=item SelectSaver
+
+save and restore selected file handle
+
+=item SelfLoader
+
+load functions only on demand
+
+=item Shell
+
+run shell commands transparently within Perl
+
+=item Socket
+
+load the C socket.h defines and structure manipulators
+
+=item Symbol
+
+manipulate Perl symbols and their names
+
+=item Sys::Hostname
+
+try every conceivable way to get hostname
+
+=item Sys::Syslog
+
+interface to the Unix syslog(3) calls
+
+=item Term::Cap
+
+termcap interface
+
+=item Term::Complete
+
+word completion module
+
+=item Term::ReadLine
+
+interface to various C<readline> packages
+
+=item Test::Harness
+
+run Perl standard test scripts with statistics
+
+=item Text::Abbrev
+
+create an abbreviation table from a list
+
+=item Text::ParseWords
+
+parse text into an array of tokens
+
+=item Text::Soundex
+
+implementation of the Soundex Algorithm as described by Knuth
+
+=item Text::Tabs
+
+expand and unexpand tabs per the Unix expand(1) and unexpand(1)
+
+=item Text::Wrap
+
+line wrapping to form simple paragraphs
+
+=item Tie::Hash
+
+base class definitions for tied hashes
+
+=item Tie::RefHash
+
+base class definitions for tied hashes with references as keys
+
+=item Tie::Scalar
+
+base class definitions for tied scalars
+
+=item Tie::SubstrHash
+
+fixed-table-size, fixed-key-length hashing
+
+=item Time::Local
+
+efficiently compute time from local and GMT time
+
+=item Time::gmtime
+
+by-name interface to Perl's builtin gmtime() function
+
+=item Time::localtime
+
+by-name interface to Perl's builtin localtime() function
+
+=item Time::tm
+
+internal object used by Time::gmtime and Time::localtime
+
+=item UNIVERSAL
+
+base class for ALL classes (blessed references)
+
+=item User::grent
+
+by-name interface to Perl's builtin getgr*() functions
+
+=item User::pwent
+
+by-name interface to Perl's builtin getpw*() functions
+
+=back
+
+To find out I<all> the modules installed on your system, including
+those without documentation or outside the standard release, do this:
+
+ % find `perl -e 'print "@INC"'` -name '*.pm' -print
+
+They should all have their own documentation installed and accessible via
+your system man(1) command. If that fails, try the I<perldoc> program.
+
+=head2 Extension Modules
+
+Extension modules are written in C (or a mix of Perl and C) and may be
+statically linked or in general are
+dynamically loaded into Perl if and when you need them. Supported
+extension modules include the Socket, Fcntl, and POSIX modules.
+
+Many popular C extension modules do not come bundled (at least, not
+completely) due to their sizes, volatility, or simply lack of time for
+adequate testing and configuration across the multitude of platforms on
+which Perl was beta-tested. You are encouraged to look for them in
+archie(1L), the Perl FAQ or Meta-FAQ, the WWW page, and even with their
+authors before randomly posting asking for their present condition and
+disposition.
+
+=head1 CPAN
+
+CPAN stands for the Comprehensive Perl Archive Network. This is a globally
+replicated collection of all known Perl materials, including hundreds
+of unbundled modules. Here are the major categories of modules:
+
+=over
+
+=item *
+Language Extensions and Documentation Tools
+
+=item *
+Development Support
+
+=item *
+Operating System Interfaces
+
+=item *
+Networking, Device Control (modems) and InterProcess Communication
+
+=item *
+Data Types and Data Type Utilities
+
+=item *
+Database Interfaces
+
+=item *
+User Interfaces
+
+=item *
+Interfaces to / Emulations of Other Programming Languages
+
+=item *
+File Names, File Systems and File Locking (see also File Handles)
+
+=item *
+String Processing, Language Text Processing, Parsing, and Searching
+
+=item *
+Option, Argument, Parameter, and Configuration File Processing
+
+=item *
+Internationalization and Locale
+
+=item *
+Authentication, Security, and Encryption
+
+=item *
+World Wide Web, HTML, HTTP, CGI, MIME
+
+=item *
+Server and Daemon Utilities
+
+=item *
+Archiving and Compression
+
+=item *
+Images, Pixmap and Bitmap Manipulation, Drawing, and Graphing
+
+=item *
+Mail and Usenet News
+
+=item *
+Control Flow Utilities (callbacks and exceptions etc)
+
+=item *
+File Handle and Input/Output Stream Utilities
+
+=item *
+Miscellaneous Modules
+
+=back
+
+The registered CPAN sites as of this writing include the following.
+You should try to choose one close to you:
+
+=over
+
+=item *
+Africa
+
+ South Africa ftp://ftp.is.co.za/programming/perl/CPAN/
+
+=item *
+Asia
+
+ Hong Kong ftp://ftp.hkstar.com/pub/CPAN/
+ Japan ftp://ftp.jaist.ac.jp/pub/lang/perl/CPAN/
+ ftp://ftp.lab.kdd.co.jp/lang/perl/CPAN/
+ South Korea ftp://ftp.nuri.net/pub/CPAN/
+ Taiwan ftp://dongpo.math.ncu.edu.tw/perl/CPAN/
+ ftp://ftp.wownet.net/pub2/PERL/
+
+=item *
+Australasia
+
+ Australia ftp://ftp.netinfo.com.au/pub/perl/CPAN/
+ New Zealand ftp://ftp.tekotago.ac.nz/pub/perl/CPAN/
+
+=item *
+Europe
+
+ Austria ftp://ftp.tuwien.ac.at/pub/languages/perl/CPAN/
+ Belgium ftp://ftp.kulnet.kuleuven.ac.be/pub/mirror/CPAN/
+ Czech Republic ftp://sunsite.mff.cuni.cz/Languages/Perl/CPAN/
+ Denmark ftp://sunsite.auc.dk/pub/languages/perl/CPAN/
+ Finland ftp://ftp.funet.fi/pub/languages/perl/CPAN/
+ France ftp://ftp.ibp.fr/pub/perl/CPAN/
+ ftp://ftp.pasteur.fr/pub/computing/unix/perl/CPAN/
+ Germany ftp://ftp.gmd.de/packages/CPAN/
+ ftp://ftp.leo.org/pub/comp/programming/languages/perl/CPAN/
+ ftp://ftp.mpi-sb.mpg.de/pub/perl/CPAN/
+ ftp://ftp.rz.ruhr-uni-bochum.de/pub/CPAN/
+ ftp://ftp.uni-erlangen.de/pub/source/Perl/CPAN/
+ ftp://ftp.uni-hamburg.de/pub/soft/lang/perl/CPAN/
+ Greece ftp://ftp.ntua.gr/pub/lang/perl/
+ Hungary ftp://ftp.kfki.hu/pub/packages/perl/CPAN/
+ Italy ftp://cis.utovrm.it/CPAN/
+ the Netherlands ftp://ftp.cs.ruu.nl/pub/PERL/CPAN/
+ ftp://ftp.EU.net/packages/cpan/
+ Norway ftp://ftp.uit.no/pub/languages/perl/cpan/
+ Poland ftp://ftp.pk.edu.pl/pub/lang/perl/CPAN/
+ ftp://sunsite.icm.edu.pl/pub/CPAN/
+ Portugal ftp://ftp.ci.uminho.pt/pub/lang/perl/
+ ftp://ftp.telepac.pt/pub/CPAN/
+ Russia ftp://ftp.sai.msu.su/pub/lang/perl/CPAN/
+ Slovenia ftp://ftp.arnes.si/software/perl/CPAN/
+ Spain ftp://ftp.etse.urv.es/pub/mirror/perl/
+ ftp://ftp.rediris.es/mirror/CPAN/
+ Sweden ftp://ftp.sunet.se/pub/lang/perl/CPAN/
+ UK ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/
+ ftp://sunsite.doc.ic.ac.uk/packages/CPAN/
+ ftp://unix.hensa.ac.uk/mirrors/perl-CPAN/
+
+=item *
+North America
+
+ Ontario ftp://ftp.utilis.com/public/CPAN/
+ ftp://enterprise.ic.gc.ca/pub/perl/CPAN/
+ Manitoba ftp://theory.uwinnipeg.ca/pub/CPAN/
+ California ftp://ftp.digital.com/pub/plan/perl/CPAN/
+ ftp://ftp.cdrom.com/pub/perl/CPAN/
+ Colorado ftp://ftp.cs.colorado.edu/pub/perl/CPAN/
+ Florida ftp://ftp.cis.ufl.edu/pub/perl/CPAN/
+ Illinois ftp://uiarchive.uiuc.edu/pub/lang/perl/CPAN/
+ Massachusetts ftp://ftp.iguide.com/pub/mirrors/packages/perl/CPAN/
+ New York ftp://ftp.rge.com/pub/languages/perl/
+ North Carolina ftp://ftp.duke.edu/pub/perl/
+ Oklahoma ftp://ftp.ou.edu/mirrors/CPAN/
+ Oregon http://www.perl.org/CPAN/
+ ftp://ftp.orst.edu/pub/packages/CPAN/
+ Pennsylvania ftp://ftp.epix.net/pub/languages/perl/
+ Texas ftp://ftp.sedl.org/pub/mirrors/CPAN/
+ ftp://ftp.metronet.com/pub/perl/
+
+=item *
+South America
+
+ Chile ftp://sunsite.dcc.uchile.cl/pub/Lang/perl/CPAN/
+
+=back
+
+For an up-to-date listing of CPAN sites,
+see F<http://www.perl.com/perl/CPAN> or F<ftp://ftp.perl.com/perl/>.
+
+=head1 Modules: Creation, Use, and Abuse
+
+(The following section is borrowed directly from Tim Bunce's modules
+file, available at your nearest CPAN site.)
+
+Perl implements a class using a package, but the presence of a
+package doesn't imply the presence of a class. A package is just a
+namespace. A class is a package that provides subroutines that can be
+used as methods. A method is just a subroutine that expects, as its
+first argument, either the name of a package (for "static" methods),
+or a reference to something (for "virtual" methods).
+
+A module is a file that (by convention) provides a class of the same
+name (sans the .pm), plus an import method in that class that can be
+called to fetch exported symbols. This module may implement some of
+its methods by loading dynamic C or C++ objects, but that should be
+totally transparent to the user of the module. Likewise, the module
+might set up an AUTOLOAD function to slurp in subroutine definitions on
+demand, but this is also transparent. Only the F<.pm> file is required to
+exist. See L<perlsub>, L<perltoot>, and L<AutoLoader> for details about
+the AUTOLOAD mechanism.
+
+=head2 Guidelines for Module Creation
+
+=over 4
+
+=item Do similar modules already exist in some form?
+
+If so, please try to reuse the existing modules either in whole or
+by inheriting useful features into a new class. If this is not
+practical try to get together with the module authors to work on
+extending or enhancing the functionality of the existing modules.
+A perfect example is the plethora of packages in perl4 for dealing
+with command line options.
+
+If you are writing a module to expand an already existing set of
+modules, please coordinate with the author of the package. It
+helps if you follow the same naming scheme and module interaction
+scheme as the original author.
+
+=item Try to design the new module to be easy to extend and reuse.
+
+Use blessed references. Use the two argument form of bless to bless
+into the class name given as the first parameter of the constructor,
+e.g.,:
+
+ sub new {
+ my $class = shift;
+ return bless {}, $class;
+ }
+
+or even this if you'd like it to be used as either a static
+or a virtual method.
+
+ sub new {
+ my $self = shift;
+ my $class = ref($self) || $self;
+ return bless {}, $class;
+ }
+
+Pass arrays as references so more parameters can be added later
+(it's also faster). Convert functions into methods where
+appropriate. Split large methods into smaller more flexible ones.
+Inherit methods from other modules if appropriate.
+
+Avoid class name tests like: C<die "Invalid" unless ref $ref eq 'FOO'>.
+Generally you can delete the "C<eq 'FOO'>" part with no harm at all.
+Let the objects look after themselves! Generally, avoid hard-wired
+class names as far as possible.
+
+Avoid C<$r-E<gt>Class::func()> where using C<@ISA=qw(... Class ...)> and
+C<$r-E<gt>func()> would work (see L<perlbot> for more details).
+
+Use autosplit so little used or newly added functions won't be a
+burden to programs that don't use them. Add test functions to
+the module after __END__ either using AutoSplit or by saying:
+
+ eval join('',<main::DATA>) || die $@ unless caller();
+
+Does your module pass the 'empty subclass' test? If you say
+"C<@SUBCLASS::ISA = qw(YOURCLASS);>" your applications should be able
+to use SUBCLASS in exactly the same way as YOURCLASS. For example,
+does your application still work if you change: C<$obj = new YOURCLASS;>
+into: C<$obj = new SUBCLASS;> ?
+
+Avoid keeping any state information in your packages. It makes it
+difficult for multiple other packages to use yours. Keep state
+information in objects.
+
+Always use B<-w>. Try to C<use strict;> (or C<use strict qw(...);>).
+Remember that you can add C<no strict qw(...);> to individual blocks
+of code that need less strictness. Always use B<-w>. Always use B<-w>!
+Follow the guidelines in the perlstyle(1) manual.
+
+=item Some simple style guidelines
+
+The perlstyle manual supplied with Perl has many helpful points.
+
+Coding style is a matter of personal taste. Many people evolve their
+style over several years as they learn what helps them write and
+maintain good code. Here's one set of assorted suggestions that
+seem to be widely used by experienced developers:
+
+Use underscores to separate words. It is generally easier to read
+$var_names_like_this than $VarNamesLikeThis, especially for
+non-native speakers of English. It's also a simple rule that works
+consistently with VAR_NAMES_LIKE_THIS.
+
+Package/Module names are an exception to this rule. Perl informally
+reserves lowercase module names for 'pragma' modules like integer
+and strict. Other modules normally begin with a capital letter and
+use mixed case with no underscores (need to be short and portable).
+
+You may find it helpful to use letter case to indicate the scope
+or nature of a variable. For example:
+
+ $ALL_CAPS_HERE constants only (beware clashes with Perl vars)
+ $Some_Caps_Here package-wide global/static
+ $no_caps_here function scope my() or local() variables
+
+Function and method names seem to work best as all lowercase.
+e.g., C<$obj-E<gt>as_string()>.
+
+You can use a leading underscore to indicate that a variable or
+function should not be used outside the package that defined it.
+
+=item Select what to export.
+
+Do NOT export method names!
+
+Do NOT export anything else by default without a good reason!
+
+Exports pollute the namespace of the module user. If you must
+export try to use @EXPORT_OK in preference to @EXPORT and avoid
+short or common names to reduce the risk of name clashes.
+
+Generally anything not exported is still accessible from outside the
+module using the ModuleName::item_name (or C<$blessed_ref-E<gt>method>)
+syntax. By convention you can use a leading underscore on names to
+indicate informally that they are 'internal' and not for public use.
+
+(It is actually possible to get private functions by saying:
+C<my $subref = sub { ... }; &$subref;>. But there's no way to call that
+directly as a method, because a method must have a name in the symbol
+table.)
+
+As a general rule, if the module is trying to be object oriented
+then export nothing. If it's just a collection of functions then
+@EXPORT_OK anything but use @EXPORT with caution.
+
+=item Select a name for the module.
+
+This name should be as descriptive, accurate, and complete as
+possible. Avoid any risk of ambiguity. Always try to use two or
+more whole words. Generally the name should reflect what is special
+about what the module does rather than how it does it. Please use
+nested module names to group informally or categorize a module.
+There should be a very good reason for a module not to have a nested name.
+Module names should begin with a capital letter.
+
+Having 57 modules all called Sort will not make life easy for anyone
+(though having 23 called Sort::Quick is only marginally better :-).
+Imagine someone trying to install your module alongside many others.
+If in any doubt ask for suggestions in comp.lang.perl.misc.
+
+If you are developing a suite of related modules/classes it's good
+practice to use nested classes with a common prefix as this will
+avoid namespace clashes. For example: Xyz::Control, Xyz::View,
+Xyz::Model etc. Use the modules in this list as a naming guide.
+
+If adding a new module to a set, follow the original author's
+standards for naming modules and the interface to methods in
+those modules.
+
+To be portable each component of a module name should be limited to
+11 characters. If it might be used on MS-DOS then try to ensure each is
+unique in the first 8 characters. Nested modules make this easier.
+
+=item Have you got it right?
+
+How do you know that you've made the right decisions? Have you
+picked an interface design that will cause problems later? Have
+you picked the most appropriate name? Do you have any questions?
+
+The best way to know for sure, and pick up many helpful suggestions,
+is to ask someone who knows. Comp.lang.perl.misc is read by just about
+all the people who develop modules and it's the best place to ask.
+
+All you need to do is post a short summary of the module, its
+purpose and interfaces. A few lines on each of the main methods is
+probably enough. (If you post the whole module it might be ignored
+by busy people - generally the very people you want to read it!)
+
+Don't worry about posting if you can't say when the module will be
+ready - just say so in the message. It might be worth inviting
+others to help you, they may be able to complete it for you!
+
+=item README and other Additional Files.
+
+It's well known that software developers usually fully document the
+software they write. If, however, the world is in urgent need of
+your software and there is not enough time to write the full
+documentation please at least provide a README file containing:
+
+=over 10
+
+=item *
+A description of the module/package/extension etc.
+
+=item *
+A copyright notice - see below.
+
+=item *
+Prerequisites - what else you may need to have.
+
+=item *
+How to build it - possible changes to Makefile.PL etc.
+
+=item *
+How to install it.
+
+=item *
+Recent changes in this release, especially incompatibilities
+
+=item *
+Changes / enhancements you plan to make in the future.
+
+=back
+
+If the README file seems to be getting too large you may wish to
+split out some of the sections into separate files: INSTALL,
+Copying, ToDo etc.
+
+=over 4
+
+=item Adding a Copyright Notice.
+
+How you choose to license your work is a personal decision.
+The general mechanism is to assert your Copyright and then make
+a declaration of how others may copy/use/modify your work.
+
+Perl, for example, is supplied with two types of licence: The GNU
+GPL and The Artistic Licence (see the files README, Copying, and
+Artistic). Larry has good reasons for NOT just using the GNU GPL.
+
+My personal recommendation, out of respect for Larry, Perl, and the
+Perl community at large is to state something simply like:
+
+ Copyright (c) 1995 Your Name. All rights reserved.
+ This program is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+
+This statement should at least appear in the README file. You may
+also wish to include it in a Copying file and your source files.
+Remember to include the other words in addition to the Copyright.
+
+=item Give the module a version/issue/release number.
+
+To be fully compatible with the Exporter and MakeMaker modules you
+should store your module's version number in a non-my package
+variable called $VERSION. This should be a floating point
+number with at least two digits after the decimal (i.e., hundredths,
+e.g, C<$VERSION = "0.01">). Don't use a "1.3.2" style version.
+See Exporter.pm in Perl5.001m or later for details.
+
+It may be handy to add a function or method to retrieve the number.
+Use the number in announcements and archive file names when
+releasing the module (ModuleName-1.02.tar.Z).
+See perldoc ExtUtils::MakeMaker.pm for details.
+
+=item How to release and distribute a module.
+
+It's good idea to post an announcement of the availability of your
+module (or the module itself if small) to the comp.lang.perl.announce
+Usenet newsgroup. This will at least ensure very wide once-off
+distribution.
+
+If possible you should place the module into a major ftp archive and
+include details of its location in your announcement.
+
+Some notes about ftp archives: Please use a long descriptive file
+name that includes the version number. Most incoming directories
+will not be readable/listable, i.e., you won't be able to see your
+file after uploading it. Remember to send your email notification
+message as soon as possible after uploading else your file may get
+deleted automatically. Allow time for the file to be processed
+and/or check the file has been processed before announcing its
+location.
+
+FTP Archives for Perl Modules:
+
+Follow the instructions and links on
+
+ http://franz.ww.tu-berlin.de/modulelist
+
+or upload to one of these sites:
+
+ ftp://franz.ww.tu-berlin.de/incoming
+ ftp://ftp.cis.ufl.edu/incoming
+
+and notify <F<upload@franz.ww.tu-berlin.de>>.
+
+By using the WWW interface you can ask the Upload Server to mirror
+your modules from your ftp or WWW site into your own directory on
+CPAN!
+
+Please remember to send me an updated entry for the Module list!
+
+=item Take care when changing a released module.
+
+Always strive to remain compatible with previous released versions.
+Otherwise try to add a mechanism to revert to the
+old behaviour if people rely on it. Document incompatible changes.
+
+=back
+
+=back
+
+=head2 Guidelines for Converting Perl 4 Library Scripts into Modules
+
+=over 4
+
+=item There is no requirement to convert anything.
+
+If it ain't broke, don't fix it! Perl 4 library scripts should
+continue to work with no problems. You may need to make some minor
+changes (like escaping non-array @'s in double quoted strings) but
+there is no need to convert a .pl file into a Module for just that.
+
+=item Consider the implications.
+
+All Perl applications that make use of the script will need to
+be changed (slightly) if the script is converted into a module. Is
+it worth it unless you plan to make other changes at the same time?
+
+=item Make the most of the opportunity.
+
+If you are going to convert the script to a module you can use the
+opportunity to redesign the interface. The 'Guidelines for Module
+Creation' above include many of the issues you should consider.
+
+=item The pl2pm utility will get you started.
+
+This utility will read *.pl files (given as parameters) and write
+corresponding *.pm files. The pl2pm utilities does the following:
+
+=over 10
+
+=item *
+Adds the standard Module prologue lines
+
+=item *
+Converts package specifiers from ' to ::
+
+=item *
+Converts die(...) to croak(...)
+
+=item *
+Several other minor changes
+
+=back
+
+Being a mechanical process pl2pm is not bullet proof. The converted
+code will need careful checking, especially any package statements.
+Don't delete the original .pl file till the new .pm one works!
+
+=back
+
+=head2 Guidelines for Reusing Application Code
+
+=over 4
+
+=item Complete applications rarely belong in the Perl Module Library.
+
+=item Many applications contain some Perl code that could be reused.
+
+Help save the world! Share your code in a form that makes it easy
+to reuse.
+
+=item Break-out the reusable code into one or more separate module files.
+
+=item Take the opportunity to reconsider and redesign the interfaces.
+
+=item In some cases the 'application' can then be reduced to a small
+
+fragment of code built on top of the reusable modules. In these cases
+the application could invoked as:
+
+ % perl -e 'use Module::Name; method(@ARGV)' ...
+or
+ % perl -mModule::Name ... (in perl5.002 or higher)
+
+=back
+
+=head1 NOTE
+
+Perl does not enforce private and public parts of its modules as you may
+have been used to in other languages like C++, Ada, or Modula-17. Perl
+doesn't have an infatuation with enforced privacy. It would prefer
+that you stayed out of its living room because you weren't invited, not
+because it has a shotgun.
+
+The module and its user have a contract, part of which is common law,
+and part of which is "written". Part of the common law contract is
+that a module doesn't pollute any namespace it wasn't asked to. The
+written contract for the module (A.K.A. documentation) may make other
+provisions. But then you know when you C<use RedefineTheWorld> that
+you're redefining the world and willing to take the consequences.
diff --git a/contrib/perl5/pod/perlobj.pod b/contrib/perl5/pod/perlobj.pod
new file mode 100644
index 000000000000..f10fbdfe2e62
--- /dev/null
+++ b/contrib/perl5/pod/perlobj.pod
@@ -0,0 +1,541 @@
+=head1 NAME
+
+perlobj - Perl objects
+
+=head1 DESCRIPTION
+
+First of all, you need to understand what references are in Perl.
+See L<perlref> for that. Second, if you still find the following
+reference work too complicated, a tutorial on object-oriented programming
+in Perl can be found in L<perltoot>.
+
+If you're still with us, then
+here are three very simple definitions that you should find reassuring.
+
+=over 4
+
+=item 1.
+
+An object is simply a reference that happens to know which class it
+belongs to.
+
+=item 2.
+
+A class is simply a package that happens to provide methods to deal
+with object references.
+
+=item 3.
+
+A method is simply a subroutine that expects an object reference (or
+a package name, for class methods) as the first argument.
+
+=back
+
+We'll cover these points now in more depth.
+
+=head2 An Object is Simply a Reference
+
+Unlike say C++, Perl doesn't provide any special syntax for
+constructors. A constructor is merely a subroutine that returns a
+reference to something "blessed" into a class, generally the
+class that the subroutine is defined in. Here is a typical
+constructor:
+
+ package Critter;
+ sub new { bless {} }
+
+That word C<new> isn't special. You could have written
+a construct this way, too:
+
+ package Critter;
+ sub spawn { bless {} }
+
+In fact, this might even be preferable, because the C++ programmers won't
+be tricked into thinking that C<new> works in Perl as it does in C++.
+It doesn't. We recommend that you name your constructors whatever
+makes sense in the context of the problem you're solving. For example,
+constructors in the Tk extension to Perl are named after the widgets
+they create.
+
+One thing that's different about Perl constructors compared with those in
+C++ is that in Perl, they have to allocate their own memory. (The other
+things is that they don't automatically call overridden base-class
+constructors.) The C<{}> allocates an anonymous hash containing no
+key/value pairs, and returns it The bless() takes that reference and
+tells the object it references that it's now a Critter, and returns
+the reference. This is for convenience, because the referenced object
+itself knows that it has been blessed, and the reference to it could
+have been returned directly, like this:
+
+ sub new {
+ my $self = {};
+ bless $self;
+ return $self;
+ }
+
+In fact, you often see such a thing in more complicated constructors
+that wish to call methods in the class as part of the construction:
+
+ sub new {
+ my $self = {};
+ bless $self;
+ $self->initialize();
+ return $self;
+ }
+
+If you care about inheritance (and you should; see
+L<perlmod/"Modules: Creation, Use, and Abuse">),
+then you want to use the two-arg form of bless
+so that your constructors may be inherited:
+
+ sub new {
+ my $class = shift;
+ my $self = {};
+ bless $self, $class;
+ $self->initialize();
+ return $self;
+ }
+
+Or if you expect people to call not just C<CLASS-E<gt>new()> but also
+C<$obj-E<gt>new()>, then use something like this. The initialize()
+method used will be of whatever $class we blessed the
+object into:
+
+ sub new {
+ my $this = shift;
+ my $class = ref($this) || $this;
+ my $self = {};
+ bless $self, $class;
+ $self->initialize();
+ return $self;
+ }
+
+Within the class package, the methods will typically deal with the
+reference as an ordinary reference. Outside the class package,
+the reference is generally treated as an opaque value that may
+be accessed only through the class's methods.
+
+A constructor may re-bless a referenced object currently belonging to
+another class, but then the new class is responsible for all cleanup
+later. The previous blessing is forgotten, as an object may belong
+to only one class at a time. (Although of course it's free to
+inherit methods from many classes.) If you find yourself having to
+do this, the parent class is probably misbehaving, though.
+
+A clarification: Perl objects are blessed. References are not. Objects
+know which package they belong to. References do not. The bless()
+function uses the reference to find the object. Consider
+the following example:
+
+ $a = {};
+ $b = $a;
+ bless $a, BLAH;
+ print "\$b is a ", ref($b), "\n";
+
+This reports $b as being a BLAH, so obviously bless()
+operated on the object and not on the reference.
+
+=head2 A Class is Simply a Package
+
+Unlike say C++, Perl doesn't provide any special syntax for class
+definitions. You use a package as a class by putting method
+definitions into the class.
+
+There is a special array within each package called @ISA, which says
+where else to look for a method if you can't find it in the current
+package. This is how Perl implements inheritance. Each element of the
+@ISA array is just the name of another package that happens to be a
+class package. The classes are searched (depth first) for missing
+methods in the order that they occur in @ISA. The classes accessible
+through @ISA are known as base classes of the current class.
+
+All classes implicitly inherit from class C<UNIVERSAL> as their
+last base class. Several commonly used methods are automatically
+supplied in the UNIVERSAL class; see L<"Default UNIVERSAL methods"> for
+more details.
+
+If a missing method is found in one of the base classes, it is cached
+in the current class for efficiency. Changing @ISA or defining new
+subroutines invalidates the cache and causes Perl to do the lookup again.
+
+If neither the current class, its named base classes, nor the UNIVERSAL
+class contains the requested method, these three places are searched
+all over again, this time looking for a method named AUTOLOAD(). If an
+AUTOLOAD is found, this method is called on behalf of the missing method,
+setting the package global $AUTOLOAD to be the fully qualified name of
+the method that was intended to be called.
+
+If none of that works, Perl finally gives up and complains.
+
+Perl classes do method inheritance only. Data inheritance is left up
+to the class itself. By and large, this is not a problem in Perl,
+because most classes model the attributes of their object using an
+anonymous hash, which serves as its own little namespace to be carved up
+by the various classes that might want to do something with the object.
+The only problem with this is that you can't sure that you aren't using
+a piece of the hash that isn't already used. A reasonable workaround
+is to prepend your fieldname in the hash with the package name.
+
+ sub bump {
+ my $self = shift;
+ $self->{ __PACKAGE__ . ".count"}++;
+ }
+
+=head2 A Method is Simply a Subroutine
+
+Unlike say C++, Perl doesn't provide any special syntax for method
+definition. (It does provide a little syntax for method invocation
+though. More on that later.) A method expects its first argument
+to be the object (reference) or package (string) it is being invoked on. There are just two
+types of methods, which we'll call class and instance.
+(Sometimes you'll hear these called static and virtual, in honor of
+the two C++ method types they most closely resemble.)
+
+A class method expects a class name as the first argument. It
+provides functionality for the class as a whole, not for any individual
+object belonging to the class. Constructors are typically class
+methods. Many class methods simply ignore their first argument, because
+they already know what package they're in, and don't care what package
+they were invoked via. (These aren't necessarily the same, because
+class methods follow the inheritance tree just like ordinary instance
+methods.) Another typical use for class methods is to look up an
+object by name:
+
+ sub find {
+ my ($class, $name) = @_;
+ $objtable{$name};
+ }
+
+An instance method expects an object reference as its first argument.
+Typically it shifts the first argument into a "self" or "this" variable,
+and then uses that as an ordinary reference.
+
+ sub display {
+ my $self = shift;
+ my @keys = @_ ? @_ : sort keys %$self;
+ foreach $key (@keys) {
+ print "\t$key => $self->{$key}\n";
+ }
+ }
+
+=head2 Method Invocation
+
+There are two ways to invoke a method, one of which you're already
+familiar with, and the other of which will look familiar. Perl 4
+already had an "indirect object" syntax that you use when you say
+
+ print STDERR "help!!!\n";
+
+This same syntax can be used to call either class or instance methods.
+We'll use the two methods defined above, the class method to lookup
+an object reference and the instance method to print out its attributes.
+
+ $fred = find Critter "Fred";
+ display $fred 'Height', 'Weight';
+
+These could be combined into one statement by using a BLOCK in the
+indirect object slot:
+
+ display {find Critter "Fred"} 'Height', 'Weight';
+
+For C++ fans, there's also a syntax using -E<gt> notation that does exactly
+the same thing. The parentheses are required if there are any arguments.
+
+ $fred = Critter->find("Fred");
+ $fred->display('Height', 'Weight');
+
+or in one statement,
+
+ Critter->find("Fred")->display('Height', 'Weight');
+
+There are times when one syntax is more readable, and times when the
+other syntax is more readable. The indirect object syntax is less
+cluttered, but it has the same ambiguity as ordinary list operators.
+Indirect object method calls are parsed using the same rule as list
+operators: "If it looks like a function, it is a function". (Presuming
+for the moment that you think two words in a row can look like a
+function name. C++ programmers seem to think so with some regularity,
+especially when the first word is "new".) Thus, the parentheses of
+
+ new Critter ('Barney', 1.5, 70)
+
+are assumed to surround ALL the arguments of the method call, regardless
+of what comes after. Saying
+
+ new Critter ('Bam' x 2), 1.4, 45
+
+would be equivalent to
+
+ Critter->new('Bam' x 2), 1.4, 45
+
+which is unlikely to do what you want.
+
+There are times when you wish to specify which class's method to use.
+In this case, you can call your method as an ordinary subroutine
+call, being sure to pass the requisite first argument explicitly:
+
+ $fred = MyCritter::find("Critter", "Fred");
+ MyCritter::display($fred, 'Height', 'Weight');
+
+Note however, that this does not do any inheritance. If you wish
+merely to specify that Perl should I<START> looking for a method in a
+particular package, use an ordinary method call, but qualify the method
+name with the package like this:
+
+ $fred = Critter->MyCritter::find("Fred");
+ $fred->MyCritter::display('Height', 'Weight');
+
+If you're trying to control where the method search begins I<and> you're
+executing in the class itself, then you may use the SUPER pseudo class,
+which says to start looking in your base class's @ISA list without having
+to name it explicitly:
+
+ $self->SUPER::display('Height', 'Weight');
+
+Please note that the C<SUPER::> construct is meaningful I<only> within the
+class.
+
+Sometimes you want to call a method when you don't know the method name
+ahead of time. You can use the arrow form, replacing the method name
+with a simple scalar variable containing the method name:
+
+ $method = $fast ? "findfirst" : "findbest";
+ $fred->$method(@args);
+
+=head2 Default UNIVERSAL methods
+
+The C<UNIVERSAL> package automatically contains the following methods that
+are inherited by all other classes:
+
+=over 4
+
+=item isa(CLASS)
+
+C<isa> returns I<true> if its object is blessed into a subclass of C<CLASS>
+
+C<isa> is also exportable and can be called as a sub with two arguments. This
+allows the ability to check what a reference points to. Example
+
+ use UNIVERSAL qw(isa);
+
+ if(isa($ref, 'ARRAY')) {
+ #...
+ }
+
+=item can(METHOD)
+
+C<can> checks to see if its object has a method called C<METHOD>,
+if it does then a reference to the sub is returned, if it does not then
+I<undef> is returned.
+
+=item VERSION( [NEED] )
+
+C<VERSION> returns the version number of the class (package). If the
+NEED argument is given then it will check that the current version (as
+defined by the $VERSION variable in the given package) not less than
+NEED; it will die if this is not the case. This method is normally
+called as a class method. This method is called automatically by the
+C<VERSION> form of C<use>.
+
+ use A 1.2 qw(some imported subs);
+ # implies:
+ A->VERSION(1.2);
+
+=back
+
+B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and
+C<isa> uses a very similar method and cache-ing strategy. This may cause
+strange effects if the Perl code dynamically changes @ISA in any package.
+
+You may add other methods to the UNIVERSAL class via Perl or XS code.
+You do not need to C<use UNIVERSAL> in order to make these methods
+available to your program. This is necessary only if you wish to
+have C<isa> available as a plain subroutine in the current package.
+
+=head2 Destructors
+
+When the last reference to an object goes away, the object is
+automatically destroyed. (This may even be after you exit, if you've
+stored references in global variables.) If you want to capture control
+just before the object is freed, you may define a DESTROY method in
+your class. It will automatically be called at the appropriate moment,
+and you can do any extra cleanup you need to do. Perl passes a reference
+to the object under destruction as the first (and only) argument. Beware
+that the reference is a read-only value, and cannot be modified by
+manipulating C<$_[0]> within the destructor. The object itself (i.e.
+the thingy the reference points to, namely C<${$_[0]}>, C<@{$_[0]}>,
+C<%{$_[0]}> etc.) is not similarly constrained.
+
+If you arrange to re-bless the reference before the destructor returns,
+perl will again call the DESTROY method for the re-blessed object after
+the current one returns. This can be used for clean delegation of
+object destruction, or for ensuring that destructors in the base classes
+of your choosing get called. Explicitly calling DESTROY is also possible,
+but is usually never needed.
+
+Do not confuse the foregoing with how objects I<CONTAINED> in the current
+one are destroyed. Such objects will be freed and destroyed automatically
+when the current object is freed, provided no other references to them exist
+elsewhere.
+
+=head2 WARNING
+
+While indirect object syntax may well be appealing to English speakers and
+to C++ programmers, be not seduced! It suffers from two grave problems.
+
+The first problem is that an indirect object is limited to a name,
+a scalar variable, or a block, because it would have to do too much
+lookahead otherwise, just like any other postfix dereference in the
+language. (These are the same quirky rules as are used for the filehandle
+slot in functions like C<print> and C<printf>.) This can lead to horribly
+confusing precedence problems, as in these next two lines:
+
+ move $obj->{FIELD}; # probably wrong!
+ move $ary[$i]; # probably wrong!
+
+Those actually parse as the very surprising:
+
+ $obj->move->{FIELD}; # Well, lookee here
+ $ary->move->[$i]; # Didn't expect this one, eh?
+
+Rather than what you might have expected:
+
+ $obj->{FIELD}->move(); # You should be so lucky.
+ $ary[$i]->move; # Yeah, sure.
+
+The left side of ``-E<gt>'' is not so limited, because it's an infix operator,
+not a postfix operator.
+
+As if that weren't bad enough, think about this: Perl must guess I<at
+compile time> whether C<name> and C<move> above are functions or methods.
+Usually Perl gets it right, but when it doesn't it, you get a function
+call compiled as a method, or vice versa. This can introduce subtle
+bugs that are hard to unravel. For example, calling a method C<new>
+in indirect notation--as C++ programmers are so wont to do--can
+be miscompiled into a subroutine call if there's already a C<new>
+function in scope. You'd end up calling the current package's C<new>
+as a subroutine, rather than the desired class's method. The compiler
+tries to cheat by remembering bareword C<require>s, but the grief if it
+messes up just isn't worth the years of debugging it would likely take
+you to to track such subtle bugs down.
+
+The infix arrow notation using ``C<-E<gt>>'' doesn't suffer from either
+of these disturbing ambiguities, so we recommend you use it exclusively.
+
+=head2 Summary
+
+That's about all there is to it. Now you need just to go off and buy a
+book about object-oriented design methodology, and bang your forehead
+with it for the next six months or so.
+
+=head2 Two-Phased Garbage Collection
+
+For most purposes, Perl uses a fast and simple reference-based
+garbage collection system. For this reason, there's an extra
+dereference going on at some level, so if you haven't built
+your Perl executable using your C compiler's C<-O> flag, performance
+will suffer. If you I<have> built Perl with C<cc -O>, then this
+probably won't matter.
+
+A more serious concern is that unreachable memory with a non-zero
+reference count will not normally get freed. Therefore, this is a bad
+idea:
+
+ {
+ my $a;
+ $a = \$a;
+ }
+
+Even thought $a I<should> go away, it can't. When building recursive data
+structures, you'll have to break the self-reference yourself explicitly
+if you don't care to leak. For example, here's a self-referential
+node such as one might use in a sophisticated tree structure:
+
+ sub new_node {
+ my $self = shift;
+ my $class = ref($self) || $self;
+ my $node = {};
+ $node->{LEFT} = $node->{RIGHT} = $node;
+ $node->{DATA} = [ @_ ];
+ return bless $node => $class;
+ }
+
+If you create nodes like that, they (currently) won't go away unless you
+break their self reference yourself. (In other words, this is not to be
+construed as a feature, and you shouldn't depend on it.)
+
+Almost.
+
+When an interpreter thread finally shuts down (usually when your program
+exits), then a rather costly but complete mark-and-sweep style of garbage
+collection is performed, and everything allocated by that thread gets
+destroyed. This is essential to support Perl as an embedded or a
+multithreadable language. For example, this program demonstrates Perl's
+two-phased garbage collection:
+
+ #!/usr/bin/perl
+ package Subtle;
+
+ sub new {
+ my $test;
+ $test = \$test;
+ warn "CREATING " . \$test;
+ return bless \$test;
+ }
+
+ sub DESTROY {
+ my $self = shift;
+ warn "DESTROYING $self";
+ }
+
+ package main;
+
+ warn "starting program";
+ {
+ my $a = Subtle->new;
+ my $b = Subtle->new;
+ $$a = 0; # break selfref
+ warn "leaving block";
+ }
+
+ warn "just exited block";
+ warn "time to die...";
+ exit;
+
+When run as F</tmp/test>, the following output is produced:
+
+ starting program at /tmp/test line 18.
+ CREATING SCALAR(0x8e5b8) at /tmp/test line 7.
+ CREATING SCALAR(0x8e57c) at /tmp/test line 7.
+ leaving block at /tmp/test line 23.
+ DESTROYING Subtle=SCALAR(0x8e5b8) at /tmp/test line 13.
+ just exited block at /tmp/test line 26.
+ time to die... at /tmp/test line 27.
+ DESTROYING Subtle=SCALAR(0x8e57c) during global destruction.
+
+Notice that "global destruction" bit there? That's the thread
+garbage collector reaching the unreachable.
+
+Objects are always destructed, even when regular refs aren't and in fact
+are destructed in a separate pass before ordinary refs just to try to
+prevent object destructors from using refs that have been themselves
+destructed. Plain refs are only garbage-collected if the destruct level
+is greater than 0. You can test the higher levels of global destruction
+by setting the PERL_DESTRUCT_LEVEL environment variable, presuming
+C<-DDEBUGGING> was enabled during perl build time.
+
+A more complete garbage collection strategy will be implemented
+at a future date.
+
+In the meantime, the best solution is to create a non-recursive container
+class that holds a pointer to the self-referential data structure.
+Define a DESTROY method for the containing object's class that manually
+breaks the circularities in the self-referential structure.
+
+=head1 SEE ALSO
+
+A kinder, gentler tutorial on object-oriented programming in Perl can
+be found in L<perltoot>.
+You should also check out L<perlbot> for other object tricks, traps, and tips,
+as well as L<perlmodlib> for some style guides on constructing both modules
+and classes.
diff --git a/contrib/perl5/pod/perlop.pod b/contrib/perl5/pod/perlop.pod
new file mode 100644
index 000000000000..c7209fac28e3
--- /dev/null
+++ b/contrib/perl5/pod/perlop.pod
@@ -0,0 +1,1724 @@
+=head1 NAME
+
+perlop - Perl operators and precedence
+
+=head1 SYNOPSIS
+
+Perl operators have the following associativity and precedence,
+listed from highest precedence to lowest. Note that all operators
+borrowed from C keep the same precedence relationship with each other,
+even where C's precedence is slightly screwy. (This makes learning
+Perl easier for C folks.) With very few exceptions, these all
+operate on scalar values only, not array values.
+
+ left terms and list operators (leftward)
+ left ->
+ nonassoc ++ --
+ right **
+ right ! ~ \ and unary + and -
+ left =~ !~
+ left * / % x
+ left + - .
+ left << >>
+ nonassoc named unary operators
+ nonassoc < > <= >= lt gt le ge
+ nonassoc == != <=> eq ne cmp
+ left &
+ left | ^
+ left &&
+ left ||
+ nonassoc .. ...
+ right ?:
+ right = += -= *= etc.
+ left , =>
+ nonassoc list operators (rightward)
+ right not
+ left and
+ left or xor
+
+In the following sections, these operators are covered in precedence order.
+
+Many operators can be overloaded for objects. See L<overload>.
+
+=head1 DESCRIPTION
+
+=head2 Terms and List Operators (Leftward)
+
+A TERM has the highest precedence in Perl. They includes variables,
+quote and quote-like operators, any expression in parentheses,
+and any function whose arguments are parenthesized. Actually, there
+aren't really functions in this sense, just list operators and unary
+operators behaving as functions because you put parentheses around
+the arguments. These are all documented in L<perlfunc>.
+
+If any list operator (print(), etc.) or any unary operator (chdir(), etc.)
+is followed by a left parenthesis as the next token, the operator and
+arguments within parentheses are taken to be of highest precedence,
+just like a normal function call.
+
+In the absence of parentheses, the precedence of list operators such as
+C<print>, C<sort>, or C<chmod> is either very high or very low depending on
+whether you are looking at the left side or the right side of the operator.
+For example, in
+
+ @ary = (1, 3, sort 4, 2);
+ print @ary; # prints 1324
+
+the commas on the right of the sort are evaluated before the sort, but
+the commas on the left are evaluated after. In other words, list
+operators tend to gobble up all the arguments that follow them, and
+then act like a simple TERM with regard to the preceding expression.
+Note that you have to be careful with parentheses:
+
+ # These evaluate exit before doing the print:
+ print($foo, exit); # Obviously not what you want.
+ print $foo, exit; # Nor is this.
+
+ # These do the print before evaluating exit:
+ (print $foo), exit; # This is what you want.
+ print($foo), exit; # Or this.
+ print ($foo), exit; # Or even this.
+
+Also note that
+
+ print ($foo & 255) + 1, "\n";
+
+probably doesn't do what you expect at first glance. See
+L<Named Unary Operators> for more discussion of this.
+
+Also parsed as terms are the C<do {}> and C<eval {}> constructs, as
+well as subroutine and method calls, and the anonymous
+constructors C<[]> and C<{}>.
+
+See also L<Quote and Quote-like Operators> toward the end of this section,
+as well as L<"I/O Operators">.
+
+=head2 The Arrow Operator
+
+Just as in C and C++, "C<-E<gt>>" is an infix dereference operator. If the
+right side is either a C<[...]> or C<{...}> subscript, then the left side
+must be either a hard or symbolic reference to an array or hash (or
+a location capable of holding a hard reference, if it's an lvalue (assignable)).
+See L<perlref>.
+
+Otherwise, the right side is a method name or a simple scalar variable
+containing the method name, and the left side must either be an object
+(a blessed reference) or a class name (that is, a package name).
+See L<perlobj>.
+
+=head2 Auto-increment and Auto-decrement
+
+"++" and "--" work as in C. That is, if placed before a variable, they
+increment or decrement the variable before returning the value, and if
+placed after, increment or decrement the variable after returning the value.
+
+The auto-increment operator has a little extra builtin magic to it. If
+you increment a variable that is numeric, or that has ever been used in
+a numeric context, you get a normal increment. If, however, the
+variable has been used in only string contexts since it was set, and
+has a value that is not the empty string and matches the pattern
+C</^[a-zA-Z]*[0-9]*$/>, the increment is done as a string, preserving each
+character within its range, with carry:
+
+ print ++($foo = '99'); # prints '100'
+ print ++($foo = 'a0'); # prints 'a1'
+ print ++($foo = 'Az'); # prints 'Ba'
+ print ++($foo = 'zz'); # prints 'aaa'
+
+The auto-decrement operator is not magical.
+
+=head2 Exponentiation
+
+Binary "**" is the exponentiation operator. Note that it binds even more
+tightly than unary minus, so -2**4 is -(2**4), not (-2)**4. (This is
+implemented using C's pow(3) function, which actually works on doubles
+internally.)
+
+=head2 Symbolic Unary Operators
+
+Unary "!" performs logical negation, i.e., "not". See also C<not> for a lower
+precedence version of this.
+
+Unary "-" performs arithmetic negation if the operand is numeric. If
+the operand is an identifier, a string consisting of a minus sign
+concatenated with the identifier is returned. Otherwise, if the string
+starts with a plus or minus, a string starting with the opposite sign
+is returned. One effect of these rules is that C<-bareword> is equivalent
+to C<"-bareword">.
+
+Unary "~" performs bitwise negation, i.e., 1's complement. For example,
+C<0666 &~ 027> is 0640. (See also L<Integer Arithmetic> and L<Bitwise
+String Operators>.)
+
+Unary "+" has no effect whatsoever, even on strings. It is useful
+syntactically for separating a function name from a parenthesized expression
+that would otherwise be interpreted as the complete list of function
+arguments. (See examples above under L<Terms and List Operators (Leftward)>.)
+
+Unary "\" creates a reference to whatever follows it. See L<perlref>.
+Do not confuse this behavior with the behavior of backslash within a
+string, although both forms do convey the notion of protecting the next
+thing from interpretation.
+
+=head2 Binding Operators
+
+Binary "=~" binds a scalar expression to a pattern match. Certain operations
+search or modify the string $_ by default. This operator makes that kind
+of operation work on some other string. The right argument is a search
+pattern, substitution, or transliteration. The left argument is what is
+supposed to be searched, substituted, or transliterated instead of the default
+$_. The return value indicates the success of the operation. (If the
+right argument is an expression rather than a search pattern,
+substitution, or transliteration, it is interpreted as a search pattern at run
+time. This can be is less efficient than an explicit search, because the
+pattern must be compiled every time the expression is evaluated.
+
+Binary "!~" is just like "=~" except the return value is negated in
+the logical sense.
+
+=head2 Multiplicative Operators
+
+Binary "*" multiplies two numbers.
+
+Binary "/" divides two numbers.
+
+Binary "%" computes the modulus of two numbers. Given integer
+operands C<$a> and C<$b>: If C<$b> is positive, then C<$a % $b> is
+C<$a> minus the largest multiple of C<$b> that is not greater than
+C<$a>. If C<$b> is negative, then C<$a % $b> is C<$a> minus the
+smallest multiple of C<$b> that is not less than C<$a> (i.e. the
+result will be less than or equal to zero).
+Note than when C<use integer> is in scope, "%" give you direct access
+to the modulus operator as implemented by your C compiler. This
+operator is not as well defined for negative operands, but it will
+execute faster.
+
+Binary "x" is the repetition operator. In scalar context, it
+returns a string consisting of the left operand repeated the number of
+times specified by the right operand. In list context, if the left
+operand is a list in parentheses, it repeats the list.
+
+ print '-' x 80; # print row of dashes
+
+ print "\t" x ($tab/8), ' ' x ($tab%8); # tab over
+
+ @ones = (1) x 80; # a list of 80 1's
+ @ones = (5) x @ones; # set all elements to 5
+
+
+=head2 Additive Operators
+
+Binary "+" returns the sum of two numbers.
+
+Binary "-" returns the difference of two numbers.
+
+Binary "." concatenates two strings.
+
+=head2 Shift Operators
+
+Binary "<<" returns the value of its left argument shifted left by the
+number of bits specified by the right argument. Arguments should be
+integers. (See also L<Integer Arithmetic>.)
+
+Binary ">>" returns the value of its left argument shifted right by
+the number of bits specified by the right argument. Arguments should
+be integers. (See also L<Integer Arithmetic>.)
+
+=head2 Named Unary Operators
+
+The various named unary operators are treated as functions with one
+argument, with optional parentheses. These include the filetest
+operators, like C<-f>, C<-M>, etc. See L<perlfunc>.
+
+If any list operator (print(), etc.) or any unary operator (chdir(), etc.)
+is followed by a left parenthesis as the next token, the operator and
+arguments within parentheses are taken to be of highest precedence,
+just like a normal function call. Examples:
+
+ chdir $foo || die; # (chdir $foo) || die
+ chdir($foo) || die; # (chdir $foo) || die
+ chdir ($foo) || die; # (chdir $foo) || die
+ chdir +($foo) || die; # (chdir $foo) || die
+
+but, because * is higher precedence than ||:
+
+ chdir $foo * 20; # chdir ($foo * 20)
+ chdir($foo) * 20; # (chdir $foo) * 20
+ chdir ($foo) * 20; # (chdir $foo) * 20
+ chdir +($foo) * 20; # chdir ($foo * 20)
+
+ rand 10 * 20; # rand (10 * 20)
+ rand(10) * 20; # (rand 10) * 20
+ rand (10) * 20; # (rand 10) * 20
+ rand +(10) * 20; # rand (10 * 20)
+
+See also L<"Terms and List Operators (Leftward)">.
+
+=head2 Relational Operators
+
+Binary "E<lt>" returns true if the left argument is numerically less than
+the right argument.
+
+Binary "E<gt>" returns true if the left argument is numerically greater
+than the right argument.
+
+Binary "E<lt>=" returns true if the left argument is numerically less than
+or equal to the right argument.
+
+Binary "E<gt>=" returns true if the left argument is numerically greater
+than or equal to the right argument.
+
+Binary "lt" returns true if the left argument is stringwise less than
+the right argument.
+
+Binary "gt" returns true if the left argument is stringwise greater
+than the right argument.
+
+Binary "le" returns true if the left argument is stringwise less than
+or equal to the right argument.
+
+Binary "ge" returns true if the left argument is stringwise greater
+than or equal to the right argument.
+
+=head2 Equality Operators
+
+Binary "==" returns true if the left argument is numerically equal to
+the right argument.
+
+Binary "!=" returns true if the left argument is numerically not equal
+to the right argument.
+
+Binary "E<lt>=E<gt>" returns -1, 0, or 1 depending on whether the left
+argument is numerically less than, equal to, or greater than the right
+argument.
+
+Binary "eq" returns true if the left argument is stringwise equal to
+the right argument.
+
+Binary "ne" returns true if the left argument is stringwise not equal
+to the right argument.
+
+Binary "cmp" returns -1, 0, or 1 depending on whether the left argument is stringwise
+less than, equal to, or greater than the right argument.
+
+"lt", "le", "ge", "gt" and "cmp" use the collation (sort) order specified
+by the current locale if C<use locale> is in effect. See L<perllocale>.
+
+=head2 Bitwise And
+
+Binary "&" returns its operators ANDed together bit by bit.
+(See also L<Integer Arithmetic> and L<Bitwise String Operators>.)
+
+=head2 Bitwise Or and Exclusive Or
+
+Binary "|" returns its operators ORed together bit by bit.
+(See also L<Integer Arithmetic> and L<Bitwise String Operators>.)
+
+Binary "^" returns its operators XORed together bit by bit.
+(See also L<Integer Arithmetic> and L<Bitwise String Operators>.)
+
+=head2 C-style Logical And
+
+Binary "&&" performs a short-circuit logical AND operation. That is,
+if the left operand is false, the right operand is not even evaluated.
+Scalar or list context propagates down to the right operand if it
+is evaluated.
+
+=head2 C-style Logical Or
+
+Binary "||" performs a short-circuit logical OR operation. That is,
+if the left operand is true, the right operand is not even evaluated.
+Scalar or list context propagates down to the right operand if it
+is evaluated.
+
+The C<||> and C<&&> operators differ from C's in that, rather than returning
+0 or 1, they return the last value evaluated. Thus, a reasonably portable
+way to find out the home directory (assuming it's not "0") might be:
+
+ $home = $ENV{'HOME'} || $ENV{'LOGDIR'} ||
+ (getpwuid($<))[7] || die "You're homeless!\n";
+
+In particular, this means that you shouldn't use this
+for selecting between two aggregates for assignment:
+
+ @a = @b || @c; # this is wrong
+ @a = scalar(@b) || @c; # really meant this
+ @a = @b ? @b : @c; # this works fine, though
+
+As more readable alternatives to C<&&> and C<||> when used for
+control flow, Perl provides C<and> and C<or> operators (see below).
+The short-circuit behavior is identical. The precedence of "and" and
+"or" is much lower, however, so that you can safely use them after a
+list operator without the need for parentheses:
+
+ unlink "alpha", "beta", "gamma"
+ or gripe(), next LINE;
+
+With the C-style operators that would have been written like this:
+
+ unlink("alpha", "beta", "gamma")
+ || (gripe(), next LINE);
+
+Use "or" for assignment is unlikely to do what you want; see below.
+
+=head2 Range Operators
+
+Binary ".." is the range operator, which is really two different
+operators depending on the context. In list context, it returns an
+array of values counting (by ones) from the left value to the right
+value. This is useful for writing C<foreach (1..10)> loops and for
+doing slice operations on arrays. In the current implementation, no
+temporary array is created when the range operator is used as the
+expression in C<foreach> loops, but older versions of Perl might burn
+a lot of memory when you write something like this:
+
+ for (1 .. 1_000_000) {
+ # code
+ }
+
+In scalar context, ".." returns a boolean value. The operator is
+bistable, like a flip-flop, and emulates the line-range (comma) operator
+of B<sed>, B<awk>, and various editors. Each ".." operator maintains its
+own boolean state. It is false as long as its left operand is false.
+Once the left operand is true, the range operator stays true until the
+right operand is true, I<AFTER> which the range operator becomes false
+again. (It doesn't become false till the next time the range operator is
+evaluated. It can test the right operand and become false on the same
+evaluation it became true (as in B<awk>), but it still returns true once.
+If you don't want it to test the right operand till the next evaluation
+(as in B<sed>), use three dots ("...") instead of two.) The right
+operand is not evaluated while the operator is in the "false" state, and
+the left operand is not evaluated while the operator is in the "true"
+state. The precedence is a little lower than || and &&. The value
+returned is either the empty string for false, or a sequence number
+(beginning with 1) for true. The sequence number is reset for each range
+encountered. The final sequence number in a range has the string "E0"
+appended to it, which doesn't affect its numeric value, but gives you
+something to search for if you want to exclude the endpoint. You can
+exclude the beginning point by waiting for the sequence number to be
+greater than 1. If either operand of scalar ".." is a constant expression,
+that operand is implicitly compared to the C<$.> variable, the current
+line number. Examples:
+
+As a scalar operator:
+
+ if (101 .. 200) { print; } # print 2nd hundred lines
+ next line if (1 .. /^$/); # skip header lines
+ s/^/> / if (/^$/ .. eof()); # quote body
+
+ # parse mail messages
+ while (<>) {
+ $in_header = 1 .. /^$/;
+ $in_body = /^$/ .. eof();
+ # do something based on those
+ } continue {
+ close ARGV if eof; # reset $. each file
+ }
+
+As a list operator:
+
+ for (101 .. 200) { print; } # print $_ 100 times
+ @foo = @foo[0 .. $#foo]; # an expensive no-op
+ @foo = @foo[$#foo-4 .. $#foo]; # slice last 5 items
+
+The range operator (in list context) makes use of the magical
+auto-increment algorithm if the operands are strings. You
+can say
+
+ @alphabet = ('A' .. 'Z');
+
+to get all the letters of the alphabet, or
+
+ $hexdigit = (0 .. 9, 'a' .. 'f')[$num & 15];
+
+to get a hexadecimal digit, or
+
+ @z2 = ('01' .. '31'); print $z2[$mday];
+
+to get dates with leading zeros. If the final value specified is not
+in the sequence that the magical increment would produce, the sequence
+goes until the next value would be longer than the final value
+specified.
+
+=head2 Conditional Operator
+
+Ternary "?:" is the conditional operator, just as in C. It works much
+like an if-then-else. If the argument before the ? is true, the
+argument before the : is returned, otherwise the argument after the :
+is returned. For example:
+
+ printf "I have %d dog%s.\n", $n,
+ ($n == 1) ? '' : "s";
+
+Scalar or list context propagates downward into the 2nd
+or 3rd argument, whichever is selected.
+
+ $a = $ok ? $b : $c; # get a scalar
+ @a = $ok ? @b : @c; # get an array
+ $a = $ok ? @b : @c; # oops, that's just a count!
+
+The operator may be assigned to if both the 2nd and 3rd arguments are
+legal lvalues (meaning that you can assign to them):
+
+ ($a_or_b ? $a : $b) = $c;
+
+This is not necessarily guaranteed to contribute to the readability of your program.
+
+Because this operator produces an assignable result, using assignments
+without parentheses will get you in trouble. For example, this:
+
+ $a % 2 ? $a += 10 : $a += 2
+
+Really means this:
+
+ (($a % 2) ? ($a += 10) : $a) += 2
+
+Rather than this:
+
+ ($a % 2) ? ($a += 10) : ($a += 2)
+
+=head2 Assignment Operators
+
+"=" is the ordinary assignment operator.
+
+Assignment operators work as in C. That is,
+
+ $a += 2;
+
+is equivalent to
+
+ $a = $a + 2;
+
+although without duplicating any side effects that dereferencing the lvalue
+might trigger, such as from tie(). Other assignment operators work similarly.
+The following are recognized:
+
+ **= += *= &= <<= &&=
+ -= /= |= >>= ||=
+ .= %= ^=
+ x=
+
+Note that while these are grouped by family, they all have the precedence
+of assignment.
+
+Unlike in C, the assignment operator produces a valid lvalue. Modifying
+an assignment is equivalent to doing the assignment and then modifying
+the variable that was assigned to. This is useful for modifying
+a copy of something, like this:
+
+ ($tmp = $global) =~ tr [A-Z] [a-z];
+
+Likewise,
+
+ ($a += 2) *= 3;
+
+is equivalent to
+
+ $a += 2;
+ $a *= 3;
+
+=head2 Comma Operator
+
+Binary "," is the comma operator. In scalar context it evaluates
+its left argument, throws that value away, then evaluates its right
+argument and returns that value. This is just like C's comma operator.
+
+In list context, it's just the list argument separator, and inserts
+both its arguments into the list.
+
+The =E<gt> digraph is mostly just a synonym for the comma operator. It's useful for
+documenting arguments that come in pairs. As of release 5.001, it also forces
+any word to the left of it to be interpreted as a string.
+
+=head2 List Operators (Rightward)
+
+On the right side of a list operator, it has very low precedence,
+such that it controls all comma-separated expressions found there.
+The only operators with lower precedence are the logical operators
+"and", "or", and "not", which may be used to evaluate calls to list
+operators without the need for extra parentheses:
+
+ open HANDLE, "filename"
+ or die "Can't open: $!\n";
+
+See also discussion of list operators in L<Terms and List Operators (Leftward)>.
+
+=head2 Logical Not
+
+Unary "not" returns the logical negation of the expression to its right.
+It's the equivalent of "!" except for the very low precedence.
+
+=head2 Logical And
+
+Binary "and" returns the logical conjunction of the two surrounding
+expressions. It's equivalent to && except for the very low
+precedence. This means that it short-circuits: i.e., the right
+expression is evaluated only if the left expression is true.
+
+=head2 Logical or and Exclusive Or
+
+Binary "or" returns the logical disjunction of the two surrounding
+expressions. It's equivalent to || except for the very low precedence.
+This makes it useful for control flow
+
+ print FH $data or die "Can't write to FH: $!";
+
+This means that it short-circuits: i.e., the right expression is evaluated
+only if the left expression is false. Due to its precedence, you should
+probably avoid using this for assignment, only for control flow.
+
+ $a = $b or $c; # bug: this is wrong
+ ($a = $b) or $c; # really means this
+ $a = $b || $c; # better written this way
+
+However, when it's a list context assignment and you're trying to use
+"||" for control flow, you probably need "or" so that the assignment
+takes higher precedence.
+
+ @info = stat($file) || die; # oops, scalar sense of stat!
+ @info = stat($file) or die; # better, now @info gets its due
+
+Then again, you could always use parentheses.
+
+Binary "xor" returns the exclusive-OR of the two surrounding expressions.
+It cannot short circuit, of course.
+
+=head2 C Operators Missing From Perl
+
+Here is what C has that Perl doesn't:
+
+=over 8
+
+=item unary &
+
+Address-of operator. (But see the "\" operator for taking a reference.)
+
+=item unary *
+
+Dereference-address operator. (Perl's prefix dereferencing
+operators are typed: $, @, %, and &.)
+
+=item (TYPE)
+
+Type casting operator.
+
+=back
+
+=head2 Quote and Quote-like Operators
+
+While we usually think of quotes as literal values, in Perl they
+function as operators, providing various kinds of interpolating and
+pattern matching capabilities. Perl provides customary quote characters
+for these behaviors, but also provides a way for you to choose your
+quote character for any of them. In the following table, a C<{}> represents
+any pair of delimiters you choose. Non-bracketing delimiters use
+the same character fore and aft, but the 4 sorts of brackets
+(round, angle, square, curly) will all nest.
+
+ Customary Generic Meaning Interpolates
+ '' q{} Literal no
+ "" qq{} Literal yes
+ `` qx{} Command yes (unless '' is delimiter)
+ qw{} Word list no
+ // m{} Pattern match yes
+ qr{} Pattern yes
+ s{}{} Substitution yes
+ tr{}{} Transliteration no (but see below)
+
+Note that there can be whitespace between the operator and the quoting
+characters, except when C<#> is being used as the quoting character.
+C<q#foo#> is parsed as being the string C<foo>, while C<q #foo#> is the
+operator C<q> followed by a comment. Its argument will be taken from the
+next line. This allows you to write:
+
+ s {foo} # Replace foo
+ {bar} # with bar.
+
+For constructs that do interpolation, variables beginning with "C<$>"
+or "C<@>" are interpolated, as are the following sequences. Within
+a transliteration, the first ten of these sequences may be used.
+
+ \t tab (HT, TAB)
+ \n newline (NL)
+ \r return (CR)
+ \f form feed (FF)
+ \b backspace (BS)
+ \a alarm (bell) (BEL)
+ \e escape (ESC)
+ \033 octal char
+ \x1b hex char
+ \c[ control char
+
+ \l lowercase next char
+ \u uppercase next char
+ \L lowercase till \E
+ \U uppercase till \E
+ \E end case modification
+ \Q quote non-word characters till \E
+
+If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u>
+and C<\U> is taken from the current locale. See L<perllocale>.
+
+All systems use the virtual C<"\n"> to represent a line terminator,
+called a "newline". There is no such thing as an unvarying, physical
+newline character. It is an illusion that the operating system,
+device drivers, C libraries, and Perl all conspire to preserve. Not all
+systems read C<"\r"> as ASCII CR and C<"\n"> as ASCII LF. For example,
+on a Mac, these are reversed, and on systems without line terminator,
+printing C<"\n"> may emit no actual data. In general, use C<"\n"> when
+you mean a "newline" for your system, but use the literal ASCII when you
+need an exact character. For example, most networking protocols expect
+and prefer a CR+LF (C<"\012\015"> or C<"\cJ\cM">) for line terminators,
+and although they often accept just C<"\012">, they seldom tolerate just
+C<"\015">. If you get in the habit of using C<"\n"> for networking,
+you may be burned some day.
+
+You cannot include a literal C<$> or C<@> within a C<\Q> sequence.
+An unescaped C<$> or C<@> interpolates the corresponding variable,
+while escaping will cause the literal string C<\$> to be inserted.
+You'll need to write something like C<m/\Quser\E\@\Qhost/>.
+
+Patterns are subject to an additional level of interpretation as a
+regular expression. This is done as a second pass, after variables are
+interpolated, so that regular expressions may be incorporated into the
+pattern from the variables. If this is not what you want, use C<\Q> to
+interpolate a variable literally.
+
+Apart from the above, there are no multiple levels of interpolation. In
+particular, contrary to the expectations of shell programmers, back-quotes
+do I<NOT> interpolate within double quotes, nor do single quotes impede
+evaluation of variables when used within double quotes.
+
+=head2 Regexp Quote-Like Operators
+
+Here are the quote-like operators that apply to pattern
+matching and related activities.
+
+Most of this section is related to use of regular expressions from Perl.
+Such a use may be considered from two points of view: Perl handles a
+a string and a "pattern" to RE (regular expression) engine to match,
+RE engine finds (or does not find) the match, and Perl uses the findings
+of RE engine for its operation, possibly asking the engine for other matches.
+
+RE engine has no idea what Perl is going to do with what it finds,
+similarly, the rest of Perl has no idea what a particular regular expression
+means to RE engine. This creates a clean separation, and in this section
+we discuss matching from Perl point of view only. The other point of
+view may be found in L<perlre>.
+
+=over 8
+
+=item ?PATTERN?
+
+This is just like the C</pattern/> search, except that it matches only
+once between calls to the reset() operator. This is a useful
+optimization when you want to see only the first occurrence of
+something in each file of a set of files, for instance. Only C<??>
+patterns local to the current package are reset.
+
+ while (<>) {
+ if (?^$?) {
+ # blank line between header and body
+ }
+ } continue {
+ reset if eof; # clear ?? status for next file
+ }
+
+This usage is vaguely deprecated, and may be removed in some future
+version of Perl.
+
+=item m/PATTERN/cgimosx
+
+=item /PATTERN/cgimosx
+
+Searches a string for a pattern match, and in scalar context returns
+true (1) or false (''). If no string is specified via the C<=~> or
+C<!~> operator, the $_ string is searched. (The string specified with
+C<=~> need not be an lvalue--it may be the result of an expression
+evaluation, but remember the C<=~> binds rather tightly.) See also
+L<perlre>.
+See L<perllocale> for discussion of additional considerations that apply
+when C<use locale> is in effect.
+
+Options are:
+
+ c Do not reset search position on a failed match when /g is in effect.
+ g Match globally, i.e., find all occurrences.
+ i Do case-insensitive pattern matching.
+ m Treat string as multiple lines.
+ o Compile pattern only once.
+ s Treat string as single line.
+ x Use extended regular expressions.
+
+If "/" is the delimiter then the initial C<m> is optional. With the C<m>
+you can use any pair of non-alphanumeric, non-whitespace characters
+as delimiters (if single quotes are used, no interpretation is done
+on the replacement string. Unlike Perl 4, Perl 5 treats backticks as normal
+delimiters; the replacement text is not evaluated as a command).
+This is particularly useful for matching Unix path names
+that contain "/", to avoid LTS (leaning toothpick syndrome). If "?" is
+the delimiter, then the match-only-once rule of C<?PATTERN?> applies.
+
+PATTERN may contain variables, which will be interpolated (and the
+pattern recompiled) every time the pattern search is evaluated. (Note
+that C<$)> and C<$|> might not be interpolated because they look like
+end-of-string tests.) If you want such a pattern to be compiled only
+once, add a C</o> after the trailing delimiter. This avoids expensive
+run-time recompilations, and is useful when the value you are
+interpolating won't change over the life of the script. However, mentioning
+C</o> constitutes a promise that you won't change the variables in the pattern.
+If you change them, Perl won't even notice.
+
+If the PATTERN evaluates to the empty string, the last
+I<successfully> matched regular expression is used instead.
+
+If the C</g> option is not used, C<m//> in a list context returns a
+list consisting of the subexpressions matched by the parentheses in the
+pattern, i.e., (C<$1>, C<$2>, C<$3>...). (Note that here C<$1> etc. are
+also set, and that this differs from Perl 4's behavior.) When there are
+no parentheses in the pattern, the return value is the list C<(1)> for
+success. With or without parentheses, an empty list is returned upon
+failure.
+
+Examples:
+
+ open(TTY, '/dev/tty');
+ <TTY> =~ /^y/i && foo(); # do foo if desired
+
+ if (/Version: *([0-9.]*)/) { $version = $1; }
+
+ next if m#^/usr/spool/uucp#;
+
+ # poor man's grep
+ $arg = shift;
+ while (<>) {
+ print if /$arg/o; # compile only once
+ }
+
+ if (($F1, $F2, $Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))
+
+This last example splits $foo into the first two words and the
+remainder of the line, and assigns those three fields to $F1, $F2, and
+$Etc. The conditional is true if any variables were assigned, i.e., if
+the pattern matched.
+
+The C</g> modifier specifies global pattern matching--that is, matching
+as many times as possible within the string. How it behaves depends on
+the context. In list context, it returns a list of all the
+substrings matched by all the parentheses in the regular expression.
+If there are no parentheses, it returns a list of all the matched
+strings, as if there were parentheses around the whole pattern.
+
+In scalar context, each execution of C<m//g> finds the next match,
+returning TRUE if it matches, and FALSE if there is no further match.
+The position after the last match can be read or set using the pos()
+function; see L<perlfunc/pos>. A failed match normally resets the
+search position to the beginning of the string, but you can avoid that
+by adding the C</c> modifier (e.g. C<m//gc>). Modifying the target
+string also resets the search position.
+
+You can intermix C<m//g> matches with C<m/\G.../g>, where C<\G> is a
+zero-width assertion that matches the exact position where the previous
+C<m//g>, if any, left off. The C<\G> assertion is not supported without
+the C</g> modifier; currently, without C</g>, C<\G> behaves just like
+C<\A>, but that's accidental and may change in the future.
+
+Examples:
+
+ # list context
+ ($one,$five,$fifteen) = (`uptime` =~ /(\d+\.\d+)/g);
+
+ # scalar context
+ $/ = ""; $* = 1; # $* deprecated in modern perls
+ while (defined($paragraph = <>)) {
+ while ($paragraph =~ /[a-z]['")]*[.!?]+['")]*\s/g) {
+ $sentences++;
+ }
+ }
+ print "$sentences\n";
+
+ # using m//gc with \G
+ $_ = "ppooqppqq";
+ while ($i++ < 2) {
+ print "1: '";
+ print $1 while /(o)/gc; print "', pos=", pos, "\n";
+ print "2: '";
+ print $1 if /\G(q)/gc; print "', pos=", pos, "\n";
+ print "3: '";
+ print $1 while /(p)/gc; print "', pos=", pos, "\n";
+ }
+
+The last example should print:
+
+ 1: 'oo', pos=4
+ 2: 'q', pos=5
+ 3: 'pp', pos=7
+ 1: '', pos=7
+ 2: 'q', pos=8
+ 3: '', pos=8
+
+A useful idiom for C<lex>-like scanners is C</\G.../gc>. You can
+combine several regexps like this to process a string part-by-part,
+doing different actions depending on which regexp matched. Each
+regexp tries to match where the previous one leaves off.
+
+ $_ = <<'EOL';
+ $url = new URI::URL "http://www/"; die if $url eq "xXx";
+ EOL
+ LOOP:
+ {
+ print(" digits"), redo LOOP if /\G\d+\b[,.;]?\s*/gc;
+ print(" lowercase"), redo LOOP if /\G[a-z]+\b[,.;]?\s*/gc;
+ print(" UPPERCASE"), redo LOOP if /\G[A-Z]+\b[,.;]?\s*/gc;
+ print(" Capitalized"), redo LOOP if /\G[A-Z][a-z]+\b[,.;]?\s*/gc;
+ print(" MiXeD"), redo LOOP if /\G[A-Za-z]+\b[,.;]?\s*/gc;
+ print(" alphanumeric"), redo LOOP if /\G[A-Za-z0-9]+\b[,.;]?\s*/gc;
+ print(" line-noise"), redo LOOP if /\G[^A-Za-z0-9]+/gc;
+ print ". That's all!\n";
+ }
+
+Here is the output (split into several lines):
+
+ line-noise lowercase line-noise lowercase UPPERCASE line-noise
+ UPPERCASE line-noise lowercase line-noise lowercase line-noise
+ lowercase lowercase line-noise lowercase lowercase line-noise
+ MiXeD line-noise. That's all!
+
+=item q/STRING/
+
+=item C<'STRING'>
+
+A single-quoted, literal string. A backslash represents a backslash
+unless followed by the delimiter or another backslash, in which case
+the delimiter or backslash is interpolated.
+
+ $foo = q!I said, "You said, 'She said it.'"!;
+ $bar = q('This is it.');
+ $baz = '\n'; # a two-character string
+
+=item qq/STRING/
+
+=item "STRING"
+
+A double-quoted, interpolated string.
+
+ $_ .= qq
+ (*** The previous line contains the naughty word "$1".\n)
+ if /(tcl|rexx|python)/; # :-)
+ $baz = "\n"; # a one-character string
+
+=item qr/STRING/imosx
+
+A string which is (possibly) interpolated and then compiled as a
+regular expression. The result may be used as a pattern in a match
+
+ $re = qr/$pattern/;
+ $string =~ /foo${re}bar/; # can be interpolated in other patterns
+ $string =~ $re; # or used standalone
+
+Options are:
+
+ i Do case-insensitive pattern matching.
+ m Treat string as multiple lines.
+ o Compile pattern only once.
+ s Treat string as single line.
+ x Use extended regular expressions.
+
+The benefit from this is that the pattern is precompiled into an internal
+representation, and does not need to be recompiled every time a match
+is attempted. This makes it very efficient to do something like:
+
+ foreach $pattern (@pattern_list) {
+ my $re = qr/$pattern/;
+ foreach $line (@lines) {
+ if($line =~ /$re/) {
+ do_something($line);
+ }
+ }
+ }
+
+See L<perlre> for additional information on valid syntax for STRING, and
+for a detailed look at the semantics of regular expressions.
+
+=item qx/STRING/
+
+=item `STRING`
+
+A string which is (possibly) interpolated and then executed as a system
+command with C</bin/sh> or its equivalent. Shell wildcards, pipes,
+and redirections will be honored. The collected standard output of the
+command is returned; standard error is unaffected. In scalar context,
+it comes back as a single (potentially multi-line) string. In list
+context, returns a list of lines (however you've defined lines with $/
+or $INPUT_RECORD_SEPARATOR).
+
+Because backticks do not affect standard error, use shell file descriptor
+syntax (assuming the shell supports this) if you care to address this.
+To capture a command's STDERR and STDOUT together:
+
+ $output = `cmd 2>&1`;
+
+To capture a command's STDOUT but discard its STDERR:
+
+ $output = `cmd 2>/dev/null`;
+
+To capture a command's STDERR but discard its STDOUT (ordering is
+important here):
+
+ $output = `cmd 2>&1 1>/dev/null`;
+
+To exchange a command's STDOUT and STDERR in order to capture the STDERR
+but leave its STDOUT to come out the old STDERR:
+
+ $output = `cmd 3>&1 1>&2 2>&3 3>&-`;
+
+To read both a command's STDOUT and its STDERR separately, it's easiest
+and safest to redirect them separately to files, and then read from those
+files when the program is done:
+
+ system("program args 1>/tmp/program.stdout 2>/tmp/program.stderr");
+
+Using single-quote as a delimiter protects the command from Perl's
+double-quote interpolation, passing it on to the shell instead:
+
+ $perl_info = qx(ps $$); # that's Perl's $$
+ $shell_info = qx'ps $$'; # that's the new shell's $$
+
+Note that how the string gets evaluated is entirely subject to the command
+interpreter on your system. On most platforms, you will have to protect
+shell metacharacters if you want them treated literally. This is in
+practice difficult to do, as it's unclear how to escape which characters.
+See L<perlsec> for a clean and safe example of a manual fork() and exec()
+to emulate backticks safely.
+
+On some platforms (notably DOS-like ones), the shell may not be
+capable of dealing with multiline commands, so putting newlines in
+the string may not get you what you want. You may be able to evaluate
+multiple commands in a single line by separating them with the command
+separator character, if your shell supports that (e.g. C<;> on many Unix
+shells; C<&> on the Windows NT C<cmd> shell).
+
+Beware that some command shells may place restrictions on the length
+of the command line. You must ensure your strings don't exceed this
+limit after any necessary interpolations. See the platform-specific
+release notes for more details about your particular environment.
+
+Using this operator can lead to programs that are difficult to port,
+because the shell commands called vary between systems, and may in
+fact not be present at all. As one example, the C<type> command under
+the POSIX shell is very different from the C<type> command under DOS.
+That doesn't mean you should go out of your way to avoid backticks
+when they're the right way to get something done. Perl was made to be
+a glue language, and one of the things it glues together is commands.
+Just understand what you're getting yourself into.
+
+See L<"I/O Operators"> for more discussion.
+
+=item qw/STRING/
+
+Returns a list of the words extracted out of STRING, using embedded
+whitespace as the word delimiters. It is exactly equivalent to
+
+ split(' ', q/STRING/);
+
+This equivalency means that if used in scalar context, you'll get split's
+(unfortunate) scalar context behavior, complete with mysterious warnings.
+
+Some frequently seen examples:
+
+ use POSIX qw( setlocale localeconv )
+ @EXPORT = qw( foo bar baz );
+
+A common mistake is to try to separate the words with comma or to put
+comments into a multi-line C<qw>-string. For this reason the C<-w>
+switch produce warnings if the STRING contains the "," or the "#"
+character.
+
+=item s/PATTERN/REPLACEMENT/egimosx
+
+Searches a string for a pattern, and if found, replaces that pattern
+with the replacement text and returns the number of substitutions
+made. Otherwise it returns false (specifically, the empty string).
+
+If no string is specified via the C<=~> or C<!~> operator, the C<$_>
+variable is searched and modified. (The string specified with C<=~> must
+be scalar variable, an array element, a hash element, or an assignment
+to one of those, i.e., an lvalue.)
+
+If the delimiter chosen is single quote, no variable interpolation is
+done on either the PATTERN or the REPLACEMENT. Otherwise, if the
+PATTERN contains a $ that looks like a variable rather than an
+end-of-string test, the variable will be interpolated into the pattern
+at run-time. If you want the pattern compiled only once the first time
+the variable is interpolated, use the C</o> option. If the pattern
+evaluates to the empty string, the last successfully executed regular
+expression is used instead. See L<perlre> for further explanation on these.
+See L<perllocale> for discussion of additional considerations that apply
+when C<use locale> is in effect.
+
+Options are:
+
+ e Evaluate the right side as an expression.
+ g Replace globally, i.e., all occurrences.
+ i Do case-insensitive pattern matching.
+ m Treat string as multiple lines.
+ o Compile pattern only once.
+ s Treat string as single line.
+ x Use extended regular expressions.
+
+Any non-alphanumeric, non-whitespace delimiter may replace the
+slashes. If single quotes are used, no interpretation is done on the
+replacement string (the C</e> modifier overrides this, however). Unlike
+Perl 4, Perl 5 treats backticks as normal delimiters; the replacement
+text is not evaluated as a command. If the
+PATTERN is delimited by bracketing quotes, the REPLACEMENT has its own
+pair of quotes, which may or may not be bracketing quotes, e.g.,
+C<s(foo)(bar)> or C<sE<lt>fooE<gt>/bar/>. A C</e> will cause the
+replacement portion to be interpreted as a full-fledged Perl expression
+and eval()ed right then and there. It is, however, syntax checked at
+compile-time.
+
+Examples:
+
+ s/\bgreen\b/mauve/g; # don't change wintergreen
+
+ $path =~ s|/usr/bin|/usr/local/bin|;
+
+ s/Login: $foo/Login: $bar/; # run-time pattern
+
+ ($foo = $bar) =~ s/this/that/; # copy first, then change
+
+ $count = ($paragraph =~ s/Mister\b/Mr./g); # get change-count
+
+ $_ = 'abc123xyz';
+ s/\d+/$&*2/e; # yields 'abc246xyz'
+ s/\d+/sprintf("%5d",$&)/e; # yields 'abc 246xyz'
+ s/\w/$& x 2/eg; # yields 'aabbcc 224466xxyyzz'
+
+ s/%(.)/$percent{$1}/g; # change percent escapes; no /e
+ s/%(.)/$percent{$1} || $&/ge; # expr now, so /e
+ s/^=(\w+)/&pod($1)/ge; # use function call
+
+ # expand variables in $_, but dynamics only, using
+ # symbolic dereferencing
+ s/\$(\w+)/${$1}/g;
+
+ # /e's can even nest; this will expand
+ # any embedded scalar variable (including lexicals) in $_
+ s/(\$\w+)/$1/eeg;
+
+ # Delete (most) C comments.
+ $program =~ s {
+ /\* # Match the opening delimiter.
+ .*? # Match a minimal number of characters.
+ \*/ # Match the closing delimiter.
+ } []gsx;
+
+ s/^\s*(.*?)\s*$/$1/; # trim white space in $_, expensively
+
+ for ($variable) { # trim white space in $variable, cheap
+ s/^\s+//;
+ s/\s+$//;
+ }
+
+ s/([^ ]*) *([^ ]*)/$2 $1/; # reverse 1st two fields
+
+Note the use of $ instead of \ in the last example. Unlike
+B<sed>, we use the \E<lt>I<digit>E<gt> form in only the left hand side.
+Anywhere else it's $E<lt>I<digit>E<gt>.
+
+Occasionally, you can't use just a C</g> to get all the changes
+to occur. Here are two common cases:
+
+ # put commas in the right places in an integer
+ 1 while s/(.*\d)(\d\d\d)/$1,$2/g; # perl4
+ 1 while s/(\d)(\d\d\d)(?!\d)/$1,$2/g; # perl5
+
+ # expand tabs to 8-column spacing
+ 1 while s/\t+/' ' x (length($&)*8 - length($`)%8)/e;
+
+
+=item tr/SEARCHLIST/REPLACEMENTLIST/cds
+
+=item y/SEARCHLIST/REPLACEMENTLIST/cds
+
+Transliterates all occurrences of the characters found in the search list
+with the corresponding character in the replacement list. It returns
+the number of characters replaced or deleted. If no string is
+specified via the =~ or !~ operator, the $_ string is transliterated. (The
+string specified with =~ must be a scalar variable, an array element, a
+hash element, or an assignment to one of those, i.e., an lvalue.)
+A character range may be specified with a hyphen, so C<tr/A-J/0-9/>
+does the same replacement as C<tr/ACEGIBDFHJ/0246813579/>.
+For B<sed> devotees, C<y> is provided as a synonym for C<tr>. If the
+SEARCHLIST is delimited by bracketing quotes, the REPLACEMENTLIST has
+its own pair of quotes, which may or may not be bracketing quotes,
+e.g., C<tr[A-Z][a-z]> or C<tr(+\-*/)/ABCD/>.
+
+Options:
+
+ c Complement the SEARCHLIST.
+ d Delete found but unreplaced characters.
+ s Squash duplicate replaced characters.
+
+If the C</c> modifier is specified, the SEARCHLIST character set is
+complemented. If the C</d> modifier is specified, any characters specified
+by SEARCHLIST not found in REPLACEMENTLIST are deleted. (Note
+that this is slightly more flexible than the behavior of some B<tr>
+programs, which delete anything they find in the SEARCHLIST, period.)
+If the C</s> modifier is specified, sequences of characters that were
+transliterated to the same character are squashed down to a single instance of the
+character.
+
+If the C</d> modifier is used, the REPLACEMENTLIST is always interpreted
+exactly as specified. Otherwise, if the REPLACEMENTLIST is shorter
+than the SEARCHLIST, the final character is replicated till it is long
+enough. If the REPLACEMENTLIST is empty, the SEARCHLIST is replicated.
+This latter is useful for counting characters in a class or for
+squashing character sequences in a class.
+
+Examples:
+
+ $ARGV[1] =~ tr/A-Z/a-z/; # canonicalize to lower case
+
+ $cnt = tr/*/*/; # count the stars in $_
+
+ $cnt = $sky =~ tr/*/*/; # count the stars in $sky
+
+ $cnt = tr/0-9//; # count the digits in $_
+
+ tr/a-zA-Z//s; # bookkeeper -> bokeper
+
+ ($HOST = $host) =~ tr/a-z/A-Z/;
+
+ tr/a-zA-Z/ /cs; # change non-alphas to single space
+
+ tr [\200-\377]
+ [\000-\177]; # delete 8th bit
+
+If multiple transliterations are given for a character, only the first one is used:
+
+ tr/AAA/XYZ/
+
+will transliterate any A to X.
+
+Note that because the transliteration table is built at compile time, neither
+the SEARCHLIST nor the REPLACEMENTLIST are subjected to double quote
+interpolation. That means that if you want to use variables, you must use
+an eval():
+
+ eval "tr/$oldlist/$newlist/";
+ die $@ if $@;
+
+ eval "tr/$oldlist/$newlist/, 1" or die $@;
+
+=back
+
+=head2 Gory details of parsing quoted constructs
+
+When presented with something which may have several different
+interpretations, Perl uses the principle B<DWIM> (expanded to Do What I Mean
+- not what I wrote) to pick up the most probable interpretation of the
+source. This strategy is so successful that Perl users usually do not
+suspect ambivalence of what they write. However, time to time Perl's ideas
+differ from what the author meant.
+
+The target of this section is to clarify the Perl's way of interpreting
+quoted constructs. The most frequent reason one may have to want to know the
+details discussed in this section is hairy regular expressions. However, the
+first steps of parsing are the same for all Perl quoting operators, so here
+they are discussed together.
+
+Some of the passes discussed below are performed concurrently, but as
+far as results are the same, we consider them one-by-one. For different
+quoting constructs Perl performs different number of passes, from
+one to five, but they are always performed in the same order.
+
+=over
+
+=item Finding the end
+
+First pass is finding the end of the quoted construct, be it multichar ender
+C<"\nEOF\n"> of C<<<EOF> construct, C</> which terminates C<qq/> construct,
+C<]> which terminates C<qq[> construct, or C<E<gt>> which terminates a
+fileglob started with C<<>.
+
+When searching for multichar construct no skipping is performed. When
+searching for one-char non-matching delimiter, such as C</>, combinations
+C<\\> and C<\/> are skipped. When searching for one-char matching delimiter,
+such as C<]>, combinations C<\\>, C<\]> and C<\[> are skipped, and
+nested C<[>, C<]> are skipped as well.
+
+For 3-parts constructs, C<s///> etc. the search is repeated once more.
+
+During this search no attention is paid to the semantic of the construct, thus
+
+ "$hash{"$foo/$bar"}"
+
+or
+
+ m/
+ bar # This is not a comment, this slash / terminated m//!
+ /x
+
+do not form legal quoted expressions. Note that since the slash which
+terminated C<m//> was followed by a C<SPACE>, this is not C<m//x>,
+thus C<#> was interpreted as a literal C<#>.
+
+=item Removal of backslashes before delimiters
+
+During the second pass the text between the starting delimiter and
+the ending delimiter is copied to a safe location, and the C<\> is
+removed from combinations consisting of C<\> and delimiter(s) (both starting
+and ending delimiter if they differ).
+
+The removal does not happen for multi-char delimiters.
+
+Note that the combination C<\\> is left as it was!
+
+Starting from this step no information about the delimiter(s) is used in the
+parsing.
+
+=item Interpolation
+
+Next step is interpolation in the obtained delimiter-independent text.
+There are four different cases.
+
+=over
+
+=item C<<<'EOF'>, C<m''>, C<s'''>, C<tr///>, C<y///>
+
+No interpolation is performed.
+
+=item C<''>, C<q//>
+
+The only interpolation is removal of C<\> from pairs C<\\>.
+
+=item C<"">, C<``>, C<qq//>, C<qx//>, C<<file*globE<gt>>
+
+C<\Q>, C<\U>, C<\u>, C<\L>, C<\l> (possibly paired with C<\E>) are converted
+to corresponding Perl constructs, thus C<"$foo\Qbaz$bar"> is converted to
+
+ $foo . (quotemeta("baz" . $bar));
+
+Other combinations of C<\> with following chars are substituted with
+appropriate expansions.
+
+Interpolated scalars and arrays are converted to C<join> and C<.> Perl
+constructs, thus C<"'@arr'"> becomes
+
+ "'" . (join $", @arr) . "'";
+
+Since all three above steps are performed simultaneously left-to-right,
+the is no way to insert a literal C<$> or C<@> inside C<\Q\E> pair: it
+cannot be protected by C<\>, since any C<\> (except in C<\E>) is
+interpreted as a literal inside C<\Q\E>, and any C<$> is
+interpreted as starting an interpolated scalar.
+
+Note also that the interpolating code needs to make decision where the
+interpolated scalar ends, say, whether C<"a $b -E<gt> {c}"> means
+
+ "a " . $b . " -> {c}";
+
+or
+
+ "a " . $b -> {c};
+
+Most the time the decision is to take the longest possible text which does
+not include spaces between components and contains matching braces/brackets.
+
+=item C<?RE?>, C</RE/>, C<m/RE/>, C<s/RE/foo/>,
+
+Processing of C<\Q>, C<\U>, C<\u>, C<\L>, C<\l> and interpolation happens
+(almost) as with C<qq//> constructs, but I<the substitution of C<\> followed by
+other chars is not performed>! Moreover, inside C<(?{BLOCK})> no processing
+is performed at all.
+
+Interpolation has several quirks: C<$|>, C<$(> and C<$)> are not interpolated, and
+constructs C<$var[SOMETHING]> are I<voted> (by several different estimators)
+to be an array element or C<$var> followed by a RE alternative. This is
+the place where the notation C<${arr[$bar]}> comes handy: C</${arr[0-9]}/>
+is interpreted as an array element C<-9>, not as a regular expression from
+variable C<$arr> followed by a digit, which is the interpretation of
+C</$arr[0-9]/>.
+
+Note that absence of processing of C<\\> creates specific restrictions on the
+post-processed text: if the delimiter is C</>, one cannot get the combination
+C<\/> into the result of this step: C</> will finish the regular expression,
+C<\/> will be stripped to C</> on the previous step, and C<\\/> will be left
+as is. Since C</> is equivalent to C<\/> inside a regular expression, this
+does not matter unless the delimiter is special character for the RE engine, as
+in C<s*foo*bar*>, C<m[foo]>, or C<?foo?>.
+
+=back
+
+This step is the last one for all the constructs except regular expressions,
+which are processed further.
+
+=item Interpolation of regular expressions
+
+All the previous steps were performed during the compilation of Perl code,
+this one happens in run time (though it may be optimized to be calculated
+at compile time if appropriate). After all the preprocessing performed
+above (and possibly after evaluation if catenation, joining, up/down-casing
+and C<quotemeta()>ing are involved) the resulting I<string> is passed to RE
+engine for compilation.
+
+Whatever happens in the RE engine is better be discussed in L<perlre>,
+but for the sake of continuity let us do it here.
+
+This is the first step where presence of the C<//x> switch is relevant.
+The RE engine scans the string left-to-right, and converts it to a finite
+automaton.
+
+Backslashed chars are either substituted by corresponding literal
+strings, or generate special nodes of the finite automaton. Characters
+which are special to the RE engine generate corresponding nodes. C<(?#...)>
+comments are ignored. All the rest is either converted to literal strings
+to match, or is ignored (as is whitespace and C<#>-style comments if
+C<//x> is present).
+
+Note that the parsing of the construct C<[...]> is performed using
+absolutely different rules than the rest of the regular expression.
+Similarly, the C<(?{...})> is only checked for matching braces.
+
+=item Optimization of regular expressions
+
+This step is listed for completeness only. Since it does not change
+semantics, details of this step are not documented and are subject
+to change.
+
+=back
+
+=head2 I/O Operators
+
+There are several I/O operators you should know about.
+A string enclosed by backticks (grave accents) first undergoes
+variable substitution just like a double quoted string. It is then
+interpreted as a command, and the output of that command is the value
+of the pseudo-literal, like in a shell. In scalar context, a single
+string consisting of all the output is returned. In list context,
+a list of values is returned, one for each line of output. (You can
+set C<$/> to use a different line terminator.) The command is executed
+each time the pseudo-literal is evaluated. The status value of the
+command is returned in C<$?> (see L<perlvar> for the interpretation
+of C<$?>). Unlike in B<csh>, no translation is done on the return
+data--newlines remain newlines. Unlike in any of the shells, single
+quotes do not hide variable names in the command from interpretation.
+To pass a $ through to the shell you need to hide it with a backslash.
+The generalized form of backticks is C<qx//>. (Because backticks
+always undergo shell expansion as well, see L<perlsec> for
+security concerns.)
+
+Evaluating a filehandle in angle brackets yields the next line from
+that file (newline, if any, included), or C<undef> at end of file.
+Ordinarily you must assign that value to a variable, but there is one
+situation where an automatic assignment happens. I<If and ONLY if> the
+input symbol is the only thing inside the conditional of a C<while> or
+C<for(;;)> loop, the value is automatically assigned to the variable
+C<$_>. In these loop constructs, the assigned value (whether assignment
+is automatic or explicit) is then tested to see if it is defined.
+The defined test avoids problems where line has a string value
+that would be treated as false by perl e.g. "" or "0" with no trailing
+newline. (This may seem like an odd thing to you, but you'll use the
+construct in almost every Perl script you write.) Anyway, the following
+lines are equivalent to each other:
+
+ while (defined($_ = <STDIN>)) { print; }
+ while ($_ = <STDIN>) { print; }
+ while (<STDIN>) { print; }
+ for (;<STDIN>;) { print; }
+ print while defined($_ = <STDIN>);
+ print while ($_ = <STDIN>);
+ print while <STDIN>;
+
+and this also behaves similarly, but avoids the use of $_ :
+
+ while (my $line = <STDIN>) { print $line }
+
+If you really mean such values to terminate the loop they should be
+tested for explicitly:
+
+ while (($_ = <STDIN>) ne '0') { ... }
+ while (<STDIN>) { last unless $_; ... }
+
+In other boolean contexts, C<E<lt>I<filehandle>E<gt>> without explicit C<defined>
+test or comparison will solicit a warning if C<-w> is in effect.
+
+The filehandles STDIN, STDOUT, and STDERR are predefined. (The
+filehandles C<stdin>, C<stdout>, and C<stderr> will also work except in
+packages, where they would be interpreted as local identifiers rather
+than global.) Additional filehandles may be created with the open()
+function. See L<perlfunc/open()> for details on this.
+
+If a E<lt>FILEHANDLEE<gt> is used in a context that is looking for a list, a
+list consisting of all the input lines is returned, one line per list
+element. It's easy to make a I<LARGE> data space this way, so use with
+care.
+
+The null filehandle E<lt>E<gt> is special and can be used to emulate the
+behavior of B<sed> and B<awk>. Input from E<lt>E<gt> comes either from
+standard input, or from each file listed on the command line. Here's
+how it works: the first time E<lt>E<gt> is evaluated, the @ARGV array is
+checked, and if it is empty, C<$ARGV[0]> is set to "-", which when opened
+gives you standard input. The @ARGV array is then processed as a list
+of filenames. The loop
+
+ while (<>) {
+ ... # code for each line
+ }
+
+is equivalent to the following Perl-like pseudo code:
+
+ unshift(@ARGV, '-') unless @ARGV;
+ while ($ARGV = shift) {
+ open(ARGV, $ARGV);
+ while (<ARGV>) {
+ ... # code for each line
+ }
+ }
+
+except that it isn't so cumbersome to say, and will actually work. It
+really does shift array @ARGV and put the current filename into variable
+$ARGV. It also uses filehandle I<ARGV> internally--E<lt>E<gt> is just a
+synonym for E<lt>ARGVE<gt>, which is magical. (The pseudo code above
+doesn't work because it treats E<lt>ARGVE<gt> as non-magical.)
+
+You can modify @ARGV before the first E<lt>E<gt> as long as the array ends up
+containing the list of filenames you really want. Line numbers (C<$.>)
+continue as if the input were one big happy file. (But see example
+under C<eof> for how to reset line numbers on each file.)
+
+If you want to set @ARGV to your own list of files, go right ahead.
+This sets @ARGV to all plain text files if no @ARGV was given:
+
+ @ARGV = grep { -f && -T } glob('*') unless @ARGV;
+
+You can even set them to pipe commands. For example, this automatically
+filters compressed arguments through B<gzip>:
+
+ @ARGV = map { /\.(gz|Z)$/ ? "gzip -dc < $_ |" : $_ } @ARGV;
+
+If you want to pass switches into your script, you can use one of the
+Getopts modules or put a loop on the front like this:
+
+ while ($_ = $ARGV[0], /^-/) {
+ shift;
+ last if /^--$/;
+ if (/^-D(.*)/) { $debug = $1 }
+ if (/^-v/) { $verbose++ }
+ # ... # other switches
+ }
+
+ while (<>) {
+ # ... # code for each line
+ }
+
+The E<lt>E<gt> symbol will return C<undef> for end-of-file only once.
+If you call it again after this it will assume you are processing another
+@ARGV list, and if you haven't set @ARGV, will input from STDIN.
+
+If the string inside the angle brackets is a reference to a scalar
+variable (e.g., E<lt>$fooE<gt>), then that variable contains the name of the
+filehandle to input from, or its typeglob, or a reference to the same. For example:
+
+ $fh = \*STDIN;
+ $line = <$fh>;
+
+If what's within the angle brackets is neither a filehandle nor a simple
+scalar variable containing a filehandle name, typeglob, or typeglob
+reference, it is interpreted as a filename pattern to be globbed, and
+either a list of filenames or the next filename in the list is returned,
+depending on context. This distinction is determined on syntactic
+grounds alone. That means C<E<lt>$xE<gt>> is always a readline from
+an indirect handle, but C<E<lt>$hash{key}E<gt>> is always a glob.
+That's because $x is a simple scalar variable, but C<$hash{key}> is
+not--it's a hash element.
+
+One level of double-quote interpretation is done first, but you can't
+say C<E<lt>$fooE<gt>> because that's an indirect filehandle as explained
+in the previous paragraph. (In older versions of Perl, programmers
+would insert curly brackets to force interpretation as a filename glob:
+C<E<lt>${foo}E<gt>>. These days, it's considered cleaner to call the
+internal function directly as C<glob($foo)>, which is probably the right
+way to have done it in the first place.) Example:
+
+ while (<*.c>) {
+ chmod 0644, $_;
+ }
+
+is equivalent to
+
+ open(FOO, "echo *.c | tr -s ' \t\r\f' '\\012\\012\\012\\012'|");
+ while (<FOO>) {
+ chop;
+ chmod 0644, $_;
+ }
+
+In fact, it's currently implemented that way. (Which means it will not
+work on filenames with spaces in them unless you have csh(1) on your
+machine.) Of course, the shortest way to do the above is:
+
+ chmod 0644, <*.c>;
+
+Because globbing invokes a shell, it's often faster to call readdir() yourself
+and do your own grep() on the filenames. Furthermore, due to its current
+implementation of using a shell, the glob() routine may get "Arg list too
+long" errors (unless you've installed tcsh(1L) as F</bin/csh>).
+
+A glob evaluates its (embedded) argument only when it is starting a new
+list. All values must be read before it will start over. In a list
+context this isn't important, because you automatically get them all
+anyway. In scalar context, however, the operator returns the next value
+each time it is called, or a C<undef> value if you've just run out. As
+for filehandles an automatic C<defined> is generated when the glob
+occurs in the test part of a C<while> or C<for> - because legal glob returns
+(e.g. a file called F<0>) would otherwise terminate the loop.
+Again, C<undef> is returned only once. So if you're expecting a single value
+from a glob, it is much better to say
+
+ ($file) = <blurch*>;
+
+than
+
+ $file = <blurch*>;
+
+because the latter will alternate between returning a filename and
+returning FALSE.
+
+It you're trying to do variable interpolation, it's definitely better
+to use the glob() function, because the older notation can cause people
+to become confused with the indirect filehandle notation.
+
+ @files = glob("$dir/*.[ch]");
+ @files = glob($files[$i]);
+
+=head2 Constant Folding
+
+Like C, Perl does a certain amount of expression evaluation at
+compile time, whenever it determines that all arguments to an
+operator are static and have no side effects. In particular, string
+concatenation happens at compile time between literals that don't do
+variable substitution. Backslash interpretation also happens at
+compile time. You can say
+
+ 'Now is the time for all' . "\n" .
+ 'good men to come to.'
+
+and this all reduces to one string internally. Likewise, if
+you say
+
+ foreach $file (@filenames) {
+ if (-s $file > 5 + 100 * 2**16) { }
+ }
+
+the compiler will precompute the number that
+expression represents so that the interpreter
+won't have to.
+
+=head2 Bitwise String Operators
+
+Bitstrings of any size may be manipulated by the bitwise operators
+(C<~ | & ^>).
+
+If the operands to a binary bitwise op are strings of different sizes,
+B<or> and B<xor> ops will act as if the shorter operand had additional
+zero bits on the right, while the B<and> op will act as if the longer
+operand were truncated to the length of the shorter.
+
+ # ASCII-based examples
+ print "j p \n" ^ " a h"; # prints "JAPH\n"
+ print "JA" | " ph\n"; # prints "japh\n"
+ print "japh\nJunk" & '_____'; # prints "JAPH\n";
+ print 'p N$' ^ " E<H\n"; # prints "Perl\n";
+
+If you are intending to manipulate bitstrings, you should be certain that
+you're supplying bitstrings: If an operand is a number, that will imply
+a B<numeric> bitwise operation. You may explicitly show which type of
+operation you intend by using C<""> or C<0+>, as in the examples below.
+
+ $foo = 150 | 105 ; # yields 255 (0x96 | 0x69 is 0xFF)
+ $foo = '150' | 105 ; # yields 255
+ $foo = 150 | '105'; # yields 255
+ $foo = '150' | '105'; # yields string '155' (under ASCII)
+
+ $baz = 0+$foo & 0+$bar; # both ops explicitly numeric
+ $biz = "$foo" ^ "$bar"; # both ops explicitly stringy
+
+=head2 Integer Arithmetic
+
+By default Perl assumes that it must do most of its arithmetic in
+floating point. But by saying
+
+ use integer;
+
+you may tell the compiler that it's okay to use integer operations
+from here to the end of the enclosing BLOCK. An inner BLOCK may
+countermand this by saying
+
+ no integer;
+
+which lasts until the end of that BLOCK.
+
+The bitwise operators ("&", "|", "^", "~", "<<", and ">>") always
+produce integral results. (But see also L<Bitwise String Operators>.)
+However, C<use integer> still has meaning
+for them. By default, their results are interpreted as unsigned
+integers. However, if C<use integer> is in effect, their results are
+interpreted as signed integers. For example, C<~0> usually evaluates
+to a large integral value. However, C<use integer; ~0> is -1 on twos-complement machines.
+
+=head2 Floating-point Arithmetic
+
+While C<use integer> provides integer-only arithmetic, there is no
+similar ways to provide rounding or truncation at a certain number of
+decimal places. For rounding to a certain number of digits, sprintf()
+or printf() is usually the easiest route.
+
+Floating-point numbers are only approximations to what a mathematician
+would call real numbers. There are infinitely more reals than floats,
+so some corners must be cut. For example:
+
+ printf "%.20g\n", 123456789123456789;
+ # produces 123456789123456784
+
+Testing for exact equality of floating-point equality or inequality is
+not a good idea. Here's a (relatively expensive) work-around to compare
+whether two floating-point numbers are equal to a particular number of
+decimal places. See Knuth, volume II, for a more robust treatment of
+this topic.
+
+ sub fp_equal {
+ my ($X, $Y, $POINTS) = @_;
+ my ($tX, $tY);
+ $tX = sprintf("%.${POINTS}g", $X);
+ $tY = sprintf("%.${POINTS}g", $Y);
+ return $tX eq $tY;
+ }
+
+The POSIX module (part of the standard perl distribution) implements
+ceil(), floor(), and a number of other mathematical and trigonometric
+functions. The Math::Complex module (part of the standard perl
+distribution) defines a number of mathematical functions that can also
+work on real numbers. Math::Complex not as efficient as POSIX, but
+POSIX can't work with complex numbers.
+
+Rounding in financial applications can have serious implications, and
+the rounding method used should be specified precisely. In these
+cases, it probably pays not to trust whichever system rounding is
+being used by Perl, but to instead implement the rounding function you
+need yourself.
+
+=head2 Bigger Numbers
+
+The standard Math::BigInt and Math::BigFloat modules provide
+variable precision arithmetic and overloaded operators.
+At the cost of some space and considerable speed, they
+avoid the normal pitfalls associated with limited-precision
+representations.
+
+ use Math::BigInt;
+ $x = Math::BigInt->new('123456789123456789');
+ print $x * $x;
+
+ # prints +15241578780673678515622620750190521
diff --git a/contrib/perl5/pod/perlpod.pod b/contrib/perl5/pod/perlpod.pod
new file mode 100644
index 000000000000..d20d62d06ae4
--- /dev/null
+++ b/contrib/perl5/pod/perlpod.pod
@@ -0,0 +1,286 @@
+=head1 NAME
+
+perlpod - plain old documentation
+
+=head1 DESCRIPTION
+
+A pod-to-whatever translator reads a pod file paragraph by paragraph,
+and translates it to the appropriate output format. There are
+three kinds of paragraphs:
+L<verbatim|/"Verbatim Paragraph">,
+L<command|/"Command Paragraph">, and
+L<ordinary text|/"Ordinary Block of Text">.
+
+
+=head2 Verbatim Paragraph
+
+A verbatim paragraph, distinguished by being indented (that is,
+it starts with space or tab). It should be reproduced exactly,
+with tabs assumed to be on 8-column boundaries. There are no
+special formatting escapes, so you can't italicize or anything
+like that. A \ means \, and nothing else.
+
+
+=head2 Command Paragraph
+
+All command paragraphs start with "=", followed by an
+identifier, followed by arbitrary text that the command can
+use however it pleases. Currently recognized commands are
+
+ =head1 heading
+ =head2 heading
+ =item text
+ =over N
+ =back
+ =cut
+ =pod
+ =for X
+ =begin X
+ =end X
+
+=over 4
+
+=item =pod
+
+=item =cut
+
+The "=pod" directive does nothing beyond telling the compiler to lay
+off parsing code through the next "=cut". It's useful for adding
+another paragraph to the doc if you're mixing up code and pod a lot.
+
+=item =head1
+
+=item =head2
+
+Head1 and head2 produce first and second level headings, with the text in
+the same paragraph as the "=headn" directive forming the heading description.
+
+=item =over
+
+=item =back
+
+=item =item
+
+Item, over, and back require a little more explanation: "=over" starts a
+section specifically for the generation of a list using "=item" commands. At
+the end of your list, use "=back" to end it. You will probably want to give
+"4" as the number to "=over", as some formatters will use this for indentation.
+This should probably be a default. Note also that there are some basic rules
+to using =item: don't use them outside of an =over/=back block, use at least
+one inside an =over/=back block, you don't _have_ to include the =back if
+the list just runs off the document, and perhaps most importantly, keep the
+items consistent: either use "=item *" for all of them, to produce bullets,
+or use "=item 1.", "=item 2.", etc., to produce numbered lists, or use
+"=item foo", "=item bar", etc., i.e., things that looks nothing like bullets
+or numbers. If you start with bullets or numbers, stick with them, as many
+formatters use the first "=item" type to decide how to format the list.
+
+
+=item =for
+
+=item =begin
+
+=item =end
+
+For, begin, and end let you include sections that are not interpreted
+as pod text, but passed directly to particular formatters. A formatter
+that can utilize that format will use the section, otherwise it will be
+completely ignored. The directive "=for" specifies that the entire next
+paragraph is in the format indicated by the first word after
+"=for", like this:
+
+ =for html <br>
+ <p> This is a raw HTML paragraph </p>
+
+The paired commands "=begin" and "=end" work very similarly to "=for", but
+instead of only accepting a single paragraph, all text from "=begin" to a
+paragraph with a matching "=end" are treated as a particular format.
+
+Here are some examples of how to use these:
+
+ =begin html
+
+ <br>Figure 1.<IMG SRC="figure1.png"><br>
+
+ =end html
+
+ =begin text
+
+ ---------------
+ | foo |
+ | bar |
+ ---------------
+
+ ^^^^ Figure 1. ^^^^
+
+ =end text
+
+Some format names that formatters currently are known to accept include
+"roff", "man", "latex", "tex", "text", and "html". (Some formatters will
+treat some of these as synonyms.)
+
+And don't forget, when using any command, that the command lasts up until
+the end of the B<paragraph>, not the line. Hence in the examples below, you
+can see the empty lines after each command to end its paragraph.
+
+Some examples of lists include:
+
+ =over 4
+
+ =item *
+
+ First item
+
+ =item *
+
+ Second item
+
+ =back
+
+ =over 4
+
+ =item Foo()
+
+ Description of Foo function
+
+ =item Bar()
+
+ Description of Bar function
+
+ =back
+
+
+=back
+
+
+=head2 Ordinary Block of Text
+
+It will be filled, and maybe even
+justified. Certain interior sequences are recognized both
+here and in commands:
+
+ I<text> italicize text, used for emphasis or variables
+ B<text> embolden text, used for switches and programs
+ S<text> text contains non-breaking spaces
+ C<code> literal code
+ L<name> A link (cross reference) to name
+ L<name> manual page
+ L<name/ident> item in manual page
+ L<name/"sec"> section in other manual page
+ L<"sec"> section in this manual page
+ (the quotes are optional)
+ L</"sec"> ditto
+ same as above but only 'text' is used for output.
+ (Text can not contain the characters '|' or '>')
+ L<text|name>
+ L<text|name/ident>
+ L<text|name/"sec">
+ L<text|"sec">
+ L<text|/"sec">
+
+ F<file> Used for filenames
+ X<index> An index entry
+ Z<> A zero-width character
+ E<escape> A named character (very similar to HTML escapes)
+ E<lt> A literal <
+ E<gt> A literal >
+ (these are optional except in other interior
+ sequences and when preceded by a capital letter)
+ E<n> Character number n (probably in ASCII)
+ E<html> Some non-numeric HTML entity, such
+ as E<Agrave>
+
+
+=head2 The Intent
+
+That's it. The intent is simplicity, not power. I wanted paragraphs
+to look like paragraphs (block format), so that they stand out
+visually, and so that I could run them through fmt easily to reformat
+them (that's F7 in my version of B<vi>). I wanted the translator (and not
+me) to worry about whether " or ' is a left quote or a right quote
+within filled text, and I wanted it to leave the quotes alone, dammit, in
+verbatim mode, so I could slurp in a working program, shift it over 4
+spaces, and have it print out, er, verbatim. And presumably in a
+constant width font.
+
+In particular, you can leave things like this verbatim in your text:
+
+ Perl
+ FILEHANDLE
+ $variable
+ function()
+ manpage(3r)
+
+Doubtless a few other commands or sequences will need to be added along
+the way, but I've gotten along surprisingly well with just these.
+
+Note that I'm not at all claiming this to be sufficient for producing a
+book. I'm just trying to make an idiot-proof common source for nroff,
+TeX, and other markup languages, as used for online documentation.
+Translators exist for B<pod2man> (that's for nroff(1) and troff(1)),
+B<pod2text>, B<pod2html>, B<pod2latex>, and B<pod2fm>.
+
+
+=head2 Embedding Pods in Perl Modules
+
+You can embed pod documentation in your Perl scripts. Start your
+documentation with a "=head1" command at the beginning, and end it
+with a "=cut" command. Perl will ignore the pod text. See any of the
+supplied library modules for examples. If you're going to put your
+pods at the end of the file, and you're using an __END__ or __DATA__
+cut mark, make sure to put an empty line there before the first pod
+directive.
+
+ __END__
+
+
+ =head1 NAME
+
+ modern - I am a modern module
+
+If you had not had that empty line there, then the translators wouldn't
+have seen it.
+
+
+=head2 Common Pod Pitfalls
+
+=over 4
+
+=item *
+
+Pod translators usually will require paragraphs to be separated by
+completely empty lines. If you have an apparently empty line with
+some spaces on it, this can cause odd formatting.
+
+=item *
+
+Translators will mostly add wording around a LE<lt>E<gt> link, so that
+C<LE<lt>foo(1)E<gt>> becomes "the I<foo>(1) manpage", for example (see
+B<pod2man> for details). Thus, you shouldn't write things like C<the
+LE<lt>fooE<gt> manpage>, if you want the translated document to read
+sensibly.
+
+If you don need or want total control of the text used for a
+link in the output use the form LE<lt>show this text|fooE<gt>
+instead.
+
+=item *
+
+The script F<pod/checkpods.PL> in the Perl source distribution
+provides skeletal checking for lines that look empty but aren't
+B<only>, but is there as a placeholder until someone writes
+Pod::Checker. The best way to check your pod is to pass it through
+one or more translators and proofread the result, or print out the
+result and proofread that. Some of the problems found may be bugs in
+the translators, which you may or may not wish to work around.
+
+=back
+
+=head1 SEE ALSO
+
+L<pod2man> and L<perlsyn/"PODs: Embedded Documentation">
+
+=head1 AUTHOR
+
+Larry Wall
+
diff --git a/contrib/perl5/pod/perlport.pod b/contrib/perl5/pod/perlport.pod
new file mode 100644
index 000000000000..79ca76769f6b
--- /dev/null
+++ b/contrib/perl5/pod/perlport.pod
@@ -0,0 +1,1461 @@
+=head1 NAME
+
+perlport - Writing portable Perl
+
+
+=head1 DESCRIPTION
+
+Perl runs on a variety of operating systems. While most of them share
+a lot in common, they also have their own very particular and unique
+features.
+
+This document is meant to help you to find out what constitutes portable
+Perl code, so that once you have made your decision to write portably,
+you know where the lines are drawn, and you can stay within them.
+
+There is a tradeoff between taking full advantage of B<a> particular type
+of computer, and taking advantage of a full B<range> of them. Naturally,
+as you make your range bigger (and thus more diverse), the common
+denominators drop, and you are left with fewer areas of common ground in
+which you can operate to accomplish a particular task. Thus, when you
+begin attacking a problem, it is important to consider which part of the
+tradeoff curve you want to operate under. Specifically, whether it is
+important to you that the task that you are coding needs the full
+generality of being portable, or if it is sufficient to just get the job
+done. This is the hardest choice to be made. The rest is easy, because
+Perl provides lots of choices, whichever way you want to approach your
+problem.
+
+Looking at it another way, writing portable code is usually about
+willfully limiting your available choices. Naturally, it takes discipline
+to do that.
+
+Be aware of two important points:
+
+=over 4
+
+=item Not all Perl programs have to be portable
+
+There is no reason why you should not use Perl as a language to glue Unix
+tools together, or to prototype a Macintosh application, or to manage the
+Windows registry. If it makes no sense to aim for portability for one
+reason or another in a given program, then don't bother.
+
+=item The vast majority of Perl B<is> portable
+
+Don't be fooled into thinking that it is hard to create portable Perl
+code. It isn't. Perl tries its level-best to bridge the gaps between
+what's available on different platforms, and all the means available to
+use those features. Thus almost all Perl code runs on any machine
+without modification. But there I<are> some significant issues in
+writing portable code, and this document is entirely about those issues.
+
+=back
+
+Here's the general rule: When you approach a task that is commonly done
+using a whole range of platforms, think in terms of writing portable
+code. That way, you don't sacrifice much by way of the implementation
+choices you can avail yourself of, and at the same time you can give
+your users lots of platform choices. On the other hand, when you have to
+take advantage of some unique feature of a particular platform, as is
+often the case with systems programming (whether for Unix, Windows,
+S<Mac OS>, VMS, etc.), consider writing platform-specific code.
+
+When the code will run on only two or three operating systems, then you
+may only need to consider the differences of those particular systems.
+The important thing is to decide where the code will run, and to be
+deliberate in your decision.
+
+The material below is separated into three main sections: main issues of
+portability (L<"ISSUES">, platform-specific issues (L<"PLATFORMS">, and
+builtin perl functions that behave differently on various ports
+(L<"FUNCTION IMPLEMENTATIONS">.
+
+This information should not be considered complete; it includes possibly
+transient information about idiosyncrasies of some of the ports, almost
+all of which are in a state of constant evolution. Thus this material
+should be considered a perpetual work in progress
+(E<lt>IMG SRC="yellow_sign.gif" ALT="Under Construction"E<gt>).
+
+
+
+
+=head1 ISSUES
+
+=head2 Newlines
+
+In most operating systems, lines in files are separated with newlines.
+Just what is used as a newline may vary from OS to OS. Unix
+traditionally uses C<\012>, one kind of Windows I/O uses C<\015\012>,
+and S<Mac OS> uses C<\015>.
+
+Perl uses C<\n> to represent the "logical" newline, where what
+is logical may depend on the platform in use. In MacPerl, C<\n>
+always means C<\015>. In DOSish perls, C<\n> usually means C<\012>, but
+when accessing a file in "text" mode, STDIO translates it to (or from)
+C<\015\012>.
+
+Due to the "text" mode translation, DOSish perls have limitations
+of using C<seek> and C<tell> when a file is being accessed in "text"
+mode. Specifically, if you stick to C<seek>-ing to locations you got
+from C<tell> (and no others), you are usually free to use C<seek> and
+C<tell> even in "text" mode. In general, using C<seek> or C<tell> or
+other file operations that count bytes instead of characters, without
+considering the length of C<\n>, may be non-portable. If you use
+C<binmode> on a file, however, you can usually use C<seek> and C<tell>
+with arbitrary values quite safely.
+
+A common misconception in socket programming is that C<\n> eq C<\012>
+everywhere. When using protocols such as common Internet protocols,
+C<\012> and C<\015> are called for specifically, and the values of
+the logical C<\n> and C<\r> (carriage return) are not reliable.
+
+ print SOCKET "Hi there, client!\r\n"; # WRONG
+ print SOCKET "Hi there, client!\015\012"; # RIGHT
+
+[NOTE: this does not necessarily apply to communications that are
+filtered by another program or module before sending to the socket; the
+the most popular EBCDIC webserver, for instance, accepts C<\r\n>,
+which translates those characters, along with all other
+characters in text streams, from EBCDIC to ASCII.]
+
+However, using C<\015\012> (or C<\cM\cJ>, or C<\x0D\x0A>) can be tedious
+and unsightly, as well as confusing to those maintaining the code. As
+such, the C<Socket> module supplies the Right Thing for those who want it.
+
+ use Socket qw(:DEFAULT :crlf);
+ print SOCKET "Hi there, client!$CRLF" # RIGHT
+
+When reading I<from> a socket, remember that the default input record
+separator (C<$/>) is C<\n>, but code like this should recognize C<$/> as
+C<\012> or C<\015\012>:
+
+ while (<SOCKET>) {
+ # ...
+ }
+
+Better:
+
+ use Socket qw(:DEFAULT :crlf);
+ local($/) = LF; # not needed if $/ is already \012
+
+ while (<SOCKET>) {
+ s/$CR?$LF/\n/; # not sure if socket uses LF or CRLF, OK
+ # s/\015?\012/\n/; # same thing
+ }
+
+And this example is actually better than the previous one even for Unix
+platforms, because now any C<\015>'s (C<\cM>'s) are stripped out
+(and there was much rejoicing).
+
+
+=head2 Numbers endianness and Width
+
+Different CPUs store integers and floating point numbers in different
+orders (called I<endianness>) and widths (32-bit and 64-bit being the
+most common). This affects your programs if they attempt to transfer
+numbers in binary format from a CPU architecture to another over some
+channel: either 'live' via network connections or storing the numbers
+to secondary storage such as a disk file.
+
+Conflicting storage orders make utter mess out of the numbers: if a
+little-endian host (Intel, Alpha) stores 0x12345678 (305419896 in
+decimal), a big-endian host (Motorola, MIPS, Sparc, PA) reads it as
+0x78563412 (2018915346 in decimal). To avoid this problem in network
+(socket) connections use the C<pack()> and C<unpack()> formats C<"n">
+and C<"N">, the "network" orders, they are guaranteed to be portable.
+
+Different widths can cause truncation even between platforms of equal
+endianness: the platform of shorter width loses the upper parts of the
+number. There is no good solution for this problem except to avoid
+transferring or storing raw binary numbers.
+
+One can circumnavigate both these problems in two ways: either
+transfer and store numbers always in text format, instead of raw
+binary, or consider using modules like C<Data::Dumper> (included in
+the standard distribution as of Perl 5.005) and C<Storable>.
+
+=head2 Files
+
+Most platforms these days structure files in a hierarchical fashion.
+So, it is reasonably safe to assume that any platform supports the
+notion of a "path" to uniquely identify a file on the system. Just
+how that path is actually written, differs.
+
+While they are similar, file path specifications differ between Unix,
+Windows, S<Mac OS>, OS/2, VMS, S<RISC OS> and probably others. Unix,
+for example, is one of the few OSes that has the idea of a single root
+directory.
+
+VMS, Windows, and OS/2 can work similarly to Unix with C</> as path
+separator, or in their own idiosyncratic ways (such as having several
+root directories and various "unrooted" device files such NIL: and
+LPT:).
+
+S<Mac OS> uses C<:> as a path separator instead of C</>.
+
+C<RISC OS> perl can emulate Unix filenames with C</> as path
+separator, or go native and use C<.> for path separator and C<:> to
+signal filing systems and disc names.
+
+As with the newline problem above, there are modules that can help. The
+C<File::Spec> modules provide methods to do the Right Thing on whatever
+platform happens to be running the program.
+
+ use File::Spec;
+ chdir(File::Spec->updir()); # go up one directory
+ $file = File::Spec->catfile(
+ File::Spec->curdir(), 'temp', 'file.txt'
+ );
+ # on Unix and Win32, './temp/file.txt'
+ # on Mac OS, ':temp:file.txt'
+
+File::Spec is available in the standard distribution, as of version
+5.004_05.
+
+In general, production code should not have file paths hardcoded; making
+them user supplied or from a configuration file is better, keeping in mind
+that file path syntax varies on different machines.
+
+This is especially noticeable in scripts like Makefiles and test suites,
+which often assume C</> as a path separator for subdirectories.
+
+Also of use is C<File::Basename>, from the standard distribution, which
+splits a pathname into pieces (base filename, full path to directory,
+and file suffix).
+
+Even when on a single platform (if you can call UNIX a single
+platform), remember not to count on the existence or the contents of
+system-specific files, like F</etc/passwd>, F</etc/sendmail.conf>, or
+F</etc/resolv.conf>. For example the F</etc/passwd> may exist but it
+may not contain the encrypted passwords because the system is using
+some form of enhanced security-- or it may not contain all the
+accounts because the system is using NIS. If code does need to rely
+on such a file, include a description of the file and its format in
+the code's documentation, and make it easy for the user to override
+the default location of the file.
+
+Do not have two files of the same name with different case, like
+F<test.pl> and <Test.pl>, as many platforms have case-insensitive
+filenames. Also, try not to have non-word characters (except for C<.>)
+in the names, and keep them to the 8.3 convention, for maximum
+portability.
+
+Likewise, if using C<AutoSplit>, try to keep the split functions to
+8.3 naming and case-insensitive conventions; or, at the very least,
+make it so the resulting files have a unique (case-insensitively)
+first 8 characters.
+
+Don't assume C<E<lt>> won't be the first character of a filename. Always
+use C<E<gt>> explicitly to open a file for reading:
+
+ open(FILE, "<$existing_file") or die $!;
+
+
+=head2 System Interaction
+
+Not all platforms provide for the notion of a command line, necessarily.
+These are usually platforms that rely on a Graphical User Interface (GUI)
+for user interaction. So a program requiring command lines might not work
+everywhere. But this is probably for the user of the program to deal
+with.
+
+Some platforms can't delete or rename files that are being held open by
+the system. Remember to C<close> files when you are done with them.
+Don't C<unlink> or C<rename> an open file. Don't C<tie> to or C<open> a
+file that is already tied to or opened; C<untie> or C<close> first.
+
+Don't open the same file more than once at a time for writing, as some
+operating systems put mandatory locks on such files.
+
+Don't count on a specific environment variable existing in C<%ENV>.
+Don't count on C<%ENV> entries being case-sensitive, or even
+case-preserving.
+
+Don't count on signals.
+
+Don't count on filename globbing. Use C<opendir>, C<readdir>, and
+C<closedir> instead.
+
+Don't count on per-program environment variables, or per-program current
+directories.
+
+
+=head2 Interprocess Communication (IPC)
+
+In general, don't directly access the system in code that is meant to be
+portable. That means, no C<system>, C<exec>, C<fork>, C<pipe>, C<``>,
+C<qx//>, C<open> with a C<|>, nor any of the other things that makes being
+a Unix perl hacker worth being.
+
+Commands that launch external processes are generally supported on
+most platforms (though many of them do not support any type of forking),
+but the problem with using them arises from what you invoke with them.
+External tools are often named differently on different platforms, often
+not available in the same location, often accept different arguments,
+often behave differently, and often represent their results in a
+platform-dependent way. Thus you should seldom depend on them to produce
+consistent results.
+
+One especially common bit of Perl code is opening a pipe to sendmail:
+
+ open(MAIL, '|/usr/lib/sendmail -t') or die $!;
+
+This is fine for systems programming when sendmail is known to be
+available. But it is not fine for many non-Unix systems, and even
+some Unix systems that may not have sendmail installed. If a portable
+solution is needed, see the C<Mail::Send> and C<Mail::Mailer> modules
+in the C<MailTools> distribution. C<Mail::Mailer> provides several
+mailing methods, including mail, sendmail, and direct SMTP
+(via C<Net::SMTP>) if a mail transfer agent is not available.
+
+The rule of thumb for portable code is: Do it all in portable Perl, or
+use a module (that may internally implement it with platform-specific
+code, but expose a common interface).
+
+The UNIX System V IPC (C<msg*(), sem*(), shm*()>) is not available
+even in all UNIX platforms.
+
+=head2 External Subroutines (XS)
+
+XS code, in general, can be made to work with any platform; but dependent
+libraries, header files, etc., might not be readily available or
+portable, or the XS code itself might be platform-specific, just as Perl
+code might be. If the libraries and headers are portable, then it is
+normally reasonable to make sure the XS code is portable, too.
+
+There is a different kind of portability issue with writing XS
+code: availability of a C compiler on the end-user's system. C brings
+with it its own portability issues, and writing XS code will expose you to
+some of those. Writing purely in perl is a comparatively easier way to
+achieve portability.
+
+
+=head2 Standard Modules
+
+In general, the standard modules work across platforms. Notable
+exceptions are C<CPAN.pm> (which currently makes connections to external
+programs that may not be available), platform-specific modules (like
+C<ExtUtils::MM_VMS>), and DBM modules.
+
+There is no one DBM module that is available on all platforms.
+C<SDBM_File> and the others are generally available on all Unix and DOSish
+ports, but not in MacPerl, where only C<NBDM_File> and C<DB_File> are
+available.
+
+The good news is that at least some DBM module should be available, and
+C<AnyDBM_File> will use whichever module it can find. Of course, then
+the code needs to be fairly strict, dropping to the lowest common
+denominator (e.g., not exceeding 1K for each record).
+
+
+=head2 Time and Date
+
+The system's notion of time of day and calendar date is controlled in
+widely different ways. Don't assume the timezone is stored in C<$ENV{TZ}>,
+and even if it is, don't assume that you can control the timezone through
+that variable.
+
+Don't assume that the epoch starts at 00:00:00, January 1, 1970,
+because that is OS-specific. Better to store a date in an unambiguous
+representation. The ISO 8601 standard defines YYYY-MM-DD as the date
+format. A text representation (like C<1 Jan 1970>) can be easily
+converted into an OS-specific value using a module like
+C<Date::Parse>. An array of values, such as those returned by
+C<localtime>, can be converted to an OS-specific representation using
+C<Time::Local>.
+
+
+=head2 Character sets and character encoding
+
+Assume very little about character sets. Do not assume anything about
+the numerical values (C<ord()>, C<chr()>) of characters. Do not
+assume that the alphabetic characters are encoded contiguously (in
+numerical sense). Do no assume anything about the ordering of the
+characters. The lowercase letters may come before or after the
+uppercase letters, the lowercase and uppercase may be interlaced so
+that both 'a' and 'A' come before the 'b', the accented and other
+international characters may be interlaced so that E<auml> comes
+before the 'b'.
+
+
+=head2 Internationalisation
+
+If you may assume POSIX (a rather large assumption, that: in practise
+that means UNIX) you may read more about the POSIX locale system from
+L<perllocale>. The locale system at least attempts to make things a
+little bit more portable or at least more convenient and
+native-friendly for non-English users. The system affects character
+sets and encoding, and date and time formatting, among other things.
+
+
+=head2 System Resources
+
+If your code is destined for systems with severely constrained (or
+missing!) virtual memory systems then you want to be I<especially> mindful
+of avoiding wasteful constructs such as:
+
+ # NOTE: this is no longer "bad" in perl5.005
+ for (0..10000000) {} # bad
+ for (my $x = 0; $x <= 10000000; ++$x) {} # good
+
+ @lines = <VERY_LARGE_FILE>; # bad
+
+ while (<FILE>) {$file .= $_} # sometimes bad
+ $file = join('', <FILE>); # better
+
+The last two may appear unintuitive to most people. The first of those
+two constructs repeatedly grows a string, while the second allocates a
+large chunk of memory in one go. On some systems, the latter is more
+efficient that the former.
+
+
+=head2 Security
+
+Most multi-user platforms provide basic levels of security that is usually
+felt at the file-system level. Other platforms usually don't
+(unfortunately). Thus the notion of user id, or "home" directory, or even
+the state of being logged-in, may be unrecognizable on many platforms. If
+you write programs that are security conscious, it is usually best to know
+what type of system you will be operating under, and write code explicitly
+for that platform (or class of platforms).
+
+
+=head2 Style
+
+For those times when it is necessary to have platform-specific code,
+consider keeping the platform-specific code in one place, making porting
+to other platforms easier. Use the C<Config> module and the special
+variable C<$^O> to differentiate platforms, as described in
+L<"PLATFORMS">.
+
+
+=head1 CPAN Testers
+
+Modules uploaded to CPAN are tested by a variety of volunteers on
+different platforms. These CPAN testers are notified by mail of each
+new upload, and reply to the list with PASS, FAIL, NA (not applicable to
+this platform), or UNKNOWN (unknown), along with any relevant notations.
+
+The purpose of the testing is twofold: one, to help developers fix any
+problems in their code that crop up because of lack of testing on other
+platforms; two, to provide users with information about whether or not
+a given module works on a given platform.
+
+=over 4
+
+=item Mailing list: cpan-testers@perl.org
+
+=item Testing results: C<http://www.connect.net/gbarr/cpan-test/>
+
+=back
+
+
+=head1 PLATFORMS
+
+As of version 5.002, Perl is built with a C<$^O> variable that
+indicates the operating system it was built on. This was implemented
+to help speed up code that would otherwise have to C<use Config;> and
+use the value of C<$Config{'osname'}>. Of course, to get
+detailed information about the system, looking into C<%Config> is
+certainly recommended.
+
+=head2 Unix
+
+Perl works on a bewildering variety of Unix and Unix-like platforms (see
+e.g. most of the files in the F<hints/> directory in the source code kit).
+On most of these systems, the value of C<$^O> (hence C<$Config{'osname'}>,
+too) is determined by lowercasing and stripping punctuation from the first
+field of the string returned by typing C<uname -a> (or a similar command)
+at the shell prompt. Here, for example, are a few of the more popular
+Unix flavors:
+
+ uname $^O $Config{'archname'}
+ -------------------------------------------
+ AIX aix aix
+ FreeBSD freebsd freebsd-i386
+ Linux linux i386-linux
+ HP-UX hpux PA-RISC1.1
+ IRIX irix irix
+ OSF1 dec_osf alpha-dec_osf
+ SunOS solaris sun4-solaris
+ SunOS solaris i86pc-solaris
+ SunOS4 sunos sun4-sunos
+
+Note that because the C<$Config{'archname'}> may depend on the hardware
+architecture it may vary quite a lot, much more than the C<$^O>.
+
+=head2 DOS and Derivatives
+
+Perl has long been ported to PC style microcomputers running under
+systems like PC-DOS, MS-DOS, OS/2, and most Windows platforms you can
+bring yourself to mention (except for Windows CE, if you count that).
+Users familiar with I<COMMAND.COM> and/or I<CMD.EXE> style shells should
+be aware that each of these file specifications may have subtle
+differences:
+
+ $filespec0 = "c:/foo/bar/file.txt";
+ $filespec1 = "c:\\foo\\bar\\file.txt";
+ $filespec2 = 'c:\foo\bar\file.txt';
+ $filespec3 = 'c:\\foo\\bar\\file.txt';
+
+System calls accept either C</> or C<\> as the path separator. However,
+many command-line utilities of DOS vintage treat C</> as the option
+prefix, so they may get confused by filenames containing C</>. Aside
+from calling any external programs, C</> will work just fine, and
+probably better, as it is more consistent with popular usage, and avoids
+the problem of remembering what to backwhack and what not to.
+
+The DOS FAT filesystem can only accommodate "8.3" style filenames. Under
+the "case insensitive, but case preserving" HPFS (OS/2) and NTFS (NT)
+filesystems you may have to be careful about case returned with functions
+like C<readdir> or used with functions like C<open> or C<opendir>.
+
+DOS also treats several filenames as special, such as AUX, PRN, NUL, CON,
+COM1, LPT1, LPT2 etc. Unfortunately these filenames won't even work
+if you include an explicit directory prefix, in some cases. It is best
+to avoid such filenames, if you want your code to be portable to DOS
+and its derivatives.
+
+Users of these operating systems may also wish to make use of
+scripts such as I<pl2bat.bat> or I<pl2cmd> as appropriate to
+put wrappers around your scripts.
+
+Newline (C<\n>) is translated as C<\015\012> by STDIO when reading from
+and writing to files. C<binmode(FILEHANDLE)> will keep C<\n> translated
+as C<\012> for that filehandle. Since it is a noop on other systems,
+C<binmode> should be used for cross-platform code that deals with binary
+data.
+
+The C<$^O> variable and the C<$Config{'archname'}> values for various
+DOSish perls are as follows:
+
+ OS $^O $Config{'archname'}
+ --------------------------------------------
+ MS-DOS dos
+ PC-DOS dos
+ OS/2 os2
+ Windows 95 MSWin32 MSWin32-x86
+ Windows NT MSWin32 MSWin32-x86
+ Windows NT MSWin32 MSWin32-alpha
+ Windows NT MSWin32 MSWin32-ppc
+
+Also see:
+
+=over 4
+
+=item The djgpp environment for DOS, C<http://www.delorie.com/djgpp/>
+
+=item The EMX environment for DOS, OS/2, etc. C<emx@iaehv.nl>,
+C<http://www.juge.com/bbs/Hobb.19.html>
+
+=item Build instructions for Win32, L<perlwin32>.
+
+=item The ActiveState Pages, C<http://www.activestate.com/>
+
+=back
+
+
+=head2 S<Mac OS>
+
+Any module requiring XS compilation is right out for most people, because
+MacPerl is built using non-free (and non-cheap!) compilers. Some XS
+modules that can work with MacPerl are built and distributed in binary
+form on CPAN. See I<MacPerl: Power and Ease> and L<"CPAN Testers">
+for more details.
+
+Directories are specified as:
+
+ volume:folder:file for absolute pathnames
+ volume:folder: for absolute pathnames
+ :folder:file for relative pathnames
+ :folder: for relative pathnames
+ :file for relative pathnames
+ file for relative pathnames
+
+Files in a directory are stored in alphabetical order. Filenames are
+limited to 31 characters, and may include any character except C<:>,
+which is reserved as a path separator.
+
+Instead of C<flock>, see C<FSpSetFLock> and C<FSpRstFLock> in the
+C<Mac::Files> module.
+
+In the MacPerl application, you can't run a program from the command line;
+programs that expect C<@ARGV> to be populated can be edited with something
+like the following, which brings up a dialog box asking for the command
+line arguments.
+
+ if (!@ARGV) {
+ @ARGV = split /\s+/, MacPerl::Ask('Arguments?');
+ }
+
+A MacPerl script saved as a droplet will populate C<@ARGV> with the full
+pathnames of the files dropped onto the script.
+
+Mac users can use programs on a kind of command line under MPW (Macintosh
+Programmer's Workshop, a free development environment from Apple).
+MacPerl was first introduced as an MPW tool, and MPW can be used like a
+shell:
+
+ perl myscript.plx some arguments
+
+ToolServer is another app from Apple that provides access to MPW tools
+from MPW and the MacPerl app, which allows MacPerl programs to use
+C<system>, backticks, and piped C<open>.
+
+"S<Mac OS>" is the proper name for the operating system, but the value
+in C<$^O> is "MacOS". To determine architecture, version, or whether
+the application or MPW tool version is running, check:
+
+ $is_app = $MacPerl::Version =~ /App/;
+ $is_tool = $MacPerl::Version =~ /MPW/;
+ ($version) = $MacPerl::Version =~ /^(\S+)/;
+ $is_ppc = $MacPerl::Architecture eq 'MacPPC';
+ $is_68k = $MacPerl::Architecture eq 'Mac68K';
+
+S<Mac OS X>, to be based on NeXT's OpenStep OS, will be able to run
+MacPerl natively (in the Blue Box, and even in the Yellow Box, once some
+changes to the toolbox calls are made), but Unix perl will also run
+natively.
+
+Also see:
+
+=over 4
+
+=item The MacPerl Pages, C<http://www.ptf.com/macperl/>.
+
+=item The MacPerl mailing list, C<mac-perl-request@iis.ee.ethz.ch>.
+
+=back
+
+
+=head2 VMS
+
+Perl on VMS is discussed in F<vms/perlvms.pod> in the perl distribution.
+Note that perl on VMS can accept either VMS- or Unix-style file
+specifications as in either of the following:
+
+ $ perl -ne "print if /perl_setup/i" SYS$LOGIN:LOGIN.COM
+ $ perl -ne "print if /perl_setup/i" /sys$login/login.com
+
+but not a mixture of both as in:
+
+ $ perl -ne "print if /perl_setup/i" sys$login:/login.com
+ Can't open sys$login:/login.com: file specification syntax error
+
+Interacting with Perl from the Digital Command Language (DCL) shell
+often requires a different set of quotation marks than Unix shells do.
+For example:
+
+ $ perl -e "print ""Hello, world.\n"""
+ Hello, world.
+
+There are a number of ways to wrap your perl scripts in DCL .COM files if
+you are so inclined. For example:
+
+ $ write sys$output "Hello from DCL!"
+ $ if p1 .eqs. ""
+ $ then perl -x 'f$environment("PROCEDURE")
+ $ else perl -x - 'p1 'p2 'p3 'p4 'p5 'p6 'p7 'p8
+ $ deck/dollars="__END__"
+ #!/usr/bin/perl
+
+ print "Hello from Perl!\n";
+
+ __END__
+ $ endif
+
+Do take care with C<$ ASSIGN/nolog/user SYS$COMMAND: SYS$INPUT> if your
+perl-in-DCL script expects to do things like C<$read = E<lt>STDINE<gt>;>.
+
+Filenames are in the format "name.extension;version". The maximum
+length for filenames is 39 characters, and the maximum length for
+extensions is also 39 characters. Version is a number from 1 to
+32767. Valid characters are C</[A-Z0-9$_-]/>.
+
+VMS' RMS filesystem is case insensitive and does not preserve case.
+C<readdir> returns lowercased filenames, but specifying a file for
+opening remains case insensitive. Files without extensions have a
+trailing period on them, so doing a C<readdir> with a file named F<A.;5>
+will return F<a.> (though that file could be opened with
+C<open(FH, 'A')>).
+
+RMS had an eight level limit on directory depths from any rooted logical
+(allowing 16 levels overall) prior to VMS 7.2. Hence
+C<PERL_ROOT:[LIB.2.3.4.5.6.7.8]> is a valid directory specification but
+C<PERL_ROOT:[LIB.2.3.4.5.6.7.8.9]> is not. F<Makefile.PL> authors might
+have to take this into account, but at least they can refer to the former
+as C</PERL_ROOT/lib/2/3/4/5/6/7/8/>.
+
+The C<VMS::Filespec> module, which gets installed as part of the build
+process on VMS, is a pure Perl module that can easily be installed on
+non-VMS platforms and can be helpful for conversions to and from RMS
+native formats.
+
+What C<\n> represents depends on the type of file that is open. It could
+be C<\015>, C<\012>, C<\015\012>, or nothing. Reading from a file
+translates newlines to C<\012>, unless C<binmode> was executed on that
+handle, just like DOSish perls.
+
+TCP/IP stacks are optional on VMS, so socket routines might not be
+implemented. UDP sockets may not be supported.
+
+The value of C<$^O> on OpenVMS is "VMS". To determine the architecture
+that you are running on without resorting to loading all of C<%Config>
+you can examine the content of the C<@INC> array like so:
+
+ if (grep(/VMS_AXP/, @INC)) {
+ print "I'm on Alpha!\n";
+ } elsif (grep(/VMS_VAX/, @INC)) {
+ print "I'm on VAX!\n";
+ } else {
+ print "I'm not so sure about where $^O is...\n";
+ }
+
+Also see:
+
+=over 4
+
+=item L<perlvms.pod>
+
+=item vmsperl list, C<vmsperl-request@newman.upenn.edu>
+
+Put words C<SUBSCRIBE VMSPERL> in message body.
+
+=item vmsperl on the web, C<http://www.sidhe.org/vmsperl/index.html>
+
+=back
+
+
+=head2 EBCDIC Platforms
+
+Recent versions of Perl have been ported to platforms such as OS/400 on
+AS/400 minicomputers as well as OS/390 for IBM Mainframes. Such computers
+use EBCDIC character sets internally (usually Character Code Set ID 00819
+for OS/400 and IBM-1047 for OS/390). Note that on the mainframe perl
+currently works under the "Unix system services for OS/390" (formerly
+known as OpenEdition).
+
+As of R2.5 of USS for OS/390 that Unix sub-system did not support the
+C<#!> shebang trick for script invocation. Hence, on OS/390 perl scripts
+can executed with a header similar to the following simple script:
+
+ : # use perl
+ eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}'
+ if 0;
+ #!/usr/local/bin/perl # just a comment really
+
+ print "Hello from perl!\n";
+
+On these platforms, bear in mind that the EBCDIC character set may have
+an effect on what happens with some perl functions (such as C<chr>,
+C<pack>, C<print>, C<printf>, C<ord>, C<sort>, C<sprintf>, C<unpack>), as
+well as bit-fiddling with ASCII constants using operators like C<^>, C<&>
+and C<|>, not to mention dealing with socket interfaces to ASCII computers
+(see L<"NEWLINES">).
+
+Fortunately, most web servers for the mainframe will correctly translate
+the C<\n> in the following statement to its ASCII equivalent (note that
+C<\r> is the same under both Unix and OS/390):
+
+ print "Content-type: text/html\r\n\r\n";
+
+The value of C<$^O> on OS/390 is "os390".
+
+Some simple tricks for determining if you are running on an EBCDIC
+platform could include any of the following (perhaps all):
+
+ if ("\t" eq "\05") { print "EBCDIC may be spoken here!\n"; }
+
+ if (ord('A') == 193) { print "EBCDIC may be spoken here!\n"; }
+
+ if (chr(169) eq 'z') { print "EBCDIC may be spoken here!\n"; }
+
+Note that one thing you may not want to rely on is the EBCDIC encoding
+of punctuation characters since these may differ from code page to code
+page (and once your module or script is rumoured to work with EBCDIC,
+folks will want it to work with all EBCDIC character sets).
+
+Also see:
+
+=over 4
+
+=item perl-mvs list
+
+The perl-mvs@perl.org list is for discussion of porting issues as well as
+general usage issues for all EBCDIC Perls. Send a message body of
+"subscribe perl-mvs" to majordomo@perl.org.
+
+=item AS/400 Perl information at C<http://as400.rochester.ibm.com/>
+
+=back
+
+
+=head2 Acorn RISC OS
+
+As Acorns use ASCII with newlines (C<\n>) in text files as C<\012> like
+Unix and Unix filename emulation is turned on by default, it is quite
+likely that most simple scripts will work "out of the box". The native
+filing system is modular, and individual filing systems are free to be
+case-sensitive or insensitive, and are usually case-preserving. Some
+native filing systems have name length limits which file and directory
+names are silently truncated to fit - scripts should be aware that the
+standard disc filing system currently has a name length limit of B<10>
+characters, with up to 77 items in a directory, but other filing systems
+may not impose such limitations.
+
+Native filenames are of the form
+
+ Filesystem#Special_Field::DiscName.$.Directory.Directory.File
+
+where
+
+ Special_Field is not usually present, but may contain . and $ .
+ Filesystem =~ m|[A-Za-z0-9_]|
+ DsicName =~ m|[A-Za-z0-9_/]|
+ $ represents the root directory
+ . is the path separator
+ @ is the current directory (per filesystem but machine global)
+ ^ is the parent directory
+ Directory and File =~ m|[^\0- "\.\$\%\&:\@\\^\|\177]+|
+
+The default filename translation is roughly C<tr|/.|./|;>
+
+Note that C<"ADFS::HardDisc.$.File" ne 'ADFS::HardDisc.$.File'> and that
+the second stage of C<$> interpolation in regular expressions will fall
+foul of the C<$.> if scripts are not careful.
+
+Logical paths specified by system variables containing comma-separated
+search lists are also allowed, hence C<System:Modules> is a valid
+filename, and the filesystem will prefix C<Modules> with each section of
+C<System$Path> until a name is made that points to an object on disc.
+Writing to a new file C<System:Modules> would only be allowed if
+C<System$Path> contains a single item list. The filesystem will also
+expand system variables in filenames if enclosed in angle brackets, so
+C<E<lt>System$DirE<gt>.Modules> would look for the file
+S<C<$ENV{'System$Dir'} . 'Modules'>>. The obvious implication of this is
+that B<fully qualified filenames can start with C<E<lt>E<gt>> and should
+be protected when C<open> is used for input.
+
+Because C<.> was in use as a directory separator and filenames could not
+be assumed to be unique after 10 characters, Acorn implemented the C
+compiler to strip the trailing C<.c> C<.h> C<.s> and C<.o> suffix from
+filenames specified in source code and store the respective files in
+subdirectories named after the suffix. Hence files are translated:
+
+ foo.h h.foo
+ C:foo.h C:h.foo (logical path variable)
+ sys/os.h sys.h.os (C compiler groks Unix-speak)
+ 10charname.c c.10charname
+ 10charname.o o.10charname
+ 11charname_.c c.11charname (assuming filesystem truncates at 10)
+
+The Unix emulation library's translation of filenames to native assumes
+that this sort of translation is required, and allows a user defined list
+of known suffixes which it will transpose in this fashion. This may
+appear transparent, but consider that with these rules C<foo/bar/baz.h>
+and C<foo/bar/h/baz> both map to C<foo.bar.h.baz>, and that C<readdir> and
+C<glob> cannot and do not attempt to emulate the reverse mapping. Other
+C<.>s in filenames are translated to C</>.
+
+As implied above the environment accessed through C<%ENV> is global, and
+the convention is that program specific environment variables are of the
+form C<Program$Name>. Each filing system maintains a current directory,
+and the current filing system's current directory is the B<global> current
+directory. Consequently, sociable scripts don't change the current
+directory but rely on full pathnames, and scripts (and Makefiles) cannot
+assume that they can spawn a child process which can change the current
+directory without affecting its parent (and everyone else for that
+matter).
+
+As native operating system filehandles are global and currently are
+allocated down from 255, with 0 being a reserved value the Unix emulation
+library emulates Unix filehandles. Consequently, you can't rely on
+passing C<STDIN>, C<STDOUT>, or C<STDERR> to your children.
+
+The desire of users to express filenames of the form
+C<E<lt>Foo$DirE<gt>.Bar> on the command line unquoted causes problems,
+too: C<``> command output capture has to perform a guessing game. It
+assumes that a string C<E<lt>[^E<lt>E<gt>]+\$[^E<lt>E<gt>]E<gt>> is a
+reference to an environment variable, whereas anything else involving
+C<E<lt>> or C<E<gt>> is redirection, and generally manages to be 99%
+right. Of course, the problem remains that scripts cannot rely on any
+Unix tools being available, or that any tools found have Unix-like command
+line arguments.
+
+Extensions and XS are, in theory, buildable by anyone using free tools.
+In practice, many don't, as users of the Acorn platform are used to binary
+distribution. MakeMaker does run, but no available make currently copes
+with MakeMaker's makefiles; even if/when this is fixed, the lack of a
+Unix-like shell can cause problems with makefile rules, especially lines
+of the form C<cd sdbm && make all>, and anything using quoting.
+
+"S<RISC OS>" is the proper name for the operating system, but the value
+in C<$^O> is "riscos" (because we don't like shouting).
+
+Also see:
+
+=over 4
+
+=item perl list
+
+=back
+
+
+=head2 Other perls
+
+Perl has been ported to a variety of platforms that do not fit into any of
+the above categories. Some, such as AmigaOS, BeOS, QNX, and Plan 9, have
+been well-integrated into the standard Perl source code kit. You may need
+to see the F<ports/> directory on CPAN for information, and possibly
+binaries, for the likes of: aos, atari, lynxos, riscos, Tandem Guardian,
+vos, I<etc.> (yes we know that some of these OSes may fall under the Unix
+category, but we are not a standards body.)
+
+See also:
+
+=over 4
+
+=item Atari, Guido Flohr's page C<http://stud.uni-sb.de/~gufl0000/>
+
+=item HP 300 MPE/iX C<http://www.cccd.edu/~markb/perlix.html>
+
+=item Novell Netware
+
+A free perl5-based PERL.NLM for Novell Netware is available from
+C<http://www.novell.com/>
+
+=back
+
+
+=head1 FUNCTION IMPLEMENTATIONS
+
+Listed below are functions unimplemented or implemented differently on
+various platforms. Following each description will be, in parentheses, a
+list of platforms that the description applies to.
+
+The list may very well be incomplete, or wrong in some places. When in
+doubt, consult the platform-specific README files in the Perl source
+distribution, and other documentation resources for a given port.
+
+Be aware, moreover, that even among Unix-ish systems there are variations.
+
+For many functions, you can also query C<%Config>, exported by default
+from C<Config.pm>. For example, to check if the platform has the C<lstat>
+call, check C<$Config{'d_lstat'}>. See L<Config.pm> for a full
+description of available variables.
+
+
+=head2 Alphabetical Listing of Perl Functions
+
+=over 8
+
+=item -X FILEHANDLE
+
+=item -X EXPR
+
+=item -X
+
+C<-r>, C<-w>, and C<-x> have only a very limited meaning; directories
+and applications are executable, and there are no uid/gid
+considerations. C<-o> is not supported. (S<Mac OS>)
+
+C<-r>, C<-w>, C<-x>, and C<-o> tell whether or not file is accessible,
+which may not reflect UIC-based file protections. (VMS)
+
+C<-s> returns the size of the data fork, not the total size of data fork
+plus resource fork. (S<Mac OS>).
+
+C<-s> by name on an open file will return the space reserved on disk,
+rather than the current extent. C<-s> on an open filehandle returns the
+current size. (S<RISC OS>)
+
+C<-R>, C<-W>, C<-X>, C<-O> are indistinguishable from C<-r>, C<-w>,
+C<-x>, C<-o>. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+C<-b>, C<-c>, C<-k>, C<-g>, C<-p>, C<-u>, C<-A> are not implemented.
+(S<Mac OS>)
+
+C<-g>, C<-k>, C<-l>, C<-p>, C<-u>, C<-A> are not particularly meaningful.
+(Win32, VMS, S<RISC OS>)
+
+C<-d> is true if passed a device spec without an explicit directory.
+(VMS)
+
+C<-T> and C<-B> are implemented, but might misclassify Mac text files
+with foreign characters; this is the case will all platforms, but may
+affect S<Mac OS> often. (S<Mac OS>)
+
+C<-x> (or C<-X>) determine if a file ends in one of the executable
+suffixes. C<-S> is meaningless. (Win32)
+
+C<-x> (or C<-X>) determine if a file has an executable file type.
+(S<RISC OS>)
+
+=item binmode FILEHANDLE
+
+Meaningless. (S<Mac OS>, S<RISC OS>)
+
+Reopens file and restores pointer; if function fails, underlying
+filehandle may be closed, or pointer may be in a different position.
+(VMS)
+
+The value returned by C<tell> may be affected after the call, and
+the filehandle may be flushed. (Win32)
+
+=item chmod LIST
+
+Only limited meaning. Disabling/enabling write permission is mapped to
+locking/unlocking the file. (S<Mac OS>)
+
+Only good for changing "owner" read-write access, "group", and "other"
+bits are meaningless. (Win32)
+
+Only good for changing "owner" and "other" read-write access. (S<RISC OS>)
+
+=item chown LIST
+
+Not implemented. (S<Mac OS>, Win32, Plan9, S<RISC OS>)
+
+Does nothing, but won't fail. (Win32)
+
+=item chroot FILENAME
+
+=item chroot
+
+Not implemented. (S<Mac OS>, Win32, VMS, Plan9, S<RISC OS>)
+
+=item crypt PLAINTEXT,SALT
+
+May not be available if library or source was not provided when building
+perl. (Win32)
+
+=item dbmclose HASH
+
+Not implemented. (VMS, Plan9)
+
+=item dbmopen HASH,DBNAME,MODE
+
+Not implemented. (VMS, Plan9)
+
+=item dump LABEL
+
+Not useful. (S<Mac OS>, S<RISC OS>)
+
+Not implemented. (Win32)
+
+Invokes VMS debugger. (VMS)
+
+=item exec LIST
+
+Not implemented. (S<Mac OS>)
+
+=item fcntl FILEHANDLE,FUNCTION,SCALAR
+
+Not implemented. (Win32, VMS)
+
+=item flock FILEHANDLE,OPERATION
+
+Not implemented (S<Mac OS>, VMS, S<RISC OS>).
+
+Available only on Windows NT (not on Windows 95). (Win32)
+
+=item fork
+
+Not implemented. (S<Mac OS>, Win32, AmigaOS, S<RISC OS>)
+
+=item getlogin
+
+Not implemented. (S<Mac OS>, S<RISC OS>)
+
+=item getpgrp PID
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item getppid
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item getpriority WHICH,WHO
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item getpwnam NAME
+
+Not implemented. (S<Mac OS>, Win32)
+
+Not useful. (S<RISC OS>)
+
+=item getgrnam NAME
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item getnetbyname NAME
+
+Not implemented. (S<Mac OS>, Win32, Plan9)
+
+=item getpwuid UID
+
+Not implemented. (S<Mac OS>, Win32)
+
+Not useful. (S<RISC OS>)
+
+=item getgrgid GID
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item getnetbyaddr ADDR,ADDRTYPE
+
+Not implemented. (S<Mac OS>, Win32, Plan9)
+
+=item getprotobynumber NUMBER
+
+Not implemented. (S<Mac OS>)
+
+=item getservbyport PORT,PROTO
+
+Not implemented. (S<Mac OS>)
+
+=item getpwent
+
+Not implemented. (S<Mac OS>, Win32)
+
+=item getgrent
+
+Not implemented. (S<Mac OS>, Win32, VMS)
+
+=item gethostent
+
+Not implemented. (S<Mac OS>, Win32)
+
+=item getnetent
+
+Not implemented. (S<Mac OS>, Win32, Plan9)
+
+=item getprotoent
+
+Not implemented. (S<Mac OS>, Win32, Plan9)
+
+=item getservent
+
+Not implemented. (Win32, Plan9)
+
+=item setpwent
+
+Not implemented. (S<Mac OS>, Win32, S<RISC OS>)
+
+=item setgrent
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item sethostent STAYOPEN
+
+Not implemented. (S<Mac OS>, Win32, Plan9, S<RISC OS>)
+
+=item setnetent STAYOPEN
+
+Not implemented. (S<Mac OS>, Win32, Plan9, S<RISC OS>)
+
+=item setprotoent STAYOPEN
+
+Not implemented. (S<Mac OS>, Win32, Plan9, S<RISC OS>)
+
+=item setservent STAYOPEN
+
+Not implemented. (Plan9, Win32, S<RISC OS>)
+
+=item endpwent
+
+Not implemented. (S<Mac OS>, Win32)
+
+=item endgrent
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item endhostent
+
+Not implemented. (S<Mac OS>, Win32)
+
+=item endnetent
+
+Not implemented. (S<Mac OS>, Win32, Plan9)
+
+=item endprotoent
+
+Not implemented. (S<Mac OS>, Win32, Plan9)
+
+=item endservent
+
+Not implemented. (Plan9, Win32)
+
+=item getsockopt SOCKET,LEVEL,OPTNAME
+
+Not implemented. (S<Mac OS>, Plan9)
+
+=item glob EXPR
+
+=item glob
+
+Globbing built-in, but only C<*> and C<?> metacharacters are supported.
+(S<Mac OS>)
+
+Features depend on external perlglob.exe or perlglob.bat. May be
+overridden with something like File::DosGlob, which is recommended.
+(Win32)
+
+Globbing built-in, but only C<*> and C<?> metacharacters are supported.
+Globbing relies on operating system calls, which may return filenames
+in any order. As most filesystems are case-insensitive, even "sorted"
+filenames will not be in case-sensitive order. (S<RISC OS>)
+
+=item ioctl FILEHANDLE,FUNCTION,SCALAR
+
+Not implemented. (VMS)
+
+Available only for socket handles, and it does what the ioctlsocket() call
+in the Winsock API does. (Win32)
+
+Available only for socket handles. (S<RISC OS>)
+
+=item kill LIST
+
+Not implemented, hence not useful for taint checking. (S<Mac OS>,
+S<RISC OS>)
+
+Available only for process handles returned by the C<system(1, ...)>
+method of spawning a process. (Win32)
+
+=item link OLDFILE,NEWFILE
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item lstat FILEHANDLE
+
+=item lstat EXPR
+
+=item lstat
+
+Not implemented. (VMS, S<RISC OS>)
+
+Return values may be bogus. (Win32)
+
+=item msgctl ID,CMD,ARG
+
+=item msgget KEY,FLAGS
+
+=item msgsnd ID,MSG,FLAGS
+
+=item msgrcv ID,VAR,SIZE,TYPE,FLAGS
+
+Not implemented. (S<Mac OS>, Win32, VMS, Plan9, S<RISC OS>)
+
+=item open FILEHANDLE,EXPR
+
+=item open FILEHANDLE
+
+The C<|> variants are only supported if ToolServer is installed.
+(S<Mac OS>)
+
+open to C<|-> and C<-|> are unsupported. (S<Mac OS>, Win32, S<RISC OS>)
+
+=item pipe READHANDLE,WRITEHANDLE
+
+Not implemented. (S<Mac OS>)
+
+=item readlink EXPR
+
+=item readlink
+
+Not implemented. (Win32, VMS, S<RISC OS>)
+
+=item select RBITS,WBITS,EBITS,TIMEOUT
+
+Only implemented on sockets. (Win32)
+
+Only reliable on sockets. (S<RISC OS>)
+
+=item semctl ID,SEMNUM,CMD,ARG
+
+=item semget KEY,NSEMS,FLAGS
+
+=item semop KEY,OPSTRING
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item setpgrp PID,PGRP
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item setpriority WHICH,WHO,PRIORITY
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL
+
+Not implemented. (S<Mac OS>, Plan9)
+
+=item shmctl ID,CMD,ARG
+
+=item shmget KEY,SIZE,FLAGS
+
+=item shmread ID,VAR,POS,SIZE
+
+=item shmwrite ID,STRING,POS,SIZE
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item stat FILEHANDLE
+
+=item stat EXPR
+
+=item stat
+
+mtime and atime are the same thing, and ctime is creation time instead of
+inode change time. (S<Mac OS>)
+
+device and inode are not meaningful. (Win32)
+
+device and inode are not necessarily reliable. (VMS)
+
+mtime, atime and ctime all return the last modification time. Device and
+inode are not necessarily reliable. (S<RISC OS>)
+
+=item symlink OLDFILE,NEWFILE
+
+Not implemented. (Win32, VMS, S<RISC OS>)
+
+=item syscall LIST
+
+Not implemented. (S<Mac OS>, Win32, VMS, S<RISC OS>)
+
+=item sysopen FILEHANDLE,FILENAME,MODE,PERMS
+
+The traditional "0", "1", and "2" MODEs are implemented with different
+numeric values on some systems. The flags exported by C<Fcntl>
+(O_RDONLY, O_WRONLY, O_RDWR) should work everywhere though. (S<Mac
+OS>, OS/390)
+
+=item system LIST
+
+Only implemented if ToolServer is installed. (S<Mac OS>)
+
+As an optimization, may not call the command shell specified in
+C<$ENV{PERL5SHELL}>. C<system(1, @args)> spawns an external
+process and immediately returns its process designator, without
+waiting for it to terminate. Return value may be used subsequently
+in C<wait> or C<waitpid>. (Win32)
+
+There is no shell to process metacharacters, and the native standard is
+to pass a command line terminated by "\n" "\r" or "\0" to the spawned
+program. Redirection such as C<E<gt> foo> is performed (if at all) by
+the run time library of the spawned program. C<system> I<list> will call
+the Unix emulation library's C<exec> emulation, which attempts to provide
+emulation of the stdin, stdout, stderr in force in the parent, providing
+the child program uses a compatible version of the emulation library.
+I<scalar> will call the native command line direct and no such emulation
+of a child Unix program will exists. Mileage B<will> vary. (S<RISC OS>)
+
+=item times
+
+Only the first entry returned is nonzero. (S<Mac OS>)
+
+"cumulative" times will be bogus. On anything other than Windows NT,
+"system" time will be bogus, and "user" time is actually the time
+returned by the clock() function in the C runtime library. (Win32)
+
+Not useful. (S<RISC OS>)
+
+=item truncate FILEHANDLE,LENGTH
+
+=item truncate EXPR,LENGTH
+
+Not implemented. (VMS)
+
+=item umask EXPR
+
+=item umask
+
+Returns undef where unavailable, as of version 5.005.
+
+=item utime LIST
+
+Only the modification time is updated. (S<Mac OS>, VMS, S<RISC OS>)
+
+May not behave as expected. Behavior depends on the C runtime
+library's implementation of utime(), and the filesystem being
+used. The FAT filesystem typically does not support an "access
+time" field, and it may limit timestamps to a granularity of
+two seconds. (Win32)
+
+=item wait
+
+=item waitpid PID,FLAGS
+
+Not implemented. (S<Mac OS>)
+
+Can only be applied to process handles returned for processes spawned
+using C<system(1, ...)>. (Win32)
+
+Not useful. (S<RISC OS>)
+
+=back
+
+=head1 CHANGES
+
+=over 4
+
+=item 1.33, 06 August 1998
+
+Integrate more minor changes.
+
+=item 1.32, 05 August 1998
+
+Integrate more minor changes.
+
+=item 1.30, 03 August 1998
+
+Major update for RISC OS, other minor changes.
+
+=item 1.23, 10 July 1998
+
+First public release with perl5.005.
+
+=back
+
+=head1 AUTHORS / CONTRIBUTORS
+
+Abigail E<lt>abigail@fnx.comE<gt>,
+Charles Bailey E<lt>bailey@genetics.upenn.eduE<gt>,
+Graham Barr E<lt>gbarr@pobox.comE<gt>,
+Tom Christiansen E<lt>tchrist@perl.comE<gt>,
+Nicholas Clark E<lt>Nicholas.Clark@liverpool.ac.ukE<gt>,
+Andy Dougherty E<lt>doughera@lafcol.lafayette.eduE<gt>,
+Dominic Dunlop E<lt>domo@vo.luE<gt>,
+M.J.T. Guy E<lt>mjtg@cus.cam.ac.ukE<gt>,
+Luther Huffman E<lt>lutherh@stratcom.comE<gt>,
+Nick Ing-Simmons E<lt>nick@ni-s.u-net.comE<gt>,
+Andreas J. KE<ouml>nig E<lt>koenig@kulturbox.deE<gt>,
+Andrew M. Langmead E<lt>aml@world.std.comE<gt>,
+Paul Moore E<lt>Paul.Moore@uk.origin-it.comE<gt>,
+Chris Nandor E<lt>pudge@pobox.comE<gt>,
+Matthias Neeracher E<lt>neeri@iis.ee.ethz.chE<gt>,
+Gary Ng E<lt>71564.1743@CompuServe.COME<gt>,
+Tom Phoenix E<lt>rootbeer@teleport.comE<gt>,
+Peter Prymmer E<lt>pvhp@forte.comE<gt>,
+Hugo van der Sanden E<lt>hv@crypt0.demon.co.ukE<gt>,
+Gurusamy Sarathy E<lt>gsar@umich.eduE<gt>,
+Paul J. Schinder E<lt>schinder@pobox.comE<gt>,
+Dan Sugalski E<lt>sugalskd@ous.eduE<gt>,
+Nathan Torkington E<lt>gnat@frii.comE<gt>.
+
+This document is maintained by Chris Nandor.
+
+=head1 VERSION
+
+Version 1.34, last modified 07 August 1998.
+
+
diff --git a/contrib/perl5/pod/perlre.pod b/contrib/perl5/pod/perlre.pod
new file mode 100644
index 000000000000..382ba6524274
--- /dev/null
+++ b/contrib/perl5/pod/perlre.pod
@@ -0,0 +1,929 @@
+=head1 NAME
+
+perlre - Perl regular expressions
+
+=head1 DESCRIPTION
+
+This page describes the syntax of regular expressions in Perl. For a
+description of how to I<use> regular expressions in matching
+operations, plus various examples of the same, see discussion
+of C<m//>, C<s///>, C<qr//> and C<??> in L<perlop/"Regexp Quote-Like Operators">.
+
+The matching operations can have various modifiers. The modifiers
+that relate to the interpretation of the regular expression inside
+are listed below. For the modifiers that alter the way a regular expression
+is used by Perl, see L<perlop/"Regexp Quote-Like Operators"> and
+L<perlop/"Gory details of parsing quoted constructs">.
+
+=over 4
+
+=item i
+
+Do case-insensitive pattern matching.
+
+If C<use locale> is in effect, the case map is taken from the current
+locale. See L<perllocale>.
+
+=item m
+
+Treat string as multiple lines. That is, change "^" and "$" from matching
+at only the very start or end of the string to the start or end of any
+line anywhere within the string,
+
+=item s
+
+Treat string as single line. That is, change "." to match any character
+whatsoever, even a newline, which it normally would not match.
+
+The C</s> and C</m> modifiers both override the C<$*> setting. That is, no matter
+what C<$*> contains, C</s> without C</m> will force "^" to match only at the
+beginning of the string and "$" to match only at the end (or just before a
+newline at the end) of the string. Together, as /ms, they let the "." match
+any character whatsoever, while yet allowing "^" and "$" to match,
+respectively, just after and just before newlines within the string.
+
+=item x
+
+Extend your pattern's legibility by permitting whitespace and comments.
+
+=back
+
+These are usually written as "the C</x> modifier", even though the delimiter
+in question might not actually be a slash. In fact, any of these
+modifiers may also be embedded within the regular expression itself using
+the new C<(?...)> construct. See below.
+
+The C</x> modifier itself needs a little more explanation. It tells
+the regular expression parser to ignore whitespace that is neither
+backslashed nor within a character class. You can use this to break up
+your regular expression into (slightly) more readable parts. The C<#>
+character is also treated as a metacharacter introducing a comment,
+just as in ordinary Perl code. This also means that if you want real
+whitespace or C<#> characters in the pattern (outside of a character
+class, where they are unaffected by C</x>), that you'll either have to
+escape them or encode them using octal or hex escapes. Taken together,
+these features go a long way towards making Perl's regular expressions
+more readable. Note that you have to be careful not to include the
+pattern delimiter in the comment--perl has no way of knowing you did
+not intend to close the pattern early. See the C-comment deletion code
+in L<perlop>.
+
+=head2 Regular Expressions
+
+The patterns used in pattern matching are regular expressions such as
+those supplied in the Version 8 regex routines. (In fact, the
+routines are derived (distantly) from Henry Spencer's freely
+redistributable reimplementation of the V8 routines.)
+See L<Version 8 Regular Expressions> for details.
+
+In particular the following metacharacters have their standard I<egrep>-ish
+meanings:
+
+ \ Quote the next metacharacter
+ ^ Match the beginning of the line
+ . Match any character (except newline)
+ $ Match the end of the line (or before newline at the end)
+ | Alternation
+ () Grouping
+ [] Character class
+
+By default, the "^" character is guaranteed to match at only the
+beginning of the string, the "$" character at only the end (or before the
+newline at the end) and Perl does certain optimizations with the
+assumption that the string contains only one line. Embedded newlines
+will not be matched by "^" or "$". You may, however, wish to treat a
+string as a multi-line buffer, such that the "^" will match after any
+newline within the string, and "$" will match before any newline. At the
+cost of a little more overhead, you can do this by using the /m modifier
+on the pattern match operator. (Older programs did this by setting C<$*>,
+but this practice is now deprecated.)
+
+To facilitate multi-line substitutions, the "." character never matches a
+newline unless you use the C</s> modifier, which in effect tells Perl to pretend
+the string is a single line--even if it isn't. The C</s> modifier also
+overrides the setting of C<$*>, in case you have some (badly behaved) older
+code that sets it in another module.
+
+The following standard quantifiers are recognized:
+
+ * Match 0 or more times
+ + Match 1 or more times
+ ? Match 1 or 0 times
+ {n} Match exactly n times
+ {n,} Match at least n times
+ {n,m} Match at least n but not more than m times
+
+(If a curly bracket occurs in any other context, it is treated
+as a regular character.) The "*" modifier is equivalent to C<{0,}>, the "+"
+modifier to C<{1,}>, and the "?" modifier to C<{0,1}>. n and m are limited
+to integral values less than 65536.
+
+By default, a quantified subpattern is "greedy", that is, it will match as
+many times as possible (given a particular starting location) while still
+allowing the rest of the pattern to match. If you want it to match the
+minimum number of times possible, follow the quantifier with a "?". Note
+that the meanings don't change, just the "greediness":
+
+ *? Match 0 or more times
+ +? Match 1 or more times
+ ?? Match 0 or 1 time
+ {n}? Match exactly n times
+ {n,}? Match at least n times
+ {n,m}? Match at least n but not more than m times
+
+Because patterns are processed as double quoted strings, the following
+also work:
+
+ \t tab (HT, TAB)
+ \n newline (LF, NL)
+ \r return (CR)
+ \f form feed (FF)
+ \a alarm (bell) (BEL)
+ \e escape (think troff) (ESC)
+ \033 octal char (think of a PDP-11)
+ \x1B hex char
+ \c[ control char
+ \l lowercase next char (think vi)
+ \u uppercase next char (think vi)
+ \L lowercase till \E (think vi)
+ \U uppercase till \E (think vi)
+ \E end case modification (think vi)
+ \Q quote (disable) pattern metacharacters till \E
+
+If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u>
+and C<\U> is taken from the current locale. See L<perllocale>.
+
+You cannot include a literal C<$> or C<@> within a C<\Q> sequence.
+An unescaped C<$> or C<@> interpolates the corresponding variable,
+while escaping will cause the literal string C<\$> to be matched.
+You'll need to write something like C<m/\Quser\E\@\Qhost/>.
+
+In addition, Perl defines the following:
+
+ \w Match a "word" character (alphanumeric plus "_")
+ \W Match a non-word character
+ \s Match a whitespace character
+ \S Match a non-whitespace character
+ \d Match a digit character
+ \D Match a non-digit character
+
+A C<\w> matches a single alphanumeric character, not a whole
+word. To match a word you'd need to say C<\w+>. If C<use locale> is in
+effect, the list of alphabetic characters generated by C<\w> is taken
+from the current locale. See L<perllocale>. You may use C<\w>, C<\W>,
+C<\s>, C<\S>, C<\d>, and C<\D> within character classes (though not as
+either end of a range).
+
+Perl defines the following zero-width assertions:
+
+ \b Match a word boundary
+ \B Match a non-(word boundary)
+ \A Match only at beginning of string
+ \Z Match only at end of string, or before newline at the end
+ \z Match only at end of string
+ \G Match only where previous m//g left off (works only with /g)
+
+A word boundary (C<\b>) is defined as a spot between two characters that
+has a C<\w> on one side of it and a C<\W> on the other side of it (in
+either order), counting the imaginary characters off the beginning and
+end of the string as matching a C<\W>. (Within character classes C<\b>
+represents backspace rather than a word boundary.) The C<\A> and C<\Z> are
+just like "^" and "$", except that they won't match multiple times when the
+C</m> modifier is used, while "^" and "$" will match at every internal line
+boundary. To match the actual end of the string, not ignoring newline,
+you can use C<\z>. The C<\G> assertion can be used to chain global
+matches (using C<m//g>), as described in
+L<perlop/"Regexp Quote-Like Operators">.
+
+It is also useful when writing C<lex>-like scanners, when you have several
+patterns that you want to match against consequent substrings of your
+string, see the previous reference.
+The actual location where C<\G> will match can also be influenced
+by using C<pos()> as an lvalue. See L<perlfunc/pos>.
+
+When the bracketing construct C<( ... )> is used, \E<lt>digitE<gt> matches the
+digit'th substring. Outside of the pattern, always use "$" instead of "\"
+in front of the digit. (While the \E<lt>digitE<gt> notation can on rare occasion work
+outside the current pattern, this should not be relied upon. See the
+WARNING below.) The scope of $E<lt>digitE<gt> (and C<$`>, C<$&>, and C<$'>)
+extends to the end of the enclosing BLOCK or eval string, or to the next
+successful pattern match, whichever comes first. If you want to use
+parentheses to delimit a subpattern (e.g., a set of alternatives) without
+saving it as a subpattern, follow the ( with a ?:.
+
+You may have as many parentheses as you wish. If you have more
+than 9 substrings, the variables $10, $11, ... refer to the
+corresponding substring. Within the pattern, \10, \11, etc. refer back
+to substrings if there have been at least that many left parentheses before
+the backreference. Otherwise (for backward compatibility) \10 is the
+same as \010, a backspace, and \11 the same as \011, a tab. And so
+on. (\1 through \9 are always backreferences.)
+
+C<$+> returns whatever the last bracket match matched. C<$&> returns the
+entire matched string. (C<$0> used to return the same thing, but not any
+more.) C<$`> returns everything before the matched string. C<$'> returns
+everything after the matched string. Examples:
+
+ s/^([^ ]*) *([^ ]*)/$2 $1/; # swap first two words
+
+ if (/Time: (..):(..):(..)/) {
+ $hours = $1;
+ $minutes = $2;
+ $seconds = $3;
+ }
+
+Once perl sees that you need one of C<$&>, C<$`> or C<$'> anywhere in
+the program, it has to provide them on each and every pattern match.
+This can slow your program down. The same mechanism that handles
+these provides for the use of $1, $2, etc., so you pay the same price
+for each pattern that contains capturing parentheses. But if you never
+use $&, etc., in your script, then patterns I<without> capturing
+parentheses won't be penalized. So avoid $&, $', and $` if you can,
+but if you can't (and some algorithms really appreciate them), once
+you've used them once, use them at will, because you've already paid
+the price. As of 5.005, $& is not so costly as the other two.
+
+Backslashed metacharacters in Perl are
+alphanumeric, such as C<\b>, C<\w>, C<\n>. Unlike some other regular
+expression languages, there are no backslashed symbols that aren't
+alphanumeric. So anything that looks like \\, \(, \), \E<lt>, \E<gt>,
+\{, or \} is always interpreted as a literal character, not a
+metacharacter. This was once used in a common idiom to disable or
+quote the special meanings of regular expression metacharacters in a
+string that you want to use for a pattern. Simply quote all
+non-alphanumeric characters:
+
+ $pattern =~ s/(\W)/\\$1/g;
+
+Now it is much more common to see either the quotemeta() function or
+the C<\Q> escape sequence used to disable all metacharacters' special
+meanings like this:
+
+ /$unquoted\Q$quoted\E$unquoted/
+
+Perl defines a consistent extension syntax for regular expressions.
+The syntax is a pair of parentheses with a question mark as the first
+thing within the parentheses (this was a syntax error in older
+versions of Perl). The character after the question mark gives the
+function of the extension. Several extensions are already supported:
+
+=over 10
+
+=item C<(?#text)>
+
+A comment. The text is ignored. If the C</x> switch is used to enable
+whitespace formatting, a simple C<#> will suffice. Note that perl closes
+the comment as soon as it sees a C<)>, so there is no way to put a literal
+C<)> in the comment.
+
+=item C<(?:pattern)>
+
+=item C<(?imsx-imsx:pattern)>
+
+This is for clustering, not capturing; it groups subexpressions like
+"()", but doesn't make backreferences as "()" does. So
+
+ @fields = split(/\b(?:a|b|c)\b/)
+
+is like
+
+ @fields = split(/\b(a|b|c)\b/)
+
+but doesn't spit out extra fields.
+
+The letters between C<?> and C<:> act as flags modifiers, see
+L<C<(?imsx-imsx)>>. In particular,
+
+ /(?s-i:more.*than).*million/i
+
+is equivalent to more verbose
+
+ /(?:(?s-i)more.*than).*million/i
+
+=item C<(?=pattern)>
+
+A zero-width positive lookahead assertion. For example, C</\w+(?=\t)/>
+matches a word followed by a tab, without including the tab in C<$&>.
+
+=item C<(?!pattern)>
+
+A zero-width negative lookahead assertion. For example C</foo(?!bar)/>
+matches any occurrence of "foo" that isn't followed by "bar". Note
+however that lookahead and lookbehind are NOT the same thing. You cannot
+use this for lookbehind.
+
+If you are looking for a "bar" that isn't preceded by a "foo", C</(?!foo)bar/>
+will not do what you want. That's because the C<(?!foo)> is just saying that
+the next thing cannot be "foo"--and it's not, it's a "bar", so "foobar" will
+match. You would have to do something like C</(?!foo)...bar/> for that. We
+say "like" because there's the case of your "bar" not having three characters
+before it. You could cover that this way: C</(?:(?!foo)...|^.{0,2})bar/>.
+Sometimes it's still easier just to say:
+
+ if (/bar/ && $` !~ /foo$/)
+
+For lookbehind see below.
+
+=item C<(?E<lt>=pattern)>
+
+A zero-width positive lookbehind assertion. For example, C</(?E<lt>=\t)\w+/>
+matches a word following a tab, without including the tab in C<$&>.
+Works only for fixed-width lookbehind.
+
+=item C<(?<!pattern)>
+
+A zero-width negative lookbehind assertion. For example C</(?<!bar)foo/>
+matches any occurrence of "foo" that isn't following "bar".
+Works only for fixed-width lookbehind.
+
+=item C<(?{ code })>
+
+Experimental "evaluate any Perl code" zero-width assertion. Always
+succeeds. C<code> is not interpolated. Currently the rules to
+determine where the C<code> ends are somewhat convoluted.
+
+The C<code> is properly scoped in the following sense: if the assertion
+is backtracked (compare L<"Backtracking">), all the changes introduced after
+C<local>isation are undone, so
+
+ $_ = 'a' x 8;
+ m<
+ (?{ $cnt = 0 }) # Initialize $cnt.
+ (
+ a
+ (?{
+ local $cnt = $cnt + 1; # Update $cnt, backtracking-safe.
+ })
+ )*
+ aaaa
+ (?{ $res = $cnt }) # On success copy to non-localized
+ # location.
+ >x;
+
+will set C<$res = 4>. Note that after the match $cnt returns to the globally
+introduced value 0, since the scopes which restrict C<local> statements
+are unwound.
+
+This assertion may be used as L<C<(?(condition)yes-pattern|no-pattern)>>
+switch. If I<not> used in this way, the result of evaluation of C<code>
+is put into variable $^R. This happens immediately, so $^R can be used from
+other C<(?{ code })> assertions inside the same regular expression.
+
+The above assignment to $^R is properly localized, thus the old value of $^R
+is restored if the assertion is backtracked (compare L<"Backtracking">).
+
+Due to security concerns, this construction is not allowed if the regular
+expression involves run-time interpolation of variables, unless
+C<use re 'eval'> pragma is used (see L<re>), or the variables contain
+results of qr() operator (see L<perlop/"qr/STRING/imosx">).
+
+This restriction is due to the wide-spread (questionable) practice of
+using the construct
+
+ $re = <>;
+ chomp $re;
+ $string =~ /$re/;
+
+without tainting. While this code is frowned upon from security point
+of view, when C<(?{})> was introduced, it was considered bad to add
+I<new> security holes to existing scripts.
+
+B<NOTE:> Use of the above insecure snippet without also enabling taint mode
+is to be severely frowned upon. C<use re 'eval'> does not disable tainting
+checks, thus to allow $re in the above snippet to contain C<(?{})>
+I<with tainting enabled>, one needs both C<use re 'eval'> and untaint
+the $re.
+
+=item C<(?E<gt>pattern)>
+
+An "independent" subexpression. Matches the substring that a
+I<standalone> C<pattern> would match if anchored at the given position,
+B<and only this substring>.
+
+Say, C<^(?E<gt>a*)ab> will never match, since C<(?E<gt>a*)> (anchored
+at the beginning of string, as above) will match I<all> characters
+C<a> at the beginning of string, leaving no C<a> for C<ab> to match.
+In contrast, C<a*ab> will match the same as C<a+b>, since the match of
+the subgroup C<a*> is influenced by the following group C<ab> (see
+L<"Backtracking">). In particular, C<a*> inside C<a*ab> will match
+fewer characters than a standalone C<a*>, since this makes the tail match.
+
+An effect similar to C<(?E<gt>pattern)> may be achieved by
+
+ (?=(pattern))\1
+
+since the lookahead is in I<"logical"> context, thus matches the same
+substring as a standalone C<a+>. The following C<\1> eats the matched
+string, thus making a zero-length assertion into an analogue of
+C<(?E<gt>...)>. (The difference between these two constructs is that the
+second one uses a catching group, thus shifting ordinals of
+backreferences in the rest of a regular expression.)
+
+This construct is useful for optimizations of "eternal"
+matches, because it will not backtrack (see L<"Backtracking">).
+
+ m{ \(
+ (
+ [^()]+
+ |
+ \( [^()]* \)
+ )+
+ \)
+ }x
+
+That will efficiently match a nonempty group with matching
+two-or-less-level-deep parentheses. However, if there is no such group,
+it will take virtually forever on a long string. That's because there are
+so many different ways to split a long string into several substrings.
+This is what C<(.+)+> is doing, and C<(.+)+> is similar to a subpattern
+of the above pattern. Consider that the above pattern detects no-match
+on C<((()aaaaaaaaaaaaaaaaaa> in several seconds, but that each extra
+letter doubles this time. This exponential performance will make it
+appear that your program has hung.
+
+However, a tiny modification of this pattern
+
+ m{ \(
+ (
+ (?> [^()]+ )
+ |
+ \( [^()]* \)
+ )+
+ \)
+ }x
+
+which uses C<(?E<gt>...)> matches exactly when the one above does (verifying
+this yourself would be a productive exercise), but finishes in a fourth
+the time when used on a similar string with 1000000 C<a>s. Be aware,
+however, that this pattern currently triggers a warning message under
+B<-w> saying it C<"matches the null string many times">):
+
+On simple groups, such as the pattern C<(?> [^()]+ )>, a comparable
+effect may be achieved by negative lookahead, as in C<[^()]+ (?! [^()] )>.
+This was only 4 times slower on a string with 1000000 C<a>s.
+
+=item C<(?(condition)yes-pattern|no-pattern)>
+
+=item C<(?(condition)yes-pattern)>
+
+Conditional expression. C<(condition)> should be either an integer in
+parentheses (which is valid if the corresponding pair of parentheses
+matched), or lookahead/lookbehind/evaluate zero-width assertion.
+
+Say,
+
+ m{ ( \( )?
+ [^()]+
+ (?(1) \) )
+ }x
+
+matches a chunk of non-parentheses, possibly included in parentheses
+themselves.
+
+=item C<(?imsx-imsx)>
+
+One or more embedded pattern-match modifiers. This is particularly
+useful for patterns that are specified in a table somewhere, some of
+which want to be case sensitive, and some of which don't. The case
+insensitive ones need to include merely C<(?i)> at the front of the
+pattern. For example:
+
+ $pattern = "foobar";
+ if ( /$pattern/i ) { }
+
+ # more flexible:
+
+ $pattern = "(?i)foobar";
+ if ( /$pattern/ ) { }
+
+Letters after C<-> switch modifiers off.
+
+These modifiers are localized inside an enclosing group (if any). Say,
+
+ ( (?i) blah ) \s+ \1
+
+(assuming C<x> modifier, and no C<i> modifier outside of this group)
+will match a repeated (I<including the case>!) word C<blah> in any
+case.
+
+=back
+
+A question mark was chosen for this and for the new minimal-matching
+construct because 1) question mark is pretty rare in older regular
+expressions, and 2) whenever you see one, you should stop and "question"
+exactly what is going on. That's psychology...
+
+=head2 Backtracking
+
+A fundamental feature of regular expression matching involves the
+notion called I<backtracking>, which is currently used (when needed)
+by all regular expression quantifiers, namely C<*>, C<*?>, C<+>,
+C<+?>, C<{n,m}>, and C<{n,m}?>.
+
+For a regular expression to match, the I<entire> regular expression must
+match, not just part of it. So if the beginning of a pattern containing a
+quantifier succeeds in a way that causes later parts in the pattern to
+fail, the matching engine backs up and recalculates the beginning
+part--that's why it's called backtracking.
+
+Here is an example of backtracking: Let's say you want to find the
+word following "foo" in the string "Food is on the foo table.":
+
+ $_ = "Food is on the foo table.";
+ if ( /\b(foo)\s+(\w+)/i ) {
+ print "$2 follows $1.\n";
+ }
+
+When the match runs, the first part of the regular expression (C<\b(foo)>)
+finds a possible match right at the beginning of the string, and loads up
+$1 with "Foo". However, as soon as the matching engine sees that there's
+no whitespace following the "Foo" that it had saved in $1, it realizes its
+mistake and starts over again one character after where it had the
+tentative match. This time it goes all the way until the next occurrence
+of "foo". The complete regular expression matches this time, and you get
+the expected output of "table follows foo."
+
+Sometimes minimal matching can help a lot. Imagine you'd like to match
+everything between "foo" and "bar". Initially, you write something
+like this:
+
+ $_ = "The food is under the bar in the barn.";
+ if ( /foo(.*)bar/ ) {
+ print "got <$1>\n";
+ }
+
+Which perhaps unexpectedly yields:
+
+ got <d is under the bar in the >
+
+That's because C<.*> was greedy, so you get everything between the
+I<first> "foo" and the I<last> "bar". In this case, it's more effective
+to use minimal matching to make sure you get the text between a "foo"
+and the first "bar" thereafter.
+
+ if ( /foo(.*?)bar/ ) { print "got <$1>\n" }
+ got <d is under the >
+
+Here's another example: let's say you'd like to match a number at the end
+of a string, and you also want to keep the preceding part the match.
+So you write this:
+
+ $_ = "I have 2 numbers: 53147";
+ if ( /(.*)(\d*)/ ) { # Wrong!
+ print "Beginning is <$1>, number is <$2>.\n";
+ }
+
+That won't work at all, because C<.*> was greedy and gobbled up the
+whole string. As C<\d*> can match on an empty string the complete
+regular expression matched successfully.
+
+ Beginning is <I have 2 numbers: 53147>, number is <>.
+
+Here are some variants, most of which don't work:
+
+ $_ = "I have 2 numbers: 53147";
+ @pats = qw{
+ (.*)(\d*)
+ (.*)(\d+)
+ (.*?)(\d*)
+ (.*?)(\d+)
+ (.*)(\d+)$
+ (.*?)(\d+)$
+ (.*)\b(\d+)$
+ (.*\D)(\d+)$
+ };
+
+ for $pat (@pats) {
+ printf "%-12s ", $pat;
+ if ( /$pat/ ) {
+ print "<$1> <$2>\n";
+ } else {
+ print "FAIL\n";
+ }
+ }
+
+That will print out:
+
+ (.*)(\d*) <I have 2 numbers: 53147> <>
+ (.*)(\d+) <I have 2 numbers: 5314> <7>
+ (.*?)(\d*) <> <>
+ (.*?)(\d+) <I have > <2>
+ (.*)(\d+)$ <I have 2 numbers: 5314> <7>
+ (.*?)(\d+)$ <I have 2 numbers: > <53147>
+ (.*)\b(\d+)$ <I have 2 numbers: > <53147>
+ (.*\D)(\d+)$ <I have 2 numbers: > <53147>
+
+As you see, this can be a bit tricky. It's important to realize that a
+regular expression is merely a set of assertions that gives a definition
+of success. There may be 0, 1, or several different ways that the
+definition might succeed against a particular string. And if there are
+multiple ways it might succeed, you need to understand backtracking to
+know which variety of success you will achieve.
+
+When using lookahead assertions and negations, this can all get even
+tricker. Imagine you'd like to find a sequence of non-digits not
+followed by "123". You might try to write that as
+
+ $_ = "ABC123";
+ if ( /^\D*(?!123)/ ) { # Wrong!
+ print "Yup, no 123 in $_\n";
+ }
+
+But that isn't going to match; at least, not the way you're hoping. It
+claims that there is no 123 in the string. Here's a clearer picture of
+why it that pattern matches, contrary to popular expectations:
+
+ $x = 'ABC123' ;
+ $y = 'ABC445' ;
+
+ print "1: got $1\n" if $x =~ /^(ABC)(?!123)/ ;
+ print "2: got $1\n" if $y =~ /^(ABC)(?!123)/ ;
+
+ print "3: got $1\n" if $x =~ /^(\D*)(?!123)/ ;
+ print "4: got $1\n" if $y =~ /^(\D*)(?!123)/ ;
+
+This prints
+
+ 2: got ABC
+ 3: got AB
+ 4: got ABC
+
+You might have expected test 3 to fail because it seems to a more
+general purpose version of test 1. The important difference between
+them is that test 3 contains a quantifier (C<\D*>) and so can use
+backtracking, whereas test 1 will not. What's happening is
+that you've asked "Is it true that at the start of $x, following 0 or more
+non-digits, you have something that's not 123?" If the pattern matcher had
+let C<\D*> expand to "ABC", this would have caused the whole pattern to
+fail.
+The search engine will initially match C<\D*> with "ABC". Then it will
+try to match C<(?!123> with "123", which of course fails. But because
+a quantifier (C<\D*>) has been used in the regular expression, the
+search engine can backtrack and retry the match differently
+in the hope of matching the complete regular expression.
+
+The pattern really, I<really> wants to succeed, so it uses the
+standard pattern back-off-and-retry and lets C<\D*> expand to just "AB" this
+time. Now there's indeed something following "AB" that is not
+"123". It's in fact "C123", which suffices.
+
+We can deal with this by using both an assertion and a negation. We'll
+say that the first part in $1 must be followed by a digit, and in fact, it
+must also be followed by something that's not "123". Remember that the
+lookaheads are zero-width expressions--they only look, but don't consume
+any of the string in their match. So rewriting this way produces what
+you'd expect; that is, case 5 will fail, but case 6 succeeds:
+
+ print "5: got $1\n" if $x =~ /^(\D*)(?=\d)(?!123)/ ;
+ print "6: got $1\n" if $y =~ /^(\D*)(?=\d)(?!123)/ ;
+
+ 6: got ABC
+
+In other words, the two zero-width assertions next to each other work as though
+they're ANDed together, just as you'd use any builtin assertions: C</^$/>
+matches only if you're at the beginning of the line AND the end of the
+line simultaneously. The deeper underlying truth is that juxtaposition in
+regular expressions always means AND, except when you write an explicit OR
+using the vertical bar. C</ab/> means match "a" AND (then) match "b",
+although the attempted matches are made at different positions because "a"
+is not a zero-width assertion, but a one-width assertion.
+
+One warning: particularly complicated regular expressions can take
+exponential time to solve due to the immense number of possible ways they
+can use backtracking to try match. For example this will take a very long
+time to run
+
+ /((a{0,5}){0,5}){0,5}/
+
+And if you used C<*>'s instead of limiting it to 0 through 5 matches, then
+it would take literally forever--or until you ran out of stack space.
+
+A powerful tool for optimizing such beasts is "independent" groups,
+which do not backtrace (see L<C<(?E<gt>pattern)>>). Note also that
+zero-length lookahead/lookbehind assertions will not backtrace to make
+the tail match, since they are in "logical" context: only the fact
+whether they match or not is considered relevant. For an example
+where side-effects of a lookahead I<might> have influenced the
+following match, see L<C<(?E<gt>pattern)>>.
+
+=head2 Version 8 Regular Expressions
+
+In case you're not familiar with the "regular" Version 8 regex
+routines, here are the pattern-matching rules not described above.
+
+Any single character matches itself, unless it is a I<metacharacter>
+with a special meaning described here or above. You can cause
+characters that normally function as metacharacters to be interpreted
+literally by prefixing them with a "\" (e.g., "\." matches a ".", not any
+character; "\\" matches a "\"). A series of characters matches that
+series of characters in the target string, so the pattern C<blurfl>
+would match "blurfl" in the target string.
+
+You can specify a character class, by enclosing a list of characters
+in C<[]>, which will match any one character from the list. If the
+first character after the "[" is "^", the class matches any character not
+in the list. Within a list, the "-" character is used to specify a
+range, so that C<a-z> represents all characters between "a" and "z",
+inclusive. If you want "-" itself to be a member of a class, put it
+at the start or end of the list, or escape it with a backslash. (The
+following all specify the same class of three characters: C<[-az]>,
+C<[az-]>, and C<[a\-z]>. All are different from C<[a-z]>, which
+specifies a class containing twenty-six characters.)
+
+Characters may be specified using a metacharacter syntax much like that
+used in C: "\n" matches a newline, "\t" a tab, "\r" a carriage return,
+"\f" a form feed, etc. More generally, \I<nnn>, where I<nnn> is a string
+of octal digits, matches the character whose ASCII value is I<nnn>.
+Similarly, \xI<nn>, where I<nn> are hexadecimal digits, matches the
+character whose ASCII value is I<nn>. The expression \cI<x> matches the
+ASCII character control-I<x>. Finally, the "." metacharacter matches any
+character except "\n" (unless you use C</s>).
+
+You can specify a series of alternatives for a pattern using "|" to
+separate them, so that C<fee|fie|foe> will match any of "fee", "fie",
+or "foe" in the target string (as would C<f(e|i|o)e>). The
+first alternative includes everything from the last pattern delimiter
+("(", "[", or the beginning of the pattern) up to the first "|", and
+the last alternative contains everything from the last "|" to the next
+pattern delimiter. For this reason, it's common practice to include
+alternatives in parentheses, to minimize confusion about where they
+start and end.
+
+Alternatives are tried from left to right, so the first
+alternative found for which the entire expression matches, is the one that
+is chosen. This means that alternatives are not necessarily greedy. For
+example: when mathing C<foo|foot> against "barefoot", only the "foo"
+part will match, as that is the first alternative tried, and it successfully
+matches the target string. (This might not seem important, but it is
+important when you are capturing matched text using parentheses.)
+
+Also remember that "|" is interpreted as a literal within square brackets,
+so if you write C<[fee|fie|foe]> you're really only matching C<[feio|]>.
+
+Within a pattern, you may designate subpatterns for later reference by
+enclosing them in parentheses, and you may refer back to the I<n>th
+subpattern later in the pattern using the metacharacter \I<n>.
+Subpatterns are numbered based on the left to right order of their
+opening parenthesis. A backreference matches whatever
+actually matched the subpattern in the string being examined, not the
+rules for that subpattern. Therefore, C<(0|0x)\d*\s\1\d*> will
+match "0x1234 0x4321", but not "0x1234 01234", because subpattern 1
+actually matched "0x", even though the rule C<0|0x> could
+potentially match the leading 0 in the second number.
+
+=head2 WARNING on \1 vs $1
+
+Some people get too used to writing things like:
+
+ $pattern =~ s/(\W)/\\\1/g;
+
+This is grandfathered for the RHS of a substitute to avoid shocking the
+B<sed> addicts, but it's a dirty habit to get into. That's because in
+PerlThink, the righthand side of a C<s///> is a double-quoted string. C<\1> in
+the usual double-quoted string means a control-A. The customary Unix
+meaning of C<\1> is kludged in for C<s///>. However, if you get into the habit
+of doing that, you get yourself into trouble if you then add an C</e>
+modifier.
+
+ s/(\d+)/ \1 + 1 /eg; # causes warning under -w
+
+Or if you try to do
+
+ s/(\d+)/\1000/;
+
+You can't disambiguate that by saying C<\{1}000>, whereas you can fix it with
+C<${1}000>. Basically, the operation of interpolation should not be confused
+with the operation of matching a backreference. Certainly they mean two
+different things on the I<left> side of the C<s///>.
+
+=head2 Repeated patterns matching zero-length substring
+
+WARNING: Difficult material (and prose) ahead. This section needs a rewrite.
+
+Regular expressions provide a terse and powerful programming language. As
+with most other power tools, power comes together with the ability
+to wreak havoc.
+
+A common abuse of this power stems from the ability to make infinite
+loops using regular expressions, with something as innocous as:
+
+ 'foo' =~ m{ ( o? )* }x;
+
+The C<o?> can match at the beginning of C<'foo'>, and since the position
+in the string is not moved by the match, C<o?> would match again and again
+due to the C<*> modifier. Another common way to create a similar cycle
+is with the looping modifier C<//g>:
+
+ @matches = ( 'foo' =~ m{ o? }xg );
+
+or
+
+ print "match: <$&>\n" while 'foo' =~ m{ o? }xg;
+
+or the loop implied by split().
+
+However, long experience has shown that many programming tasks may
+be significantly simplified by using repeated subexpressions which
+may match zero-length substrings, with a simple example being:
+
+ @chars = split //, $string; # // is not magic in split
+ ($whitewashed = $string) =~ s/()/ /g; # parens avoid magic s// /
+
+Thus Perl allows the C</()/> construct, which I<forcefully breaks
+the infinite loop>. The rules for this are different for lower-level
+loops given by the greedy modifiers C<*+{}>, and for higher-level
+ones like the C</g> modifier or split() operator.
+
+The lower-level loops are I<interrupted> when it is detected that a
+repeated expression did match a zero-length substring, thus
+
+ m{ (?: NON_ZERO_LENGTH | ZERO_LENGTH )* }x;
+
+is made equivalent to
+
+ m{ (?: NON_ZERO_LENGTH )*
+ |
+ (?: ZERO_LENGTH )?
+ }x;
+
+The higher level-loops preserve an additional state between iterations:
+whether the last match was zero-length. To break the loop, the following
+match after a zero-length match is prohibited to have a length of zero.
+This prohibition interacts with backtracking (see L<"Backtracking">),
+and so the I<second best> match is chosen if the I<best> match is of
+zero length.
+
+Say,
+
+ $_ = 'bar';
+ s/\w??/<$&>/g;
+
+results in C<"<><b><><a><><r><>">. At each position of the string the best
+match given by non-greedy C<??> is the zero-length match, and the I<second
+best> match is what is matched by C<\w>. Thus zero-length matches
+alternate with one-character-long matches.
+
+Similarly, for repeated C<m/()/g> the second-best match is the match at the
+position one notch further in the string.
+
+The additional state of being I<matched with zero-length> is associated to
+the matched string, and is reset by each assignment to pos().
+
+=head2 Creating custom RE engines
+
+Overloaded constants (see L<overload>) provide a simple way to extend
+the functionality of the RE engine.
+
+Suppose that we want to enable a new RE escape-sequence C<\Y|> which
+matches at boundary between white-space characters and non-whitespace
+characters. Note that C<(?=\S)(?<!\S)|(?!\S)(?<=\S)> matches exactly
+at these positions, so we want to have each C<\Y|> in the place of the
+more complicated version. We can create a module C<customre> to do
+this:
+
+ package customre;
+ use overload;
+
+ sub import {
+ shift;
+ die "No argument to customre::import allowed" if @_;
+ overload::constant 'qr' => \&convert;
+ }
+
+ sub invalid { die "/$_[0]/: invalid escape '\\$_[1]'"}
+
+ my %rules = ( '\\' => '\\',
+ 'Y|' => qr/(?=\S)(?<!\S)|(?!\S)(?<=\S)/ );
+ sub convert {
+ my $re = shift;
+ $re =~ s{
+ \\ ( \\ | Y . )
+ }
+ { $rules{$1} or invalid($re,$1) }sgex;
+ return $re;
+ }
+
+Now C<use customre> enables the new escape in constant regular
+expressions, i.e., those without any runtime variable interpolations.
+As documented in L<overload>, this conversion will work only over
+literal parts of regular expressions. For C<\Y|$re\Y|> the variable
+part of this regular expression needs to be converted explicitly
+(but only if the special meaning of C<\Y|> should be enabled inside $re):
+
+ use customre;
+ $re = <>;
+ chomp $re;
+ $re = customre::convert $re;
+ /\Y|$re\Y|/;
+
+=head2 SEE ALSO
+
+L<perlop/"Regexp Quote-Like Operators">.
+
+L<perlop/"Gory details of parsing quoted constructs">.
+
+L<perlfunc/pos>.
+
+L<perllocale>.
+
+I<Mastering Regular Expressions> (see L<perlbook>) by Jeffrey Friedl.
diff --git a/contrib/perl5/pod/perlref.pod b/contrib/perl5/pod/perlref.pod
new file mode 100644
index 000000000000..66b1a7d7c1f8
--- /dev/null
+++ b/contrib/perl5/pod/perlref.pod
@@ -0,0 +1,646 @@
+=head1 NAME
+
+perlref - Perl references and nested data structures
+
+=head1 DESCRIPTION
+
+Before release 5 of Perl it was difficult to represent complex data
+structures, because all references had to be symbolic--and even then
+it was difficult to refer to a variable instead of a symbol table entry.
+Perl now not only makes it easier to use symbolic references to variables,
+but also lets you have "hard" references to any piece of data or code.
+Any scalar may hold a hard reference. Because arrays and hashes contain
+scalars, you can now easily build arrays of arrays, arrays of hashes,
+hashes of arrays, arrays of hashes of functions, and so on.
+
+Hard references are smart--they keep track of reference counts for you,
+automatically freeing the thing referred to when its reference count goes
+to zero. (Note: the reference counts for values in self-referential or
+cyclic data structures may not go to zero without a little help; see
+L<perlobj/"Two-Phased Garbage Collection"> for a detailed explanation.)
+If that thing happens to be an object, the object is destructed. See
+L<perlobj> for more about objects. (In a sense, everything in Perl is an
+object, but we usually reserve the word for references to objects that
+have been officially "blessed" into a class package.)
+
+Symbolic references are names of variables or other objects, just as a
+symbolic link in a Unix filesystem contains merely the name of a file.
+The C<*glob> notation is a kind of symbolic reference. (Symbolic
+references are sometimes called "soft references", but please don't call
+them that; references are confusing enough without useless synonyms.)
+
+In contrast, hard references are more like hard links in a Unix file
+system: They are used to access an underlying object without concern for
+what its (other) name is. When the word "reference" is used without an
+adjective, as in the following paragraph, it is usually talking about a
+hard reference.
+
+References are easy to use in Perl. There is just one overriding
+principle: Perl does no implicit referencing or dereferencing. When a
+scalar is holding a reference, it always behaves as a simple scalar. It
+doesn't magically start being an array or hash or subroutine; you have to
+tell it explicitly to do so, by dereferencing it.
+
+=head2 Making References
+
+References can be created in several ways.
+
+=over 4
+
+=item 1.
+
+By using the backslash operator on a variable, subroutine, or value.
+(This works much like the & (address-of) operator in C.) Note
+that this typically creates I<ANOTHER> reference to a variable, because
+there's already a reference to the variable in the symbol table. But
+the symbol table reference might go away, and you'll still have the
+reference that the backslash returned. Here are some examples:
+
+ $scalarref = \$foo;
+ $arrayref = \@ARGV;
+ $hashref = \%ENV;
+ $coderef = \&handler;
+ $globref = \*foo;
+
+It isn't possible to create a true reference to an IO handle (filehandle
+or dirhandle) using the backslash operator. The most you can get is a
+reference to a typeglob, which is actually a complete symbol table entry.
+But see the explanation of the C<*foo{THING}> syntax below. However,
+you can still use type globs and globrefs as though they were IO handles.
+
+=item 2.
+
+A reference to an anonymous array can be created using square
+brackets:
+
+ $arrayref = [1, 2, ['a', 'b', 'c']];
+
+Here we've created a reference to an anonymous array of three elements
+whose final element is itself a reference to another anonymous array of three
+elements. (The multidimensional syntax described later can be used to
+access this. For example, after the above, C<$arrayref-E<gt>[2][1]> would have
+the value "b".)
+
+Note that taking a reference to an enumerated list is not the same
+as using square brackets--instead it's the same as creating
+a list of references!
+
+ @list = (\$a, \@b, \%c);
+ @list = \($a, @b, %c); # same thing!
+
+As a special case, C<\(@foo)> returns a list of references to the contents
+of C<@foo>, not a reference to C<@foo> itself. Likewise for C<%foo>.
+
+=item 3.
+
+A reference to an anonymous hash can be created using curly
+brackets:
+
+ $hashref = {
+ 'Adam' => 'Eve',
+ 'Clyde' => 'Bonnie',
+ };
+
+Anonymous hash and array composers like these can be intermixed freely to
+produce as complicated a structure as you want. The multidimensional
+syntax described below works for these too. The values above are
+literals, but variables and expressions would work just as well, because
+assignment operators in Perl (even within local() or my()) are executable
+statements, not compile-time declarations.
+
+Because curly brackets (braces) are used for several other things
+including BLOCKs, you may occasionally have to disambiguate braces at the
+beginning of a statement by putting a C<+> or a C<return> in front so
+that Perl realizes the opening brace isn't starting a BLOCK. The economy and
+mnemonic value of using curlies is deemed worth this occasional extra
+hassle.
+
+For example, if you wanted a function to make a new hash and return a
+reference to it, you have these options:
+
+ sub hashem { { @_ } } # silently wrong
+ sub hashem { +{ @_ } } # ok
+ sub hashem { return { @_ } } # ok
+
+On the other hand, if you want the other meaning, you can do this:
+
+ sub showem { { @_ } } # ambiguous (currently ok, but may change)
+ sub showem { {; @_ } } # ok
+ sub showem { { return @_ } } # ok
+
+Note how the leading C<+{> and C<{;> always serve to disambiguate
+the expression to mean either the HASH reference, or the BLOCK.
+
+=item 4.
+
+A reference to an anonymous subroutine can be created by using
+C<sub> without a subname:
+
+ $coderef = sub { print "Boink!\n" };
+
+Note the presence of the semicolon. Except for the fact that the code
+inside isn't executed immediately, a C<sub {}> is not so much a
+declaration as it is an operator, like C<do{}> or C<eval{}>. (However, no
+matter how many times you execute that particular line (unless you're in an
+C<eval("...")>), C<$coderef> will still have a reference to the I<SAME>
+anonymous subroutine.)
+
+Anonymous subroutines act as closures with respect to my() variables,
+that is, variables visible lexically within the current scope. Closure
+is a notion out of the Lisp world that says if you define an anonymous
+function in a particular lexical context, it pretends to run in that
+context even when it's called outside of the context.
+
+In human terms, it's a funny way of passing arguments to a subroutine when
+you define it as well as when you call it. It's useful for setting up
+little bits of code to run later, such as callbacks. You can even
+do object-oriented stuff with it, though Perl already provides a different
+mechanism to do that--see L<perlobj>.
+
+You can also think of closure as a way to write a subroutine template without
+using eval. (In fact, in version 5.000, eval was the I<only> way to get
+closures. You may wish to use "require 5.001" if you use closures.)
+
+Here's a small example of how closures works:
+
+ sub newprint {
+ my $x = shift;
+ return sub { my $y = shift; print "$x, $y!\n"; };
+ }
+ $h = newprint("Howdy");
+ $g = newprint("Greetings");
+
+ # Time passes...
+
+ &$h("world");
+ &$g("earthlings");
+
+This prints
+
+ Howdy, world!
+ Greetings, earthlings!
+
+Note particularly that $x continues to refer to the value passed into
+newprint() I<despite> the fact that the "my $x" has seemingly gone out of
+scope by the time the anonymous subroutine runs. That's what closure
+is all about.
+
+This applies only to lexical variables, by the way. Dynamic variables
+continue to work as they have always worked. Closure is not something
+that most Perl programmers need trouble themselves about to begin with.
+
+=item 5.
+
+References are often returned by special subroutines called constructors.
+Perl objects are just references to a special kind of object that happens to know
+which package it's associated with. Constructors are just special
+subroutines that know how to create that association. They do so by
+starting with an ordinary reference, and it remains an ordinary reference
+even while it's also being an object. Constructors are often
+named new() and called indirectly:
+
+ $objref = new Doggie (Tail => 'short', Ears => 'long');
+
+But don't have to be:
+
+ $objref = Doggie->new(Tail => 'short', Ears => 'long');
+
+ use Term::Cap;
+ $terminal = Term::Cap->Tgetent( { OSPEED => 9600 });
+
+ use Tk;
+ $main = MainWindow->new();
+ $menubar = $main->Frame(-relief => "raised",
+ -borderwidth => 2)
+
+=item 6.
+
+References of the appropriate type can spring into existence if you
+dereference them in a context that assumes they exist. Because we haven't
+talked about dereferencing yet, we can't show you any examples yet.
+
+=item 7.
+
+A reference can be created by using a special syntax, lovingly known as
+the *foo{THING} syntax. *foo{THING} returns a reference to the THING
+slot in *foo (which is the symbol table entry which holds everything
+known as foo).
+
+ $scalarref = *foo{SCALAR};
+ $arrayref = *ARGV{ARRAY};
+ $hashref = *ENV{HASH};
+ $coderef = *handler{CODE};
+ $ioref = *STDIN{IO};
+ $globref = *foo{GLOB};
+
+All of these are self-explanatory except for *foo{IO}. It returns the
+IO handle, used for file handles (L<perlfunc/open>), sockets
+(L<perlfunc/socket> and L<perlfunc/socketpair>), and directory handles
+(L<perlfunc/opendir>). For compatibility with previous versions of
+Perl, *foo{FILEHANDLE} is a synonym for *foo{IO}.
+
+*foo{THING} returns undef if that particular THING hasn't been used yet,
+except in the case of scalars. *foo{SCALAR} returns a reference to an
+anonymous scalar if $foo hasn't been used yet. This might change in a
+future release.
+
+*foo{IO} is an alternative to the \*HANDLE mechanism given in
+L<perldata/"Typeglobs and Filehandles"> for passing filehandles
+into or out of subroutines, or storing into larger data structures.
+Its disadvantage is that it won't create a new filehandle for you.
+Its advantage is that you have no risk of clobbering more than you want
+to with a typeglob assignment, although if you assign to a scalar instead
+of a typeglob, you're ok.
+
+ splutter(*STDOUT);
+ splutter(*STDOUT{IO});
+
+ sub splutter {
+ my $fh = shift;
+ print $fh "her um well a hmmm\n";
+ }
+
+ $rec = get_rec(*STDIN);
+ $rec = get_rec(*STDIN{IO});
+
+ sub get_rec {
+ my $fh = shift;
+ return scalar <$fh>;
+ }
+
+=back
+
+=head2 Using References
+
+That's it for creating references. By now you're probably dying to
+know how to use references to get back to your long-lost data. There
+are several basic methods.
+
+=over 4
+
+=item 1.
+
+Anywhere you'd put an identifier (or chain of identifiers) as part
+of a variable or subroutine name, you can replace the identifier with
+a simple scalar variable containing a reference of the correct type:
+
+ $bar = $$scalarref;
+ push(@$arrayref, $filename);
+ $$arrayref[0] = "January";
+ $$hashref{"KEY"} = "VALUE";
+ &$coderef(1,2,3);
+ print $globref "output\n";
+
+It's important to understand that we are specifically I<NOT> dereferencing
+C<$arrayref[0]> or C<$hashref{"KEY"}> there. The dereference of the
+scalar variable happens I<BEFORE> it does any key lookups. Anything more
+complicated than a simple scalar variable must use methods 2 or 3 below.
+However, a "simple scalar" includes an identifier that itself uses method
+1 recursively. Therefore, the following prints "howdy".
+
+ $refrefref = \\\"howdy";
+ print $$$$refrefref;
+
+=item 2.
+
+Anywhere you'd put an identifier (or chain of identifiers) as part of a
+variable or subroutine name, you can replace the identifier with a
+BLOCK returning a reference of the correct type. In other words, the
+previous examples could be written like this:
+
+ $bar = ${$scalarref};
+ push(@{$arrayref}, $filename);
+ ${$arrayref}[0] = "January";
+ ${$hashref}{"KEY"} = "VALUE";
+ &{$coderef}(1,2,3);
+ $globref->print("output\n"); # iff IO::Handle is loaded
+
+Admittedly, it's a little silly to use the curlies in this case, but
+the BLOCK can contain any arbitrary expression, in particular,
+subscripted expressions:
+
+ &{ $dispatch{$index} }(1,2,3); # call correct routine
+
+Because of being able to omit the curlies for the simple case of C<$$x>,
+people often make the mistake of viewing the dereferencing symbols as
+proper operators, and wonder about their precedence. If they were,
+though, you could use parentheses instead of braces. That's not the case.
+Consider the difference below; case 0 is a short-hand version of case 1,
+I<NOT> case 2:
+
+ $$hashref{"KEY"} = "VALUE"; # CASE 0
+ ${$hashref}{"KEY"} = "VALUE"; # CASE 1
+ ${$hashref{"KEY"}} = "VALUE"; # CASE 2
+ ${$hashref->{"KEY"}} = "VALUE"; # CASE 3
+
+Case 2 is also deceptive in that you're accessing a variable
+called %hashref, not dereferencing through $hashref to the hash
+it's presumably referencing. That would be case 3.
+
+=item 3.
+
+Subroutine calls and lookups of individual array elements arise often
+enough that it gets cumbersome to use method 2. As a form of
+syntactic sugar, the examples for method 2 may be written:
+
+ $arrayref->[0] = "January"; # Array element
+ $hashref->{"KEY"} = "VALUE"; # Hash element
+ $coderef->(1,2,3); # Subroutine call
+
+The left side of the arrow can be any expression returning a reference,
+including a previous dereference. Note that C<$array[$x]> is I<NOT> the
+same thing as C<$array-E<gt>[$x]> here:
+
+ $array[$x]->{"foo"}->[0] = "January";
+
+This is one of the cases we mentioned earlier in which references could
+spring into existence when in an lvalue context. Before this
+statement, C<$array[$x]> may have been undefined. If so, it's
+automatically defined with a hash reference so that we can look up
+C<{"foo"}> in it. Likewise C<$array[$x]-E<gt>{"foo"}> will automatically get
+defined with an array reference so that we can look up C<[0]> in it.
+This process is called I<autovivification>.
+
+One more thing here. The arrow is optional I<BETWEEN> brackets
+subscripts, so you can shrink the above down to
+
+ $array[$x]{"foo"}[0] = "January";
+
+Which, in the degenerate case of using only ordinary arrays, gives you
+multidimensional arrays just like C's:
+
+ $score[$x][$y][$z] += 42;
+
+Well, okay, not entirely like C's arrays, actually. C doesn't know how
+to grow its arrays on demand. Perl does.
+
+=item 4.
+
+If a reference happens to be a reference to an object, then there are
+probably methods to access the things referred to, and you should probably
+stick to those methods unless you're in the class package that defines the
+object's methods. In other words, be nice, and don't violate the object's
+encapsulation without a very good reason. Perl does not enforce
+encapsulation. We are not totalitarians here. We do expect some basic
+civility though.
+
+=back
+
+The ref() operator may be used to determine what type of thing the
+reference is pointing to. See L<perlfunc>.
+
+The bless() operator may be used to associate the object a reference
+points to with a package functioning as an object class. See L<perlobj>.
+
+A typeglob may be dereferenced the same way a reference can, because
+the dereference syntax always indicates the kind of reference desired.
+So C<${*foo}> and C<${\$foo}> both indicate the same scalar variable.
+
+Here's a trick for interpolating a subroutine call into a string:
+
+ print "My sub returned @{[mysub(1,2,3)]} that time.\n";
+
+The way it works is that when the C<@{...}> is seen in the double-quoted
+string, it's evaluated as a block. The block creates a reference to an
+anonymous array containing the results of the call to C<mysub(1,2,3)>. So
+the whole block returns a reference to an array, which is then
+dereferenced by C<@{...}> and stuck into the double-quoted string. This
+chicanery is also useful for arbitrary expressions:
+
+ print "That yields @{[$n + 5]} widgets\n";
+
+=head2 Symbolic references
+
+We said that references spring into existence as necessary if they are
+undefined, but we didn't say what happens if a value used as a
+reference is already defined, but I<ISN'T> a hard reference. If you
+use it as a reference in this case, it'll be treated as a symbolic
+reference. That is, the value of the scalar is taken to be the I<NAME>
+of a variable, rather than a direct link to a (possibly) anonymous
+value.
+
+People frequently expect it to work like this. So it does.
+
+ $name = "foo";
+ $$name = 1; # Sets $foo
+ ${$name} = 2; # Sets $foo
+ ${$name x 2} = 3; # Sets $foofoo
+ $name->[0] = 4; # Sets $foo[0]
+ @$name = (); # Clears @foo
+ &$name(); # Calls &foo() (as in Perl 4)
+ $pack = "THAT";
+ ${"${pack}::$name"} = 5; # Sets $THAT::foo without eval
+
+This is very powerful, and slightly dangerous, in that it's possible
+to intend (with the utmost sincerity) to use a hard reference, and
+accidentally use a symbolic reference instead. To protect against
+that, you can say
+
+ use strict 'refs';
+
+and then only hard references will be allowed for the rest of the enclosing
+block. An inner block may countermand that with
+
+ no strict 'refs';
+
+Only package variables (globals, even if localized) are visible to
+symbolic references. Lexical variables (declared with my()) aren't in
+a symbol table, and thus are invisible to this mechanism. For example:
+
+ local $value = 10;
+ $ref = \$value;
+ {
+ my $value = 20;
+ print $$ref;
+ }
+
+This will still print 10, not 20. Remember that local() affects package
+variables, which are all "global" to the package.
+
+=head2 Not-so-symbolic references
+
+A new feature contributing to readability in perl version 5.001 is that the
+brackets around a symbolic reference behave more like quotes, just as they
+always have within a string. That is,
+
+ $push = "pop on ";
+ print "${push}over";
+
+has always meant to print "pop on over", despite the fact that push is
+a reserved word. This has been generalized to work the same outside
+of quotes, so that
+
+ print ${push} . "over";
+
+and even
+
+ print ${ push } . "over";
+
+will have the same effect. (This would have been a syntax error in
+Perl 5.000, though Perl 4 allowed it in the spaceless form.) Note that this
+construct is I<not> considered to be a symbolic reference when you're
+using strict refs:
+
+ use strict 'refs';
+ ${ bareword }; # Okay, means $bareword.
+ ${ "bareword" }; # Error, symbolic reference.
+
+Similarly, because of all the subscripting that is done using single
+words, we've applied the same rule to any bareword that is used for
+subscripting a hash. So now, instead of writing
+
+ $array{ "aaa" }{ "bbb" }{ "ccc" }
+
+you can write just
+
+ $array{ aaa }{ bbb }{ ccc }
+
+and not worry about whether the subscripts are reserved words. In the
+rare event that you do wish to do something like
+
+ $array{ shift }
+
+you can force interpretation as a reserved word by adding anything that
+makes it more than a bareword:
+
+ $array{ shift() }
+ $array{ +shift }
+ $array{ shift @_ }
+
+The B<-w> switch will warn you if it interprets a reserved word as a string.
+But it will no longer warn you about using lowercase words, because the
+string is effectively quoted.
+
+=head2 Pseudo-hashes: Using an array as a hash
+
+WARNING: This section describes an experimental feature. Details may
+change without notice in future versions.
+
+Beginning with release 5.005 of Perl you can use an array reference
+in some contexts that would normally require a hash reference. This
+allows you to access array elements using symbolic names, as if they
+were fields in a structure.
+
+For this to work, the array must contain extra information. The first
+element of the array has to be a hash reference that maps field names
+to array indices. Here is an example:
+
+ $struct = [{foo => 1, bar => 2}, "FOO", "BAR"];
+
+ $struct->{foo}; # same as $struct->[1], i.e. "FOO"
+ $struct->{bar}; # same as $struct->[2], i.e. "BAR"
+
+ keys %$struct; # will return ("foo", "bar") in some order
+ values %$struct; # will return ("FOO", "BAR") in same some order
+
+ while (my($k,$v) = each %$struct) {
+ print "$k => $v\n";
+ }
+
+Perl will raise an exception if you try to delete keys from a pseudo-hash
+or try to access nonexistent fields. For better performance, Perl can also
+do the translation from field names to array indices at compile time for
+typed object references. See L<fields>.
+
+
+=head2 Function Templates
+
+As explained above, a closure is an anonymous function with access to the
+lexical variables visible when that function was compiled. It retains
+access to those variables even though it doesn't get run until later,
+such as in a signal handler or a Tk callback.
+
+Using a closure as a function template allows us to generate many functions
+that act similarly. Suppopose you wanted functions named after the colors
+that generated HTML font changes for the various colors:
+
+ print "Be ", red("careful"), "with that ", green("light");
+
+The red() and green() functions would be very similar. To create these,
+we'll assign a closure to a typeglob of the name of the function we're
+trying to build.
+
+ @colors = qw(red blue green yellow orange purple violet);
+ for my $name (@colors) {
+ no strict 'refs'; # allow symbol table manipulation
+ *$name = *{uc $name} = sub { "<FONT COLOR='$name'>@_</FONT>" };
+ }
+
+Now all those different functions appear to exist independently. You can
+call red(), RED(), blue(), BLUE(), green(), etc. This technique saves on
+both compile time and memory use, and is less error-prone as well, since
+syntax checks happen at compile time. It's critical that any variables in
+the anonymous subroutine be lexicals in order to create a proper closure.
+That's the reasons for the C<my> on the loop iteration variable.
+
+This is one of the only places where giving a prototype to a closure makes
+much sense. If you wanted to impose scalar context on the arguments of
+these functions (probably not a wise idea for this particular example),
+you could have written it this way instead:
+
+ *$name = sub ($) { "<FONT COLOR='$name'>$_[0]</FONT>" };
+
+However, since prototype checking happens at compile time, the assignment
+above happens too late to be of much use. You could address this by
+putting the whole loop of assignments within a BEGIN block, forcing it
+to occur during compilation.
+
+Access to lexicals that change over type--like those in the C<for> loop
+above--only works with closures, not general subroutines. In the general
+case, then, named subroutines do not nest properly, although anonymous
+ones do. If you are accustomed to using nested subroutines in other
+programming languages with their own private variables, you'll have to
+work at it a bit in Perl. The intuitive coding of this kind of thing
+incurs mysterious warnings about ``will not stay shared''. For example,
+this won't work:
+
+ sub outer {
+ my $x = $_[0] + 35;
+ sub inner { return $x * 19 } # WRONG
+ return $x + inner();
+ }
+
+A work-around is the following:
+
+ sub outer {
+ my $x = $_[0] + 35;
+ local *inner = sub { return $x * 19 };
+ return $x + inner();
+ }
+
+Now inner() can only be called from within outer(), because of the
+temporary assignments of the closure (anonymous subroutine). But when
+it does, it has normal access to the lexical variable $x from the scope
+of outer().
+
+This has the interesting effect of creating a function local to another
+function, something not normally supported in Perl.
+
+=head1 WARNING
+
+You may not (usefully) use a reference as the key to a hash. It will be
+converted into a string:
+
+ $x{ \$a } = $a;
+
+If you try to dereference the key, it won't do a hard dereference, and
+you won't accomplish what you're attempting. You might want to do something
+more like
+
+ $r = \@a;
+ $x{ $r } = $r;
+
+And then at least you can use the values(), which will be
+real refs, instead of the keys(), which won't.
+
+The standard Tie::RefHash module provides a convenient workaround to this.
+
+=head1 SEE ALSO
+
+Besides the obvious documents, source code can be instructive.
+Some rather pathological examples of the use of references can be found
+in the F<t/op/ref.t> regression test in the Perl source directory.
+
+See also L<perldsc> and L<perllol> for how to use references to create
+complex data structures, and L<perltoot>, L<perlobj>, and L<perlbot>
+for how to use them to create objects.
diff --git a/contrib/perl5/pod/perlrun.pod b/contrib/perl5/pod/perlrun.pod
new file mode 100644
index 000000000000..a0c85b917b30
--- /dev/null
+++ b/contrib/perl5/pod/perlrun.pod
@@ -0,0 +1,731 @@
+=head1 NAME
+
+perlrun - how to execute the Perl interpreter
+
+=head1 SYNOPSIS
+
+B<perl> S<[ B<-sTuU> ]>
+ S<[ B<-hv> ] [ B<-V>[:I<configvar>] ]>
+ S<[ B<-cw> ] [ B<-d>[:I<debugger>] ] [ B<-D>[I<number/list>] ]>
+ S<[ B<-pna> ] [ B<-F>I<pattern> ] [ B<-l>[I<octal>] ] [ B<-0>[I<octal>] ]>
+ S<[ B<-I>I<dir> ] [ B<-m>[B<->]I<module> ] [ B<-M>[B<->]I<'module...'> ]>
+ S<[ B<-P> ]>
+ S<[ B<-S> ]>
+ S<[ B<-x>[I<dir>] ]>
+ S<[ B<-i>[I<extension>] ]>
+ S<[ B<-e> I<'command'> ] [ B<--> ] [ I<programfile> ] [ I<argument> ]...>
+
+=head1 DESCRIPTION
+
+Upon startup, Perl looks for your script in one of the following
+places:
+
+=over 4
+
+=item 1.
+
+Specified line by line via B<-e> switches on the command line.
+
+=item 2.
+
+Contained in the file specified by the first filename on the command line.
+(Note that systems supporting the #! notation invoke interpreters this
+way. See L<Location of Perl>.)
+
+=item 3.
+
+Passed in implicitly via standard input. This works only if there are
+no filename arguments--to pass arguments to a STDIN script you
+must explicitly specify a "-" for the script name.
+
+=back
+
+With methods 2 and 3, Perl starts parsing the input file from the
+beginning, unless you've specified a B<-x> switch, in which case it
+scans for the first line starting with #! and containing the word
+"perl", and starts there instead. This is useful for running a script
+embedded in a larger message. (In this case you would indicate the end
+of the script using the C<__END__> token.)
+
+The #! line is always examined for switches as the line is being
+parsed. Thus, if you're on a machine that allows only one argument
+with the #! line, or worse, doesn't even recognize the #! line, you
+still can get consistent switch behavior regardless of how Perl was
+invoked, even if B<-x> was used to find the beginning of the script.
+
+Because many operating systems silently chop off kernel interpretation of
+the #! line after 32 characters, some switches may be passed in on the
+command line, and some may not; you could even get a "-" without its
+letter, if you're not careful. You probably want to make sure that all
+your switches fall either before or after that 32 character boundary.
+Most switches don't actually care if they're processed redundantly, but
+getting a - instead of a complete switch could cause Perl to try to
+execute standard input instead of your script. And a partial B<-I> switch
+could also cause odd results.
+
+Some switches do care if they are processed twice, for instance combinations
+of B<-l> and B<-0>. Either put all the switches after the 32 character
+boundary (if applicable), or replace the use of B<-0>I<digits> by
+C<BEGIN{ $/ = "\0digits"; }>.
+
+Parsing of the #! switches starts wherever "perl" is mentioned in the line.
+The sequences "-*" and "- " are specifically ignored so that you could,
+if you were so inclined, say
+
+ #!/bin/sh -- # -*- perl -*- -p
+ eval 'exec /usr/bin/perl -wS $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+to let Perl see the B<-p> switch.
+
+If the #! line does not contain the word "perl", the program named after
+the #! is executed instead of the Perl interpreter. This is slightly
+bizarre, but it helps people on machines that don't do #!, because they
+can tell a program that their SHELL is /usr/bin/perl, and Perl will then
+dispatch the program to the correct interpreter for them.
+
+After locating your script, Perl compiles the entire script to an
+internal form. If there are any compilation errors, execution of the
+script is not attempted. (This is unlike the typical shell script,
+which might run part-way through before finding a syntax error.)
+
+If the script is syntactically correct, it is executed. If the script
+runs off the end without hitting an exit() or die() operator, an implicit
+C<exit(0)> is provided to indicate successful completion.
+
+=head2 #! and quoting on non-Unix systems
+
+Unix's #! technique can be simulated on other systems:
+
+=over 4
+
+=item OS/2
+
+Put
+
+ extproc perl -S -your_switches
+
+as the first line in C<*.cmd> file (C<-S> due to a bug in cmd.exe's
+`extproc' handling).
+
+=item MS-DOS
+
+Create a batch file to run your script, and codify it in
+C<ALTERNATIVE_SHEBANG> (see the F<dosish.h> file in the source
+distribution for more information).
+
+=item Win95/NT
+
+The Win95/NT installation, when using the Activeware port of Perl,
+will modify the Registry to associate the F<.pl> extension with the perl
+interpreter. If you install another port of Perl, including the one
+in the Win32 directory of the Perl distribution, then you'll have to
+modify the Registry yourself. Note that this means you can no
+longer tell the difference between an executable Perl program
+and a Perl library file.
+
+=item Macintosh
+
+Macintosh perl scripts will have the appropriate Creator and
+Type, so that double-clicking them will invoke the perl application.
+
+=back
+
+Command-interpreters on non-Unix systems have rather different ideas
+on quoting than Unix shells. You'll need to learn the special
+characters in your command-interpreter (C<*>, C<\> and C<"> are
+common) and how to protect whitespace and these characters to run
+one-liners (see C<-e> below).
+
+On some systems, you may have to change single-quotes to double ones,
+which you must I<NOT> do on Unix or Plan9 systems. You might also
+have to change a single % to a %%.
+
+For example:
+
+ # Unix
+ perl -e 'print "Hello world\n"'
+
+ # MS-DOS, etc.
+ perl -e "print \"Hello world\n\""
+
+ # Macintosh
+ print "Hello world\n"
+ (then Run "Myscript" or Shift-Command-R)
+
+ # VMS
+ perl -e "print ""Hello world\n"""
+
+The problem is that none of this is reliable: it depends on the command
+and it is entirely possible neither works. If 4DOS was the command shell, this would
+probably work better:
+
+ perl -e "print <Ctrl-x>"Hello world\n<Ctrl-x>""
+
+CMD.EXE in Windows NT slipped a lot of standard Unix functionality in
+when nobody was looking, but just try to find documentation for its
+quoting rules.
+
+Under the Macintosh, it depends which environment you are using. The MacPerl
+shell, or MPW, is much like Unix shells in its support for several
+quoting variants, except that it makes free use of the Macintosh's non-ASCII
+characters as control characters.
+
+There is no general solution to all of this. It's just a mess.
+
+=head2 Location of Perl
+
+It may seem obvious to say, but Perl is useful only when users can
+easily find it. When possible, it's good for both B</usr/bin/perl> and
+B</usr/local/bin/perl> to be symlinks to the actual binary. If that
+can't be done, system administrators are strongly encouraged to put
+(symlinks to) perl and its accompanying utilities, such as perldoc, into
+a directory typically found along a user's PATH, or in another obvious
+and convenient place.
+
+In this documentation, C<#!/usr/bin/perl> on the first line of the script
+will stand in for whatever method works on your system.
+
+=head2 Switches
+
+A single-character switch may be combined with the following switch, if
+any.
+
+ #!/usr/bin/perl -spi.bak # same as -s -p -i.bak
+
+Switches include:
+
+=over 5
+
+=item B<-0>[I<digits>]
+
+specifies the input record separator (C<$/>) as an octal number. If there are
+no digits, the null character is the separator. Other switches may
+precede or follow the digits. For example, if you have a version of
+B<find> which can print filenames terminated by the null character, you
+can say this:
+
+ find . -name '*.bak' -print0 | perl -n0e unlink
+
+The special value 00 will cause Perl to slurp files in paragraph mode.
+The value 0777 will cause Perl to slurp files whole because there is no
+legal character with that value.
+
+=item B<-a>
+
+turns on autosplit mode when used with a B<-n> or B<-p>. An implicit
+split command to the @F array is done as the first thing inside the
+implicit while loop produced by the B<-n> or B<-p>.
+
+ perl -ane 'print pop(@F), "\n";'
+
+is equivalent to
+
+ while (<>) {
+ @F = split(' ');
+ print pop(@F), "\n";
+ }
+
+An alternate delimiter may be specified using B<-F>.
+
+=item B<-c>
+
+causes Perl to check the syntax of the script and then exit without
+executing it. Actually, it I<will> execute C<BEGIN>, C<END>, and C<use> blocks,
+because these are considered as occurring outside the execution of
+your program.
+
+=item B<-d>
+
+runs the script under the Perl debugger. See L<perldebug>.
+
+=item B<-d:>I<foo>
+
+runs the script under the control of a debugging or tracing module
+installed as Devel::foo. E.g., B<-d:DProf> executes the script using the
+Devel::DProf profiler. See L<perldebug>.
+
+=item B<-D>I<letters>
+
+=item B<-D>I<number>
+
+sets debugging flags. To watch how it executes your script, use
+B<-Dtls>. (This works only if debugging is compiled into your
+Perl.) Another nice value is B<-Dx>, which lists your compiled
+syntax tree. And B<-Dr> displays compiled regular expressions. As an
+alternative, specify a number instead of list of letters (e.g., B<-D14> is
+equivalent to B<-Dtls>):
+
+ 1 p Tokenizing and parsing
+ 2 s Stack snapshots
+ 4 l Context (loop) stack processing
+ 8 t Trace execution
+ 16 o Method and overloading resolution
+ 32 c String/numeric conversions
+ 64 P Print preprocessor command for -P
+ 128 m Memory allocation
+ 256 f Format processing
+ 512 r Regular expression parsing and execution
+ 1024 x Syntax tree dump
+ 2048 u Tainting checks
+ 4096 L Memory leaks (needs C<-DLEAKTEST> when compiling Perl)
+ 8192 H Hash dump -- usurps values()
+ 16384 X Scratchpad allocation
+ 32768 D Cleaning up
+ 65536 S Thread synchronization
+
+All these flags require C<-DDEBUGGING> when you compile the Perl
+executable. This flag is automatically set if you include C<-g>
+option when C<Configure> asks you about optimizer/debugger flags.
+
+=item B<-e> I<commandline>
+
+may be used to enter one line of script.
+If B<-e> is given, Perl
+will not look for a script filename in the argument list.
+Multiple B<-e> commands may
+be given to build up a multi-line script.
+Make sure to use semicolons where you would in a normal program.
+
+=item B<-F>I<pattern>
+
+specifies the pattern to split on if B<-a> is also in effect. The
+pattern may be surrounded by C<//>, C<"">, or C<''>, otherwise it will be
+put in single quotes.
+
+=item B<-h>
+
+prints a summary of the options.
+
+=item B<-i>[I<extension>]
+
+specifies that files processed by the C<E<lt>E<gt>> construct are to be
+edited in-place. It does this by renaming the input file, opening the
+output file by the original name, and selecting that output file as the
+default for print() statements. The extension, if supplied, is used to
+modify the name of the old file to make a backup copy, following these
+rules:
+
+If no extension is supplied, no backup is made and the current file is
+overwritten.
+
+If the extension doesn't contain a C<*> then it is appended to the end
+of the current filename as a suffix.
+
+If the extension does contain one or more C<*> characters, then each C<*>
+is replaced with the current filename. In perl terms you could think of
+this as:
+
+ ($backup = $extension) =~ s/\*/$file_name/g;
+
+This allows you to add a prefix to the backup file, instead of (or in
+addition to) a suffix:
+
+ $ perl -pi'bak_*' -e 's/bar/baz/' fileA # backup to 'bak_fileA'
+
+Or even to place backup copies of the original files into another
+directory (provided the directory already exists):
+
+ $ perl -pi'old/*.bak' -e 's/bar/baz/' fileA # backup to 'old/fileA.bak'
+
+These sets of one-liners are equivalent:
+
+ $ perl -pi -e 's/bar/baz/' fileA # overwrite current file
+ $ perl -pi'*' -e 's/bar/baz/' fileA # overwrite current file
+
+ $ perl -pi'.bak' -e 's/bar/baz/' fileA # backup to 'fileA.bak'
+ $ perl -pi'*.bak' -e 's/bar/baz/' fileA # backup to 'fileA.bak'
+
+From the shell, saying
+
+ $ perl -p -i.bak -e "s/foo/bar/; ... "
+
+is the same as using the script:
+
+ #!/usr/bin/perl -pi.bak
+ s/foo/bar/;
+
+which is equivalent to
+
+ #!/usr/bin/perl
+ $extension = '.bak';
+ while (<>) {
+ if ($ARGV ne $oldargv) {
+ if ($extension !~ /\*/) {
+ $backup = $ARGV . $extension;
+ }
+ else {
+ ($backup = $extension) =~ s/\*/$ARGV/g;
+ }
+ rename($ARGV, $backup);
+ open(ARGVOUT, ">$ARGV");
+ select(ARGVOUT);
+ $oldargv = $ARGV;
+ }
+ s/foo/bar/;
+ }
+ continue {
+ print; # this prints to original filename
+ }
+ select(STDOUT);
+
+except that the B<-i> form doesn't need to compare $ARGV to $oldargv to
+know when the filename has changed. It does, however, use ARGVOUT for
+the selected filehandle. Note that STDOUT is restored as the default
+output filehandle after the loop.
+
+As shown above, Perl creates the backup file whether or not any output
+is actually changed. So this is just a fancy way to copy files:
+
+ $ perl -p -i'/some/file/path/*' -e 1 file1 file2 file3...
+ or
+ $ perl -p -i'.bak' -e 1 file1 file2 file3...
+
+You can use C<eof> without parentheses to locate the end of each input
+file, in case you want to append to each file, or reset line numbering
+(see example in L<perlfunc/eof>).
+
+If, for a given file, Perl is unable to create the backup file as
+specified in the extension then it will skip that file and continue on
+with the next one (if it exists).
+
+For a discussion of issues surrounding file permissions and C<-i>, see
+L<perlfaq5/Why does Perl let me delete read-only files? Why does -i clobber protected files? Isn't this a bug in Perl?>.
+
+You cannot use B<-i> to create directories or to strip extensions from
+files.
+
+Perl does not expand C<~>, so don't do that.
+
+Finally, note that the B<-i> switch does not impede execution when no
+files are given on the command line. In this case, no backup is made
+(the original file cannot, of course, be determined) and processing
+proceeds from STDIN to STDOUT as might be expected.
+
+=item B<-I>I<directory>
+
+Directories specified by B<-I> are prepended to the search path for
+modules (C<@INC>), and also tells the C preprocessor where to search for
+include files. The C preprocessor is invoked with B<-P>; by default it
+searches /usr/include and /usr/lib/perl.
+
+=item B<-l>[I<octnum>]
+
+enables automatic line-ending processing. It has two effects: first,
+it automatically chomps "C<$/>" (the input record separator) when used
+with B<-n> or B<-p>, and second, it assigns "C<$\>"
+(the output record separator) to have the value of I<octnum> so that
+any print statements will have that separator added back on. If
+I<octnum> is omitted, sets "C<$\>" to the current value of "C<$/>". For
+instance, to trim lines to 80 columns:
+
+ perl -lpe 'substr($_, 80) = ""'
+
+Note that the assignment C<$\ = $/> is done when the switch is processed,
+so the input record separator can be different than the output record
+separator if the B<-l> switch is followed by a B<-0> switch:
+
+ gnufind / -print0 | perl -ln0e 'print "found $_" if -p'
+
+This sets C<$\> to newline and then sets C<$/> to the null character.
+
+=item B<-m>[B<->]I<module>
+
+=item B<-M>[B<->]I<module>
+
+=item B<-M>[B<->]I<'module ...'>
+
+=item B<-[mM]>[B<->]I<module=arg[,arg]...>
+
+C<-m>I<module> executes C<use> I<module> C<();> before executing your
+script.
+
+C<-M>I<module> executes C<use> I<module> C<;> before executing your
+script. You can use quotes to add extra code after the module name,
+e.g., C<-M'module qw(foo bar)'>.
+
+If the first character after the C<-M> or C<-m> is a dash (C<->)
+then the 'use' is replaced with 'no'.
+
+A little builtin syntactic sugar means you can also say
+C<-mmodule=foo,bar> or C<-Mmodule=foo,bar> as a shortcut for
+C<-M'module qw(foo bar)'>. This avoids the need to use quotes when
+importing symbols. The actual code generated by C<-Mmodule=foo,bar> is
+C<use module split(/,/,q{foo,bar})>. Note that the C<=> form
+removes the distinction between C<-m> and C<-M>.
+
+=item B<-n>
+
+causes Perl to assume the following loop around your script, which
+makes it iterate over filename arguments somewhat like B<sed -n> or
+B<awk>:
+
+ while (<>) {
+ ... # your script goes here
+ }
+
+Note that the lines are not printed by default. See B<-p> to have
+lines printed. If a file named by an argument cannot be opened for
+some reason, Perl warns you about it, and moves on to the next file.
+
+Here is an efficient way to delete all files older than a week:
+
+ find . -mtime +7 -print | perl -nle 'unlink;'
+
+This is faster than using the C<-exec> switch of B<find> because you don't
+have to start a process on every filename found.
+
+C<BEGIN> and C<END> blocks may be used to capture control before or after
+the implicit loop, just as in B<awk>.
+
+=item B<-p>
+
+causes Perl to assume the following loop around your script, which
+makes it iterate over filename arguments somewhat like B<sed>:
+
+
+ while (<>) {
+ ... # your script goes here
+ } continue {
+ print or die "-p destination: $!\n";
+ }
+
+If a file named by an argument cannot be opened for some reason, Perl
+warns you about it, and moves on to the next file. Note that the
+lines are printed automatically. An error occuring during printing is
+treated as fatal. To suppress printing use the B<-n> switch. A B<-p>
+overrides a B<-n> switch.
+
+C<BEGIN> and C<END> blocks may be used to capture control before or after
+the implicit loop, just as in awk.
+
+=item B<-P>
+
+causes your script to be run through the C preprocessor before
+compilation by Perl. (Because both comments and cpp directives begin
+with the # character, you should avoid starting comments with any words
+recognized by the C preprocessor such as "if", "else", or "define".)
+
+=item B<-s>
+
+enables some rudimentary switch parsing for switches on the command
+line after the script name but before any filename arguments (or before
+a B<-->). Any switch found there is removed from @ARGV and sets the
+corresponding variable in the Perl script. The following script
+prints "true" if and only if the script is invoked with a B<-xyz> switch.
+
+ #!/usr/bin/perl -s
+ if ($xyz) { print "true\n"; }
+
+=item B<-S>
+
+makes Perl use the PATH environment variable to search for the
+script (unless the name of the script contains directory separators).
+On some platforms, this also makes Perl append suffixes to the
+filename while searching for it. For example, on Win32 platforms,
+the ".bat" and ".cmd" suffixes are appended if a lookup for the
+original name fails, and if the name does not already end in one
+of those suffixes. If your Perl was compiled with DEBUGGING turned
+on, using the -Dp switch to Perl shows how the search progresses.
+
+If the filename supplied contains directory separators (i.e. it is an
+absolute or relative pathname), and if the file is not found,
+platforms that append file extensions will do so and try to look
+for the file with those extensions added, one by one.
+
+On DOS-like platforms, if the script does not contain directory
+separators, it will first be searched for in the current directory
+before being searched for on the PATH. On Unix platforms, the
+script will be searched for strictly on the PATH.
+
+Typically this is used to emulate #! startup on platforms that
+don't support #!. This example works on many platforms that
+have a shell compatible with Bourne shell:
+
+ #!/usr/bin/perl
+ eval 'exec /usr/bin/perl -wS $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+The system ignores the first line and feeds the script to /bin/sh,
+which proceeds to try to execute the Perl script as a shell script.
+The shell executes the second line as a normal shell command, and thus
+starts up the Perl interpreter. On some systems $0 doesn't always
+contain the full pathname, so the B<-S> tells Perl to search for the
+script if necessary. After Perl locates the script, it parses the
+lines and ignores them because the variable $running_under_some_shell
+is never true. If the script will be interpreted by csh, you will need
+to replace C<${1+"$@"}> with C<$*>, even though that doesn't understand
+embedded spaces (and such) in the argument list. To start up sh rather
+than csh, some systems may have to replace the #! line with a line
+containing just a colon, which will be politely ignored by Perl. Other
+systems can't control that, and need a totally devious construct that
+will work under any of csh, sh, or Perl, such as the following:
+
+ eval '(exit $?0)' && eval 'exec /usr/bin/perl -wS $0 ${1+"$@"}'
+ & eval 'exec /usr/bin/perl -wS $0 $argv:q'
+ if $running_under_some_shell;
+
+=item B<-T>
+
+forces "taint" checks to be turned on so you can test them. Ordinarily
+these checks are done only when running setuid or setgid. It's a good
+idea to turn them on explicitly for programs run on another's behalf,
+such as CGI programs. See L<perlsec>. Note that (for security reasons)
+this option must be seen by Perl quite early; usually this means it must
+appear early on the command line or in the #! line (for systems which
+support that).
+
+=item B<-u>
+
+causes Perl to dump core after compiling your script. You can then
+in theory take this core dump and turn it into an executable file by using the
+B<undump> program (not supplied). This speeds startup at the expense of
+some disk space (which you can minimize by stripping the executable).
+(Still, a "hello world" executable comes out to about 200K on my
+machine.) If you want to execute a portion of your script before dumping,
+use the dump() operator instead. Note: availability of B<undump> is
+platform specific and may not be available for a specific port of
+Perl. It has been superseded by the new perl-to-C compiler, which is more
+portable, even though it's still only considered beta.
+
+=item B<-U>
+
+allows Perl to do unsafe operations. Currently the only "unsafe"
+operations are the unlinking of directories while running as superuser,
+and running setuid programs with fatal taint checks turned into
+warnings. Note that the B<-w> switch (or the C<$^W> variable) must
+be used along with this option to actually B<generate> the
+taint-check warnings.
+
+=item B<-v>
+
+prints the version and patchlevel of your Perl executable.
+
+=item B<-V>
+
+prints summary of the major perl configuration values and the current
+value of @INC.
+
+=item B<-V:>I<name>
+
+Prints to STDOUT the value of the named configuration variable.
+
+=item B<-w>
+
+prints warnings about variable names that are mentioned only once, and
+scalar variables that are used before being set. Also warns about
+redefined subroutines, and references to undefined filehandles or
+filehandles opened read-only that you are attempting to write on. Also
+warns you if you use values as a number that doesn't look like numbers,
+using an array as though it were a scalar, if your subroutines recurse
+more than 100 deep, and innumerable other things.
+
+You can disable specific warnings using C<__WARN__> hooks, as described
+in L<perlvar> and L<perlfunc/warn>. See also L<perldiag> and L<perltrap>.
+
+=item B<-x> I<directory>
+
+tells Perl that the script is embedded in a message. Leading
+garbage will be discarded until the first line that starts with #! and
+contains the string "perl". Any meaningful switches on that line will
+be applied. If a directory name is specified, Perl will switch to
+that directory before running the script. The B<-x> switch controls
+only the disposal of leading garbage. The script must be
+terminated with C<__END__> if there is trailing garbage to be ignored (the
+script can process any or all of the trailing garbage via the DATA
+filehandle if desired).
+
+=back
+
+=head1 ENVIRONMENT
+
+=over 12
+
+=item HOME
+
+Used if chdir has no argument.
+
+=item LOGDIR
+
+Used if chdir has no argument and HOME is not set.
+
+=item PATH
+
+Used in executing subprocesses, and in finding the script if B<-S> is
+used.
+
+=item PERL5LIB
+
+A colon-separated list of directories in which to look for Perl library
+files before looking in the standard library and the current
+directory. If PERL5LIB is not defined, PERLLIB is used. When running
+taint checks (because the script was running setuid or setgid, or the
+B<-T> switch was used), neither variable is used. The script should
+instead say
+
+ use lib "/my/directory";
+
+=item PERL5OPT
+
+Command-line options (switches). Switches in this variable are taken
+as if they were on every Perl command line. Only the B<-[DIMUdmw]>
+switches are allowed. When running taint checks (because the script
+was running setuid or setgid, or the B<-T> switch was used), this
+variable is ignored.
+
+=item PERLLIB
+
+A colon-separated list of directories in which to look for Perl library
+files before looking in the standard library and the current directory.
+If PERL5LIB is defined, PERLLIB is not used.
+
+=item PERL5DB
+
+The command used to load the debugger code. The default is:
+
+ BEGIN { require 'perl5db.pl' }
+
+=item PERL5SHELL (specific to WIN32 port)
+
+May be set to an alternative shell that perl must use internally for
+executing "backtick" commands or system(). Default is C<cmd.exe /x/c>
+on WindowsNT and C<command.com /c> on Windows95. The value is considered
+to be space delimited. Precede any character that needs to be protected
+(like a space or backslash) with a backslash.
+
+Note that Perl doesn't use COMSPEC for this purpose because
+COMSPEC has a high degree of variability among users, leading to
+portability concerns. Besides, perl can use a shell that may not be
+fit for interactive use, and setting COMSPEC to such a shell may
+interfere with the proper functioning of other programs (which usually
+look in COMSPEC to find a shell fit for interactive use).
+
+=item PERL_DEBUG_MSTATS
+
+Relevant only if perl is compiled with the malloc included with the perl
+distribution (that is, if C<perl -V:d_mymalloc> is 'define').
+If set, this causes memory statistics to be dumped after execution. If set
+to an integer greater than one, also causes memory statistics to be dumped
+after compilation.
+
+=item PERL_DESTRUCT_LEVEL
+
+Relevant only if your perl executable was built with B<-DDEBUGGING>,
+this controls the behavior of global destruction of objects and other
+references.
+
+=back
+
+Perl also has environment variables that control how Perl handles data
+specific to particular natural languages. See L<perllocale>.
+
+Apart from these, Perl uses no other environment variables, except
+to make them available to the script being executed, and to child
+processes. However, scripts running setuid would do well to execute
+the following lines before doing anything else, just to keep people
+honest:
+
+ $ENV{PATH} = '/bin:/usr/bin'; # or whatever you need
+ $ENV{SHELL} = '/bin/sh' if exists $ENV{SHELL};
+ delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
+
diff --git a/contrib/perl5/pod/perlsec.pod b/contrib/perl5/pod/perlsec.pod
new file mode 100644
index 000000000000..0b22acd9cda8
--- /dev/null
+++ b/contrib/perl5/pod/perlsec.pod
@@ -0,0 +1,351 @@
+=head1 NAME
+
+perlsec - Perl security
+
+=head1 DESCRIPTION
+
+Perl is designed to make it easy to program securely even when running
+with extra privileges, like setuid or setgid programs. Unlike most
+command line shells, which are based on multiple substitution passes on
+each line of the script, Perl uses a more conventional evaluation scheme
+with fewer hidden snags. Additionally, because the language has more
+builtin functionality, it can rely less upon external (and possibly
+untrustworthy) programs to accomplish its purposes.
+
+Perl automatically enables a set of special security checks, called I<taint
+mode>, when it detects its program running with differing real and effective
+user or group IDs. The setuid bit in Unix permissions is mode 04000, the
+setgid bit mode 02000; either or both may be set. You can also enable taint
+mode explicitly by using the B<-T> command line flag. This flag is
+I<strongly> suggested for server programs and any program run on behalf of
+someone else, such as a CGI script. Once taint mode is on, it's on for
+the remainder of your script.
+
+While in this mode, Perl takes special precautions called I<taint
+checks> to prevent both obvious and subtle traps. Some of these checks
+are reasonably simple, such as verifying that path directories aren't
+writable by others; careful programmers have always used checks like
+these. Other checks, however, are best supported by the language itself,
+and it is these checks especially that contribute to making a set-id Perl
+program more secure than the corresponding C program.
+
+You may not use data derived from outside your program to affect
+something else outside your program--at least, not by accident. All
+command line arguments, environment variables, locale information (see
+L<perllocale>), results of certain system calls (readdir, readlink,
+the gecos field of getpw* calls), and all file input are marked as
+"tainted". Tainted data may not be used directly or indirectly in any
+command that invokes a sub-shell, nor in any command that modifies
+files, directories, or processes. (B<Important exception>: If you pass
+a list of arguments to either C<system> or C<exec>, the elements of
+that list are B<NOT> checked for taintedness.) Any variable set
+to a value derived from tainted data will itself be tainted,
+even if it is logically impossible for the tainted data
+to alter the variable. Because taintedness is associated with each
+scalar value, some elements of an array can be tainted and others not.
+
+For example:
+
+ $arg = shift; # $arg is tainted
+ $hid = $arg, 'bar'; # $hid is also tainted
+ $line = <>; # Tainted
+ $line = <STDIN>; # Also tainted
+ open FOO, "/home/me/bar" or die $!;
+ $line = <FOO>; # Still tainted
+ $path = $ENV{'PATH'}; # Tainted, but see below
+ $data = 'abc'; # Not tainted
+
+ system "echo $arg"; # Insecure
+ system "/bin/echo", $arg; # Secure (doesn't use sh)
+ system "echo $hid"; # Insecure
+ system "echo $data"; # Insecure until PATH set
+
+ $path = $ENV{'PATH'}; # $path now tainted
+
+ $ENV{'PATH'} = '/bin:/usr/bin';
+ delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
+
+ $path = $ENV{'PATH'}; # $path now NOT tainted
+ system "echo $data"; # Is secure now!
+
+ open(FOO, "< $arg"); # OK - read-only file
+ open(FOO, "> $arg"); # Not OK - trying to write
+
+ open(FOO,"echo $arg|"); # Not OK, but...
+ open(FOO,"-|")
+ or exec 'echo', $arg; # OK
+
+ $shout = `echo $arg`; # Insecure, $shout now tainted
+
+ unlink $data, $arg; # Insecure
+ umask $arg; # Insecure
+
+ exec "echo $arg"; # Insecure
+ exec "echo", $arg; # Secure (doesn't use the shell)
+ exec "sh", '-c', $arg; # Considered secure, alas!
+
+ @files = <*.c>; # Always insecure (uses csh)
+ @files = glob('*.c'); # Always insecure (uses csh)
+
+If you try to do something insecure, you will get a fatal error saying
+something like "Insecure dependency" or "Insecure $ENV{PATH}". Note that you
+can still write an insecure B<system> or B<exec>, but only by explicitly
+doing something like the "considered secure" example above.
+
+=head2 Laundering and Detecting Tainted Data
+
+To test whether a variable contains tainted data, and whose use would thus
+trigger an "Insecure dependency" message, check your nearby CPAN mirror
+for the F<Taint.pm> module, which should become available around November
+1997. Or you may be able to use the following I<is_tainted()> function.
+
+ sub is_tainted {
+ return ! eval {
+ join('',@_), kill 0;
+ 1;
+ };
+ }
+
+This function makes use of the fact that the presence of tainted data
+anywhere within an expression renders the entire expression tainted. It
+would be inefficient for every operator to test every argument for
+taintedness. Instead, the slightly more efficient and conservative
+approach is used that if any tainted value has been accessed within the
+same expression, the whole expression is considered tainted.
+
+But testing for taintedness gets you only so far. Sometimes you have just
+to clear your data's taintedness. The only way to bypass the tainting
+mechanism is by referencing subpatterns from a regular expression match.
+Perl presumes that if you reference a substring using $1, $2, etc., that
+you knew what you were doing when you wrote the pattern. That means using
+a bit of thought--don't just blindly untaint anything, or you defeat the
+entire mechanism. It's better to verify that the variable has only good
+characters (for certain values of "good") rather than checking whether it
+has any bad characters. That's because it's far too easy to miss bad
+characters that you never thought of.
+
+Here's a test to make sure that the data contains nothing but "word"
+characters (alphabetics, numerics, and underscores), a hyphen, an at sign,
+or a dot.
+
+ if ($data =~ /^([-\@\w.]+)$/) {
+ $data = $1; # $data now untainted
+ } else {
+ die "Bad data in $data"; # log this somewhere
+ }
+
+This is fairly secure because C</\w+/> doesn't normally match shell
+metacharacters, nor are dot, dash, or at going to mean something special
+to the shell. Use of C</.+/> would have been insecure in theory because
+it lets everything through, but Perl doesn't check for that. The lesson
+is that when untainting, you must be exceedingly careful with your patterns.
+Laundering data using regular expression is the I<ONLY> mechanism for
+untainting dirty data, unless you use the strategy detailed below to fork
+a child of lesser privilege.
+
+The example does not untaint $data if C<use locale> is in effect,
+because the characters matched by C<\w> are determined by the locale.
+Perl considers that locale definitions are untrustworthy because they
+contain data from outside the program. If you are writing a
+locale-aware program, and want to launder data with a regular expression
+containing C<\w>, put C<no locale> ahead of the expression in the same
+block. See L<perllocale/SECURITY> for further discussion and examples.
+
+=head2 Switches On the "#!" Line
+
+When you make a script executable, in order to make it usable as a
+command, the system will pass switches to perl from the script's #!
+line. Perl checks that any command line switches given to a setuid
+(or setgid) script actually match the ones set on the #! line. Some
+Unix and Unix-like environments impose a one-switch limit on the #!
+line, so you may need to use something like C<-wU> instead of C<-w -U>
+under such systems. (This issue should arise only in Unix or
+Unix-like environments that support #! and setuid or setgid scripts.)
+
+=head2 Cleaning Up Your Path
+
+For "Insecure C<$ENV{PATH}>" messages, you need to set C<$ENV{'PATH'}> to a
+known value, and each directory in the path must be non-writable by others
+than its owner and group. You may be surprised to get this message even
+if the pathname to your executable is fully qualified. This is I<not>
+generated because you didn't supply a full path to the program; instead,
+it's generated because you never set your PATH environment variable, or
+you didn't set it to something that was safe. Because Perl can't
+guarantee that the executable in question isn't itself going to turn
+around and execute some other program that is dependent on your PATH, it
+makes sure you set the PATH.
+
+The PATH isn't the only environment variable which can cause problems.
+Because some shells may use the variables IFS, CDPATH, ENV, and
+BASH_ENV, Perl checks that those are either empty or untainted when
+starting subprocesses. You may wish to add something like this to your
+setid and taint-checking scripts.
+
+ delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
+
+It's also possible to get into trouble with other operations that don't
+care whether they use tainted values. Make judicious use of the file
+tests in dealing with any user-supplied filenames. When possible, do
+opens and such B<after> properly dropping any special user (or group!)
+privileges. Perl doesn't prevent you from opening tainted filenames for reading,
+so be careful what you print out. The tainting mechanism is intended to
+prevent stupid mistakes, not to remove the need for thought.
+
+Perl does not call the shell to expand wild cards when you pass B<system>
+and B<exec> explicit parameter lists instead of strings with possible shell
+wildcards in them. Unfortunately, the B<open>, B<glob>, and
+backtick functions provide no such alternate calling convention, so more
+subterfuge will be required.
+
+Perl provides a reasonably safe way to open a file or pipe from a setuid
+or setgid program: just create a child process with reduced privilege who
+does the dirty work for you. First, fork a child using the special
+B<open> syntax that connects the parent and child by a pipe. Now the
+child resets its ID set and any other per-process attributes, like
+environment variables, umasks, current working directories, back to the
+originals or known safe values. Then the child process, which no longer
+has any special permissions, does the B<open> or other system call.
+Finally, the child passes the data it managed to access back to the
+parent. Because the file or pipe was opened in the child while running
+under less privilege than the parent, it's not apt to be tricked into
+doing something it shouldn't.
+
+Here's a way to do backticks reasonably safely. Notice how the B<exec> is
+not called with a string that the shell could expand. This is by far the
+best way to call something that might be subjected to shell escapes: just
+never call the shell at all.
+
+ use English;
+ die "Can't fork: $!" unless defined $pid = open(KID, "-|");
+ if ($pid) { # parent
+ while (<KID>) {
+ # do something
+ }
+ close KID;
+ } else {
+ my @temp = ($EUID, $EGID);
+ $EUID = $UID;
+ $EGID = $GID; # initgroups() also called!
+ # Make sure privs are really gone
+ ($EUID, $EGID) = @temp;
+ die "Can't drop privileges"
+ unless $UID == $EUID && $GID eq $EGID;
+ $ENV{PATH} = "/bin:/usr/bin";
+ exec 'myprog', 'arg1', 'arg2'
+ or die "can't exec myprog: $!";
+ }
+
+A similar strategy would work for wildcard expansion via C<glob>, although
+you can use C<readdir> instead.
+
+Taint checking is most useful when although you trust yourself not to have
+written a program to give away the farm, you don't necessarily trust those
+who end up using it not to try to trick it into doing something bad. This
+is the kind of security checking that's useful for set-id programs and
+programs launched on someone else's behalf, like CGI programs.
+
+This is quite different, however, from not even trusting the writer of the
+code not to try to do something evil. That's the kind of trust needed
+when someone hands you a program you've never seen before and says, "Here,
+run this." For that kind of safety, check out the Safe module,
+included standard in the Perl distribution. This module allows the
+programmer to set up special compartments in which all system operations
+are trapped and namespace access is carefully controlled.
+
+=head2 Security Bugs
+
+Beyond the obvious problems that stem from giving special privileges to
+systems as flexible as scripts, on many versions of Unix, set-id scripts
+are inherently insecure right from the start. The problem is a race
+condition in the kernel. Between the time the kernel opens the file to
+see which interpreter to run and when the (now-set-id) interpreter turns
+around and reopens the file to interpret it, the file in question may have
+changed, especially if you have symbolic links on your system.
+
+Fortunately, sometimes this kernel "feature" can be disabled.
+Unfortunately, there are two ways to disable it. The system can simply
+outlaw scripts with any set-id bit set, which doesn't help much.
+Alternately, it can simply ignore the set-id bits on scripts. If the
+latter is true, Perl can emulate the setuid and setgid mechanism when it
+notices the otherwise useless setuid/gid bits on Perl scripts. It does
+this via a special executable called B<suidperl> that is automatically
+invoked for you if it's needed.
+
+However, if the kernel set-id script feature isn't disabled, Perl will
+complain loudly that your set-id script is insecure. You'll need to
+either disable the kernel set-id script feature, or put a C wrapper around
+the script. A C wrapper is just a compiled program that does nothing
+except call your Perl program. Compiled programs are not subject to the
+kernel bug that plagues set-id scripts. Here's a simple wrapper, written
+in C:
+
+ #define REAL_PATH "/path/to/script"
+ main(ac, av)
+ char **av;
+ {
+ execv(REAL_PATH, av);
+ }
+
+Compile this wrapper into a binary executable and then make I<it> rather
+than your script setuid or setgid.
+
+See the program B<wrapsuid> in the F<eg> directory of your Perl
+distribution for a convenient way to do this automatically for all your
+setuid Perl programs. It moves setuid scripts into files with the same
+name plus a leading dot, and then compiles a wrapper like the one above
+for each of them.
+
+In recent years, vendors have begun to supply systems free of this
+inherent security bug. On such systems, when the kernel passes the name
+of the set-id script to open to the interpreter, rather than using a
+pathname subject to meddling, it instead passes I</dev/fd/3>. This is a
+special file already opened on the script, so that there can be no race
+condition for evil scripts to exploit. On these systems, Perl should be
+compiled with C<-DSETUID_SCRIPTS_ARE_SECURE_NOW>. The B<Configure>
+program that builds Perl tries to figure this out for itself, so you
+should never have to specify this yourself. Most modern releases of
+SysVr4 and BSD 4.4 use this approach to avoid the kernel race condition.
+
+Prior to release 5.003 of Perl, a bug in the code of B<suidperl> could
+introduce a security hole in systems compiled with strict POSIX
+compliance.
+
+=head2 Protecting Your Programs
+
+There are a number of ways to hide the source to your Perl programs,
+with varying levels of "security".
+
+First of all, however, you I<can't> take away read permission, because
+the source code has to be readable in order to be compiled and
+interpreted. (That doesn't mean that a CGI script's source is
+readable by people on the web, though.) So you have to leave the
+permissions at the socially friendly 0755 level. This lets
+people on your local system only see your source.
+
+Some people mistakenly regard this as a security problem. If your program does
+insecure things, and relies on people not knowing how to exploit those
+insecurities, it is not secure. It is often possible for someone to
+determine the insecure things and exploit them without viewing the
+source. Security through obscurity, the name for hiding your bugs
+instead of fixing them, is little security indeed.
+
+You can try using encryption via source filters (Filter::* from CPAN).
+But crackers might be able to decrypt it. You can try using the
+byte code compiler and interpreter described below, but crackers might
+be able to de-compile it. You can try using the native-code compiler
+described below, but crackers might be able to disassemble it. These
+pose varying degrees of difficulty to people wanting to get at your
+code, but none can definitively conceal it (this is true of every
+language, not just Perl).
+
+If you're concerned about people profiting from your code, then the
+bottom line is that nothing but a restrictive licence will give you
+legal security. License your software and pepper it with threatening
+statements like "This is unpublished proprietary software of XYZ Corp.
+Your access to it does not give you permission to use it blah blah
+blah." You should see a lawyer to be sure your licence's wording will
+stand up in court.
+
+=head1 SEE ALSO
+
+L<perlrun> for its description of cleaning up environment variables.
diff --git a/contrib/perl5/pod/perlstyle.pod b/contrib/perl5/pod/perlstyle.pod
new file mode 100644
index 000000000000..cf280ce1da07
--- /dev/null
+++ b/contrib/perl5/pod/perlstyle.pod
@@ -0,0 +1,275 @@
+=head1 NAME
+
+perlstyle - Perl style guide
+
+=head1 DESCRIPTION
+
+Each programmer will, of course, have his or her own preferences in
+regards to formatting, but there are some general guidelines that will
+make your programs easier to read, understand, and maintain.
+
+The most important thing is to run your programs under the B<-w>
+flag at all times. You may turn it off explicitly for particular
+portions of code via the C<$^W> variable if you must. You should
+also always run under C<use strict> or know the reason why not.
+The C<use sigtrap> and even C<use diagnostics> pragmas may also prove
+useful.
+
+Regarding aesthetics of code lay out, about the only thing Larry
+cares strongly about is that the closing curly brace of
+a multi-line BLOCK should line up with the keyword that started the construct.
+Beyond that, he has other preferences that aren't so strong:
+
+=over 4
+
+=item *
+
+4-column indent.
+
+=item *
+
+Opening curly on same line as keyword, if possible, otherwise line up.
+
+=item *
+
+Space before the opening curly of a multi-line BLOCK.
+
+=item *
+
+One-line BLOCK may be put on one line, including curlies.
+
+=item *
+
+No space before the semicolon.
+
+=item *
+
+Semicolon omitted in "short" one-line BLOCK.
+
+=item *
+
+Space around most operators.
+
+=item *
+
+Space around a "complex" subscript (inside brackets).
+
+=item *
+
+Blank lines between chunks that do different things.
+
+=item *
+
+Uncuddled elses.
+
+=item *
+
+No space between function name and its opening parenthesis.
+
+=item *
+
+Space after each comma.
+
+=item *
+
+Long lines broken after an operator (except "and" and "or").
+
+=item *
+
+Space after last parenthesis matching on current line.
+
+=item *
+
+Line up corresponding items vertically.
+
+=item *
+
+Omit redundant punctuation as long as clarity doesn't suffer.
+
+=back
+
+Larry has his reasons for each of these things, but he doesn't claim that
+everyone else's mind works the same as his does.
+
+Here are some other more substantive style issues to think about:
+
+=over 4
+
+=item *
+
+Just because you I<CAN> do something a particular way doesn't mean that
+you I<SHOULD> do it that way. Perl is designed to give you several
+ways to do anything, so consider picking the most readable one. For
+instance
+
+ open(FOO,$foo) || die "Can't open $foo: $!";
+
+is better than
+
+ die "Can't open $foo: $!" unless open(FOO,$foo);
+
+because the second way hides the main point of the statement in a
+modifier. On the other hand
+
+ print "Starting analysis\n" if $verbose;
+
+is better than
+
+ $verbose && print "Starting analysis\n";
+
+because the main point isn't whether the user typed B<-v> or not.
+
+Similarly, just because an operator lets you assume default arguments
+doesn't mean that you have to make use of the defaults. The defaults
+are there for lazy systems programmers writing one-shot programs. If
+you want your program to be readable, consider supplying the argument.
+
+Along the same lines, just because you I<CAN> omit parentheses in many
+places doesn't mean that you ought to:
+
+ return print reverse sort num values %array;
+ return print(reverse(sort num (values(%array))));
+
+When in doubt, parenthesize. At the very least it will let some poor
+schmuck bounce on the % key in B<vi>.
+
+Even if you aren't in doubt, consider the mental welfare of the person
+who has to maintain the code after you, and who will probably put
+parentheses in the wrong place.
+
+=item *
+
+Don't go through silly contortions to exit a loop at the top or the
+bottom, when Perl provides the C<last> operator so you can exit in
+the middle. Just "outdent" it a little to make it more visible:
+
+ LINE:
+ for (;;) {
+ statements;
+ last LINE if $foo;
+ next LINE if /^#/;
+ statements;
+ }
+
+=item *
+
+Don't be afraid to use loop labels--they're there to enhance
+readability as well as to allow multilevel loop breaks. See the
+previous example.
+
+=item *
+
+Avoid using grep() (or map()) or `backticks` in a void context, that is,
+when you just throw away their return values. Those functions all
+have return values, so use them. Otherwise use a foreach() loop or
+the system() function instead.
+
+=item *
+
+For portability, when using features that may not be implemented on
+every machine, test the construct in an eval to see if it fails. If
+you know what version or patchlevel a particular feature was
+implemented, you can test C<$]> (C<$PERL_VERSION> in C<English>) to see if it
+will be there. The C<Config> module will also let you interrogate values
+determined by the B<Configure> program when Perl was installed.
+
+=item *
+
+Choose mnemonic identifiers. If you can't remember what mnemonic means,
+you've got a problem.
+
+=item *
+
+While short identifiers like $gotit are probably ok, use underscores to
+separate words. It is generally easier to read $var_names_like_this than
+$VarNamesLikeThis, especially for non-native speakers of English. It's
+also a simple rule that works consistently with VAR_NAMES_LIKE_THIS.
+
+Package names are sometimes an exception to this rule. Perl informally
+reserves lowercase module names for "pragma" modules like C<integer> and
+C<strict>. Other modules should begin with a capital letter and use mixed
+case, but probably without underscores due to limitations in primitive
+file systems' representations of module names as files that must fit into a
+few sparse bytes.
+
+=item *
+
+You may find it helpful to use letter case to indicate the scope
+or nature of a variable. For example:
+
+ $ALL_CAPS_HERE constants only (beware clashes with perl vars!)
+ $Some_Caps_Here package-wide global/static
+ $no_caps_here function scope my() or local() variables
+
+Function and method names seem to work best as all lowercase.
+E.g., $obj-E<gt>as_string().
+
+You can use a leading underscore to indicate that a variable or
+function should not be used outside the package that defined it.
+
+=item *
+
+If you have a really hairy regular expression, use the C</x> modifier and
+put in some whitespace to make it look a little less like line noise.
+Don't use slash as a delimiter when your regexp has slashes or backslashes.
+
+=item *
+
+Use the new "and" and "or" operators to avoid having to parenthesize
+list operators so much, and to reduce the incidence of punctuation
+operators like C<&&> and C<||>. Call your subroutines as if they were
+functions or list operators to avoid excessive ampersands and parentheses.
+
+=item *
+
+Use here documents instead of repeated print() statements.
+
+=item *
+
+Line up corresponding things vertically, especially if it'd be too long
+to fit on one line anyway.
+
+ $IDX = $ST_MTIME;
+ $IDX = $ST_ATIME if $opt_u;
+ $IDX = $ST_CTIME if $opt_c;
+ $IDX = $ST_SIZE if $opt_s;
+
+ mkdir $tmpdir, 0700 or die "can't mkdir $tmpdir: $!";
+ chdir($tmpdir) or die "can't chdir $tmpdir: $!";
+ mkdir 'tmp', 0777 or die "can't mkdir $tmpdir/tmp: $!";
+
+=item *
+
+Always check the return codes of system calls. Good error messages should
+go to STDERR, include which program caused the problem, what the failed
+system call and arguments were, and (VERY IMPORTANT) should contain the
+standard system error message for what went wrong. Here's a simple but
+sufficient example:
+
+ opendir(D, $dir) or die "can't opendir $dir: $!";
+
+=item *
+
+Line up your transliterations when it makes sense:
+
+ tr [abc]
+ [xyz];
+
+=item *
+
+Think about reusability. Why waste brainpower on a one-shot when you
+might want to do something like it again? Consider generalizing your
+code. Consider writing a module or object class. Consider making your
+code run cleanly with C<use strict> and B<-w> in effect. Consider giving away
+your code. Consider changing your whole world view. Consider... oh,
+never mind.
+
+=item *
+
+Be consistent.
+
+=item *
+
+Be nice.
+
+=back
diff --git a/contrib/perl5/pod/perlsub.pod b/contrib/perl5/pod/perlsub.pod
new file mode 100644
index 000000000000..957b3d8ad813
--- /dev/null
+++ b/contrib/perl5/pod/perlsub.pod
@@ -0,0 +1,1149 @@
+=head1 NAME
+
+perlsub - Perl subroutines
+
+=head1 SYNOPSIS
+
+To declare subroutines:
+
+ sub NAME; # A "forward" declaration.
+ sub NAME(PROTO); # ditto, but with prototypes
+
+ sub NAME BLOCK # A declaration and a definition.
+ sub NAME(PROTO) BLOCK # ditto, but with prototypes
+
+To define an anonymous subroutine at runtime:
+
+ $subref = sub BLOCK; # no proto
+ $subref = sub (PROTO) BLOCK; # with proto
+
+To import subroutines:
+
+ use PACKAGE qw(NAME1 NAME2 NAME3);
+
+To call subroutines:
+
+ NAME(LIST); # & is optional with parentheses.
+ NAME LIST; # Parentheses optional if predeclared/imported.
+ &NAME; # Makes current @_ visible to called subroutine.
+
+=head1 DESCRIPTION
+
+Like many languages, Perl provides for user-defined subroutines. These
+may be located anywhere in the main program, loaded in from other files
+via the C<do>, C<require>, or C<use> keywords, or even generated on the
+fly using C<eval> or anonymous subroutines (closures). You can even call
+a function indirectly using a variable containing its name or a CODE reference
+to it.
+
+The Perl model for function call and return values is simple: all
+functions are passed as parameters one single flat list of scalars, and
+all functions likewise return to their caller one single flat list of
+scalars. Any arrays or hashes in these call and return lists will
+collapse, losing their identities--but you may always use
+pass-by-reference instead to avoid this. Both call and return lists may
+contain as many or as few scalar elements as you'd like. (Often a
+function without an explicit return statement is called a subroutine, but
+there's really no difference from the language's perspective.)
+
+Any arguments passed to the routine come in as the array C<@_>. Thus if you
+called a function with two arguments, those would be stored in C<$_[0]>
+and C<$_[1]>. The array C<@_> is a local array, but its elements are
+aliases for the actual scalar parameters. In particular, if an element
+C<$_[0]> is updated, the corresponding argument is updated (or an error
+occurs if it is not updatable). If an argument is an array or hash
+element which did not exist when the function was called, that element is
+created only when (and if) it is modified or if a reference to it is
+taken. (Some earlier versions of Perl created the element whether or not
+it was assigned to.) Note that assigning to the whole array C<@_> removes
+the aliasing, and does not update any arguments.
+
+The return value of the subroutine is the value of the last expression
+evaluated. Alternatively, a C<return> statement may be used to exit the
+subroutine, optionally specifying the returned value, which will be
+evaluated in the appropriate context (list, scalar, or void) depending
+on the context of the subroutine call. If you specify no return value,
+the subroutine will return an empty list in a list context, an undefined
+value in a scalar context, or nothing in a void context. If you return
+one or more arrays and/or hashes, these will be flattened together into
+one large indistinguishable list.
+
+Perl does not have named formal parameters, but in practice all you do is
+assign to a C<my()> list of these. Any variables you use in the function
+that aren't declared private are global variables. For the gory details
+on creating private variables, see
+L<"Private Variables via my()"> and L<"Temporary Values via local()">.
+To create protected environments for a set of functions in a separate
+package (and probably a separate file), see L<perlmod/"Packages">.
+
+Example:
+
+ sub max {
+ my $max = shift(@_);
+ foreach $foo (@_) {
+ $max = $foo if $max < $foo;
+ }
+ return $max;
+ }
+ $bestday = max($mon,$tue,$wed,$thu,$fri);
+
+Example:
+
+ # get a line, combining continuation lines
+ # that start with whitespace
+
+ sub get_line {
+ $thisline = $lookahead; # GLOBAL VARIABLES!!
+ LINE: while (defined($lookahead = <STDIN>)) {
+ if ($lookahead =~ /^[ \t]/) {
+ $thisline .= $lookahead;
+ }
+ else {
+ last LINE;
+ }
+ }
+ $thisline;
+ }
+
+ $lookahead = <STDIN>; # get first line
+ while ($_ = get_line()) {
+ ...
+ }
+
+Use array assignment to a local list to name your formal arguments:
+
+ sub maybeset {
+ my($key, $value) = @_;
+ $Foo{$key} = $value unless $Foo{$key};
+ }
+
+This also has the effect of turning call-by-reference into call-by-value,
+because the assignment copies the values. Otherwise a function is free to
+do in-place modifications of C<@_> and change its caller's values.
+
+ upcase_in($v1, $v2); # this changes $v1 and $v2
+ sub upcase_in {
+ for (@_) { tr/a-z/A-Z/ }
+ }
+
+You aren't allowed to modify constants in this way, of course. If an
+argument were actually literal and you tried to change it, you'd take a
+(presumably fatal) exception. For example, this won't work:
+
+ upcase_in("frederick");
+
+It would be much safer if the C<upcase_in()> function
+were written to return a copy of its parameters instead
+of changing them in place:
+
+ ($v3, $v4) = upcase($v1, $v2); # this doesn't
+ sub upcase {
+ return unless defined wantarray; # void context, do nothing
+ my @parms = @_;
+ for (@parms) { tr/a-z/A-Z/ }
+ return wantarray ? @parms : $parms[0];
+ }
+
+Notice how this (unprototyped) function doesn't care whether it was passed
+real scalars or arrays. Perl will see everything as one big long flat C<@_>
+parameter list. This is one of the ways where Perl's simple
+argument-passing style shines. The C<upcase()> function would work perfectly
+well without changing the C<upcase()> definition even if we fed it things
+like this:
+
+ @newlist = upcase(@list1, @list2);
+ @newlist = upcase( split /:/, $var );
+
+Do not, however, be tempted to do this:
+
+ (@a, @b) = upcase(@list1, @list2);
+
+Because like its flat incoming parameter list, the return list is also
+flat. So all you have managed to do here is stored everything in C<@a> and
+made C<@b> an empty list. See L<Pass by Reference> for alternatives.
+
+A subroutine may be called using the "C<&>" prefix. The "C<&>" is optional
+in modern Perls, and so are the parentheses if the subroutine has been
+predeclared. (Note, however, that the "C<&>" is I<NOT> optional when
+you're just naming the subroutine, such as when it's used as an
+argument to C<defined()> or C<undef()>. Nor is it optional when you want to
+do an indirect subroutine call with a subroutine name or reference
+using the C<&$subref()> or C<&{$subref}()> constructs. See L<perlref>
+for more on that.)
+
+Subroutines may be called recursively. If a subroutine is called using
+the "C<&>" form, the argument list is optional, and if omitted, no C<@_> array is
+set up for the subroutine: the C<@_> array at the time of the call is
+visible to subroutine instead. This is an efficiency mechanism that
+new users may wish to avoid.
+
+ &foo(1,2,3); # pass three arguments
+ foo(1,2,3); # the same
+
+ foo(); # pass a null list
+ &foo(); # the same
+
+ &foo; # foo() get current args, like foo(@_) !!
+ foo; # like foo() IFF sub foo predeclared, else "foo"
+
+Not only does the "C<&>" form make the argument list optional, but it also
+disables any prototype checking on the arguments you do provide. This
+is partly for historical reasons, and partly for having a convenient way
+to cheat if you know what you're doing. See the section on Prototypes below.
+
+Function whose names are in all upper case are reserved to the Perl core,
+just as are modules whose names are in all lower case. A function in
+all capitals is a loosely-held convention meaning it will be called
+indirectly by the run-time system itself. Functions that do special,
+pre-defined things are C<BEGIN>, C<END>, C<AUTOLOAD>, and C<DESTROY>--plus all the
+functions mentioned in L<perltie>. The 5.005 release adds C<INIT>
+to this list.
+
+=head2 Private Variables via C<my()>
+
+Synopsis:
+
+ my $foo; # declare $foo lexically local
+ my (@wid, %get); # declare list of variables local
+ my $foo = "flurp"; # declare $foo lexical, and init it
+ my @oof = @bar; # declare @oof lexical, and init it
+
+A "C<my>" declares the listed variables to be confined (lexically) to the
+enclosing block, conditional (C<if/unless/elsif/else>), loop
+(C<for/foreach/while/until/continue>), subroutine, C<eval>, or
+C<do/require/use>'d file. If more than one value is listed, the list
+must be placed in parentheses. All listed elements must be legal lvalues.
+Only alphanumeric identifiers may be lexically scoped--magical
+builtins like C<$/> must currently be C<local>ize with "C<local>" instead.
+
+Unlike dynamic variables created by the "C<local>" operator, lexical
+variables declared with "C<my>" are totally hidden from the outside world,
+including any called subroutines (even if it's the same subroutine called
+from itself or elsewhere--every call gets its own copy).
+
+This doesn't mean that a C<my()> variable declared in a statically
+I<enclosing> lexical scope would be invisible. Only the dynamic scopes
+are cut off. For example, the C<bumpx()> function below has access to the
+lexical C<$x> variable because both the my and the sub occurred at the same
+scope, presumably the file scope.
+
+ my $x = 10;
+ sub bumpx { $x++ }
+
+(An C<eval()>, however, can see the lexical variables of the scope it is
+being evaluated in so long as the names aren't hidden by declarations within
+the C<eval()> itself. See L<perlref>.)
+
+The parameter list to C<my()> may be assigned to if desired, which allows you
+to initialize your variables. (If no initializer is given for a
+particular variable, it is created with the undefined value.) Commonly
+this is used to name the parameters to a subroutine. Examples:
+
+ $arg = "fred"; # "global" variable
+ $n = cube_root(27);
+ print "$arg thinks the root is $n\n";
+ fred thinks the root is 3
+
+ sub cube_root {
+ my $arg = shift; # name doesn't matter
+ $arg **= 1/3;
+ return $arg;
+ }
+
+The "C<my>" is simply a modifier on something you might assign to. So when
+you do assign to the variables in its argument list, the "C<my>" doesn't
+change whether those variables are viewed as a scalar or an array. So
+
+ my ($foo) = <STDIN>; # WRONG?
+ my @FOO = <STDIN>;
+
+both supply a list context to the right-hand side, while
+
+ my $foo = <STDIN>;
+
+supplies a scalar context. But the following declares only one variable:
+
+ my $foo, $bar = 1; # WRONG
+
+That has the same effect as
+
+ my $foo;
+ $bar = 1;
+
+The declared variable is not introduced (is not visible) until after
+the current statement. Thus,
+
+ my $x = $x;
+
+can be used to initialize the new $x with the value of the old C<$x>, and
+the expression
+
+ my $x = 123 and $x == 123
+
+is false unless the old C<$x> happened to have the value C<123>.
+
+Lexical scopes of control structures are not bounded precisely by the
+braces that delimit their controlled blocks; control expressions are
+part of the scope, too. Thus in the loop
+
+ while (defined(my $line = <>)) {
+ $line = lc $line;
+ } continue {
+ print $line;
+ }
+
+the scope of C<$line> extends from its declaration throughout the rest of
+the loop construct (including the C<continue> clause), but not beyond
+it. Similarly, in the conditional
+
+ if ((my $answer = <STDIN>) =~ /^yes$/i) {
+ user_agrees();
+ } elsif ($answer =~ /^no$/i) {
+ user_disagrees();
+ } else {
+ chomp $answer;
+ die "'$answer' is neither 'yes' nor 'no'";
+ }
+
+the scope of C<$answer> extends from its declaration throughout the rest
+of the conditional (including C<elsif> and C<else> clauses, if any),
+but not beyond it.
+
+(None of the foregoing applies to C<if/unless> or C<while/until>
+modifiers appended to simple statements. Such modifiers are not
+control structures and have no effect on scoping.)
+
+The C<foreach> loop defaults to scoping its index variable dynamically
+(in the manner of C<local>; see below). However, if the index
+variable is prefixed with the keyword "C<my>", then it is lexically
+scoped instead. Thus in the loop
+
+ for my $i (1, 2, 3) {
+ some_function();
+ }
+
+the scope of C<$i> extends to the end of the loop, but not beyond it, and
+so the value of C<$i> is unavailable in C<some_function()>.
+
+Some users may wish to encourage the use of lexically scoped variables.
+As an aid to catching implicit references to package variables,
+if you say
+
+ use strict 'vars';
+
+then any variable reference from there to the end of the enclosing
+block must either refer to a lexical variable, or must be fully
+qualified with the package name. A compilation error results
+otherwise. An inner block may countermand this with S<"C<no strict 'vars'>">.
+
+A C<my()> has both a compile-time and a run-time effect. At compile time,
+the compiler takes notice of it; the principle usefulness of this is to
+quiet S<"C<use strict 'vars'>">. The actual initialization is delayed until
+run time, so it gets executed appropriately; every time through a loop,
+for example.
+
+Variables declared with "C<my>" are not part of any package and are therefore
+never fully qualified with the package name. In particular, you're not
+allowed to try to make a package variable (or other global) lexical:
+
+ my $pack::var; # ERROR! Illegal syntax
+ my $_; # also illegal (currently)
+
+In fact, a dynamic variable (also known as package or global variables)
+are still accessible using the fully qualified C<::> notation even while a
+lexical of the same name is also visible:
+
+ package main;
+ local $x = 10;
+ my $x = 20;
+ print "$x and $::x\n";
+
+That will print out C<20> and C<10>.
+
+You may declare "C<my>" variables at the outermost scope of a file to hide
+any such identifiers totally from the outside world. This is similar
+to C's static variables at the file level. To do this with a subroutine
+requires the use of a closure (anonymous function with lexical access).
+If a block (such as an C<eval()>, function, or C<package>) wants to create
+a private subroutine that cannot be called from outside that block,
+it can declare a lexical variable containing an anonymous sub reference:
+
+ my $secret_version = '1.001-beta';
+ my $secret_sub = sub { print $secret_version };
+ &$secret_sub();
+
+As long as the reference is never returned by any function within the
+module, no outside module can see the subroutine, because its name is not in
+any package's symbol table. Remember that it's not I<REALLY> called
+C<$some_pack::secret_version> or anything; it's just C<$secret_version>,
+unqualified and unqualifiable.
+
+This does not work with object methods, however; all object methods have
+to be in the symbol table of some package to be found.
+
+=head2 Peristent Private Variables
+
+Just because a lexical variable is lexically (also called statically)
+scoped to its enclosing block, C<eval>, or C<do> FILE, this doesn't mean that
+within a function it works like a C static. It normally works more
+like a C auto, but with implicit garbage collection.
+
+Unlike local variables in C or C++, Perl's lexical variables don't
+necessarily get recycled just because their scope has exited.
+If something more permanent is still aware of the lexical, it will
+stick around. So long as something else references a lexical, that
+lexical won't be freed--which is as it should be. You wouldn't want
+memory being free until you were done using it, or kept around once you
+were done. Automatic garbage collection takes care of this for you.
+
+This means that you can pass back or save away references to lexical
+variables, whereas to return a pointer to a C auto is a grave error.
+It also gives us a way to simulate C's function statics. Here's a
+mechanism for giving a function private variables with both lexical
+scoping and a static lifetime. If you do want to create something like
+C's static variables, just enclose the whole function in an extra block,
+and put the static variable outside the function but in the block.
+
+ {
+ my $secret_val = 0;
+ sub gimme_another {
+ return ++$secret_val;
+ }
+ }
+ # $secret_val now becomes unreachable by the outside
+ # world, but retains its value between calls to gimme_another
+
+If this function is being sourced in from a separate file
+via C<require> or C<use>, then this is probably just fine. If it's
+all in the main program, you'll need to arrange for the C<my()>
+to be executed early, either by putting the whole block above
+your main program, or more likely, placing merely a C<BEGIN>
+sub around it to make sure it gets executed before your program
+starts to run:
+
+ sub BEGIN {
+ my $secret_val = 0;
+ sub gimme_another {
+ return ++$secret_val;
+ }
+ }
+
+See L<perlmod/"Package Constructors and Destructors"> about the C<BEGIN> function.
+
+If declared at the outermost scope, the file scope, then lexicals work
+someone like C's file statics. They are available to all functions in
+that same file declared below them, but are inaccessible from outside of
+the file. This is sometimes used in modules to create private variables
+for the whole module.
+
+=head2 Temporary Values via local()
+
+B<NOTE>: In general, you should be using "C<my>" instead of "C<local>", because
+it's faster and safer. Exceptions to this include the global punctuation
+variables, filehandles and formats, and direct manipulation of the Perl
+symbol table itself. Format variables often use "C<local>" though, as do
+other variables whose current value must be visible to called
+subroutines.
+
+Synopsis:
+
+ local $foo; # declare $foo dynamically local
+ local (@wid, %get); # declare list of variables local
+ local $foo = "flurp"; # declare $foo dynamic, and init it
+ local @oof = @bar; # declare @oof dynamic, and init it
+
+ local *FH; # localize $FH, @FH, %FH, &FH ...
+ local *merlyn = *randal; # now $merlyn is really $randal, plus
+ # @merlyn is really @randal, etc
+ local *merlyn = 'randal'; # SAME THING: promote 'randal' to *randal
+ local *merlyn = \$randal; # just alias $merlyn, not @merlyn etc
+
+A C<local()> modifies its listed variables to be "local" to the enclosing
+block, C<eval>, or C<do FILE>--and to I<any subroutine called from within that block>.
+A C<local()> just gives temporary values to global (meaning package)
+variables. It does B<not> create a local variable. This is known as
+dynamic scoping. Lexical scoping is done with "C<my>", which works more
+like C's auto declarations.
+
+If more than one variable is given to C<local()>, they must be placed in
+parentheses. All listed elements must be legal lvalues. This operator works
+by saving the current values of those variables in its argument list on a
+hidden stack and restoring them upon exiting the block, subroutine, or
+eval. This means that called subroutines can also reference the local
+variable, but not the global one. The argument list may be assigned to if
+desired, which allows you to initialize your local variables. (If no
+initializer is given for a particular variable, it is created with an
+undefined value.) Commonly this is used to name the parameters to a
+subroutine. Examples:
+
+ for $i ( 0 .. 9 ) {
+ $digits{$i} = $i;
+ }
+ # assume this function uses global %digits hash
+ parse_num();
+
+ # now temporarily add to %digits hash
+ if ($base12) {
+ # (NOTE: not claiming this is efficient!)
+ local %digits = (%digits, 't' => 10, 'e' => 11);
+ parse_num(); # parse_num gets this new %digits!
+ }
+ # old %digits restored here
+
+Because C<local()> is a run-time command, it gets executed every time
+through a loop. In releases of Perl previous to 5.0, this used more stack
+storage each time until the loop was exited. Perl now reclaims the space
+each time through, but it's still more efficient to declare your variables
+outside the loop.
+
+A C<local> is simply a modifier on an lvalue expression. When you assign to
+a C<local>ized variable, the C<local> doesn't change whether its list is viewed
+as a scalar or an array. So
+
+ local($foo) = <STDIN>;
+ local @FOO = <STDIN>;
+
+both supply a list context to the right-hand side, while
+
+ local $foo = <STDIN>;
+
+supplies a scalar context.
+
+A note about C<local()> and composite types is in order. Something
+like C<local(%foo)> works by temporarily placing a brand new hash in
+the symbol table. The old hash is left alone, but is hidden "behind"
+the new one.
+
+This means the old variable is completely invisible via the symbol
+table (i.e. the hash entry in the C<*foo> typeglob) for the duration
+of the dynamic scope within which the C<local()> was seen. This
+has the effect of allowing one to temporarily occlude any magic on
+composite types. For instance, this will briefly alter a tied
+hash to some other implementation:
+
+ tie %ahash, 'APackage';
+ [...]
+ {
+ local %ahash;
+ tie %ahash, 'BPackage';
+ [..called code will see %ahash tied to 'BPackage'..]
+ {
+ local %ahash;
+ [..%ahash is a normal (untied) hash here..]
+ }
+ }
+ [..%ahash back to its initial tied self again..]
+
+As another example, a custom implementation of C<%ENV> might look
+like this:
+
+ {
+ local %ENV;
+ tie %ENV, 'MyOwnEnv';
+ [..do your own fancy %ENV manipulation here..]
+ }
+ [..normal %ENV behavior here..]
+
+It's also worth taking a moment to explain what happens when you
+C<local>ize a member of a composite type (i.e. an array or hash element).
+In this case, the element is C<local>ized I<by name>. This means that
+when the scope of the C<local()> ends, the saved value will be
+restored to the hash element whose key was named in the C<local()>, or
+the array element whose index was named in the C<local()>. If that
+element was deleted while the C<local()> was in effect (e.g. by a
+C<delete()> from a hash or a C<shift()> of an array), it will spring
+back into existence, possibly extending an array and filling in the
+skipped elements with C<undef>. For instance, if you say
+
+ %hash = ( 'This' => 'is', 'a' => 'test' );
+ @ary = ( 0..5 );
+ {
+ local($ary[5]) = 6;
+ local($hash{'a'}) = 'drill';
+ while (my $e = pop(@ary)) {
+ print "$e . . .\n";
+ last unless $e > 3;
+ }
+ if (@ary) {
+ $hash{'only a'} = 'test';
+ delete $hash{'a'};
+ }
+ }
+ print join(' ', map { "$_ $hash{$_}" } sort keys %hash),".\n";
+ print "The array has ",scalar(@ary)," elements: ",
+ join(', ', map { defined $_ ? $_ : 'undef' } @ary),"\n";
+
+Perl will print
+
+ 6 . . .
+ 4 . . .
+ 3 . . .
+ This is a test only a test.
+ The array has 6 elements: 0, 1, 2, undef, undef, 5
+
+=head2 Passing Symbol Table Entries (typeglobs)
+
+[Note: The mechanism described in this section was originally the only
+way to simulate pass-by-reference in older versions of Perl. While it
+still works fine in modern versions, the new reference mechanism is
+generally easier to work with. See below.]
+
+Sometimes you don't want to pass the value of an array to a subroutine
+but rather the name of it, so that the subroutine can modify the global
+copy of it rather than working with a local copy. In perl you can
+refer to all objects of a particular name by prefixing the name
+with a star: C<*foo>. This is often known as a "typeglob", because the
+star on the front can be thought of as a wildcard match for all the
+funny prefix characters on variables and subroutines and such.
+
+When evaluated, the typeglob produces a scalar value that represents
+all the objects of that name, including any filehandle, format, or
+subroutine. When assigned to, it causes the name mentioned to refer to
+whatever "C<*>" value was assigned to it. Example:
+
+ sub doubleary {
+ local(*someary) = @_;
+ foreach $elem (@someary) {
+ $elem *= 2;
+ }
+ }
+ doubleary(*foo);
+ doubleary(*bar);
+
+Note that scalars are already passed by reference, so you can modify
+scalar arguments without using this mechanism by referring explicitly
+to C<$_[0]> etc. You can modify all the elements of an array by passing
+all the elements as scalars, but you have to use the C<*> mechanism (or
+the equivalent reference mechanism) to C<push>, C<pop>, or change the size of
+an array. It will certainly be faster to pass the typeglob (or reference).
+
+Even if you don't want to modify an array, this mechanism is useful for
+passing multiple arrays in a single LIST, because normally the LIST
+mechanism will merge all the array values so that you can't extract out
+the individual arrays. For more on typeglobs, see
+L<perldata/"Typeglobs and Filehandles">.
+
+=head2 When to Still Use local()
+
+Despite the existence of C<my()>, there are still three places where the
+C<local()> operator still shines. In fact, in these three places, you
+I<must> use C<local> instead of C<my>.
+
+=over
+
+=item 1. You need to give a global variable a temporary value, especially C<$_>.
+
+The global variables, like C<@ARGV> or the punctuation variables, must be
+C<local>ized with C<local()>. This block reads in F</etc/motd>, and splits
+it up into chunks separated by lines of equal signs, which are placed
+in C<@Fields>.
+
+ {
+ local @ARGV = ("/etc/motd");
+ local $/ = undef;
+ local $_ = <>;
+ @Fields = split /^\s*=+\s*$/;
+ }
+
+It particular, it's important to C<local>ize C<$_> in any routine that assigns
+to it. Look out for implicit assignments in C<while> conditionals.
+
+=item 2. You need to create a local file or directory handle or a local function.
+
+A function that needs a filehandle of its own must use C<local()> uses
+C<local()> on complete typeglob. This can be used to create new symbol
+table entries:
+
+ sub ioqueue {
+ local (*READER, *WRITER); # not my!
+ pipe (READER, WRITER); or die "pipe: $!";
+ return (*READER, *WRITER);
+ }
+ ($head, $tail) = ioqueue();
+
+See the Symbol module for a way to create anonymous symbol table
+entries.
+
+Because assignment of a reference to a typeglob creates an alias, this
+can be used to create what is effectively a local function, or at least,
+a local alias.
+
+ {
+ local *grow = \&shrink; # only until this block exists
+ grow(); # really calls shrink()
+ move(); # if move() grow()s, it shrink()s too
+ }
+ grow(); # get the real grow() again
+
+See L<perlref/"Function Templates"> for more about manipulating
+functions by name in this way.
+
+=item 3. You want to temporarily change just one element of an array or hash.
+
+You can C<local>ize just one element of an aggregate. Usually this
+is done on dynamics:
+
+ {
+ local $SIG{INT} = 'IGNORE';
+ funct(); # uninterruptible
+ }
+ # interruptibility automatically restored here
+
+But it also works on lexically declared aggregates. Prior to 5.005,
+this operation could on occasion misbehave.
+
+=back
+
+=head2 Pass by Reference
+
+If you want to pass more than one array or hash into a function--or
+return them from it--and have them maintain their integrity, then
+you're going to have to use an explicit pass-by-reference. Before you
+do that, you need to understand references as detailed in L<perlref>.
+This section may not make much sense to you otherwise.
+
+Here are a few simple examples. First, let's pass in several
+arrays to a function and have it C<pop> all of then, return a new
+list of all their former last elements:
+
+ @tailings = popmany ( \@a, \@b, \@c, \@d );
+
+ sub popmany {
+ my $aref;
+ my @retlist = ();
+ foreach $aref ( @_ ) {
+ push @retlist, pop @$aref;
+ }
+ return @retlist;
+ }
+
+Here's how you might write a function that returns a
+list of keys occurring in all the hashes passed to it:
+
+ @common = inter( \%foo, \%bar, \%joe );
+ sub inter {
+ my ($k, $href, %seen); # locals
+ foreach $href (@_) {
+ while ( $k = each %$href ) {
+ $seen{$k}++;
+ }
+ }
+ return grep { $seen{$_} == @_ } keys %seen;
+ }
+
+So far, we're using just the normal list return mechanism.
+What happens if you want to pass or return a hash? Well,
+if you're using only one of them, or you don't mind them
+concatenating, then the normal calling convention is ok, although
+a little expensive.
+
+Where people get into trouble is here:
+
+ (@a, @b) = func(@c, @d);
+or
+ (%a, %b) = func(%c, %d);
+
+That syntax simply won't work. It sets just C<@a> or C<%a> and clears the C<@b> or
+C<%b>. Plus the function didn't get passed into two separate arrays or
+hashes: it got one long list in C<@_>, as always.
+
+If you can arrange for everyone to deal with this through references, it's
+cleaner code, although not so nice to look at. Here's a function that
+takes two array references as arguments, returning the two array elements
+in order of how many elements they have in them:
+
+ ($aref, $bref) = func(\@c, \@d);
+ print "@$aref has more than @$bref\n";
+ sub func {
+ my ($cref, $dref) = @_;
+ if (@$cref > @$dref) {
+ return ($cref, $dref);
+ } else {
+ return ($dref, $cref);
+ }
+ }
+
+It turns out that you can actually do this also:
+
+ (*a, *b) = func(\@c, \@d);
+ print "@a has more than @b\n";
+ sub func {
+ local (*c, *d) = @_;
+ if (@c > @d) {
+ return (\@c, \@d);
+ } else {
+ return (\@d, \@c);
+ }
+ }
+
+Here we're using the typeglobs to do symbol table aliasing. It's
+a tad subtle, though, and also won't work if you're using C<my()>
+variables, because only globals (well, and C<local()>s) are in the symbol table.
+
+If you're passing around filehandles, you could usually just use the bare
+typeglob, like C<*STDOUT>, but typeglobs references would be better because
+they'll still work properly under S<C<use strict 'refs'>>. For example:
+
+ splutter(\*STDOUT);
+ sub splutter {
+ my $fh = shift;
+ print $fh "her um well a hmmm\n";
+ }
+
+ $rec = get_rec(\*STDIN);
+ sub get_rec {
+ my $fh = shift;
+ return scalar <$fh>;
+ }
+
+Another way to do this is using C<*HANDLE{IO}>, see L<perlref> for usage
+and caveats.
+
+If you're planning on generating new filehandles, you could do this:
+
+ sub openit {
+ my $name = shift;
+ local *FH;
+ return open (FH, $path) ? *FH : undef;
+ }
+
+Although that will actually produce a small memory leak. See the bottom
+of L<perlfunc/open()> for a somewhat cleaner way using the C<IO::Handle>
+package.
+
+=head2 Prototypes
+
+As of the 5.002 release of perl, if you declare
+
+ sub mypush (\@@)
+
+then C<mypush()> takes arguments exactly like C<push()> does. The declaration
+of the function to be called must be visible at compile time. The prototype
+affects only the interpretation of new-style calls to the function, where
+new-style is defined as not using the C<&> character. In other words,
+if you call it like a builtin function, then it behaves like a builtin
+function. If you call it like an old-fashioned subroutine, then it
+behaves like an old-fashioned subroutine. It naturally falls out from
+this rule that prototypes have no influence on subroutine references
+like C<\&foo> or on indirect subroutine calls like C<&{$subref}>.
+
+Method calls are not influenced by prototypes either, because the
+function to be called is indeterminate at compile time, because it depends
+on inheritance.
+
+Because the intent is primarily to let you define subroutines that work
+like builtin commands, here are the prototypes for some other functions
+that parse almost exactly like the corresponding builtins.
+
+ Declared as Called as
+
+ sub mylink ($$) mylink $old, $new
+ sub myvec ($$$) myvec $var, $offset, 1
+ sub myindex ($$;$) myindex &getstring, "substr"
+ sub mysyswrite ($$$;$) mysyswrite $buf, 0, length($buf) - $off, $off
+ sub myreverse (@) myreverse $a, $b, $c
+ sub myjoin ($@) myjoin ":", $a, $b, $c
+ sub mypop (\@) mypop @array
+ sub mysplice (\@$$@) mysplice @array, @array, 0, @pushme
+ sub mykeys (\%) mykeys %{$hashref}
+ sub myopen (*;$) myopen HANDLE, $name
+ sub mypipe (**) mypipe READHANDLE, WRITEHANDLE
+ sub mygrep (&@) mygrep { /foo/ } $a, $b, $c
+ sub myrand ($) myrand 42
+ sub mytime () mytime
+
+Any backslashed prototype character represents an actual argument
+that absolutely must start with that character. The value passed
+to the subroutine (as part of C<@_>) will be a reference to the
+actual argument given in the subroutine call, obtained by applying
+C<\> to that argument.
+
+Unbackslashed prototype characters have special meanings. Any
+unbackslashed C<@> or C<%> eats all the rest of the arguments, and forces
+list context. An argument represented by C<$> forces scalar context. An
+C<&> requires an anonymous subroutine, which, if passed as the first
+argument, does not require the "C<sub>" keyword or a subsequent comma. A
+C<*> does whatever it has to do to turn the argument into a reference to a
+symbol table entry.
+
+A semicolon separates mandatory arguments from optional arguments.
+(It is redundant before C<@> or C<%>.)
+
+Note how the last three examples above are treated specially by the parser.
+C<mygrep()> is parsed as a true list operator, C<myrand()> is parsed as a
+true unary operator with unary precedence the same as C<rand()>, and
+C<mytime()> is truly without arguments, just like C<time()>. That is, if you
+say
+
+ mytime +2;
+
+you'll get C<mytime() + 2>, not C<mytime(2)>, which is how it would be parsed
+without the prototype.
+
+The interesting thing about C<&> is that you can generate new syntax with it:
+
+ sub try (&@) {
+ my($try,$catch) = @_;
+ eval { &$try };
+ if ($@) {
+ local $_ = $@;
+ &$catch;
+ }
+ }
+ sub catch (&) { $_[0] }
+
+ try {
+ die "phooey";
+ } catch {
+ /phooey/ and print "unphooey\n";
+ };
+
+That prints C<"unphooey">. (Yes, there are still unresolved
+issues having to do with the visibility of C<@_>. I'm ignoring that
+question for the moment. (But note that if we make C<@_> lexically
+scoped, those anonymous subroutines can act like closures... (Gee,
+is this sounding a little Lispish? (Never mind.))))
+
+And here's a reimplementation of C<grep>:
+
+ sub mygrep (&@) {
+ my $code = shift;
+ my @result;
+ foreach $_ (@_) {
+ push(@result, $_) if &$code;
+ }
+ @result;
+ }
+
+Some folks would prefer full alphanumeric prototypes. Alphanumerics have
+been intentionally left out of prototypes for the express purpose of
+someday in the future adding named, formal parameters. The current
+mechanism's main goal is to let module writers provide better diagnostics
+for module users. Larry feels the notation quite understandable to Perl
+programmers, and that it will not intrude greatly upon the meat of the
+module, nor make it harder to read. The line noise is visually
+encapsulated into a small pill that's easy to swallow.
+
+It's probably best to prototype new functions, not retrofit prototyping
+into older ones. That's because you must be especially careful about
+silent impositions of differing list versus scalar contexts. For example,
+if you decide that a function should take just one parameter, like this:
+
+ sub func ($) {
+ my $n = shift;
+ print "you gave me $n\n";
+ }
+
+and someone has been calling it with an array or expression
+returning a list:
+
+ func(@foo);
+ func( split /:/ );
+
+Then you've just supplied an automatic C<scalar()> in front of their
+argument, which can be more than a bit surprising. The old C<@foo>
+which used to hold one thing doesn't get passed in. Instead,
+the C<func()> now gets passed in C<1>, that is, the number of elements
+in C<@foo>. And the C<split()> gets called in a scalar context and
+starts scribbling on your C<@_> parameter list.
+
+This is all very powerful, of course, and should be used only in moderation
+to make the world a better place.
+
+=head2 Constant Functions
+
+Functions with a prototype of C<()> are potential candidates for
+inlining. If the result after optimization and constant folding is
+either a constant or a lexically-scoped scalar which has no other
+references, then it will be used in place of function calls made
+without C<&> or C<do>. Calls made using C<&> or C<do> are never
+inlined. (See F<constant.pm> for an easy way to declare most
+constants.)
+
+The following functions would all be inlined:
+
+ sub pi () { 3.14159 } # Not exact, but close.
+ sub PI () { 4 * atan2 1, 1 } # As good as it gets,
+ # and it's inlined, too!
+ sub ST_DEV () { 0 }
+ sub ST_INO () { 1 }
+
+ sub FLAG_FOO () { 1 << 8 }
+ sub FLAG_BAR () { 1 << 9 }
+ sub FLAG_MASK () { FLAG_FOO | FLAG_BAR }
+
+ sub OPT_BAZ () { not (0x1B58 & FLAG_MASK) }
+ sub BAZ_VAL () {
+ if (OPT_BAZ) {
+ return 23;
+ }
+ else {
+ return 42;
+ }
+ }
+
+ sub N () { int(BAZ_VAL) / 3 }
+ BEGIN {
+ my $prod = 1;
+ for (1..N) { $prod *= $_ }
+ sub N_FACTORIAL () { $prod }
+ }
+
+If you redefine a subroutine that was eligible for inlining, you'll get
+a mandatory warning. (You can use this warning to tell whether or not a
+particular subroutine is considered constant.) The warning is
+considered severe enough not to be optional because previously compiled
+invocations of the function will still be using the old value of the
+function. If you need to be able to redefine the subroutine you need to
+ensure that it isn't inlined, either by dropping the C<()> prototype
+(which changes the calling semantics, so beware) or by thwarting the
+inlining mechanism in some other way, such as
+
+ sub not_inlined () {
+ 23 if $];
+ }
+
+=head2 Overriding Builtin Functions
+
+Many builtin functions may be overridden, though this should be tried
+only occasionally and for good reason. Typically this might be
+done by a package attempting to emulate missing builtin functionality
+on a non-Unix system.
+
+Overriding may be done only by importing the name from a
+module--ordinary predeclaration isn't good enough. However, the
+C<subs> pragma (compiler directive) lets you, in effect, predeclare subs
+via the import syntax, and these names may then override the builtin ones:
+
+ use subs 'chdir', 'chroot', 'chmod', 'chown';
+ chdir $somewhere;
+ sub chdir { ... }
+
+To unambiguously refer to the builtin form, one may precede the
+builtin name with the special package qualifier C<CORE::>. For example,
+saying C<CORE::open()> will always refer to the builtin C<open()>, even
+if the current package has imported some other subroutine called
+C<&open()> from elsewhere.
+
+Library modules should not in general export builtin names like "C<open>"
+or "C<chdir>" as part of their default C<@EXPORT> list, because these may
+sneak into someone else's namespace and change the semantics unexpectedly.
+Instead, if the module adds the name to the C<@EXPORT_OK> list, then it's
+possible for a user to import the name explicitly, but not implicitly.
+That is, they could say
+
+ use Module 'open';
+
+and it would import the C<open> override, but if they said
+
+ use Module;
+
+they would get the default imports without the overrides.
+
+The foregoing mechanism for overriding builtins is restricted, quite
+deliberately, to the package that requests the import. There is a second
+method that is sometimes applicable when you wish to override a builtin
+everywhere, without regard to namespace boundaries. This is achieved by
+importing a sub into the special namespace C<CORE::GLOBAL::>. Here is an
+example that quite brazenly replaces the C<glob> operator with something
+that understands regular expressions.
+
+ package REGlob;
+ require Exporter;
+ @ISA = 'Exporter';
+ @EXPORT_OK = 'glob';
+
+ sub import {
+ my $pkg = shift;
+ return unless @_;
+ my $sym = shift;
+ my $where = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0));
+ $pkg->export($where, $sym, @_);
+ }
+
+ sub glob {
+ my $pat = shift;
+ my @got;
+ local(*D);
+ if (opendir D, '.') { @got = grep /$pat/, readdir D; closedir D; }
+ @got;
+ }
+ 1;
+
+And here's how it could be (ab)used:
+
+ #use REGlob 'GLOBAL_glob'; # override glob() in ALL namespaces
+ package Foo;
+ use REGlob 'glob'; # override glob() in Foo:: only
+ print for <^[a-z_]+\.pm\$>; # show all pragmatic modules
+
+Note that the initial comment shows a contrived, even dangerous example.
+By overriding C<glob> globally, you would be forcing the new (and
+subversive) behavior for the C<glob> operator for B<every> namespace,
+without the complete cognizance or cooperation of the modules that own
+those namespaces. Naturally, this should be done with extreme caution--if
+it must be done at all.
+
+The C<REGlob> example above does not implement all the support needed to
+cleanly override perl's C<glob> operator. The builtin C<glob> has
+different behaviors depending on whether it appears in a scalar or list
+context, but our C<REGlob> doesn't. Indeed, many perl builtins have such
+context sensitive behaviors, and these must be adequately supported by
+a properly written override. For a fully functional example of overriding
+C<glob>, study the implementation of C<File::DosGlob> in the standard
+library.
+
+
+=head2 Autoloading
+
+If you call a subroutine that is undefined, you would ordinarily get an
+immediate fatal error complaining that the subroutine doesn't exist.
+(Likewise for subroutines being used as methods, when the method
+doesn't exist in any base class of the class package.) If,
+however, there is an C<AUTOLOAD> subroutine defined in the package or
+packages that were searched for the original subroutine, then that
+C<AUTOLOAD> subroutine is called with the arguments that would have been
+passed to the original subroutine. The fully qualified name of the
+original subroutine magically appears in the C<$AUTOLOAD> variable in the
+same package as the C<AUTOLOAD> routine. The name is not passed as an
+ordinary argument because, er, well, just because, that's why...
+
+Most C<AUTOLOAD> routines will load in a definition for the subroutine in
+question using eval, and then execute that subroutine using a special
+form of "goto" that erases the stack frame of the C<AUTOLOAD> routine
+without a trace. (See the standard C<AutoLoader> module, for example.)
+But an C<AUTOLOAD> routine can also just emulate the routine and never
+define it. For example, let's pretend that a function that wasn't defined
+should just call C<system()> with those arguments. All you'd do is this:
+
+ sub AUTOLOAD {
+ my $program = $AUTOLOAD;
+ $program =~ s/.*:://;
+ system($program, @_);
+ }
+ date();
+ who('am', 'i');
+ ls('-l');
+
+In fact, if you predeclare the functions you want to call that way, you don't
+even need the parentheses:
+
+ use subs qw(date who ls);
+ date;
+ who "am", "i";
+ ls -l;
+
+A more complete example of this is the standard Shell module, which
+can treat undefined subroutine calls as calls to Unix programs.
+
+Mechanisms are available for modules writers to help split the modules
+up into autoloadable files. See the standard AutoLoader module
+described in L<AutoLoader> and in L<AutoSplit>, the standard
+SelfLoader modules in L<SelfLoader>, and the document on adding C
+functions to perl code in L<perlxs>.
+
+=head1 SEE ALSO
+
+See L<perlref> for more about references and closures. See L<perlxs> if
+you'd like to learn about calling C subroutines from perl. See L<perlmod>
+to learn about bundling up your functions in separate files.
diff --git a/contrib/perl5/pod/perlsyn.pod b/contrib/perl5/pod/perlsyn.pod
new file mode 100644
index 000000000000..832123507be8
--- /dev/null
+++ b/contrib/perl5/pod/perlsyn.pod
@@ -0,0 +1,617 @@
+=head1 NAME
+
+perlsyn - Perl syntax
+
+=head1 DESCRIPTION
+
+A Perl script consists of a sequence of declarations and statements.
+The only things that need to be declared in Perl are report formats
+and subroutines. See the sections below for more information on those
+declarations. All uninitialized user-created objects are assumed to
+start with a C<null> or C<0> value until they are defined by some explicit
+operation such as assignment. (Though you can get warnings about the
+use of undefined values if you like.) The sequence of statements is
+executed just once, unlike in B<sed> and B<awk> scripts, where the
+sequence of statements is executed for each input line. While this means
+that you must explicitly loop over the lines of your input file (or
+files), it also means you have much more control over which files and
+which lines you look at. (Actually, I'm lying--it is possible to do an
+implicit loop with either the B<-n> or B<-p> switch. It's just not the
+mandatory default like it is in B<sed> and B<awk>.)
+
+=head2 Declarations
+
+Perl is, for the most part, a free-form language. (The only
+exception to this is format declarations, for obvious reasons.) Comments
+are indicated by the C<"#"> character, and extend to the end of the line. If
+you attempt to use C</* */> C-style comments, it will be interpreted
+either as division or pattern matching, depending on the context, and C++
+C<//> comments just look like a null regular expression, so don't do
+that.
+
+A declaration can be put anywhere a statement can, but has no effect on
+the execution of the primary sequence of statements--declarations all
+take effect at compile time. Typically all the declarations are put at
+the beginning or the end of the script. However, if you're using
+lexically-scoped private variables created with C<my()>, you'll have to make sure
+your format or subroutine definition is within the same block scope
+as the my if you expect to be able to access those private variables.
+
+Declaring a subroutine allows a subroutine name to be used as if it were a
+list operator from that point forward in the program. You can declare a
+subroutine without defining it by saying C<sub name>, thus:
+
+ sub myname;
+ $me = myname $0 or die "can't get myname";
+
+Note that it functions as a list operator, not as a unary operator; so
+be careful to use C<or> instead of C<||> in this case. However, if
+you were to declare the subroutine as C<sub myname ($)>, then
+C<myname> would function as a unary operator, so either C<or> or
+C<||> would work.
+
+Subroutines declarations can also be loaded up with the C<require> statement
+or both loaded and imported into your namespace with a C<use> statement.
+See L<perlmod> for details on this.
+
+A statement sequence may contain declarations of lexically-scoped
+variables, but apart from declaring a variable name, the declaration acts
+like an ordinary statement, and is elaborated within the sequence of
+statements as if it were an ordinary statement. That means it actually
+has both compile-time and run-time effects.
+
+=head2 Simple statements
+
+The only kind of simple statement is an expression evaluated for its
+side effects. Every simple statement must be terminated with a
+semicolon, unless it is the final statement in a block, in which case
+the semicolon is optional. (A semicolon is still encouraged there if the
+block takes up more than one line, because you may eventually add another line.)
+Note that there are some operators like C<eval {}> and C<do {}> that look
+like compound statements, but aren't (they're just TERMs in an expression),
+and thus need an explicit termination if used as the last item in a statement.
+
+Any simple statement may optionally be followed by a I<SINGLE> modifier,
+just before the terminating semicolon (or block ending). The possible
+modifiers are:
+
+ if EXPR
+ unless EXPR
+ while EXPR
+ until EXPR
+ foreach EXPR
+
+The C<if> and C<unless> modifiers have the expected semantics,
+presuming you're a speaker of English. The C<foreach> modifier is an
+iterator: For each value in EXPR, it aliases C<$_> to the value and
+executes the statement. The C<while> and C<until> modifiers have the
+usual "C<while> loop" semantics (conditional evaluated first), except
+when applied to a C<do>-BLOCK (or to the now-deprecated C<do>-SUBROUTINE
+statement), in which case the block executes once before the
+conditional is evaluated. This is so that you can write loops like:
+
+ do {
+ $line = <STDIN>;
+ ...
+ } until $line eq ".\n";
+
+See L<perlfunc/do>. Note also that the loop control statements described
+later will I<NOT> work in this construct, because modifiers don't take
+loop labels. Sorry. You can always put another block inside of it
+(for C<next>) or around it (for C<last>) to do that sort of thing.
+For C<next>, just double the braces:
+
+ do {{
+ next if $x == $y;
+ # do something here
+ }} until $x++ > $z;
+
+For C<last>, you have to be more elaborate:
+
+ LOOP: {
+ do {
+ last if $x = $y**2;
+ # do something here
+ } while $x++ <= $z;
+ }
+
+=head2 Compound statements
+
+In Perl, a sequence of statements that defines a scope is called a block.
+Sometimes a block is delimited by the file containing it (in the case
+of a required file, or the program as a whole), and sometimes a block
+is delimited by the extent of a string (in the case of an eval).
+
+But generally, a block is delimited by curly brackets, also known as braces.
+We will call this syntactic construct a BLOCK.
+
+The following compound statements may be used to control flow:
+
+ if (EXPR) BLOCK
+ if (EXPR) BLOCK else BLOCK
+ if (EXPR) BLOCK elsif (EXPR) BLOCK ... else BLOCK
+ LABEL while (EXPR) BLOCK
+ LABEL while (EXPR) BLOCK continue BLOCK
+ LABEL for (EXPR; EXPR; EXPR) BLOCK
+ LABEL foreach VAR (LIST) BLOCK
+ LABEL BLOCK continue BLOCK
+
+Note that, unlike C and Pascal, these are defined in terms of BLOCKs,
+not statements. This means that the curly brackets are I<required>--no
+dangling statements allowed. If you want to write conditionals without
+curly brackets there are several other ways to do it. The following
+all do the same thing:
+
+ if (!open(FOO)) { die "Can't open $FOO: $!"; }
+ die "Can't open $FOO: $!" unless open(FOO);
+ open(FOO) or die "Can't open $FOO: $!"; # FOO or bust!
+ open(FOO) ? 'hi mom' : die "Can't open $FOO: $!";
+ # a bit exotic, that last one
+
+The C<if> statement is straightforward. Because BLOCKs are always
+bounded by curly brackets, there is never any ambiguity about which
+C<if> an C<else> goes with. If you use C<unless> in place of C<if>,
+the sense of the test is reversed.
+
+The C<while> statement executes the block as long as the expression is
+true (does not evaluate to the null string (C<"">) or C<0> or C<"0")>. The LABEL is
+optional, and if present, consists of an identifier followed by a colon.
+The LABEL identifies the loop for the loop control statements C<next>,
+C<last>, and C<redo>. If the LABEL is omitted, the loop control statement
+refers to the innermost enclosing loop. This may include dynamically
+looking back your call-stack at run time to find the LABEL. Such
+desperate behavior triggers a warning if you use the B<-w> flag.
+
+If there is a C<continue> BLOCK, it is always executed just before the
+conditional is about to be evaluated again, just like the third part of a
+C<for> loop in C. Thus it can be used to increment a loop variable, even
+when the loop has been continued via the C<next> statement (which is
+similar to the C C<continue> statement).
+
+=head2 Loop Control
+
+The C<next> command is like the C<continue> statement in C; it starts
+the next iteration of the loop:
+
+ LINE: while (<STDIN>) {
+ next LINE if /^#/; # discard comments
+ ...
+ }
+
+The C<last> command is like the C<break> statement in C (as used in
+loops); it immediately exits the loop in question. The
+C<continue> block, if any, is not executed:
+
+ LINE: while (<STDIN>) {
+ last LINE if /^$/; # exit when done with header
+ ...
+ }
+
+The C<redo> command restarts the loop block without evaluating the
+conditional again. The C<continue> block, if any, is I<not> executed.
+This command is normally used by programs that want to lie to themselves
+about what was just input.
+
+For example, when processing a file like F</etc/termcap>.
+If your input lines might end in backslashes to indicate continuation, you
+want to skip ahead and get the next record.
+
+ while (<>) {
+ chomp;
+ if (s/\\$//) {
+ $_ .= <>;
+ redo unless eof();
+ }
+ # now process $_
+ }
+
+which is Perl short-hand for the more explicitly written version:
+
+ LINE: while (defined($line = <ARGV>)) {
+ chomp($line);
+ if ($line =~ s/\\$//) {
+ $line .= <ARGV>;
+ redo LINE unless eof(); # not eof(ARGV)!
+ }
+ # now process $line
+ }
+
+Note that if there were a C<continue> block on the above code, it would get
+executed even on discarded lines. This is often used to reset line counters
+or C<?pat?> one-time matches.
+
+ # inspired by :1,$g/fred/s//WILMA/
+ while (<>) {
+ ?(fred)? && s//WILMA $1 WILMA/;
+ ?(barney)? && s//BETTY $1 BETTY/;
+ ?(homer)? && s//MARGE $1 MARGE/;
+ } continue {
+ print "$ARGV $.: $_";
+ close ARGV if eof(); # reset $.
+ reset if eof(); # reset ?pat?
+ }
+
+If the word C<while> is replaced by the word C<until>, the sense of the
+test is reversed, but the conditional is still tested before the first
+iteration.
+
+The loop control statements don't work in an C<if> or C<unless>, since
+they aren't loops. You can double the braces to make them such, though.
+
+ if (/pattern/) {{
+ next if /fred/;
+ next if /barney/;
+ # so something here
+ }}
+
+The form C<while/if BLOCK BLOCK>, available in Perl 4, is no longer
+available. Replace any occurrence of C<if BLOCK> by C<if (do BLOCK)>.
+
+=head2 For Loops
+
+Perl's C-style C<for> loop works exactly like the corresponding C<while> loop;
+that means that this:
+
+ for ($i = 1; $i < 10; $i++) {
+ ...
+ }
+
+is the same as this:
+
+ $i = 1;
+ while ($i < 10) {
+ ...
+ } continue {
+ $i++;
+ }
+
+(There is one minor difference: The first form implies a lexical scope
+for variables declared with C<my> in the initialization expression.)
+
+Besides the normal array index looping, C<for> can lend itself
+to many other interesting applications. Here's one that avoids the
+problem you get into if you explicitly test for end-of-file on
+an interactive file descriptor causing your program to appear to
+hang.
+
+ $on_a_tty = -t STDIN && -t STDOUT;
+ sub prompt { print "yes? " if $on_a_tty }
+ for ( prompt(); <STDIN>; prompt() ) {
+ # do something
+ }
+
+=head2 Foreach Loops
+
+The C<foreach> loop iterates over a normal list value and sets the
+variable VAR to be each element of the list in turn. If the variable
+is preceded with the keyword C<my>, then it is lexically scoped, and
+is therefore visible only within the loop. Otherwise, the variable is
+implicitly local to the loop and regains its former value upon exiting
+the loop. If the variable was previously declared with C<my>, it uses
+that variable instead of the global one, but it's still localized to
+the loop. (Note that a lexically scoped variable can cause problems
+if you have subroutine or format declarations within the loop which
+refer to it.)
+
+The C<foreach> keyword is actually a synonym for the C<for> keyword, so
+you can use C<foreach> for readability or C<for> for brevity. (Or because
+the Bourne shell is more familiar to you than I<csh>, so writing C<for>
+comes more naturally.) If VAR is omitted, C<$_> is set to each value.
+If any element of LIST is an lvalue, you can modify it by modifying VAR
+inside the loop. That's because the C<foreach> loop index variable is
+an implicit alias for each item in the list that you're looping over.
+
+If any part of LIST is an array, C<foreach> will get very confused if
+you add or remove elements within the loop body, for example with
+C<splice>. So don't do that.
+
+C<foreach> probably won't do what you expect if VAR is a tied or other
+special variable. Don't do that either.
+
+Examples:
+
+ for (@ary) { s/foo/bar/ }
+
+ foreach my $elem (@elements) {
+ $elem *= 2;
+ }
+
+ for $count (10,9,8,7,6,5,4,3,2,1,'BOOM') {
+ print $count, "\n"; sleep(1);
+ }
+
+ for (1..15) { print "Merry Christmas\n"; }
+
+ foreach $item (split(/:[\\\n:]*/, $ENV{TERMCAP})) {
+ print "Item: $item\n";
+ }
+
+Here's how a C programmer might code up a particular algorithm in Perl:
+
+ for (my $i = 0; $i < @ary1; $i++) {
+ for (my $j = 0; $j < @ary2; $j++) {
+ if ($ary1[$i] > $ary2[$j]) {
+ last; # can't go to outer :-(
+ }
+ $ary1[$i] += $ary2[$j];
+ }
+ # this is where that last takes me
+ }
+
+Whereas here's how a Perl programmer more comfortable with the idiom might
+do it:
+
+ OUTER: foreach my $wid (@ary1) {
+ INNER: foreach my $jet (@ary2) {
+ next OUTER if $wid > $jet;
+ $wid += $jet;
+ }
+ }
+
+See how much easier this is? It's cleaner, safer, and faster. It's
+cleaner because it's less noisy. It's safer because if code gets added
+between the inner and outer loops later on, the new code won't be
+accidentally executed. The C<next> explicitly iterates the other loop
+rather than merely terminating the inner one. And it's faster because
+Perl executes a C<foreach> statement more rapidly than it would the
+equivalent C<for> loop.
+
+=head2 Basic BLOCKs and Switch Statements
+
+A BLOCK by itself (labeled or not) is semantically equivalent to a
+loop that executes once. Thus you can use any of the loop control
+statements in it to leave or restart the block. (Note that this is
+I<NOT> true in C<eval{}>, C<sub{}>, or contrary to popular belief
+C<do{}> blocks, which do I<NOT> count as loops.) The C<continue>
+block is optional.
+
+The BLOCK construct is particularly nice for doing case
+structures.
+
+ SWITCH: {
+ if (/^abc/) { $abc = 1; last SWITCH; }
+ if (/^def/) { $def = 1; last SWITCH; }
+ if (/^xyz/) { $xyz = 1; last SWITCH; }
+ $nothing = 1;
+ }
+
+There is no official C<switch> statement in Perl, because there are
+already several ways to write the equivalent. In addition to the
+above, you could write
+
+ SWITCH: {
+ $abc = 1, last SWITCH if /^abc/;
+ $def = 1, last SWITCH if /^def/;
+ $xyz = 1, last SWITCH if /^xyz/;
+ $nothing = 1;
+ }
+
+(That's actually not as strange as it looks once you realize that you can
+use loop control "operators" within an expression, That's just the normal
+C comma operator.)
+
+or
+
+ SWITCH: {
+ /^abc/ && do { $abc = 1; last SWITCH; };
+ /^def/ && do { $def = 1; last SWITCH; };
+ /^xyz/ && do { $xyz = 1; last SWITCH; };
+ $nothing = 1;
+ }
+
+or formatted so it stands out more as a "proper" C<switch> statement:
+
+ SWITCH: {
+ /^abc/ && do {
+ $abc = 1;
+ last SWITCH;
+ };
+
+ /^def/ && do {
+ $def = 1;
+ last SWITCH;
+ };
+
+ /^xyz/ && do {
+ $xyz = 1;
+ last SWITCH;
+ };
+ $nothing = 1;
+ }
+
+or
+
+ SWITCH: {
+ /^abc/ and $abc = 1, last SWITCH;
+ /^def/ and $def = 1, last SWITCH;
+ /^xyz/ and $xyz = 1, last SWITCH;
+ $nothing = 1;
+ }
+
+or even, horrors,
+
+ if (/^abc/)
+ { $abc = 1 }
+ elsif (/^def/)
+ { $def = 1 }
+ elsif (/^xyz/)
+ { $xyz = 1 }
+ else
+ { $nothing = 1 }
+
+A common idiom for a C<switch> statement is to use C<foreach>'s aliasing to make
+a temporary assignment to C<$_> for convenient matching:
+
+ SWITCH: for ($where) {
+ /In Card Names/ && do { push @flags, '-e'; last; };
+ /Anywhere/ && do { push @flags, '-h'; last; };
+ /In Rulings/ && do { last; };
+ die "unknown value for form variable where: `$where'";
+ }
+
+Another interesting approach to a switch statement is arrange
+for a C<do> block to return the proper value:
+
+ $amode = do {
+ if ($flag & O_RDONLY) { "r" } # XXX: isn't this 0?
+ elsif ($flag & O_WRONLY) { ($flag & O_APPEND) ? "a" : "w" }
+ elsif ($flag & O_RDWR) {
+ if ($flag & O_CREAT) { "w+" }
+ else { ($flag & O_APPEND) ? "a+" : "r+" }
+ }
+ };
+
+Or
+
+ print do {
+ ($flags & O_WRONLY) ? "write-only" :
+ ($flags & O_RDWR) ? "read-write" :
+ "read-only";
+ };
+
+Or if you are certainly that all the C<&&> clauses are true, you can use
+something like this, which "switches" on the value of the
+C<HTTP_USER_AGENT> envariable.
+
+ #!/usr/bin/perl
+ # pick out jargon file page based on browser
+ $dir = 'http://www.wins.uva.nl/~mes/jargon';
+ for ($ENV{HTTP_USER_AGENT}) {
+ $page = /Mac/ && 'm/Macintrash.html'
+ || /Win(dows )?NT/ && 'e/evilandrude.html'
+ || /Win|MSIE|WebTV/ && 'm/MicroslothWindows.html'
+ || /Linux/ && 'l/Linux.html'
+ || /HP-UX/ && 'h/HP-SUX.html'
+ || /SunOS/ && 's/ScumOS.html'
+ || 'a/AppendixB.html';
+ }
+ print "Location: $dir/$page\015\012\015\012";
+
+That kind of switch statement only works when you know the C<&&> clauses
+will be true. If you don't, the previous C<?:> example should be used.
+
+You might also consider writing a hash instead of synthesizing a C<switch>
+statement.
+
+=head2 Goto
+
+Although not for the faint of heart, Perl does support a C<goto> statement.
+A loop's LABEL is not actually a valid target for a C<goto>;
+it's just the name of the loop. There are three forms: C<goto>-LABEL,
+C<goto>-EXPR, and C<goto>-&NAME.
+
+The C<goto>-LABEL form finds the statement labeled with LABEL and resumes
+execution there. It may not be used to go into any construct that
+requires initialization, such as a subroutine or a C<foreach> loop. It
+also can't be used to go into a construct that is optimized away. It
+can be used to go almost anywhere else within the dynamic scope,
+including out of subroutines, but it's usually better to use some other
+construct such as C<last> or C<die>. The author of Perl has never felt the
+need to use this form of C<goto> (in Perl, that is--C is another matter).
+
+The C<goto>-EXPR form expects a label name, whose scope will be resolved
+dynamically. This allows for computed C<goto>s per FORTRAN, but isn't
+necessarily recommended if you're optimizing for maintainability:
+
+ goto ("FOO", "BAR", "GLARCH")[$i];
+
+The C<goto>-&NAME form is highly magical, and substitutes a call to the
+named subroutine for the currently running subroutine. This is used by
+C<AUTOLOAD()> subroutines that wish to load another subroutine and then
+pretend that the other subroutine had been called in the first place
+(except that any modifications to C<@_> in the current subroutine are
+propagated to the other subroutine.) After the C<goto>, not even C<caller()>
+will be able to tell that this routine was called first.
+
+In almost all cases like this, it's usually a far, far better idea to use the
+structured control flow mechanisms of C<next>, C<last>, or C<redo> instead of
+resorting to a C<goto>. For certain applications, the catch and throw pair of
+C<eval{}> and die() for exception processing can also be a prudent approach.
+
+=head2 PODs: Embedded Documentation
+
+Perl has a mechanism for intermixing documentation with source code.
+While it's expecting the beginning of a new statement, if the compiler
+encounters a line that begins with an equal sign and a word, like this
+
+ =head1 Here There Be Pods!
+
+Then that text and all remaining text up through and including a line
+beginning with C<=cut> will be ignored. The format of the intervening
+text is described in L<perlpod>.
+
+This allows you to intermix your source code
+and your documentation text freely, as in
+
+ =item snazzle($)
+
+ The snazzle() function will behave in the most spectacular
+ form that you can possibly imagine, not even excepting
+ cybernetic pyrotechnics.
+
+ =cut back to the compiler, nuff of this pod stuff!
+
+ sub snazzle($) {
+ my $thingie = shift;
+ .........
+ }
+
+Note that pod translators should look at only paragraphs beginning
+with a pod directive (it makes parsing easier), whereas the compiler
+actually knows to look for pod escapes even in the middle of a
+paragraph. This means that the following secret stuff will be
+ignored by both the compiler and the translators.
+
+ $a=3;
+ =secret stuff
+ warn "Neither POD nor CODE!?"
+ =cut back
+ print "got $a\n";
+
+You probably shouldn't rely upon the C<warn()> being podded out forever.
+Not all pod translators are well-behaved in this regard, and perhaps
+the compiler will become pickier.
+
+One may also use pod directives to quickly comment out a section
+of code.
+
+=head2 Plain Old Comments (Not!)
+
+Much like the C preprocessor, Perl can process line directives. Using
+this, one can control Perl's idea of filenames and line numbers in
+error or warning messages (especially for strings that are processed
+with C<eval()>). The syntax for this mechanism is the same as for most
+C preprocessors: it matches the regular expression
+C</^#\s*line\s+(\d+)\s*(?:\s"([^"]*)")?/> with C<$1> being the line
+number for the next line, and C<$2> being the optional filename
+(specified within quotes).
+
+Here are some examples that you should be able to type into your command
+shell:
+
+ % perl
+ # line 200 "bzzzt"
+ # the `#' on the previous line must be the first char on line
+ die 'foo';
+ __END__
+ foo at bzzzt line 201.
+
+ % perl
+ # line 200 "bzzzt"
+ eval qq[\n#line 2001 ""\ndie 'foo']; print $@;
+ __END__
+ foo at - line 2001.
+
+ % perl
+ eval qq[\n#line 200 "foo bar"\ndie 'foo']; print $@;
+ __END__
+ foo at foo bar line 200.
+
+ % perl
+ # line 345 "goop"
+ eval "\n#line " . __LINE__ . ' "' . __FILE__ ."\"\ndie 'foo'";
+ print $@;
+ __END__
+ foo at goop line 345.
+
+=cut
diff --git a/contrib/perl5/pod/perltie.pod b/contrib/perl5/pod/perltie.pod
new file mode 100644
index 000000000000..cae0a15a5491
--- /dev/null
+++ b/contrib/perl5/pod/perltie.pod
@@ -0,0 +1,876 @@
+=head1 NAME
+
+perltie - how to hide an object class in a simple variable
+
+=head1 SYNOPSIS
+
+ tie VARIABLE, CLASSNAME, LIST
+
+ $object = tied VARIABLE
+
+ untie VARIABLE
+
+=head1 DESCRIPTION
+
+Prior to release 5.0 of Perl, a programmer could use dbmopen()
+to connect an on-disk database in the standard Unix dbm(3x)
+format magically to a %HASH in their program. However, their Perl was either
+built with one particular dbm library or another, but not both, and
+you couldn't extend this mechanism to other packages or types of variables.
+
+Now you can.
+
+The tie() function binds a variable to a class (package) that will provide
+the implementation for access methods for that variable. Once this magic
+has been performed, accessing a tied variable automatically triggers
+method calls in the proper class. The complexity of the class is
+hidden behind magic methods calls. The method names are in ALL CAPS,
+which is a convention that Perl uses to indicate that they're called
+implicitly rather than explicitly--just like the BEGIN() and END()
+functions.
+
+In the tie() call, C<VARIABLE> is the name of the variable to be
+enchanted. C<CLASSNAME> is the name of a class implementing objects of
+the correct type. Any additional arguments in the C<LIST> are passed to
+the appropriate constructor method for that class--meaning TIESCALAR(),
+TIEARRAY(), TIEHASH(), or TIEHANDLE(). (Typically these are arguments
+such as might be passed to the dbminit() function of C.) The object
+returned by the "new" method is also returned by the tie() function,
+which would be useful if you wanted to access other methods in
+C<CLASSNAME>. (You don't actually have to return a reference to a right
+"type" (e.g., HASH or C<CLASSNAME>) so long as it's a properly blessed
+object.) You can also retrieve a reference to the underlying object
+using the tied() function.
+
+Unlike dbmopen(), the tie() function will not C<use> or C<require> a module
+for you--you need to do that explicitly yourself.
+
+=head2 Tying Scalars
+
+A class implementing a tied scalar should define the following methods:
+TIESCALAR, FETCH, STORE, and possibly DESTROY.
+
+Let's look at each in turn, using as an example a tie class for
+scalars that allows the user to do something like:
+
+ tie $his_speed, 'Nice', getppid();
+ tie $my_speed, 'Nice', $$;
+
+And now whenever either of those variables is accessed, its current
+system priority is retrieved and returned. If those variables are set,
+then the process's priority is changed!
+
+We'll use Jarkko Hietaniemi <F<jhi@iki.fi>>'s BSD::Resource class (not
+included) to access the PRIO_PROCESS, PRIO_MIN, and PRIO_MAX constants
+from your system, as well as the getpriority() and setpriority() system
+calls. Here's the preamble of the class.
+
+ package Nice;
+ use Carp;
+ use BSD::Resource;
+ use strict;
+ $Nice::DEBUG = 0 unless defined $Nice::DEBUG;
+
+=over
+
+=item TIESCALAR classname, LIST
+
+This is the constructor for the class. That means it is
+expected to return a blessed reference to a new scalar
+(probably anonymous) that it's creating. For example:
+
+ sub TIESCALAR {
+ my $class = shift;
+ my $pid = shift || $$; # 0 means me
+
+ if ($pid !~ /^\d+$/) {
+ carp "Nice::Tie::Scalar got non-numeric pid $pid" if $^W;
+ return undef;
+ }
+
+ unless (kill 0, $pid) { # EPERM or ERSCH, no doubt
+ carp "Nice::Tie::Scalar got bad pid $pid: $!" if $^W;
+ return undef;
+ }
+
+ return bless \$pid, $class;
+ }
+
+This tie class has chosen to return an error rather than raising an
+exception if its constructor should fail. While this is how dbmopen() works,
+other classes may well not wish to be so forgiving. It checks the global
+variable C<$^W> to see whether to emit a bit of noise anyway.
+
+=item FETCH this
+
+This method will be triggered every time the tied variable is accessed
+(read). It takes no arguments beyond its self reference, which is the
+object representing the scalar we're dealing with. Because in this case
+we're using just a SCALAR ref for the tied scalar object, a simple $$self
+allows the method to get at the real value stored there. In our example
+below, that real value is the process ID to which we've tied our variable.
+
+ sub FETCH {
+ my $self = shift;
+ confess "wrong type" unless ref $self;
+ croak "usage error" if @_;
+ my $nicety;
+ local($!) = 0;
+ $nicety = getpriority(PRIO_PROCESS, $$self);
+ if ($!) { croak "getpriority failed: $!" }
+ return $nicety;
+ }
+
+This time we've decided to blow up (raise an exception) if the renice
+fails--there's no place for us to return an error otherwise, and it's
+probably the right thing to do.
+
+=item STORE this, value
+
+This method will be triggered every time the tied variable is set
+(assigned). Beyond its self reference, it also expects one (and only one)
+argument--the new value the user is trying to assign.
+
+ sub STORE {
+ my $self = shift;
+ confess "wrong type" unless ref $self;
+ my $new_nicety = shift;
+ croak "usage error" if @_;
+
+ if ($new_nicety < PRIO_MIN) {
+ carp sprintf
+ "WARNING: priority %d less than minimum system priority %d",
+ $new_nicety, PRIO_MIN if $^W;
+ $new_nicety = PRIO_MIN;
+ }
+
+ if ($new_nicety > PRIO_MAX) {
+ carp sprintf
+ "WARNING: priority %d greater than maximum system priority %d",
+ $new_nicety, PRIO_MAX if $^W;
+ $new_nicety = PRIO_MAX;
+ }
+
+ unless (defined setpriority(PRIO_PROCESS, $$self, $new_nicety)) {
+ confess "setpriority failed: $!";
+ }
+ return $new_nicety;
+ }
+
+=item DESTROY this
+
+This method will be triggered when the tied variable needs to be destructed.
+As with other object classes, such a method is seldom necessary, because Perl
+deallocates its moribund object's memory for you automatically--this isn't
+C++, you know. We'll use a DESTROY method here for debugging purposes only.
+
+ sub DESTROY {
+ my $self = shift;
+ confess "wrong type" unless ref $self;
+ carp "[ Nice::DESTROY pid $$self ]" if $Nice::DEBUG;
+ }
+
+=back
+
+That's about all there is to it. Actually, it's more than all there
+is to it, because we've done a few nice things here for the sake
+of completeness, robustness, and general aesthetics. Simpler
+TIESCALAR classes are certainly possible.
+
+=head2 Tying Arrays
+
+A class implementing a tied ordinary array should define the following
+methods: TIEARRAY, FETCH, STORE, FETCHSIZE, STORESIZE and perhaps DESTROY.
+
+FETCHSIZE and STORESIZE are used to provide C<$#array> and
+equivalent C<scalar(@array)> access.
+
+The methods POP, PUSH, SHIFT, UNSHIFT, SPLICE are required if the perl
+operator with the corresponding (but lowercase) name is to operate on the
+tied array. The B<Tie::Array> class can be used as a base class to implement
+these in terms of the basic five methods above.
+
+In addition EXTEND will be called when perl would have pre-extended
+allocation in a real array.
+
+This means that tied arrays are now I<complete>. The example below needs
+upgrading to illustrate this. (The documentation in B<Tie::Array> is more
+complete.)
+
+For this discussion, we'll implement an array whose indices are fixed at
+its creation. If you try to access anything beyond those bounds, you'll
+take an exception. For example:
+
+ require Bounded_Array;
+ tie @ary, 'Bounded_Array', 2;
+ $| = 1;
+ for $i (0 .. 10) {
+ print "setting index $i: ";
+ $ary[$i] = 10 * $i;
+ $ary[$i] = 10 * $i;
+ print "value of elt $i now $ary[$i]\n";
+ }
+
+The preamble code for the class is as follows:
+
+ package Bounded_Array;
+ use Carp;
+ use strict;
+
+=over
+
+=item TIEARRAY classname, LIST
+
+This is the constructor for the class. That means it is expected to
+return a blessed reference through which the new array (probably an
+anonymous ARRAY ref) will be accessed.
+
+In our example, just to show you that you don't I<really> have to return an
+ARRAY reference, we'll choose a HASH reference to represent our object.
+A HASH works out well as a generic record type: the C<{BOUND}> field will
+store the maximum bound allowed, and the C<{ARRAY}> field will hold the
+true ARRAY ref. If someone outside the class tries to dereference the
+object returned (doubtless thinking it an ARRAY ref), they'll blow up.
+This just goes to show you that you should respect an object's privacy.
+
+ sub TIEARRAY {
+ my $class = shift;
+ my $bound = shift;
+ confess "usage: tie(\@ary, 'Bounded_Array', max_subscript)"
+ if @_ || $bound =~ /\D/;
+ return bless {
+ BOUND => $bound,
+ ARRAY => [],
+ }, $class;
+ }
+
+=item FETCH this, index
+
+This method will be triggered every time an individual element the tied array
+is accessed (read). It takes one argument beyond its self reference: the
+index whose value we're trying to fetch.
+
+ sub FETCH {
+ my($self,$idx) = @_;
+ if ($idx > $self->{BOUND}) {
+ confess "Array OOB: $idx > $self->{BOUND}";
+ }
+ return $self->{ARRAY}[$idx];
+ }
+
+As you may have noticed, the name of the FETCH method (et al.) is the same
+for all accesses, even though the constructors differ in names (TIESCALAR
+vs TIEARRAY). While in theory you could have the same class servicing
+several tied types, in practice this becomes cumbersome, and it's easiest
+to keep them at simply one tie type per class.
+
+=item STORE this, index, value
+
+This method will be triggered every time an element in the tied array is set
+(written). It takes two arguments beyond its self reference: the index at
+which we're trying to store something and the value we're trying to put
+there. For example:
+
+ sub STORE {
+ my($self, $idx, $value) = @_;
+ print "[STORE $value at $idx]\n" if _debug;
+ if ($idx > $self->{BOUND} ) {
+ confess "Array OOB: $idx > $self->{BOUND}";
+ }
+ return $self->{ARRAY}[$idx] = $value;
+ }
+
+=item DESTROY this
+
+This method will be triggered when the tied variable needs to be destructed.
+As with the scalar tie class, this is almost never needed in a
+language that does its own garbage collection, so this time we'll
+just leave it out.
+
+=back
+
+The code we presented at the top of the tied array class accesses many
+elements of the array, far more than we've set the bounds to. Therefore,
+it will blow up once they try to access beyond the 2nd element of @ary, as
+the following output demonstrates:
+
+ setting index 0: value of elt 0 now 0
+ setting index 1: value of elt 1 now 10
+ setting index 2: value of elt 2 now 20
+ setting index 3: Array OOB: 3 > 2 at Bounded_Array.pm line 39
+ Bounded_Array::FETCH called at testba line 12
+
+=head2 Tying Hashes
+
+As the first Perl data type to be tied (see dbmopen()), hashes have the
+most complete and useful tie() implementation. A class implementing a
+tied hash should define the following methods: TIEHASH is the constructor.
+FETCH and STORE access the key and value pairs. EXISTS reports whether a
+key is present in the hash, and DELETE deletes one. CLEAR empties the
+hash by deleting all the key and value pairs. FIRSTKEY and NEXTKEY
+implement the keys() and each() functions to iterate over all the keys.
+And DESTROY is called when the tied variable is garbage collected.
+
+If this seems like a lot, then feel free to inherit from merely the
+standard Tie::Hash module for most of your methods, redefining only the
+interesting ones. See L<Tie::Hash> for details.
+
+Remember that Perl distinguishes between a key not existing in the hash,
+and the key existing in the hash but having a corresponding value of
+C<undef>. The two possibilities can be tested with the C<exists()> and
+C<defined()> functions.
+
+Here's an example of a somewhat interesting tied hash class: it gives you
+a hash representing a particular user's dot files. You index into the hash
+with the name of the file (minus the dot) and you get back that dot file's
+contents. For example:
+
+ use DotFiles;
+ tie %dot, 'DotFiles';
+ if ( $dot{profile} =~ /MANPATH/ ||
+ $dot{login} =~ /MANPATH/ ||
+ $dot{cshrc} =~ /MANPATH/ )
+ {
+ print "you seem to set your MANPATH\n";
+ }
+
+Or here's another sample of using our tied class:
+
+ tie %him, 'DotFiles', 'daemon';
+ foreach $f ( keys %him ) {
+ printf "daemon dot file %s is size %d\n",
+ $f, length $him{$f};
+ }
+
+In our tied hash DotFiles example, we use a regular
+hash for the object containing several important
+fields, of which only the C<{LIST}> field will be what the
+user thinks of as the real hash.
+
+=over 5
+
+=item USER
+
+whose dot files this object represents
+
+=item HOME
+
+where those dot files live
+
+=item CLOBBER
+
+whether we should try to change or remove those dot files
+
+=item LIST
+
+the hash of dot file names and content mappings
+
+=back
+
+Here's the start of F<Dotfiles.pm>:
+
+ package DotFiles;
+ use Carp;
+ sub whowasi { (caller(1))[3] . '()' }
+ my $DEBUG = 0;
+ sub debug { $DEBUG = @_ ? shift : 1 }
+
+For our example, we want to be able to emit debugging info to help in tracing
+during development. We keep also one convenience function around
+internally to help print out warnings; whowasi() returns the function name
+that calls it.
+
+Here are the methods for the DotFiles tied hash.
+
+=over
+
+=item TIEHASH classname, LIST
+
+This is the constructor for the class. That means it is expected to
+return a blessed reference through which the new object (probably but not
+necessarily an anonymous hash) will be accessed.
+
+Here's the constructor:
+
+ sub TIEHASH {
+ my $self = shift;
+ my $user = shift || $>;
+ my $dotdir = shift || '';
+ croak "usage: @{[&whowasi]} [USER [DOTDIR]]" if @_;
+ $user = getpwuid($user) if $user =~ /^\d+$/;
+ my $dir = (getpwnam($user))[7]
+ || croak "@{[&whowasi]}: no user $user";
+ $dir .= "/$dotdir" if $dotdir;
+
+ my $node = {
+ USER => $user,
+ HOME => $dir,
+ LIST => {},
+ CLOBBER => 0,
+ };
+
+ opendir(DIR, $dir)
+ || croak "@{[&whowasi]}: can't opendir $dir: $!";
+ foreach $dot ( grep /^\./ && -f "$dir/$_", readdir(DIR)) {
+ $dot =~ s/^\.//;
+ $node->{LIST}{$dot} = undef;
+ }
+ closedir DIR;
+ return bless $node, $self;
+ }
+
+It's probably worth mentioning that if you're going to filetest the
+return values out of a readdir, you'd better prepend the directory
+in question. Otherwise, because we didn't chdir() there, it would
+have been testing the wrong file.
+
+=item FETCH this, key
+
+This method will be triggered every time an element in the tied hash is
+accessed (read). It takes one argument beyond its self reference: the key
+whose value we're trying to fetch.
+
+Here's the fetch for our DotFiles example.
+
+ sub FETCH {
+ carp &whowasi if $DEBUG;
+ my $self = shift;
+ my $dot = shift;
+ my $dir = $self->{HOME};
+ my $file = "$dir/.$dot";
+
+ unless (exists $self->{LIST}->{$dot} || -f $file) {
+ carp "@{[&whowasi]}: no $dot file" if $DEBUG;
+ return undef;
+ }
+
+ if (defined $self->{LIST}->{$dot}) {
+ return $self->{LIST}->{$dot};
+ } else {
+ return $self->{LIST}->{$dot} = `cat $dir/.$dot`;
+ }
+ }
+
+It was easy to write by having it call the Unix cat(1) command, but it
+would probably be more portable to open the file manually (and somewhat
+more efficient). Of course, because dot files are a Unixy concept, we're
+not that concerned.
+
+=item STORE this, key, value
+
+This method will be triggered every time an element in the tied hash is set
+(written). It takes two arguments beyond its self reference: the index at
+which we're trying to store something, and the value we're trying to put
+there.
+
+Here in our DotFiles example, we'll be careful not to let
+them try to overwrite the file unless they've called the clobber()
+method on the original object reference returned by tie().
+
+ sub STORE {
+ carp &whowasi if $DEBUG;
+ my $self = shift;
+ my $dot = shift;
+ my $value = shift;
+ my $file = $self->{HOME} . "/.$dot";
+ my $user = $self->{USER};
+
+ croak "@{[&whowasi]}: $file not clobberable"
+ unless $self->{CLOBBER};
+
+ open(F, "> $file") || croak "can't open $file: $!";
+ print F $value;
+ close(F);
+ }
+
+If they wanted to clobber something, they might say:
+
+ $ob = tie %daemon_dots, 'daemon';
+ $ob->clobber(1);
+ $daemon_dots{signature} = "A true daemon\n";
+
+Another way to lay hands on a reference to the underlying object is to
+use the tied() function, so they might alternately have set clobber
+using:
+
+ tie %daemon_dots, 'daemon';
+ tied(%daemon_dots)->clobber(1);
+
+The clobber method is simply:
+
+ sub clobber {
+ my $self = shift;
+ $self->{CLOBBER} = @_ ? shift : 1;
+ }
+
+=item DELETE this, key
+
+This method is triggered when we remove an element from the hash,
+typically by using the delete() function. Again, we'll
+be careful to check whether they really want to clobber files.
+
+ sub DELETE {
+ carp &whowasi if $DEBUG;
+
+ my $self = shift;
+ my $dot = shift;
+ my $file = $self->{HOME} . "/.$dot";
+ croak "@{[&whowasi]}: won't remove file $file"
+ unless $self->{CLOBBER};
+ delete $self->{LIST}->{$dot};
+ my $success = unlink($file);
+ carp "@{[&whowasi]}: can't unlink $file: $!" unless $success;
+ $success;
+ }
+
+The value returned by DELETE becomes the return value of the call
+to delete(). If you want to emulate the normal behavior of delete(),
+you should return whatever FETCH would have returned for this key.
+In this example, we have chosen instead to return a value which tells
+the caller whether the file was successfully deleted.
+
+=item CLEAR this
+
+This method is triggered when the whole hash is to be cleared, usually by
+assigning the empty list to it.
+
+In our example, that would remove all the user's dot files! It's such a
+dangerous thing that they'll have to set CLOBBER to something higher than
+1 to make it happen.
+
+ sub CLEAR {
+ carp &whowasi if $DEBUG;
+ my $self = shift;
+ croak "@{[&whowasi]}: won't remove all dot files for $self->{USER}"
+ unless $self->{CLOBBER} > 1;
+ my $dot;
+ foreach $dot ( keys %{$self->{LIST}}) {
+ $self->DELETE($dot);
+ }
+ }
+
+=item EXISTS this, key
+
+This method is triggered when the user uses the exists() function
+on a particular hash. In our example, we'll look at the C<{LIST}>
+hash element for this:
+
+ sub EXISTS {
+ carp &whowasi if $DEBUG;
+ my $self = shift;
+ my $dot = shift;
+ return exists $self->{LIST}->{$dot};
+ }
+
+=item FIRSTKEY this
+
+This method will be triggered when the user is going
+to iterate through the hash, such as via a keys() or each()
+call.
+
+ sub FIRSTKEY {
+ carp &whowasi if $DEBUG;
+ my $self = shift;
+ my $a = keys %{$self->{LIST}}; # reset each() iterator
+ each %{$self->{LIST}}
+ }
+
+=item NEXTKEY this, lastkey
+
+This method gets triggered during a keys() or each() iteration. It has a
+second argument which is the last key that had been accessed. This is
+useful if you're carrying about ordering or calling the iterator from more
+than one sequence, or not really storing things in a hash anywhere.
+
+For our example, we're using a real hash so we'll do just the simple
+thing, but we'll have to go through the LIST field indirectly.
+
+ sub NEXTKEY {
+ carp &whowasi if $DEBUG;
+ my $self = shift;
+ return each %{ $self->{LIST} }
+ }
+
+=item DESTROY this
+
+This method is triggered when a tied hash is about to go out of
+scope. You don't really need it unless you're trying to add debugging
+or have auxiliary state to clean up. Here's a very simple function:
+
+ sub DESTROY {
+ carp &whowasi if $DEBUG;
+ }
+
+=back
+
+Note that functions such as keys() and values() may return huge lists
+when used on large objects, like DBM files. You may prefer to use the
+each() function to iterate over such. Example:
+
+ # print out history file offsets
+ use NDBM_File;
+ tie(%HIST, 'NDBM_File', '/usr/lib/news/history', 1, 0);
+ while (($key,$val) = each %HIST) {
+ print $key, ' = ', unpack('L',$val), "\n";
+ }
+ untie(%HIST);
+
+=head2 Tying FileHandles
+
+This is partially implemented now.
+
+A class implementing a tied filehandle should define the following
+methods: TIEHANDLE, at least one of PRINT, PRINTF, WRITE, READLINE, GETC,
+READ, and possibly CLOSE and DESTROY.
+
+It is especially useful when perl is embedded in some other program,
+where output to STDOUT and STDERR may have to be redirected in some
+special way. See nvi and the Apache module for examples.
+
+In our example we're going to create a shouting handle.
+
+ package Shout;
+
+=over
+
+=item TIEHANDLE classname, LIST
+
+This is the constructor for the class. That means it is expected to
+return a blessed reference of some sort. The reference can be used to
+hold some internal information.
+
+ sub TIEHANDLE { print "<shout>\n"; my $i; bless \$i, shift }
+
+=item WRITE this, LIST
+
+This method will be called when the handle is written to via the
+C<syswrite> function.
+
+ sub WRITE {
+ $r = shift;
+ my($buf,$len,$offset) = @_;
+ print "WRITE called, \$buf=$buf, \$len=$len, \$offset=$offset";
+ }
+
+=item PRINT this, LIST
+
+This method will be triggered every time the tied handle is printed to
+with the C<print()> function.
+Beyond its self reference it also expects the list that was passed to
+the print function.
+
+ sub PRINT { $r = shift; $$r++; print join($,,map(uc($_),@_)),$\ }
+
+=item PRINTF this, LIST
+
+This method will be triggered every time the tied handle is printed to
+with the C<printf()> function.
+Beyond its self reference it also expects the format and list that was
+passed to the printf function.
+
+ sub PRINTF {
+ shift;
+ my $fmt = shift;
+ print sprintf($fmt, @_)."\n";
+ }
+
+=item READ this, LIST
+
+This method will be called when the handle is read from via the C<read>
+or C<sysread> functions.
+
+ sub READ {
+ $r = shift;
+ my($buf,$len,$offset) = @_;
+ print "READ called, \$buf=$buf, \$len=$len, \$offset=$offset";
+ }
+
+=item READLINE this
+
+This method will be called when the handle is read from via <HANDLE>.
+The method should return undef when there is no more data.
+
+ sub READLINE { $r = shift; "PRINT called $$r times\n"; }
+
+=item GETC this
+
+This method will be called when the C<getc> function is called.
+
+ sub GETC { print "Don't GETC, Get Perl"; return "a"; }
+
+=item CLOSE this
+
+This method will be called when the handle is closed via the C<close>
+function.
+
+ sub CLOSE { print "CLOSE called.\n" }
+
+=item DESTROY this
+
+As with the other types of ties, this method will be called when the
+tied handle is about to be destroyed. This is useful for debugging and
+possibly cleaning up.
+
+ sub DESTROY { print "</shout>\n" }
+
+=back
+
+Here's how to use our little example:
+
+ tie(*FOO,'Shout');
+ print FOO "hello\n";
+ $a = 4; $b = 6;
+ print FOO $a, " plus ", $b, " equals ", $a + $b, "\n";
+ print <FOO>;
+
+=head2 The C<untie> Gotcha
+
+If you intend making use of the object returned from either tie() or
+tied(), and if the tie's target class defines a destructor, there is a
+subtle gotcha you I<must> guard against.
+
+As setup, consider this (admittedly rather contrived) example of a
+tie; all it does is use a file to keep a log of the values assigned to
+a scalar.
+
+ package Remember;
+
+ use strict;
+ use IO::File;
+
+ sub TIESCALAR {
+ my $class = shift;
+ my $filename = shift;
+ my $handle = new IO::File "> $filename"
+ or die "Cannot open $filename: $!\n";
+
+ print $handle "The Start\n";
+ bless {FH => $handle, Value => 0}, $class;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ return $self->{Value};
+ }
+
+ sub STORE {
+ my $self = shift;
+ my $value = shift;
+ my $handle = $self->{FH};
+ print $handle "$value\n";
+ $self->{Value} = $value;
+ }
+
+ sub DESTROY {
+ my $self = shift;
+ my $handle = $self->{FH};
+ print $handle "The End\n";
+ close $handle;
+ }
+
+ 1;
+
+Here is an example that makes use of this tie:
+
+ use strict;
+ use Remember;
+
+ my $fred;
+ tie $fred, 'Remember', 'myfile.txt';
+ $fred = 1;
+ $fred = 4;
+ $fred = 5;
+ untie $fred;
+ system "cat myfile.txt";
+
+This is the output when it is executed:
+
+ The Start
+ 1
+ 4
+ 5
+ The End
+
+So far so good. Those of you who have been paying attention will have
+spotted that the tied object hasn't been used so far. So lets add an
+extra method to the Remember class to allow comments to be included in
+the file -- say, something like this:
+
+ sub comment {
+ my $self = shift;
+ my $text = shift;
+ my $handle = $self->{FH};
+ print $handle $text, "\n";
+ }
+
+And here is the previous example modified to use the C<comment> method
+(which requires the tied object):
+
+ use strict;
+ use Remember;
+
+ my ($fred, $x);
+ $x = tie $fred, 'Remember', 'myfile.txt';
+ $fred = 1;
+ $fred = 4;
+ comment $x "changing...";
+ $fred = 5;
+ untie $fred;
+ system "cat myfile.txt";
+
+When this code is executed there is no output. Here's why:
+
+When a variable is tied, it is associated with the object which is the
+return value of the TIESCALAR, TIEARRAY, or TIEHASH function. This
+object normally has only one reference, namely, the implicit reference
+from the tied variable. When untie() is called, that reference is
+destroyed. Then, as in the first example above, the object's
+destructor (DESTROY) is called, which is normal for objects that have
+no more valid references; and thus the file is closed.
+
+In the second example, however, we have stored another reference to
+the tied object in C<$x>. That means that when untie() gets called
+there will still be a valid reference to the object in existence, so
+the destructor is not called at that time, and thus the file is not
+closed. The reason there is no output is because the file buffers
+have not been flushed to disk.
+
+Now that you know what the problem is, what can you do to avoid it?
+Well, the good old C<-w> flag will spot any instances where you call
+untie() and there are still valid references to the tied object. If
+the second script above is run with the C<-w> flag, Perl prints this
+warning message:
+
+ untie attempted while 1 inner references still exist
+
+To get the script to work properly and silence the warning make sure
+there are no valid references to the tied object I<before> untie() is
+called:
+
+ undef $x;
+ untie $fred;
+
+=head1 SEE ALSO
+
+See L<DB_File> or L<Config> for some interesting tie() implementations.
+
+=head1 BUGS
+
+Tied arrays are I<incomplete>. They are also distinctly lacking something
+for the C<$#ARRAY> access (which is hard, as it's an lvalue), as well as
+the other obvious array functions, like push(), pop(), shift(), unshift(),
+and splice().
+
+You cannot easily tie a multilevel data structure (such as a hash of
+hashes) to a dbm file. The first problem is that all but GDBM and
+Berkeley DB have size limitations, but beyond that, you also have problems
+with how references are to be represented on disk. One experimental
+module that does attempt to address this need partially is the MLDBM
+module. Check your nearest CPAN site as described in L<perlmodlib> for
+source code to MLDBM.
+
+=head1 AUTHOR
+
+Tom Christiansen
+
+TIEHANDLE by Sven Verdoolaege <F<skimo@dns.ufsia.ac.be>> and Doug MacEachern <F<dougm@osf.org>>
diff --git a/contrib/perl5/pod/perltoc.pod b/contrib/perl5/pod/perltoc.pod
new file mode 100644
index 000000000000..980ca8f943ee
--- /dev/null
+++ b/contrib/perl5/pod/perltoc.pod
@@ -0,0 +1,5840 @@
+
+=head1 NAME
+
+perltoc - perl documentation table of contents
+
+=head1 DESCRIPTION
+
+This page provides a brief table of contents for the rest of the Perl
+documentation set. It is meant to be scanned quickly or grepped
+through to locate the proper section you're looking for.
+
+=head1 BASIC DOCUMENTATION
+
+=head2 perl - Practical Extraction and Report Language
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+Many usability enhancements, Simplified grammar, Lexical scoping,
+Arbitrarily nested data structures, Modularity and reusability,
+Object-oriented programming, Embeddable and Extensible, POSIX compliant,
+Package constructors and destructors, Multiple simultaneous DBM
+implementations, Subroutine definitions may now be autoloaded, Regular
+expression enhancements, Innumerable Unbundled Modules, Compilability
+
+=item ENVIRONMENT
+
+=item AUTHOR
+
+=item FILES
+
+=item SEE ALSO
+
+=item DIAGNOSTICS
+
+=item BUGS
+
+=item NOTES
+
+=head2 perlfaq - frequently asked questions about Perl ($Date: 1998/07/20
+23:12:17 $)
+
+=item DESCRIPTION
+
+perlfaq: Structural overview of the FAQ, L<perlfaq1>: General Questions
+About Perl, L<perlfaq2>: Obtaining and Learning about Perl, L<perlfaq3>:
+Programming Tools, L<perlfaq4>: Data Manipulation, L<perlfaq5>: Files and
+Formats, L<perlfaq6>: Regexps, L<perlfaq7>: General Perl Language Issues,
+L<perlfaq8>: System Interaction, L<perlfaq9>: Networking
+
+=over
+
+=item Where to get this document
+
+=item How to contribute to this document
+
+=item What will happen if you mail your Perl programming problems to the
+authors
+
+=back
+
+=item Credits
+
+=item Author and Copyright Information
+
+=over
+
+=item Bundled Distributions
+
+=item Disclaimer
+
+=back
+
+=item Changes
+
+24/April/97, 23/April/97, 25/March/97, 18/March/97, 17/March/97 Version,
+Initial Release: 11/March/97
+
+=head2 perlfaq1 - General Questions About Perl ($Revision: 1.14 $, $Date:
+1998/06/14 22:15:25 $)
+
+=item DESCRIPTION
+
+=over
+
+=item What is Perl?
+
+=item Who supports Perl? Who develops it? Why is it free?
+
+=item Which version of Perl should I use?
+
+=item What are perl4 and perl5?
+
+=item How stable is Perl?
+
+=item Is Perl difficult to learn?
+
+=item How does Perl compare with other languages like Java, Python, REXX,
+Scheme, or Tcl?
+
+=item Can I do [task] in Perl?
+
+=item When shouldn't I program in Perl?
+
+=item What's the difference between "perl" and "Perl"?
+
+=item Is it a Perl program or a Perl script?
+
+=item What is a JAPH?
+
+=item Where can I get a list of Larry Wall witticisms?
+
+=item How can I convince my sysadmin/supervisor/employees to use version
+(5/5.004/Perl instead of some other language)?
+
+=back
+
+=item AUTHOR AND COPYRIGHT
+
+=head2 perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.24 $,
+$Date: 1998/07/20 23:40:28 $)
+
+=item DESCRIPTION
+
+=over
+
+=item What machines support Perl? Where do I get it?
+
+=item How can I get a binary version of Perl?
+
+=item I don't have a C compiler on my system. How can I compile perl?
+
+=item I copied the Perl binary from one machine to another, but scripts
+don't work.
+
+=item I grabbed the sources and tried to compile but gdbm/dynamic
+loading/malloc/linking/... failed. How do I make it work?
+
+=item What modules and extensions are available for Perl? What is CPAN?
+What does CPAN/src/... mean?
+
+=item Is there an ISO or ANSI certified version of Perl?
+
+=item Where can I get information on Perl?
+
+=item What are the Perl newsgroups on USENET? Where do I post questions?
+
+=item Where should I post source code?
+
+=item Perl Books
+
+References, Tutorials
+*Learning Perl [2nd edition]
+by Randal L. Schwartz and Tom Christiansen, Task-Oriented, Special Topics
+
+=item Perl in Magazines
+
+=item Perl on the Net: FTP and WWW Access
+
+=item What mailing lists are there for perl?
+
+MacPerl, Perl5-Porters, NTPerl, Perl-Packrats
+
+=item Archives of comp.lang.perl.misc
+
+=item Where can I buy a commercial version of Perl?
+
+=item Where do I send bug reports?
+
+=item What is perl.com? perl.org? The Perl Institute?
+
+=item How do I learn about object-oriented Perl programming?
+
+=back
+
+=item AUTHOR AND COPYRIGHT
+
+=head2 perlfaq3 - Programming Tools ($Revision: 1.28 $, $Date: 1998/07/16
+22:08:49 $)
+
+=item DESCRIPTION
+
+=over
+
+=item How do I do (anything)?
+
+=item How can I use Perl interactively?
+
+=item Is there a Perl shell?
+
+=item How do I debug my Perl programs?
+
+=item How do I profile my Perl programs?
+
+=item How do I cross-reference my Perl programs?
+
+=item Is there a pretty-printer (formatter) for Perl?
+
+=item Is there a ctags for Perl?
+
+=item Where can I get Perl macros for vi?
+
+=item Where can I get perl-mode for emacs?
+
+=item How can I use curses with Perl?
+
+=item How can I use X or Tk with Perl?
+
+=item How can I generate simple menus without using CGI or Tk?
+
+=item What is undump?
+
+=item How can I make my Perl program run faster?
+
+=item How can I make my Perl program take less memory?
+
+=item Is it unsafe to return a pointer to local data?
+
+=item How can I free an array or hash so my program shrinks?
+
+=item How can I make my CGI script more efficient?
+
+=item How can I hide the source for my Perl program?
+
+=item How can I compile my Perl program into byte code or C?
+
+=item How can I get C<#!perl> to work on [MS-DOS,NT,...]?
+
+=item Can I write useful perl programs on the command line?
+
+=item Why don't perl one-liners work on my DOS/Mac/VMS system?
+
+=item Where can I learn about CGI or Web programming in Perl?
+
+=item Where can I learn about object-oriented Perl programming?
+
+=item Where can I learn about linking C with Perl? [h2xs, xsubpp]
+
+=item I've read perlembed, perlguts, etc., but I can't embed perl in
+my C program, what am I doing wrong?
+
+=item When I tried to run my script, I got this message. What does it
+mean?
+
+=item What's MakeMaker?
+
+=back
+
+=item AUTHOR AND COPYRIGHT
+
+=head2 perlfaq4 - Data Manipulation ($Revision: 1.25 $, $Date: 1998/07/16
+22:49:55 $)
+
+=item DESCRIPTION
+
+=item Data: Numbers
+
+=over
+
+=item Why am I getting long decimals (eg, 19.9499999999999) instead of the
+numbers I should be getting (eg, 19.95)?
+
+=item Why isn't my octal data interpreted correctly?
+
+=item Does perl have a round function? What about ceil() and floor()?
+Trig functions?
+
+=item How do I convert bits into ints?
+
+=item How do I multiply matrices?
+
+=item How do I perform an operation on a series of integers?
+
+=item How can I output Roman numerals?
+
+=item Why aren't my random numbers random?
+
+=back
+
+=item Data: Dates
+
+=over
+
+=item How do I find the week-of-the-year/day-of-the-year?
+
+=item How can I compare two dates and find the difference?
+
+=item How can I take a string and turn it into epoch seconds?
+
+=item How can I find the Julian Day?
+
+=item Does Perl have a year 2000 problem? Is Perl Y2K compliant?
+
+=back
+
+=item Data: Strings
+
+=over
+
+=item How do I validate input?
+
+=item How do I unescape a string?
+
+=item How do I remove consecutive pairs of characters?
+
+=item How do I expand function calls in a string?
+
+=item How do I find matching/nesting anything?
+
+=item How do I reverse a string?
+
+=item How do I expand tabs in a string?
+
+=item How do I reformat a paragraph?
+
+=item How can I access/change the first N letters of a string?
+
+=item How do I change the Nth occurrence of something?
+
+=item How can I count the number of occurrences of a substring within a
+string?
+
+=item How do I capitalize all the words on one line?
+
+=item How can I split a [character] delimited string except when inside
+[character]? (Comma-separated files)
+
+=item How do I strip blank space from the beginning/end of a string?
+
+=item How do I extract selected columns from a string?
+
+=item How do I find the soundex value of a string?
+
+=item How can I expand variables in text strings?
+
+=item What's wrong with always quoting "$vars"?
+
+=item Why don't my <<HERE documents work?
+
+1. There must be no space after the << part, 2. There (probably) should be
+a semicolon at the end, 3. You can't (easily) have any space in front of
+the tag
+
+=back
+
+=item Data: Arrays
+
+=over
+
+=item What is the difference between $array[1] and @array[1]?
+
+=item How can I extract just the unique elements of an array?
+
+a) If @in is sorted, and you want @out to be sorted:(this assumes all true
+values in the array), b) If you don't know whether @in is sorted:, c) Like
+(b), but @in contains only small integers:, d) A way to do (b) without any
+loops or greps:, e) Like (d), but @in contains only small positive
+integers:
+
+=item How can I tell whether a list or array contains a certain element?
+
+=item How do I compute the difference of two arrays? How do I compute the
+intersection of two arrays?
+
+=item How do I find the first array element for which a condition is true?
+
+=item How do I handle linked lists?
+
+=item How do I handle circular lists?
+
+=item How do I shuffle an array randomly?
+
+=item How do I process/modify each element of an array?
+
+=item How do I select a random element from an array?
+
+=item How do I permute N elements of a list?
+
+=item How do I sort an array by (anything)?
+
+=item How do I manipulate arrays of bits?
+
+=item Why does defined() return true on empty arrays and hashes?
+
+=back
+
+=item Data: Hashes (Associative Arrays)
+
+=over
+
+=item How do I process an entire hash?
+
+=item What happens if I add or remove keys from a hash while iterating over
+it?
+
+=item How do I look up a hash element by value?
+
+=item How can I know how many entries are in a hash?
+
+=item How do I sort a hash (optionally by value instead of key)?
+
+=item How can I always keep my hash sorted?
+
+=item What's the difference between "delete" and "undef" with hashes?
+
+=item Why don't my tied hashes make the defined/exists distinction?
+
+=item How do I reset an each() operation part-way through?
+
+=item How can I get the unique keys from two hashes?
+
+=item How can I store a multidimensional array in a DBM file?
+
+=item How can I make my hash remember the order I put elements into it?
+
+=item Why does passing a subroutine an undefined element in a hash create
+it?
+
+=item How can I make the Perl equivalent of a C structure/C++ class/hash or
+array of hashes or arrays?
+
+=item How can I use a reference as a hash key?
+
+=back
+
+=item Data: Misc
+
+=over
+
+=item How do I handle binary data correctly?
+
+=item How do I determine whether a scalar is a number/whole/integer/float?
+
+=item How do I keep persistent data across program calls?
+
+=item How do I print out or copy a recursive data structure?
+
+=item How do I define methods for every class/object?
+
+=item How do I verify a credit card checksum?
+
+=back
+
+=item AUTHOR AND COPYRIGHT
+
+=head2 perlfaq5 - Files and Formats ($Revision: 1.24 $, $Date: 1998/07/05
+15:07:20 $)
+
+=item DESCRIPTION
+
+=over
+
+=item How do I flush/unbuffer an output filehandle? Why must I do this?
+
+=item How do I change one line in a file/delete a line in a file/insert a
+line in the middle of a file/append to the beginning of a file?
+
+=item How do I count the number of lines in a file?
+
+=item How do I make a temporary file name?
+
+=item How can I manipulate fixed-record-length files?
+
+=item How can I make a filehandle local to a subroutine? How do I pass
+filehandles between subroutines? How do I make an array of filehandles?
+
+=item How can I use a filehandle indirectly?
+
+=item How can I set up a footer format to be used with write()?
+
+=item How can I write() into a string?
+
+=item How can I output my numbers with commas added?
+
+=item How can I translate tildes (~) in a filename?
+
+=item How come when I open a file read-write it wipes it out?
+
+=item Why do I sometimes get an "Argument list too long" when I use <*>?
+
+=item Is there a leak/bug in glob()?
+
+=item How can I open a file with a leading "E<gt>" or trailing blanks?
+
+=item How can I reliably rename a file?
+
+=item How can I lock a file?
+
+=item What can't I just open(FH, ">file.lock")?
+
+=item I still don't get locking. I just want to increment the number in
+the file. How can I do this?
+
+=item How do I randomly update a binary file?
+
+=item How do I get a file's timestamp in perl?
+
+=item How do I set a file's timestamp in perl?
+
+=item How do I print to more than one file at once?
+
+=item How can I read in a file by paragraphs?
+
+=item How can I read a single character from a file? From the keyboard?
+
+=item How can I tell if there's a character waiting on a filehandle?
+
+=item How do I do a C<tail -f> in perl?
+
+=item How do I dup() a filehandle in Perl?
+
+=item How do I close a file descriptor by number?
+
+=item Why can't I use "C:\temp\foo" in DOS paths? What doesn't
+`C:\temp\foo.exe` work?
+
+=item Why doesn't glob("*.*") get all the files?
+
+=item Why does Perl let me delete read-only files? Why does C<-i> clobber
+protected files? Isn't this a bug in Perl?
+
+=item How do I select a random line from a file?
+
+=back
+
+=item AUTHOR AND COPYRIGHT
+
+=head2 perlfaq6 - Regexps ($Revision: 1.22 $, $Date: 1998/07/16 14:01:07 $)
+
+=item DESCRIPTION
+
+=over
+
+=item How can I hope to use regular expressions without creating illegible
+and unmaintainable code?
+
+Comments Outside the Regexp, Comments Inside the Regexp, Different
+Delimiters
+
+=item I'm having trouble matching over more than one line. What's wrong?
+
+=item How can I pull out lines between two patterns that are themselves on
+different lines?
+
+=item I put a regular expression into $/ but it didn't work. What's wrong?
+
+=item How do I substitute case insensitively on the LHS, but preserving
+case on the RHS?
+
+=item How can I make C<\w> match national character sets?
+
+=item How can I match a locale-smart version of C</[a-zA-Z]/>?
+
+=item How can I quote a variable to use in a regexp?
+
+=item What is C</o> really for?
+
+=item How do I use a regular expression to strip C style comments from a
+file?
+
+=item Can I use Perl regular expressions to match balanced text?
+
+=item What does it mean that regexps are greedy? How can I get around it?
+
+=item How do I process each word on each line?
+
+=item How can I print out a word-frequency or line-frequency summary?
+
+=item How can I do approximate matching?
+
+=item How do I efficiently match many regular expressions at once?
+
+=item Why don't word-boundary searches with C<\b> work for me?
+
+=item Why does using $&, $`, or $' slow my program down?
+
+=item What good is C<\G> in a regular expression?
+
+=item Are Perl regexps DFAs or NFAs? Are they POSIX compliant?
+
+=item What's wrong with using grep or map in a void context?
+
+=item How can I match strings with multibyte characters?
+
+=back
+
+=item AUTHOR AND COPYRIGHT
+
+=head2 perlfaq7 - Perl Language Issues ($Revision: 1.21 $, $Date:
+1998/06/22 15:20:07 $)
+
+=item DESCRIPTION
+
+=over
+
+=item Can I get a BNF/yacc/RE for the Perl language?
+
+=item What are all these $@%* punctuation signs, and how do I know when to
+use them?
+
+=item Do I always/never have to quote my strings or use semicolons and
+commas?
+
+=item How do I skip some return values?
+
+=item How do I temporarily block warnings?
+
+=item What's an extension?
+
+=item Why do Perl operators have different precedence than C operators?
+
+=item How do I declare/create a structure?
+
+=item How do I create a module?
+
+=item How do I create a class?
+
+=item How can I tell if a variable is tainted?
+
+=item What's a closure?
+
+=item What is variable suicide and how can I prevent it?
+
+=item How can I pass/return a {Function, FileHandle, Array, Hash, Method,
+Regexp}?
+
+Passing Variables and Functions, Passing Filehandles, Passing Regexps,
+Passing Methods
+
+=item How do I create a static variable?
+
+=item What's the difference between dynamic and lexical (static) scoping?
+Between local() and my()?
+
+=item How can I access a dynamic variable while a similarly named lexical
+is in scope?
+
+=item What's the difference between deep and shallow binding?
+
+=item Why doesn't "my($foo) = <FILE>;" work right?
+
+=item How do I redefine a builtin function, operator, or method?
+
+=item What's the difference between calling a function as &foo and foo()?
+
+=item How do I create a switch or case statement?
+
+=item How can I catch accesses to undefined variables/functions/methods?
+
+=item Why can't a method included in this same file be found?
+
+=item How can I find out my current package?
+
+=item How can I comment out a large block of perl code?
+
+=back
+
+=item AUTHOR AND COPYRIGHT
+
+=head2 perlfaq8 - System Interaction ($Revision: 1.25 $, $Date: 1998/07/05
+15:07:20 $)
+
+=item DESCRIPTION
+
+=over
+
+=item How do I find out which operating system I'm running under?
+
+=item How come exec() doesn't return?
+
+=item How do I do fancy stuff with the keyboard/screen/mouse?
+
+Keyboard, Screen, Mouse
+
+=item How do I print something out in color?
+
+=item How do I read just one key without waiting for a return key?
+
+=item How do I check whether input is ready on the keyboard?
+
+=item How do I clear the screen?
+
+=item How do I get the screen size?
+
+=item How do I ask the user for a password?
+
+=item How do I read and write the serial port?
+
+lockfiles, open mode, end of line, flushing output, non-blocking input
+
+=item How do I decode encrypted password files?
+
+=item How do I start a process in the background?
+
+STDIN, STDOUT, and STDERR are shared, Signals, Zombies
+
+=item How do I trap control characters/signals?
+
+=item How do I modify the shadow password file on a Unix system?
+
+=item How do I set the time and date?
+
+=item How can I sleep() or alarm() for under a second?
+
+=item How can I measure time under a second?
+
+=item How can I do an atexit() or setjmp()/longjmp()? (Exception handling)
+
+=item Why doesn't my sockets program work under System V (Solaris)? What
+does the error message "Protocol not supported" mean?
+
+=item How can I call my system's unique C functions from Perl?
+
+=item Where do I get the include files to do ioctl() or syscall()?
+
+=item Why do setuid perl scripts complain about kernel problems?
+
+=item How can I open a pipe both to and from a command?
+
+=item Why can't I get the output of a command with system()?
+
+=item How can I capture STDERR from an external command?
+
+=item Why doesn't open() return an error when a pipe open fails?
+
+=item What's wrong with using backticks in a void context?
+
+=item How can I call backticks without shell processing?
+
+=item Why can't my script read from STDIN after I gave it EOF (^D on Unix,
+^Z on MS-DOS)?
+
+=item How can I convert my shell script to perl?
+
+=item Can I use perl to run a telnet or ftp session?
+
+=item How can I write expect in Perl?
+
+=item Is there a way to hide perl's command line from programs such as
+"ps"?
+
+=item I {changed directory, modified my environment} in a perl script. How
+come the change disappeared when I exited the script? How do I get my
+changes to be visible?
+
+Unix
+
+=item How do I close a process's filehandle without waiting for it to
+complete?
+
+=item How do I fork a daemon process?
+
+=item How do I make my program run with sh and csh?
+
+=item How do I find out if I'm running interactively or not?
+
+=item How do I timeout a slow event?
+
+=item How do I set CPU limits?
+
+=item How do I avoid zombies on a Unix system?
+
+=item How do I use an SQL database?
+
+=item How do I make a system() exit on control-C?
+
+=item How do I open a file without blocking?
+
+=item How do I install a CPAN module?
+
+=item What's the difference between require and use?
+
+=item How do I keep my own module/library directory?
+
+=item How do I add the directory my program lives in to the module/library
+search path?
+
+=item How do I add a directory to my include path at runtime?
+
+=back
+
+=item AUTHOR AND COPYRIGHT
+
+=head2 perlfaq9 - Networking ($Revision: 1.20 $, $Date: 1998/06/22 18:31:09
+$)
+
+=item DESCRIPTION
+
+=over
+
+=item My CGI script runs from the command line but not the browser. (500
+Server Error)
+
+=item How can I get better error messages from a CGI program?
+
+=item How do I remove HTML from a string?
+
+=item How do I extract URLs?
+
+=item How do I download a file from the user's machine? How do I open a
+file on another machine?
+
+=item How do I make a pop-up menu in HTML?
+
+=item How do I fetch an HTML file?
+
+=item How do I automate an HTML form submission?
+
+=item How do I decode or create those %-encodings on the web?
+
+=item How do I redirect to another page?
+
+=item How do I put a password on my web pages?
+
+=item How do I edit my .htpasswd and .htgroup files with Perl?
+
+=item How do I make sure users can't enter values into a form that cause my
+CGI script to do bad things?
+
+=item How do I parse a mail header?
+
+=item How do I decode a CGI form?
+
+=item How do I check a valid mail address?
+
+=item How do I decode a MIME/BASE64 string?
+
+=item How do I return the user's mail address?
+
+=item How do I send mail?
+
+=item How do I read mail?
+
+=item How do I find out my hostname/domainname/IP address?
+
+=item How do I fetch a news article or the active newsgroups?
+
+=item How do I fetch/put an FTP file?
+
+=item How can I do RPC in Perl?
+
+=back
+
+=item AUTHOR AND COPYRIGHT
+
+=head2 perldelta - what's new for perl5.005
+
+=item DESCRIPTION
+
+=item About the new versioning system
+
+=item Incompatible Changes
+
+=over
+
+=item WARNING: This version is not binary compatible with Perl 5.004.
+
+=item Default installation structure has changed
+
+=item Perl Source Compatibility
+
+=item C Source Compatibility
+
+Core sources now require ANSI C compiler, All Perl global variables must
+now be referenced with an explicit prefix, Enabling threads has source
+compatibility issues
+
+=item Binary Compatibility
+
+=item Security fixes may affect compatibility
+
+=item Relaxed new mandatory warnings introduced in 5.004
+
+=item Licensing
+
+=back
+
+=item Core Changes
+
+=over
+
+=item Threads
+
+=item Compiler
+
+=item Regular Expressions
+
+Many new and improved optimizations, Many bug fixes, New regular expression
+constructs, New operator for precompiled regular expressions, Other
+improvements, Incompatible changes
+
+=item Improved malloc()
+
+=item Quicksort is internally implemented
+
+=item Reliable signals
+
+=item Reliable stack pointers
+
+=item More generous treatment of carriage returns
+
+=item Memory leaks
+
+=item Better support for multiple interpreters
+
+=item Behavior of local() on array and hash elements is now well-defined
+
+=item C<%!> is transparently tied to the L<Errno> module
+
+=item Pseudo-hashes are supported
+
+=item C<EXPR foreach EXPR> is supported
+
+=item Keywords can be globally overridden
+
+=item C<$^E> is meaningful on Win32
+
+=item C<foreach (1..1000000)> optimized
+
+=item C<Foo::> can be used as implicitly quoted package name
+
+=item C<exists $Foo::{Bar::}> tests existence of a package
+
+=item Better locale support
+
+=item Experimental support for 64-bit platforms
+
+=item prototype() returns useful results on builtins
+
+=item Extended support for exception handling
+
+=item Re-blessing in DESTROY() supported for chaining DESTROY() methods
+
+=item All C<printf> format conversions are handled internally
+
+=item New C<INIT> keyword
+
+=item New C<lock> keyword
+
+=item New C<qr//> operator
+
+=item C<our> is now a reserved word
+
+=item Tied arrays are now fully supported
+
+=item Tied handles support is better
+
+=item 4th argument to substr
+
+=item Negative LENGTH argument to splice
+
+=item Magic lvalues are now more magical
+
+=item E<lt>E<gt> now reads in records
+
+=back
+
+=item Supported Platforms
+
+=over
+
+=item New Platforms
+
+=item Changes in existing support
+
+=back
+
+=item Modules and Pragmata
+
+=over
+
+=item New Modules
+
+B, Data::Dumper, Errno, File::Spec, ExtUtils::Installed,
+ExtUtils::Packlist, Fatal, IPC::SysV, Test, Tie::Array, Tie::Handle,
+Thread, attrs, fields, re
+
+=item Changes in existing modules
+
+CGI, POSIX, DB_File, MakeMaker, CPAN, Cwd, Benchmark
+
+=back
+
+=item Utility Changes
+
+=item Documentation Changes
+
+=item New Diagnostics
+
+Ambiguous call resolved as CORE::%s(), qualify as such or use &, Bad index
+while coercing array into hash, Bareword "%s" refers to nonexistent
+package, Can't call method "%s" on an undefined value, Can't coerce array
+into hash, Can't goto subroutine from an eval-string, Can't localize
+pseudo-hash element, Can't use %%! because Errno.pm is not available,
+Cannot find an opnumber for "%s", Character class syntax [. .] is reserved
+for future extensions, Character class syntax [: :] is reserved for future
+extensions, Character class syntax [= =] is reserved for future extensions,
+%s: Eval-group in insecure regular expression, %s: Eval-group not allowed,
+use re 'eval', %s: Eval-group not allowed at run time, Explicit blessing to
+'' (assuming package main), Illegal hex digit ignored, No such array field,
+No such field "%s" in variable %s of type %s, Out of memory during
+ridiculously large request, Range iterator outside integer range, Recursive
+inheritance detected while looking for method '%s' in package '%s',
+Reference found where even-sized list expected, Undefined value assigned to
+typeglob, Use of reserved word "%s" is deprecated, perl: warning: Setting
+locale failed
+
+=item Obsolete Diagnostics
+
+Can't mktemp(), Can't write to temp file for B<-e>: %s, Cannot open
+temporary file
+
+=item BUGS
+
+=item SEE ALSO
+
+=item HISTORY
+
+=head2 perldata - Perl data types
+
+=item DESCRIPTION
+
+=over
+
+=item Variable names
+
+=item Context
+
+=item Scalar values
+
+=item Scalar value constructors
+
+=item List value constructors
+
+=item Typeglobs and Filehandles
+
+=back
+
+=head2 perlsyn - Perl syntax
+
+=item DESCRIPTION
+
+=over
+
+=item Declarations
+
+=item Simple statements
+
+=item Compound statements
+
+=item Loop Control
+
+=item For Loops
+
+=item Foreach Loops
+
+=item Basic BLOCKs and Switch Statements
+
+=item Goto
+
+=item PODs: Embedded Documentation
+
+=item Plain Old Comments (Not!)
+
+=back
+
+=head2 perlop - Perl operators and precedence
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Terms and List Operators (Leftward)
+
+=item The Arrow Operator
+
+=item Auto-increment and Auto-decrement
+
+=item Exponentiation
+
+=item Symbolic Unary Operators
+
+=item Binding Operators
+
+=item Multiplicative Operators
+
+=item Additive Operators
+
+=item Shift Operators
+
+=item Named Unary Operators
+
+=item Relational Operators
+
+=item Equality Operators
+
+=item Bitwise And
+
+=item Bitwise Or and Exclusive Or
+
+=item C-style Logical And
+
+=item C-style Logical Or
+
+=item Range Operators
+
+=item Conditional Operator
+
+=item Assignment Operators
+
+=item Comma Operator
+
+=item List Operators (Rightward)
+
+=item Logical Not
+
+=item Logical And
+
+=item Logical or and Exclusive Or
+
+=item C Operators Missing From Perl
+
+unary &, unary *, (TYPE)
+
+=item Quote and Quote-like Operators
+
+=item Regexp Quote-Like Operators
+
+?PATTERN?, m/PATTERN/cgimosx, /PATTERN/cgimosx, q/STRING/, C<'STRING'>,
+qq/STRING/, "STRING", qr/STRING/imosx, qx/STRING/, `STRING`, qw/STRING/,
+s/PATTERN/REPLACEMENT/egimosx, tr/SEARCHLIST/REPLACEMENTLIST/cds,
+y/SEARCHLIST/REPLACEMENTLIST/cds
+
+=item Gory details of parsing quoted constructs
+
+Finding the end, Removal of backslashes before delimiters, Interpolation,
+C<<<'EOF'>, C<m''>, C<s'''>, C<tr///>, C<y///>, C<''>, C<q//>, C<"">,
+C<``>, C<qq//>, C<qx//>, C<<file*globE<gt>>, C<?RE?>, C</RE/>, C<m/RE/>,
+C<s/RE/foo/>,, Interpolation of regular expressions, Optimization of
+regular expressions
+
+=item I/O Operators
+
+=item Constant Folding
+
+=item Bitwise String Operators
+
+=item Integer Arithmetic
+
+=item Floating-point Arithmetic
+
+=item Bigger Numbers
+
+=back
+
+=head2 perlre - Perl regular expressions
+
+=item DESCRIPTION
+
+i, m, s, x
+
+=over
+
+=item Regular Expressions
+
+C<(?#text)>, C<(?:pattern)>, C<(?imsx-imsx:pattern)>, C<(?=pattern)>,
+C<(?!pattern)>, C<(?E<lt>=pattern)>, C<(?<!pattern)>, C<(?{ code })>,
+C<(?E<gt>pattern)>, C<(?(condition)yes-pattern|no-pattern)>,
+C<(?(condition)yes-pattern)>, C<(?imsx-imsx)>
+
+=item Backtracking
+
+=item Version 8 Regular Expressions
+
+=item WARNING on \1 vs $1
+
+=item Repeated patterns matching zero-length substring
+
+=item Creating custom RE engines
+
+=item SEE ALSO
+
+=back
+
+=head2 perlrun - how to execute the Perl interpreter
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item #! and quoting on non-Unix systems
+
+OS/2, MS-DOS, Win95/NT, Macintosh
+
+=item Location of Perl
+
+=item Switches
+
+B<-0>[I<digits>], B<-a>, B<-c>, B<-d>, B<-d:>I<foo>, B<-D>I<letters>,
+B<-D>I<number>, B<-e> I<commandline>, B<-F>I<pattern>, B<-h>,
+B<-i>[I<extension>], B<-I>I<directory>, B<-l>[I<octnum>],
+B<-m>[B<->]I<module>, B<-M>[B<->]I<module>, B<-M>[B<->]I<'module ...'>,
+B<-[mM]>[B<->]I<module=arg[,arg]...>, B<-n>, B<-p>, B<-P>, B<-s>, B<-S>,
+B<-T>, B<-u>, B<-U>, B<-v>, B<-V>, B<-V:>I<name>, B<-w>, B<-x> I<directory>
+
+=back
+
+=item ENVIRONMENT
+
+HOME, LOGDIR, PATH, PERL5LIB, PERL5OPT, PERLLIB, PERL5DB, PERL5SHELL
+(specific to WIN32 port), PERL_DEBUG_MSTATS, PERL_DESTRUCT_LEVEL
+
+=head2 perlfunc - Perl builtin functions
+
+=item DESCRIPTION
+
+=over
+
+=item Perl Functions by Category
+
+Functions for SCALARs or strings, Regular expressions and pattern matching,
+Numeric functions, Functions for real @ARRAYs, Functions for list data,
+Functions for real %HASHes, Input and output functions, Functions for fixed
+length data or records, Functions for filehandles, files, or directories,
+Keywords related to the control flow of your perl program, Keywords related
+to scoping, Miscellaneous functions, Functions for processes and process
+groups, Keywords related to perl modules, Keywords related to classes and
+object-orientedness, Low-level socket functions, System V interprocess
+communication functions, Fetching user and group info, Fetching network
+info, Time-related functions, Functions new in perl5, Functions obsoleted
+in perl5
+
+=item Alphabetical Listing of Perl Functions
+
+I<-X> FILEHANDLE, I<-X> EXPR, I<-X>, abs VALUE, abs, accept
+NEWSOCKET,GENERICSOCKET, alarm SECONDS, alarm, atan2 Y,X, bind SOCKET,NAME,
+binmode FILEHANDLE, bless REF,CLASSNAME, bless REF, caller EXPR, caller,
+chdir EXPR, chmod LIST, chomp VARIABLE, chomp LIST, chomp, chop VARIABLE,
+chop LIST, chop, chown LIST, chr NUMBER, chr, chroot FILENAME, chroot,
+close FILEHANDLE, close, closedir DIRHANDLE, connect SOCKET,NAME, continue
+BLOCK, cos EXPR, crypt PLAINTEXT,SALT, dbmclose HASH, dbmopen
+HASH,DBNAME,MODE, defined EXPR, defined, delete EXPR, die LIST, do BLOCK,
+do SUBROUTINE(LIST), do EXPR, dump LABEL, each HASH, eof FILEHANDLE, eof
+(), eof, eval EXPR, eval BLOCK, exec LIST, exec PROGRAM LIST, exists EXPR,
+exit EXPR, exp EXPR, exp, fcntl FILEHANDLE,FUNCTION,SCALAR, fileno
+FILEHANDLE, flock FILEHANDLE,OPERATION, fork, format, formline
+PICTURE,LIST, getc FILEHANDLE, getc, getlogin, getpeername SOCKET, getpgrp
+PID, getppid, getpriority WHICH,WHO, getpwnam NAME, getgrnam NAME,
+gethostbyname NAME, getnetbyname NAME, getprotobyname NAME, getpwuid UID,
+getgrgid GID, getservbyname NAME,PROTO, gethostbyaddr ADDR,ADDRTYPE,
+getnetbyaddr ADDR,ADDRTYPE, getprotobynumber NUMBER, getservbyport
+PORT,PROTO, getpwent, getgrent, gethostent, getnetent, getprotoent,
+getservent, setpwent, setgrent, sethostent STAYOPEN, setnetent STAYOPEN,
+setprotoent STAYOPEN, setservent STAYOPEN, endpwent, endgrent, endhostent,
+endnetent, endprotoent, endservent, getsockname SOCKET, getsockopt
+SOCKET,LEVEL,OPTNAME, glob EXPR, glob, gmtime EXPR, goto LABEL, goto EXPR,
+goto &NAME, grep BLOCK LIST, grep EXPR,LIST, hex EXPR, hex, import, index
+STR,SUBSTR,POSITION, index STR,SUBSTR, int EXPR, int, ioctl
+FILEHANDLE,FUNCTION,SCALAR, join EXPR,LIST, keys HASH, kill LIST, last
+LABEL, last, lc EXPR, lc, lcfirst EXPR, lcfirst, length EXPR, length, link
+OLDFILE,NEWFILE, listen SOCKET,QUEUESIZE, local EXPR, localtime EXPR, log
+EXPR, log, lstat FILEHANDLE, lstat EXPR, lstat, m//, map BLOCK LIST, map
+EXPR,LIST, mkdir FILENAME,MODE, msgctl ID,CMD,ARG, msgget KEY,FLAGS, msgsnd
+ID,MSG,FLAGS, msgrcv ID,VAR,SIZE,TYPE,FLAGS, my EXPR, next LABEL, next, no
+Module LIST, oct EXPR, oct, open FILEHANDLE,EXPR, open FILEHANDLE, opendir
+DIRHANDLE,EXPR, ord EXPR, ord, pack TEMPLATE,LIST, package, package
+NAMESPACE, pipe READHANDLE,WRITEHANDLE, pop ARRAY, pop, pos SCALAR, pos,
+print FILEHANDLE LIST, print LIST, print, printf FILEHANDLE FORMAT, LIST,
+printf FORMAT, LIST, prototype FUNCTION, push ARRAY,LIST, q/STRING/,
+qq/STRING/, qr/STRING/, qx/STRING/, qw/STRING/, quotemeta EXPR, quotemeta,
+rand EXPR, rand, read FILEHANDLE,SCALAR,LENGTH,OFFSET, read
+FILEHANDLE,SCALAR,LENGTH, readdir DIRHANDLE, readline EXPR, readlink EXPR,
+readlink, readpipe EXPR, recv SOCKET,SCALAR,LEN,FLAGS, redo LABEL, redo,
+ref EXPR, ref, rename OLDNAME,NEWNAME, require EXPR, require, reset EXPR,
+reset, return EXPR, return, reverse LIST, rewinddir DIRHANDLE, rindex
+STR,SUBSTR,POSITION, rindex STR,SUBSTR, rmdir FILENAME, rmdir, s///, scalar
+EXPR, seek FILEHANDLE,POSITION,WHENCE, seekdir DIRHANDLE,POS, select
+FILEHANDLE, select, select RBITS,WBITS,EBITS,TIMEOUT, semctl
+ID,SEMNUM,CMD,ARG, semget KEY,NSEMS,FLAGS, semop KEY,OPSTRING, send
+SOCKET,MSG,FLAGS,TO, send SOCKET,MSG,FLAGS, setpgrp PID,PGRP, setpriority
+WHICH,WHO,PRIORITY, setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL, shift ARRAY,
+shift, shmctl ID,CMD,ARG, shmget KEY,SIZE,FLAGS, shmread ID,VAR,POS,SIZE,
+shmwrite ID,STRING,POS,SIZE, shutdown SOCKET,HOW, sin EXPR, sin, sleep
+EXPR, sleep, socket SOCKET,DOMAIN,TYPE,PROTOCOL, socketpair
+SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL, sort SUBNAME LIST, sort BLOCK LIST,
+sort LIST, splice ARRAY,OFFSET,LENGTH,LIST, splice ARRAY,OFFSET,LENGTH,
+splice ARRAY,OFFSET, split /PATTERN/,EXPR,LIMIT, split /PATTERN/,EXPR,
+split /PATTERN/, split, sprintf FORMAT, LIST, sqrt EXPR, sqrt, srand EXPR,
+srand, stat FILEHANDLE, stat EXPR, stat, study SCALAR, study, sub BLOCK,
+sub NAME, sub NAME BLOCK, substr EXPR,OFFSET,LEN,REPLACEMENT, substr
+EXPR,OFFSET,LEN, substr EXPR,OFFSET, symlink OLDFILE,NEWFILE, syscall LIST,
+sysopen FILEHANDLE,FILENAME,MODE, sysopen FILEHANDLE,FILENAME,MODE,PERMS,
+sysread FILEHANDLE,SCALAR,LENGTH,OFFSET, sysread FILEHANDLE,SCALAR,LENGTH,
+sysseek FILEHANDLE,POSITION,WHENCE, system LIST, system PROGRAM LIST,
+syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET, syswrite
+FILEHANDLE,SCALAR,LENGTH, tell FILEHANDLE, tell, telldir DIRHANDLE, tie
+VARIABLE,CLASSNAME,LIST, tied VARIABLE, time, times, tr///, truncate
+FILEHANDLE,LENGTH, truncate EXPR,LENGTH, uc EXPR, uc, ucfirst EXPR,
+ucfirst, umask EXPR, umask, undef EXPR, undef, unlink LIST, unlink, unpack
+TEMPLATE,EXPR, untie VARIABLE, unshift ARRAY,LIST, use Module LIST, use
+Module, use Module VERSION LIST, use VERSION, utime LIST, values HASH, vec
+EXPR,OFFSET,BITS, wait, waitpid PID,FLAGS, wantarray, warn LIST, write
+FILEHANDLE, write EXPR, write, y///
+
+=back
+
+=head2 perlvar - Perl predefined variables
+
+=item DESCRIPTION
+
+=over
+
+=item Predefined Names
+
+$ARG, $_, $E<lt>I<digits>E<gt>, $MATCH, $&, $PREMATCH, $`, $POSTMATCH, $',
+$LAST_PAREN_MATCH, $+, $MULTILINE_MATCHING, $*, input_line_number HANDLE
+EXPR, $INPUT_LINE_NUMBER, $NR, $, input_record_separator HANDLE EXPR,
+$INPUT_RECORD_SEPARATOR, $RS, $/, autoflush HANDLE EXPR, $OUTPUT_AUTOFLUSH,
+$|, output_field_separator HANDLE EXPR, $OUTPUT_FIELD_SEPARATOR, $OFS, $,,
+output_record_separator HANDLE EXPR, $OUTPUT_RECORD_SEPARATOR, $ORS, $\,
+$LIST_SEPARATOR, $", $SUBSCRIPT_SEPARATOR, $SUBSEP, $;, $OFMT, $#,
+format_page_number HANDLE EXPR, $FORMAT_PAGE_NUMBER, $%,
+format_lines_per_page HANDLE EXPR, $FORMAT_LINES_PER_PAGE, $=,
+format_lines_left HANDLE EXPR, $FORMAT_LINES_LEFT, $-, format_name HANDLE
+EXPR, $FORMAT_NAME, $~, format_top_name HANDLE EXPR, $FORMAT_TOP_NAME, $^,
+format_line_break_characters HANDLE EXPR, $FORMAT_LINE_BREAK_CHARACTERS,
+$:, format_formfeed HANDLE EXPR, $FORMAT_FORMFEED, $^L, $ACCUMULATOR, $^A,
+$CHILD_ERROR, $?, $OS_ERROR, $ERRNO, $!, $EXTENDED_OS_ERROR, $^E,
+$EVAL_ERROR, $@, $PROCESS_ID, $PID, $$, $REAL_USER_ID, $UID, $<,
+$EFFECTIVE_USER_ID, $EUID, $>, $REAL_GROUP_ID, $GID, $(,
+$EFFECTIVE_GROUP_ID, $EGID, $), $PROGRAM_NAME, $0, $[, $PERL_VERSION, $],
+$DEBUGGING, $^D, $SYSTEM_FD_MAX, $^F, $^H, $INPLACE_EDIT, $^I, $^M,
+$OSNAME, $^O, $PERLDB, $^P, 0x01, 0x02, 0x04, 0x08, 0x10, 0x20, $^R, $^S,
+$BASETIME, $^T, $WARNING, $^W, $EXECUTABLE_NAME, $^X, $ARGV, @ARGV, @INC,
+@_, %INC, %ENV $ENV{expr}, %SIG $SIG{expr}
+
+=item Error Indicators
+
+=back
+
+=head2 perlsub - Perl subroutines
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Private Variables via C<my()>
+
+=item Peristent Private Variables
+
+=item Temporary Values via local()
+
+=item Passing Symbol Table Entries (typeglobs)
+
+=item When to Still Use local()
+
+1. You need to give a global variable a temporary value, especially C<$_>,
+2. You need to create a local file or directory handle or a local function,
+3. You want to temporarily change just one element of an array or hash
+
+=item Pass by Reference
+
+=item Prototypes
+
+=item Constant Functions
+
+=item Overriding Builtin Functions
+
+=item Autoloading
+
+=back
+
+=item SEE ALSO
+
+=head2 perlmod - Perl modules (packages and symbol tables)
+
+=item DESCRIPTION
+
+=over
+
+=item Packages
+
+=item Symbol Tables
+
+=item Package Constructors and Destructors
+
+=item Perl Classes
+
+=item Perl Modules
+
+=back
+
+=item SEE ALSO
+
+=head2 perlmodlib - constructing new Perl modules and finding existing ones
+
+=item DESCRIPTION
+
+=item THE PERL MODULE LIBRARY
+
+=over
+
+=item Pragmatic Modules
+
+use autouse MODULE => qw(sub1 sub2 sub3), blib, diagnostics, integer, less,
+lib, locale, ops, overload, re, sigtrap, strict, subs, vmsish, vars
+
+=item Standard Modules
+
+AnyDBM_File, AutoLoader, AutoSplit, Benchmark, CPAN, CPAN::FirstTime,
+CPAN::Nox, Carp, Class::Struct, Config, Cwd, DB_File, Devel::SelfStubber,
+DirHandle, DynaLoader, English, Env, Exporter, ExtUtils::Embed,
+ExtUtils::Install, ExtUtils::Liblist, ExtUtils::MM_OS2, ExtUtils::MM_Unix,
+ExtUtils::MM_VMS, ExtUtils::MakeMaker, ExtUtils::Manifest,
+ExtUtils::Mkbootstrap, ExtUtils::Mksymlists, ExtUtils::testlib, Fatal,
+Fcntl, File::Basename, File::CheckTree, File::Compare, File::Copy,
+File::Find, File::Path, File::stat, FileCache, FileHandle, FindBin,
+GDBM_File, Getopt::Long, Getopt::Std, I18N::Collate, IO, IO::File,
+IO::Handle, IO::Pipe, IO::Seekable, IO::Select, IO::Socket, IPC::Open2,
+IPC::Open3, Math::BigFloat, Math::BigInt, Math::Complex, Math::Trig,
+NDBM_File, Net::Ping, Net::hostent, Net::netent, Net::protoent,
+Net::servent, Opcode, Pod::Text, POSIX, SDBM_File, Safe, Search::Dict,
+SelectSaver, SelfLoader, Shell, Socket, Symbol, Sys::Hostname, Sys::Syslog,
+Term::Cap, Term::Complete, Term::ReadLine, Test::Harness, Text::Abbrev,
+Text::ParseWords, Text::Soundex, Text::Tabs, Text::Wrap, Tie::Hash,
+Tie::RefHash, Tie::Scalar, Tie::SubstrHash, Time::Local, Time::gmtime,
+Time::localtime, Time::tm, UNIVERSAL, User::grent, User::pwent
+
+=item Extension Modules
+
+=back
+
+=item CPAN
+
+Language Extensions and Documentation Tools, Development Support, Operating
+System Interfaces, Networking, Device Control (modems) and InterProcess
+Communication, Data Types and Data Type Utilities, Database Interfaces,
+User Interfaces, Interfaces to / Emulations of Other Programming Languages,
+File Names, File Systems and File Locking (see also File Handles), String
+Processing, Language Text Processing, Parsing, and Searching, Option,
+Argument, Parameter, and Configuration File Processing,
+Internationalization and Locale, Authentication, Security, and Encryption,
+World Wide Web, HTML, HTTP, CGI, MIME, Server and Daemon Utilities,
+Archiving and Compression, Images, Pixmap and Bitmap Manipulation, Drawing,
+and Graphing, Mail and Usenet News, Control Flow Utilities (callbacks and
+exceptions etc), File Handle and Input/Output Stream Utilities,
+Miscellaneous Modules, Africa, Asia, Australasia, Europe, North America,
+South America
+
+=item Modules: Creation, Use, and Abuse
+
+=over
+
+=item Guidelines for Module Creation
+
+Do similar modules already exist in some form?, Try to design the new
+module to be easy to extend and reuse, Some simple style guidelines, Select
+what to export, Select a name for the module, Have you got it right?,
+README and other Additional Files, A description of the
+module/package/extension etc, A copyright notice - see below, Prerequisites
+- what else you may need to have, How to build it - possible changes to
+Makefile.PL etc, How to install it, Recent changes in this release,
+especially incompatibilities, Changes / enhancements you plan to make in
+the future, Adding a Copyright Notice, Give the module a
+version/issue/release number, How to release and distribute a module, Take
+care when changing a released module
+
+=item Guidelines for Converting Perl 4 Library Scripts into Modules
+
+There is no requirement to convert anything, Consider the implications,
+Make the most of the opportunity, The pl2pm utility will get you started,
+Adds the standard Module prologue lines, Converts package specifiers from '
+to ::, Converts die(...) to croak(...), Several other minor changes
+
+=item Guidelines for Reusing Application Code
+
+Complete applications rarely belong in the Perl Module Library, Many
+applications contain some Perl code that could be reused, Break-out the
+reusable code into one or more separate module files, Take the opportunity
+to reconsider and redesign the interfaces, In some cases the 'application'
+can then be reduced to a small
+
+=back
+
+=item NOTE
+
+=head2 perlmodinstall - Installing CPAN Modules
+
+=item DESCRIPTION
+
+=over
+
+=item PREAMBLE
+
+B<DECOMPRESS> the file, B<UNPACK> the file into a directory, B<BUILD> the
+module (sometimes unnecessary), B<INSTALL> the module
+
+=back
+
+=item HEY
+
+=item AUTHOR
+
+=item COPYRIGHT
+
+=head2 perlform - Perl formats
+
+=item DESCRIPTION
+
+=over
+
+=item Format Variables
+
+=back
+
+=item NOTES
+
+=over
+
+=item Footers
+
+=item Accessing Formatting Internals
+
+=back
+
+=item WARNINGS
+
+=head2 perllocale - Perl locale handling (internationalization and
+localization)
+
+=item DESCRIPTION
+
+=item PREPARING TO USE LOCALES
+
+=item USING LOCALES
+
+=over
+
+=item The use locale pragma
+
+=item The setlocale function
+
+=item Finding locales
+
+=item LOCALE PROBLEMS
+
+=item Temporarily fixing locale problems
+
+=item Permanently fixing locale problems
+
+=item Permanently fixing your locale configuration
+
+=item Permanently fixing system locale configuration
+
+=item The localeconv function
+
+=back
+
+=item LOCALE CATEGORIES
+
+=over
+
+=item Category LC_COLLATE: Collation
+
+=item Category LC_CTYPE: Character Types
+
+=item Category LC_NUMERIC: Numeric Formatting
+
+=item Category LC_MONETARY: Formatting of monetary amounts
+
+=item LC_TIME
+
+=item Other categories
+
+=back
+
+=item SECURITY
+
+B<Comparison operators> (C<lt>, C<le>, C<ge>, C<gt> and C<cmp>):,
+B<Case-mapping interpolation> (with C<\l>, C<\L>, C<\u> or C<\U>),
+B<Matching operator> (C<m//>):, B<Substitution operator> (C<s///>):,
+B<In-memory formatting function> (sprintf()):, B<Output formatting
+functions> (printf() and write()):, B<Case-mapping functions> (lc(),
+lcfirst(), uc(), ucfirst()):, B<POSIX locale-dependent functions>
+(localeconv(), strcoll(),strftime(), strxfrm()):, B<POSIX character class
+tests> (isalnum(), isalpha(), isdigit(),isgraph(), islower(), isprint(),
+ispunct(), isspace(), isupper(),
+isxdigit()):
+
+=item ENVIRONMENT
+
+PERL_BADLANG, LC_ALL, LC_CTYPE, LC_COLLATE, LC_MONETARY, LC_NUMERIC,
+LC_TIME, LANG
+
+=item NOTES
+
+=over
+
+=item Backward compatibility
+
+=item I18N:Collate obsolete
+
+=item Sort speed and memory use impacts
+
+=item write() and LC_NUMERIC
+
+=item Freely available locale definitions
+
+=item I18n and l10n
+
+=item An imperfect standard
+
+=back
+
+=item BUGS
+
+=over
+
+=item Broken systems
+
+=back
+
+=item SEE ALSO
+
+=item HISTORY
+
+=head2 perlref - Perl references and nested data structures
+
+=item DESCRIPTION
+
+=over
+
+=item Making References
+
+=item Using References
+
+=item Symbolic references
+
+=item Not-so-symbolic references
+
+=item Pseudo-hashes: Using an array as a hash
+
+=item Function Templates
+
+=back
+
+=item WARNING
+
+=item SEE ALSO
+
+=head2 perldsc - Perl Data Structures Cookbook
+
+=item DESCRIPTION
+
+arrays of arrays, hashes of arrays, arrays of hashes, hashes of hashes,
+more elaborate constructs
+
+=item REFERENCES
+
+=item COMMON MISTAKES
+
+=item CAVEAT ON PRECEDENCE
+
+=item WHY YOU SHOULD ALWAYS C<use strict>
+
+=item DEBUGGING
+
+=item CODE EXAMPLES
+
+=item LISTS OF LISTS
+
+=over
+
+=item Declaration of a LIST OF LISTS
+
+=item Generation of a LIST OF LISTS
+
+=item Access and Printing of a LIST OF LISTS
+
+=back
+
+=item HASHES OF LISTS
+
+=over
+
+=item Declaration of a HASH OF LISTS
+
+=item Generation of a HASH OF LISTS
+
+=item Access and Printing of a HASH OF LISTS
+
+=back
+
+=item LISTS OF HASHES
+
+=over
+
+=item Declaration of a LIST OF HASHES
+
+=item Generation of a LIST OF HASHES
+
+=item Access and Printing of a LIST OF HASHES
+
+=back
+
+=item HASHES OF HASHES
+
+=over
+
+=item Declaration of a HASH OF HASHES
+
+=item Generation of a HASH OF HASHES
+
+=item Access and Printing of a HASH OF HASHES
+
+=back
+
+=item MORE ELABORATE RECORDS
+
+=over
+
+=item Declaration of MORE ELABORATE RECORDS
+
+=item Declaration of a HASH OF COMPLEX RECORDS
+
+=item Generation of a HASH OF COMPLEX RECORDS
+
+=back
+
+=item Database Ties
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 perllol, perlLoL - Manipulating Lists of Lists in Perl
+
+=item DESCRIPTION
+
+=item Declaration and Access of Lists of Lists
+
+=item Growing Your Own
+
+=item Access and Printing
+
+=item Slices
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 perltoot - Tom's object-oriented tutorial for perl
+
+=item DESCRIPTION
+
+=item Creating a Class
+
+=over
+
+=item Object Representation
+
+=item Class Interface
+
+=item Constructors and Instance Methods
+
+=item Planning for the Future: Better Constructors
+
+=item Destructors
+
+=item Other Object Methods
+
+=back
+
+=item Class Data
+
+=over
+
+=item Accessing Class Data
+
+=item Debugging Methods
+
+=item Class Destructors
+
+=item Documenting the Interface
+
+=back
+
+=item Aggregation
+
+=item Inheritance
+
+=over
+
+=item Overridden Methods
+
+=item Multiple Inheritance
+
+=item UNIVERSAL: The Root of All Objects
+
+=back
+
+=item Alternate Object Representations
+
+=over
+
+=item Arrays as Objects
+
+=item Closures as Objects
+
+=back
+
+=item AUTOLOAD: Proxy Methods
+
+=over
+
+=item Autoloaded Data Methods
+
+=item Inherited Autoloaded Data Methods
+
+=back
+
+=item Metaclassical Tools
+
+=over
+
+=item Class::Struct
+
+=item Data Members as Variables
+
+=item NOTES
+
+=item Object Terminology
+
+=back
+
+=item SEE ALSO
+
+=item AUTHOR AND COPYRIGHT
+
+=item COPYRIGHT
+
+=over
+
+=item Acknowledgments
+
+=back
+
+=head2 perlobj - Perl objects
+
+=item DESCRIPTION
+
+=over
+
+=item An Object is Simply a Reference
+
+=item A Class is Simply a Package
+
+=item A Method is Simply a Subroutine
+
+=item Method Invocation
+
+=item Default UNIVERSAL methods
+
+isa(CLASS), can(METHOD), VERSION( [NEED] )
+
+=item Destructors
+
+=item WARNING
+
+=item Summary
+
+=item Two-Phased Garbage Collection
+
+=back
+
+=item SEE ALSO
+
+=head2 perltie - how to hide an object class in a simple variable
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Tying Scalars
+
+TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this
+
+=item Tying Arrays
+
+TIEARRAY classname, LIST, FETCH this, index, STORE this, index, value,
+DESTROY this
+
+=item Tying Hashes
+
+USER, HOME, CLOBBER, LIST, TIEHASH classname, LIST, FETCH this, key, STORE
+this, key, value, DELETE this, key, CLEAR this, EXISTS this, key, FIRSTKEY
+this, NEXTKEY this, lastkey, DESTROY this
+
+=item Tying FileHandles
+
+TIEHANDLE classname, LIST, WRITE this, LIST, PRINT this, LIST, PRINTF this,
+LIST, READ this, LIST, READLINE this, GETC this, CLOSE this, DESTROY this
+
+=item The C<untie> Gotcha
+
+=back
+
+=item SEE ALSO
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 perlbot - Bag'o Object Tricks (the BOT)
+
+=item DESCRIPTION
+
+=item OO SCALING TIPS
+
+=item INSTANCE VARIABLES
+
+=item SCALAR INSTANCE VARIABLES
+
+=item INSTANCE VARIABLE INHERITANCE
+
+=item OBJECT RELATIONSHIPS
+
+=item OVERRIDING SUPERCLASS METHODS
+
+=item USING RELATIONSHIP WITH SDBM
+
+=item THINKING OF CODE REUSE
+
+=item CLASS CONTEXT AND THE OBJECT
+
+=item INHERITING A CONSTRUCTOR
+
+=item DELEGATION
+
+=head2 perlipc - Perl interprocess communication (signals, fifos, pipes,
+safe subprocesses, sockets, and semaphores)
+
+=item DESCRIPTION
+
+=item Signals
+
+=item Named Pipes
+
+=over
+
+=item WARNING
+
+=back
+
+=item Using open() for IPC
+
+=over
+
+=item Filehandles
+
+=item Background Processes
+
+=item Complete Dissociation of Child from Parent
+
+=item Safe Pipe Opens
+
+=item Bidirectional Communication with Another Process
+
+=item Bidirectional Communication with Yourself
+
+=back
+
+=item Sockets: Client/Server Communication
+
+=over
+
+=item Internet Line Terminators
+
+=item Internet TCP Clients and Servers
+
+=item Unix-Domain TCP Clients and Servers
+
+=back
+
+=item TCP Clients with IO::Socket
+
+=over
+
+=item A Simple Client
+
+C<Proto>, C<PeerAddr>, C<PeerPort>
+
+=item A Webget Client
+
+=item Interactive Client with IO::Socket
+
+=back
+
+=item TCP Servers with IO::Socket
+
+Proto, LocalPort, Listen, Reuse
+
+=item UDP: Message Passing
+
+=item SysV IPC
+
+=item NOTES
+
+=item BUGS
+
+=item AUTHOR
+
+=item SEE ALSO
+
+=head2 perldebug - Perl debugging
+
+=item DESCRIPTION
+
+=item The Perl Debugger
+
+=over
+
+=item Debugger Commands
+
+h [command], p expr, x expr, V [pkg [vars]], X [vars], T, s [expr], n
+[expr], E<lt>CRE<gt>, c [line|sub], l, l min+incr, l min-max, l line, l
+subname, -, w [line], f filename, /pattern/, ?pattern?, L, S [[!]pattern],
+t, t expr, b [line] [condition], b subname [condition], b postpone subname
+[condition], b load filename, b compile subname, d [line], D, a [line]
+command, A, W [expr], W, O [opt[=val]] [opt"val"] [opt?]..,
+C<recallCommand>, C<ShellBang>, C<pager>, C<tkRunning>, C<signalLevel>,
+C<warnLevel>, C<dieLevel>, C<AutoTrace>, C<LineInfo>, C<inhibit_exit>,
+C<PrintRet>, C<ornaments>, C<frame>, C<maxTraceLen>, C<arrayDepth>,
+C<hashDepth>, C<compactDump>, C<veryCompact>, C<globPrint>, C<DumpDBFiles>,
+C<DumpPackages>, C<DumpReused>, C<quote>, C<HighBit>, C<undefPrint>,
+C<UsageOnly>, C<TTY>, C<noTTY>, C<ReadLine>, C<NonStop>, E<lt> [ command ],
+E<lt>E<lt> command, E<gt> command, E<gt>E<gt> command, { [ command ], {{
+command, ! number, ! -number, ! pattern, !! cmd, H -number, q or ^D, R,
+|dbcmd, ||dbcmd, command, m expr, m package
+
+=item Debugger input/output
+
+Prompt, Multiline commands, Stack backtrace, Listing, Frame listing
+
+=item Debugging compile-time statements
+
+=item Debugger Customization
+
+=item Readline Support
+
+=item Editor Support for Debugging
+
+=item The Perl Profiler
+
+=item Debugger support in perl
+
+=item Debugger Internals
+
+=item Other resources
+
+=item BUGS
+
+=back
+
+=item Debugging Perl memory usage
+
+=over
+
+=item Using C<$ENV{PERL_DEBUG_MSTATS}>
+
+C<buckets SMALLEST(APPROX)..GREATEST(APPROX)>, Free/Used, C<Total sbrk():
+SBRKed/SBRKs:CONTINUOUS>, C<pad: 0>, C<heads: 2192>, C<chain: 0>, C<tail:
+6144>
+
+=item Example of using B<-DL> switch
+
+C<717>, C<002>, C<054>, C<602>, C<702>, C<704>
+
+=item B<-DL> details
+
+C<!!!>, C<!!>, C<!>
+
+=item Limitations of B<-DL> statistic
+
+=back
+
+=item Debugging regular expressions
+
+=over
+
+=item Compile-time output
+
+C<anchored> I<STRING> C<at> I<POS>, C<floating> I<STRING> C<at>
+I<POS1..POS2>, C<matching floating/anchored>, C<minlen>, C<stclass>
+I<TYPE>, C<noscan>, C<isall>, C<GPOS>, C<plus>, C<implicit>, C<with eval>,
+C<anchored(TYPE)>
+
+=item Types of nodes
+
+=item Run-time output
+
+=back
+
+=head2 perldiag - various Perl diagnostics
+
+=item DESCRIPTION
+
+=head2 perlsec - Perl security
+
+=item DESCRIPTION
+
+=over
+
+=item Laundering and Detecting Tainted Data
+
+=item Switches On the "#!" Line
+
+=item Cleaning Up Your Path
+
+=item Security Bugs
+
+=item Protecting Your Programs
+
+=back
+
+=item SEE ALSO
+
+=head2 perltrap - Perl traps for the unwary
+
+=item DESCRIPTION
+
+=over
+
+=item Awk Traps
+
+=item C Traps
+
+=item Sed Traps
+
+=item Shell Traps
+
+=item Perl Traps
+
+=item Perl4 to Perl5 Traps
+
+Discontinuance, Deprecation, and BugFix traps, Parsing Traps, Numerical
+Traps, General data type traps, Context Traps - scalar, list contexts,
+Precedence Traps, General Regular Expression Traps using s///, etc,
+Subroutine, Signal, Sorting Traps, OS Traps, DBM Traps, Unclassified Traps
+
+=item Discontinuance, Deprecation, and BugFix traps
+
+Discontinuance, Deprecation, BugFix, Discontinuance, Discontinuance,
+Discontinuance, BugFix, Discontinuance, Discontinuance, BugFix,
+Discontinuance, Discontinuance, Deprecation, Discontinuance
+
+=item Parsing Traps
+
+Parsing, Parsing, Parsing, Parsing
+
+=item Numerical Traps
+
+Numerical, Numerical, Numerical
+
+=item General data type traps
+
+(Arrays), (Arrays), (Hashes), (Globs), (Globs), (Scalar String),
+(Constants), (Scalars), (Variable Suicide)
+
+=item Context Traps - scalar, list contexts
+
+(list context), (scalar context), (scalar context), (list, builtin)
+
+=item Precedence Traps
+
+Precedence, Precedence, Precedence, Precedence, Precedence, Precedence,
+Precedence
+
+=item General Regular Expression Traps using s///, etc.
+
+Regular Expression, Regular Expression, Regular Expression, Regular
+Expression, Regular Expression, Regular Expression, Regular Expression,
+Regular Expression
+
+=item Subroutine, Signal, Sorting Traps
+
+(Signals), (Sort Subroutine), warn() won't let you specify a filehandle
+
+=item OS Traps
+
+(SysV), (SysV)
+
+=item Interpolation Traps
+
+Interpolation, Interpolation, Interpolation, Interpolation, Interpolation,
+Interpolation, Interpolation, Interpolation, Interpolation
+
+=item DBM Traps
+
+DBM, DBM
+
+=item Unclassified Traps
+
+C<require>/C<do> trap using returned value, C<split> on empty string with
+LIMIT specified
+
+=back
+
+=head2 perlport - Writing portable Perl
+
+=item DESCRIPTION
+
+Not all Perl programs have to be portable, The vast majority of Perl B<is>
+portable
+
+=item ISSUES
+
+=over
+
+=item Newlines
+
+=item File Paths
+
+=item System Interaction
+
+=item Interprocess Communication (IPC)
+
+=item External Subroutines (XS)
+
+=item Standard Modules
+
+=item Time and Date
+
+=item System Resources
+
+=item Security
+
+=item Style
+
+=back
+
+=item CPAN TESTERS
+
+Mailing list: cpan-testers@perl.org, Testing results:
+C<http://www.connect.net/gbarr/cpan-test/>
+
+=item PLATFORMS
+
+=over
+
+=item Unix
+
+=item DOS and Derivatives
+
+The djgpp environment for DOS, C<http://www.delorie.com/djgpp/>, The EMX
+environment for DOS, OS/2, etc.
+C<emx@iaehv.nl>,C<http://www.juge.com/bbs/Hobb.19.html>, Build instructions
+for Win32, L<perlwin32>, The ActiveState Pages,
+C<http://www.activestate.com/>
+
+=item MacPerl
+
+The MacPerl Pages, C<http://www.ptf.com/macperl/>, The MacPerl mailing
+list, C<mac-perl-request@iis.ee.ethz.ch>
+
+=item VMS
+
+L<perlvms.pod>, vmsperl list, C<vmsperl-request@newman.upenn.edu>, vmsperl
+on the web, C<http://www.sidhe.org/vmsperl/index.html>
+
+=item EBCDIC Platforms
+
+perl-mvs list, AS/400 Perl information at C<http://as400.rochester.ibm.com>
+
+=item Other perls
+
+Atari, Guido Flohr's page C<http://stud.uni-sb.de/~gufl0000/>, HP 300
+MPE/iX C<http://www.cccd.edu/~markb/perlix.html>, Novell Netware
+
+=back
+
+=item FUNCTION IMPLEMENTATIONS
+
+=over
+
+=item Alphabetical Listing of Perl Functions
+
+-I<X> FILEHANDLE, -I<X> EXPR, -I<X>, binmode FILEHANDLE, chmod LIST, chown
+LIST, chroot FILENAME, chroot, crypt PLAINTEXT,SALT, dbmclose HASH, dbmopen
+HASH,DBNAME,MODE, dump LABEL, exec LIST, fcntl FILEHANDLE,FUNCTION,SCALAR,
+flock FILEHANDLE,OPERATION, fork, getlogin, getpgrp PID, getppid,
+getpriority WHICH,WHO, getpwnam NAME, getgrnam NAME, getnetbyname NAME,
+getpwuid UID, getgrgid GID, getnetbyaddr ADDR,ADDRTYPE, getprotobynumber
+NUMBER, getservbyport PORT,PROTO, getpwent, getgrent, gethostent,
+getnetent, getprotoent, getservent, setpwent, setgrent, sethostent
+STAYOPEN, setnetent STAYOPEN, setprotoent STAYOPEN, setservent STAYOPEN,
+endpwent, endgrent, endhostent, endnetent, endprotoent, endservent,
+getsockopt SOCKET,LEVEL,OPTNAME, glob EXPR, glob, ioctl
+FILEHANDLE,FUNCTION,SCALAR, kill LIST, link OLDFILE,NEWFILE, lstat
+FILEHANDLE, lstat EXPR, lstat, msgctl ID,CMD,ARG, msgget KEY,FLAGS, msgsnd
+ID,MSG,FLAGS, msgrcv ID,VAR,SIZE,TYPE,FLAGS, open FILEHANDLE,EXPR, open
+FILEHANDLE, pipe READHANDLE,WRITEHANDLE, readlink EXPR, readlink, select
+RBITS,WBITS,EBITS,TIMEOUT, semctl ID,SEMNUM,CMD,ARG, semget
+KEY,NSEMS,FLAGS, semop KEY,OPSTRING, setpgrp PID,PGRP, setpriority
+WHICH,WHO,PRIORITY, setsockopt SOCKET,LEVEL,OPTNAME,OPTVAL, shmctl
+ID,CMD,ARG, shmget KEY,SIZE,FLAGS, shmread ID,VAR,POS,SIZE, shmwrite
+ID,STRING,POS,SIZE, socketpair SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL, stat
+FILEHANDLE, stat EXPR, stat, symlink OLDFILE,NEWFILE, syscall LIST, system
+LIST, times, truncate FILEHANDLE,LENGTH, truncate EXPR,LENGTH, umask EXPR,
+umask, utime LIST, wait, waitpid PID,FLAGS
+
+=back
+
+=item AUTHORS / CONTRIBUTORS
+
+=item VERSION
+
+=head2 perlstyle - Perl style guide
+
+=item DESCRIPTION
+
+=head2 perlpod - plain old documentation
+
+=item DESCRIPTION
+
+=over
+
+=item Verbatim Paragraph
+
+=item Command Paragraph
+
+=item Ordinary Block of Text
+
+=item The Intent
+
+=item Embedding Pods in Perl Modules
+
+=item Common Pod Pitfalls
+
+=back
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 perlbook - Perl book information
+
+=item DESCRIPTION
+
+=head2 perlembed - how to embed perl in your C program
+
+=item DESCRIPTION
+
+=over
+
+=item PREAMBLE
+
+B<Use C from Perl?>, B<Use a Unix program from Perl?>, B<Use Perl from
+Perl?>, B<Use C from C?>, B<Use Perl from C?>
+
+=item ROADMAP
+
+=item Compiling your C program
+
+=item Adding a Perl interpreter to your C program
+
+=item Calling a Perl subroutine from your C program
+
+=item Evaluating a Perl statement from your C program
+
+=item Performing Perl pattern matches and substitutions from your C program
+
+=item Fiddling with the Perl stack from your C program
+
+=item Maintaining a persistent interpreter
+
+=item Maintaining multiple interpreter instances
+
+=item Using Perl modules, which themselves use C libraries, from your C
+program
+
+=back
+
+=item Embedding Perl under Win32
+
+=item MORAL
+
+=item AUTHOR
+
+=item COPYRIGHT
+
+=head2 perlapio - perl's IO abstraction interface.
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+B<PerlIO *>, B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()>,
+B<PerlIO_open(path, mode)>, B<PerlIO_fdopen(fd,mode)>,
+B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)>,
+B<PerlIO_stdoutf(fmt,...)>, B<PerlIO_read(f,buf,count)>,
+B<PerlIO_write(f,buf,count)>, B<PerlIO_close(f)>, B<PerlIO_puts(f,s)>,
+B<PerlIO_putc(f,c)>, B<PerlIO_ungetc(f,c)>, B<PerlIO_getc(f)>,
+B<PerlIO_eof(f)>, B<PerlIO_error(f)>, B<PerlIO_fileno(f)>,
+B<PerlIO_clearerr(f)>, B<PerlIO_flush(f)>, B<PerlIO_tell(f)>,
+B<PerlIO_seek(f,o,w)>, B<PerlIO_getpos(f,p)>, B<PerlIO_setpos(f,p)>,
+B<PerlIO_rewind(f)>, B<PerlIO_tmpfile()>
+
+=over
+
+=item Co-existence with stdio
+
+B<PerlIO_importFILE(f,flags)>, B<PerlIO_exportFILE(f,flags)>,
+B<PerlIO_findFILE(f)>, B<PerlIO_releaseFILE(p,f)>, B<PerlIO_setlinebuf(f)>,
+B<PerlIO_has_cntptr(f)>, B<PerlIO_get_ptr(f)>, B<PerlIO_get_cnt(f)>,
+B<PerlIO_canset_cnt(f)>, B<PerlIO_fast_gets(f)>,
+B<PerlIO_set_ptrcnt(f,p,c)>, B<PerlIO_set_cnt(f,c)>, B<PerlIO_has_base(f)>,
+B<PerlIO_get_base(f)>, B<PerlIO_get_bufsiz(f)>
+
+=back
+
+=head2 perlxs - XS language reference manual
+
+=item DESCRIPTION
+
+=over
+
+=item Introduction
+
+=item On The Road
+
+=item The Anatomy of an XSUB
+
+=item The Argument Stack
+
+=item The RETVAL Variable
+
+=item The MODULE Keyword
+
+=item The PACKAGE Keyword
+
+=item The PREFIX Keyword
+
+=item The OUTPUT: Keyword
+
+=item The CODE: Keyword
+
+=item The INIT: Keyword
+
+=item The NO_INIT Keyword
+
+=item Initializing Function Parameters
+
+=item Default Parameter Values
+
+=item The PREINIT: Keyword
+
+=item The SCOPE: Keyword
+
+=item The INPUT: Keyword
+
+=item Variable-length Parameter Lists
+
+=item The C_ARGS: Keyword
+
+=item The PPCODE: Keyword
+
+=item Returning Undef And Empty Lists
+
+=item The REQUIRE: Keyword
+
+=item The CLEANUP: Keyword
+
+=item The BOOT: Keyword
+
+=item The VERSIONCHECK: Keyword
+
+=item The PROTOTYPES: Keyword
+
+=item The PROTOTYPE: Keyword
+
+=item The ALIAS: Keyword
+
+=item The INTERFACE: Keyword
+
+=item The INTERFACE_MACRO: Keyword
+
+=item The INCLUDE: Keyword
+
+=item The CASE: Keyword
+
+=item The & Unary Operator
+
+=item Inserting Comments and C Preprocessor Directives
+
+=item Using XS With C++
+
+=item Interface Strategy
+
+=item Perl Objects And C Structures
+
+=item The Typemap
+
+=back
+
+=item EXAMPLES
+
+=item XS VERSION
+
+=item AUTHOR
+
+=head2 perlxstut, perlXStut - Tutorial for XSUBs
+
+=item DESCRIPTION
+
+=over
+
+=item VERSION CAVEAT
+
+=item DYNAMIC VERSUS STATIC
+
+=item EXAMPLE 1
+
+=item EXAMPLE 2
+
+=item WHAT HAS GONE ON?
+
+=item WRITING GOOD TEST SCRIPTS
+
+=item EXAMPLE 3
+
+=item WHAT'S NEW HERE?
+
+=item INPUT AND OUTPUT PARAMETERS
+
+=item THE XSUBPP COMPILER
+
+=item THE TYPEMAP FILE
+
+=item WARNING
+
+=item EXAMPLE 4
+
+=item WHAT HAS HAPPENED HERE?
+
+=item SPECIFYING ARGUMENTS TO XSUBPP
+
+=item THE ARGUMENT STACK
+
+=item EXTENDING YOUR EXTENSION
+
+=item DOCUMENTING YOUR EXTENSION
+
+=item INSTALLING YOUR EXTENSION
+
+=item SEE ALSO
+
+=item Author
+
+=item Last Changed
+
+=back
+
+=head2 perlguts - Perl's Internal Functions
+
+=item DESCRIPTION
+
+=item Variables
+
+=over
+
+=item Datatypes
+
+=item What is an "IV"?
+
+=item Working with SVs
+
+=item What's Really Stored in an SV?
+
+=item Working with AVs
+
+=item Working with HVs
+
+=item Hash API Extensions
+
+=item References
+
+=item Blessed References and Class Objects
+
+=item Creating New Variables
+
+=item Reference Counts and Mortality
+
+=item Stashes and Globs
+
+=item Double-Typed SVs
+
+=item Magic Variables
+
+=item Assigning Magic
+
+=item Magic Virtual Tables
+
+=item Finding Magic
+
+=item Understanding the Magic of Tied Hashes and Arrays
+
+=item Localizing changes
+
+C<SAVEINT(int i)>, C<SAVEIV(IV i)>, C<SAVEI32(I32 i)>, C<SAVELONG(long i)>,
+C<SAVESPTR(s)>, C<SAVEPPTR(p)>, C<SAVEFREESV(SV *sv)>, C<SAVEFREEOP(OP
+*op)>, C<SAVEFREEPV(p)>, C<SAVECLEARSV(SV *sv)>, C<SAVEDELETE(HV *hv, char
+*key, I32 length)>, C<SAVEDESTRUCTOR(f,p)>, C<SAVESTACK_POS()>, C<SV*
+save_scalar(GV *gv)>, C<AV* save_ary(GV *gv)>, C<HV* save_hash(GV *gv)>,
+C<void save_item(SV *item)>, C<void save_list(SV **sarg, I32 maxsarg)>,
+C<SV* save_svref(SV **sptr)>, C<void save_aptr(AV **aptr)>, C<void
+save_hptr(HV **hptr)>
+
+=back
+
+=item Subroutines
+
+=over
+
+=item XSUBs and the Argument Stack
+
+=item Calling Perl Routines from within C Programs
+
+=item Memory Allocation
+
+=item PerlIO
+
+=item Putting a C value on Perl stack
+
+=item Scratchpads
+
+=item Scratchpads and recursion
+
+=back
+
+=item Compiled code
+
+=over
+
+=item Code tree
+
+=item Examining the tree
+
+=item Compile pass 1: check routines
+
+=item Compile pass 1a: constant folding
+
+=item Compile pass 2: context propagation
+
+=item Compile pass 3: peephole optimization
+
+=back
+
+=item API LISTING
+
+av_clear, av_extend, av_fetch, AvFILL, av_len, av_make, av_pop, av_push,
+av_shift, av_store, av_undef, av_unshift, CLASS, Copy, croak, CvSTASH,
+PL_DBsingle, PL_DBsub, PL_DBtrace, dMARK, dORIGMARK, PL_dowarn, dSP,
+dXSARGS, dXSI32, do_binmode, ENTER, EXTEND, fbm_compile, fbm_instr,
+FREETMPS, G_ARRAY, G_DISCARD, G_EVAL, GIMME, GIMME_V, G_NOARGS, G_SCALAR,
+gv_fetchmeth, gv_fetchmethod, gv_fetchmethod_autoload, G_VOID, gv_stashpv,
+gv_stashsv, GvSV, HEf_SVKEY, HeHASH, HeKEY, HeKLEN, HePV, HeSVKEY,
+HeSVKEY_force, HeSVKEY_set, HeVAL, hv_clear, hv_delayfree_ent, hv_delete,
+hv_delete_ent, hv_exists, hv_exists_ent, hv_fetch, hv_fetch_ent,
+hv_free_ent, hv_iterinit, hv_iterkey, hv_iterkeysv, hv_iternext,
+hv_iternextsv, hv_iterval, hv_magic, HvNAME, hv_store, hv_store_ent,
+hv_undef, isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE, isUPPER, items, ix,
+LEAVE, looks_like_number, MARK, mg_clear, mg_copy, mg_find, mg_free,
+mg_get, mg_len, mg_magical, mg_set, Move, PL_na, New, newAV, Newc,
+newCONSTSUB, newHV, newRV_inc, newRV_noinc, NEWSV, newSViv, newSVnv,
+newSVpv, newSVpvf, newSVpvn, newSVrv, newSVsv, newXS, newXSproto, Newz,
+Nullav, Nullch, Nullcv, Nullhv, Nullsv, ORIGMARK, perl_alloc,
+perl_call_argv, perl_call_method, perl_call_pv, perl_call_sv,
+perl_construct, perl_destruct, perl_eval_sv, perl_eval_pv, perl_free,
+perl_get_av, perl_get_cv, perl_get_hv, perl_get_sv, perl_parse,
+perl_require_pv, perl_run, POPi, POPl, POPp, POPn, POPs, PUSHMARK, PUSHi,
+PUSHn, PUSHp, PUSHs, PUSHu, PUTBACK, Renew, Renewc, RETVAL, safefree,
+safemalloc, saferealloc, savepv, savepvn, SAVETMPS, SP, SPAGAIN, ST, strEQ,
+strGE, strGT, strLE, strLT, strNE, strnEQ, strnNE, sv_2mortal, sv_bless,
+sv_catpv, sv_catpv_mg, sv_catpvn, sv_catpvn_mg, sv_catpvf, sv_catpvf_mg,
+sv_catsv, sv_catsv_mg, sv_chop, sv_cmp, SvCUR, SvCUR_set, sv_dec,
+sv_derived_from, sv_derived_from, SvEND, sv_eq, SvGETMAGIC, SvGROW,
+sv_grow, sv_inc, sv_insert, SvIOK, SvIOK_off, SvIOK_on, SvIOK_only, SvIOKp,
+sv_isa, sv_isobject, SvIV, SvIVX, SvLEN, sv_len, sv_magic, sv_mortalcopy,
+sv_newmortal, SvNIOK, SvNIOK_off, SvNIOKp, PL_sv_no, SvNOK, SvNOK_off,
+SvNOK_on, SvNOK_only, SvNOKp, SvNV, SvNVX, SvOK, SvOOK, SvPOK, SvPOK_off,
+SvPOK_on, SvPOK_only, SvPOKp, SvPV, SvPV_force, SvPVX, SvREFCNT,
+SvREFCNT_dec, SvREFCNT_inc, SvROK, SvROK_off, SvROK_on, SvRV, SvSETMAGIC,
+sv_setiv, sv_setiv_mg, sv_setnv, sv_setnv_mg, sv_setpv, sv_setpv_mg,
+sv_setpviv, sv_setpviv_mg, sv_setpvn, sv_setpvn_mg, sv_setpvf,
+sv_setpvf_mg, sv_setref_iv, sv_setref_nv, sv_setref_pv, sv_setref_pvn,
+SvSetSV, SvSetSV_nosteal, sv_setsv, sv_setsv_mg, sv_setuv, sv_setuv_mg,
+SvSTASH, SvTAINT, SvTAINTED, SvTAINTED_off, SvTAINTED_on, SVt_IV, SVt_PV,
+SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SVt_NV, SvTRUE, SvTYPE, svtype,
+PL_sv_undef, sv_unref, SvUPGRADE, sv_upgrade, sv_usepvn, sv_usepvn_mg,
+sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale),
+sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, used_locale), SvUV,
+SvUVX, PL_sv_yes, THIS, toLOWER, toUPPER, warn, XPUSHi, XPUSHn, XPUSHp,
+XPUSHs, XPUSHu, XS, XSRETURN, XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO,
+XSRETURN_NV, XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNV,
+XST_mNO, XST_mPV, XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK,
+Zero
+
+=item AUTHORS
+
+=head2 perlcall - Perl calling conventions from C
+
+=item DESCRIPTION
+
+An Error Handler, An Event Driven Program
+
+=item THE PERL_CALL FUNCTIONS
+
+B<perl_call_sv>, B<perl_call_pv>, B<perl_call_method>, B<perl_call_argv>
+
+=item FLAG VALUES
+
+=over
+
+=item G_VOID
+
+=item G_SCALAR
+
+=item G_ARRAY
+
+=item G_DISCARD
+
+=item G_NOARGS
+
+=item G_EVAL
+
+=item G_KEEPERR
+
+=item Determining the Context
+
+=back
+
+=item KNOWN PROBLEMS
+
+=item EXAMPLES
+
+=over
+
+=item No Parameters, Nothing returned
+
+=item Passing Parameters
+
+=item Returning a Scalar
+
+=item Returning a list of values
+
+=item Returning a list in a scalar context
+
+=item Returning Data from Perl via the parameter list
+
+=item Using G_EVAL
+
+=item Using G_KEEPERR
+
+=item Using perl_call_sv
+
+=item Using perl_call_argv
+
+=item Using perl_call_method
+
+=item Using GIMME_V
+
+=item Using Perl to dispose of temporaries
+
+=item Strategies for storing Callback Context Information
+
+1. Ignore the problem - Allow only 1 callback, 2. Create a sequence of
+callbacks - hard wired limit, 3. Use a parameter to map to the Perl
+callback
+
+=item Alternate Stack Manipulation
+
+=item Creating and calling an anonymous subroutine in C
+
+=back
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=item DATE
+
+=head2 perlhist - the Perl history records
+
+=item DESCRIPTION
+
+=item INTRODUCTION
+
+=item THE KEEPERS OF THE PUMPKIN
+
+=over
+
+=item PUMPKIN?
+
+=back
+
+=item THE RECORDS
+
+=over
+
+=item SELECTED RELEASE SIZES
+
+=item SELECTED PATCH SIZES
+
+=back
+
+=item THE KEEPERS OF THE RECORDS
+
+=head1 PRAGMA DOCUMENTATION
+
+=head2 attrs - set/get attributes of a subroutine
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+method, locked
+
+=head2 re - Perl pragma to alter regular expression behaviour
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 autouse - postpone load of modules until a function is used
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item WARNING
+
+=item AUTHOR
+
+=item SEE ALSO
+
+=head2 base - Establish IS-A relationship with base class at compile time
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item SEE ALSO
+
+=head2 blib - Use MakeMaker's uninstalled version of a package
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 constant - Perl pragma to declare constants
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTES
+
+=item TECHNICAL NOTE
+
+=item BUGS
+
+=item AUTHOR
+
+=item COPYRIGHT
+
+=head2 diagnostics - Perl compiler pragma to force verbose warning
+diagnostics
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item The C<diagnostics> Pragma
+
+=item The I<splain> Program
+
+=back
+
+=item EXAMPLES
+
+=item INTERNALS
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 fields - compile-time class fields
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item SEE ALSO
+
+=head2 integer - Perl pragma to compute arithmetic in integer instead of
+double
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 less - perl pragma to request less of something from the compiler
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 lib - manipulate @INC at compile time
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item ADDING DIRECTORIES TO @INC
+
+=item DELETING DIRECTORIES FROM @INC
+
+=item RESTORING ORIGINAL @INC
+
+=back
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 locale - Perl pragma to use and avoid POSIX locales for built-in
+operations
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 overload - Package for overloading perl operations
+
+=item SYNOPSIS
+
+=item CAVEAT SCRIPTOR
+
+=item DESCRIPTION
+
+=over
+
+=item Declaration of overloaded functions
+
+=item Calling Conventions for Binary Operations
+
+FALSE, TRUE, C<undef>
+
+=item Calling Conventions for Unary Operations
+
+=item Overloadable Operations
+
+I<Arithmetic operations>, I<Comparison operations>, I<Bit operations>,
+I<Increment and decrement>, I<Transcendental functions>, I<Boolean, string
+and numeric conversion>, I<Special>
+
+=item Inheritance and overloading
+
+Strings as values of C<use overload> directive, Overloading of an operation
+is inherited by derived classes
+
+=back
+
+=item SPECIAL SYMBOLS FOR C<use overload>
+
+=over
+
+=item Last Resort
+
+=item Fallback
+
+C<undef>, TRUE, defined, but FALSE
+
+=item Copy Constructor
+
+B<Example>
+
+=back
+
+=item MAGIC AUTOGENERATION
+
+I<Assignment forms of arithmetic operations>, I<Conversion operations>,
+I<Increment and decrement>, C<abs($a)>, I<Unary minus>, I<Negation>,
+I<Concatenation>, I<Comparison operations>, I<Copy operator>
+
+=item WARNING
+
+=item Run-time Overloading
+
+=item Public functions
+
+overload::StrVal(arg), overload::Overloaded(arg), overload::Method(obj,op)
+
+=item Overloading constants
+
+integer, float, binary, q, qr
+
+=item IMPLEMENTATION
+
+=item AUTHOR
+
+=item DIAGNOSTICS
+
+=item BUGS
+
+=head2 sigtrap - Perl pragma to enable simple signal handling
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item OPTIONS
+
+=over
+
+=item SIGNAL HANDLERS
+
+B<stack-trace>, B<die>, B<handler> I<your-handler>
+
+=item SIGNAL LISTS
+
+B<normal-signals>, B<error-signals>, B<old-interface-signals>
+
+=item OTHER
+
+B<untrapped>, B<any>, I<signal>, I<number>
+
+=back
+
+=item EXAMPLES
+
+=head2 strict - Perl pragma to restrict unsafe constructs
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+C<strict refs>, C<strict vars>, C<strict subs>
+
+=head2 subs - Perl pragma to predeclare sub names
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 vars - Perl pragma to predeclare global variable names
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head1 MODULE DOCUMENTATION
+
+=head2 AnyDBM_File - provide framework for multiple DBMs
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item DBM Comparisons
+
+[0], [1], [2], [3]
+
+=back
+
+=item SEE ALSO
+
+=head2 AutoLoader - load subroutines only on demand
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Subroutine Stubs
+
+=item Using B<AutoLoader>'s AUTOLOAD Subroutine
+
+=item Overriding B<AutoLoader>'s AUTOLOAD Subroutine
+
+=item Package Lexicals
+
+=item B<AutoLoader> vs. B<SelfLoader>
+
+=back
+
+=item CAVEATS
+
+=item SEE ALSO
+
+=head2 AutoSplit - split a package for autoloading
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+$keep, $check, $modtime
+
+=over
+
+=item Multiple packages
+
+=back
+
+=item DIAGNOSTICS
+
+=head2 B - The Perl Compiler
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item OVERVIEW OF CLASSES
+
+=over
+
+=item SV-RELATED CLASSES
+
+=item B::SV METHODS
+
+REFCNT, FLAGS
+
+=item B::IV METHODS
+
+IV, IVX, needs64bits, packiv
+
+=item B::NV METHODS
+
+NV, NVX
+
+=item B::RV METHODS
+
+RV
+
+=item B::PV METHODS
+
+PV
+
+=item B::PVMG METHODS
+
+MAGIC, SvSTASH
+
+=item B::MAGIC METHODS
+
+MOREMAGIC, PRIVATE, TYPE, FLAGS, OBJ, PTR
+
+=item B::PVLV METHODS
+
+TARGOFF, TARGLEN, TYPE, TARG
+
+=item B::BM METHODS
+
+USEFUL, PREVIOUS, RARE, TABLE
+
+=item B::GV METHODS
+
+NAME, STASH, SV, IO, FORM, AV, HV, EGV, CV, CVGEN, LINE, FILEGV, GvREFCNT,
+FLAGS
+
+=item B::IO METHODS
+
+LINES, PAGE, PAGE_LEN, LINES_LEFT, TOP_NAME, TOP_GV, FMT_NAME, FMT_GV,
+BOTTOM_NAME, BOTTOM_GV, SUBPROCESS, IoTYPE, IoFLAGS
+
+=item B::AV METHODS
+
+FILL, MAX, OFF, ARRAY, AvFLAGS
+
+=item B::CV METHODS
+
+STASH, START, ROOT, GV, FILEGV, DEPTH, PADLIST, OUTSIDE, XSUB, XSUBANY
+
+=item B::HV METHODS
+
+FILL, MAX, KEYS, RITER, NAME, PMROOT, ARRAY
+
+=item OP-RELATED CLASSES
+
+=item B::OP METHODS
+
+next, sibling, ppaddr, desc, targ, type, seq, flags, private
+
+=item B::UNOP METHOD
+
+first
+
+=item B::BINOP METHOD
+
+last
+
+=item B::LOGOP METHOD
+
+other
+
+=item B::CONDOP METHODS
+
+true, false
+
+=item B::LISTOP METHOD
+
+children
+
+=item B::PMOP METHODS
+
+pmreplroot, pmreplstart, pmnext, pmregexp, pmflags, pmpermflags, precomp
+
+=item B::SVOP METHOD
+
+sv
+
+=item B::GVOP METHOD
+
+gv
+
+=item B::PVOP METHOD
+
+pv
+
+=item B::LOOP METHODS
+
+redoop, nextop, lastop
+
+=item B::COP METHODS
+
+label, stash, filegv, cop_seq, arybase, line
+
+=back
+
+=item FUNCTIONS EXPORTED BY C<B>
+
+main_cv, main_root, main_start, comppadlist, sv_undef, sv_yes, sv_no,
+walkoptree(OP, METHOD), walkoptree_debug(DEBUG), walksymtable(SYMREF,
+METHOD, RECURSE), svref_2object(SV), ppname(OPNUM), hash(STR), cast_I32(I),
+minus_c, cstring(STR), class(OBJ), threadsv_names, byteload_fh(FILEHANDLE)
+
+=item AUTHOR
+
+=head2 B::Asmdata - Autogenerated data about Perl ops, used to generate
+bytecode
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 B::Assembler - Assemble Perl bytecode
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 B::Bblock - Walk basic blocks
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 B::Bytecode - Perl compiler's bytecode backend
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item OPTIONS
+
+B<-ofilename>, B<-->, B<-f>, B<-fcompress-nullops>,
+B<-fomit-sequence-numbers>, B<-fbypass-nullops>, B<-fstrip-syntax-tree>,
+B<-On>, B<-D>, B<-Do>, B<-Db>, B<-Da>, B<-DC>, B<-S>, B<-m>
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 B::C - Perl compiler's C backend
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item OPTIONS
+
+B<-ofilename>, B<-v>, B<-->, B<-uPackname>, B<-D>, B<-Do>, B<-Dc>, B<-DA>,
+B<-DC>, B<-DM>, B<-f>, B<-fcog>, B<-fno-cog>, B<-On>
+
+=item EXAMPLES
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 B::CC - Perl compiler's optimized C translation backend
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item OPTIONS
+
+B<-ofilename>, B<-v>, B<-->, B<-uPackname>, B<-mModulename>, B<-D>, B<-Dr>,
+B<-DO>, B<-Ds>, B<-Dp>, B<-Dq>, B<-Dl>, B<-Dt>, B<-f>,
+B<-ffreetmps-each-bblock>, B<-ffreetmps-each-loop>, B<-fomit-taint>, B<-On>
+
+=item EXAMPLES
+
+=item BUGS
+
+=item DIFFERENCES
+
+=over
+
+=item Loops
+
+=item Context of ".."
+
+=item Arithmetic
+
+=item Deprecated features
+
+=back
+
+=item AUTHOR
+
+=head2 B::Debug - Walk Perl syntax tree, printing debug info about ops
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 B::Deparse - Perl compiler backend to produce perl code
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item OPTIONS
+
+B<-p>, B<-u>I<PACKAGE>, B<-l>, B<-s>I<LETTERS>, B<C>
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 B::Disassembler - Disassemble Perl bytecode
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 B::Lint - Perl lint
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item OPTIONS AND LINT CHECKS
+
+B<context>, B<implicit-read> and B<implicit-write>, B<dollar-underscore>,
+B<private-names>, B<undefined-subs>, B<regexp-variables>, B<all>, B<none>
+
+=item NON LINT-CHECK OPTIONS
+
+B<-u Package>
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 B::O, O - Generic interface to Perl Compiler backends
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item CONVENTIONS
+
+=item IMPLEMENTATION
+
+=item AUTHOR
+
+=head2 B::Showlex - Show lexical variables used in functions or files
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 B::Stackobj - Helper module for CC backend
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 B::Terse - Walk Perl syntax tree, printing terse info about ops
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 B::Xref - Generates cross reference reports for Perl programs
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item OPTIONS
+
+C<-oFILENAME>, C<-r>, C<-D[tO]>
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 Benchmark - benchmark running times of code
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Methods
+
+new, debug
+
+=item Standard Exports
+
+timeit(COUNT, CODE), timethis ( COUNT, CODE, [ TITLE, [ STYLE ]] ),
+timethese ( COUNT, CODEHASHREF, [ STYLE ] ), timediff ( T1, T2 ), timestr (
+TIMEDIFF, [ STYLE, [ FORMAT ] ] )
+
+=item Optional Exports
+
+clearcache ( COUNT ), clearallcache ( ), disablecache ( ), enablecache ( )
+
+=back
+
+=item NOTES
+
+=item INHERITANCE
+
+=item CAVEATS
+
+=item AUTHORS
+
+=item MODIFICATION HISTORY
+
+=head2 CGI - Simple Common Gateway Interface Class
+
+=item SYNOPSIS
+
+=item ABSTRACT
+
+=item DESCRIPTION
+
+=over
+
+=item PROGRAMMING STYLE
+
+=item CALLING CGI.PM ROUTINES
+
+1. Use another name for the argument, if one is available. Forexample,
+-value is an alias for -values, 2. Change the capitalization, e.g. -Values,
+3. Put quotes around the argument name, e.g. '-values'
+
+=item CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
+
+=item CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
+
+=item FETCHING A LIST OF KEYWORDS FROM THE QUERY:
+
+=item FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
+
+=item FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
+
+=item SETTING THE VALUE(S) OF A NAMED PARAMETER:
+
+=item APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
+
+=item IMPORTING ALL PARAMETERS INTO A NAMESPACE:
+
+=item DELETING A PARAMETER COMPLETELY:
+
+=item DELETING ALL PARAMETERS:
+
+=item DIRECT ACCESS TO THE PARAMETER LIST:
+
+=item SAVING THE STATE OF THE SCRIPT TO A FILE:
+
+=item USING THE FUNCTION-ORIENTED INTERFACE
+
+B<:cgi>, B<:form>, B<:html2>, B<:html3>, B<:netscape>, B<:html>,
+B<:standard>, B<:all>
+
+=item PRAGMAS
+
+-any, -compile, -nph, -autoload, -no_debug, -private_tempfiles
+
+=back
+
+=item GENERATING DYNAMIC DOCUMENTS
+
+=over
+
+=item CREATING A STANDARD HTTP HEADER:
+
+=item GENERATING A REDIRECTION HEADER
+
+=item CREATING THE HTML DOCUMENT HEADER
+
+B<Parameters:>, 4, 5, 6..
+
+=item ENDING THE HTML DOCUMENT:
+
+=item CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
+
+=item OBTAINING THE SCRIPT'S URL
+
+B<-absolute>, B<-relative>, B<-full>, B<-path> (B<-path_info>), B<-query>
+(B<-query_string>)
+
+=back
+
+=item CREATING STANDARD HTML ELEMENTS:
+
+=over
+
+=item PROVIDING ARGUMENTS TO HTML SHORTCUTS
+
+=item THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
+
+=item HTML SHORTCUTS AND LIST INTERPOLATION
+
+=item NON-STANDARD HTML SHORTCUTS
+
+=back
+
+=item CREATING FILL-OUT FORMS:
+
+=over
+
+=item CREATING AN ISINDEX TAG
+
+=item STARTING AND ENDING A FORM
+
+B<application/x-www-form-urlencoded>, B<multipart/form-data>
+
+=item CREATING A TEXT FIELD
+
+B<Parameters>
+
+=item CREATING A BIG TEXT FIELD
+
+=item CREATING A PASSWORD FIELD
+
+=item CREATING A FILE UPLOAD FIELD
+
+B<Parameters>
+
+=item CREATING A POPUP MENU
+
+=item CREATING A SCROLLING LIST
+
+B<Parameters:>
+
+=item CREATING A GROUP OF RELATED CHECKBOXES
+
+B<Parameters:>
+
+=item CREATING A STANDALONE CHECKBOX
+
+B<Parameters:>
+
+=item CREATING A RADIO BUTTON GROUP
+
+B<Parameters:>
+
+=item CREATING A SUBMIT BUTTON
+
+B<Parameters:>
+
+=item CREATING A RESET BUTTON
+
+=item CREATING A DEFAULT BUTTON
+
+=item CREATING A HIDDEN FIELD
+
+B<Parameters:>
+
+=item CREATING A CLICKABLE IMAGE BUTTON
+
+B<Parameters:>, 3.The third option (-align, optional) is an alignment type,
+and may be
+TOP, BOTTOM or MIDDLE
+
+=item CREATING A JAVASCRIPT ACTION BUTTON
+
+=back
+
+=item NETSCAPE COOKIES
+
+1. an expiration time, 2. a domain, 3. a path, 4. a "secure" flag,
+B<-name>, B<-value>, B<-path>, B<-domain>, B<-expires>, B<-secure>
+
+=item WORKING WITH NETSCAPE FRAMES
+
+1. Create a <Frameset> document, 2. Specify the destination for the
+document in the HTTP header, 3. Specify the destination for the document in
+the <FORM> tag
+
+=item LIMITED SUPPORT FOR CASCADING STYLE SHEETS
+
+=item DEBUGGING
+
+=over
+
+=item DUMPING OUT ALL THE NAME/VALUE PAIRS
+
+=back
+
+=item FETCHING ENVIRONMENT VARIABLES
+
+B<accept()>, B<raw_cookie()>, B<user_agent()>, B<path_info()>,
+B<path_translated()>, B<remote_host()>, B<script_name()>Return the script
+name as a partial URL, for self-refering
+scripts, B<referer()>, B<auth_type ()>, B<server_name ()>, B<virtual_host
+()>, B<server_software ()>, B<remote_user ()>, B<user_name ()>,
+B<request_method()>
+
+=item USING NPH SCRIPTS
+
+In the B<use> statement, By calling the B<nph()> method:, By using B<-nph>
+parameters in the B<header()> and B<redirect()> statements:
+
+=item Server Push
+
+multipart_init()
+multipart_init(-boundary=>$boundary);, multipart_start(), multipart_end()
+
+=item Avoiding Denial of Service Attacks
+
+B<$CGI::POST_MAX>, B<$CGI::DISABLE_UPLOADS>, B<1. On a script-by-script
+basis>, B<2. Globally for all scripts>
+
+=item COMPATIBILITY WITH CGI-LIB.PL
+
+=item AUTHOR INFORMATION
+
+=item CREDITS
+
+Matt Heffron (heffron@falstaff.css.beckman.com), James Taylor
+(james.taylor@srs.gov), Scott Anguish <sanguish@digifix.com>, Mike Jewell
+(mlj3u@virginia.edu), Timothy Shimmin (tes@kbs.citri.edu.au), Joergen Haegg
+(jh@axis.se), Laurent Delfosse (delfosse@csgrad1.cs.wvu.edu), Richard
+Resnick (applepi1@aol.com), Craig Bishop (csb@barwonwater.vic.gov.au), Tony
+Curtis (tc@vcpc.univie.ac.at), Tim Bunce (Tim.Bunce@ig.co.uk), Tom
+Christiansen (tchrist@convex.com), Andreas Koenig
+(k@franz.ww.TU-Berlin.DE), Tim MacKenzie (Tim.MacKenzie@fulcrum.com.au),
+Kevin B. Hendricks (kbhend@dogwood.tyler.wm.edu), Stephen Dahmen
+(joyfire@inxpress.net), Ed Jordan (ed@fidalgo.net), David Alan Pisoni
+(david@cnation.com), Doug MacEachern (dougm@opengroup.org), Robin Houston
+(robin@oneworld.org), ...and many many more..
+
+=item A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
+
+=item BUGS
+
+=item SEE ALSO
+
+=head2 CGI::Apache - Make things work with CGI.pm against Perl-Apache API
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTE 1
+
+=item NOTE 2
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 CGI::Carp, B<CGI::Carp> - CGI routines for writing to the HTTPD (or
+other) error log
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item REDIRECTING ERROR MESSAGES
+
+=item MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
+
+=over
+
+=item Changing the default message
+
+=back
+
+=item CHANGE LOG
+
+=item AUTHORS
+
+=item SEE ALSO
+
+=head2 CGI::Cookie - Interface to Netscape Cookies
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item USING CGI::Cookie
+
+B<1. expiration date>, B<2. domain>, B<3. path>, B<4. secure flag>
+
+=over
+
+=item Creating New Cookies
+
+=item Sending the Cookie to the Browser
+
+=item Recovering Previous Cookies
+
+=item Manipulating Cookies
+
+B<name()>, B<value()>, B<domain()>, B<path()>, B<expires()>
+
+=back
+
+=item AUTHOR INFORMATION
+
+=item BUGS
+
+=item SEE ALSO
+
+=head2 CGI::Fast - CGI Interface for Fast CGI
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item OTHER PIECES OF THE PUZZLE
+
+=item WRITING FASTCGI PERL SCRIPTS
+
+=item INSTALLING FASTCGI SCRIPTS
+
+=item USING FASTCGI SCRIPTS AS CGI SCRIPTS
+
+=item CAVEATS
+
+=item AUTHOR INFORMATION
+
+=item BUGS
+
+=item SEE ALSO
+
+=head2 CGI::Push - Simple Interface to Server Push
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item USING CGI::Push
+
+-next_page, -last_page, -type, -delay, -cookie, -target, -expires
+
+=over
+
+=item Heterogeneous Pages
+
+=item Changing the Page Delay on the Fly
+
+=back
+
+=item INSTALLING CGI::Push SCRIPTS
+
+=item CAVEATS
+
+=item AUTHOR INFORMATION
+
+=item BUGS
+
+=item SEE ALSO
+
+=head2 CGI::Switch - Try more than one constructors and return the first
+object available
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 CPAN - query, download and build perl modules from CPAN sites
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Interactive Mode
+
+Searching for authors, bundles, distribution files and modules, make, test,
+install, clean modules or distributions, readme, look module or
+distribution, Signals
+
+=item CPAN::Shell
+
+=item autobundle
+
+=item recompile
+
+=item The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
+
+=item ProgrammerE<39>s interface
+
+expand($type,@things), Programming Examples
+
+=item Methods in the four
+
+=item Cache Manager
+
+=item Bundles
+
+=item Prerequisites
+
+=item Finding packages and VERSION
+
+=item Debugging
+
+=item Floppy, Zip, and all that Jazz
+
+=back
+
+=item CONFIGURATION
+
+o conf E<lt>scalar optionE<gt>, o conf E<lt>scalar optionE<gt>
+E<lt>valueE<gt>, o conf E<lt>list optionE<gt>, o conf E<lt>list optionE<gt>
+[shift|pop], o conf E<lt>list optionE<gt> [unshift|push|splice]
+E<lt>listE<gt>
+
+=over
+
+=item CD-ROM support
+
+=back
+
+=item SECURITY
+
+=item EXPORT
+
+=item BUGS
+
+=item AUTHOR
+
+=item SEE ALSO
+
+=head2 CPAN::FirstTime - Utility for CPAN::Config file Initialization
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 CPANox, CPAN::Nox - Wrapper around CPAN.pm without using any XS
+module
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item SEE ALSO
+
+=head2 Carp, carp - warn of errors (from perspective of caller)
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Forcing a Stack Trace
+
+=back
+
+=head2 Class::Struct - declare struct-like datatypes as Perl classes
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item The C<struct()> function
+
+=item Element Types and Accessor Methods
+
+Scalar (C<'$'> or C<'*$'>), Array (C<'@'> or C<'*@'>), Hash (C<'%'> or
+C<'*%'>), Class (C<'Class_Name'> or C<'*Class_Name'>)
+
+=back
+
+=item EXAMPLES
+
+Example 1, Example 2
+
+=item Author and Modification History
+
+=head2 Cwd, getcwd - get pathname of current working directory
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 DB_File - Perl5 access to Berkeley DB version 1.x
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO>
+
+=over
+
+=item Using DB_File with Berkeley DB version 2
+
+=item Interface to Berkeley DB
+
+=item Opening a Berkeley DB Database File
+
+=item Default Parameters
+
+=item In Memory Databases
+
+=back
+
+=item DB_HASH
+
+=over
+
+=item A Simple Example
+
+=back
+
+=item DB_BTREE
+
+=over
+
+=item Changing the BTREE sort order
+
+=item Handling Duplicate Keys
+
+=item The get_dup() Method
+
+=item Matching Partial Keys
+
+=back
+
+=item DB_RECNO
+
+=over
+
+=item The 'bval' Option
+
+=item A Simple Example
+
+=item Extra Methods
+
+B<$X-E<gt>push(list) ;>, B<$value = $X-E<gt>pop ;>, B<$X-E<gt>shift>,
+B<$X-E<gt>unshift(list) ;>, B<$X-E<gt>length>
+
+=item Another Example
+
+=back
+
+=item THE API INTERFACE
+
+B<$status = $X-E<gt>get($key, $value [, $flags]) ;>, B<$status =
+$X-E<gt>put($key, $value [, $flags]) ;>, B<$status = $X-E<gt>del($key [,
+$flags]) ;>, B<$status = $X-E<gt>fd ;>, B<$status = $X-E<gt>seq($key,
+$value, $flags) ;>, B<$status = $X-E<gt>sync([$flags]) ;>
+
+=item HINTS AND TIPS
+
+=over
+
+=item Locking Databases
+
+=item Sharing Databases With C Applications
+
+=item The untie() Gotcha
+
+=back
+
+=item COMMON QUESTIONS
+
+=over
+
+=item Why is there Perl source in my database?
+
+=item How do I store complex data structures with DB_File?
+
+=item What does "Invalid Argument" mean?
+
+=item What does "Bareword 'DB_File' not allowed" mean?
+
+=back
+
+=item HISTORY
+
+=item BUGS
+
+=item AVAILABILITY
+
+=item COPYRIGHT
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 Data::Dumper - stringified perl data structures, suitable for both
+printing and C<eval>
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Methods
+
+I<PACKAGE>->new(I<ARRAYREF [>, I<ARRAYREF]>), I<$OBJ>->Dump I<or>
+I<PACKAGE>->Dump(I<ARRAYREF [>, I<ARRAYREF]>), I<$OBJ>->Dumpxs I<or>
+I<PACKAGE>->Dumpxs(I<ARRAYREF [>, I<ARRAYREF]>),
+I<$OBJ>->Seen(I<[HASHREF]>), I<$OBJ>->Values(I<[ARRAYREF]>),
+I<$OBJ>->Names(I<[ARRAYREF]>), I<$OBJ>->Reset
+
+=item Functions
+
+Dumper(I<LIST>), DumperX(I<LIST>)
+
+=item Configuration Variables or Methods
+
+$Data::Dumper::Indent I<or> I<$OBJ>->Indent(I<[NEWVAL]>),
+$Data::Dumper::Purity I<or> I<$OBJ>->Purity(I<[NEWVAL]>),
+$Data::Dumper::Pad I<or> I<$OBJ>->Pad(I<[NEWVAL]>),
+$Data::Dumper::Varname I<or> I<$OBJ>->Varname(I<[NEWVAL]>),
+$Data::Dumper::Useqq I<or> I<$OBJ>->Useqq(I<[NEWVAL]>),
+$Data::Dumper::Terse I<or> I<$OBJ>->Terse(I<[NEWVAL]>),
+$Data::Dumper::Freezer I<or> $I<OBJ>->Freezer(I<[NEWVAL]>),
+$Data::Dumper::Toaster I<or> $I<OBJ>->Toaster(I<[NEWVAL]>),
+$Data::Dumper::Deepcopy I<or> $I<OBJ>->Deepcopy(I<[NEWVAL]>),
+$Data::Dumper::Quotekeys I<or> $I<OBJ>->Quotekeys(I<[NEWVAL]>),
+$Data::Dumper::Bless I<or> $I<OBJ>->Bless(I<[NEWVAL]>)
+
+=item Exports
+
+Dumper
+
+=back
+
+=item EXAMPLES
+
+=item BUGS
+
+=item AUTHOR
+
+=item VERSION
+
+=item SEE ALSO
+
+=head2 Devel::SelfStubber - generate stubs for a SelfLoading module
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 DirHandle - supply object methods for directory handles
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 English - use nice English (or awk) names for ugly punctuation
+variables
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 Env - perl module that imports environment variables
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 Exporter - Implements default import method for modules
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Selecting What To Export
+
+=item Specialised Import Lists
+
+=item Exporting without using Export's import method
+
+=item Module Version Checking
+
+=item Managing Unknown Symbols
+
+=item Tag Handling Utility Functions
+
+=back
+
+=head2 ExtUtils::Command - utilities to replace common UNIX commands in
+Makefiles etc.
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+cat, eqtime src dst, rm_f files..., rm_f files..., touch files .., mv
+source... destination, cp source... destination, chmod mode files.., mkpath
+directory.., test_f file
+
+=item BUGS
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item @EXPORT
+
+=item FUNCTIONS
+
+xsinit(), Examples, ldopts(), Examples, perl_inc(), ccflags(), ccdlflags(),
+ccopts(), xsi_header(), xsi_protos(@modules), xsi_body(@modules)
+
+=item EXAMPLES
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 ExtUtils::Install - install files from here to there
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 ExtUtils::Installed - Inventory management of installed modules
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item USAGE
+
+=item FUNCTIONS
+
+new(), modules(), files(), directories(), directory_tree(), validate(),
+packlist(), version()
+
+=item EXAMPLE
+
+=item AUTHOR
+
+=head2 ExtUtils::Liblist - determine libraries to use and how to use them
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+For static extensions, For dynamic extensions, For dynamic extensions
+
+=over
+
+=item EXTRALIBS
+
+=item LDLOADLIBS and LD_RUN_PATH
+
+=item BSLOADLIBS
+
+=back
+
+=item PORTABILITY
+
+=over
+
+=item VMS implementation
+
+=item Win32 implementation
+
+=back
+
+=item SEE ALSO
+
+=head2 ExtUtils::MM_OS2 - methods to override UN*X behaviour in
+ExtUtils::MakeMaker
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item METHODS
+
+=over
+
+=item Preloaded methods
+
+canonpath, catdir, catfile, curdir, rootdir, updir
+
+=item SelfLoaded methods
+
+c_o (o), cflags (o), clean (o), const_cccmd (o), const_config (o),
+const_loadlibs (o), constants (o), depend (o), dir_target (o), dist (o),
+dist_basics (o), dist_ci (o), dist_core (o), dist_dir (o), dist_test (o),
+dlsyms (o), dynamic (o), dynamic_bs (o), dynamic_lib (o), exescan,
+extliblist, file_name_is_absolute, find_perl
+
+=item Methods to actually produce chunks of text for the Makefile
+
+fixin, force (o), guess_name, has_link_code, init_dirscan, init_main,
+init_others, install (o), installbin (o), libscan (o), linkext (o), lsdir,
+macro (o), makeaperl (o), makefile (o), manifypods (o), maybe_command,
+maybe_command_in_dirs, needs_linking (o), nicetext, parse_version,
+parse_abstract, pasthru (o), path, perl_script, perldepend (o), ppd,
+perm_rw (o), perm_rwx (o), pm_to_blib, post_constants (o), post_initialize
+(o), postamble (o), prefixify, processPL (o), realclean (o),
+replace_manpage_separator, static (o), static_lib (o), staticmake (o),
+subdir_x (o), subdirs (o), test (o), test_via_harness (o), test_via_script
+(o), tool_autosplit (o), tools_other (o), tool_xsubpp (o), top_targets (o),
+writedoc, xs_c (o), xs_o (o), perl_archive, export_list
+
+=back
+
+=item SEE ALSO
+
+=head2 ExtUtils::MM_VMS - methods to override UN*X behaviour in
+ExtUtils::MakeMaker
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Methods always loaded
+
+eliminate_macros, fixpath, catdir, catfile, wraplist, curdir (override),
+rootdir (override), updir (override)
+
+=item SelfLoaded methods
+
+guess_name (override), find_perl (override), path (override), maybe_command
+(override), maybe_command_in_dirs (override), perl_script (override),
+file_name_is_absolute (override), replace_manpage_separator, init_others
+(override), constants (override), cflags (override), const_cccmd
+(override), pm_to_blib (override), tool_autosplit (override), tool_sxubpp
+(override), xsubpp_version (override), tools_other (override), dist
+(override), c_o (override), xs_c (override), xs_o (override), top_targets
+(override), dlsyms (override), dynamic_lib (override), dynamic_bs
+(override), static_lib (override), manifypods (override), processPL
+(override), installbin (override), subdir_x (override), clean (override),
+realclean (override), dist_basics (override), dist_core (override),
+dist_dir (override), dist_test (override), install (override), perldepend
+(override), makefile (override), test (override), test_via_harness
+(override), test_via_script (override), makeaperl (override), nicetext
+(override)
+
+=back
+
+=head2 ExtUtils::MM_Win32 - methods to override UN*X behaviour in
+ExtUtils::MakeMaker
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+catfile, constants (o), static_lib (o), dynamic_bs (o), dynamic_lib (o),
+canonpath, perl_script, pm_to_blib, test_via_harness (o), tool_autosplit
+(override), tools_other (o), xs_o (o), top_targets (o), manifypods (o),
+dist_ci (o), dist_core (o), pasthru (o)
+
+=head2 ExtUtils::MakeMaker - create an extension Makefile
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item How To Write A Makefile.PL
+
+=item Default Makefile Behaviour
+
+=item make test
+
+=item make testdb
+
+=item make install
+
+=item PREFIX and LIB attribute
+
+=item AFS users
+
+=item Static Linking of a new Perl Binary
+
+=item Determination of Perl Library and Installation Locations
+
+=item Which architecture dependent directory?
+
+=item Using Attributes and Parameters
+
+C, CCFLAGS, CONFIG, CONFIGURE, DEFINE, DIR, DISTNAME, DL_FUNCS, DL_VARS,
+EXCLUDE_EXT, EXE_FILES, NO_VC, FIRST_MAKEFILE, FULLPERL, H, IMPORTS, INC,
+INCLUDE_EXT, INSTALLARCHLIB, INSTALLBIN, INSTALLDIRS, INSTALLMAN1DIR,
+INSTALLMAN3DIR, INSTALLPRIVLIB, INSTALLSCRIPT, INSTALLSITELIB,
+INSTALLSITEARCH, INST_ARCHLIB, INST_BIN, INST_EXE, INST_LIB, INST_MAN1DIR,
+INST_MAN3DIR, INST_SCRIPT, LDFROM, LIBPERL_A, LIB, LIBS, LINKTYPE,
+MAKEAPERL, MAKEFILE, MAN1PODS, MAN3PODS, MAP_TARGET, MYEXTLIB, NAME,
+NEEDS_LINKING, NOECHO, NORECURS, OBJECT, OPTIMIZE, PERL, PERLMAINCC,
+PERL_ARCHLIB, PERL_LIB, PERL_SRC, PERM_RW, PERM_RWX, PL_FILES, PM,
+PMLIBDIRS, PREFIX, PREREQ_PM, SKIP, TYPEMAPS, VERSION, VERSION_FROM, XS,
+XSOPT, XSPROTOARG, XS_VERSION
+
+=item Additional lowercase attributes
+
+clean, depend, dist, dynamic_lib, installpm, linkext, macro, realclean,
+tool_autosplit
+
+=item Overriding MakeMaker Methods
+
+=item Hintsfile support
+
+=item Distribution Support
+
+make distcheck, make skipcheck, make distclean, make manifest,
+make distdir, make tardist, make dist, make uutardist, make
+shdist, make zipdist, make ci
+
+=item Disabling an extension
+
+=back
+
+=item SEE ALSO
+
+=item AUTHORS
+
+=head2 ExtUtils::Manifest - utilities to write and check a MANIFEST file
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item MANIFEST.SKIP
+
+=item EXPORT_OK
+
+=item GLOBAL VARIABLES
+
+=item DIAGNOSTICS
+
+C<Not in MANIFEST:> I<file>, C<No such file:> I<file>, C<MANIFEST:> I<$!>,
+C<Added to MANIFEST:> I<file>
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 ExtUtils::Mksymlists - write linker options files for dynamic
+extension
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+NAME, DL_FUNCS, DL_VARS, FILE, FUNCLIST, DLBASE
+
+=item AUTHOR
+
+=item REVISION
+
+=head2 ExtUtils::Packlist - manage .packlist files
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item USAGE
+
+=item FUNCTIONS
+
+new(), read(), write(), validate(), packlist_file()
+
+=item EXAMPLE
+
+=item AUTHOR
+
+=head2 ExtUtils::testlib - add blib/* directories to @INC
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 Fatal - replace functions with equivalents which succeed or die
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 Fcntl - load the C Fcntl.h defines
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTE
+
+=item EXPORTED SYMBOLS
+
+=head2 File::Basename, fileparse - split a pathname into pieces
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+fileparse_set_fstype, fileparse
+
+=item EXAMPLES
+
+C<basename>, C<dirname>
+
+=head2 File::CheckTree, validate - run many filetest checks on a tree
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 File::Compare - Compare files or filehandles
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item RETURN
+
+=item AUTHOR
+
+=head2 File::Copy - Copy files or filehandles
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Special behavior if C<syscopy> is defined (VMS and OS/2)
+
+rmscopy($from,$to[,$date_flag])
+
+=back
+
+=item RETURN
+
+=item AUTHOR
+
+=head2 File::DosGlob - DOS like globbing and then some
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXPORTS (by request only)
+
+=item BUGS
+
+=item AUTHOR
+
+=item HISTORY
+
+=item SEE ALSO
+
+=head2 File::Find, find - traverse a file tree
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item BUGS
+
+=head2 File::Path - create or remove a series of directories
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHORS
+
+=item REVISION
+
+=head2 File::Spec - portably perform operations on file names
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item SEE ALSO
+
+=item AUTHORS
+
+=head2 File::Spec::Mac - File::Spec for MacOS
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item METHODS
+
+canonpath, catdir, catfile, curdir, rootdir, updir, file_name_is_absolute,
+path
+
+=item SEE ALSO
+
+=head2 File::Spec::OS2 - methods for OS/2 file specs
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 File::Spec::Unix - methods used by File::Spec
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item METHODS
+
+canonpath, catdir, catfile, curdir, rootdir, updir, no_upwards,
+file_name_is_absolute, path, join, nativename
+
+=item SEE ALSO
+
+=head2 File::Spec::VMS - methods for VMS file specs
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Methods always loaded
+
+catdir, catfile, curdir (override), rootdir (override), updir (override),
+path (override), file_name_is_absolute (override)
+
+=back
+
+=head2 File::Spec::Win32 - methods for Win32 file specs
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+catfile, canonpath
+
+=head2 File::stat - by-name interface to Perl's built-in stat() functions
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTE
+
+=item AUTHOR
+
+=head2 FileCache - keep more files open than the system permits
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item BUGS
+
+=head2 FileHandle - supply object methods for filehandles
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+$fh->print, $fh->printf, $fh->getline, $fh->getlines
+
+=item SEE ALSO
+
+=head2 FindBin - Locate directory of original perl script
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXPORTABLE VARIABLES
+
+=item KNOWN BUGS
+
+=item AUTHORS
+
+=item COPYRIGHT
+
+=item REVISION
+
+=head2 GDBM_File - Perl5 access to the gdbm library.
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AVAILABILITY
+
+=item BUGS
+
+=item SEE ALSO
+
+=head2 Getopt::Long, GetOptions - extended processing of command line
+options
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+!, +, :s, :i, :f
+
+=over
+
+=item Linkage specification
+
+=item Aliases and abbreviations
+
+=item Non-option call-back routine
+
+=item Option starters
+
+=item Return values and Errors
+
+=back
+
+=item COMPATIBILITY
+
+=item EXAMPLES
+
+=item CONFIGURATION OPTIONS
+
+default, auto_abbrev, getopt_compat, require_order, permute, bundling
+(default: reset), bundling_override (default: reset), ignore_case
+(default: set), ignore_case_always (default: reset), pass_through (default:
+reset), prefix, prefix_pattern, debug (default: reset)
+
+=item OTHER USEFUL VARIABLES
+
+$Getopt::Long::VERSION, $Getopt::Long::error
+
+=item AUTHOR
+
+=item COPYRIGHT AND DISCLAIMER
+
+=head2 Getopt::Std, getopt - Process single-character switches with switch
+clustering
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 I18N::Collate - compare 8-bit scalar data according to the current
+locale
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 IO - load various IO modules
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 IO::lib::IO::File, IO::File - supply object methods for filehandles
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item CONSTRUCTOR
+
+new ([ ARGS ] ), new_tmpfile
+
+=item METHODS
+
+open( FILENAME [,MODE [,PERMS]] )
+
+=item SEE ALSO
+
+=item HISTORY
+
+=head2 IO::lib::IO::Handle, IO::Handle - supply object methods for I/O
+handles
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item CONSTRUCTOR
+
+new (), new_from_fd ( FD, MODE )
+
+=item METHODS
+
+$fh->fdopen ( FD, MODE ), $fh->opened, $fh->getline, $fh->getlines,
+$fh->ungetc ( ORD ), $fh->write ( BUF, LEN [, OFFSET }\] ), $fh->flush,
+$fh->error, $fh->clearerr, $fh->untaint
+
+=item NOTE
+
+=item SEE ALSO
+
+=item BUGS
+
+=item HISTORY
+
+=head2 IO::lib::IO::Pipe, IO::pipe - supply object methods for pipes
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item CONSTRCUTOR
+
+new ( [READER, WRITER] )
+
+=item METHODS
+
+reader ([ARGS]), writer ([ARGS]), handles ()
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=item COPYRIGHT
+
+=head2 IO::lib::IO::Seekable, IO::Seekable - supply seek based methods for
+I/O objects
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item SEE ALSO
+
+=item HISTORY
+
+=head2 IO::lib::IO::Select, IO::Select - OO interface to the select system
+call
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item CONSTRUCTOR
+
+new ( [ HANDLES ] )
+
+=item METHODS
+
+add ( HANDLES ), remove ( HANDLES ), exists ( HANDLE ), handles, can_read (
+[ TIMEOUT ] ), can_write ( [ TIMEOUT ] ), has_error ( [ TIMEOUT ] ), count
+(), bits(), bits(), select ( READ, WRITE, ERROR [, TIMEOUT ] )
+
+=item EXAMPLE
+
+=item AUTHOR
+
+=item COPYRIGHT
+
+=head2 IO::lib::IO::Socket, IO::Socket - Object interface to socket
+communications
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item CONSTRUCTOR
+
+new ( [ARGS] )
+
+=item METHODS
+
+accept([PKG]), timeout([VAL]), sockopt(OPT [, VAL]), sockdomain, socktype,
+protocol
+
+=item SUB-CLASSES
+
+=over
+
+=item IO::Socket::INET
+
+=item METHODS
+
+sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost
+()
+
+=item IO::Socket::UNIX
+
+=item METHODS
+
+hostpath(), peerpath()
+
+=back
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=item COPYRIGHT
+
+=head2 IPC::Open2, open2 - open a process for both reading and writing
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item WARNING
+
+=item SEE ALSO
+
+=head2 IPC::Open3, open3 - open a process for reading, writing, and error
+handling
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item WARNING
+
+=head2 IPC::SysV - SysV IPC constants
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+ftok( PATH, ID )
+
+=item SEE ALSO
+
+=item AUTHORS
+
+=item COPYRIGHT
+
+=head2 IPC::SysV::Msg, IPC::Msg - SysV Msg IPC object class
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item METHODS
+
+new ( KEY , FLAGS ), id, rcv ( BUF, LEN [, TYPE [, FLAGS ]] ), remove, set
+( STAT ), set ( NAME => VALUE [, NAME => VALUE ...] ), snd ( TYPE, MSG [,
+FLAGS ] ), stat
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=item COPYRIGHT
+
+=head2 IPC::SysV::Semaphore, IPC::Semaphore - SysV Semaphore IPC object
+class
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item METHODS
+
+new ( KEY , NSEMS , FLAGS ), getall, getncnt ( SEM ), getpid ( SEM ),
+getval ( SEM ), getzcnt ( SEM ), id, op ( OPLIST ), remove, set ( STAT ),
+set ( NAME => VALUE [, NAME => VALUE ...] ), setall ( VALUES ), setval ( N
+, VALUE ), stat
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=item COPYRIGHT
+
+=head2 Math::BigFloat - Arbitrary length float math package
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+number format, Error returns 'NaN', Division is computed to
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 Math::BigInt - Arbitrary size integer math package
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+Canonical notation, Input, Output
+
+=item EXAMPLES
+
+=item Autocreating constants
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 Math::Complex - complex numbers and associated mathematical
+functions
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item OPERATIONS
+
+=item CREATION
+
+=item STRINGIFICATION
+
+=item USAGE
+
+=item ERRORS DUE TO DIVISION BY ZERO OR LOGARITHM OF ZERO
+
+=item ERRORS DUE TO INDIGESTIBLE ARGUMENTS
+
+=item BUGS
+
+=item AUTHORS
+
+=head2 Math::Trig - trigonometric functions
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item TRIGONOMETRIC FUNCTIONS
+
+B<tan>
+
+=over
+
+=item ERRORS DUE TO DIVISION BY ZERO
+
+=item SIMPLE (REAL) ARGUMENTS, COMPLEX RESULTS
+
+=back
+
+=item PLANE ANGLE CONVERSIONS
+
+=item RADIAL COORDINATE CONVERSIONS
+
+=over
+
+=item COORDINATE SYSTEMS
+
+=item 3-D ANGLE CONVERSIONS
+
+cartesian_to_cylindrical, cartesian_to_spherical, cylindrical_to_cartesian,
+cylindrical_to_spherical, spherical_to_cartesian, spherical_to_cylindrical
+
+=back
+
+=item GREAT CIRCLE DISTANCES
+
+=item EXAMPLES
+
+=item BUGS
+
+=item AUTHORS
+
+=head2 NDBM_File - Tied access to ndbm files
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 Net::Ping - check a remote host for reachability
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item Functions
+
+Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);, $p->ping($host [,
+$timeout]);, $p->close();, pingecho($host [, $timeout]);
+
+=back
+
+=item WARNING
+
+=item NOTES
+
+=head2 Net::hostent - by-name interface to Perl's built-in gethost*()
+functions
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXAMPLES
+
+=item NOTE
+
+=item AUTHOR
+
+=head2 Net::netent - by-name interface to Perl's built-in getnet*()
+functions
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXAMPLES
+
+=item NOTE
+
+=item AUTHOR
+
+=head2 Net::protoent - by-name interface to Perl's built-in getproto*()
+functions
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTE
+
+=item AUTHOR
+
+=head2 Net::servent - by-name interface to Perl's built-in getserv*()
+functions
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXAMPLES
+
+=item NOTE
+
+=item AUTHOR
+
+=head2 ODBM_File - Tied access to odbm files
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 Opcode - Disable named opcodes when compiling perl code
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTE
+
+=item WARNING
+
+=item Operator Names and Operator Lists
+
+an operator name (opname), an operator tag name (optag), a negated opname
+or optag, an operator set (opset)
+
+=item Opcode Functions
+
+opcodes, opset (OP, ...), opset_to_ops (OPSET), opset_to_hex (OPSET),
+full_opset, empty_opset, invert_opset (OPSET), verify_opset (OPSET, ...),
+define_optag (OPTAG, OPSET), opmask_add (OPSET), opmask, opdesc (OP, ...),
+opdump (PAT)
+
+=item Manipulating Opsets
+
+=item TO DO (maybe)
+
+=item Predefined Opcode Tags
+
+:base_core, :base_mem, :base_loop, :base_io, :base_orig, :base_math,
+:base_thread, :default, :filesys_read, :sys_db, :browse, :filesys_open,
+:filesys_write, :subprocess, :ownprocess, :others, :still_to_be_decided,
+:dangerous
+
+=item SEE ALSO
+
+=item AUTHORS
+
+=head2 Opcode::Safe, Safe - Compile and execute code in restricted
+compartments
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+a new namespace, an operator mask
+
+=item WARNING
+
+=over
+
+=item RECENT CHANGES
+
+=item Methods in class Safe
+
+permit (OP, ...), permit_only (OP, ...), deny (OP, ...), deny_only (OP,
+...), trap (OP, ...), untrap (OP, ...), share (NAME, ...), share_from
+(PACKAGE, ARRAYREF), varglob (VARNAME), reval (STRING), rdo (FILENAME),
+root (NAMESPACE), mask (MASK)
+
+=item Some Safety Issues
+
+Memory, CPU, Snooping, Signals, State Changes
+
+=item AUTHOR
+
+=back
+
+=head2 Opcode::ops, ops - Perl pragma to restrict unsafe operations when
+compiling
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item SEE ALSO
+
+=head2 POSIX - Perl interface to IEEE Std 1003.1
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTE
+
+=item CAVEATS
+
+=item FUNCTIONS
+
+_exit, abort, abs, access, acos, alarm, asctime, asin, assert, atan, atan2,
+atexit, atof, atoi, atol, bsearch, calloc, ceil, chdir, chmod, chown,
+clearerr, clock, close, closedir, cos, cosh, creat, ctermid, ctime,
+cuserid, difftime, div, dup, dup2, errno, execl, execle, execlp, execv,
+execve, execvp, exit, exp, fabs, fclose, fcntl, fdopen, feof, ferror,
+fflush, fgetc, fgetpos, fgets, fileno, floor, fmod, fopen, fork, fpathconf,
+fprintf, fputc, fputs, fread, free, freopen, frexp, fscanf, fseek, fsetpos,
+fstat, ftell, fwrite, getc, getchar, getcwd, getegid, getenv, geteuid,
+getgid, getgrgid, getgrnam, getgroups, getlogin, getpgrp, getpid, getppid,
+getpwnam, getpwuid, gets, getuid, gmtime, isalnum, isalpha, isatty,
+iscntrl, isdigit, isgraph, islower, isprint, ispunct, isspace, isupper,
+isxdigit, kill, labs, ldexp, ldiv, link, localeconv, localtime, log, log10,
+longjmp, lseek, malloc, mblen, mbstowcs, mbtowc, memchr, memcmp, memcpy,
+memmove, memset, mkdir, mkfifo, mktime, modf, nice, offsetof, open,
+opendir, pathconf, pause, perror, pipe, pow, printf, putc, putchar, puts,
+qsort, raise, rand, read, readdir, realloc, remove, rename, rewind,
+rewinddir, rmdir, scanf, setgid, setjmp, setlocale, setpgid, setsid,
+setuid, sigaction, siglongjmp, sigpending, sigprocmask, sigsetjmp,
+sigsuspend, sin, sinh, sleep, sprintf, sqrt, srand, sscanf, stat, strcat,
+strchr, strcmp, strcoll, strcpy, strcspn, strerror, strftime, strlen,
+strncat, strncmp, strncpy, stroul, strpbrk, strrchr, strspn, strstr,
+strtod, strtok, strtol, strtoul, strxfrm, sysconf, system, tan, tanh,
+tcdrain, tcflow, tcflush, tcgetpgrp, tcsendbreak, tcsetpgrp, time, times,
+tmpfile, tmpnam, tolower, toupper, ttyname, tzname, tzset, umask, uname,
+ungetc, unlink, utime, vfprintf, vprintf, vsprintf, wait, waitpid,
+wcstombs, wctomb, write
+
+=item CLASSES
+
+=over
+
+=item POSIX::SigAction
+
+new
+
+=item POSIX::SigSet
+
+new, addset, delset, emptyset, fillset, ismember
+
+=item POSIX::Termios
+
+new, getattr, getcc, getcflag, getiflag, getispeed, getlflag, getoflag,
+getospeed, setattr, setcc, setcflag, setiflag, setispeed, setlflag,
+setoflag, setospeed, Baud rate values, Terminal interface values, c_cc
+field values, c_cflag field values, c_iflag field values, c_lflag field
+values, c_oflag field values
+
+=back
+
+=item PATHNAME CONSTANTS
+
+Constants
+
+=item POSIX CONSTANTS
+
+Constants
+
+=item SYSTEM CONFIGURATION
+
+Constants
+
+=item ERRNO
+
+Constants
+
+=item FCNTL
+
+Constants
+
+=item FLOAT
+
+Constants
+
+=item LIMITS
+
+Constants
+
+=item LOCALE
+
+Constants
+
+=item MATH
+
+Constants
+
+=item SIGNAL
+
+Constants
+
+=item STAT
+
+Constants, Macros
+
+=item STDLIB
+
+Constants
+
+=item STDIO
+
+Constants
+
+=item TIME
+
+Constants
+
+=item UNISTD
+
+Constants
+
+=item WAIT
+
+Constants, Macros
+
+=item CREATION
+
+=head2 Pod::Html - module to convert pod files to HTML
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item ARGUMENTS
+
+help, htmlroot, infile, outfile, podroot, podpath, libpods, netscape,
+nonetscape, index, noindex, recurse, norecurse, title, verbose
+
+=item EXAMPLE
+
+=item AUTHOR
+
+=item BUGS
+
+=item SEE ALSO
+
+=item COPYRIGHT
+
+=head2 Pod::Text - convert POD data to formatted ASCII text
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=item TODO
+
+=head2 SDBM_File - Tied access to sdbm files
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 Search::Dict, look - search for key in dictionary file
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 SelectSaver - save and restore selected file handle
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 SelfLoader - load functions only on demand
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item The __DATA__ token
+
+=item SelfLoader autoloading
+
+=item Autoloading and package lexicals
+
+=item SelfLoader and AutoLoader
+
+=item __DATA__, __END__, and the FOOBAR::DATA filehandle.
+
+=item Classes and inherited methods.
+
+=back
+
+=item Multiple packages and fully qualified subroutine names
+
+=head2 Shell - run shell commands transparently within perl
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa - load the C
+socket.h defines and structure manipulators
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+inet_aton HOSTNAME, inet_ntoa IP_ADDRESS, INADDR_ANY, INADDR_BROADCAST,
+INADDR_LOOPBACK, INADDR_NONE, sockaddr_in PORT, ADDRESS, sockaddr_in
+SOCKADDR_IN, pack_sockaddr_in PORT, IP_ADDRESS, unpack_sockaddr_in
+SOCKADDR_IN, sockaddr_un PATHNAME, sockaddr_un SOCKADDR_UN,
+pack_sockaddr_un PATH, unpack_sockaddr_un SOCKADDR_UN
+
+=head2 Symbol - manipulate Perl symbols and their names
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 Sys::Hostname - Try every conceivable way to get hostname
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 Syslog, Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl
+interface to the UNIX syslog(3) calls
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+openlog $ident, $logopt, $facility, syslog $priority, $format, @args,
+setlogmask $mask_priority, setlogsock $sock_type (added in 5.004_02),
+closelog
+
+=item EXAMPLES
+
+=item DEPENDENCIES
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 Term::Cap - Perl termcap interface
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXAMPLES
+
+=head2 Term::Complete - Perl word completion module
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+E<lt>tabE<gt>, ^D, ^U, E<lt>delE<gt>, E<lt>bsE<gt>
+
+=item DIAGNOSTICS
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 Term::ReadLine - Perl interface to various C<readline> packages. If
+no real package is found, substitutes stubs instead of basic functions.
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item Minimal set of supported functions
+
+C<ReadLine>, C<new>, C<readline>, C<addhistory>, C<IN>, $C<OUT>,
+C<MinLine>, C<findConsole>, Attribs, C<Features>
+
+=item Additional supported functions
+
+C<tkRunning>, C<ornaments>, C<newTTY>
+
+=item EXPORTS
+
+=item ENVIRONMENT
+
+=head2 Test - provides a simple framework for writing test scripts
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item TEST TYPES
+
+NORMAL TESTS, SKIPPED TESTS, TODO TESTS
+
+=item ONFAIL
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=head2 Test::Harness - run perl standard test scripts with statistics
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=over
+
+=item The test script output
+
+=back
+
+=item EXPORT
+
+=item DIAGNOSTICS
+
+C<All tests successful.\nFiles=%d, Tests=%d, %s>, C<FAILED tests
+%s\n\tFailed %d/%d tests, %.2f%% okay.>, C<Test returned status %d (wstat
+%d)>, C<Failed 1 test, %.2f%% okay. %s>, C<Failed %d/%d tests, %.2f%% okay.
+%s>
+
+=item ENVIRONMENT
+
+=item SEE ALSO
+
+=item AUTHORS
+
+=item BUGS
+
+=head2 Text::Abbrev, abbrev - create an abbreviation table from a list
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXAMPLE
+
+=head2 Text::ParseWords - parse text into an array of tokens or array of
+arrays
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXAMPLES
+
+0a simple word, 1multiple spaces are skipped because of our $delim, 2use of
+quotes to include a space in a word, 3use of a backslash to include a space
+in a word, 4use of a backslash to remove the special meaning of a
+double-quote, 5another simple word (note the lack of effect of the
+backslashed double-quote)
+
+=item AUTHORS
+
+=head2 Text::Soundex - Implementation of the Soundex Algorithm as Described
+by Knuth
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXAMPLES
+
+=item LIMITATIONS
+
+=item AUTHOR
+
+=head2 Text::Tabs -- expand and unexpand tabs per the unix expand(1) and
+unexpand(1)
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 Text::Wrap - line wrapping to form simple paragraphs
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXAMPLE
+
+=item BUGS
+
+=item AUTHOR
+
+=head2 Thread - multithreading
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item FUNCTIONS
+
+new \&start_sub, new \&start_sub, LIST, lock VARIABLE, async BLOCK;,
+Thread->self, Thread->list, cond_wait VARIABLE, cond_signal VARIABLE,
+cond_broadcast VARIABLE
+
+=item METHODS
+
+join, eval, tid
+
+=item LIMITATIONS
+
+=item SEE ALSO
+
+=head2 Thread::Queue - thread-safe queues
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item FUNCTIONS AND METHODS
+
+new, enqueue LIST, dequeue, dequeue_nb, pending
+
+=item SEE ALSO
+
+=head2 Thread::Semaphore - thread-safe semaphores
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item FUNCTIONS AND METHODS
+
+new, new NUMBER, down, down NUMBER, up, up NUMBER
+
+=head2 Thread::Signal - Start a thread which runs signal handlers reliably
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item BUGS
+
+=head2 Thread::Specific - thread-specific keys
+
+=item SYNOPSIS
+
+=head2 Tie::Array - base class for tied arrays
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+TIEARRAY classname, LIST, STORE this, index, value, FETCH this, index,
+FETCHSIZE this, STORESIZE this, count, EXTEND this, count, CLEAR this,
+DESTROY this, PUSH this, LIST, POP this, SHIFT this, UNSHIFT this, LIST,
+SPLICE this, offset, length, LIST
+
+=item CAVEATS
+
+=item AUTHOR
+
+=head2 Tie::Handle - base class definitions for tied handles
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+TIEHANDLE classname, LIST, WRITE this, scalar, length, offset, PRINT this,
+LIST, PRINTF this, format, LIST, READ this, scalar, length, offset,
+READLINE this, GETC this, DESTROY this
+
+=item MORE INFORMATION
+
+=head2 Tie::Hash, Tie::StdHash - base class definitions for tied hashes
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+TIEHASH classname, LIST, STORE this, key, value, FETCH this, key, FIRSTKEY
+this, NEXTKEY this, lastkey, EXISTS this, key, DELETE this, key, CLEAR this
+
+=item CAVEATS
+
+=item MORE INFORMATION
+
+=head2 Tie::RefHash - use references as hash keys
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item EXAMPLE
+
+=item AUTHOR
+
+=item VERSION
+
+=item SEE ALSO
+
+=head2 Tie::Scalar, Tie::StdScalar - base class definitions for tied
+scalars
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this
+
+=item MORE INFORMATION
+
+=head2 Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item CAVEATS
+
+=head2 Time::Local - efficiently compute time from local and GMT time
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 Time::gmtime - by-name interface to Perl's built-in gmtime()
+function
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTE
+
+=item AUTHOR
+
+=head2 Time::localtime - by-name interface to Perl's built-in localtime()
+function
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTE
+
+=item AUTHOR
+
+=head2 Time::tm - internal object used by Time::gmtime and Time::localtime
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHOR
+
+=head2 UNIVERSAL - base class for ALL classes (blessed references)
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+isa ( TYPE ), can ( METHOD ), VERSION ( [ REQUIRE ] ), UNIVERSAL::isa (
+VAL, TYPE ), UNIVERSAL::can ( VAL, METHOD )
+
+=head2 User::grent - by-name interface to Perl's built-in getgr*()
+functions
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTE
+
+=item AUTHOR
+
+=head2 User::pwent - by-name interface to Perl's built-in getpw*()
+functions
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item NOTE
+
+=item AUTHOR
+
+=head1 AUXILIARY DOCUMENTATION
+
+Here should be listed all the extra programs' documentation, but they
+don't all have manual pages yet:
+
+=item a2p
+
+=item s2p
+
+=item find2perl
+
+=item h2ph
+
+=item c2ph
+
+=item h2xs
+
+=item xsubpp
+
+=item pod2man
+
+=item wrapsuid
+
+=head1 AUTHOR
+
+Larry Wall <F<larry@wall.org>>, with the help of oodles
+of other folks.
+
diff --git a/contrib/perl5/pod/perltoot.pod b/contrib/perl5/pod/perltoot.pod
new file mode 100644
index 000000000000..c77a971b57fd
--- /dev/null
+++ b/contrib/perl5/pod/perltoot.pod
@@ -0,0 +1,1787 @@
+=head1 NAME
+
+perltoot - Tom's object-oriented tutorial for perl
+
+=head1 DESCRIPTION
+
+Object-oriented programming is a big seller these days. Some managers
+would rather have objects than sliced bread. Why is that? What's so
+special about an object? Just what I<is> an object anyway?
+
+An object is nothing but a way of tucking away complex behaviours into
+a neat little easy-to-use bundle. (This is what professors call
+abstraction.) Smart people who have nothing to do but sit around for
+weeks on end figuring out really hard problems make these nifty
+objects that even regular people can use. (This is what professors call
+software reuse.) Users (well, programmers) can play with this little
+bundle all they want, but they aren't to open it up and mess with the
+insides. Just like an expensive piece of hardware, the contract says
+that you void the warranty if you muck with the cover. So don't do that.
+
+The heart of objects is the class, a protected little private namespace
+full of data and functions. A class is a set of related routines that
+addresses some problem area. You can think of it as a user-defined type.
+The Perl package mechanism, also used for more traditional modules,
+is used for class modules as well. Objects "live" in a class, meaning
+that they belong to some package.
+
+More often than not, the class provides the user with little bundles.
+These bundles are objects. They know whose class they belong to,
+and how to behave. Users ask the class to do something, like "give
+me an object." Or they can ask one of these objects to do something.
+Asking a class to do something for you is calling a I<class method>.
+Asking an object to do something for you is calling an I<object method>.
+Asking either a class (usually) or an object (sometimes) to give you
+back an object is calling a I<constructor>, which is just a
+kind of method.
+
+That's all well and good, but how is an object different from any other
+Perl data type? Just what is an object I<really>; that is, what's its
+fundamental type? The answer to the first question is easy. An object
+is different from any other data type in Perl in one and only one way:
+you may dereference it using not merely string or numeric subscripts
+as with simple arrays and hashes, but with named subroutine calls.
+In a word, with I<methods>.
+
+The answer to the second question is that it's a reference, and not just
+any reference, mind you, but one whose referent has been I<bless>()ed
+into a particular class (read: package). What kind of reference? Well,
+the answer to that one is a bit less concrete. That's because in Perl
+the designer of the class can employ any sort of reference they'd like
+as the underlying intrinsic data type. It could be a scalar, an array,
+or a hash reference. It could even be a code reference. But because
+of its inherent flexibility, an object is usually a hash reference.
+
+=head1 Creating a Class
+
+Before you create a class, you need to decide what to name it. That's
+because the class (package) name governs the name of the file used to
+house it, just as with regular modules. Then, that class (package)
+should provide one or more ways to generate objects. Finally, it should
+provide mechanisms to allow users of its objects to indirectly manipulate
+these objects from a distance.
+
+For example, let's make a simple Person class module. It gets stored in
+the file Person.pm. If it were called a Happy::Person class, it would
+be stored in the file Happy/Person.pm, and its package would become
+Happy::Person instead of just Person. (On a personal computer not
+running Unix or Plan 9, but something like MacOS or VMS, the directory
+separator may be different, but the principle is the same.) Do not assume
+any formal relationship between modules based on their directory names.
+This is merely a grouping convenience, and has no effect on inheritance,
+variable accessibility, or anything else.
+
+For this module we aren't going to use Exporter, because we're
+a well-behaved class module that doesn't export anything at all.
+In order to manufacture objects, a class needs to have a I<constructor
+method>. A constructor gives you back not just a regular data type,
+but a brand-new object in that class. This magic is taken care of by
+the bless() function, whose sole purpose is to enable its referent to
+be used as an object. Remember: being an object really means nothing
+more than that methods may now be called against it.
+
+While a constructor may be named anything you'd like, most Perl
+programmers seem to like to call theirs new(). However, new() is not
+a reserved word, and a class is under no obligation to supply such.
+Some programmers have also been known to use a function with
+the same name as the class as the constructor.
+
+=head2 Object Representation
+
+By far the most common mechanism used in Perl to represent a Pascal
+record, a C struct, or a C++ class is an anonymous hash. That's because a
+hash has an arbitrary number of data fields, each conveniently accessed by
+an arbitrary name of your own devising.
+
+If you were just doing a simple
+struct-like emulation, you would likely go about it something like this:
+
+ $rec = {
+ name => "Jason",
+ age => 23,
+ peers => [ "Norbert", "Rhys", "Phineas"],
+ };
+
+If you felt like it, you could add a bit of visual distinction
+by up-casing the hash keys:
+
+ $rec = {
+ NAME => "Jason",
+ AGE => 23,
+ PEERS => [ "Norbert", "Rhys", "Phineas"],
+ };
+
+And so you could get at C<$rec-E<gt>{NAME}> to find "Jason", or
+C<@{ $rec-E<gt>{PEERS} }> to get at "Norbert", "Rhys", and "Phineas".
+(Have you ever noticed how many 23-year-old programmers seem to
+be named "Jason" these days? :-)
+
+This same model is often used for classes, although it is not considered
+the pinnacle of programming propriety for folks from outside the
+class to come waltzing into an object, brazenly accessing its data
+members directly. Generally speaking, an object should be considered
+an opaque cookie that you use I<object methods> to access. Visually,
+methods look like you're dereffing a reference using a function name
+instead of brackets or braces.
+
+=head2 Class Interface
+
+Some languages provide a formal syntactic interface to a class's methods,
+but Perl does not. It relies on you to read the documentation of each
+class. If you try to call an undefined method on an object, Perl won't
+complain, but the program will trigger an exception while it's running.
+Likewise, if you call a method expecting a prime number as its argument
+with a non-prime one instead, you can't expect the compiler to catch this.
+(Well, you can expect it all you like, but it's not going to happen.)
+
+Let's suppose you have a well-educated user of your Person class,
+someone who has read the docs that explain the prescribed
+interface. Here's how they might use the Person class:
+
+ use Person;
+
+ $him = Person->new();
+ $him->name("Jason");
+ $him->age(23);
+ $him->peers( "Norbert", "Rhys", "Phineas" );
+
+ push @All_Recs, $him; # save object in array for later
+
+ printf "%s is %d years old.\n", $him->name, $him->age;
+ print "His peers are: ", join(", ", $him->peers), "\n";
+
+ printf "Last rec's name is %s\n", $All_Recs[-1]->name;
+
+As you can see, the user of the class doesn't know (or at least, has no
+business paying attention to the fact) that the object has one particular
+implementation or another. The interface to the class and its objects
+is exclusively via methods, and that's all the user of the class should
+ever play with.
+
+=head2 Constructors and Instance Methods
+
+Still, I<someone> has to know what's in the object. And that someone is
+the class. It implements methods that the programmer uses to access
+the object. Here's how to implement the Person class using the standard
+hash-ref-as-an-object idiom. We'll make a class method called new() to
+act as the constructor, and three object methods called name(), age(), and
+peers() to get at per-object data hidden away in our anonymous hash.
+
+ package Person;
+ use strict;
+
+ ##################################################
+ ## the object constructor (simplistic version) ##
+ ##################################################
+ sub new {
+ my $self = {};
+ $self->{NAME} = undef;
+ $self->{AGE} = undef;
+ $self->{PEERS} = [];
+ bless($self); # but see below
+ return $self;
+ }
+
+ ##############################################
+ ## methods to access per-object data ##
+ ## ##
+ ## With args, they set the value. Without ##
+ ## any, they only retrieve it/them. ##
+ ##############################################
+
+ sub name {
+ my $self = shift;
+ if (@_) { $self->{NAME} = shift }
+ return $self->{NAME};
+ }
+
+ sub age {
+ my $self = shift;
+ if (@_) { $self->{AGE} = shift }
+ return $self->{AGE};
+ }
+
+ sub peers {
+ my $self = shift;
+ if (@_) { @{ $self->{PEERS} } = @_ }
+ return @{ $self->{PEERS} };
+ }
+
+ 1; # so the require or use succeeds
+
+We've created three methods to access an object's data, name(), age(),
+and peers(). These are all substantially similar. If called with an
+argument, they set the appropriate field; otherwise they return the
+value held by that field, meaning the value of that hash key.
+
+=head2 Planning for the Future: Better Constructors
+
+Even though at this point you may not even know what it means, someday
+you're going to worry about inheritance. (You can safely ignore this
+for now and worry about it later if you'd like.) To ensure that this
+all works out smoothly, you must use the double-argument form of bless().
+The second argument is the class into which the referent will be blessed.
+By not assuming our own class as the default second argument and instead
+using the class passed into us, we make our constructor inheritable.
+
+While we're at it, let's make our constructor a bit more flexible.
+Rather than being uniquely a class method, we'll set it up so that
+it can be called as either a class method I<or> an object
+method. That way you can say:
+
+ $me = Person->new();
+ $him = $me->new();
+
+To do this, all we have to do is check whether what was passed in
+was a reference or not. If so, we were invoked as an object method,
+and we need to extract the package (class) using the ref() function.
+If not, we just use the string passed in as the package name
+for blessing our referent.
+
+ sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ $self->{NAME} = undef;
+ $self->{AGE} = undef;
+ $self->{PEERS} = [];
+ bless ($self, $class);
+ return $self;
+ }
+
+That's about all there is for constructors. These methods bring objects
+to life, returning neat little opaque bundles to the user to be used in
+subsequent method calls.
+
+=head2 Destructors
+
+Every story has a beginning and an end. The beginning of the object's
+story is its constructor, explicitly called when the object comes into
+existence. But the ending of its story is the I<destructor>, a method
+implicitly called when an object leaves this life. Any per-object
+clean-up code is placed in the destructor, which must (in Perl) be called
+DESTROY.
+
+If constructors can have arbitrary names, then why not destructors?
+Because while a constructor is explicitly called, a destructor is not.
+Destruction happens automatically via Perl's garbage collection (GC)
+system, which is a quick but somewhat lazy reference-based GC system.
+To know what to call, Perl insists that the destructor be named DESTROY.
+Perl's notion of the right time to call a destructor is not well-defined
+currently, which is why your destructors should not rely on when they are
+called.
+
+Why is DESTROY in all caps? Perl on occasion uses purely uppercase
+function names as a convention to indicate that the function will
+be automatically called by Perl in some way. Others that are called
+implicitly include BEGIN, END, AUTOLOAD, plus all methods used by
+tied objects, described in L<perltie>.
+
+In really good object-oriented programming languages, the user doesn't
+care when the destructor is called. It just happens when it's supposed
+to. In low-level languages without any GC at all, there's no way to
+depend on this happening at the right time, so the programmer must
+explicitly call the destructor to clean up memory and state, crossing
+their fingers that it's the right time to do so. Unlike C++, an
+object destructor is nearly never needed in Perl, and even when it is,
+explicit invocation is uncalled for. In the case of our Person class,
+we don't need a destructor because Perl takes care of simple matters
+like memory deallocation.
+
+The only situation where Perl's reference-based GC won't work is
+when there's a circularity in the data structure, such as:
+
+ $this->{WHATEVER} = $this;
+
+In that case, you must delete the self-reference manually if you expect
+your program not to leak memory. While admittedly error-prone, this is
+the best we can do right now. Nonetheless, rest assured that when your
+program is finished, its objects' destructors are all duly called.
+So you are guaranteed that an object I<eventually> gets properly
+destroyed, except in the unique case of a program that never exits.
+(If you're running Perl embedded in another application, this full GC
+pass happens a bit more frequently--whenever a thread shuts down.)
+
+=head2 Other Object Methods
+
+The methods we've talked about so far have either been constructors or
+else simple "data methods", interfaces to data stored in the object.
+These are a bit like an object's data members in the C++ world, except
+that strangers don't access them as data. Instead, they should only
+access the object's data indirectly via its methods. This is an
+important rule: in Perl, access to an object's data should I<only>
+be made through methods.
+
+Perl doesn't impose restrictions on who gets to use which methods.
+The public-versus-private distinction is by convention, not syntax.
+(Well, unless you use the Alias module described below in
+L<Data Members as Variables>.) Occasionally you'll see method names beginning or ending
+with an underscore or two. This marking is a convention indicating
+that the methods are private to that class alone and sometimes to its
+closest acquaintances, its immediate subclasses. But this distinction
+is not enforced by Perl itself. It's up to the programmer to behave.
+
+There's no reason to limit methods to those that simply access data.
+Methods can do anything at all. The key point is that they're invoked
+against an object or a class. Let's say we'd like object methods that
+do more than fetch or set one particular field.
+
+ sub exclaim {
+ my $self = shift;
+ return sprintf "Hi, I'm %s, age %d, working with %s",
+ $self->{NAME}, $self->{AGE}, join(", ", $self->{PEERS});
+ }
+
+Or maybe even one like this:
+
+ sub happy_birthday {
+ my $self = shift;
+ return ++$self->{AGE};
+ }
+
+Some might argue that one should go at these this way:
+
+ sub exclaim {
+ my $self = shift;
+ return sprintf "Hi, I'm %s, age %d, working with %s",
+ $self->name, $self->age, join(", ", $self->peers);
+ }
+
+ sub happy_birthday {
+ my $self = shift;
+ return $self->age( $self->age() + 1 );
+ }
+
+But since these methods are all executing in the class itself, this
+may not be critical. There are tradeoffs to be made. Using direct
+hash access is faster (about an order of magnitude faster, in fact), and
+it's more convenient when you want to interpolate in strings. But using
+methods (the external interface) internally shields not just the users of
+your class but even you yourself from changes in your data representation.
+
+=head1 Class Data
+
+What about "class data", data items common to each object in a class?
+What would you want that for? Well, in your Person class, you might
+like to keep track of the total people alive. How do you implement that?
+
+You I<could> make it a global variable called $Person::Census. But about
+only reason you'd do that would be if you I<wanted> people to be able to
+get at your class data directly. They could just say $Person::Census
+and play around with it. Maybe this is ok in your design scheme.
+You might even conceivably want to make it an exported variable. To be
+exportable, a variable must be a (package) global. If this were a
+traditional module rather than an object-oriented one, you might do that.
+
+While this approach is expected in most traditional modules, it's
+generally considered rather poor form in most object modules. In an
+object module, you should set up a protective veil to separate interface
+from implementation. So provide a class method to access class data
+just as you provide object methods to access object data.
+
+So, you I<could> still keep $Census as a package global and rely upon
+others to honor the contract of the module and therefore not play around
+with its implementation. You could even be supertricky and make $Census a
+tied object as described in L<perltie>, thereby intercepting all accesses.
+
+But more often than not, you just want to make your class data a
+file-scoped lexical. To do so, simply put this at the top of the file:
+
+ my $Census = 0;
+
+Even though the scope of a my() normally expires when the block in which
+it was declared is done (in this case the whole file being required or
+used), Perl's deep binding of lexical variables guarantees that the
+variable will not be deallocated, remaining accessible to functions
+declared within that scope. This doesn't work with global variables
+given temporary values via local(), though.
+
+Irrespective of whether you leave $Census a package global or make
+it instead a file-scoped lexical, you should make these
+changes to your Person::new() constructor:
+
+ sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ $Census++;
+ $self->{NAME} = undef;
+ $self->{AGE} = undef;
+ $self->{PEERS} = [];
+ bless ($self, $class);
+ return $self;
+ }
+
+ sub population {
+ return $Census;
+ }
+
+Now that we've done this, we certainly do need a destructor so that
+when Person is destroyed, the $Census goes down. Here's how
+this could be done:
+
+ sub DESTROY { --$Census }
+
+Notice how there's no memory to deallocate in the destructor? That's
+something that Perl takes care of for you all by itself.
+
+=head2 Accessing Class Data
+
+It turns out that this is not really a good way to go about handling
+class data. A good scalable rule is that I<you must never reference class
+data directly from an object method>. Otherwise you aren't building a
+scalable, inheritable class. The object must be the rendezvous point
+for all operations, especially from an object method. The globals
+(class data) would in some sense be in the "wrong" package in your
+derived classes. In Perl, methods execute in the context of the class
+they were defined in, I<not> that of the object that triggered them.
+Therefore, namespace visibility of package globals in methods is unrelated
+to inheritance.
+
+Got that? Maybe not. Ok, let's say that some other class "borrowed"
+(well, inherited) the DESTROY method as it was defined above. When those
+objects are destroyed, the original $Census variable will be altered,
+not the one in the new class's package namespace. Perhaps this is what
+you want, but probably it isn't.
+
+Here's how to fix this. We'll store a reference to the data in the
+value accessed by the hash key "_CENSUS". Why the underscore? Well,
+mostly because an initial underscore already conveys strong feelings
+of magicalness to a C programmer. It's really just a mnemonic device
+to remind ourselves that this field is special and not to be used as
+a public data member in the same way that NAME, AGE, and PEERS are.
+(Because we've been developing this code under the strict pragma, prior
+to perl version 5.004 we'll have to quote the field name.)
+
+ sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ $self->{NAME} = undef;
+ $self->{AGE} = undef;
+ $self->{PEERS} = [];
+ # "private" data
+ $self->{"_CENSUS"} = \$Census;
+ bless ($self, $class);
+ ++ ${ $self->{"_CENSUS"} };
+ return $self;
+ }
+
+ sub population {
+ my $self = shift;
+ if (ref $self) {
+ return ${ $self->{"_CENSUS"} };
+ } else {
+ return $Census;
+ }
+ }
+
+ sub DESTROY {
+ my $self = shift;
+ -- ${ $self->{"_CENSUS"} };
+ }
+
+=head2 Debugging Methods
+
+It's common for a class to have a debugging mechanism. For example,
+you might want to see when objects are created or destroyed. To do that,
+add a debugging variable as a file-scoped lexical. For this, we'll pull
+in the standard Carp module to emit our warnings and fatal messages.
+That way messages will come out with the caller's filename and
+line number instead of our own; if we wanted them to be from our own
+perspective, we'd just use die() and warn() directly instead of croak()
+and carp() respectively.
+
+ use Carp;
+ my $Debugging = 0;
+
+Now add a new class method to access the variable.
+
+ sub debug {
+ my $class = shift;
+ if (ref $class) { confess "Class method called as object method" }
+ unless (@_ == 1) { confess "usage: CLASSNAME->debug(level)" }
+ $Debugging = shift;
+ }
+
+Now fix up DESTROY to murmur a bit as the moribund object expires:
+
+ sub DESTROY {
+ my $self = shift;
+ if ($Debugging) { carp "Destroying $self " . $self->name }
+ -- ${ $self->{"_CENSUS"} };
+ }
+
+One could conceivably make a per-object debug state. That
+way you could call both of these:
+
+ Person->debug(1); # entire class
+ $him->debug(1); # just this object
+
+To do so, we need our debugging method to be a "bimodal" one, one that
+works on both classes I<and> objects. Therefore, adjust the debug()
+and DESTROY methods as follows:
+
+ sub debug {
+ my $self = shift;
+ confess "usage: thing->debug(level)" unless @_ == 1;
+ my $level = shift;
+ if (ref($self)) {
+ $self->{"_DEBUG"} = $level; # just myself
+ } else {
+ $Debugging = $level; # whole class
+ }
+ }
+
+ sub DESTROY {
+ my $self = shift;
+ if ($Debugging || $self->{"_DEBUG"}) {
+ carp "Destroying $self " . $self->name;
+ }
+ -- ${ $self->{"_CENSUS"} };
+ }
+
+What happens if a derived class (which we'll call Employee) inherits
+methods from this Person base class? Then C<Employee-E<gt>debug()>, when called
+as a class method, manipulates $Person::Debugging not $Employee::Debugging.
+
+=head2 Class Destructors
+
+The object destructor handles the death of each distinct object. But sometimes
+you want a bit of cleanup when the entire class is shut down, which
+currently only happens when the program exits. To make such a
+I<class destructor>, create a function in that class's package named
+END. This works just like the END function in traditional modules,
+meaning that it gets called whenever your program exits unless it execs
+or dies of an uncaught signal. For example,
+
+ sub END {
+ if ($Debugging) {
+ print "All persons are going away now.\n";
+ }
+ }
+
+When the program exits, all the class destructors (END functions) are
+be called in the opposite order that they were loaded in (LIFO order).
+
+=head2 Documenting the Interface
+
+And there you have it: we've just shown you the I<implementation> of this
+Person class. Its I<interface> would be its documentation. Usually this
+means putting it in pod ("plain old documentation") format right there
+in the same file. In our Person example, we would place the following
+docs anywhere in the Person.pm file. Even though it looks mostly like
+code, it's not. It's embedded documentation such as would be used by
+the pod2man, pod2html, or pod2text programs. The Perl compiler ignores
+pods entirely, just as the translators ignore code. Here's an example of
+some pods describing the informal interface:
+
+ =head1 NAME
+
+ Person - class to implement people
+
+ =head1 SYNOPSIS
+
+ use Person;
+
+ #################
+ # class methods #
+ #################
+ $ob = Person->new;
+ $count = Person->population;
+
+ #######################
+ # object data methods #
+ #######################
+
+ ### get versions ###
+ $who = $ob->name;
+ $years = $ob->age;
+ @pals = $ob->peers;
+
+ ### set versions ###
+ $ob->name("Jason");
+ $ob->age(23);
+ $ob->peers( "Norbert", "Rhys", "Phineas" );
+
+ ########################
+ # other object methods #
+ ########################
+
+ $phrase = $ob->exclaim;
+ $ob->happy_birthday;
+
+ =head1 DESCRIPTION
+
+ The Person class implements dah dee dah dee dah....
+
+That's all there is to the matter of interface versus implementation.
+A programmer who opens up the module and plays around with all the private
+little shiny bits that were safely locked up behind the interface contract
+has voided the warranty, and you shouldn't worry about their fate.
+
+=head1 Aggregation
+
+Suppose you later want to change the class to implement better names.
+Perhaps you'd like to support both given names (called Christian names,
+irrespective of one's religion) and family names (called surnames), plus
+nicknames and titles. If users of your Person class have been properly
+accessing it through its documented interface, then you can easily change
+the underlying implementation. If they haven't, then they lose and
+it's their fault for breaking the contract and voiding their warranty.
+
+To do this, we'll make another class, this one called Fullname. What's
+the Fullname class look like? To answer that question, you have to
+first figure out how you want to use it. How about we use it this way:
+
+ $him = Person->new();
+ $him->fullname->title("St");
+ $him->fullname->christian("Thomas");
+ $him->fullname->surname("Aquinas");
+ $him->fullname->nickname("Tommy");
+ printf "His normal name is %s\n", $him->name;
+ printf "But his real name is %s\n", $him->fullname->as_string;
+
+Ok. To do this, we'll change Person::new() so that it supports
+a full name field this way:
+
+ sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ $self->{FULLNAME} = Fullname->new();
+ $self->{AGE} = undef;
+ $self->{PEERS} = [];
+ $self->{"_CENSUS"} = \$Census;
+ bless ($self, $class);
+ ++ ${ $self->{"_CENSUS"} };
+ return $self;
+ }
+
+ sub fullname {
+ my $self = shift;
+ return $self->{FULLNAME};
+ }
+
+Then to support old code, define Person::name() this way:
+
+ sub name {
+ my $self = shift;
+ return $self->{FULLNAME}->nickname(@_)
+ || $self->{FULLNAME}->christian(@_);
+ }
+
+Here's the Fullname class. We'll use the same technique
+of using a hash reference to hold data fields, and methods
+by the appropriate name to access them:
+
+ package Fullname;
+ use strict;
+
+ sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {
+ TITLE => undef,
+ CHRISTIAN => undef,
+ SURNAME => undef,
+ NICK => undef,
+ };
+ bless ($self, $class);
+ return $self;
+ }
+
+ sub christian {
+ my $self = shift;
+ if (@_) { $self->{CHRISTIAN} = shift }
+ return $self->{CHRISTIAN};
+ }
+
+ sub surname {
+ my $self = shift;
+ if (@_) { $self->{SURNAME} = shift }
+ return $self->{SURNAME};
+ }
+
+ sub nickname {
+ my $self = shift;
+ if (@_) { $self->{NICK} = shift }
+ return $self->{NICK};
+ }
+
+ sub title {
+ my $self = shift;
+ if (@_) { $self->{TITLE} = shift }
+ return $self->{TITLE};
+ }
+
+ sub as_string {
+ my $self = shift;
+ my $name = join(" ", @$self{'CHRISTIAN', 'SURNAME'});
+ if ($self->{TITLE}) {
+ $name = $self->{TITLE} . " " . $name;
+ }
+ return $name;
+ }
+
+ 1;
+
+Finally, here's the test program:
+
+ #!/usr/bin/perl -w
+ use strict;
+ use Person;
+ sub END { show_census() }
+
+ sub show_census () {
+ printf "Current population: %d\n", Person->population;
+ }
+
+ Person->debug(1);
+
+ show_census();
+
+ my $him = Person->new();
+
+ $him->fullname->christian("Thomas");
+ $him->fullname->surname("Aquinas");
+ $him->fullname->nickname("Tommy");
+ $him->fullname->title("St");
+ $him->age(1);
+
+ printf "%s is really %s.\n", $him->name, $him->fullname;
+ printf "%s's age: %d.\n", $him->name, $him->age;
+ $him->happy_birthday;
+ printf "%s's age: %d.\n", $him->name, $him->age;
+
+ show_census();
+
+=head1 Inheritance
+
+Object-oriented programming systems all support some notion of
+inheritance. Inheritance means allowing one class to piggy-back on
+top of another one so you don't have to write the same code again and
+again. It's about software reuse, and therefore related to Laziness,
+the principal virtue of a programmer. (The import/export mechanisms in
+traditional modules are also a form of code reuse, but a simpler one than
+the true inheritance that you find in object modules.)
+
+Sometimes the syntax of inheritance is built into the core of the
+language, and sometimes it's not. Perl has no special syntax for
+specifying the class (or classes) to inherit from. Instead, it's all
+strictly in the semantics. Each package can have a variable called @ISA,
+which governs (method) inheritance. If you try to call a method on an
+object or class, and that method is not found in that object's package,
+Perl then looks to @ISA for other packages to go looking through in
+search of the missing method.
+
+Like the special per-package variables recognized by Exporter (such as
+@EXPORT, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, and $VERSION), the @ISA
+array I<must> be a package-scoped global and not a file-scoped lexical
+created via my(). Most classes have just one item in their @ISA array.
+In this case, we have what's called "single inheritance", or SI for short.
+
+Consider this class:
+
+ package Employee;
+ use Person;
+ @ISA = ("Person");
+ 1;
+
+Not a lot to it, eh? All it's doing so far is loading in another
+class and stating that this one will inherit methods from that
+other class if need be. We have given it none of its own methods.
+We rely upon an Employee to behave just like a Person.
+
+Setting up an empty class like this is called the "empty subclass test";
+that is, making a derived class that does nothing but inherit from a
+base class. If the original base class has been designed properly,
+then the new derived class can be used as a drop-in replacement for the
+old one. This means you should be able to write a program like this:
+
+ use Employee;
+ my $empl = Employee->new();
+ $empl->name("Jason");
+ $empl->age(23);
+ printf "%s is age %d.\n", $empl->name, $empl->age;
+
+By proper design, we mean always using the two-argument form of bless(),
+avoiding direct access of global data, and not exporting anything. If you
+look back at the Person::new() function we defined above, we were careful
+to do that. There's a bit of package data used in the constructor,
+but the reference to this is stored on the object itself and all other
+methods access package data via that reference, so we should be ok.
+
+What do we mean by the Person::new() function -- isn't that actually
+a method? Well, in principle, yes. A method is just a function that
+expects as its first argument a class name (package) or object
+(blessed reference). Person::new() is the function that both the
+C<Person-E<gt>new()> method and the C<Employee-E<gt>new()> method end
+up calling. Understand that while a method call looks a lot like a
+function call, they aren't really quite the same, and if you treat them
+as the same, you'll very soon be left with nothing but broken programs.
+First, the actual underlying calling conventions are different: method
+calls get an extra argument. Second, function calls don't do inheritance,
+but methods do.
+
+ Method Call Resulting Function Call
+ ----------- ------------------------
+ Person->new() Person::new("Person")
+ Employee->new() Person::new("Employee")
+
+So don't use function calls when you mean to call a method.
+
+If an employee is just a Person, that's not all too very interesting.
+So let's add some other methods. We'll give our employee
+data fields to access their salary, their employee ID, and their
+start date.
+
+If you're getting a little tired of creating all these nearly identical
+methods just to get at the object's data, do not despair. Later,
+we'll describe several different convenience mechanisms for shortening
+this up. Meanwhile, here's the straight-forward way:
+
+ sub salary {
+ my $self = shift;
+ if (@_) { $self->{SALARY} = shift }
+ return $self->{SALARY};
+ }
+
+ sub id_number {
+ my $self = shift;
+ if (@_) { $self->{ID} = shift }
+ return $self->{ID};
+ }
+
+ sub start_date {
+ my $self = shift;
+ if (@_) { $self->{START_DATE} = shift }
+ return $self->{START_DATE};
+ }
+
+=head2 Overridden Methods
+
+What happens when both a derived class and its base class have the same
+method defined? Well, then you get the derived class's version of that
+method. For example, let's say that we want the peers() method called on
+an employee to act a bit differently. Instead of just returning the list
+of peer names, let's return slightly different strings. So doing this:
+
+ $empl->peers("Peter", "Paul", "Mary");
+ printf "His peers are: %s\n", join(", ", $empl->peers);
+
+will produce:
+
+ His peers are: PEON=PETER, PEON=PAUL, PEON=MARY
+
+To do this, merely add this definition into the Employee.pm file:
+
+ sub peers {
+ my $self = shift;
+ if (@_) { @{ $self->{PEERS} } = @_ }
+ return map { "PEON=\U$_" } @{ $self->{PEERS} };
+ }
+
+There, we've just demonstrated the high-falutin' concept known in certain
+circles as I<polymorphism>. We've taken on the form and behaviour of
+an existing object, and then we've altered it to suit our own purposes.
+This is a form of Laziness. (Getting polymorphed is also what happens
+when the wizard decides you'd look better as a frog.)
+
+Every now and then you'll want to have a method call trigger both its
+derived class (also known as "subclass") version as well as its base class
+(also known as "superclass") version. In practice, constructors and
+destructors are likely to want to do this, and it probably also makes
+sense in the debug() method we showed previously.
+
+To do this, add this to Employee.pm:
+
+ use Carp;
+ my $Debugging = 0;
+
+ sub debug {
+ my $self = shift;
+ confess "usage: thing->debug(level)" unless @_ == 1;
+ my $level = shift;
+ if (ref($self)) {
+ $self->{"_DEBUG"} = $level;
+ } else {
+ $Debugging = $level; # whole class
+ }
+ Person::debug($self, $Debugging); # don't really do this
+ }
+
+As you see, we turn around and call the Person package's debug() function.
+But this is far too fragile for good design. What if Person doesn't
+have a debug() function, but is inheriting I<its> debug() method
+from elsewhere? It would have been slightly better to say
+
+ Person->debug($Debugging);
+
+But even that's got too much hard-coded. It's somewhat better to say
+
+ $self->Person::debug($Debugging);
+
+Which is a funny way to say to start looking for a debug() method up
+in Person. This strategy is more often seen on overridden object methods
+than on overridden class methods.
+
+There is still something a bit off here. We've hard-coded our
+superclass's name. This in particular is bad if you change which classes
+you inherit from, or add others. Fortunately, the pseudoclass SUPER
+comes to the rescue here.
+
+ $self->SUPER::debug($Debugging);
+
+This way it starts looking in my class's @ISA. This only makes sense
+from I<within> a method call, though. Don't try to access anything
+in SUPER:: from anywhere else, because it doesn't exist outside
+an overridden method call.
+
+Things are getting a bit complicated here. Have we done anything
+we shouldn't? As before, one way to test whether we're designing
+a decent class is via the empty subclass test. Since we already have
+an Employee class that we're trying to check, we'd better get a new
+empty subclass that can derive from Employee. Here's one:
+
+ package Boss;
+ use Employee; # :-)
+ @ISA = qw(Employee);
+
+And here's the test program:
+
+ #!/usr/bin/perl -w
+ use strict;
+ use Boss;
+ Boss->debug(1);
+
+ my $boss = Boss->new();
+
+ $boss->fullname->title("Don");
+ $boss->fullname->surname("Pichon Alvarez");
+ $boss->fullname->christian("Federico Jesus");
+ $boss->fullname->nickname("Fred");
+
+ $boss->age(47);
+ $boss->peers("Frank", "Felipe", "Faust");
+
+ printf "%s is age %d.\n", $boss->fullname, $boss->age;
+ printf "His peers are: %s\n", join(", ", $boss->peers);
+
+Running it, we see that we're still ok. If you'd like to dump out your
+object in a nice format, somewhat like the way the 'x' command works in
+the debugger, you could use the Data::Dumper module from CPAN this way:
+
+ use Data::Dumper;
+ print "Here's the boss:\n";
+ print Dumper($boss);
+
+Which shows us something like this:
+
+ Here's the boss:
+ $VAR1 = bless( {
+ _CENSUS => \1,
+ FULLNAME => bless( {
+ TITLE => 'Don',
+ SURNAME => 'Pichon Alvarez',
+ NICK => 'Fred',
+ CHRISTIAN => 'Federico Jesus'
+ }, 'Fullname' ),
+ AGE => 47,
+ PEERS => [
+ 'Frank',
+ 'Felipe',
+ 'Faust'
+ ]
+ }, 'Boss' );
+
+Hm.... something's missing there. What about the salary, start date,
+and ID fields? Well, we never set them to anything, even undef, so they
+don't show up in the hash's keys. The Employee class has no new() method
+of its own, and the new() method in Person doesn't know about Employees.
+(Nor should it: proper OO design dictates that a subclass be allowed to
+know about its immediate superclass, but never vice-versa.) So let's
+fix up Employee::new() this way:
+
+ sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = $class->SUPER::new();
+ $self->{SALARY} = undef;
+ $self->{ID} = undef;
+ $self->{START_DATE} = undef;
+ bless ($self, $class); # reconsecrate
+ return $self;
+ }
+
+Now if you dump out an Employee or Boss object, you'll find
+that new fields show up there now.
+
+=head2 Multiple Inheritance
+
+Ok, at the risk of confusing beginners and annoying OO gurus, it's
+time to confess that Perl's object system includes that controversial
+notion known as multiple inheritance, or MI for short. All this means
+is that rather than having just one parent class who in turn might
+itself have a parent class, etc., that you can directly inherit from
+two or more parents. It's true that some uses of MI can get you into
+trouble, although hopefully not quite so much trouble with Perl as with
+dubiously-OO languages like C++.
+
+The way it works is actually pretty simple: just put more than one package
+name in your @ISA array. When it comes time for Perl to go finding
+methods for your object, it looks at each of these packages in order.
+Well, kinda. It's actually a fully recursive, depth-first order.
+Consider a bunch of @ISA arrays like this:
+
+ @First::ISA = qw( Alpha );
+ @Second::ISA = qw( Beta );
+ @Third::ISA = qw( First Second );
+
+If you have an object of class Third:
+
+ my $ob = Third->new();
+ $ob->spin();
+
+How do we find a spin() method (or a new() method for that matter)?
+Because the search is depth-first, classes will be looked up
+in the following order: Third, First, Alpha, Second, and Beta.
+
+In practice, few class modules have been seen that actually
+make use of MI. One nearly always chooses simple containership of
+one class within another over MI. That's why our Person
+object I<contained> a Fullname object. That doesn't mean
+it I<was> one.
+
+However, there is one particular area where MI in Perl is rampant:
+borrowing another class's class methods. This is rather common,
+especially with some bundled "objectless" classes,
+like Exporter, DynaLoader, AutoLoader, and SelfLoader. These classes
+do not provide constructors; they exist only so you may inherit their
+class methods. (It's not entirely clear why inheritance was done
+here rather than traditional module importation.)
+
+For example, here is the POSIX module's @ISA:
+
+ package POSIX;
+ @ISA = qw(Exporter DynaLoader);
+
+The POSIX module isn't really an object module, but then,
+neither are Exporter or DynaLoader. They're just lending their
+classes' behaviours to POSIX.
+
+Why don't people use MI for object methods much? One reason is that
+it can have complicated side-effects. For one thing, your inheritance
+graph (no longer a tree) might converge back to the same base class.
+Although Perl guards against recursive inheritance, merely having parents
+who are related to each other via a common ancestor, incestuous though
+it sounds, is not forbidden. What if in our Third class shown above we
+wanted its new() method to also call both overridden constructors in its
+two parent classes? The SUPER notation would only find the first one.
+Also, what about if the Alpha and Beta classes both had a common ancestor,
+like Nought? If you kept climbing up the inheritance tree calling
+overridden methods, you'd end up calling Nought::new() twice,
+which might well be a bad idea.
+
+=head2 UNIVERSAL: The Root of All Objects
+
+Wouldn't it be convenient if all objects were rooted at some ultimate
+base class? That way you could give every object common methods without
+having to go and add it to each and every @ISA. Well, it turns out that
+you can. You don't see it, but Perl tacitly and irrevocably assumes
+that there's an extra element at the end of @ISA: the class UNIVERSAL.
+In version 5.003, there were no predefined methods there, but you could put
+whatever you felt like into it.
+
+However, as of version 5.004 (or some subversive releases, like 5.003_08),
+UNIVERSAL has some methods in it already. These are builtin to your Perl
+binary, so they don't take any extra time to load. Predefined methods
+include isa(), can(), and VERSION(). isa() tells you whether an object or
+class "is" another one without having to traverse the hierarchy yourself:
+
+ $has_io = $fd->isa("IO::Handle");
+ $itza_handle = IO::Socket->isa("IO::Handle");
+
+The can() method, called against that object or class, reports back
+whether its string argument is a callable method name in that class.
+In fact, it gives you back a function reference to that method:
+
+ $his_print_method = $obj->can('as_string');
+
+Finally, the VERSION method checks whether the class (or the object's
+class) has a package global called $VERSION that's high enough, as in:
+
+ Some_Module->VERSION(3.0);
+ $his_vers = $ob->VERSION();
+
+However, we don't usually call VERSION ourselves. (Remember that an all
+uppercase function name is a Perl convention that indicates that the
+function will be automatically used by Perl in some way.) In this case,
+it happens when you say
+
+ use Some_Module 3.0;
+
+If you wanted to add version checking to your Person class explained
+above, just add this to Person.pm:
+
+ use vars qw($VERSION);
+ $VERSION = '1.1';
+
+and then in Employee.pm could you can say
+
+ use Employee 1.1;
+
+And it would make sure that you have at least that version number or
+higher available. This is not the same as loading in that exact version
+number. No mechanism currently exists for concurrent installation of
+multiple versions of a module. Lamentably.
+
+=head1 Alternate Object Representations
+
+Nothing requires objects to be implemented as hash references. An object
+can be any sort of reference so long as its referent has been suitably
+blessed. That means scalar, array, and code references are also fair
+game.
+
+A scalar would work if the object has only one datum to hold. An array
+would work for most cases, but makes inheritance a bit dodgy because
+you have to invent new indices for the derived classes.
+
+=head2 Arrays as Objects
+
+If the user of your class honors the contract and sticks to the advertised
+interface, then you can change its underlying interface if you feel
+like it. Here's another implementation that conforms to the same
+interface specification. This time we'll use an array reference
+instead of a hash reference to represent the object.
+
+ package Person;
+ use strict;
+
+ my($NAME, $AGE, $PEERS) = ( 0 .. 2 );
+
+ ############################################
+ ## the object constructor (array version) ##
+ ############################################
+ sub new {
+ my $self = [];
+ $self->[$NAME] = undef; # this is unnecessary
+ $self->[$AGE] = undef; # as is this
+ $self->[$PEERS] = []; # but this isn't, really
+ bless($self);
+ return $self;
+ }
+
+ sub name {
+ my $self = shift;
+ if (@_) { $self->[$NAME] = shift }
+ return $self->[$NAME];
+ }
+
+ sub age {
+ my $self = shift;
+ if (@_) { $self->[$AGE] = shift }
+ return $self->[$AGE];
+ }
+
+ sub peers {
+ my $self = shift;
+ if (@_) { @{ $self->[$PEERS] } = @_ }
+ return @{ $self->[$PEERS] };
+ }
+
+ 1; # so the require or use succeeds
+
+You might guess that the array access would be a lot faster than the
+hash access, but they're actually comparable. The array is a I<little>
+bit faster, but not more than ten or fifteen percent, even when you
+replace the variables above like $AGE with literal numbers, like 1.
+A bigger difference between the two approaches can be found in memory use.
+A hash representation takes up more memory than an array representation
+because you have to allocate memory for the keys as well as for the values.
+However, it really isn't that bad, especially since as of version 5.004,
+memory is only allocated once for a given hash key, no matter how many
+hashes have that key. It's expected that sometime in the future, even
+these differences will fade into obscurity as more efficient underlying
+representations are devised.
+
+Still, the tiny edge in speed (and somewhat larger one in memory)
+is enough to make some programmers choose an array representation
+for simple classes. There's still a little problem with
+scalability, though, because later in life when you feel
+like creating subclasses, you'll find that hashes just work
+out better.
+
+=head2 Closures as Objects
+
+Using a code reference to represent an object offers some fascinating
+possibilities. We can create a new anonymous function (closure) who
+alone in all the world can see the object's data. This is because we
+put the data into an anonymous hash that's lexically visible only to
+the closure we create, bless, and return as the object. This object's
+methods turn around and call the closure as a regular subroutine call,
+passing it the field we want to affect. (Yes,
+the double-function call is slow, but if you wanted fast, you wouldn't
+be using objects at all, eh? :-)
+
+Use would be similar to before:
+
+ use Person;
+ $him = Person->new();
+ $him->name("Jason");
+ $him->age(23);
+ $him->peers( [ "Norbert", "Rhys", "Phineas" ] );
+ printf "%s is %d years old.\n", $him->name, $him->age;
+ print "His peers are: ", join(", ", @{$him->peers}), "\n";
+
+but the implementation would be radically, perhaps even sublimely
+different:
+
+ package Person;
+
+ sub new {
+ my $that = shift;
+ my $class = ref($that) || $that;
+ my $self = {
+ NAME => undef,
+ AGE => undef,
+ PEERS => [],
+ };
+ my $closure = sub {
+ my $field = shift;
+ if (@_) { $self->{$field} = shift }
+ return $self->{$field};
+ };
+ bless($closure, $class);
+ return $closure;
+ }
+
+ sub name { &{ $_[0] }("NAME", @_[ 1 .. $#_ ] ) }
+ sub age { &{ $_[0] }("AGE", @_[ 1 .. $#_ ] ) }
+ sub peers { &{ $_[0] }("PEERS", @_[ 1 .. $#_ ] ) }
+
+ 1;
+
+Because this object is hidden behind a code reference, it's probably a bit
+mysterious to those whose background is more firmly rooted in standard
+procedural or object-based programming languages than in functional
+programming languages whence closures derive. The object
+created and returned by the new() method is itself not a data reference
+as we've seen before. It's an anonymous code reference that has within
+it access to a specific version (lexical binding and instantiation)
+of the object's data, which are stored in the private variable $self.
+Although this is the same function each time, it contains a different
+version of $self.
+
+When a method like C<$him-E<gt>name("Jason")> is called, its implicit
+zeroth argument is the invoking object--just as it is with all method
+calls. But in this case, it's our code reference (something like a
+function pointer in C++, but with deep binding of lexical variables).
+There's not a lot to be done with a code reference beyond calling it, so
+that's just what we do when we say C<&{$_[0]}>. This is just a regular
+function call, not a method call. The initial argument is the string
+"NAME", and any remaining arguments are whatever had been passed to the
+method itself.
+
+Once we're executing inside the closure that had been created in new(),
+the $self hash reference suddenly becomes visible. The closure grabs
+its first argument ("NAME" in this case because that's what the name()
+method passed it), and uses that string to subscript into the private
+hash hidden in its unique version of $self.
+
+Nothing under the sun will allow anyone outside the executing method to
+be able to get at this hidden data. Well, nearly nothing. You I<could>
+single step through the program using the debugger and find out the
+pieces while you're in the method, but everyone else is out of luck.
+
+There, if that doesn't excite the Scheme folks, then I just don't know
+what will. Translation of this technique into C++, Java, or any other
+braindead-static language is left as a futile exercise for aficionados
+of those camps.
+
+You could even add a bit of nosiness via the caller() function and
+make the closure refuse to operate unless called via its own package.
+This would no doubt satisfy certain fastidious concerns of programming
+police and related puritans.
+
+If you were wondering when Hubris, the third principle virtue of a
+programmer, would come into play, here you have it. (More seriously,
+Hubris is just the pride in craftsmanship that comes from having written
+a sound bit of well-designed code.)
+
+=head1 AUTOLOAD: Proxy Methods
+
+Autoloading is a way to intercept calls to undefined methods. An autoload
+routine may choose to create a new function on the fly, either loaded
+from disk or perhaps just eval()ed right there. This define-on-the-fly
+strategy is why it's called autoloading.
+
+But that's only one possible approach. Another one is to just
+have the autoloaded method itself directly provide the
+requested service. When used in this way, you may think
+of autoloaded methods as "proxy" methods.
+
+When Perl tries to call an undefined function in a particular package
+and that function is not defined, it looks for a function in
+that same package called AUTOLOAD. If one exists, it's called
+with the same arguments as the original function would have had.
+The fully-qualified name of the function is stored in that package's
+global variable $AUTOLOAD. Once called, the function can do anything
+it would like, including defining a new function by the right name, and
+then doing a really fancy kind of C<goto> right to it, erasing itself
+from the call stack.
+
+What does this have to do with objects? After all, we keep talking about
+functions, not methods. Well, since a method is just a function with
+an extra argument and some fancier semantics about where it's found,
+we can use autoloading for methods, too. Perl doesn't start looking
+for an AUTOLOAD method until it has exhausted the recursive hunt up
+through @ISA, though. Some programmers have even been known to define
+a UNIVERSAL::AUTOLOAD method to trap unresolved method calls to any
+kind of object.
+
+=head2 Autoloaded Data Methods
+
+You probably began to get a little suspicious about the duplicated
+code way back earlier when we first showed you the Person class, and
+then later the Employee class. Each method used to access the
+hash fields looked virtually identical. This should have tickled
+that great programming virtue, Impatience, but for the time,
+we let Laziness win out, and so did nothing. Proxy methods can cure
+this.
+
+Instead of writing a new function every time we want a new data field,
+we'll use the autoload mechanism to generate (actually, mimic) methods on
+the fly. To verify that we're accessing a valid member, we will check
+against an C<_permitted> (pronounced "under-permitted") field, which
+is a reference to a file-scoped lexical (like a C file static) hash of permitted fields in this record
+called %fields. Why the underscore? For the same reason as the _CENSUS
+field we once used: as a marker that means "for internal use only".
+
+Here's what the module initialization code and class
+constructor will look like when taking this approach:
+
+ package Person;
+ use Carp;
+ use vars qw($AUTOLOAD); # it's a package global
+
+ my %fields = (
+ name => undef,
+ age => undef,
+ peers => undef,
+ );
+
+ sub new {
+ my $that = shift;
+ my $class = ref($that) || $that;
+ my $self = {
+ _permitted => \%fields,
+ %fields,
+ };
+ bless $self, $class;
+ return $self;
+ }
+
+If we wanted our record to have default values, we could fill those in
+where current we have C<undef> in the %fields hash.
+
+Notice how we saved a reference to our class data on the object itself?
+Remember that it's important to access class data through the object
+itself instead of having any method reference %fields directly, or else
+you won't have a decent inheritance.
+
+The real magic, though, is going to reside in our proxy method, which
+will handle all calls to undefined methods for objects of class Person
+(or subclasses of Person). It has to be called AUTOLOAD. Again, it's
+all caps because it's called for us implicitly by Perl itself, not by
+a user directly.
+
+ sub AUTOLOAD {
+ my $self = shift;
+ my $type = ref($self)
+ or croak "$self is not an object";
+
+ my $name = $AUTOLOAD;
+ $name =~ s/.*://; # strip fully-qualified portion
+
+ unless (exists $self->{_permitted}->{$name} ) {
+ croak "Can't access `$name' field in class $type";
+ }
+
+ if (@_) {
+ return $self->{$name} = shift;
+ } else {
+ return $self->{$name};
+ }
+ }
+
+Pretty nifty, eh? All we have to do to add new data fields
+is modify %fields. No new functions need be written.
+
+I could have avoided the C<_permitted> field entirely, but I
+wanted to demonstrate how to store a reference to class data on the
+object so you wouldn't have to access that class data
+directly from an object method.
+
+=head2 Inherited Autoloaded Data Methods
+
+But what about inheritance? Can we define our Employee
+class similarly? Yes, so long as we're careful enough.
+
+Here's how to be careful:
+
+ package Employee;
+ use Person;
+ use strict;
+ use vars qw(@ISA);
+ @ISA = qw(Person);
+
+ my %fields = (
+ id => undef,
+ salary => undef,
+ );
+
+ sub new {
+ my $that = shift;
+ my $class = ref($that) || $that;
+ my $self = bless $that->SUPER::new(), $class;
+ my($element);
+ foreach $element (keys %fields) {
+ $self->{_permitted}->{$element} = $fields{$element};
+ }
+ @{$self}{keys %fields} = values %fields;
+ return $self;
+ }
+
+Once we've done this, we don't even need to have an
+AUTOLOAD function in the Employee package, because
+we'll grab Person's version of that via inheritance,
+and it will all work out just fine.
+
+=head1 Metaclassical Tools
+
+Even though proxy methods can provide a more convenient approach to making
+more struct-like classes than tediously coding up data methods as
+functions, it still leaves a bit to be desired. For one thing, it means
+you have to handle bogus calls that you don't mean to trap via your proxy.
+It also means you have to be quite careful when dealing with inheritance,
+as detailed above.
+
+Perl programmers have responded to this by creating several different
+class construction classes. These metaclasses are classes
+that create other classes. A couple worth looking at are
+Class::Struct and Alias. These and other related metaclasses can be
+found in the modules directory on CPAN.
+
+=head2 Class::Struct
+
+One of the older ones is Class::Struct. In fact, its syntax and
+interface were sketched out long before perl5 even solidified into a
+real thing. What it does is provide you a way to "declare" a class
+as having objects whose fields are of a specific type. The function
+that does this is called, not surprisingly enough, struct(). Because
+structures or records are not base types in Perl, each time you want to
+create a class to provide a record-like data object, you yourself have
+to define a new() method, plus separate data-access methods for each of
+that record's fields. You'll quickly become bored with this process.
+The Class::Struct::struct() function alleviates this tedium.
+
+Here's a simple example of using it:
+
+ use Class::Struct qw(struct);
+ use Jobbie; # user-defined; see below
+
+ struct 'Fred' => {
+ one => '$',
+ many => '@',
+ profession => Jobbie, # calls Jobbie->new()
+ };
+
+ $ob = Fred->new;
+ $ob->one("hmmmm");
+
+ $ob->many(0, "here");
+ $ob->many(1, "you");
+ $ob->many(2, "go");
+ print "Just set: ", $ob->many(2), "\n";
+
+ $ob->profession->salary(10_000);
+
+You can declare types in the struct to be basic Perl types, or
+user-defined types (classes). User types will be initialized by calling
+that class's new() method.
+
+Here's a real-world example of using struct generation. Let's say you
+wanted to override Perl's idea of gethostbyname() and gethostbyaddr() so
+that they would return objects that acted like C structures. We don't
+care about high-falutin' OO gunk. All we want is for these objects to
+act like structs in the C sense.
+
+ use Socket;
+ use Net::hostent;
+ $h = gethostbyname("perl.com"); # object return
+ printf "perl.com's real name is %s, address %s\n",
+ $h->name, inet_ntoa($h->addr);
+
+Here's how to do this using the Class::Struct module.
+The crux is going to be this call:
+
+ struct 'Net::hostent' => [ # note bracket
+ name => '$',
+ aliases => '@',
+ addrtype => '$',
+ 'length' => '$',
+ addr_list => '@',
+ ];
+
+Which creates object methods of those names and types.
+It even creates a new() method for us.
+
+We could also have implemented our object this way:
+
+ struct 'Net::hostent' => { # note brace
+ name => '$',
+ aliases => '@',
+ addrtype => '$',
+ 'length' => '$',
+ addr_list => '@',
+ };
+
+and then Class::Struct would have used an anonymous hash as the object
+type, instead of an anonymous array. The array is faster and smaller,
+but the hash works out better if you eventually want to do inheritance.
+Since for this struct-like object we aren't planning on inheritance,
+this time we'll opt for better speed and size over better flexibility.
+
+Here's the whole implementation:
+
+ package Net::hostent;
+ use strict;
+
+ BEGIN {
+ use Exporter ();
+ use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @EXPORT = qw(gethostbyname gethostbyaddr gethost);
+ @EXPORT_OK = qw(
+ $h_name @h_aliases
+ $h_addrtype $h_length
+ @h_addr_list $h_addr
+ );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+ }
+ use vars @EXPORT_OK;
+
+ # Class::Struct forbids use of @ISA
+ sub import { goto &Exporter::import }
+
+ use Class::Struct qw(struct);
+ struct 'Net::hostent' => [
+ name => '$',
+ aliases => '@',
+ addrtype => '$',
+ 'length' => '$',
+ addr_list => '@',
+ ];
+
+ sub addr { shift->addr_list->[0] }
+
+ sub populate (@) {
+ return unless @_;
+ my $hob = new(); # Class::Struct made this!
+ $h_name = $hob->[0] = $_[0];
+ @h_aliases = @{ $hob->[1] } = split ' ', $_[1];
+ $h_addrtype = $hob->[2] = $_[2];
+ $h_length = $hob->[3] = $_[3];
+ $h_addr = $_[4];
+ @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ];
+ return $hob;
+ }
+
+ sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) }
+
+ sub gethostbyaddr ($;$) {
+ my ($addr, $addrtype);
+ $addr = shift;
+ require Socket unless @_;
+ $addrtype = @_ ? shift : Socket::AF_INET();
+ populate(CORE::gethostbyaddr($addr, $addrtype))
+ }
+
+ sub gethost($) {
+ if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) {
+ require Socket;
+ &gethostbyaddr(Socket::inet_aton(shift));
+ } else {
+ &gethostbyname;
+ }
+ }
+
+ 1;
+
+We've snuck in quite a fair bit of other concepts besides just dynamic
+class creation, like overriding core functions, import/export bits,
+function prototyping, short-cut function call via C<&whatever>, and
+function replacement with C<goto &whatever>. These all mostly make
+sense from the perspective of a traditional module, but as you can see,
+we can also use them in an object module.
+
+You can look at other object-based, struct-like overrides of core
+functions in the 5.004 release of Perl in File::stat, Net::hostent,
+Net::netent, Net::protoent, Net::servent, Time::gmtime, Time::localtime,
+User::grent, and User::pwent. These modules have a final component
+that's all lowercase, by convention reserved for compiler pragmas,
+because they affect the compilation and change a builtin function.
+They also have the type names that a C programmer would most expect.
+
+=head2 Data Members as Variables
+
+If you're used to C++ objects, then you're accustomed to being able to
+get at an object's data members as simple variables from within a method.
+The Alias module provides for this, as well as a good bit more, such
+as the possibility of private methods that the object can call but folks
+outside the class cannot.
+
+Here's an example of creating a Person using the Alias module.
+When you update these magical instance variables, you automatically
+update value fields in the hash. Convenient, eh?
+
+ package Person;
+
+ # this is the same as before...
+ sub new {
+ my $that = shift;
+ my $class = ref($that) || $that;
+ my $self = {
+ NAME => undef,
+ AGE => undef,
+ PEERS => [],
+ };
+ bless($self, $class);
+ return $self;
+ }
+
+ use Alias qw(attr);
+ use vars qw($NAME $AGE $PEERS);
+
+ sub name {
+ my $self = attr shift;
+ if (@_) { $NAME = shift; }
+ return $NAME;
+ }
+
+ sub age {
+ my $self = attr shift;
+ if (@_) { $AGE = shift; }
+ return $AGE;
+ }
+
+ sub peers {
+ my $self = attr shift;
+ if (@_) { @PEERS = @_; }
+ return @PEERS;
+ }
+
+ sub exclaim {
+ my $self = attr shift;
+ return sprintf "Hi, I'm %s, age %d, working with %s",
+ $NAME, $AGE, join(", ", @PEERS);
+ }
+
+ sub happy_birthday {
+ my $self = attr shift;
+ return ++$AGE;
+ }
+
+The need for the C<use vars> declaration is because what Alias does
+is play with package globals with the same name as the fields. To use
+globals while C<use strict> is in effect, you have to predeclare them.
+These package variables are localized to the block enclosing the attr()
+call just as if you'd used a local() on them. However, that means that
+they're still considered global variables with temporary values, just
+as with any other local().
+
+It would be nice to combine Alias with
+something like Class::Struct or Class::MethodMaker.
+
+=head2 NOTES
+
+=head2 Object Terminology
+
+In the various OO literature, it seems that a lot of different words
+are used to describe only a few different concepts. If you're not
+already an object programmer, then you don't need to worry about all
+these fancy words. But if you are, then you might like to know how to
+get at the same concepts in Perl.
+
+For example, it's common to call an object an I<instance> of a class
+and to call those objects' methods I<instance methods>. Data fields
+peculiar to each object are often called I<instance data> or I<object
+attributes>, and data fields common to all members of that class are
+I<class data>, I<class attributes>, or I<static data members>.
+
+Also, I<base class>, I<generic class>, and I<superclass> all describe
+the same notion, whereas I<derived class>, I<specific class>, and
+I<subclass> describe the other related one.
+
+C++ programmers have I<static methods> and I<virtual methods>,
+but Perl only has I<class methods> and I<object methods>.
+Actually, Perl only has methods. Whether a method gets used
+as a class or object method is by usage only. You could accidentally
+call a class method (one expecting a string argument) on an
+object (one expecting a reference), or vice versa.
+
+Z<>From the C++ perspective, all methods in Perl are virtual.
+This, by the way, is why they are never checked for function
+prototypes in the argument list as regular builtin and user-defined
+functions can be.
+
+Because a class is itself something of an object, Perl's classes can be
+taken as describing both a "class as meta-object" (also called I<object
+factory>) philosophy and the "class as type definition" (I<declaring>
+behaviour, not I<defining> mechanism) idea. C++ supports the latter
+notion, but not the former.
+
+=head1 SEE ALSO
+
+The following manpages will doubtless provide more
+background for this one:
+L<perlmod>,
+L<perlref>,
+L<perlobj>,
+L<perlbot>,
+L<perltie>,
+and
+L<overload>.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997, 1998 Tom Christiansen
+All rights reserved.
+
+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 I<outside>
+of that package require that special arrangements be made with
+copyright holder.
+
+Irrespective of its distribution, all code examples in this file
+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.
+
+=head1 COPYRIGHT
+
+=head2 Acknowledgments
+
+Thanks to
+Larry Wall,
+Roderick Schertler,
+Gurusamy Sarathy,
+Dean Roehrich,
+Raphael Manfredi,
+Brent Halsey,
+Greg Bacon,
+Brad Appleton,
+and many others for their helpful comments.
diff --git a/contrib/perl5/pod/perltrap.pod b/contrib/perl5/pod/perltrap.pod
new file mode 100644
index 000000000000..852d8e98263e
--- /dev/null
+++ b/contrib/perl5/pod/perltrap.pod
@@ -0,0 +1,1505 @@
+=head1 NAME
+
+perltrap - Perl traps for the unwary
+
+=head1 DESCRIPTION
+
+The biggest trap of all is forgetting to use the B<-w> switch; see
+L<perlrun>. The second biggest trap is not making your entire program
+runnable under C<use strict>. The third biggest trap is not reading
+the list of changes in this version of Perl; see L<perldelta>.
+
+=head2 Awk Traps
+
+Accustomed B<awk> users should take special note of the following:
+
+=over 4
+
+=item *
+
+The English module, loaded via
+
+ use English;
+
+allows you to refer to special variables (like C<$/>) with names (like
+C<$RS>), as though they were in B<awk>; see L<perlvar> for details.
+
+=item *
+
+Semicolons are required after all simple statements in Perl (except
+at the end of a block). Newline is not a statement delimiter.
+
+=item *
+
+Curly brackets are required on C<if>s and C<while>s.
+
+=item *
+
+Variables begin with "$", "@" or "%" in Perl.
+
+=item *
+
+Arrays index from 0. Likewise string positions in substr() and
+index().
+
+=item *
+
+You have to decide whether your array has numeric or string indices.
+
+=item *
+
+Hash values do not spring into existence upon mere reference.
+
+=item *
+
+You have to decide whether you want to use string or numeric
+comparisons.
+
+=item *
+
+Reading an input line does not split it for you. You get to split it
+to an array yourself. And the split() operator has different
+arguments than B<awk>'s.
+
+=item *
+
+The current input line is normally in $_, not $0. It generally does
+not have the newline stripped. ($0 is the name of the program
+executed.) See L<perlvar>.
+
+=item *
+
+$E<lt>I<digit>E<gt> does not refer to fields--it refers to substrings matched
+by the last match pattern.
+
+=item *
+
+The print() statement does not add field and record separators unless
+you set C<$,> and C<$\>. You can set $OFS and $ORS if you're using
+the English module.
+
+=item *
+
+You must open your files before you print to them.
+
+=item *
+
+The range operator is "..", not comma. The comma operator works as in
+C.
+
+=item *
+
+The match operator is "=~", not "~". ("~" is the one's complement
+operator, as in C.)
+
+=item *
+
+The exponentiation operator is "**", not "^". "^" is the XOR
+operator, as in C. (You know, one could get the feeling that B<awk> is
+basically incompatible with C.)
+
+=item *
+
+The concatenation operator is ".", not the null string. (Using the
+null string would render C</pat/ /pat/> unparsable, because the third slash
+would be interpreted as a division operator--the tokenizer is in fact
+slightly context sensitive for operators like "/", "?", and "E<gt>".
+And in fact, "." itself can be the beginning of a number.)
+
+=item *
+
+The C<next>, C<exit>, and C<continue> keywords work differently.
+
+=item *
+
+
+The following variables work differently:
+
+ Awk Perl
+ ARGC $#ARGV or scalar @ARGV
+ ARGV[0] $0
+ FILENAME $ARGV
+ FNR $. - something
+ FS (whatever you like)
+ NF $#Fld, or some such
+ NR $.
+ OFMT $#
+ OFS $,
+ ORS $\
+ RLENGTH length($&)
+ RS $/
+ RSTART length($`)
+ SUBSEP $;
+
+=item *
+
+You cannot set $RS to a pattern, only a string.
+
+=item *
+
+When in doubt, run the B<awk> construct through B<a2p> and see what it
+gives you.
+
+=back
+
+=head2 C Traps
+
+Cerebral C programmers should take note of the following:
+
+=over 4
+
+=item *
+
+Curly brackets are required on C<if>'s and C<while>'s.
+
+=item *
+
+You must use C<elsif> rather than C<else if>.
+
+=item *
+
+The C<break> and C<continue> keywords from C become in
+Perl C<last> and C<next>, respectively.
+Unlike in C, these do I<NOT> work within a C<do { } while> construct.
+
+=item *
+
+There's no switch statement. (But it's easy to build one on the fly.)
+
+=item *
+
+Variables begin with "$", "@" or "%" in Perl.
+
+=item *
+
+C<printf()> does not implement the "*" format for interpolating
+field widths, but it's trivial to use interpolation of double-quoted
+strings to achieve the same effect.
+
+=item *
+
+Comments begin with "#", not "/*".
+
+=item *
+
+You can't take the address of anything, although a similar operator
+in Perl is the backslash, which creates a reference.
+
+=item *
+
+C<ARGV> must be capitalized. C<$ARGV[0]> is C's C<argv[1]>, and C<argv[0]>
+ends up in C<$0>.
+
+=item *
+
+System calls such as link(), unlink(), rename(), etc. return nonzero for
+success, not 0.
+
+=item *
+
+Signal handlers deal with signal names, not numbers. Use C<kill -l>
+to find their names on your system.
+
+=back
+
+=head2 Sed Traps
+
+Seasoned B<sed> programmers should take note of the following:
+
+=over 4
+
+=item *
+
+Backreferences in substitutions use "$" rather than "\".
+
+=item *
+
+The pattern matching metacharacters "(", ")", and "|" do not have backslashes
+in front.
+
+=item *
+
+The range operator is C<...>, rather than comma.
+
+=back
+
+=head2 Shell Traps
+
+Sharp shell programmers should take note of the following:
+
+=over 4
+
+=item *
+
+The backtick operator does variable interpolation without regard to
+the presence of single quotes in the command.
+
+=item *
+
+The backtick operator does no translation of the return value, unlike B<csh>.
+
+=item *
+
+Shells (especially B<csh>) do several levels of substitution on each
+command line. Perl does substitution in only certain constructs
+such as double quotes, backticks, angle brackets, and search patterns.
+
+=item *
+
+Shells interpret scripts a little bit at a time. Perl compiles the
+entire program before executing it (except for C<BEGIN> blocks, which
+execute at compile time).
+
+=item *
+
+The arguments are available via @ARGV, not $1, $2, etc.
+
+=item *
+
+The environment is not automatically made available as separate scalar
+variables.
+
+=back
+
+=head2 Perl Traps
+
+Practicing Perl Programmers should take note of the following:
+
+=over 4
+
+=item *
+
+Remember that many operations behave differently in a list
+context than they do in a scalar one. See L<perldata> for details.
+
+=item *
+
+Avoid barewords if you can, especially all lowercase ones.
+You can't tell by just looking at it whether a bareword is
+a function or a string. By using quotes on strings and
+parentheses on function calls, you won't ever get them confused.
+
+=item *
+
+You cannot discern from mere inspection which builtins
+are unary operators (like chop() and chdir())
+and which are list operators (like print() and unlink()).
+(User-defined subroutines can be B<only> list operators, never
+unary ones.) See L<perlop>.
+
+=item *
+
+People have a hard time remembering that some functions
+default to $_, or @ARGV, or whatever, but that others which
+you might expect to do not.
+
+=item *
+
+The E<lt>FHE<gt> construct is not the name of the filehandle, it is a readline
+operation on that handle. The data read is assigned to $_ only if the
+file read is the sole condition in a while loop:
+
+ while (<FH>) { }
+ while (defined($_ = <FH>)) { }..
+ <FH>; # data discarded!
+
+=item *
+
+Remember not to use "C<=>" when you need "C<=~>";
+these two constructs are quite different:
+
+ $x = /foo/;
+ $x =~ /foo/;
+
+=item *
+
+The C<do {}> construct isn't a real loop that you can use
+loop control on.
+
+=item *
+
+Use C<my()> for local variables whenever you can get away with
+it (but see L<perlform> for where you can't).
+Using C<local()> actually gives a local value to a global
+variable, which leaves you open to unforeseen side-effects
+of dynamic scoping.
+
+=item *
+
+If you localize an exported variable in a module, its exported value will
+not change. The local name becomes an alias to a new value but the
+external name is still an alias for the original.
+
+=back
+
+=head2 Perl4 to Perl5 Traps
+
+Practicing Perl4 Programmers should take note of the following
+Perl4-to-Perl5 specific traps.
+
+They're crudely ordered according to the following list:
+
+=over 4
+
+=item Discontinuance, Deprecation, and BugFix traps
+
+Anything that's been fixed as a perl4 bug, removed as a perl4 feature
+or deprecated as a perl4 feature with the intent to encourage usage of
+some other perl5 feature.
+
+=item Parsing Traps
+
+Traps that appear to stem from the new parser.
+
+=item Numerical Traps
+
+Traps having to do with numerical or mathematical operators.
+
+=item General data type traps
+
+Traps involving perl standard data types.
+
+=item Context Traps - scalar, list contexts
+
+Traps related to context within lists, scalar statements/declarations.
+
+=item Precedence Traps
+
+Traps related to the precedence of parsing, evaluation, and execution of
+code.
+
+=item General Regular Expression Traps using s///, etc.
+
+Traps related to the use of pattern matching.
+
+=item Subroutine, Signal, Sorting Traps
+
+Traps related to the use of signals and signal handlers, general subroutines,
+and sorting, along with sorting subroutines.
+
+=item OS Traps
+
+OS-specific traps.
+
+=item DBM Traps
+
+Traps specific to the use of C<dbmopen()>, and specific dbm implementations.
+
+=item Unclassified Traps
+
+Everything else.
+
+=back
+
+If you find an example of a conversion trap that is not listed here,
+please submit it to Bill Middleton <F<wjm@best.com>> for inclusion.
+Also note that at least some of these can be caught with B<-w>.
+
+=head2 Discontinuance, Deprecation, and BugFix traps
+
+Anything that has been discontinued, deprecated, or fixed as
+a bug from perl4.
+
+=over 4
+
+=item * Discontinuance
+
+Symbols starting with "_" are no longer forced into package main, except
+for C<$_> itself (and C<@_>, etc.).
+
+ package test;
+ $_legacy = 1;
+
+ package main;
+ print "\$_legacy is ",$_legacy,"\n";
+
+ # perl4 prints: $_legacy is 1
+ # perl5 prints: $_legacy is
+
+=item * Deprecation
+
+Double-colon is now a valid package separator in a variable name. Thus these
+behave differently in perl4 vs. perl5, because the packages don't exist.
+
+ $a=1;$b=2;$c=3;$var=4;
+ print "$a::$b::$c ";
+ print "$var::abc::xyz\n";
+
+ # perl4 prints: 1::2::3 4::abc::xyz
+ # perl5 prints: 3
+
+Given that C<::> is now the preferred package delimiter, it is debatable
+whether this should be classed as a bug or not.
+(The older package delimiter, ' ,is used here)
+
+ $x = 10 ;
+ print "x=${'x}\n" ;
+
+ # perl4 prints: x=10
+ # perl5 prints: Can't find string terminator "'" anywhere before EOF
+
+You can avoid this problem, and remain compatible with perl4, if you
+always explicitly include the package name:
+
+ $x = 10 ;
+ print "x=${main'x}\n" ;
+
+Also see precedence traps, for parsing C<$:>.
+
+=item * BugFix
+
+The second and third arguments of C<splice()> are now evaluated in scalar
+context (as the Camel says) rather than list context.
+
+ sub sub1{return(0,2) } # return a 2-element list
+ sub sub2{ return(1,2,3)} # return a 3-element list
+ @a1 = ("a","b","c","d","e");
+ @a2 = splice(@a1,&sub1,&sub2);
+ print join(' ',@a2),"\n";
+
+ # perl4 prints: a b
+ # perl5 prints: c d e
+
+=item * Discontinuance
+
+You can't do a C<goto> into a block that is optimized away. Darn.
+
+ goto marker1;
+
+ for(1){
+ marker1:
+ print "Here I is!\n";
+ }
+
+ # perl4 prints: Here I is!
+ # perl5 dumps core (SEGV)
+
+=item * Discontinuance
+
+It is no longer syntactically legal to use whitespace as the name
+of a variable, or as a delimiter for any kind of quote construct.
+Double darn.
+
+ $a = ("foo bar");
+ $b = q baz ;
+ print "a is $a, b is $b\n";
+
+ # perl4 prints: a is foo bar, b is baz
+ # perl5 errors: Bareword found where operator expected
+
+=item * Discontinuance
+
+The archaic while/if BLOCK BLOCK syntax is no longer supported.
+
+ if { 1 } {
+ print "True!";
+ }
+ else {
+ print "False!";
+ }
+
+ # perl4 prints: True!
+ # perl5 errors: syntax error at test.pl line 1, near "if {"
+
+=item * BugFix
+
+The C<**> operator now binds more tightly than unary minus.
+It was documented to work this way before, but didn't.
+
+ print -4**2,"\n";
+
+ # perl4 prints: 16
+ # perl5 prints: -16
+
+=item * Discontinuance
+
+The meaning of C<foreach{}> has changed slightly when it is iterating over a
+list which is not an array. This used to assign the list to a
+temporary array, but no longer does so (for efficiency). This means
+that you'll now be iterating over the actual values, not over copies of
+the values. Modifications to the loop variable can change the original
+values.
+
+ @list = ('ab','abc','bcd','def');
+ foreach $var (grep(/ab/,@list)){
+ $var = 1;
+ }
+ print (join(':',@list));
+
+ # perl4 prints: ab:abc:bcd:def
+ # perl5 prints: 1:1:bcd:def
+
+To retain Perl4 semantics you need to assign your list
+explicitly to a temporary array and then iterate over that. For
+example, you might need to change
+
+ foreach $var (grep(/ab/,@list)){
+
+to
+
+ foreach $var (@tmp = grep(/ab/,@list)){
+
+Otherwise changing $var will clobber the values of @list. (This most often
+happens when you use C<$_> for the loop variable, and call subroutines in
+the loop that don't properly localize C<$_>.)
+
+=item * Discontinuance
+
+C<split> with no arguments now behaves like C<split ' '> (which doesn't
+return an initial null field if $_ starts with whitespace), it used to
+behave like C<split /\s+/> (which does).
+
+ $_ = ' hi mom';
+ print join(':', split);
+
+ # perl4 prints: :hi:mom
+ # perl5 prints: hi:mom
+
+=item * BugFix
+
+Perl 4 would ignore any text which was attached to an B<-e> switch,
+always taking the code snippet from the following arg. Additionally, it
+would silently accept an B<-e> switch without a following arg. Both of
+these behaviors have been fixed.
+
+ perl -e'print "attached to -e"' 'print "separate arg"'
+
+ # perl4 prints: separate arg
+ # perl5 prints: attached to -e
+
+ perl -e
+
+ # perl4 prints:
+ # perl5 dies: No code specified for -e.
+
+=item * Discontinuance
+
+In Perl 4 the return value of C<push> was undocumented, but it was
+actually the last value being pushed onto the target list. In Perl 5
+the return value of C<push> is documented, but has changed, it is the
+number of elements in the resulting list.
+
+ @x = ('existing');
+ print push(@x, 'first new', 'second new');
+
+ # perl4 prints: second new
+ # perl5 prints: 3
+
+=item * Discontinuance
+
+In Perl 4 (and versions of Perl 5 before 5.004), C<'\r'> characters in
+Perl code were silently allowed, although they could cause (mysterious!)
+failures in certain constructs, particularly here documents. Now,
+C<'\r'> characters cause an immediate fatal error. (Note: In this
+example, the notation B<\015> represents the incorrect line
+ending. Depending upon your text viewer, it will look different.)
+
+ print "foo";\015
+ print "bar";
+
+ # perl4 prints: foobar
+ # perl5.003 prints: foobar
+ # perl5.004 dies: Illegal character \015 (carriage return)
+
+See L<perldiag> for full details.
+
+=item * Deprecation
+
+Some error messages will be different.
+
+=item * Discontinuance
+
+Some bugs may have been inadvertently removed. :-)
+
+=back
+
+=head2 Parsing Traps
+
+Perl4-to-Perl5 traps from having to do with parsing.
+
+=over 4
+
+=item * Parsing
+
+Note the space between . and =
+
+ $string . = "more string";
+ print $string;
+
+ # perl4 prints: more string
+ # perl5 prints: syntax error at - line 1, near ". ="
+
+=item * Parsing
+
+Better parsing in perl 5
+
+ sub foo {}
+ &foo
+ print("hello, world\n");
+
+ # perl4 prints: hello, world
+ # perl5 prints: syntax error
+
+=item * Parsing
+
+"if it looks like a function, it is a function" rule.
+
+ print
+ ($foo == 1) ? "is one\n" : "is zero\n";
+
+ # perl4 prints: is zero
+ # perl5 warns: "Useless use of a constant in void context" if using -w
+
+=item * Parsing
+
+String interpolation of the C<$#array> construct differs when braces
+are to used around the name.
+
+ @ = (1..3);
+ print "${#a}";
+
+ # perl4 prints: 2
+ # perl5 fails with syntax error
+
+ @ = (1..3);
+ print "$#{a}";
+
+ # perl4 prints: {a}
+ # perl5 prints: 2
+
+=back
+
+=head2 Numerical Traps
+
+Perl4-to-Perl5 traps having to do with numerical operators,
+operands, or output from same.
+
+=over 5
+
+=item * Numerical
+
+Formatted output and significant digits
+
+ print 7.373504 - 0, "\n";
+ printf "%20.18f\n", 7.373504 - 0;
+
+ # Perl4 prints:
+ 7.375039999999996141
+ 7.37503999999999614
+
+ # Perl5 prints:
+ 7.373504
+ 7.37503999999999614
+
+=item * Numerical
+
+This specific item has been deleted. It demonstrated how the auto-increment
+operator would not catch when a number went over the signed int limit. Fixed
+in version 5.003_04. But always be wary when using large integers.
+If in doubt:
+
+ use Math::BigInt;
+
+=item * Numerical
+
+Assignment of return values from numeric equality tests
+does not work in perl5 when the test evaluates to false (0).
+Logical tests now return an null, instead of 0
+
+ $p = ($test == 1);
+ print $p,"\n";
+
+ # perl4 prints: 0
+ # perl5 prints:
+
+Also see L<"General Regular Expression Traps using s///, etc.">
+for another example of this new feature...
+
+=back
+
+=head2 General data type traps
+
+Perl4-to-Perl5 traps involving most data-types, and their usage
+within certain expressions and/or context.
+
+=over 5
+
+=item * (Arrays)
+
+Negative array subscripts now count from the end of the array.
+
+ @a = (1, 2, 3, 4, 5);
+ print "The third element of the array is $a[3] also expressed as $a[-2] \n";
+
+ # perl4 prints: The third element of the array is 4 also expressed as
+ # perl5 prints: The third element of the array is 4 also expressed as 4
+
+=item * (Arrays)
+
+Setting C<$#array> lower now discards array elements, and makes them
+impossible to recover.
+
+ @a = (a,b,c,d,e);
+ print "Before: ",join('',@a);
+ $#a =1;
+ print ", After: ",join('',@a);
+ $#a =3;
+ print ", Recovered: ",join('',@a),"\n";
+
+ # perl4 prints: Before: abcde, After: ab, Recovered: abcd
+ # perl5 prints: Before: abcde, After: ab, Recovered: ab
+
+=item * (Hashes)
+
+Hashes get defined before use
+
+ local($s,@a,%h);
+ die "scalar \$s defined" if defined($s);
+ die "array \@a defined" if defined(@a);
+ die "hash \%h defined" if defined(%h);
+
+ # perl4 prints:
+ # perl5 dies: hash %h defined
+
+=item * (Globs)
+
+glob assignment from variable to variable will fail if the assigned
+variable is localized subsequent to the assignment
+
+ @a = ("This is Perl 4");
+ *b = *a;
+ local(@a);
+ print @b,"\n";
+
+ # perl4 prints: This is Perl 4
+ # perl5 prints:
+
+=item * (Globs)
+
+Assigning C<undef> to a glob has no effect in Perl 5. In Perl 4
+it undefines the associated scalar (but may have other side effects
+including SEGVs).
+
+=item * (Scalar String)
+
+Changes in unary negation (of strings)
+This change effects both the return value and what it
+does to auto(magic)increment.
+
+ $x = "aaa";
+ print ++$x," : ";
+ print -$x," : ";
+ print ++$x,"\n";
+
+ # perl4 prints: aab : -0 : 1
+ # perl5 prints: aab : -aab : aac
+
+=item * (Constants)
+
+perl 4 lets you modify constants:
+
+ $foo = "x";
+ &mod($foo);
+ for ($x = 0; $x < 3; $x++) {
+ &mod("a");
+ }
+ sub mod {
+ print "before: $_[0]";
+ $_[0] = "m";
+ print " after: $_[0]\n";
+ }
+
+ # perl4:
+ # before: x after: m
+ # before: a after: m
+ # before: m after: m
+ # before: m after: m
+
+ # Perl5:
+ # before: x after: m
+ # Modification of a read-only value attempted at foo.pl line 12.
+ # before: a
+
+=item * (Scalars)
+
+The behavior is slightly different for:
+
+ print "$x", defined $x
+
+ # perl 4: 1
+ # perl 5: <no output, $x is not called into existence>
+
+=item * (Variable Suicide)
+
+Variable suicide behavior is more consistent under Perl 5.
+Perl5 exhibits the same behavior for hashes and scalars,
+that perl4 exhibits for only scalars.
+
+ $aGlobal{ "aKey" } = "global value";
+ print "MAIN:", $aGlobal{"aKey"}, "\n";
+ $GlobalLevel = 0;
+ &test( *aGlobal );
+
+ sub test {
+ local( *theArgument ) = @_;
+ local( %aNewLocal ); # perl 4 != 5.001l,m
+ $aNewLocal{"aKey"} = "this should never appear";
+ print "SUB: ", $theArgument{"aKey"}, "\n";
+ $aNewLocal{"aKey"} = "level $GlobalLevel"; # what should print
+ $GlobalLevel++;
+ if( $GlobalLevel<4 ) {
+ &test( *aNewLocal );
+ }
+ }
+
+ # Perl4:
+ # MAIN:global value
+ # SUB: global value
+ # SUB: level 0
+ # SUB: level 1
+ # SUB: level 2
+
+ # Perl5:
+ # MAIN:global value
+ # SUB: global value
+ # SUB: this should never appear
+ # SUB: this should never appear
+ # SUB: this should never appear
+
+=back
+
+=head2 Context Traps - scalar, list contexts
+
+=over 5
+
+=item * (list context)
+
+The elements of argument lists for formats are now evaluated in list
+context. This means you can interpolate list values now.
+
+ @fmt = ("foo","bar","baz");
+ format STDOUT=
+ @<<<<< @||||| @>>>>>
+ @fmt;
+ .
+ write;
+
+ # perl4 errors: Please use commas to separate fields in file
+ # perl5 prints: foo bar baz
+
+=item * (scalar context)
+
+The C<caller()> function now returns a false value in a scalar context
+if there is no caller. This lets library files determine if they're
+being required.
+
+ caller() ? (print "You rang?\n") : (print "Got a 0\n");
+
+ # perl4 errors: There is no caller
+ # perl5 prints: Got a 0
+
+=item * (scalar context)
+
+The comma operator in a scalar context is now guaranteed to give a
+scalar context to its arguments.
+
+ @y= ('a','b','c');
+ $x = (1, 2, @y);
+ print "x = $x\n";
+
+ # Perl4 prints: x = c # Thinks list context interpolates list
+ # Perl5 prints: x = 3 # Knows scalar uses length of list
+
+=item * (list, builtin)
+
+C<sprintf()> funkiness (array argument converted to scalar array count)
+This test could be added to t/op/sprintf.t
+
+ @z = ('%s%s', 'foo', 'bar');
+ $x = sprintf(@z);
+ if ($x eq 'foobar') {print "ok 2\n";} else {print "not ok 2 '$x'\n";}
+
+ # perl4 prints: ok 2
+ # perl5 prints: not ok 2
+
+C<printf()> works fine, though:
+
+ printf STDOUT (@z);
+ print "\n";
+
+ # perl4 prints: foobar
+ # perl5 prints: foobar
+
+Probably a bug.
+
+=back
+
+=head2 Precedence Traps
+
+Perl4-to-Perl5 traps involving precedence order.
+
+Perl 4 has almost the same precedence rules as Perl 5 for the operators
+that they both have. Perl 4 however, seems to have had some
+inconsistencies that made the behavior differ from what was documented.
+
+=over 5
+
+=item * Precedence
+
+LHS vs. RHS of any assignment operator. LHS is evaluated first
+in perl4, second in perl5; this can affect the relationship
+between side-effects in sub-expressions.
+
+ @arr = ( 'left', 'right' );
+ $a{shift @arr} = shift @arr;
+ print join( ' ', keys %a );
+
+ # perl4 prints: left
+ # perl5 prints: right
+
+=item * Precedence
+
+These are now semantic errors because of precedence:
+
+ @list = (1,2,3,4,5);
+ %map = ("a",1,"b",2,"c",3,"d",4);
+ $n = shift @list + 2; # first item in list plus 2
+ print "n is $n, ";
+ $m = keys %map + 2; # number of items in hash plus 2
+ print "m is $m\n";
+
+ # perl4 prints: n is 3, m is 6
+ # perl5 errors and fails to compile
+
+=item * Precedence
+
+The precedence of assignment operators is now the same as the precedence
+of assignment. Perl 4 mistakenly gave them the precedence of the associated
+operator. So you now must parenthesize them in expressions like
+
+ /foo/ ? ($a += 2) : ($a -= 2);
+
+Otherwise
+
+ /foo/ ? $a += 2 : $a -= 2
+
+would be erroneously parsed as
+
+ (/foo/ ? $a += 2 : $a) -= 2;
+
+On the other hand,
+
+ $a += /foo/ ? 1 : 2;
+
+now works as a C programmer would expect.
+
+=item * Precedence
+
+ open FOO || die;
+
+is now incorrect. You need parentheses around the filehandle.
+Otherwise, perl5 leaves the statement as its default precedence:
+
+ open(FOO || die);
+
+ # perl4 opens or dies
+ # perl5 errors: Precedence problem: open FOO should be open(FOO)
+
+=item * Precedence
+
+perl4 gives the special variable, C<$:> precedence, where perl5
+treats C<$::> as main C<package>
+
+ $a = "x"; print "$::a";
+
+ # perl 4 prints: -:a
+ # perl 5 prints: x
+
+=item * Precedence
+
+perl4 had buggy precedence for the file test operators vis-a-vis
+the assignment operators. Thus, although the precedence table
+for perl4 leads one to believe C<-e $foo .= "q"> should parse as
+C<((-e $foo) .= "q")>, it actually parses as C<(-e ($foo .= "q"))>.
+In perl5, the precedence is as documented.
+
+ -e $foo .= "q"
+
+ # perl4 prints: no output
+ # perl5 prints: Can't modify -e in concatenation
+
+=item * Precedence
+
+In perl4, keys(), each() and values() were special high-precedence operators
+that operated on a single hash, but in perl5, they are regular named unary
+operators. As documented, named unary operators have lower precedence
+than the arithmetic and concatenation operators C<+ - .>, but the perl4
+variants of these operators actually bind tighter than C<+ - .>.
+Thus, for:
+
+ %foo = 1..10;
+ print keys %foo - 1
+
+ # perl4 prints: 4
+ # perl5 prints: Type of arg 1 to keys must be hash (not subtraction)
+
+The perl4 behavior was probably more useful, if less consistent.
+
+=back
+
+=head2 General Regular Expression Traps using s///, etc.
+
+All types of RE traps.
+
+=over 5
+
+=item * Regular Expression
+
+C<s'$lhs'$rhs'> now does no interpolation on either side. It used to
+interpolate C<$lhs> but not C<$rhs>. (And still does not match a literal
+'$' in string)
+
+ $a=1;$b=2;
+ $string = '1 2 $a $b';
+ $string =~ s'$a'$b';
+ print $string,"\n";
+
+ # perl4 prints: $b 2 $a $b
+ # perl5 prints: 1 2 $a $b
+
+=item * Regular Expression
+
+C<m//g> now attaches its state to the searched string rather than the
+regular expression. (Once the scope of a block is left for the sub, the
+state of the searched string is lost)
+
+ $_ = "ababab";
+ while(m/ab/g){
+ &doit("blah");
+ }
+ sub doit{local($_) = shift; print "Got $_ "}
+
+ # perl4 prints: blah blah blah
+ # perl5 prints: infinite loop blah...
+
+=item * Regular Expression
+
+Currently, if you use the C<m//o> qualifier on a regular expression
+within an anonymous sub, I<all> closures generated from that anonymous
+sub will use the regular expression as it was compiled when it was used
+the very first time in any such closure. For instance, if you say
+
+ sub build_match {
+ my($left,$right) = @_;
+ return sub { $_[0] =~ /$left stuff $right/o; };
+ }
+
+build_match() will always return a sub which matches the contents of
+C<$left> and C<$right> as they were the I<first> time that build_match()
+was called, not as they are in the current call.
+
+This is probably a bug, and may change in future versions of Perl.
+
+=item * Regular Expression
+
+If no parentheses are used in a match, Perl4 sets C<$+> to
+the whole match, just like C<$&>. Perl5 does not.
+
+ "abcdef" =~ /b.*e/;
+ print "\$+ = $+\n";
+
+ # perl4 prints: bcde
+ # perl5 prints:
+
+=item * Regular Expression
+
+substitution now returns the null string if it fails
+
+ $string = "test";
+ $value = ($string =~ s/foo//);
+ print $value, "\n";
+
+ # perl4 prints: 0
+ # perl5 prints:
+
+Also see L<Numerical Traps> for another example of this new feature.
+
+=item * Regular Expression
+
+C<s`lhs`rhs`> (using backticks) is now a normal substitution, with no
+backtick expansion
+
+ $string = "";
+ $string =~ s`^`hostname`;
+ print $string, "\n";
+
+ # perl4 prints: <the local hostname>
+ # perl5 prints: hostname
+
+=item * Regular Expression
+
+Stricter parsing of variables used in regular expressions
+
+ s/^([^$grpc]*$grpc[$opt$plus$rep]?)//o;
+
+ # perl4: compiles w/o error
+ # perl5: with Scalar found where operator expected ..., near "$opt$plus"
+
+an added component of this example, apparently from the same script, is
+the actual value of the s'd string after the substitution.
+C<[$opt]> is a character class in perl4 and an array subscript in perl5
+
+ $grpc = 'a';
+ $opt = 'r';
+ $_ = 'bar';
+ s/^([^$grpc]*$grpc[$opt]?)/foo/;
+ print ;
+
+ # perl4 prints: foo
+ # perl5 prints: foobar
+
+=item * Regular Expression
+
+Under perl5, C<m?x?> matches only once, like C<?x?>. Under perl4, it matched
+repeatedly, like C</x/> or C<m!x!>.
+
+ $test = "once";
+ sub match { $test =~ m?once?; }
+ &match();
+ if( &match() ) {
+ # m?x? matches more then once
+ print "perl4\n";
+ } else {
+ # m?x? matches only once
+ print "perl5\n";
+ }
+
+ # perl4 prints: perl4
+ # perl5 prints: perl5
+
+
+=back
+
+=head2 Subroutine, Signal, Sorting Traps
+
+The general group of Perl4-to-Perl5 traps having to do with
+Signals, Sorting, and their related subroutines, as well as
+general subroutine traps. Includes some OS-Specific traps.
+
+=over 5
+
+=item * (Signals)
+
+Barewords that used to look like strings to Perl will now look like subroutine
+calls if a subroutine by that name is defined before the compiler sees them.
+
+ sub SeeYa { warn"Hasta la vista, baby!" }
+ $SIG{'TERM'} = SeeYa;
+ print "SIGTERM is now $SIG{'TERM'}\n";
+
+ # perl4 prints: SIGTERM is main'SeeYa
+ # perl5 prints: SIGTERM is now main::1
+
+Use B<-w> to catch this one
+
+=item * (Sort Subroutine)
+
+reverse is no longer allowed as the name of a sort subroutine.
+
+ sub reverse{ print "yup "; $a <=> $b }
+ print sort reverse a,b,c;
+
+ # perl4 prints: yup yup yup yup abc
+ # perl5 prints: abc
+
+=item * warn() won't let you specify a filehandle.
+
+Although it _always_ printed to STDERR, warn() would let you specify a
+filehandle in perl4. With perl5 it does not.
+
+ warn STDERR "Foo!";
+
+ # perl4 prints: Foo!
+ # perl5 prints: String found where operator expected
+
+=back
+
+=head2 OS Traps
+
+=over 5
+
+=item * (SysV)
+
+Under HPUX, and some other SysV OSes, one had to reset any signal handler,
+within the signal handler function, each time a signal was handled with
+perl4. With perl5, the reset is now done correctly. Any code relying
+on the handler _not_ being reset will have to be reworked.
+
+Since version 5.002, Perl uses sigaction() under SysV.
+
+ sub gotit {
+ print "Got @_... ";
+ }
+ $SIG{'INT'} = 'gotit';
+
+ $| = 1;
+ $pid = fork;
+ if ($pid) {
+ kill('INT', $pid);
+ sleep(1);
+ kill('INT', $pid);
+ } else {
+ while (1) {sleep(10);}
+ }
+
+ # perl4 (HPUX) prints: Got INT...
+ # perl5 (HPUX) prints: Got INT... Got INT...
+
+=item * (SysV)
+
+Under SysV OSes, C<seek()> on a file opened to append C<E<gt>E<gt>> now does
+the right thing w.r.t. the fopen() manpage. e.g., - When a file is opened
+for append, it is impossible to overwrite information already in
+the file.
+
+ open(TEST,">>seek.test");
+ $start = tell TEST ;
+ foreach(1 .. 9){
+ print TEST "$_ ";
+ }
+ $end = tell TEST ;
+ seek(TEST,$start,0);
+ print TEST "18 characters here";
+
+ # perl4 (solaris) seek.test has: 18 characters here
+ # perl5 (solaris) seek.test has: 1 2 3 4 5 6 7 8 9 18 characters here
+
+
+
+=back
+
+=head2 Interpolation Traps
+
+Perl4-to-Perl5 traps having to do with how things get interpolated
+within certain expressions, statements, contexts, or whatever.
+
+=over 5
+
+=item * Interpolation
+
+@ now always interpolates an array in double-quotish strings.
+
+ print "To: someone@somewhere.com\n";
+
+ # perl4 prints: To:someone@somewhere.com
+ # perl5 errors : In string, @somewhere now must be written as \@somewhere
+
+=item * Interpolation
+
+Double-quoted strings may no longer end with an unescaped $ or @.
+
+ $foo = "foo$";
+ $bar = "bar@";
+ print "foo is $foo, bar is $bar\n";
+
+ # perl4 prints: foo is foo$, bar is bar@
+ # perl5 errors: Final $ should be \$ or $name
+
+Note: perl5 DOES NOT error on the terminating @ in $bar
+
+=item * Interpolation
+
+Perl now sometimes evaluates arbitrary expressions inside braces that occur
+within double quotes (usually when the opening brace is preceded by C<$>
+or C<@>).
+
+ @www = "buz";
+ $foo = "foo";
+ $bar = "bar";
+ sub foo { return "bar" };
+ print "|@{w.w.w}|${main'foo}|";
+
+ # perl4 prints: |@{w.w.w}|foo|
+ # perl5 prints: |buz|bar|
+
+Note that you can C<use strict;> to ward off such trappiness under perl5.
+
+=item * Interpolation
+
+The construct "this is $$x" used to interpolate the pid at that
+point, but now apparently tries to dereference C<$x>. C<$$> by itself still
+works fine, however.
+
+ print "this is $$x\n";
+
+ # perl4 prints: this is XXXx (XXX is the current pid)
+ # perl5 prints: this is
+
+=item * Interpolation
+
+Creation of hashes on the fly with C<eval "EXPR"> now requires either both
+C<$>'s to be protected in the specification of the hash name, or both curlies
+to be protected. If both curlies are protected, the result will be compatible
+with perl4 and perl5. This is a very common practice, and should be changed
+to use the block form of C<eval{}> if possible.
+
+ $hashname = "foobar";
+ $key = "baz";
+ $value = 1234;
+ eval "\$$hashname{'$key'} = q|$value|";
+ (defined($foobar{'baz'})) ? (print "Yup") : (print "Nope");
+
+ # perl4 prints: Yup
+ # perl5 prints: Nope
+
+Changing
+
+ eval "\$$hashname{'$key'} = q|$value|";
+
+to
+
+ eval "\$\$hashname{'$key'} = q|$value|";
+
+causes the following result:
+
+ # perl4 prints: Nope
+ # perl5 prints: Yup
+
+or, changing to
+
+ eval "\$$hashname\{'$key'\} = q|$value|";
+
+causes the following result:
+
+ # perl4 prints: Yup
+ # perl5 prints: Yup
+ # and is compatible for both versions
+
+
+=item * Interpolation
+
+perl4 programs which unconsciously rely on the bugs in earlier perl versions.
+
+ perl -e '$bar=q/not/; print "This is $foo{$bar} perl5"'
+
+ # perl4 prints: This is not perl5
+ # perl5 prints: This is perl5
+
+=item * Interpolation
+
+You also have to be careful about array references.
+
+ print "$foo{"
+
+ perl 4 prints: {
+ perl 5 prints: syntax error
+
+=item * Interpolation
+
+Similarly, watch out for:
+
+ $foo = "array";
+ print "\$$foo{bar}\n";
+
+ # perl4 prints: $array{bar}
+ # perl5 prints: $
+
+Perl 5 is looking for C<$array{bar}> which doesn't exist, but perl 4 is
+happy just to expand $foo to "array" by itself. Watch out for this
+especially in C<eval>'s.
+
+=item * Interpolation
+
+C<qq()> string passed to C<eval>
+
+ eval qq(
+ foreach \$y (keys %\$x\) {
+ \$count++;
+ }
+ );
+
+ # perl4 runs this ok
+ # perl5 prints: Can't find string terminator ")"
+
+=back
+
+=head2 DBM Traps
+
+General DBM traps.
+
+=over 5
+
+=item * DBM
+
+Existing dbm databases created under perl4 (or any other dbm/ndbm tool)
+may cause the same script, run under perl5, to fail. The build of perl5
+must have been linked with the same dbm/ndbm as the default for C<dbmopen()>
+to function properly without C<tie>'ing to an extension dbm implementation.
+
+ dbmopen (%dbm, "file", undef);
+ print "ok\n";
+
+ # perl4 prints: ok
+ # perl5 prints: ok (IFF linked with -ldbm or -lndbm)
+
+
+=item * DBM
+
+Existing dbm databases created under perl4 (or any other dbm/ndbm tool)
+may cause the same script, run under perl5, to fail. The error generated
+when exceeding the limit on the key/value size will cause perl5 to exit
+immediately.
+
+ dbmopen(DB, "testdb",0600) || die "couldn't open db! $!";
+ $DB{'trap'} = "x" x 1024; # value too large for most dbm/ndbm
+ print "YUP\n";
+
+ # perl4 prints:
+ dbm store returned -1, errno 28, key "trap" at - line 3.
+ YUP
+
+ # perl5 prints:
+ dbm store returned -1, errno 28, key "trap" at - line 3.
+
+=back
+
+=head2 Unclassified Traps
+
+Everything else.
+
+=over 5
+
+=item * C<require>/C<do> trap using returned value
+
+If the file doit.pl has:
+
+ sub foo {
+ $rc = do "./do.pl";
+ return 8;
+ }
+ print &foo, "\n";
+
+And the do.pl file has the following single line:
+
+ return 3;
+
+Running doit.pl gives the following:
+
+ # perl 4 prints: 3 (aborts the subroutine early)
+ # perl 5 prints: 8
+
+Same behavior if you replace C<do> with C<require>.
+
+=item * C<split> on empty string with LIMIT specified
+
+ $string = '';
+ @list = split(/foo/, $string, 2)
+
+Perl4 returns a one element list containing the empty string but Perl5
+returns an empty list.
+
+=back
+
+As always, if any of these are ever officially declared as bugs,
+they'll be fixed and removed.
+
diff --git a/contrib/perl5/pod/perlvar.pod b/contrib/perl5/pod/perlvar.pod
new file mode 100644
index 000000000000..2ed3e97f77b4
--- /dev/null
+++ b/contrib/perl5/pod/perlvar.pod
@@ -0,0 +1,936 @@
+=head1 NAME
+
+perlvar - Perl predefined variables
+
+=head1 DESCRIPTION
+
+=head2 Predefined Names
+
+The following names have special meaning to Perl. Most
+punctuation names have reasonable mnemonics, or analogues in one of
+the shells. Nevertheless, if you wish to use long variable names,
+you just need to say
+
+ use English;
+
+at the top of your program. This will alias all the short names to the
+long names in the current package. Some even have medium names,
+generally borrowed from B<awk>.
+
+To go a step further, those variables that depend on the currently
+selected filehandle may instead (and preferably) be set by calling an
+object method on the FileHandle object. (Summary lines below for this
+contain the word HANDLE.) First you must say
+
+ use FileHandle;
+
+after which you may use either
+
+ method HANDLE EXPR
+
+or more safely,
+
+ HANDLE->method(EXPR)
+
+Each of the methods returns the old value of the FileHandle attribute.
+The methods each take an optional EXPR, which if supplied specifies the
+new value for the FileHandle attribute in question. If not supplied,
+most of the methods do nothing to the current value, except for
+autoflush(), which will assume a 1 for you, just to be different.
+
+A few of these variables are considered "read-only". This means that if
+you try to assign to this variable, either directly or indirectly through
+a reference, you'll raise a run-time exception.
+
+The following list is ordered by scalar variables first, then the
+arrays, then the hashes (except $^M was added in the wrong place).
+This is somewhat obscured by the fact that %ENV and %SIG are listed as
+$ENV{expr} and $SIG{expr}.
+
+
+=over 8
+
+=item $ARG
+
+=item $_
+
+The default input and pattern-searching space. The following pairs are
+equivalent:
+
+ while (<>) {...} # equivalent in only while!
+ while (defined($_ = <>)) {...}
+
+ /^Subject:/
+ $_ =~ /^Subject:/
+
+ tr/a-z/A-Z/
+ $_ =~ tr/a-z/A-Z/
+
+ chop
+ chop($_)
+
+Here are the places where Perl will assume $_ even if you
+don't use it:
+
+=over 3
+
+=item *
+
+Various unary functions, including functions like ord() and int(), as well
+as the all file tests (C<-f>, C<-d>) except for C<-t>, which defaults to
+STDIN.
+
+=item *
+
+Various list functions like print() and unlink().
+
+=item *
+
+The pattern matching operations C<m//>, C<s///>, and C<tr///> when used
+without an C<=~> operator.
+
+=item *
+
+The default iterator variable in a C<foreach> loop if no other
+variable is supplied.
+
+=item *
+
+The implicit iterator variable in the grep() and map() functions.
+
+=item *
+
+The default place to put an input record when a C<E<lt>FHE<gt>>
+operation's result is tested by itself as the sole criterion of a C<while>
+test. Note that outside of a C<while> test, this will not happen.
+
+=back
+
+(Mnemonic: underline is understood in certain operations.)
+
+=back
+
+=over 8
+
+=item $E<lt>I<digits>E<gt>
+
+Contains the subpattern from the corresponding set of parentheses in
+the last pattern matched, not counting patterns matched in nested
+blocks that have been exited already. (Mnemonic: like \digits.)
+These variables are all read-only.
+
+=item $MATCH
+
+=item $&
+
+The string matched by the last successful pattern match (not counting
+any matches hidden within a BLOCK or eval() enclosed by the current
+BLOCK). (Mnemonic: like & in some editors.) This variable is read-only.
+
+=item $PREMATCH
+
+=item $`
+
+The string preceding whatever was matched by the last successful
+pattern match (not counting any matches hidden within a BLOCK or eval
+enclosed by the current BLOCK). (Mnemonic: C<`> often precedes a quoted
+string.) This variable is read-only.
+
+=item $POSTMATCH
+
+=item $'
+
+The string following whatever was matched by the last successful
+pattern match (not counting any matches hidden within a BLOCK or eval()
+enclosed by the current BLOCK). (Mnemonic: C<'> often follows a quoted
+string.) Example:
+
+ $_ = 'abcdefghi';
+ /def/;
+ print "$`:$&:$'\n"; # prints abc:def:ghi
+
+This variable is read-only.
+
+=item $LAST_PAREN_MATCH
+
+=item $+
+
+The last bracket matched by the last search pattern. This is useful if
+you don't know which of a set of alternative patterns matched. For
+example:
+
+ /Version: (.*)|Revision: (.*)/ && ($rev = $+);
+
+(Mnemonic: be positive and forward looking.)
+This variable is read-only.
+
+=item $MULTILINE_MATCHING
+
+=item $*
+
+Set to 1 to do multi-line matching within a string, 0 to tell Perl
+that it can assume that strings contain a single line, for the purpose
+of optimizing pattern matches. Pattern matches on strings containing
+multiple newlines can produce confusing results when "C<$*>" is 0. Default
+is 0. (Mnemonic: * matches multiple things.) Note that this variable
+influences the interpretation of only "C<^>" and "C<$>". A literal newline can
+be searched for even when C<$* == 0>.
+
+Use of "C<$*>" is deprecated in modern Perls, supplanted by
+the C</s> and C</m> modifiers on pattern matching.
+
+=item input_line_number HANDLE EXPR
+
+=item $INPUT_LINE_NUMBER
+
+=item $NR
+
+=item $.
+
+The current input line number for the last file handle from
+which you read (or performed a C<seek> or C<tell> on). An
+explicit close on a filehandle resets the line number. Because
+"C<E<lt>E<gt>>" never does an explicit close, line numbers increase
+across ARGV files (but see examples under eof()). Localizing C<$.> has
+the effect of also localizing Perl's notion of "the last read
+filehandle". (Mnemonic: many programs use "." to mean the current line
+number.)
+
+=item input_record_separator HANDLE EXPR
+
+=item $INPUT_RECORD_SEPARATOR
+
+=item $RS
+
+=item $/
+
+The input record separator, newline by default. Works like B<awk>'s RS
+variable, including treating empty lines as delimiters if set to the
+null string. (Note: An empty line cannot contain any spaces or tabs.)
+You may set it to a multi-character string to match a multi-character
+delimiter, or to C<undef> to read to end of file. Note that setting it
+to C<"\n\n"> means something slightly different than setting it to
+C<"">, if the file contains consecutive empty lines. Setting it to
+C<""> will treat two or more consecutive empty lines as a single empty
+line. Setting it to C<"\n\n"> will blindly assume that the next input
+character belongs to the next paragraph, even if it's a newline.
+(Mnemonic: / is used to delimit line boundaries when quoting poetry.)
+
+ undef $/;
+ $_ = <FH>; # whole file now here
+ s/\n[ \t]+/ /g;
+
+Remember: the value of $/ is a string, not a regexp. AWK has to be
+better for something :-)
+
+Setting $/ to a reference to an integer, scalar containing an integer, or
+scalar that's convertable to an integer will attempt to read records
+instead of lines, with the maximum record size being the referenced
+integer. So this:
+
+ $/ = \32768; # or \"32768", or \$var_containing_32768
+ open(FILE, $myfile);
+ $_ = <FILE>;
+
+will read a record of no more than 32768 bytes from FILE. If you're not
+reading from a record-oriented file (or your OS doesn't have
+record-oriented files), then you'll likely get a full chunk of data with
+every read. If a record is larger than the record size you've set, you'll
+get the record back in pieces.
+
+On VMS, record reads are done with the equivalent of C<sysread>, so it's
+best not to mix record and non-record reads on the same file. (This is
+likely not a problem, as any file you'd want to read in record mode is
+proably usable in line mode) Non-VMS systems perform normal I/O, so
+it's safe to mix record and non-record reads of a file.
+
+=item autoflush HANDLE EXPR
+
+=item $OUTPUT_AUTOFLUSH
+
+=item $|
+
+If set to nonzero, forces a flush right away and after every write or print on the
+currently selected output channel. Default is 0 (regardless of whether
+the channel is actually buffered by the system or not; C<$|> tells you
+only whether you've asked Perl explicitly to flush after each write).
+Note that STDOUT will typically be line buffered if output is to the
+terminal and block buffered otherwise. Setting this variable is useful
+primarily when you are outputting to a pipe, such as when you are running
+a Perl script under rsh and want to see the output as it's happening. This
+has no effect on input buffering.
+(Mnemonic: when you want your pipes to be piping hot.)
+
+=item output_field_separator HANDLE EXPR
+
+=item $OUTPUT_FIELD_SEPARATOR
+
+=item $OFS
+
+=item $,
+
+The output field separator for the print operator. Ordinarily the
+print operator simply prints out the comma-separated fields you
+specify. To get behavior more like B<awk>, set this variable
+as you would set B<awk>'s OFS variable to specify what is printed
+between fields. (Mnemonic: what is printed when there is a , in your
+print statement.)
+
+=item output_record_separator HANDLE EXPR
+
+=item $OUTPUT_RECORD_SEPARATOR
+
+=item $ORS
+
+=item $\
+
+The output record separator for the print operator. Ordinarily the
+print operator simply prints out the comma-separated fields you
+specify, with no trailing newline or record separator assumed.
+To get behavior more like B<awk>, set this variable as you would
+set B<awk>'s ORS variable to specify what is printed at the end of the
+print. (Mnemonic: you set "C<$\>" instead of adding \n at the end of the
+print. Also, it's just like C<$/>, but it's what you get "back" from
+Perl.)
+
+=item $LIST_SEPARATOR
+
+=item $"
+
+This is like "C<$,>" except that it applies to array values interpolated
+into a double-quoted string (or similar interpreted string). Default
+is a space. (Mnemonic: obvious, I think.)
+
+=item $SUBSCRIPT_SEPARATOR
+
+=item $SUBSEP
+
+=item $;
+
+The subscript separator for multidimensional array emulation. If you
+refer to a hash element as
+
+ $foo{$a,$b,$c}
+
+it really means
+
+ $foo{join($;, $a, $b, $c)}
+
+But don't put
+
+ @foo{$a,$b,$c} # a slice--note the @
+
+which means
+
+ ($foo{$a},$foo{$b},$foo{$c})
+
+Default is "\034", the same as SUBSEP in B<awk>. Note that if your
+keys contain binary data there might not be any safe value for "C<$;>".
+(Mnemonic: comma (the syntactic subscript separator) is a
+semi-semicolon. Yeah, I know, it's pretty lame, but "C<$,>" is already
+taken for something more important.)
+
+Consider using "real" multidimensional arrays.
+
+=item $OFMT
+
+=item $#
+
+The output format for printed numbers. This variable is a half-hearted
+attempt to emulate B<awk>'s OFMT variable. There are times, however,
+when B<awk> and Perl have differing notions of what is in fact
+numeric. The initial value is %.I<n>g, where I<n> is the value
+of the macro DBL_DIG from your system's F<float.h>. This is different from
+B<awk>'s default OFMT setting of %.6g, so you need to set "C<$#>"
+explicitly to get B<awk>'s value. (Mnemonic: # is the number sign.)
+
+Use of "C<$#>" is deprecated.
+
+=item format_page_number HANDLE EXPR
+
+=item $FORMAT_PAGE_NUMBER
+
+=item $%
+
+The current page number of the currently selected output channel.
+(Mnemonic: % is page number in B<nroff>.)
+
+=item format_lines_per_page HANDLE EXPR
+
+=item $FORMAT_LINES_PER_PAGE
+
+=item $=
+
+The current page length (printable lines) of the currently selected
+output channel. Default is 60. (Mnemonic: = has horizontal lines.)
+
+=item format_lines_left HANDLE EXPR
+
+=item $FORMAT_LINES_LEFT
+
+=item $-
+
+The number of lines left on the page of the currently selected output
+channel. (Mnemonic: lines_on_page - lines_printed.)
+
+=item format_name HANDLE EXPR
+
+=item $FORMAT_NAME
+
+=item $~
+
+The name of the current report format for the currently selected output
+channel. Default is name of the filehandle. (Mnemonic: brother to
+"C<$^>".)
+
+=item format_top_name HANDLE EXPR
+
+=item $FORMAT_TOP_NAME
+
+=item $^
+
+The name of the current top-of-page format for the currently selected
+output channel. Default is name of the filehandle with _TOP
+appended. (Mnemonic: points to top of page.)
+
+=item format_line_break_characters HANDLE EXPR
+
+=item $FORMAT_LINE_BREAK_CHARACTERS
+
+=item $:
+
+The current set of characters after which a string may be broken to
+fill continuation fields (starting with ^) in a format. Default is
+S<" \n-">, to break on whitespace or hyphens. (Mnemonic: a "colon" in
+poetry is a part of a line.)
+
+=item format_formfeed HANDLE EXPR
+
+=item $FORMAT_FORMFEED
+
+=item $^L
+
+What formats output to perform a form feed. Default is \f.
+
+=item $ACCUMULATOR
+
+=item $^A
+
+The current value of the write() accumulator for format() lines. A format
+contains formline() commands that put their result into C<$^A>. After
+calling its format, write() prints out the contents of C<$^A> and empties.
+So you never actually see the contents of C<$^A> unless you call
+formline() yourself and then look at it. See L<perlform> and
+L<perlfunc/formline()>.
+
+=item $CHILD_ERROR
+
+=item $?
+
+The status returned by the last pipe close, backtick (C<``>) command,
+or system() operator. Note that this is the status word returned by the
+wait() system call (or else is made up to look like it). Thus, the exit
+value of the subprocess is actually (C<$? E<gt>E<gt> 8>), and C<$? & 127>
+gives which signal, if any, the process died from, and C<$? & 128> reports
+whether there was a core dump. (Mnemonic: similar to B<sh> and B<ksh>.)
+
+Additionally, if the C<h_errno> variable is supported in C, its value
+is returned via $? if any of the C<gethost*()> functions fail.
+
+Note that if you have installed a signal handler for C<SIGCHLD>, the
+value of C<$?> will usually be wrong outside that handler.
+
+Inside an C<END> subroutine C<$?> contains the value that is going to be
+given to C<exit()>. You can modify C<$?> in an C<END> subroutine to
+change the exit status of the script.
+
+Under VMS, the pragma C<use vmsish 'status'> makes C<$?> reflect the
+actual VMS exit status, instead of the default emulation of POSIX
+status.
+
+Also see L<Error Indicators>.
+
+=item $OS_ERROR
+
+=item $ERRNO
+
+=item $!
+
+If used in a numeric context, yields the current value of errno, with
+all the usual caveats. (This means that you shouldn't depend on the
+value of C<$!> to be anything in particular unless you've gotten a
+specific error return indicating a system error.) If used in a string
+context, yields the corresponding system error string. You can assign
+to C<$!> to set I<errno> if, for instance, you want C<"$!"> to return the
+string for error I<n>, or you want to set the exit value for the die()
+operator. (Mnemonic: What just went bang?)
+
+Also see L<Error Indicators>.
+
+=item $EXTENDED_OS_ERROR
+
+=item $^E
+
+Error information specific to the current operating system. At
+the moment, this differs from C<$!> under only VMS, OS/2, and Win32
+(and for MacPerl). On all other platforms, C<$^E> is always just
+the same as C<$!>.
+
+Under VMS, C<$^E> provides the VMS status value from the last
+system error. This is more specific information about the last
+system error than that provided by C<$!>. This is particularly
+important when C<$!> is set to B<EVMSERR>.
+
+Under OS/2, C<$^E> is set to the error code of the last call to
+OS/2 API either via CRT, or directly from perl.
+
+Under Win32, C<$^E> always returns the last error information
+reported by the Win32 call C<GetLastError()> which describes
+the last error from within the Win32 API. Most Win32-specific
+code will report errors via C<$^E>. ANSI C and UNIX-like calls
+set C<errno> and so most portable Perl code will report errors
+via C<$!>.
+
+Caveats mentioned in the description of C<$!> generally apply to
+C<$^E>, also. (Mnemonic: Extra error explanation.)
+
+Also see L<Error Indicators>.
+
+=item $EVAL_ERROR
+
+=item $@
+
+The Perl syntax error message from the last eval() command. If null, the
+last eval() parsed and executed correctly (although the operations you
+invoked may have failed in the normal fashion). (Mnemonic: Where was
+the syntax error "at"?)
+
+Note that warning messages are not collected in this variable. You can,
+however, set up a routine to process warnings by setting C<$SIG{__WARN__}>
+as described below.
+
+Also see L<Error Indicators>.
+
+=item $PROCESS_ID
+
+=item $PID
+
+=item $$
+
+The process number of the Perl running this script. (Mnemonic: same
+as shells.)
+
+=item $REAL_USER_ID
+
+=item $UID
+
+=item $<
+
+The real uid of this process. (Mnemonic: it's the uid you came I<FROM>,
+if you're running setuid.)
+
+=item $EFFECTIVE_USER_ID
+
+=item $EUID
+
+=item $>
+
+The effective uid of this process. Example:
+
+ $< = $>; # set real to effective uid
+ ($<,$>) = ($>,$<); # swap real and effective uid
+
+(Mnemonic: it's the uid you went I<TO>, if you're running setuid.)
+Note: "C<$E<lt>>" and "C<$E<gt>>" can be swapped only on machines
+supporting setreuid().
+
+=item $REAL_GROUP_ID
+
+=item $GID
+
+=item $(
+
+The real gid of this process. If you are on a machine that supports
+membership in multiple groups simultaneously, gives a space separated
+list of groups you are in. The first number is the one returned by
+getgid(), and the subsequent ones by getgroups(), one of which may be
+the same as the first number.
+
+However, a value assigned to "C<$(>" must be a single number used to
+set the real gid. So the value given by "C<$(>" should I<not> be assigned
+back to "C<$(>" without being forced numeric, such as by adding zero.
+
+(Mnemonic: parentheses are used to I<GROUP> things. The real gid is the
+group you I<LEFT>, if you're running setgid.)
+
+=item $EFFECTIVE_GROUP_ID
+
+=item $EGID
+
+=item $)
+
+The effective gid of this process. If you are on a machine that
+supports membership in multiple groups simultaneously, gives a space
+separated list of groups you are in. The first number is the one
+returned by getegid(), and the subsequent ones by getgroups(), one of
+which may be the same as the first number.
+
+Similarly, a value assigned to "C<$)>" must also be a space-separated
+list of numbers. The first number is used to set the effective gid, and
+the rest (if any) are passed to setgroups(). To get the effect of an
+empty list for setgroups(), just repeat the new effective gid; that is,
+to force an effective gid of 5 and an effectively empty setgroups()
+list, say C< $) = "5 5" >.
+
+(Mnemonic: parentheses are used to I<GROUP> things. The effective gid
+is the group that's I<RIGHT> for you, if you're running setgid.)
+
+Note: "C<$E<lt>>", "C<$E<gt>>", "C<$(>" and "C<$)>" can be set only on
+machines that support the corresponding I<set[re][ug]id()> routine. "C<$(>"
+and "C<$)>" can be swapped only on machines supporting setregid().
+
+=item $PROGRAM_NAME
+
+=item $0
+
+Contains the name of the file containing the Perl script being
+executed. On some operating systems
+assigning to "C<$0>" modifies the argument area that the ps(1)
+program sees. This is more useful as a way of indicating the
+current program state than it is for hiding the program you're running.
+(Mnemonic: same as B<sh> and B<ksh>.)
+
+=item $[
+
+The index of the first element in an array, and of the first character
+in a substring. Default is 0, but you could set it to 1 to make
+Perl behave more like B<awk> (or Fortran) when subscripting and when
+evaluating the index() and substr() functions. (Mnemonic: [ begins
+subscripts.)
+
+As of Perl 5, assignment to "C<$[>" is treated as a compiler directive,
+and cannot influence the behavior of any other file. Its use is
+discouraged.
+
+=item $PERL_VERSION
+
+=item $]
+
+The version + patchlevel / 1000 of the Perl interpreter. This variable
+can be used to determine whether the Perl interpreter executing a
+script is in the right range of versions. (Mnemonic: Is this version
+of perl in the right bracket?) Example:
+
+ warn "No checksumming!\n" if $] < 3.019;
+
+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 $DEBUGGING
+
+=item $^D
+
+The current value of the debugging flags. (Mnemonic: value of B<-D>
+switch.)
+
+=item $SYSTEM_FD_MAX
+
+=item $^F
+
+The maximum system file descriptor, ordinarily 2. System file
+descriptors are passed to exec()ed processes, while higher file
+descriptors are not. Also, during an open(), system file descriptors are
+preserved even if the open() fails. (Ordinary file descriptors are
+closed before the open() is attempted.) Note that the close-on-exec
+status of a file descriptor will be decided according to the value of
+C<$^F> at the time of the open, not the time of the exec.
+
+=item $^H
+
+The current set of syntax checks enabled by C<use strict> and other block
+scoped compiler hints. See the documentation of C<strict> for more details.
+
+=item $INPLACE_EDIT
+
+=item $^I
+
+The current value of the inplace-edit extension. Use C<undef> to disable
+inplace editing. (Mnemonic: value of B<-i> switch.)
+
+=item $^M
+
+By default, running out of memory it is not trappable. However, if
+compiled for this, Perl may use the contents of C<$^M> as an emergency
+pool after die()ing with this message. Suppose that your Perl were
+compiled with -DPERL_EMERGENCY_SBRK and used Perl's malloc. Then
+
+ $^M = 'a' x (1<<16);
+
+would allocate a 64K buffer for use when in emergency. See the F<INSTALL>
+file for information on how to enable this option. As a disincentive to
+casual use of this advanced feature, there is no L<English> long name for
+this variable.
+
+=item $OSNAME
+
+=item $^O
+
+The name of the operating system under which this copy of Perl was
+built, as determined during the configuration process. The value
+is identical to C<$Config{'osname'}>.
+
+=item $PERLDB
+
+=item $^P
+
+The internal variable for debugging support. Different bits mean the
+following (subject to change):
+
+=over 6
+
+=item 0x01
+
+Debug subroutine enter/exit.
+
+=item 0x02
+
+Line-by-line debugging.
+
+=item 0x04
+
+Switch off optimizations.
+
+=item 0x08
+
+Preserve more data for future interactive inspections.
+
+=item 0x10
+
+Keep info about source lines on which a subroutine is defined.
+
+=item 0x20
+
+Start with single-step on.
+
+=back
+
+Note that some bits may be relevent at compile-time only, some at
+run-time only. This is a new mechanism and the details may change.
+
+=item $^R
+
+The result of evaluation of the last successful L<perlre/C<(?{ code })>>
+regular expression assertion. (Excluding those used as switches.) May
+be written to.
+
+=item $^S
+
+Current state of the interpreter. Undefined if parsing of the current
+module/eval is not finished (may happen in $SIG{__DIE__} and
+$SIG{__WARN__} handlers). True if inside an eval, otherwise false.
+
+=item $BASETIME
+
+=item $^T
+
+The time at which the script began running, in seconds since the
+epoch (beginning of 1970). The values returned by the B<-M>, B<-A>,
+and B<-C> filetests are
+based on this value.
+
+=item $WARNING
+
+=item $^W
+
+The current value of the warning switch, either TRUE or FALSE.
+(Mnemonic: related to the B<-w> switch.)
+
+=item $EXECUTABLE_NAME
+
+=item $^X
+
+The name that the Perl binary itself was executed as, from C's C<argv[0]>.
+
+=item $ARGV
+
+contains the name of the current file when reading from E<lt>E<gt>.
+
+=item @ARGV
+
+The array @ARGV contains the command line arguments intended for the
+script. Note that C<$#ARGV> is the generally number of arguments minus
+one, because C<$ARGV[0]> is the first argument, I<NOT> the command name. See
+"C<$0>" for the command name.
+
+=item @INC
+
+The array @INC contains the list of places to look for Perl scripts to
+be evaluated by the C<do EXPR>, C<require>, or C<use> constructs. It
+initially consists of the arguments to any B<-I> command line switches,
+followed by the default Perl library, probably F</usr/local/lib/perl>,
+followed by ".", to represent the current directory. If you need to
+modify this at runtime, you should use the C<use lib> pragma
+to get the machine-dependent library properly loaded also:
+
+ use lib '/mypath/libdir/';
+ use SomeMod;
+
+=item @_
+
+Within a subroutine the array @_ contains the parameters passed to that
+subroutine. See L<perlsub>.
+
+=item %INC
+
+The hash %INC contains entries for each filename that has
+been included via C<do> or C<require>. The key is the filename you
+specified, and the value is the location of the file actually found.
+The C<require> command uses this array to determine whether a given file
+has already been included.
+
+=item %ENV $ENV{expr}
+
+The hash %ENV contains your current environment. Setting a
+value in C<ENV> changes the environment for child processes.
+
+=item %SIG $SIG{expr}
+
+The hash %SIG is used to set signal handlers for various
+signals. Example:
+
+ sub handler { # 1st argument is signal name
+ my($sig) = @_;
+ print "Caught a SIG$sig--shutting down\n";
+ close(LOG);
+ exit(0);
+ }
+
+ $SIG{'INT'} = \&handler;
+ $SIG{'QUIT'} = \&handler;
+ ...
+ $SIG{'INT'} = 'DEFAULT'; # restore default action
+ $SIG{'QUIT'} = 'IGNORE'; # ignore SIGQUIT
+
+The %SIG array contains values for only the signals actually set within
+the Perl script. Here are some other examples:
+
+ $SIG{"PIPE"} = Plumber; # SCARY!!
+ $SIG{"PIPE"} = "Plumber"; # assumes main::Plumber (not recommended)
+ $SIG{"PIPE"} = \&Plumber; # just fine; assume current Plumber
+ $SIG{"PIPE"} = Plumber(); # oops, what did Plumber() return??
+
+The one marked scary is problematic because it's a bareword, which means
+sometimes it's a string representing the function, and sometimes it's
+going to call the subroutine call right then and there! Best to be sure
+and quote it or take a reference to it. *Plumber works too. See L<perlsub>.
+
+If your system has the sigaction() function then signal handlers are
+installed using it. This means you get reliable signal handling. If
+your system has the SA_RESTART flag it is used when signals handlers are
+installed. This means that system calls for which it is supported
+continue rather than returning when a signal arrives. If you want your
+system calls to be interrupted by signal delivery then do something like
+this:
+
+ use POSIX ':signal_h';
+
+ my $alarm = 0;
+ sigaction SIGALRM, new POSIX::SigAction sub { $alarm = 1 }
+ or die "Error setting SIGALRM handler: $!\n";
+
+See L<POSIX>.
+
+Certain internal hooks can be also set using the %SIG hash. The
+routine indicated by C<$SIG{__WARN__}> is called when a warning message is
+about to be printed. The warning message is passed as the first
+argument. The presence of a __WARN__ hook causes the ordinary printing
+of warnings to STDERR to be suppressed. You can use this to save warnings
+in a variable, or turn warnings into fatal errors, like this:
+
+ local $SIG{__WARN__} = sub { die $_[0] };
+ eval $proggie;
+
+The routine indicated by C<$SIG{__DIE__}> is called when a fatal exception
+is about to be thrown. The error message is passed as the first
+argument. When a __DIE__ hook routine returns, the exception
+processing continues as it would have in the absence of the hook,
+unless the hook routine itself exits via a C<goto>, a loop exit, or a die().
+The C<__DIE__> handler is explicitly disabled during the call, so that you
+can die from a C<__DIE__> handler. Similarly for C<__WARN__>.
+
+Note that the C<$SIG{__DIE__}> hook is called even inside eval()ed
+blocks/strings. See L<perlfunc/die> and L<perlvar/$^S> for how to
+circumvent this.
+
+Note that C<__DIE__>/C<__WARN__> handlers are very special in one
+respect: they may be called to report (probable) errors found by the
+parser. In such a case the parser may be in inconsistent state, so
+any attempt to evaluate Perl code from such a handler will probably
+result in a segfault. This means that calls which result/may-result
+in parsing Perl should be used with extreme causion, like this:
+
+ require Carp if defined $^S;
+ Carp::confess("Something wrong") if defined &Carp::confess;
+ die "Something wrong, but could not load Carp to give backtrace...
+ To see backtrace try starting Perl with -MCarp switch";
+
+Here the first line will load Carp I<unless> it is the parser who
+called the handler. The second line will print backtrace and die if
+Carp was available. The third line will be executed only if Carp was
+not available.
+
+See L<perlfunc/die>, L<perlfunc/warn> and L<perlfunc/eval> for
+additional info.
+
+=back
+
+=head2 Error Indicators
+
+The variables L<$@>, L<$!>, L<$^E>, and L<$?> contain information about
+different types of error conditions that may appear during execution of
+Perl script. The variables are shown ordered by the "distance" between
+the subsystem which reported the error and the Perl process, and
+correspond to errors detected by the Perl interpreter, C library,
+operating system, or an external program, respectively.
+
+To illustrate the differences between these variables, consider the
+following Perl expression:
+
+ eval '
+ open PIPE, "/cdrom/install |";
+ @res = <PIPE>;
+ close PIPE or die "bad pipe: $?, $!";
+ ';
+
+After execution of this statement all 4 variables may have been set.
+
+$@ is set if the string to be C<eval>-ed did not compile (this may happen if
+C<open> or C<close> were imported with bad prototypes), or if Perl
+code executed during evaluation die()d (either implicitly, say,
+if C<open> was imported from module L<Fatal>, or the C<die> after
+C<close> was triggered). In these cases the value of $@ is the compile
+error, or C<Fatal> error (which will interpolate C<$!>!), or the argument
+to C<die> (which will interpolate C<$!> and C<$?>!).
+
+When the above expression is executed, open(), C<<PIPEE<gt>>, and C<close>
+are translated to C run-time library calls. $! is set if one of these
+calls fails. The value is a symbolic indicator chosen by the C run-time
+library, say C<No such file or directory>.
+
+On some systems the above C library calls are further translated
+to calls to the kernel. The kernel may have set more verbose error
+indicator that one of the handful of standard C errors. In such cases $^E
+contains this verbose error indicator, which may be, say, C<CDROM tray not
+closed>. On systems where C library calls are identical to system calls
+$^E is a duplicate of $!.
+
+Finally, $? may be set to non-C<0> value if the external program
+C</cdrom/install> fails. Upper bits of the particular value may reflect
+specific error conditions encountered by this program (this is
+program-dependent), lower-bits reflect mode of failure (segfault, completion,
+etc.). Note that in contrast to $@, $!, and $^E, which are set only
+if error condition is detected, the variable $? is set on each C<wait> or
+pipe C<close>, overwriting the old value.
+
+For more details, see the individual descriptions at L<$@>, L<$!>, L<$^E>,
+and L<$?>.
diff --git a/contrib/perl5/pod/perlxs.pod b/contrib/perl5/pod/perlxs.pod
new file mode 100644
index 000000000000..c578a2ec5910
--- /dev/null
+++ b/contrib/perl5/pod/perlxs.pod
@@ -0,0 +1,1348 @@
+=head1 NAME
+
+perlxs - XS language reference manual
+
+=head1 DESCRIPTION
+
+=head2 Introduction
+
+XS is a language used to create an extension interface
+between Perl and some C library which one wishes to use with
+Perl. The XS interface is combined with the library to
+create a new library which can be linked to Perl. An B<XSUB>
+is a function in the XS language and is the core component
+of the Perl application interface.
+
+The XS compiler is called B<xsubpp>. This compiler will embed
+the constructs necessary to let an XSUB, which is really a C
+function in disguise, manipulate Perl values and creates the
+glue necessary to let Perl access the XSUB. The compiler
+uses B<typemaps> to determine how to map C function parameters
+and variables to Perl values. The default typemap handles
+many common C types. A supplement typemap must be created
+to handle special structures and types for the library being
+linked.
+
+See L<perlxstut> for a tutorial on the whole extension creation process.
+
+Note: For many extensions, Dave Beazley's SWIG system provides a
+significantly more convenient mechanism for creating the XS glue
+code. See L<http://www.cs.utah.edu/~beazley/SWIG> for more
+information.
+
+=head2 On The Road
+
+Many of the examples which follow will concentrate on creating an interface
+between Perl and the ONC+ RPC bind library functions. The rpcb_gettime()
+function is used to demonstrate many features of the XS language. This
+function has two parameters; the first is an input parameter and the second
+is an output parameter. The function also returns a status value.
+
+ bool_t rpcb_gettime(const char *host, time_t *timep);
+
+From C this function will be called with the following
+statements.
+
+ #include <rpc/rpc.h>
+ bool_t status;
+ time_t timep;
+ status = rpcb_gettime( "localhost", &timep );
+
+If an XSUB is created to offer a direct translation between this function
+and Perl, then this XSUB will be used from Perl with the following code.
+The $status and $timep variables will contain the output of the function.
+
+ use RPC;
+ $status = rpcb_gettime( "localhost", $timep );
+
+The following XS file shows an XS subroutine, or XSUB, which
+demonstrates one possible interface to the rpcb_gettime()
+function. This XSUB represents a direct translation between
+C and Perl and so preserves the interface even from Perl.
+This XSUB will be invoked from Perl with the usage shown
+above. Note that the first three #include statements, for
+C<EXTERN.h>, C<perl.h>, and C<XSUB.h>, will always be present at the
+beginning of an XS file. This approach and others will be
+expanded later in this document.
+
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+ #include <rpc/rpc.h>
+
+ MODULE = RPC PACKAGE = RPC
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ time_t &timep
+ OUTPUT:
+ timep
+
+Any extension to Perl, including those containing XSUBs,
+should have a Perl module to serve as the bootstrap which
+pulls the extension into Perl. This module will export the
+extension's functions and variables to the Perl program and
+will cause the extension's XSUBs to be linked into Perl.
+The following module will be used for most of the examples
+in this document and should be used from Perl with the C<use>
+command as shown earlier. Perl modules are explained in
+more detail later in this document.
+
+ package RPC;
+
+ require Exporter;
+ require DynaLoader;
+ @ISA = qw(Exporter DynaLoader);
+ @EXPORT = qw( rpcb_gettime );
+
+ bootstrap RPC;
+ 1;
+
+Throughout this document a variety of interfaces to the rpcb_gettime()
+XSUB will be explored. The XSUBs will take their parameters in different
+orders or will take different numbers of parameters. In each case the
+XSUB is an abstraction between Perl and the real C rpcb_gettime()
+function, and the XSUB must always ensure that the real rpcb_gettime()
+function is called with the correct parameters. This abstraction will
+allow the programmer to create a more Perl-like interface to the C
+function.
+
+=head2 The Anatomy of an XSUB
+
+The following XSUB allows a Perl program to access a C library function
+called sin(). The XSUB will imitate the C function which takes a single
+argument and returns a single value.
+
+ double
+ sin(x)
+ double x
+
+When using C pointers the indirection operator C<*> should be considered
+part of the type and the address operator C<&> should be considered part of
+the variable, as is demonstrated in the rpcb_gettime() function above. See
+the section on typemaps for more about handling qualifiers and unary
+operators in C types.
+
+The function name and the return type must be placed on
+separate lines.
+
+ INCORRECT CORRECT
+
+ double sin(x) double
+ double x sin(x)
+ double x
+
+The function body may be indented or left-adjusted. The following example
+shows a function with its body left-adjusted. Most examples in this
+document will indent the body.
+
+ CORRECT
+
+ double
+ sin(x)
+ double x
+
+=head2 The Argument Stack
+
+The argument stack is used to store the values which are
+sent as parameters to the XSUB and to store the XSUB's
+return value. In reality all Perl functions keep their
+values on this stack at the same time, each limited to its
+own range of positions on the stack. In this document the
+first position on that stack which belongs to the active
+function will be referred to as position 0 for that function.
+
+XSUBs refer to their stack arguments with the macro B<ST(x)>, where I<x>
+refers to a position in this XSUB's part of the stack. Position 0 for that
+function would be known to the XSUB as ST(0). The XSUB's incoming
+parameters and outgoing return values always begin at ST(0). For many
+simple cases the B<xsubpp> compiler will generate the code necessary to
+handle the argument stack by embedding code fragments found in the
+typemaps. In more complex cases the programmer must supply the code.
+
+=head2 The RETVAL Variable
+
+The RETVAL variable is a magic variable which always matches
+the return type of the C library function. The B<xsubpp> compiler will
+supply this variable in each XSUB and by default will use it to hold the
+return value of the C library function being called. In simple cases the
+value of RETVAL will be placed in ST(0) of the argument stack where it can
+be received by Perl as the return value of the XSUB.
+
+If the XSUB has a return type of C<void> then the compiler will
+not supply a RETVAL variable for that function. When using
+the PPCODE: directive the RETVAL variable is not needed, unless used
+explicitly.
+
+If PPCODE: directive is not used, C<void> return value should be used
+only for subroutines which do not return a value, I<even if> CODE:
+directive is used which sets ST(0) explicitly.
+
+Older versions of this document recommended to use C<void> return
+value in such cases. It was discovered that this could lead to
+segfaults in cases when XSUB was I<truely> C<void>. This practice is
+now deprecated, and may be not supported at some future version. Use
+the return value C<SV *> in such cases. (Currently C<xsubpp> contains
+some heuristic code which tries to disambiguate between "truely-void"
+and "old-practice-declared-as-void" functions. Hence your code is at
+mercy of this heuristics unless you use C<SV *> as return value.)
+
+=head2 The MODULE Keyword
+
+The MODULE keyword is used to start the XS code and to
+specify the package of the functions which are being
+defined. All text preceding the first MODULE keyword is
+considered C code and is passed through to the output
+untouched. Every XS module will have a bootstrap function
+which is used to hook the XSUBs into Perl. The package name
+of this bootstrap function will match the value of the last
+MODULE statement in the XS source files. The value of
+MODULE should always remain constant within the same XS
+file, though this is not required.
+
+The following example will start the XS code and will place
+all functions in a package named RPC.
+
+ MODULE = RPC
+
+=head2 The PACKAGE Keyword
+
+When functions within an XS source file must be separated into packages
+the PACKAGE keyword should be used. This keyword is used with the MODULE
+keyword and must follow immediately after it when used.
+
+ MODULE = RPC PACKAGE = RPC
+
+ [ XS code in package RPC ]
+
+ MODULE = RPC PACKAGE = RPCB
+
+ [ XS code in package RPCB ]
+
+ MODULE = RPC PACKAGE = RPC
+
+ [ XS code in package RPC ]
+
+Although this keyword is optional and in some cases provides redundant
+information it should always be used. This keyword will ensure that the
+XSUBs appear in the desired package.
+
+=head2 The PREFIX Keyword
+
+The PREFIX keyword designates prefixes which should be
+removed from the Perl function names. If the C function is
+C<rpcb_gettime()> and the PREFIX value is C<rpcb_> then Perl will
+see this function as C<gettime()>.
+
+This keyword should follow the PACKAGE keyword when used.
+If PACKAGE is not used then PREFIX should follow the MODULE
+keyword.
+
+ MODULE = RPC PREFIX = rpc_
+
+ MODULE = RPC PACKAGE = RPCB PREFIX = rpcb_
+
+=head2 The OUTPUT: Keyword
+
+The OUTPUT: keyword indicates that certain function parameters should be
+updated (new values made visible to Perl) when the XSUB terminates or that
+certain values should be returned to the calling Perl function. For
+simple functions, such as the sin() function above, the RETVAL variable is
+automatically designated as an output value. In more complex functions
+the B<xsubpp> compiler will need help to determine which variables are output
+variables.
+
+This keyword will normally be used to complement the CODE: keyword.
+The RETVAL variable is not recognized as an output variable when the
+CODE: keyword is present. The OUTPUT: keyword is used in this
+situation to tell the compiler that RETVAL really is an output
+variable.
+
+The OUTPUT: keyword can also be used to indicate that function parameters
+are output variables. This may be necessary when a parameter has been
+modified within the function and the programmer would like the update to
+be seen by Perl.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ time_t &timep
+ OUTPUT:
+ timep
+
+The OUTPUT: keyword will also allow an output parameter to
+be mapped to a matching piece of code rather than to a
+typemap.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ time_t &timep
+ OUTPUT:
+ timep sv_setnv(ST(1), (double)timep);
+
+B<xsubpp> emits an automatic C<SvSETMAGIC()> for all parameters in the
+OUTPUT section of the XSUB, except RETVAL. This is the usually desired
+behavior, as it takes care of properly invoking 'set' magic on output
+parameters (needed for hash or array element parameters that must be
+created if they didn't exist). If for some reason, this behavior is
+not desired, the OUTPUT section may contain a C<SETMAGIC: DISABLE> line
+to disable it for the remainder of the parameters in the OUTPUT section.
+Likewise, C<SETMAGIC: ENABLE> can be used to reenable it for the
+remainder of the OUTPUT section. See L<perlguts> for more details
+about 'set' magic.
+
+=head2 The CODE: Keyword
+
+This keyword is used in more complicated XSUBs which require
+special handling for the C function. The RETVAL variable is
+available but will not be returned unless it is specified
+under the OUTPUT: keyword.
+
+The following XSUB is for a C function which requires special handling of
+its parameters. The Perl usage is given first.
+
+ $status = rpcb_gettime( "localhost", $timep );
+
+The XSUB follows.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ time_t timep
+ CODE:
+ RETVAL = rpcb_gettime( host, &timep );
+ OUTPUT:
+ timep
+ RETVAL
+
+=head2 The INIT: Keyword
+
+The INIT: keyword allows initialization to be inserted into the XSUB before
+the compiler generates the call to the C function. Unlike the CODE: keyword
+above, this keyword does not affect the way the compiler handles RETVAL.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ time_t &timep
+ INIT:
+ printf("# Host is %s\n", host );
+ OUTPUT:
+ timep
+
+=head2 The NO_INIT Keyword
+
+The NO_INIT keyword is used to indicate that a function
+parameter is being used only as an output value. The B<xsubpp>
+compiler will normally generate code to read the values of
+all function parameters from the argument stack and assign
+them to C variables upon entry to the function. NO_INIT
+will tell the compiler that some parameters will be used for
+output rather than for input and that they will be handled
+before the function terminates.
+
+The following example shows a variation of the rpcb_gettime() function.
+This function uses the timep variable only as an output variable and does
+not care about its initial contents.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ time_t &timep = NO_INIT
+ OUTPUT:
+ timep
+
+=head2 Initializing Function Parameters
+
+Function parameters are normally initialized with their
+values from the argument stack. The typemaps contain the
+code segments which are used to transfer the Perl values to
+the C parameters. The programmer, however, is allowed to
+override the typemaps and supply alternate (or additional)
+initialization code.
+
+The following code demonstrates how to supply initialization code for
+function parameters. The initialization code is eval'd within double
+quotes by the compiler before it is added to the output so anything
+which should be interpreted literally [mainly C<$>, C<@>, or C<\\>]
+must be protected with backslashes. The variables C<$var>, C<$arg>,
+and C<$type> can be used as in typemaps.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host = (char *)SvPV($arg,PL_na);
+ time_t &timep = 0;
+ OUTPUT:
+ timep
+
+This should not be used to supply default values for parameters. One
+would normally use this when a function parameter must be processed by
+another library function before it can be used. Default parameters are
+covered in the next section.
+
+If the initialization begins with C<=>, then it is output on
+the same line where the input variable is declared. If the
+initialization begins with C<;> or C<+>, then it is output after
+all of the input variables have been declared. The C<=> and C<;>
+cases replace the initialization normally supplied from the typemap.
+For the C<+> case, the initialization from the typemap will preceed
+the initialization code included after the C<+>. A global
+variable, C<%v>, is available for the truely rare case where
+information from one initialization is needed in another
+initialization.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ time_t &timep ; /*\$v{time}=@{[$v{time}=$arg]}*/
+ char *host + SvOK($v{time}) ? SvPV($arg,PL_na) : NULL;
+ OUTPUT:
+ timep
+
+=head2 Default Parameter Values
+
+Default values can be specified for function parameters by
+placing an assignment statement in the parameter list. The
+default value may be a number or a string. Defaults should
+always be used on the right-most parameters only.
+
+To allow the XSUB for rpcb_gettime() to have a default host
+value the parameters to the XSUB could be rearranged. The
+XSUB will then call the real rpcb_gettime() function with
+the parameters in the correct order. Perl will call this
+XSUB with either of the following statements.
+
+ $status = rpcb_gettime( $timep, $host );
+
+ $status = rpcb_gettime( $timep );
+
+The XSUB will look like the code which follows. A CODE:
+block is used to call the real rpcb_gettime() function with
+the parameters in the correct order for that function.
+
+ bool_t
+ rpcb_gettime(timep,host="localhost")
+ char *host
+ time_t timep = NO_INIT
+ CODE:
+ RETVAL = rpcb_gettime( host, &timep );
+ OUTPUT:
+ timep
+ RETVAL
+
+=head2 The PREINIT: Keyword
+
+The PREINIT: keyword allows extra variables to be declared before the
+typemaps are expanded. If a variable is declared in a CODE: block then that
+variable will follow any typemap code. This may result in a C syntax
+error. To force the variable to be declared before the typemap code, place
+it into a PREINIT: block. The PREINIT: keyword may be used one or more
+times within an XSUB.
+
+The following examples are equivalent, but if the code is using complex
+typemaps then the first example is safer.
+
+ bool_t
+ rpcb_gettime(timep)
+ time_t timep = NO_INIT
+ PREINIT:
+ char *host = "localhost";
+ CODE:
+ RETVAL = rpcb_gettime( host, &timep );
+ OUTPUT:
+ timep
+ RETVAL
+
+A correct, but error-prone example.
+
+ bool_t
+ rpcb_gettime(timep)
+ time_t timep = NO_INIT
+ CODE:
+ char *host = "localhost";
+ RETVAL = rpcb_gettime( host, &timep );
+ OUTPUT:
+ timep
+ RETVAL
+
+=head2 The SCOPE: Keyword
+
+The SCOPE: keyword allows scoping to be enabled for a particular XSUB. If
+enabled, the XSUB will invoke ENTER and LEAVE automatically.
+
+To support potentially complex type mappings, if a typemap entry used
+by this XSUB contains a comment like C</*scope*/> then scoping will
+automatically be enabled for that XSUB.
+
+To enable scoping:
+
+ SCOPE: ENABLE
+
+To disable scoping:
+
+ SCOPE: DISABLE
+
+=head2 The INPUT: Keyword
+
+The XSUB's parameters are usually evaluated immediately after entering the
+XSUB. The INPUT: keyword can be used to force those parameters to be
+evaluated a little later. The INPUT: keyword can be used multiple times
+within an XSUB and can be used to list one or more input variables. This
+keyword is used with the PREINIT: keyword.
+
+The following example shows how the input parameter C<timep> can be
+evaluated late, after a PREINIT.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ PREINIT:
+ time_t tt;
+ INPUT:
+ time_t timep
+ CODE:
+ RETVAL = rpcb_gettime( host, &tt );
+ timep = tt;
+ OUTPUT:
+ timep
+ RETVAL
+
+The next example shows each input parameter evaluated late.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ PREINIT:
+ time_t tt;
+ INPUT:
+ char *host
+ PREINIT:
+ char *h;
+ INPUT:
+ time_t timep
+ CODE:
+ h = host;
+ RETVAL = rpcb_gettime( h, &tt );
+ timep = tt;
+ OUTPUT:
+ timep
+ RETVAL
+
+=head2 Variable-length Parameter Lists
+
+XSUBs can have variable-length parameter lists by specifying an ellipsis
+C<(...)> in the parameter list. This use of the ellipsis is similar to that
+found in ANSI C. The programmer is able to determine the number of
+arguments passed to the XSUB by examining the C<items> variable which the
+B<xsubpp> compiler supplies for all XSUBs. By using this mechanism one can
+create an XSUB which accepts a list of parameters of unknown length.
+
+The I<host> parameter for the rpcb_gettime() XSUB can be
+optional so the ellipsis can be used to indicate that the
+XSUB will take a variable number of parameters. Perl should
+be able to call this XSUB with either of the following statements.
+
+ $status = rpcb_gettime( $timep, $host );
+
+ $status = rpcb_gettime( $timep );
+
+The XS code, with ellipsis, follows.
+
+ bool_t
+ rpcb_gettime(timep, ...)
+ time_t timep = NO_INIT
+ PREINIT:
+ char *host = "localhost";
+ CODE:
+ if( items > 1 )
+ host = (char *)SvPV(ST(1), PL_na);
+ RETVAL = rpcb_gettime( host, &timep );
+ OUTPUT:
+ timep
+ RETVAL
+
+=head2 The C_ARGS: Keyword
+
+The C_ARGS: keyword allows creating of XSUBS which have different
+calling sequence from Perl than from C, without a need to write
+CODE: or CPPCODE: section. The contents of the C_ARGS: paragraph is
+put as the argument to the called C function without any change.
+
+For example, suppose that C function is declared as
+
+ symbolic nth_derivative(int n, symbolic function, int flags);
+
+and that the default flags are kept in a global C variable
+C<default_flags>. Suppose that you want to create an interface which
+is called as
+
+ $second_deriv = $function->nth_derivative(2);
+
+To do this, declare the XSUB as
+
+ symbolic
+ nth_derivative(function, n)
+ symbolic function
+ int n
+ C_ARGS:
+ n, function, default_flags
+
+=head2 The PPCODE: Keyword
+
+The PPCODE: keyword is an alternate form of the CODE: keyword and is used
+to tell the B<xsubpp> compiler that the programmer is supplying the code to
+control the argument stack for the XSUBs return values. Occasionally one
+will want an XSUB to return a list of values rather than a single value.
+In these cases one must use PPCODE: and then explicitly push the list of
+values on the stack. The PPCODE: and CODE: keywords are not used
+together within the same XSUB.
+
+The following XSUB will call the C rpcb_gettime() function
+and will return its two output values, timep and status, to
+Perl as a single list.
+
+ void
+ rpcb_gettime(host)
+ char *host
+ PREINIT:
+ time_t timep;
+ bool_t status;
+ PPCODE:
+ status = rpcb_gettime( host, &timep );
+ EXTEND(SP, 2);
+ PUSHs(sv_2mortal(newSViv(status)));
+ PUSHs(sv_2mortal(newSViv(timep)));
+
+Notice that the programmer must supply the C code necessary
+to have the real rpcb_gettime() function called and to have
+the return values properly placed on the argument stack.
+
+The C<void> return type for this function tells the B<xsubpp> compiler that
+the RETVAL variable is not needed or used and that it should not be created.
+In most scenarios the void return type should be used with the PPCODE:
+directive.
+
+The EXTEND() macro is used to make room on the argument
+stack for 2 return values. The PPCODE: directive causes the
+B<xsubpp> compiler to create a stack pointer available as C<SP>, and it
+is this pointer which is being used in the EXTEND() macro.
+The values are then pushed onto the stack with the PUSHs()
+macro.
+
+Now the rpcb_gettime() function can be used from Perl with
+the following statement.
+
+ ($status, $timep) = rpcb_gettime("localhost");
+
+When handling output parameters with a PPCODE section, be sure to handle
+'set' magic properly. See L<perlguts> for details about 'set' magic.
+
+=head2 Returning Undef And Empty Lists
+
+Occasionally the programmer will want to return simply
+C<undef> or an empty list if a function fails rather than a
+separate status value. The rpcb_gettime() function offers
+just this situation. If the function succeeds we would like
+to have it return the time and if it fails we would like to
+have undef returned. In the following Perl code the value
+of $timep will either be undef or it will be a valid time.
+
+ $timep = rpcb_gettime( "localhost" );
+
+The following XSUB uses the C<SV *> return type as a mnemonic only,
+and uses a CODE: block to indicate to the compiler
+that the programmer has supplied all the necessary code. The
+sv_newmortal() call will initialize the return value to undef, making that
+the default return value.
+
+ SV *
+ rpcb_gettime(host)
+ char * host
+ PREINIT:
+ time_t timep;
+ bool_t x;
+ CODE:
+ ST(0) = sv_newmortal();
+ if( rpcb_gettime( host, &timep ) )
+ sv_setnv( ST(0), (double)timep);
+
+The next example demonstrates how one would place an explicit undef in the
+return value, should the need arise.
+
+ SV *
+ rpcb_gettime(host)
+ char * host
+ PREINIT:
+ time_t timep;
+ bool_t x;
+ CODE:
+ ST(0) = sv_newmortal();
+ if( rpcb_gettime( host, &timep ) ){
+ sv_setnv( ST(0), (double)timep);
+ }
+ else{
+ ST(0) = &PL_sv_undef;
+ }
+
+To return an empty list one must use a PPCODE: block and
+then not push return values on the stack.
+
+ void
+ rpcb_gettime(host)
+ char *host
+ PREINIT:
+ time_t timep;
+ PPCODE:
+ if( rpcb_gettime( host, &timep ) )
+ PUSHs(sv_2mortal(newSViv(timep)));
+ else{
+ /* Nothing pushed on stack, so an empty */
+ /* list is implicitly returned. */
+ }
+
+Some people may be inclined to include an explicit C<return> in the above
+XSUB, rather than letting control fall through to the end. In those
+situations C<XSRETURN_EMPTY> should be used, instead. This will ensure that
+the XSUB stack is properly adjusted. Consult L<perlguts/"API LISTING"> for
+other C<XSRETURN> macros.
+
+=head2 The REQUIRE: Keyword
+
+The REQUIRE: keyword is used to indicate the minimum version of the
+B<xsubpp> compiler needed to compile the XS module. An XS module which
+contains the following statement will compile with only B<xsubpp> version
+1.922 or greater:
+
+ REQUIRE: 1.922
+
+=head2 The CLEANUP: Keyword
+
+This keyword can be used when an XSUB requires special cleanup procedures
+before it terminates. When the CLEANUP: keyword is used it must follow
+any CODE:, PPCODE:, or OUTPUT: blocks which are present in the XSUB. The
+code specified for the cleanup block will be added as the last statements
+in the XSUB.
+
+=head2 The BOOT: Keyword
+
+The BOOT: keyword is used to add code to the extension's bootstrap
+function. The bootstrap function is generated by the B<xsubpp> compiler and
+normally holds the statements necessary to register any XSUBs with Perl.
+With the BOOT: keyword the programmer can tell the compiler to add extra
+statements to the bootstrap function.
+
+This keyword may be used any time after the first MODULE keyword and should
+appear on a line by itself. The first blank line after the keyword will
+terminate the code block.
+
+ BOOT:
+ # The following message will be printed when the
+ # bootstrap function executes.
+ printf("Hello from the bootstrap!\n");
+
+=head2 The VERSIONCHECK: Keyword
+
+The VERSIONCHECK: keyword corresponds to B<xsubpp>'s C<-versioncheck> and
+C<-noversioncheck> options. This keyword overrides the command line
+options. Version checking is enabled by default. When version checking is
+enabled the XS module will attempt to verify that its version matches the
+version of the PM module.
+
+To enable version checking:
+
+ VERSIONCHECK: ENABLE
+
+To disable version checking:
+
+ VERSIONCHECK: DISABLE
+
+=head2 The PROTOTYPES: Keyword
+
+The PROTOTYPES: keyword corresponds to B<xsubpp>'s C<-prototypes> and
+C<-noprototypes> options. This keyword overrides the command line options.
+Prototypes are enabled by default. When prototypes are enabled XSUBs will
+be given Perl prototypes. This keyword may be used multiple times in an XS
+module to enable and disable prototypes for different parts of the module.
+
+To enable prototypes:
+
+ PROTOTYPES: ENABLE
+
+To disable prototypes:
+
+ PROTOTYPES: DISABLE
+
+=head2 The PROTOTYPE: Keyword
+
+This keyword is similar to the PROTOTYPES: keyword above but can be used to
+force B<xsubpp> to use a specific prototype for the XSUB. This keyword
+overrides all other prototype options and keywords but affects only the
+current XSUB. Consult L<perlsub/Prototypes> for information about Perl
+prototypes.
+
+ bool_t
+ rpcb_gettime(timep, ...)
+ time_t timep = NO_INIT
+ PROTOTYPE: $;$
+ PREINIT:
+ char *host = "localhost";
+ CODE:
+ if( items > 1 )
+ host = (char *)SvPV(ST(1), PL_na);
+ RETVAL = rpcb_gettime( host, &timep );
+ OUTPUT:
+ timep
+ RETVAL
+
+=head2 The ALIAS: Keyword
+
+The ALIAS: keyword allows an XSUB to have two or more unique Perl names
+and to know which of those names was used when it was invoked. The Perl
+names may be fully-qualified with package names. Each alias is given an
+index. The compiler will setup a variable called C<ix> which contain the
+index of the alias which was used. When the XSUB is called with its
+declared name C<ix> will be 0.
+
+The following example will create aliases C<FOO::gettime()> and
+C<BAR::getit()> for this function.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ time_t &timep
+ ALIAS:
+ FOO::gettime = 1
+ BAR::getit = 2
+ INIT:
+ printf("# ix = %d\n", ix );
+ OUTPUT:
+ timep
+
+=head2 The INTERFACE: Keyword
+
+This keyword declares the current XSUB as a keeper of the given
+calling signature. If some text follows this keyword, it is
+considered as a list of functions which have this signature, and
+should be attached to XSUBs.
+
+Say, if you have 4 functions multiply(), divide(), add(), subtract() all
+having the signature
+
+ symbolic f(symbolic, symbolic);
+
+you code them all by using XSUB
+
+ symbolic
+ interface_s_ss(arg1, arg2)
+ symbolic arg1
+ symbolic arg2
+ INTERFACE:
+ multiply divide
+ add subtract
+
+The advantage of this approach comparing to ALIAS: keyword is that one
+can attach an extra function remainder() at runtime by using
+
+ CV *mycv = newXSproto("Symbolic::remainder",
+ XS_Symbolic_interface_s_ss, __FILE__, "$$");
+ XSINTERFACE_FUNC_SET(mycv, remainder);
+
+(This example supposes that there was no INTERFACE_MACRO: section,
+otherwise one needs to use something else instead of
+C<XSINTERFACE_FUNC_SET>.)
+
+=head2 The INTERFACE_MACRO: Keyword
+
+This keyword allows one to define an INTERFACE using a different way
+to extract a function pointer from an XSUB. The text which follows
+this keyword should give the name of macros which would extract/set a
+function pointer. The extractor macro is given return type, C<CV*>,
+and C<XSANY.any_dptr> for this C<CV*>. The setter macro is given cv,
+and the function pointer.
+
+The default value is C<XSINTERFACE_FUNC> and C<XSINTERFACE_FUNC_SET>.
+An INTERFACE keyword with an empty list of functions can be omitted if
+INTERFACE_MACRO keyword is used.
+
+Suppose that in the previous example functions pointers for
+multiply(), divide(), add(), subtract() are kept in a global C array
+C<fp[]> with offsets being C<multiply_off>, C<divide_off>, C<add_off>,
+C<subtract_off>. Then one can use
+
+ #define XSINTERFACE_FUNC_BYOFFSET(ret,cv,f) \
+ ((XSINTERFACE_CVT(ret,))fp[CvXSUBANY(cv).any_i32])
+ #define XSINTERFACE_FUNC_BYOFFSET_set(cv,f) \
+ CvXSUBANY(cv).any_i32 = CAT2( f, _off )
+
+in C section,
+
+ symbolic
+ interface_s_ss(arg1, arg2)
+ symbolic arg1
+ symbolic arg2
+ INTERFACE_MACRO:
+ XSINTERFACE_FUNC_BYOFFSET
+ XSINTERFACE_FUNC_BYOFFSET_set
+ INTERFACE:
+ multiply divide
+ add subtract
+
+in XSUB section.
+
+=head2 The INCLUDE: Keyword
+
+This keyword can be used to pull other files into the XS module. The other
+files may have XS code. INCLUDE: can also be used to run a command to
+generate the XS code to be pulled into the module.
+
+The file F<Rpcb1.xsh> contains our C<rpcb_gettime()> function:
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ time_t &timep
+ OUTPUT:
+ timep
+
+The XS module can use INCLUDE: to pull that file into it.
+
+ INCLUDE: Rpcb1.xsh
+
+If the parameters to the INCLUDE: keyword are followed by a pipe (C<|>) then
+the compiler will interpret the parameters as a command.
+
+ INCLUDE: cat Rpcb1.xsh |
+
+=head2 The CASE: Keyword
+
+The CASE: keyword allows an XSUB to have multiple distinct parts with each
+part acting as a virtual XSUB. CASE: is greedy and if it is used then all
+other XS keywords must be contained within a CASE:. This means nothing may
+precede the first CASE: in the XSUB and anything following the last CASE: is
+included in that case.
+
+A CASE: might switch via a parameter of the XSUB, via the C<ix> ALIAS:
+variable (see L<"The ALIAS: Keyword">), or maybe via the C<items> variable
+(see L<"Variable-length Parameter Lists">). The last CASE: becomes the
+B<default> case if it is not associated with a conditional. The following
+example shows CASE switched via C<ix> with a function C<rpcb_gettime()>
+having an alias C<x_gettime()>. When the function is called as
+C<rpcb_gettime()> its parameters are the usual C<(char *host, time_t *timep)>,
+but when the function is called as C<x_gettime()> its parameters are
+reversed, C<(time_t *timep, char *host)>.
+
+ long
+ rpcb_gettime(a,b)
+ CASE: ix == 1
+ ALIAS:
+ x_gettime = 1
+ INPUT:
+ # 'a' is timep, 'b' is host
+ char *b
+ time_t a = NO_INIT
+ CODE:
+ RETVAL = rpcb_gettime( b, &a );
+ OUTPUT:
+ a
+ RETVAL
+ CASE:
+ # 'a' is host, 'b' is timep
+ char *a
+ time_t &b = NO_INIT
+ OUTPUT:
+ b
+ RETVAL
+
+That function can be called with either of the following statements. Note
+the different argument lists.
+
+ $status = rpcb_gettime( $host, $timep );
+
+ $status = x_gettime( $timep, $host );
+
+=head2 The & Unary Operator
+
+The & unary operator is used to tell the compiler that it should dereference
+the object when it calls the C function. This is used when a CODE: block is
+not used and the object is a not a pointer type (the object is an C<int> or
+C<long> but not a C<int*> or C<long*>).
+
+The following XSUB will generate incorrect C code. The xsubpp compiler will
+turn this into code which calls C<rpcb_gettime()> with parameters C<(char
+*host, time_t timep)>, but the real C<rpcb_gettime()> wants the C<timep>
+parameter to be of type C<time_t*> rather than C<time_t>.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ time_t timep
+ OUTPUT:
+ timep
+
+That problem is corrected by using the C<&> operator. The xsubpp compiler
+will now turn this into code which calls C<rpcb_gettime()> correctly with
+parameters C<(char *host, time_t *timep)>. It does this by carrying the
+C<&> through, so the function call looks like C<rpcb_gettime(host, &timep)>.
+
+ bool_t
+ rpcb_gettime(host,timep)
+ char *host
+ time_t &timep
+ OUTPUT:
+ timep
+
+=head2 Inserting Comments and C Preprocessor Directives
+
+C preprocessor directives are allowed within BOOT:, PREINIT: INIT:,
+CODE:, PPCODE:, and CLEANUP: blocks, as well as outside the functions.
+Comments are allowed anywhere after the MODULE keyword. The compiler
+will pass the preprocessor directives through untouched and will remove
+the commented lines.
+
+Comments can be added to XSUBs by placing a C<#> as the first
+non-whitespace of a line. Care should be taken to avoid making the
+comment look like a C preprocessor directive, lest it be interpreted as
+such. The simplest way to prevent this is to put whitespace in front of
+the C<#>.
+
+If you use preprocessor directives to choose one of two
+versions of a function, use
+
+ #if ... version1
+ #else /* ... version2 */
+ #endif
+
+and not
+
+ #if ... version1
+ #endif
+ #if ... version2
+ #endif
+
+because otherwise xsubpp will believe that you made a duplicate
+definition of the function. Also, put a blank line before the
+#else/#endif so it will not be seen as part of the function body.
+
+=head2 Using XS With C++
+
+If a function is defined as a C++ method then it will assume
+its first argument is an object pointer. The object pointer
+will be stored in a variable called THIS. The object should
+have been created by C++ with the new() function and should
+be blessed by Perl with the sv_setref_pv() macro. The
+blessing of the object by Perl can be handled by a typemap. An example
+typemap is shown at the end of this section.
+
+If the method is defined as static it will call the C++
+function using the class::method() syntax. If the method is not static
+the function will be called using the THIS-E<gt>method() syntax.
+
+The next examples will use the following C++ class.
+
+ class color {
+ public:
+ color();
+ ~color();
+ int blue();
+ void set_blue( int );
+
+ private:
+ int c_blue;
+ };
+
+The XSUBs for the blue() and set_blue() methods are defined with the class
+name but the parameter for the object (THIS, or "self") is implicit and is
+not listed.
+
+ int
+ color::blue()
+
+ void
+ color::set_blue( val )
+ int val
+
+Both functions will expect an object as the first parameter. The xsubpp
+compiler will call that object C<THIS> and will use it to call the specified
+method. So in the C++ code the blue() and set_blue() methods will be called
+in the following manner.
+
+ RETVAL = THIS->blue();
+
+ THIS->set_blue( val );
+
+If the function's name is B<DESTROY> then the C++ C<delete> function will be
+called and C<THIS> will be given as its parameter.
+
+ void
+ color::DESTROY()
+
+The C++ code will call C<delete>.
+
+ delete THIS;
+
+If the function's name is B<new> then the C++ C<new> function will be called
+to create a dynamic C++ object. The XSUB will expect the class name, which
+will be kept in a variable called C<CLASS>, to be given as the first
+argument.
+
+ color *
+ color::new()
+
+The C++ code will call C<new>.
+
+ RETVAL = new color();
+
+The following is an example of a typemap that could be used for this C++
+example.
+
+ TYPEMAP
+ color * O_OBJECT
+
+ OUTPUT
+ # The Perl object is blessed into 'CLASS', which should be a
+ # char* having the name of the package for the blessing.
+ O_OBJECT
+ sv_setref_pv( $arg, CLASS, (void*)$var );
+
+ INPUT
+ O_OBJECT
+ if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG) )
+ $var = ($type)SvIV((SV*)SvRV( $arg ));
+ else{
+ warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" );
+ XSRETURN_UNDEF;
+ }
+
+=head2 Interface Strategy
+
+When designing an interface between Perl and a C library a straight
+translation from C to XS is often sufficient. The interface will often be
+very C-like and occasionally nonintuitive, especially when the C function
+modifies one of its parameters. In cases where the programmer wishes to
+create a more Perl-like interface the following strategy may help to
+identify the more critical parts of the interface.
+
+Identify the C functions which modify their parameters. The XSUBs for
+these functions may be able to return lists to Perl, or may be
+candidates to return undef or an empty list in case of failure.
+
+Identify which values are used by only the C and XSUB functions
+themselves. If Perl does not need to access the contents of the value
+then it may not be necessary to provide a translation for that value
+from C to Perl.
+
+Identify the pointers in the C function parameter lists and return
+values. Some pointers can be handled in XS with the & unary operator on
+the variable name while others will require the use of the * operator on
+the type name. In general it is easier to work with the & operator.
+
+Identify the structures used by the C functions. In many
+cases it may be helpful to use the T_PTROBJ typemap for
+these structures so they can be manipulated by Perl as
+blessed objects.
+
+=head2 Perl Objects And C Structures
+
+When dealing with C structures one should select either
+B<T_PTROBJ> or B<T_PTRREF> for the XS type. Both types are
+designed to handle pointers to complex objects. The
+T_PTRREF type will allow the Perl object to be unblessed
+while the T_PTROBJ type requires that the object be blessed.
+By using T_PTROBJ one can achieve a form of type-checking
+because the XSUB will attempt to verify that the Perl object
+is of the expected type.
+
+The following XS code shows the getnetconfigent() function which is used
+with ONC+ TIRPC. The getnetconfigent() function will return a pointer to a
+C structure and has the C prototype shown below. The example will
+demonstrate how the C pointer will become a Perl reference. Perl will
+consider this reference to be a pointer to a blessed object and will
+attempt to call a destructor for the object. A destructor will be
+provided in the XS source to free the memory used by getnetconfigent().
+Destructors in XS can be created by specifying an XSUB function whose name
+ends with the word B<DESTROY>. XS destructors can be used to free memory
+which may have been malloc'd by another XSUB.
+
+ struct netconfig *getnetconfigent(const char *netid);
+
+A C<typedef> will be created for C<struct netconfig>. The Perl
+object will be blessed in a class matching the name of the C
+type, with the tag C<Ptr> appended, and the name should not
+have embedded spaces if it will be a Perl package name. The
+destructor will be placed in a class corresponding to the
+class of the object and the PREFIX keyword will be used to
+trim the name to the word DESTROY as Perl will expect.
+
+ typedef struct netconfig Netconfig;
+
+ MODULE = RPC PACKAGE = RPC
+
+ Netconfig *
+ getnetconfigent(netid)
+ char *netid
+
+ MODULE = RPC PACKAGE = NetconfigPtr PREFIX = rpcb_
+
+ void
+ rpcb_DESTROY(netconf)
+ Netconfig *netconf
+ CODE:
+ printf("Now in NetconfigPtr::DESTROY\n");
+ free( netconf );
+
+This example requires the following typemap entry. Consult the typemap
+section for more information about adding new typemaps for an extension.
+
+ TYPEMAP
+ Netconfig * T_PTROBJ
+
+This example will be used with the following Perl statements.
+
+ use RPC;
+ $netconf = getnetconfigent("udp");
+
+When Perl destroys the object referenced by $netconf it will send the
+object to the supplied XSUB DESTROY function. Perl cannot determine, and
+does not care, that this object is a C struct and not a Perl object. In
+this sense, there is no difference between the object created by the
+getnetconfigent() XSUB and an object created by a normal Perl subroutine.
+
+=head2 The Typemap
+
+The typemap is a collection of code fragments which are used by the B<xsubpp>
+compiler to map C function parameters and values to Perl values. The
+typemap file may consist of three sections labeled C<TYPEMAP>, C<INPUT>, and
+C<OUTPUT>. The INPUT section tells the compiler how to translate Perl values
+into variables of certain C types. The OUTPUT section tells the compiler
+how to translate the values from certain C types into values Perl can
+understand. The TYPEMAP section tells the compiler which of the INPUT and
+OUTPUT code fragments should be used to map a given C type to a Perl value.
+Each of the sections of the typemap must be preceded by one of the TYPEMAP,
+INPUT, or OUTPUT keywords.
+
+The default typemap in the C<ext> directory of the Perl source contains many
+useful types which can be used by Perl extensions. Some extensions define
+additional typemaps which they keep in their own directory. These
+additional typemaps may reference INPUT and OUTPUT maps in the main
+typemap. The B<xsubpp> compiler will allow the extension's own typemap to
+override any mappings which are in the default typemap.
+
+Most extensions which require a custom typemap will need only the TYPEMAP
+section of the typemap file. The custom typemap used in the
+getnetconfigent() example shown earlier demonstrates what may be the typical
+use of extension typemaps. That typemap is used to equate a C structure
+with the T_PTROBJ typemap. The typemap used by getnetconfigent() is shown
+here. Note that the C type is separated from the XS type with a tab and
+that the C unary operator C<*> is considered to be a part of the C type name.
+
+ TYPEMAP
+ Netconfig *<tab>T_PTROBJ
+
+Here's a more complicated example: suppose that you wanted C<struct
+netconfig> to be blessed into the class C<Net::Config>. One way to do
+this is to use underscores (_) to separate package names, as follows:
+
+ typedef struct netconfig * Net_Config;
+
+And then provide a typemap entry C<T_PTROBJ_SPECIAL> that maps underscores to
+double-colons (::), and declare C<Net_Config> to be of that type:
+
+
+ TYPEMAP
+ Net_Config T_PTROBJ_SPECIAL
+
+ INPUT
+ T_PTROBJ_SPECIAL
+ if (sv_derived_from($arg, \"${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\")) {
+ IV tmp = SvIV((SV*)SvRV($arg));
+ $var = ($type) tmp;
+ }
+ else
+ croak(\"$var is not of type ${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\")
+
+ OUTPUT
+ T_PTROBJ_SPECIAL
+ sv_setref_pv($arg, \"${(my $ntt=$ntype)=~s/_/::/g;\$ntt}\",
+ (void*)$var);
+
+The INPUT and OUTPUT sections substitute underscores for double-colons
+on the fly, giving the desired effect. This example demonstrates some
+of the power and versatility of the typemap facility.
+
+=head1 EXAMPLES
+
+File C<RPC.xs>: Interface to some ONC+ RPC bind library functions.
+
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+
+ #include <rpc/rpc.h>
+
+ typedef struct netconfig Netconfig;
+
+ MODULE = RPC PACKAGE = RPC
+
+ SV *
+ rpcb_gettime(host="localhost")
+ char *host
+ PREINIT:
+ time_t timep;
+ CODE:
+ ST(0) = sv_newmortal();
+ if( rpcb_gettime( host, &timep ) )
+ sv_setnv( ST(0), (double)timep );
+
+ Netconfig *
+ getnetconfigent(netid="udp")
+ char *netid
+
+ MODULE = RPC PACKAGE = NetconfigPtr PREFIX = rpcb_
+
+ void
+ rpcb_DESTROY(netconf)
+ Netconfig *netconf
+ CODE:
+ printf("NetconfigPtr::DESTROY\n");
+ free( netconf );
+
+File C<typemap>: Custom typemap for RPC.xs.
+
+ TYPEMAP
+ Netconfig * T_PTROBJ
+
+File C<RPC.pm>: Perl module for the RPC extension.
+
+ package RPC;
+
+ require Exporter;
+ require DynaLoader;
+ @ISA = qw(Exporter DynaLoader);
+ @EXPORT = qw(rpcb_gettime getnetconfigent);
+
+ bootstrap RPC;
+ 1;
+
+File C<rpctest.pl>: Perl test program for the RPC extension.
+
+ use RPC;
+
+ $netconf = getnetconfigent();
+ $a = rpcb_gettime();
+ print "time = $a\n";
+ print "netconf = $netconf\n";
+
+ $netconf = getnetconfigent("tcp");
+ $a = rpcb_gettime("poplar");
+ print "time = $a\n";
+ print "netconf = $netconf\n";
+
+
+=head1 XS VERSION
+
+This document covers features supported by C<xsubpp> 1.935.
+
+=head1 AUTHOR
+
+Dean Roehrich <F<roehrich@cray.com>>
+Jul 8, 1996
diff --git a/contrib/perl5/pod/perlxstut.pod b/contrib/perl5/pod/perlxstut.pod
new file mode 100644
index 000000000000..867d42a8c24c
--- /dev/null
+++ b/contrib/perl5/pod/perlxstut.pod
@@ -0,0 +1,739 @@
+=head1 NAME
+
+perlXStut - Tutorial for XSUBs
+
+=head1 DESCRIPTION
+
+This tutorial will educate the reader on the steps involved in creating
+a Perl extension. The reader is assumed to have access to L<perlguts> and
+L<perlxs>.
+
+This tutorial starts with very simple examples and becomes more complex,
+with each new example adding new features. Certain concepts may not be
+completely explained until later in the tutorial to ease the
+reader slowly into building extensions.
+
+=head2 VERSION CAVEAT
+
+This tutorial tries hard to keep up with the latest development versions
+of Perl. This often means that it is sometimes in advance of the latest
+released version of Perl, and that certain features described here might
+not work on earlier versions. This section will keep track of when various
+features were added to Perl 5.
+
+=over 4
+
+=item *
+
+In versions of Perl 5.002 prior to the gamma version, the test script
+in Example 1 will not function properly. You need to change the "use
+lib" line to read:
+
+ use lib './blib';
+
+=item *
+
+In versions of Perl 5.002 prior to version beta 3, the line in the .xs file
+about "PROTOTYPES: DISABLE" will cause a compiler error. Simply remove that
+line from the file.
+
+=item *
+
+In versions of Perl 5.002 prior to version 5.002b1h, the test.pl file was not
+automatically created by h2xs. This means that you cannot say "make test"
+to run the test script. You will need to add the following line before the
+"use extension" statement:
+
+ use lib './blib';
+
+=item *
+
+In versions 5.000 and 5.001, instead of using the above line, you will need
+to use the following line:
+
+ BEGIN { unshift(@INC, "./blib") }
+
+=item *
+
+This document assumes that the executable named "perl" is Perl version 5.
+Some systems may have installed Perl version 5 as "perl5".
+
+=back
+
+=head2 DYNAMIC VERSUS STATIC
+
+It is commonly thought that if a system does not have the capability to
+load a library dynamically, you cannot build XSUBs. This is incorrect.
+You I<can> build them, but you must link the XSUB's subroutines with the
+rest of Perl, creating a new executable. This situation is similar to
+Perl 4.
+
+This tutorial can still be used on such a system. The XSUB build mechanism
+will check the system and build a dynamically-loadable library if possible,
+or else a static library and then, optionally, a new statically-linked
+executable with that static library linked in.
+
+Should you wish to build a statically-linked executable on a system which
+can dynamically load libraries, you may, in all the following examples,
+where the command "make" with no arguments is executed, run the command
+"make perl" instead.
+
+If you have generated such a statically-linked executable by choice, then
+instead of saying "make test", you should say "make test_static". On systems
+that cannot build dynamically-loadable libraries at all, simply saying "make
+test" is sufficient.
+
+=head2 EXAMPLE 1
+
+Our first extension will be very simple. When we call the routine in the
+extension, it will print out a well-known message and return.
+
+Run C<h2xs -A -n Mytest>. This creates a directory named Mytest, possibly under
+ext/ if that directory exists in the current working directory. Several files
+will be created in the Mytest dir, including MANIFEST, Makefile.PL, Mytest.pm,
+Mytest.xs, test.pl, and Changes.
+
+The MANIFEST file contains the names of all the files created.
+
+The file Makefile.PL should look something like this:
+
+ use ExtUtils::MakeMaker;
+ # See lib/ExtUtils/MakeMaker.pm for details of how to influence
+ # the contents of the Makefile that is written.
+ WriteMakefile(
+ 'NAME' => 'Mytest',
+ 'VERSION_FROM' => 'Mytest.pm', # finds $VERSION
+ 'LIBS' => [''], # e.g., '-lm'
+ 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
+ 'INC' => '', # e.g., '-I/usr/include/other'
+ );
+
+The file Mytest.pm should start with something like this:
+
+ package Mytest;
+
+ require Exporter;
+ require DynaLoader;
+
+ @ISA = qw(Exporter DynaLoader);
+ # Items to export into callers namespace by default. Note: do not export
+ # names by default without a very good reason. Use EXPORT_OK instead.
+ # Do not simply export all your public functions/methods/constants.
+ @EXPORT = qw(
+
+ );
+ $VERSION = '0.01';
+
+ bootstrap Mytest $VERSION;
+
+ # Preloaded methods go here.
+
+ # Autoload methods go after __END__, and are processed by the autosplit program.
+
+ 1;
+ __END__
+ # Below is the stub of documentation for your module. You better edit it!
+
+And the Mytest.xs file should look something like this:
+
+ #ifdef __cplusplus
+ extern "C" {
+ #endif
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+ #ifdef __cplusplus
+ }
+ #endif
+
+ PROTOTYPES: DISABLE
+
+ MODULE = Mytest PACKAGE = Mytest
+
+Let's edit the .xs file by adding this to the end of the file:
+
+ void
+ hello()
+ CODE:
+ printf("Hello, world!\n");
+
+Now we'll run "perl Makefile.PL". This will create a real Makefile,
+which make needs. Its output looks something like:
+
+ % perl Makefile.PL
+ Checking if your kit is complete...
+ Looks good
+ Writing Makefile for Mytest
+ %
+
+Now, running make will produce output that looks something like this
+(some long lines shortened for clarity):
+
+ % make
+ umask 0 && cp Mytest.pm ./blib/Mytest.pm
+ perl xsubpp -typemap typemap Mytest.xs >Mytest.tc && mv Mytest.tc Mytest.c
+ cc -c Mytest.c
+ Running Mkbootstrap for Mytest ()
+ chmod 644 Mytest.bs
+ LD_RUN_PATH="" ld -o ./blib/PA-RISC1.1/auto/Mytest/Mytest.sl -b Mytest.o
+ chmod 755 ./blib/PA-RISC1.1/auto/Mytest/Mytest.sl
+ cp Mytest.bs ./blib/PA-RISC1.1/auto/Mytest/Mytest.bs
+ chmod 644 ./blib/PA-RISC1.1/auto/Mytest/Mytest.bs
+
+Now, although there is already a test.pl template ready for us, for this
+example only, we'll create a special test script. Create a file called hello
+that looks like this:
+
+ #! /opt/perl5/bin/perl
+
+ use ExtUtils::testlib;
+
+ use Mytest;
+
+ Mytest::hello();
+
+Now we run the script and we should see the following output:
+
+ % perl hello
+ Hello, world!
+ %
+
+=head2 EXAMPLE 2
+
+Now let's add to our extension a subroutine that will take a single argument
+and return 1 if the argument is even, 0 if the argument is odd.
+
+Add the following to the end of Mytest.xs:
+
+ int
+ is_even(input)
+ int input
+ CODE:
+ RETVAL = (input % 2 == 0);
+ OUTPUT:
+ RETVAL
+
+There does not need to be white space at the start of the "int input" line,
+but it is useful for improving readability. The semi-colon at the end of
+that line is also optional.
+
+Any white space may be between the "int" and "input". It is also okay for
+the four lines starting at the "CODE:" line to not be indented. However,
+for readability purposes, it is suggested that you indent them 8 spaces
+(or one normal tab stop).
+
+Now rerun make to rebuild our new shared library.
+
+Now perform the same steps as before, generating a Makefile from the
+Makefile.PL file, and running make.
+
+To test that our extension works, we now need to look at the
+file test.pl. This file is set up to imitate the same kind of testing
+structure that Perl itself has. Within the test script, you perform a
+number of tests to confirm the behavior of the extension, printing "ok"
+when the test is correct, "not ok" when it is not. Change the print
+statement in the BEGIN block to print "1..4", and add the following code
+to the end of the file:
+
+ print &Mytest::is_even(0) == 1 ? "ok 2" : "not ok 2", "\n";
+ print &Mytest::is_even(1) == 0 ? "ok 3" : "not ok 3", "\n";
+ print &Mytest::is_even(2) == 1 ? "ok 4" : "not ok 4", "\n";
+
+We will be calling the test script through the command "make test". You
+should see output that looks something like this:
+
+ % make test
+ PERL_DL_NONLAZY=1 /opt/perl5.002b2/bin/perl (lots of -I arguments) test.pl
+ 1..4
+ ok 1
+ ok 2
+ ok 3
+ ok 4
+ %
+
+=head2 WHAT HAS GONE ON?
+
+The program h2xs is the starting point for creating extensions. In later
+examples we'll see how we can use h2xs to read header files and generate
+templates to connect to C routines.
+
+h2xs creates a number of files in the extension directory. The file
+Makefile.PL is a perl script which will generate a true Makefile to build
+the extension. We'll take a closer look at it later.
+
+The files E<lt>extensionE<gt>.pm and E<lt>extensionE<gt>.xs contain the meat
+of the extension.
+The .xs file holds the C routines that make up the extension. The .pm file
+contains routines that tell Perl how to load your extension.
+
+Generating and invoking the Makefile created a directory blib (which stands
+for "build library") in the current working directory. This directory will
+contain the shared library that we will build. Once we have tested it, we
+can install it into its final location.
+
+Invoking the test script via "make test" did something very important. It
+invoked perl with all those C<-I> arguments so that it could find the various
+files that are part of the extension.
+
+It is I<very> important that while you are still testing extensions that
+you use "make test". If you try to run the test script all by itself, you
+will get a fatal error.
+
+Another reason it is important to use "make test" to run your test script
+is that if you are testing an upgrade to an already-existing version, using
+"make test" insures that you use your new extension, not the already-existing
+version.
+
+When Perl sees a C<use extension;>, it searches for a file with the same name
+as the use'd extension that has a .pm suffix. If that file cannot be found,
+Perl dies with a fatal error. The default search path is contained in the
+@INC array.
+
+In our case, Mytest.pm tells perl that it will need the Exporter and Dynamic
+Loader extensions. It then sets the @ISA and @EXPORT arrays and the $VERSION
+scalar; finally it tells perl to bootstrap the module. Perl will call its
+dynamic loader routine (if there is one) and load the shared library.
+
+The two arrays that are set in the .pm file are very important. The @ISA
+array contains a list of other packages in which to search for methods (or
+subroutines) that do not exist in the current package. The @EXPORT array
+tells Perl which of the extension's routines should be placed into the
+calling package's namespace.
+
+It's important to select what to export carefully. Do NOT export method names
+and do NOT export anything else I<by default> without a good reason.
+
+As a general rule, if the module is trying to be object-oriented then don't
+export anything. If it's just a collection of functions then you can export
+any of the functions via another array, called @EXPORT_OK.
+
+See L<perlmod> for more information.
+
+The $VERSION variable is used to ensure that the .pm file and the shared
+library are "in sync" with each other. Any time you make changes to
+the .pm or .xs files, you should increment the value of this variable.
+
+=head2 WRITING GOOD TEST SCRIPTS
+
+The importance of writing good test scripts cannot be overemphasized. You
+should closely follow the "ok/not ok" style that Perl itself uses, so that
+it is very easy and unambiguous to determine the outcome of each test case.
+When you find and fix a bug, make sure you add a test case for it.
+
+By running "make test", you ensure that your test.pl script runs and uses
+the correct version of your extension. If you have many test cases, you
+might want to copy Perl's test style. Create a directory named "t", and
+ensure all your test files end with the suffix ".t". The Makefile will
+properly run all these test files.
+
+
+=head2 EXAMPLE 3
+
+Our third extension will take one argument as its input, round off that
+value, and set the I<argument> to the rounded value.
+
+Add the following to the end of Mytest.xs:
+
+ void
+ round(arg)
+ double arg
+ CODE:
+ if (arg > 0.0) {
+ arg = floor(arg + 0.5);
+ } else if (arg < 0.0) {
+ arg = ceil(arg - 0.5);
+ } else {
+ arg = 0.0;
+ }
+ OUTPUT:
+ arg
+
+Edit the Makefile.PL file so that the corresponding line looks like this:
+
+ 'LIBS' => ['-lm'], # e.g., '-lm'
+
+Generate the Makefile and run make. Change the BEGIN block to print out
+"1..9" and add the following to test.pl:
+
+ $i = -1.5; &Mytest::round($i); print $i == -2.0 ? "ok 5" : "not ok 5", "\n";
+ $i = -1.1; &Mytest::round($i); print $i == -1.0 ? "ok 6" : "not ok 6", "\n";
+ $i = 0.0; &Mytest::round($i); print $i == 0.0 ? "ok 7" : "not ok 7", "\n";
+ $i = 0.5; &Mytest::round($i); print $i == 1.0 ? "ok 8" : "not ok 8", "\n";
+ $i = 1.2; &Mytest::round($i); print $i == 1.0 ? "ok 9" : "not ok 9", "\n";
+
+Running "make test" should now print out that all nine tests are okay.
+
+You might be wondering if you can round a constant. To see what happens, add
+the following line to test.pl temporarily:
+
+ &Mytest::round(3);
+
+Run "make test" and notice that Perl dies with a fatal error. Perl won't let
+you change the value of constants!
+
+=head2 WHAT'S NEW HERE?
+
+Two things are new here. First, we've made some changes to Makefile.PL.
+In this case, we've specified an extra library to link in, the math library
+libm. We'll talk later about how to write XSUBs that can call every routine
+in a library.
+
+Second, the value of the function is being passed back not as the function's
+return value, but through the same variable that was passed into the function.
+
+=head2 INPUT AND OUTPUT PARAMETERS
+
+You specify the parameters that will be passed into the XSUB just after you
+declare the function return value and name. Each parameter line starts with
+optional white space, and may have an optional terminating semicolon.
+
+The list of output parameters occurs after the OUTPUT: directive. The use
+of RETVAL tells Perl that you wish to send this value back as the return
+value of the XSUB function. In Example 3, the value we wanted returned was
+contained in the same variable we passed in, so we listed it (and not RETVAL)
+in the OUTPUT: section.
+
+=head2 THE XSUBPP COMPILER
+
+The compiler xsubpp takes the XS code in the .xs file and converts it into
+C code, placing it in a file whose suffix is .c. The C code created makes
+heavy use of the C functions within Perl.
+
+=head2 THE TYPEMAP FILE
+
+The xsubpp compiler uses rules to convert from Perl's data types (scalar,
+array, etc.) to C's data types (int, char *, etc.). These rules are stored
+in the typemap file ($PERLLIB/ExtUtils/typemap). This file is split into
+three parts.
+
+The first part attempts to map various C data types to a coded flag, which
+has some correspondence with the various Perl types. The second part contains
+C code which xsubpp uses for input parameters. The third part contains C
+code which xsubpp uses for output parameters. We'll talk more about the
+C code later.
+
+Let's now take a look at a portion of the .c file created for our extension.
+
+ XS(XS_Mytest_round)
+ {
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Mytest::round(arg)");
+ {
+ double arg = (double)SvNV(ST(0)); /* XXXXX */
+ if (arg > 0.0) {
+ arg = floor(arg + 0.5);
+ } else if (arg < 0.0) {
+ arg = ceil(arg - 0.5);
+ } else {
+ arg = 0.0;
+ }
+ sv_setnv(ST(0), (double)arg); /* XXXXX */
+ }
+ XSRETURN(1);
+ }
+
+Notice the two lines marked with "XXXXX". If you check the first section of
+the typemap file, you'll see that doubles are of type T_DOUBLE. In the
+INPUT section, an argument that is T_DOUBLE is assigned to the variable
+arg by calling the routine SvNV on something, then casting it to double,
+then assigned to the variable arg. Similarly, in the OUTPUT section,
+once arg has its final value, it is passed to the sv_setnv function to
+be passed back to the calling subroutine. These two functions are explained
+in L<perlguts>; we'll talk more later about what that "ST(0)" means in the
+section on the argument stack.
+
+=head2 WARNING
+
+In general, it's not a good idea to write extensions that modify their input
+parameters, as in Example 3. However, to accommodate better calling
+pre-existing C routines, which often do modify their input parameters,
+this behavior is tolerated. The next example will show how to do this.
+
+=head2 EXAMPLE 4
+
+In this example, we'll now begin to write XSUBs that will interact with
+predefined C libraries. To begin with, we will build a small library of
+our own, then let h2xs write our .pm and .xs files for us.
+
+Create a new directory called Mytest2 at the same level as the directory
+Mytest. In the Mytest2 directory, create another directory called mylib,
+and cd into that directory.
+
+Here we'll create some files that will generate a test library. These will
+include a C source file and a header file. We'll also create a Makefile.PL
+in this directory. Then we'll make sure that running make at the Mytest2
+level will automatically run this Makefile.PL file and the resulting Makefile.
+
+In the testlib directory, create a file mylib.h that looks like this:
+
+ #define TESTVAL 4
+
+ extern double foo(int, long, const char*);
+
+Also create a file mylib.c that looks like this:
+
+ #include <stdlib.h>
+ #include "./mylib.h"
+
+ double
+ foo(a, b, c)
+ int a;
+ long b;
+ const char * c;
+ {
+ return (a + b + atof(c) + TESTVAL);
+ }
+
+And finally create a file Makefile.PL that looks like this:
+
+ use ExtUtils::MakeMaker;
+ $Verbose = 1;
+ WriteMakefile(
+ NAME => 'Mytest2::mylib',
+ SKIP => [qw(all static static_lib dynamic dynamic_lib)],
+ clean => {'FILES' => 'libmylib$(LIB_EXT)'},
+ );
+
+
+ sub MY::top_targets {
+ '
+ all :: static
+
+ static :: libmylib$(LIB_EXT)
+
+ libmylib$(LIB_EXT): $(O_FILES)
+ $(AR) cr libmylib$(LIB_EXT) $(O_FILES)
+ $(RANLIB) libmylib$(LIB_EXT)
+
+ ';
+ }
+
+We will now create the main top-level Mytest2 files. Change to the directory
+above Mytest2 and run the following command:
+
+ % h2xs -O -n Mytest2 ./Mytest2/mylib/mylib.h
+
+This will print out a warning about overwriting Mytest2, but that's okay.
+Our files are stored in Mytest2/mylib, and will be untouched.
+
+The normal Makefile.PL that h2xs generates doesn't know about the mylib
+directory. We need to tell it that there is a subdirectory and that we
+will be generating a library in it. Let's add the following key-value
+pair to the WriteMakefile call:
+
+ 'MYEXTLIB' => 'mylib/libmylib$(LIB_EXT)',
+
+and a new replacement subroutine too:
+
+ sub MY::postamble {
+ '
+ $(MYEXTLIB): mylib/Makefile
+ cd mylib && $(MAKE) $(PASTHRU)
+ ';
+ }
+
+(Note: Most makes will require that there be a tab character that indents
+the line C<cd mylib && $(MAKE) $(PASTHRU)>, similarly for the Makefile in the
+subdirectory.)
+
+Let's also fix the MANIFEST file so that it accurately reflects the contents
+of our extension. The single line that says "mylib" should be replaced by
+the following three lines:
+
+ mylib/Makefile.PL
+ mylib/mylib.c
+ mylib/mylib.h
+
+To keep our namespace nice and unpolluted, edit the .pm file and change
+the lines setting @EXPORT to @EXPORT_OK (there are two: one in the line
+beginning "use vars" and one setting the array itself). Finally, in the
+.xs file, edit the #include line to read:
+
+ #include "mylib/mylib.h"
+
+And also add the following function definition to the end of the .xs file:
+
+ double
+ foo(a,b,c)
+ int a
+ long b
+ const char * c
+ OUTPUT:
+ RETVAL
+
+Now we also need to create a typemap file because the default Perl doesn't
+currently support the const char * type. Create a file called typemap and
+place the following in it:
+
+ const char * T_PV
+
+Now run perl on the top-level Makefile.PL. Notice that it also created a
+Makefile in the mylib directory. Run make and see that it does cd into
+the mylib directory and run make in there as well.
+
+Now edit the test.pl script and change the BEGIN block to print "1..4",
+and add the following lines to the end of the script:
+
+ print &Mytest2::foo(1, 2, "Hello, world!") == 7 ? "ok 2\n" : "not ok 2\n";
+ print &Mytest2::foo(1, 2, "0.0") == 7 ? "ok 3\n" : "not ok 3\n";
+ print abs(&Mytest2::foo(0, 0, "-3.4") - 0.6) <= 0.01 ? "ok 4\n" : "not ok 4\n";
+
+(When dealing with floating-point comparisons, it is often useful not to check
+for equality, but rather the difference being below a certain epsilon factor,
+0.01 in this case)
+
+Run "make test" and all should be well.
+
+=head2 WHAT HAS HAPPENED HERE?
+
+Unlike previous examples, we've now run h2xs on a real include file. This
+has caused some extra goodies to appear in both the .pm and .xs files.
+
+=over 4
+
+=item *
+
+In the .xs file, there's now a #include declaration with the full path to
+the mylib.h header file.
+
+=item *
+
+There's now some new C code that's been added to the .xs file. The purpose
+of the C<constant> routine is to make the values that are #define'd in the
+header file available to the Perl script (in this case, by calling
+C<&main::TESTVAL>). There's also some XS code to allow calls to the
+C<constant> routine.
+
+=item *
+
+The .pm file has exported the name TESTVAL in the @EXPORT array. This
+could lead to name clashes. A good rule of thumb is that if the #define
+is going to be used by only the C routines themselves, and not by the user,
+they should be removed from the @EXPORT array. Alternately, if you don't
+mind using the "fully qualified name" of a variable, you could remove most
+or all of the items in the @EXPORT array.
+
+=item *
+
+If our include file contained #include directives, these would not be
+processed at all by h2xs. There is no good solution to this right now.
+
+=back
+
+We've also told Perl about the library that we built in the mylib
+subdirectory. That required the addition of only the MYEXTLIB variable
+to the WriteMakefile call and the replacement of the postamble subroutine
+to cd into the subdirectory and run make. The Makefile.PL for the
+library is a bit more complicated, but not excessively so. Again we
+replaced the postamble subroutine to insert our own code. This code
+specified simply that the library to be created here was a static
+archive (as opposed to a dynamically loadable library) and provided the
+commands to build it.
+
+=head2 SPECIFYING ARGUMENTS TO XSUBPP
+
+With the completion of Example 4, we now have an easy way to simulate some
+real-life libraries whose interfaces may not be the cleanest in the world.
+We shall now continue with a discussion of the arguments passed to the
+xsubpp compiler.
+
+When you specify arguments in the .xs file, you are really passing three
+pieces of information for each one listed. The first piece is the order
+of that argument relative to the others (first, second, etc). The second
+is the type of argument, and consists of the type declaration of the
+argument (e.g., int, char*, etc). The third piece is the exact way in
+which the argument should be used in the call to the library function
+from this XSUB. This would mean whether or not to place a "&" before
+the argument or not, meaning the argument expects to be passed the address
+of the specified data type.
+
+There is a difference between the two arguments in this hypothetical function:
+
+ int
+ foo(a,b)
+ char &a
+ char * b
+
+The first argument to this function would be treated as a char and assigned
+to the variable a, and its address would be passed into the function foo.
+The second argument would be treated as a string pointer and assigned to the
+variable b. The I<value> of b would be passed into the function foo. The
+actual call to the function foo that xsubpp generates would look like this:
+
+ foo(&a, b);
+
+Xsubpp will identically parse the following function argument lists:
+
+ char &a
+ char&a
+ char & a
+
+However, to help ease understanding, it is suggested that you place a "&"
+next to the variable name and away from the variable type), and place a
+"*" near the variable type, but away from the variable name (as in the
+complete example above). By doing so, it is easy to understand exactly
+what will be passed to the C function -- it will be whatever is in the
+"last column".
+
+You should take great pains to try to pass the function the type of variable
+it wants, when possible. It will save you a lot of trouble in the long run.
+
+=head2 THE ARGUMENT STACK
+
+If we look at any of the C code generated by any of the examples except
+example 1, you will notice a number of references to ST(n), where n is
+usually 0. The "ST" is actually a macro that points to the n'th argument
+on the argument stack. ST(0) is thus the first argument passed to the
+XSUB, ST(1) is the second argument, and so on.
+
+When you list the arguments to the XSUB in the .xs file, that tells xsubpp
+which argument corresponds to which of the argument stack (i.e., the first
+one listed is the first argument, and so on). You invite disaster if you
+do not list them in the same order as the function expects them.
+
+=head2 EXTENDING YOUR EXTENSION
+
+Sometimes you might want to provide some extra methods or subroutines
+to assist in making the interface between Perl and your extension simpler
+or easier to understand. These routines should live in the .pm file.
+Whether they are automatically loaded when the extension itself is loaded
+or loaded only when called depends on where in the .pm file the subroutine
+definition is placed.
+
+=head2 DOCUMENTING YOUR EXTENSION
+
+There is absolutely no excuse for not documenting your extension.
+Documentation belongs in the .pm file. This file will be fed to pod2man,
+and the embedded documentation will be converted to the manpage format,
+then placed in the blib directory. It will be copied to Perl's man
+page directory when the extension is installed.
+
+You may intersperse documentation and Perl code within the .pm file.
+In fact, if you want to use method autoloading, you must do this,
+as the comment inside the .pm file explains.
+
+See L<perlpod> for more information about the pod format.
+
+=head2 INSTALLING YOUR EXTENSION
+
+Once your extension is complete and passes all its tests, installing it
+is quite simple: you simply run "make install". You will either need
+to have write permission into the directories where Perl is installed,
+or ask your system administrator to run the make for you.
+
+=head2 SEE ALSO
+
+For more information, consult L<perlguts>, L<perlxs>, L<perlmod>,
+and L<perlpod>.
+
+=head2 Author
+
+Jeff Okamoto <F<okamoto@corp.hp.com>>
+
+Reviewed and assisted by Dean Roehrich, Ilya Zakharevich, Andreas Koenig,
+and Tim Bunce.
+
+=head2 Last Changed
+
+1996/7/10
diff --git a/contrib/perl5/pod/pod2html.PL b/contrib/perl5/pod/pod2html.PL
new file mode 100644
index 000000000000..4eec29c26bda
--- /dev/null
+++ b/contrib/perl5/pod/pod2html.PL
@@ -0,0 +1,183 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+=pod
+
+=head1 NAME
+
+pod2html - convert .pod files to .html files
+
+=head1 SYNOPSIS
+
+ pod2html --help --htmlroot=<name> --infile=<name> --outfile=<name>
+ --podpath=<name>:...:<name> --podroot=<name>
+ --libpods=<name>:...:<name> --recurse --norecurse --verbose
+ --index --noindex --title=<name>
+
+=head1 DESCRIPTION
+
+Converts files from pod format (see L<perlpod>) to HTML format.
+
+=head1 ARGUMENTS
+
+pod2html takes the following arguments:
+
+=over 4
+
+=item help
+
+ --help
+
+Displays the usage message.
+
+=item htmlroot
+
+ --htmlroot=name
+
+Sets the base URL for the HTML files. When cross-references are made,
+the HTML root is prepended to the URL.
+
+=item infile
+
+ --infile=name
+
+Specify the pod file to convert. Input is taken from STDIN if no
+infile is specified.
+
+=item outfile
+
+ --outfile=name
+
+Specify the HTML file to create. Output goes to STDOUT if no outfile
+is specified.
+
+=item podroot
+
+ --podroot=name
+
+Specify the base directory for finding library pods.
+
+=item podpath
+
+ --podpath=name:...:name
+
+Specify which subdirectories of the podroot contain pod files whose
+HTML converted forms can be linked-to in cross-references.
+
+=item libpods
+
+ --libpods=name:...:name
+
+List of page names (eg, "perlfunc") which contain linkable C<=item>s.
+
+=item netscape
+
+ --netscape
+
+Use Netscape HTML directives when applicable.
+
+=item nonetscape
+
+ --nonetscape
+
+Do not use Netscape HTML directives (default).
+
+=item index
+
+ --index
+
+Generate an index at the top of the HTML file (default behaviour).
+
+=item noindex
+
+ --noindex
+
+Do not generate an index at the top of the HTML file.
+
+
+=item recurse
+
+ --recurse
+
+Recurse into subdirectories specified in podpath (default behaviour).
+
+=item norecurse
+
+ --norecurse
+
+Do not recurse into subdirectories specified in podpath.
+
+=item title
+
+ --title=title
+
+Specify the title of the resulting HTML file.
+
+=item verbose
+
+ --verbose
+
+Display progress messages.
+
+=back
+
+=head1 AUTHOR
+
+Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
+
+=head1 BUGS
+
+See L<Pod::Html> for a list of known bugs in the translator.
+
+=head1 SEE ALSO
+
+L<perlpod>, L<Pod::HTML>
+
+=head1 COPYRIGHT
+
+This program is distributed under the Artistic License.
+
+=cut
+
+use Pod::Html;
+
+pod2html @ARGV;
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/pod/pod2latex.PL b/contrib/perl5/pod/pod2latex.PL
new file mode 100644
index 000000000000..feed98e923d9
--- /dev/null
+++ b/contrib/perl5/pod/pod2latex.PL
@@ -0,0 +1,708 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+#
+# pod2latex, version 1.1
+# by Taro Kawagish (kawagish@imslab.co.jp), Jan 11, 1995.
+#
+# pod2latex filters Perl pod documents to LaTeX documents.
+#
+# What pod2latex does:
+# 1. Pod file 'perl_doc_entry.pod' is filtered to 'perl_doc_entry.tex'.
+# 2. Indented paragraphs are translated into
+# '\begin{verbatim} ... \end{verbatim}'.
+# 3. '=head1 heading' command is translated into '\section{heading}'
+# 4. '=head2 heading' command is translated into '\subsection*{heading}'
+# 5. '=over N' command is translated into
+# '\begin{itemize}' if following =item starts with *,
+# '\begin{enumerate}' if following =item starts with 1.,
+# '\begin{description}' if else.
+# (indentation level N is ignored.)
+# 6. '=item * heading' command is translated into '\item heading',
+# '=item 1. heading' command is translated into '\item heading',
+# '=item heading' command(other) is translated into '\item[heading]'.
+# 7. '=back' command is translated into
+# '\end{itemize}' if started with '\begin{itemize}',
+# '\end{enumerate}' if started with '\begin{enumerate}',
+# '\end{description}' if started with '\begin{description}'.
+# 8. other paragraphs are translated into strings with TeX special characters
+# escaped.
+# 9. In heading text, and other paragraphs, the following translation of pod
+# quotes are done, and then TeX special characters are escaped after that.
+# I<text> to {\em text\/},
+# B<text> to {\bf text},
+# S<text> to text1,
+# where text1 is a string with blank characters replaced with ~,
+# C<text> to {\tt text2},
+# where text2 is a string with TeX special characters escaped to
+# obtain a literal printout,
+# E<text> (HTML escape) to TeX escaped string,
+# L<text> to referencing string as is done by pod2man,
+# F<file> to {\em file\/},
+# Z<> to a null string,
+# 10. those headings are indexed:
+# '=head1 heading' => \section{heading}\index{heading}
+# '=head2 heading' => \subsection*{heading}\index{heading}
+# only when heading does not match frequent patterns such as
+# DESCRIPTION, DIAGNOSTICS,...
+# '=item heading' => \item{heading}\index{heading}
+#
+# Usage:
+# pod2latex perl_doc_entry.pod
+# this will write to a file 'perl_doc_entry.tex'.
+#
+# To LaTeX:
+# The following commands need to be defined in the preamble of the LaTeX
+# document:
+# \def\C++{{\rm C\kern-.05em\raise.3ex\hbox{\footnotesize ++}}}
+# \def\underscore{\leavevmode\kern.04em\vbox{\hrule width 0.4em height 0.3pt}}
+# and \parindent should be set zero:
+# \setlength{\parindent}{0pt}
+#
+# Note:
+# This script was written modifing pod2man.
+#
+# Bug:
+# If HTML escapes E<text> other than E<amp>,E<lt>,E<gt>,E<quot> are used
+# in C<>, translation will produce wrong character strings.
+# Translation of HTML escapes of various European accents might be wrong.
+
+
+$/ = ""; # record separator is blank lines
+# TeX special characters.
+##$tt_ables = "!@*()-=+|;:'\"`,./?<>";
+$backslash_escapables = "#\$%&{}_";
+$backslash_escapables2 = "#\$%&{}"; # except _
+##$nonverbables = "^\\~";
+##$bracketesc = "[]";
+##@tex_verb_fences = unpack("aaaaaaaaa","|#@!*+?:;");
+
+@head1_freq_patterns # =head1 patterns which need not be index'ed
+ = ("AUTHOR","Author","BUGS","DATE","DESCRIPTION","DIAGNOSTICS",
+ "ENVIRONMENT","EXAMPLES","FILES","INTRODUCTION","NAME","NOTE",
+ "SEE ALSO","SYNOPSIS","WARNING");
+
+$indent = 0;
+
+# parse the pods, produce LaTeX.
+
+open(POD,"<$ARGV[0]") || die "cant open $ARGV[0]";
+($pod=$ARGV[0]) =~ s/\.pod$//;
+open(LATEX,">$pod.tex");
+&do_hdr();
+
+$cutting = 1;
+$begun = "";
+while (<POD>) {
+ if ($cutting) {
+ next unless /^=/;
+ $cutting = 0;
+ }
+ if ($begun) {
+ if (/^=end\s+$begun/) {
+ $begun = "";
+ }
+ elsif ($begun =~ /^(tex|latex)$/) {
+ print LATEX $_;
+ }
+ next;
+ }
+ chop;
+ length || (print LATEX "\n") && next;
+
+ # translate indented lines as a verabatim paragraph
+ if (/^\s/) {
+ @lines = split(/\n/);
+ print LATEX "\\begin{verbatim}\n";
+ for (@lines) {
+ 1 while s
+ {^( [^\t]* ) \t ( \t* ) }
+ { $1 . ' ' x (8 - (length($1)%8) + 8*(length($2))) }ex;
+ print LATEX $_,"\n";
+ }
+ print LATEX "\\end{verbatim}\n";
+ next;
+ }
+
+ if (/^=for\s+(\S+)\s*/s) {
+ if ($1 eq "tex" or $1 eq "latex") {
+ print LATEX $',"\n";
+ } else {
+ # ignore unknown for
+ }
+ next;
+ }
+ elsif (/^=begin\s+(\S+)\s*/s) {
+ $begun = $1;
+ if ($1 eq "tex" or $1 eq "latex") {
+ print LATEX $'."\n";
+ }
+ next;
+ }
+
+ # preserve '=item' line with pod quotes as they are.
+ if (/^=item/) {
+ ($bareitem = $_) =~ s/^=item\s*//;
+ }
+
+ # check for things that'll hosed our noremap scheme; affects $_
+ &init_noremap();
+
+ # expand strings "func()" as pod quotes.
+ if (!/^=item/) {
+ # first hide pod escapes.
+ # escaped strings are mapped into the ones with the MSB's on.
+ s/([A-Z]<[^<>]*>)/noremap($1)/ge;
+
+ # func() is a reference to a perl function
+ s{\b([:\w]+\(\))}{I<$1>}g;
+ # func(n) is a reference to a man page
+ s{(\w+)(\([^\s,\051]+\))}{I<$1>$2}g;
+ # convert simple variable references
+# s/([\$\@%][\w:]+)/C<$1>/g;
+# s/\$[\w:]+\[[0-9]+\]/C<$&>/g;
+
+ if (m{ ([\-\w]+\([^\051]*?[\@\$,][^\051]*?\))
+ }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/)
+ {
+ warn "``$1'' should be a [LCI]<$1> ref";
+ }
+ while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) {
+ warn "``$1'' should be [CB]<$1> ref";
+ }
+
+ # put back pod quotes so we get the inside of <> processed;
+ $_ = &clear_noremap($_);
+ }
+
+
+ # process TeX special characters
+
+ # First hide HTML quotes E<> since they can be included in C<>.
+ s/(E<[^<>]+>)/noremap($1)/ge;
+
+ # Then hide C<> type literal quotes.
+ # String inside of C<> will later be expanded into {\tt ..} strings
+ # with TeX special characters escaped as needed.
+ s/(C<[^<>]*>)/&noremap($1)/ge;
+
+ # Next escape TeX special characters including other pod quotes B< >,...
+ #
+ # NOTE: s/re/&func($str)/e evaluates $str just once in perl5.
+ # (in perl4 evaluation takes place twice before getting passed to func().)
+
+ # - hyphen => ---
+ s/(\S+)(\s+)-+(\s+)(\S+)/"$1".&noremap(" --- ")."$4"/ge;
+ # '-', '--', "-" => '{\tt -}', '{\tt --}', "{\tt -}"
+## s/("|')(\s*)(-+)(\s*)\1/&noremap("$1$2\{\\tt $3\}$4$1")/ge;
+## changed Wed Jan 25 15:26:39 JST 1995
+ # '-', '--', "-" => '$-$', '$--$', "$-$"
+ s/(\s+)(['"])(-+)([^'"\-]*)\2(\s+|[,.])/"$1$2".&noremap("\$$3\$")."$4$2$5"/ge;
+ s/(\s+)(['"])([^'"\-]*)(-+)(\s*)\2(\s+|[,.])/"$1$2$3".&noremap("\$$4\$")."$5$2$6"/ge;
+ # (--|-) => ($--$|$-$)
+ s/(\s+)\((-+)([=@%\$\+\\\|\w]*)(-*)([=@%\$\+\\\|\w]*)\)(\s+|[,.])/"$1\(".&noremap("\$$2\$")."$3".&noremap("\$$4\$")."$5\)$6"/ge;
+ # numeral - => $-$
+ s/(\(|[0-9]+|\s+)-(\s*\(?\s*[0-9]+)/&noremap("$1\$-\$$2")/ge;
+ # -- in quotes => two separate -
+ s/B<([^<>]*)--([^<>]*)>/&noremap("B<$1\{\\tt --\}$2>")/ge;
+
+ # backslash escapable characters except _.
+ s/([$backslash_escapables2])/&noremap("\\$1")/ge;
+ s/_/&noremap("\\underscore{}")/ge; # a litle thicker than \_.
+ # quote TeX special characters |, ^, ~, \.
+ s/\|/&noremap("\$|\$")/ge;
+ s/\^/&noremap("\$\\hat{\\hspace{0.4em}}\$")/ge;
+ s/\~/&noremap("\$\\tilde{\\hspace{0.4em}}\$")/ge;
+ s/\\/&noremap("\$\\backslash{}\$")/ge;
+ # quote [ and ] to be used in \item[]
+ s/([\[\]])/&noremap("{\\tt $1}")/ge;
+ # characters need to be treated differently in TeX
+ # keep * if an item heading
+ s/^(=item[ \t]+)[*]((.|\n)*)/"$1" . &noremap("*") . "$2"/ge;
+ s/[*]/&noremap("\$\\ast\$")/ge; # other *
+
+ # hide other pod quotes.
+ s/([ABD-Z]<[^<>]*>)/&noremap($1)/ge;
+
+ # escape < and > as math strings,
+ # now that we are done with hiding pod <> quotes.
+ s/</&noremap("\$<\$")/ge;
+ s/>/&noremap("\$>\$")/ge;
+
+ # put it back so we get the <> processed again;
+ $_ = &clear_noremap($_);
+
+
+ # Expand pod quotes recursively:
+ # (1) type face directives [BIFS]<[^<>]*> to appropriate TeX commands,
+ # (2) L<[^<>]*> to reference strings,
+ # (3) C<[^<>]*> to TeX literal quotes,
+ # (4) HTML quotes E<> inside of C<> quotes.
+
+ # Hide E<> again since they can be included in C<>.
+ s/(E<[^<>]+>)/noremap($1)/ge;
+
+ $maxnest = 10;
+ while ($maxnest-- && /[A-Z]</) {
+
+ # bold and italic quotes
+ s/B<([^<>]*)>/"{\\bf $1}"/eg;
+ s#I<([^<>]*)>#"{\\em $1\\/}"#eg;
+
+ # files and filelike refs in italics
+ s#F<([^<>]*)>#"{\\em $1\\/}"#eg;
+
+ # no break quote -- usually we want C<> for this
+ s/S<([^<>]*)>/&nobreak($1)/eg;
+
+ # LREF: a manpage(3f)
+ s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the {\\em $1\\/}$2 manpage:g;
+
+ # LREF: an =item on another manpage
+ s{
+ L<([^/]+)/([:\w]+(\(\))?)>
+ } {the C<$2> entry in the I<$1> manpage}gx;
+
+ # LREF: an =item on this manpage
+ s{
+ ((?:L</([:\w]+(\(\))?)>
+ (,?\s+(and\s+)?)?)+)
+ } { &internal_lrefs($1) }gex;
+
+ # LREF: a =head2 (head1?), maybe on a manpage, maybe right here
+ # the "func" can disambiguate
+ s{
+ L<(?:([a-zA-Z]\S+?) /)?"?(.*?)"?>
+ }{
+ do {
+ $1 # if no $1, assume it means on this page.
+ ? "the section on I<$2> in the I<$1> manpage"
+ : "the section on I<$2>"
+ }
+ }gex;
+
+ s/Z<>/\\&/g; # the "don't format me" thing
+
+ # comes last because not subject to reprocessing
+ s{
+ C<([^<>]*)>
+ }{
+ do {
+ ($str = $1) =~ tr/\200-\377/\000-\177/; #normalize hidden stuff
+ # expand HTML escapes if any;
+ # WARNING: if HTML escapes other than E<amp>,E<lt>,E<gt>,
+ # E<quot> are in C<>, they will not be printed correctly.
+ $str = &expand_HTML_escapes($str);
+ $strverb = &alltt($str); # Tex verbatim escape of a string.
+ &noremap("$strverb");
+ }
+ }gex;
+
+# if ( /C<([^<>]*)/ ) {
+# $str = $1;
+# if ($str !~ /\|/) { # if includes |
+# s/C<([^<>]*)>/&noremap("\\verb|$str|")/eg;
+# } else {
+# print STDERR "found \| in C<.*> at paragraph $.\n";
+# # find a character not contained in $str to use it as a
+# # separator of the \verb
+# ($chars = $str) =~ s/(\W)/\\$1/g;
+# ## ($chars = $str) =~ s/([\$<>,\|"'\-^{}()*+?\\])/\\$1/g;
+# @fence = grep(!/[ $chars]/,@tex_verb_fences);
+# s/C<([^<>]*)>/&noremap("\\verb$fence[0]$str$fence[0]")/eg;
+# }
+# }
+ }
+
+
+ # process each pod command
+ if (s/^=//) { # if a command
+ s/\n/ /g;
+ ($cmd, $rest) = split(' ', $_, 2);
+ $rest =~ s/^\s*//;
+ $rest =~ s/\s*$//;
+
+ if (defined $rest) {
+ &escapes;
+ }
+
+ $rest = &clear_noremap($rest);
+ $rest = &expand_HTML_escapes($rest);
+
+ if ($cmd eq 'cut') {
+ $cutting = 1;
+ $lastcmd = 'cut';
+ }
+ elsif ($cmd eq 'head1') { # heading type 1
+ $rest =~ s/^\s*//; $rest =~ s/\s*$//;
+ print LATEX "\n\\subsection*{$rest}";
+ # put index entry
+ ($index = $rest) =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The'
+ # index only those heads not matching the frequent patterns.
+ foreach $pat (@head1_freq_patterns) {
+ if ($index =~ /^$pat/) {
+ goto freqpatt;
+ }
+ }
+ print LATEX "%\n\\index{$index}\n" if ($index);
+ freqpatt:
+ $lastcmd = 'head1';
+ }
+ elsif ($cmd eq 'head2') { # heading type 2
+ $rest =~ s/^\s*//; $rest =~ s/\s*$//;
+ print LATEX "\n\\subsubsection*{$rest}";
+ # put index entry
+ ($index = $rest) =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The'
+ $index =~ s/^Example\s*[1-9][0-9]*\s*:\s*//; # remove 'Example :'
+ print LATEX "%\n\\index{$index}\n" if ($index);
+ $lastcmd = 'head2';
+ }
+ elsif ($cmd eq 'over') { # 1 level within a listing environment
+ push(@indent,$indent);
+ $indent = $rest + 0;
+ $lastcmd = 'over';
+ }
+ elsif ($cmd eq 'back') { # 1 level out of a listing environment
+ $indent = pop(@indent);
+ warn "Unmatched =back\n" unless defined $indent;
+ $listingcmd = pop(@listingcmd);
+ print LATEX "\n\\end{$listingcmd}\n" if ($listingcmd);
+ $lastcmd = 'back';
+ }
+ elsif ($cmd eq 'item') { # an item paragraph starts
+ if ($lastcmd eq 'over') { # if we have just entered listing env
+ # see what type of list environment we are in.
+ if ($rest =~ /^[0-9]\.?/) { # if numeral heading
+ $listingcmd = 'enumerate';
+ } elsif ($rest =~ /^\*\s*/) { # if * heading
+ $listingcmd = 'itemize';
+ } elsif ($rest =~ /^[^*]/) { # if other headings
+ $listingcmd = 'description';
+ } else {
+ warn "unknown list type for item $rest";
+ }
+ print LATEX "\n\\begin{$listingcmd}\n";
+ push(@listingcmd,$listingcmd);
+ } elsif ($lastcmd ne 'item') {
+ warn "Illegal '=item' command without preceding 'over':";
+ warn "=item $bareitem";
+ }
+
+ if ($listingcmd eq 'enumerate') {
+ $rest =~ s/^[0-9]+\.?\s*//; # remove numeral heading
+ print LATEX "\n\\item";
+ print LATEX "{\\bf $rest}" if $rest;
+ } elsif ($listingcmd eq 'itemize') {
+ $rest =~ s/^\*\s*//; # remove * heading
+ print LATEX "\n\\item";
+ print LATEX "{\\bf $rest}" if $rest;
+ } else { # description item
+ print LATEX "\n\\item[$rest]";
+ }
+ $lastcmd = 'item';
+ $rightafter_item = 'yes';
+
+ # check if the item heading is short or long.
+ ($itemhead = $rest) =~ s/{\\bf (\S*)}/$1/g;
+ if (length($itemhead) < 4) {
+ $itemshort = "yes";
+ } else {
+ $itemshort = "no";
+ }
+ # write index entry
+ if ($pod =~ "perldiag") { # skip 'perldiag.pod'
+ goto noindex;
+ }
+ # strip out the item of pod quotes and get a plain text entry
+ $bareitem =~ s/\n/ /g; # remove newlines
+ $bareitem =~ s/\s*$//; # remove trailing space
+ $bareitem =~ s/[A-Z]<([^<>]*)>/$1/g; # remove <> quotes
+ ($index = $bareitem) =~ s/^\*\s+//; # remove leading '*'
+ $index =~ s/^(An?\s+|The\s+)//i; # remove 'A' and 'The'
+ $index =~ s/^\s*[1-9][0-9]*\s*[.]\s*$//; # remove numeral only
+ $index =~ s/^\s*\w\s*$//; # remove 1 char only's
+ # quote ", @ and ! with " to be used in makeindex.
+ $index =~ s/"/""/g; # quote "
+ $index =~ s/@/"@/g; # quote @
+ $index =~ s/!/"!/g; # quote !
+ ($rest2=$rest) =~ s/^\*\s+//; # remove *
+ $rest2 =~ s/"/""/g; # quote "
+ $rest2 =~ s/@/"@/g; # quote @
+ $rest2 =~ s/!/"!/g; # quote !
+ if ($pod =~ "(perlfunc|perlvar)") { # when doc is perlfunc,perlvar
+ # take only the 1st word of item heading
+ $index =~ s/^([^{}\s]*)({.*})?([^{}\s]*)\s+.*/\1\2\3/;
+ $rest2 =~ s/^([^{}\s]*)({.*})?([^{}\s]*)\s+.*/\1\2\3/;
+ }
+ if ($index =~ /[A-Za-z\$@%]/) {
+ # write \index{plain_text_entry@TeX_string_entry}
+ print LATEX "%\n\\index{$index\@$rest2}%\n";
+ }
+ noindex:
+ ;
+ }
+ elsif ($cmd eq 'pod') {
+ ; # recognise the pod directive, as no op (hs)
+ }
+ elsif ($cmd eq 'pod') {
+ ; # recognise the pod directive, as no op (hs)
+ }
+ else {
+ warn "Unrecognized directive: $cmd\n";
+ }
+ }
+ else { # if not command
+ &escapes;
+ $_ = &clear_noremap($_);
+ $_ = &expand_HTML_escapes($_);
+
+ # if the present paragraphs follows an =item declaration,
+ # put a line break.
+ if ($lastcmd eq 'item' &&
+ $rightafter_item eq 'yes' && $itemshort eq "no") {
+ print LATEX "\\hfil\\\\";
+ $rightafter_item = 'no';
+ }
+ print LATEX "\n",$_;
+ }
+}
+
+print LATEX "\n";
+close(POD);
+close(LATEX);
+
+
+#########################################################################
+
+sub do_hdr {
+ print LATEX "% LaTeX document produced by pod2latex from \"$pod.pod\".\n";
+ print LATEX "% The followings need be defined in the preamble of this document:\n";
+ print LATEX "%\\def\\C++{{\\rm C\\kern-.05em\\raise.3ex\\hbox{\\footnotesize ++}}}\n";
+ print LATEX "%\\def\\underscore{\\leavevmode\\kern.04em\\vbox{\\hrule width 0.4em height 0.3pt}}\n";
+ print LATEX "%\\setlength{\\parindent}{0pt}\n";
+ print LATEX "\n";
+ $podq = &escape_tex_specials("\U$pod\E");
+ print LATEX "\\section{$podq}%\n";
+ print LATEX "\\index{$podq}";
+ print LATEX "\n";
+}
+
+sub nobreak {
+ my $string = shift;
+ $string =~ s/ +/~/g; # TeX no line break
+ $string;
+}
+
+sub noremap {
+ local($thing_to_hide) = shift;
+ $thing_to_hide =~ tr/\000-\177/\200-\377/;
+ return $thing_to_hide;
+}
+
+sub init_noremap {
+ # escape high bit characters in input stream
+ s/([\200-\377])/"E<".ord($1).">"/ge;
+}
+
+sub clear_noremap {
+ local($tmp) = shift;
+ $tmp =~ tr/\200-\377/\000-\177/;
+ return $tmp;
+}
+
+sub expand_HTML_escapes {
+ local($s) = $_[0];
+ $s =~ s { E<((\d+)|([A-Za-z]+))> }
+ {
+ do {
+ defined($2)
+ ? do { chr($2) }
+ :
+ exists $HTML_Escapes{$3}
+ ? do { $HTML_Escapes{$3} }
+ : do {
+ warn "Unknown escape: $& in $_";
+ "E<$1>";
+ }
+ }
+ }egx;
+ return $s;
+}
+
+sub escapes {
+ # make C++ into \C++, which is to be defined as
+ # \def\C++{{\rm C\kern-.05em\raise.3ex\hbox{\footnotesize ++}}}
+ s/\bC\+\+/\\C++{}/g;
+}
+
+# Translate a string into a TeX \tt string to obtain a verbatim print out.
+# TeX special characters are escaped by \.
+# This can be used inside of LaTeX command arguments.
+# We don't use LaTeX \verb since it doesn't work inside of command arguments.
+sub alltt {
+ local($str) = shift;
+ # other chars than #,\,$,%,&,{,},_,\,^,~ ([ and ] included).
+ $str =~ s/([^${backslash_escapables}\\\^\~]+)/&noremap("$&")/eg;
+ # chars #,\,$,%,&,{,} => \# , ...
+ $str =~ s/([$backslash_escapables2])/&noremap("\\$&")/eg;
+ # chars _,\,^,~ => \char`\_ , ...
+ $str =~ s/_/&noremap("\\char`\\_")/eg;
+ $str =~ s/\\/&noremap("\\char`\\\\")/ge;
+ $str =~ s/\^/\\char`\\^/g;
+ $str =~ s/\~/\\char`\\~/g;
+
+ $str =~ tr/\200-\377/\000-\177/; # put back
+ $str = "{\\tt ".$str."}"; # make it a \tt string
+ return $str;
+}
+
+sub escape_tex_specials {
+ local($str) = shift;
+ # other chars than #,\,$,%,&,{,}, _,\,^,~ ([ and ] included).
+ # backslash escapable characters #,\,$,%,&,{,} except _.
+ $str =~ s/([$backslash_escapables2])/&noremap("\\$1")/ge;
+ $str =~ s/_/&noremap("\\underscore{}")/ge; # \_ is too thin.
+ # quote TeX special characters |, ^, ~, \.
+ $str =~ s/\|/&noremap("\$|\$")/ge;
+ $str =~ s/\^/&noremap("\$\\hat{\\hspace{0.4em}}\$")/ge;
+ $str =~ s/\~/&noremap("\$\\tilde{\\hspace{0.4em}}\$")/ge;
+ $str =~ s/\\/&noremap("\$\\backslash{}\$")/ge;
+ # characters need to be treated differently in TeX
+ # *
+ $str =~ s/[*]/&noremap("\$\\ast\$")/ge;
+ # escape < and > as math string,
+ $str =~ s/</&noremap("\$<\$")/ge;
+ $str =~ s/>/&noremap("\$>\$")/ge;
+ $str =~ tr/\200-\377/\000-\177/; # put back
+ return $str;
+}
+
+sub internal_lrefs {
+ local($_) = shift;
+
+ s{L</([^>]+)>}{$1}g;
+ my(@items) = split( /(?:,?\s+(?:and\s+)?)/ );
+ my $retstr = "the ";
+ my $i;
+ for ($i = 0; $i <= $#items; $i++) {
+ $retstr .= "C<$items[$i]>";
+ $retstr .= ", " if @items > 2 && $i != $#items;
+ $retstr .= " and " if $i+2 == @items;
+ }
+ $retstr .= " entr" . ( @items > 1 ? "ies" : "y" )
+ . " elsewhere in this document";
+
+ return $retstr;
+}
+
+# map of HTML escapes to TeX escapes.
+BEGIN {
+%HTML_Escapes = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "\\'{A}", # capital A, acute accent
+ "aacute" => "\\'{a}", # small a, acute accent
+ "Acirc" => "\\^{A}", # capital A, circumflex accent
+ "acirc" => "\\^{a}", # small a, circumflex accent
+ "AElig" => '\\AE', # capital AE diphthong (ligature)
+ "aelig" => '\\ae', # small ae diphthong (ligature)
+ "Agrave" => "\\`{A}", # capital A, grave accent
+ "agrave" => "\\`{a}", # small a, grave accent
+ "Aring" => '\\u{A}', # capital A, ring
+ "aring" => '\\u{a}', # small a, ring
+ "Atilde" => '\\~{A}', # capital A, tilde
+ "atilde" => '\\~{a}', # small a, tilde
+ "Auml" => '\\"{A}', # capital A, dieresis or umlaut mark
+ "auml" => '\\"{a}', # small a, dieresis or umlaut mark
+ "Ccedil" => '\\c{C}', # capital C, cedilla
+ "ccedil" => '\\c{c}', # small c, cedilla
+ "Eacute" => "\\'{E}", # capital E, acute accent
+ "eacute" => "\\'{e}", # small e, acute accent
+ "Ecirc" => "\\^{E}", # capital E, circumflex accent
+ "ecirc" => "\\^{e}", # small e, circumflex accent
+ "Egrave" => "\\`{E}", # capital E, grave accent
+ "egrave" => "\\`{e}", # small e, grave accent
+ "ETH" => '\\OE', # capital Eth, Icelandic
+ "eth" => '\\oe', # small eth, Icelandic
+ "Euml" => '\\"{E}', # capital E, dieresis or umlaut mark
+ "euml" => '\\"{e}', # small e, dieresis or umlaut mark
+ "Iacute" => "\\'{I}", # capital I, acute accent
+ "iacute" => "\\'{i}", # small i, acute accent
+ "Icirc" => "\\^{I}", # capital I, circumflex accent
+ "icirc" => "\\^{i}", # small i, circumflex accent
+ "Igrave" => "\\`{I}", # capital I, grave accent
+ "igrave" => "\\`{i}", # small i, grave accent
+ "Iuml" => '\\"{I}', # capital I, dieresis or umlaut mark
+ "iuml" => '\\"{i}', # small i, dieresis or umlaut mark
+ "Ntilde" => '\\~{N}', # capital N, tilde
+ "ntilde" => '\\~{n}', # small n, tilde
+ "Oacute" => "\\'{O}", # capital O, acute accent
+ "oacute" => "\\'{o}", # small o, acute accent
+ "Ocirc" => "\\^{O}", # capital O, circumflex accent
+ "ocirc" => "\\^{o}", # small o, circumflex accent
+ "Ograve" => "\\`{O}", # capital O, grave accent
+ "ograve" => "\\`{o}", # small o, grave accent
+ "Oslash" => "\\O", # capital O, slash
+ "oslash" => "\\o", # small o, slash
+ "Otilde" => "\\~{O}", # capital O, tilde
+ "otilde" => "\\~{o}", # small o, tilde
+ "Ouml" => '\\"{O}', # capital O, dieresis or umlaut mark
+ "ouml" => '\\"{o}', # small o, dieresis or umlaut mark
+ "szlig" => '\\ss{}', # small sharp s, German (sz ligature)
+ "THORN" => '\\L', # capital THORN, Icelandic
+ "thorn" => '\\l',, # small thorn, Icelandic
+ "Uacute" => "\\'{U}", # capital U, acute accent
+ "uacute" => "\\'{u}", # small u, acute accent
+ "Ucirc" => "\\^{U}", # capital U, circumflex accent
+ "ucirc" => "\\^{u}", # small u, circumflex accent
+ "Ugrave" => "\\`{U}", # capital U, grave accent
+ "ugrave" => "\\`{u}", # small u, grave accent
+ "Uuml" => '\\"{U}', # capital U, dieresis or umlaut mark
+ "uuml" => '\\"{u}', # small u, dieresis or umlaut mark
+ "Yacute" => "\\'{Y}", # capital Y, acute accent
+ "yacute" => "\\'{y}", # small y, acute accent
+ "yuml" => '\\"{y}', # small y, dieresis or umlaut mark
+);
+}
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/pod/pod2man.PL b/contrib/perl5/pod/pod2man.PL
new file mode 100644
index 000000000000..8040bf5d63ec
--- /dev/null
+++ b/contrib/perl5/pod/pod2man.PL
@@ -0,0 +1,1216 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# $man3ext
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+
+\$DEF_PM_SECTION = '$Config{man3ext}' || '3';
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+=head1 NAME
+
+pod2man - translate embedded Perl pod directives into man pages
+
+=head1 SYNOPSIS
+
+B<pod2man>
+[ B<--section=>I<manext> ]
+[ B<--release=>I<relpatch> ]
+[ B<--center=>I<string> ]
+[ B<--date=>I<string> ]
+[ B<--fixed=>I<font> ]
+[ B<--official> ]
+[ B<--lax> ]
+I<inputfile>
+
+=head1 DESCRIPTION
+
+B<pod2man> converts its input file containing embedded pod directives (see
+L<perlpod>) into nroff source suitable for viewing with nroff(1) or
+troff(1) using the man(7) macro set.
+
+Besides the obvious pod conversions, B<pod2man> also takes care of
+func(), func(n), and simple variable references like $foo or @bar so
+you don't have to use code escapes for them; complex expressions like
+C<$fred{'stuff'}> will still need to be escaped, though. Other nagging
+little roffish things that it catches include translating the minus in
+something like foo-bar, making a long dash--like this--into a real em
+dash, fixing up "paired quotes", putting a little space after the
+parens in something like func(), making C++ and PI look right, making
+double underbars have a little tiny space between them, making ALLCAPS
+a teeny bit smaller in troff(1), and escaping backslashes so you don't
+have to.
+
+=head1 OPTIONS
+
+=over 8
+
+=item center
+
+Set the centered header to a specific string. The default is
+"User Contributed Perl Documentation", unless the C<--official> flag is
+given, in which case the default is "Perl Programmers Reference Guide".
+
+=item date
+
+Set the left-hand footer string to this value. By default,
+the modification date of the input file will be used.
+
+=item fixed
+
+The fixed font to use for code refs. Defaults to CW.
+
+=item official
+
+Set the default header to indicate that this page is of
+the standard release in case C<--center> is not given.
+
+=item release
+
+Set the centered footer. By default, this is the current
+perl release.
+
+=item section
+
+Set the section for the C<.TH> macro. The standard conventions on
+sections are to use 1 for user commands, 2 for system calls, 3 for
+functions, 4 for devices, 5 for file formats, 6 for games, 7 for
+miscellaneous information, and 8 for administrator commands. This works
+best if you put your Perl man pages in a separate tree, like
+F</usr/local/perl/man/>. By default, section 1 will be used
+unless the file ends in F<.pm> in which case section 3 will be selected.
+
+=item lax
+
+Don't complain when required sections aren't present.
+
+=back
+
+=head1 Anatomy of a Proper Man Page
+
+For those not sure of the proper layout of a man page, here's
+an example of the skeleton of a proper man page. Head of the
+major headers should be setout as a C<=head1> directive, and
+are historically written in the rather startling ALL UPPER CASE
+format, although this is not mandatory.
+Minor headers may be included using C<=head2>, and are
+typically in mixed case.
+
+=over 10
+
+=item NAME
+
+Mandatory section; should be a comma-separated list of programs or
+functions documented by this podpage, such as:
+
+ foo, bar - programs to do something
+
+=item SYNOPSIS
+
+A short usage summary for programs and functions, which
+may someday be deemed mandatory.
+
+=item DESCRIPTION
+
+Long drawn out discussion of the program. It's a good idea to break this
+up into subsections using the C<=head2> directives, like
+
+ =head2 A Sample Subection
+
+ =head2 Yet Another Sample Subection
+
+=item OPTIONS
+
+Some people make this separate from the description.
+
+=item RETURN VALUE
+
+What the program or function returns if successful.
+
+=item ERRORS
+
+Exceptions, return codes, exit stati, and errno settings.
+
+=item EXAMPLES
+
+Give some example uses of the program.
+
+=item ENVIRONMENT
+
+Envariables this program might care about.
+
+=item FILES
+
+All files used by the program. You should probably use the FE<lt>E<gt>
+for these.
+
+=item SEE ALSO
+
+Other man pages to check out, like man(1), man(7), makewhatis(8), or catman(8).
+
+=item NOTES
+
+Miscellaneous commentary.
+
+=item CAVEATS
+
+Things to take special care with; sometimes called WARNINGS.
+
+=item DIAGNOSTICS
+
+All possible messages the program can print out--and
+what they mean.
+
+=item BUGS
+
+Things that are broken or just don't work quite right.
+
+=item RESTRICTIONS
+
+Bugs you don't plan to fix :-)
+
+=item AUTHOR
+
+Who wrote it (or AUTHORS if multiple).
+
+=item HISTORY
+
+Programs derived from other sources sometimes have this, or
+you might keep a modification log here.
+
+=back
+
+=head1 EXAMPLES
+
+ pod2man program > program.1
+ pod2man some_module.pm > /usr/perl/man/man3/some_module.3
+ pod2man --section=7 note.pod > note.7
+
+=head1 DIAGNOSTICS
+
+The following diagnostics are generated by B<pod2man>. Items
+marked "(W)" are non-fatal, whereas the "(F)" errors will cause
+B<pod2man> to immediately exit with a non-zero status.
+
+=over 4
+
+=item bad option in paragraph %d of %s: ``%s'' should be [%s]<%s>
+
+(W) If you start include an option, you should set it off
+as bold, italic, or code.
+
+=item can't open %s: %s
+
+(F) The input file wasn't available for the given reason.
+
+=item Improper man page - no dash in NAME header in paragraph %d of %s
+
+(W) The NAME header did not have an isolated dash in it. This is
+considered important.
+
+=item Invalid man page - no NAME line in %s
+
+(F) You did not include a NAME header, which is essential.
+
+=item roff font should be 1 or 2 chars, not `%s' (F)
+
+(F) The font specified with the C<--fixed> option was not
+a one- or two-digit roff font.
+
+=item %s is missing required section: %s
+
+(W) Required sections include NAME, DESCRIPTION, and if you're
+using a section starting with a 3, also a SYNOPSIS. Actually,
+not having a NAME is a fatal.
+
+=item Unknown escape: %s in %s
+
+(W) An unknown HTML entity (probably for an 8-bit character) was given via
+a C<EE<lt>E<gt>> directive. Besides amp, lt, gt, and quot, recognized
+entities are Aacute, aacute, Acirc, acirc, AElig, aelig, Agrave, agrave,
+Aring, aring, Atilde, atilde, Auml, auml, Ccedil, ccedil, Eacute, eacute,
+Ecirc, ecirc, Egrave, egrave, ETH, eth, Euml, euml, Iacute, iacute, Icirc,
+icirc, Igrave, igrave, Iuml, iuml, Ntilde, ntilde, Oacute, oacute, Ocirc,
+ocirc, Ograve, ograve, Oslash, oslash, Otilde, otilde, Ouml, ouml, szlig,
+THORN, thorn, Uacute, uacute, Ucirc, ucirc, Ugrave, ugrave, Uuml, uuml,
+Yacute, yacute, and yuml.
+
+=item Unmatched =back
+
+(W) You have a C<=back> without a corresponding C<=over>.
+
+=item Unrecognized pod directive: %s
+
+(W) You specified a pod directive that isn't in the known list of
+C<=head1>, C<=head2>, C<=item>, C<=over>, C<=back>, or C<=cut>.
+
+
+=back
+
+=head1 NOTES
+
+If you would like to print out a lot of man page continuously, you
+probably want to set the C and D registers to set contiguous page
+numbering and even/odd paging, at least on some versions of man(7).
+Settting the F register will get you some additional experimental
+indexing:
+
+ troff -man -rC1 -rD1 -rF1 perl.1 perldata.1 perlsyn.1 ...
+
+The indexing merely outputs messages via C<.tm> for each
+major page, section, subsection, item, and any C<XE<lt>E<gt>>
+directives.
+
+
+=head1 RESTRICTIONS
+
+None at this time.
+
+=head1 BUGS
+
+The =over and =back directives don't really work right. They
+take absolute positions instead of offsets, don't nest well, and
+making people count is suboptimal in any event.
+
+=head1 AUTHORS
+
+Original prototype by Larry Wall, but so massively hacked over by
+Tom Christiansen such that Larry probably doesn't recognize it anymore.
+
+=cut
+
+$/ = "";
+$cutting = 1;
+@Indices = ();
+
+# We try first to get the version number from a local binary, in case we're
+# running an installed version of Perl to produce documentation from an
+# uninstalled newer version's pod files.
+if ($^O ne 'plan9' and $^O ne 'dos' and $^O ne 'os2' and $^O ne 'MSWin32') {
+ ($version,$patch) =
+ `\PATH=.:..:\$PATH; perl -v` =~ /version (\d\.\d{3})(?:_(\d{2}))?/;
+}
+# No luck; we'll just go with the running Perl's version
+($version,$patch) = $] =~ /^(.{5})(\d{2})?/ unless $version;
+$DEF_RELEASE = "perl $version";
+$DEF_RELEASE .= ", patch $patch" if $patch;
+
+
+sub makedate {
+ my $secs = shift;
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($secs);
+ my $mname = (qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec})[$mon];
+ return "$mday/$mname/$year";
+}
+
+use Getopt::Long;
+
+$DEF_SECTION = 1;
+$DEF_CENTER = "User Contributed Perl Documentation";
+$STD_CENTER = "Perl Programmers Reference Guide";
+$DEF_FIXED = 'CW';
+$DEF_LAX = 0;
+
+sub usage {
+ warn "$0: @_\n" if @_;
+ die <<EOF;
+usage: $0 [options] podpage
+Options are:
+ --section=manext (default "$DEF_SECTION")
+ --release=relpatch (default "$DEF_RELEASE")
+ --center=string (default "$DEF_CENTER")
+ --date=string (default "$DEF_DATE")
+ --fixed=font (default "$DEF_FIXED")
+ --official (default NOT)
+ --lax (default NOT)
+EOF
+}
+
+$uok = GetOptions( qw(
+ section=s
+ release=s
+ center=s
+ date=s
+ fixed=s
+ official
+ lax
+ help));
+
+$DEF_DATE = makedate((stat($ARGV[0]))[9] || time());
+
+usage("Usage error!") unless $uok;
+usage() if $opt_help;
+usage("Need one and only one podpage argument") unless @ARGV == 1;
+
+$section = $opt_section || ($ARGV[0] =~ /\.pm$/
+ ? $DEF_PM_SECTION : $DEF_SECTION);
+$RP = $opt_release || $DEF_RELEASE;
+$center = $opt_center || ($opt_official ? $STD_CENTER : $DEF_CENTER);
+$lax = $opt_lax || $DEF_LAX;
+
+$CFont = $opt_fixed || $DEF_FIXED;
+
+if (length($CFont) == 2) {
+ $CFont_embed = "\\f($CFont";
+}
+elsif (length($CFont) == 1) {
+ $CFont_embed = "\\f$CFont";
+}
+else {
+ die "roff font should be 1 or 2 chars, not `$CFont_embed'";
+}
+
+$date = $opt_date || $DEF_DATE;
+
+for (qw{NAME DESCRIPTION}) {
+# for (qw{NAME DESCRIPTION AUTHOR}) {
+ $wanna_see{$_}++;
+}
+$wanna_see{SYNOPSIS}++ if $section =~ /^3/;
+
+
+$name = @ARGV ? $ARGV[0] : "<STDIN>";
+$Filename = $name;
+if ($section =~ /^1/) {
+ require File::Basename;
+ $name = uc File::Basename::basename($name);
+}
+$name =~ s/\.(pod|p[lm])$//i;
+
+# Lose everything up to the first of
+# */lib/*perl* standard or site_perl module
+# */*perl*/lib from -D prefix=/opt/perl
+# */*perl*/ random module hierarchy
+# which works.
+$name =~ s-//+-/-g;
+if ($name =~ s-^.*?/lib/[^/]*perl[^/]*/--i
+ or $name =~ s-^.*?/[^/]*perl[^/]*/lib/--i
+ or $name =~ s-^.*?/[^/]*perl[^/]*/--i) {
+ # Lose ^site(_perl)?/.
+ $name =~ s-^site(_perl)?/--;
+ # Lose ^arch/. (XXX should we use Config? Just for archname?)
+ $name =~ s~^(.*-$^O|$^O-.*)/~~o;
+ # Lose ^version/.
+ $name =~ s-^\d+\.\d+/--;
+}
+
+# Translate Getopt/Long to Getopt::Long, etc.
+$name =~ s(/)(::)g;
+
+if ($name ne 'something') {
+ FCHECK: {
+ open(F, "< $ARGV[0]") || die "can't open $ARGV[0]: $!";
+ while (<F>) {
+ next unless /^=\b/;
+ if (/^=head1\s+NAME\s*$/) { # an /m would forgive mistakes
+ $_ = <F>;
+ unless (/\s*-+\s+/) {
+ $oops++;
+ warn "$0: Improper man page - no dash in NAME header in paragraph $. of $ARGV[0]\n"
+ } else {
+ my @n = split /\s+-+\s+/;
+ if (@n != 2) {
+ $oops++;
+ warn "$0: Improper man page - malformed NAME header in paragraph $. of $ARGV[0]\n"
+ }
+ else {
+ %namedesc = @n;
+ }
+ }
+ last FCHECK;
+ }
+ next if /^=cut\b/; # DB_File and Net::Ping have =cut before NAME
+ next if /^=pod\b/; # It is OK to have =pod before NAME
+ die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n" unless $lax;
+ }
+ die "$0: Invalid man page - no documentation in $ARGV[0]\n" unless $lax;
+ }
+ close F;
+}
+
+print <<"END";
+.rn '' }`
+''' \$RCSfile\$\$Revision\$\$Date\$
+'''
+''' \$Log\$
+'''
+.de Sh
+.br
+.if t .Sp
+.ne 5
+.PP
+\\fB\\\\\$1\\fR
+.PP
+..
+.de Sp
+.if t .sp .5v
+.if n .sp
+..
+.de Ip
+.br
+.ie \\\\n(.\$>=3 .ne \\\\\$3
+.el .ne 3
+.IP "\\\\\$1" \\\\\$2
+..
+.de Vb
+.ft $CFont
+.nf
+.ne \\\\\$1
+..
+.de Ve
+.ft R
+
+.fi
+..
+'''
+'''
+''' Set up \\*(-- to give an unbreakable dash;
+''' string Tr holds user defined translation string.
+''' Bell System Logo is used as a dummy character.
+'''
+.tr \\(*W-|\\(bv\\*(Tr
+.ie n \\{\\
+.ds -- \\(*W-
+.ds PI pi
+.if (\\n(.H=4u)&(1m=24u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-12u'-\\" diablo 10 pitch
+.if (\\n(.H=4u)&(1m=20u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-8u'-\\" diablo 12 pitch
+.ds L" ""
+.ds R" ""
+''' \\*(M", \\*(S", \\*(N" and \\*(T" are the equivalent of
+''' \\*(L" and \\*(R", except that they are used on ".xx" lines,
+''' such as .IP and .SH, which do another additional levels of
+''' double-quote interpretation
+.ds M" """
+.ds S" """
+.ds N" """""
+.ds T" """""
+.ds L' '
+.ds R' '
+.ds M' '
+.ds S' '
+.ds N' '
+.ds T' '
+'br\\}
+.el\\{\\
+.ds -- \\(em\\|
+.tr \\*(Tr
+.ds L" ``
+.ds R" ''
+.ds M" ``
+.ds S" ''
+.ds N" ``
+.ds T" ''
+.ds L' `
+.ds R' '
+.ds M' `
+.ds S' '
+.ds N' `
+.ds T' '
+.ds PI \\(*p
+'br\\}
+END
+
+print <<'END';
+.\" If the F register is turned on, we'll generate
+.\" index entries out stderr for the following things:
+.\" TH Title
+.\" SH Header
+.\" Sh Subsection
+.\" Ip Item
+.\" X<> Xref (embedded
+.\" Of course, you have to process the output yourself
+.\" in some meaninful fashion.
+.if \nF \{
+.de IX
+.tm Index:\\$1\t\\n%\t"\\$2"
+..
+.nr % 0
+.rr F
+.\}
+END
+
+print <<"END";
+.TH $name $section "$RP" "$date" "$center"
+.UC
+END
+
+push(@Indices, qq{.IX Title "$name $section"});
+
+while (($name, $desc) = each %namedesc) {
+ for ($name, $desc) { s/^\s+//; s/\s+$//; }
+ push(@Indices, qq(.IX Name "$name - $desc"\n));
+}
+
+print <<'END';
+.if n .hy 0
+.if n .na
+.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
+.de CQ \" put $1 in typewriter font
+END
+print ".ft $CFont\n";
+print <<'END';
+'if n "\c
+'if t \\&\\$1\c
+'if n \\&\\$1\c
+'if n \&"
+\\&\\$2 \\$3 \\$4 \\$5 \\$6 \\$7
+'.ft R
+..
+.\" @(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2
+. \" AM - accent mark definitions
+.bd B 3
+. \" fudge factors for nroff and troff
+.if n \{\
+. ds #H 0
+. ds #V .8m
+. ds #F .3m
+. ds #[ \f1
+. ds #] \fP
+.\}
+.if t \{\
+. ds #H ((1u-(\\\\n(.fu%2u))*.13m)
+. ds #V .6m
+. ds #F 0
+. ds #[ \&
+. ds #] \&
+.\}
+. \" simple accents for nroff and troff
+.if n \{\
+. ds ' \&
+. ds ` \&
+. ds ^ \&
+. ds , \&
+. ds ~ ~
+. ds ? ?
+. ds ! !
+. ds /
+. ds q
+.\}
+.if t \{\
+. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
+. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
+. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
+. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
+. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
+. ds ? \s-2c\h'-\w'c'u*7/10'\u\h'\*(#H'\zi\d\s+2\h'\w'c'u*8/10'
+. ds ! \s-2\(or\s+2\h'-\w'\(or'u'\v'-.8m'.\v'.8m'
+. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
+. ds q o\h'-\w'o'u*8/10'\s-4\v'.4m'\z\(*i\v'-.4m'\s+4\h'\w'o'u*8/10'
+.\}
+. \" troff and (daisy-wheel) nroff accents
+.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
+.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
+.ds v \\k:\h'-(\\n(.wu*9/10-\*(#H)'\v'-\*(#V'\*(#[\s-4v\s0\v'\*(#V'\h'|\\n:u'\*(#]
+.ds _ \\k:\h'-(\\n(.wu*9/10-\*(#H+(\*(#F*2/3))'\v'-.4m'\z\(hy\v'.4m'\h'|\\n:u'
+.ds . \\k:\h'-(\\n(.wu*8/10)'\v'\*(#V*4/10'\z.\v'-\*(#V*4/10'\h'|\\n:u'
+.ds 3 \*(#[\v'.2m'\s-2\&3\s0\v'-.2m'\*(#]
+.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
+.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
+.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
+.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
+.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
+.ds ae a\h'-(\w'a'u*4/10)'e
+.ds Ae A\h'-(\w'A'u*4/10)'E
+.ds oe o\h'-(\w'o'u*4/10)'e
+.ds Oe O\h'-(\w'O'u*4/10)'E
+. \" corrections for vroff
+.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
+.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
+. \" for low resolution devices (crt and lpr)
+.if \n(.H>23 .if \n(.V>19 \
+\{\
+. ds : e
+. ds 8 ss
+. ds v \h'-1'\o'\(aa\(ga'
+. ds _ \h'-1'^
+. ds . \h'-1'.
+. ds 3 3
+. ds o a
+. ds d- d\h'-1'\(ga
+. ds D- D\h'-1'\(hy
+. ds th \o'bp'
+. ds Th \o'LP'
+. ds ae ae
+. ds Ae AE
+. ds oe oe
+. ds Oe OE
+.\}
+.rm #[ #] #H #V #F C
+END
+
+$indent = 0;
+
+$begun = "";
+
+# Unrolling [^A-Z>]|[A-Z](?!<) gives: // MRE pp 165.
+my $nonest = '(?:[^A-Z>]*(?:[A-Z](?!<)[^A-Z>]*)*)';
+
+while (<>) {
+ if ($cutting) {
+ next unless /^=/;
+ $cutting = 0;
+ }
+ if ($begun) {
+ if (/^=end\s+$begun/) {
+ $begun = "";
+ }
+ elsif ($begun =~ /^(roff|man)$/) {
+ print STDOUT $_;
+ }
+ next;
+ }
+ chomp;
+
+ # Translate verbatim paragraph
+
+ if (/^\s/) {
+ @lines = split(/\n/);
+ for (@lines) {
+ 1 while s
+ {^( [^\t]* ) \t ( \t* ) }
+ { $1 . ' ' x (8 - (length($1)%8) + 8 * (length($2))) }ex;
+ s/\\/\\e/g;
+ s/\A/\\&/s;
+ }
+ $lines = @lines;
+ makespace() unless $verbatim++;
+ print ".Vb $lines\n";
+ print join("\n", @lines), "\n";
+ print ".Ve\n";
+ $needspace = 0;
+ next;
+ }
+
+ $verbatim = 0;
+
+ if (/^=for\s+(\S+)\s*/s) {
+ if ($1 eq "man" or $1 eq "roff") {
+ print STDOUT $',"\n\n";
+ } else {
+ # ignore unknown for
+ }
+ next;
+ }
+ elsif (/^=begin\s+(\S+)\s*/s) {
+ $begun = $1;
+ if ($1 eq "man" or $1 eq "roff") {
+ print STDOUT $'."\n\n";
+ }
+ next;
+ }
+
+ # check for things that'll hosed our noremap scheme; affects $_
+ init_noremap();
+
+ if (!/^=item/) {
+
+ # trofficate backslashes; must do it before what happens below
+ s/\\/noremap('\\e')/ge;
+
+ # protect leading periods and quotes against *roff
+ # mistaking them for directives
+ s/^(?:[A-Z]<)?[.']/\\&$&/gm;
+
+ # first hide the escapes in case we need to
+ # intuit something and get it wrong due to fmting
+
+ 1 while s/([A-Z]<$nonest>)/noremap($1)/ge;
+
+ # func() is a reference to a perl function
+ s{
+ \b
+ (
+ [:\w]+ \(\)
+ )
+ } {I<$1>}gx;
+
+ # func(n) is a reference to a perl function or a man page
+ s{
+ ([:\w]+)
+ (
+ \( [^\051]+ \)
+ )
+ } {I<$1>\\|$2}gx;
+
+ # convert simple variable references
+ s/(\s+)([\$\@%][\w:]+)(?!\()/${1}C<$2>/g;
+
+ if (m{ (
+ [\-\w]+
+ \(
+ [^\051]*?
+ [\@\$,]
+ [^\051]*?
+ \)
+ )
+ }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/)
+ {
+ warn "$0: bad option in paragraph $. of $ARGV: ``$1'' should be [LCI]<$1>\n";
+ $oops++;
+ }
+
+ while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) {
+ warn "$0: bad option in paragraph $. of $ARGV: ``$1'' should be [CB]<$1>\n";
+ $oops++;
+ }
+
+ # put it back so we get the <> processed again;
+ clear_noremap(0); # 0 means leave the E's
+
+ } else {
+ # trofficate backslashes
+ s/\\/noremap('\\e')/ge;
+
+ }
+
+ # need to hide E<> first; they're processed in clear_noremap
+ s/(E<[^<>]+>)/noremap($1)/ge;
+
+
+ $maxnest = 10;
+ while ($maxnest-- && /[A-Z]</) {
+
+ # can't do C font here
+ s/([BI])<($nonest)>/font($1) . $2 . font('R')/eg;
+
+ # files and filelike refs in italics
+ s/F<($nonest)>/I<$1>/g;
+
+ # no break -- usually we want C<> for this
+ s/S<($nonest)>/nobreak($1)/eg;
+
+ # LREF: a la HREF L<show this text|man/section>
+ s:L<([^|>]+)\|[^>]+>:$1:g;
+
+ # LREF: a manpage(3f)
+ s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the I<$1>$2 manpage:g;
+
+ # LREF: an =item on another manpage
+ s{
+ L<
+ ([^/]+)
+ /
+ (
+ [:\w]+
+ (\(\))?
+ )
+ >
+ } {the C<$2> entry in the I<$1> manpage}gx;
+
+ # LREF: an =item on this manpage
+ s{
+ ((?:
+ L<
+ /
+ (
+ [:\w]+
+ (\(\))?
+ )
+ >
+ (,?\s+(and\s+)?)?
+ )+)
+ } { internal_lrefs($1) }gex;
+
+ # LREF: a =head2 (head1?), maybe on a manpage, maybe right here
+ # the "func" can disambiguate
+ s{
+ L<
+ (?:
+ ([a-zA-Z]\S+?) /
+ )?
+ "?(.*?)"?
+ >
+ }{
+ do {
+ $1 # if no $1, assume it means on this page.
+ ? "the section on I<$2> in the I<$1> manpage"
+ : "the section on I<$2>"
+ }
+ }gesx; # s in case it goes over multiple lines, so . matches \n
+
+ s/Z<>/\\&/g;
+
+ # comes last because not subject to reprocessing
+ s/C<($nonest)>/noremap("${CFont_embed}${1}\\fR")/eg;
+ }
+
+ if (s/^=//) {
+ $needspace = 0; # Assume this.
+
+ s/\n/ /g;
+
+ ($Cmd, $_) = split(' ', $_, 2);
+
+ $dotlevel = 1;
+ if ($Cmd eq 'head1') {
+ $dotlevel = 1;
+ }
+ elsif ($Cmd eq 'head2') {
+ $dotlevel = 1;
+ }
+ elsif ($Cmd eq 'item') {
+ $dotlevel = 2;
+ }
+
+ if (defined $_) {
+ &escapes($dotlevel);
+ s/"/""/g;
+ }
+
+ clear_noremap(1);
+
+ if ($Cmd eq 'cut') {
+ $cutting = 1;
+ }
+ elsif ($Cmd eq 'head1') {
+ s/\s+$//;
+ delete $wanna_see{$_} if exists $wanna_see{$_};
+ print qq{.SH "$_"\n};
+ push(@Indices, qq{.IX Header "$_"\n});
+ }
+ elsif ($Cmd eq 'head2') {
+ print qq{.Sh "$_"\n};
+ push(@Indices, qq{.IX Subsection "$_"\n});
+ }
+ elsif ($Cmd eq 'over') {
+ push(@indent,$indent);
+ $indent += ($_ + 0) || 5;
+ }
+ elsif ($Cmd eq 'back') {
+ $indent = pop(@indent);
+ warn "$0: Unmatched =back in paragraph $. of $ARGV\n" unless defined $indent;
+ $needspace = 1;
+ }
+ elsif ($Cmd eq 'item') {
+ s/^\*( |$)/\\(bu$1/g;
+ # if you know how to get ":s please do
+ s/\\\*\(L"([^"]+?)\\\*\(R"/'$1'/g;
+ s/\\\*\(L"([^"]+?)""/'$1'/g;
+ s/[^"]""([^"]+?)""[^"]/'$1'/g;
+ # here do something about the $" in perlvar?
+ print STDOUT qq{.Ip "$_" $indent\n};
+ push(@Indices, qq{.IX Item "$_"\n});
+ }
+ elsif ($Cmd eq 'pod') {
+ # this is just a comment
+ }
+ else {
+ warn "$0: Unrecognized pod directive in paragraph $. of $ARGV: $Cmd\n";
+ }
+ }
+ else {
+ if ($needspace) {
+ &makespace;
+ }
+ &escapes(0);
+ clear_noremap(1);
+ print $_, "\n";
+ $needspace = 1;
+ }
+}
+
+print <<"END";
+
+.rn }` ''
+END
+
+if (%wanna_see && !$lax) {
+ @missing = keys %wanna_see;
+ warn "$0: $Filename is missing required section"
+ . (@missing > 1 && "s")
+ . ": @missing\n";
+ $oops++;
+}
+
+foreach (@Indices) { print "$_\n"; }
+
+exit;
+#exit ($oops != 0);
+
+#########################################################################
+
+sub nobreak {
+ my $string = shift;
+ $string =~ s/ /\\ /g;
+ $string;
+}
+
+sub escapes {
+ my $indot = shift;
+
+ s/X<(.*?)>/mkindex($1)/ge;
+
+ # translate the minus in foo-bar into foo\-bar for roff
+ s/([^0-9a-z-])-([^-])/$1\\-$2/g;
+
+ # make -- into the string version \*(-- (defined above)
+ s/\b--\b/\\*(--/g;
+ s/"--([^"])/"\\*(--$1/g; # should be a better way
+ s/([^"])--"/$1\\*(--"/g;
+
+ # fix up quotes; this is somewhat tricky
+ my $dotmacroL = 'L';
+ my $dotmacroR = 'R';
+ if ( $indot == 1 ) {
+ $dotmacroL = 'M';
+ $dotmacroR = 'S';
+ }
+ elsif ( $indot >= 2 ) {
+ $dotmacroL = 'N';
+ $dotmacroR = 'T';
+ }
+ if (!/""/) {
+ s/(^|\s)(['"])/noremap("$1\\*($dotmacroL$2")/ge;
+ s/(['"])($|[\-\s,;\\!?.])/noremap("\\*($dotmacroR$1$2")/ge;
+ }
+
+ #s/(?!")(?:.)--(?!")(?:.)/\\*(--/g;
+ #s/(?:(?!")(?:.)--(?:"))|(?:(?:")--(?!")(?:.))/\\*(--/g;
+
+
+ # make sure that func() keeps a bit a space tween the parens
+ ### s/\b\(\)/\\|()/g;
+ ### s/\b\(\)/(\\|)/g;
+
+ # make C++ into \*C+, which is a squinched version (defined above)
+ s/\bC\+\+/\\*(C+/g;
+
+ # make double underbars have a little tiny space between them
+ s/__/_\\|_/g;
+
+ # PI goes to \*(PI (defined above)
+ s/\bPI\b/noremap('\\*(PI')/ge;
+
+ # make all caps a teeny bit smaller, but don't muck with embedded code literals
+ my $hidCFont = font('C');
+ if ($Cmd !~ /^head1/) { # SH already makes smaller
+ # /g isn't enough; 1 while or we'll be off
+
+# 1 while s{
+# (?!$hidCFont)(..|^.|^)
+# \b
+# (
+# [A-Z][\/A-Z+:\-\d_$.]+
+# )
+# (s?)
+# \b
+# } {$1\\s-1$2\\s0}gmox;
+
+ 1 while s{
+ (?!$hidCFont)(..|^.|^)
+ (
+ \b[A-Z]{2,}[\/A-Z+:\-\d_\$]*\b
+ )
+ } {
+ $1 . noremap( '\\s-1' . $2 . '\\s0' )
+ }egmox;
+
+ }
+}
+
+# make troff just be normal, but make small nroff get quoted
+# decided to just put the quotes in the text; sigh;
+sub ccvt {
+ local($_,$prev) = @_;
+ noremap(qq{.CQ "$_" \n\\&});
+}
+
+sub makespace {
+ if ($indent) {
+ print ".Sp\n";
+ }
+ else {
+ print ".PP\n";
+ }
+}
+
+sub mkindex {
+ my ($entry) = @_;
+ my @entries = split m:\s*/\s*:, $entry;
+ push @Indices, ".IX Xref " . join ' ', map {qq("$_")} @entries;
+ return '';
+}
+
+sub font {
+ local($font) = shift;
+ return '\\f' . noremap($font);
+}
+
+sub noremap {
+ local($thing_to_hide) = shift;
+ $thing_to_hide =~ tr/\000-\177/\200-\377/;
+ return $thing_to_hide;
+}
+
+sub init_noremap {
+ # escape high bit characters in input stream
+ s/([\200-\377])/"E<".ord($1).">"/ge;
+}
+
+sub clear_noremap {
+ my $ready_to_print = $_[0];
+
+ tr/\200-\377/\000-\177/;
+
+ # trofficate backslashes
+ # s/(?!\\e)(?:..|^.|^)\\/\\e/g;
+
+ # now for the E<>s, which have been hidden until now
+ # otherwise the interative \w<> processing would have
+ # been hosed by the E<gt>
+ s {
+ E<
+ (
+ ( \d + )
+ | ( [A-Za-z]+ )
+ )
+ >
+ } {
+ do {
+ defined $2
+ ? chr($2)
+ :
+ exists $HTML_Escapes{$3}
+ ? do { $HTML_Escapes{$3} }
+ : do {
+ warn "$0: Unknown escape in paragraph $. of $ARGV: ``$&''\n";
+ "E<$1>";
+ }
+ }
+ }egx if $ready_to_print;
+}
+
+sub internal_lrefs {
+ local($_) = shift;
+ local $trailing_and = s/and\s+$// ? "and " : "";
+
+ s{L</([^>]+)>}{$1}g;
+ my(@items) = split( /(?:,?\s+(?:and\s+)?)/ );
+ my $retstr = "the ";
+ my $i;
+ for ($i = 0; $i <= $#items; $i++) {
+ $retstr .= "C<$items[$i]>";
+ $retstr .= ", " if @items > 2 && $i != $#items;
+ $retstr .= " and " if $i+2 == @items;
+ }
+
+ $retstr .= " entr" . ( @items > 1 ? "ies" : "y" )
+ . " elsewhere in this document";
+ # terminal space to avoid words running together (pattern used
+ # strips terminal spaces)
+ $retstr .= " " if length $trailing_and;
+ $retstr .= $trailing_and;
+
+ return $retstr;
+
+}
+
+BEGIN {
+%HTML_Escapes = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "A\\*'", # capital A, acute accent
+ "aacute" => "a\\*'", # small a, acute accent
+ "Acirc" => "A\\*^", # capital A, circumflex accent
+ "acirc" => "a\\*^", # small a, circumflex accent
+ "AElig" => '\*(AE', # capital AE diphthong (ligature)
+ "aelig" => '\*(ae', # small ae diphthong (ligature)
+ "Agrave" => "A\\*`", # capital A, grave accent
+ "agrave" => "A\\*`", # small a, grave accent
+ "Aring" => 'A\\*o', # capital A, ring
+ "aring" => 'a\\*o', # small a, ring
+ "Atilde" => 'A\\*~', # capital A, tilde
+ "atilde" => 'a\\*~', # small a, tilde
+ "Auml" => 'A\\*:', # capital A, dieresis or umlaut mark
+ "auml" => 'a\\*:', # small a, dieresis or umlaut mark
+ "Ccedil" => 'C\\*,', # capital C, cedilla
+ "ccedil" => 'c\\*,', # small c, cedilla
+ "Eacute" => "E\\*'", # capital E, acute accent
+ "eacute" => "e\\*'", # small e, acute accent
+ "Ecirc" => "E\\*^", # capital E, circumflex accent
+ "ecirc" => "e\\*^", # small e, circumflex accent
+ "Egrave" => "E\\*`", # capital E, grave accent
+ "egrave" => "e\\*`", # small e, grave accent
+ "ETH" => '\\*(D-', # capital Eth, Icelandic
+ "eth" => '\\*(d-', # small eth, Icelandic
+ "Euml" => "E\\*:", # capital E, dieresis or umlaut mark
+ "euml" => "e\\*:", # small e, dieresis or umlaut mark
+ "Iacute" => "I\\*'", # capital I, acute accent
+ "iacute" => "i\\*'", # small i, acute accent
+ "Icirc" => "I\\*^", # capital I, circumflex accent
+ "icirc" => "i\\*^", # small i, circumflex accent
+ "Igrave" => "I\\*`", # capital I, grave accent
+ "igrave" => "i\\*`", # small i, grave accent
+ "Iuml" => "I\\*:", # capital I, dieresis or umlaut mark
+ "iuml" => "i\\*:", # small i, dieresis or umlaut mark
+ "Ntilde" => 'N\*~', # capital N, tilde
+ "ntilde" => 'n\*~', # small n, tilde
+ "Oacute" => "O\\*'", # capital O, acute accent
+ "oacute" => "o\\*'", # small o, acute accent
+ "Ocirc" => "O\\*^", # capital O, circumflex accent
+ "ocirc" => "o\\*^", # small o, circumflex accent
+ "Ograve" => "O\\*`", # capital O, grave accent
+ "ograve" => "o\\*`", # small o, grave accent
+ "Oslash" => "O\\*/", # capital O, slash
+ "oslash" => "o\\*/", # small o, slash
+ "Otilde" => "O\\*~", # capital O, tilde
+ "otilde" => "o\\*~", # small o, tilde
+ "Ouml" => "O\\*:", # capital O, dieresis or umlaut mark
+ "ouml" => "o\\*:", # small o, dieresis or umlaut mark
+ "szlig" => '\*8', # small sharp s, German (sz ligature)
+ "THORN" => '\\*(Th', # capital THORN, Icelandic
+ "thorn" => '\\*(th',, # small thorn, Icelandic
+ "Uacute" => "U\\*'", # capital U, acute accent
+ "uacute" => "u\\*'", # small u, acute accent
+ "Ucirc" => "U\\*^", # capital U, circumflex accent
+ "ucirc" => "u\\*^", # small u, circumflex accent
+ "Ugrave" => "U\\*`", # capital U, grave accent
+ "ugrave" => "u\\*`", # small u, grave accent
+ "Uuml" => "U\\*:", # capital U, dieresis or umlaut mark
+ "uuml" => "u\\*:", # small u, dieresis or umlaut mark
+ "Yacute" => "Y\\*'", # capital Y, acute accent
+ "yacute" => "y\\*'", # small y, acute accent
+ "yuml" => "y\\*:", # small y, dieresis or umlaut mark
+);
+}
+
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/pod/pod2text.PL b/contrib/perl5/pod/pod2text.PL
new file mode 100644
index 000000000000..94516c399782
--- /dev/null
+++ b/contrib/perl5/pod/pod2text.PL
@@ -0,0 +1,51 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+use Pod::Text;
+
+if(@ARGV) {
+ pod2text($ARGV[0]);
+} else {
+ pod2text("<&STDIN");
+}
+
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/pod/roffitall b/contrib/perl5/pod/roffitall
new file mode 100644
index 000000000000..918fe0270ab3
--- /dev/null
+++ b/contrib/perl5/pod/roffitall
@@ -0,0 +1,284 @@
+#!/bin/sh
+#
+# Usage: roffitall [-nroff|-psroff|-groff]
+#
+# Authors: Tom Christiansen, Raphael Manfredi
+
+me=roffitall
+tmp=.
+
+if test -f ../config.sh; then
+ . ../config.sh
+fi
+
+mandir=$installman1dir
+libdir=$installman3dir
+
+test -d $mandir || mandir=/usr/new/man/man1
+test -d $libdir || libdir=/usr/new/man/man3
+
+case "$1" in
+-nroff) cmd="nroff -man"; ext='txt';;
+-psroff) cmd="psroff -t"; ext='ps';;
+-groff) cmd="groff -man"; ext='ps';;
+*)
+ echo "Usage: roffitall [-nroff|-psroff|-groff]" >&2
+ exit 1
+ ;;
+esac
+
+toroff=`
+ echo \
+ $mandir/perl.1 \
+ $mandir/perldata.1 \
+ $mandir/perlsyn.1 \
+ $mandir/perlop.1 \
+ $mandir/perlre.1 \
+ $mandir/perlrun.1 \
+ $mandir/perlfunc.1 \
+ $mandir/perlvar.1 \
+ $mandir/perlsub.1 \
+ $mandir/perlmod.1 \
+ $mandir/perlmodlib.1 \
+ $mandir/perlmodinstall.1 \
+ $mandir/perlform.1 \
+ $mandir/perllocale.1 \
+ $mandir/perlref.1 \
+ $mandir/perldsc.1 \
+ $mandir/perllol.1 \
+ $mandir/perltoot.1 \
+ $mandir/perlobj.1 \
+ $mandir/perltie.1 \
+ $mandir/perlbot.1 \
+ $mandir/perlipc.1 \
+ $mandir/perldebug.1 \
+ $mandir/perldiag.1 \
+ $mandir/perlsec.1 \
+ $mandir/perltrap.1 \
+ $mandir/perlport.1 \
+ $mandir/perlstyle.1 \
+ $mandir/perlpod.1 \
+ $mandir/perlbook.1 \
+ $mandir/perlembed.1 \
+ $mandir/perlapio.1 \
+ $mandir/perlxs.1 \
+ $mandir/perlxstut.1 \
+ $mandir/perlguts.1 \
+ $mandir/perlcall.1 \
+ $mandir/perlhist.1 \
+ $mandir/perldelta.1 \
+ $mandir/perl5004delta.1 \
+ $mandir/perlfaq.1 \
+ $mandir/perlfaq1.1 \
+ $mandir/perlfaq2.1 \
+ $mandir/perlfaq3.1 \
+ $mandir/perlfaq4.1 \
+ $mandir/perlfaq5.1 \
+ $mandir/perlfaq6.1 \
+ $mandir/perlfaq7.1 \
+ $mandir/perlfaq8.1 \
+ $mandir/perlfaq9.1 \
+ \
+ $mandir/a2p.1 \
+ $mandir/c2ph.1 \
+ $mandir/h2ph.1 \
+ $mandir/h2xs.1 \
+ $mandir/perlbug.1 \
+ $mandir/perldoc.1 \
+ $mandir/pl2pm.1 \
+ $mandir/pod2html.1 \
+ $mandir/pod2man.1 \
+ $mandir/s2p.1 \
+ $mandir/splain.1 \
+ $mandir/xsubpp.1 \
+ \
+ $libdir/attrs.3 \
+ $libdir/autouse.3 \
+ $libdir/base.3 \
+ $libdir/blib.3 \
+ $libdir/constant.3 \
+ $libdir/diagnostics.3 \
+ $libdir/fields.3 \
+ $libdir/integer.3 \
+ $libdir/less.3 \
+ $libdir/lib.3 \
+ $libdir/locale.3 \
+ $libdir/ops.3 \
+ $libdir/overload.3 \
+ $libdir/re.3 \
+ $libdir/sigtrap.3 \
+ $libdir/strict.3 \
+ $libdir/subs.3 \
+ $libdir/vars.3 \
+ \
+ $libdir/AnyDBM_File.3 \
+ $libdir/AutoLoader.3 \
+ $libdir/AutoSplit.3 \
+ $libdir/B.3 \
+ $libdir/B::Asmdata.3 \
+ $libdir/B::Assembler.3 \
+ $libdir/B::Bblock.3 \
+ $libdir/B::Bytecode.3 \
+ $libdir/B::C.3 \
+ $libdir/B::CC.3 \
+ $libdir/B::Debug.3 \
+ $libdir/B::Deparse.3 \
+ $libdir/B::Disassembler.3 \
+ $libdir/B::Lint.3 \
+ $libdir/B::Showlex.3 \
+ $libdir/B::Stackobj.3 \
+ $libdir/B::Terse.3 \
+ $libdir/B::Xref.3 \
+ $libdir/Benchmark.3 \
+ $libdir/Carp.3 \
+ $libdir/CGI.3 \
+ $libdir/CGI::Apache.3 \
+ $libdir/CGI::Carp.3 \
+ $libdir/CGI::Cookie.3 \
+ $libdir/CGI::Fast.3 \
+ $libdir/CGI::Push.3 \
+ $libdir/CGI::Switch.3 \
+ $libdir/Class::Struct.3 \
+ $libdir/Config.3 \
+ $libdir/CPAN.3 \
+ $libdir/CPAN::FirstTime.3 \
+ $libdir/CPAN::Nox.3 \
+ $libdir/Cwd.3 \
+ $libdir/Data::Dumper.3 \
+ $libdir/DB_File.3 \
+ $libdir/Devel::SelfStubber.3 \
+ $libdir/DirHandle.3 \
+ $libdir/DynaLoader.3 \
+ $libdir/English.3 \
+ $libdir/Env.3 \
+ $libdir/Errno.3 \
+ $libdir/Exporter.3 \
+ $libdir/ExtUtils::Command.3 \
+ $libdir/ExtUtils::Embed.3 \
+ $libdir/ExtUtils::Install.3 \
+ $libdir/ExtUtils::Installed.3 \
+ $libdir/ExtUtils::Liblist.3 \
+ $libdir/ExtUtils::MakeMaker.3 \
+ $libdir/ExtUtils::Manifest.3 \
+ $libdir/ExtUtils::Miniperl.3 \
+ $libdir/ExtUtils::Mkbootstrap.3 \
+ $libdir/ExtUtils::Mksymlists.3 \
+ $libdir/ExtUtils::MM_OS2.3 \
+ $libdir/ExtUtils::MM_Unix.3 \
+ $libdir/ExtUtils::MM_VMS.3 \
+ $libdir/ExtUtils::MM_Win32.3 \
+ $libdir/ExtUtils::Packlist.3 \
+ $libdir/ExtUtils::testlib.3 \
+ $libdir/Fatal.3 \
+ $libdir/Fcntl.3 \
+ $libdir/File::Basename.3 \
+ $libdir/File::CheckTree.3 \
+ $libdir/File::Compare.3 \
+ $libdir/File::Copy.3 \
+ $libdir/File::DosGlob.3 \
+ $libdir/File::Find.3 \
+ $libdir/File::Path.3 \
+ $libdir/File::Spec.3 \
+ $libdir/File::Spec::Mac.3 \
+ $libdir/File::Spec::OS2.3 \
+ $libdir/File::Spec::Unix.3 \
+ $libdir/File::Spec::VMS.3 \
+ $libdir/File::Spec::Win32.3 \
+ $libdir/File::stat.3 \
+ $libdir/FileCache.3 \
+ $libdir/FileHandle.3 \
+ $libdir/FindBin.3 \
+ $libdir/GDBM_File.3 \
+ $libdir/Getopt::Long.3 \
+ $libdir/Getopt::Std.3 \
+ $libdir/I18N::Collate.3 \
+ $libdir/IO.3 \
+ $libdir/IO::File.3 \
+ $libdir/IO::Handle.3 \
+ $libdir/IO::Pipe.3 \
+ $libdir/IO::Seekable.3 \
+ $libdir/IO::Select.3 \
+ $libdir/IO::Socket.3 \
+ $libdir/IPC::Msg.3 \
+ $libdir/IPC::Open2.3 \
+ $libdir/IPC::Open3.3 \
+ $libdir/IPC::Semaphore.3 \
+ $libdir/IPC::SysV.3 \
+ $libdir/Math::BigFloat.3 \
+ $libdir/Math::BigInt.3 \
+ $libdir/Math::Complex.3 \
+ $libdir/Math::Trig.3 \
+ $libdir/NDBM_File.3 \
+ $libdir/Net::hostent.3 \
+ $libdir/Net::netent.3 \
+ $libdir/Net::Ping.3 \
+ $libdir/Net::protoent.3 \
+ $libdir/Net::servent.3 \
+ $libdir/O.3 \
+ $libdir/Opcode.3 \
+ $libdir/Pod::Html.3 \
+ $libdir/Pod::Text.3 \
+ $libdir/POSIX.3 \
+ $libdir/Safe.3 \
+ $libdir/SDBM_File.3 \
+ $libdir/Search::Dict.3 \
+ $libdir/SelectSaver.3 \
+ $libdir/SelfLoader.3 \
+ $libdir/Shell.3 \
+ $libdir/Socket.3 \
+ $libdir/Symbol.3 \
+ $libdir/Sys::Hostname.3 \
+ $libdir/Sys::Syslog.3 \
+ $libdir/Term::Cap.3 \
+ $libdir/Term::Complete.3 \
+ $libdir/Term::ReadLine.3 \
+ $libdir/Test.3 \
+ $libdir/Test::Harness.3 \
+ $libdir/Text::Abbrev.3 \
+ $libdir/Text::ParseWords.3 \
+ $libdir/Text::Soundex.3 \
+ $libdir/Text::Tabs.3 \
+ $libdir/Text::Wrap.3 \
+ $libdir/Tie::Array.3 \
+ $libdir/Tie::Handle.3 \
+ $libdir/Tie::Hash.3 \
+ $libdir/Tie::RefHash.3 \
+ $libdir/Tie::Scalar.3 \
+ $libdir/Tie::SubstrHash.3 \
+ $libdir/Time::gmtime.3 \
+ $libdir/Time::Local.3 \
+ $libdir/Time::localtime.3 \
+ $libdir/Time::tm.3 \
+ $libdir/UNIVERSAL.3 \
+ $libdir/User::grent.3 \
+ $libdir/User::pwent.3 | \
+ perl -ne 'map { -r && print "$_ " } split'`
+
+ # Bypass internal shell buffer limit -- can't use case
+ if perl -e '$a = shift; exit($a =~ m|/|)' $toroff; then
+ echo "$me: empty file list -- did you run install?" >&2
+ exit 1
+ fi
+
+ #psroff -t -man -rC1 -rD1 -rF1 > $tmp/PerlDoc.ps 2>$tmp/PerlTOC.raw
+ #nroff -man -rC1 -rD1 -rF1 > $tmp/PerlDoc.txt 2>$tmp/PerlTOC.nr.raw
+
+ # First, create the raw data
+ run="$cmd -rC1 -rD1 -rF1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw"
+ echo "$me: running $run"
+ eval $run $toroff
+
+ #Now create the TOC
+ echo "$me: parsing TOC"
+ ./rofftoc $tmp/PerlTOC.$ext.raw > $tmp/PerlTOC.tmp.man
+ run="$cmd $tmp/PerlTOC.tmp.man >$tmp/PerlTOC.$ext"
+ echo "$me: running $run"
+ eval $run
+
+ # Finally, recreate the Doc, without the blank page 0
+ run="$cmd -rC1 -rD1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw"
+ echo "$me: running $run"
+ eval $run $toroff
+ rm -f $tmp/PerlTOC.tmp.man $tmp/PerlTOC.$ext.raw
+ echo "$me: leaving you with $tmp/PerlDoc.$ext and $tmp/PerlTOC.$ext"
+
diff --git a/contrib/perl5/pod/rofftoc b/contrib/perl5/pod/rofftoc
new file mode 100755
index 000000000000..a2d0e7ba2047
--- /dev/null
+++ b/contrib/perl5/pod/rofftoc
@@ -0,0 +1,66 @@
+# feed this into perl
+ eval 'exec perl -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# Usage: rofftoc PerlTOC.xxx.raw
+#
+# Post-processes roffitall output. Called from roffitall to produce
+# a formatted table of contents.
+#
+# Author: Tom Christiansen
+
+print <<'EOF';
+.de NP
+'.sp 0.8i
+.tl ''- % -''
+'bp
+'sp 0.5i
+.tl ''\fB\s+2Perl Table of Contents\s0\fR''
+'sp 0.3i
+..
+.wh -1i NP
+.af % i
+.sp 0.5i
+.tl ''\fB\s+5Perl Table of Contents\s0\fR''
+.sp 0.5i
+.nf
+.na
+EOF
+while (<>) {
+ #chomp;
+ s/Index://;
+ ($type, $page, $desc) = split ' ', $_, 3;
+ $desc =~ s/^"(.*)"$/$1/;
+ if ($type eq 'Title') {
+ ($name = $desc) =~ s/ .*//;
+ next;
+ } elsif ($type eq 'Name') {
+ #print STDERR $page, "\t", $desc;
+ print ".ne 5\n";
+ print ".in 0\n";
+ print ".sp\n";
+ print ".ft B\n";
+ print "$desc\n";
+ print ".ft P\n";
+ print ".in 5n\n";
+ } elsif ($type eq 'Header') {
+ print ".br\n", $page, "\t", $desc;
+ } elsif ($type eq 'Subsection') {
+ print ".br\n", $page, "\t\t", $desc;
+ } elsif ($type eq 'Item') {
+ next if $desc =~ /\\bu/;
+ next unless $name =~ /POSIX|func/i;
+ print ".br\n", $page, "\t\t\t", $desc;
+ }
+}
+__END__
+Index:Title 1 "PERL 1"
+Index:Name 1 "perl - Practical Extraction and Report Language"
+Index:Header 1 "NAME"
+Index:Header 1 "SYNOPSIS"
+Index:Header 2 "DESCRIPTION"
+Index:Item 2 "\(bu Many usability enhancements"
+Index:Item 2 "\(bu Simplified grammar"
+Index:Item 2 "\(bu Lexical scoping"
+Index:Item 2 "\(bu Arbitrarily nested data structures"
+Index:Item 2 "\(bu Modularity and reusability"
diff --git a/contrib/perl5/pod/splitman b/contrib/perl5/pod/splitman
new file mode 100755
index 000000000000..9fe404a0610b
--- /dev/null
+++ b/contrib/perl5/pod/splitman
@@ -0,0 +1,46 @@
+#!/usr/bin/perl
+
+while (<>) {
+ if ($seqno = 1 .. /^\.TH/) {
+ unless ($seqno =~ /e/i) {
+ $header .= $_;
+ }
+ next;
+ }
+
+ if ( /^\.Ip\s*"(.*)"\s*\d+$/) {
+ $desking = 0;
+ $desc = $1;
+ if (name($desc) ne $myname) {
+ $myname = name($desc);
+ print $myname, "\n";
+ open(MAN, "> $myname.3pl");
+ print MAN <<EOALL;
+$header
+.TH $myname 3PL "\\*(RP"
+.SH NAME
+$myname
+.SH SYNOPSIS
+.B $desc
+EOALL
+ } else {
+ print MAN <<EOMORE;
+.br
+.ti +3n
+or
+.br
+.B $desc
+EOMORE
+ }
+ next;
+ }
+ unless ($desking) {
+ print MAN ".SH DESCRIPTION\n";
+ $desking = 1;
+ }
+ print MAN;
+}
+
+sub name {
+ ($_[0] =~ /(\w+)/)[0];
+}
diff --git a/contrib/perl5/pod/splitpod b/contrib/perl5/pod/splitpod
new file mode 100755
index 000000000000..fd38e51acf88
--- /dev/null
+++ b/contrib/perl5/pod/splitpod
@@ -0,0 +1,60 @@
+#!/usr/bin/perl
+
+use lib '../lib'; # If you haven't installed perl yet.
+use Pod::Functions;
+
+local $/ = '';
+
+$cur = '';
+while (<>) {
+
+ next unless /^=(?!cut)/ .. /^=cut/;
+
+ if (s/=item (\S+)/$1/) {
+ #$cur = "POSIX::" . $1;
+ $next{$cur} = $1;
+ $cur = $1;
+ $syn{$cur} .= $_;
+ next;
+ } else {
+ #s,L</,L<POSIX/,g;
+ s,L</,L<perlfunc/,g;
+ push @{$pod{$cur}}, $_ if $cur;
+ }
+}
+
+for $f ( keys %syn ) {
+ next unless $Type{$f};
+ $flavor = $Flavor{$f};
+ $orig = $f;
+ ($name = $f) =~ s/\W//g;
+
+ # deal with several functions sharing a description
+ $func = $orig;
+ $func = $next{$func} until $pod{$func};
+ my $body = join "", @{$pod{$func}};
+
+ # deal with unbalanced =over and =back cause by the split
+ my $has_over = $body =~ /^=over/;
+ my $has_back = $body =~ /^=back/;
+ $body =~ s/^=over\s*//m if $has_over and !$has_back;
+ $body =~ s/^=back\s*//m if $has_back and !$has_over;
+ open (POD, "> $name.pod") || die "can't open $name.pod: $!";
+ print POD <<EOF;
+=head1 NAME
+
+$orig - $flavor
+
+=head1 SYNOPSIS
+
+$syn{$orig}
+
+=head1 DESCRIPTION
+
+$body
+
+EOF
+
+ close POD;
+
+}
diff --git a/contrib/perl5/pp.c b/contrib/perl5/pp.c
new file mode 100644
index 000000000000..35b1552af76f
--- /dev/null
+++ b/contrib/perl5/pp.c
@@ -0,0 +1,4550 @@
+/* pp.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "It's a big house this, and very peculiar. Always a bit more to discover,
+ * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+/*
+ * The compiler on Concurrent CX/UX systems has a subtle bug which only
+ * seems to show up when compiling pp.c - it generates the wrong double
+ * precision constant value for (double)UV_MAX when used inline in the body
+ * of the code below, so this makes a static variable up front (which the
+ * compiler seems to get correct) and uses it in place of UV_MAX below.
+ */
+#ifdef CXUX_BROKEN_CONSTANT_CONVERT
+static double UV_MAX_cxux = ((double)UV_MAX);
+#endif
+
+/*
+ * Types used in bitwise operations.
+ *
+ * Normally we'd just use IV and UV. However, some hardware and
+ * software combinations (e.g. Alpha and current OSF/1) don't have a
+ * floating-point type to use for NV that has adequate bits to fully
+ * hold an IV/UV. (In other words, sizeof(long) == sizeof(double).)
+ *
+ * It just so happens that "int" is the right size almost everywhere.
+ */
+typedef int IBW;
+typedef unsigned UBW;
+
+/*
+ * Mask used after bitwise operations.
+ *
+ * There is at least one realm (Cray word machines) that doesn't
+ * have an integral type (except char) small enough to be represented
+ * in a double without loss; that is, it has no 32-bit type.
+ */
+#if LONGSIZE > 4 && defined(_CRAY) && !defined(_CRAYMPP)
+# define BW_BITS 32
+# define BW_MASK ((1 << BW_BITS) - 1)
+# define BW_SIGN (1 << (BW_BITS - 1))
+# define BWi(i) (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
+# define BWu(u) ((u) & BW_MASK)
+#else
+# define BWi(i) (i)
+# define BWu(u) (u)
+#endif
+
+/*
+ * Offset for integer pack/unpack.
+ *
+ * On architectures where I16 and I32 aren't really 16 and 32 bits,
+ * which for now are all Crays, pack and unpack have to play games.
+ */
+
+/*
+ * These values are required for portability of pack() output.
+ * If they're not right on your machine, then pack() and unpack()
+ * wouldn't work right anyway; you'll need to apply the Cray hack.
+ * (I'd like to check them with #if, but you can't use sizeof() in
+ * the preprocessor.) --???
+ */
+/*
+ The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE
+ defines are now in config.h. --Andy Dougherty April 1998
+ */
+#define SIZE16 2
+#define SIZE32 4
+
+#if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
+# if BYTEORDER == 0x12345678
+# define OFF16(p) (char*)(p)
+# define OFF32(p) (char*)(p)
+# else
+# if BYTEORDER == 0x87654321
+# define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16))
+# define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32))
+# else
+ }}}} bad cray byte order
+# endif
+# endif
+# define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char))
+# define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char))
+# define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16)
+# define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32)
+#else
+# define COPY16(s,p) Copy(s, p, SIZE16, char)
+# define COPY32(s,p) Copy(s, p, SIZE32, char)
+# define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16)
+# define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32)
+#endif
+
+#ifndef PERL_OBJECT
+static void doencodes _((SV* sv, char* s, I32 len));
+static SV* refto _((SV* sv));
+static U32 seed _((void));
+#endif
+
+static bool srand_called = FALSE;
+
+/* variations on pp_null */
+
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+
+/* XXX I can't imagine anyone who doesn't have this actually _needs_
+ it, since pid_t is an integral type.
+ --AD 2/20/1998
+*/
+#ifdef NEED_GETPID_PROTO
+extern Pid_t getpid (void);
+#endif
+
+PP(pp_stub)
+{
+ djSP;
+ if (GIMME_V == G_SCALAR)
+ XPUSHs(&PL_sv_undef);
+ RETURN;
+}
+
+PP(pp_scalar)
+{
+ return NORMAL;
+}
+
+/* Pushy stuff. */
+
+PP(pp_padav)
+{
+ djSP; dTARGET;
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ EXTEND(SP, 1);
+ if (PL_op->op_flags & OPf_REF) {
+ PUSHs(TARG);
+ RETURN;
+ }
+ if (GIMME == G_ARRAY) {
+ I32 maxarg = AvFILL((AV*)TARG) + 1;
+ EXTEND(SP, maxarg);
+ if (SvMAGICAL(TARG)) {
+ U32 i;
+ for (i=0; i < maxarg; i++) {
+ SV **svp = av_fetch((AV*)TARG, i, FALSE);
+ SP[i+1] = (svp) ? *svp : &PL_sv_undef;
+ }
+ }
+ else {
+ Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
+ }
+ SP += maxarg;
+ }
+ else {
+ SV* sv = sv_newmortal();
+ I32 maxarg = AvFILL((AV*)TARG) + 1;
+ sv_setiv(sv, maxarg);
+ PUSHs(sv);
+ }
+ RETURN;
+}
+
+PP(pp_padhv)
+{
+ djSP; dTARGET;
+ I32 gimme;
+
+ XPUSHs(TARG);
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ if (PL_op->op_flags & OPf_REF)
+ RETURN;
+ gimme = GIMME_V;
+ if (gimme == G_ARRAY) {
+ RETURNOP(do_kv(ARGS));
+ }
+ else if (gimme == G_SCALAR) {
+ SV* sv = sv_newmortal();
+ if (HvFILL((HV*)TARG))
+ sv_setpvf(sv, "%ld/%ld",
+ (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
+ else
+ sv_setiv(sv, 0);
+ SETs(sv);
+ }
+ RETURN;
+}
+
+PP(pp_padany)
+{
+ DIE("NOT IMPL LINE %d",__LINE__);
+}
+
+/* Translations. */
+
+PP(pp_rv2gv)
+{
+ djSP; dTOPss;
+
+ if (SvROK(sv)) {
+ wasref:
+ sv = SvRV(sv);
+ if (SvTYPE(sv) == SVt_PVIO) {
+ GV *gv = (GV*) sv_newmortal();
+ gv_init(gv, 0, "", 0, 0);
+ GvIOp(gv) = (IO *)sv;
+ (void)SvREFCNT_inc(sv);
+ sv = (SV*) gv;
+ } else if (SvTYPE(sv) != SVt_PVGV)
+ DIE("Not a GLOB reference");
+ }
+ else {
+ if (SvTYPE(sv) != SVt_PVGV) {
+ char *sym;
+
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvROK(sv))
+ goto wasref;
+ }
+ if (!SvOK(sv)) {
+ if (PL_op->op_flags & OPf_REF ||
+ PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_usym, "a symbol");
+ if (PL_dowarn)
+ warn(warn_uninit);
+ RETSETUNDEF;
+ }
+ sym = SvPV(sv, PL_na);
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_symref, sym, "a symbol");
+ sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
+ }
+ }
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_rv2sv)
+{
+ djSP; dTOPss;
+
+ if (SvROK(sv)) {
+ wasref:
+ sv = SvRV(sv);
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ case SVt_PVHV:
+ case SVt_PVCV:
+ DIE("Not a SCALAR reference");
+ }
+ }
+ else {
+ GV *gv = (GV*)sv;
+ char *sym;
+
+ if (SvTYPE(gv) != SVt_PVGV) {
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvROK(sv))
+ goto wasref;
+ }
+ if (!SvOK(sv)) {
+ if (PL_op->op_flags & OPf_REF ||
+ PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_usym, "a SCALAR");
+ if (PL_dowarn)
+ warn(warn_uninit);
+ RETSETUNDEF;
+ }
+ sym = SvPV(sv, PL_na);
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_symref, sym, "a SCALAR");
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
+ }
+ sv = GvSV(gv);
+ }
+ if (PL_op->op_flags & OPf_MOD) {
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ sv = save_scalar((GV*)TOPs);
+ else if (PL_op->op_private & OPpDEREF)
+ vivify_ref(sv, PL_op->op_private & OPpDEREF);
+ }
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_av2arylen)
+{
+ djSP;
+ AV *av = (AV*)TOPs;
+ SV *sv = AvARYLEN(av);
+ if (!sv) {
+ AvARYLEN(av) = sv = NEWSV(0,0);
+ sv_upgrade(sv, SVt_IV);
+ sv_magic(sv, (SV*)av, '#', Nullch, 0);
+ }
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_pos)
+{
+ djSP; dTARGET; dPOPss;
+
+ if (PL_op->op_flags & OPf_MOD) {
+ if (SvTYPE(TARG) < SVt_PVLV) {
+ sv_upgrade(TARG, SVt_PVLV);
+ sv_magic(TARG, Nullsv, '.', Nullch, 0);
+ }
+
+ LvTYPE(TARG) = '.';
+ if (LvTARG(TARG) != sv) {
+ if (LvTARG(TARG))
+ SvREFCNT_dec(LvTARG(TARG));
+ LvTARG(TARG) = SvREFCNT_inc(sv);
+ }
+ PUSHs(TARG); /* no SvSETMAGIC */
+ RETURN;
+ }
+ else {
+ MAGIC* mg;
+
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ mg = mg_find(sv, 'g');
+ if (mg && mg->mg_len >= 0) {
+ PUSHi(mg->mg_len + PL_curcop->cop_arybase);
+ RETURN;
+ }
+ }
+ RETPUSHUNDEF;
+ }
+}
+
+PP(pp_rv2cv)
+{
+ djSP;
+ GV *gv;
+ HV *stash;
+
+ /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
+ /* (But not in defined().) */
+ CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
+ if (cv) {
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ }
+ else
+ cv = (CV*)&PL_sv_undef;
+ SETs((SV*)cv);
+ RETURN;
+}
+
+PP(pp_prototype)
+{
+ djSP;
+ CV *cv;
+ HV *stash;
+ GV *gv;
+ SV *ret;
+
+ ret = &PL_sv_undef;
+ if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
+ char *s = SvPVX(TOPs);
+ if (strnEQ(s, "CORE::", 6)) {
+ int code;
+
+ code = keyword(s + 6, SvCUR(TOPs) - 6);
+ if (code < 0) { /* Overridable. */
+#define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
+ int i = 0, n = 0, seen_question = 0;
+ I32 oa;
+ char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+
+ while (i < MAXO) { /* The slow way. */
+ if (strEQ(s + 6, op_name[i]) || strEQ(s + 6, op_desc[i]))
+ goto found;
+ i++;
+ }
+ goto nonesuch; /* Should not happen... */
+ found:
+ oa = opargs[i] >> OASHIFT;
+ while (oa) {
+ if (oa & OA_OPTIONAL) {
+ seen_question = 1;
+ str[n++] = ';';
+ } else if (seen_question)
+ goto set; /* XXXX system, exec */
+ if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
+ && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
+ str[n++] = '\\';
+ }
+ /* What to do with R ((un)tie, tied, (sys)read, recv)? */
+ str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
+ oa = oa >> 4;
+ }
+ str[n++] = '\0';
+ ret = sv_2mortal(newSVpv(str, n - 1));
+ } else if (code) /* Non-Overridable */
+ goto set;
+ else { /* None such */
+ nonesuch:
+ croak("Cannot find an opnumber for \"%s\"", s+6);
+ }
+ }
+ }
+ cv = sv_2cv(TOPs, &stash, &gv, FALSE);
+ if (cv && SvPOK(cv))
+ ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
+ set:
+ SETs(ret);
+ RETURN;
+}
+
+PP(pp_anoncode)
+{
+ djSP;
+ CV* cv = (CV*)PL_curpad[PL_op->op_targ];
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ EXTEND(SP,1);
+ PUSHs((SV*)cv);
+ RETURN;
+}
+
+PP(pp_srefgen)
+{
+ djSP;
+ *SP = refto(*SP);
+ RETURN;
+}
+
+PP(pp_refgen)
+{
+ djSP; dMARK;
+ if (GIMME != G_ARRAY) {
+ if (++MARK <= SP)
+ *MARK = *SP;
+ else
+ *MARK = &PL_sv_undef;
+ *MARK = refto(*MARK);
+ SP = MARK;
+ RETURN;
+ }
+ EXTEND_MORTAL(SP - MARK);
+ while (++MARK <= SP)
+ *MARK = refto(*MARK);
+ RETURN;
+}
+
+STATIC SV*
+refto(SV *sv)
+{
+ SV* rv;
+
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
+ if (LvTARGLEN(sv))
+ vivify_defelem(sv);
+ if (!(sv = LvTARG(sv)))
+ sv = &PL_sv_undef;
+ }
+ else if (SvPADTMP(sv))
+ sv = newSVsv(sv);
+ else {
+ SvTEMP_off(sv);
+ (void)SvREFCNT_inc(sv);
+ }
+ rv = sv_newmortal();
+ sv_upgrade(rv, SVt_RV);
+ SvRV(rv) = sv;
+ SvROK_on(rv);
+ return rv;
+}
+
+PP(pp_ref)
+{
+ djSP; dTARGET;
+ SV *sv;
+ char *pv;
+
+ sv = POPs;
+
+ if (sv && SvGMAGICAL(sv))
+ mg_get(sv);
+
+ if (!sv || !SvROK(sv))
+ RETPUSHNO;
+
+ sv = SvRV(sv);
+ pv = sv_reftype(sv,TRUE);
+ PUSHp(pv, strlen(pv));
+ RETURN;
+}
+
+PP(pp_bless)
+{
+ djSP;
+ HV *stash;
+
+ if (MAXARG == 1)
+ stash = PL_curcop->cop_stash;
+ else {
+ SV *ssv = POPs;
+ STRLEN len;
+ char *ptr = SvPV(ssv,len);
+ if (PL_dowarn && len == 0)
+ warn("Explicit blessing to '' (assuming package main)");
+ stash = gv_stashpvn(ptr, len, TRUE);
+ }
+
+ (void)sv_bless(TOPs, stash);
+ RETURN;
+}
+
+PP(pp_gelem)
+{
+ GV *gv;
+ SV *sv;
+ SV *tmpRef;
+ char *elem;
+ djSP;
+
+ sv = POPs;
+ elem = SvPV(sv, PL_na);
+ gv = (GV*)POPs;
+ tmpRef = Nullsv;
+ sv = Nullsv;
+ switch (elem ? *elem : '\0')
+ {
+ case 'A':
+ if (strEQ(elem, "ARRAY"))
+ tmpRef = (SV*)GvAV(gv);
+ break;
+ case 'C':
+ if (strEQ(elem, "CODE"))
+ tmpRef = (SV*)GvCVu(gv);
+ break;
+ case 'F':
+ if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
+ tmpRef = (SV*)GvIOp(gv);
+ break;
+ case 'G':
+ if (strEQ(elem, "GLOB"))
+ tmpRef = (SV*)gv;
+ break;
+ case 'H':
+ if (strEQ(elem, "HASH"))
+ tmpRef = (SV*)GvHV(gv);
+ break;
+ case 'I':
+ if (strEQ(elem, "IO"))
+ tmpRef = (SV*)GvIOp(gv);
+ break;
+ case 'N':
+ if (strEQ(elem, "NAME"))
+ sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
+ break;
+ case 'P':
+ if (strEQ(elem, "PACKAGE"))
+ sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
+ break;
+ case 'S':
+ if (strEQ(elem, "SCALAR"))
+ tmpRef = GvSV(gv);
+ break;
+ }
+ if (tmpRef)
+ sv = newRV(tmpRef);
+ if (sv)
+ sv_2mortal(sv);
+ else
+ sv = &PL_sv_undef;
+ XPUSHs(sv);
+ RETURN;
+}
+
+/* Pattern matching */
+
+PP(pp_study)
+{
+ djSP; dPOPss;
+ register UNOP *unop = cUNOP;
+ register unsigned char *s;
+ register I32 pos;
+ register I32 ch;
+ register I32 *sfirst;
+ register I32 *snext;
+ STRLEN len;
+
+ if (sv == PL_lastscream) {
+ if (SvSCREAM(sv))
+ RETPUSHYES;
+ }
+ else {
+ if (PL_lastscream) {
+ SvSCREAM_off(PL_lastscream);
+ SvREFCNT_dec(PL_lastscream);
+ }
+ PL_lastscream = SvREFCNT_inc(sv);
+ }
+
+ s = (unsigned char*)(SvPV(sv, len));
+ pos = len;
+ if (pos <= 0)
+ RETPUSHNO;
+ if (pos > PL_maxscream) {
+ if (PL_maxscream < 0) {
+ PL_maxscream = pos + 80;
+ New(301, PL_screamfirst, 256, I32);
+ New(302, PL_screamnext, PL_maxscream, I32);
+ }
+ else {
+ PL_maxscream = pos + pos / 4;
+ Renew(PL_screamnext, PL_maxscream, I32);
+ }
+ }
+
+ sfirst = PL_screamfirst;
+ snext = PL_screamnext;
+
+ if (!sfirst || !snext)
+ DIE("do_study: out of memory");
+
+ for (ch = 256; ch; --ch)
+ *sfirst++ = -1;
+ sfirst -= 256;
+
+ while (--pos >= 0) {
+ ch = s[pos];
+ if (sfirst[ch] >= 0)
+ snext[pos] = sfirst[ch] - pos;
+ else
+ snext[pos] = -pos;
+ sfirst[ch] = pos;
+ }
+
+ SvSCREAM_on(sv);
+ sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
+ RETPUSHYES;
+}
+
+PP(pp_trans)
+{
+ djSP; dTARG;
+ SV *sv;
+
+ if (PL_op->op_flags & OPf_STACKED)
+ sv = POPs;
+ else {
+ sv = DEFSV;
+ EXTEND(SP,1);
+ }
+ TARG = sv_newmortal();
+ PUSHi(do_trans(sv, PL_op));
+ RETURN;
+}
+
+/* Lvalue operators. */
+
+PP(pp_schop)
+{
+ djSP; dTARGET;
+ do_chop(TARG, TOPs);
+ SETTARG;
+ RETURN;
+}
+
+PP(pp_chop)
+{
+ djSP; dMARK; dTARGET;
+ while (SP > MARK)
+ do_chop(TARG, POPs);
+ PUSHTARG;
+ RETURN;
+}
+
+PP(pp_schomp)
+{
+ djSP; dTARGET;
+ SETi(do_chomp(TOPs));
+ RETURN;
+}
+
+PP(pp_chomp)
+{
+ djSP; dMARK; dTARGET;
+ register I32 count = 0;
+
+ while (SP > MARK)
+ count += do_chomp(POPs);
+ PUSHi(count);
+ RETURN;
+}
+
+PP(pp_defined)
+{
+ djSP;
+ register SV* sv;
+
+ sv = POPs;
+ if (!sv || !SvANY(sv))
+ RETPUSHNO;
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
+ RETPUSHYES;
+ break;
+ case SVt_PVHV:
+ if (HvARRAY(sv) || SvGMAGICAL(sv))
+ RETPUSHYES;
+ break;
+ case SVt_PVCV:
+ if (CvROOT(sv) || CvXSUB(sv))
+ RETPUSHYES;
+ break;
+ default:
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (SvOK(sv))
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+}
+
+PP(pp_undef)
+{
+ djSP;
+ SV *sv;
+
+ if (!PL_op->op_private) {
+ EXTEND(SP, 1);
+ RETPUSHUNDEF;
+ }
+
+ sv = POPs;
+ if (!sv)
+ RETPUSHUNDEF;
+
+ if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv))
+ RETPUSHUNDEF;
+ if (SvROK(sv))
+ sv_unref(sv);
+ }
+
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ break;
+ case SVt_PVAV:
+ av_undef((AV*)sv);
+ break;
+ case SVt_PVHV:
+ hv_undef((HV*)sv);
+ break;
+ case SVt_PVCV:
+ if (PL_dowarn && cv_const_sv((CV*)sv))
+ warn("Constant subroutine %s undefined",
+ CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
+ /* FALL THROUGH */
+ case SVt_PVFM:
+ { GV* gv = (GV*)SvREFCNT_inc(CvGV((CV*)sv));
+ cv_undef((CV*)sv);
+ CvGV((CV*)sv) = gv; } /* let user-undef'd sub keep its identity */
+ break;
+ case SVt_PVGV:
+ if (SvFAKE(sv))
+ SvSetMagicSV(sv, &PL_sv_undef);
+ else {
+ GP *gp;
+ gp_free((GV*)sv);
+ Newz(602, gp, 1, GP);
+ GvGP(sv) = gp_ref(gp);
+ GvSV(sv) = NEWSV(72,0);
+ GvLINE(sv) = PL_curcop->cop_line;
+ GvEGV(sv) = (GV*)sv;
+ GvMULTI_on(sv);
+ }
+ break;
+ default:
+ if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
+ (void)SvOOK_off(sv);
+ Safefree(SvPVX(sv));
+ SvPV_set(sv, Nullch);
+ SvLEN_set(sv, 0);
+ }
+ (void)SvOK_off(sv);
+ SvSETMAGIC(sv);
+ }
+
+ RETPUSHUNDEF;
+}
+
+PP(pp_predec)
+{
+ djSP;
+ if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ croak(no_modify);
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ SvIVX(TOPs) != IV_MIN)
+ {
+ --SvIVX(TOPs);
+ SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
+ }
+ else
+ sv_dec(TOPs);
+ SvSETMAGIC(TOPs);
+ return NORMAL;
+}
+
+PP(pp_postinc)
+{
+ djSP; dTARGET;
+ if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ croak(no_modify);
+ sv_setsv(TARG, TOPs);
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ SvIVX(TOPs) != IV_MAX)
+ {
+ ++SvIVX(TOPs);
+ SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
+ }
+ else
+ sv_inc(TOPs);
+ SvSETMAGIC(TOPs);
+ if (!SvOK(TARG))
+ sv_setiv(TARG, 0);
+ SETs(TARG);
+ return NORMAL;
+}
+
+PP(pp_postdec)
+{
+ djSP; dTARGET;
+ if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ croak(no_modify);
+ sv_setsv(TARG, TOPs);
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ SvIVX(TOPs) != IV_MIN)
+ {
+ --SvIVX(TOPs);
+ SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
+ }
+ else
+ sv_dec(TOPs);
+ SvSETMAGIC(TOPs);
+ SETs(TARG);
+ return NORMAL;
+}
+
+/* Ordinary operators. */
+
+PP(pp_pow)
+{
+ djSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
+ {
+ dPOPTOPnnrl;
+ SETn( pow( left, right) );
+ RETURN;
+ }
+}
+
+PP(pp_multiply)
+{
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ {
+ dPOPTOPnnrl;
+ SETn( left * right );
+ RETURN;
+ }
+}
+
+PP(pp_divide)
+{
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ {
+ dPOPPOPnnrl;
+ double value;
+ if (right == 0.0)
+ DIE("Illegal division by zero");
+#ifdef SLOPPYDIVIDE
+ /* insure that 20./5. == 4. */
+ {
+ IV k;
+ if ((double)I_V(left) == left &&
+ (double)I_V(right) == right &&
+ (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
+ value = k;
+ } else {
+ value = left / right;
+ }
+ }
+#else
+ value = left / right;
+#endif
+ PUSHn( value );
+ RETURN;
+ }
+}
+
+PP(pp_modulo)
+{
+ djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ UV left;
+ UV right;
+ bool left_neg;
+ bool right_neg;
+ UV ans;
+
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ IV i = SvIVX(POPs);
+ right = (right_neg = (i < 0)) ? -i : i;
+ }
+ else {
+ double n = POPn;
+ right = U_V((right_neg = (n < 0)) ? -n : n);
+ }
+
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ IV i = SvIVX(POPs);
+ left = (left_neg = (i < 0)) ? -i : i;
+ }
+ else {
+ double n = POPn;
+ left = U_V((left_neg = (n < 0)) ? -n : n);
+ }
+
+ if (!right)
+ DIE("Illegal modulus zero");
+
+ ans = left % right;
+ if ((left_neg != right_neg) && ans)
+ ans = right - ans;
+ if (right_neg) {
+ /* XXX may warn: unary minus operator applied to unsigned type */
+ /* could change -foo to be (~foo)+1 instead */
+ if (ans <= ~((UV)IV_MAX)+1)
+ sv_setiv(TARG, ~ans+1);
+ else
+ sv_setnv(TARG, -(double)ans);
+ }
+ else
+ sv_setuv(TARG, ans);
+ PUSHTARG;
+ RETURN;
+ }
+}
+
+PP(pp_repeat)
+{
+ djSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
+ {
+ register I32 count = POPi;
+ if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
+ dMARK;
+ I32 items = SP - MARK;
+ I32 max;
+
+ max = items * count;
+ MEXTEND(MARK, max);
+ if (count > 1) {
+ while (SP > MARK) {
+ if (*SP)
+ SvTEMP_off((*SP));
+ SP--;
+ }
+ MARK++;
+ repeatcpy((char*)(MARK + items), (char*)MARK,
+ items * sizeof(SV*), count - 1);
+ SP += max;
+ }
+ else if (count <= 0)
+ SP -= items;
+ }
+ else { /* Note: mark already snarfed by pp_list */
+ SV *tmpstr;
+ STRLEN len;
+
+ tmpstr = POPs;
+ if (TARG == tmpstr && SvTHINKFIRST(tmpstr)) {
+ if (SvREADONLY(tmpstr) && PL_curcop != &PL_compiling)
+ DIE("Can't x= to readonly value");
+ if (SvROK(tmpstr))
+ sv_unref(tmpstr);
+ }
+ SvSetSV(TARG, tmpstr);
+ SvPV_force(TARG, len);
+ if (count != 1) {
+ if (count < 1)
+ SvCUR_set(TARG, 0);
+ else {
+ SvGROW(TARG, (count * len) + 1);
+ repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
+ SvCUR(TARG) *= count;
+ }
+ *SvEND(TARG) = '\0';
+ }
+ (void)SvPOK_only(TARG);
+ PUSHTARG;
+ }
+ RETURN;
+ }
+}
+
+PP(pp_subtract)
+{
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ {
+ dPOPTOPnnrl_ul;
+ SETn( left - right );
+ RETURN;
+ }
+}
+
+PP(pp_left_shift)
+{
+ djSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
+ {
+ IBW shift = POPi;
+ if (PL_op->op_private & HINT_INTEGER) {
+ IBW i = TOPi;
+ i = BWi(i) << shift;
+ SETi(BWi(i));
+ }
+ else {
+ UBW u = TOPu;
+ u <<= shift;
+ SETu(BWu(u));
+ }
+ RETURN;
+ }
+}
+
+PP(pp_right_shift)
+{
+ djSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
+ {
+ IBW shift = POPi;
+ if (PL_op->op_private & HINT_INTEGER) {
+ IBW i = TOPi;
+ i = BWi(i) >> shift;
+ SETi(BWi(i));
+ }
+ else {
+ UBW u = TOPu;
+ u >>= shift;
+ SETu(BWu(u));
+ }
+ RETURN;
+ }
+}
+
+PP(pp_lt)
+{
+ djSP; tryAMAGICbinSET(lt,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn < value));
+ RETURN;
+ }
+}
+
+PP(pp_gt)
+{
+ djSP; tryAMAGICbinSET(gt,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn > value));
+ RETURN;
+ }
+}
+
+PP(pp_le)
+{
+ djSP; tryAMAGICbinSET(le,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn <= value));
+ RETURN;
+ }
+}
+
+PP(pp_ge)
+{
+ djSP; tryAMAGICbinSET(ge,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn >= value));
+ RETURN;
+ }
+}
+
+PP(pp_ne)
+{
+ djSP; tryAMAGICbinSET(ne,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn != value));
+ RETURN;
+ }
+}
+
+PP(pp_ncmp)
+{
+ djSP; dTARGET; tryAMAGICbin(ncmp,0);
+ {
+ dPOPTOPnnrl;
+ I32 value;
+
+ if (left == right)
+ value = 0;
+ else if (left < right)
+ value = -1;
+ else if (left > right)
+ value = 1;
+ else {
+ SETs(&PL_sv_undef);
+ RETURN;
+ }
+ SETi(value);
+ RETURN;
+ }
+}
+
+PP(pp_slt)
+{
+ djSP; tryAMAGICbinSET(slt,0);
+ {
+ dPOPTOPssrl;
+ int cmp = ((PL_op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp < 0));
+ RETURN;
+ }
+}
+
+PP(pp_sgt)
+{
+ djSP; tryAMAGICbinSET(sgt,0);
+ {
+ dPOPTOPssrl;
+ int cmp = ((PL_op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp > 0));
+ RETURN;
+ }
+}
+
+PP(pp_sle)
+{
+ djSP; tryAMAGICbinSET(sle,0);
+ {
+ dPOPTOPssrl;
+ int cmp = ((PL_op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp <= 0));
+ RETURN;
+ }
+}
+
+PP(pp_sge)
+{
+ djSP; tryAMAGICbinSET(sge,0);
+ {
+ dPOPTOPssrl;
+ int cmp = ((PL_op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp >= 0));
+ RETURN;
+ }
+}
+
+PP(pp_seq)
+{
+ djSP; tryAMAGICbinSET(seq,0);
+ {
+ dPOPTOPssrl;
+ SETs(boolSV(sv_eq(left, right)));
+ RETURN;
+ }
+}
+
+PP(pp_sne)
+{
+ djSP; tryAMAGICbinSET(sne,0);
+ {
+ dPOPTOPssrl;
+ SETs(boolSV(!sv_eq(left, right)));
+ RETURN;
+ }
+}
+
+PP(pp_scmp)
+{
+ djSP; dTARGET; tryAMAGICbin(scmp,0);
+ {
+ dPOPTOPssrl;
+ int cmp = ((PL_op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETi( cmp );
+ RETURN;
+ }
+}
+
+PP(pp_bit_and)
+{
+ djSP; dATARGET; tryAMAGICbin(band,opASSIGN);
+ {
+ dPOPTOPssrl;
+ if (SvNIOKp(left) || SvNIOKp(right)) {
+ if (PL_op->op_private & HINT_INTEGER) {
+ IBW value = SvIV(left) & SvIV(right);
+ SETi(BWi(value));
+ }
+ else {
+ UBW value = SvUV(left) & SvUV(right);
+ SETu(BWu(value));
+ }
+ }
+ else {
+ do_vop(PL_op->op_type, TARG, left, right);
+ SETTARG;
+ }
+ RETURN;
+ }
+}
+
+PP(pp_bit_xor)
+{
+ djSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
+ {
+ dPOPTOPssrl;
+ if (SvNIOKp(left) || SvNIOKp(right)) {
+ if (PL_op->op_private & HINT_INTEGER) {
+ IBW value = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+ SETi(BWi(value));
+ }
+ else {
+ UBW value = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+ SETu(BWu(value));
+ }
+ }
+ else {
+ do_vop(PL_op->op_type, TARG, left, right);
+ SETTARG;
+ }
+ RETURN;
+ }
+}
+
+PP(pp_bit_or)
+{
+ djSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
+ {
+ dPOPTOPssrl;
+ if (SvNIOKp(left) || SvNIOKp(right)) {
+ if (PL_op->op_private & HINT_INTEGER) {
+ IBW value = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+ SETi(BWi(value));
+ }
+ else {
+ UBW value = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+ SETu(BWu(value));
+ }
+ }
+ else {
+ do_vop(PL_op->op_type, TARG, left, right);
+ SETTARG;
+ }
+ RETURN;
+ }
+}
+
+PP(pp_negate)
+{
+ djSP; dTARGET; tryAMAGICun(neg);
+ {
+ dTOPss;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (SvIOKp(sv) && !SvNOKp(sv) && !SvPOKp(sv) && SvIVX(sv) != IV_MIN)
+ SETi(-SvIVX(sv));
+ else if (SvNIOKp(sv))
+ SETn(-SvNV(sv));
+ else if (SvPOKp(sv)) {
+ STRLEN len;
+ char *s = SvPV(sv, len);
+ if (isIDFIRST(*s)) {
+ sv_setpvn(TARG, "-", 1);
+ sv_catsv(TARG, sv);
+ }
+ else if (*s == '+' || *s == '-') {
+ sv_setsv(TARG, sv);
+ *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
+ }
+ else
+ sv_setnv(TARG, -SvNV(sv));
+ SETTARG;
+ }
+ else
+ SETn(-SvNV(sv));
+ }
+ RETURN;
+}
+
+PP(pp_not)
+{
+#ifdef OVERLOAD
+ djSP; tryAMAGICunSET(not);
+#endif /* OVERLOAD */
+ *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
+ return NORMAL;
+}
+
+PP(pp_complement)
+{
+ djSP; dTARGET; tryAMAGICun(compl);
+ {
+ dTOPss;
+ if (SvNIOKp(sv)) {
+ if (PL_op->op_private & HINT_INTEGER) {
+ IBW value = ~SvIV(sv);
+ SETi(BWi(value));
+ }
+ else {
+ UBW value = ~SvUV(sv);
+ SETu(BWu(value));
+ }
+ }
+ else {
+ register char *tmps;
+ register long *tmpl;
+ register I32 anum;
+ STRLEN len;
+
+ SvSetSV(TARG, sv);
+ tmps = SvPV_force(TARG, len);
+ anum = len;
+#ifdef LIBERAL
+ for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
+ *tmps = ~*tmps;
+ tmpl = (long*)tmps;
+ for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
+ *tmpl = ~*tmpl;
+ tmps = (char*)tmpl;
+#endif
+ for ( ; anum > 0; anum--, tmps++)
+ *tmps = ~*tmps;
+
+ SETs(TARG);
+ }
+ RETURN;
+ }
+}
+
+/* integer versions of some of the above */
+
+PP(pp_i_multiply)
+{
+ djSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
+ {
+ dPOPTOPiirl;
+ SETi( left * right );
+ RETURN;
+ }
+}
+
+PP(pp_i_divide)
+{
+ djSP; dATARGET; tryAMAGICbin(div,opASSIGN);
+ {
+ dPOPiv;
+ if (value == 0)
+ DIE("Illegal division by zero");
+ value = POPi / value;
+ PUSHi( value );
+ RETURN;
+ }
+}
+
+PP(pp_i_modulo)
+{
+ djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
+ {
+ dPOPTOPiirl;
+ if (!right)
+ DIE("Illegal modulus zero");
+ SETi( left % right );
+ RETURN;
+ }
+}
+
+PP(pp_i_add)
+{
+ djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ {
+ dPOPTOPiirl;
+ SETi( left + right );
+ RETURN;
+ }
+}
+
+PP(pp_i_subtract)
+{
+ djSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
+ {
+ dPOPTOPiirl;
+ SETi( left - right );
+ RETURN;
+ }
+}
+
+PP(pp_i_lt)
+{
+ djSP; tryAMAGICbinSET(lt,0);
+ {
+ dPOPTOPiirl;
+ SETs(boolSV(left < right));
+ RETURN;
+ }
+}
+
+PP(pp_i_gt)
+{
+ djSP; tryAMAGICbinSET(gt,0);
+ {
+ dPOPTOPiirl;
+ SETs(boolSV(left > right));
+ RETURN;
+ }
+}
+
+PP(pp_i_le)
+{
+ djSP; tryAMAGICbinSET(le,0);
+ {
+ dPOPTOPiirl;
+ SETs(boolSV(left <= right));
+ RETURN;
+ }
+}
+
+PP(pp_i_ge)
+{
+ djSP; tryAMAGICbinSET(ge,0);
+ {
+ dPOPTOPiirl;
+ SETs(boolSV(left >= right));
+ RETURN;
+ }
+}
+
+PP(pp_i_eq)
+{
+ djSP; tryAMAGICbinSET(eq,0);
+ {
+ dPOPTOPiirl;
+ SETs(boolSV(left == right));
+ RETURN;
+ }
+}
+
+PP(pp_i_ne)
+{
+ djSP; tryAMAGICbinSET(ne,0);
+ {
+ dPOPTOPiirl;
+ SETs(boolSV(left != right));
+ RETURN;
+ }
+}
+
+PP(pp_i_ncmp)
+{
+ djSP; dTARGET; tryAMAGICbin(ncmp,0);
+ {
+ dPOPTOPiirl;
+ I32 value;
+
+ if (left > right)
+ value = 1;
+ else if (left < right)
+ value = -1;
+ else
+ value = 0;
+ SETi(value);
+ RETURN;
+ }
+}
+
+PP(pp_i_negate)
+{
+ djSP; dTARGET; tryAMAGICun(neg);
+ SETi(-TOPi);
+ RETURN;
+}
+
+/* High falutin' math. */
+
+PP(pp_atan2)
+{
+ djSP; dTARGET; tryAMAGICbin(atan2,0);
+ {
+ dPOPTOPnnrl;
+ SETn(atan2(left, right));
+ RETURN;
+ }
+}
+
+PP(pp_sin)
+{
+ djSP; dTARGET; tryAMAGICun(sin);
+ {
+ double value;
+ value = POPn;
+ value = sin(value);
+ XPUSHn(value);
+ RETURN;
+ }
+}
+
+PP(pp_cos)
+{
+ djSP; dTARGET; tryAMAGICun(cos);
+ {
+ double value;
+ value = POPn;
+ value = cos(value);
+ XPUSHn(value);
+ RETURN;
+ }
+}
+
+/* Support Configure command-line overrides for rand() functions.
+ After 5.005, perhaps we should replace this by Configure support
+ for drand48(), random(), or rand(). For 5.005, though, maintain
+ compatibility by calling rand() but allow the user to override it.
+ See INSTALL for details. --Andy Dougherty 15 July 1998
+*/
+#ifndef my_rand
+# define my_rand rand
+#endif
+#ifndef my_srand
+# define my_srand srand
+#endif
+
+PP(pp_rand)
+{
+ djSP; dTARGET;
+ double value;
+ if (MAXARG < 1)
+ value = 1.0;
+ else
+ value = POPn;
+ if (value == 0.0)
+ value = 1.0;
+ if (!srand_called) {
+ (void)my_srand((unsigned)seed());
+ srand_called = TRUE;
+ }
+#if RANDBITS == 31
+ value = my_rand() * value / 2147483648.0;
+#else
+#if RANDBITS == 16
+ value = my_rand() * value / 65536.0;
+#else
+#if RANDBITS == 15
+ value = my_rand() * value / 32768.0;
+#else
+ value = my_rand() * value / (double)(((unsigned long)1) << RANDBITS);
+#endif
+#endif
+#endif
+ XPUSHn(value);
+ RETURN;
+}
+
+PP(pp_srand)
+{
+ djSP;
+ UV anum;
+ if (MAXARG < 1)
+ anum = seed();
+ else
+ anum = POPu;
+ (void)my_srand((unsigned)anum);
+ srand_called = TRUE;
+ EXTEND(SP, 1);
+ RETPUSHYES;
+}
+
+STATIC U32
+seed(void)
+{
+ /*
+ * This is really just a quick hack which grabs various garbage
+ * values. It really should be a real hash algorithm which
+ * spreads the effect of every input bit onto every output bit,
+ * if someone who knows about such tings would bother to write it.
+ * Might be a good idea to add that function to CORE as well.
+ * No numbers below come from careful analysis or anyting here,
+ * except they are primes and SEED_C1 > 1E6 to get a full-width
+ * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
+ * probably be bigger too.
+ */
+#if RANDBITS > 16
+# define SEED_C1 1000003
+#define SEED_C4 73819
+#else
+# define SEED_C1 25747
+#define SEED_C4 20639
+#endif
+#define SEED_C2 3
+#define SEED_C3 269
+#define SEED_C5 26107
+
+ dTHR;
+ U32 u;
+#ifdef VMS
+# include <starlet.h>
+ /* when[] = (low 32 bits, high 32 bits) of time since epoch
+ * in 100-ns units, typically incremented ever 10 ms. */
+ unsigned int when[2];
+ _ckvmssts(sys$gettim(when));
+ u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
+#else
+# ifdef HAS_GETTIMEOFDAY
+ struct timeval when;
+ gettimeofday(&when,(struct timezone *) 0);
+ u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
+# else
+ Time_t when;
+ (void)time(&when);
+ u = (U32)SEED_C1 * when;
+# endif
+#endif
+ u += SEED_C3 * (U32)getpid();
+ u += SEED_C4 * (U32)(UV)PL_stack_sp;
+#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
+ u += SEED_C5 * (U32)(UV)&when;
+#endif
+ return u;
+}
+
+PP(pp_exp)
+{
+ djSP; dTARGET; tryAMAGICun(exp);
+ {
+ double value;
+ value = POPn;
+ value = exp(value);
+ XPUSHn(value);
+ RETURN;
+ }
+}
+
+PP(pp_log)
+{
+ djSP; dTARGET; tryAMAGICun(log);
+ {
+ double value;
+ value = POPn;
+ if (value <= 0.0) {
+ SET_NUMERIC_STANDARD();
+ DIE("Can't take log of %g", value);
+ }
+ value = log(value);
+ XPUSHn(value);
+ RETURN;
+ }
+}
+
+PP(pp_sqrt)
+{
+ djSP; dTARGET; tryAMAGICun(sqrt);
+ {
+ double value;
+ value = POPn;
+ if (value < 0.0) {
+ SET_NUMERIC_STANDARD();
+ DIE("Can't take sqrt of %g", value);
+ }
+ value = sqrt(value);
+ XPUSHn(value);
+ RETURN;
+ }
+}
+
+PP(pp_int)
+{
+ djSP; dTARGET;
+ {
+ double value = TOPn;
+ IV iv;
+
+ if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs)) {
+ iv = SvIVX(TOPs);
+ SETi(iv);
+ }
+ else {
+ if (value >= 0.0)
+ (void)modf(value, &value);
+ else {
+ (void)modf(-value, &value);
+ value = -value;
+ }
+ iv = I_V(value);
+ if (iv == value)
+ SETi(iv);
+ else
+ SETn(value);
+ }
+ }
+ RETURN;
+}
+
+PP(pp_abs)
+{
+ djSP; dTARGET; tryAMAGICun(abs);
+ {
+ double value = TOPn;
+ IV iv;
+
+ if (SvIOKp(TOPs) && !SvNOKp(TOPs) && !SvPOKp(TOPs) &&
+ (iv = SvIVX(TOPs)) != IV_MIN) {
+ if (iv < 0)
+ iv = -iv;
+ SETi(iv);
+ }
+ else {
+ if (value < 0.0)
+ value = -value;
+ SETn(value);
+ }
+ }
+ RETURN;
+}
+
+PP(pp_hex)
+{
+ djSP; dTARGET;
+ char *tmps;
+ I32 argtype;
+
+ tmps = POPp;
+ XPUSHu(scan_hex(tmps, 99, &argtype));
+ RETURN;
+}
+
+PP(pp_oct)
+{
+ djSP; dTARGET;
+ UV value;
+ I32 argtype;
+ char *tmps;
+
+ tmps = POPp;
+ while (*tmps && isSPACE(*tmps))
+ tmps++;
+ if (*tmps == '0')
+ tmps++;
+ if (*tmps == 'x')
+ value = scan_hex(++tmps, 99, &argtype);
+ else
+ value = scan_oct(tmps, 99, &argtype);
+ XPUSHu(value);
+ RETURN;
+}
+
+/* String stuff. */
+
+PP(pp_length)
+{
+ djSP; dTARGET;
+ SETi( sv_len(TOPs) );
+ RETURN;
+}
+
+PP(pp_substr)
+{
+ djSP; dTARGET;
+ SV *sv;
+ I32 len;
+ STRLEN curlen;
+ I32 pos;
+ I32 rem;
+ I32 fail;
+ I32 lvalue = PL_op->op_flags & OPf_MOD;
+ char *tmps;
+ I32 arybase = PL_curcop->cop_arybase;
+ char *repl = 0;
+ STRLEN repl_len;
+
+ SvTAINTED_off(TARG); /* decontaminate */
+ if (MAXARG > 2) {
+ if (MAXARG > 3) {
+ sv = POPs;
+ repl = SvPV(sv, repl_len);
+ }
+ len = POPi;
+ }
+ pos = POPi;
+ sv = POPs;
+ PUTBACK;
+ tmps = SvPV(sv, curlen);
+ if (pos >= arybase) {
+ pos -= arybase;
+ rem = curlen-pos;
+ fail = rem;
+ if (MAXARG > 2) {
+ if (len < 0) {
+ rem += len;
+ if (rem < 0)
+ rem = 0;
+ }
+ else if (rem > len)
+ rem = len;
+ }
+ }
+ else {
+ pos += curlen;
+ if (MAXARG < 3)
+ rem = curlen;
+ else if (len >= 0) {
+ rem = pos+len;
+ if (rem > (I32)curlen)
+ rem = curlen;
+ }
+ else {
+ rem = curlen+len;
+ if (rem < pos)
+ rem = pos;
+ }
+ if (pos < 0)
+ pos = 0;
+ fail = rem;
+ rem -= pos;
+ }
+ if (fail < 0) {
+ if (PL_dowarn || lvalue || repl)
+ warn("substr outside of string");
+ RETPUSHUNDEF;
+ }
+ else {
+ tmps += pos;
+ sv_setpvn(TARG, tmps, rem);
+ if (lvalue) { /* it's an lvalue! */
+ if (!SvGMAGICAL(sv)) {
+ if (SvROK(sv)) {
+ SvPV_force(sv,PL_na);
+ if (PL_dowarn)
+ warn("Attempt to use reference as lvalue in substr");
+ }
+ if (SvOK(sv)) /* is it defined ? */
+ (void)SvPOK_only(sv);
+ else
+ sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
+ }
+
+ if (SvTYPE(TARG) < SVt_PVLV) {
+ sv_upgrade(TARG, SVt_PVLV);
+ sv_magic(TARG, Nullsv, 'x', Nullch, 0);
+ }
+
+ LvTYPE(TARG) = 'x';
+ if (LvTARG(TARG) != sv) {
+ if (LvTARG(TARG))
+ SvREFCNT_dec(LvTARG(TARG));
+ LvTARG(TARG) = SvREFCNT_inc(sv);
+ }
+ LvTARGOFF(TARG) = pos;
+ LvTARGLEN(TARG) = rem;
+ }
+ else if (repl)
+ sv_insert(sv, pos, rem, repl, repl_len);
+ }
+ SPAGAIN;
+ PUSHs(TARG); /* avoid SvSETMAGIC here */
+ RETURN;
+}
+
+PP(pp_vec)
+{
+ djSP; dTARGET;
+ register I32 size = POPi;
+ register I32 offset = POPi;
+ register SV *src = POPs;
+ I32 lvalue = PL_op->op_flags & OPf_MOD;
+ STRLEN srclen;
+ unsigned char *s = (unsigned char*)SvPV(src, srclen);
+ unsigned long retnum;
+ I32 len;
+
+ SvTAINTED_off(TARG); /* decontaminate */
+ offset *= size; /* turn into bit offset */
+ len = (offset + size + 7) / 8;
+ if (offset < 0 || size < 1)
+ retnum = 0;
+ else {
+ if (lvalue) { /* it's an lvalue! */
+ if (SvTYPE(TARG) < SVt_PVLV) {
+ sv_upgrade(TARG, SVt_PVLV);
+ sv_magic(TARG, Nullsv, 'v', Nullch, 0);
+ }
+
+ LvTYPE(TARG) = 'v';
+ if (LvTARG(TARG) != src) {
+ if (LvTARG(TARG))
+ SvREFCNT_dec(LvTARG(TARG));
+ LvTARG(TARG) = SvREFCNT_inc(src);
+ }
+ LvTARGOFF(TARG) = offset;
+ LvTARGLEN(TARG) = size;
+ }
+ if (len > srclen) {
+ if (size <= 8)
+ retnum = 0;
+ else {
+ offset >>= 3;
+ if (size == 16) {
+ if (offset >= srclen)
+ retnum = 0;
+ else
+ retnum = (unsigned long) s[offset] << 8;
+ }
+ else if (size == 32) {
+ if (offset >= srclen)
+ retnum = 0;
+ else if (offset + 1 >= srclen)
+ retnum = (unsigned long) s[offset] << 24;
+ else if (offset + 2 >= srclen)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16);
+ else
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8);
+ }
+ }
+ }
+ else if (size < 8)
+ retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
+ else {
+ offset >>= 3;
+ if (size == 8)
+ retnum = s[offset];
+ else if (size == 16)
+ retnum = ((unsigned long) s[offset] << 8) + s[offset+1];
+ else if (size == 32)
+ retnum = ((unsigned long) s[offset] << 24) +
+ ((unsigned long) s[offset + 1] << 16) +
+ (s[offset + 2] << 8) + s[offset+3];
+ }
+ }
+
+ sv_setuv(TARG, (UV)retnum);
+ PUSHs(TARG);
+ RETURN;
+}
+
+PP(pp_index)
+{
+ djSP; dTARGET;
+ SV *big;
+ SV *little;
+ I32 offset;
+ I32 retval;
+ char *tmps;
+ char *tmps2;
+ STRLEN biglen;
+ I32 arybase = PL_curcop->cop_arybase;
+
+ if (MAXARG < 3)
+ offset = 0;
+ else
+ offset = POPi - arybase;
+ little = POPs;
+ big = POPs;
+ tmps = SvPV(big, biglen);
+ if (offset < 0)
+ offset = 0;
+ else if (offset > biglen)
+ offset = biglen;
+ if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
+ (unsigned char*)tmps + biglen, little, 0)))
+ retval = -1 + arybase;
+ else
+ retval = tmps2 - tmps + arybase;
+ PUSHi(retval);
+ RETURN;
+}
+
+PP(pp_rindex)
+{
+ djSP; dTARGET;
+ SV *big;
+ SV *little;
+ STRLEN blen;
+ STRLEN llen;
+ SV *offstr;
+ I32 offset;
+ I32 retval;
+ char *tmps;
+ char *tmps2;
+ I32 arybase = PL_curcop->cop_arybase;
+
+ if (MAXARG >= 3)
+ offstr = POPs;
+ little = POPs;
+ big = POPs;
+ tmps2 = SvPV(little, llen);
+ tmps = SvPV(big, blen);
+ if (MAXARG < 3)
+ offset = blen;
+ else
+ offset = SvIV(offstr) - arybase + llen;
+ if (offset < 0)
+ offset = 0;
+ else if (offset > blen)
+ offset = blen;
+ if (!(tmps2 = rninstr(tmps, tmps + offset,
+ tmps2, tmps2 + llen)))
+ retval = -1 + arybase;
+ else
+ retval = tmps2 - tmps + arybase;
+ PUSHi(retval);
+ RETURN;
+}
+
+PP(pp_sprintf)
+{
+ djSP; dMARK; dORIGMARK; dTARGET;
+#ifdef USE_LOCALE_NUMERIC
+ if (PL_op->op_private & OPpLOCALE)
+ SET_NUMERIC_LOCAL();
+ else
+ SET_NUMERIC_STANDARD();
+#endif
+ do_sprintf(TARG, SP-MARK, MARK+1);
+ TAINT_IF(SvTAINTED(TARG));
+ SP = ORIGMARK;
+ PUSHTARG;
+ RETURN;
+}
+
+PP(pp_ord)
+{
+ djSP; dTARGET;
+ I32 value;
+ char *tmps;
+
+#ifndef I286
+ tmps = POPp;
+ value = (I32) (*tmps & 255);
+#else
+ I32 anum;
+ tmps = POPp;
+ anum = (I32) *tmps;
+ value = (I32) (anum & 255);
+#endif
+ XPUSHi(value);
+ RETURN;
+}
+
+PP(pp_chr)
+{
+ djSP; dTARGET;
+ char *tmps;
+
+ (void)SvUPGRADE(TARG,SVt_PV);
+ SvGROW(TARG,2);
+ SvCUR_set(TARG, 1);
+ tmps = SvPVX(TARG);
+ *tmps++ = POPi;
+ *tmps = '\0';
+ (void)SvPOK_only(TARG);
+ XPUSHs(TARG);
+ RETURN;
+}
+
+PP(pp_crypt)
+{
+ djSP; dTARGET; dPOPTOPssrl;
+#ifdef HAS_CRYPT
+ char *tmps = SvPV(left, PL_na);
+#ifdef FCRYPT
+ sv_setpv(TARG, fcrypt(tmps, SvPV(right, PL_na)));
+#else
+ sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, PL_na)));
+#endif
+#else
+ DIE(
+ "The crypt() function is unimplemented due to excessive paranoia.");
+#endif
+ SETs(TARG);
+ RETURN;
+}
+
+PP(pp_ucfirst)
+{
+ djSP;
+ SV *sv = TOPs;
+ register char *s;
+
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPV_force(sv, PL_na);
+ if (*s) {
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toUPPER_LC(*s);
+ }
+ else
+ *s = toUPPER(*s);
+ }
+
+ RETURN;
+}
+
+PP(pp_lcfirst)
+{
+ djSP;
+ SV *sv = TOPs;
+ register char *s;
+
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+ s = SvPV_force(sv, PL_na);
+ if (*s) {
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toLOWER_LC(*s);
+ }
+ else
+ *s = toLOWER(*s);
+ }
+
+ SETs(sv);
+ RETURN;
+}
+
+PP(pp_uc)
+{
+ djSP;
+ SV *sv = TOPs;
+ register char *s;
+ STRLEN len;
+
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+
+ s = SvPV_force(sv, len);
+ if (len) {
+ register char *send = s + len;
+
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ for (; s < send; s++)
+ *s = toUPPER_LC(*s);
+ }
+ else {
+ for (; s < send; s++)
+ *s = toUPPER(*s);
+ }
+ }
+ RETURN;
+}
+
+PP(pp_lc)
+{
+ djSP;
+ SV *sv = TOPs;
+ register char *s;
+ STRLEN len;
+
+ if (!SvPADTMP(sv)) {
+ dTARGET;
+ sv_setsv(TARG, sv);
+ sv = TARG;
+ SETs(sv);
+ }
+
+ s = SvPV_force(sv, len);
+ if (len) {
+ register char *send = s + len;
+
+ if (PL_op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ for (; s < send; s++)
+ *s = toLOWER_LC(*s);
+ }
+ else {
+ for (; s < send; s++)
+ *s = toLOWER(*s);
+ }
+ }
+ RETURN;
+}
+
+PP(pp_quotemeta)
+{
+ djSP; dTARGET;
+ SV *sv = TOPs;
+ STRLEN len;
+ register char *s = SvPV(sv,len);
+ register char *d;
+
+ if (len) {
+ (void)SvUPGRADE(TARG, SVt_PV);
+ SvGROW(TARG, (len * 2) + 1);
+ d = SvPVX(TARG);
+ while (len--) {
+ if (!isALNUM(*s))
+ *d++ = '\\';
+ *d++ = *s++;
+ }
+ *d = '\0';
+ SvCUR_set(TARG, d - SvPVX(TARG));
+ (void)SvPOK_only(TARG);
+ }
+ else
+ sv_setpvn(TARG, s, len);
+ SETs(TARG);
+ RETURN;
+}
+
+/* Arrays. */
+
+PP(pp_aslice)
+{
+ djSP; dMARK; dORIGMARK;
+ register SV** svp;
+ register AV* av = (AV*)POPs;
+ register I32 lval = PL_op->op_flags & OPf_MOD;
+ I32 arybase = PL_curcop->cop_arybase;
+ I32 elem;
+
+ if (SvTYPE(av) == SVt_PVAV) {
+ if (lval && PL_op->op_private & OPpLVAL_INTRO) {
+ I32 max = -1;
+ for (svp = MARK + 1; svp <= SP; svp++) {
+ elem = SvIVx(*svp);
+ if (elem > max)
+ max = elem;
+ }
+ if (max > AvMAX(av))
+ av_extend(av, max);
+ }
+ while (++MARK <= SP) {
+ elem = SvIVx(*MARK);
+
+ if (elem > 0)
+ elem -= arybase;
+ svp = av_fetch(av, elem, lval);
+ if (lval) {
+ if (!svp || *svp == &PL_sv_undef)
+ DIE(no_aelem, elem);
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ save_aelem(av, elem, svp);
+ }
+ *MARK = svp ? *svp : &PL_sv_undef;
+ }
+ }
+ if (GIMME != G_ARRAY) {
+ MARK = ORIGMARK;
+ *++MARK = *SP;
+ SP = MARK;
+ }
+ RETURN;
+}
+
+/* Associative arrays. */
+
+PP(pp_each)
+{
+ djSP; dTARGET;
+ HV *hash = (HV*)POPs;
+ HE *entry;
+ I32 gimme = GIMME_V;
+ I32 realhv = (SvTYPE(hash) == SVt_PVHV);
+
+ PUTBACK;
+ /* might clobber stack_sp */
+ entry = realhv ? hv_iternext(hash) : avhv_iternext((AV*)hash);
+ SPAGAIN;
+
+ EXTEND(SP, 2);
+ if (entry) {
+ PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
+ if (gimme == G_ARRAY) {
+ PUTBACK;
+ /* might clobber stack_sp */
+ sv_setsv(TARG, realhv ?
+ hv_iterval(hash, entry) : avhv_iterval((AV*)hash, entry));
+ SPAGAIN;
+ PUSHs(TARG);
+ }
+ }
+ else if (gimme == G_SCALAR)
+ RETPUSHUNDEF;
+
+ RETURN;
+}
+
+PP(pp_values)
+{
+ return do_kv(ARGS);
+}
+
+PP(pp_keys)
+{
+ return do_kv(ARGS);
+}
+
+PP(pp_delete)
+{
+ djSP;
+ I32 gimme = GIMME_V;
+ I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
+ SV *sv;
+ HV *hv;
+
+ if (PL_op->op_private & OPpSLICE) {
+ dMARK; dORIGMARK;
+ U32 hvtype;
+ hv = (HV*)POPs;
+ hvtype = SvTYPE(hv);
+ while (++MARK <= SP) {
+ if (hvtype == SVt_PVHV)
+ sv = hv_delete_ent(hv, *MARK, discard, 0);
+ else
+ DIE("Not a HASH reference");
+ *MARK = sv ? sv : &PL_sv_undef;
+ }
+ if (discard)
+ SP = ORIGMARK;
+ else if (gimme == G_SCALAR) {
+ MARK = ORIGMARK;
+ *++MARK = *SP;
+ SP = MARK;
+ }
+ }
+ else {
+ SV *keysv = POPs;
+ hv = (HV*)POPs;
+ if (SvTYPE(hv) == SVt_PVHV)
+ sv = hv_delete_ent(hv, keysv, discard, 0);
+ else
+ DIE("Not a HASH reference");
+ if (!sv)
+ sv = &PL_sv_undef;
+ if (!discard)
+ PUSHs(sv);
+ }
+ RETURN;
+}
+
+PP(pp_exists)
+{
+ djSP;
+ SV *tmpsv = POPs;
+ HV *hv = (HV*)POPs;
+ if (SvTYPE(hv) == SVt_PVHV) {
+ if (hv_exists_ent(hv, tmpsv, 0))
+ RETPUSHYES;
+ } else if (SvTYPE(hv) == SVt_PVAV) {
+ if (avhv_exists_ent((AV*)hv, tmpsv, 0))
+ RETPUSHYES;
+ } else {
+ DIE("Not a HASH reference");
+ }
+ RETPUSHNO;
+}
+
+PP(pp_hslice)
+{
+ djSP; dMARK; dORIGMARK;
+ register HV *hv = (HV*)POPs;
+ register I32 lval = PL_op->op_flags & OPf_MOD;
+ I32 realhv = (SvTYPE(hv) == SVt_PVHV);
+
+ if (!realhv && PL_op->op_private & OPpLVAL_INTRO)
+ DIE("Can't localize pseudo-hash element");
+
+ if (realhv || SvTYPE(hv) == SVt_PVAV) {
+ while (++MARK <= SP) {
+ SV *keysv = *MARK;
+ SV **svp;
+ if (realhv) {
+ HE *he = hv_fetch_ent(hv, keysv, lval, 0);
+ svp = he ? &HeVAL(he) : 0;
+ } else {
+ svp = avhv_fetch_ent((AV*)hv, keysv, lval, 0);
+ }
+ if (lval) {
+ if (!svp || *svp == &PL_sv_undef)
+ DIE(no_helem, SvPV(keysv, PL_na));
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ save_helem(hv, keysv, svp);
+ }
+ *MARK = svp ? *svp : &PL_sv_undef;
+ }
+ }
+ if (GIMME != G_ARRAY) {
+ MARK = ORIGMARK;
+ *++MARK = *SP;
+ SP = MARK;
+ }
+ RETURN;
+}
+
+/* List operators. */
+
+PP(pp_list)
+{
+ djSP; dMARK;
+ if (GIMME != G_ARRAY) {
+ if (++MARK <= SP)
+ *MARK = *SP; /* unwanted list, return last item */
+ else
+ *MARK = &PL_sv_undef;
+ SP = MARK;
+ }
+ RETURN;
+}
+
+PP(pp_lslice)
+{
+ djSP;
+ SV **lastrelem = PL_stack_sp;
+ SV **lastlelem = PL_stack_base + POPMARK;
+ SV **firstlelem = PL_stack_base + POPMARK + 1;
+ register SV **firstrelem = lastlelem + 1;
+ I32 arybase = PL_curcop->cop_arybase;
+ I32 lval = PL_op->op_flags & OPf_MOD;
+ I32 is_something_there = lval;
+
+ register I32 max = lastrelem - lastlelem;
+ register SV **lelem;
+ register I32 ix;
+
+ if (GIMME != G_ARRAY) {
+ ix = SvIVx(*lastlelem);
+ if (ix < 0)
+ ix += max;
+ else
+ ix -= arybase;
+ if (ix < 0 || ix >= max)
+ *firstlelem = &PL_sv_undef;
+ else
+ *firstlelem = firstrelem[ix];
+ SP = firstlelem;
+ RETURN;
+ }
+
+ if (max == 0) {
+ SP = firstlelem - 1;
+ RETURN;
+ }
+
+ for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
+ ix = SvIVx(*lelem);
+ if (ix < 0) {
+ ix += max;
+ if (ix < 0)
+ *lelem = &PL_sv_undef;
+ else if (!(*lelem = firstrelem[ix]))
+ *lelem = &PL_sv_undef;
+ }
+ else {
+ ix -= arybase;
+ if (ix >= max || !(*lelem = firstrelem[ix]))
+ *lelem = &PL_sv_undef;
+ }
+ if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
+ is_something_there = TRUE;
+ }
+ if (is_something_there)
+ SP = lastlelem;
+ else
+ SP = firstlelem - 1;
+ RETURN;
+}
+
+PP(pp_anonlist)
+{
+ djSP; dMARK; dORIGMARK;
+ I32 items = SP - MARK;
+ SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
+ SP = ORIGMARK; /* av_make() might realloc stack_sp */
+ XPUSHs(av);
+ RETURN;
+}
+
+PP(pp_anonhash)
+{
+ djSP; dMARK; dORIGMARK;
+ HV* hv = (HV*)sv_2mortal((SV*)newHV());
+
+ while (MARK < SP) {
+ SV* key = *++MARK;
+ SV *val = NEWSV(46, 0);
+ if (MARK < SP)
+ sv_setsv(val, *++MARK);
+ else if (PL_dowarn)
+ warn("Odd number of elements in hash assignment");
+ (void)hv_store_ent(hv,key,val,0);
+ }
+ SP = ORIGMARK;
+ XPUSHs((SV*)hv);
+ RETURN;
+}
+
+PP(pp_splice)
+{
+ djSP; dMARK; dORIGMARK;
+ register AV *ary = (AV*)*++MARK;
+ register SV **src;
+ register SV **dst;
+ register I32 i;
+ register I32 offset;
+ register I32 length;
+ I32 newlen;
+ I32 after;
+ I32 diff;
+ SV **tmparyval = 0;
+ MAGIC *mg;
+
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ *MARK-- = mg->mg_obj;
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ perl_call_method("SPLICE",GIMME_V);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+
+ SP++;
+
+ if (++MARK < SP) {
+ offset = i = SvIVx(*MARK);
+ if (offset < 0)
+ offset += AvFILLp(ary) + 1;
+ else
+ offset -= PL_curcop->cop_arybase;
+ if (offset < 0)
+ DIE(no_aelem, i);
+ if (++MARK < SP) {
+ length = SvIVx(*MARK++);
+ if (length < 0) {
+ length += AvFILLp(ary) - offset + 1;
+ if (length < 0)
+ length = 0;
+ }
+ }
+ else
+ length = AvMAX(ary) + 1; /* close enough to infinity */
+ }
+ else {
+ offset = 0;
+ length = AvMAX(ary) + 1;
+ }
+ if (offset > AvFILLp(ary) + 1)
+ offset = AvFILLp(ary) + 1;
+ after = AvFILLp(ary) + 1 - (offset + length);
+ if (after < 0) { /* not that much array */
+ length += after; /* offset+length now in array */
+ after = 0;
+ if (!AvALLOC(ary))
+ av_extend(ary, 0);
+ }
+
+ /* At this point, MARK .. SP-1 is our new LIST */
+
+ newlen = SP - MARK;
+ diff = newlen - length;
+ if (newlen && !AvREAL(ary)) {
+ if (AvREIFY(ary))
+ av_reify(ary);
+ else
+ assert(AvREAL(ary)); /* would leak, so croak */
+ }
+
+ if (diff < 0) { /* shrinking the area */
+ if (newlen) {
+ New(451, tmparyval, newlen, SV*); /* so remember insertion */
+ Copy(MARK, tmparyval, newlen, SV*);
+ }
+
+ MARK = ORIGMARK + 1;
+ if (GIMME == G_ARRAY) { /* copy return vals to stack */
+ MEXTEND(MARK, length);
+ Copy(AvARRAY(ary)+offset, MARK, length, SV*);
+ if (AvREAL(ary)) {
+ EXTEND_MORTAL(length);
+ for (i = length, dst = MARK; i; i--) {
+ sv_2mortal(*dst); /* free them eventualy */
+ dst++;
+ }
+ }
+ MARK += length - 1;
+ }
+ else {
+ *MARK = AvARRAY(ary)[offset+length-1];
+ if (AvREAL(ary)) {
+ sv_2mortal(*MARK);
+ for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
+ SvREFCNT_dec(*dst++); /* free them now */
+ }
+ }
+ AvFILLp(ary) += diff;
+
+ /* pull up or down? */
+
+ if (offset < after) { /* easier to pull up */
+ if (offset) { /* esp. if nothing to pull */
+ src = &AvARRAY(ary)[offset-1];
+ dst = src - diff; /* diff is negative */
+ for (i = offset; i > 0; i--) /* can't trust Copy */
+ *dst-- = *src--;
+ }
+ dst = AvARRAY(ary);
+ SvPVX(ary) = (char*)(AvARRAY(ary) - diff); /* diff is negative */
+ AvMAX(ary) += diff;
+ }
+ else {
+ if (after) { /* anything to pull down? */
+ src = AvARRAY(ary) + offset + length;
+ dst = src + diff; /* diff is negative */
+ Move(src, dst, after, SV*);
+ }
+ dst = &AvARRAY(ary)[AvFILLp(ary)+1];
+ /* avoid later double free */
+ }
+ i = -diff;
+ while (i)
+ dst[--i] = &PL_sv_undef;
+
+ if (newlen) {
+ for (src = tmparyval, dst = AvARRAY(ary) + offset;
+ newlen; newlen--) {
+ *dst = NEWSV(46, 0);
+ sv_setsv(*dst++, *src++);
+ }
+ Safefree(tmparyval);
+ }
+ }
+ else { /* no, expanding (or same) */
+ if (length) {
+ New(452, tmparyval, length, SV*); /* so remember deletion */
+ Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
+ }
+
+ if (diff > 0) { /* expanding */
+
+ /* push up or down? */
+
+ if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
+ if (offset) {
+ src = AvARRAY(ary);
+ dst = src - diff;
+ Move(src, dst, offset, SV*);
+ }
+ SvPVX(ary) = (char*)(AvARRAY(ary) - diff);/* diff is positive */
+ AvMAX(ary) += diff;
+ AvFILLp(ary) += diff;
+ }
+ else {
+ if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
+ av_extend(ary, AvFILLp(ary) + diff);
+ AvFILLp(ary) += diff;
+
+ if (after) {
+ dst = AvARRAY(ary) + AvFILLp(ary);
+ src = dst - diff;
+ for (i = after; i; i--) {
+ *dst-- = *src--;
+ }
+ }
+ }
+ }
+
+ for (src = MARK, dst = AvARRAY(ary) + offset; newlen; newlen--) {
+ *dst = NEWSV(46, 0);
+ sv_setsv(*dst++, *src++);
+ }
+ MARK = ORIGMARK + 1;
+ if (GIMME == G_ARRAY) { /* copy return vals to stack */
+ if (length) {
+ Copy(tmparyval, MARK, length, SV*);
+ if (AvREAL(ary)) {
+ EXTEND_MORTAL(length);
+ for (i = length, dst = MARK; i; i--) {
+ sv_2mortal(*dst); /* free them eventualy */
+ dst++;
+ }
+ }
+ Safefree(tmparyval);
+ }
+ MARK += length - 1;
+ }
+ else if (length--) {
+ *MARK = tmparyval[length];
+ if (AvREAL(ary)) {
+ sv_2mortal(*MARK);
+ while (length-- > 0)
+ SvREFCNT_dec(tmparyval[length]);
+ }
+ Safefree(tmparyval);
+ }
+ else
+ *MARK = &PL_sv_undef;
+ }
+ SP = MARK;
+ RETURN;
+}
+
+PP(pp_push)
+{
+ djSP; dMARK; dORIGMARK; dTARGET;
+ register AV *ary = (AV*)*++MARK;
+ register SV *sv = &PL_sv_undef;
+ MAGIC *mg;
+
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ *MARK-- = mg->mg_obj;
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ LEAVE;
+ SPAGAIN;
+ }
+ else {
+ /* Why no pre-extend of ary here ? */
+ for (++MARK; MARK <= SP; MARK++) {
+ sv = NEWSV(51, 0);
+ if (*MARK)
+ sv_setsv(sv, *MARK);
+ av_push(ary, sv);
+ }
+ }
+ SP = ORIGMARK;
+ PUSHi( AvFILL(ary) + 1 );
+ RETURN;
+}
+
+PP(pp_pop)
+{
+ djSP;
+ AV *av = (AV*)POPs;
+ SV *sv = av_pop(av);
+ if (AvREAL(av))
+ (void)sv_2mortal(sv);
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_shift)
+{
+ djSP;
+ AV *av = (AV*)POPs;
+ SV *sv = av_shift(av);
+ EXTEND(SP, 1);
+ if (!sv)
+ RETPUSHUNDEF;
+ if (AvREAL(av))
+ (void)sv_2mortal(sv);
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_unshift)
+{
+ djSP; dMARK; dORIGMARK; dTARGET;
+ register AV *ary = (AV*)*++MARK;
+ register SV *sv;
+ register I32 i = 0;
+ MAGIC *mg;
+
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV*)ary,'P'))) {
+ *MARK-- = mg->mg_obj;
+ PUSHMARK(MARK);
+ PUTBACK;
+ ENTER;
+ perl_call_method("UNSHIFT",G_SCALAR|G_DISCARD);
+ LEAVE;
+ SPAGAIN;
+ }
+ else {
+ av_unshift(ary, SP - MARK);
+ while (MARK < SP) {
+ sv = NEWSV(27, 0);
+ sv_setsv(sv, *++MARK);
+ (void)av_store(ary, i++, sv);
+ }
+ }
+ SP = ORIGMARK;
+ PUSHi( AvFILL(ary) + 1 );
+ RETURN;
+}
+
+PP(pp_reverse)
+{
+ djSP; dMARK;
+ register SV *tmp;
+ SV **oldsp = SP;
+
+ if (GIMME == G_ARRAY) {
+ MARK++;
+ while (MARK < SP) {
+ tmp = *MARK;
+ *MARK++ = *SP;
+ *SP-- = tmp;
+ }
+ SP = oldsp;
+ }
+ else {
+ register char *up;
+ register char *down;
+ register I32 tmp;
+ dTARGET;
+ STRLEN len;
+
+ if (SP - MARK > 1)
+ do_join(TARG, &PL_sv_no, MARK, SP);
+ else
+ sv_setsv(TARG, (SP > MARK) ? *SP : DEFSV);
+ up = SvPV_force(TARG, len);
+ if (len > 1) {
+ down = SvPVX(TARG) + len - 1;
+ while (down > up) {
+ tmp = *up;
+ *up++ = *down;
+ *down-- = tmp;
+ }
+ (void)SvPOK_only(TARG);
+ }
+ SP = MARK + 1;
+ SETTARG;
+ }
+ RETURN;
+}
+
+STATIC SV *
+mul128(SV *sv, U8 m)
+{
+ STRLEN len;
+ char *s = SvPV(sv, len);
+ char *t;
+ U32 i = 0;
+
+ if (!strnEQ(s, "0000", 4)) { /* need to grow sv */
+ SV *tmpNew = newSVpv("0000000000", 10);
+
+ sv_catsv(tmpNew, sv);
+ SvREFCNT_dec(sv); /* free old sv */
+ sv = tmpNew;
+ s = SvPV(sv, len);
+ }
+ t = s + len - 1;
+ while (!*t) /* trailing '\0'? */
+ t--;
+ while (t > s) {
+ i = ((*t - '0') << 7) + m;
+ *(t--) = '0' + (i % 10);
+ m = i / 10;
+ }
+ return (sv);
+}
+
+/* Explosives and implosives. */
+
+static const char uuemap[] =
+ "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
+static char uudmap[256]; /* Initialised on first use */
+#if 'I' == 73 && 'J' == 74
+/* On an ASCII/ISO kind of system */
+#define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a')
+#else
+/*
+ Some other sort of character set - use memchr() so we don't match
+ the null byte.
+ */
+#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1) || (ch) == ' ')
+#endif
+
+PP(pp_unpack)
+{
+ djSP;
+ dPOPPOPssrl;
+ SV **oldsp = SP;
+ I32 gimme = GIMME_V;
+ SV *sv;
+ STRLEN llen;
+ STRLEN rlen;
+ register char *pat = SvPV(left, llen);
+ register char *s = SvPV(right, rlen);
+ char *strend = s + rlen;
+ char *strbeg = s;
+ register char *patend = pat + llen;
+ I32 datumtype;
+ register I32 len;
+ register I32 bits;
+
+ /* These must not be in registers: */
+ I16 ashort;
+ int aint;
+ I32 along;
+#ifdef HAS_QUAD
+ Quad_t aquad;
+#endif
+ U16 aushort;
+ unsigned int auint;
+ U32 aulong;
+#ifdef HAS_QUAD
+ unsigned Quad_t auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+ I32 checksum = 0;
+ register U32 culong;
+ double cdouble;
+ static char* bitcount = 0;
+ int commas = 0;
+
+ if (gimme != G_ARRAY) { /* arrange to do first one only */
+ /*SUPPRESS 530*/
+ for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
+ if (strchr("aAbBhHP", *patend) || *pat == '%') {
+ patend++;
+ while (isDIGIT(*patend) || *patend == '*')
+ patend++;
+ }
+ else
+ patend++;
+ }
+ while (pat < patend) {
+ reparse:
+ datumtype = *pat++ & 0xFF;
+ if (isSPACE(datumtype))
+ continue;
+ if (pat >= patend)
+ len = 1;
+ else if (*pat == '*') {
+ len = strend - strbeg; /* long enough */
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = (datumtype != '@');
+ switch(datumtype) {
+ default:
+ croak("Invalid type in unpack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && PL_dowarn)
+ warn("Invalid type in unpack: '%c'", (int)datumtype);
+ break;
+ case '%':
+ if (len == 1 && pat[-1] != '1')
+ len = 16;
+ checksum = len;
+ culong = 0;
+ cdouble = 0;
+ if (pat < patend)
+ goto reparse;
+ break;
+ case '@':
+ if (len > strend - strbeg)
+ DIE("@ outside of string");
+ s = strbeg + len;
+ break;
+ case 'X':
+ if (len > s - strbeg)
+ DIE("X outside of string");
+ s -= len;
+ break;
+ case 'x':
+ if (len > strend - s)
+ DIE("x outside of string");
+ s += len;
+ break;
+ case 'A':
+ case 'a':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum)
+ goto uchar_checksum;
+ sv = NEWSV(35, len);
+ sv_setpvn(sv, s, len);
+ s += len;
+ if (datumtype == 'A') {
+ aptr = s; /* borrow register */
+ s = SvPVX(sv) + len - 1;
+ while (s >= SvPVX(sv) && (!*s || isSPACE(*s)))
+ s--;
+ *++s = '\0';
+ SvCUR_set(sv, s - SvPVX(sv));
+ s = aptr; /* unborrow register */
+ }
+ XPUSHs(sv_2mortal(sv));
+ break;
+ case 'B':
+ case 'b':
+ if (pat[-1] == '*' || len > (strend - s) * 8)
+ len = (strend - s) * 8;
+ if (checksum) {
+ if (!bitcount) {
+ Newz(601, bitcount, 256, char);
+ for (bits = 1; bits < 256; bits++) {
+ if (bits & 1) bitcount[bits]++;
+ if (bits & 2) bitcount[bits]++;
+ if (bits & 4) bitcount[bits]++;
+ if (bits & 8) bitcount[bits]++;
+ if (bits & 16) bitcount[bits]++;
+ if (bits & 32) bitcount[bits]++;
+ if (bits & 64) bitcount[bits]++;
+ if (bits & 128) bitcount[bits]++;
+ }
+ }
+ while (len >= 8) {
+ culong += bitcount[*(unsigned char*)s++];
+ len -= 8;
+ }
+ if (len) {
+ bits = *s;
+ if (datumtype == 'b') {
+ while (len-- > 0) {
+ if (bits & 1) culong++;
+ bits >>= 1;
+ }
+ }
+ else {
+ while (len-- > 0) {
+ if (bits & 128) culong++;
+ bits <<= 1;
+ }
+ }
+ }
+ break;
+ }
+ sv = NEWSV(35, len + 1);
+ SvCUR_set(sv, len);
+ SvPOK_on(sv);
+ aptr = pat; /* borrow register */
+ pat = SvPVX(sv);
+ if (datumtype == 'b') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7) /*SUPPRESS 595*/
+ bits >>= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + (bits & 1);
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 7)
+ bits <<= 1;
+ else
+ bits = *s++;
+ *pat++ = '0' + ((bits & 128) != 0);
+ }
+ }
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ XPUSHs(sv_2mortal(sv));
+ break;
+ case 'H':
+ case 'h':
+ if (pat[-1] == '*' || len > (strend - s) * 2)
+ len = (strend - s) * 2;
+ sv = NEWSV(35, len + 1);
+ SvCUR_set(sv, len);
+ SvPOK_on(sv);
+ aptr = pat; /* borrow register */
+ pat = SvPVX(sv);
+ if (datumtype == 'h') {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits >>= 4;
+ else
+ bits = *s++;
+ *pat++ = PL_hexdigit[bits & 15];
+ }
+ }
+ else {
+ aint = len;
+ for (len = 0; len < aint; len++) {
+ if (len & 1)
+ bits <<= 4;
+ else
+ bits = *s++;
+ *pat++ = PL_hexdigit[(bits >> 4) & 15];
+ }
+ }
+ *pat = '\0';
+ pat = aptr; /* unborrow register */
+ XPUSHs(sv_2mortal(sv));
+ break;
+ case 'c':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ while (len-- > 0) {
+ aint = *s++;
+ if (aint >= 128) /* fake up signed chars */
+ aint -= 256;
+ culong += aint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ aint = *s++;
+ if (aint >= 128) /* fake up signed chars */
+ aint -= 256;
+ sv = NEWSV(36, 0);
+ sv_setiv(sv, (IV)aint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'C':
+ if (len > strend - s)
+ len = strend - s;
+ if (checksum) {
+ uchar_checksum:
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ culong += auint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ auint = *s++ & 255;
+ sv = NEWSV(37, 0);
+ sv_setiv(sv, (IV)auint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 's':
+ along = (strend - s) / SIZE16;
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ COPY16(s, &ashort);
+ s += SIZE16;
+ culong += ashort;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ COPY16(s, &ashort);
+ s += SIZE16;
+ sv = NEWSV(38, 0);
+ sv_setiv(sv, (IV)ashort);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'v':
+ case 'n':
+ case 'S':
+ along = (strend - s) / SIZE16;
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ COPY16(s, &aushort);
+ s += SIZE16;
+#ifdef HAS_NTOHS
+ if (datumtype == 'n')
+ aushort = PerlSock_ntohs(aushort);
+#endif
+#ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+#endif
+ culong += aushort;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ COPY16(s, &aushort);
+ s += SIZE16;
+ sv = NEWSV(39, 0);
+#ifdef HAS_NTOHS
+ if (datumtype == 'n')
+ aushort = PerlSock_ntohs(aushort);
+#endif
+#ifdef HAS_VTOHS
+ if (datumtype == 'v')
+ aushort = vtohs(aushort);
+#endif
+ sv_setiv(sv, (IV)aushort);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'i':
+ along = (strend - s) / sizeof(int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &aint, 1, int);
+ s += sizeof(int);
+ if (checksum > 32)
+ cdouble += (double)aint;
+ else
+ culong += aint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ Copy(s, &aint, 1, int);
+ s += sizeof(int);
+ sv = NEWSV(40, 0);
+#ifdef __osf__
+ /* Without the dummy below unpack("i", pack("i",-1))
+ * return 0xFFffFFff instead of -1 for Digital Unix V4.0
+ * cc with optimization turned on */
+ (aint) ?
+ sv_setiv(sv, (IV)aint) :
+#endif
+ sv_setiv(sv, (IV)aint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'I':
+ along = (strend - s) / sizeof(unsigned int);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &auint, 1, unsigned int);
+ s += sizeof(unsigned int);
+ if (checksum > 32)
+ cdouble += (double)auint;
+ else
+ culong += auint;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ Copy(s, &auint, 1, unsigned int);
+ s += sizeof(unsigned int);
+ sv = NEWSV(41, 0);
+ sv_setuv(sv, (UV)auint);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'l':
+ along = (strend - s) / SIZE32;
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ COPY32(s, &along);
+ s += SIZE32;
+ if (checksum > 32)
+ cdouble += (double)along;
+ else
+ culong += along;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ COPY32(s, &along);
+ s += SIZE32;
+ sv = NEWSV(42, 0);
+ sv_setiv(sv, (IV)along);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'V':
+ case 'N':
+ case 'L':
+ along = (strend - s) / SIZE32;
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ COPY32(s, &aulong);
+ s += SIZE32;
+#ifdef HAS_NTOHL
+ if (datumtype == 'N')
+ aulong = PerlSock_ntohl(aulong);
+#endif
+#ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
+#endif
+ if (checksum > 32)
+ cdouble += (double)aulong;
+ else
+ culong += aulong;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ COPY32(s, &aulong);
+ s += SIZE32;
+#ifdef HAS_NTOHL
+ if (datumtype == 'N')
+ aulong = PerlSock_ntohl(aulong);
+#endif
+#ifdef HAS_VTOHL
+ if (datumtype == 'V')
+ aulong = vtohl(aulong);
+#endif
+ sv = NEWSV(43, 0);
+ sv_setuv(sv, (UV)aulong);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'p':
+ along = (strend - s) / sizeof(char*);
+ if (len > along)
+ len = along;
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ if (sizeof(char*) > strend - s)
+ break;
+ else {
+ Copy(s, &aptr, 1, char*);
+ s += sizeof(char*);
+ }
+ sv = NEWSV(44, 0);
+ if (aptr)
+ sv_setpv(sv, aptr);
+ PUSHs(sv_2mortal(sv));
+ }
+ break;
+ case 'w':
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ {
+ UV auv = 0;
+ U32 bytes = 0;
+
+ while ((len > 0) && (s < strend)) {
+ auv = (auv << 7) | (*s & 0x7f);
+ if (!(*s++ & 0x80)) {
+ bytes = 0;
+ sv = NEWSV(40, 0);
+ sv_setuv(sv, auv);
+ PUSHs(sv_2mortal(sv));
+ len--;
+ auv = 0;
+ }
+ else if (++bytes >= sizeof(UV)) { /* promote to string */
+ char *t;
+
+ sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
+ while (s < strend) {
+ sv = mul128(sv, *s & 0x7f);
+ if (!(*s++ & 0x80)) {
+ bytes = 0;
+ break;
+ }
+ }
+ t = SvPV(sv, PL_na);
+ while (*t == '0')
+ t++;
+ sv_chop(sv, t);
+ PUSHs(sv_2mortal(sv));
+ len--;
+ auv = 0;
+ }
+ }
+ if ((s >= strend) && bytes)
+ croak("Unterminated compressed integer");
+ }
+ break;
+ case 'P':
+ EXTEND(SP, 1);
+ if (sizeof(char*) > strend - s)
+ break;
+ else {
+ Copy(s, &aptr, 1, char*);
+ s += sizeof(char*);
+ }
+ sv = NEWSV(44, 0);
+ if (aptr)
+ sv_setpvn(sv, aptr, len);
+ PUSHs(sv_2mortal(sv));
+ break;
+#ifdef HAS_QUAD
+ case 'q':
+ along = (strend - s) / sizeof(Quad_t);
+ if (len > along)
+ len = along;
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ if (s + sizeof(Quad_t) > strend)
+ aquad = 0;
+ else {
+ Copy(s, &aquad, 1, Quad_t);
+ s += sizeof(Quad_t);
+ }
+ sv = NEWSV(42, 0);
+ if (aquad >= IV_MIN && aquad <= IV_MAX)
+ sv_setiv(sv, (IV)aquad);
+ else
+ sv_setnv(sv, (double)aquad);
+ PUSHs(sv_2mortal(sv));
+ }
+ break;
+ case 'Q':
+ along = (strend - s) / sizeof(Quad_t);
+ if (len > along)
+ len = along;
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ if (s + sizeof(unsigned Quad_t) > strend)
+ auquad = 0;
+ else {
+ Copy(s, &auquad, 1, unsigned Quad_t);
+ s += sizeof(unsigned Quad_t);
+ }
+ sv = NEWSV(43, 0);
+ if (auquad <= UV_MAX)
+ sv_setuv(sv, (UV)auquad);
+ else
+ sv_setnv(sv, (double)auquad);
+ PUSHs(sv_2mortal(sv));
+ }
+ break;
+#endif
+ /* float and double added gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ along = (strend - s) / sizeof(float);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &afloat, 1, float);
+ s += sizeof(float);
+ cdouble += afloat;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ Copy(s, &afloat, 1, float);
+ s += sizeof(float);
+ sv = NEWSV(47, 0);
+ sv_setnv(sv, (double)afloat);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'd':
+ case 'D':
+ along = (strend - s) / sizeof(double);
+ if (len > along)
+ len = along;
+ if (checksum) {
+ while (len-- > 0) {
+ Copy(s, &adouble, 1, double);
+ s += sizeof(double);
+ cdouble += adouble;
+ }
+ }
+ else {
+ EXTEND(SP, len);
+ EXTEND_MORTAL(len);
+ while (len-- > 0) {
+ Copy(s, &adouble, 1, double);
+ s += sizeof(double);
+ sv = NEWSV(48, 0);
+ sv_setnv(sv, (double)adouble);
+ PUSHs(sv_2mortal(sv));
+ }
+ }
+ break;
+ case 'u':
+ /* MKS:
+ * Initialise the decode mapping. By using a table driven
+ * algorithm, the code will be character-set independent
+ * (and just as fast as doing character arithmetic)
+ */
+ if (uudmap['M'] == 0) {
+ int i;
+
+ for (i = 0; i < sizeof(uuemap); i += 1)
+ uudmap[uuemap[i]] = i;
+ /*
+ * Because ' ' and '`' map to the same value,
+ * we need to decode them both the same.
+ */
+ uudmap[' '] = 0;
+ }
+
+ along = (strend - s) * 3 / 4;
+ sv = NEWSV(42, along);
+ if (along)
+ SvPOK_on(sv);
+ while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
+ I32 a, b, c, d;
+ char hunk[4];
+
+ hunk[3] = '\0';
+ len = (*s++ - ' ') & 077;
+ while (len > 0) {
+ if (s < strend && ISUUCHAR(*s))
+ a = uudmap[*s++] & 077;
+ else
+ a = 0;
+ if (s < strend && ISUUCHAR(*s))
+ b = uudmap[*s++] & 077;
+ else
+ b = 0;
+ if (s < strend && ISUUCHAR(*s))
+ c = uudmap[*s++] & 077;
+ else
+ c = 0;
+ if (s < strend && ISUUCHAR(*s))
+ d = uudmap[*s++] & 077;
+ else
+ d = 0;
+ hunk[0] = (a << 2) | (b >> 4);
+ hunk[1] = (b << 4) | (c >> 2);
+ hunk[2] = (c << 6) | d;
+ sv_catpvn(sv, hunk, (len > 3) ? 3 : len);
+ len -= 3;
+ }
+ if (*s == '\n')
+ s++;
+ else if (s[1] == '\n') /* possible checksum byte */
+ s += 2;
+ }
+ XPUSHs(sv_2mortal(sv));
+ break;
+ }
+ if (checksum) {
+ sv = NEWSV(42, 0);
+ if (strchr("fFdD", datumtype) ||
+ (checksum > 32 && strchr("iIlLN", datumtype)) ) {
+ double trouble;
+
+ adouble = 1.0;
+ while (checksum >= 16) {
+ checksum -= 16;
+ adouble *= 65536.0;
+ }
+ while (checksum >= 4) {
+ checksum -= 4;
+ adouble *= 16.0;
+ }
+ while (checksum--)
+ adouble *= 2.0;
+ along = (1 << checksum) - 1;
+ while (cdouble < 0.0)
+ cdouble += adouble;
+ cdouble = modf(cdouble / adouble, &trouble) * adouble;
+ sv_setnv(sv, cdouble);
+ }
+ else {
+ if (checksum < 32) {
+ aulong = (1 << checksum) - 1;
+ culong &= aulong;
+ }
+ sv_setuv(sv, (UV)culong);
+ }
+ XPUSHs(sv_2mortal(sv));
+ checksum = 0;
+ }
+ }
+ if (SP == oldsp && gimme == G_SCALAR)
+ PUSHs(&PL_sv_undef);
+ RETURN;
+}
+
+STATIC void
+doencodes(register SV *sv, register char *s, register I32 len)
+{
+ char hunk[5];
+
+ *hunk = uuemap[len];
+ sv_catpvn(sv, hunk, 1);
+ hunk[4] = '\0';
+ while (len > 2) {
+ hunk[0] = uuemap[(077 & (*s >> 2))];
+ hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))];
+ hunk[2] = uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))];
+ hunk[3] = uuemap[(077 & (s[2] & 077))];
+ sv_catpvn(sv, hunk, 4);
+ s += 3;
+ len -= 3;
+ }
+ if (len > 0) {
+ char r = (len > 1 ? s[1] : '\0');
+ hunk[0] = uuemap[(077 & (*s >> 2))];
+ hunk[1] = uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))];
+ hunk[2] = uuemap[(077 & ((r << 2) & 074))];
+ hunk[3] = uuemap[0];
+ sv_catpvn(sv, hunk, 4);
+ }
+ sv_catpvn(sv, "\n", 1);
+}
+
+STATIC SV *
+is_an_int(char *s, STRLEN l)
+{
+ SV *result = newSVpv("", l);
+ char *result_c = SvPV(result, PL_na); /* convenience */
+ char *out = result_c;
+ bool skip = 1;
+ bool ignore = 0;
+
+ while (*s) {
+ switch (*s) {
+ case ' ':
+ break;
+ case '+':
+ if (!skip) {
+ SvREFCNT_dec(result);
+ return (NULL);
+ }
+ break;
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ case '8':
+ case '9':
+ skip = 0;
+ if (!ignore) {
+ *(out++) = *s;
+ }
+ break;
+ case '.':
+ ignore = 1;
+ break;
+ default:
+ SvREFCNT_dec(result);
+ return (NULL);
+ }
+ s++;
+ }
+ *(out++) = '\0';
+ SvCUR_set(result, out - result_c);
+ return (result);
+}
+
+STATIC int
+div128(SV *pnum, bool *done)
+ /* must be '\0' terminated */
+
+{
+ STRLEN len;
+ char *s = SvPV(pnum, len);
+ int m = 0;
+ int r = 0;
+ char *t = s;
+
+ *done = 1;
+ while (*t) {
+ int i;
+
+ i = m * 10 + (*t - '0');
+ m = i & 0x7F;
+ r = (i >> 7); /* r < 10 */
+ if (r) {
+ *done = 0;
+ }
+ *(t++) = '0' + r;
+ }
+ *(t++) = '\0';
+ SvCUR_set(pnum, (STRLEN) (t - s));
+ return (m);
+}
+
+
+PP(pp_pack)
+{
+ djSP; dMARK; dORIGMARK; dTARGET;
+ register SV *cat = TARG;
+ register I32 items;
+ STRLEN fromlen;
+ register char *pat = SvPVx(*++MARK, fromlen);
+ register char *patend = pat + fromlen;
+ register I32 len;
+ I32 datumtype;
+ SV *fromstr;
+ /*SUPPRESS 442*/
+ static char null10[] = {0,0,0,0,0,0,0,0,0,0};
+ static char *space10 = " ";
+
+ /* These must not be in registers: */
+ char achar;
+ I16 ashort;
+ int aint;
+ unsigned int auint;
+ I32 along;
+ U32 aulong;
+#ifdef HAS_QUAD
+ Quad_t aquad;
+ unsigned Quad_t auquad;
+#endif
+ char *aptr;
+ float afloat;
+ double adouble;
+ int commas = 0;
+
+ items = SP - MARK;
+ MARK++;
+ sv_setpvn(cat, "", 0);
+ while (pat < patend) {
+#define NEXTFROM (items-- > 0 ? *MARK++ : &PL_sv_no)
+ datumtype = *pat++ & 0xFF;
+ if (isSPACE(datumtype))
+ continue;
+ if (*pat == '*') {
+ len = strchr("@Xxu", datumtype) ? 0 : items;
+ pat++;
+ }
+ else if (isDIGIT(*pat)) {
+ len = *pat++ - '0';
+ while (isDIGIT(*pat))
+ len = (len * 10) + (*pat++ - '0');
+ }
+ else
+ len = 1;
+ switch(datumtype) {
+ default:
+ croak("Invalid type in pack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && PL_dowarn)
+ warn("Invalid type in pack: '%c'", (int)datumtype);
+ break;
+ case '%':
+ DIE("%% may only be used in unpack");
+ case '@':
+ len -= SvCUR(cat);
+ if (len > 0)
+ goto grow;
+ len = -len;
+ if (len > 0)
+ goto shrink;
+ break;
+ case 'X':
+ shrink:
+ if (SvCUR(cat) < len)
+ DIE("X outside of string");
+ SvCUR(cat) -= len;
+ *SvEND(cat) = '\0';
+ break;
+ case 'x':
+ grow:
+ while (len >= 10) {
+ sv_catpvn(cat, null10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, null10, len);
+ break;
+ case 'A':
+ case 'a':
+ fromstr = NEXTFROM;
+ aptr = SvPV(fromstr, fromlen);
+ if (pat[-1] == '*')
+ len = fromlen;
+ if (fromlen > len)
+ sv_catpvn(cat, aptr, len);
+ else {
+ sv_catpvn(cat, aptr, fromlen);
+ len -= fromlen;
+ if (datumtype == 'A') {
+ while (len >= 10) {
+ sv_catpvn(cat, space10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, space10, len);
+ }
+ else {
+ while (len >= 10) {
+ sv_catpvn(cat, null10, 10);
+ len -= 10;
+ }
+ sv_catpvn(cat, null10, len);
+ }
+ }
+ break;
+ case 'B':
+ case 'b':
+ {
+ char *savepat = pat;
+ I32 saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = SvPV(fromstr, fromlen);
+ if (pat[-1] == '*')
+ len = fromlen;
+ pat = aptr;
+ aint = SvCUR(cat);
+ SvCUR(cat) += (len+7)/8;
+ SvGROW(cat, SvCUR(cat) + 1);
+ aptr = SvPVX(cat) + aint;
+ if (len > fromlen)
+ len = fromlen;
+ aint = len;
+ items = 0;
+ if (datumtype == 'B') {
+ for (len = 0; len++ < aint;) {
+ items |= *pat++ & 1;
+ if (len & 7)
+ items <<= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (*pat++ & 1)
+ items |= 128;
+ if (len & 7)
+ items >>= 1;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 7) {
+ if (datumtype == 'B')
+ items <<= 7 - (aint & 7);
+ else
+ items >>= 7 - (aint & 7);
+ *aptr++ = items & 0xff;
+ }
+ pat = SvPVX(cat) + SvCUR(cat);
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'H':
+ case 'h':
+ {
+ char *savepat = pat;
+ I32 saveitems;
+
+ fromstr = NEXTFROM;
+ saveitems = items;
+ aptr = SvPV(fromstr, fromlen);
+ if (pat[-1] == '*')
+ len = fromlen;
+ pat = aptr;
+ aint = SvCUR(cat);
+ SvCUR(cat) += (len+1)/2;
+ SvGROW(cat, SvCUR(cat) + 1);
+ aptr = SvPVX(cat) + aint;
+ if (len > fromlen)
+ len = fromlen;
+ aint = len;
+ items = 0;
+ if (datumtype == 'H') {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*pat))
+ items |= ((*pat++ & 15) + 9) & 15;
+ else
+ items |= *pat++ & 15;
+ if (len & 1)
+ items <<= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ else {
+ for (len = 0; len++ < aint;) {
+ if (isALPHA(*pat))
+ items |= (((*pat++ & 15) + 9) & 15) << 4;
+ else
+ items |= (*pat++ & 15) << 4;
+ if (len & 1)
+ items >>= 4;
+ else {
+ *aptr++ = items & 0xff;
+ items = 0;
+ }
+ }
+ }
+ if (aint & 1)
+ *aptr++ = items & 0xff;
+ pat = SvPVX(cat) + SvCUR(cat);
+ while (aptr <= pat)
+ *aptr++ = '\0';
+
+ pat = savepat;
+ items = saveitems;
+ }
+ break;
+ case 'C':
+ case 'c':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = SvIV(fromstr);
+ achar = aint;
+ sv_catpvn(cat, &achar, sizeof(char));
+ }
+ break;
+ /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */
+ case 'f':
+ case 'F':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ afloat = (float)SvNV(fromstr);
+ sv_catpvn(cat, (char *)&afloat, sizeof (float));
+ }
+ break;
+ case 'd':
+ case 'D':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ adouble = (double)SvNV(fromstr);
+ sv_catpvn(cat, (char *)&adouble, sizeof (double));
+ }
+ break;
+ case 'n':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIV(fromstr);
+#ifdef HAS_HTONS
+ ashort = PerlSock_htons(ashort);
+#endif
+ CAT16(cat, &ashort);
+ }
+ break;
+ case 'v':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIV(fromstr);
+#ifdef HAS_HTOVS
+ ashort = htovs(ashort);
+#endif
+ CAT16(cat, &ashort);
+ }
+ break;
+ case 'S':
+ case 's':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ ashort = (I16)SvIV(fromstr);
+ CAT16(cat, &ashort);
+ }
+ break;
+ case 'I':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auint = SvUV(fromstr);
+ sv_catpvn(cat, (char*)&auint, sizeof(unsigned int));
+ }
+ break;
+ case 'w':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ adouble = floor(SvNV(fromstr));
+
+ if (adouble < 0)
+ croak("Cannot compress negative numbers");
+
+ if (
+#ifdef BW_BITS
+ adouble <= BW_MASK
+#else
+#ifdef CXUX_BROKEN_CONSTANT_CONVERT
+ adouble <= UV_MAX_cxux
+#else
+ adouble <= UV_MAX
+#endif
+#endif
+ )
+ {
+ char buf[1 + sizeof(UV)];
+ char *in = buf + sizeof(buf);
+ UV auv = U_V(adouble);;
+
+ do {
+ *--in = (auv & 0x7f) | 0x80;
+ auv >>= 7;
+ } while (auv);
+ buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
+ sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
+ }
+ else if (SvPOKp(fromstr)) { /* decimal string arithmetics */
+ char *from, *result, *in;
+ SV *norm;
+ STRLEN len;
+ bool done;
+
+ /* Copy string and check for compliance */
+ from = SvPV(fromstr, len);
+ if ((norm = is_an_int(from, len)) == NULL)
+ croak("can compress only unsigned integer");
+
+ New('w', result, len, char);
+ in = result + len;
+ done = FALSE;
+ while (!done)
+ *--in = div128(norm, &done) | 0x80;
+ result[len - 1] &= 0x7F; /* clear continue bit */
+ sv_catpvn(cat, in, (result + len) - in);
+ Safefree(result);
+ SvREFCNT_dec(norm); /* free norm */
+ }
+ else if (SvNOKp(fromstr)) {
+ char buf[sizeof(double) * 2]; /* 8/7 <= 2 */
+ char *in = buf + sizeof(buf);
+
+ do {
+ double next = floor(adouble / 128);
+ *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
+ if (--in < buf) /* this cannot happen ;-) */
+ croak ("Cannot compress integer");
+ adouble = next;
+ } while (adouble > 0);
+ buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
+ sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
+ }
+ else
+ croak("Cannot compress non integer");
+ }
+ break;
+ case 'i':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aint = SvIV(fromstr);
+ sv_catpvn(cat, (char*)&aint, sizeof(int));
+ }
+ break;
+ case 'N':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+#ifdef HAS_HTONL
+ aulong = PerlSock_htonl(aulong);
+#endif
+ CAT32(cat, &aulong);
+ }
+ break;
+ case 'V':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+#ifdef HAS_HTOVL
+ aulong = htovl(aulong);
+#endif
+ CAT32(cat, &aulong);
+ }
+ break;
+ case 'L':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aulong = SvUV(fromstr);
+ CAT32(cat, &aulong);
+ }
+ break;
+ case 'l':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ along = SvIV(fromstr);
+ CAT32(cat, &along);
+ }
+ break;
+#ifdef HAS_QUAD
+ case 'Q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ auquad = (unsigned Quad_t)SvIV(fromstr);
+ sv_catpvn(cat, (char*)&auquad, sizeof(unsigned Quad_t));
+ }
+ break;
+ case 'q':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ aquad = (Quad_t)SvIV(fromstr);
+ sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
+ }
+ break;
+#endif /* HAS_QUAD */
+ case 'P':
+ len = 1; /* assume SV is correct length */
+ /* FALL THROUGH */
+ case 'p':
+ while (len-- > 0) {
+ fromstr = NEXTFROM;
+ if (fromstr == &PL_sv_undef)
+ aptr = NULL;
+ else {
+ /* XXX better yet, could spirit away the string to
+ * a safe spot and hang on to it until the result
+ * of pack() (and all copies of the result) are
+ * gone.
+ */
+ if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
+ warn("Attempt to pack pointer to temporary value");
+ if (SvPOK(fromstr) || SvNIOK(fromstr))
+ aptr = SvPV(fromstr,PL_na);
+ else
+ aptr = SvPV_force(fromstr,PL_na);
+ }
+ sv_catpvn(cat, (char*)&aptr, sizeof(char*));
+ }
+ break;
+ case 'u':
+ fromstr = NEXTFROM;
+ aptr = SvPV(fromstr, fromlen);
+ SvGROW(cat, fromlen * 4 / 3);
+ if (len <= 1)
+ len = 45;
+ else
+ len = len / 3 * 3;
+ while (fromlen > 0) {
+ I32 todo;
+
+ if (fromlen > len)
+ todo = len;
+ else
+ todo = fromlen;
+ doencodes(cat, aptr, todo);
+ fromlen -= todo;
+ aptr += todo;
+ }
+ break;
+ }
+ }
+ SvSETMAGIC(cat);
+ SP = ORIGMARK;
+ PUSHs(cat);
+ RETURN;
+}
+#undef NEXTFROM
+
+
+PP(pp_split)
+{
+ djSP; dTARG;
+ AV *ary;
+ register I32 limit = POPi; /* note, negative is forever */
+ SV *sv = POPs;
+ STRLEN len;
+ register char *s = SvPV(sv, len);
+ char *strend = s + len;
+ register PMOP *pm;
+ register REGEXP *rx;
+ register SV *dstr;
+ register char *m;
+ I32 iters = 0;
+ I32 maxiters = (strend - s) + 10;
+ I32 i;
+ char *orig;
+ I32 origlimit = limit;
+ I32 realarray = 0;
+ I32 base;
+ AV *oldstack = PL_curstack;
+ I32 gimme = GIMME_V;
+ I32 oldsave = PL_savestack_ix;
+ I32 make_mortal = 1;
+ MAGIC *mg = (MAGIC *) NULL;
+
+#ifdef DEBUGGING
+ Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
+#else
+ pm = (PMOP*)POPs;
+#endif
+ if (!pm || !s)
+ DIE("panic: do_split");
+ rx = pm->op_pmregexp;
+
+ TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
+ (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
+
+ if (pm->op_pmreplroot)
+ ary = GvAVn((GV*)pm->op_pmreplroot);
+ else if (gimme != G_ARRAY)
+#ifdef USE_THREADS
+ ary = (AV*)PL_curpad[0];
+#else
+ ary = GvAVn(PL_defgv);
+#endif /* USE_THREADS */
+ else
+ ary = Nullav;
+ if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
+ realarray = 1;
+ PUTBACK;
+ av_extend(ary,0);
+ av_clear(ary);
+ SPAGAIN;
+ if (SvRMAGICAL(ary) && (mg = mg_find((SV *) ary, 'P'))) {
+ PUSHMARK(SP);
+ XPUSHs(mg->mg_obj);
+ }
+ else {
+ if (!AvREAL(ary)) {
+ AvREAL_on(ary);
+ for (i = AvFILLp(ary); i >= 0; i--)
+ AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
+ }
+ /* temporarily switch stacks */
+ SWITCHSTACK(PL_curstack, ary);
+ make_mortal = 0;
+ }
+ }
+ base = SP - PL_stack_base;
+ orig = s;
+ if (pm->op_pmflags & PMf_SKIPWHITE) {
+ if (pm->op_pmflags & PMf_LOCALE) {
+ while (isSPACE_LC(*s))
+ s++;
+ }
+ else {
+ while (isSPACE(*s))
+ s++;
+ }
+ }
+ if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+ SAVEINT(PL_multiline);
+ PL_multiline = pm->op_pmflags & PMf_MULTILINE;
+ }
+
+ if (!limit)
+ limit = maxiters + 2;
+ if (pm->op_pmflags & PMf_WHITE) {
+ while (--limit) {
+ m = s;
+ while (m < strend &&
+ !((pm->op_pmflags & PMf_LOCALE)
+ ? isSPACE_LC(*m) : isSPACE(*m)))
+ ++m;
+ if (m >= strend)
+ break;
+
+ dstr = NEWSV(30, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (make_mortal)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+
+ s = m + 1;
+ while (s < strend &&
+ ((pm->op_pmflags & PMf_LOCALE)
+ ? isSPACE_LC(*s) : isSPACE(*s)))
+ ++s;
+ }
+ }
+ else if (strEQ("^", rx->precomp)) {
+ while (--limit) {
+ /*SUPPRESS 530*/
+ for (m = s; m < strend && *m != '\n'; m++) ;
+ m++;
+ if (m >= strend)
+ break;
+ dstr = NEWSV(30, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (make_mortal)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ s = m;
+ }
+ }
+ else if (rx->check_substr && !rx->nparens
+ && (rx->reganch & ROPT_CHECK_ALL)
+ && !(rx->reganch & ROPT_ANCH)) {
+ i = SvCUR(rx->check_substr);
+ if (i == 1 && !SvTAIL(rx->check_substr)) {
+ i = *SvPVX(rx->check_substr);
+ while (--limit) {
+ /*SUPPRESS 530*/
+ for (m = s; m < strend && *m != i; m++) ;
+ if (m >= strend)
+ break;
+ dstr = NEWSV(30, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (make_mortal)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ s = m + 1;
+ }
+ }
+ else {
+#ifndef lint
+ while (s < strend && --limit &&
+ (m=fbm_instr((unsigned char*)s, (unsigned char*)strend,
+ rx->check_substr, 0)) )
+#endif
+ {
+ dstr = NEWSV(31, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (make_mortal)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ s = m + i;
+ }
+ }
+ }
+ else {
+ maxiters += (strend - s) * rx->nparens;
+ while (s < strend && --limit &&
+ CALLREGEXEC(rx, s, strend, orig, 1, Nullsv, NULL, 0))
+ {
+ TAINT_IF(RX_MATCH_TAINTED(rx));
+ if (rx->subbase
+ && rx->subbase != orig) {
+ m = s;
+ s = orig;
+ orig = rx->subbase;
+ s = orig + (m - s);
+ strend = s + (strend - m);
+ }
+ m = rx->startp[0];
+ dstr = NEWSV(32, m-s);
+ sv_setpvn(dstr, s, m-s);
+ if (make_mortal)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ if (rx->nparens) {
+ for (i = 1; i <= rx->nparens; i++) {
+ s = rx->startp[i];
+ m = rx->endp[i];
+ if (m && s) {
+ dstr = NEWSV(33, m-s);
+ sv_setpvn(dstr, s, m-s);
+ }
+ else
+ dstr = NEWSV(33, 0);
+ if (make_mortal)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ }
+ }
+ s = rx->endp[0];
+ }
+ }
+
+ LEAVE_SCOPE(oldsave);
+ iters = (SP - PL_stack_base) - base;
+ if (iters > maxiters)
+ DIE("Split loop");
+
+ /* keep field after final delim? */
+ if (s < strend || (iters && origlimit)) {
+ dstr = NEWSV(34, strend-s);
+ sv_setpvn(dstr, s, strend-s);
+ if (make_mortal)
+ sv_2mortal(dstr);
+ XPUSHs(dstr);
+ iters++;
+ }
+ else if (!origlimit) {
+ while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
+ iters--, SP--;
+ }
+
+ if (realarray) {
+ if (!mg) {
+ SWITCHSTACK(ary, oldstack);
+ if (SvSMAGICAL(ary)) {
+ PUTBACK;
+ mg_set((SV*)ary);
+ SPAGAIN;
+ }
+ if (gimme == G_ARRAY) {
+ EXTEND(SP, iters);
+ Copy(AvARRAY(ary), SP + 1, iters, SV*);
+ SP += iters;
+ RETURN;
+ }
+ }
+ else {
+ PUTBACK;
+ ENTER;
+ perl_call_method("PUSH",G_SCALAR|G_DISCARD);
+ LEAVE;
+ SPAGAIN;
+ if (gimme == G_ARRAY) {
+ /* EXTEND should not be needed - we just popped them */
+ EXTEND(SP, iters);
+ for (i=0; i < iters; i++) {
+ SV **svp = av_fetch(ary, i, FALSE);
+ PUSHs((svp) ? *svp : &PL_sv_undef);
+ }
+ RETURN;
+ }
+ }
+ }
+ else {
+ if (gimme == G_ARRAY)
+ RETURN;
+ }
+ if (iters || !pm->op_pmreplroot) {
+ GETTARGET;
+ PUSHi(iters);
+ RETURN;
+ }
+ RETPUSHUNDEF;
+}
+
+#ifdef USE_THREADS
+void
+unlock_condpair(void *svv)
+{
+ dTHR;
+ MAGIC *mg = mg_find((SV*)svv, 'm');
+
+ if (!mg)
+ croak("panic: unlock_condpair unlocking non-mutex");
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) != thr)
+ croak("panic: unlock_condpair unlocking mutex that we don't own");
+ MgOWNER(mg) = 0;
+ COND_SIGNAL(MgOWNERCONDP(mg));
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: unlock 0x%lx\n",
+ (unsigned long)thr, (unsigned long)svv);)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+}
+#endif /* USE_THREADS */
+
+PP(pp_lock)
+{
+ djSP;
+ dTOPss;
+ SV *retsv = sv;
+#ifdef USE_THREADS
+ MAGIC *mg;
+
+ if (SvROK(sv))
+ sv = SvRV(sv);
+
+ mg = condpair_magic(sv);
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) == thr)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ else {
+ while (MgOWNER(mg))
+ COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
+ MgOWNER(mg) = thr;
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "0x%lx: pp_lock lock 0x%lx\n",
+ (unsigned long)thr, (unsigned long)sv);)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ SvREFCNT_inc(sv); /* keep alive until magic_mutexfree */
+ save_destructor(unlock_condpair, sv);
+ }
+#endif /* USE_THREADS */
+ if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
+ || SvTYPE(retsv) == SVt_PVCV) {
+ retsv = refto(retsv);
+ }
+ SETs(retsv);
+ RETURN;
+}
+
+PP(pp_threadsv)
+{
+ djSP;
+#ifdef USE_THREADS
+ EXTEND(SP, 1);
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ PUSHs(*save_threadsv(PL_op->op_targ));
+ else
+ PUSHs(THREADSV(PL_op->op_targ));
+ RETURN;
+#else
+ DIE("tried to access per-thread data in non-threaded perl");
+#endif /* USE_THREADS */
+}
diff --git a/contrib/perl5/pp.h b/contrib/perl5/pp.h
new file mode 100644
index 000000000000..6fe91f40c800
--- /dev/null
+++ b/contrib/perl5/pp.h
@@ -0,0 +1,237 @@
+/* pp.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifdef USE_THREADS
+#define ARGS thr
+#define dARGS struct perl_thread *thr;
+#else
+#define ARGS
+#define dARGS
+#endif /* USE_THREADS */
+#ifdef PERL_OBJECT
+#define PP(s) OP * CPerlObj::s(ARGSproto)
+#else
+#define PP(s) OP * s(ARGSproto)
+#endif
+
+#define SP sp
+#define MARK mark
+#define TARG targ
+
+#define PUSHMARK(p) if (++PL_markstack_ptr == PL_markstack_max) \
+ markstack_grow(); \
+ *PL_markstack_ptr = (p) - PL_stack_base
+
+#define TOPMARK (*PL_markstack_ptr)
+#define POPMARK (*PL_markstack_ptr--)
+
+#define djSP register SV **sp = PL_stack_sp
+#define dSP dTHR; djSP
+#define dMARK register SV **mark = PL_stack_base + POPMARK
+#define dORIGMARK I32 origmark = mark - PL_stack_base
+#define SETORIGMARK origmark = mark - PL_stack_base
+#define ORIGMARK (PL_stack_base + origmark)
+
+#define SPAGAIN sp = PL_stack_sp
+#define MSPAGAIN sp = PL_stack_sp; mark = ORIGMARK
+
+#define GETTARGETSTACKED targ = (PL_op->op_flags & OPf_STACKED ? POPs : PAD_SV(PL_op->op_targ))
+#define dTARGETSTACKED SV * GETTARGETSTACKED
+
+#define GETTARGET targ = PAD_SV(PL_op->op_targ)
+#define dTARGET SV * GETTARGET
+
+#define GETATARGET targ = (PL_op->op_flags & OPf_STACKED ? sp[-1] : PAD_SV(PL_op->op_targ))
+#define dATARGET SV * GETATARGET
+
+#define dTARG SV *targ
+
+#define NORMAL PL_op->op_next
+#define DIE return die
+
+#define PUTBACK PL_stack_sp = sp
+#define RETURN return PUTBACK, NORMAL
+#define RETURNOP(o) return PUTBACK, o
+#define RETURNX(x) return x, PUTBACK, NORMAL
+
+#define POPs (*sp--)
+#define POPp (SvPVx(POPs, PL_na))
+#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 TOPn (SvNV(TOPs))
+#define TOPi ((IV)SvIV(TOPs))
+#define TOPu ((UV)SvUV(TOPs))
+#define TOPl ((long)SvIV(TOPs))
+
+/* Go to some pains in the rare event that we must extend the stack. */
+#define EXTEND(p,n) STMT_START { if (PL_stack_max - p < (n)) { \
+ sp = stack_grow(sp,p, (int) (n)); \
+ } } STMT_END
+
+/* Same thing, but update mark register too. */
+#define MEXTEND(p,n) STMT_START {if (PL_stack_max - p < (n)) { \
+ int markoff = mark - PL_stack_base; \
+ sp = stack_grow(sp,p,(int) (n)); \
+ mark = PL_stack_base + markoff; \
+ } } STMT_END
+
+#define PUSHs(s) (*++sp = (s))
+#define PUSHTARG STMT_START { SvSETMAGIC(TARG); PUSHs(TARG); } STMT_END
+#define PUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); PUSHTARG; } STMT_END
+#define PUSHn(n) STMT_START { sv_setnv(TARG, (double)(n)); PUSHTARG; } STMT_END
+#define PUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); PUSHTARG; } STMT_END
+#define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
+
+#define XPUSHs(s) STMT_START { EXTEND(sp,1); (*++sp = (s)); } STMT_END
+#define XPUSHTARG STMT_START { SvSETMAGIC(TARG); XPUSHs(TARG); } STMT_END
+#define XPUSHp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); XPUSHTARG; } STMT_END
+#define XPUSHn(n) STMT_START { sv_setnv(TARG, (double)(n)); XPUSHTARG; } STMT_END
+#define XPUSHi(i) STMT_START { sv_setiv(TARG, (IV)(i)); XPUSHTARG; } STMT_END
+#define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
+
+#define SETs(s) (*sp = s)
+#define SETTARG STMT_START { SvSETMAGIC(TARG); SETs(TARG); } STMT_END
+#define SETp(p,l) STMT_START { sv_setpvn(TARG, (p), (l)); SETTARG; } STMT_END
+#define SETn(n) STMT_START { sv_setnv(TARG, (double)(n)); SETTARG; } STMT_END
+#define SETi(i) STMT_START { sv_setiv(TARG, (IV)(i)); SETTARG; } STMT_END
+#define SETu(u) STMT_START { sv_setuv(TARG, (UV)(u)); SETTARG; } STMT_END
+
+#define dTOPss SV *sv = TOPs
+#define dPOPss SV *sv = POPs
+#define dTOPnv double value = TOPn
+#define dPOPnv double value = POPn
+#define dTOPiv IV value = TOPi
+#define dPOPiv IV value = POPi
+#define dTOPuv UV value = TOPu
+#define dPOPuv UV value = POPu
+
+#define dPOPXssrl(X) SV *right = POPs; SV *left = CAT2(X,s)
+#define dPOPXnnrl(X) double right = POPn; double left = CAT2(X,n)
+#define dPOPXiirl(X) IV right = POPi; IV left = CAT2(X,i)
+
+#define USE_LEFT(sv) \
+ (SvOK(sv) || SvGMAGICAL(sv) || !(PL_op->op_flags & OPf_STACKED))
+#define dPOPXnnrl_ul(X) \
+ double right = POPn; \
+ SV *leftsv = CAT2(X,s); \
+ double left = USE_LEFT(leftsv) ? SvNV(leftsv) : 0.0
+#define dPOPXiirl_ul(X) \
+ IV right = POPi; \
+ SV *leftsv = CAT2(X,s); \
+ IV left = USE_LEFT(leftsv) ? SvIV(leftsv) : 0
+
+#define dPOPPOPssrl dPOPXssrl(POP)
+#define dPOPPOPnnrl dPOPXnnrl(POP)
+#define dPOPPOPnnrl_ul dPOPXnnrl_ul(POP)
+#define dPOPPOPiirl dPOPXiirl(POP)
+#define dPOPPOPiirl_ul dPOPXiirl_ul(POP)
+
+#define dPOPTOPssrl dPOPXssrl(TOP)
+#define dPOPTOPnnrl dPOPXnnrl(TOP)
+#define dPOPTOPnnrl_ul dPOPXnnrl_ul(TOP)
+#define dPOPTOPiirl dPOPXiirl(TOP)
+#define dPOPTOPiirl_ul dPOPXiirl_ul(TOP)
+
+#define RETPUSHYES RETURNX(PUSHs(&PL_sv_yes))
+#define RETPUSHNO RETURNX(PUSHs(&PL_sv_no))
+#define RETPUSHUNDEF RETURNX(PUSHs(&PL_sv_undef))
+
+#define RETSETYES RETURNX(SETs(&PL_sv_yes))
+#define RETSETNO RETURNX(SETs(&PL_sv_no))
+#define RETSETUNDEF RETURNX(SETs(&PL_sv_undef))
+
+#define ARGTARG PL_op->op_targ
+#define MAXARG PL_op->op_private
+
+#define SWITCHSTACK(f,t) \
+ STMT_START { \
+ AvFILLp(f) = sp - PL_stack_base; \
+ PL_stack_base = AvARRAY(t); \
+ PL_stack_max = PL_stack_base + AvMAX(t); \
+ sp = PL_stack_sp = PL_stack_base + AvFILLp(t); \
+ PL_curstack = t; \
+ } STMT_END
+
+#define EXTEND_MORTAL(n) \
+ STMT_START { \
+ if (PL_tmps_ix + (n) >= PL_tmps_max) \
+ Renew(PL_tmps_stack, PL_tmps_max = PL_tmps_ix + (n) + 1, SV*); \
+ } STMT_END
+
+#ifdef OVERLOAD
+
+#define AMGf_noright 1
+#define AMGf_noleft 2
+#define AMGf_assign 4
+#define AMGf_unary 8
+
+#define tryAMAGICbinW(meth,assign,set) STMT_START { \
+ if (PL_amagic_generation) { \
+ SV* tmpsv; \
+ SV* right= *(sp); SV* left= *(sp-1);\
+ if ((SvAMAGIC(left)||SvAMAGIC(right))&&\
+ (tmpsv=amagic_call(left, \
+ right, \
+ CAT2(meth,_amg), \
+ (assign)? AMGf_assign: 0))) {\
+ SPAGAIN; \
+ (void)POPs; set(tmpsv); RETURN; } \
+ } \
+ } STMT_END
+
+#define tryAMAGICbin(meth,assign) tryAMAGICbinW(meth,assign,SETsv)
+#define tryAMAGICbinSET(meth,assign) tryAMAGICbinW(meth,assign,SETs)
+
+#define AMG_CALLun(sv,meth) amagic_call(sv,&PL_sv_undef, \
+ CAT2(meth,_amg),AMGf_noright | AMGf_unary)
+#define AMG_CALLbinL(left,right,meth) \
+ amagic_call(left,right,CAT2(meth,_amg),AMGf_noright)
+
+#define tryAMAGICunW(meth,set) STMT_START { \
+ if (PL_amagic_generation) { \
+ SV* tmpsv; \
+ SV* arg= *(sp); \
+ if ((SvAMAGIC(arg))&&\
+ (tmpsv=AMG_CALLun(arg,meth))) {\
+ SPAGAIN; \
+ set(tmpsv); RETURN; } \
+ } \
+ } STMT_END
+
+#define tryAMAGICun tryAMAGICunSET
+#define tryAMAGICunSET(meth) tryAMAGICunW(meth,SETs)
+
+#define opASSIGN (PL_op->op_flags & OPf_STACKED)
+#define SETsv(sv) STMT_START { \
+ if (opASSIGN) { sv_setsv(TARG, (sv)); SETTARG; } \
+ else SETs(sv); } STMT_END
+
+/* newSVsv does not behave as advertised, so we copy missing
+ * information by hand */
+
+/* SV* ref causes confusion with the member variable
+ changed SV* ref to SV* tmpRef */
+#define RvDEEPCP(rv) STMT_START { SV* tmpRef=SvRV(rv); \
+ if (SvREFCNT(tmpRef)>1) { \
+ SvREFCNT_dec(tmpRef); \
+ SvRV(rv)=AMG_CALLun(rv,copy); \
+ } } STMT_END
+#else
+
+#define tryAMAGICbin(a,b)
+#define tryAMAGICbinSET(a,b)
+#define tryAMAGICun(a)
+#define tryAMAGICunSET(a)
+
+#endif /* OVERLOAD */
diff --git a/contrib/perl5/pp_ctl.c b/contrib/perl5/pp_ctl.c
new file mode 100644
index 000000000000..7a1ad799b850
--- /dev/null
+++ b/contrib/perl5/pp_ctl.c
@@ -0,0 +1,3716 @@
+/* pp_ctl.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * Now far ahead the Road has gone,
+ * And I must follow, if I can,
+ * Pursuing it with eager feet,
+ * Until it joins some larger way
+ * Where many paths and errands meet.
+ * And whither then? I cannot say.
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifndef WORD_ALIGN
+#define WORD_ALIGN sizeof(U16)
+#endif
+
+#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+
+#ifdef PERL_OBJECT
+#define CALLOP this->*PL_op
+#else
+#define CALLOP *PL_op
+static OP *docatch _((OP *o));
+static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
+static void doparseform _((SV *sv));
+static I32 dopoptoeval _((I32 startingblock));
+static I32 dopoptolabel _((char *label));
+static I32 dopoptoloop _((I32 startingblock));
+static I32 dopoptosub _((I32 startingblock));
+static I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock));
+static void save_lines _((AV *array, SV *sv));
+static I32 sortcv _((SV *a, SV *b));
+static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
+static OP *doeval _((int gimme, OP** startop));
+#endif
+
+PP(pp_wantarray)
+{
+ djSP;
+ I32 cxix;
+ EXTEND(SP, 1);
+
+ cxix = dopoptosub(cxstack_ix);
+ if (cxix < 0)
+ RETPUSHUNDEF;
+
+ switch (cxstack[cxix].blk_gimme) {
+ case G_ARRAY:
+ RETPUSHYES;
+ case G_SCALAR:
+ RETPUSHNO;
+ default:
+ RETPUSHUNDEF;
+ }
+}
+
+PP(pp_regcmaybe)
+{
+ return NORMAL;
+}
+
+PP(pp_regcreset)
+{
+ /* XXXX Should store the old value to allow for tie/overload - and
+ restore in regcomp, where marked with XXXX. */
+ PL_reginterp_cnt = 0;
+ return NORMAL;
+}
+
+PP(pp_regcomp)
+{
+ djSP;
+ register PMOP *pm = (PMOP*)cLOGOP->op_other;
+ register char *t;
+ SV *tmpstr;
+ STRLEN len;
+ MAGIC *mg = Null(MAGIC*);
+
+ tmpstr = POPs;
+ if (SvROK(tmpstr)) {
+ SV *sv = SvRV(tmpstr);
+ if(SvMAGICAL(sv))
+ mg = mg_find(sv, 'r');
+ }
+ if (mg) {
+ regexp *re = (regexp *)mg->mg_obj;
+ ReREFCNT_dec(pm->op_pmregexp);
+ pm->op_pmregexp = ReREFCNT_inc(re);
+ }
+ else {
+ t = SvPV(tmpstr, len);
+
+ /* Check against the last compiled regexp. */
+ if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
+ pm->op_pmregexp->prelen != len ||
+ memNE(pm->op_pmregexp->precomp, t, len))
+ {
+ if (pm->op_pmregexp) {
+ ReREFCNT_dec(pm->op_pmregexp);
+ pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
+ }
+ if (PL_op->op_flags & OPf_SPECIAL)
+ PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
+
+ pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
+ pm->op_pmregexp = CALLREGCOMP(t, t + len, pm);
+ PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
+ inside tie/overload accessors. */
+ }
+ }
+
+#ifndef INCOMPLETE_TAINTS
+ if (PL_tainting) {
+ if (PL_tainted)
+ pm->op_pmdynflags |= PMdf_TAINTED;
+ else
+ pm->op_pmdynflags &= ~PMdf_TAINTED;
+ }
+#endif
+
+ if (!pm->op_pmregexp->prelen && PL_curpm)
+ pm = PL_curpm;
+ else if (strEQ("\\s+", pm->op_pmregexp->precomp))
+ pm->op_pmflags |= PMf_WHITE;
+
+ if (pm->op_pmflags & PMf_KEEP) {
+ pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
+ cLOGOP->op_first->op_next = PL_op->op_next;
+ }
+ RETURN;
+}
+
+PP(pp_substcont)
+{
+ djSP;
+ register PMOP *pm = (PMOP*) cLOGOP->op_other;
+ register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ register SV *dstr = cx->sb_dstr;
+ register char *s = cx->sb_s;
+ register char *m = cx->sb_m;
+ char *orig = cx->sb_orig;
+ register REGEXP *rx = cx->sb_rx;
+
+ rxres_restore(&cx->sb_rxres, rx);
+
+ if (cx->sb_iters++) {
+ if (cx->sb_iters > cx->sb_maxiters)
+ DIE("Substitution loop");
+
+ if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
+ cx->sb_rxtainted |= 2;
+ sv_catsv(dstr, POPs);
+
+ /* Are we done */
+ if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
+ s == m, Nullsv, NULL,
+ cx->sb_safebase ? 0 : REXEC_COPY_STR))
+ {
+ SV *targ = cx->sb_targ;
+ sv_catpvn(dstr, s, cx->sb_strend - s);
+
+ cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
+
+ (void)SvOOK_off(targ);
+ Safefree(SvPVX(targ));
+ SvPVX(targ) = SvPVX(dstr);
+ SvCUR_set(targ, SvCUR(dstr));
+ SvLEN_set(targ, SvLEN(dstr));
+ SvPVX(dstr) = 0;
+ sv_free(dstr);
+
+ TAINT_IF(cx->sb_rxtainted & 1);
+ PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
+
+ (void)SvPOK_only(targ);
+ TAINT_IF(cx->sb_rxtainted);
+ SvSETMAGIC(targ);
+ SvTAINT(targ);
+
+ LEAVE_SCOPE(cx->sb_oldsave);
+ POPSUBST(cx);
+ RETURNOP(pm->op_next);
+ }
+ }
+ if (rx->subbase && rx->subbase != orig) {
+ m = s;
+ s = orig;
+ cx->sb_orig = orig = rx->subbase;
+ s = orig + (m - s);
+ cx->sb_strend = s + (cx->sb_strend - m);
+ }
+ cx->sb_m = m = rx->startp[0];
+ sv_catpvn(dstr, s, m-s);
+ cx->sb_s = rx->endp[0];
+ cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
+ rxres_save(&cx->sb_rxres, rx);
+ RETURNOP(pm->op_pmreplstart);
+}
+
+void
+rxres_save(void **rsp, REGEXP *rx)
+{
+ UV *p = (UV*)*rsp;
+ U32 i;
+
+ if (!p || p[1] < rx->nparens) {
+ i = 6 + rx->nparens * 2;
+ if (!p)
+ New(501, p, i, UV);
+ else
+ Renew(p, i, UV);
+ *rsp = (void*)p;
+ }
+
+ *p++ = (UV)rx->subbase;
+ rx->subbase = Nullch;
+
+ *p++ = rx->nparens;
+
+ *p++ = (UV)rx->subbeg;
+ *p++ = (UV)rx->subend;
+ for (i = 0; i <= rx->nparens; ++i) {
+ *p++ = (UV)rx->startp[i];
+ *p++ = (UV)rx->endp[i];
+ }
+}
+
+void
+rxres_restore(void **rsp, REGEXP *rx)
+{
+ UV *p = (UV*)*rsp;
+ U32 i;
+
+ Safefree(rx->subbase);
+ rx->subbase = (char*)(*p);
+ *p++ = 0;
+
+ rx->nparens = *p++;
+
+ rx->subbeg = (char*)(*p++);
+ rx->subend = (char*)(*p++);
+ for (i = 0; i <= rx->nparens; ++i) {
+ rx->startp[i] = (char*)(*p++);
+ rx->endp[i] = (char*)(*p++);
+ }
+}
+
+void
+rxres_free(void **rsp)
+{
+ UV *p = (UV*)*rsp;
+
+ if (p) {
+ Safefree((char*)(*p));
+ Safefree(p);
+ *rsp = Null(void*);
+ }
+}
+
+PP(pp_formline)
+{
+ djSP; dMARK; dORIGMARK;
+ register SV *tmpForm = *++MARK;
+ register U16 *fpc;
+ register char *t;
+ register char *f;
+ register char *s;
+ register char *send;
+ register I32 arg;
+ register SV *sv;
+ char *item;
+ I32 itemsize;
+ I32 fieldsize;
+ I32 lines = 0;
+ bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
+ char *chophere;
+ char *linemark;
+ double value;
+ bool gotsome;
+ STRLEN len;
+
+ if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
+ SvREADONLY_off(tmpForm);
+ doparseform(tmpForm);
+ }
+
+ SvPV_force(PL_formtarget, len);
+ t = SvGROW(PL_formtarget, len + SvCUR(tmpForm) + 1); /* XXX SvCUR bad */
+ t += len;
+ f = SvPV(tmpForm, len);
+ /* need to jump to the next word */
+ s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
+
+ fpc = (U16*)s;
+
+ for (;;) {
+ DEBUG_f( {
+ char *name = "???";
+ arg = -1;
+ switch (*fpc) {
+ case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
+ case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
+ case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
+ case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
+ case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
+
+ case FF_CHECKNL: name = "CHECKNL"; break;
+ case FF_CHECKCHOP: name = "CHECKCHOP"; break;
+ case FF_SPACE: name = "SPACE"; break;
+ case FF_HALFSPACE: name = "HALFSPACE"; break;
+ case FF_ITEM: name = "ITEM"; break;
+ case FF_CHOP: name = "CHOP"; break;
+ case FF_LINEGLOB: name = "LINEGLOB"; break;
+ case FF_NEWLINE: name = "NEWLINE"; break;
+ case FF_MORE: name = "MORE"; break;
+ case FF_LINEMARK: name = "LINEMARK"; break;
+ case FF_END: name = "END"; break;
+ }
+ if (arg >= 0)
+ PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
+ else
+ PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
+ } )
+ switch (*fpc++) {
+ case FF_LINEMARK:
+ linemark = t;
+ lines++;
+ gotsome = FALSE;
+ break;
+
+ case FF_LITERAL:
+ arg = *fpc++;
+ while (arg--)
+ *t++ = *f++;
+ break;
+
+ case FF_SKIP:
+ f += *fpc++;
+ break;
+
+ case FF_FETCH:
+ arg = *fpc++;
+ f += arg;
+ fieldsize = arg;
+
+ if (MARK < SP)
+ sv = *++MARK;
+ else {
+ sv = &PL_sv_no;
+ if (PL_dowarn)
+ warn("Not enough format arguments");
+ }
+ break;
+
+ case FF_CHECKNL:
+ item = s = SvPV(sv, len);
+ itemsize = len;
+ if (itemsize > fieldsize)
+ itemsize = fieldsize;
+ send = chophere = s + itemsize;
+ while (s < send) {
+ if (*s & ~31)
+ gotsome = TRUE;
+ else if (*s == '\n')
+ break;
+ s++;
+ }
+ itemsize = s - item;
+ break;
+
+ case FF_CHECKCHOP:
+ item = s = SvPV(sv, len);
+ itemsize = len;
+ if (itemsize <= fieldsize) {
+ send = chophere = s + itemsize;
+ while (s < send) {
+ if (*s == '\r') {
+ itemsize = s - item;
+ break;
+ }
+ if (*s++ & ~31)
+ gotsome = TRUE;
+ }
+ }
+ else {
+ itemsize = fieldsize;
+ send = chophere = s + itemsize;
+ while (s < send || (s == send && isSPACE(*s))) {
+ if (isSPACE(*s)) {
+ if (chopspace)
+ chophere = s;
+ if (*s == '\r')
+ break;
+ }
+ else {
+ if (*s & ~31)
+ gotsome = TRUE;
+ if (strchr(PL_chopset, *s))
+ chophere = s + 1;
+ }
+ s++;
+ }
+ itemsize = chophere - item;
+ }
+ break;
+
+ case FF_SPACE:
+ arg = fieldsize - itemsize;
+ if (arg) {
+ fieldsize -= arg;
+ while (arg-- > 0)
+ *t++ = ' ';
+ }
+ break;
+
+ case FF_HALFSPACE:
+ arg = fieldsize - itemsize;
+ if (arg) {
+ arg /= 2;
+ fieldsize -= arg;
+ while (arg-- > 0)
+ *t++ = ' ';
+ }
+ break;
+
+ case FF_ITEM:
+ arg = itemsize;
+ s = item;
+ while (arg--) {
+#ifdef EBCDIC
+ int ch = *t++ = *s++;
+ if (iscntrl(ch))
+#else
+ if ( !((*t++ = *s++) & ~31) )
+#endif
+ t[-1] = ' ';
+ }
+ break;
+
+ case FF_CHOP:
+ s = chophere;
+ if (chopspace) {
+ while (*s && isSPACE(*s))
+ s++;
+ }
+ sv_chop(sv,s);
+ break;
+
+ case FF_LINEGLOB:
+ item = s = SvPV(sv, len);
+ itemsize = len;
+ if (itemsize) {
+ gotsome = TRUE;
+ send = s + itemsize;
+ while (s < send) {
+ if (*s++ == '\n') {
+ if (s == send)
+ itemsize--;
+ else
+ lines++;
+ }
+ }
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ sv_catpvn(PL_formtarget, item, itemsize);
+ SvGROW(PL_formtarget, SvCUR(PL_formtarget) + SvCUR(tmpForm) + 1);
+ t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
+ }
+ break;
+
+ case FF_DECIMAL:
+ /* If the field is marked with ^ and the value is undefined,
+ blank it out. */
+ arg = *fpc++;
+ if ((arg & 512) && !SvOK(sv)) {
+ arg = fieldsize;
+ while (arg--)
+ *t++ = ' ';
+ break;
+ }
+ gotsome = TRUE;
+ value = SvNV(sv);
+ /* Formats aren't yet marked for locales, so assume "yes". */
+ SET_NUMERIC_LOCAL();
+ if (arg & 256) {
+ sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value);
+ } else {
+ sprintf(t, "%*.0f", (int) fieldsize, value);
+ }
+ t += fieldsize;
+ break;
+
+ case FF_NEWLINE:
+ f++;
+ while (t-- > linemark && *t == ' ') ;
+ t++;
+ *t++ = '\n';
+ break;
+
+ case FF_BLANK:
+ arg = *fpc++;
+ if (gotsome) {
+ if (arg) { /* repeat until fields exhausted? */
+ *t = '\0';
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ lines += FmLINES(PL_formtarget);
+ if (lines == 200) {
+ arg = t - linemark;
+ if (strnEQ(linemark, linemark - arg, arg))
+ DIE("Runaway format");
+ }
+ FmLINES(PL_formtarget) = lines;
+ SP = ORIGMARK;
+ RETURNOP(cLISTOP->op_first);
+ }
+ }
+ else {
+ t = linemark;
+ lines--;
+ }
+ break;
+
+ case FF_MORE:
+ if (itemsize) {
+ arg = fieldsize - itemsize;
+ if (arg) {
+ fieldsize -= arg;
+ while (arg-- > 0)
+ *t++ = ' ';
+ }
+ s = t - 3;
+ if (strnEQ(s," ",3)) {
+ while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
+ s--;
+ }
+ *s++ = '.';
+ *s++ = '.';
+ *s++ = '.';
+ }
+ break;
+
+ case FF_END:
+ *t = '\0';
+ SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ FmLINES(PL_formtarget) += lines;
+ SP = ORIGMARK;
+ RETPUSHYES;
+ }
+ }
+}
+
+PP(pp_grepstart)
+{
+ djSP;
+ SV *src;
+
+ if (PL_stack_base + *PL_markstack_ptr == SP) {
+ (void)POPMARK;
+ if (GIMME_V == G_SCALAR)
+ XPUSHs(&PL_sv_no);
+ RETURNOP(PL_op->op_next->op_next);
+ }
+ PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
+ pp_pushmark(ARGS); /* push dst */
+ pp_pushmark(ARGS); /* push src */
+ ENTER; /* enter outer scope */
+
+ SAVETMPS;
+#ifdef USE_THREADS
+ /* SAVE_DEFSV does *not* suffice here */
+ save_sptr(&THREADSV(0));
+#else
+ SAVESPTR(GvSV(PL_defgv));
+#endif /* USE_THREADS */
+ ENTER; /* enter inner scope */
+ SAVESPTR(PL_curpm);
+
+ src = PL_stack_base[*PL_markstack_ptr];
+ SvTEMP_off(src);
+ DEFSV = src;
+
+ PUTBACK;
+ if (PL_op->op_type == OP_MAPSTART)
+ pp_pushmark(ARGS); /* push top */
+ return ((LOGOP*)PL_op->op_next)->op_other;
+}
+
+PP(pp_mapstart)
+{
+ DIE("panic: mapstart"); /* uses grepstart */
+}
+
+PP(pp_mapwhile)
+{
+ djSP;
+ I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
+ I32 count;
+ I32 shift;
+ SV** src;
+ SV** dst;
+
+ ++PL_markstack_ptr[-1];
+ if (diff) {
+ if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
+ shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
+ count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
+
+ EXTEND(SP,shift);
+ src = SP;
+ dst = (SP += shift);
+ PL_markstack_ptr[-1] += shift;
+ *PL_markstack_ptr += shift;
+ while (--count)
+ *dst-- = *src--;
+ }
+ dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
+ ++diff;
+ while (--diff)
+ *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
+ }
+ LEAVE; /* exit inner scope */
+
+ /* All done yet? */
+ if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
+ I32 items;
+ I32 gimme = GIMME_V;
+
+ (void)POPMARK; /* pop top */
+ LEAVE; /* exit outer scope */
+ (void)POPMARK; /* pop src */
+ items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
+ (void)POPMARK; /* pop dst */
+ SP = PL_stack_base + POPMARK; /* pop original mark */
+ if (gimme == G_SCALAR) {
+ dTARGET;
+ XPUSHi(items);
+ }
+ else if (gimme == G_ARRAY)
+ SP += items;
+ RETURN;
+ }
+ else {
+ SV *src;
+
+ ENTER; /* enter inner scope */
+ SAVESPTR(PL_curpm);
+
+ src = PL_stack_base[PL_markstack_ptr[-1]];
+ SvTEMP_off(src);
+ DEFSV = src;
+
+ RETURNOP(cLOGOP->op_other);
+ }
+}
+
+PP(pp_sort)
+{
+ djSP; dMARK; dORIGMARK;
+ register SV **up;
+ SV **myorigmark = ORIGMARK;
+ register I32 max;
+ HV *stash;
+ GV *gv;
+ CV *cv;
+ I32 gimme = GIMME;
+ OP* nextop = PL_op->op_next;
+
+ if (gimme != G_ARRAY) {
+ SP = MARK;
+ RETPUSHUNDEF;
+ }
+
+ ENTER;
+ SAVEPPTR(PL_sortcop);
+ if (PL_op->op_flags & OPf_STACKED) {
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ OP *kid = cLISTOP->op_first->op_sibling; /* pass pushmark */
+ kid = kUNOP->op_first; /* pass rv2gv */
+ kid = kUNOP->op_first; /* pass leave */
+ PL_sortcop = kid->op_next;
+ stash = PL_curcop->cop_stash;
+ }
+ else {
+ cv = sv_2cv(*++MARK, &stash, &gv, 0);
+ if (!(cv && CvROOT(cv))) {
+ if (gv) {
+ SV *tmpstr = sv_newmortal();
+ gv_efullname3(tmpstr, gv, Nullch);
+ if (cv && CvXSUB(cv))
+ DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
+ DIE("Undefined sort subroutine \"%s\" called",
+ SvPVX(tmpstr));
+ }
+ if (cv) {
+ if (CvXSUB(cv))
+ DIE("Xsub called in sort");
+ DIE("Undefined subroutine in sort");
+ }
+ DIE("Not a CODE reference in sort");
+ }
+ PL_sortcop = CvSTART(cv);
+ SAVESPTR(CvROOT(cv)->op_ppaddr);
+ CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
+
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+ }
+ }
+ else {
+ PL_sortcop = Nullop;
+ stash = PL_curcop->cop_stash;
+ }
+
+ up = myorigmark + 1;
+ while (MARK < SP) { /* This may or may not shift down one here. */
+ /*SUPPRESS 560*/
+ if (*up = *++MARK) { /* Weed out nulls. */
+ SvTEMP_off(*up);
+ if (!PL_sortcop && !SvPOK(*up))
+ (void)sv_2pv(*up, &PL_na);
+ up++;
+ }
+ }
+ max = --up - myorigmark;
+ if (PL_sortcop) {
+ if (max > 1) {
+ PERL_CONTEXT *cx;
+ SV** newsp;
+ bool oldcatch = CATCH_GET;
+
+ SAVETMPS;
+ SAVEOP();
+
+ CATCH_SET(TRUE);
+ PUSHSTACKi(PERLSI_SORT);
+ if (PL_sortstash != stash) {
+ PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
+ PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
+ PL_sortstash = stash;
+ }
+
+ SAVESPTR(GvSV(PL_firstgv));
+ SAVESPTR(GvSV(PL_secondgv));
+
+ PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
+ if (!(PL_op->op_flags & OPf_SPECIAL)) {
+ bool hasargs = FALSE;
+ cx->cx_type = CXt_SUB;
+ cx->blk_gimme = G_SCALAR;
+ PUSHSUB(cx);
+ if (!CvDEPTH(cv))
+ (void)SvREFCNT_inc(cv); /* in preparation for POPSUB */
+ }
+ PL_sortcxix = cxstack_ix;
+ qsortsv((myorigmark+1), max, FUNC_NAME_TO_PTR(sortcv));
+
+ POPBLOCK(cx,PL_curpm);
+ POPSTACK;
+ CATCH_SET(oldcatch);
+ }
+ }
+ else {
+ if (max > 1) {
+ MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
+ qsortsv(ORIGMARK+1, max,
+ (PL_op->op_private & OPpLOCALE)
+ ? FUNC_NAME_TO_PTR(sv_cmp_locale)
+ : FUNC_NAME_TO_PTR(sv_cmp));
+ }
+ }
+ LEAVE;
+ PL_stack_sp = ORIGMARK + max;
+ return nextop;
+}
+
+/* Range stuff. */
+
+PP(pp_range)
+{
+ if (GIMME == G_ARRAY)
+ return cCONDOP->op_true;
+ return SvTRUEx(PAD_SV(PL_op->op_targ)) ? cCONDOP->op_false : cCONDOP->op_true;
+}
+
+PP(pp_flip)
+{
+ djSP;
+
+ if (GIMME == G_ARRAY) {
+ RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
+ }
+ else {
+ dTOPss;
+ SV *targ = PAD_SV(PL_op->op_targ);
+
+ if ((PL_op->op_private & OPpFLIP_LINENUM)
+ ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
+ : SvTRUE(sv) ) {
+ sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ sv_setiv(targ, 1);
+ SETs(targ);
+ RETURN;
+ }
+ else {
+ sv_setiv(targ, 0);
+ SP--;
+ RETURNOP(((CONDOP*)cUNOP->op_first)->op_false);
+ }
+ }
+ sv_setpv(TARG, "");
+ SETs(targ);
+ RETURN;
+ }
+}
+
+PP(pp_flop)
+{
+ djSP;
+
+ if (GIMME == G_ARRAY) {
+ dPOPPOPssrl;
+ register I32 i;
+ register SV *sv;
+ I32 max;
+
+ if (SvNIOKp(left) || !SvPOKp(left) ||
+ (looks_like_number(left) && *SvPVX(left) != '0') )
+ {
+ if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX)
+ croak("Range iterator outside integer range");
+ i = SvIV(left);
+ max = SvIV(right);
+ if (max >= i) {
+ EXTEND_MORTAL(max - i + 1);
+ EXTEND(SP, max - i + 1);
+ }
+ while (i <= max) {
+ sv = sv_2mortal(newSViv(i++));
+ PUSHs(sv);
+ }
+ }
+ else {
+ SV *final = sv_mortalcopy(right);
+ STRLEN len;
+ char *tmps = SvPV(final, len);
+
+ sv = sv_mortalcopy(left);
+ SvPV_force(sv,PL_na);
+ while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
+ XPUSHs(sv);
+ if (strEQ(SvPVX(sv),tmps))
+ break;
+ sv = sv_2mortal(newSVsv(sv));
+ sv_inc(sv);
+ }
+ }
+ }
+ else {
+ dTOPss;
+ SV *targ = PAD_SV(cUNOP->op_first->op_targ);
+ sv_inc(targ);
+ if ((PL_op->op_private & OPpFLIP_LINENUM)
+ ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
+ : SvTRUE(sv) ) {
+ sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
+ sv_catpv(targ, "E0");
+ }
+ SETs(targ);
+ }
+
+ RETURN;
+}
+
+/* Control. */
+
+STATIC I32
+dopoptolabel(char *label)
+{
+ dTHR;
+ register I32 i;
+ register PERL_CONTEXT *cx;
+
+ for (i = cxstack_ix; i >= 0; i--) {
+ cx = &cxstack[i];
+ switch (cx->cx_type) {
+ case CXt_SUBST:
+ if (PL_dowarn)
+ warn("Exiting substitution via %s", op_name[PL_op->op_type]);
+ break;
+ case CXt_SUB:
+ if (PL_dowarn)
+ warn("Exiting subroutine via %s", op_name[PL_op->op_type]);
+ break;
+ case CXt_EVAL:
+ if (PL_dowarn)
+ warn("Exiting eval via %s", op_name[PL_op->op_type]);
+ break;
+ case CXt_NULL:
+ if (PL_dowarn)
+ warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]);
+ return -1;
+ case CXt_LOOP:
+ if (!cx->blk_loop.label ||
+ strNE(label, cx->blk_loop.label) ) {
+ DEBUG_l(deb("(Skipping label #%ld %s)\n",
+ (long)i, cx->blk_loop.label));
+ continue;
+ }
+ DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
+ return i;
+ }
+ }
+ return i;
+}
+
+I32
+dowantarray(void)
+{
+ I32 gimme = block_gimme();
+ return (gimme == G_VOID) ? G_SCALAR : gimme;
+}
+
+I32
+block_gimme(void)
+{
+ dTHR;
+ I32 cxix;
+
+ cxix = dopoptosub(cxstack_ix);
+ if (cxix < 0)
+ return G_VOID;
+
+ switch (cxstack[cxix].blk_gimme) {
+ case G_VOID:
+ return G_VOID;
+ case G_SCALAR:
+ return G_SCALAR;
+ case G_ARRAY:
+ return G_ARRAY;
+ default:
+ croak("panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
+ /* NOTREACHED */
+ return 0;
+ }
+}
+
+STATIC I32
+dopoptosub(I32 startingblock)
+{
+ dTHR;
+ return dopoptosub_at(cxstack, startingblock);
+}
+
+STATIC I32
+dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
+{
+ dTHR;
+ I32 i;
+ register PERL_CONTEXT *cx;
+ for (i = startingblock; i >= 0; i--) {
+ cx = &cxstk[i];
+ switch (cx->cx_type) {
+ default:
+ continue;
+ case CXt_EVAL:
+ case CXt_SUB:
+ DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
+ return i;
+ }
+ }
+ return i;
+}
+
+STATIC I32
+dopoptoeval(I32 startingblock)
+{
+ dTHR;
+ I32 i;
+ register PERL_CONTEXT *cx;
+ for (i = startingblock; i >= 0; i--) {
+ cx = &cxstack[i];
+ switch (cx->cx_type) {
+ default:
+ continue;
+ case CXt_EVAL:
+ DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
+ return i;
+ }
+ }
+ return i;
+}
+
+STATIC I32
+dopoptoloop(I32 startingblock)
+{
+ dTHR;
+ I32 i;
+ register PERL_CONTEXT *cx;
+ for (i = startingblock; i >= 0; i--) {
+ cx = &cxstack[i];
+ switch (cx->cx_type) {
+ case CXt_SUBST:
+ if (PL_dowarn)
+ warn("Exiting substitution via %s", op_name[PL_op->op_type]);
+ break;
+ case CXt_SUB:
+ if (PL_dowarn)
+ warn("Exiting subroutine via %s", op_name[PL_op->op_type]);
+ break;
+ case CXt_EVAL:
+ if (PL_dowarn)
+ warn("Exiting eval via %s", op_name[PL_op->op_type]);
+ break;
+ case CXt_NULL:
+ if (PL_dowarn)
+ warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]);
+ return -1;
+ case CXt_LOOP:
+ DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
+ return i;
+ }
+ }
+ return i;
+}
+
+void
+dounwind(I32 cxix)
+{
+ dTHR;
+ register PERL_CONTEXT *cx;
+ SV **newsp;
+ I32 optype;
+
+ while (cxstack_ix > cxix) {
+ cx = &cxstack[cxstack_ix];
+ DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
+ (long) cxstack_ix, block_type[cx->cx_type]));
+ /* Note: we don't need to restore the base context info till the end. */
+ switch (cx->cx_type) {
+ case CXt_SUBST:
+ POPSUBST(cx);
+ continue; /* not break */
+ case CXt_SUB:
+ POPSUB(cx);
+ break;
+ case CXt_EVAL:
+ POPEVAL(cx);
+ break;
+ case CXt_LOOP:
+ POPLOOP(cx);
+ break;
+ case CXt_NULL:
+ break;
+ }
+ cxstack_ix--;
+ }
+}
+
+OP *
+die_where(char *message)
+{
+ dSP;
+ if (PL_in_eval) {
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+
+ if (message) {
+ if (PL_in_eval & 4) {
+ SV **svp;
+ STRLEN klen = strlen(message);
+
+ svp = hv_fetch(ERRHV, message, klen, TRUE);
+ if (svp) {
+ if (!SvIOK(*svp)) {
+ static char prefix[] = "\t(in cleanup) ";
+ SV *err = ERRSV;
+ sv_upgrade(*svp, SVt_IV);
+ (void)SvIOK_only(*svp);
+ if (!SvPOK(err))
+ sv_setpv(err,"");
+ SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
+ sv_catpvn(err, prefix, sizeof(prefix)-1);
+ sv_catpvn(err, message, klen);
+ }
+ sv_inc(*svp);
+ }
+ }
+ else
+ sv_setpv(ERRSV, message);
+ }
+ else
+ message = SvPVx(ERRSV, PL_na);
+
+ while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
+ dounwind(-1);
+ POPSTACK;
+ }
+
+ if (cxix >= 0) {
+ I32 optype;
+
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ POPBLOCK(cx,PL_curpm);
+ if (cx->cx_type != CXt_EVAL) {
+ PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
+ my_exit(1);
+ }
+ POPEVAL(cx);
+
+ if (gimme == G_SCALAR)
+ *++newsp = &PL_sv_undef;
+ PL_stack_sp = newsp;
+
+ LEAVE;
+
+ if (optype == OP_REQUIRE) {
+ char* msg = SvPVx(ERRSV, PL_na);
+ DIE("%s", *msg ? msg : "Compilation failed in require");
+ }
+ return pop_return();
+ }
+ }
+ PerlIO_printf(PerlIO_stderr(), "%s",message);
+ PerlIO_flush(PerlIO_stderr());
+ my_failure_exit();
+ /* NOTREACHED */
+ return 0;
+}
+
+PP(pp_xor)
+{
+ djSP; dPOPTOPssrl;
+ if (SvTRUE(left) != SvTRUE(right))
+ RETSETYES;
+ else
+ RETSETNO;
+}
+
+PP(pp_andassign)
+{
+ djSP;
+ if (!SvTRUE(TOPs))
+ RETURN;
+ else
+ RETURNOP(cLOGOP->op_other);
+}
+
+PP(pp_orassign)
+{
+ djSP;
+ if (SvTRUE(TOPs))
+ RETURN;
+ else
+ RETURNOP(cLOGOP->op_other);
+}
+
+PP(pp_caller)
+{
+ djSP;
+ register I32 cxix = dopoptosub(cxstack_ix);
+ register PERL_CONTEXT *cx;
+ register PERL_CONTEXT *ccstack = cxstack;
+ PERL_SI *top_si = PL_curstackinfo;
+ I32 dbcxix;
+ I32 gimme;
+ HV *hv;
+ SV *sv;
+ I32 count = 0;
+
+ if (MAXARG)
+ count = POPi;
+ EXTEND(SP, 6);
+ for (;;) {
+ /* we may be in a higher stacklevel, so dig down deeper */
+ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
+ top_si = top_si->si_prev;
+ ccstack = top_si->si_cxstack;
+ cxix = dopoptosub_at(ccstack, top_si->si_cxix);
+ }
+ if (cxix < 0) {
+ if (GIMME != G_ARRAY)
+ RETPUSHUNDEF;
+ RETURN;
+ }
+ if (PL_DBsub && cxix >= 0 &&
+ ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
+ count++;
+ if (!count--)
+ break;
+ cxix = dopoptosub_at(ccstack, cxix - 1);
+ }
+
+ cx = &ccstack[cxix];
+ if (ccstack[cxix].cx_type == CXt_SUB) {
+ dbcxix = dopoptosub_at(ccstack, cxix - 1);
+ /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
+ field below is defined for any cx. */
+ if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
+ cx = &ccstack[dbcxix];
+ }
+
+ if (GIMME != G_ARRAY) {
+ hv = cx->blk_oldcop->cop_stash;
+ if (!hv)
+ PUSHs(&PL_sv_undef);
+ else {
+ dTARGET;
+ sv_setpv(TARG, HvNAME(hv));
+ PUSHs(TARG);
+ }
+ RETURN;
+ }
+
+ hv = cx->blk_oldcop->cop_stash;
+ if (!hv)
+ PUSHs(&PL_sv_undef);
+ else
+ PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0)));
+ PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
+ PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
+ if (!MAXARG)
+ RETURN;
+ if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */
+ sv = NEWSV(49, 0);
+ gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
+ PUSHs(sv_2mortal(sv));
+ PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
+ }
+ else {
+ PUSHs(sv_2mortal(newSVpv("(eval)",0)));
+ PUSHs(sv_2mortal(newSViv(0)));
+ }
+ gimme = (I32)cx->blk_gimme;
+ if (gimme == G_VOID)
+ PUSHs(&PL_sv_undef);
+ else
+ PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
+ if (cx->cx_type == CXt_EVAL) {
+ if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
+ PUSHs(cx->blk_eval.cur_text);
+ PUSHs(&PL_sv_no);
+ }
+ else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
+ /* Require, put the name. */
+ PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
+ PUSHs(&PL_sv_yes);
+ }
+ }
+ else if (cx->cx_type == CXt_SUB &&
+ cx->blk_sub.hasargs &&
+ PL_curcop->cop_stash == PL_debstash)
+ {
+ AV *ary = cx->blk_sub.argarray;
+ int off = AvARRAY(ary) - AvALLOC(ary);
+
+ if (!PL_dbargs) {
+ GV* tmpgv;
+ PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
+ SVt_PVAV)));
+ GvMULTI_on(tmpgv);
+ AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
+ }
+
+ if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
+ av_extend(PL_dbargs, AvFILLp(ary) + off);
+ Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
+ AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
+ }
+ RETURN;
+}
+
+STATIC I32
+sortcv(SV *a, SV *b)
+{
+ dTHR;
+ I32 oldsaveix = PL_savestack_ix;
+ I32 oldscopeix = PL_scopestack_ix;
+ I32 result;
+ GvSV(PL_firstgv) = a;
+ GvSV(PL_secondgv) = b;
+ PL_stack_sp = PL_stack_base;
+ PL_op = PL_sortcop;
+ CALLRUNOPS();
+ if (PL_stack_sp != PL_stack_base + 1)
+ croak("Sort subroutine didn't return single value");
+ if (!SvNIOKp(*PL_stack_sp))
+ croak("Sort subroutine didn't return a numeric value");
+ result = SvIV(*PL_stack_sp);
+ while (PL_scopestack_ix > oldscopeix) {
+ LEAVE;
+ }
+ leave_scope(oldsaveix);
+ return result;
+}
+
+PP(pp_reset)
+{
+ djSP;
+ char *tmps;
+
+ if (MAXARG < 1)
+ tmps = "";
+ else
+ tmps = POPp;
+ sv_reset(tmps, PL_curcop->cop_stash);
+ PUSHs(&PL_sv_yes);
+ RETURN;
+}
+
+PP(pp_lineseq)
+{
+ return NORMAL;
+}
+
+PP(pp_dbstate)
+{
+ PL_curcop = (COP*)PL_op;
+ TAINT_NOT; /* Each statement is presumed innocent */
+ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
+ FREETMPS;
+
+ if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
+ {
+ djSP;
+ register CV *cv;
+ register PERL_CONTEXT *cx;
+ I32 gimme = G_ARRAY;
+ I32 hasargs;
+ GV *gv;
+
+ gv = PL_DBgv;
+ cv = GvCV(gv);
+ if (!cv)
+ DIE("No DB::DB routine defined");
+
+ if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
+ return NORMAL;
+
+ ENTER;
+ SAVETMPS;
+
+ SAVEI32(PL_debug);
+ SAVESTACK_POS();
+ PL_debug = 0;
+ hasargs = 0;
+ SPAGAIN;
+
+ push_return(PL_op->op_next);
+ PUSHBLOCK(cx, CXt_SUB, SP);
+ PUSHSUB(cx);
+ CvDEPTH(cv)++;
+ (void)SvREFCNT_inc(cv);
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)*av_fetch(CvPADLIST(cv),1,FALSE));
+ RETURNOP(CvSTART(cv));
+ }
+ else
+ return NORMAL;
+}
+
+PP(pp_scope)
+{
+ return NORMAL;
+}
+
+PP(pp_enteriter)
+{
+ djSP; dMARK;
+ register PERL_CONTEXT *cx;
+ I32 gimme = GIMME_V;
+ SV **svp;
+
+ ENTER;
+ SAVETMPS;
+
+#ifdef USE_THREADS
+ if (PL_op->op_flags & OPf_SPECIAL)
+ svp = save_threadsv(PL_op->op_targ); /* per-thread variable */
+ else
+#endif /* USE_THREADS */
+ if (PL_op->op_targ) {
+ svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
+ SAVESPTR(*svp);
+ }
+ else {
+ GV *gv = (GV*)POPs;
+ (void)save_scalar(gv);
+ svp = &GvSV(gv); /* symbol table variable */
+ }
+
+ ENTER;
+
+ PUSHBLOCK(cx, CXt_LOOP, SP);
+ PUSHLOOP(cx, svp, MARK);
+ if (PL_op->op_flags & OPf_STACKED) {
+ cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
+ if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
+ dPOPss;
+ if (SvNIOKp(sv) || !SvPOKp(sv) ||
+ (looks_like_number(sv) && *SvPVX(sv) != '0')) {
+ if (SvNV(sv) < IV_MIN ||
+ SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
+ croak("Range iterator outside integer range");
+ cx->blk_loop.iterix = SvIV(sv);
+ cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
+ }
+ else
+ cx->blk_loop.iterlval = newSVsv(sv);
+ }
+ }
+ else {
+ cx->blk_loop.iterary = PL_curstack;
+ AvFILLp(PL_curstack) = SP - PL_stack_base;
+ cx->blk_loop.iterix = MARK - PL_stack_base;
+ }
+
+ RETURN;
+}
+
+PP(pp_enterloop)
+{
+ djSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme = GIMME_V;
+
+ ENTER;
+ SAVETMPS;
+ ENTER;
+
+ PUSHBLOCK(cx, CXt_LOOP, SP);
+ PUSHLOOP(cx, 0, SP);
+
+ RETURN;
+}
+
+PP(pp_leaveloop)
+{
+ djSP;
+ register PERL_CONTEXT *cx;
+ struct block_loop cxloop;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+ SV **mark;
+
+ POPBLOCK(cx,newpm);
+ mark = newsp;
+ POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
+
+ TAINT_NOT;
+ if (gimme == G_VOID)
+ ; /* do nothing */
+ else if (gimme == G_SCALAR) {
+ if (mark < SP)
+ *++newsp = sv_mortalcopy(*SP);
+ else
+ *++newsp = &PL_sv_undef;
+ }
+ else {
+ while (mark < SP) {
+ *++newsp = sv_mortalcopy(*++mark);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ SP = newsp;
+ PUTBACK;
+
+ POPLOOP2(); /* Stack values are safe: release loop vars ... */
+ PL_curpm = newpm; /* ... and pop $1 et al */
+
+ LEAVE;
+ LEAVE;
+
+ return NORMAL;
+}
+
+PP(pp_return)
+{
+ djSP; dMARK;
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ struct block_sub cxsub;
+ bool popsub2 = FALSE;
+ I32 gimme;
+ SV **newsp;
+ PMOP *newpm;
+ I32 optype = 0;
+
+ if (PL_curstackinfo->si_type == PERLSI_SORT) {
+ if (cxstack_ix == PL_sortcxix || dopoptosub(cxstack_ix) <= PL_sortcxix) {
+ if (cxstack_ix > PL_sortcxix)
+ dounwind(PL_sortcxix);
+ AvARRAY(PL_curstack)[1] = *SP;
+ PL_stack_sp = PL_stack_base + 1;
+ return 0;
+ }
+ }
+
+ cxix = dopoptosub(cxstack_ix);
+ if (cxix < 0)
+ DIE("Can't return outside a subroutine");
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ POPBLOCK(cx,newpm);
+ switch (cx->cx_type) {
+ case CXt_SUB:
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+ popsub2 = TRUE;
+ break;
+ case CXt_EVAL:
+ POPEVAL(cx);
+ if (optype == OP_REQUIRE &&
+ (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
+ {
+ /* Unassume the success we assumed earlier. */
+ char *name = cx->blk_eval.old_name;
+ (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
+ DIE("%s did not return a true value", name);
+ }
+ break;
+ default:
+ DIE("panic: return");
+ }
+
+ TAINT_NOT;
+ if (gimme == G_SCALAR) {
+ if (MARK < SP) {
+ if (popsub2) {
+ if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
+ if (SvTEMP(TOPs)) {
+ *++newsp = SvREFCNT_inc(*SP);
+ FREETMPS;
+ sv_2mortal(*newsp);
+ } else {
+ FREETMPS;
+ *++newsp = sv_mortalcopy(*SP);
+ }
+ } else
+ *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
+ } else
+ *++newsp = sv_mortalcopy(*SP);
+ } else
+ *++newsp = &PL_sv_undef;
+ }
+ else if (gimme == G_ARRAY) {
+ while (++MARK <= SP) {
+ *++newsp = (popsub2 && SvTEMP(*MARK))
+ ? *MARK : sv_mortalcopy(*MARK);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ PL_stack_sp = newsp;
+
+ /* Stack values are safe: */
+ if (popsub2) {
+ POPSUB2(); /* release CV and @_ ... */
+ }
+ PL_curpm = newpm; /* ... and pop $1 et al */
+
+ LEAVE;
+ return pop_return();
+}
+
+PP(pp_last)
+{
+ djSP;
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ struct block_loop cxloop;
+ struct block_sub cxsub;
+ I32 pop2 = 0;
+ I32 gimme;
+ I32 optype;
+ OP *nextop;
+ SV **newsp;
+ PMOP *newpm;
+ SV **mark = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
+
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ cxix = dopoptoloop(cxstack_ix);
+ if (cxix < 0)
+ DIE("Can't \"last\" outside a block");
+ }
+ else {
+ cxix = dopoptolabel(cPVOP->op_pv);
+ if (cxix < 0)
+ DIE("Label not found for \"last %s\"", cPVOP->op_pv);
+ }
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ POPBLOCK(cx,newpm);
+ switch (cx->cx_type) {
+ case CXt_LOOP:
+ POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
+ pop2 = CXt_LOOP;
+ nextop = cxloop.last_op->op_next;
+ break;
+ case CXt_SUB:
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+ pop2 = CXt_SUB;
+ nextop = pop_return();
+ break;
+ case CXt_EVAL:
+ POPEVAL(cx);
+ nextop = pop_return();
+ break;
+ default:
+ DIE("panic: last");
+ }
+
+ TAINT_NOT;
+ if (gimme == G_SCALAR) {
+ if (MARK < SP)
+ *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
+ ? *SP : sv_mortalcopy(*SP);
+ else
+ *++newsp = &PL_sv_undef;
+ }
+ else if (gimme == G_ARRAY) {
+ while (++MARK <= SP) {
+ *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
+ ? *MARK : sv_mortalcopy(*MARK);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ SP = newsp;
+ PUTBACK;
+
+ /* Stack values are safe: */
+ switch (pop2) {
+ case CXt_LOOP:
+ POPLOOP2(); /* release loop vars ... */
+ LEAVE;
+ break;
+ case CXt_SUB:
+ POPSUB2(); /* release CV and @_ ... */
+ break;
+ }
+ PL_curpm = newpm; /* ... and pop $1 et al */
+
+ LEAVE;
+ return nextop;
+}
+
+PP(pp_next)
+{
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 oldsave;
+
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ cxix = dopoptoloop(cxstack_ix);
+ if (cxix < 0)
+ DIE("Can't \"next\" outside a block");
+ }
+ else {
+ cxix = dopoptolabel(cPVOP->op_pv);
+ if (cxix < 0)
+ DIE("Label not found for \"next %s\"", cPVOP->op_pv);
+ }
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ TOPBLOCK(cx);
+ oldsave = PL_scopestack[PL_scopestack_ix - 1];
+ LEAVE_SCOPE(oldsave);
+ return cx->blk_loop.next_op;
+}
+
+PP(pp_redo)
+{
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ I32 oldsave;
+
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ cxix = dopoptoloop(cxstack_ix);
+ if (cxix < 0)
+ DIE("Can't \"redo\" outside a block");
+ }
+ else {
+ cxix = dopoptolabel(cPVOP->op_pv);
+ if (cxix < 0)
+ DIE("Label not found for \"redo %s\"", cPVOP->op_pv);
+ }
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+
+ TOPBLOCK(cx);
+ oldsave = PL_scopestack[PL_scopestack_ix - 1];
+ LEAVE_SCOPE(oldsave);
+ return cx->blk_loop.redo_op;
+}
+
+STATIC OP *
+dofindlabel(OP *o, char *label, OP **opstack, OP **oplimit)
+{
+ OP *kid;
+ OP **ops = opstack;
+ static char too_deep[] = "Target of goto is too deeply nested";
+
+ if (ops >= oplimit)
+ croak(too_deep);
+ if (o->op_type == OP_LEAVE ||
+ o->op_type == OP_SCOPE ||
+ o->op_type == OP_LEAVELOOP ||
+ o->op_type == OP_LEAVETRY)
+ {
+ *ops++ = cUNOPo->op_first;
+ if (ops >= oplimit)
+ croak(too_deep);
+ }
+ *ops = 0;
+ if (o->op_flags & OPf_KIDS) {
+ dTHR;
+ /* First try all the kids at this level, since that's likeliest. */
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
+ if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
+ kCOP->cop_label && strEQ(kCOP->cop_label, label))
+ return kid;
+ }
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
+ if (kid == PL_lastgotoprobe)
+ continue;
+ if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
+ (ops == opstack ||
+ (ops[-1]->op_type != OP_NEXTSTATE &&
+ ops[-1]->op_type != OP_DBSTATE)))
+ *ops++ = kid;
+ if (o = dofindlabel(kid, label, ops, oplimit))
+ return o;
+ }
+ }
+ *ops = 0;
+ return 0;
+}
+
+PP(pp_dump)
+{
+ return pp_goto(ARGS);
+ /*NOTREACHED*/
+}
+
+PP(pp_goto)
+{
+ djSP;
+ OP *retop = 0;
+ I32 ix;
+ register PERL_CONTEXT *cx;
+#define GOTO_DEPTH 64
+ OP *enterops[GOTO_DEPTH];
+ char *label;
+ int do_dump = (PL_op->op_type == OP_DUMP);
+
+ label = 0;
+ if (PL_op->op_flags & OPf_STACKED) {
+ SV *sv = POPs;
+
+ /* This egregious kludge implements goto &subroutine */
+ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
+ I32 cxix;
+ register PERL_CONTEXT *cx;
+ CV* cv = (CV*)SvRV(sv);
+ SV** mark;
+ I32 items = 0;
+ I32 oldsave;
+
+ if (!CvROOT(cv) && !CvXSUB(cv)) {
+ if (CvGV(cv)) {
+ SV *tmpstr = sv_newmortal();
+ gv_efullname3(tmpstr, CvGV(cv), Nullch);
+ DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
+ }
+ DIE("Goto undefined subroutine");
+ }
+
+ /* First do some returnish stuff. */
+ cxix = dopoptosub(cxstack_ix);
+ if (cxix < 0)
+ DIE("Can't goto subroutine outside a subroutine");
+ if (cxix < cxstack_ix)
+ dounwind(cxix);
+ TOPBLOCK(cx);
+ if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
+ DIE("Can't goto subroutine from an eval-string");
+ mark = PL_stack_sp;
+ if (cx->cx_type == CXt_SUB &&
+ cx->blk_sub.hasargs) { /* put @_ back onto stack */
+ AV* av = cx->blk_sub.argarray;
+
+ items = AvFILLp(av) + 1;
+ PL_stack_sp++;
+ EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
+ Copy(AvARRAY(av), PL_stack_sp, items, SV*);
+ PL_stack_sp += items;
+#ifndef USE_THREADS
+ SvREFCNT_dec(GvAV(PL_defgv));
+ GvAV(PL_defgv) = cx->blk_sub.savearray;
+#endif /* USE_THREADS */
+ AvREAL_off(av);
+ av_clear(av);
+ }
+ else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
+ AV* av;
+ int i;
+#ifdef USE_THREADS
+ av = (AV*)PL_curpad[0];
+#else
+ av = GvAV(PL_defgv);
+#endif
+ items = AvFILLp(av) + 1;
+ PL_stack_sp++;
+ EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
+ Copy(AvARRAY(av), PL_stack_sp, items, SV*);
+ PL_stack_sp += items;
+ }
+ if (cx->cx_type == CXt_SUB &&
+ !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
+ SvREFCNT_dec(cx->blk_sub.cv);
+ oldsave = PL_scopestack[PL_scopestack_ix - 1];
+ LEAVE_SCOPE(oldsave);
+
+ /* Now do some callish stuff. */
+ SAVETMPS;
+ if (CvXSUB(cv)) {
+ if (CvOLDSTYLE(cv)) {
+ I32 (*fp3)_((int,int,int));
+ while (SP > mark) {
+ SP[1] = SP[0];
+ SP--;
+ }
+ fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
+ items = (*fp3)(CvXSUBANY(cv).any_i32,
+ mark - PL_stack_base + 1,
+ items);
+ SP = PL_stack_base + items;
+ }
+ else {
+ SV **newsp;
+ I32 gimme;
+
+ PL_stack_sp--; /* There is no cv arg. */
+ /* Push a mark for the start of arglist */
+ PUSHMARK(mark);
+ (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
+ /* Pop the current context like a decent sub should */
+ POPBLOCK(cx, PL_curpm);
+ /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
+ }
+ LEAVE;
+ return pop_return();
+ }
+ else {
+ AV* padlist = CvPADLIST(cv);
+ SV** svp = AvARRAY(padlist);
+ if (cx->cx_type == CXt_EVAL) {
+ PL_in_eval = cx->blk_eval.old_in_eval;
+ PL_eval_root = cx->blk_eval.old_eval_root;
+ cx->cx_type = CXt_SUB;
+ cx->blk_sub.hasargs = 0;
+ }
+ cx->blk_sub.cv = cv;
+ cx->blk_sub.olddepth = CvDEPTH(cv);
+ CvDEPTH(cv)++;
+ if (CvDEPTH(cv) < 2)
+ (void)SvREFCNT_inc(cv);
+ else { /* save temporaries on recursion? */
+ if (CvDEPTH(cv) == 100 && PL_dowarn)
+ sub_crush_depth(cv);
+ if (CvDEPTH(cv) > AvFILLp(padlist)) {
+ AV *newpad = newAV();
+ SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
+ I32 ix = AvFILLp((AV*)svp[1]);
+ svp = AvARRAY(svp[0]);
+ for ( ;ix > 0; ix--) {
+ if (svp[ix] != &PL_sv_undef) {
+ char *name = SvPVX(svp[ix]);
+ if ((SvFLAGS(svp[ix]) & SVf_FAKE)
+ || *name == '&')
+ {
+ /* outer lexical or anon code */
+ av_store(newpad, ix,
+ SvREFCNT_inc(oldpad[ix]) );
+ }
+ else { /* our own lexical */
+ if (*name == '@')
+ av_store(newpad, ix, sv = (SV*)newAV());
+ else if (*name == '%')
+ av_store(newpad, ix, sv = (SV*)newHV());
+ else
+ av_store(newpad, ix, sv = NEWSV(0,0));
+ SvPADMY_on(sv);
+ }
+ }
+ else {
+ av_store(newpad, ix, sv = NEWSV(0,0));
+ SvPADTMP_on(sv);
+ }
+ }
+ if (cx->blk_sub.hasargs) {
+ AV* av = newAV();
+ av_extend(av, 0);
+ av_store(newpad, 0, (SV*)av);
+ AvFLAGS(av) = AVf_REIFY;
+ }
+ av_store(padlist, CvDEPTH(cv), (SV*)newpad);
+ AvFILLp(padlist) = CvDEPTH(cv);
+ svp = AvARRAY(padlist);
+ }
+ }
+#ifdef USE_THREADS
+ if (!cx->blk_sub.hasargs) {
+ AV* av = (AV*)PL_curpad[0];
+
+ items = AvFILLp(av) + 1;
+ if (items) {
+ /* Mark is at the end of the stack. */
+ EXTEND(SP, items);
+ Copy(AvARRAY(av), SP + 1, items, SV*);
+ SP += items;
+ PUTBACK ;
+ }
+ }
+#endif /* USE_THREADS */
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
+#ifndef USE_THREADS
+ if (cx->blk_sub.hasargs)
+#endif /* USE_THREADS */
+ {
+ AV* av = (AV*)PL_curpad[0];
+ SV** ary;
+
+#ifndef USE_THREADS
+ cx->blk_sub.savearray = GvAV(PL_defgv);
+ GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+#endif /* USE_THREADS */
+ cx->blk_sub.argarray = av;
+ ++mark;
+
+ if (items >= AvMAX(av) + 1) {
+ ary = AvALLOC(av);
+ if (AvARRAY(av) != ary) {
+ AvMAX(av) += AvARRAY(av) - AvALLOC(av);
+ SvPVX(av) = (char*)ary;
+ }
+ if (items >= AvMAX(av) + 1) {
+ AvMAX(av) = items - 1;
+ Renew(ary,items+1,SV*);
+ AvALLOC(av) = ary;
+ SvPVX(av) = (char*)ary;
+ }
+ }
+ Copy(mark,AvARRAY(av),items,SV*);
+ AvFILLp(av) = items - 1;
+
+ while (items--) {
+ if (*mark)
+ SvTEMP_off(*mark);
+ mark++;
+ }
+ }
+ if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
+ /*
+ * We do not care about using sv to call CV;
+ * it's for informational purposes only.
+ */
+ SV *sv = GvSV(PL_DBsub);
+ CV *gotocv;
+
+ if (PERLDB_SUB_NN) {
+ SvIVX(sv) = (IV)cv; /* Already upgraded, saved */
+ } else {
+ save_item(sv);
+ gv_efullname3(sv, CvGV(cv), Nullch);
+ }
+ if ( PERLDB_GOTO
+ && (gotocv = perl_get_cv("DB::goto", FALSE)) ) {
+ PUSHMARK( PL_stack_sp );
+ perl_call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
+ PL_stack_sp--;
+ }
+ }
+ RETURNOP(CvSTART(cv));
+ }
+ }
+ else
+ label = SvPV(sv,PL_na);
+ }
+ else if (PL_op->op_flags & OPf_SPECIAL) {
+ if (! do_dump)
+ DIE("goto must have label");
+ }
+ else
+ label = cPVOP->op_pv;
+
+ if (label && *label) {
+ OP *gotoprobe = 0;
+
+ /* find label */
+
+ PL_lastgotoprobe = 0;
+ *enterops = 0;
+ for (ix = cxstack_ix; ix >= 0; ix--) {
+ cx = &cxstack[ix];
+ switch (cx->cx_type) {
+ case CXt_EVAL:
+ gotoprobe = PL_eval_root; /* XXX not good for nested eval */
+ break;
+ case CXt_LOOP:
+ gotoprobe = cx->blk_oldcop->op_sibling;
+ break;
+ case CXt_SUBST:
+ continue;
+ case CXt_BLOCK:
+ if (ix)
+ gotoprobe = cx->blk_oldcop->op_sibling;
+ else
+ gotoprobe = PL_main_root;
+ break;
+ case CXt_SUB:
+ if (CvDEPTH(cx->blk_sub.cv)) {
+ gotoprobe = CvROOT(cx->blk_sub.cv);
+ break;
+ }
+ /* FALL THROUGH */
+ case CXt_NULL:
+ DIE("Can't \"goto\" outside a block");
+ default:
+ if (ix)
+ DIE("panic: goto");
+ gotoprobe = PL_main_root;
+ break;
+ }
+ retop = dofindlabel(gotoprobe, label,
+ enterops, enterops + GOTO_DEPTH);
+ if (retop)
+ break;
+ PL_lastgotoprobe = gotoprobe;
+ }
+ if (!retop)
+ DIE("Can't find label %s", label);
+
+ /* pop unwanted frames */
+
+ if (ix < cxstack_ix) {
+ I32 oldsave;
+
+ if (ix < 0)
+ ix = 0;
+ dounwind(ix);
+ TOPBLOCK(cx);
+ oldsave = PL_scopestack[PL_scopestack_ix];
+ LEAVE_SCOPE(oldsave);
+ }
+
+ /* push wanted frames */
+
+ if (*enterops && enterops[1]) {
+ OP *oldop = PL_op;
+ for (ix = 1; enterops[ix]; ix++) {
+ PL_op = enterops[ix];
+ /* Eventually we may want to stack the needed arguments
+ * for each op. For now, we punt on the hard ones. */
+ if (PL_op->op_type == OP_ENTERITER)
+ DIE("Can't \"goto\" into the middle of a foreach loop",
+ label);
+ (CALLOP->op_ppaddr)(ARGS);
+ }
+ PL_op = oldop;
+ }
+ }
+
+ if (do_dump) {
+#ifdef VMS
+ if (!retop) retop = PL_main_start;
+#endif
+ PL_restartop = retop;
+ PL_do_undump = TRUE;
+
+ my_unexec();
+
+ PL_restartop = 0; /* hmm, must be GNU unexec().. */
+ PL_do_undump = FALSE;
+ }
+
+ if (PL_top_env->je_prev) {
+ PL_restartop = retop;
+ JMPENV_JUMP(3);
+ }
+
+ RETURNOP(retop);
+}
+
+PP(pp_exit)
+{
+ djSP;
+ I32 anum;
+
+ if (MAXARG < 1)
+ anum = 0;
+ else {
+ anum = SvIVx(POPs);
+#ifdef VMSISH_EXIT
+ if (anum == 1 && VMSISH_EXIT)
+ anum = 0;
+#endif
+ }
+ my_exit(anum);
+ PUSHs(&PL_sv_undef);
+ RETURN;
+}
+
+#ifdef NOTYET
+PP(pp_nswitch)
+{
+ djSP;
+ double value = SvNVx(GvSV(cCOP->cop_gv));
+ register I32 match = I_32(value);
+
+ if (value < 0.0) {
+ if (((double)match) > value)
+ --match; /* was fractional--truncate other way */
+ }
+ match -= cCOP->uop.scop.scop_offset;
+ if (match < 0)
+ match = 0;
+ else if (match > cCOP->uop.scop.scop_max)
+ match = cCOP->uop.scop.scop_max;
+ PL_op = cCOP->uop.scop.scop_next[match];
+ RETURNOP(PL_op);
+}
+
+PP(pp_cswitch)
+{
+ djSP;
+ register I32 match;
+
+ if (PL_multiline)
+ PL_op = PL_op->op_next; /* can't assume anything */
+ else {
+ match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255;
+ match -= cCOP->uop.scop.scop_offset;
+ if (match < 0)
+ match = 0;
+ else if (match > cCOP->uop.scop.scop_max)
+ match = cCOP->uop.scop.scop_max;
+ PL_op = cCOP->uop.scop.scop_next[match];
+ }
+ RETURNOP(PL_op);
+}
+#endif
+
+/* Eval. */
+
+STATIC void
+save_lines(AV *array, SV *sv)
+{
+ register char *s = SvPVX(sv);
+ register char *send = SvPVX(sv) + SvCUR(sv);
+ register char *t;
+ register I32 line = 1;
+
+ while (s && s < send) {
+ SV *tmpstr = NEWSV(85,0);
+
+ sv_upgrade(tmpstr, SVt_PVMG);
+ t = strchr(s, '\n');
+ if (t)
+ t++;
+ else
+ t = send;
+
+ sv_setpvn(tmpstr, s, t - s);
+ av_store(array, line++, tmpstr);
+ s = t;
+ }
+}
+
+STATIC OP *
+docatch(OP *o)
+{
+ dTHR;
+ int ret;
+ OP *oldop = PL_op;
+ dJMPENV;
+
+ PL_op = o;
+#ifdef DEBUGGING
+ assert(CATCH_GET == TRUE);
+ DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
+#endif
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ default: /* topmost level handles it */
+ JMPENV_POP;
+ PL_op = oldop;
+ JMPENV_JUMP(ret);
+ /* NOTREACHED */
+ case 3:
+ if (!PL_restartop) {
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ break;
+ }
+ PL_op = PL_restartop;
+ PL_restartop = 0;
+ /* FALL THROUGH */
+ case 0:
+ CALLRUNOPS();
+ break;
+ }
+ JMPENV_POP;
+ PL_op = oldop;
+ return Nullop;
+}
+
+OP *
+sv_compile_2op(SV *sv, OP** startop, char *code, AV** avp)
+/* sv Text to convert to OP tree. */
+/* startop op_free() this to undo. */
+/* code Short string id of the caller. */
+{
+ dSP; /* Make POPBLOCK work. */
+ PERL_CONTEXT *cx;
+ SV **newsp;
+ I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
+ I32 optype;
+ OP dummy;
+ OP *oop = PL_op, *rop;
+ char tmpbuf[TYPE_DIGITS(long) + 12 + 10];
+ char *safestr;
+
+ ENTER;
+ lex_start(sv);
+ SAVETMPS;
+ /* switch to eval mode */
+
+ if (PL_curcop == &PL_compiling) {
+ SAVESPTR(PL_compiling.cop_stash);
+ PL_compiling.cop_stash = PL_curstash;
+ }
+ SAVESPTR(PL_compiling.cop_filegv);
+ SAVEI16(PL_compiling.cop_line);
+ sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
+ PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
+ PL_compiling.cop_line = 1;
+ /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
+ deleting the eval's FILEGV from the stash before gv_check() runs
+ (i.e. before run-time proper). To work around the coredump that
+ ensues, we always turn GvMULTI_on for any globals that were
+ introduced within evals. See force_ident(). GSAR 96-10-12 */
+ safestr = savepv(tmpbuf);
+ SAVEDELETE(PL_defstash, safestr, strlen(safestr));
+ SAVEHINTS();
+#ifdef OP_IN_REGISTER
+ PL_opsave = op;
+#else
+ SAVEPPTR(PL_op);
+#endif
+ PL_hints = 0;
+
+ PL_op = &dummy;
+ PL_op->op_type = 0; /* Avoid uninit warning. */
+ PL_op->op_flags = 0; /* Avoid uninit warning. */
+ PUSHBLOCK(cx, CXt_EVAL, SP);
+ PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
+ rop = doeval(G_SCALAR, startop);
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+
+ (*startop)->op_type = OP_NULL;
+ (*startop)->op_ppaddr = ppaddr[OP_NULL];
+ lex_end();
+ *avp = (AV*)SvREFCNT_inc(PL_comppad);
+ LEAVE;
+#ifdef OP_IN_REGISTER
+ op = PL_opsave;
+#endif
+ return rop;
+}
+
+/* With USE_THREADS, eval_owner must be held on entry to doeval */
+STATIC OP *
+doeval(int gimme, OP** startop)
+{
+ dSP;
+ OP *saveop = PL_op;
+ HV *newstash;
+ CV *caller;
+ AV* comppadlist;
+ I32 i;
+
+ PL_in_eval = 1;
+
+ PUSHMARK(SP);
+
+ /* set up a scratch pad */
+
+ SAVEI32(PL_padix);
+ SAVESPTR(PL_curpad);
+ SAVESPTR(PL_comppad);
+ SAVESPTR(PL_comppad_name);
+ SAVEI32(PL_comppad_name_fill);
+ SAVEI32(PL_min_intro_pending);
+ SAVEI32(PL_max_intro_pending);
+
+ caller = PL_compcv;
+ for (i = cxstack_ix; i >= 0; i--) {
+ PERL_CONTEXT *cx = &cxstack[i];
+ if (cx->cx_type == CXt_EVAL)
+ break;
+ else if (cx->cx_type == CXt_SUB) {
+ caller = cx->blk_sub.cv;
+ break;
+ }
+ }
+
+ SAVESPTR(PL_compcv);
+ PL_compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)PL_compcv, SVt_PVCV);
+ CvUNIQUE_on(PL_compcv);
+#ifdef USE_THREADS
+ CvOWNER(PL_compcv) = 0;
+ New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(PL_compcv));
+#endif /* USE_THREADS */
+
+ PL_comppad = newAV();
+ av_push(PL_comppad, Nullsv);
+ PL_curpad = AvARRAY(PL_comppad);
+ PL_comppad_name = newAV();
+ PL_comppad_name_fill = 0;
+ PL_min_intro_pending = 0;
+ PL_padix = 0;
+#ifdef USE_THREADS
+ av_store(PL_comppad_name, 0, newSVpv("@_", 2));
+ PL_curpad[0] = (SV*)newAV();
+ SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
+#endif /* USE_THREADS */
+
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, (SV*)PL_comppad_name);
+ av_store(comppadlist, 1, (SV*)PL_comppad);
+ CvPADLIST(PL_compcv) = comppadlist;
+
+ if (!saveop || saveop->op_type != OP_REQUIRE)
+ CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
+
+ SAVEFREESV(PL_compcv);
+
+ /* make sure we compile in the right package */
+
+ newstash = PL_curcop->cop_stash;
+ if (PL_curstash != newstash) {
+ SAVESPTR(PL_curstash);
+ PL_curstash = newstash;
+ }
+ SAVESPTR(PL_beginav);
+ PL_beginav = newAV();
+ SAVEFREESV(PL_beginav);
+
+ /* try to compile it */
+
+ PL_eval_root = Nullop;
+ PL_error_count = 0;
+ PL_curcop = &PL_compiling;
+ PL_curcop->cop_arybase = 0;
+ SvREFCNT_dec(PL_rs);
+ PL_rs = newSVpv("\n", 1);
+ if (saveop && saveop->op_flags & OPf_SPECIAL)
+ PL_in_eval |= 4;
+ else
+ sv_setpv(ERRSV,"");
+ if (yyparse() || PL_error_count || !PL_eval_root) {
+ SV **newsp;
+ I32 gimme;
+ PERL_CONTEXT *cx;
+ I32 optype = 0; /* Might be reset by POPEVAL. */
+
+ PL_op = saveop;
+ if (PL_eval_root) {
+ op_free(PL_eval_root);
+ PL_eval_root = Nullop;
+ }
+ SP = PL_stack_base + POPMARK; /* pop original mark */
+ if (!startop) {
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ pop_return();
+ }
+ lex_end();
+ LEAVE;
+ if (optype == OP_REQUIRE) {
+ char* msg = SvPVx(ERRSV, PL_na);
+ DIE("%s", *msg ? msg : "Compilation failed in require");
+ } else if (startop) {
+ char* msg = SvPVx(ERRSV, PL_na);
+
+ POPBLOCK(cx,PL_curpm);
+ POPEVAL(cx);
+ croak("%sCompilation failed in regexp", (*msg ? msg : "Unknown error\n"));
+ }
+ SvREFCNT_dec(PL_rs);
+ PL_rs = SvREFCNT_inc(PL_nrs);
+#ifdef USE_THREADS
+ MUTEX_LOCK(&PL_eval_mutex);
+ PL_eval_owner = 0;
+ COND_SIGNAL(&PL_eval_cond);
+ MUTEX_UNLOCK(&PL_eval_mutex);
+#endif /* USE_THREADS */
+ RETPUSHUNDEF;
+ }
+ SvREFCNT_dec(PL_rs);
+ PL_rs = SvREFCNT_inc(PL_nrs);
+ PL_compiling.cop_line = 0;
+ if (startop) {
+ *startop = PL_eval_root;
+ SvREFCNT_dec(CvOUTSIDE(PL_compcv));
+ CvOUTSIDE(PL_compcv) = Nullcv;
+ } else
+ SAVEFREEOP(PL_eval_root);
+ if (gimme & G_VOID)
+ scalarvoid(PL_eval_root);
+ else if (gimme & G_ARRAY)
+ list(PL_eval_root);
+ else
+ scalar(PL_eval_root);
+
+ DEBUG_x(dump_eval());
+
+ /* Register with debugger: */
+ if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
+ CV *cv = perl_get_cv("DB::postponed", FALSE);
+ if (cv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs((SV*)PL_compiling.cop_filegv);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
+ }
+
+ /* compiled okay, so do it */
+
+ CvDEPTH(PL_compcv) = 1;
+ SP = PL_stack_base + POPMARK; /* pop original mark */
+ PL_op = saveop; /* The caller may need it. */
+#ifdef USE_THREADS
+ MUTEX_LOCK(&PL_eval_mutex);
+ PL_eval_owner = 0;
+ COND_SIGNAL(&PL_eval_cond);
+ MUTEX_UNLOCK(&PL_eval_mutex);
+#endif /* USE_THREADS */
+
+ RETURNOP(PL_eval_start);
+}
+
+PP(pp_require)
+{
+ djSP;
+ register PERL_CONTEXT *cx;
+ SV *sv;
+ char *name;
+ STRLEN len;
+ char *tryname;
+ SV *namesv = Nullsv;
+ SV** svp;
+ I32 gimme = G_SCALAR;
+ PerlIO *tryrsfp = 0;
+
+ 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);
+ RETPUSHYES;
+ }
+ name = SvPV(sv, len);
+ if (!(name && len > 0 && *name))
+ DIE("Null filename used");
+ TAINT_PROPER("require");
+ if (PL_op->op_type == OP_REQUIRE &&
+ (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
+ *svp != &PL_sv_undef)
+ RETPUSHYES;
+
+ /* prepare to compile file */
+
+ if (*name == '/' ||
+ (*name == '.' &&
+ (name[1] == '/' ||
+ (name[1] == '.' && name[2] == '/')))
+#ifdef DOSISH
+ || (name[0] && name[1] == ':')
+#endif
+#ifdef WIN32
+ || (name[0] == '\\' && name[1] == '\\') /* UNC path */
+#endif
+#ifdef VMS
+ || (strchr(name,':') || ((*name == '[' || *name == '<') &&
+ (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
+#endif
+ )
+ {
+ tryname = name;
+ tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
+ }
+ else {
+ AV *ar = GvAVn(PL_incgv);
+ I32 i;
+#ifdef VMS
+ char *unixname;
+ if ((unixname = tounixspec(name, Nullch)) != Nullch)
+#endif
+ {
+ namesv = NEWSV(806, 0);
+ for (i = 0; i <= AvFILL(ar); i++) {
+ char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na);
+#ifdef VMS
+ char *unixdir;
+ if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
+ continue;
+ sv_setpv(namesv, unixdir);
+ sv_catpv(namesv, unixname);
+#else
+ sv_setpvf(namesv, "%s/%s", dir, name);
+#endif
+ tryname = SvPVX(namesv);
+ tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
+ if (tryrsfp) {
+ if (tryname[0] == '.' && tryname[1] == '/')
+ tryname += 2;
+ break;
+ }
+ }
+ }
+ }
+ SAVESPTR(PL_compiling.cop_filegv);
+ PL_compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
+ SvREFCNT_dec(namesv);
+ if (!tryrsfp) {
+ if (PL_op->op_type == OP_REQUIRE) {
+ SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
+ SV *dirmsgsv = NEWSV(0, 0);
+ AV *ar = GvAVn(PL_incgv);
+ I32 i;
+ if (instr(SvPVX(msg), ".h "))
+ sv_catpv(msg, " (change .h to .ph maybe?)");
+ if (instr(SvPVX(msg), ".ph "))
+ 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);
+ sv_setpvf(dirmsgsv, " %s", dir);
+ sv_catsv(msg, dirmsgsv);
+ }
+ sv_catpvn(msg, ")", 1);
+ SvREFCNT_dec(dirmsgsv);
+ DIE("%_", msg);
+ }
+
+ RETPUSHUNDEF;
+ }
+
+ /* Assume success here to prevent recursive requirement. */
+ (void)hv_store(GvHVn(PL_incgv), name, strlen(name),
+ newSVsv(GvSV(PL_compiling.cop_filegv)), 0 );
+
+ ENTER;
+ SAVETMPS;
+ lex_start(sv_2mortal(newSVpv("",0)));
+ if (PL_rsfp_filters){
+ save_aptr(&PL_rsfp_filters);
+ PL_rsfp_filters = NULL;
+ }
+
+ PL_rsfp = tryrsfp;
+ name = savepv(name);
+ SAVEFREEPV(name);
+ SAVEHINTS();
+ PL_hints = 0;
+
+ /* switch to eval mode */
+
+ push_return(PL_op->op_next);
+ PUSHBLOCK(cx, CXt_EVAL, SP);
+ PUSHEVAL(cx, name, PL_compiling.cop_filegv);
+
+ PL_compiling.cop_line = 0;
+
+ PUTBACK;
+#ifdef USE_THREADS
+ MUTEX_LOCK(&PL_eval_mutex);
+ if (PL_eval_owner && PL_eval_owner != thr)
+ while (PL_eval_owner)
+ COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
+ PL_eval_owner = thr;
+ MUTEX_UNLOCK(&PL_eval_mutex);
+#endif /* USE_THREADS */
+ return DOCATCH(doeval(G_SCALAR, NULL));
+}
+
+PP(pp_dofile)
+{
+ return pp_require(ARGS);
+}
+
+PP(pp_entereval)
+{
+ djSP;
+ register PERL_CONTEXT *cx;
+ dPOPss;
+ I32 gimme = GIMME_V, was = PL_sub_generation;
+ char tmpbuf[TYPE_DIGITS(long) + 12];
+ char *safestr;
+ STRLEN len;
+ OP *ret;
+
+ if (!SvPV(sv,len) || !len)
+ RETPUSHUNDEF;
+ TAINT_PROPER("eval");
+
+ ENTER;
+ lex_start(sv);
+ SAVETMPS;
+
+ /* switch to eval mode */
+
+ SAVESPTR(PL_compiling.cop_filegv);
+ sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+ PL_compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
+ PL_compiling.cop_line = 1;
+ /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
+ deleting the eval's FILEGV from the stash before gv_check() runs
+ (i.e. before run-time proper). To work around the coredump that
+ ensues, we always turn GvMULTI_on for any globals that were
+ introduced within evals. See force_ident(). GSAR 96-10-12 */
+ safestr = savepv(tmpbuf);
+ SAVEDELETE(PL_defstash, safestr, strlen(safestr));
+ SAVEHINTS();
+ PL_hints = PL_op->op_targ;
+
+ push_return(PL_op->op_next);
+ PUSHBLOCK(cx, CXt_EVAL, SP);
+ PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
+
+ /* prepare to compile string */
+
+ if (PERLDB_LINE && PL_curstash != PL_debstash)
+ save_lines(GvAV(PL_compiling.cop_filegv), PL_linestr);
+ PUTBACK;
+#ifdef USE_THREADS
+ MUTEX_LOCK(&PL_eval_mutex);
+ if (PL_eval_owner && PL_eval_owner != thr)
+ while (PL_eval_owner)
+ COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
+ PL_eval_owner = thr;
+ MUTEX_UNLOCK(&PL_eval_mutex);
+#endif /* USE_THREADS */
+ ret = doeval(gimme, NULL);
+ if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
+ && ret != PL_op->op_next) { /* Successive compilation. */
+ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
+ }
+ return DOCATCH(ret);
+}
+
+PP(pp_leaveeval)
+{
+ djSP;
+ register SV **mark;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
+ register PERL_CONTEXT *cx;
+ OP *retop;
+ U8 save_flags = PL_op -> op_flags;
+ I32 optype;
+
+ POPBLOCK(cx,newpm);
+ POPEVAL(cx);
+ retop = pop_return();
+
+ TAINT_NOT;
+ if (gimme == G_VOID)
+ MARK = newsp;
+ else if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP) {
+ if (SvFLAGS(TOPs) & SVs_TEMP)
+ *MARK = TOPs;
+ else
+ *MARK = sv_mortalcopy(TOPs);
+ }
+ else {
+ MEXTEND(mark,0);
+ *MARK = &PL_sv_undef;
+ }
+ }
+ else {
+ /* in case LEAVE wipes old return values */
+ for (mark = newsp + 1; mark <= SP; mark++) {
+ if (!(SvFLAGS(*mark) & SVs_TEMP)) {
+ *mark = sv_mortalcopy(*mark);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ }
+ PL_curpm = newpm; /* Don't pop $1 et al till now */
+
+ /*
+ * Closures mentioned at top level of eval cannot be referenced
+ * again, and their presence indirectly causes a memory leak.
+ * (Note that the fact that compcv and friends are still set here
+ * is, AFAIK, an accident.) --Chip
+ */
+ if (AvFILLp(PL_comppad_name) >= 0) {
+ SV **svp = AvARRAY(PL_comppad_name);
+ I32 ix;
+ for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
+ SV *sv = svp[ix];
+ if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
+ SvREFCNT_dec(sv);
+ svp[ix] = &PL_sv_undef;
+
+ sv = PL_curpad[ix];
+ if (CvCLONE(sv)) {
+ SvREFCNT_dec(CvOUTSIDE(sv));
+ CvOUTSIDE(sv) = Nullcv;
+ }
+ else {
+ SvREFCNT_dec(sv);
+ sv = NEWSV(0,0);
+ SvPADTMP_on(sv);
+ PL_curpad[ix] = sv;
+ }
+ }
+ }
+ }
+
+#ifdef DEBUGGING
+ assert(CvDEPTH(PL_compcv) == 1);
+#endif
+ CvDEPTH(PL_compcv) = 0;
+ lex_end();
+
+ if (optype == OP_REQUIRE &&
+ !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
+ {
+ /* Unassume the success we assumed earlier. */
+ char *name = cx->blk_eval.old_name;
+ (void)hv_delete(GvHVn(PL_incgv), name, strlen(name), G_DISCARD);
+ retop = die("%s did not return a true value", name);
+ /* die_where() did LEAVE, or we won't be here */
+ }
+ else {
+ LEAVE;
+ if (!(save_flags & OPf_SPECIAL))
+ sv_setpv(ERRSV,"");
+ }
+
+ RETURNOP(retop);
+}
+
+PP(pp_entertry)
+{
+ djSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme = GIMME_V;
+
+ ENTER;
+ SAVETMPS;
+
+ push_return(cLOGOP->op_other->op_next);
+ PUSHBLOCK(cx, CXt_EVAL, SP);
+ PUSHEVAL(cx, 0, 0);
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
+
+ PL_in_eval = 1;
+ sv_setpv(ERRSV,"");
+ PUTBACK;
+ return DOCATCH(PL_op->op_next);
+}
+
+PP(pp_leavetry)
+{
+ djSP;
+ register SV **mark;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
+ register PERL_CONTEXT *cx;
+ I32 optype;
+
+ POPBLOCK(cx,newpm);
+ POPEVAL(cx);
+ pop_return();
+
+ TAINT_NOT;
+ if (gimme == G_VOID)
+ SP = newsp;
+ else if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP) {
+ if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
+ *MARK = TOPs;
+ else
+ *MARK = sv_mortalcopy(TOPs);
+ }
+ else {
+ MEXTEND(mark,0);
+ *MARK = &PL_sv_undef;
+ }
+ SP = MARK;
+ }
+ else {
+ /* in case LEAVE wipes old return values */
+ for (mark = newsp + 1; mark <= SP; mark++) {
+ if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
+ *mark = sv_mortalcopy(*mark);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ }
+ PL_curpm = newpm; /* Don't pop $1 et al till now */
+
+ LEAVE;
+ sv_setpv(ERRSV,"");
+ RETURN;
+}
+
+STATIC void
+doparseform(SV *sv)
+{
+ STRLEN len;
+ register char *s = SvPV_force(sv, len);
+ register char *send = s + len;
+ register char *base;
+ register I32 skipspaces = 0;
+ bool noblank;
+ bool repeat;
+ bool postspace = FALSE;
+ U16 *fops;
+ register U16 *fpc;
+ U16 *linepc;
+ register I32 arg;
+ bool ischop;
+
+ if (len == 0)
+ croak("Null picture in formline");
+
+ New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */
+ fpc = fops;
+
+ if (s < send) {
+ linepc = fpc;
+ *fpc++ = FF_LINEMARK;
+ noblank = repeat = FALSE;
+ base = s;
+ }
+
+ while (s <= send) {
+ switch (*s++) {
+ default:
+ skipspaces = 0;
+ continue;
+
+ case '~':
+ if (*s == '~') {
+ repeat = TRUE;
+ *s = ' ';
+ }
+ noblank = TRUE;
+ s[-1] = ' ';
+ /* FALL THROUGH */
+ case ' ': case '\t':
+ skipspaces++;
+ continue;
+
+ case '\n': case 0:
+ arg = s - base;
+ skipspaces++;
+ arg -= skipspaces;
+ if (arg) {
+ if (postspace)
+ *fpc++ = FF_SPACE;
+ *fpc++ = FF_LITERAL;
+ *fpc++ = arg;
+ }
+ postspace = FALSE;
+ if (s <= send)
+ skipspaces--;
+ if (skipspaces) {
+ *fpc++ = FF_SKIP;
+ *fpc++ = skipspaces;
+ }
+ skipspaces = 0;
+ if (s <= send)
+ *fpc++ = FF_NEWLINE;
+ if (noblank) {
+ *fpc++ = FF_BLANK;
+ if (repeat)
+ arg = fpc - linepc + 1;
+ else
+ arg = 0;
+ *fpc++ = arg;
+ }
+ if (s < send) {
+ linepc = fpc;
+ *fpc++ = FF_LINEMARK;
+ noblank = repeat = FALSE;
+ base = s;
+ }
+ else
+ s++;
+ continue;
+
+ case '@':
+ case '^':
+ ischop = s[-1] == '^';
+
+ if (postspace) {
+ *fpc++ = FF_SPACE;
+ postspace = FALSE;
+ }
+ arg = (s - base) - 1;
+ if (arg) {
+ *fpc++ = FF_LITERAL;
+ *fpc++ = arg;
+ }
+
+ base = s - 1;
+ *fpc++ = FF_FETCH;
+ if (*s == '*') {
+ s++;
+ *fpc++ = 0;
+ *fpc++ = FF_LINEGLOB;
+ }
+ else if (*s == '#' || (*s == '.' && s[1] == '#')) {
+ arg = ischop ? 512 : 0;
+ base = s - 1;
+ while (*s == '#')
+ s++;
+ if (*s == '.') {
+ char *f;
+ s++;
+ f = s;
+ while (*s == '#')
+ s++;
+ arg |= 256 + (s - f);
+ }
+ *fpc++ = s - base; /* fieldsize for FETCH */
+ *fpc++ = FF_DECIMAL;
+ *fpc++ = arg;
+ }
+ else {
+ I32 prespace = 0;
+ bool ismore = FALSE;
+
+ if (*s == '>') {
+ while (*++s == '>') ;
+ prespace = FF_SPACE;
+ }
+ else if (*s == '|') {
+ while (*++s == '|') ;
+ prespace = FF_HALFSPACE;
+ postspace = TRUE;
+ }
+ else {
+ if (*s == '<')
+ while (*++s == '<') ;
+ postspace = TRUE;
+ }
+ if (*s == '.' && s[1] == '.' && s[2] == '.') {
+ s += 3;
+ ismore = TRUE;
+ }
+ *fpc++ = s - base; /* fieldsize for FETCH */
+
+ *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
+
+ if (prespace)
+ *fpc++ = prespace;
+ *fpc++ = FF_ITEM;
+ if (ismore)
+ *fpc++ = FF_MORE;
+ if (ischop)
+ *fpc++ = FF_CHOP;
+ }
+ base = s;
+ skipspaces = 0;
+ continue;
+ }
+ }
+ *fpc++ = FF_END;
+
+ arg = fpc - fops;
+ { /* need to jump to the next word */
+ int z;
+ z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
+ SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
+ s = SvPVX(sv) + SvCUR(sv) + z;
+ }
+ Copy(fops, s, arg, U16);
+ Safefree(fops);
+ sv_magic(sv, Nullsv, 'f', Nullch, 0);
+ SvCOMPILED_on(sv);
+}
+
+/*
+ * The rest of this file was derived from source code contributed
+ * by Tom Horsley.
+ *
+ * NOTE: this code was derived from Tom Horsley's qsort replacement
+ * and should not be confused with the original code.
+ */
+
+/* Copyright (C) Tom Horsley, 1997. All rights reserved.
+
+ Permission granted to distribute under the same terms as perl which are
+ (briefly):
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+
+ b) the "Artistic License" which comes with this Kit.
+
+ Details on the perl license can be found in the perl source code which
+ may be located via the www.perl.com web page.
+
+ This is the most wonderfulest possible qsort I can come up with (and
+ still be mostly portable) My (limited) tests indicate it consistently
+ does about 20% fewer calls to compare than does the qsort in the Visual
+ C++ library, other vendors may vary.
+
+ Some of the ideas in here can be found in "Algorithms" by Sedgewick,
+ others I invented myself (or more likely re-invented since they seemed
+ pretty obvious once I watched the algorithm operate for a while).
+
+ Most of this code was written while watching the Marlins sweep the Giants
+ in the 1997 National League Playoffs - no Braves fans allowed to use this
+ code (just kidding :-).
+
+ I realize that if I wanted to be true to the perl tradition, the only
+ comment in this file would be something like:
+
+ ...they shuffled back towards the rear of the line. 'No, not at the
+ rear!' the slave-driver shouted. 'Three files up. And stay there...
+
+ However, I really needed to violate that tradition just so I could keep
+ track of what happens myself, not to mention some poor fool trying to
+ understand this years from now :-).
+*/
+
+/* ********************************************************** Configuration */
+
+#ifndef QSORT_ORDER_GUESS
+#define QSORT_ORDER_GUESS 2 /* Select doubling version of the netBSD trick */
+#endif
+
+/* QSORT_MAX_STACK is the largest number of partitions that can be stacked up for
+ future processing - a good max upper bound is log base 2 of memory size
+ (32 on 32 bit machines, 64 on 64 bit machines, etc). In reality can
+ safely be smaller than that since the program is taking up some space and
+ most operating systems only let you grab some subset of contiguous
+ memory (not to mention that you are normally sorting data larger than
+ 1 byte element size :-).
+*/
+#ifndef QSORT_MAX_STACK
+#define QSORT_MAX_STACK 32
+#endif
+
+/* QSORT_BREAK_EVEN is the size of the largest partition we should insertion sort.
+ Anything bigger and we use qsort. If you make this too small, the qsort
+ will probably break (or become less efficient), because it doesn't expect
+ the middle element of a partition to be the same as the right or left -
+ you have been warned).
+*/
+#ifndef QSORT_BREAK_EVEN
+#define QSORT_BREAK_EVEN 6
+#endif
+
+/* ************************************************************* Data Types */
+
+/* hold left and right index values of a partition waiting to be sorted (the
+ partition includes both left and right - right is NOT one past the end or
+ anything like that).
+*/
+struct partition_stack_entry {
+ int left;
+ int right;
+#ifdef QSORT_ORDER_GUESS
+ int qsort_break_even;
+#endif
+};
+
+/* ******************************************************* Shorthand Macros */
+
+/* Note that these macros will be used from inside the qsort function where
+ we happen to know that the variable 'elt_size' contains the size of an
+ array element and the variable 'temp' points to enough space to hold a
+ temp element and the variable 'array' points to the array being sorted
+ and 'compare' is the pointer to the compare routine.
+
+ Also note that there are very many highly architecture specific ways
+ these might be sped up, but this is simply the most generally portable
+ code I could think of.
+*/
+
+/* Return < 0 == 0 or > 0 as the value of elt1 is < elt2, == elt2, > elt2
+*/
+#ifdef PERL_OBJECT
+#define qsort_cmp(elt1, elt2) \
+ ((this->*compare)(array[elt1], array[elt2]))
+#else
+#define qsort_cmp(elt1, elt2) \
+ ((*compare)(array[elt1], array[elt2]))
+#endif
+
+#ifdef QSORT_ORDER_GUESS
+#define QSORT_NOTICE_SWAP swapped++;
+#else
+#define QSORT_NOTICE_SWAP
+#endif
+
+/* swaps contents of array elements elt1, elt2.
+*/
+#define qsort_swap(elt1, elt2) \
+ STMT_START { \
+ QSORT_NOTICE_SWAP \
+ temp = array[elt1]; \
+ array[elt1] = array[elt2]; \
+ array[elt2] = temp; \
+ } STMT_END
+
+/* rotate contents of elt1, elt2, elt3 such that elt1 gets elt2, elt2 gets
+ elt3 and elt3 gets elt1.
+*/
+#define qsort_rotate(elt1, elt2, elt3) \
+ STMT_START { \
+ QSORT_NOTICE_SWAP \
+ temp = array[elt1]; \
+ array[elt1] = array[elt2]; \
+ array[elt2] = array[elt3]; \
+ array[elt3] = temp; \
+ } STMT_END
+
+/* ************************************************************ Debug stuff */
+
+#ifdef QSORT_DEBUG
+
+static void
+break_here()
+{
+ return; /* good place to set a breakpoint */
+}
+
+#define qsort_assert(t) (void)( (t) || (break_here(), 0) )
+
+static void
+doqsort_all_asserts(
+ void * array,
+ size_t num_elts,
+ size_t elt_size,
+ int (*compare)(const void * elt1, const void * elt2),
+ int pc_left, int pc_right, int u_left, int u_right)
+{
+ int i;
+
+ qsort_assert(pc_left <= pc_right);
+ qsort_assert(u_right < pc_left);
+ qsort_assert(pc_right < u_left);
+ for (i = u_right + 1; i < pc_left; ++i) {
+ qsort_assert(qsort_cmp(i, pc_left) < 0);
+ }
+ for (i = pc_left; i < pc_right; ++i) {
+ qsort_assert(qsort_cmp(i, pc_right) == 0);
+ }
+ for (i = pc_right + 1; i < u_left; ++i) {
+ qsort_assert(qsort_cmp(pc_right, i) < 0);
+ }
+}
+
+#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) \
+ doqsort_all_asserts(array, num_elts, elt_size, compare, \
+ PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT)
+
+#else
+
+#define qsort_assert(t) ((void)0)
+
+#define qsort_all_asserts(PC_LEFT, PC_RIGHT, U_LEFT, U_RIGHT) ((void)0)
+
+#endif
+
+/* ****************************************************************** qsort */
+
+STATIC void
+#ifdef PERL_OBJECT
+qsortsv(SV ** array, size_t num_elts, SVCOMPARE compare)
+#else
+qsortsv(
+ SV ** array,
+ size_t num_elts,
+ I32 (*compare)(SV *a, SV *b))
+#endif
+{
+ register SV * temp;
+
+ struct partition_stack_entry partition_stack[QSORT_MAX_STACK];
+ int next_stack_entry = 0;
+
+ int part_left;
+ int part_right;
+#ifdef QSORT_ORDER_GUESS
+ int qsort_break_even;
+ int swapped;
+#endif
+
+ /* Make sure we actually have work to do.
+ */
+ if (num_elts <= 1) {
+ return;
+ }
+
+ /* Setup the initial partition definition and fall into the sorting loop
+ */
+ part_left = 0;
+ part_right = (int)(num_elts - 1);
+#ifdef QSORT_ORDER_GUESS
+ qsort_break_even = QSORT_BREAK_EVEN;
+#else
+#define qsort_break_even QSORT_BREAK_EVEN
+#endif
+ for ( ; ; ) {
+ if ((part_right - part_left) >= qsort_break_even) {
+ /* OK, this is gonna get hairy, so lets try to document all the
+ concepts and abbreviations and variables and what they keep
+ track of:
+
+ pc: pivot chunk - the set of array elements we accumulate in the
+ middle of the partition, all equal in value to the original
+ pivot element selected. The pc is defined by:
+
+ pc_left - the leftmost array index of the pc
+ pc_right - the rightmost array index of the pc
+
+ we start with pc_left == pc_right and only one element
+ in the pivot chunk (but it can grow during the scan).
+
+ u: uncompared elements - the set of elements in the partition
+ we have not yet compared to the pivot value. There are two
+ uncompared sets during the scan - one to the left of the pc
+ and one to the right.
+
+ u_right - the rightmost index of the left side's uncompared set
+ u_left - the leftmost index of the right side's uncompared set
+
+ The leftmost index of the left sides's uncompared set
+ doesn't need its own variable because it is always defined
+ by the leftmost edge of the whole partition (part_left). The
+ same goes for the rightmost edge of the right partition
+ (part_right).
+
+ We know there are no uncompared elements on the left once we
+ get u_right < part_left and no uncompared elements on the
+ right once u_left > part_right. When both these conditions
+ are met, we have completed the scan of the partition.
+
+ Any elements which are between the pivot chunk and the
+ uncompared elements should be less than the pivot value on
+ the left side and greater than the pivot value on the right
+ side (in fact, the goal of the whole algorithm is to arrange
+ for that to be true and make the groups of less-than and
+ greater-then elements into new partitions to sort again).
+
+ As you marvel at the complexity of the code and wonder why it
+ has to be so confusing. Consider some of the things this level
+ of confusion brings:
+
+ Once I do a compare, I squeeze every ounce of juice out of it. I
+ never do compare calls I don't have to do, and I certainly never
+ do redundant calls.
+
+ I also never swap any elements unless I can prove there is a
+ good reason. Many sort algorithms will swap a known value with
+ an uncompared value just to get things in the right place (or
+ avoid complexity :-), but that uncompared value, once it gets
+ compared, may then have to be swapped again. A lot of the
+ complexity of this code is due to the fact that it never swaps
+ anything except compared values, and it only swaps them when the
+ compare shows they are out of position.
+ */
+ int pc_left, pc_right;
+ int u_right, u_left;
+
+ int s;
+
+ pc_left = ((part_left + part_right) / 2);
+ pc_right = pc_left;
+ u_right = pc_left - 1;
+ u_left = pc_right + 1;
+
+ /* Qsort works best when the pivot value is also the median value
+ in the partition (unfortunately you can't find the median value
+ without first sorting :-), so to give the algorithm a helping
+ hand, we pick 3 elements and sort them and use the median value
+ of that tiny set as the pivot value.
+
+ Some versions of qsort like to use the left middle and right as
+ the 3 elements to sort so they can insure the ends of the
+ partition will contain values which will stop the scan in the
+ compare loop, but when you have to call an arbitrarily complex
+ routine to do a compare, its really better to just keep track of
+ array index values to know when you hit the edge of the
+ partition and avoid the extra compare. An even better reason to
+ avoid using a compare call is the fact that you can drop off the
+ edge of the array if someone foolishly provides you with an
+ unstable compare function that doesn't always provide consistent
+ results.
+
+ So, since it is simpler for us to compare the three adjacent
+ elements in the middle of the partition, those are the ones we
+ pick here (conveniently pointed at by u_right, pc_left, and
+ u_left). The values of the left, center, and right elements
+ are refered to as l c and r in the following comments.
+ */
+
+#ifdef QSORT_ORDER_GUESS
+ swapped = 0;
+#endif
+ s = qsort_cmp(u_right, pc_left);
+ if (s < 0) {
+ /* l < c */
+ s = qsort_cmp(pc_left, u_left);
+ /* if l < c, c < r - already in order - nothing to do */
+ if (s == 0) {
+ /* l < c, c == r - already in order, pc grows */
+ ++pc_right;
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ } else if (s > 0) {
+ /* l < c, c > r - need to know more */
+ s = qsort_cmp(u_right, u_left);
+ if (s < 0) {
+ /* l < c, c > r, l < r - swap c & r to get ordered */
+ qsort_swap(pc_left, u_left);
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ } else if (s == 0) {
+ /* l < c, c > r, l == r - swap c&r, grow pc */
+ qsort_swap(pc_left, u_left);
+ --pc_left;
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ } else {
+ /* l < c, c > r, l > r - make lcr into rlc to get ordered */
+ qsort_rotate(pc_left, u_right, u_left);
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ }
+ }
+ } else if (s == 0) {
+ /* l == c */
+ s = qsort_cmp(pc_left, u_left);
+ if (s < 0) {
+ /* l == c, c < r - already in order, grow pc */
+ --pc_left;
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ } else if (s == 0) {
+ /* l == c, c == r - already in order, grow pc both ways */
+ --pc_left;
+ ++pc_right;
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ } else {
+ /* l == c, c > r - swap l & r, grow pc */
+ qsort_swap(u_right, u_left);
+ ++pc_right;
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ }
+ } else {
+ /* l > c */
+ s = qsort_cmp(pc_left, u_left);
+ if (s < 0) {
+ /* l > c, c < r - need to know more */
+ s = qsort_cmp(u_right, u_left);
+ if (s < 0) {
+ /* l > c, c < r, l < r - swap l & c to get ordered */
+ qsort_swap(u_right, pc_left);
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ } else if (s == 0) {
+ /* l > c, c < r, l == r - swap l & c, grow pc */
+ qsort_swap(u_right, pc_left);
+ ++pc_right;
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ } else {
+ /* l > c, c < r, l > r - rotate lcr into crl to order */
+ qsort_rotate(u_right, pc_left, u_left);
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ }
+ } else if (s == 0) {
+ /* l > c, c == r - swap ends, grow pc */
+ qsort_swap(u_right, u_left);
+ --pc_left;
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ } else {
+ /* l > c, c > r - swap ends to get in order */
+ qsort_swap(u_right, u_left);
+ qsort_all_asserts(pc_left, pc_right, u_left + 1, u_right - 1);
+ }
+ }
+ /* We now know the 3 middle elements have been compared and
+ arranged in the desired order, so we can shrink the uncompared
+ sets on both sides
+ */
+ --u_right;
+ ++u_left;
+ qsort_all_asserts(pc_left, pc_right, u_left, u_right);
+
+ /* The above massive nested if was the simple part :-). We now have
+ the middle 3 elements ordered and we need to scan through the
+ uncompared sets on either side, swapping elements that are on
+ the wrong side or simply shuffling equal elements around to get
+ all equal elements into the pivot chunk.
+ */
+
+ for ( ; ; ) {
+ int still_work_on_left;
+ int still_work_on_right;
+
+ /* Scan the uncompared values on the left. If I find a value
+ equal to the pivot value, move it over so it is adjacent to
+ the pivot chunk and expand the pivot chunk. If I find a value
+ less than the pivot value, then just leave it - its already
+ on the correct side of the partition. If I find a greater
+ value, then stop the scan.
+ */
+ while (still_work_on_left = (u_right >= part_left)) {
+ s = qsort_cmp(u_right, pc_left);
+ if (s < 0) {
+ --u_right;
+ } else if (s == 0) {
+ --pc_left;
+ if (pc_left != u_right) {
+ qsort_swap(u_right, pc_left);
+ }
+ --u_right;
+ } else {
+ break;
+ }
+ qsort_assert(u_right < pc_left);
+ qsort_assert(pc_left <= pc_right);
+ qsort_assert(qsort_cmp(u_right + 1, pc_left) <= 0);
+ qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
+ }
+
+ /* Do a mirror image scan of uncompared values on the right
+ */
+ while (still_work_on_right = (u_left <= part_right)) {
+ s = qsort_cmp(pc_right, u_left);
+ if (s < 0) {
+ ++u_left;
+ } else if (s == 0) {
+ ++pc_right;
+ if (pc_right != u_left) {
+ qsort_swap(pc_right, u_left);
+ }
+ ++u_left;
+ } else {
+ break;
+ }
+ qsort_assert(u_left > pc_right);
+ qsort_assert(pc_left <= pc_right);
+ qsort_assert(qsort_cmp(pc_right, u_left - 1) <= 0);
+ qsort_assert(qsort_cmp(pc_left, pc_right) == 0);
+ }
+
+ if (still_work_on_left) {
+ /* I know I have a value on the left side which needs to be
+ on the right side, but I need to know more to decide
+ exactly the best thing to do with it.
+ */
+ if (still_work_on_right) {
+ /* I know I have values on both side which are out of
+ position. This is a big win because I kill two birds
+ with one swap (so to speak). I can advance the
+ uncompared pointers on both sides after swapping both
+ of them into the right place.
+ */
+ qsort_swap(u_right, u_left);
+ --u_right;
+ ++u_left;
+ qsort_all_asserts(pc_left, pc_right, u_left, u_right);
+ } else {
+ /* I have an out of position value on the left, but the
+ right is fully scanned, so I "slide" the pivot chunk
+ and any less-than values left one to make room for the
+ greater value over on the right. If the out of position
+ value is immediately adjacent to the pivot chunk (there
+ are no less-than values), I can do that with a swap,
+ otherwise, I have to rotate one of the less than values
+ into the former position of the out of position value
+ and the right end of the pivot chunk into the left end
+ (got all that?).
+ */
+ --pc_left;
+ if (pc_left == u_right) {
+ qsort_swap(u_right, pc_right);
+ qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
+ } else {
+ qsort_rotate(u_right, pc_left, pc_right);
+ qsort_all_asserts(pc_left, pc_right-1, u_left, u_right-1);
+ }
+ --pc_right;
+ --u_right;
+ }
+ } else if (still_work_on_right) {
+ /* Mirror image of complex case above: I have an out of
+ position value on the right, but the left is fully
+ scanned, so I need to shuffle things around to make room
+ for the right value on the left.
+ */
+ ++pc_right;
+ if (pc_right == u_left) {
+ qsort_swap(u_left, pc_left);
+ qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
+ } else {
+ qsort_rotate(pc_right, pc_left, u_left);
+ qsort_all_asserts(pc_left+1, pc_right, u_left+1, u_right);
+ }
+ ++pc_left;
+ ++u_left;
+ } else {
+ /* No more scanning required on either side of partition,
+ break out of loop and figure out next set of partitions
+ */
+ break;
+ }
+ }
+
+ /* The elements in the pivot chunk are now in the right place. They
+ will never move or be compared again. All I have to do is decide
+ what to do with the stuff to the left and right of the pivot
+ chunk.
+
+ Notes on the QSORT_ORDER_GUESS ifdef code:
+
+ 1. If I just built these partitions without swapping any (or
+ very many) elements, there is a chance that the elements are
+ already ordered properly (being properly ordered will
+ certainly result in no swapping, but the converse can't be
+ proved :-).
+
+ 2. A (properly written) insertion sort will run faster on
+ already ordered data than qsort will.
+
+ 3. Perhaps there is some way to make a good guess about
+ switching to an insertion sort earlier than partition size 6
+ (for instance - we could save the partition size on the stack
+ and increase the size each time we find we didn't swap, thus
+ switching to insertion sort earlier for partitions with a
+ history of not swapping).
+
+ 4. Naturally, if I just switch right away, it will make
+ artificial benchmarks with pure ascending (or descending)
+ data look really good, but is that a good reason in general?
+ Hard to say...
+ */
+
+#ifdef QSORT_ORDER_GUESS
+ if (swapped < 3) {
+#if QSORT_ORDER_GUESS == 1
+ qsort_break_even = (part_right - part_left) + 1;
+#endif
+#if QSORT_ORDER_GUESS == 2
+ qsort_break_even *= 2;
+#endif
+#if QSORT_ORDER_GUESS == 3
+ int prev_break = qsort_break_even;
+ qsort_break_even *= qsort_break_even;
+ if (qsort_break_even < prev_break) {
+ qsort_break_even = (part_right - part_left) + 1;
+ }
+#endif
+ } else {
+ qsort_break_even = QSORT_BREAK_EVEN;
+ }
+#endif
+
+ if (part_left < pc_left) {
+ /* There are elements on the left which need more processing.
+ Check the right as well before deciding what to do.
+ */
+ if (pc_right < part_right) {
+ /* We have two partitions to be sorted. Stack the biggest one
+ and process the smallest one on the next iteration. This
+ minimizes the stack height by insuring that any additional
+ stack entries must come from the smallest partition which
+ (because it is smallest) will have the fewest
+ opportunities to generate additional stack entries.
+ */
+ if ((part_right - pc_right) > (pc_left - part_left)) {
+ /* stack the right partition, process the left */
+ partition_stack[next_stack_entry].left = pc_right + 1;
+ partition_stack[next_stack_entry].right = part_right;
+#ifdef QSORT_ORDER_GUESS
+ partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
+#endif
+ part_right = pc_left - 1;
+ } else {
+ /* stack the left partition, process the right */
+ partition_stack[next_stack_entry].left = part_left;
+ partition_stack[next_stack_entry].right = pc_left - 1;
+#ifdef QSORT_ORDER_GUESS
+ partition_stack[next_stack_entry].qsort_break_even = qsort_break_even;
+#endif
+ part_left = pc_right + 1;
+ }
+ qsort_assert(next_stack_entry < QSORT_MAX_STACK);
+ ++next_stack_entry;
+ } else {
+ /* The elements on the left are the only remaining elements
+ that need sorting, arrange for them to be processed as the
+ next partition.
+ */
+ part_right = pc_left - 1;
+ }
+ } else if (pc_right < part_right) {
+ /* There is only one chunk on the right to be sorted, make it
+ the new partition and loop back around.
+ */
+ part_left = pc_right + 1;
+ } else {
+ /* This whole partition wound up in the pivot chunk, so
+ we need to get a new partition off the stack.
+ */
+ if (next_stack_entry == 0) {
+ /* the stack is empty - we are done */
+ break;
+ }
+ --next_stack_entry;
+ part_left = partition_stack[next_stack_entry].left;
+ part_right = partition_stack[next_stack_entry].right;
+#ifdef QSORT_ORDER_GUESS
+ qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
+#endif
+ }
+ } else {
+ /* This partition is too small to fool with qsort complexity, just
+ do an ordinary insertion sort to minimize overhead.
+ */
+ int i;
+ /* Assume 1st element is in right place already, and start checking
+ at 2nd element to see where it should be inserted.
+ */
+ for (i = part_left + 1; i <= part_right; ++i) {
+ int j;
+ /* Scan (backwards - just in case 'i' is already in right place)
+ through the elements already sorted to see if the ith element
+ belongs ahead of one of them.
+ */
+ for (j = i - 1; j >= part_left; --j) {
+ if (qsort_cmp(i, j) >= 0) {
+ /* i belongs right after j
+ */
+ break;
+ }
+ }
+ ++j;
+ if (j != i) {
+ /* Looks like we really need to move some things
+ */
+ int k;
+ temp = array[i];
+ for (k = i - 1; k >= j; --k)
+ array[k + 1] = array[k];
+ array[j] = temp;
+ }
+ }
+
+ /* That partition is now sorted, grab the next one, or get out
+ of the loop if there aren't any more.
+ */
+
+ if (next_stack_entry == 0) {
+ /* the stack is empty - we are done */
+ break;
+ }
+ --next_stack_entry;
+ part_left = partition_stack[next_stack_entry].left;
+ part_right = partition_stack[next_stack_entry].right;
+#ifdef QSORT_ORDER_GUESS
+ qsort_break_even = partition_stack[next_stack_entry].qsort_break_even;
+#endif
+ }
+ }
+
+ /* Believe it or not, the array is sorted at this point! */
+}
diff --git a/contrib/perl5/pp_hot.c b/contrib/perl5/pp_hot.c
new file mode 100644
index 000000000000..e82c0957cab0
--- /dev/null
+++ b/contrib/perl5/pp_hot.c
@@ -0,0 +1,2535 @@
+/* pp_hot.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
+ * shaking the air.
+ *
+ * Awake! Awake! Fear, Fire, Foes! Awake!
+ * Fire, Foes! Awake!
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
+/* Hot code. */
+
+#ifdef USE_THREADS
+static void
+unset_cvowner(void *cvarg)
+{
+ register CV* cv = (CV *) cvarg;
+#ifdef DEBUGGING
+ dTHR;
+#endif /* DEBUGGING */
+
+ DEBUG_S((PerlIO_printf(PerlIO_stderr(), "%p unsetting CvOWNER of %p:%s\n",
+ thr, cv, SvPEEK((SV*)cv))));
+ MUTEX_LOCK(CvMUTEXP(cv));
+ DEBUG_S(if (CvDEPTH(cv) != 0)
+ PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
+ CvDEPTH(cv)););
+ assert(thr == CvOWNER(cv));
+ CvOWNER(cv) = 0;
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ SvREFCNT_dec(cv);
+}
+#endif /* USE_THREADS */
+
+PP(pp_const)
+{
+ djSP;
+ XPUSHs(cSVOP->op_sv);
+ RETURN;
+}
+
+PP(pp_nextstate)
+{
+ PL_curcop = (COP*)PL_op;
+ TAINT_NOT; /* Each statement is presumed innocent */
+ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
+ FREETMPS;
+ return NORMAL;
+}
+
+PP(pp_gvsv)
+{
+ djSP;
+ EXTEND(SP,1);
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ PUSHs(save_scalar(cGVOP->op_gv));
+ else
+ PUSHs(GvSV(cGVOP->op_gv));
+ RETURN;
+}
+
+PP(pp_null)
+{
+ return NORMAL;
+}
+
+PP(pp_pushmark)
+{
+ PUSHMARK(PL_stack_sp);
+ return NORMAL;
+}
+
+PP(pp_stringify)
+{
+ djSP; dTARGET;
+ STRLEN len;
+ char *s;
+ s = SvPV(TOPs,len);
+ sv_setpvn(TARG,s,len);
+ SETTARG;
+ RETURN;
+}
+
+PP(pp_gv)
+{
+ djSP;
+ XPUSHs((SV*)cGVOP->op_gv);
+ RETURN;
+}
+
+PP(pp_and)
+{
+ djSP;
+ if (!SvTRUE(TOPs))
+ RETURN;
+ else {
+ --SP;
+ RETURNOP(cLOGOP->op_other);
+ }
+}
+
+PP(pp_sassign)
+{
+ djSP; dPOPTOPssrl;
+ MAGIC *mg;
+
+ if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
+ SV *temp;
+ temp = left; left = right; right = temp;
+ }
+ if (PL_tainting && PL_tainted && !SvTAINTED(left))
+ TAINT_NOT;
+ SvSetMagicSV(right, left);
+ SETs(right);
+ RETURN;
+}
+
+PP(pp_cond_expr)
+{
+ djSP;
+ if (SvTRUEx(POPs))
+ RETURNOP(cCONDOP->op_true);
+ else
+ RETURNOP(cCONDOP->op_false);
+}
+
+PP(pp_unstack)
+{
+ I32 oldsave;
+ TAINT_NOT; /* Each statement is presumed innocent */
+ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
+ FREETMPS;
+ oldsave = PL_scopestack[PL_scopestack_ix - 1];
+ LEAVE_SCOPE(oldsave);
+ return NORMAL;
+}
+
+PP(pp_concat)
+{
+ djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
+ {
+ dPOPTOPssrl;
+ STRLEN len;
+ char *s;
+ if (TARG != left) {
+ s = SvPV(left,len);
+ sv_setpvn(TARG,s,len);
+ }
+ else if (SvGMAGICAL(TARG))
+ mg_get(TARG);
+ else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
+ sv_setpv(TARG, ""); /* Suppress warning. */
+ s = SvPV_force(TARG, len);
+ }
+ s = SvPV(right,len);
+ if (SvOK(TARG))
+ sv_catpvn(TARG,s,len);
+ else
+ sv_setpvn(TARG,s,len); /* suppress warning */
+ SETTARG;
+ RETURN;
+ }
+}
+
+PP(pp_padsv)
+{
+ djSP; dTARGET;
+ XPUSHs(TARG);
+ if (PL_op->op_flags & OPf_MOD) {
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ SAVECLEARSV(PL_curpad[PL_op->op_targ]);
+ else if (PL_op->op_private & OPpDEREF) {
+ PUTBACK;
+ vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
+ SPAGAIN;
+ }
+ }
+ RETURN;
+}
+
+PP(pp_readline)
+{
+ PL_last_in_gv = (GV*)(*PL_stack_sp--);
+ return do_readline();
+}
+
+PP(pp_eq)
+{
+ djSP; tryAMAGICbinSET(eq,0);
+ {
+ dPOPnv;
+ SETs(boolSV(TOPn == value));
+ RETURN;
+ }
+}
+
+PP(pp_preinc)
+{
+ djSP;
+ if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ croak(no_modify);
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ SvIVX(TOPs) != IV_MAX)
+ {
+ ++SvIVX(TOPs);
+ SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
+ }
+ else
+ sv_inc(TOPs);
+ SvSETMAGIC(TOPs);
+ return NORMAL;
+}
+
+PP(pp_or)
+{
+ djSP;
+ if (SvTRUE(TOPs))
+ RETURN;
+ else {
+ --SP;
+ RETURNOP(cLOGOP->op_other);
+ }
+}
+
+PP(pp_add)
+{
+ djSP; dATARGET; tryAMAGICbin(add,opASSIGN);
+ {
+ dPOPTOPnnrl_ul;
+ SETn( left + right );
+ RETURN;
+ }
+}
+
+PP(pp_aelemfast)
+{
+ djSP;
+ AV *av = GvAV((GV*)cSVOP->op_sv);
+ U32 lval = PL_op->op_flags & OPf_MOD;
+ SV** svp = av_fetch(av, PL_op->op_private, lval);
+ SV *sv = (svp ? *svp : &PL_sv_undef);
+ EXTEND(SP, 1);
+ if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
+ sv = sv_mortalcopy(sv);
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_join)
+{
+ djSP; dMARK; dTARGET;
+ MARK++;
+ do_join(TARG, *MARK, MARK, SP);
+ SP = MARK;
+ SETs(TARG);
+ RETURN;
+}
+
+PP(pp_pushre)
+{
+ djSP;
+#ifdef DEBUGGING
+ /*
+ * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
+ * will be enough to hold an OP*.
+ */
+ SV* sv = sv_newmortal();
+ sv_upgrade(sv, SVt_PVLV);
+ LvTYPE(sv) = '/';
+ Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
+ XPUSHs(sv);
+#else
+ XPUSHs((SV*)PL_op);
+#endif
+ RETURN;
+}
+
+/* Oversized hot code. */
+
+PP(pp_print)
+{
+ djSP; dMARK; dORIGMARK;
+ GV *gv;
+ IO *io;
+ register PerlIO *fp;
+ MAGIC *mg;
+
+ if (PL_op->op_flags & OPf_STACKED)
+ gv = (GV*)*++MARK;
+ else
+ gv = PL_defoutgv;
+ if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+ if (MARK == ORIGMARK) {
+ /* If using default handle then we need to make space to
+ * pass object as 1st arg, so move other args up ...
+ */
+ MEXTEND(SP, 1);
+ ++MARK;
+ Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
+ ++SP;
+ }
+ PUSHMARK(MARK - 1);
+ *MARK = mg->mg_obj;
+ PUTBACK;
+ ENTER;
+ perl_call_method("PRINT", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ MARK = ORIGMARK + 1;
+ *MARK = *SP;
+ SP = MARK;
+ RETURN;
+ }
+ if (!(io = GvIO(gv))) {
+ if (PL_dowarn) {
+ SV* sv = sv_newmortal();
+ gv_fullname3(sv, gv, Nullch);
+ warn("Filehandle %s never opened", SvPV(sv,PL_na));
+ }
+
+ SETERRNO(EBADF,RMS$_IFI);
+ goto just_say_no;
+ }
+ else if (!(fp = IoOFP(io))) {
+ if (PL_dowarn) {
+ SV* sv = sv_newmortal();
+ gv_fullname3(sv, gv, Nullch);
+ if (IoIFP(io))
+ warn("Filehandle %s opened only for input", SvPV(sv,PL_na));
+ else
+ warn("print on closed filehandle %s", SvPV(sv,PL_na));
+ }
+ SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
+ goto just_say_no;
+ }
+ else {
+ MARK++;
+ if (PL_ofslen) {
+ while (MARK <= SP) {
+ if (!do_print(*MARK, fp))
+ break;
+ MARK++;
+ if (MARK <= SP) {
+ if (PerlIO_write(fp, PL_ofs, PL_ofslen) == 0 || PerlIO_error(fp)) {
+ MARK--;
+ break;
+ }
+ }
+ }
+ }
+ else {
+ while (MARK <= SP) {
+ if (!do_print(*MARK, fp))
+ break;
+ MARK++;
+ }
+ }
+ if (MARK <= SP)
+ goto just_say_no;
+ else {
+ if (PL_orslen)
+ if (PerlIO_write(fp, PL_ors, PL_orslen) == 0 || PerlIO_error(fp))
+ goto just_say_no;
+
+ if (IoFLAGS(io) & IOf_FLUSH)
+ if (PerlIO_flush(fp) == EOF)
+ goto just_say_no;
+ }
+ }
+ SP = ORIGMARK;
+ PUSHs(&PL_sv_yes);
+ RETURN;
+
+ just_say_no:
+ SP = ORIGMARK;
+ PUSHs(&PL_sv_undef);
+ RETURN;
+}
+
+PP(pp_rv2av)
+{
+ djSP; dPOPss;
+ AV *av;
+
+ if (SvROK(sv)) {
+ wasref:
+ av = (AV*)SvRV(sv);
+ if (SvTYPE(av) != SVt_PVAV)
+ DIE("Not an ARRAY reference");
+ if (PL_op->op_flags & OPf_REF) {
+ PUSHs((SV*)av);
+ RETURN;
+ }
+ }
+ else {
+ if (SvTYPE(sv) == SVt_PVAV) {
+ av = (AV*)sv;
+ if (PL_op->op_flags & OPf_REF) {
+ PUSHs((SV*)av);
+ RETURN;
+ }
+ }
+ else {
+ GV *gv;
+
+ if (SvTYPE(sv) != SVt_PVGV) {
+ char *sym;
+
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvROK(sv))
+ goto wasref;
+ }
+ if (!SvOK(sv)) {
+ if (PL_op->op_flags & OPf_REF ||
+ PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_usym, "an ARRAY");
+ if (PL_dowarn)
+ warn(warn_uninit);
+ if (GIMME == G_ARRAY)
+ RETURN;
+ RETPUSHUNDEF;
+ }
+ sym = SvPV(sv,PL_na);
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_symref, sym, "an ARRAY");
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
+ } else {
+ gv = (GV*)sv;
+ }
+ av = GvAVn(gv);
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ av = save_ary(gv);
+ if (PL_op->op_flags & OPf_REF) {
+ PUSHs((SV*)av);
+ RETURN;
+ }
+ }
+ }
+
+ if (GIMME == G_ARRAY) {
+ I32 maxarg = AvFILL(av) + 1;
+ EXTEND(SP, maxarg);
+ if (SvRMAGICAL(av)) {
+ U32 i;
+ for (i=0; i < maxarg; i++) {
+ SV **svp = av_fetch(av, i, FALSE);
+ SP[i+1] = (svp) ? *svp : &PL_sv_undef;
+ }
+ }
+ else {
+ Copy(AvARRAY(av), SP+1, maxarg, SV*);
+ }
+ SP += maxarg;
+ }
+ else {
+ dTARGET;
+ I32 maxarg = AvFILL(av) + 1;
+ PUSHi(maxarg);
+ }
+ RETURN;
+}
+
+PP(pp_rv2hv)
+{
+ djSP; dTOPss;
+ HV *hv;
+
+ if (SvROK(sv)) {
+ wasref:
+ hv = (HV*)SvRV(sv);
+ if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
+ DIE("Not a HASH reference");
+ if (PL_op->op_flags & OPf_REF) {
+ SETs((SV*)hv);
+ RETURN;
+ }
+ }
+ else {
+ if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
+ hv = (HV*)sv;
+ if (PL_op->op_flags & OPf_REF) {
+ SETs((SV*)hv);
+ RETURN;
+ }
+ }
+ else {
+ GV *gv;
+
+ if (SvTYPE(sv) != SVt_PVGV) {
+ char *sym;
+
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvROK(sv))
+ goto wasref;
+ }
+ if (!SvOK(sv)) {
+ if (PL_op->op_flags & OPf_REF ||
+ PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_usym, "a HASH");
+ if (PL_dowarn)
+ warn(warn_uninit);
+ if (GIMME == G_ARRAY) {
+ SP--;
+ RETURN;
+ }
+ RETSETUNDEF;
+ }
+ sym = SvPV(sv,PL_na);
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_symref, sym, "a HASH");
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
+ } else {
+ gv = (GV*)sv;
+ }
+ hv = GvHVn(gv);
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ hv = save_hash(gv);
+ if (PL_op->op_flags & OPf_REF) {
+ SETs((SV*)hv);
+ RETURN;
+ }
+ }
+ }
+
+ if (GIMME == G_ARRAY) { /* array wanted */
+ *PL_stack_sp = (SV*)hv;
+ return do_kv(ARGS);
+ }
+ else {
+ dTARGET;
+ if (SvTYPE(hv) == SVt_PVAV)
+ hv = avhv_keys((AV*)hv);
+ if (HvFILL(hv))
+ sv_setpvf(TARG, "%ld/%ld",
+ (long)HvFILL(hv), (long)HvMAX(hv) + 1);
+ else
+ sv_setiv(TARG, 0);
+
+ SETTARG;
+ RETURN;
+ }
+}
+
+PP(pp_aassign)
+{
+ djSP;
+ SV **lastlelem = PL_stack_sp;
+ SV **lastrelem = PL_stack_base + POPMARK;
+ SV **firstrelem = PL_stack_base + POPMARK + 1;
+ SV **firstlelem = lastrelem + 1;
+
+ register SV **relem;
+ register SV **lelem;
+
+ register SV *sv;
+ register AV *ary;
+
+ I32 gimme;
+ HV *hash;
+ I32 i;
+ int magic;
+
+ PL_delaymagic = DM_DELAY; /* catch simultaneous items */
+
+ /* If there's a common identifier on both sides we have to take
+ * special care that assigning the identifier on the left doesn't
+ * clobber a value on the right that's used later in the list.
+ */
+ if (PL_op->op_private & OPpASSIGN_COMMON) {
+ for (relem = firstrelem; relem <= lastrelem; relem++) {
+ /*SUPPRESS 560*/
+ if (sv = *relem) {
+ TAINT_NOT; /* Each item is independent */
+ *relem = sv_mortalcopy(sv);
+ }
+ }
+ }
+
+ relem = firstrelem;
+ lelem = firstlelem;
+ ary = Null(AV*);
+ hash = Null(HV*);
+ while (lelem <= lastlelem) {
+ TAINT_NOT; /* Each item stands on its own, taintwise. */
+ sv = *lelem++;
+ switch (SvTYPE(sv)) {
+ case SVt_PVAV:
+ ary = (AV*)sv;
+ magic = SvMAGICAL(ary) != 0;
+
+ av_clear(ary);
+ av_extend(ary, lastrelem - relem);
+ i = 0;
+ while (relem <= lastrelem) { /* gobble up all the rest */
+ SV **didstore;
+ sv = NEWSV(28,0);
+ assert(*relem);
+ sv_setsv(sv,*relem);
+ *(relem++) = sv;
+ didstore = av_store(ary,i++,sv);
+ if (magic) {
+ if (SvSMAGICAL(sv))
+ mg_set(sv);
+ if (!didstore)
+ SvREFCNT_dec(sv);
+ }
+ TAINT_NOT;
+ }
+ break;
+ case SVt_PVHV: {
+ SV *tmpstr;
+
+ hash = (HV*)sv;
+ magic = SvMAGICAL(hash) != 0;
+ hv_clear(hash);
+
+ while (relem < lastrelem) { /* gobble up all the rest */
+ HE *didstore;
+ if (*relem)
+ sv = *(relem++);
+ else
+ sv = &PL_sv_no, relem++;
+ tmpstr = NEWSV(29,0);
+ if (*relem)
+ sv_setsv(tmpstr,*relem); /* value */
+ *(relem++) = tmpstr;
+ didstore = hv_store_ent(hash,sv,tmpstr,0);
+ if (magic) {
+ if (SvSMAGICAL(tmpstr))
+ mg_set(tmpstr);
+ if (!didstore)
+ SvREFCNT_dec(tmpstr);
+ }
+ TAINT_NOT;
+ }
+ if (relem == lastrelem) {
+ if (*relem) {
+ HE *didstore;
+ if (PL_dowarn) {
+ if (relem == firstrelem &&
+ SvROK(*relem) &&
+ ( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
+ SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
+ warn("Reference found where even-sized list expected");
+ else
+ warn("Odd number of elements in hash assignment");
+ }
+ tmpstr = NEWSV(29,0);
+ didstore = hv_store_ent(hash,*relem,tmpstr,0);
+ if (magic) {
+ if (SvSMAGICAL(tmpstr))
+ mg_set(tmpstr);
+ if (!didstore)
+ SvREFCNT_dec(tmpstr);
+ }
+ TAINT_NOT;
+ }
+ relem++;
+ }
+ }
+ break;
+ default:
+ if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv) && PL_curcop != &PL_compiling) {
+ if (!SvIMMORTAL(sv))
+ DIE(no_modify);
+ if (relem <= lastrelem)
+ relem++;
+ break;
+ }
+ if (SvROK(sv))
+ sv_unref(sv);
+ }
+ if (relem <= lastrelem) {
+ sv_setsv(sv, *relem);
+ *(relem++) = sv;
+ }
+ else
+ sv_setsv(sv, &PL_sv_undef);
+ SvSETMAGIC(sv);
+ break;
+ }
+ }
+ if (PL_delaymagic & ~DM_DELAY) {
+ if (PL_delaymagic & DM_UID) {
+#ifdef HAS_SETRESUID
+ (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
+#else
+# ifdef HAS_SETREUID
+ (void)setreuid(PL_uid,PL_euid);
+# else
+# ifdef HAS_SETRUID
+ if ((PL_delaymagic & DM_UID) == DM_RUID) {
+ (void)setruid(PL_uid);
+ PL_delaymagic &= ~DM_RUID;
+ }
+# endif /* HAS_SETRUID */
+# ifdef HAS_SETEUID
+ if ((PL_delaymagic & DM_UID) == DM_EUID) {
+ (void)seteuid(PL_uid);
+ PL_delaymagic &= ~DM_EUID;
+ }
+# endif /* HAS_SETEUID */
+ if (PL_delaymagic & DM_UID) {
+ if (PL_uid != PL_euid)
+ DIE("No setreuid available");
+ (void)PerlProc_setuid(PL_uid);
+ }
+# endif /* HAS_SETREUID */
+#endif /* HAS_SETRESUID */
+ PL_uid = (int)PerlProc_getuid();
+ PL_euid = (int)PerlProc_geteuid();
+ }
+ if (PL_delaymagic & DM_GID) {
+#ifdef HAS_SETRESGID
+ (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
+#else
+# ifdef HAS_SETREGID
+ (void)setregid(PL_gid,PL_egid);
+# else
+# ifdef HAS_SETRGID
+ if ((PL_delaymagic & DM_GID) == DM_RGID) {
+ (void)setrgid(PL_gid);
+ PL_delaymagic &= ~DM_RGID;
+ }
+# endif /* HAS_SETRGID */
+# ifdef HAS_SETEGID
+ if ((PL_delaymagic & DM_GID) == DM_EGID) {
+ (void)setegid(PL_gid);
+ PL_delaymagic &= ~DM_EGID;
+ }
+# endif /* HAS_SETEGID */
+ if (PL_delaymagic & DM_GID) {
+ if (PL_gid != PL_egid)
+ DIE("No setregid available");
+ (void)PerlProc_setgid(PL_gid);
+ }
+# endif /* HAS_SETREGID */
+#endif /* HAS_SETRESGID */
+ PL_gid = (int)PerlProc_getgid();
+ PL_egid = (int)PerlProc_getegid();
+ }
+ PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
+ }
+ PL_delaymagic = 0;
+
+ gimme = GIMME_V;
+ if (gimme == G_VOID)
+ SP = firstrelem - 1;
+ else if (gimme == G_SCALAR) {
+ dTARGET;
+ SP = firstrelem;
+ SETi(lastrelem - firstrelem + 1);
+ }
+ else {
+ if (ary || hash)
+ SP = lastrelem;
+ else
+ SP = firstrelem + (lastlelem - firstlelem);
+ lelem = firstlelem + (relem - firstrelem);
+ while (relem <= SP)
+ *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
+ }
+ RETURN;
+}
+
+PP(pp_qr)
+{
+ djSP;
+ register PMOP *pm = cPMOP;
+ SV *rv = sv_newmortal();
+ SV *sv = newSVrv(rv, "Regexp");
+ sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
+ RETURNX(PUSHs(rv));
+}
+
+PP(pp_match)
+{
+ djSP; dTARG;
+ register PMOP *pm = cPMOP;
+ register char *t;
+ register char *s;
+ char *strend;
+ I32 global;
+ I32 safebase;
+ char *truebase;
+ register REGEXP *rx = pm->op_pmregexp;
+ bool rxtainted;
+ I32 gimme = GIMME;
+ STRLEN len;
+ I32 minmatch = 0;
+ I32 oldsave = PL_savestack_ix;
+ I32 update_minmatch = 1;
+ SV *screamer;
+
+ if (PL_op->op_flags & OPf_STACKED)
+ TARG = POPs;
+ else {
+ TARG = DEFSV;
+ EXTEND(SP,1);
+ }
+ PUTBACK; /* EVAL blocks need stack_sp. */
+ s = SvPV(TARG, len);
+ strend = s + len;
+ if (!s)
+ DIE("panic: do_match");
+ rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
+ (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
+ TAINT_NOT;
+
+ if (pm->op_pmdynflags & PMdf_USED) {
+ failure:
+ if (gimme == G_ARRAY)
+ RETURN;
+ RETPUSHNO;
+ }
+
+ if (!rx->prelen && PL_curpm) {
+ pm = PL_curpm;
+ rx = pm->op_pmregexp;
+ }
+ if (rx->minlen > len) goto failure;
+
+ screamer = ( (SvSCREAM(TARG) && rx->check_substr
+ && SvTYPE(rx->check_substr) == SVt_PVBM
+ && SvVALID(rx->check_substr))
+ ? TARG : Nullsv);
+ truebase = t = s;
+ if (global = pm->op_pmflags & PMf_GLOBAL) {
+ rx->startp[0] = 0;
+ if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
+ MAGIC* mg = mg_find(TARG, 'g');
+ if (mg && mg->mg_len >= 0) {
+ rx->endp[0] = rx->startp[0] = s + mg->mg_len;
+ minmatch = (mg->mg_flags & MGf_MINMATCH);
+ update_minmatch = 0;
+ }
+ }
+ }
+ safebase = (((gimme == G_ARRAY) || global || !rx->nparens)
+ && !PL_sawampersand);
+ safebase = safebase ? 0 : REXEC_COPY_STR ;
+ if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+ SAVEINT(PL_multiline);
+ PL_multiline = pm->op_pmflags & PMf_MULTILINE;
+ }
+
+play_it_again:
+ if (global && rx->startp[0]) {
+ t = s = rx->endp[0];
+ if ((s + rx->minlen) > strend)
+ goto nope;
+ if (update_minmatch++)
+ minmatch = (s == rx->startp[0]);
+ }
+ if (rx->check_substr) {
+ if (!(rx->reganch & ROPT_NOSCAN)) { /* Floating checkstring. */
+ if ( screamer ) {
+ I32 p = -1;
+
+ if (PL_screamfirst[BmRARE(rx->check_substr)] < 0)
+ goto nope;
+ else if (!(s = screaminstr(TARG, rx->check_substr,
+ rx->check_offset_min, 0, &p, 0)))
+ goto nope;
+ else if ((rx->reganch & ROPT_CHECK_ALL)
+ && !PL_sawampersand && !SvTAIL(rx->check_substr))
+ goto yup;
+ }
+ else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min,
+ (unsigned char*)strend,
+ rx->check_substr, 0)))
+ goto nope;
+ else if ((rx->reganch & ROPT_CHECK_ALL) && !PL_sawampersand)
+ goto yup;
+ if (s && rx->check_offset_max < s - t) {
+ ++BmUSEFUL(rx->check_substr);
+ s -= rx->check_offset_max;
+ }
+ else
+ s = t;
+ }
+ /* Now checkstring is fixed, i.e. at fixed offset from the
+ beginning of match, and the match is anchored at s. */
+ else if (!PL_multiline) { /* Anchored near beginning of string. */
+ I32 slen;
+ if (*SvPVX(rx->check_substr) != s[rx->check_offset_min]
+ || ((slen = SvCUR(rx->check_substr)) > 1
+ && memNE(SvPVX(rx->check_substr),
+ s + rx->check_offset_min, slen)))
+ goto nope;
+ }
+ if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0
+ && rx->check_substr == rx->float_substr) {
+ SvREFCNT_dec(rx->check_substr);
+ rx->check_substr = Nullsv; /* opt is being useless */
+ rx->float_substr = Nullsv;
+ }
+ }
+ if (CALLREGEXEC(rx, s, strend, truebase, minmatch,
+ screamer, NULL, safebase))
+ {
+ PL_curpm = pm;
+ if (pm->op_pmflags & PMf_ONCE)
+ pm->op_pmdynflags |= PMdf_USED;
+ goto gotcha;
+ }
+ else
+ goto ret_no;
+ /*NOTREACHED*/
+
+ gotcha:
+ if (rxtainted)
+ RX_MATCH_TAINTED_on(rx);
+ TAINT_IF(RX_MATCH_TAINTED(rx));
+ if (gimme == G_ARRAY) {
+ I32 iters, i, len;
+
+ iters = rx->nparens;
+ if (global && !iters)
+ i = 1;
+ else
+ i = 0;
+ SPAGAIN; /* EVAL blocks could move the stack. */
+ EXTEND(SP, iters + i);
+ EXTEND_MORTAL(iters + i);
+ for (i = !i; i <= iters; i++) {
+ PUSHs(sv_newmortal());
+ /*SUPPRESS 560*/
+ if ((s = rx->startp[i]) && rx->endp[i] ) {
+ len = rx->endp[i] - s;
+ sv_setpvn(*SP, s, len);
+ }
+ }
+ if (global) {
+ truebase = rx->subbeg;
+ strend = rx->subend;
+ if (rx->startp[0] && rx->startp[0] == rx->endp[0])
+ ++rx->endp[0];
+ PUTBACK; /* EVAL blocks may use stack */
+ goto play_it_again;
+ }
+ else if (!iters)
+ XPUSHs(&PL_sv_yes);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
+ }
+ else {
+ if (global) {
+ MAGIC* mg = 0;
+ if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
+ mg = mg_find(TARG, 'g');
+ if (!mg) {
+ sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
+ mg = mg_find(TARG, 'g');
+ }
+ if (rx->startp[0]) {
+ mg->mg_len = rx->endp[0] - rx->subbeg;
+ if (rx->startp[0] == rx->endp[0])
+ mg->mg_flags |= MGf_MINMATCH;
+ else
+ mg->mg_flags &= ~MGf_MINMATCH;
+ }
+ }
+ LEAVE_SCOPE(oldsave);
+ RETPUSHYES;
+ }
+
+yup: /* Confirmed by check_substr */
+ if (rxtainted)
+ RX_MATCH_TAINTED_on(rx);
+ TAINT_IF(RX_MATCH_TAINTED(rx));
+ ++BmUSEFUL(rx->check_substr);
+ PL_curpm = pm;
+ if (pm->op_pmflags & PMf_ONCE)
+ pm->op_pmdynflags |= PMdf_USED;
+ Safefree(rx->subbase);
+ rx->subbase = Nullch;
+ if (global) {
+ rx->subbeg = truebase;
+ rx->subend = strend;
+ rx->startp[0] = s;
+ rx->endp[0] = s + SvCUR(rx->check_substr);
+ goto gotcha;
+ }
+ if (PL_sawampersand) {
+ char *tmps;
+
+ tmps = rx->subbase = savepvn(t, strend-t);
+ rx->subbeg = tmps;
+ rx->subend = tmps + (strend-t);
+ tmps = rx->startp[0] = tmps + (s - t);
+ rx->endp[0] = tmps + SvCUR(rx->check_substr);
+ }
+ LEAVE_SCOPE(oldsave);
+ RETPUSHYES;
+
+nope:
+ if (rx->check_substr)
+ ++BmUSEFUL(rx->check_substr);
+
+ret_no:
+ if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
+ if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
+ MAGIC* mg = mg_find(TARG, 'g');
+ if (mg)
+ mg->mg_len = -1;
+ }
+ }
+ LEAVE_SCOPE(oldsave);
+ if (gimme == G_ARRAY)
+ RETURN;
+ RETPUSHNO;
+}
+
+OP *
+do_readline(void)
+{
+ dSP; dTARGETSTACKED;
+ register SV *sv;
+ STRLEN tmplen = 0;
+ STRLEN offset;
+ PerlIO *fp;
+ register IO *io = GvIO(PL_last_in_gv);
+ register I32 type = PL_op->op_type;
+ I32 gimme = GIMME_V;
+ MAGIC *mg;
+
+ if (SvRMAGICAL(PL_last_in_gv) && (mg = mg_find((SV*)PL_last_in_gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(mg->mg_obj);
+ PUTBACK;
+ ENTER;
+ perl_call_method("READLINE", gimme);
+ LEAVE;
+ SPAGAIN;
+ if (gimme == G_SCALAR)
+ SvSetMagicSV_nosteal(TARG, TOPs);
+ RETURN;
+ }
+ fp = Nullfp;
+ if (io) {
+ fp = IoIFP(io);
+ if (!fp) {
+ if (IoFLAGS(io) & IOf_ARGV) {
+ if (IoFLAGS(io) & IOf_START) {
+ IoFLAGS(io) &= ~IOf_START;
+ IoLINES(io) = 0;
+ if (av_len(GvAVn(PL_last_in_gv)) < 0) {
+ do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
+ sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
+ SvSETMAGIC(GvSV(PL_last_in_gv));
+ fp = IoIFP(io);
+ goto have_fp;
+ }
+ }
+ fp = nextargv(PL_last_in_gv);
+ if (!fp) { /* Note: fp != IoIFP(io) */
+ (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
+ IoFLAGS(io) |= IOf_START;
+ }
+ }
+ else if (type == OP_GLOB) {
+ SV *tmpcmd = NEWSV(55, 0);
+ SV *tmpglob = POPs;
+ ENTER;
+ SAVEFREESV(tmpcmd);
+#ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
+ /* since spawning off a process is a real performance hit */
+ {
+#include <descrip.h>
+#include <lib$routines.h>
+#include <nam.h>
+#include <rmsdef.h>
+ char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
+ char vmsspec[NAM$C_MAXRSS+1];
+ char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
+ char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
+ $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
+ PerlIO *tmpfp;
+ STRLEN i;
+ struct dsc$descriptor_s wilddsc
+ = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+ struct dsc$descriptor_vs rsdsc
+ = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
+ unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
+
+ /* We could find out if there's an explicit dev/dir or version
+ by peeking into lib$find_file's internal context at
+ ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
+ but that's unsupported, so I don't want to do it now and
+ have it bite someone in the future. */
+ strcat(tmpfnam,PerlLIO_tmpnam(NULL));
+ cp = SvPV(tmpglob,i);
+ for (; i; i--) {
+ if (cp[i] == ';') hasver = 1;
+ if (cp[i] == '.') {
+ if (sts) hasver = 1;
+ else sts = 1;
+ }
+ if (cp[i] == '/') {
+ hasdir = isunix = 1;
+ break;
+ }
+ if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
+ hasdir = 1;
+ break;
+ }
+ }
+ if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
+ Stat_t st;
+ if (!PerlLIO_stat(SvPVX(tmpglob),&st) && S_ISDIR(st.st_mode))
+ ok = ((wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec)) != NULL);
+ else ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
+ if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
+ while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
+ &dfltdsc,NULL,NULL,NULL))&1)) {
+ end = rstr + (unsigned long int) *rslt;
+ if (!hasver) while (*end != ';') end--;
+ *(end++) = '\n'; *end = '\0';
+ for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
+ if (hasdir) {
+ if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
+ begin = rstr;
+ }
+ else {
+ begin = end;
+ while (*(--begin) != ']' && *begin != '>') ;
+ ++begin;
+ }
+ ok = (PerlIO_puts(tmpfp,begin) != EOF);
+ }
+ if (cxt) (void)lib$find_file_end(&cxt);
+ if (ok && sts != RMS$_NMF &&
+ sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
+ if (!ok) {
+ if (!(sts & 1)) {
+ SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
+ }
+ PerlIO_close(tmpfp);
+ fp = NULL;
+ }
+ else {
+ PerlIO_rewind(tmpfp);
+ IoTYPE(io) = '<';
+ IoIFP(io) = fp = tmpfp;
+ IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
+ }
+ }
+ }
+#else /* !VMS */
+#ifdef DOSISH
+#ifdef OS2
+ sv_setpv(tmpcmd, "for a in ");
+ sv_catsv(tmpcmd, tmpglob);
+ sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
+#else
+#ifdef DJGPP
+ sv_setpv(tmpcmd, "/dev/dosglob/"); /* File System Extension */
+ sv_catsv(tmpcmd, tmpglob);
+#else
+ sv_setpv(tmpcmd, "perlglob ");
+ sv_catsv(tmpcmd, tmpglob);
+ sv_catpv(tmpcmd, " |");
+#endif /* !DJGPP */
+#endif /* !OS2 */
+#else /* !DOSISH */
+#if defined(CSH)
+ sv_setpvn(tmpcmd, PL_cshname, PL_cshlen);
+ sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
+ sv_catsv(tmpcmd, tmpglob);
+ sv_catpv(tmpcmd, "' 2>/dev/null |");
+#else
+ sv_setpv(tmpcmd, "echo ");
+ sv_catsv(tmpcmd, tmpglob);
+#if 'z' - 'a' == 25
+ sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
+#else
+ sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
+#endif
+#endif /* !CSH */
+#endif /* !DOSISH */
+ (void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
+ FALSE, O_RDONLY, 0, Nullfp);
+ fp = IoIFP(io);
+#endif /* !VMS */
+ LEAVE;
+ }
+ }
+ else if (type == OP_GLOB)
+ SP--;
+ }
+ if (!fp) {
+ if (PL_dowarn && io && !(IoFLAGS(io) & IOf_START))
+ warn("Read on closed filehandle <%s>", GvENAME(PL_last_in_gv));
+ if (gimme == G_SCALAR) {
+ (void)SvOK_off(TARG);
+ PUSHTARG;
+ }
+ RETURN;
+ }
+ have_fp:
+ if (gimme == G_SCALAR) {
+ sv = TARG;
+ if (SvROK(sv))
+ sv_unref(sv);
+ (void)SvUPGRADE(sv, SVt_PV);
+ tmplen = SvLEN(sv); /* remember if already alloced */
+ if (!tmplen)
+ Sv_Grow(sv, 80); /* try short-buffering it */
+ if (type == OP_RCATLINE)
+ offset = SvCUR(sv);
+ else
+ offset = 0;
+ }
+ else {
+ sv = sv_2mortal(NEWSV(57, 80));
+ offset = 0;
+ }
+ for (;;) {
+ if (!sv_gets(sv, fp, offset)) {
+ PerlIO_clearerr(fp);
+ if (IoFLAGS(io) & IOf_ARGV) {
+ fp = nextargv(PL_last_in_gv);
+ if (fp)
+ continue;
+ (void)do_close(PL_last_in_gv, FALSE);
+ IoFLAGS(io) |= IOf_START;
+ }
+ else if (type == OP_GLOB) {
+ if (!do_close(PL_last_in_gv, FALSE))
+ warn("internal error: glob failed");
+ }
+ if (gimme == G_SCALAR) {
+ (void)SvOK_off(TARG);
+ PUSHTARG;
+ }
+ RETURN;
+ }
+ /* This should not be marked tainted if the fp is marked clean */
+ if (!(IoFLAGS(io) & IOf_UNTAINT)) {
+ TAINT;
+ SvTAINTED_on(sv);
+ }
+ IoLINES(io)++;
+ SvSETMAGIC(sv);
+ XPUSHs(sv);
+ if (type == OP_GLOB) {
+ char *tmps;
+
+ if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
+ tmps = SvEND(sv) - 1;
+ if (*tmps == *SvPVX(PL_rs)) {
+ *tmps = '\0';
+ SvCUR(sv)--;
+ }
+ }
+ for (tmps = SvPVX(sv); *tmps; tmps++)
+ if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
+ strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
+ break;
+ if (*tmps && PerlLIO_stat(SvPVX(sv), &PL_statbuf) < 0) {
+ (void)POPs; /* Unmatched wildcard? Chuck it... */
+ continue;
+ }
+ }
+ if (gimme == G_ARRAY) {
+ if (SvLEN(sv) - SvCUR(sv) > 20) {
+ SvLEN_set(sv, SvCUR(sv)+1);
+ Renew(SvPVX(sv), SvLEN(sv), char);
+ }
+ sv = sv_2mortal(NEWSV(58, 80));
+ continue;
+ }
+ else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
+ /* try to reclaim a bit of scalar space (only on 1st alloc) */
+ if (SvCUR(sv) < 60)
+ SvLEN_set(sv, 80);
+ else
+ SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
+ Renew(SvPVX(sv), SvLEN(sv), char);
+ }
+ RETURN;
+ }
+}
+
+PP(pp_enter)
+{
+ djSP;
+ register PERL_CONTEXT *cx;
+ I32 gimme = OP_GIMME(PL_op, -1);
+
+ if (gimme == -1) {
+ if (cxstack_ix >= 0)
+ gimme = cxstack[cxstack_ix].blk_gimme;
+ else
+ gimme = G_SCALAR;
+ }
+
+ ENTER;
+
+ SAVETMPS;
+ PUSHBLOCK(cx, CXt_BLOCK, SP);
+
+ RETURN;
+}
+
+PP(pp_helem)
+{
+ djSP;
+ HE* he;
+ SV **svp;
+ SV *keysv = POPs;
+ HV *hv = (HV*)POPs;
+ U32 lval = PL_op->op_flags & OPf_MOD;
+ U32 defer = PL_op->op_private & OPpLVAL_DEFER;
+ SV *sv;
+
+ if (SvTYPE(hv) == SVt_PVHV) {
+ he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
+ svp = he ? &HeVAL(he) : 0;
+ }
+ else if (SvTYPE(hv) == SVt_PVAV) {
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ DIE("Can't localize pseudo-hash element");
+ svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
+ }
+ else {
+ RETPUSHUNDEF;
+ }
+ if (lval) {
+ if (!svp || *svp == &PL_sv_undef) {
+ SV* lv;
+ SV* key2;
+ if (!defer)
+ DIE(no_helem, SvPV(keysv, PL_na));
+ lv = sv_newmortal();
+ sv_upgrade(lv, SVt_PVLV);
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
+ SvREFCNT_dec(key2); /* sv_magic() increments refcount */
+ LvTARG(lv) = SvREFCNT_inc(hv);
+ LvTARGLEN(lv) = 1;
+ PUSHs(lv);
+ RETURN;
+ }
+ if (PL_op->op_private & OPpLVAL_INTRO) {
+ if (HvNAME(hv) && isGV(*svp))
+ save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
+ else
+ save_helem(hv, keysv, svp);
+ }
+ else if (PL_op->op_private & OPpDEREF)
+ vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+ }
+ sv = (svp ? *svp : &PL_sv_undef);
+ /* This makes C<local $tied{foo} = $tied{foo}> possible.
+ * Pushing the magical RHS on to the stack is useless, since
+ * that magic is soon destined to be misled by the local(),
+ * and thus the later pp_sassign() will fail to mg_get() the
+ * old value. This should also cure problems with delayed
+ * mg_get()s. GSAR 98-07-03 */
+ if (!lval && SvGMAGICAL(sv))
+ sv = sv_mortalcopy(sv);
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_leave)
+{
+ djSP;
+ register PERL_CONTEXT *cx;
+ register SV **mark;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
+
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ cx = &cxstack[cxstack_ix];
+ cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
+ }
+
+ POPBLOCK(cx,newpm);
+
+ gimme = OP_GIMME(PL_op, -1);
+ if (gimme == -1) {
+ if (cxstack_ix >= 0)
+ gimme = cxstack[cxstack_ix].blk_gimme;
+ else
+ gimme = G_SCALAR;
+ }
+
+ TAINT_NOT;
+ if (gimme == G_VOID)
+ SP = newsp;
+ else if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP)
+ if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
+ *MARK = TOPs;
+ else
+ *MARK = sv_mortalcopy(TOPs);
+ else {
+ MEXTEND(mark,0);
+ *MARK = &PL_sv_undef;
+ }
+ SP = MARK;
+ }
+ else if (gimme == G_ARRAY) {
+ /* in case LEAVE wipes old return values */
+ for (mark = newsp + 1; mark <= SP; mark++) {
+ if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
+ *mark = sv_mortalcopy(*mark);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ }
+ PL_curpm = newpm; /* Don't pop $1 et al till now */
+
+ LEAVE;
+
+ RETURN;
+}
+
+PP(pp_iter)
+{
+ djSP;
+ register PERL_CONTEXT *cx;
+ SV* sv;
+ AV* av;
+
+ EXTEND(SP, 1);
+ cx = &cxstack[cxstack_ix];
+ if (cx->cx_type != CXt_LOOP)
+ DIE("panic: pp_iter");
+
+ av = cx->blk_loop.iterary;
+ if (SvTYPE(av) != SVt_PVAV) {
+ /* iterate ($min .. $max) */
+ if (cx->blk_loop.iterlval) {
+ /* string increment */
+ register SV* cur = cx->blk_loop.iterlval;
+ STRLEN maxlen;
+ char *max = SvPV((SV*)av, maxlen);
+ if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
+#ifndef USE_THREADS /* don't risk potential race */
+ if (SvREFCNT(*cx->blk_loop.itervar) == 1
+ && !SvMAGICAL(*cx->blk_loop.itervar))
+ {
+ /* safe to reuse old SV */
+ sv_setsv(*cx->blk_loop.itervar, cur);
+ }
+ else
+#endif
+ {
+ /* we need a fresh SV every time so that loop body sees a
+ * completely new SV for closures/references to work as
+ * they used to */
+ SvREFCNT_dec(*cx->blk_loop.itervar);
+ *cx->blk_loop.itervar = newSVsv(cur);
+ }
+ if (strEQ(SvPVX(cur), max))
+ sv_setiv(cur, 0); /* terminate next time */
+ else
+ sv_inc(cur);
+ RETPUSHYES;
+ }
+ RETPUSHNO;
+ }
+ /* integer increment */
+ if (cx->blk_loop.iterix > cx->blk_loop.itermax)
+ RETPUSHNO;
+
+#ifndef USE_THREADS /* don't risk potential race */
+ if (SvREFCNT(*cx->blk_loop.itervar) == 1
+ && !SvMAGICAL(*cx->blk_loop.itervar))
+ {
+ /* safe to reuse old SV */
+ sv_setiv(*cx->blk_loop.itervar, cx->blk_loop.iterix++);
+ }
+ else
+#endif
+ {
+ /* we need a fresh SV every time so that loop body sees a
+ * completely new SV for closures/references to work as they
+ * used to */
+ SvREFCNT_dec(*cx->blk_loop.itervar);
+ *cx->blk_loop.itervar = newSViv(cx->blk_loop.iterix++);
+ }
+ RETPUSHYES;
+ }
+
+ /* iterate array */
+ if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
+ RETPUSHNO;
+
+ SvREFCNT_dec(*cx->blk_loop.itervar);
+
+ if (sv = (SvMAGICAL(av))
+ ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
+ : AvARRAY(av)[++cx->blk_loop.iterix])
+ SvTEMP_off(sv);
+ else
+ sv = &PL_sv_undef;
+ if (av != PL_curstack && SvIMMORTAL(sv)) {
+ SV *lv = cx->blk_loop.iterlval;
+ if (lv && SvREFCNT(lv) > 1) {
+ SvREFCNT_dec(lv);
+ lv = Nullsv;
+ }
+ if (lv)
+ SvREFCNT_dec(LvTARG(lv));
+ else {
+ lv = cx->blk_loop.iterlval = NEWSV(26, 0);
+ sv_upgrade(lv, SVt_PVLV);
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, Nullsv, 'y', Nullch, 0);
+ }
+ LvTARG(lv) = SvREFCNT_inc(av);
+ LvTARGOFF(lv) = cx->blk_loop.iterix;
+ LvTARGLEN(lv) = (UV) -1;
+ sv = (SV*)lv;
+ }
+
+ *cx->blk_loop.itervar = SvREFCNT_inc(sv);
+ RETPUSHYES;
+}
+
+PP(pp_subst)
+{
+ djSP; dTARG;
+ register PMOP *pm = cPMOP;
+ PMOP *rpm = pm;
+ register SV *dstr;
+ register char *s;
+ char *strend;
+ register char *m;
+ char *c;
+ register char *d;
+ STRLEN clen;
+ I32 iters = 0;
+ I32 maxiters;
+ register I32 i;
+ bool once;
+ bool rxtainted;
+ char *orig;
+ I32 safebase;
+ register REGEXP *rx = pm->op_pmregexp;
+ STRLEN len;
+ int force_on_match = 0;
+ I32 oldsave = PL_savestack_ix;
+ I32 update_minmatch = 1;
+ SV *screamer;
+
+ /* known replacement string? */
+ dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
+ if (PL_op->op_flags & OPf_STACKED)
+ TARG = POPs;
+ else {
+ TARG = DEFSV;
+ EXTEND(SP,1);
+ }
+ if (SvREADONLY(TARG)
+ || (SvTYPE(TARG) > SVt_PVLV
+ && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
+ croak(no_modify);
+ PUTBACK;
+
+ s = SvPV(TARG, len);
+ if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
+ force_on_match = 1;
+ rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
+ (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
+ if (PL_tainted)
+ rxtainted |= 2;
+ TAINT_NOT;
+
+ force_it:
+ if (!pm || !s)
+ DIE("panic: do_subst");
+
+ strend = s + len;
+ maxiters = 2*(strend - s) + 10; /* We can match twice at each
+ position, once with zero-length,
+ second time with non-zero. */
+
+ if (!rx->prelen && PL_curpm) {
+ pm = PL_curpm;
+ rx = pm->op_pmregexp;
+ }
+ screamer = ( (SvSCREAM(TARG) && rx->check_substr
+ && SvTYPE(rx->check_substr) == SVt_PVBM
+ && SvVALID(rx->check_substr))
+ ? TARG : Nullsv);
+ safebase = (!rx->nparens && !PL_sawampersand) ? 0 : REXEC_COPY_STR;
+ if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
+ SAVEINT(PL_multiline);
+ PL_multiline = pm->op_pmflags & PMf_MULTILINE;
+ }
+ orig = m = s;
+ if (rx->check_substr) {
+ if (!(rx->reganch & ROPT_NOSCAN)) { /* It floats. */
+ if (screamer) {
+ I32 p = -1;
+
+ if (PL_screamfirst[BmRARE(rx->check_substr)] < 0)
+ goto nope;
+ else if (!(s = screaminstr(TARG, rx->check_substr, rx->check_offset_min, 0, &p, 0)))
+ goto nope;
+ }
+ else if (!(s = fbm_instr((unsigned char*)s + rx->check_offset_min,
+ (unsigned char*)strend,
+ rx->check_substr, 0)))
+ goto nope;
+ if (s && rx->check_offset_max < s - m) {
+ ++BmUSEFUL(rx->check_substr);
+ s -= rx->check_offset_max;
+ }
+ else
+ s = m;
+ }
+ /* Now checkstring is fixed, i.e. at fixed offset from the
+ beginning of match, and the match is anchored at s. */
+ else if (!PL_multiline) { /* Anchored at beginning of string. */
+ I32 slen;
+ if (*SvPVX(rx->check_substr) != s[rx->check_offset_min]
+ || ((slen = SvCUR(rx->check_substr)) > 1
+ && memNE(SvPVX(rx->check_substr),
+ s + rx->check_offset_min, slen)))
+ goto nope;
+ }
+ if (!rx->naughty && --BmUSEFUL(rx->check_substr) < 0
+ && rx->check_substr == rx->float_substr) {
+ SvREFCNT_dec(rx->check_substr);
+ rx->check_substr = Nullsv; /* opt is being useless */
+ rx->float_substr = Nullsv;
+ }
+ }
+
+ /* only replace once? */
+ once = !(rpm->op_pmflags & PMf_GLOBAL);
+
+ /* known replacement string? */
+ c = dstr ? SvPV(dstr, clen) : Nullch;
+
+ /* can do inplace substitution? */
+ if (c && clen <= rx->minlen && (once || !(safebase & REXEC_COPY_STR))
+ && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
+ if (!CALLREGEXEC(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+ SPAGAIN;
+ PUSHs(&PL_sv_no);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
+ }
+ if (force_on_match) {
+ force_on_match = 0;
+ s = SvPV_force(TARG, len);
+ goto force_it;
+ }
+ d = s;
+ PL_curpm = pm;
+ SvSCREAM_off(TARG); /* disable possible screamer */
+ if (once) {
+ rxtainted |= RX_MATCH_TAINTED(rx);
+ if (rx->subbase) {
+ m = orig + (rx->startp[0] - rx->subbase);
+ d = orig + (rx->endp[0] - rx->subbase);
+ } else {
+ m = rx->startp[0];
+ d = rx->endp[0];
+ }
+ s = orig;
+ if (m - s > strend - d) { /* faster to shorten from end */
+ if (clen) {
+ Copy(c, m, clen, char);
+ m += clen;
+ }
+ i = strend - d;
+ if (i > 0) {
+ Move(d, m, i, char);
+ m += i;
+ }
+ *m = '\0';
+ SvCUR_set(TARG, m - s);
+ }
+ /*SUPPRESS 560*/
+ else if (i = m - s) { /* faster from front */
+ d -= clen;
+ m = d;
+ sv_chop(TARG, d-i);
+ s += i;
+ while (i--)
+ *--d = *--s;
+ if (clen)
+ Copy(c, m, clen, char);
+ }
+ else if (clen) {
+ d -= clen;
+ sv_chop(TARG, d);
+ Copy(c, d, clen, char);
+ }
+ else {
+ sv_chop(TARG, d);
+ }
+ TAINT_IF(rxtainted & 1);
+ SPAGAIN;
+ PUSHs(&PL_sv_yes);
+ }
+ else {
+ do {
+ if (iters++ > maxiters)
+ DIE("Substitution loop");
+ rxtainted |= RX_MATCH_TAINTED(rx);
+ m = rx->startp[0];
+ /*SUPPRESS 560*/
+ if (i = m - s) {
+ if (s != d)
+ Move(s, d, i, char);
+ d += i;
+ }
+ if (clen) {
+ Copy(c, d, clen, char);
+ d += clen;
+ }
+ s = rx->endp[0];
+ } while (CALLREGEXEC(rx, s, strend, orig, s == m,
+ Nullsv, NULL, 0)); /* don't match same null twice */
+ if (s != d) {
+ i = strend - s;
+ SvCUR_set(TARG, d - SvPVX(TARG) + i);
+ Move(s, d, i+1, char); /* include the NUL */
+ }
+ TAINT_IF(rxtainted & 1);
+ SPAGAIN;
+ PUSHs(sv_2mortal(newSViv((I32)iters)));
+ }
+ (void)SvPOK_only(TARG);
+ TAINT_IF(rxtainted);
+ if (SvSMAGICAL(TARG)) {
+ PUTBACK;
+ mg_set(TARG);
+ SPAGAIN;
+ }
+ SvTAINT(TARG);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
+ }
+
+ if (CALLREGEXEC(rx, s, strend, orig, 0, screamer, NULL, safebase)) {
+ if (force_on_match) {
+ force_on_match = 0;
+ s = SvPV_force(TARG, len);
+ goto force_it;
+ }
+ rxtainted |= RX_MATCH_TAINTED(rx);
+ dstr = NEWSV(25, len);
+ sv_setpvn(dstr, m, s-m);
+ PL_curpm = pm;
+ if (!c) {
+ register PERL_CONTEXT *cx;
+ SPAGAIN;
+ PUSHSUBST(cx);
+ RETURNOP(cPMOP->op_pmreplroot);
+ }
+ do {
+ if (iters++ > maxiters)
+ DIE("Substitution loop");
+ rxtainted |= RX_MATCH_TAINTED(rx);
+ if (rx->subbase && rx->subbase != orig) {
+ m = s;
+ s = orig;
+ orig = rx->subbase;
+ s = orig + (m - s);
+ strend = s + (strend - m);
+ }
+ m = rx->startp[0];
+ sv_catpvn(dstr, s, m-s);
+ s = rx->endp[0];
+ if (clen)
+ sv_catpvn(dstr, c, clen);
+ if (once)
+ break;
+ } while (CALLREGEXEC(rx, s, strend, orig, s == m, Nullsv, NULL, safebase));
+ sv_catpvn(dstr, s, strend - s);
+
+ (void)SvOOK_off(TARG);
+ Safefree(SvPVX(TARG));
+ SvPVX(TARG) = SvPVX(dstr);
+ SvCUR_set(TARG, SvCUR(dstr));
+ SvLEN_set(TARG, SvLEN(dstr));
+ SvPVX(dstr) = 0;
+ sv_free(dstr);
+
+ TAINT_IF(rxtainted & 1);
+ SPAGAIN;
+ PUSHs(sv_2mortal(newSViv((I32)iters)));
+
+ (void)SvPOK_only(TARG);
+ TAINT_IF(rxtainted);
+ SvSETMAGIC(TARG);
+ SvTAINT(TARG);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
+ }
+ goto ret_no;
+
+nope:
+ ++BmUSEFUL(rx->check_substr);
+
+ret_no:
+ SPAGAIN;
+ PUSHs(&PL_sv_no);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
+}
+
+PP(pp_grepwhile)
+{
+ djSP;
+
+ if (SvTRUEx(POPs))
+ PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
+ ++*PL_markstack_ptr;
+ LEAVE; /* exit inner scope */
+
+ /* All done yet? */
+ if (PL_stack_base + *PL_markstack_ptr > SP) {
+ I32 items;
+ I32 gimme = GIMME_V;
+
+ LEAVE; /* exit outer scope */
+ (void)POPMARK; /* pop src */
+ items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
+ (void)POPMARK; /* pop dst */
+ SP = PL_stack_base + POPMARK; /* pop original mark */
+ if (gimme == G_SCALAR) {
+ dTARGET;
+ XPUSHi(items);
+ }
+ else if (gimme == G_ARRAY)
+ SP += items;
+ RETURN;
+ }
+ else {
+ SV *src;
+
+ ENTER; /* enter inner scope */
+ SAVESPTR(PL_curpm);
+
+ src = PL_stack_base[*PL_markstack_ptr];
+ SvTEMP_off(src);
+ DEFSV = src;
+
+ RETURNOP(cLOGOP->op_other);
+ }
+}
+
+PP(pp_leavesub)
+{
+ djSP;
+ SV **mark;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
+ register PERL_CONTEXT *cx;
+ struct block_sub cxsub;
+
+ POPBLOCK(cx,newpm);
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+
+ TAINT_NOT;
+ if (gimme == G_SCALAR) {
+ MARK = newsp + 1;
+ if (MARK <= SP) {
+ if (cxsub.cv && CvDEPTH(cxsub.cv) > 1) {
+ if (SvTEMP(TOPs)) {
+ *MARK = SvREFCNT_inc(TOPs);
+ FREETMPS;
+ sv_2mortal(*MARK);
+ } else {
+ FREETMPS;
+ *MARK = sv_mortalcopy(TOPs);
+ }
+ } else
+ *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
+ } else {
+ MEXTEND(MARK, 0);
+ *MARK = &PL_sv_undef;
+ }
+ SP = MARK;
+ }
+ else if (gimme == G_ARRAY) {
+ for (MARK = newsp + 1; MARK <= SP; MARK++) {
+ if (!SvTEMP(*MARK)) {
+ *MARK = sv_mortalcopy(*MARK);
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
+ }
+ PUTBACK;
+
+ POPSUB2(); /* Stack values are safe: release CV and @_ ... */
+ PL_curpm = newpm; /* ... and pop $1 et al */
+
+ LEAVE;
+ return pop_return();
+}
+
+STATIC CV *
+get_db_sub(SV **svp, CV *cv)
+{
+ dTHR;
+ SV *dbsv = GvSV(PL_DBsub);
+
+ if (!PERLDB_SUB_NN) {
+ GV *gv = CvGV(cv);
+
+ save_item(dbsv);
+ if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+ || strEQ(GvNAME(gv), "END")
+ || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+ !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
+ && (gv = (GV*)*svp) ))) {
+ /* Use GV from the stack as a fallback. */
+ /* GV is potentially non-unique, or contain different CV. */
+ sv_setsv(dbsv, newRV((SV*)cv));
+ }
+ else {
+ gv_efullname3(dbsv, gv, Nullch);
+ }
+ }
+ else {
+ SvUPGRADE(dbsv, SVt_PVIV);
+ SvIOK_on(dbsv);
+ SAVEIV(SvIVX(dbsv));
+ SvIVX(dbsv) = (IV)cv; /* Do it the quickest way */
+ }
+
+ if (CvXSUB(cv))
+ PL_curcopdb = PL_curcop;
+ cv = GvCV(PL_DBsub);
+ return cv;
+}
+
+PP(pp_entersub)
+{
+ djSP; dPOPss;
+ GV *gv;
+ HV *stash;
+ register CV *cv;
+ register PERL_CONTEXT *cx;
+ I32 gimme;
+ bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
+
+ if (!sv)
+ DIE("Not a CODE reference");
+ switch (SvTYPE(sv)) {
+ default:
+ if (!SvROK(sv)) {
+ char *sym;
+
+ if (sv == &PL_sv_yes) { /* unfound import, ignore */
+ if (hasargs)
+ SP = PL_stack_base + POPMARK;
+ RETURN;
+ }
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
+ }
+ else
+ sym = SvPV(sv, PL_na);
+ if (!sym)
+ DIE(no_usym, "a subroutine");
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(no_symref, sym, "a subroutine");
+ cv = perl_get_cv(sym, TRUE);
+ break;
+ }
+ cv = (CV*)SvRV(sv);
+ if (SvTYPE(cv) == SVt_PVCV)
+ break;
+ /* FALL THROUGH */
+ case SVt_PVHV:
+ case SVt_PVAV:
+ DIE("Not a CODE reference");
+ case SVt_PVCV:
+ cv = (CV*)sv;
+ break;
+ case SVt_PVGV:
+ if (!(cv = GvCVu((GV*)sv)))
+ cv = sv_2cv(sv, &stash, &gv, TRUE);
+ break;
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ retry:
+ if (!cv)
+ DIE("Not a CODE reference");
+
+ if (!CvROOT(cv) && !CvXSUB(cv)) {
+ GV* autogv;
+ SV* sub_name;
+
+ /* anonymous or undef'd function leaves us no recourse */
+ if (CvANON(cv) || !(gv = CvGV(cv)))
+ DIE("Undefined subroutine called");
+ /* autoloaded stub? */
+ if (cv != GvCV(gv)) {
+ cv = GvCV(gv);
+ goto retry;
+ }
+ /* should call AUTOLOAD now? */
+ if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
+ FALSE)))
+ {
+ cv = GvCV(autogv);
+ goto retry;
+ }
+ /* sorry */
+ sub_name = sv_newmortal();
+ gv_efullname3(sub_name, gv, Nullch);
+ DIE("Undefined subroutine &%s called", SvPVX(sub_name));
+ }
+
+ gimme = GIMME_V;
+ if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv))
+ cv = get_db_sub(&sv, cv);
+ if (!cv)
+ DIE("No DBsub routine");
+
+#ifdef USE_THREADS
+ /*
+ * First we need to check if the sub or method requires locking.
+ * If so, we gain a lock on the CV, the first argument or the
+ * stash (for static methods), as appropriate. This has to be
+ * inline because for FAKE_THREADS, COND_WAIT inlines code to
+ * reschedule by returning a new op.
+ */
+ MUTEX_LOCK(CvMUTEXP(cv));
+ if (CvFLAGS(cv) & CVf_LOCKED) {
+ MAGIC *mg;
+ if (CvFLAGS(cv) & CVf_METHOD) {
+ if (SP > PL_stack_base + TOPMARK)
+ sv = *(PL_stack_base + TOPMARK + 1);
+ else {
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ croak("no argument for locked method call");
+ }
+ if (SvROK(sv))
+ sv = SvRV(sv);
+ else {
+ STRLEN len;
+ char *stashname = SvPV(sv, len);
+ sv = (SV*)gv_stashpvn(stashname, len, TRUE);
+ }
+ }
+ else {
+ sv = (SV*)cv;
+ }
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ mg = condpair_magic(sv);
+ MUTEX_LOCK(MgMUTEXP(mg));
+ if (MgOWNER(mg) == thr)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ else {
+ while (MgOWNER(mg))
+ COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
+ MgOWNER(mg) = thr;
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: pp_entersub lock %p\n",
+ thr, sv);)
+ MUTEX_UNLOCK(MgMUTEXP(mg));
+ SvREFCNT_inc(sv); /* Keep alive until magic_mutexfree */
+ save_destructor(unlock_condpair, sv);
+ }
+ MUTEX_LOCK(CvMUTEXP(cv));
+ }
+ /*
+ * Now we have permission to enter the sub, we must distinguish
+ * four cases. (0) It's an XSUB (in which case we don't care
+ * about ownership); (1) it's ours already (and we're recursing);
+ * (2) it's free (but we may already be using a cached clone);
+ * (3) another thread owns it. Case (1) is easy: we just use it.
+ * Case (2) means we look for a clone--if we have one, use it
+ * otherwise grab ownership of cv. Case (3) means we look for a
+ * clone (for non-XSUBs) and have to create one if we don't
+ * already have one.
+ * Why look for a clone in case (2) when we could just grab
+ * ownership of cv straight away? Well, we could be recursing,
+ * i.e. we originally tried to enter cv while another thread
+ * owned it (hence we used a clone) but it has been freed up
+ * and we're now recursing into it. It may or may not be "better"
+ * to use the clone but at least CvDEPTH can be trusted.
+ */
+ if (CvOWNER(cv) == thr || CvXSUB(cv))
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ else {
+ /* Case (2) or (3) */
+ SV **svp;
+
+ /*
+ * XXX Might it be better to release CvMUTEXP(cv) while we
+ * do the hv_fetch? We might find someone has pinched it
+ * when we look again, in which case we would be in case
+ * (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)))
+ {
+ /* We already have a clone to use */
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ cv = *(CV**)svp;
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "entersub: %p already has clone %p:%s\n",
+ thr, cv, SvPEEK((SV*)cv)));
+ CvOWNER(cv) = thr;
+ SvREFCNT_inc(cv);
+ if (CvDEPTH(cv) == 0)
+ SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
+ }
+ else {
+ /* (2) => grab ownership of cv. (3) => make clone */
+ if (!CvOWNER(cv)) {
+ CvOWNER(cv) = thr;
+ SvREFCNT_inc(cv);
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "entersub: %p grabbing %p:%s in stash %s\n",
+ thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
+ HvNAME(CvSTASH(cv)) : "(none)"));
+ } else {
+ /* Make a new clone. */
+ CV *clonecv;
+ SvREFCNT_inc(cv); /* don't let it vanish from under us */
+ MUTEX_UNLOCK(CvMUTEXP(cv));
+ DEBUG_S((PerlIO_printf(PerlIO_stderr(),
+ "entersub: %p cloning %p:%s\n",
+ thr, cv, SvPEEK((SV*)cv))));
+ /*
+ * We're creating a new clone so there's no race
+ * between the original MUTEX_UNLOCK and the
+ * SvREFCNT_inc since no one will be trying to undef
+ * it out from underneath us. At least, I don't think
+ * there's a race...
+ */
+ clonecv = cv_clone(cv);
+ SvREFCNT_dec(cv); /* finished with this */
+ hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
+ CvOWNER(clonecv) = thr;
+ cv = clonecv;
+ SvREFCNT_inc(cv);
+ }
+ DEBUG_S(if (CvDEPTH(cv) != 0)
+ PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
+ CvDEPTH(cv)););
+ SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
+ }
+ }
+#endif /* USE_THREADS */
+
+ if (CvXSUB(cv)) {
+ if (CvOLDSTYLE(cv)) {
+ I32 (*fp3)_((int,int,int));
+ dMARK;
+ register I32 items = SP - MARK;
+ /* We dont worry to copy from @_. */
+ while (SP > mark) {
+ SP[1] = SP[0];
+ SP--;
+ }
+ PL_stack_sp = mark + 1;
+ fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
+ items = (*fp3)(CvXSUBANY(cv).any_i32,
+ MARK - PL_stack_base + 1,
+ items);
+ PL_stack_sp = PL_stack_base + items;
+ }
+ else {
+ I32 markix = TOPMARK;
+
+ PUTBACK;
+
+ if (!hasargs) {
+ /* Need to copy @_ to stack. Alternative may be to
+ * switch stack to @_, and copy return values
+ * back. This would allow popping @_ in XSUB, e.g.. XXXX */
+ AV* av;
+ I32 items;
+#ifdef USE_THREADS
+ av = (AV*)PL_curpad[0];
+#else
+ av = GvAV(PL_defgv);
+#endif /* USE_THREADS */
+ items = AvFILLp(av) + 1; /* @_ is not tieable */
+
+ if (items) {
+ /* Mark is at the end of the stack. */
+ EXTEND(SP, items);
+ Copy(AvARRAY(av), SP + 1, items, SV*);
+ SP += items;
+ PUTBACK ;
+ }
+ }
+ if (PL_curcopdb) { /* We assume that the first
+ XSUB in &DB::sub is the
+ called one. */
+ SAVESPTR(PL_curcop);
+ PL_curcop = PL_curcopdb;
+ PL_curcopdb = NULL;
+ }
+ /* Do we need to open block here? XXXX */
+ (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
+
+ /* Enforce some sanity in scalar context. */
+ if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
+ if (markix > PL_stack_sp - PL_stack_base)
+ *(PL_stack_base + markix) = &PL_sv_undef;
+ else
+ *(PL_stack_base + markix) = *PL_stack_sp;
+ PL_stack_sp = PL_stack_base + markix;
+ }
+ }
+ LEAVE;
+ return NORMAL;
+ }
+ else {
+ dMARK;
+ register I32 items = SP - MARK;
+ AV* padlist = CvPADLIST(cv);
+ SV** svp = AvARRAY(padlist);
+ push_return(PL_op->op_next);
+ PUSHBLOCK(cx, CXt_SUB, MARK);
+ PUSHSUB(cx);
+ CvDEPTH(cv)++;
+ if (CvDEPTH(cv) < 2)
+ (void)SvREFCNT_inc(cv);
+ else { /* save temporaries on recursion? */
+ if (CvDEPTH(cv) == 100 && PL_dowarn
+ && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
+ sub_crush_depth(cv);
+ if (CvDEPTH(cv) > AvFILLp(padlist)) {
+ AV *av;
+ AV *newpad = newAV();
+ SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
+ I32 ix = AvFILLp((AV*)svp[1]);
+ svp = AvARRAY(svp[0]);
+ for ( ;ix > 0; ix--) {
+ if (svp[ix] != &PL_sv_undef) {
+ char *name = SvPVX(svp[ix]);
+ if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
+ || *name == '&') /* anonymous code? */
+ {
+ av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
+ }
+ else { /* our own lexical */
+ if (*name == '@')
+ av_store(newpad, ix, sv = (SV*)newAV());
+ else if (*name == '%')
+ av_store(newpad, ix, sv = (SV*)newHV());
+ else
+ av_store(newpad, ix, sv = NEWSV(0,0));
+ SvPADMY_on(sv);
+ }
+ }
+ else {
+ av_store(newpad, ix, sv = NEWSV(0,0));
+ SvPADTMP_on(sv);
+ }
+ }
+ av = newAV(); /* will be @_ */
+ av_extend(av, 0);
+ av_store(newpad, 0, (SV*)av);
+ AvFLAGS(av) = AVf_REIFY;
+ av_store(padlist, CvDEPTH(cv), (SV*)newpad);
+ AvFILLp(padlist) = CvDEPTH(cv);
+ svp = AvARRAY(padlist);
+ }
+ }
+#ifdef USE_THREADS
+ if (!hasargs) {
+ AV* av = (AV*)PL_curpad[0];
+
+ items = AvFILLp(av) + 1;
+ if (items) {
+ /* Mark is at the end of the stack. */
+ EXTEND(SP, items);
+ Copy(AvARRAY(av), SP + 1, items, SV*);
+ SP += items;
+ PUTBACK ;
+ }
+ }
+#endif /* USE_THREADS */
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
+#ifndef USE_THREADS
+ if (hasargs)
+#endif /* USE_THREADS */
+ {
+ AV* av;
+ SV** ary;
+
+#if 0
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p entersub preparing @_\n", thr));
+#endif
+ av = (AV*)PL_curpad[0];
+ if (AvREAL(av)) {
+ av_clear(av);
+ AvREAL_off(av);
+ }
+#ifndef USE_THREADS
+ cx->blk_sub.savearray = GvAV(PL_defgv);
+ GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+#endif /* USE_THREADS */
+ cx->blk_sub.argarray = av;
+ ++MARK;
+
+ if (items > AvMAX(av) + 1) {
+ ary = AvALLOC(av);
+ if (AvARRAY(av) != ary) {
+ AvMAX(av) += AvARRAY(av) - AvALLOC(av);
+ SvPVX(av) = (char*)ary;
+ }
+ if (items > AvMAX(av) + 1) {
+ AvMAX(av) = items - 1;
+ Renew(ary,items,SV*);
+ AvALLOC(av) = ary;
+ SvPVX(av) = (char*)ary;
+ }
+ }
+ Copy(MARK,AvARRAY(av),items,SV*);
+ AvFILLp(av) = items - 1;
+
+ while (items--) {
+ if (*MARK)
+ SvTEMP_off(*MARK);
+ MARK++;
+ }
+ }
+#if 0
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p entersub returning %p\n", thr, CvSTART(cv)));
+#endif
+ RETURNOP(CvSTART(cv));
+ }
+}
+
+void
+sub_crush_depth(CV *cv)
+{
+ if (CvANON(cv))
+ warn("Deep recursion on anonymous subroutine");
+ else {
+ SV* tmpstr = sv_newmortal();
+ gv_efullname3(tmpstr, CvGV(cv), Nullch);
+ warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr));
+ }
+}
+
+PP(pp_aelem)
+{
+ djSP;
+ SV** svp;
+ I32 elem = POPi;
+ AV* av = (AV*)POPs;
+ U32 lval = PL_op->op_flags & OPf_MOD;
+ U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
+ SV *sv;
+
+ if (elem > 0)
+ elem -= PL_curcop->cop_arybase;
+ if (SvTYPE(av) != SVt_PVAV)
+ RETPUSHUNDEF;
+ svp = av_fetch(av, elem, lval && !defer);
+ if (lval) {
+ if (!svp || *svp == &PL_sv_undef) {
+ SV* lv;
+ if (!defer)
+ DIE(no_aelem, elem);
+ lv = sv_newmortal();
+ sv_upgrade(lv, SVt_PVLV);
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, Nullsv, 'y', Nullch, 0);
+ LvTARG(lv) = SvREFCNT_inc(av);
+ LvTARGOFF(lv) = elem;
+ LvTARGLEN(lv) = 1;
+ PUSHs(lv);
+ RETURN;
+ }
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ save_aelem(av, elem, svp);
+ else if (PL_op->op_private & OPpDEREF)
+ vivify_ref(*svp, PL_op->op_private & OPpDEREF);
+ }
+ sv = (svp ? *svp : &PL_sv_undef);
+ if (!lval && SvGMAGICAL(sv)) /* see note in pp_helem() */
+ sv = sv_mortalcopy(sv);
+ PUSHs(sv);
+ RETURN;
+}
+
+void
+vivify_ref(SV *sv, U32 to_what)
+{
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (!SvOK(sv)) {
+ if (SvREADONLY(sv))
+ croak(no_modify);
+ if (SvTYPE(sv) < SVt_RV)
+ sv_upgrade(sv, SVt_RV);
+ else if (SvTYPE(sv) >= SVt_PV) {
+ (void)SvOOK_off(sv);
+ Safefree(SvPVX(sv));
+ SvLEN(sv) = SvCUR(sv) = 0;
+ }
+ switch (to_what) {
+ case OPpDEREF_SV:
+ SvRV(sv) = NEWSV(355,0);
+ break;
+ case OPpDEREF_AV:
+ SvRV(sv) = (SV*)newAV();
+ break;
+ case OPpDEREF_HV:
+ SvRV(sv) = (SV*)newHV();
+ break;
+ }
+ SvROK_on(sv);
+ SvSETMAGIC(sv);
+ }
+}
+
+PP(pp_method)
+{
+ djSP;
+ SV* sv;
+ SV* ob;
+ GV* gv;
+ HV* stash;
+ char* name;
+ char* packname;
+ STRLEN packlen;
+
+ if (SvROK(TOPs)) {
+ sv = SvRV(TOPs);
+ if (SvTYPE(sv) == SVt_PVCV) {
+ SETs(sv);
+ RETURN;
+ }
+ }
+
+ name = SvPV(TOPs, PL_na);
+ sv = *(PL_stack_base + TOPMARK + 1);
+
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (SvROK(sv))
+ ob = (SV*)SvRV(sv);
+ else {
+ GV* iogv;
+
+ packname = Nullch;
+ if (!SvOK(sv) ||
+ !(packname = SvPV(sv, packlen)) ||
+ !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
+ !(ob=(SV*)GvIO(iogv)))
+ {
+ if (!packname || !isIDFIRST(*packname))
+ DIE("Can't call method \"%s\" %s", name,
+ SvOK(sv)? "without a package or object reference"
+ : "on an undefined value");
+ stash = gv_stashpvn(packname, packlen, TRUE);
+ goto fetch;
+ }
+ *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
+ }
+
+ if (!ob || !SvOBJECT(ob))
+ DIE("Can't call method \"%s\" on unblessed reference", name);
+
+ stash = SvSTASH(ob);
+
+ fetch:
+ gv = gv_fetchmethod(stash, name);
+ if (!gv) {
+ char* leaf = name;
+ char* sep = Nullch;
+ char* p;
+
+ for (p = name; *p; p++) {
+ if (*p == '\'')
+ sep = p, leaf = p + 1;
+ else if (*p == ':' && *(p + 1) == ':')
+ sep = p, leaf = p + 2;
+ }
+ if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
+ packname = HvNAME(sep ? PL_curcop->cop_stash : stash);
+ packlen = strlen(packname);
+ }
+ else {
+ packname = name;
+ packlen = sep - name;
+ }
+ DIE("Can't locate object method \"%s\" via package \"%.*s\"",
+ leaf, (int)packlen, packname);
+ }
+ SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);
+ RETURN;
+}
+
diff --git a/contrib/perl5/pp_proto.h b/contrib/perl5/pp_proto.h
new file mode 100644
index 000000000000..ad82696849b4
--- /dev/null
+++ b/contrib/perl5/pp_proto.h
@@ -0,0 +1,344 @@
+PPDEF(pp_null)
+PPDEF(pp_stub)
+PPDEF(pp_scalar)
+PPDEF(pp_pushmark)
+PPDEF(pp_wantarray)
+PPDEF(pp_const)
+PPDEF(pp_gvsv)
+PPDEF(pp_gv)
+PPDEF(pp_gelem)
+PPDEF(pp_padsv)
+PPDEF(pp_padav)
+PPDEF(pp_padhv)
+PPDEF(pp_padany)
+PPDEF(pp_pushre)
+PPDEF(pp_rv2gv)
+PPDEF(pp_rv2sv)
+PPDEF(pp_av2arylen)
+PPDEF(pp_rv2cv)
+PPDEF(pp_anoncode)
+PPDEF(pp_prototype)
+PPDEF(pp_refgen)
+PPDEF(pp_srefgen)
+PPDEF(pp_ref)
+PPDEF(pp_bless)
+PPDEF(pp_backtick)
+PPDEF(pp_glob)
+PPDEF(pp_readline)
+PPDEF(pp_rcatline)
+PPDEF(pp_regcmaybe)
+PPDEF(pp_regcreset)
+PPDEF(pp_regcomp)
+PPDEF(pp_match)
+PPDEF(pp_qr)
+PPDEF(pp_subst)
+PPDEF(pp_substcont)
+PPDEF(pp_trans)
+PPDEF(pp_sassign)
+PPDEF(pp_aassign)
+PPDEF(pp_chop)
+PPDEF(pp_schop)
+PPDEF(pp_chomp)
+PPDEF(pp_schomp)
+PPDEF(pp_defined)
+PPDEF(pp_undef)
+PPDEF(pp_study)
+PPDEF(pp_pos)
+PPDEF(pp_preinc)
+PPDEF(pp_predec)
+PPDEF(pp_postinc)
+PPDEF(pp_postdec)
+PPDEF(pp_pow)
+PPDEF(pp_multiply)
+PPDEF(pp_i_multiply)
+PPDEF(pp_divide)
+PPDEF(pp_i_divide)
+PPDEF(pp_modulo)
+PPDEF(pp_i_modulo)
+PPDEF(pp_repeat)
+PPDEF(pp_add)
+PPDEF(pp_i_add)
+PPDEF(pp_subtract)
+PPDEF(pp_i_subtract)
+PPDEF(pp_concat)
+PPDEF(pp_stringify)
+PPDEF(pp_left_shift)
+PPDEF(pp_right_shift)
+PPDEF(pp_lt)
+PPDEF(pp_i_lt)
+PPDEF(pp_gt)
+PPDEF(pp_i_gt)
+PPDEF(pp_le)
+PPDEF(pp_i_le)
+PPDEF(pp_ge)
+PPDEF(pp_i_ge)
+PPDEF(pp_eq)
+PPDEF(pp_i_eq)
+PPDEF(pp_ne)
+PPDEF(pp_i_ne)
+PPDEF(pp_ncmp)
+PPDEF(pp_i_ncmp)
+PPDEF(pp_slt)
+PPDEF(pp_sgt)
+PPDEF(pp_sle)
+PPDEF(pp_sge)
+PPDEF(pp_seq)
+PPDEF(pp_sne)
+PPDEF(pp_scmp)
+PPDEF(pp_bit_and)
+PPDEF(pp_bit_xor)
+PPDEF(pp_bit_or)
+PPDEF(pp_negate)
+PPDEF(pp_i_negate)
+PPDEF(pp_not)
+PPDEF(pp_complement)
+PPDEF(pp_atan2)
+PPDEF(pp_sin)
+PPDEF(pp_cos)
+PPDEF(pp_rand)
+PPDEF(pp_srand)
+PPDEF(pp_exp)
+PPDEF(pp_log)
+PPDEF(pp_sqrt)
+PPDEF(pp_int)
+PPDEF(pp_hex)
+PPDEF(pp_oct)
+PPDEF(pp_abs)
+PPDEF(pp_length)
+PPDEF(pp_substr)
+PPDEF(pp_vec)
+PPDEF(pp_index)
+PPDEF(pp_rindex)
+PPDEF(pp_sprintf)
+PPDEF(pp_formline)
+PPDEF(pp_ord)
+PPDEF(pp_chr)
+PPDEF(pp_crypt)
+PPDEF(pp_ucfirst)
+PPDEF(pp_lcfirst)
+PPDEF(pp_uc)
+PPDEF(pp_lc)
+PPDEF(pp_quotemeta)
+PPDEF(pp_rv2av)
+PPDEF(pp_aelemfast)
+PPDEF(pp_aelem)
+PPDEF(pp_aslice)
+PPDEF(pp_each)
+PPDEF(pp_values)
+PPDEF(pp_keys)
+PPDEF(pp_delete)
+PPDEF(pp_exists)
+PPDEF(pp_rv2hv)
+PPDEF(pp_helem)
+PPDEF(pp_hslice)
+PPDEF(pp_unpack)
+PPDEF(pp_pack)
+PPDEF(pp_split)
+PPDEF(pp_join)
+PPDEF(pp_list)
+PPDEF(pp_lslice)
+PPDEF(pp_anonlist)
+PPDEF(pp_anonhash)
+PPDEF(pp_splice)
+PPDEF(pp_push)
+PPDEF(pp_pop)
+PPDEF(pp_shift)
+PPDEF(pp_unshift)
+PPDEF(pp_sort)
+PPDEF(pp_reverse)
+PPDEF(pp_grepstart)
+PPDEF(pp_grepwhile)
+PPDEF(pp_mapstart)
+PPDEF(pp_mapwhile)
+PPDEF(pp_range)
+PPDEF(pp_flip)
+PPDEF(pp_flop)
+PPDEF(pp_and)
+PPDEF(pp_or)
+PPDEF(pp_xor)
+PPDEF(pp_cond_expr)
+PPDEF(pp_andassign)
+PPDEF(pp_orassign)
+PPDEF(pp_method)
+PPDEF(pp_entersub)
+PPDEF(pp_leavesub)
+PPDEF(pp_caller)
+PPDEF(pp_warn)
+PPDEF(pp_die)
+PPDEF(pp_reset)
+PPDEF(pp_lineseq)
+PPDEF(pp_nextstate)
+PPDEF(pp_dbstate)
+PPDEF(pp_unstack)
+PPDEF(pp_enter)
+PPDEF(pp_leave)
+PPDEF(pp_scope)
+PPDEF(pp_enteriter)
+PPDEF(pp_iter)
+PPDEF(pp_enterloop)
+PPDEF(pp_leaveloop)
+PPDEF(pp_return)
+PPDEF(pp_last)
+PPDEF(pp_next)
+PPDEF(pp_redo)
+PPDEF(pp_dump)
+PPDEF(pp_goto)
+PPDEF(pp_exit)
+PPDEF(pp_open)
+PPDEF(pp_close)
+PPDEF(pp_pipe_op)
+PPDEF(pp_fileno)
+PPDEF(pp_umask)
+PPDEF(pp_binmode)
+PPDEF(pp_tie)
+PPDEF(pp_untie)
+PPDEF(pp_tied)
+PPDEF(pp_dbmopen)
+PPDEF(pp_dbmclose)
+PPDEF(pp_sselect)
+PPDEF(pp_select)
+PPDEF(pp_getc)
+PPDEF(pp_read)
+PPDEF(pp_enterwrite)
+PPDEF(pp_leavewrite)
+PPDEF(pp_prtf)
+PPDEF(pp_print)
+PPDEF(pp_sysopen)
+PPDEF(pp_sysseek)
+PPDEF(pp_sysread)
+PPDEF(pp_syswrite)
+PPDEF(pp_send)
+PPDEF(pp_recv)
+PPDEF(pp_eof)
+PPDEF(pp_tell)
+PPDEF(pp_seek)
+PPDEF(pp_truncate)
+PPDEF(pp_fcntl)
+PPDEF(pp_ioctl)
+PPDEF(pp_flock)
+PPDEF(pp_socket)
+PPDEF(pp_sockpair)
+PPDEF(pp_bind)
+PPDEF(pp_connect)
+PPDEF(pp_listen)
+PPDEF(pp_accept)
+PPDEF(pp_shutdown)
+PPDEF(pp_gsockopt)
+PPDEF(pp_ssockopt)
+PPDEF(pp_getsockname)
+PPDEF(pp_getpeername)
+PPDEF(pp_lstat)
+PPDEF(pp_stat)
+PPDEF(pp_ftrread)
+PPDEF(pp_ftrwrite)
+PPDEF(pp_ftrexec)
+PPDEF(pp_fteread)
+PPDEF(pp_ftewrite)
+PPDEF(pp_fteexec)
+PPDEF(pp_ftis)
+PPDEF(pp_fteowned)
+PPDEF(pp_ftrowned)
+PPDEF(pp_ftzero)
+PPDEF(pp_ftsize)
+PPDEF(pp_ftmtime)
+PPDEF(pp_ftatime)
+PPDEF(pp_ftctime)
+PPDEF(pp_ftsock)
+PPDEF(pp_ftchr)
+PPDEF(pp_ftblk)
+PPDEF(pp_ftfile)
+PPDEF(pp_ftdir)
+PPDEF(pp_ftpipe)
+PPDEF(pp_ftlink)
+PPDEF(pp_ftsuid)
+PPDEF(pp_ftsgid)
+PPDEF(pp_ftsvtx)
+PPDEF(pp_fttty)
+PPDEF(pp_fttext)
+PPDEF(pp_ftbinary)
+PPDEF(pp_chdir)
+PPDEF(pp_chown)
+PPDEF(pp_chroot)
+PPDEF(pp_unlink)
+PPDEF(pp_chmod)
+PPDEF(pp_utime)
+PPDEF(pp_rename)
+PPDEF(pp_link)
+PPDEF(pp_symlink)
+PPDEF(pp_readlink)
+PPDEF(pp_mkdir)
+PPDEF(pp_rmdir)
+PPDEF(pp_open_dir)
+PPDEF(pp_readdir)
+PPDEF(pp_telldir)
+PPDEF(pp_seekdir)
+PPDEF(pp_rewinddir)
+PPDEF(pp_closedir)
+PPDEF(pp_fork)
+PPDEF(pp_wait)
+PPDEF(pp_waitpid)
+PPDEF(pp_system)
+PPDEF(pp_exec)
+PPDEF(pp_kill)
+PPDEF(pp_getppid)
+PPDEF(pp_getpgrp)
+PPDEF(pp_setpgrp)
+PPDEF(pp_getpriority)
+PPDEF(pp_setpriority)
+PPDEF(pp_time)
+PPDEF(pp_tms)
+PPDEF(pp_localtime)
+PPDEF(pp_gmtime)
+PPDEF(pp_alarm)
+PPDEF(pp_sleep)
+PPDEF(pp_shmget)
+PPDEF(pp_shmctl)
+PPDEF(pp_shmread)
+PPDEF(pp_shmwrite)
+PPDEF(pp_msgget)
+PPDEF(pp_msgctl)
+PPDEF(pp_msgsnd)
+PPDEF(pp_msgrcv)
+PPDEF(pp_semget)
+PPDEF(pp_semctl)
+PPDEF(pp_semop)
+PPDEF(pp_require)
+PPDEF(pp_dofile)
+PPDEF(pp_entereval)
+PPDEF(pp_leaveeval)
+PPDEF(pp_entertry)
+PPDEF(pp_leavetry)
+PPDEF(pp_ghbyname)
+PPDEF(pp_ghbyaddr)
+PPDEF(pp_ghostent)
+PPDEF(pp_gnbyname)
+PPDEF(pp_gnbyaddr)
+PPDEF(pp_gnetent)
+PPDEF(pp_gpbyname)
+PPDEF(pp_gpbynumber)
+PPDEF(pp_gprotoent)
+PPDEF(pp_gsbyname)
+PPDEF(pp_gsbyport)
+PPDEF(pp_gservent)
+PPDEF(pp_shostent)
+PPDEF(pp_snetent)
+PPDEF(pp_sprotoent)
+PPDEF(pp_sservent)
+PPDEF(pp_ehostent)
+PPDEF(pp_enetent)
+PPDEF(pp_eprotoent)
+PPDEF(pp_eservent)
+PPDEF(pp_gpwnam)
+PPDEF(pp_gpwuid)
+PPDEF(pp_gpwent)
+PPDEF(pp_spwent)
+PPDEF(pp_epwent)
+PPDEF(pp_ggrnam)
+PPDEF(pp_ggrgid)
+PPDEF(pp_ggrent)
+PPDEF(pp_sgrent)
+PPDEF(pp_egrent)
+PPDEF(pp_getlogin)
+PPDEF(pp_syscall)
+PPDEF(pp_lock)
+PPDEF(pp_threadsv)
diff --git a/contrib/perl5/pp_sys.c b/contrib/perl5/pp_sys.c
new file mode 100644
index 000000000000..2630e050b882
--- /dev/null
+++ b/contrib/perl5/pp_sys.c
@@ -0,0 +1,4595 @@
+/* pp_sys.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * But only a short way ahead its floor and the walls on either side were
+ * cloven by a great fissure, out of which the red glare came, now leaping
+ * up, now dying down into darkness; and all the while far below there was
+ * a rumour and a trouble as of great engines throbbing and labouring.
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+
+#ifdef HAS_SYSCALL
+#ifdef __cplusplus
+extern "C" int syscall(unsigned long,...);
+#endif
+#endif
+
+#ifdef I_SYS_WAIT
+# include <sys/wait.h>
+#endif
+
+#ifdef I_SYS_RESOURCE
+# include <sys/resource.h>
+#endif
+
+#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
+# include <sys/socket.h>
+# ifdef I_NETDB
+# include <netdb.h>
+# endif
+# ifndef ENOTSOCK
+# ifdef I_NET_ERRNO
+# include <net/errno.h>
+# endif
+# endif
+#endif
+
+#ifdef HAS_SELECT
+#ifdef I_SYS_SELECT
+#include <sys/select.h>
+#endif
+#endif
+
+/* XXX Configure test needed.
+ h_errno might not be a simple 'int', especially for multi-threaded
+ applications. HOST_NOT_FOUND is typically defined in <netdb.h>.
+*/
+#if defined(HOST_NOT_FOUND) && !defined(h_errno)
+extern int h_errno;
+#endif
+
+#ifdef HAS_PASSWD
+# ifdef I_PWD
+# include <pwd.h>
+# else
+ struct passwd *getpwnam _((char *));
+ struct passwd *getpwuid _((Uid_t));
+# endif
+# ifdef HAS_GETPWENT
+ struct passwd *getpwent _((void));
+# endif
+#endif
+
+#ifdef HAS_GROUP
+# ifdef I_GRP
+# include <grp.h>
+# else
+ struct group *getgrnam _((char *));
+ struct group *getgrgid _((Gid_t));
+# endif
+# ifdef HAS_GETGRENT
+ struct group *getgrent _((void));
+# endif
+#endif
+
+#ifdef I_UTIME
+# if defined(_MSC_VER) || defined(__MINGW32__)
+# include <sys/utime.h>
+# else
+# include <utime.h>
+# endif
+#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
+/* Put this after #includes because fork and vfork prototypes may conflict. */
+#ifndef HAS_VFORK
+# define vfork fork
+#endif
+
+/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
+#ifndef Sock_size_t
+# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
+# define Sock_size_t Size_t
+# else
+# define Sock_size_t int
+# endif
+#endif
+
+#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
+static int dooneliner _((char *cmd, char *filename));
+#endif
+
+#ifdef HAS_CHSIZE
+# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
+# undef my_chsize
+# endif
+# define my_chsize PerlLIO_chsize
+#endif
+
+#ifdef HAS_FLOCK
+# define FLOCK flock
+#else /* no flock() */
+
+ /* fcntl.h might not have been included, even if it exists, because
+ the current Configure only sets I_FCNTL if it's needed to pick up
+ the *_OK constants. Make sure it has been included before testing
+ the fcntl() locking constants. */
+# if defined(HAS_FCNTL) && !defined(I_FCNTL)
+# include <fcntl.h>
+# endif
+
+# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
+# define FLOCK fcntl_emulate_flock
+# define FCNTL_EMULATE_FLOCK
+# else /* no flock() or fcntl(F_SETLK,...) */
+# ifdef HAS_LOCKF
+# define FLOCK lockf_emulate_flock
+# define LOCKF_EMULATE_FLOCK
+# endif /* lockf */
+# endif /* no flock() or fcntl(F_SETLK,...) */
+
+# ifdef FLOCK
+ static int FLOCK _((int, int));
+
+ /*
+ * These are the flock() constants. Since this sytems doesn't have
+ * flock(), the values of the constants are probably not available.
+ */
+# ifndef LOCK_SH
+# define LOCK_SH 1
+# endif
+# ifndef LOCK_EX
+# define LOCK_EX 2
+# endif
+# ifndef LOCK_NB
+# define LOCK_NB 4
+# endif
+# ifndef LOCK_UN
+# define LOCK_UN 8
+# endif
+# endif /* emulating flock() */
+
+#endif /* no flock() */
+
+#ifndef MAXPATHLEN
+# ifdef PATH_MAX
+# define MAXPATHLEN PATH_MAX
+# else
+# define MAXPATHLEN 1024
+# endif
+#endif
+
+#define ZBTLEN 10
+static char zero_but_true[ZBTLEN + 1] = "0 but true";
+
+/* Pushy I/O. */
+
+PP(pp_backtick)
+{
+ djSP; dTARGET;
+ PerlIO *fp;
+ char *tmps = POPp;
+ I32 gimme = GIMME_V;
+
+ TAINT_PROPER("``");
+ fp = PerlProc_popen(tmps, "r");
+ if (fp) {
+ if (gimme == G_VOID) {
+ char tmpbuf[256];
+ while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
+ /*SUPPRESS 530*/
+ ;
+ }
+ else if (gimme == G_SCALAR) {
+ sv_setpv(TARG, ""); /* note that this preserves previous buffer */
+ while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
+ /*SUPPRESS 530*/
+ ;
+ XPUSHs(TARG);
+ SvTAINTED_on(TARG);
+ }
+ else {
+ SV *sv;
+
+ for (;;) {
+ sv = NEWSV(56, 79);
+ if (sv_gets(sv, fp, 0) == Nullch) {
+ SvREFCNT_dec(sv);
+ break;
+ }
+ XPUSHs(sv_2mortal(sv));
+ if (SvLEN(sv) - SvCUR(sv) > 20) {
+ SvLEN_set(sv, SvCUR(sv)+1);
+ Renew(SvPVX(sv), SvLEN(sv), char);
+ }
+ SvTAINTED_on(sv);
+ }
+ }
+ STATUS_NATIVE_SET(PerlProc_pclose(fp));
+ TAINT; /* "I believe that this is not gratuitous!" */
+ }
+ else {
+ STATUS_NATIVE_SET(-1);
+ if (gimme == G_SCALAR)
+ RETPUSHUNDEF;
+ }
+
+ RETURN;
+}
+
+PP(pp_glob)
+{
+ OP *result;
+ ENTER;
+
+#ifndef VMS
+ if (PL_tainting) {
+ /*
+ * The external globbing program may use things we can't control,
+ * so for security reasons we must assume the worst.
+ */
+ TAINT;
+ taint_proper(no_security, "glob");
+ }
+#endif /* !VMS */
+
+ SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
+ PL_last_in_gv = (GV*)*PL_stack_sp--;
+
+ SAVESPTR(PL_rs); /* This is not permanent, either. */
+ PL_rs = sv_2mortal(newSVpv("", 1));
+#ifndef DOSISH
+#ifndef CSH
+ *SvPVX(PL_rs) = '\n';
+#endif /* !CSH */
+#endif /* !DOSISH */
+
+ result = do_readline();
+ LEAVE;
+ return result;
+}
+
+#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);
+ return do_readline();
+}
+#endif
+
+PP(pp_rcatline)
+{
+ PL_last_in_gv = cGVOP->op_gv;
+ return do_readline();
+}
+
+PP(pp_warn)
+{
+ djSP; dMARK;
+ char *tmps;
+ if (SP - MARK != 1) {
+ dTARGET;
+ do_join(TARG, &PL_sv_no, MARK, SP);
+ tmps = SvPV(TARG, PL_na);
+ SP = MARK + 1;
+ }
+ else {
+ tmps = SvPV(TOPs, PL_na);
+ }
+ 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);
+ }
+ if (!tmps || !*tmps)
+ tmps = "Warning: something's wrong";
+ warn("%s", tmps);
+ RETSETYES;
+}
+
+PP(pp_die)
+{
+ djSP; dMARK;
+ char *tmps;
+ SV *tmpsv = Nullsv;
+ char *pat = "%s";
+ if (SP - MARK != 1) {
+ dTARGET;
+ do_join(TARG, &PL_sv_no, MARK, SP);
+ tmps = SvPV(TARG, PL_na);
+ SP = MARK + 1;
+ }
+ else {
+ tmpsv = TOPs;
+ tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, PL_na);
+ }
+ if (!tmps || !*tmps) {
+ SV *error = ERRSV;
+ (void)SvUPGRADE(error, SVt_PV);
+ if(tmpsv ? SvROK(tmpsv) : SvROK(error)) {
+ if(tmpsv)
+ SvSetSV(error,tmpsv);
+ else if(sv_isobject(error)) {
+ HV *stash = SvSTASH(SvRV(error));
+ GV *gv = gv_fetchmethod(stash, "PROPAGATE");
+ if (gv) {
+ SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
+ SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
+ EXTEND(SP, 3);
+ PUSHMARK(SP);
+ PUSHs(error);
+ PUSHs(file);
+ PUSHs(line);
+ PUTBACK;
+ perl_call_sv((SV*)GvCV(gv),
+ G_SCALAR|G_EVAL|G_KEEPERR);
+ sv_setsv(error,*PL_stack_sp--);
+ }
+ }
+ pat = Nullch;
+ }
+ else {
+ if (SvPOK(error) && SvCUR(error))
+ sv_catpv(error, "\t...propagated");
+ tmps = SvPV(error, PL_na);
+ }
+ }
+ if (!tmps || !*tmps)
+ tmps = "Died";
+ DIE(pat, tmps);
+}
+
+/* I/O. */
+
+PP(pp_open)
+{
+ djSP; dTARGET;
+ GV *gv;
+ SV *sv;
+ char *tmps;
+ STRLEN len;
+
+ if (MAXARG > 1)
+ sv = POPs;
+ if (!isGV(TOPs))
+ DIE(no_usym, "filehandle");
+ if (MAXARG <= 1)
+ sv = GvSV(TOPs);
+ gv = (GV*)POPs;
+ if (!isGV(gv))
+ DIE(no_usym, "filehandle");
+ if (GvIOp(gv))
+ IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
+ tmps = SvPV(sv, len);
+ if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
+ PUSHi( (I32)PL_forkprocess );
+ else if (PL_forkprocess == 0) /* we are a new child */
+ PUSHi(0);
+ else
+ RETPUSHUNDEF;
+ RETURN;
+}
+
+PP(pp_close)
+{
+ djSP;
+ GV *gv;
+ MAGIC *mg;
+
+ if (MAXARG == 0)
+ gv = PL_defoutgv;
+ else
+ gv = (GV*)POPs;
+
+ if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+ PUSHMARK(SP);
+ XPUSHs(mg->mg_obj);
+ PUTBACK;
+ ENTER;
+ perl_call_method("CLOSE", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ RETURN;
+ }
+ EXTEND(SP, 1);
+ PUSHs(boolSV(do_close(gv, TRUE)));
+ RETURN;
+}
+
+PP(pp_pipe_op)
+{
+ djSP;
+#ifdef HAS_PIPE
+ GV *rgv;
+ GV *wgv;
+ register IO *rstio;
+ register IO *wstio;
+ int fd[2];
+
+ wgv = (GV*)POPs;
+ rgv = (GV*)POPs;
+
+ if (!rgv || !wgv)
+ goto badexit;
+
+ if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
+ DIE(no_usym, "filehandle");
+ rstio = GvIOn(rgv);
+ wstio = GvIOn(wgv);
+
+ if (IoIFP(rstio))
+ do_close(rgv, FALSE);
+ if (IoIFP(wstio))
+ do_close(wgv, FALSE);
+
+ if (PerlProc_pipe(fd) < 0)
+ goto badexit;
+
+ IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
+ IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
+ IoIFP(wstio) = IoOFP(wstio);
+ IoTYPE(rstio) = '<';
+ IoTYPE(wstio) = '>';
+
+ if (!IoIFP(rstio) || !IoOFP(wstio)) {
+ if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
+ else PerlLIO_close(fd[0]);
+ if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
+ else PerlLIO_close(fd[1]);
+ goto badexit;
+ }
+
+ RETPUSHYES;
+
+badexit:
+ RETPUSHUNDEF;
+#else
+ DIE(no_func, "pipe");
+#endif
+}
+
+PP(pp_fileno)
+{
+ djSP; dTARGET;
+ GV *gv;
+ IO *io;
+ PerlIO *fp;
+ if (MAXARG < 1)
+ RETPUSHUNDEF;
+ gv = (GV*)POPs;
+ if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
+ RETPUSHUNDEF;
+ PUSHi(PerlIO_fileno(fp));
+ RETURN;
+}
+
+PP(pp_umask)
+{
+ djSP; dTARGET;
+ int anum;
+
+#ifdef HAS_UMASK
+ if (MAXARG < 1) {
+ anum = PerlLIO_umask(0);
+ (void)PerlLIO_umask(anum);
+ }
+ else
+ anum = PerlLIO_umask(POPi);
+ TAINT_PROPER("umask");
+ XPUSHi(anum);
+#else
+ /* Only DIE if trying to restrict permissions on `user' (self).
+ * Otherwise it's harmless and more useful to just return undef
+ * since 'group' and 'other' concepts probably don't exist here. */
+ if (MAXARG >= 1 && (POPi & 0700))
+ DIE("umask not implemented");
+ XPUSHs(&PL_sv_undef);
+#endif
+ RETURN;
+}
+
+PP(pp_binmode)
+{
+ djSP;
+ GV *gv;
+ IO *io;
+ PerlIO *fp;
+
+ if (MAXARG < 1)
+ RETPUSHUNDEF;
+
+ gv = (GV*)POPs;
+
+ EXTEND(SP, 1);
+ if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
+ RETPUSHUNDEF;
+
+ if (do_binmode(fp,IoTYPE(io),TRUE))
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+}
+
+
+PP(pp_tie)
+{
+ djSP;
+ dMARK;
+ SV *varsv;
+ HV* stash;
+ GV *gv;
+ SV *sv;
+ I32 markoff = MARK - PL_stack_base;
+ char *methname;
+ int how = 'P';
+ U32 items;
+
+ varsv = *++MARK;
+ switch(SvTYPE(varsv)) {
+ case SVt_PVHV:
+ methname = "TIEHASH";
+ break;
+ case SVt_PVAV:
+ methname = "TIEARRAY";
+ break;
+ case SVt_PVGV:
+ methname = "TIEHANDLE";
+ how = 'q';
+ break;
+ default:
+ methname = "TIESCALAR";
+ how = 'q';
+ break;
+ }
+ items = SP - MARK++;
+ if (sv_isobject(*MARK)) {
+ ENTER;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP,items);
+ while (items--)
+ PUSHs(*MARK++);
+ PUTBACK;
+ perl_call_method(methname, G_SCALAR);
+ }
+ else {
+ /* Not clear why we don't call perl_call_method here too.
+ * perhaps to get different error message ?
+ */
+ 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));
+ }
+ ENTER;
+ PUSHSTACKi(PERLSI_MAGIC);
+ PUSHMARK(SP);
+ EXTEND(SP,items);
+ while (items--)
+ PUSHs(*MARK++);
+ PUTBACK;
+ perl_call_sv((SV*)GvCV(gv), G_SCALAR);
+ }
+ SPAGAIN;
+
+ sv = TOPs;
+ POPSTACK;
+ if (sv_isobject(sv)) {
+ sv_unmagic(varsv, how);
+ sv_magic(varsv, sv, how, Nullch, 0);
+ }
+ LEAVE;
+ SP = PL_stack_base + markoff;
+ PUSHs(sv);
+ RETURN;
+}
+
+PP(pp_untie)
+{
+ djSP;
+ SV * sv ;
+
+ sv = POPs;
+
+ if (PL_dowarn) {
+ MAGIC * mg ;
+ if (SvMAGICAL(sv)) {
+ if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
+ mg = mg_find(sv, 'P') ;
+ else
+ mg = mg_find(sv, 'q') ;
+
+ if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
+ warn("untie attempted while %lu inner references still exist",
+ (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
+ }
+ }
+
+ if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
+ sv_unmagic(sv, 'P');
+ else
+ sv_unmagic(sv, 'q');
+ RETPUSHYES;
+}
+
+PP(pp_tied)
+{
+ djSP;
+ SV * sv ;
+ MAGIC * mg ;
+
+ sv = POPs;
+ if (SvMAGICAL(sv)) {
+ if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
+ mg = mg_find(sv, 'P') ;
+ else
+ mg = mg_find(sv, 'q') ;
+
+ if (mg) {
+ PUSHs(sv_2mortal(newSVsv(mg->mg_obj))) ;
+ RETURN ;
+ }
+ }
+ RETPUSHUNDEF;
+}
+
+PP(pp_dbmopen)
+{
+ djSP;
+ HV *hv;
+ dPOPPOPssrl;
+ HV* stash;
+ GV *gv;
+ SV *sv;
+
+ hv = (HV*)POPs;
+
+ sv = sv_mortalcopy(&PL_sv_no);
+ sv_setpv(sv, "AnyDBM_File");
+ stash = gv_stashsv(sv, FALSE);
+ if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
+ PUTBACK;
+ perl_require_pv("AnyDBM_File.pm");
+ SPAGAIN;
+ if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
+ DIE("No dbm on this machine");
+ }
+
+ ENTER;
+ PUSHMARK(SP);
+
+ EXTEND(SP, 5);
+ PUSHs(sv);
+ PUSHs(left);
+ if (SvIV(right))
+ PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
+ else
+ PUSHs(sv_2mortal(newSViv(O_RDWR)));
+ PUSHs(right);
+ PUTBACK;
+ perl_call_sv((SV*)GvCV(gv), G_SCALAR);
+ SPAGAIN;
+
+ if (!sv_isobject(TOPs)) {
+ SP--;
+ PUSHMARK(SP);
+ PUSHs(sv);
+ PUSHs(left);
+ PUSHs(sv_2mortal(newSViv(O_RDONLY)));
+ PUSHs(right);
+ PUTBACK;
+ perl_call_sv((SV*)GvCV(gv), G_SCALAR);
+ SPAGAIN;
+ }
+
+ if (sv_isobject(TOPs)) {
+ sv_unmagic((SV *) hv, 'P');
+ sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
+ }
+ LEAVE;
+ RETURN;
+}
+
+PP(pp_dbmclose)
+{
+ return pp_untie(ARGS);
+}
+
+PP(pp_sselect)
+{
+ djSP; dTARGET;
+#ifdef HAS_SELECT
+ register I32 i;
+ register I32 j;
+ register char *s;
+ register SV *sv;
+ double value;
+ I32 maxlen = 0;
+ I32 nfound;
+ struct timeval timebuf;
+ struct timeval *tbuf = &timebuf;
+ I32 growsize;
+ char *fd_sets[4];
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ I32 masksize;
+ I32 offset;
+ I32 k;
+
+# if BYTEORDER & 0xf0000
+# define ORDERBYTE (0x88888888 - BYTEORDER)
+# else
+# define ORDERBYTE (0x4444 - BYTEORDER)
+# endif
+
+#endif
+
+ SP -= 4;
+ for (i = 1; i <= 3; i++) {
+ if (!SvPOK(SP[i]))
+ continue;
+ j = SvCUR(SP[i]);
+ if (maxlen < j)
+ maxlen = j;
+ }
+
+#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+/* XXX Configure test needed. */
+#if defined(__linux__) || defined(OS2) || defined(NeXT) || defined(__osf__) || defined(sun)
+ growsize = sizeof(fd_set);
+#else
+ growsize = maxlen; /* little endians can use vecs directly */
+#endif
+#else
+#ifdef NFDBITS
+
+#ifndef NBBY
+#define NBBY 8
+#endif
+
+ masksize = NFDBITS / NBBY;
+#else
+ masksize = sizeof(long); /* documented int, everyone seems to use long */
+#endif
+ growsize = maxlen + (masksize - (maxlen % masksize));
+ Zero(&fd_sets[0], 4, char*);
+#endif
+
+ sv = SP[4];
+ if (SvOK(sv)) {
+ value = SvNV(sv);
+ if (value < 0.0)
+ value = 0.0;
+ timebuf.tv_sec = (long)value;
+ value -= (double)timebuf.tv_sec;
+ timebuf.tv_usec = (long)(value * 1000000.0);
+ }
+ else
+ tbuf = Null(struct timeval*);
+
+ for (i = 1; i <= 3; i++) {
+ sv = SP[i];
+ if (!SvOK(sv)) {
+ fd_sets[i] = 0;
+ continue;
+ }
+ else if (!SvPOK(sv))
+ SvPV_force(sv,PL_na); /* force string conversion */
+ j = SvLEN(sv);
+ if (j < growsize) {
+ Sv_Grow(sv, growsize);
+ }
+ j = SvCUR(sv);
+ s = SvPVX(sv) + j;
+ while (++j <= growsize) {
+ *s++ = '\0';
+ }
+
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ s = SvPVX(sv);
+ New(403, fd_sets[i], growsize, char);
+ for (offset = 0; offset < growsize; offset += masksize) {
+ for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
+ fd_sets[i][j+offset] = s[(k % masksize) + offset];
+ }
+#else
+ fd_sets[i] = SvPVX(sv);
+#endif
+ }
+
+ nfound = PerlSock_select(
+ maxlen * 8,
+ (Select_fd_set_t) fd_sets[1],
+ (Select_fd_set_t) fd_sets[2],
+ (Select_fd_set_t) fd_sets[3],
+ tbuf);
+ for (i = 1; i <= 3; i++) {
+ if (fd_sets[i]) {
+ sv = SP[i];
+#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ s = SvPVX(sv);
+ for (offset = 0; offset < growsize; offset += masksize) {
+ for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
+ s[(k % masksize) + offset] = fd_sets[i][j+offset];
+ }
+ Safefree(fd_sets[i]);
+#endif
+ SvSETMAGIC(sv);
+ }
+ }
+
+ PUSHi(nfound);
+ if (GIMME == G_ARRAY && tbuf) {
+ value = (double)(timebuf.tv_sec) +
+ (double)(timebuf.tv_usec) / 1000000.0;
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setnv(sv, value);
+ }
+ RETURN;
+#else
+ DIE("select not implemented");
+#endif
+}
+
+void
+setdefout(GV *gv)
+{
+ dTHR;
+ if (gv)
+ (void)SvREFCNT_inc(gv);
+ if (PL_defoutgv)
+ SvREFCNT_dec(PL_defoutgv);
+ PL_defoutgv = gv;
+}
+
+PP(pp_select)
+{
+ djSP; dTARGET;
+ GV *newdefout, *egv;
+ HV *hv;
+
+ newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
+
+ egv = GvEGV(PL_defoutgv);
+ if (!egv)
+ egv = PL_defoutgv;
+ hv = GvSTASH(egv);
+ if (! hv)
+ XPUSHs(&PL_sv_undef);
+ else {
+ GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
+ if (gvp && *gvp == egv) {
+ gv_efullname3(TARG, PL_defoutgv, Nullch);
+ XPUSHTARG;
+ }
+ else {
+ XPUSHs(sv_2mortal(newRV((SV*)egv)));
+ }
+ }
+
+ if (newdefout) {
+ if (!GvIO(newdefout))
+ gv_IOadd(newdefout);
+ setdefout(newdefout);
+ }
+
+ RETURN;
+}
+
+PP(pp_getc)
+{
+ djSP; dTARGET;
+ GV *gv;
+ MAGIC *mg;
+
+ if (MAXARG <= 0)
+ gv = PL_stdingv;
+ else
+ gv = (GV*)POPs;
+ if (!gv)
+ gv = PL_argvgv;
+
+ if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+ I32 gimme = GIMME_V;
+ PUSHMARK(SP);
+ XPUSHs(mg->mg_obj);
+ PUTBACK;
+ ENTER;
+ perl_call_method("GETC", gimme);
+ LEAVE;
+ SPAGAIN;
+ if (gimme == G_SCALAR)
+ SvSetMagicSV_nosteal(TARG, TOPs);
+ RETURN;
+ }
+ if (!gv || do_eof(gv)) /* make sure we have fp with something */
+ RETPUSHUNDEF;
+ TAINT;
+ sv_setpv(TARG, " ");
+ *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
+ PUSHTARG;
+ RETURN;
+}
+
+PP(pp_read)
+{
+ return pp_sysread(ARGS);
+}
+
+STATIC OP *
+doform(CV *cv, GV *gv, OP *retop)
+{
+ dTHR;
+ register PERL_CONTEXT *cx;
+ I32 gimme = GIMME_V;
+ AV* padlist = CvPADLIST(cv);
+ SV** svp = AvARRAY(padlist);
+
+ ENTER;
+ SAVETMPS;
+
+ push_return(retop);
+ PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
+ PUSHFORMAT(cx);
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)svp[1]);
+
+ setdefout(gv); /* locally select filehandle so $% et al work */
+ return CvSTART(cv);
+}
+
+PP(pp_enterwrite)
+{
+ djSP;
+ register GV *gv;
+ register IO *io;
+ GV *fgv;
+ CV *cv;
+
+ if (MAXARG == 0)
+ gv = PL_defoutgv;
+ else {
+ gv = (GV*)POPs;
+ if (!gv)
+ gv = PL_defoutgv;
+ }
+ EXTEND(SP, 1);
+ io = GvIO(gv);
+ if (!io) {
+ RETPUSHNO;
+ }
+ if (IoFMT_GV(io))
+ fgv = IoFMT_GV(io);
+ else
+ fgv = gv;
+
+ cv = GvFORM(fgv);
+ if (!cv) {
+ if (fgv) {
+ SV *tmpsv = sv_newmortal();
+ gv_efullname3(tmpsv, fgv, Nullch);
+ DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
+ }
+ DIE("Not a format reference");
+ }
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+
+ IoFLAGS(io) &= ~IOf_DIDTOP;
+ return doform(cv,gv,PL_op->op_next);
+}
+
+PP(pp_leavewrite)
+{
+ djSP;
+ GV *gv = cxstack[cxstack_ix].blk_sub.gv;
+ register IO *io = GvIOp(gv);
+ PerlIO *ofp = IoOFP(io);
+ PerlIO *fp;
+ SV **newsp;
+ I32 gimme;
+ register PERL_CONTEXT *cx;
+
+ DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
+ (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
+ if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
+ PL_formtarget != PL_toptarget)
+ {
+ GV *fgv;
+ CV *cv;
+ if (!IoTOP_GV(io)) {
+ GV *topgv;
+ SV *topname;
+
+ if (!IoTOP_NAME(io)) {
+ if (!IoFMT_NAME(io))
+ IoFMT_NAME(io) = savepv(GvNAME(gv));
+ topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
+ topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
+ if ((topgv && GvFORM(topgv)) ||
+ !gv_fetchpv("top",FALSE,SVt_PVFM))
+ IoTOP_NAME(io) = savepv(SvPVX(topname));
+ else
+ IoTOP_NAME(io) = savepv("top");
+ }
+ topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
+ if (!topgv || !GvFORM(topgv)) {
+ IoLINES_LEFT(io) = 100000000;
+ goto forget_top;
+ }
+ IoTOP_GV(io) = topgv;
+ }
+ if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
+ I32 lines = IoLINES_LEFT(io);
+ char *s = SvPVX(PL_formtarget);
+ if (lines <= 0) /* Yow, header didn't even fit!!! */
+ goto forget_top;
+ while (lines-- > 0) {
+ s = strchr(s, '\n');
+ if (!s)
+ break;
+ s++;
+ }
+ if (s) {
+ PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
+ sv_chop(PL_formtarget, s);
+ FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
+ }
+ }
+ if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
+ PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
+ IoLINES_LEFT(io) = IoPAGE_LEN(io);
+ IoPAGE(io)++;
+ PL_formtarget = PL_toptarget;
+ IoFLAGS(io) |= IOf_DIDTOP;
+ fgv = IoTOP_GV(io);
+ if (!fgv)
+ DIE("bad top format reference");
+ cv = GvFORM(fgv);
+ if (!cv) {
+ SV *tmpsv = sv_newmortal();
+ gv_efullname3(tmpsv, fgv, Nullch);
+ DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
+ }
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ return doform(cv,gv,PL_op);
+ }
+
+ forget_top:
+ POPBLOCK(cx,PL_curpm);
+ POPFORMAT(cx);
+ LEAVE;
+
+ fp = IoOFP(io);
+ if (!fp) {
+ if (PL_dowarn) {
+ if (IoIFP(io))
+ warn("Filehandle only opened for input");
+ else
+ warn("Write on closed filehandle");
+ }
+ PUSHs(&PL_sv_no);
+ }
+ else {
+ if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
+ if (PL_dowarn)
+ warn("page overflow");
+ }
+ if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
+ PerlIO_error(fp))
+ PUSHs(&PL_sv_no);
+ else {
+ FmLINES(PL_formtarget) = 0;
+ SvCUR_set(PL_formtarget, 0);
+ *SvEND(PL_formtarget) = '\0';
+ if (IoFLAGS(io) & IOf_FLUSH)
+ (void)PerlIO_flush(fp);
+ PUSHs(&PL_sv_yes);
+ }
+ }
+ PL_formtarget = PL_bodytarget;
+ PUTBACK;
+ return pop_return();
+}
+
+PP(pp_prtf)
+{
+ djSP; dMARK; dORIGMARK;
+ GV *gv;
+ IO *io;
+ PerlIO *fp;
+ SV *sv;
+ MAGIC *mg;
+
+ if (PL_op->op_flags & OPf_STACKED)
+ gv = (GV*)*++MARK;
+ else
+ gv = PL_defoutgv;
+
+ if (SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+ if (MARK == ORIGMARK) {
+ MEXTEND(SP, 1);
+ ++MARK;
+ Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
+ ++SP;
+ }
+ PUSHMARK(MARK - 1);
+ *MARK = mg->mg_obj;
+ PUTBACK;
+ ENTER;
+ perl_call_method("PRINTF", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ MARK = ORIGMARK + 1;
+ *MARK = *SP;
+ SP = MARK;
+ RETURN;
+ }
+
+ sv = NEWSV(0,0);
+ if (!(io = GvIO(gv))) {
+ if (PL_dowarn) {
+ gv_fullname3(sv, gv, Nullch);
+ warn("Filehandle %s never opened", SvPV(sv,PL_na));
+ }
+ SETERRNO(EBADF,RMS$_IFI);
+ goto just_say_no;
+ }
+ else if (!(fp = IoOFP(io))) {
+ if (PL_dowarn) {
+ gv_fullname3(sv, gv, Nullch);
+ if (IoIFP(io))
+ warn("Filehandle %s opened only for input", SvPV(sv,PL_na));
+ else
+ warn("printf on closed filehandle %s", SvPV(sv,PL_na));
+ }
+ SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
+ goto just_say_no;
+ }
+ else {
+#ifdef USE_LOCALE_NUMERIC
+ if (PL_op->op_private & OPpLOCALE)
+ SET_NUMERIC_LOCAL();
+ else
+ SET_NUMERIC_STANDARD();
+#endif
+ do_sprintf(sv, SP - MARK, MARK + 1);
+ if (!do_print(sv, fp))
+ goto just_say_no;
+
+ if (IoFLAGS(io) & IOf_FLUSH)
+ if (PerlIO_flush(fp) == EOF)
+ goto just_say_no;
+ }
+ SvREFCNT_dec(sv);
+ SP = ORIGMARK;
+ PUSHs(&PL_sv_yes);
+ RETURN;
+
+ just_say_no:
+ SvREFCNT_dec(sv);
+ SP = ORIGMARK;
+ PUSHs(&PL_sv_undef);
+ RETURN;
+}
+
+PP(pp_sysopen)
+{
+ djSP;
+ GV *gv;
+ SV *sv;
+ char *tmps;
+ STRLEN len;
+ int mode, perm;
+
+ if (MAXARG > 3)
+ perm = POPi;
+ else
+ perm = 0666;
+ mode = POPi;
+ sv = POPs;
+ gv = (GV *)POPs;
+
+ tmps = SvPV(sv, len);
+ if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
+ IoLINES(GvIOp(gv)) = 0;
+ PUSHs(&PL_sv_yes);
+ }
+ else {
+ PUSHs(&PL_sv_undef);
+ }
+ RETURN;
+}
+
+PP(pp_sysread)
+{
+ djSP; dMARK; dORIGMARK; dTARGET;
+ int offset;
+ GV *gv;
+ IO *io;
+ char *buffer;
+ SSize_t length;
+ Sock_size_t bufsize;
+ SV *bufsv;
+ STRLEN blen;
+ MAGIC *mg;
+
+ gv = (GV*)*++MARK;
+ if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
+ SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q')))
+ {
+ SV *sv;
+
+ PUSHMARK(MARK-1);
+ *MARK = mg->mg_obj;
+ ENTER;
+ perl_call_method("READ", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ sv = POPs;
+ SP = ORIGMARK;
+ PUSHs(sv);
+ RETURN;
+ }
+
+ if (!gv)
+ goto say_undef;
+ bufsv = *++MARK;
+ if (! SvOK(bufsv))
+ sv_setpvn(bufsv, "", 0);
+ buffer = SvPV_force(bufsv, blen);
+ length = SvIVx(*++MARK);
+ if (length < 0)
+ DIE("Negative length");
+ SETERRNO(0,0);
+ if (MARK < SP)
+ offset = SvIVx(*++MARK);
+ else
+ offset = 0;
+ io = GvIO(gv);
+ if (!io || !IoIFP(io))
+ goto say_undef;
+#ifdef HAS_SOCKET
+ if (PL_op->op_type == OP_RECV) {
+ char namebuf[MAXPATHLEN];
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
+ bufsize = sizeof (struct sockaddr_in);
+#else
+ bufsize = sizeof namebuf;
+#endif
+ buffer = SvGROW(bufsv, length+1);
+ /* 'offset' means 'flags' here */
+ length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+ (struct sockaddr *)namebuf, &bufsize);
+ if (length < 0)
+ RETPUSHUNDEF;
+ SvCUR_set(bufsv, length);
+ *SvEND(bufsv) = '\0';
+ (void)SvPOK_only(bufsv);
+ SvSETMAGIC(bufsv);
+ /* This should not be marked tainted if the fp is marked clean */
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(bufsv);
+ SP = ORIGMARK;
+ sv_setpvn(TARG, namebuf, bufsize);
+ PUSHs(TARG);
+ RETURN;
+ }
+#else
+ if (PL_op->op_type == OP_RECV)
+ DIE(no_sock_func, "recv");
+#endif
+ if (offset < 0) {
+ if (-offset > blen)
+ DIE("Offset outside string");
+ offset += blen;
+ }
+ bufsize = SvCUR(bufsv);
+ buffer = SvGROW(bufsv, length+offset+1);
+ if (offset > bufsize) { /* Zero any newly allocated space */
+ Zero(buffer+bufsize, offset-bufsize, char);
+ }
+ if (PL_op->op_type == OP_SYSREAD) {
+ length = PerlLIO_read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
+ }
+ else
+#ifdef HAS_SOCKET__bad_code_maybe
+ if (IoTYPE(io) == 's') {
+ char namebuf[MAXPATHLEN];
+#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
+ bufsize = sizeof (struct sockaddr_in);
+#else
+ bufsize = sizeof namebuf;
+#endif
+ length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
+ (struct sockaddr *)namebuf, &bufsize);
+ }
+ else
+#endif
+ {
+ length = PerlIO_read(IoIFP(io), buffer+offset, length);
+ /* fread() returns 0 on both error and EOF */
+ if (length == 0 && PerlIO_error(IoIFP(io)))
+ length = -1;
+ }
+ if (length < 0)
+ goto say_undef;
+ SvCUR_set(bufsv, length+offset);
+ *SvEND(bufsv) = '\0';
+ (void)SvPOK_only(bufsv);
+ SvSETMAGIC(bufsv);
+ /* This should not be marked tainted if the fp is marked clean */
+ if (!(IoFLAGS(io) & IOf_UNTAINT))
+ SvTAINTED_on(bufsv);
+ SP = ORIGMARK;
+ PUSHi(length);
+ RETURN;
+
+ say_undef:
+ SP = ORIGMARK;
+ RETPUSHUNDEF;
+}
+
+PP(pp_syswrite)
+{
+ return pp_send(ARGS);
+}
+
+PP(pp_send)
+{
+ djSP; dMARK; dORIGMARK; dTARGET;
+ GV *gv;
+ IO *io;
+ int offset;
+ SV *bufsv;
+ char *buffer;
+ int length;
+ STRLEN blen;
+ MAGIC *mg;
+
+ gv = (GV*)*++MARK;
+ if (PL_op->op_type == OP_SYSWRITE &&
+ SvRMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q')))
+ {
+ SV *sv;
+
+ PUSHMARK(MARK-1);
+ *MARK = mg->mg_obj;
+ ENTER;
+ perl_call_method("WRITE", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ sv = POPs;
+ SP = ORIGMARK;
+ PUSHs(sv);
+ RETURN;
+ }
+ if (!gv)
+ goto say_undef;
+ bufsv = *++MARK;
+ buffer = SvPV(bufsv, blen);
+ length = SvIVx(*++MARK);
+ if (length < 0)
+ DIE("Negative length");
+ SETERRNO(0,0);
+ io = GvIO(gv);
+ if (!io || !IoIFP(io)) {
+ length = -1;
+ if (PL_dowarn) {
+ if (PL_op->op_type == OP_SYSWRITE)
+ warn("Syswrite on closed filehandle");
+ else
+ warn("Send on closed socket");
+ }
+ }
+ else if (PL_op->op_type == OP_SYSWRITE) {
+ if (MARK < SP) {
+ offset = SvIVx(*++MARK);
+ if (offset < 0) {
+ if (-offset > blen)
+ DIE("Offset outside string");
+ offset += blen;
+ } else if (offset >= blen && blen > 0)
+ DIE("Offset outside string");
+ } else
+ offset = 0;
+ if (length > blen - offset)
+ length = blen - offset;
+ length = PerlLIO_write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
+ }
+#ifdef HAS_SOCKET
+ else if (SP > MARK) {
+ char *sockbuf;
+ STRLEN mlen;
+ sockbuf = SvPVx(*++MARK, mlen);
+ length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
+ (struct sockaddr *)sockbuf, mlen);
+ }
+ else
+ length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
+
+#else
+ else
+ DIE(no_sock_func, "send");
+#endif
+ if (length < 0)
+ goto say_undef;
+ SP = ORIGMARK;
+ PUSHi(length);
+ RETURN;
+
+ say_undef:
+ SP = ORIGMARK;
+ RETPUSHUNDEF;
+}
+
+PP(pp_recv)
+{
+ return pp_sysread(ARGS);
+}
+
+PP(pp_eof)
+{
+ djSP;
+ GV *gv;
+
+ if (MAXARG <= 0)
+ gv = PL_last_in_gv;
+ else
+ gv = PL_last_in_gv = (GV*)POPs;
+ PUSHs(boolSV(!gv || do_eof(gv)));
+ RETURN;
+}
+
+PP(pp_tell)
+{
+ djSP; dTARGET;
+ GV *gv;
+
+ if (MAXARG <= 0)
+ gv = PL_last_in_gv;
+ else
+ gv = PL_last_in_gv = (GV*)POPs;
+ PUSHi( do_tell(gv) );
+ RETURN;
+}
+
+PP(pp_seek)
+{
+ return pp_sysseek(ARGS);
+}
+
+PP(pp_sysseek)
+{
+ djSP;
+ GV *gv;
+ int whence = POPi;
+ long offset = POPl;
+
+ gv = PL_last_in_gv = (GV*)POPs;
+ if (PL_op->op_type == OP_SEEK)
+ PUSHs(boolSV(do_seek(gv, offset, whence)));
+ else {
+ long n = do_sysseek(gv, offset, whence);
+ PUSHs((n < 0) ? &PL_sv_undef
+ : sv_2mortal(n ? newSViv((IV)n)
+ : newSVpv(zero_but_true, ZBTLEN)));
+ }
+ RETURN;
+}
+
+PP(pp_truncate)
+{
+ djSP;
+ Off_t len = (Off_t)POPn;
+ int result = 1;
+ GV *tmpgv;
+
+ 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);
+ do_ftruncate:
+ TAINT_PROPER("truncate");
+ if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
+#ifdef HAS_TRUNCATE
+ ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+#else
+ my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+#endif
+ result = 0;
+ }
+ else {
+ SV *sv = POPs;
+ char *name;
+
+ if (SvTYPE(sv) == SVt_PVGV) {
+ tmpgv = (GV*)sv; /* *main::FRED for example */
+ goto do_ftruncate;
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
+ goto do_ftruncate;
+ }
+
+ name = SvPV(sv, PL_na);
+ TAINT_PROPER("truncate");
+#ifdef HAS_TRUNCATE
+ if (truncate(name, len) < 0)
+ result = 0;
+#else
+ {
+ int tmpfd;
+ if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
+ result = 0;
+ else {
+ if (my_chsize(tmpfd, len) < 0)
+ result = 0;
+ PerlLIO_close(tmpfd);
+ }
+ }
+#endif
+ }
+
+ if (result)
+ RETPUSHYES;
+ if (!errno)
+ SETERRNO(EBADF,RMS$_IFI);
+ RETPUSHUNDEF;
+#else
+ DIE("truncate not implemented");
+#endif
+}
+
+PP(pp_fcntl)
+{
+ return pp_ioctl(ARGS);
+}
+
+PP(pp_ioctl)
+{
+ djSP; dTARGET;
+ SV *argsv = POPs;
+ unsigned int func = U_I(POPn);
+ int optype = PL_op->op_type;
+ char *s;
+ IV retval;
+ GV *gv = (GV*)POPs;
+ IO *io = GvIOn(gv);
+
+ if (!io || !argsv || !IoIFP(io)) {
+ SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
+ RETPUSHUNDEF;
+ }
+
+ if (SvPOK(argsv) || !SvNIOK(argsv)) {
+ STRLEN len;
+ STRLEN need;
+ s = SvPV_force(argsv, len);
+ need = IOCPARM_LEN(func);
+ if (len < need) {
+ s = Sv_Grow(argsv, need + 1);
+ SvCUR_set(argsv, need);
+ }
+
+ s[SvCUR(argsv)] = 17; /* a little sanity check here */
+ }
+ else {
+ retval = SvIV(argsv);
+ s = (char*)retval; /* ouch */
+ }
+
+ TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
+
+ if (optype == OP_IOCTL)
+#ifdef HAS_IOCTL
+ retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
+#else
+ DIE("ioctl is not implemented");
+#endif
+ else
+#ifdef HAS_FCNTL
+#if defined(OS2) && defined(__EMX__)
+ retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
+#else
+ retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
+#endif
+#else
+ DIE("fcntl is not implemented");
+#endif
+
+ if (SvPOK(argsv)) {
+ if (s[SvCUR(argsv)] != 17)
+ DIE("Possible memory corruption: %s overflowed 3rd argument",
+ op_name[optype]);
+ s[SvCUR(argsv)] = 0; /* put our null back */
+ SvSETMAGIC(argsv); /* Assume it has changed */
+ }
+
+ if (retval == -1)
+ RETPUSHUNDEF;
+ if (retval != 0) {
+ PUSHi(retval);
+ }
+ else {
+ PUSHp(zero_but_true, ZBTLEN);
+ }
+ RETURN;
+}
+
+PP(pp_flock)
+{
+ djSP; dTARGET;
+ I32 value;
+ int argtype;
+ GV *gv;
+ PerlIO *fp;
+
+#ifdef FLOCK
+ argtype = POPi;
+ if (MAXARG <= 0)
+ gv = PL_last_in_gv;
+ else
+ gv = (GV*)POPs;
+ if (gv && GvIO(gv))
+ fp = IoIFP(GvIOp(gv));
+ else
+ fp = Nullfp;
+ if (fp) {
+ (void)PerlIO_flush(fp);
+ value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
+ }
+ else
+ value = 0;
+ PUSHi(value);
+ RETURN;
+#else
+ DIE(no_func, "flock()");
+#endif
+}
+
+/* Sockets. */
+
+PP(pp_socket)
+{
+ djSP;
+#ifdef HAS_SOCKET
+ GV *gv;
+ register IO *io;
+ int protocol = POPi;
+ int type = POPi;
+ int domain = POPi;
+ int fd;
+
+ gv = (GV*)POPs;
+
+ if (!gv) {
+ SETERRNO(EBADF,LIB$_INVARG);
+ RETPUSHUNDEF;
+ }
+
+ io = GvIOn(gv);
+ if (IoIFP(io))
+ do_close(gv, FALSE);
+
+ TAINT_PROPER("socket");
+ fd = PerlSock_socket(domain, type, protocol);
+ if (fd < 0)
+ RETPUSHUNDEF;
+ IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
+ IoOFP(io) = PerlIO_fdopen(fd, "w");
+ IoTYPE(io) = 's';
+ if (!IoIFP(io) || !IoOFP(io)) {
+ if (IoIFP(io)) PerlIO_close(IoIFP(io));
+ if (IoOFP(io)) PerlIO_close(IoOFP(io));
+ if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
+ RETPUSHUNDEF;
+ }
+
+ RETPUSHYES;
+#else
+ DIE(no_sock_func, "socket");
+#endif
+}
+
+PP(pp_sockpair)
+{
+ djSP;
+#ifdef HAS_SOCKETPAIR
+ GV *gv1;
+ GV *gv2;
+ register IO *io1;
+ register IO *io2;
+ int protocol = POPi;
+ int type = POPi;
+ int domain = POPi;
+ int fd[2];
+
+ gv2 = (GV*)POPs;
+ gv1 = (GV*)POPs;
+ if (!gv1 || !gv2)
+ RETPUSHUNDEF;
+
+ io1 = GvIOn(gv1);
+ io2 = GvIOn(gv2);
+ if (IoIFP(io1))
+ do_close(gv1, FALSE);
+ if (IoIFP(io2))
+ do_close(gv2, FALSE);
+
+ TAINT_PROPER("socketpair");
+ if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
+ RETPUSHUNDEF;
+ IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
+ IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
+ IoTYPE(io1) = 's';
+ IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
+ IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
+ IoTYPE(io2) = 's';
+ if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
+ if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
+ if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
+ if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
+ if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
+ if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
+ if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
+ RETPUSHUNDEF;
+ }
+
+ RETPUSHYES;
+#else
+ DIE(no_sock_func, "socketpair");
+#endif
+}
+
+PP(pp_bind)
+{
+ djSP;
+#ifdef HAS_SOCKET
+#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
+ extern GETPRIVMODE();
+ extern GETUSERMODE();
+#endif
+ SV *addrsv = POPs;
+ char *addr;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+ STRLEN len;
+ int bind_ok = 0;
+#ifdef MPE
+ int mpeprivmode = 0;
+#endif
+
+ if (!io || !IoIFP(io))
+ goto nuts;
+
+ addr = SvPV(addrsv, len);
+ TAINT_PROPER("bind");
+#ifdef MPE /* Deal with MPE bind() peculiarities */
+ if (((struct sockaddr *)addr)->sa_family == AF_INET) {
+ /* The address *MUST* stupidly be zero. */
+ ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
+ /* PRIV mode is required to bind() to ports < 1024. */
+ if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
+ ((struct sockaddr_in *)addr)->sin_port > 0) {
+ GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
+ mpeprivmode = 1;
+ }
+ }
+#endif /* MPE */
+ if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
+ (struct sockaddr *)addr, len) >= 0)
+ bind_ok = 1;
+
+#ifdef MPE /* Switch back to USER mode */
+ if (mpeprivmode)
+ GETUSERMODE();
+#endif /* MPE */
+
+ if (bind_ok)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+
+nuts:
+ if (PL_dowarn)
+ warn("bind() on closed fd");
+ SETERRNO(EBADF,SS$_IVCHAN);
+ RETPUSHUNDEF;
+#else
+ DIE(no_sock_func, "bind");
+#endif
+}
+
+PP(pp_connect)
+{
+ djSP;
+#ifdef HAS_SOCKET
+ SV *addrsv = POPs;
+ char *addr;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+ STRLEN len;
+
+ if (!io || !IoIFP(io))
+ goto nuts;
+
+ addr = SvPV(addrsv, len);
+ TAINT_PROPER("connect");
+ if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+
+nuts:
+ if (PL_dowarn)
+ warn("connect() on closed fd");
+ SETERRNO(EBADF,SS$_IVCHAN);
+ RETPUSHUNDEF;
+#else
+ DIE(no_sock_func, "connect");
+#endif
+}
+
+PP(pp_listen)
+{
+ djSP;
+#ifdef HAS_SOCKET
+ int backlog = POPi;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !IoIFP(io))
+ goto nuts;
+
+ if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+
+nuts:
+ if (PL_dowarn)
+ warn("listen() on closed fd");
+ SETERRNO(EBADF,SS$_IVCHAN);
+ RETPUSHUNDEF;
+#else
+ DIE(no_sock_func, "listen");
+#endif
+}
+
+PP(pp_accept)
+{
+ djSP; dTARGET;
+#ifdef HAS_SOCKET
+ GV *ngv;
+ GV *ggv;
+ register IO *nstio;
+ register IO *gstio;
+ struct sockaddr saddr; /* use a struct to avoid alignment problems */
+ Sock_size_t len = sizeof saddr;
+ int fd;
+
+ ggv = (GV*)POPs;
+ ngv = (GV*)POPs;
+
+ if (!ngv)
+ goto badexit;
+ if (!ggv)
+ goto nuts;
+
+ gstio = GvIO(ggv);
+ if (!gstio || !IoIFP(gstio))
+ goto nuts;
+
+ nstio = GvIOn(ngv);
+ if (IoIFP(nstio))
+ do_close(ngv, FALSE);
+
+ fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
+ if (fd < 0)
+ goto badexit;
+ IoIFP(nstio) = PerlIO_fdopen(fd, "r");
+ IoOFP(nstio) = PerlIO_fdopen(fd, "w");
+ IoTYPE(nstio) = 's';
+ if (!IoIFP(nstio) || !IoOFP(nstio)) {
+ if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
+ if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
+ if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
+ goto badexit;
+ }
+
+ PUSHp((char *)&saddr, len);
+ RETURN;
+
+nuts:
+ if (PL_dowarn)
+ warn("accept() on closed fd");
+ SETERRNO(EBADF,SS$_IVCHAN);
+
+badexit:
+ RETPUSHUNDEF;
+
+#else
+ DIE(no_sock_func, "accept");
+#endif
+}
+
+PP(pp_shutdown)
+{
+ djSP; dTARGET;
+#ifdef HAS_SOCKET
+ int how = POPi;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !IoIFP(io))
+ goto nuts;
+
+ PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
+ RETURN;
+
+nuts:
+ if (PL_dowarn)
+ warn("shutdown() on closed fd");
+ SETERRNO(EBADF,SS$_IVCHAN);
+ RETPUSHUNDEF;
+#else
+ DIE(no_sock_func, "shutdown");
+#endif
+}
+
+PP(pp_gsockopt)
+{
+#ifdef HAS_SOCKET
+ return pp_ssockopt(ARGS);
+#else
+ DIE(no_sock_func, "getsockopt");
+#endif
+}
+
+PP(pp_ssockopt)
+{
+ djSP;
+#ifdef HAS_SOCKET
+ int optype = PL_op->op_type;
+ SV *sv;
+ int fd;
+ unsigned int optname;
+ unsigned int lvl;
+ GV *gv;
+ register IO *io;
+ Sock_size_t len;
+
+ if (optype == OP_GSOCKOPT)
+ sv = sv_2mortal(NEWSV(22, 257));
+ else
+ sv = POPs;
+ optname = (unsigned int) POPi;
+ lvl = (unsigned int) POPi;
+
+ gv = (GV*)POPs;
+ io = GvIOn(gv);
+ if (!io || !IoIFP(io))
+ goto nuts;
+
+ fd = PerlIO_fileno(IoIFP(io));
+ switch (optype) {
+ case OP_GSOCKOPT:
+ SvGROW(sv, 257);
+ (void)SvPOK_only(sv);
+ SvCUR_set(sv,256);
+ *SvEND(sv) ='\0';
+ len = SvCUR(sv);
+ if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
+ goto nuts2;
+ SvCUR_set(sv, len);
+ *SvEND(sv) ='\0';
+ PUSHs(sv);
+ break;
+ case OP_SSOCKOPT: {
+ char *buf;
+ int aint;
+ if (SvPOKp(sv)) {
+ buf = SvPV(sv, PL_na);
+ len = PL_na;
+ }
+ else {
+ aint = (int)SvIV(sv);
+ buf = (char*)&aint;
+ len = sizeof(int);
+ }
+ if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
+ goto nuts2;
+ PUSHs(&PL_sv_yes);
+ }
+ break;
+ }
+ RETURN;
+
+nuts:
+ if (PL_dowarn)
+ warn("[gs]etsockopt() on closed fd");
+ SETERRNO(EBADF,SS$_IVCHAN);
+nuts2:
+ RETPUSHUNDEF;
+
+#else
+ DIE(no_sock_func, "setsockopt");
+#endif
+}
+
+PP(pp_getsockname)
+{
+#ifdef HAS_SOCKET
+ return pp_getpeername(ARGS);
+#else
+ DIE(no_sock_func, "getsockname");
+#endif
+}
+
+PP(pp_getpeername)
+{
+ djSP;
+#ifdef HAS_SOCKET
+ int optype = PL_op->op_type;
+ SV *sv;
+ int fd;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+ Sock_size_t len;
+
+ if (!io || !IoIFP(io))
+ goto nuts;
+
+ sv = sv_2mortal(NEWSV(22, 257));
+ (void)SvPOK_only(sv);
+ len = 256;
+ SvCUR_set(sv, len);
+ *SvEND(sv) ='\0';
+ fd = PerlIO_fileno(IoIFP(io));
+ switch (optype) {
+ case OP_GETSOCKNAME:
+ if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
+ goto nuts2;
+ break;
+ case OP_GETPEERNAME:
+ if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
+ goto nuts2;
+#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
+ {
+ static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
+ /* If the call succeeded, make sure we don't have a zeroed port/addr */
+ if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
+ !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
+ sizeof(u_short) + sizeof(struct in_addr))) {
+ goto nuts2;
+ }
+ }
+#endif
+ break;
+ }
+#ifdef BOGUS_GETNAME_RETURN
+ /* Interactive Unix, getpeername() and getsockname()
+ does not return valid namelen */
+ if (len == BOGUS_GETNAME_RETURN)
+ len = sizeof(struct sockaddr);
+#endif
+ SvCUR_set(sv, len);
+ *SvEND(sv) ='\0';
+ PUSHs(sv);
+ RETURN;
+
+nuts:
+ if (PL_dowarn)
+ warn("get{sock, peer}name() on closed fd");
+ SETERRNO(EBADF,SS$_IVCHAN);
+nuts2:
+ RETPUSHUNDEF;
+
+#else
+ DIE(no_sock_func, "getpeername");
+#endif
+}
+
+/* Stat calls. */
+
+PP(pp_lstat)
+{
+ return pp_stat(ARGS);
+}
+
+PP(pp_stat)
+{
+ djSP;
+ GV *tmpgv;
+ I32 gimme;
+ I32 max = 13;
+
+ if (PL_op->op_flags & OPf_REF) {
+ tmpgv = cGVOP->op_gv;
+ do_fstat:
+ if (tmpgv != PL_defgv) {
+ PL_laststype = OP_STAT;
+ PL_statgv = tmpgv;
+ sv_setpv(PL_statname, "");
+ PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
+ ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
+ }
+ if (PL_laststatval < 0)
+ max = 0;
+ }
+ else {
+ SV* sv = POPs;
+ if (SvTYPE(sv) == SVt_PVGV) {
+ tmpgv = (GV*)sv;
+ goto do_fstat;
+ }
+ else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+ tmpgv = (GV*)SvRV(sv);
+ goto do_fstat;
+ }
+ sv_setpv(PL_statname, SvPV(sv,PL_na));
+ 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);
+ else
+#endif
+ PL_laststatval = PerlLIO_stat(SvPV(PL_statname, PL_na), &PL_statcache);
+ if (PL_laststatval < 0) {
+ if (PL_dowarn && strchr(SvPV(PL_statname, PL_na), '\n'))
+ warn(warn_nl, "stat");
+ max = 0;
+ }
+ }
+
+ gimme = GIMME_V;
+ if (gimme != G_ARRAY) {
+ if (gimme != G_VOID)
+ XPUSHs(boolSV(max));
+ RETURN;
+ }
+ if (max) {
+ EXTEND(SP, max);
+ EXTEND_MORTAL(max);
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
+#ifdef USE_STAT_RDEV
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
+#else
+ PUSHs(sv_2mortal(newSVpv("", 0)));
+#endif
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
+#ifdef BIG_TIME
+ PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
+ PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
+ PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
+#else
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
+#endif
+#ifdef USE_STAT_BLOCKS
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
+ PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
+#else
+ PUSHs(sv_2mortal(newSVpv("", 0)));
+ PUSHs(sv_2mortal(newSVpv("", 0)));
+#endif
+ }
+ RETURN;
+}
+
+PP(pp_ftrread)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IRUSR, 0, &PL_statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftrwrite)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IWUSR, 0, &PL_statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftrexec)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IXUSR, 0, &PL_statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_fteread)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IRUSR, 1, &PL_statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftewrite)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IWUSR, 1, &PL_statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_fteexec)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (cando(S_IXUSR, 1, &PL_statcache))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftis)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ RETPUSHYES;
+}
+
+PP(pp_fteowned)
+{
+ return pp_ftrowned(ARGS);
+}
+
+PP(pp_ftrowned)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftzero)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (!PL_statcache.st_size)
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftsize)
+{
+ I32 result = my_stat(ARGS);
+ djSP; dTARGET;
+ if (result < 0)
+ RETPUSHUNDEF;
+ PUSHi(PL_statcache.st_size);
+ RETURN;
+}
+
+PP(pp_ftmtime)
+{
+ I32 result = my_stat(ARGS);
+ djSP; dTARGET;
+ if (result < 0)
+ RETPUSHUNDEF;
+ PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_mtime) / 86400.0 );
+ RETURN;
+}
+
+PP(pp_ftatime)
+{
+ I32 result = my_stat(ARGS);
+ djSP; dTARGET;
+ if (result < 0)
+ RETPUSHUNDEF;
+ PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
+ RETURN;
+}
+
+PP(pp_ftctime)
+{
+ I32 result = my_stat(ARGS);
+ djSP; dTARGET;
+ if (result < 0)
+ RETPUSHUNDEF;
+ PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_ctime) / 86400.0 );
+ RETURN;
+}
+
+PP(pp_ftsock)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISSOCK(PL_statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftchr)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISCHR(PL_statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftblk)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISBLK(PL_statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftfile)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISREG(PL_statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftdir)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISDIR(PL_statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftpipe)
+{
+ I32 result = my_stat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISFIFO(PL_statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftlink)
+{
+ I32 result = my_lstat(ARGS);
+ djSP;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (S_ISLNK(PL_statcache.st_mode))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+PP(pp_ftsuid)
+{
+ djSP;
+#ifdef S_ISUID
+ I32 result = my_stat(ARGS);
+ SPAGAIN;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (PL_statcache.st_mode & S_ISUID)
+ RETPUSHYES;
+#endif
+ RETPUSHNO;
+}
+
+PP(pp_ftsgid)
+{
+ djSP;
+#ifdef S_ISGID
+ I32 result = my_stat(ARGS);
+ SPAGAIN;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (PL_statcache.st_mode & S_ISGID)
+ RETPUSHYES;
+#endif
+ RETPUSHNO;
+}
+
+PP(pp_ftsvtx)
+{
+ djSP;
+#ifdef S_ISVTX
+ I32 result = my_stat(ARGS);
+ SPAGAIN;
+ if (result < 0)
+ RETPUSHUNDEF;
+ if (PL_statcache.st_mode & S_ISVTX)
+ RETPUSHYES;
+#endif
+ RETPUSHNO;
+}
+
+PP(pp_fttty)
+{
+ djSP;
+ int fd;
+ GV *gv;
+ char *tmps = Nullch;
+
+ if (PL_op->op_flags & OPf_REF)
+ gv = cGVOP->op_gv;
+ else if (isGV(TOPs))
+ gv = (GV*)POPs;
+ else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
+ gv = (GV*)SvRV(POPs);
+ else
+ gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
+
+ if (GvIO(gv) && IoIFP(GvIOp(gv)))
+ fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
+ else if (tmps && isDIGIT(*tmps))
+ fd = atoi(tmps);
+ else
+ RETPUSHUNDEF;
+ if (PerlLIO_isatty(fd))
+ RETPUSHYES;
+ RETPUSHNO;
+}
+
+#if defined(atarist) /* this will work with atariST. Configure will
+ make guesses for other systems. */
+# define FILE_base(f) ((f)->_base)
+# define FILE_ptr(f) ((f)->_ptr)
+# define FILE_cnt(f) ((f)->_cnt)
+# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
+#endif
+
+PP(pp_fttext)
+{
+ djSP;
+ I32 i;
+ I32 len;
+ I32 odd = 0;
+ STDCHAR tbuf[512];
+ register STDCHAR *s;
+ register IO *io;
+ register SV *sv;
+ GV *gv;
+
+ if (PL_op->op_flags & OPf_REF)
+ gv = cGVOP->op_gv;
+ else if (isGV(TOPs))
+ gv = (GV*)POPs;
+ else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
+ gv = (GV*)SvRV(POPs);
+ else
+ gv = Nullgv;
+
+ if (gv) {
+ EXTEND(SP, 1);
+ if (gv == PL_defgv) {
+ if (PL_statgv)
+ io = GvIO(PL_statgv);
+ else {
+ sv = PL_statname;
+ goto really_filename;
+ }
+ }
+ else {
+ PL_statgv = gv;
+ PL_laststatval = -1;
+ sv_setpv(PL_statname, "");
+ io = GvIO(PL_statgv);
+ }
+ if (io && IoIFP(io)) {
+ if (! PerlIO_has_base(IoIFP(io)))
+ DIE("-T and -B not implemented on filehandles");
+ PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+ if (PL_laststatval < 0)
+ RETPUSHUNDEF;
+ if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
+ if (PL_op->op_type == OP_FTTEXT)
+ RETPUSHNO;
+ else
+ RETPUSHYES;
+ if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
+ i = PerlIO_getc(IoIFP(io));
+ if (i != EOF)
+ (void)PerlIO_ungetc(IoIFP(io),i);
+ }
+ if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
+ RETPUSHYES;
+ len = PerlIO_get_bufsiz(IoIFP(io));
+ s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
+ /* sfio can have large buffers - limit to 512 */
+ if (len > 512)
+ len = 512;
+ }
+ else {
+ if (PL_dowarn)
+ warn("Test on unopened file <%s>",
+ GvENAME(cGVOP->op_gv));
+ SETERRNO(EBADF,RMS$_IFI);
+ RETPUSHUNDEF;
+ }
+ }
+ else {
+ sv = POPs;
+ really_filename:
+ PL_statgv = Nullgv;
+ PL_laststatval = -1;
+ sv_setpv(PL_statname, SvPV(sv, PL_na));
+#ifdef HAS_OPEN3
+ i = PerlLIO_open3(SvPV(sv, PL_na), O_RDONLY, 0);
+#else
+ i = PerlLIO_open(SvPV(sv, PL_na), 0);
+#endif
+ if (i < 0) {
+ if (PL_dowarn && strchr(SvPV(sv, PL_na), '\n'))
+ warn(warn_nl, "open");
+ RETPUSHUNDEF;
+ }
+ PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
+ if (PL_laststatval < 0)
+ RETPUSHUNDEF;
+ len = PerlLIO_read(i, tbuf, 512);
+ (void)PerlLIO_close(i);
+ if (len <= 0) {
+ if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
+ RETPUSHNO; /* special case NFS directories */
+ RETPUSHYES; /* null file is anything */
+ }
+ s = tbuf;
+ }
+
+ /* now scan s to look for textiness */
+ /* XXX ASCII dependent code */
+
+ for (i = 0; i < len; i++, s++) {
+ if (!*s) { /* null never allowed in text */
+ odd += len;
+ break;
+ }
+#ifdef EBCDIC
+ else if (!(isPRINT(*s) || isSPACE(*s)))
+ odd++;
+#else
+ else if (*s & 128)
+ odd++;
+ else if (*s < 32 &&
+ *s != '\n' && *s != '\r' && *s != '\b' &&
+ *s != '\t' && *s != '\f' && *s != 27)
+ odd++;
+#endif
+ }
+
+ if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
+ RETPUSHNO;
+ else
+ RETPUSHYES;
+}
+
+PP(pp_ftbinary)
+{
+ return pp_fttext(ARGS);
+}
+
+/* File calls. */
+
+PP(pp_chdir)
+{
+ djSP; dTARGET;
+ char *tmps;
+ SV **svp;
+
+ if (MAXARG < 1)
+ tmps = Nullch;
+ else
+ tmps = POPp;
+ if (!tmps || !*tmps) {
+ svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
+ if (svp)
+ tmps = SvPV(*svp, PL_na);
+ }
+ if (!tmps || !*tmps) {
+ svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
+ if (svp)
+ tmps = SvPV(*svp, PL_na);
+ }
+#ifdef VMS
+ if (!tmps || !*tmps) {
+ svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
+ if (svp)
+ tmps = SvPV(*svp, PL_na);
+ }
+#endif
+ TAINT_PROPER("chdir");
+ PUSHi( PerlDir_chdir(tmps) >= 0 );
+#ifdef VMS
+ /* Clear the DEFAULT element of ENV so we'll get the new value
+ * in the future. */
+ hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
+#endif
+ RETURN;
+}
+
+PP(pp_chown)
+{
+ djSP; dMARK; dTARGET;
+ I32 value;
+#ifdef HAS_CHOWN
+ value = (I32)apply(PL_op->op_type, MARK, SP);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function chown");
+#endif
+}
+
+PP(pp_chroot)
+{
+ djSP; dTARGET;
+ char *tmps;
+#ifdef HAS_CHROOT
+ tmps = POPp;
+ TAINT_PROPER("chroot");
+ PUSHi( chroot(tmps) >= 0 );
+ RETURN;
+#else
+ DIE(no_func, "chroot");
+#endif
+}
+
+PP(pp_unlink)
+{
+ djSP; dMARK; dTARGET;
+ I32 value;
+ value = (I32)apply(PL_op->op_type, MARK, SP);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+}
+
+PP(pp_chmod)
+{
+ djSP; dMARK; dTARGET;
+ I32 value;
+ value = (I32)apply(PL_op->op_type, MARK, SP);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+}
+
+PP(pp_utime)
+{
+ djSP; dMARK; dTARGET;
+ I32 value;
+ value = (I32)apply(PL_op->op_type, MARK, SP);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+}
+
+PP(pp_rename)
+{
+ djSP; dTARGET;
+ int anum;
+
+ char *tmps2 = POPp;
+ char *tmps = SvPV(TOPs, PL_na);
+ TAINT_PROPER("rename");
+#ifdef HAS_RENAME
+ anum = PerlLIO_rename(tmps, tmps2);
+#else
+ if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
+ if (same_dirent(tmps2, tmps)) /* can always rename to same name */
+ anum = 1;
+ else {
+ if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
+ (void)UNLINK(tmps2);
+ if (!(anum = link(tmps, tmps2)))
+ anum = UNLINK(tmps);
+ }
+ }
+#endif
+ SETi( anum >= 0 );
+ RETURN;
+}
+
+PP(pp_link)
+{
+ djSP; dTARGET;
+#ifdef HAS_LINK
+ char *tmps2 = POPp;
+ char *tmps = SvPV(TOPs, PL_na);
+ TAINT_PROPER("link");
+ SETi( link(tmps, tmps2) >= 0 );
+#else
+ DIE(no_func, "Unsupported function link");
+#endif
+ RETURN;
+}
+
+PP(pp_symlink)
+{
+ djSP; dTARGET;
+#ifdef HAS_SYMLINK
+ char *tmps2 = POPp;
+ char *tmps = SvPV(TOPs, PL_na);
+ TAINT_PROPER("symlink");
+ SETi( symlink(tmps, tmps2) >= 0 );
+ RETURN;
+#else
+ DIE(no_func, "symlink");
+#endif
+}
+
+PP(pp_readlink)
+{
+ djSP; dTARGET;
+#ifdef HAS_SYMLINK
+ char *tmps;
+ char buf[MAXPATHLEN];
+ int len;
+
+#ifndef INCOMPLETE_TAINTS
+ TAINT;
+#endif
+ tmps = POPp;
+ len = readlink(tmps, buf, sizeof buf);
+ EXTEND(SP, 1);
+ if (len < 0)
+ RETPUSHUNDEF;
+ PUSHp(buf, len);
+ RETURN;
+#else
+ EXTEND(SP, 1);
+ RETSETUNDEF; /* just pretend it's a normal file */
+#endif
+}
+
+#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
+static int
+dooneliner(cmd, filename)
+char *cmd;
+char *filename;
+{
+ char *save_filename = filename;
+ char *cmdline;
+ char *s;
+ PerlIO *myfp;
+ int anum = 1;
+
+ New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
+ strcpy(cmdline, cmd);
+ strcat(cmdline, " ");
+ for (s = cmdline + strlen(cmdline); *filename; ) {
+ *s++ = '\\';
+ *s++ = *filename++;
+ }
+ strcpy(s, " 2>&1");
+ myfp = PerlProc_popen(cmdline, "r");
+ Safefree(cmdline);
+
+ if (myfp) {
+ SV *tmpsv = sv_newmortal();
+ /* Need to save/restore 'PL_rs' ?? */
+ s = sv_gets(tmpsv, myfp, 0);
+ (void)PerlProc_pclose(myfp);
+ if (s != Nullch) {
+ int e;
+ for (e = 1;
+#ifdef HAS_SYS_ERRLIST
+ e <= sys_nerr
+#endif
+ ; e++)
+ {
+ /* you don't see this */
+ char *errmsg =
+#ifdef HAS_SYS_ERRLIST
+ sys_errlist[e]
+#else
+ strerror(e)
+#endif
+ ;
+ if (!errmsg)
+ break;
+ if (instr(s, errmsg)) {
+ SETERRNO(e,0);
+ return 0;
+ }
+ }
+ SETERRNO(0,0);
+#ifndef EACCES
+#define EACCES EPERM
+#endif
+ if (instr(s, "cannot make"))
+ SETERRNO(EEXIST,RMS$_FEX);
+ else if (instr(s, "existing file"))
+ SETERRNO(EEXIST,RMS$_FEX);
+ else if (instr(s, "ile exists"))
+ SETERRNO(EEXIST,RMS$_FEX);
+ else if (instr(s, "non-exist"))
+ SETERRNO(ENOENT,RMS$_FNF);
+ else if (instr(s, "does not exist"))
+ SETERRNO(ENOENT,RMS$_FNF);
+ else if (instr(s, "not empty"))
+ SETERRNO(EBUSY,SS$_DEVOFFLINE);
+ else if (instr(s, "cannot access"))
+ SETERRNO(EACCES,RMS$_PRV);
+ else
+ SETERRNO(EPERM,RMS$_PRV);
+ return 0;
+ }
+ else { /* some mkdirs return no failure indication */
+ anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
+ if (PL_op->op_type == OP_RMDIR)
+ anum = !anum;
+ if (anum)
+ SETERRNO(0,0);
+ else
+ SETERRNO(EACCES,RMS$_PRV); /* a guess */
+ }
+ return anum;
+ }
+ else
+ return 0;
+}
+#endif
+
+PP(pp_mkdir)
+{
+ djSP; dTARGET;
+ int mode = POPi;
+#ifndef HAS_MKDIR
+ int oldumask;
+#endif
+ char *tmps = SvPV(TOPs, PL_na);
+
+ TAINT_PROPER("mkdir");
+#ifdef HAS_MKDIR
+ SETi( PerlDir_mkdir(tmps, mode) >= 0 );
+#else
+ SETi( dooneliner("mkdir", tmps) );
+ oldumask = PerlLIO_umask(0);
+ PerlLIO_umask(oldumask);
+ PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
+#endif
+ RETURN;
+}
+
+PP(pp_rmdir)
+{
+ djSP; dTARGET;
+ char *tmps;
+
+ tmps = POPp;
+ TAINT_PROPER("rmdir");
+#ifdef HAS_RMDIR
+ XPUSHi( PerlDir_rmdir(tmps) >= 0 );
+#else
+ XPUSHi( dooneliner("rmdir", tmps) );
+#endif
+ RETURN;
+}
+
+/* Directory calls. */
+
+PP(pp_open_dir)
+{
+ djSP;
+#if defined(Direntry_t) && defined(HAS_READDIR)
+ char *dirname = POPp;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io)
+ goto nope;
+
+ if (IoDIRP(io))
+ PerlDir_close(IoDIRP(io));
+ if (!(IoDIRP(io) = PerlDir_open(dirname)))
+ goto nope;
+
+ RETPUSHYES;
+nope:
+ if (!errno)
+ SETERRNO(EBADF,RMS$_DIR);
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "opendir");
+#endif
+}
+
+PP(pp_readdir)
+{
+ djSP;
+#if defined(Direntry_t) && defined(HAS_READDIR)
+#ifndef I_DIRENT
+ Direntry_t *readdir _((DIR *));
+#endif
+ register Direntry_t *dp;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+ SV *sv;
+
+ if (!io || !IoDIRP(io))
+ goto nope;
+
+ if (GIMME == G_ARRAY) {
+ /*SUPPRESS 560*/
+ while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
+#ifdef DIRNAMLEN
+ sv = newSVpv(dp->d_name, dp->d_namlen);
+#else
+ sv = newSVpv(dp->d_name, 0);
+#endif
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(sv);
+#endif
+ XPUSHs(sv_2mortal(sv));
+ }
+ }
+ else {
+ if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
+ goto nope;
+#ifdef DIRNAMLEN
+ sv = newSVpv(dp->d_name, dp->d_namlen);
+#else
+ sv = newSVpv(dp->d_name, 0);
+#endif
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(sv);
+#endif
+ XPUSHs(sv_2mortal(sv));
+ }
+ RETURN;
+
+nope:
+ if (!errno)
+ SETERRNO(EBADF,RMS$_ISI);
+ if (GIMME == G_ARRAY)
+ RETURN;
+ else
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "readdir");
+#endif
+}
+
+PP(pp_telldir)
+{
+ djSP; dTARGET;
+#if defined(HAS_TELLDIR) || defined(telldir)
+# ifdef NEED_TELLDIR_PROTO /* XXX does _anyone_ need this? --AD 2/20/1998 */
+ long telldir _((DIR *));
+# endif
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !IoDIRP(io))
+ goto nope;
+
+ PUSHi( PerlDir_tell(IoDIRP(io)) );
+ RETURN;
+nope:
+ if (!errno)
+ SETERRNO(EBADF,RMS$_ISI);
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "telldir");
+#endif
+}
+
+PP(pp_seekdir)
+{
+ djSP;
+#if defined(HAS_SEEKDIR) || defined(seekdir)
+ long along = POPl;
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !IoDIRP(io))
+ goto nope;
+
+ (void)PerlDir_seek(IoDIRP(io), along);
+
+ RETPUSHYES;
+nope:
+ if (!errno)
+ SETERRNO(EBADF,RMS$_ISI);
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "seekdir");
+#endif
+}
+
+PP(pp_rewinddir)
+{
+ djSP;
+#if defined(HAS_REWINDDIR) || defined(rewinddir)
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !IoDIRP(io))
+ goto nope;
+
+ (void)PerlDir_rewind(IoDIRP(io));
+ RETPUSHYES;
+nope:
+ if (!errno)
+ SETERRNO(EBADF,RMS$_ISI);
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "rewinddir");
+#endif
+}
+
+PP(pp_closedir)
+{
+ djSP;
+#if defined(Direntry_t) && defined(HAS_READDIR)
+ GV *gv = (GV*)POPs;
+ register IO *io = GvIOn(gv);
+
+ if (!io || !IoDIRP(io))
+ goto nope;
+
+#ifdef VOID_CLOSEDIR
+ PerlDir_close(IoDIRP(io));
+#else
+ if (PerlDir_close(IoDIRP(io)) < 0) {
+ IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
+ goto nope;
+ }
+#endif
+ IoDIRP(io) = 0;
+
+ RETPUSHYES;
+nope:
+ if (!errno)
+ SETERRNO(EBADF,RMS$_IFI);
+ RETPUSHUNDEF;
+#else
+ DIE(no_dir_func, "closedir");
+#endif
+}
+
+/* Process control. */
+
+PP(pp_fork)
+{
+#ifdef HAS_FORK
+ djSP; dTARGET;
+ int childpid;
+ GV *tmpgv;
+
+ EXTEND(SP, 1);
+ childpid = fork();
+ if (childpid < 0)
+ RETSETUNDEF;
+ if (!childpid) {
+ /*SUPPRESS 560*/
+ if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
+ hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
+ }
+ PUSHi(childpid);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function fork");
+#endif
+}
+
+PP(pp_wait)
+{
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
+ djSP; dTARGET;
+ int childpid;
+ int argflags;
+
+ childpid = wait4pid(-1, &argflags, 0);
+ STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+ XPUSHi(childpid);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function wait");
+#endif
+}
+
+PP(pp_waitpid)
+{
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
+ djSP; dTARGET;
+ int childpid;
+ int optype;
+ int argflags;
+
+ optype = POPi;
+ childpid = TOPi;
+ childpid = wait4pid(childpid, &argflags, optype);
+ STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+ SETi(childpid);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function waitpid");
+#endif
+}
+
+PP(pp_system)
+{
+ djSP; dMARK; dORIGMARK; dTARGET;
+ I32 value;
+ int childpid;
+ int result;
+ int status;
+ Sigsave_t ihand,qhand; /* place to save signals during system() */
+
+ if (SP - MARK == 1) {
+ if (PL_tainting) {
+ char *junk = SvPV(TOPs, PL_na);
+ TAINT_ENV();
+ TAINT_PROPER("system");
+ }
+ }
+#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
+ while ((childpid = vfork()) == -1) {
+ if (errno != EAGAIN) {
+ value = -1;
+ SP = ORIGMARK;
+ PUSHi(value);
+ RETURN;
+ }
+ sleep(5);
+ }
+ if (childpid > 0) {
+ rsignal_save(SIGINT, SIG_IGN, &ihand);
+ rsignal_save(SIGQUIT, SIG_IGN, &qhand);
+ do {
+ result = wait4pid(childpid, &status, 0);
+ } while (result == -1 && errno == EINTR);
+ (void)rsignal_restore(SIGINT, &ihand);
+ (void)rsignal_restore(SIGQUIT, &qhand);
+ STATUS_NATIVE_SET(result == -1 ? -1 : status);
+ do_execfree(); /* free any memory child malloced on vfork */
+ SP = ORIGMARK;
+ PUSHi(STATUS_CURRENT);
+ RETURN;
+ }
+ if (PL_op->op_flags & OPf_STACKED) {
+ SV *really = *++MARK;
+ value = (I32)do_aexec(really, MARK, SP);
+ }
+ else if (SP - MARK != 1)
+ value = (I32)do_aexec(Nullsv, MARK, SP);
+ else {
+ value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
+ }
+ PerlProc__exit(-1);
+#else /* ! FORK or VMS or OS/2 */
+ if (PL_op->op_flags & OPf_STACKED) {
+ SV *really = *++MARK;
+ value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
+ }
+ 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));
+ }
+ STATUS_NATIVE_SET(value);
+ do_execfree();
+ SP = ORIGMARK;
+ PUSHi(STATUS_CURRENT);
+#endif /* !FORK or VMS */
+ RETURN;
+}
+
+PP(pp_exec)
+{
+ djSP; dMARK; dORIGMARK; dTARGET;
+ I32 value;
+
+ if (PL_op->op_flags & OPf_STACKED) {
+ SV *really = *++MARK;
+ value = (I32)do_aexec(really, MARK, SP);
+ }
+ else if (SP - MARK != 1)
+#ifdef VMS
+ value = (I32)vms_do_aexec(Nullsv, MARK, SP);
+#else
+ value = (I32)do_aexec(Nullsv, MARK, SP);
+#endif
+ else {
+ if (PL_tainting) {
+ char *junk = SvPV(*SP, PL_na);
+ TAINT_ENV();
+ TAINT_PROPER("exec");
+ }
+#ifdef VMS
+ value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
+#else
+ value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), PL_na));
+#endif
+ }
+ SP = ORIGMARK;
+ PUSHi(value);
+ RETURN;
+}
+
+PP(pp_kill)
+{
+ djSP; dMARK; dTARGET;
+ I32 value;
+#ifdef HAS_KILL
+ value = (I32)apply(PL_op->op_type, MARK, SP);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function kill");
+#endif
+}
+
+PP(pp_getppid)
+{
+#ifdef HAS_GETPPID
+ djSP; dTARGET;
+ XPUSHi( getppid() );
+ RETURN;
+#else
+ DIE(no_func, "getppid");
+#endif
+}
+
+PP(pp_getpgrp)
+{
+#ifdef HAS_GETPGRP
+ djSP; dTARGET;
+ int pid;
+ I32 value;
+
+ if (MAXARG < 1)
+ pid = 0;
+ else
+ pid = SvIVx(POPs);
+#ifdef BSD_GETPGRP
+ value = (I32)BSD_GETPGRP(pid);
+#else
+ if (pid != 0 && pid != getpid())
+ DIE("POSIX getpgrp can't take an argument");
+ value = (I32)getpgrp();
+#endif
+ XPUSHi(value);
+ RETURN;
+#else
+ DIE(no_func, "getpgrp()");
+#endif
+}
+
+PP(pp_setpgrp)
+{
+#ifdef HAS_SETPGRP
+ djSP; dTARGET;
+ int pgrp;
+ int pid;
+ if (MAXARG < 2) {
+ pgrp = 0;
+ pid = 0;
+ }
+ else {
+ pgrp = POPi;
+ pid = TOPi;
+ }
+
+ TAINT_PROPER("setpgrp");
+#ifdef BSD_SETPGRP
+ SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
+#else
+ if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
+ DIE("POSIX setpgrp can't take an argument");
+ SETi( setpgrp() >= 0 );
+#endif /* USE_BSDPGRP */
+ RETURN;
+#else
+ DIE(no_func, "setpgrp()");
+#endif
+}
+
+PP(pp_getpriority)
+{
+ djSP; dTARGET;
+ int which;
+ int who;
+#ifdef HAS_GETPRIORITY
+ who = POPi;
+ which = TOPi;
+ SETi( getpriority(which, who) );
+ RETURN;
+#else
+ DIE(no_func, "getpriority()");
+#endif
+}
+
+PP(pp_setpriority)
+{
+ djSP; dTARGET;
+ int which;
+ int who;
+ int niceval;
+#ifdef HAS_SETPRIORITY
+ niceval = POPi;
+ who = POPi;
+ which = TOPi;
+ TAINT_PROPER("setpriority");
+ SETi( setpriority(which, who, niceval) >= 0 );
+ RETURN;
+#else
+ DIE(no_func, "setpriority()");
+#endif
+}
+
+/* Time calls. */
+
+PP(pp_time)
+{
+ djSP; dTARGET;
+#ifdef BIG_TIME
+ XPUSHn( time(Null(Time_t*)) );
+#else
+ XPUSHi( time(Null(Time_t*)) );
+#endif
+ RETURN;
+}
+
+/* XXX The POSIX name is CLK_TCK; it is to be preferred
+ to HZ. Probably. For now, assume that if the system
+ defines HZ, it does so correctly. (Will this break
+ on VMS?)
+ Probably we ought to use _sysconf(_SC_CLK_TCK), if
+ it's supported. --AD 9/96.
+*/
+
+#ifndef HZ
+# ifdef CLK_TCK
+# define HZ CLK_TCK
+# else
+# define HZ 60
+# endif
+#endif
+
+PP(pp_tms)
+{
+ djSP;
+
+#ifndef HAS_TIMES
+ DIE("times not implemented");
+#else
+ EXTEND(SP, 4);
+
+#ifndef VMS
+ (void)PerlProc_times(&PL_timesbuf);
+#else
+ (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
+ /* struct tms, though same data */
+ /* is returned. */
+#endif
+
+ PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
+ if (GIMME == G_ARRAY) {
+ PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
+ PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
+ }
+ RETURN;
+#endif /* HAS_TIMES */
+}
+
+PP(pp_localtime)
+{
+ return pp_gmtime(ARGS);
+}
+
+PP(pp_gmtime)
+{
+ djSP;
+ Time_t when;
+ struct tm *tmbuf;
+ static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
+ static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
+
+ if (MAXARG < 1)
+ (void)time(&when);
+ else
+#ifdef BIG_TIME
+ when = (Time_t)SvNVx(POPs);
+#else
+ when = (Time_t)SvIVx(POPs);
+#endif
+
+ if (PL_op->op_type == OP_LOCALTIME)
+ tmbuf = localtime(&when);
+ else
+ tmbuf = gmtime(&when);
+
+ EXTEND(SP, 9);
+ EXTEND_MORTAL(9);
+ if (GIMME != G_ARRAY) {
+ dTARGET;
+ SV *tsv;
+ if (!tmbuf)
+ RETPUSHUNDEF;
+ tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
+ dayname[tmbuf->tm_wday],
+ monname[tmbuf->tm_mon],
+ tmbuf->tm_mday,
+ tmbuf->tm_hour,
+ tmbuf->tm_min,
+ tmbuf->tm_sec,
+ tmbuf->tm_year + 1900);
+ PUSHs(sv_2mortal(tsv));
+ }
+ else if (tmbuf) {
+ PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
+ PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
+ PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
+ PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
+ PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
+ PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
+ PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
+ PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
+ PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
+ }
+ RETURN;
+}
+
+PP(pp_alarm)
+{
+ djSP; dTARGET;
+ int anum;
+#ifdef HAS_ALARM
+ anum = POPi;
+ anum = alarm((unsigned int)anum);
+ EXTEND(SP, 1);
+ if (anum < 0)
+ RETPUSHUNDEF;
+ PUSHi((I32)anum);
+ RETURN;
+#else
+ DIE(no_func, "Unsupported function alarm");
+#endif
+}
+
+PP(pp_sleep)
+{
+ djSP; dTARGET;
+ I32 duration;
+ Time_t lasttime;
+ Time_t when;
+
+ (void)time(&lasttime);
+ if (MAXARG < 1)
+ PerlProc_pause();
+ else {
+ duration = POPi;
+ PerlProc_sleep((unsigned int)duration);
+ }
+ (void)time(&when);
+ XPUSHi(when - lasttime);
+ RETURN;
+}
+
+/* Shared memory. */
+
+PP(pp_shmget)
+{
+ return pp_semget(ARGS);
+}
+
+PP(pp_shmctl)
+{
+ return pp_semctl(ARGS);
+}
+
+PP(pp_shmread)
+{
+ return pp_shmwrite(ARGS);
+}
+
+PP(pp_shmwrite)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ djSP; dMARK; dTARGET;
+ I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ return pp_semget(ARGS);
+#endif
+}
+
+/* Message passing. */
+
+PP(pp_msgget)
+{
+ return pp_semget(ARGS);
+}
+
+PP(pp_msgctl)
+{
+ return pp_semctl(ARGS);
+}
+
+PP(pp_msgsnd)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ djSP; dMARK; dTARGET;
+ I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ return pp_semget(ARGS);
+#endif
+}
+
+PP(pp_msgrcv)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ djSP; dMARK; dTARGET;
+ I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ return pp_semget(ARGS);
+#endif
+}
+
+/* Semaphores. */
+
+PP(pp_semget)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ djSP; dMARK; dTARGET;
+ int anum = do_ipcget(PL_op->op_type, MARK, SP);
+ SP = MARK;
+ if (anum == -1)
+ RETPUSHUNDEF;
+ PUSHi(anum);
+ RETURN;
+#else
+ DIE("System V IPC is not implemented on this machine");
+#endif
+}
+
+PP(pp_semctl)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ djSP; dMARK; dTARGET;
+ int anum = do_ipcctl(PL_op->op_type, MARK, SP);
+ SP = MARK;
+ if (anum == -1)
+ RETSETUNDEF;
+ if (anum != 0) {
+ PUSHi(anum);
+ }
+ else {
+ PUSHp(zero_but_true, ZBTLEN);
+ }
+ RETURN;
+#else
+ return pp_semget(ARGS);
+#endif
+}
+
+PP(pp_semop)
+{
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+ djSP; dMARK; dTARGET;
+ I32 value = (I32)(do_semop(MARK, SP) >= 0);
+ SP = MARK;
+ PUSHi(value);
+ RETURN;
+#else
+ return pp_semget(ARGS);
+#endif
+}
+
+/* Get system info. */
+
+PP(pp_ghbyname)
+{
+#ifdef HAS_GETHOSTBYNAME
+ return pp_ghostent(ARGS);
+#else
+ DIE(no_sock_func, "gethostbyname");
+#endif
+}
+
+PP(pp_ghbyaddr)
+{
+#ifdef HAS_GETHOSTBYADDR
+ return pp_ghostent(ARGS);
+#else
+ DIE(no_sock_func, "gethostbyaddr");
+#endif
+}
+
+PP(pp_ghostent)
+{
+ djSP;
+#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
+ I32 which = PL_op->op_type;
+ register char **elem;
+ register SV *sv;
+#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
+ struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
+ struct hostent *PerlSock_gethostbyname(Netdb_name_t);
+ struct hostent *PerlSock_gethostent(void);
+#endif
+ struct hostent *hent;
+ unsigned long len;
+
+ EXTEND(SP, 10);
+ if (which == OP_GHBYNAME)
+#ifdef HAS_GETHOSTBYNAME
+ hent = PerlSock_gethostbyname(POPp);
+#else
+ DIE(no_sock_func, "gethostbyname");
+#endif
+ else if (which == OP_GHBYADDR) {
+#ifdef HAS_GETHOSTBYADDR
+ int addrtype = POPi;
+ SV *addrsv = POPs;
+ STRLEN addrlen;
+ Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
+
+ hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
+#else
+ DIE(no_sock_func, "gethostbyaddr");
+#endif
+ }
+ else
+#ifdef HAS_GETHOSTENT
+ hent = PerlSock_gethostent();
+#else
+ DIE(no_sock_func, "gethostent");
+#endif
+
+#ifdef HOST_NOT_FOUND
+ if (!hent)
+ STATUS_NATIVE_SET(h_errno);
+#endif
+
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_newmortal());
+ if (hent) {
+ if (which == OP_GHBYNAME) {
+ if (hent->h_addr)
+ sv_setpvn(sv, hent->h_addr, hent->h_length);
+ }
+ else
+ sv_setpv(sv, (char*)hent->h_name);
+ }
+ RETURN;
+ }
+
+ if (hent) {
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setpv(sv, (char*)hent->h_name);
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ for (elem = hent->h_aliases; elem && *elem; elem++) {
+ sv_catpv(sv, *elem);
+ if (elem[1])
+ sv_catpvn(sv, " ", 1);
+ }
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)hent->h_addrtype);
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ len = hent->h_length;
+ sv_setiv(sv, (IV)len);
+#ifdef h_addr
+ for (elem = hent->h_addr_list; elem && *elem; elem++) {
+ XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setpvn(sv, *elem, len);
+ }
+#else
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ if (hent->h_addr)
+ sv_setpvn(sv, hent->h_addr, len);
+#endif /* h_addr */
+ }
+ RETURN;
+#else
+ DIE(no_sock_func, "gethostent");
+#endif
+}
+
+PP(pp_gnbyname)
+{
+#ifdef HAS_GETNETBYNAME
+ return pp_gnetent(ARGS);
+#else
+ DIE(no_sock_func, "getnetbyname");
+#endif
+}
+
+PP(pp_gnbyaddr)
+{
+#ifdef HAS_GETNETBYADDR
+ return pp_gnetent(ARGS);
+#else
+ DIE(no_sock_func, "getnetbyaddr");
+#endif
+}
+
+PP(pp_gnetent)
+{
+ djSP;
+#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
+ I32 which = PL_op->op_type;
+ register char **elem;
+ register SV *sv;
+#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
+ struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
+ struct netent *PerlSock_getnetbyname(Netdb_name_t);
+ struct netent *PerlSock_getnetent(void);
+#endif
+ struct netent *nent;
+
+ if (which == OP_GNBYNAME)
+#ifdef HAS_GETNETBYNAME
+ nent = PerlSock_getnetbyname(POPp);
+#else
+ DIE(no_sock_func, "getnetbyname");
+#endif
+ else if (which == OP_GNBYADDR) {
+#ifdef HAS_GETNETBYADDR
+ int addrtype = POPi;
+ Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
+ nent = PerlSock_getnetbyaddr(addr, addrtype);
+#else
+ DIE(no_sock_func, "getnetbyaddr");
+#endif
+ }
+ else
+#ifdef HAS_GETNETENT
+ nent = PerlSock_getnetent();
+#else
+ DIE(no_sock_func, "getnetent");
+#endif
+
+ EXTEND(SP, 4);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_newmortal());
+ if (nent) {
+ if (which == OP_GNBYNAME)
+ sv_setiv(sv, (IV)nent->n_net);
+ else
+ sv_setpv(sv, nent->n_name);
+ }
+ RETURN;
+ }
+
+ if (nent) {
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setpv(sv, nent->n_name);
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ for (elem = nent->n_aliases; elem && *elem; elem++) {
+ sv_catpv(sv, *elem);
+ if (elem[1])
+ sv_catpvn(sv, " ", 1);
+ }
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)nent->n_addrtype);
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)nent->n_net);
+ }
+
+ RETURN;
+#else
+ DIE(no_sock_func, "getnetent");
+#endif
+}
+
+PP(pp_gpbyname)
+{
+#ifdef HAS_GETPROTOBYNAME
+ return pp_gprotoent(ARGS);
+#else
+ DIE(no_sock_func, "getprotobyname");
+#endif
+}
+
+PP(pp_gpbynumber)
+{
+#ifdef HAS_GETPROTOBYNUMBER
+ return pp_gprotoent(ARGS);
+#else
+ DIE(no_sock_func, "getprotobynumber");
+#endif
+}
+
+PP(pp_gprotoent)
+{
+ djSP;
+#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
+ I32 which = PL_op->op_type;
+ register char **elem;
+ register SV *sv;
+#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
+ struct protoent *PerlSock_getprotobyname(Netdb_name_t);
+ struct protoent *PerlSock_getprotobynumber(int);
+ struct protoent *PerlSock_getprotoent(void);
+#endif
+ struct protoent *pent;
+
+ if (which == OP_GPBYNAME)
+#ifdef HAS_GETPROTOBYNAME
+ pent = PerlSock_getprotobyname(POPp);
+#else
+ DIE(no_sock_func, "getprotobyname");
+#endif
+ else if (which == OP_GPBYNUMBER)
+#ifdef HAS_GETPROTOBYNUMBER
+ pent = PerlSock_getprotobynumber(POPi);
+#else
+ DIE(no_sock_func, "getprotobynumber");
+#endif
+ else
+#ifdef HAS_GETPROTOENT
+ pent = PerlSock_getprotoent();
+#else
+ DIE(no_sock_func, "getprotoent");
+#endif
+
+ EXTEND(SP, 3);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_newmortal());
+ if (pent) {
+ if (which == OP_GPBYNAME)
+ sv_setiv(sv, (IV)pent->p_proto);
+ else
+ sv_setpv(sv, pent->p_name);
+ }
+ RETURN;
+ }
+
+ if (pent) {
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setpv(sv, pent->p_name);
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ for (elem = pent->p_aliases; elem && *elem; elem++) {
+ sv_catpv(sv, *elem);
+ if (elem[1])
+ sv_catpvn(sv, " ", 1);
+ }
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)pent->p_proto);
+ }
+
+ RETURN;
+#else
+ DIE(no_sock_func, "getprotoent");
+#endif
+}
+
+PP(pp_gsbyname)
+{
+#ifdef HAS_GETSERVBYNAME
+ return pp_gservent(ARGS);
+#else
+ DIE(no_sock_func, "getservbyname");
+#endif
+}
+
+PP(pp_gsbyport)
+{
+#ifdef HAS_GETSERVBYPORT
+ return pp_gservent(ARGS);
+#else
+ DIE(no_sock_func, "getservbyport");
+#endif
+}
+
+PP(pp_gservent)
+{
+ djSP;
+#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
+ I32 which = PL_op->op_type;
+ register char **elem;
+ register SV *sv;
+#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
+ struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
+ struct servent *PerlSock_getservbyport(int, Netdb_name_t);
+ struct servent *PerlSock_getservent(void);
+#endif
+ struct servent *sent;
+
+ if (which == OP_GSBYNAME) {
+#ifdef HAS_GETSERVBYNAME
+ char *proto = POPp;
+ char *name = POPp;
+
+ if (proto && !*proto)
+ proto = Nullch;
+
+ sent = PerlSock_getservbyname(name, proto);
+#else
+ DIE(no_sock_func, "getservbyname");
+#endif
+ }
+ else if (which == OP_GSBYPORT) {
+#ifdef HAS_GETSERVBYPORT
+ char *proto = POPp;
+ unsigned short port = POPu;
+
+#ifdef HAS_HTONS
+ port = PerlSock_htons(port);
+#endif
+ sent = PerlSock_getservbyport(port, proto);
+#else
+ DIE(no_sock_func, "getservbyport");
+#endif
+ }
+ else
+#ifdef HAS_GETSERVENT
+ sent = PerlSock_getservent();
+#else
+ DIE(no_sock_func, "getservent");
+#endif
+
+ EXTEND(SP, 4);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_newmortal());
+ if (sent) {
+ if (which == OP_GSBYNAME) {
+#ifdef HAS_NTOHS
+ sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
+#else
+ sv_setiv(sv, (IV)(sent->s_port));
+#endif
+ }
+ else
+ sv_setpv(sv, sent->s_name);
+ }
+ RETURN;
+ }
+
+ if (sent) {
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setpv(sv, sent->s_name);
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ for (elem = sent->s_aliases; elem && *elem; elem++) {
+ sv_catpv(sv, *elem);
+ if (elem[1])
+ sv_catpvn(sv, " ", 1);
+ }
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+#ifdef HAS_NTOHS
+ sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
+#else
+ sv_setiv(sv, (IV)(sent->s_port));
+#endif
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setpv(sv, sent->s_proto);
+ }
+
+ RETURN;
+#else
+ DIE(no_sock_func, "getservent");
+#endif
+}
+
+PP(pp_shostent)
+{
+ djSP;
+#ifdef HAS_SETHOSTENT
+ PerlSock_sethostent(TOPi);
+ RETSETYES;
+#else
+ DIE(no_sock_func, "sethostent");
+#endif
+}
+
+PP(pp_snetent)
+{
+ djSP;
+#ifdef HAS_SETNETENT
+ PerlSock_setnetent(TOPi);
+ RETSETYES;
+#else
+ DIE(no_sock_func, "setnetent");
+#endif
+}
+
+PP(pp_sprotoent)
+{
+ djSP;
+#ifdef HAS_SETPROTOENT
+ PerlSock_setprotoent(TOPi);
+ RETSETYES;
+#else
+ DIE(no_sock_func, "setprotoent");
+#endif
+}
+
+PP(pp_sservent)
+{
+ djSP;
+#ifdef HAS_SETSERVENT
+ PerlSock_setservent(TOPi);
+ RETSETYES;
+#else
+ DIE(no_sock_func, "setservent");
+#endif
+}
+
+PP(pp_ehostent)
+{
+ djSP;
+#ifdef HAS_ENDHOSTENT
+ PerlSock_endhostent();
+ EXTEND(SP,1);
+ RETPUSHYES;
+#else
+ DIE(no_sock_func, "endhostent");
+#endif
+}
+
+PP(pp_enetent)
+{
+ djSP;
+#ifdef HAS_ENDNETENT
+ PerlSock_endnetent();
+ EXTEND(SP,1);
+ RETPUSHYES;
+#else
+ DIE(no_sock_func, "endnetent");
+#endif
+}
+
+PP(pp_eprotoent)
+{
+ djSP;
+#ifdef HAS_ENDPROTOENT
+ PerlSock_endprotoent();
+ EXTEND(SP,1);
+ RETPUSHYES;
+#else
+ DIE(no_sock_func, "endprotoent");
+#endif
+}
+
+PP(pp_eservent)
+{
+ djSP;
+#ifdef HAS_ENDSERVENT
+ PerlSock_endservent();
+ EXTEND(SP,1);
+ RETPUSHYES;
+#else
+ DIE(no_sock_func, "endservent");
+#endif
+}
+
+PP(pp_gpwnam)
+{
+#ifdef HAS_PASSWD
+ return pp_gpwent(ARGS);
+#else
+ DIE(no_func, "getpwnam");
+#endif
+}
+
+PP(pp_gpwuid)
+{
+#ifdef HAS_PASSWD
+ return pp_gpwent(ARGS);
+#else
+ DIE(no_func, "getpwuid");
+#endif
+}
+
+PP(pp_gpwent)
+{
+ djSP;
+#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
+ I32 which = PL_op->op_type;
+ register SV *sv;
+ struct passwd *pwent;
+
+ if (which == OP_GPWNAM)
+ pwent = getpwnam(POPp);
+ else if (which == OP_GPWUID)
+ pwent = getpwuid(POPi);
+ else
+ pwent = (struct passwd *)getpwent();
+
+ EXTEND(SP, 10);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_newmortal());
+ if (pwent) {
+ if (which == OP_GPWNAM)
+ sv_setiv(sv, (IV)pwent->pw_uid);
+ else
+ sv_setpv(sv, pwent->pw_name);
+ }
+ RETURN;
+ }
+
+ if (pwent) {
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setpv(sv, pwent->pw_name);
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+#ifdef PWPASSWD
+ sv_setpv(sv, pwent->pw_passwd);
+#endif
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)pwent->pw_uid);
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)pwent->pw_gid);
+
+ /* pw_change, pw_quota, and pw_age are mutually exclusive. */
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+#ifdef PWCHANGE
+ sv_setiv(sv, (IV)pwent->pw_change);
+#else
+# ifdef PWQUOTA
+ sv_setiv(sv, (IV)pwent->pw_quota);
+# else
+# ifdef PWAGE
+ sv_setpv(sv, pwent->pw_age);
+# endif
+# endif
+#endif
+
+ /* pw_class and pw_comment are mutually exclusive. */
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+#ifdef PWCLASS
+ sv_setpv(sv, pwent->pw_class);
+#else
+# ifdef PWCOMMENT
+ sv_setpv(sv, pwent->pw_comment);
+# endif
+#endif
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+#ifdef PWGECOS
+ sv_setpv(sv, pwent->pw_gecos);
+#endif
+#ifndef INCOMPLETE_TAINTS
+ /* pw_gecos is tainted because user himself can diddle with it. */
+ SvTAINTED_on(sv);
+#endif
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setpv(sv, pwent->pw_dir);
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setpv(sv, pwent->pw_shell);
+
+#ifdef PWEXPIRE
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)pwent->pw_expire);
+#endif
+ }
+ RETURN;
+#else
+ DIE(no_func, "getpwent");
+#endif
+}
+
+PP(pp_spwent)
+{
+ djSP;
+#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
+ setpwent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "setpwent");
+#endif
+}
+
+PP(pp_epwent)
+{
+ djSP;
+#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
+ endpwent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "endpwent");
+#endif
+}
+
+PP(pp_ggrnam)
+{
+#ifdef HAS_GROUP
+ return pp_ggrent(ARGS);
+#else
+ DIE(no_func, "getgrnam");
+#endif
+}
+
+PP(pp_ggrgid)
+{
+#ifdef HAS_GROUP
+ return pp_ggrent(ARGS);
+#else
+ DIE(no_func, "getgrgid");
+#endif
+}
+
+PP(pp_ggrent)
+{
+ djSP;
+#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
+ I32 which = PL_op->op_type;
+ register char **elem;
+ register SV *sv;
+ struct group *grent;
+
+ if (which == OP_GGRNAM)
+ grent = (struct group *)getgrnam(POPp);
+ else if (which == OP_GGRGID)
+ grent = (struct group *)getgrgid(POPi);
+ else
+ grent = (struct group *)getgrent();
+
+ EXTEND(SP, 4);
+ if (GIMME != G_ARRAY) {
+ PUSHs(sv = sv_newmortal());
+ if (grent) {
+ if (which == OP_GGRNAM)
+ sv_setiv(sv, (IV)grent->gr_gid);
+ else
+ sv_setpv(sv, grent->gr_name);
+ }
+ RETURN;
+ }
+
+ if (grent) {
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setpv(sv, grent->gr_name);
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+#ifdef GRPASSWD
+ sv_setpv(sv, grent->gr_passwd);
+#endif
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ sv_setiv(sv, (IV)grent->gr_gid);
+
+ PUSHs(sv = sv_mortalcopy(&PL_sv_no));
+ for (elem = grent->gr_mem; elem && *elem; elem++) {
+ sv_catpv(sv, *elem);
+ if (elem[1])
+ sv_catpvn(sv, " ", 1);
+ }
+ }
+
+ RETURN;
+#else
+ DIE(no_func, "getgrent");
+#endif
+}
+
+PP(pp_sgrent)
+{
+ djSP;
+#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
+ setgrent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "setgrent");
+#endif
+}
+
+PP(pp_egrent)
+{
+ djSP;
+#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
+ endgrent();
+ RETPUSHYES;
+#else
+ DIE(no_func, "endgrent");
+#endif
+}
+
+PP(pp_getlogin)
+{
+ djSP; dTARGET;
+#ifdef HAS_GETLOGIN
+ char *tmps;
+ EXTEND(SP, 1);
+ if (!(tmps = PerlProc_getlogin()))
+ RETPUSHUNDEF;
+ PUSHp(tmps, strlen(tmps));
+ RETURN;
+#else
+ DIE(no_func, "getlogin");
+#endif
+}
+
+/* Miscellaneous. */
+
+PP(pp_syscall)
+{
+#ifdef HAS_SYSCALL
+ djSP; dMARK; dORIGMARK; dTARGET;
+ register I32 items = SP - MARK;
+ unsigned long a[20];
+ register I32 i = 0;
+ I32 retval = -1;
+ MAGIC *mg;
+
+ if (PL_tainting) {
+ while (++MARK <= SP) {
+ if (SvTAINTED(*MARK)) {
+ TAINT;
+ break;
+ }
+ }
+ MARK = ORIGMARK;
+ TAINT_PROPER("syscall");
+ }
+
+ /* This probably won't work on machines where sizeof(long) != sizeof(int)
+ * or where sizeof(long) != sizeof(char*). But such machines will
+ * not likely have syscall implemented either, so who cares?
+ */
+ while (++MARK <= SP) {
+ if (SvNIOK(*MARK) || !i)
+ a[i++] = SvIV(*MARK);
+ else if (*MARK == &PL_sv_undef)
+ a[i++] = 0;
+ else
+ a[i++] = (unsigned long)SvPV_force(*MARK, PL_na);
+ if (i > 15)
+ break;
+ }
+ switch (items) {
+ default:
+ DIE("Too many args to syscall");
+ case 0:
+ DIE("Too few args to syscall");
+ case 1:
+ retval = syscall(a[0]);
+ break;
+ case 2:
+ retval = syscall(a[0],a[1]);
+ break;
+ case 3:
+ retval = syscall(a[0],a[1],a[2]);
+ break;
+ case 4:
+ retval = syscall(a[0],a[1],a[2],a[3]);
+ break;
+ case 5:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4]);
+ break;
+ case 6:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
+ break;
+ case 7:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
+ break;
+ case 8:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
+ break;
+#ifdef atarist
+ case 9:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
+ break;
+ case 10:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
+ break;
+ case 11:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
+ a[10]);
+ break;
+ case 12:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
+ a[10],a[11]);
+ break;
+ case 13:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
+ a[10],a[11],a[12]);
+ break;
+ case 14:
+ retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
+ a[10],a[11],a[12],a[13]);
+ break;
+#endif /* atarist */
+ }
+ SP = ORIGMARK;
+ PUSHi(retval);
+ RETURN;
+#else
+ DIE(no_func, "syscall");
+#endif
+}
+
+#ifdef FCNTL_EMULATE_FLOCK
+
+/* XXX Emulate flock() with fcntl().
+ What's really needed is a good file locking module.
+*/
+
+static int
+fcntl_emulate_flock(int fd, int operation)
+{
+ struct flock flock;
+
+ switch (operation & ~LOCK_NB) {
+ case LOCK_SH:
+ flock.l_type = F_RDLCK;
+ break;
+ case LOCK_EX:
+ flock.l_type = F_WRLCK;
+ break;
+ case LOCK_UN:
+ flock.l_type = F_UNLCK;
+ break;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+ flock.l_whence = SEEK_SET;
+ flock.l_start = flock.l_len = 0L;
+
+ return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
+}
+
+#endif /* FCNTL_EMULATE_FLOCK */
+
+#ifdef LOCKF_EMULATE_FLOCK
+
+/* XXX Emulate flock() with lockf(). This is just to increase
+ portability of scripts. The calls are not completely
+ interchangeable. What's really needed is a good file
+ locking module.
+*/
+
+/* The lockf() constants might have been defined in <unistd.h>.
+ Unfortunately, <unistd.h> causes troubles on some mixed
+ (BSD/POSIX) systems, such as SunOS 4.1.3.
+
+ Further, the lockf() constants aren't POSIX, so they might not be
+ visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
+ just stick in the SVID values and be done with it. Sigh.
+*/
+
+# ifndef F_ULOCK
+# define F_ULOCK 0 /* Unlock a previously locked region */
+# endif
+# ifndef F_LOCK
+# define F_LOCK 1 /* Lock a region for exclusive use */
+# endif
+# ifndef F_TLOCK
+# define F_TLOCK 2 /* Test and lock a region for exclusive use */
+# endif
+# ifndef F_TEST
+# define F_TEST 3 /* Test a region for other processes locks */
+# endif
+
+static int
+lockf_emulate_flock (fd, operation)
+int fd;
+int operation;
+{
+ int i;
+ int save_errno;
+ Off_t pos;
+
+ /* flock locks entire file so for lockf we need to do the same */
+ save_errno = errno;
+ pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
+ if (pos > 0) /* is seekable and needs to be repositioned */
+ if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
+ pos = -1; /* seek failed, so don't seek back afterwards */
+ errno = save_errno;
+
+ switch (operation) {
+
+ /* LOCK_SH - get a shared lock */
+ case LOCK_SH:
+ /* LOCK_EX - get an exclusive lock */
+ case LOCK_EX:
+ i = lockf (fd, F_LOCK, 0);
+ break;
+
+ /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
+ case LOCK_SH|LOCK_NB:
+ /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
+ case LOCK_EX|LOCK_NB:
+ i = lockf (fd, F_TLOCK, 0);
+ if (i == -1)
+ if ((errno == EAGAIN) || (errno == EACCES))
+ errno = EWOULDBLOCK;
+ break;
+
+ /* LOCK_UN - unlock (non-blocking is a no-op) */
+ case LOCK_UN:
+ case LOCK_UN|LOCK_NB:
+ i = lockf (fd, F_ULOCK, 0);
+ break;
+
+ /* Default - can't decipher operation */
+ default:
+ i = -1;
+ errno = EINVAL;
+ break;
+ }
+
+ if (pos > 0) /* need to restore position of the handle */
+ PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
+
+ return (i);
+}
+
+#endif /* LOCKF_EMULATE_FLOCK */
diff --git a/contrib/perl5/proto.h b/contrib/perl5/proto.h
new file mode 100644
index 000000000000..1b9867552d06
--- /dev/null
+++ b/contrib/perl5/proto.h
@@ -0,0 +1,902 @@
+#ifndef PERL_CALLCONV
+# define PERL_CALLCONV
+#endif
+
+#ifdef PERL_OBJECT
+#define VIRTUAL virtual PERL_CALLCONV
+#else
+#define VIRTUAL PERL_CALLCONV
+START_EXTERN_C
+#endif
+
+/* NOTE!!! When new virtual functions are added, they must be added at
+ * the end of this file to maintain binary compatibility with PERL_OBJECT
+ */
+
+
+#ifndef NEXT30_NO_ATTRIBUTE
+#ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */
+#ifdef __attribute__ /* Avoid possible redefinition errors */
+#undef __attribute__
+#endif
+#define __attribute__(attr)
+#endif
+#endif
+#ifdef OVERLOAD
+VIRTUAL SV* amagic_call _((SV* left,SV* right,int method,int dir));
+VIRTUAL bool Gv_AMupdate _((HV* stash));
+#endif /* OVERLOAD */
+VIRTUAL OP* append_elem _((I32 optype, OP* head, OP* tail));
+VIRTUAL OP* append_list _((I32 optype, LISTOP* first, LISTOP* last));
+VIRTUAL I32 apply _((I32 type, SV** mark, SV** sp));
+VIRTUAL void assertref _((OP* o));
+VIRTUAL bool avhv_exists_ent _((AV *ar, SV* keysv, U32 hash));
+VIRTUAL SV** avhv_fetch_ent _((AV *ar, SV* keysv, I32 lval, U32 hash));
+VIRTUAL HE* avhv_iternext _((AV *ar));
+VIRTUAL SV* avhv_iterval _((AV *ar, HE* entry));
+VIRTUAL HV* avhv_keys _((AV *ar));
+VIRTUAL void av_clear _((AV* ar));
+VIRTUAL void av_extend _((AV* ar, I32 key));
+VIRTUAL AV* av_fake _((I32 size, SV** svp));
+VIRTUAL SV** av_fetch _((AV* ar, I32 key, I32 lval));
+VIRTUAL void av_fill _((AV* ar, I32 fill));
+VIRTUAL I32 av_len _((AV* ar));
+VIRTUAL AV* av_make _((I32 size, SV** svp));
+VIRTUAL SV* av_pop _((AV* ar));
+VIRTUAL void av_push _((AV* ar, SV* val));
+VIRTUAL void av_reify _((AV* ar));
+VIRTUAL SV* av_shift _((AV* ar));
+VIRTUAL SV** av_store _((AV* ar, I32 key, SV* val));
+VIRTUAL void av_undef _((AV* ar));
+VIRTUAL void av_unshift _((AV* ar, I32 num));
+VIRTUAL OP* bind_match _((I32 type, OP* left, OP* pat));
+VIRTUAL OP* block_end _((I32 floor, OP* seq));
+VIRTUAL I32 block_gimme _((void));
+VIRTUAL int block_start _((int full));
+VIRTUAL void boot_core_UNIVERSAL _((void));
+VIRTUAL void call_list _((I32 oldscope, AV* av_list));
+VIRTUAL I32 cando _((I32 bit, I32 effective, Stat_t* statbufp));
+#ifndef CASTNEGFLOAT
+VIRTUAL U32 cast_ulong _((double f));
+#endif
+#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
+VIRTUAL I32 my_chsize _((int fd, Off_t length));
+#endif
+VIRTUAL OP* ck_gvconst _((OP* o));
+VIRTUAL OP* ck_retarget _((OP* o));
+#ifdef USE_THREADS
+VIRTUAL MAGIC * condpair_magic _((SV *sv));
+#endif
+VIRTUAL OP* convert _((I32 optype, I32 flags, OP* o));
+VIRTUAL void croak _((const char* pat,...)) __attribute__((noreturn));
+VIRTUAL void cv_ckproto _((CV* cv, GV* gv, char* p));
+VIRTUAL CV* cv_clone _((CV* proto));
+VIRTUAL SV* cv_const_sv _((CV* cv));
+VIRTUAL SV* op_const_sv _((OP* o, CV* cv));
+VIRTUAL void cv_undef _((CV* cv));
+VIRTUAL void cx_dump _((PERL_CONTEXT* cs));
+VIRTUAL SV* filter_add _((filter_t funcp, SV* datasv));
+VIRTUAL void filter_del _((filter_t funcp));
+VIRTUAL I32 filter_read _((int idx, SV* buffer, int maxlen));
+VIRTUAL char ** get_op_descs _((void));
+VIRTUAL char ** get_op_names _((void));
+VIRTUAL char * get_no_modify _((void));
+VIRTUAL U32 * get_opargs _((void));
+VIRTUAL I32 cxinc _((void));
+VIRTUAL void deb _((const char* pat,...));
+VIRTUAL void deb_growlevel _((void));
+VIRTUAL void debprofdump _((void));
+VIRTUAL I32 debop _((OP* o));
+VIRTUAL I32 debstack _((void));
+VIRTUAL I32 debstackptrs _((void));
+VIRTUAL char* delimcpy _((char* to, char* toend, char* from, char* fromend,
+ int delim, I32* retlen));
+VIRTUAL void deprecate _((char* s));
+VIRTUAL OP* die _((const char* pat,...));
+VIRTUAL OP* die_where _((char* message));
+VIRTUAL void dounwind _((I32 cxix));
+VIRTUAL bool do_aexec _((SV* really, SV** mark, SV** sp));
+VIRTUAL int do_binmode _((PerlIO *fp, int iotype, int flag));
+VIRTUAL void do_chop _((SV* asv, SV* sv));
+VIRTUAL bool do_close _((GV* gv, bool not_implicit));
+VIRTUAL bool do_eof _((GV* gv));
+VIRTUAL bool do_exec _((char* cmd));
+VIRTUAL void do_execfree _((void));
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+I32 do_ipcctl _((I32 optype, SV** mark, SV** sp));
+I32 do_ipcget _((I32 optype, SV** mark, SV** sp));
+#endif
+VIRTUAL void do_join _((SV* sv, SV* del, SV** mark, SV** sp));
+VIRTUAL OP* do_kv _((ARGSproto));
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+I32 do_msgrcv _((SV** mark, SV** sp));
+I32 do_msgsnd _((SV** mark, SV** sp));
+#endif
+VIRTUAL bool do_open _((GV* gv, char* name, I32 len,
+ int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp));
+VIRTUAL void do_pipe _((SV* sv, GV* rgv, GV* wgv));
+VIRTUAL bool do_print _((SV* sv, PerlIO* fp));
+VIRTUAL OP* do_readline _((void));
+VIRTUAL I32 do_chomp _((SV* sv));
+VIRTUAL bool do_seek _((GV* gv, long pos, int whence));
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+I32 do_semop _((SV** mark, SV** sp));
+I32 do_shmio _((I32 optype, SV** mark, SV** sp));
+#endif
+VIRTUAL void do_sprintf _((SV* sv, I32 len, SV** sarg));
+VIRTUAL long do_sysseek _((GV* gv, long pos, int whence));
+VIRTUAL long do_tell _((GV* gv));
+VIRTUAL I32 do_trans _((SV* sv, OP* arg));
+VIRTUAL void do_vecset _((SV* sv));
+VIRTUAL void do_vop _((I32 optype, SV* sv, SV* left, SV* right));
+VIRTUAL I32 dowantarray _((void));
+VIRTUAL void dump_all _((void));
+VIRTUAL void dump_eval _((void));
+#ifdef DUMP_FDS /* See util.c */
+VIRTUAL void dump_fds _((char* s));
+#endif
+VIRTUAL void dump_form _((GV* gv));
+VIRTUAL void dump_gv _((GV* gv));
+#ifdef MYMALLOC
+VIRTUAL void dump_mstats _((char* s));
+#endif
+VIRTUAL void dump_op _((OP* arg));
+VIRTUAL void dump_pm _((PMOP* pm));
+VIRTUAL void dump_packsubs _((HV* stash));
+VIRTUAL void dump_sub _((GV* gv));
+VIRTUAL void fbm_compile _((SV* sv, U32 flags));
+VIRTUAL char* fbm_instr _((unsigned char* big, unsigned char* bigend, SV* littlesv, U32 flags));
+VIRTUAL char* find_script _((char *scriptname, bool dosearch, char **search_ext, I32 flags));
+#ifdef USE_THREADS
+VIRTUAL PADOFFSET find_threadsv _((char *name));
+#endif
+VIRTUAL OP* force_list _((OP* arg));
+VIRTUAL OP* fold_constants _((OP* arg));
+VIRTUAL char* form _((const char* pat, ...));
+VIRTUAL void free_tmps _((void));
+VIRTUAL OP* gen_constant_list _((OP* o));
+VIRTUAL void gp_free _((GV* gv));
+VIRTUAL GP* gp_ref _((GP* gp));
+VIRTUAL GV* gv_AVadd _((GV* gv));
+VIRTUAL GV* gv_HVadd _((GV* gv));
+VIRTUAL GV* gv_IOadd _((GV* gv));
+VIRTUAL GV* gv_autoload4 _((HV* stash, char* name, STRLEN len, I32 method));
+VIRTUAL void gv_check _((HV* stash));
+VIRTUAL void gv_efullname _((SV* sv, GV* gv));
+VIRTUAL void gv_efullname3 _((SV* sv, GV* gv, char* prefix));
+VIRTUAL GV* gv_fetchfile _((char* name));
+VIRTUAL GV* gv_fetchmeth _((HV* stash, char* name, STRLEN len, I32 level));
+VIRTUAL GV* gv_fetchmethod _((HV* stash, char* name));
+VIRTUAL GV* gv_fetchmethod_autoload _((HV* stash, char* name, I32 autoload));
+VIRTUAL GV* gv_fetchpv _((char* name, I32 add, I32 sv_type));
+VIRTUAL void gv_fullname _((SV* sv, GV* gv));
+VIRTUAL void gv_fullname3 _((SV* sv, GV* gv, char* prefix));
+VIRTUAL void gv_init _((GV* gv, HV* stash, char* name, STRLEN len, int multi));
+VIRTUAL HV* gv_stashpv _((char* name, I32 create));
+VIRTUAL HV* gv_stashpvn _((char* name, U32 namelen, I32 create));
+VIRTUAL HV* gv_stashsv _((SV* sv, I32 create));
+VIRTUAL void hv_clear _((HV* tb));
+VIRTUAL void hv_delayfree_ent _((HV* hv, HE* entry));
+VIRTUAL SV* hv_delete _((HV* tb, char* key, U32 klen, I32 flags));
+VIRTUAL SV* hv_delete_ent _((HV* tb, SV* key, I32 flags, U32 hash));
+VIRTUAL bool hv_exists _((HV* tb, char* key, U32 klen));
+VIRTUAL bool hv_exists_ent _((HV* tb, SV* key, U32 hash));
+VIRTUAL SV** hv_fetch _((HV* tb, char* key, U32 klen, I32 lval));
+VIRTUAL HE* hv_fetch_ent _((HV* tb, SV* key, I32 lval, U32 hash));
+VIRTUAL void hv_free_ent _((HV* hv, HE* entry));
+VIRTUAL I32 hv_iterinit _((HV* tb));
+VIRTUAL char* hv_iterkey _((HE* entry, I32* retlen));
+VIRTUAL SV* hv_iterkeysv _((HE* entry));
+VIRTUAL HE* hv_iternext _((HV* tb));
+VIRTUAL SV* hv_iternextsv _((HV* hv, char** key, I32* retlen));
+VIRTUAL SV* hv_iterval _((HV* tb, HE* entry));
+VIRTUAL void hv_ksplit _((HV* hv, IV newmax));
+VIRTUAL void hv_magic _((HV* hv, GV* gv, int how));
+VIRTUAL SV** hv_store _((HV* tb, char* key, U32 klen, SV* val, U32 hash));
+VIRTUAL HE* hv_store_ent _((HV* tb, SV* key, SV* val, U32 hash));
+VIRTUAL void hv_undef _((HV* tb));
+VIRTUAL I32 ibcmp _((char* a, char* b, I32 len));
+VIRTUAL I32 ibcmp_locale _((char* a, char* b, I32 len));
+VIRTUAL I32 ingroup _((I32 testgid, I32 effective));
+VIRTUAL void init_stacks _((ARGSproto));
+VIRTUAL U32 intro_my _((void));
+VIRTUAL char* instr _((char* big, char* little));
+VIRTUAL bool io_close _((IO* io));
+VIRTUAL OP* invert _((OP* cmd));
+VIRTUAL OP* jmaybe _((OP* arg));
+VIRTUAL I32 keyword _((char* d, I32 len));
+VIRTUAL void leave_scope _((I32 base));
+VIRTUAL void lex_end _((void));
+VIRTUAL void lex_start _((SV* line));
+VIRTUAL OP* linklist _((OP* o));
+VIRTUAL OP* list _((OP* o));
+VIRTUAL OP* listkids _((OP* o));
+VIRTUAL OP* localize _((OP* arg, I32 lexical));
+VIRTUAL I32 looks_like_number _((SV* sv));
+VIRTUAL int magic_clearenv _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_clear_all_env _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_clearpack _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_clearsig _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_existspack _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_freeregexp _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_get _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_getarylen _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_getdefelem _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_getglob _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_getnkeys _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_getpack _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_getpos _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_getsig _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_getsubstr _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_gettaint _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_getuvar _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_getvec _((SV* sv, MAGIC* mg));
+VIRTUAL U32 magic_len _((SV* sv, MAGIC* mg));
+#ifdef USE_THREADS
+VIRTUAL int magic_mutexfree _((SV* sv, MAGIC* mg));
+#endif /* USE_THREADS */
+VIRTUAL int magic_nextpack _((SV* sv, MAGIC* mg, SV* key));
+VIRTUAL int magic_set _((SV* sv, MAGIC* mg));
+#ifdef OVERLOAD
+VIRTUAL int magic_setamagic _((SV* sv, MAGIC* mg));
+#endif /* OVERLOAD */
+VIRTUAL int magic_setarylen _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setbm _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setdbline _((SV* sv, MAGIC* mg));
+#ifdef USE_LOCALE_COLLATE
+VIRTUAL int magic_setcollxfrm _((SV* sv, MAGIC* mg));
+#endif
+VIRTUAL int magic_setdefelem _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setenv _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setfm _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setisa _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setglob _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setmglob _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setnkeys _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setpack _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setpos _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setsig _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setsubstr _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_settaint _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setuvar _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_setvec _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_set_all_env _((SV* sv, MAGIC* mg));
+VIRTUAL U32 magic_sizepack _((SV* sv, MAGIC* mg));
+VIRTUAL int magic_wipepack _((SV* sv, MAGIC* mg));
+VIRTUAL void magicname _((char* sym, char* name, I32 namlen));
+int main _((int argc, char** argv, char** env));
+#ifdef MYMALLOC
+VIRTUAL MEM_SIZE malloced_size _((void *p));
+#endif
+VIRTUAL void markstack_grow _((void));
+#ifdef USE_LOCALE_COLLATE
+VIRTUAL char* mem_collxfrm _((const char* s, STRLEN len, STRLEN* xlen));
+#endif
+VIRTUAL char* mess _((const char* pat, va_list* args));
+VIRTUAL int mg_clear _((SV* sv));
+VIRTUAL int mg_copy _((SV* sv, SV* nsv, char* key, I32 klen));
+VIRTUAL MAGIC* mg_find _((SV* sv, int type));
+VIRTUAL int mg_free _((SV* sv));
+VIRTUAL int mg_get _((SV* sv));
+VIRTUAL U32 mg_length _((SV* sv));
+VIRTUAL void mg_magical _((SV* sv));
+VIRTUAL int mg_set _((SV* sv));
+VIRTUAL I32 mg_size _((SV* sv));
+VIRTUAL OP* mod _((OP* o, I32 type));
+VIRTUAL char* moreswitches _((char* s));
+VIRTUAL OP* my _((OP* o));
+#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
+VIRTUAL char* my_bcopy _((char* from, char* to, I32 len));
+#endif
+#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
+char* my_bzero _((char* loc, I32 len));
+#endif
+VIRTUAL void my_exit _((U32 status)) __attribute__((noreturn));
+VIRTUAL void my_failure_exit _((void)) __attribute__((noreturn));
+VIRTUAL I32 my_lstat _((ARGSproto));
+#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
+VIRTUAL I32 my_memcmp _((char* s1, char* s2, I32 len));
+#endif
+#if !defined(HAS_MEMSET)
+VIRTUAL void* my_memset _((char* loc, I32 ch, I32 len));
+#endif
+#ifndef PERL_OBJECT
+VIRTUAL I32 my_pclose _((PerlIO* ptr));
+VIRTUAL PerlIO* my_popen _((char* cmd, char* mode));
+#endif
+VIRTUAL void my_setenv _((char* nam, char* val));
+VIRTUAL I32 my_stat _((ARGSproto));
+#ifdef MYSWAP
+VIRTUAL short my_swap _((short s));
+VIRTUAL long my_htonl _((long l));
+VIRTUAL long my_ntohl _((long l));
+#endif
+VIRTUAL void my_unexec _((void));
+VIRTUAL OP* newANONLIST _((OP* o));
+VIRTUAL OP* newANONHASH _((OP* o));
+VIRTUAL OP* newANONSUB _((I32 floor, OP* proto, OP* block));
+VIRTUAL OP* newASSIGNOP _((I32 flags, OP* left, I32 optype, OP* right));
+VIRTUAL OP* newCONDOP _((I32 flags, OP* expr, OP* trueop, OP* falseop));
+VIRTUAL void newCONSTSUB _((HV* stash, char* name, SV* sv));
+VIRTUAL void newFORM _((I32 floor, OP* o, OP* block));
+VIRTUAL OP* newFOROP _((I32 flags, char* label, line_t forline, OP* sclr, OP* expr, OP*block, OP*cont));
+VIRTUAL OP* newLOGOP _((I32 optype, I32 flags, OP* left, OP* right));
+VIRTUAL OP* newLOOPEX _((I32 type, OP* label));
+VIRTUAL OP* newLOOPOP _((I32 flags, I32 debuggable, OP* expr, OP* block));
+VIRTUAL OP* newNULLLIST _((void));
+VIRTUAL OP* newOP _((I32 optype, I32 flags));
+VIRTUAL void newPROG _((OP* o));
+VIRTUAL OP* newRANGE _((I32 flags, OP* left, OP* right));
+VIRTUAL OP* newSLICEOP _((I32 flags, OP* subscript, OP* list));
+VIRTUAL OP* newSTATEOP _((I32 flags, char* label, OP* o));
+VIRTUAL CV* newSUB _((I32 floor, OP* o, OP* proto, OP* block));
+VIRTUAL CV* newXS _((char* name, void (*subaddr)(CV* cv _CPERLproto), char* filename));
+VIRTUAL AV* newAV _((void));
+VIRTUAL OP* newAVREF _((OP* o));
+VIRTUAL OP* newBINOP _((I32 type, I32 flags, OP* first, OP* last));
+VIRTUAL OP* newCVREF _((I32 flags, OP* o));
+VIRTUAL OP* newGVOP _((I32 type, I32 flags, GV* gv));
+VIRTUAL GV* newGVgen _((char* pack));
+VIRTUAL OP* newGVREF _((I32 type, OP* o));
+VIRTUAL OP* newHVREF _((OP* o));
+VIRTUAL HV* newHV _((void));
+VIRTUAL HV* newHVhv _((HV* hv));
+VIRTUAL IO* newIO _((void));
+VIRTUAL OP* newLISTOP _((I32 type, I32 flags, OP* first, OP* last));
+VIRTUAL OP* newPMOP _((I32 type, I32 flags));
+VIRTUAL OP* newPVOP _((I32 type, I32 flags, char* pv));
+VIRTUAL SV* newRV _((SV* pref));
+VIRTUAL SV* newRV_noinc _((SV *sv));
+VIRTUAL SV* newSV _((STRLEN len));
+VIRTUAL OP* newSVREF _((OP* o));
+VIRTUAL OP* newSVOP _((I32 type, I32 flags, SV* sv));
+VIRTUAL SV* newSViv _((IV i));
+VIRTUAL SV* newSVnv _((double n));
+VIRTUAL SV* newSVpv _((char* s, STRLEN len));
+VIRTUAL SV* newSVpvn _((char *s, STRLEN len));
+VIRTUAL SV* newSVpvf _((const char* pat, ...));
+VIRTUAL SV* newSVrv _((SV* rv, char* classname));
+VIRTUAL SV* newSVsv _((SV* old));
+VIRTUAL OP* newUNOP _((I32 type, I32 flags, OP* first));
+VIRTUAL OP* newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop,
+ I32 whileline, OP* expr, OP* block, OP* cont));
+#ifdef USE_THREADS
+VIRTUAL struct perl_thread * new_struct_thread _((struct perl_thread *t));
+#endif
+VIRTUAL PERL_SI * new_stackinfo _((I32 stitems, I32 cxitems));
+VIRTUAL PerlIO* nextargv _((GV* gv));
+VIRTUAL char* ninstr _((char* big, char* bigend, char* little, char* lend));
+VIRTUAL OP* oopsCV _((OP* o));
+VIRTUAL void op_free _((OP* arg));
+VIRTUAL void package _((OP* o));
+VIRTUAL PADOFFSET pad_alloc _((I32 optype, U32 tmptype));
+VIRTUAL PADOFFSET pad_allocmy _((char* name));
+VIRTUAL PADOFFSET pad_findmy _((char* name));
+VIRTUAL OP* oopsAV _((OP* o));
+VIRTUAL OP* oopsHV _((OP* o));
+VIRTUAL void pad_leavemy _((I32 fill));
+VIRTUAL SV* pad_sv _((PADOFFSET po));
+VIRTUAL void pad_free _((PADOFFSET po));
+VIRTUAL void pad_reset _((void));
+VIRTUAL void pad_swipe _((PADOFFSET po));
+VIRTUAL void peep _((OP* o));
+#ifndef PERL_OBJECT
+PerlInterpreter* perl_alloc _((void));
+#endif
+#ifdef PERL_OBJECT
+VIRTUAL void perl_atexit _((void(*fn)(CPerlObj *, void *), void* ptr));
+#else
+void perl_atexit _((void(*fn)(void *), void*));
+#endif
+VIRTUAL I32 perl_call_argv _((char* sub_name, I32 flags, char** argv));
+VIRTUAL I32 perl_call_method _((char* methname, I32 flags));
+VIRTUAL I32 perl_call_pv _((char* sub_name, I32 flags));
+VIRTUAL I32 perl_call_sv _((SV* sv, I32 flags));
+#ifdef PERL_OBJECT
+VIRTUAL void perl_construct _((void));
+VIRTUAL void perl_destruct _((void));
+#else
+void perl_construct _((PerlInterpreter* sv_interp));
+void perl_destruct _((PerlInterpreter* sv_interp));
+#endif
+VIRTUAL SV* perl_eval_pv _((char* p, I32 croak_on_error));
+VIRTUAL I32 perl_eval_sv _((SV* sv, I32 flags));
+#ifdef PERL_OBJECT
+VIRTUAL void perl_free _((void));
+#else
+void perl_free _((PerlInterpreter* sv_interp));
+#endif
+VIRTUAL SV* perl_get_sv _((char* name, I32 create));
+VIRTUAL AV* perl_get_av _((char* name, I32 create));
+VIRTUAL HV* perl_get_hv _((char* name, I32 create));
+VIRTUAL CV* perl_get_cv _((char* name, I32 create));
+VIRTUAL int perl_init_i18nl10n _((int printwarn));
+VIRTUAL int perl_init_i18nl14n _((int printwarn));
+VIRTUAL void perl_new_collate _((char* newcoll));
+VIRTUAL void perl_new_ctype _((char* newctype));
+VIRTUAL void perl_new_numeric _((char* newcoll));
+VIRTUAL void perl_set_numeric_local _((void));
+VIRTUAL void perl_set_numeric_standard _((void));
+#ifdef PERL_OBJECT
+VIRTUAL int perl_parse _((void(*xsinit)(CPerlObj*), int argc, char** argv, char** env));
+#else
+int perl_parse _((PerlInterpreter* sv_interp, void(*xsinit)(void), int argc, char** argv, char** env));
+#endif
+VIRTUAL void perl_require_pv _((char* pv));
+#define perl_requirepv perl_require_pv
+#ifdef PERL_OBJECT
+VIRTUAL int perl_run _((void));
+#else
+int perl_run _((PerlInterpreter* sv_interp));
+#endif
+VIRTUAL void pidgone _((int pid, int status));
+VIRTUAL void pmflag _((U16* pmfl, int ch));
+VIRTUAL OP* pmruntime _((OP* pm, OP* expr, OP* repl));
+VIRTUAL OP* pmtrans _((OP* o, OP* expr, OP* repl));
+VIRTUAL OP* pop_return _((void));
+VIRTUAL void pop_scope _((void));
+VIRTUAL OP* prepend_elem _((I32 optype, OP* head, OP* tail));
+VIRTUAL void push_return _((OP* o));
+VIRTUAL void push_scope _((void));
+VIRTUAL OP* ref _((OP* o, I32 type));
+VIRTUAL OP* refkids _((OP* o, I32 type));
+VIRTUAL void regdump _((regexp* r));
+VIRTUAL I32 pregexec _((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, U32 nosave));
+VIRTUAL void pregfree _((struct regexp* r));
+VIRTUAL regexp* pregcomp _((char* exp, char* xend, PMOP* pm));
+VIRTUAL I32 regexec_flags _((regexp* prog, char* stringarg, char* strend,
+ char* strbeg, I32 minend, SV* screamer,
+ void* data, U32 flags));
+VIRTUAL regnode* regnext _((regnode* p));
+VIRTUAL void regprop _((SV* sv, regnode* o));
+VIRTUAL void repeatcpy _((char* to, char* from, I32 len, I32 count));
+VIRTUAL char* rninstr _((char* big, char* bigend, char* little, char* lend));
+VIRTUAL Sighandler_t rsignal _((int i, Sighandler_t t));
+VIRTUAL int rsignal_restore _((int i, Sigsave_t* t));
+VIRTUAL int rsignal_save _((int i, Sighandler_t t1, Sigsave_t* t2));
+VIRTUAL Sighandler_t rsignal_state _((int i));
+VIRTUAL void rxres_free _((void** rsp));
+VIRTUAL void rxres_restore _((void** rsp, REGEXP* prx));
+VIRTUAL void rxres_save _((void** rsp, REGEXP* prx));
+#ifndef HAS_RENAME
+VIRTUAL I32 same_dirent _((char* a, char* b));
+#endif
+VIRTUAL char* savepv _((char* sv));
+VIRTUAL char* savepvn _((char* sv, I32 len));
+VIRTUAL void savestack_grow _((void));
+VIRTUAL void save_aelem _((AV* av, I32 idx, SV **sptr));
+VIRTUAL void save_aptr _((AV** aptr));
+VIRTUAL AV* save_ary _((GV* gv));
+VIRTUAL void save_clearsv _((SV** svp));
+VIRTUAL void save_delete _((HV* hv, char* key, I32 klen));
+#ifndef titan /* TitanOS cc can't handle this */
+#ifdef PERL_OBJECT
+typedef void (CPerlObj::*DESTRUCTORFUNC) _((void*));
+VIRTUAL void save_destructor _((DESTRUCTORFUNC f, void* p));
+#else
+void save_destructor _((void (*f)(void*), void* p));
+#endif
+#endif /* titan */
+VIRTUAL void save_freesv _((SV* sv));
+VIRTUAL void save_freeop _((OP* o));
+VIRTUAL void save_freepv _((char* pv));
+VIRTUAL void save_gp _((GV* gv, I32 empty));
+VIRTUAL HV* save_hash _((GV* gv));
+VIRTUAL void save_helem _((HV* hv, SV *key, SV **sptr));
+VIRTUAL void save_hints _((void));
+VIRTUAL void save_hptr _((HV** hptr));
+VIRTUAL void save_I16 _((I16* intp));
+VIRTUAL void save_I32 _((I32* intp));
+VIRTUAL void save_int _((int* intp));
+VIRTUAL void save_item _((SV* item));
+VIRTUAL void save_iv _((IV* iv));
+VIRTUAL void save_list _((SV** sarg, I32 maxsarg));
+VIRTUAL void save_long _((long* longp));
+VIRTUAL void save_nogv _((GV* gv));
+VIRTUAL void save_op _((void));
+VIRTUAL SV* save_scalar _((GV* gv));
+VIRTUAL void save_pptr _((char** pptr));
+VIRTUAL void save_sptr _((SV** sptr));
+VIRTUAL SV* save_svref _((SV** sptr));
+VIRTUAL SV** save_threadsv _((PADOFFSET i));
+VIRTUAL OP* sawparens _((OP* o));
+VIRTUAL OP* scalar _((OP* o));
+VIRTUAL OP* scalarkids _((OP* o));
+VIRTUAL OP* scalarseq _((OP* o));
+VIRTUAL OP* scalarvoid _((OP* o));
+VIRTUAL UV scan_hex _((char* start, I32 len, I32* retlen));
+VIRTUAL char* scan_num _((char* s));
+VIRTUAL UV scan_oct _((char* start, I32 len, I32* retlen));
+VIRTUAL OP* scope _((OP* o));
+VIRTUAL char* screaminstr _((SV* bigsv, SV* littlesv, I32 start_shift, I32 end_shift, I32 *state, I32 last));
+#ifndef VMS
+VIRTUAL I32 setenv_getix _((char* nam));
+#endif
+VIRTUAL void setdefout _((GV* gv));
+VIRTUAL char* sharepvn _((char* sv, I32 len, U32 hash));
+VIRTUAL HEK* share_hek _((char* sv, I32 len, U32 hash));
+VIRTUAL Signal_t sighandler _((int sig));
+VIRTUAL SV** stack_grow _((SV** sp, SV**p, int n));
+VIRTUAL I32 start_subparse _((I32 is_format, U32 flags));
+VIRTUAL void sub_crush_depth _((CV* cv));
+VIRTUAL bool sv_2bool _((SV* sv));
+VIRTUAL CV* sv_2cv _((SV* sv, HV** st, GV** gvp, I32 lref));
+VIRTUAL IO* sv_2io _((SV* sv));
+VIRTUAL IV sv_2iv _((SV* sv));
+VIRTUAL SV* sv_2mortal _((SV* sv));
+VIRTUAL double sv_2nv _((SV* sv));
+VIRTUAL char* sv_2pv _((SV* sv, STRLEN* lp));
+VIRTUAL UV sv_2uv _((SV* sv));
+VIRTUAL IV sv_iv _((SV* sv));
+VIRTUAL UV sv_uv _((SV* sv));
+VIRTUAL double sv_nv _((SV* sv));
+VIRTUAL char * sv_pvn _((SV *sv, STRLEN *len));
+VIRTUAL I32 sv_true _((SV *sv));
+VIRTUAL void sv_add_arena _((char* ptr, U32 size, U32 flags));
+VIRTUAL int sv_backoff _((SV* sv));
+VIRTUAL SV* sv_bless _((SV* sv, HV* stash));
+VIRTUAL void sv_catpvf _((SV* sv, const char* pat, ...));
+VIRTUAL void sv_catpv _((SV* sv, char* ptr));
+VIRTUAL void sv_catpvn _((SV* sv, char* ptr, STRLEN len));
+VIRTUAL void sv_catsv _((SV* dsv, SV* ssv));
+VIRTUAL void sv_chop _((SV* sv, char* ptr));
+VIRTUAL void sv_clean_all _((void));
+VIRTUAL void sv_clean_objs _((void));
+VIRTUAL void sv_clear _((SV* sv));
+VIRTUAL I32 sv_cmp _((SV* sv1, SV* sv2));
+VIRTUAL I32 sv_cmp_locale _((SV* sv1, SV* sv2));
+#ifdef USE_LOCALE_COLLATE
+VIRTUAL char* sv_collxfrm _((SV* sv, STRLEN* nxp));
+#endif
+VIRTUAL OP* sv_compile_2op _((SV* sv, OP** startp, char* code, AV** avp));
+VIRTUAL void sv_dec _((SV* sv));
+VIRTUAL void sv_dump _((SV* sv));
+VIRTUAL bool sv_derived_from _((SV* sv, char* name));
+VIRTUAL I32 sv_eq _((SV* sv1, SV* sv2));
+VIRTUAL void sv_free _((SV* sv));
+VIRTUAL void sv_free_arenas _((void));
+VIRTUAL char* sv_gets _((SV* sv, PerlIO* fp, I32 append));
+#ifndef DOSISH
+VIRTUAL char* sv_grow _((SV* sv, I32 newlen));
+#else
+VIRTUAL char* sv_grow _((SV* sv, unsigned long newlen));
+#endif
+VIRTUAL void sv_inc _((SV* sv));
+VIRTUAL void sv_insert _((SV* bigsv, STRLEN offset, STRLEN len, char* little, STRLEN littlelen));
+VIRTUAL int sv_isa _((SV* sv, char* name));
+VIRTUAL int sv_isobject _((SV* sv));
+VIRTUAL STRLEN sv_len _((SV* sv));
+VIRTUAL void sv_magic _((SV* sv, SV* obj, int how, char* name, I32 namlen));
+VIRTUAL SV* sv_mortalcopy _((SV* oldsv));
+VIRTUAL SV* sv_newmortal _((void));
+VIRTUAL SV* sv_newref _((SV* sv));
+VIRTUAL char* sv_peek _((SV* sv));
+VIRTUAL char* sv_pvn_force _((SV* sv, STRLEN* lp));
+VIRTUAL char* sv_reftype _((SV* sv, int ob));
+VIRTUAL void sv_replace _((SV* sv, SV* nsv));
+VIRTUAL void sv_report_used _((void));
+VIRTUAL void sv_reset _((char* s, HV* stash));
+VIRTUAL void sv_setpvf _((SV* sv, const char* pat, ...));
+VIRTUAL void sv_setiv _((SV* sv, IV num));
+VIRTUAL void sv_setpviv _((SV* sv, IV num));
+VIRTUAL void sv_setuv _((SV* sv, UV num));
+VIRTUAL void sv_setnv _((SV* sv, double num));
+VIRTUAL SV* sv_setref_iv _((SV* rv, char* classname, IV iv));
+VIRTUAL SV* sv_setref_nv _((SV* rv, char* classname, double nv));
+VIRTUAL SV* sv_setref_pv _((SV* rv, char* classname, void* pv));
+VIRTUAL SV* sv_setref_pvn _((SV* rv, char* classname, char* pv, I32 n));
+VIRTUAL void sv_setpv _((SV* sv, const char* ptr));
+VIRTUAL void sv_setpvn _((SV* sv, const char* ptr, STRLEN len));
+VIRTUAL void sv_setsv _((SV* dsv, SV* ssv));
+VIRTUAL void sv_taint _((SV* sv));
+VIRTUAL bool sv_tainted _((SV* sv));
+VIRTUAL int sv_unmagic _((SV* sv, int type));
+VIRTUAL void sv_unref _((SV* sv));
+VIRTUAL void sv_untaint _((SV* sv));
+VIRTUAL bool sv_upgrade _((SV* sv, U32 mt));
+VIRTUAL void sv_usepvn _((SV* sv, char* ptr, STRLEN len));
+VIRTUAL void sv_vcatpvfn _((SV* sv, const char* pat, STRLEN patlen,
+ va_list* args, SV** svargs, I32 svmax,
+ bool *used_locale));
+VIRTUAL void sv_vsetpvfn _((SV* sv, const char* pat, STRLEN patlen,
+ va_list* args, SV** svargs, I32 svmax,
+ bool *used_locale));
+VIRTUAL void taint_env _((void));
+VIRTUAL void taint_proper _((const char* f, char* s));
+#ifdef UNLINK_ALL_VERSIONS
+VIRTUAL I32 unlnk _((char* f));
+#endif
+#ifdef USE_THREADS
+VIRTUAL void unlock_condpair _((void* svv));
+#endif
+VIRTUAL void unsharepvn _((char* sv, I32 len, U32 hash));
+VIRTUAL void unshare_hek _((HEK* hek));
+VIRTUAL void utilize _((int aver, I32 floor, OP* version, OP* id, OP* arg));
+VIRTUAL void vivify_defelem _((SV* sv));
+VIRTUAL void vivify_ref _((SV* sv, U32 to_what));
+VIRTUAL I32 wait4pid _((int pid, int* statusp, int flags));
+VIRTUAL void warn _((const char* pat,...));
+VIRTUAL void watch _((char** addr));
+VIRTUAL I32 whichsig _((char* sig));
+VIRTUAL int yyerror _((char* s));
+VIRTUAL int yylex _((void));
+VIRTUAL int yyparse _((void));
+VIRTUAL int yywarn _((char* s));
+
+#ifndef MYMALLOC
+VIRTUAL Malloc_t safemalloc _((MEM_SIZE nbytes));
+VIRTUAL Malloc_t safecalloc _((MEM_SIZE elements, MEM_SIZE size));
+VIRTUAL Malloc_t saferealloc _((Malloc_t where, MEM_SIZE nbytes));
+VIRTUAL Free_t safefree _((Malloc_t where));
+#endif
+
+#ifdef LEAKTEST
+VIRTUAL Malloc_t safexmalloc _((I32 x, MEM_SIZE size));
+VIRTUAL Malloc_t safexcalloc _((I32 x, MEM_SIZE elements, MEM_SIZE size));
+VIRTUAL Malloc_t safexrealloc _((Malloc_t where, MEM_SIZE size));
+VIRTUAL void safexfree _((Malloc_t where));
+#endif
+
+#ifdef PERL_GLOBAL_STRUCT
+VIRTUAL struct perl_vars *Perl_GetVars _((void));
+#endif
+
+#ifdef PERL_OBJECT
+protected:
+void hsplit _((HV *hv));
+void hfreeentries _((HV *hv));
+HE* more_he _((void));
+HE* new_he _((void));
+void del_he _((HE *p));
+HEK *save_hek _((char *str, I32 len, U32 hash));
+SV *mess_alloc _((void));
+void gv_init_sv _((GV *gv, I32 sv_type));
+SV *save_scalar_at _((SV **sptr));
+IV asIV _((SV* sv));
+UV asUV _((SV* sv));
+SV *more_sv _((void));
+XPVIV *more_xiv _((void));
+XPVNV *more_xnv _((void));
+XPV *more_xpv _((void));
+XRV *more_xrv _((void));
+XPVIV *new_xiv _((void));
+XPVNV *new_xnv _((void));
+XPV *new_xpv _((void));
+XRV *new_xrv _((void));
+void del_xiv _((XPVIV* p));
+void del_xnv _((XPVNV* p));
+void del_xpv _((XPV* p));
+void del_xrv _((XRV* p));
+void sv_mortalgrow _((void));
+void sv_unglob _((SV* sv));
+void sv_check_thinkfirst _((SV *sv));
+I32 avhv_index_sv _((SV* sv));
+
+void do_report_used _((SV *sv));
+void do_clean_objs _((SV *sv));
+void do_clean_named_objs _((SV *sv));
+void do_clean_all _((SV *sv));
+void not_a_number _((SV *sv));
+void* my_safemalloc _((MEM_SIZE size));
+
+typedef void (CPerlObj::*SVFUNC) _((SV*));
+void visit _((SVFUNC f));
+
+typedef I32 (CPerlObj::*SVCOMPARE) _((SV*, SV*));
+void qsortsv _((SV ** array, size_t num_elts, SVCOMPARE f));
+I32 sortcv _((SV *a, SV *b));
+void save_magic _((MGS *mgs, SV *sv));
+int magic_methpack _((SV *sv, MAGIC *mg, char *meth));
+int magic_methcall _((MAGIC *mg, char *meth, I32 flags, int n, SV *val));
+OP * doform _((CV *cv, GV *gv, OP *retop));
+void doencodes _((SV* sv, char* s, I32 len));
+SV* refto _((SV* sv));
+U32 seed _((void));
+OP *docatch _((OP *o));
+OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
+void doparseform _((SV *sv));
+I32 dopoptoeval _((I32 startingblock));
+I32 dopoptolabel _((char *label));
+I32 dopoptoloop _((I32 startingblock));
+I32 dopoptosub _((I32 startingblock));
+I32 dopoptosub_at _((PERL_CONTEXT* cxstk, I32 startingblock));
+void save_lines _((AV *array, SV *sv));
+OP *doeval _((int gimme, OP** startop));
+SV *mul128 _((SV *sv, U8 m));
+SV *is_an_int _((char *s, STRLEN l));
+int div128 _((SV *pnum, bool *done));
+
+int runops_standard _((void));
+int runops_debug _((void));
+
+void check_uni _((void));
+void force_next _((I32 type));
+char *force_version _((char *start));
+char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
+SV *tokeq _((SV *sv));
+char *scan_const _((char *start));
+char *scan_formline _((char *s));
+char *scan_heredoc _((char *s));
+char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen, I32 ck_uni));
+char *scan_inputsymbol _((char *start));
+char *scan_pat _((char *start, I32 type));
+char *scan_str _((char *start));
+char *scan_subst _((char *start));
+char *scan_trans _((char *start));
+char *scan_word _((char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp));
+char *skipspace _((char *s));
+void checkcomma _((char *s, char *name, char *what));
+void force_ident _((char *s, int kind));
+void incline _((char *s));
+int intuit_method _((char *s, GV *gv));
+int intuit_more _((char *s));
+I32 lop _((I32 f, expectation x, char *s));
+void missingterm _((char *s));
+void no_op _((char *what, char *s));
+void set_csh _((void));
+I32 sublex_done _((void));
+I32 sublex_push _((void));
+I32 sublex_start _((void));
+#ifdef CRIPPLED_CC
+int uni _((I32 f, char *s));
+#endif
+char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
+SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
+int ao _((int toketype));
+void depcom _((void));
+#ifdef WIN32
+I32 win32_textfilter _((int idx, SV *sv, int maxlen));
+#endif
+char* incl_perldb _((void));
+SV *isa_lookup _((HV *stash, char *name, int len, int level));
+CV *get_db_sub _((SV **svp, CV *cv));
+I32 list_assignment _((OP *o));
+void bad_type _((I32 n, char *t, char *name, OP *kid));
+OP *modkids _((OP *o, I32 type));
+OP *no_fh_allowed _((OP *o));
+OP *scalarboolean _((OP *o));
+OP *too_few_arguments _((OP *o, char* name));
+OP *too_many_arguments _((OP *o, char* name));
+void null _((OP* o));
+PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix));
+OP *newDEFSVOP _((void));
+char* gv_ename _((GV *gv));
+CV *cv_clone2 _((CV *proto, CV *outside));
+
+void find_beginning _((void));
+void forbid_setid _((char *));
+void incpush _((char *, int));
+void init_interp _((void));
+void init_ids _((void));
+void init_debugger _((void));
+void init_lexer _((void));
+void init_main_stash _((void));
+#ifdef USE_THREADS
+struct perl_thread * init_main_thread _((void));
+#endif /* USE_THREADS */
+void init_perllib _((void));
+void init_postdump_symbols _((int, char **, char **));
+void init_predump_symbols _((void));
+void my_exit_jump _((void)) __attribute__((noreturn));
+void nuke_stacks _((void));
+void open_script _((char *, bool, SV *, int *fd));
+void usage _((char *));
+void validate_suid _((char *, char*, int));
+
+regnode *reg _((I32, I32 *));
+regnode *reganode _((U8, U32));
+regnode *regatom _((I32 *));
+regnode *regbranch _((I32 *, I32));
+void regc _((U8, char *));
+regnode *regclass _((void));
+I32 regcurly _((char *));
+regnode *reg_node _((U8));
+regnode *regpiece _((I32 *));
+void reginsert _((U8, regnode *));
+void regoptail _((regnode *, regnode *));
+void regset _((char *, I32));
+void regtail _((regnode *, regnode *));
+char* regwhite _((char *, char *));
+char* nextchar _((void));
+regnode *dumpuntil _((regnode *start, regnode *node, regnode *last, SV* sv, I32 l));
+void scan_commit _((scan_data_t *data));
+I32 study_chunk _((regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags));
+I32 add_data _((I32 n, char *s));
+void re_croak2 _((const char* pat1,const char* pat2,...)) __attribute__((noreturn));
+I32 regmatch _((regnode *prog));
+I32 regrepeat _((regnode *p, I32 max));
+I32 regrepeat_hard _((regnode *p, I32 max, I32 *lp));
+I32 regtry _((regexp *prog, char *startpos));
+bool reginclass _((char *p, I32 c));
+CHECKPOINT regcppush _((I32 parenfloor));
+char * regcppop _((void));
+void dump _((char *pat,...));
+#ifdef WIN32
+int do_aspawn _((void *vreally, void **vmark, void **vsp));
+#endif
+
+#ifdef DEBUGGING
+void del_sv _((SV *p));
+#endif
+void debprof _((OP *o));
+
+void *bset_obj_store _((void *obj, I32 ix));
+OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
+
+#define PPDEF(s) OP* CPerlObj::s _((ARGSproto));
+public:
+
+#include "pp_proto.h"
+
+OP * ck_ftst _((OP *o));
+OP *ck_anoncode _((OP *o));
+OP *ck_bitop _((OP *o));
+OP *ck_concat _((OP *o));
+OP *ck_spair _((OP *o));
+OP *ck_delete _((OP *o));
+OP *ck_eof _((OP *o));
+OP *ck_eval _((OP *o));
+OP *ck_exec _((OP *o));
+OP *ck_exists _((OP *o));
+OP *ck_rvconst _((OP *o));
+OP *ck_fun _((OP *o));
+OP *ck_glob _((OP *o));
+OP *ck_grep _((OP *o));
+OP *ck_index _((OP *o));
+OP *ck_lengthconst _((OP *o));
+OP *ck_lfun _((OP *o));
+OP *ck_rfun _((OP *o));
+OP *ck_listiob _((OP *o));
+OP *ck_fun_locale _((OP *o));
+OP *ck_scmp _((OP *o));
+OP *ck_match _((OP *o));
+OP *ck_null _((OP *o));
+OP *ck_repeat _((OP *o));
+OP *ck_require _((OP *o));
+OP *ck_select _((OP *o));
+OP *ck_shift _((OP *o));
+OP *ck_sort _((OP *o));
+OP *ck_split _((OP *o));
+OP *ck_subr _((OP *o));
+OP *ck_svconst _((OP *o));
+OP *ck_trunc _((OP *o));
+void unwind_handler_stack _((void *p));
+void restore_magic _((void *p));
+void restore_rsfp _((void *f));
+void restore_expect _((void *e));
+void restore_lex_expect _((void *e));
+void yydestruct _((void *ptr));
+VIRTUAL int fprintf _((PerlIO *pf, const char *pat, ...));
+VIRTUAL SV** get_specialsv_list _((void));
+
+#ifdef WIN32
+VIRTUAL int& ErrorNo _((void));
+#endif /* WIN32 */
+#else /* !PERL_OBJECT */
+END_EXTERN_C
+#endif /* PERL_OBJECT */
+
+#ifdef INDIRECT_BGET_MACROS
+VIRTUAL void byterun _((struct bytestream bs));
+#else
+VIRTUAL void byterun _((PerlIO *fp));
+#endif /* INDIRECT_BGET_MACROS */
+
+VIRTUAL void sv_catpvf_mg _((SV *sv, const char* pat, ...));
+VIRTUAL void sv_catpv_mg _((SV *sv, char *ptr));
+VIRTUAL void sv_catpvn_mg _((SV *sv, char *ptr, STRLEN len));
+VIRTUAL void sv_catsv_mg _((SV *dstr, SV *sstr));
+VIRTUAL void sv_setpvf_mg _((SV *sv, const char* pat, ...));
+VIRTUAL void sv_setiv_mg _((SV *sv, IV i));
+VIRTUAL void sv_setpviv_mg _((SV *sv, IV iv));
+VIRTUAL void sv_setuv_mg _((SV *sv, UV u));
+VIRTUAL void sv_setnv_mg _((SV *sv, double num));
+VIRTUAL void sv_setpv_mg _((SV *sv, const char *ptr));
+VIRTUAL void sv_setpvn_mg _((SV *sv, const char *ptr, STRLEN len));
+VIRTUAL void sv_setsv_mg _((SV *dstr, SV *sstr));
+VIRTUAL void sv_usepvn_mg _((SV *sv, char *ptr, STRLEN len));
+
+/* New virtual functions must be added here to maintain binary
+ * compatablity with PERL_OBJECT
+ */
+
diff --git a/contrib/perl5/regcomp.c b/contrib/perl5/regcomp.c
new file mode 100644
index 000000000000..f2f51a442011
--- /dev/null
+++ b/contrib/perl5/regcomp.c
@@ -0,0 +1,2672 @@
+/* regcomp.c
+ */
+
+/*
+ * "A fair jaw-cracker dwarf-language must be." --Samwise Gamgee
+ */
+
+/* NOTE: this is derived from Henry Spencer's regexp code, and should not
+ * confused with the original package (see point 3 below). Thanks, Henry!
+ */
+
+/* Additional note: this code is very heavily munged from Henry's version
+ * in places. In some spots I've traded clarity for efficiency, so don't
+ * blame Henry for some of the lack of readability.
+ */
+
+/* The names of the functions have been changed from regcomp and
+ * regexec to pregcomp and pregexec in order to avoid conflicts
+ * with the POSIX routines of the same names.
+*/
+
+#ifdef PERL_EXT_RE_BUILD
+/* need to replace pregcomp et al, so enable that */
+# ifndef PERL_IN_XSUB_RE
+# define PERL_IN_XSUB_RE
+# endif
+/* need access to debugger hooks */
+# ifndef DEBUGGING
+# define DEBUGGING
+# endif
+#endif
+
+#ifdef PERL_IN_XSUB_RE
+/* We *really* need to overwrite these symbols: */
+# define Perl_pregcomp my_regcomp
+# define Perl_regdump my_regdump
+# define Perl_regprop my_regprop
+/* *These* symbols are masked to allow static link. */
+# define Perl_pregfree my_regfree
+# define Perl_regnext my_regnext
+#endif
+
+/*SUPPRESS 112*/
+/*
+ * pregcomp and pregexec -- regsub and regerror are not used in perl
+ *
+ * Copyright (c) 1986 by University of Toronto.
+ * Written by Henry Spencer. Not derived from licensed software.
+ *
+ * Permission is granted to anyone to use this software for any
+ * purpose on any computer system, and to redistribute it freely,
+ * subject to the following restrictions:
+ *
+ * 1. The author is not responsible for the consequences of use of
+ * this software, no matter how awful, even if they arise
+ * from defects in it.
+ *
+ * 2. The origin of this software must not be misrepresented, either
+ * by explicit claim or by omission.
+ *
+ * 3. Altered versions must be plainly marked as such, and must not
+ * be misrepresented as being the original software.
+ *
+ *
+ **** Alterations to Henry's code are...
+ ****
+ **** Copyright (c) 1991-1997, Larry Wall
+ ****
+ **** You may distribute under the terms of either the GNU General Public
+ **** License or the Artistic License, as specified in the README file.
+
+ *
+ * Beware that some of this code is subtly aware of the way operator
+ * precedence is structured in regular expressions. Serious changes in
+ * regular-expression syntax might require a total rethink.
+ */
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifndef PERL_IN_XSUB_RE
+# include "INTERN.h"
+#endif
+
+#define REG_COMP_C
+#include "regcomp.h"
+
+#ifdef op
+#undef op
+#endif /* op */
+
+#ifdef MSDOS
+# if defined(BUGGY_MSC6)
+ /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
+ # pragma optimize("a",off)
+ /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
+ # pragma optimize("w",on )
+# endif /* BUGGY_MSC6 */
+#endif /* MSDOS */
+
+#ifndef STATIC
+#define STATIC static
+#endif
+
+#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
+#define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
+ ((*s) == '{' && regcurly(s)))
+#ifdef atarist
+#define PERL_META "^$.[()|?+*\\"
+#else
+#define META "^$.[()|?+*\\"
+#endif
+
+#ifdef SPSTART
+#undef SPSTART /* dratted cpp namespace... */
+#endif
+/*
+ * Flags to be passed up and down.
+ */
+#define WORST 0 /* Worst case. */
+#define HASWIDTH 0x1 /* Known to match non-null strings. */
+#define SIMPLE 0x2 /* Simple enough to be STAR/PLUS operand. */
+#define SPSTART 0x4 /* Starts with * or +. */
+#define TRYAGAIN 0x8 /* Weeded out a declaration. */
+
+/*
+ * Forward declarations for pregcomp()'s friends.
+ */
+
+#ifndef PERL_OBJECT
+static regnode *reg _((I32, I32 *));
+static regnode *reganode _((U8, U32));
+static regnode *regatom _((I32 *));
+static regnode *regbranch _((I32 *, I32));
+static void regc _((U8, char *));
+static regnode *regclass _((void));
+STATIC I32 regcurly _((char *));
+static regnode *reg_node _((U8));
+static regnode *regpiece _((I32 *));
+static void reginsert _((U8, regnode *));
+static void regoptail _((regnode *, regnode *));
+static void regtail _((regnode *, regnode *));
+static char* regwhite _((char *, char *));
+static char* nextchar _((void));
+static void re_croak2 _((const char* pat1,const char* pat2,...)) __attribute__((noreturn));
+#endif
+
+/* Length of a variant. */
+
+#ifndef PERL_OBJECT
+typedef struct {
+ I32 len_min;
+ I32 len_delta;
+ I32 pos_min;
+ I32 pos_delta;
+ SV *last_found;
+ I32 last_end; /* min value, <0 unless valid. */
+ I32 last_start_min;
+ I32 last_start_max;
+ SV **longest; /* Either &l_fixed, or &l_float. */
+ SV *longest_fixed;
+ I32 offset_fixed;
+ SV *longest_float;
+ I32 offset_float_min;
+ I32 offset_float_max;
+ I32 flags;
+} scan_data_t;
+#endif
+
+static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 };
+
+#define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
+#define SF_BEFORE_SEOL 0x1
+#define SF_BEFORE_MEOL 0x2
+#define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
+#define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
+
+#ifdef NO_UNARY_PLUS
+# define SF_FIX_SHIFT_EOL (0+2)
+# define SF_FL_SHIFT_EOL (0+4)
+#else
+# define SF_FIX_SHIFT_EOL (+2)
+# define SF_FL_SHIFT_EOL (+4)
+#endif
+
+#define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
+#define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
+
+#define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
+#define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
+#define SF_IS_INF 0x40
+#define SF_HAS_PAR 0x80
+#define SF_IN_PAR 0x100
+#define SF_HAS_EVAL 0x200
+#define SCF_DO_SUBSTR 0x400
+
+STATIC void
+scan_commit(scan_data_t *data)
+{
+ STRLEN l = SvCUR(data->last_found);
+ STRLEN old_l = SvCUR(*data->longest);
+
+ if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
+ sv_setsv(*data->longest, data->last_found);
+ if (*data->longest == data->longest_fixed) {
+ data->offset_fixed = l ? data->last_start_min : data->pos_min;
+ if (data->flags & SF_BEFORE_EOL)
+ data->flags
+ |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
+ else
+ data->flags &= ~SF_FIX_BEFORE_EOL;
+ } else {
+ data->offset_float_min = l ? data->last_start_min : data->pos_min;
+ data->offset_float_max = (l
+ ? data->last_start_max
+ : data->pos_min + data->pos_delta);
+ if (data->flags & SF_BEFORE_EOL)
+ data->flags
+ |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
+ else
+ data->flags &= ~SF_FL_BEFORE_EOL;
+ }
+ }
+ SvCUR_set(data->last_found, 0);
+ data->last_end = -1;
+ data->flags &= ~SF_BEFORE_EOL;
+}
+
+/* Stops at toplevel WHILEM as well as at `last'. At end *scanp is set
+ to the position after last scanned or to NULL. */
+
+STATIC I32
+study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)
+ /* scanp: Start here (read-write). */
+ /* deltap: Write maxlen-minlen here. */
+ /* last: Stop before this one. */
+{
+ dTHR;
+ I32 min = 0, pars = 0, code;
+ regnode *scan = *scanp, *next;
+ I32 delta = 0;
+ int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
+ I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
+ scan_data_t data_fake;
+
+ while (scan && OP(scan) != END && scan < last) {
+ /* Peephole optimizer: */
+
+ if (regkind[(U8)OP(scan)] == EXACT) {
+ regnode *n = regnext(scan);
+ U32 stringok = 1;
+#ifdef DEBUGGING
+ regnode *stop = scan;
+#endif
+
+ next = scan + (*OPERAND(scan) + 2 - 1)/sizeof(regnode) + 2;
+ /* Skip NOTHING, merge EXACT*. */
+ while (n &&
+ ( regkind[(U8)OP(n)] == NOTHING ||
+ (stringok && (OP(n) == OP(scan))))
+ && NEXT_OFF(n)
+ && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
+ if (OP(n) == TAIL || n > next)
+ stringok = 0;
+ if (regkind[(U8)OP(n)] == NOTHING) {
+ NEXT_OFF(scan) += NEXT_OFF(n);
+ next = n + NODE_STEP_REGNODE;
+#ifdef DEBUGGING
+ if (stringok)
+ stop = n;
+#endif
+ n = regnext(n);
+ } else {
+ int oldl = *OPERAND(scan);
+ regnode *nnext = regnext(n);
+
+ if (oldl + *OPERAND(n) > U8_MAX)
+ break;
+ NEXT_OFF(scan) += NEXT_OFF(n);
+ *OPERAND(scan) += *OPERAND(n);
+ next = n + (*OPERAND(n) + 2 - 1)/sizeof(regnode) + 2;
+ /* Now we can overwrite *n : */
+ Move(OPERAND(n) + 1, OPERAND(scan) + oldl + 1,
+ *OPERAND(n) + 1, char);
+#ifdef DEBUGGING
+ if (stringok)
+ stop = next - 1;
+#endif
+ n = nnext;
+ }
+ }
+#ifdef DEBUGGING
+ /* Allow dumping */
+ n = scan + (*OPERAND(scan) + 2 - 1)/sizeof(regnode) + 2;
+ while (n <= stop) {
+ /* Purify reports a benign UMR here sometimes, because we
+ * don't initialize the OP() slot of a node when that node
+ * is occupied by just the trailing null of the string in
+ * an EXACT node */
+ if (regkind[(U8)OP(n)] != NOTHING || OP(n) == NOTHING) {
+ OP(n) = OPTIMIZED;
+ NEXT_OFF(n) = 0;
+ }
+ n++;
+ }
+#endif
+
+ }
+ if (OP(scan) != CURLYX) {
+ int max = (reg_off_by_arg[OP(scan)]
+ ? I32_MAX
+ /* I32 may be smaller than U16 on CRAYs! */
+ : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
+ int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
+ int noff;
+ regnode *n = scan;
+
+ /* Skip NOTHING and LONGJMP. */
+ while ((n = regnext(n))
+ && ((regkind[(U8)OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
+ || ((OP(n) == LONGJMP) && (noff = ARG(n))))
+ && off + noff < max)
+ off += noff;
+ if (reg_off_by_arg[OP(scan)])
+ ARG(scan) = off;
+ else
+ NEXT_OFF(scan) = off;
+ }
+ if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
+ || OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
+ next = regnext(scan);
+ code = OP(scan);
+
+ if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
+ I32 max1 = 0, min1 = I32_MAX, num = 0;
+
+ if (flags & SCF_DO_SUBSTR)
+ scan_commit(data);
+ while (OP(scan) == code) {
+ I32 deltanext, minnext;
+
+ num++;
+ data_fake.flags = 0;
+ next = regnext(scan);
+ scan = NEXTOPER(scan);
+ if (code != BRANCH)
+ scan = NEXTOPER(scan);
+ /* We suppose the run is continuous, last=next...*/
+ minnext = study_chunk(&scan, &deltanext, next,
+ &data_fake, 0);
+ if (min1 > minnext)
+ min1 = minnext;
+ if (max1 < minnext + deltanext)
+ max1 = minnext + deltanext;
+ if (deltanext == I32_MAX)
+ is_inf = 1;
+ scan = next;
+ if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
+ pars++;
+ if (data && (data_fake.flags & SF_HAS_EVAL))
+ data->flags |= SF_HAS_EVAL;
+ if (code == SUSPEND)
+ break;
+ }
+ if (code == IFTHEN && num < 2) /* Empty ELSE branch */
+ min1 = 0;
+ if (flags & SCF_DO_SUBSTR) {
+ data->pos_min += min1;
+ data->pos_delta += max1 - min1;
+ if (max1 != min1 || is_inf)
+ data->longest = &(data->longest_float);
+ }
+ min += min1;
+ delta += max1 - min1;
+ } else if (code == BRANCHJ) /* single branch is optimized. */
+ scan = NEXTOPER(NEXTOPER(scan));
+ else /* single branch is optimized. */
+ scan = NEXTOPER(scan);
+ continue;
+ } else if (OP(scan) == EXACT) {
+ min += *OPERAND(scan);
+ if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
+ I32 l = *OPERAND(scan);
+
+ /* The code below prefers earlier match for fixed
+ offset, later match for variable offset. */
+ if (data->last_end == -1) { /* Update the start info. */
+ data->last_start_min = data->pos_min;
+ data->last_start_max = is_inf
+ ? I32_MAX : data->pos_min + data->pos_delta;
+ }
+ sv_catpvn(data->last_found, (char *)(OPERAND(scan)+1), l);
+ data->last_end = data->pos_min + l;
+ data->pos_min += l; /* As in the first entry. */
+ data->flags &= ~SF_BEFORE_EOL;
+ }
+ } else if (regkind[(U8)OP(scan)] == EXACT) {
+ if (flags & SCF_DO_SUBSTR)
+ scan_commit(data);
+ min += *OPERAND(scan);
+ if (data && (flags & SCF_DO_SUBSTR))
+ data->pos_min += *OPERAND(scan);
+ } else if (strchr(varies,OP(scan))) {
+ I32 mincount, maxcount, minnext, deltanext, pos_before, fl;
+ regnode *oscan = scan;
+
+ switch (regkind[(U8)OP(scan)]) {
+ case WHILEM:
+ scan = NEXTOPER(scan);
+ goto finish;
+ case PLUS:
+ if (flags & SCF_DO_SUBSTR) {
+ next = NEXTOPER(scan);
+ if (OP(next) == EXACT) {
+ mincount = 1;
+ maxcount = REG_INFTY;
+ next = regnext(scan);
+ scan = NEXTOPER(scan);
+ goto do_curly;
+ }
+ }
+ if (flags & SCF_DO_SUBSTR)
+ data->pos_min++;
+ min++;
+ /* Fall through. */
+ case STAR:
+ is_inf = 1;
+ scan = regnext(scan);
+ if (flags & SCF_DO_SUBSTR) {
+ scan_commit(data);
+ data->longest = &(data->longest_float);
+ }
+ goto optimize_curly_tail;
+ case CURLY:
+ mincount = ARG1(scan);
+ maxcount = ARG2(scan);
+ next = regnext(scan);
+ scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
+ do_curly:
+ if (flags & SCF_DO_SUBSTR) {
+ if (mincount == 0) scan_commit(data);
+ pos_before = data->pos_min;
+ }
+ if (data) {
+ fl = data->flags;
+ data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
+ if (is_inf)
+ data->flags |= SF_IS_INF;
+ }
+ /* This will finish on WHILEM, setting scan, or on NULL: */
+ minnext = study_chunk(&scan, &deltanext, last, data,
+ mincount == 0
+ ? (flags & ~SCF_DO_SUBSTR) : flags);
+ if (!scan) /* It was not CURLYX, but CURLY. */
+ scan = next;
+ if (PL_dowarn && (minnext + deltanext == 0)
+ && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
+ && maxcount <= 10000) /* Complement check for big count */
+ warn("Strange *+?{} on zero-length expression");
+ min += minnext * mincount;
+ is_inf |= (maxcount == REG_INFTY && (minnext + deltanext) > 0
+ || deltanext == I32_MAX);
+ delta += (minnext + deltanext) * maxcount - minnext * mincount;
+
+ /* Try powerful optimization CURLYX => CURLYN. */
+ if ( OP(oscan) == CURLYX && data
+ && data->flags & SF_IN_PAR
+ && !(data->flags & SF_HAS_EVAL)
+ && !deltanext && minnext == 1 ) {
+ /* Try to optimize to CURLYN. */
+ regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
+ regnode *nxt1 = nxt, *nxt2;
+
+ /* Skip open. */
+ nxt = regnext(nxt);
+ if (!strchr(simple,OP(nxt))
+ && !(regkind[(U8)OP(nxt)] == EXACT
+ && *OPERAND(nxt) == 1))
+ goto nogo;
+ nxt2 = nxt;
+ nxt = regnext(nxt);
+ if (OP(nxt) != CLOSE)
+ goto nogo;
+ /* Now we know that nxt2 is the only contents: */
+ oscan->flags = ARG(nxt);
+ OP(oscan) = CURLYN;
+ OP(nxt1) = NOTHING; /* was OPEN. */
+#ifdef DEBUGGING
+ OP(nxt1 + 1) = OPTIMIZED; /* was count. */
+ NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
+ NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
+ OP(nxt) = OPTIMIZED; /* was CLOSE. */
+ OP(nxt + 1) = OPTIMIZED; /* was count. */
+ NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
+#endif
+ }
+ nogo:
+
+ /* Try optimization CURLYX => CURLYM. */
+ if ( OP(oscan) == CURLYX && data
+ && !(data->flags & SF_HAS_PAR)
+ && !(data->flags & SF_HAS_EVAL)
+ && !deltanext ) {
+ /* XXXX How to optimize if data == 0? */
+ /* Optimize to a simpler form. */
+ regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
+ regnode *nxt2;
+
+ OP(oscan) = CURLYM;
+ while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
+ && (OP(nxt2) != WHILEM))
+ nxt = nxt2;
+ OP(nxt2) = SUCCEED; /* Whas WHILEM */
+ /* Need to optimize away parenths. */
+ if (data->flags & SF_IN_PAR) {
+ /* Set the parenth number. */
+ regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
+
+ if (OP(nxt) != CLOSE)
+ FAIL("panic opt close");
+ oscan->flags = ARG(nxt);
+ OP(nxt1) = OPTIMIZED; /* was OPEN. */
+ OP(nxt) = OPTIMIZED; /* was CLOSE. */
+#ifdef DEBUGGING
+ OP(nxt1 + 1) = OPTIMIZED; /* was count. */
+ OP(nxt + 1) = OPTIMIZED; /* was count. */
+ NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
+ NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
+#endif
+#if 0
+ while ( nxt1 && (OP(nxt1) != WHILEM)) {
+ regnode *nnxt = regnext(nxt1);
+
+ if (nnxt == nxt) {
+ if (reg_off_by_arg[OP(nxt1)])
+ ARG_SET(nxt1, nxt2 - nxt1);
+ else if (nxt2 - nxt1 < U16_MAX)
+ NEXT_OFF(nxt1) = nxt2 - nxt1;
+ else
+ OP(nxt) = NOTHING; /* Cannot beautify */
+ }
+ nxt1 = nnxt;
+ }
+#endif
+ /* Optimize again: */
+ study_chunk(&nxt1, &deltanext, nxt, NULL, 0);
+ } else
+ oscan->flags = 0;
+ }
+ if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
+ pars++;
+ if (flags & SCF_DO_SUBSTR) {
+ SV *last_str = Nullsv;
+ int counted = mincount != 0;
+
+ if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
+ I32 b = pos_before >= data->last_start_min
+ ? pos_before : data->last_start_min;
+ STRLEN l;
+ char *s = SvPV(data->last_found, l);
+
+ l -= b - data->last_start_min;
+ /* Get the added string: */
+ last_str = newSVpv(s + b - data->last_start_min, l);
+ if (deltanext == 0 && pos_before == b) {
+ /* What was added is a constant string */
+ if (mincount > 1) {
+ SvGROW(last_str, (mincount * l) + 1);
+ repeatcpy(SvPVX(last_str) + l,
+ SvPVX(last_str), l, mincount - 1);
+ SvCUR(last_str) *= mincount;
+ /* Add additional parts. */
+ SvCUR_set(data->last_found,
+ SvCUR(data->last_found) - l);
+ sv_catsv(data->last_found, last_str);
+ data->last_end += l * (mincount - 1);
+ }
+ }
+ }
+ /* It is counted once already... */
+ data->pos_min += minnext * (mincount - counted);
+ data->pos_delta += - counted * deltanext +
+ (minnext + deltanext) * maxcount - minnext * mincount;
+ if (mincount != maxcount) {
+ scan_commit(data);
+ if (mincount && last_str) {
+ sv_setsv(data->last_found, last_str);
+ data->last_end = data->pos_min;
+ data->last_start_min =
+ data->pos_min - SvCUR(last_str);
+ data->last_start_max = is_inf
+ ? I32_MAX
+ : data->pos_min + data->pos_delta
+ - SvCUR(last_str);
+ }
+ data->longest = &(data->longest_float);
+ }
+ }
+ if (data && (fl & SF_HAS_EVAL))
+ data->flags |= SF_HAS_EVAL;
+ optimize_curly_tail:
+ if (OP(oscan) != CURLYX) {
+ while (regkind[(U8)OP(next = regnext(oscan))] == NOTHING
+ && NEXT_OFF(next))
+ NEXT_OFF(oscan) += NEXT_OFF(next);
+ }
+ continue;
+ default: /* REF only? */
+ if (flags & SCF_DO_SUBSTR) {
+ scan_commit(data);
+ data->longest = &(data->longest_float);
+ }
+ is_inf = 1;
+ break;
+ }
+ } else if (strchr(simple,OP(scan))) {
+ if (flags & SCF_DO_SUBSTR) {
+ scan_commit(data);
+ data->pos_min++;
+ }
+ min++;
+ } else if (regkind[(U8)OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
+ data->flags |= (OP(scan) == MEOL
+ ? SF_BEFORE_MEOL
+ : SF_BEFORE_SEOL);
+ } else if (regkind[(U8)OP(scan)] == BRANCHJ
+ && (scan->flags || data)
+ && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
+ I32 deltanext, minnext;
+ regnode *nscan;
+
+ data_fake.flags = 0;
+ next = regnext(scan);
+ nscan = NEXTOPER(NEXTOPER(scan));
+ minnext = study_chunk(&nscan, &deltanext, last, &data_fake, 0);
+ if (scan->flags) {
+ if (deltanext) {
+ FAIL("variable length lookbehind not implemented");
+ } else if (minnext > U8_MAX) {
+ FAIL2("lookbehind longer than %d not implemented", U8_MAX);
+ }
+ scan->flags = minnext;
+ }
+ if (data && data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
+ pars++;
+ if (data && (data_fake.flags & SF_HAS_EVAL))
+ data->flags |= SF_HAS_EVAL;
+ } else if (OP(scan) == OPEN) {
+ pars++;
+ } else if (OP(scan) == CLOSE && ARG(scan) == is_par) {
+ next = regnext(scan);
+
+ if ( next && (OP(next) != WHILEM) && next < last)
+ is_par = 0; /* Disable optimization */
+ } else if (OP(scan) == EVAL) {
+ if (data)
+ data->flags |= SF_HAS_EVAL;
+ }
+ /* Else: zero-length, ignore. */
+ scan = regnext(scan);
+ }
+
+ finish:
+ *scanp = scan;
+ *deltap = is_inf ? I32_MAX : delta;
+ if (flags & SCF_DO_SUBSTR && is_inf)
+ data->pos_delta = I32_MAX - data->pos_min;
+ if (is_par > U8_MAX)
+ is_par = 0;
+ if (is_par && pars==1 && data) {
+ data->flags |= SF_IN_PAR;
+ data->flags &= ~SF_HAS_PAR;
+ } else if (pars && data) {
+ data->flags |= SF_HAS_PAR;
+ data->flags &= ~SF_IN_PAR;
+ }
+ return min;
+}
+
+STATIC I32
+add_data(I32 n, char *s)
+{
+ dTHR;
+ if (PL_regcomp_rx->data) {
+ Renewc(PL_regcomp_rx->data,
+ sizeof(*PL_regcomp_rx->data) + sizeof(void*) * (PL_regcomp_rx->data->count + n - 1),
+ char, struct reg_data);
+ Renew(PL_regcomp_rx->data->what, PL_regcomp_rx->data->count + n, U8);
+ PL_regcomp_rx->data->count += n;
+ } else {
+ Newc(1207, PL_regcomp_rx->data, sizeof(*PL_regcomp_rx->data) + sizeof(void*) * (n - 1),
+ char, struct reg_data);
+ New(1208, PL_regcomp_rx->data->what, n, U8);
+ PL_regcomp_rx->data->count = n;
+ }
+ Copy(s, PL_regcomp_rx->data->what + PL_regcomp_rx->data->count - n, n, U8);
+ return PL_regcomp_rx->data->count - n;
+}
+
+/*
+ - pregcomp - compile a regular expression into internal code
+ *
+ * We can't allocate space until we know how big the compiled form will be,
+ * but we can't compile it (and thus know how big it is) until we've got a
+ * place to put the code. So we cheat: we compile it twice, once with code
+ * generation turned off and size counting turned on, and once "for real".
+ * This also means that we don't allocate space until we are sure that the
+ * thing really will compile successfully, and we never have to move the
+ * code and thus invalidate pointers into it. (Note that it has to be in
+ * one piece because free() must be able to free it all.) [NB: not true in perl]
+ *
+ * Beware that the optimization-preparation code in here knows about some
+ * of the structure of the compiled regexp. [I'll say.]
+ */
+regexp *
+pregcomp(char *exp, char *xend, PMOP *pm)
+{
+ dTHR;
+ register regexp *r;
+ regnode *scan;
+ SV **longest;
+ SV *longest_fixed;
+ SV *longest_float;
+ regnode *first;
+ I32 flags;
+ I32 minlen = 0;
+ I32 sawplus = 0;
+ I32 sawopen = 0;
+
+ if (exp == NULL)
+ FAIL("NULL regexp argument");
+
+ PL_regprecomp = savepvn(exp, xend - exp);
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "compiling RE `%*s'\n",
+ xend - exp, PL_regprecomp));
+ PL_regflags = pm->op_pmflags;
+ PL_regsawback = 0;
+
+ PL_regseen = 0;
+ PL_seen_zerolen = *exp == '^' ? -1 : 0;
+ PL_seen_evals = 0;
+ PL_extralen = 0;
+
+ /* First pass: determine size, legality. */
+ PL_regcomp_parse = exp;
+ PL_regxend = xend;
+ PL_regnaughty = 0;
+ PL_regnpar = 1;
+ PL_regsize = 0L;
+ PL_regcode = &PL_regdummy;
+ regc((U8)MAGIC, (char*)PL_regcode);
+ if (reg(0, &flags) == NULL) {
+ Safefree(PL_regprecomp);
+ PL_regprecomp = Nullch;
+ return(NULL);
+ }
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "size %d ", PL_regsize));
+
+ DEBUG_r(
+ if (!PL_colorset) {
+ int i = 0;
+ char *s = PerlEnv_getenv("TERMCAP_COLORS");
+
+ PL_colorset = 1;
+ if (s) {
+ PL_colors[0] = s = savepv(s);
+ while (++i < 4) {
+ s = strchr(s, '\t');
+ if (!s)
+ FAIL("Not enough TABs in TERMCAP_COLORS");
+ *s = '\0';
+ PL_colors[i] = ++s;
+ }
+ } else {
+ while (i < 4)
+ PL_colors[i++] = "";
+ }
+ /* Reset colors: */
+ PerlIO_printf(Perl_debug_log, "%s%s%s%s",
+ PL_colors[0],PL_colors[1],PL_colors[2],PL_colors[3]);
+ }
+ );
+
+ /* Small enough for pointer-storage convention?
+ If extralen==0, this means that we will not need long jumps. */
+ if (PL_regsize >= 0x10000L && PL_extralen)
+ PL_regsize += PL_extralen;
+ else
+ PL_extralen = 0;
+
+ /* Allocate space and initialize. */
+ Newc(1001, r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode),
+ char, regexp);
+ if (r == NULL)
+ FAIL("regexp out of space");
+ r->refcnt = 1;
+ r->prelen = xend - exp;
+ r->precomp = PL_regprecomp;
+ r->subbeg = r->subbase = NULL;
+ r->nparens = PL_regnpar - 1; /* set early to validate backrefs */
+ PL_regcomp_rx = r;
+
+ /* Second pass: emit code. */
+ PL_regcomp_parse = exp;
+ PL_regxend = xend;
+ PL_regnaughty = 0;
+ PL_regnpar = 1;
+ PL_regcode = r->program;
+ /* Store the count of eval-groups for security checks: */
+ PL_regcode->next_off = ((PL_seen_evals > U16_MAX) ? U16_MAX : PL_seen_evals);
+ regc((U8)MAGIC, (char*) PL_regcode++);
+ r->data = 0;
+ if (reg(0, &flags) == NULL)
+ return(NULL);
+
+ /* Dig out information for optimizations. */
+ r->reganch = pm->op_pmflags & PMf_COMPILETIME;
+ pm->op_pmflags = PL_regflags;
+ r->regstclass = NULL;
+ r->naughty = PL_regnaughty >= 10; /* Probably an expensive pattern. */
+ scan = r->program + 1; /* First BRANCH. */
+
+ /* XXXX To minimize changes to RE engine we always allocate
+ 3-units-long substrs field. */
+ Newz(1004, r->substrs, 1, struct reg_substr_data);
+
+ if (OP(scan) != BRANCH) { /* Only one top-level choice. */
+ scan_data_t data;
+ I32 fake;
+ STRLEN longest_float_length, longest_fixed_length;
+
+ StructCopy(&zero_scan_data, &data, scan_data_t);
+ first = scan;
+ /* Skip introductions and multiplicators >= 1. */
+ while ((OP(first) == OPEN && (sawopen = 1)) ||
+ (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
+ (OP(first) == PLUS) ||
+ (OP(first) == MINMOD) ||
+ (regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) {
+ if (OP(first) == PLUS)
+ sawplus = 1;
+ else
+ first += regarglen[(U8)OP(first)];
+ first = NEXTOPER(first);
+ }
+
+ /* Starting-point info. */
+ again:
+ if (OP(first) == EXACT); /* Empty, get anchored substr later. */
+ else if (strchr(simple+2,OP(first)))
+ r->regstclass = first;
+ else if (regkind[(U8)OP(first)] == BOUND ||
+ regkind[(U8)OP(first)] == NBOUND)
+ r->regstclass = first;
+ else if (regkind[(U8)OP(first)] == BOL) {
+ r->reganch |= (OP(first) == MBOL ? ROPT_ANCH_MBOL: ROPT_ANCH_BOL);
+ first = NEXTOPER(first);
+ goto again;
+ }
+ else if (OP(first) == GPOS) {
+ r->reganch |= ROPT_ANCH_GPOS;
+ first = NEXTOPER(first);
+ goto again;
+ }
+ else if ((OP(first) == STAR &&
+ regkind[(U8)OP(NEXTOPER(first))] == ANY) &&
+ !(r->reganch & ROPT_ANCH) )
+ {
+ /* turn .* into ^.* with an implied $*=1 */
+ r->reganch |= ROPT_ANCH_BOL | ROPT_IMPLICIT;
+ first = NEXTOPER(first);
+ goto again;
+ }
+ if (sawplus && (!sawopen || !PL_regsawback))
+ r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */
+
+ /* Scan is after the zeroth branch, first is atomic matcher. */
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %d\n",
+ first - scan + 1));
+ /*
+ * If there's something expensive in the r.e., find the
+ * longest literal string that must appear and make it the
+ * regmust. Resolve ties in favor of later strings, since
+ * the regstart check works with the beginning of the r.e.
+ * and avoiding duplication strengthens checking. Not a
+ * strong reason, but sufficient in the absence of others.
+ * [Now we resolve ties in favor of the earlier string if
+ * it happens that c_offset_min has been invalidated, since the
+ * earlier string may buy us something the later one won't.]
+ */
+ minlen = 0;
+
+ data.longest_fixed = newSVpv("",0);
+ data.longest_float = newSVpv("",0);
+ data.last_found = newSVpv("",0);
+ data.longest = &(data.longest_fixed);
+ first = scan;
+
+ minlen = study_chunk(&first, &fake, scan + PL_regsize, /* Up to end */
+ &data, SCF_DO_SUBSTR);
+ if ( PL_regnpar == 1 && data.longest == &(data.longest_fixed)
+ && data.last_start_min == 0 && data.last_end > 0
+ && !PL_seen_zerolen
+ && (!(PL_regseen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
+ r->reganch |= ROPT_CHECK_ALL;
+ scan_commit(&data);
+ SvREFCNT_dec(data.last_found);
+
+ longest_float_length = SvCUR(data.longest_float);
+ if (longest_float_length
+ || (data.flags & SF_FL_BEFORE_EOL
+ && (!(data.flags & SF_FL_BEFORE_MEOL)
+ || (PL_regflags & PMf_MULTILINE)))) {
+ if (SvCUR(data.longest_fixed)
+ && data.offset_fixed == data.offset_float_min)
+ goto remove; /* Like in (a)+. */
+
+ r->float_substr = data.longest_float;
+ r->float_min_offset = data.offset_float_min;
+ r->float_max_offset = data.offset_float_max;
+ fbm_compile(r->float_substr, 0);
+ BmUSEFUL(r->float_substr) = 100;
+ if (data.flags & SF_FL_BEFORE_EOL /* Cannot have SEOL and MULTI */
+ && (!(data.flags & SF_FL_BEFORE_MEOL)
+ || (PL_regflags & PMf_MULTILINE)))
+ SvTAIL_on(r->float_substr);
+ } else {
+ remove:
+ r->float_substr = Nullsv;
+ SvREFCNT_dec(data.longest_float);
+ longest_float_length = 0;
+ }
+
+ longest_fixed_length = SvCUR(data.longest_fixed);
+ if (longest_fixed_length
+ || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
+ && (!(data.flags & SF_FIX_BEFORE_MEOL)
+ || (PL_regflags & PMf_MULTILINE)))) {
+ r->anchored_substr = data.longest_fixed;
+ r->anchored_offset = data.offset_fixed;
+ fbm_compile(r->anchored_substr, 0);
+ BmUSEFUL(r->anchored_substr) = 100;
+ if (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
+ && (!(data.flags & SF_FIX_BEFORE_MEOL)
+ || (PL_regflags & PMf_MULTILINE)))
+ SvTAIL_on(r->anchored_substr);
+ } else {
+ r->anchored_substr = Nullsv;
+ SvREFCNT_dec(data.longest_fixed);
+ longest_fixed_length = 0;
+ }
+
+ /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
+ if (longest_fixed_length > longest_float_length) {
+ r->check_substr = r->anchored_substr;
+ r->check_offset_min = r->check_offset_max = r->anchored_offset;
+ if (r->reganch & ROPT_ANCH_SINGLE)
+ r->reganch |= ROPT_NOSCAN;
+ } else {
+ r->check_substr = r->float_substr;
+ r->check_offset_min = data.offset_float_min;
+ r->check_offset_max = data.offset_float_max;
+ }
+ } else {
+ /* Several toplevels. Best we can is to set minlen. */
+ I32 fake;
+
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "\n"));
+ scan = r->program + 1;
+ minlen = study_chunk(&scan, &fake, scan + PL_regsize, NULL, 0);
+ r->check_substr = r->anchored_substr = r->float_substr = Nullsv;
+ }
+
+ r->minlen = minlen;
+ if (PL_regseen & REG_SEEN_GPOS)
+ r->reganch |= ROPT_GPOS_SEEN;
+ if (PL_regseen & REG_SEEN_LOOKBEHIND)
+ r->reganch |= ROPT_LOOKBEHIND_SEEN;
+ if (PL_regseen & REG_SEEN_EVAL)
+ r->reganch |= ROPT_EVAL_SEEN;
+ Newz(1002, r->startp, PL_regnpar, char*);
+ Newz(1002, r->endp, PL_regnpar, char*);
+ DEBUG_r(regdump(r));
+ return(r);
+}
+
+/*
+ - reg - regular expression, i.e. main body or parenthesized thing
+ *
+ * Caller must absorb opening parenthesis.
+ *
+ * Combining parenthesis handling with the base level of regular expression
+ * is a trifle forced, but the need to tie the tails of the branches to what
+ * follows makes it hard to avoid.
+ */
+STATIC regnode *
+reg(I32 paren, I32 *flagp)
+ /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
+{
+ dTHR;
+ register regnode *ret; /* Will be the head of the group. */
+ register regnode *br;
+ register regnode *lastbr;
+ register regnode *ender = 0;
+ register I32 parno = 0;
+ I32 flags, oregflags = PL_regflags, have_branch = 0, open = 0;
+ char c;
+
+ *flagp = 0; /* Tentatively. */
+
+ /* Make an OPEN node, if parenthesized. */
+ if (paren) {
+ if (*PL_regcomp_parse == '?') {
+ U16 posflags = 0, negflags = 0;
+ U16 *flagsp = &posflags;
+
+ PL_regcomp_parse++;
+ paren = *PL_regcomp_parse++;
+ ret = NULL; /* For look-ahead/behind. */
+ switch (paren) {
+ case '<':
+ PL_regseen |= REG_SEEN_LOOKBEHIND;
+ if (*PL_regcomp_parse == '!')
+ paren = ',';
+ if (*PL_regcomp_parse != '=' && *PL_regcomp_parse != '!')
+ goto unknown;
+ PL_regcomp_parse++;
+ case '=':
+ case '!':
+ PL_seen_zerolen++;
+ case ':':
+ case '>':
+ break;
+ case '$':
+ case '@':
+ FAIL2("Sequence (?%c...) not implemented", (int)paren);
+ break;
+ case '#':
+ while (*PL_regcomp_parse && *PL_regcomp_parse != ')')
+ PL_regcomp_parse++;
+ if (*PL_regcomp_parse != ')')
+ FAIL("Sequence (?#... not terminated");
+ nextchar();
+ *flagp = TRYAGAIN;
+ return NULL;
+ case '{':
+ {
+ dTHR;
+ I32 count = 1, n = 0;
+ char c;
+ char *s = PL_regcomp_parse;
+ SV *sv;
+ OP_4tree *sop, *rop;
+
+ PL_seen_zerolen++;
+ PL_regseen |= REG_SEEN_EVAL;
+ while (count && (c = *PL_regcomp_parse)) {
+ if (c == '\\' && PL_regcomp_parse[1])
+ PL_regcomp_parse++;
+ else if (c == '{')
+ count++;
+ else if (c == '}')
+ count--;
+ PL_regcomp_parse++;
+ }
+ if (*PL_regcomp_parse != ')')
+ FAIL("Sequence (?{...}) not terminated or not {}-balanced");
+ if (!SIZE_ONLY) {
+ AV *av;
+
+ if (PL_regcomp_parse - 1 - s)
+ sv = newSVpv(s, PL_regcomp_parse - 1 - s);
+ else
+ sv = newSVpv("", 0);
+
+ rop = sv_compile_2op(sv, &sop, "re", &av);
+
+ n = add_data(3, "nso");
+ PL_regcomp_rx->data->data[n] = (void*)rop;
+ PL_regcomp_rx->data->data[n+1] = (void*)av;
+ PL_regcomp_rx->data->data[n+2] = (void*)sop;
+ SvREFCNT_dec(sv);
+ } else { /* First pass */
+ if (PL_reginterp_cnt < ++PL_seen_evals && PL_curcop != &PL_compiling)
+ /* No compiled RE interpolated, has runtime
+ components ===> unsafe. */
+ FAIL("Eval-group not allowed at runtime, use re 'eval'");
+ if (PL_tainted)
+ FAIL("Eval-group in insecure regular expression");
+ }
+
+ nextchar();
+ return reganode(EVAL, n);
+ }
+ case '(':
+ {
+ if (PL_regcomp_parse[0] == '?') {
+ if (PL_regcomp_parse[1] == '=' || PL_regcomp_parse[1] == '!'
+ || PL_regcomp_parse[1] == '<'
+ || PL_regcomp_parse[1] == '{') { /* Lookahead or eval. */
+ I32 flag;
+
+ ret = reg_node(LOGICAL);
+ regtail(ret, reg(1, &flag));
+ goto insert_if;
+ }
+ } else if (PL_regcomp_parse[0] >= '1' && PL_regcomp_parse[0] <= '9' ) {
+ parno = atoi(PL_regcomp_parse++);
+
+ while (isDIGIT(*PL_regcomp_parse))
+ PL_regcomp_parse++;
+ ret = reganode(GROUPP, parno);
+ if ((c = *nextchar()) != ')')
+ FAIL2("Switch (?(number%c not recognized", c);
+ insert_if:
+ regtail(ret, reganode(IFTHEN, 0));
+ br = regbranch(&flags, 1);
+ if (br == NULL)
+ br = reganode(LONGJMP, 0);
+ else
+ regtail(br, reganode(LONGJMP, 0));
+ c = *nextchar();
+ if (c == '|') {
+ lastbr = reganode(IFTHEN, 0); /* Fake one for optimizer. */
+ regbranch(&flags, 1);
+ regtail(ret, lastbr);
+ c = *nextchar();
+ } else
+ lastbr = NULL;
+ if (c != ')')
+ FAIL("Switch (?(condition)... contains too many branches");
+ ender = reg_node(TAIL);
+ regtail(br, ender);
+ if (lastbr) {
+ regtail(lastbr, ender);
+ regtail(NEXTOPER(NEXTOPER(lastbr)), ender);
+ } else
+ regtail(ret, ender);
+ return ret;
+ } else {
+ FAIL2("Unknown condition for (?(%.2s", PL_regcomp_parse);
+ }
+ }
+ case 0:
+ FAIL("Sequence (? incomplete");
+ break;
+ default:
+ --PL_regcomp_parse;
+ parse_flags:
+ while (*PL_regcomp_parse && strchr("iogcmsx", *PL_regcomp_parse)) {
+ if (*PL_regcomp_parse != 'o')
+ pmflag(flagsp, *PL_regcomp_parse);
+ ++PL_regcomp_parse;
+ }
+ if (*PL_regcomp_parse == '-') {
+ flagsp = &negflags;
+ ++PL_regcomp_parse;
+ goto parse_flags;
+ }
+ PL_regflags |= posflags;
+ PL_regflags &= ~negflags;
+ if (*PL_regcomp_parse == ':') {
+ PL_regcomp_parse++;
+ paren = ':';
+ break;
+ }
+ unknown:
+ if (*PL_regcomp_parse != ')')
+ FAIL2("Sequence (?%c...) not recognized", *PL_regcomp_parse);
+ nextchar();
+ *flagp = TRYAGAIN;
+ return NULL;
+ }
+ }
+ else {
+ parno = PL_regnpar;
+ PL_regnpar++;
+ ret = reganode(OPEN, parno);
+ open = 1;
+ }
+ } else
+ ret = NULL;
+
+ /* Pick up the branches, linking them together. */
+ br = regbranch(&flags, 1);
+ if (br == NULL)
+ return(NULL);
+ if (*PL_regcomp_parse == '|') {
+ if (!SIZE_ONLY && PL_extralen) {
+ reginsert(BRANCHJ, br);
+ } else
+ reginsert(BRANCH, br);
+ have_branch = 1;
+ if (SIZE_ONLY)
+ PL_extralen += 1; /* For BRANCHJ-BRANCH. */
+ } else if (paren == ':') {
+ *flagp |= flags&SIMPLE;
+ }
+ if (open) { /* Starts with OPEN. */
+ regtail(ret, br); /* OPEN -> first. */
+ } else if (paren != '?') /* Not Conditional */
+ ret = br;
+ if (flags&HASWIDTH)
+ *flagp |= HASWIDTH;
+ *flagp |= flags&SPSTART;
+ lastbr = br;
+ while (*PL_regcomp_parse == '|') {
+ if (!SIZE_ONLY && PL_extralen) {
+ ender = reganode(LONGJMP,0);
+ regtail(NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
+ }
+ if (SIZE_ONLY)
+ PL_extralen += 2; /* Account for LONGJMP. */
+ nextchar();
+ br = regbranch(&flags, 0);
+ if (br == NULL)
+ return(NULL);
+ regtail(lastbr, br); /* BRANCH -> BRANCH. */
+ lastbr = br;
+ if (flags&HASWIDTH)
+ *flagp |= HASWIDTH;
+ *flagp |= flags&SPSTART;
+ }
+
+ if (have_branch || paren != ':') {
+ /* Make a closing node, and hook it on the end. */
+ switch (paren) {
+ case ':':
+ ender = reg_node(TAIL);
+ break;
+ case 1:
+ ender = reganode(CLOSE, parno);
+ break;
+ case '<':
+ case ',':
+ case '=':
+ case '!':
+ *flagp &= ~HASWIDTH;
+ /* FALL THROUGH */
+ case '>':
+ ender = reg_node(SUCCEED);
+ break;
+ case 0:
+ ender = reg_node(END);
+ break;
+ }
+ regtail(lastbr, ender);
+
+ if (have_branch) {
+ /* Hook the tails of the branches to the closing node. */
+ for (br = ret; br != NULL; br = regnext(br)) {
+ regoptail(br, ender);
+ }
+ }
+ }
+
+ {
+ char *p;
+ static char parens[] = "=!<,>";
+
+ if (paren && (p = strchr(parens, paren))) {
+ int node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
+ int flag = (p - parens) > 1;
+
+ if (paren == '>')
+ node = SUSPEND, flag = 0;
+ reginsert(node,ret);
+ ret->flags = flag;
+ regtail(ret, reg_node(TAIL));
+ }
+ }
+
+ /* Check for proper termination. */
+ if (paren && (PL_regcomp_parse >= PL_regxend || *nextchar() != ')')) {
+ FAIL("unmatched () in regexp");
+ } else if (!paren && PL_regcomp_parse < PL_regxend) {
+ if (*PL_regcomp_parse == ')') {
+ FAIL("unmatched () in regexp");
+ } else
+ FAIL("junk on end of regexp"); /* "Can't happen". */
+ /* NOTREACHED */
+ }
+ if (paren != 0) {
+ PL_regflags = oregflags;
+ }
+
+ return(ret);
+}
+
+/*
+ - regbranch - one alternative of an | operator
+ *
+ * Implements the concatenation operator.
+ */
+STATIC regnode *
+regbranch(I32 *flagp, I32 first)
+{
+ dTHR;
+ register regnode *ret;
+ register regnode *chain = NULL;
+ register regnode *latest;
+ I32 flags = 0, c = 0;
+
+ if (first)
+ ret = NULL;
+ else {
+ if (!SIZE_ONLY && PL_extralen)
+ ret = reganode(BRANCHJ,0);
+ else
+ ret = reg_node(BRANCH);
+ }
+
+ if (!first && SIZE_ONLY)
+ PL_extralen += 1; /* BRANCHJ */
+
+ *flagp = WORST; /* Tentatively. */
+
+ PL_regcomp_parse--;
+ nextchar();
+ while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != '|' && *PL_regcomp_parse != ')') {
+ flags &= ~TRYAGAIN;
+ latest = regpiece(&flags);
+ if (latest == NULL) {
+ if (flags & TRYAGAIN)
+ continue;
+ return(NULL);
+ } else if (ret == NULL)
+ ret = latest;
+ *flagp |= flags&HASWIDTH;
+ if (chain == NULL) /* First piece. */
+ *flagp |= flags&SPSTART;
+ else {
+ PL_regnaughty++;
+ regtail(chain, latest);
+ }
+ chain = latest;
+ c++;
+ }
+ if (chain == NULL) { /* Loop ran zero times. */
+ chain = reg_node(NOTHING);
+ if (ret == NULL)
+ ret = chain;
+ }
+ if (c == 1) {
+ *flagp |= flags&SIMPLE;
+ }
+
+ return(ret);
+}
+
+/*
+ - regpiece - something followed by possible [*+?]
+ *
+ * Note that the branching code sequences used for ? and the general cases
+ * of * and + are somewhat optimized: they use the same NOTHING node as
+ * both the endmarker for their branch list and the body of the last branch.
+ * It might seem that this node could be dispensed with entirely, but the
+ * endmarker role is not redundant.
+ */
+STATIC regnode *
+regpiece(I32 *flagp)
+{
+ dTHR;
+ register regnode *ret;
+ register char op;
+ register char *next;
+ I32 flags;
+ char *origparse = PL_regcomp_parse;
+ char *maxpos;
+ I32 min;
+ I32 max = REG_INFTY;
+
+ ret = regatom(&flags);
+ if (ret == NULL) {
+ if (flags & TRYAGAIN)
+ *flagp |= TRYAGAIN;
+ return(NULL);
+ }
+
+ op = *PL_regcomp_parse;
+
+ if (op == '{' && regcurly(PL_regcomp_parse)) {
+ next = PL_regcomp_parse + 1;
+ maxpos = Nullch;
+ while (isDIGIT(*next) || *next == ',') {
+ if (*next == ',') {
+ if (maxpos)
+ break;
+ else
+ maxpos = next;
+ }
+ next++;
+ }
+ if (*next == '}') { /* got one */
+ if (!maxpos)
+ maxpos = next;
+ PL_regcomp_parse++;
+ min = atoi(PL_regcomp_parse);
+ if (*maxpos == ',')
+ maxpos++;
+ else
+ maxpos = PL_regcomp_parse;
+ max = atoi(maxpos);
+ if (!max && *maxpos != '0')
+ max = REG_INFTY; /* meaning "infinity" */
+ else if (max >= REG_INFTY)
+ FAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
+ PL_regcomp_parse = next;
+ nextchar();
+
+ do_curly:
+ if ((flags&SIMPLE)) {
+ PL_regnaughty += 2 + PL_regnaughty / 2;
+ reginsert(CURLY, ret);
+ }
+ else {
+ PL_regnaughty += 4 + PL_regnaughty; /* compound interest */
+ regtail(ret, reg_node(WHILEM));
+ if (!SIZE_ONLY && PL_extralen) {
+ reginsert(LONGJMP,ret);
+ reginsert(NOTHING,ret);
+ NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
+ }
+ reginsert(CURLYX,ret);
+ if (!SIZE_ONLY && PL_extralen)
+ NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
+ regtail(ret, reg_node(NOTHING));
+ if (SIZE_ONLY)
+ PL_extralen += 3;
+ }
+ ret->flags = 0;
+
+ if (min > 0)
+ *flagp = WORST;
+ if (max > 0)
+ *flagp |= HASWIDTH;
+ if (max && max < min)
+ FAIL("Can't do {n,m} with n > m");
+ if (!SIZE_ONLY) {
+ ARG1_SET(ret, min);
+ ARG2_SET(ret, max);
+ }
+
+ goto nest_check;
+ }
+ }
+
+ if (!ISMULT1(op)) {
+ *flagp = flags;
+ return(ret);
+ }
+
+#if 0 /* Now runtime fix should be reliable. */
+ if (!(flags&HASWIDTH) && op != '?')
+ FAIL("regexp *+ operand could be empty");
+#endif
+
+ nextchar();
+
+ *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
+
+ if (op == '*' && (flags&SIMPLE)) {
+ reginsert(STAR, ret);
+ ret->flags = 0;
+ PL_regnaughty += 4;
+ }
+ else if (op == '*') {
+ min = 0;
+ goto do_curly;
+ } else if (op == '+' && (flags&SIMPLE)) {
+ reginsert(PLUS, ret);
+ ret->flags = 0;
+ PL_regnaughty += 3;
+ }
+ else if (op == '+') {
+ min = 1;
+ goto do_curly;
+ } else if (op == '?') {
+ min = 0; max = 1;
+ goto do_curly;
+ }
+ nest_check:
+ if (PL_dowarn && !SIZE_ONLY && !(flags&HASWIDTH) && max > 10000) {
+ warn("%.*s matches null string many times",
+ PL_regcomp_parse - origparse, origparse);
+ }
+
+ if (*PL_regcomp_parse == '?') {
+ nextchar();
+ reginsert(MINMOD, ret);
+ regtail(ret, ret + NODE_STEP_REGNODE);
+ }
+ if (ISMULT2(PL_regcomp_parse))
+ FAIL("nested *?+ in regexp");
+
+ return(ret);
+}
+
+/*
+ - regatom - the lowest level
+ *
+ * Optimization: gobbles an entire sequence of ordinary characters so that
+ * it can turn them into a single node, which is smaller to store and
+ * faster to run. Backslashed characters are exceptions, each becoming a
+ * separate node; the code is simpler that way and it's not worth fixing.
+ *
+ * [Yes, it is worth fixing, some scripts can run twice the speed.]
+ */
+STATIC regnode *
+regatom(I32 *flagp)
+{
+ dTHR;
+ register regnode *ret = 0;
+ I32 flags;
+
+ *flagp = WORST; /* Tentatively. */
+
+tryagain:
+ switch (*PL_regcomp_parse) {
+ case '^':
+ PL_seen_zerolen++;
+ nextchar();
+ if (PL_regflags & PMf_MULTILINE)
+ ret = reg_node(MBOL);
+ else if (PL_regflags & PMf_SINGLELINE)
+ ret = reg_node(SBOL);
+ else
+ ret = reg_node(BOL);
+ break;
+ case '$':
+ if (PL_regcomp_parse[1])
+ PL_seen_zerolen++;
+ nextchar();
+ if (PL_regflags & PMf_MULTILINE)
+ ret = reg_node(MEOL);
+ else if (PL_regflags & PMf_SINGLELINE)
+ ret = reg_node(SEOL);
+ else
+ ret = reg_node(EOL);
+ break;
+ case '.':
+ nextchar();
+ if (PL_regflags & PMf_SINGLELINE)
+ ret = reg_node(SANY);
+ else
+ ret = reg_node(ANY);
+ PL_regnaughty++;
+ *flagp |= HASWIDTH|SIMPLE;
+ break;
+ case '[':
+ PL_regcomp_parse++;
+ ret = regclass();
+ *flagp |= HASWIDTH|SIMPLE;
+ break;
+ case '(':
+ nextchar();
+ ret = reg(1, &flags);
+ if (ret == NULL) {
+ if (flags & TRYAGAIN)
+ goto tryagain;
+ return(NULL);
+ }
+ *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
+ break;
+ case '|':
+ case ')':
+ if (flags & TRYAGAIN) {
+ *flagp |= TRYAGAIN;
+ return NULL;
+ }
+ FAIL2("internal urp in regexp at /%s/", PL_regcomp_parse);
+ /* Supposed to be caught earlier. */
+ break;
+ case '{':
+ if (!regcurly(PL_regcomp_parse)) {
+ PL_regcomp_parse++;
+ goto defchar;
+ }
+ /* FALL THROUGH */
+ case '?':
+ case '+':
+ case '*':
+ FAIL("?+*{} follows nothing in regexp");
+ break;
+ case '\\':
+ switch (*++PL_regcomp_parse) {
+ case 'A':
+ PL_seen_zerolen++;
+ ret = reg_node(SBOL);
+ *flagp |= SIMPLE;
+ nextchar();
+ break;
+ case 'G':
+ ret = reg_node(GPOS);
+ PL_regseen |= REG_SEEN_GPOS;
+ *flagp |= SIMPLE;
+ nextchar();
+ break;
+ case 'Z':
+ ret = reg_node(SEOL);
+ *flagp |= SIMPLE;
+ nextchar();
+ break;
+ case 'z':
+ ret = reg_node(EOS);
+ *flagp |= SIMPLE;
+ PL_seen_zerolen++; /* Do not optimize RE away */
+ nextchar();
+ break;
+ case 'w':
+ ret = reg_node((PL_regflags & PMf_LOCALE) ? ALNUML : ALNUM);
+ *flagp |= HASWIDTH|SIMPLE;
+ nextchar();
+ break;
+ case 'W':
+ ret = reg_node((PL_regflags & PMf_LOCALE) ? NALNUML : NALNUM);
+ *flagp |= HASWIDTH|SIMPLE;
+ nextchar();
+ break;
+ case 'b':
+ PL_seen_zerolen++;
+ ret = reg_node((PL_regflags & PMf_LOCALE) ? BOUNDL : BOUND);
+ *flagp |= SIMPLE;
+ nextchar();
+ break;
+ case 'B':
+ PL_seen_zerolen++;
+ ret = reg_node((PL_regflags & PMf_LOCALE) ? NBOUNDL : NBOUND);
+ *flagp |= SIMPLE;
+ nextchar();
+ break;
+ case 's':
+ ret = reg_node((PL_regflags & PMf_LOCALE) ? SPACEL : SPACE);
+ *flagp |= HASWIDTH|SIMPLE;
+ nextchar();
+ break;
+ case 'S':
+ ret = reg_node((PL_regflags & PMf_LOCALE) ? NSPACEL : NSPACE);
+ *flagp |= HASWIDTH|SIMPLE;
+ nextchar();
+ break;
+ case 'd':
+ ret = reg_node(DIGIT);
+ *flagp |= HASWIDTH|SIMPLE;
+ nextchar();
+ break;
+ case 'D':
+ ret = reg_node(NDIGIT);
+ *flagp |= HASWIDTH|SIMPLE;
+ nextchar();
+ break;
+ case 'n':
+ case 'r':
+ case 't':
+ case 'f':
+ case 'e':
+ case 'a':
+ case 'x':
+ case 'c':
+ case '0':
+ goto defchar;
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ {
+ I32 num = atoi(PL_regcomp_parse);
+
+ if (num > 9 && num >= PL_regnpar)
+ goto defchar;
+ else {
+ if (!SIZE_ONLY && num > PL_regcomp_rx->nparens)
+ FAIL("reference to nonexistent group");
+ PL_regsawback = 1;
+ ret = reganode((PL_regflags & PMf_FOLD)
+ ? ((PL_regflags & PMf_LOCALE) ? REFFL : REFF)
+ : REF, num);
+ *flagp |= HASWIDTH;
+ while (isDIGIT(*PL_regcomp_parse))
+ PL_regcomp_parse++;
+ PL_regcomp_parse--;
+ nextchar();
+ }
+ }
+ break;
+ case '\0':
+ if (PL_regcomp_parse >= PL_regxend)
+ FAIL("trailing \\ in regexp");
+ /* FALL THROUGH */
+ default:
+ goto defchar;
+ }
+ break;
+
+ case '#':
+ if (PL_regflags & PMf_EXTENDED) {
+ while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != '\n') PL_regcomp_parse++;
+ if (PL_regcomp_parse < PL_regxend)
+ goto tryagain;
+ }
+ /* FALL THROUGH */
+
+ default: {
+ register I32 len;
+ register U8 ender;
+ register char *p;
+ char *oldp, *s;
+ I32 numlen;
+
+ PL_regcomp_parse++;
+
+ defchar:
+ ret = reg_node((PL_regflags & PMf_FOLD)
+ ? ((PL_regflags & PMf_LOCALE) ? EXACTFL : EXACTF)
+ : EXACT);
+ s = (char *) OPERAND(ret);
+ regc(0, s++); /* save spot for len */
+ for (len = 0, p = PL_regcomp_parse - 1;
+ len < 127 && p < PL_regxend;
+ len++)
+ {
+ oldp = p;
+
+ if (PL_regflags & PMf_EXTENDED)
+ p = regwhite(p, PL_regxend);
+ switch (*p) {
+ case '^':
+ case '$':
+ case '.':
+ case '[':
+ case '(':
+ case ')':
+ case '|':
+ goto loopdone;
+ case '\\':
+ switch (*++p) {
+ case 'A':
+ case 'G':
+ case 'Z':
+ case 'z':
+ case 'w':
+ case 'W':
+ case 'b':
+ case 'B':
+ case 's':
+ case 'S':
+ case 'd':
+ case 'D':
+ --p;
+ goto loopdone;
+ case 'n':
+ ender = '\n';
+ p++;
+ break;
+ case 'r':
+ ender = '\r';
+ p++;
+ break;
+ case 't':
+ ender = '\t';
+ p++;
+ break;
+ case 'f':
+ ender = '\f';
+ p++;
+ break;
+ case 'e':
+ ender = '\033';
+ p++;
+ break;
+ case 'a':
+ ender = '\007';
+ p++;
+ break;
+ case 'x':
+ ender = scan_hex(++p, 2, &numlen);
+ p += numlen;
+ break;
+ case 'c':
+ p++;
+ ender = UCHARAT(p++);
+ ender = toCTRL(ender);
+ break;
+ case '0': case '1': case '2': case '3':case '4':
+ case '5': case '6': case '7': case '8':case '9':
+ if (*p == '0' ||
+ (isDIGIT(p[1]) && atoi(p) >= PL_regnpar) ) {
+ ender = scan_oct(p, 3, &numlen);
+ p += numlen;
+ }
+ else {
+ --p;
+ goto loopdone;
+ }
+ break;
+ case '\0':
+ if (p >= PL_regxend)
+ FAIL("trailing \\ in regexp");
+ /* FALL THROUGH */
+ default:
+ ender = *p++;
+ break;
+ }
+ break;
+ default:
+ ender = *p++;
+ break;
+ }
+ if (PL_regflags & PMf_EXTENDED)
+ p = regwhite(p, PL_regxend);
+ if (ISMULT2(p)) { /* Back off on ?+*. */
+ if (len)
+ p = oldp;
+ else {
+ len++;
+ regc(ender, s++);
+ }
+ break;
+ }
+ regc(ender, s++);
+ }
+ loopdone:
+ PL_regcomp_parse = p - 1;
+ nextchar();
+ if (len < 0)
+ FAIL("internal disaster in regexp");
+ if (len > 0)
+ *flagp |= HASWIDTH;
+ if (len == 1)
+ *flagp |= SIMPLE;
+ if (!SIZE_ONLY)
+ *OPERAND(ret) = len;
+ regc('\0', s++);
+ if (SIZE_ONLY) {
+ PL_regsize += (len + 2 + sizeof(regnode) - 1) / sizeof(regnode);
+ } else {
+ PL_regcode += (len + 2 + sizeof(regnode) - 1) / sizeof(regnode);
+ }
+ }
+ break;
+ }
+
+ return(ret);
+}
+
+STATIC char *
+regwhite(char *p, char *e)
+{
+ while (p < e) {
+ if (isSPACE(*p))
+ ++p;
+ else if (*p == '#') {
+ do {
+ p++;
+ } while (p < e && *p != '\n');
+ }
+ else
+ break;
+ }
+ return p;
+}
+
+STATIC regnode *
+regclass(void)
+{
+ dTHR;
+ register char *opnd, *s;
+ register I32 Class;
+ register I32 lastclass = 1234;
+ register I32 range = 0;
+ register regnode *ret;
+ register I32 def;
+ I32 numlen;
+
+ s = opnd = (char *) OPERAND(PL_regcode);
+ ret = reg_node(ANYOF);
+ for (Class = 0; Class < 33; Class++)
+ regc(0, s++);
+ if (*PL_regcomp_parse == '^') { /* Complement of range. */
+ PL_regnaughty++;
+ PL_regcomp_parse++;
+ if (!SIZE_ONLY)
+ *opnd |= ANYOF_INVERT;
+ }
+ if (!SIZE_ONLY) {
+ PL_regcode += ANY_SKIP;
+ if (PL_regflags & PMf_FOLD)
+ *opnd |= ANYOF_FOLD;
+ if (PL_regflags & PMf_LOCALE)
+ *opnd |= ANYOF_LOCALE;
+ } else {
+ PL_regsize += ANY_SKIP;
+ }
+ if (*PL_regcomp_parse == ']' || *PL_regcomp_parse == '-')
+ goto skipcond; /* allow 1st char to be ] or - */
+ while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != ']') {
+ skipcond:
+ Class = UCHARAT(PL_regcomp_parse++);
+ if (Class == '[' && PL_regcomp_parse + 1 < PL_regxend &&
+ /* I smell either [: or [= or [. -- POSIX has been here, right? */
+ (*PL_regcomp_parse == ':' || *PL_regcomp_parse == '=' || *PL_regcomp_parse == '.')) {
+ char posixccc = *PL_regcomp_parse;
+ char* posixccs = PL_regcomp_parse++;
+
+ while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != posixccc)
+ PL_regcomp_parse++;
+ if (PL_regcomp_parse == PL_regxend)
+ /* Grandfather lone [:, [=, [. */
+ PL_regcomp_parse = posixccs;
+ else {
+ PL_regcomp_parse++; /* skip over the posixccc */
+ if (*PL_regcomp_parse == ']') {
+ /* Not Implemented Yet.
+ * (POSIX Extended Character Classes, that is)
+ * The text between e.g. [: and :] would start
+ * at posixccs + 1 and stop at regcomp_parse - 2. */
+ if (PL_dowarn && !SIZE_ONLY)
+ warn("Character class syntax [%c %c] is reserved for future extensions", posixccc, posixccc);
+ PL_regcomp_parse++; /* skip over the ending ] */
+ }
+ }
+ }
+ if (Class == '\\') {
+ Class = UCHARAT(PL_regcomp_parse++);
+ switch (Class) {
+ case 'w':
+ if (!SIZE_ONLY) {
+ if (PL_regflags & PMf_LOCALE)
+ *opnd |= ANYOF_ALNUML;
+ else {
+ for (Class = 0; Class < 256; Class++)
+ if (isALNUM(Class))
+ ANYOF_SET(opnd, Class);
+ }
+ }
+ lastclass = 1234;
+ continue;
+ case 'W':
+ if (!SIZE_ONLY) {
+ if (PL_regflags & PMf_LOCALE)
+ *opnd |= ANYOF_NALNUML;
+ else {
+ for (Class = 0; Class < 256; Class++)
+ if (!isALNUM(Class))
+ ANYOF_SET(opnd, Class);
+ }
+ }
+ lastclass = 1234;
+ continue;
+ case 's':
+ if (!SIZE_ONLY) {
+ if (PL_regflags & PMf_LOCALE)
+ *opnd |= ANYOF_SPACEL;
+ else {
+ for (Class = 0; Class < 256; Class++)
+ if (isSPACE(Class))
+ ANYOF_SET(opnd, Class);
+ }
+ }
+ lastclass = 1234;
+ continue;
+ case 'S':
+ if (!SIZE_ONLY) {
+ if (PL_regflags & PMf_LOCALE)
+ *opnd |= ANYOF_NSPACEL;
+ else {
+ for (Class = 0; Class < 256; Class++)
+ if (!isSPACE(Class))
+ ANYOF_SET(opnd, Class);
+ }
+ }
+ lastclass = 1234;
+ continue;
+ case 'd':
+ if (!SIZE_ONLY) {
+ for (Class = '0'; Class <= '9'; Class++)
+ ANYOF_SET(opnd, Class);
+ }
+ lastclass = 1234;
+ continue;
+ case 'D':
+ if (!SIZE_ONLY) {
+ for (Class = 0; Class < '0'; Class++)
+ ANYOF_SET(opnd, Class);
+ for (Class = '9' + 1; Class < 256; Class++)
+ ANYOF_SET(opnd, Class);
+ }
+ lastclass = 1234;
+ continue;
+ case 'n':
+ Class = '\n';
+ break;
+ case 'r':
+ Class = '\r';
+ break;
+ case 't':
+ Class = '\t';
+ break;
+ case 'f':
+ Class = '\f';
+ break;
+ case 'b':
+ Class = '\b';
+ break;
+ case 'e':
+ Class = '\033';
+ break;
+ case 'a':
+ Class = '\007';
+ break;
+ case 'x':
+ Class = scan_hex(PL_regcomp_parse, 2, &numlen);
+ PL_regcomp_parse += numlen;
+ break;
+ case 'c':
+ Class = UCHARAT(PL_regcomp_parse++);
+ Class = toCTRL(Class);
+ break;
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ Class = scan_oct(--PL_regcomp_parse, 3, &numlen);
+ PL_regcomp_parse += numlen;
+ break;
+ }
+ }
+ if (range) {
+ if (lastclass > Class)
+ FAIL("invalid [] range in regexp");
+ range = 0;
+ }
+ else {
+ lastclass = Class;
+ if (*PL_regcomp_parse == '-' && PL_regcomp_parse+1 < PL_regxend &&
+ PL_regcomp_parse[1] != ']') {
+ PL_regcomp_parse++;
+ range = 1;
+ continue; /* do it next time */
+ }
+ }
+ if (!SIZE_ONLY) {
+ for ( ; lastclass <= Class; lastclass++)
+ ANYOF_SET(opnd, lastclass);
+ }
+ lastclass = Class;
+ }
+ if (*PL_regcomp_parse != ']')
+ FAIL("unmatched [] in regexp");
+ nextchar();
+ /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
+ if (!SIZE_ONLY && (*opnd & (0xFF ^ ANYOF_INVERT)) == ANYOF_FOLD) {
+ for (Class = 0; Class < 256; ++Class) {
+ if (ANYOF_TEST(opnd, Class)) {
+ I32 cf = fold[Class];
+ ANYOF_SET(opnd, cf);
+ }
+ }
+ *opnd &= ~ANYOF_FOLD;
+ }
+ /* optimize inverted simple patterns (e.g. [^a-z]) */
+ if (!SIZE_ONLY && (*opnd & 0xFF) == ANYOF_INVERT) {
+ for (Class = 0; Class < 32; ++Class)
+ opnd[1 + Class] ^= 0xFF;
+ *opnd = 0;
+ }
+ return ret;
+}
+
+STATIC char*
+nextchar(void)
+{
+ dTHR;
+ char* retval = PL_regcomp_parse++;
+
+ for (;;) {
+ if (*PL_regcomp_parse == '(' && PL_regcomp_parse[1] == '?' &&
+ PL_regcomp_parse[2] == '#') {
+ while (*PL_regcomp_parse && *PL_regcomp_parse != ')')
+ PL_regcomp_parse++;
+ PL_regcomp_parse++;
+ continue;
+ }
+ if (PL_regflags & PMf_EXTENDED) {
+ if (isSPACE(*PL_regcomp_parse)) {
+ PL_regcomp_parse++;
+ continue;
+ }
+ else if (*PL_regcomp_parse == '#') {
+ while (*PL_regcomp_parse && *PL_regcomp_parse != '\n')
+ PL_regcomp_parse++;
+ PL_regcomp_parse++;
+ continue;
+ }
+ }
+ return retval;
+ }
+}
+
+/*
+- reg_node - emit a node
+*/
+STATIC regnode * /* Location. */
+reg_node(U8 op)
+{
+ dTHR;
+ register regnode *ret;
+ register regnode *ptr;
+
+ ret = PL_regcode;
+ if (SIZE_ONLY) {
+ SIZE_ALIGN(PL_regsize);
+ PL_regsize += 1;
+ return(ret);
+ }
+
+ NODE_ALIGN_FILL(ret);
+ ptr = ret;
+ FILL_ADVANCE_NODE(ptr, op);
+ PL_regcode = ptr;
+
+ return(ret);
+}
+
+/*
+- reganode - emit a node with an argument
+*/
+STATIC regnode * /* Location. */
+reganode(U8 op, U32 arg)
+{
+ dTHR;
+ register regnode *ret;
+ register regnode *ptr;
+
+ ret = PL_regcode;
+ if (SIZE_ONLY) {
+ SIZE_ALIGN(PL_regsize);
+ PL_regsize += 2;
+ return(ret);
+ }
+
+ NODE_ALIGN_FILL(ret);
+ ptr = ret;
+ FILL_ADVANCE_NODE_ARG(ptr, op, arg);
+ PL_regcode = ptr;
+
+ return(ret);
+}
+
+/*
+- regc - emit (if appropriate) a byte of code
+*/
+STATIC void
+regc(U8 b, char* s)
+{
+ dTHR;
+ if (!SIZE_ONLY)
+ *s = b;
+}
+
+/*
+- reginsert - insert an operator in front of already-emitted operand
+*
+* Means relocating the operand.
+*/
+STATIC void
+reginsert(U8 op, regnode *opnd)
+{
+ dTHR;
+ register regnode *src;
+ register regnode *dst;
+ register regnode *place;
+ register int offset = regarglen[(U8)op];
+
+/* (regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
+
+ if (SIZE_ONLY) {
+ PL_regsize += NODE_STEP_REGNODE + offset;
+ return;
+ }
+
+ src = PL_regcode;
+ PL_regcode += NODE_STEP_REGNODE + offset;
+ dst = PL_regcode;
+ while (src > opnd)
+ StructCopy(--src, --dst, regnode);
+
+ place = opnd; /* Op node, where operand used to be. */
+ src = NEXTOPER(place);
+ FILL_ADVANCE_NODE(place, op);
+ Zero(src, offset, regnode);
+}
+
+/*
+- regtail - set the next-pointer at the end of a node chain of p to val.
+*/
+STATIC void
+regtail(regnode *p, regnode *val)
+{
+ dTHR;
+ register regnode *scan;
+ register regnode *temp;
+ register I32 offset;
+
+ if (SIZE_ONLY)
+ return;
+
+ /* Find last node. */
+ scan = p;
+ for (;;) {
+ temp = regnext(scan);
+ if (temp == NULL)
+ break;
+ scan = temp;
+ }
+
+ if (reg_off_by_arg[OP(scan)]) {
+ ARG_SET(scan, val - scan);
+ } else {
+ NEXT_OFF(scan) = val - scan;
+ }
+}
+
+/*
+- regoptail - regtail on operand of first argument; nop if operandless
+*/
+STATIC void
+regoptail(regnode *p, regnode *val)
+{
+ dTHR;
+ /* "Operandless" and "op != BRANCH" are synonymous in practice. */
+ if (p == NULL || SIZE_ONLY)
+ return;
+ if (regkind[(U8)OP(p)] == BRANCH) {
+ regtail(NEXTOPER(p), val);
+ } else if ( regkind[(U8)OP(p)] == BRANCHJ) {
+ regtail(NEXTOPER(NEXTOPER(p)), val);
+ } else
+ return;
+}
+
+/*
+ - regcurly - a little FSA that accepts {\d+,?\d*}
+ */
+STATIC I32
+regcurly(register char *s)
+{
+ if (*s++ != '{')
+ return FALSE;
+ if (!isDIGIT(*s))
+ return FALSE;
+ while (isDIGIT(*s))
+ s++;
+ if (*s == ',')
+ s++;
+ while (isDIGIT(*s))
+ s++;
+ if (*s != '}')
+ return FALSE;
+ return TRUE;
+}
+
+
+STATIC regnode *
+dumpuntil(regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
+{
+#ifdef DEBUGGING
+ register char op = EXACT; /* Arbitrary non-END op. */
+ register regnode *next, *onode;
+
+ while (op != END && (!last || node < last)) {
+ /* While that wasn't END last time... */
+
+ NODE_ALIGN(node);
+ op = OP(node);
+ if (op == CLOSE)
+ l--;
+ next = regnext(node);
+ /* Where, what. */
+ if (OP(node) == OPTIMIZED)
+ goto after_print;
+ regprop(sv, node);
+ PerlIO_printf(Perl_debug_log, "%4d:%*s%s", node - start,
+ 2*l + 1, "", SvPVX(sv));
+ if (next == NULL) /* Next ptr. */
+ PerlIO_printf(Perl_debug_log, "(0)");
+ else
+ PerlIO_printf(Perl_debug_log, "(%d)", next - start);
+ (void)PerlIO_putc(Perl_debug_log, '\n');
+ after_print:
+ if (regkind[(U8)op] == BRANCHJ) {
+ register regnode *nnode = (OP(next) == LONGJMP
+ ? regnext(next)
+ : next);
+ if (last && nnode > last)
+ nnode = last;
+ node = dumpuntil(start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
+ } else if (regkind[(U8)op] == BRANCH) {
+ node = dumpuntil(start, NEXTOPER(node), next, sv, l + 1);
+ } else if ( op == CURLY) { /* `next' might be very big: optimizer */
+ node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
+ NEXTOPER(node) + EXTRA_STEP_2ARGS + 1, sv, l + 1);
+ } else if (regkind[(U8)op] == CURLY && op != CURLYX) {
+ node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
+ next, sv, l + 1);
+ } else if ( op == PLUS || op == STAR) {
+ node = dumpuntil(start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
+ } else if (op == ANYOF) {
+ node = NEXTOPER(node);
+ node += ANY_SKIP;
+ } else if (regkind[(U8)op] == EXACT) {
+ /* Literal string, where present. */
+ node += ((*OPERAND(node)) + 2 + sizeof(regnode) - 1) / sizeof(regnode);
+ node = NEXTOPER(node);
+ } else {
+ node = NEXTOPER(node);
+ node += regarglen[(U8)op];
+ }
+ if (op == CURLYX || op == OPEN)
+ l++;
+ else if (op == WHILEM)
+ l--;
+ }
+#endif /* DEBUGGING */
+ return node;
+}
+
+/*
+ - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
+ */
+void
+regdump(regexp *r)
+{
+#ifdef DEBUGGING
+ dTHR;
+ SV *sv = sv_newmortal();
+
+ (void)dumpuntil(r->program, r->program + 1, NULL, sv, 0);
+
+ /* Header fields of interest. */
+ if (r->anchored_substr)
+ PerlIO_printf(Perl_debug_log, "anchored `%s%s%s'%s at %d ",
+ PL_colors[0],
+ SvPVX(r->anchored_substr),
+ PL_colors[1],
+ SvTAIL(r->anchored_substr) ? "$" : "",
+ r->anchored_offset);
+ if (r->float_substr)
+ PerlIO_printf(Perl_debug_log, "floating `%s%s%s'%s at %d..%u ",
+ PL_colors[0],
+ SvPVX(r->float_substr),
+ PL_colors[1],
+ SvTAIL(r->float_substr) ? "$" : "",
+ r->float_min_offset, r->float_max_offset);
+ if (r->check_substr)
+ PerlIO_printf(Perl_debug_log,
+ r->check_substr == r->float_substr
+ ? "(checking floating" : "(checking anchored");
+ if (r->reganch & ROPT_NOSCAN)
+ PerlIO_printf(Perl_debug_log, " noscan");
+ if (r->reganch & ROPT_CHECK_ALL)
+ PerlIO_printf(Perl_debug_log, " isall");
+ if (r->check_substr)
+ PerlIO_printf(Perl_debug_log, ") ");
+
+ if (r->regstclass) {
+ regprop(sv, r->regstclass);
+ PerlIO_printf(Perl_debug_log, "stclass `%s' ", SvPVX(sv));
+ }
+ if (r->reganch & ROPT_ANCH) {
+ PerlIO_printf(Perl_debug_log, "anchored");
+ if (r->reganch & ROPT_ANCH_BOL)
+ PerlIO_printf(Perl_debug_log, "(BOL)");
+ if (r->reganch & ROPT_ANCH_MBOL)
+ PerlIO_printf(Perl_debug_log, "(MBOL)");
+ if (r->reganch & ROPT_ANCH_GPOS)
+ PerlIO_printf(Perl_debug_log, "(GPOS)");
+ PerlIO_putc(Perl_debug_log, ' ');
+ }
+ if (r->reganch & ROPT_GPOS_SEEN)
+ PerlIO_printf(Perl_debug_log, "GPOS ");
+ if (r->reganch & ROPT_SKIP)
+ PerlIO_printf(Perl_debug_log, "plus ");
+ if (r->reganch & ROPT_IMPLICIT)
+ PerlIO_printf(Perl_debug_log, "implicit ");
+ PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
+ if (r->reganch & ROPT_EVAL_SEEN)
+ PerlIO_printf(Perl_debug_log, "with eval ");
+ PerlIO_printf(Perl_debug_log, "\n");
+#endif /* DEBUGGING */
+}
+
+/*
+- regprop - printable representation of opcode
+*/
+void
+regprop(SV *sv, regnode *o)
+{
+#ifdef DEBUGGING
+ dTHR;
+ register char *p = 0;
+
+ sv_setpvn(sv, "", 0);
+ switch (OP(o)) {
+ case BOL:
+ p = "BOL";
+ break;
+ case MBOL:
+ p = "MBOL";
+ break;
+ case SBOL:
+ p = "SBOL";
+ break;
+ case EOL:
+ p = "EOL";
+ break;
+ case EOS:
+ p = "EOS";
+ break;
+ case MEOL:
+ p = "MEOL";
+ break;
+ case SEOL:
+ p = "SEOL";
+ break;
+ case ANY:
+ p = "ANY";
+ break;
+ case SANY:
+ p = "SANY";
+ break;
+ case ANYOF:
+ p = "ANYOF";
+ break;
+ case BRANCH:
+ p = "BRANCH";
+ break;
+ case EXACT:
+ sv_catpvf(sv, "EXACT <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]);
+ break;
+ case EXACTF:
+ sv_catpvf(sv, "EXACTF <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]);
+ break;
+ case EXACTFL:
+ sv_catpvf(sv, "EXACTFL <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]);
+ break;
+ case NOTHING:
+ p = "NOTHING";
+ break;
+ case TAIL:
+ p = "TAIL";
+ break;
+ case BACK:
+ p = "BACK";
+ break;
+ case END:
+ p = "END";
+ break;
+ case BOUND:
+ p = "BOUND";
+ break;
+ case BOUNDL:
+ p = "BOUNDL";
+ break;
+ case NBOUND:
+ p = "NBOUND";
+ break;
+ case NBOUNDL:
+ p = "NBOUNDL";
+ break;
+ case CURLY:
+ sv_catpvf(sv, "CURLY {%d,%d}", ARG1(o), ARG2(o));
+ break;
+ case CURLYM:
+ sv_catpvf(sv, "CURLYM[%d] {%d,%d}", o->flags, ARG1(o), ARG2(o));
+ break;
+ case CURLYN:
+ sv_catpvf(sv, "CURLYN[%d] {%d,%d}", o->flags, ARG1(o), ARG2(o));
+ break;
+ case CURLYX:
+ sv_catpvf(sv, "CURLYX {%d,%d}", ARG1(o), ARG2(o));
+ break;
+ case REF:
+ sv_catpvf(sv, "REF%d", ARG(o));
+ break;
+ case REFF:
+ sv_catpvf(sv, "REFF%d", ARG(o));
+ break;
+ case REFFL:
+ sv_catpvf(sv, "REFFL%d", ARG(o));
+ break;
+ case OPEN:
+ sv_catpvf(sv, "OPEN%d", ARG(o));
+ break;
+ case CLOSE:
+ sv_catpvf(sv, "CLOSE%d", ARG(o));
+ p = NULL;
+ break;
+ case STAR:
+ p = "STAR";
+ break;
+ case PLUS:
+ p = "PLUS";
+ break;
+ case MINMOD:
+ p = "MINMOD";
+ break;
+ case GPOS:
+ p = "GPOS";
+ break;
+ case UNLESSM:
+ sv_catpvf(sv, "UNLESSM[-%d]", o->flags);
+ break;
+ case IFMATCH:
+ sv_catpvf(sv, "IFMATCH[-%d]", o->flags);
+ break;
+ case SUCCEED:
+ p = "SUCCEED";
+ break;
+ case WHILEM:
+ p = "WHILEM";
+ break;
+ case DIGIT:
+ p = "DIGIT";
+ break;
+ case NDIGIT:
+ p = "NDIGIT";
+ break;
+ case ALNUM:
+ p = "ALNUM";
+ break;
+ case NALNUM:
+ p = "NALNUM";
+ break;
+ case SPACE:
+ p = "SPACE";
+ break;
+ case NSPACE:
+ p = "NSPACE";
+ break;
+ case ALNUML:
+ p = "ALNUML";
+ break;
+ case NALNUML:
+ p = "NALNUML";
+ break;
+ case SPACEL:
+ p = "SPACEL";
+ break;
+ case NSPACEL:
+ p = "NSPACEL";
+ break;
+ case EVAL:
+ p = "EVAL";
+ break;
+ case LONGJMP:
+ p = "LONGJMP";
+ break;
+ case BRANCHJ:
+ p = "BRANCHJ";
+ break;
+ case IFTHEN:
+ p = "IFTHEN";
+ break;
+ case GROUPP:
+ sv_catpvf(sv, "GROUPP%d", ARG(o));
+ break;
+ case LOGICAL:
+ p = "LOGICAL";
+ break;
+ case SUSPEND:
+ p = "SUSPEND";
+ break;
+ case RENUM:
+ p = "RENUM";
+ break;
+ case OPTIMIZED:
+ p = "OPTIMIZED";
+ break;
+ default:
+ FAIL("corrupted regexp opcode");
+ }
+ if (p)
+ sv_catpv(sv, p);
+#endif /* DEBUGGING */
+}
+
+void
+pregfree(struct regexp *r)
+{
+ dTHR;
+ if (!r || (--r->refcnt > 0))
+ return;
+ if (r->precomp)
+ Safefree(r->precomp);
+ if (r->subbase)
+ Safefree(r->subbase);
+ if (r->substrs) {
+ if (r->anchored_substr)
+ SvREFCNT_dec(r->anchored_substr);
+ if (r->float_substr)
+ SvREFCNT_dec(r->float_substr);
+ Safefree(r->substrs);
+ }
+ if (r->data) {
+ int n = r->data->count;
+ while (--n >= 0) {
+ switch (r->data->what[n]) {
+ case 's':
+ SvREFCNT_dec((SV*)r->data->data[n]);
+ break;
+ case 'o':
+ op_free((OP_4tree*)r->data->data[n]);
+ break;
+ case 'n':
+ break;
+ default:
+ FAIL2("panic: regfree data code '%c'", r->data->what[n]);
+ }
+ }
+ Safefree(r->data->what);
+ Safefree(r->data);
+ }
+ Safefree(r->startp);
+ Safefree(r->endp);
+ Safefree(r);
+}
+
+/*
+ - regnext - dig the "next" pointer out of a node
+ *
+ * [Note, when REGALIGN is defined there are two places in regmatch()
+ * that bypass this code for speed.]
+ */
+regnode *
+regnext(register regnode *p)
+{
+ dTHR;
+ register I32 offset;
+
+ if (p == &PL_regdummy)
+ return(NULL);
+
+ offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
+ if (offset == 0)
+ return(NULL);
+
+ return(p+offset);
+}
+
+STATIC void
+re_croak2(const char* pat1,const char* pat2,...)
+{
+ va_list args;
+ STRLEN l1 = strlen(pat1);
+ STRLEN l2 = strlen(pat2);
+ char buf[512];
+ char *message;
+
+ if (l1 > 510)
+ l1 = 510;
+ if (l1 + l2 > 510)
+ l2 = 510 - l1;
+ Copy(pat1, buf, l1 , char);
+ Copy(pat2, buf + l1, l2 , char);
+ buf[l1 + l2] = '\n';
+ buf[l1 + l2 + 1] = '\0';
+ va_start(args, pat2);
+ message = mess(buf, &args);
+ va_end(args);
+ l1 = strlen(message);
+ if (l1 > 512)
+ l1 = 512;
+ Copy(message, buf, l1 , char);
+ buf[l1] = '\0'; /* Overwrite \n */
+ croak("%s", buf);
+}
diff --git a/contrib/perl5/regcomp.h b/contrib/perl5/regcomp.h
new file mode 100644
index 000000000000..526b885eecf8
--- /dev/null
+++ b/contrib/perl5/regcomp.h
@@ -0,0 +1,222 @@
+/* regcomp.h
+ */
+
+typedef OP OP_4tree; /* Will be redefined later. */
+
+/*
+ * The "internal use only" fields in regexp.h are present to pass info from
+ * compile to execute that permits the execute phase to run lots faster on
+ * simple cases. They are:
+ *
+ * regstart sv that must begin a match; Nullch if none obvious
+ * reganch is the match anchored (at beginning-of-line only)?
+ * regmust string (pointer into program) that match must include, or NULL
+ * [regmust changed to SV* for bminstr()--law]
+ * regmlen length of regmust string
+ * [regmlen not used currently]
+ *
+ * Regstart and reganch permit very fast decisions on suitable starting points
+ * for a match, cutting down the work a lot. Regmust permits fast rejection
+ * of lines that cannot possibly match. The regmust tests are costly enough
+ * that pregcomp() supplies a regmust only if the r.e. contains something
+ * potentially expensive (at present, the only such thing detected is * or +
+ * at the start of the r.e., which can involve a lot of backup). Regmlen is
+ * supplied because the test in pregexec() needs it and pregcomp() is computing
+ * it anyway.
+ * [regmust is now supplied always. The tests that use regmust have a
+ * heuristic that disables the test if it usually matches.]
+ *
+ * [In fact, we now use regmust in many cases to locate where the search
+ * starts in the string, so if regback is >= 0, the regmust search is never
+ * wasted effort. The regback variable says how many characters back from
+ * where regmust matched is the earliest possible start of the match.
+ * For instance, /[a-z].foo/ has a regmust of 'foo' and a regback of 2.]
+ */
+
+/*
+ * Structure for regexp "program". This is essentially a linear encoding
+ * of a nondeterministic finite-state machine (aka syntax charts or
+ * "railroad normal form" in parsing technology). Each node is an opcode
+ * plus a "next" pointer, possibly plus an operand. "Next" pointers of
+ * all nodes except BRANCH implement concatenation; a "next" pointer with
+ * a BRANCH on both ends of it is connecting two alternatives. (Here we
+ * have one of the subtle syntax dependencies: an individual BRANCH (as
+ * opposed to a collection of them) is never concatenated with anything
+ * because of operator precedence.) The operand of some types of node is
+ * a literal string; for others, it is a node leading into a sub-FSM. In
+ * particular, the operand of a BRANCH node is the first node of the branch.
+ * (NB this is *not* a tree structure: the tail of the branch connects
+ * to the thing following the set of BRANCHes.) The opcodes are:
+ */
+
+/*
+ * A node is one char of opcode followed by two chars of "next" pointer.
+ * "Next" pointers are stored as two 8-bit pieces, high order first. The
+ * value is a positive offset from the opcode of the node containing it.
+ * An operand, if any, simply follows the node. (Note that much of the
+ * code generation knows about this implicit relationship.)
+ *
+ * Using two bytes for the "next" pointer is vast overkill for most things,
+ * but allows patterns to get big without disasters.
+ *
+ * [The "next" pointer is always aligned on an even
+ * boundary, and reads the offset directly as a short. Also, there is no
+ * special test to reverse the sign of BACK pointers since the offset is
+ * stored negative.]
+ */
+
+struct regnode_string {
+ U8 flags;
+ U8 type;
+ U16 next_off;
+ U8 string[1];
+};
+
+struct regnode_1 {
+ U8 flags;
+ U8 type;
+ U16 next_off;
+ U32 arg1;
+};
+
+struct regnode_2 {
+ U8 flags;
+ U8 type;
+ U16 next_off;
+ U16 arg1;
+ U16 arg2;
+};
+
+/* XXX fix this description.
+ Impose a limit of REG_INFTY on various pattern matching operations
+ to limit stack growth and to avoid "infinite" recursions.
+*/
+/* The default size for REG_INFTY is I16_MAX, which is the same as
+ SHORT_MAX (see perl.h). Unfortunately I16 isn't necessarily 16 bits
+ (see handy.h). On the Cray C90, sizeof(short)==4 and hence I16_MAX is
+ ((1<<31)-1), while on the Cray T90, sizeof(short)==8 and I16_MAX is
+ ((1<<63)-1). To limit stack growth to reasonable sizes, supply a
+ smaller default.
+ --Andy Dougherty 11 June 1998
+*/
+#if SHORTSIZE > 2
+# ifndef REG_INFTY
+# define REG_INFTY ((1<<15)-1)
+# endif
+#endif
+
+#ifndef REG_INFTY
+# define REG_INFTY I16_MAX
+#endif
+
+#define ARG_VALUE(arg) (arg)
+#define ARG__SET(arg,val) ((arg) = (val))
+
+#define ARG(p) ARG_VALUE(ARG_LOC(p))
+#define ARG1(p) ARG_VALUE(ARG1_LOC(p))
+#define ARG2(p) ARG_VALUE(ARG2_LOC(p))
+#define ARG_SET(p, val) ARG__SET(ARG_LOC(p), (val))
+#define ARG1_SET(p, val) ARG__SET(ARG1_LOC(p), (val))
+#define ARG2_SET(p, val) ARG__SET(ARG2_LOC(p), (val))
+
+#ifndef lint
+# define NEXT_OFF(p) ((p)->next_off)
+# define NODE_ALIGN(node)
+# define NODE_ALIGN_FILL(node) ((node)->flags = 0xde) /* deadbeef */
+#else /* lint */
+# define NEXT_OFF(p) 0
+# define NODE_ALIGN(node)
+# define NODE_ALIGN_FILL(node)
+#endif /* lint */
+
+#define SIZE_ALIGN NODE_ALIGN
+
+#define OP(p) ((p)->type)
+#define OPERAND(p) (((struct regnode_string *)p)->string)
+#define NODE_ALIGN(node)
+#define ARG_LOC(p) (((struct regnode_1 *)p)->arg1)
+#define ARG1_LOC(p) (((struct regnode_2 *)p)->arg1)
+#define ARG2_LOC(p) (((struct regnode_2 *)p)->arg2)
+#define NODE_STEP_REGNODE 1 /* sizeof(regnode)/sizeof(regnode) */
+#define EXTRA_STEP_2ARGS EXTRA_SIZE(struct regnode_2)
+
+#define NODE_STEP_B 4
+
+#define NEXTOPER(p) ((p) + NODE_STEP_REGNODE)
+#define PREVOPER(p) ((p) - NODE_STEP_REGNODE)
+
+#define FILL_ADVANCE_NODE(ptr, op) STMT_START { \
+ (ptr)->type = op; (ptr)->next_off = 0; (ptr)++; } STMT_END
+#define FILL_ADVANCE_NODE_ARG(ptr, op, arg) STMT_START { \
+ ARG_SET(ptr, arg); FILL_ADVANCE_NODE(ptr, op); (ptr) += 1; } STMT_END
+
+#define MAGIC 0234
+
+#define SIZE_ONLY (PL_regcode == &PL_regdummy)
+
+/* Flags for first parameter byte of ANYOF */
+#define ANYOF_INVERT 0x40
+#define ANYOF_FOLD 0x20
+#define ANYOF_LOCALE 0x10
+#define ANYOF_ISA 0x0F
+#define ANYOF_ALNUML 0x08
+#define ANYOF_NALNUML 0x04
+#define ANYOF_SPACEL 0x02
+#define ANYOF_NSPACEL 0x01
+
+/* Utility macros for bitmap of ANYOF */
+#define ANYOF_BYTE(p,c) (p)[1 + (((c) >> 3) & 31)]
+#define ANYOF_BIT(c) (1 << ((c) & 7))
+#define ANYOF_SET(p,c) (ANYOF_BYTE(p,c) |= ANYOF_BIT(c))
+#define ANYOF_CLEAR(p,c) (ANYOF_BYTE(p,c) &= ~ANYOF_BIT(c))
+#define ANYOF_TEST(p,c) (ANYOF_BYTE(p,c) & ANYOF_BIT(c))
+
+#define ANY_SKIP ((33 - 1)/sizeof(regnode) + 1)
+
+/*
+ * Utility definitions.
+ */
+#ifndef lint
+#ifndef CHARMASK
+#define UCHARAT(p) ((int)*(unsigned char *)(p))
+#else
+#define UCHARAT(p) ((int)*(p)&CHARMASK)
+#endif
+#else /* lint */
+#define UCHARAT(p) PL_regdummy
+#endif /* lint */
+
+#define FAIL(m) croak ("/%.127s/: %s", PL_regprecomp,m)
+#define FAIL2(pat,m) re_croak2("/%.127s/: ",pat,PL_regprecomp,m)
+
+#define EXTRA_SIZE(guy) ((sizeof(guy)-1)/sizeof(struct regnode))
+
+#define REG_SEEN_ZERO_LEN 1
+#define REG_SEEN_LOOKBEHIND 2
+#define REG_SEEN_GPOS 4
+#define REG_SEEN_EVAL 8
+
+#include "regnodes.h"
+
+/* The following have no fixed length. char* since we do strchr on it. */
+#ifndef DOINIT
+EXTCONST char varies[];
+#else
+EXTCONST char varies[] = {
+ BRANCH, BACK, STAR, PLUS, CURLY, CURLYX, REF, REFF, REFFL,
+ WHILEM, CURLYM, CURLYN, BRANCHJ, IFTHEN, SUSPEND, 0
+};
+#endif
+
+/* The following always have a length of 1. char* since we do strchr on it. */
+#ifndef DOINIT
+EXTCONST char simple[];
+#else
+EXTCONST char simple[] = {
+ ANY, SANY, ANYOF,
+ ALNUM, ALNUML, NALNUM, NALNUML,
+ SPACE, SPACEL, NSPACE, NSPACEL,
+ DIGIT, NDIGIT, 0
+};
+#endif
+
diff --git a/contrib/perl5/regcomp.pl b/contrib/perl5/regcomp.pl
new file mode 100644
index 000000000000..cfe59adc2213
--- /dev/null
+++ b/contrib/perl5/regcomp.pl
@@ -0,0 +1,98 @@
+#use Fatal qw(open close rename chmod unlink);
+open DESC, 'regcomp.sym';
+$ind = 0;
+
+while (<DESC>) {
+ next if /^\s*($|\#)/;
+ $ind++;
+ chomp;
+ ($name[$ind], $desc, $rest[$ind]) = split /\t+/, $_, 3;
+ ($type[$ind], $code[$ind], $args[$ind], $longj[$ind])
+ = split /[,\s]\s*/, $desc, 4;
+}
+close DESC;
+$tot = $ind;
+
+$tmp_h = 'tmp_reg.h';
+
+unlink $tmp_h if -f $tmp_h;
+
+open OUT, ">$tmp_h";
+
+print OUT <<EOP;
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by regcomp.pl from regcomp.sym.
+ Any changes made here will be lost!
+*/
+
+EOP
+
+$ind = 0;
+while (++$ind <= $tot) {
+ $oind = $ind - 1;
+ $hind = sprintf "%#4x", $oind;
+ print OUT <<EOP;
+#define $name[$ind] $oind /* $hind $rest[$ind] */
+EOP
+}
+
+print OUT <<EOP;
+
+#ifndef DOINIT
+EXTCONST U8 regkind[];
+#else
+EXTCONST U8 regkind[] = {
+EOP
+
+$ind = 0;
+while (++$ind <= $tot) {
+ print OUT <<EOP;
+ $type[$ind], /* $name[$ind] */
+EOP
+}
+
+print OUT <<EOP;
+};
+#endif
+
+
+#ifdef REG_COMP_C
+const static U8 regarglen[] = {
+EOP
+
+$ind = 0;
+while (++$ind <= $tot) {
+ $size = 0;
+ $size = "EXTRA_SIZE(struct regnode_$args[$ind])" if $args[$ind];
+
+ print OUT <<EOP;
+ $size, /* $name[$ind] */
+EOP
+}
+
+print OUT <<EOP;
+};
+
+const static char reg_off_by_arg[] = {
+EOP
+
+$ind = 0;
+while (++$ind <= $tot) {
+ $size = $longj[$ind] || 0;
+
+ print OUT <<EOP;
+ $size, /* $name[$ind] */
+EOP
+}
+
+print OUT <<EOP;
+};
+#endif /* REG_COMP_C */
+
+EOP
+
+close OUT;
+
+chmod 0666, 'regnodes.h';
+unlink 'regnodes.h';
+rename $tmp_h, 'regnodes.h';
diff --git a/contrib/perl5/regcomp.sym b/contrib/perl5/regcomp.sym
new file mode 100644
index 000000000000..9775b9374da1
--- /dev/null
+++ b/contrib/perl5/regcomp.sym
@@ -0,0 +1,112 @@
+# Format:
+# NAME \t TYPE, arg-description [num-args] [longjump-len] \t DESCRIPTION
+
+# Empty rows and #-comment rows are ignored.
+
+# Exit points
+END END, no End of program.
+SUCCEED END, no Return from a subroutine, basically.
+
+# Anchors:
+BOL BOL, no Match "" at beginning of line.
+MBOL BOL, no Same, assuming multiline.
+SBOL BOL, no Same, assuming singleline.
+EOS EOL, no Match "" at end of string.
+EOL EOL, no Match "" at end of line.
+MEOL EOL, no Same, assuming multiline.
+SEOL EOL, no Same, assuming singleline.
+BOUND BOUND, no Match "" at any word boundary
+BOUNDL BOUND, no Match "" at any word boundary
+NBOUND NBOUND, no Match "" at any word non-boundary
+NBOUNDL NBOUND, no Match "" at any word non-boundary
+GPOS GPOS, no Matches where last m//g left off.
+
+# [Special] alternatives
+ANY ANY, no Match any one character (except newline).
+SANY ANY, no Match any one character.
+ANYOF ANYOF, sv Match character in (or not in) this class.
+ALNUM ALNUM, no Match any alphanumeric character
+ALNUML ALNUM, no Match any alphanumeric char in locale
+NALNUM NALNUM, no Match any non-alphanumeric character
+NALNUML NALNUM, no Match any non-alphanumeric char in locale
+SPACE SPACE, no Match any whitespace character
+SPACEL SPACE, no Match any whitespace char in locale
+NSPACE NSPACE, no Match any non-whitespace character
+NSPACEL NSPACE, no Match any non-whitespace char in locale
+DIGIT DIGIT, no Match any numeric character
+NDIGIT NDIGIT, no Match any non-numeric character
+
+# BRANCH The set of branches constituting a single choice are hooked
+# together with their "next" pointers, since precedence prevents
+# anything being concatenated to any individual branch. The
+# "next" pointer of the last BRANCH in a choice points to the
+# thing following the whole choice. This is also where the
+# final "next" pointer of each individual branch points; each
+# branch starts with the operand node of a BRANCH node.
+#
+BRANCH BRANCH, node Match this alternative, or the next...
+
+# BACK Normal "next" pointers all implicitly point forward; BACK
+# exists to make loop structures possible.
+# not used
+BACK BACK, no Match "", "next" ptr points backward.
+
+# Literals
+EXACT EXACT, sv Match this string (preceded by length).
+EXACTF EXACT, sv Match this string, folded (prec. by length).
+EXACTFL EXACT, sv Match this string, folded in locale (w/len).
+
+# Do nothing
+NOTHING NOTHING,no Match empty string.
+# A variant of above which delimits a group, thus stops optimizations
+TAIL NOTHING,no Match empty string. Can jump here from outside.
+
+# STAR,PLUS '?', and complex '*' and '+', are implemented as circular
+# BRANCH structures using BACK. Simple cases (one character
+# per match) are implemented with STAR and PLUS for speed
+# and to minimize recursive plunges.
+#
+STAR STAR, node Match this (simple) thing 0 or more times.
+PLUS PLUS, node Match this (simple) thing 1 or more times.
+
+CURLY CURLY, sv 2 Match this simple thing {n,m} times.
+CURLYN CURLY, no 2 Match next-after-this simple thing
+# {n,m} times, set parenths.
+CURLYM CURLY, no 2 Match this medium-complex thing {n,m} times.
+CURLYX CURLY, sv 2 Match this complex thing {n,m} times.
+
+# This terminator creates a loop structure for CURLYX
+WHILEM WHILEM, no Do curly processing and see if rest matches.
+
+# OPEN,CLOSE,GROUPP ...are numbered at compile time.
+OPEN OPEN, num 1 Mark this point in input as start of #n.
+CLOSE CLOSE, num 1 Analogous to OPEN.
+
+REF REF, num 1 Match some already matched string
+REFF REF, num 1 Match already matched string, folded
+REFFL REF, num 1 Match already matched string, folded in loc.
+
+# grouping assertions
+IFMATCH BRANCHJ,off 1 2 Succeeds if the following matches.
+UNLESSM BRANCHJ,off 1 2 Fails if the following matches.
+SUSPEND BRANCHJ,off 1 1 "Independent" sub-RE.
+IFTHEN BRANCHJ,off 1 1 Switch, should be preceeded by switcher .
+GROUPP GROUPP, num 1 Whether the group matched.
+
+# Support for long RE
+LONGJMP LONGJMP,off 1 1 Jump far away.
+BRANCHJ BRANCHJ,off 1 1 BRANCH with long offset.
+
+# The heavy worker
+EVAL EVAL, evl 1 Execute some Perl code.
+
+# Modifiers
+MINMOD MINMOD, no Next operator is not greedy.
+LOGICAL LOGICAL,no Next opcode should set the flag only.
+
+# This is not used yet
+RENUM BRANCHJ,off 1 1 Group with independently numbered parens.
+
+# This is not really a node, but an optimized away piece of a "long" node.
+# To simplify debugging output, we mark it as if it were a node
+OPTIMIZED NOTHING,off Placeholder for dump.
diff --git a/contrib/perl5/regexec.c b/contrib/perl5/regexec.c
new file mode 100644
index 000000000000..f8c5e7e9972a
--- /dev/null
+++ b/contrib/perl5/regexec.c
@@ -0,0 +1,1834 @@
+/* regexec.c
+ */
+
+/*
+ * "One Ring to rule them all, One Ring to find them..."
+ */
+
+/* NOTE: this is derived from Henry Spencer's regexp code, and should not
+ * confused with the original package (see point 3 below). Thanks, Henry!
+ */
+
+/* Additional note: this code is very heavily munged from Henry's version
+ * in places. In some spots I've traded clarity for efficiency, so don't
+ * blame Henry for some of the lack of readability.
+ */
+
+/* The names of the functions have been changed from regcomp and
+ * regexec to pregcomp and pregexec in order to avoid conflicts
+ * with the POSIX routines of the same names.
+*/
+
+#ifdef PERL_EXT_RE_BUILD
+/* need to replace pregcomp et al, so enable that */
+# ifndef PERL_IN_XSUB_RE
+# define PERL_IN_XSUB_RE
+# endif
+/* need access to debugger hooks */
+# ifndef DEBUGGING
+# define DEBUGGING
+# endif
+#endif
+
+#ifdef PERL_IN_XSUB_RE
+/* We *really* need to overwrite these symbols: */
+# define Perl_regexec_flags my_regexec
+# define Perl_regdump my_regdump
+# define Perl_regprop my_regprop
+/* *These* symbols are masked to allow static link. */
+# define Perl_pregexec my_pregexec
+#endif
+
+/*SUPPRESS 112*/
+/*
+ * pregcomp and pregexec -- regsub and regerror are not used in perl
+ *
+ * Copyright (c) 1986 by University of Toronto.
+ * Written by Henry Spencer. Not derived from licensed software.
+ *
+ * Permission is granted to anyone to use this software for any
+ * purpose on any computer system, and to redistribute it freely,
+ * subject to the following restrictions:
+ *
+ * 1. The author is not responsible for the consequences of use of
+ * this software, no matter how awful, even if they arise
+ * from defects in it.
+ *
+ * 2. The origin of this software must not be misrepresented, either
+ * by explicit claim or by omission.
+ *
+ * 3. Altered versions must be plainly marked as such, and must not
+ * be misrepresented as being the original software.
+ *
+ **** Alterations to Henry's code are...
+ ****
+ **** Copyright (c) 1991-1997, Larry Wall
+ ****
+ **** You may distribute under the terms of either the GNU General Public
+ **** License or the Artistic License, as specified in the README file.
+ *
+ * Beware that some of this code is subtly aware of the way operator
+ * precedence is structured in regular expressions. Serious changes in
+ * regular-expression syntax might require a total rethink.
+ */
+#include "EXTERN.h"
+#include "perl.h"
+#include "regcomp.h"
+
+#define RF_tainted 1 /* tainted information used? */
+#define RF_warned 2 /* warned about big count? */
+#define RF_evaled 4 /* Did an EVAL with setting? */
+
+#define RS_init 1 /* eval environment created */
+#define RS_set 2 /* replsv value is set */
+
+#ifndef STATIC
+#define STATIC static
+#endif
+
+#ifndef PERL_OBJECT
+typedef I32 CHECKPOINT;
+
+/*
+ * Forwards.
+ */
+
+static I32 regmatch _((regnode *prog));
+static I32 regrepeat _((regnode *p, I32 max));
+static I32 regrepeat_hard _((regnode *p, I32 max, I32 *lp));
+static I32 regtry _((regexp *prog, char *startpos));
+
+static bool reginclass _((char *p, I32 c));
+static CHECKPOINT regcppush _((I32 parenfloor));
+static char * regcppop _((void));
+#endif
+#define REGINCLASS(p,c) (*(p) ? reginclass(p,c) : ANYOF_TEST(p,c))
+
+STATIC CHECKPOINT
+regcppush(I32 parenfloor)
+{
+ dTHR;
+ int retval = PL_savestack_ix;
+ int i = (PL_regsize - parenfloor) * 4;
+ int p;
+
+ SSCHECK(i + 5);
+ for (p = PL_regsize; p > parenfloor; p--) {
+ SSPUSHPTR(PL_regendp[p]);
+ SSPUSHPTR(PL_regstartp[p]);
+ SSPUSHPTR(PL_reg_start_tmp[p]);
+ SSPUSHINT(p);
+ }
+ SSPUSHINT(PL_regsize);
+ SSPUSHINT(*PL_reglastparen);
+ SSPUSHPTR(PL_reginput);
+ SSPUSHINT(i + 3);
+ SSPUSHINT(SAVEt_REGCONTEXT);
+ return retval;
+}
+
+/* These are needed since we do not localize EVAL nodes: */
+# define REGCP_SET DEBUG_r(PerlIO_printf(Perl_debug_log, \
+ " Setting an EVAL scope, savestack=%i\n", \
+ PL_savestack_ix)); lastcp = PL_savestack_ix
+
+# define REGCP_UNWIND DEBUG_r(lastcp != PL_savestack_ix ? \
+ PerlIO_printf(Perl_debug_log, \
+ " Clearing an EVAL scope, savestack=%i..%i\n", \
+ lastcp, PL_savestack_ix) : 0); regcpblow(lastcp)
+
+STATIC char *
+regcppop(void)
+{
+ dTHR;
+ I32 i = SSPOPINT;
+ U32 paren = 0;
+ char *input;
+ char *tmps;
+ assert(i == SAVEt_REGCONTEXT);
+ i = SSPOPINT;
+ input = (char *) SSPOPPTR;
+ *PL_reglastparen = SSPOPINT;
+ PL_regsize = SSPOPINT;
+ for (i -= 3; i > 0; i -= 4) {
+ paren = (U32)SSPOPINT;
+ PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
+ PL_regstartp[paren] = (char *) SSPOPPTR;
+ tmps = (char*)SSPOPPTR;
+ if (paren <= *PL_reglastparen)
+ PL_regendp[paren] = tmps;
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ " restoring \\%d to %d(%d)..%d%s\n",
+ paren, PL_regstartp[paren] - PL_regbol,
+ PL_reg_start_tmp[paren] - PL_regbol,
+ PL_regendp[paren] - PL_regbol,
+ (paren > *PL_reglastparen ? "(no)" : ""));
+ );
+ }
+ DEBUG_r(
+ if (*PL_reglastparen + 1 <= PL_regnpar) {
+ PerlIO_printf(Perl_debug_log,
+ " restoring \\%d..\\%d to undef\n",
+ *PL_reglastparen + 1, PL_regnpar);
+ }
+ );
+ for (paren = *PL_reglastparen + 1; paren <= PL_regnpar; paren++) {
+ if (paren > PL_regsize)
+ PL_regstartp[paren] = Nullch;
+ PL_regendp[paren] = Nullch;
+ }
+ return input;
+}
+
+#define regcpblow(cp) LEAVE_SCOPE(cp)
+
+/*
+ * pregexec and friends
+ */
+
+/*
+ - pregexec - match a regexp against a string
+ */
+I32
+pregexec(register regexp *prog, char *stringarg, register char *strend,
+ char *strbeg, I32 minend, SV *screamer, U32 nosave)
+/* strend: pointer to null at end of string */
+/* strbeg: real beginning of string */
+/* minend: end of match must be >=minend after stringarg. */
+/* nosave: For optimizations. */
+{
+ return
+ regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
+ nosave ? 0 : REXEC_COPY_STR);
+}
+
+/*
+ - regexec_flags - match a regexp against a string
+ */
+I32
+regexec_flags(register regexp *prog, char *stringarg, register char *strend,
+ char *strbeg, I32 minend, SV *screamer, void *data, U32 flags)
+/* strend: pointer to null at end of string */
+/* strbeg: real beginning of string */
+/* minend: end of match must be >=minend after stringarg. */
+/* data: May be used for some additional optimizations. */
+/* nosave: For optimizations. */
+{
+ dTHR;
+ register char *s;
+ register regnode *c;
+ register char *startpos = stringarg;
+ register I32 tmp;
+ I32 minlen; /* must match at least this many chars */
+ I32 dontbother = 0; /* how many characters not to try at end */
+ CURCUR cc;
+ I32 start_shift = 0; /* Offset of the start to find
+ constant substr. */
+ I32 end_shift = 0; /* Same for the end. */
+ I32 scream_pos = -1; /* Internal iterator of scream. */
+ char *scream_olds;
+ SV* oreplsv = GvSV(PL_replgv);
+
+ cc.cur = 0;
+ cc.oldcc = 0;
+ PL_regcc = &cc;
+
+ PL_regprecomp = prog->precomp; /* Needed for error messages. */
+#ifdef DEBUGGING
+ PL_regnarrate = PL_debug & 512;
+ PL_regprogram = prog->program;
+#endif
+
+ /* Be paranoid... */
+ if (prog == NULL || startpos == NULL) {
+ croak("NULL regexp parameter");
+ return 0;
+ }
+
+ minlen = prog->minlen;
+ if (strend - startpos < minlen) goto phooey;
+
+ if (startpos == strbeg) /* is ^ valid at stringarg? */
+ PL_regprev = '\n';
+ else {
+ PL_regprev = stringarg[-1];
+ if (!PL_multiline && PL_regprev == '\n')
+ PL_regprev = '\0'; /* force ^ to NOT match */
+ }
+
+ /* Check validity of program. */
+ if (UCHARAT(prog->program) != MAGIC) {
+ FAIL("corrupted regexp program");
+ }
+
+ PL_regnpar = prog->nparens;
+ PL_reg_flags = 0;
+ PL_reg_eval_set = 0;
+
+ /* If there is a "must appear" string, look for it. */
+ s = startpos;
+ if (!(flags & REXEC_CHECKED)
+ && prog->check_substr != Nullsv &&
+ !(prog->reganch & ROPT_ANCH_GPOS) &&
+ (!(prog->reganch & (ROPT_ANCH_BOL | ROPT_ANCH_MBOL))
+ || (PL_multiline && prog->check_substr == prog->anchored_substr)) )
+ {
+ start_shift = prog->check_offset_min;
+ /* Should be nonnegative! */
+ end_shift = minlen - start_shift - SvCUR(prog->check_substr);
+ if (screamer) {
+ if (PL_screamfirst[BmRARE(prog->check_substr)] >= 0)
+ s = screaminstr(screamer, prog->check_substr,
+ start_shift + (stringarg - strbeg),
+ end_shift, &scream_pos, 0);
+ else
+ s = Nullch;
+ scream_olds = s;
+ }
+ else
+ s = fbm_instr((unsigned char*)s + start_shift,
+ (unsigned char*)strend - end_shift,
+ prog->check_substr, 0);
+ if (!s) {
+ ++BmUSEFUL(prog->check_substr); /* hooray */
+ goto phooey; /* not present */
+ } else if ((s - stringarg) > prog->check_offset_max) {
+ ++BmUSEFUL(prog->check_substr); /* hooray/2 */
+ s -= prog->check_offset_max;
+ } else if (!prog->naughty
+ && --BmUSEFUL(prog->check_substr) < 0
+ && prog->check_substr == prog->float_substr) { /* boo */
+ SvREFCNT_dec(prog->check_substr);
+ prog->check_substr = Nullsv; /* disable */
+ prog->float_substr = Nullsv; /* clear */
+ s = startpos;
+ } else s = startpos;
+ }
+
+ /* Mark beginning of line for ^ and lookbehind. */
+ PL_regbol = startpos;
+ PL_bostr = strbeg;
+
+ /* Mark end of line for $ (and such) */
+ PL_regeol = strend;
+
+ /* see how far we have to get to not match where we matched before */
+ PL_regtill = startpos+minend;
+
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "Matching `%.60s%s' against `%.*s%s'\n",
+ prog->precomp,
+ (strlen(prog->precomp) > 60 ? "..." : ""),
+ (strend - startpos > 60 ? 60 : strend - startpos),
+ startpos,
+ (strend - startpos > 60 ? "..." : ""))
+ );
+
+ /* Simplest case: anchored match need be tried only once. */
+ /* [unless only anchor is BOL and multiline is set] */
+ if (prog->reganch & ROPT_ANCH) {
+ if (regtry(prog, startpos))
+ goto got_it;
+ else if (!(prog->reganch & ROPT_ANCH_GPOS) &&
+ (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
+ || (prog->reganch & ROPT_ANCH_MBOL)))
+ {
+ if (minlen)
+ dontbother = minlen - 1;
+ strend -= dontbother;
+ /* for multiline we only have to try after newlines */
+ if (s > startpos)
+ s--;
+ while (s < strend) {
+ if (*s++ == '\n') {
+ if (s < strend && regtry(prog, s))
+ goto got_it;
+ }
+ }
+ }
+ goto phooey;
+ }
+
+ /* Messy cases: unanchored match. */
+ if (prog->anchored_substr && prog->reganch & ROPT_SKIP) {
+ /* we have /x+whatever/ */
+ /* it must be a one character string */
+ char ch = SvPVX(prog->anchored_substr)[0];
+ while (s < strend) {
+ if (*s == ch) {
+ if (regtry(prog, s)) goto got_it;
+ s++;
+ while (s < strend && *s == ch)
+ s++;
+ }
+ s++;
+ }
+ }
+ /*SUPPRESS 560*/
+ else if (prog->anchored_substr != Nullsv
+ || (prog->float_substr != Nullsv
+ && prog->float_max_offset < strend - s)) {
+ SV *must = prog->anchored_substr
+ ? prog->anchored_substr : prog->float_substr;
+ I32 back_max =
+ prog->anchored_substr ? prog->anchored_offset : prog->float_max_offset;
+ I32 back_min =
+ prog->anchored_substr ? prog->anchored_offset : prog->float_min_offset;
+ I32 delta = back_max - back_min;
+ char *last = strend - SvCUR(must) - back_min; /* Cannot start after this */
+ char *last1 = s - 1; /* Last position checked before */
+
+ /* XXXX check_substr already used to find `s', can optimize if
+ check_substr==must. */
+ scream_pos = -1;
+ dontbother = end_shift;
+ strend -= dontbother;
+ while ( (s <= last) &&
+ (screamer
+ ? (s = screaminstr(screamer, must, s + back_min - strbeg,
+ end_shift, &scream_pos, 0))
+ : (s = fbm_instr((unsigned char*)s + back_min,
+ (unsigned char*)strend, must, 0))) ) {
+ if (s - back_max > last1) {
+ last1 = s - back_min;
+ s = s - back_max;
+ } else {
+ char *t = last1 + 1;
+
+ last1 = s - back_min;
+ s = t;
+ }
+ while (s <= last1) {
+ if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ }
+ goto phooey;
+ } else if (c = prog->regstclass) {
+ I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
+ char *Class;
+
+ if (minlen)
+ dontbother = minlen - 1;
+ strend -= dontbother; /* don't bother with what can't match */
+ tmp = 1;
+ /* We know what class it must start with. */
+ switch (OP(c)) {
+ case ANYOF:
+ Class = (char *) OPERAND(c);
+ while (s < strend) {
+ if (REGINCLASS(Class, *s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case BOUNDL:
+ PL_reg_flags |= RF_tainted;
+ /* FALL THROUGH */
+ case BOUND:
+ if (minlen)
+ dontbother++,strend--;
+ tmp = (s != startpos) ? UCHARAT(s - 1) : PL_regprev;
+ tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
+ while (s < strend) {
+ if (tmp == !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
+ tmp = !tmp;
+ if (regtry(prog, s))
+ goto got_it;
+ }
+ s++;
+ }
+ if ((minlen || tmp) && regtry(prog,s))
+ goto got_it;
+ break;
+ case NBOUNDL:
+ PL_reg_flags |= RF_tainted;
+ /* FALL THROUGH */
+ case NBOUND:
+ if (minlen)
+ dontbother++,strend--;
+ tmp = (s != startpos) ? UCHARAT(s - 1) : PL_regprev;
+ tmp = ((OP(c) == NBOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
+ while (s < strend) {
+ if (tmp == !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
+ tmp = !tmp;
+ else if (regtry(prog, s))
+ goto got_it;
+ s++;
+ }
+ if ((minlen || !tmp) && regtry(prog,s))
+ goto got_it;
+ break;
+ case ALNUM:
+ while (s < strend) {
+ if (isALNUM(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case ALNUML:
+ PL_reg_flags |= RF_tainted;
+ while (s < strend) {
+ if (isALNUM_LC(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case NALNUM:
+ while (s < strend) {
+ if (!isALNUM(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case NALNUML:
+ PL_reg_flags |= RF_tainted;
+ while (s < strend) {
+ if (!isALNUM_LC(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case SPACE:
+ while (s < strend) {
+ if (isSPACE(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case SPACEL:
+ PL_reg_flags |= RF_tainted;
+ while (s < strend) {
+ if (isSPACE_LC(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case NSPACE:
+ while (s < strend) {
+ if (!isSPACE(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case NSPACEL:
+ PL_reg_flags |= RF_tainted;
+ while (s < strend) {
+ if (!isSPACE_LC(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case DIGIT:
+ while (s < strend) {
+ if (isDIGIT(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case NDIGIT:
+ while (s < strend) {
+ if (!isDIGIT(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ }
+ }
+ else {
+ dontbother = 0;
+ if (prog->float_substr != Nullsv) { /* Trim the end. */
+ char *last;
+ I32 oldpos = scream_pos;
+
+ if (screamer) {
+ last = screaminstr(screamer, prog->float_substr, s - strbeg,
+ end_shift, &scream_pos, 1); /* last one */
+ if (!last) {
+ last = scream_olds; /* Only one occurence. */
+ }
+ } else {
+ STRLEN len;
+ char *little = SvPV(prog->float_substr, len);
+ if (len)
+ last = rninstr(s, strend, little, little + len);
+ else
+ last = strend; /* matching `$' */
+ }
+ if (last == NULL) goto phooey; /* Should not happen! */
+ dontbother = strend - last + prog->float_min_offset;
+ }
+ if (minlen && (dontbother < minlen))
+ dontbother = minlen - 1;
+ strend -= dontbother;
+ /* We don't know much -- general case. */
+ do {
+ if (regtry(prog, s))
+ goto got_it;
+ } while (s++ < strend);
+ }
+
+ /* Failure. */
+ goto phooey;
+
+got_it:
+ prog->subbeg = strbeg;
+ prog->subend = PL_regeol; /* strend may have been modified */
+ RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
+
+ /* make sure $`, $&, $', and $digit will work later */
+ if (strbeg != prog->subbase) { /* second+ //g match. */
+ if (!(flags & REXEC_COPY_STR)) {
+ if (prog->subbase) {
+ Safefree(prog->subbase);
+ prog->subbase = Nullch;
+ }
+ }
+ else {
+ I32 i = PL_regeol - startpos + (stringarg - strbeg);
+ s = savepvn(strbeg, i);
+ Safefree(prog->subbase);
+ prog->subbase = s;
+ prog->subbeg = prog->subbase;
+ prog->subend = prog->subbase + i;
+ s = prog->subbase + (stringarg - strbeg);
+ for (i = 0; i <= prog->nparens; i++) {
+ if (prog->endp[i]) {
+ prog->startp[i] = s + (prog->startp[i] - startpos);
+ prog->endp[i] = s + (prog->endp[i] - startpos);
+ }
+ }
+ }
+ }
+ /* Preserve the current value of $^R */
+ if (oreplsv != GvSV(PL_replgv)) {
+ sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
+ restored, the value remains
+ the same. */
+ }
+ return 1;
+
+phooey:
+ return 0;
+}
+
+/*
+ - regtry - try match at specific point
+ */
+STATIC I32 /* 0 failure, 1 success */
+regtry(regexp *prog, char *startpos)
+{
+ dTHR;
+ register I32 i;
+ register char **sp;
+ register char **ep;
+ CHECKPOINT lastcp;
+
+ if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
+ PL_reg_eval_set = RS_init;
+ DEBUG_r(DEBUG_s(
+ PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %i\n",
+ PL_stack_sp - PL_stack_base);
+ ));
+ SAVEINT(cxstack[cxstack_ix].blk_oldsp);
+ cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
+ /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
+ SAVETMPS;
+ /* Apparently this is not needed, judging by wantarray. */
+ /* SAVEINT(cxstack[cxstack_ix].blk_gimme);
+ cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
+ }
+ PL_reginput = startpos;
+ PL_regstartp = prog->startp;
+ PL_regendp = prog->endp;
+ PL_reglastparen = &prog->lastparen;
+ prog->lastparen = 0;
+ PL_regsize = 0;
+ if (PL_reg_start_tmpl <= prog->nparens) {
+ PL_reg_start_tmpl = prog->nparens*3/2 + 3;
+ if(PL_reg_start_tmp)
+ Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
+ else
+ New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*);
+ }
+
+ sp = prog->startp;
+ ep = prog->endp;
+ PL_regdata = prog->data;
+ if (prog->nparens) {
+ for (i = prog->nparens; i >= 0; i--) {
+ *sp++ = NULL;
+ *ep++ = NULL;
+ }
+ }
+ REGCP_SET;
+ if (regmatch(prog->program + 1)) {
+ prog->startp[0] = startpos;
+ prog->endp[0] = PL_reginput;
+ return 1;
+ }
+ REGCP_UNWIND;
+ return 0;
+}
+
+/*
+ - regmatch - main matching routine
+ *
+ * Conceptually the strategy is simple: check to see whether the current
+ * node matches, call self recursively to see whether the rest matches,
+ * and then act accordingly. In practice we make some effort to avoid
+ * recursion, in particular by going through "ordinary" nodes (that don't
+ * need to know whether the rest of the match failed) by a loop instead of
+ * by recursion.
+ */
+/* [lwall] I've hoisted the register declarations to the outer block in order to
+ * maybe save a little bit of pushing and popping on the stack. It also takes
+ * advantage of machines that use a register save mask on subroutine entry.
+ */
+STATIC I32 /* 0 failure, 1 success */
+regmatch(regnode *prog)
+{
+ dTHR;
+ register regnode *scan; /* Current node. */
+ regnode *next; /* Next node. */
+ regnode *inner; /* Next node in internal branch. */
+ register I32 nextchr; /* renamed nextchr - nextchar colides with
+ function of same name */
+ register I32 n; /* no or next */
+ register I32 ln; /* len or last */
+ register char *s; /* operand or save */
+ register char *locinput = PL_reginput;
+ register I32 c1, c2, paren; /* case fold search, parenth */
+ int minmod = 0, sw = 0, logical = 0;
+#ifdef DEBUGGING
+ PL_regindent++;
+#endif
+
+ nextchr = UCHARAT(locinput);
+ scan = prog;
+ while (scan != NULL) {
+#define sayNO_L (logical ? (logical = 0, sw = 0, goto cont) : sayNO)
+#ifdef DEBUGGING
+# define sayYES goto yes
+# define sayNO goto no
+# define saySAME(x) if (x) goto yes; else goto no
+# define REPORT_CODE_OFF 24
+#else
+# define sayYES return 1
+# define sayNO return 0
+# define saySAME(x) return x
+#endif
+ DEBUG_r( {
+ SV *prop = sv_newmortal();
+ int docolor = *PL_colors[0];
+ int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
+ int l = (PL_regeol - locinput > taill ? taill : PL_regeol - locinput);
+ int pref_len = (locinput - PL_bostr > (5 + taill) - l
+ ? (5 + taill) - l : locinput - PL_bostr);
+
+ if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
+ l = ( PL_regeol - locinput > (5 + taill) - pref_len
+ ? (5 + taill) - pref_len : PL_regeol - locinput);
+ regprop(prop, scan);
+ PerlIO_printf(Perl_debug_log,
+ "%4i <%s%.*s%s%s%s%.*s%s>%*s|%3d:%*s%s\n",
+ locinput - PL_bostr,
+ PL_colors[2], pref_len, locinput - pref_len, PL_colors[3],
+ (docolor ? "" : "> <"),
+ PL_colors[0], l, locinput, PL_colors[1],
+ 15 - l - pref_len + 1,
+ "",
+ scan - PL_regprogram, PL_regindent*2, "",
+ SvPVX(prop));
+ } );
+
+ next = scan + NEXT_OFF(scan);
+ if (next == scan)
+ next = NULL;
+
+ switch (OP(scan)) {
+ case BOL:
+ if (locinput == PL_bostr
+ ? PL_regprev == '\n'
+ : (PL_multiline &&
+ (nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
+ {
+ /* PL_regtill = PL_regbol; */
+ break;
+ }
+ sayNO;
+ case MBOL:
+ if (locinput == PL_bostr
+ ? PL_regprev == '\n'
+ : ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
+ {
+ break;
+ }
+ sayNO;
+ case SBOL:
+ if (locinput == PL_regbol && PL_regprev == '\n')
+ break;
+ sayNO;
+ case GPOS:
+ if (locinput == PL_regbol)
+ break;
+ sayNO;
+ case EOL:
+ if (PL_multiline)
+ goto meol;
+ else
+ goto seol;
+ case MEOL:
+ meol:
+ if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
+ sayNO;
+ break;
+ case SEOL:
+ seol:
+ if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
+ sayNO;
+ if (PL_regeol - locinput > 1)
+ sayNO;
+ break;
+ case EOS:
+ if (PL_regeol != locinput)
+ sayNO;
+ break;
+ case SANY:
+ if (!nextchr && locinput >= PL_regeol)
+ sayNO;
+ nextchr = UCHARAT(++locinput);
+ break;
+ case ANY:
+ if (!nextchr && locinput >= PL_regeol || nextchr == '\n')
+ sayNO;
+ nextchr = UCHARAT(++locinput);
+ break;
+ case EXACT:
+ s = (char *) OPERAND(scan);
+ ln = UCHARAT(s++);
+ /* Inline the first character, for speed. */
+ if (UCHARAT(s) != nextchr)
+ sayNO;
+ if (PL_regeol - locinput < ln)
+ sayNO;
+ if (ln > 1 && memNE(s, locinput, ln))
+ sayNO;
+ locinput += ln;
+ nextchr = UCHARAT(locinput);
+ break;
+ case EXACTFL:
+ PL_reg_flags |= RF_tainted;
+ /* FALL THROUGH */
+ case EXACTF:
+ s = (char *) OPERAND(scan);
+ ln = UCHARAT(s++);
+ /* Inline the first character, for speed. */
+ if (UCHARAT(s) != nextchr &&
+ UCHARAT(s) != ((OP(scan) == EXACTF)
+ ? fold : fold_locale)[nextchr])
+ sayNO;
+ if (PL_regeol - locinput < ln)
+ sayNO;
+ if (ln > 1 && (OP(scan) == EXACTF
+ ? ibcmp(s, locinput, ln)
+ : ibcmp_locale(s, locinput, ln)))
+ sayNO;
+ locinput += ln;
+ nextchr = UCHARAT(locinput);
+ break;
+ case ANYOF:
+ s = (char *) OPERAND(scan);
+ if (nextchr < 0)
+ nextchr = UCHARAT(locinput);
+ if (!REGINCLASS(s, nextchr))
+ sayNO;
+ if (!nextchr && locinput >= PL_regeol)
+ sayNO;
+ nextchr = UCHARAT(++locinput);
+ break;
+ case ALNUML:
+ PL_reg_flags |= RF_tainted;
+ /* FALL THROUGH */
+ case ALNUM:
+ if (!nextchr)
+ sayNO;
+ if (!(OP(scan) == ALNUM
+ ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
+ sayNO;
+ nextchr = UCHARAT(++locinput);
+ break;
+ case NALNUML:
+ PL_reg_flags |= RF_tainted;
+ /* FALL THROUGH */
+ case NALNUM:
+ if (!nextchr && locinput >= PL_regeol)
+ sayNO;
+ if (OP(scan) == NALNUM
+ ? isALNUM(nextchr) : isALNUM_LC(nextchr))
+ sayNO;
+ nextchr = UCHARAT(++locinput);
+ break;
+ case BOUNDL:
+ case NBOUNDL:
+ PL_reg_flags |= RF_tainted;
+ /* FALL THROUGH */
+ case BOUND:
+ case NBOUND:
+ /* was last char in word? */
+ ln = (locinput != PL_regbol) ? UCHARAT(locinput - 1) : PL_regprev;
+ if (OP(scan) == BOUND || OP(scan) == NBOUND) {
+ ln = isALNUM(ln);
+ n = isALNUM(nextchr);
+ }
+ else {
+ ln = isALNUM_LC(ln);
+ n = isALNUM_LC(nextchr);
+ }
+ if (((!ln) == (!n)) == (OP(scan) == BOUND || OP(scan) == BOUNDL))
+ sayNO;
+ break;
+ case SPACEL:
+ PL_reg_flags |= RF_tainted;
+ /* FALL THROUGH */
+ case SPACE:
+ if (!nextchr && locinput >= PL_regeol)
+ sayNO;
+ if (!(OP(scan) == SPACE
+ ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
+ sayNO;
+ nextchr = UCHARAT(++locinput);
+ break;
+ case NSPACEL:
+ PL_reg_flags |= RF_tainted;
+ /* FALL THROUGH */
+ case NSPACE:
+ if (!nextchr)
+ sayNO;
+ if (OP(scan) == SPACE
+ ? isSPACE(nextchr) : isSPACE_LC(nextchr))
+ sayNO;
+ nextchr = UCHARAT(++locinput);
+ break;
+ case DIGIT:
+ if (!isDIGIT(nextchr))
+ sayNO;
+ nextchr = UCHARAT(++locinput);
+ break;
+ case NDIGIT:
+ if (!nextchr && locinput >= PL_regeol)
+ sayNO;
+ if (isDIGIT(nextchr))
+ sayNO;
+ nextchr = UCHARAT(++locinput);
+ break;
+ case REFFL:
+ PL_reg_flags |= RF_tainted;
+ /* FALL THROUGH */
+ case REF:
+ case REFF:
+ n = ARG(scan); /* which paren pair */
+ s = PL_regstartp[n];
+ if (*PL_reglastparen < n || !s)
+ sayNO; /* Do not match unless seen CLOSEn. */
+ if (s == PL_regendp[n])
+ break;
+ /* Inline the first character, for speed. */
+ if (UCHARAT(s) != nextchr &&
+ (OP(scan) == REF ||
+ (UCHARAT(s) != ((OP(scan) == REFF
+ ? fold : fold_locale)[nextchr]))))
+ sayNO;
+ ln = PL_regendp[n] - s;
+ if (locinput + ln > PL_regeol)
+ sayNO;
+ if (ln > 1 && (OP(scan) == REF
+ ? memNE(s, locinput, ln)
+ : (OP(scan) == REFF
+ ? ibcmp(s, locinput, ln)
+ : ibcmp_locale(s, locinput, ln))))
+ sayNO;
+ locinput += ln;
+ nextchr = UCHARAT(locinput);
+ break;
+
+ case NOTHING:
+ case TAIL:
+ break;
+ case BACK:
+ break;
+ case EVAL:
+ {
+ dSP;
+ OP_4tree *oop = PL_op;
+ COP *ocurcop = PL_curcop;
+ SV **ocurpad = PL_curpad;
+ SV *ret;
+
+ n = ARG(scan);
+ PL_op = (OP_4tree*)PL_regdata->data[n];
+ DEBUG_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%x\n", PL_op) );
+ PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 1]);
+
+ CALLRUNOPS(); /* Scalar context. */
+ SPAGAIN;
+ ret = POPs;
+ PUTBACK;
+
+ if (logical) {
+ logical = 0;
+ sw = SvTRUE(ret);
+ } else
+ sv_setsv(save_scalar(PL_replgv), ret);
+ PL_op = oop;
+ PL_curpad = ocurpad;
+ PL_curcop = ocurcop;
+ break;
+ }
+ case OPEN:
+ n = ARG(scan); /* which paren pair */
+ PL_reg_start_tmp[n] = locinput;
+ if (n > PL_regsize)
+ PL_regsize = n;
+ break;
+ case CLOSE:
+ n = ARG(scan); /* which paren pair */
+ PL_regstartp[n] = PL_reg_start_tmp[n];
+ PL_regendp[n] = locinput;
+ if (n > *PL_reglastparen)
+ *PL_reglastparen = n;
+ break;
+ case GROUPP:
+ n = ARG(scan); /* which paren pair */
+ sw = (*PL_reglastparen >= n && PL_regendp[n] != NULL);
+ break;
+ case IFTHEN:
+ if (sw)
+ next = NEXTOPER(NEXTOPER(scan));
+ else {
+ next = scan + ARG(scan);
+ if (OP(next) == IFTHEN) /* Fake one. */
+ next = NEXTOPER(NEXTOPER(next));
+ }
+ break;
+ case LOGICAL:
+ logical = 1;
+ break;
+ case CURLYX: {
+ CURCUR cc;
+ CHECKPOINT cp = PL_savestack_ix;
+
+ if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
+ next += ARG(next);
+ cc.oldcc = PL_regcc;
+ PL_regcc = &cc;
+ cc.parenfloor = *PL_reglastparen;
+ cc.cur = -1;
+ cc.min = ARG1(scan);
+ cc.max = ARG2(scan);
+ cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
+ cc.next = next;
+ cc.minmod = minmod;
+ cc.lastloc = 0;
+ PL_reginput = locinput;
+ n = regmatch(PREVOPER(next)); /* start on the WHILEM */
+ regcpblow(cp);
+ PL_regcc = cc.oldcc;
+ saySAME(n);
+ }
+ /* NOT REACHED */
+ case WHILEM: {
+ /*
+ * This is really hard to understand, because after we match
+ * what we're trying to match, we must make sure the rest of
+ * the RE is going to match for sure, and to do that we have
+ * to go back UP the parse tree by recursing ever deeper. And
+ * if it fails, we have to reset our parent's current state
+ * that we can try again after backing off.
+ */
+
+ CHECKPOINT cp, lastcp;
+ CURCUR* cc = PL_regcc;
+ char *lastloc = cc->lastloc; /* Detection of 0-len. */
+
+ n = cc->cur + 1; /* how many we know we matched */
+ PL_reginput = locinput;
+
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s %ld out of %ld..%ld cc=%lx\n",
+ REPORT_CODE_OFF+PL_regindent*2, "",
+ (long)n, (long)cc->min,
+ (long)cc->max, (long)cc)
+ );
+
+ /* If degenerate scan matches "", assume scan done. */
+
+ if (locinput == cc->lastloc && n >= cc->min) {
+ PL_regcc = cc->oldcc;
+ ln = PL_regcc->cur;
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s empty match detected, try continuation...\n",
+ REPORT_CODE_OFF+PL_regindent*2, "")
+ );
+ if (regmatch(cc->next))
+ sayYES;
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s failed...\n",
+ REPORT_CODE_OFF+PL_regindent*2, "")
+ );
+ PL_regcc->cur = ln;
+ PL_regcc = cc;
+ sayNO;
+ }
+
+ /* First just match a string of min scans. */
+
+ if (n < cc->min) {
+ cc->cur = n;
+ cc->lastloc = locinput;
+ if (regmatch(cc->scan))
+ sayYES;
+ cc->cur = n - 1;
+ cc->lastloc = lastloc;
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s failed...\n",
+ REPORT_CODE_OFF+PL_regindent*2, "")
+ );
+ sayNO;
+ }
+
+ /* Prefer next over scan for minimal matching. */
+
+ if (cc->minmod) {
+ PL_regcc = cc->oldcc;
+ ln = PL_regcc->cur;
+ cp = regcppush(cc->parenfloor);
+ REGCP_SET;
+ if (regmatch(cc->next)) {
+ regcpblow(cp);
+ sayYES; /* All done. */
+ }
+ REGCP_UNWIND;
+ regcppop();
+ PL_regcc->cur = ln;
+ PL_regcc = cc;
+
+ if (n >= cc->max) { /* Maximum greed exceeded? */
+ if (PL_dowarn && n >= REG_INFTY
+ && !(PL_reg_flags & RF_warned)) {
+ PL_reg_flags |= RF_warned;
+ warn("%s limit (%d) exceeded",
+ "Complex regular subexpression recursion",
+ REG_INFTY - 1);
+ }
+ sayNO;
+ }
+
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s trying longer...\n",
+ REPORT_CODE_OFF+PL_regindent*2, "")
+ );
+ /* Try scanning more and see if it helps. */
+ PL_reginput = locinput;
+ cc->cur = n;
+ cc->lastloc = locinput;
+ cp = regcppush(cc->parenfloor);
+ REGCP_SET;
+ if (regmatch(cc->scan)) {
+ regcpblow(cp);
+ sayYES;
+ }
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s failed...\n",
+ REPORT_CODE_OFF+PL_regindent*2, "")
+ );
+ REGCP_UNWIND;
+ regcppop();
+ cc->cur = n - 1;
+ cc->lastloc = lastloc;
+ sayNO;
+ }
+
+ /* Prefer scan over next for maximal matching. */
+
+ if (n < cc->max) { /* More greed allowed? */
+ cp = regcppush(cc->parenfloor);
+ cc->cur = n;
+ cc->lastloc = locinput;
+ REGCP_SET;
+ if (regmatch(cc->scan)) {
+ regcpblow(cp);
+ sayYES;
+ }
+ REGCP_UNWIND;
+ regcppop(); /* Restore some previous $<digit>s? */
+ PL_reginput = locinput;
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s failed, try continuation...\n",
+ REPORT_CODE_OFF+PL_regindent*2, "")
+ );
+ }
+ if (PL_dowarn && n >= REG_INFTY && !(PL_reg_flags & RF_warned)) {
+ PL_reg_flags |= RF_warned;
+ warn("%s limit (%d) exceeded",
+ "Complex regular subexpression recursion",
+ REG_INFTY - 1);
+ }
+
+ /* Failed deeper matches of scan, so see if this one works. */
+ PL_regcc = cc->oldcc;
+ ln = PL_regcc->cur;
+ if (regmatch(cc->next))
+ sayYES;
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log, "%*s failed...\n",
+ REPORT_CODE_OFF+PL_regindent*2, "")
+ );
+ PL_regcc->cur = ln;
+ PL_regcc = cc;
+ cc->cur = n - 1;
+ cc->lastloc = lastloc;
+ sayNO;
+ }
+ /* NOT REACHED */
+ case BRANCHJ:
+ next = scan + ARG(scan);
+ if (next == scan)
+ next = NULL;
+ inner = NEXTOPER(NEXTOPER(scan));
+ goto do_branch;
+ case BRANCH:
+ inner = NEXTOPER(scan);
+ do_branch:
+ {
+ CHECKPOINT lastcp;
+ c1 = OP(scan);
+ if (OP(next) != c1) /* No choice. */
+ next = inner; /* Avoid recursion. */
+ else {
+ int lastparen = *PL_reglastparen;
+
+ REGCP_SET;
+ do {
+ PL_reginput = locinput;
+ if (regmatch(inner))
+ sayYES;
+ REGCP_UNWIND;
+ for (n = *PL_reglastparen; n > lastparen; n--)
+ PL_regendp[n] = 0;
+ *PL_reglastparen = n;
+ scan = next;
+ /*SUPPRESS 560*/
+ if (n = (c1 == BRANCH ? NEXT_OFF(next) : ARG(next)))
+ next += n;
+ else
+ next = NULL;
+ inner = NEXTOPER(scan);
+ if (c1 == BRANCHJ) {
+ inner = NEXTOPER(inner);
+ }
+ } while (scan != NULL && OP(scan) == c1);
+ sayNO;
+ /* NOTREACHED */
+ }
+ }
+ break;
+ case MINMOD:
+ minmod = 1;
+ break;
+ case CURLYM:
+ {
+ I32 l = 0;
+ CHECKPOINT lastcp;
+
+ /* We suppose that the next guy does not need
+ backtracking: in particular, it is of constant length,
+ and has no parenths to influence future backrefs. */
+ ln = ARG1(scan); /* min to match */
+ n = ARG2(scan); /* max to match */
+ paren = scan->flags;
+ if (paren) {
+ if (paren > PL_regsize)
+ PL_regsize = paren;
+ if (paren > *PL_reglastparen)
+ *PL_reglastparen = paren;
+ }
+ scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
+ if (paren)
+ scan += NEXT_OFF(scan); /* Skip former OPEN. */
+ PL_reginput = locinput;
+ if (minmod) {
+ minmod = 0;
+ if (ln && regrepeat_hard(scan, ln, &l) < ln)
+ sayNO;
+ if (ln && l == 0 && n >= ln
+ /* In fact, this is tricky. If paren, then the
+ fact that we did/didnot match may influence
+ future execution. */
+ && !(paren && ln == 0))
+ ln = n;
+ locinput = PL_reginput;
+ if (regkind[(U8)OP(next)] == EXACT) {
+ c1 = UCHARAT(OPERAND(next) + 1);
+ if (OP(next) == EXACTF)
+ c2 = fold[c1];
+ else if (OP(next) == EXACTFL)
+ c2 = fold_locale[c1];
+ else
+ c2 = c1;
+ } else
+ c1 = c2 = -1000;
+ REGCP_SET;
+ /* This may be improved if l == 0. */
+ while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
+ /* If it could work, try it. */
+ if (c1 == -1000 ||
+ UCHARAT(PL_reginput) == c1 ||
+ UCHARAT(PL_reginput) == c2)
+ {
+ if (paren) {
+ if (n) {
+ PL_regstartp[paren] = PL_reginput - l;
+ PL_regendp[paren] = PL_reginput;
+ } else
+ PL_regendp[paren] = NULL;
+ }
+ if (regmatch(next))
+ sayYES;
+ REGCP_UNWIND;
+ }
+ /* Couldn't or didn't -- move forward. */
+ PL_reginput = locinput;
+ if (regrepeat_hard(scan, 1, &l)) {
+ ln++;
+ locinput = PL_reginput;
+ }
+ else
+ sayNO;
+ }
+ } else {
+ n = regrepeat_hard(scan, n, &l);
+ if (n != 0 && l == 0
+ /* In fact, this is tricky. If paren, then the
+ fact that we did/didnot match may influence
+ future execution. */
+ && !(paren && ln == 0))
+ ln = n;
+ locinput = PL_reginput;
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s matched %ld times, len=%ld...\n",
+ REPORT_CODE_OFF+PL_regindent*2, "", n, l)
+ );
+ if (n >= ln) {
+ if (regkind[(U8)OP(next)] == EXACT) {
+ c1 = UCHARAT(OPERAND(next) + 1);
+ if (OP(next) == EXACTF)
+ c2 = fold[c1];
+ else if (OP(next) == EXACTFL)
+ c2 = fold_locale[c1];
+ else
+ c2 = c1;
+ } else
+ c1 = c2 = -1000;
+ }
+ REGCP_SET;
+ while (n >= ln) {
+ /* If it could work, try it. */
+ if (c1 == -1000 ||
+ UCHARAT(PL_reginput) == c1 ||
+ UCHARAT(PL_reginput) == c2)
+ {
+ DEBUG_r(
+ PerlIO_printf(Perl_debug_log,
+ "%*s trying tail with n=%ld...\n",
+ REPORT_CODE_OFF+PL_regindent*2, "", n)
+ );
+ if (paren) {
+ if (n) {
+ PL_regstartp[paren] = PL_reginput - l;
+ PL_regendp[paren] = PL_reginput;
+ } else
+ PL_regendp[paren] = NULL;
+ }
+ if (regmatch(next))
+ sayYES;
+ REGCP_UNWIND;
+ }
+ /* Couldn't or didn't -- back up. */
+ n--;
+ locinput -= l;
+ PL_reginput = locinput;
+ }
+ }
+ sayNO;
+ break;
+ }
+ case CURLYN:
+ paren = scan->flags; /* Which paren to set */
+ if (paren > PL_regsize)
+ PL_regsize = paren;
+ if (paren > *PL_reglastparen)
+ *PL_reglastparen = paren;
+ ln = ARG1(scan); /* min to match */
+ n = ARG2(scan); /* max to match */
+ scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
+ goto repeat;
+ case CURLY:
+ paren = 0;
+ ln = ARG1(scan); /* min to match */
+ n = ARG2(scan); /* max to match */
+ scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
+ goto repeat;
+ case STAR:
+ ln = 0;
+ n = REG_INFTY;
+ scan = NEXTOPER(scan);
+ paren = 0;
+ goto repeat;
+ case PLUS:
+ ln = 1;
+ n = REG_INFTY;
+ scan = NEXTOPER(scan);
+ paren = 0;
+ repeat:
+ /*
+ * Lookahead to avoid useless match attempts
+ * when we know what character comes next.
+ */
+ if (regkind[(U8)OP(next)] == EXACT) {
+ c1 = UCHARAT(OPERAND(next) + 1);
+ if (OP(next) == EXACTF)
+ c2 = fold[c1];
+ else if (OP(next) == EXACTFL)
+ c2 = fold_locale[c1];
+ else
+ c2 = c1;
+ }
+ else
+ c1 = c2 = -1000;
+ PL_reginput = locinput;
+ if (minmod) {
+ CHECKPOINT lastcp;
+ minmod = 0;
+ if (ln && regrepeat(scan, ln) < ln)
+ sayNO;
+ REGCP_SET;
+ while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
+ /* If it could work, try it. */
+ if (c1 == -1000 ||
+ UCHARAT(PL_reginput) == c1 ||
+ UCHARAT(PL_reginput) == c2)
+ {
+ if (paren) {
+ if (n) {
+ PL_regstartp[paren] = PL_reginput - 1;
+ PL_regendp[paren] = PL_reginput;
+ } else
+ PL_regendp[paren] = NULL;
+ }
+ if (regmatch(next))
+ sayYES;
+ REGCP_UNWIND;
+ }
+ /* Couldn't or didn't -- move forward. */
+ PL_reginput = locinput + ln;
+ if (regrepeat(scan, 1)) {
+ ln++;
+ PL_reginput = locinput + ln;
+ } else
+ sayNO;
+ }
+ }
+ else {
+ CHECKPOINT lastcp;
+ n = regrepeat(scan, n);
+ if (ln < n && regkind[(U8)OP(next)] == EOL &&
+ (!PL_multiline || OP(next) == SEOL))
+ ln = n; /* why back off? */
+ REGCP_SET;
+ if (paren) {
+ while (n >= ln) {
+ /* If it could work, try it. */
+ if (c1 == -1000 ||
+ UCHARAT(PL_reginput) == c1 ||
+ UCHARAT(PL_reginput) == c2)
+ {
+ if (paren && n) {
+ if (n) {
+ PL_regstartp[paren] = PL_reginput - 1;
+ PL_regendp[paren] = PL_reginput;
+ } else
+ PL_regendp[paren] = NULL;
+ }
+ if (regmatch(next))
+ sayYES;
+ REGCP_UNWIND;
+ }
+ /* Couldn't or didn't -- back up. */
+ n--;
+ PL_reginput = locinput + n;
+ }
+ } else {
+ while (n >= ln) {
+ /* If it could work, try it. */
+ if (c1 == -1000 ||
+ UCHARAT(PL_reginput) == c1 ||
+ UCHARAT(PL_reginput) == c2)
+ {
+ if (regmatch(next))
+ sayYES;
+ REGCP_UNWIND;
+ }
+ /* Couldn't or didn't -- back up. */
+ n--;
+ PL_reginput = locinput + n;
+ }
+ }
+ }
+ sayNO;
+ break;
+ case END:
+ if (locinput < PL_regtill)
+ sayNO; /* Cannot match: too short. */
+ /* Fall through */
+ case SUCCEED:
+ PL_reginput = locinput; /* put where regtry can find it */
+ sayYES; /* Success! */
+ case SUSPEND:
+ n = 1;
+ goto do_ifmatch;
+ case UNLESSM:
+ n = 0;
+ if (locinput < PL_bostr + scan->flags)
+ goto say_yes;
+ goto do_ifmatch;
+ case IFMATCH:
+ n = 1;
+ if (locinput < PL_bostr + scan->flags)
+ goto say_no;
+ do_ifmatch:
+ PL_reginput = locinput - scan->flags;
+ inner = NEXTOPER(NEXTOPER(scan));
+ if (regmatch(inner) != n) {
+ say_no:
+ if (logical) {
+ logical = 0;
+ sw = 0;
+ goto do_longjump;
+ } else
+ sayNO;
+ }
+ say_yes:
+ if (logical) {
+ logical = 0;
+ sw = 1;
+ }
+ if (OP(scan) == SUSPEND) {
+ locinput = PL_reginput;
+ nextchr = UCHARAT(locinput);
+ }
+ /* FALL THROUGH. */
+ case LONGJMP:
+ do_longjump:
+ next = scan + ARG(scan);
+ if (next == scan)
+ next = NULL;
+ break;
+ default:
+ PerlIO_printf(PerlIO_stderr(), "%lx %d\n",
+ (unsigned long)scan, OP(scan));
+ FAIL("regexp memory corruption");
+ }
+ scan = next;
+ }
+
+ /*
+ * We get here only if there's trouble -- normally "case END" is
+ * the terminating point.
+ */
+ FAIL("corrupted regexp pointers");
+ /*NOTREACHED*/
+ sayNO;
+
+yes:
+#ifdef DEBUGGING
+ PL_regindent--;
+#endif
+ return 1;
+
+no:
+#ifdef DEBUGGING
+ PL_regindent--;
+#endif
+ return 0;
+}
+
+/*
+ - regrepeat - repeatedly match something simple, report how many
+ */
+/*
+ * [This routine now assumes that it will only match on things of length 1.
+ * That was true before, but now we assume scan - reginput is the count,
+ * rather than incrementing count on every character.]
+ */
+STATIC I32
+regrepeat(regnode *p, I32 max)
+{
+ dTHR;
+ register char *scan;
+ register char *opnd;
+ register I32 c;
+ register char *loceol = PL_regeol;
+
+ scan = PL_reginput;
+ if (max != REG_INFTY && max < loceol - scan)
+ loceol = scan + max;
+ opnd = (char *) OPERAND(p);
+ switch (OP(p)) {
+ case ANY:
+ while (scan < loceol && *scan != '\n')
+ scan++;
+ break;
+ case SANY:
+ scan = loceol;
+ break;
+ case EXACT: /* length of string is 1 */
+ c = UCHARAT(++opnd);
+ while (scan < loceol && UCHARAT(scan) == c)
+ scan++;
+ break;
+ case EXACTF: /* length of string is 1 */
+ c = UCHARAT(++opnd);
+ while (scan < loceol &&
+ (UCHARAT(scan) == c || UCHARAT(scan) == fold[c]))
+ scan++;
+ break;
+ case EXACTFL: /* length of string is 1 */
+ PL_reg_flags |= RF_tainted;
+ c = UCHARAT(++opnd);
+ while (scan < loceol &&
+ (UCHARAT(scan) == c || UCHARAT(scan) == fold_locale[c]))
+ scan++;
+ break;
+ case ANYOF:
+ while (scan < loceol && REGINCLASS(opnd, *scan))
+ scan++;
+ break;
+ case ALNUM:
+ while (scan < loceol && isALNUM(*scan))
+ scan++;
+ break;
+ case ALNUML:
+ PL_reg_flags |= RF_tainted;
+ while (scan < loceol && isALNUM_LC(*scan))
+ scan++;
+ break;
+ case NALNUM:
+ while (scan < loceol && !isALNUM(*scan))
+ scan++;
+ break;
+ case NALNUML:
+ PL_reg_flags |= RF_tainted;
+ while (scan < loceol && !isALNUM_LC(*scan))
+ scan++;
+ break;
+ case SPACE:
+ while (scan < loceol && isSPACE(*scan))
+ scan++;
+ break;
+ case SPACEL:
+ PL_reg_flags |= RF_tainted;
+ while (scan < loceol && isSPACE_LC(*scan))
+ scan++;
+ break;
+ case NSPACE:
+ while (scan < loceol && !isSPACE(*scan))
+ scan++;
+ break;
+ case NSPACEL:
+ PL_reg_flags |= RF_tainted;
+ while (scan < loceol && !isSPACE_LC(*scan))
+ scan++;
+ break;
+ case DIGIT:
+ while (scan < loceol && isDIGIT(*scan))
+ scan++;
+ break;
+ case NDIGIT:
+ while (scan < loceol && !isDIGIT(*scan))
+ scan++;
+ break;
+ default: /* Called on something of 0 width. */
+ break; /* So match right here or not at all. */
+ }
+
+ c = scan - PL_reginput;
+ PL_reginput = scan;
+
+ DEBUG_r(
+ {
+ SV *prop = sv_newmortal();
+
+ regprop(prop, p);
+ PerlIO_printf(Perl_debug_log,
+ "%*s %s can match %ld times out of %ld...\n",
+ REPORT_CODE_OFF+1, "", SvPVX(prop),c,max);
+ });
+
+ return(c);
+}
+
+/*
+ - regrepeat_hard - repeatedly match something, report total lenth and length
+ *
+ * The repeater is supposed to have constant length.
+ */
+
+STATIC I32
+regrepeat_hard(regnode *p, I32 max, I32 *lp)
+{
+ dTHR;
+ register char *scan;
+ register char *start;
+ register char *loceol = PL_regeol;
+ I32 l = -1;
+
+ start = PL_reginput;
+ while (PL_reginput < loceol && (scan = PL_reginput, regmatch(p))) {
+ if (l == -1) {
+ *lp = l = PL_reginput - start;
+ if (max != REG_INFTY && l*max < loceol - scan)
+ loceol = scan + l*max;
+ if (l == 0) {
+ return max;
+ }
+ }
+ }
+ if (PL_reginput < loceol)
+ PL_reginput = scan;
+ else
+ scan = PL_reginput;
+
+ return (scan - start)/l;
+}
+
+/*
+ - regclass - determine if a character falls into a character class
+ */
+
+STATIC bool
+reginclass(register char *p, register I32 c)
+{
+ dTHR;
+ char flags = *p;
+ bool match = FALSE;
+
+ c &= 0xFF;
+ if (ANYOF_TEST(p, c))
+ match = TRUE;
+ else if (flags & ANYOF_FOLD) {
+ I32 cf;
+ if (flags & ANYOF_LOCALE) {
+ PL_reg_flags |= RF_tainted;
+ cf = fold_locale[c];
+ }
+ else
+ cf = fold[c];
+ if (ANYOF_TEST(p, cf))
+ match = TRUE;
+ }
+
+ if (!match && (flags & ANYOF_ISA)) {
+ PL_reg_flags |= RF_tainted;
+
+ if (((flags & ANYOF_ALNUML) && isALNUM_LC(c)) ||
+ ((flags & ANYOF_NALNUML) && !isALNUM_LC(c)) ||
+ ((flags & ANYOF_SPACEL) && isSPACE_LC(c)) ||
+ ((flags & ANYOF_NSPACEL) && !isSPACE_LC(c)))
+ {
+ match = TRUE;
+ }
+ }
+
+ return (flags & ANYOF_INVERT) ? !match : match;
+}
+
+
+
diff --git a/contrib/perl5/regexp.h b/contrib/perl5/regexp.h
new file mode 100644
index 000000000000..fbc92370b841
--- /dev/null
+++ b/contrib/perl5/regexp.h
@@ -0,0 +1,103 @@
+/* regexp.h
+ */
+
+/*
+ * Definitions etc. for regexp(3) routines.
+ *
+ * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof],
+ * not the System V one.
+ */
+
+
+struct regnode {
+ U8 flags;
+ U8 type;
+ U16 next_off;
+};
+
+typedef struct regnode regnode;
+
+struct reg_data {
+ U32 count;
+ U8 *what;
+ void* data[1];
+};
+
+struct reg_substr_datum {
+ I32 min_offset;
+ I32 max_offset;
+ SV *substr;
+};
+
+struct reg_substr_data {
+ struct reg_substr_datum data[3]; /* Actual array */
+};
+
+typedef struct regexp {
+ I32 refcnt;
+ char **startp;
+ char **endp;
+ regnode *regstclass;
+ I32 minlen; /* mininum possible length of $& */
+ I32 prelen; /* length of precomp */
+ U32 nparens; /* number of parentheses */
+ U32 lastparen; /* last paren matched */
+ char *precomp; /* pre-compilation regular expression */
+ char *subbase; /* saved string so \digit works forever */
+ char *subbeg; /* same, but not responsible for allocation */
+ char *subend; /* end of subbase */
+ U16 naughty; /* how exponential is this pattern? */
+ U16 reganch; /* Internal use only +
+ Tainted information used by regexec? */
+#if 0
+ SV *anchored_substr; /* Substring at fixed position wrt start. */
+ I32 anchored_offset; /* Position of it. */
+ SV *float_substr; /* Substring at variable position wrt start. */
+ I32 float_min_offset; /* Minimal position of it. */
+ I32 float_max_offset; /* Maximal position of it. */
+ SV *check_substr; /* Substring to check before matching. */
+ I32 check_offset_min; /* Offset of the above. */
+ I32 check_offset_max; /* Offset of the above. */
+#else
+ struct reg_substr_data *substrs;
+#endif
+ struct reg_data *data; /* Additional data. */
+ regnode program[1]; /* Unwarranted chumminess with compiler. */
+} regexp;
+
+#define anchored_substr substrs->data[0].substr
+#define anchored_offset substrs->data[0].min_offset
+#define float_substr substrs->data[1].substr
+#define float_min_offset substrs->data[1].min_offset
+#define float_max_offset substrs->data[1].max_offset
+#define check_substr substrs->data[2].substr
+#define check_offset_min substrs->data[2].min_offset
+#define check_offset_max substrs->data[2].max_offset
+
+#define ROPT_ANCH (ROPT_ANCH_BOL|ROPT_ANCH_MBOL|ROPT_ANCH_GPOS)
+#define ROPT_ANCH_SINGLE (ROPT_ANCH_BOL|ROPT_ANCH_GPOS)
+#define ROPT_ANCH_BOL 1
+#define ROPT_ANCH_MBOL 2
+#define ROPT_ANCH_GPOS 4
+#define ROPT_SKIP 8
+#define ROPT_IMPLICIT 0x10 /* Converted .* to ^.* */
+#define ROPT_NOSCAN 0x20 /* Check-string always at start. */
+#define ROPT_GPOS_SEEN 0x40
+#define ROPT_CHECK_ALL 0x80
+#define ROPT_LOOKBEHIND_SEEN 0x100
+#define ROPT_EVAL_SEEN 0x200
+#define ROPT_TAINTED_SEEN 0x400
+/* 0xf800 of reganch is used by PMf_COMPILETIME */
+
+#define RX_MATCH_TAINTED(prog) ((prog)->reganch & ROPT_TAINTED_SEEN)
+#define RX_MATCH_TAINTED_on(prog) ((prog)->reganch |= ROPT_TAINTED_SEEN)
+#define RX_MATCH_TAINTED_off(prog) ((prog)->reganch &= ~ROPT_TAINTED_SEEN)
+#define RX_MATCH_TAINTED_set(prog, t) ((t) \
+ ? RX_MATCH_TAINTED_on(prog) \
+ : RX_MATCH_TAINTED_off(prog))
+
+#define REXEC_COPY_STR 1 /* Need to copy the string. */
+#define REXEC_CHECKED 2 /* check_substr already checked. */
+
+#define ReREFCNT_inc(re) ((re && re->refcnt++), re)
+#define ReREFCNT_dec(re) pregfree(re)
diff --git a/contrib/perl5/regnodes.h b/contrib/perl5/regnodes.h
new file mode 100644
index 000000000000..c494daed12bb
--- /dev/null
+++ b/contrib/perl5/regnodes.h
@@ -0,0 +1,254 @@
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by regcomp.pl from regcomp.sym.
+ Any changes made here will be lost!
+*/
+
+#define END 0 /* 0 End of program. */
+#define SUCCEED 1 /* 0x1 Return from a subroutine, basically. */
+#define BOL 2 /* 0x2 Match "" at beginning of line. */
+#define MBOL 3 /* 0x3 Same, assuming multiline. */
+#define SBOL 4 /* 0x4 Same, assuming singleline. */
+#define EOS 5 /* 0x5 Match "" at end of string. */
+#define EOL 6 /* 0x6 Match "" at end of line. */
+#define MEOL 7 /* 0x7 Same, assuming multiline. */
+#define SEOL 8 /* 0x8 Same, assuming singleline. */
+#define BOUND 9 /* 0x9 Match "" at any word boundary */
+#define BOUNDL 10 /* 0xa Match "" at any word boundary */
+#define NBOUND 11 /* 0xb Match "" at any word non-boundary */
+#define NBOUNDL 12 /* 0xc Match "" at any word non-boundary */
+#define GPOS 13 /* 0xd Matches where last m//g left off. */
+#define ANY 14 /* 0xe Match any one character (except newline). */
+#define SANY 15 /* 0xf Match any one character. */
+#define ANYOF 16 /* 0x10 Match character in (or not in) this class. */
+#define ALNUM 17 /* 0x11 Match any alphanumeric character */
+#define ALNUML 18 /* 0x12 Match any alphanumeric char in locale */
+#define NALNUM 19 /* 0x13 Match any non-alphanumeric character */
+#define NALNUML 20 /* 0x14 Match any non-alphanumeric char in locale */
+#define SPACE 21 /* 0x15 Match any whitespace character */
+#define SPACEL 22 /* 0x16 Match any whitespace char in locale */
+#define NSPACE 23 /* 0x17 Match any non-whitespace character */
+#define NSPACEL 24 /* 0x18 Match any non-whitespace char in locale */
+#define DIGIT 25 /* 0x19 Match any numeric character */
+#define NDIGIT 26 /* 0x1a Match any non-numeric character */
+#define BRANCH 27 /* 0x1b Match this alternative, or the next... */
+#define BACK 28 /* 0x1c Match "", "next" ptr points backward. */
+#define EXACT 29 /* 0x1d Match this string (preceded by length). */
+#define EXACTF 30 /* 0x1e Match this string, folded (prec. by length). */
+#define EXACTFL 31 /* 0x1f Match this string, folded in locale (w/len). */
+#define NOTHING 32 /* 0x20 Match empty string. */
+#define TAIL 33 /* 0x21 Match empty string. Can jump here from outside. */
+#define STAR 34 /* 0x22 Match this (simple) thing 0 or more times. */
+#define PLUS 35 /* 0x23 Match this (simple) thing 1 or more times. */
+#define CURLY 36 /* 0x24 Match this simple thing {n,m} times. */
+#define CURLYN 37 /* 0x25 Match next-after-this simple thing */
+#define CURLYM 38 /* 0x26 Match this medium-complex thing {n,m} times. */
+#define CURLYX 39 /* 0x27 Match this complex thing {n,m} times. */
+#define WHILEM 40 /* 0x28 Do curly processing and see if rest matches. */
+#define OPEN 41 /* 0x29 Mark this point in input as start of #n. */
+#define CLOSE 42 /* 0x2a Analogous to OPEN. */
+#define REF 43 /* 0x2b Match some already matched string */
+#define REFF 44 /* 0x2c Match already matched string, folded */
+#define REFFL 45 /* 0x2d Match already matched string, folded in loc. */
+#define IFMATCH 46 /* 0x2e Succeeds if the following matches. */
+#define UNLESSM 47 /* 0x2f Fails if the following matches. */
+#define SUSPEND 48 /* 0x30 "Independent" sub-RE. */
+#define IFTHEN 49 /* 0x31 Switch, should be preceeded by switcher . */
+#define GROUPP 50 /* 0x32 Whether the group matched. */
+#define LONGJMP 51 /* 0x33 Jump far away. */
+#define BRANCHJ 52 /* 0x34 BRANCH with long offset. */
+#define EVAL 53 /* 0x35 Execute some Perl code. */
+#define MINMOD 54 /* 0x36 Next operator is not greedy. */
+#define LOGICAL 55 /* 0x37 Next opcode should set the flag only. */
+#define RENUM 56 /* 0x38 Group with independently numbered parens. */
+#define OPTIMIZED 57 /* 0x39 Placeholder for dump. */
+
+#ifndef DOINIT
+EXTCONST U8 regkind[];
+#else
+EXTCONST U8 regkind[] = {
+ END, /* END */
+ END, /* SUCCEED */
+ BOL, /* BOL */
+ BOL, /* MBOL */
+ BOL, /* SBOL */
+ EOL, /* EOS */
+ EOL, /* EOL */
+ EOL, /* MEOL */
+ EOL, /* SEOL */
+ BOUND, /* BOUND */
+ BOUND, /* BOUNDL */
+ NBOUND, /* NBOUND */
+ NBOUND, /* NBOUNDL */
+ GPOS, /* GPOS */
+ ANY, /* ANY */
+ ANY, /* SANY */
+ ANYOF, /* ANYOF */
+ ALNUM, /* ALNUM */
+ ALNUM, /* ALNUML */
+ NALNUM, /* NALNUM */
+ NALNUM, /* NALNUML */
+ SPACE, /* SPACE */
+ SPACE, /* SPACEL */
+ NSPACE, /* NSPACE */
+ NSPACE, /* NSPACEL */
+ DIGIT, /* DIGIT */
+ NDIGIT, /* NDIGIT */
+ BRANCH, /* BRANCH */
+ BACK, /* BACK */
+ EXACT, /* EXACT */
+ EXACT, /* EXACTF */
+ EXACT, /* EXACTFL */
+ NOTHING, /* NOTHING */
+ NOTHING, /* TAIL */
+ STAR, /* STAR */
+ PLUS, /* PLUS */
+ CURLY, /* CURLY */
+ CURLY, /* CURLYN */
+ CURLY, /* CURLYM */
+ CURLY, /* CURLYX */
+ WHILEM, /* WHILEM */
+ OPEN, /* OPEN */
+ CLOSE, /* CLOSE */
+ REF, /* REF */
+ REF, /* REFF */
+ REF, /* REFFL */
+ BRANCHJ, /* IFMATCH */
+ BRANCHJ, /* UNLESSM */
+ BRANCHJ, /* SUSPEND */
+ BRANCHJ, /* IFTHEN */
+ GROUPP, /* GROUPP */
+ LONGJMP, /* LONGJMP */
+ BRANCHJ, /* BRANCHJ */
+ EVAL, /* EVAL */
+ MINMOD, /* MINMOD */
+ LOGICAL, /* LOGICAL */
+ BRANCHJ, /* RENUM */
+ NOTHING, /* OPTIMIZED */
+};
+#endif
+
+
+#ifdef REG_COMP_C
+const static U8 regarglen[] = {
+ 0, /* END */
+ 0, /* SUCCEED */
+ 0, /* BOL */
+ 0, /* MBOL */
+ 0, /* SBOL */
+ 0, /* EOS */
+ 0, /* EOL */
+ 0, /* MEOL */
+ 0, /* SEOL */
+ 0, /* BOUND */
+ 0, /* BOUNDL */
+ 0, /* NBOUND */
+ 0, /* NBOUNDL */
+ 0, /* GPOS */
+ 0, /* ANY */
+ 0, /* SANY */
+ 0, /* ANYOF */
+ 0, /* ALNUM */
+ 0, /* ALNUML */
+ 0, /* NALNUM */
+ 0, /* NALNUML */
+ 0, /* SPACE */
+ 0, /* SPACEL */
+ 0, /* NSPACE */
+ 0, /* NSPACEL */
+ 0, /* DIGIT */
+ 0, /* NDIGIT */
+ 0, /* BRANCH */
+ 0, /* BACK */
+ 0, /* EXACT */
+ 0, /* EXACTF */
+ 0, /* EXACTFL */
+ 0, /* NOTHING */
+ 0, /* TAIL */
+ 0, /* STAR */
+ 0, /* PLUS */
+ EXTRA_SIZE(struct regnode_2), /* CURLY */
+ EXTRA_SIZE(struct regnode_2), /* CURLYN */
+ EXTRA_SIZE(struct regnode_2), /* CURLYM */
+ EXTRA_SIZE(struct regnode_2), /* CURLYX */
+ 0, /* WHILEM */
+ EXTRA_SIZE(struct regnode_1), /* OPEN */
+ EXTRA_SIZE(struct regnode_1), /* CLOSE */
+ EXTRA_SIZE(struct regnode_1), /* REF */
+ EXTRA_SIZE(struct regnode_1), /* REFF */
+ EXTRA_SIZE(struct regnode_1), /* REFFL */
+ EXTRA_SIZE(struct regnode_1), /* IFMATCH */
+ EXTRA_SIZE(struct regnode_1), /* UNLESSM */
+ EXTRA_SIZE(struct regnode_1), /* SUSPEND */
+ EXTRA_SIZE(struct regnode_1), /* IFTHEN */
+ EXTRA_SIZE(struct regnode_1), /* GROUPP */
+ EXTRA_SIZE(struct regnode_1), /* LONGJMP */
+ EXTRA_SIZE(struct regnode_1), /* BRANCHJ */
+ EXTRA_SIZE(struct regnode_1), /* EVAL */
+ 0, /* MINMOD */
+ 0, /* LOGICAL */
+ EXTRA_SIZE(struct regnode_1), /* RENUM */
+ 0, /* OPTIMIZED */
+};
+
+const static char reg_off_by_arg[] = {
+ 0, /* END */
+ 0, /* SUCCEED */
+ 0, /* BOL */
+ 0, /* MBOL */
+ 0, /* SBOL */
+ 0, /* EOS */
+ 0, /* EOL */
+ 0, /* MEOL */
+ 0, /* SEOL */
+ 0, /* BOUND */
+ 0, /* BOUNDL */
+ 0, /* NBOUND */
+ 0, /* NBOUNDL */
+ 0, /* GPOS */
+ 0, /* ANY */
+ 0, /* SANY */
+ 0, /* ANYOF */
+ 0, /* ALNUM */
+ 0, /* ALNUML */
+ 0, /* NALNUM */
+ 0, /* NALNUML */
+ 0, /* SPACE */
+ 0, /* SPACEL */
+ 0, /* NSPACE */
+ 0, /* NSPACEL */
+ 0, /* DIGIT */
+ 0, /* NDIGIT */
+ 0, /* BRANCH */
+ 0, /* BACK */
+ 0, /* EXACT */
+ 0, /* EXACTF */
+ 0, /* EXACTFL */
+ 0, /* NOTHING */
+ 0, /* TAIL */
+ 0, /* STAR */
+ 0, /* PLUS */
+ 0, /* CURLY */
+ 0, /* CURLYN */
+ 0, /* CURLYM */
+ 0, /* CURLYX */
+ 0, /* WHILEM */
+ 0, /* OPEN */
+ 0, /* CLOSE */
+ 0, /* REF */
+ 0, /* REFF */
+ 0, /* REFFL */
+ 2, /* IFMATCH */
+ 2, /* UNLESSM */
+ 1, /* SUSPEND */
+ 1, /* IFTHEN */
+ 0, /* GROUPP */
+ 1, /* LONGJMP */
+ 1, /* BRANCHJ */
+ 0, /* EVAL */
+ 0, /* MINMOD */
+ 0, /* LOGICAL */
+ 1, /* RENUM */
+ 0, /* OPTIMIZED */
+};
+#endif /* REG_COMP_C */
+
diff --git a/contrib/perl5/run.c b/contrib/perl5/run.c
new file mode 100644
index 000000000000..97444ec58e89
--- /dev/null
+++ b/contrib/perl5/run.c
@@ -0,0 +1,139 @@
+/* run.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+/*
+ * "Away now, Shadowfax! Run, greatheart, run as you have never run before!
+ * Now we are come to the lands where you were foaled, and every stone you
+ * know. Run now! Hope is in speed!" --Gandalf
+ */
+
+#ifdef PERL_OBJECT
+#define CALLOP this->*PL_op
+#else
+#define CALLOP *PL_op
+#endif
+
+int
+runops_standard(void)
+{
+ dTHR;
+
+ while ( PL_op = (CALLOP->op_ppaddr)(ARGS) ) ;
+
+ TAINT_NOT;
+ return 0;
+}
+
+#ifdef DEBUGGING
+
+dEXT char **watchaddr = 0;
+dEXT char *watchok;
+
+#ifndef PERL_OBJECT
+static void debprof _((OP*o));
+#endif
+
+#endif /* DEBUGGING */
+
+int
+runops_debug(void)
+{
+#ifdef DEBUGGING
+ dTHR;
+ if (!PL_op) {
+ warn("NULL OP IN RUN");
+ return 0;
+ }
+
+ do {
+ if (PL_debug) {
+ if (watchaddr != 0 && *watchaddr != watchok)
+ PerlIO_printf(Perl_debug_log, "WARNING: %lx changed from %lx to %lx\n",
+ (long)watchaddr, (long)watchok, (long)*watchaddr);
+ DEBUG_s(debstack());
+ DEBUG_t(debop(PL_op));
+ DEBUG_P(debprof(PL_op));
+ }
+ } while ( PL_op = (CALLOP->op_ppaddr)(ARGS) );
+
+ TAINT_NOT;
+ return 0;
+#else
+ return runops_standard();
+#endif /* DEBUGGING */
+}
+
+I32
+debop(OP *o)
+{
+#ifdef DEBUGGING
+ SV *sv;
+ deb("%s", op_name[o->op_type]);
+ switch (o->op_type) {
+ case OP_CONST:
+ PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo->op_sv));
+ break;
+ case OP_GVSV:
+ case OP_GV:
+ 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));
+ SvREFCNT_dec(sv);
+ }
+ else
+ PerlIO_printf(Perl_debug_log, "(NULL)");
+ break;
+ default:
+ break;
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
+#endif /* DEBUGGING */
+ return 0;
+}
+
+void
+watch(char **addr)
+{
+#ifdef DEBUGGING
+ watchaddr = addr;
+ watchok = *addr;
+ PerlIO_printf(Perl_debug_log, "WATCHING, %lx is currently %lx\n",
+ (long)watchaddr, (long)watchok);
+#endif /* DEBUGGING */
+}
+
+STATIC void
+debprof(OP *o)
+{
+#ifdef DEBUGGING
+ if (!PL_profiledata)
+ Newz(000, PL_profiledata, MAXO, U32);
+ ++PL_profiledata[o->op_type];
+#endif /* DEBUGGING */
+}
+
+void
+debprofdump(void)
+{
+#ifdef DEBUGGING
+ unsigned i;
+ if (!PL_profiledata)
+ return;
+ for (i = 0; i < MAXO; i++) {
+ if (PL_profiledata[i])
+ PerlIO_printf(Perl_debug_log,
+ "%5lu %s\n", (unsigned long)PL_profiledata[i],
+ op_name[i]);
+ }
+#endif /* DEBUGGING */
+}
diff --git a/contrib/perl5/scope.c b/contrib/perl5/scope.c
new file mode 100644
index 000000000000..067e29edaae6
--- /dev/null
+++ b/contrib/perl5/scope.c
@@ -0,0 +1,915 @@
+/* scope.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "For the fashion of Minas Tirith was such that it was built on seven
+ * levels..."
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+SV**
+stack_grow(SV **sp, SV **p, int n)
+{
+ dTHR;
+#if defined(DEBUGGING) && !defined(USE_THREADS)
+ static int growing = 0;
+ if (growing++)
+ abort();
+#endif
+ PL_stack_sp = sp;
+#ifndef STRESS_REALLOC
+ av_extend(PL_curstack, (p - PL_stack_base) + (n) + 128);
+#else
+ av_extend(PL_curstack, (p - PL_stack_base) + (n) + 1);
+#endif
+#if defined(DEBUGGING) && !defined(USE_THREADS)
+ growing--;
+#endif
+ return PL_stack_sp;
+}
+
+#ifndef STRESS_REALLOC
+#define GROW(old) ((old) * 3 / 2)
+#else
+#define GROW(old) ((old) + 1)
+#endif
+
+PERL_SI *
+new_stackinfo(I32 stitems, I32 cxitems)
+{
+ PERL_SI *si;
+ PERL_CONTEXT *cxt;
+ New(56, si, 1, PERL_SI);
+ si->si_stack = newAV();
+ AvREAL_off(si->si_stack);
+ av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
+ AvALLOC(si->si_stack)[0] = &PL_sv_undef;
+ AvFILLp(si->si_stack) = 0;
+ si->si_prev = 0;
+ si->si_next = 0;
+ si->si_cxmax = cxitems - 1;
+ si->si_cxix = -1;
+ si->si_type = PERLSI_UNDEF;
+ New(56, si->si_cxstack, cxitems, PERL_CONTEXT);
+ return si;
+}
+
+I32
+cxinc(void)
+{
+ dTHR;
+ cxstack_max = GROW(cxstack_max);
+ Renew(cxstack, cxstack_max + 1, PERL_CONTEXT); /* XXX should fix CXINC macro */
+ return cxstack_ix + 1;
+}
+
+void
+push_return(OP *retop)
+{
+ dTHR;
+ if (PL_retstack_ix == PL_retstack_max) {
+ PL_retstack_max = GROW(PL_retstack_max);
+ Renew(PL_retstack, PL_retstack_max, OP*);
+ }
+ PL_retstack[PL_retstack_ix++] = retop;
+}
+
+OP *
+pop_return(void)
+{
+ dTHR;
+ if (PL_retstack_ix > 0)
+ return PL_retstack[--PL_retstack_ix];
+ else
+ return Nullop;
+}
+
+void
+push_scope(void)
+{
+ dTHR;
+ if (PL_scopestack_ix == PL_scopestack_max) {
+ PL_scopestack_max = GROW(PL_scopestack_max);
+ Renew(PL_scopestack, PL_scopestack_max, I32);
+ }
+ PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
+
+}
+
+void
+pop_scope(void)
+{
+ dTHR;
+ I32 oldsave = PL_scopestack[--PL_scopestack_ix];
+ LEAVE_SCOPE(oldsave);
+}
+
+void
+markstack_grow(void)
+{
+ dTHR;
+ I32 oldmax = PL_markstack_max - PL_markstack;
+ I32 newmax = GROW(oldmax);
+
+ Renew(PL_markstack, newmax, I32);
+ PL_markstack_ptr = PL_markstack + oldmax;
+ PL_markstack_max = PL_markstack + newmax;
+}
+
+void
+savestack_grow(void)
+{
+ dTHR;
+ PL_savestack_max = GROW(PL_savestack_max) + 4;
+ Renew(PL_savestack, PL_savestack_max, ANY);
+}
+
+#undef GROW
+
+void
+free_tmps(void)
+{
+ dTHR;
+ /* XXX should tmps_floor live in cxstack? */
+ I32 myfloor = PL_tmps_floor;
+ while (PL_tmps_ix > myfloor) { /* clean up after last statement */
+ SV* sv = PL_tmps_stack[PL_tmps_ix];
+ PL_tmps_stack[PL_tmps_ix--] = Nullsv;
+ if (sv) {
+#ifdef DEBUGGING
+ SvTEMP_off(sv);
+#endif
+ SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */
+ }
+ }
+}
+
+STATIC SV *
+save_scalar_at(SV **sptr)
+{
+ dTHR;
+ register SV *sv;
+ SV *osv = *sptr;
+
+ sv = *sptr = NEWSV(0,0);
+ if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
+ sv_upgrade(sv, SvTYPE(osv));
+ if (SvGMAGICAL(osv)) {
+ MAGIC* mg;
+ bool oldtainted = PL_tainted;
+ mg_get(osv);
+ if (PL_tainting && PL_tainted && (mg = mg_find(osv, 't'))) {
+ SAVESPTR(mg->mg_obj);
+ mg->mg_obj = osv;
+ }
+ SvFLAGS(osv) |= (SvFLAGS(osv) &
+ (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ PL_tainted = oldtainted;
+ }
+ SvMAGIC(sv) = SvMAGIC(osv);
+ SvFLAGS(sv) |= SvMAGICAL(osv);
+ PL_localizing = 1;
+ SvSETMAGIC(sv);
+ PL_localizing = 0;
+ }
+ return sv;
+}
+
+SV *
+save_scalar(GV *gv)
+{
+ dTHR;
+ SV **sptr = &GvSV(gv);
+ SSCHECK(3);
+ SSPUSHPTR(SvREFCNT_inc(gv));
+ SSPUSHPTR(SvREFCNT_inc(*sptr));
+ SSPUSHINT(SAVEt_SV);
+ return save_scalar_at(sptr);
+}
+
+SV*
+save_svref(SV **sptr)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHPTR(sptr);
+ SSPUSHPTR(SvREFCNT_inc(*sptr));
+ SSPUSHINT(SAVEt_SVREF);
+ return save_scalar_at(sptr);
+}
+
+void
+save_gp(GV *gv, I32 empty)
+{
+ dTHR;
+ SSCHECK(6);
+ SSPUSHIV((IV)SvLEN(gv));
+ SvLEN(gv) = 0; /* forget that anything was allocated here */
+ SSPUSHIV((IV)SvCUR(gv));
+ SSPUSHPTR(SvPVX(gv));
+ SvPOK_off(gv);
+ SSPUSHPTR(SvREFCNT_inc(gv));
+ SSPUSHPTR(GvGP(gv));
+ SSPUSHINT(SAVEt_GP);
+
+ if (empty) {
+ register GP *gp;
+
+ if (GvCVu(gv))
+ PL_sub_generation++; /* taking a method out of circulation */
+ Newz(602, gp, 1, GP);
+ GvGP(gv) = gp_ref(gp);
+ GvSV(gv) = NEWSV(72,0);
+ GvLINE(gv) = PL_curcop->cop_line;
+ GvEGV(gv) = gv;
+ }
+ else {
+ gp_ref(GvGP(gv));
+ GvINTRO_on(gv);
+ }
+}
+
+AV *
+save_ary(GV *gv)
+{
+ dTHR;
+ AV *oav = GvAVn(gv);
+ AV *av;
+
+ if (!AvREAL(oav) && AvREIFY(oav))
+ av_reify(oav);
+ SSCHECK(3);
+ SSPUSHPTR(gv);
+ SSPUSHPTR(oav);
+ SSPUSHINT(SAVEt_AV);
+
+ GvAV(gv) = Null(AV*);
+ av = GvAVn(gv);
+ if (SvMAGIC(oav)) {
+ SvMAGIC(av) = SvMAGIC(oav);
+ SvFLAGS(av) |= SvMAGICAL(oav);
+ SvMAGICAL_off(oav);
+ SvMAGIC(oav) = 0;
+ PL_localizing = 1;
+ SvSETMAGIC((SV*)av);
+ PL_localizing = 0;
+ }
+ return av;
+}
+
+HV *
+save_hash(GV *gv)
+{
+ dTHR;
+ HV *ohv, *hv;
+
+ SSCHECK(3);
+ SSPUSHPTR(gv);
+ SSPUSHPTR(ohv = GvHVn(gv));
+ SSPUSHINT(SAVEt_HV);
+
+ GvHV(gv) = Null(HV*);
+ hv = GvHVn(gv);
+ if (SvMAGIC(ohv)) {
+ SvMAGIC(hv) = SvMAGIC(ohv);
+ SvFLAGS(hv) |= SvMAGICAL(ohv);
+ SvMAGICAL_off(ohv);
+ SvMAGIC(ohv) = 0;
+ PL_localizing = 1;
+ SvSETMAGIC((SV*)hv);
+ PL_localizing = 0;
+ }
+ return hv;
+}
+
+void
+save_item(register SV *item)
+{
+ dTHR;
+ register SV *sv = NEWSV(0,0);
+
+ sv_setsv(sv,item);
+ SSCHECK(3);
+ SSPUSHPTR(item); /* remember the pointer */
+ SSPUSHPTR(sv); /* remember the value */
+ SSPUSHINT(SAVEt_ITEM);
+}
+
+void
+save_int(int *intp)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHINT(*intp);
+ SSPUSHPTR(intp);
+ SSPUSHINT(SAVEt_INT);
+}
+
+void
+save_long(long int *longp)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHLONG(*longp);
+ SSPUSHPTR(longp);
+ SSPUSHINT(SAVEt_LONG);
+}
+
+void
+save_I32(I32 *intp)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHINT(*intp);
+ SSPUSHPTR(intp);
+ SSPUSHINT(SAVEt_I32);
+}
+
+void
+save_I16(I16 *intp)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHINT(*intp);
+ SSPUSHPTR(intp);
+ SSPUSHINT(SAVEt_I16);
+}
+
+void
+save_iv(IV *ivp)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHIV(*ivp);
+ SSPUSHPTR(ivp);
+ SSPUSHINT(SAVEt_IV);
+}
+
+/* Cannot use save_sptr() to store a char* since the SV** cast will
+ * force word-alignment and we'll miss the pointer.
+ */
+void
+save_pptr(char **pptr)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHPTR(*pptr);
+ SSPUSHPTR(pptr);
+ SSPUSHINT(SAVEt_PPTR);
+}
+
+void
+save_sptr(SV **sptr)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHPTR(*sptr);
+ SSPUSHPTR(sptr);
+ SSPUSHINT(SAVEt_SPTR);
+}
+
+SV **
+save_threadsv(PADOFFSET i)
+{
+#ifdef USE_THREADS
+ dTHR;
+ SV **svp = &THREADSV(i); /* XXX Change to save by offset */
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "save_threadsv %u: %p %p:%s\n",
+ i, svp, *svp, SvPEEK(*svp)));
+ save_svref(svp);
+ return svp;
+#else
+ croak("panic: save_threadsv called in non-threaded perl");
+ return 0;
+#endif /* USE_THREADS */
+}
+
+void
+save_nogv(GV *gv)
+{
+ dTHR;
+ SSCHECK(2);
+ SSPUSHPTR(gv);
+ SSPUSHINT(SAVEt_NSTAB);
+}
+
+void
+save_hptr(HV **hptr)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHPTR(*hptr);
+ SSPUSHPTR(hptr);
+ SSPUSHINT(SAVEt_HPTR);
+}
+
+void
+save_aptr(AV **aptr)
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHPTR(*aptr);
+ SSPUSHPTR(aptr);
+ SSPUSHINT(SAVEt_APTR);
+}
+
+void
+save_freesv(SV *sv)
+{
+ dTHR;
+ SSCHECK(2);
+ SSPUSHPTR(sv);
+ SSPUSHINT(SAVEt_FREESV);
+}
+
+void
+save_freeop(OP *o)
+{
+ dTHR;
+ SSCHECK(2);
+ SSPUSHPTR(o);
+ SSPUSHINT(SAVEt_FREEOP);
+}
+
+void
+save_freepv(char *pv)
+{
+ dTHR;
+ SSCHECK(2);
+ SSPUSHPTR(pv);
+ SSPUSHINT(SAVEt_FREEPV);
+}
+
+void
+save_clearsv(SV **svp)
+{
+ dTHR;
+ SSCHECK(2);
+ SSPUSHLONG((long)(svp-PL_curpad));
+ SSPUSHINT(SAVEt_CLEARSV);
+}
+
+void
+save_delete(HV *hv, char *key, I32 klen)
+{
+ dTHR;
+ SSCHECK(4);
+ SSPUSHINT(klen);
+ SSPUSHPTR(key);
+ SSPUSHPTR(SvREFCNT_inc(hv));
+ SSPUSHINT(SAVEt_DELETE);
+}
+
+void
+save_list(register SV **sarg, I32 maxsarg)
+{
+ dTHR;
+ register SV *sv;
+ register I32 i;
+
+ for (i = 1; i <= maxsarg; i++) {
+ sv = NEWSV(0,0);
+ sv_setsv(sv,sarg[i]);
+ SSCHECK(3);
+ SSPUSHPTR(sarg[i]); /* remember the pointer */
+ SSPUSHPTR(sv); /* remember the value */
+ SSPUSHINT(SAVEt_ITEM);
+ }
+}
+
+void
+#ifdef PERL_OBJECT
+save_destructor(DESTRUCTORFUNC f, void* p)
+#else
+save_destructor(void (*f) (void *), void *p)
+#endif
+{
+ dTHR;
+ SSCHECK(3);
+ SSPUSHDPTR(f);
+ SSPUSHPTR(p);
+ SSPUSHINT(SAVEt_DESTRUCTOR);
+}
+
+void
+save_aelem(AV *av, I32 idx, SV **sptr)
+{
+ dTHR;
+ SSCHECK(4);
+ SSPUSHPTR(SvREFCNT_inc(av));
+ SSPUSHINT(idx);
+ SSPUSHPTR(SvREFCNT_inc(*sptr));
+ SSPUSHINT(SAVEt_AELEM);
+ save_scalar_at(sptr);
+}
+
+void
+save_helem(HV *hv, SV *key, SV **sptr)
+{
+ dTHR;
+ SSCHECK(4);
+ SSPUSHPTR(SvREFCNT_inc(hv));
+ SSPUSHPTR(SvREFCNT_inc(key));
+ SSPUSHPTR(SvREFCNT_inc(*sptr));
+ SSPUSHINT(SAVEt_HELEM);
+ save_scalar_at(sptr);
+}
+
+void
+save_op(void)
+{
+ dTHR;
+ SSCHECK(2);
+ SSPUSHPTR(PL_op);
+ SSPUSHINT(SAVEt_OP);
+}
+
+void
+leave_scope(I32 base)
+{
+ dTHR;
+ register SV *sv;
+ register SV *value;
+ register GV *gv;
+ register AV *av;
+ register HV *hv;
+ register void* ptr;
+ I32 i;
+
+ if (base < -1)
+ croak("panic: corrupt saved stack index");
+ while (PL_savestack_ix > base) {
+ switch (SSPOPINT) {
+ case SAVEt_ITEM: /* normal string */
+ value = (SV*)SSPOPPTR;
+ sv = (SV*)SSPOPPTR;
+ sv_replace(sv,value);
+ PL_localizing = 2;
+ SvSETMAGIC(sv);
+ PL_localizing = 0;
+ break;
+ case SAVEt_SV: /* scalar reference */
+ value = (SV*)SSPOPPTR;
+ gv = (GV*)SSPOPPTR;
+ ptr = &GvSV(gv);
+ SvREFCNT_dec(gv);
+ goto restore_sv;
+ case SAVEt_SVREF: /* scalar reference */
+ value = (SV*)SSPOPPTR;
+ ptr = SSPOPPTR;
+ restore_sv:
+ sv = *(SV**)ptr;
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "restore svref: %p %p:%s -> %p:%s\n",
+ ptr, sv, SvPEEK(sv), value, SvPEEK(value)));
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
+ SvTYPE(sv) != SVt_PVGV)
+ {
+ (void)SvUPGRADE(value, SvTYPE(sv));
+ SvMAGIC(value) = SvMAGIC(sv);
+ SvFLAGS(value) |= SvMAGICAL(sv);
+ SvMAGICAL_off(sv);
+ SvMAGIC(sv) = 0;
+ }
+ else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) &&
+ SvTYPE(value) != SVt_PVGV)
+ {
+ SvFLAGS(value) |= (SvFLAGS(value) &
+ (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ SvMAGICAL_off(value);
+ SvMAGIC(value) = 0;
+ }
+ SvREFCNT_dec(sv);
+ *(SV**)ptr = value;
+ PL_localizing = 2;
+ SvSETMAGIC(value);
+ PL_localizing = 0;
+ SvREFCNT_dec(value);
+ break;
+ case SAVEt_AV: /* array reference */
+ av = (AV*)SSPOPPTR;
+ gv = (GV*)SSPOPPTR;
+ if (GvAV(gv)) {
+ AV *goner = GvAV(gv);
+ SvMAGIC(av) = SvMAGIC(goner);
+ SvFLAGS(av) |= SvMAGICAL(goner);
+ SvMAGICAL_off(goner);
+ SvMAGIC(goner) = 0;
+ SvREFCNT_dec(goner);
+ }
+ GvAV(gv) = av;
+ if (SvMAGICAL(av)) {
+ PL_localizing = 2;
+ SvSETMAGIC((SV*)av);
+ PL_localizing = 0;
+ }
+ break;
+ case SAVEt_HV: /* hash reference */
+ hv = (HV*)SSPOPPTR;
+ gv = (GV*)SSPOPPTR;
+ if (GvHV(gv)) {
+ HV *goner = GvHV(gv);
+ SvMAGIC(hv) = SvMAGIC(goner);
+ SvFLAGS(hv) |= SvMAGICAL(goner);
+ SvMAGICAL_off(goner);
+ SvMAGIC(goner) = 0;
+ SvREFCNT_dec(goner);
+ }
+ GvHV(gv) = hv;
+ if (SvMAGICAL(hv)) {
+ PL_localizing = 2;
+ SvSETMAGIC((SV*)hv);
+ PL_localizing = 0;
+ }
+ break;
+ case SAVEt_INT: /* int reference */
+ ptr = SSPOPPTR;
+ *(int*)ptr = (int)SSPOPINT;
+ break;
+ case SAVEt_LONG: /* long reference */
+ ptr = SSPOPPTR;
+ *(long*)ptr = (long)SSPOPLONG;
+ break;
+ case SAVEt_I32: /* I32 reference */
+ ptr = SSPOPPTR;
+ *(I32*)ptr = (I32)SSPOPINT;
+ break;
+ case SAVEt_I16: /* I16 reference */
+ ptr = SSPOPPTR;
+ *(I16*)ptr = (I16)SSPOPINT;
+ break;
+ case SAVEt_IV: /* IV reference */
+ ptr = SSPOPPTR;
+ *(IV*)ptr = (IV)SSPOPIV;
+ break;
+ case SAVEt_SPTR: /* SV* reference */
+ ptr = SSPOPPTR;
+ *(SV**)ptr = (SV*)SSPOPPTR;
+ break;
+ case SAVEt_PPTR: /* char* reference */
+ ptr = SSPOPPTR;
+ *(char**)ptr = (char*)SSPOPPTR;
+ break;
+ case SAVEt_HPTR: /* HV* reference */
+ ptr = SSPOPPTR;
+ *(HV**)ptr = (HV*)SSPOPPTR;
+ break;
+ case SAVEt_APTR: /* AV* reference */
+ ptr = SSPOPPTR;
+ *(AV**)ptr = (AV*)SSPOPPTR;
+ break;
+ case SAVEt_NSTAB:
+ gv = (GV*)SSPOPPTR;
+ (void)sv_clear((SV*)gv);
+ break;
+ case SAVEt_GP: /* scalar reference */
+ ptr = SSPOPPTR;
+ gv = (GV*)SSPOPPTR;
+ if (SvPVX(gv) && SvLEN(gv) > 0) {
+ Safefree(SvPVX(gv));
+ }
+ SvPVX(gv) = (char *)SSPOPPTR;
+ SvCUR(gv) = (STRLEN)SSPOPIV;
+ SvLEN(gv) = (STRLEN)SSPOPIV;
+ gp_free(gv);
+ GvGP(gv) = (GP*)ptr;
+ if (GvCVu(gv))
+ PL_sub_generation++; /* putting a method back into circulation */
+ SvREFCNT_dec(gv);
+ break;
+ case SAVEt_FREESV:
+ ptr = SSPOPPTR;
+ SvREFCNT_dec((SV*)ptr);
+ break;
+ case SAVEt_FREEOP:
+ ptr = SSPOPPTR;
+ if (PL_comppad)
+ PL_curpad = AvARRAY(PL_comppad);
+ op_free((OP*)ptr);
+ break;
+ case SAVEt_FREEPV:
+ ptr = SSPOPPTR;
+ Safefree((char*)ptr);
+ break;
+ case SAVEt_CLEARSV:
+ ptr = (void*)&PL_curpad[SSPOPLONG];
+ sv = *(SV**)ptr;
+ /* Can clear pad variable in place? */
+ if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
+ if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv))
+ croak("panic: leave_scope clearsv");
+ if (SvROK(sv))
+ sv_unref(sv);
+ }
+ if (SvMAGICAL(sv))
+ mg_free(sv);
+
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ break;
+ case SVt_PVAV:
+ av_clear((AV*)sv);
+ break;
+ case SVt_PVHV:
+ hv_clear((HV*)sv);
+ break;
+ case SVt_PVCV:
+ croak("panic: leave_scope pad code");
+ case SVt_RV:
+ case SVt_IV:
+ case SVt_NV:
+ (void)SvOK_off(sv);
+ break;
+ default:
+ (void)SvOK_off(sv);
+ (void)SvOOK_off(sv);
+ break;
+ }
+ }
+ else { /* Someone has a claim on this, so abandon it. */
+ U32 padflags = SvFLAGS(sv) & (SVs_PADBUSY|SVs_PADMY|SVs_PADTMP);
+ switch (SvTYPE(sv)) { /* Console ourselves with a new value */
+ case SVt_PVAV: *(SV**)ptr = (SV*)newAV(); break;
+ case SVt_PVHV: *(SV**)ptr = (SV*)newHV(); break;
+ default: *(SV**)ptr = NEWSV(0,0); break;
+ }
+ SvREFCNT_dec(sv); /* Cast current value to the winds. */
+ SvFLAGS(*(SV**)ptr) |= padflags; /* preserve pad nature */
+ }
+ break;
+ case SAVEt_DELETE:
+ ptr = SSPOPPTR;
+ hv = (HV*)ptr;
+ ptr = SSPOPPTR;
+ (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
+ SvREFCNT_dec(hv);
+ Safefree(ptr);
+ break;
+ case SAVEt_DESTRUCTOR:
+ ptr = SSPOPPTR;
+ (CALLDESTRUCTOR)(ptr);
+ break;
+ case SAVEt_REGCONTEXT:
+ i = SSPOPINT;
+ PL_savestack_ix -= i; /* regexp must have croaked */
+ break;
+ case SAVEt_STACK_POS: /* Position on Perl stack */
+ i = SSPOPINT;
+ PL_stack_sp = PL_stack_base + i;
+ break;
+ case SAVEt_AELEM: /* array element */
+ value = (SV*)SSPOPPTR;
+ i = SSPOPINT;
+ av = (AV*)SSPOPPTR;
+ ptr = av_fetch(av,i,1);
+ if (ptr) {
+ sv = *(SV**)ptr;
+ if (sv && sv != &PL_sv_undef) {
+ if (SvRMAGICAL(av) && mg_find((SV*)av, 'P'))
+ (void)SvREFCNT_inc(sv);
+ SvREFCNT_dec(av);
+ goto restore_sv;
+ }
+ }
+ SvREFCNT_dec(av);
+ SvREFCNT_dec(value);
+ break;
+ case SAVEt_HELEM: /* hash element */
+ value = (SV*)SSPOPPTR;
+ sv = (SV*)SSPOPPTR;
+ hv = (HV*)SSPOPPTR;
+ ptr = hv_fetch_ent(hv, sv, 1, 0);
+ if (ptr) {
+ SV *oval = HeVAL((HE*)ptr);
+ if (oval && oval != &PL_sv_undef) {
+ ptr = &HeVAL((HE*)ptr);
+ if (SvRMAGICAL(hv) && mg_find((SV*)hv, 'P'))
+ (void)SvREFCNT_inc(*(SV**)ptr);
+ SvREFCNT_dec(hv);
+ SvREFCNT_dec(sv);
+ goto restore_sv;
+ }
+ }
+ SvREFCNT_dec(hv);
+ SvREFCNT_dec(sv);
+ SvREFCNT_dec(value);
+ break;
+ case SAVEt_OP:
+ PL_op = (OP*)SSPOPPTR;
+ break;
+ case SAVEt_HINTS:
+ if (GvHV(PL_hintgv)) {
+ SvREFCNT_dec((SV*)GvHV(PL_hintgv));
+ GvHV(PL_hintgv) = NULL;
+ }
+ *(I32*)&PL_hints = (I32)SSPOPINT;
+ break;
+ default:
+ croak("panic: leave_scope inconsistency");
+ }
+ }
+}
+
+void
+cx_dump(PERL_CONTEXT *cx)
+{
+#ifdef DEBUGGING
+ dTHR;
+ PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[cx->cx_type]);
+ if (cx->cx_type != CXt_SUBST) {
+ PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
+ PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop);
+ PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
+ PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
+ PerlIO_printf(Perl_debug_log, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp);
+ PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm);
+ PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
+ }
+ switch (cx->cx_type) {
+ case CXt_NULL:
+ case CXt_BLOCK:
+ break;
+ case CXt_SUB:
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n",
+ (long)cx->blk_sub.cv);
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n",
+ (long)cx->blk_sub.gv);
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n",
+ (long)cx->blk_sub.dfoutgv);
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
+ (long)cx->blk_sub.olddepth);
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
+ (int)cx->blk_sub.hasargs);
+ break;
+ case CXt_EVAL:
+ PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
+ (long)cx->blk_eval.old_in_eval);
+ PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
+ op_name[cx->blk_eval.old_op_type],
+ op_desc[cx->blk_eval.old_op_type]);
+ PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
+ cx->blk_eval.old_name);
+ PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n",
+ (long)cx->blk_eval.old_eval_root);
+ break;
+
+ case CXt_LOOP:
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n",
+ cx->blk_loop.label);
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
+ (long)cx->blk_loop.resetsp);
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%lx\n",
+ (long)cx->blk_loop.redo_op);
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%lx\n",
+ (long)cx->blk_loop.next_op);
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%lx\n",
+ (long)cx->blk_loop.last_op);
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
+ (long)cx->blk_loop.iterix);
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n",
+ (long)cx->blk_loop.iterary);
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%lx\n",
+ (long)cx->blk_loop.itervar);
+ if (cx->blk_loop.itervar)
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n",
+ (long)cx->blk_loop.itersave);
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%lx\n",
+ (long)cx->blk_loop.iterlval);
+ break;
+
+ case CXt_SUBST:
+ PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
+ (long)cx->sb_iters);
+ PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
+ (long)cx->sb_maxiters);
+ PerlIO_printf(Perl_debug_log, "SB_SAFEBASE = %ld\n",
+ (long)cx->sb_safebase);
+ PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
+ (long)cx->sb_once);
+ PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
+ cx->sb_orig);
+ PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%lx\n",
+ (long)cx->sb_dstr);
+ PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%lx\n",
+ (long)cx->sb_targ);
+ PerlIO_printf(Perl_debug_log, "SB_S = 0x%lx\n",
+ (long)cx->sb_s);
+ PerlIO_printf(Perl_debug_log, "SB_M = 0x%lx\n",
+ (long)cx->sb_m);
+ PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%lx\n",
+ (long)cx->sb_strend);
+ PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%lx\n",
+ (long)cx->sb_rxres);
+ break;
+ }
+#endif /* DEBUGGING */
+}
diff --git a/contrib/perl5/scope.h b/contrib/perl5/scope.h
new file mode 100644
index 000000000000..0dde4e12a062
--- /dev/null
+++ b/contrib/perl5/scope.h
@@ -0,0 +1,171 @@
+#define SAVEt_ITEM 0
+#define SAVEt_SV 1
+#define SAVEt_AV 2
+#define SAVEt_HV 3
+#define SAVEt_INT 4
+#define SAVEt_LONG 5
+#define SAVEt_I32 6
+#define SAVEt_IV 7
+#define SAVEt_SPTR 8
+#define SAVEt_APTR 9
+#define SAVEt_HPTR 10
+#define SAVEt_PPTR 11
+#define SAVEt_NSTAB 12
+#define SAVEt_SVREF 13
+#define SAVEt_GP 14
+#define SAVEt_FREESV 15
+#define SAVEt_FREEOP 16
+#define SAVEt_FREEPV 17
+#define SAVEt_CLEARSV 18
+#define SAVEt_DELETE 19
+#define SAVEt_DESTRUCTOR 20
+#define SAVEt_REGCONTEXT 21
+#define SAVEt_STACK_POS 22
+#define SAVEt_I16 23
+#define SAVEt_AELEM 24
+#define SAVEt_HELEM 25
+#define SAVEt_OP 26
+#define SAVEt_HINTS 27
+
+#define SSCHECK(need) if (PL_savestack_ix + need > PL_savestack_max) savestack_grow()
+#define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i))
+#define SSPUSHLONG(i) (PL_savestack[PL_savestack_ix++].any_long = (long)(i))
+#define SSPUSHIV(i) (PL_savestack[PL_savestack_ix++].any_iv = (IV)(i))
+#define SSPUSHPTR(p) (PL_savestack[PL_savestack_ix++].any_ptr = (void*)(p))
+#define SSPUSHDPTR(p) (PL_savestack[PL_savestack_ix++].any_dptr = (p))
+#define SSPOPINT (PL_savestack[--PL_savestack_ix].any_i32)
+#define SSPOPLONG (PL_savestack[--PL_savestack_ix].any_long)
+#define SSPOPIV (PL_savestack[--PL_savestack_ix].any_iv)
+#define SSPOPPTR (PL_savestack[--PL_savestack_ix].any_ptr)
+#define SSPOPDPTR (PL_savestack[--PL_savestack_ix].any_dptr)
+
+#define SAVETMPS save_int((int*)&PL_tmps_floor), PL_tmps_floor = PL_tmps_ix
+#define FREETMPS if (PL_tmps_ix > PL_tmps_floor) free_tmps()
+
+#ifdef DEBUGGING
+#define ENTER \
+ STMT_START { \
+ push_scope(); \
+ DEBUG_l(WITH_THR(deb("ENTER scope %ld at %s:%d\n", \
+ PL_scopestack_ix, __FILE__, __LINE__))); \
+ } STMT_END
+#define LEAVE \
+ STMT_START { \
+ DEBUG_l(WITH_THR(deb("LEAVE scope %ld at %s:%d\n", \
+ PL_scopestack_ix, __FILE__, __LINE__))); \
+ pop_scope(); \
+ } STMT_END
+#else
+#define ENTER push_scope()
+#define LEAVE pop_scope()
+#endif
+#define LEAVE_SCOPE(old) if (PL_savestack_ix > old) leave_scope(old)
+
+/*
+ * Not using SOFT_CAST on SAVEFREESV and SAVEFREESV
+ * because these are used for several kinds of pointer values
+ */
+#define SAVEI16(i) save_I16(SOFT_CAST(I16*)&(i))
+#define SAVEI32(i) save_I32(SOFT_CAST(I32*)&(i))
+#define SAVEINT(i) save_int(SOFT_CAST(int*)&(i))
+#define SAVEIV(i) save_iv(SOFT_CAST(IV*)&(i))
+#define SAVELONG(l) save_long(SOFT_CAST(long*)&(l))
+#define SAVESPTR(s) save_sptr((SV**)&(s))
+#define SAVEPPTR(s) save_pptr(SOFT_CAST(char**)&(s))
+#define SAVEFREESV(s) save_freesv((SV*)(s))
+#define SAVEFREEOP(o) save_freeop(SOFT_CAST(OP*)(o))
+#define SAVEFREEPV(p) save_freepv(SOFT_CAST(char*)(p))
+#define SAVECLEARSV(sv) save_clearsv(SOFT_CAST(SV**)&(sv))
+#define SAVEDELETE(h,k,l) \
+ save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l))
+#ifdef PERL_OBJECT
+#define CALLDESTRUCTOR this->*SSPOPDPTR
+#define SAVEDESTRUCTOR(f,p) \
+ save_destructor((DESTRUCTORFUNC)(FUNC_NAME_TO_PTR(f)), \
+ SOFT_CAST(void*)(p))
+#else
+#define CALLDESTRUCTOR *SSPOPDPTR
+#define SAVEDESTRUCTOR(f,p) \
+ save_destructor(SOFT_CAST(void(*)_((void*)))(FUNC_NAME_TO_PTR(f)), \
+ SOFT_CAST(void*)(p))
+#endif
+
+#define SAVESTACK_POS() \
+ STMT_START { \
+ SSCHECK(2); \
+ SSPUSHINT(PL_stack_sp - PL_stack_base); \
+ SSPUSHINT(SAVEt_STACK_POS); \
+ } STMT_END
+
+#define SAVEOP() save_op()
+
+#define SAVEHINTS() \
+ STMT_START { \
+ if (PL_hints & HINT_LOCALIZE_HH) \
+ save_hints(); \
+ else { \
+ SSCHECK(2); \
+ SSPUSHINT(PL_hints); \
+ SSPUSHINT(SAVEt_HINTS); \
+ } \
+ } STMT_END
+
+/* A jmpenv packages the state required to perform a proper non-local jump.
+ * Note that there is a start_env initialized when perl starts, and top_env
+ * points to this initially, so top_env should always be non-null.
+ *
+ * Existence of a non-null top_env->je_prev implies it is valid to call
+ * longjmp() at that runlevel (we make sure start_env.je_prev is always
+ * null to ensure this).
+ *
+ * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
+ * establish a local jmpenv to handle exception traps. Care must be taken
+ * to restore the previous value of je_mustcatch before exiting the
+ * stack frame iff JMPENV_PUSH was not called in that stack frame.
+ * GSAR 97-03-27
+ */
+
+struct jmpenv {
+ struct jmpenv * je_prev;
+ Sigjmp_buf je_buf;
+ int je_ret; /* return value of last setjmp() */
+ bool je_mustcatch; /* longjmp()s must be caught locally */
+};
+
+typedef struct jmpenv JMPENV;
+
+#ifdef OP_IN_REGISTER
+#define OP_REG_TO_MEM PL_opsave = op
+#define OP_MEM_TO_REG op = PL_opsave
+#else
+#define OP_REG_TO_MEM NOOP
+#define OP_MEM_TO_REG NOOP
+#endif
+
+#define dJMPENV JMPENV cur_env
+#define JMPENV_PUSH(v) \
+ STMT_START { \
+ cur_env.je_prev = PL_top_env; \
+ OP_REG_TO_MEM; \
+ cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1); \
+ OP_MEM_TO_REG; \
+ PL_top_env = &cur_env; \
+ cur_env.je_mustcatch = FALSE; \
+ (v) = cur_env.je_ret; \
+ } STMT_END
+#define JMPENV_POP \
+ STMT_START { PL_top_env = cur_env.je_prev; } STMT_END
+#define JMPENV_JUMP(v) \
+ STMT_START { \
+ OP_REG_TO_MEM; \
+ if (PL_top_env->je_prev) \
+ PerlProc_longjmp(PL_top_env->je_buf, (v)); \
+ if ((v) == 2) \
+ PerlProc_exit(STATUS_NATIVE_EXPORT); \
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
+ PerlProc_exit(1); \
+ } STMT_END
+
+#define CATCH_GET (PL_top_env->je_mustcatch)
+#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v))
+
diff --git a/contrib/perl5/sv.c b/contrib/perl5/sv.c
new file mode 100644
index 000000000000..a53e76979eb7
--- /dev/null
+++ b/contrib/perl5/sv.c
@@ -0,0 +1,5148 @@
+/* sv.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "I wonder what the Entish is for 'yes' and 'no'," he thought.
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef OVR_DBL_DIG
+/* Use an overridden DBL_DIG */
+# ifdef DBL_DIG
+# undef DBL_DIG
+# endif
+# define DBL_DIG OVR_DBL_DIG
+#else
+/* The following is all to get DBL_DIG, in order to pick a nice
+ default value for printing floating point numbers in Gconvert.
+ (see config.h)
+*/
+#ifdef I_LIMITS
+#include <limits.h>
+#endif
+#ifdef I_FLOAT
+#include <float.h>
+#endif
+#ifndef HAS_DBL_DIG
+#define DBL_DIG 15 /* A guess that works lots of places */
+#endif
+#endif
+
+#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__)
+# define FAST_SV_GETS
+#endif
+
+#ifdef PERL_OBJECT
+#define FCALL this->*f
+#define VTBL this->*vtbl
+
+#else /* !PERL_OBJECT */
+
+static IV asIV _((SV* sv));
+static UV asUV _((SV* sv));
+static SV *more_sv _((void));
+static XPVIV *more_xiv _((void));
+static XPVNV *more_xnv _((void));
+static XPV *more_xpv _((void));
+static XRV *more_xrv _((void));
+static XPVIV *new_xiv _((void));
+static XPVNV *new_xnv _((void));
+static XPV *new_xpv _((void));
+static XRV *new_xrv _((void));
+static void del_xiv _((XPVIV* p));
+static void del_xnv _((XPVNV* p));
+static void del_xpv _((XPV* p));
+static void del_xrv _((XRV* p));
+static void sv_mortalgrow _((void));
+static void sv_unglob _((SV* sv));
+static void sv_check_thinkfirst _((SV *sv));
+
+#ifndef PURIFY
+static void *my_safemalloc(MEM_SIZE size);
+#endif
+
+typedef void (*SVFUNC) _((SV*));
+#define VTBL *vtbl
+#define FCALL *f
+
+#endif /* PERL_OBJECT */
+
+#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_check_thinkfirst(sv)
+
+#ifdef PURIFY
+
+#define new_SV(p) \
+ do { \
+ LOCK_SV_MUTEX; \
+ (p) = (SV*)safemalloc(sizeof(SV)); \
+ reg_add(p); \
+ UNLOCK_SV_MUTEX; \
+ } while (0)
+
+#define del_SV(p) \
+ do { \
+ LOCK_SV_MUTEX; \
+ reg_remove(p); \
+ Safefree((char*)(p)); \
+ UNLOCK_SV_MUTEX; \
+ } while (0)
+
+static SV **registry;
+static I32 registry_size;
+
+#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
+
+#define REG_REPLACE(sv,a,b) \
+ do { \
+ void* p = sv->sv_any; \
+ I32 h = REGHASH(sv, registry_size); \
+ I32 i = h; \
+ while (registry[i] != (a)) { \
+ if (++i >= registry_size) \
+ i = 0; \
+ if (i == h) \
+ die("SV registry bug"); \
+ } \
+ registry[i] = (b); \
+ } while (0)
+
+#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
+#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
+
+static void
+reg_add(sv)
+SV* sv;
+{
+ if (PL_sv_count >= (registry_size >> 1))
+ {
+ SV **oldreg = registry;
+ I32 oldsize = registry_size;
+
+ registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
+ Newz(707, registry, registry_size, SV*);
+
+ if (oldreg) {
+ I32 i;
+
+ for (i = 0; i < oldsize; ++i) {
+ SV* oldsv = oldreg[i];
+ if (oldsv)
+ REG_ADD(oldsv);
+ }
+ Safefree(oldreg);
+ }
+ }
+
+ REG_ADD(sv);
+ ++PL_sv_count;
+}
+
+static void
+reg_remove(sv)
+SV* sv;
+{
+ REG_REMOVE(sv);
+ --PL_sv_count;
+}
+
+static void
+visit(f)
+SVFUNC f;
+{
+ I32 i;
+
+ for (i = 0; i < registry_size; ++i) {
+ SV* sv = registry[i];
+ if (sv && SvTYPE(sv) != SVTYPEMASK)
+ (*f)(sv);
+ }
+}
+
+void
+sv_add_arena(ptr, size, flags)
+char* ptr;
+U32 size;
+U32 flags;
+{
+ if (!(flags & SVf_FAKE))
+ Safefree(ptr);
+}
+
+#else /* ! PURIFY */
+
+/*
+ * "A time to plant, and a time to uproot what was planted..."
+ */
+
+#define plant_SV(p) \
+ do { \
+ SvANY(p) = (void *)PL_sv_root; \
+ SvFLAGS(p) = SVTYPEMASK; \
+ PL_sv_root = (p); \
+ --PL_sv_count; \
+ } while (0)
+
+/* sv_mutex must be held while calling uproot_SV() */
+#define uproot_SV(p) \
+ do { \
+ (p) = PL_sv_root; \
+ PL_sv_root = (SV*)SvANY(p); \
+ ++PL_sv_count; \
+ } while (0)
+
+#define new_SV(p) do { \
+ LOCK_SV_MUTEX; \
+ if (PL_sv_root) \
+ uproot_SV(p); \
+ else \
+ (p) = more_sv(); \
+ UNLOCK_SV_MUTEX; \
+ } while (0)
+
+#ifdef DEBUGGING
+
+#define del_SV(p) do { \
+ LOCK_SV_MUTEX; \
+ if (PL_debug & 32768) \
+ del_sv(p); \
+ else \
+ plant_SV(p); \
+ UNLOCK_SV_MUTEX; \
+ } while (0)
+
+STATIC void
+del_sv(SV *p)
+{
+ if (PL_debug & 32768) {
+ SV* sva;
+ SV* sv;
+ SV* svend;
+ int ok = 0;
+ for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
+ sv = sva + 1;
+ svend = &sva[SvREFCNT(sva)];
+ if (p >= sv && p < svend)
+ ok = 1;
+ }
+ if (!ok) {
+ warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
+ return;
+ }
+ }
+ plant_SV(p);
+}
+
+#else /* ! DEBUGGING */
+
+#define del_SV(p) plant_SV(p)
+
+#endif /* DEBUGGING */
+
+void
+sv_add_arena(char *ptr, U32 size, U32 flags)
+{
+ SV* sva = (SV*)ptr;
+ register SV* sv;
+ register SV* svend;
+ Zero(sva, size, char);
+
+ /* The first SV in an arena isn't an SV. */
+ SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
+ SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
+ SvFLAGS(sva) = flags; /* FAKE if not to be freed */
+
+ PL_sv_arenaroot = sva;
+ PL_sv_root = sva + 1;
+
+ svend = &sva[SvREFCNT(sva) - 1];
+ sv = sva + 1;
+ while (sv < svend) {
+ SvANY(sv) = (void *)(SV*)(sv + 1);
+ SvFLAGS(sv) = SVTYPEMASK;
+ sv++;
+ }
+ SvANY(sv) = 0;
+ SvFLAGS(sv) = SVTYPEMASK;
+}
+
+/* sv_mutex must be held while calling more_sv() */
+STATIC SV*
+more_sv(void)
+{
+ register SV* sv;
+
+ if (PL_nice_chunk) {
+ sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
+ PL_nice_chunk = Nullch;
+ }
+ else {
+ char *chunk; /* must use New here to match call to */
+ New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
+ sv_add_arena(chunk, 1008, 0);
+ }
+ uproot_SV(sv);
+ return sv;
+}
+
+STATIC void
+visit(SVFUNC f)
+{
+ SV* sva;
+ SV* sv;
+ register SV* svend;
+
+ for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
+ svend = &sva[SvREFCNT(sva)];
+ for (sv = sva + 1; sv < svend; ++sv) {
+ if (SvTYPE(sv) != SVTYPEMASK)
+ (FCALL)(sv);
+ }
+ }
+}
+
+#endif /* PURIFY */
+
+STATIC void
+do_report_used(SV *sv)
+{
+ if (SvTYPE(sv) != SVTYPEMASK) {
+ /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
+ PerlIO_printf(PerlIO_stderr(), "****\n");
+ sv_dump(sv);
+ }
+}
+
+void
+sv_report_used(void)
+{
+ visit(FUNC_NAME_TO_PTR(do_report_used));
+}
+
+STATIC void
+do_clean_objs(SV *sv)
+{
+ SV* rv;
+
+ if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
+ SvROK_off(sv);
+ SvRV(sv) = 0;
+ SvREFCNT_dec(rv);
+ }
+
+ /* XXX Might want to check arrays, etc. */
+}
+
+#ifndef DISABLE_DESTRUCTOR_KLUDGE
+STATIC void
+do_clean_named_objs(SV *sv)
+{
+ if (SvTYPE(sv) == SVt_PVGV) {
+ if ( SvOBJECT(GvSV(sv)) ||
+ GvAV(sv) && SvOBJECT(GvAV(sv)) ||
+ GvHV(sv) && SvOBJECT(GvHV(sv)) ||
+ GvIO(sv) && SvOBJECT(GvIO(sv)) ||
+ GvCV(sv) && SvOBJECT(GvCV(sv)) )
+ {
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
+ SvREFCNT_dec(sv);
+ }
+ }
+}
+#endif
+
+void
+sv_clean_objs(void)
+{
+ PL_in_clean_objs = TRUE;
+ visit(FUNC_NAME_TO_PTR(do_clean_objs));
+#ifndef DISABLE_DESTRUCTOR_KLUDGE
+ /* some barnacles may yet remain, clinging to typeglobs */
+ visit(FUNC_NAME_TO_PTR(do_clean_named_objs));
+#endif
+ PL_in_clean_objs = FALSE;
+}
+
+STATIC void
+do_clean_all(SV *sv)
+{
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
+ SvFLAGS(sv) |= SVf_BREAK;
+ SvREFCNT_dec(sv);
+}
+
+void
+sv_clean_all(void)
+{
+ PL_in_clean_all = TRUE;
+ visit(FUNC_NAME_TO_PTR(do_clean_all));
+ PL_in_clean_all = FALSE;
+}
+
+void
+sv_free_arenas(void)
+{
+ SV* sva;
+ SV* svanext;
+
+ /* Free arenas here, but be careful about fake ones. (We assume
+ contiguity of the fake ones with the corresponding real ones.) */
+
+ for (sva = PL_sv_arenaroot; sva; sva = svanext) {
+ svanext = (SV*) SvANY(sva);
+ while (svanext && SvFAKE(svanext))
+ svanext = (SV*) SvANY(svanext);
+
+ if (!SvFAKE(sva))
+ Safefree((void *)sva);
+ }
+
+ if (PL_nice_chunk)
+ Safefree(PL_nice_chunk);
+ PL_nice_chunk = Nullch;
+ PL_nice_chunk_size = 0;
+ PL_sv_arenaroot = 0;
+ PL_sv_root = 0;
+}
+
+STATIC XPVIV*
+new_xiv(void)
+{
+ IV* xiv;
+ if (PL_xiv_root) {
+ xiv = PL_xiv_root;
+ /*
+ * See comment in more_xiv() -- RAM.
+ */
+ PL_xiv_root = *(IV**)xiv;
+ return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
+ }
+ return more_xiv();
+}
+
+STATIC void
+del_xiv(XPVIV *p)
+{
+ IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
+ *(IV**)xiv = PL_xiv_root;
+ PL_xiv_root = xiv;
+}
+
+STATIC XPVIV*
+more_xiv(void)
+{
+ register IV* xiv;
+ register IV* xivend;
+ XPV* ptr;
+ New(705, ptr, 1008/sizeof(XPV), XPV);
+ ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
+ PL_xiv_arenaroot = ptr; /* to keep Purify happy */
+
+ xiv = (IV*) ptr;
+ xivend = &xiv[1008 / sizeof(IV) - 1];
+ xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
+ PL_xiv_root = xiv;
+ while (xiv < xivend) {
+ *(IV**)xiv = (IV *)(xiv + 1);
+ xiv++;
+ }
+ *(IV**)xiv = 0;
+ return new_xiv();
+}
+
+STATIC XPVNV*
+new_xnv(void)
+{
+ double* xnv;
+ if (PL_xnv_root) {
+ xnv = PL_xnv_root;
+ PL_xnv_root = *(double**)xnv;
+ return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
+ }
+ return more_xnv();
+}
+
+STATIC void
+del_xnv(XPVNV *p)
+{
+ double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
+ *(double**)xnv = PL_xnv_root;
+ PL_xnv_root = xnv;
+}
+
+STATIC XPVNV*
+more_xnv(void)
+{
+ register double* xnv;
+ register double* xnvend;
+ New(711, xnv, 1008/sizeof(double), double);
+ xnvend = &xnv[1008 / sizeof(double) - 1];
+ xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */
+ PL_xnv_root = xnv;
+ while (xnv < xnvend) {
+ *(double**)xnv = (double*)(xnv + 1);
+ xnv++;
+ }
+ *(double**)xnv = 0;
+ return new_xnv();
+}
+
+STATIC XRV*
+new_xrv(void)
+{
+ XRV* xrv;
+ if (PL_xrv_root) {
+ xrv = PL_xrv_root;
+ PL_xrv_root = (XRV*)xrv->xrv_rv;
+ return xrv;
+ }
+ return more_xrv();
+}
+
+STATIC void
+del_xrv(XRV *p)
+{
+ p->xrv_rv = (SV*)PL_xrv_root;
+ PL_xrv_root = p;
+}
+
+STATIC XRV*
+more_xrv(void)
+{
+ register XRV* xrv;
+ register XRV* xrvend;
+ New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
+ xrv = PL_xrv_root;
+ xrvend = &xrv[1008 / sizeof(XRV) - 1];
+ while (xrv < xrvend) {
+ xrv->xrv_rv = (SV*)(xrv + 1);
+ xrv++;
+ }
+ xrv->xrv_rv = 0;
+ return new_xrv();
+}
+
+STATIC XPV*
+new_xpv(void)
+{
+ XPV* xpv;
+ if (PL_xpv_root) {
+ xpv = PL_xpv_root;
+ PL_xpv_root = (XPV*)xpv->xpv_pv;
+ return xpv;
+ }
+ return more_xpv();
+}
+
+STATIC void
+del_xpv(XPV *p)
+{
+ p->xpv_pv = (char*)PL_xpv_root;
+ PL_xpv_root = p;
+}
+
+STATIC XPV*
+more_xpv(void)
+{
+ register XPV* xpv;
+ register XPV* xpvend;
+ New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
+ xpv = PL_xpv_root;
+ xpvend = &xpv[1008 / sizeof(XPV) - 1];
+ while (xpv < xpvend) {
+ xpv->xpv_pv = (char*)(xpv + 1);
+ xpv++;
+ }
+ xpv->xpv_pv = 0;
+ return new_xpv();
+}
+
+#ifdef PURIFY
+#define new_XIV() (void*)safemalloc(sizeof(XPVIV))
+#define del_XIV(p) Safefree((char*)p)
+#else
+#define new_XIV() (void*)new_xiv()
+#define del_XIV(p) del_xiv((XPVIV*) p)
+#endif
+
+#ifdef PURIFY
+#define new_XNV() (void*)safemalloc(sizeof(XPVNV))
+#define del_XNV(p) Safefree((char*)p)
+#else
+#define new_XNV() (void*)new_xnv()
+#define del_XNV(p) del_xnv((XPVNV*) p)
+#endif
+
+#ifdef PURIFY
+#define new_XRV() (void*)safemalloc(sizeof(XRV))
+#define del_XRV(p) Safefree((char*)p)
+#else
+#define new_XRV() (void*)new_xrv()
+#define del_XRV(p) del_xrv((XRV*) p)
+#endif
+
+#ifdef PURIFY
+#define new_XPV() (void*)safemalloc(sizeof(XPV))
+#define del_XPV(p) Safefree((char*)p)
+#else
+#define new_XPV() (void*)new_xpv()
+#define del_XPV(p) del_xpv((XPV *)p)
+#endif
+
+#ifdef PURIFY
+# define my_safemalloc(s) safemalloc(s)
+# define my_safefree(s) free(s)
+#else
+STATIC void*
+my_safemalloc(MEM_SIZE size)
+{
+ char *p;
+ New(717, p, size, char);
+ return (void*)p;
+}
+# define my_safefree(s) Safefree(s)
+#endif
+
+#define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
+#define del_XPVIV(p) my_safefree((char*)p)
+
+#define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
+#define del_XPVNV(p) my_safefree((char*)p)
+
+#define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
+#define del_XPVMG(p) my_safefree((char*)p)
+
+#define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
+#define del_XPVLV(p) my_safefree((char*)p)
+
+#define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
+#define del_XPVAV(p) my_safefree((char*)p)
+
+#define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
+#define del_XPVHV(p) my_safefree((char*)p)
+
+#define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
+#define del_XPVCV(p) my_safefree((char*)p)
+
+#define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
+#define del_XPVGV(p) my_safefree((char*)p)
+
+#define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
+#define del_XPVBM(p) my_safefree((char*)p)
+
+#define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
+#define del_XPVFM(p) my_safefree((char*)p)
+
+#define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
+#define del_XPVIO(p) my_safefree((char*)p)
+
+bool
+sv_upgrade(register SV *sv, U32 mt)
+{
+ char* pv;
+ U32 cur;
+ U32 len;
+ IV iv;
+ double nv;
+ MAGIC* magic;
+ HV* stash;
+
+ if (SvTYPE(sv) == mt)
+ return TRUE;
+
+ if (mt < SVt_PVIV)
+ (void)SvOOK_off(sv);
+
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ pv = 0;
+ cur = 0;
+ len = 0;
+ iv = 0;
+ nv = 0.0;
+ magic = 0;
+ stash = 0;
+ break;
+ case SVt_IV:
+ pv = 0;
+ cur = 0;
+ len = 0;
+ iv = SvIVX(sv);
+ nv = (double)SvIVX(sv);
+ del_XIV(SvANY(sv));
+ magic = 0;
+ stash = 0;
+ if (mt == SVt_NV)
+ mt = SVt_PVNV;
+ else if (mt < SVt_PVIV)
+ mt = SVt_PVIV;
+ break;
+ case SVt_NV:
+ pv = 0;
+ cur = 0;
+ len = 0;
+ nv = SvNVX(sv);
+ iv = I_32(nv);
+ magic = 0;
+ stash = 0;
+ del_XNV(SvANY(sv));
+ SvANY(sv) = 0;
+ if (mt < SVt_PVNV)
+ mt = SVt_PVNV;
+ break;
+ case SVt_RV:
+ pv = (char*)SvRV(sv);
+ cur = 0;
+ len = 0;
+ iv = (IV)pv;
+ nv = (double)(unsigned long)pv;
+ del_XRV(SvANY(sv));
+ magic = 0;
+ stash = 0;
+ break;
+ case SVt_PV:
+ pv = SvPVX(sv);
+ cur = SvCUR(sv);
+ len = SvLEN(sv);
+ iv = 0;
+ nv = 0.0;
+ magic = 0;
+ stash = 0;
+ del_XPV(SvANY(sv));
+ if (mt <= SVt_IV)
+ mt = SVt_PVIV;
+ else if (mt == SVt_NV)
+ mt = SVt_PVNV;
+ break;
+ case SVt_PVIV:
+ pv = SvPVX(sv);
+ cur = SvCUR(sv);
+ len = SvLEN(sv);
+ iv = SvIVX(sv);
+ nv = 0.0;
+ magic = 0;
+ stash = 0;
+ del_XPVIV(SvANY(sv));
+ break;
+ case SVt_PVNV:
+ pv = SvPVX(sv);
+ cur = SvCUR(sv);
+ len = SvLEN(sv);
+ iv = SvIVX(sv);
+ nv = SvNVX(sv);
+ magic = 0;
+ stash = 0;
+ del_XPVNV(SvANY(sv));
+ break;
+ case SVt_PVMG:
+ pv = SvPVX(sv);
+ cur = SvCUR(sv);
+ len = SvLEN(sv);
+ iv = SvIVX(sv);
+ nv = SvNVX(sv);
+ magic = SvMAGIC(sv);
+ stash = SvSTASH(sv);
+ del_XPVMG(SvANY(sv));
+ break;
+ default:
+ croak("Can't upgrade that kind of scalar");
+ }
+
+ switch (mt) {
+ case SVt_NULL:
+ croak("Can't upgrade to undef");
+ case SVt_IV:
+ SvANY(sv) = new_XIV();
+ SvIVX(sv) = iv;
+ break;
+ case SVt_NV:
+ SvANY(sv) = new_XNV();
+ SvNVX(sv) = nv;
+ break;
+ case SVt_RV:
+ SvANY(sv) = new_XRV();
+ SvRV(sv) = (SV*)pv;
+ break;
+ case SVt_PV:
+ SvANY(sv) = new_XPV();
+ SvPVX(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ break;
+ case SVt_PVIV:
+ SvANY(sv) = new_XPVIV();
+ SvPVX(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIVX(sv) = iv;
+ if (SvNIOK(sv))
+ (void)SvIOK_on(sv);
+ SvNOK_off(sv);
+ break;
+ case SVt_PVNV:
+ SvANY(sv) = new_XPVNV();
+ SvPVX(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIVX(sv) = iv;
+ SvNVX(sv) = nv;
+ break;
+ case SVt_PVMG:
+ SvANY(sv) = new_XPVMG();
+ SvPVX(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIVX(sv) = iv;
+ SvNVX(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ break;
+ case SVt_PVLV:
+ SvANY(sv) = new_XPVLV();
+ SvPVX(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIVX(sv) = iv;
+ SvNVX(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ LvTARGOFF(sv) = 0;
+ LvTARGLEN(sv) = 0;
+ LvTARG(sv) = 0;
+ LvTYPE(sv) = 0;
+ break;
+ case SVt_PVAV:
+ SvANY(sv) = new_XPVAV();
+ if (pv)
+ Safefree(pv);
+ SvPVX(sv) = 0;
+ AvMAX(sv) = -1;
+ AvFILLp(sv) = -1;
+ SvIVX(sv) = 0;
+ SvNVX(sv) = 0.0;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ AvALLOC(sv) = 0;
+ AvARYLEN(sv) = 0;
+ AvFLAGS(sv) = 0;
+ break;
+ case SVt_PVHV:
+ SvANY(sv) = new_XPVHV();
+ if (pv)
+ Safefree(pv);
+ SvPVX(sv) = 0;
+ HvFILL(sv) = 0;
+ HvMAX(sv) = 0;
+ HvKEYS(sv) = 0;
+ SvNVX(sv) = 0.0;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ HvRITER(sv) = 0;
+ HvEITER(sv) = 0;
+ HvPMROOT(sv) = 0;
+ HvNAME(sv) = 0;
+ break;
+ case SVt_PVCV:
+ SvANY(sv) = new_XPVCV();
+ Zero(SvANY(sv), 1, XPVCV);
+ SvPVX(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIVX(sv) = iv;
+ SvNVX(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ break;
+ case SVt_PVGV:
+ SvANY(sv) = new_XPVGV();
+ SvPVX(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIVX(sv) = iv;
+ SvNVX(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ GvGP(sv) = 0;
+ GvNAME(sv) = 0;
+ GvNAMELEN(sv) = 0;
+ GvSTASH(sv) = 0;
+ GvFLAGS(sv) = 0;
+ break;
+ case SVt_PVBM:
+ SvANY(sv) = new_XPVBM();
+ SvPVX(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIVX(sv) = iv;
+ SvNVX(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ BmRARE(sv) = 0;
+ BmUSEFUL(sv) = 0;
+ BmPREVIOUS(sv) = 0;
+ break;
+ case SVt_PVFM:
+ SvANY(sv) = new_XPVFM();
+ Zero(SvANY(sv), 1, XPVFM);
+ SvPVX(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIVX(sv) = iv;
+ SvNVX(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ break;
+ case SVt_PVIO:
+ SvANY(sv) = new_XPVIO();
+ Zero(SvANY(sv), 1, XPVIO);
+ SvPVX(sv) = pv;
+ SvCUR(sv) = cur;
+ SvLEN(sv) = len;
+ SvIVX(sv) = iv;
+ SvNVX(sv) = nv;
+ SvMAGIC(sv) = magic;
+ SvSTASH(sv) = stash;
+ IoPAGE_LEN(sv) = 60;
+ break;
+ }
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= mt;
+ return TRUE;
+}
+
+char *
+sv_peek(SV *sv)
+{
+#ifdef DEBUGGING
+ SV *t = sv_newmortal();
+ STRLEN prevlen;
+ int unref = 0;
+
+ sv_setpvn(t, "", 0);
+ retry:
+ if (!sv) {
+ sv_catpv(t, "VOID");
+ goto finish;
+ }
+ else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
+ sv_catpv(t, "WILD");
+ goto finish;
+ }
+ else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes) {
+ if (sv == &PL_sv_undef) {
+ sv_catpv(t, "SV_UNDEF");
+ if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
+ SVs_GMG|SVs_SMG|SVs_RMG)) &&
+ SvREADONLY(sv))
+ goto finish;
+ }
+ else if (sv == &PL_sv_no) {
+ sv_catpv(t, "SV_NO");
+ if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
+ SVs_GMG|SVs_SMG|SVs_RMG)) &&
+ !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
+ SVp_POK|SVp_NOK)) &&
+ SvCUR(sv) == 0 &&
+ SvNVX(sv) == 0.0)
+ goto finish;
+ }
+ else {
+ sv_catpv(t, "SV_YES");
+ if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
+ SVs_GMG|SVs_SMG|SVs_RMG)) &&
+ !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
+ SVp_POK|SVp_NOK)) &&
+ SvCUR(sv) == 1 &&
+ SvPVX(sv) && *SvPVX(sv) == '1' &&
+ SvNVX(sv) == 1.0)
+ goto finish;
+ }
+ sv_catpv(t, ":");
+ }
+ else if (SvREFCNT(sv) == 0) {
+ sv_catpv(t, "(");
+ unref++;
+ }
+ if (SvROK(sv)) {
+ sv_catpv(t, "\\");
+ if (SvCUR(t) + unref > 10) {
+ SvCUR(t) = unref + 3;
+ *SvEND(t) = '\0';
+ sv_catpv(t, "...");
+ goto finish;
+ }
+ sv = (SV*)SvRV(sv);
+ goto retry;
+ }
+ switch (SvTYPE(sv)) {
+ default:
+ sv_catpv(t, "FREED");
+ goto finish;
+
+ case SVt_NULL:
+ sv_catpv(t, "UNDEF");
+ goto finish;
+ case SVt_IV:
+ sv_catpv(t, "IV");
+ break;
+ case SVt_NV:
+ sv_catpv(t, "NV");
+ break;
+ case SVt_RV:
+ sv_catpv(t, "RV");
+ break;
+ case SVt_PV:
+ sv_catpv(t, "PV");
+ break;
+ case SVt_PVIV:
+ sv_catpv(t, "PVIV");
+ break;
+ case SVt_PVNV:
+ sv_catpv(t, "PVNV");
+ break;
+ case SVt_PVMG:
+ sv_catpv(t, "PVMG");
+ break;
+ case SVt_PVLV:
+ sv_catpv(t, "PVLV");
+ break;
+ case SVt_PVAV:
+ sv_catpv(t, "AV");
+ break;
+ case SVt_PVHV:
+ sv_catpv(t, "HV");
+ break;
+ case SVt_PVCV:
+ if (CvGV(sv))
+ sv_catpvf(t, "CV(%s)", GvNAME(CvGV(sv)));
+ else
+ sv_catpv(t, "CV()");
+ goto finish;
+ case SVt_PVGV:
+ sv_catpv(t, "GV");
+ break;
+ case SVt_PVBM:
+ sv_catpv(t, "BM");
+ break;
+ case SVt_PVFM:
+ sv_catpv(t, "FM");
+ break;
+ case SVt_PVIO:
+ sv_catpv(t, "IO");
+ break;
+ }
+
+ if (SvPOKp(sv)) {
+ if (!SvPVX(sv))
+ sv_catpv(t, "(null)");
+ if (SvOOK(sv))
+ sv_catpvf(t, "(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv));
+ else
+ sv_catpvf(t, "(\"%.127s\")",SvPVX(sv));
+ }
+ else if (SvNOKp(sv)) {
+ SET_NUMERIC_STANDARD();
+ sv_catpvf(t, "(%g)",SvNVX(sv));
+ }
+ else if (SvIOKp(sv))
+ sv_catpvf(t, "(%ld)",(long)SvIVX(sv));
+ else
+ sv_catpv(t, "()");
+
+ finish:
+ if (unref) {
+ while (unref--)
+ sv_catpv(t, ")");
+ }
+ return SvPV(t, PL_na);
+#else /* DEBUGGING */
+ return "";
+#endif /* DEBUGGING */
+}
+
+int
+sv_backoff(register SV *sv)
+{
+ assert(SvOOK(sv));
+ if (SvIVX(sv)) {
+ char *s = SvPVX(sv);
+ SvLEN(sv) += SvIVX(sv);
+ SvPVX(sv) -= SvIVX(sv);
+ SvIV_set(sv, 0);
+ Move(s, SvPVX(sv), SvCUR(sv)+1, char);
+ }
+ SvFLAGS(sv) &= ~SVf_OOK;
+ return 0;
+}
+
+char *
+#ifndef DOSISH
+sv_grow(register SV *sv, register I32 newlen)
+#else
+sv_grow(SV* sv, unsigned long newlen)
+#endif
+{
+ register char *s;
+
+#ifdef HAS_64K_LIMIT
+ if (newlen >= 0x10000) {
+ PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
+ my_exit(1);
+ }
+#endif /* HAS_64K_LIMIT */
+ if (SvROK(sv))
+ sv_unref(sv);
+ if (SvTYPE(sv) < SVt_PV) {
+ sv_upgrade(sv, SVt_PV);
+ s = SvPVX(sv);
+ }
+ else if (SvOOK(sv)) { /* pv is offset? */
+ sv_backoff(sv);
+ s = SvPVX(sv);
+ if (newlen > SvLEN(sv))
+ newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
+#ifdef HAS_64K_LIMIT
+ if (newlen >= 0x10000)
+ newlen = 0xFFFF;
+#endif
+ }
+ else
+ s = SvPVX(sv);
+ if (newlen > SvLEN(sv)) { /* need more room? */
+ if (SvLEN(sv) && s) {
+#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
+ STRLEN l = malloced_size((void*)SvPVX(sv));
+ if (newlen <= l) {
+ SvLEN_set(sv, l);
+ return s;
+ } else
+#endif
+ Renew(s,newlen,char);
+ }
+ else
+ New(703,s,newlen,char);
+ SvPV_set(sv, s);
+ SvLEN_set(sv, newlen);
+ }
+ return s;
+}
+
+void
+sv_setiv(register SV *sv, IV i)
+{
+ SV_CHECK_THINKFIRST(sv);
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ sv_upgrade(sv, SVt_IV);
+ break;
+ case SVt_NV:
+ sv_upgrade(sv, SVt_PVNV);
+ break;
+ case SVt_RV:
+ case SVt_PV:
+ sv_upgrade(sv, SVt_PVIV);
+ break;
+
+ case SVt_PVGV:
+ if (SvFAKE(sv)) {
+ sv_unglob(sv);
+ break;
+ }
+ /* FALL THROUGH */
+ case SVt_PVAV:
+ case SVt_PVHV:
+ case SVt_PVCV:
+ case SVt_PVFM:
+ case SVt_PVIO:
+ {
+ dTHR;
+ croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
+ op_desc[PL_op->op_type]);
+ }
+ }
+ (void)SvIOK_only(sv); /* validate number */
+ SvIVX(sv) = i;
+ SvTAINT(sv);
+}
+
+void
+sv_setiv_mg(register SV *sv, IV i)
+{
+ sv_setiv(sv,i);
+ SvSETMAGIC(sv);
+}
+
+void
+sv_setuv(register SV *sv, UV u)
+{
+ if (u <= IV_MAX)
+ sv_setiv(sv, u);
+ else
+ sv_setnv(sv, (double)u);
+}
+
+void
+sv_setuv_mg(register SV *sv, UV u)
+{
+ sv_setuv(sv,u);
+ SvSETMAGIC(sv);
+}
+
+void
+sv_setnv(register SV *sv, double num)
+{
+ SV_CHECK_THINKFIRST(sv);
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ case SVt_IV:
+ sv_upgrade(sv, SVt_NV);
+ break;
+ case SVt_RV:
+ case SVt_PV:
+ case SVt_PVIV:
+ sv_upgrade(sv, SVt_PVNV);
+ break;
+
+ case SVt_PVGV:
+ if (SvFAKE(sv)) {
+ sv_unglob(sv);
+ break;
+ }
+ /* FALL THROUGH */
+ case SVt_PVAV:
+ case SVt_PVHV:
+ case SVt_PVCV:
+ case SVt_PVFM:
+ case SVt_PVIO:
+ {
+ dTHR;
+ croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
+ op_name[PL_op->op_type]);
+ }
+ }
+ SvNVX(sv) = num;
+ (void)SvNOK_only(sv); /* validate number */
+ SvTAINT(sv);
+}
+
+void
+sv_setnv_mg(register SV *sv, double num)
+{
+ sv_setnv(sv,num);
+ SvSETMAGIC(sv);
+}
+
+STATIC void
+not_a_number(SV *sv)
+{
+ dTHR;
+ char tmpbuf[64];
+ char *d = tmpbuf;
+ char *s;
+ char *limit = tmpbuf + sizeof(tmpbuf) - 8;
+ /* each *s can expand to 4 chars + "...\0",
+ i.e. need room for 8 chars */
+
+ for (s = SvPVX(sv); *s && d < limit; s++) {
+ int ch = *s & 0xFF;
+ if (ch & 128 && !isPRINT_LC(ch)) {
+ *d++ = 'M';
+ *d++ = '-';
+ ch &= 127;
+ }
+ if (ch == '\n') {
+ *d++ = '\\';
+ *d++ = 'n';
+ }
+ else if (ch == '\r') {
+ *d++ = '\\';
+ *d++ = 'r';
+ }
+ else if (ch == '\f') {
+ *d++ = '\\';
+ *d++ = 'f';
+ }
+ else if (ch == '\\') {
+ *d++ = '\\';
+ *d++ = '\\';
+ }
+ else if (isPRINT_LC(ch))
+ *d++ = ch;
+ else {
+ *d++ = '^';
+ *d++ = toCTRL(ch);
+ }
+ }
+ if (*s) {
+ *d++ = '.';
+ *d++ = '.';
+ *d++ = '.';
+ }
+ *d = '\0';
+
+ if (PL_op)
+ warn("Argument \"%s\" isn't numeric in %s", tmpbuf,
+ op_name[PL_op->op_type]);
+ else
+ warn("Argument \"%s\" isn't numeric", tmpbuf);
+}
+
+IV
+sv_2iv(register SV *sv)
+{
+ if (!sv)
+ return 0;
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvIOKp(sv))
+ return SvIVX(sv);
+ if (SvNOKp(sv)) {
+ if (SvNVX(sv) < 0.0)
+ return I_V(SvNVX(sv));
+ else
+ return (IV) U_V(SvNVX(sv));
+ }
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asIV(sv);
+ if (!SvROK(sv)) {
+ if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ dTHR;
+ if (!PL_localizing)
+ warn(warn_uninit);
+ }
+ return 0;
+ }
+ }
+ if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+#ifdef OVERLOAD
+ SV* tmpstr;
+ if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
+ return SvIV(tmpstr);
+#endif /* OVERLOAD */
+ return (IV)SvRV(sv);
+ }
+ if (SvREADONLY(sv)) {
+ if (SvNOKp(sv)) {
+ if (SvNVX(sv) < 0.0)
+ return I_V(SvNVX(sv));
+ else
+ return (IV) U_V(SvNVX(sv));
+ }
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asIV(sv);
+ if (PL_dowarn)
+ warn(warn_uninit);
+ return 0;
+ }
+ }
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ sv_upgrade(sv, SVt_IV);
+ break;
+ case SVt_PV:
+ sv_upgrade(sv, SVt_PVIV);
+ break;
+ case SVt_NV:
+ sv_upgrade(sv, SVt_PVNV);
+ break;
+ }
+ if (SvNOKp(sv)) {
+ (void)SvIOK_on(sv);
+ if (SvNVX(sv) < 0.0)
+ SvIVX(sv) = I_V(SvNVX(sv));
+ else
+ SvUVX(sv) = U_V(SvNVX(sv));
+ }
+ else if (SvPOKp(sv) && SvLEN(sv)) {
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = asIV(sv);
+ }
+ else {
+ dTHR;
+ if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warn(warn_uninit);
+ return 0;
+ }
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
+ (unsigned long)sv,(long)SvIVX(sv)));
+ return SvIVX(sv);
+}
+
+UV
+sv_2uv(register SV *sv)
+{
+ if (!sv)
+ return 0;
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvIOKp(sv))
+ return SvUVX(sv);
+ if (SvNOKp(sv))
+ return U_V(SvNVX(sv));
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asUV(sv);
+ if (!SvROK(sv)) {
+ if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ dTHR;
+ if (!PL_localizing)
+ warn(warn_uninit);
+ }
+ return 0;
+ }
+ }
+ if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+#ifdef OVERLOAD
+ SV* tmpstr;
+ if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
+ return SvUV(tmpstr);
+#endif /* OVERLOAD */
+ return (UV)SvRV(sv);
+ }
+ if (SvREADONLY(sv)) {
+ if (SvNOKp(sv)) {
+ return U_V(SvNVX(sv));
+ }
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asUV(sv);
+ if (PL_dowarn)
+ warn(warn_uninit);
+ return 0;
+ }
+ }
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ sv_upgrade(sv, SVt_IV);
+ break;
+ case SVt_PV:
+ sv_upgrade(sv, SVt_PVIV);
+ break;
+ case SVt_NV:
+ sv_upgrade(sv, SVt_PVNV);
+ break;
+ }
+ if (SvNOKp(sv)) {
+ (void)SvIOK_on(sv);
+ SvUVX(sv) = U_V(SvNVX(sv));
+ }
+ else if (SvPOKp(sv) && SvLEN(sv)) {
+ (void)SvIOK_on(sv);
+ SvUVX(sv) = asUV(sv);
+ }
+ else {
+ if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ dTHR;
+ if (!PL_localizing)
+ warn(warn_uninit);
+ }
+ return 0;
+ }
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
+ (unsigned long)sv,SvUVX(sv)));
+ return SvUVX(sv);
+}
+
+double
+sv_2nv(register SV *sv)
+{
+ if (!sv)
+ return 0.0;
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvNOKp(sv))
+ return SvNVX(sv);
+ if (SvPOKp(sv) && SvLEN(sv)) {
+ if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv))
+ not_a_number(sv);
+ SET_NUMERIC_STANDARD();
+ return atof(SvPVX(sv));
+ }
+ if (SvIOKp(sv))
+ return (double)SvIVX(sv);
+ if (!SvROK(sv)) {
+ if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ dTHR;
+ if (!PL_localizing)
+ warn(warn_uninit);
+ }
+ return 0;
+ }
+ }
+ if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+#ifdef OVERLOAD
+ SV* tmpstr;
+ if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
+ return SvNV(tmpstr);
+#endif /* OVERLOAD */
+ return (double)(unsigned long)SvRV(sv);
+ }
+ if (SvREADONLY(sv)) {
+ if (SvPOKp(sv) && SvLEN(sv)) {
+ if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv))
+ not_a_number(sv);
+ SET_NUMERIC_STANDARD();
+ return atof(SvPVX(sv));
+ }
+ if (SvIOKp(sv))
+ return (double)SvIVX(sv);
+ if (PL_dowarn)
+ warn(warn_uninit);
+ return 0.0;
+ }
+ }
+ if (SvTYPE(sv) < SVt_NV) {
+ if (SvTYPE(sv) == SVt_IV)
+ sv_upgrade(sv, SVt_PVNV);
+ else
+ sv_upgrade(sv, SVt_NV);
+ DEBUG_c(SET_NUMERIC_STANDARD());
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
+ }
+ else if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ if (SvIOKp(sv) &&
+ (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
+ {
+ SvNVX(sv) = (double)SvIVX(sv);
+ }
+ else if (SvPOKp(sv) && SvLEN(sv)) {
+ if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv))
+ not_a_number(sv);
+ SET_NUMERIC_STANDARD();
+ SvNVX(sv) = atof(SvPVX(sv));
+ }
+ else {
+ dTHR;
+ if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warn(warn_uninit);
+ return 0.0;
+ }
+ SvNOK_on(sv);
+ DEBUG_c(SET_NUMERIC_STANDARD());
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
+ return SvNVX(sv);
+}
+
+STATIC IV
+asIV(SV *sv)
+{
+ I32 numtype = looks_like_number(sv);
+ double d;
+
+ if (numtype == 1)
+ return atol(SvPVX(sv));
+ if (!numtype && PL_dowarn)
+ not_a_number(sv);
+ SET_NUMERIC_STANDARD();
+ d = atof(SvPVX(sv));
+ if (d < 0.0)
+ return I_V(d);
+ else
+ return (IV) U_V(d);
+}
+
+STATIC UV
+asUV(SV *sv)
+{
+ I32 numtype = looks_like_number(sv);
+
+#ifdef HAS_STRTOUL
+ if (numtype == 1)
+ return strtoul(SvPVX(sv), Null(char**), 10);
+#endif
+ if (!numtype && PL_dowarn)
+ not_a_number(sv);
+ SET_NUMERIC_STANDARD();
+ return U_V(atof(SvPVX(sv)));
+}
+
+I32
+looks_like_number(SV *sv)
+{
+ register char *s;
+ register char *send;
+ register char *sbegin;
+ I32 numtype;
+ STRLEN len;
+
+ if (SvPOK(sv)) {
+ sbegin = SvPVX(sv);
+ len = SvCUR(sv);
+ }
+ else if (SvPOKp(sv))
+ sbegin = SvPV(sv, len);
+ else
+ return 1;
+ send = sbegin + len;
+
+ s = sbegin;
+ while (isSPACE(*s))
+ s++;
+ if (*s == '+' || *s == '-')
+ s++;
+
+ /* next must be digit or '.' */
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ if (*s == '.') {
+ s++;
+ while (isDIGIT(*s)) /* optional digits after "." */
+ s++;
+ }
+ }
+ else if (*s == '.') {
+ s++;
+ /* no digits before '.' means we need digits after it */
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ else
+ return 0;
+
+ /*
+ * we return 1 if the number can be converted to _integer_ with atol()
+ * and 2 if you need (int)atof().
+ */
+ numtype = 1;
+
+ /* we can have an optional exponent part */
+ if (*s == 'e' || *s == 'E') {
+ numtype = 2;
+ s++;
+ if (*s == '+' || *s == '-')
+ s++;
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ while (isSPACE(*s))
+ s++;
+ if (s >= send)
+ return numtype;
+ if (len == 10 && memEQ(sbegin, "0 but true", 10))
+ return 1;
+ return 0;
+}
+
+char *
+sv_2pv(register SV *sv, STRLEN *lp)
+{
+ register char *s;
+ int olderrno;
+ SV *tsv;
+ char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
+
+ if (!sv) {
+ *lp = 0;
+ return "";
+ }
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvPOKp(sv)) {
+ *lp = SvCUR(sv);
+ return SvPVX(sv);
+ }
+ if (SvIOKp(sv)) {
+ (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
+ tsv = Nullsv;
+ goto tokensave;
+ }
+ if (SvNOKp(sv)) {
+ SET_NUMERIC_STANDARD();
+ Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
+ tsv = Nullsv;
+ goto tokensave;
+ }
+ if (!SvROK(sv)) {
+ if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ dTHR;
+ if (!PL_localizing)
+ warn(warn_uninit);
+ }
+ *lp = 0;
+ return "";
+ }
+ }
+ if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+#ifdef OVERLOAD
+ SV* tmpstr;
+ if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
+ return SvPV(tmpstr,*lp);
+#endif /* OVERLOAD */
+ sv = (SV*)SvRV(sv);
+ if (!sv)
+ s = "NULLREF";
+ else {
+ MAGIC *mg;
+
+ switch (SvTYPE(sv)) {
+ case SVt_PVMG:
+ if ( ((SvFLAGS(sv) &
+ (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
+ == (SVs_OBJECT|SVs_RMG))
+ && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
+ && (mg = mg_find(sv, 'r'))) {
+ dTHR;
+ regexp *re = (regexp *)mg->mg_obj;
+
+ if (!mg->mg_ptr) {
+ char *fptr = "msix";
+ char reflags[6];
+ char ch;
+ int left = 0;
+ int right = 4;
+ U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
+
+ while(ch = *fptr++) {
+ if(reganch & 1) {
+ reflags[left++] = ch;
+ }
+ else {
+ reflags[right--] = ch;
+ }
+ reganch >>= 1;
+ }
+ if(left != 4) {
+ reflags[left] = '-';
+ left = 5;
+ }
+
+ mg->mg_len = re->prelen + 4 + left;
+ New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
+ Copy("(?", mg->mg_ptr, 2, char);
+ Copy(reflags, mg->mg_ptr+2, left, char);
+ Copy(":", mg->mg_ptr+left+2, 1, char);
+ Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
+ mg->mg_ptr[mg->mg_len - 1] = ')';
+ mg->mg_ptr[mg->mg_len] = 0;
+ }
+ PL_reginterp_cnt += re->program[0].next_off;
+ *lp = mg->mg_len;
+ return mg->mg_ptr;
+ }
+ /* Fall through */
+ case SVt_NULL:
+ case SVt_IV:
+ case SVt_NV:
+ case SVt_RV:
+ case SVt_PV:
+ case SVt_PVIV:
+ case SVt_PVNV:
+ case SVt_PVBM: s = "SCALAR"; break;
+ case SVt_PVLV: s = "LVALUE"; break;
+ case SVt_PVAV: s = "ARRAY"; break;
+ case SVt_PVHV: s = "HASH"; break;
+ case SVt_PVCV: s = "CODE"; break;
+ case SVt_PVGV: s = "GLOB"; break;
+ case SVt_PVFM: s = "FORMAT"; break;
+ case SVt_PVIO: s = "IO"; break;
+ default: s = "UNKNOWN"; break;
+ }
+ tsv = NEWSV(0,0);
+ if (SvOBJECT(sv))
+ sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
+ else
+ sv_setpv(tsv, s);
+ sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
+ goto tokensaveref;
+ }
+ *lp = strlen(s);
+ return s;
+ }
+ if (SvREADONLY(sv)) {
+ if (SvNOKp(sv)) {
+ SET_NUMERIC_STANDARD();
+ Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
+ tsv = Nullsv;
+ goto tokensave;
+ }
+ if (SvIOKp(sv)) {
+ (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
+ tsv = Nullsv;
+ goto tokensave;
+ }
+ if (PL_dowarn)
+ warn(warn_uninit);
+ *lp = 0;
+ return "";
+ }
+ }
+ (void)SvUPGRADE(sv, SVt_PV);
+ if (SvNOKp(sv)) {
+ if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ SvGROW(sv, 28);
+ s = SvPVX(sv);
+ olderrno = errno; /* some Xenix systems wipe out errno here */
+#ifdef apollo
+ if (SvNVX(sv) == 0.0)
+ (void)strcpy(s,"0");
+ else
+#endif /*apollo*/
+ {
+ SET_NUMERIC_STANDARD();
+ Gconvert(SvNVX(sv), DBL_DIG, 0, s);
+ }
+ errno = olderrno;
+#ifdef FIXNEGATIVEZERO
+ if (*s == '-' && s[1] == '0' && !s[2])
+ strcpy(s,"0");
+#endif
+ while (*s) s++;
+#ifdef hcx
+ if (s[-1] == '.')
+ *--s = '\0';
+#endif
+ }
+ else if (SvIOKp(sv)) {
+ U32 oldIOK = SvIOK(sv);
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ olderrno = errno; /* some Xenix systems wipe out errno here */
+ sv_setpviv(sv, SvIVX(sv));
+ errno = olderrno;
+ s = SvEND(sv);
+ if (oldIOK)
+ SvIOK_on(sv);
+ else
+ SvIOKp_on(sv);
+ }
+ else {
+ dTHR;
+ if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warn(warn_uninit);
+ *lp = 0;
+ return "";
+ }
+ *lp = s - SvPVX(sv);
+ SvCUR_set(sv, *lp);
+ SvPOK_on(sv);
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
+ return SvPVX(sv);
+
+ tokensave:
+ if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
+ /* Sneaky stuff here */
+
+ tokensaveref:
+ if (!tsv)
+ tsv = newSVpv(tmpbuf, 0);
+ sv_2mortal(tsv);
+ *lp = SvCUR(tsv);
+ return SvPVX(tsv);
+ }
+ else {
+ STRLEN len;
+ char *t;
+
+ if (tsv) {
+ sv_2mortal(tsv);
+ t = SvPVX(tsv);
+ len = SvCUR(tsv);
+ }
+ else {
+ t = tmpbuf;
+ len = strlen(tmpbuf);
+ }
+#ifdef FIXNEGATIVEZERO
+ if (len == 2 && t[0] == '-' && t[1] == '0') {
+ t = "0";
+ len = 1;
+ }
+#endif
+ (void)SvUPGRADE(sv, SVt_PV);
+ *lp = len;
+ s = SvGROW(sv, len + 1);
+ SvCUR_set(sv, len);
+ (void)strcpy(s, t);
+ SvPOKp_on(sv);
+ return s;
+ }
+}
+
+/* This function is only called on magical items */
+bool
+sv_2bool(register SV *sv)
+{
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+
+ if (!SvOK(sv))
+ return 0;
+ if (SvROK(sv)) {
+#ifdef OVERLOAD
+ {
+ dTHR;
+ SV* tmpsv;
+ if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
+ return SvTRUE(tmpsv);
+ }
+#endif /* OVERLOAD */
+ return SvRV(sv) != 0;
+ }
+ if (SvPOKp(sv)) {
+ register XPV* Xpvtmp;
+ if ((Xpvtmp = (XPV*)SvANY(sv)) &&
+ (*Xpvtmp->xpv_pv > '0' ||
+ Xpvtmp->xpv_cur > 1 ||
+ (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
+ return 1;
+ else
+ return 0;
+ }
+ else {
+ if (SvIOKp(sv))
+ return SvIVX(sv) != 0;
+ else {
+ if (SvNOKp(sv))
+ return SvNVX(sv) != 0.0;
+ else
+ return FALSE;
+ }
+ }
+}
+
+/* Note: sv_setsv() should not be called with a source string that needs
+ * to be reused, since it may destroy the source string if it is marked
+ * as temporary.
+ */
+
+void
+sv_setsv(SV *dstr, register SV *sstr)
+{
+ dTHR;
+ register U32 sflags;
+ register int dtype;
+ register int stype;
+
+ if (sstr == dstr)
+ return;
+ SV_CHECK_THINKFIRST(dstr);
+ if (!sstr)
+ sstr = &PL_sv_undef;
+ stype = SvTYPE(sstr);
+ dtype = SvTYPE(dstr);
+
+ if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) {
+ sv_unglob(dstr); /* so fake GLOB won't perpetuate */
+ sv_setpvn(dstr, "", 0);
+ (void)SvPOK_only(dstr);
+ dtype = SvTYPE(dstr);
+ }
+
+#ifdef OVERLOAD
+ SvAMAGIC_off(dstr);
+#endif /* OVERLOAD */
+ /* There's a lot of redundancy below but we're going for speed here */
+
+ switch (stype) {
+ case SVt_NULL:
+ undef_sstr:
+ if (dtype != SVt_PVGV) {
+ (void)SvOK_off(dstr);
+ return;
+ }
+ break;
+ case SVt_IV:
+ if (SvIOK(sstr)) {
+ switch (dtype) {
+ case SVt_NULL:
+ sv_upgrade(dstr, SVt_IV);
+ break;
+ case SVt_NV:
+ sv_upgrade(dstr, SVt_PVNV);
+ break;
+ case SVt_RV:
+ case SVt_PV:
+ sv_upgrade(dstr, SVt_PVIV);
+ break;
+ }
+ (void)SvIOK_only(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
+ SvTAINT(dstr);
+ return;
+ }
+ goto undef_sstr;
+
+ case SVt_NV:
+ if (SvNOK(sstr)) {
+ switch (dtype) {
+ case SVt_NULL:
+ case SVt_IV:
+ sv_upgrade(dstr, SVt_NV);
+ break;
+ case SVt_RV:
+ case SVt_PV:
+ case SVt_PVIV:
+ sv_upgrade(dstr, SVt_PVNV);
+ break;
+ }
+ SvNVX(dstr) = SvNVX(sstr);
+ (void)SvNOK_only(dstr);
+ SvTAINT(dstr);
+ return;
+ }
+ goto undef_sstr;
+
+ case SVt_RV:
+ if (dtype < SVt_RV)
+ sv_upgrade(dstr, SVt_RV);
+ else if (dtype == SVt_PVGV &&
+ SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ sstr = SvRV(sstr);
+ if (sstr == dstr) {
+ if (PL_curcop->cop_stash != GvSTASH(dstr))
+ GvIMPORTED_on(dstr);
+ GvMULTI_on(dstr);
+ return;
+ }
+ goto glob_assign;
+ }
+ break;
+ case SVt_PV:
+ case SVt_PVFM:
+ if (dtype < SVt_PV)
+ sv_upgrade(dstr, SVt_PV);
+ break;
+ case SVt_PVIV:
+ if (dtype < SVt_PVIV)
+ sv_upgrade(dstr, SVt_PVIV);
+ break;
+ case SVt_PVNV:
+ if (dtype < SVt_PVNV)
+ sv_upgrade(dstr, SVt_PVNV);
+ break;
+ case SVt_PVAV:
+ case SVt_PVHV:
+ case SVt_PVCV:
+ case SVt_PVIO:
+ if (PL_op)
+ croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
+ op_name[PL_op->op_type]);
+ else
+ croak("Bizarre copy of %s", sv_reftype(sstr, 0));
+ break;
+
+ case SVt_PVGV:
+ if (dtype <= SVt_PVGV) {
+ glob_assign:
+ if (dtype != SVt_PVGV) {
+ char *name = GvNAME(sstr);
+ STRLEN len = GvNAMELEN(sstr);
+ sv_upgrade(dstr, SVt_PVGV);
+ sv_magic(dstr, dstr, '*', name, len);
+ GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
+ GvNAME(dstr) = savepvn(name, len);
+ GvNAMELEN(dstr) = len;
+ SvFAKE_on(dstr); /* can coerce to non-glob */
+ }
+ /* ahem, death to those who redefine active sort subs */
+ else if (PL_curstackinfo->si_type == PERLSI_SORT
+ && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
+ croak("Can't redefine active sort subroutine %s",
+ GvNAME(dstr));
+ (void)SvOK_off(dstr);
+ GvINTRO_off(dstr); /* one-shot flag */
+ gp_free((GV*)dstr);
+ GvGP(dstr) = gp_ref(GvGP(sstr));
+ SvTAINT(dstr);
+ if (PL_curcop->cop_stash != GvSTASH(dstr))
+ GvIMPORTED_on(dstr);
+ GvMULTI_on(dstr);
+ return;
+ }
+ /* FALL THROUGH */
+
+ default:
+ if (SvGMAGICAL(sstr)) {
+ mg_get(sstr);
+ if (SvTYPE(sstr) != stype) {
+ stype = SvTYPE(sstr);
+ if (stype == SVt_PVGV && dtype <= SVt_PVGV)
+ goto glob_assign;
+ }
+ }
+ if (stype == SVt_PVLV)
+ SvUPGRADE(dstr, SVt_PVNV);
+ else
+ SvUPGRADE(dstr, stype);
+ }
+
+ sflags = SvFLAGS(sstr);
+
+ if (sflags & SVf_ROK) {
+ if (dtype >= SVt_PV) {
+ if (dtype == SVt_PVGV) {
+ SV *sref = SvREFCNT_inc(SvRV(sstr));
+ SV *dref = 0;
+ int intro = GvINTRO(dstr);
+
+ if (intro) {
+ GP *gp;
+ GvGP(dstr)->gp_refcnt--;
+ GvINTRO_off(dstr); /* one-shot flag */
+ Newz(602,gp, 1, GP);
+ GvGP(dstr) = gp_ref(gp);
+ GvSV(dstr) = NEWSV(72,0);
+ GvLINE(dstr) = PL_curcop->cop_line;
+ GvEGV(dstr) = (GV*)dstr;
+ }
+ GvMULTI_on(dstr);
+ switch (SvTYPE(sref)) {
+ case SVt_PVAV:
+ if (intro)
+ SAVESPTR(GvAV(dstr));
+ else
+ dref = (SV*)GvAV(dstr);
+ GvAV(dstr) = (AV*)sref;
+ if (PL_curcop->cop_stash != GvSTASH(dstr))
+ GvIMPORTED_AV_on(dstr);
+ break;
+ case SVt_PVHV:
+ if (intro)
+ SAVESPTR(GvHV(dstr));
+ else
+ dref = (SV*)GvHV(dstr);
+ GvHV(dstr) = (HV*)sref;
+ if (PL_curcop->cop_stash != GvSTASH(dstr))
+ GvIMPORTED_HV_on(dstr);
+ break;
+ case SVt_PVCV:
+ if (intro) {
+ if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
+ SvREFCNT_dec(GvCV(dstr));
+ GvCV(dstr) = Nullcv;
+ GvCVGEN(dstr) = 0; /* Switch off cacheness. */
+ PL_sub_generation++;
+ }
+ SAVESPTR(GvCV(dstr));
+ }
+ else
+ dref = (SV*)GvCV(dstr);
+ if (GvCV(dstr) != (CV*)sref) {
+ CV* cv = GvCV(dstr);
+ if (cv) {
+ if (!GvCVGEN((GV*)dstr) &&
+ (CvROOT(cv) || CvXSUB(cv)))
+ {
+ SV *const_sv = cv_const_sv(cv);
+ bool const_changed = TRUE;
+ if(const_sv)
+ const_changed = sv_cmp(const_sv,
+ op_const_sv(CvSTART((CV*)sref),
+ Nullcv));
+ /* ahem, death to those who redefine
+ * active sort subs */
+ if (PL_curstackinfo->si_type == PERLSI_SORT &&
+ PL_sortcop == CvSTART(cv))
+ croak(
+ "Can't redefine active sort subroutine %s",
+ GvENAME((GV*)dstr));
+ if (PL_dowarn || (const_changed && const_sv)) {
+ if (!(CvGV(cv) && GvSTASH(CvGV(cv))
+ && HvNAME(GvSTASH(CvGV(cv)))
+ && strEQ(HvNAME(GvSTASH(CvGV(cv))),
+ "autouse")))
+ warn(const_sv ?
+ "Constant subroutine %s redefined"
+ : "Subroutine %s redefined",
+ GvENAME((GV*)dstr));
+ }
+ }
+ cv_ckproto(cv, (GV*)dstr,
+ SvPOK(sref) ? SvPVX(sref) : Nullch);
+ }
+ GvCV(dstr) = (CV*)sref;
+ GvCVGEN(dstr) = 0; /* Switch off cacheness. */
+ GvASSUMECV_on(dstr);
+ PL_sub_generation++;
+ }
+ if (PL_curcop->cop_stash != GvSTASH(dstr))
+ GvIMPORTED_CV_on(dstr);
+ break;
+ case SVt_PVIO:
+ if (intro)
+ SAVESPTR(GvIOp(dstr));
+ else
+ dref = (SV*)GvIOp(dstr);
+ GvIOp(dstr) = (IO*)sref;
+ break;
+ default:
+ if (intro)
+ SAVESPTR(GvSV(dstr));
+ else
+ dref = (SV*)GvSV(dstr);
+ GvSV(dstr) = sref;
+ if (PL_curcop->cop_stash != GvSTASH(dstr))
+ GvIMPORTED_SV_on(dstr);
+ break;
+ }
+ if (dref)
+ SvREFCNT_dec(dref);
+ if (intro)
+ SAVEFREESV(sref);
+ SvTAINT(dstr);
+ return;
+ }
+ if (SvPVX(dstr)) {
+ (void)SvOOK_off(dstr); /* backoff */
+ Safefree(SvPVX(dstr));
+ SvLEN(dstr)=SvCUR(dstr)=0;
+ }
+ }
+ (void)SvOK_off(dstr);
+ SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
+ SvROK_on(dstr);
+ if (sflags & SVp_NOK) {
+ SvNOK_on(dstr);
+ SvNVX(dstr) = SvNVX(sstr);
+ }
+ if (sflags & SVp_IOK) {
+ (void)SvIOK_on(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
+ }
+#ifdef OVERLOAD
+ if (SvAMAGIC(sstr)) {
+ SvAMAGIC_on(dstr);
+ }
+#endif /* OVERLOAD */
+ }
+ else if (sflags & SVp_POK) {
+
+ /*
+ * Check to see if we can just swipe the string. If so, it's a
+ * possible small lose on short strings, but a big win on long ones.
+ * It might even be a win on short strings if SvPVX(dstr)
+ * has to be allocated and SvPVX(sstr) has to be freed.
+ */
+
+ if (SvTEMP(sstr) && /* slated for free anyway? */
+ SvREFCNT(sstr) == 1 && /* and no other references to it? */
+ !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
+ {
+ if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
+ if (SvOOK(dstr)) {
+ SvFLAGS(dstr) &= ~SVf_OOK;
+ Safefree(SvPVX(dstr) - SvIVX(dstr));
+ }
+ else
+ Safefree(SvPVX(dstr));
+ }
+ (void)SvPOK_only(dstr);
+ SvPV_set(dstr, SvPVX(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvCUR_set(dstr, SvCUR(sstr));
+ SvTEMP_off(dstr);
+ (void)SvOK_off(sstr);
+ SvPV_set(sstr, Nullch);
+ SvLEN_set(sstr, 0);
+ SvCUR_set(sstr, 0);
+ SvTEMP_off(sstr);
+ }
+ else { /* have to copy actual string */
+ STRLEN len = SvCUR(sstr);
+
+ SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
+ Move(SvPVX(sstr),SvPVX(dstr),len,char);
+ SvCUR_set(dstr, len);
+ *SvEND(dstr) = '\0';
+ (void)SvPOK_only(dstr);
+ }
+ /*SUPPRESS 560*/
+ if (sflags & SVp_NOK) {
+ SvNOK_on(dstr);
+ SvNVX(dstr) = SvNVX(sstr);
+ }
+ if (sflags & SVp_IOK) {
+ (void)SvIOK_on(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
+ }
+ }
+ else if (sflags & SVp_NOK) {
+ SvNVX(dstr) = SvNVX(sstr);
+ (void)SvNOK_only(dstr);
+ if (SvIOK(sstr)) {
+ (void)SvIOK_on(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
+ }
+ }
+ else if (sflags & SVp_IOK) {
+ (void)SvIOK_only(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
+ }
+ else {
+ if (dtype == SVt_PVGV) {
+ if (PL_dowarn)
+ warn("Undefined value assigned to typeglob");
+ }
+ else
+ (void)SvOK_off(dstr);
+ }
+ SvTAINT(dstr);
+}
+
+void
+sv_setsv_mg(SV *dstr, register SV *sstr)
+{
+ sv_setsv(dstr,sstr);
+ SvSETMAGIC(dstr);
+}
+
+void
+sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len)
+{
+ register char *dptr;
+ assert(len >= 0); /* STRLEN is probably unsigned, so this may
+ elicit a warning, but it won't hurt. */
+ SV_CHECK_THINKFIRST(sv);
+ if (!ptr) {
+ (void)SvOK_off(sv);
+ return;
+ }
+ if (SvTYPE(sv) >= SVt_PV) {
+ if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
+ sv_unglob(sv);
+ }
+ else
+ sv_upgrade(sv, SVt_PV);
+
+ SvGROW(sv, len + 1);
+ dptr = SvPVX(sv);
+ Move(ptr,dptr,len,char);
+ dptr[len] = '\0';
+ SvCUR_set(sv, len);
+ (void)SvPOK_only(sv); /* validate pointer */
+ SvTAINT(sv);
+}
+
+void
+sv_setpvn_mg(register SV *sv, register const char *ptr, register STRLEN len)
+{
+ sv_setpvn(sv,ptr,len);
+ SvSETMAGIC(sv);
+}
+
+void
+sv_setpv(register SV *sv, register const char *ptr)
+{
+ register STRLEN len;
+
+ SV_CHECK_THINKFIRST(sv);
+ if (!ptr) {
+ (void)SvOK_off(sv);
+ return;
+ }
+ len = strlen(ptr);
+ if (SvTYPE(sv) >= SVt_PV) {
+ if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
+ sv_unglob(sv);
+ }
+ else
+ sv_upgrade(sv, SVt_PV);
+
+ SvGROW(sv, len + 1);
+ Move(ptr,SvPVX(sv),len+1,char);
+ SvCUR_set(sv, len);
+ (void)SvPOK_only(sv); /* validate pointer */
+ SvTAINT(sv);
+}
+
+void
+sv_setpv_mg(register SV *sv, register const char *ptr)
+{
+ sv_setpv(sv,ptr);
+ SvSETMAGIC(sv);
+}
+
+void
+sv_usepvn(register SV *sv, register char *ptr, register STRLEN len)
+{
+ SV_CHECK_THINKFIRST(sv);
+ (void)SvUPGRADE(sv, SVt_PV);
+ if (!ptr) {
+ (void)SvOK_off(sv);
+ return;
+ }
+ if (SvPVX(sv))
+ Safefree(SvPVX(sv));
+ Renew(ptr, len+1, char);
+ SvPVX(sv) = ptr;
+ SvCUR_set(sv, len);
+ SvLEN_set(sv, len+1);
+ *SvEND(sv) = '\0';
+ (void)SvPOK_only(sv); /* validate pointer */
+ SvTAINT(sv);
+}
+
+void
+sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len)
+{
+ sv_usepvn(sv,ptr,len);
+ SvSETMAGIC(sv);
+}
+
+STATIC void
+sv_check_thinkfirst(register SV *sv)
+{
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (PL_curcop != &PL_compiling)
+ croak(no_modify);
+ }
+ if (SvROK(sv))
+ sv_unref(sv);
+}
+
+void
+sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
+
+
+{
+ register STRLEN delta;
+
+ if (!ptr || !SvPOKp(sv))
+ return;
+ SV_CHECK_THINKFIRST(sv);
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv,SVt_PVIV);
+
+ if (!SvOOK(sv)) {
+ SvIVX(sv) = 0;
+ SvFLAGS(sv) |= SVf_OOK;
+ }
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK);
+ delta = ptr - SvPVX(sv);
+ SvLEN(sv) -= delta;
+ SvCUR(sv) -= delta;
+ SvPVX(sv) += delta;
+ SvIVX(sv) += delta;
+}
+
+void
+sv_catpvn(register SV *sv, register char *ptr, register STRLEN len)
+{
+ STRLEN tlen;
+ char *junk;
+
+ junk = SvPV_force(sv, tlen);
+ SvGROW(sv, tlen + len + 1);
+ if (ptr == junk)
+ ptr = SvPVX(sv);
+ Move(ptr,SvPVX(sv)+tlen,len,char);
+ SvCUR(sv) += len;
+ *SvEND(sv) = '\0';
+ (void)SvPOK_only(sv); /* validate pointer */
+ SvTAINT(sv);
+}
+
+void
+sv_catpvn_mg(register SV *sv, register char *ptr, register STRLEN len)
+{
+ sv_catpvn(sv,ptr,len);
+ SvSETMAGIC(sv);
+}
+
+void
+sv_catsv(SV *dstr, register SV *sstr)
+{
+ char *s;
+ STRLEN len;
+ if (!sstr)
+ return;
+ if (s = SvPV(sstr, len))
+ sv_catpvn(dstr,s,len);
+}
+
+void
+sv_catsv_mg(SV *dstr, register SV *sstr)
+{
+ sv_catsv(dstr,sstr);
+ SvSETMAGIC(dstr);
+}
+
+void
+sv_catpv(register SV *sv, register char *ptr)
+{
+ register STRLEN len;
+ STRLEN tlen;
+ char *junk;
+
+ if (!ptr)
+ return;
+ junk = SvPV_force(sv, tlen);
+ len = strlen(ptr);
+ SvGROW(sv, tlen + len + 1);
+ if (ptr == junk)
+ ptr = SvPVX(sv);
+ Move(ptr,SvPVX(sv)+tlen,len+1,char);
+ SvCUR(sv) += len;
+ (void)SvPOK_only(sv); /* validate pointer */
+ SvTAINT(sv);
+}
+
+void
+sv_catpv_mg(register SV *sv, register char *ptr)
+{
+ sv_catpv(sv,ptr);
+ SvSETMAGIC(sv);
+}
+
+SV *
+newSV(STRLEN len)
+{
+ register SV *sv;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ if (len) {
+ sv_upgrade(sv, SVt_PV);
+ SvGROW(sv, len + 1);
+ }
+ return sv;
+}
+
+/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
+
+void
+sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen)
+{
+ MAGIC* mg;
+
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (PL_curcop != &PL_compiling && !strchr("gBf", how))
+ croak(no_modify);
+ }
+ if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
+ if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
+ if (how == 't')
+ mg->mg_len |= 1;
+ return;
+ }
+ }
+ else {
+ (void)SvUPGRADE(sv, SVt_PVMG);
+ }
+ Newz(702,mg, 1, MAGIC);
+ mg->mg_moremagic = SvMAGIC(sv);
+
+ SvMAGIC(sv) = mg;
+ if (!obj || obj == sv || how == '#' || how == 'r')
+ mg->mg_obj = obj;
+ else {
+ dTHR;
+ mg->mg_obj = SvREFCNT_inc(obj);
+ mg->mg_flags |= MGf_REFCOUNTED;
+ }
+ mg->mg_type = how;
+ mg->mg_len = namlen;
+ if (name)
+ if (namlen >= 0)
+ mg->mg_ptr = savepvn(name, namlen);
+ else if (namlen == HEf_SVKEY)
+ mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+
+ switch (how) {
+ case 0:
+ mg->mg_virtual = &vtbl_sv;
+ break;
+#ifdef OVERLOAD
+ case 'A':
+ mg->mg_virtual = &vtbl_amagic;
+ break;
+ case 'a':
+ mg->mg_virtual = &vtbl_amagicelem;
+ break;
+ case 'c':
+ mg->mg_virtual = 0;
+ break;
+#endif /* OVERLOAD */
+ case 'B':
+ mg->mg_virtual = &vtbl_bm;
+ break;
+ case 'E':
+ mg->mg_virtual = &vtbl_env;
+ break;
+ case 'f':
+ mg->mg_virtual = &vtbl_fm;
+ break;
+ case 'e':
+ mg->mg_virtual = &vtbl_envelem;
+ break;
+ case 'g':
+ mg->mg_virtual = &vtbl_mglob;
+ break;
+ case 'I':
+ mg->mg_virtual = &vtbl_isa;
+ break;
+ case 'i':
+ mg->mg_virtual = &vtbl_isaelem;
+ break;
+ case 'k':
+ mg->mg_virtual = &vtbl_nkeys;
+ break;
+ case 'L':
+ SvRMAGICAL_on(sv);
+ mg->mg_virtual = 0;
+ break;
+ case 'l':
+ mg->mg_virtual = &vtbl_dbline;
+ break;
+#ifdef USE_THREADS
+ case 'm':
+ mg->mg_virtual = &vtbl_mutex;
+ break;
+#endif /* USE_THREADS */
+#ifdef USE_LOCALE_COLLATE
+ case 'o':
+ mg->mg_virtual = &vtbl_collxfrm;
+ break;
+#endif /* USE_LOCALE_COLLATE */
+ case 'P':
+ mg->mg_virtual = &vtbl_pack;
+ break;
+ case 'p':
+ case 'q':
+ mg->mg_virtual = &vtbl_packelem;
+ break;
+ case 'r':
+ mg->mg_virtual = &vtbl_regexp;
+ break;
+ case 'S':
+ mg->mg_virtual = &vtbl_sig;
+ break;
+ case 's':
+ mg->mg_virtual = &vtbl_sigelem;
+ break;
+ case 't':
+ mg->mg_virtual = &vtbl_taint;
+ mg->mg_len = 1;
+ break;
+ case 'U':
+ mg->mg_virtual = &vtbl_uvar;
+ break;
+ case 'v':
+ mg->mg_virtual = &vtbl_vec;
+ break;
+ case 'x':
+ mg->mg_virtual = &vtbl_substr;
+ break;
+ case 'y':
+ mg->mg_virtual = &vtbl_defelem;
+ break;
+ case '*':
+ mg->mg_virtual = &vtbl_glob;
+ break;
+ case '#':
+ mg->mg_virtual = &vtbl_arylen;
+ break;
+ case '.':
+ mg->mg_virtual = &vtbl_pos;
+ break;
+ case '~': /* Reserved for use by extensions not perl internals. */
+ /* Useful for attaching extension internal data to perl vars. */
+ /* Note that multiple extensions may clash if magical scalars */
+ /* etc holding private data from one are passed to another. */
+ SvRMAGICAL_on(sv);
+ break;
+ default:
+ croak("Don't know how to handle magic of type '%c'", how);
+ }
+ mg_magical(sv);
+ if (SvGMAGICAL(sv))
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
+}
+
+int
+sv_unmagic(SV *sv, int type)
+{
+ MAGIC* mg;
+ MAGIC** mgp;
+ if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
+ return 0;
+ mgp = &SvMAGIC(sv);
+ for (mg = *mgp; mg; mg = *mgp) {
+ if (mg->mg_type == type) {
+ MGVTBL* vtbl = mg->mg_virtual;
+ *mgp = mg->mg_moremagic;
+ if (vtbl && (vtbl->svt_free != NULL))
+ (VTBL->svt_free)(sv, mg);
+ if (mg->mg_ptr && mg->mg_type != 'g')
+ if (mg->mg_len >= 0)
+ Safefree(mg->mg_ptr);
+ else if (mg->mg_len == HEf_SVKEY)
+ SvREFCNT_dec((SV*)mg->mg_ptr);
+ if (mg->mg_flags & MGf_REFCOUNTED)
+ SvREFCNT_dec(mg->mg_obj);
+ Safefree(mg);
+ }
+ else
+ mgp = &mg->mg_moremagic;
+ }
+ if (!SvMAGIC(sv)) {
+ SvMAGICAL_off(sv);
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ }
+
+ return 0;
+}
+
+void
+sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
+{
+ register char *big;
+ register char *mid;
+ register char *midend;
+ register char *bigend;
+ register I32 i;
+ STRLEN curlen;
+
+
+ if (!bigstr)
+ croak("Can't modify non-existent substring");
+ SvPV_force(bigstr, curlen);
+ if (offset + len > curlen) {
+ SvGROW(bigstr, offset+len+1);
+ Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
+ SvCUR_set(bigstr, offset+len);
+ }
+
+ i = littlelen - len;
+ if (i > 0) { /* string might grow */
+ big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
+ mid = big + offset + len;
+ midend = bigend = big + SvCUR(bigstr);
+ bigend += i;
+ *bigend = '\0';
+ while (midend > mid) /* shove everything down */
+ *--bigend = *--midend;
+ Move(little,big+offset,littlelen,char);
+ SvCUR(bigstr) += i;
+ SvSETMAGIC(bigstr);
+ return;
+ }
+ else if (i == 0) {
+ Move(little,SvPVX(bigstr)+offset,len,char);
+ SvSETMAGIC(bigstr);
+ return;
+ }
+
+ big = SvPVX(bigstr);
+ mid = big + offset;
+ midend = mid + len;
+ bigend = big + SvCUR(bigstr);
+
+ if (midend > bigend)
+ croak("panic: sv_insert");
+
+ if (mid - big > bigend - midend) { /* faster to shorten from end */
+ if (littlelen) {
+ Move(little, mid, littlelen,char);
+ mid += littlelen;
+ }
+ i = bigend - midend;
+ if (i > 0) {
+ Move(midend, mid, i,char);
+ mid += i;
+ }
+ *mid = '\0';
+ SvCUR_set(bigstr, mid - big);
+ }
+ /*SUPPRESS 560*/
+ else if (i = mid - big) { /* faster from front */
+ midend -= littlelen;
+ mid = midend;
+ sv_chop(bigstr,midend-i);
+ big += i;
+ while (i--)
+ *--midend = *--big;
+ if (littlelen)
+ Move(little, mid, littlelen,char);
+ }
+ else if (littlelen) {
+ midend -= littlelen;
+ sv_chop(bigstr,midend);
+ Move(little,midend,littlelen,char);
+ }
+ else {
+ sv_chop(bigstr,midend);
+ }
+ SvSETMAGIC(bigstr);
+}
+
+/* make sv point to what nstr did */
+
+void
+sv_replace(register SV *sv, register SV *nsv)
+{
+ U32 refcnt = SvREFCNT(sv);
+ SV_CHECK_THINKFIRST(sv);
+ if (SvREFCNT(nsv) != 1)
+ warn("Reference miscount in sv_replace()");
+ if (SvMAGICAL(sv)) {
+ if (SvMAGICAL(nsv))
+ mg_free(nsv);
+ else
+ sv_upgrade(nsv, SVt_PVMG);
+ SvMAGIC(nsv) = SvMAGIC(sv);
+ SvFLAGS(nsv) |= SvMAGICAL(sv);
+ SvMAGICAL_off(sv);
+ SvMAGIC(sv) = 0;
+ }
+ SvREFCNT(sv) = 0;
+ sv_clear(sv);
+ assert(!SvREFCNT(sv));
+ StructCopy(nsv,sv,SV);
+ SvREFCNT(sv) = refcnt;
+ SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
+ del_SV(nsv);
+}
+
+void
+sv_clear(register SV *sv)
+{
+ HV* stash;
+ assert(sv);
+ assert(SvREFCNT(sv) == 0);
+
+ if (SvOBJECT(sv)) {
+ dTHR;
+ if (PL_defstash) { /* Still have a symbol table? */
+ djSP;
+ GV* destructor;
+ SV tmpref;
+
+ Zero(&tmpref, 1, SV);
+ sv_upgrade(&tmpref, SVt_RV);
+ SvROK_on(&tmpref);
+ SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
+ SvREFCNT(&tmpref) = 1;
+
+ do {
+ stash = SvSTASH(sv);
+ destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
+ if (destructor) {
+ ENTER;
+ PUSHSTACKi(PERLSI_DESTROY);
+ SvRV(&tmpref) = SvREFCNT_inc(sv);
+ EXTEND(SP, 2);
+ PUSHMARK(SP);
+ PUSHs(&tmpref);
+ PUTBACK;
+ perl_call_sv((SV*)GvCV(destructor),
+ G_DISCARD|G_EVAL|G_KEEPERR);
+ SvREFCNT(sv)--;
+ POPSTACK;
+ LEAVE;
+ }
+ } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
+
+ del_XRV(SvANY(&tmpref));
+ }
+
+ if (SvOBJECT(sv)) {
+ SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
+ SvOBJECT_off(sv); /* Curse the object. */
+ if (SvTYPE(sv) != SVt_PVIO)
+ --PL_sv_objcount; /* XXX Might want something more general */
+ }
+ if (SvREFCNT(sv)) {
+ if (PL_in_clean_objs)
+ croak("DESTROY created new reference to dead object");
+ /* DESTROY gave object new lease on life */
+ return;
+ }
+ }
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
+ mg_free(sv);
+ stash = NULL;
+ switch (SvTYPE(sv)) {
+ case SVt_PVIO:
+ if (IoIFP(sv) &&
+ IoIFP(sv) != PerlIO_stdin() &&
+ IoIFP(sv) != PerlIO_stdout() &&
+ IoIFP(sv) != PerlIO_stderr())
+ io_close((IO*)sv);
+ Safefree(IoTOP_NAME(sv));
+ Safefree(IoFMT_NAME(sv));
+ Safefree(IoBOTTOM_NAME(sv));
+ /* FALL THROUGH */
+ case SVt_PVBM:
+ goto freescalar;
+ case SVt_PVCV:
+ case SVt_PVFM:
+ cv_undef((CV*)sv);
+ goto freescalar;
+ case SVt_PVHV:
+ hv_undef((HV*)sv);
+ break;
+ case SVt_PVAV:
+ av_undef((AV*)sv);
+ break;
+ case SVt_PVLV:
+ SvREFCNT_dec(LvTARG(sv));
+ goto freescalar;
+ case SVt_PVGV:
+ gp_free((GV*)sv);
+ Safefree(GvNAME(sv));
+ /* cannot decrease stash refcount yet, as we might recursively delete
+ ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
+ of stash until current sv is completely gone.
+ -- JohnPC, 27 Mar 1998 */
+ stash = GvSTASH(sv);
+ /* FALL THROUGH */
+ case SVt_PVMG:
+ case SVt_PVNV:
+ case SVt_PVIV:
+ freescalar:
+ (void)SvOOK_off(sv);
+ /* FALL THROUGH */
+ case SVt_PV:
+ case SVt_RV:
+ if (SvROK(sv))
+ SvREFCNT_dec(SvRV(sv));
+ else if (SvPVX(sv) && SvLEN(sv))
+ Safefree(SvPVX(sv));
+ break;
+/*
+ case SVt_NV:
+ case SVt_IV:
+ case SVt_NULL:
+ break;
+*/
+ }
+
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ break;
+ case SVt_IV:
+ del_XIV(SvANY(sv));
+ break;
+ case SVt_NV:
+ del_XNV(SvANY(sv));
+ break;
+ case SVt_RV:
+ del_XRV(SvANY(sv));
+ break;
+ case SVt_PV:
+ del_XPV(SvANY(sv));
+ break;
+ case SVt_PVIV:
+ del_XPVIV(SvANY(sv));
+ break;
+ case SVt_PVNV:
+ del_XPVNV(SvANY(sv));
+ break;
+ case SVt_PVMG:
+ del_XPVMG(SvANY(sv));
+ break;
+ case SVt_PVLV:
+ del_XPVLV(SvANY(sv));
+ break;
+ case SVt_PVAV:
+ del_XPVAV(SvANY(sv));
+ break;
+ case SVt_PVHV:
+ del_XPVHV(SvANY(sv));
+ break;
+ case SVt_PVCV:
+ del_XPVCV(SvANY(sv));
+ break;
+ case SVt_PVGV:
+ del_XPVGV(SvANY(sv));
+ /* code duplication for increased performance. */
+ SvFLAGS(sv) &= SVf_BREAK;
+ SvFLAGS(sv) |= SVTYPEMASK;
+ /* decrease refcount of the stash that owns this GV, if any */
+ if (stash)
+ SvREFCNT_dec(stash);
+ return; /* not break, SvFLAGS reset already happened */
+ case SVt_PVBM:
+ del_XPVBM(SvANY(sv));
+ break;
+ case SVt_PVFM:
+ del_XPVFM(SvANY(sv));
+ break;
+ case SVt_PVIO:
+ del_XPVIO(SvANY(sv));
+ break;
+ }
+ SvFLAGS(sv) &= SVf_BREAK;
+ SvFLAGS(sv) |= SVTYPEMASK;
+}
+
+SV *
+sv_newref(SV *sv)
+{
+ if (sv)
+ ATOMIC_INC(SvREFCNT(sv));
+ return sv;
+}
+
+void
+sv_free(SV *sv)
+{
+ int refcount_is_zero;
+
+ if (!sv)
+ return;
+ if (SvREFCNT(sv) == 0) {
+ if (SvFLAGS(sv) & SVf_BREAK)
+ return;
+ if (PL_in_clean_all) /* All is fair */
+ return;
+ if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
+ /* make sure SvREFCNT(sv)==0 happens very seldom */
+ SvREFCNT(sv) = (~(U32)0)/2;
+ return;
+ }
+ warn("Attempt to free unreferenced scalar");
+ return;
+ }
+ ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
+ if (!refcount_is_zero)
+ return;
+#ifdef DEBUGGING
+ if (SvTEMP(sv)) {
+ warn("Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
+ return;
+ }
+#endif
+ if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
+ /* make sure SvREFCNT(sv)==0 happens very seldom */
+ SvREFCNT(sv) = (~(U32)0)/2;
+ return;
+ }
+ sv_clear(sv);
+ if (! SvREFCNT(sv))
+ del_SV(sv);
+}
+
+STRLEN
+sv_len(register SV *sv)
+{
+ char *junk;
+ STRLEN len;
+
+ if (!sv)
+ return 0;
+
+ if (SvGMAGICAL(sv))
+ len = mg_length(sv);
+ else
+ junk = SvPV(sv, len);
+ return len;
+}
+
+I32
+sv_eq(register SV *str1, register SV *str2)
+{
+ char *pv1;
+ STRLEN cur1;
+ char *pv2;
+ STRLEN cur2;
+
+ if (!str1) {
+ pv1 = "";
+ cur1 = 0;
+ }
+ else
+ pv1 = SvPV(str1, cur1);
+
+ if (!str2)
+ return !cur1;
+ else
+ pv2 = SvPV(str2, cur2);
+
+ if (cur1 != cur2)
+ return 0;
+
+ return memEQ(pv1, pv2, cur1);
+}
+
+I32
+sv_cmp(register SV *str1, register SV *str2)
+{
+ STRLEN cur1 = 0;
+ char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
+ STRLEN cur2 = 0;
+ char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
+ I32 retval;
+
+ if (!cur1)
+ return cur2 ? -1 : 0;
+
+ if (!cur2)
+ return 1;
+
+ retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
+
+ if (retval)
+ return retval < 0 ? -1 : 1;
+
+ if (cur1 == cur2)
+ return 0;
+ else
+ return cur1 < cur2 ? -1 : 1;
+}
+
+I32
+sv_cmp_locale(register SV *sv1, register SV *sv2)
+{
+#ifdef USE_LOCALE_COLLATE
+
+ char *pv1, *pv2;
+ STRLEN len1, len2;
+ I32 retval;
+
+ if (PL_collation_standard)
+ goto raw_compare;
+
+ len1 = 0;
+ pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
+ len2 = 0;
+ pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
+
+ if (!pv1 || !len1) {
+ if (pv2 && len2)
+ return -1;
+ else
+ goto raw_compare;
+ }
+ else {
+ if (!pv2 || !len2)
+ return 1;
+ }
+
+ retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
+
+ if (retval)
+ return retval < 0 ? -1 : 1;
+
+ /*
+ * When the result of collation is equality, that doesn't mean
+ * that there are no differences -- some locales exclude some
+ * characters from consideration. So to avoid false equalities,
+ * we use the raw string as a tiebreaker.
+ */
+
+ raw_compare:
+ /* FALL THROUGH */
+
+#endif /* USE_LOCALE_COLLATE */
+
+ return sv_cmp(sv1, sv2);
+}
+
+#ifdef USE_LOCALE_COLLATE
+/*
+ * Any scalar variable may carry an 'o' magic that contains the
+ * scalar data of the variable transformed to such a format that
+ * a normal memory comparison can be used to compare the data
+ * according to the locale settings.
+ */
+char *
+sv_collxfrm(SV *sv, STRLEN *nxp)
+{
+ MAGIC *mg;
+
+ mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
+ if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
+ char *s, *xf;
+ STRLEN len, xlen;
+
+ if (mg)
+ Safefree(mg->mg_ptr);
+ s = SvPV(sv, len);
+ if ((xf = mem_collxfrm(s, len, &xlen))) {
+ if (SvREADONLY(sv)) {
+ SAVEFREEPV(xf);
+ *nxp = xlen;
+ return xf + sizeof(PL_collation_ix);
+ }
+ if (! mg) {
+ sv_magic(sv, 0, 'o', 0, 0);
+ mg = mg_find(sv, 'o');
+ assert(mg);
+ }
+ mg->mg_ptr = xf;
+ mg->mg_len = xlen;
+ }
+ else {
+ if (mg) {
+ mg->mg_ptr = NULL;
+ mg->mg_len = -1;
+ }
+ }
+ }
+ if (mg && mg->mg_ptr) {
+ *nxp = mg->mg_len;
+ return mg->mg_ptr + sizeof(PL_collation_ix);
+ }
+ else {
+ *nxp = 0;
+ return NULL;
+ }
+}
+
+#endif /* USE_LOCALE_COLLATE */
+
+char *
+sv_gets(register SV *sv, register PerlIO *fp, I32 append)
+{
+ dTHR;
+ char *rsptr;
+ STRLEN rslen;
+ register STDCHAR rslast;
+ register STDCHAR *bp;
+ register I32 cnt;
+ I32 i;
+
+ SV_CHECK_THINKFIRST(sv);
+ (void)SvUPGRADE(sv, SVt_PV);
+ SvSCREAM_off(sv);
+
+ if (RsSNARF(PL_rs)) {
+ rsptr = NULL;
+ rslen = 0;
+ }
+ else if (RsRECORD(PL_rs)) {
+ I32 recsize, bytesread;
+ char *buffer;
+
+ /* Grab the size of the record we're getting */
+ recsize = SvIV(SvRV(PL_rs));
+ (void)SvPOK_only(sv); /* Validate pointer */
+ buffer = SvGROW(sv, recsize + 1);
+ /* Go yank in */
+#ifdef VMS
+ /* VMS wants read instead of fread, because fread doesn't respect */
+ /* RMS record boundaries. This is not necessarily a good thing to be */
+ /* doing, but we've got no other real choice */
+ bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
+#else
+ bytesread = PerlIO_read(fp, buffer, recsize);
+#endif
+ SvCUR_set(sv, bytesread);
+ buffer[bytesread] = '\0';
+ return(SvCUR(sv) ? SvPVX(sv) : Nullch);
+ }
+ else if (RsPARA(PL_rs)) {
+ rsptr = "\n\n";
+ rslen = 2;
+ }
+ else
+ rsptr = SvPV(PL_rs, rslen);
+ rslast = rslen ? rsptr[rslen - 1] : '\0';
+
+ if (RsPARA(PL_rs)) { /* have to do this both before and after */
+ do { /* to make sure file boundaries work right */
+ if (PerlIO_eof(fp))
+ return 0;
+ i = PerlIO_getc(fp);
+ if (i != '\n') {
+ if (i == -1)
+ return 0;
+ PerlIO_ungetc(fp,i);
+ break;
+ }
+ } while (i != EOF);
+ }
+
+ /* See if we know enough about I/O mechanism to cheat it ! */
+
+ /* This used to be #ifdef test - it is made run-time test for ease
+ of abstracting out stdio interface. One call should be cheap
+ enough here - and may even be a macro allowing compile
+ time optimization.
+ */
+
+ if (PerlIO_fast_gets(fp)) {
+
+ /*
+ * We're going to steal some values from the stdio struct
+ * and put EVERYTHING in the innermost loop into registers.
+ */
+ register STDCHAR *ptr;
+ STRLEN bpx;
+ I32 shortbuffered;
+
+#if defined(VMS) && defined(PERLIO_IS_STDIO)
+ /* An ungetc()d char is handled separately from the regular
+ * buffer, so we getc() it back out and stuff it in the buffer.
+ */
+ i = PerlIO_getc(fp);
+ if (i == EOF) return 0;
+ *(--((*fp)->_ptr)) = (unsigned char) i;
+ (*fp)->_cnt++;
+#endif
+
+ /* Here is some breathtakingly efficient cheating */
+
+ cnt = PerlIO_get_cnt(fp); /* get count into register */
+ (void)SvPOK_only(sv); /* validate pointer */
+ if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
+ if (cnt > 80 && SvLEN(sv) > append) {
+ shortbuffered = cnt - SvLEN(sv) + append + 1;
+ cnt -= shortbuffered;
+ }
+ else {
+ shortbuffered = 0;
+ /* remember that cnt can be negative */
+ SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
+ }
+ }
+ else
+ shortbuffered = 0;
+ bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
+ ptr = (STDCHAR*)PerlIO_get_ptr(fp);
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
+ (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
+ (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
+ for (;;) {
+ screamer:
+ if (cnt > 0) {
+ if (rslen) {
+ while (cnt > 0) { /* this | eat */
+ cnt--;
+ if ((*bp++ = *ptr++) == rslast) /* really | dust */
+ goto thats_all_folks; /* screams | sed :-) */
+ }
+ }
+ else {
+ Copy(ptr, bp, cnt, char); /* this | eat */
+ bp += cnt; /* screams | dust */
+ ptr += cnt; /* louder | sed :-) */
+ cnt = 0;
+ }
+ }
+
+ if (shortbuffered) { /* oh well, must extend */
+ cnt = shortbuffered;
+ shortbuffered = 0;
+ bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
+ SvCUR_set(sv, bpx);
+ SvGROW(sv, SvLEN(sv) + append + cnt + 2);
+ bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
+ continue;
+ }
+
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
+ PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
+ (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
+ (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+ /* This used to call 'filbuf' in stdio form, but as that behaves like
+ getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
+ another abstraction. */
+ i = PerlIO_getc(fp); /* get more characters */
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
+ (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
+ (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+ cnt = PerlIO_get_cnt(fp);
+ ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
+
+ if (i == EOF) /* all done for ever? */
+ goto thats_really_all_folks;
+
+ bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
+ SvCUR_set(sv, bpx);
+ SvGROW(sv, bpx + cnt + 2);
+ bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
+
+ *bp++ = i; /* store character from PerlIO_getc */
+
+ if (rslen && (STDCHAR)i == rslast) /* all done for now? */
+ goto thats_all_folks;
+ }
+
+thats_all_folks:
+ if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
+ memNE((char*)bp - rslen, rsptr, rslen))
+ goto screamer; /* go back to the fray */
+thats_really_all_folks:
+ if (shortbuffered)
+ cnt += shortbuffered;
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
+ PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
+ (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
+ (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+ *bp = '\0';
+ SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: done, len=%ld, string=|%.*s|\n",
+ (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
+ }
+ else
+ {
+ /*The big, slow, and stupid way */
+ STDCHAR buf[8192];
+
+screamer2:
+ if (rslen) {
+ register STDCHAR *bpe = buf + sizeof(buf);
+ bp = buf;
+ while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
+ ; /* keep reading */
+ cnt = bp - buf;
+ }
+ else {
+ cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
+ /* Accomodate broken VAXC compiler, which applies U8 cast to
+ * both args of ?: operator, causing EOF to change into 255
+ */
+ if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
+ }
+
+ if (append)
+ sv_catpvn(sv, (char *) buf, cnt);
+ else
+ sv_setpvn(sv, (char *) buf, cnt);
+
+ if (i != EOF && /* joy */
+ (!rslen ||
+ SvCUR(sv) < rslen ||
+ memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
+ {
+ append = -1;
+ /*
+ * If we're reading from a TTY and we get a short read,
+ * indicating that the user hit his EOF character, we need
+ * to notice it now, because if we try to read from the TTY
+ * again, the EOF condition will disappear.
+ *
+ * The comparison of cnt to sizeof(buf) is an optimization
+ * that prevents unnecessary calls to feof().
+ *
+ * - jik 9/25/96
+ */
+ if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
+ goto screamer2;
+ }
+ }
+
+ if (RsPARA(PL_rs)) { /* have to do this both before and after */
+ while (i != EOF) { /* to make sure file boundaries work right */
+ i = PerlIO_getc(fp);
+ if (i != '\n') {
+ PerlIO_ungetc(fp,i);
+ break;
+ }
+ }
+ }
+
+#ifdef WIN32
+ win32_strip_return(sv);
+#endif
+
+ return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
+}
+
+
+void
+sv_inc(register SV *sv)
+{
+ register char *d;
+ int flags;
+
+ if (!sv)
+ return;
+ if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (PL_curcop != &PL_compiling)
+ croak(no_modify);
+ }
+ if (SvROK(sv)) {
+ IV i;
+#ifdef OVERLOAD
+ if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return;
+#endif /* OVERLOAD */
+ i = (IV)SvRV(sv);
+ sv_unref(sv);
+ sv_setiv(sv, i);
+ }
+ }
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ flags = SvFLAGS(sv);
+ if (flags & SVp_NOK) {
+ (void)SvNOK_only(sv);
+ SvNVX(sv) += 1.0;
+ return;
+ }
+ if (flags & SVp_IOK) {
+ if (SvIVX(sv) == IV_MAX)
+ sv_setnv(sv, (double)IV_MAX + 1.0);
+ else {
+ (void)SvIOK_only(sv);
+ ++SvIVX(sv);
+ }
+ return;
+ }
+ if (!(flags & SVp_POK) || !*SvPVX(sv)) {
+ if ((flags & SVTYPEMASK) < SVt_PVNV)
+ sv_upgrade(sv, SVt_NV);
+ SvNVX(sv) = 1.0;
+ (void)SvNOK_only(sv);
+ return;
+ }
+ d = SvPVX(sv);
+ while (isALPHA(*d)) d++;
+ while (isDIGIT(*d)) d++;
+ if (*d) {
+ SET_NUMERIC_STANDARD();
+ sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
+ return;
+ }
+ d--;
+ while (d >= SvPVX(sv)) {
+ if (isDIGIT(*d)) {
+ if (++*d <= '9')
+ return;
+ *(d--) = '0';
+ }
+ else {
+#ifdef EBCDIC
+ /* MKS: The original code here died if letters weren't consecutive.
+ * at least it didn't have to worry about non-C locales. The
+ * new code assumes that ('z'-'a')==('Z'-'A'), letters are
+ * arranged in order (although not consecutively) and that only
+ * [A-Za-z] are accepted by isALPHA in the C locale.
+ */
+ if (*d != 'z' && *d != 'Z') {
+ do { ++*d; } while (!isALPHA(*d));
+ return;
+ }
+ *(d--) -= 'z' - 'a';
+#else
+ ++*d;
+ if (isALPHA(*d))
+ return;
+ *(d--) -= 'z' - 'a' + 1;
+#endif
+ }
+ }
+ /* oh,oh, the number grew */
+ SvGROW(sv, SvCUR(sv) + 2);
+ SvCUR(sv)++;
+ for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
+ *d = d[-1];
+ if (isDIGIT(d[1]))
+ *d = '1';
+ else
+ *d = d[1];
+}
+
+void
+sv_dec(register SV *sv)
+{
+ int flags;
+
+ if (!sv)
+ return;
+ if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (PL_curcop != &PL_compiling)
+ croak(no_modify);
+ }
+ if (SvROK(sv)) {
+ IV i;
+#ifdef OVERLOAD
+ if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return;
+#endif /* OVERLOAD */
+ i = (IV)SvRV(sv);
+ sv_unref(sv);
+ sv_setiv(sv, i);
+ }
+ }
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ flags = SvFLAGS(sv);
+ if (flags & SVp_NOK) {
+ SvNVX(sv) -= 1.0;
+ (void)SvNOK_only(sv);
+ return;
+ }
+ if (flags & SVp_IOK) {
+ if (SvIVX(sv) == IV_MIN)
+ sv_setnv(sv, (double)IV_MIN - 1.0);
+ else {
+ (void)SvIOK_only(sv);
+ --SvIVX(sv);
+ }
+ return;
+ }
+ if (!(flags & SVp_POK)) {
+ if ((flags & SVTYPEMASK) < SVt_PVNV)
+ sv_upgrade(sv, SVt_NV);
+ SvNVX(sv) = -1.0;
+ (void)SvNOK_only(sv);
+ return;
+ }
+ SET_NUMERIC_STANDARD();
+ sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
+}
+
+/* Make a string that will exist for the duration of the expression
+ * evaluation. Actually, it may have to last longer than that, but
+ * hopefully we won't free it until it has been assigned to a
+ * permanent location. */
+
+STATIC void
+sv_mortalgrow(void)
+{
+ dTHR;
+ PL_tmps_max += (PL_tmps_max < 512) ? 128 : 512;
+ Renew(PL_tmps_stack, PL_tmps_max, SV*);
+}
+
+SV *
+sv_mortalcopy(SV *oldstr)
+{
+ dTHR;
+ register SV *sv;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ sv_setsv(sv,oldstr);
+ if (++PL_tmps_ix >= PL_tmps_max)
+ sv_mortalgrow();
+ PL_tmps_stack[PL_tmps_ix] = sv;
+ SvTEMP_on(sv);
+ return sv;
+}
+
+SV *
+sv_newmortal(void)
+{
+ dTHR;
+ register SV *sv;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = SVs_TEMP;
+ if (++PL_tmps_ix >= PL_tmps_max)
+ sv_mortalgrow();
+ PL_tmps_stack[PL_tmps_ix] = sv;
+ return sv;
+}
+
+/* same thing without the copying */
+
+SV *
+sv_2mortal(register SV *sv)
+{
+ dTHR;
+ if (!sv)
+ return sv;
+ if (SvREADONLY(sv) && SvIMMORTAL(sv))
+ return sv;
+ if (++PL_tmps_ix >= PL_tmps_max)
+ sv_mortalgrow();
+ PL_tmps_stack[PL_tmps_ix] = sv;
+ SvTEMP_on(sv);
+ return sv;
+}
+
+SV *
+newSVpv(char *s, STRLEN len)
+{
+ register SV *sv;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ if (!len)
+ len = strlen(s);
+ sv_setpvn(sv,s,len);
+ return sv;
+}
+
+SV *
+newSVpvn(char *s, STRLEN len)
+{
+ register SV *sv;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ sv_setpvn(sv,s,len);
+ return sv;
+}
+
+SV *
+newSVpvf(const char* pat, ...)
+{
+ register SV *sv;
+ va_list args;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ va_start(args, pat);
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+ return sv;
+}
+
+
+SV *
+newSVnv(double n)
+{
+ register SV *sv;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ sv_setnv(sv,n);
+ return sv;
+}
+
+SV *
+newSViv(IV i)
+{
+ register SV *sv;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ sv_setiv(sv,i);
+ return sv;
+}
+
+SV *
+newRV_noinc(SV *tmpRef)
+{
+ dTHR;
+ register SV *sv;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ sv_upgrade(sv, SVt_RV);
+ SvTEMP_off(tmpRef);
+ SvRV(sv) = tmpRef;
+ SvROK_on(sv);
+ return sv;
+}
+
+SV *
+newRV(SV *tmpRef)
+{
+ return newRV_noinc(SvREFCNT_inc(tmpRef));
+}
+
+/* make an exact duplicate of old */
+
+SV *
+newSVsv(register SV *old)
+{
+ register SV *sv;
+
+ if (!old)
+ return Nullsv;
+ if (SvTYPE(old) == SVTYPEMASK) {
+ warn("semi-panic: attempt to dup freed string");
+ return Nullsv;
+ }
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ if (SvTEMP(old)) {
+ SvTEMP_off(old);
+ sv_setsv(sv,old);
+ SvTEMP_on(old);
+ }
+ else
+ sv_setsv(sv,old);
+ return sv;
+}
+
+void
+sv_reset(register char *s, HV *stash)
+{
+ register HE *entry;
+ register GV *gv;
+ register SV *sv;
+ register I32 i;
+ register PMOP *pm;
+ register I32 max;
+ char todo[256];
+
+ if (!stash)
+ return;
+
+ if (!*s) { /* reset ?? searches */
+ for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
+ pm->op_pmdynflags &= ~PMdf_USED;
+ }
+ return;
+ }
+
+ /* reset variables */
+
+ if (!HvARRAY(stash))
+ return;
+
+ Zero(todo, 256, char);
+ while (*s) {
+ i = *s;
+ if (s[1] == '-') {
+ s += 2;
+ }
+ max = *s++;
+ for ( ; i <= max; i++) {
+ todo[i] = 1;
+ }
+ for (i = 0; i <= (I32) HvMAX(stash); i++) {
+ for (entry = HvARRAY(stash)[i];
+ entry;
+ entry = HeNEXT(entry)) {
+ if (!todo[(U8)*HeKEY(entry)])
+ continue;
+ gv = (GV*)HeVAL(entry);
+ sv = GvSV(gv);
+ (void)SvOK_off(sv);
+ if (SvTYPE(sv) >= SVt_PV) {
+ SvCUR_set(sv, 0);
+ if (SvPVX(sv) != Nullch)
+ *SvPVX(sv) = '\0';
+ SvTAINT(sv);
+ }
+ if (GvAV(gv)) {
+ av_clear(GvAV(gv));
+ }
+ if (GvHV(gv) && !HvNAME(GvHV(gv))) {
+ hv_clear(GvHV(gv));
+#ifndef VMS /* VMS has no environ array */
+ if (gv == PL_envgv)
+ environ[0] = Nullch;
+#endif
+ }
+ }
+ }
+ }
+}
+
+IO*
+sv_2io(SV *sv)
+{
+ IO* io;
+ GV* gv;
+
+ switch (SvTYPE(sv)) {
+ case SVt_PVIO:
+ io = (IO*)sv;
+ break;
+ case SVt_PVGV:
+ gv = (GV*)sv;
+ io = GvIO(gv);
+ if (!io)
+ croak("Bad filehandle: %s", GvNAME(gv));
+ break;
+ default:
+ if (!SvOK(sv))
+ croak(no_usym, "filehandle");
+ if (SvROK(sv))
+ return sv_2io(SvRV(sv));
+ gv = gv_fetchpv(SvPV(sv,PL_na), FALSE, SVt_PVIO);
+ if (gv)
+ io = GvIO(gv);
+ else
+ io = 0;
+ if (!io)
+ croak("Bad filehandle: %s", SvPV(sv,PL_na));
+ break;
+ }
+ return io;
+}
+
+CV *
+sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref)
+{
+ GV *gv;
+ CV *cv;
+
+ if (!sv)
+ return *gvp = Nullgv, Nullcv;
+ switch (SvTYPE(sv)) {
+ case SVt_PVCV:
+ *st = CvSTASH(sv);
+ *gvp = Nullgv;
+ return (CV*)sv;
+ case SVt_PVHV:
+ case SVt_PVAV:
+ *gvp = Nullgv;
+ return Nullcv;
+ case SVt_PVGV:
+ gv = (GV*)sv;
+ *gvp = gv;
+ *st = GvESTASH(gv);
+ goto fix_gv;
+
+ default:
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (SvROK(sv)) {
+ cv = (CV*)SvRV(sv);
+ if (SvTYPE(cv) != SVt_PVCV)
+ croak("Not a subroutine reference");
+ *gvp = Nullgv;
+ *st = CvSTASH(cv);
+ return cv;
+ }
+ if (isGV(sv))
+ gv = (GV*)sv;
+ else
+ gv = gv_fetchpv(SvPV(sv, PL_na), lref, SVt_PVCV);
+ *gvp = gv;
+ if (!gv)
+ return Nullcv;
+ *st = GvESTASH(gv);
+ fix_gv:
+ if (lref && !GvCVu(gv)) {
+ SV *tmpsv;
+ ENTER;
+ tmpsv = NEWSV(704,0);
+ gv_efullname3(tmpsv, gv, Nullch);
+ newSUB(start_subparse(FALSE, 0),
+ newSVOP(OP_CONST, 0, tmpsv),
+ Nullop,
+ Nullop);
+ LEAVE;
+ if (!GvCVu(gv))
+ croak("Unable to create sub named \"%s\"", SvPV(sv,PL_na));
+ }
+ return GvCVu(gv);
+ }
+}
+
+I32
+sv_true(register SV *sv)
+{
+ dTHR;
+ if (!sv)
+ return 0;
+ if (SvPOK(sv)) {
+ register XPV* tXpv;
+ if ((tXpv = (XPV*)SvANY(sv)) &&
+ (*tXpv->xpv_pv > '0' ||
+ tXpv->xpv_cur > 1 ||
+ (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
+ return 1;
+ else
+ return 0;
+ }
+ else {
+ if (SvIOK(sv))
+ return SvIVX(sv) != 0;
+ else {
+ if (SvNOK(sv))
+ return SvNVX(sv) != 0.0;
+ else
+ return sv_2bool(sv);
+ }
+ }
+}
+
+IV
+sv_iv(register SV *sv)
+{
+ if (SvIOK(sv))
+ return SvIVX(sv);
+ return sv_2iv(sv);
+}
+
+UV
+sv_uv(register SV *sv)
+{
+ if (SvIOK(sv))
+ return SvUVX(sv);
+ return sv_2uv(sv);
+}
+
+double
+sv_nv(register SV *sv)
+{
+ if (SvNOK(sv))
+ return SvNVX(sv);
+ return sv_2nv(sv);
+}
+
+char *
+sv_pvn(SV *sv, STRLEN *lp)
+{
+ if (SvPOK(sv)) {
+ *lp = SvCUR(sv);
+ return SvPVX(sv);
+ }
+ return sv_2pv(sv, lp);
+}
+
+char *
+sv_pvn_force(SV *sv, STRLEN *lp)
+{
+ char *s;
+
+ if (SvREADONLY(sv)) {
+ dTHR;
+ if (PL_curcop != &PL_compiling)
+ croak(no_modify);
+ }
+
+ if (SvPOK(sv)) {
+ *lp = SvCUR(sv);
+ }
+ else {
+ if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
+ if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) {
+ sv_unglob(sv);
+ s = SvPVX(sv);
+ *lp = SvCUR(sv);
+ }
+ else {
+ dTHR;
+ croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
+ op_name[PL_op->op_type]);
+ }
+ }
+ else
+ s = sv_2pv(sv, lp);
+ if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
+ STRLEN len = *lp;
+
+ if (SvROK(sv))
+ sv_unref(sv);
+ (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
+ SvGROW(sv, len + 1);
+ Move(s,SvPVX(sv),len,char);
+ SvCUR_set(sv, len);
+ *SvEND(sv) = '\0';
+ }
+ if (!SvPOK(sv)) {
+ SvPOK_on(sv); /* validate pointer */
+ SvTAINT(sv);
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
+ (unsigned long)sv,SvPVX(sv)));
+ }
+ }
+ return SvPVX(sv);
+}
+
+char *
+sv_reftype(SV *sv, int ob)
+{
+ if (ob && SvOBJECT(sv))
+ return HvNAME(SvSTASH(sv));
+ else {
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ case SVt_IV:
+ case SVt_NV:
+ case SVt_RV:
+ case SVt_PV:
+ case SVt_PVIV:
+ case SVt_PVNV:
+ case SVt_PVMG:
+ case SVt_PVBM:
+ if (SvROK(sv))
+ return "REF";
+ else
+ return "SCALAR";
+ case SVt_PVLV: return "LVALUE";
+ case SVt_PVAV: return "ARRAY";
+ case SVt_PVHV: return "HASH";
+ case SVt_PVCV: return "CODE";
+ case SVt_PVGV: return "GLOB";
+ case SVt_PVFM: return "FORMAT";
+ default: return "UNKNOWN";
+ }
+ }
+}
+
+int
+sv_isobject(SV *sv)
+{
+ if (!sv)
+ return 0;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (!SvROK(sv))
+ return 0;
+ sv = (SV*)SvRV(sv);
+ if (!SvOBJECT(sv))
+ return 0;
+ return 1;
+}
+
+int
+sv_isa(SV *sv, char *name)
+{
+ if (!sv)
+ return 0;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
+ if (!SvROK(sv))
+ return 0;
+ sv = (SV*)SvRV(sv);
+ if (!SvOBJECT(sv))
+ return 0;
+
+ return strEQ(HvNAME(SvSTASH(sv)), name);
+}
+
+SV*
+newSVrv(SV *rv, char *classname)
+{
+ dTHR;
+ SV *sv;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 0;
+ SvFLAGS(sv) = 0;
+
+ SV_CHECK_THINKFIRST(rv);
+#ifdef OVERLOAD
+ SvAMAGIC_off(rv);
+#endif /* OVERLOAD */
+
+ if (SvTYPE(rv) < SVt_RV)
+ sv_upgrade(rv, SVt_RV);
+
+ (void)SvOK_off(rv);
+ SvRV(rv) = SvREFCNT_inc(sv);
+ SvROK_on(rv);
+
+ if (classname) {
+ HV* stash = gv_stashpv(classname, TRUE);
+ (void)sv_bless(rv, stash);
+ }
+ return sv;
+}
+
+SV*
+sv_setref_pv(SV *rv, char *classname, void *pv)
+{
+ if (!pv) {
+ sv_setsv(rv, &PL_sv_undef);
+ SvSETMAGIC(rv);
+ }
+ else
+ sv_setiv(newSVrv(rv,classname), (IV)pv);
+ return rv;
+}
+
+SV*
+sv_setref_iv(SV *rv, char *classname, IV iv)
+{
+ sv_setiv(newSVrv(rv,classname), iv);
+ return rv;
+}
+
+SV*
+sv_setref_nv(SV *rv, char *classname, double nv)
+{
+ sv_setnv(newSVrv(rv,classname), nv);
+ return rv;
+}
+
+SV*
+sv_setref_pvn(SV *rv, char *classname, char *pv, I32 n)
+{
+ sv_setpvn(newSVrv(rv,classname), pv, n);
+ return rv;
+}
+
+SV*
+sv_bless(SV *sv, HV *stash)
+{
+ dTHR;
+ SV *tmpRef;
+ if (!SvROK(sv))
+ croak("Can't bless non-reference value");
+ tmpRef = SvRV(sv);
+ if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
+ if (SvREADONLY(tmpRef))
+ croak(no_modify);
+ if (SvOBJECT(tmpRef)) {
+ if (SvTYPE(tmpRef) != SVt_PVIO)
+ --PL_sv_objcount;
+ SvREFCNT_dec(SvSTASH(tmpRef));
+ }
+ }
+ SvOBJECT_on(tmpRef);
+ if (SvTYPE(tmpRef) != SVt_PVIO)
+ ++PL_sv_objcount;
+ (void)SvUPGRADE(tmpRef, SVt_PVMG);
+ SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
+
+#ifdef OVERLOAD
+ if (Gv_AMG(stash))
+ SvAMAGIC_on(sv);
+ else
+ SvAMAGIC_off(sv);
+#endif /* OVERLOAD */
+
+ return sv;
+}
+
+STATIC void
+sv_unglob(SV *sv)
+{
+ assert(SvTYPE(sv) == SVt_PVGV);
+ SvFAKE_off(sv);
+ if (GvGP(sv))
+ gp_free((GV*)sv);
+ if (GvSTASH(sv)) {
+ SvREFCNT_dec(GvSTASH(sv));
+ GvSTASH(sv) = Nullhv;
+ }
+ sv_unmagic(sv, '*');
+ Safefree(GvNAME(sv));
+ GvMULTI_off(sv);
+ SvFLAGS(sv) &= ~SVTYPEMASK;
+ SvFLAGS(sv) |= SVt_PVMG;
+}
+
+void
+sv_unref(SV *sv)
+{
+ SV* rv = SvRV(sv);
+
+ SvRV(sv) = 0;
+ SvROK_off(sv);
+ if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
+ SvREFCNT_dec(rv);
+ else
+ sv_2mortal(rv); /* Schedule for freeing later */
+}
+
+void
+sv_taint(SV *sv)
+{
+ sv_magic((sv), Nullsv, 't', Nullch, 0);
+}
+
+void
+sv_untaint(SV *sv)
+{
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ MAGIC *mg = mg_find(sv, 't');
+ if (mg)
+ mg->mg_len &= ~1;
+ }
+}
+
+bool
+sv_tainted(SV *sv)
+{
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ MAGIC *mg = mg_find(sv, 't');
+ if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
+ return TRUE;
+ }
+ return FALSE;
+}
+
+void
+sv_setpviv(SV *sv, IV iv)
+{
+ STRLEN len;
+ char buf[TYPE_DIGITS(UV)];
+ char *ptr = buf + sizeof(buf);
+ int sign;
+ UV uv;
+ char *p;
+
+ sv_setpvn(sv, "", 0);
+ if (iv >= 0) {
+ uv = iv;
+ sign = 0;
+ } else {
+ uv = -iv;
+ sign = 1;
+ }
+ do {
+ *--ptr = '0' + (uv % 10);
+ } while (uv /= 10);
+ len = (buf + sizeof(buf)) - ptr;
+ /* taking advantage of SvCUR(sv) == 0 */
+ SvGROW(sv, sign + len + 1);
+ p = SvPVX(sv);
+ if (sign)
+ *p++ = '-';
+ memcpy(p, ptr, len);
+ p += len;
+ *p = '\0';
+ SvCUR(sv) = p - SvPVX(sv);
+}
+
+
+void
+sv_setpviv_mg(SV *sv, IV iv)
+{
+ sv_setpviv(sv,iv);
+ SvSETMAGIC(sv);
+}
+
+void
+sv_setpvf(SV *sv, const char* pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+}
+
+
+void
+sv_setpvf_mg(SV *sv, const char* pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+ SvSETMAGIC(sv);
+}
+
+void
+sv_catpvf(SV *sv, const char* pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+}
+
+void
+sv_catpvf_mg(SV *sv, const char* pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+ SvSETMAGIC(sv);
+}
+
+void
+sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
+{
+ sv_setpvn(sv, "", 0);
+ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
+}
+
+void
+sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
+{
+ dTHR;
+ char *p;
+ char *q;
+ char *patend;
+ STRLEN origlen;
+ I32 svix = 0;
+ static char nullstr[] = "(null)";
+
+ /* no matter what, this is a string now */
+ (void)SvPV_force(sv, origlen);
+
+ /* special-case "", "%s", and "%_" */
+ if (patlen == 0)
+ return;
+ if (patlen == 2 && pat[0] == '%') {
+ switch (pat[1]) {
+ case 's':
+ if (args) {
+ char *s = va_arg(*args, char*);
+ sv_catpv(sv, s ? s : nullstr);
+ }
+ else if (svix < svmax)
+ sv_catsv(sv, *svargs);
+ return;
+ case '_':
+ if (args) {
+ sv_catsv(sv, va_arg(*args, SV*));
+ return;
+ }
+ /* See comment on '_' below */
+ break;
+ }
+ }
+
+ patend = (char*)pat + patlen;
+ for (p = (char*)pat; p < patend; p = q) {
+ bool alt = FALSE;
+ bool left = FALSE;
+ char fill = ' ';
+ char plus = 0;
+ char intsize = 0;
+ STRLEN width = 0;
+ STRLEN zeros = 0;
+ bool has_precis = FALSE;
+ STRLEN precis = 0;
+
+ char esignbuf[4];
+ STRLEN esignlen = 0;
+
+ char *eptr = Nullch;
+ STRLEN elen = 0;
+ char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
+
+ static char *efloatbuf = Nullch;
+ static STRLEN efloatsize = 0;
+
+ char c;
+ int i;
+ unsigned base;
+ IV iv;
+ UV uv;
+ double nv;
+ STRLEN have;
+ STRLEN need;
+ STRLEN gap;
+
+ for (q = p; q < patend && *q != '%'; ++q) ;
+ if (q > p) {
+ sv_catpvn(sv, p, q - p);
+ p = q;
+ }
+ if (q++ >= patend)
+ break;
+
+ /* FLAGS */
+
+ while (*q) {
+ switch (*q) {
+ case ' ':
+ case '+':
+ plus = *q++;
+ continue;
+
+ case '-':
+ left = TRUE;
+ q++;
+ continue;
+
+ case '0':
+ fill = *q++;
+ continue;
+
+ case '#':
+ alt = TRUE;
+ q++;
+ continue;
+
+ default:
+ break;
+ }
+ break;
+ }
+
+ /* WIDTH */
+
+ switch (*q) {
+ case '1': case '2': case '3':
+ case '4': case '5': case '6':
+ case '7': case '8': case '9':
+ width = 0;
+ while (isDIGIT(*q))
+ width = width * 10 + (*q++ - '0');
+ break;
+
+ case '*':
+ if (args)
+ i = va_arg(*args, int);
+ else
+ i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+ left |= (i < 0);
+ width = (i < 0) ? -i : i;
+ q++;
+ break;
+ }
+
+ /* PRECISION */
+
+ if (*q == '.') {
+ q++;
+ if (*q == '*') {
+ if (args)
+ i = va_arg(*args, int);
+ else
+ i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+ precis = (i < 0) ? 0 : i;
+ q++;
+ }
+ else {
+ precis = 0;
+ while (isDIGIT(*q))
+ precis = precis * 10 + (*q++ - '0');
+ }
+ has_precis = TRUE;
+ }
+
+ /* SIZE */
+
+ switch (*q) {
+ case 'l':
+#if 0 /* when quads have better support within Perl */
+ if (*(q + 1) == 'l') {
+ intsize = 'q';
+ q += 2;
+ break;
+ }
+#endif
+ /* FALL THROUGH */
+ case 'h':
+ case 'V':
+ intsize = *q++;
+ break;
+ }
+
+ /* CONVERSION */
+
+ switch (c = *q++) {
+
+ /* STRINGS */
+
+ case '%':
+ eptr = q - 1;
+ elen = 1;
+ goto string;
+
+ case 'c':
+ if (args)
+ c = va_arg(*args, int);
+ else
+ c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+ eptr = &c;
+ elen = 1;
+ goto string;
+
+ case 's':
+ if (args) {
+ eptr = va_arg(*args, char*);
+ if (eptr)
+ elen = strlen(eptr);
+ else {
+ eptr = nullstr;
+ elen = sizeof nullstr - 1;
+ }
+ }
+ else if (svix < svmax)
+ eptr = SvPVx(svargs[svix++], elen);
+ goto string;
+
+ case '_':
+ /*
+ * The "%_" hack might have to be changed someday,
+ * if ISO or ANSI decide to use '_' for something.
+ * So we keep it hidden from users' code.
+ */
+ if (!args)
+ goto unknown;
+ eptr = SvPVx(va_arg(*args, SV*), elen);
+
+ string:
+ if (has_precis && elen > precis)
+ elen = precis;
+ break;
+
+ /* INTEGERS */
+
+ case 'p':
+ if (args)
+ uv = (UV)va_arg(*args, void*);
+ else
+ uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
+ base = 16;
+ goto integer;
+
+ case 'D':
+ intsize = 'l';
+ /* FALL THROUGH */
+ case 'd':
+ case 'i':
+ if (args) {
+ switch (intsize) {
+ case 'h': iv = (short)va_arg(*args, int); break;
+ default: iv = va_arg(*args, int); break;
+ case 'l': iv = va_arg(*args, long); break;
+ case 'V': iv = va_arg(*args, IV); break;
+ }
+ }
+ else {
+ iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+ switch (intsize) {
+ case 'h': iv = (short)iv; break;
+ default: iv = (int)iv; break;
+ case 'l': iv = (long)iv; break;
+ case 'V': break;
+ }
+ }
+ if (iv >= 0) {
+ uv = iv;
+ if (plus)
+ esignbuf[esignlen++] = plus;
+ }
+ else {
+ uv = -iv;
+ esignbuf[esignlen++] = '-';
+ }
+ base = 10;
+ goto integer;
+
+ case 'U':
+ intsize = 'l';
+ /* FALL THROUGH */
+ case 'u':
+ base = 10;
+ goto uns_integer;
+
+ case 'O':
+ intsize = 'l';
+ /* FALL THROUGH */
+ case 'o':
+ base = 8;
+ goto uns_integer;
+
+ case 'X':
+ case 'x':
+ base = 16;
+
+ uns_integer:
+ if (args) {
+ switch (intsize) {
+ case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
+ default: uv = va_arg(*args, unsigned); break;
+ case 'l': uv = va_arg(*args, unsigned long); break;
+ case 'V': uv = va_arg(*args, UV); break;
+ }
+ }
+ else {
+ uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
+ switch (intsize) {
+ case 'h': uv = (unsigned short)uv; break;
+ default: uv = (unsigned)uv; break;
+ case 'l': uv = (unsigned long)uv; break;
+ case 'V': break;
+ }
+ }
+
+ integer:
+ eptr = ebuf + sizeof ebuf;
+ switch (base) {
+ unsigned dig;
+ case 16:
+ if (!uv)
+ alt = FALSE;
+ p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
+ do {
+ dig = uv & 15;
+ *--eptr = p[dig];
+ } while (uv >>= 4);
+ if (alt) {
+ esignbuf[esignlen++] = '0';
+ esignbuf[esignlen++] = c; /* 'x' or 'X' */
+ }
+ break;
+ case 8:
+ do {
+ dig = uv & 7;
+ *--eptr = '0' + dig;
+ } while (uv >>= 3);
+ if (alt && *eptr != '0')
+ *--eptr = '0';
+ break;
+ default: /* it had better be ten or less */
+ do {
+ dig = uv % base;
+ *--eptr = '0' + dig;
+ } while (uv /= base);
+ break;
+ }
+ elen = (ebuf + sizeof ebuf) - eptr;
+ if (has_precis) {
+ if (precis > elen)
+ zeros = precis - elen;
+ else if (precis == 0 && elen == 1 && *eptr == '0')
+ elen = 0;
+ }
+ break;
+
+ /* FLOATING POINT */
+
+ case 'F':
+ c = 'f'; /* maybe %F isn't supported here */
+ /* FALL THROUGH */
+ case 'e': case 'E':
+ case 'f':
+ case 'g': case 'G':
+
+ /* This is evil, but floating point is even more evil */
+
+ if (args)
+ nv = va_arg(*args, double);
+ else
+ nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
+
+ need = 0;
+ if (c != 'e' && c != 'E') {
+ i = PERL_INT_MIN;
+ (void)frexp(nv, &i);
+ if (i == PERL_INT_MIN)
+ die("panic: frexp");
+ if (i > 0)
+ need = BIT_DIGITS(i);
+ }
+ need += has_precis ? precis : 6; /* known default */
+ if (need < width)
+ need = width;
+
+ need += 20; /* fudge factor */
+ if (efloatsize < need) {
+ Safefree(efloatbuf);
+ efloatsize = need + 20; /* more fudge */
+ New(906, efloatbuf, efloatsize, char);
+ }
+
+ eptr = ebuf + sizeof ebuf;
+ *--eptr = '\0';
+ *--eptr = c;
+ if (has_precis) {
+ base = precis;
+ do { *--eptr = '0' + (base % 10); } while (base /= 10);
+ *--eptr = '.';
+ }
+ if (width) {
+ base = width;
+ do { *--eptr = '0' + (base % 10); } while (base /= 10);
+ }
+ if (fill == '0')
+ *--eptr = fill;
+ if (left)
+ *--eptr = '-';
+ if (plus)
+ *--eptr = plus;
+ if (alt)
+ *--eptr = '#';
+ *--eptr = '%';
+
+ (void)sprintf(efloatbuf, eptr, nv);
+
+ eptr = efloatbuf;
+ elen = strlen(efloatbuf);
+
+#ifdef LC_NUMERIC
+ /*
+ * User-defined locales may include arbitrary characters.
+ * And, unfortunately, some system may alloc the "C" locale
+ * to be overridden by a malicious user.
+ */
+ if (used_locale)
+ *used_locale = TRUE;
+#endif /* LC_NUMERIC */
+
+ break;
+
+ /* SPECIAL */
+
+ case 'n':
+ i = SvCUR(sv) - origlen;
+ if (args) {
+ switch (intsize) {
+ case 'h': *(va_arg(*args, short*)) = i; break;
+ default: *(va_arg(*args, int*)) = i; break;
+ case 'l': *(va_arg(*args, long*)) = i; break;
+ case 'V': *(va_arg(*args, IV*)) = i; break;
+ }
+ }
+ else if (svix < svmax)
+ sv_setuv(svargs[svix++], (UV)i);
+ continue; /* not "break" */
+
+ /* UNKNOWN */
+
+ default:
+ unknown:
+ if (!args && PL_dowarn &&
+ (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
+ SV *msg = sv_newmortal();
+ sv_setpvf(msg, "Invalid conversion in %s: ",
+ (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
+ if (c)
+ sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
+ c & 0xFF);
+ else
+ sv_catpv(msg, "end of string");
+ warn("%_", msg); /* yes, this is reentrant */
+ }
+
+ /* output mangled stuff ... */
+ if (c == '\0')
+ --q;
+ eptr = p;
+ elen = q - p;
+
+ /* ... right here, because formatting flags should not apply */
+ SvGROW(sv, SvCUR(sv) + elen + 1);
+ p = SvEND(sv);
+ memcpy(p, eptr, elen);
+ p += elen;
+ *p = '\0';
+ SvCUR(sv) = p - SvPVX(sv);
+ continue; /* not "break" */
+ }
+
+ have = esignlen + zeros + elen;
+ need = (have > width ? have : width);
+ gap = need - have;
+
+ SvGROW(sv, SvCUR(sv) + need + 1);
+ p = SvEND(sv);
+ if (esignlen && fill == '0') {
+ for (i = 0; i < esignlen; i++)
+ *p++ = esignbuf[i];
+ }
+ if (gap && !left) {
+ memset(p, fill, gap);
+ p += gap;
+ }
+ if (esignlen && fill != '0') {
+ for (i = 0; i < esignlen; i++)
+ *p++ = esignbuf[i];
+ }
+ if (zeros) {
+ for (i = zeros; i; i--)
+ *p++ = '0';
+ }
+ if (elen) {
+ memcpy(p, eptr, elen);
+ p += elen;
+ }
+ if (gap && left) {
+ memset(p, ' ', gap);
+ p += gap;
+ }
+ *p = '\0';
+ SvCUR(sv) = p - SvPVX(sv);
+ }
+}
+
+void
+sv_dump(SV *sv)
+{
+#ifdef DEBUGGING
+ SV *d = sv_newmortal();
+ char *s;
+ U32 flags;
+ U32 type;
+
+ if (!sv) {
+ PerlIO_printf(Perl_debug_log, "SV = 0\n");
+ return;
+ }
+
+ flags = SvFLAGS(sv);
+ type = SvTYPE(sv);
+
+ sv_setpvf(d, "(0x%lx)\n REFCNT = %ld\n FLAGS = (",
+ (unsigned long)SvANY(sv), (long)SvREFCNT(sv));
+ if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,");
+ if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
+ if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
+ if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
+ if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
+ if (flags & SVs_GMG) sv_catpv(d, "GMG,");
+ if (flags & SVs_SMG) sv_catpv(d, "SMG,");
+ if (flags & SVs_RMG) sv_catpv(d, "RMG,");
+
+ if (flags & SVf_IOK) sv_catpv(d, "IOK,");
+ if (flags & SVf_NOK) sv_catpv(d, "NOK,");
+ if (flags & SVf_POK) sv_catpv(d, "POK,");
+ if (flags & SVf_ROK) sv_catpv(d, "ROK,");
+ if (flags & SVf_OOK) sv_catpv(d, "OOK,");
+ if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
+ if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
+
+#ifdef OVERLOAD
+ if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
+#endif /* OVERLOAD */
+ if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
+ if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
+ if (flags & SVp_POK) sv_catpv(d, "pPOK,");
+ if (flags & SVp_SCREAM) sv_catpv(d, "SCREAM,");
+
+ switch (type) {
+ case SVt_PVCV:
+ case SVt_PVFM:
+ if (CvANON(sv)) sv_catpv(d, "ANON,");
+ if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
+ if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
+ if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
+ if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
+ break;
+ case SVt_PVHV:
+ if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
+ if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
+ break;
+ case SVt_PVGV:
+ if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
+ if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
+ if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
+ if (GvIMPORTED(sv)) {
+ sv_catpv(d, "IMPORT");
+ if (GvIMPORTED(sv) == GVf_IMPORTED)
+ sv_catpv(d, "ALL,");
+ else {
+ sv_catpv(d, "(");
+ if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
+ if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
+ if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
+ if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
+ sv_catpv(d, " ),");
+ }
+ }
+ case SVt_PVBM:
+ if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
+ if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
+ break;
+ }
+
+ if (*(SvEND(d) - 1) == ',')
+ SvPVX(d)[--SvCUR(d)] = '\0';
+ sv_catpv(d, ")");
+ s = SvPVX(d);
+
+ PerlIO_printf(Perl_debug_log, "SV = ");
+ switch (type) {
+ case SVt_NULL:
+ PerlIO_printf(Perl_debug_log, "NULL%s\n", s);
+ return;
+ case SVt_IV:
+ PerlIO_printf(Perl_debug_log, "IV%s\n", s);
+ break;
+ case SVt_NV:
+ PerlIO_printf(Perl_debug_log, "NV%s\n", s);
+ break;
+ case SVt_RV:
+ PerlIO_printf(Perl_debug_log, "RV%s\n", s);
+ break;
+ case SVt_PV:
+ PerlIO_printf(Perl_debug_log, "PV%s\n", s);
+ break;
+ case SVt_PVIV:
+ PerlIO_printf(Perl_debug_log, "PVIV%s\n", s);
+ break;
+ case SVt_PVNV:
+ PerlIO_printf(Perl_debug_log, "PVNV%s\n", s);
+ break;
+ case SVt_PVBM:
+ PerlIO_printf(Perl_debug_log, "PVBM%s\n", s);
+ break;
+ case SVt_PVMG:
+ PerlIO_printf(Perl_debug_log, "PVMG%s\n", s);
+ break;
+ case SVt_PVLV:
+ PerlIO_printf(Perl_debug_log, "PVLV%s\n", s);
+ break;
+ case SVt_PVAV:
+ PerlIO_printf(Perl_debug_log, "PVAV%s\n", s);
+ break;
+ case SVt_PVHV:
+ PerlIO_printf(Perl_debug_log, "PVHV%s\n", s);
+ break;
+ case SVt_PVCV:
+ PerlIO_printf(Perl_debug_log, "PVCV%s\n", s);
+ break;
+ case SVt_PVGV:
+ PerlIO_printf(Perl_debug_log, "PVGV%s\n", s);
+ break;
+ case SVt_PVFM:
+ PerlIO_printf(Perl_debug_log, "PVFM%s\n", s);
+ break;
+ case SVt_PVIO:
+ PerlIO_printf(Perl_debug_log, "PVIO%s\n", s);
+ break;
+ default:
+ PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", s);
+ return;
+ }
+ if (type >= SVt_PVIV || type == SVt_IV)
+ PerlIO_printf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv));
+ if (type >= SVt_PVNV || type == SVt_NV) {
+ SET_NUMERIC_STANDARD();
+ PerlIO_printf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
+ }
+ if (SvROK(sv)) {
+ PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv));
+ sv_dump(SvRV(sv));
+ return;
+ }
+ if (type < SVt_PV)
+ return;
+ if (type <= SVt_PVLV) {
+ if (SvPVX(sv))
+ PerlIO_printf(Perl_debug_log, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n",
+ (long)SvPVX(sv), SvPVX(sv), (long)SvCUR(sv), (long)SvLEN(sv));
+ else
+ PerlIO_printf(Perl_debug_log, " PV = 0\n");
+ }
+ if (type >= SVt_PVMG) {
+ if (SvMAGIC(sv)) {
+ PerlIO_printf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv));
+ }
+ if (SvSTASH(sv))
+ PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv)));
+ }
+ switch (type) {
+ case SVt_PVLV:
+ PerlIO_printf(Perl_debug_log, " TYPE = %c\n", LvTYPE(sv));
+ PerlIO_printf(Perl_debug_log, " TARGOFF = %ld\n", (long)LvTARGOFF(sv));
+ PerlIO_printf(Perl_debug_log, " TARGLEN = %ld\n", (long)LvTARGLEN(sv));
+ PerlIO_printf(Perl_debug_log, " TARG = 0x%lx\n", (long)LvTARG(sv));
+ sv_dump(LvTARG(sv));
+ break;
+ case SVt_PVAV:
+ PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv));
+ PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv));
+ PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILLp(sv));
+ PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv));
+ PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
+ flags = AvFLAGS(sv);
+ sv_setpv(d, "");
+ if (flags & AVf_REAL) sv_catpv(d, ",REAL");
+ if (flags & AVf_REIFY) sv_catpv(d, ",REIFY");
+ if (flags & AVf_REUSED) sv_catpv(d, ",REUSED");
+ PerlIO_printf(Perl_debug_log, " FLAGS = (%s)\n",
+ SvCUR(d) ? SvPVX(d) + 1 : "");
+ break;
+ case SVt_PVHV:
+ PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n",(long)HvARRAY(sv));
+ PerlIO_printf(Perl_debug_log, " KEYS = %ld\n", (long)HvKEYS(sv));
+ PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)HvFILL(sv));
+ PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)HvMAX(sv));
+ PerlIO_printf(Perl_debug_log, " RITER = %ld\n", (long)HvRITER(sv));
+ PerlIO_printf(Perl_debug_log, " EITER = 0x%lx\n",(long) HvEITER(sv));
+ if (HvPMROOT(sv))
+ PerlIO_printf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
+ if (HvNAME(sv))
+ PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv));
+ break;
+ case SVt_PVCV:
+ if (SvPOK(sv))
+ PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,PL_na));
+ /* FALL THROUGH */
+ case SVt_PVFM:
+ PerlIO_printf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv));
+ PerlIO_printf(Perl_debug_log, " START = 0x%lx\n", (long)CvSTART(sv));
+ PerlIO_printf(Perl_debug_log, " ROOT = 0x%lx\n", (long)CvROOT(sv));
+ PerlIO_printf(Perl_debug_log, " XSUB = 0x%lx\n", (long)CvXSUB(sv));
+ PerlIO_printf(Perl_debug_log, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32);
+ PerlIO_printf(Perl_debug_log, " GV = 0x%lx", (long)CvGV(sv));
+ if (CvGV(sv) && GvNAME(CvGV(sv))) {
+ PerlIO_printf(Perl_debug_log, " \"%s\"\n", GvNAME(CvGV(sv)));
+ } else {
+ PerlIO_printf(Perl_debug_log, "\n");
+ }
+ PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv));
+ PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv));
+ PerlIO_printf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv));
+ PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv));
+#ifdef USE_THREADS
+ PerlIO_printf(Perl_debug_log, " MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv));
+ PerlIO_printf(Perl_debug_log, " OWNER = 0x%lx\n", (long)CvOWNER(sv));
+#endif /* USE_THREADS */
+ PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n",
+ (unsigned long)CvFLAGS(sv));
+ if (type == SVt_PVFM)
+ PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv));
+ break;
+ case SVt_PVGV:
+ PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv));
+ PerlIO_printf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv));
+ PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n",
+ SvTYPE(GvSTASH(sv)) == SVt_PVHV ? HvNAME(GvSTASH(sv)) : "(deleted)");
+ PerlIO_printf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv));
+ PerlIO_printf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv));
+ PerlIO_printf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv));
+ PerlIO_printf(Perl_debug_log, " IO = 0x%lx\n", (long)GvIOp(sv));
+ PerlIO_printf(Perl_debug_log, " FORM = 0x%lx\n", (long)GvFORM(sv));
+ PerlIO_printf(Perl_debug_log, " AV = 0x%lx\n", (long)GvAV(sv));
+ PerlIO_printf(Perl_debug_log, " HV = 0x%lx\n", (long)GvHV(sv));
+ PerlIO_printf(Perl_debug_log, " CV = 0x%lx\n", (long)GvCV(sv));
+ PerlIO_printf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv));
+ PerlIO_printf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv));
+ PerlIO_printf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv));
+ PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)GvFILEGV(sv));
+ PerlIO_printf(Perl_debug_log, " EGV = 0x%lx\n", (long)GvEGV(sv));
+ break;
+ case SVt_PVIO:
+ PerlIO_printf(Perl_debug_log, " IFP = 0x%lx\n", (long)IoIFP(sv));
+ PerlIO_printf(Perl_debug_log, " OFP = 0x%lx\n", (long)IoOFP(sv));
+ PerlIO_printf(Perl_debug_log, " DIRP = 0x%lx\n", (long)IoDIRP(sv));
+ PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)IoLINES(sv));
+ PerlIO_printf(Perl_debug_log, " PAGE = %ld\n", (long)IoPAGE(sv));
+ PerlIO_printf(Perl_debug_log, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv));
+ PerlIO_printf(Perl_debug_log, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv));
+ PerlIO_printf(Perl_debug_log, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
+ PerlIO_printf(Perl_debug_log, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv));
+ PerlIO_printf(Perl_debug_log, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
+ PerlIO_printf(Perl_debug_log, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv));
+ PerlIO_printf(Perl_debug_log, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
+ PerlIO_printf(Perl_debug_log, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv));
+ PerlIO_printf(Perl_debug_log, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv));
+ PerlIO_printf(Perl_debug_log, " TYPE = %c\n", IoTYPE(sv));
+ PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv));
+ break;
+ }
+#endif /* DEBUGGING */
+}
diff --git a/contrib/perl5/sv.h b/contrib/perl5/sv.h
new file mode 100644
index 000000000000..3dac54829160
--- /dev/null
+++ b/contrib/perl5/sv.h
@@ -0,0 +1,669 @@
+/* sv.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+#ifdef sv_flags
+#undef sv_flags /* Convex has this in <signal.h> for sigvec() */
+#endif
+
+typedef enum {
+ SVt_NULL, /* 0 */
+ SVt_IV, /* 1 */
+ SVt_NV, /* 2 */
+ SVt_RV, /* 3 */
+ SVt_PV, /* 4 */
+ SVt_PVIV, /* 5 */
+ SVt_PVNV, /* 6 */
+ SVt_PVMG, /* 7 */
+ SVt_PVBM, /* 8 */
+ SVt_PVLV, /* 9 */
+ SVt_PVAV, /* 10 */
+ SVt_PVHV, /* 11 */
+ SVt_PVCV, /* 12 */
+ SVt_PVGV, /* 13 */
+ SVt_PVFM, /* 14 */
+ SVt_PVIO /* 15 */
+} svtype;
+
+/* Using C's structural equivalence to help emulate C++ inheritance here... */
+
+struct sv {
+ void* sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ U32 sv_flags; /* what we are */
+};
+
+struct gv {
+ XPVGV* sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ U32 sv_flags; /* what we are */
+};
+
+struct cv {
+ XPVCV* sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ U32 sv_flags; /* what we are */
+};
+
+struct av {
+ XPVAV* sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ U32 sv_flags; /* what we are */
+};
+
+struct hv {
+ XPVHV* sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ U32 sv_flags; /* what we are */
+};
+
+struct io {
+ XPVIO* sv_any; /* pointer to something */
+ U32 sv_refcnt; /* how many references to us */
+ U32 sv_flags; /* what we are */
+};
+
+#define SvANY(sv) (sv)->sv_any
+#define SvFLAGS(sv) (sv)->sv_flags
+#define SvREFCNT(sv) (sv)->sv_refcnt
+
+#ifdef USE_THREADS
+
+# ifdef EMULATE_ATOMIC_REFCOUNTS
+# define ATOMIC_INC(count) STMT_START { \
+ MUTEX_LOCK(&PL_svref_mutex); \
+ ++count; \
+ MUTEX_UNLOCK(&PL_svref_mutex); \
+ } STMT_END
+# define ATOMIC_DEC_AND_TEST(res,count) STMT_START { \
+ MUTEX_LOCK(&PL_svref_mutex); \
+ res = (--count == 0); \
+ MUTEX_UNLOCK(&PL_svref_mutex); \
+ } STMT_END
+# else
+# define ATOMIC_INC(count) atomic_inc(&count)
+# define ATOMIC_DEC_AND_TEST(res,count) (res = atomic_dec_and_test(&count))
+# endif /* EMULATE_ATOMIC_REFCOUNTS */
+#else
+# define ATOMIC_INC(count) (++count)
+# define ATOMIC_DEC_AND_TEST(res, count) (res = (--count == 0))
+#endif /* USE_THREADS */
+
+#ifdef __GNUC__
+# define SvREFCNT_inc(sv) \
+ ({ \
+ SV *nsv = (SV*)(sv); \
+ if (nsv) \
+ ATOMIC_INC(SvREFCNT(nsv)); \
+ nsv; \
+ })
+#else
+# if defined(CRIPPLED_CC) || defined(USE_THREADS)
+# define SvREFCNT_inc(sv) sv_newref((SV*)sv)
+# else
+# define SvREFCNT_inc(sv) \
+ ((PL_Sv=(SV*)(sv)), (PL_Sv && ATOMIC_INC(SvREFCNT(PL_Sv))), (SV*)PL_Sv)
+# endif
+#endif
+
+#define SvREFCNT_dec(sv) sv_free((SV*)sv)
+
+#define SVTYPEMASK 0xff
+#define SvTYPE(sv) ((sv)->sv_flags & SVTYPEMASK)
+
+#define SvUPGRADE(sv, mt) (SvTYPE(sv) >= mt || sv_upgrade(sv, mt))
+
+#define SVs_PADBUSY 0x00000100 /* reserved for tmp or my already */
+#define SVs_PADTMP 0x00000200 /* in use as tmp */
+#define SVs_PADMY 0x00000400 /* in use a "my" variable */
+#define SVs_TEMP 0x00000800 /* string is stealable? */
+#define SVs_OBJECT 0x00001000 /* is "blessed" */
+#define SVs_GMG 0x00002000 /* has magical get method */
+#define SVs_SMG 0x00004000 /* has magical set method */
+#define SVs_RMG 0x00008000 /* has random magical methods */
+
+#define SVf_IOK 0x00010000 /* has valid public integer value */
+#define SVf_NOK 0x00020000 /* has valid public numeric value */
+#define SVf_POK 0x00040000 /* has valid public pointer value */
+#define SVf_ROK 0x00080000 /* has a valid reference pointer */
+
+#define SVf_FAKE 0x00100000 /* glob or lexical is just a copy */
+#define SVf_OOK 0x00200000 /* has valid offset value */
+#define SVf_BREAK 0x00400000 /* refcnt is artificially low */
+#define SVf_READONLY 0x00800000 /* may not be modified */
+
+#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK)
+
+#define SVp_IOK 0x01000000 /* has valid non-public integer value */
+#define SVp_NOK 0x02000000 /* has valid non-public numeric value */
+#define SVp_POK 0x04000000 /* has valid non-public pointer value */
+#define SVp_SCREAM 0x08000000 /* has been studied? */
+
+#define SVf_OK (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \
+ SVp_IOK|SVp_NOK|SVp_POK)
+
+#ifdef OVERLOAD
+#define SVf_AMAGIC 0x10000000 /* has magical overloaded methods */
+#else
+#define SVf_AMAGIC 0 /* can be or-ed without effect */
+#endif /* OVERLOAD */
+
+#define PRIVSHIFT 8
+
+/* Some private flags. */
+
+#define SVpfm_COMPILED 0x80000000
+
+#define SVpbm_VALID 0x80000000
+#define SVpbm_TAIL 0x40000000
+
+#define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */
+#define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */
+
+struct xrv {
+ SV * xrv_rv; /* pointer to another SV */
+};
+
+struct xpv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+};
+
+struct xpviv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xiv_iv; /* integer value or pv offset */
+};
+
+struct xpvuv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ UV xuv_uv; /* unsigned value or pv offset */
+};
+
+struct xpvnv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+};
+
+/* These structure must match the beginning of struct xpvhv in hv.h. */
+struct xpvmg {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+};
+
+struct xpvlv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+
+ STRLEN xlv_targoff;
+ STRLEN xlv_targlen;
+ SV* xlv_targ;
+ char xlv_type;
+};
+
+struct xpvgv {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+
+ GP* xgv_gp;
+ char* xgv_name;
+ STRLEN xgv_namelen;
+ HV* xgv_stash;
+ U8 xgv_flags;
+};
+
+struct xpvbm {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+
+ I32 xbm_useful; /* is this constant pattern being useful? */
+ U16 xbm_previous; /* how many characters in string before rare? */
+ U8 xbm_rare; /* rarest character in string */
+};
+
+/* This structure much match XPVCV */
+
+typedef U16 cv_flags_t;
+
+struct xpvfm {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+
+ HV * xcv_stash;
+ OP * xcv_start;
+ OP * xcv_root;
+ void (*xcv_xsub)_((CV* _CPERLproto));
+ ANY xcv_xsubany;
+ GV * xcv_gv;
+ GV * xcv_filegv;
+ long xcv_depth; /* >= 2 indicates recursive call */
+ AV * xcv_padlist;
+ CV * xcv_outside;
+#ifdef USE_THREADS
+ perl_mutex *xcv_mutexp; /* protects xcv_owner */
+ struct perl_thread *xcv_owner; /* current owner thread */
+#endif /* USE_THREADS */
+ cv_flags_t xcv_flags;
+
+ I32 xfm_lines;
+};
+
+struct xpvio {
+ char * xpv_pv; /* pointer to malloced string */
+ STRLEN xpv_cur; /* length of xpv_pv as a C string */
+ STRLEN xpv_len; /* allocated size */
+ IV xiv_iv; /* integer value or pv offset */
+ double xnv_nv; /* numeric value, if any */
+ MAGIC* xmg_magic; /* linked list of magicalness */
+ HV* xmg_stash; /* class package */
+
+ PerlIO * xio_ifp; /* ifp and ofp are normally the same */
+ PerlIO * xio_ofp; /* but sockets need separate streams */
+ DIR * xio_dirp; /* for opendir, readdir, etc */
+ long xio_lines; /* $. */
+ long xio_page; /* $% */
+ long xio_page_len; /* $= */
+ long xio_lines_left; /* $- */
+ char * xio_top_name; /* $^ */
+ GV * xio_top_gv; /* $^ */
+ char * xio_fmt_name; /* $~ */
+ GV * xio_fmt_gv; /* $~ */
+ char * xio_bottom_name;/* $^B */
+ GV * xio_bottom_gv; /* $^B */
+ short xio_subprocess; /* -| or |- */
+ char xio_type;
+ char xio_flags;
+};
+
+#define IOf_ARGV 1 /* this fp iterates over ARGV */
+#define IOf_START 2 /* check for null ARGV and substitute '-' */
+#define IOf_FLUSH 4 /* this fp wants a flush after write op */
+#define IOf_DIDTOP 8 /* just did top of form */
+#define IOf_UNTAINT 16 /* consider this fp (and it's data) "safe" */
+
+/* The following macros define implementation-independent predicates on SVs. */
+
+#define SvNIOK(sv) (SvFLAGS(sv) & (SVf_IOK|SVf_NOK))
+#define SvNIOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK))
+#define SvNIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK| \
+ SVp_IOK|SVp_NOK))
+
+#define SvOK(sv) (SvFLAGS(sv) & SVf_OK)
+#define SvOK_off(sv) (SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC), \
+ SvOOK_off(sv))
+
+#define SvOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK))
+#define SvIOKp(sv) (SvFLAGS(sv) & SVp_IOK)
+#define SvIOKp_on(sv) (SvOOK_off(sv), SvFLAGS(sv) |= SVp_IOK)
+#define SvNOKp(sv) (SvFLAGS(sv) & SVp_NOK)
+#define SvNOKp_on(sv) (SvFLAGS(sv) |= SVp_NOK)
+#define SvPOKp(sv) (SvFLAGS(sv) & SVp_POK)
+#define SvPOKp_on(sv) (SvFLAGS(sv) |= SVp_POK)
+
+#define SvIOK(sv) (SvFLAGS(sv) & SVf_IOK)
+#define SvIOK_on(sv) (SvOOK_off(sv), \
+ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
+#define SvIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK))
+#define SvIOK_only(sv) (SvOK_off(sv), \
+ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK))
+
+#define SvNOK(sv) (SvFLAGS(sv) & SVf_NOK)
+#define SvNOK_on(sv) (SvFLAGS(sv) |= (SVf_NOK|SVp_NOK))
+#define SvNOK_off(sv) (SvFLAGS(sv) &= ~(SVf_NOK|SVp_NOK))
+#define SvNOK_only(sv) (SvOK_off(sv), \
+ SvFLAGS(sv) |= (SVf_NOK|SVp_NOK))
+
+#define SvPOK(sv) (SvFLAGS(sv) & SVf_POK)
+#define SvPOK_on(sv) (SvFLAGS(sv) |= (SVf_POK|SVp_POK))
+#define SvPOK_off(sv) (SvFLAGS(sv) &= ~(SVf_POK|SVp_POK))
+#define SvPOK_only(sv) (SvFLAGS(sv) &= ~(SVf_OK|SVf_AMAGIC), \
+ SvFLAGS(sv) |= (SVf_POK|SVp_POK))
+
+#define SvOOK(sv) (SvFLAGS(sv) & SVf_OOK)
+#define SvOOK_on(sv) (SvIOK_off(sv), SvFLAGS(sv) |= SVf_OOK)
+#define SvOOK_off(sv) (SvOOK(sv) && sv_backoff(sv))
+
+#define SvFAKE(sv) (SvFLAGS(sv) & SVf_FAKE)
+#define SvFAKE_on(sv) (SvFLAGS(sv) |= SVf_FAKE)
+#define SvFAKE_off(sv) (SvFLAGS(sv) &= ~SVf_FAKE)
+
+#define SvROK(sv) (SvFLAGS(sv) & SVf_ROK)
+#define SvROK_on(sv) (SvFLAGS(sv) |= SVf_ROK)
+#define SvROK_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVf_AMAGIC))
+
+#define SvMAGICAL(sv) (SvFLAGS(sv) & (SVs_GMG|SVs_SMG|SVs_RMG))
+#define SvMAGICAL_on(sv) (SvFLAGS(sv) |= (SVs_GMG|SVs_SMG|SVs_RMG))
+#define SvMAGICAL_off(sv) (SvFLAGS(sv) &= ~(SVs_GMG|SVs_SMG|SVs_RMG))
+
+#define SvGMAGICAL(sv) (SvFLAGS(sv) & SVs_GMG)
+#define SvGMAGICAL_on(sv) (SvFLAGS(sv) |= SVs_GMG)
+#define SvGMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVs_GMG)
+
+#define SvSMAGICAL(sv) (SvFLAGS(sv) & SVs_SMG)
+#define SvSMAGICAL_on(sv) (SvFLAGS(sv) |= SVs_SMG)
+#define SvSMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVs_SMG)
+
+#define SvRMAGICAL(sv) (SvFLAGS(sv) & SVs_RMG)
+#define SvRMAGICAL_on(sv) (SvFLAGS(sv) |= SVs_RMG)
+#define SvRMAGICAL_off(sv) (SvFLAGS(sv) &= ~SVs_RMG)
+
+#ifdef OVERLOAD
+#define SvAMAGIC(sv) (SvFLAGS(sv) & SVf_AMAGIC)
+#define SvAMAGIC_on(sv) (SvFLAGS(sv) |= SVf_AMAGIC)
+#define SvAMAGIC_off(sv) (SvFLAGS(sv) &= ~SVf_AMAGIC)
+
+/*
+#define Gv_AMG(stash) \
+ (HV_AMAGICmb(stash) && \
+ ((!HV_AMAGICbad(stash) && HV_AMAGIC(stash)) || Gv_AMupdate(stash)))
+*/
+#define Gv_AMG(stash) (PL_amagic_generation && Gv_AMupdate(stash))
+#endif /* OVERLOAD */
+
+#define SvTHINKFIRST(sv) (SvFLAGS(sv) & SVf_THINKFIRST)
+
+#define SvPADBUSY(sv) (SvFLAGS(sv) & SVs_PADBUSY)
+
+#define SvPADTMP(sv) (SvFLAGS(sv) & SVs_PADTMP)
+#define SvPADTMP_on(sv) (SvFLAGS(sv) |= SVs_PADTMP|SVs_PADBUSY)
+#define SvPADTMP_off(sv) (SvFLAGS(sv) &= ~SVs_PADTMP)
+
+#define SvPADMY(sv) (SvFLAGS(sv) & SVs_PADMY)
+#define SvPADMY_on(sv) (SvFLAGS(sv) |= SVs_PADMY|SVs_PADBUSY)
+
+#define SvTEMP(sv) (SvFLAGS(sv) & SVs_TEMP)
+#define SvTEMP_on(sv) (SvFLAGS(sv) |= SVs_TEMP)
+#define SvTEMP_off(sv) (SvFLAGS(sv) &= ~SVs_TEMP)
+
+#define SvOBJECT(sv) (SvFLAGS(sv) & SVs_OBJECT)
+#define SvOBJECT_on(sv) (SvFLAGS(sv) |= SVs_OBJECT)
+#define SvOBJECT_off(sv) (SvFLAGS(sv) &= ~SVs_OBJECT)
+
+#define SvREADONLY(sv) (SvFLAGS(sv) & SVf_READONLY)
+#define SvREADONLY_on(sv) (SvFLAGS(sv) |= SVf_READONLY)
+#define SvREADONLY_off(sv) (SvFLAGS(sv) &= ~SVf_READONLY)
+
+#define SvSCREAM(sv) (SvFLAGS(sv) & SVp_SCREAM)
+#define SvSCREAM_on(sv) (SvFLAGS(sv) |= SVp_SCREAM)
+#define SvSCREAM_off(sv) (SvFLAGS(sv) &= ~SVp_SCREAM)
+
+#define SvCOMPILED(sv) (SvFLAGS(sv) & SVpfm_COMPILED)
+#define SvCOMPILED_on(sv) (SvFLAGS(sv) |= SVpfm_COMPILED)
+#define SvCOMPILED_off(sv) (SvFLAGS(sv) &= ~SVpfm_COMPILED)
+
+#define SvTAIL(sv) (SvFLAGS(sv) & SVpbm_TAIL)
+#define SvTAIL_on(sv) (SvFLAGS(sv) |= SVpbm_TAIL)
+#define SvTAIL_off(sv) (SvFLAGS(sv) &= ~SVpbm_TAIL)
+
+#define SvVALID(sv) (SvFLAGS(sv) & SVpbm_VALID)
+#define SvVALID_on(sv) (SvFLAGS(sv) |= SVpbm_VALID)
+#define SvVALID_off(sv) (SvFLAGS(sv) &= ~SVpbm_VALID)
+
+#define SvRV(sv) ((XRV*) SvANY(sv))->xrv_rv
+#define SvRVx(sv) SvRV(sv)
+
+#define SvIVX(sv) ((XPVIV*) SvANY(sv))->xiv_iv
+#define SvIVXx(sv) SvIVX(sv)
+#define SvUVX(sv) ((XPVUV*) SvANY(sv))->xuv_uv
+#define SvUVXx(sv) SvUVX(sv)
+#define SvNVX(sv) ((XPVNV*)SvANY(sv))->xnv_nv
+#define SvNVXx(sv) SvNVX(sv)
+#define SvPVX(sv) ((XPV*) SvANY(sv))->xpv_pv
+#define SvPVXx(sv) SvPVX(sv)
+#define SvCUR(sv) ((XPV*) SvANY(sv))->xpv_cur
+#define SvLEN(sv) ((XPV*) SvANY(sv))->xpv_len
+#define SvLENx(sv) SvLEN(sv)
+#define SvEND(sv)(((XPV*) SvANY(sv))->xpv_pv + ((XPV*)SvANY(sv))->xpv_cur)
+#define SvENDx(sv) ((PL_Sv = (sv)), SvEND(PL_Sv))
+#define SvMAGIC(sv) ((XPVMG*) SvANY(sv))->xmg_magic
+#define SvSTASH(sv) ((XPVMG*) SvANY(sv))->xmg_stash
+
+#define SvIV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
+ (((XPVIV*) SvANY(sv))->xiv_iv = val); } STMT_END
+#define SvNV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) == SVt_NV || SvTYPE(sv) >= SVt_PVNV); \
+ (((XPVNV*) SvANY(sv))->xnv_nv = val); } STMT_END
+#define SvPV_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
+ (((XPV*) SvANY(sv))->xpv_pv = val); } STMT_END
+#define SvCUR_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
+ (((XPV*) SvANY(sv))->xpv_cur = val); } STMT_END
+#define SvLEN_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
+ (((XPV*) SvANY(sv))->xpv_len = val); } STMT_END
+#define SvEND_set(sv, val) \
+ STMT_START { assert(SvTYPE(sv) >= SVt_PV); \
+ (((XPV*) SvANY(sv))->xpv_cur = val - SvPVX(sv)); } STMT_END
+
+#define BmRARE(sv) ((XPVBM*) SvANY(sv))->xbm_rare
+#define BmUSEFUL(sv) ((XPVBM*) SvANY(sv))->xbm_useful
+#define BmPREVIOUS(sv) ((XPVBM*) SvANY(sv))->xbm_previous
+
+#define FmLINES(sv) ((XPVFM*) SvANY(sv))->xfm_lines
+
+#define LvTYPE(sv) ((XPVLV*) SvANY(sv))->xlv_type
+#define LvTARG(sv) ((XPVLV*) SvANY(sv))->xlv_targ
+#define LvTARGOFF(sv) ((XPVLV*) SvANY(sv))->xlv_targoff
+#define LvTARGLEN(sv) ((XPVLV*) SvANY(sv))->xlv_targlen
+
+#define IoIFP(sv) ((XPVIO*) SvANY(sv))->xio_ifp
+#define IoOFP(sv) ((XPVIO*) SvANY(sv))->xio_ofp
+#define IoDIRP(sv) ((XPVIO*) SvANY(sv))->xio_dirp
+#define IoLINES(sv) ((XPVIO*) SvANY(sv))->xio_lines
+#define IoPAGE(sv) ((XPVIO*) SvANY(sv))->xio_page
+#define IoPAGE_LEN(sv) ((XPVIO*) SvANY(sv))->xio_page_len
+#define IoLINES_LEFT(sv)((XPVIO*) SvANY(sv))->xio_lines_left
+#define IoTOP_NAME(sv) ((XPVIO*) SvANY(sv))->xio_top_name
+#define IoTOP_GV(sv) ((XPVIO*) SvANY(sv))->xio_top_gv
+#define IoFMT_NAME(sv) ((XPVIO*) SvANY(sv))->xio_fmt_name
+#define IoFMT_GV(sv) ((XPVIO*) SvANY(sv))->xio_fmt_gv
+#define IoBOTTOM_NAME(sv)((XPVIO*) SvANY(sv))->xio_bottom_name
+#define IoBOTTOM_GV(sv) ((XPVIO*) SvANY(sv))->xio_bottom_gv
+#define IoSUBPROCESS(sv)((XPVIO*) SvANY(sv))->xio_subprocess
+#define IoTYPE(sv) ((XPVIO*) SvANY(sv))->xio_type
+#define IoFLAGS(sv) ((XPVIO*) SvANY(sv))->xio_flags
+
+#define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
+#define SvTAINTED_on(sv) STMT_START{ if(PL_tainting){sv_taint(sv);} }STMT_END
+#define SvTAINTED_off(sv) STMT_START{ if(PL_tainting){sv_untaint(sv);} }STMT_END
+
+#define SvTAINT(sv) \
+ STMT_START { \
+ if (PL_tainting) { \
+ dTHR; \
+ if (PL_tainted) \
+ SvTAINTED_on(sv); \
+ } \
+ } STMT_END
+
+#define SvPV_force(sv, lp) sv_pvn_force(sv, &lp)
+#define SvPV(sv, lp) sv_pvn(sv, &lp)
+#define SvIVx(sv) sv_iv(sv)
+#define SvUVx(sv) sv_uv(sv)
+#define SvNVx(sv) sv_nv(sv)
+#define SvPVx(sv, lp) sv_pvn(sv, &lp)
+#define SvPVx_force(sv, lp) sv_pvn_force(sv, &lp)
+#define SvTRUEx(sv) sv_true(sv)
+
+#define SvIV(sv) SvIVx(sv)
+#define SvNV(sv) SvNVx(sv)
+#define SvUV(sv) SvIVx(sv)
+#define SvTRUE(sv) SvTRUEx(sv)
+
+#ifndef CRIPPLED_CC
+/* redefine some things to more efficient inlined versions */
+
+#undef SvIV
+#define SvIV(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv))
+
+#undef SvUV
+#define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
+
+#undef SvNV
+#define SvNV(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv))
+
+#undef SvPV
+#define SvPV(sv, lp) \
+ (SvPOK(sv) ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv(sv, &lp))
+
+#undef SvPV_force
+#define SvPV_force(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force(sv, &lp))
+
+#ifdef __GNUC__
+# undef SvIVx
+# undef SvUVx
+# undef SvNVx
+# undef SvPVx
+# undef SvTRUE
+# undef SvTRUEx
+# define SvIVx(sv) ({SV *nsv = (SV*)(sv); SvIV(nsv); })
+# define SvUVx(sv) ({SV *nsv = (SV*)(sv); SvUV(nsv); })
+# define SvNVx(sv) ({SV *nsv = (SV*)(sv); SvNV(nsv); })
+# define SvPVx(sv, lp) ({SV *nsv = (sv); SvPV(nsv, lp); })
+# define SvTRUE(sv) ( \
+ !sv \
+ ? 0 \
+ : SvPOK(sv) \
+ ? (({XPV *nxpv = (XPV*)SvANY(sv); \
+ nxpv && \
+ (*nxpv->xpv_pv > '0' || \
+ nxpv->xpv_cur > 1 || \
+ (nxpv->xpv_cur && *nxpv->xpv_pv != '0')); }) \
+ ? 1 \
+ : 0) \
+ : \
+ SvIOK(sv) \
+ ? SvIVX(sv) != 0 \
+ : SvNOK(sv) \
+ ? SvNVX(sv) != 0.0 \
+ : sv_2bool(sv) )
+# define SvTRUEx(sv) ({SV *nsv = (sv); SvTRUE(nsv); })
+#else /* __GNUC__ */
+#ifndef USE_THREADS
+/* These inlined macros use globals, which will require a thread
+ * declaration in user code, so we avoid them under threads */
+
+# undef SvIVx
+# undef SvUVx
+# undef SvNVx
+# undef SvPVx
+# undef SvTRUE
+# undef SvTRUEx
+# define SvIVx(sv) ((PL_Sv = (sv)), SvIV(PL_Sv))
+# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
+# define SvNVx(sv) ((PL_Sv = (sv)), SvNV(PL_Sv))
+# define SvPVx(sv, lp) ((PL_Sv = (sv)), SvPV(PL_Sv, lp))
+# define SvTRUE(sv) ( \
+ !sv \
+ ? 0 \
+ : SvPOK(sv) \
+ ? ((PL_Xpv = (XPV*)SvANY(sv)) && \
+ (*PL_Xpv->xpv_pv > '0' || \
+ PL_Xpv->xpv_cur > 1 || \
+ (PL_Xpv->xpv_cur && *PL_Xpv->xpv_pv != '0')) \
+ ? 1 \
+ : 0) \
+ : \
+ SvIOK(sv) \
+ ? SvIVX(sv) != 0 \
+ : SvNOK(sv) \
+ ? SvNVX(sv) != 0.0 \
+ : sv_2bool(sv) )
+# define SvTRUEx(sv) ((PL_Sv = (sv)), SvTRUE(PL_Sv))
+#endif /* !USE_THREADS */
+#endif /* !__GNU__ */
+#endif /* !CRIPPLED_CC */
+
+#define newRV_inc(sv) newRV(sv)
+
+/* the following macros update any magic values this sv is associated with */
+
+#define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+#define SvSETMAGIC(x) STMT_START { if (SvSMAGICAL(x)) mg_set(x); } STMT_END
+
+#define SvSetSV_and(dst,src,finally) \
+ STMT_START { \
+ if ((dst) != (src)) { \
+ sv_setsv(dst, src); \
+ finally; \
+ } \
+ } STMT_END
+#define SvSetSV_nosteal_and(dst,src,finally) \
+ STMT_START { \
+ if ((dst) != (src)) { \
+ U32 tMpF = SvFLAGS(src) & SVs_TEMP; \
+ SvTEMP_off(src); \
+ sv_setsv(dst, src); \
+ SvFLAGS(src) |= tMpF; \
+ finally; \
+ } \
+ } STMT_END
+
+#define SvSetSV(dst,src) \
+ SvSetSV_and(dst,src,/*nothing*/;)
+#define SvSetSV_nosteal(dst,src) \
+ SvSetSV_nosteal_and(dst,src,/*nothing*/;)
+
+#define SvSetMagicSV(dst,src) \
+ SvSetSV_and(dst,src,SvSETMAGIC(dst))
+#define SvSetMagicSV_nosteal(dst,src) \
+ SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst))
+
+#define SvPEEK(sv) sv_peek(sv)
+
+#define SvIMMORTAL(sv) ((sv)==&PL_sv_undef || (sv)==&PL_sv_yes || (sv)==&PL_sv_no)
+
+#define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+
+#define isGV(sv) (SvTYPE(sv) == SVt_PVGV)
+
+#ifndef DOSISH
+# define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv))
+# define Sv_Grow sv_grow
+#else
+ /* extra parentheses intentionally NOT placed around "len"! */
+# define SvGROW(sv,len) ((SvLEN(sv) < (unsigned long)len) \
+ ? sv_grow(sv,(unsigned long)len) : SvPVX(sv))
+# define Sv_Grow(sv,len) sv_grow(sv,(unsigned long)(len))
+#endif /* DOSISH */
diff --git a/contrib/perl5/t/README b/contrib/perl5/t/README
new file mode 100644
index 000000000000..838434917916
--- /dev/null
+++ b/contrib/perl5/t/README
@@ -0,0 +1,16 @@
+This is the perl test library. To run all the tests, just type 'TEST'.
+
+To add new tests, just look at the current tests and do likewise.
+
+If a test fails, run it by itself to see if it prints any informative
+diagnostics. If not, modify the test to print informative diagnostics.
+If you put out extra lines with a '#' character on the front, you don't
+have to worry about removing the extra print statements later since TEST
+ignores lines beginning with '#'.
+
+If you know that Perl is basically working but expect that some tests
+will fail, you may want to use Test::Harness thusly:
+ ./perl -I../lib harness
+This method pinpoints failed tests automatically.
+
+If you come up with new tests, please send them to larry@wall.org.
diff --git a/contrib/perl5/t/TEST b/contrib/perl5/t/TEST
new file mode 100755
index 000000000000..3685c2a45f08
--- /dev/null
+++ b/contrib/perl5/t/TEST
@@ -0,0 +1,181 @@
+#!./perl
+
+# Last change: Fri Jan 10 09:57:03 WET 1997
+
+# This is written in a peculiar style, since we're trying to avoid
+# most of the constructs we'll be testing for.
+
+$| = 1;
+
+if ($#ARGV >= 0 && $ARGV[0] eq '-v') {
+ $verbose = 1;
+ shift;
+}
+
+chdir 't' if -f 't/TEST';
+
+die "You need to run \"make test\" first to set things up.\n"
+ unless -e 'perl' or -e 'perl.exe';
+
+# check leakage for embedders
+$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
+
+$ENV{EMXSHELL} = 'sh'; # For OS/2
+
+if ($#ARGV == -1) {
+ @ARGV = split(/[ \n]/,
+ `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`);
+}
+
+%infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
+
+_testprogs('perl', @ARGV);
+_testprogs('compile', @ARGV) if (-e "../testcompile");
+
+sub _testprogs {
+ $type = shift @_;
+ @tests = @_;
+
+
+ print <<'EOT' if ($type eq 'compile');
+--------------------------------------------------------------------------------
+TESTING COMPILER
+--------------------------------------------------------------------------------
+EOT
+
+ $bad = 0;
+ $good = 0;
+ $total = @tests;
+ $files = 0;
+ $totmax = 0;
+ $maxlen = 0;
+ foreach (@tests) {
+ $len = length;
+ $maxlen = $len if $len > $maxlen;
+ }
+ # +3 : we want three dots between the test name and the "ok"
+ # -2 : the .t suffix
+ $dotdotdot = $maxlen + 3 - 2;
+ while ($test = shift @tests) {
+
+ if ( $infinite{$test} && $type eq 'compile' ) {
+ print STDERR "$test creates infinite loop! Skipping.\n";
+ next;
+ }
+ if ($test =~ /^$/) {
+ next;
+ }
+ $te = $test;
+ chop($te);
+ print "$te" . '.' x ($dotdotdot - length($te));
+
+ open(SCRIPT,"<$test") or die "Can't run $test.\n";
+ $_ = <SCRIPT>;
+ close(SCRIPT);
+ if (/#!.*perl(.*)$/) {
+ $switch = $1;
+ if ($^O eq 'VMS') {
+ # Must protect uppercase switches with "" on command line
+ $switch =~ s/-([A-Z]\S*)/"-$1"/g;
+ }
+ }
+ else {
+ $switch = '';
+ }
+
+ if ($type eq 'perl') {
+ open(RESULTS,"./perl$switch $test |") or print "can't run.\n";
+ }
+ else {
+ open(RESULTS, "./perl -I../lib ../utils/perlcc ./$test "
+ ."-run -verbose dcf -log ../compilelog |")
+ or print "can't compile.\n";
+ }
+
+ $ok = 0;
+ $next = 0;
+ while (<RESULTS>) {
+ if ($verbose) {
+ print $_;
+ }
+ unless (/^#/) {
+ if (/^1\.\.([0-9]+)/) {
+ $max = $1;
+ $totmax += $max;
+ $files += 1;
+ $next = 1;
+ $ok = 1;
+ }
+ else {
+ $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
+ if (/^ok (\d+)(\s*#.*)?$/ && $1 == $next) {
+ $next = $next + 1;
+ }
+ else {
+ $ok = 0;
+ }
+ }
+ }
+ }
+ close RESULTS;
+ $next = $next - 1;
+ if ($ok && $next == $max) {
+ if ($max) {
+ print "ok\n";
+ $good = $good + 1;
+ }
+ else {
+ print "skipping test on this platform\n";
+ $files -= 1;
+ }
+ }
+ else {
+ $next += 1;
+ print "FAILED at test $next\n";
+ $bad = $bad + 1;
+ $_ = $test;
+ if (/^base/) {
+ die "Failed a basic test--cannot continue.\n";
+ }
+ }
+ }
+
+ if ($bad == 0) {
+ if ($ok) {
+ print "All tests successful.\n";
+ # XXX add mention of 'perlbug -ok' ?
+ }
+ else {
+ die "FAILED--no tests were run for some reason.\n";
+ }
+ }
+ else {
+ $pct = sprintf("%.2f", $good / $total * 100);
+ if ($bad == 1) {
+ warn "Failed 1 test script out of $total, $pct% okay.\n";
+ }
+ else {
+ warn "Failed $bad test scripts out of $total, $pct% okay.\n";
+ }
+ warn <<'SHRDLU';
+ ### Since not all tests were successful, you may want to run some
+ ### of them individually and examine any diagnostic messages they
+ ### produce. See the INSTALL document's section on "make test".
+ ### If you are testing the compiler, then ignore this message
+ ### and run
+ ### ./perl harness
+ ### in the directory ./t.
+SHRDLU
+ warn <<'SHRDLU' if $good / $total > 0.8;
+ ###
+ ### Since most tests were successful, you have a good chance to
+ ### get information with better granularity by running
+ ### ./perl harness
+ ### in directory ./t.
+SHRDLU
+ }
+ ($user,$sys,$cuser,$csys) = times;
+ print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n",
+ $user,$sys,$cuser,$csys,$files,$totmax);
+}
+exit ($bad != 0);
diff --git a/contrib/perl5/t/base/cond.t b/contrib/perl5/t/base/cond.t
new file mode 100755
index 000000000000..9a57348474ec
--- /dev/null
+++ b/contrib/perl5/t/base/cond.t
@@ -0,0 +1,19 @@
+#!./perl
+
+# $RCSfile: cond.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:02 $
+
+# make sure conditional operators work
+
+print "1..4\n";
+
+$x = '0';
+
+$x eq $x && (print "ok 1\n");
+$x ne $x && (print "not ok 1\n");
+$x eq $x || (print "not ok 2\n");
+$x ne $x || (print "ok 2\n");
+
+$x == $x && (print "ok 3\n");
+$x != $x && (print "not ok 3\n");
+$x == $x || (print "not ok 4\n");
+$x != $x || (print "ok 4\n");
diff --git a/contrib/perl5/t/base/if.t b/contrib/perl5/t/base/if.t
new file mode 100755
index 000000000000..12db7652e49b
--- /dev/null
+++ b/contrib/perl5/t/base/if.t
@@ -0,0 +1,11 @@
+#!./perl
+
+# $RCSfile: if.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:03 $
+
+print "1..2\n";
+
+# first test to see if we can run the tests.
+
+$x = 'test';
+if ($x eq $x) { print "ok 1\n"; } else { print "not ok 1\n";}
+if ($x ne $x) { print "not ok 2\n"; } else { print "ok 2\n";}
diff --git a/contrib/perl5/t/base/lex.t b/contrib/perl5/t/base/lex.t
new file mode 100755
index 000000000000..045cb22eb075
--- /dev/null
+++ b/contrib/perl5/t/base/lex.t
@@ -0,0 +1,119 @@
+#!./perl
+
+# $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $
+
+print "1..30\n";
+
+$x = 'x';
+
+print "#1 :$x: eq :x:\n";
+if ($x eq 'x') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$x = $#; # this is the register $#
+
+if ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";}
+
+$x = $#x;
+
+if ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";}
+
+$x = '\\'; # ';
+
+if (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";}
+
+eval 'while (0) {
+ print "foo\n";
+}
+/^/ && (print "ok 5\n");
+';
+
+eval '$foo{1} / 1;';
+if (!$@) {print "ok 6\n";} else {print "not ok 6 $@\n";}
+
+eval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;';
+
+$foo = int($foo * 100 + .5);
+if ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7 :$foo:\n";}
+
+print <<'EOF';
+ok 8
+EOF
+
+$foo = 'ok 9';
+print <<EOF;
+$foo
+EOF
+
+eval <<\EOE, print $@;
+print <<'EOF';
+ok 10
+EOF
+
+$foo = 'ok 11';
+print <<EOF;
+$foo
+EOF
+EOE
+
+print <<`EOS` . <<\EOF;
+echo ok 12
+EOS
+ok 13
+EOF
+
+print qq/ok 14\n/;
+print qq(ok 15\n);
+
+print qq
+[ok 16\n]
+;
+
+print q<ok 17
+>;
+
+print <<; # Yow!
+ok 18
+
+# previous line intentionally left blank.
+
+print <<E1 eq "foo\n\n" ? "ok 19\n" : "not ok 19\n";
+@{[ <<E2 ]}
+foo
+E2
+E1
+
+print <<E1 eq "foo\n\n" ? "ok 20\n" : "not ok 20\n";
+@{[
+ <<E2
+foo
+E2
+]}
+E1
+
+$foo = FOO;
+$bar = BAR;
+$foo{$bar} = BAZ;
+$ary[0] = ABC;
+
+print "$foo{$bar}" eq "BAZ" ? "ok 21\n" : "not ok 21\n";
+
+print "${foo}{$bar}" eq "FOO{BAR}" ? "ok 22\n" : "not ok 22\n";
+print "${foo{$bar}}" eq "BAZ" ? "ok 23\n" : "not ok 23\n";
+
+print "FOO:" =~ /$foo[:]/ ? "ok 24\n" : "not ok 24\n";
+print "ABC" =~ /^$ary[$A]$/ ? "ok 25\n" : "not ok 25\n";
+print "FOOZ" =~ /^$foo[$A-Z]$/ ? "ok 26\n" : "not ok 26\n";
+
+# MJD 19980425
+($X, @X) = qw(a b c d);
+print "d" =~ /^$X[-1]$/ ? "ok 27\n" : "not ok 27\n";
+print "a1" !~ /^$X[-1]$/ ? "ok 28\n" : "not ok 28\n";
+
+print (((q{{\{\(}} . q{{\)\}}}) eq '{{\(}{\)}}') ? "ok 29\n" : "not ok 29\n");
+
+
+$foo = "not ok 30\n";
+$foo =~ s/^not /substr(<<EOF, 0, 0)/e;
+ Ignored
+EOF
+print $foo;
diff --git a/contrib/perl5/t/base/pat.t b/contrib/perl5/t/base/pat.t
new file mode 100755
index 000000000000..c689f4552d94
--- /dev/null
+++ b/contrib/perl5/t/base/pat.t
@@ -0,0 +1,11 @@
+#!./perl
+
+# $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:05 $
+
+print "1..2\n";
+
+# first test to see if we can run the tests.
+
+$_ = 'test';
+if (/^test/) { print "ok 1\n"; } else { print "not ok 1\n";}
+if (/^foo/) { print "not ok 2\n"; } else { print "ok 2\n";}
diff --git a/contrib/perl5/t/base/rs.t b/contrib/perl5/t/base/rs.t
new file mode 100755
index 000000000000..52a957260fda
--- /dev/null
+++ b/contrib/perl5/t/base/rs.t
@@ -0,0 +1,131 @@
+#!./perl
+# Test $!
+
+print "1..14\n";
+
+$teststring = "1\n12\n123\n1234\n1234\n12345\n\n123456\n1234567\n";
+
+# Create our test datafile
+open TESTFILE, ">./foo" or die "error $! $^E opening";
+binmode TESTFILE;
+print TESTFILE $teststring;
+close TESTFILE;
+
+open TESTFILE, "<./foo";
+binmode TESTFILE;
+
+# Check the default $/
+$bar = <TESTFILE>;
+if ($bar eq "1\n") {print "ok 1\n";} else {print "not ok 1\n";}
+
+# explicitly set to \n
+$/ = "\n";
+$bar = <TESTFILE>;
+if ($bar eq "12\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+# Try a non line terminator
+$/ = "3";
+$bar = <TESTFILE>;
+if ($bar eq "123") {print "ok 3\n";} else {print "not ok 3\n";}
+
+# Eat the line terminator
+$/ = "\n";
+$bar = <TESTFILE>;
+
+# How about a larger terminator
+$/ = "34";
+$bar = <TESTFILE>;
+if ($bar eq "1234") {print "ok 4\n";} else {print "not ok 4\n";}
+
+# Eat the line terminator
+$/ = "\n";
+$bar = <TESTFILE>;
+
+# Does paragraph mode work?
+$/ = '';
+$bar = <TESTFILE>;
+if ($bar eq "1234\n12345\n\n") {print "ok 5\n";} else {print "not ok 5\n";}
+
+# Try slurping the rest of the file
+$/ = undef;
+$bar = <TESTFILE>;
+if ($bar eq "123456\n1234567\n") {print "ok 6\n";} else {print "not ok 6\n";}
+
+# try the record reading tests. New file so we don't have to worry about
+# the size of \n.
+close TESTFILE;
+unlink "./foo";
+open TESTFILE, ">./foo";
+print TESTFILE "1234567890123456789012345678901234567890";
+binmode TESTFILE;
+close TESTFILE;
+open TESTFILE, "<./foo";
+binmode TESTFILE;
+
+# Test straight number
+$/ = \2;
+$bar = <TESTFILE>;
+if ($bar eq "12") {print "ok 7\n";} else {print "not ok 7\n";}
+
+# Test stringified number
+$/ = \"2";
+$bar = <TESTFILE>;
+if ($bar eq "34") {print "ok 8\n";} else {print "not ok 8\n";}
+
+# Integer variable
+$foo = 2;
+$/ = \$foo;
+$bar = <TESTFILE>;
+if ($bar eq "56") {print "ok 9\n";} else {print "not ok 9\n";}
+
+# String variable
+$foo = "2";
+$/ = \$foo;
+$bar = <TESTFILE>;
+if ($bar eq "78") {print "ok 10\n";} else {print "not ok 10\n";}
+
+# Get rid of the temp file
+close TESTFILE;
+unlink "./foo";
+
+# Now for the tricky bit--full record reading
+if ($^O eq 'VMS') {
+ # Create a temp file. We jump through these hoops 'cause CREATE really
+ # doesn't like our methods for some reason.
+ open FDLFILE, "> ./foo.fdl";
+ print FDLFILE "RECORD\n FORMAT VARIABLE\n";
+ close FDLFILE;
+ open CREATEFILE, "> ./foo.com";
+ print CREATEFILE '$ DEFINE/USER SYS$INPUT NL:', "\n";
+ print CREATEFILE '$ DEFINE/USER SYS$OUTPUT NL:', "\n";
+ print CREATEFILE '$ OPEN YOW []FOO.BAR/WRITE', "\n";
+ print CREATEFILE '$ CLOSE YOW', "\n";
+ print CREATEFILE "\$EXIT\n";
+ close CREATEFILE;
+ $throwaway = `\@\[\]foo`, "\n";
+ open(TEMPFILE, ">./foo.bar") or print "# open failed $! $^E\n";
+ print TEMPFILE "foo\nfoobar\nbaz\n";
+ close TEMPFILE;
+
+ open TESTFILE, "<./foo.bar";
+ $/ = \10;
+ $bar = <TESTFILE>;
+ if ($bar eq "foo\n") {print "ok 11\n";} else {print "not ok 11\n";}
+ $bar = <TESTFILE>;
+ if ($bar eq "foobar\n") {print "ok 12\n";} else {print "not ok 12\n";}
+ # can we do a short read?
+ $/ = \2;
+ $bar = <TESTFILE>;
+ if ($bar eq "ba") {print "ok 13\n";} else {print "not ok 13\n";}
+ # do we get the rest of the record?
+ $bar = <TESTFILE>;
+ if ($bar eq "z\n") {print "ok 14\n";} else {print "not ok 14\n";}
+
+ close TESTFILE;
+ unlink "./foo.bar";
+ unlink "./foo.com";
+} else {
+ # Nobody else does this at the moment (well, maybe OS/390, but they can
+ # put their own tests in) so we just punt
+ foreach $test (11..14) {print "ok $test # skipped on non-VMS system\n"};
+}
diff --git a/contrib/perl5/t/base/term.t b/contrib/perl5/t/base/term.t
new file mode 100755
index 000000000000..e96313dec57c
--- /dev/null
+++ b/contrib/perl5/t/base/term.t
@@ -0,0 +1,55 @@
+#!./perl
+
+# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:07 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+
+print "1..7\n";
+
+# check "" interpretation
+
+$x = "\n";
+# 10 is ASCII/Iso Latin, 21 is EBCDIC.
+if ($x eq chr(10) ||
+ ($Config{ebcdic} eq 'define' && $x eq chr(21))) {print "ok 1\n";}
+else {print "not ok 1\n";}
+
+# check `` processing
+
+$x = `echo hi there`;
+if ($x eq "hi there\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+# check $#array
+
+$x[0] = 'foo';
+$x[1] = 'foo';
+$tmp = $#x;
+print "#3\t:$tmp: == :1:\n";
+if ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";}
+
+# check numeric literal
+
+$x = 1;
+if ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";}
+
+$x = '1E2';
+if (($x | 1) == 101) {print "ok 5\n";} else {print "not ok 5\n";}
+
+# check <> pseudoliteral
+
+open(try, "/dev/null") || open(try,"nla0:") || (die "Can't open /dev/null.");
+if (<try> eq '') {
+ print "ok 6\n";
+}
+else {
+ print "not ok 6\n";
+ die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null';
+}
+
+open(try, "../Configure") || (die "Can't open ../Configure.");
+if (<try> ne '') {print "ok 7\n";} else {print "not ok 7\n";}
diff --git a/contrib/perl5/t/cmd/elsif.t b/contrib/perl5/t/cmd/elsif.t
new file mode 100755
index 000000000000..7eace161e047
--- /dev/null
+++ b/contrib/perl5/t/cmd/elsif.t
@@ -0,0 +1,25 @@
+#!./perl
+
+# $RCSfile: elsif.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:08 $
+
+sub foo {
+ if ($_[0] == 1) {
+ 1;
+ }
+ elsif ($_[0] == 2) {
+ 2;
+ }
+ elsif ($_[0] == 3) {
+ 3;
+ }
+ else {
+ 4;
+ }
+}
+
+print "1..4\n";
+
+if (($x = &foo(1)) == 1) {print "ok 1\n";} else {print "not ok 1 '$x'\n";}
+if (($x = &foo(2)) == 2) {print "ok 2\n";} else {print "not ok 2 '$x'\n";}
+if (($x = &foo(3)) == 3) {print "ok 3\n";} else {print "not ok 3 '$x'\n";}
+if (($x = &foo(4)) == 4) {print "ok 4\n";} else {print "not ok 4 '$x'\n";}
diff --git a/contrib/perl5/t/cmd/for.t b/contrib/perl5/t/cmd/for.t
new file mode 100755
index 000000000000..e45f05040bc2
--- /dev/null
+++ b/contrib/perl5/t/cmd/for.t
@@ -0,0 +1,49 @@
+#!./perl
+
+# $RCSfile: for.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:09 $
+
+print "1..7\n";
+
+for ($i = 0; $i <= 10; $i++) {
+ $x[$i] = $i;
+}
+$y = $x[10];
+print "#1 :$y: eq :10:\n";
+$y = join(' ', @x);
+print "#1 :$y: eq :0 1 2 3 4 5 6 7 8 9 10:\n";
+if (join(' ', @x) eq '0 1 2 3 4 5 6 7 8 9 10') {
+ print "ok 1\n";
+} else {
+ print "not ok 1\n";
+}
+
+$i = $c = 0;
+for (;;) {
+ $c++;
+ last if $i++ > 10;
+}
+if ($c == 12) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$foo = 3210;
+@ary = (1,2,3,4,5);
+foreach $foo (@ary) {
+ $foo *= 2;
+}
+if (join('',@ary) eq '246810') {print "ok 3\n";} else {print "not ok 3\n";}
+
+for (@ary) {
+ s/(.*)/ok $1\n/;
+}
+
+print $ary[1];
+
+# test for internal scratch array generation
+# this also tests that $foo was restored to 3210 after test 3
+for (split(' ','a b c d e')) {
+ $foo .= $_;
+}
+if ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";}
+
+foreach $foo (("ok 6\n","ok 7\n")) {
+ print $foo;
+}
diff --git a/contrib/perl5/t/cmd/mod.t b/contrib/perl5/t/cmd/mod.t
new file mode 100755
index 000000000000..e2ab77724643
--- /dev/null
+++ b/contrib/perl5/t/cmd/mod.t
@@ -0,0 +1,54 @@
+#!./perl
+
+# $RCSfile: mod.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:11 $
+
+print "1..12\n";
+
+print "ok 1\n" if 1;
+print "not ok 1\n" unless 1;
+
+print "ok 2\n" unless 0;
+print "not ok 2\n" if 0;
+
+1 && (print "not ok 3\n") if 0;
+1 && (print "ok 3\n") if 1;
+0 || (print "not ok 4\n") if 0;
+0 || (print "ok 4\n") if 1;
+
+$x = 0;
+do {$x[$x] = $x;} while ($x++) < 10;
+if (join(' ',@x) eq '0 1 2 3 4 5 6 7 8 9 10') {
+ print "ok 5\n";
+} else {
+ print "not ok 5 @x\n";
+}
+
+$x = 15;
+$x = 10 while $x < 10;
+if ($x == 15) {print "ok 6\n";} else {print "not ok 6\n";}
+
+$y[$_] = $_ * 2 foreach @x;
+if (join(' ',@y) eq '0 2 4 6 8 10 12 14 16 18 20') {
+ print "ok 7\n";
+} else {
+ print "not ok 7 @y\n";
+}
+
+open(foo,'./TEST') || open(foo,'TEST') || open(foo,'t/TEST');
+$x = 0;
+$x++ while <foo>;
+print $x > 50 && $x < 1000 ? "ok 8\n" : "not ok 8\n";
+
+$x = -0.5;
+print "not " if scalar($x) < 0 and $x >= 0;
+print "ok 9\n";
+
+print "not " unless (-(-$x) < 0) == ($x < 0);
+print "ok 10\n";
+
+print "ok 11\n" if $x < 0;
+print "not ok 11\n" unless $x < 0;
+
+print "ok 12\n" unless $x > 0;
+print "not ok 12\n" if $x > 0;
+
diff --git a/contrib/perl5/t/cmd/subval.t b/contrib/perl5/t/cmd/subval.t
new file mode 100755
index 000000000000..3c60690ebf14
--- /dev/null
+++ b/contrib/perl5/t/cmd/subval.t
@@ -0,0 +1,186 @@
+#!./perl
+
+# $RCSfile: subval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:13 $
+
+sub foo1 {
+ 'true1';
+ if ($_[0]) { 'true2'; }
+}
+
+sub foo2 {
+ 'true1';
+ if ($_[0]) { return 'true2'; } else { return 'true3'; }
+ 'true0';
+}
+
+sub foo3 {
+ 'true1';
+ unless ($_[0]) { 'true2'; }
+}
+
+sub foo4 {
+ 'true1';
+ unless ($_[0]) { 'true2'; } else { 'true3'; }
+}
+
+sub foo5 {
+ 'true1';
+ 'true2' if $_[0];
+}
+
+sub foo6 {
+ 'true1';
+ 'true2' unless $_[0];
+}
+
+print "1..36\n";
+
+if (&foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
+if (&foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";}
+if (&foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";}
+if (&foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";}
+
+if (&foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";}
+if (&foo3(1) eq '1') {print "ok 6\n";} else {print "not ok 6\n";}
+if (&foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";}
+if (&foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";}
+
+if (&foo5(0) eq '0') {print "ok 9\n";} else {print "not ok 9\n";}
+if (&foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";}
+if (&foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";}
+if (&foo6(1) eq '1') {print "ok 12\n";} else {print "not ok 12 $x\n";}
+
+# Now test to see that recursion works using a Fibonacci number generator
+
+sub fib {
+ my($arg) = @_;
+ my($foo);
+ $level++;
+ if ($arg <= 2) {
+ $foo = 1;
+ }
+ else {
+ $foo = &fib($arg-1) + &fib($arg-2);
+ }
+ $level--;
+ $foo;
+}
+
+@good = (0,1,1,2,3,5,8,13,21,34,55,89);
+
+for ($i = 1; $i <= 10; $i++) {
+ $foo = $i + 12;
+ if (&fib($i) == $good[$i]) {
+ print "ok $foo\n";
+ }
+ else {
+ print "not ok $foo\n";
+ }
+}
+
+sub ary1 {
+ (1,2,3);
+}
+
+print &ary1 eq 3 ? "ok 23\n" : "not ok 23\n";
+
+print join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n";
+
+sub ary2 {
+ do {
+ return (1,2,3);
+ (3,2,1);
+ };
+ 0;
+}
+
+print &ary2 eq 3 ? "ok 25\n" : "not ok 25\n";
+
+$x = join(':',&ary2);
+print $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n";
+
+sub somesub {
+ local($num,$P,$F,$L) = @_;
+ ($p,$f,$l) = caller;
+ print "$p:$f:$l" eq "$P:$F:$L" ? "ok $num\n" : "not ok $num $p:$f:$l ne $P:$F:$L\n";
+}
+
+&somesub(27, 'main', __FILE__, __LINE__);
+
+package foo;
+&main'somesub(28, 'foo', __FILE__, __LINE__);
+
+package main;
+$i = 28;
+open(FOO,">Cmd_subval.tmp");
+print FOO "blah blah\n";
+close FOO;
+
+&file_main(*F);
+close F;
+&info_main;
+
+&file_package(*F);
+close F;
+&info_package;
+
+unlink 'Cmd_subval.tmp';
+
+sub file_main {
+ local(*F) = @_;
+
+ open(F, 'Cmd_subval.tmp') || die "can't open\n";
+ $i++;
+ eof F ? print "not ok $i\n" : print "ok $i\n";
+}
+
+sub info_main {
+ local(*F);
+
+ open(F, 'Cmd_subval.tmp') || die "test: can't open\n";
+ $i++;
+ eof F ? print "not ok $i\n" : print "ok $i\n";
+ &iseof(*F);
+ close F;
+}
+
+sub iseof {
+ local(*UNIQ) = @_;
+
+ $i++;
+ eof UNIQ ? print "(not ok $i)\n" : print "ok $i\n";
+}
+
+{package foo;
+
+ sub main'file_package {
+ local(*F) = @_;
+
+ open(F, 'Cmd_subval.tmp') || die "can't open\n";
+ $main'i++;
+ eof F ? print "not ok $main'i\n" : print "ok $main'i\n";
+ }
+
+ sub main'info_package {
+ local(*F);
+
+ open(F, 'Cmd_subval.tmp') || die "can't open\n";
+ $main'i++;
+ eof F ? print "not ok $main'i\n" : print "ok $main'i\n";
+ &iseof(*F);
+ }
+
+ sub iseof {
+ local(*UNIQ) = @_;
+
+ $main'i++;
+ eof UNIQ ? print "not ok $main'i\n" : print "ok $main'i\n";
+ }
+}
+
+sub autov { $_[0] = 23 };
+
+my $href = {};
+print keys %$href ? 'not ' : '', "ok 35\n";
+autov($href->{b});
+print join(':', %$href) eq 'b:23' ? '' : 'not ', "ok 36\n";
diff --git a/contrib/perl5/t/cmd/switch.t b/contrib/perl5/t/cmd/switch.t
new file mode 100755
index 000000000000..faa5de470f3c
--- /dev/null
+++ b/contrib/perl5/t/cmd/switch.t
@@ -0,0 +1,75 @@
+#!./perl
+
+# $RCSfile: switch.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:14 $
+
+print "1..18\n";
+
+sub foo1 {
+ $_ = shift(@_);
+ $a = 0;
+ until ($a++) {
+ next if $_ eq 1;
+ next if $_ eq 2;
+ next if $_ eq 3;
+ next if $_ eq 4;
+ return 20;
+ }
+ continue {
+ return $_;
+ }
+}
+
+print do foo1(0) == 20 ? "ok 1\n" : "not ok 1\n";
+print do foo1(1) == 1 ? "ok 2\n" : "not ok 2\n";
+print do foo1(2) == 2 ? "ok 3\n" : "not ok 3\n";
+print do foo1(3) == 3 ? "ok 4\n" : "not ok 4\n";
+print do foo1(4) == 4 ? "ok 5\n" : "not ok 5\n";
+print do foo1(5) == 20 ? "ok 6\n" : "not ok 6\n";
+
+sub foo2 {
+ $_ = shift(@_);
+ {
+ last if $_ == 1;
+ last if $_ == 2;
+ last if $_ == 3;
+ last if $_ == 4;
+ }
+ continue {
+ return 20;
+ }
+ return $_;
+}
+
+print do foo2(0) == 20 ? "ok 7\n" : "not ok 7\n";
+print do foo2(1) == 1 ? "ok 8\n" : "not ok 8\n";
+print do foo2(2) == 2 ? "ok 9\n" : "not ok 9\n";
+print do foo2(3) == 3 ? "ok 10\n" : "not ok 10\n";
+print do foo2(4) == 4 ? "ok 11\n" : "not ok 11\n";
+print do foo2(5) == 20 ? "ok 12\n" : "not ok 12\n";
+
+sub foo3 {
+ $_ = shift(@_);
+ if (/^1/) {
+ return 1;
+ }
+ elsif (/^2/) {
+ return 2;
+ }
+ elsif (/^3/) {
+ return 3;
+ }
+ elsif (/^4/) {
+ return 4;
+ }
+ else {
+ return 20;
+ }
+ return 40;
+}
+
+print do foo3(0) == 20 ? "ok 13\n" : "not ok 13\n";
+print do foo3(1) == 1 ? "ok 14\n" : "not ok 14\n";
+print do foo3(2) == 2 ? "ok 15\n" : "not ok 15\n";
+print do foo3(3) == 3 ? "ok 16\n" : "not ok 16\n";
+print do foo3(4) == 4 ? "ok 17\n" : "not ok 17\n";
+print do foo3(5) == 20 ? "ok 18\n" : "not ok 18\n";
diff --git a/contrib/perl5/t/cmd/while.t b/contrib/perl5/t/cmd/while.t
new file mode 100755
index 000000000000..c6e464d444ad
--- /dev/null
+++ b/contrib/perl5/t/cmd/while.t
@@ -0,0 +1,111 @@
+#!./perl
+
+# $RCSfile: while.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:15 $
+
+print "1..10\n";
+
+open (tmp,'>Cmd_while.tmp') || die "Can't create Cmd_while.tmp.";
+print tmp "tvi925\n";
+print tmp "tvi920\n";
+print tmp "vt100\n";
+print tmp "Amiga\n";
+print tmp "paper\n";
+close tmp;
+
+# test "last" command
+
+open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp.";
+while (<fh>) {
+ last if /vt100/;
+}
+if (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1 $_\n";}
+
+# test "next" command
+
+$bad = '';
+open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp.";
+while (<fh>) {
+ next if /vt100/;
+ $bad = 1 if /vt100/;
+}
+if (!eof || /vt100/ || $bad) {print "not ok 2\n";} else {print "ok 2\n";}
+
+# test "redo" command
+
+$bad = '';
+open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp.";
+while (<fh>) {
+ if (s/vt100/VT100/g) {
+ s/VT100/Vt100/g;
+ redo;
+ }
+ $bad = 1 if /vt100/;
+ $bad = 1 if /VT100/;
+}
+if (!eof || $bad) {print "not ok 3\n";} else {print "ok 3\n";}
+
+# now do the same with a label and a continue block
+
+# test "last" command
+
+$badcont = '';
+open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp.";
+line: while (<fh>) {
+ if (/vt100/) {last line;}
+} continue {
+ $badcont = 1 if /vt100/;
+}
+if (!eof && /vt100/) {print "ok 4\n";} else {print "not ok 4\n";}
+if (!$badcont) {print "ok 5\n";} else {print "not ok 5\n";}
+
+# test "next" command
+
+$bad = '';
+$badcont = 1;
+open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp.";
+entry: while (<fh>) {
+ next entry if /vt100/;
+ $bad = 1 if /vt100/;
+} continue {
+ $badcont = '' if /vt100/;
+}
+if (!eof || /vt100/ || $bad) {print "not ok 6\n";} else {print "ok 6\n";}
+if (!$badcont) {print "ok 7\n";} else {print "not ok 7\n";}
+
+# test "redo" command
+
+$bad = '';
+$badcont = '';
+open(fh,'Cmd_while.tmp') || die "Can't open Cmd_while.tmp.";
+loop: while (<fh>) {
+ if (s/vt100/VT100/g) {
+ s/VT100/Vt100/g;
+ redo loop;
+ }
+ $bad = 1 if /vt100/;
+ $bad = 1 if /VT100/;
+} continue {
+ $badcont = 1 if /vt100/;
+}
+if (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";}
+if (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";}
+
+close(fh) || die "Can't close Cmd_while.tmp.";
+unlink 'Cmd_while.tmp' || `/bin/rm Cmd_While.tmp`;
+
+#$x = 0;
+#while (1) {
+# if ($x > 1) {last;}
+# next;
+#} continue {
+# if ($x++ > 10) {last;}
+# next;
+#}
+#
+#if ($x < 10) {print "ok 10\n";} else {print "not ok 10\n";}
+
+$i = 9;
+{
+ $i++;
+}
+print "ok $i\n";
diff --git a/contrib/perl5/t/comp/cmdopt.t b/contrib/perl5/t/comp/cmdopt.t
new file mode 100755
index 000000000000..3f701a456ac4
--- /dev/null
+++ b/contrib/perl5/t/comp/cmdopt.t
@@ -0,0 +1,90 @@
+#!./perl
+
+# $RCSfile: cmdopt.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:17 $
+
+print "1..44\n";
+
+# test the optimization of constants
+
+if (1) { print "ok 1\n";} else { print "not ok 1\n";}
+unless (0) { print "ok 2\n";} else { print "not ok 2\n";}
+
+if (0) { print "not ok 3\n";} else { print "ok 3\n";}
+unless (1) { print "not ok 4\n";} else { print "ok 4\n";}
+
+unless (!1) { print "ok 5\n";} else { print "not ok 5\n";}
+if (!0) { print "ok 6\n";} else { print "not ok 6\n";}
+
+unless (!0) { print "not ok 7\n";} else { print "ok 7\n";}
+if (!1) { print "not ok 8\n";} else { print "ok 8\n";}
+
+$x = 1;
+if (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";}
+if (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";}
+$x = '';
+if (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";}
+if (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";}
+
+$x = 1;
+if (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";}
+if (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";}
+$x = '';
+if (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";}
+if (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";}
+
+
+# test the optimization of variables
+
+$x = 1;
+if ($x) { print "ok 17\n";} else { print "not ok 17\n";}
+unless ($x) { print "not ok 18\n";} else { print "ok 18\n";}
+
+$x = '';
+if ($x) { print "not ok 19\n";} else { print "ok 19\n";}
+unless ($x) { print "ok 20\n";} else { print "not ok 20\n";}
+
+# test optimization of string operations
+
+$a = 'a';
+if ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";}
+if ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";}
+
+if ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";}
+if ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";}
+# test interaction of logicals and other operations
+
+$a = 'a';
+$x = 1;
+if ($a eq 'a' and $x) { print "ok 25\n";} else { print "not ok 25\n";}
+if ($a ne 'a' and $x) { print "not ok 26\n";} else { print "ok 26\n";}
+$x = '';
+if ($a eq 'a' and $x) { print "not ok 27\n";} else { print "ok 27\n";}
+if ($a ne 'a' and $x) { print "not ok 28\n";} else { print "ok 28\n";}
+
+$x = 1;
+if ($a eq 'a' or $x) { print "ok 29\n";} else { print "not ok 29\n";}
+if ($a ne 'a' or $x) { print "ok 30\n";} else { print "not ok 30\n";}
+$x = '';
+if ($a eq 'a' or $x) { print "ok 31\n";} else { print "not ok 31\n";}
+if ($a ne 'a' or $x) { print "not ok 32\n";} else { print "ok 32\n";}
+
+$x = 1;
+if ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";}
+if ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";}
+$x = '';
+if ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";}
+if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";}
+
+$x = 1;
+if ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";}
+if ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";}
+$x = '';
+if ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";}
+if ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";}
+
+$x = 1;
+if ($a eq 'a' xor $x) { print "not ok 41\n";} else { print "ok 41\n";}
+if ($a ne 'a' xor $x) { print "ok 42\n";} else { print "not ok 42\n";}
+$x = '';
+if ($a eq 'a' xor $x) { print "ok 43\n";} else { print "not ok 43\n";}
+if ($a ne 'a' xor $x) { print "not ok 44\n";} else { print "ok 44\n";}
diff --git a/contrib/perl5/t/comp/colon.t b/contrib/perl5/t/comp/colon.t
new file mode 100755
index 000000000000..d2c64fe4c535
--- /dev/null
+++ b/contrib/perl5/t/comp/colon.t
@@ -0,0 +1,138 @@
+#!./perl
+
+#
+# Ensure that syntax using colons (:) is parsed correctly.
+# The tests are done on the following tokens (by default):
+# ABC LABEL XYZZY m q qq qw qx s tr y AUTOLOAD and alarm
+# -- Robin Barker <rmb@cise.npl.co.uk>
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+
+$_ = ''; # to avoid undef warning on m// etc.
+
+sub ok {
+ my($test,$ok) = @_;
+ print "not " unless $ok;
+ print "ok $test\n";
+}
+
+$SIG{__WARN__} = sub { 1; }; # avoid some spurious warnings
+
+print "1..25\n";
+
+ok 1, (eval "package ABC; sub zyx {1}; 1;" and
+ eval "ABC::zyx" and
+ not eval "ABC:: eq ABC||" and
+ not eval "ABC::: >= 0");
+
+ok 2, (eval "package LABEL; sub zyx {1}; 1;" and
+ eval "LABEL::zyx" and
+ not eval "LABEL:: eq LABEL||" and
+ not eval "LABEL::: >= 0");
+
+ok 3, (eval "package XYZZY; sub zyx {1}; 1;" and
+ eval "XYZZY::zyx" and
+ not eval "XYZZY:: eq XYZZY||" and
+ not eval "XYZZY::: >= 0");
+
+ok 4, (eval "package m; sub zyx {1}; 1;" and
+ not eval "m::zyx" and
+ eval "m:: eq m||" and
+ not eval "m::: >= 0");
+
+ok 5, (eval "package q; sub zyx {1}; 1;" and
+ not eval "q::zyx" and
+ eval "q:: eq q||" and
+ not eval "q::: >= 0");
+
+ok 6, (eval "package qq; sub zyx {1}; 1;" and
+ not eval "qq::zyx" and
+ eval "qq:: eq qq||" and
+ not eval "qq::: >= 0");
+
+ok 7, (eval "package qw; sub zyx {1}; 1;" and
+ not eval "qw::zyx" and
+ eval "qw:: eq qw||" and
+ not eval "qw::: >= 0");
+
+ok 8, (eval "package qx; sub zyx {1}; 1;" and
+ not eval "qx::zyx" and
+ eval "qx:: eq qx||" and
+ not eval "qx::: >= 0");
+
+ok 9, (eval "package s; sub zyx {1}; 1;" and
+ not eval "s::zyx" and
+ not eval "s:: eq s||" and
+ eval "s::: >= 0");
+
+ok 10, (eval "package tr; sub zyx {1}; 1;" and
+ not eval "tr::zyx" and
+ not eval "tr:: eq tr||" and
+ eval "tr::: >= 0");
+
+ok 11, (eval "package y; sub zyx {1}; 1;" and
+ not eval "y::zyx" and
+ not eval "y:: eq y||" and
+ eval "y::: >= 0");
+
+ok 12, (eval "ABC:1" and
+ not eval "ABC:echo: eq ABC|echo|" and
+ not eval "ABC:echo:ohce: >= 0");
+
+ok 13, (eval "LABEL:1" and
+ not eval "LABEL:echo: eq LABEL|echo|" and
+ not eval "LABEL:echo:ohce: >= 0");
+
+ok 14, (eval "XYZZY:1" and
+ not eval "XYZZY:echo: eq XYZZY|echo|" and
+ not eval "XYZZY:echo:ohce: >= 0");
+
+ok 15, (not eval "m:1" and
+ eval "m:echo: eq m|echo|" and
+ not eval "m:echo:ohce: >= 0");
+
+ok 16, (not eval "q:1" and
+ eval "q:echo: eq q|echo|" and
+ not eval "q:echo:ohce: >= 0");
+
+ok 17, (not eval "qq:1" and
+ eval "qq:echo: eq qq|echo|" and
+ not eval "qq:echo:ohce: >= 0");
+
+ok 18, (not eval "qw:1" and
+ eval "qw:echo: eq qw|echo|" and
+ not eval "qw:echo:ohce: >= 0");
+
+ok 19, (not eval "qx:1" and
+ eval "qx:echo 1: eq qx|echo 1|" and # echo without args may warn
+ not eval "qx:echo:ohce: >= 0");
+
+ok 20, (not eval "s:1" and
+ not eval "s:echo: eq s|echo|" and
+ eval "s:echo:ohce: >= 0");
+
+ok 21, (not eval "tr:1" and
+ not eval "tr:echo: eq tr|echo|" and
+ eval "tr:echo:ohce: >= 0");
+
+ok 22, (not eval "y:1" and
+ not eval "y:echo: eq y|echo|" and
+ eval "y:echo:ohce: >= 0");
+
+ok 23, (eval "AUTOLOAD:1" and
+ not eval "AUTOLOAD:echo: eq AUTOLOAD|echo|" and
+ not eval "AUTOLOAD:echo:ohce: >= 0");
+
+ok 24, (eval "and:1" and
+ not eval "and:echo: eq and|echo|" and
+ not eval "and:echo:ohce: >= 0");
+
+ok 25, (eval "alarm:1" and
+ not eval "alarm:echo: eq alarm|echo|" and
+ not eval "alarm:echo:ohce: >= 0");
diff --git a/contrib/perl5/t/comp/cpp.aux b/contrib/perl5/t/comp/cpp.aux
new file mode 100755
index 000000000000..bb93d212c3bc
--- /dev/null
+++ b/contrib/perl5/t/comp/cpp.aux
@@ -0,0 +1,39 @@
+#!./perl -P
+
+# $RCSfile: cpp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:18 $
+
+print "1..3\n";
+
+#this is a comment
+#define MESS "ok 1\n"
+print MESS;
+
+#If you capitalize, it's a comment.
+#ifdef MESS
+ print "ok 2\n";
+#else
+ print "not ok 2\n";
+#endif
+
+open(TRY,">Comp.cpp.tmp") || die "Can't open temp perl file.";
+
+($prog = <<'END') =~ s/X//g;
+X$ok = "not ok 3\n";
+X#include "Comp.cpp.inc"
+X#ifdef OK
+X$ok = OK;
+X#endif
+Xprint $ok;
+END
+print TRY $prog;
+close TRY;
+
+open(TRY,">Comp.cpp.inc") || (die "Can't open temp include file.");
+print TRY '#define OK "ok 3\n"' . "\n";
+close TRY;
+
+$pwd=`pwd`;
+$pwd =~ s/\n//;
+$x = `./perl -P Comp.cpp.tmp`;
+print $x;
+unlink "Comp.cpp.tmp", "Comp.cpp.inc";
diff --git a/contrib/perl5/t/comp/cpp.t b/contrib/perl5/t/comp/cpp.t
new file mode 100755
index 000000000000..86e7359524ef
--- /dev/null
+++ b/contrib/perl5/t/comp/cpp.t
@@ -0,0 +1,18 @@
+#!./perl
+
+# $RCSfile: cpp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:18 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+if ( $^O eq 'MSWin32' or
+ ($Config{'cppstdin'} =~ /\bcppstdin\b/) and
+ ( ! -x $Config{'binexp'} . "/cppstdin") ) {
+ print "1..0\n";
+ exit; # Cannot test till after install, alas.
+}
+
+system "./perl -P comp/cpp.aux"
diff --git a/contrib/perl5/t/comp/decl.t b/contrib/perl5/t/comp/decl.t
new file mode 100755
index 000000000000..32b8509df774
--- /dev/null
+++ b/contrib/perl5/t/comp/decl.t
@@ -0,0 +1,49 @@
+#!./perl
+
+# $RCSfile: decl.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:19 $
+
+# check to see if subroutine declarations work everwhere
+
+sub one {
+ print "ok 1\n";
+}
+format one =
+ok 5
+.
+
+print "1..7\n";
+
+do one();
+do two();
+
+sub two {
+ print "ok 2\n";
+}
+format two =
+@<<<
+$foo
+.
+
+if ($x eq $x) {
+ sub three {
+ print "ok 3\n";
+ }
+ do three();
+}
+
+do four();
+$~ = 'one';
+write;
+$~ = 'two';
+$foo = "ok 6";
+write;
+$~ = 'three';
+write;
+
+format three =
+ok 7
+.
+
+sub four {
+ print "ok 4\n";
+}
diff --git a/contrib/perl5/t/comp/multiline.t b/contrib/perl5/t/comp/multiline.t
new file mode 100755
index 000000000000..ed418b84fc1d
--- /dev/null
+++ b/contrib/perl5/t/comp/multiline.t
@@ -0,0 +1,46 @@
+#!./perl
+
+# $RCSfile: multiline.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:20 $
+
+print "1..5\n";
+
+open(try,'>Comp.try') || (die "Can't open temp file.");
+
+$x = 'now is the time
+for all good men
+to come to.
+
+
+!
+
+';
+
+$y = 'now is the time' . "\n" .
+'for all good men' . "\n" .
+'to come to.' . "\n\n\n!\n\n";
+
+if ($x eq $y) {print "ok 1\n";} else {print "not ok 1\n";}
+
+print try $x;
+close try;
+
+open(try,'Comp.try') || (die "Can't reopen temp file.");
+$count = 0;
+$z = '';
+while (<try>) {
+ $z .= $_;
+ $count = $count + 1;
+}
+
+if ($z eq $y) {print "ok 2\n";} else {print "not ok 2\n";}
+
+if ($count == 7) {print "ok 3\n";} else {print "not ok 3\n";}
+
+$_ = ($^O eq 'MSWin32') ? `type Comp.try` : `cat Comp.try`;
+
+if (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";}
+
+close(try) || (die "Can't close temp file.");
+unlink 'Comp.try' || `/bin/rm -f Comp.try`;
+
+if ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";}
diff --git a/contrib/perl5/t/comp/package.t b/contrib/perl5/t/comp/package.t
new file mode 100755
index 000000000000..d7d19ae882c0
--- /dev/null
+++ b/contrib/perl5/t/comp/package.t
@@ -0,0 +1,39 @@
+#!./perl
+
+print "1..7\n";
+
+$blurfl = 123;
+$foo = 3;
+
+package xyz;
+
+$bar = 4;
+
+{
+ package ABC;
+ $blurfl = 5;
+ $main'a = $'b;
+}
+
+$ABC'dyick = 6;
+
+$xyz = 2;
+
+$main = join(':', sort(keys %main::));
+$xyz = join(':', sort(keys %xyz::));
+$ABC = join(':', sort(keys %ABC::));
+
+if ('a' lt 'A') {
+ print $xyz eq 'bar:main:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n";
+} else {
+ print $xyz eq 'ABC:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n";
+}
+print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\n";
+print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n";
+
+package ABC;
+
+print $blurfl == 5 ? "ok 4\n" : "not ok 4\n";
+eval 'print $blurfl == 5 ? "ok 5\n" : "not ok 5\n";';
+eval 'package main; print $blurfl == 123 ? "ok 6\n" : "not ok 6\n";';
+print $blurfl == 5 ? "ok 7\n" : "not ok 7\n";
diff --git a/contrib/perl5/t/comp/proto.t b/contrib/perl5/t/comp/proto.t
new file mode 100755
index 000000000000..6a59107ce72b
--- /dev/null
+++ b/contrib/perl5/t/comp/proto.t
@@ -0,0 +1,415 @@
+#!./perl
+#
+# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
+#
+# So far there are tests for the following prototypes.
+# none, () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@)
+#
+# It is impossible to test every prototype that can be specified, but
+# we should test as many as we can.
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+
+print "1..82\n";
+
+my $i = 1;
+
+sub testing (&$) {
+ my $p = prototype(shift);
+ my $c = shift;
+ my $what = defined $c ? '(' . $p . ')' : 'no prototype';
+ print '#' x 25,"\n";
+ print '# Testing ',$what,"\n";
+ print '#' x 25,"\n";
+ print "not "
+ if((defined($p) && defined($c) && $p ne $c)
+ || (defined($p) != defined($c)));
+ printf "ok %d\n",$i++;
+}
+
+@_ = qw(a b c d);
+my @array;
+my %hash;
+
+##
+##
+##
+
+testing \&no_proto, undef;
+
+sub no_proto {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 0 == no_proto();
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == no_proto(5);
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &no_proto;
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == no_proto +6;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == no_proto(@_);
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
+
+testing \&no_args, '';
+
+sub no_args () {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 0 == no_args();
+printf "ok %d\n",$i++;
+
+print "not " unless 0 == no_args;
+printf "ok %d\n",$i++;
+
+print "not " unless 5 == no_args +5;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &no_args;
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == &no_args(1,2);
+printf "ok %d\n",$i++;
+
+eval "no_args(1)";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
+testing \&one_args, '$';
+
+sub one_args ($) {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 1 == one_args(1);
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == one_args +5;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &one_args;
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == &one_args(1,2);
+printf "ok %d\n",$i++;
+
+eval "one_args(1,2)";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+eval "one_args()";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+sub one_a_args ($) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ == 1 && $_[0] == 4;
+ printf "ok %d\n",$i++;
+}
+
+one_a_args(@_);
+
+##
+##
+##
+
+testing \&over_one_args, '$@';
+
+sub over_one_args ($@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 1 == over_one_args(1);
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == over_one_args(1,2);
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == over_one_args +5;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &over_one_args;
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == &over_one_args(1,2);
+printf "ok %d\n",$i++;
+
+print "not " unless 5 == &over_one_args(1,@_);
+printf "ok %d\n",$i++;
+
+eval "over_one_args()";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+sub over_one_a_args ($@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ >= 1 && $_[0] == 4;
+ printf "ok %d\n",$i++;
+}
+
+over_one_a_args(@_);
+over_one_a_args(@_,1);
+over_one_a_args(@_,1,2);
+over_one_a_args(@_,@_);
+
+##
+##
+##
+
+testing \&scalar_and_hash, '$%';
+
+sub scalar_and_hash ($%) {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 1 == scalar_and_hash(1);
+printf "ok %d\n",$i++;
+
+print "not " unless 3 == scalar_and_hash(1,2,3);
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == scalar_and_hash +5;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &scalar_and_hash;
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == &scalar_and_hash(1,2);
+printf "ok %d\n",$i++;
+
+print "not " unless 5 == &scalar_and_hash(1,@_);
+printf "ok %d\n",$i++;
+
+eval "scalar_and_hash()";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+sub scalar_and_hash_a ($@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ >= 1 && $_[0] == 4;
+ printf "ok %d\n",$i++;
+}
+
+scalar_and_hash_a(@_);
+scalar_and_hash_a(@_,1);
+scalar_and_hash_a(@_,1,2);
+scalar_and_hash_a(@_,@_);
+
+##
+##
+##
+
+testing \&one_or_two, '$;$';
+
+sub one_or_two ($;$) {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_)
+}
+
+print "not " unless 1 == one_or_two(1);
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == one_or_two(1,3);
+printf "ok %d\n",$i++;
+
+print "not " unless 1 == one_or_two +5;
+printf "ok %d\n",$i++;
+
+print "not " unless 4 == &one_or_two;
+printf "ok %d\n",$i++;
+
+print "not " unless 3 == &one_or_two(1,2,3);
+printf "ok %d\n",$i++;
+
+print "not " unless 5 == &one_or_two(1,@_);
+printf "ok %d\n",$i++;
+
+eval "one_or_two()";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+eval "one_or_two(1,2,3)";
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+sub one_or_two_a ($;$) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ >= 1 && $_[0] == 4;
+ printf "ok %d\n",$i++;
+}
+
+one_or_two_a(@_);
+one_or_two_a(@_,1);
+one_or_two_a(@_,@_);
+
+##
+##
+##
+
+testing \&a_sub, '&';
+
+sub a_sub (&) {
+ print "# \@_ = (",join(",",@_),")\n";
+ &{$_[0]};
+}
+
+sub tmp_sub_1 { printf "ok %d\n",$i++ }
+
+a_sub { printf "ok %d\n",$i++ };
+a_sub \&tmp_sub_1;
+
+@array = ( \&tmp_sub_1 );
+eval 'a_sub @array';
+print "not " unless $@;
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
+testing \&sub_aref, '&\@';
+
+sub sub_aref (&\@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ my($sub,$array) = @_;
+ print "not " unless @_ == 2 && @{$array} == 4;
+ print map { &{$sub}($_) } @{$array}
+}
+
+@array = (qw(O K)," ", $i++);
+sub_aref { lc shift } @array;
+print "\n";
+
+##
+##
+##
+
+testing \&sub_array, '&@';
+
+sub sub_array (&@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ == 5;
+ my $sub = shift;
+ print map { &{$sub}($_) } @_
+}
+
+@array = (qw(O K)," ", $i++);
+sub_array { lc shift } @array;
+print "\n";
+
+##
+##
+##
+
+testing \&a_hash, '%';
+
+sub a_hash (%) {
+ print "# \@_ = (",join(",",@_),")\n";
+ scalar(@_);
+}
+
+print "not " unless 1 == a_hash 'a';
+printf "ok %d\n",$i++;
+
+print "not " unless 2 == a_hash 'a','b';
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
+testing \&a_hash_ref, '\%';
+
+sub a_hash_ref (\%) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless ref($_[0]) && $_[0]->{'a'};
+ printf "ok %d\n",$i++;
+ $_[0]->{'b'} = 2;
+}
+
+%hash = ( a => 1);
+a_hash_ref %hash;
+print "not " unless $hash{'b'} == 2;
+printf "ok %d\n",$i++;
+
+##
+##
+##
+
+testing \&array_ref_plus, '\@@';
+
+sub array_ref_plus (\@@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x';
+ printf "ok %d\n",$i++;
+ @{$_[0]} = (qw(ok)," ",$i++,"\n");
+}
+
+@array = ('a');
+{ my @more = ('x');
+ array_ref_plus @array, @more; }
+print "not " unless @array == 4;
+print @array;
+
+my $p;
+print "not " if defined prototype('CORE::print');
+print "ok ", $i++, "\n";
+
+print "not " if defined prototype('CORE::system');
+print "ok ", $i++, "\n";
+
+print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$';
+print "ok ", $i++, "\n";
+
+print "# CORE:Foo => ($p), \$@ => `$@'\nnot "
+ if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Cannot find an opnumber/;
+print "ok ", $i++, "\n";
+
+# correctly note too-short parameter lists that don't end with '$',
+# a possible regression.
+
+sub foo1 ($\@);
+eval q{ foo1 "s" };
+print "not " unless $@ =~ /^Not enough/;
+print "ok ", $i++, "\n";
+
+sub foo2 ($\%);
+eval q{ foo2 "s" };
+print "not " unless $@ =~ /^Not enough/;
+print "ok ", $i++, "\n";
+
+sub X::foo3;
+*X::foo3 = sub {'ok'};
+print "# $@not " unless eval {X->foo3} eq 'ok';
+print "ok ", $i++, "\n";
+
+sub X::foo4 ($);
+*X::foo4 = sub ($) {'ok'};
+print "not " unless X->foo4 eq 'ok';
+print "ok ", $i++, "\n";
diff --git a/contrib/perl5/t/comp/redef.t b/contrib/perl5/t/comp/redef.t
new file mode 100755
index 000000000000..07e978bb8665
--- /dev/null
+++ b/contrib/perl5/t/comp/redef.t
@@ -0,0 +1,80 @@
+#!./perl -w
+#
+# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
+
+BEGIN {
+ $warn = "";
+ $SIG{__WARN__} = sub { $warn .= join("",@_) }
+}
+
+sub ok ($$) {
+ print $_[1] ? "ok " : "not ok ", $_[0], "\n";
+}
+
+print "1..18\n";
+
+my $NEWPROTO = 'Prototype mismatch:';
+
+sub sub0 { 1 }
+sub sub0 { 2 }
+
+ok 1, $warn =~ s/Subroutine sub0 redefined[^\n]+\n//s;
+
+sub sub1 { 1 }
+sub sub1 () { 2 }
+
+ok 2, $warn =~ s/$NEWPROTO \Qsub main::sub1 vs ()\E[^\n]+\n//s;
+ok 3, $warn =~ s/Subroutine sub1 redefined[^\n]+\n//s;
+
+sub sub2 { 1 }
+sub sub2 ($) { 2 }
+
+ok 4, $warn =~ s/$NEWPROTO \Qsub main::sub2 vs ($)\E[^\n]+\n//s;
+ok 5, $warn =~ s/Subroutine sub2 redefined[^\n]+\n//s;
+
+sub sub3 () { 1 }
+sub sub3 { 2 }
+
+ok 6, $warn =~ s/$NEWPROTO \Qsub main::sub3 () vs none\E[^\n]+\n//s;
+ok 7, $warn =~ s/Constant subroutine sub3 redefined[^\n]+\n//s;
+
+sub sub4 () { 1 }
+sub sub4 () { 2 }
+
+ok 8, $warn =~ s/Constant subroutine sub4 redefined[^\n]+\n//s;
+
+sub sub5 () { 1 }
+sub sub5 ($) { 2 }
+
+ok 9, $warn =~ s/$NEWPROTO \Qsub main::sub5 () vs ($)\E[^\n]+\n//s;
+ok 10, $warn =~ s/Constant subroutine sub5 redefined[^\n]+\n//s;
+
+sub sub6 ($) { 1 }
+sub sub6 { 2 }
+
+ok 11, $warn =~ s/$NEWPROTO \Qsub main::sub6 ($) vs none\E[^\n]+\n//s;
+ok 12, $warn =~ s/Subroutine sub6 redefined[^\n]+\n//s;
+
+sub sub7 ($) { 1 }
+sub sub7 () { 2 }
+
+ok 13, $warn =~ s/$NEWPROTO \Qsub main::sub7 ($) vs ()\E[^\n]+\n//s;
+ok 14, $warn =~ s/Subroutine sub7 redefined[^\n]+\n//s;
+
+sub sub8 ($) { 1 }
+sub sub8 ($) { 2 }
+
+ok 15, $warn =~ s/Subroutine sub8 redefined[^\n]+\n//s;
+
+sub sub9 ($@) { 1 }
+sub sub9 ($) { 2 }
+
+ok 16, $warn =~ s/$NEWPROTO sub main::sub9 \(\$\Q@) vs ($)\E[^\n]+\n//s;
+ok 17, $warn =~ s/Subroutine sub9 redefined[^\n]+\n//s;
+
+ok 18, $_ eq '';
+
+# If we got any errors that we were not expecting, then print them
+print $_ if length $_;
+
+
diff --git a/contrib/perl5/t/comp/require.t b/contrib/perl5/t/comp/require.t
new file mode 100755
index 000000000000..203b996e068d
--- /dev/null
+++ b/contrib/perl5/t/comp/require.t
@@ -0,0 +1,50 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = ('.');
+}
+
+# don't make this lexical
+$i = 1;
+print "1..4\n";
+
+sub do_require {
+ %INC = ();
+ write_file('bleah.pm',@_);
+ eval { require "bleah.pm" };
+ my @a; # magic guard for scope violations (must be first lexical in file)
+}
+
+sub write_file {
+ my $f = shift;
+ open(REQ,">$f") or die "Can't write '$f': $!";
+ print REQ @_;
+ close REQ;
+}
+
+# interaction with pod (see the eof)
+write_file('bleah.pm', "print 'ok $i\n'; 1;\n");
+require "bleah.pm";
+$i++;
+
+# run-time failure in require
+do_require "0;\n";
+print "# $@\nnot " unless $@ =~ /did not return a true/;
+print "ok ",$i++,"\n";
+
+# compile-time failure in require
+do_require "1)\n";
+print "# $@\nnot " unless $@ =~ /syntax error/i;
+print "ok ",$i++,"\n";
+
+# successful require
+do_require "1";
+print "# $@\nnot " if $@;
+print "ok ",$i++,"\n";
+
+END { unlink 'bleah.pm'; }
+
+# ***interaction with pod (don't put any thing after here)***
+
+=pod
diff --git a/contrib/perl5/t/comp/script.t b/contrib/perl5/t/comp/script.t
new file mode 100755
index 000000000000..d0c12e955280
--- /dev/null
+++ b/contrib/perl5/t/comp/script.t
@@ -0,0 +1,27 @@
+#!./perl
+
+# $RCSfile: script.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:23 $
+
+print "1..3\n";
+
+$PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl';
+$x = `$PERL -le "print 'ok';"`;
+if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. -e "print ""ok\n""";`; }
+
+if ($x eq "ok\n") {print "ok 1\n";} else {print "not ok 1\n";}
+
+open(try,">Comp.script") || (die "Can't open temp file.");
+print try 'print "ok\n";'; print try "\n";
+close try;
+
+$x = `$PERL Comp.script`;
+if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. Comp.script`; }
+
+if ($x eq "ok\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+$x = `$PERL <Comp.script`;
+if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. <Comp.script`; }
+
+if ($x eq "ok\n") {print "ok 3\n";} else {print "not ok 3\n";}
+
+unlink 'Comp.script' || `/bin/rm -f Comp.script`;
diff --git a/contrib/perl5/t/comp/term.t b/contrib/perl5/t/comp/term.t
new file mode 100755
index 000000000000..eb9968003e7d
--- /dev/null
+++ b/contrib/perl5/t/comp/term.t
@@ -0,0 +1,70 @@
+#!./perl
+
+# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:24 $
+
+# tests that aren't important enough for base.term
+
+print "1..22\n";
+
+$x = "\\n";
+print "#1\t:$x: eq " . ':\n:' . "\n";
+if ($x eq '\n') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$x = "#2\t:$x: eq :\\n:\n";
+print $x;
+unless (index($x,'\\\\')>0) {print "ok 2\n";} else {print "not ok 2\n";}
+
+if (length('\\\\') == 2) {print "ok 3\n";} else {print "not ok 3\n";}
+
+$one = 'a';
+
+if (length("\\n") == 2) {print "ok 4\n";} else {print "not ok 4\n";}
+if (length("\\\n") == 2) {print "ok 5\n";} else {print "not ok 5\n";}
+if (length("$one\\n") == 3) {print "ok 6\n";} else {print "not ok 6\n";}
+if (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";}
+if (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";}
+if (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";}
+if (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";}
+
+if ("${one}b" eq "ab") { print "ok 11\n";} else {print "not ok 11\n";}
+
+@foo = (1,2,3);
+if ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";}
+if ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";}
+$" = '::';
+if ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";}
+
+# test if C<eval "{...}"> distinguishes between blocks and hashrefs
+
+$a = "{ '\\'' , 'foo' }";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 15\n";} else {print "not ok 15\n";}
+
+$a = "{ '\\\\\\'abc' => 'foo' }";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 16\n";} else {print "not ok 16\n";}
+
+$a = "{'a\\\n\\'b','foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 17\n";} else {print "not ok 17\n";}
+
+$a = "{'\\\\\\'\\\\'=>'foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 18\n";} else {print "not ok 18\n";}
+
+$a = "{q,a'b,,'foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 19\n";} else {print "not ok 19\n";}
+
+$a = "{q[[']]=>'foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 20\n";} else {print "not ok 20\n";}
+
+# needs disambiguation if first term is a variable
+$a = "+{ \$a , 'foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 21\n";} else {print "not ok 21\n";}
+
+$a = "+{ \$a=>'foo'}";
+$a = eval $a;
+if (ref($a) eq 'HASH') {print "ok 22\n";} else {print "not ok 22\n";}
diff --git a/contrib/perl5/t/comp/use.t b/contrib/perl5/t/comp/use.t
new file mode 100755
index 000000000000..a6ce2a4d565c
--- /dev/null
+++ b/contrib/perl5/t/comp/use.t
@@ -0,0 +1,101 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..14\n";
+
+my $i = 1;
+
+eval "use 5.000;";
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+eval sprintf "use %.5f;", $];
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+
+eval sprintf "use %.5f;", $] - 0.000001;
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+eval sprintf("use %.5f;", $] + 1);
+unless ($@) {
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+eval sprintf "use %.5f;", $] + 0.00001;
+unless ($@) {
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+
+
+use lib; # I know that this module will be there.
+
+
+local $lib::VERSION = 1.0;
+
+eval "use lib 0.9";
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+eval "use lib 1.0";
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+eval "use lib 1.01";
+unless ($@) {
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+
+eval "use lib 0.9 qw(fred)";
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+print "not " unless $INC[0] eq "fred";
+print "ok ",$i++,"\n";
+
+eval "use lib 1.0 qw(joe)";
+if ($@) {
+ print STDERR $@,"\n";
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+print "not " unless $INC[0] eq "joe";
+print "ok ",$i++,"\n";
+
+eval "use lib 1.01 qw(freda)";
+unless ($@) {
+ print "not ";
+}
+print "ok ",$i++,"\n";
+
+print "not " if $INC[0] eq "freda";
+print "ok ",$i++,"\n";
diff --git a/contrib/perl5/t/harness b/contrib/perl5/t/harness
new file mode 100644
index 000000000000..f6d94de90f2e
--- /dev/null
+++ b/contrib/perl5/t/harness
@@ -0,0 +1,33 @@
+#!./perl
+
+# We suppose that perl _mostly_ works at this moment, so may use
+# sophisticated testing.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib'; # so children will see it too
+}
+use lib '../lib';
+
+use Test::Harness;
+
+$Test::Harness::switches = ""; # Too much noise otherwise
+$Test::Harness::verbose = shift if @ARGV && $ARGV[0] eq '-v';
+
+@tests = @ARGV;
+@tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t> unless @tests;
+
+Test::Harness::runtests @tests;
+
+%infinite = ('comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
+
+@tests = grep (!$infinite{$_}, @tests);
+
+if (-e "../testcompile")
+{
+ print "The tests ", join(' ', keys(%infinite)),
+ " generate infinite loops! Skipping!\n";
+
+ $ENV{'COMPILE_TEST'} = 1; Test::Harness::runtests @tests;
+}
diff --git a/contrib/perl5/t/io/argv.t b/contrib/perl5/t/io/argv.t
new file mode 100755
index 000000000000..d99865e142eb
--- /dev/null
+++ b/contrib/perl5/t/io/argv.t
@@ -0,0 +1,48 @@
+#!./perl
+
+# $RCSfile: argv.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:25 $
+
+print "1..5\n";
+
+open(try, '>Io.argv.tmp') || (die "Can't open temp file.");
+print try "a line\n";
+close try;
+
+if ($^O eq 'MSWin32') {
+ $x = `.\\perl -e "while (<>) {print \$.,\$_;}" Io.argv.tmp Io.argv.tmp`;
+}
+else {
+ $x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`;
+}
+if ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";}
+
+if ($^O eq 'MSWin32') {
+ $x = `.\\perl -le "print 'foo'" | .\\perl -e "while (<>) {print \$_;}" Io.argv.tmp -`;
+}
+else {
+ $x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`;
+}
+if ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+if ($^O eq 'MSWin32') {
+ $x = `.\\perl -le "print 'foo'" |.\\perl -e "while (<>) {print \$_;}"`;
+}
+else {
+ $x = `echo foo|./perl -e 'while (<>) {print $_;}'`;
+}
+if ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3 :$x:\n";}
+
+@ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp');
+while (<>) {
+ $y .= $. . $_;
+ if (eof()) {
+ if ($. == 3) {print "ok 4\n";} else {print "not ok 4\n";}
+ }
+}
+
+if ($y eq "1a line\n2a line\n3a line\n")
+ {print "ok 5\n";}
+else
+ {print "not ok 5\n";}
+
+unlink 'Io.argv.tmp';
diff --git a/contrib/perl5/t/io/dup.t b/contrib/perl5/t/io/dup.t
new file mode 100755
index 000000000000..f312671e56be
--- /dev/null
+++ b/contrib/perl5/t/io/dup.t
@@ -0,0 +1,39 @@
+#!./perl
+
+# $RCSfile: dup.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:27 $
+
+print "1..6\n";
+
+print "ok 1\n";
+
+open(dupout,">&STDOUT");
+open(duperr,">&STDERR");
+
+open(STDOUT,">Io.dup") || die "Can't open stdout";
+open(STDERR,">&STDOUT") || die "Can't open stderr";
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+print STDOUT "ok 2\n";
+print STDERR "ok 3\n";
+if ($^O eq 'MSWin32') {
+ print `echo ok 4`;
+ print `echo ok 5 1>&2`; # does this work?
+}
+else {
+ system 'echo ok 4';
+ system 'echo ok 5 1>&2';
+}
+
+close(STDOUT);
+close(STDERR);
+
+open(STDOUT,">&dupout");
+open(STDERR,">&duperr");
+
+if ($^O eq 'MSWin32') { print `type Io.dup` }
+else { system 'cat Io.dup' }
+unlink 'Io.dup';
+
+print STDOUT "ok 6\n";
diff --git a/contrib/perl5/t/io/fs.t b/contrib/perl5/t/io/fs.t
new file mode 100755
index 000000000000..164a6676e68b
--- /dev/null
+++ b/contrib/perl5/t/io/fs.t
@@ -0,0 +1,159 @@
+#!./perl
+
+# $RCSfile: fs.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:28 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+
+$Is_Dosish = ($^O eq 'dos' or $^O eq 'os2');
+
+# avoid win32 (for now)
+do { print "1..0\n"; exit(0); } if $^O eq 'MSWin32';
+
+print "1..26\n";
+
+$wd = (($^O eq 'MSWin32') ? `cd` : `pwd`);
+chop($wd);
+
+if ($^O eq 'MSWin32') { `del tmp`; `mkdir tmp`; }
+else { `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; }
+chdir './tmp';
+`/bin/rm -rf a b c x` if -x '/bin/rm';
+
+umask(022);
+
+if ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";}
+open(fh,'>x') || die "Can't create x";
+close(fh);
+open(fh,'>a') || die "Can't create a";
+close(fh);
+
+if ($Is_Dosish) {print "ok 2 # skipped: no link\n";}
+elsif (eval {link('a','b')}) {print "ok 2\n";}
+else {print "not ok 2\n";}
+
+if ($Is_Dosish) {print "ok 3 # skipped: no link\n";}
+elsif (eval {link('b','c')}) {print "ok 3\n";}
+else {print "not ok 3\n";}
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('c');
+
+if ($Config{dont_use_nlink} || $Is_Dosish)
+ {print "ok 4 # skipped: no link\n";}
+elsif ($nlink == 3)
+ {print "ok 4\n";}
+else {print "not ok 4\n";}
+
+if ($^O eq 'amigaos' || $Is_Dosish)
+ {print "ok 5 # skipped: no link\n";}
+elsif (($mode & 0777) == 0666)
+ {print "ok 5\n";}
+else {print "not ok 5\n";}
+
+if ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";}
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('c');
+if ($Is_Dosish) {print "ok 7 # skipped: no link\n";}
+elsif (($mode & 0777) == 0777) {print "ok 7\n";}
+else {print "not ok 7\n";}
+
+if ($Is_Dosish) {print "ok 8 # skipped: no link\n";}
+elsif ((chmod 0700,'c','x') == 2) {print "ok 8\n";}
+else {print "not ok 8\n";}
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('c');
+if ($Is_Dosish) {print "ok 9 # skipped: no link\n";}
+elsif (($mode & 0777) == 0700) {print "ok 9\n";}
+else {print "not ok 9\n";}
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('x');
+if ($Is_Dosish) {print "ok 10 # skipped: no link\n";}
+elsif (($mode & 0777) == 0700) {print "ok 10\n";}
+else {print "not ok 10\n";}
+
+if ($Is_Dosish) {print "ok 11 # skipped: no link\n"; unlink 'b','x'; }
+elsif ((unlink 'b','x') == 2) {print "ok 11\n";}
+else {print "not ok 11\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('b');
+if ($ino == 0) {print "ok 12\n";} else {print "not ok 12\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('x');
+if ($ino == 0) {print "ok 13\n";} else {print "not ok 13\n";}
+
+if (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('a');
+if ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";}
+$delta = $Is_Dosish ? 2 : 1; # Granularity of time on the filesystem
+$foo = (utime 500000000,500000000 + $delta,'b');
+if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('b');
+if ($ino) {print "ok 17\n";} else {print "not ok 17\n";}
+if ($wd =~ m#/afs/# || $^O eq 'amigaos')
+ {print "ok 18 # skipped: granularity of the filetime\n";}
+elsif ($atime == 500000000 && $mtime == 500000000 + $delta)
+ {print "ok 18\n";}
+else
+ {print "not ok 18 $atime $mtime\n";}
+
+if ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";}
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('b');
+if ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";}
+unlink 'c';
+
+chdir $wd || die "Can't cd back to $wd";
+rmdir 'tmp';
+
+unlink 'c';
+if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) {
+ # we have symbolic links
+ if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";}
+ $foo = `grep perl c`;
+ if ($foo) {print "ok 22\n";} else {print "not ok 22\n";}
+ unlink 'c';
+}
+else {
+ print "ok 21\nok 22\n";
+}
+
+# truncate (may not be implemented everywhere)
+unlink "Iofs.tmp";
+`echo helloworld > Iofs.tmp`;
+eval { truncate "Iofs.tmp", 5; };
+if ($@ =~ /not implemented/) {
+ print "# truncate not implemented -- skipping tests 23 through 26\n";
+ for (23 .. 26) {
+ print "ok $_\n";
+ }
+}
+else {
+ if (-s "Iofs.tmp" == 5) {print "ok 23\n"} else {print "not ok 23\n"}
+ truncate "Iofs.tmp", 0;
+ if (-z "Iofs.tmp") {print "ok 24\n"} else {print "not ok 24\n"}
+ open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp";
+ { select FH; $| = 1; select STDOUT }
+ print FH "helloworld\n";
+ truncate FH, 5;
+ if ($^O eq 'dos') {
+ close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
+ }
+ if (-s "Iofs.tmp" == 5) {print "ok 25\n"} else {print "not ok 25\n"}
+ truncate FH, 0;
+ if ($^O eq 'dos') {
+ close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
+ }
+ if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"}
+ close FH;
+}
+unlink "Iofs.tmp";
diff --git a/contrib/perl5/t/io/inplace.t b/contrib/perl5/t/io/inplace.t
new file mode 100755
index 000000000000..ff410a7b5fca
--- /dev/null
+++ b/contrib/perl5/t/io/inplace.t
@@ -0,0 +1,36 @@
+#!./perl
+
+$^I = $^O eq 'VMS' ? '_bak' : '.bak';
+
+# $RCSfile: inplace.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:29 $
+
+print "1..2\n";
+
+@ARGV = ('.a','.b','.c');
+if ($^O eq 'MSWin32') {
+ $CAT = '.\perl -e "print<>"';
+ `.\\perl -le "print 'foo'" > .a`;
+ `.\\perl -le "print 'foo'" > .b`;
+ `.\\perl -le "print 'foo'" > .c`;
+}
+elsif ($^O eq 'VMS') {
+ $CAT = 'MCR []perl. -e "print<>"';
+ `MCR []perl. -le "print 'foo'" > ./.a`;
+ `MCR []perl. -le "print 'foo'" > ./.b`;
+ `MCR []perl. -le "print 'foo'" > ./.c`;
+}
+else {
+ $CAT = 'cat';
+ `echo foo | tee .a .b .c`;
+}
+while (<>) {
+ s/foo/bar/;
+}
+continue {
+ print;
+}
+
+if (`$CAT .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";}
+if (`$CAT .a$^I .b$^I .c$^I` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+unlink '.a', '.b', '.c', ".a$^I", ".b$^I", ".c$^I";
diff --git a/contrib/perl5/t/io/iprefix.t b/contrib/perl5/t/io/iprefix.t
new file mode 100755
index 000000000000..10a5c5f686a0
--- /dev/null
+++ b/contrib/perl5/t/io/iprefix.t
@@ -0,0 +1,36 @@
+#!./perl
+
+$^I = 'bak*';
+
+# Modified from the original inplace.t to test adding prefixes
+
+print "1..2\n";
+
+@ARGV = ('.a','.b','.c');
+if ($^O eq 'MSWin32') {
+ $CAT = '.\perl -e "print<>"';
+ `.\\perl -le "print 'foo'" > .a`;
+ `.\\perl -le "print 'foo'" > .b`;
+ `.\\perl -le "print 'foo'" > .c`;
+}
+elsif ($^O eq 'VMS') {
+ $CAT = 'MCR []perl. -e "print<>"';
+ `MCR []perl. -le "print 'foo'" > ./.a`;
+ `MCR []perl. -le "print 'foo'" > ./.b`;
+ `MCR []perl. -le "print 'foo'" > ./.c`;
+}
+else {
+ $CAT = 'cat';
+ `echo foo | tee .a .b .c`;
+}
+while (<>) {
+ s/foo/bar/;
+}
+continue {
+ print;
+}
+
+if (`$CAT .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";}
+if (`$CAT bak.a bak.b bak.c` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
+
+unlink '.a', '.b', '.c', 'bak.a', 'bak.b', 'bak.c';
diff --git a/contrib/perl5/t/io/pipe.t b/contrib/perl5/t/io/pipe.t
new file mode 100755
index 000000000000..ba7a9b093b66
--- /dev/null
+++ b/contrib/perl5/t/io/pipe.t
@@ -0,0 +1,135 @@
+#!./perl
+
+# $RCSfile: pipe.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:31 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ unless ($Config{'d_fork'}) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+$| = 1;
+print "1..12\n";
+
+open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
+print PIPE "Xk 1\n";
+print PIPE "oY 2\n";
+close PIPE;
+
+if (open(PIPE, "-|")) {
+ while(<PIPE>) {
+ s/^not //;
+ print;
+ }
+ close PIPE; # avoid zombies which disrupt test 12
+}
+else {
+ print STDOUT "not ok 3\n";
+ exec 'echo', 'not ok 4';
+}
+
+pipe(READER,WRITER) || die "Can't open pipe";
+
+if ($pid = fork) {
+ close WRITER;
+ while(<READER>) {
+ s/^not //;
+ y/A-Z/a-z/;
+ print;
+ }
+ close READER; # avoid zombies which disrupt test 12
+}
+else {
+ die "Couldn't fork" unless defined $pid;
+ close READER;
+ print WRITER "not ok 5\n";
+ open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
+ close WRITER;
+ exec 'echo', 'not ok 6';
+}
+
+
+pipe(READER,WRITER) || die "Can't open pipe";
+close READER;
+
+$SIG{'PIPE'} = 'broken_pipe';
+
+sub broken_pipe {
+ $SIG{'PIPE'} = 'IGNORE'; # loop preventer
+ print "ok 7\n";
+}
+
+print WRITER "not ok 7\n";
+close WRITER;
+sleep 1;
+print "ok 8\n";
+
+# VMS doesn't like spawning subprocesses that are still connected to
+# STDOUT. Someone should modify tests #9 to #12 to work with VMS.
+
+if ($^O eq 'VMS') {
+ print "ok 9\n";
+ print "ok 10\n";
+ print "ok 11\n";
+ print "ok 12\n";
+ exit;
+}
+
+if ($Config{d_sfio} || $^O eq machten || $^O eq beos) {
+ # Sfio doesn't report failure when closing a broken pipe
+ # that has pending output. Go figure. MachTen doesn't either,
+ # but won't write to broken pipes, so nothing's pending at close.
+ # BeOS will not write to broken pipes, either.
+ print "ok 9\n";
+}
+else {
+ local $SIG{PIPE} = 'IGNORE';
+ open NIL, '|true' or die "open failed: $!";
+ sleep 2;
+ print NIL 'foo' or die "print failed: $!";
+ if (close NIL) {
+ print "not ok 9\n";
+ }
+ else {
+ print "ok 9\n";
+ }
+}
+
+# check that errno gets forced to 0 if the piped program exited non-zero
+open NIL, '|exit 23;' or die "fork failed: $!";
+$! = 1;
+if (close NIL) {
+ print "not ok 10\n# successful close\n";
+}
+elsif ($! != 0) {
+ print "not ok 10\n# errno $!\n";
+}
+elsif ($? == 0) {
+ print "not ok 10\n# status 0\n";
+}
+else {
+ print "ok 10\n";
+}
+
+# check that status for the correct process is collected
+wait; # Collect from $pid
+my $zombie = fork or exit 37;
+my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
+$SIG{ALRM} = sub { return };
+alarm(1);
+my $close = close FH;
+if ($? == 13*256 && ! length $close && ! $!) {
+ print "ok 11\n";
+} else {
+ print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n";
+};
+my $wait = wait;
+if ($? == 37*256 && $wait == $zombie && ! $!) {
+ print "ok 12\n";
+} else {
+ print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$? \$!=", $!+0, ":$!\n";
+}
diff --git a/contrib/perl5/t/io/print.t b/contrib/perl5/t/io/print.t
new file mode 100755
index 000000000000..180b1e88d721
--- /dev/null
+++ b/contrib/perl5/t/io/print.t
@@ -0,0 +1,32 @@
+#!./perl
+
+# $RCSfile: print.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:32 $
+
+print "1..16\n";
+
+$foo = 'STDOUT';
+print $foo "ok 1\n";
+
+print "ok 2\n","ok 3\n","ok 4\n";
+print STDOUT "ok 5\n";
+
+open(foo,">-");
+print foo "ok 6\n";
+
+printf "ok %d\n",7;
+printf("ok %d\n",8);
+
+@a = ("ok %d%c",9,ord("\n"));
+printf @a;
+
+$a[1] = 10;
+printf STDOUT @a;
+
+$, = ' ';
+$\ = "\n";
+
+print "ok","11";
+
+@x = ("ok","12\nok","13\nok");
+@y = ("15\nok","16");
+print @x,"14\nok",@y;
diff --git a/contrib/perl5/t/io/read.t b/contrib/perl5/t/io/read.t
new file mode 100755
index 000000000000..b27fde17c7ba
--- /dev/null
+++ b/contrib/perl5/t/io/read.t
@@ -0,0 +1,26 @@
+#!./perl
+
+# $RCSfile$
+
+print "1..1\n";
+
+open(A,"+>a");
+print A "_";
+seek(A,0,0);
+
+$b = "abcd";
+$b = "";
+
+read(A,$b,1,4);
+
+close(A);
+
+unlink("a");
+
+if ($b eq "\000\000\000\000_") {
+ print "ok 1\n";
+} else { # Probably "\000bcd_"
+ print "not ok 1\n";
+}
+
+unlink 'a';
diff --git a/contrib/perl5/t/io/tell.t b/contrib/perl5/t/io/tell.t
new file mode 100755
index 000000000000..83904e88bba8
--- /dev/null
+++ b/contrib/perl5/t/io/tell.t
@@ -0,0 +1,44 @@
+#!./perl
+
+# $RCSfile: tell.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:33 $
+
+print "1..13\n";
+
+$TST = 'tst';
+
+open($TST, '../Configure') || (die "Can't open ../Configure");
+binmode $TST if $^O eq 'MSWin32';
+if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
+
+$firstline = <$TST>;
+$secondpos = tell;
+
+$x = 0;
+while (<tst>) {
+ if (eof) {$x++;}
+}
+if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
+
+$lastpos = tell;
+
+unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
+
+if (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
+
+if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
+
+if ($firstline eq <tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
+
+if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
+
+if (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
+
+if (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; }
+
+if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
+
+if (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
+
+if ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
+
+unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
diff --git a/contrib/perl5/t/lib/abbrev.t b/contrib/perl5/t/lib/abbrev.t
new file mode 100755
index 000000000000..fb5a9841eb1b
--- /dev/null
+++ b/contrib/perl5/t/lib/abbrev.t
@@ -0,0 +1,51 @@
+#!./perl
+
+print "1..7\n";
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Text::Abbrev;
+
+print "ok 1\n";
+
+# old style as reference
+local(%x);
+my @z = qw(list edit send abort gripe listen);
+abbrev(*x, @z);
+my $r = join ':', sort keys %x;
+print "not " if exists $x{'l'} ||
+ exists $x{'li'} ||
+ exists $x{'lis'};
+print "ok 2\n";
+
+print "not " unless $x{'list'} eq 'list' &&
+ $x{'liste'} eq 'listen' &&
+ $x{'listen'} eq 'listen';
+print "ok 3\n";
+
+print "not " unless $x{'a'} eq 'abort' &&
+ $x{'ab'} eq 'abort' &&
+ $x{'abo'} eq 'abort' &&
+ $x{'abor'} eq 'abort' &&
+ $x{'abort'} eq 'abort';
+print "ok 4\n";
+
+my $test = 5;
+
+# wantarray
+my %y = abbrev @z;
+my $s = join ':', sort keys %y;
+print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++;
+
+my $y = abbrev @z;
+$s = join ':', sort keys %$y;
+print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++;
+
+%y = ();
+abbrev \%y, @z;
+
+$s = join ':', sort keys %y;
+print (($r eq $s)?"ok $test\n":"not ok $test\n"); $test++;
diff --git a/contrib/perl5/t/lib/anydbm.t b/contrib/perl5/t/lib/anydbm.t
new file mode 100755
index 000000000000..0391b7b4900c
--- /dev/null
+++ b/contrib/perl5/t/lib/anydbm.t
@@ -0,0 +1,125 @@
+#!./perl
+
+# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+require AnyDBM_File;
+#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+use Fcntl;
+
+print "1..12\n";
+
+unlink <Op_dbmx*>;
+
+umask(0);
+print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640)
+ ? "ok 1\n" : "not ok 1\n");
+
+$Dfile = "Op_dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op_dbmx*>;
+}
+if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') {
+ print "ok 2 # Skipped: different file permission semantics\n";
+}
+else {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+}
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+print (!$i ? "ok 3\n" : "not ok 3 # i=$i\n\n");
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+$h{'b'} = 'B';
+$h{'c'} = 'C';
+$h{'d'} = 'D';
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'G';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+untie(%h);
+print (tie(%h,AnyDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+delete $h{'goner3'};
+
+@keys = keys(%h);
+@values = values(%h);
+
+if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+@keys = ('blurfl', keys(%h), 'dyick');
+if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+$h{'foo'} = '';
+$h{''} = 'bar';
+
+# check cache overflow and numeric keys and contents
+$ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+print ($ok ? "ok 8\n" : "not ok 8\n");
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+@h{0..200} = 200..400;
+@foo = @h{0..200};
+print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
+print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
+
+untie %h;
+if ($^O eq 'VMS') {
+ unlink 'Op_dbmx.sdbm_dir', $Dfile;
+} else {
+ unlink 'Op_dbmx.dir', $Dfile;
+}
diff --git a/contrib/perl5/t/lib/autoloader.t b/contrib/perl5/t/lib/autoloader.t
new file mode 100755
index 000000000000..b1622a8ae2e2
--- /dev/null
+++ b/contrib/perl5/t/lib/autoloader.t
@@ -0,0 +1,100 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ $dir = "auto-$$";
+ @INC = ("./$dir", "../lib");
+}
+
+print "1..9\n";
+
+# First we must set up some autoloader files
+mkdir $dir, 0755 or die "Can't mkdir $dir: $!";
+mkdir "$dir/auto", 0755 or die "Can't mkdir: $!";
+mkdir "$dir/auto/Foo", 0755 or die "Can't mkdir: $!";
+
+open(FOO, ">$dir/auto/Foo/foo.al") or die;
+print FOO <<'EOT';
+package Foo;
+sub foo { shift; shift || "foo" }
+1;
+EOT
+close(FOO);
+
+open(BAR, ">$dir/auto/Foo/bar.al") or die;
+print BAR <<'EOT';
+package Foo;
+sub bar { shift; shift || "bar" }
+1;
+EOT
+close(BAR);
+
+open(BAZ, ">$dir/auto/Foo/bazmarkhian.al") or die;
+print BAZ <<'EOT';
+package Foo;
+sub bazmarkhianish { shift; shift || "baz" }
+1;
+EOT
+close(BAZ);
+
+# Let's define the package
+package Foo;
+require AutoLoader;
+@ISA=qw(AutoLoader);
+
+sub new { bless {}, shift };
+
+package main;
+
+$foo = new Foo;
+
+print "not " unless $foo->foo eq 'foo'; # autoloaded first time
+print "ok 1\n";
+
+print "not " unless $foo->foo eq 'foo'; # regular call
+print "ok 2\n";
+
+# Try an undefined method
+eval {
+ $foo->will_fail;
+};
+print "not " unless $@ =~ /^Can't locate/;
+print "ok 3\n";
+
+# Used to be trouble with this
+eval {
+ my $foo = new Foo;
+ die "oops";
+};
+print "not " unless $@ =~ /oops/;
+print "ok 4\n";
+
+# Pass regular expression variable to autoloaded function. This used
+# to go wrong because AutoLoader used regular expressions to generate
+# autoloaded filename.
+"foo" =~ /(\w+)/;
+print "not " unless $1 eq 'foo';
+print "ok 5\n";
+
+print "not " unless $foo->bar($1) eq 'foo';
+print "ok 6\n";
+
+print "not " unless $foo->bar($1) eq 'foo';
+print "ok 7\n";
+
+print "not " unless $foo->bazmarkhianish($1) eq 'foo';
+print "ok 8\n";
+
+print "not " unless $foo->bazmarkhianish($1) eq 'foo';
+print "ok 9\n";
+
+# cleanup
+END {
+return unless $dir && -d $dir;
+unlink "$dir/auto/Foo/foo.al";
+unlink "$dir/auto/Foo/bar.al";
+unlink "$dir/auto/Foo/bazmarkhian.al";
+rmdir "$dir/auto/Foo";
+rmdir "$dir/auto";
+rmdir "$dir";
+}
diff --git a/contrib/perl5/t/lib/basename.t b/contrib/perl5/t/lib/basename.t
new file mode 100755
index 000000000000..a02aa32cb7a7
--- /dev/null
+++ b/contrib/perl5/t/lib/basename.t
@@ -0,0 +1,139 @@
+#!./perl -T
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use File::Basename qw(fileparse basename dirname);
+
+print "1..36\n";
+
+# import correctly?
+print +(defined(&basename) && !defined(&fileparse_set_fstype) ?
+ '' : 'not '),"ok 1\n";
+
+# set fstype -- should replace non-null default
+print +(length(File::Basename::fileparse_set_fstype('unix')) ?
+ '' : 'not '),"ok 2\n";
+
+# Unix syntax tests
+($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7','\.book\d+');
+if ($base eq 'draft' and $path eq '/virgil/aeneid/' and $type eq '.book7') {
+ print "ok 3\n";
+}
+else {
+ print "not ok 3 |$base|$path|$type|\n";
+}
+print +(basename('/arma/virumque.cano') eq 'virumque.cano' ?
+ '' : 'not '),"ok 4\n";
+print +(dirname('/arma/virumque.cano') eq '/arma' ? '' : 'not '),"ok 5\n";
+print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 6\n";
+print +(dirname('/') eq '/' ? '' : 'not '),"ok 7\n";
+
+
+# set fstype -- should replace non-null default
+print +(File::Basename::fileparse_set_fstype('VMS') eq 'unix' ?
+ '' : 'not '),"ok 8\n";
+
+# VMS syntax tests
+($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7','\.book\d+');
+if ($base eq 'draft' and $path eq 'virgil:[aeneid]' and $type eq '.book7') {
+ print "ok 9\n";
+}
+else {
+ print "not ok 9 |$base|$path|$type|\n";
+}
+print +(basename('arma:[virumque]cano.trojae') eq 'cano.trojae' ?
+ '' : 'not '),"ok 10\n";
+print +(dirname('arma:[virumque]cano.trojae') eq 'arma:[virumque]' ?
+ '' : 'not '),"ok 11\n";
+print +(dirname('arma:<virumque>cano.trojae') eq 'arma:<virumque>' ?
+ '' : 'not '),"ok 12\n";
+print +(dirname('arma:virumque.cano') eq 'arma:' ? '' : 'not '),"ok 13\n";
+$ENV{DEFAULT} = '' unless exists $ENV{DEFAULT};
+print +(dirname('virumque.cano') eq $ENV{DEFAULT} ? '' : 'not '),"ok 14\n";
+print +(dirname('arma/') eq '.' ? '' : 'not '),"ok 15\n";
+
+# set fstype -- should replace non-null default
+print +(File::Basename::fileparse_set_fstype('MSDOS') eq 'VMS' ?
+ '' : 'not '),"ok 16\n";
+
+# MSDOS syntax tests
+($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7','\.book\d+');
+if ($base eq 'draft' and $path eq 'C:\\virgil\\aeneid\\' and $type eq '.book7') {
+ print "ok 17\n";
+}
+else {
+ print "not ok 17 |$base|$path|$type|\n";
+}
+print +(basename('A:virumque\\cano.trojae') eq 'cano.trojae' ?
+ '' : 'not '),"ok 18\n";
+print +(dirname('A:\\virumque\\cano.trojae') eq 'A:\\virumque' ?
+ '' : 'not '),"ok 19\n";
+print +(dirname('A:\\') eq 'A:\\' ? '' : 'not '),"ok 20\n";
+print +(dirname('arma\\') eq '.' ? '' : 'not '),"ok 21\n";
+
+# Yes "/" is a legal path separator under MSDOS
+basename("lib/File/Basename.pm") eq "Basename.pm" or print "not ";
+print "ok 22\n";
+
+
+
+# set fstype -- should replace non-null default
+print +(File::Basename::fileparse_set_fstype('MacOS') eq 'MSDOS' ?
+ '' : 'not '),"ok 23\n";
+
+# MacOS syntax tests
+($base,$path,$type) = fileparse('virgil:aeneid:draft.book7','\.book\d+');
+if ($base eq 'draft' and $path eq 'virgil:aeneid:' and $type eq '.book7') {
+ print "ok 24\n";
+}
+else {
+ print "not ok 24 |$base|$path|$type|\n";
+}
+print +(basename(':arma:virumque:cano.trojae') eq 'cano.trojae' ?
+ '' : 'not '),"ok 25\n";
+print +(dirname(':arma:virumque:cano.trojae') eq ':arma:virumque:' ?
+ '' : 'not '),"ok 26\n";
+print +(dirname('arma:') eq 'arma:' ? '' : 'not '),"ok 27\n";
+print +(dirname(':') eq ':' ? '' : 'not '),"ok 28\n";
+
+
+# Check quoting of metacharacters in suffix arg by basename()
+print +(basename(':arma:virumque:cano.trojae','.trojae') eq 'cano' ?
+ '' : 'not '),"ok 29\n";
+print +(basename(':arma:virumque:cano_trojae','.trojae') eq 'cano_trojae' ?
+ '' : 'not '),"ok 30\n";
+
+# extra tests for a few specific bugs
+
+File::Basename::fileparse_set_fstype 'MSDOS';
+# perl5.003_18 gives C:/perl/.\
+print +((fileparse 'C:/perl/lib')[1] eq 'C:/perl/' ? '' : 'not '), "ok 31\n";
+# perl5.003_18 gives C:\perl\
+print +(dirname('C:\\perl\\lib\\') eq 'C:\\perl' ? '' : 'not '), "ok 32\n";
+
+File::Basename::fileparse_set_fstype 'UNIX';
+# perl5.003_18 gives '.'
+print +(dirname('/perl/') eq '/' ? '' : 'not '), "ok 33\n";
+# perl5.003_18 gives '/perl/lib'
+print +(dirname('/perl/lib//') eq '/perl' ? '' : 'not '), "ok 34\n";
+
+# The empty tainted value, for tainting strings
+my $TAINT = substr($^X, 0, 0);
+# How to identify taint when you see it
+sub any_tainted (@) {
+ not eval { join("",@_), kill 0; 1 };
+}
+sub tainted ($) {
+ any_tainted @_;
+}
+sub all_tainted (@) {
+ for (@_) { return 0 unless tainted $_ }
+ 1;
+}
+
+print +(tainted(dirname($TAINT.'/perl/lib//')) ? '' : 'not '), "ok 35\n";
+print +(all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+'))
+ ? '' : 'not '), "ok 36\n";
diff --git a/contrib/perl5/t/lib/bigint.t b/contrib/perl5/t/lib/bigint.t
new file mode 100755
index 000000000000..034c5c645710
--- /dev/null
+++ b/contrib/perl5/t/lib/bigint.t
@@ -0,0 +1,282 @@
+#!./perl
+
+BEGIN { @INC = '../lib' }
+require "bigint.pl";
+
+$test = 0;
+$| = 1;
+print "1..246\n";
+while (<DATA>) {
+ chop;
+ if (/^&/) {
+ $f = $_;
+ } else {
+ ++$test;
+ @args = split(/:/,$_,99);
+ $ans = pop(@args);
+ $try = "$f('" . join("','", @args) . "');";
+ if (($ans1 = eval($try)) eq $ans) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ print "# '$try' expected: '$ans' got: '$ans1'\n";
+ }
+ }
+}
+__END__
+&bnorm
+abc:NaN
+ 1 a:NaN
+1bcd2:NaN
+11111b:NaN
++1z:NaN
+-1z:NaN
+0:+0
++0:+0
++00:+0
++0 0 0:+0
+000000 0000000 00000:+0
+-0:+0
+-0000:+0
++1:+1
++01:+1
++001:+1
++00000100000:+100000
+123456789:+123456789
+-1:-1
+-01:-1
+-001:-1
+-123456789:-123456789
+-00000100000:-100000
+&bneg
+abd:NaN
++0:+0
++1:-1
+-1:+1
++123456789:-123456789
+-123456789:+123456789
+&babs
+abc:NaN
++0:+0
++1:+1
+-1:+1
++123456789:+123456789
+-123456789:+123456789
+&bcmp
+abc:abc:
+abc:+0:
++0:abc:
++0:+0:0
+-1:+0:-1
++0:-1:1
++1:+0:1
++0:+1:-1
+-1:+1:-1
++1:-1:1
+-1:-1:0
++1:+1:0
++123:+123:0
++123:+12:1
++12:+123:-1
+-123:-123:0
+-123:-12:-1
+-12:-123:1
++123:+124:-1
++124:+123:1
+-123:-124:1
+-124:-123:-1
+&badd
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++1:+0:+1
++0:+1:+1
++1:+1:+2
+-1:+0:-1
++0:-1:-1
+-1:-1:-2
+-1:+1:+0
++1:-1:+0
++9:+1:+10
++99:+1:+100
++999:+1:+1000
++9999:+1:+10000
++99999:+1:+100000
++999999:+1:+1000000
++9999999:+1:+10000000
++99999999:+1:+100000000
++999999999:+1:+1000000000
++9999999999:+1:+10000000000
++99999999999:+1:+100000000000
++10:-1:+9
++100:-1:+99
++1000:-1:+999
++10000:-1:+9999
++100000:-1:+99999
++1000000:-1:+999999
++10000000:-1:+9999999
++100000000:-1:+99999999
++1000000000:-1:+999999999
++10000000000:-1:+9999999999
++123456789:+987654321:+1111111110
+-123456789:+987654321:+864197532
+-123456789:-987654321:-1111111110
++123456789:-987654321:-864197532
+&bsub
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++1:+0:+1
++0:+1:-1
++1:+1:+0
+-1:+0:-1
++0:-1:+1
+-1:-1:+0
+-1:+1:-2
++1:-1:+2
++9:+1:+8
++99:+1:+98
++999:+1:+998
++9999:+1:+9998
++99999:+1:+99998
++999999:+1:+999998
++9999999:+1:+9999998
++99999999:+1:+99999998
++999999999:+1:+999999998
++9999999999:+1:+9999999998
++99999999999:+1:+99999999998
++10:-1:+11
++100:-1:+101
++1000:-1:+1001
++10000:-1:+10001
++100000:-1:+100001
++1000000:-1:+1000001
++10000000:-1:+10000001
++100000000:-1:+100000001
++1000000000:-1:+1000000001
++10000000000:-1:+10000000001
++123456789:+987654321:-864197532
+-123456789:+987654321:-1111111110
+-123456789:-987654321:+864197532
++123456789:-987654321:+1111111110
+&bmul
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++0:+1:+0
++1:+0:+0
++0:-1:+0
+-1:+0:+0
++123456789123456789:+0:+0
++0:+123456789123456789:+0
+-1:-1:+1
+-1:+1:-1
++1:-1:-1
++1:+1:+1
++2:+3:+6
+-2:+3:-6
++2:-3:-6
+-2:-3:+6
++111:+111:+12321
++10101:+10101:+102030201
++1001001:+1001001:+1002003002001
++100010001:+100010001:+10002000300020001
++10000100001:+10000100001:+100002000030000200001
++11111111111:+9:+99999999999
++22222222222:+9:+199999999998
++33333333333:+9:+299999999997
++44444444444:+9:+399999999996
++55555555555:+9:+499999999995
++66666666666:+9:+599999999994
++77777777777:+9:+699999999993
++88888888888:+9:+799999999992
++99999999999:+9:+899999999991
+&bdiv
+abc:abc:NaN
+abc:+1:abc:NaN
++1:abc:NaN
++0:+0:NaN
++0:+1:+0
++1:+0:NaN
++0:-1:+0
+-1:+0:NaN
++1:+1:+1
+-1:-1:+1
++1:-1:-1
+-1:+1:-1
++1:+2:+0
++2:+1:+2
++1000000000:+9:+111111111
++2000000000:+9:+222222222
++3000000000:+9:+333333333
++4000000000:+9:+444444444
++5000000000:+9:+555555555
++6000000000:+9:+666666666
++7000000000:+9:+777777777
++8000000000:+9:+888888888
++9000000000:+9:+1000000000
++35500000:+113:+314159
++71000000:+226:+314159
++106500000:+339:+314159
++1000000000:+3:+333333333
++10:+5:+2
++100:+4:+25
++1000:+8:+125
++10000:+16:+625
++999999999999:+9:+111111111111
++999999999999:+99:+10101010101
++999999999999:+999:+1001001001
++999999999999:+9999:+100010001
++999999999999999:+99999:+10000100001
+&bmod
+abc:abc:NaN
+abc:+1:abc:NaN
++1:abc:NaN
++0:+0:NaN
++0:+1:+0
++1:+0:NaN
++0:-1:+0
+-1:+0:NaN
++1:+1:+0
+-1:-1:+0
++1:-1:+0
+-1:+1:+0
++1:+2:+1
++2:+1:+0
++1000000000:+9:+1
++2000000000:+9:+2
++3000000000:+9:+3
++4000000000:+9:+4
++5000000000:+9:+5
++6000000000:+9:+6
++7000000000:+9:+7
++8000000000:+9:+8
++9000000000:+9:+0
++35500000:+113:+33
++71000000:+226:+66
++106500000:+339:+99
++1000000000:+3:+1
++10:+5:+0
++100:+4:+0
++1000:+8:+0
++10000:+16:+0
++999999999999:+9:+0
++999999999999:+99:+0
++999999999999:+999:+0
++999999999999:+9999:+0
++999999999999999:+99999:+0
+&bgcd
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++0:+1:+1
++1:+0:+1
++1:+1:+1
++2:+3:+1
++3:+2:+1
++100:+625:+25
++4096:+81:+1
diff --git a/contrib/perl5/t/lib/bigintpm.t b/contrib/perl5/t/lib/bigintpm.t
new file mode 100755
index 000000000000..e7cac26323d0
--- /dev/null
+++ b/contrib/perl5/t/lib/bigintpm.t
@@ -0,0 +1,313 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Math::BigInt;
+
+$test = 0;
+$| = 1;
+print "1..247\n";
+while (<DATA>) {
+ chop;
+ if (s/^&//) {
+ $f = $_;
+ } else {
+ ++$test;
+ @args = split(/:/,$_,99);
+ $ans = pop(@args);
+ $try = "\$x = new Math::BigInt \"$args[0]\";";
+ if ($f eq "bnorm"){
+ $try .= "\$x+0;";
+ } elsif ($f eq "bneg") {
+ $try .= "-\$x;";
+ } elsif ($f eq "babs") {
+ $try .= "abs \$x;";
+ } else {
+ $try .= "\$y = new Math::BigInt \"$args[1]\";";
+ if ($f eq bcmp){
+ $try .= "\$x <=> \$y;";
+ }elsif ($f eq badd){
+ $try .= "\$x + \$y;";
+ }elsif ($f eq bsub){
+ $try .= "\$x - \$y;";
+ }elsif ($f eq bmul){
+ $try .= "\$x * \$y;";
+ }elsif ($f eq bdiv){
+ $try .= "\$x / \$y;";
+ }elsif ($f eq bmod){
+ $try .= "\$x % \$y;";
+ }elsif ($f eq bgcd){
+ $try .= "Math::BigInt::bgcd(\$x, \$y);";
+ } else { warn "Unknown op"; }
+ }
+ #print ">>>",$try,"<<<\n";
+ $ans1 = eval $try;
+ if ("$ans1" eq $ans) { #bug!
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ print "# '$try' expected: '$ans' got: '$ans1'\n";
+ }
+ }
+}
+__END__
+&bnorm
+abc:NaN
+ 1 a:NaN
+1bcd2:NaN
+11111b:NaN
++1z:NaN
+-1z:NaN
+0:+0
++0:+0
++00:+0
++0 0 0:+0
+000000 0000000 00000:+0
+-0:+0
+-0000:+0
++1:+1
++01:+1
++001:+1
++00000100000:+100000
+123456789:+123456789
+-1:-1
+-01:-1
+-001:-1
+-123456789:-123456789
+-00000100000:-100000
+&bneg
+abd:NaN
++0:+0
++1:-1
+-1:+1
++123456789:-123456789
+-123456789:+123456789
+&babs
+abc:NaN
++0:+0
++1:+1
+-1:+1
++123456789:+123456789
+-123456789:+123456789
+&bcmp
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
+-1:+0:-1
++0:-1:+1
++1:+0:+1
++0:+1:-1
+-1:+1:-1
++1:-1:+1
+-1:-1:+0
++1:+1:+0
++123:+123:+0
++123:+12:+1
++12:+123:-1
+-123:-123:+0
+-123:-12:-1
+-12:-123:+1
++123:+124:-1
++124:+123:+1
+-123:-124:+1
+-124:-123:-1
++100:+5:+1
+&badd
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++1:+0:+1
++0:+1:+1
++1:+1:+2
+-1:+0:-1
++0:-1:-1
+-1:-1:-2
+-1:+1:+0
++1:-1:+0
++9:+1:+10
++99:+1:+100
++999:+1:+1000
++9999:+1:+10000
++99999:+1:+100000
++999999:+1:+1000000
++9999999:+1:+10000000
++99999999:+1:+100000000
++999999999:+1:+1000000000
++9999999999:+1:+10000000000
++99999999999:+1:+100000000000
++10:-1:+9
++100:-1:+99
++1000:-1:+999
++10000:-1:+9999
++100000:-1:+99999
++1000000:-1:+999999
++10000000:-1:+9999999
++100000000:-1:+99999999
++1000000000:-1:+999999999
++10000000000:-1:+9999999999
++123456789:+987654321:+1111111110
+-123456789:+987654321:+864197532
+-123456789:-987654321:-1111111110
++123456789:-987654321:-864197532
+&bsub
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++1:+0:+1
++0:+1:-1
++1:+1:+0
+-1:+0:-1
++0:-1:+1
+-1:-1:+0
+-1:+1:-2
++1:-1:+2
++9:+1:+8
++99:+1:+98
++999:+1:+998
++9999:+1:+9998
++99999:+1:+99998
++999999:+1:+999998
++9999999:+1:+9999998
++99999999:+1:+99999998
++999999999:+1:+999999998
++9999999999:+1:+9999999998
++99999999999:+1:+99999999998
++10:-1:+11
++100:-1:+101
++1000:-1:+1001
++10000:-1:+10001
++100000:-1:+100001
++1000000:-1:+1000001
++10000000:-1:+10000001
++100000000:-1:+100000001
++1000000000:-1:+1000000001
++10000000000:-1:+10000000001
++123456789:+987654321:-864197532
+-123456789:+987654321:-1111111110
+-123456789:-987654321:+864197532
++123456789:-987654321:+1111111110
+&bmul
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++0:+1:+0
++1:+0:+0
++0:-1:+0
+-1:+0:+0
++123456789123456789:+0:+0
++0:+123456789123456789:+0
+-1:-1:+1
+-1:+1:-1
++1:-1:-1
++1:+1:+1
++2:+3:+6
+-2:+3:-6
++2:-3:-6
+-2:-3:+6
++111:+111:+12321
++10101:+10101:+102030201
++1001001:+1001001:+1002003002001
++100010001:+100010001:+10002000300020001
++10000100001:+10000100001:+100002000030000200001
++11111111111:+9:+99999999999
++22222222222:+9:+199999999998
++33333333333:+9:+299999999997
++44444444444:+9:+399999999996
++55555555555:+9:+499999999995
++66666666666:+9:+599999999994
++77777777777:+9:+699999999993
++88888888888:+9:+799999999992
++99999999999:+9:+899999999991
+&bdiv
+abc:abc:NaN
+abc:+1:abc:NaN
++1:abc:NaN
++0:+0:NaN
++0:+1:+0
++1:+0:NaN
++0:-1:+0
+-1:+0:NaN
++1:+1:+1
+-1:-1:+1
++1:-1:-1
+-1:+1:-1
++1:+2:+0
++2:+1:+2
++1000000000:+9:+111111111
++2000000000:+9:+222222222
++3000000000:+9:+333333333
++4000000000:+9:+444444444
++5000000000:+9:+555555555
++6000000000:+9:+666666666
++7000000000:+9:+777777777
++8000000000:+9:+888888888
++9000000000:+9:+1000000000
++35500000:+113:+314159
++71000000:+226:+314159
++106500000:+339:+314159
++1000000000:+3:+333333333
++10:+5:+2
++100:+4:+25
++1000:+8:+125
++10000:+16:+625
++999999999999:+9:+111111111111
++999999999999:+99:+10101010101
++999999999999:+999:+1001001001
++999999999999:+9999:+100010001
++999999999999999:+99999:+10000100001
+&bmod
+abc:abc:NaN
+abc:+1:abc:NaN
++1:abc:NaN
++0:+0:NaN
++0:+1:+0
++1:+0:NaN
++0:-1:+0
+-1:+0:NaN
++1:+1:+0
+-1:-1:+0
++1:-1:+0
+-1:+1:+0
++1:+2:+1
++2:+1:+0
++1000000000:+9:+1
++2000000000:+9:+2
++3000000000:+9:+3
++4000000000:+9:+4
++5000000000:+9:+5
++6000000000:+9:+6
++7000000000:+9:+7
++8000000000:+9:+8
++9000000000:+9:+0
++35500000:+113:+33
++71000000:+226:+66
++106500000:+339:+99
++1000000000:+3:+1
++10:+5:+0
++100:+4:+0
++1000:+8:+0
++10000:+16:+0
++999999999999:+9:+0
++999999999999:+99:+0
++999999999999:+999:+0
++999999999999:+9999:+0
++999999999999999:+99999:+0
+&bgcd
+abc:abc:NaN
+abc:+0:NaN
++0:abc:NaN
++0:+0:+0
++0:+1:+1
++1:+0:+1
++1:+1:+1
++2:+3:+1
++3:+2:+1
++100:+625:+25
++4096:+81:+1
diff --git a/contrib/perl5/t/lib/cgi-form.t b/contrib/perl5/t/lib/cgi-form.t
new file mode 100755
index 000000000000..86df161b02e4
--- /dev/null
+++ b/contrib/perl5/t/lib/cgi-form.t
@@ -0,0 +1,81 @@
+#!./perl
+
+# Test ability to retrieve HTTP request info
+######################### We start with some black magic to print on failure.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+BEGIN {$| = 1; print "1..17\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use CGI (':standard','-no_debug');
+$loaded = 1;
+print "ok 1\n";
+
+######################### End of black magic.
+
+# util
+sub test {
+ local($^W) = 0;
+ my($num, $true,$msg) = @_;
+ print($true ? "ok $num\n" : "not ok $num $msg\n");
+}
+
+# Set up a CGI environment
+$ENV{REQUEST_METHOD}='GET';
+$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull';
+$ENV{PATH_INFO} ='/somewhere/else';
+$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else';
+$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
+$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+$ENV{SERVER_PORT} = 8080;
+$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
+
+test(2,start_form(-action=>'foobar',-method=>GET) eq
+ qq(<FORM METHOD="GET" ACTION="foobar" ENCTYPE="application/x-www-form-urlencoded">\n),
+ "start_form()");
+
+test(3,submit() eq qq(<INPUT TYPE="submit" NAME=".submit">),"submit()");
+test(4,submit(-name=>'foo',-value=>'bar') eq qq(<INPUT TYPE="submit" NAME="foo" VALUE="bar">),"submit(-name,-value)");
+test(5,submit({-name=>'foo',-value=>'bar'}) eq qq(<INPUT TYPE="submit" NAME="foo" VALUE="bar">),"submit({-name,-value})");
+test(6,textfield(-name=>'weather') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name})");
+test(7,textfield(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="text" NAME="weather" VALUE="dull">),"textfield({-name,-value})");
+test(8,textfield(-name=>'weather',-value=>'nice',-override=>1) eq qq(<INPUT TYPE="text" NAME="weather" VALUE="nice">),
+ "textfield({-name,-value,-override})");
+test(9,checkbox(-name=>'weather',-value=>'nice') eq qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">weather\n),
+ "checkbox()");
+test(10,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast') eq
+ qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice">forecast\n),
+ "checkbox()");
+test(11,checkbox(-name=>'weather',-value=>'nice',-label=>'forecast',-checked=>1,-override=>1) eq
+ qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="nice" CHECKED>forecast\n),
+ "checkbox()");
+test(12,checkbox(-name=>'weather',-value=>'dull',-label=>'forecast') eq
+ qq(<INPUT TYPE="checkbox" NAME="weather" VALUE="dull" CHECKED>forecast\n),
+ "checkbox()");
+
+test(13,radio_group(-name=>'game') eq
+ qq(<INPUT TYPE="radio" NAME="game" VALUE="chess" CHECKED>chess <INPUT TYPE="radio" NAME="game" VALUE="checkers">checkers),
+ 'radio_group()');
+test(14,radio_group(-name=>'game',-labels=>{'chess'=>'ping pong'}) eq
+ qq(<INPUT TYPE="radio" NAME="game" VALUE="chess" CHECKED>ping pong <INPUT TYPE="radio" NAME="game" VALUE="checkers">checkers),
+ 'radio_group()');
+
+test(15, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/]) eq
+ qq(<INPUT TYPE="checkbox" NAME="game" VALUE="checkers" CHECKED>checkers <INPUT TYPE="checkbox" NAME="game" VALUE="chess" CHECKED>chess <INPUT TYPE="checkbox" NAME="game" VALUE="cribbage">cribbage),
+ 'checkbox_group()');
+
+test(16, checkbox_group(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Defaults=>['cribbage'],-override=>1) eq
+ qq(<INPUT TYPE="checkbox" NAME="game" VALUE="checkers">checkers <INPUT TYPE="checkbox" NAME="game" VALUE="chess">chess <INPUT TYPE="checkbox" NAME="game" VALUE="cribbage" CHECKED>cribbage),
+ 'checkbox_group()');
+
+test(17, popup_menu(-name=>'game',-Values=>[qw/checkers chess cribbage/],-Default=>'cribbage',-override=>1) eq <<END,'checkbox_group()');
+<SELECT NAME="game">
+<OPTION VALUE="checkers">checkers
+<OPTION VALUE="chess">chess
+<OPTION SELECTED VALUE="cribbage">cribbage
+</SELECT>
+END
+
diff --git a/contrib/perl5/t/lib/cgi-function.t b/contrib/perl5/t/lib/cgi-function.t
new file mode 100755
index 000000000000..ad8b968161de
--- /dev/null
+++ b/contrib/perl5/t/lib/cgi-function.t
@@ -0,0 +1,85 @@
+#!./perl
+
+# Test ability to retrieve HTTP request info
+######################### We start with some black magic to print on failure.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+BEGIN {$| = 1; print "1..24\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Config;
+use CGI (':standard','keywords');
+$loaded = 1;
+print "ok 1\n";
+
+######################### End of black magic.
+
+# util
+sub test {
+ local($^W) = 0;
+ my($num, $true,$msg) = @_;
+ print($true ? "ok $num\n" : "not ok $num $msg\n");
+}
+
+# Set up a CGI environment
+$ENV{REQUEST_METHOD}='GET';
+$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull';
+$ENV{PATH_INFO} ='/somewhere/else';
+$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else';
+$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
+$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+$ENV{SERVER_PORT} = 8080;
+$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
+$ENV{HTTP_LOVE} = 'true';
+
+test(2,request_method() eq 'GET',"CGI::request_method()");
+test(3,query_string() eq 'game=chess&game=checkers&weather=dull',"CGI::query_string()");
+test(4,param() == 2,"CGI::param()");
+test(5,join(' ',sort {$a cmp $b} param()) eq 'game weather',"CGI::param()");
+test(6,param('game') eq 'chess',"CGI::param()");
+test(7,param('weather') eq 'dull',"CGI::param()");
+test(8,join(' ',param('game')) eq 'chess checkers',"CGI::param()");
+test(9,param(-name=>'foo',-value=>'bar'),'CGI::param() put');
+test(10,param(-name=>'foo') eq 'bar','CGI::param() get');
+test(11,query_string() eq 'game=chess&game=checkers&weather=dull&foo=bar',"CGI::query_string() redux");
+test(12,http('love') eq 'true',"CGI::http()");
+test(13,script_name() eq '/cgi-bin/foo.cgi',"CGI::script_name()");
+test(14,url() eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()");
+test(15,self_url() eq
+ 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar',
+ "CGI::url()");
+test(16,url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)');
+test(17,url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)');
+test(18,url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)');
+test(19,url(-relative=>1,-path=>1,-query=>1) eq
+ 'foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar',
+ 'CGI::url(-relative=>1,-path=>1,-query=>1)');
+Delete('foo');
+test(20,!param('foo'),'CGI::delete()');
+
+CGI::_reset_globals();
+$ENV{QUERY_STRING}='mary+had+a+little+lamb';
+test(21,join(' ',keywords()) eq 'mary had a little lamb','CGI::keywords');
+test(22,join(' ',param('keywords')) eq 'mary had a little lamb','CGI::keywords');
+
+if (!$Config{d_fork} or $^O eq 'MSWin32' or $^O eq 'VMS') {
+ for (23,24) { print "ok $_ # Skipped: fork n/a\n" }
+}
+else {
+ CGI::_reset_globals;
+ $test_string = 'game=soccer&game=baseball&weather=nice';
+ $ENV{REQUEST_METHOD}='POST';
+ $ENV{CONTENT_LENGTH}=length($test_string);
+ $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf';
+ if (open(CHILD,"|-")) { # cparent
+ print CHILD $test_string;
+ close CHILD;
+ exit 0;
+ }
+ # at this point, we're in a new (child) process
+ test(23,param('weather') eq 'nice',"CGI::param() from POST");
+ test(24,url_param('big_balls') eq 'basketball',"CGI::url_param()");
+}
diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t
new file mode 100755
index 000000000000..16aa824c51ea
--- /dev/null
+++ b/contrib/perl5/t/lib/cgi-html.t
@@ -0,0 +1,66 @@
+#!./perl
+
+# Test ability to retrieve HTTP request info
+######################### We start with some black magic to print on failure.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+BEGIN {$| = 1; print "1..17\n"; }
+BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ";
+ $eol = "\r\n" if $^O eq 'os390'; }
+END {print "not ok 1\n" unless $loaded;}
+use CGI (':standard','-no_debug');
+$loaded = 1;
+print "ok 1\n";
+
+######################### End of black magic.
+
+# util
+sub test {
+ local($^W) = 0;
+ my($num, $true,$msg) = @_;
+ print($true ? "ok $num\n" : "not ok $num $msg\n");
+}
+
+# all the automatic tags
+test(2,h1() eq '<H1>',"single tag");
+test(3,h1('fred') eq '<H1>fred</H1>',"open/close tag");
+test(4,h1('fred','agnes','maura') eq '<H1>fred agnes maura</H1>',"open/close tag multiple");
+test(5,h1({-align=>'CENTER'},'fred') eq '<H1 ALIGN="CENTER">fred</H1>',"open/close tag with attribute");
+test(6,h1({-align=>undef},'fred') eq '<H1 ALIGN>fred</H1>',"open/close tag with orphan attribute");
+test(7,h1({-align=>'CENTER'},['fred','agnes']) eq
+ '<H1 ALIGN="CENTER">fred</H1> <H1 ALIGN="CENTER">agnes</H1>',
+ "distributive tag with attribute");
+{
+ local($") = '-';
+ test(8,h1('fred','agnes','maura') eq '<H1>fred-agnes-maura</H1>',"open/close tag \$\" interpolation");
+}
+test(9,header() eq "Content-Type: text/html${eol}${eol}","header()");
+test(10,header(-type=>'image/gif') eq "Content-Type: image/gif${eol}${eol}","header()");
+test(11,header(-type=>'image/gif',-status=>'500 Sucks') eq "Status: 500 Sucks${eol}Content-Type: image/gif${eol}${eol}","header()");
+test(12,header(-nph=>1) eq "HTTP/1.0 200 OK${eol}Content-Type: text/html${eol}${eol}","header()");
+test(13,start_html() ."\n" eq <<END,"start_html()");
+<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
+<HTML><HEAD><TITLE>Untitled Document</TITLE>
+</HEAD><BODY>
+END
+ ;
+test(14,start_html(-dtd=>"-//IETF//DTD HTML 3.2//FR") ."\n" eq <<END,"start_html()");
+<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 3.2//FR">
+<HTML><HEAD><TITLE>Untitled Document</TITLE>
+</HEAD><BODY>
+END
+ ;
+test(15,start_html(-Title=>'The world of foo') ."\n" eq <<END,"start_html()");
+<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
+<HTML><HEAD><TITLE>The world of foo</TITLE>
+</HEAD><BODY>
+END
+ ;
+test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) eq
+ 'fred=chocolate&chip; path=/',"cookie()");
+test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${eol}Date:.*${eol}Content-Type: text/html${eol}${eol}!s,
+ "header(-cookie)");
diff --git a/contrib/perl5/t/lib/cgi-request.t b/contrib/perl5/t/lib/cgi-request.t
new file mode 100755
index 000000000000..8c70c40350b4
--- /dev/null
+++ b/contrib/perl5/t/lib/cgi-request.t
@@ -0,0 +1,93 @@
+#!./perl
+
+# Test ability to retrieve HTTP request info
+######################### We start with some black magic to print on failure.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+BEGIN {$| = 1; print "1..31\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use Config;
+use CGI ();
+$loaded = 1;
+print "ok 1\n";
+
+######################### End of black magic.
+
+# util
+sub test {
+ local($^W) = 0;
+ my($num, $true,$msg) = @_;
+ print($true ? "ok $num\n" : "not ok $num $msg\n");
+}
+
+# Set up a CGI environment
+$ENV{REQUEST_METHOD}='GET';
+$ENV{QUERY_STRING} ='game=chess&game=checkers&weather=dull';
+$ENV{PATH_INFO} ='/somewhere/else';
+$ENV{PATH_TRANSLATED} ='/usr/local/somewhere/else';
+$ENV{SCRIPT_NAME} ='/cgi-bin/foo.cgi';
+$ENV{SERVER_PROTOCOL} = 'HTTP/1.0';
+$ENV{SERVER_PORT} = 8080;
+$ENV{SERVER_NAME} = 'the.good.ship.lollypop.com';
+$ENV{HTTP_LOVE} = 'true';
+
+$q = new CGI;
+test(2,$q,"CGI::new()");
+test(3,$q->request_method eq 'GET',"CGI::request_method()");
+test(4,$q->query_string eq 'game=chess&game=checkers&weather=dull',"CGI::query_string()");
+test(5,$q->param() == 2,"CGI::param()");
+test(6,join(' ',sort $q->param()) eq 'game weather',"CGI::param()");
+test(7,$q->param('game') eq 'chess',"CGI::param()");
+test(8,$q->param('weather') eq 'dull',"CGI::param()");
+test(9,join(' ',$q->param('game')) eq 'chess checkers',"CGI::param()");
+test(10,$q->param(-name=>'foo',-value=>'bar'),'CGI::param() put');
+test(11,$q->param(-name=>'foo') eq 'bar','CGI::param() get');
+test(12,$q->query_string eq 'game=chess&game=checkers&weather=dull&foo=bar',"CGI::query_string() redux");
+test(13,$q->http('love') eq 'true',"CGI::http()");
+test(14,$q->script_name eq '/cgi-bin/foo.cgi',"CGI::script_name()");
+test(15,$q->url eq 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi',"CGI::url()");
+test(16,$q->self_url eq
+ 'http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar',
+ "CGI::url()");
+test(17,$q->url(-absolute=>1) eq '/cgi-bin/foo.cgi','CGI::url(-absolute=>1)');
+test(18,$q->url(-relative=>1) eq 'foo.cgi','CGI::url(-relative=>1)');
+test(19,$q->url(-relative=>1,-path=>1) eq 'foo.cgi/somewhere/else','CGI::url(-relative=>1,-path=>1)');
+test(20,$q->url(-relative=>1,-path=>1,-query=>1) eq
+ 'foo.cgi/somewhere/else?game=chess&game=checkers&weather=dull&foo=bar',
+ 'CGI::url(-relative=>1,-path=>1,-query=>1)');
+$q->delete('foo');
+test(21,!$q->param('foo'),'CGI::delete()');
+
+$q->_reset_globals;
+$ENV{QUERY_STRING}='mary+had+a+little+lamb';
+test(22,$q=new CGI,"CGI::new() redux");
+test(23,join(' ',$q->keywords) eq 'mary had a little lamb','CGI::keywords');
+test(24,join(' ',$q->param('keywords')) eq 'mary had a little lamb','CGI::keywords');
+test(25,$q=new CGI('foo=bar&foo=baz'),"CGI::new() redux");
+test(26,$q->param('foo') eq 'bar','CGI::param() redux');
+test(27,$q=new CGI({'foo'=>'bar','bar'=>'froz'}),"CGI::new() redux 2");
+test(28,$q->param('bar') eq 'froz',"CGI::param() redux 2");
+
+if (!$Config{d_fork} or $^O eq 'MSWin32' or $^O eq 'VMS') {
+ for (29..31) { print "ok $_ # Skipped: fork n/a\n" }
+}
+else {
+ $q->_reset_globals;
+ $test_string = 'game=soccer&game=baseball&weather=nice';
+ $ENV{REQUEST_METHOD}='POST';
+ $ENV{CONTENT_LENGTH}=length($test_string);
+ $ENV{QUERY_STRING}='big_balls=basketball&small_balls=golf';
+ if (open(CHILD,"|-")) { # cparent
+ print CHILD $test_string;
+ close CHILD;
+ exit 0;
+ }
+ # at this point, we're in a new (child) process
+ test(29,$q=new CGI,"CGI::new() from POST");
+ test(30,$q->param('weather') eq 'nice',"CGI::param() from POST");
+ test(31,$q->url_param('big_balls') eq 'basketball',"CGI::url_param()");
+}
diff --git a/contrib/perl5/t/lib/checktree.t b/contrib/perl5/t/lib/checktree.t
new file mode 100755
index 000000000000..b5426ca261e7
--- /dev/null
+++ b/contrib/perl5/t/lib/checktree.t
@@ -0,0 +1,19 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..1\n";
+
+use File::CheckTree;
+
+# We assume that we run from the perl "t" directory.
+
+validate q{
+ lib -d || die
+ lib/checktree.t -f || die
+};
+
+print "ok 1\n";
diff --git a/contrib/perl5/t/lib/complex.t b/contrib/perl5/t/lib/complex.t
new file mode 100755
index 000000000000..2bb14f086605
--- /dev/null
+++ b/contrib/perl5/t/lib/complex.t
@@ -0,0 +1,879 @@
+#!./perl
+
+# $RCSfile: complex.t,v $
+#
+# Regression tests for the Math::Complex pacakge
+# -- Raphael Manfredi since Sep 1996
+# -- Jarkko Hietaniemi since Mar 1997
+# -- Daniel S. Lewart since Sep 1997
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Math::Complex;
+
+$VERSION = sprintf("%s", q$Id: complex.t,v 1.8 1998/02/05 16:03:39 jhi Exp $ =~ /(\d+\.d+)/);
+
+my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val);
+
+$test = 0;
+$| = 1;
+my @script = (
+ 'my ($res, $s0,$s1,$s2,$s3,$s4,$s5,$s6,$s7,$s8,$s9,$s10, $z0,$z1,$z2);' .
+ "\n\n"
+);
+my $eps = 1e-13;
+
+if ($^O eq 'unicos') { # For some reason root() produces very inaccurate
+ $eps = 1e-11; # results in Cray UNICOS, and occasionally also
+} # cos(), sin(), cosh(), sinh(). The division
+ # of doubles is the current suspect.
+
+while (<DATA>) {
+ s/^\s+//;
+ next if $_ eq '' || /^\#/;
+ chomp;
+ $test_set = 0; # Assume not a test over a set of values
+ if (/^&(.+)/) {
+ $op = $1;
+ next;
+ }
+ elsif (/^\{(.+)\}/) {
+ set($1, \@set, \@val);
+ next;
+ }
+ elsif (s/^\|//) {
+ $test_set = 1; # Requests we loop over the set...
+ }
+ my @args = split(/:/);
+ if ($test_set == 1) {
+ my $i;
+ for ($i = 0; $i < @set; $i++) {
+ # complex number
+ $target = $set[$i];
+ # textual value as found in set definition
+ $zvalue = $val[$i];
+ test($zvalue, $target, @args);
+ }
+ } else {
+ test($op, undef, @args);
+ }
+}
+
+#
+
+sub test_mutators {
+ my $op;
+
+ $test++;
+push(@script, <<'EOT');
+{
+ my $z = cplx( 1, 1);
+ $z->Re(2);
+ $z->Im(3);
+ print 'not ' unless Re($z) == 2 and Im($z) == 3;
+EOT
+ push(@script, qq(print "ok $test\\n"}\n));
+
+ $test++;
+push(@script, <<'EOT');
+{
+ my $z = cplx( 1, 1);
+ $z->abs(3 * sqrt(2));
+ print 'not ' unless (abs($z) - 3 * sqrt(2)) < $eps and
+ (arg($z) - pi / 4 ) < $eps and
+ (Re($z) - 3 ) < $eps and
+ (Im($z) - 3 ) < $eps;
+EOT
+ push(@script, qq(print "ok $test\\n"}\n));
+
+ $test++;
+push(@script, <<'EOT');
+{
+ my $z = cplx( 1, 1);
+ $z->arg(-3 / 4 * pi);
+ print 'not ' unless (arg($z) + 3 / 4 * pi) < $eps and
+ (abs($z) - sqrt(2) ) < $eps and
+ (Re($z) + 1 ) < $eps and
+ (Im($z) + 1 ) < $eps;
+EOT
+ push(@script, qq(print "ok $test\\n"}\n));
+}
+
+test_mutators();
+
+my $constants = '
+my $i = cplx(0, 1);
+my $pi = cplx(pi, 0);
+my $pii = cplx(0, pi);
+my $pip2 = cplx(pi/2, 0);
+my $zero = cplx(0, 0);
+';
+
+push(@script, $constants);
+
+
+# test the divbyzeros
+
+sub test_dbz {
+ for my $op (@_) {
+ $test++;
+
+ push(@script, <<EOT);
+eval '$op';
+print 'not ' unless (\$@ =~ /Division by zero/);
+EOT
+ push(@script, qq(print "ok $test\\n";\n));
+ }
+}
+
+# test the logofzeros
+
+sub test_loz {
+ for my $op (@_) {
+ $test++;
+
+ push(@script, <<EOT);
+eval '$op';
+print 'not ' unless (\$@ =~ /Logarithm of zero/);
+EOT
+ push(@script, qq(print "ok $test\\n";\n));
+ }
+}
+
+test_dbz(
+ 'i/0',
+ 'acot(0)',
+ 'acot(+$i)',
+# 'acoth(-1)', # Log of zero.
+ 'acoth(0)',
+ 'acoth(+1)',
+ 'acsc(0)',
+ 'acsch(0)',
+ 'asec(0)',
+ 'asech(0)',
+ 'atan(-$i)',
+ 'atan($i)',
+# 'atanh(-1)', # Log of zero.
+ 'atanh(+1)',
+ 'cot(0)',
+ 'coth(0)',
+ 'csc(0)',
+ 'tan($pip2)',
+ 'csch(0)',
+ 'tan($pip2)',
+ );
+
+test_loz(
+ 'log($zero)',
+ 'acot(-$i)',
+ 'atanh(-1)',
+ 'acoth(-1)',
+ );
+
+# test the 0**0
+
+sub test_ztz {
+ $test++;
+
+ push(@script, <<'EOT');
+eval 'cplx(0)**cplx(0)';
+print 'not ' unless ($@ =~ /zero raised to the zeroth/);
+EOT
+ push(@script, qq(print "ok $test\\n";\n));
+}
+
+test_ztz;
+
+# test the bad roots
+
+sub test_broot {
+ for my $op (@_) {
+ $test++;
+
+ push(@script, <<EOT);
+eval 'root(2, $op)';
+print 'not ' unless (\$@ =~ /root must be/);
+EOT
+ push(@script, qq(print "ok $test\\n";\n));
+ }
+}
+
+test_broot(qw(-3 -2.1 0 0.99));
+
+print "1..$test\n";
+eval join '', @script;
+die $@ if $@;
+
+sub abop {
+ my ($op) = @_;
+
+ push(@script, qq(print "# $op=\n";));
+}
+
+sub test {
+ my ($op, $z, @args) = @_;
+ my ($baop) = 0;
+ $test++;
+ my $i;
+ $baop = 1 if ($op =~ s/;=$//);
+ for ($i = 0; $i < @args; $i++) {
+ $val = value($args[$i]);
+ push @script, "\$z$i = $val;\n";
+ }
+ if (defined $z) {
+ $args = "'$op'"; # Really the value
+ $try = "abs(\$z0 - \$z1) <= $eps ? \$z1 : \$z0";
+ push @script, "\$res = $try; ";
+ push @script, "check($test, $args[0], \$res, \$z$#args, $args);\n";
+ } else {
+ my ($try, $args);
+ if (@args == 2) {
+ $try = "$op \$z0";
+ $args = "'$args[0]'";
+ } else {
+ $try = ($op =~ /^\w/) ? "$op(\$z0, \$z1)" : "\$z0 $op \$z1";
+ $args = "'$args[0]', '$args[1]'";
+ }
+ push @script, "\$res = $try; ";
+ push @script, "check($test, '$try', \$res, \$z$#args, $args);\n";
+ if (@args > 2 and $baop) { # binary assignment ops
+ $test++;
+ # check the op= works
+ push @script, <<EOB;
+{
+ my \$za = cplx(ref \$z0 ? \@{\$z0->cartesian} : (\$z0, 0));
+
+ my (\$z1r, \$z1i) = ref \$z1 ? \@{\$z1->cartesian} : (\$z1, 0);
+
+ my \$zb = cplx(\$z1r, \$z1i);
+
+ \$za $op= \$zb;
+ my (\$zbr, \$zbi) = \@{\$zb->cartesian};
+
+ check($test, '\$z0 $op= \$z1', \$za, \$z$#args, $args);
+EOB
+ $test++;
+ # check that the rhs has not changed
+ push @script, qq(print "not " unless (\$zbr == \$z1r and \$zbi == \$z1i););
+ push @script, qq(print "ok $test\\n";\n);
+ push @script, "}\n";
+ }
+ }
+}
+
+sub set {
+ my ($set, $setref, $valref) = @_;
+ @{$setref} = ();
+ @{$valref} = ();
+ my @set = split(/;\s*/, $set);
+ my @res;
+ my $i;
+ for ($i = 0; $i < @set; $i++) {
+ push(@{$valref}, $set[$i]);
+ my $val = value($set[$i]);
+ push @script, "\$s$i = $val;\n";
+ push @{$setref}, "\$s$i";
+ }
+}
+
+sub value {
+ local ($_) = @_;
+ if (/^\s*\((.*),(.*)\)/) {
+ return "cplx($1,$2)";
+ }
+ elsif (/^\s*([\-\+]?(?:\d+(\.\d+)?|\.\d+)(?:[e[\-\+]\d+])?)/) {
+ return "cplx($1,0)";
+ }
+ elsif (/^\s*\[(.*),(.*)\]/) {
+ return "cplxe($1,$2)";
+ }
+ elsif (/^\s*'(.*)'/) {
+ my $ex = $1;
+ $ex =~ s/\bz\b/$target/g;
+ $ex =~ s/\br\b/abs($target)/g;
+ $ex =~ s/\bt\b/arg($target)/g;
+ $ex =~ s/\ba\b/Re($target)/g;
+ $ex =~ s/\bb\b/Im($target)/g;
+ return $ex;
+ }
+ elsif (/^\s*"(.*)"/) {
+ return "\"$1\"";
+ }
+ return $_;
+}
+
+sub check {
+ my ($test, $try, $got, $expected, @z) = @_;
+
+# print "# @_\n";
+
+ if ("$got" eq "$expected"
+ ||
+ ($expected =~ /^-?\d/ && $got == $expected)
+ ||
+ (abs($got - $expected) < $eps)
+ ) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ my $args = (@z == 1) ? "z = $z[0]" : "z0 = $z[0], z1 = $z[1]";
+ print "# '$try' expected: '$expected' got: '$got' for $args\n";
+ }
+}
+
+sub addsq {
+ my ($z1, $z2) = @_;
+ return ($z1 + i*$z2) * ($z1 - i*$z2);
+}
+
+sub subsq {
+ my ($z1, $z2) = @_;
+ return ($z1 + $z2) * ($z1 - $z2);
+}
+
+__END__
+&+;=
+(3,4):(3,4):(6,8)
+(-3,4):(3,-4):(0,0)
+(3,4):-3:(0,4)
+1:(4,2):(5,2)
+[2,0]:[2,pi]:(0,0)
+
+&++
+(2,1):(3,1)
+
+&-;=
+(2,3):(-2,-3)
+[2,pi/2]:[2,-(pi)/2]
+2:[2,0]:(0,0)
+[3,0]:2:(1,0)
+3:(4,5):(-1,-5)
+(4,5):3:(1,5)
+(2,1):(3,5):(-1,-4)
+
+&--
+(1,2):(0,2)
+[2,pi]:[3,pi]
+
+&*;=
+(0,1):(0,1):(-1,0)
+(4,5):(1,0):(4,5)
+[2,2*pi/3]:(1,0):[2,2*pi/3]
+2:(0,1):(0,2)
+(0,1):3:(0,3)
+(0,1):(4,1):(-1,4)
+(2,1):(4,-1):(9,2)
+
+&/;=
+(3,4):(3,4):(1,0)
+(4,-5):1:(4,-5)
+1:(0,1):(0,-1)
+(0,6):(0,2):(3,0)
+(9,2):(4,-1):(2,1)
+[4,pi]:[2,pi/2]:[2,pi/2]
+[2,pi/2]:[4,pi]:[0.5,-(pi)/2]
+
+&**;=
+(2,0):(3,0):(8,0)
+(3,0):(2,0):(9,0)
+(2,3):(4,0):(-119,-120)
+(0,0):(1,0):(0,0)
+(0,0):(2,3):(0,0)
+(1,0):(0,0):(1,0)
+(1,0):(1,0):(1,0)
+(1,0):(2,3):(1,0)
+(2,3):(0,0):(1,0)
+(2,3):(1,0):(2,3)
+
+&Re
+(3,4):3
+(-3,4):-3
+[1,pi/2]:0
+
+&Im
+(3,4):4
+(3,-4):-4
+[1,pi/2]:1
+
+&abs
+(3,4):5
+(-3,4):5
+
+&arg
+[2,0]:0
+[-2,0]:pi
+
+&~
+(4,5):(4,-5)
+(-3,4):(-3,-4)
+[2,pi/2]:[2,-(pi)/2]
+
+&<
+(3,4):(1,2):0
+(3,4):(3,2):0
+(3,4):(3,8):1
+(4,4):(5,129):1
+
+&==
+(3,4):(4,5):0
+(3,4):(3,5):0
+(3,4):(2,4):0
+(3,4):(3,4):1
+
+&sqrt
+-9:(0,3)
+(-100,0):(0,10)
+(16,-30):(5,-3)
+
+&stringify_cartesian
+(-100,0):"-100"
+(0,1):"i"
+(4,-3):"4-3i"
+(4,0):"4"
+(-4,0):"-4"
+(-2,4):"-2+4i"
+(-2,-1):"-2-i"
+
+&stringify_polar
+[-1, 0]:"[1,pi]"
+[1, pi/3]:"[1,pi/3]"
+[6, -2*pi/3]:"[6,-2pi/3]"
+[0.5, -9*pi/11]:"[0.5,-9pi/11]"
+
+{ (4,3); [3,2]; (-3,4); (0,2); [2,1] }
+
+|'z + ~z':'2*Re(z)'
+|'z - ~z':'2*i*Im(z)'
+|'z * ~z':'abs(z) * abs(z)'
+
+{ (0.5, 0); (-0.5, 0); (2,3); [3,2]; (-3,2); (0,2); 3; 1.2; (-3, 0); (-2, -1); [2,1] }
+
+|'(root(z, 4))[1] ** 4':'z'
+|'(root(z, 5))[3] ** 5':'z'
+|'(root(z, 8))[7] ** 8':'z'
+|'abs(z)':'r'
+|'acot(z)':'acotan(z)'
+|'acsc(z)':'acosec(z)'
+|'acsc(z)':'asin(1 / z)'
+|'asec(z)':'acos(1 / z)'
+|'cbrt(z)':'cbrt(r) * exp(i * t/3)'
+|'cos(acos(z))':'z'
+|'addsq(cos(z), sin(z))':1
+|'cos(z)':'cosh(i*z)'
+|'subsq(cosh(z), sinh(z))':1
+|'cot(acot(z))':'z'
+|'cot(z)':'1 / tan(z)'
+|'cot(z)':'cotan(z)'
+|'csc(acsc(z))':'z'
+|'csc(z)':'1 / sin(z)'
+|'csc(z)':'cosec(z)'
+|'exp(log(z))':'z'
+|'exp(z)':'exp(a) * exp(i * b)'
+|'ln(z)':'log(z)'
+|'log(exp(z))':'z'
+|'log(z)':'log(r) + i*t'
+|'log10(z)':'log(z) / log(10)'
+|'logn(z, 2)':'log(z) / log(2)'
+|'logn(z, 3)':'log(z) / log(3)'
+|'sec(asec(z))':'z'
+|'sec(z)':'1 / cos(z)'
+|'sin(asin(z))':'z'
+|'sin(i * z)':'i * sinh(z)'
+|'sqrt(z) * sqrt(z)':'z'
+|'sqrt(z)':'sqrt(r) * exp(i * t/2)'
+|'tan(atan(z))':'z'
+|'z**z':'exp(z * log(z))'
+
+{ (1,1); [1,0.5]; (-2, -1); 2; -3; (-1,0.5); (0,0.5); 0.5; (2, 0); (-1, -2) }
+
+|'cosh(acosh(z))':'z'
+|'coth(acoth(z))':'z'
+|'coth(z)':'1 / tanh(z)'
+|'coth(z)':'cotanh(z)'
+|'csch(acsch(z))':'z'
+|'csch(z)':'1 / sinh(z)'
+|'csch(z)':'cosech(z)'
+|'sech(asech(z))':'z'
+|'sech(z)':'1 / cosh(z)'
+|'sinh(asinh(z))':'z'
+|'tanh(atanh(z))':'z'
+
+{ (0.2,-0.4); [1,0.5]; -1.2; (-1,0.5); 0.5; (1.1, 0) }
+
+|'acos(cos(z)) ** 2':'z * z'
+|'acosh(cosh(z)) ** 2':'z * z'
+|'acoth(z)':'acotanh(z)'
+|'acoth(z)':'atanh(1 / z)'
+|'acsch(z)':'acosech(z)'
+|'acsch(z)':'asinh(1 / z)'
+|'asech(z)':'acosh(1 / z)'
+|'asin(sin(z))':'z'
+|'asinh(sinh(z))':'z'
+|'atan(tan(z))':'z'
+|'atanh(tanh(z))':'z'
+
+&log
+(-2.0,0):( 0.69314718055995, 3.14159265358979)
+(-1.0,0):( 0 , 3.14159265358979)
+(-0.5,0):( -0.69314718055995, 3.14159265358979)
+( 0.5,0):( -0.69314718055995, 0 )
+( 1.0,0):( 0 , 0 )
+( 2.0,0):( 0.69314718055995, 0 )
+
+&log
+( 2, 3):( 1.28247467873077, 0.98279372324733)
+(-2, 3):( 1.28247467873077, 2.15879893034246)
+(-2,-3):( 1.28247467873077, -2.15879893034246)
+( 2,-3):( 1.28247467873077, -0.98279372324733)
+
+&sin
+(-2.0,0):( -0.90929742682568, 0 )
+(-1.0,0):( -0.84147098480790, 0 )
+(-0.5,0):( -0.47942553860420, 0 )
+( 0.0,0):( 0 , 0 )
+( 0.5,0):( 0.47942553860420, 0 )
+( 1.0,0):( 0.84147098480790, 0 )
+( 2.0,0):( 0.90929742682568, 0 )
+
+&sin
+( 2, 3):( 9.15449914691143, -4.16890695996656)
+(-2, 3):( -9.15449914691143, -4.16890695996656)
+(-2,-3):( -9.15449914691143, 4.16890695996656)
+( 2,-3):( 9.15449914691143, 4.16890695996656)
+
+&cos
+(-2.0,0):( -0.41614683654714, 0 )
+(-1.0,0):( 0.54030230586814, 0 )
+(-0.5,0):( 0.87758256189037, 0 )
+( 0.0,0):( 1 , 0 )
+( 0.5,0):( 0.87758256189037, 0 )
+( 1.0,0):( 0.54030230586814, 0 )
+( 2.0,0):( -0.41614683654714, 0 )
+
+&cos
+( 2, 3):( -4.18962569096881, -9.10922789375534)
+(-2, 3):( -4.18962569096881, 9.10922789375534)
+(-2,-3):( -4.18962569096881, -9.10922789375534)
+( 2,-3):( -4.18962569096881, 9.10922789375534)
+
+&tan
+(-2.0,0):( 2.18503986326152, 0 )
+(-1.0,0):( -1.55740772465490, 0 )
+(-0.5,0):( -0.54630248984379, 0 )
+( 0.0,0):( 0 , 0 )
+( 0.5,0):( 0.54630248984379, 0 )
+( 1.0,0):( 1.55740772465490, 0 )
+( 2.0,0):( -2.18503986326152, 0 )
+
+&tan
+( 2, 3):( -0.00376402564150, 1.00323862735361)
+(-2, 3):( 0.00376402564150, 1.00323862735361)
+(-2,-3):( 0.00376402564150, -1.00323862735361)
+( 2,-3):( -0.00376402564150, -1.00323862735361)
+
+&sec
+(-2.0,0):( -2.40299796172238, 0 )
+(-1.0,0):( 1.85081571768093, 0 )
+(-0.5,0):( 1.13949392732455, 0 )
+( 0.0,0):( 1 , 0 )
+( 0.5,0):( 1.13949392732455, 0 )
+( 1.0,0):( 1.85081571768093, 0 )
+( 2.0,0):( -2.40299796172238, 0 )
+
+&sec
+( 2, 3):( -0.04167496441114, 0.09061113719624)
+(-2, 3):( -0.04167496441114, -0.09061113719624)
+(-2,-3):( -0.04167496441114, 0.09061113719624)
+( 2,-3):( -0.04167496441114, -0.09061113719624)
+
+&csc
+(-2.0,0):( -1.09975017029462, 0 )
+(-1.0,0):( -1.18839510577812, 0 )
+(-0.5,0):( -2.08582964293349, 0 )
+( 0.5,0):( 2.08582964293349, 0 )
+( 1.0,0):( 1.18839510577812, 0 )
+( 2.0,0):( 1.09975017029462, 0 )
+
+&csc
+( 2, 3):( 0.09047320975321, 0.04120098628857)
+(-2, 3):( -0.09047320975321, 0.04120098628857)
+(-2,-3):( -0.09047320975321, -0.04120098628857)
+( 2,-3):( 0.09047320975321, -0.04120098628857)
+
+&cot
+(-2.0,0):( 0.45765755436029, 0 )
+(-1.0,0):( -0.64209261593433, 0 )
+(-0.5,0):( -1.83048772171245, 0 )
+( 0.5,0):( 1.83048772171245, 0 )
+( 1.0,0):( 0.64209261593433, 0 )
+( 2.0,0):( -0.45765755436029, 0 )
+
+&cot
+( 2, 3):( -0.00373971037634, -0.99675779656936)
+(-2, 3):( 0.00373971037634, -0.99675779656936)
+(-2,-3):( 0.00373971037634, 0.99675779656936)
+( 2,-3):( -0.00373971037634, 0.99675779656936)
+
+&asin
+(-2.0,0):( -1.57079632679490, 1.31695789692482)
+(-1.0,0):( -1.57079632679490, 0 )
+(-0.5,0):( -0.52359877559830, 0 )
+( 0.0,0):( 0 , 0 )
+( 0.5,0):( 0.52359877559830, 0 )
+( 1.0,0):( 1.57079632679490, 0 )
+( 2.0,0):( 1.57079632679490, -1.31695789692482)
+
+&asin
+( 2, 3):( 0.57065278432110, 1.98338702991654)
+(-2, 3):( -0.57065278432110, 1.98338702991654)
+(-2,-3):( -0.57065278432110, -1.98338702991654)
+( 2,-3):( 0.57065278432110, -1.98338702991654)
+
+&acos
+(-2.0,0):( 3.14159265358979, -1.31695789692482)
+(-1.0,0):( 3.14159265358979, 0 )
+(-0.5,0):( 2.09439510239320, 0 )
+( 0.0,0):( 1.57079632679490, 0 )
+( 0.5,0):( 1.04719755119660, 0 )
+( 1.0,0):( 0 , 0 )
+( 2.0,0):( 0 , 1.31695789692482)
+
+&acos
+( 2, 3):( 1.00014354247380, -1.98338702991654)
+(-2, 3):( 2.14144911111600, -1.98338702991654)
+(-2,-3):( 2.14144911111600, 1.98338702991654)
+( 2,-3):( 1.00014354247380, 1.98338702991654)
+
+&atan
+(-2.0,0):( -1.10714871779409, 0 )
+(-1.0,0):( -0.78539816339745, 0 )
+(-0.5,0):( -0.46364760900081, 0 )
+( 0.0,0):( 0 , 0 )
+( 0.5,0):( 0.46364760900081, 0 )
+( 1.0,0):( 0.78539816339745, 0 )
+( 2.0,0):( 1.10714871779409, 0 )
+
+&atan
+( 2, 3):( 1.40992104959658, 0.22907268296854)
+(-2, 3):( -1.40992104959658, 0.22907268296854)
+(-2,-3):( -1.40992104959658, -0.22907268296854)
+( 2,-3):( 1.40992104959658, -0.22907268296854)
+
+&asec
+(-2.0,0):( 2.09439510239320, 0 )
+(-1.0,0):( 3.14159265358979, 0 )
+(-0.5,0):( 3.14159265358979, -1.31695789692482)
+( 0.5,0):( 0 , 1.31695789692482)
+( 1.0,0):( 0 , 0 )
+( 2.0,0):( 1.04719755119660, 0 )
+
+&asec
+( 2, 3):( 1.42041072246703, 0.23133469857397)
+(-2, 3):( 1.72118193112276, 0.23133469857397)
+(-2,-3):( 1.72118193112276, -0.23133469857397)
+( 2,-3):( 1.42041072246703, -0.23133469857397)
+
+&acsc
+(-2.0,0):( -0.52359877559830, 0 )
+(-1.0,0):( -1.57079632679490, 0 )
+(-0.5,0):( -1.57079632679490, 1.31695789692482)
+( 0.5,0):( 1.57079632679490, -1.31695789692482)
+( 1.0,0):( 1.57079632679490, 0 )
+( 2.0,0):( 0.52359877559830, 0 )
+
+&acsc
+( 2, 3):( 0.15038560432786, -0.23133469857397)
+(-2, 3):( -0.15038560432786, -0.23133469857397)
+(-2,-3):( -0.15038560432786, 0.23133469857397)
+( 2,-3):( 0.15038560432786, 0.23133469857397)
+
+&acot
+(-2.0,0):( -0.46364760900081, 0 )
+(-1.0,0):( -0.78539816339745, 0 )
+(-0.5,0):( -1.10714871779409, 0 )
+( 0.5,0):( 1.10714871779409, 0 )
+( 1.0,0):( 0.78539816339745, 0 )
+( 2.0,0):( 0.46364760900081, 0 )
+
+&acot
+( 2, 3):( 0.16087527719832, -0.22907268296854)
+(-2, 3):( -0.16087527719832, -0.22907268296854)
+(-2,-3):( -0.16087527719832, 0.22907268296854)
+( 2,-3):( 0.16087527719832, 0.22907268296854)
+
+&sinh
+(-2.0,0):( -3.62686040784702, 0 )
+(-1.0,0):( -1.17520119364380, 0 )
+(-0.5,0):( -0.52109530549375, 0 )
+( 0.0,0):( 0 , 0 )
+( 0.5,0):( 0.52109530549375, 0 )
+( 1.0,0):( 1.17520119364380, 0 )
+( 2.0,0):( 3.62686040784702, 0 )
+
+&sinh
+( 2, 3):( -3.59056458998578, 0.53092108624852)
+(-2, 3):( 3.59056458998578, 0.53092108624852)
+(-2,-3):( 3.59056458998578, -0.53092108624852)
+( 2,-3):( -3.59056458998578, -0.53092108624852)
+
+&cosh
+(-2.0,0):( 3.76219569108363, 0 )
+(-1.0,0):( 1.54308063481524, 0 )
+(-0.5,0):( 1.12762596520638, 0 )
+( 0.0,0):( 1 , 0 )
+( 0.5,0):( 1.12762596520638, 0 )
+( 1.0,0):( 1.54308063481524, 0 )
+( 2.0,0):( 3.76219569108363, 0 )
+
+&cosh
+( 2, 3):( -3.72454550491532, 0.51182256998738)
+(-2, 3):( -3.72454550491532, -0.51182256998738)
+(-2,-3):( -3.72454550491532, 0.51182256998738)
+( 2,-3):( -3.72454550491532, -0.51182256998738)
+
+&tanh
+(-2.0,0):( -0.96402758007582, 0 )
+(-1.0,0):( -0.76159415595576, 0 )
+(-0.5,0):( -0.46211715726001, 0 )
+( 0.0,0):( 0 , 0 )
+( 0.5,0):( 0.46211715726001, 0 )
+( 1.0,0):( 0.76159415595576, 0 )
+( 2.0,0):( 0.96402758007582, 0 )
+
+&tanh
+( 2, 3):( 0.96538587902213, -0.00988437503832)
+(-2, 3):( -0.96538587902213, -0.00988437503832)
+(-2,-3):( -0.96538587902213, 0.00988437503832)
+( 2,-3):( 0.96538587902213, 0.00988437503832)
+
+&sech
+(-2.0,0):( 0.26580222883408, 0 )
+(-1.0,0):( 0.64805427366389, 0 )
+(-0.5,0):( 0.88681888397007, 0 )
+( 0.0,0):( 1 , 0 )
+( 0.5,0):( 0.88681888397007, 0 )
+( 1.0,0):( 0.64805427366389, 0 )
+( 2.0,0):( 0.26580222883408, 0 )
+
+&sech
+( 2, 3):( -0.26351297515839, -0.03621163655877)
+(-2, 3):( -0.26351297515839, 0.03621163655877)
+(-2,-3):( -0.26351297515839, -0.03621163655877)
+( 2,-3):( -0.26351297515839, 0.03621163655877)
+
+&csch
+(-2.0,0):( -0.27572056477178, 0 )
+(-1.0,0):( -0.85091812823932, 0 )
+(-0.5,0):( -1.91903475133494, 0 )
+( 0.5,0):( 1.91903475133494, 0 )
+( 1.0,0):( 0.85091812823932, 0 )
+( 2.0,0):( 0.27572056477178, 0 )
+
+&csch
+( 2, 3):( -0.27254866146294, -0.04030057885689)
+(-2, 3):( 0.27254866146294, -0.04030057885689)
+(-2,-3):( 0.27254866146294, 0.04030057885689)
+( 2,-3):( -0.27254866146294, 0.04030057885689)
+
+&coth
+(-2.0,0):( -1.03731472072755, 0 )
+(-1.0,0):( -1.31303528549933, 0 )
+(-0.5,0):( -2.16395341373865, 0 )
+( 0.5,0):( 2.16395341373865, 0 )
+( 1.0,0):( 1.31303528549933, 0 )
+( 2.0,0):( 1.03731472072755, 0 )
+
+&coth
+( 2, 3):( 1.03574663776500, 0.01060478347034)
+(-2, 3):( -1.03574663776500, 0.01060478347034)
+(-2,-3):( -1.03574663776500, -0.01060478347034)
+( 2,-3):( 1.03574663776500, -0.01060478347034)
+
+&asinh
+(-2.0,0):( -1.44363547517881, 0 )
+(-1.0,0):( -0.88137358701954, 0 )
+(-0.5,0):( -0.48121182505960, 0 )
+( 0.0,0):( 0 , 0 )
+( 0.5,0):( 0.48121182505960, 0 )
+( 1.0,0):( 0.88137358701954, 0 )
+( 2.0,0):( 1.44363547517881, 0 )
+
+&asinh
+( 2, 3):( 1.96863792579310, 0.96465850440760)
+(-2, 3):( -1.96863792579310, 0.96465850440761)
+(-2,-3):( -1.96863792579310, -0.96465850440761)
+( 2,-3):( 1.96863792579310, -0.96465850440760)
+
+&acosh
+(-2.0,0):( -1.31695789692482, 3.14159265358979)
+(-1.0,0):( 0, 3.14159265358979)
+(-0.5,0):( 0, 2.09439510239320)
+( 0.0,0):( 0, 1.57079632679490)
+( 0.5,0):( 0, 1.04719755119660)
+( 1.0,0):( 0 , 0 )
+( 2.0,0):( 1.31695789692482, 0 )
+
+&acosh
+( 2, 3):( 1.98338702991654, 1.00014354247380)
+(-2, 3):( -1.98338702991653, -2.14144911111600)
+(-2,-3):( -1.98338702991653, 2.14144911111600)
+( 2,-3):( 1.98338702991654, -1.00014354247380)
+
+&atanh
+(-2.0,0):( -0.54930614433405, 1.57079632679490)
+(-0.5,0):( -0.54930614433405, 0 )
+( 0.0,0):( 0 , 0 )
+( 0.5,0):( 0.54930614433405, 0 )
+( 2.0,0):( 0.54930614433405, 1.57079632679490)
+
+&atanh
+( 2, 3):( 0.14694666622553, 1.33897252229449)
+(-2, 3):( -0.14694666622553, 1.33897252229449)
+(-2,-3):( -0.14694666622553, -1.33897252229449)
+( 2,-3):( 0.14694666622553, -1.33897252229449)
+
+&asech
+(-2.0,0):( 0 , 2.09439510239320)
+(-1.0,0):( 0 , 3.14159265358979)
+(-0.5,0):( -1.31695789692482, 3.14159265358979)
+( 0.5,0):( 1.31695789692482, 0 )
+( 1.0,0):( 0 , 0 )
+( 2.0,0):( 0 , 1.04719755119660)
+
+&asech
+( 2, 3):( 0.23133469857397, -1.42041072246703)
+(-2, 3):( -0.23133469857397, 1.72118193112276)
+(-2,-3):( -0.23133469857397, -1.72118193112276)
+( 2,-3):( 0.23133469857397, 1.42041072246703)
+
+&acsch
+(-2.0,0):( -0.48121182505960, 0 )
+(-1.0,0):( -0.88137358701954, 0 )
+(-0.5,0):( -1.44363547517881, 0 )
+( 0.5,0):( 1.44363547517881, 0 )
+( 1.0,0):( 0.88137358701954, 0 )
+( 2.0,0):( 0.48121182505960, 0 )
+
+&acsch
+( 2, 3):( 0.15735549884499, -0.22996290237721)
+(-2, 3):( -0.15735549884499, -0.22996290237721)
+(-2,-3):( -0.15735549884499, 0.22996290237721)
+( 2,-3):( 0.15735549884499, 0.22996290237721)
+
+&acoth
+(-2.0,0):( -0.54930614433405, 0 )
+(-0.5,0):( -0.54930614433405, 1.57079632679490)
+( 0.5,0):( 0.54930614433405, 1.57079632679490)
+( 2.0,0):( 0.54930614433405, 0 )
+
+&acoth
+( 2, 3):( 0.14694666622553, -0.23182380450040)
+(-2, 3):( -0.14694666622553, -0.23182380450040)
+(-2,-3):( -0.14694666622553, 0.23182380450040)
+( 2,-3):( 0.14694666622553, 0.23182380450040)
+
+# eof
+
diff --git a/contrib/perl5/t/lib/db-btree.t b/contrib/perl5/t/lib/db-btree.t
new file mode 100755
index 000000000000..bf739c81d5c6
--- /dev/null
+++ b/contrib/perl5/t/lib/db-btree.t
@@ -0,0 +1,612 @@
+#!./perl -w
+
+BEGIN {
+ @INC = '../lib' if -d '../lib' ;
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDB_File\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use DB_File;
+use Fcntl;
+
+print "1..102\n";
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+sub lexical
+{
+ my(@a) = unpack ("C*", $a) ;
+ my(@b) = unpack ("C*", $b) ;
+
+ my $len = (@a > @b ? @b : @a) ;
+ my $i = 0 ;
+
+ foreach $i ( 0 .. $len -1) {
+ return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
+ }
+
+ return @a - @b ;
+}
+
+$Dfile = "dbbtree.tmp";
+unlink $Dfile;
+
+umask(0);
+
+# Check the interface to BTREEINFO
+
+my $dbh = new DB_File::BTREEINFO ;
+ok(1, ! defined $dbh->{flags}) ;
+ok(2, ! defined $dbh->{cachesize}) ;
+ok(3, ! defined $dbh->{psize}) ;
+ok(4, ! defined $dbh->{lorder}) ;
+ok(5, ! defined $dbh->{minkeypage}) ;
+ok(6, ! defined $dbh->{maxkeypage}) ;
+ok(7, ! defined $dbh->{compare}) ;
+ok(8, ! defined $dbh->{prefix}) ;
+
+$dbh->{flags} = 3000 ;
+ok(9, $dbh->{flags} == 3000) ;
+
+$dbh->{cachesize} = 9000 ;
+ok(10, $dbh->{cachesize} == 9000);
+
+$dbh->{psize} = 400 ;
+ok(11, $dbh->{psize} == 400) ;
+
+$dbh->{lorder} = 65 ;
+ok(12, $dbh->{lorder} == 65) ;
+
+$dbh->{minkeypage} = 123 ;
+ok(13, $dbh->{minkeypage} == 123) ;
+
+$dbh->{maxkeypage} = 1234 ;
+ok(14, $dbh->{maxkeypage} == 1234 );
+
+$dbh->{compare} = 1234 ;
+ok(15, $dbh->{compare} == 1234) ;
+
+$dbh->{prefix} = 1234 ;
+ok(16, $dbh->{prefix} == 1234 );
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
+eval '$q = $dbh->{fred}' ;
+ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
+
+# Now check the interface to BTREE
+
+ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
+
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(21, !$i ) ;
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+ok(22, $h{'abc'} eq 'ABC' );
+ok(23, ! defined $h{'jimmy'} ) ;
+ok(24, ! exists $h{'jimmy'} ) ;
+ok(25, defined $h{'abc'} ) ;
+
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+
+#$h{'b'} = 'B';
+$X->STORE('b', 'B') ;
+
+$h{'c'} = 'C';
+
+#$h{'d'} = 'D';
+$X->put('d', 'D') ;
+
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'X';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+
+# IMPORTANT - $X must be undefined before the untie otherwise the
+# underlying DB close routine will not get called.
+undef $X ;
+untie(%h);
+
+
+# tie to the same file again
+ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ;
+
+# Modify an entry from the previous tie
+$h{'g'} = 'G';
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+$X->DELETE('goner3');
+
+@keys = keys(%h);
+@values = values(%h);
+
+ok(27, $#keys == 29 && $#values == 29) ;
+
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+ok(28, $i == 30) ;
+
+@keys = ('blurfl', keys(%h), 'dyick');
+ok(29, $#keys == 31) ;
+
+#Check that the keys can be retrieved in order
+my @b = keys %h ;
+my @c = sort lexical @b ;
+ok(30, ArrayCompare(\@b, \@c)) ;
+
+$h{'foo'} = '';
+ok(31, $h{'foo'} eq '' ) ;
+
+#$h{''} = 'bar';
+#ok(32, $h{''} eq 'bar' );
+ok(32,1) ;
+
+# check cache overflow and numeric keys and contents
+$ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ok(33, $ok);
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ok(34, $size > 0 );
+
+@h{0..200} = 200..400;
+@foo = @h{0..200};
+ok(35, join(':',200..400) eq join(':',@foo) );
+
+# Now check all the non-tie specific stuff
+
+
+# Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
+# an existing record.
+
+$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+ok(36, $status == 1 );
+
+# check that the value of the key 'x' has not been changed by the
+# previous test
+ok(37, $h{'x'} eq 'X' );
+
+# standard put
+$status = $X->put('key', 'value') ;
+ok(38, $status == 0 );
+
+#check that previous put can be retrieved
+$value = 0 ;
+$status = $X->get('key', $value) ;
+ok(39, $status == 0 );
+ok(40, $value eq 'value' );
+
+# Attempting to delete an existing key should work
+
+$status = $X->del('q') ;
+ok(41, $status == 0 );
+#$status = $X->del('') ;
+#ok(42, $status == 0 );
+ok(42,1) ;
+
+# Make sure that the key deleted, cannot be retrieved
+ok(43, ! defined $h{'q'}) ;
+ok(44, ! defined $h{''}) ;
+
+undef $X ;
+untie %h ;
+
+ok(45, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE ));
+
+# Attempting to delete a non-existant key should fail
+
+$status = $X->del('joe') ;
+ok(46, $status == 1 );
+
+# Check the get interface
+
+# First a non-existing key
+$status = $X->get('aaaa', $value) ;
+ok(47, $status == 1 );
+
+# Next an existing key
+$status = $X->get('a', $value) ;
+ok(48, $status == 0 );
+ok(49, $value eq 'A' );
+
+# seq
+# ###
+
+# use seq to find an approximate match
+$key = 'ke' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(50, $status == 0 );
+ok(51, $key eq 'key' );
+ok(52, $value eq 'value' );
+
+# seq when the key does not match
+$key = 'zzz' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(53, $status == 1 );
+
+
+# use seq to set the cursor, then delete the record @ the cursor.
+
+$key = 'x' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(54, $status == 0 );
+ok(55, $key eq 'x' );
+ok(56, $value eq 'X' );
+$status = $X->del(0, R_CURSOR) ;
+ok(57, $status == 0 );
+$status = $X->get('x', $value) ;
+ok(58, $status == 1 );
+
+# ditto, but use put to replace the key/value pair.
+$key = 'y' ;
+$value = '' ;
+$status = $X->seq($key, $value, R_CURSOR) ;
+ok(59, $status == 0 );
+ok(60, $key eq 'y' );
+ok(61, $value eq 'Y' );
+
+$key = "replace key" ;
+$value = "replace value" ;
+$status = $X->put($key, $value, R_CURSOR) ;
+ok(62, $status == 0 );
+ok(63, $key eq 'replace key' );
+ok(64, $value eq 'replace value' );
+$status = $X->get('y', $value) ;
+ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1)
+ # only worked because of a bug in 1.85/6
+
+# use seq to walk forwards through a file
+
+$status = $X->seq($key, $value, R_FIRST) ;
+ok(66, $status == 0 );
+$previous = $key ;
+
+$ok = 1 ;
+while (($status = $X->seq($key, $value, R_NEXT)) == 0)
+{
+ ($ok = 0), last if ($previous cmp $key) == 1 ;
+}
+
+ok(67, $status == 1 );
+ok(68, $ok == 1 );
+
+# use seq to walk backwards through a file
+$status = $X->seq($key, $value, R_LAST) ;
+ok(69, $status == 0 );
+$previous = $key ;
+
+$ok = 1 ;
+while (($status = $X->seq($key, $value, R_PREV)) == 0)
+{
+ ($ok = 0), last if ($previous cmp $key) == -1 ;
+ #print "key = [$key] value = [$value]\n" ;
+}
+
+ok(70, $status == 1 );
+ok(71, $ok == 1 );
+
+
+# check seq FIRST/LAST
+
+# sync
+# ####
+
+$status = $X->sync ;
+ok(72, $status == 0 );
+
+
+# fd
+# ##
+
+$status = $X->fd ;
+ok(73, $status != 0 );
+
+
+undef $X ;
+untie %h ;
+
+unlink $Dfile;
+
+# Now try an in memory file
+ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
+
+# fd with an in memory file should return failure
+$status = $Y->fd ;
+ok(75, $status == -1 );
+
+
+undef $Y ;
+untie %h ;
+
+# Duplicate keys
+my $bt = new DB_File::BTREEINFO ;
+$bt->{flags} = R_DUP ;
+ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;
+
+$hh{'Wall'} = 'Larry' ;
+$hh{'Wall'} = 'Stone' ; # Note the duplicate key
+$hh{'Wall'} = 'Brick' ; # Note the duplicate key
+$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value
+$hh{'Smith'} = 'John' ;
+$hh{'mouse'} = 'mickey' ;
+
+# first work in scalar context
+ok(77, scalar $YY->get_dup('Unknown') == 0 );
+ok(78, scalar $YY->get_dup('Smith') == 1 );
+ok(79, scalar $YY->get_dup('Wall') == 4 );
+
+# now in list context
+my @unknown = $YY->get_dup('Unknown') ;
+ok(80, "@unknown" eq "" );
+
+my @smith = $YY->get_dup('Smith') ;
+ok(81, "@smith" eq "John" );
+
+{
+my @wall = $YY->get_dup('Wall') ;
+my %wall ;
+@wall{@wall} = @wall ;
+ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) );
+}
+
+# hash
+my %unknown = $YY->get_dup('Unknown', 1) ;
+ok(83, keys %unknown == 0 );
+
+my %smith = $YY->get_dup('Smith', 1) ;
+ok(84, keys %smith == 1 && $smith{'John'}) ;
+
+my %wall = $YY->get_dup('Wall', 1) ;
+ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
+ && $wall{'Brick'} == 2);
+
+undef $YY ;
+untie %hh ;
+unlink $Dfile;
+
+
+# test multiple callbacks
+$Dfile1 = "btree1" ;
+$Dfile2 = "btree2" ;
+$Dfile3 = "btree3" ;
+
+$dbh1 = new DB_File::BTREEINFO ;
+{ local $^W = 0 ;
+ $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; }
+
+$dbh2 = new DB_File::BTREEINFO ;
+$dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
+
+$dbh3 = new DB_File::BTREEINFO ;
+$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
+
+
+tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
+tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
+tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
+
+@Keys = qw( 0123 12 -1234 9 987654321 def ) ;
+{ local $^W = 0 ;
+ @srt_1 = sort { $a <=> $b } @Keys ; }
+@srt_2 = sort { $a cmp $b } @Keys ;
+@srt_3 = sort { length $a <=> length $b } @Keys ;
+
+foreach (@Keys) {
+ { local $^W = 0 ;
+ $h{$_} = 1 ; }
+ $g{$_} = 1 ;
+ $k{$_} = 1 ;
+}
+
+sub ArrayCompare
+{
+ my($a, $b) = @_ ;
+
+ return 0 if @$a != @$b ;
+
+ foreach (1 .. length @$a)
+ {
+ return 0 unless $$a[$_] eq $$b[$_] ;
+ }
+
+ 1 ;
+}
+
+ok(86, ArrayCompare (\@srt_1, [keys %h]) );
+ok(87, ArrayCompare (\@srt_2, [keys %g]) );
+ok(88, ArrayCompare (\@srt_3, [keys %k]) );
+
+untie %h ;
+untie %g ;
+untie %k ;
+unlink $Dfile1, $Dfile2, $Dfile3 ;
+
+# clear
+# #####
+
+ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
+foreach (1 .. 10)
+ { $h{$_} = $_ * 100 }
+
+# check that there are 10 elements in the hash
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(90, $i == 10);
+
+# now clear the hash
+%h = () ;
+
+# check it is empty
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(91, $i == 0);
+
+untie %h ;
+unlink $Dfile1 ;
+
+{
+ # check that attempting to tie an array to a DB_BTREE will fail
+
+ my $filename = "xyz" ;
+ my @x ;
+ eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ;
+ ok(92, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ;
+ unlink $filename ;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use DB_File;
+ @ISA=qw(DB_File);
+ @EXPORT = @DB_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::put($key, $value * 3) ;
+ }
+
+ sub get {
+ my $self = shift ;
+ $self->SUPER::get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok(93, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
+ ' ;
+
+ main::ok(94, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(95, $@ eq "") ;
+ main::ok(96, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
+ main::ok(97, $@ eq "") ;
+ main::ok(98, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(99, $@ eq "" ) ;
+ main::ok(100, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ main::ok(101, $@ eq "") ;
+ main::ok(102, $ret eq "[[11]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", "dbbtree.tmp" ;
+
+}
+
+exit ;
diff --git a/contrib/perl5/t/lib/db-hash.t b/contrib/perl5/t/lib/db-hash.t
new file mode 100755
index 000000000000..e74847226314
--- /dev/null
+++ b/contrib/perl5/t/lib/db-hash.t
@@ -0,0 +1,416 @@
+#!./perl -w
+
+BEGIN {
+ @INC = '../lib' if -d '../lib' ;
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDB_File\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use DB_File;
+use Fcntl;
+
+print "1..62\n";
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+$Dfile = "dbhash.tmp";
+unlink $Dfile;
+
+umask(0);
+
+# Check the interface to HASHINFO
+
+my $dbh = new DB_File::HASHINFO ;
+
+ok(1, ! defined $dbh->{bsize}) ;
+ok(2, ! defined $dbh->{ffactor}) ;
+ok(3, ! defined $dbh->{nelem}) ;
+ok(4, ! defined $dbh->{cachesize}) ;
+ok(5, ! defined $dbh->{hash}) ;
+ok(6, ! defined $dbh->{lorder}) ;
+
+$dbh->{bsize} = 3000 ;
+ok(7, $dbh->{bsize} == 3000 );
+
+$dbh->{ffactor} = 9000 ;
+ok(8, $dbh->{ffactor} == 9000 );
+
+$dbh->{nelem} = 400 ;
+ok(9, $dbh->{nelem} == 400 );
+
+$dbh->{cachesize} = 65 ;
+ok(10, $dbh->{cachesize} == 65 );
+
+$dbh->{hash} = "abc" ;
+ok(11, $dbh->{hash} eq "abc" );
+
+$dbh->{lorder} = 1234 ;
+ok(12, $dbh->{lorder} == 1234 );
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
+eval 'my $q = $dbh->{fred}' ;
+ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
+
+
+# Now check the interface to HASH
+
+ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
+
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(17, !$i );
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+ok(18, $h{'abc'} eq 'ABC' );
+ok(19, !defined $h{'jimmy'} );
+ok(20, !exists $h{'jimmy'} );
+ok(21, exists $h{'abc'} );
+
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+
+#$h{'b'} = 'B';
+$X->STORE('b', 'B') ;
+
+$h{'c'} = 'C';
+
+#$h{'d'} = 'D';
+$X->put('d', 'D') ;
+
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'X';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+
+# IMPORTANT - $X must be undefined before the untie otherwise the
+# underlying DB close routine will not get called.
+undef $X ;
+untie(%h);
+
+
+# tie to the same file again, do not supply a type - should default to HASH
+ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
+
+# Modify an entry from the previous tie
+$h{'g'} = 'G';
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+$X->DELETE('goner3');
+
+@keys = keys(%h);
+@values = values(%h);
+
+ok(23, $#keys == 29 && $#values == 29) ;
+
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+ok(24, $i == 30) ;
+
+@keys = ('blurfl', keys(%h), 'dyick');
+ok(25, $#keys == 31) ;
+
+$h{'foo'} = '';
+ok(26, $h{'foo'} eq '' );
+
+#$h{''} = 'bar';
+#ok(27, $h{''} eq 'bar' );
+ok(27,1) ;
+
+# check cache overflow and numeric keys and contents
+$ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+ok(28, $ok );
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ok(29, $size > 0 );
+
+@h{0..200} = 200..400;
+@foo = @h{0..200};
+ok(30, join(':',200..400) eq join(':',@foo) );
+
+
+# Now check all the non-tie specific stuff
+
+# Check NOOVERWRITE will make put fail when attempting to overwrite
+# an existing record.
+
+$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
+ok(31, $status == 1 );
+
+# check that the value of the key 'x' has not been changed by the
+# previous test
+ok(32, $h{'x'} eq 'X' );
+
+# standard put
+$status = $X->put('key', 'value') ;
+ok(33, $status == 0 );
+
+#check that previous put can be retrieved
+$value = 0 ;
+$status = $X->get('key', $value) ;
+ok(34, $status == 0 );
+ok(35, $value eq 'value' );
+
+# Attempting to delete an existing key should work
+
+$status = $X->del('q') ;
+ok(36, $status == 0 );
+
+# Make sure that the key deleted, cannot be retrieved
+$^W = 0 ;
+ok(37, $h{'q'} eq undef );
+$^W = 1 ;
+
+# Attempting to delete a non-existant key should fail
+
+$status = $X->del('joe') ;
+ok(38, $status == 1 );
+
+# Check the get interface
+
+# First a non-existing key
+$status = $X->get('aaaa', $value) ;
+ok(39, $status == 1 );
+
+# Next an existing key
+$status = $X->get('a', $value) ;
+ok(40, $status == 0 );
+ok(41, $value eq 'A' );
+
+# seq
+# ###
+
+# ditto, but use put to replace the key/value pair.
+
+# use seq to walk backwards through a file - check that this reversed is
+
+# check seq FIRST/LAST
+
+# sync
+# ####
+
+$status = $X->sync ;
+ok(42, $status == 0 );
+
+
+# fd
+# ##
+
+$status = $X->fd ;
+ok(43, $status != 0 );
+
+undef $X ;
+untie %h ;
+
+unlink $Dfile;
+
+# clear
+# #####
+
+ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+foreach (1 .. 10)
+ { $h{$_} = $_ * 100 }
+
+# check that there are 10 elements in the hash
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(45, $i == 10);
+
+# now clear the hash
+%h = () ;
+
+# check it is empty
+$i = 0 ;
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+ok(46, $i == 0);
+
+untie %h ;
+unlink $Dfile ;
+
+
+# Now try an in memory file
+ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
+
+# fd with an in memory file should return fail
+$status = $X->fd ;
+ok(48, $status == -1 );
+
+undef $X ;
+untie %h ;
+
+{
+ # check ability to override the default hashing
+ my %x ;
+ my $filename = "xyz" ;
+ my $hi = new DB_File::HASHINFO ;
+ $::count = 0 ;
+ $hi->{hash} = sub { ++$::count ; length $_[0] } ;
+ ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
+ $h{"abc"} = 123 ;
+ ok(50, $h{"abc"} == 123) ;
+ untie %x ;
+ unlink $filename ;
+ ok(51, $::count >0) ;
+}
+
+{
+ # check that attempting to tie an array to a DB_HASH will fail
+
+ my $filename = "xyz" ;
+ my @x ;
+ eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
+ ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
+ unlink $filename ;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use DB_File;
+ @ISA=qw(DB_File);
+ @EXPORT = @DB_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::put($key, $value * 3) ;
+ }
+
+ sub get {
+ my $self = shift ;
+ $self->SUPER::get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok(53, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
+ ' ;
+
+ main::ok(54, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(55, $@ eq "") ;
+ main::ok(56, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
+ main::ok(57, $@ eq "") ;
+ main::ok(58, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(59, $@ eq "" ) ;
+ main::ok(60, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method("joe") ' ;
+ main::ok(61, $@ eq "") ;
+ main::ok(62, $ret eq "[[11]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", "dbhash.tmp" ;
+
+}
+exit ;
diff --git a/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t
new file mode 100755
index 000000000000..c89c3cafdee7
--- /dev/null
+++ b/contrib/perl5/t/lib/db-recno.t
@@ -0,0 +1,453 @@
+#!./perl -w
+
+BEGIN {
+ @INC = '../lib' if -d '../lib' ;
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bDB_File\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use DB_File;
+use Fcntl;
+use strict ;
+use vars qw($dbh $Dfile $bad_ones $FA) ;
+
+# full tied array support started in Perl 5.004_57
+# Double check to see if it is available.
+
+{
+ sub try::TIEARRAY { bless [], "try" }
+ sub try::FETCHSIZE { $FA = 1 }
+ $FA = 0 ;
+ my @a ;
+ tie @a, 'try' ;
+ my $a = @a ;
+}
+
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+
+ return $result ;
+}
+
+sub bad_one
+{
+ print STDERR <<EOM unless $bad_ones++ ;
+#
+# Some older versions of Berkeley DB will fail tests 51, 53 and 55.
+#
+# You can safely ignore the errors if you're never going to use the
+# broken functionality (recno databases with a modified bval).
+# Otherwise you'll have to upgrade your DB library.
+#
+# If you want to upgrade Berkeley DB, the most recent version is 1.85.
+# Check out http://www.bostic.com/db for more details.
+#
+EOM
+}
+
+print "1..78\n";
+
+my $Dfile = "recno.tmp";
+unlink $Dfile ;
+
+umask(0);
+
+# Check the interface to RECNOINFO
+
+my $dbh = new DB_File::RECNOINFO ;
+ok(1, ! defined $dbh->{bval}) ;
+ok(2, ! defined $dbh->{cachesize}) ;
+ok(3, ! defined $dbh->{psize}) ;
+ok(4, ! defined $dbh->{flags}) ;
+ok(5, ! defined $dbh->{lorder}) ;
+ok(6, ! defined $dbh->{reclen}) ;
+ok(7, ! defined $dbh->{bfname}) ;
+
+$dbh->{bval} = 3000 ;
+ok(8, $dbh->{bval} == 3000 );
+
+$dbh->{cachesize} = 9000 ;
+ok(9, $dbh->{cachesize} == 9000 );
+
+$dbh->{psize} = 400 ;
+ok(10, $dbh->{psize} == 400 );
+
+$dbh->{flags} = 65 ;
+ok(11, $dbh->{flags} == 65 );
+
+$dbh->{lorder} = 123 ;
+ok(12, $dbh->{lorder} == 123 );
+
+$dbh->{reclen} = 1234 ;
+ok(13, $dbh->{reclen} == 1234 );
+
+$dbh->{bfname} = 1234 ;
+ok(14, $dbh->{bfname} == 1234 );
+
+
+# Check that an invalid entry is caught both for store & fetch
+eval '$dbh->{fred} = 1234' ;
+ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ );
+eval 'my $q = $dbh->{fred}' ;
+ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ );
+
+# Now check the interface to RECNOINFO
+
+my $X ;
+my @h ;
+ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+
+ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640)
+ || $^O eq 'MSWin32' || $^O eq 'amigaos') ;
+
+#my $l = @h ;
+my $l = $X->length ;
+ok(19, ($FA ? @h == 0 : !$l) );
+
+my @data = qw( a b c d ever f g h i j k longername m n o p) ;
+
+$h[0] = shift @data ;
+ok(20, $h[0] eq 'a' );
+
+my $ i;
+foreach (@data)
+ { $h[++$i] = $_ }
+
+unshift (@data, 'a') ;
+
+ok(21, defined $h[1] );
+ok(22, ! defined $h[16] );
+ok(23, $FA ? @h == @data : $X->length == @data );
+
+
+# Overwrite an entry & check fetch it
+$h[3] = 'replaced' ;
+$data[3] = 'replaced' ;
+ok(24, $h[3] eq 'replaced' );
+
+#PUSH
+my @push_data = qw(added to the end) ;
+($FA ? push(@h, @push_data) : $X->push(@push_data)) ;
+push (@data, @push_data) ;
+ok(25, $h[++$i] eq 'added' );
+ok(26, $h[++$i] eq 'to' );
+ok(27, $h[++$i] eq 'the' );
+ok(28, $h[++$i] eq 'end' );
+
+# POP
+my $popped = pop (@data) ;
+my $value = ($FA ? pop @h : $X->pop) ;
+ok(29, $value eq $popped) ;
+
+# SHIFT
+$value = ($FA ? shift @h : $X->shift) ;
+my $shifted = shift @data ;
+ok(30, $value eq $shifted );
+
+# UNSHIFT
+
+# empty list
+($FA ? unshift @h : $X->unshift) ;
+ok(31, ($FA ? @h == @data : $X->length == @data ));
+
+my @new_data = qw(add this to the start of the array) ;
+$FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ;
+unshift (@data, @new_data) ;
+ok(32, $FA ? @h == @data : $X->length == @data );
+ok(33, $h[0] eq "add") ;
+ok(34, $h[1] eq "this") ;
+ok(35, $h[2] eq "to") ;
+ok(36, $h[3] eq "the") ;
+ok(37, $h[4] eq "start") ;
+ok(38, $h[5] eq "of") ;
+ok(39, $h[6] eq "the") ;
+ok(40, $h[7] eq "array") ;
+ok(41, $h[8] eq $data[8]) ;
+
+# SPLICE
+
+# Now both arrays should be identical
+
+my $ok = 1 ;
+my $j = 0 ;
+foreach (@data)
+{
+ $ok = 0, last if $_ ne $h[$j ++] ;
+}
+ok(42, $ok );
+
+# Neagtive subscripts
+
+# get the last element of the array
+ok(43, $h[-1] eq $data[-1] );
+ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] );
+
+# get the first element using a negative subscript
+eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ;
+ok(45, $@ eq "" );
+ok(46, $h[0] eq "abcd" );
+
+# now try to read before the start of the array
+eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ;
+ok(47, $@ =~ '^Modification of non-creatable array value attempted' );
+
+# IMPORTANT - $X must be undefined before the untie otherwise the
+# underlying DB close routine will not get called.
+undef $X ;
+untie(@h);
+
+unlink $Dfile;
+
+sub docat
+{
+ my $file = shift;
+ local $/ = undef;
+ open(CAT,$file) || die "Cannot open $file:$!";
+ my $result = <CAT>;
+ close(CAT);
+ return $result;
+}
+
+
+{
+ # Check bval defaults to \n
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ untie @h ;
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ ok(49, $x eq "abc\ndef\n\nghi\n") ;
+}
+
+{
+ # Change bval
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ $dbh->{bval} = "-" ;
+ ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ untie @h ;
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ my $ok = ($x eq "abc-def--ghi-") ;
+ bad_one() unless $ok ;
+ ok(51, $ok) ;
+}
+
+{
+ # Check R_FIXEDLEN with default bval (space)
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ $dbh->{flags} = R_FIXEDLEN ;
+ $dbh->{reclen} = 5 ;
+ ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ untie @h ;
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ my $ok = ($x eq "abc def ghi ") ;
+ bad_one() unless $ok ;
+ ok(53, $ok) ;
+}
+
+{
+ # Check R_FIXEDLEN with user-defined bval
+
+ my @h = () ;
+ my $dbh = new DB_File::RECNOINFO ;
+ $dbh->{flags} = R_FIXEDLEN ;
+ $dbh->{bval} = "-" ;
+ $dbh->{reclen} = 5 ;
+ ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[3] = "ghi" ;
+ untie @h ;
+ my $x = docat($Dfile) ;
+ unlink $Dfile;
+ my $ok = ($x eq "abc--def-------ghi--") ;
+ bad_one() unless $ok ;
+ ok(55, $ok) ;
+}
+
+{
+ # check that attempting to tie an associative array to a DB_RECNO will fail
+
+ my $filename = "xyz" ;
+ my %x ;
+ eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ;
+ ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ;
+ unlink $filename ;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use DB_File;
+ @ISA=qw(DB_File);
+ @EXPORT = @DB_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub put {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::put($key, $value * 3) ;
+ }
+
+ sub get {
+ my $self = shift ;
+ $self->SUPER::get($_[0], $_[1]) ;
+ $_[1] -= 2 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+ eval 'use SubDB ; ';
+ main::ok(57, $@ eq "") ;
+ my @h ;
+ my $X ;
+ eval '
+ $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
+ ' ;
+
+ main::ok(58, $@ eq "") ;
+
+ my $ret = eval '$h[3] = 3 ; return $h[3] ' ;
+ main::ok(59, $@ eq "") ;
+ main::ok(60, $ret == 5) ;
+
+ my $value = 0;
+ $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ;
+ main::ok(61, $@ eq "") ;
+ main::ok(62, $ret == 10) ;
+
+ $ret = eval ' R_NEXT eq main::R_NEXT ' ;
+ main::ok(63, $@ eq "" ) ;
+ main::ok(64, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method(1) ' ;
+ main::ok(65, $@ eq "") ;
+ main::ok(66, $ret eq "[[11]]") ;
+
+ undef $X;
+ untie(@h);
+ unlink "SubDB.pm", "recno.tmp" ;
+
+}
+
+{
+
+ # test $#
+ my $self ;
+ unlink $Dfile;
+ ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
+ $h[0] = "abc" ;
+ $h[1] = "def" ;
+ $h[2] = "ghi" ;
+ $h[3] = "jkl" ;
+ ok(68, $FA ? $#h == 3 : $self->length() == 4) ;
+ undef $self ;
+ untie @h ;
+ my $x = docat($Dfile) ;
+ ok(69, $x eq "abc\ndef\nghi\njkl\n") ;
+
+ # $# sets array to same length
+ ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+ if ($FA)
+ { $#h = 3 }
+ else
+ { $self->STORESIZE(4) }
+ ok(71, $FA ? $#h == 3 : $self->length() == 4) ;
+ undef $self ;
+ untie @h ;
+ $x = docat($Dfile) ;
+ ok(72, $x eq "abc\ndef\nghi\njkl\n") ;
+
+ # $# sets array to bigger
+ ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+ if ($FA)
+ { $#h = 6 }
+ else
+ { $self->STORESIZE(7) }
+ ok(74, $FA ? $#h == 6 : $self->length() == 7) ;
+ undef $self ;
+ untie @h ;
+ $x = docat($Dfile) ;
+ ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ;
+
+ # $# sets array smaller
+ ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ;
+ if ($FA)
+ { $#h = 2 }
+ else
+ { $self->STORESIZE(3) }
+ ok(77, $FA ? $#h == 2 : $self->length() == 3) ;
+ undef $self ;
+ untie @h ;
+ $x = docat($Dfile) ;
+ ok(78, $x eq "abc\ndef\nghi\n") ;
+
+ unlink $Dfile;
+
+
+}
+
+exit ;
diff --git a/contrib/perl5/t/lib/dirhand.t b/contrib/perl5/t/lib/dirhand.t
new file mode 100755
index 000000000000..aa7be356df3a
--- /dev/null
+++ b/contrib/perl5/t/lib/dirhand.t
@@ -0,0 +1,33 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (not $Config{'d_readdir'}) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use DirHandle;
+
+print "1..5\n";
+
+$dot = new DirHandle ".";
+print defined($dot) ? "ok" : "not ok", " 1\n";
+
+@a = sort <*>;
+do { $first = $dot->read } while defined($first) && $first =~ /^\./;
+print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n";
+
+@b = sort($first, (grep {/^[^.]/} $dot->read));
+print +(join("\0", @a) eq join("\0", @b)) ? "ok" : "not ok", " 3\n";
+
+$dot->rewind;
+@c = sort grep {/^[^.]/} $dot->read;
+print +(join("\0", @b) eq join("\0", @c)) ? "ok" : "not ok", " 4\n";
+
+$dot->close;
+$dot->rewind;
+print defined($dot->read) ? "not ok" : "ok", " 5\n";
diff --git a/contrib/perl5/t/lib/dosglob.t b/contrib/perl5/t/lib/dosglob.t
new file mode 100755
index 000000000000..577d4eac22b8
--- /dev/null
+++ b/contrib/perl5/t/lib/dosglob.t
@@ -0,0 +1,112 @@
+#!./perl
+
+#
+# test glob() in File::DosGlob
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..10\n";
+
+# override it in main::
+use File::DosGlob 'glob';
+
+# test if $_ takes as the default
+$_ = "lib/a*.t";
+my @r = glob;
+print "not " if $_ ne 'lib/a*.t';
+print "ok 1\n";
+# we should have at least abbrev.t, anydbm.t, autoloader.t
+print "# |@r|\nnot " if @r < 3;
+print "ok 2\n";
+
+# check if <*/*> works
+@r = <*/a*.t>;
+# atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
+print "not " if @r < 9;
+print "ok 3\n";
+my $r = scalar @r;
+
+# check if scalar context works
+@r = ();
+while (defined($_ = <*/a*.t>)) {
+ print "# $_\n";
+ push @r, $_;
+}
+print "not " if @r != $r;
+print "ok 4\n";
+
+# check if array context works
+@r = ();
+for (<*/a*.t>) {
+ print "# $_\n";
+ push @r, $_;
+}
+print "not " if @r != $r;
+print "ok 5\n";
+
+# test if implicit assign to $_ in while() works
+@r = ();
+while (<*/a*.t>) {
+ print "# $_\n";
+ push @r, $_;
+}
+print "not " if @r != $r;
+print "ok 6\n";
+
+# test if explicit glob() gets assign magic too
+my @s = ();
+while (glob '*/a*.t') {
+ print "# $_\n";
+ push @s, $_;
+}
+print "not " if "@r" ne "@s";
+print "ok 7\n";
+
+# how about in a different package, like?
+package Foo;
+use File::DosGlob 'glob';
+@s = ();
+while (glob '*/a*.t') {
+ print "# $_\n";
+ push @s, $_;
+}
+print "not " if "@r" ne "@s";
+print "ok 8\n";
+
+# test if different glob ops maintain independent contexts
+@s = ();
+while (<*/a*.t>) {
+ my $i = 0;
+ print "# $_ <";
+ push @s, $_;
+ while (<*/b*.t>) {
+ print " $_";
+ $i++;
+ }
+ print " >\n";
+}
+print "not " if "@r" ne "@s";
+print "ok 9\n";
+
+# how about a global override, hm?
+eval <<'EOT';
+use File::DosGlob 'GLOBAL_glob';
+package Bar;
+@s = ();
+while (<*/a*.t>) {
+ my $i = 0;
+ print "# $_ <";
+ push @s, $_;
+ while (glob '*/b*.t') {
+ print " $_";
+ $i++;
+ }
+ print " >\n";
+}
+print "not " if "@r" ne "@s";
+print "ok 10\n";
+EOT
diff --git a/contrib/perl5/t/lib/dumper-ovl.t b/contrib/perl5/t/lib/dumper-ovl.t
new file mode 100755
index 000000000000..db4a5d9e7525
--- /dev/null
+++ b/contrib/perl5/t/lib/dumper-ovl.t
@@ -0,0 +1,30 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+use Data::Dumper;
+
+print "1..1\n";
+
+package Foo;
+use overload '""' => 'as_string';
+
+sub new { bless { foo => "bar" }, shift }
+sub as_string { "%%%%" }
+
+package main;
+
+my $f = Foo->new;
+
+print "#\$f=$f\n";
+
+$_ = Dumper($f);
+s/^/#/mg;
+print $_;
+
+print "not " unless /bar/ && /Foo/;
+print "ok 1\n";
+
diff --git a/contrib/perl5/t/lib/dumper.t b/contrib/perl5/t/lib/dumper.t
new file mode 100755
index 000000000000..70f8abeb9e4e
--- /dev/null
+++ b/contrib/perl5/t/lib/dumper.t
@@ -0,0 +1,611 @@
+#!./perl -w
+#
+# testsuite for Data::Dumper
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+use Data::Dumper;
+
+$Data::Dumper::Pad = "#";
+my $TMAX;
+my $XS;
+my $TNUM = 0;
+my $WANT = '';
+
+sub TEST {
+ my $string = shift;
+ my $t = eval $string;
+ ++$TNUM;
+ print( ($t eq $WANT and not $@) ? "ok $TNUM\n"
+ : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n");
+
+ ++$TNUM;
+ eval "$t";
+ print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\n";
+
+ $t = eval $string;
+ ++$TNUM;
+ print( ($t eq $WANT and not $@) ? "ok $TNUM\n"
+ : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n");
+}
+
+if (defined &Data::Dumper::Dumpxs) {
+ print "### XS extension loaded, will run XS tests\n";
+ $TMAX = 138; $XS = 1;
+}
+else {
+ print "### XS extensions not loaded, will NOT run XS tests\n";
+ $TMAX = 69; $XS = 0;
+}
+
+print "1..$TMAX\n";
+
+#############
+#############
+
+@c = ('c');
+$c = \@c;
+$b = {};
+$a = [1, $b, $c];
+$b->{a} = $a;
+$b->{b} = $a->[1];
+$b->{c} = $a->[2];
+
+############# 1
+##
+$WANT = <<'EOT';
+#$a = [
+# 1,
+# {
+# 'a' => $a,
+# 'b' => $a->[1],
+# 'c' => [
+# 'c'
+# ]
+# },
+# $a->[1]{'c'}
+# ];
+#$b = $a->[1];
+#$c = $a->[1]{'c'};
+EOT
+
+TEST q(Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]));
+TEST q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b c)])) if $XS;
+
+
+############# 7
+##
+$WANT = <<'EOT';
+#@a = (
+# 1,
+# {
+# 'a' => [],
+# 'b' => {},
+# 'c' => [
+# 'c'
+# ]
+# },
+# []
+# );
+#$a[1]{'a'} = \@a;
+#$a[1]{'b'} = $a[1];
+#$a[2] = $a[1]{'c'};
+#$b = $a[1];
+EOT
+
+$Data::Dumper::Purity = 1; # fill in the holes for eval
+TEST q(Data::Dumper->Dump([$a, $b], [qw(*a b)])); # print as @a
+TEST q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])) if $XS;
+
+############# 13
+##
+$WANT = <<'EOT';
+#%b = (
+# 'a' => [
+# 1,
+# {},
+# [
+# 'c'
+# ]
+# ],
+# 'b' => {},
+# 'c' => []
+# );
+#$b{'a'}[1] = \%b;
+#$b{'b'} = \%b;
+#$b{'c'} = $b{'a'}[2];
+#$a = $b{'a'};
+EOT
+
+TEST q(Data::Dumper->Dump([$b, $a], [qw(*b a)])); # print as %b
+TEST q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])) if $XS;
+
+############# 19
+##
+$WANT = <<'EOT';
+#$a = [
+# 1,
+# {
+# 'a' => [],
+# 'b' => {},
+# 'c' => []
+# },
+# []
+#];
+#$a->[1]{'a'} = $a;
+#$a->[1]{'b'} = $a->[1];
+#$a->[1]{'c'} = \@c;
+#$a->[2] = \@c;
+#$b = $a->[1];
+EOT
+
+$Data::Dumper::Indent = 1;
+TEST q(
+ $d = Data::Dumper->new([$a,$b], [qw(a b)]);
+ $d->Seen({'*c' => $c});
+ $d->Dump;
+ );
+if ($XS) {
+ TEST q(
+ $d = Data::Dumper->new([$a,$b], [qw(a b)]);
+ $d->Seen({'*c' => $c});
+ $d->Dumpxs;
+ );
+}
+
+
+############# 25
+##
+$WANT = <<'EOT';
+#$a = [
+# #0
+# 1,
+# #1
+# {
+# a => $a,
+# b => $a->[1],
+# c => [
+# #0
+# 'c'
+# ]
+# },
+# #2
+# $a->[1]{c}
+# ];
+#$b = $a->[1];
+EOT
+
+$d->Indent(3);
+$d->Purity(0)->Quotekeys(0);
+TEST q( $d->Reset; $d->Dump );
+
+TEST q( $d->Reset; $d->Dumpxs ) if $XS;
+
+############# 31
+##
+$WANT = <<'EOT';
+#$VAR1 = [
+# 1,
+# {
+# 'a' => [],
+# 'b' => {},
+# 'c' => [
+# 'c'
+# ]
+# },
+# []
+#];
+#$VAR1->[1]{'a'} = $VAR1;
+#$VAR1->[1]{'b'} = $VAR1->[1];
+#$VAR1->[2] = $VAR1->[1]{'c'};
+EOT
+
+TEST q(Dumper($a));
+TEST q(Data::Dumper::DumperX($a)) if $XS;
+
+############# 37
+##
+$WANT = <<'EOT';
+#[
+# 1,
+# {
+# a => $VAR1,
+# b => $VAR1->[1],
+# c => [
+# 'c'
+# ]
+# },
+# $VAR1->[1]{c}
+#]
+EOT
+
+{
+ local $Data::Dumper::Purity = 0;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Terse = 1;
+ TEST q(Dumper($a));
+ TEST q(Data::Dumper::DumperX($a)) if $XS;
+}
+
+
+############# 43
+##
+$WANT = <<'EOT';
+#$VAR1 = {
+# "abc\000\efg" => "mno\000"
+#};
+EOT
+
+$foo = { "abc\000\efg" => "mno\000" };
+{
+ local $Data::Dumper::Useqq = 1;
+ TEST q(Dumper($foo));
+}
+
+ $WANT = <<"EOT";
+#\$VAR1 = {
+# 'abc\000\efg' => 'mno\000'
+#};
+EOT
+
+ {
+ local $Data::Dumper::Useqq = 1;
+ TEST q(Data::Dumper::DumperX($foo)) if $XS; # cheat
+ }
+
+
+
+#############
+#############
+
+{
+ package main;
+ use Data::Dumper;
+ $foo = 5;
+ @foo = (10,\*foo);
+ %foo = (a=>1,b=>\$foo,c=>\@foo);
+ $foo{d} = \%foo;
+ $foo[2] = \%foo;
+
+############# 49
+##
+ $WANT = <<'EOT';
+#$foo = \*::foo;
+#*::foo = \5;
+#*::foo = [
+# #0
+# 10,
+# #1
+# '',
+# #2
+# {
+# 'a' => 1,
+# 'b' => '',
+# 'c' => [],
+# 'd' => {}
+# }
+# ];
+#*::foo{ARRAY}->[1] = $foo;
+#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR};
+#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY};
+#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2];
+#*::foo = *::foo{ARRAY}->[2];
+#@bar = @{*::foo{ARRAY}};
+#%baz = %{*::foo{ARRAY}->[2]};
+EOT
+
+ $Data::Dumper::Purity = 1;
+ $Data::Dumper::Indent = 3;
+ TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz']));
+ TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS;
+
+############# 55
+##
+ $WANT = <<'EOT';
+#$foo = \*::foo;
+#*::foo = \5;
+#*::foo = [
+# 10,
+# '',
+# {
+# 'a' => 1,
+# 'b' => '',
+# 'c' => [],
+# 'd' => {}
+# }
+#];
+#*::foo{ARRAY}->[1] = $foo;
+#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR};
+#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY};
+#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2];
+#*::foo = *::foo{ARRAY}->[2];
+#$bar = *::foo{ARRAY};
+#$baz = *::foo{ARRAY}->[2];
+EOT
+
+ $Data::Dumper::Indent = 1;
+ TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz']));
+ TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS;
+
+############# 61
+##
+ $WANT = <<'EOT';
+#@bar = (
+# 10,
+# \*::foo,
+# {}
+#);
+#*::foo = \5;
+#*::foo = \@bar;
+#*::foo = {
+# 'a' => 1,
+# 'b' => '',
+# 'c' => [],
+# 'd' => {}
+#};
+#*::foo{HASH}->{'b'} = *::foo{SCALAR};
+#*::foo{HASH}->{'c'} = \@bar;
+#*::foo{HASH}->{'d'} = *::foo{HASH};
+#$bar[2] = *::foo{HASH};
+#%baz = %{*::foo{HASH}};
+#$foo = $bar[1];
+EOT
+
+ TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo']));
+ TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])) if $XS;
+
+############# 67
+##
+ $WANT = <<'EOT';
+#$bar = [
+# 10,
+# \*::foo,
+# {}
+#];
+#*::foo = \5;
+#*::foo = $bar;
+#*::foo = {
+# 'a' => 1,
+# 'b' => '',
+# 'c' => [],
+# 'd' => {}
+#};
+#*::foo{HASH}->{'b'} = *::foo{SCALAR};
+#*::foo{HASH}->{'c'} = $bar;
+#*::foo{HASH}->{'d'} = *::foo{HASH};
+#$bar->[2] = *::foo{HASH};
+#$baz = *::foo{HASH};
+#$foo = $bar->[1];
+EOT
+
+ TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo']));
+ TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])) if $XS;
+
+############# 73
+##
+ $WANT = <<'EOT';
+#$foo = \*::foo;
+#@bar = (
+# 10,
+# $foo,
+# {
+# a => 1,
+# b => \5,
+# c => \@bar,
+# d => $bar[2]
+# }
+#);
+#%baz = %{$bar[2]};
+EOT
+
+ $Data::Dumper::Purity = 0;
+ $Data::Dumper::Quotekeys = 0;
+ TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz']));
+ TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS;
+
+############# 79
+##
+ $WANT = <<'EOT';
+#$foo = \*::foo;
+#$bar = [
+# 10,
+# $foo,
+# {
+# a => 1,
+# b => \5,
+# c => $bar,
+# d => $bar->[2]
+# }
+#];
+#$baz = $bar->[2];
+EOT
+
+ TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz']));
+ TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS;
+
+}
+
+#############
+#############
+{
+ package main;
+ @dogs = ( 'Fido', 'Wags' );
+ %kennel = (
+ First => \$dogs[0],
+ Second => \$dogs[1],
+ );
+ $dogs[2] = \%kennel;
+ $mutts = \%kennel;
+ $mutts = $mutts; # avoid warning
+
+############# 85
+##
+ $WANT = <<'EOT';
+#%kennels = (
+# First => \'Fido',
+# Second => \'Wags'
+#);
+#@dogs = (
+# $kennels{First},
+# $kennels{Second},
+# \%kennels
+#);
+#%mutts = %kennels;
+EOT
+
+ TEST q(
+ $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts],
+ [qw(*kennels *dogs *mutts)] );
+ $d->Dump;
+ );
+ if ($XS) {
+ TEST q(
+ $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts],
+ [qw(*kennels *dogs *mutts)] );
+ $d->Dumpxs;
+ );
+ }
+
+############# 91
+##
+ $WANT = <<'EOT';
+#%kennels = %kennels;
+#@dogs = @dogs;
+#%mutts = %kennels;
+EOT
+
+ TEST q($d->Dump);
+ TEST q($d->Dumpxs) if $XS;
+
+############# 97
+##
+ $WANT = <<'EOT';
+#%kennels = (
+# First => \'Fido',
+# Second => \'Wags'
+#);
+#@dogs = (
+# $kennels{First},
+# $kennels{Second},
+# \%kennels
+#);
+#%mutts = %kennels;
+EOT
+
+
+ TEST q($d->Reset; $d->Dump);
+ if ($XS) {
+ TEST q($d->Reset; $d->Dumpxs);
+ }
+
+############# 103
+##
+ $WANT = <<'EOT';
+#@dogs = (
+# 'Fido',
+# 'Wags',
+# {
+# First => \$dogs[0],
+# Second => \$dogs[1]
+# }
+#);
+#%kennels = %{$dogs[2]};
+#%mutts = %{$dogs[2]};
+EOT
+
+ TEST q(
+ $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts],
+ [qw(*dogs *kennels *mutts)] );
+ $d->Dump;
+ );
+ if ($XS) {
+ TEST q(
+ $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts],
+ [qw(*dogs *kennels *mutts)] );
+ $d->Dumpxs;
+ );
+ }
+
+############# 109
+##
+ TEST q($d->Reset->Dump);
+ if ($XS) {
+ TEST q($d->Reset->Dumpxs);
+ }
+
+############# 115
+##
+ $WANT = <<'EOT';
+#@dogs = (
+# 'Fido',
+# 'Wags',
+# {
+# First => \'Fido',
+# Second => \'Wags'
+# }
+#);
+#%kennels = (
+# First => \'Fido',
+# Second => \'Wags'
+#);
+EOT
+
+ TEST q(
+ $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] );
+ $d->Deepcopy(1)->Dump;
+ );
+ if ($XS) {
+ TEST q($d->Reset->Dumpxs);
+ }
+
+}
+
+{
+
+sub a { print "foo\n" }
+$c = [ \&a ];
+
+############# 121
+##
+ $WANT = <<'EOT';
+#$a = $b;
+#$c = [
+# $b
+#];
+EOT
+
+TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dump;);
+TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dumpxs;)
+ if $XS;
+
+############# 127
+##
+ $WANT = <<'EOT';
+#$a = \&b;
+#$c = [
+# \&b
+#];
+EOT
+
+TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dump;);
+TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dumpxs;)
+ if $XS;
+
+############# 133
+##
+ $WANT = <<'EOT';
+#*a = \&b;
+#@c = (
+# \&b
+#);
+EOT
+
+TEST q(Data::Dumper->new([\&a,$c],['*a','*c'])->Seen({'*b' => \&a})->Dump;);
+TEST q(Data::Dumper->new([\&a,$c],['*a','*c'])->Seen({'*b' => \&a})->Dumpxs;)
+ if $XS;
+
+}
diff --git a/contrib/perl5/t/lib/english.t b/contrib/perl5/t/lib/english.t
new file mode 100755
index 000000000000..9691229be072
--- /dev/null
+++ b/contrib/perl5/t/lib/english.t
@@ -0,0 +1,47 @@
+#!./perl
+
+print "1..16\n";
+
+BEGIN { @INC = '../lib' }
+use English;
+use Config;
+my $threads = $Config{'usethreads'} || 0;
+
+print $PID == $$ ? "ok 1\n" : "not ok 1\n";
+
+$_ = 1;
+print $ARG == $_ || $threads ? "ok 2\n" : "not ok 2\n";
+
+sub foo {
+ print $ARG[0] == $_[0] || $threads ? "ok 3\n" : "not ok 3\n";
+}
+&foo(1);
+
+if ($threads) {
+ $_ = "ok 4\nok 5\nok 6\n";
+} else {
+ $ARG = "ok 4\nok 5\nok 6\n";
+}
+/ok 5\n/;
+print $PREMATCH, $MATCH, $POSTMATCH;
+
+$OFS = " ";
+$ORS = "\n";
+print 'ok',7;
+undef $OUTPUT_FIELD_SEPARATOR;
+
+if ($threads) { $" = "\n" } else { $LIST_SEPARATOR = "\n" };
+@foo = ("ok 8", "ok 9");
+print "@foo";
+undef $OUTPUT_RECORD_SEPARATOR;
+
+eval 'NO SUCH FUNCTION';
+print "ok 10\n" if $EVAL_ERROR =~ /method/ || $threads;
+
+print $UID == $< ? "ok 11\n" : "not ok 11\n";
+print $GID == $( ? "ok 12\n" : "not ok 12\n";
+print $EUID == $> ? "ok 13\n" : "not ok 13\n";
+print $EGID == $) ? "ok 14\n" : "not ok 14\n";
+
+print $PROGRAM_NAME == $0 ? "ok 15\n" : "not ok 15\n";
+print $BASETIME == $^T ? "ok 16\n" : "not ok 16\n";
diff --git a/contrib/perl5/t/lib/env.t b/contrib/perl5/t/lib/env.t
new file mode 100755
index 000000000000..5a8220778aa5
--- /dev/null
+++ b/contrib/perl5/t/lib/env.t
@@ -0,0 +1,18 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+BEGIN {
+ $ENV{FOO} = "foo";
+}
+
+use Env qw(FOO);
+
+$FOO .= "/bar";
+
+print "1..1\n";
+print "not " if $FOO ne 'foo/bar';
+print "ok 1\n";
diff --git a/contrib/perl5/t/lib/errno.t b/contrib/perl5/t/lib/errno.t
new file mode 100755
index 000000000000..361723f1b22c
--- /dev/null
+++ b/contrib/perl5/t/lib/errno.t
@@ -0,0 +1,50 @@
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Errno;
+
+print "1..5\n";
+
+print "not " unless @Errno::EXPORT_OK;
+print "ok 1\n";
+die unless @Errno::EXPORT_OK;
+
+$err = $Errno::EXPORT_OK[0];
+$num = &{"Errno::$err"};
+
+print "not " unless &{"Errno::$err"} == $num;
+print "ok 2\n";
+
+$! = $num;
+print "not " unless $!{$err};
+print "ok 3\n";
+
+$! = 0;
+print "not " if $!{$err};
+print "ok 4\n";
+
+$s1 = join(",",sort keys(%!));
+$s2 = join(",",sort @Errno::EXPORT_OK);
+
+if($s1 ne $s2) {
+ my @s1 = keys(%!);
+ my @s2 = @Errno::EXPORT_OK;
+ my(%s1,%s2);
+ @s1{@s1} = ();
+ @s2{@s2} = ();
+ delete @s2{@s1};
+ delete @s1{@s2};
+ print "# These are only in \%!\n";
+ print "# ",join(" ",map { "'$_'" } keys %s1),"\n";
+ print "# These are only in \@EXPORT_OK\n";
+ print "# ",join(" ",map { "'$_'" } keys %s2),"\n";
+ print "not ";
+}
+
+print "ok 5\n";
diff --git a/contrib/perl5/t/lib/fields.t b/contrib/perl5/t/lib/fields.t
new file mode 100755
index 000000000000..139e469b5a27
--- /dev/null
+++ b/contrib/perl5/t/lib/fields.t
@@ -0,0 +1,112 @@
+#!./perl -w
+
+my $w;
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ $SIG{__WARN__} = sub {
+ if ($_[0] =~ /^Hides field 'b1' in base class/) {
+ $w++;
+ return;
+ }
+ print $_[0];
+ };
+}
+
+use strict;
+use vars qw($DEBUG);
+
+package B1;
+use fields qw(b1 b2 b3);
+
+package B2;
+use fields '_b1';
+use fields qw(b1 _b2 b2);
+
+sub new { bless [], shift }
+
+package D1;
+use base 'B1';
+use fields qw(d1 d2 d3);
+
+package D2;
+use base 'B1';
+use fields qw(_d1 _d2);
+use fields qw(d1 d2);
+
+package D3;
+use base 'B2';
+use fields qw(b1 d1 _b1 _d1); # hide b1
+
+package D4;
+use base 'D3';
+use fields qw(_d3 d3);
+
+package M;
+sub m {}
+
+package D5;
+use base qw(M B2);
+
+package Foo::Bar;
+use base 'B1';
+
+package Foo::Bar::Baz;
+use base 'Foo::Bar';
+use fields qw(foo bar baz);
+
+package main;
+
+sub fstr
+{
+ my $h = shift;
+ my @tmp;
+ for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) {
+ my $v = $h->{$k};
+ push(@tmp, "$k:$v");
+ }
+ my $str = join(",", @tmp);
+ print "$h => $str\n" if $DEBUG;
+ $str;
+}
+
+my %expect = (
+ B1 => "b1:1,b2:2,b3:3",
+ B2 => "_b1:1,b1:2,_b2:3,b2:4",
+ D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6",
+ D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7",
+ D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8",
+ D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10",
+ D5 => "b1:2,b2:4",
+ 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6',
+);
+
+print "1..", int(keys %expect)+3, "\n";
+my $testno = 0;
+while (my($class, $exp) = each %expect) {
+ no strict 'refs';
+ my $fstr = fstr(\%{$class."::FIELDS"});
+ print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp;
+ print "ok ", ++$testno, "\n";
+}
+
+# Did we get the appropriate amount of warnings?
+print "not " unless $w == 1;
+print "ok ", ++$testno, "\n";
+
+# A simple object creation and AVHV attribute access test
+my B2 $obj1 = D3->new;
+$obj1->{b1} = "B2";
+my D3 $obj2 = $obj1;
+$obj2->{b1} = "D3";
+
+print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3";
+print "ok ", ++$testno, "\n";
+
+# We should get compile time failures field name typos
+eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
+print "not " unless $@ && $@ =~ /^No such field "notthere"/;
+print "ok ", ++$testno, "\n";
+
+#fields::_dump();
diff --git a/contrib/perl5/t/lib/filecache.t b/contrib/perl5/t/lib/filecache.t
new file mode 100755
index 000000000000..a97fdd532c6c
--- /dev/null
+++ b/contrib/perl5/t/lib/filecache.t
@@ -0,0 +1,25 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..1\n";
+
+use FileCache;
+
+# This is really not a complete test as I don't bother to open enough
+# files to make real swapping of open filedescriptor happen.
+
+$path = "foo";
+cacheout $path;
+
+print $path "\n";
+
+close $path;
+
+print "not " unless -f $path;
+print "ok 1\n";
+
+unlink $path;
diff --git a/contrib/perl5/t/lib/filecopy.t b/contrib/perl5/t/lib/filecopy.t
new file mode 100755
index 000000000000..329931f4b413
--- /dev/null
+++ b/contrib/perl5/t/lib/filecopy.t
@@ -0,0 +1,90 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..11\n";
+
+$| = 1;
+
+use File::Copy;
+
+# First we create a file
+open(F, ">file-$$") or die;
+binmode F; # for DOSISH platforms, because test 3 copies to stdout
+print F "ok 3\n";
+close F;
+
+copy "file-$$", "copy-$$";
+
+open(F, "copy-$$") or die;
+$foo = <F>;
+close(F);
+
+print "not " if -s "file-$$" != -s "copy-$$";
+print "ok 1\n";
+
+print "not " unless $foo eq "ok 3\n";
+print "ok 2\n";
+
+binmode STDOUT unless $^O eq 'VMS'; # Copy::copy works in binary mode
+copy "copy-$$", \*STDOUT;
+unlink "copy-$$" or die "unlink: $!";
+
+open(F,"file-$$");
+copy(*F, "copy-$$");
+open(R, "copy-$$") or die "open copy-$$: $!"; $foo = <R>; close(R);
+print "not " unless $foo eq "ok 3\n";
+print "ok 4\n";
+unlink "copy-$$" or die "unlink: $!";
+open(F,"file-$$");
+copy(\*F, "copy-$$");
+close(F) or die "close: $!";
+open(R, "copy-$$") or die; $foo = <R>; close(R) or die "close: $!";
+print "not " unless $foo eq "ok 3\n";
+print "ok 5\n";
+unlink "copy-$$" or die "unlink: $!";
+
+require IO::File;
+$fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!";
+binmode $fh or die;
+copy("file-$$",$fh);
+$fh->close or die "close: $!";
+open(R, "copy-$$") or die; $foo = <R>; close(R);
+print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n";
+print "ok 6\n";
+unlink "copy-$$" or die "unlink: $!";
+require FileHandle;
+my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!";
+binmode $fh or die;
+copy("file-$$",$fh);
+$fh->close;
+open(R, "copy-$$") or die; $foo = <R>; close(R);
+print "not " unless $foo eq "ok 3\n";
+print "ok 7\n";
+unlink "file-$$" or die "unlink: $!";
+
+print "# moved missing file.\nnot " if move("file-$$", "copy-$$");
+print "# target disappeared.\nnot " if not -e "copy-$$";
+print "ok 8\n";
+
+move "copy-$$", "file-$$" or print "# move did not succeed.\n";
+print "# not moved: $!\nnot " unless -e "file-$$" and not -e "copy-$$";
+open(R, "file-$$") or die; $foo = <R>; close(R);
+print "# foo=`$foo'\nnot " unless $foo eq "ok 3\n";
+print "ok 9\n";
+
+copy "file-$$", "lib";
+open(R, "lib/file-$$") or die; $foo = <R>; close(R);
+print "not " unless $foo eq "ok 3\n";
+print "ok 10\n";
+unlink "lib/file-$$" or die "unlink: $!";
+
+move "file-$$", "lib";
+open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
+print "not " unless $foo eq "ok 3\n" and not -e "file-$$";;
+print "ok 11\n";
+unlink "lib/file-$$" or die "unlink: $!";
+
diff --git a/contrib/perl5/t/lib/filefind.t b/contrib/perl5/t/lib/filefind.t
new file mode 100755
index 000000000000..cd2e9771c7ad
--- /dev/null
+++ b/contrib/perl5/t/lib/filefind.t
@@ -0,0 +1,14 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..2\n";
+
+use File::Find;
+
+# hope we will eventually find ourself
+find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, ".");
+finddepth(sub { print "ok 2\n" if $_ eq 'filefind.t'; }, ".");
diff --git a/contrib/perl5/t/lib/filehand.t b/contrib/perl5/t/lib/filehand.t
new file mode 100755
index 000000000000..b8ec95f320e2
--- /dev/null
+++ b/contrib/perl5/t/lib/filehand.t
@@ -0,0 +1,90 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use FileHandle;
+use strict subs;
+
+autoflush STDOUT 1;
+
+$mystdout = new_from_fd FileHandle 1,"w";
+$| = 1;
+autoflush $mystdout;
+print "1..11\n";
+
+print $mystdout "ok ",fileno($mystdout),"\n";
+
+$fh = (new FileHandle "./TEST", O_RDONLY
+ or new FileHandle "TEST", O_RDONLY)
+ and print "ok 2\n";
+
+
+$buffer = <$fh>;
+print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n";
+
+
+ungetc $fh ord 'A';
+CORE::read($fh, $buf,1);
+print $buf eq 'A' ? "ok 4\n" : "not ok 4\n";
+
+close $fh;
+
+$fh = new FileHandle;
+
+print "not " unless ($fh->open("< TEST") && <$fh> eq $buffer);
+print "ok 5\n";
+
+$fh->seek(0,0);
+print "#possible mixed CRLF/LF in t/TEST\nnot " unless (<$fh> eq $buffer);
+print "ok 6\n";
+
+$fh->seek(0,2);
+$line = <$fh>;
+print "not " if (defined($line) || !$fh->eof);
+print "ok 7\n";
+
+print "not " unless ($fh->open("TEST","r") && !$fh->tell && $fh->close);
+print "ok 8\n";
+
+autoflush STDOUT 0;
+
+print "not " if ($|);
+print "ok 9\n";
+
+autoflush STDOUT 1;
+
+print "not " unless ($|);
+print "ok 10\n";
+
+if ($^O eq 'dos')
+{
+ printf("ok %d\n",11);
+ exit(0);
+}
+
+($rd,$wr) = FileHandle::pipe;
+
+if ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'amigaos' || $^O eq 'MSWin32') {
+ $wr->autoflush;
+ $wr->printf("ok %d\n",11);
+ print $rd->getline;
+}
+else {
+ if (fork) {
+ $wr->close;
+ print $rd->getline;
+ }
+ else {
+ $rd->close;
+ $wr->printf("ok %d\n",11);
+ exit(0);
+ }
+}
diff --git a/contrib/perl5/t/lib/filepath.t b/contrib/perl5/t/lib/filepath.t
new file mode 100755
index 000000000000..c3bf4a44799f
--- /dev/null
+++ b/contrib/perl5/t/lib/filepath.t
@@ -0,0 +1,28 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use File::Path;
+use strict;
+
+my $count = 0;
+$^W = 1;
+
+print "1..4\n";
+
+# first check for stupid permissions second for full, so we clean up
+# behind ourselves
+for my $perm (0111,0777) {
+ mkpath("foo/bar");
+ chmod $perm, "foo", "foo/bar";
+
+ print "not " unless -d "foo" && -d "foo/bar";
+ print "ok ", ++$count, "\n";
+
+ rmtree("foo");
+ print "not " if -e "foo";
+ print "ok ", ++$count, "\n";
+}
diff --git a/contrib/perl5/t/lib/filespec.t b/contrib/perl5/t/lib/filespec.t
new file mode 100755
index 000000000000..ca22d3e12ba6
--- /dev/null
+++ b/contrib/perl5/t/lib/filespec.t
@@ -0,0 +1,43 @@
+#!./perl
+
+BEGIN {
+ $^O = '';
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..4\n";
+
+use File::Spec;
+
+
+if (File::Spec->catfile('a','b','c') eq 'a/b/c') {
+ print "ok 1\n";
+} else {
+ print "not ok 1\n";
+}
+
+use File::Spec::OS2;
+
+if (File::Spec::OS2->catfile('a','b','c') eq 'a/b/c') {
+ print "ok 2\n";
+} else {
+ print "not ok 2\n";
+}
+
+use File::Spec::Win32;
+
+if (File::Spec::Win32->catfile('a','b','c') eq 'a\b\c') {
+ print "ok 3\n";
+} else {
+ print "not ok 3\n";
+}
+
+use File::Spec::Mac;
+
+if (File::Spec::Mac->catfile('a','b','c') eq 'a:b:c') {
+ print "ok 4\n";
+} else {
+ print "not ok 4\n";
+}
+
diff --git a/contrib/perl5/t/lib/findbin.t b/contrib/perl5/t/lib/findbin.t
new file mode 100755
index 000000000000..3e742f9a4f79
--- /dev/null
+++ b/contrib/perl5/t/lib/findbin.t
@@ -0,0 +1,13 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..1\n";
+
+use FindBin qw($Bin);
+
+print "not " unless $Bin =~ m,t[/.]lib\]?$,;
+print "ok 1\n";
diff --git a/contrib/perl5/t/lib/gdbm.t b/contrib/perl5/t/lib/gdbm.t
new file mode 100755
index 000000000000..2395611d1e18
--- /dev/null
+++ b/contrib/perl5/t/lib/gdbm.t
@@ -0,0 +1,208 @@
+#!./perl
+
+# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+BEGIN {
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bGDBM_File\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use GDBM_File;
+
+print "1..20\n";
+
+unlink <Op.dbmx*>;
+
+umask(0);
+print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 1\n" : "not ok 1\n");
+
+$Dfile = "Op.dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op.dbmx*>;
+}
+if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') {
+ print "ok 2 # Skipped: different file permission semantics\n";
+}
+else {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+}
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+print (!$i ? "ok 3\n" : "not ok 3\n");
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+$h{'b'} = 'B';
+$h{'c'} = 'C';
+$h{'d'} = 'D';
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'G';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+untie(%h);
+print (tie(%h,GDBM_File,'Op.dbmx', &GDBM_WRCREAT, 0640) ? "ok 4\n" : "not ok 4\n");
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+delete $h{'goner3'};
+
+@keys = keys(%h);
+@values = values(%h);
+
+if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+@keys = ('blurfl', keys(%h), 'dyick');
+if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+$h{'foo'} = '';
+$h{''} = 'bar';
+
+# check cache overflow and numeric keys and contents
+$ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+print ($ok ? "ok 8\n" : "not ok 8\n");
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+@h{0..200} = 200..400;
+@foo = @h{0..200};
+print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
+print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
+
+untie %h;
+unlink 'Op.dbmx.dir', $Dfile;
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw(@ISA @EXPORT) ;
+
+ require Exporter ;
+ use GDBM_File;
+ @ISA=qw(GDBM_File);
+ @EXPORT = @GDBM_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+
+ eval 'use SubDB ; ';
+ main::ok(13, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash.tmp", &GDBM_WRCREAT, 0640 );
+ ' ;
+
+ main::ok(14, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(15, $@ eq "") ;
+ main::ok(16, $ret == 5) ;
+
+ $ret = eval ' &GDBM_WRCREAT eq &main::GDBM_WRCREAT ' ;
+ main::ok(17, $@ eq "" ) ;
+ main::ok(18, $ret == 1) ;
+
+ $ret = eval '$X->A_new_method("fred") ' ;
+ main::ok(19, $@ eq "") ;
+ main::ok(20, $ret eq "[[5]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+}
diff --git a/contrib/perl5/t/lib/getopt.t b/contrib/perl5/t/lib/getopt.t
new file mode 100755
index 000000000000..fb70f10aae87
--- /dev/null
+++ b/contrib/perl5/t/lib/getopt.t
@@ -0,0 +1,73 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..11\n";
+
+use Getopt::Std;
+
+# First we test the getopt function
+@ARGV = qw(-xo -f foo -y file);
+getopt('f');
+
+print "not " if "@ARGV" ne 'file';
+print "ok 1\n";
+
+print "not " unless $opt_x && $opt_o && opt_y;
+print "ok 2\n";
+
+print "not " unless $opt_f eq 'foo';
+print "ok 3\n";
+
+
+# Then we try the getopts
+$opt_o = $opt_i = $opt_f = undef;
+@ARGV = qw(-foi -i file);
+getopts('oif:') or print "not ";
+print "ok 4\n";
+
+print "not " unless "@ARGV" eq 'file';
+print "ok 5\n";
+
+print "not " unless $opt_i and $opt_f eq 'oi';
+print "ok 6\n";
+
+print "not " if $opt_o;
+print "ok 7\n";
+
+# Try illegal options, but avoid printing of the error message
+
+open(STDERR, ">stderr") || die;
+
+@ARGV = qw(-h help);
+
+!getopts("xf:y") or print "not ";
+print "ok 8\n";
+
+
+# Then try the Getopt::Long module
+
+use Getopt::Long;
+
+@ARGV = qw(--help --file foo --foo --nobar --num=5 -- file);
+
+GetOptions(
+ 'help' => \$HELP,
+ 'file:s' => \$FILE,
+ 'foo!' => \$FOO,
+ 'bar!' => \$BAR,
+ 'num:i' => \$NO,
+) || print "not ";
+print "ok 9\n";
+
+print "not " unless $HELP && $FOO && !$BAR && $FILE eq 'foo' && $NO == 5;
+print "ok 10\n";
+
+print "not " unless "@ARGV" eq "file";
+print "ok 11\n";
+
+close STDERR;
+unlink "stderr";
diff --git a/contrib/perl5/t/lib/h2ph.h b/contrib/perl5/t/lib/h2ph.h
new file mode 100644
index 000000000000..cddf0a7d947d
--- /dev/null
+++ b/contrib/perl5/t/lib/h2ph.h
@@ -0,0 +1,85 @@
+/*
+ * Test header file for h2ph
+ *
+ * Try to test as many constructs as possible
+ * For example, the multi-line comment :)
+ */
+
+/* And here's a single line comment :) */
+
+/* Test #define with no indenting, over multiple lines */
+#define SQUARE(x) \
+((x)*(x))
+
+/* Test #ifndef and parameter interpretation*/
+#ifndef ERROR
+#define ERROR(x) fprintf(stderr, "%s\n", x[2][3][0])
+#endif /* ERROR */
+
+#ifndef _H2PH_H_
+#define _H2PH_H_
+
+/* #ident - doesn't really do anything, but I think it always gets included anyway */
+#ident "$Revision h2ph.h,v 1.0 98/05/04 20:42:14 billy $"
+
+/* Test #undef */
+#undef MAX
+#define MAX(a,b) ((a) > (b) ? (a) : (b))
+
+/* Test #ifdef */
+#ifdef __SOME_UNIMPORTANT_PROPERTY
+#define MIN(a,b) ((a) < (b) ? (a) : (b))
+#endif /* __SOME_UNIMPORTANT_PROPERTY */
+
+/*
+ * Test #if, #elif, #else, #endif, #warn and #error, and `!'
+ * Also test whitespace between the `#' and the command
+ */
+#if !(defined __SOMETHING_MORE_IMPORTANT)
+# warn Be careful...
+#elif !(defined __SOMETHING_REALLY_REALLY_IMPORTANT)
+# error Nup, can't go on /* ' /* stupid font-lock-mode */
+#else /* defined __SOMETHING_MORE_IMPORTANT && defined __SOMETHING_REALLY_REALLY_IMPORTANT */
+# define EVERYTHING_IS_OK
+#endif
+
+/* Test && and || */
+#undef WHATEVER
+#if (!((defined __SOMETHING_TRIVIAL && defined __SOMETHING_LESS_SO)) \
+ || defined __SOMETHING_OVERPOWERING)
+# define WHATEVER 6
+#elif !(defined __SOMETHING_TRIVIAL) /* defined __SOMETHING_LESS_SO */
+# define WHATEVER 7
+#elif !(defined __SOMETHING_LESS_SO) /* defined __SOMETHING_TRIVIAL */
+# define WHATEVER 8
+#else /* defined __SOMETHING_TRIVIAL && defined __SOMETHING_LESS_SO */
+# define WHATEVER 1000
+#endif
+
+/*
+ * Test #include, #import and #include_next
+ * #include_next is difficult to test, it really depends on the actual
+ * circumstances - for example, `#include_next <limits.h>' on a Linux system
+ * with `use lib qw(/opt/perl5/lib/site_perl/i586-linux/linux);' or whatever
+ * your equivalent is...
+ */
+#include <sys/socket.h>
+#import "sys/ioctl.h"
+#include_next <sys/fcntl.h>
+
+/* typedefs should be ignored */
+typedef struct a_struct {
+ int typedefs_should;
+ char be_ignored;
+ long as_well;
+} a_typedef;
+
+/*
+ * however, typedefs of enums and just plain enums should end up being treated
+ * like a bunch of #defines...
+ */
+
+typedef enum _days_of_week { sun, mon, tue, wed, thu, fri, sat, Sun=0, Mon,
+ Tue, Wed, Thu, Fri, Sat } days_of_week;
+
+#endif /* _H2PH_H_ */
diff --git a/contrib/perl5/t/lib/h2ph.pht b/contrib/perl5/t/lib/h2ph.pht
new file mode 100644
index 000000000000..80867a611378
--- /dev/null
+++ b/contrib/perl5/t/lib/h2ph.pht
@@ -0,0 +1,69 @@
+unless(defined(&SQUARE)) {
+ sub SQUARE {
+ local($x) = @_;
+ eval q((($x)*($x)));
+ }
+}
+unless(defined(&ERROR)) {
+ eval 'sub ERROR {
+ local($x) = @_;
+ eval q( &fprintf( &stderr, \\"%s\\\\n\\", $x->[2][3][0]));
+ }' unless defined(&ERROR);
+}
+unless(defined(&_H2PH_H_)) {
+ eval 'sub _H2PH_H_ () {1;}' unless defined(&_H2PH_H_);
+ # "$Revision h2ph.h,v 1.0 98/05/04 20:42:14 billy $"
+ undef(&MAX) if defined(&MAX);
+ eval 'sub MAX {
+ local($a,$b) = @_;
+ eval q((($a) > ($b) ? ($a) : ($b)));
+ }' unless defined(&MAX);
+ if(defined(&__SOME_UNIMPORTANT_PROPERTY)) {
+ eval 'sub MIN {
+ local($a,$b) = @_;
+ eval q((($a) < ($b) ? ($a) : ($b)));
+ }' unless defined(&MIN);
+ }
+ if(!(defined (defined(&__SOMETHING_MORE_IMPORTANT) ? &__SOMETHING_MORE_IMPORTANT : 0))) {
+ }
+ elsif(!(defined (defined(&__SOMETHING_REALLY_REALLY_IMPORTANT) ? &__SOMETHING_REALLY_REALLY_IMPORTANT : 0))) {
+ die("Nup, can't go on ");
+ } else {
+ eval 'sub EVERYTHING_IS_OK () {1;}' unless defined(&EVERYTHING_IS_OK);
+ }
+ undef(&WHATEVER) if defined(&WHATEVER);
+ if((!((defined (defined(&__SOMETHING_TRIVIAL) ? &__SOMETHING_TRIVIAL : 0) && defined (defined(&__SOMETHING_LESS_SO) ? &__SOMETHING_LESS_SO : 0))) || defined (defined(&__SOMETHING_OVERPOWERING) ? &__SOMETHING_OVERPOWERING : 0))) {
+ eval 'sub WHATEVER () {6;}' unless defined(&WHATEVER);
+ }
+ elsif(!(defined (defined(&__SOMETHING_TRIVIAL) ? &__SOMETHING_TRIVIAL : 0)) ) {
+ eval 'sub WHATEVER () {7;}' unless defined(&WHATEVER);
+ }
+ elsif(!(defined (defined(&__SOMETHING_LESS_SO) ? &__SOMETHING_LESS_SO : 0)) ) {
+ eval 'sub WHATEVER () {8;}' unless defined(&WHATEVER);
+ } else {
+ eval 'sub WHATEVER () {1000;}' unless defined(&WHATEVER);
+ }
+ require 'sys/socket.ph';
+ require 'sys/ioctl.ph';
+ eval {
+ my(%INCD) = map { $INC{$_} => 1 } (grep { $_ eq "sys/fcntl.ph" } keys(%INC));
+ my(@REM) = map { "$_/sys/fcntl.ph" } (grep { not exists($INCD{"$_/sys/fcntl.ph"})and -f "$_/sys/fcntl.ph" } @INC);
+ require "$REM[0]" if @REM;
+ };
+ warn($@) if $@;
+ eval("sub sun () { 0; }") unless defined(&sun);
+ eval("sub mon () { 1; }") unless defined(&mon);
+ eval("sub tue () { 2; }") unless defined(&tue);
+ eval("sub wed () { 3; }") unless defined(&wed);
+ eval("sub thu () { 4; }") unless defined(&thu);
+ eval("sub fri () { 5; }") unless defined(&fri);
+ eval("sub sat () { 6; }") unless defined(&sat);
+ eval("sub Sun () { 0; }") unless defined(&Sun);
+ eval("sub Mon () { 1; }") unless defined(&Mon);
+ eval("sub Tue () { 2; }") unless defined(&Tue);
+ eval("sub Wed () { 3; }") unless defined(&Wed);
+ eval("sub Thu () { 4; }") unless defined(&Thu);
+ eval("sub Fri () { 5; }") unless defined(&Fri);
+ eval("sub Sat () { 6; }") unless defined(&Sat);
+}
+1;
diff --git a/contrib/perl5/t/lib/h2ph.t b/contrib/perl5/t/lib/h2ph.t
new file mode 100755
index 000000000000..1fa7f63536d7
--- /dev/null
+++ b/contrib/perl5/t/lib/h2ph.t
@@ -0,0 +1,34 @@
+#!./perl
+
+# quickie tests to see if h2ph actually runs and does more or less what is
+# expected
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..2\n";
+
+# quickly compare two text files
+sub txt_compare {
+ local ($/, $A, $B);
+ for (($A,$B) = @_) { open(_,"<$_") ? $_ = <_> : die "$_ : $!"; close _ }
+ $A cmp $B;
+}
+
+unless(-e '../utils/h2ph') {
+ print("ok 1\nok 2\n");
+ # i'll probably get in trouble for this :)
+} else {
+ # does it run?
+ $ok = system("./perl -I../lib ../utils/h2ph -d. -Q lib/h2ph.h");
+ print(($ok == 0 ? "" : "not "), "ok 1\n");
+
+ # does it work? well, does it do what we expect? :-)
+ $ok = txt_compare("lib/h2ph.ph", "lib/h2ph.pht");
+ print(($ok == 0 ? "" : "not "), "ok 2\n");
+
+ # cleanup - should this be in an END block?
+ unlink("lib/h2ph.ph");
+}
diff --git a/contrib/perl5/t/lib/hostname.t b/contrib/perl5/t/lib/hostname.t
new file mode 100755
index 000000000000..e4ac36521c7b
--- /dev/null
+++ b/contrib/perl5/t/lib/hostname.t
@@ -0,0 +1,19 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Sys::Hostname;
+
+eval {
+ $host = hostname;
+};
+
+if ($@) {
+ print "1..0\n" if $@ =~ /Cannot get host name/;
+} else {
+ print "1..1\n";
+ print "ok 1\n";
+}
diff --git a/contrib/perl5/t/lib/io_dup.t b/contrib/perl5/t/lib/io_dup.t
new file mode 100755
index 000000000000..6b0caf14fad8
--- /dev/null
+++ b/contrib/perl5/t/lib/io_dup.t
@@ -0,0 +1,61 @@
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+use IO::Handle;
+use IO::File;
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+print "1..6\n";
+
+print "ok 1\n";
+
+$dupout = IO::Handle->new->fdopen( \*STDOUT ,"w");
+$duperr = IO::Handle->new->fdopen( \*STDERR ,"w");
+
+$stdout = \*STDOUT; bless $stdout, "IO::File"; # "IO::Handle";
+$stderr = \*STDERR; bless $stderr, "IO::Handle";
+
+$stdout->open( "Io.dup","w") || die "Can't open stdout";
+$stderr->fdopen($stdout,"w");
+
+print $stdout "ok 2\n";
+print $stderr "ok 3\n";
+if ($^O eq 'MSWin32') {
+ print `echo ok 4`;
+ print `echo ok 5 1>&2`; # does this *really* work?
+}
+else {
+ system 'echo ok 4';
+ system 'echo ok 5 1>&2';
+}
+
+$stderr->close;
+$stdout->close;
+
+$stdout->fdopen($dupout,"w");
+$stderr->fdopen($duperr,"w");
+
+if ($^O eq 'MSWin32') { print `type Io.dup` }
+else { system 'cat Io.dup' }
+unlink 'Io.dup';
+
+print STDOUT "ok 6\n";
diff --git a/contrib/perl5/t/lib/io_pipe.t b/contrib/perl5/t/lib/io_pipe.t
new file mode 100755
index 000000000000..e617c92432fc
--- /dev/null
+++ b/contrib/perl5/t/lib/io_pipe.t
@@ -0,0 +1,117 @@
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if (! $Config{'d_fork'} ||
+ ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS'))
+ {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+use IO::Pipe;
+
+my $perl = './perl';
+
+$| = 1;
+print "1..10\n";
+
+$pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"');
+while (<$pipe>) {
+ s/^not //;
+ print;
+}
+$pipe->close or print "# \$!=$!\nnot ";
+print "ok 2\n";
+
+$cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //';
+$pipe = new IO::Pipe->writer($perl, '-pe', $cmd);
+print $pipe "not ok 3\n" ;
+$pipe->close or print "# \$!=$!\nnot ";
+print "ok 4\n";
+
+# Check if can fork with dynamic extensions (bug in CRT):
+if ($^O eq 'os2' and
+ system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") {
+ print "ok $_ # skipped: broken fork\n" for 5..10;
+ exit 0;
+}
+
+$pipe = new IO::Pipe;
+
+$pid = fork();
+
+if($pid)
+ {
+ $pipe->writer;
+ print $pipe "Xk 5\n";
+ print $pipe "oY 6\n";
+ $pipe->close;
+ wait;
+ }
+elsif(defined $pid)
+ {
+ $pipe->reader;
+ $stdin = bless \*STDIN, "IO::Handle";
+ $stdin->fdopen($pipe,"r");
+ exec 'tr', 'YX', 'ko';
+ }
+else
+ {
+ die "# error = $!";
+ }
+
+$pipe = new IO::Pipe;
+$pid = fork();
+
+if($pid)
+ {
+ $pipe->reader;
+ while(<$pipe>) {
+ s/^not //;
+ print;
+ }
+ $pipe->close;
+ wait;
+ }
+elsif(defined $pid)
+ {
+ $pipe->writer;
+
+ $stdout = bless \*STDOUT, "IO::Handle";
+ $stdout->fdopen($pipe,"w");
+ print STDOUT "not ok 7\n";
+ exec 'echo', 'not ok 8';
+ }
+else
+ {
+ die;
+ }
+
+$pipe = new IO::Pipe;
+$pipe->writer;
+
+$SIG{'PIPE'} = 'broken_pipe';
+
+sub broken_pipe {
+ print "ok 9\n";
+}
+
+print $pipe "not ok 9\n";
+$pipe->close;
+
+sleep 1;
+
+print "ok 10\n";
+
diff --git a/contrib/perl5/t/lib/io_sel.t b/contrib/perl5/t/lib/io_sel.t
new file mode 100755
index 000000000000..3dc651bbc24a
--- /dev/null
+++ b/contrib/perl5/t/lib/io_sel.t
@@ -0,0 +1,116 @@
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+print "1..21\n";
+
+use IO::Select 1.09;
+
+my $sel = new IO::Select(\*STDIN);
+$sel->add(4, 5) == 2 or print "not ";
+print "ok 1\n";
+
+$sel->add([\*STDOUT, 'foo']) == 1 or print "not ";
+print "ok 2\n";
+
+@handles = $sel->handles;
+print "not " unless $sel->count == 4 && @handles == 4;
+print "ok 3\n";
+#print $sel->as_string, "\n";
+
+$sel->remove(\*STDIN) == 1 or print "not ";
+print "ok 4\n",
+;
+$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present
+ or print "not ";
+print "ok 5\n";
+
+print "not " unless $sel->count == 2;
+print "ok 6\n";
+#print $sel->as_string, "\n";
+
+$sel->remove(1, 4);
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 7\n";
+
+$sel = new IO::Select;
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 8\n";
+
+$sel->remove([\*STDOUT, 5]);
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 9\n";
+
+if ($^O eq 'MSWin32' || $^O eq 'dos') { # 4-arg select is only valid on sockets
+ print "# skipping tests 10..15\n";
+ for (10 .. 15) { print "ok $_\n" }
+ $sel->add(\*STDOUT); # update
+ goto POST_SOCKET;
+}
+
+@a = $sel->can_read(); # should return imediately
+print "not " unless @a == 0;
+print "ok 10\n";
+
+# we assume that we can write to STDOUT :-)
+$sel->add([\*STDOUT, "ok 12\n"]);
+
+@a = $sel->can_write;
+print "not " unless @a == 1;
+print "ok 11\n";
+
+my($fd, $msg) = @{shift @a};
+print $fd $msg;
+
+$sel->add(\*STDOUT); # update
+
+@a = IO::Select::select(undef, $sel, undef, 1);
+print "not " unless @a == 3;
+print "ok 13\n";
+
+($r, $w, $e) = @a;
+
+print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
+print "ok 14\n";
+
+$fd = $w->[0];
+print $fd "ok 15\n";
+
+POST_SOCKET:
+# Test new exists() method
+$sel->exists(\*STDIN) and print "not ";
+print "ok 16\n";
+
+($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
+print "ok 17\n";
+
+$fd = $sel->exists(\*STDOUT);
+if ($fd) {
+ print $fd "ok 18\n";
+} else {
+ print "not ok 18\n";
+}
+
+$fd = $sel->exists([1, 'foo']);
+if ($fd) {
+ print $fd "ok 19\n";
+} else {
+ print "not ok 19\n";
+}
+
+# Try self clearing
+$sel->add(5,6,7,8,9,10);
+print "not " unless $sel->count == 7;
+print "ok 20\n";
+
+$sel->remove($sel->handles);
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 21\n";
diff --git a/contrib/perl5/t/lib/io_sock.t b/contrib/perl5/t/lib/io_sock.t
new file mode 100755
index 000000000000..8fc52e4026bf
--- /dev/null
+++ b/contrib/perl5/t/lib/io_sock.t
@@ -0,0 +1,91 @@
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if (-d "lib" && -f "TEST") {
+ if (!$Config{'d_fork'} ||
+ (($Config{'extensions'} !~ /\bSocket\b/ ||
+ $Config{'extensions'} !~ /\bIO\b/) &&
+ !(($^O eq 'VMS') && $Config{d_socket}))) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+$| = 1;
+print "1..5\n";
+
+use IO::Socket;
+
+$listen = IO::Socket::INET->new(Listen => 2,
+ Proto => 'tcp',
+ ) or die "$!";
+
+print "ok 1\n";
+
+# Check if can fork with dynamic extensions (bug in CRT):
+if ($^O eq 'os2' and
+ system "$^X -I../lib -MOpcode -e 'defined fork or die' > /dev/null 2>&1") {
+ print "ok $_ # skipped: broken fork\n" for 2..5;
+ exit 0;
+}
+
+$port = $listen->sockport;
+
+if($pid = fork()) {
+
+ $sock = $listen->accept();
+ print "ok 2\n";
+
+ $sock->autoflush(1);
+ print $sock->getline();
+
+ print $sock "ok 4\n";
+
+ $sock->close;
+
+ waitpid($pid,0);
+
+ print "ok 5\n";
+
+} elsif(defined $pid) {
+
+ # This can fail if localhost is undefined or the
+ # special 'loopback' address 127.0.0.1 is not configured
+ # on your system. (/etc/rc.config.d/netconfig on HP-UX.)
+ # As a shortcut (not recommended) you could change 'localhost'
+ # here to be the name of this machine eg 'myhost.mycompany.com'.
+
+ $sock = IO::Socket::INET->new(PeerPort => $port,
+ Proto => 'tcp',
+ PeerAddr => 'localhost'
+ )
+ or die "$! (maybe your system does not have the 'localhost' address defined)";
+
+ $sock->autoflush(1);
+
+ print $sock "ok 3\n";
+
+ print $sock->getline();
+
+ $sock->close;
+
+ exit;
+} else {
+ die;
+}
+
+
+
+
+
+
diff --git a/contrib/perl5/t/lib/io_taint.t b/contrib/perl5/t/lib/io_taint.t
new file mode 100755
index 000000000000..0ef2cfd63f51
--- /dev/null
+++ b/contrib/perl5/t/lib/io_taint.t
@@ -0,0 +1,48 @@
+#!./perl -T
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+END { unlink "./__taint__$$" }
+
+print "1..3\n";
+use IO::File;
+$x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n");
+print $x "$$\n";
+$x->close;
+
+$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n");
+chop($unsafe = <$x>);
+eval { kill 0 * $unsafe };
+print "not " if $^O ne 'MSWin32' and ($@ !~ /^Insecure/o);
+print "ok 1\n";
+$x->close;
+
+# We could have just done a seek on $x, but technically we haven't tested
+# seek yet...
+$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n");
+$x->untaint;
+print "not " if ($?);
+print "ok 2\n"; # Calling the method worked
+chop($unsafe = <$x>);
+eval { kill 0 * $unsafe };
+print "not " if ($@ =~ /^Insecure/o);
+print "ok 3\n"; # No Insecure message from using the data
+$x->close;
+
+exit 0;
diff --git a/contrib/perl5/t/lib/io_tell.t b/contrib/perl5/t/lib/io_tell.t
new file mode 100755
index 000000000000..2009d610db00
--- /dev/null
+++ b/contrib/perl5/t/lib/io_tell.t
@@ -0,0 +1,64 @@
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ $tell_file = "TEST";
+ }
+ else {
+ $tell_file = "Makefile";
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+print "1..13\n";
+
+use IO::File;
+
+$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file");
+binmode $tst if ($^O eq 'MSWin32' or $^O eq 'dos');
+if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; }
+
+$firstline = <$tst>;
+$secondpos = tell;
+
+$x = 0;
+while (<$tst>) {
+ if (eof) {$x++;}
+}
+if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
+
+$lastpos = tell;
+
+unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
+
+if ($tst->seek(0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
+
+if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
+
+if ($firstline eq <$tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
+
+if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
+
+if ($tst->seek(0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
+
+if ($tst->eof) { print "not ok 9\n"; } else { print "ok 9\n"; }
+
+if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
+
+if ($tst->seek(0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
+
+if ($lastpos == $tst->tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
+
+unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
diff --git a/contrib/perl5/t/lib/io_udp.t b/contrib/perl5/t/lib/io_udp.t
new file mode 100755
index 000000000000..014e12dc58dc
--- /dev/null
+++ b/contrib/perl5/t/lib/io_udp.t
@@ -0,0 +1,48 @@
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
+ $Config{'extensions'} !~ /\bIO\b/ ||
+ $^O eq 'os2') &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+$| = 1;
+print "1..3\n";
+
+use Socket;
+use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
+
+ # This can fail if localhost is undefined or the
+ # special 'loopback' address 127.0.0.1 is not configured
+ # on your system. (/etc/rc.config.d/netconfig on HP-UX.)
+ # As a shortcut (not recommended) you could change 'localhost'
+ # here to be the name of this machine eg 'myhost.mycompany.com'.
+
+$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
+ or die "$! (maybe your system does not have the 'localhost' address defined)";
+$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
+ or die "$! (maybe your system does not have the 'localhost' address defined)";
+
+print "ok 1\n";
+
+$udpa->send("ok 2\n",0,$udpb->sockname);
+$udpb->recv($buf="",5);
+print $buf;
+$udpb->send("ok 3\n");
+$udpa->recv($buf="",5);
+print $buf;
diff --git a/contrib/perl5/t/lib/io_xs.t b/contrib/perl5/t/lib/io_xs.t
new file mode 100755
index 000000000000..1a6fd381a306
--- /dev/null
+++ b/contrib/perl5/t/lib/io_xs.t
@@ -0,0 +1,42 @@
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+}
+
+use IO::File;
+use IO::Seekable;
+
+print "1..4\n";
+
+$x = new_tmpfile IO::File or print "not ";
+print "ok 1\n";
+print $x "ok 2\n";
+$x->seek(0,SEEK_SET);
+print <$x>;
+
+$x->seek(0,SEEK_SET);
+print $x "not ok 3\n";
+$p = $x->getpos;
+print $x "ok 3\n";
+$x->flush;
+$x->setpos($p);
+print scalar <$x>;
+
+$! = 0;
+$x->setpos(undef);
+print $! ? "ok 4 # $!\n" : "not ok 4\n";
diff --git a/contrib/perl5/t/lib/ipc_sysv.t b/contrib/perl5/t/lib/ipc_sysv.t
new file mode 100755
index 000000000000..30ea48d99942
--- /dev/null
+++ b/contrib/perl5/t/lib/ipc_sysv.t
@@ -0,0 +1,178 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+
+ @INC = '../lib';
+
+ require Config; import Config;
+
+ unless ($Config{'d_msg'} eq 'define' &&
+ $Config{'d_sem'} eq 'define') {
+ print "1..0\n";
+ exit;
+ }
+}
+
+# These constants are common to all tests.
+# Later the sem* tests will import more for themselves.
+
+use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID
+ S_IRWXU S_IRWXG S_IRWXO);
+use strict;
+
+print "1..16\n";
+
+my $msg;
+my $sem;
+
+$SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed
+
+# FreeBSD is known to throw this if there's no SysV IPC in the kernel.
+$SIG{SYS} = sub {
+ print STDERR <<EOM;
+SIGSYS caught.
+It may be that your kernel does not have SysV IPC configured.
+
+EOM
+ if ($^O eq 'freebsd') {
+ print STDERR <<EOM;
+You must have following options in your kernel:
+
+options SYSVSHM
+options SYSVSEM
+options SYSVMSG
+
+See config(8).
+EOM
+ }
+ exit(1);
+};
+
+if ($Config{'d_msgget'} eq 'define' &&
+ $Config{'d_msgctl'} eq 'define' &&
+ $Config{'d_msgsnd'} eq 'define' &&
+ $Config{'d_msgrcv'} eq 'define') {
+ $msg = msgget(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO);
+ # Very first time called after machine is booted value may be 0
+ die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
+
+ print "ok 1\n";
+
+ #Putting a message on the queue
+ my $msgtype = 1;
+ my $msgtext = "hello";
+
+ msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not ";
+ print "ok 2\n";
+
+ my $data;
+ msgctl($msg,IPC_STAT,$data) or print "not ";
+ print "ok 3\n";
+
+ print "not " unless length($data);
+ print "ok 4\n";
+
+ my $msgbuf;
+ msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not ";
+ print "ok 5\n";
+
+ my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf);
+
+ print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext);
+ print "ok 6\n";
+} else {
+ for (1..6) {
+ print "ok $_\n"; # fake it
+ }
+}
+
+if($Config{'d_semget'} eq 'define' &&
+ $Config{'d_semctl'} eq 'define') {
+
+ use IPC::SysV qw(IPC_CREAT GETALL SETALL);
+
+ $sem = semget(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT);
+ # Very first time called after machine is booted value may be 0
+ die "semget: $!\n" unless defined($sem) && $sem >= 0;
+
+ print "ok 7\n";
+
+ my $data;
+ semctl($sem,0,IPC_STAT,$data) or print "not ";
+ print "ok 8\n";
+
+ print "not " unless length($data);
+ print "ok 9\n";
+
+ my $template;
+
+ # Find the pack/unpack template capable of handling native C shorts.
+
+ if ($Config{shortsize} == 2) {
+ $template = "s";
+ } elsif ($Config{shortsize} == 4) {
+ $template = "l";
+ } elsif ($Config{shortsize} == 8) {
+ # Try quad last because not supported everywhere.
+ foreach my $t (qw(i q)) {
+ # We could trap the unsupported quad template with eval
+ # but if we get this far we should have quad support anyway.
+ if (length(pack($t, 0)) == 8) {
+ $template = $t;
+ last;
+ }
+ }
+ }
+
+ die "$0: cannot pack native shorts\n" unless defined $template;
+
+ $template .= "*";
+
+ my $nsem = 10;
+
+ semctl($sem,0,SETALL,pack($template,(0) x $nsem)) or print "not ";
+ print "ok 10\n";
+
+ $data = "";
+ semctl($sem,0,GETALL,$data) or print "not ";
+ print "ok 11\n";
+
+ print "not " unless length($data) == length(pack($template,(0) x $nsem));
+ print "ok 12\n";
+
+ my @data = unpack($template,$data);
+
+ my $adata = "0" x $nsem;
+
+ print "not " unless @data == $nsem and join("",@data) eq $adata;
+ print "ok 13\n";
+
+ my $poke = 2;
+
+ $data[$poke] = 1;
+ semctl($sem,0,SETALL,pack($template,@data)) or print "not ";
+ print "ok 14\n";
+
+ $data = "";
+ semctl($sem,0,GETALL,$data) or print "not ";
+ print "ok 15\n";
+
+ @data = unpack($template,$data);
+
+ my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
+
+ print "not " unless join("",@data) eq $bdata;
+ print "ok 16\n";
+} else {
+ for (7..16) {
+ print "ok $_\n"; # fake it
+ }
+}
+
+sub cleanup {
+ msgctl($msg,IPC_RMID,0) if defined $msg;
+ semctl($sem,0,IPC_RMID,undef) if defined $sem;
+}
+
+cleanup;
diff --git a/contrib/perl5/t/lib/ndbm.t b/contrib/perl5/t/lib/ndbm.t
new file mode 100755
index 000000000000..a97dbd1f1e95
--- /dev/null
+++ b/contrib/perl5/t/lib/ndbm.t
@@ -0,0 +1,207 @@
+#!./perl
+
+# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bNDBM_File\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+require NDBM_File;
+#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+use Fcntl;
+
+print "1..18\n";
+
+unlink <Op.dbmx*>;
+
+umask(0);
+print (tie(%h,NDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n");
+
+$Dfile = "Op.dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op.dbmx*>;
+}
+if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') {
+ print "ok 2 # Skipped: different file permission semantics\n";
+}
+else {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+}
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+print (!$i ? "ok 3\n" : "not ok 3\n");
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+$h{'b'} = 'B';
+$h{'c'} = 'C';
+$h{'d'} = 'D';
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'G';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+untie(%h);
+print (tie(%h,NDBM_File,'Op.dbmx', &O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+delete $h{'goner3'};
+
+@keys = keys(%h);
+@values = values(%h);
+
+if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+@keys = ('blurfl', keys(%h), 'dyick');
+if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+$h{'foo'} = '';
+$h{''} = 'bar';
+
+# check cache overflow and numeric keys and contents
+$ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+print ($ok ? "ok 8\n" : "not ok 8\n");
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+@h{0..200} = 200..400;
+@foo = @h{0..200};
+print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
+print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
+
+untie %h;
+unlink 'Op.dbmx.dir', $Dfile;
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw(@ISA @EXPORT) ;
+
+ require Exporter ;
+ use NDBM_File;
+ @ISA=qw(NDBM_File);
+ @EXPORT = @NDBM_File::EXPORT if defined @NDBM_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+
+ eval 'use SubDB ; use Fcntl ; ';
+ main::ok(13, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 );
+ ' ;
+
+ main::ok(14, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(15, $@ eq "") ;
+ main::ok(16, $ret == 5) ;
+
+ $ret = eval '$X->A_new_method("fred") ' ;
+ main::ok(17, $@ eq "") ;
+ main::ok(18, $ret eq "[[5]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+}
diff --git a/contrib/perl5/t/lib/odbm.t b/contrib/perl5/t/lib/odbm.t
new file mode 100755
index 000000000000..8ba9bcf3a47b
--- /dev/null
+++ b/contrib/perl5/t/lib/odbm.t
@@ -0,0 +1,207 @@
+#!./perl
+
+# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bODBM_File\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+require ODBM_File;
+#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+use Fcntl;
+
+print "1..18\n";
+
+unlink <Op.dbmx*>;
+
+umask(0);
+print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640) ? "ok 1\n" : "not ok 1\n");
+
+$Dfile = "Op.dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op.dbmx*>;
+}
+if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') {
+ print "ok 2 # Skipped: different file permission semantics\n";
+}
+else {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+}
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+print (!$i ? "ok 3\n" : "not ok 3\n");
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+$h{'b'} = 'B';
+$h{'c'} = 'C';
+$h{'d'} = 'D';
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'G';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+untie(%h);
+print (tie(%h,ODBM_File,'Op.dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+delete $h{'goner3'};
+
+@keys = keys(%h);
+@values = values(%h);
+
+if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+@keys = ('blurfl', keys(%h), 'dyick');
+if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+$h{'foo'} = '';
+$h{''} = 'bar';
+
+# check cache overflow and numeric keys and contents
+$ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+print ($ok ? "ok 8\n" : "not ok 8\n");
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+@h{0..200} = 200..400;
+@foo = @h{0..200};
+print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
+print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
+
+untie %h;
+unlink 'Op.dbmx.dir', $Dfile;
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw(@ISA @EXPORT) ;
+
+ require Exporter ;
+ use ODBM_File;
+ @ISA=qw(ODBM_File);
+ @EXPORT = @ODBM_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+
+ eval 'use SubDB ; use Fcntl ;';
+ main::ok(13, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640 );
+ ' ;
+
+ main::ok(14, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(15, $@ eq "") ;
+ main::ok(16, $ret == 5) ;
+
+ $ret = eval '$X->A_new_method("fred") ' ;
+ main::ok(17, $@ eq "") ;
+ main::ok(18, $ret eq "[[5]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+}
diff --git a/contrib/perl5/t/lib/opcode.t b/contrib/perl5/t/lib/opcode.t
new file mode 100755
index 000000000000..a785fce48b66
--- /dev/null
+++ b/contrib/perl5/t/lib/opcode.t
@@ -0,0 +1,115 @@
+#!./perl -w
+
+$|=1;
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use Opcode qw(
+ opcodes opdesc opmask verify_opset
+ opset opset_to_ops opset_to_hex invert_opset
+ opmask_add full_opset empty_opset define_optag
+);
+
+use strict;
+
+my $t = 1;
+my $last_test; # initalised at end
+print "1..$last_test\n";
+
+my($s1, $s2, $s3);
+my(@o1, @o2, @o3);
+
+# --- opset_to_ops and opset
+
+my @empty_l = opset_to_ops(empty_opset);
+print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+my @full_l1 = opset_to_ops(full_opset);
+print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
+my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed
+print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++;
+
+@empty_l = opset_to_ops(opset(':none'));
+print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+my @full_l3 = opset_to_ops(opset(':all'));
+print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++;
+print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++;
+
+die $t unless $t == 7;
+$s1 = opset( 'padsv');
+$s2 = opset($s1, 'padav');
+$s3 = opset($s2, '!padav');
+print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t;
+print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t;
+
+# --- define_optag
+
+print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t;
+define_optag(":_tst_", opset(qw(padsv padav padhv)));
+print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t;
+
+# --- opdesc and opcodes
+
+die $t unless $t == 11;
+print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++;
+my @desc = opdesc(':_tst_','stub');
+print "@desc" eq "private variable private array private hash stub"
+ ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++;
+print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
+print "ok $t\n"; ++$t;
+
+# --- invert_opset
+
+$s1 = opset(qw(fileno padsv padav));
+@o2 = opset_to_ops(invert_opset($s1));
+print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+# --- opmask
+
+die $t unless $t == 16;
+print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work
+print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++;
+
+# --- verify_opset
+
+print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++;
+
+# --- opmask_add
+
+opmask_add(opset(qw(fileno))); # add to global op_mask
+print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail
+print $@ =~ /fileno trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++;
+
+# --- check use of bit vector ops on opsets
+
+$s1 = opset('padsv');
+$s2 = opset('padav');
+$s3 = opset('padsv', 'padav', 'padhv');
+
+# Non-negated
+print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++;
+print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++;
+print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++;
+
+# Negated, e.g., with possible extra bits in last byte beyond last op bit.
+# The extra bits mean we can't just say ~mask eq invert_opset(mask).
+
+@o1 = opset_to_ops( ~ $s3);
+@o2 = opset_to_ops(invert_opset $s3);
+print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++;
+
+# --- finally, check some opname assertions
+
+foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ }
+
+print "ok $last_test\n";
+BEGIN { $last_test = 25 }
diff --git a/contrib/perl5/t/lib/open2.t b/contrib/perl5/t/lib/open2.t
new file mode 100755
index 000000000000..85b807c98aae
--- /dev/null
+++ b/contrib/perl5/t/lib/open2.t
@@ -0,0 +1,59 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (!$Config{'d_fork'}
+ # open2/3 supported on win32 (but not Borland due to CRT bugs)
+ && ($^O ne 'MSWin32' || $Config{'cc'} =~ /^bcc/i))
+ {
+ print "1..0\n";
+ exit 0;
+ }
+ # make warnings fatal
+ $SIG{__WARN__} = sub { die @_ };
+}
+
+use strict;
+use IO::Handle;
+use IPC::Open2;
+#require 'open2.pl'; use subs 'open2';
+
+my $perl = './perl';
+
+sub ok {
+ my ($n, $result, $info) = @_;
+ if ($result) {
+ print "ok $n\n";
+ }
+ else {
+ print "not ok $n\n";
+ print "# $info\n" if $info;
+ }
+}
+
+sub cmd_line {
+ if ($^O eq 'MSWin32') {
+ return qq/"$_[0]"/;
+ }
+ else {
+ return $_[0];
+ }
+}
+
+my ($pid, $reaped_pid);
+STDOUT->autoflush;
+STDERR->autoflush;
+
+print "1..7\n";
+
+ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e',
+ cmd_line('print scalar <STDIN>');
+ok 2, print WRITE "hi kid\n";
+ok 3, <READ> =~ /^hi kid\r?\n$/;
+ok 4, close(WRITE), $!;
+ok 5, close(READ), $!;
+$reaped_pid = waitpid $pid, 0;
+ok 6, $reaped_pid == $pid, $reaped_pid;
+ok 7, $? == 0, $?;
diff --git a/contrib/perl5/t/lib/open3.t b/contrib/perl5/t/lib/open3.t
new file mode 100755
index 000000000000..b84dac9f141c
--- /dev/null
+++ b/contrib/perl5/t/lib/open3.t
@@ -0,0 +1,136 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (!$Config{'d_fork'}
+ # open2/3 supported on win32 (but not Borland due to CRT bugs)
+ && ($^O ne 'MSWin32' || $Config{'cc'} =~ /^bcc/i))
+ {
+ print "1..0\n";
+ exit 0;
+ }
+ # make warnings fatal
+ $SIG{__WARN__} = sub { die @_ };
+}
+
+use strict;
+use IO::Handle;
+use IPC::Open3;
+#require 'open3.pl'; use subs 'open3';
+
+my $perl = './perl';
+
+sub ok {
+ my ($n, $result, $info) = @_;
+ if ($result) {
+ print "ok $n\n";
+ }
+ else {
+ print "not ok $n\n";
+ print "# $info\n" if $info;
+ }
+}
+
+sub cmd_line {
+ if ($^O eq 'MSWin32') {
+ my $cmd = shift;
+ $cmd =~ tr/\r\n//d;
+ $cmd =~ s/"/\\"/g;
+ return qq/"$cmd"/;
+ }
+ else {
+ return $_[0];
+ }
+}
+
+my ($pid, $reaped_pid);
+STDOUT->autoflush;
+STDERR->autoflush;
+
+print "1..21\n";
+
+# basic
+ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print scalar <STDIN>;
+ print STDERR "hi error\n";
+EOF
+ok 2, print WRITE "hi kid\n";
+ok 3, <READ> =~ /^hi kid\r?\n$/;
+ok 4, <ERROR> =~ /^hi error\r?\n$/;
+ok 5, close(WRITE), $!;
+ok 6, close(READ), $!;
+ok 7, close(ERROR), $!;
+$reaped_pid = waitpid $pid, 0;
+ok 8, $reaped_pid == $pid, $reaped_pid;
+ok 9, $? == 0, $?;
+
+# read and error together, both named
+$pid = open3 'WRITE', 'READ', 'READ', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 10\n";
+print scalar <READ>;
+print WRITE "ok 11\n";
+print scalar <READ>;
+waitpid $pid, 0;
+
+# read and error together, error empty
+$pid = open3 'WRITE', 'READ', '', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 12\n";
+print scalar <READ>;
+print WRITE "ok 13\n";
+print scalar <READ>;
+waitpid $pid, 0;
+
+# dup writer
+ok 14, pipe PIPE_READ, PIPE_WRITE;
+$pid = open3 '<&PIPE_READ', 'READ', '',
+ $perl, '-e', cmd_line('print scalar <STDIN>');
+close PIPE_READ;
+print PIPE_WRITE "ok 15\n";
+close PIPE_WRITE;
+print scalar <READ>;
+waitpid $pid, 0;
+
+# dup reader
+$pid = open3 'WRITE', '>&STDOUT', 'ERROR',
+ $perl, '-e', cmd_line('print scalar <STDIN>');
+print WRITE "ok 16\n";
+waitpid $pid, 0;
+
+# dup error: This particular case, duping stderr onto the existing
+# stdout but putting stdout somewhere else, is a good case because it
+# used not to work.
+$pid = open3 'WRITE', 'READ', '>&STDOUT',
+ $perl, '-e', cmd_line('print STDERR scalar <STDIN>');
+print WRITE "ok 17\n";
+waitpid $pid, 0;
+
+# dup reader and error together, both named
+$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print STDOUT scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 18\n";
+print WRITE "ok 19\n";
+waitpid $pid, 0;
+
+# dup reader and error together, error empty
+$pid = open3 'WRITE', '>&STDOUT', '', $perl, '-e', cmd_line(<<'EOF');
+ $| = 1;
+ print STDOUT scalar <STDIN>;
+ print STDERR scalar <STDIN>;
+EOF
+print WRITE "ok 20\n";
+print WRITE "ok 21\n";
+waitpid $pid, 0;
diff --git a/contrib/perl5/t/lib/ops.t b/contrib/perl5/t/lib/ops.t
new file mode 100755
index 000000000000..56b1bacabb09
--- /dev/null
+++ b/contrib/perl5/t/lib/ops.t
@@ -0,0 +1,29 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+print "1..2\n";
+
+eval <<'EOP';
+ no ops 'fileno'; # equiv to "perl -M-ops=fileno"
+ $a = fileno STDIN;
+EOP
+
+print $@ =~ /trapped/ ? "ok 1\n" : "not ok 1\n# $@\n";
+
+eval <<'EOP';
+ use ops ':default'; # equiv to "perl -M(as above) -Mops=:default"
+ eval 1;
+EOP
+
+print $@ =~ /trapped/ ? "ok 2\n" : "not ok 2\n# $@\n";
+
+1;
diff --git a/contrib/perl5/t/lib/parsewords.t b/contrib/perl5/t/lib/parsewords.t
new file mode 100755
index 000000000000..90791790ab85
--- /dev/null
+++ b/contrib/perl5/t/lib/parsewords.t
@@ -0,0 +1,103 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Text::ParseWords;
+
+print "1..17\n";
+
+@words = shellwords(qq(foo "bar quiz" zoo));
+print "not " if $words[0] ne 'foo';
+print "ok 1\n";
+print "not " if $words[1] ne 'bar quiz';
+print "ok 2\n";
+print "not " if $words[2] ne 'zoo';
+print "ok 3\n";
+
+# Gonna get some undefined things back
+local($^W) = 0;
+
+# Test quotewords() with other parameters and null last field
+@words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:');
+print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;);
+print "ok 4\n";
+
+$^W = 1;
+
+# Test $keep eq 'delimiters' and last field zero
+@words = quotewords('\s+', 'delimiters', '4 3 2 1 0');
+print "not " unless join(";", @words) eq qq(4; ;3; ;2; ;1; ;0);
+print "ok 5\n";
+
+# Big ol' nasty test (thanks, Joerk!)
+$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd" eee\\\\\\"ffff" "gg"';
+
+# First with $keep == 1
+$result = join('|', parse_line('\s+', 1, $string));
+print "not " unless $result eq 'aaaa"bbbbb"|cc\\ cc|\\\\\\"dddd" eee\\\\\\"ffff"|"gg"';
+print "ok 6\n";
+
+# Now, $keep == 0
+$result = join('|', parse_line('\s+', 0, $string));
+print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\"ffff|gg';
+print "ok 7\n";
+
+# Now test single quote behavior
+$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd\' eee\\\\\\"ffff\' gg';
+$result = join('|', parse_line('\s+', 0, $string));
+print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\\\\\"ffff|gg';
+print "ok 8\n";
+
+# Make sure @nested_quotewords does the right thing
+@lists = nested_quotewords('\s+', 0, 'a b c', '1 2 3', 'x y z');
+print "not " unless (@lists == 3 && @{$lists[0]} == 3 && @{$lists[1]} == 3 && @{$lists[2]} == 3);
+print "ok 9\n";
+
+# Now test error return
+$string = 'foo bar baz"bach blech boop';
+
+@words = shellwords($string);
+print "not " if (@words);
+print "ok 10\n";
+
+@words = parse_line('s+', 0, $string);
+print "not " if (@words);
+print "ok 11\n";
+
+@words = quotewords('s+', 0, $string);
+print "not " if (@words);
+print "ok 12\n";
+
+# Gonna get some more undefined things back
+$^W = 0;
+
+@words = nested_quotewords('s+', 0, $string);
+print "not " if (@words);
+print "ok 13\n";
+
+# Now test empty fields
+$result = join('|', parse_line(':', 0, 'foo::0:"":::'));
+print "not " unless ($result eq 'foo||0||||');
+print "ok 14\n";
+
+# Test for 0 in quotes without $keep
+$result = join('|', parse_line(':', 0, ':"0":'));
+print "not " unless ($result eq '|0|');
+print "ok 15\n";
+
+# Test for \001 in quoted string
+$result = join('|', parse_line(':', 0, ':"' . "\001" . '":'));
+print "not " unless ($result eq "|\1|");
+print "ok 16\n";
+
+$^W = 1;
+
+# Now test perlish single quote behavior
+$Text::ParseWords::PERL_SINGLE_QUOTE = 1;
+$string = 'aaaa"bbbbb" cc\ cc \\\\\"dddd\' eee\\\\\"\\\'ffff\' gg';
+$result = join('|', parse_line('\s+', 0, $string));
+print "not " unless $result eq 'aaaabbbbb|cc cc|\"dddd eee\\\\"\'ffff|gg';
+print "ok 17\n";
diff --git a/contrib/perl5/t/lib/ph.t b/contrib/perl5/t/lib/ph.t
new file mode 100755
index 000000000000..de27dee5e23b
--- /dev/null
+++ b/contrib/perl5/t/lib/ph.t
@@ -0,0 +1,96 @@
+#!./perl
+
+# Check for presence and correctness of .ph files; for now,
+# just socket.ph and pals.
+# -- Kurt Starsinic <kstar@isinet.com>
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# All the constants which Socket.pm tries to make available:
+my @possibly_defined = qw(
+ INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT
+ AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK
+ AF_INET AF_LAT AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP
+ AF_SNA AF_UNIX AF_UNSPEC AF_X25 MSG_DONTROUTE MSG_MAXIOVLEN MSG_OOB
+ MSG_PEEK PF_802 PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI
+ PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT
+ PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25 SOCK_DGRAM
+ SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SOMAXCONN
+ SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR
+ SO_KEEPALIVE SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO
+ SO_REUSEADDR SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK
+);
+
+
+# The libraries which I'm going to require:
+my @libs = qw(Socket "sys/types.ph" "sys/socket.ph" "netinet/in.ph");
+
+
+# These are defined by Socket.pm even if the C header files don't define them:
+my %ok_to_miss = (
+ INADDR_NONE => 1,
+ INADDR_LOOPBACK => 1,
+);
+
+
+my $total_tests = scalar @libs + scalar @possibly_defined;
+my $i = 0;
+
+print "1..$total_tests\n";
+
+
+foreach (@libs) {
+ $i++;
+
+ if (eval "require $_" ) {
+ print "ok $i\n";
+ } else {
+ print "# Skipping tests; $_ may be missing\n";
+ foreach ($i .. $total_tests) { print "ok $_\n" }
+ exit;
+ }
+}
+
+
+foreach (@possibly_defined) {
+ $i++;
+
+ $pm_val = eval "Socket::$_()";
+ $ph_val = eval "main::$_()";
+
+ if (defined $pm_val and !defined $ph_val) {
+ if ($ok_to_miss{$_}) { print "ok $i\n" }
+ else { print "not ok $i\n" }
+ next;
+ } elsif (defined $ph_val and !defined $pm_val) {
+ print "not ok $i\n";
+ next;
+ }
+
+ # Socket.pm converts these to network byte order, so we convert the
+ # socket.ph version to match; note that these cases skip the following
+ # `elsif', which is only applied to _numeric_ values, not literal
+ # bitmasks.
+ if ($_ eq 'INADDR_ANY'
+ or $_ eq 'INADDR_LOOPBACK'
+ or $_ eq 'INADDR_NONE') {
+ $ph_val = pack("N*", $ph_val); # htonl(3) equivalent
+ }
+
+ # Since Socket.pm and socket.ph wave their hands over macros differently,
+ # they could return functionally equivalent bitmaps with different numeric
+ # interpretations (due to sign extension). The only apparent case of this
+ # is SO_DONTLINGER (only on Solaris, and deprecated, at that):
+ elsif ($pm_val != $ph_val) {
+ $pm_val = oct(sprintf "0x%lx", $pm_val);
+ $ph_val = oct(sprintf "0x%lx", $ph_val);
+ }
+
+ if ($pm_val == $ph_val) { print "ok $i\n" }
+ else { print "not ok $i\n" }
+}
+
+
diff --git a/contrib/perl5/t/lib/posix.t b/contrib/perl5/t/lib/posix.t
new file mode 100755
index 000000000000..8dafc80387d7
--- /dev/null
+++ b/contrib/perl5/t/lib/posix.t
@@ -0,0 +1,101 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($^O ne 'VMS' and $Config{'extensions'} !~ /\bPOSIX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write);
+use strict subs;
+
+$| = 1;
+print "1..18\n";
+
+$Is_W32 = $^O eq 'MSWin32';
+
+$testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n";
+read($testfd, $buffer, 9) if $testfd > 2;
+print $buffer eq "#!./perl\n" ? "ok 2\n" : "not ok 2\n";
+
+write(1,"ok 3\nnot ok 3\n", 5);
+
+@fds = POSIX::pipe();
+print $fds[0] > $testfd ? "ok 4\n" : "not ok 4\n";
+CORE::open($reader = \*READER, "<&=".$fds[0]);
+CORE::open($writer = \*WRITER, ">&=".$fds[1]);
+print $writer "ok 5\n";
+close $writer;
+print <$reader>;
+close $reader;
+
+if ($Is_W32) {
+ for (6..11) {
+ print "ok $_ # skipped, no sigaction support on win32\n";
+ }
+}
+else {
+$sigset = new POSIX::SigSet 1,3;
+delset $sigset 1;
+if (!ismember $sigset 1) { print "ok 6\n" }
+if (ismember $sigset 3) { print "ok 7\n" }
+$mask = new POSIX::SigSet &SIGINT;
+$action = new POSIX::SigAction 'main::SigHUP', $mask, 0;
+sigaction(&SIGHUP, $action);
+$SIG{'INT'} = 'SigINT';
+kill 'HUP', $$;
+sleep 1;
+print "ok 11\n";
+
+sub SigHUP {
+ print "ok 8\n";
+ kill 'INT', $$;
+ sleep 2;
+ print "ok 9\n";
+}
+
+sub SigINT {
+ print "ok 10\n";
+}
+}
+
+print &_POSIX_OPEN_MAX > $fds[1] ? "ok 12\n" : "not ok 12\n";
+
+print getcwd() =~ m#/t$# ? "ok 13\n" : "not ok 13\n";
+
+# Check string conversion functions.
+
+if ($Config{d_strtod}) {
+ $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C') if $Config{d_setlocale};
+ ($n, $x) = &POSIX::strtod('3.14159_OR_SO');
+ print (($n == 3.14159) && ($x == 6) ? "ok 14\n" : "not ok 14\n");
+ &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale};
+} else { print "# strtod not present\n", "ok 14\n"; }
+
+if ($Config{d_strtol}) {
+ ($n, $x) = &POSIX::strtol('21_PENGUINS');
+ print (($n == 21) && ($x == 9) ? "ok 15\n" : "not ok 15\n");
+} else { print "# strtol not present\n", "ok 15\n"; }
+
+if ($Config{d_strtoul}) {
+ ($n, $x) = &POSIX::strtoul('88_TEARS');
+ print (($n == 88) && ($x == 6) ? "ok 16\n" : "not ok 16\n");
+} else { print "# strtoul not present\n", "ok 16\n"; }
+
+# Pick up whether we're really able to dynamically load everything.
+print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n";
+
+# This can coredump if struct tm has a timezone field and we
+# didn't detect it. If this fails, try adding
+# -DSTRUCT_TM_HASZONE to your cflags when compiling ext/POSIX/POSIX.c.
+# See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl
+print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime());
+
+$| = 0;
+# The following line assumes buffered output, which may be not true with EMX:
+print '@#!*$@(!@#$' unless $^O eq 'os2';
+_exit(0);
diff --git a/contrib/perl5/t/lib/safe1.t b/contrib/perl5/t/lib/safe1.t
new file mode 100755
index 000000000000..27993d95c9f5
--- /dev/null
+++ b/contrib/perl5/t/lib/safe1.t
@@ -0,0 +1,68 @@
+#!./perl -w
+$|=1;
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+# Tests Todo:
+# 'main' as root
+
+package test; # test from somewhere other than main
+
+use vars qw($bar);
+
+use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
+ opmask_add full_opset empty_opset opcodes opmask define_optag);
+
+use Safe 1.00;
+
+my $last_test; # initalised at end
+print "1..$last_test\n";
+
+my $t = 1;
+my $cpt;
+# create and destroy some automatic Safe compartments first
+$cpt = new Safe or die;
+$cpt = new Safe or die;
+$cpt = new Safe or die;
+
+$cpt = new Safe "Root" or die;
+
+foreach(1..3) {
+ $foo = 42;
+
+ $cpt->share(qw($foo));
+
+ print ${$cpt->varglob('foo')} == 42 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ ${$cpt->varglob('foo')} = 9;
+
+ print $foo == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ print $cpt->reval('$foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ # check 'main' has been changed:
+ print $cpt->reval('$::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ print $cpt->reval('$main::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ # check we can't see our test package:
+ print $cpt->reval('$test::foo') ? "not ok $t\n" : "ok $t\n"; $t++;
+ print $cpt->reval('${"test::foo"}') ? "not ok $t\n" : "ok $t\n"; $t++;
+
+ $cpt->erase; # erase the compartment, e.g., delete all variables
+
+ print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++;
+
+ # Note that we *must* use $cpt->varglob here because if we used
+ # $Root::foo etc we would still see the original values!
+ # This seems to be because the compiler has created an extra ref.
+
+ print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++;
+}
+
+print "ok $last_test\n";
+BEGIN { $last_test = 28 }
diff --git a/contrib/perl5/t/lib/safe2.t b/contrib/perl5/t/lib/safe2.t
new file mode 100755
index 000000000000..c9e38808b3c1
--- /dev/null
+++ b/contrib/perl5/t/lib/safe2.t
@@ -0,0 +1,146 @@
+#!./perl -w
+$|=1;
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ # test 30 rather naughtily expects English error messages
+ $ENV{'LC_ALL'} = 'C';
+}
+
+# Tests Todo:
+# 'main' as root
+
+use vars qw($bar);
+
+use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
+ opmask_add full_opset empty_opset opcodes opmask define_optag);
+
+use Safe 1.00;
+
+my $last_test; # initalised at end
+print "1..$last_test\n";
+
+# Set up a package namespace of things to be visible to the unsafe code
+$Root::foo = "visible";
+$bar = "invisible";
+
+# Stop perl from moaning about identifies which are apparently only used once
+$Root::foo .= "";
+
+my $cpt;
+# create and destroy a couple of automatic Safe compartments first
+$cpt = new Safe or die;
+$cpt = new Safe or die;
+
+$cpt = new Safe "Root";
+
+$cpt->reval(q{ system("echo not ok 1"); });
+if ($@ =~ /^system trapped by operation mask/) {
+ print "ok 1\n";
+} else {
+ print "#$@" if $@;
+ print "not ok 1\n";
+}
+
+$cpt->reval(q{
+ print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n";
+ print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n";
+ print defined($bar) ? "not ok 4\n" : "ok 4\n";
+ print defined($::bar) ? "not ok 5\n" : "ok 5\n";
+ print defined($main::bar) ? "not ok 6\n" : "ok 6\n";
+});
+print $@ ? "not ok 7\n#$@" : "ok 7\n";
+
+$foo = "ok 8\n";
+%bar = (key => "ok 9\n");
+@baz = (); push(@baz, "o", "10"); $" = 'k ';
+$glob = "ok 11\n";
+@glob = qw(not ok 16);
+
+sub sayok { print "ok @_\n" }
+
+$cpt->share(qw($foo %bar @baz *glob sayok));
+$cpt->share('$"') unless $Config{archname} =~ /-thread$/;
+
+$cpt->reval(q{
+ package other;
+ sub other_sayok { print "ok @_\n" }
+ package main;
+ print $foo ? $foo : "not ok 8\n";
+ print $bar{key} ? $bar{key} : "not ok 9\n";
+ (@baz) ? print "@baz\n" : print "not ok 10\n";
+ print $glob;
+ other::other_sayok(12);
+ $foo =~ s/8/14/;
+ $bar{new} = "ok 15\n";
+ @glob = qw(ok 16);
+});
+print $@ ? "not ok 13\n#$@" : "ok 13\n";
+$" = ' ';
+print $foo, $bar{new}, "@glob\n";
+
+$Root::foo = "not ok 17";
+@{$cpt->varglob('bar')} = qw(not ok 18);
+${$cpt->varglob('foo')} = "ok 17";
+@Root::bar = "ok";
+push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
+
+print "$Root::foo\n";
+print "@{$cpt->varglob('bar')}\n";
+
+use strict;
+
+print 1 ? "ok 19\n" : "not ok 19\n";
+print 1 ? "ok 20\n" : "not ok 20\n";
+
+my $m1 = $cpt->mask;
+$cpt->trap("negate");
+my $m2 = $cpt->mask;
+my @masked = opset_to_ops($m1);
+print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
+
+print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
+
+print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
+
+$cpt->mask(empty_opset);
+my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
+print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
+my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
+print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
+
+my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
+print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
+print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
+
+# --- rdo
+
+my $t = 30;
+$cpt->rdo('/non/existant/file.name');
+print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) ||
+ $! =~ /A file or directory in the path name does not exist/ ||
+ $! =~ /Invalid argument/ ||
+ $! =~ /Device not configured/ ?
+ "ok $t\n" : "not ok $t # $!\n"); $t++;
+print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++;
+
+#my $rdo_file = "tmp_rdo.tpl";
+#if (open X,">$rdo_file") {
+# print X "999\n";
+# close X;
+# $cpt->permit_only('const', 'leaveeval');
+# print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
+# unlink $rdo_file;
+#}
+#else {
+# print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
+#}
+
+
+print "ok $last_test\n";
+BEGIN { $last_test = 32 }
diff --git a/contrib/perl5/t/lib/sdbm.t b/contrib/perl5/t/lib/sdbm.t
new file mode 100755
index 000000000000..591fe14c60be
--- /dev/null
+++ b/contrib/perl5/t/lib/sdbm.t
@@ -0,0 +1,212 @@
+#!./perl
+
+# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (($Config{'extensions'} !~ /\bSDBM_File\b/) && ($^O ne 'VMS')){
+ print "1..0\n";
+ exit 0;
+ }
+}
+require SDBM_File;
+#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
+use Fcntl;
+
+print "1..18\n";
+
+unlink <Op_dbmx.*>;
+
+umask(0);
+print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR|O_CREAT, 0640)
+ ? "ok 1\n" : "not ok 1\n");
+
+$Dfile = "Op_dbmx.pag";
+if (! -e $Dfile) {
+ ($Dfile) = <Op_dbmx.*>;
+}
+if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') {
+ print "ok 2 # Skipped: different file permission semantics\n";
+}
+else {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+ print (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
+}
+while (($key,$value) = each(%h)) {
+ $i++;
+}
+print (!$i ? "ok 3\n" : "not ok 3\n");
+
+$h{'goner1'} = 'snork';
+
+$h{'abc'} = 'ABC';
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+$h{'b'} = 'B';
+$h{'c'} = 'C';
+$h{'d'} = 'D';
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'G';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+
+$h{'goner2'} = 'snork';
+delete $h{'goner2'};
+
+untie(%h);
+print (tie(%h,SDBM_File,'Op_dbmx', O_RDWR, 0640) ? "ok 4\n" : "not ok 4\n");
+
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+$h{'goner3'} = 'snork';
+
+delete $h{'goner1'};
+delete $h{'goner3'};
+
+@keys = keys(%h);
+@values = values(%h);
+
+if ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
+
+while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+if ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
+
+@keys = ('blurfl', keys(%h), 'dyick');
+if ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
+
+$h{'foo'} = '';
+$h{''} = 'bar';
+
+# check cache overflow and numeric keys and contents
+$ok = 1;
+for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
+for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
+print ($ok ? "ok 8\n" : "not ok 8\n");
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat($Dfile);
+print ($size > 0 ? "ok 9\n" : "not ok 9\n");
+
+@h{0..200} = 200..400;
+@foo = @h{0..200};
+print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "not ok 10\n";
+
+print ($h{'foo'} eq '' ? "ok 11\n" : "not ok 11\n");
+print ($h{''} eq 'bar' ? "ok 12\n" : "not ok 12\n");
+
+untie %h;
+if ($^O eq 'VMS') {
+ unlink 'Op_dbmx.sdbm_dir', $Dfile;
+} else {
+ unlink 'Op_dbmx.dir', $Dfile;
+}
+
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+{
+ # sub-class test
+
+ package Another ;
+
+ use strict ;
+
+ open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
+ print FILE <<'EOM' ;
+
+ package SubDB ;
+
+ use strict ;
+ use vars qw( @ISA @EXPORT) ;
+
+ require Exporter ;
+ use SDBM_File;
+ @ISA=qw(SDBM_File);
+ @EXPORT = @SDBM_File::EXPORT if defined @SDBM_File::EXPORT ;
+
+ sub STORE {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+ $self->SUPER::STORE($key, $value * 2) ;
+ }
+
+ sub FETCH {
+ my $self = shift ;
+ my $key = shift ;
+ $self->SUPER::FETCH($key) - 1 ;
+ }
+
+ sub A_new_method
+ {
+ my $self = shift ;
+ my $key = shift ;
+ my $value = $self->FETCH($key) ;
+ return "[[$value]]" ;
+ }
+
+ 1 ;
+EOM
+
+ close FILE ;
+
+ BEGIN { push @INC, '.'; }
+
+ eval 'use SubDB ; use Fcntl ;';
+ main::ok(13, $@ eq "") ;
+ my %h ;
+ my $X ;
+ eval '
+ $X = tie(%h, "SubDB","dbhash_tmp", O_RDWR|O_CREAT, 0640 );
+ ' ;
+
+ main::ok(14, $@ eq "") ;
+
+ my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
+ main::ok(15, $@ eq "") ;
+ main::ok(16, $ret == 5) ;
+
+ $ret = eval '$X->A_new_method("fred") ' ;
+ main::ok(17, $@ eq "") ;
+ main::ok(18, $ret eq "[[5]]") ;
+
+ undef $X;
+ untie(%h);
+ unlink "SubDB.pm", <dbhash_tmp.*> ;
+
+}
diff --git a/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t
new file mode 100755
index 000000000000..447c425b2761
--- /dev/null
+++ b/contrib/perl5/t/lib/searchdict.t
@@ -0,0 +1,65 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..3\n";
+
+$DICT = <<EOT;
+Aarhus
+Aaron
+Ababa
+aback
+abaft
+abandon
+abandoned
+abandoning
+abandonment
+abandons
+abase
+abased
+abasement
+abasements
+abases
+abash
+abashed
+abashes
+abashing
+abasing
+abate
+abated
+abatement
+abatements
+abater
+abates
+abating
+Abba
+EOT
+
+use Search::Dict;
+
+open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!";
+binmode DICT; # To make length expected one.
+print DICT $DICT;
+
+my $pos = look *DICT, "abash";
+chomp($word = <DICT>);
+print "not " if $pos < 0 || $word ne "abash";
+print "ok 1\n";
+
+$pos = look *DICT, "foo";
+chomp($word = <DICT>);
+
+print "not " if $pos != length($DICT); # will search to end of file
+print "ok 2\n";
+
+$pos = look *DICT, "aarhus", 1, 1;
+chomp($word = <DICT>);
+
+print "not " if $pos < 0 || $word ne "Aarhus";
+print "ok 3\n";
+
+close DICT or die "cannot close";
+unlink "dict-$$";
diff --git a/contrib/perl5/t/lib/selectsaver.t b/contrib/perl5/t/lib/selectsaver.t
new file mode 100755
index 000000000000..3b58d709ab3a
--- /dev/null
+++ b/contrib/perl5/t/lib/selectsaver.t
@@ -0,0 +1,28 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..3\n";
+
+use SelectSaver;
+
+open(FOO, ">foo-$$") || die;
+
+print "ok 1\n";
+{
+ my $saver = new SelectSaver(FOO);
+ print "foo\n";
+}
+
+# Get data written to file
+open(FOO, "foo-$$") || die;
+chomp($foo = <FOO>);
+close FOO;
+unlink "foo-$$";
+
+print "ok 2\n" if $foo eq "foo";
+
+print "ok 3\n";
diff --git a/contrib/perl5/t/lib/socket.t b/contrib/perl5/t/lib/socket.t
new file mode 100755
index 000000000000..4e382958ce4e
--- /dev/null
+++ b/contrib/perl5/t/lib/socket.t
@@ -0,0 +1,76 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bSocket\b/ &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use Socket;
+
+print "1..6\n";
+
+if (socket(T,PF_INET,SOCK_STREAM,6)) {
+ print "ok 1\n";
+
+ if (connect(T,pack_sockaddr_in(7,inet_aton("localhost")))){
+ print "ok 2\n";
+
+ print "# Connected to ",
+ inet_ntoa((unpack_sockaddr_in(getpeername(T)))[1]),"\n";
+
+ syswrite(T,"hello",5);
+ $read = sysread(T,$buff,10); # Connection may be granted, then closed!
+ while ($read > 0 && length($buff) < 5) {
+ # adjust for fact that TCP doesn't guarantee size of reads/writes
+ $read = sysread(T,$buff,10,length($buff));
+ }
+ print(($read == 0 || $buff eq "hello") ? "ok 3\n" : "not ok 3\n");
+ }
+ else {
+ print "# You're allowed to fail tests 2 and 3 if.\n";
+ print "# The echo service has been disabled.\n";
+ print "# $!\n";
+ print "ok 2\n";
+ print "ok 3\n";
+ }
+}
+else {
+ print "# $!\n";
+ print "not ok 1\n";
+}
+
+if( socket(S,PF_INET,SOCK_STREAM,6) ){
+ print "ok 4\n";
+
+ if (connect(S,pack_sockaddr_in(7,INADDR_LOOPBACK))){
+ print "ok 5\n";
+
+ print "# Connected to ",
+ inet_ntoa((unpack_sockaddr_in(getpeername(S)))[1]),"\n";
+
+ syswrite(S,"olleh",5);
+ $read = sysread(S,$buff,10); # Connection may be granted, then closed!
+ while ($read > 0 && length($buff) < 5) {
+ # adjust for fact that TCP doesn't guarantee size of reads/writes
+ $read = sysread(S,$buff,10,length($buff));
+ }
+ print(($read == 0 || $buff eq "olleh") ? "ok 6\n" : "not ok 6\n");
+ }
+ else {
+ print "# You're allowed to fail tests 5 and 6 if.\n";
+ print "# The echo service has been disabled.\n";
+ print "# $!\n";
+ print "ok 5\n";
+ print "ok 6\n";
+ }
+}
+else {
+ print "# $!\n";
+ print "not ok 4\n";
+}
diff --git a/contrib/perl5/t/lib/soundex.t b/contrib/perl5/t/lib/soundex.t
new file mode 100755
index 000000000000..d35f264c7a67
--- /dev/null
+++ b/contrib/perl5/t/lib/soundex.t
@@ -0,0 +1,143 @@
+#!./perl
+#
+# $Id: soundex.t,v 1.2 1994/03/24 00:30:27 mike Exp $
+#
+# test module for soundex.pl
+#
+# $Log: soundex.t,v $
+# Revision 1.2 1994/03/24 00:30:27 mike
+# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu>
+# in the way I handles leasing characters which were different but had
+# the same soundex code. This showed up comparing it with Oracle's
+# soundex output.
+#
+# Revision 1.1 1994/03/02 13:03:02 mike
+# Initial revision
+#
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Text::Soundex;
+
+$test = 0;
+print "1..13\n";
+
+while (<DATA>)
+{
+ chop;
+ next if /^\s*;?#/;
+ next if /^\s*$/;
+
+ ++$test;
+ $bad = 0;
+
+ if (/^eval\s+/)
+ {
+ ($try = $_) =~ s/^eval\s+//;
+
+ eval ($try);
+ if ($@)
+ {
+ $bad++;
+ print "not ok $test\n";
+ print "# eval '$try' returned $@";
+ }
+ }
+ elsif (/^\(/)
+ {
+ ($in, $out) = split (':');
+
+ $try = "\@expect = $out; \@got = &soundex $in;";
+ eval ($try);
+
+ if (@expect != @got)
+ {
+ $bad++;
+ print "not ok $test\n";
+ print "# expected ", scalar @expect, " results, got ", scalar @got, "\n";
+ print "# expected (", join (', ', @expect),
+ ") got (", join (', ', @got), ")\n";
+ }
+ else
+ {
+ while (@got)
+ {
+ $expect = shift @expect;
+ $got = shift @got;
+
+ if ($expect ne $got)
+ {
+ $bad++;
+ print "not ok $test\n";
+ print "# expected $expect, got $got\n";
+ }
+ }
+ }
+ }
+ else
+ {
+ ($in, $out) = split (':');
+
+ $try = "\$expect = $out; \$got = &soundex ($in);";
+ eval ($try);
+
+ if ($expect ne $got)
+ {
+ $bad++;
+ print "not ok $test\n";
+ print "# expected $expect, got $got\n";
+ }
+ }
+
+ print "ok $test\n" unless $bad;
+}
+
+__END__
+#
+# 1..6
+#
+# Knuth's test cases, scalar in, scalar out
+#
+'Euler':'E460'
+'Gauss':'G200'
+'Hilbert':'H416'
+'Knuth':'K530'
+'Lloyd':'L300'
+'Lukasiewicz':'L222'
+#
+# 7..8
+#
+# check default bad code
+#
+'2 + 2 = 4':undef
+undef:undef
+#
+# 9
+#
+# check array in, array out
+#
+('Ellery', 'Ghosh', 'Heilbronn', 'Kant', 'Ladd', 'Lissajous'):('E460', 'G200', 'H416', 'K530', 'L300', 'L222')
+#
+# 10
+#
+# check array with explicit undef
+#
+('Mike', undef, 'Stok'):('M200', undef, 'S320')
+#
+# 11..12
+#
+# check setting $Text::Soundex::noCode
+#
+eval $soundex_nocode = 'Z000';
+('Mike', undef, 'Stok'):('M200', 'Z000', 'S320')
+#
+# 13
+#
+# a subtle difference between me & oracle, spotted by Rich Pinder
+# <rpinder@hsc.usc.edu>
+#
+CZARKOWSKA:C622
diff --git a/contrib/perl5/t/lib/symbol.t b/contrib/perl5/t/lib/symbol.t
new file mode 100755
index 000000000000..03449a3ed749
--- /dev/null
+++ b/contrib/perl5/t/lib/symbol.t
@@ -0,0 +1,52 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..8\n";
+
+BEGIN { $_ = 'foo'; } # because Symbol used to clobber $_
+
+use Symbol;
+
+# First check $_ clobbering
+print "not " if $_ ne 'foo';
+print "ok 1\n";
+
+
+# First test gensym()
+$sym1 = gensym;
+print "not " if ref($sym1) ne 'GLOB';
+print "ok 2\n";
+
+$sym2 = gensym;
+
+print "not " if $sym1 eq $sym2;
+print "ok 3\n";
+
+ungensym $sym1;
+
+$sym1 = $sym2 = undef;
+
+
+# Test qualify()
+package foo;
+
+use Symbol qw(qualify); # must import into this package too
+
+qualify("x") eq "foo::x" or print "not ";
+print "ok 4\n";
+
+qualify("x", "FOO") eq "FOO::x" or print "not ";
+print "ok 5\n";
+
+qualify("BAR::x") eq "BAR::x" or print "not ";
+print "ok 6\n";
+
+qualify("STDOUT") eq "main::STDOUT" or print "not ";
+print "ok 7\n";
+
+qualify("ARGV", "FOO") eq "main::ARGV" or print "not ";
+print "ok 8\n";
diff --git a/contrib/perl5/t/lib/texttabs.t b/contrib/perl5/t/lib/texttabs.t
new file mode 100755
index 000000000000..ea9012c6526e
--- /dev/null
+++ b/contrib/perl5/t/lib/texttabs.t
@@ -0,0 +1,28 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..3\n";
+
+use Text::Tabs;
+
+$tabstop = 4;
+
+$s1 = "foo\tbar\tb\tb";
+$s2 = expand $s1;
+$s3 = unexpand $s2;
+
+print "not " unless $s2 eq "foo bar b b";
+print "ok 1\n";
+
+print "not " unless $s3 eq "foo bar b\tb";
+print "ok 2\n";
+
+
+$tabstop = 8;
+
+print "not " unless unexpand(" foo") eq "\t\t foo";
+print "ok 3\n";
diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t
new file mode 100755
index 000000000000..9c8d1b497569
--- /dev/null
+++ b/contrib/perl5/t/lib/textwrap.t
@@ -0,0 +1,40 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..5\n";
+
+use Text::Wrap qw(wrap $columns);
+
+$columns = 30;
+
+$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
+
+$text =~ s/\n/ /g;
+$_ = wrap "| ", "|", $text;
+
+#print "$_\n";
+
+print "not " unless /^\| Text::Wrap is/; # start is ok
+print "ok 1\n";
+
+print "not " if /^.{31,}$/m; # no line longer than 30 chars
+print "ok 2\n";
+
+print "not " unless /^\|\w/m; # other lines start with
+print "ok 3\n";
+
+print "not " unless /\bsubsquent\b/; # look for a random word
+print "ok 4\n";
+
+print "not " unless /\bdevice\./; # look for last word
+print "ok 5\n";
diff --git a/contrib/perl5/t/lib/thread.t b/contrib/perl5/t/lib/thread.t
new file mode 100755
index 000000000000..83407a9fab6a
--- /dev/null
+++ b/contrib/perl5/t/lib/thread.t
@@ -0,0 +1,73 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (! $Config{'usethreads'}) {
+ print "1..0\n";
+ exit 0;
+ }
+
+ # XXX known trouble with global destruction
+ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
+}
+$| = 1;
+print "1..14\n";
+use Thread;
+print "ok 1\n";
+
+sub content
+{
+ print shift;
+ return shift;
+}
+
+# create a thread passing args and immedaietly wait for it.
+my $t = new Thread \&content,("ok 2\n","ok 3\n");
+print $t->join;
+
+# check that lock works ...
+{lock $foo;
+ $t = new Thread sub { lock $foo; print "ok 5\n" };
+ print "ok 4\n";
+}
+$t->join;
+
+sub dorecurse
+{
+ my $val = shift;
+ my $ret;
+ print $val;
+ if (@_)
+ {
+ $ret = Thread->new(\&dorecurse, @_);
+ $ret->join;
+ }
+}
+
+$t = new Thread \&dorecurse, map { "ok $_\n" } 6..10;
+$t->join;
+
+# test that sleep lets other thread run
+$t = new Thread \&dorecurse,"ok 11\n";
+sleep 6;
+print "ok 12\n";
+$t->join;
+
+sub islocked
+{
+ use attrs 'locked';
+ my $val = shift;
+ my $ret;
+ print $val;
+ if (@_)
+ {
+ $ret = Thread->new(\&islocked, shift);
+ }
+ $ret;
+}
+
+$t = Thread->new(\&islocked, "ok 13\n", "ok 14\n");
+$t->join->join;
+
diff --git a/contrib/perl5/t/lib/tie-push.t b/contrib/perl5/t/lib/tie-push.t
new file mode 100755
index 000000000000..dd718deb145d
--- /dev/null
+++ b/contrib/perl5/t/lib/tie-push.t
@@ -0,0 +1,24 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+{
+ package Basic;
+ use Tie::Array;
+ @ISA = qw(Tie::Array);
+
+ sub TIEARRAY { return bless [], shift }
+ sub FETCH { $_[0]->[$_[1]] }
+ sub STORE { $_[0]->[$_[1]] = $_[2] }
+ sub FETCHSIZE { scalar(@{$_[0]}) }
+ sub STORESIZE { $#{$_[0]} = $_[1]-1 }
+}
+
+tie @x,Basic;
+tie @get,Basic;
+tie @got,Basic;
+tie @tests,Basic;
+require "../t/op/push.t"
diff --git a/contrib/perl5/t/lib/tie-stdarray.t b/contrib/perl5/t/lib/tie-stdarray.t
new file mode 100755
index 000000000000..7ca4d76f1196
--- /dev/null
+++ b/contrib/perl5/t/lib/tie-stdarray.t
@@ -0,0 +1,12 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Tie::Array;
+tie @foo,Tie::StdArray;
+tie @ary,Tie::StdArray;
+tie @bar,Tie::StdArray;
+require "../t/op/array.t"
diff --git a/contrib/perl5/t/lib/tie-stdpush.t b/contrib/perl5/t/lib/tie-stdpush.t
new file mode 100755
index 000000000000..34a69472f4cd
--- /dev/null
+++ b/contrib/perl5/t/lib/tie-stdpush.t
@@ -0,0 +1,10 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Tie::Array;
+tie @x,Tie::StdArray;
+require "../t/op/push.t"
diff --git a/contrib/perl5/t/lib/timelocal.t b/contrib/perl5/t/lib/timelocal.t
new file mode 100755
index 000000000000..100e0768aa4e
--- /dev/null
+++ b/contrib/perl5/t/lib/timelocal.t
@@ -0,0 +1,90 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Time::Local;
+
+# Set up time values to test
+@time =
+ (
+ #year,mon,day,hour,min,sec
+ [1970, 1, 2, 00, 00, 00],
+ [1980, 2, 28, 12, 00, 00],
+ [1980, 2, 29, 12, 00, 00],
+ [1999, 12, 31, 23, 59, 59],
+ [2000, 1, 1, 00, 00, 00],
+ [2010, 10, 12, 14, 13, 12],
+ );
+
+# use vmsish 'time' makes for oddness around the Unix epoch
+if ($^O eq 'VMS') { $time[0][2]++ }
+
+print "1..", @time * 2 + 5, "\n";
+
+$count = 1;
+for (@time) {
+ my($year, $mon, $mday, $hour, $min, $sec) = @$_;
+ $year -= 1900;
+ $mon --;
+ my $time = timelocal($sec,$min,$hour,$mday,$mon,$year);
+ # print scalar(localtime($time)), "\n";
+ my($s,$m,$h,$D,$M,$Y) = localtime($time);
+
+ if ($s == $sec &&
+ $m == $min &&
+ $h == $hour &&
+ $D == $mday &&
+ $M == $mon &&
+ $Y == $year
+ ) {
+ print "ok $count\n";
+ } else {
+ print "not ok $count\n";
+ }
+ $count++;
+
+ # Test gmtime function
+ $time = timegm($sec,$min,$hour,$mday,$mon,$year);
+ ($s,$m,$h,$D,$M,$Y) = gmtime($time);
+
+ if ($s == $sec &&
+ $m == $min &&
+ $h == $hour &&
+ $D == $mday &&
+ $M == $mon &&
+ $Y == $year
+ ) {
+ print "ok $count\n";
+ } else {
+ print "not ok $count\n";
+ }
+ $count++;
+}
+
+#print "Testing that the differences between a few dates makes sence...\n";
+
+timelocal(0,0,1,1,0,90) - timelocal(0,0,0,1,0,90) == 3600
+ or print "not ";
+print "ok ", $count++, "\n";
+
+timelocal(1,2,3,1,0,100) - timelocal(1,2,3,31,11,99) == 24 * 3600
+ or print "not ";
+print "ok ", $count++, "\n";
+
+# Diff beween Jan 1, 1970 and Mar 1, 1970 = (31 + 28 = 59 days)
+timegm(0,0,0, 1, 2, 70) - timegm(0,0,0, 1, 0, 70) == 59 * 24 * 3600
+ or print "not ";
+print "ok ", $count++, "\n";
+
+
+#print "Testing timelocal.pl module too...\n";
+package test;
+require 'timelocal.pl';
+timegm(0,0,0,1,0,70) == main::timegm(0,0,0,1,0,70) or print "not ";
+print "ok ", $main::count++, "\n";
+
+timelocal(1,2,3,4,5,78) == main::timelocal(1,2,3,4,5,78) or print "not ";
+print "ok ", $main::count++, "\n";
diff --git a/contrib/perl5/t/lib/trig.t b/contrib/perl5/t/lib/trig.t
new file mode 100755
index 000000000000..3114176ab0b8
--- /dev/null
+++ b/contrib/perl5/t/lib/trig.t
@@ -0,0 +1,160 @@
+#!./perl
+
+#
+# Regression tests for the Math::Trig package
+#
+# The tests are quite modest as the Math::Complex tests exercise
+# these quite vigorously.
+#
+# -- Jarkko Hietaniemi, April 1997
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Math::Trig;
+
+use strict;
+
+use vars qw($x $y $z);
+
+my $eps = 1e-11;
+
+if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t.
+ $eps = 1e-10;
+}
+
+sub near ($$;$) {
+ abs($_[0] - $_[1]) < (defined $_[2] ? $_[2] : $eps);
+}
+
+print "1..20\n";
+
+$x = 0.9;
+print 'not ' unless (near(tan($x), sin($x) / cos($x)));
+print "ok 1\n";
+
+print 'not ' unless (near(sinh(2), 3.62686040784702));
+print "ok 2\n";
+
+print 'not ' unless (near(acsch(0.1), 2.99822295029797));
+print "ok 3\n";
+
+$x = asin(2);
+print 'not ' unless (ref $x eq 'Math::Complex');
+print "ok 4\n";
+
+# avoid using Math::Complex here
+$x =~ /^([^-]+)(-[^i]+)i$/;
+($y, $z) = ($1, $2);
+print 'not ' unless (near($y, 1.5707963267949) and
+ near($z, -1.31695789692482));
+print "ok 5\n";
+
+print 'not ' unless (near(deg2rad(90), pi/2));
+print "ok 6\n";
+
+print 'not ' unless (near(rad2deg(pi), 180));
+print "ok 7\n";
+
+use Math::Trig ':radial';
+
+{
+ my ($r,$t,$z) = cartesian_to_cylindrical(1,1,1);
+
+ print 'not ' unless (near($r, sqrt(2))) and
+ (near($t, deg2rad(45))) and
+ (near($z, 1));
+ print "ok 8\n";
+
+ ($x,$y,$z) = cylindrical_to_cartesian($r, $t, $z);
+
+ print 'not ' unless (near($x, 1)) and
+ (near($y, 1)) and
+ (near($z, 1));
+ print "ok 9\n";
+
+ ($r,$t,$z) = cartesian_to_cylindrical(1,1,0);
+
+ print 'not ' unless (near($r, sqrt(2))) and
+ (near($t, deg2rad(45))) and
+ (near($z, 0));
+ print "ok 10\n";
+
+ ($x,$y,$z) = cylindrical_to_cartesian($r, $t, $z);
+
+ print 'not ' unless (near($x, 1)) and
+ (near($y, 1)) and
+ (near($z, 0));
+ print "ok 11\n";
+}
+
+{
+ my ($r,$t,$f) = cartesian_to_spherical(1,1,1);
+
+ print 'not ' unless (near($r, sqrt(3))) and
+ (near($t, deg2rad(45))) and
+ (near($f, atan2(sqrt(2), 1)));
+ print "ok 12\n";
+
+ ($x,$y,$z) = spherical_to_cartesian($r, $t, $f);
+
+ print 'not ' unless (near($x, 1)) and
+ (near($y, 1)) and
+ (near($z, 1));
+ print "ok 13\n";
+
+ ($r,$t,$f) = cartesian_to_spherical(1,1,0);
+
+ print 'not ' unless (near($r, sqrt(2))) and
+ (near($t, deg2rad(45))) and
+ (near($f, deg2rad(90)));
+ print "ok 14\n";
+
+ ($x,$y,$z) = spherical_to_cartesian($r, $t, $f);
+
+ print 'not ' unless (near($x, 1)) and
+ (near($y, 1)) and
+ (near($z, 0));
+ print "ok 15\n";
+}
+
+{
+ my ($r,$t,$z) = cylindrical_to_spherical(spherical_to_cylindrical(1,1,1));
+
+ print 'not ' unless (near($r, 1)) and
+ (near($t, 1)) and
+ (near($z, 1));
+ print "ok 16\n";
+
+ ($r,$t,$z) = spherical_to_cylindrical(cylindrical_to_spherical(1,1,1));
+
+ print 'not ' unless (near($r, 1)) and
+ (near($t, 1)) and
+ (near($z, 1));
+ print "ok 17\n";
+}
+
+{
+ use Math::Trig 'great_circle_distance';
+
+ print 'not '
+ unless (near(great_circle_distance(0, 0, 0, pi/2), pi/2));
+ print "ok 18\n";
+
+ print 'not '
+ unless (near(great_circle_distance(0, 0, pi, pi), pi));
+ print "ok 19\n";
+
+ # London to Tokyo.
+ my @L = (deg2rad(-0.5), deg2rad(90 - 51.3));
+ my @T = (deg2rad(139.8),deg2rad(90 - 35.7));
+
+ my $km = great_circle_distance(@L, @T, 6378);
+
+ print 'not ' unless (near($km, 9605.26637021388));
+ print "ok 20\n";
+}
+
+# eof
diff --git a/contrib/perl5/t/op/append.t b/contrib/perl5/t/op/append.t
new file mode 100755
index 000000000000..d11514615ac2
--- /dev/null
+++ b/contrib/perl5/t/op/append.t
@@ -0,0 +1,21 @@
+#!./perl
+
+# $RCSfile: append.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:36 $
+
+print "1..3\n";
+
+$a = 'ab' . 'c'; # compile time
+$b = 'def';
+
+$c = $a . $b;
+print "#1\t:$c: eq :abcdef:\n";
+if ($c eq 'abcdef') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$c .= 'xyz';
+print "#2\t:$c: eq :abcdefxyz:\n";
+if ($c eq 'abcdefxyz') {print "ok 2\n";} else {print "not ok 2\n";}
+
+$_ = $a;
+$_ .= $b;
+print "#3\t:$_: eq :abcdef:\n";
+if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";}
diff --git a/contrib/perl5/t/op/arith.t b/contrib/perl5/t/op/arith.t
new file mode 100755
index 000000000000..43af807b8b46
--- /dev/null
+++ b/contrib/perl5/t/op/arith.t
@@ -0,0 +1,12 @@
+#!./perl
+
+print "1..4\n";
+
+sub try ($$) {
+ print +($_[1] ? "ok" : "not ok"), " $_[0]\n";
+}
+
+try 1, 13 % 4 == 1;
+try 2, -13 % 4 == 3;
+try 3, 13 % -4 == -3;
+try 4, -13 % -4 == -1;
diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t
new file mode 100755
index 000000000000..8dea44de3fa5
--- /dev/null
+++ b/contrib/perl5/t/op/array.t
@@ -0,0 +1,208 @@
+#!./perl
+
+print "1..63\n";
+
+#
+# @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them
+#
+
+@ary = (1,2,3,4,5);
+if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$tmp = $ary[$#ary]; --$#ary;
+if ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";}
+if ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";}
+if (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";}
+
+$[ = 1;
+@ary = (1,2,3,4,5);
+if (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";}
+
+$tmp = $ary[$#ary]; --$#ary;
+if ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";}
+if ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";}
+if (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";}
+
+if ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";}
+
+$#ary += 1; # see if element 5 gone for good
+if ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";}
+if (defined $ary[5]) {print "not ok 11\n";} else {print "ok 11\n";}
+
+$[ = 0;
+@foo = ();
+$r = join(',', $#foo, @foo);
+if ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";}
+$foo[0] = '0';
+$r = join(',', $#foo, @foo);
+if ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";}
+$foo[2] = '2';
+$r = join(',', $#foo, @foo);
+if ($r eq "2,0,,2") {print "ok 14\n";} else {print "not ok 14 $r\n";}
+@bar = ();
+$bar[0] = '0';
+$bar[1] = '1';
+$r = join(',', $#bar, @bar);
+if ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";}
+@bar = ();
+$r = join(',', $#bar, @bar);
+if ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";}
+$bar[0] = '0';
+$r = join(',', $#bar, @bar);
+if ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";}
+$bar[2] = '2';
+$r = join(',', $#bar, @bar);
+if ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";}
+reset 'b';
+@bar = ();
+$bar[0] = '0';
+$r = join(',', $#bar, @bar);
+if ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";}
+$bar[2] = '2';
+$r = join(',', $#bar, @bar);
+if ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";}
+
+$foo = 'now is the time';
+if (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) {
+ if ($F1 eq 'now' && $F2 eq 'is' && $Etc eq 'the time') {
+ print "ok 21\n";
+ }
+ else {
+ print "not ok 21\n";
+ }
+}
+else {
+ print "not ok 21\n";
+}
+
+$foo = 'lskjdf';
+if ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) {
+ print "not ok 22 $cnt $F1:$F2:$Etc\n";
+}
+else {
+ print "ok 22\n";
+}
+
+%foo = ('blurfl','dyick','foo','bar','etc.','etc.');
+%bar = %foo;
+print $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n";
+%bar = ();
+print $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n";
+(%bar,$a,$b) = (%foo,'how','now');
+print $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n";
+print $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n";
+@bar{keys %foo} = values %foo;
+print $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n";
+print $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n";
+
+@foo = grep(/e/,split(' ','now is the time for all good men to come to'));
+print join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n";
+
+@foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
+print join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n";
+
+$foo = join('',('a','b','c','d','e','f')[0..5]);
+print $foo eq 'abcdef' ? "ok 31\n" : "not ok 31\n";
+
+$foo = join('',('a','b','c','d','e','f')[0..1]);
+print $foo eq 'ab' ? "ok 32\n" : "not ok 32\n";
+
+$foo = join('',('a','b','c','d','e','f')[6]);
+print $foo eq '' ? "ok 33\n" : "not ok 33\n";
+
+@foo = ('a','b','c','d','e','f')[0,2,4];
+@bar = ('a','b','c','d','e','f')[1,3,5];
+$foo = join('',(@foo,@bar)[0..5]);
+print $foo eq 'acebdf' ? "ok 34\n" : "not ok 34\n";
+
+$foo = ('a','b','c','d','e','f')[0,2,4];
+print $foo eq 'e' ? "ok 35\n" : "not ok 35\n";
+
+$foo = ('a','b','c','d','e','f')[1];
+print $foo eq 'b' ? "ok 36\n" : "not ok 36\n";
+
+@foo = ( 'foo', 'bar', 'burbl');
+push(foo, 'blah');
+print $#foo == 3 ? "ok 37\n" : "not ok 37\n";
+
+# various AASSIGN_COMMON checks (see newASSIGNOP() in op.c)
+
+$test = 37;
+sub t { ++$test; print "not " unless $_[0]; print "ok $test\n"; }
+
+@foo = @foo;
+t("@foo" eq "foo bar burbl blah"); # 38
+
+(undef,@foo) = @foo;
+t("@foo" eq "bar burbl blah"); # 39
+
+@foo = ('XXX',@foo, 'YYY');
+t("@foo" eq "XXX bar burbl blah YYY"); # 40
+
+@foo = @foo = qw(foo bar burbl blah);
+t("@foo" eq "foo bar burbl blah"); # 41
+
+@bar = @foo = qw(foo bar); # 42
+t("@foo" eq "foo bar");
+t("@bar" eq "foo bar"); # 43
+
+# try the same with local
+# XXX tie-stdarray fails the tests involving local, so we use
+# different variable names to escape the 'tie'
+
+@bee = ( 'foo', 'bar', 'burbl', 'blah');
+{
+
+ local @bee = @bee;
+ t("@bee" eq "foo bar burbl blah"); # 44
+ {
+ local (undef,@bee) = @bee;
+ t("@bee" eq "bar burbl blah"); # 45
+ {
+ local @bee = ('XXX',@bee,'YYY');
+ t("@bee" eq "XXX bar burbl blah YYY"); # 46
+ {
+ local @bee = local(@bee) = qw(foo bar burbl blah);
+ t("@bee" eq "foo bar burbl blah"); # 47
+ {
+ local (@bim) = local(@bee) = qw(foo bar);
+ t("@bee" eq "foo bar"); # 48
+ t("@bim" eq "foo bar"); # 49
+ }
+ t("@bee" eq "foo bar burbl blah"); # 50
+ }
+ t("@bee" eq "XXX bar burbl blah YYY"); # 51
+ }
+ t("@bee" eq "bar burbl blah"); # 52
+ }
+ t("@bee" eq "foo bar burbl blah"); # 53
+}
+
+# try the same with my
+{
+
+ my @bee = @bee;
+ t("@bee" eq "foo bar burbl blah"); # 54
+ {
+ my (undef,@bee) = @bee;
+ t("@bee" eq "bar burbl blah"); # 55
+ {
+ my @bee = ('XXX',@bee,'YYY');
+ t("@bee" eq "XXX bar burbl blah YYY"); # 56
+ {
+ my @bee = my @bee = qw(foo bar burbl blah);
+ t("@bee" eq "foo bar burbl blah"); # 57
+ {
+ my (@bim) = my(@bee) = qw(foo bar);
+ t("@bee" eq "foo bar"); # 58
+ t("@bim" eq "foo bar"); # 59
+ }
+ t("@bee" eq "foo bar burbl blah"); # 60
+ }
+ t("@bee" eq "XXX bar burbl blah YYY"); # 61
+ }
+ t("@bee" eq "bar burbl blah"); # 62
+ }
+ t("@bee" eq "foo bar burbl blah"); # 63
+}
+
diff --git a/contrib/perl5/t/op/assignwarn.t b/contrib/perl5/t/op/assignwarn.t
new file mode 100755
index 000000000000..57e89c45e044
--- /dev/null
+++ b/contrib/perl5/t/op/assignwarn.t
@@ -0,0 +1,61 @@
+#!./perl
+
+#
+# Verify which OP= operators warn if their targets are undefined.
+# Based on redef.t, contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
+# -- Robin Barker <rmb@cise.npl.co.uk>
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+
+$^W = 1;
+my $warn = "";
+$SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) };
+
+sub ok { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; }
+
+sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; }
+
+print "1..23\n";
+
+{ my $x; $x ++; ok 1, ! uninitialized; }
+{ my $x; $x --; ok 2, ! uninitialized; }
+{ my $x; ++ $x; ok 3, ! uninitialized; }
+{ my $x; -- $x; ok 4, ! uninitialized; }
+
+{ my $x; $x **= 1; ok 5, uninitialized; }
+
+{ my $x; $x += 1; ok 6, ! uninitialized; }
+{ my $x; $x -= 1; ok 7, ! uninitialized; }
+
+{ my $x; $x .= 1; ok 8, ! uninitialized; }
+
+{ my $x; $x *= 1; ok 9, uninitialized; }
+{ my $x; $x /= 1; ok 10, uninitialized; }
+{ my $x; $x %= 1; ok 11, uninitialized; }
+
+{ my $x; $x x= 1; ok 12, uninitialized; }
+
+{ my $x; $x &= 1; ok 13, uninitialized; }
+{ my $x; $x |= 1; ok 14, ! uninitialized; }
+{ my $x; $x ^= 1; ok 15, ! uninitialized; }
+
+{ my $x; $x &&= 1; ok 16, ! uninitialized; }
+{ my $x; $x ||= 1; ok 17, ! uninitialized; }
+
+{ my $x; $x <<= 1; ok 18, uninitialized; }
+{ my $x; $x >>= 1; ok 19, uninitialized; }
+
+{ my $x; $x &= "x"; ok 20, uninitialized; }
+{ my $x; $x |= "x"; ok 21, ! uninitialized; }
+{ my $x; $x ^= "x"; ok 22, ! uninitialized; }
+
+ok 23, $warn eq '';
+
+# If we got any errors that we were not expecting, then print them
+print map "#$_\n", split /\n/, $warn if length $warn;
diff --git a/contrib/perl5/t/op/auto.t b/contrib/perl5/t/op/auto.t
new file mode 100755
index 000000000000..2eb009765098
--- /dev/null
+++ b/contrib/perl5/t/op/auto.t
@@ -0,0 +1,52 @@
+#!./perl
+
+# $RCSfile: auto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:39 $
+
+print "1..37\n";
+
+$x = 10000;
+if (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";}
+if (0 + $x-- - 1 == 10000) { print "ok 2\n";} else {print "not ok 2\n";}
+if (1 * $x == 10000) { print "ok 3\n";} else {print "not ok 3\n";}
+if (0 + $x-- - 0 == 10000) { print "ok 4\n";} else {print "not ok 4\n";}
+if (1 + $x == 10000) { print "ok 5\n";} else {print "not ok 5\n";}
+if (1 + $x++ == 10000) { print "ok 6\n";} else {print "not ok 6\n";}
+if (0 + $x == 10000) { print "ok 7\n";} else {print "not ok 7\n";}
+if (0 + --$x + 1 == 10000) { print "ok 8\n";} else {print "not ok 8\n";}
+if (0 + ++$x + 0 == 10000) { print "ok 9\n";} else {print "not ok 9\n";}
+if ($x == 10000) { print "ok 10\n";} else {print "not ok 10\n";}
+
+$x[0] = 10000;
+if (0 + ++$x[0] - 1 == 10000) { print "ok 11\n";} else {print "not ok 11\n";}
+if (0 + $x[0]-- - 1 == 10000) { print "ok 12\n";} else {print "not ok 12\n";}
+if (1 * $x[0] == 10000) { print "ok 13\n";} else {print "not ok 13\n";}
+if (0 + $x[0]-- - 0 == 10000) { print "ok 14\n";} else {print "not ok 14\n";}
+if (1 + $x[0] == 10000) { print "ok 15\n";} else {print "not ok 15\n";}
+if (1 + $x[0]++ == 10000) { print "ok 16\n";} else {print "not ok 16\n";}
+if (0 + $x[0] == 10000) { print "ok 17\n";} else {print "not ok 17\n";}
+if (0 + --$x[0] + 1 == 10000) { print "ok 18\n";} else {print "not ok 18\n";}
+if (0 + ++$x[0] + 0 == 10000) { print "ok 19\n";} else {print "not ok 19\n";}
+if ($x[0] == 10000) { print "ok 20\n";} else {print "not ok 20\n";}
+
+$x{0} = 10000;
+if (0 + ++$x{0} - 1 == 10000) { print "ok 21\n";} else {print "not ok 21\n";}
+if (0 + $x{0}-- - 1 == 10000) { print "ok 22\n";} else {print "not ok 22\n";}
+if (1 * $x{0} == 10000) { print "ok 23\n";} else {print "not ok 23\n";}
+if (0 + $x{0}-- - 0 == 10000) { print "ok 24\n";} else {print "not ok 24\n";}
+if (1 + $x{0} == 10000) { print "ok 25\n";} else {print "not ok 25\n";}
+if (1 + $x{0}++ == 10000) { print "ok 26\n";} else {print "not ok 26\n";}
+if (0 + $x{0} == 10000) { print "ok 27\n";} else {print "not ok 27\n";}
+if (0 + --$x{0} + 1 == 10000) { print "ok 28\n";} else {print "not ok 28\n";}
+if (0 + ++$x{0} + 0 == 10000) { print "ok 29\n";} else {print "not ok 29\n";}
+if ($x{0} == 10000) { print "ok 30\n";} else {print "not ok 30\n";}
+
+# test magical autoincrement
+
+if (++($foo = '99') eq '100') {print "ok 31\n";} else {print "not ok 31\n";}
+if (++($foo = 'a0') eq 'a1') {print "ok 32\n";} else {print "not ok 32\n";}
+if (++($foo = 'Az') eq 'Ba') {print "ok 33\n";} else {print "not ok 33\n";}
+if (++($foo = 'zz') eq 'aaa') {print "ok 34\n";} else {print "not ok 34\n";}
+if (++($foo = 'A99') eq 'B00') {print "ok 35\n";} else {print "not ok 35\n";}
+# EBCDIC guards: i and j, r and s, are not contiguous.
+if (++($foo = 'zi') eq 'zj') {print "ok 36\n";} else {print "not ok 36\n";}
+if (++($foo = 'zr') eq 'zs') {print "ok 37\n";} else {print "not ok 37\n";}
diff --git a/contrib/perl5/t/op/avhv.t b/contrib/perl5/t/op/avhv.t
new file mode 100755
index 000000000000..55cc992e63c6
--- /dev/null
+++ b/contrib/perl5/t/op/avhv.t
@@ -0,0 +1,110 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+require Tie::Array;
+
+package Tie::BasicArray;
+@ISA = 'Tie::Array';
+sub TIEARRAY { bless [], $_[0] }
+sub STORE { $_[0]->[$_[1]] = $_[2] }
+sub FETCH { $_[0]->[$_[1]] }
+sub FETCHSIZE { scalar(@{$_[0]})}
+sub STORESIZE { $#{$_[0]} = $_[1]+1 }
+
+package main;
+
+print "1..12\n";
+
+$sch = {
+ 'abc' => 1,
+ 'def' => 2,
+ 'jkl' => 3,
+};
+
+# basic normal array
+$a = [];
+$a->[0] = $sch;
+
+$a->{'abc'} = 'ABC';
+$a->{'def'} = 'DEF';
+$a->{'jkl'} = 'JKL';
+
+@keys = keys %$a;
+@values = values %$a;
+
+if ($#keys == 2 && $#values == 2) {print "ok 1\n";} else {print "not ok 1\n";}
+
+$i = 0; # stop -w complaints
+
+while (($key,$value) = each %$a) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+if ($i == 3) {print "ok 2\n";} else {print "not ok 2\n";}
+
+# quick check with tied array
+tie @fake, 'Tie::StdArray';
+$a = \@fake;
+$a->[0] = $sch;
+
+$a->{'abc'} = 'ABC';
+if ($a->{'abc'} eq 'ABC') {print "ok 3\n";} else {print "not ok 3\n";}
+
+# quick check with tied array
+tie @fake, 'Tie::BasicArray';
+$a = \@fake;
+$a->[0] = $sch;
+
+$a->{'abc'} = 'ABC';
+if ($a->{'abc'} eq 'ABC') {print "ok 4\n";} else {print "not ok 4\n";}
+
+# quick check with tied array & tied hash
+require Tie::Hash;
+tie %fake, Tie::StdHash;
+%fake = %$sch;
+$a->[0] = \%fake;
+
+$a->{'abc'} = 'ABC';
+if ($a->{'abc'} eq 'ABC') {print "ok 5\n";} else {print "not ok 5\n";}
+
+# hash slice
+my $slice = join('', 'x',@$a{'abc','def'},'x');
+print "not " if $slice ne 'xABCx';
+print "ok 6\n";
+
+# evaluation in scalar context
+my $avhv = [{}];
+print "not " if %$avhv;
+print "ok 7\n";
+
+push @$avhv, "a";
+print "not " if %$avhv;
+print "ok 8\n";
+
+$avhv = [];
+eval { $a = %$avhv };
+print "not " unless $@ and $@ =~ /^Can't coerce array into hash/;
+print "ok 9\n";
+
+$avhv = [{foo=>1, bar=>2}];
+print "not " unless %$avhv =~ m,^\d+/\d+,;
+print "ok 10\n";
+
+# check if defelem magic works
+sub f {
+ print "not " unless $_[0] eq 'a';
+ $_[0] = 'b';
+ print "ok 11\n";
+}
+$a = [{key => 1}, 'a'];
+f($a->{key});
+print "not " unless $a->[1] eq 'b';
+print "ok 12\n";
+
diff --git a/contrib/perl5/t/op/bop.t b/contrib/perl5/t/op/bop.t
new file mode 100755
index 000000000000..b247341417c1
--- /dev/null
+++ b/contrib/perl5/t/op/bop.t
@@ -0,0 +1,64 @@
+#!./perl
+
+#
+# test the bit operators '&', '|', '^', '~', '<<', and '>>'
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..18\n";
+
+# numerics
+print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n");
+print ((0xdead | 0xbeef) == 0xfeef ? "ok 2\n" : "not ok 2\n");
+print ((0xdead ^ 0xbeef) == 0x6042 ? "ok 3\n" : "not ok 3\n");
+print ((~0xdead & 0xbeef) == 0x2042 ? "ok 4\n" : "not ok 4\n");
+
+# shifts
+print ((257 << 7) == 32896 ? "ok 5\n" : "not ok 5\n");
+print ((33023 >> 7) == 257 ? "ok 6\n" : "not ok 6\n");
+
+# signed vs. unsigned
+print ((~0 > 0 && do { use integer; ~0 } == -1)
+ ? "ok 7\n" : "not ok 7\n");
+
+my $bits = 0;
+for (my $i = ~0; $i; $i >>= 1) { ++$bits; }
+my $cusp = 1 << ($bits - 1);
+
+print ((($cusp & -1) > 0 && do { use integer; $cusp & -1 } < 0)
+ ? "ok 8\n" : "not ok 8\n");
+print ((($cusp | 1) > 0 && do { use integer; $cusp | 1 } < 0)
+ ? "ok 9\n" : "not ok 9\n");
+print ((($cusp ^ 1) > 0 && do { use integer; $cusp ^ 1 } < 0)
+ ? "ok 10\n" : "not ok 10\n");
+print (((1 << ($bits - 1)) == $cusp &&
+ do { use integer; 1 << ($bits - 1) } == -$cusp)
+ ? "ok 11\n" : "not ok 11\n");
+print ((($cusp >> 1) == ($cusp / 2) &&
+ do { use integer; $cusp >> 1 } == -($cusp / 2))
+ ? "ok 12\n" : "not ok 12\n");
+
+$Aaz = chr(ord("A") & ord("z"));
+$Aoz = chr(ord("A") | ord("z"));
+$Axz = chr(ord("A") ^ ord("z"));
+
+# short strings
+print (("AAAAA" & "zzzzz") eq ($Aaz x 5) ? "ok 13\n" : "not ok 13\n");
+print (("AAAAA" | "zzzzz") eq ($Aoz x 5) ? "ok 14\n" : "not ok 14\n");
+print (("AAAAA" ^ "zzzzz") eq ($Axz x 5) ? "ok 15\n" : "not ok 15\n");
+
+# long strings
+$foo = "A" x 150;
+$bar = "z" x 75;
+$zap = "A" x 75;
+# & truncates
+print (($foo & $bar) eq ($Aaz x 75 ) ? "ok 16\n" : "not ok 16\n");
+# | does not truncate
+print (($foo | $bar) eq ($Aoz x 75 . $zap) ? "ok 17\n" : "not ok 17\n");
+# ^ does not truncate
+print (($foo ^ $bar) eq ($Axz x 75 . $zap) ? "ok 18\n" : "not ok 18\n");
+
diff --git a/contrib/perl5/t/op/chop.t b/contrib/perl5/t/op/chop.t
new file mode 100755
index 000000000000..77263ad3ad19
--- /dev/null
+++ b/contrib/perl5/t/op/chop.t
@@ -0,0 +1,87 @@
+#!./perl
+
+# $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $
+
+print "1..28\n";
+
+# optimized
+
+$_ = 'abc';
+$c = do foo();
+if ($c . $_ eq 'cab') {print "ok 1\n";} else {print "not ok 1 $c$_\n";}
+
+# unoptimized
+
+$_ = 'abc';
+$c = chop($_);
+if ($c . $_ eq 'cab') {print "ok 2\n";} else {print "not ok 2\n";}
+
+sub foo {
+ chop;
+}
+
+@foo = ("hi \n","there\n","!\n");
+@bar = @foo;
+chop(@bar);
+print join('',@bar) eq 'hi there!' ? "ok 3\n" : "not ok 3\n";
+
+$foo = "\n";
+chop($foo,@foo);
+print join('',$foo,@foo) eq 'hi there!' ? "ok 4\n" : "not ok 4\n";
+
+$_ = "foo\n\n";
+print chomp() == 1 ? "ok 5\n" : "not ok 5\n";
+print $_ eq "foo\n" ? "ok 6\n" : "not ok 6\n";
+
+$_ = "foo\n";
+print chomp() == 1 ? "ok 7\n" : "not ok 7\n";
+print $_ eq "foo" ? "ok 8\n" : "not ok 8\n";
+
+$_ = "foo";
+print chomp() == 0 ? "ok 9\n" : "not ok 9\n";
+print $_ eq "foo" ? "ok 10\n" : "not ok 10\n";
+
+$_ = "foo";
+$/ = "oo";
+print chomp() == 2 ? "ok 11\n" : "not ok 11\n";
+print $_ eq "f" ? "ok 12\n" : "not ok 12\n";
+
+$_ = "bar";
+$/ = "oo";
+print chomp() == 0 ? "ok 13\n" : "not ok 13\n";
+print $_ eq "bar" ? "ok 14\n" : "not ok 14\n";
+
+$_ = "f\n\n\n\n\n";
+$/ = "";
+print chomp() == 5 ? "ok 15\n" : "not ok 15\n";
+print $_ eq "f" ? "ok 16\n" : "not ok 16\n";
+
+$_ = "f\n\n";
+$/ = "";
+print chomp() == 2 ? "ok 17\n" : "not ok 17\n";
+print $_ eq "f" ? "ok 18\n" : "not ok 18\n";
+
+$_ = "f\n";
+$/ = "";
+print chomp() == 1 ? "ok 19\n" : "not ok 19\n";
+print $_ eq "f" ? "ok 20\n" : "not ok 20\n";
+
+$_ = "f";
+$/ = "";
+print chomp() == 0 ? "ok 21\n" : "not ok 21\n";
+print $_ eq "f" ? "ok 22\n" : "not ok 22\n";
+
+$_ = "xx";
+$/ = "xx";
+print chomp() == 2 ? "ok 23\n" : "not ok 23\n";
+print $_ eq "" ? "ok 24\n" : "not ok 24\n";
+
+$_ = "axx";
+$/ = "xx";
+print chomp() == 2 ? "ok 25\n" : "not ok 25\n";
+print $_ eq "a" ? "ok 26\n" : "not ok 26\n";
+
+$_ = "axx";
+$/ = "yy";
+print chomp() == 0 ? "ok 27\n" : "not ok 27\n";
+print $_ eq "axx" ? "ok 28\n" : "not ok 28\n";
diff --git a/contrib/perl5/t/op/closure.t b/contrib/perl5/t/op/closure.t
new file mode 100755
index 000000000000..95d44f51e3fa
--- /dev/null
+++ b/contrib/perl5/t/op/closure.t
@@ -0,0 +1,482 @@
+#!./perl
+# -*- Mode: Perl -*-
+# closure.t:
+# Original written by Ulrich Pfeifer on 2 Jan 1997.
+# Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997.
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+
+print "1..169\n";
+
+my $test = 1;
+sub test (&) {
+ print ((&{$_[0]})?"ok $test\n":"not ok $test\n");
+ $test++;
+}
+
+my $i = 1;
+sub foo { $i = shift if @_; $i }
+
+# no closure
+test { foo == 1 };
+foo(2);
+test { foo == 2 };
+
+# closure: lexical outside sub
+my $foo = sub {$i = shift if @_; $i };
+my $bar = sub {$i = shift if @_; $i };
+test {&$foo() == 2 };
+&$foo(3);
+test {&$foo() == 3 };
+# did the lexical change?
+test { foo == 3 and $i == 3};
+# did the second closure notice?
+test {&$bar() == 3 };
+
+# closure: lexical inside sub
+sub bar {
+ my $i = shift;
+ sub { $i = shift if @_; $i }
+}
+
+$foo = bar(4);
+$bar = bar(5);
+test {&$foo() == 4 };
+&$foo(6);
+test {&$foo() == 6 };
+test {&$bar() == 5 };
+
+# nested closures
+sub bizz {
+ my $i = 7;
+ if (@_) {
+ my $i = shift;
+ sub {$i = shift if @_; $i };
+ } else {
+ my $i = $i;
+ sub {$i = shift if @_; $i };
+ }
+}
+$foo = bizz();
+$bar = bizz();
+test {&$foo() == 7 };
+&$foo(8);
+test {&$foo() == 8 };
+test {&$bar() == 7 };
+
+$foo = bizz(9);
+$bar = bizz(10);
+test {&$foo(11)-1 == &$bar()};
+
+my @foo;
+for (qw(0 1 2 3 4)) {
+ my $i = $_;
+ $foo[$_] = sub {$i = shift if @_; $i };
+}
+
+test {
+ &{$foo[0]}() == 0 and
+ &{$foo[1]}() == 1 and
+ &{$foo[2]}() == 2 and
+ &{$foo[3]}() == 3 and
+ &{$foo[4]}() == 4
+ };
+
+for (0 .. 4) {
+ &{$foo[$_]}(4-$_);
+}
+
+test {
+ &{$foo[0]}() == 4 and
+ &{$foo[1]}() == 3 and
+ &{$foo[2]}() == 2 and
+ &{$foo[3]}() == 1 and
+ &{$foo[4]}() == 0
+ };
+
+sub barf {
+ my @foo;
+ for (qw(0 1 2 3 4)) {
+ my $i = $_;
+ $foo[$_] = sub {$i = shift if @_; $i };
+ }
+ @foo;
+}
+
+@foo = barf();
+test {
+ &{$foo[0]}() == 0 and
+ &{$foo[1]}() == 1 and
+ &{$foo[2]}() == 2 and
+ &{$foo[3]}() == 3 and
+ &{$foo[4]}() == 4
+ };
+
+for (0 .. 4) {
+ &{$foo[$_]}(4-$_);
+}
+
+test {
+ &{$foo[0]}() == 4 and
+ &{$foo[1]}() == 3 and
+ &{$foo[2]}() == 2 and
+ &{$foo[3]}() == 1 and
+ &{$foo[4]}() == 0
+ };
+
+# test if closures get created in optimized for loops
+
+my %foo;
+for my $n ('A'..'E') {
+ $foo{$n} = sub { $n eq $_[0] };
+}
+
+test {
+ &{$foo{A}}('A') and
+ &{$foo{B}}('B') and
+ &{$foo{C}}('C') and
+ &{$foo{D}}('D') and
+ &{$foo{E}}('E')
+};
+
+for my $n (0..4) {
+ $foo[$n] = sub { $n == $_[0] };
+}
+
+test {
+ &{$foo[0]}(0) and
+ &{$foo[1]}(1) and
+ &{$foo[2]}(2) and
+ &{$foo[3]}(3) and
+ &{$foo[4]}(4)
+};
+
+# Additional tests by Tom Phoenix <rootbeer@teleport.com>.
+
+{
+ use strict;
+
+ use vars qw!$test!;
+ my($debugging, %expected, $inner_type, $where_declared, $within);
+ my($nc_attempt, $call_outer, $call_inner, $undef_outer);
+ my($code, $inner_sub_test, $expected, $line, $errors, $output);
+ my(@inners, $sub_test, $pid);
+ $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';
+
+ # The expected values for these tests
+ %expected = (
+ 'global_scalar' => 1001,
+ 'global_array' => 2101,
+ 'global_hash' => 3004,
+ 'fs_scalar' => 4001,
+ 'fs_array' => 5101,
+ 'fs_hash' => 6004,
+ 'sub_scalar' => 7001,
+ 'sub_array' => 8101,
+ 'sub_hash' => 9004,
+ 'foreach' => 10011,
+ );
+
+ # Our innermost sub is either named or anonymous
+ for $inner_type (qw!named anon!) {
+ # And it may be declared at filescope, within a named
+ # sub, or within an anon sub
+ for $where_declared (qw!filescope in_named in_anon!) {
+ # And that, in turn, may be within a foreach loop,
+ # a naked block, or another named sub
+ for $within (qw!foreach naked other_sub!) {
+
+ # Here are a number of variables which show what's
+ # going on, in a way.
+ $nc_attempt = 0+ # Named closure attempted
+ ( ($inner_type eq 'named') ||
+ ($within eq 'other_sub') ) ;
+ $call_inner = 0+ # Need to call &inner
+ ( ($inner_type eq 'anon') &&
+ ($within eq 'other_sub') ) ;
+ $call_outer = 0+ # Need to call &outer or &$outer
+ ( ($inner_type eq 'anon') &&
+ ($within ne 'other_sub') ) ;
+ $undef_outer = 0+ # $outer is created but unused
+ ( ($where_declared eq 'in_anon') &&
+ (not $call_outer) ) ;
+
+ $code = "# This is a test script built by t/op/closure.t\n\n";
+
+ $code .= <<"DEBUG_INFO" if $debugging;
+# inner_type: $inner_type
+# where_declared: $where_declared
+# within: $within
+# nc_attempt: $nc_attempt
+# call_inner: $call_inner
+# call_outer: $call_outer
+# undef_outer: $undef_outer
+DEBUG_INFO
+
+ $code .= <<"END_MARK_ONE";
+
+BEGIN { \$SIG{__WARN__} = sub {
+ my \$msg = \$_[0];
+END_MARK_ONE
+
+ $code .= <<"END_MARK_TWO" if $nc_attempt;
+ return if index(\$msg, 'will not stay shared') != -1;
+ return if index(\$msg, 'may be unavailable') != -1;
+END_MARK_TWO
+
+ $code .= <<"END_MARK_THREE"; # Backwhack a lot!
+ print "not ok: got unexpected warning \$msg\\n";
+} }
+
+{
+ my \$test = $test;
+ sub test (&) {
+ my \$result = &{\$_[0]};
+ print "not " unless \$result;
+ print "ok \$test\\n";
+ \$test++;
+ }
+}
+
+# some of the variables which the closure will access
+\$global_scalar = 1000;
+\@global_array = (2000, 2100, 2200, 2300);
+%global_hash = 3000..3009;
+
+my \$fs_scalar = 4000;
+my \@fs_array = (5000, 5100, 5200, 5300);
+my %fs_hash = 6000..6009;
+
+END_MARK_THREE
+
+ if ($where_declared eq 'filescope') {
+ # Nothing here
+ } elsif ($where_declared eq 'in_named') {
+ $code .= <<'END';
+sub outer {
+ my $sub_scalar = 7000;
+ my @sub_array = (8000, 8100, 8200, 8300);
+ my %sub_hash = 9000..9009;
+END
+ # }
+ } elsif ($where_declared eq 'in_anon') {
+ $code .= <<'END';
+$outer = sub {
+ my $sub_scalar = 7000;
+ my @sub_array = (8000, 8100, 8200, 8300);
+ my %sub_hash = 9000..9009;
+END
+ # }
+ } else {
+ die "What was $where_declared?"
+ }
+
+ if ($within eq 'foreach') {
+ $code .= "
+ my \$foreach = 12000;
+ my \@list = (10000, 10010);
+ foreach \$foreach (\@list) {
+ " # }
+ } elsif ($within eq 'naked') {
+ $code .= " { # naked block\n" # }
+ } elsif ($within eq 'other_sub') {
+ $code .= " sub inner_sub {\n" # }
+ } else {
+ die "What was $within?"
+ }
+
+ $sub_test = $test;
+ @inners = ( qw!global_scalar global_array global_hash! ,
+ qw!fs_scalar fs_array fs_hash! );
+ push @inners, 'foreach' if $within eq 'foreach';
+ if ($where_declared ne 'filescope') {
+ push @inners, qw!sub_scalar sub_array sub_hash!;
+ }
+ for $inner_sub_test (@inners) {
+
+ if ($inner_type eq 'named') {
+ $code .= " sub named_$sub_test "
+ } elsif ($inner_type eq 'anon') {
+ $code .= " \$anon_$sub_test = sub "
+ } else {
+ die "What was $inner_type?"
+ }
+
+ # Now to write the body of the test sub
+ if ($inner_sub_test eq 'global_scalar') {
+ $code .= '{ ++$global_scalar }'
+ } elsif ($inner_sub_test eq 'fs_scalar') {
+ $code .= '{ ++$fs_scalar }'
+ } elsif ($inner_sub_test eq 'sub_scalar') {
+ $code .= '{ ++$sub_scalar }'
+ } elsif ($inner_sub_test eq 'global_array') {
+ $code .= '{ ++$global_array[1] }'
+ } elsif ($inner_sub_test eq 'fs_array') {
+ $code .= '{ ++$fs_array[1] }'
+ } elsif ($inner_sub_test eq 'sub_array') {
+ $code .= '{ ++$sub_array[1] }'
+ } elsif ($inner_sub_test eq 'global_hash') {
+ $code .= '{ ++$global_hash{3002} }'
+ } elsif ($inner_sub_test eq 'fs_hash') {
+ $code .= '{ ++$fs_hash{6002} }'
+ } elsif ($inner_sub_test eq 'sub_hash') {
+ $code .= '{ ++$sub_hash{9002} }'
+ } elsif ($inner_sub_test eq 'foreach') {
+ $code .= '{ ++$foreach }'
+ } else {
+ die "What was $inner_sub_test?"
+ }
+
+ # Close up
+ if ($inner_type eq 'anon') {
+ $code .= ';'
+ }
+ $code .= "\n";
+ $sub_test++; # sub name sequence number
+
+ } # End of foreach $inner_sub_test
+
+ # Close up $within block # {
+ $code .= " }\n\n";
+
+ # Close up $where_declared block
+ if ($where_declared eq 'in_named') { # {
+ $code .= "}\n\n";
+ } elsif ($where_declared eq 'in_anon') { # {
+ $code .= "};\n\n";
+ }
+
+ # We may need to do something with the sub we just made...
+ $code .= "undef \$outer;\n" if $undef_outer;
+ $code .= "&inner_sub;\n" if $call_inner;
+ if ($call_outer) {
+ if ($where_declared eq 'in_named') {
+ $code .= "&outer;\n\n";
+ } elsif ($where_declared eq 'in_anon') {
+ $code .= "&\$outer;\n\n"
+ }
+ }
+
+ # Now, we can actually prep to run the tests.
+ for $inner_sub_test (@inners) {
+ $expected = $expected{$inner_sub_test} or
+ die "expected $inner_sub_test missing";
+
+ # Named closures won't access the expected vars
+ if ( $nc_attempt and
+ substr($inner_sub_test, 0, 4) eq "sub_" ) {
+ $expected = 1;
+ }
+
+ # If you make a sub within a foreach loop,
+ # what happens if it tries to access the
+ # foreach index variable? If it's a named
+ # sub, it gets the var from "outside" the loop,
+ # but if it's anon, it gets the value to which
+ # the index variable is aliased.
+ #
+ # Of course, if the value was set only
+ # within another sub which was never called,
+ # the value has not been set yet.
+ #
+ if ($inner_sub_test eq 'foreach') {
+ if ($inner_type eq 'named') {
+ if ($call_outer || ($where_declared eq 'filescope')) {
+ $expected = 12001
+ } else {
+ $expected = 1
+ }
+ }
+ }
+
+ # Here's the test:
+ if ($inner_type eq 'anon') {
+ $code .= "test { &\$anon_$test == $expected };\n"
+ } else {
+ $code .= "test { &named_$test == $expected };\n"
+ }
+ $test++;
+ }
+
+ if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') {
+ # Fork off a new perl to run the tests.
+ # (This is so we can catch spurious warnings.)
+ $| = 1; print ""; $| = 0; # flush output before forking
+ pipe READ, WRITE or die "Can't make pipe: $!";
+ pipe READ2, WRITE2 or die "Can't make second pipe: $!";
+ die "Can't fork: $!" unless defined($pid = open PERL, "|-");
+ unless ($pid) {
+ # Child process here. We're going to send errors back
+ # through the extra pipe.
+ close READ;
+ close READ2;
+ open STDOUT, ">&WRITE" or die "Can't redirect STDOUT: $!";
+ open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
+ exec './perl', '-w', '-'
+ or die "Can't exec ./perl: $!";
+ } else {
+ # Parent process here.
+ close WRITE;
+ close WRITE2;
+ print PERL $code;
+ close PERL;
+ { local $/;
+ $output = join '', <READ>;
+ $errors = join '', <READ2>; }
+ close READ;
+ close READ2;
+ }
+ } else {
+ # No fork(). Do it the hard way.
+ my $cmdfile = "tcmd$$"; $cmdfile++ while -e $cmdfile;
+ my $errfile = "terr$$"; $errfile++ while -e $errfile;
+ my @tmpfiles = ($cmdfile, $errfile);
+ open CMD, ">$cmdfile"; print CMD $code; close CMD;
+ my $cmd = (($^O eq 'VMS') ? "MCR $^X"
+ : ($^O eq 'MSWin32') ? '.\perl'
+ : './perl');
+ $cmd .= " -w $cmdfile 2>$errfile";
+ if ($^O eq 'VMS' or $^O eq 'MSWin32') {
+ # Use pipe instead of system so we don't inherit STD* from
+ # this process, and then foul our pipe back to parent by
+ # redirecting output in the child.
+ open PERL,"$cmd |" or die "Can't open pipe: $!\n";
+ { local $/; $output = join '', <PERL> }
+ close PERL;
+ } else {
+ my $outfile = "tout$$"; $outfile++ while -e $outfile;
+ push @tmpfiles, $outfile;
+ system "$cmd >$outfile";
+ { local $/; open IN, $outfile; $output = <IN>; close IN }
+ }
+ if ($?) {
+ printf "not ok: exited with error code %04X\n", $?;
+ $debugging or do { 1 while unlink @tmpfiles };
+ exit;
+ }
+ { local $/; open IN, $errfile; $errors = <IN>; close IN }
+ 1 while unlink @tmpfiles;
+ }
+ print $output;
+ print STDERR $errors;
+ if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
+ my $lnum = 0;
+ for $line (split '\n', $code) {
+ printf "%3d: %s\n", ++$lnum, $line;
+ }
+ }
+ printf "not ok: exited with error code %04X\n", $? if $?;
+ print "-" x 30, "\n" if $debugging;
+
+ } # End of foreach $within
+ } # End of foreach $where_declared
+ } # End of foreach $inner_type
+
+}
+
diff --git a/contrib/perl5/t/op/cmp.t b/contrib/perl5/t/op/cmp.t
new file mode 100755
index 000000000000..4a7e68d44871
--- /dev/null
+++ b/contrib/perl5/t/op/cmp.t
@@ -0,0 +1,35 @@
+#!./perl
+
+@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1);
+
+$expect = ($#FOO+2) * ($#FOO+1);
+print "1..$expect\n";
+
+my $ok = 0;
+for my $i (0..$#FOO) {
+ for my $j ($i..$#FOO) {
+ $ok++;
+ my $cmp = $FOO[$i] <=> $FOO[$j];
+ if (!defined($cmp) ||
+ $cmp == -1 && $FOO[$i] < $FOO[$j] ||
+ $cmp == 0 && $FOO[$i] == $FOO[$j] ||
+ $cmp == 1 && $FOO[$i] > $FOO[$j])
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n";
+ }
+ $ok++;
+ $cmp = $FOO[$i] cmp $FOO[$j];
+ if ($cmp == -1 && $FOO[$i] lt $FOO[$j] ||
+ $cmp == 0 && $FOO[$i] eq $FOO[$j] ||
+ $cmp == 1 && $FOO[$i] gt $FOO[$j])
+ {
+ print "ok $ok\n";
+ }
+ else {
+ print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n";
+ }
+ }
+}
diff --git a/contrib/perl5/t/op/cond.t b/contrib/perl5/t/op/cond.t
new file mode 100755
index 000000000000..427efb48879c
--- /dev/null
+++ b/contrib/perl5/t/op/cond.t
@@ -0,0 +1,12 @@
+#!./perl
+
+# $RCSfile: cond.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:41 $
+
+print "1..4\n";
+
+print 1 ? "ok 1\n" : "not ok 1\n"; # compile time
+print 0 ? "not ok 2\n" : "ok 2\n";
+
+$x = 1;
+print $x ? "ok 3\n" : "not ok 3\n"; # run time
+print !$x ? "not ok 4\n" : "ok 4\n";
diff --git a/contrib/perl5/t/op/context.t b/contrib/perl5/t/op/context.t
new file mode 100755
index 000000000000..4625441efa74
--- /dev/null
+++ b/contrib/perl5/t/op/context.t
@@ -0,0 +1,18 @@
+#!./perl
+
+$n=0;
+
+print "1..3\n";
+
+sub foo {
+ $a='abcd';
+
+ $a=~/(.)/g;
+
+ $1 eq 'a' or print 'not ';
+ print "ok ",++$n,"\n";
+}
+
+$a=foo;
+@a=foo;
+foo;
diff --git a/contrib/perl5/t/op/defins.t b/contrib/perl5/t/op/defins.t
new file mode 100755
index 000000000000..33c74ea28e8d
--- /dev/null
+++ b/contrib/perl5/t/op/defins.t
@@ -0,0 +1,147 @@
+#!./perl -w
+
+#
+# test auto defined() test insertion
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $SIG{__WARN__} = sub { $warns++; warn $_[0] };
+ print "1..14\n";
+}
+
+$wanted_filename = $^O eq 'VMS' ? '0.' : '0';
+
+print "not " if $warns;
+print "ok 1\n";
+
+open(FILE,">./0");
+print FILE "1\n";
+print FILE "0";
+close(FILE);
+
+open(FILE,"<./0");
+my $seen = 0;
+my $dummy;
+while (my $name = <FILE>)
+ {
+ $seen++ if $name eq '0';
+ }
+print "not " unless $seen;
+print "ok 2\n";
+
+seek(FILE,0,0);
+$seen = 0;
+my $line = '';
+do
+ {
+ $seen++ if $line eq '0';
+ } while ($line = <FILE>);
+
+print "not " unless $seen;
+print "ok 3\n";
+
+
+seek(FILE,0,0);
+$seen = 0;
+while (($seen ? $dummy : $name) = <FILE>)
+ {
+ $seen++ if $name eq '0';
+ }
+print "not " unless $seen;
+print "ok 4\n";
+
+seek(FILE,0,0);
+$seen = 0;
+my %where;
+while ($where{$seen} = <FILE>)
+ {
+ $seen++ if $where{$seen} eq '0';
+ }
+print "not " unless $seen;
+print "ok 5\n";
+close FILE;
+
+opendir(DIR,'.');
+$seen = 0;
+while (my $name = readdir(DIR))
+ {
+ $seen++ if $name eq $wanted_filename;
+ }
+print "not " unless $seen;
+print "ok 6\n";
+
+rewinddir(DIR);
+$seen = 0;
+$dummy = '';
+while (($seen ? $dummy : $name) = readdir(DIR))
+ {
+ $seen++ if $name eq $wanted_filename;
+ }
+print "not " unless $seen;
+print "ok 7\n";
+
+rewinddir(DIR);
+$seen = 0;
+while ($where{$seen} = readdir(DIR))
+ {
+ $seen++ if $where{$seen} eq $wanted_filename;
+ }
+print "not " unless $seen;
+print "ok 8\n";
+
+$seen = 0;
+while (my $name = glob('*'))
+ {
+ $seen++ if $name eq $wanted_filename;
+ }
+print "not " unless $seen;
+print "ok 9\n";
+
+$seen = 0;
+$dummy = '';
+while (($seen ? $dummy : $name) = glob('*'))
+ {
+ $seen++ if $name eq $wanted_filename;
+ }
+print "not " unless $seen;
+print "ok 10\n";
+
+$seen = 0;
+while ($where{$seen} = glob('*'))
+ {
+ $seen++ if $where{$seen} eq $wanted_filename;
+ }
+print "not " unless $seen;
+print "ok 11\n";
+
+unlink("./0");
+
+my %hash = (0 => 1, 1 => 2);
+
+$seen = 0;
+while (my $name = each %hash)
+ {
+ $seen++ if $name eq '0';
+ }
+print "not " unless $seen;
+print "ok 12\n";
+
+$seen = 0;
+$dummy = '';
+while (($seen ? $dummy : $name) = each %hash)
+ {
+ $seen++ if $name eq '0';
+ }
+print "not " unless $seen;
+print "ok 13\n";
+
+$seen = 0;
+while ($where{$seen} = each %hash)
+ {
+ $seen++ if $where{$seen} eq '0';
+ }
+print "not " unless $seen;
+print "ok 14\n";
+
diff --git a/contrib/perl5/t/op/delete.t b/contrib/perl5/t/op/delete.t
new file mode 100755
index 000000000000..6cc447506ac9
--- /dev/null
+++ b/contrib/perl5/t/op/delete.t
@@ -0,0 +1,51 @@
+#!./perl
+
+# $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $
+
+print "1..16\n";
+
+$foo{1} = 'a';
+$foo{2} = 'b';
+$foo{3} = 'c';
+$foo{4} = 'd';
+$foo{5} = 'e';
+
+$foo = delete $foo{2};
+
+if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
+if ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";}
+if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";}
+if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";}
+if ($foo{4} eq 'd') {print "ok 5\n";} else {print "not ok 5\n";}
+if ($foo{5} eq 'e') {print "ok 6\n";} else {print "not ok 6\n";}
+
+@foo = delete @foo{4, 5};
+
+if (@foo == 2) {print "ok 7\n";} else {print "not ok 7 ", @foo+0, "\n";}
+if ($foo[0] eq 'd') {print "ok 8\n";} else {print "not ok 8 ", $foo[0], "\n";}
+if ($foo[1] eq 'e') {print "ok 9\n";} else {print "not ok 9 ", $foo[1], "\n";}
+if ($foo{4} eq '') {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";}
+if ($foo{5} eq '') {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";}
+if ($foo{1} eq 'a') {print "ok 12\n";} else {print "not ok 12\n";}
+if ($foo{3} eq 'c') {print "ok 13\n";} else {print "not ok 13\n";}
+
+$foo = join('',values(%foo));
+if ($foo eq 'ac' || $foo eq 'ca') {print "ok 14\n";} else {print "not ok 14\n";}
+
+foreach $key (keys %foo) {
+ delete $foo{$key};
+}
+
+$foo{'foo'} = 'x';
+$foo{'bar'} = 'y';
+
+$foo = join('',values(%foo));
+print +($foo eq 'xy' || $foo eq 'yx') ? "ok 15\n" : "not ok 15\n";
+
+$refhash{"top"}->{"foo"} = "FOO";
+$refhash{"top"}->{"bar"} = "BAR";
+
+delete $refhash{"top"}->{"bar"};
+@list = keys %{$refhash{"top"}};
+
+print "@list" eq "foo" ? "ok 16\n" : "not ok 16 @list\n";
diff --git a/contrib/perl5/t/op/die.t b/contrib/perl5/t/op/die.t
new file mode 100755
index 000000000000..d473ed6b7f71
--- /dev/null
+++ b/contrib/perl5/t/op/die.t
@@ -0,0 +1,43 @@
+#!./perl
+
+print "1..10\n";
+
+$SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ;
+
+$err = "ok 1\n";
+eval {
+ die $err;
+};
+
+print "not " unless $@ eq $err;
+print "ok 2\n";
+
+$x = [3];
+eval { die $x; };
+
+print "not " unless $x->[0] == 4;
+print "ok 4\n";
+
+eval {
+ eval {
+ die [ 5 ];
+ };
+ die if $@;
+};
+
+eval {
+ eval {
+ die bless [ 7 ], "Error";
+ };
+ die if $@;
+};
+
+print "not " unless ref($@) eq "Out";
+print "ok 10\n";
+
+package Error;
+
+sub PROPAGATE {
+ print "ok ",$_[0]->[0]++,"\n";
+ bless [$_[0]->[0]], "Out";
+}
diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t
new file mode 100755
index 000000000000..ffbb1e015e38
--- /dev/null
+++ b/contrib/perl5/t/op/die_exit.t
@@ -0,0 +1,53 @@
+#!./perl
+
+#
+# Verify that C<die> return the return code
+# -- Robin Barker <rmb@cise.npl.co.uk>
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -e '../lib';
+}
+my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl';
+
+use strict;
+
+my %tests = (
+ 1 => [ 0, 0],
+ 2 => [ 0, 1],
+ 3 => [ 0, 127],
+ 4 => [ 0, 128],
+ 5 => [ 0, 255],
+ 6 => [ 0, 256],
+ 7 => [ 0, 512],
+ 8 => [ 1, 0],
+ 9 => [ 1, 1],
+ 10 => [ 1, 256],
+ 11 => [ 128, 0],
+ 12 => [ 128, 1],
+ 13 => [ 128, 256],
+ 14 => [ 255, 0],
+ 15 => [ 255, 1],
+ 16 => [ 255, 256],
+ # see if implicit close preserves $?
+ 17 => [ 42, 42, '{ local *F; open F, q[TEST]; close F } die;'],
+);
+
+my $max = keys %tests;
+
+print "1..$max\n";
+
+foreach my $test (1 .. $max) {
+ my($bang, $query, $code) = @{$tests{$test}};
+ $code ||= 'die;';
+ my $exit =
+ ($^O eq 'MSWin32'
+ ? system qq($perl -e "\$! = $bang; \$? = $query; $code" 2> nul)
+ : system qq($perl -e '\$! = $bang; \$? = $query; $code' 2> /dev/null));
+
+ printf "# 0x%04x 0x%04x 0x%04x\nnot ", $exit, $bang, $query
+ unless $exit == (($bang || ($query >> 8) || 255) << 8);
+ print "ok $test\n";
+}
+
diff --git a/contrib/perl5/t/op/do.t b/contrib/perl5/t/op/do.t
new file mode 100755
index 000000000000..87ec08d3001c
--- /dev/null
+++ b/contrib/perl5/t/op/do.t
@@ -0,0 +1,44 @@
+#!./perl
+
+# $RCSfile: do.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:45 $
+
+sub foo1
+{
+ print $_[0];
+ 'value';
+}
+
+sub foo2
+{
+ shift;
+ print $_[0];
+ $x = 'value';
+ $x;
+}
+
+print "1..15\n";
+
+$_[0] = "not ok 1\n";
+$result = do foo1("ok 1\n");
+print "#2\t:$result: eq :value:\n";
+if ($result EQ 'value') { print "ok 2\n"; } else { print "not ok 2\n"; }
+if ($_[0] EQ "not ok 1\n") { print "ok 3\n"; } else { print "not ok 3\n"; }
+
+$_[0] = "not ok 4\n";
+$result = do foo2("not ok 4\n","ok 4\n","not ok 4\n");
+print "#5\t:$result: eq :value:\n";
+if ($result EQ 'value') { print "ok 5\n"; } else { print "not ok 5\n"; }
+if ($_[0] EQ "not ok 4\n") { print "ok 6\n"; } else { print "not ok 6\n"; }
+
+$result = do{print "ok 7\n"; 'value';};
+print "#8\t:$result: eq :value:\n";
+if ($result EQ 'value') { print "ok 8\n"; } else { print "not ok 8\n"; }
+
+sub blather {
+ print @_;
+}
+
+do blather("ok 9\n","ok 10\n");
+@x = ("ok 11\n", "ok 12\n");
+@y = ("ok 14\n", "ok 15\n");
+do blather(@x,"ok 13\n",@y);
diff --git a/contrib/perl5/t/op/each.t b/contrib/perl5/t/op/each.t
new file mode 100755
index 000000000000..9063c2c3ed8f
--- /dev/null
+++ b/contrib/perl5/t/op/each.t
@@ -0,0 +1,122 @@
+#!./perl
+
+# $RCSfile: each.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:47 $
+
+print "1..16\n";
+
+$h{'abc'} = 'ABC';
+$h{'def'} = 'DEF';
+$h{'jkl','mno'} = "JKL\034MNO";
+$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
+$h{'a'} = 'A';
+$h{'b'} = 'B';
+$h{'c'} = 'C';
+$h{'d'} = 'D';
+$h{'e'} = 'E';
+$h{'f'} = 'F';
+$h{'g'} = 'G';
+$h{'h'} = 'H';
+$h{'i'} = 'I';
+$h{'j'} = 'J';
+$h{'k'} = 'K';
+$h{'l'} = 'L';
+$h{'m'} = 'M';
+$h{'n'} = 'N';
+$h{'o'} = 'O';
+$h{'p'} = 'P';
+$h{'q'} = 'Q';
+$h{'r'} = 'R';
+$h{'s'} = 'S';
+$h{'t'} = 'T';
+$h{'u'} = 'U';
+$h{'v'} = 'V';
+$h{'w'} = 'W';
+$h{'x'} = 'X';
+$h{'y'} = 'Y';
+$h{'z'} = 'Z';
+
+@keys = keys %h;
+@values = values %h;
+
+if ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";}
+
+$i = 0; # stop -w complaints
+
+while (($key,$value) = each(%h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i]
+ && (('a' lt 'A' && $key lt $value) || $key gt $value)) {
+ $key =~ y/a-z/A-Z/;
+ $i++ if $key eq $value;
+ }
+}
+
+if ($i == 30) {print "ok 2\n";} else {print "not ok 2\n";}
+
+@keys = ('blurfl', keys(%h), 'dyick');
+if ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";}
+
+$size = ((split('/',scalar %h))[1]);
+keys %h = $size * 5;
+$newsize = ((split('/',scalar %h))[1]);
+if ($newsize == $size * 8) {print "ok 4\n";} else {print "not ok 4\n";}
+keys %h = 1;
+$size = ((split('/',scalar %h))[1]);
+if ($size == $newsize) {print "ok 5\n";} else {print "not ok 5\n";}
+%h = (1,1);
+$size = ((split('/',scalar %h))[1]);
+if ($size == $newsize) {print "ok 6\n";} else {print "not ok 6\n";}
+undef %h;
+%h = (1,1);
+$size = ((split('/',scalar %h))[1]);
+if ($size == 8) {print "ok 7\n";} else {print "not ok 7\n";}
+
+# test scalar each
+%hash = 1..20;
+$total = 0;
+$total += $key while $key = each %hash;
+print "# Scalar each is bad.\nnot " unless $total == 100;
+print "ok 8\n";
+
+for (1..3) { @foo = each %hash }
+keys %hash;
+$total = 0;
+$total += $key while $key = each %hash;
+print "# Scalar keys isn't resetting the iterator.\nnot " if $total != 100;
+print "ok 9\n";
+
+for (1..3) { @foo = each %hash }
+$total = 0;
+$total += $key while $key = each %hash;
+print "# Iterator of each isn't being maintained.\nnot " if $total == 100;
+print "ok 10\n";
+
+for (1..3) { @foo = each %hash }
+values %hash;
+$total = 0;
+$total += $key while $key = each %hash;
+print "# Scalar values isn't resetting the iterator.\nnot " if $total != 100;
+print "ok 11\n";
+
+$size = (split('/', scalar %hash))[1];
+keys(%hash) = $size / 2;
+print "not " if $size != (split('/', scalar %hash))[1];
+print "ok 12\n";
+keys(%hash) = $size + 100;
+print "not " if $size == (split('/', scalar %hash))[1];
+print "ok 13\n";
+
+print "not " if keys(%hash) != 10;
+print "ok 14\n";
+
+print keys(hash) != 10 ? "not ok 15\n" : "ok 15\n";
+
+$i = 0;
+%h = (a => A, b => B, c=> C, d => D, abc => ABC);
+@keys = keys(h);
+@values = values(h);
+while (($key, $value) = each(h)) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ $i++;
+ }
+}
+if ($i == 5) { print "ok 16\n" } else { print "not ok\n" }
diff --git a/contrib/perl5/t/op/eval.t b/contrib/perl5/t/op/eval.t
new file mode 100755
index 000000000000..9368281d5b66
--- /dev/null
+++ b/contrib/perl5/t/op/eval.t
@@ -0,0 +1,81 @@
+#!./perl
+
+# $RCSfile: eval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:48 $
+
+print "1..23\n";
+
+eval 'print "ok 1\n";';
+
+if ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
+
+eval "\$foo\n = # this is a comment\n'ok 3';";
+print $foo,"\n";
+
+eval "\$foo\n = # this is a comment\n'ok 4\n';";
+print $foo;
+
+print eval '
+$foo =;'; # this tests for a call through yyerror()
+if ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
+
+print eval '$foo = /'; # this tests for a call through fatal()
+if ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
+
+print eval '"ok 7\n";';
+
+# calculate a factorial with recursive evals
+
+$foo = 5;
+$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
+$ans = eval $fact;
+if ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
+
+$foo = 5;
+$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
+$ans = eval $fact;
+if ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
+
+open(try,'>Op.eval');
+print try 'print "ok 10\n"; unlink "Op.eval";',"\n";
+close try;
+
+do 'Op.eval'; print $@;
+
+# Test the singlequoted eval optimizer
+
+$i = 11;
+for (1..3) {
+ eval 'print "ok ", $i++, "\n"';
+}
+
+eval {
+ print "ok 14\n";
+ die "ok 16\n";
+ 1;
+} || print "ok 15\n$@";
+
+# check whether eval EXPR determines value of EXPR correctly
+
+{
+ my @a = qw(a b c d);
+ my @b = eval @a;
+ print "@b" eq '4' ? "ok 17\n" : "not ok 17\n";
+ print $@ ? "not ok 18\n" : "ok 18\n";
+
+ my $a = q[defined(wantarray) ? (wantarray ? ($b='A') : ($b='S')) : ($b='V')];
+ my $b;
+ @a = eval $a;
+ print "@a" eq 'A' ? "ok 19\n" : "# $b\nnot ok 19\n";
+ print $b eq 'A' ? "ok 20\n" : "# $b\nnot ok 20\n";
+ $_ = eval $a;
+ print $b eq 'S' ? "ok 21\n" : "# $b\nnot ok 21\n";
+ eval $a;
+ print $b eq 'V' ? "ok 22\n" : "# $b\nnot ok 22\n";
+
+ $b = 'wrong';
+ $x = sub {
+ my $b = "right";
+ print eval('"$b"') eq $b ? "ok 23\n" : "not ok 23\n";
+ };
+ &$x();
+}
diff --git a/contrib/perl5/t/op/exec.t b/contrib/perl5/t/op/exec.t
new file mode 100755
index 000000000000..098a455455dc
--- /dev/null
+++ b/contrib/perl5/t/op/exec.t
@@ -0,0 +1,35 @@
+#!./perl
+
+# $RCSfile: exec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:49 $
+
+$| = 1; # flush stdout
+
+if ($^O eq 'MSWin32') {
+ print "# exec is unsupported on Win32\n";
+ # XXX the system tests could be written to use ./perl and so work on Win32
+ print "1..0\n";
+ exit(0);
+}
+
+print "1..8\n";
+
+if ($^O ne 'os2') {
+ print "not ok 1\n" if system "echo ok \\1"; # shell interpreted
+}
+else {
+ print "ok 1 # skipped: bug/feature of pdksh\n"; # shell interpreted
+}
+print "not ok 2\n" if system "echo ok 2"; # split and directly called
+print "not ok 3\n" if system "echo", "ok", "3"; # directly called
+
+# these should probably be rewritten to match the examples in perlfunc.pod
+if (system "true") {print "not ok 4\n";} else {print "ok 4\n";}
+
+if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; }
+print "ok 5\n";
+
+if ((system "lskdfj") == 255 << 8) {print "ok 6\n";} else {print "not ok 6\n";}
+
+unless (exec "lskdjfalksdjfdjfkls") {print "ok 7\n";} else {print "not ok 7\n";}
+
+exec "echo","ok","8";
diff --git a/contrib/perl5/t/op/exp.t b/contrib/perl5/t/op/exp.t
new file mode 100755
index 000000000000..5efc9ba950f1
--- /dev/null
+++ b/contrib/perl5/t/op/exp.t
@@ -0,0 +1,27 @@
+#!./perl
+
+# $RCSfile: exp.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:50 $
+
+print "1..6\n";
+
+# compile time evaluation
+
+$s = sqrt(2);
+if (substr($s,0,5) eq '1.414') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$s = exp(1);
+if (substr($s,0,7) eq '2.71828') {print "ok 2\n";} else {print "not ok 2\n";}
+
+if (exp(log(1)) == 1) {print "ok 3\n";} else {print "not ok 3\n";}
+
+# run time evaluation
+
+$x1 = 1;
+$x2 = 2;
+$s = sqrt($x2);
+if (substr($s,0,5) eq '1.414') {print "ok 4\n";} else {print "not ok 4\n";}
+
+$s = exp($x1);
+if (substr($s,0,7) eq '2.71828') {print "ok 5\n";} else {print "not ok 5\n";}
+
+if (exp(log($x1)) == 1) {print "ok 6\n";} else {print "not ok 6\n";}
diff --git a/contrib/perl5/t/op/flip.t b/contrib/perl5/t/op/flip.t
new file mode 100755
index 000000000000..20167f3333b8
--- /dev/null
+++ b/contrib/perl5/t/op/flip.t
@@ -0,0 +1,29 @@
+#!./perl
+
+# $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $
+
+print "1..9\n";
+
+@a = (1,2,3,4,5,6,7,8,9,10,11,12);
+
+while ($_ = shift(@a)) {
+ if ($x = /4/../8/) { $z = $x; print "ok ", $x + 0, "\n"; }
+ $y .= /1/../2/;
+}
+
+if ($z eq '5E0') {print "ok 6\n";} else {print "not ok 6\n";}
+
+if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";}
+
+@a = ('a','b','c','d','e','f','g');
+
+open(of,'../Configure');
+while (<of>) {
+ (3 .. 5) && ($foo .= $_);
+}
+$x = ($foo =~ y/\n/\n/);
+
+if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";}
+
+$x = 3.14;
+if (($x...$x) eq "1") {print "ok 9\n";} else {print "not ok 9\n";}
diff --git a/contrib/perl5/t/op/fork.t b/contrib/perl5/t/op/fork.t
new file mode 100755
index 000000000000..9790ff0f8ce1
--- /dev/null
+++ b/contrib/perl5/t/op/fork.t
@@ -0,0 +1,26 @@
+#!./perl
+
+# $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ unless ($Config{'d_fork'}) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+$| = 1;
+print "1..2\n";
+
+if ($cid = fork) {
+ sleep 2;
+ if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";}
+}
+else {
+ $| = 1;
+ print "ok 1\n";
+ sleep 10;
+}
diff --git a/contrib/perl5/t/op/glob.t b/contrib/perl5/t/op/glob.t
new file mode 100755
index 000000000000..253e4a312fb2
--- /dev/null
+++ b/contrib/perl5/t/op/glob.t
@@ -0,0 +1,37 @@
+#!./perl
+
+# $RCSfile: glob.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:55 $
+
+print "1..6\n";
+
+@oops = @ops = <op/*>;
+
+if ($^O eq 'MSWin32') {
+ map { $files{lc($_)}++ } <op/*>;
+ map { delete $files{"op/$_"} } split /[\s\n]/, `cmd /c "dir /b /l op & dir /b /l /ah op 2>nul"`,
+}
+else {
+ map { $files{$_}++ } <op/*>;
+ map { delete $files{$_} } split /[\s\n]/, `echo op/*`;
+}
+if (keys %files) {
+ print "not ok 1\t(",join(' ', sort keys %files),"\n";
+} else { print "ok 1\n"; }
+
+print $/ eq "\n" ? "ok 2\n" : "not ok 2\n";
+
+while (<jskdfjskdfj* op/* jskdjfjkosvk*>) {
+ $not = "not " unless $_ eq shift @ops;
+ $not = "not at all " if $/ eq "\0";
+}
+print "${not}ok 3\n";
+
+print $/ eq "\n" ? "ok 4\n" : "not ok 4\n";
+
+# test the "glob" operator
+$_ = "op/*";
+@glops = glob $_;
+print "@glops" eq "@oops" ? "ok 5\n" : "not ok 5\n";
+
+@glops = glob;
+print "@glops" eq "@oops" ? "ok 6\n" : "not ok 6\n";
diff --git a/contrib/perl5/t/op/goto.t b/contrib/perl5/t/op/goto.t
new file mode 100755
index 000000000000..1b34acda3950
--- /dev/null
+++ b/contrib/perl5/t/op/goto.t
@@ -0,0 +1,90 @@
+#!./perl
+
+# $RCSfile: goto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:56 $
+
+# "This IS structured code. It's just randomly structured."
+
+print "1..9\n";
+
+while ($?) {
+ $foo = 1;
+ label1:
+ $foo = 2;
+ goto label2;
+} continue {
+ $foo = 0;
+ goto label4;
+ label3:
+ $foo = 4;
+ goto label4;
+}
+goto label1;
+
+$foo = 3;
+
+label2:
+print "#1\t:$foo: == 2\n";
+if ($foo == 2) {print "ok 1\n";} else {print "not ok 1\n";}
+goto label3;
+
+label4:
+print "#2\t:$foo: == 4\n";
+if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl';
+$x = `$PERL -e "goto foo;" 2>&1`;
+if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. -e "goto foo;"`; }
+
+if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";}
+
+sub foo {
+ goto bar;
+ print "not ok 4\n";
+ return;
+bar:
+ print "ok 4\n";
+}
+
+&foo;
+
+sub bar {
+ $x = 'bypass';
+ eval "goto $x";
+}
+
+&bar;
+exit;
+
+FINALE:
+print "ok 9\n";
+exit;
+
+bypass:
+print "ok 5\n";
+
+# Test autoloading mechanism.
+
+sub two {
+ ($pack, $file, $line) = caller; # Should indicate original call stats.
+ print "@_ $pack $file $line" eq "1 2 3 main $FILE $LINE"
+ ? "ok 7\n"
+ : "not ok 7\n";
+}
+
+sub one {
+ eval <<'END';
+ sub one { print "ok 6\n"; goto &two; print "not ok 6\n"; }
+END
+ goto &one;
+}
+
+$FILE = __FILE__;
+$LINE = __LINE__ + 1;
+&one(1,2,3);
+
+$wherever = NOWHERE;
+eval { goto $wherever };
+print $@ =~ /Can't find label NOWHERE/ ? "ok 8\n" : "not ok 8\n";
+
+$wherever = FINALE;
+goto $wherever;
diff --git a/contrib/perl5/t/op/goto_xs.t b/contrib/perl5/t/op/goto_xs.t
new file mode 100755
index 000000000000..a35575eb26a1
--- /dev/null
+++ b/contrib/perl5/t/op/goto_xs.t
@@ -0,0 +1,98 @@
+#!./perl
+# tests for "goto &sub"-ing into XSUBs
+
+# $RCSfile$$Revision$$Date$
+
+# Note: This only tests things that should *work*. At some point, it may
+# be worth while to write some failure tests for things that should
+# *break* (such as calls with wrong number of args). For now, I'm
+# guessing that if all of these work correctly, the bad ones will
+# break correctly as well.
+
+chdir 't' if -d 't';
+@INC = "../lib";
+$ENV{PERL5LIB} = "../lib";
+
+# turn warnings into fatal errors
+$SIG{__WARN__} = sub { die "WARNING: @_" } ;
+
+BEGIN { $| = 1; }
+eval 'require Fcntl'
+ or do { print "1..0\n# Fcntl unavailable, can't test XS goto.\n"; exit 0 };
+
+print "1..10\n";
+
+# We don't know what symbols are defined in platform X's system headers.
+# We don't even want to guess, because some platform out there will
+# likely do the unthinkable. However, Fcntl::constant("LOCK_SH",0)
+# should always return a value, even on platforms which don't define the
+# cpp symbol; Fcntl.xs says:
+# /* We support flock() on systems which don't have it, so
+# always supply the constants. */
+# If this ceases to be the case, we're in trouble. =)
+$VALID = 'LOCK_SH';
+
+### First, we check whether Fcntl::constant returns sane answers.
+# Fcntl::constant("LOCK_SH",0) should always succeed.
+
+$value = Fcntl::constant($VALID,0);
+print((!defined $value)
+ ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n"
+ : "ok 1\n");
+
+### OK, we're ready to do real tests.
+
+# test "goto &function_constant"
+sub goto_const { goto &Fcntl::constant; }
+
+$ret = goto_const($VALID,0);
+print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n");
+
+# test "goto &$function_package_and_name"
+$FNAME1 = 'Fcntl::constant';
+sub goto_name1 { goto &$FNAME1; }
+
+$ret = goto_name1($VALID,0);
+print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n");
+
+# test "goto &$function_package_and_name" again, with dirtier stack
+$ret = goto_name1($VALID,0);
+print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n");
+$ret = goto_name1($VALID,0);
+print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n");
+
+# test "goto &$function_name" from local package
+package Fcntl;
+$FNAME2 = 'constant';
+sub goto_name2 { goto &$FNAME2; }
+package main;
+
+$ret = Fcntl::goto_name2($VALID,0);
+print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n");
+
+# test "goto &$function_ref"
+$FREF = \&Fcntl::constant;
+sub goto_ref { goto &$FREF; }
+
+$ret = goto_ref($VALID,0);
+print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n");
+
+### tests where the args are not on stack but in GvAV(defgv) (ie, @_)
+
+# test "goto &function_constant" from a sub called without arglist
+sub call_goto_const { &goto_const; }
+
+$ret = call_goto_const($VALID,0);
+print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n");
+
+# test "goto &$function_package_and_name" from a sub called without arglist
+sub call_goto_name1 { &goto_name1; }
+
+$ret = call_goto_name1($VALID,0);
+print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n");
+
+# test "goto &$function_ref" from a sub called without arglist
+sub call_goto_ref { &goto_ref; }
+
+$ret = call_goto_ref($VALID,0);
+print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");
diff --git a/contrib/perl5/t/op/groups.t b/contrib/perl5/t/op/groups.t
new file mode 100755
index 000000000000..47aabe3d7b45
--- /dev/null
+++ b/contrib/perl5/t/op/groups.t
@@ -0,0 +1,50 @@
+#!./perl
+
+if (! -x ($groups = '/usr/ucb/groups') &&
+ ! -x ($groups = '/usr/bin/groups') &&
+ ! -x ($groups = '/bin/groups')
+) {
+ print "1..0\n";
+ exit 0;
+}
+
+print "1..2\n";
+
+$pwgid = $( + 0;
+($pwgnam) = getgrgid($pwgid);
+@basegroup{$pwgid,$pwgnam} = (1,1);
+
+$seen{$pwgid}++;
+
+for (split(' ', $()) {
+ next if $seen{$_}++;
+ ($group) = getgrgid($_);
+ if (defined $group) {
+ push(@gr, $group);
+ }
+ else {
+ push(@gr, $_);
+ }
+}
+
+$gr1 = join(' ', sort @gr);
+
+$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',`$groups`)));
+
+if ($gr1 eq $gr2) {
+ print "ok 1\n";
+}
+else {
+ print "#gr1 is <$gr1>\n";
+ print "#gr2 is <$gr2>\n";
+ print "not ok 1\n";
+}
+
+# multiple 0's indicate GROUPSTYPE is currently long but should be short
+
+if ($pwgid == 0 || $seen{0} < 2) {
+ print "ok 2\n";
+}
+else {
+ print "not ok 2 (groupstype should be type short, not long)\n";
+}
diff --git a/contrib/perl5/t/op/gv.t b/contrib/perl5/t/op/gv.t
new file mode 100755
index 000000000000..c253e4bd9d57
--- /dev/null
+++ b/contrib/perl5/t/op/gv.t
@@ -0,0 +1,98 @@
+#!./perl
+
+#
+# various typeglob tests
+#
+
+print "1..23\n";
+
+# type coersion on assignment
+$foo = 'foo';
+$bar = *main::foo;
+$bar = $foo;
+print ref(\$bar) eq 'SCALAR' ? "ok 1\n" : "not ok 1\n";
+$foo = *main::bar;
+
+# type coersion (not) on misc ops
+
+if ($foo) {
+ print ref(\$foo) eq 'GLOB' ? "ok 2\n" : "not ok 2\n";
+}
+
+unless ($foo =~ /abcd/) {
+ print ref(\$foo) eq 'GLOB' ? "ok 3\n" : "not ok 3\n";
+}
+
+if ($foo eq '*main::bar') {
+ print ref(\$foo) eq 'GLOB' ? "ok 4\n" : "not ok 4\n";
+}
+
+# type coersion on substitutions that match
+$a = *main::foo;
+$b = $a;
+$a =~ s/^X//;
+print ref(\$a) eq 'GLOB' ? "ok 5\n" : "not ok 5\n";
+$a =~ s/^\*//;
+print $a eq 'main::foo' ? "ok 6\n" : "not ok 6\n";
+print ref(\$b) eq 'GLOB' ? "ok 7\n" : "not ok 7\n";
+
+# typeglobs as lvalues
+substr($foo, 0, 1) = "XXX";
+print ref(\$foo) eq 'SCALAR' ? "ok 8\n" : "not ok 8\n";
+print $foo eq 'XXXmain::bar' ? "ok 9\n" : "not ok 9\n";
+
+# returning glob values
+sub foo {
+ local($bar) = *main::foo;
+ $foo = *main::bar;
+ return ($foo, $bar);
+}
+
+($fuu, $baa) = foo();
+if (defined $fuu) {
+ print ref(\$fuu) eq 'GLOB' ? "ok 10\n" : "not ok 10\n";
+}
+
+if (defined $baa) {
+ print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n";
+}
+
+# nested package globs
+# NOTE: It's probably OK if these semantics change, because the
+# fact that %X::Y:: is stored in %X:: isn't documented.
+# (I hope.)
+
+{ package Foo::Bar }
+print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n";
+print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n";
+
+# test undef operator clearing out entire glob
+$foo = 'stuff';
+@foo = qw(more stuff);
+%foo = qw(even more random stuff);
+undef *foo;
+print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n";
+
+# test warnings from assignment of undef to glob
+{
+ my $msg;
+ local $SIG{__WARN__} = sub { $msg = $_[0] };
+ local $^W = 1;
+ *foo = 'bar';
+ print $msg ? "not ok" : "ok", " 15\n";
+ *foo = undef;
+ print $msg ? "ok" : "not ok", " 16\n";
+}
+
+# test *glob{THING} syntax
+$x = "ok 17\n";
+@x = ("ok 18\n");
+%x = ("ok 19" => "\n");
+sub x { "ok 20\n" }
+print ${*x{SCALAR}}, @{*x{ARRAY}}, %{*x{HASH}}, &{*x{CODE}};
+*x = *STDOUT;
+print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 21\n" : "not ok 21\n";
+print {*x{IO}} "ok 22\n";
+print {*x{FILEHANDLE}} "ok 23\n";
+
+
diff --git a/contrib/perl5/t/op/hashwarn.t b/contrib/perl5/t/op/hashwarn.t
new file mode 100755
index 000000000000..6343a2a8d574
--- /dev/null
+++ b/contrib/perl5/t/op/hashwarn.t
@@ -0,0 +1,71 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+
+use vars qw{ @warnings };
+
+BEGIN {
+ $^W |= 1; # Insist upon warnings
+ # ...and save 'em as we go
+ $SIG{'__WARN__'} = sub { push @warnings, @_ };
+ $| = 1;
+ print "1..7\n";
+}
+
+END { print "not ok\n# Uncaught warnings:\n@warnings\n" if @warnings }
+
+sub test ($$;$) {
+ my($num, $bool, $diag) = @_;
+ if ($bool) {
+ print "ok $num\n";
+ return;
+ }
+ print "not ok $num\n";
+ return unless defined $diag;
+ $diag =~ s/\Z\n?/\n/; # unchomp
+ print map "# $num : $_", split m/^/m, $diag;
+}
+
+sub test_warning ($$$) {
+ my($num, $got, $expected) = @_;
+ my($pattern, $ok);
+ if (($pattern) = ($expected =~ m#^/(.+)/$#s) or
+ (undef, $pattern) = ($expected =~ m#^m([^\w\s])(.+)\1$#s)) {
+ # it's a regexp
+ $ok = ($got =~ /$pattern/);
+ test $num, $ok, "Expected pattern /$pattern/, got '$got'\n";
+ } else {
+ $ok = ($got eq $expected);
+ test $num, $ok, "Expected string '$expected', got '$got'\n";
+ }
+# print "# $num: $got\n";
+}
+
+my $odd_msg = '/^Odd number of elements in hash/';
+my $ref_msg = '/^Reference found where even-sized list expected/';
+
+{
+ my %hash = (1..3);
+ test_warning 1, shift @warnings, $odd_msg;
+
+ %hash = 1;
+ test_warning 2, shift @warnings, $odd_msg;
+
+ %hash = { 1..3 };
+ test_warning 3, shift @warnings, $odd_msg;
+ test_warning 4, shift @warnings, $ref_msg;
+
+ %hash = [ 1..3 ];
+ test_warning 5, shift @warnings, $ref_msg;
+
+ %hash = sub { print "ok" };
+ test_warning 6, shift @warnings, $odd_msg;
+
+ $_ = { 1..10 };
+ test 7, ! @warnings, "Unexpected warning";
+}
diff --git a/contrib/perl5/t/op/inc.t b/contrib/perl5/t/op/inc.t
new file mode 100755
index 000000000000..e5a2a921b3f9
--- /dev/null
+++ b/contrib/perl5/t/op/inc.t
@@ -0,0 +1,52 @@
+#!./perl
+
+
+# $RCSfile$
+
+print "1..6\n";
+
+# Verify that addition/subtraction properly upgrade to doubles.
+# These tests are only significant on machines with 32 bit longs,
+# and two's complement negation, but shouldn't fail anywhere.
+
+$a = 2147483647;
+$c=$a++;
+if ($a == 2147483648)
+ {print "ok 1\n"}
+else
+ {print "not ok 1\n";}
+
+$a = 2147483647;
+$c=++$a;
+if ($a == 2147483648)
+ {print "ok 2\n"}
+else
+ {print "not ok 2\n";}
+
+$a = 2147483647;
+$a=$a+1;
+if ($a == 2147483648)
+ {print "ok 3\n"}
+else
+ {print "not ok 3\n";}
+
+$a = -2147483648;
+$c=$a--;
+if ($a == -2147483649)
+ {print "ok 4\n"}
+else
+ {print "not ok 4\n";}
+
+$a = -2147483648;
+$c=--$a;
+if ($a == -2147483649)
+ {print "ok 5\n"}
+else
+ {print "not ok 5\n";}
+
+$a = -2147483648;
+$a=$a-1;
+if ($a == -2147483649)
+ {print "ok 6\n"}
+else
+ {print "not ok 6\n";}
diff --git a/contrib/perl5/t/op/index.t b/contrib/perl5/t/op/index.t
new file mode 100755
index 000000000000..0b08f0879d7e
--- /dev/null
+++ b/contrib/perl5/t/op/index.t
@@ -0,0 +1,42 @@
+#!./perl
+
+# $RCSfile: index.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:59 $
+
+print "1..20\n";
+
+
+$foo = 'Now is the time for all good men to come to the aid of their country.';
+
+$first = substr($foo,0,index($foo,'the'));
+print ($first eq "Now is " ? "ok 1\n" : "not ok 1\n");
+
+$last = substr($foo,rindex($foo,'the'),100);
+print ($last eq "their country." ? "ok 2\n" : "not ok 2\n");
+
+$last = substr($foo,index($foo,'Now'),2);
+print ($last eq "No" ? "ok 3\n" : "not ok 3\n");
+
+$last = substr($foo,rindex($foo,'Now'),2);
+print ($last eq "No" ? "ok 4\n" : "not ok 4\n");
+
+$last = substr($foo,index($foo,'.'),100);
+print ($last eq "." ? "ok 5\n" : "not ok 5\n");
+
+$last = substr($foo,rindex($foo,'.'),100);
+print ($last eq "." ? "ok 6\n" : "not ok 6\n");
+
+print index("ababa","a",-1) == 0 ? "ok 7\n" : "not ok 7\n";
+print index("ababa","a",0) == 0 ? "ok 8\n" : "not ok 8\n";
+print index("ababa","a",1) == 2 ? "ok 9\n" : "not ok 9\n";
+print index("ababa","a",2) == 2 ? "ok 10\n" : "not ok 10\n";
+print index("ababa","a",3) == 4 ? "ok 11\n" : "not ok 11\n";
+print index("ababa","a",4) == 4 ? "ok 12\n" : "not ok 12\n";
+print index("ababa","a",5) == -1 ? "ok 13\n" : "not ok 13\n";
+
+print rindex("ababa","a",-1) == -1 ? "ok 14\n" : "not ok 14\n";
+print rindex("ababa","a",0) == 0 ? "ok 15\n" : "not ok 15\n";
+print rindex("ababa","a",1) == 0 ? "ok 16\n" : "not ok 16\n";
+print rindex("ababa","a",2) == 2 ? "ok 17\n" : "not ok 17\n";
+print rindex("ababa","a",3) == 2 ? "ok 18\n" : "not ok 18\n";
+print rindex("ababa","a",4) == 4 ? "ok 19\n" : "not ok 19\n";
+print rindex("ababa","a",5) == 4 ? "ok 20\n" : "not ok 20\n";
diff --git a/contrib/perl5/t/op/int.t b/contrib/perl5/t/op/int.t
new file mode 100755
index 000000000000..eb060acd727c
--- /dev/null
+++ b/contrib/perl5/t/op/int.t
@@ -0,0 +1,17 @@
+#!./perl
+
+# $RCSfile: int.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:00 $
+
+print "1..4\n";
+
+# compile time evaluation
+
+if (int(1.234) == 1) {print "ok 1\n";} else {print "not ok 1\n";}
+
+if (int(-1.234) == -1) {print "ok 2\n";} else {print "not ok 2\n";}
+
+# run time evaluation
+
+$x = 1.234;
+if (int($x) == 1) {print "ok 3\n";} else {print "not ok 3\n";}
+if (int(-$x) == -1) {print "ok 4\n";} else {print "not ok 4\n";}
diff --git a/contrib/perl5/t/op/join.t b/contrib/perl5/t/op/join.t
new file mode 100755
index 000000000000..eec4611e625d
--- /dev/null
+++ b/contrib/perl5/t/op/join.t
@@ -0,0 +1,12 @@
+#!./perl
+
+# $RCSfile: join.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:01 $
+
+print "1..3\n";
+
+@x = (1, 2, 3);
+if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
+
+if (join('',1,2,3) eq '123') {print "ok 2\n";} else {print "not ok 2\n";}
+
+if (join(':',split(/ /,"1 2 3")) eq '1:2:3') {print "ok 3\n";} else {print "not ok 3\n";}
diff --git a/contrib/perl5/t/op/list.t b/contrib/perl5/t/op/list.t
new file mode 100755
index 000000000000..a4230b681b36
--- /dev/null
+++ b/contrib/perl5/t/op/list.t
@@ -0,0 +1,83 @@
+#!./perl
+
+# $RCSfile: list.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:02 $
+
+print "1..27\n";
+
+@foo = (1, 2, 3, 4);
+if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";}
+
+$_ = join(':',@foo);
+if ($_ eq '1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
+
+($a,$b,$c,$d) = (1,2,3,4);
+if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 3\n";} else {print "not ok 3\n";}
+
+($c,$b,$a) = split(/ /,"111 222 333");
+if ("$a;$b;$c" eq '333;222;111') {print "ok 4\n";} else {print "not ok 4\n";}
+
+($a,$b,$c) = ($c,$b,$a);
+if ("$a;$b;$c" eq '111;222;333') {print "ok 5\n";} else {print "not ok 5 $a;$b;$c\n";}
+
+($a, $b) = ($b, $a);
+if ("$a;$b;$c" eq '222;111;333') {print "ok 6\n";} else {print "not ok 6\n";}
+
+($a, $b[1], $c{2}, $d) = (1, 2, 3, 4);
+if ($a eq 1) {print "ok 7\n";} else {print "not ok 7\n";}
+if ($b[1] eq 2) {print "ok 8\n";} else {print "not ok 8\n";}
+if ($c{2} eq 3) {print "ok 9\n";} else {print "not ok 9\n";}
+if ($d eq 4) {print "ok 10\n";} else {print "not ok 10\n";}
+
+@foo = (1,2,3,4,5,6,7,8);
+($a, $b, $c, $d) = @foo;
+print "#11 $a;$b;$c;$d eq 1;2;3;4\n";
+if ("$a;$b;$c;$d" eq '1;2;3;4') {print "ok 11\n";} else {print "not ok 11\n";}
+
+@foo = @bar = (1);
+if (join(':',@foo,@bar) eq '1:1') {print "ok 12\n";} else {print "not ok 12\n";}
+
+@foo = ();
+@foo = 1+2+3;
+if (join(':',@foo) eq '6') {print "ok 13\n";} else {print "not ok 13\n";}
+
+for ($x = 0; $x < 3; $x++) {
+ ($a, $b, $c) =
+ $x == 0?
+ ('ok ', 14, "\n"):
+ $x == 1?
+ ('ok ', 15, "\n"):
+ # default
+ ('ok ', 16, "\n");
+
+ print $a,$b,$c;
+}
+
+@a = ($x == 12345 || (1,2,3));
+if (join('',@a) eq '123') {print "ok 17\n";} else {print "not ok 17\n";}
+
+@a = ($x == $x || (4,5,6));
+if (join('',@a) eq '1') {print "ok 18\n";} else {print "not ok 18\n";}
+
+if (join('',1,2,(3,4,5)) eq '12345'){print "ok 19\n";}else{print "not ok 19\n";}
+if (join('',(1,2,3,4,5)) eq '12345'){print "ok 20\n";}else{print "not ok 20\n";}
+if (join('',(1,2,3,4),5) eq '12345'){print "ok 21\n";}else{print "not ok 21\n";}
+if (join('',1,(2,3,4),5) eq '12345'){print "ok 22\n";}else{print "not ok 22\n";}
+if (join('',1,2,(3,4),5) eq '12345'){print "ok 23\n";}else{print "not ok 23\n";}
+if (join('',1,2,3,(4),5) eq '12345'){print "ok 24\n";}else{print "not ok 24\n";}
+
+for ($x = 0; $x < 3; $x++) {
+ ($a, $b, $c) = do {
+ if ($x == 0) {
+ ('ok ', 25, "\n");
+ }
+ elsif ($x == 1) {
+ ('ok ', 26, "\n");
+ }
+ else {
+ ('ok ', 27, "\n");
+ }
+ };
+
+ print $a,$b,$c;
+}
+
diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t
new file mode 100755
index 000000000000..2f674d103bfe
--- /dev/null
+++ b/contrib/perl5/t/op/local.t
@@ -0,0 +1,200 @@
+#!./perl
+
+# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $
+
+print "1..58\n";
+
+# XXX known to leak scalars
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
+
+sub foo {
+ local($a, $b) = @_;
+ local($c, $d);
+ $c = "ok 3\n";
+ $d = "ok 4\n";
+ { local($a,$c) = ("ok 9\n", "ok 10\n"); ($x, $y) = ($a, $c); }
+ print $a, $b;
+ $c . $d;
+}
+
+$a = "ok 5\n";
+$b = "ok 6\n";
+$c = "ok 7\n";
+$d = "ok 8\n";
+
+print &foo("ok 1\n","ok 2\n");
+
+print $a,$b,$c,$d,$x,$y;
+
+# same thing, only with arrays and associative arrays
+
+sub foo2 {
+ local($a, @b) = @_;
+ local(@c, %d);
+ @c = "ok 13\n";
+ $d{''} = "ok 14\n";
+ { local($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); }
+ print $a, @b;
+ $c[0] . $d{''};
+}
+
+$a = "ok 15\n";
+@b = "ok 16\n";
+@c = "ok 17\n";
+$d{''} = "ok 18\n";
+
+print &foo2("ok 11\n","ok 12\n");
+
+print $a,@b,@c,%d,$x,$y;
+
+eval 'local($$e)';
+print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 21\n";
+
+eval 'local(@$e)';
+print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n";
+
+eval 'local(%$e)';
+print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n";
+
+# Array and hash elements
+
+@a = ('a', 'b', 'c');
+{
+ local($a[1]) = 'foo';
+ local($a[2]) = $a[2];
+ print +($a[1] eq 'foo') ? "" : "not ", "ok 24\n";
+ print +($a[2] eq 'c') ? "" : "not ", "ok 25\n";
+ undef @a;
+}
+print +($a[1] eq 'b') ? "" : "not ", "ok 26\n";
+print +($a[2] eq 'c') ? "" : "not ", "ok 27\n";
+print +(!defined $a[0]) ? "" : "not ", "ok 28\n";
+
+@a = ('a', 'b', 'c');
+{
+ local($a[1]) = "X";
+ shift @a;
+}
+print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 29\n";
+
+%h = ('a' => 1, 'b' => 2, 'c' => 3);
+{
+ local($h{'a'}) = 'foo';
+ local($h{'b'}) = $h{'b'};
+ print +($h{'a'} eq 'foo') ? "" : "not ", "ok 30\n";
+ print +($h{'b'} == 2) ? "" : "not ", "ok 31\n";
+ local($h{'c'});
+ delete $h{'c'};
+}
+print +($h{'a'} == 1) ? "" : "not ", "ok 32\n";
+print +($h{'b'} == 2) ? "" : "not ", "ok 33\n";
+print +($h{'c'} == 3) ? "" : "not ", "ok 34\n";
+
+# check for scope leakage
+$a = 'outer';
+if (1) { local $a = 'inner' }
+print +($a eq 'outer') ? "" : "not ", "ok 35\n";
+
+# see if localization works when scope unwinds
+local $m = 5;
+eval {
+ for $m (6) {
+ local $m = 7;
+ die "bye";
+ }
+};
+print $m == 5 ? "" : "not ", "ok 36\n";
+
+# see if localization works on tied arrays
+{
+ package TA;
+ sub TIEARRAY { bless [], $_[0] }
+ sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] }
+ sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v }
+ sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); }
+ sub FETCHSIZE { scalar(@{$_[0]}) }
+ sub SHIFT { shift (@{$_[0]}) }
+ sub EXTEND {}
+}
+
+tie @a, 'TA';
+@a = ('a', 'b', 'c');
+{
+ local($a[1]) = 'foo';
+ local($a[2]) = $a[2];
+ print +($a[1] eq 'foo') ? "" : "not ", "ok 37\n";
+ print +($a[2] eq 'c') ? "" : "not ", "ok 38\n";
+ @a = ();
+}
+print +($a[1] eq 'b') ? "" : "not ", "ok 39\n";
+print +($a[2] eq 'c') ? "" : "not ", "ok 40\n";
+print +(!defined $a[0]) ? "" : "not ", "ok 41\n";
+
+{
+ package TH;
+ sub TIEHASH { bless {}, $_[0] }
+ sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] }
+ sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v }
+ sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; }
+ sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); }
+}
+
+# see if localization works on tied hashes
+tie %h, 'TH';
+%h = ('a' => 1, 'b' => 2, 'c' => 3);
+
+{
+ local($h{'a'}) = 'foo';
+ local($h{'b'}) = $h{'b'};
+ print +($h{'a'} eq 'foo') ? "" : "not ", "ok 42\n";
+ print +($h{'b'} == 2) ? "" : "not ", "ok 43\n";
+ local($h{'c'});
+ delete $h{'c'};
+}
+print +($h{'a'} == 1) ? "" : "not ", "ok 44\n";
+print +($h{'b'} == 2) ? "" : "not ", "ok 45\n";
+print +($h{'c'} == 3) ? "" : "not ", "ok 46\n";
+
+@a = ('a', 'b', 'c');
+{
+ local($a[1]) = "X";
+ shift @a;
+}
+print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 47\n";
+
+# now try the same for %SIG
+
+$SIG{TERM} = 'foo';
+$SIG{INT} = \&foo;
+$SIG{__WARN__} = $SIG{INT};
+{
+ local($SIG{TERM}) = $SIG{TERM};
+ local($SIG{INT}) = $SIG{INT};
+ local($SIG{__WARN__}) = $SIG{__WARN__};
+ print +($SIG{TERM} eq 'main::foo') ? "" : "not ", "ok 48\n";
+ print +($SIG{INT} eq \&foo) ? "" : "not ", "ok 49\n";
+ print +($SIG{__WARN__} eq \&foo) ? "" : "not ", "ok 50\n";
+ local($SIG{INT});
+ delete $SIG{__WARN__};
+}
+print +($SIG{TERM} eq 'main::foo') ? "" : "not ", "ok 51\n";
+print +($SIG{INT} eq \&foo) ? "" : "not ", "ok 52\n";
+print +($SIG{__WARN__} eq \&foo) ? "" : "not ", "ok 53\n";
+
+# and for %ENV
+
+$ENV{_X_} = 'a';
+$ENV{_Y_} = 'b';
+$ENV{_Z_} = 'c';
+{
+ local($ENV{_X_}) = 'foo';
+ local($ENV{_Y_}) = $ENV{_Y_};
+ print +($ENV{_X_} eq 'foo') ? "" : "not ", "ok 54\n";
+ print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 55\n";
+ local($ENV{_Z_});
+ delete $ENV{_Z_};
+}
+print +($ENV{_X_} eq 'a') ? "" : "not ", "ok 56\n";
+print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 57\n";
+print +($ENV{_Z_} eq 'c') ? "" : "not ", "ok 58\n";
+
diff --git a/contrib/perl5/t/op/magic.t b/contrib/perl5/t/op/magic.t
new file mode 100755
index 000000000000..7f08e06f8518
--- /dev/null
+++ b/contrib/perl5/t/op/magic.t
@@ -0,0 +1,209 @@
+#!./perl
+
+BEGIN {
+ $^W = 1;
+ $| = 1;
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
+}
+
+sub ok {
+ my ($n, $result, $info) = @_;
+ if ($result) {
+ print "ok $n\n";
+ }
+ else {
+ print "not ok $n\n";
+ print "# $info\n" if $info;
+ }
+}
+
+$Is_MSWin32 = $^O eq 'MSWin32';
+$Is_VMS = $^O eq 'VMS';
+$Is_Dos = $^O eq 'dos';
+$PERL = ($Is_MSWin32 ? '.\perl' : './perl');
+
+print "1..35\n";
+
+eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval
+if ($Is_MSWin32) { ok 1, `cmd /x /c set FOO` eq "FOO=hi there\n"; }
+else { ok 1, `echo \$FOO` eq "hi there\n"; }
+
+unlink 'ajslkdfpqjsjfk';
+$! = 0;
+open(FOO,'ajslkdfpqjsjfk');
+ok 2, $!, $!;
+close FOO; # just mention it, squelch used-only-once
+
+if ($Is_MSWin32 || $Is_Dos) {
+ ok "3 # skipped",1;
+ ok "4 # skipped",1;
+}
+else {
+ # the next tests are embedded inside system simply because sh spits out
+ # a newline onto stderr when a child process kills itself with SIGINT.
+ system './perl', '-e', <<'END';
+
+ $| = 1; # command buffering
+
+ $SIG{"INT"} = "ok3"; kill "INT",$$; sleep 1;
+ $SIG{"INT"} = "IGNORE"; kill "INT",$$; sleep 1; print "ok 4\n";
+ $SIG{"INT"} = "DEFAULT"; kill "INT",$$; sleep 1; print "not ok\n";
+
+ sub ok3 {
+ if (($x = pop(@_)) eq "INT") {
+ print "ok 3\n";
+ }
+ else {
+ print "not ok 3 ($x @_)\n";
+ }
+ }
+
+END
+}
+
+# can we slice ENV?
+@val1 = @ENV{keys(%ENV)};
+@val2 = values(%ENV);
+ok 5, join(':',@val1) eq join(':',@val2);
+ok 6, @val1 > 1;
+
+# regex vars
+'foobarbaz' =~ /b(a)r/;
+ok 7, $` eq 'foo', $`;
+ok 8, $& eq 'bar', $&;
+ok 9, $' eq 'baz', $';
+ok 10, $+ eq 'a', $+;
+
+# $"
+@a = qw(foo bar baz);
+ok 11, "@a" eq "foo bar baz", "@a";
+{
+ local $" = ',';
+ ok 12, "@a" eq "foo,bar,baz", "@a";
+}
+
+# $;
+%h = ();
+$h{'foo', 'bar'} = 1;
+ok 13, (keys %h)[0] eq "foo\034bar", (keys %h)[0];
+{
+ local $; = 'x';
+ %h = ();
+ $h{'foo', 'bar'} = 1;
+ ok 14, (keys %h)[0] eq 'fooxbar', (keys %h)[0];
+}
+
+# $?, $@, $$
+system qq[$PERL -e "exit(0)"];
+ok 15, $? == 0, $?;
+system qq[$PERL -e "exit(1)"];
+ok 16, $? != 0, $?;
+
+eval { die "foo\n" };
+ok 17, $@ eq "foo\n", $@;
+
+ok 18, $$ > 0, $$;
+
+# $^X and $0
+{
+ if ($^O eq 'qnx') {
+ chomp($wd = `/usr/bin/fullpath -t`);
+ }
+ else {
+ $wd = '.';
+ }
+ my $perl = "$wd/perl";
+ my $headmaybe = '';
+ my $tailmaybe = '';
+ $script = "$wd/show-shebang";
+ if ($Is_MSWin32) {
+ chomp($wd = `cd`);
+ $perl = "$wd\\perl.exe";
+ $script = "$wd\\show-shebang.bat";
+ $headmaybe = <<EOH ;
+\@rem ='
+\@echo off
+$perl -x \%0
+goto endofperl
+\@rem ';
+EOH
+ $tailmaybe = <<EOT ;
+
+__END__
+:endofperl
+EOT
+ }
+ if ($^O eq 'os390') { # no shebang
+ $headmaybe = <<EOH ;
+ eval 'exec ./perl -S \$0 \${1+"\$\@"}'
+ if 0;
+EOH
+ }
+ $s1 = $s2 = "\$^X is $perl, \$0 is $script\n";
+ ok 19, open(SCRIPT, ">$script"), $!;
+ ok 20, print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!;
+#!$wd/perl
+EOB
+print "\$^X is $^X, \$0 is $0\n";
+EOF
+ ok 21, close(SCRIPT), $!;
+ ok 22, chmod(0755, $script), $!;
+ $_ = `$script`;
+ s/.exe//i if $Is_Dos;
+ s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl
+ s{is perl}{is $perl}; # for systems where $^X is only a basename
+ ok 23, ($Is_MSWin32 ? uc($_) eq uc($s2) : $_ eq $s2), ":$_:!=:$s2:";
+ $_ = `$perl $script`;
+ s/.exe//i if $Is_Dos;
+ ok 24, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1: after `$perl $script`";
+ ok 25, unlink($script), $!;
+}
+
+# $], $^O, $^T
+ok 26, $] >= 5.00319, $];
+ok 27, $^O;
+ok 28, $^T > 850000000, $^T;
+
+if ($Is_VMS || $Is_Dos) {
+ ok "29 # skipped", 1;
+ ok "30 # skipped", 1;
+}
+else {
+ $PATH = $ENV{PATH};
+ $ENV{foo} = "bar";
+ %ENV = ();
+ $ENV{PATH} = $PATH;
+ ok 29, ($Is_MSWin32 ? (`cmd /x /c set foo 2>NUL` eq "")
+ : (`echo \$foo` eq "\n") );
+
+ $ENV{NoNeSuCh} = "foo";
+ $0 = "bar";
+ ok 30, ($Is_MSWin32 ? (`cmd /x /c set NoNeSuCh` eq "NoNeSuCh=foo\n")
+ : (`echo \$NoNeSuCh` eq "foo\n") );
+}
+
+{
+ local $SIG{'__WARN__'} = sub { print "not " };
+ $! = undef;
+ print "ok 31\n";
+}
+
+# test case-insignificance of %ENV (these tests must be enabled only
+# when perl is compiled with -DENV_IS_CASELESS)
+if ($Is_MSWin32) {
+ %ENV = ();
+ $ENV{'Foo'} = 'bar';
+ $ENV{'fOo'} = 'baz';
+ ok 32, (scalar(keys(%ENV)) == 1);
+ ok 33, exists($ENV{'FOo'});
+ ok 34, (delete($ENV{'foO'}) eq 'baz');
+ ok 35, (scalar(keys(%ENV)) == 0);
+}
+else {
+ ok "32 # skipped",1;
+ ok "33 # skipped",1;
+ ok "34 # skipped",1;
+ ok "35 # skipped",1;
+}
diff --git a/contrib/perl5/t/op/method.t b/contrib/perl5/t/op/method.t
new file mode 100755
index 000000000000..f1b1888ef649
--- /dev/null
+++ b/contrib/perl5/t/op/method.t
@@ -0,0 +1,128 @@
+#!./perl
+
+#
+# test method calls and autoloading.
+#
+
+print "1..26\n";
+
+@A::ISA = 'B';
+@B::ISA = 'C';
+
+sub C::d {"C::d"}
+sub D::d {"D::d"}
+
+my $cnt = 0;
+sub test {
+ print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1];
+ # print "not " unless shift eq shift;
+ print "ok ", ++$cnt, "\n"
+}
+
+test( A->d, "C::d"); # Update hash table;
+
+*B::d = \&D::d; # Import now.
+test (A->d, "D::d"); # Update hash table;
+
+{
+ local @A::ISA = qw(C); # Update hash table with split() assignment
+ test (A->d, "C::d");
+ $#A::ISA = -1;
+ test (eval { A->d } || "fail", "fail");
+}
+test (A->d, "D::d");
+
+{
+ local *B::d;
+ eval 'sub B::d {"B::d1"}'; # Import now.
+ test (A->d, "B::d1"); # Update hash table;
+ undef &B::d;
+ test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1);
+}
+
+test (A->d, "D::d"); # Back to previous state
+
+eval 'sub B::d {"B::d2"}'; # Import now.
+test (A->d, "B::d2"); # Update hash table;
+
+# What follows is hardly guarantied to work, since the names in scripts
+# are already linked to "pruned" globs. Say, `undef &B::d' if it were
+# after `delete $B::{d}; sub B::d {}' would reach an old subroutine.
+
+undef &B::d;
+delete $B::{d};
+test (A->d, "C::d"); # Update hash table;
+
+eval 'sub B::d {"B::d3"}'; # Import now.
+test (A->d, "B::d3"); # Update hash table;
+
+delete $B::{d};
+*dummy::dummy = sub {}; # Mark as updated
+test (A->d, "C::d");
+
+eval 'sub B::d {"B::d4"}'; # Import now.
+test (A->d, "B::d4"); # Update hash table;
+
+delete $B::{d}; # Should work without any help too
+test (A->d, "C::d");
+
+{
+ local *C::d;
+ test (eval { A->d } || "nope", "nope");
+}
+test (A->d, "C::d");
+
+*A::x = *A::d; # See if cache incorrectly follows synonyms
+A->d;
+test (eval { A->x } || "nope", "nope");
+
+eval <<'EOF';
+sub C::e;
+BEGIN { *B::e = \&C::e } # Shouldn't prevent AUTOLOAD in original pkg
+sub Y::f;
+$counter = 0;
+
+@X::ISA = 'Y';
+@Y::ISA = 'B';
+
+sub B::AUTOLOAD {
+ my $c = ++$counter;
+ my $method = $B::AUTOLOAD;
+ my $msg = "B: In $method, $c";
+ eval "sub $method { \$msg }";
+ goto &$method;
+}
+sub C::AUTOLOAD {
+ my $c = ++$counter;
+ my $method = $C::AUTOLOAD;
+ my $msg = "C: In $method, $c";
+ eval "sub $method { \$msg }";
+ goto &$method;
+}
+EOF
+
+test(A->e(), "C: In C::e, 1"); # We get a correct autoload
+test(A->e(), "C: In C::e, 1"); # Which sticks
+
+test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top
+test(A->ee(), "B: In A::ee, 2"); # Which sticks
+
+test(Y->f(), "B: In Y::f, 3"); # We vivify a correct method
+test(Y->f(), "B: In Y::f, 3"); # Which sticks
+
+# This test is not intended to be reasonable. It is here just to let you
+# know that you broke some old construction. Feel free to rewrite the test
+# if your patch breaks it.
+
+*B::AUTOLOAD = sub {
+ my $c = ++$counter;
+ my $method = $AUTOLOAD;
+ *$AUTOLOAD = sub { "new B: In $method, $c" };
+ goto &$AUTOLOAD;
+};
+
+test(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload
+test(A->eee(), "new B: In A::eee, 4"); # Which sticks
+
+# this test added due to bug discovery
+test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");
diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t
new file mode 100755
index 000000000000..7292ffebd493
--- /dev/null
+++ b/contrib/perl5/t/op/misc.t
@@ -0,0 +1,420 @@
+#!./perl
+
+# NOTE: Please don't add tests to this file unless they *need* to be run in
+# separate executable and can't simply use eval.
+
+chdir 't' if -d 't';
+@INC = "../lib";
+$ENV{PERL5LIB} = "../lib";
+
+$|=1;
+
+undef $/;
+@prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+$tmpfile = "misctmp000";
+1 while -f ++$tmpfile;
+END { unlink $tmpfile if $tmpfile; }
+
+$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat');
+
+for (@prgs){
+ my $switch;
+ if (s/^\s*(-\w.*)//){
+ $switch = $1;
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ if ($^O eq 'MSWin32') {
+ open TEST, "| .\\perl -I../lib $switch >$tmpfile 2>&1";
+ }
+ else {
+ open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1";
+ }
+ print TEST $prog, "\n";
+ close TEST;
+ $status = $?;
+ $results = `$CAT $tmpfile`;
+ $results =~ s/\n+$//;
+ $results =~ s/syntax error/syntax error/i;
+ $expected =~ s/\n+$//;
+ if ( $results ne $expected){
+ print STDERR "PROG: $switch\n$prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+}
+
+__END__
+()=()
+########
+$a = ":="; split /($a)/o, "a:=b:=c"; print "@_"
+EXPECT
+a := b := c
+########
+$cusp = ~0 ^ (~0 >> 1);
+$, = " ";
+print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n";
+EXPECT
+7 0 0 1 !
+########
+$foo=undef; $foo->go;
+EXPECT
+Can't call method "go" on an undefined value at - line 1.
+########
+BEGIN
+ {
+ "foo";
+ }
+########
+$array[128]=1
+########
+$x=0x0eabcd; print $x->ref;
+EXPECT
+Can't call method "ref" without a package or object reference at - line 1.
+########
+chop ($str .= <STDIN>);
+########
+close ($banana);
+########
+$x=2;$y=3;$x<$y ? $x : $y += 23;print $x;
+EXPECT
+25
+########
+eval {sub bar {print "In bar";}}
+########
+system './perl -ne "print if eof" /dev/null'
+########
+chop($file = <>);
+########
+package N;
+sub new {my ($obj,$n)=@_; bless \$n}
+$aa=new N 1;
+$aa=12345;
+print $aa;
+EXPECT
+12345
+########
+%@x=0;
+EXPECT
+Can't modify hash deref in repeat at - line 1, near "0;"
+Execution of - aborted due to compilation errors.
+########
+$_="foo";
+printf(STDOUT "%s\n", $_);
+EXPECT
+foo
+########
+push(@a, 1, 2, 3,)
+########
+quotemeta ""
+########
+for ("ABCDE") {
+ &sub;
+s/./&sub($&)/eg;
+print;}
+sub sub {local($_) = @_;
+$_ x 4;}
+EXPECT
+Modification of a read-only value attempted at - line 3.
+########
+package FOO;sub new {bless {FOO => BAR}};
+package main;
+use strict vars;
+my $self = new FOO;
+print $$self{FOO};
+EXPECT
+BAR
+########
+$_="foo";
+s/.{1}//s;
+print;
+EXPECT
+oo
+########
+print scalar ("foo","bar")
+EXPECT
+bar
+########
+sub by_number { $a <=> $b; };# inline function for sort below
+$as_ary{0}="a0";
+@ordered_array=sort by_number keys(%as_ary);
+########
+sub NewShell
+{
+ local($Host) = @_;
+ my($m2) = $#Shells++;
+ $Shells[$m2]{HOST} = $Host;
+ return $m2;
+}
+
+sub ShowShell
+{
+ local($i) = @_;
+}
+
+&ShowShell(&NewShell(beach,Work,"+0+0"));
+&ShowShell(&NewShell(beach,Work,"+0+0"));
+&ShowShell(&NewShell(beach,Work,"+0+0"));
+########
+ {
+ package FAKEARRAY;
+
+ sub TIEARRAY
+ { print "TIEARRAY @_\n";
+ die "bomb out\n" unless $count ++ ;
+ bless ['foo']
+ }
+ sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] }
+ sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] }
+ sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; }
+ }
+
+eval 'tie @h, FAKEARRAY, fred' ;
+tie @h, FAKEARRAY, fred ;
+EXPECT
+TIEARRAY FAKEARRAY fred
+TIEARRAY FAKEARRAY fred
+DESTROY
+########
+BEGIN { die "phooey\n" }
+EXPECT
+phooey
+BEGIN failed--compilation aborted at - line 1.
+########
+BEGIN { 1/$zero }
+EXPECT
+Illegal division by zero at - line 1.
+BEGIN failed--compilation aborted at - line 1.
+########
+BEGIN { undef = 0 }
+EXPECT
+Modification of a read-only value attempted at - line 1.
+BEGIN failed--compilation aborted at - line 1.
+########
+{
+ package foo;
+ sub PRINT {
+ shift;
+ print join(' ', reverse @_)."\n";
+ }
+ sub PRINTF {
+ shift;
+ my $fmt = shift;
+ print sprintf($fmt, @_)."\n";
+ }
+ sub TIEHANDLE {
+ bless {}, shift;
+ }
+ sub READLINE {
+ "Out of inspiration";
+ }
+ sub DESTROY {
+ print "and destroyed as well\n";
+ }
+ sub READ {
+ shift;
+ print STDOUT "foo->can(READ)(@_)\n";
+ return 100;
+ }
+ sub GETC {
+ shift;
+ print STDOUT "Don't GETC, Get Perl\n";
+ return "a";
+ }
+}
+{
+ local(*FOO);
+ tie(*FOO,'foo');
+ print FOO "sentence.", "reversed", "a", "is", "This";
+ print "-- ", <FOO>, " --\n";
+ my($buf,$len,$offset);
+ $buf = "string";
+ $len = 10; $offset = 1;
+ read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed";
+ getc(FOO) eq "a" or die "foo->GETC failed";
+ printf "%s is number %d\n", "Perl", 1;
+}
+EXPECT
+This is a reversed sentence.
+-- Out of inspiration --
+foo->can(READ)(string 10 1)
+Don't GETC, Get Perl
+Perl is number 1
+and destroyed as well
+########
+my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
+EXPECT
+2 2 2
+########
+@a = ($a, $b, $c, $d) = (5, 6);
+print "ok\n"
+ if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
+EXPECT
+ok
+########
+print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000);
+EXPECT
+ok
+########
+print "ok\n" if ("\0" lt "\xFF");
+EXPECT
+ok
+########
+open(H,'op/misc.t'); # must be in the 't' directory
+stat(H);
+print "ok\n" if (-e _ and -f _ and -r _);
+EXPECT
+ok
+########
+sub thing { 0 || return qw(now is the time) }
+print thing(), "\n";
+EXPECT
+nowisthetime
+########
+$ren = 'joy';
+$stimpy = 'happy';
+{ local $main::{ren} = *stimpy; print $ren, ' ' }
+print $ren, "\n";
+EXPECT
+happy joy
+########
+$stimpy = 'happy';
+{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' }
+print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n";
+EXPECT
+happy joy
+########
+package p;
+sub func { print 'really ' unless wantarray; 'p' }
+sub groovy { 'groovy' }
+package main;
+print p::func()->groovy(), "\n"
+EXPECT
+really groovy
+########
+@list = ([ 'one', 1 ], [ 'two', 2 ]);
+sub func { $num = shift; (grep $_->[1] == $num, @list)[0] }
+print scalar(map &func($_), 1 .. 3), " ",
+ scalar(map scalar &func($_), 1 .. 3), "\n";
+EXPECT
+2 3
+########
+($k, $s) = qw(x 0);
+@{$h{$k}} = qw(1 2 4);
+for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) }
+print "bogus\n" unless $s == 7;
+########
+my $a = 'outer';
+eval q[ my $a = 'inner'; eval q[ print "$a " ] ];
+eval { my $x = 'peace'; eval q[ print "$x\n" ] }
+EXPECT
+inner peace
+########
+-w
+$| = 1;
+sub foo {
+ print "In foo1\n";
+ eval 'sub foo { print "In foo2\n" }';
+ print "Exiting foo1\n";
+}
+foo;
+foo;
+EXPECT
+In foo1
+Subroutine foo redefined at (eval 1) line 1.
+Exiting foo1
+In foo2
+########
+$s = 0;
+map {#this newline here tickles the bug
+$s += $_} (1,2,4);
+print "eat flaming death\n" unless ($s == 7);
+########
+sub foo { local $_ = shift; split; @_ }
+@x = foo(' x y z ');
+print "you die joe!\n" unless "@x" eq 'x y z';
+########
+/(?{"{"})/ # Check it outside of eval too
+EXPECT
+Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern
+/(?{"{"})/: Sequence (?{...}) not terminated or not {}-balanced at - line 1.
+########
+/(?{"{"}})/ # Check it outside of eval too
+EXPECT
+Unmatched right bracket at (re_eval 1) line 1, at end of line
+syntax error at (re_eval 1) line 1, near ""{"}"
+Compilation failed in regexp at - line 1.
+########
+BEGIN { @ARGV = qw(a b c) }
+BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }
+END { print "end <",shift,">\nargv <@ARGV>\n" }
+INIT { print "init <",shift,">\n" }
+EXPECT
+argv <a b c>
+begin <a>
+init <b>
+end <c>
+argv <>
+########
+-l
+# fdopen from a system descriptor to a system descriptor used to close
+# the former.
+open STDERR, '>&=STDOUT' or die $!;
+select STDOUT; $| = 1; print fileno STDOUT;
+select STDERR; $| = 1; print fileno STDERR;
+EXPECT
+1
+2
+########
+-w
+sub testme { my $a = "test"; { local $a = "new test"; print $a }}
+EXPECT
+Can't localize lexical variable $a at - line 2.
+########
+package X;
+sub ascalar { my $r; bless \$r }
+sub DESTROY { print "destroyed\n" };
+package main;
+*s = ascalar X;
+EXPECT
+destroyed
+########
+package X;
+sub anarray { bless [] }
+sub DESTROY { print "destroyed\n" };
+package main;
+*a = anarray X;
+EXPECT
+destroyed
+########
+package X;
+sub ahash { bless {} }
+sub DESTROY { print "destroyed\n" };
+package main;
+*h = ahash X;
+EXPECT
+destroyed
+########
+package X;
+sub aclosure { my $x; bless sub { ++$x } }
+sub DESTROY { print "destroyed\n" };
+package main;
+*c = aclosure X;
+EXPECT
+destroyed
+########
+package X;
+sub any { bless {} }
+my $f = "FH000"; # just to thwart any future optimisations
+sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r }
+sub DESTROY { print "destroyed\n" }
+package main;
+$x = any X; # to bump sv_objcount. IO objs aren't counted??
+*f = afh X;
+EXPECT
+destroyed
+destroyed
+########
diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t
new file mode 100755
index 000000000000..5ba0a0f18d1e
--- /dev/null
+++ b/contrib/perl5/t/op/mkdir.t
@@ -0,0 +1,18 @@
+#!./perl
+
+# $RCSfile: mkdir.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:06 $
+
+print "1..7\n";
+
+$^O eq 'MSWin32' ? `del /s /q blurfl 2>&1` : `rm -rf blurfl`;
+
+# tests 3 and 7 rather naughtily expect English error messages
+$ENV{'LC_ALL'} = 'C';
+
+print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n");
+print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n");
+print ($! =~ /exist|denied/ ? "ok 3\n" : "# $!\nnot ok 3\n");
+print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n");
+print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n");
+print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n");
+print ($! =~ /such|exist/ ? "ok 7\n" : "not ok 7\n");
diff --git a/contrib/perl5/t/op/my.t b/contrib/perl5/t/op/my.t
new file mode 100755
index 000000000000..1777e88266bc
--- /dev/null
+++ b/contrib/perl5/t/op/my.t
@@ -0,0 +1,94 @@
+#!./perl
+
+# $RCSfile: my.t,v $
+
+print "1..30\n";
+
+sub foo {
+ my($a, $b) = @_;
+ my $c;
+ my $d;
+ $c = "ok 3\n";
+ $d = "ok 4\n";
+ { my($a, undef, $c) = ("ok 9\n", "not ok 10\n", "ok 10\n");
+ ($x, $y) = ($a, $c); }
+ print $a, $b;
+ $c . $d;
+}
+
+$a = "ok 5\n";
+$b = "ok 6\n";
+$c = "ok 7\n";
+$d = "ok 8\n";
+
+print &foo("ok 1\n","ok 2\n");
+
+print $a,$b,$c,$d,$x,$y;
+
+# same thing, only with arrays and associative arrays
+
+sub foo2 {
+ my($a, @b) = @_;
+ my(@c, %d);
+ @c = "ok 13\n";
+ $d{''} = "ok 14\n";
+ { my($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); }
+ print $a, @b;
+ $c[0] . $d{''};
+}
+
+$a = "ok 15\n";
+@b = "ok 16\n";
+@c = "ok 17\n";
+$d{''} = "ok 18\n";
+
+print &foo2("ok 11\n","ok 12\n");
+
+print $a,@b,@c,%d,$x,$y;
+
+my $i = "outer";
+
+if (my $i = "inner") {
+ print "not " if $i ne "inner";
+}
+print "ok 21\n";
+
+if ((my $i = 1) == 0) {
+ print "not ";
+}
+else {
+ print "not" if $i != 1;
+}
+print "ok 22\n";
+
+my $j = 5;
+while (my $i = --$j) {
+ print("not "), last unless $i > 0;
+}
+continue {
+ print("not "), last unless $i > 0;
+}
+print "ok 23\n";
+
+$j = 5;
+for (my $i = 0; (my $k = $i) < $j; ++$i) {
+ print("not "), last unless $i >= 0 && $i < $j && $i == $k;
+}
+print "ok 24\n";
+print "not " if defined $k;
+print "ok 25\n";
+
+foreach my $i (26, 27) {
+ print "ok $i\n";
+}
+
+print "not " if $i ne "outer";
+print "ok 28\n";
+
+# Ensure that C<my @y> (without parens) doesn't force scalar context.
+my @x;
+{ @x = my @y }
+print +(@x ? "not " : ""), "ok 29\n";
+{ @x = my %y }
+print +(@x ? "not " : ""), "ok 30\n";
+
diff --git a/contrib/perl5/t/op/nothread.t b/contrib/perl5/t/op/nothread.t
new file mode 100755
index 000000000000..a0d444d90b31
--- /dev/null
+++ b/contrib/perl5/t/op/nothread.t
@@ -0,0 +1,35 @@
+#!./perl
+
+# NOTE: Please don't add tests to this file unless they *need* to be run in
+# separate executable and can't simply use eval.
+
+BEGIN
+ {
+ chdir 't' if -d 't';
+ @INC = "../lib";
+ require Config;
+ import Config;
+ if ($Config{'usethreads'})
+ {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+
+$|=1;
+
+print "1..9\n";
+$t = 1;
+sub foo { local(@_) = ('p', 'q', 'r'); }
+sub bar { unshift @_, 'D'; @_ }
+sub baz { push @_, 'E'; return @_ }
+for (1..3)
+ {
+ print "not " unless join('',foo('a', 'b', 'c')) eq 'pqr';
+ print "ok ",$t++,"\n";
+ print "not" unless join('',bar('d')) eq 'Dd';
+ print "ok ",$t++,"\n";
+ print "not" unless join('',baz('e')) eq 'eE';
+ print "ok ",$t++,"\n";
+ }
diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t
new file mode 100755
index 000000000000..24b5c4309d4a
--- /dev/null
+++ b/contrib/perl5/t/op/oct.t
@@ -0,0 +1,14 @@
+#!./perl
+
+# $RCSfile: oct.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:08 $
+
+print "1..8\n";
+
+print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n";
+print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n";
+print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 3\n";
+print +(oct('20000000000') == 020000000000) ? "ok" : "not ok", " 4\n";
+print +(oct('x80000000') == 0x80000000) ? "ok" : "not ok", " 5\n";
+print +(hex('80000000') == 0x80000000) ? "ok" : "not ok", " 6\n";
+print +(oct('1234') == 668) ? "ok" : "not ok", " 7\n";
+print +(hex('1234') == 4660) ? "ok" : "not ok", " 8\n";
diff --git a/contrib/perl5/t/op/ord.t b/contrib/perl5/t/op/ord.t
new file mode 100755
index 000000000000..ba943f4e8c2d
--- /dev/null
+++ b/contrib/perl5/t/op/ord.t
@@ -0,0 +1,18 @@
+#!./perl
+
+# $RCSfile: ord.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:09 $
+
+print "1..3\n";
+
+# compile time evaluation
+
+# 65 ASCII
+# 193 EBCDIC
+if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n";}
+
+# run time evaluation
+
+$x = 'ABC';
+if (ord($x) == 65 || ord($x) == 193) {print "ok 2\n";} else {print "not ok 2\n";}
+
+if (chr 65 == 'A' || chr 193 == 'A') {print "ok 3\n";} else {print "not ok 3\n";}
diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t
new file mode 100755
index 000000000000..9b7bc351f909
--- /dev/null
+++ b/contrib/perl5/t/op/pack.t
@@ -0,0 +1,205 @@
+#!./perl
+
+# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
+
+print "1..60\n";
+
+$format = "c2 x5 C C x s d i l a6";
+# Need the expression in here to force ary[5] to be numeric. This avoids
+# test2 failing because ary2 goes str->numeric->str and ary doesn't.
+@ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef");
+$foo = pack($format,@ary);
+@ary2 = unpack($format,$foo);
+
+print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n");
+
+$out1=join(':',@ary);
+$out2=join(':',@ary2);
+print ($out1 eq $out2 ? "ok 2\n" : "not ok 2\n");
+
+print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n");
+
+# How about counting bits?
+
+print +($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16
+ ? "ok 4\n" : "not ok 4 $x\n";
+
+print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12
+ ? "ok 5\n" : "not ok 5 $x\n";
+
+print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9
+ ? "ok 6\n" : "not ok 6 $x\n";
+
+my $sum = 129; # ASCII
+$sum = 103 if ($^O eq 'os390'); # An EBCDIC variant.
+
+print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum
+ ? "ok 7\n" : "not ok 7 $x\n";
+
+open(BIN, "./perl") || open(BIN, "./perl.exe")
+ || die "Can't open ../perl or ../perl.exe: $!\n";
+sysread BIN, $foo, 8192;
+close BIN;
+
+$sum = unpack("%32b*", $foo);
+$longway = unpack("b*", $foo);
+print $sum == $longway =~ tr/1/1/ ? "ok 8\n" : "not ok 8\n";
+
+print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF
+ ? "ok 9\n" : "not ok 9 $x\n";
+
+# check 'w'
+my $test=10;
+my @x = (5,130,256,560,32000,3097152,268435455,1073741844,
+ '4503599627365785','23728385234614992549757750638446');
+my $x = pack('w*', @x);
+my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';
+
+print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++;
+
+@y = unpack('w*', $y);
+my $a;
+while ($a = pop @x) {
+ my $b = pop @y;
+ print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++;
+}
+
+@y = unpack('w2', $x);
+
+print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++;
+print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++;
+
+# test exeptions
+eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
+print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
+
+eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff};
+print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
+
+eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
+print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
+
+#
+# test the "p" template
+
+# literals
+print((unpack("p",pack("p","foo")) eq "foo" ? "ok " : "not ok "),$test++,"\n");
+
+# scalars
+print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n");
+
+# temps
+sub foo { my $a = "a"; return $a . $a++ . $a++ }
+{
+ local $^W = 1;
+ my $last = $test;
+ local $SIG{__WARN__} = sub {
+ print "ok ",$test++,"\n" if $_[0] =~ /temporary val/
+ };
+ my $junk = pack("p", &foo);
+ print "not ok ", $test++, "\n" if $last == $test;
+}
+
+# undef should give null pointer
+print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n");
+
+# Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives
+# 4294967295 instead of -1)
+# see #ifdef __osf__ in pp.c pp_unpack
+# Test 30:
+print( ((unpack("i",pack("i",-1))) == -1 ? "ok " : "not ok "),$test++,"\n");
+
+# 31..36: test the pack lengths of s S i I l L
+print "not " unless length(pack("s", 0)) == 2;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("S", 0)) == 2;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("i", 0)) >= 4;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("I", 0)) >= 4;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("l", 0)) == 4;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("L", 0)) == 4;
+print "ok ", $test++, "\n";
+
+# 37..40: test the pack lengths of n N v V
+
+print "not " unless length(pack("n", 0)) == 2;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("N", 0)) == 4;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("v", 0)) == 2;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("V", 0)) == 4;
+print "ok ", $test++, "\n";
+
+# 41..56: test unpack-pack lengths
+
+my @templates = qw(c C i I s S l L n N v V f d);
+
+# quads not supported everywhere: if not, retest floats/doubles
+# to preserve the test count...
+eval { my $q = pack("q",0) };
+push @templates, $@ !~ /Invalid type in pack/ ? qw(q Q) : qw(f d);
+
+foreach my $t (@templates) {
+ my @t = unpack("$t*", pack("$t*", 12, 34));
+ print "not "
+ unless @t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i));
+ print "ok ", $test++, "\n";
+}
+
+# 57..60: uuencode/decode
+
+$in = join "", map { chr } 0..255;
+
+# just to be anal, we do some random tr/`/ /
+$uu = <<'EOUU';
+M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL
+M+2XO,#$R,S0U-C<X.3H[/#T^/T!!0D-$149'2$E*2TQ-3D]045)35%565UA9
+M6EM<75Y?8&%B8V1E9F=H:6IK;&UN;W!Q<G-T=79W>'EZ>WQ]?G^`@8*#A(6&
+MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S
+MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R<K+S,W.S]#1TM/4U=;7V-G:V]S=WM_@
+?X>+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P `
+EOUU
+
+$_ = $uu;
+tr/ /`/;
+print "not " unless pack('u', $in) eq $_;
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('u', $uu) eq $in;
+print "ok ", $test++, "\n";
+
+$in = "\x1f\x8b\x08\x08\x58\xdc\xc4\x35\x02\x03\x4a\x41\x50\x55\x00\xf3\x2a\x2d\x2e\x51\x48\xcc\xcb\x2f\xc9\x48\x2d\x52\x08\x48\x2d\xca\x51\x28\x2d\x4d\xce\x4f\x49\x2d\xe2\x02\x00\x64\x66\x60\x5c\x1a\x00\x00\x00";
+$uu = <<'EOUU';
+M'XL("%C<Q#4"`TI!4%4`\RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>("`&1F
+&8%P:````
+EOUU
+
+print "not " unless unpack('u', $uu) eq $in;
+print "ok ", $test++, "\n";
+
+# 60 identical to 59 except that backquotes have been changed to spaces
+
+$uu = <<'EOUU';
+M'XL("%C<Q#4" TI!4%4 \RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>(" &1F
+&8%P:
+EOUU
+
+print "not " unless unpack('u', $uu) eq $in;
+print "ok ", $test++, "\n";
+
+# Note that first uuencoding known 'text' data and then checking the
+# binary values of the uuencoded version would not be portable between
+# character sets. Uuencoding is meant for encoding binary data, not
+# text data.
diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t
new file mode 100755
index 000000000000..7d4278f38a80
--- /dev/null
+++ b/contrib/perl5/t/op/pat.t
@@ -0,0 +1,597 @@
+#!./perl
+#
+# This is a home for regular expression tests that don't fit into
+# the format supported by op/regexp.t. If you want to add a test
+# that does fit that format, add it to op/re_tests, not here.
+
+print "1..141\n";
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = "../lib" if -d "../lib";
+}
+eval 'use Config'; # Defaults assumed if this fails
+
+# XXX known to leak scalars
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
+
+$x = "abc\ndef\n";
+
+if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
+if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$* = 1;
+if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
+$* = 0;
+
+$_ = '123';
+if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
+
+if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
+if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
+
+if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
+if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
+
+if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
+if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
+
+if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
+if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
+
+$_ = 'aaabbbccc';
+if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
+ print "ok 13\n";
+} else {
+ print "not ok 13\n";
+}
+if (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
+ print "ok 14\n";
+} else {
+ print "not ok 14\n";
+}
+
+if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
+
+$_ = 'aaabccc';
+if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
+if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
+
+$_ = 'aaaccc';
+if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
+if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
+
+$_ = 'abcdef';
+if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
+if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
+
+if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
+
+if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
+
+$* = 1; # test 3 only tested the optimized version--this one is for real
+if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
+$* = 0;
+
+$XXX{123} = 123;
+$XXX{234} = 234;
+$XXX{345} = 345;
+
+@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27');
+while ($_ = shift(@XXX)) {
+ ?(.*)? && (print $1,"\n");
+ /not/ && reset;
+ /not ok 26/ && reset 'X';
+}
+
+while (($key,$val) = each(%XXX)) {
+ print "not ok 27\n";
+ exit;
+}
+
+print "ok 27\n";
+
+'cde' =~ /[^ab]*/;
+'xyz' =~ //;
+if ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";}
+
+$foo = '[^ab]*';
+'cde' =~ /$foo/;
+'xyz' =~ //;
+if ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";}
+
+$foo = '[^ab]*';
+'cde' =~ /$foo/;
+'xyz' =~ /$null/;
+if ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";}
+
+$_ = 'abcdefghi';
+/def/; # optimized up to cmd
+if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";}
+
+/cde/ + 0; # optimized only to spat
+if ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";}
+
+/[d][e][f]/; # not optimized
+if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";}
+
+$_ = 'now is the {time for all} good men to come to.';
+/ {([^}]*)}/;
+if ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";}
+
+$_ = 'xxx {3,4} yyy zzz';
+print /( {3,4})/ ? "ok 35\n" : "not ok 35\n";
+print $1 eq ' ' ? "ok 36\n" : "not ok 36\n";
+print /( {4,})/ ? "not ok 37\n" : "ok 37\n";
+print /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n";
+print $1 eq ' y' ? "ok 39\n" : "not ok 39\n";
+print /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n";
+print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n";
+print /x {3,4}/ ? "not ok 42\n" : "ok 42\n";
+print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n";
+
+$_ = "now is the time for all good men to come to.";
+@words = /(\w+)/g;
+print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
+ ? "ok 44\n"
+ : "not ok 44\n";
+
+@words = ();
+while (/\w+/g) {
+ push(@words, $&);
+}
+print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
+ ? "ok 45\n"
+ : "not ok 45\n";
+
+@words = ();
+pos = 0;
+while (/to/g) {
+ push(@words, $&);
+}
+print join(':',@words) eq "to:to"
+ ? "ok 46\n"
+ : "not ok 46 `@words'\n";
+
+pos $_ = 0;
+@words = /to/g;
+print join(':',@words) eq "to:to"
+ ? "ok 47\n"
+ : "not ok 47 `@words'\n";
+
+$_ = "abcdefghi";
+
+$pat1 = 'def';
+$pat2 = '^def';
+$pat3 = '.def.';
+$pat4 = 'abc';
+$pat5 = '^abc';
+$pat6 = 'abc$';
+$pat7 = 'ghi';
+$pat8 = '\w*ghi';
+$pat9 = 'ghi$';
+
+$t1=$t2=$t3=$t4=$t5=$t6=$t7=$t8=$t9=0;
+
+for $iter (1..5) {
+ $t1++ if /$pat1/o;
+ $t2++ if /$pat2/o;
+ $t3++ if /$pat3/o;
+ $t4++ if /$pat4/o;
+ $t5++ if /$pat5/o;
+ $t6++ if /$pat6/o;
+ $t7++ if /$pat7/o;
+ $t8++ if /$pat8/o;
+ $t9++ if /$pat9/o;
+}
+
+$x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9";
+print $x eq '505550555' ? "ok 48\n" : "not ok 48 $x\n";
+
+$xyz = 'xyz';
+print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n";
+
+# perl 4.009 says "unmatched ()"
+eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"';
+print $@ eq "" ? "ok 50\n" : "not ok 50\n";
+print $result eq "abc:bc" ? "ok 51\n" : "not ok 51\n";
+
+
+$_="abcfooabcbar";
+$x=/abc/g;
+print $` eq "" ? "ok 52\n" : "not ok 52\n" if $x;
+$x=/abc/g;
+print $` eq "abcfoo" ? "ok 53\n" : "not ok 53\n" if $x;
+$x=/abc/g;
+print $x == 0 ? "ok 54\n" : "not ok 54\n";
+pos = 0;
+$x=/ABC/gi;
+print $` eq "" ? "ok 55\n" : "not ok 55\n" if $x;
+$x=/ABC/gi;
+print $` eq "abcfoo" ? "ok 56\n" : "not ok 56\n" if $x;
+$x=/ABC/gi;
+print $x == 0 ? "ok 57\n" : "not ok 57\n";
+pos = 0;
+$x=/abc/g;
+print $' eq "fooabcbar" ? "ok 58\n" : "not ok 58\n" if $x;
+$x=/abc/g;
+print $' eq "bar" ? "ok 59\n" : "not ok 59\n" if $x;
+$_ .= '';
+@x=/abc/g;
+print scalar @x == 2 ? "ok 60\n" : "not ok 60\n";
+
+$_ = "abdc";
+pos $_ = 2;
+/\Gc/gc;
+print "not " if (pos $_) != 2;
+print "ok 61\n";
+/\Gc/g;
+print "not " if defined pos $_;
+print "ok 62\n";
+
+$out = 1;
+'abc' =~ m'a(?{ $out = 2 })b';
+print "not " if $out != 2;
+print "ok 63\n";
+
+$out = 1;
+'abc' =~ m'a(?{ $out = 3 })c';
+print "not " if $out != 1;
+print "ok 64\n";
+
+$_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6';
+@out = /(?<!foo)bar./g;
+print "not " if "@out" ne 'bar2 barf';
+print "ok 65\n";
+
+# Tests which depend on REG_INFTY
+$reg_infty = defined $Config{reg_infty} ? $Config{reg_infty} : 32767;
+$reg_infty_m = $reg_infty - 1; $reg_infty_p = $reg_infty + 1;
+
+# As well as failing if the pattern matches do unexpected things, the
+# next three tests will fail if you should have picked up a lower-than-
+# default value for $reg_infty from Config.pm, but have not.
+
+undef $@;
+print "not " if eval q(('aaa' =~ /(a{1,$reg_infty_m})/)[0] ne 'aaa') || $@;
+print "ok 66\n";
+
+undef $@;
+print "not " if eval q(('a' x $reg_infty_m) !~ /a{$reg_infty_m}/) || $@;
+print "ok 67\n";
+
+undef $@;
+print "not " if eval q(('a' x ($reg_infty_m - 1)) =~ /a{$reg_infty_m}/) || $@;
+print "ok 68\n";
+
+undef $@;
+eval "'aaa' =~ /a{1,$reg_infty}/";
+print "not " if $@ !~ m%^\Q/a{1,$reg_infty}/: Quantifier in {,} bigger than%;
+print "ok 69\n";
+
+eval "'aaa' =~ /a{1,$reg_infty_p}/";
+print "not "
+ if $@ !~ m%^\Q/a{1,$reg_infty_p}/: Quantifier in {,} bigger than%;
+print "ok 70\n";
+undef $@;
+
+# Poke a couple more parse failures
+
+$context = 'x' x 256;
+eval qq("${context}y" =~ /(?<=$context)y/);
+print "not " if $@ !~ m%^\Q/(?<=\Ex+/: lookbehind longer than 255 not%;
+print "ok 71\n";
+
+# This one will fail when POSIX character classes do get implemented
+{
+ my $w;
+ local $^W = 1;
+ local $SIG{__WARN__} = sub{$w = shift};
+ eval q('a' =~ /[[:alpha:]]/);
+ print "not " if $w !~ /^\QCharacter class syntax [: :] is reserved/;
+}
+print "ok 72\n";
+
+# Long Monsters
+$test = 73;
+for $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory
+ $a = 'a' x $l;
+ print "# length=$l\nnot " unless "ba$a=" =~ /a$a=/;
+ print "ok $test\n";
+ $test++;
+
+ print "not " if "b$a=" =~ /a$a=/;
+ print "ok $test\n";
+ $test++;
+}
+
+# 20000 nodes, each taking 3 words per string, and 1 per branch
+$long_constant_len = join '|', 12120 .. 32645;
+$long_var_len = join '|', 8120 .. 28645;
+%ans = ( 'ax13876y25677lbc' => 1,
+ 'ax13876y25677mcb' => 0, # not b.
+ 'ax13876y35677nbc' => 0, # Num too big
+ 'ax13876y25677y21378obc' => 1,
+ 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o]
+ 'ax13876y25677y21378y21378kbc' => 1,
+ 'ax13876y25677y21378y21378kcb' => 0, # Not b.
+ 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs
+ );
+
+for ( keys %ans ) {
+ print "# const-len `$_' not => $ans{$_}\nnot "
+ if $ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o;
+ print "ok $test\n";
+ $test++;
+ print "# var-len `$_' not => $ans{$_}\nnot "
+ if $ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o;
+ print "ok $test\n";
+ $test++;
+}
+
+$_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e";
+$expect = "(bla()) ((l)u((e))) (l(e)e)";
+
+sub matchit {
+ m/
+ (
+ \(
+ (?{ $c = 1 }) # Initialize
+ (?:
+ (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop
+ (?!
+ ) # Fail: will unwind one iteration back
+ )
+ (?:
+ [^()]+ # Match a big chunk
+ (?=
+ [()]
+ ) # Do not try to match subchunks
+ |
+ \(
+ (?{ ++$c })
+ |
+ \)
+ (?{ --$c })
+ )
+ )+ # This may not match with different subblocks
+ )
+ (?(?{ $c != 0 })
+ (?!
+ ) # Fail
+ ) # Otherwise the chunk 1 may succeed with $c>0
+ /xg;
+}
+
+push @ans, $res while $res = matchit;
+
+print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1";
+print "ok $test\n";
+$test++;
+
+@ans = matchit;
+
+print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect;
+print "ok $test\n";
+$test++;
+
+@ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad
+print "not " if "@ans" ne 'a/ b';
+print "ok $test\n";
+$test++;
+
+$code = '{$blah = 45}';
+$blah = 12;
+eval { /(?$code)/ };
+print "not " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12;
+print "ok $test\n";
+$test++;
+
+for $code ('{$blah = 45}','=xx') {
+ $blah = 12;
+ $res = eval { "xx" =~ /(?$code)/o };
+ if ($code eq '=xx') {
+ print "#'$@','$res','$blah'\nnot " unless not $@ and $res;
+ } else {
+ print "#'$@','$res','$blah'\nnot " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12;
+ }
+ print "ok $test\n";
+ $test++;
+}
+
+$code = '{$blah = 45}';
+$blah = 12;
+eval "/(?$code)/";
+print "not " if $blah != 45;
+print "ok $test\n";
+$test++;
+
+$blah = 12;
+/(?{$blah = 45})/;
+print "not " if $blah != 45;
+print "ok $test\n";
+$test++;
+
+$x = 'banana';
+$x =~ /.a/g;
+print "not " unless pos($x) == 2;
+print "ok $test\n";
+$test++;
+
+$x =~ /.z/gc;
+print "not " unless pos($x) == 2;
+print "ok $test\n";
+$test++;
+
+sub f {
+ my $p = $_[0];
+ return $p;
+}
+
+$x =~ /.a/g;
+print "not " unless f(pos($x)) == 4;
+print "ok $test\n";
+$test++;
+
+$x = $^R = 67;
+'foot' =~ /foo(?{$x = 12; 75})[t]/;
+print "not " unless $^R eq '75';
+print "ok $test\n";
+$test++;
+
+$x = $^R = 67;
+'foot' =~ /foo(?{$x = 12; 75})[xy]/;
+print "not " unless $^R eq '67' and $x eq '12';
+print "ok $test\n";
+$test++;
+
+$x = $^R = 67;
+'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/;
+print "not " unless $^R eq '79' and $x eq '12';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/i eq '(?i-xsm:\bv$)';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/s eq '(?s-xim:\bv$)';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/m eq '(?m-xis:\bv$)';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/x eq '(?x-ism:\bv$)';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/xism eq '(?msix:\bv$)';
+print "ok $test\n";
+$test++;
+
+print "not " unless qr/\b\v$/ eq '(?-xism:\bv$)';
+print "ok $test\n";
+$test++;
+
+$_ = 'xabcx';
+foreach $ans ('', 'c') {
+ /(?<=(?=a)..)((?=c)|.)/g;
+ print "not " unless $1 eq $ans;
+ print "ok $test\n";
+ $test++;
+}
+
+$_ = 'a';
+foreach $ans ('', 'a', '') {
+ /^|a|$/g;
+ print "not " unless $& eq $ans;
+ print "ok $test\n";
+ $test++;
+}
+
+sub prefixify {
+ my($v,$a,$b,$res) = @_;
+ $v =~ s/\Q$a\E/$b/;
+ print "not " unless $res eq $v;
+ print "ok $test\n";
+ $test++;
+}
+prefixify('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch');
+prefixify('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch');
+
+$_ = 'var="foo"';
+/(\")/;
+print "not " unless $1 and /$1/;
+print "ok $test\n";
+$test++;
+
+$a=qr/(?{++$b})/;
+$b = 7;
+/$a$a/;
+print "not " unless $b eq '9';
+print "ok $test\n";
+$test++;
+
+$c="$a";
+/$a$a/;
+print "not " unless $b eq '11';
+print "ok $test\n";
+$test++;
+
+{
+ use re "eval";
+ /$a$c$a/;
+ print "not " unless $b eq '14';
+ print "ok $test\n";
+ $test++;
+
+ no re "eval";
+ $match = eval { /$a$c$a/ };
+ print "not "
+ unless $b eq '14' and $@ =~ /Eval-group not allowed/ and not $match;
+ print "ok $test\n";
+ $test++;
+}
+
+{
+ package aa;
+ $c = 2;
+ $::c = 3;
+ '' =~ /(?{ $c = 4 })/;
+ print "not " unless $c == 4;
+}
+print "ok $test\n";
+$test++;
+print "not " unless $c == 3;
+print "ok $test\n";
+$test++;
+
+sub must_warn_pat {
+ my $warn_pat = shift;
+ return sub { print "not " unless $_[0] =~ /$warn_pat/ }
+}
+
+sub must_warn {
+ my ($warn_pat, $code) = @_;
+ local $^W; local %SIG;
+ eval 'BEGIN { $^W = 1; $SIG{__WARN__} = $warn_pat };' . $code;
+ print "ok $test\n";
+ $test++;
+}
+
+
+sub make_must_warn {
+ my $warn_pat = shift;
+ return sub { must_warn(must_warn_pat($warn_pat)) }
+}
+
+my $for_future = make_must_warn('reserved for future extensions');
+
+&$for_future('q(a:[b]:) =~ /[x[:foo:]]/');
+&$for_future('q(a=[b]=) =~ /[x[=foo=]]/');
+&$for_future('q(a.[b].) =~ /[x[.foo.]]/');
+
+# test if failure of patterns returns empty list
+$_ = 'aaa';
+@_ = /bbb/;
+print "not " if @_;
+print "ok $test\n";
+$test++;
+
+@_ = /bbb/g;
+print "not " if @_;
+print "ok $test\n";
+$test++;
+
+@_ = /(bbb)/;
+print "not " if @_;
+print "ok $test\n";
+$test++;
+
+@_ = /(bbb)/g;
+print "not " if @_;
+print "ok $test\n";
+$test++;
+
diff --git a/contrib/perl5/t/op/pos.t b/contrib/perl5/t/op/pos.t
new file mode 100755
index 000000000000..46811b7bbc7d
--- /dev/null
+++ b/contrib/perl5/t/op/pos.t
@@ -0,0 +1,16 @@
+#!./perl
+
+print "1..3\n";
+
+$x='banana';
+$x=~/.a/g;
+if (pos($x)==2) {print "ok 1\n"} else {print "not ok 1\n";}
+
+$x=~/.z/gc;
+if (pos($x)==2) {print "ok 2\n"} else {print "not ok 2\n";}
+
+sub f { my $p=$_[0]; return $p }
+
+$x=~/.a/g;
+if (f(pos($x))==4) {print "ok 3\n"} else {print "not ok 3\n";}
+
diff --git a/contrib/perl5/t/op/push.t b/contrib/perl5/t/op/push.t
new file mode 100755
index 000000000000..a67caed2b319
--- /dev/null
+++ b/contrib/perl5/t/op/push.t
@@ -0,0 +1,56 @@
+#!./perl
+
+# $RCSfile: push.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:13 $
+
+@tests = split(/\n/, <<EOF);
+0 3, 0 1 2, 3 4 5 6 7
+0 0 a b c, , a b c 0 1 2 3 4 5 6 7
+8 0 a b c, , 0 1 2 3 4 5 6 7 a b c
+7 0 6.5, , 0 1 2 3 4 5 6 6.5 7
+1 0 a b c d e f g h i j,, 0 a b c d e f g h i j 1 2 3 4 5 6 7
+0 1 a, 0, a 1 2 3 4 5 6 7
+1 6 x y z, 1 2 3 4 5 6, 0 x y z 7
+0 7 x y z, 0 1 2 3 4 5 6, x y z 7
+1 7 x y z, 1 2 3 4 5 6 7, 0 x y z
+4, 4 5 6 7, 0 1 2 3
+-4, 4 5 6 7, 0 1 2 3
+EOF
+
+print "1..", 4 + @tests, "\n";
+die "blech" unless @tests;
+
+@x = (1,2,3);
+push(@x,@x);
+if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
+push(@x,4);
+if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
+
+# test for push/pop intuiting @ on array
+push(x,3);
+if (join(':',@x) eq '1:2:3:1:2:3:4:3') {print "ok 3\n";} else {print "not ok 3\n";}
+pop(x);
+if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 4\n";} else {print "not ok 4\n";}
+
+$test = 5;
+foreach $line (@tests) {
+ ($list,$get,$leave) = split(/,\t*/,$line);
+ ($pos, $len, @list) = split(' ',$list);
+ @get = split(' ',$get);
+ @leave = split(' ',$leave);
+ @x = (0,1,2,3,4,5,6,7);
+ if (defined $len) {
+ @got = splice(@x, $pos, $len, @list);
+ }
+ else {
+ @got = splice(@x, $pos);
+ }
+ if (join(':',@got) eq join(':',@get) &&
+ join(':',@x) eq join(':',@leave)) {
+ print "ok ",$test++,"\n";
+ }
+ else {
+ print "not ok ",$test++," got: @got == @get left: @x == @leave\n";
+ }
+}
+
+1; # this file is require'd by lib/tie-stdpush.t
diff --git a/contrib/perl5/t/op/quotemeta.t b/contrib/perl5/t/op/quotemeta.t
new file mode 100755
index 000000000000..913e07cdd6a1
--- /dev/null
+++ b/contrib/perl5/t/op/quotemeta.t
@@ -0,0 +1,38 @@
+#!./perl
+
+print "1..15\n";
+
+if ($^O eq 'os390') { # An EBCDIC variant.
+ $_=join "", map chr($_), 129..233;
+
+ # 105 characters - 52 letters = 53 backslashes
+ # 105 characters + 53 backslashes = 158 characters
+ $_=quotemeta $_;
+ if ( length == 158 ){print "ok 1\n"} else {print "not ok 1\n"}
+ # 104 non-backslash characters
+ if (tr/\\//cd == 104){print "ok 2\n"} else {print "not ok 2\n"}
+} else { # some ASCII descendant, then.
+ $_=join "", map chr($_), 32..127;
+
+ # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes
+ # 96 characters + 33 backslashes = 129 characters
+ $_=quotemeta $_;
+ if ( length == 129 ){print "ok 1\n"} else {print "not ok 1\n"}
+ # 95 non-backslash characters
+ if (tr/\\//cd == 95){print "ok 2\n"} else {print "not ok 2\n"}
+}
+
+if (length quotemeta "" == 0){print "ok 3\n"} else {print "not ok 3\n"}
+
+print "aA\UbB\LcC\EdD" eq "aABBccdD" ? "ok 4\n" : "not ok 4 \n";
+print "aA\LbB\UcC\EdD" eq "aAbbCCdD" ? "ok 5\n" : "not ok 5 \n";
+print "\L\upERL" eq "Perl" ? "ok 6\n" : "not ok 6 \n";
+print "\u\LpERL" eq "Perl" ? "ok 7\n" : "not ok 7 \n";
+print "\U\lPerl" eq "pERL" ? "ok 8\n" : "not ok 8 \n";
+print "\l\UPerl" eq "pERL" ? "ok 9\n" : "not ok 9 \n";
+print "\u\LpE\Q#X#\ER\EL" eq "Pe\\#x\\#rL" ? "ok 10\n" : "not ok 10 \n";
+print "\l\UPe\Q!x!\Er\El" eq "pE\\!X\\!Rl" ? "ok 11\n" : "not ok 11 \n";
+print "\Q\u\LpE.X.R\EL\E." eq "Pe\\.x\\.rL." ? "ok 12\n" : "not ok 12 \n";
+print "\Q\l\UPe*x*r\El\E*" eq "pE\\*X\\*Rl*" ? "ok 13\n" : "not ok 13 \n";
+print "\U\lPerl\E\E\E\E" eq "pERL" ? "ok 14\n" : "not ok 14 \n";
+print "\l\UPerl\E\E\E\E" eq "pERL" ? "ok 15\n" : "not ok 15 \n";
diff --git a/contrib/perl5/t/op/rand.t b/contrib/perl5/t/op/rand.t
new file mode 100755
index 000000000000..c779f9dad9c5
--- /dev/null
+++ b/contrib/perl5/t/op/rand.t
@@ -0,0 +1,348 @@
+#!./perl
+
+# From Tom Phoenix <rootbeer@teleport.com> 22 Feb 1997
+# Based upon a test script by kgb@ast.cam.ac.uk (Karl Glazebrook)
+
+# Looking for the hints? You're in the right place.
+# The hints are near each test, so search for "TEST #", where
+# the pound sign is replaced by the number of the test.
+
+# I'd like to include some more robust tests, but anything
+# too subtle to be detected here would require a time-consuming
+# test. Also, of course, we're here to detect only flaws in Perl;
+# if there are flaws in the underlying system rand, that's not
+# our responsibility. But if you want better tests, see
+# The Art of Computer Programming, Donald E. Knuth, volume 2,
+# chapter 3. ISBN 0-201-03822-6 (v. 2)
+
+BEGIN {
+ chdir "t" if -d "t";
+ @INC = "../lib" if -d "../lib";
+}
+
+use strict;
+use Config;
+
+print "1..11\n";
+
+srand; # Shouldn't need this with 5.004...
+ # But I'll include it now and test for
+ # whether we needed it later.
+
+my $reps = 1000; # How many times to try rand each time.
+ # May be changed, but should be over 500.
+ # The more the better! (But slower.)
+
+sub bits ($) {
+ # Takes a small integer and returns the number of one-bits in it.
+ my $total;
+ my $bits = sprintf "%o", $_[0];
+ while (length $bits) {
+ $total += (0,1,1,2,1,2,2,3)[chop $bits]; # Oct to bits
+ }
+ $total;
+}
+
+# First, let's see whether randbits is set right
+{
+ my($max, $min, $sum); # Characteristics of rand
+ my($off, $shouldbe); # Problems with randbits
+ my($dev, $bits); # Number of one bits
+ my $randbits = $Config{randbits};
+ $max = $min = rand(1);
+ for (1..$reps) {
+ my $n = rand(1);
+ $sum += $n;
+ $bits += bits($n * 256); # Don't be greedy; 8 is enough
+ # It's too many if randbits is less than 8!
+ # But that should never be the case... I hope.
+ # Note: If you change this, you must adapt the
+ # formula for absolute standard deviation, below.
+ $max = $n if $n > $max;
+ $min = $n if $n < $min;
+ }
+
+
+ # Hints for TEST 1
+ #
+ # This test checks for one of Perl's most frequent
+ # mis-configurations. Your system's documentation
+ # for rand(2) should tell you what value you need
+ # for randbits. Usually the diagnostic message
+ # has the right value as well. Just fix it and
+ # recompile, and you'll usually be fine. (The main
+ # reason that the diagnostic message might get the
+ # wrong value is that Config.pm is incorrect.)
+ #
+ if ($max <= 0 or $max >= (1 << $randbits)) { # Just in case...
+ print "not ok 1\n";
+ print "# This perl was compiled with randbits=$randbits\n";
+ print "# which is _way_ off. Or maybe your system rand is broken,\n";
+ print "# or your C compiler can't multiply, or maybe Martians\n";
+ print "# have taken over your computer. For starters, see about\n";
+ print "# trying a better value for randbits, probably smaller.\n";
+ # If that isn't the problem, we'll have
+ # to put d_martians into Config.pm
+ print "# Skipping remaining tests until randbits is fixed.\n";
+ exit;
+ }
+
+ $off = log($max) / log(2); # log2
+ $off = int($off) + ($off > 0); # Next more positive int
+ if ($off) {
+ $shouldbe = $Config{randbits} + $off;
+ print "not ok 1\n";
+ print "# This perl was compiled with randbits=$randbits on $^O.\n";
+ print "# Consider using randbits=$shouldbe instead.\n";
+ # And skip the remaining tests; they would be pointless now.
+ print "# Skipping remaining tests until randbits is fixed.\n";
+ exit;
+ } else {
+ print "ok 1\n";
+ }
+
+ # Hints for TEST 2
+ #
+ # This should always be true: 0 <= rand(1) < 1
+ # If this test is failing, something is seriously wrong,
+ # either in perl or your system's rand function.
+ #
+ if ($min < 0 or $max >= 1) { # Slightly redundant...
+ print "not ok 2\n";
+ print "# min too low\n" if $min < 0;
+ print "# max too high\n" if $max >= 1;
+ } else {
+ print "ok 2\n";
+ }
+
+ # Hints for TEST 3
+ #
+ # This is just a crude test. The average number produced
+ # by rand should be about one-half. But once in a while
+ # it will be relatively far away. Note: This test will
+ # occasionally fail on a perfectly good system!
+ # See the hints for test 4 to see why.
+ #
+ $sum /= $reps;
+ if ($sum < 0.4 or $sum > 0.6) {
+ print "not ok 3\n# Average random number is far from 0.5\n";
+ } else {
+ print "ok 3\n";
+ }
+
+ # Hints for TEST 4
+ #
+ # NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+ # This test will fail .1% of the time on a normal system.
+ # also
+ # This test asks you to see these hints 100% of the time!
+ # NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
+ #
+ # There is probably no reason to be alarmed that
+ # something is wrong with your rand function. But,
+ # if you're curious or if you can't help being
+ # alarmed, keep reading.
+ #
+ # This is a less-crude test than test 3. But it has
+ # the same basic flaw: Unusually distributed random
+ # values should occasionally appear in every good
+ # random number sequence. (If you flip a fair coin
+ # twenty times every day, you'll see it land all
+ # heads about one time in a million days, on the
+ # average. That might alarm you if you saw it happen
+ # on the first day!)
+ #
+ # So, if this test failed on you once, run it a dozen
+ # times. If it keeps failing, it's likely that your
+ # rand is bogus. If it keeps passing, it's likely
+ # that the one failure was bogus. If it's a mix,
+ # read on to see about how to interpret the tests.
+ #
+ # The number printed in square brackets is the
+ # standard deviation, a statistical measure
+ # of how unusual rand's behavior seemed. It should
+ # fall in these ranges with these *approximate*
+ # probabilities:
+ #
+ # under 1 68.26% of the time
+ # 1-2 27.18% of the time
+ # 2-3 4.30% of the time
+ # over 3 0.26% of the time
+ #
+ # If the numbers you see are not scattered approximately
+ # (not exactly!) like that table, check with your vendor
+ # to find out what's wrong with your rand. Or with this
+ # algorithm. :-)
+ #
+ # Calculating absoulute standard deviation for number of bits set
+ # (eight bits per rep)
+ $dev = abs ($bits - $reps * 4) / sqrt($reps * 2);
+
+ if ($dev < 1.96) {
+ print "ok 4\n"; # 95% of the time.
+ print "# Your rand seems fine. If this test failed\n";
+ print "# previously, you may want to run it again.\n";
+ } elsif ($dev < 2.575) {
+ print "ok 4\n# In here about 4% of the time. Hmmm...\n";
+ print "# This is ok, but suspicious. But it will happen\n";
+ print "# one time out of 25, more or less.\n";
+ print "# You should run this test again to be sure.\n";
+ } elsif ($dev < 3.3) {
+ print "ok 4\n# In this range about 1% of the time.\n";
+ print "# This is very suspicious. It will happen only\n";
+ print "# about one time out of 100, more or less.\n";
+ print "# You should run this test again to be sure.\n";
+ } elsif ($dev < 3.9) {
+ print "not ok 4\n# In this range very rarely.\n";
+ print "# This is VERY suspicious. It will happen only\n";
+ print "# about one time out of 1000, more or less.\n";
+ print "# You should run this test again to be sure.\n";
+ } else {
+ print "not ok 4\n# Seriously whacked.\n";
+ print "# This is VERY VERY suspicious.\n";
+ print "# Your rand seems to be bogus.\n";
+ }
+ print "#\n# If you are having random number troubles,\n";
+ print "# see the hints within the test script for more\n";
+ printf "# information on why this might fail. [ %.3f ]\n", $dev;
+}
+
+{
+ srand; # These three lines are for test 7
+ my $time = time; # It's just faster to do them here.
+ my $rand = join ", ", rand, rand, rand;
+
+ # Hints for TEST 5
+ #
+ # This test checks that the argument to srand actually
+ # sets the seed for generating random numbers.
+ #
+ srand(3.14159);
+ my $r = rand;
+ srand(3.14159);
+ if (rand != $r) {
+ print "not ok 5\n";
+ print "# srand is not consistent.\n";
+ } else {
+ print "ok 5\n";
+ }
+
+ # Hints for TEST 6
+ #
+ # This test just checks that the previous one didn't
+ # give us false confidence!
+ #
+ if (rand == $r) {
+ print "not ok 6\n";
+ print "# rand is now unchanging!\n";
+ } else {
+ print "ok 6\n";
+ }
+
+ # Hints for TEST 7
+ #
+ # This checks that srand without arguments gives
+ # different sequences each time. Note: You shouldn't
+ # be calling srand more than once unless you know
+ # what you're doing! But if this fails on your
+ # system, run perlbug and let the developers know
+ # what other sources of randomness srand should
+ # tap into.
+ #
+ while ($time == time) { } # Wait for new second, just in case.
+ srand;
+ if ((join ", ", rand, rand, rand) eq $rand) {
+ print "not ok 7\n";
+ print "# srand without args isn't varying.\n";
+ } else {
+ print "ok 7\n";
+ }
+}
+
+# Now, let's see whether rand accepts its argument
+{
+ my($max, $min);
+ $max = $min = rand(100);
+ for (1..$reps) {
+ my $n = rand(100);
+ $max = $n if $n > $max;
+ $min = $n if $n < $min;
+ }
+
+ # Hints for TEST 8
+ #
+ # This test checks to see that rand(100) really falls
+ # within the range 0 - 100, and that the numbers produced
+ # have a reasonably-large range among them.
+ #
+ if ($min < 0 or $max >= 100 or ($max - $min) < 65) {
+ print "not ok 8\n";
+ print "# min too low\n" if $min < 0;
+ print "# max too high\n" if $max >= 100;
+ print "# range too narrow\n" if ($max - $min) < 65;
+ } else {
+ print "ok 8\n";
+ }
+
+ # Hints for TEST 9
+ #
+ # This test checks that rand without an argument
+ # is equivalent to rand(1).
+ #
+ $_ = 12345; # Just for fun.
+ srand 12345;
+ my $r = rand;
+ srand 12345;
+ if (rand(1) == $r) {
+ print "ok 9\n";
+ } else {
+ print "not ok 9\n";
+ print "# rand without arguments isn't rand(1)!\n";
+ }
+
+ # Hints for TEST 10
+ #
+ # This checks that rand without an argument is not
+ # rand($_). (In case somebody got overzealous.)
+ #
+ if ($r >= 1) {
+ print "not ok 10\n";
+ print "# rand without arguments isn't under 1!\n";
+ } else {
+ print "ok 10\n";
+ }
+}
+
+# Hints for TEST 11
+#
+# This test checks whether Perl called srand for you. This should
+# be the case in version 5.004 and later. Note: You must still
+# call srand if your code might ever be run on a pre-5.004 system!
+#
+AUTOSRAND:
+{
+ unless ($Config{d_fork}) {
+ # Skip this test. It's not likely to be system-specific, anyway.
+ print "ok 11\n# Skipping this test on this platform.\n";
+ last;
+ }
+
+ my($pid, $first);
+ for (1..5) {
+ my $PERL = (($^O eq 'VMS') ? "MCR $^X"
+ : ($^O eq 'MSWin32') ? '.\perl'
+ : './perl');
+ $pid = open PERL, qq[$PERL -e "print rand"|];
+ die "Couldn't pipe from perl: $!" unless defined $pid;
+ if (defined $first) {
+ if ($first ne <PERL>) {
+ print "ok 11\n";
+ last AUTOSRAND;
+ }
+ } else {
+ $first = <PERL>;
+ }
+ close PERL or die "perl returned error code $?";
+ }
+ print "not ok 11\n# srand isn't being autocalled.\n";
+}
diff --git a/contrib/perl5/t/op/range.t b/contrib/perl5/t/op/range.t
new file mode 100755
index 000000000000..7999b869cb1b
--- /dev/null
+++ b/contrib/perl5/t/op/range.t
@@ -0,0 +1,48 @@
+#!./perl
+
+print "1..10\n";
+
+print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n";
+
+@foo = (1,2,3,4,5,6,7,8,9);
+@foo[2..4] = ('c','d','e');
+
+print join(':',@foo[$foo[0]..5]) eq '2:c:d:e:6' ? "ok 2\n" : "not ok 2\n";
+
+@bar[2..4] = ('c','d','e');
+print join(':',@bar[1..5]) eq ':c:d:e:' ? "ok 3\n" : "not ok 3\n";
+
+($a,@bcd[0..2],$e) = ('a','b','c','d','e');
+print join(':',$a,@bcd[0..2],$e) eq 'a:b:c:d:e' ? "ok 4\n" : "not ok 4\n";
+
+$x = 0;
+for (1..100) {
+ $x += $_;
+}
+print $x == 5050 ? "ok 5\n" : "not ok 5 $x\n";
+
+$x = 0;
+for ((100,2..99,1)) {
+ $x += $_;
+}
+print $x == 5050 ? "ok 6\n" : "not ok 6 $x\n";
+
+$x = join('','a'..'z');
+print $x eq 'abcdefghijklmnopqrstuvwxyz' ? "ok 7\n" : "not ok 7 $x\n";
+
+@x = 'A'..'ZZ';
+print @x == 27 * 26 ? "ok 8\n" : "not ok 8\n";
+
+@x = '09' .. '08'; # should produce '09', '10',... '99' (strange but true)
+print "not " unless join(",", @x) eq
+ join(",", map {sprintf "%02d",$_} 9..99);
+print "ok 9\n";
+
+# same test with foreach (which is a separate implementation)
+@y = ();
+foreach ('09'..'08') {
+ push(@y, $_);
+}
+print "not " unless join(",", @y) eq join(",", @x);
+print "ok 10\n";
+
diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests
new file mode 100644
index 000000000000..a5295f5aae10
--- /dev/null
+++ b/contrib/perl5/t/op/re_tests
@@ -0,0 +1,485 @@
+abc abc y $& abc
+abc xbc n - -
+abc axc n - -
+abc abx n - -
+abc xabcy y $& abc
+abc ababc y $& abc
+ab*c abc y $& abc
+ab*bc abc y $& abc
+ab*bc abbc y $& abbc
+ab*bc abbbbc y $& abbbbc
+.{1} abbbbc y $& a
+.{3,4} abbbbc y $& abbb
+ab{0,}bc abbbbc y $& abbbbc
+ab+bc abbc y $& abbc
+ab+bc abc n - -
+ab+bc abq n - -
+ab{1,}bc abq n - -
+ab+bc abbbbc y $& abbbbc
+ab{1,}bc abbbbc y $& abbbbc
+ab{1,3}bc abbbbc y $& abbbbc
+ab{3,4}bc abbbbc y $& abbbbc
+ab{4,5}bc abbbbc n - -
+ab?bc abbc y $& abbc
+ab?bc abc y $& abc
+ab{0,1}bc abc y $& abc
+ab?bc abbbbc n - -
+ab?c abc y $& abc
+ab{0,1}c abc y $& abc
+^abc$ abc y $& abc
+^abc$ abcc n - -
+^abc abcc y $& abc
+^abc$ aabc n - -
+abc$ aabc y $& abc
+abc$ aabcd n - -
+^ abc y $&
+$ abc y $&
+a.c abc y $& abc
+a.c axc y $& axc
+a.*c axyzc y $& axyzc
+a.*c axyzd n - -
+a[bc]d abc n - -
+a[bc]d abd y $& abd
+a[b-d]e abd n - -
+a[b-d]e ace y $& ace
+a[b-d] aac y $& ac
+a[-b] a- y $& a-
+a[b-] a- y $& a-
+a[b-a] - c - /a[b-a]/: invalid [] range in regexp
+a[]b - c - /a[]b/: unmatched [] in regexp
+a[ - c - /a[/: unmatched [] in regexp
+a] a] y $& a]
+a[]]b a]b y $& a]b
+a[^bc]d aed y $& aed
+a[^bc]d abd n - -
+a[^-b]c adc y $& adc
+a[^-b]c a-c n - -
+a[^]b]c a]c n - -
+a[^]b]c adc y $& adc
+\ba\b a- y - -
+\ba\b -a y - -
+\ba\b -a- y - -
+\by\b xy n - -
+\by\b yz n - -
+\by\b xyz n - -
+\Ba\B a- n - -
+\Ba\B -a n - -
+\Ba\B -a- n - -
+\By\b xy y - -
+\by\B yz y - -
+\By\B xyz y - -
+\w a y - -
+\w - n - -
+\W a n - -
+\W - y - -
+a\sb a b y - -
+a\sb a-b n - -
+a\Sb a b n - -
+a\Sb a-b y - -
+\d 1 y - -
+\d - n - -
+\D 1 n - -
+\D - y - -
+[\w] a y - -
+[\w] - n - -
+[\W] a n - -
+[\W] - y - -
+a[\s]b a b y - -
+a[\s]b a-b n - -
+a[\S]b a b n - -
+a[\S]b a-b y - -
+[\d] 1 y - -
+[\d] - n - -
+[\D] 1 n - -
+[\D] - y - -
+ab|cd abc y $& ab
+ab|cd abcd y $& ab
+()ef def y $&-$1 ef-
+*a - c - /*a/: ?+*{} follows nothing in regexp
+(*)b - c - /(*)b/: ?+*{} follows nothing in regexp
+$b b n - -
+a\ - c - Search pattern not terminated
+a\(b a(b y $&-$1 a(b-
+a\(*b ab y $& ab
+a\(*b a((b y $& a((b
+a\\b a\b y $& a\b
+abc) - c - /abc)/: unmatched () in regexp
+(abc - c - /(abc/: unmatched () in regexp
+((a)) abc y $&-$1-$2 a-a-a
+(a)b(c) abc y $&-$1-$2 abc-a-c
+a+b+c aabbabc y $& abc
+a{1,}b{1,}c aabbabc y $& abc
+a** - c - /a**/: nested *?+ in regexp
+a.+?c abcabc y $& abc
+(a+|b)* ab y $&-$1 ab-b
+(a+|b){0,} ab y $&-$1 ab-b
+(a+|b)+ ab y $&-$1 ab-b
+(a+|b){1,} ab y $&-$1 ab-b
+(a+|b)? ab y $&-$1 a-a
+(a+|b){0,1} ab y $&-$1 a-a
+)( - c - /)(/: unmatched () in regexp
+[^ab]* cde y $& cde
+abc n - -
+a* y $&
+([abc])*d abbbcd y $&-$1 abbbcd-c
+([abc])*bcd abcd y $&-$1 abcd-a
+a|b|c|d|e e y $& e
+(a|b|c|d|e)f ef y $&-$1 ef-e
+abcd*efg abcdefg y $& abcdefg
+ab* xabyabbbz y $& ab
+ab* xayabbbz y $& a
+(ab|cd)e abcde y $&-$1 cde-cd
+[abhgefdc]ij hij y $& hij
+^(ab|cd)e abcde n x$1y xy
+(abc|)ef abcdef y $&-$1 ef-
+(a|b)c*d abcd y $&-$1 bcd-b
+(ab|ab*)bc abc y $&-$1 abc-a
+a([bc]*)c* abc y $&-$1 abc-bc
+a([bc]*)(c*d) abcd y $&-$1-$2 abcd-bc-d
+a([bc]+)(c*d) abcd y $&-$1-$2 abcd-bc-d
+a([bc]*)(c+d) abcd y $&-$1-$2 abcd-b-cd
+a[bcd]*dcdcde adcdcde y $& adcdcde
+a[bcd]+dcdcde adcdcde n - -
+(ab|a)b*c abc y $&-$1 abc-ab
+((a)(b)c)(d) abcd y $1-$2-$3-$4 abc-a-b-d
+[a-zA-Z_][a-zA-Z0-9_]* alpha y $& alpha
+^a(bc+|b[eh])g|.h$ abh y $&-$1 bh-
+(bc+d$|ef*g.|h?i(j|k)) effgz y $&-$1-$2 effgz-effgz-
+(bc+d$|ef*g.|h?i(j|k)) ij y $&-$1-$2 ij-ij-j
+(bc+d$|ef*g.|h?i(j|k)) effg n - -
+(bc+d$|ef*g.|h?i(j|k)) bcdd n - -
+(bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz-
+((((((((((a)))))))))) a y $10 a
+((((((((((a))))))))))\10 aa y $& aa
+((((((((((a))))))))))${bang} aa n - -
+((((((((((a))))))))))${bang} a! y $& a!
+(((((((((a))))))))) a y $& a
+multiple words of text uh-uh n - -
+multiple words multiple words, yeah y $& multiple words
+(.*)c(.*) abcde y $&-$1-$2 abcde-ab-de
+\((.*), (.*)\) (a, b) y ($2, $1) (b, a)
+[k] ab n - -
+abcd abcd y $&-\$&-\\$& abcd-$&-\abcd
+a(bc)d abcd y $1-\$1-\\$1 bc-$1-\bc
+a[-]?c ac y $& ac
+(abc)\1 abcabc y $1 abc
+([a-c]*)\1 abcabc y $1 abc
+\1 - c - /\1/: reference to nonexistent group
+\2 - c - /\2/: reference to nonexistent group
+(a)|\1 a y - -
+(a)|\1 x n - -
+(a)|\2 - c - /(a)|\2/: reference to nonexistent group
+(([a-c])b*?\2)* ababbbcbc y $&-$1-$2 ababb-bb-b
+(([a-c])b*?\2){3} ababbbcbc y $&-$1-$2 ababbbcbc-cbc-c
+((\3|b)\2(a)x)+ aaxabxbaxbbx n - -
+((\3|b)\2(a)x)+ aaaxabaxbaaxbbax y $&-$1-$2-$3 bbax-bbax-b-a
+((\3|b)\2(a)){2,} bbaababbabaaaaabbaaaabba y $&-$1-$2-$3 bbaaaabba-bba-b-a
+'abc'i ABC y $& ABC
+'abc'i XBC n - -
+'abc'i AXC n - -
+'abc'i ABX n - -
+'abc'i XABCY y $& ABC
+'abc'i ABABC y $& ABC
+'ab*c'i ABC y $& ABC
+'ab*bc'i ABC y $& ABC
+'ab*bc'i ABBC y $& ABBC
+'ab*?bc'i ABBBBC y $& ABBBBC
+'ab{0,}?bc'i ABBBBC y $& ABBBBC
+'ab+?bc'i ABBC y $& ABBC
+'ab+bc'i ABC n - -
+'ab+bc'i ABQ n - -
+'ab{1,}bc'i ABQ n - -
+'ab+bc'i ABBBBC y $& ABBBBC
+'ab{1,}?bc'i ABBBBC y $& ABBBBC
+'ab{1,3}?bc'i ABBBBC y $& ABBBBC
+'ab{3,4}?bc'i ABBBBC y $& ABBBBC
+'ab{4,5}?bc'i ABBBBC n - -
+'ab??bc'i ABBC y $& ABBC
+'ab??bc'i ABC y $& ABC
+'ab{0,1}?bc'i ABC y $& ABC
+'ab??bc'i ABBBBC n - -
+'ab??c'i ABC y $& ABC
+'ab{0,1}?c'i ABC y $& ABC
+'^abc$'i ABC y $& ABC
+'^abc$'i ABCC n - -
+'^abc'i ABCC y $& ABC
+'^abc$'i AABC n - -
+'abc$'i AABC y $& ABC
+'^'i ABC y $&
+'$'i ABC y $&
+'a.c'i ABC y $& ABC
+'a.c'i AXC y $& AXC
+'a.*?c'i AXYZC y $& AXYZC
+'a.*c'i AXYZD n - -
+'a[bc]d'i ABC n - -
+'a[bc]d'i ABD y $& ABD
+'a[b-d]e'i ABD n - -
+'a[b-d]e'i ACE y $& ACE
+'a[b-d]'i AAC y $& AC
+'a[-b]'i A- y $& A-
+'a[b-]'i A- y $& A-
+'a[b-a]'i - c - /a[b-a]/: invalid [] range in regexp
+'a[]b'i - c - /a[]b/: unmatched [] in regexp
+'a['i - c - /a[/: unmatched [] in regexp
+'a]'i A] y $& A]
+'a[]]b'i A]B y $& A]B
+'a[^bc]d'i AED y $& AED
+'a[^bc]d'i ABD n - -
+'a[^-b]c'i ADC y $& ADC
+'a[^-b]c'i A-C n - -
+'a[^]b]c'i A]C n - -
+'a[^]b]c'i ADC y $& ADC
+'ab|cd'i ABC y $& AB
+'ab|cd'i ABCD y $& AB
+'()ef'i DEF y $&-$1 EF-
+'*a'i - c - /*a/: ?+*{} follows nothing in regexp
+'(*)b'i - c - /(*)b/: ?+*{} follows nothing in regexp
+'$b'i B n - -
+'a\'i - c - Search pattern not terminated
+'a\(b'i A(B y $&-$1 A(B-
+'a\(*b'i AB y $& AB
+'a\(*b'i A((B y $& A((B
+'a\\b'i A\B y $& A\B
+'abc)'i - c - /abc)/: unmatched () in regexp
+'(abc'i - c - /(abc/: unmatched () in regexp
+'((a))'i ABC y $&-$1-$2 A-A-A
+'(a)b(c)'i ABC y $&-$1-$2 ABC-A-C
+'a+b+c'i AABBABC y $& ABC
+'a{1,}b{1,}c'i AABBABC y $& ABC
+'a**'i - c - /a**/: nested *?+ in regexp
+'a.+?c'i ABCABC y $& ABC
+'a.*?c'i ABCABC y $& ABC
+'a.{0,5}?c'i ABCABC y $& ABC
+'(a+|b)*'i AB y $&-$1 AB-B
+'(a+|b){0,}'i AB y $&-$1 AB-B
+'(a+|b)+'i AB y $&-$1 AB-B
+'(a+|b){1,}'i AB y $&-$1 AB-B
+'(a+|b)?'i AB y $&-$1 A-A
+'(a+|b){0,1}'i AB y $&-$1 A-A
+'(a+|b){0,1}?'i AB y $&-$1 -
+')('i - c - /)(/: unmatched () in regexp
+'[^ab]*'i CDE y $& CDE
+'abc'i n - -
+'a*'i y $&
+'([abc])*d'i ABBBCD y $&-$1 ABBBCD-C
+'([abc])*bcd'i ABCD y $&-$1 ABCD-A
+'a|b|c|d|e'i E y $& E
+'(a|b|c|d|e)f'i EF y $&-$1 EF-E
+'abcd*efg'i ABCDEFG y $& ABCDEFG
+'ab*'i XABYABBBZ y $& AB
+'ab*'i XAYABBBZ y $& A
+'(ab|cd)e'i ABCDE y $&-$1 CDE-CD
+'[abhgefdc]ij'i HIJ y $& HIJ
+'^(ab|cd)e'i ABCDE n x$1y XY
+'(abc|)ef'i ABCDEF y $&-$1 EF-
+'(a|b)c*d'i ABCD y $&-$1 BCD-B
+'(ab|ab*)bc'i ABC y $&-$1 ABC-A
+'a([bc]*)c*'i ABC y $&-$1 ABC-BC
+'a([bc]*)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D
+'a([bc]+)(c*d)'i ABCD y $&-$1-$2 ABCD-BC-D
+'a([bc]*)(c+d)'i ABCD y $&-$1-$2 ABCD-B-CD
+'a[bcd]*dcdcde'i ADCDCDE y $& ADCDCDE
+'a[bcd]+dcdcde'i ADCDCDE n - -
+'(ab|a)b*c'i ABC y $&-$1 ABC-AB
+'((a)(b)c)(d)'i ABCD y $1-$2-$3-$4 ABC-A-B-D
+'[a-zA-Z_][a-zA-Z0-9_]*'i ALPHA y $& ALPHA
+'^a(bc+|b[eh])g|.h$'i ABH y $&-$1 BH-
+'(bc+d$|ef*g.|h?i(j|k))'i EFFGZ y $&-$1-$2 EFFGZ-EFFGZ-
+'(bc+d$|ef*g.|h?i(j|k))'i IJ y $&-$1-$2 IJ-IJ-J
+'(bc+d$|ef*g.|h?i(j|k))'i EFFG n - -
+'(bc+d$|ef*g.|h?i(j|k))'i BCDD n - -
+'(bc+d$|ef*g.|h?i(j|k))'i REFFGZ y $&-$1-$2 EFFGZ-EFFGZ-
+'((((((((((a))))))))))'i A y $10 A
+'((((((((((a))))))))))\10'i AA y $& AA
+'((((((((((a))))))))))${bang}'i AA n - -
+'((((((((((a))))))))))${bang}'i A! y $& A!
+'(((((((((a)))))))))'i A y $& A
+'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))'i A y $1 A
+'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))'i C y $1 C
+'multiple words of text'i UH-UH n - -
+'multiple words'i MULTIPLE WORDS, YEAH y $& MULTIPLE WORDS
+'(.*)c(.*)'i ABCDE y $&-$1-$2 ABCDE-AB-DE
+'\((.*), (.*)\)'i (A, B) y ($2, $1) (B, A)
+'[k]'i AB n - -
+'abcd'i ABCD y $&-\$&-\\$& ABCD-$&-\ABCD
+'a(bc)d'i ABCD y $1-\$1-\\$1 BC-$1-\BC
+'a[-]?c'i AC y $& AC
+'(abc)\1'i ABCABC y $1 ABC
+'([a-c]*)\1'i ABCABC y $1 ABC
+a(?!b). abad y $& ad
+a(?=d). abad y $& ad
+a(?=c|d). abad y $& ad
+a(?:b|c|d)(.) ace y $1 e
+a(?:b|c|d)*(.) ace y $1 e
+a(?:b|c|d)+?(.) ace y $1 e
+a(?:b|c|d)+?(.) acdbcdbe y $1 d
+a(?:b|c|d)+(.) acdbcdbe y $1 e
+a(?:b|c|d){2}(.) acdbcdbe y $1 b
+a(?:b|c|d){4,5}(.) acdbcdbe y $1 b
+a(?:b|c|d){4,5}?(.) acdbcdbe y $1 d
+((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar
+:(?: - c - /(?/: Sequence (? incomplete
+a(?:b|c|d){6,7}(.) acdbcdbe y $1 e
+a(?:b|c|d){6,7}?(.) acdbcdbe y $1 e
+a(?:b|c|d){5,6}(.) acdbcdbe y $1 e
+a(?:b|c|d){5,6}?(.) acdbcdbe y $1 b
+a(?:b|c|d){5,7}(.) acdbcdbe y $1 e
+a(?:b|c|d){5,7}?(.) acdbcdbe y $1 b
+a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce
+^(.+)?B AB y $1 A
+^([^a-z])|(\^)$ . y $1 .
+^[<>]& <&OUT y $& <&
+^(a\1?){4}$ aaaaaaaaaa y $1 aaaa
+^(a\1?){4}$ aaaaaaaaa n - -
+^(a\1?){4}$ aaaaaaaaaaa n - -
+^(a(?(1)\1)){4}$ aaaaaaaaaa y $1 aaaa
+^(a(?(1)\1)){4}$ aaaaaaaaa n - -
+^(a(?(1)\1)){4}$ aaaaaaaaaaa n - -
+(?:(f)(o)(o)|(b)(a)(r))* foobar y $1:$2:$3:$4:$5:$6 f:o:o:b:a:r
+(?<=a)b ab y $& b
+(?<=a)b cb n - -
+(?<=a)b b n - -
+(?<!c)b ab y $& b
+(?<!c)b cb n - -
+(?<!c)b b y - -
+(?<!c)b b y $& b
+(?<%)b - c - /(?<%)b/: Sequence (?%...) not recognized
+(?:..)*a aba y $& aba
+(?:..)*?a aba y $& a
+^(?:b|a(?=(.)))*\1 abc y $& ab
+^(){3,5} abc y a$1 a
+^(a+)*ax aax y $1 a
+^((a|b)+)*ax aax y $1 a
+^((a|bc)+)*ax aax y $1 a
+(a|x)*ab cab y y$1 y
+(a)*ab cab y y$1 y
+(?:(?i)a)b ab y $& ab
+((?i)a)b ab y $&:$1 ab:a
+(?:(?i)a)b Ab y $& Ab
+((?i)a)b Ab y $&:$1 Ab:A
+(?:(?i)a)b aB n - -
+((?i)a)b aB n - -
+(?i:a)b ab y $& ab
+((?i:a))b ab y $&:$1 ab:a
+(?i:a)b Ab y $& Ab
+((?i:a))b Ab y $&:$1 Ab:A
+(?i:a)b aB n - -
+((?i:a))b aB n - -
+'(?:(?-i)a)b'i ab y $& ab
+'((?-i)a)b'i ab y $&:$1 ab:a
+'(?:(?-i)a)b'i aB y $& aB
+'((?-i)a)b'i aB y $&:$1 aB:a
+'(?:(?-i)a)b'i Ab n - -
+'((?-i)a)b'i Ab n - -
+'(?:(?-i)a)b'i aB y $& aB
+'((?-i)a)b'i aB y $1 a
+'(?:(?-i)a)b'i AB n - -
+'((?-i)a)b'i AB n - -
+'(?-i:a)b'i ab y $& ab
+'((?-i:a))b'i ab y $&:$1 ab:a
+'(?-i:a)b'i aB y $& aB
+'((?-i:a))b'i aB y $&:$1 aB:a
+'(?-i:a)b'i Ab n - -
+'((?-i:a))b'i Ab n - -
+'(?-i:a)b'i aB y $& aB
+'((?-i:a))b'i aB y $1 a
+'(?-i:a)b'i AB n - -
+'((?-i:a))b'i AB n - -
+'((?-i:a.))b'i a\nB n - -
+'((?s-i:a.))b'i a\nB y $1 a\n
+'((?s-i:a.))b'i B\nB n - -
+(?:c|d)(?:)(?:a(?:)(?:b)(?:b(?:))(?:b(?:)(?:b))) cabbbb y $& cabbbb
+(?:c|d)(?:)(?:aaaaaaaa(?:)(?:bbbbbbbb)(?:bbbbbbbb(?:))(?:bbbbbbbb(?:)(?:bbbbbbbb))) caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb y $& caaaaaaaabbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+'(ab)\d\1'i Ab4ab y $1 Ab
+'(ab)\d\1'i ab4Ab y $1 ab
+foo\w*\d{4}baz foobar1234baz y $& foobar1234baz
+a(?{})b cabd y $& ab
+a(?{)b - c - /a(?{)b/: Sequence (?{...}) not terminated or not {}-balanced
+a(?{{})b - c - /a(?{{})b/: Sequence (?{...}) not terminated or not {}-balanced
+a(?{}})b - c - /a(?{}})b/: Sequence (?{...}) not terminated or not {}-balanced
+a(?{"{"})b - c - /a(?{"{"})b/: Sequence (?{...}) not terminated or not {}-balanced
+a(?{"\{"})b cabd y $& ab
+a(?{"{"}})b - c - Unmatched right bracket
+a(?{$bl="\{"}).b caxbd y $bl {
+x(~~)*(?:(?:F)?)? x~~ y - -
+^a(?#xxx){3}c aaac y $& aaac
+'^a (?#xxx) (?#yyy) {3}c'x aaac y $& aaac
+(?<![cd])b dbcb n - -
+(?<![cd])[ab] dbaacb y $& a
+(?<!(c|d))b dbcb n - -
+(?<!(c|d))[ab] dbaacb y $& a
+(?<!cd)[ab] cdaccb y $& b
+^(?:a?b?)*$ a-- n - -
+((?s)^a(.))((?m)^b$) a\nb\nc\n y $1;$2;$3 a\n;\n;b
+((?m)^b$) a\nb\nc\n y $1 b
+(?m)^b a\nb\n y $& b
+(?m)^(b) a\nb\n y $1 b
+((?m)^b) a\nb\n y $1 b
+\n((?m)^b) a\nb\n y $1 b
+((?s).)c(?!.) a\nb\nc\n y $1 \n
+((?s).)c(?!.) a\nb\nc\n y $1:$& \n:\nc
+((?s)b.)c(?!.) a\nb\nc\n y $1 b\n
+((?s)b.)c(?!.) a\nb\nc\n y $1:$& b\n:b\nc
+^b a\nb\nc\n n - -
+()^b a\nb\nc\n n - -
+((?m)^b) a\nb\nc\n y $1 b
+(?(1)a|b) a n - -
+(?(1)b|a) a y $& a
+(x)?(?(1)a|b) a n - -
+(x)?(?(1)b|a) a y $& a
+()?(?(1)b|a) a y $& a
+()(?(1)b|a) a n - -
+()?(?(1)a|b) a y $& a
+^(\()?blah(?(1)(\)))$ (blah) y $2 )
+^(\()?blah(?(1)(\)))$ blah y ($2) ()
+^(\()?blah(?(1)(\)))$ blah) n - -
+^(\()?blah(?(1)(\)))$ (blah n - -
+^(\(+)?blah(?(1)(\)))$ (blah) y $2 )
+^(\(+)?blah(?(1)(\)))$ blah y ($2) ()
+^(\(+)?blah(?(1)(\)))$ blah) n - -
+^(\(+)?blah(?(1)(\)))$ (blah n - -
+(?(1?)a|b) a c - /(?(1?)a|b)/: Switch (?(number? not recognized
+(?(1)a|b|c) a c - /(?(1)a|b|c)/: Switch (?(condition)... contains too many branches
+(?(?{0})a|b) a n - -
+(?(?{0})b|a) a y $& a
+(?(?{1})b|a) a n - -
+(?(?{1})a|b) a y $& a
+(?(?!a)a|b) a n - -
+(?(?!a)b|a) a y $& a
+(?(?=a)b|a) a n - -
+(?(?=a)a|b) a y $& a
+(?=(a+?))(\1ab) aaab y $2 aab
+^(?=(a+?))\1ab aaab n - -
+(\w+:)+ one: y $1 one:
+$(?<=^(a)) a y $1 a
+(?=(a+?))(\1ab) aaab y $2 aab
+^(?=(a+?))\1ab aaab n - -
+([\w:]+::)?(\w+)$ abcd: n - -
+([\w:]+::)?(\w+)$ abcd y $1-$2 -abcd
+([\w:]+::)?(\w+)$ xy:z:::abcd y $1-$2 xy:z:::-abcd
+^[^bcd]*(c+) aexycd y $1 c
+(a*)b+ caab y $1 aa
+([\w:]+::)?(\w+)$ abcd: n - -
+([\w:]+::)?(\w+)$ abcd y $1-$2 -abcd
+([\w:]+::)?(\w+)$ xy:z:::abcd y $1-$2 xy:z:::-abcd
+^[^bcd]*(c+) aexycd y $1 c
+(?{$a=2})a*aa(?{local$a=$a+1})k*c(?{$b=$a}) yaaxxaaaacd y $b 3
+(?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a}) yaaxxaaaacd y $b 4
+(>a+)ab aaab n - -
+(?>a+)b aaab y - -
+([[:]+) a:[b]: y $1 :[
+([[=]+) a=[b]= y $1 =[
+([[.]+) a.[b]. y $1 .[
+[a[:xyz: - c - /[a[:xyz:/: unmatched [] in regexp
+[a[:xyz:] - c - /[a[:xyz:]/: unmatched [] in regexp
+([a[:xyz:]b]+) pbaq y $1 ba
+((?>a+)b) aaab y $1 aaab
+(?>(a+))b aaab y $1 aaa
+((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x
+(?<=x+)y - c - /(?<=x+)y/: variable length lookbehind not implemented
+a{37,17} - c - /a{37,17}/: Can't do {n,m} with n > m
+a\Z a\nb\n n - -
+b\Z a\nb\n y - -
+b\z a\nb\n n - -
+b\Z a\nb y - -
+b\z a\nb y - -
diff --git a/contrib/perl5/t/op/read.t b/contrib/perl5/t/op/read.t
new file mode 100755
index 000000000000..2746970d157d
--- /dev/null
+++ b/contrib/perl5/t/op/read.t
@@ -0,0 +1,19 @@
+#!./perl
+
+# $RCSfile: read.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:17 $
+
+print "1..4\n";
+
+
+open(FOO,'op/read.t') || open(FOO,'t/op/read.t') || die "Can't open op.read";
+seek(FOO,4,0);
+$got = read(FOO,$buf,4);
+
+print ($got == 4 ? "ok 1\n" : "not ok 1\n");
+print ($buf eq "perl" ? "ok 2\n" : "not ok 2 :$buf:\n");
+
+seek (FOO,0,2) || seek(FOO,20000,0);
+$got = read(FOO,$buf,4);
+
+print ($got == 0 ? "ok 3\n" : "not ok 3\n");
+print ($buf eq "" ? "ok 4\n" : "not ok 4\n");
diff --git a/contrib/perl5/t/op/readdir.t b/contrib/perl5/t/op/readdir.t
new file mode 100755
index 000000000000..ca19ebc7db47
--- /dev/null
+++ b/contrib/perl5/t/op/readdir.t
@@ -0,0 +1,25 @@
+#!./perl
+
+eval 'opendir(NOSUCH, "no/such/directory");';
+if ($@) { print "1..0\n"; exit; }
+
+print "1..3\n";
+
+if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; }
+@D = grep(/^[^\.].*\.t$/i, readdir(OP));
+closedir(OP);
+
+if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; }
+
+@R = sort @D;
+@G = sort <op/*.t>;
+if ($G[0] =~ m#.*\](\w+\.t)#i) {
+ # grep is to convert filespecs returned from glob under VMS to format
+ # identical to that returned by readdir
+ @G = grep(s#.*\](\w+\.t).*#op/$1#i,<op/*.t>);
+}
+while (@R && @G && "op/".$R[0] eq $G[0]) {
+ shift(@R);
+ shift(@G);
+}
+if (@R == 0 && @G == 0) { print "ok 3\n"; } else { print "not ok 3\n"; }
diff --git a/contrib/perl5/t/op/recurse.t b/contrib/perl5/t/op/recurse.t
new file mode 100755
index 000000000000..6594940a9033
--- /dev/null
+++ b/contrib/perl5/t/op/recurse.t
@@ -0,0 +1,86 @@
+#!./perl
+
+#
+# test recursive functions.
+#
+
+print "1..23\n";
+
+sub gcd ($$) {
+ return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]);
+ return gcd($_[0], $_[1] - $_[0]) if ($_[0] < $_[1]);
+ $_[0];
+}
+
+sub factorial ($) {
+ $_[0] < 2 ? 1 : $_[0] * factorial($_[0] - 1);
+}
+
+sub fibonacci ($) {
+ $_[0] < 2 ? 1 : fibonacci($_[0] - 2) + fibonacci($_[0] - 1);
+}
+
+# Highly recursive, highly aggressive.
+# Kids, don't try this at home.
+#
+# For example ackermann(4,1) will take quite a long time.
+# It will simply eat away your memory. Trust me.
+
+sub ackermann ($$) {
+ return $_[1] + 1 if ($_[0] == 0);
+ return ackermann($_[0] - 1, 1) if ($_[1] == 0);
+ ackermann($_[0] - 1, ackermann($_[0], $_[1] - 1));
+}
+
+# Highly recursive, highly boring.
+
+sub takeuchi ($$$) {
+ $_[1] < $_[0] ?
+ takeuchi(takeuchi($_[0] - 1, $_[1], $_[2]),
+ takeuchi($_[1] - 1, $_[2], $_[0]),
+ takeuchi($_[2] - 1, $_[0], $_[1]))
+ : $_[2];
+}
+
+print 'not ' unless (($d = gcd(1147, 1271)) == 31);
+print "ok 1\n";
+print "# gcd(1147, 1271) = $d\n";
+
+print 'not ' unless (($d = gcd(1908, 2016)) == 36);
+print "ok 2\n";
+print "# gcd(1908, 2016) = $d\n";
+
+print 'not ' unless (($f = factorial(10)) == 3628800);
+print "ok 3\n";
+print "# factorial(10) = $f\n";
+
+print 'not ' unless (($f = factorial(factorial(3))) == 720);
+print "ok 4\n";
+print "# factorial(factorial(3)) = $f\n";
+
+print 'not ' unless (($f = fibonacci(10)) == 89);
+print "ok 5\n";
+print "# fibonacci(10) = $f\n";
+
+print 'not ' unless (($f = fibonacci(fibonacci(7))) == 17711);
+print "ok 6\n";
+print "# fibonacci(fibonacci(7)) = $f\n";
+
+$i = 7;
+
+@ack = qw(1 2 3 4 2 3 4 5 3 5 7 9 5 13 29 61);
+
+for $x (0..3) {
+ for $y (0..3) {
+ $a = ackermann($x, $y);
+ print 'not ' unless ($a == shift(@ack));
+ print "ok ", $i++, "\n";
+ print "# ackermann($x, $y) = $a\n";
+ }
+}
+
+($x, $y, $z) = (18, 12, 6);
+
+print 'not ' unless (($t = takeuchi($x, $y, $z)) == $z + 1);
+print "ok ", $i++, "\n";
+print "# takeuchi($x, $y, $z) = $t\n";
diff --git a/contrib/perl5/t/op/ref.t b/contrib/perl5/t/op/ref.t
new file mode 100755
index 000000000000..1d70f9fd4c81
--- /dev/null
+++ b/contrib/perl5/t/op/ref.t
@@ -0,0 +1,287 @@
+#!./perl
+
+print "1..55\n";
+
+# Test glob operations.
+
+$bar = "ok 1\n";
+$foo = "ok 2\n";
+{
+ local(*foo) = *bar;
+ print $foo;
+}
+print $foo;
+
+$baz = "ok 3\n";
+$foo = "ok 4\n";
+{
+ local(*foo) = 'baz';
+ print $foo;
+}
+print $foo;
+
+$foo = "ok 6\n";
+{
+ local(*foo);
+ print $foo;
+ $foo = "ok 5\n";
+ print $foo;
+}
+print $foo;
+
+# Test fake references.
+
+$baz = "ok 7\n";
+$bar = 'baz';
+$foo = 'bar';
+print $$$foo;
+
+# Test real references.
+
+$FOO = \$BAR;
+$BAR = \$BAZ;
+$BAZ = "ok 8\n";
+print $$$FOO;
+
+# Test references to real arrays.
+
+@ary = (9,10,11,12);
+$ref[0] = \@a;
+$ref[1] = \@b;
+$ref[2] = \@c;
+$ref[3] = \@d;
+for $i (3,1,2,0) {
+ push(@{$ref[$i]}, "ok $ary[$i]\n");
+}
+print @a;
+print ${$ref[1]}[0];
+print @{$ref[2]}[0];
+print @{'d'};
+
+# Test references to references.
+
+$refref = \\$x;
+$x = "ok 13\n";
+print $$$refref;
+
+# Test nested anonymous lists.
+
+$ref = [[],2,[3,4,5,]];
+print scalar @$ref == 3 ? "ok 14\n" : "not ok 14\n";
+print $$ref[1] == 2 ? "ok 15\n" : "not ok 15\n";
+print ${$$ref[2]}[2] == 5 ? "ok 16\n" : "not ok 16\n";
+print scalar @{$$ref[0]} == 0 ? "ok 17\n" : "not ok 17\n";
+
+print $ref->[1] == 2 ? "ok 18\n" : "not ok 18\n";
+print $ref->[2]->[0] == 3 ? "ok 19\n" : "not ok 19\n";
+
+# Test references to hashes of references.
+
+$refref = \%whatever;
+$refref->{"key"} = $ref;
+print $refref->{"key"}->[2]->[0] == 3 ? "ok 20\n" : "not ok 20\n";
+
+# Test to see if anonymous subarrays spring into existence.
+
+$spring[5]->[0] = 123;
+$spring[5]->[1] = 456;
+push(@{$spring[5]}, 789);
+print join(':',@{$spring[5]}) eq "123:456:789" ? "ok 21\n" : "not ok 21\n";
+
+# Test to see if anonymous subhashes spring into existence.
+
+@{$spring2{"foo"}} = (1,2,3);
+$spring2{"foo"}->[3] = 4;
+print join(':',@{$spring2{"foo"}}) eq "1:2:3:4" ? "ok 22\n" : "not ok 22\n";
+
+# Test references to subroutines.
+
+sub mysub { print "ok 23\n" }
+$subref = \&mysub;
+&$subref;
+
+$subrefref = \\&mysub2;
+$$subrefref->("ok 24\n");
+sub mysub2 { print shift }
+
+# Test the ref operator.
+
+print ref $subref eq CODE ? "ok 25\n" : "not ok 25\n";
+print ref $ref eq ARRAY ? "ok 26\n" : "not ok 26\n";
+print ref $refref eq HASH ? "ok 27\n" : "not ok 27\n";
+
+# Test anonymous hash syntax.
+
+$anonhash = {};
+print ref $anonhash eq HASH ? "ok 28\n" : "not ok 28\n";
+$anonhash2 = {FOO => BAR, ABC => XYZ,};
+print join('', sort values %$anonhash2) eq BARXYZ ? "ok 29\n" : "not ok 29\n";
+
+# Test bless operator.
+
+package MYHASH;
+
+$object = bless $main'anonhash2;
+print ref $object eq MYHASH ? "ok 30\n" : "not ok 30\n";
+print $object->{ABC} eq XYZ ? "ok 31\n" : "not ok 31\n";
+
+$object2 = bless {};
+print ref $object2 eq MYHASH ? "ok 32\n" : "not ok 32\n";
+
+# Test ordinary call on object method.
+
+&mymethod($object,33);
+
+sub mymethod {
+ local($THIS, @ARGS) = @_;
+ die 'Got a "' . ref($THIS). '" instead of a MYHASH'
+ unless ref $THIS eq MYHASH;
+ print $THIS->{FOO} eq BAR ? "ok $ARGS[0]\n" : "not ok $ARGS[0]\n";
+}
+
+# Test automatic destructor call.
+
+$string = "not ok 34\n";
+$object = "foo";
+$string = "ok 34\n";
+$main'anonhash2 = "foo";
+$string = "";
+
+DESTROY {
+ return unless $string;
+ print $string;
+
+ # Test that the object has not already been "cursed".
+ print ref shift ne HASH ? "ok 35\n" : "not ok 35\n";
+}
+
+# Now test inheritance of methods.
+
+package OBJ;
+
+@ISA = (BASEOBJ);
+
+$main'object = bless {FOO => foo, BAR => bar};
+
+package main;
+
+# Test arrow-style method invocation.
+
+print $object->doit("BAR") eq bar ? "ok 36\n" : "not ok 36\n";
+
+# Test indirect-object-style method invocation.
+
+$foo = doit $object "FOO";
+print $foo eq foo ? "ok 37\n" : "not ok 37\n";
+
+sub BASEOBJ'doit {
+ local $ref = shift;
+ die "Not an OBJ" unless ref $ref eq OBJ;
+ $ref->{shift()};
+}
+
+package UNIVERSAL;
+@ISA = 'LASTCHANCE';
+
+package LASTCHANCE;
+sub foo { print $_[1] }
+
+package WHATEVER;
+foo WHATEVER "ok 38\n";
+
+#
+# test the \(@foo) construct
+#
+package main;
+@foo = (1,2,3);
+@bar = \(@foo);
+@baz = \(1,@foo,@bar);
+print @bar == 3 ? "ok 39\n" : "not ok 39\n";
+print grep(ref($_), @bar) == 3 ? "ok 40\n" : "not ok 40\n";
+print @baz == 3 ? "ok 41\n" : "not ok 41\n";
+
+my(@fuu) = (1,2,3);
+my(@baa) = \(@fuu);
+my(@bzz) = \(1,@fuu,@baa);
+print @baa == 3 ? "ok 42\n" : "not ok 42\n";
+print grep(ref($_), @baa) == 3 ? "ok 43\n" : "not ok 43\n";
+print @bzz == 3 ? "ok 44\n" : "not ok 44\n";
+
+# test for proper destruction of lexical objects
+
+sub larry::DESTROY { print "# larry\nok 45\n"; }
+sub curly::DESTROY { print "# curly\nok 46\n"; }
+sub moe::DESTROY { print "# moe\nok 47\n"; }
+
+{
+ my ($joe, @curly, %larry);
+ my $moe = bless \$joe, 'moe';
+ my $curly = bless \@curly, 'curly';
+ my $larry = bless \%larry, 'larry';
+ print "# leaving block\n";
+}
+
+print "# left block\n";
+
+# another glob test
+
+$foo = "not ok 48";
+{ local(*bar) = "foo" }
+$bar = "ok 48";
+local(*bar) = *bar;
+print "$bar\n";
+
+$var = "ok 49";
+$_ = \$var;
+print $$_,"\n";
+
+# test if reblessing during destruction results in more destruction
+
+{
+ package A;
+ sub new { bless {}, shift }
+ DESTROY { print "# destroying 'A'\nok 51\n" }
+ package B;
+ sub new { bless {}, shift }
+ DESTROY { print "# destroying 'B'\nok 50\n"; bless shift, 'A' }
+ package main;
+ my $b = B->new;
+}
+
+# test if $_[0] is properly protected in DESTROY()
+
+{
+ my $i = 0;
+ local $SIG{'__DIE__'} = sub {
+ my $m = shift;
+ if ($i++ > 4) {
+ print "# infinite recursion, bailing\nnot ok 52\n";
+ exit 1;
+ }
+ print "# $m";
+ if ($m =~ /^Modification of a read-only/) { print "ok 52\n" }
+ };
+ package C;
+ sub new { bless {}, shift }
+ DESTROY { $_[0] = 'foo' }
+ {
+ print "# should generate an error...\n";
+ my $c = C->new;
+ }
+ print "# good, didn't recurse\n";
+}
+
+# test global destruction
+
+package FINALE;
+
+{
+ $ref3 = bless ["ok 55\n"]; # package destruction
+ my $ref2 = bless ["ok 54\n"]; # lexical destruction
+ local $ref1 = bless ["ok 53\n"]; # dynamic destruction
+ 1; # flush any temp values on stack
+}
+
+DESTROY {
+ print $_[0][0];
+}
diff --git a/contrib/perl5/t/op/regexp.t b/contrib/perl5/t/op/regexp.t
new file mode 100755
index 000000000000..11b3ee31da24
--- /dev/null
+++ b/contrib/perl5/t/op/regexp.t
@@ -0,0 +1,97 @@
+#!./perl
+
+# XXX known to leak scalars
+$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
+
+# The tests are in a separate file 't/op/re_tests'.
+# Each line in that file is a separate test.
+# There are five columns, separated by tabs.
+#
+# Column 1 contains the pattern, optionally enclosed in C<''>.
+# Modifiers can be put after the closing C<'>.
+#
+# Column 2 contains the string to be matched.
+#
+# Column 3 contains the expected result:
+# y expect a match
+# n expect no match
+# c expect an error
+#
+# Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
+#
+# Column 4 contains a string, usually C<$&>.
+#
+# Column 5 contains the expected result of double-quote
+# interpolating that string after the match, or start of error message.
+#
+# \n in the tests are interpolated, as are variables of the form ${\w+}.
+#
+# If you want to add a regular expression test that can't be expressed
+# in this format, don't add it here: put it in op/pat.t instead.
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+$iters = shift || 1; # Poor man performance suite, 10000 is OK.
+
+open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') ||
+ die "Can't open re_tests";
+
+while (<TESTS>) { }
+$numtests = $.;
+seek(TESTS,0,0);
+$. = 0;
+
+$bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
+
+$| = 1;
+print "1..$numtests\n# $iters iterations\n";
+TEST:
+while (<TESTS>) {
+ chomp;
+ s/\\n/\n/g;
+ ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_);
+ $input = join(':',$pat,$subject,$result,$repl,$expect);
+ infty_subst(\$pat);
+ infty_subst(\$expect);
+ $pat = "'$pat'" unless $pat =~ /^[:']/;
+ $pat =~ s/\\n/\n/g;
+ $pat =~ s/(\$\{\w+\})/$1/eeg;
+ $subject =~ s/\\n/\n/g;
+ $expect =~ s/\\n/\n/g;
+ $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
+ for $study ("", "study \$subject") {
+ $c = $iters;
+ eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";";
+ chomp( $err = $@ );
+ if ($result eq 'c') {
+ if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST }
+ last; # no need to study a syntax error
+ }
+ elsif ($@) {
+ print "not ok $. $input => error `$err'\n"; next TEST;
+ }
+ elsif ($result eq 'n') {
+ if ($match) { print "not ok $. ($study) $input => false positive\n"; next TEST }
+ }
+ else {
+ if (!$match || $got ne $expect) {
+ print "not ok $. ($study) $input => `$got', match=$match\n";
+ next TEST;
+ }
+ }
+ }
+ print "ok $.\n";
+}
+
+close(TESTS);
+
+sub infty_subst # Special-case substitution
+{ # of $reg_infty and friends
+ my $tp = shift;
+ $$tp =~ s/,\$reg_infty_m}/,$reg_infty_m}/o;
+ $$tp =~ s/,\$reg_infty_p}/,$reg_infty_p}/o;
+ $$tp =~ s/,\$reg_infty}/,$reg_infty}/o;
+}
diff --git a/contrib/perl5/t/op/regexp_noamp.t b/contrib/perl5/t/op/regexp_noamp.t
new file mode 100755
index 000000000000..03c19e95edc1
--- /dev/null
+++ b/contrib/perl5/t/op/regexp_noamp.t
@@ -0,0 +1,10 @@
+#!./perl
+
+$skip_amp = 1;
+for $file ('op/regexp.t', 't/op/regexp.t') {
+ if (-r $file) {
+ do $file;
+ exit;
+ }
+}
+die "Cannot find op/regexp.t or t/op/regexp.t\n";
diff --git a/contrib/perl5/t/op/repeat.t b/contrib/perl5/t/op/repeat.t
new file mode 100755
index 000000000000..54fa590836f5
--- /dev/null
+++ b/contrib/perl5/t/op/repeat.t
@@ -0,0 +1,42 @@
+#!./perl
+
+# $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $
+
+print "1..19\n";
+
+# compile time
+
+if ('-' x 5 eq '-----') {print "ok 1\n";} else {print "not ok 1\n";}
+if ('-' x 1 eq '-') {print "ok 2\n";} else {print "not ok 2\n";}
+if ('-' x 0 eq '') {print "ok 3\n";} else {print "not ok 3\n";}
+
+if ('ab' x 3 eq 'ababab') {print "ok 4\n";} else {print "not ok 4\n";}
+
+# run time
+
+$a = '-';
+if ($a x 5 eq '-----') {print "ok 5\n";} else {print "not ok 5\n";}
+if ($a x 1 eq '-') {print "ok 6\n";} else {print "not ok 6\n";}
+if ($a x 0 eq '') {print "ok 7\n";} else {print "not ok 7\n";}
+
+$a = 'ab';
+if ($a x 3 eq 'ababab') {print "ok 8\n";} else {print "not ok 8\n";}
+
+$a = 'xyz';
+$a x= 2;
+if ($a eq 'xyzxyz') {print "ok 9\n";} else {print "not ok 9\n";}
+$a x= 1;
+if ($a eq 'xyzxyz') {print "ok 10\n";} else {print "not ok 10\n";}
+$a x= 0;
+if ($a eq '') {print "ok 11\n";} else {print "not ok 11\n";}
+
+@x = (1,2,3);
+
+print join('', @x x 4) eq '3333' ? "ok 12\n" : "not ok 12\n";
+print join('', (@x) x 4) eq '123123123123' ? "ok 13\n" : "not ok 13\n";
+print join('', (@x,()) x 4) eq '123123123123' ? "ok 14\n" : "not ok 14\n";
+print join('', (@x,1) x 4) eq '1231123112311231' ? "ok 15\n" : "not ok 15\n";
+print join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n";
+print join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n";
+print join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n";
+print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n";
diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t
new file mode 100755
index 000000000000..307e2a0bb5b5
--- /dev/null
+++ b/contrib/perl5/t/op/runlevel.t
@@ -0,0 +1,317 @@
+#!./perl
+
+##
+## Many of these tests are originally from Michael Schroeder
+## <Michael.Schroeder@informatik.uni-erlangen.de>
+## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu>
+##
+
+chdir 't' if -d 't';
+@INC = "../lib";
+$Is_VMS = $^O eq 'VMS';
+$Is_MSWin32 = $^O eq 'MSWin32';
+$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
+
+$|=1;
+
+undef $/;
+@prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+$tmpfile = "runltmp000";
+1 while -f ++$tmpfile;
+END { if ($tmpfile) { 1 while unlink $tmpfile; } }
+
+for (@prgs){
+ my $switch = "";
+ if (s/^\s*(-\w+)//){
+ $switch = $1;
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ open TEST, ">$tmpfile";
+ print TEST "$prog\n";
+ close TEST;
+ my $results = $Is_VMS ?
+ `MCR $^X "-I[-.lib]" $switch $tmpfile` :
+ $Is_MSWin32 ?
+ `.\\perl -I../lib $switch $tmpfile 2>&1` :
+ `sh -c './perl $switch $tmpfile' 2>&1`;
+ my $status = $?;
+ $results =~ s/\n+$//;
+ # allow expected output to be written as if $prog is on STDIN
+ $results =~ s/runltmp\d+/-/g;
+ $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
+ $expected =~ s/\n+$//;
+ if ($results ne $expected) {
+ print STDERR "PROG: $switch\n$prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+}
+
+__END__
+@a = (1, 2, 3);
+{
+ @a = sort { last ; } @a;
+}
+EXPECT
+Can't "last" outside a block at - line 3.
+########
+package TEST;
+
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ eval 'die("test")';
+ print "still in fetch\n";
+ return ">$@<";
+}
+package main;
+
+tie $bar, TEST;
+print "- $bar\n";
+EXPECT
+still in fetch
+- >test at (eval 1) line 1.
+<
+########
+package TEST;
+
+sub TIESCALAR {
+ my $foo;
+ eval('die("foo\n")');
+ print "after eval\n";
+ return bless \$foo;
+}
+sub FETCH {
+ return "ZZZ";
+}
+
+package main;
+
+tie $bar, TEST;
+print "- $bar\n";
+print "OK\n";
+EXPECT
+after eval
+- ZZZ
+OK
+########
+package TEST;
+
+sub TIEHANDLE {
+ my $foo;
+ return bless \$foo;
+}
+sub PRINT {
+print STDERR "PRINT CALLED\n";
+(split(/./, 'x'x10000))[0];
+eval('die("test\n")');
+}
+
+package main;
+
+open FH, ">&STDOUT";
+tie *FH, TEST;
+print FH "OK\n";
+print STDERR "DONE\n";
+EXPECT
+PRINT CALLED
+DONE
+########
+sub warnhook {
+ print "WARNHOOK\n";
+ eval('die("foooo\n")');
+}
+$SIG{'__WARN__'} = 'warnhook';
+warn("dfsds\n");
+print "END\n";
+EXPECT
+WARNHOOK
+END
+########
+package TEST;
+
+use overload
+ "\"\"" => \&str
+;
+
+sub str {
+ eval('die("test\n")');
+ return "STR";
+}
+
+package main;
+
+$bar = bless {}, TEST;
+print "$bar\n";
+print "OK\n";
+EXPECT
+STR
+OK
+########
+sub foo {
+ $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+EXPECT
+0, 1, 2, 3
+########
+sub foo {
+ goto bar if $a == 0 || $b == 0;
+ $a <=> $b;
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+exit;
+bar:
+print "bar reached\n";
+EXPECT
+Can't "goto" outside a block at - line 2.
+########
+sub sortfn {
+ (split(/./, 'x'x10000))[0];
+ my (@y) = ( 4, 6, 5);
+ @y = sort { $a <=> $b } @y;
+ print "sortfn ".join(', ', @y)."\n";
+ return $_[0] <=> $_[1];
+}
+@x = ( 3, 2, 1 );
+@x = sort { &sortfn($a, $b) } @x;
+print "---- ".join(', ', @x)."\n";
+EXPECT
+sortfn 4, 5, 6
+sortfn 4, 5, 6
+sortfn 4, 5, 6
+---- 1, 2, 3
+########
+@a = (3, 2, 1);
+@a = sort { eval('die("no way")') , $a <=> $b} @a;
+print join(", ", @a)."\n";
+EXPECT
+1, 2, 3
+########
+@a = (1, 2, 3);
+foo:
+{
+ @a = sort { last foo; } @a;
+}
+EXPECT
+Label not found for "last foo" at - line 2.
+########
+package TEST;
+
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ next;
+ return "ZZZ";
+}
+sub STORE {
+}
+
+package main;
+
+tie $bar, TEST;
+{
+ print "- $bar\n";
+}
+print "OK\n";
+EXPECT
+Can't "next" outside a block at - line 8.
+########
+package TEST;
+
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ goto bbb;
+ return "ZZZ";
+}
+
+package main;
+
+tie $bar, TEST;
+print "- $bar\n";
+exit;
+bbb:
+print "bbb\n";
+EXPECT
+Can't find label bbb at - line 8.
+########
+sub foo {
+ $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+EXPECT
+0, 1, 2, 3
+########
+package TEST;
+sub TIESCALAR {
+ my $foo;
+ return bless \$foo;
+}
+sub FETCH {
+ return "fetch";
+}
+sub STORE {
+(split(/./, 'x'x10000))[0];
+}
+package main;
+tie $bar, TEST;
+$bar = "x";
+########
+package TEST;
+sub TIESCALAR {
+ my $foo;
+ next;
+ return bless \$foo;
+}
+package main;
+{
+tie $bar, TEST;
+}
+EXPECT
+Can't "next" outside a block at - line 4.
+########
+@a = (1, 2, 3);
+foo:
+{
+ @a = sort { exit(0) } @a;
+}
+END { print "foobar\n" }
+EXPECT
+foobar
+########
+$SIG{__DIE__} = sub {
+ print "In DIE\n";
+ $i = 0;
+ while (($p,$f,$l,$s) = caller(++$i)) {
+ print "$p|$f|$l|$s\n";
+ }
+};
+eval { die };
+&{sub { eval 'die' }}();
+sub foo { eval { die } } foo();
+EXPECT
+In DIE
+main|-|8|(eval)
+In DIE
+main|-|9|(eval)
+main|-|9|main::__ANON__
+In DIE
+main|-|10|(eval)
+main|-|10|main::foo
diff --git a/contrib/perl5/t/op/sleep.t b/contrib/perl5/t/op/sleep.t
new file mode 100755
index 000000000000..5f6c4c0bbbe9
--- /dev/null
+++ b/contrib/perl5/t/op/sleep.t
@@ -0,0 +1,8 @@
+#!./perl
+
+# $RCSfile: sleep.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:23 $
+
+print "1..1\n";
+
+$x = sleep 3;
+if ($x >= 2 && $x <= 10) {print "ok 1\n";} else {print "not ok 1 $x\n";}
diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t
new file mode 100755
index 000000000000..70341b9106b8
--- /dev/null
+++ b/contrib/perl5/t/op/sort.t
@@ -0,0 +1,127 @@
+#!./perl
+
+# $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $
+
+print "1..21\n";
+
+sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
+
+my $upperfirst = 'A' lt 'a';
+
+# Beware: in future this may become hairier because of possible
+# collation complications: qw(A a B c) can be sorted at least as
+# any of the following
+#
+# A a B b
+# A B a b
+# a b A B
+# a A b B
+#
+# All the above orders make sense.
+#
+# That said, EBCDIC sorts all small letters first, as opposed
+# to ASCII which sorts all big letters first.
+
+@harry = ('dog','cat','x','Cain','Abel');
+@george = ('gone','chased','yz','punished','Axed');
+
+$x = join('', sort @harry);
+$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
+print "# 1: x = '$x', expected = '$expected'\n";
+print ($x eq $expected ? "ok 1\n" : "not ok 1\n");
+
+$x = join('', sort( backwards @harry));
+$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
+print "# 2: x = '$x', expected = '$expected'\n";
+print ($x eq $expected ? "ok 2\n" : "not ok 2\n");
+
+$x = join('', sort @george, 'to', @harry);
+$expected = $upperfirst ?
+ 'AbelAxedCaincatchaseddoggonepunishedtoxyz' :
+ 'catchaseddoggonepunishedtoxyzAbelAxedCain' ;
+print "# 3: x = '$x', expected = '$expected'\n";
+print ($x eq $expected ?"ok 3\n":"not ok 3\n");
+
+@a = ();
+@b = reverse @a;
+print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n");
+
+@a = (1);
+@b = reverse @a;
+print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n");
+
+@a = (1,2);
+@b = reverse @a;
+print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n");
+
+@a = (1,2,3);
+@b = reverse @a;
+print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n");
+
+@a = (1,2,3,4);
+@b = reverse @a;
+print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n");
+
+@a = (10,2,3,4);
+@b = sort {$a <=> $b;} @a;
+print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n");
+
+$sub = 'backwards';
+$x = join('', sort $sub @harry);
+$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
+print "# 10: x = $x, expected = '$expected'\n";
+print ($x eq $expected ? "ok 10\n" : "not ok 10\n");
+
+# literals, combinations
+
+@b = sort (4,1,3,2);
+print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n");
+print "# x = '@b'\n";
+
+@b = sort grep { $_ } (4,1,3,2);
+print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n");
+print "# x = '@b'\n";
+
+@b = sort map { $_ } (4,1,3,2);
+print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n");
+print "# x = '@b'\n";
+
+@b = sort reverse (4,1,3,2);
+print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n");
+print "# x = '@b'\n";
+
+$^W = 0;
+# redefining sort sub inside the sort sub should fail
+sub twoface { *twoface = sub { $a <=> $b }; &twoface }
+eval { @b = sort twoface 4,1,3,2 };
+print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n");
+
+# redefining sort subs outside the sort should not fail
+eval { *twoface = sub { &backwards } };
+print $@ ? "not ok 16\n" : "ok 16\n";
+
+eval { @b = sort twoface 4,1,3,2 };
+print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n");
+
+*twoface = sub { *twoface = *backwards; $a <=> $b };
+eval { @b = sort twoface 4,1 };
+print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n");
+
+*twoface = sub {
+ eval 'sub twoface { $a <=> $b }';
+ die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n");
+ $a <=> $b;
+ };
+eval { @b = sort twoface 4,1 };
+print $@ ? "$@" : "not ok 19\n";
+
+eval <<'CODE';
+ my @result = sort main'backwards 'one', 'two';
+CODE
+print $@ ? "not ok 20\n# $@" : "ok 20\n";
+
+eval <<'CODE';
+ # "sort 'one', 'two'" should not try to parse "'one" as a sort sub
+ my @result = sort 'one', 'two';
+CODE
+print $@ ? "not ok 21\n# $@" : "ok 21\n";
diff --git a/contrib/perl5/t/op/splice.t b/contrib/perl5/t/op/splice.t
new file mode 100755
index 000000000000..06e350988d01
--- /dev/null
+++ b/contrib/perl5/t/op/splice.t
@@ -0,0 +1,34 @@
+#!./perl
+
+print "1..9\n";
+
+@a = (1..10);
+
+sub j { join(":",@_) }
+
+print "not " unless j(splice(@a,@a,0,11,12)) eq "" && j(@a) eq j(1..12);
+print "ok 1\n";
+
+print "not " unless j(splice(@a,-1)) eq "12" && j(@a) eq j(1..11);
+print "ok 2\n";
+
+print "not " unless j(splice(@a,0,1)) eq "1" && j(@a) eq j(2..11);
+print "ok 3\n";
+
+print "not " unless j(splice(@a,0,0,0,1)) eq "" && j(@a) eq j(0..11);
+print "ok 4\n";
+
+print "not " unless j(splice(@a,5,1,5)) eq "5" && j(@a) eq j(0..11);
+print "ok 5\n";
+
+print "not " unless j(splice(@a, 20, 0, 12, 13)) eq "" && j(@a) eq j(0..13);
+print "ok 6\n";
+
+print "not " unless j(splice(@a, -@a, @a, 1, 2, 3)) eq j(0..13) && j(@a) eq j(1..3);
+print "ok 7\n";
+
+print "not " unless j(splice(@a, 1, -1, 7, 7)) eq "2" && j(@a) eq j(1,7,7,3);
+print "ok 8\n";
+
+print "not " unless j(splice(@a,-3,-2,2)) eq j(7) && j(@a) eq j(1,2,7,3);
+print "ok 9\n";
diff --git a/contrib/perl5/t/op/split.t b/contrib/perl5/t/op/split.t
new file mode 100755
index 000000000000..7f0accea5eee
--- /dev/null
+++ b/contrib/perl5/t/op/split.t
@@ -0,0 +1,113 @@
+#!./perl
+
+# $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $
+
+print "1..25\n";
+
+$FS = ':';
+
+$_ = 'a:b:c';
+
+($a,$b,$c) = split($FS,$_);
+
+if (join(';',$a,$b,$c) eq 'a;b;c') {print "ok 1\n";} else {print "not ok 1\n";}
+
+@ary = split(/:b:/);
+if (join("$_",@ary) eq 'aa:b:cc') {print "ok 2\n";} else {print "not ok 2\n";}
+
+$_ = "abc\n";
+@xyz = (@ary = split(//));
+if (join(".",@ary) eq "a.b.c.\n") {print "ok 3\n";} else {print "not ok 3\n";}
+
+$_ = "a:b:c::::";
+@ary = split(/:/);
+if (join(".",@ary) eq "a.b.c") {print "ok 4\n";} else {print "not ok 4\n";}
+
+$_ = join(':',split(' '," a b\tc \t d "));
+if ($_ eq 'a:b:c:d') {print "ok 5\n";} else {print "not ok 5 #$_#\n";}
+
+$_ = join(':',split(/ */,"foo bar bie\tdoll"));
+if ($_ eq "f:o:o:b:a:r:b:i:e:\t:d:o:l:l")
+ {print "ok 6\n";} else {print "not ok 6\n";}
+
+$_ = join(':', 'foo', split(/ /,'a b c'), 'bar');
+if ($_ eq "foo:a:b::c:bar") {print "ok 7\n";} else {print "not ok 7 $_\n";}
+
+# Can we say how many fields to split to?
+$_ = join(':', split(' ','1 2 3 4 5 6', 3));
+print $_ eq '1:2:3 4 5 6' ? "ok 8\n" : "not ok 8 $_\n";
+
+# Can we do it as a variable?
+$x = 4;
+$_ = join(':', split(' ','1 2 3 4 5 6', $x));
+print $_ eq '1:2:3:4 5 6' ? "ok 9\n" : "not ok 9 $_\n";
+
+# Does the 999 suppress null field chopping?
+$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999));
+print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n";
+
+# Does assignment to a list imply split to one more field than that?
+if ($^O eq 'MSWin32') { $foo = `.\\perl -D1024 -e "(\$a,\$b) = split;" 2>&1` }
+else { $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1` }
+if ($foo =~ /DCL-W-NOCOMD/) {
+ $foo = `\$ mcr sys\$disk:[]perl. "-D1024" -e "(\$a,\$b) = split;"`;
+}
+print $foo =~ /DEBUGGING/ || $foo =~ /SV = IV\(3\)/ ? "ok 11\n" : "not ok 11\n";
+
+# Can we say how many fields to split to when assigning to a list?
+($a,$b) = split(' ','1 2 3 4 5 6', 2);
+$_ = join(':',$a,$b);
+print $_ eq '1:2 3 4 5 6' ? "ok 12\n" : "not ok 12 $_\n";
+
+# do subpatterns generate additional fields (without trailing nulls)?
+$_ = join '|', split(/,|(-)/, "1-10,20,,,");
+print $_ eq "1|-|10||20" ? "ok 13\n" : "not ok 13\n";
+
+# do subpatterns generate additional fields (with a limit)?
+$_ = join '|', split(/,|(-)/, "1-10,20,,,", 10);
+print $_ eq "1|-|10||20||||||" ? "ok 14\n" : "not ok 14\n";
+
+# is the 'two undefs' bug fixed?
+(undef, $a, undef, $b) = qw(1 2 3 4);
+print "$a|$b" eq "2|4" ? "ok 15\n" : "not ok 15\n";
+
+# .. even for locals?
+{
+ local(undef, $a, undef, $b) = qw(1 2 3 4);
+ print "$a|$b" eq "2|4" ? "ok 16\n" : "not ok 16\n";
+}
+
+# check splitting of null string
+$_ = join('|', split(/x/, '',-1), 'Z');
+print $_ eq "Z" ? "ok 17\n" : "#$_\nnot ok 17\n";
+
+$_ = join('|', split(/x/, '', 1), 'Z');
+print $_ eq "Z" ? "ok 18\n" : "#$_\nnot ok 18\n";
+
+$_ = join('|', split(/(p+)/,'',-1), 'Z');
+print $_ eq "Z" ? "ok 19\n" : "#$_\nnot ok 19\n";
+
+$_ = join('|', split(/.?/, '',-1), 'Z');
+print $_ eq "Z" ? "ok 20\n" : "#$_\nnot ok 20\n";
+
+
+# Are /^/m patterns scanned?
+$_ = join '|', split(/^a/m, "a b a\na d a", 20);
+print $_ eq "| b a\n| d a" ? "ok 21\n" : "not ok 21\n# `$_'\n";
+
+# Are /$/m patterns scanned?
+$_ = join '|', split(/a$/m, "a b a\na d a", 20);
+print $_ eq "a b |\na d |" ? "ok 22\n" : "not ok 22\n# `$_'\n";
+
+# Are /^/m patterns scanned?
+$_ = join '|', split(/^aa/m, "aa b aa\naa d aa", 20);
+print $_ eq "| b aa\n| d aa" ? "ok 23\n" : "not ok 23\n# `$_'\n";
+
+# Are /$/m patterns scanned?
+$_ = join '|', split(/aa$/m, "aa b aa\naa d aa", 20);
+print $_ eq "aa b |\naa d |" ? "ok 24\n" : "not ok 24\n# `$_'\n";
+
+# Greedyness:
+$_ = "a : b :c: d";
+@ary = split(/\s*:\s*/);
+if (($res = join(".",@ary)) eq "a.b.c.d") {print "ok 25\n";} else {print "not ok 25\n# res=`$res' != `a.b.c.d'\n";}
diff --git a/contrib/perl5/t/op/sprintf.t b/contrib/perl5/t/op/sprintf.t
new file mode 100755
index 000000000000..b9b4751c791d
--- /dev/null
+++ b/contrib/perl5/t/op/sprintf.t
@@ -0,0 +1,33 @@
+#!./perl
+
+# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $
+
+print "1..4\n";
+
+$^W = 1;
+$SIG{__WARN__} = sub {
+ if ($_[0] =~ /^Invalid conversion/) {
+ $w++;
+ } else {
+ warn @_;
+ }
+};
+
+$w = 0;
+$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,ord('A'),3.0999);
+if ($x eq ' hi 123 %foo 456 0A3.1' && $w == 0) {
+ print "ok 1\n";
+} else {
+ print "not ok 1 '$x'\n";
+}
+
+for $i (2 .. 4) {
+ $f = ('%6 .6s', '%6. 6s', '%6.6 s')[$i - 2];
+ $w = 0;
+ $x = sprintf($f, '');
+ if ($x eq $f && $w == 1) {
+ print "ok $i\n";
+ } else {
+ print "not ok $i '$x' '$f' '$w'\n";
+ }
+}
diff --git a/contrib/perl5/t/op/stat.t b/contrib/perl5/t/op/stat.t
new file mode 100755
index 000000000000..2207b40e309e
--- /dev/null
+++ b/contrib/perl5/t/op/stat.t
@@ -0,0 +1,252 @@
+#!./perl
+
+# $RCSfile: stat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:28 $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+
+print "1..58\n";
+
+$Is_MSWin32 = $^O eq 'MSWin32';
+$Is_Dos = $^O eq 'dos';
+$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32;
+chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`));
+
+$DEV = `ls -l /dev` unless $Is_Dosish;
+
+unlink "Op.stat.tmp";
+open(FOO, ">Op.stat.tmp");
+
+# hack to make Apollo update link count:
+$junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_Dos);
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat(FOO);
+if ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";}
+if ($Is_MSWin32 || ($mtime && $mtime == $ctime)) {print "ok 2\n";}
+else {print "# |$mtime| vs |$ctime|\nnot ok 2\n";}
+
+print FOO "Now is the time for all good men to come to.\n";
+close(FOO);
+
+sleep 2;
+
+if ($Is_Dosish) { unlink "Op.stat.tmp2" }
+else {
+ `rm -f Op.stat.tmp2;ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`;
+}
+
+($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
+ $blksize,$blocks) = stat('Op.stat.tmp');
+
+if ($Is_Dosish || $Config{dont_use_nlink})
+ {print "ok 3 # skipped: no link count\n";}
+elsif ($nlink == 2)
+ {print "ok 3\n";}
+else {print "# \$nlink is |$nlink|\nnot ok 3\n";}
+
+if ( $Is_Dosish
+ || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime) # Solaris tmpfs bug
+ || $cwd =~ m#/afs/#
+ || $^O eq 'amigaos') {
+ print "ok 4 # skipped: different semantic of mtime/ctime\n";
+}
+elsif ( ($mtime && $mtime != $ctime) ) {
+ print "ok 4\n";
+}
+else {
+ print "not ok 4\n";
+ print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n";
+ print "#4 of some sort. Building in /tmp sometimes has this problem.\n";
+}
+print "#4 :$mtime: should != :$ctime:\n";
+
+unlink "Op.stat.tmp";
+if ($Is_MSWin32) { open F, '>Op.stat.tmp' and close F }
+else { `touch Op.stat.tmp` }
+
+if (-z 'Op.stat.tmp') {print "ok 5\n";} else {print "not ok 5\n";}
+if (! -s 'Op.stat.tmp') {print "ok 6\n";} else {print "not ok 6\n";}
+
+$Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`;
+if (! -z 'Op.stat.tmp') {print "ok 7\n";} else {print "not ok 7\n";}
+if (-s 'Op.stat.tmp') {print "ok 8\n";} else {print "not ok 8\n";}
+
+unlink 'Op.stat.tmp';
+$olduid = $>; # can't test -r if uid == 0
+$Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`;
+chmod 0,'Op.stat.tmp';
+eval '$> = 1;'; # so switch uid (may not be implemented)
+if (!$> || $Is_Dos || ! -r 'Op.stat.tmp') {print "ok 9\n";} else {print "not ok 9\n";}
+if (!$> || ! -w 'Op.stat.tmp') {print "ok 10\n";} else {print "not ok 10\n";}
+eval '$> = $olduid;'; # switch uid back (may not be implemented)
+print "# olduid=$olduid, newuid=$>\n" unless ($> == $olduid);
+
+if (! -x 'Op.stat.tmp') {print "ok 11\n";}
+else {print "not ok 11\n";}
+
+foreach ((12,13,14,15,16,17)) {
+ print "ok $_\n"; #deleted tests
+}
+
+chmod 0700,'Op.stat.tmp';
+if (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";}
+if (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";}
+if ($Is_Dosish) {print "ok 20 # skipped: -x by extension\n";}
+elsif (-x 'Op.stat.tmp') {print "ok 20\n";}
+else {print "not ok 20\n";}
+
+if (-f 'Op.stat.tmp') {print "ok 21\n";} else {print "not ok 21\n";}
+if (! -d 'Op.stat.tmp') {print "ok 22\n";} else {print "not ok 22\n";}
+
+if (-d '.') {print "ok 23\n";} else {print "not ok 23\n";}
+if (! -f '.') {print "ok 24\n";} else {print "not ok 24\n";}
+
+if (!$Is_Dosish and `ls -l perl` =~ /^l.*->/) {
+ if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";}
+}
+else {
+ print "ok 25\n";
+}
+
+if (-o 'Op.stat.tmp') {print "ok 26\n";} else {print "not ok 26\n";}
+
+if (-e 'Op.stat.tmp') {print "ok 27\n";} else {print "not ok 27\n";}
+unlink 'Op.stat.tmp2';
+if (! -e 'Op.stat.tmp2') {print "ok 28\n";} else {print "not ok 28\n";}
+
+if ($Is_MSWin32 || $Is_Dos)
+ {print "ok 29\n";}
+elsif ($DEV !~ /\nc.* (\S+)\n/)
+ {print "ok 29\n";}
+elsif (-c "/dev/$1")
+ {print "ok 29\n";}
+else
+ {print "not ok 29\n";}
+if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";}
+
+if ($Is_MSWin32 || $Is_Dos)
+ {print "ok 31\n";}
+elsif ($DEV !~ /\ns.* (\S+)\n/)
+ {print "ok 31\n";}
+elsif (-S "/dev/$1")
+ {print "ok 31\n";}
+else
+ {print "not ok 31\n";}
+if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";}
+
+if ($Is_MSWin32 || $Is_Dos)
+ {print "ok 33\n";}
+elsif ($DEV !~ /\nb.* (\S+)\n/)
+ {print "ok 33\n";}
+elsif (-b "/dev/$1")
+ {print "ok 33\n";}
+else
+ {print "not ok 33\n";}
+if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";}
+
+if ($^O eq 'amigaos' or $Is_Dosish) {
+ print "ok 35 # skipped: no -u\n"; goto tty_test;
+}
+
+$cnt = $uid = 0;
+
+die "Can't run op/stat.t test 35 without pwd working" unless $cwd;
+($bin) = grep {-d} ($^O eq 'machten' ? qw(/usr/bin /bin) : qw(/bin /usr/bin))
+ or print ("not ok 35\n"), goto tty_test;
+opendir BIN, $bin or die "Can't opendir $bin: $!";
+while (defined($_ = readdir BIN)) {
+ $_ = "$bin/$_";
+ $cnt++;
+ $uid++ if -u;
+ last if $uid && $uid < $cnt;
+}
+closedir BIN;
+
+# I suppose this is going to fail somewhere...
+if ($uid > 0 && $uid < $cnt)
+ {print "ok 35\n";}
+else
+ {print "not ok 35 \n# ($uid $cnt)\n";}
+
+tty_test:
+
+# To assist in automated testing when a controlling terminal (/dev/tty)
+# may not be available (at, cron rsh etc), the PERL_SKIP_TTY_TEST env var
+# can be set to skip the tests that need a tty.
+unless($ENV{PERL_SKIP_TTY_TEST}) {
+ if ($Is_MSWin32) {
+ print "ok 36\n";
+ print "ok 37\n";
+ }
+ else {
+ unless (open(tty,"/dev/tty")) {
+ print STDERR "Can't open /dev/tty--run t/TEST outside of make.\n";
+ }
+ if (-t tty) {print "ok 36\n";} else {print "not ok 36\n";}
+ if (-c tty) {print "ok 37\n";} else {print "not ok 37\n";}
+ close(tty);
+ }
+ if (! -t tty) {print "ok 38\n";} else {print "not ok 38\n";}
+ if (-t) {print "ok 39\n";} else {print "not ok 39\n";}
+}
+else {
+ print "ok 36\n";
+ print "ok 37\n";
+ print "ok 38\n";
+ print "ok 39\n";
+}
+open(null,"/dev/null");
+if (! -t null || -e '/xenix' || $^O eq 'machten' || $Is_MSWin32)
+ {print "ok 40\n";} else {print "not ok 40\n";}
+close(null);
+
+# These aren't strictly "stat" calls, but so what?
+
+if (-T 'op/stat.t') {print "ok 41\n";} else {print "not ok 41\n";}
+if (! -B 'op/stat.t') {print "ok 42\n";} else {print "not ok 42\n";}
+
+if (-B './perl' || -B './perl.exe') {print "ok 43\n";} else {print "not ok 43\n";}
+if (! -T './perl' && ! -T './perl.exe') {print "ok 44\n";} else {print "not ok 44\n";}
+
+open(FOO,'op/stat.t');
+eval { -T FOO; };
+if ($@ =~ /not implemented/) {
+ print "# $@";
+ for (45 .. 54) {
+ print "ok $_\n";
+ }
+}
+else {
+ if (-T FOO) {print "ok 45\n";} else {print "not ok 45\n";}
+ if (! -B FOO) {print "ok 46\n";} else {print "not ok 46\n";}
+ $_ = <FOO>;
+ if (/perl/) {print "ok 47\n";} else {print "not ok 47\n";}
+ if (-T FOO) {print "ok 48\n";} else {print "not ok 48\n";}
+ if (! -B FOO) {print "ok 49\n";} else {print "not ok 49\n";}
+ close(FOO);
+
+ open(FOO,'op/stat.t');
+ $_ = <FOO>;
+ if (/perl/) {print "ok 50\n";} else {print "not ok 50\n";}
+ if (-T FOO) {print "ok 51\n";} else {print "not ok 51\n";}
+ if (! -B FOO) {print "ok 52\n";} else {print "not ok 52\n";}
+ seek(FOO,0,0);
+ if (-T FOO) {print "ok 53\n";} else {print "not ok 53\n";}
+ if (! -B FOO) {print "ok 54\n";} else {print "not ok 54\n";}
+}
+close(FOO);
+
+if (-T '/dev/null') {print "ok 55\n";} else {print "not ok 55\n";}
+if (-B '/dev/null') {print "ok 56\n";} else {print "not ok 56\n";}
+
+# and now, a few parsing tests:
+$_ = 'Op.stat.tmp';
+if (-f) {print "ok 57\n";} else {print "not ok 57\n";}
+if (-f()) {print "ok 58\n";} else {print "not ok 58\n";}
+
+unlink 'Op.stat.tmp';
diff --git a/contrib/perl5/t/op/study.t b/contrib/perl5/t/op/study.t
new file mode 100755
index 000000000000..ea3b366f0bc3
--- /dev/null
+++ b/contrib/perl5/t/op/study.t
@@ -0,0 +1,69 @@
+#!./perl
+
+# $RCSfile: study.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:30 $
+
+print "1..24\n";
+
+$x = "abc\ndef\n";
+study($x);
+
+if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
+if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
+
+$* = 1;
+if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
+$* = 0;
+
+$_ = '123';
+study;
+if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
+
+if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
+if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
+
+if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
+if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
+
+study($x);
+if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
+if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
+
+if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
+if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
+
+$_ = 'aaabbbccc';
+study;
+if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
+ print "ok 13\n";
+} else {
+ print "not ok 13\n";
+}
+if (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
+ print "ok 14\n";
+} else {
+ print "not ok 14\n";
+}
+
+if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
+
+$_ = 'aaabccc';
+study;
+if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
+if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
+
+$_ = 'aaaccc';
+study;
+if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
+if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
+
+$_ = 'abcdef';
+study;
+if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
+if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
+
+if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
+
+if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
+
+$* = 1; # test 3 only tested the optimized version--this one is for real
+if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
diff --git a/contrib/perl5/t/op/subst.t b/contrib/perl5/t/op/subst.t
new file mode 100755
index 000000000000..afa06ab77217
--- /dev/null
+++ b/contrib/perl5/t/op/subst.t
@@ -0,0 +1,310 @@
+#!./perl
+
+print "1..71\n";
+
+$x = 'foo';
+$_ = "x";
+s/x/\$x/;
+print "#1\t:$_: eq :\$x:\n";
+if ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";}
+
+$_ = "x";
+s/x/$x/;
+print "#2\t:$_: eq :foo:\n";
+if ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";}
+
+$_ = "x";
+s/x/\$x $x/;
+print "#3\t:$_: eq :\$x foo:\n";
+if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";}
+
+$b = 'cd';
+($a = 'abcdef') =~ s<(b${b}e)>'\n$1';
+print "#4\t:$1: eq :bcde:\n";
+print "#4\t:$a: eq :a\\n\$1f:\n";
+if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";}
+
+$a = 'abacada';
+if (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx')
+ {print "ok 5\n";} else {print "not ok 5\n";}
+
+if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx')
+ {print "ok 6\n";} else {print "not ok 6 $a\n";}
+
+if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx')
+ {print "ok 7\n";} else {print "not ok 7 $a\n";}
+
+$_ = 'ABACADA';
+if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";}
+
+$_ = '\\' x 4;
+if (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";}
+s/\\/\\\\/g;
+if ($_ eq '\\' x 8) {print "ok 10\n";} else {print "not ok 10 $_\n";}
+
+$_ = '\/' x 4;
+if (length($_) == 8) {print "ok 11\n";} else {print "not ok 11\n";}
+s/\//\/\//g;
+if ($_ eq '\\//' x 4) {print "ok 12\n";} else {print "not ok 12\n";}
+if (length($_) == 12) {print "ok 13\n";} else {print "not ok 13\n";}
+
+$_ = 'aaaXXXXbbb';
+s/^a//;
+print $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n";
+
+$_ = 'aaaXXXXbbb';
+s/a//;
+print $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n";
+
+$_ = 'aaaXXXXbbb';
+s/^a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n";
+
+$_ = 'aaaXXXXbbb';
+s/a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n";
+
+$_ = 'aaaXXXXbbb';
+s/aa//;
+print $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n";
+
+$_ = 'aaaXXXXbbb';
+s/aa/b/;
+print $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n";
+
+$_ = 'aaaXXXXbbb';
+s/b$//;
+print $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n";
+
+$_ = 'aaaXXXXbbb';
+s/b//;
+print $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n";
+
+$_ = 'aaaXXXXbbb';
+s/bb//;
+print $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n";
+
+$_ = 'aaaXXXXbbb';
+s/aX/y/;
+print $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n";
+
+$_ = 'aaaXXXXbbb';
+s/Xb/z/;
+print $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n";
+
+$_ = 'aaaXXXXbbb';
+s/aaX.*Xbb//;
+print $_ eq 'ab' ? "ok 25\n" : "not ok 25\n";
+
+$_ = 'aaaXXXXbbb';
+s/bb/x/;
+print $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n";
+
+# now for some unoptimized versions of the same.
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/^a//;
+print $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/a//;
+print $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/^a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/a/b/;
+print $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aa//;
+print $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aa/b/;
+print $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/b$//;
+print $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/b//;
+print $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/bb//;
+print $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aX/y/;
+print $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/Xb/z/;
+print $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/aaX.*Xbb//;
+print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n";
+
+$_ = 'aaaXXXXbbb';
+$x ne $x || s/bb/x/;
+print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n";
+
+$_ = 'abc123xyz';
+s/(\d+)/$1*2/e; # yields 'abc246xyz'
+print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n";
+s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz'
+print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n";
+s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz'
+print $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" : "not ok 42\n";
+
+$_ = "aaaaa";
+print y/a/b/ == 5 ? "ok 43\n" : "not ok 43\n";
+print y/a/b/ == 0 ? "ok 44\n" : "not ok 44\n";
+print y/b// == 5 ? "ok 45\n" : "not ok 45\n";
+print y/b/c/s == 5 ? "ok 46\n" : "not ok 46\n";
+print y/c// == 1 ? "ok 47\n" : "not ok 47\n";
+print y/c//d == 1 ? "ok 48\n" : "not ok 48\n";
+print $_ eq "" ? "ok 49\n" : "not ok 49\n";
+
+$_ = "Now is the %#*! time for all good men...";
+print (($x=(y/a-zA-Z //cd)) == 7 ? "ok 50\n" : "not ok 50\n");
+print y/ / /s == 8 ? "ok 51\n" : "not ok 51\n";
+
+$_ = 'abcdefghijklmnopqrstuvwxyz0123456789';
+tr/a-z/A-Z/;
+
+print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n";
+
+# same as tr/A-Z/a-z/;
+if ($^O eq 'os390') { # An EBCDIC variant.
+ y[\301-\351][\201-\251];
+} else { # Ye Olde ASCII. Or something like it.
+ y[\101-\132][\141-\172];
+}
+
+print $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ? "ok 53\n" : "not ok 53\n";
+
+if (ord("+") == ord(",") - 1 && ord(",") == ord("-") - 1 &&
+ ord("a") == ord("b") - 1 && ord("b") == ord("c") - 1) {
+ $_ = '+,-';
+ tr/+--/a-c/;
+ print "not " unless $_ eq 'abc';
+}
+print "ok 54\n";
+
+$_ = '+,-';
+tr/+\--/a\/c/;
+print $_ eq 'a,/' ? "ok 55\n" : "not ok 55\n";
+
+$_ = '+,-';
+tr/-+,/ab\-/;
+print $_ eq 'b-a' ? "ok 56\n" : "not ok 56\n";
+
+
+# test recursive substitutions
+# code based on the recursive expansion of makefile variables
+
+my %MK = (
+ AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short
+ E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long
+ DIR => '$(UNDEFINEDNAME)/xxx',
+);
+sub var {
+ my($var,$level) = @_;
+ return "\$($var)" unless exists $MK{$var};
+ return exp_vars($MK{$var}, $level+1); # can recurse
+}
+sub exp_vars {
+ my($str,$level) = @_;
+ $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse
+ #warn "exp_vars $level = '$str'\n";
+ $str;
+}
+
+print exp_vars('$(AAAAA)',0) eq 'D'
+ ? "ok 57\n" : "not ok 57\n";
+print exp_vars('$(E)',0) eq 'p HHHHH q'
+ ? "ok 58\n" : "not ok 58\n";
+print exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx'
+ ? "ok 59\n" : "not ok 59\n";
+print exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar'
+ ? "ok 60\n" : "not ok 60\n";
+
+# a match nested in the RHS of a substitution:
+
+$_ = "abcd";
+s/(..)/$x = $1, m#.#/eg;
+print $x eq "cd" ? "ok 61\n" : "not ok 61\n";
+
+# Subst and lookbehind
+
+$_="ccccc";
+s/(?<!x)c/x/g;
+print $_ eq "xxxxx" ? "ok 62\n" : "not ok 62 # `$_' ne `xxxxx'\n";
+
+$_="ccccc";
+s/(?<!x)(c)/x/g;
+print $_ eq "xxxxx" ? "ok 63\n" : "not ok 63 # `$_' ne `xxxxx'\n";
+
+$_="foobbarfoobbar";
+s/(?<!r)foobbar/foobar/g;
+print $_ eq "foobarfoobbar" ? "ok 64\n" : "not ok 64 # `$_' ne `foobarfoobbar'\n";
+
+$_="foobbarfoobbar";
+s/(?<!ar)(foobbar)/foobar/g;
+print $_ eq "foobarfoobbar" ? "ok 65\n" : "not ok 65 # `$_' ne `foobarfoobbar'\n";
+
+$_="foobbarfoobbar";
+s/(?<!ar)foobbar/foobar/g;
+print $_ eq "foobarfoobbar" ? "ok 66\n" : "not ok 66 # `$_' ne `foobarfoobbar'\n";
+
+# check parsing of split subst with comment
+eval 's{foo} # this is a comment, not a delimiter
+ {bar};';
+print @? ? "not ok 67\n" : "ok 67\n";
+
+# check if squashing works at the end of string
+$_="baacbaa";
+tr/a/b/s;
+print $_ eq "bbcbb" ? "ok 68\n" : "not ok 68 # `$_' ne `bbcbb'\n";
+
+# XXX TODO: Most tests above don't test return values of the ops. They should.
+$_ = "ab";
+print (s/a/b/ == 1 ? "ok 69\n" : "not ok 69\n");
+
+$_ = <<'EOL';
+ $url = new URI::URL "http://www/"; die if $url eq "xXx";
+EOL
+$^R = 'junk';
+
+$foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' .
+ ' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' .
+ ' lowercase $@%#MiXeD$@%# ';
+
+s{ \d+ \b [,.;]? (?{ 'digits' })
+ |
+ [a-z]+ \b [,.;]? (?{ 'lowercase' })
+ |
+ [A-Z]+ \b [,.;]? (?{ 'UPPERCASE' })
+ |
+ [A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' })
+ |
+ [A-Za-z]+ \b [,.;]? (?{ 'MiXeD' })
+ |
+ [A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' })
+ |
+ \s+ (?{ ' ' })
+ |
+ [^A-Za-z0-9\s]+ (?{ '$@%#' })
+}{$^R}xg;
+print ($_ eq $foo ? "ok 70\n" : "not ok 70\n#'$_'\n#'$foo'\n");
+
+$_ = 'x' x 20;
+s/\d*|x/<$&>/g;
+$foo = '<>' . ('<x><>' x 20) ;
+print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n");
diff --git a/contrib/perl5/t/op/substr.t b/contrib/perl5/t/op/substr.t
new file mode 100755
index 000000000000..87efcb45124a
--- /dev/null
+++ b/contrib/perl5/t/op/substr.t
@@ -0,0 +1,211 @@
+#!./perl
+
+print "1..106\n";
+
+#P = start of string Q = start of substr R = end of substr S = end of string
+
+$a = 'abcdefxyz';
+BEGIN { $^W = 1 };
+
+$SIG{__WARN__} = sub {
+ if ($_[0] =~ /^substr outside of string/) {
+ $w++;
+ } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) {
+ $w += 2;
+ } elsif ($_[0] =~ /^Use of uninitialized value/) {
+ $w += 3;
+ } else {
+ warn $_[0];
+ }
+};
+
+sub fail { !defined(shift) && $w-- };
+
+print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); # P=Q R S
+print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); # P Q R S
+print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); # P Q S R
+print (fail(substr($a,999,999)) ? "ok 4\n" : "not ok 4\n"); # P R Q S
+print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); # P=Q R S
+print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); # P Q R S
+
+$[ = 1;
+
+print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); # P=Q R S
+print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); # P Q R S
+print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); # P Q S R
+print (fail(substr($a,999,999)) ? "ok 10\n" : "not ok 10\n");# P R Q S
+print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");# P=Q R S
+print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); # P Q R S
+
+$[ = 0;
+
+substr($a,3,3) = 'XYZ';
+print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n";
+substr($a,0,2) = '';
+print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n";
+substr($a,0,0) = 'ab';
+print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n";
+substr($a,0,0) = '12345678';
+print $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n";
+substr($a,-3,3) = 'def';
+print $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n";
+substr($a,-3,3) = '<';
+print $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n";
+substr($a,-1,1) = '12345678';
+print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n";
+
+$a = 'abcdefxyz';
+
+print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n"); # P Q R=S
+print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); # P Q R=S
+print (fail(substr($a,999)) ? "ok 22\n" : "not ok 22\n"); # P R=S Q
+print (substr($a,0) eq 'abcdefxyz' ? "ok 23\n" : "not ok 23\n");# P=Q R=S
+print (substr($a,9) eq '' ? "ok 24\n" : "not ok 24\n"); # P Q=R=S
+print (substr($a,-11) eq 'abcdefxyz' ? "ok 25\n" : "not ok 25\n");# Q P R=S
+print (substr($a,-9) eq 'abcdefxyz' ? "ok 26\n" : "not ok 26\n"); # P=Q R=S
+
+$a = '54321';
+
+print (fail(substr($a,-7, 1)) ? "ok 27\n" : "not ok 27\n"); # Q R P S
+print (fail(substr($a,-7,-6)) ? "ok 28\n" : "not ok 28\n"); # Q R P S
+print (substr($a,-5,-7) eq '' ? "ok 29\n" : "not ok 29\n"); # R P=Q S
+print (substr($a, 2,-7) eq '' ? "ok 30\n" : "not ok 30\n"); # R P Q S
+print (substr($a,-3,-7) eq '' ? "ok 31\n" : "not ok 31\n"); # R P Q S
+print (substr($a, 2,-5) eq '' ? "ok 32\n" : "not ok 32\n"); # P=R Q S
+print (substr($a,-3,-5) eq '' ? "ok 33\n" : "not ok 33\n"); # P=R Q S
+print (substr($a, 2,-4) eq '' ? "ok 34\n" : "not ok 34\n"); # P R Q S
+print (substr($a,-3,-4) eq '' ? "ok 35\n" : "not ok 35\n"); # P R Q S
+print (substr($a, 5,-6) eq '' ? "ok 36\n" : "not ok 36\n"); # R P Q=S
+print (substr($a, 5,-5) eq '' ? "ok 37\n" : "not ok 37\n"); # P=R Q S
+print (substr($a, 5,-3) eq '' ? "ok 38\n" : "not ok 38\n"); # P R Q=S
+print (fail(substr($a, 7,-7)) ? "ok 39\n" : "not ok 39\n"); # R P S Q
+print (fail(substr($a, 7,-5)) ? "ok 40\n" : "not ok 40\n"); # P=R S Q
+print (fail(substr($a, 7,-3)) ? "ok 41\n" : "not ok 41\n"); # P R S Q
+print (fail(substr($a, 7, 0)) ? "ok 42\n" : "not ok 42\n"); # P S Q=R
+
+print (substr($a,-7,2) eq '' ? "ok 43\n" : "not ok 43\n"); # Q P=R S
+print (substr($a,-7,4) eq '54' ? "ok 44\n" : "not ok 44\n"); # Q P R S
+print (substr($a,-7,7) eq '54321' ? "ok 45\n" : "not ok 45\n");# Q P R=S
+print (substr($a,-7,9) eq '54321' ? "ok 46\n" : "not ok 46\n");# Q P S R
+print (substr($a,-5,0) eq '' ? "ok 47\n" : "not ok 47\n"); # P=Q=R S
+print (substr($a,-5,3) eq '543' ? "ok 48\n" : "not ok 48\n");# P=Q R S
+print (substr($a,-5,5) eq '54321' ? "ok 49\n" : "not ok 49\n");# P=Q R=S
+print (substr($a,-5,7) eq '54321' ? "ok 50\n" : "not ok 50\n");# P=Q S R
+print (substr($a,-3,0) eq '' ? "ok 51\n" : "not ok 51\n"); # P Q=R S
+print (substr($a,-3,3) eq '321' ? "ok 52\n" : "not ok 52\n");# P Q R=S
+print (substr($a,-2,3) eq '21' ? "ok 53\n" : "not ok 53\n"); # P Q S R
+print (substr($a,0,-5) eq '' ? "ok 54\n" : "not ok 54\n"); # P=Q=R S
+print (substr($a,2,-3) eq '' ? "ok 55\n" : "not ok 55\n"); # P Q=R S
+print (substr($a,0,0) eq '' ? "ok 56\n" : "not ok 56\n"); # P=Q=R S
+print (substr($a,0,5) eq '54321' ? "ok 57\n" : "not ok 57\n");# P=Q R=S
+print (substr($a,0,7) eq '54321' ? "ok 58\n" : "not ok 58\n");# P=Q S R
+print (substr($a,2,0) eq '' ? "ok 59\n" : "not ok 59\n"); # P Q=R S
+print (substr($a,2,3) eq '321' ? "ok 60\n" : "not ok 60\n"); # P Q R=S
+print (substr($a,5,0) eq '' ? "ok 61\n" : "not ok 61\n"); # P Q=R=S
+print (substr($a,5,2) eq '' ? "ok 62\n" : "not ok 62\n"); # P Q=S R
+print (substr($a,-7,-5) eq '' ? "ok 63\n" : "not ok 63\n"); # Q P=R S
+print (substr($a,-7,-2) eq '543' ? "ok 64\n" : "not ok 64\n");# Q P R S
+print (substr($a,-5,-5) eq '' ? "ok 65\n" : "not ok 65\n"); # P=Q=R S
+print (substr($a,-5,-2) eq '543' ? "ok 66\n" : "not ok 66\n");# P=Q R S
+print (substr($a,-3,-3) eq '' ? "ok 67\n" : "not ok 67\n"); # P Q=R S
+print (substr($a,-3,-1) eq '32' ? "ok 68\n" : "not ok 68\n");# P Q R S
+
+$a = '';
+
+print (substr($a,-2,2) eq '' ? "ok 69\n" : "not ok 69\n"); # Q P=R=S
+print (substr($a,0,0) eq '' ? "ok 70\n" : "not ok 70\n"); # P=Q=R=S
+print (substr($a,0,1) eq '' ? "ok 71\n" : "not ok 71\n"); # P=Q=S R
+print (substr($a,-2,3) eq '' ? "ok 72\n" : "not ok 72\n"); # Q P=S R
+print (substr($a,-2) eq '' ? "ok 73\n" : "not ok 73\n"); # Q P=R=S
+print (substr($a,0) eq '' ? "ok 74\n" : "not ok 74\n"); # P=Q=R=S
+
+
+print (substr($a,0,-1) eq '' ? "ok 75\n" : "not ok 75\n"); # R P=Q=S
+print (fail(substr($a,-2,0)) ? "ok 76\n" : "not ok 76\n"); # Q=R P=S
+print (fail(substr($a,-2,1)) ? "ok 77\n" : "not ok 77\n"); # Q R P=S
+print (fail(substr($a,-2,-1)) ? "ok 78\n" : "not ok 78\n"); # Q R P=S
+print (fail(substr($a,-2,-2)) ? "ok 79\n" : "not ok 79\n"); # Q=R P=S
+print (fail(substr($a,1,-2)) ? "ok 80\n" : "not ok 81\n"); # R P=S Q
+print (fail(substr($a,1,1)) ? "ok 81\n" : "not ok 81\n"); # P=S Q R
+print (fail(substr($a,1,0)) ? "ok 82\n" : "not ok 82\n"); # P=S Q=R
+print (fail(substr($a,1)) ? "ok 83\n" : "not ok 83\n"); # P=R=S Q
+
+
+my $a = 'zxcvbnm';
+substr($a,2,0) = '';
+print $a eq 'zxcvbnm' ? "ok 84\n" : "not ok 84\n";
+substr($a,7,0) = '';
+print $a eq 'zxcvbnm' ? "ok 85\n" : "not ok 85\n";
+substr($a,5,0) = '';
+print $a eq 'zxcvbnm' ? "ok 86\n" : "not ok 86\n";
+substr($a,0,2) = 'pq';
+print $a eq 'pqcvbnm' ? "ok 87\n" : "not ok 87\n";
+substr($a,2,0) = 'r';
+print $a eq 'pqrcvbnm' ? "ok 88\n" : "not ok 88\n";
+substr($a,8,0) = 'asd';
+print $a eq 'pqrcvbnmasd' ? "ok 89\n" : "not ok 89\n";
+substr($a,0,2) = 'iop';
+print $a eq 'ioprcvbnmasd' ? "ok 90\n" : "not ok 90\n";
+substr($a,0,5) = 'fgh';
+print $a eq 'fghvbnmasd' ? "ok 91\n" : "not ok 91\n";
+substr($a,3,5) = 'jkl';
+print $a eq 'fghjklsd' ? "ok 92\n" : "not ok 92\n";
+substr($a,3,2) = '1234';
+print $a eq 'fgh1234lsd' ? "ok 93\n" : "not ok 93\n";
+
+
+# with lexicals (and in re-entered scopes)
+for (0,1) {
+ my $txt;
+ unless ($_) {
+ $txt = "Foo";
+ substr($txt, -1) = "X";
+ print $txt eq "FoX" ? "ok 94\n" : "not ok 94\n";
+ }
+ else {
+ local $^W = 0; # because of (spurious?) "uninitialised value"
+ substr($txt, 0, 1) = "X";
+ print $txt eq "X" ? "ok 95\n" : "not ok 95\n";
+ }
+}
+
+# coercion of references
+{
+ my $s = [];
+ substr($s, 0, 1) = 'Foo';
+ print substr($s,0,7) eq "FooRRAY" && !($w-=2) ? "ok 96\n" : "not ok 96\n";
+}
+
+# check no spurious warnings
+print $w ? "not ok 97\n" : "ok 97\n";
+
+# check new 4 arg replacement syntax
+$a = "abcxyz";
+$w = 0;
+print "not " unless substr($a, 0, 3, "") eq "abc" && $a eq "xyz";
+print "ok 98\n";
+print "not " unless substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz";
+print "ok 99\n";
+print "not " unless substr($a, 3, -1, "") eq "xy" && $a eq "abcz";
+print "ok 100\n";
+
+print "not " unless substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz"
+ && $w == 3;
+print "ok 101\n";
+$w = 0;
+
+print "not " unless substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc";
+print "ok 102\n";
+print "not " unless fail(substr($a, -99, 0, ""));
+print "ok 103\n";
+print "not " unless fail(substr($a, 99, 3, ""));
+print "ok 104\n";
+
+substr($a, 0, length($a), "foo");
+print "not " unless $a eq "foo" && !$w;
+print "ok 105\n";
+
+# using 4 arg substr as lvalue is a compile time error
+eval 'substr($a,0,0,"") = "abc"';
+print "not " unless $@ && $@ =~ /Can't modify substr/ && $a eq "foo";
+print "ok 106\n";
diff --git a/contrib/perl5/t/op/sysio.t b/contrib/perl5/t/op/sysio.t
new file mode 100755
index 000000000000..826cf383ae7e
--- /dev/null
+++ b/contrib/perl5/t/op/sysio.t
@@ -0,0 +1,194 @@
+#!./perl
+
+print "1..36\n";
+
+chdir('op') || die "sysio.t: cannot look for myself: $!";
+
+open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!";
+
+$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos');
+
+$x = 'abc';
+
+# should not be able to do negative lengths
+eval { sysread(I, $x, -1) };
+print 'not ' unless ($@ =~ /^Negative length /);
+print "ok 1\n";
+
+# $x should be intact
+print 'not ' unless ($x eq 'abc');
+print "ok 2\n";
+
+# should not be able to read before the buffer
+eval { sysread(I, $x, 1, -4) };
+print 'not ' unless ($x eq 'abc');
+print "ok 3\n";
+
+# $x should be intact
+print 'not ' unless ($x eq 'abc');
+print "ok 4\n";
+
+$a ='0123456789';
+
+# default offset 0
+print 'not ' unless(sysread(I, $a, 3) == 3);
+print "ok 5\n";
+
+# $a should be as follows
+print 'not ' unless ($a eq '#!.');
+print "ok 6\n";
+
+# reading past the buffer should zero pad
+print 'not ' unless(sysread(I, $a, 2, 5) == 2);
+print "ok 7\n";
+
+# the zero pad should be seen now
+print 'not ' unless ($a eq "#!.\0\0/p");
+print "ok 8\n";
+
+# try changing the last two characters of $a
+print 'not ' unless(sysread(I, $a, 3, -2) == 3);
+print "ok 9\n";
+
+# the last two characters of $a should have changed (into three)
+print 'not ' unless ($a eq "#!.\0\0erl");
+print "ok 10\n";
+
+$outfile = 'sysio.out';
+
+open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
+
+select(O); $|=1; select(STDOUT);
+
+# cannot write negative lengths
+eval { syswrite(O, $x, -1) };
+print 'not ' unless ($@ =~ /^Negative length /);
+print "ok 11\n";
+
+# $x still intact
+print 'not ' unless ($x eq 'abc');
+print "ok 12\n";
+
+# $outfile still intact
+print 'not ' if (-s $outfile);
+print "ok 13\n";
+
+# should not be able to write from after the buffer
+eval { syswrite(O, $x, 1, 3) };
+print 'not ' unless ($@ =~ /^Offset outside string /);
+print "ok 14\n";
+
+# $x still intact
+print 'not ' unless ($x eq 'abc');
+print "ok 15\n";
+
+# $outfile still intact
+if ($reopen) { # must close file to update EOF marker for stat
+ close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+}
+print 'not ' if (-s $outfile);
+print "ok 16\n";
+
+# should not be able to write from before the buffer
+
+eval { syswrite(O, $x, 1, -4) };
+print 'not ' unless ($@ =~ /^Offset outside string /);
+print "ok 17\n";
+
+# $x still intact
+print 'not ' unless ($x eq 'abc');
+print "ok 18\n";
+
+# $outfile still intact
+if ($reopen) { # must close file to update EOF marker for stat
+ close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+}
+print 'not ' if (-s $outfile);
+print "ok 19\n";
+
+# default offset 0
+print 'not ' unless (syswrite(O, $a, 2) == 2);
+print "ok 20\n";
+
+# $a still intact
+print 'not ' unless ($a eq "#!.\0\0erl");
+print "ok 21\n";
+
+# $outfile should have grown now
+if ($reopen) { # must close file to update EOF marker for stat
+ close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+}
+print 'not ' unless (-s $outfile == 2);
+print "ok 22\n";
+
+# with offset
+print 'not ' unless (syswrite(O, $a, 2, 5) == 2);
+print "ok 23\n";
+
+# $a still intact
+print 'not ' unless ($a eq "#!.\0\0erl");
+print "ok 24\n";
+
+# $outfile should have grown now
+if ($reopen) { # must close file to update EOF marker for stat
+ close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+}
+print 'not ' unless (-s $outfile == 4);
+print "ok 25\n";
+
+# with negative offset and a bit too much length
+print 'not ' unless (syswrite(O, $a, 5, -3) == 3);
+print "ok 26\n";
+
+# $a still intact
+print 'not ' unless ($a eq "#!.\0\0erl");
+print "ok 27\n";
+
+# $outfile should have grown now
+if ($reopen) { # must close file to update EOF marker for stat
+ close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
+}
+print 'not ' unless (-s $outfile == 7);
+print "ok 28\n";
+
+close(O);
+
+open(I, $outfile) || die "sysio.t: cannot read $outfile: $!";
+
+$b = 'xyz';
+
+# reading too much only return as much as available
+print 'not ' unless (sysread(I, $b, 100) == 7);
+print "ok 29\n";
+# this we should have
+print 'not ' unless ($b eq '#!ererl');
+print "ok 30\n";
+
+# test sysseek
+
+print 'not ' unless sysseek(I, 2, 0) == 2;
+print "ok 31\n";
+sysread(I, $b, 3);
+print 'not ' unless $b eq 'ere';
+print "ok 32\n";
+
+print 'not ' unless sysseek(I, -2, 1) == 3;
+print "ok 33\n";
+sysread(I, $b, 4);
+print 'not ' unless $b eq 'rerl';
+print "ok 34\n";
+
+print 'not ' unless sysseek(I, 0, 0) eq '0 but true';
+print "ok 35\n";
+print 'not ' if defined sysseek(I, -1, 1);
+print "ok 36\n";
+
+close(I);
+
+unlink $outfile;
+
+chdir('..');
+
+1;
+
+# eof
diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t
new file mode 100755
index 000000000000..d2cae8e70a18
--- /dev/null
+++ b/contrib/perl5/t/op/taint.t
@@ -0,0 +1,596 @@
+#!./perl -T
+#
+# Taint tests by Tom Phoenix <rootbeer@teleport.com>.
+#
+# I don't claim to know all about tainting. If anyone sees
+# tests that I've missed here, please add them. But this is
+# better than having no tests at all, right?
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+use strict;
+use Config;
+
+# We do not want the whole taint.t to fail
+# just because Errno possibly failing.
+eval { require Errno; import Errno };
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MSWin32 = $^O eq 'MSWin32';
+my $Is_Dos = $^O eq 'dos';
+my $Invoke_Perl = $Is_VMS ? 'MCR Sys$Disk:[]Perl.' :
+ $Is_MSWin32 ? '.\perl' : './perl';
+my @MoreEnv = qw/IFS CDPATH ENV BASH_ENV/;
+
+if ($Is_VMS) {
+ my (%old, $x);
+ for $x ('DCL$PATH', @MoreEnv) {
+ ($old{$x}) = $ENV{$x} =~ /^(.*)$/ if exists $ENV{$x};
+ }
+ eval <<EndOfCleanup;
+ END {
+ \$ENV{PATH} = '';
+ warn "# Note: logical name 'PATH' may have been deleted\n";
+ @ENV{keys %old} = values %old;
+ }
+EndOfCleanup
+}
+
+# Sources of taint:
+# The empty tainted value, for tainting strings
+my $TAINT = substr($^X, 0, 0);
+# A tainted zero, useful for tainting numbers
+my $TAINT0 = 0 + $TAINT;
+
+# This taints each argument passed. All must be lvalues.
+# Side effect: It also stringifies them. :-(
+sub taint_these (@) {
+ for (@_) { $_ .= $TAINT }
+}
+
+# How to identify taint when you see it
+sub any_tainted (@) {
+ not eval { join("",@_), kill 0; 1 };
+}
+sub tainted ($) {
+ any_tainted @_;
+}
+sub all_tainted (@) {
+ for (@_) { return 0 unless tainted $_ }
+ 1;
+}
+
+sub test ($$;$) {
+ my($serial, $boolean, $diag) = @_;
+ if ($boolean) {
+ print "ok $serial\n";
+ } else {
+ print "not ok $serial\n";
+ for (split m/^/m, $diag) {
+ print "# $_";
+ }
+ print "\n" unless
+ $diag eq ''
+ or substr($diag, -1) eq "\n";
+ }
+}
+
+# We need an external program to call.
+my $ECHO = ($Is_MSWin32 ? ".\\echo$$" : "./echo$$");
+END { unlink $ECHO }
+open PROG, "> $ECHO" or die "Can't create $ECHO: $!";
+print PROG 'print "@ARGV\n"', "\n";
+close PROG;
+my $echo = "$Invoke_Perl $ECHO";
+
+print "1..149\n";
+
+# First, let's make sure that Perl is checking the dangerous
+# environment variables. Maybe they aren't set yet, so we'll
+# taint them ourselves.
+{
+ $ENV{'DCL$PATH'} = '' if $Is_VMS;
+
+ $ENV{PATH} = '';
+ delete @ENV{@MoreEnv};
+ $ENV{TERM} = 'dumb';
+
+ test 1, eval { `$echo 1` } eq "1\n";
+
+ if ($Is_MSWin32 || $Is_VMS || $Is_Dos) {
+ print "# Environment tainting tests skipped\n";
+ for (2..5) { print "ok $_\n" }
+ }
+ else {
+ my @vars = ('PATH', @MoreEnv);
+ while (my $v = $vars[0]) {
+ local $ENV{$v} = $TAINT;
+ last if eval { `$echo 1` };
+ last unless $@ =~ /^Insecure \$ENV{$v}/;
+ shift @vars;
+ }
+ test 2, !@vars, "\$$vars[0]";
+
+ # tainted $TERM is unsafe only if it contains metachars
+ local $ENV{TERM};
+ $ENV{TERM} = 'e=mc2';
+ test 3, eval { `$echo 1` } eq "1\n";
+ $ENV{TERM} = 'e=mc2' . $TAINT;
+ test 4, eval { `$echo 1` } eq '';
+ test 5, $@ =~ /^Insecure \$ENV{TERM}/, $@;
+ }
+
+ my $tmp;
+ if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) {
+ print "# all directories are writeable\n";
+ }
+ else {
+ $tmp = (grep { defined and -d and (stat _)[2] & 2 }
+ qw(/tmp /var/tmp /usr/tmp /sys$scratch),
+ @ENV{qw(TMP TEMP)})[0]
+ or print "# can't find world-writeable directory to test PATH\n";
+ }
+
+ if ($tmp) {
+ local $ENV{PATH} = $tmp;
+ test 6, eval { `$echo 1` } eq '';
+ test 7, $@ =~ /^Insecure directory in \$ENV{PATH}/, $@;
+ }
+ else {
+ for (6..7) { print "ok $_ # Skipped: all directories are writeable\n" }
+ }
+
+ if ($Is_VMS) {
+ $ENV{'DCL$PATH'} = $TAINT;
+ test 8, eval { `$echo 1` } eq '';
+ test 9, $@ =~ /^Insecure \$ENV{DCL\$PATH}/, $@;
+ if ($tmp) {
+ $ENV{'DCL$PATH'} = $tmp;
+ test 10, eval { `$echo 1` } eq '';
+ test 11, $@ =~ /^Insecure directory in \$ENV{DCL\$PATH}/, $@;
+ }
+ else {
+ for (10..11) { print "ok $_ # Skipped: can't find world-writeable directory to test DCL\$PATH\n" }
+ }
+ $ENV{'DCL$PATH'} = '';
+ }
+ else {
+ for (8..11) { print "ok $_ # Skipped: This is not VMS\n"; }
+ }
+}
+
+# Let's see that we can taint and untaint as needed.
+{
+ my $foo = $TAINT;
+ test 12, tainted $foo;
+
+ # That was a sanity check. If it failed, stop the insanity!
+ die "Taint checks don't seem to be enabled" unless tainted $foo;
+
+ $foo = "foo";
+ test 13, not tainted $foo;
+
+ taint_these($foo);
+ test 14, tainted $foo;
+
+ my @list = 1..10;
+ test 15, not any_tainted @list;
+ taint_these @list[1,3,5,7,9];
+ test 16, any_tainted @list;
+ test 17, all_tainted @list[1,3,5,7,9];
+ test 18, not any_tainted @list[0,2,4,6,8];
+
+ ($foo) = $foo =~ /(.+)/;
+ test 19, not tainted $foo;
+
+ $foo = $1 if ('bar' . $TAINT) =~ /(.+)/;
+ test 20, not tainted $foo;
+ test 21, $foo eq 'bar';
+
+ {
+ use re 'taint';
+
+ ($foo) = ('bar' . $TAINT) =~ /(.+)/;
+ test 22, tainted $foo;
+ test 23, $foo eq 'bar';
+
+ $foo = $1 if ('bar' . $TAINT) =~ /(.+)/;
+ test 24, tainted $foo;
+ test 25, $foo eq 'bar';
+ }
+
+ $foo = $1 if 'bar' =~ /(.+)$TAINT/;
+ test 26, tainted $foo;
+ test 27, $foo eq 'bar';
+
+ my $pi = 4 * atan2(1,1) + $TAINT0;
+ test 28, tainted $pi;
+
+ ($pi) = $pi =~ /(\d+\.\d+)/;
+ test 29, not tainted $pi;
+ test 30, sprintf("%.5f", $pi) eq '3.14159';
+}
+
+# How about command-line arguments? The problem is that we don't
+# always get some, so we'll run another process with some.
+{
+ my $arg = "./arg$$";
+ open PROG, "> $arg" or die "Can't create $arg: $!";
+ print PROG q{
+ eval { join('', @ARGV), kill 0 };
+ exit 0 if $@ =~ /^Insecure dependency/;
+ print "# Oops: \$@ was [$@]\n";
+ exit 1;
+ };
+ close PROG;
+ print `$Invoke_Perl "-T" $arg and some suspect arguments`;
+ test 31, !$?, "Exited with status $?";
+ unlink $arg;
+}
+
+# Reading from a file should be tainted
+{
+ my $file = './TEST';
+ test 32, open(FILE, $file), "Couldn't open '$file': $!";
+
+ my $block;
+ sysread(FILE, $block, 100);
+ my $line = <FILE>;
+ close FILE;
+ test 33, tainted $block;
+ test 34, tainted $line;
+}
+
+# Globs should be forbidden, except under VMS,
+# which doesn't spawn an external program.
+if ($Is_VMS) {
+ for (35..36) { print "ok $_\n"; }
+}
+else {
+ my @globs = eval { <*> };
+ test 35, @globs == 0 && $@ =~ /^Insecure dependency/;
+
+ @globs = eval { glob '*' };
+ test 36, @globs == 0 && $@ =~ /^Insecure dependency/;
+}
+
+# Output of commands should be tainted
+{
+ my $foo = `$echo abc`;
+ test 37, tainted $foo;
+}
+
+# Certain system variables should be tainted
+{
+ test 38, all_tainted $^X, $0;
+}
+
+# Results of matching should all be untainted
+{
+ my $foo = "abcdefghi" . $TAINT;
+ test 39, tainted $foo;
+
+ $foo =~ /def/;
+ test 40, not any_tainted $`, $&, $';
+
+ $foo =~ /(...)(...)(...)/;
+ test 41, not any_tainted $1, $2, $3, $+;
+
+ my @bar = $foo =~ /(...)(...)(...)/;
+ test 42, not any_tainted @bar;
+
+ test 43, tainted $foo; # $foo should still be tainted!
+ test 44, $foo eq "abcdefghi";
+}
+
+# Operations which affect files can't use tainted data.
+{
+ test 45, eval { chmod 0, $TAINT } eq '', 'chmod';
+ test 46, $@ =~ /^Insecure dependency/, $@;
+
+ # There is no feature test in $Config{} for truncate,
+ # so we allow for the possibility that it's missing.
+ test 47, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate';
+ test 48, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@;
+
+ test 49, eval { rename '', $TAINT } eq '', 'rename';
+ test 50, $@ =~ /^Insecure dependency/, $@;
+
+ test 51, eval { unlink $TAINT } eq '', 'unlink';
+ test 52, $@ =~ /^Insecure dependency/, $@;
+
+ test 53, eval { utime $TAINT } eq '', 'utime';
+ test 54, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_chown}) {
+ test 55, eval { chown -1, -1, $TAINT } eq '', 'chown';
+ test 56, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ for (55..56) { print "ok $_ # Skipped: chown() is not available\n" }
+ }
+
+ if ($Config{d_link}) {
+ test 57, eval { link $TAINT, '' } eq '', 'link';
+ test 58, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ for (57..58) { print "ok $_ # Skipped: link() is not available\n" }
+ }
+
+ if ($Config{d_symlink}) {
+ test 59, eval { symlink $TAINT, '' } eq '', 'symlink';
+ test 60, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ for (59..60) { print "ok $_ # Skipped: symlink() is not available\n" }
+ }
+}
+
+# Operations which affect directories can't use tainted data.
+{
+ test 61, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir';
+ test 62, $@ =~ /^Insecure dependency/, $@;
+
+ test 63, eval { rmdir $TAINT } eq '', 'rmdir';
+ test 64, $@ =~ /^Insecure dependency/, $@;
+
+ test 65, eval { chdir $TAINT } eq '', 'chdir';
+ test 66, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_chroot}) {
+ test 67, eval { chroot $TAINT } eq '', 'chroot';
+ test 68, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ for (67..68) { print "ok $_ # Skipped: chroot() is not available\n" }
+ }
+}
+
+# Some operations using files can't use tainted data.
+{
+ my $foo = "imaginary library" . $TAINT;
+ test 69, eval { require $foo } eq '', 'require';
+ test 70, $@ =~ /^Insecure dependency/, $@;
+
+ my $filename = "./taintB$$"; # NB: $filename isn't tainted!
+ END { unlink $filename if defined $filename }
+ $foo = $filename . $TAINT;
+ unlink $filename; # in any case
+
+ test 71, eval { open FOO, $foo } eq '', 'open for read';
+ test 72, $@ eq '', $@; # NB: This should be allowed
+
+ # Try first new style but allow also old style.
+ test 73, $!{ENOENT} || $! == 2 || ($Is_Dos && $! == 22); # File not found
+
+ test 74, eval { open FOO, "> $foo" } eq '', 'open for write';
+ test 75, $@ =~ /^Insecure dependency/, $@;
+}
+
+# Commands to the system can't use tainted data
+{
+ my $foo = $TAINT;
+
+ if ($^O eq 'amigaos') {
+ for (76..79) { print "ok $_ # Skipped: open('|') is not available\n" }
+ }
+ else {
+ test 76, eval { open FOO, "| $foo" } eq '', 'popen to';
+ test 77, $@ =~ /^Insecure dependency/, $@;
+
+ test 78, eval { open FOO, "$foo |" } eq '', 'popen from';
+ test 79, $@ =~ /^Insecure dependency/, $@;
+ }
+
+ test 80, eval { exec $TAINT } eq '', 'exec';
+ test 81, $@ =~ /^Insecure dependency/, $@;
+
+ test 82, eval { system $TAINT } eq '', 'system';
+ test 83, $@ =~ /^Insecure dependency/, $@;
+
+ $foo = "*";
+ taint_these $foo;
+
+ test 84, eval { `$echo 1$foo` } eq '', 'backticks';
+ test 85, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe
+ test 86, join('', eval { glob $foo } ) ne '', 'globbing';
+ test 87, $@ eq '', $@;
+ }
+ else {
+ for (86..87) { print "ok $_ # Skipped: this is not VMS\n"; }
+ }
+}
+
+# Operations which affect processes can't use tainted data.
+{
+ test 88, eval { kill 0, $TAINT } eq '', 'kill';
+ test 89, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_setpgrp}) {
+ test 90, eval { setpgrp 0, $TAINT } eq '', 'setpgrp';
+ test 91, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ for (90..91) { print "ok $_ # Skipped: setpgrp() is not available\n" }
+ }
+
+ if ($Config{d_setprior}) {
+ test 92, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority';
+ test 93, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ for (92..93) { print "ok $_ # Skipped: setpriority() is not available\n" }
+ }
+}
+
+# Some miscellaneous operations can't use tainted data.
+{
+ if ($Config{d_syscall}) {
+ test 94, eval { syscall $TAINT } eq '', 'syscall';
+ test 95, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ for (94..95) { print "ok $_ # Skipped: syscall() is not available\n" }
+ }
+
+ {
+ my $foo = "x" x 979;
+ taint_these $foo;
+ local *FOO;
+ my $temp = "./taintC$$";
+ END { unlink $temp }
+ test 96, open(FOO, "> $temp"), "Couldn't open $temp for write: $!";
+
+ test 97, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl';
+ test 98, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_fcntl}) {
+ test 99, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl';
+ test 100, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ for (99..100) { print "ok $_ # Skipped: fcntl() is not available\n" }
+ }
+
+ close FOO;
+ }
+}
+
+# Some tests involving references
+{
+ my $foo = 'abc' . $TAINT;
+ my $fooref = \$foo;
+ test 101, not tainted $fooref;
+ test 102, tainted $$fooref;
+ test 103, tainted $foo;
+}
+
+# Some tests involving assignment
+{
+ my $foo = $TAINT0;
+ my $bar = $foo;
+ test 104, all_tainted $foo, $bar;
+ test 105, tainted($foo = $bar);
+ test 106, tainted($bar = $bar);
+ test 107, tainted($bar += $bar);
+ test 108, tainted($bar -= $bar);
+ test 109, tainted($bar *= $bar);
+ test 110, tainted($bar++);
+ test 111, tainted($bar /= $bar);
+ test 112, tainted($bar += 0);
+ test 113, tainted($bar -= 2);
+ test 114, tainted($bar *= -1);
+ test 115, tainted($bar /= 1);
+ test 116, tainted($bar--);
+ test 117, $bar == 0;
+}
+
+# Test assignment and return of lists
+{
+ my @foo = ("A", "tainted" . $TAINT, "B");
+ test 118, not tainted $foo[0];
+ test 119, tainted $foo[1];
+ test 120, not tainted $foo[2];
+ my @bar = @foo;
+ test 121, not tainted $bar[0];
+ test 122, tainted $bar[1];
+ test 123, not tainted $bar[2];
+ my @baz = eval { "A", "tainted" . $TAINT, "B" };
+ test 124, not tainted $baz[0];
+ test 125, tainted $baz[1];
+ test 126, not tainted $baz[2];
+ my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ];
+ test 127, not tainted $plugh[0];
+ test 128, tainted $plugh[1];
+ test 129, not tainted $plugh[2];
+ my $nautilus = sub { "A", "tainted" . $TAINT, "B" };
+ test 130, not tainted ((&$nautilus)[0]);
+ test 131, tainted ((&$nautilus)[1]);
+ test 132, not tainted ((&$nautilus)[2]);
+ my @xyzzy = &$nautilus;
+ test 133, not tainted $xyzzy[0];
+ test 134, tainted $xyzzy[1];
+ test 135, not tainted $xyzzy[2];
+ my $red_october = sub { return "A", "tainted" . $TAINT, "B" };
+ test 136, not tainted ((&$red_october)[0]);
+ test 137, tainted ((&$red_october)[1]);
+ test 138, not tainted ((&$red_october)[2]);
+ my @corge = &$red_october;
+ test 139, not tainted $corge[0];
+ test 140, tainted $corge[1];
+ test 141, not tainted $corge[2];
+}
+
+# Test for system/library calls returning string data of dubious origin.
+{
+ # No reliable %Config check for getpw*
+ if (eval { setpwent(); getpwent(); 1 }) {
+ setpwent();
+ my @getpwent = getpwent();
+ die "getpwent: $!\n" unless (@getpwent);
+ test 142,( not tainted $getpwent[0]
+ and not tainted $getpwent[1]
+ and not tainted $getpwent[2]
+ and not tainted $getpwent[3]
+ and not tainted $getpwent[4]
+ and not tainted $getpwent[5]
+ and tainted $getpwent[6] # gecos
+ and not tainted $getpwent[7]
+ and not tainted $getpwent[8]);
+ endpwent();
+ } else {
+ for (142) { print "ok $_ # Skipped: getpwent() is not available\n" }
+ }
+
+ if ($Config{d_readdir}) { # pretty hard to imagine not
+ local(*D);
+ opendir(D, "op") or die "opendir: $!\n";
+ my $readdir = readdir(D);
+ test 143, tainted $readdir;
+ closedir(OP);
+ } else {
+ for (143) { print "ok $_ # Skipped: readdir() is not available\n" }
+ }
+
+ if ($Config{d_readlink} && $Config{d_symlink}) {
+ my $symlink = "sl$$";
+ unlink($symlink);
+ symlink("/something/naughty", $symlink) or die "symlink: $!\n";
+ my $readlink = readlink($symlink);
+ test 144, tainted $readlink;
+ unlink($symlink);
+ } else {
+ for (144) { print "ok $_ # Skipped: readlink() or symlink() is not available\n"; }
+ }
+}
+
+# test bitwise ops (regression bug)
+{
+ my $why = "y";
+ my $j = "x" | $why;
+ test 145, not tainted $j;
+ $why = $TAINT."y";
+ $j = "x" | $why;
+ test 146, tainted $j;
+}
+
+# test target of substitution (regression bug)
+{
+ my $why = $TAINT."y";
+ $why =~ s/y/z/;
+ test 147, tainted $why;
+
+ my $z = "[z]";
+ $why =~ s/$z/zee/;
+ test 148, tainted $why;
+
+ $why =~ s/e/'-'.$$/ge;
+ test 149, tainted $why;
+}
diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t
new file mode 100755
index 000000000000..77e74db4e2c8
--- /dev/null
+++ b/contrib/perl5/t/op/tie.t
@@ -0,0 +1,155 @@
+#!./perl
+
+# This test harness will (eventually) test the "tie" functionality
+# without the need for a *DBM* implementation.
+
+# Currently it only tests the untie warning
+
+chdir 't' if -d 't';
+@INC = "../lib";
+$ENV{PERL5LIB} = "../lib";
+
+$|=1;
+
+# catch warnings into fatal errors
+$SIG{__WARN__} = sub { die "WARNING: @_" } ;
+
+undef $/;
+@prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+for (@prgs){
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ eval "$prog" ;
+ $status = $?;
+ $results = $@ ;
+ $results =~ s/\n+$//;
+ $expected =~ s/\n+$//;
+ if ( $status or $results and $results !~ /^WARNING: $expected/){
+ print STDERR "STATUS: $status\n";
+ print STDERR "PROG: $prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+}
+
+__END__
+
+# standard behaviour, without any extra references
+use Tie::Hash ;
+tie %h, Tie::StdHash;
+untie %h;
+EXPECT
+########
+
+# standard behaviour, with 1 extra reference
+use Tie::Hash ;
+$a = tie %h, Tie::StdHash;
+untie %h;
+EXPECT
+########
+
+# standard behaviour, with 1 extra reference via tied
+use Tie::Hash ;
+tie %h, Tie::StdHash;
+$a = tied %h;
+untie %h;
+EXPECT
+########
+
+# standard behaviour, with 1 extra reference which is destroyed
+use Tie::Hash ;
+$a = tie %h, Tie::StdHash;
+$a = 0 ;
+untie %h;
+EXPECT
+########
+
+# standard behaviour, with 1 extra reference via tied which is destroyed
+use Tie::Hash ;
+tie %h, Tie::StdHash;
+$a = tied %h;
+$a = 0 ;
+untie %h;
+EXPECT
+########
+
+# strict behaviour, without any extra references
+#use warning 'untie';
+local $^W = 1 ;
+use Tie::Hash ;
+tie %h, Tie::StdHash;
+untie %h;
+EXPECT
+########
+
+# strict behaviour, with 1 extra references generating an error
+#use warning 'untie';
+local $^W = 1 ;
+use Tie::Hash ;
+$a = tie %h, Tie::StdHash;
+untie %h;
+EXPECT
+untie attempted while 1 inner references still exist
+########
+
+# strict behaviour, with 1 extra references via tied generating an error
+#use warning 'untie';
+local $^W = 1 ;
+use Tie::Hash ;
+tie %h, Tie::StdHash;
+$a = tied %h;
+untie %h;
+EXPECT
+untie attempted while 1 inner references still exist
+########
+
+# strict behaviour, with 1 extra references which are destroyed
+#use warning 'untie';
+local $^W = 1 ;
+use Tie::Hash ;
+$a = tie %h, Tie::StdHash;
+$a = 0 ;
+untie %h;
+EXPECT
+########
+
+# strict behaviour, with extra 1 references via tied which are destroyed
+#use warning 'untie';
+local $^W = 1 ;
+use Tie::Hash ;
+tie %h, Tie::StdHash;
+$a = tied %h;
+$a = 0 ;
+untie %h;
+EXPECT
+########
+
+# strict error behaviour, with 2 extra references
+#use warning 'untie';
+local $^W = 1 ;
+use Tie::Hash ;
+$a = tie %h, Tie::StdHash;
+$b = tied %h ;
+untie %h;
+EXPECT
+untie attempted while 2 inner references still exist
+########
+
+# strict behaviour, check scope of strictness.
+#no warning 'untie';
+local $^W = 0 ;
+use Tie::Hash ;
+$A = tie %H, Tie::StdHash;
+$C = $B = tied %H ;
+{
+ #use warning 'untie';
+ local $^W = 1 ;
+ use Tie::Hash ;
+ tie %h, Tie::StdHash;
+ untie %h;
+}
+untie %H;
+EXPECT
diff --git a/contrib/perl5/t/op/tiearray.t b/contrib/perl5/t/op/tiearray.t
new file mode 100755
index 000000000000..8e78b2f76b0e
--- /dev/null
+++ b/contrib/perl5/t/op/tiearray.t
@@ -0,0 +1,210 @@
+#!./perl
+
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+my %seen;
+
+package Implement;
+
+sub TIEARRAY
+{
+ $seen{'TIEARRAY'}++;
+ my ($class,@val) = @_;
+ return bless \@val,$class;
+}
+
+sub STORESIZE
+{
+ $seen{'STORESIZE'}++;
+ my ($ob,$sz) = @_;
+ return $#{$ob} = $sz-1;
+}
+
+sub EXTEND
+{
+ $seen{'EXTEND'}++;
+ my ($ob,$sz) = @_;
+ return @$ob = $sz;
+}
+
+sub FETCHSIZE
+{
+ $seen{'FETCHSIZE'}++;
+ return scalar(@{$_[0]});
+}
+
+sub FETCH
+{
+ $seen{'FETCH'}++;
+ my ($ob,$id) = @_;
+ return $ob->[$id];
+}
+
+sub STORE
+{
+ $seen{'STORE'}++;
+ my ($ob,$id,$val) = @_;
+ $ob->[$id] = $val;
+}
+
+sub UNSHIFT
+{
+ $seen{'UNSHIFT'}++;
+ my $ob = shift;
+ unshift(@$ob,@_);
+}
+
+sub PUSH
+{
+ $seen{'PUSH'}++;
+ my $ob = shift;;
+ push(@$ob,@_);
+}
+
+sub CLEAR
+{
+ $seen{'CLEAR'}++;
+ @{$_[0]} = ();
+}
+
+sub DESTROY
+{
+ $seen{'DESTROY'}++;
+}
+
+sub POP
+{
+ $seen{'POP'}++;
+ my ($ob) = @_;
+ return pop(@$ob);
+}
+
+sub SHIFT
+{
+ $seen{'SHIFT'}++;
+ my ($ob) = @_;
+ return shift(@$ob);
+}
+
+sub SPLICE
+{
+ $seen{'SPLICE'}++;
+ my $ob = shift;
+ my $off = @_ ? shift : 0;
+ my $len = @_ ? shift : @$ob-1;
+ return splice(@$ob,$off,$len,@_);
+}
+
+package main;
+
+print "1..31\n";
+my $test = 1;
+
+{my @ary;
+
+{ my $ob = tie @ary,'Implement',3,2,1;
+ print "not " unless $ob;
+ print "ok ", $test++,"\n";
+ print "not " unless tied(@ary) == $ob;
+ print "ok ", $test++,"\n";
+}
+
+
+print "not " unless @ary == 3;
+print "ok ", $test++,"\n";
+
+print "not " unless $#ary == 2;
+print "ok ", $test++,"\n";
+
+print "not " unless join(':',@ary) eq '3:2:1';
+print "ok ", $test++,"\n";
+
+print "not " unless $seen{'FETCH'} >= 3;
+print "ok ", $test++,"\n";
+
+@ary = (1,2,3);
+
+print "not " unless $seen{'STORE'} >= 3;
+print "ok ", $test++,"\n";
+print "not " unless join(':',@ary) eq '1:2:3';
+print "ok ", $test++,"\n";
+
+{my @thing = @ary;
+print "not " unless join(':',@thing) eq '1:2:3';
+print "ok ", $test++,"\n";
+
+tie @thing,'Implement';
+@thing = @ary;
+print "not " unless join(':',@thing) eq '1:2:3';
+print "ok ", $test++,"\n";
+}
+
+print "not " unless pop(@ary) == 3;
+print "ok ", $test++,"\n";
+print "not " unless $seen{'POP'} == 1;
+print "ok ", $test++,"\n";
+print "not " unless join(':',@ary) eq '1:2';
+print "ok ", $test++,"\n";
+
+push(@ary,4);
+print "not " unless $seen{'PUSH'} == 1;
+print "ok ", $test++,"\n";
+print "not " unless join(':',@ary) eq '1:2:4';
+print "ok ", $test++,"\n";
+
+my @x = splice(@ary,1,1,7);
+
+
+print "not " unless $seen{'SPLICE'} == 1;
+print "ok ", $test++,"\n";
+
+print "not " unless @x == 1;
+print "ok ", $test++,"\n";
+print "not " unless $x[0] == 2;
+print "ok ", $test++,"\n";
+print "not " unless join(':',@ary) eq '1:7:4';
+print "ok ", $test++,"\n";
+
+print "not " unless shift(@ary) == 1;
+print "ok ", $test++,"\n";
+print "not " unless $seen{'SHIFT'} == 1;
+print "ok ", $test++,"\n";
+print "not " unless join(':',@ary) eq '7:4';
+print "ok ", $test++,"\n";
+
+my $n = unshift(@ary,5,6);
+print "not " unless $seen{'UNSHIFT'} == 1;
+print "ok ", $test++,"\n";
+print "not " unless $n == 4;
+print "ok ", $test++,"\n";
+print "not " unless join(':',@ary) eq '5:6:7:4';
+print "ok ", $test++,"\n";
+
+@ary = split(/:/,'1:2:3');
+print "not " unless join(':',@ary) eq '1:2:3';
+print "ok ", $test++,"\n";
+
+my $t = 0;
+foreach $n (@ary)
+ {
+ print "not " unless $n == ++$t;
+ print "ok ", $test++,"\n";
+ }
+
+@ary = qw(3 2 1);
+print "not " unless join(':',@ary) eq '3:2:1';
+print "ok ", $test++,"\n";
+
+untie @ary;
+
+}
+
+print "not " unless $seen{'DESTROY'} == 2;
+print "ok ", $test++,"\n";
+
+
+
diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t
new file mode 100755
index 000000000000..e3d24723a94f
--- /dev/null
+++ b/contrib/perl5/t/op/tiehandle.t
@@ -0,0 +1,137 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+my @expect;
+my $data = "";
+my @data = ();
+my $test = 1;
+
+sub ok { print "not " unless shift; print "ok ",$test++,"\n"; }
+
+package Implement;
+
+BEGIN { *ok = \*main::ok }
+
+sub compare {
+ return unless @expect;
+ return ok(0) unless(@_ == @expect);
+
+ my $i;
+ for($i = 0 ; $i < @_ ; $i++) {
+ next if $_[$i] eq $expect[$i];
+ return ok(0);
+ }
+
+ ok(1);
+}
+
+sub TIEHANDLE {
+ compare(TIEHANDLE => @_);
+ my ($class,@val) = @_;
+ return bless \@val,$class;
+}
+
+sub PRINT {
+ compare(PRINT => @_);
+ 1;
+}
+
+sub PRINTF {
+ compare(PRINTF => @_);
+ 2;
+}
+
+sub READLINE {
+ compare(READLINE => @_);
+ wantarray ? @data : shift @data;
+}
+
+sub GETC {
+ compare(GETC => @_);
+ substr($data,0,1);
+}
+
+sub READ {
+ compare(READ => @_);
+ substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
+ 3;
+}
+
+sub WRITE {
+ compare(WRITE => @_);
+ $data = substr($_[1],$_[3] || 0, $_[2]);
+ 4;
+}
+
+sub CLOSE {
+ compare(CLOSE => @_);
+
+ 5;
+}
+
+package main;
+
+use Symbol;
+
+print "1..23\n";
+
+my $fh = gensym;
+
+@expect = (TIEHANDLE => 'Implement');
+my $ob = tie *$fh,'Implement';
+ok(ref($ob) eq 'Implement');
+ok(tied(*$fh) == $ob);
+
+@expect = (PRINT => $ob,"some","text");
+$r = print $fh @expect[2,3];
+ok($r == 1);
+
+@expect = (PRINTF => $ob,"%s","text");
+$r = printf $fh @expect[2,3];
+ok($r == 2);
+
+$text = (@data = ("the line\n"))[0];
+@expect = (READLINE => $ob);
+$ln = <$fh>;
+ok($ln eq $text);
+
+@expect = ();
+@in = @data = qw(a line at a time);
+@line = <$fh>;
+@expect = @in;
+Implement::compare(@line);
+
+@expect = (GETC => $ob);
+$data = "abc";
+$ch = getc $fh;
+ok($ch eq "a");
+
+$buf = "xyz";
+@expect = (READ => $ob, $buf, 3);
+$data = "abc";
+$r = read $fh,$buf,3;
+ok($r == 3);
+ok($buf eq "abc");
+
+
+$buf = "xyzasd";
+@expect = (READ => $ob, $buf, 3,3);
+$data = "abc";
+$r = sysread $fh,$buf,3,3;
+ok($r == 3);
+ok($buf eq "xyzabc");
+
+$buf = "qwerty";
+@expect = (WRITE => $ob, $buf, 4,1);
+$data = "";
+$r = syswrite $fh,$buf,4,1;
+ok($r == 4);
+ok($data eq "wert");
+
+@expect = (CLOSE => $ob);
+$r = close $fh;
+ok($r == 5);
diff --git a/contrib/perl5/t/op/time.t b/contrib/perl5/t/op/time.t
new file mode 100755
index 000000000000..1bec442fe2e8
--- /dev/null
+++ b/contrib/perl5/t/op/time.t
@@ -0,0 +1,47 @@
+#!./perl
+
+# $RCSfile: time.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:32 $
+
+if ($does_gmtime = gmtime(time)) { print "1..5\n" }
+else { print "1..3\n" }
+
+($beguser,$begsys) = times;
+
+$beg = time;
+
+while (($now = time) == $beg) { sleep 1 }
+
+if ($now > $beg && $now - $beg < 10){print "ok 1\n";} else {print "not ok 1\n";}
+
+for ($i = 0; $i < 100000; $i++) {
+ ($nowuser, $nowsys) = times;
+ $i = 200000 if $nowuser > $beguser && ( $nowsys > $begsys ||
+ (!$nowsys && !$begsys));
+ last if time - $beg > 20;
+}
+
+if ($i >= 200000) {print "ok 2\n";} else {print "not ok 2\n";}
+
+($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg);
+($xsec,$foo) = localtime($now);
+$localyday = $yday;
+
+if ($sec != $xsec && $mday && $year)
+ {print "ok 3\n";}
+else
+ {print "not ok 3\n";}
+
+exit 0 unless $does_gmtime;
+
+($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg);
+($xsec,$foo) = localtime($now);
+
+if ($sec != $xsec && $mday && $year)
+ {print "ok 4\n";}
+else
+ {print "not ok 4\n";}
+
+if (index(" :0:1:-1:364:365:-364:-365:",':' . ($localyday - $yday) . ':') > 0)
+ {print "ok 5\n";}
+else
+ {print "not ok 5\n";}
diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t
new file mode 100755
index 000000000000..8ab2ec421f32
--- /dev/null
+++ b/contrib/perl5/t/op/undef.t
@@ -0,0 +1,56 @@
+#!./perl
+
+# $RCSfile: undef.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:34 $
+
+print "1..21\n";
+
+print defined($a) ? "not ok 1\n" : "ok 1\n";
+
+$a = 1+1;
+print defined($a) ? "ok 2\n" : "not ok 2\n";
+
+undef $a;
+print defined($a) ? "not ok 3\n" : "ok 3\n";
+
+$a = "hi";
+print defined($a) ? "ok 4\n" : "not ok 4\n";
+
+$a = $b;
+print defined($a) ? "not ok 5\n" : "ok 5\n";
+
+@ary = ("1arg");
+$a = pop(@ary);
+print defined($a) ? "ok 6\n" : "not ok 6\n";
+$a = pop(@ary);
+print defined($a) ? "not ok 7\n" : "ok 7\n";
+
+@ary = ("1arg");
+$a = shift(@ary);
+print defined($a) ? "ok 8\n" : "not ok 8\n";
+$a = shift(@ary);
+print defined($a) ? "not ok 9\n" : "ok 9\n";
+
+$ary{'foo'} = 'hi';
+print defined($ary{'foo'}) ? "ok 10\n" : "not ok 10\n";
+print defined($ary{'bar'}) ? "not ok 11\n" : "ok 11\n";
+undef $ary{'foo'};
+print defined($ary{'foo'}) ? "not ok 12\n" : "ok 12\n";
+
+print defined(@ary) ? "ok 13\n" : "not ok 13\n";
+print defined(%ary) ? "ok 14\n" : "not ok 14\n";
+undef @ary;
+print defined(@ary) ? "not ok 15\n" : "ok 15\n";
+undef %ary;
+print defined(%ary) ? "not ok 16\n" : "ok 16\n";
+@ary = (1);
+print defined @ary ? "ok 17\n" : "not ok 17\n";
+%ary = (1,1);
+print defined %ary ? "ok 18\n" : "not ok 18\n";
+
+sub foo { print "ok 19\n"; }
+
+&foo || print "not ok 19\n";
+
+print defined &foo ? "ok 20\n" : "not ok 20\n";
+undef &foo;
+print defined(&foo) ? "not ok 21\n" : "ok 21\n";
diff --git a/contrib/perl5/t/op/universal.t b/contrib/perl5/t/op/universal.t
new file mode 100755
index 000000000000..bde78fd04ceb
--- /dev/null
+++ b/contrib/perl5/t/op/universal.t
@@ -0,0 +1,104 @@
+#!./perl
+#
+# check UNIVERSAL
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+print "1..72\n";
+
+$a = {};
+bless $a, "Bob";
+print "not " unless $a->isa("Bob");
+print "ok 1\n";
+
+package Human;
+sub eat {}
+
+package Female;
+@ISA=qw(Human);
+
+package Alice;
+@ISA=qw(Bob Female);
+sub drink {}
+sub new { bless {} }
+
+$Alice::VERSION = 2.718;
+
+package main;
+
+my $i = 2;
+sub test { print "not " unless shift; print "ok $i\n"; $i++; }
+
+$a = new Alice;
+
+test $a->isa("Alice");
+
+test $a->isa("Bob");
+
+test $a->isa("Female");
+
+test $a->isa("Human");
+
+test ! $a->isa("Male");
+
+test $a->can("drink");
+
+test $a->can("eat");
+
+test ! $a->can("sleep");
+
+my $b = 'abc';
+my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE);
+my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} );
+for ($p=0; $p < @refs; $p++) {
+ for ($q=0; $q < @vals; $q++) {
+ test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1);
+ };
+};
+
+test ! UNIVERSAL::can(23, "can");
+
+test $a->can("VERSION");
+
+test $a->can("can");
+test ! $a->can("export_tags"); # a method in Exporter
+
+test (eval { $a->VERSION }) == 2.718;
+
+test ! (eval { $a->VERSION(2.719) }) &&
+ $@ =~ /^Alice version 2.719 required--this is only version 2.718 at /;
+
+test (eval { $a->VERSION(2.718) }) && ! $@;
+
+my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
+if ('a' lt 'A') {
+ test $subs eq "can isa VERSION";
+} else {
+ test $subs eq "VERSION can isa";
+}
+
+test $a->isa("UNIVERSAL");
+
+# now use UNIVERSAL.pm and see what changes
+eval "use UNIVERSAL";
+
+test $a->isa("UNIVERSAL");
+
+my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
+# XXX import being here is really a bug
+if ('a' lt 'A') {
+ test $sub2 eq "can import isa VERSION";
+} else {
+ test $sub2 eq "VERSION can import isa";
+}
+
+eval 'sub UNIVERSAL::sleep {}';
+test $a->can("sleep");
+
+test ! UNIVERSAL::can($b, "can");
+
+test ! $a->can("export_tags"); # a method in Exporter
diff --git a/contrib/perl5/t/op/unshift.t b/contrib/perl5/t/op/unshift.t
new file mode 100755
index 000000000000..68d37756bd6f
--- /dev/null
+++ b/contrib/perl5/t/op/unshift.t
@@ -0,0 +1,14 @@
+#!./perl
+
+# $RCSfile: unshift.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:35 $
+
+print "1..2\n";
+
+@a = (1,2,3);
+$cnt1 = unshift(a,0);
+
+if (join(' ',@a) eq '0 1 2 3') {print "ok 1\n";} else {print "not ok 1\n";}
+$cnt2 = unshift(a,3,2,1);
+if (join(' ',@a) eq '3 2 1 0 1 2 3') {print "ok 2\n";} else {print "not ok 2\n";}
+
+
diff --git a/contrib/perl5/t/op/vec.t b/contrib/perl5/t/op/vec.t
new file mode 100755
index 000000000000..71171447d6e3
--- /dev/null
+++ b/contrib/perl5/t/op/vec.t
@@ -0,0 +1,27 @@
+#!./perl
+
+# $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $
+
+print "1..15\n";
+
+print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n";
+print length($foo) == 0 ? "ok 2\n" : "not ok 2\n";
+vec($foo,0,1) = 1;
+print length($foo) == 1 ? "ok 3\n" : "not ok 3\n";
+print ord($foo) == 1 ? "ok 4\n" : "not ok 4\n";
+print vec($foo,0,1) == 1 ? "ok 5\n" : "not ok 5\n";
+
+print vec($foo,20,1) == 0 ? "ok 6\n" : "not ok 6\n";
+vec($foo,20,1) = 1;
+print vec($foo,20,1) == 1 ? "ok 7\n" : "not ok 7\n";
+print length($foo) == 3 ? "ok 8\n" : "not ok 8\n";
+print vec($foo,1,8) == 0 ? "ok 9\n" : "not ok 9\n";
+vec($foo,1,8) = 0xf1;
+print vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n";
+print ((ord(substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n");
+print vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n";
+print vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n";
+vec($Vec, 0, 32) = 0xbaddacab;
+print $Vec eq "\xba\xdd\xac\xab" ? "ok 14\n" : "not ok 14\n";
+print vec($Vec, 0, 32) == 3135089835 ? "ok 15\n" : "not ok 15\n";
+
diff --git a/contrib/perl5/t/op/wantarray.t b/contrib/perl5/t/op/wantarray.t
new file mode 100755
index 000000000000..0a47b6d3ba0b
--- /dev/null
+++ b/contrib/perl5/t/op/wantarray.t
@@ -0,0 +1,16 @@
+#!./perl
+
+print "1..3\n";
+sub context {
+ my ( $cona, $testnum ) = @_;
+ my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V';
+ unless ( $cona eq $conb ) {
+ print "# Context $conb should be $cona\nnot ";
+ }
+ print "ok $testnum\n";
+}
+
+context('V',1);
+$a = context('S',2);
+@a = context('A',3);
+1;
diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t
new file mode 100755
index 000000000000..705fa7977b3e
--- /dev/null
+++ b/contrib/perl5/t/op/write.t
@@ -0,0 +1,169 @@
+#!./perl
+
+# $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $
+
+print "1..5\n";
+
+my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat';
+
+format OUT =
+the quick brown @<<
+$fox
+jumped
+@*
+$multiline
+^<<<<<<<<<
+$foo
+^<<<<<<<<<
+$foo
+^<<<<<<...
+$foo
+now @<<the@>>>> for all@|||||men to come @<<<<
+{
+ 'i' . 's', "time\n", $good, 'to'
+}
+.
+
+open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+
+$fox = 'foxiness';
+$good = 'good';
+$multiline = "forescore\nand\nseven years\n";
+$foo = 'when in the course of human events it becomes necessary';
+write(OUT);
+close OUT;
+
+$right =
+"the quick brown fox
+jumped
+forescore
+and
+seven years
+when in
+the course
+of huma...
+now is the time for all good men to come to\n";
+
+if (`$CAT Op_write.tmp` eq $right)
+ { print "ok 1\n"; unlink 'Op_write.tmp'; }
+else
+ { print "not ok 1\n"; }
+
+$fox = 'wolfishness';
+my $fox = 'foxiness'; # Test a lexical variable.
+
+format OUT2 =
+the quick brown @<<
+$fox
+jumped
+@*
+$multiline
+^<<<<<<<<< ~~
+$foo
+now @<<the@>>>> for all@|||||men to come @<<<<
+'i' . 's', "time\n", $good, 'to'
+.
+
+open OUT2, '>Op_write.tmp' or die "Can't create Op_write.tmp";
+
+$good = 'good';
+$multiline = "forescore\nand\nseven years\n";
+$foo = 'when in the course of human events it becomes necessary';
+write(OUT2);
+close OUT2;
+
+$right =
+"the quick brown fox
+jumped
+forescore
+and
+seven years
+when in
+the course
+of human
+events it
+becomes
+necessary
+now is the time for all good men to come to\n";
+
+if (`$CAT Op_write.tmp` eq $right)
+ { print "ok 2\n"; unlink 'Op_write.tmp'; }
+else
+ { print "not ok 2\n"; }
+
+eval <<'EOFORMAT';
+format OUT2 =
+the brown quick @<<
+$fox
+jumped
+@*
+$multiline
+and
+^<<<<<<<<< ~~
+$foo
+now @<<the@>>>> for all@|||||men to come @<<<<
+'i' . 's', "time\n", $good, 'to'
+.
+EOFORMAT
+
+open(OUT2, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+
+$fox = 'foxiness';
+$good = 'good';
+$multiline = "forescore\nand\nseven years\n";
+$foo = 'when in the course of human events it becomes necessary';
+write(OUT2);
+close OUT2;
+
+$right =
+"the brown quick fox
+jumped
+forescore
+and
+seven years
+and
+when in
+the course
+of human
+events it
+becomes
+necessary
+now is the time for all good men to come to\n";
+
+if (`$CAT Op_write.tmp` eq $right)
+ { print "ok 3\n"; unlink 'Op_write.tmp'; }
+else
+ { print "not ok 3\n"; }
+
+# formline tests
+
+$mustbe = <<EOT;
+@ a
+@> ab
+@>> abc
+@>>> abc
+@>>>> abc
+@>>>>> abc
+@>>>>>> abc
+@>>>>>>> abc
+@>>>>>>>> abc
+@>>>>>>>>> abc
+@>>>>>>>>>> abc
+EOT
+
+$was1 = $was2 = '';
+for (0..10) {
+ # lexical picture
+ $^A = '';
+ my $format1 = '@' . '>' x $_;
+ formline $format1, 'abc';
+ $was1 .= "$format1 $^A\n";
+ # global
+ $^A = '';
+ local $format2 = '@' . '>' x $_;
+ formline $format2, 'abc';
+ $was2 .= "$format2 $^A\n";
+}
+print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n";
+print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n";
+
diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t
new file mode 100755
index 000000000000..0b58bae60704
--- /dev/null
+++ b/contrib/perl5/t/pragma/constant.t
@@ -0,0 +1,141 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+}
+
+BEGIN {$^W |= 1} # Insist upon warnings
+use vars qw{ @warnings };
+BEGIN { # ...and save 'em for later
+ $SIG{'__WARN__'} = sub { push @warnings, @_ }
+}
+END { print @warnings }
+
+######################### We start with some black magic to print on failure.
+
+BEGIN { $| = 1; print "1..39\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use constant;
+$loaded = 1;
+#print "# Version: $constant::VERSION\n";
+print "ok 1\n";
+
+######################### End of black magic.
+
+use strict;
+
+sub test ($$;$) {
+ my($num, $bool, $diag) = @_;
+ if ($bool) {
+ print "ok $num\n";
+ return;
+ }
+ print "not ok $num\n";
+ return unless defined $diag;
+ $diag =~ s/\Z\n?/\n/; # unchomp
+ print map "# $num : $_", split m/^/m, $diag;
+}
+
+use constant PI => 4 * atan2 1, 1;
+
+test 2, substr(PI, 0, 7) eq '3.14159';
+test 3, defined PI;
+
+sub deg2rad { PI * $_[0] / 180 }
+
+my $ninety = deg2rad 90;
+
+test 4, $ninety > 1.5707;
+test 5, $ninety < 1.5708;
+
+use constant UNDEF1 => undef; # the right way
+use constant UNDEF2 => ; # the weird way
+use constant 'UNDEF3' ; # the 'short' way
+use constant EMPTY => ( ) ; # the right way for lists
+
+test 6, not defined UNDEF1;
+test 7, not defined UNDEF2;
+test 8, not defined UNDEF3;
+my @undef = UNDEF1;
+test 9, @undef == 1;
+test 10, not defined $undef[0];
+@undef = UNDEF2;
+test 11, @undef == 0;
+@undef = UNDEF3;
+test 12, @undef == 0;
+@undef = EMPTY;
+test 13, @undef == 0;
+
+use constant COUNTDOWN => scalar reverse 1, 2, 3, 4, 5;
+use constant COUNTLIST => reverse 1, 2, 3, 4, 5;
+use constant COUNTLAST => (COUNTLIST)[-1];
+
+test 14, COUNTDOWN eq '54321';
+my @cl = COUNTLIST;
+test 15, @cl == 5;
+test 16, COUNTDOWN eq join '', @cl;
+test 17, COUNTLAST == 1;
+test 18, (COUNTLIST)[1] == 4;
+
+use constant ABC => 'ABC';
+test 19, "abc${\( ABC )}abc" eq "abcABCabc";
+
+use constant DEF => 'D', 'E', chr ord 'F';
+test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f";
+
+use constant SINGLE => "'";
+use constant DOUBLE => '"';
+use constant BACK => '\\';
+my $tt = BACK . SINGLE . DOUBLE ;
+test 21, $tt eq q(\\'");
+
+use constant MESS => q('"'\\"'"\\);
+test 22, MESS eq q('"'\\"'"\\);
+test 23, length(MESS) == 8;
+
+use constant TRAILING => '12 cats';
+{
+ my $save_warn;
+ local $^W;
+ BEGIN { $save_warn = $^W; $^W = 0 }
+ test 24, TRAILING == 12;
+ BEGIN { $^W = $save_warn }
+}
+test 25, TRAILING eq '12 cats';
+
+use constant LEADING => " \t1234";
+test 26, LEADING == 1234;
+test 27, LEADING eq " \t1234";
+
+use constant ZERO1 => 0;
+use constant ZERO2 => 0.0;
+use constant ZERO3 => '0.0';
+test 28, ZERO1 eq '0';
+test 29, ZERO2 eq '0';
+test 30, ZERO3 eq '0.0';
+
+{
+ package Other;
+ use constant PI => 3.141;
+}
+
+test 31, (PI > 3.1415 and PI < 3.1416);
+test 32, Other::PI == 3.141;
+
+use constant E2BIG => $! = 7;
+test 33, E2BIG == 7;
+# This is something like "Arg list too long", but the actual message
+# text may vary, so we can't test much better than this.
+test 34, length(E2BIG) > 6;
+test 35, index(E2BIG, " ") > 0;
+
+test 36, @warnings == 0, join "\n", "unexpected warning", @warnings;
+@warnings = (); # just in case
+undef &PI;
+test 37, @warnings &&
+ ($warnings[0] =~ /Constant sub.* undefined/),
+ shift @warnings;
+
+test 38, @warnings == 0, "unexpected warning";
+test 39, $^W & 1, "Who disabled the warnings?";
diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t
new file mode 100755
index 000000000000..00baa6645e3a
--- /dev/null
+++ b/contrib/perl5/t/pragma/locale.t
@@ -0,0 +1,483 @@
+#!./perl -wT
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if (!$Config{d_setlocale} || $Config{ccflags} =~ /\bD?NO_LOCALE\b/) {
+ print "1..0\n";
+ exit;
+ }
+}
+
+use strict;
+
+my $have_setlocale = 0;
+eval {
+ require POSIX;
+ import POSIX ':locale_h';
+ $have_setlocale++;
+};
+
+# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1"
+# and mingw32 uses said silly CRT
+$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i;
+
+print "1..", ($have_setlocale ? 102 : 98), "\n";
+
+use vars qw($a
+ $English $German $French $Spanish
+ @C @English @German @French @Spanish
+ $Locale @Locale %iLocale %UPPER %lower @Neoalpha);
+
+$a = 'abc %';
+
+sub ok {
+ my ($n, $result) = @_;
+
+ print 'not ' unless ($result);
+ print "ok $n\n";
+}
+
+# First we'll do a lot of taint checking for locales.
+# This is the easiest to test, actually, as any locale,
+# even the default locale will taint under 'use locale'.
+
+sub is_tainted { # hello, camel two.
+ local $^W; # no warnings 'undef'
+ my $dummy;
+ not eval { $dummy = join("", @_), kill 0; 1 }
+}
+
+sub check_taint ($$) {
+ ok $_[0], is_tainted($_[1]);
+}
+
+sub check_taint_not ($$) {
+ ok $_[0], not is_tainted($_[1]);
+}
+
+use locale; # engage locale and therefore locale taint.
+
+check_taint_not 1, $a;
+
+check_taint 2, uc($a);
+check_taint 3, "\U$a";
+check_taint 4, ucfirst($a);
+check_taint 5, "\u$a";
+check_taint 6, lc($a);
+check_taint 7, "\L$a";
+check_taint 8, lcfirst($a);
+check_taint 9, "\l$a";
+
+check_taint 10, sprintf('%e', 123.456);
+check_taint 11, sprintf('%f', 123.456);
+check_taint 12, sprintf('%g', 123.456);
+check_taint_not 13, sprintf('%d', 123.456);
+check_taint_not 14, sprintf('%x', 123.456);
+
+$_ = $a; # untaint $_
+
+$_ = uc($a); # taint $_
+
+check_taint 15, $_;
+
+/(\w)/; # taint $&, $`, $', $+, $1.
+check_taint 16, $&;
+check_taint 17, $`;
+check_taint 18, $';
+check_taint 19, $+;
+check_taint 20, $1;
+check_taint_not 21, $2;
+
+/(.)/; # untaint $&, $`, $', $+, $1.
+check_taint_not 22, $&;
+check_taint_not 23, $`;
+check_taint_not 24, $';
+check_taint_not 25, $+;
+check_taint_not 26, $1;
+check_taint_not 27, $2;
+
+/(\W)/; # taint $&, $`, $', $+, $1.
+check_taint 28, $&;
+check_taint 29, $`;
+check_taint 30, $';
+check_taint 31, $+;
+check_taint 32, $1;
+check_taint_not 33, $2;
+
+/(\s)/; # taint $&, $`, $', $+, $1.
+check_taint 34, $&;
+check_taint 35, $`;
+check_taint 36, $';
+check_taint 37, $+;
+check_taint 38, $1;
+check_taint_not 39, $2;
+
+/(\S)/; # taint $&, $`, $', $+, $1.
+check_taint 40, $&;
+check_taint 41, $`;
+check_taint 42, $';
+check_taint 43, $+;
+check_taint 44, $1;
+check_taint_not 45, $2;
+
+$_ = $a; # untaint $_
+
+check_taint_not 46, $_;
+
+/(b)/; # this must not taint
+check_taint_not 47, $&;
+check_taint_not 48, $`;
+check_taint_not 49, $';
+check_taint_not 50, $+;
+check_taint_not 51, $1;
+check_taint_not 52, $2;
+
+$_ = $a; # untaint $_
+
+check_taint_not 53, $_;
+
+$b = uc($a); # taint $b
+s/(.+)/$b/; # this must taint only the $_
+
+check_taint 54, $_;
+check_taint_not 55, $&;
+check_taint_not 56, $`;
+check_taint_not 57, $';
+check_taint_not 58, $+;
+check_taint_not 59, $1;
+check_taint_not 60, $2;
+
+$_ = $a; # untaint $_
+
+s/(.+)/b/; # this must not taint
+check_taint_not 61, $_;
+check_taint_not 62, $&;
+check_taint_not 63, $`;
+check_taint_not 64, $';
+check_taint_not 65, $+;
+check_taint_not 66, $1;
+check_taint_not 67, $2;
+
+$b = $a; # untaint $b
+
+($b = $a) =~ s/\w/$&/;
+check_taint 68, $b; # $b should be tainted.
+check_taint_not 69, $a; # $a should be not.
+
+$_ = $a; # untaint $_
+
+s/(\w)/\l$1/; # this must taint
+check_taint 70, $_;
+check_taint 71, $&;
+check_taint 72, $`;
+check_taint 73, $';
+check_taint 74, $+;
+check_taint 75, $1;
+check_taint_not 76, $2;
+
+$_ = $a; # untaint $_
+
+s/(\w)/\L$1/; # this must taint
+check_taint 77, $_;
+check_taint 78, $&;
+check_taint 79, $`;
+check_taint 80, $';
+check_taint 81, $+;
+check_taint 82, $1;
+check_taint_not 83, $2;
+
+$_ = $a; # untaint $_
+
+s/(\w)/\u$1/; # this must taint
+check_taint 84, $_;
+check_taint 85, $&;
+check_taint 86, $`;
+check_taint 87, $';
+check_taint 88, $+;
+check_taint 89, $1;
+check_taint_not 90, $2;
+
+$_ = $a; # untaint $_
+
+s/(\w)/\U$1/; # this must taint
+check_taint 91, $_;
+check_taint 92, $&;
+check_taint 93, $`;
+check_taint 94, $';
+check_taint 95, $+;
+check_taint 96, $1;
+check_taint_not 97, $2;
+
+# After all this tainting $a should be cool.
+
+check_taint_not 98, $a;
+
+# I think we've seen quite enough of taint.
+# Let us do some *real* locale work now,
+# unless setlocale() is missing (i.e. minitest).
+
+exit unless $have_setlocale;
+
+sub getalnum {
+ sort grep /\w/, map { chr } 0..255
+}
+
+sub locatelocale ($$@) {
+ my ($lcall, $alnum, @try) = @_;
+
+ undef $$lcall;
+
+ for (@try) {
+ local $^W = 0; # suppress "Subroutine LC_ALL redefined"
+ if (setlocale(&LC_ALL, $_)) {
+ $$lcall = $_;
+ @$alnum = &getalnum;
+ last;
+ }
+ }
+
+ @$alnum = () unless (defined $$lcall);
+}
+
+# Find some default locale
+
+locatelocale(\$Locale, \@Locale, qw(C POSIX));
+
+# Find some English locale
+
+locatelocale(\$English, \@English,
+ qw(en_US.ISO8859-1 en_GB.ISO8859-1
+ en en_US en_UK en_IE en_CA en_AU en_NZ
+ english english.iso88591
+ american american.iso88591
+ british british.iso88591
+ ));
+
+# Find some German locale
+
+locatelocale(\$German, \@German,
+ qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1
+ de de_DE de_AT de_CH
+ german german.iso88591));
+
+# Find some French locale
+
+locatelocale(\$French, \@French,
+ qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1
+ fr fr_FR fr_BE fr_CA fr_CH
+ french french.iso88591));
+
+# Find some Spanish locale
+
+locatelocale(\$Spanish, \@Spanish,
+ qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1
+ es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1
+ es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1
+ es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1
+ es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1
+ es es_AR es_BO es_CL
+ es_CO es_CR es_EC
+ es_ES es_GT es_MX
+ es_NI es_PA es_PE
+ es_PY es_SV es_UY es_VE
+ spanish spanish.iso88591));
+
+# Select the largest of the alpha(num)bets.
+
+($Locale, @Locale) = ($English, @English)
+ if (@English > @Locale);
+($Locale, @Locale) = ($German, @German)
+ if (@German > @Locale);
+($Locale, @Locale) = ($French, @French)
+ if (@French > @Locale);
+($Locale, @Locale) = ($Spanish, @Spanish)
+ if (@Spanish > @Locale);
+
+{
+ local $^W = 0;
+ setlocale(&LC_ALL, $Locale);
+}
+
+# Sort it now that LC_ALL has been set.
+
+@Locale = sort @Locale;
+
+print "# Locale = $Locale\n";
+print "# Alnum_ = @Locale\n";
+
+{
+ my $i = 0;
+
+ for (@Locale) {
+ $iLocale{$_} = $i++;
+ }
+}
+
+# Sieve the uppercase and the lowercase.
+
+for (@Locale) {
+ if (/[^\d_]/) { # skip digits and the _
+ if (lc eq $_) {
+ $UPPER{$_} = uc;
+ } else {
+ $lower{$_} = lc;
+ }
+ }
+}
+
+# Find the alphabets that are not alphabets in the default locale.
+
+{
+ no locale;
+
+ for (keys %UPPER, keys %lower) {
+ push(@Neoalpha, $_) if (/\W/);
+ }
+}
+
+@Neoalpha = sort @Neoalpha;
+
+# Test \w.
+
+{
+ my $word = join('', @Neoalpha);
+
+ $word =~ /^(\w*)$/;
+
+ print 'not ' if ($1 ne $word);
+}
+print "ok 99\n";
+
+# Find places where the collation order differs from the default locale.
+
+print "# testing 100\n";
+{
+ my (@k, $i, $j, @d);
+
+ {
+ no locale;
+
+ @k = sort (keys %UPPER, keys %lower);
+ }
+
+ for ($i = 0; $i < @k; $i++) {
+ for ($j = $i + 1; $j < @k; $j++) {
+ if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) {
+ push(@d, [$k[$j], $k[$i]]);
+ }
+ }
+ }
+
+ # Cross-check those places.
+
+ for (@d) {
+ ($i, $j) = @$_;
+ if ($i gt $j) {
+ print "# failed 100 at:\n";
+ print "# i = $i, j = $j, i ",
+ $i le $j ? 'le' : 'gt', " j\n";
+ print 'not ';
+ last;
+ }
+ }
+}
+print "ok 100\n";
+
+# Cross-check whole character set.
+
+print "# testing 101\n";
+for (map { chr } 0..255) {
+ if (/\w/ and /\W/) { print 'not '; last }
+ if (/\d/ and /\D/) { print 'not '; last }
+ if (/\s/ and /\S/) { print 'not '; last }
+ if (/\w/ and /\D/ and not /_/ and
+ not (exists $UPPER{$_} or exists $lower{$_})) {
+ print "# failed 101 at:\n";
+ print "# ", ord($_), " '$_'\n";
+ print 'not ';
+ last;
+ }
+}
+print "ok 101\n";
+
+# Test for read-onlys.
+
+{
+ no locale;
+ $a = "qwerty";
+ {
+ use locale;
+ print "not " if $a cmp "qwerty";
+ }
+}
+print "ok 102\n";
+
+# This test must be the last one because its failure is not fatal.
+# The @Locale should be internally consistent.
+# Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no>
+# for inventing a way to test for ordering consistency
+# without requiring any particular order.
+# ++$jhi;#@iki.fi
+
+print "# testing 103\n";
+{
+ my ($from, $to, $lesser, $greater, @test, %test, $test, $yes, $no, $sign);
+
+ for (0..9) {
+ # Select a slice.
+ $from = int(($_*@Locale)/10);
+ $to = $from + int(@Locale/10);
+ $to = $#Locale if ($to > $#Locale);
+ $lesser = join('', @Locale[$from..$to]);
+ # Select a slice one character on.
+ $from++; $to++;
+ $to = $#Locale if ($to > $#Locale);
+ $greater = join('', @Locale[$from..$to]);
+ ($yes, $no, $sign) = ($lesser lt $greater
+ ? (" ", "not ", 1)
+ : ("not ", " ", -1));
+ # all these tests should FAIL (return 0).
+ @test =
+ (
+ $no.' ($lesser lt $greater)', # 0
+ $no.' ($lesser le $greater)', # 1
+ 'not ($lesser ne $greater)', # 2
+ ' ($lesser eq $greater)', # 3
+ $yes.' ($lesser ge $greater)', # 4
+ $yes.' ($lesser gt $greater)', # 5
+ $yes.' ($greater lt $lesser )', # 6
+ $yes.' ($greater le $lesser )', # 7
+ 'not ($greater ne $lesser )', # 8
+ ' ($greater eq $lesser )', # 9
+ $no.' ($greater ge $lesser )', # 10
+ $no.' ($greater gt $lesser )', # 11
+ 'not (($lesser cmp $greater) == -$sign)' # 12
+ );
+ @test{@test} = 0 x @test;
+ $test = 0;
+ for my $ti (@test) { $test{$ti} = eval $ti ; $test ||= $test{$ti} }
+ if ($test) {
+ print "# failed 103 at:\n";
+ print "# lesser = '$lesser'\n";
+ print "# greater = '$greater'\n";
+ print "# lesser cmp greater = ", $lesser cmp $greater, "\n";
+ print "# greater cmp lesser = ", $greater cmp $lesser, "\n";
+ print "# (greater) from = $from, to = $to\n";
+ for my $ti (@test) {
+ printf("# %-40s %-4s", $ti,
+ $test{$ti} ? 'FAIL' : 'ok');
+ if ($ti =~ /\(\.*(\$.+ +cmp +\$[^\)]+)\.*\)/) {
+ printf("(%s == %4d)", $1, eval $1);
+ }
+ print "\n";
+ }
+
+ warn "The locale definition on your system may have errors.\n";
+ last;
+ }
+ }
+}
+
+# eof
diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t
new file mode 100755
index 000000000000..afba8a322164
--- /dev/null
+++ b/contrib/perl5/t/pragma/overload.t
@@ -0,0 +1,698 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+package Oscalar;
+use overload (
+ # Anonymous subroutines:
+'+' => sub {new Oscalar $ {$_[0]}+$_[1]},
+'-' => sub {new Oscalar
+ $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
+'<=>' => sub {new Oscalar
+ $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]},
+'cmp' => sub {new Oscalar
+ $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
+'*' => sub {new Oscalar ${$_[0]}*$_[1]},
+'/' => sub {new Oscalar
+ $_[2]? $_[1]/${$_[0]} :
+ ${$_[0]}/$_[1]},
+'%' => sub {new Oscalar
+ $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]},
+'**' => sub {new Oscalar
+ $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]},
+
+qw(
+"" stringify
+0+ numify) # Order of arguments unsignificant
+);
+
+sub new {
+ my $foo = $_[1];
+ bless \$foo, $_[0];
+}
+
+sub stringify { "${$_[0]}" }
+sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
+ # comparing to direct compilation based on
+ # stringify
+
+package main;
+
+$test = 0;
+$| = 1;
+print "1..",&last,"\n";
+
+sub test {
+ $test++;
+ if (@_ > 1) {
+ if ($_[0] eq $_[1]) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test: '$_[0]' ne '$_[1]'\n";
+ }
+ } else {
+ if (shift) {
+ print "ok $test\n";
+ } else {
+ print "not ok $test\n";
+ }
+ }
+}
+
+$a = new Oscalar "087";
+$b= "$a";
+
+# All test numbers in comments are off by 1.
+# So much for hard-wiring them in :-) To fix this:
+test(1); # 1
+
+test ($b eq $a); # 2
+test ($b eq "087"); # 3
+test (ref $a eq "Oscalar"); # 4
+test ($a eq $a); # 5
+test ($a eq "087"); # 6
+
+$c = $a + 7;
+
+test (ref $c eq "Oscalar"); # 7
+test (!($c eq $a)); # 8
+test ($c eq "94"); # 9
+
+$b=$a;
+
+test (ref $a eq "Oscalar"); # 10
+
+$b++;
+
+test (ref $b eq "Oscalar"); # 11
+test ( $a eq "087"); # 12
+test ( $b eq "88"); # 13
+test (ref $a eq "Oscalar"); # 14
+
+$c=$b;
+$c-=$a;
+
+test (ref $c eq "Oscalar"); # 15
+test ( $a eq "087"); # 16
+test ( $c eq "1"); # 17
+test (ref $a eq "Oscalar"); # 18
+
+$b=1;
+$b+=$a;
+
+test (ref $b eq "Oscalar"); # 19
+test ( $a eq "087"); # 20
+test ( $b eq "88"); # 21
+test (ref $a eq "Oscalar"); # 22
+
+eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ];
+
+$b=$a;
+
+test (ref $a eq "Oscalar"); # 23
+
+$b++;
+
+test (ref $b eq "Oscalar"); # 24
+test ( $a eq "087"); # 25
+test ( $b eq "88"); # 26
+test (ref $a eq "Oscalar"); # 27
+
+package Oscalar;
+$dummy=bless \$dummy; # Now cache of method should be reloaded
+package main;
+
+$b=$a;
+$b++;
+
+test (ref $b eq "Oscalar"); # 28
+test ( $a eq "087"); # 29
+test ( $b eq "88"); # 30
+test (ref $a eq "Oscalar"); # 31
+
+
+eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
+
+$b=$a;
+
+test (ref $a eq "Oscalar"); # 32
+
+$b++;
+
+test (ref $b eq "Oscalar"); # 33
+test ( $a eq "087"); # 34
+test ( $b eq "88"); # 35
+test (ref $a eq "Oscalar"); # 36
+
+package Oscalar;
+$dummy=bless \$dummy; # Now cache of method should be reloaded
+package main;
+
+$b++;
+
+test (ref $b eq "Oscalar"); # 37
+test ( $a eq "087"); # 38
+test ( $b eq "90"); # 39
+test (ref $a eq "Oscalar"); # 40
+
+$b=$a;
+$b++;
+
+test (ref $b eq "Oscalar"); # 41
+test ( $a eq "087"); # 42
+test ( $b eq "89"); # 43
+test (ref $a eq "Oscalar"); # 44
+
+
+test ($b? 1:0); # 45
+
+eval q[ package Oscalar; use overload ('=' => sub {$main::copies++;
+ package Oscalar;
+ local $new=$ {$_[0]};
+ bless \$new } ) ];
+
+$b=new Oscalar "$a";
+
+test (ref $b eq "Oscalar"); # 46
+test ( $a eq "087"); # 47
+test ( $b eq "087"); # 48
+test (ref $a eq "Oscalar"); # 49
+
+$b++;
+
+test (ref $b eq "Oscalar"); # 50
+test ( $a eq "087"); # 51
+test ( $b eq "89"); # 52
+test (ref $a eq "Oscalar"); # 53
+test ($copies == 0); # 54
+
+$b+=1;
+
+test (ref $b eq "Oscalar"); # 55
+test ( $a eq "087"); # 56
+test ( $b eq "90"); # 57
+test (ref $a eq "Oscalar"); # 58
+test ($copies == 0); # 59
+
+$b=$a;
+$b+=1;
+
+test (ref $b eq "Oscalar"); # 60
+test ( $a eq "087"); # 61
+test ( $b eq "88"); # 62
+test (ref $a eq "Oscalar"); # 63
+test ($copies == 0); # 64
+
+$b=$a;
+$b++;
+
+test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65
+test ( $a eq "087"); # 66
+test ( $b eq "89"); # 67
+test (ref $a eq "Oscalar"); # 68
+test ($copies == 1); # 69
+
+eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1];
+ $_[0] } ) ];
+$c=new Oscalar; # Cause rehash
+
+$b=$a;
+$b+=1;
+
+test (ref $b eq "Oscalar"); # 70
+test ( $a eq "087"); # 71
+test ( $b eq "90"); # 72
+test (ref $a eq "Oscalar"); # 73
+test ($copies == 2); # 74
+
+$b+=$b;
+
+test (ref $b eq "Oscalar"); # 75
+test ( $b eq "360"); # 76
+test ($copies == 2); # 77
+$b=-$b;
+
+test (ref $b eq "Oscalar"); # 78
+test ( $b eq "-360"); # 79
+test ($copies == 2); # 80
+
+$b=abs($b);
+
+test (ref $b eq "Oscalar"); # 81
+test ( $b eq "360"); # 82
+test ($copies == 2); # 83
+
+$b=abs($b);
+
+test (ref $b eq "Oscalar"); # 84
+test ( $b eq "360"); # 85
+test ($copies == 2); # 86
+
+eval q[package Oscalar;
+ use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]}
+ : "_.${$_[0]}._" x $_[1])}) ];
+
+$a=new Oscalar "yy";
+$a x= 3;
+test ($a eq "_.yy.__.yy.__.yy._"); # 87
+
+eval q[package Oscalar;
+ use overload ('.' => sub {new Oscalar ( $_[2] ?
+ "_.$_[1].__.$ {$_[0]}._"
+ : "_.$ {$_[0]}.__.$_[1]._")}) ];
+
+$a=new Oscalar "xx";
+
+test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88
+
+# Check inheritance of overloading;
+{
+ package OscalarI;
+ @ISA = 'Oscalar';
+}
+
+$aI = new OscalarI "$a";
+test (ref $aI eq "OscalarI"); # 89
+test ("$aI" eq "xx"); # 90
+test ($aI eq "xx"); # 91
+test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92
+
+# Here we test blessing to a package updates hash
+
+eval "package Oscalar; no overload '.'";
+
+test ("b${a}" eq "_.b.__.xx._"); # 93
+$x="1";
+bless \$x, Oscalar;
+test ("b${a}c" eq "bxxc"); # 94
+new Oscalar 1;
+test ("b${a}c" eq "bxxc"); # 95
+
+# Negative overloading:
+
+$na = eval { ~$a };
+test($@ =~ /no method found/); # 96
+
+# Check AUTOLOADING:
+
+*Oscalar::AUTOLOAD =
+ sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
+ goto &{"Oscalar::$AUTOLOAD"}};
+
+eval "package Oscalar; sub comple; use overload '~' => 'comple'";
+
+$na = eval { ~$a }; # Hash was not updated
+test($@ =~ /no method found/); # 97
+
+bless \$x, Oscalar;
+
+$na = eval { ~$a }; # Hash updated
+warn "`$na', $@" if $@;
+test !$@; # 98
+test($na eq '_!_xx_!_'); # 99
+
+$na = 0;
+
+$na = eval { ~$aI }; # Hash was not updated
+test($@ =~ /no method found/); # 100
+
+bless \$x, OscalarI;
+
+$na = eval { ~$aI };
+print $@;
+
+test !$@; # 101
+test($na eq '_!_xx_!_'); # 102
+
+eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
+
+$na = eval { $aI >> 1 }; # Hash was not updated
+test($@ =~ /no method found/); # 103
+
+bless \$x, OscalarI;
+
+$na = 0;
+
+$na = eval { $aI >> 1 };
+print $@;
+
+test !$@; # 104
+test($na eq '_!_xx_!_'); # 105
+
+# warn overload::Method($a, '0+'), "\n";
+test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106
+test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107
+test (overload::Overloaded($aI)); # 108
+test (!overload::Overloaded('overload')); # 109
+
+test (! defined overload::Method($aI, '<<')); # 110
+test (! defined overload::Method($a, '<')); # 111
+
+test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
+test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
+
+# Check overloading by methods (specified deep in the ISA tree).
+{
+ package OscalarII;
+ @ISA = 'OscalarI';
+ sub Oscalar::lshft {"_<<_" . shift() . "_<<_"}
+ eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'";
+}
+
+$aaII = "087";
+$aII = \$aaII;
+bless $aII, 'OscalarII';
+bless \$fake, 'OscalarI'; # update the hash
+test(($aI | 3) eq '_<<_xx_<<_'); # 114
+# warn $aII << 3;
+test(($aII << 3) eq '_<<_087_<<_'); # 115
+
+{
+ BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; }
+ $out = 2**10;
+}
+test($int, 9); # 116
+test($out, 1024); # 117
+
+$foo = 'foo';
+$foo1 = 'f\'o\\o';
+{
+ BEGIN { $q = $qr = 7;
+ overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift},
+ 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; }
+ $out = 'foo';
+ $out1 = 'f\'o\\o';
+ $out2 = "a\a$foo,\,";
+ /b\b$foo.\./;
+}
+
+test($out, 'foo'); # 118
+test($out, $foo); # 119
+test($out1, 'f\'o\\o'); # 120
+test($out1, $foo1); # 121
+test($out2, "a\afoo,\,"); # 122
+test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123
+test($q, 11); # 124
+test("@qr", "b\\b qq .\\. qq"); # 125
+test($qr, 9); # 126
+
+{
+ $_ = '!<b>!foo!<-.>!';
+ BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"},
+ 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; }
+ $out = 'foo';
+ $out1 = 'f\'o\\o';
+ $out2 = "a\a$foo,\,";
+ $res = /b\b$foo.\./;
+ $a = <<EOF;
+oups
+EOF
+ $b = <<'EOF';
+oups1
+EOF
+ $c = bareword;
+ m'try it';
+ s'first part'second part';
+ s/yet another/tail here/;
+ tr/z-Z/z-Z/;
+}
+
+test($out, '_<foo>_'); # 117
+test($out1, '_<f\'o\\o>_'); # 128
+test($out2, "_<a\a>_foo_<,\,>_"); # 129
+test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups
+ qq oups1
+ q second part q tail here s z-Z tr z-Z tr"); # 130
+test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131
+test($res, 1); # 132
+test($a, "_<oups
+>_"); # 133
+test($b, "_<oups1
+>_"); # 134
+test($c, "bareword"); # 135
+
+{
+ package symbolic; # Primitive symbolic calculator
+ use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num,
+ '=' => \&cpy, '++' => \&inc, '--' => \&dec;
+
+ sub new { shift; bless ['n', @_] }
+ sub cpy {
+ my $self = shift;
+ bless [@$self], ref $self;
+ }
+ sub inc { $_[0] = bless ['++', $_[0], 1]; }
+ sub dec { $_[0] = bless ['--', $_[0], 1]; }
+ sub wrap {
+ my ($obj, $other, $inv, $meth) = @_;
+ if ($meth eq '++' or $meth eq '--') {
+ @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
+ return $obj;
+ }
+ ($obj, $other) = ($other, $obj) if $inv;
+ bless [$meth, $obj, $other];
+ }
+ sub str {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ if (defined $b) {
+ "[$meth $a $b]";
+ } else {
+ "[$meth $a]";
+ }
+ }
+ my %subr = ( 'n' => sub {$_[0]} );
+ foreach my $op (split " ", $overload::ops{with_assign}) {
+ $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+ }
+ my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+ foreach my $op (split " ", "@overload::ops{ @bins }") {
+ $subr{$op} = eval "sub {shift() $op shift()}";
+ }
+ foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+ $subr{$op} = eval "sub {$op shift()}";
+ }
+ $subr{'++'} = $subr{'+'};
+ $subr{'--'} = $subr{'-'};
+
+ sub num {
+ my ($meth, $a, $b) = @{+shift};
+ my $subr = $subr{$meth}
+ or die "Do not know how to ($meth) in symbolic";
+ $a = $a->num if ref $a eq __PACKAGE__;
+ $b = $b->num if ref $b eq __PACKAGE__;
+ $subr->($a,$b);
+ }
+ sub TIESCALAR { my $pack = shift; $pack->new(@_) }
+ sub FETCH { shift }
+ sub nop { } # Around a bug
+ sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+ sub STORE {
+ my $obj = shift;
+ $#$obj = 1;
+ @$obj->[0,1] = ('=', shift);
+ }
+}
+
+{
+ my $foo = new symbolic 11;
+ my $baz = $foo++;
+ test( (sprintf "%d", $foo), '12');
+ test( (sprintf "%d", $baz), '11');
+ my $bar = $foo;
+ $baz = ++$foo;
+ test( (sprintf "%d", $foo), '13');
+ test( (sprintf "%d", $bar), '12');
+ test( (sprintf "%d", $baz), '13');
+ my $ban = $foo;
+ $baz = ($foo += 1);
+ test( (sprintf "%d", $foo), '14');
+ test( (sprintf "%d", $bar), '12');
+ test( (sprintf "%d", $baz), '14');
+ test( (sprintf "%d", $ban), '13');
+ $baz = 0;
+ $baz = $foo++;
+ test( (sprintf "%d", $foo), '15');
+ test( (sprintf "%d", $baz), '14');
+ test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
+}
+
+{
+ my $iter = new symbolic 2;
+ my $side = new symbolic 1;
+ my $cnt = $iter;
+
+ while ($cnt) {
+ $cnt = $cnt - 1; # The "simple" way
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ my $pi = $side*(2**($iter+2));
+ test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+ test( (sprintf "%f", $pi), '3.182598');
+}
+
+{
+ my $iter = new symbolic 2;
+ my $side = new symbolic 1;
+ my $cnt = $iter;
+
+ while ($cnt--) {
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ my $pi = $side*(2**($iter+2));
+ test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+ test( (sprintf "%f", $pi), '3.182598');
+}
+
+{
+ my ($a, $b);
+ symbolic->vars($a, $b);
+ my $c = sqrt($a**2 + $b**2);
+ $a = 3; $b = 4;
+ test( (sprintf "%d", $c), '5');
+ $a = 12; $b = 5;
+ test( (sprintf "%d", $c), '13');
+}
+
+{
+ package symbolic1; # Primitive symbolic calculator
+ # Mutator inc/dec
+ use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy;
+
+ sub new { shift; bless ['n', @_] }
+ sub cpy {
+ my $self = shift;
+ bless [@$self], ref $self;
+ }
+ sub wrap {
+ my ($obj, $other, $inv, $meth) = @_;
+ if ($meth eq '++' or $meth eq '--') {
+ @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
+ return $obj;
+ }
+ ($obj, $other) = ($other, $obj) if $inv;
+ bless [$meth, $obj, $other];
+ }
+ sub str {
+ my ($meth, $a, $b) = @{+shift};
+ $a = 'u' unless defined $a;
+ if (defined $b) {
+ "[$meth $a $b]";
+ } else {
+ "[$meth $a]";
+ }
+ }
+ my %subr = ( 'n' => sub {$_[0]} );
+ foreach my $op (split " ", $overload::ops{with_assign}) {
+ $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}";
+ }
+ my @bins = qw(binary 3way_comparison num_comparison str_comparison);
+ foreach my $op (split " ", "@overload::ops{ @bins }") {
+ $subr{$op} = eval "sub {shift() $op shift()}";
+ }
+ foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
+ $subr{$op} = eval "sub {$op shift()}";
+ }
+ $subr{'++'} = $subr{'+'};
+ $subr{'--'} = $subr{'-'};
+
+ sub num {
+ my ($meth, $a, $b) = @{+shift};
+ my $subr = $subr{$meth}
+ or die "Do not know how to ($meth) in symbolic";
+ $a = $a->num if ref $a eq __PACKAGE__;
+ $b = $b->num if ref $b eq __PACKAGE__;
+ $subr->($a,$b);
+ }
+ sub TIESCALAR { my $pack = shift; $pack->new(@_) }
+ sub FETCH { shift }
+ sub nop { } # Around a bug
+ sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
+ sub STORE {
+ my $obj = shift;
+ $#$obj = 1;
+ @$obj->[0,1] = ('=', shift);
+ }
+}
+
+{
+ my $foo = new symbolic1 11;
+ my $baz = $foo++;
+ test( (sprintf "%d", $foo), '12');
+ test( (sprintf "%d", $baz), '11');
+ my $bar = $foo;
+ $baz = ++$foo;
+ test( (sprintf "%d", $foo), '13');
+ test( (sprintf "%d", $bar), '12');
+ test( (sprintf "%d", $baz), '13');
+ my $ban = $foo;
+ $baz = ($foo += 1);
+ test( (sprintf "%d", $foo), '14');
+ test( (sprintf "%d", $bar), '12');
+ test( (sprintf "%d", $baz), '14');
+ test( (sprintf "%d", $ban), '13');
+ $baz = 0;
+ $baz = $foo++;
+ test( (sprintf "%d", $foo), '15');
+ test( (sprintf "%d", $baz), '14');
+ test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
+}
+
+{
+ my $iter = new symbolic1 2;
+ my $side = new symbolic1 1;
+ my $cnt = $iter;
+
+ while ($cnt) {
+ $cnt = $cnt - 1; # The "simple" way
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ my $pi = $side*(2**($iter+2));
+ test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+ test( (sprintf "%f", $pi), '3.182598');
+}
+
+{
+ my $iter = new symbolic1 2;
+ my $side = new symbolic1 1;
+ my $cnt = $iter;
+
+ while ($cnt--) {
+ $side = (sqrt(1 + $side**2) - 1)/$side;
+ }
+ my $pi = $side*(2**($iter+2));
+ test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]';
+ test( (sprintf "%f", $pi), '3.182598');
+}
+
+{
+ my ($a, $b);
+ symbolic1->vars($a, $b);
+ my $c = sqrt($a**2 + $b**2);
+ $a = 3; $b = 4;
+ test( (sprintf "%d", $c), '5');
+ $a = 12; $b = 5;
+ test( (sprintf "%d", $c), '13');
+}
+
+{
+ package two_face; # Scalars with separate string and
+ # numeric values.
+ sub new { my $p = shift; bless [@_], $p }
+ use overload '""' => \&str, '0+' => \&num, fallback => 1;
+ sub num {shift->[1]}
+ sub str {shift->[0]}
+}
+
+{
+ my $seven = new two_face ("vii", 7);
+ test( (sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1),
+ 'seven=vii, seven=7, eight=8');
+ test( scalar ($seven =~ /i/), '1')
+}
+
+# Last test is:
+sub last {173}
diff --git a/contrib/perl5/t/pragma/strict-refs b/contrib/perl5/t/pragma/strict-refs
new file mode 100644
index 000000000000..7bf1556e10a7
--- /dev/null
+++ b/contrib/perl5/t/pragma/strict-refs
@@ -0,0 +1,295 @@
+Check strict refs functionality
+
+__END__
+
+# no strict, should build & run ok.
+my $fred ;
+$b = "fred" ;
+$a = $$b ;
+$c = ${"def"} ;
+$c = @{"def"} ;
+$c = %{"def"} ;
+$c = *{"def"} ;
+$c = \&{"def"} ;
+$c = def->[0];
+$c = def->{xyz};
+EXPECT
+
+########
+
+# strict refs - error
+use strict ;
+my $fred ;
+my $a = ${"fred"} ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $fred ;
+my $a = ${"fred"} ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $fred ;
+my $b = "fred" ;
+my $a = $$b ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 6.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $b ;
+my $a = $$b ;
+EXPECT
+Can't use an undefined value as a SCALAR reference at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $b ;
+my $a = @$b ;
+EXPECT
+Can't use an undefined value as an ARRAY reference at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $b ;
+my $a = %$b ;
+EXPECT
+Can't use an undefined value as a HASH reference at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $b ;
+my $a = *$b ;
+EXPECT
+Can't use an undefined value as a symbol reference at - line 5.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $a = fred->[0] ;
+EXPECT
+Can't use bareword ("fred") as an ARRAY ref while "strict refs" in use at - line 4.
+########
+
+# strict refs - error
+use strict 'refs' ;
+my $a = fred->{barney} ;
+EXPECT
+Can't use bareword ("fred") as a HASH ref while "strict refs" in use at - line 4.
+########
+
+# strict refs - no error
+use strict ;
+no strict 'refs' ;
+my $fred ;
+my $b = "fred" ;
+my $a = $$b ;
+use strict 'refs' ;
+EXPECT
+
+########
+
+# strict refs - no error
+use strict qw(subs vars) ;
+my $fred ;
+my $b = "fred" ;
+my $a = $$b ;
+use strict 'refs' ;
+EXPECT
+
+########
+
+# strict refs - no error
+my $fred ;
+my $b = "fred" ;
+my $a = $$b ;
+use strict 'refs' ;
+EXPECT
+
+########
+
+# strict refs - no error
+use strict 'refs' ;
+my $fred ;
+my $b = \$fred ;
+my $a = $$b ;
+EXPECT
+
+########
+
+# Check runtime scope of strict refs pragma
+use strict 'refs';
+my $fred ;
+my $b = "fred" ;
+{
+ no strict ;
+ my $a = $$b ;
+}
+my $a = $$b ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10.
+########
+
+# Check runtime scope of strict refs pragma
+no strict ;
+my $fred ;
+my $b = "fred" ;
+{
+ use strict 'refs' ;
+ my $a = $$b ;
+}
+my $a = $$b ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+########
+
+# Check runtime scope of strict refs pragma
+no strict ;
+my $fred ;
+my $b = "fred" ;
+{
+ use strict 'refs' ;
+ $a = sub { my $c = $$b ; }
+}
+&$a ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+########
+
+
+--FILE-- abc
+my $a = ${"Fred"} ;
+1;
+--FILE--
+use strict 'refs' ;
+require "./abc";
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'refs' ;
+1;
+--FILE--
+require "./abc";
+my $a = ${"Fred"} ;
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'refs' ;
+my $a = ${"Fred"} ;
+1;
+--FILE--
+${"Fred"} ;
+require "./abc";
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at ./abc line 2.
+########
+
+--FILE-- abc.pm
+use strict 'refs' ;
+my $a = ${"Fred"} ;
+1;
+--FILE--
+my $a = ${"Fred"} ;
+use abc;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at abc.pm line 2.
+BEGIN failed--compilation aborted at - line 2.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+ my $a = ${"Fred"} ;
+};
+print STDERR $@ ;
+my $a = ${"Fred"} ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+ use strict 'refs' ;
+ my $a = ${"Fred"} ;
+};
+print STDERR $@ ;
+my $a = ${"Fred"} ;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 6.
+########
+
+# Check scope of pragma with eval
+use strict 'refs' ;
+eval {
+ my $a = ${"Fred"} ;
+};
+print STDERR $@ ;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 5.
+########
+
+# Check scope of pragma with eval
+use strict 'refs' ;
+eval {
+ no strict ;
+ my $a = ${"Fred"} ;
+};
+print STDERR $@ ;
+my $a = ${"Fred"} ;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 9.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval '
+ my $a = ${"Fred"} ;
+'; print STDERR $@ ;
+my $a = ${"Fred"} ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval q[
+ use strict 'refs' ;
+ my $a = ${"Fred"} ;
+]; print STDERR $@;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+use strict 'refs' ;
+eval '
+ my $a = ${"Fred"} ;
+'; print STDERR $@ ;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at (eval 1) line 2.
+########
+
+# Check scope of pragma with eval
+use strict 'refs' ;
+eval '
+ no strict ;
+ my $a = ${"Fred"} ;
+'; print STDERR $@;
+my $a = ${"Fred"} ;
+EXPECT
+Can't use string ("Fred") as a SCALAR ref while "strict refs" in use at - line 8.
diff --git a/contrib/perl5/t/pragma/strict-subs b/contrib/perl5/t/pragma/strict-subs
new file mode 100644
index 000000000000..61ec286eb6db
--- /dev/null
+++ b/contrib/perl5/t/pragma/strict-subs
@@ -0,0 +1,279 @@
+Check strict subs functionality
+
+__END__
+
+# no strict, should build & run ok.
+Fred ;
+my $fred ;
+$b = "fred" ;
+$a = $$b ;
+EXPECT
+
+########
+
+use strict qw(refs vars);
+Fred ;
+EXPECT
+
+########
+
+use strict ;
+no strict 'subs' ;
+Fred ;
+EXPECT
+
+########
+
+# strict subs - error
+use strict 'subs' ;
+Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# strict subs - error
+use strict ;
+Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# strict subs - no error
+use strict 'subs' ;
+sub Fred {}
+Fred ;
+EXPECT
+
+########
+
+# Check compile time scope of strict subs pragma
+use strict 'subs' ;
+{
+ no strict ;
+ my $a = Fred ;
+}
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict subs pragma
+no strict;
+{
+ use strict 'subs' ;
+ my $a = Fred ;
+}
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 6.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict vars pragma
+use strict 'vars' ;
+{
+ no strict ;
+ $joe = 1 ;
+}
+$joe = 1 ;
+EXPECT
+Variable "$joe" is not imported at - line 8.
+Global symbol "$joe" requires explicit package name at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict vars pragma
+no strict;
+{
+ use strict 'vars' ;
+ $joe = 1 ;
+}
+$joe = 1 ;
+EXPECT
+Global symbol "$joe" requires explicit package name at - line 6.
+Execution of - aborted due to compilation errors.
+########
+
+# Check runtime scope of strict refs pragma
+use strict 'refs';
+my $fred ;
+my $b = "fred" ;
+{
+ no strict ;
+ my $a = $$b ;
+}
+my $a = $$b ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 10.
+########
+
+# Check runtime scope of strict refs pragma
+no strict ;
+my $fred ;
+my $b = "fred" ;
+{
+ use strict 'refs' ;
+ my $a = $$b ;
+}
+my $a = $$b ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+########
+
+# Check runtime scope of strict refs pragma
+no strict ;
+my $fred ;
+my $b = "fred" ;
+{
+ use strict 'refs' ;
+ $a = sub { my $c = $$b ; }
+}
+&$a ;
+EXPECT
+Can't use string ("fred") as a SCALAR ref while "strict refs" in use at - line 8.
+########
+
+use strict 'subs' ;
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 3.
+Execution of - aborted due to compilation errors.
+########
+
+--FILE-- abc
+my $a = Fred ;
+1;
+--FILE--
+use strict 'subs' ;
+require "./abc";
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'subs' ;
+1;
+--FILE--
+require "./abc";
+my $a = Fred ;
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'subs' ;
+my $a = Fred ;
+1;
+--FILE--
+Fred ;
+require "./abc";
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at ./abc line 2.
+Compilation failed in require at - line 2.
+########
+
+--FILE-- abc.pm
+use strict 'subs' ;
+my $a = Fred ;
+1;
+--FILE--
+Fred ;
+use abc;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at abc.pm line 2.
+Compilation failed in require at - line 2.
+BEGIN failed--compilation aborted at - line 2.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+ my $a = Fred ;
+};
+print STDERR $@;
+my $a = Fred ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+ use strict 'subs' ;
+ my $a = Fred ;
+};
+print STDERR $@;
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 6.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+use strict 'subs' ;
+eval {
+ my $a = Fred ;
+};
+print STDERR $@;
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 5.
+Bareword "Fred" not allowed while "strict subs" in use at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+use strict 'subs' ;
+eval {
+ no strict ;
+ my $a = Fred ;
+};
+print STDERR $@;
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 9.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval '
+ Fred ;
+'; print STDERR $@ ;
+Fred ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval q[
+ use strict 'subs' ;
+ Fred ;
+]; print STDERR $@;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+use strict 'subs' ;
+eval '
+ Fred ;
+'; print STDERR $@ ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at (eval 1) line 2.
+########
+
+# Check scope of pragma with eval
+use strict 'subs' ;
+eval '
+ no strict ;
+ my $a = Fred ;
+'; print STDERR $@;
+my $a = Fred ;
+EXPECT
+Bareword "Fred" not allowed while "strict subs" in use at - line 8.
+Execution of - aborted due to compilation errors.
diff --git a/contrib/perl5/t/pragma/strict-vars b/contrib/perl5/t/pragma/strict-vars
new file mode 100644
index 000000000000..42107fa8e100
--- /dev/null
+++ b/contrib/perl5/t/pragma/strict-vars
@@ -0,0 +1,223 @@
+Check strict vars functionality
+
+__END__
+
+# no strict, should build & run ok.
+Fred ;
+my $fred ;
+$b = "fred" ;
+$a = $$b ;
+EXPECT
+
+########
+
+use strict qw(subs refs) ;
+$fred ;
+EXPECT
+
+########
+
+use strict ;
+no strict 'vars' ;
+$fred ;
+EXPECT
+
+########
+
+# strict vars - no error
+use strict 'vars' ;
+use vars qw( $freddy) ;
+local $abc::joe ;
+my $fred ;
+my $b = \$fred ;
+$Fred::ABC = 1 ;
+$freddy = 2 ;
+EXPECT
+
+########
+
+# strict vars - error
+use strict ;
+$fred ;
+EXPECT
+Global symbol "$fred" requires explicit package name at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# strict vars - error
+use strict 'vars' ;
+$fred ;
+EXPECT
+Global symbol "$fred" requires explicit package name at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# strict vars - error
+use strict 'vars' ;
+local $fred ;
+EXPECT
+Global symbol "$fred" requires explicit package name at - line 4.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict vars pragma
+use strict 'vars' ;
+{
+ no strict ;
+ $joe = 1 ;
+}
+$joe = 1 ;
+EXPECT
+Variable "$joe" is not imported at - line 8.
+Global symbol "$joe" requires explicit package name at - line 8.
+Execution of - aborted due to compilation errors.
+########
+
+# Check compile time scope of strict vars pragma
+no strict;
+{
+ use strict 'vars' ;
+ $joe = 1 ;
+}
+$joe = 1 ;
+EXPECT
+Global symbol "$joe" requires explicit package name at - line 6.
+Execution of - aborted due to compilation errors.
+########
+
+--FILE-- abc
+$joe = 1 ;
+1;
+--FILE--
+use strict 'vars' ;
+require "./abc";
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'vars' ;
+1;
+--FILE--
+require "./abc";
+$joe = 1 ;
+EXPECT
+
+########
+
+--FILE-- abc
+use strict 'vars' ;
+$joe = 1 ;
+1;
+--FILE--
+$joe = 1 ;
+require "./abc";
+EXPECT
+Variable "$joe" is not imported at ./abc line 2.
+Global symbol "$joe" requires explicit package name at ./abc line 2.
+Compilation failed in require at - line 2.
+########
+
+--FILE-- abc.pm
+use strict 'vars' ;
+$joe = 1 ;
+1;
+--FILE--
+$joe = 1 ;
+use abc;
+EXPECT
+Variable "$joe" is not imported at abc.pm line 2.
+Global symbol "$joe" requires explicit package name at abc.pm line 2.
+Compilation failed in require at - line 2.
+BEGIN failed--compilation aborted at - line 2.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+ $joe = 1 ;
+};
+print STDERR $@;
+$joe = 1 ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval {
+ use strict 'vars' ;
+ $joe = 1 ;
+};
+print STDERR $@;
+$joe = 1 ;
+EXPECT
+Global symbol "$joe" requires explicit package name at - line 6.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+use strict 'vars' ;
+eval {
+ $joe = 1 ;
+};
+print STDERR $@;
+$joe = 1 ;
+EXPECT
+Global symbol "$joe" requires explicit package name at - line 5.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+use strict 'vars' ;
+eval {
+ no strict ;
+ $joe = 1 ;
+};
+print STDERR $@;
+$joe = 1 ;
+EXPECT
+Variable "$joe" is not imported at - line 9.
+Global symbol "$joe" requires explicit package name at - line 9.
+Execution of - aborted due to compilation errors.
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval '
+ $joe = 1 ;
+'; print STDERR $@ ;
+$joe = 1 ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no strict ;
+eval q[
+ use strict 'vars' ;
+ $joe = 1 ;
+]; print STDERR $@;
+EXPECT
+Global symbol "$joe" requires explicit package name at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+use strict 'vars' ;
+eval '
+ $joe = 1 ;
+'; print STDERR $@ ;
+EXPECT
+Global symbol "$joe" requires explicit package name at (eval 1) line 2.
+########
+
+# Check scope of pragma with eval
+use strict 'vars' ;
+eval '
+ no strict ;
+ $joe = 1 ;
+'; print STDERR $@;
+$joe = 1 ;
+EXPECT
+Global symbol "$joe" requires explicit package name at - line 8.
+Execution of - aborted due to compilation errors.
diff --git a/contrib/perl5/t/pragma/strict.t b/contrib/perl5/t/pragma/strict.t
new file mode 100755
index 000000000000..fc3282089fa8
--- /dev/null
+++ b/contrib/perl5/t/pragma/strict.t
@@ -0,0 +1,93 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+}
+
+$| = 1;
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MSWin32 = $^O eq 'MSWin32';
+my $tmpfile = "tmp0000";
+my $i = 0 ;
+1 while -f ++$tmpfile;
+END { if ($tmpfile) { 1 while unlink $tmpfile; } }
+
+my @prgs = () ;
+
+foreach (sort glob("pragma/strict-*")) {
+
+ next if /(~|\.orig)$/;
+
+ open F, "<$_" or die "Cannot open $_: $!\n" ;
+ while (<F>) {
+ last if /^__END__/ ;
+ }
+
+ {
+ local $/ = undef;
+ @prgs = (@prgs, split "\n########\n", <F>) ;
+ }
+ close F ;
+}
+
+undef $/;
+
+print "1..", scalar @prgs, "\n";
+
+
+for (@prgs){
+ my $switch = "";
+ my @temps = () ;
+ if (s/^\s*-\w+//){
+ $switch = $&;
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ if ( $prog =~ /--FILE--/) {
+ my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+ shift @files ;
+ die "Internal error test $i didn't split into pairs, got " .
+ scalar(@files) . "[" . join("%%%%", @files) ."]\n"
+ if @files % 2 ;
+ while (@files > 2) {
+ my $filename = shift @files ;
+ my $code = shift @files ;
+ push @temps, $filename ;
+ open F, ">$filename" or die "Cannot open $filename: $!\n" ;
+ print F $code ;
+ close F ;
+ }
+ shift @files ;
+ $prog = shift @files ;
+ }
+ open TEST, ">$tmpfile";
+ print TEST $prog,"\n";
+ close TEST;
+ my $results = $Is_VMS ?
+ `MCR $^X $switch $tmpfile` :
+ $Is_MSWin32 ?
+ `.\\perl -I../lib $switch $tmpfile 2>&1` :
+ `sh -c './perl $switch $tmpfile' 2>&1`;
+ my $status = $?;
+ $results =~ s/\n+$//;
+ # allow expected output to be written as if $prog is on STDIN
+ $results =~ s/tmp\d+/-/g;
+ $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
+ $expected =~ s/\n+$//;
+ my $prefix = ($results =~ s/^PREFIX\n//) ;
+ if ( $results =~ s/^SKIPPED\n//) {
+ print "$results\n" ;
+ }
+ elsif (($prefix and $results !~ /^\Q$expected/) or
+ (!$prefix and $results ne $expected)){
+ print STDERR "PROG: $switch\n$prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+ foreach (@temps)
+ { unlink $_ if $_ }
+}
diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t
new file mode 100755
index 000000000000..680564f843f4
--- /dev/null
+++ b/contrib/perl5/t/pragma/subs.t
@@ -0,0 +1,133 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+}
+
+$| = 1;
+undef $/;
+my @prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MSWin32 = $^O eq 'MSWin32';
+my $tmpfile = "tmp0000";
+my $i = 0 ;
+1 while -f ++$tmpfile;
+END { if ($tmpfile) { 1 while unlink $tmpfile} }
+
+for (@prgs){
+ my $switch = "";
+ my @temps = () ;
+ if (s/^\s*-\w+//){
+ $switch = $&;
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ if ( $prog =~ /--FILE--/) {
+ my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+ shift @files ;
+ die "Internal error test $i didn't split into pairs, got " .
+ scalar(@files) . "[" . join("%%%%", @files) ."]\n"
+ if @files % 2 ;
+ while (@files > 2) {
+ my $filename = shift @files ;
+ my $code = shift @files ;
+ push @temps, $filename ;
+ open F, ">$filename" or die "Cannot open $filename: $!\n" ;
+ print F $code ;
+ close F ;
+ }
+ shift @files ;
+ $prog = shift @files ;
+ }
+ open TEST, ">$tmpfile";
+ print TEST $prog,"\n";
+ close TEST;
+ my $results = $Is_VMS ?
+ `MCR $^X $switch $tmpfile` :
+ $Is_MSWin32 ?
+ `.\\perl -I../lib $switch $tmpfile 2>&1` :
+ `sh -c './perl $switch $tmpfile' 2>&1`;
+ my $status = $?;
+ $results =~ s/\n+$//;
+ # allow expected output to be written as if $prog is on STDIN
+ $results =~ s/tmp\d+/-/g;
+ $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
+ $results =~ s/Syntax/syntax/; # non-standard yacc
+ $expected =~ s/\n+$//;
+ my $prefix = ($results =~ s/^PREFIX\n//) ;
+ if ( $results =~ s/^SKIPPED\n//) {
+ print "$results\n" ;
+ }
+ elsif (($prefix and $results !~ /^\Q$expected/) or
+ (!$prefix and $results ne $expected)){
+ print STDERR "PROG: $switch\n$prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+ foreach (@temps)
+ { unlink $_ if $_ }
+}
+
+__END__
+
+# Error - not predeclaring a sub
+Fred 1,2 ;
+sub Fred {}
+EXPECT
+Number found where operator expected at - line 3, near "Fred 1"
+ (Do you need to predeclare Fred?)
+syntax error at - line 3, near "Fred 1"
+Execution of - aborted due to compilation errors.
+########
+
+# Error - not predeclaring a sub in time
+Fred 1,2 ;
+use subs qw( Fred ) ;
+sub Fred {}
+EXPECT
+Number found where operator expected at - line 3, near "Fred 1"
+ (Do you need to predeclare Fred?)
+syntax error at - line 3, near "Fred 1"
+BEGIN not safe after errors--compilation aborted at - line 4.
+########
+
+# AOK
+use subs qw( Fred) ;
+Fred 1,2 ;
+sub Fred { print $_[0] + $_[1], "\n" }
+EXPECT
+3
+########
+
+# override a built-in function
+use subs qw( open ) ;
+open 1,2 ;
+sub open { print $_[0] + $_[1], "\n" }
+EXPECT
+3
+########
+
+--FILE-- abc
+Fred 1,2 ;
+1;
+--FILE--
+use subs qw( Fred ) ;
+require "./abc" ;
+sub Fred { print $_[0] + $_[1], "\n" }
+EXPECT
+3
+########
+
+# check that it isn't affected by block scope
+{
+ use subs qw( Fred ) ;
+}
+Fred 1, 2;
+sub Fred { print $_[0] + $_[1], "\n" }
+EXPECT
+3
diff --git a/contrib/perl5/t/pragma/warn-1global b/contrib/perl5/t/pragma/warn-1global
new file mode 100644
index 000000000000..07b5bc8eb94d
--- /dev/null
+++ b/contrib/perl5/t/pragma/warn-1global
@@ -0,0 +1,151 @@
+Check existing $^W functionality
+
+__END__
+
+# warnable code, warnings disabled
+$a =+ 3 ;
+EXPECT
+
+########
+-w
+# warnable code, warnings enabled via command line switch
+$a =+ 3 ;
+EXPECT
+Reversed += operator at - line 3.
+########
+#! perl -w
+# warnable code, warnings enabled via #! line
+$a =+ 3 ;
+EXPECT
+Reversed += operator at - line 3.
+########
+
+# warnable code, warnings enabled via compile time $^W
+BEGIN { $^W = 1 }
+$a =+ 3 ;
+EXPECT
+Reversed += operator at - line 4.
+########
+
+# compile-time warnable code, warnings enabled via runtime $^W
+# so no warning printed.
+$^W = 1 ;
+$a =+ 3 ;
+EXPECT
+
+########
+
+# warnable code, warnings enabled via runtime $^W
+$^W = 1 ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 4.
+########
+
+# warnings enabled at compile time, disabled at run time
+BEGIN { $^W = 1 }
+$^W = 0 ;
+my $b ; chop $b ;
+EXPECT
+
+########
+
+# warnings disabled at compile time, enabled at run time
+BEGIN { $^W = 0 }
+$^W = 1 ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 5.
+########
+-w
+--FILE-- abcd
+my $b ; chop $b ;
+1 ;
+--FILE--
+require "./abcd";
+EXPECT
+Use of uninitialized value at ./abcd line 1.
+########
+
+--FILE-- abcd
+my $b ; chop $b ;
+1 ;
+--FILE--
+#! perl -w
+require "./abcd";
+EXPECT
+Use of uninitialized value at ./abcd line 1.
+########
+
+--FILE-- abcd
+my $b ; chop $b ;
+1 ;
+--FILE--
+$^W =1 ;
+require "./abcd";
+EXPECT
+Use of uninitialized value at ./abcd line 1.
+########
+
+--FILE-- abcd
+$^W = 0;
+my $b ; chop $b ;
+1 ;
+--FILE--
+$^W =1 ;
+require "./abcd";
+EXPECT
+
+########
+
+--FILE-- abcd
+$^W = 1;
+1 ;
+--FILE--
+$^W =0 ;
+require "./abcd";
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 3.
+########
+
+$^W = 1;
+eval "my $b ; chop $b ;" ;
+EXPECT
+Use of uninitialized value at - line 3.
+Use of uninitialized value at - line 3.
+########
+
+eval "$^W = 1;" ;
+my $b ; chop $b ;
+EXPECT
+
+########
+
+eval {$^W = 1;} ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 3.
+########
+
+{
+ local ($^W) = 1;
+}
+my $b ; chop $b ;
+EXPECT
+
+########
+
+my $a ; chop $a ;
+{
+ local ($^W) = 1;
+ my $b ; chop $b ;
+}
+my $c ; chop $c ;
+EXPECT
+Use of uninitialized value at - line 5.
+########
+-w
+-e undef
+EXPECT
+Use of uninitialized value at - line 2.
diff --git a/contrib/perl5/t/pragma/warning.t b/contrib/perl5/t/pragma/warning.t
new file mode 100755
index 000000000000..fa0301ea6a6a
--- /dev/null
+++ b/contrib/perl5/t/pragma/warning.t
@@ -0,0 +1,94 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $ENV{PERL5LIB} = '../lib';
+}
+
+$| = 1;
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MSWin32 = $^O eq 'MSWin32';
+my $tmpfile = "tmp0000";
+my $i = 0 ;
+1 while -f ++$tmpfile;
+END { if ($tmpfile) { 1 while unlink $tmpfile} }
+
+my @prgs = () ;
+
+foreach (sort glob("pragma/warn-*")) {
+
+ next if /(~|\.orig)$/;
+
+ open F, "<$_" or die "Cannot open $_: $!\n" ;
+ while (<F>) {
+ last if /^__END__/ ;
+ }
+
+ {
+ local $/ = undef;
+ @prgs = (@prgs, split "\n########\n", <F>) ;
+ }
+ close F ;
+}
+
+undef $/;
+
+print "1..", scalar @prgs, "\n";
+
+
+for (@prgs){
+ my $switch = "";
+ my @temps = () ;
+ if (s/^\s*-\w+//){
+ $switch = $&;
+ $switch =~ s/(-\S*[A-Z]\S*)/"-$1"/ if $Is_VMS; # protect uc switches
+ }
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ if ( $prog =~ /--FILE--/) {
+ my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
+ shift @files ;
+ die "Internal error test $i didn't split into pairs, got " .
+ scalar(@files) . "[" . join("%%%%", @files) ."]\n"
+ if @files % 2 ;
+ while (@files > 2) {
+ my $filename = shift @files ;
+ my $code = shift @files ;
+ push @temps, $filename ;
+ open F, ">$filename" or die "Cannot open $filename: $!\n" ;
+ print F $code ;
+ close F ;
+ }
+ shift @files ;
+ $prog = shift @files ;
+ }
+ open TEST, ">$tmpfile";
+ print TEST $prog,"\n";
+ close TEST;
+ my $results = $Is_VMS ?
+ `MCR $^X $switch $tmpfile` :
+ $Is_MSWin32 ?
+ `.\\perl -I../lib $switch $tmpfile 2>&1` :
+ `sh -c './perl $switch $tmpfile' 2>&1`;
+ my $status = $?;
+ $results =~ s/\n+$//;
+ # allow expected output to be written as if $prog is on STDIN
+ $results =~ s/tmp\d+/-/g;
+ $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
+ $expected =~ s/\n+$//;
+ my $prefix = ($results =~ s/^PREFIX\n//) ;
+ if ( $results =~ s/^SKIPPED\n//) {
+ print "$results\n" ;
+ }
+ elsif (($prefix and $results !~ /^\Q$expected/) or
+ (!$prefix and $results ne $expected)){
+ print STDERR "PROG: $switch\n$prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+ foreach (@temps)
+ { unlink $_ if $_ }
+}
diff --git a/contrib/perl5/taint.c b/contrib/perl5/taint.c
new file mode 100644
index 000000000000..4c031de5177d
--- /dev/null
+++ b/contrib/perl5/taint.c
@@ -0,0 +1,113 @@
+/*
+ * "...we will have peace, when you and all your works have perished--and
+ * the works of your dark master to whom you would deliver us. You are a
+ * liar, Saruman, and a corrupter of men's hearts." --Theoden
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+void
+taint_proper(const char *f, char *s)
+{
+ dTHR; /* just for taint */
+ char *ug;
+
+ DEBUG_u(PerlIO_printf(Perl_debug_log,
+ "%s %d %d %d\n", s, PL_tainted, PL_uid, PL_euid));
+
+ if (PL_tainted) {
+ if (PL_euid != PL_uid)
+ ug = " while running setuid";
+ else if (PL_egid != PL_gid)
+ ug = " while running setgid";
+ else
+ ug = " while running with -T switch";
+ if (!PL_unsafe)
+ croak(f, s, ug);
+ else if (PL_dowarn)
+ warn(f, s, ug);
+ }
+}
+
+void
+taint_env(void)
+{
+ SV** svp;
+ MAGIC* mg;
+ char** e;
+ static char* misc_env[] = {
+ "IFS", /* most shells' inter-field separators */
+ "CDPATH", /* ksh dain bramage #1 */
+ "ENV", /* ksh dain bramage #2 */
+ "BASH_ENV", /* bash dain bramage -- I guess it's contagious */
+ NULL
+ };
+
+#ifdef VMS
+ int i = 0;
+ char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";
+
+ while (1) {
+ if (i)
+ (void)sprintf(name,"DCL$PATH;%d", i);
+ svp = hv_fetch(GvHVn(PL_envgv), name, strlen(name), FALSE);
+ if (!svp || *svp == &PL_sv_undef)
+ break;
+ if (SvTAINTED(*svp)) {
+ dTHR;
+ TAINT;
+ taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
+ }
+ if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
+ dTHR;
+ TAINT;
+ taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
+ }
+ i++;
+ }
+#endif /* VMS */
+
+ svp = hv_fetch(GvHVn(PL_envgv),"PATH",4,FALSE);
+ if (svp && *svp) {
+ if (SvTAINTED(*svp)) {
+ dTHR;
+ TAINT;
+ taint_proper("Insecure %s%s", "$ENV{PATH}");
+ }
+ if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
+ dTHR;
+ TAINT;
+ taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
+ }
+ }
+
+#ifndef VMS
+ /* tainted $TERM is okay if it contains no metachars */
+ svp = hv_fetch(GvHVn(PL_envgv),"TERM",4,FALSE);
+ if (svp && *svp && SvTAINTED(*svp)) {
+ dTHR; /* just for taint */
+ bool was_tainted = PL_tainted;
+ char *t = SvPV(*svp, PL_na);
+ char *e = t + PL_na;
+ PL_tainted = was_tainted;
+ if (t < e && isALNUM(*t))
+ t++;
+ while (t < e && (isALNUM(*t) || *t == '-' || *t == ':'))
+ t++;
+ if (t < e) {
+ TAINT;
+ taint_proper("Insecure $ENV{%s}%s", "TERM");
+ }
+ }
+#endif /* !VMS */
+
+ for (e = misc_env; *e; e++) {
+ svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
+ if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
+ dTHR; /* just for taint */
+ TAINT;
+ taint_proper("Insecure $ENV{%s}%s", *e);
+ }
+ }
+}
diff --git a/contrib/perl5/thrdvar.h b/contrib/perl5/thrdvar.h
new file mode 100644
index 000000000000..4ca3ccbd50a3
--- /dev/null
+++ b/contrib/perl5/thrdvar.h
@@ -0,0 +1,192 @@
+/***********************************************/
+/* Global only to current thread */
+/***********************************************/
+
+/* Don't forget to re-run embed.pl to propagate changes! */
+
+/* The 'T' prefix is only needed for vars that need appropriate #defines
+ * generated when built with or without USE_THREADS. It is also used
+ * to generate the appropriate export list for win32.
+ *
+ * When building without USE_THREADS, these variables will be truly global.
+ * When building without USE_THREADS but with MULTIPLICITY, these variables
+ * will be global per-interpreter.
+ *
+ * Avoid build-specific #ifdefs here, like DEBUGGING. That way,
+ * we can keep binary compatibility of the curinterp structure */
+
+/* Important ones in the first cache line (if alignment is done right) */
+
+PERLVAR(Tstack_sp, SV **) /* top of the stack */
+#ifdef OP_IN_REGISTER
+PERLVAR(Topsave, OP *)
+#else
+PERLVAR(Top, OP *) /* currently executing op */
+#endif
+PERLVAR(Tcurpad, SV **) /* active pad (lexicals+tmps) */
+
+PERLVAR(Tstack_base, SV **)
+PERLVAR(Tstack_max, SV **)
+
+PERLVAR(Tscopestack, I32 *) /* scopes we've ENTERed */
+PERLVAR(Tscopestack_ix, I32)
+PERLVAR(Tscopestack_max,I32)
+
+PERLVAR(Tsavestack, ANY *) /* items that need to be restored
+ when LEAVEing scopes we've ENTERed */
+PERLVAR(Tsavestack_ix, I32)
+PERLVAR(Tsavestack_max, I32)
+
+PERLVAR(Ttmps_stack, SV **) /* mortals we've made */
+PERLVARI(Ttmps_ix, I32, -1)
+PERLVARI(Ttmps_floor, I32, -1)
+PERLVAR(Ttmps_max, I32)
+
+PERLVAR(Tmarkstack, I32 *) /* stack_sp locations we're remembering */
+PERLVAR(Tmarkstack_ptr, I32 *)
+PERLVAR(Tmarkstack_max, I32 *)
+
+PERLVAR(Tretstack, OP **) /* OPs we have postponed executing */
+PERLVAR(Tretstack_ix, I32)
+PERLVAR(Tretstack_max, I32)
+
+PERLVAR(TSv, SV *) /* used to hold temporary values */
+PERLVAR(TXpv, XPV *) /* used to hold temporary values */
+
+/* stat stuff */
+PERLVAR(Tstatbuf, Stat_t)
+PERLVAR(Tstatcache, Stat_t) /* _ */
+PERLVAR(Tstatgv, GV *)
+PERLVARI(Tstatname, SV *, Nullsv)
+
+#ifdef HAS_TIMES
+PERLVAR(Ttimesbuf, struct tms)
+#endif
+
+/* Fields used by magic variables such as $@, $/ and so on */
+PERLVAR(Ttainted, bool) /* using variables controlled by $< */
+PERLVAR(Tcurpm, PMOP *) /* what to do \ interps in REs from */
+PERLVAR(Tnrs, SV *)
+PERLVAR(Trs, SV *) /* input record separator $/ */
+PERLVAR(Tlast_in_gv, GV *) /* GV used in last <FH> */
+PERLVAR(Tofs, char *) /* output field separator $, */
+PERLVAR(Tofslen, STRLEN)
+PERLVAR(Tdefoutgv, GV *) /* default FH for output */
+PERLVARI(Tchopset, char *, " \n-") /* $: */
+PERLVAR(Tformtarget, SV *)
+PERLVAR(Tbodytarget, SV *)
+PERLVAR(Ttoptarget, SV *)
+
+/* Stashes */
+PERLVAR(Tdefstash, HV *) /* main symbol table */
+PERLVAR(Tcurstash, HV *) /* symbol table for current package */
+
+PERLVAR(Trestartop, OP *) /* propagating an error from croak? */
+PERLVARI(Tcurcop, COP * VOL, &PL_compiling)
+PERLVAR(Tin_eval, VOL int) /* trap "fatal" errors? */
+PERLVAR(Tdelaymagic, int) /* ($<,$>) = ... */
+PERLVAR(Tdirty, bool) /* in the middle of tearing things down? */
+PERLVAR(Tlocalizing, int) /* are we processing a local() list? */
+
+PERLVAR(Tcurstack, AV *) /* THE STACK */
+PERLVAR(Tcurstackinfo, PERL_SI *) /* current stack + context */
+PERLVAR(Tmainstack, AV *) /* the stack when nothing funny is happening */
+PERLVAR(Ttop_env, JMPENV *) /* ptr. to current sigjmp() environment */
+PERLVAR(Tstart_env, JMPENV) /* empty startup sigjmp() environment */
+
+/* statics "owned" by various functions */
+PERLVAR(Tav_fetch_sv, SV *) /* owned by av_fetch() */
+PERLVAR(Thv_fetch_sv, SV *) /* owned by hv_fetch() */
+PERLVAR(Thv_fetch_ent_mh, HE) /* owned by hv_fetch_ent() */
+
+PERLVAR(Tmodcount, I32) /* how much mod()ification in assignment? */
+
+PERLVAR(Tlastgotoprobe, OP*) /* from pp_ctl.c */
+
+/* sort stuff */
+PERLVAR(Tsortcop, OP *) /* user defined sort routine */
+PERLVAR(Tsortstash, HV *) /* which is in some package or other */
+PERLVAR(Tfirstgv, GV *) /* $a */
+PERLVAR(Tsecondgv, GV *) /* $b */
+PERLVAR(Tsortcxix, I32) /* from pp_ctl.c */
+
+/* regex stuff */
+
+PERLVAR(Tscreamfirst, I32 *)
+PERLVAR(Tscreamnext, I32 *)
+PERLVARI(Tmaxscream, I32, -1)
+PERLVAR(Tlastscream, SV *)
+
+PERLVAR(Tregdummy, regnode) /* from regcomp.c */
+PERLVAR(Tregcomp_parse, char*) /* Input-scan pointer. */
+PERLVAR(Tregxend, char*) /* End of input for compile */
+PERLVAR(Tregcode, regnode*) /* Code-emit pointer; &regdummy = don't */
+PERLVAR(Tregnaughty, I32) /* How bad is this pattern? */
+PERLVAR(Tregsawback, I32) /* Did we see \1, ...? */
+PERLVAR(Tregprecomp, char *) /* uncompiled string. */
+PERLVAR(Tregnpar, I32) /* () count. */
+PERLVAR(Tregsize, I32) /* Code size. */
+PERLVAR(Tregflags, U16) /* are we folding, multilining? */
+PERLVAR(Tregseen, U32) /* from regcomp.c */
+PERLVAR(Tseen_zerolen, I32) /* from regcomp.c */
+PERLVAR(Tseen_evals, I32) /* from regcomp.c */
+PERLVAR(Tregcomp_rx, regexp *) /* from regcomp.c */
+PERLVAR(Textralen, I32) /* from regcomp.c */
+PERLVAR(Tcolorset, int) /* from regcomp.c */
+PERLVAR(Tcolors[4], char *) /* from regcomp.c */
+PERLVAR(Treginput, char *) /* String-input pointer. */
+PERLVAR(Tregbol, char *) /* Beginning of input, for ^ check. */
+PERLVAR(Tregeol, char *) /* End of input, for $ check. */
+PERLVAR(Tregstartp, char **) /* Pointer to startp array. */
+PERLVAR(Tregendp, char **) /* Ditto for endp. */
+PERLVAR(Treglastparen, U32 *) /* Similarly for lastparen. */
+PERLVAR(Tregtill, char *) /* How far we are required to go. */
+PERLVAR(Tregprev, char) /* char before regbol, \n if none */
+PERLVAR(Treg_start_tmp, char **) /* from regexec.c */
+PERLVAR(Treg_start_tmpl,U32) /* from regexec.c */
+PERLVAR(Tregdata, struct reg_data *)
+ /* from regexec.c renamed was data */
+PERLVAR(Tbostr, char *) /* from regexec.c */
+PERLVAR(Treg_flags, U32) /* from regexec.c */
+PERLVAR(Treg_eval_set, I32) /* from regexec.c */
+PERLVAR(Tregnarrate, I32) /* from regexec.c */
+PERLVAR(Tregprogram, regnode *) /* from regexec.c */
+PERLVARI(Tregindent, int, 0) /* from regexec.c */
+PERLVAR(Tregcc, CURCUR *) /* from regexec.c */
+
+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 `Regexp'
+ was interpolated. */
+
+
+/* Note that the variables below are all explicitly referenced in the code
+ * as thr->whatever and therefore don't need the 'T' prefix. */
+
+#ifdef USE_THREADS
+
+PERLVAR(oursv, SV *)
+PERLVAR(cvcache, HV *)
+PERLVAR(self, perl_os_thread) /* Underlying thread object */
+PERLVAR(flags, U32)
+PERLVAR(threadsv, AV *) /* Per-thread SVs ($_, $@ etc.) */
+PERLVAR(threadsvp, SV **) /* AvARRAY(threadsv) */
+PERLVAR(specific, AV *) /* Thread-specific user data */
+PERLVAR(errsv, SV *) /* Backing SV for $@ */
+PERLVAR(errhv, HV *) /* HV for what was %@ in pp_ctl.c */
+PERLVAR(mutex, perl_mutex) /* For the fields others can change */
+PERLVAR(tid, U32)
+PERLVAR(prev, struct perl_thread *)
+PERLVAR(next, struct perl_thread *)
+ /* Circular linked list of threads */
+
+#ifdef HAVE_THREAD_INTERN
+PERLVAR(i, struct thread_intern)
+ /* Platform-dependent internals */
+#endif
+
+PERLVAR(trailing_nul, char) /* For the sake of thrsv and oursv */
+
+#endif /* USE_THREADS */
diff --git a/contrib/perl5/thread.h b/contrib/perl5/thread.h
new file mode 100644
index 000000000000..3eb061a22a2e
--- /dev/null
+++ b/contrib/perl5/thread.h
@@ -0,0 +1,234 @@
+#ifdef USE_THREADS
+
+#ifdef WIN32
+# include <win32thread.h>
+#else
+
+#ifndef DJGPP
+/* POSIXish threads */
+#ifdef OLD_PTHREADS_API
+# define pthread_mutexattr_init(a) pthread_mutexattr_create(a)
+# define pthread_mutexattr_settype(a,t) pthread_mutexattr_setkind_np(a,t)
+# define pthread_key_create(k,d) pthread_keycreate(k,(pthread_destructor_t)(d))
+# define YIELD pthread_yield()
+# define DETACH(t) \
+ STMT_START { \
+ if (pthread_detach(&(t)->self)) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ croak("panic: DETACH"); \
+ } \
+ } STMT_END
+#else
+# define pthread_mutexattr_default NULL
+# define pthread_condattr_default NULL
+#endif /* OLD_PTHREADS_API */
+#endif
+#endif
+
+#ifdef PTHREADS_CREATED_JOINABLE
+# define ATTR_JOINABLE PTHREAD_CREATE_JOINABLE
+#else
+# ifdef PTHREAD_CREATE_UNDETACHED
+# define ATTR_JOINABLE PTHREAD_CREATE_UNDETACHED
+# else
+# define ATTR_JOINABLE PTHREAD_CREATE_JOINABLE
+# endif
+#endif
+
+#ifndef YIELD
+# ifdef HAS_SCHED_YIELD
+# define YIELD sched_yield()
+# else
+# ifdef HAS_PTHREAD_YIELD
+# define YIELD pthread_yield()
+# endif
+# endif
+#endif
+
+#ifndef MUTEX_INIT
+#define MUTEX_INIT(m) \
+ STMT_START { \
+ if (pthread_mutex_init((m), pthread_mutexattr_default)) \
+ croak("panic: MUTEX_INIT"); \
+ } STMT_END
+#define MUTEX_LOCK(m) \
+ STMT_START { \
+ if (pthread_mutex_lock((m))) \
+ croak("panic: MUTEX_LOCK"); \
+ } STMT_END
+#define MUTEX_UNLOCK(m) \
+ STMT_START { \
+ if (pthread_mutex_unlock((m))) \
+ croak("panic: MUTEX_UNLOCK"); \
+ } STMT_END
+#define MUTEX_DESTROY(m) \
+ STMT_START { \
+ if (pthread_mutex_destroy((m))) \
+ croak("panic: MUTEX_DESTROY"); \
+ } STMT_END
+#endif /* MUTEX_INIT */
+
+#ifndef COND_INIT
+#define COND_INIT(c) \
+ STMT_START { \
+ if (pthread_cond_init((c), pthread_condattr_default)) \
+ croak("panic: COND_INIT"); \
+ } STMT_END
+#define COND_SIGNAL(c) \
+ STMT_START { \
+ if (pthread_cond_signal((c))) \
+ croak("panic: COND_SIGNAL"); \
+ } STMT_END
+#define COND_BROADCAST(c) \
+ STMT_START { \
+ if (pthread_cond_broadcast((c))) \
+ croak("panic: COND_BROADCAST"); \
+ } STMT_END
+#define COND_WAIT(c, m) \
+ STMT_START { \
+ if (pthread_cond_wait((c), (m))) \
+ croak("panic: COND_WAIT"); \
+ } STMT_END
+#define COND_DESTROY(c) \
+ STMT_START { \
+ if (pthread_cond_destroy((c))) \
+ croak("panic: COND_DESTROY"); \
+ } STMT_END
+#endif /* COND_INIT */
+
+/* DETACH(t) must only be called while holding t->mutex */
+#ifndef DETACH
+#define DETACH(t) \
+ STMT_START { \
+ if (pthread_detach((t)->self)) { \
+ MUTEX_UNLOCK(&(t)->mutex); \
+ croak("panic: DETACH"); \
+ } \
+ } STMT_END
+#endif /* DETACH */
+
+#ifndef JOIN
+#define JOIN(t, avp) \
+ STMT_START { \
+ if (pthread_join((t)->self, (void**)(avp))) \
+ croak("panic: pthread_join"); \
+ } STMT_END
+#endif /* JOIN */
+
+#ifndef SET_THR
+#define SET_THR(t) \
+ STMT_START { \
+ if (pthread_setspecific(PL_thr_key, (void *) (t))) \
+ croak("panic: pthread_setspecific"); \
+ } STMT_END
+#endif /* SET_THR */
+
+#ifndef THR
+# ifdef OLD_PTHREADS_API
+struct perl_thread *getTHR _((void));
+# define THR getTHR()
+# else
+# define THR ((struct perl_thread *) pthread_getspecific(PL_thr_key))
+# endif /* OLD_PTHREADS_API */
+#endif /* THR */
+
+/*
+ * dTHR is performance-critical. Here, we only do the pthread_get_specific
+ * if there may be more than one thread in existence, otherwise we get thr
+ * 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".
+ */
+#ifndef dTHR
+# define dTHR \
+ struct perl_thread *thr = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv)
+#endif /* dTHR */
+
+#ifndef INIT_THREADS
+# ifdef NEED_PTHREAD_INIT
+# define INIT_THREADS pthread_init()
+# else
+# define INIT_THREADS NOOP
+# endif
+#endif
+
+/* Accessor for per-thread SVs */
+#define THREADSV(i) (thr->threadsvp[i])
+
+/*
+ * LOCK_SV_MUTEX and UNLOCK_SV_MUTEX are performance-critical. Here, we
+ * 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.
+ */
+#define LOCK_SV_MUTEX \
+ STMT_START { \
+ if (PL_threadnum) \
+ MUTEX_LOCK(&PL_sv_mutex); \
+ } STMT_END
+
+#define UNLOCK_SV_MUTEX \
+ STMT_START { \
+ if (PL_threadnum) \
+ MUTEX_UNLOCK(&PL_sv_mutex); \
+ } STMT_END
+
+#ifndef THREAD_RET_TYPE
+# define THREAD_RET_TYPE void *
+# define THREAD_RET_CAST(p) ((void *)(p))
+#endif /* THREAD_RET */
+
+
+/* Values and macros for thr->flags */
+#define THRf_STATE_MASK 7
+#define THRf_R_JOINABLE 0
+#define THRf_R_JOINED 1
+#define THRf_R_DETACHED 2
+#define THRf_ZOMBIE 3
+#define THRf_DEAD 4
+
+#define THRf_DID_DIE 8
+
+/* ThrSTATE(t) and ThrSETSTATE(t) must only be called while holding t->mutex */
+#define ThrSTATE(t) ((t)->flags & THRf_STATE_MASK)
+#define ThrSETSTATE(t, s) STMT_START { \
+ (t)->flags &= ~THRf_STATE_MASK; \
+ (t)->flags |= (s); \
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), \
+ "thread %p set to state %d\n", (t), (s))); \
+ } STMT_END
+
+typedef struct condpair {
+ perl_mutex mutex; /* Protects all other fields */
+ perl_cond owner_cond; /* For when owner changes at all */
+ perl_cond cond; /* For cond_signal and cond_broadcast */
+ Thread owner; /* Currently owning thread */
+} condpair_t;
+
+#define MgMUTEXP(mg) (&((condpair_t *)(mg->mg_ptr))->mutex)
+#define MgOWNERCONDP(mg) (&((condpair_t *)(mg->mg_ptr))->owner_cond)
+#define MgCONDP(mg) (&((condpair_t *)(mg->mg_ptr))->cond)
+#define MgOWNER(mg) ((condpair_t *)(mg->mg_ptr))->owner
+
+#else
+/* USE_THREADS is not defined */
+#define MUTEX_LOCK(m)
+#define MUTEX_UNLOCK(m)
+#define MUTEX_INIT(m)
+#define MUTEX_DESTROY(m)
+#define COND_INIT(c)
+#define COND_SIGNAL(c)
+#define COND_BROADCAST(c)
+#define COND_WAIT(c, m)
+#define COND_DESTROY(c)
+#define LOCK_SV_MUTEX
+#define UNLOCK_SV_MUTEX
+
+#define THR
+/* Rats: if dTHR is just blank then the subsequent ";" throws an error */
+#ifdef WIN32
+#define dTHR extern int Perl___notused
+#else
+#define dTHR extern int errno
+#endif
+#endif /* USE_THREADS */
diff --git a/contrib/perl5/thread.sym b/contrib/perl5/thread.sym
new file mode 100644
index 000000000000..1e0ca6a5f2c3
--- /dev/null
+++ b/contrib/perl5/thread.sym
@@ -0,0 +1 @@
+#
diff --git a/contrib/perl5/toke.c b/contrib/perl5/toke.c
new file mode 100644
index 000000000000..c069978f614b
--- /dev/null
+++ b/contrib/perl5/toke.c
@@ -0,0 +1,6097 @@
+/* toke.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "It all comes from here, the stench and the peril." --Frodo
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifndef PERL_OBJECT
+static void check_uni _((void));
+static void force_next _((I32 type));
+static char *force_version _((char *start));
+static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
+static SV *tokeq _((SV *sv));
+static char *scan_const _((char *start));
+static char *scan_formline _((char *s));
+static char *scan_heredoc _((char *s));
+static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
+ I32 ck_uni));
+static char *scan_inputsymbol _((char *start));
+static char *scan_pat _((char *start, I32 type));
+static char *scan_str _((char *start));
+static char *scan_subst _((char *start));
+static char *scan_trans _((char *start));
+static char *scan_word _((char *s, char *dest, STRLEN destlen,
+ int allow_package, STRLEN *slp));
+static char *skipspace _((char *s));
+static void checkcomma _((char *s, char *name, char *what));
+static void force_ident _((char *s, int kind));
+static void incline _((char *s));
+static int intuit_method _((char *s, GV *gv));
+static int intuit_more _((char *s));
+static I32 lop _((I32 f, expectation x, char *s));
+static void missingterm _((char *s));
+static void no_op _((char *what, char *s));
+static void set_csh _((void));
+static I32 sublex_done _((void));
+static I32 sublex_push _((void));
+static I32 sublex_start _((void));
+#ifdef CRIPPLED_CC
+static int uni _((I32 f, char *s));
+#endif
+static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
+static void restore_rsfp _((void *f));
+static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
+static void restore_expect _((void *e));
+static void restore_lex_expect _((void *e));
+#endif /* PERL_OBJECT */
+
+static char ident_too_long[] = "Identifier too long";
+
+/* The following are arranged oddly so that the guard on the switch statement
+ * can get by with a single comparison (if the compiler is smart enough).
+ */
+
+/* #define LEX_NOTPARSING 11 is done in perl.h. */
+
+#define LEX_NORMAL 10
+#define LEX_INTERPNORMAL 9
+#define LEX_INTERPCASEMOD 8
+#define LEX_INTERPPUSH 7
+#define LEX_INTERPSTART 6
+#define LEX_INTERPEND 5
+#define LEX_INTERPENDMAYBE 4
+#define LEX_INTERPCONCAT 3
+#define LEX_INTERPCONST 2
+#define LEX_FORMLINE 1
+#define LEX_KNOWNEXT 0
+
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
+
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+# include <unistd.h> /* Needed for execv() */
+#endif
+
+
+#ifdef ff_next
+#undef ff_next
+#endif
+
+#include "keywords.h"
+
+#ifdef CLINE
+#undef CLINE
+#endif
+#define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
+
+#define TOKEN(retval) return (PL_bufptr = s,(int)retval)
+#define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
+#define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
+#define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
+#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
+#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
+#define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
+#define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
+#define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
+#define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
+#define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
+#define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
+#define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
+#define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
+#define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
+#define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
+#define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
+#define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
+#define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
+#define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
+
+/* This bit of chicanery makes a unary function followed by
+ * a parenthesis into a function with one argument, highest precedence.
+ */
+#define UNI(f) return(yylval.ival = f, \
+ PL_expect = XTERM, \
+ PL_bufptr = s, \
+ PL_last_uni = PL_oldbufptr, \
+ PL_last_lop_op = f, \
+ (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
+
+#define UNIBRACK(f) return(yylval.ival = f, \
+ PL_bufptr = s, \
+ PL_last_uni = PL_oldbufptr, \
+ (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
+
+/* grandfather return to old style */
+#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
+
+STATIC int
+ao(int toketype)
+{
+ if (*PL_bufptr == '=') {
+ PL_bufptr++;
+ if (toketype == ANDAND)
+ yylval.ival = OP_ANDASSIGN;
+ else if (toketype == OROR)
+ yylval.ival = OP_ORASSIGN;
+ toketype = ASSIGNOP;
+ }
+ return toketype;
+}
+
+STATIC void
+no_op(char *what, char *s)
+{
+ char *oldbp = PL_bufptr;
+ bool is_first = (PL_oldbufptr == PL_linestart);
+
+ PL_bufptr = s;
+ yywarn(form("%s found where operator expected", what));
+ if (is_first)
+ warn("\t(Missing semicolon on previous line?)\n");
+ else if (PL_oldoldbufptr && isIDFIRST(*PL_oldoldbufptr)) {
+ char *t;
+ for (t = PL_oldoldbufptr; *t && (isALNUM(*t) || *t == ':'); t++) ;
+ if (t < PL_bufptr && isSPACE(*t))
+ warn("\t(Do you need to predeclare %.*s?)\n",
+ t - PL_oldoldbufptr, PL_oldoldbufptr);
+
+ }
+ else
+ warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
+ PL_bufptr = oldbp;
+}
+
+STATIC void
+missingterm(char *s)
+{
+ char tmpbuf[3];
+ char q;
+ if (s) {
+ char *nl = strrchr(s,'\n');
+ if (nl)
+ *nl = '\0';
+ }
+ else if (
+#ifdef EBCDIC
+ iscntrl(PL_multi_close)
+#else
+ PL_multi_close < 32 || PL_multi_close == 127
+#endif
+ ) {
+ *tmpbuf = '^';
+ tmpbuf[1] = toCTRL(PL_multi_close);
+ s = "\\n";
+ tmpbuf[2] = '\0';
+ s = tmpbuf;
+ }
+ else {
+ *tmpbuf = PL_multi_close;
+ tmpbuf[1] = '\0';
+ s = tmpbuf;
+ }
+ q = strchr(s,'"') ? '\'' : '"';
+ croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
+}
+
+void
+deprecate(char *s)
+{
+ if (PL_dowarn)
+ warn("Use of %s is deprecated", s);
+}
+
+STATIC void
+depcom(void)
+{
+ deprecate("comma-less variable list");
+}
+
+#ifdef WIN32
+
+STATIC I32
+win32_textfilter(int idx, SV *sv, int maxlen)
+{
+ I32 count = FILTER_READ(idx+1, sv, maxlen);
+ if (count > 0 && !maxlen)
+ win32_strip_return(sv);
+ return count;
+}
+#endif
+
+
+void
+lex_start(SV *line)
+{
+ dTHR;
+ char *s;
+ STRLEN len;
+
+ SAVEI32(PL_lex_dojoin);
+ SAVEI32(PL_lex_brackets);
+ SAVEI32(PL_lex_fakebrack);
+ SAVEI32(PL_lex_casemods);
+ SAVEI32(PL_lex_starts);
+ SAVEI32(PL_lex_state);
+ SAVESPTR(PL_lex_inpat);
+ SAVEI32(PL_lex_inwhat);
+ SAVEI16(PL_curcop->cop_line);
+ SAVEPPTR(PL_bufptr);
+ SAVEPPTR(PL_bufend);
+ SAVEPPTR(PL_oldbufptr);
+ SAVEPPTR(PL_oldoldbufptr);
+ SAVEPPTR(PL_linestart);
+ SAVESPTR(PL_linestr);
+ SAVEPPTR(PL_lex_brackstack);
+ SAVEPPTR(PL_lex_casestack);
+ SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
+ SAVESPTR(PL_lex_stuff);
+ SAVEI32(PL_lex_defer);
+ SAVESPTR(PL_lex_repl);
+ SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
+ SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
+
+ PL_lex_state = LEX_NORMAL;
+ PL_lex_defer = 0;
+ PL_expect = XSTATE;
+ PL_lex_brackets = 0;
+ PL_lex_fakebrack = 0;
+ New(899, PL_lex_brackstack, 120, char);
+ New(899, PL_lex_casestack, 12, char);
+ SAVEFREEPV(PL_lex_brackstack);
+ SAVEFREEPV(PL_lex_casestack);
+ PL_lex_casemods = 0;
+ *PL_lex_casestack = '\0';
+ PL_lex_dojoin = 0;
+ PL_lex_starts = 0;
+ PL_lex_stuff = Nullsv;
+ PL_lex_repl = Nullsv;
+ PL_lex_inpat = 0;
+ PL_lex_inwhat = 0;
+ PL_linestr = line;
+ if (SvREADONLY(PL_linestr))
+ PL_linestr = sv_2mortal(newSVsv(PL_linestr));
+ s = SvPV(PL_linestr, len);
+ if (len && s[len-1] != ';') {
+ if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
+ PL_linestr = sv_2mortal(newSVsv(PL_linestr));
+ sv_catpvn(PL_linestr, "\n;", 2);
+ }
+ SvTEMP_off(PL_linestr);
+ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = PL_bufptr + SvCUR(PL_linestr);
+ SvREFCNT_dec(PL_rs);
+ PL_rs = newSVpv("\n", 1);
+ PL_rsfp = 0;
+}
+
+void
+lex_end(void)
+{
+ PL_doextract = FALSE;
+}
+
+STATIC void
+restore_rsfp(void *f)
+{
+ PerlIO *fp = (PerlIO*)f;
+
+ if (PL_rsfp == PerlIO_stdin())
+ PerlIO_clearerr(PL_rsfp);
+ else if (PL_rsfp && (PL_rsfp != fp))
+ PerlIO_close(PL_rsfp);
+ PL_rsfp = fp;
+}
+
+STATIC void
+restore_expect(void *e)
+{
+ /* a safe way to store a small integer in a pointer */
+ PL_expect = (expectation)((char *)e - PL_tokenbuf);
+}
+
+STATIC void
+restore_lex_expect(void *e)
+{
+ /* a safe way to store a small integer in a pointer */
+ PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
+}
+
+STATIC void
+incline(char *s)
+{
+ dTHR;
+ char *t;
+ char *n;
+ char ch;
+ int sawline = 0;
+
+ PL_curcop->cop_line++;
+ if (*s++ != '#')
+ return;
+ while (*s == ' ' || *s == '\t') s++;
+ if (strnEQ(s, "line ", 5)) {
+ s += 5;
+ sawline = 1;
+ }
+ if (!isDIGIT(*s))
+ return;
+ n = s;
+ while (isDIGIT(*s))
+ s++;
+ while (*s == ' ' || *s == '\t')
+ s++;
+ if (*s == '"' && (t = strchr(s+1, '"')))
+ s++;
+ else {
+ if (!sawline)
+ return; /* false alarm */
+ for (t = s; !isSPACE(*t); t++) ;
+ }
+ ch = *t;
+ *t = '\0';
+ if (t - s > 0)
+ PL_curcop->cop_filegv = gv_fetchfile(s);
+ else
+ PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
+ *t = ch;
+ PL_curcop->cop_line = atoi(n)-1;
+}
+
+STATIC char *
+skipspace(register char *s)
+{
+ dTHR;
+ if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
+ while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ s++;
+ return s;
+ }
+ for (;;) {
+ STRLEN prevlen;
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (s < PL_bufend && *s == '#') {
+ while (s < PL_bufend && *s != '\n')
+ s++;
+ if (s < PL_bufend)
+ s++;
+ }
+ if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
+ return s;
+ if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
+ if (PL_minus_n || PL_minus_p) {
+ sv_setpv(PL_linestr,PL_minus_p ?
+ ";}continue{print or die qq(-p destination: $!\\n)" :
+ "");
+ sv_catpv(PL_linestr,";}");
+ PL_minus_n = PL_minus_p = 0;
+ }
+ else
+ sv_setpv(PL_linestr,";");
+ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ if (PL_preprocess && !PL_in_eval)
+ (void)PerlProc_pclose(PL_rsfp);
+ else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
+ PerlIO_clearerr(PL_rsfp);
+ else
+ (void)PerlIO_close(PL_rsfp);
+ PL_rsfp = Nullfp;
+ return s;
+ }
+ PL_linestart = PL_bufptr = s + prevlen;
+ PL_bufend = s + SvCUR(PL_linestr);
+ s = PL_bufptr;
+ incline(s);
+ if (PERLDB_LINE && PL_curstash != PL_debstash) {
+ SV *sv = NEWSV(85,0);
+
+ sv_upgrade(sv, SVt_PVMG);
+ sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
+ av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
+ }
+ }
+}
+
+STATIC void
+check_uni(void) {
+ char *s;
+ char ch;
+ char *t;
+
+ if (PL_oldoldbufptr != PL_last_uni)
+ return;
+ while (isSPACE(*PL_last_uni))
+ PL_last_uni++;
+ for (s = PL_last_uni; isALNUM(*s) || *s == '-'; s++) ;
+ if ((t = strchr(s, '(')) && t < PL_bufptr)
+ return;
+ ch = *s;
+ *s = '\0';
+ warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
+ *s = ch;
+}
+
+#ifdef CRIPPLED_CC
+
+#undef UNI
+#define UNI(f) return uni(f,s)
+
+STATIC int
+uni(I32 f, char *s)
+{
+ yylval.ival = f;
+ PL_expect = XTERM;
+ PL_bufptr = s;
+ PL_last_uni = PL_oldbufptr;
+ PL_last_lop_op = f;
+ if (*s == '(')
+ return FUNC1;
+ s = skipspace(s);
+ if (*s == '(')
+ return FUNC1;
+ else
+ return UNIOP;
+}
+
+#endif /* CRIPPLED_CC */
+
+#define LOP(f,x) return lop(f,x,s)
+
+STATIC I32
+lop(I32 f, expectation x, char *s)
+{
+ dTHR;
+ yylval.ival = f;
+ CLINE;
+ PL_expect = x;
+ PL_bufptr = s;
+ PL_last_lop = PL_oldbufptr;
+ PL_last_lop_op = f;
+ if (PL_nexttoke)
+ return LSTOP;
+ if (*s == '(')
+ return FUNC;
+ s = skipspace(s);
+ if (*s == '(')
+ return FUNC;
+ else
+ return LSTOP;
+}
+
+STATIC void
+force_next(I32 type)
+{
+ PL_nexttype[PL_nexttoke] = type;
+ PL_nexttoke++;
+ if (PL_lex_state != LEX_KNOWNEXT) {
+ PL_lex_defer = PL_lex_state;
+ PL_lex_expect = PL_expect;
+ PL_lex_state = LEX_KNOWNEXT;
+ }
+}
+
+STATIC char *
+force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
+{
+ register char *s;
+ STRLEN len;
+
+ start = skipspace(start);
+ s = start;
+ if (isIDFIRST(*s) ||
+ (allow_pack && *s == ':') ||
+ (allow_initial_tick && *s == '\'') )
+ {
+ s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
+ if (check_keyword && keyword(PL_tokenbuf, len))
+ return start;
+ if (token == METHOD) {
+ s = skipspace(s);
+ if (*s == '(')
+ PL_expect = XTERM;
+ else {
+ PL_expect = XOPERATOR;
+ force_next(')');
+ force_next('(');
+ }
+ }
+ PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
+ PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
+ force_next(token);
+ }
+ return s;
+}
+
+STATIC void
+force_ident(register char *s, int kind)
+{
+ if (s && *s) {
+ OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
+ PL_nextval[PL_nexttoke].opval = o;
+ force_next(WORD);
+ if (kind) {
+ dTHR; /* just for in_eval */
+ o->op_private = OPpCONST_ENTERED;
+ /* XXX see note in pp_entereval() for why we forgo typo
+ warnings if the symbol must be introduced in an eval.
+ GSAR 96-10-12 */
+ gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
+ kind == '$' ? SVt_PV :
+ kind == '@' ? SVt_PVAV :
+ kind == '%' ? SVt_PVHV :
+ SVt_PVGV
+ );
+ }
+ }
+}
+
+STATIC char *
+force_version(char *s)
+{
+ OP *version = Nullop;
+
+ s = skipspace(s);
+
+ /* default VERSION number -- GBARR */
+
+ if(isDIGIT(*s)) {
+ char *d;
+ int c;
+ for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
+ if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
+ s = scan_num(s);
+ /* real VERSION number -- GBARR */
+ version = yylval.opval;
+ }
+ }
+
+ /* NOTE: The parser sees the package name and the VERSION swapped */
+ PL_nextval[PL_nexttoke].opval = version;
+ force_next(WORD);
+
+ return (s);
+}
+
+STATIC SV *
+tokeq(SV *sv)
+{
+ register char *s;
+ register char *send;
+ register char *d;
+ STRLEN len = 0;
+ SV *pv = sv;
+
+ if (!SvLEN(sv))
+ goto finish;
+
+ s = SvPV_force(sv, len);
+ if (SvIVX(sv) == -1)
+ goto finish;
+ send = s + len;
+ while (s < send && *s != '\\')
+ s++;
+ if (s == send)
+ goto finish;
+ d = s;
+ if ( PL_hints & HINT_NEW_STRING )
+ pv = sv_2mortal(newSVpv(SvPVX(pv), len));
+ while (s < send) {
+ if (*s == '\\') {
+ if (s + 1 < send && (s[1] == '\\'))
+ s++; /* all that, just for this */
+ }
+ *d++ = *s++;
+ }
+ *d = '\0';
+ SvCUR_set(sv, d - SvPVX(sv));
+ finish:
+ if ( PL_hints & HINT_NEW_STRING )
+ return new_constant(NULL, 0, "q", sv, pv, "q");
+ return sv;
+}
+
+STATIC I32
+sublex_start(void)
+{
+ register I32 op_type = yylval.ival;
+
+ if (op_type == OP_NULL) {
+ yylval.opval = PL_lex_op;
+ PL_lex_op = Nullop;
+ return THING;
+ }
+ if (op_type == OP_CONST || op_type == OP_READLINE) {
+ SV *sv = tokeq(PL_lex_stuff);
+
+ if (SvTYPE(sv) == SVt_PVIV) {
+ /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
+ STRLEN len;
+ char *p;
+ SV *nsv;
+
+ p = SvPV(sv, len);
+ nsv = newSVpv(p, len);
+ SvREFCNT_dec(sv);
+ sv = nsv;
+ }
+ yylval.opval = (OP*)newSVOP(op_type, 0, sv);
+ PL_lex_stuff = Nullsv;
+ return THING;
+ }
+
+ PL_sublex_info.super_state = PL_lex_state;
+ PL_sublex_info.sub_inwhat = op_type;
+ PL_sublex_info.sub_op = PL_lex_op;
+ PL_lex_state = LEX_INTERPPUSH;
+
+ PL_expect = XTERM;
+ if (PL_lex_op) {
+ yylval.opval = PL_lex_op;
+ PL_lex_op = Nullop;
+ return PMFUNC;
+ }
+ else
+ return FUNC;
+}
+
+STATIC I32
+sublex_push(void)
+{
+ dTHR;
+ ENTER;
+
+ PL_lex_state = PL_sublex_info.super_state;
+ SAVEI32(PL_lex_dojoin);
+ SAVEI32(PL_lex_brackets);
+ SAVEI32(PL_lex_fakebrack);
+ SAVEI32(PL_lex_casemods);
+ SAVEI32(PL_lex_starts);
+ SAVEI32(PL_lex_state);
+ SAVESPTR(PL_lex_inpat);
+ SAVEI32(PL_lex_inwhat);
+ SAVEI16(PL_curcop->cop_line);
+ SAVEPPTR(PL_bufptr);
+ SAVEPPTR(PL_oldbufptr);
+ SAVEPPTR(PL_oldoldbufptr);
+ SAVEPPTR(PL_linestart);
+ SAVESPTR(PL_linestr);
+ SAVEPPTR(PL_lex_brackstack);
+ SAVEPPTR(PL_lex_casestack);
+
+ PL_linestr = PL_lex_stuff;
+ PL_lex_stuff = Nullsv;
+
+ PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend += SvCUR(PL_linestr);
+ SAVEFREESV(PL_linestr);
+
+ PL_lex_dojoin = FALSE;
+ PL_lex_brackets = 0;
+ PL_lex_fakebrack = 0;
+ New(899, PL_lex_brackstack, 120, char);
+ New(899, PL_lex_casestack, 12, char);
+ SAVEFREEPV(PL_lex_brackstack);
+ SAVEFREEPV(PL_lex_casestack);
+ PL_lex_casemods = 0;
+ *PL_lex_casestack = '\0';
+ PL_lex_starts = 0;
+ PL_lex_state = LEX_INTERPCONCAT;
+ PL_curcop->cop_line = PL_multi_start;
+
+ PL_lex_inwhat = PL_sublex_info.sub_inwhat;
+ if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
+ PL_lex_inpat = PL_sublex_info.sub_op;
+ else
+ PL_lex_inpat = Nullop;
+
+ return '(';
+}
+
+STATIC I32
+sublex_done(void)
+{
+ if (!PL_lex_starts++) {
+ PL_expect = XOPERATOR;
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
+ return THING;
+ }
+
+ if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
+ PL_lex_state = LEX_INTERPCASEMOD;
+ return yylex();
+ }
+
+ /* Is there a right-hand side to take care of? */
+ if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
+ PL_linestr = PL_lex_repl;
+ PL_lex_inpat = 0;
+ PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend += SvCUR(PL_linestr);
+ SAVEFREESV(PL_linestr);
+ PL_lex_dojoin = FALSE;
+ PL_lex_brackets = 0;
+ PL_lex_fakebrack = 0;
+ PL_lex_casemods = 0;
+ *PL_lex_casestack = '\0';
+ PL_lex_starts = 0;
+ if (SvCOMPILED(PL_lex_repl)) {
+ PL_lex_state = LEX_INTERPNORMAL;
+ PL_lex_starts++;
+ }
+ else
+ PL_lex_state = LEX_INTERPCONCAT;
+ PL_lex_repl = Nullsv;
+ return ',';
+ }
+ else {
+ LEAVE;
+ PL_bufend = SvPVX(PL_linestr);
+ PL_bufend += SvCUR(PL_linestr);
+ PL_expect = XOPERATOR;
+ return ')';
+ }
+}
+
+/*
+ scan_const
+
+ Extracts a pattern, double-quoted string, or transliteration. This
+ is terrifying code.
+
+ It looks at lex_inwhat and PL_lex_inpat to find out whether it's
+ processing a pattern (PL_lex_inpat is true), a transliteration
+ (lex_inwhat & OP_TRANS is true), or a double-quoted string.
+
+ Returns a pointer to the character scanned up to. Iff this is
+ advanced from the start pointer supplied (ie if anything was
+ successfully parsed), will leave an OP for the substring scanned
+ in yylval. Caller must intuit reason for not parsing further
+ by looking at the next characters herself.
+
+ In patterns:
+ backslashes:
+ double-quoted style: \r and \n
+ regexp special ones: \D \s
+ constants: \x3
+ backrefs: \1 (deprecated in substitution replacements)
+ case and quoting: \U \Q \E
+ stops on @ and $, but not for $ as tail anchor
+
+ In transliterations:
+ characters are VERY literal, except for - not at the start or end
+ of the string, which indicates a range. scan_const expands the
+ range to the full set of intermediate characters.
+
+ In double-quoted strings:
+ backslashes:
+ double-quoted style: \r and \n
+ constants: \x3
+ backrefs: \1 (deprecated)
+ case and quoting: \U \Q \E
+ stops on @ and $
+
+ scan_const does *not* construct ops to handle interpolated strings.
+ It stops processing as soon as it finds an embedded $ or @ variable
+ and leaves it to the caller to work out what's going on.
+
+ @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
+
+ $ in pattern could be $foo or could be tail anchor. Assumption:
+ it's a tail anchor if $ is the last thing in the string, or if it's
+ followed by one of ")| \n\t"
+
+ \1 (backreferences) are turned into $1
+
+ The structure of the code is
+ while (there's a character to process) {
+ handle transliteration ranges
+ skip regexp comments
+ skip # initiated comments in //x patterns
+ check for embedded @foo
+ check for embedded scalars
+ if (backslash) {
+ leave intact backslashes from leave (below)
+ deprecate \1 in strings and sub replacements
+ handle string-changing backslashes \l \U \Q \E, etc.
+ switch (what was escaped) {
+ handle - in a transliteration (becomes a literal -)
+ handle \132 octal characters
+ handle 0x15 hex characters
+ handle \cV (control V)
+ handle printf backslashes (\f, \r, \n, etc)
+ } (end switch)
+ } (end if backslash)
+ } (end while character to read)
+
+*/
+
+STATIC char *
+scan_const(char *start)
+{
+ register char *send = PL_bufend; /* end of the constant */
+ SV *sv = NEWSV(93, send - start); /* sv for the constant */
+ register char *s = start; /* start of the constant */
+ register char *d = SvPVX(sv); /* destination for copies */
+ bool dorange = FALSE; /* are we in a translit range? */
+ I32 len; /* ? */
+
+ /* leaveit is the set of acceptably-backslashed characters */
+ char *leaveit =
+ PL_lex_inpat
+ ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
+ : "";
+
+ while (s < send || dorange) {
+ /* get transliterations out of the way (they're most literal) */
+ if (PL_lex_inwhat == OP_TRANS) {
+ /* expand a range A-Z to the full set of characters. AIE! */
+ if (dorange) {
+ I32 i; /* current expanded character */
+ I32 max; /* last character in range */
+
+ i = d - SvPVX(sv); /* remember current offset */
+ SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
+ d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
+ d -= 2; /* eat the first char and the - */
+
+ max = (U8)d[1]; /* last char in range */
+
+ for (i = (U8)*d; i <= max; i++)
+ *d++ = i;
+
+ /* mark the range as done, and continue */
+ dorange = FALSE;
+ continue;
+ }
+
+ /* range begins (ignore - as first or last char) */
+ else if (*s == '-' && s+1 < send && s != start) {
+ dorange = TRUE;
+ s++;
+ }
+ }
+
+ /* if we get here, we're not doing a transliteration */
+
+ /* skip for regexp comments /(?#comment)/ */
+ else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
+ if (s[2] == '#') {
+ while (s < send && *s != ')')
+ *d++ = *s++;
+ } else if (s[2] == '{') { /* This should march regcomp.c */
+ I32 count = 1;
+ char *regparse = s + 3;
+ char c;
+
+ while (count && (c = *regparse)) {
+ if (c == '\\' && regparse[1])
+ regparse++;
+ else if (c == '{')
+ count++;
+ else if (c == '}')
+ count--;
+ regparse++;
+ }
+ if (*regparse == ')')
+ regparse++;
+ else
+ yyerror("Sequence (?{...}) not terminated or not {}-balanced");
+ while (s < regparse && *s != ')')
+ *d++ = *s++;
+ }
+ }
+
+ /* likewise skip #-initiated comments in //x patterns */
+ else if (*s == '#' && PL_lex_inpat &&
+ ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
+ while (s+1 < send && *s != '\n')
+ *d++ = *s++;
+ }
+
+ /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
+ else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
+ break;
+
+ /* check for embedded scalars. only stop if we're sure it's a
+ variable.
+ */
+ else if (*s == '$') {
+ if (!PL_lex_inpat) /* not a regexp, so $ must be var */
+ break;
+ if (s + 1 < send && !strchr("()| \n\t", s[1]))
+ break; /* in regexp, $ might be tail anchor */
+ }
+
+ /* backslashes */
+ if (*s == '\\' && s+1 < send) {
+ s++;
+
+ /* some backslashes we leave behind */
+ if (*s && strchr(leaveit, *s)) {
+ *d++ = '\\';
+ *d++ = *s++;
+ continue;
+ }
+
+ /* deprecate \1 in strings and substitution replacements */
+ if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
+ isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
+ {
+ if (PL_dowarn)
+ warn("\\%c better written as $%c", *s, *s);
+ *--s = '$';
+ break;
+ }
+
+ /* string-change backslash escapes */
+ if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
+ --s;
+ break;
+ }
+
+ /* if we get here, it's either a quoted -, or a digit */
+ switch (*s) {
+
+ /* quoted - in transliterations */
+ case '-':
+ if (PL_lex_inwhat == OP_TRANS) {
+ *d++ = *s++;
+ continue;
+ }
+ /* FALL THROUGH */
+ /* default action is to copy the quoted character */
+ default:
+ *d++ = *s++;
+ continue;
+
+ /* \132 indicates an octal constant */
+ case '0': case '1': case '2': case '3':
+ case '4': case '5': case '6': case '7':
+ *d++ = scan_oct(s, 3, &len);
+ s += len;
+ continue;
+
+ /* \x24 indicates a hex constant */
+ case 'x':
+ *d++ = scan_hex(++s, 2, &len);
+ s += len;
+ continue;
+
+ /* \c is a control character */
+ case 'c':
+ s++;
+#ifdef EBCDIC
+ *d = *s++;
+ if (isLOWER(*d))
+ *d = toUPPER(*d);
+ *d++ = toCTRL(*d);
+#else
+ len = *s++;
+ *d++ = toCTRL(len);
+#endif
+ continue;
+
+ /* printf-style backslashes, formfeeds, newlines, etc */
+ case 'b':
+ *d++ = '\b';
+ break;
+ case 'n':
+ *d++ = '\n';
+ break;
+ case 'r':
+ *d++ = '\r';
+ break;
+ case 'f':
+ *d++ = '\f';
+ break;
+ case 't':
+ *d++ = '\t';
+ break;
+ case 'e':
+ *d++ = '\033';
+ break;
+ case 'a':
+ *d++ = '\007';
+ break;
+ } /* end switch */
+
+ s++;
+ continue;
+ } /* end if (backslash) */
+
+ *d++ = *s++;
+ } /* while loop to process each character */
+
+ /* terminate the string and set up the sv */
+ *d = '\0';
+ SvCUR_set(sv, d - SvPVX(sv));
+ SvPOK_on(sv);
+
+ /* shrink the sv if we allocated more than we used */
+ if (SvCUR(sv) + 5 < SvLEN(sv)) {
+ SvLEN_set(sv, SvCUR(sv) + 1);
+ Renew(SvPVX(sv), SvLEN(sv), char);
+ }
+
+ /* return the substring (via yylval) only if we parsed anything */
+ if (s > PL_bufptr) {
+ if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
+ sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
+ sv, Nullsv,
+ ( PL_lex_inwhat == OP_TRANS
+ ? "tr"
+ : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
+ ? "s"
+ : "qq")));
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ } else
+ SvREFCNT_dec(sv);
+ return s;
+}
+
+/* This is the one truly awful dwimmer necessary to conflate C and sed. */
+STATIC int
+intuit_more(register char *s)
+{
+ if (PL_lex_brackets)
+ return TRUE;
+ if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
+ return TRUE;
+ if (*s != '{' && *s != '[')
+ return FALSE;
+ if (!PL_lex_inpat)
+ return TRUE;
+
+ /* In a pattern, so maybe we have {n,m}. */
+ if (*s == '{') {
+ s++;
+ if (!isDIGIT(*s))
+ return TRUE;
+ while (isDIGIT(*s))
+ s++;
+ if (*s == ',')
+ s++;
+ while (isDIGIT(*s))
+ s++;
+ if (*s == '}')
+ return FALSE;
+ return TRUE;
+
+ }
+
+ /* On the other hand, maybe we have a character class */
+
+ s++;
+ if (*s == ']' || *s == '^')
+ return FALSE;
+ else {
+ int weight = 2; /* let's weigh the evidence */
+ char seen[256];
+ unsigned char un_char = 255, last_un_char;
+ char *send = strchr(s,']');
+ char tmpbuf[sizeof PL_tokenbuf * 4];
+
+ if (!send) /* has to be an expression */
+ return TRUE;
+
+ Zero(seen,256,char);
+ if (*s == '$')
+ weight -= 3;
+ else if (isDIGIT(*s)) {
+ if (s[1] != ']') {
+ if (isDIGIT(s[1]) && s[2] == ']')
+ weight -= 10;
+ }
+ else
+ weight -= 100;
+ }
+ for (; s < send; s++) {
+ last_un_char = un_char;
+ un_char = (unsigned char)*s;
+ switch (*s) {
+ case '@':
+ case '&':
+ case '$':
+ weight -= seen[un_char] * 10;
+ if (isALNUM(s[1])) {
+ scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
+ if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
+ weight -= 100;
+ else
+ weight -= 10;
+ }
+ else if (*s == '$' && s[1] &&
+ strchr("[#!%*<>()-=",s[1])) {
+ if (/*{*/ strchr("])} =",s[2]))
+ weight -= 10;
+ else
+ weight -= 1;
+ }
+ break;
+ case '\\':
+ un_char = 254;
+ if (s[1]) {
+ if (strchr("wds]",s[1]))
+ weight += 100;
+ else if (seen['\''] || seen['"'])
+ weight += 1;
+ else if (strchr("rnftbxcav",s[1]))
+ weight += 40;
+ else if (isDIGIT(s[1])) {
+ weight += 40;
+ while (s[1] && isDIGIT(s[1]))
+ s++;
+ }
+ }
+ else
+ weight += 100;
+ break;
+ case '-':
+ if (s[1] == '\\')
+ weight += 50;
+ if (strchr("aA01! ",last_un_char))
+ weight += 30;
+ if (strchr("zZ79~",s[1]))
+ weight += 30;
+ if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
+ weight -= 5; /* cope with negative subscript */
+ break;
+ default:
+ if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
+ isALPHA(*s) && s[1] && isALPHA(s[1])) {
+ char *d = tmpbuf;
+ while (isALPHA(*s))
+ *d++ = *s++;
+ *d = '\0';
+ if (keyword(tmpbuf, d - tmpbuf))
+ weight -= 150;
+ }
+ if (un_char == last_un_char + 1)
+ weight += 5;
+ weight -= seen[un_char];
+ break;
+ }
+ seen[un_char]++;
+ }
+ if (weight >= 0) /* probably a character class */
+ return FALSE;
+ }
+
+ return TRUE;
+}
+
+STATIC int
+intuit_method(char *start, GV *gv)
+{
+ char *s = start + (*start == '$');
+ char tmpbuf[sizeof PL_tokenbuf];
+ STRLEN len;
+ GV* indirgv;
+
+ if (gv) {
+ CV *cv;
+ if (GvIO(gv))
+ return 0;
+ if ((cv = GvCVu(gv))) {
+ char *proto = SvPVX(cv);
+ if (proto) {
+ if (*proto == ';')
+ proto++;
+ if (*proto == '*')
+ return 0;
+ }
+ } else
+ gv = 0;
+ }
+ s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
+ if (*start == '$') {
+ if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
+ return 0;
+ s = skipspace(s);
+ PL_bufptr = start;
+ PL_expect = XREF;
+ return *s == '(' ? FUNCMETH : METHOD;
+ }
+ if (!keyword(tmpbuf, len)) {
+ if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
+ len -= 2;
+ tmpbuf[len] = '\0';
+ goto bare_package;
+ }
+ indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
+ if (indirgv && GvCVu(indirgv))
+ return 0;
+ /* filehandle or package name makes it a method */
+ if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
+ s = skipspace(s);
+ if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
+ return 0; /* no assumptions -- "=>" quotes bearword */
+ bare_package:
+ PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
+ newSVpv(tmpbuf,0));
+ PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
+ PL_expect = XTERM;
+ force_next(WORD);
+ PL_bufptr = s;
+ return *s == '(' ? FUNCMETH : METHOD;
+ }
+ }
+ return 0;
+}
+
+STATIC char*
+incl_perldb(void)
+{
+ if (PL_perldb) {
+ char *pdb = PerlEnv_getenv("PERL5DB");
+
+ if (pdb)
+ return pdb;
+ SETERRNO(0,SS$_NORMAL);
+ return "BEGIN { require 'perl5db.pl' }";
+ }
+ return "";
+}
+
+
+/* Encoded script support. filter_add() effectively inserts a
+ * 'pre-processing' function into the current source input stream.
+ * Note that the filter function only applies to the current source file
+ * (e.g., it will not affect files 'require'd or 'use'd by this one).
+ *
+ * The datasv parameter (which may be NULL) can be used to pass
+ * private data to this instance of the filter. The filter function
+ * can recover the SV using the FILTER_DATA macro and use it to
+ * store private buffers and state information.
+ *
+ * The supplied datasv parameter is upgraded to a PVIO type
+ * and the IoDIRP field is used to store the function pointer.
+ * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
+ * private use must be set using malloc'd pointers.
+ */
+static int filter_debug = 0;
+
+SV *
+filter_add(filter_t funcp, SV *datasv)
+{
+ if (!funcp){ /* temporary handy debugging hack to be deleted */
+ filter_debug = atoi((char*)datasv);
+ return NULL;
+ }
+ if (!PL_rsfp_filters)
+ PL_rsfp_filters = newAV();
+ if (!datasv)
+ datasv = NEWSV(255,0);
+ 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));
+ av_unshift(PL_rsfp_filters, 1);
+ av_store(PL_rsfp_filters, 0, datasv) ;
+ return(datasv);
+}
+
+
+/* Delete most recently added instance of this filter function. */
+void
+filter_del(filter_t funcp)
+{
+ if (filter_debug)
+ warn("filter_del func %p", funcp);
+ if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
+ return;
+ /* if filter is on top of stack (usual case) just pop it off */
+ if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (void*)funcp){
+ sv_free(av_pop(PL_rsfp_filters));
+
+ return;
+ }
+ /* we need to search for the correct entry and clear it */
+ die("filter_del can only delete in reverse order (currently)");
+}
+
+
+/* Invoke the n'th filter function for the current rsfp. */
+I32
+filter_read(int idx, SV *buf_sv, int maxlen)
+
+
+ /* 0 = read one text line */
+{
+ filter_t funcp;
+ SV *datasv = NULL;
+
+ if (!PL_rsfp_filters)
+ return -1;
+ if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */
+ /* Provide a default input filter to make life easy. */
+ /* Note that we append to the line. This is handy. */
+ if (filter_debug)
+ warn("filter_read %d: from rsfp\n", idx);
+ if (maxlen) {
+ /* Want a block */
+ int len ;
+ int old_len = SvCUR(buf_sv) ;
+
+ /* ensure buf_sv is large enough */
+ SvGROW(buf_sv, old_len + maxlen) ;
+ if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
+ if (PerlIO_error(PL_rsfp))
+ return -1; /* error */
+ else
+ return 0 ; /* end of file */
+ }
+ SvCUR_set(buf_sv, old_len + len) ;
+ } else {
+ /* Want a line */
+ if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
+ if (PerlIO_error(PL_rsfp))
+ return -1; /* error */
+ else
+ return 0 ; /* end of file */
+ }
+ }
+ return SvCUR(buf_sv);
+ }
+ /* Skip this filter slot if filter has been deleted */
+ if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
+ if (filter_debug)
+ warn("filter_read %d: skipped (filter deleted)\n", idx);
+ return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
+ }
+ /* Get function pointer hidden within datasv */
+ funcp = (filter_t)IoDIRP(datasv);
+ if (filter_debug)
+ warn("filter_read %d: via function %p (%s)\n",
+ idx, funcp, SvPV(datasv,PL_na));
+ /* Call function. The function is expected to */
+ /* call "FILTER_READ(idx+1, buf_sv)" first. */
+ /* Return: <0:error, =0:eof, >0:not eof */
+ return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
+}
+
+STATIC char *
+filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
+{
+#ifdef WIN32FILTER
+ if (!PL_rsfp_filters) {
+ filter_add(win32_textfilter,NULL);
+ }
+#endif
+ if (PL_rsfp_filters) {
+
+ if (!append)
+ SvCUR_set(sv, 0); /* start with empty line */
+ if (FILTER_READ(0, sv, 0) > 0)
+ return ( SvPVX(sv) ) ;
+ else
+ return Nullch ;
+ }
+ else
+ return (sv_gets(sv, fp, append));
+}
+
+
+#ifdef DEBUGGING
+ static char* exp_name[] =
+ { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
+#endif
+
+EXT int yychar; /* last token */
+
+/*
+ yylex
+
+ Works out what to call the token just pulled out of the input
+ stream. The yacc parser takes care of taking the ops we return and
+ stitching them into a tree.
+
+ Returns:
+ PRIVATEREF
+
+ Structure:
+ if read an identifier
+ if we're in a my declaration
+ croak if they tried to say my($foo::bar)
+ build the ops for a my() declaration
+ if it's an access to a my() variable
+ are we in a sort block?
+ croak if my($a); $a <=> $b
+ build ops for access to a my() variable
+ if in a dq string, and they've said @foo and we can't find @foo
+ croak
+ build ops for a bareword
+ if we already built the token before, use it.
+*/
+
+int
+yylex(void)
+{
+ dTHR;
+ register char *s;
+ register char *d;
+ register I32 tmp;
+ STRLEN len;
+ GV *gv = Nullgv;
+ GV **gvp = 0;
+
+ /* check if there's an identifier for us to look at */
+ if (PL_pending_ident) {
+ /* pit holds the identifier we read and pending_ident is reset */
+ char pit = PL_pending_ident;
+ PL_pending_ident = 0;
+
+ /* if we're in a my(), we can't allow dynamics here.
+ $foo'bar has already been turned into $foo::bar, so
+ just check for colons.
+
+ if it's a legal name, the OP is a PADANY.
+ */
+ if (PL_in_my) {
+ if (strchr(PL_tokenbuf,':'))
+ croak(no_myglob,PL_tokenbuf);
+
+ yylval.opval = newOP(OP_PADANY, 0);
+ yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
+ return PRIVATEREF;
+ }
+
+ /*
+ build the ops for accesses to a my() variable.
+
+ Deny my($a) or my($b) in a sort block, *if* $a or $b is
+ then used in a comparison. This catches most, but not
+ all cases. For instance, it catches
+ sort { my($a); $a <=> $b }
+ but not
+ sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
+ (although why you'd do that is anyone's guess).
+ */
+
+ if (!strchr(PL_tokenbuf,':')) {
+#ifdef USE_THREADS
+ /* Check for single character per-thread SVs */
+ if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
+ && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
+ && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
+ {
+ yylval.opval = newOP(OP_THREADSV, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
+#endif /* USE_THREADS */
+ if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
+ /* if it's a sort block and they're naming $a or $b */
+ if (PL_last_lop_op == OP_SORT &&
+ PL_tokenbuf[0] == '$' &&
+ (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
+ && !PL_tokenbuf[2])
+ {
+ for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
+ d < PL_bufend && *d != '\n';
+ d++)
+ {
+ if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
+ croak("Can't use \"my %s\" in sort comparison",
+ PL_tokenbuf);
+ }
+ }
+ }
+
+ yylval.opval = newOP(OP_PADANY, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
+ }
+
+ /*
+ Whine if they've said @foo in a doublequoted string,
+ and @foo isn't a variable we can find in the symbol
+ table.
+ */
+ if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
+ GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
+ if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
+ yyerror(form("In string, %s now must be written as \\%s",
+ PL_tokenbuf, PL_tokenbuf));
+ }
+
+ /* build ops for a bareword */
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
+ yylval.opval->op_private = OPpCONST_ENTERED;
+ gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
+ ((PL_tokenbuf[0] == '$') ? SVt_PV
+ : (PL_tokenbuf[0] == '@') ? SVt_PVAV
+ : SVt_PVHV));
+ return WORD;
+ }
+
+ /* no identifier pending identification */
+
+ switch (PL_lex_state) {
+#ifdef COMMENTARY
+ case LEX_NORMAL: /* Some compilers will produce faster */
+ case LEX_INTERPNORMAL: /* code if we comment these out. */
+ break;
+#endif
+
+ /* when we're already built the next token, just pull it out the queue */
+ case LEX_KNOWNEXT:
+ PL_nexttoke--;
+ yylval = PL_nextval[PL_nexttoke];
+ if (!PL_nexttoke) {
+ PL_lex_state = PL_lex_defer;
+ PL_expect = PL_lex_expect;
+ PL_lex_defer = LEX_NORMAL;
+ }
+ return(PL_nexttype[PL_nexttoke]);
+
+ /* interpolated case modifiers like \L \U, including \Q and \E.
+ when we get here, PL_bufptr is at the \
+ */
+ case LEX_INTERPCASEMOD:
+#ifdef DEBUGGING
+ if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
+ croak("panic: INTERPCASEMOD");
+#endif
+ /* handle \E or end of string */
+ if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
+ char oldmod;
+
+ /* if at a \E */
+ if (PL_lex_casemods) {
+ oldmod = PL_lex_casestack[--PL_lex_casemods];
+ PL_lex_casestack[PL_lex_casemods] = '\0';
+
+ if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
+ PL_bufptr += 2;
+ PL_lex_state = LEX_INTERPCONCAT;
+ }
+ return ')';
+ }
+ if (PL_bufptr != PL_bufend)
+ PL_bufptr += 2;
+ PL_lex_state = LEX_INTERPCONCAT;
+ return yylex();
+ }
+ else {
+ s = PL_bufptr + 1;
+ if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
+ tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */
+ if (strchr("LU", *s) &&
+ (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
+ {
+ PL_lex_casestack[--PL_lex_casemods] = '\0';
+ return ')';
+ }
+ if (PL_lex_casemods > 10) {
+ char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
+ if (newlb != PL_lex_casestack) {
+ SAVEFREEPV(newlb);
+ PL_lex_casestack = newlb;
+ }
+ }
+ PL_lex_casestack[PL_lex_casemods++] = *s;
+ PL_lex_casestack[PL_lex_casemods] = '\0';
+ PL_lex_state = LEX_INTERPCONCAT;
+ PL_nextval[PL_nexttoke].ival = 0;
+ force_next('(');
+ if (*s == 'l')
+ PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
+ else if (*s == 'u')
+ PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
+ else if (*s == 'L')
+ PL_nextval[PL_nexttoke].ival = OP_LC;
+ else if (*s == 'U')
+ PL_nextval[PL_nexttoke].ival = OP_UC;
+ else if (*s == 'Q')
+ PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
+ else
+ croak("panic: yylex");
+ PL_bufptr = s + 1;
+ force_next(FUNC);
+ if (PL_lex_starts) {
+ s = PL_bufptr;
+ PL_lex_starts = 0;
+ Aop(OP_CONCAT);
+ }
+ else
+ return yylex();
+ }
+
+ case LEX_INTERPPUSH:
+ return sublex_push();
+
+ case LEX_INTERPSTART:
+ if (PL_bufptr == PL_bufend)
+ return sublex_done();
+ PL_expect = XTERM;
+ PL_lex_dojoin = (*PL_bufptr == '@');
+ PL_lex_state = LEX_INTERPNORMAL;
+ if (PL_lex_dojoin) {
+ PL_nextval[PL_nexttoke].ival = 0;
+ force_next(',');
+#ifdef USE_THREADS
+ PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
+ PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
+ force_next(PRIVATEREF);
+#else
+ force_ident("\"", '$');
+#endif /* USE_THREADS */
+ PL_nextval[PL_nexttoke].ival = 0;
+ force_next('$');
+ PL_nextval[PL_nexttoke].ival = 0;
+ force_next('(');
+ PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
+ force_next(FUNC);
+ }
+ if (PL_lex_starts++) {
+ s = PL_bufptr;
+ Aop(OP_CONCAT);
+ }
+ return yylex();
+
+ case LEX_INTERPENDMAYBE:
+ if (intuit_more(PL_bufptr)) {
+ PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
+ break;
+ }
+ /* FALL THROUGH */
+
+ case LEX_INTERPEND:
+ if (PL_lex_dojoin) {
+ PL_lex_dojoin = FALSE;
+ PL_lex_state = LEX_INTERPCONCAT;
+ return ')';
+ }
+ /* FALLTHROUGH */
+ case LEX_INTERPCONCAT:
+#ifdef DEBUGGING
+ if (PL_lex_brackets)
+ croak("panic: INTERPCONCAT");
+#endif
+ if (PL_bufptr == PL_bufend)
+ return sublex_done();
+
+ if (SvIVX(PL_linestr) == '\'') {
+ SV *sv = newSVsv(PL_linestr);
+ if (!PL_lex_inpat)
+ sv = tokeq(sv);
+ else if ( PL_hints & HINT_NEW_RE )
+ sv = new_constant(NULL, 0, "qr", sv, sv, "q");
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ s = PL_bufend;
+ }
+ else {
+ s = scan_const(PL_bufptr);
+ if (*s == '\\')
+ PL_lex_state = LEX_INTERPCASEMOD;
+ else
+ PL_lex_state = LEX_INTERPSTART;
+ }
+
+ if (s != PL_bufptr) {
+ PL_nextval[PL_nexttoke] = yylval;
+ PL_expect = XTERM;
+ force_next(THING);
+ if (PL_lex_starts++)
+ Aop(OP_CONCAT);
+ else {
+ PL_bufptr = s;
+ return yylex();
+ }
+ }
+
+ return yylex();
+ case LEX_FORMLINE:
+ PL_lex_state = LEX_NORMAL;
+ s = scan_formline(PL_bufptr);
+ if (!PL_lex_formbrack)
+ goto rightbracket;
+ OPERATOR(';');
+ }
+
+ s = PL_bufptr;
+ PL_oldoldbufptr = PL_oldbufptr;
+ PL_oldbufptr = s;
+ DEBUG_p( {
+ PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
+ } )
+
+ retry:
+ switch (*s) {
+ default:
+ croak("Unrecognized character \\%03o", *s & 255);
+ case 4:
+ case 26:
+ goto fake_eof; /* emulate EOF on ^D or ^Z */
+ case 0:
+ if (!PL_rsfp) {
+ PL_last_uni = 0;
+ PL_last_lop = 0;
+ if (PL_lex_brackets)
+ yyerror("Missing right bracket");
+ TOKEN(0);
+ }
+ if (s++ < PL_bufend)
+ goto retry; /* ignore stray nulls */
+ PL_last_uni = 0;
+ PL_last_lop = 0;
+ if (!PL_in_eval && !PL_preambled) {
+ PL_preambled = TRUE;
+ sv_setpv(PL_linestr,incl_perldb());
+ if (SvCUR(PL_linestr))
+ sv_catpv(PL_linestr,";");
+ if (PL_preambleav){
+ while(AvFILLp(PL_preambleav) >= 0) {
+ SV *tmpsv = av_shift(PL_preambleav);
+ sv_catsv(PL_linestr, tmpsv);
+ sv_catpv(PL_linestr, ";");
+ sv_free(tmpsv);
+ }
+ sv_free((SV*)PL_preambleav);
+ PL_preambleav = NULL;
+ }
+ if (PL_minus_n || PL_minus_p) {
+ sv_catpv(PL_linestr, "LINE: while (<>) {");
+ if (PL_minus_l)
+ sv_catpv(PL_linestr,"chomp;");
+ if (PL_minus_a) {
+ GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
+ if (gv)
+ GvIMPORTED_AV_on(gv);
+ if (PL_minus_F) {
+ if (strchr("/'\"", *PL_splitstr)
+ && strchr(PL_splitstr + 1, *PL_splitstr))
+ sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
+ else {
+ char delim;
+ s = "'~#\200\1'"; /* surely one char is unused...*/
+ while (s[1] && strchr(PL_splitstr, *s)) s++;
+ delim = *s;
+ sv_catpvf(PL_linestr, "@F=split(%s%c",
+ "q" + (delim == '\''), delim);
+ for (s = PL_splitstr; *s; s++) {
+ if (*s == '\\')
+ sv_catpvn(PL_linestr, "\\", 1);
+ sv_catpvn(PL_linestr, s, 1);
+ }
+ sv_catpvf(PL_linestr, "%c);", delim);
+ }
+ }
+ else
+ sv_catpv(PL_linestr,"@F=split(' ');");
+ }
+ }
+ sv_catpv(PL_linestr, "\n");
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ if (PERLDB_LINE && PL_curstash != PL_debstash) {
+ SV *sv = NEWSV(85,0);
+
+ sv_upgrade(sv, SVt_PVMG);
+ sv_setsv(sv,PL_linestr);
+ av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
+ }
+ goto retry;
+ }
+ do {
+ if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
+ fake_eof:
+ if (PL_rsfp) {
+ if (PL_preprocess && !PL_in_eval)
+ (void)PerlProc_pclose(PL_rsfp);
+ else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
+ PerlIO_clearerr(PL_rsfp);
+ else
+ (void)PerlIO_close(PL_rsfp);
+ PL_rsfp = Nullfp;
+ PL_doextract = FALSE;
+ }
+ if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
+ sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
+ sv_catpv(PL_linestr,";}");
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_minus_n = PL_minus_p = 0;
+ goto retry;
+ }
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ sv_setpv(PL_linestr,"");
+ TOKEN(';'); /* not infinite loop because rsfp is NULL now */
+ }
+ if (PL_doextract) {
+ if (*s == '#' && s[1] == '!' && instr(s,"perl"))
+ PL_doextract = FALSE;
+
+ /* Incest with pod. */
+ if (*s == '=' && strnEQ(s, "=cut", 4)) {
+ sv_setpv(PL_linestr, "");
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_doextract = FALSE;
+ }
+ }
+ incline(s);
+ } while (PL_doextract);
+ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
+ if (PERLDB_LINE && PL_curstash != PL_debstash) {
+ SV *sv = NEWSV(85,0);
+
+ sv_upgrade(sv, SVt_PVMG);
+ sv_setsv(sv,PL_linestr);
+ av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
+ }
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ if (PL_curcop->cop_line == 1) {
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
+ s++;
+ d = Nullch;
+ if (!PL_in_eval) {
+ if (*s == '#' && *(s+1) == '!')
+ d = s + 2;
+#ifdef ALTERNATE_SHEBANG
+ else {
+ static char as[] = ALTERNATE_SHEBANG;
+ if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
+ d = s + (sizeof(as) - 1);
+ }
+#endif /* ALTERNATE_SHEBANG */
+ }
+ if (d) {
+ char *ipath;
+ char *ipathend;
+
+ while (isSPACE(*d))
+ d++;
+ ipath = d;
+ while (*d && !isSPACE(*d))
+ d++;
+ ipathend = d;
+
+#ifdef ARG_ZERO_IS_SCRIPT
+ if (ipathend > ipath) {
+ /*
+ * HP-UX (at least) sets argv[0] to the script name,
+ * which makes $^X incorrect. And Digital UNIX and Linux,
+ * at least, set argv[0] to the basename of the Perl
+ * interpreter. So, having found "#!", we'll set it right.
+ */
+ SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
+ assert(SvPOK(x) || SvGMAGICAL(x));
+ if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
+ sv_setpvn(x, ipath, ipathend - ipath);
+ SvSETMAGIC(x);
+ }
+ TAINT_NOT; /* $^X is always tainted, but that's OK */
+ }
+#endif /* ARG_ZERO_IS_SCRIPT */
+
+ /*
+ * Look for options.
+ */
+ d = instr(s,"perl -");
+ if (!d)
+ d = instr(s,"perl");
+#ifdef ALTERNATE_SHEBANG
+ /*
+ * If the ALTERNATE_SHEBANG on this system starts with a
+ * character that can be part of a Perl expression, then if
+ * we see it but not "perl", we're probably looking at the
+ * start of Perl code, not a request to hand off to some
+ * other interpreter. Similarly, if "perl" is there, but
+ * not in the first 'word' of the line, we assume the line
+ * contains the start of the Perl program.
+ */
+ if (d && *s != '#') {
+ char *c = ipath;
+ while (*c && !strchr("; \t\r\n\f\v#", *c))
+ c++;
+ if (c < d)
+ d = Nullch; /* "perl" not in first word; ignore */
+ else
+ *s = '#'; /* Don't try to parse shebang line */
+ }
+#endif /* ALTERNATE_SHEBANG */
+ if (!d &&
+ *s == '#' &&
+ ipathend > ipath &&
+ !PL_minus_c &&
+ !instr(s,"indir") &&
+ instr(PL_origargv[0],"perl"))
+ {
+ char **newargv;
+
+ *ipathend = '\0';
+ s = ipathend + 1;
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (s < PL_bufend) {
+ Newz(899,newargv,PL_origargc+3,char*);
+ newargv[1] = s;
+ while (s < PL_bufend && !isSPACE(*s))
+ s++;
+ *s = '\0';
+ Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
+ }
+ else
+ newargv = PL_origargv;
+ newargv[0] = ipath;
+ execv(ipath, newargv);
+ croak("Can't exec %s", ipath);
+ }
+ if (d) {
+ U32 oldpdb = PL_perldb;
+ bool oldn = PL_minus_n;
+ bool oldp = PL_minus_p;
+
+ while (*d && !isSPACE(*d)) d++;
+ while (*d == ' ' || *d == '\t') d++;
+
+ if (*d++ == '-') {
+ do {
+ if (*d == 'M' || *d == 'm') {
+ char *m = d;
+ while (*d && !isSPACE(*d)) d++;
+ croak("Too late for \"-%.*s\" option",
+ (int)(d - m), m);
+ }
+ d = moreswitches(d);
+ } while (d);
+ if (PERLDB_LINE && !oldpdb ||
+ ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
+ /* if we have already added "LINE: while (<>) {",
+ we must not do it again */
+ {
+ sv_setpv(PL_linestr, "");
+ PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ PL_preambled = FALSE;
+ if (PERLDB_LINE)
+ (void)gv_fetchfile(PL_origfilename);
+ goto retry;
+ }
+ }
+ }
+ }
+ }
+ if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
+ PL_bufptr = s;
+ PL_lex_state = LEX_FORMLINE;
+ return yylex();
+ }
+ goto retry;
+ case '\r':
+#ifdef PERL_STRICT_CR
+ warn("Illegal character \\%03o (carriage return)", '\r');
+ croak(
+ "(Maybe you didn't strip carriage returns after a network transfer?)\n");
+#endif
+ case ' ': case '\t': case '\f': case 013:
+ s++;
+ goto retry;
+ case '#':
+ case '\n':
+ if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
+ d = PL_bufend;
+ while (s < d && *s != '\n')
+ s++;
+ if (s < d)
+ s++;
+ incline(s);
+ if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
+ PL_bufptr = s;
+ PL_lex_state = LEX_FORMLINE;
+ return yylex();
+ }
+ }
+ else {
+ *s = '\0';
+ PL_bufend = s;
+ }
+ goto retry;
+ case '-':
+ if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
+ s++;
+ PL_bufptr = s;
+ tmp = *s++;
+
+ while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ s++;
+
+ if (strnEQ(s,"=>",2)) {
+ s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
+ OPERATOR('-'); /* unary minus */
+ }
+ PL_last_uni = PL_oldbufptr;
+ PL_last_lop_op = OP_FTEREAD; /* good enough */
+ switch (tmp) {
+ case 'r': FTST(OP_FTEREAD);
+ case 'w': FTST(OP_FTEWRITE);
+ case 'x': FTST(OP_FTEEXEC);
+ case 'o': FTST(OP_FTEOWNED);
+ case 'R': FTST(OP_FTRREAD);
+ case 'W': FTST(OP_FTRWRITE);
+ case 'X': FTST(OP_FTREXEC);
+ case 'O': FTST(OP_FTROWNED);
+ case 'e': FTST(OP_FTIS);
+ case 'z': FTST(OP_FTZERO);
+ case 's': FTST(OP_FTSIZE);
+ case 'f': FTST(OP_FTFILE);
+ case 'd': FTST(OP_FTDIR);
+ case 'l': FTST(OP_FTLINK);
+ case 'p': FTST(OP_FTPIPE);
+ case 'S': FTST(OP_FTSOCK);
+ case 'u': FTST(OP_FTSUID);
+ case 'g': FTST(OP_FTSGID);
+ case 'k': FTST(OP_FTSVTX);
+ case 'b': FTST(OP_FTBLK);
+ case 'c': FTST(OP_FTCHR);
+ case 't': FTST(OP_FTTTY);
+ case 'T': FTST(OP_FTTEXT);
+ case 'B': FTST(OP_FTBINARY);
+ case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
+ case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
+ case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
+ default:
+ croak("Unrecognized file test: -%c", (int)tmp);
+ break;
+ }
+ }
+ tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ if (PL_expect == XOPERATOR)
+ TERM(POSTDEC);
+ else
+ OPERATOR(PREDEC);
+ }
+ else if (*s == '>') {
+ s++;
+ s = skipspace(s);
+ if (isIDFIRST(*s)) {
+ s = force_word(s,METHOD,FALSE,TRUE,FALSE);
+ TOKEN(ARROW);
+ }
+ else if (*s == '$')
+ OPERATOR(ARROW);
+ else
+ TERM(ARROW);
+ }
+ if (PL_expect == XOPERATOR)
+ Aop(OP_SUBTRACT);
+ else {
+ if (isSPACE(*s) || !isSPACE(*PL_bufptr))
+ check_uni();
+ OPERATOR('-'); /* unary minus */
+ }
+
+ case '+':
+ tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ if (PL_expect == XOPERATOR)
+ TERM(POSTINC);
+ else
+ OPERATOR(PREINC);
+ }
+ if (PL_expect == XOPERATOR)
+ Aop(OP_ADD);
+ else {
+ if (isSPACE(*s) || !isSPACE(*PL_bufptr))
+ check_uni();
+ OPERATOR('+');
+ }
+
+ case '*':
+ if (PL_expect != XOPERATOR) {
+ s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
+ PL_expect = XOPERATOR;
+ force_ident(PL_tokenbuf, '*');
+ if (!*PL_tokenbuf)
+ PREREF('*');
+ TERM('*');
+ }
+ s++;
+ if (*s == '*') {
+ s++;
+ PWop(OP_POW);
+ }
+ Mop(OP_MULTIPLY);
+
+ case '%':
+ if (PL_expect == XOPERATOR) {
+ ++s;
+ Mop(OP_MODULO);
+ }
+ PL_tokenbuf[0] = '%';
+ s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
+ if (!PL_tokenbuf[1]) {
+ if (s == PL_bufend)
+ yyerror("Final % should be \\% or %name");
+ PREREF('%');
+ }
+ PL_pending_ident = '%';
+ TERM('%');
+
+ case '^':
+ s++;
+ BOop(OP_BIT_XOR);
+ case '[':
+ PL_lex_brackets++;
+ /* FALL THROUGH */
+ case '~':
+ case ',':
+ tmp = *s++;
+ OPERATOR(tmp);
+ case ':':
+ if (s[1] == ':') {
+ len = 0;
+ goto just_a_word;
+ }
+ s++;
+ OPERATOR(':');
+ case '(':
+ s++;
+ if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
+ PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
+ else
+ PL_expect = XTERM;
+ TOKEN('(');
+ case ';':
+ if (PL_curcop->cop_line < PL_copline)
+ PL_copline = PL_curcop->cop_line;
+ tmp = *s++;
+ OPERATOR(tmp);
+ case ')':
+ tmp = *s++;
+ s = skipspace(s);
+ if (*s == '{')
+ PREBLOCK(tmp);
+ TERM(tmp);
+ case ']':
+ s++;
+ if (PL_lex_brackets <= 0)
+ yyerror("Unmatched right bracket");
+ else
+ --PL_lex_brackets;
+ if (PL_lex_state == LEX_INTERPNORMAL) {
+ if (PL_lex_brackets == 0) {
+ if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
+ PL_lex_state = LEX_INTERPEND;
+ }
+ }
+ TERM(']');
+ case '{':
+ leftbracket:
+ s++;
+ if (PL_lex_brackets > 100) {
+ char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
+ if (newlb != PL_lex_brackstack) {
+ SAVEFREEPV(newlb);
+ PL_lex_brackstack = newlb;
+ }
+ }
+ switch (PL_expect) {
+ case XTERM:
+ if (PL_lex_formbrack) {
+ s--;
+ PRETERMBLOCK(DO);
+ }
+ if (PL_oldoldbufptr == PL_last_lop)
+ PL_lex_brackstack[PL_lex_brackets++] = XTERM;
+ else
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ OPERATOR(HASHBRACK);
+ case XOPERATOR:
+ while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ s++;
+ d = s;
+ PL_tokenbuf[0] = '\0';
+ if (d < PL_bufend && *d == '-') {
+ PL_tokenbuf[0] = '-';
+ d++;
+ while (d < PL_bufend && (*d == ' ' || *d == '\t'))
+ d++;
+ }
+ if (d < PL_bufend && isIDFIRST(*d)) {
+ d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
+ FALSE, &len);
+ while (d < PL_bufend && (*d == ' ' || *d == '\t'))
+ d++;
+ if (*d == '}') {
+ char minus = (PL_tokenbuf[0] == '-');
+ s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
+ if (minus)
+ force_next('-');
+ }
+ }
+ /* FALL THROUGH */
+ case XBLOCK:
+ PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
+ PL_expect = XSTATE;
+ break;
+ case XTERMBLOCK:
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ PL_expect = XSTATE;
+ break;
+ default: {
+ char *t;
+ if (PL_oldoldbufptr == PL_last_lop)
+ PL_lex_brackstack[PL_lex_brackets++] = XTERM;
+ else
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ s = skipspace(s);
+ if (*s == '}')
+ OPERATOR(HASHBRACK);
+ /* This hack serves to disambiguate a pair of curlies
+ * as being a block or an anon hash. Normally, expectation
+ * determines that, but in cases where we're not in a
+ * position to expect anything in particular (like inside
+ * eval"") we have to resolve the ambiguity. This code
+ * covers the case where the first term in the curlies is a
+ * quoted string. Most other cases need to be explicitly
+ * disambiguated by prepending a `+' before the opening
+ * curly in order to force resolution as an anon hash.
+ *
+ * XXX should probably propagate the outer expectation
+ * into eval"" to rely less on this hack, but that could
+ * potentially break current behavior of eval"".
+ * GSAR 97-07-21
+ */
+ t = s;
+ if (*s == '\'' || *s == '"' || *s == '`') {
+ /* common case: get past first string, handling escapes */
+ for (t++; t < PL_bufend && *t != *s;)
+ if (*t++ == '\\' && (*t == '\\' || *t == *s))
+ t++;
+ t++;
+ }
+ else if (*s == 'q') {
+ if (++t < PL_bufend
+ && (!isALNUM(*t)
+ || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
+ && !isALNUM(*t)))) {
+ char *tmps;
+ char open, close, term;
+ I32 brackets = 1;
+
+ while (t < PL_bufend && isSPACE(*t))
+ t++;
+ term = *t;
+ open = term;
+ if (term && (tmps = strchr("([{< )]}> )]}>",term)))
+ term = tmps[5];
+ close = term;
+ if (open == close)
+ for (t++; t < PL_bufend; t++) {
+ if (*t == '\\' && t+1 < PL_bufend && open != '\\')
+ t++;
+ else if (*t == open)
+ break;
+ }
+ else
+ for (t++; t < PL_bufend; t++) {
+ if (*t == '\\' && t+1 < PL_bufend)
+ t++;
+ else if (*t == close && --brackets <= 0)
+ break;
+ else if (*t == open)
+ brackets++;
+ }
+ }
+ t++;
+ }
+ else if (isALPHA(*s)) {
+ for (t++; t < PL_bufend && isALNUM(*t); t++) ;
+ }
+ while (t < PL_bufend && isSPACE(*t))
+ t++;
+ /* if comma follows first term, call it an anon hash */
+ /* XXX it could be a comma expression with loop modifiers */
+ if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
+ || (*t == '=' && t[1] == '>')))
+ OPERATOR(HASHBRACK);
+ if (PL_expect == XREF)
+ PL_expect = XTERM;
+ else {
+ PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
+ PL_expect = XSTATE;
+ }
+ }
+ break;
+ }
+ yylval.ival = PL_curcop->cop_line;
+ if (isSPACE(*s) || *s == '#')
+ PL_copline = NOLINE; /* invalidate current command line number */
+ TOKEN('{');
+ case '}':
+ rightbracket:
+ s++;
+ if (PL_lex_brackets <= 0)
+ yyerror("Unmatched right bracket");
+ else
+ PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
+ if (PL_lex_brackets < PL_lex_formbrack)
+ PL_lex_formbrack = 0;
+ if (PL_lex_state == LEX_INTERPNORMAL) {
+ if (PL_lex_brackets == 0) {
+ if (PL_lex_fakebrack) {
+ PL_lex_state = LEX_INTERPEND;
+ PL_bufptr = s;
+ return yylex(); /* ignore fake brackets */
+ }
+ if (*s == '-' && s[1] == '>')
+ PL_lex_state = LEX_INTERPENDMAYBE;
+ else if (*s != '[' && *s != '{')
+ PL_lex_state = LEX_INTERPEND;
+ }
+ }
+ if (PL_lex_brackets < PL_lex_fakebrack) {
+ PL_bufptr = s;
+ PL_lex_fakebrack = 0;
+ return yylex(); /* ignore fake brackets */
+ }
+ force_next('}');
+ TOKEN(';');
+ case '&':
+ s++;
+ tmp = *s++;
+ if (tmp == '&')
+ AOPERATOR(ANDAND);
+ s--;
+ if (PL_expect == XOPERATOR) {
+ if (PL_dowarn && isALPHA(*s) && PL_bufptr == PL_linestart) {
+ PL_curcop->cop_line--;
+ warn(warn_nosemi);
+ PL_curcop->cop_line++;
+ }
+ BAop(OP_BIT_AND);
+ }
+
+ s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
+ if (*PL_tokenbuf) {
+ PL_expect = XOPERATOR;
+ force_ident(PL_tokenbuf, '&');
+ }
+ else
+ PREREF('&');
+ yylval.ival = (OPpENTERSUB_AMPER<<8);
+ TERM('&');
+
+ case '|':
+ s++;
+ tmp = *s++;
+ if (tmp == '|')
+ AOPERATOR(OROR);
+ s--;
+ BOop(OP_BIT_OR);
+ case '=':
+ s++;
+ tmp = *s++;
+ if (tmp == '=')
+ Eop(OP_EQ);
+ if (tmp == '>')
+ OPERATOR(',');
+ if (tmp == '~')
+ PMop(OP_MATCH);
+ if (PL_dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
+ warn("Reversed %c= operator",(int)tmp);
+ s--;
+ if (PL_expect == XSTATE && isALPHA(tmp) &&
+ (s == PL_linestart+1 || s[-2] == '\n') )
+ {
+ if (PL_in_eval && !PL_rsfp) {
+ d = PL_bufend;
+ while (s < d) {
+ if (*s++ == '\n') {
+ incline(s);
+ if (strnEQ(s,"=cut",4)) {
+ s = strchr(s,'\n');
+ if (s)
+ s++;
+ else
+ s = d;
+ incline(s);
+ goto retry;
+ }
+ }
+ }
+ goto retry;
+ }
+ s = PL_bufend;
+ PL_doextract = TRUE;
+ goto retry;
+ }
+ if (PL_lex_brackets < PL_lex_formbrack) {
+ char *t;
+ for (t = s; *t == ' ' || *t == '\t'; t++) ;
+ if (*t == '\n' || *t == '#') {
+ s--;
+ PL_expect = XBLOCK;
+ goto leftbracket;
+ }
+ }
+ yylval.ival = 0;
+ OPERATOR(ASSIGNOP);
+ case '!':
+ s++;
+ tmp = *s++;
+ if (tmp == '=')
+ Eop(OP_NE);
+ if (tmp == '~')
+ PMop(OP_NOT);
+ s--;
+ OPERATOR('!');
+ case '<':
+ if (PL_expect != XOPERATOR) {
+ if (s[1] != '<' && !strchr(s,'>'))
+ check_uni();
+ if (s[1] == '<')
+ s = scan_heredoc(s);
+ else
+ s = scan_inputsymbol(s);
+ TERM(sublex_start());
+ }
+ s++;
+ tmp = *s++;
+ if (tmp == '<')
+ SHop(OP_LEFT_SHIFT);
+ if (tmp == '=') {
+ tmp = *s++;
+ if (tmp == '>')
+ Eop(OP_NCMP);
+ s--;
+ Rop(OP_LE);
+ }
+ s--;
+ Rop(OP_LT);
+ case '>':
+ s++;
+ tmp = *s++;
+ if (tmp == '>')
+ SHop(OP_RIGHT_SHIFT);
+ if (tmp == '=')
+ Rop(OP_GE);
+ s--;
+ Rop(OP_GT);
+
+ case '$':
+ CLINE;
+
+ if (PL_expect == XOPERATOR) {
+ if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
+ PL_expect = XTERM;
+ depcom();
+ return ','; /* grandfather non-comma-format format */
+ }
+ }
+
+ if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
+ if (PL_expect == XOPERATOR)
+ no_op("Array length", PL_bufptr);
+ PL_tokenbuf[0] = '@';
+ s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
+ FALSE);
+ if (!PL_tokenbuf[1])
+ PREREF(DOLSHARP);
+ PL_expect = XOPERATOR;
+ PL_pending_ident = '#';
+ TOKEN(DOLSHARP);
+ }
+
+ if (PL_expect == XOPERATOR)
+ no_op("Scalar", PL_bufptr);
+ PL_tokenbuf[0] = '$';
+ s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
+ if (!PL_tokenbuf[1]) {
+ if (s == PL_bufend)
+ yyerror("Final $ should be \\$ or $name");
+ PREREF('$');
+ }
+
+ /* This kludge not intended to be bulletproof. */
+ if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
+ yylval.opval = newSVOP(OP_CONST, 0,
+ newSViv((IV)PL_compiling.cop_arybase));
+ yylval.opval->op_private = OPpCONST_ARYBASE;
+ TERM(THING);
+ }
+
+ d = s;
+ if (PL_lex_state == LEX_NORMAL)
+ s = skipspace(s);
+
+ if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
+ char *t;
+ if (*s == '[') {
+ PL_tokenbuf[0] = '@';
+ if (PL_dowarn) {
+ for(t = s + 1;
+ isSPACE(*t) || isALNUM(*t) || *t == '$';
+ t++) ;
+ if (*t++ == ',') {
+ PL_bufptr = skipspace(PL_bufptr);
+ while (t < PL_bufend && *t != ']')
+ t++;
+ warn("Multidimensional syntax %.*s not supported",
+ (t - PL_bufptr) + 1, PL_bufptr);
+ }
+ }
+ }
+ else if (*s == '{') {
+ PL_tokenbuf[0] = '%';
+ if (PL_dowarn && strEQ(PL_tokenbuf+1, "SIG") &&
+ (t = strchr(s, '}')) && (t = strchr(t, '=')))
+ {
+ char tmpbuf[sizeof PL_tokenbuf];
+ STRLEN len;
+ for (t++; isSPACE(*t); t++) ;
+ if (isIDFIRST(*t)) {
+ t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
+ if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
+ warn("You need to quote \"%s\"", tmpbuf);
+ }
+ }
+ }
+ }
+
+ PL_expect = XOPERATOR;
+ if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
+ bool islop = (PL_last_lop == PL_oldoldbufptr);
+ if (!islop || PL_last_lop_op == OP_GREPSTART)
+ PL_expect = XOPERATOR;
+ else if (strchr("$@\"'`q", *s))
+ PL_expect = XTERM; /* e.g. print $fh "foo" */
+ else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
+ PL_expect = XTERM; /* e.g. print $fh &sub */
+ else if (isIDFIRST(*s)) {
+ char tmpbuf[sizeof PL_tokenbuf];
+ scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
+ if (tmp = keyword(tmpbuf, len)) {
+ /* binary operators exclude handle interpretations */
+ switch (tmp) {
+ case -KEY_x:
+ case -KEY_eq:
+ case -KEY_ne:
+ case -KEY_gt:
+ case -KEY_lt:
+ case -KEY_ge:
+ case -KEY_le:
+ case -KEY_cmp:
+ break;
+ default:
+ PL_expect = XTERM; /* e.g. print $fh length() */
+ break;
+ }
+ }
+ else {
+ GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
+ if (gv && GvCVu(gv))
+ PL_expect = XTERM; /* e.g. print $fh subr() */
+ }
+ }
+ else if (isDIGIT(*s))
+ PL_expect = XTERM; /* e.g. print $fh 3 */
+ else if (*s == '.' && isDIGIT(s[1]))
+ PL_expect = XTERM; /* e.g. print $fh .3 */
+ else if (strchr("/?-+", *s) && !isSPACE(s[1]))
+ PL_expect = XTERM; /* e.g. print $fh -1 */
+ else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
+ PL_expect = XTERM; /* print $fh <<"EOF" */
+ }
+ PL_pending_ident = '$';
+ TOKEN('$');
+
+ case '@':
+ if (PL_expect == XOPERATOR)
+ no_op("Array", s);
+ PL_tokenbuf[0] = '@';
+ s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
+ if (!PL_tokenbuf[1]) {
+ if (s == PL_bufend)
+ yyerror("Final @ should be \\@ or @name");
+ PREREF('@');
+ }
+ if (PL_lex_state == LEX_NORMAL)
+ s = skipspace(s);
+ if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
+ if (*s == '{')
+ PL_tokenbuf[0] = '%';
+
+ /* Warn about @ where they meant $. */
+ if (PL_dowarn) {
+ if (*s == '[' || *s == '{') {
+ char *t = s + 1;
+ while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
+ t++;
+ if (*t == '}' || *t == ']') {
+ t++;
+ PL_bufptr = skipspace(PL_bufptr);
+ warn("Scalar value %.*s better written as $%.*s",
+ t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
+ }
+ }
+ }
+ }
+ PL_pending_ident = '@';
+ TERM('@');
+
+ case '/': /* may either be division or pattern */
+ case '?': /* may either be conditional or pattern */
+ if (PL_expect != XOPERATOR) {
+ /* Disable warning on "study /blah/" */
+ if (PL_oldoldbufptr == PL_last_uni
+ && (*PL_last_uni != 's' || s - PL_last_uni < 5
+ || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
+ check_uni();
+ s = scan_pat(s,OP_MATCH);
+ TERM(sublex_start());
+ }
+ tmp = *s++;
+ if (tmp == '/')
+ Mop(OP_DIVIDE);
+ OPERATOR(tmp);
+
+ case '.':
+ if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' &&
+ (s == PL_linestart || s[-1] == '\n') ) {
+ PL_lex_formbrack = 0;
+ PL_expect = XSTATE;
+ goto rightbracket;
+ }
+ if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
+ tmp = *s++;
+ if (*s == tmp) {
+ s++;
+ if (*s == tmp) {
+ s++;
+ yylval.ival = OPf_SPECIAL;
+ }
+ else
+ yylval.ival = 0;
+ OPERATOR(DOTDOT);
+ }
+ if (PL_expect != XOPERATOR)
+ check_uni();
+ Aop(OP_CONCAT);
+ }
+ /* FALL THROUGH */
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ s = scan_num(s);
+ if (PL_expect == XOPERATOR)
+ no_op("Number",s);
+ TERM(THING);
+
+ case '\'':
+ s = scan_str(s);
+ if (PL_expect == XOPERATOR) {
+ if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
+ PL_expect = XTERM;
+ depcom();
+ return ','; /* grandfather non-comma-format format */
+ }
+ else
+ no_op("String",s);
+ }
+ if (!s)
+ missingterm((char*)0);
+ yylval.ival = OP_CONST;
+ TERM(sublex_start());
+
+ case '"':
+ s = scan_str(s);
+ if (PL_expect == XOPERATOR) {
+ if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
+ PL_expect = XTERM;
+ depcom();
+ return ','; /* grandfather non-comma-format format */
+ }
+ else
+ no_op("String",s);
+ }
+ if (!s)
+ missingterm((char*)0);
+ yylval.ival = OP_CONST;
+ for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
+ if (*d == '$' || *d == '@' || *d == '\\') {
+ yylval.ival = OP_STRINGIFY;
+ break;
+ }
+ }
+ TERM(sublex_start());
+
+ case '`':
+ s = scan_str(s);
+ if (PL_expect == XOPERATOR)
+ no_op("Backticks",s);
+ if (!s)
+ missingterm((char*)0);
+ yylval.ival = OP_BACKTICK;
+ set_csh();
+ TERM(sublex_start());
+
+ case '\\':
+ s++;
+ if (PL_dowarn && PL_lex_inwhat && isDIGIT(*s))
+ warn("Can't use \\%c to mean $%c in expression", *s, *s);
+ if (PL_expect == XOPERATOR)
+ no_op("Backslash",s);
+ OPERATOR(REFGEN);
+
+ case 'x':
+ if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
+ s++;
+ Mop(OP_REPEAT);
+ }
+ goto keylookup;
+
+ case '_':
+ case 'a': case 'A':
+ case 'b': case 'B':
+ case 'c': case 'C':
+ case 'd': case 'D':
+ case 'e': case 'E':
+ case 'f': case 'F':
+ case 'g': case 'G':
+ case 'h': case 'H':
+ case 'i': case 'I':
+ case 'j': case 'J':
+ case 'k': case 'K':
+ case 'l': case 'L':
+ case 'm': case 'M':
+ case 'n': case 'N':
+ case 'o': case 'O':
+ case 'p': case 'P':
+ case 'q': case 'Q':
+ case 'r': case 'R':
+ case 's': case 'S':
+ case 't': case 'T':
+ case 'u': case 'U':
+ case 'v': case 'V':
+ case 'w': case 'W':
+ case 'X':
+ case 'y': case 'Y':
+ case 'z': case 'Z':
+
+ keylookup: {
+ gv = Nullgv;
+ gvp = 0;
+
+ PL_bufptr = s;
+ s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
+
+ /* Some keywords can be followed by any delimiter, including ':' */
+ tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
+ len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
+ (PL_tokenbuf[0] == 'q' &&
+ strchr("qwxr", PL_tokenbuf[1]))));
+
+ /* x::* is just a word, unless x is "CORE" */
+ if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
+ goto just_a_word;
+
+ d = s;
+ while (d < PL_bufend && isSPACE(*d))
+ d++; /* no comments skipped here, or s### is misparsed */
+
+ /* Is this a label? */
+ if (!tmp && PL_expect == XSTATE
+ && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
+ s = d + 1;
+ yylval.pval = savepv(PL_tokenbuf);
+ CLINE;
+ TOKEN(LABEL);
+ }
+
+ /* Check for keywords */
+ tmp = keyword(PL_tokenbuf, len);
+
+ /* Is this a word before a => operator? */
+ if (strnEQ(d,"=>",2)) {
+ CLINE;
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
+ yylval.opval->op_private = OPpCONST_BARE;
+ TERM(WORD);
+ }
+
+ if (tmp < 0) { /* second-class keyword? */
+ GV *ogv = Nullgv; /* override (winner) */
+ GV *hgv = Nullgv; /* hidden (loser) */
+ if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
+ CV *cv;
+ if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
+ (cv = GvCVu(gv)))
+ {
+ if (GvIMPORTED_CV(gv))
+ ogv = gv;
+ else if (! CvMETHOD(cv))
+ hgv = gv;
+ }
+ if (!ogv &&
+ (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
+ (gv = *gvp) != (GV*)&PL_sv_undef &&
+ GvCVu(gv) && GvIMPORTED_CV(gv))
+ {
+ ogv = gv;
+ }
+ }
+ if (ogv) {
+ tmp = 0; /* overridden by import or by GLOBAL */
+ }
+ else if (gv && !gvp
+ && -tmp==KEY_lock /* XXX generalizable kludge */
+ && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
+ {
+ tmp = 0; /* any sub overrides "weak" keyword */
+ }
+ else { /* no override */
+ tmp = -tmp;
+ gv = Nullgv;
+ gvp = 0;
+ if (PL_dowarn && hgv)
+ warn("Ambiguous call resolved as CORE::%s(), %s",
+ GvENAME(hgv), "qualify as such or use &");
+ }
+ }
+
+ reserved_word:
+ switch (tmp) {
+
+ default: /* not a keyword */
+ just_a_word: {
+ SV *sv;
+ char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
+
+ /* Get the rest if it looks like a package qualifier */
+
+ if (*s == '\'' || *s == ':' && s[1] == ':') {
+ STRLEN morelen;
+ s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
+ TRUE, &morelen);
+ if (!morelen)
+ croak("Bad name after %s%s", PL_tokenbuf,
+ *s == '\'' ? "'" : "::");
+ len += morelen;
+ }
+
+ if (PL_expect == XOPERATOR) {
+ if (PL_bufptr == PL_linestart) {
+ PL_curcop->cop_line--;
+ warn(warn_nosemi);
+ PL_curcop->cop_line++;
+ }
+ else
+ no_op("Bareword",s);
+ }
+
+ /* Look for a subroutine with this name in current package,
+ unless name is "Foo::", in which case Foo is a bearword
+ (and a package name). */
+
+ if (len > 2 &&
+ PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
+ {
+ if (PL_dowarn && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
+ warn("Bareword \"%s\" refers to nonexistent package",
+ PL_tokenbuf);
+ len -= 2;
+ PL_tokenbuf[len] = '\0';
+ gv = Nullgv;
+ gvp = 0;
+ }
+ else {
+ len = 0;
+ if (!gv)
+ gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
+ }
+
+ /* if we saw a global override before, get the right name */
+
+ if (gvp) {
+ sv = newSVpv("CORE::GLOBAL::",14);
+ sv_catpv(sv,PL_tokenbuf);
+ }
+ else
+ sv = newSVpv(PL_tokenbuf,0);
+
+ /* Presume this is going to be a bareword of some sort. */
+
+ CLINE;
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ yylval.opval->op_private = OPpCONST_BARE;
+
+ /* And if "Foo::", then that's what it certainly is. */
+
+ if (len)
+ goto safe_bareword;
+
+ /* See if it's the indirect object for a list operator. */
+
+ if (PL_oldoldbufptr &&
+ PL_oldoldbufptr < PL_bufptr &&
+ (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
+ /* NO SKIPSPACE BEFORE HERE! */
+ (PL_expect == XREF
+ || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
+ || (PL_last_lop_op == OP_ENTERSUB
+ && PL_last_proto
+ && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
+ {
+ bool immediate_paren = *s == '(';
+
+ /* (Now we can afford to cross potential line boundary.) */
+ s = skipspace(s);
+
+ /* Two barewords in a row may indicate method call. */
+
+ if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
+ return tmp;
+
+ /* If not a declared subroutine, it's an indirect object. */
+ /* (But it's an indir obj regardless for sort.) */
+
+ if ((PL_last_lop_op == OP_SORT ||
+ (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
+ (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
+ PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
+ goto bareword;
+ }
+ }
+
+ /* If followed by a paren, it's certainly a subroutine. */
+
+ PL_expect = XOPERATOR;
+ s = skipspace(s);
+ if (*s == '(') {
+ CLINE;
+ if (gv && GvCVu(gv)) {
+ for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
+ if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
+ s = d + 1;
+ goto its_constant;
+ }
+ }
+ PL_nextval[PL_nexttoke].opval = yylval.opval;
+ PL_expect = XOPERATOR;
+ force_next(WORD);
+ yylval.ival = 0;
+ TOKEN('&');
+ }
+
+ /* If followed by var or block, call it a method (unless sub) */
+
+ if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
+ PL_last_lop = PL_oldbufptr;
+ PL_last_lop_op = OP_METHOD;
+ PREBLOCK(METHOD);
+ }
+
+ /* If followed by a bareword, see if it looks like indir obj. */
+
+ if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
+ return tmp;
+
+ /* Not a method, so call it a subroutine (if defined) */
+
+ if (gv && GvCVu(gv)) {
+ CV* cv;
+ if (lastchar == '-')
+ warn("Ambiguous use of -%s resolved as -&%s()",
+ PL_tokenbuf, PL_tokenbuf);
+ PL_last_lop = PL_oldbufptr;
+ PL_last_lop_op = OP_ENTERSUB;
+ /* Check for a constant sub */
+ cv = GvCV(gv);
+ if ((sv = cv_const_sv(cv))) {
+ its_constant:
+ SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
+ ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
+ yylval.opval->op_private = 0;
+ TOKEN(WORD);
+ }
+
+ /* Resolve to GV now. */
+ op_free(yylval.opval);
+ yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
+ /* Is there a prototype? */
+ if (SvPOK(cv)) {
+ STRLEN len;
+ PL_last_proto = SvPV((SV*)cv, len);
+ if (!len)
+ TERM(FUNC0SUB);
+ if (strEQ(PL_last_proto, "$"))
+ OPERATOR(UNIOPSUB);
+ if (*PL_last_proto == '&' && *s == '{') {
+ sv_setpv(PL_subname,"__ANON__");
+ PREBLOCK(LSTOPSUB);
+ }
+ } else
+ PL_last_proto = NULL;
+ PL_nextval[PL_nexttoke].opval = yylval.opval;
+ PL_expect = XTERM;
+ force_next(WORD);
+ TOKEN(NOAMP);
+ }
+
+ if (PL_hints & HINT_STRICT_SUBS &&
+ lastchar != '-' &&
+ strnNE(s,"->",2) &&
+ PL_last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
+ PL_last_lop_op != OP_ACCEPT &&
+ PL_last_lop_op != OP_PIPE_OP &&
+ PL_last_lop_op != OP_SOCKPAIR)
+ {
+ warn(
+ "Bareword \"%s\" not allowed while \"strict subs\" in use",
+ PL_tokenbuf);
+ ++PL_error_count;
+ }
+
+ /* Call it a bare word */
+
+ bareword:
+ if (PL_dowarn) {
+ if (lastchar != '-') {
+ for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
+ if (!*d)
+ warn(warn_reserved, PL_tokenbuf);
+ }
+ }
+
+ safe_bareword:
+ if (lastchar && strchr("*%&", lastchar)) {
+ warn("Operator or semicolon missing before %c%s",
+ lastchar, PL_tokenbuf);
+ warn("Ambiguous use of %c resolved as operator %c",
+ lastchar, lastchar);
+ }
+ TOKEN(WORD);
+ }
+
+ case KEY___FILE__:
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ newSVsv(GvSV(PL_curcop->cop_filegv)));
+ TERM(THING);
+
+ case KEY___LINE__:
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ newSVpvf("%ld", (long)PL_curcop->cop_line));
+ TERM(THING);
+
+ case KEY___PACKAGE__:
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ (PL_curstash
+ ? newSVsv(PL_curstname)
+ : &PL_sv_undef));
+ TERM(THING);
+
+ case KEY___DATA__:
+ case KEY___END__: {
+ GV *gv;
+
+ /*SUPPRESS 560*/
+ if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
+ char *pname = "main";
+ if (PL_tokenbuf[2] == 'D')
+ pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
+ gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
+ GvMULTI_on(gv);
+ if (!GvIO(gv))
+ GvIOp(gv) = newIO();
+ IoIFP(GvIOp(gv)) = PL_rsfp;
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+ {
+ int fd = PerlIO_fileno(PL_rsfp);
+ fcntl(fd,F_SETFD,fd >= 3);
+ }
+#endif
+ /* Mark this internal pseudo-handle as clean */
+ IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
+ if (PL_preprocess)
+ IoTYPE(GvIOp(gv)) = '|';
+ else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
+ IoTYPE(GvIOp(gv)) = '-';
+ else
+ IoTYPE(GvIOp(gv)) = '<';
+ PL_rsfp = Nullfp;
+ }
+ goto fake_eof;
+ }
+
+ case KEY_AUTOLOAD:
+ case KEY_DESTROY:
+ case KEY_BEGIN:
+ case KEY_END:
+ case KEY_INIT:
+ if (PL_expect == XSTATE) {
+ s = PL_bufptr;
+ goto really_sub;
+ }
+ goto just_a_word;
+
+ case KEY_CORE:
+ if (*s == ':' && s[1] == ':') {
+ s += 2;
+ d = s;
+ s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
+ tmp = keyword(PL_tokenbuf, len);
+ if (tmp < 0)
+ tmp = -tmp;
+ goto reserved_word;
+ }
+ goto just_a_word;
+
+ case KEY_abs:
+ UNI(OP_ABS);
+
+ case KEY_alarm:
+ UNI(OP_ALARM);
+
+ case KEY_accept:
+ LOP(OP_ACCEPT,XTERM);
+
+ case KEY_and:
+ OPERATOR(ANDOP);
+
+ case KEY_atan2:
+ LOP(OP_ATAN2,XTERM);
+
+ case KEY_bind:
+ LOP(OP_BIND,XTERM);
+
+ case KEY_binmode:
+ UNI(OP_BINMODE);
+
+ case KEY_bless:
+ LOP(OP_BLESS,XTERM);
+
+ case KEY_chop:
+ UNI(OP_CHOP);
+
+ case KEY_continue:
+ PREBLOCK(CONTINUE);
+
+ case KEY_chdir:
+ (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
+ UNI(OP_CHDIR);
+
+ case KEY_close:
+ UNI(OP_CLOSE);
+
+ case KEY_closedir:
+ UNI(OP_CLOSEDIR);
+
+ case KEY_cmp:
+ Eop(OP_SCMP);
+
+ case KEY_caller:
+ UNI(OP_CALLER);
+
+ case KEY_crypt:
+#ifdef FCRYPT
+ if (!PL_cryptseen++)
+ init_des();
+#endif
+ LOP(OP_CRYPT,XTERM);
+
+ case KEY_chmod:
+ if (PL_dowarn) {
+ for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
+ if (*d != '0' && isDIGIT(*d))
+ yywarn("chmod: mode argument is missing initial 0");
+ }
+ LOP(OP_CHMOD,XTERM);
+
+ case KEY_chown:
+ LOP(OP_CHOWN,XTERM);
+
+ case KEY_connect:
+ LOP(OP_CONNECT,XTERM);
+
+ case KEY_chr:
+ UNI(OP_CHR);
+
+ case KEY_cos:
+ UNI(OP_COS);
+
+ case KEY_chroot:
+ UNI(OP_CHROOT);
+
+ case KEY_do:
+ s = skipspace(s);
+ if (*s == '{')
+ PRETERMBLOCK(DO);
+ if (*s != '\'')
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ OPERATOR(DO);
+
+ case KEY_die:
+ PL_hints |= HINT_BLOCK_SCOPE;
+ LOP(OP_DIE,XTERM);
+
+ case KEY_defined:
+ UNI(OP_DEFINED);
+
+ case KEY_delete:
+ UNI(OP_DELETE);
+
+ case KEY_dbmopen:
+ gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
+ LOP(OP_DBMOPEN,XTERM);
+
+ case KEY_dbmclose:
+ UNI(OP_DBMCLOSE);
+
+ case KEY_dump:
+ s = force_word(s,WORD,TRUE,FALSE,FALSE);
+ LOOPX(OP_DUMP);
+
+ case KEY_else:
+ PREBLOCK(ELSE);
+
+ case KEY_elsif:
+ yylval.ival = PL_curcop->cop_line;
+ OPERATOR(ELSIF);
+
+ case KEY_eq:
+ Eop(OP_SEQ);
+
+ case KEY_exists:
+ UNI(OP_EXISTS);
+
+ case KEY_exit:
+ UNI(OP_EXIT);
+
+ case KEY_eval:
+ s = skipspace(s);
+ PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
+ UNIBRACK(OP_ENTEREVAL);
+
+ case KEY_eof:
+ UNI(OP_EOF);
+
+ case KEY_exp:
+ UNI(OP_EXP);
+
+ case KEY_each:
+ UNI(OP_EACH);
+
+ case KEY_exec:
+ set_csh();
+ LOP(OP_EXEC,XREF);
+
+ case KEY_endhostent:
+ FUN0(OP_EHOSTENT);
+
+ case KEY_endnetent:
+ FUN0(OP_ENETENT);
+
+ case KEY_endservent:
+ FUN0(OP_ESERVENT);
+
+ case KEY_endprotoent:
+ FUN0(OP_EPROTOENT);
+
+ case KEY_endpwent:
+ FUN0(OP_EPWENT);
+
+ case KEY_endgrent:
+ FUN0(OP_EGRENT);
+
+ case KEY_for:
+ case KEY_foreach:
+ yylval.ival = PL_curcop->cop_line;
+ s = skipspace(s);
+ if (PL_expect == XSTATE && isIDFIRST(*s)) {
+ char *p = s;
+ if ((PL_bufend - p) >= 3 &&
+ strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
+ p += 2;
+ p = skipspace(p);
+ if (isIDFIRST(*p))
+ croak("Missing $ on loop variable");
+ }
+ OPERATOR(FOR);
+
+ case KEY_formline:
+ LOP(OP_FORMLINE,XTERM);
+
+ case KEY_fork:
+ FUN0(OP_FORK);
+
+ case KEY_fcntl:
+ LOP(OP_FCNTL,XTERM);
+
+ case KEY_fileno:
+ UNI(OP_FILENO);
+
+ case KEY_flock:
+ LOP(OP_FLOCK,XTERM);
+
+ case KEY_gt:
+ Rop(OP_SGT);
+
+ case KEY_ge:
+ Rop(OP_SGE);
+
+ case KEY_grep:
+ LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
+
+ case KEY_goto:
+ s = force_word(s,WORD,TRUE,FALSE,FALSE);
+ LOOPX(OP_GOTO);
+
+ case KEY_gmtime:
+ UNI(OP_GMTIME);
+
+ case KEY_getc:
+ UNI(OP_GETC);
+
+ case KEY_getppid:
+ FUN0(OP_GETPPID);
+
+ case KEY_getpgrp:
+ UNI(OP_GETPGRP);
+
+ case KEY_getpriority:
+ LOP(OP_GETPRIORITY,XTERM);
+
+ case KEY_getprotobyname:
+ UNI(OP_GPBYNAME);
+
+ case KEY_getprotobynumber:
+ LOP(OP_GPBYNUMBER,XTERM);
+
+ case KEY_getprotoent:
+ FUN0(OP_GPROTOENT);
+
+ case KEY_getpwent:
+ FUN0(OP_GPWENT);
+
+ case KEY_getpwnam:
+ UNI(OP_GPWNAM);
+
+ case KEY_getpwuid:
+ UNI(OP_GPWUID);
+
+ case KEY_getpeername:
+ UNI(OP_GETPEERNAME);
+
+ case KEY_gethostbyname:
+ UNI(OP_GHBYNAME);
+
+ case KEY_gethostbyaddr:
+ LOP(OP_GHBYADDR,XTERM);
+
+ case KEY_gethostent:
+ FUN0(OP_GHOSTENT);
+
+ case KEY_getnetbyname:
+ UNI(OP_GNBYNAME);
+
+ case KEY_getnetbyaddr:
+ LOP(OP_GNBYADDR,XTERM);
+
+ case KEY_getnetent:
+ FUN0(OP_GNETENT);
+
+ case KEY_getservbyname:
+ LOP(OP_GSBYNAME,XTERM);
+
+ case KEY_getservbyport:
+ LOP(OP_GSBYPORT,XTERM);
+
+ case KEY_getservent:
+ FUN0(OP_GSERVENT);
+
+ case KEY_getsockname:
+ UNI(OP_GETSOCKNAME);
+
+ case KEY_getsockopt:
+ LOP(OP_GSOCKOPT,XTERM);
+
+ case KEY_getgrent:
+ FUN0(OP_GGRENT);
+
+ case KEY_getgrnam:
+ UNI(OP_GGRNAM);
+
+ case KEY_getgrgid:
+ UNI(OP_GGRGID);
+
+ case KEY_getlogin:
+ FUN0(OP_GETLOGIN);
+
+ case KEY_glob:
+ set_csh();
+ LOP(OP_GLOB,XTERM);
+
+ case KEY_hex:
+ UNI(OP_HEX);
+
+ case KEY_if:
+ yylval.ival = PL_curcop->cop_line;
+ OPERATOR(IF);
+
+ case KEY_index:
+ LOP(OP_INDEX,XTERM);
+
+ case KEY_int:
+ UNI(OP_INT);
+
+ case KEY_ioctl:
+ LOP(OP_IOCTL,XTERM);
+
+ case KEY_join:
+ LOP(OP_JOIN,XTERM);
+
+ case KEY_keys:
+ UNI(OP_KEYS);
+
+ case KEY_kill:
+ LOP(OP_KILL,XTERM);
+
+ case KEY_last:
+ s = force_word(s,WORD,TRUE,FALSE,FALSE);
+ LOOPX(OP_LAST);
+
+ case KEY_lc:
+ UNI(OP_LC);
+
+ case KEY_lcfirst:
+ UNI(OP_LCFIRST);
+
+ case KEY_local:
+ OPERATOR(LOCAL);
+
+ case KEY_length:
+ UNI(OP_LENGTH);
+
+ case KEY_lt:
+ Rop(OP_SLT);
+
+ case KEY_le:
+ Rop(OP_SLE);
+
+ case KEY_localtime:
+ UNI(OP_LOCALTIME);
+
+ case KEY_log:
+ UNI(OP_LOG);
+
+ case KEY_link:
+ LOP(OP_LINK,XTERM);
+
+ case KEY_listen:
+ LOP(OP_LISTEN,XTERM);
+
+ case KEY_lock:
+ UNI(OP_LOCK);
+
+ case KEY_lstat:
+ UNI(OP_LSTAT);
+
+ case KEY_m:
+ s = scan_pat(s,OP_MATCH);
+ TERM(sublex_start());
+
+ case KEY_map:
+ LOP(OP_MAPSTART,XREF);
+
+ case KEY_mkdir:
+ LOP(OP_MKDIR,XTERM);
+
+ case KEY_msgctl:
+ LOP(OP_MSGCTL,XTERM);
+
+ case KEY_msgget:
+ LOP(OP_MSGGET,XTERM);
+
+ case KEY_msgrcv:
+ LOP(OP_MSGRCV,XTERM);
+
+ case KEY_msgsnd:
+ LOP(OP_MSGSND,XTERM);
+
+ case KEY_my:
+ PL_in_my = TRUE;
+ s = skipspace(s);
+ if (isIDFIRST(*s)) {
+ s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
+ PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
+ if (!PL_in_my_stash) {
+ char tmpbuf[1024];
+ PL_bufptr = s;
+ sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
+ yyerror(tmpbuf);
+ }
+ }
+ OPERATOR(MY);
+
+ case KEY_next:
+ s = force_word(s,WORD,TRUE,FALSE,FALSE);
+ LOOPX(OP_NEXT);
+
+ case KEY_ne:
+ Eop(OP_SNE);
+
+ case KEY_no:
+ if (PL_expect != XSTATE)
+ yyerror("\"no\" not allowed in expression");
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s);
+ yylval.ival = 0;
+ OPERATOR(USE);
+
+ case KEY_not:
+ OPERATOR(NOTOP);
+
+ case KEY_open:
+ s = skipspace(s);
+ if (isIDFIRST(*s)) {
+ char *t;
+ for (d = s; isALNUM(*d); d++) ;
+ t = skipspace(d);
+ if (strchr("|&*+-=!?:.", *t))
+ warn("Precedence problem: open %.*s should be open(%.*s)",
+ d-s,s, d-s,s);
+ }
+ LOP(OP_OPEN,XTERM);
+
+ case KEY_or:
+ yylval.ival = OP_OR;
+ OPERATOR(OROP);
+
+ case KEY_ord:
+ UNI(OP_ORD);
+
+ case KEY_oct:
+ UNI(OP_OCT);
+
+ case KEY_opendir:
+ LOP(OP_OPEN_DIR,XTERM);
+
+ case KEY_print:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_PRINT,XREF);
+
+ case KEY_printf:
+ checkcomma(s,PL_tokenbuf,"filehandle");
+ LOP(OP_PRTF,XREF);
+
+ case KEY_prototype:
+ UNI(OP_PROTOTYPE);
+
+ case KEY_push:
+ LOP(OP_PUSH,XTERM);
+
+ case KEY_pop:
+ UNI(OP_POP);
+
+ case KEY_pos:
+ UNI(OP_POS);
+
+ case KEY_pack:
+ LOP(OP_PACK,XTERM);
+
+ case KEY_package:
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ OPERATOR(PACKAGE);
+
+ case KEY_pipe:
+ LOP(OP_PIPE_OP,XTERM);
+
+ case KEY_q:
+ s = scan_str(s);
+ if (!s)
+ missingterm((char*)0);
+ yylval.ival = OP_CONST;
+ TERM(sublex_start());
+
+ case KEY_quotemeta:
+ UNI(OP_QUOTEMETA);
+
+ case KEY_qw:
+ s = scan_str(s);
+ if (!s)
+ missingterm((char*)0);
+ if (PL_dowarn && SvLEN(PL_lex_stuff)) {
+ d = SvPV_force(PL_lex_stuff, len);
+ for (; len; --len, ++d) {
+ if (*d == ',') {
+ warn("Possible attempt to separate words with commas");
+ break;
+ }
+ if (*d == '#') {
+ warn("Possible attempt to put comments in qw() list");
+ break;
+ }
+ }
+ }
+ force_next(')');
+ PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
+ PL_lex_stuff = Nullsv;
+ force_next(THING);
+ force_next(',');
+ PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
+ force_next(THING);
+ force_next('(');
+ yylval.ival = OP_SPLIT;
+ CLINE;
+ PL_expect = XTERM;
+ PL_bufptr = s;
+ PL_last_lop = PL_oldbufptr;
+ PL_last_lop_op = OP_SPLIT;
+ return FUNC;
+
+ case KEY_qq:
+ s = scan_str(s);
+ if (!s)
+ missingterm((char*)0);
+ yylval.ival = OP_STRINGIFY;
+ if (SvIVX(PL_lex_stuff) == '\'')
+ SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
+ TERM(sublex_start());
+
+ case KEY_qr:
+ s = scan_pat(s,OP_QR);
+ TERM(sublex_start());
+
+ case KEY_qx:
+ s = scan_str(s);
+ if (!s)
+ missingterm((char*)0);
+ yylval.ival = OP_BACKTICK;
+ set_csh();
+ TERM(sublex_start());
+
+ case KEY_return:
+ OLDLOP(OP_RETURN);
+
+ case KEY_require:
+ *PL_tokenbuf = '\0';
+ s = force_word(s,WORD,TRUE,TRUE,FALSE);
+ if (isIDFIRST(*PL_tokenbuf))
+ gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
+ else if (*s == '<')
+ yyerror("<> should be quotes");
+ UNI(OP_REQUIRE);
+
+ case KEY_reset:
+ UNI(OP_RESET);
+
+ case KEY_redo:
+ s = force_word(s,WORD,TRUE,FALSE,FALSE);
+ LOOPX(OP_REDO);
+
+ case KEY_rename:
+ LOP(OP_RENAME,XTERM);
+
+ case KEY_rand:
+ UNI(OP_RAND);
+
+ case KEY_rmdir:
+ UNI(OP_RMDIR);
+
+ case KEY_rindex:
+ LOP(OP_RINDEX,XTERM);
+
+ case KEY_read:
+ LOP(OP_READ,XTERM);
+
+ case KEY_readdir:
+ UNI(OP_READDIR);
+
+ case KEY_readline:
+ set_csh();
+ UNI(OP_READLINE);
+
+ case KEY_readpipe:
+ set_csh();
+ UNI(OP_BACKTICK);
+
+ case KEY_rewinddir:
+ UNI(OP_REWINDDIR);
+
+ case KEY_recv:
+ LOP(OP_RECV,XTERM);
+
+ case KEY_reverse:
+ LOP(OP_REVERSE,XTERM);
+
+ case KEY_readlink:
+ UNI(OP_READLINK);
+
+ case KEY_ref:
+ UNI(OP_REF);
+
+ case KEY_s:
+ s = scan_subst(s);
+ if (yylval.opval)
+ TERM(sublex_start());
+ else
+ TOKEN(1); /* force error */
+
+ case KEY_chomp:
+ UNI(OP_CHOMP);
+
+ case KEY_scalar:
+ UNI(OP_SCALAR);
+
+ case KEY_select:
+ LOP(OP_SELECT,XTERM);
+
+ case KEY_seek:
+ LOP(OP_SEEK,XTERM);
+
+ case KEY_semctl:
+ LOP(OP_SEMCTL,XTERM);
+
+ case KEY_semget:
+ LOP(OP_SEMGET,XTERM);
+
+ case KEY_semop:
+ LOP(OP_SEMOP,XTERM);
+
+ case KEY_send:
+ LOP(OP_SEND,XTERM);
+
+ case KEY_setpgrp:
+ LOP(OP_SETPGRP,XTERM);
+
+ case KEY_setpriority:
+ LOP(OP_SETPRIORITY,XTERM);
+
+ case KEY_sethostent:
+ UNI(OP_SHOSTENT);
+
+ case KEY_setnetent:
+ UNI(OP_SNETENT);
+
+ case KEY_setservent:
+ UNI(OP_SSERVENT);
+
+ case KEY_setprotoent:
+ UNI(OP_SPROTOENT);
+
+ case KEY_setpwent:
+ FUN0(OP_SPWENT);
+
+ case KEY_setgrent:
+ FUN0(OP_SGRENT);
+
+ case KEY_seekdir:
+ LOP(OP_SEEKDIR,XTERM);
+
+ case KEY_setsockopt:
+ LOP(OP_SSOCKOPT,XTERM);
+
+ case KEY_shift:
+ UNI(OP_SHIFT);
+
+ case KEY_shmctl:
+ LOP(OP_SHMCTL,XTERM);
+
+ case KEY_shmget:
+ LOP(OP_SHMGET,XTERM);
+
+ case KEY_shmread:
+ LOP(OP_SHMREAD,XTERM);
+
+ case KEY_shmwrite:
+ LOP(OP_SHMWRITE,XTERM);
+
+ case KEY_shutdown:
+ LOP(OP_SHUTDOWN,XTERM);
+
+ case KEY_sin:
+ UNI(OP_SIN);
+
+ case KEY_sleep:
+ UNI(OP_SLEEP);
+
+ case KEY_socket:
+ LOP(OP_SOCKET,XTERM);
+
+ case KEY_socketpair:
+ LOP(OP_SOCKPAIR,XTERM);
+
+ case KEY_sort:
+ checkcomma(s,PL_tokenbuf,"subroutine name");
+ s = skipspace(s);
+ if (*s == ';' || *s == ')') /* probably a close */
+ croak("sort is now a reserved word");
+ PL_expect = XTERM;
+ s = force_word(s,WORD,TRUE,TRUE,FALSE);
+ LOP(OP_SORT,XREF);
+
+ case KEY_split:
+ LOP(OP_SPLIT,XTERM);
+
+ case KEY_sprintf:
+ LOP(OP_SPRINTF,XTERM);
+
+ case KEY_splice:
+ LOP(OP_SPLICE,XTERM);
+
+ case KEY_sqrt:
+ UNI(OP_SQRT);
+
+ case KEY_srand:
+ UNI(OP_SRAND);
+
+ case KEY_stat:
+ UNI(OP_STAT);
+
+ case KEY_study:
+ PL_sawstudy++;
+ UNI(OP_STUDY);
+
+ case KEY_substr:
+ LOP(OP_SUBSTR,XTERM);
+
+ case KEY_format:
+ case KEY_sub:
+ really_sub:
+ s = skipspace(s);
+
+ if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
+ char tmpbuf[sizeof PL_tokenbuf];
+ PL_expect = XBLOCK;
+ d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
+ if (strchr(tmpbuf, ':'))
+ sv_setpv(PL_subname, tmpbuf);
+ else {
+ sv_setsv(PL_subname,PL_curstname);
+ sv_catpvn(PL_subname,"::",2);
+ sv_catpvn(PL_subname,tmpbuf,len);
+ }
+ s = force_word(s,WORD,FALSE,TRUE,TRUE);
+ s = skipspace(s);
+ }
+ else {
+ PL_expect = XTERMBLOCK;
+ sv_setpv(PL_subname,"?");
+ }
+
+ if (tmp == KEY_format) {
+ s = skipspace(s);
+ if (*s == '=')
+ PL_lex_formbrack = PL_lex_brackets + 1;
+ OPERATOR(FORMAT);
+ }
+
+ /* Look for a prototype */
+ if (*s == '(') {
+ char *p;
+
+ s = scan_str(s);
+ if (!s) {
+ if (PL_lex_stuff)
+ SvREFCNT_dec(PL_lex_stuff);
+ PL_lex_stuff = Nullsv;
+ croak("Prototype not terminated");
+ }
+ /* strip spaces */
+ d = SvPVX(PL_lex_stuff);
+ tmp = 0;
+ for (p = d; *p; ++p) {
+ if (!isSPACE(*p))
+ d[tmp++] = *p;
+ }
+ d[tmp] = '\0';
+ SvCUR(PL_lex_stuff) = tmp;
+
+ PL_nexttoke++;
+ PL_nextval[1] = PL_nextval[0];
+ PL_nexttype[1] = PL_nexttype[0];
+ PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
+ PL_nexttype[0] = THING;
+ if (PL_nexttoke == 1) {
+ PL_lex_defer = PL_lex_state;
+ PL_lex_expect = PL_expect;
+ PL_lex_state = LEX_KNOWNEXT;
+ }
+ PL_lex_stuff = Nullsv;
+ }
+
+ if (*SvPV(PL_subname,PL_na) == '?') {
+ sv_setpv(PL_subname,"__ANON__");
+ TOKEN(ANONSUB);
+ }
+ PREBLOCK(SUB);
+
+ case KEY_system:
+ set_csh();
+ LOP(OP_SYSTEM,XREF);
+
+ case KEY_symlink:
+ LOP(OP_SYMLINK,XTERM);
+
+ case KEY_syscall:
+ LOP(OP_SYSCALL,XTERM);
+
+ case KEY_sysopen:
+ LOP(OP_SYSOPEN,XTERM);
+
+ case KEY_sysseek:
+ LOP(OP_SYSSEEK,XTERM);
+
+ case KEY_sysread:
+ LOP(OP_SYSREAD,XTERM);
+
+ case KEY_syswrite:
+ LOP(OP_SYSWRITE,XTERM);
+
+ case KEY_tr:
+ s = scan_trans(s);
+ TERM(sublex_start());
+
+ case KEY_tell:
+ UNI(OP_TELL);
+
+ case KEY_telldir:
+ UNI(OP_TELLDIR);
+
+ case KEY_tie:
+ LOP(OP_TIE,XTERM);
+
+ case KEY_tied:
+ UNI(OP_TIED);
+
+ case KEY_time:
+ FUN0(OP_TIME);
+
+ case KEY_times:
+ FUN0(OP_TMS);
+
+ case KEY_truncate:
+ LOP(OP_TRUNCATE,XTERM);
+
+ case KEY_uc:
+ UNI(OP_UC);
+
+ case KEY_ucfirst:
+ UNI(OP_UCFIRST);
+
+ case KEY_untie:
+ UNI(OP_UNTIE);
+
+ case KEY_until:
+ yylval.ival = PL_curcop->cop_line;
+ OPERATOR(UNTIL);
+
+ case KEY_unless:
+ yylval.ival = PL_curcop->cop_line;
+ OPERATOR(UNLESS);
+
+ case KEY_unlink:
+ LOP(OP_UNLINK,XTERM);
+
+ case KEY_undef:
+ UNI(OP_UNDEF);
+
+ case KEY_unpack:
+ LOP(OP_UNPACK,XTERM);
+
+ case KEY_utime:
+ LOP(OP_UTIME,XTERM);
+
+ case KEY_umask:
+ if (PL_dowarn) {
+ for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
+ if (*d != '0' && isDIGIT(*d))
+ yywarn("umask: argument is missing initial 0");
+ }
+ UNI(OP_UMASK);
+
+ case KEY_unshift:
+ LOP(OP_UNSHIFT,XTERM);
+
+ case KEY_use:
+ if (PL_expect != XSTATE)
+ yyerror("\"use\" not allowed in expression");
+ s = skipspace(s);
+ if(isDIGIT(*s)) {
+ s = force_version(s);
+ if(*s == ';' || (s = skipspace(s), *s == ';')) {
+ PL_nextval[PL_nexttoke].opval = Nullop;
+ force_next(WORD);
+ }
+ }
+ else {
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s);
+ }
+ yylval.ival = 1;
+ OPERATOR(USE);
+
+ case KEY_values:
+ UNI(OP_VALUES);
+
+ case KEY_vec:
+ PL_sawvec = TRUE;
+ LOP(OP_VEC,XTERM);
+
+ case KEY_while:
+ yylval.ival = PL_curcop->cop_line;
+ OPERATOR(WHILE);
+
+ case KEY_warn:
+ PL_hints |= HINT_BLOCK_SCOPE;
+ LOP(OP_WARN,XTERM);
+
+ case KEY_wait:
+ FUN0(OP_WAIT);
+
+ case KEY_waitpid:
+ LOP(OP_WAITPID,XTERM);
+
+ case KEY_wantarray:
+ FUN0(OP_WANTARRAY);
+
+ case KEY_write:
+#ifdef EBCDIC
+ {
+ static char ctl_l[2];
+
+ if (ctl_l[0] == '\0')
+ ctl_l[0] = toCTRL('L');
+ gv_fetchpv(ctl_l,TRUE, SVt_PV);
+ }
+#else
+ gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
+#endif
+ UNI(OP_ENTERWRITE);
+
+ case KEY_x:
+ if (PL_expect == XOPERATOR)
+ Mop(OP_REPEAT);
+ check_uni();
+ goto just_a_word;
+
+ case KEY_xor:
+ yylval.ival = OP_XOR;
+ OPERATOR(OROP);
+
+ case KEY_y:
+ s = scan_trans(s);
+ TERM(sublex_start());
+ }
+ }}
+}
+
+I32
+keyword(register char *d, I32 len)
+{
+ switch (*d) {
+ case '_':
+ if (d[1] == '_') {
+ if (strEQ(d,"__FILE__")) return -KEY___FILE__;
+ if (strEQ(d,"__LINE__")) return -KEY___LINE__;
+ if (strEQ(d,"__PACKAGE__")) return -KEY___PACKAGE__;
+ if (strEQ(d,"__DATA__")) return KEY___DATA__;
+ if (strEQ(d,"__END__")) return KEY___END__;
+ }
+ break;
+ case 'A':
+ if (strEQ(d,"AUTOLOAD")) return KEY_AUTOLOAD;
+ break;
+ case 'a':
+ switch (len) {
+ case 3:
+ if (strEQ(d,"and")) return -KEY_and;
+ if (strEQ(d,"abs")) return -KEY_abs;
+ break;
+ case 5:
+ if (strEQ(d,"alarm")) return -KEY_alarm;
+ if (strEQ(d,"atan2")) return -KEY_atan2;
+ break;
+ case 6:
+ if (strEQ(d,"accept")) return -KEY_accept;
+ break;
+ }
+ break;
+ case 'B':
+ if (strEQ(d,"BEGIN")) return KEY_BEGIN;
+ break;
+ case 'b':
+ if (strEQ(d,"bless")) return -KEY_bless;
+ if (strEQ(d,"bind")) return -KEY_bind;
+ if (strEQ(d,"binmode")) return -KEY_binmode;
+ break;
+ case 'C':
+ if (strEQ(d,"CORE")) return -KEY_CORE;
+ break;
+ case 'c':
+ switch (len) {
+ case 3:
+ if (strEQ(d,"cmp")) return -KEY_cmp;
+ if (strEQ(d,"chr")) return -KEY_chr;
+ if (strEQ(d,"cos")) return -KEY_cos;
+ break;
+ case 4:
+ if (strEQ(d,"chop")) return KEY_chop;
+ break;
+ case 5:
+ if (strEQ(d,"close")) return -KEY_close;
+ if (strEQ(d,"chdir")) return -KEY_chdir;
+ if (strEQ(d,"chomp")) return KEY_chomp;
+ if (strEQ(d,"chmod")) return -KEY_chmod;
+ if (strEQ(d,"chown")) return -KEY_chown;
+ if (strEQ(d,"crypt")) return -KEY_crypt;
+ break;
+ case 6:
+ if (strEQ(d,"chroot")) return -KEY_chroot;
+ if (strEQ(d,"caller")) return -KEY_caller;
+ break;
+ case 7:
+ if (strEQ(d,"connect")) return -KEY_connect;
+ break;
+ case 8:
+ if (strEQ(d,"closedir")) return -KEY_closedir;
+ if (strEQ(d,"continue")) return -KEY_continue;
+ break;
+ }
+ break;
+ case 'D':
+ if (strEQ(d,"DESTROY")) return KEY_DESTROY;
+ break;
+ case 'd':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"do")) return KEY_do;
+ break;
+ case 3:
+ if (strEQ(d,"die")) return -KEY_die;
+ break;
+ case 4:
+ if (strEQ(d,"dump")) return -KEY_dump;
+ break;
+ case 6:
+ if (strEQ(d,"delete")) return KEY_delete;
+ break;
+ case 7:
+ if (strEQ(d,"defined")) return KEY_defined;
+ if (strEQ(d,"dbmopen")) return -KEY_dbmopen;
+ break;
+ case 8:
+ if (strEQ(d,"dbmclose")) return -KEY_dbmclose;
+ break;
+ }
+ break;
+ case 'E':
+ if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;}
+ if (strEQ(d,"END")) return KEY_END;
+ break;
+ case 'e':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"eq")) return -KEY_eq;
+ break;
+ case 3:
+ if (strEQ(d,"eof")) return -KEY_eof;
+ if (strEQ(d,"exp")) return -KEY_exp;
+ break;
+ case 4:
+ if (strEQ(d,"else")) return KEY_else;
+ if (strEQ(d,"exit")) return -KEY_exit;
+ if (strEQ(d,"eval")) return KEY_eval;
+ if (strEQ(d,"exec")) return -KEY_exec;
+ if (strEQ(d,"each")) return KEY_each;
+ break;
+ case 5:
+ if (strEQ(d,"elsif")) return KEY_elsif;
+ break;
+ case 6:
+ if (strEQ(d,"exists")) return KEY_exists;
+ if (strEQ(d,"elseif")) warn("elseif should be elsif");
+ break;
+ case 8:
+ if (strEQ(d,"endgrent")) return -KEY_endgrent;
+ if (strEQ(d,"endpwent")) return -KEY_endpwent;
+ break;
+ case 9:
+ if (strEQ(d,"endnetent")) return -KEY_endnetent;
+ break;
+ case 10:
+ if (strEQ(d,"endhostent")) return -KEY_endhostent;
+ if (strEQ(d,"endservent")) return -KEY_endservent;
+ break;
+ case 11:
+ if (strEQ(d,"endprotoent")) return -KEY_endprotoent;
+ break;
+ }
+ break;
+ case 'f':
+ switch (len) {
+ case 3:
+ if (strEQ(d,"for")) return KEY_for;
+ break;
+ case 4:
+ if (strEQ(d,"fork")) return -KEY_fork;
+ break;
+ case 5:
+ if (strEQ(d,"fcntl")) return -KEY_fcntl;
+ if (strEQ(d,"flock")) return -KEY_flock;
+ break;
+ case 6:
+ if (strEQ(d,"format")) return KEY_format;
+ if (strEQ(d,"fileno")) return -KEY_fileno;
+ break;
+ case 7:
+ if (strEQ(d,"foreach")) return KEY_foreach;
+ break;
+ case 8:
+ if (strEQ(d,"formline")) return -KEY_formline;
+ break;
+ }
+ break;
+ case 'G':
+ if (len == 2) {
+ if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;}
+ if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;}
+ }
+ break;
+ case 'g':
+ if (strnEQ(d,"get",3)) {
+ d += 3;
+ if (*d == 'p') {
+ switch (len) {
+ case 7:
+ if (strEQ(d,"ppid")) return -KEY_getppid;
+ if (strEQ(d,"pgrp")) return -KEY_getpgrp;
+ break;
+ case 8:
+ if (strEQ(d,"pwent")) return -KEY_getpwent;
+ if (strEQ(d,"pwnam")) return -KEY_getpwnam;
+ if (strEQ(d,"pwuid")) return -KEY_getpwuid;
+ break;
+ case 11:
+ if (strEQ(d,"peername")) return -KEY_getpeername;
+ if (strEQ(d,"protoent")) return -KEY_getprotoent;
+ if (strEQ(d,"priority")) return -KEY_getpriority;
+ break;
+ case 14:
+ if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
+ break;
+ case 16:
+ if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
+ break;
+ }
+ }
+ else if (*d == 'h') {
+ if (strEQ(d,"hostbyname")) return -KEY_gethostbyname;
+ if (strEQ(d,"hostbyaddr")) return -KEY_gethostbyaddr;
+ if (strEQ(d,"hostent")) return -KEY_gethostent;
+ }
+ else if (*d == 'n') {
+ if (strEQ(d,"netbyname")) return -KEY_getnetbyname;
+ if (strEQ(d,"netbyaddr")) return -KEY_getnetbyaddr;
+ if (strEQ(d,"netent")) return -KEY_getnetent;
+ }
+ else if (*d == 's') {
+ if (strEQ(d,"servbyname")) return -KEY_getservbyname;
+ if (strEQ(d,"servbyport")) return -KEY_getservbyport;
+ if (strEQ(d,"servent")) return -KEY_getservent;
+ if (strEQ(d,"sockname")) return -KEY_getsockname;
+ if (strEQ(d,"sockopt")) return -KEY_getsockopt;
+ }
+ else if (*d == 'g') {
+ if (strEQ(d,"grent")) return -KEY_getgrent;
+ if (strEQ(d,"grnam")) return -KEY_getgrnam;
+ if (strEQ(d,"grgid")) return -KEY_getgrgid;
+ }
+ else if (*d == 'l') {
+ if (strEQ(d,"login")) return -KEY_getlogin;
+ }
+ else if (strEQ(d,"c")) return -KEY_getc;
+ break;
+ }
+ switch (len) {
+ case 2:
+ if (strEQ(d,"gt")) return -KEY_gt;
+ if (strEQ(d,"ge")) return -KEY_ge;
+ break;
+ case 4:
+ if (strEQ(d,"grep")) return KEY_grep;
+ if (strEQ(d,"goto")) return KEY_goto;
+ if (strEQ(d,"glob")) return KEY_glob;
+ break;
+ case 6:
+ if (strEQ(d,"gmtime")) return -KEY_gmtime;
+ break;
+ }
+ break;
+ case 'h':
+ if (strEQ(d,"hex")) return -KEY_hex;
+ break;
+ case 'I':
+ if (strEQ(d,"INIT")) return KEY_INIT;
+ break;
+ case 'i':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"if")) return KEY_if;
+ break;
+ case 3:
+ if (strEQ(d,"int")) return -KEY_int;
+ break;
+ case 5:
+ if (strEQ(d,"index")) return -KEY_index;
+ if (strEQ(d,"ioctl")) return -KEY_ioctl;
+ break;
+ }
+ break;
+ case 'j':
+ if (strEQ(d,"join")) return -KEY_join;
+ break;
+ case 'k':
+ if (len == 4) {
+ if (strEQ(d,"keys")) return KEY_keys;
+ if (strEQ(d,"kill")) return -KEY_kill;
+ }
+ break;
+ case 'L':
+ if (len == 2) {
+ if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;}
+ if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;}
+ }
+ break;
+ case 'l':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"lt")) return -KEY_lt;
+ if (strEQ(d,"le")) return -KEY_le;
+ if (strEQ(d,"lc")) return -KEY_lc;
+ break;
+ case 3:
+ if (strEQ(d,"log")) return -KEY_log;
+ break;
+ case 4:
+ if (strEQ(d,"last")) return KEY_last;
+ if (strEQ(d,"link")) return -KEY_link;
+ if (strEQ(d,"lock")) return -KEY_lock;
+ break;
+ case 5:
+ if (strEQ(d,"local")) return KEY_local;
+ if (strEQ(d,"lstat")) return -KEY_lstat;
+ break;
+ case 6:
+ if (strEQ(d,"length")) return -KEY_length;
+ if (strEQ(d,"listen")) return -KEY_listen;
+ break;
+ case 7:
+ if (strEQ(d,"lcfirst")) return -KEY_lcfirst;
+ break;
+ case 9:
+ if (strEQ(d,"localtime")) return -KEY_localtime;
+ break;
+ }
+ break;
+ case 'm':
+ switch (len) {
+ case 1: return KEY_m;
+ case 2:
+ if (strEQ(d,"my")) return KEY_my;
+ break;
+ case 3:
+ if (strEQ(d,"map")) return KEY_map;
+ break;
+ case 5:
+ if (strEQ(d,"mkdir")) return -KEY_mkdir;
+ break;
+ case 6:
+ if (strEQ(d,"msgctl")) return -KEY_msgctl;
+ if (strEQ(d,"msgget")) return -KEY_msgget;
+ if (strEQ(d,"msgrcv")) return -KEY_msgrcv;
+ if (strEQ(d,"msgsnd")) return -KEY_msgsnd;
+ break;
+ }
+ break;
+ case 'N':
+ if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;}
+ break;
+ case 'n':
+ if (strEQ(d,"next")) return KEY_next;
+ if (strEQ(d,"ne")) return -KEY_ne;
+ if (strEQ(d,"not")) return -KEY_not;
+ if (strEQ(d,"no")) return KEY_no;
+ break;
+ case 'o':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"or")) return -KEY_or;
+ break;
+ case 3:
+ if (strEQ(d,"ord")) return -KEY_ord;
+ if (strEQ(d,"oct")) return -KEY_oct;
+ if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
+ return 0;}
+ break;
+ case 4:
+ if (strEQ(d,"open")) return -KEY_open;
+ break;
+ case 7:
+ if (strEQ(d,"opendir")) return -KEY_opendir;
+ break;
+ }
+ break;
+ case 'p':
+ switch (len) {
+ case 3:
+ if (strEQ(d,"pop")) return KEY_pop;
+ if (strEQ(d,"pos")) return KEY_pos;
+ break;
+ case 4:
+ if (strEQ(d,"push")) return KEY_push;
+ if (strEQ(d,"pack")) return -KEY_pack;
+ if (strEQ(d,"pipe")) return -KEY_pipe;
+ break;
+ case 5:
+ if (strEQ(d,"print")) return KEY_print;
+ break;
+ case 6:
+ if (strEQ(d,"printf")) return KEY_printf;
+ break;
+ case 7:
+ if (strEQ(d,"package")) return KEY_package;
+ break;
+ case 9:
+ if (strEQ(d,"prototype")) return KEY_prototype;
+ }
+ break;
+ case 'q':
+ if (len <= 2) {
+ if (strEQ(d,"q")) return KEY_q;
+ if (strEQ(d,"qr")) return KEY_qr;
+ if (strEQ(d,"qq")) return KEY_qq;
+ if (strEQ(d,"qw")) return KEY_qw;
+ if (strEQ(d,"qx")) return KEY_qx;
+ }
+ else if (strEQ(d,"quotemeta")) return -KEY_quotemeta;
+ break;
+ case 'r':
+ switch (len) {
+ case 3:
+ if (strEQ(d,"ref")) return -KEY_ref;
+ break;
+ case 4:
+ if (strEQ(d,"read")) return -KEY_read;
+ if (strEQ(d,"rand")) return -KEY_rand;
+ if (strEQ(d,"recv")) return -KEY_recv;
+ if (strEQ(d,"redo")) return KEY_redo;
+ break;
+ case 5:
+ if (strEQ(d,"rmdir")) return -KEY_rmdir;
+ if (strEQ(d,"reset")) return -KEY_reset;
+ break;
+ case 6:
+ if (strEQ(d,"return")) return KEY_return;
+ if (strEQ(d,"rename")) return -KEY_rename;
+ if (strEQ(d,"rindex")) return -KEY_rindex;
+ break;
+ case 7:
+ if (strEQ(d,"require")) return -KEY_require;
+ if (strEQ(d,"reverse")) return -KEY_reverse;
+ if (strEQ(d,"readdir")) return -KEY_readdir;
+ break;
+ case 8:
+ if (strEQ(d,"readlink")) return -KEY_readlink;
+ if (strEQ(d,"readline")) return -KEY_readline;
+ if (strEQ(d,"readpipe")) return -KEY_readpipe;
+ break;
+ case 9:
+ if (strEQ(d,"rewinddir")) return -KEY_rewinddir;
+ break;
+ }
+ break;
+ case 's':
+ switch (d[1]) {
+ case 0: return KEY_s;
+ case 'c':
+ if (strEQ(d,"scalar")) return KEY_scalar;
+ break;
+ case 'e':
+ switch (len) {
+ case 4:
+ if (strEQ(d,"seek")) return -KEY_seek;
+ if (strEQ(d,"send")) return -KEY_send;
+ break;
+ case 5:
+ if (strEQ(d,"semop")) return -KEY_semop;
+ break;
+ case 6:
+ if (strEQ(d,"select")) return -KEY_select;
+ if (strEQ(d,"semctl")) return -KEY_semctl;
+ if (strEQ(d,"semget")) return -KEY_semget;
+ break;
+ case 7:
+ if (strEQ(d,"setpgrp")) return -KEY_setpgrp;
+ if (strEQ(d,"seekdir")) return -KEY_seekdir;
+ break;
+ case 8:
+ if (strEQ(d,"setpwent")) return -KEY_setpwent;
+ if (strEQ(d,"setgrent")) return -KEY_setgrent;
+ break;
+ case 9:
+ if (strEQ(d,"setnetent")) return -KEY_setnetent;
+ break;
+ case 10:
+ if (strEQ(d,"setsockopt")) return -KEY_setsockopt;
+ if (strEQ(d,"sethostent")) return -KEY_sethostent;
+ if (strEQ(d,"setservent")) return -KEY_setservent;
+ break;
+ case 11:
+ if (strEQ(d,"setpriority")) return -KEY_setpriority;
+ if (strEQ(d,"setprotoent")) return -KEY_setprotoent;
+ break;
+ }
+ break;
+ case 'h':
+ switch (len) {
+ case 5:
+ if (strEQ(d,"shift")) return KEY_shift;
+ break;
+ case 6:
+ if (strEQ(d,"shmctl")) return -KEY_shmctl;
+ if (strEQ(d,"shmget")) return -KEY_shmget;
+ break;
+ case 7:
+ if (strEQ(d,"shmread")) return -KEY_shmread;
+ break;
+ case 8:
+ if (strEQ(d,"shmwrite")) return -KEY_shmwrite;
+ if (strEQ(d,"shutdown")) return -KEY_shutdown;
+ break;
+ }
+ break;
+ case 'i':
+ if (strEQ(d,"sin")) return -KEY_sin;
+ break;
+ case 'l':
+ if (strEQ(d,"sleep")) return -KEY_sleep;
+ break;
+ case 'o':
+ if (strEQ(d,"sort")) return KEY_sort;
+ if (strEQ(d,"socket")) return -KEY_socket;
+ if (strEQ(d,"socketpair")) return -KEY_socketpair;
+ break;
+ case 'p':
+ if (strEQ(d,"split")) return KEY_split;
+ if (strEQ(d,"sprintf")) return -KEY_sprintf;
+ if (strEQ(d,"splice")) return KEY_splice;
+ break;
+ case 'q':
+ if (strEQ(d,"sqrt")) return -KEY_sqrt;
+ break;
+ case 'r':
+ if (strEQ(d,"srand")) return -KEY_srand;
+ break;
+ case 't':
+ if (strEQ(d,"stat")) return -KEY_stat;
+ if (strEQ(d,"study")) return KEY_study;
+ break;
+ case 'u':
+ if (strEQ(d,"substr")) return -KEY_substr;
+ if (strEQ(d,"sub")) return KEY_sub;
+ break;
+ case 'y':
+ switch (len) {
+ case 6:
+ if (strEQ(d,"system")) return -KEY_system;
+ break;
+ case 7:
+ if (strEQ(d,"symlink")) return -KEY_symlink;
+ if (strEQ(d,"syscall")) return -KEY_syscall;
+ if (strEQ(d,"sysopen")) return -KEY_sysopen;
+ if (strEQ(d,"sysread")) return -KEY_sysread;
+ if (strEQ(d,"sysseek")) return -KEY_sysseek;
+ break;
+ case 8:
+ if (strEQ(d,"syswrite")) return -KEY_syswrite;
+ break;
+ }
+ break;
+ }
+ break;
+ case 't':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"tr")) return KEY_tr;
+ break;
+ case 3:
+ if (strEQ(d,"tie")) return KEY_tie;
+ break;
+ case 4:
+ if (strEQ(d,"tell")) return -KEY_tell;
+ if (strEQ(d,"tied")) return KEY_tied;
+ if (strEQ(d,"time")) return -KEY_time;
+ break;
+ case 5:
+ if (strEQ(d,"times")) return -KEY_times;
+ break;
+ case 7:
+ if (strEQ(d,"telldir")) return -KEY_telldir;
+ break;
+ case 8:
+ if (strEQ(d,"truncate")) return -KEY_truncate;
+ break;
+ }
+ break;
+ case 'u':
+ switch (len) {
+ case 2:
+ if (strEQ(d,"uc")) return -KEY_uc;
+ break;
+ case 3:
+ if (strEQ(d,"use")) return KEY_use;
+ break;
+ case 5:
+ if (strEQ(d,"undef")) return KEY_undef;
+ if (strEQ(d,"until")) return KEY_until;
+ if (strEQ(d,"untie")) return KEY_untie;
+ if (strEQ(d,"utime")) return -KEY_utime;
+ if (strEQ(d,"umask")) return -KEY_umask;
+ break;
+ case 6:
+ if (strEQ(d,"unless")) return KEY_unless;
+ if (strEQ(d,"unpack")) return -KEY_unpack;
+ if (strEQ(d,"unlink")) return -KEY_unlink;
+ break;
+ case 7:
+ if (strEQ(d,"unshift")) return KEY_unshift;
+ if (strEQ(d,"ucfirst")) return -KEY_ucfirst;
+ break;
+ }
+ break;
+ case 'v':
+ if (strEQ(d,"values")) return -KEY_values;
+ if (strEQ(d,"vec")) return -KEY_vec;
+ break;
+ case 'w':
+ switch (len) {
+ case 4:
+ if (strEQ(d,"warn")) return -KEY_warn;
+ if (strEQ(d,"wait")) return -KEY_wait;
+ break;
+ case 5:
+ if (strEQ(d,"while")) return KEY_while;
+ if (strEQ(d,"write")) return -KEY_write;
+ break;
+ case 7:
+ if (strEQ(d,"waitpid")) return -KEY_waitpid;
+ break;
+ case 9:
+ if (strEQ(d,"wantarray")) return -KEY_wantarray;
+ break;
+ }
+ break;
+ case 'x':
+ if (len == 1) return -KEY_x;
+ if (strEQ(d,"xor")) return -KEY_xor;
+ break;
+ case 'y':
+ if (len == 1) return KEY_y;
+ break;
+ case 'z':
+ break;
+ }
+ return 0;
+}
+
+STATIC void
+checkcomma(register char *s, char *name, char *what)
+{
+ char *w;
+
+ if (PL_dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
+ int level = 1;
+ for (w = s+2; *w && level; w++) {
+ if (*w == '(')
+ ++level;
+ else if (*w == ')')
+ --level;
+ }
+ if (*w)
+ for (; *w && isSPACE(*w); w++) ;
+ if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
+ warn("%s (...) interpreted as function",name);
+ }
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (*s == '(')
+ s++;
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (isIDFIRST(*s)) {
+ w = s++;
+ while (isALNUM(*s))
+ s++;
+ while (s < PL_bufend && isSPACE(*s))
+ s++;
+ if (*s == ',') {
+ int kw;
+ *s = '\0';
+ kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
+ *s = ',';
+ if (kw)
+ return;
+ croak("No comma allowed after %s", what);
+ }
+ }
+}
+
+STATIC SV *
+new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
+{
+ dSP;
+ HV *table = GvHV(PL_hintgv); /* ^H */
+ BINOP myop;
+ SV *res;
+ bool oldcatch = CATCH_GET;
+ SV **cvp;
+ SV *cv, *typesv;
+ char buf[128];
+
+ if (!table) {
+ yyerror("%^H is not defined");
+ return sv;
+ }
+ cvp = hv_fetch(table, key, strlen(key), FALSE);
+ if (!cvp || !SvOK(*cvp)) {
+ sprintf(buf,"$^H{%s} is not defined", key);
+ yyerror(buf);
+ return sv;
+ }
+ sv_2mortal(sv); /* Parent created it permanently */
+ cv = *cvp;
+ if (!pv)
+ pv = sv_2mortal(newSVpv(s, len));
+ if (type)
+ typesv = sv_2mortal(newSVpv(type, 0));
+ else
+ typesv = &PL_sv_undef;
+ CATCH_SET(TRUE);
+ Zero(&myop, 1, BINOP);
+ myop.op_last = (OP *) &myop;
+ myop.op_next = Nullop;
+ myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+
+ PUSHSTACKi(PERLSI_OVERLOAD);
+ ENTER;
+ SAVEOP();
+ PL_op = (OP *) &myop;
+ if (PERLDB_SUB && PL_curstash != PL_debstash)
+ PL_op->op_private |= OPpENTERSUB_DB;
+ PUTBACK;
+ pp_pushmark(ARGS);
+
+ EXTEND(sp, 4);
+ PUSHs(pv);
+ PUSHs(sv);
+ PUSHs(typesv);
+ PUSHs(cv);
+ PUTBACK;
+
+ if (PL_op = pp_entersub(ARGS))
+ CALLRUNOPS();
+ LEAVE;
+ SPAGAIN;
+
+ res = POPs;
+ PUTBACK;
+ CATCH_SET(oldcatch);
+ POPSTACK;
+
+ if (!SvOK(res)) {
+ sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
+ yyerror(buf);
+ }
+ return SvREFCNT_inc(res);
+}
+
+STATIC char *
+scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
+{
+ register char *d = dest;
+ register char *e = d + destlen - 3; /* two-character token, ending NUL */
+ for (;;) {
+ if (d >= e)
+ croak(ident_too_long);
+ if (isALNUM(*s))
+ *d++ = *s++;
+ else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
+ *d++ = ':';
+ *d++ = ':';
+ s++;
+ }
+ else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
+ *d++ = *s++;
+ *d++ = *s++;
+ }
+ else {
+ *d = '\0';
+ *slp = d - dest;
+ return s;
+ }
+ }
+}
+
+STATIC char *
+scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
+{
+ register char *d;
+ register char *e;
+ char *bracket = 0;
+ char funny = *s++;
+
+ if (PL_lex_brackets == 0)
+ PL_lex_fakebrack = 0;
+ if (isSPACE(*s))
+ s = skipspace(s);
+ d = dest;
+ e = d + destlen - 3; /* two-character token, ending NUL */
+ if (isDIGIT(*s)) {
+ while (isDIGIT(*s)) {
+ if (d >= e)
+ croak(ident_too_long);
+ *d++ = *s++;
+ }
+ }
+ else {
+ for (;;) {
+ if (d >= e)
+ croak(ident_too_long);
+ if (isALNUM(*s))
+ *d++ = *s++;
+ else if (*s == '\'' && isIDFIRST(s[1])) {
+ *d++ = ':';
+ *d++ = ':';
+ s++;
+ }
+ else if (*s == ':' && s[1] == ':') {
+ *d++ = *s++;
+ *d++ = *s++;
+ }
+ else
+ break;
+ }
+ }
+ *d = '\0';
+ d = dest;
+ if (*d) {
+ if (PL_lex_state != LEX_NORMAL)
+ PL_lex_state = LEX_INTERPENDMAYBE;
+ return s;
+ }
+ if (*s == '$' && s[1] &&
+ (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
+ {
+ if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
+ deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
+ else
+ return s;
+ }
+ if (*s == '{') {
+ bracket = s;
+ s++;
+ }
+ else if (ck_uni)
+ check_uni();
+ if (s < send)
+ *d = *s++;
+ d[1] = '\0';
+ if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
+ *d = toCTRL(*s);
+ s++;
+ }
+ if (bracket) {
+ if (isSPACE(s[-1])) {
+ while (s < send) {
+ char ch = *s++;
+ if (ch != ' ' && ch != '\t') {
+ *d = ch;
+ break;
+ }
+ }
+ }
+ if (isIDFIRST(*d)) {
+ d++;
+ while (isALNUM(*s) || *s == ':')
+ *d++ = *s++;
+ *d = '\0';
+ while (s < send && (*s == ' ' || *s == '\t')) s++;
+ if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
+ if (PL_dowarn && keyword(dest, d - dest)) {
+ char *brack = *s == '[' ? "[...]" : "{...}";
+ warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
+ funny, dest, brack, funny, dest, brack);
+ }
+ PL_lex_fakebrack = PL_lex_brackets+1;
+ bracket++;
+ PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
+ return s;
+ }
+ }
+ if (*s == '}') {
+ s++;
+ if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
+ PL_lex_state = LEX_INTERPEND;
+ if (funny == '#')
+ funny = '@';
+ if (PL_dowarn && PL_lex_state == LEX_NORMAL &&
+ (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
+ warn("Ambiguous use of %c{%s} resolved to %c%s",
+ funny, dest, funny, dest);
+ }
+ else {
+ s = bracket; /* let the parser handle it */
+ *dest = '\0';
+ }
+ }
+ else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
+ PL_lex_state = LEX_INTERPEND;
+ return s;
+}
+
+void pmflag(U16 *pmfl, int ch)
+{
+ if (ch == 'i')
+ *pmfl |= PMf_FOLD;
+ else if (ch == 'g')
+ *pmfl |= PMf_GLOBAL;
+ else if (ch == 'c')
+ *pmfl |= PMf_CONTINUE;
+ else if (ch == 'o')
+ *pmfl |= PMf_KEEP;
+ else if (ch == 'm')
+ *pmfl |= PMf_MULTILINE;
+ else if (ch == 's')
+ *pmfl |= PMf_SINGLELINE;
+ else if (ch == 'x')
+ *pmfl |= PMf_EXTENDED;
+}
+
+STATIC char *
+scan_pat(char *start, I32 type)
+{
+ PMOP *pm;
+ char *s;
+
+ s = scan_str(start);
+ if (!s) {
+ if (PL_lex_stuff)
+ SvREFCNT_dec(PL_lex_stuff);
+ PL_lex_stuff = Nullsv;
+ croak("Search pattern not terminated");
+ }
+
+ pm = (PMOP*)newPMOP(type, 0);
+ if (PL_multi_open == '?')
+ pm->op_pmflags |= PMf_ONCE;
+ if(type == OP_QR) {
+ while (*s && strchr("iomsx", *s))
+ pmflag(&pm->op_pmflags,*s++);
+ }
+ else {
+ while (*s && strchr("iogcmsx", *s))
+ pmflag(&pm->op_pmflags,*s++);
+ }
+ pm->op_pmpermflags = pm->op_pmflags;
+
+ PL_lex_op = (OP*)pm;
+ yylval.ival = OP_MATCH;
+ return s;
+}
+
+STATIC char *
+scan_subst(char *start)
+{
+ register char *s;
+ register PMOP *pm;
+ I32 first_start;
+ I32 es = 0;
+
+ yylval.ival = OP_NULL;
+
+ s = scan_str(start);
+
+ if (!s) {
+ if (PL_lex_stuff)
+ SvREFCNT_dec(PL_lex_stuff);
+ PL_lex_stuff = Nullsv;
+ croak("Substitution pattern not terminated");
+ }
+
+ if (s[-1] == PL_multi_open)
+ s--;
+
+ first_start = PL_multi_start;
+ s = scan_str(s);
+ if (!s) {
+ if (PL_lex_stuff)
+ SvREFCNT_dec(PL_lex_stuff);
+ PL_lex_stuff = Nullsv;
+ if (PL_lex_repl)
+ SvREFCNT_dec(PL_lex_repl);
+ PL_lex_repl = Nullsv;
+ croak("Substitution replacement not terminated");
+ }
+ PL_multi_start = first_start; /* so whole substitution is taken together */
+
+ pm = (PMOP*)newPMOP(OP_SUBST, 0);
+ while (*s) {
+ if (*s == 'e') {
+ s++;
+ es++;
+ }
+ else if (strchr("iogcmsx", *s))
+ pmflag(&pm->op_pmflags,*s++);
+ else
+ break;
+ }
+
+ if (es) {
+ SV *repl;
+ pm->op_pmflags |= PMf_EVAL;
+ repl = newSVpv("",0);
+ while (es-- > 0)
+ sv_catpv(repl, es ? "eval " : "do ");
+ sv_catpvn(repl, "{ ", 2);
+ sv_catsv(repl, PL_lex_repl);
+ sv_catpvn(repl, " };", 2);
+ SvCOMPILED_on(repl);
+ SvREFCNT_dec(PL_lex_repl);
+ PL_lex_repl = repl;
+ }
+
+ pm->op_pmpermflags = pm->op_pmflags;
+ PL_lex_op = (OP*)pm;
+ yylval.ival = OP_SUBST;
+ return s;
+}
+
+STATIC char *
+scan_trans(char *start)
+{
+ register char* s;
+ OP *o;
+ short *tbl;
+ I32 squash;
+ I32 Delete;
+ I32 complement;
+
+ yylval.ival = OP_NULL;
+
+ s = scan_str(start);
+ if (!s) {
+ if (PL_lex_stuff)
+ SvREFCNT_dec(PL_lex_stuff);
+ PL_lex_stuff = Nullsv;
+ croak("Transliteration pattern not terminated");
+ }
+ if (s[-1] == PL_multi_open)
+ s--;
+
+ s = scan_str(s);
+ if (!s) {
+ if (PL_lex_stuff)
+ SvREFCNT_dec(PL_lex_stuff);
+ PL_lex_stuff = Nullsv;
+ if (PL_lex_repl)
+ SvREFCNT_dec(PL_lex_repl);
+ PL_lex_repl = Nullsv;
+ croak("Transliteration replacement not terminated");
+ }
+
+ New(803,tbl,256,short);
+ o = newPVOP(OP_TRANS, 0, (char*)tbl);
+
+ complement = Delete = squash = 0;
+ while (*s == 'c' || *s == 'd' || *s == 's') {
+ if (*s == 'c')
+ complement = OPpTRANS_COMPLEMENT;
+ else if (*s == 'd')
+ Delete = OPpTRANS_DELETE;
+ else
+ squash = OPpTRANS_SQUASH;
+ s++;
+ }
+ o->op_private = Delete|squash|complement;
+
+ PL_lex_op = o;
+ yylval.ival = OP_TRANS;
+ return s;
+}
+
+STATIC char *
+scan_heredoc(register char *s)
+{
+ dTHR;
+ SV *herewas;
+ I32 op_type = OP_SCALAR;
+ I32 len;
+ SV *tmpstr;
+ char term;
+ register char *d;
+ register char *e;
+ char *peek;
+ int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
+
+ s += 2;
+ d = PL_tokenbuf;
+ e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
+ if (!outer)
+ *d++ = '\n';
+ for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
+ if (*peek && strchr("`'\"",*peek)) {
+ s = peek;
+ term = *s++;
+ s = delimcpy(d, e, s, PL_bufend, term, &len);
+ d += len;
+ if (s < PL_bufend)
+ s++;
+ }
+ else {
+ if (*s == '\\')
+ s++, term = '\'';
+ else
+ term = '"';
+ if (!isALNUM(*s))
+ deprecate("bare << to mean <<\"\"");
+ for (; isALNUM(*s); s++) {
+ if (d < e)
+ *d++ = *s;
+ }
+ }
+ if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
+ croak("Delimiter for here document is too long");
+ *d++ = '\n';
+ *d = '\0';
+ len = d - PL_tokenbuf;
+#ifndef PERL_STRICT_CR
+ d = strchr(s, '\r');
+ if (d) {
+ char *olds = s;
+ s = d;
+ while (s < PL_bufend) {
+ if (*s == '\r') {
+ *d++ = '\n';
+ if (*++s == '\n')
+ s++;
+ }
+ else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
+ *d++ = *s++;
+ s++;
+ }
+ else
+ *d++ = *s++;
+ }
+ *d = '\0';
+ PL_bufend = d;
+ SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
+ s = olds;
+ }
+#endif
+ d = "\n";
+ if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
+ herewas = newSVpv(s,PL_bufend-s);
+ else
+ s--, herewas = newSVpv(s,d-s);
+ s += SvCUR(herewas);
+
+ tmpstr = NEWSV(87,79);
+ sv_upgrade(tmpstr, SVt_PVIV);
+ if (term == '\'') {
+ op_type = OP_CONST;
+ SvIVX(tmpstr) = -1;
+ }
+ else if (term == '`') {
+ op_type = OP_BACKTICK;
+ SvIVX(tmpstr) = '\\';
+ }
+
+ CLINE;
+ PL_multi_start = PL_curcop->cop_line;
+ PL_multi_open = PL_multi_close = '<';
+ term = *PL_tokenbuf;
+ if (!outer) {
+ d = s;
+ while (s < PL_bufend &&
+ (*s != term || memNE(s,PL_tokenbuf,len)) ) {
+ if (*s++ == '\n')
+ PL_curcop->cop_line++;
+ }
+ if (s >= PL_bufend) {
+ PL_curcop->cop_line = PL_multi_start;
+ missingterm(PL_tokenbuf);
+ }
+ sv_setpvn(tmpstr,d+1,s-d);
+ s += len - 1;
+ PL_curcop->cop_line++; /* the preceding stmt passes a newline */
+
+ sv_catpvn(herewas,s,PL_bufend-s);
+ sv_setsv(PL_linestr,herewas);
+ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ }
+ else
+ sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
+ while (s >= PL_bufend) { /* multiple line string? */
+ if (!outer ||
+ !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
+ PL_curcop->cop_line = PL_multi_start;
+ missingterm(PL_tokenbuf);
+ }
+ PL_curcop->cop_line++;
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+#ifndef PERL_STRICT_CR
+ if (PL_bufend - PL_linestart >= 2) {
+ if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
+ (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
+ {
+ PL_bufend[-2] = '\n';
+ PL_bufend--;
+ SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
+ }
+ else if (PL_bufend[-1] == '\r')
+ PL_bufend[-1] = '\n';
+ }
+ else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
+ PL_bufend[-1] = '\n';
+#endif
+ if (PERLDB_LINE && PL_curstash != PL_debstash) {
+ SV *sv = NEWSV(88,0);
+
+ sv_upgrade(sv, SVt_PVMG);
+ sv_setsv(sv,PL_linestr);
+ av_store(GvAV(PL_curcop->cop_filegv),
+ (I32)PL_curcop->cop_line,sv);
+ }
+ if (*s == term && memEQ(s,PL_tokenbuf,len)) {
+ s = PL_bufend - 1;
+ *s = ' ';
+ sv_catsv(PL_linestr,herewas);
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ }
+ else {
+ s = PL_bufend;
+ sv_catsv(tmpstr,PL_linestr);
+ }
+ }
+ PL_multi_end = PL_curcop->cop_line;
+ s++;
+ if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
+ SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
+ Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
+ }
+ SvREFCNT_dec(herewas);
+ PL_lex_stuff = tmpstr;
+ yylval.ival = op_type;
+ return s;
+}
+
+/* scan_inputsymbol
+ takes: current position in input buffer
+ returns: new position in input buffer
+ side-effects: yylval and lex_op are set.
+
+ This code handles:
+
+ <> read from ARGV
+ <FH> read from filehandle
+ <pkg::FH> read from package qualified filehandle
+ <pkg'FH> read from package qualified filehandle
+ <$fh> read from filehandle in $fh
+ <*.h> filename glob
+
+*/
+
+STATIC char *
+scan_inputsymbol(char *start)
+{
+ register char *s = start; /* current position in buffer */
+ register char *d;
+ register char *e;
+ I32 len;
+
+ d = PL_tokenbuf; /* start of temp holding space */
+ e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
+ s = delimcpy(d, e, s + 1, PL_bufend, '>', &len); /* extract until > */
+
+ /* die if we didn't have space for the contents of the <>,
+ or if it didn't end
+ */
+
+ if (len >= sizeof PL_tokenbuf)
+ croak("Excessively long <> operator");
+ if (s >= PL_bufend)
+ croak("Unterminated <> operator");
+
+ s++;
+
+ /* check for <$fh>
+ Remember, only scalar variables are interpreted as filehandles by
+ this code. Anything more complex (e.g., <$fh{$num}>) will be
+ treated as a glob() call.
+ This code makes use of the fact that except for the $ at the front,
+ a scalar variable and a filehandle look the same.
+ */
+ if (*d == '$' && d[1]) d++;
+
+ /* allow <Pkg'VALUE> or <Pkg::VALUE> */
+ while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
+ d++;
+
+ /* If we've tried to read what we allow filehandles to look like, and
+ there's still text left, then it must be a glob() and not a getline.
+ Use scan_str to pull out the stuff between the <> and treat it
+ as nothing more than a string.
+ */
+
+ if (d - PL_tokenbuf != len) {
+ yylval.ival = OP_GLOB;
+ set_csh();
+ s = scan_str(start);
+ if (!s)
+ croak("Glob not terminated");
+ return s;
+ }
+ else {
+ /* we're in a filehandle read situation */
+ d = PL_tokenbuf;
+
+ /* turn <> into <ARGV> */
+ if (!len)
+ (void)strcpy(d,"ARGV");
+
+ /* if <$fh>, create the ops to turn the variable into a
+ filehandle
+ */
+ if (*d == '$') {
+ I32 tmp;
+
+ /* try to find it in the pad for this block, otherwise find
+ add symbol table ops
+ */
+ if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
+ OP *o = newOP(OP_PADSV, 0);
+ o->op_targ = tmp;
+ PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
+ }
+ else {
+ GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
+ PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
+ newUNOP(OP_RV2GV, 0,
+ newUNOP(OP_RV2SV, 0,
+ newGVOP(OP_GV, 0, gv))));
+ }
+ /* we created the ops in lex_op, so make yylval.ival a null op */
+ yylval.ival = OP_NULL;
+ }
+
+ /* If it's none of the above, it must be a literal filehandle
+ (<Foo::BAR> or <FOO>) so build a simple readline OP */
+ else {
+ GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
+ PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
+ yylval.ival = OP_NULL;
+ }
+ }
+
+ return s;
+}
+
+
+/* scan_str
+ takes: start position in buffer
+ returns: position to continue reading from buffer
+ side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
+ updates the read buffer.
+
+ This subroutine pulls a string out of the input. It is called for:
+ q single quotes q(literal text)
+ ' single quotes 'literal text'
+ qq double quotes qq(interpolate $here please)
+ " double quotes "interpolate $here please"
+ qx backticks qx(/bin/ls -l)
+ ` backticks `/bin/ls -l`
+ qw quote words @EXPORT_OK = qw( func() $spam )
+ m// regexp match m/this/
+ s/// regexp substitute s/this/that/
+ tr/// string transliterate tr/this/that/
+ y/// string transliterate y/this/that/
+ ($*@) sub prototypes sub foo ($)
+ <> readline or globs <FOO>, <>, <$fh>, or <*.c>
+
+ In most of these cases (all but <>, patterns and transliterate)
+ yylex() calls scan_str(). m// makes yylex() call scan_pat() which
+ calls scan_str(). s/// makes yylex() call scan_subst() which calls
+ scan_str(). tr/// and y/// make yylex() call scan_trans() which
+ calls scan_str().
+
+ It skips whitespace before the string starts, and treats the first
+ character as the delimiter. If the delimiter is one of ([{< then
+ the corresponding "close" character )]}> is used as the closing
+ delimiter. It allows quoting of delimiters, and if the string has
+ balanced delimiters ([{<>}]) it allows nesting.
+
+ The lexer always reads these strings into lex_stuff, except in the
+ case of the operators which take *two* arguments (s/// and tr///)
+ when it checks to see if lex_stuff is full (presumably with the 1st
+ arg to s or tr) and if so puts the string into lex_repl.
+
+*/
+
+STATIC char *
+scan_str(char *start)
+{
+ dTHR;
+ SV *sv; /* scalar value: string */
+ char *tmps; /* temp string, used for delimiter matching */
+ register char *s = start; /* current position in the buffer */
+ register char term; /* terminating character */
+ register char *to; /* current position in the sv's data */
+ I32 brackets = 1; /* bracket nesting level */
+
+ /* skip space before the delimiter */
+ if (isSPACE(*s))
+ s = skipspace(s);
+
+ /* mark where we are, in case we need to report errors */
+ CLINE;
+
+ /* after skipping whitespace, the next character is the terminator */
+ term = *s;
+ /* mark where we are */
+ PL_multi_start = PL_curcop->cop_line;
+ PL_multi_open = term;
+
+ /* find corresponding closing delimiter */
+ if (term && (tmps = strchr("([{< )]}> )]}>",term)))
+ term = tmps[5];
+ PL_multi_close = term;
+
+ /* create a new SV to hold the contents. 87 is leak category, I'm
+ assuming. 79 is the SV's initial length. What a random number. */
+ sv = NEWSV(87,79);
+ sv_upgrade(sv, SVt_PVIV);
+ SvIVX(sv) = term;
+ (void)SvPOK_only(sv); /* validate pointer */
+
+ /* move past delimiter and try to read a complete string */
+ s++;
+ for (;;) {
+ /* extend sv if need be */
+ SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
+ /* set 'to' to the next character in the sv's string */
+ to = SvPVX(sv)+SvCUR(sv);
+
+ /* if open delimiter is the close delimiter read unbridle */
+ if (PL_multi_open == PL_multi_close) {
+ for (; s < PL_bufend; s++,to++) {
+ /* embedded newlines increment the current line number */
+ if (*s == '\n' && !PL_rsfp)
+ PL_curcop->cop_line++;
+ /* handle quoted delimiters */
+ if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
+ if (s[1] == term)
+ s++;
+ /* any other quotes are simply copied straight through */
+ else
+ *to++ = *s++;
+ }
+ /* terminate when run out of buffer (the for() condition), or
+ have found the terminator */
+ else if (*s == term)
+ break;
+ *to = *s;
+ }
+ }
+
+ /* if the terminator isn't the same as the start character (e.g.,
+ matched brackets), we have to allow more in the quoting, and
+ be prepared for nested brackets.
+ */
+ else {
+ /* read until we run out of string, or we find the terminator */
+ for (; s < PL_bufend; s++,to++) {
+ /* embedded newlines increment the line count */
+ if (*s == '\n' && !PL_rsfp)
+ PL_curcop->cop_line++;
+ /* backslashes can escape the open or closing characters */
+ if (*s == '\\' && s+1 < PL_bufend) {
+ if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
+ s++;
+ else
+ *to++ = *s++;
+ }
+ /* allow nested opens and closes */
+ else if (*s == PL_multi_close && --brackets <= 0)
+ break;
+ else if (*s == PL_multi_open)
+ brackets++;
+ *to = *s;
+ }
+ }
+ /* terminate the copied string and update the sv's end-of-string */
+ *to = '\0';
+ SvCUR_set(sv, to - SvPVX(sv));
+
+ /*
+ * this next chunk reads more into the buffer if we're not done yet
+ */
+
+ if (s < PL_bufend) break; /* handle case where we are done yet :-) */
+
+#ifndef PERL_STRICT_CR
+ if (to - SvPVX(sv) >= 2) {
+ if ((to[-2] == '\r' && to[-1] == '\n') ||
+ (to[-2] == '\n' && to[-1] == '\r'))
+ {
+ to[-2] = '\n';
+ to--;
+ SvCUR_set(sv, to - SvPVX(sv));
+ }
+ else if (to[-1] == '\r')
+ to[-1] = '\n';
+ }
+ else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
+ to[-1] = '\n';
+#endif
+
+ /* if we're out of file, or a read fails, bail and reset the current
+ line marker so we can report where the unterminated string began
+ */
+ if (!PL_rsfp ||
+ !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
+ sv_free(sv);
+ PL_curcop->cop_line = PL_multi_start;
+ return Nullch;
+ }
+ /* we read a line, so increment our line counter */
+ PL_curcop->cop_line++;
+
+ /* update debugger info */
+ if (PERLDB_LINE && PL_curstash != PL_debstash) {
+ SV *sv = NEWSV(88,0);
+
+ sv_upgrade(sv, SVt_PVMG);
+ sv_setsv(sv,PL_linestr);
+ av_store(GvAV(PL_curcop->cop_filegv),
+ (I32)PL_curcop->cop_line, sv);
+ }
+
+ /* having changed the buffer, we must update PL_bufend */
+ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ }
+
+ /* at this point, we have successfully read the delimited string */
+
+ PL_multi_end = PL_curcop->cop_line;
+ s++;
+
+ /* if we allocated too much space, give some back */
+ if (SvCUR(sv) + 5 < SvLEN(sv)) {
+ SvLEN_set(sv, SvCUR(sv) + 1);
+ Renew(SvPVX(sv), SvLEN(sv), char);
+ }
+
+ /* decide whether this is the first or second quoted string we've read
+ for this op
+ */
+
+ if (PL_lex_stuff)
+ PL_lex_repl = sv;
+ else
+ PL_lex_stuff = sv;
+ return s;
+}
+
+/*
+ scan_num
+ takes: pointer to position in buffer
+ returns: pointer to new position in buffer
+ side-effects: builds ops for the constant in yylval.op
+
+ Read a number in any of the formats that Perl accepts:
+
+ 0(x[0-7A-F]+)|([0-7]+)
+ [\d_]+(\.[\d_]*)?[Ee](\d+)
+
+ Underbars (_) are allowed in decimal numbers. If -w is on,
+ underbars before a decimal point must be at three digit intervals.
+
+ Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
+ thing it reads.
+
+ If it reads a number without a decimal point or an exponent, it will
+ try converting the number to an integer and see if it can do so
+ without loss of precision.
+*/
+
+char *
+scan_num(char *start)
+{
+ register char *s = start; /* current position in buffer */
+ register char *d; /* destination in temp buffer */
+ register char *e; /* end of temp buffer */
+ I32 tryiv; /* used to see if it can be an int */
+ double value; /* number read, as a double */
+ SV *sv; /* place to put the converted number */
+ I32 floatit; /* boolean: int or float? */
+ char *lastub = 0; /* position of last underbar */
+ static char number_too_long[] = "Number too long";
+
+ /* We use the first character to decide what type of number this is */
+
+ switch (*s) {
+ default:
+ croak("panic: scan_num");
+
+ /* if it starts with a 0, it could be an octal number, a decimal in
+ 0.13 disguise, or a hexadecimal number.
+ */
+ case '0':
+ {
+ /* variables:
+ u holds the "number so far"
+ shift the power of 2 of the base (hex == 4, octal == 3)
+ overflowed was the number more than we can hold?
+
+ Shift is used when we add a digit. It also serves as an "are
+ we in octal or hex?" indicator to disallow hex characters when
+ in octal mode.
+ */
+ UV u;
+ I32 shift;
+ bool overflowed = FALSE;
+
+ /* check for hex */
+ if (s[1] == 'x') {
+ shift = 4;
+ s += 2;
+ }
+ /* check for a decimal in disguise */
+ else if (s[1] == '.')
+ goto decimal;
+ /* so it must be octal */
+ else
+ shift = 3;
+ u = 0;
+
+ /* read the rest of the octal number */
+ for (;;) {
+ UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
+
+ switch (*s) {
+
+ /* if we don't mention it, we're done */
+ default:
+ goto out;
+
+ /* _ are ignored */
+ case '_':
+ s++;
+ break;
+
+ /* 8 and 9 are not octal */
+ case '8': case '9':
+ if (shift != 4)
+ yyerror("Illegal octal digit");
+ /* FALL THROUGH */
+
+ /* octal digits */
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7':
+ b = *s++ & 15; /* ASCII digit -> value of digit */
+ goto digit;
+
+ /* hex digits */
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ /* make sure they said 0x */
+ if (shift != 4)
+ goto out;
+ b = (*s++ & 7) + 9;
+
+ /* Prepare to put the digit we have onto the end
+ of the number so far. We check for overflows.
+ */
+
+ digit:
+ n = u << shift; /* make room for the digit */
+ if (!overflowed && (n >> shift) != u
+ && !(PL_hints & HINT_NEW_BINARY)) {
+ warn("Integer overflow in %s number",
+ (shift == 4) ? "hex" : "octal");
+ overflowed = TRUE;
+ }
+ u = n | b; /* add the digit to the end */
+ break;
+ }
+ }
+
+ /* if we get here, we had success: make a scalar value from
+ the number.
+ */
+ out:
+ sv = NEWSV(92,0);
+ sv_setuv(sv, u);
+ if ( PL_hints & HINT_NEW_BINARY)
+ sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
+ }
+ break;
+
+ /*
+ handle decimal numbers.
+ we're also sent here when we read a 0 as the first digit
+ */
+ case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9': case '.':
+ decimal:
+ d = PL_tokenbuf;
+ e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
+ floatit = FALSE;
+
+ /* read next group of digits and _ and copy into d */
+ while (isDIGIT(*s) || *s == '_') {
+ /* skip underscores, checking for misplaced ones
+ if -w is on
+ */
+ if (*s == '_') {
+ if (PL_dowarn && lastub && s - lastub != 3)
+ warn("Misplaced _ in number");
+ lastub = ++s;
+ }
+ else {
+ /* check for end of fixed-length buffer */
+ if (d >= e)
+ croak(number_too_long);
+ /* if we're ok, copy the character */
+ *d++ = *s++;
+ }
+ }
+
+ /* final misplaced underbar check */
+ if (PL_dowarn && lastub && s - lastub != 3)
+ warn("Misplaced _ in number");
+
+ /* read a decimal portion if there is one. avoid
+ 3..5 being interpreted as the number 3. followed
+ by .5
+ */
+ if (*s == '.' && s[1] != '.') {
+ floatit = TRUE;
+ *d++ = *s++;
+
+ /* copy, ignoring underbars, until we run out of
+ digits. Note: no misplaced underbar checks!
+ */
+ for (; isDIGIT(*s) || *s == '_'; s++) {
+ /* fixed length buffer check */
+ if (d >= e)
+ croak(number_too_long);
+ if (*s != '_')
+ *d++ = *s;
+ }
+ }
+
+ /* read exponent part, if present */
+ if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
+ floatit = TRUE;
+ s++;
+
+ /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
+ *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
+
+ /* allow positive or negative exponent */
+ if (*s == '+' || *s == '-')
+ *d++ = *s++;
+
+ /* read digits of exponent (no underbars :-) */
+ while (isDIGIT(*s)) {
+ if (d >= e)
+ croak(number_too_long);
+ *d++ = *s++;
+ }
+ }
+
+ /* terminate the string */
+ *d = '\0';
+
+ /* make an sv from the string */
+ sv = NEWSV(92,0);
+ /* reset numeric locale in case we were earlier left in Swaziland */
+ SET_NUMERIC_STANDARD();
+ value = atof(PL_tokenbuf);
+
+ /*
+ See if we can make do with an integer value without loss of
+ precision. We use I_V to cast to an int, because some
+ compilers have issues. Then we try casting it back and see
+ if it was the same. We only do this if we know we
+ specifically read an integer.
+
+ Note: if floatit is true, then we don't need to do the
+ conversion at all.
+ */
+ tryiv = I_V(value);
+ if (!floatit && (double)tryiv == value)
+ sv_setiv(sv, tryiv);
+ else
+ sv_setnv(sv, value);
+ if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
+ sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
+ (floatit ? "float" : "integer"), sv, Nullsv, NULL);
+ break;
+ }
+
+ /* make the op for the constant and return */
+
+ yylval.opval = newSVOP(OP_CONST, 0, sv);
+
+ return s;
+}
+
+STATIC char *
+scan_formline(register char *s)
+{
+ dTHR;
+ register char *eol;
+ register char *t;
+ SV *stuff = newSVpv("",0);
+ bool needargs = FALSE;
+
+ while (!needargs) {
+ if (*s == '.' || *s == '}') {
+ /*SUPPRESS 530*/
+ for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
+ if (*t == '\n')
+ break;
+ }
+ if (PL_in_eval && !PL_rsfp) {
+ eol = strchr(s,'\n');
+ if (!eol++)
+ eol = PL_bufend;
+ }
+ else
+ eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+ if (*s != '#') {
+ for (t = s; t < eol; t++) {
+ if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
+ needargs = FALSE;
+ goto enough; /* ~~ must be first line in formline */
+ }
+ if (*t == '@' || *t == '^')
+ needargs = TRUE;
+ }
+ sv_catpvn(stuff, s, eol-s);
+ }
+ s = eol;
+ if (PL_rsfp) {
+ s = filter_gets(PL_linestr, PL_rsfp, 0);
+ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
+ PL_bufend = PL_bufptr + SvCUR(PL_linestr);
+ if (!s) {
+ s = PL_bufptr;
+ yyerror("Format not terminated");
+ break;
+ }
+ }
+ incline(s);
+ }
+ enough:
+ if (SvCUR(stuff)) {
+ PL_expect = XTERM;
+ if (needargs) {
+ PL_lex_state = LEX_NORMAL;
+ PL_nextval[PL_nexttoke].ival = 0;
+ force_next(',');
+ }
+ else
+ PL_lex_state = LEX_FORMLINE;
+ PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
+ force_next(THING);
+ PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
+ force_next(LSTOP);
+ }
+ else {
+ SvREFCNT_dec(stuff);
+ PL_lex_formbrack = 0;
+ PL_bufptr = s;
+ }
+ return s;
+}
+
+STATIC void
+set_csh(void)
+{
+#ifdef CSH
+ if (!PL_cshlen)
+ PL_cshlen = strlen(PL_cshname);
+#endif
+}
+
+I32
+start_subparse(I32 is_format, U32 flags)
+{
+ dTHR;
+ I32 oldsavestack_ix = PL_savestack_ix;
+ CV* outsidecv = PL_compcv;
+ AV* comppadlist;
+
+ if (PL_compcv) {
+ assert(SvTYPE(PL_compcv) == SVt_PVCV);
+ }
+ save_I32(&PL_subline);
+ save_item(PL_subname);
+ SAVEI32(PL_padix);
+ SAVESPTR(PL_curpad);
+ SAVESPTR(PL_comppad);
+ SAVESPTR(PL_comppad_name);
+ SAVESPTR(PL_compcv);
+ SAVEI32(PL_comppad_name_fill);
+ SAVEI32(PL_min_intro_pending);
+ SAVEI32(PL_max_intro_pending);
+ SAVEI32(PL_pad_reset_pending);
+
+ PL_compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
+ CvFLAGS(PL_compcv) |= flags;
+
+ PL_comppad = newAV();
+ av_push(PL_comppad, Nullsv);
+ PL_curpad = AvARRAY(PL_comppad);
+ PL_comppad_name = newAV();
+ PL_comppad_name_fill = 0;
+ PL_min_intro_pending = 0;
+ PL_padix = 0;
+ PL_subline = PL_curcop->cop_line;
+#ifdef USE_THREADS
+ av_store(PL_comppad_name, 0, newSVpv("@_", 2));
+ PL_curpad[0] = (SV*)newAV();
+ SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
+#endif /* USE_THREADS */
+
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, (SV*)PL_comppad_name);
+ av_store(comppadlist, 1, (SV*)PL_comppad);
+
+ CvPADLIST(PL_compcv) = comppadlist;
+ CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
+#ifdef USE_THREADS
+ CvOWNER(PL_compcv) = 0;
+ New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(PL_compcv));
+#endif /* USE_THREADS */
+
+ return oldsavestack_ix;
+}
+
+int
+yywarn(char *s)
+{
+ dTHR;
+ --PL_error_count;
+ PL_in_eval |= 2;
+ yyerror(s);
+ PL_in_eval &= ~2;
+ return 0;
+}
+
+int
+yyerror(char *s)
+{
+ dTHR;
+ char *where = NULL;
+ char *context = NULL;
+ int contlen = -1;
+ SV *msg;
+
+ if (!yychar || (yychar == ';' && !PL_rsfp))
+ where = "at EOF";
+ else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
+ PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
+ while (isSPACE(*PL_oldoldbufptr))
+ PL_oldoldbufptr++;
+ context = PL_oldoldbufptr;
+ contlen = PL_bufptr - PL_oldoldbufptr;
+ }
+ else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
+ PL_oldbufptr != PL_bufptr) {
+ while (isSPACE(*PL_oldbufptr))
+ PL_oldbufptr++;
+ context = PL_oldbufptr;
+ contlen = PL_bufptr - PL_oldbufptr;
+ }
+ else if (yychar > 255)
+ where = "next token ???";
+ else if ((yychar & 127) == 127) {
+ if (PL_lex_state == LEX_NORMAL ||
+ (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
+ where = "at end of line";
+ else if (PL_lex_inpat)
+ where = "within pattern";
+ else
+ where = "within string";
+ }
+ else {
+ SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
+ if (yychar < 32)
+ sv_catpvf(where_sv, "^%c", toCTRL(yychar));
+ else if (isPRINT_LC(yychar))
+ sv_catpvf(where_sv, "%c", yychar);
+ else
+ sv_catpvf(where_sv, "\\%03o", yychar & 255);
+ where = SvPVX(where_sv);
+ }
+ msg = sv_2mortal(newSVpv(s, 0));
+ sv_catpvf(msg, " at %_ line %ld, ",
+ GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
+ if (context)
+ sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
+ else
+ sv_catpvf(msg, "%s\n", where);
+ if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
+ sv_catpvf(msg,
+ " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
+ (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
+ PL_multi_end = 0;
+ }
+ if (PL_in_eval & 2)
+ warn("%_", msg);
+ else if (PL_in_eval)
+ sv_catsv(ERRSV, msg);
+ else
+ PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
+ if (++PL_error_count >= 10)
+ croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
+ PL_in_my = 0;
+ PL_in_my_stash = Nullhv;
+ return 0;
+}
+
+
diff --git a/contrib/perl5/universal.c b/contrib/perl5/universal.c
new file mode 100644
index 000000000000..bf03261db78f
--- /dev/null
+++ b/contrib/perl5/universal.c
@@ -0,0 +1,218 @@
+#include "EXTERN.h"
+#include "perl.h"
+
+/*
+ * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
+ * The main guts of traverse_isa was actually copied from gv_fetchmeth
+ */
+
+STATIC SV *
+isa_lookup(HV *stash, char *name, int len, int level)
+{
+ AV* av;
+ GV* gv;
+ GV** gvp;
+ HV* hv = Nullhv;
+
+ if (!stash)
+ return &PL_sv_undef;
+
+ if(strEQ(HvNAME(stash), name))
+ return &PL_sv_yes;
+
+ if (level > 100)
+ croak("Recursive inheritance detected in package '%s'", HvNAME(stash));
+
+ gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
+
+ if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv))) {
+ SV* sv;
+ SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
+ if (svp && (sv = *svp) != (SV*)&PL_sv_undef)
+ return sv;
+ }
+
+ gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
+
+ if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
+ if(!hv) {
+ gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
+
+ gv = *gvp;
+
+ if (SvTYPE(gv) != SVt_PVGV)
+ gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
+
+ hv = GvHVn(gv);
+ }
+ if(hv) {
+ SV** svp = AvARRAY(av);
+ /* NOTE: No support for tied ISA */
+ I32 items = AvFILLp(av) + 1;
+ while (items--) {
+ SV* sv = *svp++;
+ HV* basestash = gv_stashsv(sv, FALSE);
+ if (!basestash) {
+ if (PL_dowarn)
+ warn("Can't locate package %s for @%s::ISA",
+ SvPVX(sv), HvNAME(stash));
+ continue;
+ }
+ if(&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
+ (void)hv_store(hv,name,len,&PL_sv_yes,0);
+ return &PL_sv_yes;
+ }
+ }
+ (void)hv_store(hv,name,len,&PL_sv_no,0);
+ }
+ }
+
+ return boolSV(strEQ(name, "UNIVERSAL"));
+}
+
+bool
+sv_derived_from(SV *sv, char *name)
+{
+ SV *rv;
+ char *type;
+ HV *stash;
+
+ stash = Nullhv;
+ type = Nullch;
+
+ if (SvGMAGICAL(sv))
+ mg_get(sv) ;
+
+ if (SvROK(sv)) {
+ sv = SvRV(sv);
+ type = sv_reftype(sv,0);
+ if(SvOBJECT(sv))
+ stash = SvSTASH(sv);
+ }
+ else {
+ stash = gv_stashsv(sv, FALSE);
+ }
+
+ return (type && strEQ(type,name)) ||
+ (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
+ ? TRUE
+ : FALSE ;
+
+}
+
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#endif /* PERL_OBJECT */
+
+#include "XSUB.h"
+
+static
+XS(XS_UNIVERSAL_isa)
+{
+ dXSARGS;
+ SV *sv;
+ char *name;
+
+ if (items != 2)
+ croak("Usage: UNIVERSAL::isa(reference, kind)");
+
+ sv = ST(0);
+ name = (char *)SvPV(ST(1),PL_na);
+
+ ST(0) = boolSV(sv_derived_from(sv, name));
+ XSRETURN(1);
+}
+
+static
+XS(XS_UNIVERSAL_can)
+{
+ dXSARGS;
+ SV *sv;
+ char *name;
+ SV *rv;
+ HV *pkg = NULL;
+
+ if (items != 2)
+ croak("Usage: UNIVERSAL::can(object-ref, method)");
+
+ sv = ST(0);
+ name = (char *)SvPV(ST(1),PL_na);
+ rv = &PL_sv_undef;
+
+ if(SvROK(sv)) {
+ sv = (SV*)SvRV(sv);
+ if(SvOBJECT(sv))
+ pkg = SvSTASH(sv);
+ }
+ else {
+ pkg = gv_stashsv(sv, FALSE);
+ }
+
+ if (pkg) {
+ GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
+ if (gv && isGV(gv))
+ rv = sv_2mortal(newRV((SV*)GvCV(gv)));
+ }
+
+ ST(0) = rv;
+ XSRETURN(1);
+}
+
+static
+XS(XS_UNIVERSAL_VERSION)
+{
+ dXSARGS;
+ HV *pkg;
+ GV **gvp;
+ GV *gv;
+ SV *sv;
+ char *undef;
+ double req;
+
+ if(SvROK(ST(0))) {
+ sv = (SV*)SvRV(ST(0));
+ if(!SvOBJECT(sv))
+ croak("Cannot find version of an unblessed reference");
+ pkg = SvSTASH(sv);
+ }
+ else {
+ pkg = gv_stashsv(ST(0), FALSE);
+ }
+
+ gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
+
+ if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (sv = GvSV(gv))) {
+ SV *nsv = sv_newmortal();
+ sv_setsv(nsv, sv);
+ sv = nsv;
+ undef = Nullch;
+ }
+ else {
+ sv = (SV*)&PL_sv_undef;
+ undef = "(undef)";
+ }
+
+ if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv))))
+ croak("%s version %s required--this is only version %s",
+ HvNAME(pkg), SvPV(ST(1),PL_na), undef ? undef : SvPV(sv,PL_na));
+
+ ST(0) = sv;
+
+ XSRETURN(1);
+}
+
+#ifdef PERL_OBJECT
+#undef boot_core_UNIVERSAL
+#define boot_core_UNIVERSAL CPerlObj::Perl_boot_core_UNIVERSAL
+#define pPerl this
+#endif
+
+void
+boot_core_UNIVERSAL(void)
+{
+ char *file = __FILE__;
+
+ newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
+ newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
+ newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
+}
diff --git a/contrib/perl5/unixish.h b/contrib/perl5/unixish.h
new file mode 100644
index 000000000000..2f812942862c
--- /dev/null
+++ b/contrib/perl5/unixish.h
@@ -0,0 +1,132 @@
+/*
+ * The following symbols are defined if your operating system supports
+ * functions by that name. All Unixes I know of support them, thus they
+ * are not checked by the configuration script, but are directly defined
+ * here.
+ */
+
+/* HAS_IOCTL:
+ * This symbol, if defined, indicates that the ioctl() routine is
+ * available to set I/O characteristics
+ */
+#define HAS_IOCTL / **/
+
+/* HAS_UTIME:
+ * This symbol, if defined, indicates that the routine utime() is
+ * available to update the access and modification times of files.
+ */
+#define HAS_UTIME / **/
+
+/* HAS_GROUP
+ * This symbol, if defined, indicates that the getgrnam() and
+ * getgrgid() routines are available to get group entries.
+ * The getgrent() has a separate definition, HAS_GETGRENT.
+ */
+#define HAS_GROUP / **/
+
+/* HAS_PASSWD
+ * This symbol, if defined, indicates that the getpwnam() and
+ * getpwuid() routines are available to get password entries.
+ * The getpwent() has a separate definition, HAS_GETPWENT.
+ */
+#define HAS_PASSWD / **/
+
+#define HAS_KILL
+#define HAS_WAIT
+
+/* USEMYBINMODE
+ * This symbol, if defined, indicates that the program should
+ * use the routine my_binmode(FILE *fp, char iotype) to insure
+ * that a file is in "binary" mode -- that is, that no translation
+ * of bytes occurs on read or write operations.
+ */
+#undef USEMYBINMODE
+
+/* Stat_t:
+ * This symbol holds the type used to declare buffers for information
+ * returned by stat(). It's usually just struct stat. It may be necessary
+ * to include <sys/stat.h> and <sys/types.h> to get any typedef'ed
+ * information.
+ */
+#define Stat_t struct stat
+
+/* USE_STAT_RDEV:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_rdev
+ */
+#define USE_STAT_RDEV / **/
+
+/* ACME_MESS:
+ * This symbol, if defined, indicates that error messages should be
+ * should be generated in a format that allows the use of the Acme
+ * GUI/editor's autofind feature.
+ */
+#undef ACME_MESS /**/
+
+/* UNLINK_ALL_VERSIONS:
+ * This symbol, if defined, indicates that the program should arrange
+ * to remove all versions of a file if unlink() is called. This is
+ * probably only relevant for VMS.
+ */
+/* #define UNLINK_ALL_VERSIONS / **/
+
+/* VMS:
+ * This symbol, if defined, indicates that the program is running under
+ * VMS. It is currently automatically set by cpps running under VMS,
+ * and is included here for completeness only.
+ */
+/* #define VMS / **/
+
+/* ALTERNATE_SHEBANG:
+ * This symbol, if defined, contains a "magic" string which may be used
+ * as the first line of a Perl program designed to be executed directly
+ * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG
+ * begins with a character other then #, then Perl will only treat
+ * it as a command line if if finds the string "perl" in the first
+ * word; otherwise it's treated as the first line of code in the script.
+ * (IOW, Perl won't hand off to another interpreter via an alternate
+ * shebang sequence that might be legal Perl code.)
+ */
+/* #define ALTERNATE_SHEBANG "#!" / **/
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+# include <signal.h>
+#endif
+
+#ifndef SIGABRT
+# define SIGABRT SIGILL
+#endif
+#ifndef SIGILL
+# define SIGILL 6 /* blech */
+#endif
+#define ABORT() kill(getpid(),SIGABRT);
+
+/*
+ * fwrite1() should be a routine with the same calling sequence as fwrite(),
+ * but which outputs all of the bytes requested as a single stream (unlike
+ * fwrite() itself, which on some systems outputs several distinct records
+ * if the number_of_items parameter is >1).
+ */
+#define fwrite1 fwrite
+
+#define Stat(fname,bufptr) stat((fname),(bufptr))
+#define Fstat(fd,bufptr) fstat((fd),(bufptr))
+#define Fflush(fp) fflush(fp)
+#define Mkdir(path,mode) mkdir((path),(mode))
+
+#ifndef PERL_SYS_INIT
+#ifdef PERL_SCO5
+/* this should be set in a hint file, not here */
+# define PERL_SYS_INIT(c,v) fpsetmask(0); MALLOC_INIT
+#else
+# define PERL_SYS_INIT(c,v) MALLOC_INIT
+#endif
+#endif
+
+#ifndef PERL_SYS_TERM
+#define PERL_SYS_TERM() MALLOC_TERM
+#endif
+
+#define BIT_BUCKET "/dev/null"
+
+#define dXSUB_SYS
diff --git a/contrib/perl5/util.c b/contrib/perl5/util.c
new file mode 100644
index 000000000000..431c5fafb0f1
--- /dev/null
+++ b/contrib/perl5/util.c
@@ -0,0 +1,2879 @@
+/* util.c
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "Very useful, no doubt, that was to Saruman; yet it seems that he was
+ * not content." --Gandalf
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+#include <signal.h>
+#endif
+
+#ifndef SIG_ERR
+# define SIG_ERR ((Sighandler_t) -1)
+#endif
+
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+
+#ifdef I_VFORK
+# include <vfork.h>
+#endif
+
+/* Put this after #includes because fork and vfork prototypes may
+ conflict.
+*/
+#ifndef HAS_VFORK
+# define vfork fork
+#endif
+
+#ifdef I_FCNTL
+# include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+# include <sys/file.h>
+#endif
+
+#ifdef I_SYS_WAIT
+# include <sys/wait.h>
+#endif
+
+#define FLUSH
+
+#ifdef LEAKTEST
+
+static void xstat _((int));
+long xcount[MAXXCOUNT];
+long lastxcount[MAXXCOUNT];
+long xycount[MAXXCOUNT][MAXYCOUNT];
+long lastxycount[MAXXCOUNT][MAXYCOUNT];
+
+#endif
+
+#ifndef MYMALLOC
+
+/* paranoid version of malloc */
+
+/* NOTE: Do not call the next three routines directly. Use the macros
+ * in handy.h, so that we can easily redefine everything to do tracking of
+ * allocated hunks back to the original New to track down any memory leaks.
+ * XXX This advice seems to be widely ignored :-( --AD August 1996.
+ */
+
+Malloc_t
+safemalloc(MEM_SIZE size)
+{
+ Malloc_t ptr;
+#ifdef HAS_64K_LIMIT
+ if (size > 0xffff) {
+ PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH;
+ my_exit(1);
+ }
+#endif /* HAS_64K_LIMIT */
+#ifdef DEBUGGING
+ if ((long)size < 0)
+ croak("panic: malloc");
+#endif
+ ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
+#if !(defined(I286) || defined(atarist))
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
+#else
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
+#endif
+ if (ptr != Nullch)
+ return ptr;
+ else if (PL_nomemok)
+ return Nullch;
+ else {
+ PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
+ my_exit(1);
+ return Nullch;
+ }
+ /*NOTREACHED*/
+}
+
+/* paranoid version of realloc */
+
+Malloc_t
+saferealloc(Malloc_t where,MEM_SIZE size)
+{
+ Malloc_t ptr;
+#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
+ Malloc_t PerlMem_realloc();
+#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
+
+#ifdef HAS_64K_LIMIT
+ if (size > 0xffff) {
+ PerlIO_printf(PerlIO_stderr(),
+ "Reallocation too large: %lx\n", size) FLUSH;
+ my_exit(1);
+ }
+#endif /* HAS_64K_LIMIT */
+ if (!size) {
+ safefree(where);
+ return NULL;
+ }
+
+ if (!where)
+ return safemalloc(size);
+#ifdef DEBUGGING
+ if ((long)size < 0)
+ croak("panic: realloc");
+#endif
+ ptr = PerlMem_realloc(where,size);
+
+#if !(defined(I286) || defined(atarist))
+ DEBUG_m( {
+ PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,PL_an++);
+ PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
+ } )
+#else
+ DEBUG_m( {
+ PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++);
+ PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
+ } )
+#endif
+
+ if (ptr != Nullch)
+ return ptr;
+ else if (PL_nomemok)
+ return Nullch;
+ else {
+ PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
+ my_exit(1);
+ return Nullch;
+ }
+ /*NOTREACHED*/
+}
+
+/* safe version of free */
+
+Free_t
+safefree(Malloc_t where)
+{
+#if !(defined(I286) || defined(atarist))
+ DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,PL_an++));
+#else
+ DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,PL_an++));
+#endif
+ if (where) {
+ /*SUPPRESS 701*/
+ PerlMem_free(where);
+ }
+}
+
+/* safe version of calloc */
+
+Malloc_t
+safecalloc(MEM_SIZE count, MEM_SIZE size)
+{
+ Malloc_t ptr;
+
+#ifdef HAS_64K_LIMIT
+ if (size * count > 0xffff) {
+ PerlIO_printf(PerlIO_stderr(),
+ "Allocation too large: %lx\n", size * count) FLUSH;
+ my_exit(1);
+ }
+#endif /* HAS_64K_LIMIT */
+#ifdef DEBUGGING
+ if ((long)size < 0 || (long)count < 0)
+ croak("panic: calloc");
+#endif
+ size *= count;
+ ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
+#if !(defined(I286) || defined(atarist))
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
+#else
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
+#endif
+ if (ptr != Nullch) {
+ memset((void*)ptr, 0, size);
+ return ptr;
+ }
+ else if (PL_nomemok)
+ return Nullch;
+ else {
+ PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
+ my_exit(1);
+ return Nullch;
+ }
+ /*NOTREACHED*/
+}
+
+#endif /* !MYMALLOC */
+
+#ifdef LEAKTEST
+
+struct mem_test_strut {
+ union {
+ long type;
+ char c[2];
+ } u;
+ long size;
+};
+
+# define ALIGN sizeof(struct mem_test_strut)
+
+# define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
+# define typeof_chunk(ch) \
+ (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
+# define set_typeof_chunk(ch,t) \
+ (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
+#define SIZE_TO_Y(size) ( (size) > MAXY_SIZE \
+ ? MAXYCOUNT - 1 \
+ : ( (size) > 40 \
+ ? ((size) - 1)/8 + 5 \
+ : ((size) - 1)/4))
+
+Malloc_t
+safexmalloc(I32 x, MEM_SIZE size)
+{
+ register char* where = (char*)safemalloc(size + ALIGN);
+
+ xcount[x] += size;
+ xycount[x][SIZE_TO_Y(size)]++;
+ set_typeof_chunk(where, x);
+ sizeof_chunk(where) = size;
+ return (Malloc_t)(where + ALIGN);
+}
+
+Malloc_t
+safexrealloc(Malloc_t wh, MEM_SIZE size)
+{
+ char *where = (char*)wh;
+
+ if (!wh)
+ return safexmalloc(0,size);
+
+ {
+ MEM_SIZE old = sizeof_chunk(where - ALIGN);
+ int t = typeof_chunk(where - ALIGN);
+ register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
+
+ xycount[t][SIZE_TO_Y(old)]--;
+ xycount[t][SIZE_TO_Y(size)]++;
+ xcount[t] += size - old;
+ sizeof_chunk(new) = size;
+ return (Malloc_t)(new + ALIGN);
+ }
+}
+
+void
+safexfree(Malloc_t wh)
+{
+ I32 x;
+ char *where = (char*)wh;
+ MEM_SIZE size;
+
+ if (!where)
+ return;
+ where -= ALIGN;
+ size = sizeof_chunk(where);
+ x = where[0] + 100 * where[1];
+ xcount[x] -= size;
+ xycount[x][SIZE_TO_Y(size)]--;
+ safefree(where);
+}
+
+Malloc_t
+safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
+{
+ register char * where = (char*)safexmalloc(x, size * count + ALIGN);
+ xcount[x] += size;
+ xycount[x][SIZE_TO_Y(size)]++;
+ memset((void*)(where + ALIGN), 0, size * count);
+ set_typeof_chunk(where, x);
+ sizeof_chunk(where) = size;
+ return (Malloc_t)(where + ALIGN);
+}
+
+static void
+xstat(int flag)
+{
+ register I32 i, j, total = 0;
+ I32 subtot[MAXYCOUNT];
+
+ for (j = 0; j < MAXYCOUNT; j++) {
+ subtot[j] = 0;
+ }
+
+ PerlIO_printf(PerlIO_stderr(), " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total);
+ for (i = 0; i < MAXXCOUNT; i++) {
+ total += xcount[i];
+ for (j = 0; j < MAXYCOUNT; j++) {
+ subtot[j] += xycount[i][j];
+ }
+ if (flag == 0
+ ? xcount[i] /* Have something */
+ : (flag == 2
+ ? xcount[i] != lastxcount[i] /* Changed */
+ : xcount[i] > lastxcount[i])) { /* Growed */
+ PerlIO_printf(PerlIO_stderr(),"%2d %02d %7ld ", i / 100, i % 100,
+ flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
+ lastxcount[i] = xcount[i];
+ for (j = 0; j < MAXYCOUNT; j++) {
+ if ( flag == 0
+ ? xycount[i][j] /* Have something */
+ : (flag == 2
+ ? xycount[i][j] != lastxycount[i][j] /* Changed */
+ : xycount[i][j] > lastxycount[i][j])) { /* Growed */
+ PerlIO_printf(PerlIO_stderr(),"%3ld ",
+ flag == 2
+ ? xycount[i][j] - lastxycount[i][j]
+ : xycount[i][j]);
+ lastxycount[i][j] = xycount[i][j];
+ } else {
+ PerlIO_printf(PerlIO_stderr(), " . ", xycount[i][j]);
+ }
+ }
+ PerlIO_printf(PerlIO_stderr(), "\n");
+ }
+ }
+ if (flag != 2) {
+ PerlIO_printf(PerlIO_stderr(), "Total %7ld ", total);
+ for (j = 0; j < MAXYCOUNT; j++) {
+ if (subtot[j]) {
+ PerlIO_printf(PerlIO_stderr(), "%3ld ", subtot[j]);
+ } else {
+ PerlIO_printf(PerlIO_stderr(), " . ");
+ }
+ }
+ PerlIO_printf(PerlIO_stderr(), "\n");
+ }
+}
+
+#endif /* LEAKTEST */
+
+/* copy a string up to some (non-backslashed) delimiter, if any */
+
+char *
+delimcpy(register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
+{
+ register I32 tolen;
+ for (tolen = 0; from < fromend; from++, tolen++) {
+ if (*from == '\\') {
+ if (from[1] == delim)
+ from++;
+ else {
+ if (to < toend)
+ *to++ = *from;
+ tolen++;
+ from++;
+ }
+ }
+ else if (*from == delim)
+ break;
+ if (to < toend)
+ *to++ = *from;
+ }
+ if (to < toend)
+ *to = '\0';
+ *retlen = tolen;
+ return from;
+}
+
+/* return ptr to little string in big string, NULL if not found */
+/* This routine was donated by Corey Satten. */
+
+char *
+instr(register char *big, register char *little)
+{
+ register char *s, *x;
+ register I32 first;
+
+ if (!little)
+ return big;
+ first = *little++;
+ if (!first)
+ return big;
+ while (*big) {
+ if (*big++ != first)
+ continue;
+ for (x=big,s=little; *s; /**/ ) {
+ if (!*x)
+ return Nullch;
+ if (*s++ != *x++) {
+ s--;
+ break;
+ }
+ }
+ if (!*s)
+ return big-1;
+ }
+ return Nullch;
+}
+
+/* same as instr but allow embedded nulls */
+
+char *
+ninstr(register char *big, register char *bigend, char *little, char *lend)
+{
+ register char *s, *x;
+ register I32 first = *little;
+ register char *littleend = lend;
+
+ if (!first && little >= littleend)
+ return big;
+ if (bigend - big < littleend - little)
+ return Nullch;
+ bigend -= littleend - little++;
+ while (big <= bigend) {
+ if (*big++ != first)
+ continue;
+ for (x=big,s=little; s < littleend; /**/ ) {
+ if (*s++ != *x++) {
+ s--;
+ break;
+ }
+ }
+ if (s >= littleend)
+ return big-1;
+ }
+ return Nullch;
+}
+
+/* reverse of the above--find last substring */
+
+char *
+rninstr(register char *big, char *bigend, char *little, char *lend)
+{
+ register char *bigbeg;
+ register char *s, *x;
+ register I32 first = *little;
+ register char *littleend = lend;
+
+ if (!first && little >= littleend)
+ return bigend;
+ bigbeg = big;
+ big = bigend - (littleend - little++);
+ while (big >= bigbeg) {
+ if (*big-- != first)
+ continue;
+ for (x=big+2,s=little; s < littleend; /**/ ) {
+ if (*s++ != *x++) {
+ s--;
+ break;
+ }
+ }
+ if (s >= littleend)
+ return big+1;
+ }
+ return Nullch;
+}
+
+/*
+ * Set up for a new ctype locale.
+ */
+void
+perl_new_ctype(char *newctype)
+{
+#ifdef USE_LOCALE_CTYPE
+
+ int i;
+
+ for (i = 0; i < 256; i++) {
+ if (isUPPER_LC(i))
+ fold_locale[i] = toLOWER_LC(i);
+ else if (isLOWER_LC(i))
+ fold_locale[i] = toUPPER_LC(i);
+ else
+ fold_locale[i] = i;
+ }
+
+#endif /* USE_LOCALE_CTYPE */
+}
+
+/*
+ * Set up for a new collation locale.
+ */
+void
+perl_new_collate(char *newcoll)
+{
+#ifdef USE_LOCALE_COLLATE
+
+ if (! newcoll) {
+ if (PL_collation_name) {
+ ++PL_collation_ix;
+ Safefree(PL_collation_name);
+ PL_collation_name = NULL;
+ PL_collation_standard = TRUE;
+ PL_collxfrm_base = 0;
+ PL_collxfrm_mult = 2;
+ }
+ return;
+ }
+
+ if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
+ ++PL_collation_ix;
+ Safefree(PL_collation_name);
+ PL_collation_name = savepv(newcoll);
+ PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
+
+ {
+ /* 2: at most so many chars ('a', 'b'). */
+ /* 50: surely no system expands a char more. */
+#define XFRMBUFSIZE (2 * 50)
+ char xbuf[XFRMBUFSIZE];
+ Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
+ Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
+ SSize_t mult = fb - fa;
+ if (mult < 1)
+ croak("strxfrm() gets absurd");
+ PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
+ PL_collxfrm_mult = mult;
+ }
+ }
+
+#endif /* USE_LOCALE_COLLATE */
+}
+
+/*
+ * Set up for a new numeric locale.
+ */
+void
+perl_new_numeric(char *newnum)
+{
+#ifdef USE_LOCALE_NUMERIC
+
+ if (! newnum) {
+ if (PL_numeric_name) {
+ Safefree(PL_numeric_name);
+ PL_numeric_name = NULL;
+ PL_numeric_standard = TRUE;
+ PL_numeric_local = TRUE;
+ }
+ return;
+ }
+
+ if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
+ Safefree(PL_numeric_name);
+ PL_numeric_name = savepv(newnum);
+ PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
+ PL_numeric_local = TRUE;
+ }
+
+#endif /* USE_LOCALE_NUMERIC */
+}
+
+void
+perl_set_numeric_standard(void)
+{
+#ifdef USE_LOCALE_NUMERIC
+
+ if (! PL_numeric_standard) {
+ setlocale(LC_NUMERIC, "C");
+ PL_numeric_standard = TRUE;
+ PL_numeric_local = FALSE;
+ }
+
+#endif /* USE_LOCALE_NUMERIC */
+}
+
+void
+perl_set_numeric_local(void)
+{
+#ifdef USE_LOCALE_NUMERIC
+
+ if (! PL_numeric_local) {
+ setlocale(LC_NUMERIC, PL_numeric_name);
+ PL_numeric_standard = FALSE;
+ PL_numeric_local = TRUE;
+ }
+
+#endif /* USE_LOCALE_NUMERIC */
+}
+
+
+/*
+ * Initialize locale awareness.
+ */
+int
+perl_init_i18nl10n(int printwarn)
+{
+ int ok = 1;
+ /* returns
+ * 1 = set ok or not applicable,
+ * 0 = fallback to C locale,
+ * -1 = fallback to C locale failed
+ */
+
+#ifdef USE_LOCALE
+
+#ifdef USE_LOCALE_CTYPE
+ char *curctype = NULL;
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ char *curcoll = NULL;
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ char *curnum = NULL;
+#endif /* USE_LOCALE_NUMERIC */
+ char *lc_all = PerlEnv_getenv("LC_ALL");
+ char *lang = PerlEnv_getenv("LANG");
+ bool setlocale_failure = FALSE;
+
+#ifdef LOCALE_ENVIRON_REQUIRED
+
+ /*
+ * Ultrix setlocale(..., "") fails if there are no environment
+ * variables from which to get a locale name.
+ */
+
+ bool done = FALSE;
+
+#ifdef LC_ALL
+ if (lang) {
+ if (setlocale(LC_ALL, ""))
+ done = TRUE;
+ else
+ setlocale_failure = TRUE;
+ }
+ if (!setlocale_failure)
+#endif /* LC_ALL */
+ {
+#ifdef USE_LOCALE_CTYPE
+ if (! (curctype = setlocale(LC_CTYPE,
+ (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ if (! (curcoll = setlocale(LC_COLLATE,
+ (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ if (! (curnum = setlocale(LC_NUMERIC,
+ (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_NUMERIC */
+ }
+
+#else /* !LOCALE_ENVIRON_REQUIRED */
+
+#ifdef LC_ALL
+
+ if (! setlocale(LC_ALL, ""))
+ setlocale_failure = TRUE;
+ else {
+#ifdef USE_LOCALE_CTYPE
+ curctype = setlocale(LC_CTYPE, Nullch);
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ curcoll = setlocale(LC_COLLATE, Nullch);
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ curnum = setlocale(LC_NUMERIC, Nullch);
+#endif /* USE_LOCALE_NUMERIC */
+ }
+
+#else /* !LC_ALL */
+
+#ifdef USE_LOCALE_CTYPE
+ if (! (curctype = setlocale(LC_CTYPE, "")))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ if (! (curcoll = setlocale(LC_COLLATE, "")))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ if (! (curnum = setlocale(LC_NUMERIC, "")))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_NUMERIC */
+
+#endif /* LC_ALL */
+
+#endif /* !LOCALE_ENVIRON_REQUIRED */
+
+ if (setlocale_failure) {
+ char *p;
+ bool locwarn = (printwarn > 1 ||
+ printwarn &&
+ (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)));
+
+ if (locwarn) {
+#ifdef LC_ALL
+
+ PerlIO_printf(PerlIO_stderr(),
+ "perl: warning: Setting locale failed.\n");
+
+#else /* !LC_ALL */
+
+ PerlIO_printf(PerlIO_stderr(),
+ "perl: warning: Setting locale failed for the categories:\n\t");
+#ifdef USE_LOCALE_CTYPE
+ if (! curctype)
+ PerlIO_printf(PerlIO_stderr(), "LC_CTYPE ");
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ if (! curcoll)
+ PerlIO_printf(PerlIO_stderr(), "LC_COLLATE ");
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ if (! curnum)
+ PerlIO_printf(PerlIO_stderr(), "LC_NUMERIC ");
+#endif /* USE_LOCALE_NUMERIC */
+ PerlIO_printf(PerlIO_stderr(), "\n");
+
+#endif /* LC_ALL */
+
+ PerlIO_printf(PerlIO_stderr(),
+ "perl: warning: Please check that your locale settings:\n");
+
+ PerlIO_printf(PerlIO_stderr(),
+ "\tLC_ALL = %c%s%c,\n",
+ lc_all ? '"' : '(',
+ lc_all ? lc_all : "unset",
+ lc_all ? '"' : ')');
+
+ {
+ char **e;
+ for (e = environ; *e; e++) {
+ if (strnEQ(*e, "LC_", 3)
+ && strnNE(*e, "LC_ALL=", 7)
+ && (p = strchr(*e, '=')))
+ PerlIO_printf(PerlIO_stderr(), "\t%.*s = \"%s\",\n",
+ (int)(p - *e), *e, p + 1);
+ }
+ }
+
+ PerlIO_printf(PerlIO_stderr(),
+ "\tLANG = %c%s%c\n",
+ lang ? '"' : '(',
+ lang ? lang : "unset",
+ lang ? '"' : ')');
+
+ PerlIO_printf(PerlIO_stderr(),
+ " are supported and installed on your system.\n");
+ }
+
+#ifdef LC_ALL
+
+ if (setlocale(LC_ALL, "C")) {
+ if (locwarn)
+ PerlIO_printf(PerlIO_stderr(),
+ "perl: warning: Falling back to the standard locale (\"C\").\n");
+ ok = 0;
+ }
+ else {
+ if (locwarn)
+ PerlIO_printf(PerlIO_stderr(),
+ "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
+ ok = -1;
+ }
+
+#else /* ! LC_ALL */
+
+ if (0
+#ifdef USE_LOCALE_CTYPE
+ || !(curctype || setlocale(LC_CTYPE, "C"))
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ || !(curcoll || setlocale(LC_COLLATE, "C"))
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ || !(curnum || setlocale(LC_NUMERIC, "C"))
+#endif /* USE_LOCALE_NUMERIC */
+ )
+ {
+ if (locwarn)
+ PerlIO_printf(PerlIO_stderr(),
+ "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
+ ok = -1;
+ }
+
+#endif /* ! LC_ALL */
+
+#ifdef USE_LOCALE_CTYPE
+ curctype = setlocale(LC_CTYPE, Nullch);
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ curcoll = setlocale(LC_COLLATE, Nullch);
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ curnum = setlocale(LC_NUMERIC, Nullch);
+#endif /* USE_LOCALE_NUMERIC */
+ }
+
+#ifdef USE_LOCALE_CTYPE
+ perl_new_ctype(curctype);
+#endif /* USE_LOCALE_CTYPE */
+
+#ifdef USE_LOCALE_COLLATE
+ perl_new_collate(curcoll);
+#endif /* USE_LOCALE_COLLATE */
+
+#ifdef USE_LOCALE_NUMERIC
+ perl_new_numeric(curnum);
+#endif /* USE_LOCALE_NUMERIC */
+
+#endif /* USE_LOCALE */
+
+ return ok;
+}
+
+/* Backwards compatibility. */
+int
+perl_init_i18nl14n(int printwarn)
+{
+ return perl_init_i18nl10n(printwarn);
+}
+
+#ifdef USE_LOCALE_COLLATE
+
+/*
+ * mem_collxfrm() is a bit like strxfrm() but with two important
+ * differences. First, it handles embedded NULs. Second, it allocates
+ * a bit more memory than needed for the transformed data itself.
+ * The real transformed data begins at offset sizeof(collationix).
+ * Please see sv_collxfrm() to see how this is used.
+ */
+char *
+mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen)
+{
+ char *xbuf;
+ STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
+
+ /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
+ /* the +1 is for the terminating NUL. */
+
+ xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
+ New(171, xbuf, xAlloc, char);
+ if (! xbuf)
+ goto bad;
+
+ *(U32*)xbuf = PL_collation_ix;
+ xout = sizeof(PL_collation_ix);
+ for (xin = 0; xin < len; ) {
+ SSize_t xused;
+
+ for (;;) {
+ xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
+ if (xused == -1)
+ goto bad;
+ if (xused < xAlloc - xout)
+ break;
+ xAlloc = (2 * xAlloc) + 1;
+ Renew(xbuf, xAlloc, char);
+ if (! xbuf)
+ goto bad;
+ }
+
+ xin += strlen(s + xin) + 1;
+ xout += xused;
+
+ /* Embedded NULs are understood but silently skipped
+ * because they make no sense in locale collation. */
+ }
+
+ xbuf[xout] = '\0';
+ *xlen = xout - sizeof(PL_collation_ix);
+ return xbuf;
+
+ bad:
+ Safefree(xbuf);
+ *xlen = 0;
+ return NULL;
+}
+
+#endif /* USE_LOCALE_COLLATE */
+
+void
+fbm_compile(SV *sv, U32 flags /* not used yet */)
+{
+ register unsigned char *s;
+ register unsigned char *table;
+ register U32 i;
+ register U32 len = SvCUR(sv);
+ I32 rarest = 0;
+ U32 frequency = 256;
+
+ sv_upgrade(sv, SVt_PVBM);
+ if (len > 255 || len == 0) /* TAIL might be on on a zero-length string. */
+ return; /* can't have offsets that big */
+ if (len > 2) {
+ Sv_Grow(sv,len + 258);
+ table = (unsigned char*)(SvPVX(sv) + len + 1);
+ s = table - 2;
+ for (i = 0; i < 256; i++) {
+ table[i] = len;
+ }
+ i = 0;
+ while (s >= (unsigned char*)(SvPVX(sv)))
+ {
+ if (table[*s] == len)
+ table[*s] = i;
+ s--,i++;
+ }
+ }
+ sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
+ SvVALID_on(sv);
+
+ s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
+ for (i = 0; i < len; i++) {
+ if (freq[s[i]] < frequency) {
+ rarest = i;
+ frequency = freq[s[i]];
+ }
+ }
+ BmRARE(sv) = s[rarest];
+ BmPREVIOUS(sv) = rarest;
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
+}
+
+char *
+fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
+{
+ register unsigned char *s;
+ register I32 tmp;
+ register I32 littlelen;
+ register unsigned char *little;
+ register unsigned char *table;
+ register unsigned char *olds;
+ register unsigned char *oldlittle;
+
+ if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
+ STRLEN len;
+ char *l = SvPV(littlestr,len);
+ if (!len) {
+ if (SvTAIL(littlestr)) { /* Can be only 0-len constant
+ substr => we can ignore SvVALID */
+ if (PL_multiline) {
+ char *t = "\n";
+ if ((s = (unsigned char*)ninstr((char*)big, (char*)bigend,
+ t, t + len))) {
+ return (char*)s;
+ }
+ }
+ if (bigend > big && bigend[-1] == '\n')
+ return (char *)(bigend - 1);
+ else
+ return (char *) bigend;
+ }
+ return (char*)big;
+ }
+ return ninstr((char*)big,(char*)bigend, l, l + len);
+ }
+
+ littlelen = SvCUR(littlestr);
+ if (SvTAIL(littlestr) && !PL_multiline) { /* tail anchored? */
+ if (littlelen > bigend - big)
+ return Nullch;
+ little = (unsigned char*)SvPVX(littlestr);
+ s = bigend - littlelen;
+ if (s > big
+ && bigend[-1] == '\n'
+ && s[-1] == *little && memEQ((char*)s - 1,(char*)little,littlelen))
+ return (char*)s - 1; /* how sweet it is */
+ else if (*s == *little && memEQ((char*)s,(char*)little,littlelen))
+ return (char*)s; /* how sweet it is */
+ return Nullch;
+ }
+ if (littlelen <= 2) {
+ unsigned char c1 = (unsigned char)SvPVX(littlestr)[0];
+ unsigned char c2 = (unsigned char)SvPVX(littlestr)[1];
+ /* This may do extra comparisons if littlelen == 2, but this
+ should be hidden in the noise since we do less indirection. */
+
+ s = big;
+ bigend -= littlelen;
+ while (s <= bigend) {
+ if (s[0] == c1
+ && (littlelen == 1 || s[1] == c2)
+ && (!SvTAIL(littlestr)
+ || s == bigend
+ || s[littlelen] == '\n')) /* Automatically multiline */
+ {
+ return (char*)s;
+ }
+ s++;
+ }
+ return Nullch;
+ }
+ table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1);
+ if (--littlelen >= bigend - big)
+ return Nullch;
+ s = big + littlelen;
+ oldlittle = little = table - 2;
+ if (s < bigend) {
+ top2:
+ /*SUPPRESS 560*/
+ if (tmp = table[*s]) {
+#ifdef POINTERRIGOR
+ if (bigend - s > tmp) {
+ s += tmp;
+ goto top2;
+ }
+#else
+ if ((s += tmp) < bigend)
+ goto top2;
+#endif
+ return Nullch;
+ }
+ else {
+ tmp = littlelen; /* less expensive than calling strncmp() */
+ olds = s;
+ while (tmp--) {
+ if (*--s == *--little)
+ continue;
+ differ:
+ s = olds + 1; /* here we pay the price for failure */
+ little = oldlittle;
+ if (s < bigend) /* fake up continue to outer loop */
+ goto top2;
+ return Nullch;
+ }
+ if (SvTAIL(littlestr) /* automatically multiline */
+ && olds + 1 != bigend
+ && olds[1] != '\n')
+ goto differ;
+ return (char *)s;
+ }
+ }
+ return Nullch;
+}
+
+/* start_shift, end_shift are positive quantities which give offsets
+ of ends of some substring of bigstr.
+ If `last' we want the last occurence.
+ old_posp is the way of communication between consequent calls if
+ the next call needs to find the .
+ The initial *old_posp should be -1.
+ Note that we do not take into account SvTAIL, so it may give wrong
+ positives if _ALL flag is set.
+ */
+
+char *
+screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
+{
+ dTHR;
+ register unsigned char *s, *x;
+ register unsigned char *big;
+ register I32 pos;
+ register I32 previous;
+ register I32 first;
+ register unsigned char *little;
+ register I32 stop_pos;
+ register unsigned char *littleend;
+ I32 found = 0;
+
+ if (*old_posp == -1
+ ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
+ : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0))
+ return Nullch;
+ little = (unsigned char *)(SvPVX(littlestr));
+ littleend = little + SvCUR(littlestr);
+ first = *little++;
+ /* The value of pos we can start at: */
+ previous = BmPREVIOUS(littlestr);
+ big = (unsigned char *)(SvPVX(bigstr));
+ /* The value of pos we can stop at: */
+ stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
+ if (previous + start_shift > stop_pos) return Nullch;
+ while (pos < previous + start_shift) {
+ if (!(pos += PL_screamnext[pos]))
+ return Nullch;
+ }
+#ifdef POINTERRIGOR
+ do {
+ if (pos >= stop_pos) break;
+ if (big[pos-previous] != first)
+ continue;
+ for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
+ if (*s++ != *x++) {
+ s--;
+ break;
+ }
+ }
+ if (s == littleend) {
+ *old_posp = pos;
+ if (!last) return (char *)(big+pos-previous);
+ found = 1;
+ }
+ } while ( pos += PL_screamnext[pos] );
+ return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch;
+#else /* !POINTERRIGOR */
+ big -= previous;
+ do {
+ if (pos >= stop_pos) break;
+ if (big[pos] != first)
+ continue;
+ for (x=big+pos+1,s=little; s < littleend; /**/ ) {
+ if (*s++ != *x++) {
+ s--;
+ break;
+ }
+ }
+ if (s == littleend) {
+ *old_posp = pos;
+ if (!last) return (char *)(big+pos);
+ found = 1;
+ }
+ } while ( pos += PL_screamnext[pos] );
+ return (last && found) ? (char *)(big+(*old_posp)) : Nullch;
+#endif /* POINTERRIGOR */
+}
+
+I32
+ibcmp(char *s1, char *s2, register I32 len)
+{
+ register U8 *a = (U8 *)s1;
+ register U8 *b = (U8 *)s2;
+ while (len--) {
+ if (*a != *b && *a != fold[*b])
+ return 1;
+ a++,b++;
+ }
+ return 0;
+}
+
+I32
+ibcmp_locale(char *s1, char *s2, register I32 len)
+{
+ register U8 *a = (U8 *)s1;
+ register U8 *b = (U8 *)s2;
+ while (len--) {
+ if (*a != *b && *a != fold_locale[*b])
+ return 1;
+ a++,b++;
+ }
+ return 0;
+}
+
+/* copy a string to a safe spot */
+
+char *
+savepv(char *sv)
+{
+ register char *newaddr;
+
+ New(902,newaddr,strlen(sv)+1,char);
+ (void)strcpy(newaddr,sv);
+ return newaddr;
+}
+
+/* same thing but with a known length */
+
+char *
+savepvn(char *sv, register I32 len)
+{
+ register char *newaddr;
+
+ New(903,newaddr,len+1,char);
+ Copy(sv,newaddr,len,char); /* might not be null terminated */
+ newaddr[len] = '\0'; /* is now */
+ return newaddr;
+}
+
+/* the SV for form() and mess() is not kept in an arena */
+
+STATIC SV *
+mess_alloc(void)
+{
+ SV *sv;
+ XPVMG *any;
+
+ /* Create as PVMG now, to avoid any upgrading later */
+ New(905, sv, 1, SV);
+ Newz(905, any, 1, XPVMG);
+ SvFLAGS(sv) = SVt_PVMG;
+ SvANY(sv) = (void*)any;
+ SvREFCNT(sv) = 1 << 30; /* practically infinite */
+ return sv;
+}
+
+char *
+form(const char* pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ if (!PL_mess_sv)
+ PL_mess_sv = mess_alloc();
+ sv_vsetpvfn(PL_mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+ return SvPVX(PL_mess_sv);
+}
+
+char *
+mess(const char *pat, va_list *args)
+{
+ SV *sv;
+ static char dgd[] = " during global destruction.\n";
+
+ if (!PL_mess_sv)
+ PL_mess_sv = mess_alloc();
+ sv = PL_mess_sv;
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
+ dTHR;
+ if (PL_dirty)
+ sv_catpv(sv, dgd);
+ else {
+ if (PL_curcop->cop_line)
+ sv_catpvf(sv, " at %_ line %ld",
+ GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
+ if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
+ bool line_mode = (RsSIMPLE(PL_rs) &&
+ SvLEN(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
+ sv_catpvf(sv, ", <%s> %s %ld",
+ PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
+ line_mode ? "line" : "chunk",
+ (long)IoLINES(GvIOp(PL_last_in_gv)));
+ }
+ sv_catpv(sv, ".\n");
+ }
+ }
+ return SvPVX(sv);
+}
+
+OP *
+die(const char* pat, ...)
+{
+ dTHR;
+ va_list args;
+ char *message;
+ int was_in_eval = PL_in_eval;
+ HV *stash;
+ GV *gv;
+ CV *cv;
+
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p: die: curstack = %p, mainstack = %p\n",
+ thr, PL_curstack, PL_mainstack));
+
+ va_start(args, pat);
+ message = pat ? mess(pat, &args) : Nullch;
+ va_end(args);
+
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p: die: message = %s\ndiehook = %p\n",
+ thr, message, PL_diehook));
+ if (PL_diehook) {
+ /* sv_2cv might call croak() */
+ SV *olddiehook = PL_diehook;
+ ENTER;
+ SAVESPTR(PL_diehook);
+ PL_diehook = Nullsv;
+ cv = sv_2cv(olddiehook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ if(message) {
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+ }
+ else {
+ msg = ERRSV;
+ }
+
+ PUSHSTACKi(PERLSI_DIEHOOK);
+ PUSHMARK(SP);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ POPSTACK;
+ LEAVE;
+ }
+ }
+
+ PL_restartop = die_where(message);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
+ thr, PL_restartop, was_in_eval, PL_top_env));
+ if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
+ JMPENV_JUMP(3);
+ return PL_restartop;
+}
+
+void
+croak(const char* pat, ...)
+{
+ dTHR;
+ va_list args;
+ char *message;
+ HV *stash;
+ GV *gv;
+ CV *cv;
+
+ va_start(args, pat);
+ message = mess(pat, &args);
+ va_end(args);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+ if (PL_diehook) {
+ /* sv_2cv might call croak() */
+ SV *olddiehook = PL_diehook;
+ ENTER;
+ SAVESPTR(PL_diehook);
+ PL_diehook = Nullsv;
+ cv = sv_2cv(olddiehook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+
+ PUSHSTACKi(PERLSI_DIEHOOK);
+ PUSHMARK(SP);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ POPSTACK;
+ LEAVE;
+ }
+ }
+ if (PL_in_eval) {
+ PL_restartop = die_where(message);
+ JMPENV_JUMP(3);
+ }
+ PerlIO_puts(PerlIO_stderr(),message);
+ (void)PerlIO_flush(PerlIO_stderr());
+ my_failure_exit();
+}
+
+void
+warn(const char* pat,...)
+{
+ va_list args;
+ char *message;
+ HV *stash;
+ GV *gv;
+ CV *cv;
+
+ va_start(args, pat);
+ message = mess(pat, &args);
+ va_end(args);
+
+ if (PL_warnhook) {
+ /* sv_2cv might call warn() */
+ dTHR;
+ SV *oldwarnhook = PL_warnhook;
+ ENTER;
+ SAVESPTR(PL_warnhook);
+ PL_warnhook = Nullsv;
+ cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+
+ PUSHSTACKi(PERLSI_WARNHOOK);
+ PUSHMARK(SP);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ POPSTACK;
+ LEAVE;
+ return;
+ }
+ }
+ PerlIO_puts(PerlIO_stderr(),message);
+#ifdef LEAKTEST
+ DEBUG_L(*message == '!'
+ ? (xstat(message[1]=='!'
+ ? (message[2]=='!' ? 2 : 1)
+ : 0)
+ , 0)
+ : 0);
+#endif
+ (void)PerlIO_flush(PerlIO_stderr());
+}
+
+#ifndef VMS /* VMS' my_setenv() is in VMS.c */
+#ifndef WIN32
+void
+my_setenv(char *nam, char *val)
+{
+ register I32 i=setenv_getix(nam); /* where does it go? */
+
+ if (environ == PL_origenviron) { /* need we copy environment? */
+ I32 j;
+ I32 max;
+ char **tmpenv;
+
+ /*SUPPRESS 530*/
+ for (max = i; environ[max]; max++) ;
+ New(901,tmpenv, max+2, char*);
+ for (j=0; j<max; j++) /* copy environment */
+ tmpenv[j] = savepv(environ[j]);
+ tmpenv[max] = Nullch;
+ environ = tmpenv; /* tell exec where it is now */
+ }
+ if (!val) {
+ Safefree(environ[i]);
+ while (environ[i]) {
+ environ[i] = environ[i+1];
+ i++;
+ }
+ return;
+ }
+ if (!environ[i]) { /* does not exist yet */
+ Renew(environ, i+2, char*); /* just expand it a bit */
+ environ[i+1] = Nullch; /* make sure it's null terminated */
+ }
+ else
+ Safefree(environ[i]);
+ New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
+#ifndef MSDOS
+ (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
+#else
+ /* MS-DOS requires environment variable names to be in uppercase */
+ /* [Tom Dinger, 27 August 1990: Well, it doesn't _require_ it, but
+ * some utilities and applications may break because they only look
+ * for upper case strings. (Fixed strupr() bug here.)]
+ */
+ strcpy(environ[i],nam); strupr(environ[i]);
+ (void)sprintf(environ[i] + strlen(nam),"=%s",val);
+#endif /* MSDOS */
+}
+
+#else /* if WIN32 */
+
+void
+my_setenv(char *nam,char *val)
+{
+
+#ifdef USE_WIN32_RTL_ENV
+
+ register char *envstr;
+ STRLEN namlen = strlen(nam);
+ STRLEN vallen;
+ char *oldstr = environ[setenv_getix(nam)];
+
+ /* putenv() has totally broken semantics in both the Borland
+ * and Microsoft CRTLs. They either store the passed pointer in
+ * the environment without making a copy, or make a copy and don't
+ * free it. And on top of that, they dont free() old entries that
+ * are being replaced/deleted. This means the caller must
+ * free any old entries somehow, or we end up with a memory
+ * leak every time my_setenv() is called. One might think
+ * one could directly manipulate environ[], like the UNIX code
+ * above, but direct changes to environ are not allowed when
+ * calling putenv(), since the RTLs maintain an internal
+ * *copy* of environ[]. Bad, bad, *bad* stink.
+ * GSAR 97-06-07
+ */
+
+ if (!val) {
+ if (!oldstr)
+ return;
+ val = "";
+ vallen = 0;
+ }
+ else
+ vallen = strlen(val);
+ New(904, envstr, namlen + vallen + 3, char);
+ (void)sprintf(envstr,"%s=%s",nam,val);
+ (void)PerlEnv_putenv(envstr);
+ if (oldstr)
+ Safefree(oldstr);
+#ifdef _MSC_VER
+ Safefree(envstr); /* MSVCRT leaks without this */
+#endif
+
+#else /* !USE_WIN32_RTL_ENV */
+
+ /* The sane way to deal with the environment.
+ * Has these advantages over putenv() & co.:
+ * * enables us to store a truly empty value in the
+ * environment (like in UNIX).
+ * * we don't have to deal with RTL globals, bugs and leaks.
+ * * Much faster.
+ * Why you may want to enable USE_WIN32_RTL_ENV:
+ * * environ[] and RTL functions will not reflect changes,
+ * which might be an issue if extensions want to access
+ * the env. via RTL. This cuts both ways, since RTL will
+ * not see changes made by extensions that call the Win32
+ * functions directly, either.
+ * GSAR 97-06-07
+ */
+ SetEnvironmentVariable(nam,val);
+
+#endif
+}
+
+#endif /* WIN32 */
+
+I32
+setenv_getix(char *nam)
+{
+ register I32 i, len = strlen(nam);
+
+ for (i = 0; environ[i]; i++) {
+ if (
+#ifdef WIN32
+ strnicmp(environ[i],nam,len) == 0
+#else
+ strnEQ(environ[i],nam,len)
+#endif
+ && environ[i][len] == '=')
+ break; /* strnEQ must come first to avoid */
+ } /* potential SEGV's */
+ return i;
+}
+
+#endif /* !VMS */
+
+#ifdef UNLINK_ALL_VERSIONS
+I32
+unlnk(f) /* unlink all versions of a file */
+char *f;
+{
+ I32 i;
+
+ for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
+ return i ? 0 : -1;
+}
+#endif
+
+#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
+char *
+my_bcopy(register char *from,register char *to,register I32 len)
+{
+ char *retval = to;
+
+ if (from - to >= 0) {
+ while (len--)
+ *to++ = *from++;
+ }
+ else {
+ to += len;
+ from += len;
+ while (len--)
+ *(--to) = *(--from);
+ }
+ return retval;
+}
+#endif
+
+#ifndef HAS_MEMSET
+void *
+my_memset(loc,ch,len)
+register char *loc;
+register I32 ch;
+register I32 len;
+{
+ char *retval = loc;
+
+ while (len--)
+ *loc++ = ch;
+ return retval;
+}
+#endif
+
+#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
+char *
+my_bzero(loc,len)
+register char *loc;
+register I32 len;
+{
+ char *retval = loc;
+
+ while (len--)
+ *loc++ = 0;
+ return retval;
+}
+#endif
+
+#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
+I32
+my_memcmp(s1,s2,len)
+char *s1;
+char *s2;
+register I32 len;
+{
+ register U8 *a = (U8 *)s1;
+ register U8 *b = (U8 *)s2;
+ register I32 tmp;
+
+ while (len--) {
+ if (tmp = *a++ - *b++)
+ return tmp;
+ }
+ return 0;
+}
+#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
+
+#ifndef HAS_VPRINTF
+
+#ifdef USE_CHAR_VSPRINTF
+char *
+#else
+int
+#endif
+vsprintf(dest, pat, args)
+char *dest;
+const char *pat;
+char *args;
+{
+ FILE fakebuf;
+
+ fakebuf._ptr = dest;
+ fakebuf._cnt = 32767;
+#ifndef _IOSTRG
+#define _IOSTRG 0
+#endif
+ fakebuf._flag = _IOWRT|_IOSTRG;
+ _doprnt(pat, args, &fakebuf); /* what a kludge */
+ (void)putc('\0', &fakebuf);
+#ifdef USE_CHAR_VSPRINTF
+ return(dest);
+#else
+ return 0; /* perl doesn't use return value */
+#endif
+}
+
+#endif /* HAS_VPRINTF */
+
+#ifdef MYSWAP
+#if BYTEORDER != 0x4321
+short
+my_swap(short s)
+{
+#if (BYTEORDER & 1) == 0
+ short result;
+
+ result = ((s & 255) << 8) + ((s >> 8) & 255);
+ return result;
+#else
+ return s;
+#endif
+}
+
+long
+my_htonl(long l)
+{
+ union {
+ long result;
+ char c[sizeof(long)];
+ } u;
+
+#if BYTEORDER == 0x1234
+ u.c[0] = (l >> 24) & 255;
+ u.c[1] = (l >> 16) & 255;
+ u.c[2] = (l >> 8) & 255;
+ u.c[3] = l & 255;
+ return u.result;
+#else
+#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
+ croak("Unknown BYTEORDER\n");
+#else
+ register I32 o;
+ register I32 s;
+
+ for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
+ u.c[o & 0xf] = (l >> s) & 255;
+ }
+ return u.result;
+#endif
+#endif
+}
+
+long
+my_ntohl(long l)
+{
+ union {
+ long l;
+ char c[sizeof(long)];
+ } u;
+
+#if BYTEORDER == 0x1234
+ u.c[0] = (l >> 24) & 255;
+ u.c[1] = (l >> 16) & 255;
+ u.c[2] = (l >> 8) & 255;
+ u.c[3] = l & 255;
+ return u.l;
+#else
+#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
+ croak("Unknown BYTEORDER\n");
+#else
+ register I32 o;
+ register I32 s;
+
+ u.l = l;
+ l = 0;
+ for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
+ l |= (u.c[o & 0xf] & 255) << s;
+ }
+ return l;
+#endif
+#endif
+}
+
+#endif /* BYTEORDER != 0x4321 */
+#endif /* MYSWAP */
+
+/*
+ * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
+ * If these functions are defined,
+ * the BYTEORDER is neither 0x1234 nor 0x4321.
+ * However, this is not assumed.
+ * -DWS
+ */
+
+#define HTOV(name,type) \
+ type \
+ name (n) \
+ register type n; \
+ { \
+ union { \
+ type value; \
+ char c[sizeof(type)]; \
+ } u; \
+ register I32 i; \
+ register I32 s; \
+ for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
+ u.c[i] = (n >> s) & 0xFF; \
+ } \
+ return u.value; \
+ }
+
+#define VTOH(name,type) \
+ type \
+ name (n) \
+ register type n; \
+ { \
+ union { \
+ type value; \
+ char c[sizeof(type)]; \
+ } u; \
+ register I32 i; \
+ register I32 s; \
+ u.value = n; \
+ n = 0; \
+ for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \
+ n += (u.c[i] & 0xFF) << s; \
+ } \
+ return n; \
+ }
+
+#if defined(HAS_HTOVS) && !defined(htovs)
+HTOV(htovs,short)
+#endif
+#if defined(HAS_HTOVL) && !defined(htovl)
+HTOV(htovl,long)
+#endif
+#if defined(HAS_VTOHS) && !defined(vtohs)
+VTOH(vtohs,short)
+#endif
+#if defined(HAS_VTOHL) && !defined(vtohl)
+VTOH(vtohl,long)
+#endif
+
+ /* VMS' my_popen() is in VMS.c, same with OS/2. */
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
+PerlIO *
+my_popen(char *cmd, char *mode)
+{
+ int p[2];
+ register I32 This, that;
+ register I32 pid;
+ SV *sv;
+ I32 doexec = strNE(cmd,"-");
+
+#ifdef OS2
+ if (doexec) {
+ return my_syspopen(cmd,mode);
+ }
+#endif
+ This = (*mode == 'w');
+ that = !This;
+ if (doexec && PL_tainting) {
+ taint_env();
+ taint_proper("Insecure %s%s", "EXEC");
+ }
+ if (PerlProc_pipe(p) < 0)
+ return Nullfp;
+ while ((pid = (doexec?vfork():fork())) < 0) {
+ if (errno != EAGAIN) {
+ PerlLIO_close(p[This]);
+ if (!doexec)
+ croak("Can't fork");
+ return Nullfp;
+ }
+ sleep(5);
+ }
+ if (pid == 0) {
+ GV* tmpgv;
+
+#undef THIS
+#undef THAT
+#define THIS that
+#define THAT This
+ PerlLIO_close(p[THAT]);
+ if (p[THIS] != (*mode == 'r')) {
+ PerlLIO_dup2(p[THIS], *mode == 'r');
+ PerlLIO_close(p[THIS]);
+ }
+ if (doexec) {
+#if !defined(HAS_FCNTL) || !defined(F_SETFD)
+ int fd;
+
+#ifndef NOFILE
+#define NOFILE 20
+#endif
+ for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
+ PerlLIO_close(fd);
+#endif
+ do_exec(cmd); /* may or may not use the shell */
+ PerlProc__exit(1);
+ }
+ /*SUPPRESS 560*/
+ if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
+ PL_forkprocess = 0;
+ hv_clear(PL_pidstatus); /* we have no children */
+ return Nullfp;
+#undef THIS
+#undef THAT
+ }
+ do_execfree(); /* free any memory malloced by child on vfork */
+ PerlLIO_close(p[that]);
+ if (p[that] < p[This]) {
+ PerlLIO_dup2(p[This], p[that]);
+ PerlLIO_close(p[This]);
+ p[This] = p[that];
+ }
+ sv = *av_fetch(PL_fdpid,p[This],TRUE);
+ (void)SvUPGRADE(sv,SVt_IV);
+ SvIVX(sv) = pid;
+ PL_forkprocess = pid;
+ return PerlIO_fdopen(p[This], mode);
+}
+#else
+#if defined(atarist) || defined(DJGPP)
+FILE *popen();
+PerlIO *
+my_popen(cmd,mode)
+char *cmd;
+char *mode;
+{
+ /* Needs work for PerlIO ! */
+ /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
+ return popen(PerlIO_exportFILE(cmd, 0), mode);
+}
+#endif
+
+#endif /* !DOSISH */
+
+#ifdef DUMP_FDS
+void
+dump_fds(char *s)
+{
+ int fd;
+ struct stat tmpstatbuf;
+
+ PerlIO_printf(PerlIO_stderr(),"%s", s);
+ for (fd = 0; fd < 32; fd++) {
+ if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
+ PerlIO_printf(PerlIO_stderr()," %d",fd);
+ }
+ PerlIO_printf(PerlIO_stderr(),"\n");
+}
+#endif /* DUMP_FDS */
+
+#ifndef HAS_DUP2
+int
+dup2(oldfd,newfd)
+int oldfd;
+int newfd;
+{
+#if defined(HAS_FCNTL) && defined(F_DUPFD)
+ if (oldfd == newfd)
+ return oldfd;
+ PerlLIO_close(newfd);
+ return fcntl(oldfd, F_DUPFD, newfd);
+#else
+#define DUP2_MAX_FDS 256
+ int fdtmp[DUP2_MAX_FDS];
+ I32 fdx = 0;
+ int fd;
+
+ if (oldfd == newfd)
+ return oldfd;
+ PerlLIO_close(newfd);
+ /* good enough for low fd's... */
+ while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
+ if (fdx >= DUP2_MAX_FDS) {
+ PerlLIO_close(fd);
+ fd = -1;
+ break;
+ }
+ fdtmp[fdx++] = fd;
+ }
+ while (fdx > 0)
+ PerlLIO_close(fdtmp[--fdx]);
+ return fd;
+#endif
+}
+#endif
+
+
+#ifdef HAS_SIGACTION
+
+Sighandler_t
+rsignal(int signo, Sighandler_t handler)
+{
+ struct sigaction act, oact;
+
+ act.sa_handler = handler;
+ sigemptyset(&act.sa_mask);
+ act.sa_flags = 0;
+#ifdef SA_RESTART
+ act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
+#endif
+#ifdef SA_NOCLDWAIT
+ if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+ act.sa_flags |= SA_NOCLDWAIT;
+#endif
+ if (sigaction(signo, &act, &oact) == -1)
+ return SIG_ERR;
+ else
+ return oact.sa_handler;
+}
+
+Sighandler_t
+rsignal_state(int signo)
+{
+ struct sigaction oact;
+
+ if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
+ return SIG_ERR;
+ else
+ return oact.sa_handler;
+}
+
+int
+rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save)
+{
+ struct sigaction act;
+
+ act.sa_handler = handler;
+ sigemptyset(&act.sa_mask);
+ act.sa_flags = 0;
+#ifdef SA_RESTART
+ act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
+#endif
+#ifdef SA_NOCLDWAIT
+ if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
+ act.sa_flags |= SA_NOCLDWAIT;
+#endif
+ return sigaction(signo, &act, save);
+}
+
+int
+rsignal_restore(int signo, Sigsave_t *save)
+{
+ return sigaction(signo, save, (struct sigaction *)NULL);
+}
+
+#else /* !HAS_SIGACTION */
+
+Sighandler_t
+rsignal(int signo, Sighandler_t handler)
+{
+ return PerlProc_signal(signo, handler);
+}
+
+static int sig_trapped;
+
+static
+Signal_t
+sig_trap(int signo)
+{
+ sig_trapped++;
+}
+
+Sighandler_t
+rsignal_state(int signo)
+{
+ Sighandler_t oldsig;
+
+ sig_trapped = 0;
+ oldsig = PerlProc_signal(signo, sig_trap);
+ PerlProc_signal(signo, oldsig);
+ if (sig_trapped)
+ PerlProc_kill(getpid(), signo);
+ return oldsig;
+}
+
+int
+rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save)
+{
+ *save = PerlProc_signal(signo, handler);
+ return (*save == SIG_ERR) ? -1 : 0;
+}
+
+int
+rsignal_restore(int signo, Sigsave_t *save)
+{
+ return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
+}
+
+#endif /* !HAS_SIGACTION */
+
+ /* VMS' my_pclose() is in VMS.c; same with OS/2 */
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
+I32
+my_pclose(PerlIO *ptr)
+{
+ Sigsave_t hstat, istat, qstat;
+ int status;
+ SV **svp;
+ int pid;
+ int pid2;
+ bool close_failed;
+ int saved_errno;
+#ifdef VMS
+ int saved_vaxc_errno;
+#endif
+#ifdef WIN32
+ int saved_win32_errno;
+#endif
+
+ svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
+ pid = (int)SvIVX(*svp);
+ SvREFCNT_dec(*svp);
+ *svp = &PL_sv_undef;
+#ifdef OS2
+ if (pid == -1) { /* Opened by popen. */
+ return my_syspclose(ptr);
+ }
+#endif
+ if ((close_failed = (PerlIO_close(ptr) == EOF))) {
+ saved_errno = errno;
+#ifdef VMS
+ saved_vaxc_errno = vaxc$errno;
+#endif
+#ifdef WIN32
+ saved_win32_errno = GetLastError();
+#endif
+ }
+#ifdef UTS
+ if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
+#endif
+ rsignal_save(SIGHUP, SIG_IGN, &hstat);
+ rsignal_save(SIGINT, SIG_IGN, &istat);
+ rsignal_save(SIGQUIT, SIG_IGN, &qstat);
+ do {
+ pid2 = wait4pid(pid, &status, 0);
+ } while (pid2 == -1 && errno == EINTR);
+ rsignal_restore(SIGHUP, &hstat);
+ rsignal_restore(SIGINT, &istat);
+ rsignal_restore(SIGQUIT, &qstat);
+ if (close_failed) {
+ SETERRNO(saved_errno, saved_vaxc_errno);
+ return -1;
+ }
+ return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
+}
+#endif /* !DOSISH */
+
+#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
+I32
+wait4pid(int pid, int *statusp, int flags)
+{
+ SV *sv;
+ SV** svp;
+ char spid[TYPE_CHARS(int)];
+
+ if (!pid)
+ return -1;
+ if (pid > 0) {
+ sprintf(spid, "%d", pid);
+ svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
+ if (svp && *svp != &PL_sv_undef) {
+ *statusp = SvIVX(*svp);
+ (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
+ return pid;
+ }
+ }
+ else {
+ HE *entry;
+
+ hv_iterinit(PL_pidstatus);
+ if (entry = hv_iternext(PL_pidstatus)) {
+ pid = atoi(hv_iterkey(entry,(I32*)statusp));
+ sv = hv_iterval(PL_pidstatus,entry);
+ *statusp = SvIVX(sv);
+ sprintf(spid, "%d", pid);
+ (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
+ return pid;
+ }
+ }
+#ifdef HAS_WAITPID
+# ifdef HAS_WAITPID_RUNTIME
+ if (!HAS_WAITPID_RUNTIME)
+ goto hard_way;
+# endif
+ return PerlProc_waitpid(pid,statusp,flags);
+#endif
+#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
+ return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
+#endif
+#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+ hard_way:
+ {
+ I32 result;
+ if (flags)
+ croak("Can't do waitpid with flags");
+ else {
+ while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
+ pidgone(result,*statusp);
+ if (result < 0)
+ *statusp = -1;
+ }
+ return result;
+ }
+#endif
+}
+#endif /* !DOSISH || OS2 || WIN32 */
+
+void
+/*SUPPRESS 590*/
+pidgone(int pid, int status)
+{
+ register SV *sv;
+ char spid[TYPE_CHARS(int)];
+
+ sprintf(spid, "%d", pid);
+ sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
+ (void)SvUPGRADE(sv,SVt_IV);
+ SvIVX(sv) = status;
+ return;
+}
+
+#if defined(atarist) || defined(OS2) || defined(DJGPP)
+int pclose();
+#ifdef HAS_FORK
+int /* Cannot prototype with I32
+ in os2ish.h. */
+my_syspclose(ptr)
+#else
+I32
+my_pclose(ptr)
+#endif
+PerlIO *ptr;
+{
+ /* Needs work for PerlIO ! */
+ FILE *f = PerlIO_findFILE(ptr);
+ I32 result = pclose(f);
+ PerlIO_releaseFILE(ptr,f);
+ return result;
+}
+#endif
+
+void
+repeatcpy(register char *to, register char *from, I32 len, register I32 count)
+{
+ register I32 todo;
+ register char *frombase = from;
+
+ if (len == 1) {
+ todo = *from;
+ while (count-- > 0)
+ *to++ = todo;
+ return;
+ }
+ while (count-- > 0) {
+ for (todo = len; todo > 0; todo--) {
+ *to++ = *from++;
+ }
+ from = frombase;
+ }
+}
+
+#ifndef CASTNEGFLOAT
+U32
+cast_ulong(f)
+double f;
+{
+ long along;
+
+#if CASTFLAGS & 2
+# define BIGDOUBLE 2147483648.0
+ if (f >= BIGDOUBLE)
+ return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
+#endif
+ if (f >= 0.0)
+ return (unsigned long)f;
+ along = (long)f;
+ return (unsigned long)along;
+}
+# undef BIGDOUBLE
+#endif
+
+#ifndef CASTI32
+
+/* Unfortunately, on some systems the cast_uv() function doesn't
+ work with the system-supplied definition of ULONG_MAX. The
+ comparison (f >= ULONG_MAX) always comes out true. It must be a
+ problem with the compiler constant folding.
+
+ In any case, this workaround should be fine on any two's complement
+ system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
+ ccflags.
+ --Andy Dougherty <doughera@lafcol.lafayette.edu>
+*/
+
+/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
+ of LONG_(MIN/MAX).
+ -- Kenneth Albanowski <kjahds@kjahds.com>
+*/
+
+#ifndef MY_UV_MAX
+# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
+#endif
+
+I32
+cast_i32(f)
+double f;
+{
+ if (f >= I32_MAX)
+ return (I32) I32_MAX;
+ if (f <= I32_MIN)
+ return (I32) I32_MIN;
+ return (I32) f;
+}
+
+IV
+cast_iv(f)
+double f;
+{
+ if (f >= IV_MAX)
+ return (IV) IV_MAX;
+ if (f <= IV_MIN)
+ return (IV) IV_MIN;
+ return (IV) f;
+}
+
+UV
+cast_uv(f)
+double f;
+{
+ if (f >= MY_UV_MAX)
+ return (UV) MY_UV_MAX;
+ return (UV) f;
+}
+
+#endif
+
+#ifndef HAS_RENAME
+I32
+same_dirent(a,b)
+char *a;
+char *b;
+{
+ char *fa = strrchr(a,'/');
+ char *fb = strrchr(b,'/');
+ struct stat tmpstatbuf1;
+ struct stat tmpstatbuf2;
+ SV *tmpsv = sv_newmortal();
+
+ if (fa)
+ fa++;
+ else
+ fa = a;
+ if (fb)
+ fb++;
+ else
+ fb = b;
+ if (strNE(a,b))
+ return FALSE;
+ if (fa == a)
+ sv_setpv(tmpsv, ".");
+ else
+ sv_setpvn(tmpsv, a, fa - a);
+ if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
+ return FALSE;
+ if (fb == b)
+ sv_setpv(tmpsv, ".");
+ else
+ sv_setpvn(tmpsv, b, fb - b);
+ if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
+ return FALSE;
+ return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
+ tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
+}
+#endif /* !HAS_RENAME */
+
+UV
+scan_oct(char *start, I32 len, I32 *retlen)
+{
+ register char *s = start;
+ register UV retval = 0;
+ bool overflowed = FALSE;
+
+ while (len && *s >= '0' && *s <= '7') {
+ register UV n = retval << 3;
+ if (!overflowed && (n >> 3) != retval) {
+ warn("Integer overflow in octal number");
+ overflowed = TRUE;
+ }
+ retval = n | (*s++ - '0');
+ len--;
+ }
+ if (PL_dowarn && len && (*s == '8' || *s == '9'))
+ warn("Illegal octal digit ignored");
+ *retlen = s - start;
+ return retval;
+}
+
+UV
+scan_hex(char *start, I32 len, I32 *retlen)
+{
+ register char *s = start;
+ register UV retval = 0;
+ bool overflowed = FALSE;
+ char *tmp = s;
+
+ while (len-- && *s && (tmp = strchr((char *) PL_hexdigit, *s))) {
+ register UV n = retval << 4;
+ if (!overflowed && (n >> 4) != retval) {
+ warn("Integer overflow in hex number");
+ overflowed = TRUE;
+ }
+ retval = n | ((tmp - PL_hexdigit) & 15);
+ s++;
+ }
+ if (PL_dowarn && !tmp) {
+ warn("Illegal hex digit ignored");
+ }
+ *retlen = s - start;
+ return retval;
+}
+
+char*
+find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
+{
+ dTHR;
+ char *xfound = Nullch;
+ char *xfailed = Nullch;
+ char tmpbuf[512];
+ register char *s;
+ I32 len;
+ int retval;
+#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
+# define SEARCH_EXTS ".bat", ".cmd", NULL
+# define MAX_EXT_LEN 4
+#endif
+#ifdef OS2
+# define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
+# define MAX_EXT_LEN 4
+#endif
+#ifdef VMS
+# define SEARCH_EXTS ".pl", ".com", NULL
+# define MAX_EXT_LEN 4
+#endif
+ /* additional extensions to try in each dir if scriptname not found */
+#ifdef SEARCH_EXTS
+ char *exts[] = { SEARCH_EXTS };
+ char **ext = search_ext ? search_ext : exts;
+ int extidx = 0, i = 0;
+ char *curext = Nullch;
+#else
+# define MAX_EXT_LEN 0
+#endif
+
+ /*
+ * If dosearch is true and if scriptname does not contain path
+ * delimiters, search the PATH for scriptname.
+ *
+ * If SEARCH_EXTS is also defined, will look for each
+ * scriptname{SEARCH_EXTS} whenever scriptname is not found
+ * while searching the PATH.
+ *
+ * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
+ * proceeds as follows:
+ * If DOSISH or VMSISH:
+ * + look for ./scriptname{,.foo,.bar}
+ * + search the PATH for scriptname{,.foo,.bar}
+ *
+ * If !DOSISH:
+ * + look *only* in the PATH for scriptname{,.foo,.bar} (note
+ * this will not look in '.' if it's not in the PATH)
+ */
+ tmpbuf[0] = '\0';
+
+#ifdef VMS
+# ifdef ALWAYS_DEFTYPES
+ len = strlen(scriptname);
+ if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
+ int hasdir, idx = 0, deftypes = 1;
+ bool seen_dot = 1;
+
+ hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
+# else
+ if (dosearch) {
+ int hasdir, idx = 0, deftypes = 1;
+ bool seen_dot = 1;
+
+ hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
+# endif
+ /* The first time through, just add SEARCH_EXTS to whatever we
+ * already have, so we can check for default file types. */
+ while (deftypes ||
+ (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
+ {
+ if (deftypes) {
+ deftypes = 0;
+ *tmpbuf = '\0';
+ }
+ if ((strlen(tmpbuf) + strlen(scriptname)
+ + MAX_EXT_LEN) >= sizeof tmpbuf)
+ continue; /* don't search dir with too-long name */
+ strcat(tmpbuf, scriptname);
+#else /* !VMS */
+
+#ifdef DOSISH
+ if (strEQ(scriptname, "-"))
+ dosearch = 0;
+ if (dosearch) { /* Look in '.' first. */
+ char *cur = scriptname;
+#ifdef SEARCH_EXTS
+ if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
+ while (ext[i])
+ if (strEQ(ext[i++],curext)) {
+ extidx = -1; /* already has an ext */
+ break;
+ }
+ do {
+#endif
+ DEBUG_p(PerlIO_printf(Perl_debug_log,
+ "Looking for %s\n",cur));
+ if (PerlLIO_stat(cur,&PL_statbuf) >= 0) {
+ dosearch = 0;
+ scriptname = cur;
+#ifdef SEARCH_EXTS
+ break;
+#endif
+ }
+#ifdef SEARCH_EXTS
+ if (cur == scriptname) {
+ len = strlen(scriptname);
+ if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
+ break;
+ cur = strcpy(tmpbuf, scriptname);
+ }
+ } while (extidx >= 0 && ext[extidx] /* try an extension? */
+ && strcpy(tmpbuf+len, ext[extidx++]));
+#endif
+ }
+#endif
+
+ if (dosearch && !strchr(scriptname, '/')
+#ifdef DOSISH
+ && !strchr(scriptname, '\\')
+#endif
+ && (s = PerlEnv_getenv("PATH"))) {
+ bool seen_dot = 0;
+
+ PL_bufend = s + strlen(s);
+ while (s < PL_bufend) {
+#if defined(atarist) || defined(DOSISH)
+ for (len = 0; *s
+# ifdef atarist
+ && *s != ','
+# endif
+ && *s != ';'; len++, s++) {
+ if (len < sizeof tmpbuf)
+ tmpbuf[len] = *s;
+ }
+ if (len < sizeof tmpbuf)
+ tmpbuf[len] = '\0';
+#else /* ! (atarist || DOSISH) */
+ s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
+ ':',
+ &len);
+#endif /* ! (atarist || DOSISH) */
+ if (s < PL_bufend)
+ s++;
+ if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
+ continue; /* don't search dir with too-long name */
+ if (len
+#if defined(atarist) || defined(DOSISH)
+ && tmpbuf[len - 1] != '/'
+ && tmpbuf[len - 1] != '\\'
+#endif
+ )
+ tmpbuf[len++] = '/';
+ if (len == 2 && tmpbuf[0] == '.')
+ seen_dot = 1;
+ (void)strcpy(tmpbuf + len, scriptname);
+#endif /* !VMS */
+
+#ifdef SEARCH_EXTS
+ len = strlen(tmpbuf);
+ if (extidx > 0) /* reset after previous loop */
+ extidx = 0;
+ do {
+#endif
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
+ retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
+#ifdef SEARCH_EXTS
+ } while ( retval < 0 /* not there */
+ && extidx>=0 && ext[extidx] /* try an extension? */
+ && strcpy(tmpbuf+len, ext[extidx++])
+ );
+#endif
+ if (retval < 0)
+ continue;
+ if (S_ISREG(PL_statbuf.st_mode)
+ && cando(S_IRUSR,TRUE,&PL_statbuf)
+#ifndef DOSISH
+ && cando(S_IXUSR,TRUE,&PL_statbuf)
+#endif
+ )
+ {
+ xfound = tmpbuf; /* bingo! */
+ break;
+ }
+ if (!xfailed)
+ xfailed = savepv(tmpbuf);
+ }
+#ifndef DOSISH
+ if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&PL_statbuf) < 0))
+#endif
+ seen_dot = 1; /* Disable message. */
+ if (!xfound) {
+ if (flags & 1) { /* do or die? */
+ croak("Can't %s %s%s%s",
+ (xfailed ? "execute" : "find"),
+ (xfailed ? xfailed : scriptname),
+ (xfailed ? "" : " on PATH"),
+ (xfailed || seen_dot) ? "" : ", '.' not in PATH");
+ }
+ scriptname = Nullch;
+ }
+ if (xfailed)
+ Safefree(xfailed);
+ scriptname = xfound;
+ }
+ return (scriptname ? savepv(scriptname) : Nullch);
+}
+
+
+#ifdef USE_THREADS
+#ifdef FAKE_THREADS
+/* Very simplistic scheduler for now */
+void
+schedule(void)
+{
+ thr = thr->i.next_run;
+}
+
+void
+perl_cond_init(cp)
+perl_cond *cp;
+{
+ *cp = 0;
+}
+
+void
+perl_cond_signal(cp)
+perl_cond *cp;
+{
+ perl_os_thread t;
+ perl_cond cond = *cp;
+
+ if (!cond)
+ return;
+ t = cond->thread;
+ /* Insert t in the runnable queue just ahead of us */
+ t->i.next_run = thr->i.next_run;
+ thr->i.next_run->i.prev_run = t;
+ t->i.prev_run = thr;
+ thr->i.next_run = t;
+ thr->i.wait_queue = 0;
+ /* Remove from the wait queue */
+ *cp = cond->next;
+ Safefree(cond);
+}
+
+void
+perl_cond_broadcast(cp)
+perl_cond *cp;
+{
+ perl_os_thread t;
+ perl_cond cond, cond_next;
+
+ for (cond = *cp; cond; cond = cond_next) {
+ t = cond->thread;
+ /* Insert t in the runnable queue just ahead of us */
+ t->i.next_run = thr->i.next_run;
+ thr->i.next_run->i.prev_run = t;
+ t->i.prev_run = thr;
+ thr->i.next_run = t;
+ thr->i.wait_queue = 0;
+ /* Remove from the wait queue */
+ cond_next = cond->next;
+ Safefree(cond);
+ }
+ *cp = 0;
+}
+
+void
+perl_cond_wait(cp)
+perl_cond *cp;
+{
+ perl_cond cond;
+
+ if (thr->i.next_run == thr)
+ croak("panic: perl_cond_wait called by last runnable thread");
+
+ New(666, cond, 1, struct perl_wait_queue);
+ cond->thread = thr;
+ cond->next = *cp;
+ *cp = cond;
+ thr->i.wait_queue = cond;
+ /* Remove ourselves from runnable queue */
+ thr->i.next_run->i.prev_run = thr->i.prev_run;
+ thr->i.prev_run->i.next_run = thr->i.next_run;
+}
+#endif /* FAKE_THREADS */
+
+#ifdef OLD_PTHREADS_API
+struct perl_thread *
+getTHR _((void))
+{
+ pthread_addr_t t;
+
+ if (pthread_getspecific(PL_thr_key, &t))
+ croak("panic: pthread_getspecific");
+ return (struct perl_thread *) t;
+}
+#endif /* OLD_PTHREADS_API */
+
+MAGIC *
+condpair_magic(SV *sv)
+{
+ MAGIC *mg;
+
+ SvUPGRADE(sv, SVt_PVMG);
+ mg = mg_find(sv, 'm');
+ if (!mg) {
+ condpair_t *cp;
+
+ New(53, cp, 1, condpair_t);
+ MUTEX_INIT(&cp->mutex);
+ COND_INIT(&cp->owner_cond);
+ COND_INIT(&cp->cond);
+ cp->owner = 0;
+ LOCK_SV_MUTEX;
+ mg = mg_find(sv, 'm');
+ if (mg) {
+ /* someone else beat us to initialising it */
+ UNLOCK_SV_MUTEX;
+ MUTEX_DESTROY(&cp->mutex);
+ COND_DESTROY(&cp->owner_cond);
+ COND_DESTROY(&cp->cond);
+ Safefree(cp);
+ }
+ else {
+ sv_magic(sv, Nullsv, 'm', 0, 0);
+ mg = SvMAGIC(sv);
+ mg->mg_ptr = (char *)cp;
+ mg->mg_len = sizeof(cp);
+ UNLOCK_SV_MUTEX;
+ DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(),
+ "%p: condpair_magic %p\n", thr, sv));)
+ }
+ }
+ return mg;
+}
+
+/*
+ * Make a new perl thread structure using t as a prototype. Some of the
+ * fields for the new thread are copied from the prototype thread, t,
+ * so t should not be running in perl at the time this function is
+ * called. The use by ext/Thread/Thread.xs in core perl (where t is the
+ * thread calling new_struct_thread) clearly satisfies this constraint.
+ */
+struct perl_thread *
+new_struct_thread(struct perl_thread *t)
+{
+ struct perl_thread *thr;
+ SV *sv;
+ SV **svp;
+ I32 i;
+
+ sv = newSVpv("", 0);
+ SvGROW(sv, sizeof(struct perl_thread) + 1);
+ SvCUR_set(sv, sizeof(struct perl_thread));
+ thr = (Thread) SvPVX(sv);
+ /* debug */
+ memset(thr, 0xab, sizeof(struct perl_thread));
+ PL_markstack = 0;
+ PL_scopestack = 0;
+ PL_savestack = 0;
+ PL_retstack = 0;
+ PL_dirty = 0;
+ PL_localizing = 0;
+ /* end debug */
+
+ thr->oursv = sv;
+ init_stacks(ARGS);
+
+ PL_curcop = &PL_compiling;
+ thr->cvcache = newHV();
+ thr->threadsv = newAV();
+ thr->specific = newAV();
+ thr->errsv = newSVpv("", 0);
+ thr->errhv = newHV();
+ 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
+ be per-thread. Otherwise a 'die' in a thread gives
+ that thread the C stack of last thread to do an eval {}!
+ See comments in scope.h
+ Initialize top entry (as in perl.c for main thread)
+ */
+ PL_start_env.je_prev = NULL;
+ PL_start_env.je_ret = -1;
+ PL_start_env.je_mustcatch = TRUE;
+ PL_top_env = &PL_start_env;
+
+ PL_in_eval = FALSE;
+ PL_restartop = 0;
+
+ PL_tainted = t->Ttainted;
+ PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
+ PL_nrs = newSVsv(t->Tnrs);
+ PL_rs = SvREFCNT_inc(PL_nrs);
+ PL_last_in_gv = Nullgv;
+ PL_ofslen = t->Tofslen;
+ PL_ofs = savepvn(t->Tofs, PL_ofslen);
+ PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
+ PL_chopset = t->Tchopset;
+ PL_formtarget = newSVsv(t->Tformtarget);
+ 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++) {
+ if (*svp && *svp != &PL_sv_undef) {
+ SV *sv = newSVsv(*svp);
+ av_store(thr->threadsv, i, sv);
+ sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr));
+ }
+ }
+ thr->threadsvp = AvARRAY(thr->threadsv);
+
+ MUTEX_LOCK(&PL_threads_mutex);
+ PL_nthreads++;
+ thr->tid = ++PL_threadnum;
+ thr->next = t->next;
+ thr->prev = t;
+ t->next = thr;
+ thr->next->prev = thr;
+ MUTEX_UNLOCK(&PL_threads_mutex);
+
+#ifdef HAVE_THREAD_INTERN
+ init_thread_intern(thr);
+#endif /* HAVE_THREAD_INTERN */
+ return thr;
+}
+#endif /* USE_THREADS */
+
+#ifdef HUGE_VAL
+/*
+ * This hack is to force load of "huge" support from libm.a
+ * So it is in perl for (say) POSIX to use.
+ * Needed for SunOS with Sun's 'acc' for example.
+ */
+double
+Perl_huge(void)
+{
+ return HUGE_VAL;
+}
+#endif
+
+#ifdef PERL_GLOBAL_STRUCT
+struct perl_vars *
+Perl_GetVars(void)
+{
+ return &PL_Vars;
+}
+#endif
+
+char **
+get_op_names(void)
+{
+ return op_name;
+}
+
+char **
+get_op_descs(void)
+{
+ return op_desc;
+}
+
+char *
+get_no_modify(void)
+{
+ return (char*)no_modify;
+}
+
+U32 *
+get_opargs(void)
+{
+ return opargs;
+}
+
+
+SV **
+get_specialsv_list(void)
+{
+ return PL_specialsv_list;
+}
diff --git a/contrib/perl5/util.h b/contrib/perl5/util.h
new file mode 100644
index 000000000000..7dcf9ceab51c
--- /dev/null
+++ b/contrib/perl5/util.h
@@ -0,0 +1,8 @@
+/* util.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
diff --git a/contrib/perl5/utils/Makefile b/contrib/perl5/utils/Makefile
new file mode 100644
index 000000000000..2df16d8060fe
--- /dev/null
+++ b/contrib/perl5/utils/Makefile
@@ -0,0 +1,43 @@
+
+PERL = ../miniperl
+REALPERL = ../perl
+
+# Files to be built with variable substitution after miniperl is
+# available. Dependencies handled manually below (for now).
+
+pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL perlcc.PL
+plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain perlcc
+plextractexe = c2ph.exe h2ph.exe h2xs.exe perlbug.exe perldoc.exe pl2pm.exe splain.exe perlcc.exe
+
+all: $(plextract)
+
+compile: all
+ $(REALPERL) -I../lib perlcc -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog;
+
+$(plextract):
+ $(PERL) -I../lib $@.PL
+
+c2ph: c2ph.PL ../config.sh
+
+h2ph: h2ph.PL ../config.sh
+
+h2xs: h2xs.PL ../config.sh
+
+perlbug: perlbug.PL ../config.sh ../patchlevel.h
+
+perldoc: perldoc.PL ../config.sh
+
+pl2pm: pl2pm.PL ../config.sh
+
+splain: splain.PL ../config.sh ../lib/diagnostics.pm
+
+perlcc: perlcc.PL ../config.sh
+
+clean:
+
+realclean:
+ rm -rf $(plextract) pstruct $(plextractexe)
+
+clobber: realclean
+
+distclean: clobber
diff --git a/contrib/perl5/utils/c2ph.PL b/contrib/perl5/utils/c2ph.PL
new file mode 100644
index 000000000000..38b259f0db18
--- /dev/null
+++ b/contrib/perl5/utils/c2ph.PL
@@ -0,0 +1,1403 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+#
+#
+# c2ph (aka pstruct)
+# Tom Christiansen, <tchrist@convex.com>
+#
+# As pstruct, dump C structures as generated from 'cc -g -S' stabs.
+# As c2ph, do this PLUS generate perl code for getting at the structures.
+#
+# See the usage message for more. If this isn't enough, read the code.
+#
+
+=head1 NAME
+
+c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
+
+=head1 SYNOPSIS
+
+ c2ph [-dpnP] [var=val] [files ...]
+
+=head2 OPTIONS
+
+ Options:
+
+ -w wide; short for: type_width=45 member_width=35 offset_width=8
+ -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+ -n do not generate perl code (default when invoked as pstruct)
+ -p generate perl code (default when invoked as c2ph)
+ -v generate perl code, with C decls as comments
+
+ -i do NOT recompute sizes for intrinsic datatypes
+ -a dump information on intrinsics also
+
+ -t trace execution
+ -d spew reams of debugging output
+
+ -slist give comma-separated list a structures to dump
+
+=head1 DESCRIPTION
+
+The following is the old c2ph.doc documentation by Tom Christiansen
+<tchrist@perl.com>
+Date: 25 Jul 91 08:10:21 GMT
+
+Once upon a time, I wrote a program called pstruct. It was a perl
+program that tried to parse out C structures and display their member
+offsets for you. This was especially useful for people looking at
+binary dumps or poking around the kernel.
+
+Pstruct was not a pretty program. Neither was it particularly robust.
+The problem, you see, was that the C compiler was much better at parsing
+C than I could ever hope to be.
+
+So I got smart: I decided to be lazy and let the C compiler parse the C,
+which would spit out debugger stabs for me to read. These were much
+easier to parse. It's still not a pretty program, but at least it's more
+robust.
+
+Pstruct takes any .c or .h files, or preferably .s ones, since that's
+the format it is going to massage them into anyway, and spits out
+listings like this:
+
+ struct tty {
+ int tty.t_locker 000 4
+ int tty.t_mutex_index 004 4
+ struct tty * tty.t_tp_virt 008 4
+ struct clist tty.t_rawq 00c 20
+ int tty.t_rawq.c_cc 00c 4
+ int tty.t_rawq.c_cmax 010 4
+ int tty.t_rawq.c_cfx 014 4
+ int tty.t_rawq.c_clx 018 4
+ struct tty * tty.t_rawq.c_tp_cpu 01c 4
+ struct tty * tty.t_rawq.c_tp_iop 020 4
+ unsigned char * tty.t_rawq.c_buf_cpu 024 4
+ unsigned char * tty.t_rawq.c_buf_iop 028 4
+ struct clist tty.t_canq 02c 20
+ int tty.t_canq.c_cc 02c 4
+ int tty.t_canq.c_cmax 030 4
+ int tty.t_canq.c_cfx 034 4
+ int tty.t_canq.c_clx 038 4
+ struct tty * tty.t_canq.c_tp_cpu 03c 4
+ struct tty * tty.t_canq.c_tp_iop 040 4
+ unsigned char * tty.t_canq.c_buf_cpu 044 4
+ unsigned char * tty.t_canq.c_buf_iop 048 4
+ struct clist tty.t_outq 04c 20
+ int tty.t_outq.c_cc 04c 4
+ int tty.t_outq.c_cmax 050 4
+ int tty.t_outq.c_cfx 054 4
+ int tty.t_outq.c_clx 058 4
+ struct tty * tty.t_outq.c_tp_cpu 05c 4
+ struct tty * tty.t_outq.c_tp_iop 060 4
+ unsigned char * tty.t_outq.c_buf_cpu 064 4
+ unsigned char * tty.t_outq.c_buf_iop 068 4
+ (*int)() tty.t_oproc_cpu 06c 4
+ (*int)() tty.t_oproc_iop 070 4
+ (*int)() tty.t_stopproc_cpu 074 4
+ (*int)() tty.t_stopproc_iop 078 4
+ struct thread * tty.t_rsel 07c 4
+
+etc.
+
+
+Actually, this was generated by a particular set of options. You can control
+the formatting of each column, whether you prefer wide or fat, hex or decimal,
+leading zeroes or whatever.
+
+All you need to be able to use this is a C compiler than generates
+BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
+should get this for you.
+
+To learn more, just type a bogus option, like B<-\?>, and a long usage message
+will be provided. There are a fair number of possibilities.
+
+If you're only a C programmer, than this is the end of the message for you.
+You can quit right now, and if you care to, save off the source and run it
+when you feel like it. Or not.
+
+
+
+But if you're a perl programmer, then for you I have something much more
+wondrous than just a structure offset printer.
+
+You see, if you call pstruct by its other incybernation, c2ph, you have a code
+generator that translates C code into perl code! Well, structure and union
+declarations at least, but that's quite a bit.
+
+Prior to this point, anyone programming in perl who wanted to interact
+with C programs, like the kernel, was forced to guess the layouts of
+the C strutures, and then hardwire these into his program. Of course,
+when you took your wonderfully crafted program to a system where the
+sgtty structure was laid out differently, you program broke. Which is
+a shame.
+
+We've had Larry's h2ph translator, which helped, but that only works on
+cpp symbols, not real C, which was also very much needed. What I offer
+you is a symbolic way of getting at all the C structures. I've couched
+them in terms of packages and functions. Consider the following program:
+
+ #!/usr/local/bin/perl
+
+ require 'syscall.ph';
+ require 'sys/time.ph';
+ require 'sys/resource.ph';
+
+ $ru = "\0" x &rusage'sizeof();
+
+ syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
+
+ @ru = unpack($t = &rusage'typedef(), $ru);
+
+ $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
+
+ $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
+
+ printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
+
+
+As you see, the name of the package is the name of the structure. Regular
+fields are just their own names. Plus the following accessor functions are
+provided for your convenience:
+
+ struct This takes no arguments, and is merely the number of first-level
+ elements in the structure. You would use this for indexing
+ into arrays of structures, perhaps like this
+
+
+ $usec = $u[ &user'u_utimer
+ + (&ITIMER_VIRTUAL * &itimerval'struct)
+ + &itimerval'it_value
+ + &timeval'tv_usec
+ ];
+
+ sizeof Returns the bytes in the structure, or the member if
+ you pass it an argument, such as
+
+ &rusage'sizeof(&rusage'ru_utime)
+
+ typedef This is the perl format definition for passing to pack and
+ unpack. If you ask for the typedef of a nothing, you get
+ the whole structure, otherwise you get that of the member
+ you ask for. Padding is taken care of, as is the magic to
+ guarantee that a union is unpacked into all its aliases.
+ Bitfields are not quite yet supported however.
+
+ offsetof This function is the byte offset into the array of that
+ member. You may wish to use this for indexing directly
+ into the packed structure with vec() if you're too lazy
+ to unpack it.
+
+ typeof Not to be confused with the typedef accessor function, this
+ one returns the C type of that field. This would allow
+ you to print out a nice structured pretty print of some
+ structure without knoning anything about it beforehand.
+ No args to this one is a noop. Someday I'll post such
+ a thing to dump out your u structure for you.
+
+
+The way I see this being used is like basically this:
+
+ % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
+ % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
+ % install
+
+It's a little tricker with c2ph because you have to get the includes right.
+I can't know this for your system, but it's not usually too terribly difficult.
+
+The code isn't pretty as I mentioned -- I never thought it would be a 1000-
+line program when I started, or I might not have begun. :-) But I would have
+been less cavalier in how the parts of the program communicated with each
+other, etc. It might also have helped if I didn't have to divine the makeup
+of the stabs on the fly, and then account for micro differences between my
+compiler and gcc.
+
+Anyway, here it is. Should run on perl v4 or greater. Maybe less.
+
+
+ --tom
+
+=cut
+
+$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
+
+
+######################################################################
+
+# some handy data definitions. many of these can be reset later.
+
+$bitorder = 'b'; # ascending; set to B for descending bit fields
+
+%intrinsics =
+%template = (
+ 'char', 'c',
+ 'unsigned char', 'C',
+ 'short', 's',
+ 'short int', 's',
+ 'unsigned short', 'S',
+ 'unsigned short int', 'S',
+ 'short unsigned int', 'S',
+ 'int', 'i',
+ 'unsigned int', 'I',
+ 'long', 'l',
+ 'long int', 'l',
+ 'unsigned long', 'L',
+ 'unsigned long', 'L',
+ 'long unsigned int', 'L',
+ 'unsigned long int', 'L',
+ 'long long', 'q',
+ 'long long int', 'q',
+ 'unsigned long long', 'Q',
+ 'unsigned long long int', 'Q',
+ 'float', 'f',
+ 'double', 'd',
+ 'pointer', 'p',
+ 'null', 'x',
+ 'neganull', 'X',
+ 'bit', $bitorder,
+);
+
+&buildscrunchlist;
+delete $intrinsics{'neganull'};
+delete $intrinsics{'bit'};
+delete $intrinsics{'null'};
+
+# use -s to recompute sizes
+%sizeof = (
+ 'char', '1',
+ 'unsigned char', '1',
+ 'short', '2',
+ 'short int', '2',
+ 'unsigned short', '2',
+ 'unsigned short int', '2',
+ 'short unsigned int', '2',
+ 'int', '4',
+ 'unsigned int', '4',
+ 'long', '4',
+ 'long int', '4',
+ 'unsigned long', '4',
+ 'unsigned long int', '4',
+ 'long unsigned int', '4',
+ 'long long', '8',
+ 'long long int', '8',
+ 'unsigned long long', '8',
+ 'unsigned long long int', '8',
+ 'float', '4',
+ 'double', '8',
+ 'pointer', '4',
+);
+
+($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
+
+($offset_fmt, $size_fmt) = ('d', 'd');
+
+$indent = 2;
+
+$CC = 'cc';
+$CFLAGS = '-g -S';
+$DEFINES = '';
+
+$perl++ if $0 =~ m#/?c2ph$#;
+
+require 'getopts.pl';
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+&Getopts('aixdpvtnws:') || &usage(0);
+
+$opt_d && $debug++;
+$opt_t && $trace++;
+$opt_p && $perl++;
+$opt_v && $verbose++;
+$opt_n && ($perl = 0);
+
+if ($opt_w) {
+ ($type_width, $member_width, $offset_width) = (45, 35, 8);
+}
+if ($opt_x) {
+ ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
+}
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+sub PLUMBER {
+ select(STDERR);
+ print "oops, apperent pager foulup\n";
+ $isatty++;
+ &usage(1);
+}
+
+sub usage {
+ local($oops) = @_;
+ unless (-t STDOUT) {
+ select(STDERR);
+ } elsif (!$oops) {
+ $isatty++;
+ $| = 1;
+ print "hit <RETURN> for further explanation: ";
+ <STDIN>;
+ open (PIPE, "|". ($ENV{PAGER} || 'more'));
+ $SIG{PIPE} = PLUMBER;
+ select(PIPE);
+ }
+
+ print "usage: $0 [-dpnP] [var=val] [files ...]\n";
+
+ exit unless $isatty;
+
+ print <<EOF;
+
+Options:
+
+-w wide; short for: type_width=45 member_width=35 offset_width=8
+-x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+-n do not generate perl code (default when invoked as pstruct)
+-p generate perl code (default when invoked as c2ph)
+-v generate perl code, with C decls as comments
+
+-i do NOT recompute sizes for intrinsic datatypes
+-a dump information on intrinsics also
+
+-t trace execution
+-d spew reams of debugging output
+
+-slist give comma-separated list a structures to dump
+
+
+Var Name Default Value Meaning
+
+EOF
+
+ &defvar('CC', 'which_compiler to call');
+ &defvar('CFLAGS', 'how to generate *.s files with stabs');
+ &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
+
+ print "\n";
+
+ &defvar('type_width', 'width of type field (column 1)');
+ &defvar('member_width', 'width of member field (column 2)');
+ &defvar('offset_width', 'width of offset field (column 3)');
+ &defvar('size_width', 'width of size field (column 4)');
+
+ print "\n";
+
+ &defvar('offset_fmt', 'sprintf format type for offset');
+ &defvar('size_fmt', 'sprintf format type for size');
+
+ print "\n";
+
+ &defvar('indent', 'how far to indent each nesting level');
+
+ print <<'EOF';
+
+ If any *.[ch] files are given, these will be catted together into
+ a temporary *.c file and sent through:
+ $CC $CFLAGS $DEFINES
+ and the resulting *.s groped for stab information. If no files are
+ supplied, then stdin is read directly with the assumption that it
+ contains stab information. All other liens will be ignored. At
+ most one *.s file should be supplied.
+
+EOF
+ close PIPE;
+ exit 1;
+}
+
+sub defvar {
+ local($var, $msg) = @_;
+ printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
+}
+
+$recurse = 1;
+
+if (@ARGV) {
+ if (grep(!/\.[csh]$/,@ARGV)) {
+ warn "Only *.[csh] files expected!\n";
+ &usage;
+ }
+ elsif (grep(/\.s$/,@ARGV)) {
+ if (@ARGV > 1) {
+ warn "Only one *.s file allowed!\n";
+ &usage;
+ }
+ }
+ elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
+ local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
+ $chdir = "cd $dir; " if $dir;
+ &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
+ $ARGV[0] =~ s/\.c$/.s/;
+ }
+ else {
+ $TMP = "/tmp/c2ph.$$.c";
+ &system("cat @ARGV > $TMP") && exit 1;
+ &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
+ unlink $TMP;
+ $TMP =~ s/\.c$/.s/;
+ @ARGV = ($TMP);
+ }
+}
+
+if ($opt_s) {
+ for (split(/[\s,]+/, $opt_s)) {
+ $interested{$_}++;
+ }
+}
+
+
+$| = 1 if $debug;
+
+main: {
+
+ if ($trace) {
+ if (-t && !@ARGV) {
+ print STDERR "reading from your keyboard: ";
+ } else {
+ print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
+ }
+ }
+
+STAB: while (<>) {
+ if ($trace && !($. % 10)) {
+ $lineno = $..'';
+ print STDERR $lineno, "\b" x length($lineno);
+ }
+ next unless /^\s*\.stabs\s+/;
+ $line = $_;
+ s/^\s*\.stabs\s+//;
+ if (s/\\\\"[d,]+$//) {
+ $saveline .= $line;
+ $savebar = $_;
+ next STAB;
+ }
+ if ($saveline) {
+ s/^"//;
+ $_ = $savebar . $_;
+ $line = $saveline;
+ }
+ &stab;
+ $savebar = $saveline = undef;
+ }
+ print STDERR "$.\n" if $trace;
+ unlink $TMP if $TMP;
+
+ &compute_intrinsics if $perl && !$opt_i;
+
+ print STDERR "resolving types\n" if $trace;
+
+ &resolve_types;
+ &adjust_start_addrs;
+
+ $sum = 2 + $type_width + $member_width;
+ $pmask1 = "%-${type_width}s %-${member_width}s";
+ $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
+
+
+
+ if ($perl) {
+ # resolve template -- should be in stab define order, but even this isn't enough.
+ print STDERR "\nbuilding type templates: " if $trace;
+ for $i (reverse 0..$#type) {
+ next unless defined($name = $type[$i]);
+ next unless defined $struct{$name};
+ ($iname = $name) =~ s/\..*//;
+ $build_recursed = 0;
+ &build_template($name) unless defined $template{&psou($name)} ||
+ $opt_s && !$interested{$iname};
+ }
+ print STDERR "\n\n" if $trace;
+ }
+
+ print STDERR "dumping structs: " if $trace;
+
+ local($iam);
+
+
+
+ foreach $name (sort keys %struct) {
+ ($iname = $name) =~ s/\..*//;
+ next if $opt_s && !$interested{$iname};
+ print STDERR "$name " if $trace;
+
+ undef @sizeof;
+ undef @typedef;
+ undef @offsetof;
+ undef @indices;
+ undef @typeof;
+ undef @fieldnames;
+
+ $mname = &munge($name);
+
+ $fname = &psou($name);
+
+ print "# " if $perl && $verbose;
+ $pcode = '';
+ print "$fname {\n" if !$perl || $verbose;
+ $template{$fname} = &scrunch($template{$fname}) if $perl;
+ &pstruct($name,$name,0);
+ print "# " if $perl && $verbose;
+ print "}\n" if !$perl || $verbose;
+ print "\n" if $perl && $verbose;
+
+ if ($perl) {
+ print "$pcode";
+
+ printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
+
+ print <<EOF;
+sub ${mname}'typedef {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'typedef[\$${mname}'index]
+ : \$${mname}'typedef;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'sizeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'sizeof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'offsetof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'offsetof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'typeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'typeof[\$${mname}'index]
+ : '$name';
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'fieldnames {
+ \@${mname}'fieldnames;
+}
+EOF
+
+ $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
+
+ print <<EOF;
+sub ${mname}'isastruct {
+ '$iam';
+}
+EOF
+
+ print "\$${mname}'typedef = '" . &scrunch($template{$fname})
+ . "';\n";
+
+ print "\$${mname}'sizeof = $sizeof{$name};\n\n";
+
+
+ print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
+
+ print "\n";
+
+ print "\@${mname}'typedef[\@${mname}'indices] = (",
+ join("\n\t", '', @typedef), "\n );\n\n";
+ print "\@${mname}'sizeof[\@${mname}'indices] = (",
+ join("\n\t", '', @sizeof), "\n );\n\n";
+ print "\@${mname}'offsetof[\@${mname}'indices] = (",
+ join("\n\t", '', @offsetof), "\n );\n\n";
+ print "\@${mname}'typeof[\@${mname}'indices] = (",
+ join("\n\t", '', @typeof), "\n );\n\n";
+ print "\@${mname}'fieldnames[\@${mname}'indices] = (",
+ join("\n\t", '', @fieldnames), "\n );\n\n";
+
+ $template_printed{$fname}++;
+ $size_printed{$fname}++;
+ }
+ print "\n";
+ }
+
+ print STDERR "\n" if $trace;
+
+ unless ($perl && $opt_a) {
+ print "\n1;\n" if $perl;
+ exit;
+ }
+
+
+
+ foreach $name (sort bysizevalue keys %intrinsics) {
+ next if $size_printed{$name};
+ print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
+ }
+
+ print "\n";
+
+ sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
+
+
+ foreach $name (sort keys %intrinsics) {
+ print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
+ }
+
+ print "\n1;\n" if $perl;
+
+ exit;
+}
+
+########################################################################################
+
+
+sub stab {
+ next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
+ s/"// || next;
+ s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
+
+ next if /^\s*$/;
+
+ $size = $3 if $3;
+ $_ = $continued . $_ if length($continued);
+ if (s/\\\\$//) {
+ # if last 2 chars of string are '\\' then stab is continued
+ # in next stab entry
+ chop;
+ $continued = $_;
+ next;
+ }
+ $continued = '';
+
+
+ $line = $_;
+
+ if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
+ print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
+ &pdecl($pdecl);
+ next;
+ }
+
+
+
+ if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
+ local($ident) = $2;
+ push(@intrinsics, $ident);
+ $typeno = &typeno($3);
+ $type[$typeno] = $ident;
+ print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
+ next;
+ }
+
+ if (($name, $typeordef, $typeno, $extra, $struct, $_)
+ = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
+ {
+ $typeno = &typeno($typeno); # sun foolery
+ }
+ elsif (/^[\$\w]+:/) {
+ next; # variable
+ }
+ else {
+ warn "can't grok stab: <$_> in: $line " if $_;
+ next;
+ }
+
+ #warn "got size $size for $name\n";
+ $sizeof{$name} = $size if $size;
+
+ s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
+
+ $typenos{$name} = $typeno;
+
+ unless (defined $type[$typeno]) {
+ &panic("type 0??") unless $typeno;
+ $type[$typeno] = $name unless defined $type[$typeno];
+ printf "new type $typeno is $name" if $debug;
+ if ($extra =~ /\*/ && defined $type[$struct]) {
+ print ", a typedef for a pointer to " , $type[$struct] if $debug;
+ }
+ } else {
+ printf "%s is type %d", $name, $typeno if $debug;
+ print ", a typedef for " , $type[$typeno] if $debug;
+ }
+ print "\n" if $debug;
+ #next unless $extra =~ /[su*]/;
+
+ #$type[$struct] = $name;
+
+ if ($extra =~ /[us*]/) {
+ &sou($name, $extra);
+ $_ = &sdecl($name, $_, 0);
+ }
+ elsif (/^=ar/) {
+ print "it's a bare array typedef -- that's pretty sick\n" if $debug;
+ $_ = "$typeno$_";
+ $scripts = '';
+ $_ = &adecl($_,1);
+
+ }
+ elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
+ push(@intrinsics, $2);
+ $typeno = &typeno($3);
+ $type[$typeno] = $2;
+ print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
+ }
+ elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
+ &edecl;
+ }
+ else {
+ warn "Funny remainder for $name on line $_ left in $line " if $_;
+ }
+}
+
+sub typeno { # sun thinks types are (0,27) instead of just 27
+ local($_) = @_;
+ s/\(\d+,(\d+)\)/$1/;
+ $_;
+}
+
+sub pstruct {
+ local($what,$prefix,$base) = @_;
+ local($field, $fieldname, $typeno, $count, $offset, $entry);
+ local($fieldtype);
+ local($type, $tname);
+ local($mytype, $mycount, $entry2);
+ local($struct_count) = 0;
+ local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
+ local($bits,$bytes);
+ local($template);
+
+
+ local($mname) = &munge($name);
+
+ sub munge {
+ local($_) = @_;
+ s/[\s\$\.]/_/g;
+ $_;
+ }
+
+ local($sname) = &psou($what);
+
+ $nesting++;
+
+ for $field (split(/;/, $struct{$what})) {
+ $pad = $prepad = 0;
+ $entry = '';
+ ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
+
+ $type = $type[$typeno];
+
+ $type =~ /([^[]*)(\[.*\])?/;
+ $mytype = $1;
+ $count .= $2;
+ $fieldtype = &psou($mytype);
+
+ local($fname) = &psou($name);
+
+ if ($build_templates) {
+
+ $pad = ($offset - ($lastoffset + $lastlength))/8
+ if defined $lastoffset;
+
+ if (! $finished_template{$sname}) {
+ if ($isaunion{$what}) {
+ $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
+ } else {
+ $template{$sname} .= 'x' x $pad . ' ' if $pad;
+ }
+ }
+
+ $template = &fetch_template($type);
+ &repeat_template($template,$count);
+
+ if (! $finished_template{$sname}) {
+ $template{$sname} .= $template;
+ }
+
+ $revpad = $length/8 if $isaunion{$what};
+
+ ($lastoffset, $lastlength) = ($offset, $length);
+
+ } else {
+ print '# ' if $perl && $verbose;
+ $entry = sprintf($pmask1,
+ ' ' x ($nesting * $indent) . $fieldtype,
+ "$prefix.$fieldname" . $count);
+
+ $entry =~ s/(\*+)( )/$2$1/;
+
+ printf $pmask2,
+ $entry,
+ ($base+$offset)/8,
+ ($bits = ($base+$offset)%8) ? ".$bits" : " ",
+ $length/8,
+ ($bits = $length % 8) ? ".$bits": ""
+ if !$perl || $verbose;
+
+ if ($perl) {
+ $template = &fetch_template($type);
+ &repeat_template($template,$count);
+ }
+
+ if ($perl && $nesting == 1) {
+
+ push(@sizeof, int($length/8) .",\t# $fieldname");
+ push(@offsetof, int($offset/8) .",\t# $fieldname");
+ local($little) = &scrunch($template);
+ push(@typedef, "'$little', \t# $fieldname");
+ $type =~ s/(struct|union) //;
+ push(@typeof, "'$mytype" . ($count ? $count : '') .
+ "',\t# $fieldname");
+ push(@fieldnames, "'$fieldname',");
+ }
+
+ print ' ', ' ' x $indent x $nesting, $template
+ if $perl && $verbose;
+
+ print "\n" if !$perl || $verbose;
+
+ }
+ if ($perl) {
+ local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
+ $mycount *= &scripts2count($count) if $count;
+ if ($nesting==1 && !$build_templates) {
+ $pcode .= sprintf("sub %-32s { %4d; }\n",
+ "${mname}'${fieldname}", $struct_count);
+ push(@indices, $struct_count);
+ }
+ $struct_count += $mycount;
+ }
+
+
+ &pstruct($type, "$prefix.$fieldname", $base+$offset)
+ if $recurse && defined $struct{$type};
+ }
+
+ $countof{$what} = $struct_count unless defined $countof{$whati};
+
+ $template{$sname} .= '$' if $build_templates;
+ $finished_template{$sname}++;
+
+ if ($build_templates && !defined $sizeof{$name}) {
+ local($fmt) = &scrunch($template{$sname});
+ print STDERR "no size for $name, punting with $fmt..." if $debug;
+ eval '$sizeof{$name} = length(pack($fmt, ()))';
+ if ($@) {
+ chop $@;
+ warn "couldn't get size for \$name: $@";
+ } else {
+ print STDERR $sizeof{$name}, "\n" if $debUg;
+ }
+ }
+
+ --$nesting;
+}
+
+
+sub psize {
+ local($me) = @_;
+ local($amstruct) = $struct{$me} ? 'struct ' : '';
+
+ print '$sizeof{\'', $amstruct, $me, '\'} = ';
+ printf "%d;\n", $sizeof{$me};
+}
+
+sub pdecl {
+ local($pdecl) = @_;
+ local(@pdecls);
+ local($tname);
+
+ warn "pdecl: $pdecl\n" if $debug;
+
+ $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
+ $pdecl =~ s/\*//g;
+ @pdecls = split(/=/, $pdecl);
+ $typeno = $pdecls[0];
+ $tname = pop @pdecls;
+
+ if ($tname =~ s/^f//) { $tname = "$tname&"; }
+ #else { $tname = "$tname*"; }
+
+ for (reverse @pdecls) {
+ $tname .= s/^f// ? "&" : "*";
+ #$tname =~ s/^f(.*)/$1&/;
+ print "type[$_] is $tname\n" if $debug;
+ $type[$_] = $tname unless defined $type[$_];
+ }
+}
+
+
+
+sub adecl {
+ ($arraytype, $unknown, $lower, $upper) = ();
+ #local($typeno);
+ # global $typeno, @type
+ local($_, $typedef) = @_;
+
+ while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
+ ($arraytype, $unknown) = ($2, $3);
+ $arraytype = &typeno($arraytype);
+ $unknown = &typeno($unknown);
+ if (s/^(\d+);(\d+);//) {
+ ($lower, $upper) = ($1, $2);
+ $scripts .= '[' . ($upper+1) . ']';
+ } else {
+ warn "can't find array bounds: $_";
+ }
+ }
+ if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ $whatis = $1;
+ if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
+ $typeno = &typeno($1);
+ &pdecl($whatis);
+ } else {
+ $typeno = &typeno($whatis);
+ }
+ } elsif (s/^(\d+)(=[*suf]\d*)//) {
+ local($whatis) = $2;
+
+ if ($whatis =~ /[f*]/) {
+ &pdecl($whatis);
+ } elsif ($whatis =~ /[su]/) { #
+ print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
+ if $debug;
+ #$type[$typeno] = $name unless defined $type[$typeno];
+ ##printf "new type $typeno is $name" if $debug;
+ $typeno = $1;
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = $type[$typeno];
+ &sou($name, $whatis);
+ $_ = &sdecl($name, $_, $start+$offset);
+ 1;
+ $start = $start{$name};
+ $offset = $sizeof{$name};
+ $length = $offset;
+ } else {
+ warn "what's this? $whatis in $line ";
+ }
+ } elsif (/^\d+$/) {
+ $typeno = $_;
+ } else {
+ warn "bad array stab: $_ in $line ";
+ next STAB;
+ }
+ #local($wasdef) = defined($type[$typeno]) && $debug;
+ #if ($typedef) {
+ #print "redefining $type[$typeno] to " if $wasdef;
+ #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
+ #print "$type[$typeno]\n" if $wasdef;
+ #} else {
+ #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
+ #}
+ $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
+ print "type[$arraytype] is $type[$arraytype]\n" if $debug;
+ print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
+ $_;
+}
+
+
+
+sub sdecl {
+ local($prefix, $_, $offset) = @_;
+
+ local($fieldname, $scripts, $type, $arraytype, $unknown,
+ $whatis, $pdecl, $upper,$lower, $start,$length) = ();
+ local($typeno,$sou);
+
+
+SFIELD:
+ while (/^([^;]+);/) {
+ $scripts = '';
+ warn "sdecl $_\n" if $debug;
+ if (s/^([\$\w]+)://) {
+ $fieldname = $1;
+ } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
+ $typeno = &typeno($1);
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$2);
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $offset += $sizeof{$name};
+ #print "done with anon, start is $start, offset is $offset\n";
+ #next SFIELD;
+ } else {
+ warn "weird field $_ of $line" if $debug;
+ next STAB;
+ #$fieldname = &gensym;
+ #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ }
+
+ if (/^(\d+|\(\d+,\d+\))=ar/) {
+ $_ = &adecl($_);
+ }
+ elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
+ ($pdecl, $start, $length) = ($1,$5,$6);
+ &pdecl($pdecl);
+ }
+ elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
+ ($typeno, $sou) = ($1, $2);
+ $typeno = &typeno($typeno);
+ if (defined($type[$typeno])) {
+ warn "now how did we get type $1 in $fieldname of $line?";
+ } else {
+ print "anon type $typeno is $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
+ };
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$sou);
+ print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname";
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $length = $sizeof{$name};
+ }
+ else {
+ warn "can't grok stab for $name ($_) in line $line ";
+ next STAB;
+ }
+
+ &panic("no length for $prefix.$fieldname") unless $length;
+ $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
+ }
+ if (s/;\d*,(\d+),(\d+);//) {
+ local($start, $size) = ($1, $2);
+ $sizeof{$prefix} = $size;
+ print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
+ $start{$prefix} = $start;
+ }
+ $_;
+}
+
+sub edecl {
+ s/;$//;
+ $enum{$name} = $_;
+ $_ = '';
+}
+
+sub resolve_types {
+ local($sou);
+ for $i (0 .. $#type) {
+ next unless defined $type[$i];
+ $_ = $type[$i];
+ unless (/\d/) {
+ print "type[$i] $type[$i]\n" if $debug;
+ next;
+ }
+ print "type[$i] $_ ==> " if $debug;
+ s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
+ s/^(\d+)\&/&type($1)/e;
+ s/^(\d+)/&type($1)/e;
+ s/(\*+)([^*]+)(\*+)/$1$3$2/;
+ s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
+ s/^(\d+)([\*\[].*)/&type($1).$2/e;
+ #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
+ $type[$i] = $_;
+ print "$_\n" if $debug;
+ }
+}
+sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
+
+sub adjust_start_addrs {
+ for (sort keys %start) {
+ ($basename = $_) =~ s/\.[^.]+$//;
+ $start{$_} += $start{$basename};
+ print "start: $_ @ $start{$_}\n" if $debug;
+ }
+}
+
+sub sou {
+ local($what, $_) = @_;
+ /u/ && $isaunion{$what}++;
+ /s/ && $isastruct{$what}++;
+}
+
+sub psou {
+ local($what) = @_;
+ local($prefix) = '';
+ if ($isaunion{$what}) {
+ $prefix = 'union ';
+ } elsif ($isastruct{$what}) {
+ $prefix = 'struct ';
+ }
+ $prefix . $what;
+}
+
+sub scrunch {
+ local($_) = @_;
+
+ return '' if $_ eq '';
+
+ study;
+
+ s/\$//g;
+ s/ / /g;
+ 1 while s/(\w) \1/$1$1/g;
+
+ # i wanna say this, but perl resists my efforts:
+ # s/(\w)(\1+)/$2 . length($1)/ge;
+
+ &quick_scrunch;
+
+ s/ $//;
+
+ $_;
+}
+
+sub buildscrunchlist {
+ $scrunch_code = "sub quick_scrunch {\n";
+ for (values %intrinsics) {
+ $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
+ }
+ $scrunch_code .= "}\n";
+ print "$scrunch_code" if $debug;
+ eval $scrunch_code;
+ &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
+}
+
+sub fetch_template {
+ local($mytype) = @_;
+ local($fmt);
+ local($count) = 1;
+
+ &panic("why do you care?") unless $perl;
+
+ if ($mytype =~ s/(\[\d+\])+$//) {
+ $count .= $1;
+ }
+
+ if ($mytype =~ /\*/) {
+ $fmt = $template{'pointer'};
+ }
+ elsif (defined $template{$mytype}) {
+ $fmt = $template{$mytype};
+ }
+ elsif (defined $struct{$mytype}) {
+ if (!defined $template{&psou($mytype)}) {
+ &build_template($mytype) unless $mytype eq $name;
+ }
+ elsif ($template{&psou($mytype)} !~ /\$$/) {
+ #warn "incomplete template for $mytype\n";
+ }
+ $fmt = $template{&psou($mytype)} || '?';
+ }
+ else {
+ warn "unknown fmt for $mytype\n";
+ $fmt = '?';
+ }
+
+ $fmt x $count . ' ';
+}
+
+sub compute_intrinsics {
+ local($TMP) = "/tmp/c2ph-i.$$.c";
+ open (TMP, ">$TMP") || die "can't open $TMP: $!";
+ select(TMP);
+
+ print STDERR "computing intrinsic sizes: " if $trace;
+
+ undef %intrinsics;
+
+ print <<'EOF';
+main() {
+ char *mask = "%d %s\n";
+EOF
+
+ for $type (@intrinsics) {
+ next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
+ print <<"EOF";
+ printf(mask,sizeof($type), "$type");
+EOF
+ }
+
+ print <<'EOF';
+ printf(mask,sizeof(char *), "pointer");
+ exit(0);
+}
+EOF
+ close TMP;
+
+ select(STDOUT);
+ open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
+ while (<PIPE>) {
+ chop;
+ split(' ',$_,2);;
+ print "intrinsic $_[1] is size $_[0]\n" if $debug;
+ $sizeof{$_[1]} = $_[0];
+ $intrinsics{$_[1]} = $template{$_[0]};
+ }
+ close(PIPE) || die "couldn't read intrinsics!";
+ unlink($TMP, '/tmp/a.out');
+ print STDERR "done\n" if $trace;
+}
+
+sub scripts2count {
+ local($_) = @_;
+
+ s/^\[//;
+ s/\]$//;
+ s/\]\[/*/g;
+ $_ = eval;
+ &panic("$_: $@") if $@;
+ $_;
+}
+
+sub system {
+ print STDERR "@_\n" if $trace;
+ system @_;
+}
+
+sub build_template {
+ local($name) = @_;
+
+ &panic("already got a template for $name") if defined $template{$name};
+
+ local($build_templates) = 1;
+
+ local($lparen) = '(' x $build_recursed;
+ local($rparen) = ')' x $build_recursed;
+
+ print STDERR "$lparen$name$rparen " if $trace;
+ $build_recursed++;
+ &pstruct($name,$name,0);
+ print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
+ --$build_recursed;
+}
+
+
+sub panic {
+
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ local($i,$_);
+ local($p,$f,$l,$s,$h,$a,@a,@sub);
+ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @DB'args;
+ for (@a) {
+ if (/^StB\000/ && length($_) == length($_main{'_main'})) {
+ $_ = sprintf("%s",$_);
+ }
+ else {
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ push(@sub, "$w&$s$a from file $f line $l\n");
+ last if $signal;
+ }
+ for ($i=0; $i <= $#sub; $i++) {
+ last if $signal;
+ print $sub[$i];
+ }
+ exit 1;
+}
+
+sub squishseq {
+ local($num);
+ local($last) = -1e8;
+ local($string);
+ local($seq) = '..';
+
+ while (defined($num = shift)) {
+ if ($num == ($last + 1)) {
+ $string .= $seq unless $inseq++;
+ $last = $num;
+ next;
+ } elsif ($inseq) {
+ $string .= $last unless $last == -1e8;
+ }
+
+ $string .= ',' if defined $string;
+ $string .= $num;
+ $last = $num;
+ $inseq = 0;
+ }
+ $string .= $last if $inseq && $last != -e18;
+ $string;
+}
+
+sub repeat_template {
+ # local($template, $scripts) = @_; have to change caller's values
+
+ if ( $_[1] ) {
+ local($ncount) = &scripts2count($_[1]);
+ if ($_[0] =~ /^\s*c\s*$/i) {
+ $_[0] = "A$ncount ";
+ $_[1] = '';
+ } else {
+ $_[0] = $template x $ncount;
+ }
+ }
+}
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+unlink 'pstruct';
+print "Linking c2ph to pstruct.\n";
+if (defined $Config{d_link}) {
+ link 'c2ph', 'pstruct';
+} else {
+ unshift @INC, '../lib';
+ require File::Copy;
+ File::Copy::syscopy('c2ph', 'pstruct');
+}
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/utils/h2ph.PL b/contrib/perl5/utils/h2ph.PL
new file mode 100644
index 000000000000..066f2c9c3fe5
--- /dev/null
+++ b/contrib/perl5/utils/h2ph.PL
@@ -0,0 +1,636 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(basename dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+# Wanted: $archlibexp
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+use Config;
+use File::Path qw(mkpath);
+use Getopt::Std;
+
+getopts('Dd:rlhaQ');
+die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
+@inc_dirs = inc_dirs() if $opt_a;
+
+my $Exit = 0;
+
+my $Dest_dir = $opt_d || $Config{installsitearch};
+die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
+ unless -d $Dest_dir;
+
+@isatype = split(' ',<<END);
+ char uchar u_char
+ short ushort u_short
+ int uint u_int
+ long ulong u_long
+ FILE key_t caddr_t
+END
+
+@isatype{@isatype} = (1) x @isatype;
+$inif = 0;
+
+@ARGV = ('-') unless @ARGV;
+
+while (defined ($file = next_file())) {
+ if (-l $file and -d $file) {
+ link_if_possible($file) if ($opt_l);
+ next;
+ }
+
+ # Recover from header files with unbalanced cpp directives
+ $t = '';
+ $tab = 0;
+
+ # $eval_index goes into ``#line'' directives, to help locate syntax errors:
+ $eval_index = 1;
+
+ if ($file eq '-') {
+ open(IN, "-");
+ open(OUT, ">-");
+ } else {
+ ($outfile = $file) =~ s/\.h$/.ph/ || next;
+ print "$file -> $outfile\n" unless $opt_Q;
+ if ($file =~ m|^(.*)/|) {
+ $dir = $1;
+ mkpath "$Dest_dir/$dir";
+ }
+
+ if ($opt_a) { # automagic mode: locate header file in @inc_dirs
+ foreach (@inc_dirs) {
+ chdir $_;
+ last if -f $file;
+ }
+ }
+
+ open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
+ open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
+ }
+ while (<IN>) {
+ chop;
+ while (/\\$/) {
+ chop;
+ $_ .= <IN>;
+ chop;
+ }
+ print OUT "# $_\n" if $opt_D;
+ if (s:/\*:\200:g) {
+ s:\*/:\201:g;
+ s/\200[^\201]*\201//g; # delete single line comments
+ if (s/\200.*//) { # begin multi-line comment?
+ $_ .= '/*';
+ $_ .= <IN>;
+ redo;
+ }
+ }
+ if (s/^\s*\#\s*//) {
+ if (s/^define\s+(\w+)//) {
+ $name = $1;
+ $new = '';
+ s/\s+$//;
+ if (s/^\(([\w,\s]*)\)//) {
+ $args = $1;
+ my $proto = '() ';
+ if ($args ne '') {
+ $proto = '';
+ foreach $arg (split(/,\s*/,$args)) {
+ $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
+ $curargs{$arg} = 1;
+ }
+ $args =~ s/\b(\w)/\$$1/g;
+ $args = "local($args) = \@_;\n$t ";
+ }
+ s/^\s+//;
+ expr();
+ $new =~ s/(["\\])/\\$1/g; #"]);
+ $new = reindent($new);
+ $args = reindent($args);
+ if ($t ne '') {
+ $new =~ s/(['\\])/\\$1/g; #']);
+ if ($opt_h) {
+ print OUT $t,
+ "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
+ $eval_index++;
+ } else {
+ print OUT $t,
+ "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
+ }
+ } else {
+ print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
+ }
+ %curargs = ();
+ } else {
+ s/^\s+//;
+ expr();
+ $new = 1 if $new eq '';
+ $new = reindent($new);
+ $args = reindent($args);
+ if ($t ne '') {
+ $new =~ s/(['\\])/\\$1/g; #']);
+ if ($opt_h) {
+ print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+ $eval_index++;
+ } else {
+ print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+ }
+ } else {
+ print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
+ }
+ }
+ } elsif (/^(include|import)\s*[<"](.*)[>"]/) {
+ ($incl = $2) =~ s/\.h$/.ph/;
+ print OUT $t,"require '$incl';\n";
+ } elsif(/^include_next\s*[<"](.*)[>"]/) {
+ ($incl = $1) =~ s/\.h$/.ph/;
+ print OUT ($t,
+ "eval {\n");
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT ($t,
+ "my(\%INCD) = map { \$INC{\$_} => 1 } ",
+ "(grep { \$_ eq \"$incl\" } keys(\%INC));\n");
+ print OUT ($t,
+ "my(\@REM) = map { \"\$_/$incl\" } ",
+ "(grep { not exists(\$INCD{\"\$_/$incl\"})",
+ "and -f \"\$_/$incl\" } \@INC);\n");
+ print OUT ($t,
+ "require \"\$REM[0]\" if \@REM;\n");
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT ($t,
+ "};\n");
+ print OUT ($t,
+ "warn(\$\@) if \$\@;\n");
+ } elsif (/^ifdef\s+(\w+)/) {
+ print OUT $t,"if(defined(&$1)) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (/^ifndef\s+(\w+)/) {
+ print OUT $t,"unless(defined(&$1)) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (s/^if\s+//) {
+ $new = '';
+ $inif = 1;
+ expr();
+ $inif = 0;
+ print OUT $t,"if($new) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (s/^elif\s+//) {
+ $new = '';
+ $inif = 1;
+ expr();
+ $inif = 0;
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"}\n elsif($new) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (/^else/) {
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"} else {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (/^endif/) {
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"}\n";
+ } elsif(/^undef\s+(\w+)/) {
+ print OUT $t, "undef(&$1) if defined(&$1);\n";
+ } elsif(/^error\s+(.*)/) {
+ print OUT $t, "die(\"$1\");\n";
+ } elsif(/^warning\s+(.*)/) {
+ print OUT $t, "warn(\"$1\");\n";
+ } elsif(/^ident\s+(.*)/) {
+ print OUT $t, "# $1\n";
+ }
+ } elsif(/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?\{/) {
+ until(/\}.*?;/) {
+ chomp($next = <IN>);
+ $_ .= $next;
+ print OUT "# $next\n" if $opt_D;
+ }
+ s@/\*.*?\*/@@g;
+ s/\s+/ /g;
+ /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
+ ($enum_subs = $3) =~ s/\s//g;
+ @enum_subs = split(/,/, $enum_subs);
+ $enum_val = -1;
+ for $enum (@enum_subs) {
+ ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
+ $enum_value =~ s/^=//;
+ $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
+ if ($opt_h) {
+ print OUT ($t,
+ "eval(\"\\n#line $eval_index $outfile\\n",
+ "sub $enum_name () \{ $enum_val; \}\") ",
+ "unless defined(\&$enum_name);\n");
+ ++ $eval_index;
+ } else {
+ print OUT ($t,
+ "eval(\"sub $enum_name () \{ $enum_val; \}\") ",
+ "unless defined(\&$enum_name);\n");
+ }
+ }
+ }
+ }
+ print OUT "1;\n";
+
+ $is_converted{$file} = 1;
+ queue_includes_from($file) if ($opt_a);
+}
+
+exit $Exit;
+
+sub reindent($) {
+ my($text) = shift;
+ $text =~ s/\n/\n /g;
+ $text =~ s/ /\t/g;
+ $text;
+}
+
+sub expr {
+ if(keys(%curargs)) {
+ my($joined_args) = join('|', keys(%curargs));
+ }
+ while ($_ ne '') {
+ s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
+ s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
+ s/^(\s+)// && do {$new .= ' '; next;};
+ s/^(0X[0-9A-F]+)[UL]*//i && do {$new .= lc($1); next;};
+ s/^(-?\d+\.\d+E[-+]\d+)F?//i && do {$new .= $1; next;};
+ s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
+ s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
+ s/^'((\\"|[^"])*)'// && do {
+ if ($curargs{$1}) {
+ $new .= "ord('\$$1')";
+ } else {
+ $new .= "ord('$1')";
+ }
+ next;
+ };
+ # replace "sizeof(foo)" with "{foo}"
+ # also, remove * (C dereference operator) to avoid perl syntax
+ # problems. Where the %sizeof array comes from is anyone's
+ # guess (c2ph?), but this at least avoids fatal syntax errors.
+ # Behavior is undefined if sizeof() delimiters are unbalanced.
+ # This code was modified to able to handle constructs like this:
+ # sizeof(*(p)), which appear in the HP-UX 10.01 header files.
+ s/^sizeof\s*\(// && do {
+ $new .= '$sizeof';
+ my $lvl = 1; # already saw one open paren
+ # tack { on the front, and skip it in the loop
+ $_ = "{" . "$_";
+ my $index = 1;
+ # find balanced closing paren
+ while ($index <= length($_) && $lvl > 0) {
+ $lvl++ if substr($_, $index, 1) eq "(";
+ $lvl-- if substr($_, $index, 1) eq ")";
+ $index++;
+ }
+ # tack } on the end, replacing )
+ substr($_, $index - 1, 1) = "}";
+ # remove pesky * operators within the sizeof argument
+ substr($_, 0, $index - 1) =~ s/\*//g;
+ next;
+ };
+ # Eliminate typedefs
+ /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
+ foreach (split /\s+/, $1) { # Make sure all the words are types,
+ last unless ($isatype{$_} or $_ eq 'struct');
+ }
+ s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
+ };
+ # struct/union member, including arrays:
+ s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
+ $id = $1;
+ $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
+ $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
+ while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
+ my($index) = $1;
+ $index =~ s/\s//g;
+ if(exists($curargs{$index})) {
+ $index = "\$$index";
+ } else {
+ $index = "&$index";
+ }
+ $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
+ }
+ $new .= " (\$$id)";
+ };
+ s/^([_a-zA-Z]\w*)// && do {
+ $id = $1;
+ if ($id eq 'struct') {
+ s/^\s+(\w+)//;
+ $id .= ' ' . $1;
+ $isatype{$id} = 1;
+ } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
+ while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
+ $isatype{$id} = 1;
+ }
+ if ($curargs{$id}) {
+ $new .= "\$$id";
+ $new .= '->' if /^[\[\{]/;
+ } elsif ($id eq 'defined') {
+ $new .= 'defined';
+ } elsif (/^\(/) {
+ s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
+ $new .= " &$id";
+ } elsif ($isatype{$id}) {
+ if ($new =~ /{\s*$/) {
+ $new .= "'$id'";
+ } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
+ $new =~ s/\(\s*$//;
+ s/^[\s*]*\)//;
+ } else {
+ $new .= q(').$id.q(');
+ }
+ } else {
+ if ($inif && $new !~ /defined\s*\($/) {
+ $new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
+ } elsif (/^\[/) {
+ $new .= " \$$id";
+ } else {
+ $new .= ' &' . $id;
+ }
+ }
+ next;
+ };
+ s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
+ }
+}
+
+
+# Handle recursive subdirectories without getting a grotesquely big stack.
+# Could this be implemented using File::Find?
+sub next_file
+{
+ my $file;
+
+ while (@ARGV) {
+ $file = shift @ARGV;
+
+ if ($file eq '-' or -f $file or -l $file) {
+ return $file;
+ } elsif (-d $file) {
+ if ($opt_r) {
+ expand_glob($file);
+ } else {
+ print STDERR "Skipping directory `$file'\n";
+ }
+ } elsif ($opt_a) {
+ return $file;
+ } else {
+ print STDERR "Skipping `$file': not a file or directory\n";
+ }
+ }
+
+ return undef;
+}
+
+
+# Put all the files in $directory into @ARGV for processing.
+sub expand_glob
+{
+ my ($directory) = @_;
+
+ $directory =~ s:/$::;
+
+ opendir DIR, $directory;
+ foreach (readdir DIR) {
+ next if ($_ eq '.' or $_ eq '..');
+
+ # expand_glob() is going to be called until $ARGV[0] isn't a
+ # directory; so push directories, and unshift everything else.
+ if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
+ else { unshift @ARGV, "$directory/$_" }
+ }
+ closedir DIR;
+}
+
+
+# Given $file, a symbolic link to a directory in the C include directory,
+# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
+# Otherwise, just duplicate the file or directory.
+sub link_if_possible
+{
+ my ($dirlink) = @_;
+ my $target = eval 'readlink($dirlink)';
+
+ if ($target =~ m:^\.\./: or $target =~ m:^/:) {
+ # The target of a parent or absolute link could leave the $Dest_dir
+ # hierarchy, so let's put all of the contents of $dirlink (actually,
+ # the contents of $target) into @ARGV; as a side effect down the
+ # line, $dirlink will get created as an _actual_ directory.
+ expand_glob($dirlink);
+ } else {
+ if (-l "$Dest_dir/$dirlink") {
+ unlink "$Dest_dir/$dirlink" or
+ print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
+ }
+
+ if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
+ print "Linking $target -> $Dest_dir/$dirlink\n";
+
+ # Make sure that the link _links_ to something:
+ if (! -e "$Dest_dir/$target") {
+ mkpath("$Dest_dir/$target", 0755) or
+ print STDERR "Could not create $Dest_dir/$target/\n";
+ }
+ } else {
+ print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
+ }
+ }
+}
+
+
+# Push all #included files in $file onto our stack, except for STDIN
+# and files we've already processed.
+sub queue_includes_from
+{
+ my ($file) = @_;
+ my $line;
+
+ return if ($file eq "-");
+
+ open HEADER, $file or return;
+ while (defined($line = <HEADER>)) {
+ while (/\\$/) { # Handle continuation lines
+ chop $line;
+ $line .= <HEADER>;
+ }
+
+ if ($line =~ /^#\s*include\s+<(.*?)>/) {
+ push(@ARGV, $1) unless $is_converted{$1};
+ }
+ }
+ close HEADER;
+}
+
+
+# Determine include directories; $Config{usrinc} should be enough for (all
+# non-GCC?) C compilers, but gcc uses an additional include directory.
+sub inc_dirs
+{
+ my $from_gcc = `$Config{cc} -v 2>&1`;
+ $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s;
+
+ length($from_gcc) ? ($from_gcc, $Config{usrinc}) : ($Config{usrinc});
+}
+
+
+1;
+
+##############################################################################
+__END__
+
+=head1 NAME
+
+h2ph - convert .h C header files to .ph Perl header files
+
+=head1 SYNOPSIS
+
+B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
+
+=head1 DESCRIPTION
+
+I<h2ph>
+converts any C header files specified to the corresponding Perl header file
+format.
+It is most easily run while in /usr/include:
+
+ cd /usr/include; h2ph * sys/*
+
+or
+
+ cd /usr/include; h2ph -r -l .
+
+The output files are placed in the hierarchy rooted at Perl's
+architecture dependent library directory. You can specify a different
+hierarchy with a B<-d> switch.
+
+If run with no arguments, filters standard input to standard output.
+
+=head1 OPTIONS
+
+=over 4
+
+=item -d destination_dir
+
+Put the resulting B<.ph> files beneath B<destination_dir>, instead of
+beneath the default Perl library location (C<$Config{'installsitsearch'}>).
+
+=item -r
+
+Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
+on all files in those directories (and their subdirectories, etc.). B<-r>
+and B<-a> are mutually exclusive.
+
+=item -a
+
+Run automagically; convert B<headerfiles>, as well as any B<.h> files
+which they include. This option will search for B<.h> files in all
+directories which your C compiler ordinarily uses. B<-a> and B<-r> are
+mutually exclusive.
+
+=item -l
+
+Symbolic links will be replicated in the destination directory. If B<-l>
+is not specified, then links are skipped over.
+
+=item -h
+
+Put ``hints'' in the .ph files which will help in locating problems with
+I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
+errors, instead of the cryptic
+
+ [ some error condition ] at (eval mmm) line nnn
+
+you will see the slightly more helpful
+
+ [ some error condition ] at filename.ph line nnn
+
+However, the B<.ph> files almost double in size when built using B<-h>.
+
+=item -D
+
+Include the code from the B<.h> file as a comment in the B<.ph> file.
+This is primarily used for debugging I<h2ph>.
+
+=back
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 FILES
+
+ /usr/include/*.h
+ /usr/include/sys/*.h
+
+etc.
+
+=head1 AUTHOR
+
+Larry Wall
+
+=head1 SEE ALSO
+
+perl(1)
+
+=head1 DIAGNOSTICS
+
+The usual warnings if it can't read or write the files involved.
+
+=head1 BUGS
+
+Doesn't construct the %sizeof array for you.
+
+It doesn't handle all C constructs, but it does attempt to isolate
+definitions inside evals so that you can get at the definitions
+that it can translate.
+
+It's only intended as a rough tool.
+You may need to dicker with the files produced.
+
+=cut
+
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/utils/h2xs.PL b/contrib/perl5/utils/h2xs.PL
new file mode 100644
index 000000000000..52f590b776de
--- /dev/null
+++ b/contrib/perl5/utils/h2xs.PL
@@ -0,0 +1,905 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+=head1 NAME
+
+h2xs - convert .h C header files to Perl extensions
+
+=head1 SYNOPSIS
+
+B<h2xs> [B<-AOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]]
+
+B<h2xs> B<-h>
+
+=head1 DESCRIPTION
+
+I<h2xs> builds a Perl extension from C header files. The extension
+will include functions which can be used to retrieve the value of any
+#define statement which was in the C header files.
+
+The I<module_name> will be used for the name of the extension. If
+module_name is not supplied then the name of the first header file
+will be used, with the first character capitalized.
+
+If the extension might need extra libraries, they should be included
+here. The extension Makefile.PL will take care of checking whether
+the libraries actually exist and how they should be loaded.
+The extra libraries should be specified in the form -lm -lposix, etc,
+just as on the cc command line. By default, the Makefile.PL will
+search through the library path determined by Configure. That path
+can be augmented by including arguments of the form B<-L/another/library/path>
+in the extra-libraries argument.
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-A>
+
+Omit all autoload facilities. This is the same as B<-c> but also removes the
+S<C<require AutoLoader>> statement from the .pm file.
+
+=item B<-F>
+
+Additional flags to specify to C preprocessor when scanning header for
+function declarations. Should not be used without B<-x>.
+
+=item B<-O>
+
+Allows a pre-existing extension directory to be overwritten.
+
+=item B<-P>
+
+Omit the autogenerated stub POD section.
+
+=item B<-X>
+
+Omit the XS portion. Used to generate templates for a module which is not
+XS-based.
+
+=item B<-c>
+
+Omit C<constant()> from the .xs file and corresponding specialised
+C<AUTOLOAD> from the .pm file.
+
+=item B<-d>
+
+Turn on debugging messages.
+
+=item B<-f>
+
+Allows an extension to be created for a header even if that header is
+not found in /usr/include.
+
+=item B<-h>
+
+Print the usage, help and version for this h2xs and exit.
+
+=item B<-n> I<module_name>
+
+Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
+
+=item B<-p> I<prefix>
+
+Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_>
+This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are
+autoloaded via the C<constant()> mechansim.
+
+=item B<-s> I<sub1,sub2>
+
+Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine.
+These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
+
+=item B<-v> I<version>
+
+Specify a version number for this extension. This version number is added
+to the templates. The default is 0.01.
+
+=item B<-x>
+
+Automatically generate XSUBs basing on function declarations in the
+header file. The package C<C::Scan> should be installed. If this
+option is specified, the name of the header file may look like
+C<NAME1,NAME2>. In this case NAME1 is used instead of the specified string,
+but XSUBs are emitted only for the declarations included from file NAME2.
+
+Note that some types of arguments/return-values for functions may
+result in XSUB-declarations/typemap-entries which need
+hand-editing. Such may be objects which cannot be converted from/to a
+pointer (like C<long long>), pointers to functions, or arrays.
+
+=back
+
+=head1 EXAMPLES
+
+
+ # Default behavior, extension is Rusers
+ h2xs rpcsvc/rusers
+
+ # Same, but extension is RUSERS
+ h2xs -n RUSERS rpcsvc/rusers
+
+ # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
+ h2xs rpcsvc::rusers
+
+ # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h>
+ h2xs -n ONC::RPC rpcsvc/rusers
+
+ # Without constant() or AUTOLOAD
+ h2xs -c rpcsvc/rusers
+
+ # Creates templates for an extension named RPC
+ h2xs -cfn RPC
+
+ # Extension is ONC::RPC.
+ h2xs -cfn ONC::RPC
+
+ # Makefile.PL will look for library -lrpc in
+ # additional directory /opt/net/lib
+ h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
+
+ # Extension is DCE::rgynbase
+ # prefix "sec_rgy_" is dropped from perl function names
+ h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
+
+ # Extension is DCE::rgynbase
+ # prefix "sec_rgy_" is dropped from perl function names
+ # subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid
+ h2xs -n DCE::rgynbase -p sec_rgy_ \
+ -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
+
+ # Make XS without defines in perl.h, but with function declarations
+ # visible from perl.h. Name of the extension is perl1.
+ # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
+ # Extra backslashes below because the string is passed to shell.
+ # Note that a directory with perl header files would
+ # be added automatically to include path.
+ h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
+
+ # Same with function declaration in proto.h as visible from perl.h.
+ h2xs -xAn perl2 perl.h,proto.h
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 AUTHOR
+
+Larry Wall and others
+
+=head1 SEE ALSO
+
+L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
+
+=head1 DIAGNOSTICS
+
+The usual warnings if it cannot read or write the files involved.
+
+=cut
+
+my( $H2XS_VERSION ) = ' $Revision: 1.18 $ ' =~ /\$Revision:\s+([^\s]+)/;
+my $TEMPLATE_VERSION = '0.01';
+
+use Getopt::Std;
+
+sub usage{
+ warn "@_\n" if @_;
+ die "h2xs [-AOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
+version: $H2XS_VERSION
+ -A Omit all autoloading facilities (implies -c).
+ -F Additional flags for C preprocessor (used with -x).
+ -O Allow overwriting of a pre-existing extension directory.
+ -P Omit the stub POD section.
+ -X Omit the XS portion.
+ -c Omit the constant() function and specialised AUTOLOAD from the XS file.
+ -d Turn on debugging messages.
+ -f Force creation of the extension even if the C header does not exist.
+ -h Display this help message
+ -n Specify a name to use for the extension (recommended).
+ -p Specify a prefix which should be removed from the Perl function names.
+ -s Create subroutines for specified macros.
+ -v Specify a version number for this extension.
+ -x Autogenerate XSUBs using C::Scan.
+extra_libraries
+ are any libraries that might be needed for loading the
+ extension, e.g. -lm would try to link in the math library.
+";
+}
+
+
+getopts("AF:OPXcdfhn:p:s:v:x") || usage;
+
+usage if $opt_h;
+
+if( $opt_v ){
+ $TEMPLATE_VERSION = $opt_v;
+}
+$opt_c = 1 if $opt_A;
+%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
+
+while (my $arg = shift) {
+ if ($arg =~ /^-l/i) {
+ $extralibs = "$arg @ARGV";
+ last;
+ }
+ push(@path_h, $arg);
+}
+
+usage "Must supply header file or module name\n"
+ unless (@path_h or $opt_n);
+
+
+if( @path_h ){
+ foreach my $path_h (@path_h) {
+ $name ||= $path_h;
+ if( $path_h =~ s#::#/#g && $opt_n ){
+ warn "Nesting of headerfile ignored with -n\n";
+ }
+ $path_h .= ".h" unless $path_h =~ /\.h$/;
+ $fullpath = $path_h;
+ $path_h =~ s/,.*$// if $opt_x;
+ if ($^O eq 'VMS') { # Consider overrides of default location
+ if ($path_h !~ m![:>\[]!) {
+ my($hadsys) = ($path_h =~ s!^sys/!!i);
+ if ($ENV{'DECC$System_Include'}) { $path_h = "DECC\$System_Include:$path_h"; }
+ elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h"; }
+ elsif ($ENV{'GNU_CC_Include'}) { $path_h = 'GNU_CC_Include:' .
+ ($hadsys ? '[vms]' : '[000000]') . $path_h; }
+ elsif ($ENV{'VAXC$Include'}) { $path_h = "VAXC\$_Include:$path_h"; }
+ else { $path_h = "Sys\$Library:$path_h"; }
+ }
+ }
+ elsif ($^O eq 'os2') {
+ $path_h = "/usr/include/$path_h"
+ if $path_h !~ m#^([a-z]:)?[./]#i and -r "/usr/include/$path_h";
+ }
+ else {
+ $path_h = "/usr/include/$path_h"
+ if $path_h !~ m#^[./]# and -r "/usr/include/$path_h";
+ }
+
+ if (!$opt_c) {
+ die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
+ # Scan the header file (we should deal with nested header files)
+ # Record the names of simple #define constants into const_names
+ # Function prototypes are processed below.
+ open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
+ while (<CH>) {
+ if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) {
+ print "Matched $_ ($1)\n" if $opt_d;
+ $_ = $1;
+ next if /^_.*_h_*$/i; # special case, but for what?
+ if (defined $opt_p) {
+ if (!/^$opt_p(\d)/) {
+ ++$prefix{$_} if s/^$opt_p//;
+ }
+ else {
+ warn "can't remove $opt_p prefix from '$_'!\n";
+ }
+ }
+ $const_names{$_}++;
+ }
+ }
+ close(CH);
+ }
+ }
+ @const_names = sort keys %const_names;
+}
+
+
+$module = $opt_n || do {
+ $name =~ s/\.h$//;
+ if( $name !~ /::/ ){
+ $name =~ s#^.*/##;
+ $name = "\u$name";
+ }
+ $name;
+};
+
+(chdir 'ext', $ext = 'ext/') if -d 'ext';
+
+if( $module =~ /::/ ){
+ $nested = 1;
+ @modparts = split(/::/,$module);
+ $modfname = $modparts[-1];
+ $modpname = join('/',@modparts);
+}
+else {
+ $nested = 0;
+ @modparts = ();
+ $modfname = $modpname = $module;
+}
+
+
+if ($opt_O) {
+ warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
+} else {
+ die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
+}
+if( $nested ){
+ $modpath = "";
+ foreach (@modparts){
+ mkdir("$modpath$_", 0777);
+ $modpath .= "$_/";
+ }
+}
+mkdir($modpname, 0777);
+chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
+
+my %types_seen;
+my %std_types;
+my $fdecls;
+my $fdecls_parsed;
+
+if( ! $opt_X ){ # use XS, unless it was disabled
+ open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
+ if ($opt_x) {
+ require C::Scan; # Run-time directive
+ require Config; # Run-time directive
+ warn "Scanning typemaps...\n";
+ get_typemap();
+ my $c;
+ my $filter;
+ my @fdecls;
+ foreach my $filename (@path_h) {
+ my $addflags = $opt_F || '';
+ if ($fullpath =~ /,/) {
+ $filename = $`;
+ $filter = $';
+ }
+ warn "Scanning $filename for functions...\n";
+ $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
+ 'add_cppflags' => $addflags;
+ $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
+
+ $fdecls_parsed = $c->get('parsed_fdecls');
+ push(@fdecls, @{$c->get('fdecls')});
+ }
+ $fdecls = [ @fdecls ];
+ }
+}
+
+open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
+
+$" = "\n\t";
+warn "Writing $ext$modpname/$modfname.pm\n";
+
+print PM <<"END";
+package $module;
+
+use strict;
+END
+
+if( $opt_X || $opt_c || $opt_A ){
+ # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD
+ print PM <<'END';
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+END
+}
+else{
+ # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
+ # will want Carp.
+ print PM <<'END';
+use Carp;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+END
+}
+
+print PM <<'END';
+
+require Exporter;
+END
+
+print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled
+require DynaLoader;
+END
+
+# require autoloader if XS is disabled.
+# if XS is enabled, require autoloader unless autoloading is disabled.
+if( ($opt_X && (! $opt_A)) || (!$opt_X) ) {
+ print PM <<"END";
+require AutoLoader;
+END
+}
+
+if( $opt_X || ($opt_c && ! $opt_A) ){
+ # we won't have our own AUTOLOAD(), so we'll inherit it.
+ if( ! $opt_X ) { # use DynaLoader, unless XS was disabled
+ print PM <<"END";
+
+\@ISA = qw(Exporter AutoLoader DynaLoader);
+END
+ }
+ else{
+ print PM <<"END";
+
+\@ISA = qw(Exporter AutoLoader);
+END
+ }
+}
+else{
+ # 1) we have our own AUTOLOAD(), so don't need to inherit it.
+ # or
+ # 2) we don't want autoloading mentioned.
+ if( ! $opt_X ){ # use DynaLoader, unless XS was disabled
+ print PM <<"END";
+
+\@ISA = qw(Exporter DynaLoader);
+END
+ }
+ else{
+ print PM <<"END";
+
+\@ISA = qw(Exporter);
+END
+ }
+}
+
+print PM<<"END";
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+\@EXPORT = qw(
+ @const_names
+);
+\$VERSION = '$TEMPLATE_VERSION';
+
+END
+
+print PM <<"END" unless $opt_c or $opt_X;
+sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function. If a constant is not found then control is passed
+ # to the AUTOLOAD in AutoLoader.
+
+ my \$constname;
+ (\$constname = \$AUTOLOAD) =~ s/.*:://;
+ croak "&$module::constant not defined" if \$constname eq 'constant';
+ my \$val = constant(\$constname, \@_ ? \$_[0] : 0);
+ if (\$! != 0) {
+ if (\$! =~ /Invalid/) {
+ \$AutoLoader::AUTOLOAD = \$AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ croak "Your vendor has not defined $module macro \$constname";
+ }
+ }
+ *\$AUTOLOAD = sub () { \$val };
+ goto &\$AUTOLOAD;
+}
+
+END
+
+if( ! $opt_X ){ # print bootstrap, unless XS is disabled
+ print PM <<"END";
+bootstrap $module \$VERSION;
+END
+}
+
+if( $opt_P ){ # if POD is disabled
+ $after = '__END__';
+}
+else {
+ $after = '=cut';
+}
+
+print PM <<"END";
+
+# Preloaded methods go here.
+
+# Autoload methods go after $after, and are processed by the autosplit program.
+
+1;
+__END__
+END
+
+$author = "A. U. Thor";
+$email = 'a.u.thor@a.galaxy.far.far.away';
+
+my $const_doc = '';
+my $fdecl_doc = '';
+if (@const_names and not $opt_P) {
+ $const_doc = <<EOD;
+\n=head1 Exported constants
+
+ @{[join "\n ", @const_names]}
+
+EOD
+}
+if (defined $fdecls and @$fdecls and not $opt_P) {
+ $fdecl_doc = <<EOD;
+\n=head1 Exported functions
+
+ @{[join "\n ", @$fdecls]}
+
+EOD
+}
+
+$pod = <<"END" unless $opt_P;
+## Below is the stub of documentation for your module. You better edit it!
+#
+#=head1 NAME
+#
+#$module - Perl extension for blah blah blah
+#
+#=head1 SYNOPSIS
+#
+# use $module;
+# blah blah blah
+#
+#=head1 DESCRIPTION
+#
+#Stub documentation for $module was created by h2xs. It looks like the
+#author of the extension was negligent enough to leave the stub
+#unedited.
+#
+#Blah blah blah.
+#$const_doc$fdecl_doc
+#=head1 AUTHOR
+#
+#$author, $email
+#
+#=head1 SEE ALSO
+#
+#perl(1).
+#
+#=cut
+END
+
+$pod =~ s/^\#//gm unless $opt_P;
+print PM $pod unless $opt_P;
+
+close PM;
+
+
+if( ! $opt_X ){ # print XS, unless it is disabled
+warn "Writing $ext$modpname/$modfname.xs\n";
+
+print XS <<"END";
+#ifdef __cplusplus
+extern "C" {
+#endif
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#ifdef __cplusplus
+}
+#endif
+
+END
+if( @path_h ){
+ foreach my $path_h (@path_h) {
+ my($h) = $path_h;
+ $h =~ s#^/usr/include/##;
+ if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
+ print XS qq{#include <$h>\n};
+ }
+ print XS "\n";
+}
+
+if( ! $opt_c ){
+print XS <<"END";
+static int
+not_here(s)
+char *s;
+{
+ croak("$module::%s not implemented on this architecture", s);
+ return -1;
+}
+
+static double
+constant(name, arg)
+char *name;
+int arg;
+{
+ errno = 0;
+ switch (*name) {
+END
+
+my(@AZ, @az, @under);
+
+foreach(@const_names){
+ @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
+ @az = 'a' .. 'z' if !@az && /^[a-z]/;
+ @under = '_' if !@under && /^_/;
+}
+
+foreach $letter (@AZ, @az, @under) {
+
+ last if $letter eq 'a' && !@const_names;
+
+ print XS " case '$letter':\n";
+ my($name);
+ while (substr($const_names[0],0,1) eq $letter) {
+ $name = shift(@const_names);
+ $macro = $prefix{$name} ? "$opt_p$name" : $name;
+ next if $const_xsub{$macro};
+ print XS <<"END";
+ if (strEQ(name, "$name"))
+#ifdef $macro
+ return $macro;
+#else
+ goto not_there;
+#endif
+END
+ }
+ print XS <<"END";
+ break;
+END
+}
+print XS <<"END";
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+END
+}
+
+$prefix = "PREFIX = $opt_p" if defined $opt_p;
+# Now switch from C to XS by issuing the first MODULE declaration:
+print XS <<"END";
+
+MODULE = $module PACKAGE = $module $prefix
+
+END
+
+foreach (sort keys %const_xsub) {
+ print XS <<"END";
+char *
+$_()
+
+ CODE:
+#ifdef $_
+ RETVAL = $_;
+#else
+ croak("Your vendor has not defined the $module macro $_");
+#endif
+
+ OUTPUT:
+ RETVAL
+
+END
+}
+
+# If a constant() function was written then output a corresponding
+# XS declaration:
+print XS <<"END" unless $opt_c;
+
+double
+constant(name,arg)
+ char * name
+ int arg
+
+END
+
+my %seen_decl;
+
+
+sub print_decl {
+ my $fh = shift;
+ my $decl = shift;
+ my ($type, $name, $args) = @$decl;
+ return if $seen_decl{$name}++; # Need to do the same for docs as well?
+
+ my @argnames = map {$_->[1]} @$args;
+ my @argtypes = map { normalize_type( $_->[0] ) } @$args;
+ my @argarrays = map { $_->[4] || '' } @$args;
+ my $numargs = @$args;
+ if ($numargs and $argtypes[-1] eq '...') {
+ $numargs--;
+ $argnames[-1] = '...';
+ }
+ local $" = ', ';
+ $type = normalize_type($type);
+
+ print $fh <<"EOP";
+
+$type
+$name(@argnames)
+EOP
+
+ for $arg (0 .. $numargs - 1) {
+ print $fh <<"EOP";
+ $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
+EOP
+ }
+}
+
+# Should be called before any actual call to normalize_type().
+sub get_typemap {
+ # We do not want to read ./typemap by obvios reasons.
+ my @tm = qw(../../../typemap ../../typemap ../typemap);
+ my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
+ unshift @tm, $stdtypemap;
+ my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
+ my $image;
+
+ foreach $typemap (@tm) {
+ next unless -e $typemap ;
+ # skip directories, binary files etc.
+ warn " Scanning $typemap\n";
+ warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
+ unless -T $typemap ;
+ open(TYPEMAP, $typemap)
+ or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
+ my $mode = 'Typemap';
+ while (<TYPEMAP>) {
+ next if /^\s*\#/;
+ if (/^INPUT\s*$/) { $mode = 'Input'; next; }
+ elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
+ elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
+ elsif ($mode eq 'Typemap') {
+ next if /^\s*($|\#)/ ;
+ if ( ($type, $image) =
+ /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
+ # This may reference undefined functions:
+ and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
+ normalize_type($type);
+ }
+ }
+ }
+ close(TYPEMAP) or die "Cannot close $typemap: $!";
+ }
+ %std_types = %types_seen;
+ %types_seen = ();
+}
+
+
+sub normalize_type {
+ my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*';
+ my $type = shift;
+ $type =~ s/$ignore_mods//go;
+ $type =~ s/([\]\[()])/ \1 /g;
+ $type =~ s/\s+/ /g;
+ $type =~ s/\s+$//;
+ $type =~ s/^\s+//;
+ $type =~ s/\b\*/ */g;
+ $type =~ s/\*\b/* /g;
+ $type =~ s/\*\s+(?=\*)/*/g;
+ $types_seen{$type}++
+ unless $type eq '...' or $type eq 'void' or $std_types{$type};
+ $type;
+}
+
+if ($opt_x) {
+ for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
+}
+
+close XS;
+
+if (%types_seen) {
+ my $type;
+ warn "Writing $ext$modpname/typemap\n";
+ open TM, ">typemap" or die "Cannot open typemap file for write: $!";
+
+ for $type (keys %types_seen) {
+ print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n"
+ }
+
+ close TM or die "Cannot close typemap file for write: $!";
+}
+
+} # if( ! $opt_X )
+
+warn "Writing $ext$modpname/Makefile.PL\n";
+open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
+
+print PL <<'END';
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+END
+print PL "WriteMakefile(\n";
+print PL " 'NAME' => '$module',\n";
+print PL " 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n";
+if( ! $opt_X ){ # print C stuff, unless XS is disabled
+ print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n";
+ print PL " 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' \n";
+ print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n";
+}
+print PL ");\n";
+close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
+
+warn "Writing $ext$modpname/test.pl\n";
+open(EX, ">test.pl") || die "Can't create $ext$modpname/test.pl: $!\n";
+print EX <<'_END_';
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### 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;}
+_END_
+print EX <<_END_;
+use $module;
+_END_
+print EX <<'_END_';
+$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):
+
+_END_
+close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
+
+warn "Writing $ext$modpname/Changes\n";
+open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
+print EX "Revision history for Perl extension $module.\n\n";
+print EX "$TEMPLATE_VERSION ",scalar localtime,"\n";
+print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n";
+close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
+
+warn "Writing $ext$modpname/MANIFEST\n";
+open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
+@files = <*>;
+if (!@files) {
+ eval {opendir(D,'.');};
+ unless ($@) { @files = readdir(D); closedir(D); }
+}
+if (!@files) { @files = map {chomp && $_} `ls`; }
+if ($^O eq 'VMS') {
+ foreach (@files) {
+ # Clip trailing '.' for portability -- non-VMS OSs don't expect it
+ s%\.$%%;
+ # Fix up for case-sensitive file systems
+ s/$modfname/$modfname/i && next;
+ $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
+ $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
+ }
+}
+print MANI join("\n",@files), "\n";
+close MANI;
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/utils/perlbug.PL b/contrib/perl5/utils/perlbug.PL
new file mode 100644
index 000000000000..589e7e69b4c7
--- /dev/null
+++ b/contrib/perl5/utils/perlbug.PL
@@ -0,0 +1,1093 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+# $perlpath
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT, ">$file" or die "Can't create $file: $!";
+
+# extract patchlevel.h information
+
+open PATCH_LEVEL, "<../patchlevel.h" or die "Can't open patchlevel.h: $!";
+
+my $patchlevel_date = (stat PATCH_LEVEL)[9];
+
+while (<PATCH_LEVEL>) {
+ last if $_ =~ /^\s*static\s+char.*?local_patches\[\]\s*=\s*{\s*$/;
+}
+
+my @patches;
+while (<PATCH_LEVEL>) {
+ last if /^\s*}/;
+ chomp;
+ s/^\s+,?"?//;
+ s/"?,?$//;
+ s/(['\\])/\\$1/g;
+ push @patches, $_ unless $_ eq 'NULL';
+}
+my $patch_desc = "'" . join("',\n '", @patches) . "'";
+my $patch_tags = join "", map /(\S+)/ ? "+$1 " : (), @patches;
+
+close PATCH_LEVEL;
+
+# TO DO (prehaps): store/embed $Config::config_sh into perlbug. When perlbug is
+# used, compare $Config::config_sh with the stored version. If they differ then
+# append a list of individual differences to the bug report.
+
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+
+my \$config_tag1 = '$] - $Config{cf_time}';
+
+my \$patchlevel_date = $patchlevel_date;
+my \$patch_tags = '$patch_tags';
+my \@patches = (
+ $patch_desc
+);
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+use Config;
+use Getopt::Std;
+use strict;
+
+sub paraprint;
+
+BEGIN {
+ eval "use Mail::Send;";
+ $::HaveSend = ($@ eq "");
+ eval "use Mail::Util;";
+ $::HaveUtil = ($@ eq "");
+};
+
+my $Version = "1.26";
+
+# Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
+# Changed in 1.07 to see more sendmail execs, and added pipe output.
+# Changed in 1.08 to use correct address for sendmail.
+# Changed in 1.09 to close the REP file before calling it up in the editor.
+# Also removed some old comments duplicated elsewhere.
+# Changed in 1.10 to run under VMS without Mail::Send; also fixed
+# temp filename generation.
+# Changed in 1.11 to clean up some text and removed Mail::Send deactivator.
+# Changed in 1.12 to check for editor errors, make save/send distinction
+# clearer and add $ENV{REPLYTO}.
+# Changed in 1.13 to hopefully make it more difficult to accidentally
+# send mail
+# Changed in 1.14 to make the prompts a little more clear on providing
+# helpful information. Also let file read fail gracefully.
+# Changed in 1.15 to add warnings to stop people using perlbug for non-bugs.
+# Also report selected environment variables.
+# Changed in 1.16 to include @INC, and allow user to re-edit if no changes.
+# Changed in 1.17 Win32 support added. GSAR 97-04-12
+# Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18
+# Changed in 1.19 '-ok' default not '-v'
+# add local patch information
+# warn on '-ok' if this is an old system; add '-okay'
+# Changed in 1.20 Added patchlevel.h reading and version/config checks
+# Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05
+# Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10
+# Changed in 1.23 Restore -ok(ay): say 'success'; don't prompt
+# Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01
+# Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
+# Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
+
+# TODO: - Allow the user to re-name the file on mail failure, and
+# make sure failure (transmission-wise) of Mail::Send is
+# accounted for.
+# - Test -b option
+
+my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename,
+ $subject, $from, $verbose, $ed, $outfile,
+ $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok);
+
+my $config_tag2 = "$] - $Config{cf_time}";
+
+Init();
+
+if ($::opt_h) { Help(); exit; }
+if ($::opt_d) { Dump(*STDOUT); exit; }
+if (!-t STDIN && !($ok and not $::opt_n)) {
+ paraprint <<EOF;
+Please use perlbug interactively. If you want to
+include a file, you can use the -f switch.
+EOF
+ die "\n";
+}
+if (!-t STDOUT && !$outfile) { Dump(*STDOUT); exit; }
+
+Query();
+Edit() unless $usefile || ($ok and not $::opt_n);
+NowWhat();
+Send();
+
+exit;
+
+sub Init {
+ # -------- Setup --------
+
+ $Is_MSWin32 = $^O eq 'MSWin32';
+ $Is_VMS = $^O eq 'VMS';
+
+ if (!getopts("dhva:s:b:f:F:r:e:SCc:to:n:")) { Help(); exit; };
+
+ # This comment is needed to notify metaconfig that we are
+ # using the $perladmin, $cf_by, and $cf_time definitions.
+
+ # -------- Configuration ---------
+
+ # perlbug address
+ $perlbug = 'perlbug@perl.com';
+
+ # Test address
+ $testaddress = 'perlbug-test@perl.com';
+
+ # Target address
+ $address = $::opt_a || ($::opt_t ? $testaddress : $perlbug);
+
+ # Users address, used in message and in Reply-To header
+ $from = $::opt_r || "";
+
+ # Include verbose configuration information
+ $verbose = $::opt_v || 0;
+
+ # Subject of bug-report message
+ $subject = $::opt_s || "";
+
+ # Send a file
+ $usefile = ($::opt_f || 0);
+
+ # File to send as report
+ $file = $::opt_f || "";
+
+ # File to output to
+ $outfile = $::opt_F || "";
+
+ # Body of report
+ $body = $::opt_b || "";
+
+ # Editor
+ $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
+ || ($Is_VMS && "edit/tpu")
+ || ($Is_MSWin32 && "notepad")
+ || "vi";
+
+ # Not OK - provide build failure template by finessing OK report
+ if ($::opt_n) {
+ if (substr($::opt_n, 0, 2) eq 'ok' ) {
+ $::opt_o = substr($::opt_n, 1);
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # OK - send "OK" report for build on this system
+ $ok = 0;
+ if ($::opt_o) {
+ if ($::opt_o eq 'k' or $::opt_o eq 'kay') {
+ my $age = time - $patchlevel_date;
+ if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) {
+ my $date = localtime $patchlevel_date;
+ print <<"EOF";
+"perlbug -ok" and "perlbug -nok" do not report on Perl versions which
+are more than 60 days old. This Perl version was constructed on
+$date. If you really want to report this, use
+"perlbug -okay" or "perlbug -nokay".
+EOF
+ exit();
+ }
+ # force these options
+ unless ($::opt_n) {
+ $::opt_S = 1; # don't prompt for send
+ $::opt_b = 1; # we have a body
+ $body = "Perl reported to build OK on this system.\n";
+ }
+ $::opt_C = 1; # don't send a copy to the local admin
+ $::opt_s = 1; # we have a subject line
+ $subject = ($::opt_n ? 'Not ' : '')
+ . "OK: perl $] ${patch_tags}on"
+ ." $::Config{'archname'} $::Config{'osvers'} $subject";
+ $ok = 1;
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # Possible administrator addresses, in order of confidence
+ # (Note that cf_email is not mentioned to metaconfig, since
+ # we don't really want it. We'll just take it if we have to.)
+ #
+ # This has to be after the $ok stuff above because of the way
+ # that $::opt_C is forced.
+ $cc = $::opt_C ? "" : (
+ $::opt_c || $::Config{'perladmin'}
+ || $::Config{'cf_email'} || $::Config{'cf_by'}
+ );
+
+ # My username
+ $me = $Is_MSWin32 ? $ENV{'USERNAME'}
+ : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'}
+ : eval { getpwuid($<) }; # May be missing
+
+ $from = $::Config{'cf_email'}
+ if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me &&
+ ($me eq $::Config{'cf_by'});
+} # sub Init
+
+sub Query {
+ # Explain what perlbug is
+ unless ($ok) {
+ paraprint <<EOF;
+This program provides an easy way to create a message reporting a bug
+in perl, and e-mail it to $address. It is *NOT* intended for
+sending test messages or simply verifying that perl works, *NOR* is it
+intended for reporting bugs in third-party perl modules. It is *ONLY*
+a means of reporting verifiable problems with the core perl distribution,
+and any solutions to such problems, to the people who maintain perl.
+
+If you're just looking for help with perl, try posting to the Usenet
+newsgroup comp.lang.perl.misc. If you're looking for help with using
+perl with CGI, try posting to comp.infosystems.www.programming.cgi.
+EOF
+ }
+
+ # Prompt for subject of message, if needed
+ unless ($subject) {
+ paraprint <<EOF;
+First of all, please provide a subject for the
+message. It should be a concise description of
+the bug or problem. "perl bug" or "perl problem"
+is not a concise description.
+EOF
+ print "Subject: ";
+ $subject = <>;
+
+ my $err = 0;
+ while ($subject !~ /\S/) {
+ print "\nPlease enter a subject: ";
+ $subject = <>;
+ if ($err++ > 5) {
+ die "Aborting.\n";
+ }
+ }
+ chop $subject;
+ }
+
+ # Prompt for return address, if needed
+ unless ($from) {
+ # Try and guess return address
+ my $guess;
+
+ $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || '';
+ unless ($guess) {
+ my $domain;
+ if ($::HaveUtil) {
+ $domain = Mail::Util::maildomain();
+ } elsif ($Is_MSWin32) {
+ $domain = $ENV{'USERDOMAIN'};
+ } else {
+ require Sys::Hostname;
+ $domain = Sys::Hostname::hostname();
+ }
+ if ($domain) {
+ if ($Is_VMS && !$::Config{'d_socket'}) {
+ $guess = "$domain\:\:$me";
+ } else {
+ $guess = "$me\@$domain" if $domain;
+ }
+ }
+ }
+
+ if ($guess) {
+ unless ($ok) {
+ paraprint <<EOF;
+Your e-mail address will be useful if you need to be contacted. If the
+default shown is not your full internet e-mail address, please correct it.
+EOF
+ }
+ } else {
+ paraprint <<EOF;
+So that you may be contacted if necessary, please enter
+your full internet e-mail address here.
+EOF
+ }
+
+ if ($ok && $guess) {
+ # use it
+ $from = $guess;
+ } else {
+ # verify it
+ print "Your address [$guess]: ";
+ $from = <>;
+ chop $from;
+ $from = $guess if $from eq '';
+ }
+ }
+
+ if ($from eq $cc or $me eq $cc) {
+ # Try not to copy ourselves
+ $cc = "yourself";
+ }
+
+ # Prompt for administrator address, unless an override was given
+ if( !$::opt_C and !$::opt_c ) {
+ paraprint <<EOF;
+A copy of this report can be sent to your local
+perl administrator. If the address is wrong, please
+correct it, or enter 'none' or 'yourself' to not send
+a copy.
+EOF
+ print "Local perl administrator [$cc]: ";
+ my $entry = scalar <>;
+ chop $entry;
+
+ if ($entry ne "") {
+ $cc = $entry;
+ $cc = '' if $me eq $cc;
+ }
+ }
+
+ $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i;
+ $andcc = " and $cc" if $cc;
+
+ # Prompt for editor, if no override is given
+editor:
+ unless ($::opt_e || $::opt_f || $::opt_b) {
+ paraprint <<EOF;
+Now you need to supply the bug report. Try to make
+the report concise but descriptive. Include any
+relevant detail. If you are reporting something
+that does not work as you think it should, please
+try to include example of both the actual
+result, and what you expected.
+
+Some information about your local
+perl configuration will automatically be included
+at the end of the report. If you are using any
+unusual version of perl, please try and confirm
+exactly which versions are relevant.
+
+You will probably want to use an editor to enter
+the report. If "$ed" is the editor you want
+to use, then just press Enter, otherwise type in
+the name of the editor you would like to use.
+
+If you would like to use a prepared file, type
+"file", and you will be asked for the filename.
+EOF
+ print "Editor [$ed]: ";
+ my $entry =scalar <>;
+ chop $entry;
+
+ $usefile = 0;
+ if ($entry eq "file") {
+ $usefile = 1;
+ } elsif ($entry ne "") {
+ $ed = $entry;
+ }
+ }
+
+ # Generate scratch file to edit report in
+ $filename = filename();
+
+ # Prompt for file to read report from, if needed
+ if ($usefile and !$file) {
+filename:
+ paraprint <<EOF;
+What is the name of the file that contains your report?
+EOF
+ print "Filename: ";
+ my $entry = scalar <>;
+ chop $entry;
+
+ if ($entry eq "") {
+ paraprint <<EOF;
+No filename? I'll let you go back and choose an editor again.
+EOF
+ goto editor;
+ }
+
+ unless (-f $entry and -r $entry) {
+ paraprint <<EOF;
+I'm sorry, but I can't read from `$entry'. Maybe you mistyped the name of
+the file? If you don't want to send a file, just enter a blank line and you
+can get back to the editor selection.
+EOF
+ goto filename;
+ }
+ $file = $entry;
+ }
+
+ # Generate report
+ open(REP,">$filename");
+ my $reptype = !$ok ? "bug" : $::opt_n ? "build failure" : "success";
+
+ print REP <<EOF;
+This is a $reptype report for perl from $from,
+generated with the help of perlbug $Version running under perl $].
+
+EOF
+
+ if ($body) {
+ print REP $body;
+ } elsif ($usefile) {
+ open(F, "<$file")
+ or die "Unable to read report file from `$file': $!\n";
+ while (<F>) {
+ print REP $_
+ }
+ close(F);
+ } else {
+ print REP <<EOF;
+
+-----------------------------------------------------------------
+[Please enter your report here]
+
+
+
+[Please do not change anything below this line]
+-----------------------------------------------------------------
+EOF
+ }
+ Dump(*REP);
+ close(REP);
+
+ # read in the report template once so that
+ # we can track whether the user does any editing.
+ # yes, *all* whitespace is ignored.
+ open(REP, "<$filename");
+ while (<REP>) {
+ s/\s+//g;
+ $REP{$_}++;
+ }
+ close(REP);
+} # sub Query
+
+sub Dump {
+ local(*OUT) = @_;
+
+ print REP "\n---\n";
+ print REP "This perlbug was built using Perl $config_tag1\n",
+ "It is being executed now by Perl $config_tag2.\n\n"
+ if $config_tag2 ne $config_tag1;
+
+ print OUT <<EOF;
+Site configuration information for perl $]:
+
+EOF
+ if ($::Config{cf_by} and $::Config{cf_time}) {
+ print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n";
+ }
+ print OUT Config::myconfig;
+
+ if (@patches) {
+ print OUT join "\n ", "Locally applied patches:", @patches;
+ print OUT "\n";
+ };
+
+ print OUT <<EOF;
+
+---
+\@INC for perl $]:
+EOF
+ for my $i (@INC) {
+ print OUT " $i\n";
+ }
+
+ print OUT <<EOF;
+
+---
+Environment for perl $]:
+EOF
+ for my $env (sort
+ (qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR),
+ grep /^(?:PERL|LC_)/, keys %ENV)
+ ) {
+ print OUT " $env",
+ exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)',
+ "\n";
+ }
+ if ($verbose) {
+ print OUT "\nComplete configuration data for perl $]:\n\n";
+ my $value;
+ foreach (sort keys %::Config) {
+ $value = $::Config{$_};
+ $value =~ s/'/\\'/g;
+ print OUT "$_='$value'\n";
+ }
+ }
+} # sub Dump
+
+sub Edit {
+ # Edit the report
+ if ($usefile || $body) {
+ paraprint <<EOF;
+Please make sure that the name of the editor you want to use is correct.
+EOF
+ print "Editor [$ed]: ";
+ my $entry =scalar <>;
+ chop $entry;
+ $ed = $entry unless $entry eq '';
+ }
+
+tryagain:
+ my $sts = system("$ed $filename");
+ if ($sts) {
+ paraprint <<EOF;
+The editor you chose (`$ed') could apparently not be run!
+Did you mistype the name of your editor? If so, please
+correct it here, otherwise just press Enter.
+EOF
+ print "Editor [$ed]: ";
+ my $entry =scalar <>;
+ chop $entry;
+
+ if ($entry ne "") {
+ $ed = $entry;
+ goto tryagain;
+ } else {
+ paraprint <<EOF;
+You may want to save your report to a file, so you can edit and mail it
+yourself.
+EOF
+ }
+ }
+
+ return if ($ok and not $::opt_n) || $body;
+ # Check that we have a report that has some, eh, report in it.
+ my $unseen = 0;
+
+ open(REP, "<$filename");
+ # a strange way to check whether any significant editing
+ # have been done: check whether any new non-empty lines
+ # have been added. Yes, the below code ignores *any* space
+ # in *any* line.
+ while (<REP>) {
+ s/\s+//g;
+ $unseen++ if $_ ne '' and not exists $REP{$_};
+ }
+
+ while ($unseen == 0) {
+ paraprint <<EOF;
+I am sorry but it looks like you did not report anything.
+EOF
+ print "Action (Retry Edit/Cancel) ";
+ my ($action) = scalar(<>);
+ if ($action =~ /^[re]/i) { # <R>etry <E>dit
+ goto tryagain;
+ } elsif ($action =~ /^[cq]/i) { # <C>ancel, <Q>uit
+ Cancel();
+ }
+ }
+} # sub Edit
+
+sub Cancel {
+ 1 while unlink($filename); # remove all versions under VMS
+ print "\nCancelling.\n";
+ exit(0);
+}
+
+sub NowWhat {
+ # Report is done, prompt for further action
+ if( !$::opt_S ) {
+ while(1) {
+ paraprint <<EOF;
+Now that you have completed your report, would you like to send
+the message to $address$andcc, display the message on
+the screen, re-edit it, or cancel without sending anything?
+You may also save the message as a file to mail at another time.
+EOF
+ retry:
+ print "Action (Send/Display/Edit/Cancel/Save to File): ";
+ my $action = scalar <>;
+ chop $action;
+
+ if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
+ print "\n\nName of file to save message in [perlbug.rep]: ";
+ my $file = scalar <>;
+ chop $file;
+ $file = "perlbug.rep" if $file eq "";
+
+ unless (open(FILE, ">$file")) {
+ print "\nError opening $file: $!\n\n";
+ goto retry;
+ }
+ open(REP, "<$filename");
+ print FILE "To: $address\nSubject: $subject\n";
+ print FILE "Cc: $cc\n" if $cc;
+ print FILE "Reply-To: $from\n" if $from;
+ print FILE "\n";
+ while (<REP>) { print FILE }
+ close(REP);
+ close(FILE);
+
+ print "\nMessage saved in `$file'.\n";
+ exit;
+ } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
+ # Display the message
+ open(REP, "<$filename");
+ while (<REP>) { print $_ }
+ close(REP);
+ } elsif ($action =~ /^se/i) { # <S>end
+ # Send the message
+ print "Are you certain you want to send this message?\n"
+ . 'Please type "yes" if you are: ';
+ my $reply = scalar <STDIN>;
+ chop $reply;
+ if ($reply eq "yes") {
+ last;
+ } else {
+ paraprint <<EOF;
+That wasn't a clear "yes", so I won't send your message. If you are sure
+your message should be sent, type in "yes" (without the quotes) at the
+confirmation prompt.
+EOF
+ }
+ } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit
+ # edit the message
+ Edit();
+ } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit
+ Cancel();
+ } elsif ($action =~ /^s/) {
+ paraprint <<EOF;
+I'm sorry, but I didn't understand that. Please type "send" or "save".
+EOF
+ }
+ }
+ }
+} # sub NowWhat
+
+sub Send {
+ # Message has been accepted for transmission -- Send the message
+ if ($outfile) {
+ open SENDMAIL, ">$outfile" or die "Couldn't open '$outfile': $!\n";
+ goto sendout;
+ }
+ if ($::HaveSend) {
+ $msg = new Mail::Send Subject => $subject, To => $address;
+ $msg->cc($cc) if $cc;
+ $msg->add("Reply-To",$from) if $from;
+
+ $fh = $msg->open;
+ open(REP, "<$filename");
+ while (<REP>) { print $fh $_ }
+ close(REP);
+ $fh->close;
+
+ print "\nMessage sent.\n";
+ } elsif ($Is_VMS) {
+ if ( ($address =~ /@/ and $address !~ /^\w+%"/) or
+ ($cc =~ /@/ and $cc !~ /^\w+%"/) ) {
+ my $prefix;
+ foreach (qw[ IN MX SMTP UCX PONY WINS ], '') {
+ $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"};
+ }
+ $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/;
+ $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/;
+ }
+ $subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g;
+ my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]);
+ if ($sts) {
+ die <<EOF;
+Can't spawn off mail
+ (leaving bug report in $filename): $sts
+EOF
+ }
+ } else {
+ my $sendmail = "";
+ for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) {
+ $sendmail = $_, last if -e $_;
+ }
+ if ($^O eq 'os2' and $sendmail eq "") {
+ my $path = $ENV{PATH};
+ $path =~ s:\\:/: ;
+ my @path = split /$Config{'path_sep'}/, $path;
+ for (@path) {
+ $sendmail = "$_/sendmail", last if -e "$_/sendmail";
+ $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe";
+ }
+ }
+
+ paraprint(<<"EOF"), die "\n" if $sendmail eq "";
+I am terribly sorry, but I cannot find sendmail, or a close equivalent, and
+the perl package Mail::Send has not been installed, so I can't send your bug
+report. We apologize for the inconvenience.
+
+So you may attempt to find some way of sending your message, it has
+been left in the file `$filename'.
+EOF
+ open(SENDMAIL, "|$sendmail -t") || die "'|$sendmail -t' failed: $!";
+sendout:
+ print SENDMAIL "To: $address\n";
+ print SENDMAIL "Subject: $subject\n";
+ print SENDMAIL "Cc: $cc\n" if $cc;
+ print SENDMAIL "Reply-To: $from\n" if $from;
+ print SENDMAIL "\n\n";
+ open(REP, "<$filename");
+ while (<REP>) { print SENDMAIL $_ }
+ close(REP);
+
+ if (close(SENDMAIL)) {
+ printf "\nMessage %s.\n", $outfile ? "saved" : "sent";
+ } else {
+ warn "\nSendmail returned status '", $? >> 8, "'\n";
+ }
+ }
+ 1 while unlink($filename); # remove all versions under VMS
+} # sub Send
+
+sub Help {
+ print <<EOF;
+
+A program to help generate bug reports about perl5, and mail them.
+It is designed to be used interactively. Normally no arguments will
+be needed.
+
+Usage:
+$0 [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ]
+ [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
+$0 [-v] [-r returnaddress] [-ok | -okay | -nok | -nokay]
+
+Simplest usage: run "$0", and follow the prompts.
+
+Options:
+
+ -v Include Verbose configuration data in the report
+ -f File containing the body of the report. Use this to
+ quickly send a prepared message.
+ -F File to output the resulting mail message to, instead of mailing.
+ -S Send without asking for confirmation.
+ -a Address to send the report to. Defaults to `$address'.
+ -c Address to send copy of report to. Defaults to `$cc'.
+ -C Don't send copy to administrator.
+ -s Subject to include with the message. You will be prompted
+ if you don't supply one on the command line.
+ -b Body of the report. If not included on the command line, or
+ in a file with -f, you will get a chance to edit the message.
+ -r Your return address. The program will ask you to confirm
+ this if you don't give it here.
+ -e Editor to use.
+ -t Test mode. The target address defaults to `$testaddress'.
+ -d Data mode (the default if you redirect or pipe output.)
+ This prints out your configuration data, without mailing
+ anything. You can use this with -v to get more complete data.
+ -ok Report successful build on this system to perl porters
+ (use alone or with -v). Only use -ok if *everything* was ok:
+ if there were *any* problems at all, use -nok.
+ -okay As -ok but allow report from old builds.
+ -nok Report unsuccessful build on this system to perl porters
+ (use alone or with -v). You must describe what went wrong
+ in the body of the report which you will be asked to edit.
+ -nokay As -nok but allow report from old builds.
+ -h Print this help message.
+
+EOF
+}
+
+sub filename {
+ my $dir = $Is_VMS ? 'sys$scratch:'
+ : ($Is_MSWin32 && $ENV{'TEMP'}) ? $ENV{'TEMP'}
+ : '/tmp/';
+ $filename = "bugrep0$$";
+ $dir .= "\\" if $Is_MSWin32 and $dir !~ m|[\\/]$|;
+ $filename++ while -e "$dir$filename";
+ $filename = "$dir$filename";
+}
+
+sub paraprint {
+ my @paragraphs = split /\n{2,}/, "@_";
+ print "\n\n";
+ for (@paragraphs) { # implicit local $_
+ s/(\S)\s*\n/$1 /g;
+ write;
+ print "\n";
+ }
+}
+
+format STDOUT =
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
+$_
+.
+
+__END__
+
+=head1 NAME
+
+perlbug - how to submit bug reports on Perl
+
+=head1 SYNOPSIS
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]>
+S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]>
+S<[ B<-r> I<returnaddress> ]>
+S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]>
+S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-h> ]>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
+S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
+
+=head1 DESCRIPTION
+
+A program to help generate bug reports about perl or the modules that
+come with it, and mail them.
+
+If you have found a bug with a non-standard port (one that was not part
+of the I<standard distribution>), a binary distribution, or a
+non-standard module (such as Tk, CGI, etc), then please see the
+documentation that came with that distribution to determine the correct
+place to report bugs.
+
+C<perlbug> is designed to be used interactively. Normally no arguments
+will be needed. Simply run it, and follow the prompts.
+
+If you are unable to run B<perlbug> (most likely because you don't have
+a working setup to send mail that perlbug recognizes), you may have to
+compose your own report, and email it to B<perlbug@perl.com>. You might
+find the B<-d> option useful to get summary information in that case.
+
+In any case, when reporting a bug, please make sure you have run through
+this checklist:
+
+=over 4
+
+=item What version of perl you are running?
+
+Type C<perl -v> at the command line to find out.
+
+=item Are you running the latest released version of perl?
+
+Look at http://www.perl.com/ to find out. If it is not the latest
+released version, get that one and see whether your bug has been
+fixed. Note that bug reports about old versions of perl, especially
+those prior to the 5.0 release, are likely to fall upon deaf ears.
+You are on your own if you continue to use perl1 .. perl4.
+
+=item Are you sure what you have is a bug?
+
+A significant number of the bug reports we get turn out to be documented
+features in perl. Make sure the behavior you are witnessing doesn't fall
+under that category, by glancing through the documentation that comes
+with perl (we'll admit this is no mean task, given the sheer volume of
+it all, but at least have a look at the sections that I<seem> relevant).
+
+Be aware of the familiar traps that perl programmers of various hues
+fall into. See L<perltrap>.
+
+Try to study the problem under the perl debugger, if necessary.
+See L<perldebug>.
+
+=item Do you have a proper test case?
+
+The easier it is to reproduce your bug, the more likely it will be
+fixed, because if no one can duplicate the problem, no one can fix it.
+A good test case has most of these attributes: fewest possible number
+of lines; few dependencies on external commands, modules, or
+libraries; runs on most platforms unimpeded; and is self-documenting.
+
+A good test case is almost always a good candidate to be on the perl
+test suite. If you have the time, consider making your test case so
+that it will readily fit into the standard test suite.
+
+=item Can you describe the bug in plain English?
+
+The easier it is to understand a reproducible bug, the more likely it
+will be fixed. Anything you can provide by way of insight into the
+problem helps a great deal. In other words, try to analyse the
+problem to the extent you feel qualified and report your discoveries.
+
+=item Can you fix the bug yourself?
+
+A bug report which I<includes a patch to fix it> will almost
+definitely be fixed. Use the C<diff> program to generate your patches
+(C<diff> is being maintained by the GNU folks as part of the B<diffutils>
+package, so you should be able to get it from any of the GNU software
+repositories). If you do submit a patch, the cool-dude counter at
+perlbug@perl.com will register you as a savior of the world. Your
+patch may be returned with requests for changes, or requests for more
+detailed explanations about your fix.
+
+Here are some clues for creating quality patches: Use the B<-c> or
+B<-u> switches to the diff program (to create a so-called context or
+unified diff). Make sure the patch is not reversed (the first
+argument to diff is typically the original file, the second argument
+your changed file). Make sure you test your patch by applying it with
+the C<patch> program before you send it on its way. Try to follow the
+same style as the code you are trying to patch. Make sure your patch
+really does work (C<make test>, if the thing you're patching supports
+it).
+
+=item Can you use C<perlbug> to submit the report?
+
+B<perlbug> will, amongst other things, ensure your report includes
+crucial information about your version of perl. If C<perlbug> is unable
+to mail your report after you have typed it in, you may have to compose
+the message yourself, add the output produced by C<perlbug -d> and email
+it to B<perlbug@perl.com>. If, for some reason, you cannot run
+C<perlbug> at all on your system, be sure to include the entire output
+produced by running C<perl -V> (note the uppercase V).
+
+=back
+
+Having done your bit, please be prepared to wait, to be told the bug
+is in your code, or even to get no reply at all. The perl maintainers
+are busy folks, so if your problem is a small one or if it is difficult
+to understand or already known, they may not respond with a personal reply.
+If it is important to you that your bug be fixed, do monitor the
+C<Changes> file in any development releases since the time you submitted
+the bug, and encourage the maintainers with kind words (but never any
+flames!). Feel free to resend your bug report if the next released
+version of perl comes out and your bug is still present.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-a>
+
+Address to send the report to. Defaults to `perlbug@perl.com'.
+
+=item B<-b>
+
+Body of the report. If not included on the command line, or
+in a file with B<-f>, you will get a chance to edit the message.
+
+=item B<-C>
+
+Don't send copy to administrator.
+
+=item B<-c>
+
+Address to send copy of report to. Defaults to the address of the
+local perl administrator (recorded when perl was built).
+
+=item B<-d>
+
+Data mode (the default if you redirect or pipe output). This prints out
+your configuration data, without mailing anything. You can use this
+with B<-v> to get more complete data.
+
+=item B<-e>
+
+Editor to use.
+
+=item B<-f>
+
+File containing the body of the report. Use this to quickly send a
+prepared message.
+
+=item B<-F>
+
+File to output the results to instead of sending as an email. Useful
+particularly when running perlbug on a machine with no direct internet
+connection.
+
+=item B<-h>
+
+Prints a brief summary of the options.
+
+=item B<-ok>
+
+Report successful build on this system to perl porters. Forces B<-S>
+and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only
+prompts for a return address if it cannot guess it (for use with
+B<make>). Honors return address specified with B<-r>. You can use this
+with B<-v> to get more complete data. Only makes a report if this
+system is less than 60 days old.
+
+=item B<-okay>
+
+As B<-ok> except it will report on older systems.
+
+=item B<-nok>
+
+Report unsuccessful build on this system. Forces B<-C>. Forces and
+supplies a value for B<-s>, then requires you to edit the report
+and say what went wrong. Alternatively, a prepared report may be
+supplied using B<-f>. Only prompts for a return address if it
+cannot guess it (for use with B<make>). Honors return address
+specified with B<-r>. You can use this with B<-v> to get more
+complete data. Only makes a report if this system is less than 60
+days old.
+
+=item B<-nokay>
+
+As B<-nok> except it will report on older systems.
+
+=item B<-r>
+
+Your return address. The program will ask you to confirm its default
+if you don't use this option.
+
+=item B<-S>
+
+Send without asking for confirmation.
+
+=item B<-s>
+
+Subject to include with the message. You will be prompted if you don't
+supply one on the command line.
+
+=item B<-t>
+
+Test mode. The target address defaults to `perlbug-test@perl.com'.
+
+=item B<-v>
+
+Include verbose configuration data in the report.
+
+=back
+
+=head1 AUTHORS
+
+Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently I<doc>tored
+by Gurusamy Sarathy (E<lt>gsar@umich.eduE<gt>), Tom Christiansen
+(E<lt>tchrist@perl.comE<gt>), Nathan Torkington (E<lt>gnat@frii.comE<gt>),
+Charles F. Randall (E<lt>cfr@pobox.comE<gt>), Mike Guy
+(E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop (E<lt>domo@computer.orgE<gt>)
+and Hugo van der Sanden (E<lt>hv@crypt0.demon.co.ukE<gt>).
+
+=head1 SEE ALSO
+
+perl(1), perldebug(1), perltrap(1), diff(1), patch(1)
+
+=head1 BUGS
+
+None known (guess what must have been used to report them?)
+
+=cut
+
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
+
diff --git a/contrib/perl5/utils/perlcc.PL b/contrib/perl5/utils/perlcc.PL
new file mode 100644
index 000000000000..b214645ad990
--- /dev/null
+++ b/contrib/perl5/utils/perlcc.PL
@@ -0,0 +1,945 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+# Wanted: $archlibexp
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+use Config;
+use strict;
+use FileHandle;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+use Getopt::Long;
+
+$Getopt::Long::bundling_override = 1;
+$Getopt::Long::passthrough = 0;
+$Getopt::Long::ignore_case = 0;
+
+my $options = {};
+my $_fh;
+
+main();
+
+sub main
+{
+
+ GetOptions
+ (
+ $options, "L:s",
+ "I:s",
+ "C:s",
+ "o:s",
+ "e:s",
+ "regex:s",
+ "verbose:s",
+ "log:s",
+ "argv:s",
+ "gen",
+ "sav",
+ "run",
+ "prog",
+ "mod"
+ );
+
+
+ my $key;
+
+ local($") = "|";
+
+ _usage() if (!_checkopts());
+ push(@ARGV, _maketempfile()) if ($options->{'e'});
+
+ _usage() if (!@ARGV);
+
+ my $file;
+ foreach $file (@ARGV)
+ {
+ _print("
+--------------------------------------------------------------------------------
+Compiling $file:
+--------------------------------------------------------------------------------
+", 36 );
+ _doit($file);
+ }
+}
+
+sub _doit
+{
+ my ($file) = @_;
+
+ my ($program_ext, $module_ext) = _getRegexps();
+ my ($obj, $objfile, $so, $type);
+
+ if (
+ (($file =~ m"@$program_ext") && ($file !~ m"@$module_ext"))
+ || (defined($options->{'prog'}) || defined($options->{'run'}))
+ )
+ {
+ $objfile = ($options->{'C'}) ? $options->{'C'} : "$file.c";
+ $type = 'program';
+
+ $obj = ($options->{'o'})? $options->{'o'} :
+ _getExecutable( $file,$program_ext);
+
+ return() if (!$obj);
+
+ }
+ elsif (($file =~ m"@$module_ext") || ($options->{'mod'}))
+ {
+ die "Shared objects are not supported on Win32 yet!!!!\n"
+ if ($Config{'osname'} eq 'MSWin32');
+
+ $obj = ($options->{'o'})? $options->{'o'} :
+ _getExecutable($file, $module_ext);
+ $so = "$obj.$Config{so}";
+ $type = 'sharedlib';
+ return() if (!$obj);
+ $objfile = ($options->{'C'}) ? $options->{'C'} : "$file.c";
+ }
+ else
+ {
+ _error("noextension", $file, $program_ext, $module_ext);
+ return();
+ }
+
+ if ($type eq 'program')
+ {
+ _print("Making C($objfile) for $file!\n", 36 );
+
+ my $errcode = _createCode($objfile, $file);
+ (_print( "ERROR: In generating code for $file!\n", -1), return())
+ if ($errcode);
+
+ _print("Compiling C($obj) for $file!\n", 36 ) if (!$options->{'gen'});
+ $errcode = _compileCode($file, $objfile, $obj)
+ if (!$options->{'gen'});
+
+ if ($errcode)
+ {
+ _print( "ERROR: In compiling code for $objfile !\n", -1);
+ my $ofile = File::Basename::basename($objfile);
+ $ofile =~ s"\.c$"\.o"s;
+
+ _removeCode("$ofile");
+ return()
+ }
+
+ _runCode($obj) if ($options->{'run'});
+
+ _removeCode($objfile) if (!$options->{'sav'} ||
+ ($options->{'e'} && !$options->{'C'}));
+
+ _removeCode($file) if ($options->{'e'});
+
+ _removeCode($obj) if (($options->{'e'}
+ && !$options->{'sav'}
+ && !$options->{'o'})
+ || ($options->{'run'} && !$options->{'sav'}));
+ }
+ else
+ {
+ _print( "Making C($objfile) for $file!\n", 36 );
+ my $errcode = _createCode($objfile, $file, $obj);
+ (_print( "ERROR: In generating code for $file!\n", -1), return())
+ if ($errcode);
+
+ _print( "Compiling C($so) for $file!\n", 36 ) if (!$options->{'gen'});
+
+ my $errorcode =
+ _compileCode($file, $objfile, $obj, $so ) if (!$options->{'gen'});
+
+ (_print( "ERROR: In compiling code for $objfile!\n", -1), return())
+ if ($errcode);
+ }
+}
+
+sub _getExecutable
+{
+ my ($sourceprog, $ext) = @_;
+ my ($obj);
+
+ if (defined($options->{'regex'}))
+ {
+ eval("(\$obj = \$sourceprog) =~ $options->{'regex'}");
+ return(0) if (_error('badeval', $@));
+ return(0) if (_error('equal', $obj, $sourceprog));
+ }
+ elsif (defined ($options->{'ext'}))
+ {
+ ($obj = $sourceprog) =~ s"@$ext"$options->{ext}"g;
+ return(0) if (_error('equal', $obj, $sourceprog));
+ }
+ elsif (defined ($options->{'run'}))
+ {
+ $obj = "perlc$$";
+ }
+ else
+ {
+ ($obj = $sourceprog) =~ s"@$ext""g;
+ return(0) if (_error('equal', $obj, $sourceprog));
+ }
+ return($obj);
+}
+
+sub _createCode
+{
+ my ( $generated_cfile, $file, $final_output ) = @_;
+ my $return;
+
+ local($") = " -I";
+
+ if (@_ == 2) # compiling a program
+ {
+ _print( "$^X -I@INC -MO=CC,-o$generated_cfile $file\n", 36);
+ $return = _run("$ -I@INC -MO=CC,-o$generated_cfile $file", 9);
+ $return;
+ }
+ else # compiling a shared object
+ {
+ _print(
+ "$ -I@INC -MO=CC,-m$final_output,-o$generated_cfile $file\n", 36);
+ $return =
+ _run("$ -I@INC -MO=CC,-m$final_output,-o$generated_cfile $file", 9);
+ $return;
+ }
+}
+
+sub _compileCode
+{
+ my ($sourceprog, $generated_cfile, $output_executable, $shared_object) = @_;
+ my @return;
+
+ if (@_ == 3) # just compiling a program
+ {
+ $return[0] =
+ _ccharness('static', $sourceprog, "-o", $output_executable, $generated_cfile);
+ $return[0];
+ }
+ else
+ {
+ my $object_file = $generated_cfile;
+ $object_file =~ s"\.c$"$Config{_o}";
+
+ $return[0] = _ccharness('compile', $sourceprog, "-c", $generated_cfile);
+ $return[1] = _ccharness
+ (
+ 'dynamic',
+ $sourceprog, "-o",
+ $shared_object, $object_file
+ );
+ return(1) if (grep ($_, @return));
+ return(0);
+ }
+}
+
+sub _runCode
+{
+ my ($executable) = @_;
+ _print("$executable $options->{'argv'}\n", 36);
+ _run("$executable $options->{'argv'}", -1 );
+}
+
+sub _removeCode
+{
+ my ($file) = @_;
+ unlink($file) if (-e $file);
+}
+
+sub _ccharness
+{
+ my $type = shift;
+ my (@args) = @_;
+ local($") = " ";
+
+ my $sourceprog = shift(@args);
+ my ($libdir, $incdir);
+
+ if (-d "$Config{installarchlib}/CORE")
+ {
+ $libdir = "-L$Config{installarchlib}/CORE";
+ $incdir = "-I$Config{installarchlib}/CORE";
+ }
+ else
+ {
+ $libdir = "-L.. -L.";
+ $incdir = "-I.. -I.";
+ }
+
+ $libdir .= " -L$options->{L}" if (defined($options->{L}));
+ $incdir .= " -I$options->{L}" if (defined($options->{L}));
+
+ my $linkargs = '';
+
+ if (!grep(/^-[cS]$/, @args))
+ {
+ my $lperl = $^O eq 'os2' ? '-llibperl' : '-lperl';
+ my $flags = $type eq 'dynamic' ? $Config{lddlflags} : $Config{ldflags};
+ $linkargs = "$flags $libdir $lperl @Config{libs}";
+ }
+
+ my @sharedobjects = _getSharedObjects($sourceprog);
+
+ my $cccmd =
+ "$Config{cc} @Config{qw(ccflags optimize)} $incdir @sharedobjects @args $linkargs";
+
+
+ _print ("$cccmd\n", 36);
+ _run("$cccmd", 18 );
+}
+
+sub _getSharedObjects
+{
+ my ($sourceprog) = @_;
+ my ($tmpfile, $incfile);
+ my (@return);
+ local($") = " -I";
+
+ if ($Config{'osname'} eq 'MSWin32')
+ {
+ # _addstuff;
+ }
+ else
+ {
+ my ($tmpprog);
+ ($tmpprog = $sourceprog) =~ s"(.*)[\/\\](.*)"$2";
+ $tmpfile = "/tmp/$tmpprog.tst";
+ $incfile = "/tmp/$tmpprog.val";
+ }
+
+ my $fd = new FileHandle("> $tmpfile") || die "Couldn't open $tmpfile!\n";
+ my $fd2 =
+ new FileHandle("$sourceprog") || die "Couldn't open $sourceprog!\n";
+
+ my $perl = <$fd2>; # strip off header;
+
+ print $fd
+<<"EOF";
+ use FileHandle;
+ my \$fh3 = new FileHandle("> $incfile")
+ || die "Couldn't open $incfile\\n";
+
+ my \$key;
+ foreach \$key (keys(\%INC)) { print \$fh3 "\$key:\$INC{\$key}\\n"; }
+ close(\$fh3);
+ exit();
+EOF
+
+ print $fd ( <$fd2> );
+ close($fd);
+
+ _print("$ -I@INC $tmpfile\n", 36);
+ _run("$ -I@INC $tmpfile", 9 );
+
+ $fd = new FileHandle ("$incfile");
+ my @lines = <$fd>;
+
+ unlink($tmpfile);
+ unlink($incfile);
+
+ my $line;
+ my $autolib;
+
+ foreach $line (@lines)
+ {
+ chomp($line);
+ my ($modname, $modpath) = split(':', $line);
+ my ($dir, $file) = ($modpath=~ m"(.*)[\\/]($modname)");
+
+ if ($autolib = _lookforAuto($dir, $file))
+ {
+ push(@return, $autolib);
+ }
+ }
+
+ return(@return);
+}
+
+sub _maketempfile
+{
+ my $return;
+
+# if ($Config{'osname'} eq 'MSWin32')
+# { $return = "C:\\TEMP\\comp$$.p"; }
+# else
+# { $return = "/tmp/comp$$.p"; }
+
+ $return = "comp$$.p";
+
+ my $fd = new FileHandle( "> $return") || die "Couldn't open $return!\n";
+ print $fd $options->{'e'};
+ close($fd);
+
+ return($return);
+}
+
+
+sub _lookforAuto
+{
+ my ($dir, $file) = @_;
+
+ my $relshared;
+ my $return;
+
+ ($relshared = $file) =~ s"(.*)\.pm"$1";
+
+ my ($tmp, $modname) = ($relshared =~ m"(?:(.*)[\\/]){0,1}(.*)"s);
+
+ $relshared .=
+ ($Config{'osname'} eq 'MSWin32')? "\\$modname.dll" : "/$modname.so";
+
+
+
+ if (-e ($return = "$Config{'installarchlib'}/auto/$relshared") )
+ {
+ return($return);
+ }
+ elsif (-e ($return = "$Config{'installsitearch'}/auto/$relshared"))
+ {
+ return($return);
+ }
+ elsif (-e ($return = "$dir/arch/auto/$relshared"))
+ {
+ return($return);
+ }
+ else
+ {
+ return(undef);
+ }
+}
+
+sub _getRegexps # make the appropriate regexps for making executables,
+{ # shared libs
+
+ my ($program_ext, $module_ext) = ([],[]);
+
+
+ @$program_ext = ($ENV{PERL_SCRIPT_EXT})? split(':', $ENV{PERL_SCRIPT_EXT}) :
+ ('.p$', '.pl$', '.bat$');
+
+
+ @$module_ext = ($ENV{PERL_MODULE_EXT})? split(':', $ENV{PERL_MODULE_EXT}) :
+ ('.pm$');
+
+
+ _mungeRegexp( $program_ext );
+ _mungeRegexp( $module_ext );
+
+ return($program_ext, $module_ext);
+}
+
+sub _mungeRegexp
+{
+ my ($regexp) = @_;
+
+ grep(s:(^|[^\\])\.:$1\x00\\.:g, @$regexp);
+ grep(s:(^|[^\x00])\\\.:$1\.:g, @$regexp);
+ grep(s:\x00::g, @$regexp);
+}
+
+
+sub _error
+{
+ my ($type, @args) = @_;
+
+ if ($type eq 'equal')
+ {
+
+ if ($args[0] eq $args[1])
+ {
+ _print ("ERROR: The object file '$args[0]' does not generate a legitimate executable file! Skipping!\n", -1);
+ return(1);
+ }
+ }
+ elsif ($type eq 'badeval')
+ {
+ if ($args[0])
+ {
+ _print ("ERROR: $args[0]\n", -1);
+ return(1);
+ }
+ }
+ elsif ($type eq 'noextension')
+ {
+ my $progext = join(',', @{$args[1]});
+ my $modext = join(',', @{$args[2]});
+
+ $progext =~ s"\\""g;
+ $modext =~ s"\\""g;
+
+ $progext =~ s"\$""g;
+ $modext =~ s"\$""g;
+
+ _print
+ (
+"
+ERROR: '$args[0]' does not have a proper extension! Proper extensions are:
+
+ PROGRAM: $progext
+ SHARED OBJECT: $modext
+
+Use the '-prog' flag to force your files to be interpreted as programs.
+Use the '-mod' flag to force your files to be interpreted as modules.
+", -1
+ );
+ return(1);
+ }
+
+ return(0);
+}
+
+sub _checkopts
+{
+ my @errors;
+ local($") = "\n";
+
+ if ($options->{'log'})
+ {
+ $_fh = new FileHandle(">> $options->{'log'}") || push(@errors, "ERROR: Couldn't open $options->{'log'}\n");
+ }
+
+ if (($options->{'c'}) && (@ARGV > 1) && ($options->{'sav'} ))
+ {
+ push(@errors,
+"ERROR: The '-sav' and '-C' options are incompatible when you have more than
+ one input file! ('-C' explicitly names resulting C code, '-sav' saves it,
+ and hence, with more than one file, the c code will be overwritten for
+ each file that you compile)\n");
+ }
+ if (($options->{'o'}) && (@ARGV > 1))
+ {
+ push(@errors,
+"ERROR: The '-o' option is incompatible when you have more than one input file!
+ (-o explicitly names the resulting executable, hence, with more than
+ one file the names clash)\n");
+ }
+
+ if ($options->{'e'} && $options->{'sav'} && !$options->{'o'} &&
+ !$options->{'C'})
+ {
+ push(@errors,
+"ERROR: You need to specify where you are going to save the resulting
+ executable or C code, when using '-sav' and '-e'. Use '-o' or '-C'.\n");
+ }
+
+ if (($options->{'regex'} || $options->{'run'} || $options->{'o'})
+ && $options->{'gen'})
+ {
+ push(@errors,
+"ERROR: The options '-regex', '-run', and '-o' are incompatible with '-gen'.
+ '-gen' says to stop at C generation, and the other three modify the
+ compilation and/or running process!\n");
+ }
+
+ if ($options->{'run'} && $options->{'mod'})
+ {
+ push(@errors,
+"ERROR: Can't run modules that you are compiling! '-run' and '-mod' are
+ incompatible!\n");
+ }
+
+ if ($options->{'e'} && @ARGV)
+ {
+ push (@errors,
+"ERROR: The option '-e' needs to be all by itself without any other
+ file arguments!\n");
+ }
+ if ($options->{'e'} && !($options->{'o'} || $options->{'run'}))
+ {
+ $options->{'run'} = 1;
+ }
+
+ if (!defined($options->{'verbose'}))
+ {
+ $options->{'verbose'} = ($options->{'log'})? 64 : 7;
+ }
+
+ my $verbose_error;
+
+ if ($options->{'verbose'} =~ m"[^tagfcd]" &&
+ !( $options->{'verbose'} eq '0' ||
+ ($options->{'verbose'} < 64 && $options->{'verbose'} > 0)))
+ {
+ $verbose_error = 1;
+ push(@errors,
+"ERROR: Illegal verbosity level. Needs to have either the letters
+ 't','a','g','f','c', or 'd' in it or be between 0 and 63, inclusive.\n");
+ }
+
+ $options->{'verbose'} = ($options->{'verbose'} =~ m"[tagfcd]")?
+ ($options->{'verbose'} =~ m"d") * 32 +
+ ($options->{'verbose'} =~ m"c") * 16 +
+ ($options->{'verbose'} =~ m"f") * 8 +
+ ($options->{'verbose'} =~ m"t") * 4 +
+ ($options->{'verbose'} =~ m"a") * 2 +
+ ($options->{'verbose'} =~ m"g") * 1
+ : $options->{'verbose'};
+
+ if (!$verbose_error && ( $options->{'log'} &&
+ !(
+ ($options->{'verbose'} & 8) ||
+ ($options->{'verbose'} & 16) ||
+ ($options->{'verbose'} & 32 )
+ )
+ )
+ )
+ {
+ push(@errors,
+"ERROR: The verbosity level '$options->{'verbose'}' does not output anything
+ to a logfile, and you specified '-log'!\n");
+ } # }
+
+ if (!$verbose_error && ( !$options->{'log'} &&
+ (
+ ($options->{'verbose'} & 8) ||
+ ($options->{'verbose'} & 16) ||
+ ($options->{'verbose'} & 32) ||
+ ($options->{'verbose'} & 64)
+ )
+ )
+ )
+ {
+ push(@errors,
+"ERROR: The verbosity level '$options->{'verbose'}' requires that you also
+ specify a logfile via '-log'\n");
+ } # }
+
+
+ (_print( "\n". join("\n", @errors), -1), return(0)) if (@errors);
+ return(1);
+}
+
+sub _print
+{
+ my ($text, $flag ) = @_;
+
+ my $logflag = int($flag/8) * 8;
+ my $regflag = $flag % 8;
+
+ if ($flag == -1 || ($flag & $options->{'verbose'}))
+ {
+ my $dolog = ((($logflag & $options->{'verbose'}) || $flag == -1)
+ && $options->{'log'});
+
+ my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1);
+
+ if ($doreg) { print( STDERR $text ); }
+ if ($dolog) { print $_fh $text; }
+ }
+}
+
+sub _run
+{
+ my ($command, $flag) = @_;
+
+ my $logflag = ($flag != -1)? int($flag/8) * 8 : 0;
+ my $regflag = $flag % 8;
+
+ if ($flag == -1 || ($flag & $options->{'verbose'}))
+ {
+ my $dolog = ($logflag & $options->{'verbose'} && $options->{'log'});
+ my $doreg = (($regflag & $options->{'verbose'}) || $flag == -1);
+
+ if ($doreg && !$dolog)
+ { system("$command"); }
+
+ elsif ($doreg && $dolog)
+ { my $text = `$command 2>&1`; print $_fh $text; print STDERR $text;}
+ else
+ { my $text = `$command 2>&1`; print $_fh $text; }
+ }
+ else
+ {
+ `$command 2>&1`;
+ }
+ return($?);
+}
+
+sub _usage
+{
+ _print
+ (
+ <<"EOF"
+
+Usage: $0 <file_list>
+
+ Flags with arguments
+ -L < extra library dirs for installation (form of 'dir1:dir2') >
+ -I < extra include dirs for installation (form of 'dir1:dir2') >
+ -C < explicit name of resulting C code >
+ -o < explicit name of resulting executable >
+ -e < to compile 'one liners'. Need executable name (-o) or '-run'>
+ -regex < rename regex, -regex 's/\.p/\.exe/' compiles a.p to a.exe >
+ -verbose < verbose level (1-63, or following letters 'gatfcd' >
+ -argv < arguments for the executables to be run via '-run' or '-e' >
+
+ Boolean flags
+ -gen ( to just generate the c code. Implies '-sav' )
+ -sav ( to save intermediate c code, (and executables with '-run'))
+ -run ( to run the compiled program on the fly, as were interpreted.)
+ -prog ( to indicate that the files on command line are programs )
+ -mod ( to indicate that the files on command line are modules )
+
+EOF
+, -1
+
+ );
+ exit(255);
+}
+
+
+__END__
+
+=head1 NAME
+
+perlcc - frontend for perl compiler
+
+=head1 SYNOPSIS
+
+ %prompt perlcc a.p # compiles into executable 'a'
+
+ %prompt perlcc A.pm # compile into 'A.so'
+
+ %prompt perlcc a.p -o execute # compiles 'a.p' into 'execute'.
+
+ %prompt perlcc a.p -o execute -run # compiles 'a.p' into execute, runs on
+ # the fly
+
+ %prompt perlcc a.p -o execute -run -argv 'arg1 arg2 arg3'
+ # compiles into execute, runs with
+ # arg1 arg2 arg3 as @ARGV
+
+ %prompt perlcc a.p b.p c.p -regex 's/\.p/\.exe'
+ # compiles into 'a.exe','b.exe','c.exe'.
+
+ %prompt perlcc a.p -log compilelog # compiles into 'a', saves compilation
+ # info into compilelog, as well
+ # as mirroring to screen
+
+ %prompt perlcc a.p -log compilelog -verbose cdf
+ # compiles into 'a', saves compilation
+ # info into compilelog, being silent
+ # on screen.
+
+ %prompt perlcc a.p -C a.c -gen # generates C code (into a.c) and
+ # stops without compile.
+
+ %prompt perlcc a.p -L ../lib a.c
+ # Compiles with the perl libraries
+ # inside ../lib included.
+
+=head1 DESCRIPTION
+
+'perlcc' is the frontend into the perl compiler. Typing 'perlcc a.p'
+compiles the code inside a.p into a standalone executable, and
+perlcc A.pm will compile into a shared object, A.so, suitable for inclusion
+into a perl program via "use A".
+
+There are quite a few flags to perlcc which help with such issues as compiling
+programs in bulk, testing compiled programs for compatibility with the
+interpreter, and controlling.
+
+=head1 OPTIONS
+
+=over 4
+
+=item -L < library_directories >
+
+Adds directories in B<library_directories> to the compilation command.
+
+=item -I < include_directories >
+
+Adds directories inside B<include_directories> to the compilation command.
+
+=item -C < c_code_name >
+
+Explicitly gives the name B<c_code_name> to the generated c code which is to
+be compiled. Can only be used if compiling one file on the command line.
+
+=item -o < executable_name >
+
+Explicitly gives the name B<executable_name> to the executable which is to be
+compiled. Can only be used if compiling one file on the command line.
+
+=item -e < perl_line_to_execute>
+
+Compiles 'one liners', in the same way that B<perl -e> runs text strings at
+the command line. Default is to have the 'one liner' be compiled, and run all
+in one go (see B<-run>); giving the B<-o> flag saves the resultant executable,
+rather than throwing it away. Use '-argv' to pass arguments to the executable
+created.
+
+=item -regex <rename_regex>
+
+Gives a rule B<rename_regex> - which is a legal perl regular expression - to
+create executable file names.
+
+=item -verbose <verbose_level>
+
+Show exactly what steps perlcc is taking to compile your code. You can change
+the verbosity level B<verbose_level> much in the same way that the '-D' switch
+changes perl's debugging level, by giving either a number which is the sum of
+bits you want or a list of letters representing what you wish to see. Here are
+the verbosity levels so far :
+
+ Bit 1(g): Code Generation Errors to STDERR
+ Bit 2(a): Compilation Errors to STDERR
+ Bit 4(t): Descriptive text to STDERR
+ Bit 8(f): Code Generation Errors to file (B<-log> flag needed)
+ Bit 16(c): Compilation Errors to file (B<-log> flag needed)
+ Bit 32(d): Descriptive text to file (B<-log> flag needed)
+
+If the B<-log> tag is given, the default verbose level is 63 (ie: mirroring
+all of perlcc's output to both the screen and to a log file). If no B<-log>
+tag is given, then the default verbose level is 7 (ie: outputting all of
+perlcc's output to STDERR).
+
+NOTE: Because of buffering concerns, you CANNOT shadow the output of '-run' to
+both a file, and to the screen! Suggestions are welcome on how to overcome this
+difficulty, but for now it simply does not work properly, and hence will only go
+to the screen.
+
+=item -log <logname>
+
+Opens, for append, a logfile to save some or all of the text for a given
+compile command. No rewrite version is available, so this needs to be done
+manually.
+
+=item -argv <arguments>
+
+In combination with '-run' or '-e', tells perlcc to run the resulting
+executable with the string B<arguments> as @ARGV.
+
+=item -sav
+
+Tells perl to save the intermediate C code. Usually, this C code is the name
+of the perl code, plus '.c'; 'perlcode.p' gets generated in 'perlcode.p.c',
+for example. If used with the '-e' operator, you need to tell perlcc where to
+save resulting executables.
+
+=item -gen
+
+Tells perlcc to only create the intermediate C code, and not compile the
+results. Does an implicit B<-sav>, saving the C code rather than deleting it.
+
+=item -run
+
+Immediately run the perl code that has been generated. NOTE: IF YOU GIVE THE
+B<-run> FLAG TO B<perlcc>, THEN THE REST OF @ARGV WILL BE INTERPRETED AS
+ARGUMENTS TO THE PROGRAM THAT YOU ARE COMPILING.
+
+=item -prog
+
+Indicate that the programs at the command line are programs, and should be
+compiled as such. B<perlcc> will automatically determine files to be
+programs if they have B<.p>, B<.pl>, B<.bat> extensions.
+
+=item -mod
+
+Indicate that the programs at the command line are modules, and should be
+compiled as such. B<perlcc> will automatically determine files to be
+modules if they have the extension B<.pm>.
+
+=back
+
+=head1 ENVIRONMENT
+
+Most of the work of B<perlcc> is done at the command line. However, you can
+change the heuristic which determines what is a module and what is a program.
+As indicated above, B<perlcc> assumes that the extensions:
+
+.p$, .pl$, and .bat$
+
+indicate a perl program, and:
+
+.pm$
+
+indicate a library, for the purposes of creating executables. And furthermore,
+by default, these extensions will be replaced (and dropped ) in the process of
+creating an executable.
+
+To change the extensions which are programs, and which are modules, set the
+environmental variables:
+
+PERL_SCRIPT_EXT
+PERL_MODULE_EXT
+
+These two environmental variables take colon-separated, legal perl regular
+expressions, and are used by perlcc to decide which objects are which.
+For example:
+
+setenv PERL_SCRIPT_EXT '.prl$:.perl$'
+prompt% perlcc sample.perl
+
+will compile the script 'sample.perl' into the executable 'sample', and
+
+setenv PERL_MODULE_EXT '.perlmod$:.perlmodule$'
+
+prompt% perlcc sample.perlmod
+
+will compile the module 'sample.perlmod' into the shared object
+'sample.so'
+
+NOTE: the '.' in the regular expressions for PERL_SCRIPT_EXT and PERL_MODULE_EXT
+is a literal '.', and not a wild-card. To get a true wild-card, you need to
+backslash the '.'; as in:
+
+setenv PERL_SCRIPT_EXT '\.\.\.\.\.'
+
+which would have the effect of compiling ANYTHING (except what is in
+PERL_MODULE_EXT) into an executable with 5 less characters in its name.
+
+=head1 FILES
+
+'perlcc' uses a temporary file when you use the B<-e> option to evaluate
+text and compile it. This temporary file is 'perlc$$.p'. The temporary C code is
+perlc$$.p.c, and the temporary executable is perlc$$.
+
+When you use '-run' and don't save your executable, the temporary executable is
+perlc$$
+
+=head1 BUGS
+
+perlcc currently cannot compile shared objects on Win32. This should be fixed
+by perl5.005.
+
+=cut
+
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/utils/perldoc.PL b/contrib/perl5/utils/perldoc.PL
new file mode 100644
index 000000000000..875cd25144be
--- /dev/null
+++ b/contrib/perl5/utils/perldoc.PL
@@ -0,0 +1,687 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if 0;
+
+use strict;
+my \@pagers = ();
+push \@pagers, "$Config{'pager'}" if -x "$Config{'pager'}";
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+#
+# Perldoc revision #1 -- look up a piece of documentation in .pod format that
+# is embedded in the perl installation tree.
+#
+# This is not to be confused with Tom Christianson's perlman, which is a
+# man replacement, written in perl. This perldoc is strictly for reading
+# the perl manuals, though it too is written in perl.
+
+if(@ARGV<1) {
+ my $me = $0; # Editing $0 is unportable
+ $me =~ s,.*/,,;
+ die <<EOF;
+Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-l] [-F] [-X] PageName|ModuleName|ProgramName
+ $me -f PerlFunc
+ $me -q FAQKeywords
+
+The -h option prints more help. Also try "perldoc perldoc" to get
+aquainted with the system.
+EOF
+}
+
+use Getopt::Std;
+use Config '%Config';
+
+my @global_found = ();
+my $global_target = "";
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MSWin32 = $^O eq 'MSWin32';
+my $Is_Dos = $^O eq 'dos';
+
+sub usage{
+ warn "@_\n" if @_;
+ # Erase evidence of previous errors (if any), so exit status is simple.
+ $! = 0;
+ die <<EOF;
+perldoc [options] PageName|ModuleName|ProgramName...
+perldoc [options] -f BuiltinFunction
+perldoc [options] -q FAQRegex
+
+Options:
+ -h Display this help message
+ -r Recursive search (slow)
+ -i Ignore case
+ -t Display pod using pod2text instead of pod2man and nroff
+ (-t is the default on win32)
+ -u Display unformatted pod text
+ -m Display module's file in its entirety
+ -l Display the module's file name
+ -F Arguments are file names, not modules
+ -v Verbosely describe what's going on
+ -X use index if present (looks for pod.idx at $Config{archlib})
+
+
+PageName|ModuleName...
+ is the name of a piece of documentation that you want to look at. You
+ may either give a descriptive name of the page (as in the case of
+ `perlfunc') the name of a module, either like `Term::Info',
+ `Term/Info', the partial name of a module, like `info', or
+ `makemaker', or the name of a program, like `perldoc'.
+
+BuiltinFunction
+ is the name of a perl function. Will extract documentation from
+ `perlfunc'.
+
+FAQRegex
+ is a regex. Will search perlfaq[1-9] for and extract any
+ questions that match.
+
+Any switches in the PERLDOC environment variable will be used before the
+command line arguments. The optional pod index file contains a list of
+filenames, one per line.
+
+EOF
+}
+
+if( defined $ENV{"PERLDOC"} ) {
+ require Text::ParseWords;
+ unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"}));
+}
+!NO!SUBS!
+
+my $getopts = "mhtluvriFf:Xq:";
+print OUT <<"!GET!OPTS!";
+
+use vars qw( @{[map "\$opt_$_", ($getopts =~ /\w/g)]} );
+
+getopts("$getopts") || usage;
+!GET!OPTS!
+
+print OUT <<'!NO!SUBS!';
+
+usage if $opt_h;
+
+my $podidx;
+if( $opt_X ) {
+ $podidx = "$Config{'archlib'}/pod.idx";
+ $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
+}
+
+if( (my $opts = do{ local $^W; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
+ usage("only one of -t, -u, -m or -l")
+} elsif ($Is_MSWin32 || $Is_Dos) {
+ $opt_t = 1 unless $opts
+}
+
+if ($opt_t) { require Pod::Text; import Pod::Text; }
+
+my @pages;
+if ($opt_f) {
+ @pages = ("perlfunc");
+} elsif ($opt_q) {
+ @pages = ("perlfaq1" .. "perlfaq9");
+} else {
+ @pages = @ARGV;
+}
+
+# Does this look like a module or extension directory?
+if (-f "Makefile.PL") {
+ # Add ., lib and blib/* libs to @INC (if they exist)
+ unshift(@INC, '.');
+ unshift(@INC, 'lib') if -d 'lib';
+ require ExtUtils::testlib;
+}
+
+
+
+sub containspod {
+ my($file, $readit) = @_;
+ return 1 if !$readit && $file =~ /\.pod$/i;
+ local($_);
+ open(TEST,"<$file");
+ while(<TEST>) {
+ if(/^=head/) {
+ close(TEST);
+ return 1;
+ }
+ }
+ close(TEST);
+ return 0;
+}
+
+sub minus_f_nocase {
+ my($dir,$file) = @_;
+ my $path = join('/',$dir,$file);
+ return $path if -f $path and -r _;
+ if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
+ # on a case-forgiving file system or if case is important
+ # that is it all we can do
+ warn "Ignored $file: unreadable\n" if -f _;
+ return '';
+ }
+ local *DIR;
+ local($")="/";
+ my @p = ($dir);
+ my($p,$cip);
+ foreach $p (split(/\//, $file)){
+ my $try = "@p/$p";
+ stat $try;
+ if (-d _){
+ push @p, $p;
+ if ( $p eq $global_target) {
+ my $tmp_path = join ('/', @p);
+ my $path_f = 0;
+ for (@global_found) {
+ $path_f = 1 if $_ eq $tmp_path;
+ }
+ push (@global_found, $tmp_path) unless $path_f;
+ print STDERR "Found as @p but directory\n" if $opt_v;
+ }
+ } elsif (-f _ && -r _) {
+ return $try;
+ } elsif (-f _) {
+ warn "Ignored $try: unreadable\n";
+ } else {
+ my $found=0;
+ my $lcp = lc $p;
+ opendir DIR, "@p";
+ while ($cip=readdir(DIR)) {
+ if (lc $cip eq $lcp){
+ $found++;
+ last;
+ }
+ }
+ closedir DIR;
+ return "" unless $found;
+ push @p, $cip;
+ return "@p" if -f "@p" and -r _;
+ warn "Ignored $file: unreadable\n" if -f _;
+ }
+ }
+ return "";
+}
+
+
+sub check_file {
+ my($dir,$file) = @_;
+ if ($opt_m) {
+ return minus_f_nocase($dir,$file);
+ } else {
+ my $path = minus_f_nocase($dir,$file);
+ return $path if length $path and containspod($path);
+ }
+ return "";
+}
+
+
+sub searchfor {
+ my($recurse,$s,@dirs) = @_;
+ $s =~ s!::!/!g;
+ $s = VMS::Filespec::unixify($s) if $Is_VMS;
+ return $s if -f $s && containspod($s);
+ printf STDERR "Looking for $s in @dirs\n" if $opt_v;
+ my $ret;
+ my $i;
+ my $dir;
+ $global_target = (split('/', $s))[-1];
+ for ($i=0; $i<@dirs; $i++) {
+ $dir = $dirs[$i];
+ ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS;
+ if ( ( $ret = check_file $dir,"$s.pod")
+ or ( $ret = check_file $dir,"$s.pm")
+ or ( $ret = check_file $dir,$s)
+ or ( $Is_VMS and
+ $ret = check_file $dir,"$s.com")
+ or ( $^O eq 'os2' and
+ $ret = check_file $dir,"$s.cmd")
+ or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
+ $ret = check_file $dir,"$s.bat")
+ or ( $ret = check_file "$dir/pod","$s.pod")
+ or ( $ret = check_file "$dir/pod",$s)
+ ) {
+ return $ret;
+ }
+
+ if ($recurse) {
+ opendir(D,$dir);
+ my @newdirs = map "$dir/$_", grep {
+ not /^\.\.?$/ and
+ not /^auto$/ and # save time! don't search auto dirs
+ -d "$dir/$_"
+ } readdir D;
+ closedir(D);
+ next unless @newdirs;
+ @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS;
+ print STDERR "Also looking in @newdirs\n" if $opt_v;
+ push(@dirs,@newdirs);
+ }
+ }
+ return ();
+}
+
+my @found;
+foreach (@pages) {
+ if ($podidx && open(PODIDX, $podidx)) {
+ my $searchfor = $_;
+ local($_);
+ $searchfor =~ s,::,/,g;
+ print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
+ while (<PODIDX>) {
+ chomp;
+ push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?$,i;
+ }
+ close(PODIDX);
+ next;
+ }
+ print STDERR "Searching for $_\n" if $opt_v;
+ # We must look both in @INC for library modules and in PATH
+ # for executables, like h2xs or perldoc itself.
+ my @searchdirs = @INC;
+ if ($opt_F) {
+ next unless -r;
+ push @found, $_ if $opt_m or containspod($_);
+ next;
+ }
+ unless ($opt_m) {
+ if ($Is_VMS) {
+ my($i,$trn);
+ for ($i = 0; $trn = $ENV{'DCL$PATH'.$i}; $i++) {
+ push(@searchdirs,$trn);
+ }
+ push(@searchdirs,'perl_root:[lib.pod]') # installed pods
+ } else {
+ push(@searchdirs, grep(-d, split($Config{path_sep},
+ $ENV{'PATH'})));
+ }
+ }
+ my @files = searchfor(0,$_,@searchdirs);
+ if( @files ) {
+ print STDERR "Found as @files\n" if $opt_v;
+ } else {
+ # no match, try recursive search
+
+ @searchdirs = grep(!/^\.$/,@INC);
+
+ @files= searchfor(1,$_,@searchdirs) if $opt_r;
+ if( @files ) {
+ print STDERR "Loosely found as @files\n" if $opt_v;
+ } else {
+ print STDERR "No documentation found for \"$_\".\n";
+ if (@global_found) {
+ print STDERR "However, try\n";
+ for my $dir (@global_found) {
+ opendir(DIR, $dir) or die "$!";
+ while (my $file = readdir(DIR)) {
+ next if ($file =~ /^\./);
+ $file =~ s/\.(pm|pod)$//;
+ print STDERR "\tperldoc $_\::$file\n";
+ }
+ closedir DIR;
+ }
+ }
+ }
+ }
+ push(@found,@files);
+}
+
+if(!@found) {
+ exit ($Is_VMS ? 98962 : 1);
+}
+
+if ($opt_l) {
+ print join("\n", @found), "\n";
+ exit;
+}
+
+my $lines = $ENV{LINES} || 24;
+
+my $no_tty;
+if( ! -t STDOUT ) { $no_tty = 1 }
+
+my $tmp;
+if ($Is_MSWin32) {
+ $tmp = "$ENV{TEMP}\\perldoc1.$$";
+ push @pagers, qw( more< less notepad );
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+} elsif ($Is_VMS) {
+ $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
+ push @pagers, qw( most more less type/page );
+} elsif ($Is_Dos) {
+ $tmp = "$ENV{TEMP}/perldoc1.$$";
+ $tmp =~ tr!\\/!//!s;
+ push @pagers, qw( less.exe more.com< );
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+} else {
+ if ($^O eq 'os2') {
+ require POSIX;
+ $tmp = POSIX::tmpnam();
+ unshift @pagers, 'less', 'cmd /c more <';
+ } else {
+ $tmp = "/tmp/perldoc1.$$";
+ }
+ push @pagers, qw( more less pg view cat );
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+}
+unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
+
+if ($opt_m) {
+ foreach my $pager (@pagers) {
+ system("$pager @found") or exit;
+ }
+ if ($Is_VMS) { eval 'use vmsish qw(status exit); exit $?' }
+ exit 1;
+}
+
+if ($opt_f) {
+ my $perlfunc = shift @found;
+ open(PFUNC, $perlfunc) or die "Can't open $perlfunc: $!";
+
+ # Skip introduction
+ while (<PFUNC>) {
+ last if /^=head2 Alphabetical Listing of Perl Functions/;
+ }
+
+ # Look for our function
+ my $found = 0;
+ my @pod;
+ while (<PFUNC>) {
+ if (/^=item\s+\Q$opt_f\E\b/o) {
+ $found = 1;
+ } elsif (/^=item/) {
+ last if $found > 1;
+ }
+ next unless $found;
+ push @pod, $_;
+ ++$found if /^\w/; # found descriptive text
+ }
+ if (@pod) {
+ if ($opt_t) {
+ open(FORMATTER, "| pod2text") || die "Can't start filter";
+ print FORMATTER "=over 8\n\n";
+ print FORMATTER @pod;
+ print FORMATTER "=back\n";
+ close(FORMATTER);
+ } elsif (@pod < $lines-2) {
+ print @pod;
+ } else {
+ foreach my $pager (@pagers) {
+ open (PAGER, "| $pager") or next;
+ print PAGER @pod ;
+ close(PAGER) or next;
+ last;
+ }
+ }
+ } else {
+ die "No documentation for perl function `$opt_f' found\n";
+ }
+ exit;
+}
+
+if ($opt_q) {
+ local @ARGV = @found; # I'm lazy, sue me.
+ my $found = 0;
+ my %found_in;
+ my @pod;
+
+ while (<>) {
+ if (/^=head2\s+.*$opt_q/oi) {
+ $found = 1;
+ push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
+ } elsif (/^=head2/) {
+ $found = 0;
+ }
+ next unless $found;
+ push @pod, $_;
+ }
+
+ if (@pod) {
+ if ($opt_t) {
+ open(FORMATTER, "| pod2text") || die "Can't start filter";
+ print FORMATTER "=over 8\n\n";
+ print FORMATTER @pod;
+ print FORMATTER "=back\n";
+ close(FORMATTER);
+ } elsif (@pod < $lines-2) {
+ print @pod;
+ } else {
+ foreach my $pager (@pagers) {
+ open (PAGER, "| $pager") or next;
+ print PAGER @pod ;
+ close(PAGER) or next;
+ last;
+ }
+ }
+ } else {
+ die "No documentation for perl FAQ keyword `$opt_q' found\n";
+ }
+ exit;
+}
+
+foreach (@found) {
+
+ my $err;
+ if($opt_t) {
+ open(TMP,">>$tmp");
+ Pod::Text::pod2text($_,*TMP);
+ close(TMP);
+ } elsif(not $opt_u) {
+ my $cmd = "pod2man --lax $_ | nroff -man";
+ $cmd .= " | col -x" if $^O =~ /hpux/;
+ my $rslt = `$cmd`;
+ unless(($err = $?)) {
+ open(TMP,">>$tmp");
+ print TMP $rslt;
+ close TMP;
+ }
+ }
+
+ if( $opt_u or $err or -z $tmp) {
+ open(OUT,">>$tmp");
+ open(IN,"<$_");
+ my $cut = 1;
+ while (<IN>) {
+ $cut = $1 eq 'cut' if /^=(\w+)/;
+ next if $cut;
+ print OUT;
+ }
+ close(IN);
+ close(OUT);
+ }
+}
+
+if( $no_tty ) {
+ open(TMP,"<$tmp");
+ print while <TMP>;
+ close(TMP);
+} else {
+ foreach my $pager (@pagers) {
+ system("$pager $tmp") or last;
+ }
+}
+
+1 while unlink($tmp); #Possibly pointless VMSism
+
+exit 0;
+
+__END__
+
+=head1 NAME
+
+perldoc - Look up Perl documentation in pod format.
+
+=head1 SYNOPSIS
+
+B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>] [B<-X>] PageName|ModuleName|ProgramName
+
+B<perldoc> B<-f> BuiltinFunction
+
+B<perldoc> B<-q> FAQ Keyword
+
+=head1 DESCRIPTION
+
+I<perldoc> looks up a piece of documentation in .pod format that is embedded
+in the perl installation tree or in a perl script, and displays it via
+C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
+C<col -x> will be used.) This is primarily used for the documentation for
+the perl library modules.
+
+Your system may also have man pages installed for those modules, in
+which case you can probably just use the man(1) command.
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-h> help
+
+Prints out a brief help message.
+
+=item B<-v> verbose
+
+Describes search for the item in detail.
+
+=item B<-t> text output
+
+Display docs using plain text converter, instead of nroff. This may be faster,
+but it won't look as nice.
+
+=item B<-u> unformatted
+
+Find docs only; skip reformatting by pod2*
+
+=item B<-m> module
+
+Display the entire module: both code and unformatted pod documentation.
+This may be useful if the docs don't explain a function in the detail
+you need, and you'd like to inspect the code directly; perldoc will find
+the file for you and simply hand it off for display.
+
+=item B<-l> file name only
+
+Display the file name of the module found.
+
+=item B<-F> file names
+
+Consider arguments as file names, no search in directories will be performed.
+
+=item B<-f> perlfunc
+
+The B<-f> option followed by the name of a perl built in function will
+extract the documentation of this function from L<perlfunc>.
+
+=item B<-q> perlfaq
+
+The B<-q> option takes a regular expression as an argument. It will search
+the question headings in perlfaq[1-9] and print the entries matching
+the regular expression.
+
+=item B<-X> use an index if present
+
+The B<-X> option looks for a entry whose basename matches the name given on the
+command line in the file C<$Config{archlib}/pod.idx>. The pod.idx file should
+contain fully qualified filenames, one per line.
+
+=item B<PageName|ModuleName|ProgramName>
+
+The item you want to look up. Nested modules (such as C<File::Basename>)
+are specified either as C<File::Basename> or C<File/Basename>. You may also
+give a descriptive name of a page, such as C<perlfunc>. You make also give a
+partial or wrong-case name, such as "basename" for "File::Basename", but
+this will be slower, if there is more then one page with the same partial
+name, you will only get the first one.
+
+=back
+
+=head1 ENVIRONMENT
+
+Any switches in the C<PERLDOC> environment variable will be used before the
+command line arguments. C<perldoc> also searches directories
+specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
+defined) and C<PATH> environment variables.
+(The latter is so that embedded pods for executables, such as
+C<perldoc> itself, are available.) C<perldoc> will use, in order of
+preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
+C<PAGER> before trying to find a pager on its own. (C<MANPAGER> is not
+used if C<perldoc> was told to display plain text or unformatted pod.)
+
+=head1 AUTHOR
+
+Kenneth Albanowski <kjahds@kjahds.com>
+
+Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
+
+=cut
+
+#
+# Version 1.14: Wed Jul 15 01:50:20 EST 1998
+# Robin Barker <rmb1@cise.npl.co.uk>
+# -strict, -w cleanups
+# Version 1.13: Fri Feb 27 16:20:50 EST 1997
+# Gurusamy Sarathy <gsar@umich.edu>
+# -doc tweaks for -F and -X options
+# Version 1.12: Sat Apr 12 22:41:09 EST 1997
+# Gurusamy Sarathy <gsar@umich.edu>
+# -various fixes for win32
+# Version 1.11: Tue Dec 26 09:54:33 EST 1995
+# Kenneth Albanowski <kjahds@kjahds.com>
+# -added Charles Bailey's further VMS patches, and -u switch
+# -added -t switch, with pod2text support
+#
+# Version 1.10: Thu Nov 9 07:23:47 EST 1995
+# Kenneth Albanowski <kjahds@kjahds.com>
+# -added VMS support
+# -added better error recognition (on no found pages, just exit. On
+# missing nroff/pod2man, just display raw pod.)
+# -added recursive/case-insensitive matching (thanks, Andreas). This
+# slows things down a bit, unfortunately. Give a precise name, and
+# it'll run faster.
+#
+# Version 1.01: Tue May 30 14:47:34 EDT 1995
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
+# -added pod documentation.
+# -added PATH searching.
+# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
+# and friends.
+#
+#
+# TODO:
+#
+# Cache directories read during sloppy match
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/utils/pl2pm.PL b/contrib/perl5/utils/pl2pm.PL
new file mode 100644
index 000000000000..48e281d1a57e
--- /dev/null
+++ b/contrib/perl5/utils/pl2pm.PL
@@ -0,0 +1,389 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+=head1 NAME
+
+pl2pm - Rough tool to translate Perl4 .pl files to Perl5 .pm modules.
+
+=head1 SYNOPSIS
+
+B<pl2pm> F<files>
+
+=head1 DESCRIPTION
+
+B<pl2pm> is a tool to aid in the conversion of Perl4-style .pl
+library files to Perl5-style library modules. Usually, your old .pl
+file will still work fine and you should only use this tool if you
+plan to update your library to use some of the newer Perl 5 features,
+such as AutoLoading.
+
+=head1 LIMITATIONS
+
+It's just a first step, but it's usually a good first step.
+
+=head1 AUTHOR
+
+Larry Wall <larry@wall.org>
+
+=cut
+
+while (<DATA>) {
+ chop;
+ $keyword{$_} = 1;
+}
+
+undef $/;
+$* = 1;
+while (<>) {
+ $newname = $ARGV;
+ $newname =~ s/\.pl$/.pm/ || next;
+ $newname =~ s#(.*/)?(\w+)#$1\u$2#;
+ if (-f $newname) {
+ warn "Won't overwrite existing $newname\n";
+ next;
+ }
+ $oldpack = $2;
+ $newpack = "\u$2";
+ @export = ();
+ print "$oldpack => $newpack\n" if $verbose;
+
+ s/\bstd(in|out|err)\b/\U$&/g;
+ s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
+ if (/sub\s+main'/) {
+ @export = m/sub\s+main'(\w+)/g;
+ s/(sub\s+)main'(\w+)/$1$2/g;
+ }
+ else {
+ @export = m/sub\s+([A-Za-z]\w*)/g;
+ }
+ @export_ok = grep($keyword{$_}, @export);
+ @export = grep(!$keyword{$_}, @export);
+ @export{@export} = (1) x @export;
+ s/(^\s*);#/$1#/g;
+ s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
+ s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
+ s/([\$\@%&*])'(\w+)/&xlate($1,"",$2)/eg;
+ s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3)/eg;
+ if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
+ s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
+ s/\$\[\s*\+\s*//g;
+ s/\s*\+\s*\$\[//g;
+ s/\$\[/0/g;
+ }
+ s/open\s+(\w+)/open($1)/g;
+
+ if (s/\bdie\b/croak/g) {
+ $carp = "use Carp;\n";
+ s/croak "([^"]*)\\n"/croak "$1"/g;
+ }
+ else {
+ $carp = "";
+ }
+ if (@export_ok) {
+ $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
+ }
+ else {
+ $export_ok = "";
+ }
+
+ open(PM, ">$newname") || warn "Can't create $newname: $!\n";
+ print PM <<"END";
+package $newpack;
+require 5.000;
+require Exporter;
+$carp
+\@ISA = qw(Exporter);
+\@EXPORT = qw(@export);
+$export_ok
+$_
+END
+}
+
+sub xlate {
+ local($prefix, $pack, $ident) = @_;
+ if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
+ "${pack}'$ident";
+ }
+ elsif ($pack eq "" || $pack eq "main") {
+ if ($export{$ident}) {
+ "$prefix$ident";
+ }
+ else {
+ "$prefix${pack}::$ident";
+ }
+ }
+ elsif ($pack eq $oldpack) {
+ "$prefix${newpack}::$ident";
+ }
+ else {
+ "$prefix${pack}::$ident";
+ }
+}
+__END__
+AUTOLOAD
+BEGIN
+CORE
+DESTROY
+END
+abs
+accept
+alarm
+and
+atan2
+bind
+binmode
+bless
+caller
+chdir
+chmod
+chop
+chown
+chr
+chroot
+close
+closedir
+cmp
+connect
+continue
+cos
+crypt
+dbmclose
+dbmopen
+defined
+delete
+die
+do
+dump
+each
+else
+elsif
+endgrent
+endhostent
+endnetent
+endprotoent
+endpwent
+endservent
+eof
+eq
+eval
+exec
+exit
+exp
+fcntl
+fileno
+flock
+for
+foreach
+fork
+format
+formline
+ge
+getc
+getgrent
+getgrgid
+getgrnam
+gethostbyaddr
+gethostbyname
+gethostent
+getlogin
+getnetbyaddr
+getnetbyname
+getnetent
+getpeername
+getpgrp
+getppid
+getpriority
+getprotobyname
+getprotobynumber
+getprotoent
+getpwent
+getpwnam
+getpwuid
+getservbyname
+getservbyport
+getservent
+getsockname
+getsockopt
+glob
+gmtime
+goto
+grep
+gt
+hex
+if
+index
+int
+ioctl
+join
+keys
+kill
+last
+lc
+lcfirst
+le
+length
+link
+listen
+local
+localtime
+log
+lstat
+lt
+m
+mkdir
+msgctl
+msgget
+msgrcv
+msgsnd
+my
+ne
+next
+no
+not
+oct
+open
+opendir
+or
+ord
+pack
+package
+pipe
+pop
+print
+printf
+push
+q
+qq
+quotemeta
+qw
+qx
+rand
+read
+readdir
+readline
+readlink
+readpipe
+recv
+redo
+ref
+rename
+require
+reset
+return
+reverse
+rewinddir
+rindex
+rmdir
+s
+scalar
+seek
+seekdir
+select
+semctl
+semget
+semop
+send
+setgrent
+sethostent
+setnetent
+setpgrp
+setpriority
+setprotoent
+setpwent
+setservent
+setsockopt
+shift
+shmctl
+shmget
+shmread
+shmwrite
+shutdown
+sin
+sleep
+socket
+socketpair
+sort
+splice
+split
+sprintf
+sqrt
+srand
+stat
+study
+sub
+substr
+symlink
+syscall
+sysread
+system
+syswrite
+tell
+telldir
+tie
+time
+times
+tr
+truncate
+uc
+ucfirst
+umask
+undef
+unless
+unlink
+unpack
+unshift
+untie
+until
+use
+utime
+values
+vec
+wait
+waitpid
+wantarray
+warn
+while
+write
+x
+xor
+y
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/utils/splain.PL b/contrib/perl5/utils/splain.PL
new file mode 100644
index 000000000000..a638dbae7174
--- /dev/null
+++ b/contrib/perl5/utils/splain.PL
@@ -0,0 +1,49 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries:
+# $startperl
+# $perlpath
+# $eunicefix
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+# Open input file before creating output file.
+$IN = '../lib/diagnostics.pm';
+open IN or die "Can't open $IN: $!\n";
+
+# Create output file.
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+!GROK!THIS!
+
+while (<IN>) {
+ print OUT unless /^package diagnostics/;
+}
+
+close IN;
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/writemain.SH b/contrib/perl5/writemain.SH
new file mode 100755
index 000000000000..c42838308541
--- /dev/null
+++ b/contrib/perl5/writemain.SH
@@ -0,0 +1,104 @@
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
+esac
+echo "Extracting writemain (with variable substitutions)"
+: This section of the file will have variable substitutions done on it.
+: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
+: Protect any dollar signs and backticks that you do not want interpreted
+: by putting a backslash in front. You may delete these comments.
+rm -f writemain
+$spitshell >writemain <<!GROK!THIS!
+$startsh
+!GROK!THIS!
+
+: In the following dollars and backticks do not need the extra backslash.
+$spitshell >>writemain <<'!NO!SUBS!'
+# This script takes the plain miniperlmain.c and writes out perlmain.c
+# which includes all the extensions.
+# The command line arguments name extensions to be used.
+# E.g.: sh writemain SDBM_File POSIX > perlmain.c
+#
+
+orig="$*"
+args=''
+: Remove any .a suffixes and any leading path components
+for file in `echo $orig | sed 's/\.a//g'` ; do
+ case "$file" in
+ ext/*) file=`echo $file | sed 's:ext/\(.*\)/[^/]*:\1:'`
+ ;;
+ lib/auto/*) file=`echo $file | sed 's:lib/auto/\(.*\)/[^/]*:\1:'`
+ ;;
+ */*)
+ file=`expr X$file : 'X.*/\(.*\)'`
+ ;;
+ esac
+ args="$args $file"
+done
+
+
+sed '/Do not delete this line--writemain depends on it/q' miniperlmain.c
+
+
+if test X"$args" != "X" ; then
+ for ext in $args ; do
+: $ext will either be 'Name' or 'Name1/Name2' etc
+: convert ext into cname and mname
+mname=`echo $ext | sed 's!/!::!g'`
+cname=`echo $mname | sed 's!:!_!g'`
+
+echo "EXTERN_C void boot_${cname} _((CV* cv));"
+ done
+fi
+
+cat << 'EOP'
+
+static void
+xs_init()
+{
+EOP
+
+if test X"$args" != "X" ; then
+ echo " char *file = __FILE__;"
+ echo " dXSUB_SYS;"
+
+ ai=''
+
+ for ext in $args ; do
+
+ : $ext will either be 'Name' or 'Name1/Name2' etc
+ : convert ext into cname and mname
+ mname=`echo $ext | sed 's!/!::!g'`
+ cname=`echo $mname | sed 's!:!_!g'`
+
+ if test "$ext" = "DynaLoader"; then
+ : Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
+ : boot_DynaLoader is called directly in DynaLoader.pm
+ echo " newXS(\"${mname}::boot_${ext}\", boot_${cname}, file);"
+ else
+ echo " newXS(\"${mname}::bootstrap\", boot_${cname}, file);"
+ fi
+ done
+fi
+
+cat << 'EOP'
+}
+EOP
+
+!NO!SUBS!
+chmod 755 writemain
+$eunicefix writemain
diff --git a/contrib/perl5/x2p/EXTERN.h b/contrib/perl5/x2p/EXTERN.h
new file mode 100644
index 000000000000..cd1a4112ae28
--- /dev/null
+++ b/contrib/perl5/x2p/EXTERN.h
@@ -0,0 +1,17 @@
+/* $RCSfile: EXTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:05 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: EXTERN.h,v $
+ */
+
+#undef EXT
+#define EXT extern
+
+#undef INIT
+#define INIT(x)
+
+#undef DOINIT
diff --git a/contrib/perl5/x2p/INTERN.h b/contrib/perl5/x2p/INTERN.h
new file mode 100644
index 000000000000..ac1d57ab05c1
--- /dev/null
+++ b/contrib/perl5/x2p/INTERN.h
@@ -0,0 +1,17 @@
+/* $RCSfile: INTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:06 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: INTERN.h,v $
+ */
+
+#undef EXT
+#define EXT
+
+#undef INIT
+#define INIT(x) = x
+
+#define DOINIT
diff --git a/contrib/perl5/x2p/Makefile.SH b/contrib/perl5/x2p/Makefile.SH
new file mode 100755
index 000000000000..5bec7a0058f6
--- /dev/null
+++ b/contrib/perl5/x2p/Makefile.SH
@@ -0,0 +1,181 @@
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/Makefile.SH) cd `expr X$0 : 'X\(.*\)/'` ;;
+Makefile.SH) ;;
+*) case `pwd` in
+ */x2p) ;;
+ *) if test -d x2p; then cd x2p
+ else echo "Can't figure out where to write output."; exit 1
+ fi;;
+ esac;;
+esac
+
+echo "Extracting x2p/Makefile (with variable substitutions)"
+rm -f Makefile
+cat >Makefile <<!GROK!THIS!
+# $RCSfile: Makefile.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:07 $
+#
+# $Log: Makefile.SH,v $
+
+CC = $cc
+BYACC = $byacc
+LDFLAGS = $ldflags
+SMALL = $small
+LARGE = $large $split
+mallocsrc = $mallocsrc
+mallocobj = $mallocobj
+shellflags = $shellflags
+
+libs = $libs
+
+$make_set_make
+# grrr
+SHELL = $sh
+
+# These variables may need to be manually set for non-Unix systems.
+AR = $ar
+EXE_EXT = $_ext
+LIB_EXT = $_a
+OBJ_EXT = $_o
+PATH_SEP = $p_
+
+FIRSTMAKEFILE = $firstmakefile
+
+# how to tr(anslate) newlines
+
+TRNL = '$trnl'
+
+.SUFFIXES: .c \$(OBJ_EXT)
+
+!GROK!THIS!
+
+cat >>Makefile <<'!NO!SUBS!'
+
+REALPERL = ../perl
+CCCMD = `sh $(shellflags) cflags $@`
+
+public = a2p s2p find2perl
+
+private =
+
+manpages = a2p.man s2p.man
+
+util =
+
+sh = Makefile.SH cflags.SH
+shextract = Makefile cflags
+
+pl = find2perl.PL s2p.PL
+plextract = find2perl s2p
+plexe = find2perl.exe s2p.exe
+plc = find2perl.c s2p.c
+
+addedbyconf = $(shextract) $(plextract)
+
+h = EXTERN.h INTERN.h ../config.h ../handy.h hash.h a2p.h str.h util.h
+
+c = hash.c $(mallocsrc) str.c util.c walk.c
+
+obj = hash$(OBJ_EXT) $(mallocobj) str$(OBJ_EXT) util$(OBJ_EXT) walk$(OBJ_EXT)
+
+lintflags = -phbvxac
+
+
+.c$(OBJ_EXT):
+ $(CCCMD) -DPERL_FOR_X2P $*.c
+
+all: $(public) $(private) $(util)
+ @echo " "
+
+compile: all
+ $(REALPERL) -I../lib ../utils/perlcc -regex 's/$$/.exe/' $(plextract) -prog -verbose dcf -log ../compilelog;
+
+a2p: $(obj) a2p$(OBJ_EXT)
+ $(CC) -o a2p $(LDFLAGS) $(obj) a2p$(OBJ_EXT) $(libs)
+
+# I now supply a2p.c with the kits, so the following section is
+# used only if you force byacc to run by saying
+# make run_byacc
+
+run_byacc: FORCE
+ @ echo Expect many shift/reduce and reduce/reduce conflicts
+ $(BYACC) a2p.y
+ rm -f a2p.c
+ mv y.tab.c a2p.c
+
+# We don't want to regenerate a2p.c, but it might appear out-of-date
+# after a patch is applied or a new distribution is made.
+a2p.c: a2p.y
+ -@sh -c true
+
+a2p$(OBJ_EXT): a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h \
+ ../handy.h ../config.h str.h hash.h
+ $(CCCMD) $(LARGE) a2p.c
+
+clean:
+ rm -f a2p *$(OBJ_EXT) $(plexe) $(plc)
+
+realclean: clean
+ rm -f *.orig core $(addedbyconf) all malloc.c
+ rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old
+
+# The following lint has practically everything turned on. Unfortunately,
+# you have to wade through a lot of mumbo jumbo that can't be suppressed.
+# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
+# for that spot.
+
+lint:
+ lint $(lintflags) $(defs) $(c) > a2p.fuzz
+
+depend: $(mallocsrc) ../makedepend
+ sh ../makedepend MAKE=$(MAKE)
+
+clist:
+ echo $(c) | tr ' ' $(TRNL) >.clist
+
+hlist:
+ echo $(h) | tr ' ' $(TRNL) >.hlist
+
+shlist:
+ echo $(sh) | tr ' ' $(TRNL) >.shlist
+
+# These should be automatically generated
+
+$(plextract):
+ ../miniperl -I../lib $@.PL
+
+malloc.c: ../malloc.c
+ rm -f malloc.c
+ sed <../malloc.c >malloc.c \
+ -e 's/"EXTERN.h"/"..\/EXTERN.h"/' \
+ -e 's/"perl.h"/"..\/perl.h"/' \
+ -e 's/my_exit/exit/' \
+ -e 's/MUTEX_[A-Z_]*(&PL_malloc_mutex);//'
+
+# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
+$(obj):
+ @ echo "You haven't done a "'"make depend" yet!'; exit 1
+makedepend: depend
+!NO!SUBS!
+$eunicefix Makefile
+case `pwd` in
+*SH)
+ $rm -f ../Makefile
+ $ln Makefile ../Makefile
+ ;;
+esac
+rm -f $firstmakefile
diff --git a/contrib/perl5/x2p/a2p.c b/contrib/perl5/x2p/a2p.c
new file mode 100644
index 000000000000..e79e1562034f
--- /dev/null
+++ b/contrib/perl5/x2p/a2p.c
@@ -0,0 +1,2731 @@
+#ifndef lint
+static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
+#endif
+#define YYBYACC 1
+#line 2 "a2p.y"
+/* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: a2p.y,v $
+ */
+
+#include "INTERN.h"
+#include "a2p.h"
+
+int root;
+int begins = Nullop;
+int ends = Nullop;
+
+#line 24 "y.tab.c"
+#define BEGIN 257
+#define END 258
+#define REGEX 259
+#define SEMINEW 260
+#define NEWLINE 261
+#define COMMENT 262
+#define FUN1 263
+#define FUNN 264
+#define GRGR 265
+#define PRINT 266
+#define PRINTF 267
+#define SPRINTF 268
+#define SPLIT 269
+#define IF 270
+#define ELSE 271
+#define WHILE 272
+#define FOR 273
+#define IN 274
+#define EXIT 275
+#define NEXT 276
+#define BREAK 277
+#define CONTINUE 278
+#define RET 279
+#define GETLINE 280
+#define DO 281
+#define SUB 282
+#define GSUB 283
+#define MATCH 284
+#define FUNCTION 285
+#define USERFUN 286
+#define DELETE 287
+#define ASGNOP 288
+#define OROR 289
+#define ANDAND 290
+#define NUMBER 291
+#define VAR 292
+#define SUBSTR 293
+#define INDEX 294
+#define MATCHOP 295
+#define RELOP 296
+#define OR 297
+#define STRING 298
+#define UMINUS 299
+#define NOT 300
+#define INCR 301
+#define DECR 302
+#define FIELD 303
+#define VFIELD 304
+#define YYERRCODE 256
+short yylhs[] = { -1,
+ 0, 3, 6, 6, 2, 2, 7, 7, 7, 7,
+ 7, 7, 9, 8, 8, 11, 11, 11, 11, 11,
+ 15, 15, 15, 15, 14, 14, 14, 14, 13, 13,
+ 13, 13, 12, 12, 12, 12, 16, 16, 16, 16,
+ 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
+ 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
+ 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
+ 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
+ 16, 17, 17, 17, 17, 10, 10, 10, 18, 18,
+ 18, 1, 1, 19, 19, 19, 19, 4, 4, 20,
+ 20, 21, 21, 21, 21, 5, 5, 22, 22, 22,
+ 22, 25, 25, 23, 23, 23, 23, 23, 23, 23,
+ 23, 23, 23, 23, 23, 23, 26, 26, 26, 24,
+ 24, 24, 24, 24, 24, 24, 24,
+};
+short yylen[] = { 2,
+ 2, 6, 5, 2, 3, 0, 1, 5, 10, 4,
+ 1, 1, 1, 1, 3, 1, 1, 1, 1, 5,
+ 3, 4, 4, 2, 3, 3, 3, 3, 3, 3,
+ 1, 3, 1, 2, 5, 3, 1, 1, 1, 3,
+ 3, 3, 3, 3, 3, 3, 2, 2, 2, 2,
+ 2, 2, 3, 1, 2, 3, 4, 3, 4, 1,
+ 3, 4, 4, 4, 2, 8, 6, 8, 8, 6,
+ 6, 6, 6, 6, 6, 6, 6, 8, 8, 8,
+ 8, 1, 4, 1, 2, 1, 1, 0, 4, 4,
+ 3, 2, 0, 1, 1, 1, 1, 2, 0, 1,
+ 1, 2, 2, 2, 2, 2, 0, 3, 2, 2,
+ 1, 1, 0, 1, 4, 2, 4, 2, 1, 1,
+ 1, 2, 1, 1, 2, 5, 1, 1, 1, 6,
+ 9, 6, 7, 10, 9, 6, 5,
+};
+short yydefred[] = { 93,
+ 0, 0, 95, 96, 97, 94, 0, 92, 0, 0,
+ 31, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 38, 0, 0, 0, 39, 0, 0, 0, 0,
+ 0, 84, 0, 99, 0, 11, 0, 93, 0, 0,
+ 0, 17, 18, 19, 0, 0, 99, 99, 0, 0,
+ 0, 65, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 24,
+ 49, 50, 0, 0, 0, 0, 0, 0, 4, 0,
+ 99, 0, 99, 99, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 47, 48, 0, 0, 61, 0, 0, 0, 0, 0,
+ 99, 99, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 100, 101, 0, 98, 53,
+ 32, 28, 21, 0, 0, 0, 0, 0, 0, 30,
+ 0, 0, 0, 0, 46, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 62, 63, 91, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 13, 64,
+ 83, 0, 0, 99, 0, 0, 0, 0, 0, 0,
+ 120, 119, 123, 0, 99, 0, 99, 10, 99, 0,
+ 106, 0, 111, 0, 0, 0, 22, 0, 59, 93,
+ 3, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 99, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 99, 99, 99, 99, 99,
+ 8, 0, 0, 0, 70, 0, 75, 0, 74, 0,
+ 77, 0, 76, 0, 72, 73, 0, 67, 0, 71,
+ 128, 127, 129, 0, 0, 0, 0, 0, 112, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 99, 0, 0, 0, 99, 99,
+ 99, 0, 0, 0, 99, 69, 68, 79, 78, 81,
+ 80, 0, 66, 0, 0, 0, 0, 0, 0, 126,
+ 0, 0, 0, 132, 136, 0, 0, 0, 9, 99,
+ 99, 0, 133, 0, 0, 99, 131, 135, 0, 134,
+};
+short yydgoto[] = { 1,
+ 2, 7, 36, 74, 128, 37, 38, 39, 168, 52,
+ 75, 190, 42, 43, 44, 45, 46, 54, 8, 129,
+ 230, 191, 192, 193, 260, 254,
+};
+short yysindex[] = { 0,
+ 0, -50, 0, 0, 0, 0, 4775, 0, -91, -38,
+ 0, 34, 41, 7201, 42, 6, 46, 48, 50, -184,
+ 70, 0, 16, 77, 80, 0, 7255, 7255, 5051, -220,
+ -220, 0, 7255, 0, 5051, 0, -140, 0, 5, -13,
+ 5693, 0, 0, 0, -32, -233, 0, 0, 4619, 7201,
+ 5962, 0, 6006, 79, 7255, 7255, 71, 6890, 6936, 7255,
+ 87, 7201, 7201, 7255, 7255, 5051, -42, -244, -42, 0,
+ 0, 0, 20, -183, -41, 89, 92, 93, 0, -50,
+ 0, 7255, 0, 0, 5051, 7255, 6990, 7255, 7255, 7255,
+ -32, -157, 7255, 7255, 7255, 7255, 7255, 7255, -144, 5051,
+ 0, 0, -183, -183, 0, 3590, 96, 5962, 5577, 10,
+ 0, 0, 6049, 1522, 7255, 94, 6107, 95, 6153, 6195,
+ 7201, 99, 51, 6238, 6281, 0, 0, 4886, 0, 0,
+ 0, 0, 0, -183, 6323, 1605, 1605, -60, 6380, 0,
+ 1522, 1522, 1522, 1522, 0, -7, -7, -42, -42, -42,
+ -42, -220, -60, 4931, 4977, 0, 0, 0, 6425, 6425,
+ -151, 1522, 7255, 7255, 7255, 7255, 7052, 102, 0, 0,
+ 0, 7255, 7255, 0, 7201, 7201, 115, 119, 121, 7255,
+ 0, 0, 0, 7255, 0, -130, 0, 0, 0, 7112,
+ 0, 18, 0, 5242, 7255, -126, 0, 7255, 0, 0,
+ 0, 7112, 7112, 32, 2427, 2474, 5735, 5779, 126, 6470,
+ 0, 5842, 6513, -183, -33, -33, 5051, 5051, 5428, 7112,
+ 7112, 4046, 81, -183, -183, 0, 0, 0, 0, 0,
+ 0, 7112, 7112, -50, 0, 7158, 0, 7255, 0, 7255,
+ 0, 7255, 0, 7255, 0, 0, -96, 0, 7255, 0,
+ 0, 0, 0, 7255, 7255, -39, -37, 6555, 0, 116,
+ -95, 7201, 5287, -183, -183, -183, -183, -183, 135, 6612,
+ 6657, 6702, 6745, 6787, 0, 6844, 7112, 7112, 0, 0,
+ 0, 5908, 144, 97, 0, 0, 0, 0, 0, 0,
+ 0, -183, 0, 4046, 4046, 4046, 5428, -51, 5051, 0,
+ -183, 5332, -85, 0, 0, 146, 5428, -35, 0, 0,
+ 0, 147, 0, 4046, 4046, 0, 0, 0, 4046, 0,
+};
+short yyrindex[] = { 0,
+ 0, 2000, 0, 0, 0, 0, 189, 0, 0, 0,
+ 0, 56, 0, 3312, 0, 2591, 0, 0, 0, 0,
+ 0, 0, 1, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 2138, 0, 1930, 1209,
+ 3755, 0, 0, 0, 1818, 1394, 0, 0, 0, 151,
+ 0, 0, 3707, 111, 0, 0, 381, 0, 0, 0,
+ 0, 151, 100, 0, 0, 0, 564, 834, 889, 0,
+ 0, 0, 436, 5378, 0, -49, -46, -43, 0, 2195,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 2084, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 5378, 5378, 0, 0, 0, 0, -22, 0,
+ 0, 0, 0, 2639, 0, 0, 0, 0, 0, 0,
+ 151, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 5378, 0, 0, 0, 1872, 0, 0,
+ 2878, 2923, 2968, 3037, 0, 1719, 1770, 943, 1016, 1286,
+ 1340, 2536, 1664, 0, 0, 0, 0, 0, 0, 0,
+ 0, 3245, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 67, 67, 0, 0, 0, -34,
+ 0, 0, 0, 12, 0, 0, 0, 0, 0, 101,
+ 0, 0, 0, 0, 0, 491, 0, 0, 0, 0,
+ 0, 3360, 3432, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 4091, 104, 172, 0, 0, 136, 241,
+ 247, 0, 0, 5378, 4146, 0, 0, 0, 0, 0,
+ 0, 3520, 3640, 2266, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 137, 0, 0,
+ 0, 100, 0, 4220, 4411, 4485, 4530, 4576, 0, 0,
+ 0, 0, 0, 0, 0, 0, 296, 357, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 5378, 0, 0, 0, 0, 153, 0, 0, 0,
+ 4841, 0, 5643, 0, 0, 0, 153, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+};
+short yygindex[] = { 0,
+ -15, 0, 0, 3236, -67, 0, 0, 0, 0, -29,
+ 171, 4012, -19, 4, 14, 7669, 7480, -4, 0, 0,
+ 0, -113, -201, 0, -232, -18,
+};
+#define YYTABLESIZE 7947
+short yytable[] = { 130,
+ 82, 279, 82, 280, 97, 313, 121, 307, 6, 95,
+ 93, 82, 94, 17, 96, 76, 18, 259, 16, 19,
+ 107, 82, 80, 82, 121, 82, 275, 82, 252, 97,
+ 85, 47, 122, 123, 95, 154, 155, 82, 77, 96,
+ 82, 82, 82, 82, 82, 82, 110, 82, 78, 82,
+ 158, 98, 124, 112, 100, 60, 101, 102, 82, 82,
+ 82, 98, 82, 82, 306, 56, 194, 101, 102, 99,
+ 124, 23, 235, 49, 312, 236, 229, 126, 127, 99,
+ 50, 55, 32, 33, 48, 58, 98, 59, 76, 60,
+ 253, 169, 60, 82, 82, 259, 60, 60, 60, 60,
+ 60, 61, 60, 110, 99, 259, 63, 88, 261, 62,
+ 87, 77, 82, 60, 60, 60, 64, 60, 60, 65,
+ 79, 78, 112, 82, 82, 88, 121, 81, 88, 131,
+ 115, 99, 132, 133, 145, 152, 157, 163, 165, 170,
+ 204, 114, 211, 171, 116, 215, 216, 87, 60, 60,
+ 87, 87, 87, 87, 217, 87, 263, 87, 218, 114,
+ 219, 223, 116, 84, 126, 127, 245, 60, 87, 87,
+ 87, 262, 87, 87, 282, 286, 283, 40, 60, 60,
+ 303, 304, 305, 299, 234, 310, 311, 316, 1, 300,
+ 88, 88, 88, 113, 113, 114, 0, 255, 0, 70,
+ 317, 318, 0, 87, 87, 320, 0, 0, 0, 3,
+ 4, 5, 118, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 87, 0, 302, 121, 121, 121, 83, 84,
+ 118, 251, 284, 87, 87, 0, 0, 83, 84, 17,
+ 17, 92, 18, 18, 0, 19, 19, 83, 84, 83,
+ 84, 83, 84, 83, 84, 138, 0, 82, 82, 82,
+ 82, 82, 82, 82, 82, 82, 16, 16, 82, 82,
+ 153, 124, 124, 124, 82, 83, 84, 226, 227, 228,
+ 82, 122, 82, 82, 82, 82, 82, 125, 82, 82,
+ 82, 82, 82, 82, 82, 82, 82, 23, 82, 122,
+ 82, 82, 82, 82, 82, 125, 196, 197, 32, 33,
+ 0, 0, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 0, 0, 60, 60, 0, 88, 88, 88, 60,
+ 0, 88, 0, 0, 0, 60, 115, 60, 60, 60,
+ 60, 60, 0, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 0, 60, 115, 60, 60, 60, 60, 60,
+ 114, 114, 114, 116, 116, 116, 0, 87, 87, 87,
+ 87, 87, 87, 87, 87, 87, 0, 0, 87, 87,
+ 55, 0, 0, 0, 87, 0, 0, 256, 257, 0,
+ 87, 0, 87, 87, 87, 87, 87, 117, 87, 87,
+ 87, 87, 87, 87, 87, 87, 87, 0, 87, 0,
+ 87, 87, 87, 87, 87, 117, 0, 55, 0, 0,
+ 55, 55, 55, 55, 55, 55, 0, 55, 0, 0,
+ 0, 118, 118, 118, 0, 85, 0, 0, 55, 55,
+ 0, 0, 55, 55, 0, 0, 0, 0, 0, 0,
+ 0, 0, 298, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 308,
+ 0, 0, 85, 55, 55, 85, 85, 85, 85, 85,
+ 85, 0, 85, 0, 0, 0, 0, 0, 0, 0,
+ 23, 0, 55, 85, 85, 85, 0, 85, 85, 0,
+ 122, 122, 122, 55, 55, 0, 125, 125, 125, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 23, 85, 85,
+ 23, 23, 23, 23, 23, 23, 0, 23, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 23, 23,
+ 23, 0, 23, 23, 0, 115, 115, 115, 85, 85,
+ 0, 0, 0, 52, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 23, 23, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 52, 0, 23, 52, 52, 52, 52, 52, 52, 0,
+ 52, 0, 0, 23, 23, 0, 117, 117, 117, 0,
+ 0, 52, 52, 52, 0, 52, 52, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 55, 55, 55,
+ 55, 55, 55, 55, 55, 55, 0, 0, 55, 55,
+ 0, 0, 0, 0, 55, 0, 52, 0, 0, 0,
+ 55, 0, 55, 55, 55, 55, 55, 0, 55, 55,
+ 55, 55, 55, 55, 55, 55, 55, 0, 55, 0,
+ 55, 55, 55, 55, 55, 0, 52, 52, 0, 0,
+ 0, 0, 85, 85, 85, 85, 85, 85, 85, 85,
+ 85, 0, 0, 85, 85, 0, 0, 0, 0, 85,
+ 0, 0, 0, 0, 0, 85, 0, 85, 85, 85,
+ 85, 85, 0, 85, 85, 85, 85, 85, 85, 85,
+ 85, 85, 0, 85, 0, 85, 85, 85, 85, 85,
+ 0, 0, 0, 0, 0, 0, 0, 23, 23, 23,
+ 23, 23, 23, 23, 23, 23, 0, 0, 23, 23,
+ 0, 0, 0, 0, 23, 0, 0, 0, 0, 0,
+ 23, 0, 23, 23, 23, 23, 23, 0, 23, 23,
+ 0, 23, 23, 23, 23, 23, 23, 0, 23, 0,
+ 23, 23, 23, 23, 23, 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,
+ 52, 52, 52, 52, 52, 52, 52, 52, 52, 0,
+ 0, 52, 52, 37, 0, 0, 0, 52, 0, 0,
+ 0, 0, 0, 52, 0, 52, 52, 52, 52, 52,
+ 0, 52, 52, 52, 52, 52, 52, 52, 52, 52,
+ 0, 52, 0, 52, 52, 52, 52, 52, 0, 0,
+ 37, 0, 0, 37, 37, 37, 37, 37, 37, 0,
+ 37, 0, 0, 0, 0, 0, 0, 0, 51, 0,
+ 0, 37, 37, 37, 0, 37, 37, 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, 51, 37, 37, 51, 51,
+ 51, 51, 51, 51, 0, 51, 0, 0, 0, 0,
+ 0, 0, 42, 0, 0, 37, 51, 51, 51, 0,
+ 51, 51, 0, 0, 0, 0, 37, 37, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 42,
+ 0, 51, 42, 42, 42, 42, 42, 42, 0, 42,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 42, 42, 42, 0, 42, 42, 0, 0, 0, 0,
+ 0, 51, 51, 0, 0, 43, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 42, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 43, 0, 0, 43, 43, 43, 43, 43,
+ 43, 0, 43, 0, 0, 42, 42, 0, 0, 0,
+ 0, 0, 0, 43, 43, 43, 0, 43, 43, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 37, 37, 37, 37, 37, 37, 37, 37, 37, 0,
+ 0, 37, 37, 0, 0, 0, 0, 37, 43, 0,
+ 0, 0, 0, 37, 0, 37, 37, 37, 37, 37,
+ 0, 37, 37, 37, 37, 37, 37, 37, 37, 37,
+ 0, 37, 0, 37, 0, 0, 37, 37, 43, 43,
+ 0, 0, 0, 0, 0, 51, 51, 51, 51, 51,
+ 51, 51, 51, 51, 0, 0, 51, 51, 0, 0,
+ 0, 0, 51, 0, 0, 0, 0, 0, 51, 0,
+ 51, 51, 51, 51, 51, 0, 51, 51, 51, 51,
+ 51, 51, 51, 51, 51, 0, 51, 0, 51, 51,
+ 51, 51, 51, 0, 0, 0, 0, 0, 0, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 14, 0,
+ 42, 42, 0, 0, 0, 0, 42, 0, 0, 0,
+ 0, 0, 42, 0, 42, 42, 42, 42, 42, 0,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 0,
+ 42, 0, 42, 42, 42, 42, 42, 0, 14, 0,
+ 0, 14, 0, 14, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 14, 0, 0,
+ 0, 0, 43, 43, 43, 43, 43, 43, 43, 43,
+ 43, 0, 0, 43, 43, 44, 0, 0, 0, 43,
+ 0, 0, 0, 0, 0, 43, 0, 43, 43, 43,
+ 43, 43, 0, 43, 43, 43, 43, 43, 43, 43,
+ 43, 43, 0, 43, 0, 43, 43, 43, 43, 43,
+ 0, 0, 44, 0, 0, 44, 44, 44, 44, 44,
+ 44, 14, 44, 0, 0, 0, 0, 0, 0, 45,
+ 0, 0, 0, 44, 44, 44, 0, 44, 44, 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, 45, 0, 44, 45,
+ 45, 45, 45, 45, 45, 0, 45, 0, 0, 0,
+ 0, 0, 0, 37, 0, 0, 0, 45, 45, 45,
+ 0, 45, 45, 0, 0, 0, 0, 0, 44, 44,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 37, 0, 45, 37, 37, 37, 37, 37, 37, 0,
+ 37, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 37, 37, 37, 0, 37, 37, 0, 0, 0,
+ 0, 0, 45, 45, 0, 14, 14, 14, 14, 14,
+ 14, 14, 14, 0, 0, 0, 14, 14, 0, 0,
+ 0, 0, 0, 0, 0, 0, 37, 37, 14, 0,
+ 14, 14, 14, 14, 14, 0, 0, 0, 0, 14,
+ 14, 14, 14, 0, 0, 37, 14, 0, 14, 14,
+ 14, 14, 14, 0, 0, 0, 37, 37, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 44, 44, 44, 44, 44, 44, 44, 44,
+ 44, 0, 0, 44, 44, 0, 0, 0, 0, 44,
+ 0, 66, 0, 0, 27, 44, 28, 44, 44, 44,
+ 44, 44, 0, 44, 44, 44, 44, 44, 44, 44,
+ 44, 44, 0, 44, 0, 44, 44, 44, 44, 44,
+ 0, 0, 0, 0, 0, 0, 45, 45, 45, 45,
+ 45, 45, 45, 45, 45, 0, 0, 45, 45, 0,
+ 0, 0, 0, 45, 0, 0, 0, 0, 0, 45,
+ 0, 45, 45, 45, 45, 45, 0, 45, 45, 45,
+ 45, 45, 45, 45, 45, 45, 0, 45, 0, 45,
+ 45, 45, 45, 45, 35, 0, 0, 27, 0, 28,
+ 37, 37, 37, 37, 37, 37, 37, 37, 37, 0,
+ 0, 37, 37, 36, 0, 0, 0, 37, 0, 0,
+ 0, 0, 0, 37, 0, 37, 37, 37, 37, 37,
+ 0, 0, 37, 37, 37, 37, 37, 37, 37, 37,
+ 0, 37, 0, 37, 0, 0, 37, 37, 0, 0,
+ 36, 0, 0, 36, 36, 36, 36, 36, 36, 0,
+ 36, 0, 0, 0, 0, 0, 0, 0, 40, 0,
+ 0, 36, 36, 36, 0, 36, 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, 36, 36, 40, 40,
+ 0, 40, 40, 40, 0, 0, 0, 0, 0, 41,
+ 0, 0, 0, 0, 0, 36, 40, 40, 40, 0,
+ 40, 40, 0, 0, 12, 13, 36, 36, 0, 14,
+ 15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 16, 0, 17, 18, 19, 0, 21, 0, 41,
+ 41, 40, 41, 41, 41, 0, 0, 33, 0, 26,
+ 0, 0, 30, 31, 32, 33, 0, 41, 41, 41,
+ 0, 41, 41, 0, 0, 0, 0, 0, 0, 0,
+ 0, 40, 40, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 33, 33, 0,
+ 0, 33, 41, 11, 0, 126, 127, 12, 13, 0,
+ 0, 15, 14, 15, 0, 33, 33, 33, 0, 33,
+ 33, 0, 0, 0, 16, 0, 17, 18, 19, 0,
+ 21, 0, 41, 41, 0, 22, 23, 24, 25, 0,
+ 0, 0, 26, 0, 29, 30, 31, 32, 33, 0,
+ 33, 15, 0, 0, 15, 0, 15, 0, 0, 0,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 7,
+ 15, 36, 36, 0, 0, 0, 0, 36, 0, 0,
+ 33, 33, 0, 36, 0, 36, 36, 36, 36, 36,
+ 0, 36, 0, 0, 36, 36, 36, 36, 36, 36,
+ 0, 36, 0, 36, 36, 36, 36, 36, 0, 7,
+ 0, 0, 7, 0, 7, 40, 40, 40, 40, 40,
+ 40, 40, 40, 40, 0, 0, 40, 40, 7, 0,
+ 0, 0, 40, 0, 15, 0, 0, 0, 40, 6,
+ 40, 40, 40, 40, 40, 0, 40, 40, 40, 40,
+ 40, 40, 40, 40, 40, 0, 40, 0, 40, 40,
+ 40, 40, 40, 0, 0, 0, 41, 41, 41, 41,
+ 41, 41, 41, 41, 41, 0, 0, 41, 41, 6,
+ 0, 0, 6, 41, 6, 0, 0, 0, 0, 41,
+ 0, 41, 41, 41, 41, 41, 0, 41, 41, 41,
+ 41, 41, 41, 41, 41, 41, 0, 41, 0, 41,
+ 41, 41, 41, 41, 33, 33, 33, 33, 33, 33,
+ 33, 33, 33, 34, 0, 33, 33, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 33, 0, 33,
+ 33, 33, 33, 33, 0, 33, 33, 33, 33, 33,
+ 33, 33, 33, 33, 0, 33, 0, 33, 33, 33,
+ 33, 33, 6, 34, 34, 0, 0, 34, 15, 15,
+ 15, 15, 15, 15, 15, 15, 0, 12, 0, 15,
+ 15, 34, 34, 34, 0, 34, 34, 0, 0, 0,
+ 0, 15, 0, 15, 15, 15, 15, 15, 0, 0,
+ 0, 0, 15, 15, 15, 15, 0, 0, 0, 15,
+ 0, 15, 15, 15, 15, 15, 34, 12, 0, 0,
+ 12, 0, 12, 0, 0, 0, 7, 7, 7, 7,
+ 7, 7, 7, 7, 5, 0, 12, 7, 7, 0,
+ 0, 0, 0, 0, 0, 0, 34, 34, 0, 7,
+ 0, 7, 7, 7, 7, 7, 0, 0, 0, 0,
+ 7, 7, 7, 7, 0, 0, 0, 7, 0, 7,
+ 7, 7, 7, 7, 5, 0, 0, 5, 0, 5,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 6, 6, 6, 0,
+ 12, 0, 6, 6, 0, 2, 0, 6, 6, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 6,
+ 0, 6, 6, 6, 6, 6, 0, 0, 0, 0,
+ 6, 6, 6, 6, 0, 0, 0, 6, 0, 6,
+ 6, 6, 6, 6, 0, 2, 0, 0, 2, 0,
+ 2, 0, 0, 0, 0, 0, 0, 5, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 34, 34, 34, 34, 34, 34, 34, 34, 34, 0,
+ 0, 34, 34, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 34, 0, 34, 34, 34, 34, 34,
+ 0, 34, 34, 34, 34, 34, 34, 34, 34, 34,
+ 0, 34, 0, 34, 34, 34, 34, 34, 2, 0,
+ 0, 0, 0, 0, 12, 12, 12, 12, 0, 12,
+ 12, 12, 0, 0, 0, 12, 12, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 12, 0, 12,
+ 12, 12, 12, 12, 0, 0, 0, 0, 12, 12,
+ 12, 12, 0, 0, 0, 12, 0, 12, 12, 12,
+ 12, 12, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 5, 5, 5, 0, 0, 0, 5, 5, 0,
+ 0, 0, 5, 5, 0, 0, 66, 237, 0, 27,
+ 238, 28, 0, 0, 5, 0, 5, 5, 5, 5,
+ 5, 0, 0, 0, 0, 5, 5, 5, 5, 86,
+ 0, 0, 5, 0, 5, 5, 5, 5, 5, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 66, 239, 0, 27, 240, 28, 0,
+ 0, 0, 2, 2, 2, 0, 0, 0, 2, 2,
+ 0, 0, 0, 2, 2, 58, 86, 0, 0, 0,
+ 0, 0, 0, 0, 0, 2, 0, 2, 2, 2,
+ 2, 2, 0, 0, 0, 0, 2, 2, 2, 2,
+ 0, 0, 0, 2, 0, 2, 2, 2, 2, 2,
+ 0, 0, 58, 0, 0, 58, 58, 58, 58, 58,
+ 58, 0, 58, 0, 0, 0, 0, 0, 0, 0,
+ 54, 0, 0, 58, 58, 58, 0, 58, 58, 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, 54, 58, 58,
+ 54, 54, 54, 54, 54, 54, 0, 54, 56, 0,
+ 0, 0, 0, 0, 0, 0, 0, 58, 54, 54,
+ 0, 0, 54, 54, 0, 0, 0, 0, 58, 58,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 56, 0, 0, 0, 56,
+ 56, 0, 56, 54, 54, 56, 0, 0, 0, 12,
+ 13, 0, 0, 0, 14, 15, 56, 56, 56, 0,
+ 56, 56, 54, 0, 0, 0, 16, 0, 17, 18,
+ 19, 0, 21, 54, 54, 0, 0, 22, 23, 24,
+ 25, 0, 0, 0, 26, 0, 0, 30, 31, 32,
+ 33, 56, 56, 0, 0, 0, 12, 13, 0, 0,
+ 0, 14, 15, 0, 0, 0, 0, 0, 0, 0,
+ 56, 0, 0, 16, 0, 17, 18, 19, 0, 21,
+ 0, 56, 56, 0, 22, 23, 24, 25, 0, 0,
+ 0, 26, 0, 0, 30, 31, 32, 33, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 58, 58, 58, 58, 58, 58, 58, 58,
+ 58, 0, 0, 58, 58, 0, 0, 0, 0, 58,
+ 0, 0, 0, 0, 0, 58, 0, 58, 58, 58,
+ 58, 58, 0, 58, 58, 58, 58, 0, 58, 58,
+ 58, 58, 0, 58, 0, 58, 58, 58, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 54, 54, 54,
+ 54, 54, 54, 54, 54, 54, 0, 0, 54, 54,
+ 0, 0, 0, 0, 54, 0, 0, 0, 0, 0,
+ 54, 0, 54, 54, 54, 54, 54, 29, 54, 54,
+ 54, 54, 0, 54, 54, 54, 54, 0, 54, 0,
+ 54, 54, 54, 0, 0, 56, 56, 56, 56, 56,
+ 56, 0, 0, 56, 0, 0, 0, 0, 0, 0,
+ 0, 0, 56, 0, 29, 0, 0, 0, 29, 29,
+ 0, 29, 25, 56, 29, 0, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 29, 29, 29, 56, 29,
+ 29, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 25,
+ 0, 0, 0, 25, 25, 0, 25, 27, 0, 25,
+ 29, 29, 0, 0, 0, 0, 0, 0, 0, 0,
+ 25, 25, 25, 0, 25, 25, 0, 0, 0, 29,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 29, 29, 0, 0, 27, 0, 0, 0, 27, 27,
+ 0, 27, 0, 0, 27, 25, 25, 0, 0, 0,
+ 0, 0, 0, 0, 0, 27, 27, 27, 0, 27,
+ 27, 0, 0, 0, 25, 0, 26, 0, 0, 0,
+ 0, 0, 0, 0, 0, 25, 25, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 27, 27, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 26, 0, 0, 0, 26, 26, 27,
+ 26, 0, 0, 26, 0, 0, 0, 0, 0, 0,
+ 27, 27, 0, 0, 26, 26, 26, 0, 26, 26,
+ 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, 26,
+ 26, 0, 0, 0, 29, 29, 29, 29, 29, 29,
+ 0, 0, 29, 0, 0, 0, 0, 0, 26, 0,
+ 0, 29, 0, 0, 0, 0, 0, 0, 0, 26,
+ 26, 0, 29, 0, 0, 29, 29, 29, 29, 29,
+ 29, 29, 29, 29, 0, 0, 0, 29, 0, 25,
+ 25, 25, 25, 25, 25, 0, 0, 25, 0, 0,
+ 0, 0, 0, 0, 0, 0, 25, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 25, 0, 0,
+ 25, 25, 25, 25, 25, 25, 25, 25, 25, 0,
+ 0, 0, 25, 0, 27, 27, 27, 27, 27, 27,
+ 0, 0, 27, 0, 0, 0, 0, 0, 0, 0,
+ 0, 27, 0, 0, 57, 0, 0, 0, 0, 0,
+ 0, 0, 27, 0, 0, 27, 27, 27, 27, 27,
+ 27, 27, 27, 27, 0, 0, 0, 27, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 57, 103, 104, 0, 57, 57, 0, 57, 0,
+ 0, 57, 0, 26, 26, 26, 26, 26, 26, 0,
+ 0, 26, 57, 57, 57, 0, 57, 57, 0, 0,
+ 26, 88, 0, 0, 0, 0, 134, 0, 136, 137,
+ 0, 26, 0, 0, 26, 26, 26, 26, 26, 26,
+ 26, 26, 26, 0, 0, 0, 26, 57, 57, 0,
+ 0, 0, 0, 0, 0, 0, 159, 160, 88, 0,
+ 0, 0, 88, 88, 0, 88, 57, 0, 88, 89,
+ 0, 0, 0, 0, 0, 0, 0, 57, 57, 88,
+ 88, 88, 0, 88, 88, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 89, 0, 0, 0,
+ 89, 89, 0, 89, 88, 88, 89, 0, 0, 214,
+ 0, 0, 0, 0, 0, 0, 0, 89, 89, 89,
+ 222, 89, 224, 88, 225, 0, 0, 0, 0, 0,
+ 0, 90, 0, 0, 88, 88, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 247, 0, 0, 0,
+ 0, 0, 89, 89, 0, 0, 0, 0, 0, 0,
+ 0, 264, 265, 266, 267, 268, 0, 0, 90, 0,
+ 0, 89, 90, 90, 0, 90, 0, 0, 90, 0,
+ 0, 0, 89, 89, 0, 0, 0, 0, 0, 90,
+ 90, 90, 0, 90, 0, 0, 0, 0, 0, 0,
+ 0, 57, 57, 57, 57, 57, 57, 0, 0, 57,
+ 292, 0, 0, 0, 294, 295, 296, 0, 57, 20,
+ 301, 0, 0, 0, 90, 90, 0, 0, 0, 57,
+ 0, 0, 57, 57, 57, 57, 57, 57, 57, 57,
+ 57, 0, 0, 90, 57, 314, 315, 0, 0, 0,
+ 0, 319, 0, 0, 90, 90, 20, 0, 0, 0,
+ 20, 20, 0, 20, 0, 0, 20, 0, 88, 88,
+ 88, 88, 88, 88, 0, 0, 88, 20, 20, 20,
+ 0, 20, 0, 0, 0, 88, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 88, 0, 0, 88,
+ 88, 88, 0, 0, 0, 0, 88, 88, 0, 0,
+ 0, 88, 20, 20, 0, 0, 89, 89, 89, 89,
+ 89, 89, 0, 0, 89, 0, 0, 0, 0, 66,
+ 156, 20, 27, 89, 28, 0, 0, 0, 0, 35,
+ 0, 0, 20, 20, 89, 0, 0, 89, 89, 89,
+ 0, 0, 86, 0, 89, 89, 0, 0, 0, 89,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 35, 0, 0, 0,
+ 35, 35, 0, 35, 0, 0, 35, 0, 90, 90,
+ 90, 90, 90, 90, 0, 0, 90, 35, 35, 35,
+ 0, 35, 0, 0, 0, 90, 86, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 90, 0, 0, 90,
+ 90, 90, 0, 0, 0, 0, 90, 90, 0, 0,
+ 0, 90, 35, 35, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 86, 0, 0, 0, 86, 86, 0,
+ 0, 35, 0, 86, 16, 0, 0, 0, 0, 0,
+ 0, 0, 35, 35, 86, 86, 86, 0, 86, 0,
+ 0, 0, 0, 0, 0, 0, 20, 20, 20, 20,
+ 20, 20, 0, 0, 20, 0, 0, 0, 0, 0,
+ 0, 16, 0, 20, 0, 16, 16, 0, 16, 86,
+ 86, 16, 0, 0, 20, 0, 0, 20, 20, 20,
+ 0, 0, 16, 16, 20, 20, 0, 0, 86, 20,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 86,
+ 86, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 16, 16, 0,
+ 0, 0, 12, 13, 0, 0, 0, 14, 15, 0,
+ 0, 0, 0, 0, 0, 0, 16, 0, 0, 16,
+ 0, 17, 18, 19, 0, 21, 0, 16, 16, 0,
+ 22, 23, 24, 25, 0, 0, 0, 26, 0, 0,
+ 30, 31, 32, 33, 0, 0, 35, 35, 35, 35,
+ 35, 35, 0, 0, 35, 0, 0, 0, 0, 0,
+ 0, 0, 0, 35, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 35, 0, 0, 35, 35, 35,
+ 0, 0, 0, 0, 35, 35, 0, 0, 0, 35,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 86, 86, 86, 86, 86, 86, 0,
+ 0, 86, 0, 0, 0, 0, 0, 0, 0, 0,
+ 86, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 86, 0, 0, 86, 86, 86, 0, 0, 0,
+ 0, 86, 86, 0, 0, 0, 86, 0, 0, 0,
+ 0, 16, 16, 16, 16, 16, 16, 0, 41, 16,
+ 0, 0, 0, 0, 0, 53, 0, 0, 16, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 16,
+ 41, 0, 16, 16, 16, 0, 41, 0, 0, 0,
+ 0, 0, 0, 0, 16, 0, 0, 0, 0, 0,
+ 106, 53, 109, 0, 0, 0, 113, 114, 0, 117,
+ 119, 120, 0, 53, 53, 124, 125, 41, 0, 0,
+ 0, 0, 0, 0, 0, 66, 0, 0, 27, 0,
+ 28, 0, 0, 135, 0, 0, 41, 139, 141, 142,
+ 143, 144, 0, 0, 189, 0, 0, 0, 0, 0,
+ 0, 41, 0, 0, 0, 0, 0, 0, 0, 109,
+ 0, 0, 0, 0, 0, 0, 162, 0, 0, 0,
+ 110, 0, 53, 110, 0, 110, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 41, 41, 110,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 187, 0,
+ 202, 203, 0, 0, 205, 206, 207, 208, 210, 0,
+ 0, 0, 0, 212, 213, 109, 53, 53, 109, 0,
+ 109, 220, 0, 0, 0, 221, 0, 0, 0, 0,
+ 0, 0, 0, 0, 109, 0, 232, 0, 0, 233,
+ 0, 0, 0, 110, 0, 110, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 41, 41,
+ 258, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 270, 0, 271,
+ 0, 272, 0, 273, 0, 274, 0, 0, 0, 103,
+ 276, 0, 103, 0, 103, 277, 278, 0, 109, 0,
+ 109, 0, 0, 53, 0, 0, 0, 0, 103, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 41, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 174, 126, 127, 12, 13,
+ 41, 175, 176, 14, 15, 177, 0, 178, 179, 0,
+ 180, 181, 182, 183, 184, 16, 185, 17, 18, 19,
+ 0, 21, 186, 0, 0, 0, 22, 23, 24, 25,
+ 0, 0, 103, 26, 103, 0, 30, 31, 32, 33,
+ 110, 0, 0, 110, 110, 0, 110, 110, 110, 110,
+ 110, 110, 110, 110, 0, 110, 110, 110, 110, 110,
+ 110, 110, 110, 110, 110, 0, 110, 110, 0, 0,
+ 0, 110, 110, 110, 110, 0, 0, 0, 110, 0,
+ 0, 110, 110, 110, 110, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 109, 0, 0, 109, 109,
+ 0, 109, 109, 109, 109, 109, 109, 109, 109, 0,
+ 109, 109, 109, 109, 109, 109, 109, 109, 109, 109,
+ 0, 109, 109, 0, 0, 0, 109, 109, 109, 109,
+ 0, 0, 0, 109, 0, 0, 109, 109, 109, 109,
+ 104, 0, 0, 104, 0, 104, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 104,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 103,
+ 0, 0, 103, 103, 0, 103, 103, 103, 103, 103,
+ 103, 103, 103, 0, 103, 103, 103, 103, 103, 103,
+ 103, 103, 103, 103, 0, 103, 103, 0, 0, 0,
+ 103, 103, 103, 103, 0, 0, 0, 103, 0, 0,
+ 103, 103, 103, 103, 105, 0, 0, 105, 0, 105,
+ 0, 0, 0, 104, 0, 104, 0, 0, 0, 0,
+ 0, 0, 0, 105, 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, 102,
+ 0, 0, 102, 0, 102, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 102, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 105, 0, 105,
+ 0, 0, 0, 0, 0, 108, 0, 0, 108, 0,
+ 108, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 108, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 102, 0, 102, 0, 0, 0, 66, 105,
+ 0, 27, 0, 28, 0, 0, 0, 0, 0, 0,
+ 104, 0, 0, 104, 104, 0, 104, 104, 104, 104,
+ 104, 104, 104, 104, 0, 104, 104, 104, 104, 104,
+ 104, 104, 104, 104, 104, 0, 104, 104, 108, 0,
+ 108, 104, 104, 104, 104, 0, 0, 0, 104, 0,
+ 0, 104, 104, 104, 104, 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, 105, 0, 0, 105, 105, 0,
+ 105, 105, 105, 105, 105, 105, 105, 105, 0, 105,
+ 105, 105, 105, 105, 105, 105, 105, 105, 105, 0,
+ 105, 105, 0, 0, 0, 105, 105, 105, 105, 0,
+ 0, 0, 105, 0, 0, 105, 105, 105, 105, 102,
+ 0, 0, 102, 102, 0, 102, 102, 102, 102, 102,
+ 102, 102, 102, 0, 102, 102, 102, 102, 102, 102,
+ 102, 102, 102, 102, 35, 102, 102, 27, 0, 28,
+ 102, 102, 102, 102, 0, 0, 0, 102, 0, 0,
+ 102, 102, 102, 102, 0, 108, 0, 0, 108, 108,
+ 0, 108, 108, 108, 108, 108, 108, 108, 108, 0,
+ 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
+ 0, 108, 108, 0, 0, 0, 108, 108, 108, 108,
+ 0, 0, 0, 108, 0, 0, 108, 108, 108, 108,
+ 137, 12, 13, 137, 0, 137, 14, 15, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 34, 16, 137,
+ 17, 18, 19, 0, 21, 0, 0, 0, 0, 22,
+ 23, 24, 25, 0, 0, 0, 26, 0, 0, 30,
+ 31, 32, 33, 0, 0, 66, 0, 0, 27, 0,
+ 28, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 189, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 137, 0, 137, 0, 0, 0, 0,
+ 66, 0, 0, 27, 0, 28, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 189,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 187, 0,
+ 188, 0, 0, 0, 0, 0, 66, 0, 0, 27,
+ 0, 28, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 9, 10, 11, 0, 189, 0, 12, 13, 0,
+ 0, 0, 14, 15, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 187, 16, 200, 17, 18, 19, 20,
+ 21, 0, 0, 0, 0, 22, 23, 24, 25, 0,
+ 0, 0, 26, 0, 29, 30, 31, 32, 33, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 35, 0, 0, 27, 0, 28, 0, 0, 0, 187,
+ 137, 201, 0, 137, 137, 0, 137, 137, 137, 137,
+ 137, 137, 137, 137, 0, 137, 137, 137, 137, 137,
+ 137, 137, 137, 137, 137, 0, 137, 137, 0, 0,
+ 0, 137, 137, 137, 137, 0, 0, 0, 137, 0,
+ 0, 137, 137, 137, 137, 174, 0, 0, 12, 13,
+ 0, 175, 176, 14, 15, 177, 0, 178, 179, 0,
+ 180, 181, 182, 183, 184, 16, 185, 17, 18, 19,
+ 0, 21, 186, 0, 0, 0, 22, 23, 24, 25,
+ 0, 0, 0, 26, 0, 0, 30, 31, 32, 33,
+ 174, 0, 0, 12, 13, 0, 175, 176, 14, 15,
+ 177, 0, 178, 179, 0, 180, 181, 182, 183, 184,
+ 16, 185, 17, 18, 19, 0, 21, 186, 0, 0,
+ 0, 22, 23, 24, 25, 0, 0, 0, 26, 0,
+ 0, 30, 31, 32, 33, 0, 174, 0, 0, 12,
+ 13, 0, 175, 176, 14, 15, 177, 0, 178, 179,
+ 0, 180, 181, 182, 183, 184, 16, 185, 17, 18,
+ 19, 0, 21, 186, 0, 0, 0, 22, 23, 24,
+ 25, 0, 0, 0, 26, 0, 0, 30, 31, 32,
+ 33, 66, 0, 0, 27, 0, 28, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 189, 0, 0, 0, 0, 0, 0, 0, 0, 11,
+ 0, 0, 0, 12, 13, 0, 0, 0, 14, 15,
+ 0, 0, 0, 0, 0, 0, 66, 0, 0, 27,
+ 16, 28, 17, 18, 19, 0, 21, 0, 0, 0,
+ 0, 22, 23, 24, 25, 189, 0, 0, 26, 0,
+ 29, 30, 31, 32, 33, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 187, 0, 231, 0, 0, 0,
+ 0, 66, 0, 0, 27, 0, 28, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 189, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 187,
+ 0, 285, 0, 0, 0, 0, 0, 107, 0, 0,
+ 107, 0, 107, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 107, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 187, 0, 309, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 66, 0, 0,
+ 27, 0, 28, 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,
+ 107, 174, 107, 0, 12, 13, 0, 175, 176, 14,
+ 15, 177, 0, 178, 179, 0, 180, 181, 182, 183,
+ 184, 16, 185, 17, 18, 19, 0, 21, 186, 0,
+ 0, 0, 22, 23, 24, 25, 0, 0, 0, 26,
+ 0, 0, 30, 31, 32, 33, 174, 0, 0, 12,
+ 13, 0, 175, 176, 14, 15, 177, 0, 178, 179,
+ 0, 180, 181, 182, 183, 184, 16, 185, 17, 18,
+ 19, 0, 21, 186, 0, 0, 0, 22, 23, 24,
+ 25, 0, 0, 0, 26, 0, 0, 30, 31, 32,
+ 33, 174, 0, 0, 12, 13, 0, 175, 176, 14,
+ 15, 177, 0, 178, 179, 0, 180, 181, 182, 183,
+ 184, 16, 185, 17, 18, 19, 66, 21, 186, 27,
+ 111, 28, 22, 23, 24, 25, 0, 0, 0, 26,
+ 0, 0, 30, 31, 32, 33, 89, 107, 90, 86,
+ 107, 107, 0, 107, 107, 107, 107, 107, 0, 107,
+ 107, 0, 107, 107, 107, 107, 107, 107, 107, 107,
+ 107, 107, 0, 107, 107, 0, 0, 0, 107, 107,
+ 107, 107, 0, 0, 0, 107, 0, 0, 107, 107,
+ 107, 107, 130, 0, 0, 130, 0, 130, 0, 0,
+ 12, 13, 0, 175, 176, 14, 15, 0, 0, 0,
+ 0, 130, 180, 181, 182, 183, 184, 16, 0, 17,
+ 18, 19, 0, 21, 186, 0, 0, 0, 22, 23,
+ 24, 25, 0, 0, 0, 26, 0, 0, 30, 31,
+ 32, 33, 66, 0, 0, 27, 0, 28, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 89, 0, 90, 86, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 130, 0, 130, 0, 0,
+ 0, 0, 0, 0, 66, 241, 0, 27, 242, 28,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 86, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 66, 243,
+ 0, 27, 244, 28, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 12,
+ 13, 86, 0, 0, 14, 15, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 16, 0, 17, 18,
+ 19, 0, 21, 0, 0, 0, 0, 22, 23, 24,
+ 25, 87, 88, 0, 26, 0, 0, 30, 31, 32,
+ 33, 66, 248, 0, 27, 249, 28, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 130, 0, 86, 130, 130, 0, 130, 130,
+ 130, 130, 130, 0, 130, 130, 0, 130, 130, 130,
+ 130, 130, 130, 130, 130, 130, 130, 0, 130, 130,
+ 0, 0, 0, 130, 130, 130, 130, 0, 0, 0,
+ 130, 0, 0, 130, 130, 130, 130, 35, 0, 0,
+ 27, 0, 28, 0, 0, 12, 13, 0, 0, 0,
+ 14, 15, 0, 0, 0, 0, 297, 0, 0, 0,
+ 0, 0, 16, 0, 17, 18, 19, 0, 21, 0,
+ 0, 0, 0, 22, 23, 24, 25, 87, 88, 0,
+ 26, 0, 0, 30, 31, 32, 33, 12, 13, 0,
+ 0, 108, 14, 15, 27, 0, 28, 0, 0, 0,
+ 0, 0, 0, 0, 16, 0, 17, 18, 19, 0,
+ 21, 0, 0, 0, 0, 22, 23, 24, 25, 0,
+ 0, 0, 26, 0, 0, 30, 31, 32, 33, 0,
+ 0, 12, 13, 0, 0, 66, 14, 15, 27, 111,
+ 28, 0, 0, 0, 0, 0, 0, 0, 16, 0,
+ 17, 18, 19, 0, 21, 0, 0, 0, 86, 22,
+ 23, 24, 25, 0, 0, 0, 26, 0, 0, 30,
+ 31, 32, 33, 0, 0, 0, 0, 0, 66, 0,
+ 0, 27, 161, 28, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 12, 13, 0, 0, 0, 14,
+ 15, 86, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 16, 0, 17, 18, 19, 0, 21, 0, 0,
+ 0, 0, 22, 23, 24, 25, 0, 0, 0, 26,
+ 0, 0, 30, 31, 32, 33, 66, 0, 0, 27,
+ 164, 28, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 11, 0, 0, 86,
+ 12, 13, 0, 0, 0, 14, 15, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 16, 0, 17,
+ 18, 19, 66, 21, 0, 27, 166, 28, 22, 23,
+ 24, 25, 0, 0, 0, 26, 0, 29, 30, 31,
+ 32, 33, 0, 0, 0, 86, 0, 0, 0, 0,
+ 11, 0, 0, 0, 12, 13, 0, 0, 0, 14,
+ 15, 0, 0, 0, 66, 0, 0, 27, 167, 28,
+ 0, 16, 0, 17, 18, 19, 0, 21, 0, 0,
+ 0, 0, 22, 23, 24, 25, 0, 86, 0, 26,
+ 0, 29, 30, 31, 32, 33, 0, 0, 12, 13,
+ 0, 0, 0, 14, 15, 0, 0, 66, 0, 0,
+ 27, 172, 28, 0, 0, 16, 0, 17, 18, 19,
+ 0, 21, 0, 0, 0, 0, 22, 23, 24, 25,
+ 86, 0, 0, 26, 0, 0, 30, 31, 32, 33,
+ 0, 12, 13, 0, 0, 0, 14, 15, 0, 0,
+ 66, 0, 0, 27, 173, 28, 0, 0, 16, 0,
+ 17, 18, 19, 0, 21, 0, 0, 0, 0, 22,
+ 23, 24, 25, 86, 0, 0, 26, 0, 0, 30,
+ 31, 32, 33, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 66, 0, 0, 27, 0, 28, 0, 12,
+ 13, 0, 0, 0, 14, 15, 0, 0, 0, 0,
+ 195, 0, 0, 0, 0, 86, 16, 0, 17, 18,
+ 19, 0, 21, 0, 0, 0, 0, 22, 23, 24,
+ 25, 0, 0, 0, 26, 0, 0, 30, 31, 32,
+ 33, 0, 0, 0, 0, 12, 13, 0, 0, 66,
+ 14, 15, 27, 0, 28, 0, 0, 0, 0, 0,
+ 0, 0, 16, 0, 17, 18, 19, 198, 21, 0,
+ 0, 0, 86, 22, 23, 24, 25, 0, 0, 0,
+ 26, 0, 0, 30, 31, 32, 33, 12, 13, 0,
+ 0, 0, 14, 15, 66, 0, 0, 27, 0, 28,
+ 0, 0, 0, 0, 16, 0, 17, 18, 19, 0,
+ 21, 0, 0, 0, 0, 22, 23, 24, 25, 0,
+ 0, 0, 26, 0, 0, 30, 31, 32, 33, 0,
+ 12, 13, 0, 0, 0, 14, 15, 0, 0, 66,
+ 246, 0, 27, 0, 28, 0, 0, 16, 0, 17,
+ 18, 19, 0, 21, 0, 0, 0, 0, 22, 23,
+ 24, 25, 86, 0, 0, 26, 0, 0, 30, 31,
+ 32, 33, 0, 12, 13, 0, 0, 0, 14, 15,
+ 0, 0, 66, 250, 0, 27, 0, 28, 0, 0,
+ 16, 0, 17, 18, 19, 0, 21, 0, 0, 0,
+ 0, 22, 23, 24, 25, 86, 0, 0, 26, 0,
+ 0, 30, 31, 32, 33, 12, 13, 0, 0, 0,
+ 14, 15, 0, 0, 66, 281, 0, 27, 0, 28,
+ 0, 0, 16, 0, 17, 18, 19, 0, 21, 0,
+ 0, 0, 0, 22, 23, 24, 25, 86, 0, 0,
+ 26, 0, 0, 30, 31, 32, 33, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 12, 13, 0, 0, 0, 14, 15, 0,
+ 0, 66, 287, 0, 27, 0, 28, 0, 0, 16,
+ 0, 17, 18, 19, 0, 21, 0, 0, 0, 0,
+ 22, 23, 24, 25, 86, 0, 0, 26, 0, 0,
+ 30, 31, 32, 33, 0, 126, 127, 12, 13, 0,
+ 0, 0, 14, 15, 0, 0, 66, 288, 0, 27,
+ 0, 28, 0, 0, 16, 0, 17, 18, 19, 0,
+ 21, 0, 0, 0, 0, 22, 23, 24, 25, 86,
+ 0, 0, 26, 0, 0, 30, 31, 32, 33, 0,
+ 0, 0, 12, 13, 0, 0, 0, 14, 15, 0,
+ 0, 66, 289, 0, 27, 0, 28, 0, 0, 16,
+ 0, 17, 18, 19, 0, 21, 0, 0, 0, 0,
+ 22, 23, 24, 25, 86, 0, 0, 26, 0, 0,
+ 30, 31, 32, 33, 0, 12, 13, 0, 0, 0,
+ 14, 15, 0, 0, 66, 290, 0, 27, 0, 28,
+ 0, 0, 16, 0, 17, 18, 19, 0, 21, 0,
+ 0, 0, 0, 22, 23, 24, 25, 86, 0, 0,
+ 26, 0, 0, 30, 31, 32, 33, 12, 13, 0,
+ 0, 0, 14, 15, 0, 0, 66, 291, 0, 27,
+ 0, 28, 0, 0, 16, 0, 17, 18, 19, 0,
+ 21, 0, 0, 0, 0, 22, 23, 24, 25, 86,
+ 0, 0, 26, 0, 0, 30, 31, 32, 33, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 12, 13, 0, 0, 0, 14,
+ 15, 0, 0, 66, 293, 0, 27, 0, 28, 0,
+ 0, 16, 0, 17, 18, 19, 0, 21, 0, 0,
+ 0, 0, 22, 23, 24, 25, 86, 0, 0, 26,
+ 0, 0, 30, 31, 32, 33, 0, 0, 0, 12,
+ 13, 0, 0, 0, 14, 15, 0, 0, 0, 66,
+ 0, 0, 27, 0, 28, 0, 16, 0, 17, 18,
+ 19, 0, 21, 0, 0, 0, 0, 22, 23, 24,
+ 25, 0, 0, 0, 26, 0, 0, 30, 31, 32,
+ 33, 0, 0, 0, 12, 13, 0, 0, 0, 14,
+ 15, 0, 0, 0, 0, 66, 0, 0, 27, 0,
+ 28, 16, 0, 17, 18, 19, 0, 21, 0, 0,
+ 0, 0, 22, 23, 24, 25, 0, 0, 0, 26,
+ 0, 0, 30, 31, 32, 33, 0, 12, 13, 0,
+ 0, 0, 14, 15, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 16, 0, 17, 18, 19, 66,
+ 21, 0, 27, 0, 28, 22, 23, 24, 25, 0,
+ 0, 0, 26, 0, 0, 30, 31, 32, 33, 12,
+ 13, 0, 0, 0, 14, 15, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 16, 0, 17, 18,
+ 19, 0, 21, 0, 0, 0, 0, 22, 23, 24,
+ 25, 0, 0, 0, 26, 0, 0, 30, 31, 32,
+ 33, 66, 0, 0, 27, 0, 28, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 12, 13, 0, 0,
+ 0, 14, 15, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 16, 0, 17, 18, 19, 0, 21,
+ 0, 0, 0, 0, 22, 23, 24, 25, 0, 0,
+ 0, 26, 0, 0, 30, 31, 32, 33, 116, 0,
+ 0, 66, 12, 13, 27, 0, 28, 14, 15, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 16,
+ 0, 17, 18, 19, 86, 21, 0, 0, 0, 0,
+ 22, 23, 24, 25, 0, 0, 0, 26, 0, 0,
+ 30, 31, 32, 33, 118, 0, 0, 66, 12, 13,
+ 27, 0, 28, 14, 15, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 16, 0, 17, 18, 19,
+ 0, 21, 0, 0, 0, 0, 22, 23, 24, 25,
+ 0, 0, 0, 26, 0, 0, 30, 31, 32, 33,
+ 51, 0, 0, 27, 0, 28, 0, 0, 140, 0,
+ 0, 0, 12, 13, 0, 0, 0, 14, 15, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 16,
+ 0, 17, 18, 19, 0, 21, 0, 0, 0, 0,
+ 22, 23, 24, 25, 0, 0, 0, 26, 0, 0,
+ 30, 31, 32, 33, 66, 0, 0, 27, 0, 28,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 209, 0, 0, 0, 12, 13, 0, 0, 0, 14,
+ 15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 16, 0, 17, 18, 19, 0, 21, 0, 0,
+ 0, 0, 22, 23, 24, 25, 0, 0, 0, 26,
+ 0, 0, 30, 31, 32, 33, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 12, 13, 0, 0, 0, 14,
+ 15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 16, 0, 17, 18, 19, 0, 21, 0, 0,
+ 0, 0, 22, 23, 24, 25, 0, 0, 0, 26,
+ 0, 0, 30, 31, 32, 33, 269, 0, 0, 0,
+ 12, 13, 0, 0, 0, 14, 15, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 16, 0, 17,
+ 18, 19, 0, 21, 0, 0, 0, 0, 22, 23,
+ 24, 25, 0, 0, 0, 26, 0, 0, 30, 31,
+ 32, 33, 0, 12, 13, 0, 0, 0, 14, 15,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 16, 0, 17, 18, 19, 0, 21, 0, 0, 0,
+ 0, 22, 23, 24, 25, 57, 0, 0, 26, 0,
+ 0, 30, 31, 32, 33, 0, 68, 68, 0, 71,
+ 72, 0, 68, 0, 0, 0, 0, 12, 13, 0,
+ 68, 0, 14, 15, 0, 0, 0, 0, 0, 0,
+ 0, 0, 68, 0, 16, 0, 17, 18, 19, 0,
+ 21, 0, 0, 0, 0, 22, 23, 24, 25, 0,
+ 0, 0, 26, 0, 0, 30, 31, 32, 33, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 68, 68, 68, 68, 68, 68, 0, 0,
+ 0, 0, 0, 0, 0, 68, 0, 0, 68, 0,
+ 0, 0, 68, 68, 0, 0, 68, 0, 68, 68,
+ 0, 0, 0, 68, 68, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 68, 0, 0, 0, 68, 0,
+ 68, 68, 68, 68, 0, 0, 0, 0, 0, 0,
+ 0, 199, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 68, 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, 68,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 68, 68, 0, 68, 68, 68, 68, 0, 68,
+ 0, 68, 68, 0, 0, 67, 69, 0, 0, 68,
+ 68, 73, 0, 0, 0, 0, 0, 0, 0, 91,
+ 0, 68, 68, 0, 0, 0, 0, 0, 0, 0,
+ 0, 91, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 68, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 68,
+ 68, 68, 68, 68, 0, 68, 68, 68, 0, 0,
+ 0, 146, 147, 148, 149, 150, 151, 0, 0, 0,
+ 0, 0, 0, 0, 91, 0, 0, 91, 0, 0,
+ 0, 91, 91, 0, 0, 91, 0, 91, 91, 0,
+ 0, 0, 91, 91, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 91, 0, 0, 0, 91, 0, 91,
+ 91, 91, 91, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 91, 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, 91, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 91, 91, 0, 91, 91, 91, 91, 0, 91, 0,
+ 91, 91, 0, 0, 0, 0, 0, 0, 91, 91,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 91, 91, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 91, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 91, 91,
+ 91, 91, 91, 0, 91, 91, 91,
+};
+short yycheck[] = { 41,
+ 0, 41, 63, 41, 37, 41, 41, 59, 59, 42,
+ 43, 63, 45, 63, 47, 35, 63, 219, 41, 63,
+ 50, 63, 38, 63, 59, 63, 123, 63, 62, 37,
+ 44, 123, 62, 63, 42, 103, 104, 37, 35, 47,
+ 40, 41, 42, 43, 44, 45, 51, 47, 35, 63,
+ 41, 94, 41, 44, 288, 0, 301, 302, 58, 59,
+ 60, 94, 62, 63, 297, 60, 134, 301, 302, 112,
+ 59, 292, 41, 40, 307, 44, 59, 261, 262, 112,
+ 40, 40, 303, 304, 123, 40, 94, 40, 108, 40,
+ 124, 121, 37, 93, 94, 297, 41, 42, 43, 44,
+ 45, 286, 47, 108, 112, 307, 91, 41, 222, 40,
+ 0, 108, 112, 58, 59, 60, 40, 62, 63, 40,
+ 261, 108, 44, 123, 124, 59, 40, 123, 62, 41,
+ 60, 112, 41, 41, 292, 280, 41, 44, 44, 41,
+ 292, 41, 41, 93, 41, 175, 176, 37, 93, 94,
+ 40, 41, 42, 43, 40, 45, 224, 47, 40, 59,
+ 40, 292, 59, 290, 261, 262, 41, 112, 58, 59,
+ 60, 91, 62, 63, 59, 41, 272, 7, 123, 124,
+ 294, 295, 296, 40, 200, 271, 41, 41, 0, 93,
+ 124, 41, 93, 41, 59, 59, -1, 216, -1, 29,
+ 314, 315, -1, 93, 94, 319, -1, -1, -1, 260,
+ 261, 262, 41, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 112, -1, 292, 260, 261, 262, 289, 290,
+ 59, 265, 262, 123, 124, -1, -1, 289, 290, 289,
+ 290, 274, 289, 290, -1, 289, 290, 289, 290, 289,
+ 290, 289, 290, 289, 290, 85, -1, 257, 258, 259,
+ 260, 261, 262, 263, 264, 265, 289, 290, 268, 269,
+ 100, 260, 261, 262, 274, 289, 290, 260, 261, 262,
+ 280, 41, 282, 283, 284, 285, 286, 41, 288, 289,
+ 290, 291, 292, 293, 294, 295, 296, 292, 298, 59,
+ 300, 301, 302, 303, 304, 59, 136, 137, 303, 304,
+ -1, -1, 257, 258, 259, 260, 261, 262, 263, 264,
+ 265, -1, -1, 268, 269, -1, 260, 261, 262, 274,
+ -1, 265, -1, -1, -1, 280, 41, 282, 283, 284,
+ 285, 286, -1, 288, 289, 290, 291, 292, 293, 294,
+ 295, 296, -1, 298, 59, 300, 301, 302, 303, 304,
+ 260, 261, 262, 260, 261, 262, -1, 257, 258, 259,
+ 260, 261, 262, 263, 264, 265, -1, -1, 268, 269,
+ 0, -1, -1, -1, 274, -1, -1, 217, 218, -1,
+ 280, -1, 282, 283, 284, 285, 286, 41, 288, 289,
+ 290, 291, 292, 293, 294, 295, 296, -1, 298, -1,
+ 300, 301, 302, 303, 304, 59, -1, 37, -1, -1,
+ 40, 41, 42, 43, 44, 45, -1, 47, -1, -1,
+ -1, 260, 261, 262, -1, 0, -1, -1, 58, 59,
+ -1, -1, 62, 63, -1, -1, -1, -1, -1, -1,
+ -1, -1, 282, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 299,
+ -1, -1, 37, 93, 94, 40, 41, 42, 43, 44,
+ 45, -1, 47, -1, -1, -1, -1, -1, -1, -1,
+ 0, -1, 112, 58, 59, 60, -1, 62, 63, -1,
+ 260, 261, 262, 123, 124, -1, 260, 261, 262, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 37, 93, 94,
+ 40, 41, 42, 43, 44, 45, -1, 47, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 58, 59,
+ 60, -1, 62, 63, -1, 260, 261, 262, 123, 124,
+ -1, -1, -1, 0, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 93, 94, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 37, -1, 112, 40, 41, 42, 43, 44, 45, -1,
+ 47, -1, -1, 123, 124, -1, 260, 261, 262, -1,
+ -1, 58, 59, 60, -1, 62, 63, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 257, 258, 259,
+ 260, 261, 262, 263, 264, 265, -1, -1, 268, 269,
+ -1, -1, -1, -1, 274, -1, 93, -1, -1, -1,
+ 280, -1, 282, 283, 284, 285, 286, -1, 288, 289,
+ 290, 291, 292, 293, 294, 295, 296, -1, 298, -1,
+ 300, 301, 302, 303, 304, -1, 123, 124, -1, -1,
+ -1, -1, 257, 258, 259, 260, 261, 262, 263, 264,
+ 265, -1, -1, 268, 269, -1, -1, -1, -1, 274,
+ -1, -1, -1, -1, -1, 280, -1, 282, 283, 284,
+ 285, 286, -1, 288, 289, 290, 291, 292, 293, 294,
+ 295, 296, -1, 298, -1, 300, 301, 302, 303, 304,
+ -1, -1, -1, -1, -1, -1, -1, 257, 258, 259,
+ 260, 261, 262, 263, 264, 265, -1, -1, 268, 269,
+ -1, -1, -1, -1, 274, -1, -1, -1, -1, -1,
+ 280, -1, 282, 283, 284, 285, 286, -1, 288, 289,
+ -1, 291, 292, 293, 294, 295, 296, -1, 298, -1,
+ 300, 301, 302, 303, 304, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 257, 258, 259, 260, 261, 262, 263, 264, 265, -1,
+ -1, 268, 269, 0, -1, -1, -1, 274, -1, -1,
+ -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
+ -1, 288, 289, 290, 291, 292, 293, 294, 295, 296,
+ -1, 298, -1, 300, 301, 302, 303, 304, -1, -1,
+ 37, -1, -1, 40, 41, 42, 43, 44, 45, -1,
+ 47, -1, -1, -1, -1, -1, -1, -1, 0, -1,
+ -1, 58, 59, 60, -1, 62, 63, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 37, 93, 94, 40, 41,
+ 42, 43, 44, 45, -1, 47, -1, -1, -1, -1,
+ -1, -1, 0, -1, -1, 112, 58, 59, 60, -1,
+ 62, 63, -1, -1, -1, -1, 123, 124, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 37,
+ -1, 93, 40, 41, 42, 43, 44, 45, -1, 47,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 58, 59, 60, -1, 62, 63, -1, -1, -1, -1,
+ -1, 123, 124, -1, -1, 0, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 93, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 37, -1, -1, 40, 41, 42, 43, 44,
+ 45, -1, 47, -1, -1, 123, 124, -1, -1, -1,
+ -1, -1, -1, 58, 59, 60, -1, 62, 63, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 257, 258, 259, 260, 261, 262, 263, 264, 265, -1,
+ -1, 268, 269, -1, -1, -1, -1, 274, 93, -1,
+ -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
+ -1, 288, 289, 290, 291, 292, 293, 294, 295, 296,
+ -1, 298, -1, 300, -1, -1, 303, 304, 123, 124,
+ -1, -1, -1, -1, -1, 257, 258, 259, 260, 261,
+ 262, 263, 264, 265, -1, -1, 268, 269, -1, -1,
+ -1, -1, 274, -1, -1, -1, -1, -1, 280, -1,
+ 282, 283, 284, 285, 286, -1, 288, 289, 290, 291,
+ 292, 293, 294, 295, 296, -1, 298, -1, 300, 301,
+ 302, 303, 304, -1, -1, -1, -1, -1, -1, 257,
+ 258, 259, 260, 261, 262, 263, 264, 265, 0, -1,
+ 268, 269, -1, -1, -1, -1, 274, -1, -1, -1,
+ -1, -1, 280, -1, 282, 283, 284, 285, 286, -1,
+ 288, 289, 290, 291, 292, 293, 294, 295, 296, -1,
+ 298, -1, 300, 301, 302, 303, 304, -1, 40, -1,
+ -1, 43, -1, 45, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 59, -1, -1,
+ -1, -1, 257, 258, 259, 260, 261, 262, 263, 264,
+ 265, -1, -1, 268, 269, 0, -1, -1, -1, 274,
+ -1, -1, -1, -1, -1, 280, -1, 282, 283, 284,
+ 285, 286, -1, 288, 289, 290, 291, 292, 293, 294,
+ 295, 296, -1, 298, -1, 300, 301, 302, 303, 304,
+ -1, -1, 37, -1, -1, 40, 41, 42, 43, 44,
+ 45, 123, 47, -1, -1, -1, -1, -1, -1, 0,
+ -1, -1, -1, 58, 59, 60, -1, 62, 63, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 37, -1, 93, 40,
+ 41, 42, 43, 44, 45, -1, 47, -1, -1, -1,
+ -1, -1, -1, 0, -1, -1, -1, 58, 59, 60,
+ -1, 62, 63, -1, -1, -1, -1, -1, 123, 124,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 37, -1, 93, 40, 41, 42, 43, 44, 45, -1,
+ 47, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 58, 59, 60, -1, 62, 63, -1, -1, -1,
+ -1, -1, 123, 124, -1, 257, 258, 259, 260, 261,
+ 262, 263, 264, -1, -1, -1, 268, 269, -1, -1,
+ -1, -1, -1, -1, -1, -1, 93, 94, 280, -1,
+ 282, 283, 284, 285, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, -1, -1, 112, 298, -1, 300, 301,
+ 302, 303, 304, -1, -1, -1, 123, 124, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 257, 258, 259, 260, 261, 262, 263, 264,
+ 265, -1, -1, 268, 269, -1, -1, -1, -1, 274,
+ -1, 40, -1, -1, 43, 280, 45, 282, 283, 284,
+ 285, 286, -1, 288, 289, 290, 291, 292, 293, 294,
+ 295, 296, -1, 298, -1, 300, 301, 302, 303, 304,
+ -1, -1, -1, -1, -1, -1, 257, 258, 259, 260,
+ 261, 262, 263, 264, 265, -1, -1, 268, 269, -1,
+ -1, -1, -1, 274, -1, -1, -1, -1, -1, 280,
+ -1, 282, 283, 284, 285, 286, -1, 288, 289, 290,
+ 291, 292, 293, 294, 295, 296, -1, 298, -1, 300,
+ 301, 302, 303, 304, 40, -1, -1, 43, -1, 45,
+ 257, 258, 259, 260, 261, 262, 263, 264, 265, -1,
+ -1, 268, 269, 0, -1, -1, -1, 274, -1, -1,
+ -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
+ -1, -1, 289, 290, 291, 292, 293, 294, 295, 296,
+ -1, 298, -1, 300, -1, -1, 303, 304, -1, -1,
+ 37, -1, -1, 40, 41, 42, 43, 44, 45, -1,
+ 47, -1, -1, -1, -1, -1, -1, -1, 0, -1,
+ -1, 58, 59, 60, -1, 62, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 93, 94, 40, 41,
+ -1, 43, 44, 45, -1, -1, -1, -1, -1, 0,
+ -1, -1, -1, -1, -1, 112, 58, 59, 60, -1,
+ 62, 63, -1, -1, 263, 264, 123, 124, -1, 268,
+ 269, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 280, -1, 282, 283, 284, -1, 286, -1, 40,
+ 41, 93, 43, 44, 45, -1, -1, 0, -1, 298,
+ -1, -1, 301, 302, 303, 304, -1, 58, 59, 60,
+ -1, 62, 63, -1, -1, -1, -1, -1, -1, -1,
+ -1, 123, 124, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 40, 41, -1,
+ -1, 44, 93, 259, -1, 261, 262, 263, 264, -1,
+ -1, 0, 268, 269, -1, 58, 59, 60, -1, 62,
+ 63, -1, -1, -1, 280, -1, 282, 283, 284, -1,
+ 286, -1, 123, 124, -1, 291, 292, 293, 294, -1,
+ -1, -1, 298, -1, 300, 301, 302, 303, 304, -1,
+ 93, 40, -1, -1, 43, -1, 45, -1, -1, -1,
+ 257, 258, 259, 260, 261, 262, 263, 264, 265, 0,
+ 59, 268, 269, -1, -1, -1, -1, 274, -1, -1,
+ 123, 124, -1, 280, -1, 282, 283, 284, 285, 286,
+ -1, 288, -1, -1, 291, 292, 293, 294, 295, 296,
+ -1, 298, -1, 300, 301, 302, 303, 304, -1, 40,
+ -1, -1, 43, -1, 45, 257, 258, 259, 260, 261,
+ 262, 263, 264, 265, -1, -1, 268, 269, 59, -1,
+ -1, -1, 274, -1, 123, -1, -1, -1, 280, 0,
+ 282, 283, 284, 285, 286, -1, 288, 289, 290, 291,
+ 292, 293, 294, 295, 296, -1, 298, -1, 300, 301,
+ 302, 303, 304, -1, -1, -1, 257, 258, 259, 260,
+ 261, 262, 263, 264, 265, -1, -1, 268, 269, 40,
+ -1, -1, 43, 274, 45, -1, -1, -1, -1, 280,
+ -1, 282, 283, 284, 285, 286, -1, 288, 289, 290,
+ 291, 292, 293, 294, 295, 296, -1, 298, -1, 300,
+ 301, 302, 303, 304, 257, 258, 259, 260, 261, 262,
+ 263, 264, 265, 0, -1, 268, 269, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
+ 283, 284, 285, 286, -1, 288, 289, 290, 291, 292,
+ 293, 294, 295, 296, -1, 298, -1, 300, 301, 302,
+ 303, 304, 123, 40, 41, -1, -1, 44, 257, 258,
+ 259, 260, 261, 262, 263, 264, -1, 0, -1, 268,
+ 269, 58, 59, 60, -1, 62, 63, -1, -1, -1,
+ -1, 280, -1, 282, 283, 284, 285, 286, -1, -1,
+ -1, -1, 291, 292, 293, 294, -1, -1, -1, 298,
+ -1, 300, 301, 302, 303, 304, 93, 40, -1, -1,
+ 43, -1, 45, -1, -1, -1, 257, 258, 259, 260,
+ 261, 262, 263, 264, 0, -1, 59, 268, 269, -1,
+ -1, -1, -1, -1, -1, -1, 123, 124, -1, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, -1, -1, -1, 298, -1, 300,
+ 301, 302, 303, 304, 40, -1, -1, 43, -1, 45,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 257, 258, 259, -1,
+ 123, -1, 263, 264, -1, 0, -1, 268, 269, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, -1, -1, -1, 298, -1, 300,
+ 301, 302, 303, 304, -1, 40, -1, -1, 43, -1,
+ 45, -1, -1, -1, -1, -1, -1, 123, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 257, 258, 259, 260, 261, 262, 263, 264, 265, -1,
+ -1, 268, 269, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
+ -1, 288, 289, 290, 291, 292, 293, 294, 295, 296,
+ -1, 298, -1, 300, 301, 302, 303, 304, 123, -1,
+ -1, -1, -1, -1, 257, 258, 259, 260, -1, 262,
+ 263, 264, -1, -1, -1, 268, 269, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
+ 283, 284, 285, 286, -1, -1, -1, -1, 291, 292,
+ 293, 294, -1, -1, -1, 298, -1, 300, 301, 302,
+ 303, 304, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 257, 258, 259, -1, -1, -1, 263, 264, -1,
+ -1, -1, 268, 269, -1, -1, 40, 41, -1, 43,
+ 44, 45, -1, -1, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 63,
+ -1, -1, 298, -1, 300, 301, 302, 303, 304, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 40, 41, -1, 43, 44, 45, -1,
+ -1, -1, 257, 258, 259, -1, -1, -1, 263, 264,
+ -1, -1, -1, 268, 269, 0, 63, -1, -1, -1,
+ -1, -1, -1, -1, -1, 280, -1, 282, 283, 284,
+ 285, 286, -1, -1, -1, -1, 291, 292, 293, 294,
+ -1, -1, -1, 298, -1, 300, 301, 302, 303, 304,
+ -1, -1, 37, -1, -1, 40, 41, 42, 43, 44,
+ 45, -1, 47, -1, -1, -1, -1, -1, -1, -1,
+ 0, -1, -1, 58, 59, 60, -1, 62, 63, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 37, 93, 94,
+ 40, 41, 42, 43, 44, 45, -1, 47, 0, -1,
+ -1, -1, -1, -1, -1, -1, -1, 112, 58, 59,
+ -1, -1, 62, 63, -1, -1, -1, -1, 123, 124,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 37, -1, -1, -1, 41,
+ 42, -1, 44, 93, 94, 47, -1, -1, -1, 263,
+ 264, -1, -1, -1, 268, 269, 58, 59, 60, -1,
+ 62, 63, 112, -1, -1, -1, 280, -1, 282, 283,
+ 284, -1, 286, 123, 124, -1, -1, 291, 292, 293,
+ 294, -1, -1, -1, 298, -1, -1, 301, 302, 303,
+ 304, 93, 94, -1, -1, -1, 263, 264, -1, -1,
+ -1, 268, 269, -1, -1, -1, -1, -1, -1, -1,
+ 112, -1, -1, 280, -1, 282, 283, 284, -1, 286,
+ -1, 123, 124, -1, 291, 292, 293, 294, -1, -1,
+ -1, 298, -1, -1, 301, 302, 303, 304, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 257, 258, 259, 260, 261, 262, 263, 264,
+ 265, -1, -1, 268, 269, -1, -1, -1, -1, 274,
+ -1, -1, -1, -1, -1, 280, -1, 282, 283, 284,
+ 285, 286, -1, 288, 289, 290, 291, -1, 293, 294,
+ 295, 296, -1, 298, -1, 300, 301, 302, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 257, 258, 259,
+ 260, 261, 262, 263, 264, 265, -1, -1, 268, 269,
+ -1, -1, -1, -1, 274, -1, -1, -1, -1, -1,
+ 280, -1, 282, 283, 284, 285, 286, 0, 288, 289,
+ 290, 291, -1, 293, 294, 295, 296, -1, 298, -1,
+ 300, 301, 302, -1, -1, 257, 258, 259, 260, 261,
+ 262, -1, -1, 265, -1, -1, -1, -1, -1, -1,
+ -1, -1, 274, -1, 37, -1, -1, -1, 41, 42,
+ -1, 44, 0, 285, 47, -1, 288, 289, 290, 291,
+ 292, 293, 294, 295, 296, 58, 59, 60, 300, 62,
+ 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 37,
+ -1, -1, -1, 41, 42, -1, 44, 0, -1, 47,
+ 93, 94, -1, -1, -1, -1, -1, -1, -1, -1,
+ 58, 59, 60, -1, 62, 63, -1, -1, -1, 112,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 123, 124, -1, -1, 37, -1, -1, -1, 41, 42,
+ -1, 44, -1, -1, 47, 93, 94, -1, -1, -1,
+ -1, -1, -1, -1, -1, 58, 59, 60, -1, 62,
+ 63, -1, -1, -1, 112, -1, 0, -1, -1, -1,
+ -1, -1, -1, -1, -1, 123, 124, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 93, 94, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 37, -1, -1, -1, 41, 42, 112,
+ 44, -1, -1, 47, -1, -1, -1, -1, -1, -1,
+ 123, 124, -1, -1, 58, 59, 60, -1, 62, 63,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 93,
+ 94, -1, -1, -1, 257, 258, 259, 260, 261, 262,
+ -1, -1, 265, -1, -1, -1, -1, -1, 112, -1,
+ -1, 274, -1, -1, -1, -1, -1, -1, -1, 123,
+ 124, -1, 285, -1, -1, 288, 289, 290, 291, 292,
+ 293, 294, 295, 296, -1, -1, -1, 300, -1, 257,
+ 258, 259, 260, 261, 262, -1, -1, 265, -1, -1,
+ -1, -1, -1, -1, -1, -1, 274, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 285, -1, -1,
+ 288, 289, 290, 291, 292, 293, 294, 295, 296, -1,
+ -1, -1, 300, -1, 257, 258, 259, 260, 261, 262,
+ -1, -1, 265, -1, -1, -1, -1, -1, -1, -1,
+ -1, 274, -1, -1, 0, -1, -1, -1, -1, -1,
+ -1, -1, 285, -1, -1, 288, 289, 290, 291, 292,
+ 293, 294, 295, 296, -1, -1, -1, 300, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 37, 47, 48, -1, 41, 42, -1, 44, -1,
+ -1, 47, -1, 257, 258, 259, 260, 261, 262, -1,
+ -1, 265, 58, 59, 60, -1, 62, 63, -1, -1,
+ 274, 0, -1, -1, -1, -1, 81, -1, 83, 84,
+ -1, 285, -1, -1, 288, 289, 290, 291, 292, 293,
+ 294, 295, 296, -1, -1, -1, 300, 93, 94, -1,
+ -1, -1, -1, -1, -1, -1, 111, 112, 37, -1,
+ -1, -1, 41, 42, -1, 44, 112, -1, 47, 0,
+ -1, -1, -1, -1, -1, -1, -1, 123, 124, 58,
+ 59, 60, -1, 62, 63, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 37, -1, -1, -1,
+ 41, 42, -1, 44, 93, 94, 47, -1, -1, 174,
+ -1, -1, -1, -1, -1, -1, -1, 58, 59, 60,
+ 185, 62, 187, 112, 189, -1, -1, -1, -1, -1,
+ -1, 0, -1, -1, 123, 124, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 211, -1, -1, -1,
+ -1, -1, 93, 94, -1, -1, -1, -1, -1, -1,
+ -1, 226, 227, 228, 229, 230, -1, -1, 37, -1,
+ -1, 112, 41, 42, -1, 44, -1, -1, 47, -1,
+ -1, -1, 123, 124, -1, -1, -1, -1, -1, 58,
+ 59, 60, -1, 62, -1, -1, -1, -1, -1, -1,
+ -1, 257, 258, 259, 260, 261, 262, -1, -1, 265,
+ 275, -1, -1, -1, 279, 280, 281, -1, 274, 0,
+ 285, -1, -1, -1, 93, 94, -1, -1, -1, 285,
+ -1, -1, 288, 289, 290, 291, 292, 293, 294, 295,
+ 296, -1, -1, 112, 300, 310, 311, -1, -1, -1,
+ -1, 316, -1, -1, 123, 124, 37, -1, -1, -1,
+ 41, 42, -1, 44, -1, -1, 47, -1, 257, 258,
+ 259, 260, 261, 262, -1, -1, 265, 58, 59, 60,
+ -1, 62, -1, -1, -1, 274, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 285, -1, -1, 288,
+ 289, 290, -1, -1, -1, -1, 295, 296, -1, -1,
+ -1, 300, 93, 94, -1, -1, 257, 258, 259, 260,
+ 261, 262, -1, -1, 265, -1, -1, -1, -1, 40,
+ 41, 112, 43, 274, 45, -1, -1, -1, -1, 0,
+ -1, -1, 123, 124, 285, -1, -1, 288, 289, 290,
+ -1, -1, 63, -1, 295, 296, -1, -1, -1, 300,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 37, -1, -1, -1,
+ 41, 42, -1, 44, -1, -1, 47, -1, 257, 258,
+ 259, 260, 261, 262, -1, -1, 265, 58, 59, 60,
+ -1, 62, -1, -1, -1, 274, 0, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 285, -1, -1, 288,
+ 289, 290, -1, -1, -1, -1, 295, 296, -1, -1,
+ -1, 300, 93, 94, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 37, -1, -1, -1, 41, 42, -1,
+ -1, 112, -1, 47, 0, -1, -1, -1, -1, -1,
+ -1, -1, 123, 124, 58, 59, 60, -1, 62, -1,
+ -1, -1, -1, -1, -1, -1, 257, 258, 259, 260,
+ 261, 262, -1, -1, 265, -1, -1, -1, -1, -1,
+ -1, 37, -1, 274, -1, 41, 42, -1, 44, 93,
+ 94, 47, -1, -1, 285, -1, -1, 288, 289, 290,
+ -1, -1, 58, 59, 295, 296, -1, -1, 112, 300,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 123,
+ 124, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 93, 94, -1,
+ -1, -1, 263, 264, -1, -1, -1, 268, 269, -1,
+ -1, -1, -1, -1, -1, -1, 112, -1, -1, 280,
+ -1, 282, 283, 284, -1, 286, -1, 123, 124, -1,
+ 291, 292, 293, 294, -1, -1, -1, 298, -1, -1,
+ 301, 302, 303, 304, -1, -1, 257, 258, 259, 260,
+ 261, 262, -1, -1, 265, -1, -1, -1, -1, -1,
+ -1, -1, -1, 274, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 285, -1, -1, 288, 289, 290,
+ -1, -1, -1, -1, 295, 296, -1, -1, -1, 300,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 257, 258, 259, 260, 261, 262, -1,
+ -1, 265, -1, -1, -1, -1, -1, -1, -1, -1,
+ 274, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 285, -1, -1, 288, 289, 290, -1, -1, -1,
+ -1, 295, 296, -1, -1, -1, 300, -1, -1, -1,
+ -1, 257, 258, 259, 260, 261, 262, -1, 7, 265,
+ -1, -1, -1, -1, -1, 14, -1, -1, 274, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 285,
+ 29, -1, 288, 289, 290, -1, 35, -1, -1, -1,
+ -1, -1, -1, -1, 300, -1, -1, -1, -1, -1,
+ 49, 50, 51, -1, -1, -1, 55, 56, -1, 58,
+ 59, 60, -1, 62, 63, 64, 65, 66, -1, -1,
+ -1, -1, -1, -1, -1, 40, -1, -1, 43, -1,
+ 45, -1, -1, 82, -1, -1, 85, 86, 87, 88,
+ 89, 90, -1, -1, 59, -1, -1, -1, -1, -1,
+ -1, 100, -1, -1, -1, -1, -1, -1, -1, 108,
+ -1, -1, -1, -1, -1, -1, 115, -1, -1, -1,
+ 40, -1, 121, 43, -1, 45, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 136, 137, 59,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 123, -1,
+ 159, 160, -1, -1, 163, 164, 165, 166, 167, -1,
+ -1, -1, -1, 172, 173, 40, 175, 176, 43, -1,
+ 45, 180, -1, -1, -1, 184, -1, -1, -1, -1,
+ -1, -1, -1, -1, 59, -1, 195, -1, -1, 198,
+ -1, -1, -1, 123, -1, 125, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 217, 218,
+ 219, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 236, -1, 238,
+ -1, 240, -1, 242, -1, 244, -1, -1, -1, 40,
+ 249, -1, 43, -1, 45, 254, 255, -1, 123, -1,
+ 125, -1, -1, 262, -1, -1, -1, -1, 59, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 282, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 260, 261, 262, 263, 264,
+ 299, 266, 267, 268, 269, 270, -1, 272, 273, -1,
+ 275, 276, 277, 278, 279, 280, 281, 282, 283, 284,
+ -1, 286, 287, -1, -1, -1, 291, 292, 293, 294,
+ -1, -1, 123, 298, 125, -1, 301, 302, 303, 304,
+ 260, -1, -1, 263, 264, -1, 266, 267, 268, 269,
+ 270, 271, 272, 273, -1, 275, 276, 277, 278, 279,
+ 280, 281, 282, 283, 284, -1, 286, 287, -1, -1,
+ -1, 291, 292, 293, 294, -1, -1, -1, 298, -1,
+ -1, 301, 302, 303, 304, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 260, -1, -1, 263, 264,
+ -1, 266, 267, 268, 269, 270, 271, 272, 273, -1,
+ 275, 276, 277, 278, 279, 280, 281, 282, 283, 284,
+ -1, 286, 287, -1, -1, -1, 291, 292, 293, 294,
+ -1, -1, -1, 298, -1, -1, 301, 302, 303, 304,
+ 40, -1, -1, 43, -1, 45, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 59,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 260,
+ -1, -1, 263, 264, -1, 266, 267, 268, 269, 270,
+ 271, 272, 273, -1, 275, 276, 277, 278, 279, 280,
+ 281, 282, 283, 284, -1, 286, 287, -1, -1, -1,
+ 291, 292, 293, 294, -1, -1, -1, 298, -1, -1,
+ 301, 302, 303, 304, 40, -1, -1, 43, -1, 45,
+ -1, -1, -1, 123, -1, 125, -1, -1, -1, -1,
+ -1, -1, -1, 59, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 40,
+ -1, -1, 43, -1, 45, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 59, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 123, -1, 125,
+ -1, -1, -1, -1, -1, 40, -1, -1, 43, -1,
+ 45, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 59, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 123, -1, 125, -1, -1, -1, 40, 41,
+ -1, 43, -1, 45, -1, -1, -1, -1, -1, -1,
+ 260, -1, -1, 263, 264, -1, 266, 267, 268, 269,
+ 270, 271, 272, 273, -1, 275, 276, 277, 278, 279,
+ 280, 281, 282, 283, 284, -1, 286, 287, 123, -1,
+ 125, 291, 292, 293, 294, -1, -1, -1, 298, -1,
+ -1, 301, 302, 303, 304, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 260, -1, -1, 263, 264, -1,
+ 266, 267, 268, 269, 270, 271, 272, 273, -1, 275,
+ 276, 277, 278, 279, 280, 281, 282, 283, 284, -1,
+ 286, 287, -1, -1, -1, 291, 292, 293, 294, -1,
+ -1, -1, 298, -1, -1, 301, 302, 303, 304, 260,
+ -1, -1, 263, 264, -1, 266, 267, 268, 269, 270,
+ 271, 272, 273, -1, 275, 276, 277, 278, 279, 280,
+ 281, 282, 283, 284, 40, 286, 287, 43, -1, 45,
+ 291, 292, 293, 294, -1, -1, -1, 298, -1, -1,
+ 301, 302, 303, 304, -1, 260, -1, -1, 263, 264,
+ -1, 266, 267, 268, 269, 270, 271, 272, 273, -1,
+ 275, 276, 277, 278, 279, 280, 281, 282, 283, 284,
+ -1, 286, 287, -1, -1, -1, 291, 292, 293, 294,
+ -1, -1, -1, 298, -1, -1, 301, 302, 303, 304,
+ 40, 263, 264, 43, -1, 45, 268, 269, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 123, 280, 59,
+ 282, 283, 284, -1, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, -1, -1, -1, 298, -1, -1, 301,
+ 302, 303, 304, -1, -1, 40, -1, -1, 43, -1,
+ 45, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 59, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 123, -1, 125, -1, -1, -1, -1,
+ 40, -1, -1, 43, -1, 45, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 59,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 123, -1,
+ 125, -1, -1, -1, -1, -1, 40, -1, -1, 43,
+ -1, 45, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 257, 258, 259, -1, 59, -1, 263, 264, -1,
+ -1, -1, 268, 269, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 123, 280, 125, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, -1,
+ -1, -1, 298, -1, 300, 301, 302, 303, 304, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 40, -1, -1, 43, -1, 45, -1, -1, -1, 123,
+ 260, 125, -1, 263, 264, -1, 266, 267, 268, 269,
+ 270, 271, 272, 273, -1, 275, 276, 277, 278, 279,
+ 280, 281, 282, 283, 284, -1, 286, 287, -1, -1,
+ -1, 291, 292, 293, 294, -1, -1, -1, 298, -1,
+ -1, 301, 302, 303, 304, 260, -1, -1, 263, 264,
+ -1, 266, 267, 268, 269, 270, -1, 272, 273, -1,
+ 275, 276, 277, 278, 279, 280, 281, 282, 283, 284,
+ -1, 286, 287, -1, -1, -1, 291, 292, 293, 294,
+ -1, -1, -1, 298, -1, -1, 301, 302, 303, 304,
+ 260, -1, -1, 263, 264, -1, 266, 267, 268, 269,
+ 270, -1, 272, 273, -1, 275, 276, 277, 278, 279,
+ 280, 281, 282, 283, 284, -1, 286, 287, -1, -1,
+ -1, 291, 292, 293, 294, -1, -1, -1, 298, -1,
+ -1, 301, 302, 303, 304, -1, 260, -1, -1, 263,
+ 264, -1, 266, 267, 268, 269, 270, -1, 272, 273,
+ -1, 275, 276, 277, 278, 279, 280, 281, 282, 283,
+ 284, -1, 286, 287, -1, -1, -1, 291, 292, 293,
+ 294, -1, -1, -1, 298, -1, -1, 301, 302, 303,
+ 304, 40, -1, -1, 43, -1, 45, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 59, -1, -1, -1, -1, -1, -1, -1, -1, 259,
+ -1, -1, -1, 263, 264, -1, -1, -1, 268, 269,
+ -1, -1, -1, -1, -1, -1, 40, -1, -1, 43,
+ 280, 45, 282, 283, 284, -1, 286, -1, -1, -1,
+ -1, 291, 292, 293, 294, 59, -1, -1, 298, -1,
+ 300, 301, 302, 303, 304, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 123, -1, 125, -1, -1, -1,
+ -1, 40, -1, -1, 43, -1, 45, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 59, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 123,
+ -1, 125, -1, -1, -1, -1, -1, 40, -1, -1,
+ 43, -1, 45, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 59, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 123, -1, 125, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 40, -1, -1,
+ 43, -1, 45, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 123, 260, 125, -1, 263, 264, -1, 266, 267, 268,
+ 269, 270, -1, 272, 273, -1, 275, 276, 277, 278,
+ 279, 280, 281, 282, 283, 284, -1, 286, 287, -1,
+ -1, -1, 291, 292, 293, 294, -1, -1, -1, 298,
+ -1, -1, 301, 302, 303, 304, 260, -1, -1, 263,
+ 264, -1, 266, 267, 268, 269, 270, -1, 272, 273,
+ -1, 275, 276, 277, 278, 279, 280, 281, 282, 283,
+ 284, -1, 286, 287, -1, -1, -1, 291, 292, 293,
+ 294, -1, -1, -1, 298, -1, -1, 301, 302, 303,
+ 304, 260, -1, -1, 263, 264, -1, 266, 267, 268,
+ 269, 270, -1, 272, 273, -1, 275, 276, 277, 278,
+ 279, 280, 281, 282, 283, 284, 40, 286, 287, 43,
+ 44, 45, 291, 292, 293, 294, -1, -1, -1, 298,
+ -1, -1, 301, 302, 303, 304, 60, 260, 62, 63,
+ 263, 264, -1, 266, 267, 268, 269, 270, -1, 272,
+ 273, -1, 275, 276, 277, 278, 279, 280, 281, 282,
+ 283, 284, -1, 286, 287, -1, -1, -1, 291, 292,
+ 293, 294, -1, -1, -1, 298, -1, -1, 301, 302,
+ 303, 304, 40, -1, -1, 43, -1, 45, -1, -1,
+ 263, 264, -1, 266, 267, 268, 269, -1, -1, -1,
+ -1, 59, 275, 276, 277, 278, 279, 280, -1, 282,
+ 283, 284, -1, 286, 287, -1, -1, -1, 291, 292,
+ 293, 294, -1, -1, -1, 298, -1, -1, 301, 302,
+ 303, 304, 40, -1, -1, 43, -1, 45, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 60, -1, 62, 63, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 123, -1, 125, -1, -1,
+ -1, -1, -1, -1, 40, 41, -1, 43, 44, 45,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 63, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 40, 41,
+ -1, 43, 44, 45, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 263,
+ 264, 63, -1, -1, 268, 269, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
+ 284, -1, 286, -1, -1, -1, -1, 291, 292, 293,
+ 294, 295, 296, -1, 298, -1, -1, 301, 302, 303,
+ 304, 40, 41, -1, 43, 44, 45, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 260, -1, 63, 263, 264, -1, 266, 267,
+ 268, 269, 270, -1, 272, 273, -1, 275, 276, 277,
+ 278, 279, 280, 281, 282, 283, 284, -1, 286, 287,
+ -1, -1, -1, 291, 292, 293, 294, -1, -1, -1,
+ 298, -1, -1, 301, 302, 303, 304, 40, -1, -1,
+ 43, -1, 45, -1, -1, 263, 264, -1, -1, -1,
+ 268, 269, -1, -1, -1, -1, 59, -1, -1, -1,
+ -1, -1, 280, -1, 282, 283, 284, -1, 286, -1,
+ -1, -1, -1, 291, 292, 293, 294, 295, 296, -1,
+ 298, -1, -1, 301, 302, 303, 304, 263, 264, -1,
+ -1, 40, 268, 269, 43, -1, 45, -1, -1, -1,
+ -1, -1, -1, -1, 280, -1, 282, 283, 284, -1,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, -1,
+ -1, -1, 298, -1, -1, 301, 302, 303, 304, -1,
+ -1, 263, 264, -1, -1, 40, 268, 269, 43, 44,
+ 45, -1, -1, -1, -1, -1, -1, -1, 280, -1,
+ 282, 283, 284, -1, 286, -1, -1, -1, 63, 291,
+ 292, 293, 294, -1, -1, -1, 298, -1, -1, 301,
+ 302, 303, 304, -1, -1, -1, -1, -1, 40, -1,
+ -1, 43, 44, 45, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 263, 264, -1, -1, -1, 268,
+ 269, 63, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 280, -1, 282, 283, 284, -1, 286, -1, -1,
+ -1, -1, 291, 292, 293, 294, -1, -1, -1, 298,
+ -1, -1, 301, 302, 303, 304, 40, -1, -1, 43,
+ 44, 45, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 259, -1, -1, 63,
+ 263, 264, -1, -1, -1, 268, 269, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
+ 283, 284, 40, 286, -1, 43, 44, 45, 291, 292,
+ 293, 294, -1, -1, -1, 298, -1, 300, 301, 302,
+ 303, 304, -1, -1, -1, 63, -1, -1, -1, -1,
+ 259, -1, -1, -1, 263, 264, -1, -1, -1, 268,
+ 269, -1, -1, -1, 40, -1, -1, 43, 44, 45,
+ -1, 280, -1, 282, 283, 284, -1, 286, -1, -1,
+ -1, -1, 291, 292, 293, 294, -1, 63, -1, 298,
+ -1, 300, 301, 302, 303, 304, -1, -1, 263, 264,
+ -1, -1, -1, 268, 269, -1, -1, 40, -1, -1,
+ 43, 44, 45, -1, -1, 280, -1, 282, 283, 284,
+ -1, 286, -1, -1, -1, -1, 291, 292, 293, 294,
+ 63, -1, -1, 298, -1, -1, 301, 302, 303, 304,
+ -1, 263, 264, -1, -1, -1, 268, 269, -1, -1,
+ 40, -1, -1, 43, 44, 45, -1, -1, 280, -1,
+ 282, 283, 284, -1, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, 63, -1, -1, 298, -1, -1, 301,
+ 302, 303, 304, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 40, -1, -1, 43, -1, 45, -1, 263,
+ 264, -1, -1, -1, 268, 269, -1, -1, -1, -1,
+ 58, -1, -1, -1, -1, 63, 280, -1, 282, 283,
+ 284, -1, 286, -1, -1, -1, -1, 291, 292, 293,
+ 294, -1, -1, -1, 298, -1, -1, 301, 302, 303,
+ 304, -1, -1, -1, -1, 263, 264, -1, -1, 40,
+ 268, 269, 43, -1, 45, -1, -1, -1, -1, -1,
+ -1, -1, 280, -1, 282, 283, 284, 58, 286, -1,
+ -1, -1, 63, 291, 292, 293, 294, -1, -1, -1,
+ 298, -1, -1, 301, 302, 303, 304, 263, 264, -1,
+ -1, -1, 268, 269, 40, -1, -1, 43, -1, 45,
+ -1, -1, -1, -1, 280, -1, 282, 283, 284, -1,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, -1,
+ -1, -1, 298, -1, -1, 301, 302, 303, 304, -1,
+ 263, 264, -1, -1, -1, 268, 269, -1, -1, 40,
+ 41, -1, 43, -1, 45, -1, -1, 280, -1, 282,
+ 283, 284, -1, 286, -1, -1, -1, -1, 291, 292,
+ 293, 294, 63, -1, -1, 298, -1, -1, 301, 302,
+ 303, 304, -1, 263, 264, -1, -1, -1, 268, 269,
+ -1, -1, 40, 41, -1, 43, -1, 45, -1, -1,
+ 280, -1, 282, 283, 284, -1, 286, -1, -1, -1,
+ -1, 291, 292, 293, 294, 63, -1, -1, 298, -1,
+ -1, 301, 302, 303, 304, 263, 264, -1, -1, -1,
+ 268, 269, -1, -1, 40, 41, -1, 43, -1, 45,
+ -1, -1, 280, -1, 282, 283, 284, -1, 286, -1,
+ -1, -1, -1, 291, 292, 293, 294, 63, -1, -1,
+ 298, -1, -1, 301, 302, 303, 304, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 263, 264, -1, -1, -1, 268, 269, -1,
+ -1, 40, 41, -1, 43, -1, 45, -1, -1, 280,
+ -1, 282, 283, 284, -1, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, 63, -1, -1, 298, -1, -1,
+ 301, 302, 303, 304, -1, 261, 262, 263, 264, -1,
+ -1, -1, 268, 269, -1, -1, 40, 41, -1, 43,
+ -1, 45, -1, -1, 280, -1, 282, 283, 284, -1,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 63,
+ -1, -1, 298, -1, -1, 301, 302, 303, 304, -1,
+ -1, -1, 263, 264, -1, -1, -1, 268, 269, -1,
+ -1, 40, 41, -1, 43, -1, 45, -1, -1, 280,
+ -1, 282, 283, 284, -1, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, 63, -1, -1, 298, -1, -1,
+ 301, 302, 303, 304, -1, 263, 264, -1, -1, -1,
+ 268, 269, -1, -1, 40, 41, -1, 43, -1, 45,
+ -1, -1, 280, -1, 282, 283, 284, -1, 286, -1,
+ -1, -1, -1, 291, 292, 293, 294, 63, -1, -1,
+ 298, -1, -1, 301, 302, 303, 304, 263, 264, -1,
+ -1, -1, 268, 269, -1, -1, 40, 41, -1, 43,
+ -1, 45, -1, -1, 280, -1, 282, 283, 284, -1,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 63,
+ -1, -1, 298, -1, -1, 301, 302, 303, 304, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 263, 264, -1, -1, -1, 268,
+ 269, -1, -1, 40, 41, -1, 43, -1, 45, -1,
+ -1, 280, -1, 282, 283, 284, -1, 286, -1, -1,
+ -1, -1, 291, 292, 293, 294, 63, -1, -1, 298,
+ -1, -1, 301, 302, 303, 304, -1, -1, -1, 263,
+ 264, -1, -1, -1, 268, 269, -1, -1, -1, 40,
+ -1, -1, 43, -1, 45, -1, 280, -1, 282, 283,
+ 284, -1, 286, -1, -1, -1, -1, 291, 292, 293,
+ 294, -1, -1, -1, 298, -1, -1, 301, 302, 303,
+ 304, -1, -1, -1, 263, 264, -1, -1, -1, 268,
+ 269, -1, -1, -1, -1, 40, -1, -1, 43, -1,
+ 45, 280, -1, 282, 283, 284, -1, 286, -1, -1,
+ -1, -1, 291, 292, 293, 294, -1, -1, -1, 298,
+ -1, -1, 301, 302, 303, 304, -1, 263, 264, -1,
+ -1, -1, 268, 269, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 280, -1, 282, 283, 284, 40,
+ 286, -1, 43, -1, 45, 291, 292, 293, 294, -1,
+ -1, -1, 298, -1, -1, 301, 302, 303, 304, 263,
+ 264, -1, -1, -1, 268, 269, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
+ 284, -1, 286, -1, -1, -1, -1, 291, 292, 293,
+ 294, -1, -1, -1, 298, -1, -1, 301, 302, 303,
+ 304, 40, -1, -1, 43, -1, 45, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 263, 264, -1, -1,
+ -1, 268, 269, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 280, -1, 282, 283, 284, -1, 286,
+ -1, -1, -1, -1, 291, 292, 293, 294, -1, -1,
+ -1, 298, -1, -1, 301, 302, 303, 304, 259, -1,
+ -1, 40, 263, 264, 43, -1, 45, 268, 269, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 280,
+ -1, 282, 283, 284, 63, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, -1, -1, -1, 298, -1, -1,
+ 301, 302, 303, 304, 259, -1, -1, 40, 263, 264,
+ 43, -1, 45, 268, 269, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 280, -1, 282, 283, 284,
+ -1, 286, -1, -1, -1, -1, 291, 292, 293, 294,
+ -1, -1, -1, 298, -1, -1, 301, 302, 303, 304,
+ 40, -1, -1, 43, -1, 45, -1, -1, 259, -1,
+ -1, -1, 263, 264, -1, -1, -1, 268, 269, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 280,
+ -1, 282, 283, 284, -1, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, -1, -1, -1, 298, -1, -1,
+ 301, 302, 303, 304, 40, -1, -1, 43, -1, 45,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 259, -1, -1, -1, 263, 264, -1, -1, -1, 268,
+ 269, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 280, -1, 282, 283, 284, -1, 286, -1, -1,
+ -1, -1, 291, 292, 293, 294, -1, -1, -1, 298,
+ -1, -1, 301, 302, 303, 304, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 263, 264, -1, -1, -1, 268,
+ 269, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 280, -1, 282, 283, 284, -1, 286, -1, -1,
+ -1, -1, 291, 292, 293, 294, -1, -1, -1, 298,
+ -1, -1, 301, 302, 303, 304, 259, -1, -1, -1,
+ 263, 264, -1, -1, -1, 268, 269, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
+ 283, 284, -1, 286, -1, -1, -1, -1, 291, 292,
+ 293, 294, -1, -1, -1, 298, -1, -1, 301, 302,
+ 303, 304, -1, 263, 264, -1, -1, -1, 268, 269,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 280, -1, 282, 283, 284, -1, 286, -1, -1, -1,
+ -1, 291, 292, 293, 294, 16, -1, -1, 298, -1,
+ -1, 301, 302, 303, 304, -1, 27, 28, -1, 30,
+ 31, -1, 33, -1, -1, -1, -1, 263, 264, -1,
+ 41, -1, 268, 269, -1, -1, -1, -1, -1, -1,
+ -1, -1, 53, -1, 280, -1, 282, 283, 284, -1,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, -1,
+ -1, -1, 298, -1, -1, 301, 302, 303, 304, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 93, 94, 95, 96, 97, 98, -1, -1,
+ -1, -1, -1, -1, -1, 106, -1, -1, 109, -1,
+ -1, -1, 113, 114, -1, -1, 117, -1, 119, 120,
+ -1, -1, -1, 124, 125, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 135, -1, -1, -1, 139, -1,
+ 141, 142, 143, 144, -1, -1, -1, -1, -1, -1,
+ -1, 152, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 162, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 190,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 202, 203, -1, 205, 206, 207, 208, -1, 210,
+ -1, 212, 213, -1, -1, 27, 28, -1, -1, 220,
+ 221, 33, -1, -1, -1, -1, -1, -1, -1, 41,
+ -1, 232, 233, -1, -1, -1, -1, -1, -1, -1,
+ -1, 53, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 258, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 270,
+ 271, 272, 273, 274, -1, 276, 277, 278, -1, -1,
+ -1, 93, 94, 95, 96, 97, 98, -1, -1, -1,
+ -1, -1, -1, -1, 106, -1, -1, 109, -1, -1,
+ -1, 113, 114, -1, -1, 117, -1, 119, 120, -1,
+ -1, -1, 124, 125, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 135, -1, -1, -1, 139, -1, 141,
+ 142, 143, 144, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 162, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 190, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 202, 203, -1, 205, 206, 207, 208, -1, 210, -1,
+ 212, 213, -1, -1, -1, -1, -1, -1, 220, 221,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 232, 233, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 258, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 270, 271,
+ 272, 273, 274, -1, 276, 277, 278,
+};
+#define YYFINAL 1
+#ifndef YYDEBUG
+#define YYDEBUG 0
+#endif
+#define YYMAXTOKEN 304
+#if YYDEBUG
+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,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,"'p'",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,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,0,"BEGIN","END","REGEX","SEMINEW",
+"NEWLINE","COMMENT","FUN1","FUNN","GRGR","PRINT","PRINTF","SPRINTF","SPLIT",
+"IF","ELSE","WHILE","FOR","IN","EXIT","NEXT","BREAK","CONTINUE","RET","GETLINE",
+"DO","SUB","GSUB","MATCH","FUNCTION","USERFUN","DELETE","ASGNOP","OROR",
+"ANDAND","NUMBER","VAR","SUBSTR","INDEX","MATCHOP","RELOP","OR","STRING",
+"UMINUS","NOT","INCR","DECR","FIELD","VFIELD",
+};
+char *yyrule[] = {
+"$accept : program",
+"program : junk hunks",
+"begin : BEGIN '{' maybe states '}' junk",
+"end : END '{' maybe states '}'",
+"end : end NEWLINE",
+"hunks : hunks hunk junk",
+"hunks :",
+"hunk : patpat",
+"hunk : patpat '{' maybe states '}'",
+"hunk : FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}'",
+"hunk : '{' maybe states '}'",
+"hunk : begin",
+"hunk : end",
+"arg_list : expr_list",
+"patpat : cond",
+"patpat : cond ',' cond",
+"cond : expr",
+"cond : match",
+"cond : rel",
+"cond : compound_cond",
+"cond : cond '?' expr ':' expr",
+"compound_cond : '(' compound_cond ')'",
+"compound_cond : cond ANDAND maybe cond",
+"compound_cond : cond OROR maybe cond",
+"compound_cond : NOT cond",
+"rel : expr RELOP expr",
+"rel : expr '>' expr",
+"rel : expr '<' expr",
+"rel : '(' rel ')'",
+"match : expr MATCHOP expr",
+"match : expr MATCHOP REGEX",
+"match : REGEX",
+"match : '(' match ')'",
+"expr : term",
+"expr : expr term",
+"expr : expr '?' expr ':' expr",
+"expr : variable ASGNOP cond",
+"term : variable",
+"term : NUMBER",
+"term : STRING",
+"term : term '+' term",
+"term : term '-' term",
+"term : term '*' term",
+"term : term '/' term",
+"term : term '%' term",
+"term : term '^' term",
+"term : term IN VAR",
+"term : variable INCR",
+"term : variable DECR",
+"term : INCR variable",
+"term : DECR variable",
+"term : '-' term",
+"term : '+' term",
+"term : '(' cond ')'",
+"term : GETLINE",
+"term : GETLINE variable",
+"term : GETLINE '<' expr",
+"term : GETLINE variable '<' expr",
+"term : term 'p' GETLINE",
+"term : term 'p' GETLINE variable",
+"term : FUN1",
+"term : FUN1 '(' ')'",
+"term : FUN1 '(' expr ')'",
+"term : FUNN '(' expr_list ')'",
+"term : USERFUN '(' expr_list ')'",
+"term : SPRINTF expr_list",
+"term : SUBSTR '(' expr ',' expr ',' expr ')'",
+"term : SUBSTR '(' expr ',' expr ')'",
+"term : SPLIT '(' expr ',' VAR ',' expr ')'",
+"term : SPLIT '(' expr ',' VAR ',' REGEX ')'",
+"term : SPLIT '(' expr ',' VAR ')'",
+"term : INDEX '(' expr ',' expr ')'",
+"term : MATCH '(' expr ',' REGEX ')'",
+"term : MATCH '(' expr ',' expr ')'",
+"term : SUB '(' expr ',' expr ')'",
+"term : SUB '(' REGEX ',' expr ')'",
+"term : GSUB '(' expr ',' expr ')'",
+"term : GSUB '(' REGEX ',' expr ')'",
+"term : SUB '(' expr ',' expr ',' expr ')'",
+"term : SUB '(' REGEX ',' expr ',' expr ')'",
+"term : GSUB '(' expr ',' expr ',' expr ')'",
+"term : GSUB '(' REGEX ',' expr ',' expr ')'",
+"variable : VAR",
+"variable : VAR '[' expr_list ']'",
+"variable : FIELD",
+"variable : VFIELD term",
+"expr_list : expr",
+"expr_list : clist",
+"expr_list :",
+"clist : expr ',' maybe expr",
+"clist : clist ',' maybe expr",
+"clist : '(' clist ')'",
+"junk : junk hunksep",
+"junk :",
+"hunksep : ';'",
+"hunksep : SEMINEW",
+"hunksep : NEWLINE",
+"hunksep : COMMENT",
+"maybe : maybe nlstuff",
+"maybe :",
+"nlstuff : NEWLINE",
+"nlstuff : COMMENT",
+"separator : ';' maybe",
+"separator : SEMINEW maybe",
+"separator : NEWLINE maybe",
+"separator : COMMENT maybe",
+"states : states statement",
+"states :",
+"statement : simple separator maybe",
+"statement : ';' maybe",
+"statement : SEMINEW maybe",
+"statement : compound",
+"simpnull : simple",
+"simpnull :",
+"simple : expr",
+"simple : PRINT expr_list redir expr",
+"simple : PRINT expr_list",
+"simple : PRINTF expr_list redir expr",
+"simple : PRINTF expr_list",
+"simple : BREAK",
+"simple : NEXT",
+"simple : EXIT",
+"simple : EXIT expr",
+"simple : CONTINUE",
+"simple : RET",
+"simple : RET expr",
+"simple : DELETE VAR '[' expr_list ']'",
+"redir : '>'",
+"redir : GRGR",
+"redir : '|'",
+"compound : IF '(' cond ')' maybe statement",
+"compound : IF '(' cond ')' maybe statement ELSE maybe statement",
+"compound : WHILE '(' cond ')' maybe statement",
+"compound : DO maybe statement WHILE '(' cond ')'",
+"compound : FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement",
+"compound : FOR '(' simpnull ';' ';' simpnull ')' maybe statement",
+"compound : FOR '(' expr ')' maybe statement",
+"compound : '{' maybe states '}' maybe",
+};
+#endif
+#ifndef YYSTYPE
+typedef int YYSTYPE;
+#endif
+#define yyclearin (yychar=(-1))
+#define yyerrok (yyerrflag=0)
+#ifdef YYSTACKSIZE
+#ifndef YYMAXDEPTH
+#define YYMAXDEPTH YYSTACKSIZE
+#endif
+#else
+#ifdef YYMAXDEPTH
+#define YYSTACKSIZE YYMAXDEPTH
+#else
+#define YYSTACKSIZE 500
+#define YYMAXDEPTH 500
+#endif
+#endif
+int yydebug;
+int yynerrs;
+int yyerrflag;
+int yychar;
+short *yyssp;
+YYSTYPE *yyvsp;
+YYSTYPE yyval;
+YYSTYPE yylval;
+short yyss[YYSTACKSIZE];
+YYSTYPE yyvs[YYSTACKSIZE];
+#define yystacksize YYSTACKSIZE
+#line 396 "a2p.y"
+
+int yyparse _((void));
+
+#include "a2py.c"
+#line 2008 "y.tab.c"
+#define YYABORT goto yyabort
+#define YYACCEPT goto yyaccept
+#define YYERROR goto yyerrlab
+int
+yyparse()
+{
+ register int yym, yyn, yystate;
+#if YYDEBUG
+ register char *yys;
+#ifndef __cplusplus
+ extern char *getenv();
+#endif
+
+ if (yys = getenv("YYDEBUG"))
+ {
+ yyn = *yys;
+ if (yyn >= '0' && yyn <= '9')
+ yydebug = yyn - '0';
+ }
+#endif
+
+ yynerrs = 0;
+ yyerrflag = 0;
+ yychar = (-1);
+
+ yyssp = yyss;
+ yyvsp = yyvs;
+ *yyssp = yystate = 0;
+
+yyloop:
+ if (yyn = yydefred[yystate]) goto yyreduce;
+ if (yychar < 0)
+ {
+ if ((yychar = yylex()) < 0) yychar = 0;
+#if YYDEBUG
+ if (yydebug)
+ {
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+ printf("yydebug: state %d, reading %d (%s)\n", yystate,
+ yychar, yys);
+ }
+#endif
+ }
+ if ((yyn = yysindex[yystate]) && (yyn += yychar) >= 0 &&
+ yyn <= YYTABLESIZE && yycheck[yyn] == yychar)
+ {
+#if YYDEBUG
+ if (yydebug)
+ printf("yydebug: state %d, shifting to state %d\n",
+ yystate, yytable[yyn]);
+#endif
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+ goto yyoverflow;
+ }
+ *++yyssp = yystate = yytable[yyn];
+ *++yyvsp = yylval;
+ yychar = (-1);
+ if (yyerrflag > 0) --yyerrflag;
+ goto yyloop;
+ }
+ if ((yyn = yyrindex[yystate]) && (yyn += yychar) >= 0 &&
+ yyn <= YYTABLESIZE && yycheck[yyn] == yychar)
+ {
+ yyn = yytable[yyn];
+ goto yyreduce;
+ }
+ if (yyerrflag) goto yyinrecovery;
+#ifdef lint
+ goto yynewerror;
+#endif
+yynewerror:
+ yyerror("syntax error");
+#ifdef lint
+ goto yyerrlab;
+#endif
+yyerrlab:
+ ++yynerrs;
+yyinrecovery:
+ if (yyerrflag < 3)
+ {
+ yyerrflag = 3;
+ for (;;)
+ {
+ if ((yyn = yysindex[*yyssp]) && (yyn += YYERRCODE) >= 0 &&
+ yyn <= YYTABLESIZE && yycheck[yyn] == YYERRCODE)
+ {
+#if YYDEBUG
+ if (yydebug)
+ printf("yydebug: state %d, error recovery shifting\
+ to state %d\n", *yyssp, yytable[yyn]);
+#endif
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+ goto yyoverflow;
+ }
+ *++yyssp = yystate = yytable[yyn];
+ *++yyvsp = yylval;
+ goto yyloop;
+ }
+ else
+ {
+#if YYDEBUG
+ if (yydebug)
+ printf("yydebug: error recovery discarding state %d\n",
+ *yyssp);
+#endif
+ if (yyssp <= yyss) goto yyabort;
+ --yyssp;
+ --yyvsp;
+ }
+ }
+ }
+ else
+ {
+ if (yychar == 0) goto yyabort;
+#if YYDEBUG
+ if (yydebug)
+ {
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+ printf("yydebug: state %d, error recovery discards token %d (%s)\n",
+ yystate, yychar, yys);
+ }
+#endif
+ yychar = (-1);
+ goto yyloop;
+ }
+yyreduce:
+#if YYDEBUG
+ if (yydebug)
+ printf("yydebug: state %d, reducing by rule %d (%s)\n",
+ yystate, yyn, yyrule[yyn]);
+#endif
+ yym = yylen[yyn];
+ yyval = yyvsp[1-yym];
+ switch (yyn)
+ {
+case 1:
+#line 51 "a2p.y"
+{ root = oper4(OPROG,yyvsp[-1],begins,yyvsp[0],ends); }
+break;
+case 2:
+#line 55 "a2p.y"
+{ begins = oper4(OJUNK,begins,yyvsp[-3],yyvsp[-2],yyvsp[0]); in_begin = FALSE;
+ yyval = Nullop; }
+break;
+case 3:
+#line 60 "a2p.y"
+{ ends = oper3(OJUNK,ends,yyvsp[-2],yyvsp[-1]); yyval = Nullop; }
+break;
+case 4:
+#line 62 "a2p.y"
+{ yyval = yyvsp[-1]; }
+break;
+case 5:
+#line 66 "a2p.y"
+{ yyval = oper3(OHUNKS,yyvsp[-2],yyvsp[-1],yyvsp[0]); }
+break;
+case 6:
+#line 68 "a2p.y"
+{ yyval = Nullop; }
+break;
+case 7:
+#line 72 "a2p.y"
+{ yyval = oper1(OHUNK,yyvsp[0]); need_entire = TRUE; }
+break;
+case 8:
+#line 74 "a2p.y"
+{ yyval = oper2(OHUNK,yyvsp[-4],oper2(OJUNK,yyvsp[-2],yyvsp[-1])); }
+break;
+case 9:
+#line 76 "a2p.y"
+{ fixfargs(yyvsp[-8],yyvsp[-6],0); yyval = oper5(OUSERDEF,yyvsp[-8],yyvsp[-6],yyvsp[-4],yyvsp[-2],yyvsp[-1]); }
+break;
+case 10:
+#line 78 "a2p.y"
+{ yyval = oper2(OHUNK,Nullop,oper2(OJUNK,yyvsp[-2],yyvsp[-1])); }
+break;
+case 13:
+#line 84 "a2p.y"
+{ yyval = rememberargs(yyval); }
+break;
+case 14:
+#line 88 "a2p.y"
+{ yyval = oper1(OPAT,yyvsp[0]); }
+break;
+case 15:
+#line 90 "a2p.y"
+{ yyval = oper2(ORANGE,yyvsp[-2],yyvsp[0]); }
+break;
+case 20:
+#line 98 "a2p.y"
+{ yyval = oper3(OCOND,yyvsp[-4],yyvsp[-2],yyvsp[0]); }
+break;
+case 21:
+#line 103 "a2p.y"
+{ yyval = oper1(OCPAREN,yyvsp[-1]); }
+break;
+case 22:
+#line 105 "a2p.y"
+{ yyval = oper3(OCANDAND,yyvsp[-3],yyvsp[-1],yyvsp[0]); }
+break;
+case 23:
+#line 107 "a2p.y"
+{ yyval = oper3(OCOROR,yyvsp[-3],yyvsp[-1],yyvsp[0]); }
+break;
+case 24:
+#line 109 "a2p.y"
+{ yyval = oper1(OCNOT,yyvsp[0]); }
+break;
+case 25:
+#line 113 "a2p.y"
+{ yyval = oper3(ORELOP,yyvsp[-1],yyvsp[-2],yyvsp[0]); }
+break;
+case 26:
+#line 115 "a2p.y"
+{ yyval = oper3(ORELOP,string(">",1),yyvsp[-2],yyvsp[0]); }
+break;
+case 27:
+#line 117 "a2p.y"
+{ yyval = oper3(ORELOP,string("<",1),yyvsp[-2],yyvsp[0]); }
+break;
+case 28:
+#line 119 "a2p.y"
+{ yyval = oper1(ORPAREN,yyvsp[-1]); }
+break;
+case 29:
+#line 123 "a2p.y"
+{ yyval = oper3(OMATCHOP,yyvsp[-1],yyvsp[-2],yyvsp[0]); }
+break;
+case 30:
+#line 125 "a2p.y"
+{ yyval = oper3(OMATCHOP,yyvsp[-1],yyvsp[-2],oper1(OREGEX,yyvsp[0])); }
+break;
+case 31:
+#line 127 "a2p.y"
+{ yyval = oper1(OREGEX,yyvsp[0]); }
+break;
+case 32:
+#line 129 "a2p.y"
+{ yyval = oper1(OMPAREN,yyvsp[-1]); }
+break;
+case 33:
+#line 133 "a2p.y"
+{ yyval = yyvsp[0]; }
+break;
+case 34:
+#line 135 "a2p.y"
+{ yyval = oper2(OCONCAT,yyvsp[-1],yyvsp[0]); }
+break;
+case 35:
+#line 137 "a2p.y"
+{ yyval = oper3(OCOND,yyvsp[-4],yyvsp[-2],yyvsp[0]); }
+break;
+case 36:
+#line 139 "a2p.y"
+{ yyval = oper3(OASSIGN,yyvsp[-1],yyvsp[-2],yyvsp[0]);
+ if ((ops[yyvsp[-2]].ival & 255) == OFLD)
+ lval_field = TRUE;
+ if ((ops[yyvsp[-2]].ival & 255) == OVFLD)
+ lval_field = TRUE;
+ }
+break;
+case 37:
+#line 148 "a2p.y"
+{ yyval = yyvsp[0]; }
+break;
+case 38:
+#line 150 "a2p.y"
+{ yyval = oper1(ONUM,yyvsp[0]); }
+break;
+case 39:
+#line 152 "a2p.y"
+{ yyval = oper1(OSTR,yyvsp[0]); }
+break;
+case 40:
+#line 154 "a2p.y"
+{ yyval = oper2(OADD,yyvsp[-2],yyvsp[0]); }
+break;
+case 41:
+#line 156 "a2p.y"
+{ yyval = oper2(OSUBTRACT,yyvsp[-2],yyvsp[0]); }
+break;
+case 42:
+#line 158 "a2p.y"
+{ yyval = oper2(OMULT,yyvsp[-2],yyvsp[0]); }
+break;
+case 43:
+#line 160 "a2p.y"
+{ yyval = oper2(ODIV,yyvsp[-2],yyvsp[0]); }
+break;
+case 44:
+#line 162 "a2p.y"
+{ yyval = oper2(OMOD,yyvsp[-2],yyvsp[0]); }
+break;
+case 45:
+#line 164 "a2p.y"
+{ yyval = oper2(OPOW,yyvsp[-2],yyvsp[0]); }
+break;
+case 46:
+#line 166 "a2p.y"
+{ yyval = oper2(ODEFINED,aryrefarg(yyvsp[0]),yyvsp[-2]); }
+break;
+case 47:
+#line 168 "a2p.y"
+{ yyval = oper1(OPOSTINCR,yyvsp[-1]); }
+break;
+case 48:
+#line 170 "a2p.y"
+{ yyval = oper1(OPOSTDECR,yyvsp[-1]); }
+break;
+case 49:
+#line 172 "a2p.y"
+{ yyval = oper1(OPREINCR,yyvsp[0]); }
+break;
+case 50:
+#line 174 "a2p.y"
+{ yyval = oper1(OPREDECR,yyvsp[0]); }
+break;
+case 51:
+#line 176 "a2p.y"
+{ yyval = oper1(OUMINUS,yyvsp[0]); }
+break;
+case 52:
+#line 178 "a2p.y"
+{ yyval = oper1(OUPLUS,yyvsp[0]); }
+break;
+case 53:
+#line 180 "a2p.y"
+{ yyval = oper1(OPAREN,yyvsp[-1]); }
+break;
+case 54:
+#line 182 "a2p.y"
+{ yyval = oper0(OGETLINE); }
+break;
+case 55:
+#line 184 "a2p.y"
+{ yyval = oper1(OGETLINE,yyvsp[0]); }
+break;
+case 56:
+#line 186 "a2p.y"
+{ yyval = oper3(OGETLINE,Nullop,string("<",1),yyvsp[0]);
+ if (ops[yyvsp[0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+break;
+case 57:
+#line 189 "a2p.y"
+{ yyval = oper3(OGETLINE,yyvsp[-2],string("<",1),yyvsp[0]);
+ if (ops[yyvsp[0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+break;
+case 58:
+#line 192 "a2p.y"
+{ yyval = oper3(OGETLINE,Nullop,string("|",1),yyvsp[-2]);
+ if (ops[yyvsp[-2]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+break;
+case 59:
+#line 195 "a2p.y"
+{ yyval = oper3(OGETLINE,yyvsp[0],string("|",1),yyvsp[-3]);
+ if (ops[yyvsp[-3]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+break;
+case 60:
+#line 198 "a2p.y"
+{ yyval = oper0(yyvsp[0]); need_entire = do_chop = TRUE; }
+break;
+case 61:
+#line 200 "a2p.y"
+{ yyval = oper1(yyvsp[-2],Nullop); need_entire = do_chop = TRUE; }
+break;
+case 62:
+#line 202 "a2p.y"
+{ yyval = oper1(yyvsp[-3],yyvsp[-1]); }
+break;
+case 63:
+#line 204 "a2p.y"
+{ yyval = oper1(yyvsp[-3],yyvsp[-1]); }
+break;
+case 64:
+#line 206 "a2p.y"
+{ yyval = oper2(OUSERFUN,yyvsp[-3],yyvsp[-1]); }
+break;
+case 65:
+#line 208 "a2p.y"
+{ yyval = oper1(OSPRINTF,yyvsp[0]); }
+break;
+case 66:
+#line 210 "a2p.y"
+{ yyval = oper3(OSUBSTR,yyvsp[-5],yyvsp[-3],yyvsp[-1]); }
+break;
+case 67:
+#line 212 "a2p.y"
+{ yyval = oper2(OSUBSTR,yyvsp[-3],yyvsp[-1]); }
+break;
+case 68:
+#line 214 "a2p.y"
+{ yyval = oper3(OSPLIT,yyvsp[-5],aryrefarg(numary(yyvsp[-3])),yyvsp[-1]); }
+break;
+case 69:
+#line 216 "a2p.y"
+{ yyval = oper3(OSPLIT,yyvsp[-5],aryrefarg(numary(yyvsp[-3])),oper1(OREGEX,yyvsp[-1]));}
+break;
+case 70:
+#line 218 "a2p.y"
+{ yyval = oper2(OSPLIT,yyvsp[-3],aryrefarg(numary(yyvsp[-1]))); }
+break;
+case 71:
+#line 220 "a2p.y"
+{ yyval = oper2(OINDEX,yyvsp[-3],yyvsp[-1]); }
+break;
+case 72:
+#line 222 "a2p.y"
+{ yyval = oper2(OMATCH,yyvsp[-3],oper1(OREGEX,yyvsp[-1])); }
+break;
+case 73:
+#line 224 "a2p.y"
+{ yyval = oper2(OMATCH,yyvsp[-3],yyvsp[-1]); }
+break;
+case 74:
+#line 226 "a2p.y"
+{ yyval = oper2(OSUB,yyvsp[-3],yyvsp[-1]); }
+break;
+case 75:
+#line 228 "a2p.y"
+{ yyval = oper2(OSUB,oper1(OREGEX,yyvsp[-3]),yyvsp[-1]); }
+break;
+case 76:
+#line 230 "a2p.y"
+{ yyval = oper2(OGSUB,yyvsp[-3],yyvsp[-1]); }
+break;
+case 77:
+#line 232 "a2p.y"
+{ yyval = oper2(OGSUB,oper1(OREGEX,yyvsp[-3]),yyvsp[-1]); }
+break;
+case 78:
+#line 234 "a2p.y"
+{ yyval = oper3(OSUB,yyvsp[-5],yyvsp[-3],yyvsp[-1]); }
+break;
+case 79:
+#line 236 "a2p.y"
+{ yyval = oper3(OSUB,oper1(OREGEX,yyvsp[-5]),yyvsp[-3],yyvsp[-1]); }
+break;
+case 80:
+#line 238 "a2p.y"
+{ yyval = oper3(OGSUB,yyvsp[-5],yyvsp[-3],yyvsp[-1]); }
+break;
+case 81:
+#line 240 "a2p.y"
+{ yyval = oper3(OGSUB,oper1(OREGEX,yyvsp[-5]),yyvsp[-3],yyvsp[-1]); }
+break;
+case 82:
+#line 244 "a2p.y"
+{ yyval = oper1(OVAR,yyvsp[0]); }
+break;
+case 83:
+#line 246 "a2p.y"
+{ yyval = oper2(OVAR,aryrefarg(yyvsp[-3]),yyvsp[-1]); }
+break;
+case 84:
+#line 248 "a2p.y"
+{ yyval = oper1(OFLD,yyvsp[0]); }
+break;
+case 85:
+#line 250 "a2p.y"
+{ yyval = oper1(OVFLD,yyvsp[0]); }
+break;
+case 88:
+#line 257 "a2p.y"
+{ yyval = Nullop; }
+break;
+case 89:
+#line 261 "a2p.y"
+{ yyval = oper3(OCOMMA,yyvsp[-3],yyvsp[-1],yyvsp[0]); }
+break;
+case 90:
+#line 263 "a2p.y"
+{ yyval = oper3(OCOMMA,yyvsp[-3],yyvsp[-1],yyvsp[0]); }
+break;
+case 91:
+#line 265 "a2p.y"
+{ yyval = yyvsp[-1]; }
+break;
+case 92:
+#line 269 "a2p.y"
+{ yyval = oper2(OJUNK,yyvsp[-1],yyvsp[0]); }
+break;
+case 93:
+#line 271 "a2p.y"
+{ yyval = Nullop; }
+break;
+case 94:
+#line 275 "a2p.y"
+{ yyval = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
+break;
+case 95:
+#line 277 "a2p.y"
+{ yyval = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
+break;
+case 96:
+#line 279 "a2p.y"
+{ yyval = oper0(ONEWLINE); }
+break;
+case 97:
+#line 281 "a2p.y"
+{ yyval = oper1(OCOMMENT,yyvsp[0]); }
+break;
+case 98:
+#line 285 "a2p.y"
+{ yyval = oper2(OJUNK,yyvsp[-1],yyvsp[0]); }
+break;
+case 99:
+#line 287 "a2p.y"
+{ yyval = Nullop; }
+break;
+case 100:
+#line 291 "a2p.y"
+{ yyval = oper0(ONEWLINE); }
+break;
+case 101:
+#line 293 "a2p.y"
+{ yyval = oper1(OCOMMENT,yyvsp[0]); }
+break;
+case 102:
+#line 298 "a2p.y"
+{ yyval = oper2(OJUNK,oper0(OSEMICOLON),yyvsp[0]); }
+break;
+case 103:
+#line 300 "a2p.y"
+{ yyval = oper2(OJUNK,oper0(OSNEWLINE),yyvsp[0]); }
+break;
+case 104:
+#line 302 "a2p.y"
+{ yyval = oper2(OJUNK,oper0(OSNEWLINE),yyvsp[0]); }
+break;
+case 105:
+#line 304 "a2p.y"
+{ yyval = oper2(OJUNK,oper1(OSCOMMENT,yyvsp[-1]),yyvsp[0]); }
+break;
+case 106:
+#line 308 "a2p.y"
+{ yyval = oper2(OSTATES,yyvsp[-1],yyvsp[0]); }
+break;
+case 107:
+#line 310 "a2p.y"
+{ yyval = Nullop; }
+break;
+case 108:
+#line 315 "a2p.y"
+{ yyval = oper2(OJUNK,oper2(OSTATE,yyvsp[-2],yyvsp[-1]),yyvsp[0]); }
+break;
+case 109:
+#line 317 "a2p.y"
+{ yyval = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),yyvsp[0])); }
+break;
+case 110:
+#line 319 "a2p.y"
+{ yyval = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),yyvsp[0])); }
+break;
+case 113:
+#line 325 "a2p.y"
+{ yyval = Nullop; }
+break;
+case 115:
+#line 331 "a2p.y"
+{ yyval = oper3(OPRINT,yyvsp[-2],yyvsp[-1],yyvsp[0]);
+ do_opens = TRUE;
+ saw_ORS = saw_OFS = TRUE;
+ if (!yyvsp[-2]) need_entire = TRUE;
+ if (ops[yyvsp[0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+break;
+case 116:
+#line 337 "a2p.y"
+{ yyval = oper1(OPRINT,yyvsp[0]);
+ if (!yyvsp[0]) need_entire = TRUE;
+ saw_ORS = saw_OFS = TRUE;
+ }
+break;
+case 117:
+#line 342 "a2p.y"
+{ yyval = oper3(OPRINTF,yyvsp[-2],yyvsp[-1],yyvsp[0]);
+ do_opens = TRUE;
+ if (!yyvsp[-2]) need_entire = TRUE;
+ if (ops[yyvsp[0]].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+break;
+case 118:
+#line 347 "a2p.y"
+{ yyval = oper1(OPRINTF,yyvsp[0]);
+ if (!yyvsp[0]) need_entire = TRUE;
+ }
+break;
+case 119:
+#line 351 "a2p.y"
+{ yyval = oper0(OBREAK); }
+break;
+case 120:
+#line 353 "a2p.y"
+{ yyval = oper0(ONEXT); }
+break;
+case 121:
+#line 355 "a2p.y"
+{ yyval = oper0(OEXIT); }
+break;
+case 122:
+#line 357 "a2p.y"
+{ yyval = oper1(OEXIT,yyvsp[0]); }
+break;
+case 123:
+#line 359 "a2p.y"
+{ yyval = oper0(OCONTINUE); }
+break;
+case 124:
+#line 361 "a2p.y"
+{ yyval = oper0(ORETURN); }
+break;
+case 125:
+#line 363 "a2p.y"
+{ yyval = oper1(ORETURN,yyvsp[0]); }
+break;
+case 126:
+#line 365 "a2p.y"
+{ yyval = oper2(ODELETE,aryrefarg(yyvsp[-3]),yyvsp[-1]); }
+break;
+case 127:
+#line 369 "a2p.y"
+{ yyval = oper1(OREDIR,string(">",1)); }
+break;
+case 128:
+#line 371 "a2p.y"
+{ yyval = oper1(OREDIR,string(">>",2)); }
+break;
+case 129:
+#line 373 "a2p.y"
+{ yyval = oper1(OREDIR,string("|",1)); }
+break;
+case 130:
+#line 378 "a2p.y"
+{ yyval = oper2(OIF,yyvsp[-3],bl(yyvsp[0],yyvsp[-1])); }
+break;
+case 131:
+#line 380 "a2p.y"
+{ yyval = oper3(OIF,yyvsp[-6],bl(yyvsp[-3],yyvsp[-4]),bl(yyvsp[0],yyvsp[-1])); }
+break;
+case 132:
+#line 382 "a2p.y"
+{ yyval = oper2(OWHILE,yyvsp[-3],bl(yyvsp[0],yyvsp[-1])); }
+break;
+case 133:
+#line 384 "a2p.y"
+{ yyval = oper2(ODO,bl(yyvsp[-4],yyvsp[-5]),yyvsp[-1]); }
+break;
+case 134:
+#line 386 "a2p.y"
+{ yyval = oper4(OFOR,yyvsp[-7],yyvsp[-5],yyvsp[-3],bl(yyvsp[0],yyvsp[-1])); }
+break;
+case 135:
+#line 388 "a2p.y"
+{ yyval = oper4(OFOR,yyvsp[-6],string("",0),yyvsp[-3],bl(yyvsp[0],yyvsp[-1])); }
+break;
+case 136:
+#line 390 "a2p.y"
+{ yyval = oper2(OFORIN,yyvsp[-3],bl(yyvsp[0],yyvsp[-1])); }
+break;
+case 137:
+#line 392 "a2p.y"
+{ yyval = oper3(OBLOCK,oper2(OJUNK,yyvsp[-3],yyvsp[-2]),Nullop,yyvsp[0]); }
+break;
+#line 2674 "y.tab.c"
+ }
+ yyssp -= yym;
+ yystate = *yyssp;
+ yyvsp -= yym;
+ yym = yylhs[yyn];
+ if (yystate == 0 && yym == 0)
+ {
+#if YYDEBUG
+ if (yydebug)
+ printf("yydebug: after reduction, shifting from state 0 to\
+ state %d\n", YYFINAL);
+#endif
+ yystate = YYFINAL;
+ *++yyssp = YYFINAL;
+ *++yyvsp = yyval;
+ if (yychar < 0)
+ {
+ if ((yychar = yylex()) < 0) yychar = 0;
+#if YYDEBUG
+ if (yydebug)
+ {
+ yys = 0;
+ if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
+ if (!yys) yys = "illegal-symbol";
+ printf("yydebug: state %d, reading %d (%s)\n",
+ YYFINAL, yychar, yys);
+ }
+#endif
+ }
+ if (yychar == 0) goto yyaccept;
+ goto yyloop;
+ }
+ if ((yyn = yygindex[yym]) && (yyn += yystate) >= 0 &&
+ yyn <= YYTABLESIZE && yycheck[yyn] == yystate)
+ yystate = yytable[yyn];
+ else
+ yystate = yydgoto[yym];
+#if YYDEBUG
+ if (yydebug)
+ printf("yydebug: after reduction, shifting from state %d \
+to state %d\n", *yyssp, yystate);
+#endif
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+ goto yyoverflow;
+ }
+ *++yyssp = yystate;
+ *++yyvsp = yyval;
+ goto yyloop;
+yyoverflow:
+ yyerror("yacc stack overflow");
+yyabort:
+ return (1);
+yyaccept:
+ return (0);
+}
diff --git a/contrib/perl5/x2p/a2p.h b/contrib/perl5/x2p/a2p.h
new file mode 100644
index 000000000000..80530469ed04
--- /dev/null
+++ b/contrib/perl5/x2p/a2p.h
@@ -0,0 +1,482 @@
+/* $RCSfile: a2p.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:09 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: a2p.h,v $
+ */
+
+#define VOIDUSED 1
+
+#ifdef WIN32
+#define _INC_WIN32_PERL5 /* kludge around win32 stdio layer */
+#endif
+
+#ifdef VMS
+# include "config.h"
+#else
+# include "../config.h"
+#endif
+
+#if defined(__STDC__) || defined(vax11c) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus)
+# define STANDARD_C 1
+#endif
+
+#ifdef WIN32
+#undef USE_STDIO_PTR /* XXX fast gets won't work, must investigate */
+# ifndef STANDARD_C
+# define STANDARD_C
+# endif
+# if defined(__BORLANDC__)
+# pragma warn -ccc
+# pragma warn -rch
+# pragma warn -sig
+# pragma warn -pia
+# pragma warn -par
+# pragma warn -aus
+# pragma warn -use
+# pragma warn -csu
+# pragma warn -pro
+# elif defined(_MSC_VER)
+# elif defined(__MINGW32__)
+# endif
+#endif
+
+/* Use all the "standard" definitions? */
+#if defined(STANDARD_C) && defined(I_STDLIB)
+# include <stdlib.h>
+#endif /* STANDARD_C */
+
+#include <stdio.h>
+
+#ifdef I_MATH
+#include <math.h>
+#endif
+
+#ifdef I_SYS_TYPES
+# include <sys/types.h>
+#endif
+
+#ifdef USE_NEXT_CTYPE
+
+#if NX_CURRENT_COMPILER_RELEASE >= 400
+#include <objc/NXCType.h>
+#else /* NX_CURRENT_COMPILER_RELEASE < 400 */
+#include <appkit/NXCType.h>
+#endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */
+
+#else /* !USE_NEXT_CTYPE */
+#include <ctype.h>
+#endif /* USE_NEXT_CTYPE */
+
+#define MEM_SIZE Size_t
+
+#ifdef STANDARD_C
+# include <stdlib.h>
+#else
+ Malloc_t malloc _((MEM_SIZE nbytes));
+ Malloc_t calloc _((MEM_SIZE elements, MEM_SIZE size));
+ Malloc_t realloc _((Malloc_t where, MEM_SIZE nbytes));
+ Free_t free _((Malloc_t where));
+#endif
+
+#if defined(I_STRING) || defined(__cplusplus)
+# include <string.h>
+#else
+# include <strings.h>
+#endif
+
+#if !defined(HAS_BCOPY) || defined(__cplusplus)
+# define bcopy(s1,s2,l) memcpy(s2,s1,l)
+#endif
+#if !defined(HAS_BZERO) || defined(__cplusplus)
+# define bzero(s,l) memset(s,0,l)
+#endif
+
+#if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr)
+#define strchr index
+#define strrchr rindex
+#endif
+
+
+#ifdef I_TIME
+# include <time.h>
+#endif
+
+#ifdef I_SYS_TIME
+# ifdef I_SYS_TIME_KERNEL
+# define KERNEL
+# endif
+# include <sys/time.h>
+# ifdef I_SYS_TIME_KERNEL
+# undef KERNEL
+# endif
+#endif
+
+#ifndef MSDOS
+# if defined(HAS_TIMES) && defined(I_SYS_TIMES)
+# include <sys/times.h>
+# endif
+#endif
+
+#ifdef DOSISH
+# if defined(OS2)
+# include "../os2ish.h"
+# else
+# include "../dosish.h"
+# endif
+#else
+# if defined(VMS)
+# define NO_PERL_TYPEDEFS
+# include "vmsish.h"
+# endif
+#endif
+
+#ifndef STANDARD_C
+/* All of these are in stdlib.h or time.h for ANSI C */
+Time_t time();
+struct tm *gmtime(), *localtime();
+char *strchr(), *strrchr();
+char *strcpy(), *strcat();
+#endif /* ! STANDARD_C */
+
+#ifdef VMS
+# include "handy.h"
+#else
+# include "../handy.h"
+#endif
+
+#undef Nullfp
+#define Nullfp Null(FILE*)
+
+#define Nullop 0
+
+#define OPROG 1
+#define OJUNK 2
+#define OHUNKS 3
+#define ORANGE 4
+#define OPAT 5
+#define OHUNK 6
+#define OPPAREN 7
+#define OPANDAND 8
+#define OPOROR 9
+#define OPNOT 10
+#define OCPAREN 11
+#define OCANDAND 12
+#define OCOROR 13
+#define OCNOT 14
+#define ORELOP 15
+#define ORPAREN 16
+#define OMATCHOP 17
+#define OMPAREN 18
+#define OCONCAT 19
+#define OASSIGN 20
+#define OADD 21
+#define OSUBTRACT 22
+#define OMULT 23
+#define ODIV 24
+#define OMOD 25
+#define OPOSTINCR 26
+#define OPOSTDECR 27
+#define OPREINCR 28
+#define OPREDECR 29
+#define OUMINUS 30
+#define OUPLUS 31
+#define OPAREN 32
+#define OGETLINE 33
+#define OSPRINTF 34
+#define OSUBSTR 35
+#define OSTRING 36
+#define OSPLIT 37
+#define OSNEWLINE 38
+#define OINDEX 39
+#define ONUM 40
+#define OSTR 41
+#define OVAR 42
+#define OFLD 43
+#define ONEWLINE 44
+#define OCOMMENT 45
+#define OCOMMA 46
+#define OSEMICOLON 47
+#define OSCOMMENT 48
+#define OSTATES 49
+#define OSTATE 50
+#define OPRINT 51
+#define OPRINTF 52
+#define OBREAK 53
+#define ONEXT 54
+#define OEXIT 55
+#define OCONTINUE 56
+#define OREDIR 57
+#define OIF 58
+#define OWHILE 59
+#define OFOR 60
+#define OFORIN 61
+#define OVFLD 62
+#define OBLOCK 63
+#define OREGEX 64
+#define OLENGTH 65
+#define OLOG 66
+#define OEXP 67
+#define OSQRT 68
+#define OINT 69
+#define ODO 70
+#define OPOW 71
+#define OSUB 72
+#define OGSUB 73
+#define OMATCH 74
+#define OUSERFUN 75
+#define OUSERDEF 76
+#define OCLOSE 77
+#define OATAN2 78
+#define OSIN 79
+#define OCOS 80
+#define ORAND 81
+#define OSRAND 82
+#define ODELETE 83
+#define OSYSTEM 84
+#define OCOND 85
+#define ORETURN 86
+#define ODEFINED 87
+#define OSTAR 88
+
+#ifdef DOINIT
+char *opname[] = {
+ "0",
+ "PROG",
+ "JUNK",
+ "HUNKS",
+ "RANGE",
+ "PAT",
+ "HUNK",
+ "PPAREN",
+ "PANDAND",
+ "POROR",
+ "PNOT",
+ "CPAREN",
+ "CANDAND",
+ "COROR",
+ "CNOT",
+ "RELOP",
+ "RPAREN",
+ "MATCHOP",
+ "MPAREN",
+ "CONCAT",
+ "ASSIGN",
+ "ADD",
+ "SUBTRACT",
+ "MULT",
+ "DIV",
+ "MOD",
+ "POSTINCR",
+ "POSTDECR",
+ "PREINCR",
+ "PREDECR",
+ "UMINUS",
+ "UPLUS",
+ "PAREN",
+ "GETLINE",
+ "SPRINTF",
+ "SUBSTR",
+ "STRING",
+ "SPLIT",
+ "SNEWLINE",
+ "INDEX",
+ "NUM",
+ "STR",
+ "VAR",
+ "FLD",
+ "NEWLINE",
+ "COMMENT",
+ "COMMA",
+ "SEMICOLON",
+ "SCOMMENT",
+ "STATES",
+ "STATE",
+ "PRINT",
+ "PRINTF",
+ "BREAK",
+ "NEXT",
+ "EXIT",
+ "CONTINUE",
+ "REDIR",
+ "IF",
+ "WHILE",
+ "FOR",
+ "FORIN",
+ "VFLD",
+ "BLOCK",
+ "REGEX",
+ "LENGTH",
+ "LOG",
+ "EXP",
+ "SQRT",
+ "INT",
+ "DO",
+ "POW",
+ "SUB",
+ "GSUB",
+ "MATCH",
+ "USERFUN",
+ "USERDEF",
+ "CLOSE",
+ "ATAN2",
+ "SIN",
+ "COS",
+ "RAND",
+ "SRAND",
+ "DELETE",
+ "SYSTEM",
+ "COND",
+ "RETURN",
+ "DEFINED",
+ "STAR",
+ "89"
+};
+#else
+extern char *opname[];
+#endif
+
+EXT int mop INIT(1);
+
+union u_ops {
+ int ival;
+ char *cval;
+};
+#if defined(iAPX286) || defined(M_I286) || defined(I80286) /* 80286 hack */
+#define OPSMAX (64000/sizeof(union u_ops)) /* approx. max segment size */
+#else
+#define OPSMAX 50000
+#endif /* 80286 hack */
+EXT union u_ops ops[OPSMAX];
+
+typedef struct string STR;
+typedef struct htbl HASH;
+
+#include "str.h"
+#include "hash.h"
+
+
+/* A string is TRUE if not "" or "0". */
+#define True(val) (tmps = (val), (*tmps && !(*tmps == '0' && !tmps[1])))
+EXT char *Yes INIT("1");
+EXT char *No INIT("");
+
+#define str_true(str) (Str = (str), (Str->str_pok ? True(Str->str_ptr) : (Str->str_nok ? (Str->str_nval != 0.0) : 0 )))
+
+#define str_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(buf,"num(%g)",Str->str_nval),buf) : "" )))
+#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
+#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_nval : str_2num(Str)))
+EXT STR *Str;
+
+#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len)
+
+/* Prototypes for things in a2p.c */
+int aryrefarg _(( int arg ));
+int bl _(( int arg, int maybe ));
+void dump _(( int branch ));
+int fixfargs _(( int name, int arg, int prevargs ));
+int fixrargs _(( char *name, int arg, int prevargs ));
+void fixup _(( STR *str ));
+int numary _(( int arg ));
+int oper0 _(( int type ));
+int oper1 _(( int type, int arg1 ));
+int oper2 _(( int type, int arg1, int arg2 ));
+int oper3 _(( int type, int arg1, int arg2, int arg3 ));
+int oper4 _(( int type, int arg1, int arg2, int arg3, int arg4 ));
+int oper5 _(( int type, int arg1, int arg2, int arg3, int arg4, int arg5 ));
+void putlines _(( STR *str ));
+void putone _(( void ));
+int rememberargs _(( int arg ));
+char * scannum _(( char *s ));
+char * scanpat _(( char *s ));
+int string _(( char *ptr, int len ));
+void yyerror _(( char *s ));
+int yylex _(( void ));
+
+EXT int line INIT(0);
+
+EXT FILE *rsfp;
+EXT char buf[2048];
+EXT char *bufptr INIT(buf);
+
+EXT STR *linestr INIT(Nullstr);
+
+EXT char tokenbuf[2048];
+EXT int expectterm INIT(TRUE);
+
+#ifdef DEBUGGING
+EXT int debug INIT(0);
+EXT int dlevel INIT(0);
+#define YYDEBUG 1
+extern int yydebug;
+#else
+# ifndef YYDEBUG
+# define YYDEBUG 0
+# endif
+#endif
+
+EXT STR *freestrroot INIT(Nullstr);
+
+EXT STR str_no;
+EXT STR str_yes;
+
+EXT bool do_split INIT(FALSE);
+EXT bool split_to_array INIT(FALSE);
+EXT bool set_array_base INIT(FALSE);
+EXT bool saw_RS INIT(FALSE);
+EXT bool saw_OFS INIT(FALSE);
+EXT bool saw_ORS INIT(FALSE);
+EXT bool saw_line_op INIT(FALSE);
+EXT bool in_begin INIT(TRUE);
+EXT bool do_opens INIT(FALSE);
+EXT bool do_fancy_opens INIT(FALSE);
+EXT bool lval_field INIT(FALSE);
+EXT bool do_chop INIT(FALSE);
+EXT bool need_entire INIT(FALSE);
+EXT bool absmaxfld INIT(FALSE);
+EXT bool saw_altinput INIT(FALSE);
+
+EXT bool nomemok INIT(FALSE);
+
+EXT char const_FS INIT(0);
+EXT char *namelist INIT(Nullch);
+EXT char fswitch INIT(0);
+EXT bool old_awk INIT(0);
+
+EXT int saw_FS INIT(0);
+EXT int maxfld INIT(0);
+EXT int arymax INIT(0);
+EXT char *nameary[100];
+
+EXT STR *opens;
+
+EXT HASH *symtab;
+EXT HASH *curarghash;
+
+#define P_MIN 0
+#define P_LISTOP 5
+#define P_COMMA 10
+#define P_ASSIGN 15
+#define P_COND 20
+#define P_DOTDOT 25
+#define P_OROR 30
+#define P_ANDAND 35
+#define P_OR 40
+#define P_AND 45
+#define P_EQ 50
+#define P_REL 55
+#define P_UNI 60
+#define P_FILETEST 65
+#define P_SHIFT 70
+#define P_ADD 75
+#define P_MUL 80
+#define P_MATCH 85
+#define P_UNARY 90
+#define P_POW 95
+#define P_AUTO 100
+#define P_MAX 999
+
+EXT int an;
diff --git a/contrib/perl5/x2p/a2p.pod b/contrib/perl5/x2p/a2p.pod
new file mode 100644
index 000000000000..fa726fb101c7
--- /dev/null
+++ b/contrib/perl5/x2p/a2p.pod
@@ -0,0 +1,162 @@
+=head1 NAME
+
+a2p - Awk to Perl translator
+
+=head1 SYNOPSIS
+
+B<a2p [options] filename>
+
+=head1 DESCRIPTION
+
+I<A2p> takes an awk script specified on the command line (or from
+standard input) and produces a comparable I<perl> script on the
+standard output.
+
+=head2 Options
+
+Options include:
+
+=over 5
+
+=item B<-DE<lt>numberE<gt>>
+
+sets debugging flags.
+
+=item B<-FE<lt>characterE<gt>>
+
+tells a2p that this awk script is always invoked with this B<-F>
+switch.
+
+=item B<-nE<lt>fieldlistE<gt>>
+
+specifies the names of the input fields if input does not have to be
+split into an array. If you were translating an awk script that
+processes the password file, you might say:
+
+ a2p -7 -nlogin.password.uid.gid.gcos.shell.home
+
+Any delimiter can be used to separate the field names.
+
+=item B<-E<lt>numberE<gt>>
+
+causes a2p to assume that input will always have that many fields.
+
+=item B<-o>
+
+tells a2p to use old awk behavior. For now, the only difference is
+that old awk always has a line loop, even if there are no line
+actions, whereas new awk does not.
+
+=back
+
+=head2 "Considerations"
+
+A2p cannot do as good a job translating as a human would, but it
+usually does pretty well. There are some areas where you may want to
+examine the perl script produced and tweak it some. Here are some of
+them, in no particular order.
+
+There is an awk idiom of putting int() around a string expression to
+force numeric interpretation, even though the argument is always
+integer anyway. This is generally unneeded in perl, but a2p can't
+tell if the argument is always going to be integer, so it leaves it
+in. You may wish to remove it.
+
+Perl differentiates numeric comparison from string comparison. Awk
+has one operator for both that decides at run time which comparison to
+do. A2p does not try to do a complete job of awk emulation at this
+point. Instead it guesses which one you want. It's almost always
+right, but it can be spoofed. All such guesses are marked with the
+comment "C<#???>". You should go through and check them. You might
+want to run at least once with the B<-w> switch to perl, which will
+warn you if you use == where you should have used eq.
+
+Perl does not attempt to emulate the behavior of awk in which
+nonexistent array elements spring into existence simply by being
+referenced. If somehow you are relying on this mechanism to create
+null entries for a subsequent for...in, they won't be there in perl.
+
+If a2p makes a split line that assigns to a list of variables that
+looks like (Fld1, Fld2, Fld3...) you may want to rerun a2p using the
+B<-n> option mentioned above. This will let you name the fields
+throughout the script. If it splits to an array instead, the script
+is probably referring to the number of fields somewhere.
+
+The exit statement in awk doesn't necessarily exit; it goes to the END
+block if there is one. Awk scripts that do contortions within the END
+block to bypass the block under such circumstances can be simplified
+by removing the conditional in the END block and just exiting directly
+from the perl script.
+
+Perl has two kinds of array, numerically-indexed and associative.
+Perl associative arrays are called "hashes". Awk arrays are usually
+translated to hashes, but if you happen to know that the index is
+always going to be numeric you could change the {...} to [...].
+Iteration over a hash is done using the keys() function, but iteration
+over an array is NOT. You might need to modify any loop that iterates
+over such an array.
+
+Awk starts by assuming OFMT has the value %.6g. Perl starts by
+assuming its equivalent, $#, to have the value %.20g. You'll want to
+set $# explicitly if you use the default value of OFMT.
+
+Near the top of the line loop will be the split operation that is
+implicit in the awk script. There are times when you can move this
+down past some conditionals that test the entire record so that the
+split is not done as often.
+
+For aesthetic reasons you may wish to change the array base $[ from 1
+back to perl's default of 0, but remember to change all array
+subscripts AND all substr() and index() operations to match.
+
+Cute comments that say "# Here is a workaround because awk is dumb"
+are passed through unmodified.
+
+Awk scripts are often embedded in a shell script that pipes stuff into
+and out of awk. Often the shell script wrapper can be incorporated
+into the perl script, since perl can start up pipes into and out of
+itself, and can do other things that awk can't do by itself.
+
+Scripts that refer to the special variables RSTART and RLENGTH can
+often be simplified by referring to the variables $`, $& and $', as
+long as they are within the scope of the pattern match that sets them.
+
+The produced perl script may have subroutines defined to deal with
+awk's semantics regarding getline and print. Since a2p usually picks
+correctness over efficiency. it is almost always possible to rewrite
+such code to be more efficient by discarding the semantic sugar.
+
+For efficiency, you may wish to remove the keyword from any return
+statement that is the last statement executed in a subroutine. A2p
+catches the most common case, but doesn't analyze embedded blocks for
+subtler cases.
+
+ARGV[0] translates to $ARGV0, but ARGV[n] translates to $ARGV[$n]. A
+loop that tries to iterate over ARGV[0] won't find it.
+
+=head1 ENVIRONMENT
+
+A2p uses no environment variables.
+
+=head1 AUTHOR
+
+Larry Wall E<lt>F<larry@wall.org>E<gt>
+
+=head1 FILES
+
+=head1 SEE ALSO
+
+ perl The perl compiler/interpreter
+
+ s2p sed to perl translator
+
+=head1 DIAGNOSTICS
+
+=head1 BUGS
+
+It would be possible to emulate awk's behavior in selecting string
+versus numeric operations at run time by inspection of the operands,
+but it would be gross and inefficient. Besides, a2p almost always
+guesses right.
+
+Storage for the awk syntax tree is currently static, and can run out.
diff --git a/contrib/perl5/x2p/a2p.y b/contrib/perl5/x2p/a2p.y
new file mode 100644
index 000000000000..2d3f23923e54
--- /dev/null
+++ b/contrib/perl5/x2p/a2p.y
@@ -0,0 +1,399 @@
+%{
+/* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: a2p.y,v $
+ */
+
+#include "INTERN.h"
+#include "a2p.h"
+
+int root;
+int begins = Nullop;
+int ends = Nullop;
+
+%}
+%token BEGIN END
+%token REGEX
+%token SEMINEW NEWLINE COMMENT
+%token FUN1 FUNN GRGR
+%token PRINT PRINTF SPRINTF SPLIT
+%token IF ELSE WHILE FOR IN
+%token EXIT NEXT BREAK CONTINUE RET
+%token GETLINE DO SUB GSUB MATCH
+%token FUNCTION USERFUN DELETE
+
+%right ASGNOP
+%right '?' ':'
+%left OROR
+%left ANDAND
+%left IN
+%left NUMBER VAR SUBSTR INDEX
+%left MATCHOP
+%left RELOP '<' '>'
+%left OR
+%left STRING
+%left '+' '-'
+%left '*' '/' '%'
+%right UMINUS
+%left NOT
+%right '^'
+%left INCR DECR
+%left FIELD VFIELD
+
+%%
+
+program : junk hunks
+ { root = oper4(OPROG,$1,begins,$2,ends); }
+ ;
+
+begin : BEGIN '{' maybe states '}' junk
+ { begins = oper4(OJUNK,begins,$3,$4,$6); in_begin = FALSE;
+ $$ = Nullop; }
+ ;
+
+end : END '{' maybe states '}'
+ { ends = oper3(OJUNK,ends,$3,$4); $$ = Nullop; }
+ | end NEWLINE
+ { $$ = $1; }
+ ;
+
+hunks : hunks hunk junk
+ { $$ = oper3(OHUNKS,$1,$2,$3); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+hunk : patpat
+ { $$ = oper1(OHUNK,$1); need_entire = TRUE; }
+ | patpat '{' maybe states '}'
+ { $$ = oper2(OHUNK,$1,oper2(OJUNK,$3,$4)); }
+ | FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}'
+ { fixfargs($2,$4,0); $$ = oper5(OUSERDEF,$2,$4,$6,$8,$9); }
+ | '{' maybe states '}'
+ { $$ = oper2(OHUNK,Nullop,oper2(OJUNK,$2,$3)); }
+ | begin
+ | end
+ ;
+
+arg_list: expr_list
+ { $$ = rememberargs($$); }
+ ;
+
+patpat : cond
+ { $$ = oper1(OPAT,$1); }
+ | cond ',' cond
+ { $$ = oper2(ORANGE,$1,$3); }
+ ;
+
+cond : expr
+ | match
+ | rel
+ | compound_cond
+ | cond '?' expr ':' expr
+ { $$ = oper3(OCOND,$1,$3,$5); }
+ ;
+
+compound_cond
+ : '(' compound_cond ')'
+ { $$ = oper1(OCPAREN,$2); }
+ | cond ANDAND maybe cond
+ { $$ = oper3(OCANDAND,$1,$3,$4); }
+ | cond OROR maybe cond
+ { $$ = oper3(OCOROR,$1,$3,$4); }
+ | NOT cond
+ { $$ = oper1(OCNOT,$2); }
+ ;
+
+rel : expr RELOP expr
+ { $$ = oper3(ORELOP,$2,$1,$3); }
+ | expr '>' expr
+ { $$ = oper3(ORELOP,string(">",1),$1,$3); }
+ | expr '<' expr
+ { $$ = oper3(ORELOP,string("<",1),$1,$3); }
+ | '(' rel ')'
+ { $$ = oper1(ORPAREN,$2); }
+ ;
+
+match : expr MATCHOP expr
+ { $$ = oper3(OMATCHOP,$2,$1,$3); }
+ | expr MATCHOP REGEX
+ { $$ = oper3(OMATCHOP,$2,$1,oper1(OREGEX,$3)); }
+ | REGEX %prec MATCHOP
+ { $$ = oper1(OREGEX,$1); }
+ | '(' match ')'
+ { $$ = oper1(OMPAREN,$2); }
+ ;
+
+expr : term
+ { $$ = $1; }
+ | expr term
+ { $$ = oper2(OCONCAT,$1,$2); }
+ | expr '?' expr ':' expr
+ { $$ = oper3(OCOND,$1,$3,$5); }
+ | variable ASGNOP cond
+ { $$ = oper3(OASSIGN,$2,$1,$3);
+ if ((ops[$1].ival & 255) == OFLD)
+ lval_field = TRUE;
+ if ((ops[$1].ival & 255) == OVFLD)
+ lval_field = TRUE;
+ }
+ ;
+
+term : variable
+ { $$ = $1; }
+ | NUMBER
+ { $$ = oper1(ONUM,$1); }
+ | STRING
+ { $$ = oper1(OSTR,$1); }
+ | term '+' term
+ { $$ = oper2(OADD,$1,$3); }
+ | term '-' term
+ { $$ = oper2(OSUBTRACT,$1,$3); }
+ | term '*' term
+ { $$ = oper2(OMULT,$1,$3); }
+ | term '/' term
+ { $$ = oper2(ODIV,$1,$3); }
+ | term '%' term
+ { $$ = oper2(OMOD,$1,$3); }
+ | term '^' term
+ { $$ = oper2(OPOW,$1,$3); }
+ | term IN VAR
+ { $$ = oper2(ODEFINED,aryrefarg($3),$1); }
+ | variable INCR
+ { $$ = oper1(OPOSTINCR,$1); }
+ | variable DECR
+ { $$ = oper1(OPOSTDECR,$1); }
+ | INCR variable
+ { $$ = oper1(OPREINCR,$2); }
+ | DECR variable
+ { $$ = oper1(OPREDECR,$2); }
+ | '-' term %prec UMINUS
+ { $$ = oper1(OUMINUS,$2); }
+ | '+' term %prec UMINUS
+ { $$ = oper1(OUPLUS,$2); }
+ | '(' cond ')'
+ { $$ = oper1(OPAREN,$2); }
+ | GETLINE
+ { $$ = oper0(OGETLINE); }
+ | GETLINE variable
+ { $$ = oper1(OGETLINE,$2); }
+ | GETLINE '<' expr
+ { $$ = oper3(OGETLINE,Nullop,string("<",1),$3);
+ if (ops[$3].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | GETLINE variable '<' expr
+ { $$ = oper3(OGETLINE,$2,string("<",1),$4);
+ if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | term 'p' GETLINE
+ { $$ = oper3(OGETLINE,Nullop,string("|",1),$1);
+ if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | term 'p' GETLINE variable
+ { $$ = oper3(OGETLINE,$4,string("|",1),$1);
+ if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | FUN1
+ { $$ = oper0($1); need_entire = do_chop = TRUE; }
+ | FUN1 '(' ')'
+ { $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; }
+ | FUN1 '(' expr ')'
+ { $$ = oper1($1,$3); }
+ | FUNN '(' expr_list ')'
+ { $$ = oper1($1,$3); }
+ | USERFUN '(' expr_list ')'
+ { $$ = oper2(OUSERFUN,$1,$3); }
+ | SPRINTF expr_list
+ { $$ = oper1(OSPRINTF,$2); }
+ | SUBSTR '(' expr ',' expr ',' expr ')'
+ { $$ = oper3(OSUBSTR,$3,$5,$7); }
+ | SUBSTR '(' expr ',' expr ')'
+ { $$ = oper2(OSUBSTR,$3,$5); }
+ | SPLIT '(' expr ',' VAR ',' expr ')'
+ { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),$7); }
+ | SPLIT '(' expr ',' VAR ',' REGEX ')'
+ { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),oper1(OREGEX,$7));}
+ | SPLIT '(' expr ',' VAR ')'
+ { $$ = oper2(OSPLIT,$3,aryrefarg(numary($5))); }
+ | INDEX '(' expr ',' expr ')'
+ { $$ = oper2(OINDEX,$3,$5); }
+ | MATCH '(' expr ',' REGEX ')'
+ { $$ = oper2(OMATCH,$3,oper1(OREGEX,$5)); }
+ | MATCH '(' expr ',' expr ')'
+ { $$ = oper2(OMATCH,$3,$5); }
+ | SUB '(' expr ',' expr ')'
+ { $$ = oper2(OSUB,$3,$5); }
+ | SUB '(' REGEX ',' expr ')'
+ { $$ = oper2(OSUB,oper1(OREGEX,$3),$5); }
+ | GSUB '(' expr ',' expr ')'
+ { $$ = oper2(OGSUB,$3,$5); }
+ | GSUB '(' REGEX ',' expr ')'
+ { $$ = oper2(OGSUB,oper1(OREGEX,$3),$5); }
+ | SUB '(' expr ',' expr ',' expr ')'
+ { $$ = oper3(OSUB,$3,$5,$7); }
+ | SUB '(' REGEX ',' expr ',' expr ')'
+ { $$ = oper3(OSUB,oper1(OREGEX,$3),$5,$7); }
+ | GSUB '(' expr ',' expr ',' expr ')'
+ { $$ = oper3(OGSUB,$3,$5,$7); }
+ | GSUB '(' REGEX ',' expr ',' expr ')'
+ { $$ = oper3(OGSUB,oper1(OREGEX,$3),$5,$7); }
+ ;
+
+variable: VAR
+ { $$ = oper1(OVAR,$1); }
+ | VAR '[' expr_list ']'
+ { $$ = oper2(OVAR,aryrefarg($1),$3); }
+ | FIELD
+ { $$ = oper1(OFLD,$1); }
+ | VFIELD term
+ { $$ = oper1(OVFLD,$2); }
+ ;
+
+expr_list
+ : expr
+ | clist
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+clist : expr ',' maybe expr
+ { $$ = oper3(OCOMMA,$1,$3,$4); }
+ | clist ',' maybe expr
+ { $$ = oper3(OCOMMA,$1,$3,$4); }
+ | '(' clist ')' /* these parens are invisible */
+ { $$ = $2; }
+ ;
+
+junk : junk hunksep
+ { $$ = oper2(OJUNK,$1,$2); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+hunksep : ';'
+ { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
+ | SEMINEW
+ { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
+ | NEWLINE
+ { $$ = oper0(ONEWLINE); }
+ | COMMENT
+ { $$ = oper1(OCOMMENT,$1); }
+ ;
+
+maybe : maybe nlstuff
+ { $$ = oper2(OJUNK,$1,$2); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+nlstuff : NEWLINE
+ { $$ = oper0(ONEWLINE); }
+ | COMMENT
+ { $$ = oper1(OCOMMENT,$1); }
+ ;
+
+separator
+ : ';' maybe
+ { $$ = oper2(OJUNK,oper0(OSEMICOLON),$2); }
+ | SEMINEW maybe
+ { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
+ | NEWLINE maybe
+ { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
+ | COMMENT maybe
+ { $$ = oper2(OJUNK,oper1(OSCOMMENT,$1),$2); }
+ ;
+
+states : states statement
+ { $$ = oper2(OSTATES,$1,$2); }
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+statement
+ : simple separator maybe
+ { $$ = oper2(OJUNK,oper2(OSTATE,$1,$2),$3); }
+ | ';' maybe
+ { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),$2)); }
+ | SEMINEW maybe
+ { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),$2)); }
+ | compound
+ ;
+
+simpnull: simple
+ | /* NULL */
+ { $$ = Nullop; }
+ ;
+
+simple
+ : expr
+ | PRINT expr_list redir expr
+ { $$ = oper3(OPRINT,$2,$3,$4);
+ do_opens = TRUE;
+ saw_ORS = saw_OFS = TRUE;
+ if (!$2) need_entire = TRUE;
+ if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | PRINT expr_list
+ { $$ = oper1(OPRINT,$2);
+ if (!$2) need_entire = TRUE;
+ saw_ORS = saw_OFS = TRUE;
+ }
+ | PRINTF expr_list redir expr
+ { $$ = oper3(OPRINTF,$2,$3,$4);
+ do_opens = TRUE;
+ if (!$2) need_entire = TRUE;
+ if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
+ | PRINTF expr_list
+ { $$ = oper1(OPRINTF,$2);
+ if (!$2) need_entire = TRUE;
+ }
+ | BREAK
+ { $$ = oper0(OBREAK); }
+ | NEXT
+ { $$ = oper0(ONEXT); }
+ | EXIT
+ { $$ = oper0(OEXIT); }
+ | EXIT expr
+ { $$ = oper1(OEXIT,$2); }
+ | CONTINUE
+ { $$ = oper0(OCONTINUE); }
+ | RET
+ { $$ = oper0(ORETURN); }
+ | RET expr
+ { $$ = oper1(ORETURN,$2); }
+ | DELETE VAR '[' expr_list ']'
+ { $$ = oper2(ODELETE,aryrefarg($2),$4); }
+ ;
+
+redir : '>' %prec FIELD
+ { $$ = oper1(OREDIR,string(">",1)); }
+ | GRGR
+ { $$ = oper1(OREDIR,string(">>",2)); }
+ | '|'
+ { $$ = oper1(OREDIR,string("|",1)); }
+ ;
+
+compound
+ : IF '(' cond ')' maybe statement
+ { $$ = oper2(OIF,$3,bl($6,$5)); }
+ | IF '(' cond ')' maybe statement ELSE maybe statement
+ { $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); }
+ | WHILE '(' cond ')' maybe statement
+ { $$ = oper2(OWHILE,$3,bl($6,$5)); }
+ | DO maybe statement WHILE '(' cond ')'
+ { $$ = oper2(ODO,bl($3,$2),$6); }
+ | FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement
+ { $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); }
+ | FOR '(' simpnull ';' ';' simpnull ')' maybe statement
+ { $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); }
+ | FOR '(' expr ')' maybe statement
+ { $$ = oper2(OFORIN,$3,bl($6,$5)); }
+ | '{' maybe states '}' maybe
+ { $$ = oper3(OBLOCK,oper2(OJUNK,$2,$3),Nullop,$5); }
+ ;
+
+%%
+
+int yyparse _((void));
+
+#include "a2py.c"
diff --git a/contrib/perl5/x2p/a2py.c b/contrib/perl5/x2p/a2py.c
new file mode 100644
index 000000000000..8a6155f4555b
--- /dev/null
+++ b/contrib/perl5/x2p/a2py.c
@@ -0,0 +1,1284 @@
+/* $RCSfile: a2py.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:14 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: a2py.c,v $
+ */
+
+#if defined(OS2) || defined(WIN32)
+#if defined(WIN32)
+#include <io.h>
+#endif
+#include "../patchlevel.h"
+#endif
+#include "util.h"
+
+char *filename;
+char *myname;
+
+int checkers = 0;
+
+int oper0(int type);
+int oper1(int type, int arg1);
+int oper2(int type, int arg1, int arg2);
+int oper3(int type, int arg1, int arg2, int arg3);
+int oper4(int type, int arg1, int arg2, int arg3, int arg4);
+int oper5(int type, int arg1, int arg2, int arg3, int arg4, int arg5);
+STR *walk(int useval, int level, register int node, int *numericptr, int minprec);
+
+#if defined(OS2) || defined(WIN32)
+static void usage(void);
+
+static void
+usage()
+{
+ printf("\nThis is the AWK to PERL translator, version 5.0, patchlevel %d\n", PATCHLEVEL);
+ printf("\nUsage: %s [-D<number>] [-F<char>] [-n<fieldlist>] [-<number>] filename\n", myname);
+ printf("\n -D<number> sets debugging flags."
+ "\n -F<character> the awk script to translate is always invoked with"
+ "\n this -F switch."
+ "\n -n<fieldlist> specifies the names of the input fields if input does"
+ "\n not have to be split into an array."
+ "\n -<number> causes a2p to assume that input will always have that"
+ "\n many fields.\n");
+ exit(1);
+}
+#endif
+
+int
+main(register int argc, register char **argv, register char **env)
+{
+ register STR *str;
+ int i;
+ STR *tmpstr;
+
+ myname = argv[0];
+ linestr = str_new(80);
+ str = str_new(0); /* first used for -I flags */
+ for (argc--,argv++; argc; argc--,argv++) {
+ if (argv[0][0] != '-' || !argv[0][1])
+ break;
+ reswitch:
+ switch (argv[0][1]) {
+#ifdef DEBUGGING
+ case 'D':
+ debug = atoi(argv[0]+2);
+#if YYDEBUG
+ yydebug = (debug & 1);
+#endif
+ break;
+#endif
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ maxfld = atoi(argv[0]+1);
+ absmaxfld = TRUE;
+ break;
+ case 'F':
+ fswitch = argv[0][2];
+ break;
+ case 'n':
+ namelist = savestr(argv[0]+2);
+ break;
+ case 'o':
+ old_awk = TRUE;
+ break;
+ case '-':
+ argc--,argv++;
+ goto switch_end;
+ case 0:
+ break;
+ default:
+#if defined(OS2) || defined(WIN32)
+ fprintf(stderr, "Unrecognized switch: %s\n",argv[0]);
+ usage();
+#else
+ fatal("Unrecognized switch: %s\n",argv[0]);
+#endif
+ }
+ }
+ switch_end:
+
+ /* open script */
+
+ if (argv[0] == Nullch) {
+#if defined(OS2) || defined(WIN32)
+ if ( isatty(fileno(stdin)) )
+ usage();
+#endif
+ argv[0] = "-";
+ }
+ filename = savestr(argv[0]);
+
+ filename = savestr(argv[0]);
+ if (strEQ(filename,"-"))
+ argv[0] = "";
+ if (!*argv[0])
+ rsfp = stdin;
+ else
+ rsfp = fopen(argv[0],"r");
+ if (rsfp == Nullfp)
+ fatal("Awk script \"%s\" doesn't seem to exist.\n",filename);
+
+ /* init tokener */
+
+ bufptr = str_get(linestr);
+ symtab = hnew();
+ curarghash = hnew();
+
+ /* now parse the report spec */
+
+ if (yyparse())
+ fatal("Translation aborted due to syntax errors.\n");
+
+#ifdef DEBUGGING
+ if (debug & 2) {
+ int type, len;
+
+ for (i=1; i<mop;) {
+ type = ops[i].ival;
+ len = type >> 8;
+ type &= 255;
+ printf("%d\t%d\t%d\t%-10s",i++,type,len,opname[type]);
+ if (type == OSTRING)
+ printf("\t\"%s\"\n",ops[i].cval),i++;
+ else {
+ while (len--) {
+ printf("\t%d",ops[i].ival),i++;
+ }
+ putchar('\n');
+ }
+ }
+ }
+ if (debug & 8)
+ dump(root);
+#endif
+
+ /* first pass to look for numeric variables */
+
+ prewalk(0,0,root,&i);
+
+ /* second pass to produce new program */
+
+ tmpstr = walk(0,0,root,&i,P_MIN);
+ str = str_make(STARTPERL);
+ str_cat(str, "\neval 'exec ");
+ str_cat(str, BIN);
+ str_cat(str, "/perl -S $0 ${1+\"$@\"}'\n\
+ if $running_under_some_shell;\n\
+ # this emulates #! processing on NIH machines.\n\
+ # (remove #! line above if indigestible)\n\n");
+ str_cat(str,
+ "eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_0-9]+=)(.*)/ && shift;\n");
+ str_cat(str,
+ " # process any FOO=bar switches\n\n");
+ if (do_opens && opens) {
+ str_scat(str,opens);
+ str_free(opens);
+ str_cat(str,"\n");
+ }
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+#ifdef DEBUGGING
+ if (!(debug & 16))
+#endif
+ fixup(str);
+ putlines(str);
+ if (checkers) {
+ fprintf(stderr,
+ "Please check my work on the %d line%s I've marked with \"#???\".\n",
+ checkers, checkers == 1 ? "" : "s" );
+ fprintf(stderr,
+ "The operation I've selected may be wrong for the operand types.\n");
+ }
+ exit(0);
+}
+
+#define RETURN(retval) return (bufptr = s,retval)
+#define XTERM(retval) return (expectterm = TRUE,bufptr = s,retval)
+#define XOP(retval) return (expectterm = FALSE,bufptr = s,retval)
+#define ID(x) return (yylval=string(x,0),expectterm = FALSE,bufptr = s,idtype)
+
+int idtype;
+
+int
+yylex(void)
+{
+ register char *s = bufptr;
+ register char *d;
+ register int tmp;
+
+ retry:
+#if YYDEBUG
+ if (yydebug)
+ if (strchr(s,'\n'))
+ fprintf(stderr,"Tokener at %s",s);
+ else
+ fprintf(stderr,"Tokener at %s\n",s);
+#endif
+ switch (*s) {
+ default:
+ fprintf(stderr,
+ "Unrecognized character %c in file %s line %d--ignoring.\n",
+ *s++,filename,line);
+ goto retry;
+ case '\\':
+ s++;
+ if (*s && *s != '\n') {
+ yyerror("Ignoring spurious backslash");
+ goto retry;
+ }
+ /*FALLSTHROUGH*/
+ case 0:
+ s = str_get(linestr);
+ *s = '\0';
+ if (!rsfp)
+ RETURN(0);
+ line++;
+ if ((s = str_gets(linestr, rsfp)) == Nullch) {
+ if (rsfp != stdin)
+ fclose(rsfp);
+ rsfp = Nullfp;
+ s = str_get(linestr);
+ RETURN(0);
+ }
+ goto retry;
+ case ' ': case '\t':
+ s++;
+ goto retry;
+ case '\n':
+ *s = '\0';
+ XTERM(NEWLINE);
+ case '#':
+ yylval = string(s,0);
+ *s = '\0';
+ XTERM(COMMENT);
+ case ';':
+ tmp = *s++;
+ if (*s == '\n') {
+ s++;
+ XTERM(SEMINEW);
+ }
+ XTERM(tmp);
+ case '(':
+ tmp = *s++;
+ XTERM(tmp);
+ case '{':
+ case '[':
+ case ')':
+ case ']':
+ case '?':
+ case ':':
+ tmp = *s++;
+ XOP(tmp);
+#ifdef EBCDIC
+ case 7:
+#else
+ case 127:
+#endif
+ s++;
+ XTERM('}');
+ case '}':
+ for (d = s + 1; isspace(*d); d++) ;
+ if (!*d)
+ s = d - 1;
+ *s = 127;
+ XTERM(';');
+ case ',':
+ tmp = *s++;
+ XTERM(tmp);
+ case '~':
+ s++;
+ yylval = string("~",1);
+ XTERM(MATCHOP);
+ case '+':
+ case '-':
+ if (s[1] == *s) {
+ s++;
+ if (*s++ == '+')
+ XTERM(INCR);
+ else
+ XTERM(DECR);
+ }
+ /* FALL THROUGH */
+ case '*':
+ case '%':
+ case '^':
+ tmp = *s++;
+ if (*s == '=') {
+ if (tmp == '^')
+ yylval = string("**=",3);
+ else
+ yylval = string(s-1,2);
+ s++;
+ XTERM(ASGNOP);
+ }
+ XTERM(tmp);
+ case '&':
+ s++;
+ tmp = *s++;
+ if (tmp == '&')
+ XTERM(ANDAND);
+ s--;
+ XTERM('&');
+ case '|':
+ s++;
+ tmp = *s++;
+ if (tmp == '|')
+ XTERM(OROR);
+ s--;
+ while (*s == ' ' || *s == '\t')
+ s++;
+ if (strnEQ(s,"getline",7))
+ XTERM('p');
+ else
+ XTERM('|');
+ case '=':
+ s++;
+ tmp = *s++;
+ if (tmp == '=') {
+ yylval = string("==",2);
+ XTERM(RELOP);
+ }
+ s--;
+ yylval = string("=",1);
+ XTERM(ASGNOP);
+ case '!':
+ s++;
+ tmp = *s++;
+ if (tmp == '=') {
+ yylval = string("!=",2);
+ XTERM(RELOP);
+ }
+ if (tmp == '~') {
+ yylval = string("!~",2);
+ XTERM(MATCHOP);
+ }
+ s--;
+ XTERM(NOT);
+ case '<':
+ s++;
+ tmp = *s++;
+ if (tmp == '=') {
+ yylval = string("<=",2);
+ XTERM(RELOP);
+ }
+ s--;
+ XTERM('<');
+ case '>':
+ s++;
+ tmp = *s++;
+ if (tmp == '>') {
+ yylval = string(">>",2);
+ XTERM(GRGR);
+ }
+ if (tmp == '=') {
+ yylval = string(">=",2);
+ XTERM(RELOP);
+ }
+ s--;
+ XTERM('>');
+
+#define SNARFWORD \
+ d = tokenbuf; \
+ while (isalpha(*s) || isdigit(*s) || *s == '_') \
+ *d++ = *s++; \
+ *d = '\0'; \
+ d = tokenbuf; \
+ if (*s == '(') \
+ idtype = USERFUN; \
+ else \
+ idtype = VAR;
+
+ case '$':
+ s++;
+ if (*s == '0') {
+ s++;
+ do_chop = TRUE;
+ need_entire = TRUE;
+ idtype = VAR;
+ ID("0");
+ }
+ do_split = TRUE;
+ if (isdigit(*s)) {
+ for (d = s; isdigit(*s); s++) ;
+ yylval = string(d,s-d);
+ tmp = atoi(d);
+ if (tmp > maxfld)
+ maxfld = tmp;
+ XOP(FIELD);
+ }
+ split_to_array = set_array_base = TRUE;
+ XOP(VFIELD);
+
+ case '/': /* may either be division or pattern */
+ if (expectterm) {
+ s = scanpat(s);
+ XTERM(REGEX);
+ }
+ tmp = *s++;
+ if (*s == '=') {
+ yylval = string("/=",2);
+ s++;
+ XTERM(ASGNOP);
+ }
+ XTERM(tmp);
+
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9': case '.':
+ s = scannum(s);
+ XOP(NUMBER);
+ case '"':
+ s++;
+ s = cpy2(tokenbuf,s,s[-1]);
+ if (!*s)
+ fatal("String not terminated:\n%s",str_get(linestr));
+ s++;
+ yylval = string(tokenbuf,0);
+ XOP(STRING);
+
+ case 'a': case 'A':
+ SNARFWORD;
+ if (strEQ(d,"ARGC"))
+ set_array_base = TRUE;
+ if (strEQ(d,"ARGV")) {
+ yylval=numary(string("ARGV",0));
+ XOP(VAR);
+ }
+ if (strEQ(d,"atan2")) {
+ yylval = OATAN2;
+ XTERM(FUNN);
+ }
+ ID(d);
+ case 'b': case 'B':
+ SNARFWORD;
+ if (strEQ(d,"break"))
+ XTERM(BREAK);
+ if (strEQ(d,"BEGIN"))
+ XTERM(BEGIN);
+ ID(d);
+ case 'c': case 'C':
+ SNARFWORD;
+ if (strEQ(d,"continue"))
+ XTERM(CONTINUE);
+ if (strEQ(d,"cos")) {
+ yylval = OCOS;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"close")) {
+ do_fancy_opens = 1;
+ yylval = OCLOSE;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"chdir"))
+ *d = toupper(*d);
+ else if (strEQ(d,"crypt"))
+ *d = toupper(*d);
+ else if (strEQ(d,"chop"))
+ *d = toupper(*d);
+ else if (strEQ(d,"chmod"))
+ *d = toupper(*d);
+ else if (strEQ(d,"chown"))
+ *d = toupper(*d);
+ ID(d);
+ case 'd': case 'D':
+ SNARFWORD;
+ if (strEQ(d,"do"))
+ XTERM(DO);
+ if (strEQ(d,"delete"))
+ XTERM(DELETE);
+ if (strEQ(d,"die"))
+ *d = toupper(*d);
+ ID(d);
+ case 'e': case 'E':
+ SNARFWORD;
+ if (strEQ(d,"END"))
+ XTERM(END);
+ if (strEQ(d,"else"))
+ XTERM(ELSE);
+ if (strEQ(d,"exit")) {
+ saw_line_op = TRUE;
+ XTERM(EXIT);
+ }
+ if (strEQ(d,"exp")) {
+ yylval = OEXP;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"elsif"))
+ *d = toupper(*d);
+ else if (strEQ(d,"eq"))
+ *d = toupper(*d);
+ else if (strEQ(d,"eval"))
+ *d = toupper(*d);
+ else if (strEQ(d,"eof"))
+ *d = toupper(*d);
+ else if (strEQ(d,"each"))
+ *d = toupper(*d);
+ else if (strEQ(d,"exec"))
+ *d = toupper(*d);
+ ID(d);
+ case 'f': case 'F':
+ SNARFWORD;
+ if (strEQ(d,"FS")) {
+ saw_FS++;
+ if (saw_FS == 1 && in_begin) {
+ for (d = s; *d && isspace(*d); d++) ;
+ if (*d == '=') {
+ for (d++; *d && isspace(*d); d++) ;
+ if (*d == '"' && d[2] == '"')
+ const_FS = d[1];
+ }
+ }
+ ID(tokenbuf);
+ }
+ if (strEQ(d,"for"))
+ XTERM(FOR);
+ else if (strEQ(d,"function"))
+ XTERM(FUNCTION);
+ if (strEQ(d,"FILENAME"))
+ d = "ARGV";
+ if (strEQ(d,"foreach"))
+ *d = toupper(*d);
+ else if (strEQ(d,"format"))
+ *d = toupper(*d);
+ else if (strEQ(d,"fork"))
+ *d = toupper(*d);
+ else if (strEQ(d,"fh"))
+ *d = toupper(*d);
+ ID(d);
+ case 'g': case 'G':
+ SNARFWORD;
+ if (strEQ(d,"getline"))
+ XTERM(GETLINE);
+ if (strEQ(d,"gsub"))
+ XTERM(GSUB);
+ if (strEQ(d,"ge"))
+ *d = toupper(*d);
+ else if (strEQ(d,"gt"))
+ *d = toupper(*d);
+ else if (strEQ(d,"goto"))
+ *d = toupper(*d);
+ else if (strEQ(d,"gmtime"))
+ *d = toupper(*d);
+ ID(d);
+ case 'h': case 'H':
+ SNARFWORD;
+ if (strEQ(d,"hex"))
+ *d = toupper(*d);
+ ID(d);
+ case 'i': case 'I':
+ SNARFWORD;
+ if (strEQ(d,"if"))
+ XTERM(IF);
+ if (strEQ(d,"in"))
+ XTERM(IN);
+ if (strEQ(d,"index")) {
+ set_array_base = TRUE;
+ XTERM(INDEX);
+ }
+ if (strEQ(d,"int")) {
+ yylval = OINT;
+ XTERM(FUN1);
+ }
+ ID(d);
+ case 'j': case 'J':
+ SNARFWORD;
+ if (strEQ(d,"join"))
+ *d = toupper(*d);
+ ID(d);
+ case 'k': case 'K':
+ SNARFWORD;
+ if (strEQ(d,"keys"))
+ *d = toupper(*d);
+ else if (strEQ(d,"kill"))
+ *d = toupper(*d);
+ ID(d);
+ case 'l': case 'L':
+ SNARFWORD;
+ if (strEQ(d,"length")) {
+ yylval = OLENGTH;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"log")) {
+ yylval = OLOG;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"last"))
+ *d = toupper(*d);
+ else if (strEQ(d,"local"))
+ *d = toupper(*d);
+ else if (strEQ(d,"lt"))
+ *d = toupper(*d);
+ else if (strEQ(d,"le"))
+ *d = toupper(*d);
+ else if (strEQ(d,"locatime"))
+ *d = toupper(*d);
+ else if (strEQ(d,"link"))
+ *d = toupper(*d);
+ ID(d);
+ case 'm': case 'M':
+ SNARFWORD;
+ if (strEQ(d,"match")) {
+ set_array_base = TRUE;
+ XTERM(MATCH);
+ }
+ if (strEQ(d,"m"))
+ *d = toupper(*d);
+ ID(d);
+ case 'n': case 'N':
+ SNARFWORD;
+ if (strEQ(d,"NF"))
+ do_chop = do_split = split_to_array = set_array_base = TRUE;
+ if (strEQ(d,"next")) {
+ saw_line_op = TRUE;
+ XTERM(NEXT);
+ }
+ if (strEQ(d,"ne"))
+ *d = toupper(*d);
+ ID(d);
+ case 'o': case 'O':
+ SNARFWORD;
+ if (strEQ(d,"ORS")) {
+ saw_ORS = TRUE;
+ d = "\\";
+ }
+ if (strEQ(d,"OFS")) {
+ saw_OFS = TRUE;
+ d = ",";
+ }
+ if (strEQ(d,"OFMT")) {
+ d = "#";
+ }
+ if (strEQ(d,"open"))
+ *d = toupper(*d);
+ else if (strEQ(d,"ord"))
+ *d = toupper(*d);
+ else if (strEQ(d,"oct"))
+ *d = toupper(*d);
+ ID(d);
+ case 'p': case 'P':
+ SNARFWORD;
+ if (strEQ(d,"print")) {
+ XTERM(PRINT);
+ }
+ if (strEQ(d,"printf")) {
+ XTERM(PRINTF);
+ }
+ if (strEQ(d,"push"))
+ *d = toupper(*d);
+ else if (strEQ(d,"pop"))
+ *d = toupper(*d);
+ ID(d);
+ case 'q': case 'Q':
+ SNARFWORD;
+ ID(d);
+ case 'r': case 'R':
+ SNARFWORD;
+ if (strEQ(d,"RS")) {
+ d = "/";
+ saw_RS = TRUE;
+ }
+ if (strEQ(d,"rand")) {
+ yylval = ORAND;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"return"))
+ XTERM(RET);
+ if (strEQ(d,"reset"))
+ *d = toupper(*d);
+ else if (strEQ(d,"redo"))
+ *d = toupper(*d);
+ else if (strEQ(d,"rename"))
+ *d = toupper(*d);
+ ID(d);
+ case 's': case 'S':
+ SNARFWORD;
+ if (strEQ(d,"split")) {
+ set_array_base = TRUE;
+ XOP(SPLIT);
+ }
+ if (strEQ(d,"substr")) {
+ set_array_base = TRUE;
+ XTERM(SUBSTR);
+ }
+ if (strEQ(d,"sub"))
+ XTERM(SUB);
+ if (strEQ(d,"sprintf"))
+ XTERM(SPRINTF);
+ if (strEQ(d,"sqrt")) {
+ yylval = OSQRT;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"SUBSEP")) {
+ d = ";";
+ }
+ if (strEQ(d,"sin")) {
+ yylval = OSIN;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"srand")) {
+ yylval = OSRAND;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"system")) {
+ yylval = OSYSTEM;
+ XTERM(FUN1);
+ }
+ if (strEQ(d,"s"))
+ *d = toupper(*d);
+ else if (strEQ(d,"shift"))
+ *d = toupper(*d);
+ else if (strEQ(d,"select"))
+ *d = toupper(*d);
+ else if (strEQ(d,"seek"))
+ *d = toupper(*d);
+ else if (strEQ(d,"stat"))
+ *d = toupper(*d);
+ else if (strEQ(d,"study"))
+ *d = toupper(*d);
+ else if (strEQ(d,"sleep"))
+ *d = toupper(*d);
+ else if (strEQ(d,"symlink"))
+ *d = toupper(*d);
+ else if (strEQ(d,"sort"))
+ *d = toupper(*d);
+ ID(d);
+ case 't': case 'T':
+ SNARFWORD;
+ if (strEQ(d,"tr"))
+ *d = toupper(*d);
+ else if (strEQ(d,"tell"))
+ *d = toupper(*d);
+ else if (strEQ(d,"time"))
+ *d = toupper(*d);
+ else if (strEQ(d,"times"))
+ *d = toupper(*d);
+ ID(d);
+ case 'u': case 'U':
+ SNARFWORD;
+ if (strEQ(d,"until"))
+ *d = toupper(*d);
+ else if (strEQ(d,"unless"))
+ *d = toupper(*d);
+ else if (strEQ(d,"umask"))
+ *d = toupper(*d);
+ else if (strEQ(d,"unshift"))
+ *d = toupper(*d);
+ else if (strEQ(d,"unlink"))
+ *d = toupper(*d);
+ else if (strEQ(d,"utime"))
+ *d = toupper(*d);
+ ID(d);
+ case 'v': case 'V':
+ SNARFWORD;
+ if (strEQ(d,"values"))
+ *d = toupper(*d);
+ ID(d);
+ case 'w': case 'W':
+ SNARFWORD;
+ if (strEQ(d,"while"))
+ XTERM(WHILE);
+ if (strEQ(d,"write"))
+ *d = toupper(*d);
+ else if (strEQ(d,"wait"))
+ *d = toupper(*d);
+ ID(d);
+ case 'x': case 'X':
+ SNARFWORD;
+ if (strEQ(d,"x"))
+ *d = toupper(*d);
+ ID(d);
+ case 'y': case 'Y':
+ SNARFWORD;
+ if (strEQ(d,"y"))
+ *d = toupper(*d);
+ ID(d);
+ case 'z': case 'Z':
+ SNARFWORD;
+ ID(d);
+ }
+}
+
+char *
+scanpat(register char *s)
+{
+ register char *d;
+
+ switch (*s++) {
+ case '/':
+ break;
+ default:
+ fatal("Search pattern not found:\n%s",str_get(linestr));
+ }
+
+ d = tokenbuf;
+ for (; *s; s++,d++) {
+ if (*s == '\\') {
+ if (s[1] == '/')
+ *d++ = *s++;
+ else if (s[1] == '\\')
+ *d++ = *s++;
+ else if (s[1] == '[')
+ *d++ = *s++;
+ }
+ else if (*s == '[') {
+ *d++ = *s++;
+ do {
+ if (*s == '\\' && s[1])
+ *d++ = *s++;
+ if (*s == '/' || (*s == '-' && s[1] == ']'))
+ *d++ = '\\';
+ *d++ = *s++;
+ } while (*s && *s != ']');
+ }
+ else if (*s == '/')
+ break;
+ *d = *s;
+ }
+ *d = '\0';
+
+ if (!*s)
+ fatal("Search pattern not terminated:\n%s",str_get(linestr));
+ s++;
+ yylval = string(tokenbuf,0);
+ return s;
+}
+
+void
+yyerror(char *s)
+{
+ fprintf(stderr,"%s in file %s at line %d\n",
+ s,filename,line);
+}
+
+char *
+scannum(register char *s)
+{
+ register char *d;
+
+ switch (*s) {
+ case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9': case '0' : case '.':
+ d = tokenbuf;
+ while (isdigit(*s)) {
+ *d++ = *s++;
+ }
+ if (*s == '.') {
+ if (isdigit(s[1])) {
+ *d++ = *s++;
+ while (isdigit(*s)) {
+ *d++ = *s++;
+ }
+ }
+ else
+ s++;
+ }
+ if (strchr("eE",*s) && strchr("+-0123456789",s[1])) {
+ *d++ = *s++;
+ if (*s == '+' || *s == '-')
+ *d++ = *s++;
+ while (isdigit(*s))
+ *d++ = *s++;
+ }
+ *d = '\0';
+ yylval = string(tokenbuf,0);
+ break;
+ }
+ return s;
+}
+
+int
+string(char *ptr, int len)
+{
+ int retval = mop;
+
+ ops[mop++].ival = OSTRING + (1<<8);
+ if (!len)
+ len = strlen(ptr);
+ ops[mop].cval = (char *) safemalloc(len+1);
+ strncpy(ops[mop].cval,ptr,len);
+ ops[mop++].cval[len] = '\0';
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+int
+oper0(int type)
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+int
+oper1(int type, int arg1)
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type + (1<<8);
+ ops[mop++].ival = arg1;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+int
+oper2(int type, int arg1, int arg2)
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type + (2<<8);
+ ops[mop++].ival = arg1;
+ ops[mop++].ival = arg2;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+int
+oper3(int type, int arg1, int arg2, int arg3)
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type + (3<<8);
+ ops[mop++].ival = arg1;
+ ops[mop++].ival = arg2;
+ ops[mop++].ival = arg3;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+int
+oper4(int type, int arg1, int arg2, int arg3, int arg4)
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type + (4<<8);
+ ops[mop++].ival = arg1;
+ ops[mop++].ival = arg2;
+ ops[mop++].ival = arg3;
+ ops[mop++].ival = arg4;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+int
+oper5(int type, int arg1, int arg2, int arg3, int arg4, int arg5)
+{
+ int retval = mop;
+
+ if (type > 255)
+ fatal("type > 255 (%d)\n",type);
+ ops[mop++].ival = type + (5<<8);
+ ops[mop++].ival = arg1;
+ ops[mop++].ival = arg2;
+ ops[mop++].ival = arg3;
+ ops[mop++].ival = arg4;
+ ops[mop++].ival = arg5;
+ if (mop >= OPSMAX)
+ fatal("Recompile a2p with larger OPSMAX\n");
+ return retval;
+}
+
+int depth = 0;
+
+void
+dump(int branch)
+{
+ register int type;
+ register int len;
+ register int i;
+
+ type = ops[branch].ival;
+ len = type >> 8;
+ type &= 255;
+ for (i=depth; i; i--)
+ printf(" ");
+ if (type == OSTRING) {
+ printf("%-5d\"%s\"\n",branch,ops[branch+1].cval);
+ }
+ else {
+ printf("(%-5d%s %d\n",branch,opname[type],len);
+ depth++;
+ for (i=1; i<=len; i++)
+ dump(ops[branch+i].ival);
+ depth--;
+ for (i=depth; i; i--)
+ printf(" ");
+ printf(")\n");
+ }
+}
+
+int
+bl(int arg, int maybe)
+{
+ if (!arg)
+ return 0;
+ else if ((ops[arg].ival & 255) != OBLOCK)
+ return oper2(OBLOCK,arg,maybe);
+ else if ((ops[arg].ival >> 8) < 2)
+ return oper2(OBLOCK,ops[arg+1].ival,maybe);
+ else
+ return arg;
+}
+
+void
+fixup(STR *str)
+{
+ register char *s;
+ register char *t;
+
+ for (s = str->str_ptr; *s; s++) {
+ if (*s == ';' && s[1] == ' ' && s[2] == '\n') {
+ strcpy(s+1,s+2);
+ s++;
+ }
+ else if (*s == '\n') {
+ for (t = s+1; isspace(*t & 127); t++) ;
+ t--;
+ while (isspace(*t & 127) && *t != '\n') t--;
+ if (*t == '\n' && t-s > 1) {
+ if (s[-1] == '{')
+ s--;
+ strcpy(s+1,t);
+ }
+ s++;
+ }
+ }
+}
+
+void
+putlines(STR *str)
+{
+ register char *d, *s, *t, *e;
+ register int pos, newpos;
+
+ d = tokenbuf;
+ pos = 0;
+ for (s = str->str_ptr; *s; s++) {
+ *d++ = *s;
+ pos++;
+ if (*s == '\n') {
+ *d = '\0';
+ d = tokenbuf;
+ pos = 0;
+ putone();
+ }
+ else if (*s == '\t')
+ pos += 7;
+ if (pos > 78) { /* split a long line? */
+ *d-- = '\0';
+ newpos = 0;
+ for (t = tokenbuf; isspace(*t & 127); t++) {
+ if (*t == '\t')
+ newpos += 8;
+ else
+ newpos += 1;
+ }
+ e = d;
+ while (d > tokenbuf && (*d != ' ' || d[-1] != ';'))
+ d--;
+ if (d < t+10) {
+ d = e;
+ while (d > tokenbuf &&
+ (*d != ' ' || d[-1] != '|' || d[-2] != '|') )
+ d--;
+ }
+ if (d < t+10) {
+ d = e;
+ while (d > tokenbuf &&
+ (*d != ' ' || d[-1] != '&' || d[-2] != '&') )
+ d--;
+ }
+ if (d < t+10) {
+ d = e;
+ while (d > tokenbuf && (*d != ' ' || d[-1] != ','))
+ d--;
+ }
+ if (d < t+10) {
+ d = e;
+ while (d > tokenbuf && *d != ' ')
+ d--;
+ }
+ if (d > t+3) {
+ char save[2048];
+ strcpy(save, d);
+ *d = '\n';
+ d[1] = '\0';
+ putone();
+ putchar('\n');
+ if (d[-1] != ';' && !(newpos % 4)) {
+ *t++ = ' ';
+ *t++ = ' ';
+ newpos += 2;
+ }
+ strcpy(t,save+1);
+ newpos += strlen(t);
+ d = t + strlen(t);
+ pos = newpos;
+ }
+ else
+ d = e + 1;
+ }
+ }
+}
+
+void
+putone(void)
+{
+ register char *t;
+
+ for (t = tokenbuf; *t; t++) {
+ *t &= 127;
+ if (*t == 127) {
+ *t = ' ';
+ strcpy(t+strlen(t)-1, "\t#???\n");
+ checkers++;
+ }
+ }
+ t = tokenbuf;
+ if (*t == '#') {
+ if (strnEQ(t,"#!/bin/awk",10) || strnEQ(t,"#! /bin/awk",11))
+ return;
+ if (strnEQ(t,"#!/usr/bin/awk",14) || strnEQ(t,"#! /usr/bin/awk",15))
+ return;
+ }
+ fputs(tokenbuf,stdout);
+}
+
+int
+numary(int arg)
+{
+ STR *key;
+ int dummy;
+
+ key = walk(0,0,arg,&dummy,P_MIN);
+ str_cat(key,"[]");
+ hstore(symtab,key->str_ptr,str_make("1"));
+ str_free(key);
+ set_array_base = TRUE;
+ return arg;
+}
+
+int
+rememberargs(int arg)
+{
+ int type;
+ STR *str;
+
+ if (!arg)
+ return arg;
+ type = ops[arg].ival & 255;
+ if (type == OCOMMA) {
+ rememberargs(ops[arg+1].ival);
+ rememberargs(ops[arg+3].ival);
+ }
+ else if (type == OVAR) {
+ str = str_new(0);
+ hstore(curarghash,ops[ops[arg+1].ival+1].cval,str);
+ }
+ else
+ fatal("panic: unknown argument type %d, line %d\n",type,line);
+ return arg;
+}
+
+int
+aryrefarg(int arg)
+{
+ int type = ops[arg].ival & 255;
+ STR *str;
+
+ if (type != OSTRING)
+ fatal("panic: aryrefarg %d, line %d\n",type,line);
+ str = hfetch(curarghash,ops[arg+1].cval);
+ if (str)
+ str_set(str,"*");
+ return arg;
+}
+
+int
+fixfargs(int name, int arg, int prevargs)
+{
+ int type;
+ STR *str;
+ int numargs;
+
+ if (!arg)
+ return prevargs;
+ type = ops[arg].ival & 255;
+ if (type == OCOMMA) {
+ numargs = fixfargs(name,ops[arg+1].ival,prevargs);
+ numargs = fixfargs(name,ops[arg+3].ival,numargs);
+ }
+ else if (type == OVAR) {
+ str = hfetch(curarghash,ops[ops[arg+1].ival+1].cval);
+ if (strEQ(str_get(str),"*")) {
+ char tmpbuf[128];
+
+ str_set(str,""); /* in case another routine has this */
+ ops[arg].ival &= ~255;
+ ops[arg].ival |= OSTAR;
+ sprintf(tmpbuf,"%s:%d",ops[name+1].cval,prevargs);
+ fprintf(stderr,"Adding %s\n",tmpbuf);
+ str = str_new(0);
+ str_set(str,"*");
+ hstore(curarghash,tmpbuf,str);
+ }
+ numargs = prevargs + 1;
+ }
+ else
+ fatal("panic: unknown argument type %d, arg %d, line %d\n",
+ type,prevargs+1,line);
+ return numargs;
+}
+
+int
+fixrargs(char *name, int arg, int prevargs)
+{
+ int type;
+ STR *str;
+ int numargs;
+
+ if (!arg)
+ return prevargs;
+ type = ops[arg].ival & 255;
+ if (type == OCOMMA) {
+ numargs = fixrargs(name,ops[arg+1].ival,prevargs);
+ numargs = fixrargs(name,ops[arg+3].ival,numargs);
+ }
+ else {
+ char *tmpbuf = (char *) safemalloc(strlen(name) + (sizeof(prevargs) * 3) + 5);
+ sprintf(tmpbuf,"%s:%d",name,prevargs);
+ str = hfetch(curarghash,tmpbuf);
+ safefree(tmpbuf);
+ if (str && strEQ(str->str_ptr,"*")) {
+ if (type == OVAR || type == OSTAR) {
+ ops[arg].ival &= ~255;
+ ops[arg].ival |= OSTAR;
+ }
+ else
+ fatal("Can't pass expression by reference as arg %d of %s\n",
+ prevargs+1, name);
+ }
+ numargs = prevargs + 1;
+ }
+ return numargs;
+}
diff --git a/contrib/perl5/x2p/cflags.SH b/contrib/perl5/x2p/cflags.SH
new file mode 100755
index 000000000000..62bd11c9d98a
--- /dev/null
+++ b/contrib/perl5/x2p/cflags.SH
@@ -0,0 +1,95 @@
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+: This forces SH files to create target in same directory as SH file.
+: This is so that make depend always knows where to find SH derivatives.
+case "$0" in
+*/cflags.SH) cd `expr X$0 : 'X\(.*\)/'` ;;
+cflags.SH) ;;
+*) case `pwd` in
+ */x2p) ;;
+ *) if test -d x2p; then cd x2p
+ else echo "Can't figure out where to write output."; exit 1
+ fi;;
+ esac;;
+esac
+echo "Extracting x2p/cflags (with variable substitutions)"
+: This section of the file will have variable substitutions done on it.
+: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
+: Protect any dollar signs and backticks that you do not want interpreted
+: by putting a backslash in front. You may delete these comments.
+rm -f cflags
+$spitshell >cflags <<!GROK!THIS!
+!GROK!THIS!
+
+: In the following dollars and backticks do not need the extra backslash.
+$spitshell >>cflags <<'!NO!SUBS!'
+case $CONFIG in
+'')
+ if test -f config.sh; then TOP=.;
+ elif test -f ../config.sh; then TOP=..;
+ elif test -f ../../config.sh; then TOP=../..;
+ elif test -f ../../../config.sh; then TOP=../../..;
+ elif test -f ../../../../config.sh; then TOP=../../../..;
+ else
+ echo "Can't find config.sh."; exit 1
+ fi
+ . $TOP/config.sh
+ ;;
+esac
+
+also=': '
+case $# in
+1) also='echo 1>&2 " CCCMD = "'
+esac
+
+case $# in
+0) set *.c; echo "The current C flags are:" ;;
+esac
+
+set `echo "$* " | sed -e 's/\.[oc] / /g' -e 's/\.obj / /g'`
+
+for file do
+
+ case "$#" in
+ 1) ;;
+ *) echo $n " $file.c $c" ;;
+ esac
+
+ : allow variables like str_cflags to be evaluated
+
+ eval 'eval ${'"${file}_cflags"'-""}'
+
+ : or customize here
+
+ case "$file" in
+ a2p) ;;
+ a2py) ;;
+ hash) ;;
+ str) ;;
+ util) ;;
+ walk) ;;
+ *) ;;
+ esac
+
+ ccflags="`echo $ccflags | sed -e 's/-DMULTIPLICITY//'`"
+
+ echo "$cc -c $ccflags $optimize $large $split"
+ eval "$also "'"$cc -c $ccflags $optimize $large $split"'
+
+ . $TOP/config.sh
+
+done
+!NO!SUBS!
+chmod 755 cflags
+$eunicefix cflags
diff --git a/contrib/perl5/x2p/find2perl.PL b/contrib/perl5/x2p/find2perl.PL
new file mode 100644
index 000000000000..f82b6602e729
--- /dev/null
+++ b/contrib/perl5/x2p/find2perl.PL
@@ -0,0 +1,627 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+\$startperl = "$Config{startperl}";
+\$perlpath = "$Config{perlpath}";
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+#
+# Modified September 26, 1993 to provide proper handling of years after 1999
+# Tom Link <tml+@pitt.edu>
+# University of Pittsburgh
+#
+# Modified April 7, 1998 with nasty hacks to implement the troublesome -follow
+# Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au>
+# University of Adelaide, Adelaide, South Australia
+#
+
+while ($ARGV[0] =~ /^[^-!(]/) {
+ push(@roots, shift);
+}
+@roots = ('.') unless @roots;
+for (@roots) { $_ = &quote($_); }
+$roots = join(',', @roots);
+
+$indent = 1;
+$stat = 'lstat';
+$decl = '';
+
+while (@ARGV) {
+ $_ = shift;
+ s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
+ if ($_ eq '(') {
+ $out .= &tab . "(\n";
+ $indent++;
+ next;
+ }
+ elsif ($_ eq ')') {
+ $indent--;
+ $out .= &tab . ")";
+ }
+ elsif ($_ eq 'follow') {
+ $stat = 'stat';
+ $decl = '%already_seen = ();';
+ $out .= &tab . '(not $already_seen{"$dev,$ino"}) &&';
+ $out .= "\n" . &tab . '(($already_seen{"$dev,$ino"} = !(-d _)) || 1)';
+ }
+ elsif ($_ eq '!') {
+ $out .= &tab . "!";
+ next;
+ }
+ elsif ($_ eq 'name') {
+ $out .= &tab;
+ $pat = &fileglob_to_re(shift);
+ $out .= '/' . $pat . "/";
+ }
+ elsif ($_ eq 'perm') {
+ $onum = shift;
+ die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
+ if ($onum =~ s/^-//) {
+ $onum = '0' . sprintf("%o", oct($onum) & 017777); # s/b 07777 ?
+ $out .= &tab . "((\$mode & $onum) == $onum)";
+ }
+ else {
+ $onum = '0' . $onum unless $onum =~ /^0/;
+ $out .= &tab . "((\$mode & 0777) == $onum)";
+ }
+ }
+ elsif ($_ eq 'type') {
+ ($filetest = shift) =~ tr/s/S/;
+ $out .= &tab . "-$filetest _";
+ }
+ elsif ($_ eq 'print') {
+ $out .= &tab . 'print("$name\n")';
+ }
+ elsif ($_ eq 'print0') {
+ $out .= &tab . 'print("$name\0")';
+ }
+ elsif ($_ eq 'fstype') {
+ $out .= &tab;
+ $type = shift;
+ if ($type eq 'nfs')
+ { $out .= '($dev < 0)'; }
+ else
+ { $out .= '($dev >= 0)'; }
+ }
+ elsif ($_ eq 'user') {
+ $uname = shift;
+ $out .= &tab . "(\$uid == \$uid{'$uname'})";
+ $inituser++;
+ }
+ elsif ($_ eq 'group') {
+ $gname = shift;
+ $out .= &tab . "(\$gid == \$gid{'$gname'})";
+ $initgroup++;
+ }
+ elsif ($_ eq 'nouser') {
+ $out .= &tab . '!defined $uid{$uid}';
+ $inituser++;
+ }
+ elsif ($_ eq 'nogroup') {
+ $out .= &tab . '!defined $gid{$gid}';
+ $initgroup++;
+ }
+ elsif ($_ eq 'links') {
+ $out .= &tab . '($nlink ' . &n(shift);
+ }
+ elsif ($_ eq 'inum') {
+ $out .= &tab . '($ino ' . &n(shift);
+ }
+ elsif ($_ eq 'size') {
+ $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift);
+ }
+ elsif ($_ eq 'atime') {
+ $out .= &tab . '(int(-A _) ' . &n(shift);
+ }
+ elsif ($_ eq 'mtime') {
+ $out .= &tab . '(int(-M _) ' . &n(shift);
+ }
+ elsif ($_ eq 'ctime') {
+ $out .= &tab . '(int(-C _) ' . &n(shift);
+ }
+ elsif ($_ eq 'exec') {
+ for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
+ shift;
+ $_ = "@cmd";
+ if (m#^(/bin/)?rm -f {}$#) {
+ if (!@ARGV) {
+ $out .= &tab . 'unlink($_)';
+ }
+ else {
+ $out .= &tab . '(unlink($_) || 1)';
+ }
+ }
+ elsif (m#^(/bin/)?rm {}$#) {
+ $out .= &tab . '(unlink($_) || warn "$name: $!\n")';
+ }
+ else {
+ for (@cmd) { s/'/\\'/g; }
+ $" = "','";
+ $out .= &tab . "&exec(0, '@cmd')";
+ $" = ' ';
+ $initexec++;
+ }
+ }
+ elsif ($_ eq 'ok') {
+ for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
+ shift;
+ for (@cmd) { s/'/\\'/g; }
+ $" = "','";
+ $out .= &tab . "&exec(1, '@cmd')";
+ $" = ' ';
+ $initexec++;
+ }
+ elsif ($_ eq 'prune') {
+ $out .= &tab . '($prune = 1)';
+ }
+ elsif ($_ eq 'xdev') {
+ $out .= &tab . '!($prune |= ($dev != $topdev))';
+ }
+ elsif ($_ eq 'newer') {
+ $out .= &tab;
+ $file = shift;
+ $newername = 'AGE_OF' . $file;
+ $newername =~ s/[^\w]/_/g;
+ $newername = "\$$newername";
+ $out .= "(-M _ < $newername)";
+ $initnewer .= "$newername = -M " . &quote($file) . ";\n";
+ }
+ elsif ($_ eq 'eval') {
+ $prog = &quote(shift);
+ $out .= &tab . "eval $prog";
+ }
+ elsif ($_ eq 'depth') {
+ $depth++;
+ next;
+ }
+ elsif ($_ eq 'ls') {
+ $out .= &tab . "&ls";
+ $initls++;
+ }
+ elsif ($_ eq 'tar') {
+ $out .= &tab;
+ die "-tar must have a filename argument\n" unless @ARGV;
+ $file = shift;
+ $fh = 'FH' . $file;
+ $fh =~ s/[^\w]/_/g;
+ $out .= "&tar($fh)";
+ $file = '>' . $file;
+ $initfile .= "open($fh, " . &quote($file) .
+ qq{) || die "Can't open $fh: \$!\\n";\n};
+ $inittar++;
+ $flushall = "\n&tflushall;\n";
+ }
+ elsif (/^n?cpio$/) {
+ $depth++;
+ $out .= &tab;
+ die "-$_ must have a filename argument\n" unless @ARGV;
+ $file = shift;
+ $fh = 'FH' . $file;
+ $fh =~ s/[^\w]/_/g;
+ $out .= "&cpio('" . substr($_,0,1) . "', $fh)";
+ $file = '>' . $file;
+ $initfile .= "open($fh, " . &quote($file) .
+ qq{) || die "Can't open $fh: \$!\\n";\n};
+ $initcpio++;
+ $flushall = "\n&flushall;\n";
+ }
+ else {
+ die "Unrecognized switch: -$_\n";
+ }
+ if (@ARGV) {
+ if ($ARGV[0] eq '-o') {
+ { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
+ $statdone = 0 if $indent == 1 && $delayedstat;
+ $saw_or++;
+ shift;
+ }
+ else {
+ $out .= " &&" unless $ARGV[0] eq ')';
+ $out .= "\n";
+ shift if $ARGV[0] eq '-a';
+ }
+ }
+}
+
+print <<"END";
+$startperl
+ eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+
+END
+
+if ($initls) {
+ print <<'END';
+@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
+@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
+
+END
+}
+
+if ($inituser || $initls) {
+ print 'while (($name, $pw, $uid) = getpwent) {', "\n";
+ print ' $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
+ print ' $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
+ print "}\n\n";
+}
+
+if ($initgroup || $initls) {
+ print 'while (($name, $pw, $gid) = getgrent) {', "\n";
+ print ' $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
+ print ' $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
+ print "}\n\n";
+}
+
+print $initnewer, "\n" if $initnewer;
+
+print $initfile, "\n" if $initfile;
+
+$find = $depth ? "finddepth" : "find";
+print <<"END";
+require "$find.pl";
+
+# Traverse desired filesystems
+
+$decl
+&$find($roots);
+$flushall
+exit;
+sub wanted {
+$out;
+}
+
+END
+
+if ($initexec) {
+ print <<'END';
+sub exec {
+ local($ok, @cmd) = @_;
+ foreach $word (@cmd) {
+ $word =~ s#{}#$name#g;
+ }
+ if ($ok) {
+ local($old) = select(STDOUT);
+ $| = 1;
+ print "@cmd";
+ select($old);
+ return 0 unless <STDIN> =~ /^y/;
+ }
+ chdir $cwd; # sigh
+ system @cmd;
+ chdir $dir;
+ return !$?;
+}
+
+END
+}
+
+if ($initls) {
+ print <<"INTERP", <<'END';
+sub ls {
+ (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$sizemm,
+ \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
+INTERP
+
+ $pname = $name;
+
+ if (defined $blocks) {
+ $blocks = int(($blocks + 1) / 2);
+ }
+ else {
+ $blocks = int(($size + 1023) / 1024);
+ }
+
+ if (-f _) { $perms = '-'; }
+ elsif (-d _) { $perms = 'd'; }
+ elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
+ elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
+ elsif (-p _) { $perms = 'p'; }
+ elsif (-S _) { $perms = 's'; }
+ else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
+
+ $tmpmode = $mode;
+ $tmp = $rwx[$tmpmode & 7];
+ $tmpmode >>= 3;
+ $tmp = $rwx[$tmpmode & 7] . $tmp;
+ $tmpmode >>= 3;
+ $tmp = $rwx[$tmpmode & 7] . $tmp;
+ substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
+ substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
+ substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
+ $perms .= $tmp;
+
+ $user = $user{$uid} || $uid;
+ $group = $group{$gid} || $gid;
+
+ ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
+ $moname = $moname[$mon];
+ if (-M _ > 365.25 / 2) {
+ $timeyear = $year + 1900;
+ }
+ else {
+ $timeyear = sprintf("%02d:%02d", $hour, $min);
+ }
+
+ printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
+ $ino,
+ $blocks,
+ $perms,
+ $nlink,
+ $user,
+ $group,
+ $sizemm,
+ $moname,
+ $mday,
+ $timeyear,
+ $pname;
+ 1;
+}
+
+sub sizemm {
+ sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
+}
+
+END
+}
+
+if ($initcpio) {
+print <<'START', <<"INTERP", <<'END';
+sub cpio {
+ local($nc,$fh) = @_;
+ local($text);
+
+ if ($name eq 'TRAILER!!!') {
+ $text = '';
+ $size = 0;
+ }
+ else {
+START
+ (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size,
+ \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
+INTERP
+ if (-f _) {
+ open(IN, "./$_\0") || do {
+ warn "Couldn't open $name: $!\n";
+ return;
+ };
+ }
+ else {
+ $text = readlink($_);
+ $size = 0 unless defined $text;
+ }
+ }
+
+ ($nm = $name) =~ s#^\./##;
+ $nc{$fh} = $nc;
+ if ($nc eq 'n') {
+ $cpout{$fh} .=
+ sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
+ 070707,
+ $dev & 0777777,
+ $ino & 0777777,
+ $mode & 0777777,
+ $uid & 0777777,
+ $gid & 0777777,
+ $nlink & 0777777,
+ $rdev & 0177777,
+ $mtime,
+ length($nm)+1,
+ $size,
+ $nm);
+ }
+ else {
+ $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
+ $cpout{$fh} .= pack("SSSSSSSSLSLa*",
+ 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
+ length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
+ }
+ if ($text ne '') {
+ $cpout{$fh} .= $text;
+ }
+ elsif ($size) {
+ &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
+ while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
+ &flush($fh);
+ $l = length($cpout{$fh});
+ }
+ }
+ close IN;
+}
+
+sub flush {
+ local($fh) = @_;
+
+ while (length($cpout{$fh}) >= 5120) {
+ syswrite($fh,$cpout{$fh},5120);
+ ++$blocks{$fh};
+ substr($cpout{$fh}, 0, 5120) = '';
+ }
+}
+
+sub flushall {
+ $name = 'TRAILER!!!';
+ foreach $fh (keys %cpout) {
+ &cpio($nc{$fh},$fh);
+ $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
+ &flush($fh);
+ print $blocks{$fh} * 10, " blocks\n";
+ }
+}
+
+END
+}
+
+if ($inittar) {
+print <<'START', <<"INTERP", <<'END';
+sub tar {
+ local($fh) = @_;
+ local($linkname,$header,$l,$slop);
+ local($linkflag) = "\0";
+
+START
+ (\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid,\$rdev,\$size,
+ \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat\(_\);
+INTERP
+ $nm = $name;
+ if ($nlink > 1) {
+ if ($linkname = $linkseen{$fh,$dev,$ino}) {
+ $linkflag = 1;
+ }
+ else {
+ $linkseen{$fh,$dev,$ino} = $nm;
+ }
+ }
+ if (-f _) {
+ open(IN, "./$_\0") || do {
+ warn "Couldn't open $name: $!\n";
+ return;
+ };
+ $size = 0 if $linkflag ne "\0";
+ }
+ else {
+ $linkname = readlink($_);
+ $linkflag = 2 if defined $linkname;
+ $nm .= '/' if -d _;
+ $size = 0;
+ }
+
+ $header = pack("a100a8a8a8a12a12a8a1a100",
+ $nm,
+ sprintf("%6o ", $mode & 0777),
+ sprintf("%6o ", $uid & 0777777),
+ sprintf("%6o ", $gid & 0777777),
+ sprintf("%11o ", $size),
+ sprintf("%11o ", $mtime),
+ " ",
+ $linkflag,
+ $linkname);
+ $l = length($header) % 512;
+ substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
+ substr($header, 154, 1) = "\0"; # blech
+ $tarout{$fh} .= $header;
+ $tarout{$fh} .= "\0" x (512 - $l) if $l;
+ if ($size) {
+ &tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
+ while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
+ $slop = length($tarout{$fh}) % 512;
+ $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
+ &tflush($fh);
+ $l = length($tarout{$fh});
+ }
+ }
+ close IN;
+}
+
+sub tflush {
+ local($fh) = @_;
+
+ while (length($tarout{$fh}) >= 10240) {
+ syswrite($fh,$tarout{$fh},10240);
+ ++$blocks{$fh};
+ substr($tarout{$fh}, 0, 10240) = '';
+ }
+}
+
+sub tflushall {
+ local($len);
+
+ foreach $fh (keys %tarout) {
+ $len = 10240 - length($tarout{$fh});
+ $len += 10240 if $len < 1024;
+ $tarout{$fh} .= "\0" x $len;
+ &tflush($fh);
+ }
+}
+
+END
+}
+
+exit;
+
+############################################################################
+
+sub tab {
+ local($tabstring);
+
+ $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
+ if (!$statdone) {
+ if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) {
+ $delayedstat++;
+ }
+ else {
+ if ($saw_or) {
+ $tabstring .= <<"ENDOFSTAT" . $tabstring;
+(\$nlink || ((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\))) &&
+ENDOFSTAT
+ }
+ else {
+ $tabstring .= <<"ENDOFSTAT" . $tabstring;
+((\$dev,\$ino,\$mode,\$nlink,\$uid,\$gid) = $stat\(\$_\)) &&
+ENDOFSTAT
+ }
+ $statdone = 1;
+ }
+ }
+ $tabstring =~ s/^\s+/ / if $out =~ /!$/;
+ $tabstring;
+}
+
+sub fileglob_to_re {
+ local($tmp) = @_;
+
+ $tmp =~ s#([./^\$()])#\\$1#g;
+ $tmp =~ s/([?*])/.$1/g;
+ "^$tmp\$";
+}
+
+sub n {
+ local($n) = @_;
+
+ $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
+ $n =~ s/ 0*(\d)/ $1/;
+ $n . ')';
+}
+
+sub quote {
+ local($string) = @_;
+ $string =~ s/'/\\'/;
+ "'$string'";
+}
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/x2p/hash.c b/contrib/perl5/x2p/hash.c
new file mode 100644
index 000000000000..f11f7dfc55bb
--- /dev/null
+++ b/contrib/perl5/x2p/hash.c
@@ -0,0 +1,232 @@
+/* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:20 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: hash.c,v $
+ */
+
+#include <stdio.h>
+#include "EXTERN.h"
+#include "a2p.h"
+#include "util.h"
+
+STR *
+hfetch(register HASH *tb, char *key)
+{
+ register char *s;
+ register int i;
+ register int hash;
+ register HENT *entry;
+
+ if (!tb)
+ return Nullstr;
+ for (s=key, i=0, hash = 0;
+ /* while */ *s;
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+ entry = tb->tbl_array[hash & tb->tbl_max];
+ for (; entry; entry = entry->hent_next) {
+ if (entry->hent_hash != hash) /* strings can't be equal */
+ continue;
+ if (strNE(entry->hent_key,key)) /* is this it? */
+ continue;
+ return entry->hent_val;
+ }
+ return Nullstr;
+}
+
+bool
+hstore(register HASH *tb, char *key, STR *val)
+{
+ register char *s;
+ register int i;
+ register int hash;
+ register HENT *entry;
+ register HENT **oentry;
+
+ if (!tb)
+ return FALSE;
+ for (s=key, i=0, hash = 0;
+ /* while */ *s;
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+
+ oentry = &(tb->tbl_array[hash & tb->tbl_max]);
+ i = 1;
+
+ for (entry = *oentry; entry; i=0, entry = entry->hent_next) {
+ if (entry->hent_hash != hash) /* strings can't be equal */
+ continue;
+ if (strNE(entry->hent_key,key)) /* is this it? */
+ continue;
+ /*NOSTRICT*/
+ safefree(entry->hent_val);
+ entry->hent_val = val;
+ return TRUE;
+ }
+ /*NOSTRICT*/
+ entry = (HENT*) safemalloc(sizeof(HENT));
+
+ entry->hent_key = savestr(key);
+ entry->hent_val = val;
+ entry->hent_hash = hash;
+ entry->hent_next = *oentry;
+ *oentry = entry;
+
+ if (i) { /* initial entry? */
+ tb->tbl_fill++;
+ if ((tb->tbl_fill * 100 / (tb->tbl_max + 1)) > FILLPCT)
+ hsplit(tb);
+ }
+
+ return FALSE;
+}
+
+#ifdef NOTUSED
+bool
+hdelete(tb,key)
+register HASH *tb;
+char *key;
+{
+ register char *s;
+ register int i;
+ register int hash;
+ register HENT *entry;
+ register HENT **oentry;
+
+ if (!tb)
+ return FALSE;
+ for (s=key, i=0, hash = 0;
+ /* while */ *s;
+ s++, i++, hash *= 5) {
+ hash += *s * coeff[i];
+ }
+
+ oentry = &(tb->tbl_array[hash & tb->tbl_max]);
+ entry = *oentry;
+ i = 1;
+ for (; entry; i=0, oentry = &entry->hent_next, entry = entry->hent_next) {
+ if (entry->hent_hash != hash) /* strings can't be equal */
+ continue;
+ if (strNE(entry->hent_key,key)) /* is this it? */
+ continue;
+ safefree((char*)entry->hent_val);
+ safefree(entry->hent_key);
+ *oentry = entry->hent_next;
+ safefree((char*)entry);
+ if (i)
+ tb->tbl_fill--;
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif
+
+void
+hsplit(HASH *tb)
+{
+ int oldsize = tb->tbl_max + 1;
+ register int newsize = oldsize * 2;
+ register int i;
+ register HENT **a;
+ register HENT **b;
+ register HENT *entry;
+ register HENT **oentry;
+
+ a = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*));
+ bzero((char*)&a[oldsize], oldsize * sizeof(HENT*)); /* zero second half */
+ tb->tbl_max = --newsize;
+ tb->tbl_array = a;
+
+ for (i=0; i<oldsize; i++,a++) {
+ if (!*a) /* non-existent */
+ continue;
+ b = a+oldsize;
+ for (oentry = a, entry = *a; entry; entry = *oentry) {
+ if ((entry->hent_hash & newsize) != i) {
+ *oentry = entry->hent_next;
+ entry->hent_next = *b;
+ if (!*b)
+ tb->tbl_fill++;
+ *b = entry;
+ continue;
+ }
+ else
+ oentry = &entry->hent_next;
+ }
+ if (!*a) /* everything moved */
+ tb->tbl_fill--;
+ }
+}
+
+HASH *
+hnew(void)
+{
+ register HASH *tb = (HASH*)safemalloc(sizeof(HASH));
+
+ tb->tbl_array = (HENT**) safemalloc(8 * sizeof(HENT*));
+ tb->tbl_fill = 0;
+ tb->tbl_max = 7;
+ hiterinit(tb); /* so each() will start off right */
+ bzero((char*)tb->tbl_array, 8 * sizeof(HENT*));
+ return tb;
+}
+
+#ifdef NOTUSED
+hshow(tb)
+register HASH *tb;
+{
+ fprintf(stderr,"%5d %4d (%2d%%)\n",
+ tb->tbl_max+1,
+ tb->tbl_fill,
+ tb->tbl_fill * 100 / (tb->tbl_max+1));
+}
+#endif
+
+int
+hiterinit(register HASH *tb)
+{
+ tb->tbl_riter = -1;
+ tb->tbl_eiter = Null(HENT*);
+ return tb->tbl_fill;
+}
+
+HENT *
+hiternext(register HASH *tb)
+{
+ register HENT *entry;
+
+ entry = tb->tbl_eiter;
+ do {
+ if (entry)
+ entry = entry->hent_next;
+ if (!entry) {
+ tb->tbl_riter++;
+ if (tb->tbl_riter > tb->tbl_max) {
+ tb->tbl_riter = -1;
+ break;
+ }
+ entry = tb->tbl_array[tb->tbl_riter];
+ }
+ } while (!entry);
+
+ tb->tbl_eiter = entry;
+ return entry;
+}
+
+char *
+hiterkey(register HENT *entry)
+{
+ return entry->hent_key;
+}
+
+STR *
+hiterval(register HENT *entry)
+{
+ return entry->hent_val;
+}
diff --git a/contrib/perl5/x2p/hash.h b/contrib/perl5/x2p/hash.h
new file mode 100644
index 000000000000..9dc64a1dcd5d
--- /dev/null
+++ b/contrib/perl5/x2p/hash.h
@@ -0,0 +1,52 @@
+/* $RCSfile: hash.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:21 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: hash.h,v $
+ */
+
+#define FILLPCT 60 /* don't make greater than 99 */
+
+#ifdef DOINIT
+char coeff[] = {
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
+#else
+extern char coeff[];
+#endif
+
+typedef struct hentry HENT;
+
+struct hentry {
+ HENT *hent_next;
+ char *hent_key;
+ STR *hent_val;
+ int hent_hash;
+};
+
+struct htbl {
+ HENT **tbl_array;
+ int tbl_max;
+ int tbl_fill;
+ int tbl_riter; /* current root of iterator */
+ HENT *tbl_eiter; /* current entry of iterator */
+};
+
+bool hdelete _((HASH *tb, char *key));
+STR * hfetch _(( HASH *tb, char *key ));
+int hiterinit _(( HASH *tb ));
+char * hiterkey _(( HENT *entry ));
+HENT * hiternext _(( HASH *tb ));
+STR * hiterval _(( HENT *entry ));
+HASH * hnew _(( void ));
+void hsplit _(( HASH *tb ));
+bool hstore _(( HASH *tb, char *key, STR *val ));
diff --git a/contrib/perl5/x2p/proto.h b/contrib/perl5/x2p/proto.h
new file mode 100644
index 000000000000..85d749616aef
--- /dev/null
+++ b/contrib/perl5/x2p/proto.h
@@ -0,0 +1,8 @@
+/* proto.h
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ */
diff --git a/contrib/perl5/x2p/s2p.PL b/contrib/perl5/x2p/s2p.PL
new file mode 100644
index 000000000000..dbcb27c1361d
--- /dev/null
+++ b/contrib/perl5/x2p/s2p.PL
@@ -0,0 +1,848 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+use Cwd;
+
+# List explicitly here the variables you want Configure to
+# generate. Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries. Thus you write
+# $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+\$startperl = "$Config{startperl}";
+\$perlpath = "$Config{perlpath}";
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+
+# $RCSfile: s2p.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:23 $
+#
+# $Log: s2p.SH,v $
+
+=head1 NAME
+
+s2p - Sed to Perl translator
+
+=head1 SYNOPSIS
+
+B<s2p [options] filename>
+
+=head1 DESCRIPTION
+
+I<S2p> takes a sed script specified on the command line (or from
+standard input) and produces a comparable I<perl> script on the
+standard output.
+
+=head2 Options
+
+Options include:
+
+=over 5
+
+=item B<-DE<lt>numberE<gt>>
+
+sets debugging flags.
+
+=item B<-n>
+
+specifies that this sed script was always invoked with a B<sed -n>.
+Otherwise a switch parser is prepended to the front of the script.
+
+=item B<-p>
+
+specifies that this sed script was never invoked with a B<sed -n>.
+Otherwise a switch parser is prepended to the front of the script.
+
+=back
+
+=head2 Considerations
+
+The perl script produced looks very sed-ish, and there may very well
+be better ways to express what you want to do in perl. For instance,
+s2p does not make any use of the split operator, but you might want
+to.
+
+The perl script you end up with may be either faster or slower than
+the original sed script. If you're only interested in speed you'll
+just have to try it both ways. Of course, if you want to do something
+sed doesn't do, you have no choice. It's often possible to speed up
+the perl script by various methods, such as deleting all references to
+$\ and chop.
+
+=head1 ENVIRONMENT
+
+S2p uses no environment variables.
+
+=head1 AUTHOR
+
+Larry Wall E<lt>F<larry@wall.org>E<gt>
+
+=head1 FILES
+
+=head1 SEE ALSO
+
+ perl The perl compiler/interpreter
+
+ a2p awk to perl translator
+
+=head1 DIAGNOSTICS
+
+=head1 BUGS
+
+=cut
+
+$indent = 4;
+$shiftwidth = 4;
+$l = '{'; $r = '}';
+
+while ($ARGV[0] =~ /^-/) {
+ $_ = shift;
+ last if /^--/;
+ if (/^-D/) {
+ $debug++;
+ open(BODY,'>-');
+ next;
+ }
+ if (/^-n/) {
+ $assumen++;
+ next;
+ }
+ if (/^-p/) {
+ $assumep++;
+ next;
+ }
+ die "I don't recognize this switch: $_\n";
+}
+
+unless ($debug) {
+ open(BODY,"+>/tmp/sperl$$") ||
+ &Die("Can't open temp file: $!\n");
+}
+
+if (!$assumen && !$assumep) {
+ print BODY &q(<<'EOT');
+: while ($ARGV[0] =~ /^-/) {
+: $_ = shift;
+: last if /^--/;
+: if (/^-n/) {
+: $nflag++;
+: next;
+: }
+: die "I don't recognize this switch: $_\\n";
+: }
+:
+EOT
+}
+
+print BODY &q(<<'EOT');
+: #ifdef PRINTIT
+: #ifdef ASSUMEP
+: $printit++;
+: #else
+: $printit++ unless $nflag;
+: #endif
+: #endif
+: <><>
+: $\ = "\n"; # automatically add newline on print
+: <><>
+: #ifdef TOPLABEL
+: LINE:
+: while (chop($_ = <>)) {
+: #else
+: LINE:
+: while (<>) {
+: chop;
+: #endif
+EOT
+
+LINE:
+while (<>) {
+
+ # Wipe out surrounding whitespace.
+
+ s/[ \t]*(.*)\n$/$1/;
+
+ # Perhaps it's a label/comment.
+
+ if (/^:/) {
+ s/^:[ \t]*//;
+ $label = &make_label($_);
+ if ($. == 1) {
+ $toplabel = $label;
+ if (/^(top|(re)?start|redo|begin(ning)|again|input)$/i) {
+ $_ = <>;
+ redo LINE; # Never referenced, so delete it if not a comment.
+ }
+ }
+ $_ = "$label:";
+ if ($lastlinewaslabel++) {
+ $indent += 4;
+ print BODY &tab, ";\n";
+ $indent -= 4;
+ }
+ if ($indent >= 2) {
+ $indent -= 2;
+ $indmod = 2;
+ }
+ next;
+ } else {
+ $lastlinewaslabel = '';
+ }
+
+ # Look for one or two address clauses
+
+ $addr1 = '';
+ $addr2 = '';
+ if (s/^([0-9]+)//) {
+ $addr1 = "$1";
+ $addr1 = "\$. == $addr1" unless /^,/;
+ }
+ elsif (s/^\$//) {
+ $addr1 = 'eof()';
+ }
+ elsif (s|^/||) {
+ $addr1 = &fetchpat('/');
+ }
+ if (s/^,//) {
+ if (s/^([0-9]+)//) {
+ $addr2 = "$1";
+ } elsif (s/^\$//) {
+ $addr2 = "eof()";
+ } elsif (s|^/||) {
+ $addr2 = &fetchpat('/');
+ } else {
+ &Die("Invalid second address at line $.\n");
+ }
+ if ($addr2 =~ /^\d+$/) {
+ $addr1 .= "..$addr2";
+ }
+ else {
+ $addr1 .= "...$addr2";
+ }
+ }
+
+ # Now we check for metacommands {, }, and ! and worry
+ # about indentation.
+
+ s/^[ \t]+//;
+ # a { to keep vi happy
+ if ($_ eq '}') {
+ $indent -= 4;
+ next;
+ }
+ if (s/^!//) {
+ $if = 'unless';
+ $else = "$r else $l\n";
+ } else {
+ $if = 'if';
+ $else = '';
+ }
+ if (s/^{//) { # a } to keep vi happy
+ $indmod = 4;
+ $redo = $_;
+ $_ = '';
+ $rmaybe = '';
+ } else {
+ $rmaybe = "\n$r";
+ if ($addr2 || $addr1) {
+ $space = ' ' x $shiftwidth;
+ } else {
+ $space = '';
+ }
+ $_ = &transmogrify();
+ }
+
+ # See if we can optimize to modifier form.
+
+ if ($addr1) {
+ if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
+ $_ !~ / if / && $_ !~ / unless /) {
+ s/;$/ $if $addr1;/;
+ $_ = substr($_,$shiftwidth,1000);
+ } else {
+ $_ = "$if ($addr1) $l\n$change$_$rmaybe";
+ }
+ $change = '';
+ next LINE;
+ }
+} continue {
+ @lines = split(/\n/,$_);
+ for (@lines) {
+ unless (s/^ *<<--//) {
+ print BODY &tab;
+ }
+ print BODY $_, "\n";
+ }
+ $indent += $indmod;
+ $indmod = 0;
+ if ($redo) {
+ $_ = $redo;
+ $redo = '';
+ redo LINE;
+ }
+}
+if ($lastlinewaslabel++) {
+ $indent += 4;
+ print BODY &tab, ";\n";
+ $indent -= 4;
+}
+
+if ($appendseen || $tseen || !$assumen) {
+ $printit++ if $dseen || (!$assumen && !$assumep);
+ print BODY &q(<<'EOT');
+: #ifdef SAWNEXT
+: }
+: continue {
+: #endif
+: #ifdef PRINTIT
+: #ifdef DSEEN
+: #ifdef ASSUMEP
+: print if $printit++;
+: #else
+: if ($printit)
+: { print; }
+: else
+: { $printit++ unless $nflag; }
+: #endif
+: #else
+: print if $printit;
+: #endif
+: #else
+: print;
+: #endif
+: #ifdef TSEEN
+: $tflag = 0;
+: #endif
+: #ifdef APPENDSEEN
+: if ($atext) { chop $atext; print $atext; $atext = ''; }
+: #endif
+EOT
+
+print BODY &q(<<'EOT');
+: }
+EOT
+}
+
+unless ($debug) {
+
+ print &q(<<"EOT");
+: $startperl
+: eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+: if \$running_under_some_shell;
+:
+EOT
+ print"$opens\n" if $opens;
+ seek(BODY, 0, 0) || die "Can't rewind temp file: $!\n";
+ while (<BODY>) {
+ /^[ \t]*$/ && next;
+ /^#ifdef (\w+)/ && ((${lc $1} || &skip), next);
+ /^#else/ && (&skip, next);
+ /^#endif/ && next;
+ s/^<><>//;
+ print;
+ }
+}
+
+&Cleanup;
+exit;
+
+sub Cleanup {
+ unlink "/tmp/sperl$$";
+}
+sub Die {
+ &Cleanup;
+ die $_[0];
+}
+sub tab {
+ "\t" x ($indent / 8) . ' ' x ($indent % 8);
+}
+sub make_filehandle {
+ local($_) = $_[0];
+ local($fname) = $_;
+ if (!$seen{$fname}) {
+ $_ = "FH_" . $_ if /^\d/;
+ s/[^a-zA-Z0-9]/_/g;
+ s/^_*//;
+ $_ = "\U$_";
+ if ($fhseen{$_}) {
+ for ($tmp = "a"; $fhseen{"$_$tmp"}; $a++) {}
+ $_ .= $tmp;
+ }
+ $fhseen{$_} = 1;
+ $opens .= &q(<<"EOT");
+: open($_, '>$fname') || die "Can't create $fname: \$!";
+EOT
+ $seen{$fname} = $_;
+ }
+ $seen{$fname};
+}
+
+sub make_label {
+ local($label) = @_;
+ $label =~ s/[^a-zA-Z0-9]/_/g;
+ if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
+ $label = substr($label,0,8);
+
+ # Could be a reserved word, so capitalize it.
+ substr($label,0,1) =~ y/a-z/A-Z/
+ if $label =~ /^[a-z]/;
+
+ $label;
+}
+
+sub transmogrify {
+ { # case
+ if (/^d/) {
+ $dseen++;
+ chop($_ = &q(<<'EOT'));
+: <<--#ifdef PRINTIT
+: $printit = 0;
+: <<--#endif
+: next LINE;
+EOT
+ $sawnext++;
+ next;
+ }
+
+ if (/^n/) {
+ chop($_ = &q(<<'EOT'));
+: <<--#ifdef PRINTIT
+: <<--#ifdef DSEEN
+: <<--#ifdef ASSUMEP
+: print if $printit++;
+: <<--#else
+: if ($printit)
+: { print; }
+: else
+: { $printit++ unless $nflag; }
+: <<--#endif
+: <<--#else
+: print if $printit;
+: <<--#endif
+: <<--#else
+: print;
+: <<--#endif
+: <<--#ifdef APPENDSEEN
+: if ($atext) {chop $atext; print $atext; $atext = '';}
+: <<--#endif
+: $_ = <>;
+: chop;
+: <<--#ifdef TSEEN
+: $tflag = 0;
+: <<--#endif
+EOT
+ next;
+ }
+
+ if (/^a/) {
+ $appendseen++;
+ $command = $space . "\$atext .= <<'End_Of_Text';\n<<--";
+ $lastline = 0;
+ while (<>) {
+ s/^[ \t]*//;
+ s/^[\\]//;
+ unless (s|\\$||) { $lastline = 1;}
+ s/^([ \t]*\n)/<><>$1/;
+ $command .= $_;
+ $command .= '<<--';
+ last if $lastline;
+ }
+ $_ = $command . "End_Of_Text";
+ last;
+ }
+
+ if (/^[ic]/) {
+ if (/^c/) { $change = 1; }
+ $addr1 = 1 if $addr1 eq '';
+ $addr1 = '$iter = (' . $addr1 . ')';
+ $command = $space .
+ " if (\$iter == 1) { print <<'End_Of_Text'; }\n<<--";
+ $lastline = 0;
+ while (<>) {
+ s/^[ \t]*//;
+ s/^[\\]//;
+ unless (s/\\$//) { $lastline = 1;}
+ s/'/\\'/g;
+ s/^([ \t]*\n)/<><>$1/;
+ $command .= $_;
+ $command .= '<<--';
+ last if $lastline;
+ }
+ $_ = $command . "End_Of_Text";
+ if ($change) {
+ $dseen++;
+ $change = "$_\n";
+ chop($_ = &q(<<"EOT"));
+: <<--#ifdef PRINTIT
+: $space\$printit = 0;
+: <<--#endif
+: ${space}next LINE;
+EOT
+ $sawnext++;
+ }
+ last;
+ }
+
+ if (/^s/) {
+ $delim = substr($_,1,1);
+ $len = length($_);
+ $repl = $end = 0;
+ $inbracket = 0;
+ for ($i = 2; $i < $len; $i++) {
+ $c = substr($_,$i,1);
+ if ($c eq $delim) {
+ if ($inbracket) {
+ substr($_, $i, 0) = '\\';
+ $i++;
+ $len++;
+ }
+ else {
+ if ($repl) {
+ $end = $i;
+ last;
+ } else {
+ $repl = $i;
+ }
+ }
+ }
+ elsif ($c eq '\\') {
+ $i++;
+ if ($i >= $len) {
+ $_ .= 'n';
+ $_ .= <>;
+ $len = length($_);
+ $_ = substr($_,0,--$len);
+ }
+ elsif (substr($_,$i,1) =~ /^[n]$/) {
+ ;
+ }
+ elsif (!$repl &&
+ substr($_,$i,1) =~ /^[(){}\w]$/) {
+ $i--;
+ $len--;
+ substr($_, $i, 1) = '';
+ }
+ elsif (!$repl &&
+ substr($_,$i,1) =~ /^[<>]$/) {
+ substr($_,$i,1) = 'b';
+ }
+ elsif ($repl && substr($_,$i,1) =~ /^\d$/) {
+ substr($_,$i-1,1) = '$';
+ }
+ }
+ elsif ($c eq '&' && $repl) {
+ substr($_, $i, 0) = '$';
+ $i++;
+ $len++;
+ }
+ elsif ($c eq '$' && $repl) {
+ substr($_, $i, 0) = '\\';
+ $i++;
+ $len++;
+ }
+ elsif ($c eq '[' && !$repl) {
+ $i++ if substr($_,$i,1) eq '^';
+ $i++ if substr($_,$i,1) eq ']';
+ $inbracket = 1;
+ }
+ elsif ($c eq ']') {
+ $inbracket = 0;
+ }
+ elsif ($c eq "\t") {
+ substr($_, $i, 1) = '\\t';
+ $i++;
+ $len++;
+ }
+ elsif (!$repl && index("()+",$c) >= 0) {
+ substr($_, $i, 0) = '\\';
+ $i++;
+ $len++;
+ }
+ }
+ &Die("Malformed substitution at line $.\n")
+ unless $end;
+ $pat = substr($_, 0, $repl + 1);
+ $repl = substr($_, $repl+1, $end-$repl-1);
+ $end = substr($_, $end + 1, 1000);
+ &simplify($pat);
+ $subst = "$pat$repl$delim";
+ $cmd = '';
+ while ($end) {
+ if ($end =~ s/^g//) {
+ $subst .= 'g';
+ next;
+ }
+ if ($end =~ s/^p//) {
+ $cmd .= ' && (print)';
+ next;
+ }
+ if ($end =~ s/^w[ \t]*//) {
+ $fh = &make_filehandle($end);
+ $cmd .= " && (print $fh \$_)";
+ $end = '';
+ next;
+ }
+ &Die("Unrecognized substitution command".
+ "($end) at line $.\n");
+ }
+ chop ($_ = &q(<<"EOT"));
+: <<--#ifdef TSEEN
+: $subst && \$tflag++$cmd;
+: <<--#else
+: $subst$cmd;
+: <<--#endif
+EOT
+ next;
+ }
+
+ if (/^p/) {
+ $_ = 'print;';
+ next;
+ }
+
+ if (/^w/) {
+ s/^w[ \t]*//;
+ $fh = &make_filehandle($_);
+ $_ = "print $fh \$_;";
+ next;
+ }
+
+ if (/^r/) {
+ $appendseen++;
+ s/^r[ \t]*//;
+ $file = $_;
+ $_ = "\$atext .= `cat $file 2>/dev/null`;";
+ next;
+ }
+
+ if (/^P/) {
+ $_ = 'print $1 if /^(.*)/;';
+ next;
+ }
+
+ if (/^D/) {
+ chop($_ = &q(<<'EOT'));
+: s/^.*\n?//;
+: redo LINE if $_;
+: next LINE;
+EOT
+ $sawnext++;
+ next;
+ }
+
+ if (/^N/) {
+ chop($_ = &q(<<'EOT'));
+: $_ .= "\n";
+: $len1 = length;
+: $_ .= <>;
+: chop if $len1 < length;
+: <<--#ifdef TSEEN
+: $tflag = 0;
+: <<--#endif
+EOT
+ next;
+ }
+
+ if (/^h/) {
+ $_ = '$hold = $_;';
+ next;
+ }
+
+ if (/^H/) {
+ $_ = '$hold .= "\n"; $hold .= $_;';
+ next;
+ }
+
+ if (/^g/) {
+ $_ = '$_ = $hold;';
+ next;
+ }
+
+ if (/^G/) {
+ $_ = '$_ .= "\n"; $_ .= $hold;';
+ next;
+ }
+
+ if (/^x/) {
+ $_ = '($_, $hold) = ($hold, $_);';
+ next;
+ }
+
+ if (/^b$/) {
+ $_ = 'next LINE;';
+ $sawnext++;
+ next;
+ }
+
+ if (/^b/) {
+ s/^b[ \t]*//;
+ $lab = &make_label($_);
+ if ($lab eq $toplabel) {
+ $_ = 'redo LINE;';
+ } else {
+ $_ = "goto $lab;";
+ }
+ next;
+ }
+
+ if (/^t$/) {
+ $_ = 'next LINE if $tflag;';
+ $sawnext++;
+ $tseen++;
+ next;
+ }
+
+ if (/^t/) {
+ s/^t[ \t]*//;
+ $lab = &make_label($_);
+ $_ = q/if ($tflag) {$tflag = 0; /;
+ if ($lab eq $toplabel) {
+ $_ .= 'redo LINE;}';
+ } else {
+ $_ .= "goto $lab;}";
+ }
+ $tseen++;
+ next;
+ }
+
+ if (/^y/) {
+ s/abcdefghijklmnopqrstuvwxyz/a-z/g;
+ s/ABCDEFGHIJKLMNOPQRSTUVWXYZ/A-Z/g;
+ s/abcdef/a-f/g;
+ s/ABCDEF/A-F/g;
+ s/0123456789/0-9/g;
+ s/01234567/0-7/g;
+ $_ .= ';';
+ }
+
+ if (/^=/) {
+ $_ = 'print $.;';
+ next;
+ }
+
+ if (/^q/) {
+ chop($_ = &q(<<'EOT'));
+: close(ARGV);
+: @ARGV = ();
+: next LINE;
+EOT
+ $sawnext++;
+ next;
+ }
+ } continue {
+ if ($space) {
+ s/^/$space/;
+ s/(\n)(.)/$1$space$2/g;
+ }
+ last;
+ }
+ $_;
+}
+
+sub fetchpat {
+ local($outer) = @_;
+ local($addr) = $outer;
+ local($inbracket);
+ local($prefix,$delim,$ch);
+
+ # Process pattern one potential delimiter at a time.
+
+ DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
+ $prefix = $1;
+ $delim = $2;
+ if ($delim eq '\\') {
+ s/(.)//;
+ $ch = $1;
+ $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
+ $ch = 'b' if $ch =~ /^[<>]$/;
+ $delim .= $ch;
+ }
+ elsif ($delim eq '[') {
+ $inbracket = 1;
+ s/^\^// && ($delim .= '^');
+ s/^]// && ($delim .= ']');
+ }
+ elsif ($delim eq ']') {
+ $inbracket = 0;
+ }
+ elsif ($inbracket || $delim ne $outer) {
+ $delim = '\\' . $delim;
+ }
+ $addr .= $prefix;
+ $addr .= $delim;
+ if ($delim eq $outer && !$inbracket) {
+ last DELIM;
+ }
+ }
+ $addr =~ s/\t/\\t/g;
+ &simplify($addr);
+ $addr;
+}
+
+sub q {
+ local($string) = @_;
+ local($*) = 1;
+ $string =~ s/^:\t?//g;
+ $string;
+}
+
+sub simplify {
+ $_[0] =~ s/_a-za-z0-9/\\w/ig;
+ $_[0] =~ s/a-z_a-z0-9/\\w/ig;
+ $_[0] =~ s/a-za-z_0-9/\\w/ig;
+ $_[0] =~ s/a-za-z0-9_/\\w/ig;
+ $_[0] =~ s/_0-9a-za-z/\\w/ig;
+ $_[0] =~ s/0-9_a-za-z/\\w/ig;
+ $_[0] =~ s/0-9a-z_a-z/\\w/ig;
+ $_[0] =~ s/0-9a-za-z_/\\w/ig;
+ $_[0] =~ s/\[\\w\]/\\w/g;
+ $_[0] =~ s/\[^\\w\]/\\W/g;
+ $_[0] =~ s/\[0-9\]/\\d/g;
+ $_[0] =~ s/\[^0-9\]/\\D/g;
+ $_[0] =~ s/\\d\\d\*/\\d+/g;
+ $_[0] =~ s/\\D\\D\*/\\D+/g;
+ $_[0] =~ s/\\w\\w\*/\\w+/g;
+ $_[0] =~ s/\\t\\t\*/\\t+/g;
+ $_[0] =~ s/(\[.[^]]*\])\1\*/$1+/g;
+ $_[0] =~ s/([\w\s!@#%^&-=,:;'"])\1\*/$1+/g;
+}
+
+sub skip {
+ local($level) = 0;
+
+ while(<BODY>) {
+ /^#ifdef/ && $level++;
+ /^#else/ && !$level && return;
+ /^#endif/ && !$level-- && return;
+ }
+
+ die "Unterminated `#ifdef' conditional\n";
+}
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;
diff --git a/contrib/perl5/x2p/str.c b/contrib/perl5/x2p/str.c
new file mode 100644
index 000000000000..b820a8d67da1
--- /dev/null
+++ b/contrib/perl5/x2p/str.c
@@ -0,0 +1,442 @@
+/* $RCSfile: str.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:26 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: str.c,v $
+ */
+
+#include "EXTERN.h"
+#include "a2p.h"
+#include "util.h"
+
+void
+str_numset(register STR *str, double num)
+{
+ str->str_nval = num;
+ str->str_pok = 0; /* invalidate pointer */
+ str->str_nok = 1; /* validate number */
+}
+
+char *
+str_2ptr(register STR *str)
+{
+ register char *s;
+
+ if (!str)
+ return "";
+ GROWSTR(&(str->str_ptr), &(str->str_len), 24);
+ s = str->str_ptr;
+ if (str->str_nok) {
+ sprintf(s,"%.20g",str->str_nval);
+ while (*s) s++;
+ }
+ *s = '\0';
+ str->str_cur = s - str->str_ptr;
+ str->str_pok = 1;
+#ifdef DEBUGGING
+ if (debug & 32)
+ fprintf(stderr,"0x%lx ptr(%s)\n",(unsigned long)str,str->str_ptr);
+#endif
+ return str->str_ptr;
+}
+
+double
+str_2num(register STR *str)
+{
+ if (!str)
+ return 0.0;
+ if (str->str_len && str->str_pok)
+ str->str_nval = atof(str->str_ptr);
+ else
+ str->str_nval = 0.0;
+ str->str_nok = 1;
+#ifdef DEBUGGING
+ if (debug & 32)
+ fprintf(stderr,"0x%lx num(%g)\n",(unsigned long)str,str->str_nval);
+#endif
+ return str->str_nval;
+}
+
+void
+str_sset(STR *dstr, register STR *sstr)
+{
+ if (!sstr)
+ str_nset(dstr,No,0);
+ else if (sstr->str_nok)
+ str_numset(dstr,sstr->str_nval);
+ else if (sstr->str_pok)
+ str_nset(dstr,sstr->str_ptr,sstr->str_cur);
+ else
+ str_nset(dstr,"",0);
+}
+
+void
+str_nset(register STR *str, register char *ptr, register int len)
+{
+ GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
+ bcopy(ptr,str->str_ptr,len);
+ str->str_cur = len;
+ *(str->str_ptr+str->str_cur) = '\0';
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+}
+
+void
+str_set(register STR *str, register char *ptr)
+{
+ register int len;
+
+ if (!ptr)
+ ptr = "";
+ len = strlen(ptr);
+ GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
+ bcopy(ptr,str->str_ptr,len+1);
+ str->str_cur = len;
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+}
+
+void
+str_chop(register STR *str, register char *ptr) /* like set but assuming ptr is in str */
+
+
+{
+ if (!(str->str_pok))
+ str_2ptr(str);
+ str->str_cur -= (ptr - str->str_ptr);
+ bcopy(ptr,str->str_ptr, str->str_cur + 1);
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+}
+
+void
+str_ncat(register STR *str, register char *ptr, register int len)
+{
+ if (!(str->str_pok))
+ str_2ptr(str);
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
+ bcopy(ptr,str->str_ptr+str->str_cur,len);
+ str->str_cur += len;
+ *(str->str_ptr+str->str_cur) = '\0';
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+}
+
+void
+str_scat(STR *dstr, register STR *sstr)
+{
+ if (!(sstr->str_pok))
+ str_2ptr(sstr);
+ if (sstr)
+ str_ncat(dstr,sstr->str_ptr,sstr->str_cur);
+}
+
+void
+str_cat(register STR *str, register char *ptr)
+{
+ register int len;
+
+ if (!ptr)
+ return;
+ if (!(str->str_pok))
+ str_2ptr(str);
+ len = strlen(ptr);
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
+ bcopy(ptr,str->str_ptr+str->str_cur,len+1);
+ str->str_cur += len;
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+}
+
+char *
+str_append_till(register STR *str, register char *from, register int delim, char *keeplist)
+{
+ register char *to;
+ register int len;
+
+ if (!from)
+ return Nullch;
+ len = strlen(from);
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + len + 1);
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+ to = str->str_ptr+str->str_cur;
+ for (; *from; from++,to++) {
+ if (*from == '\\' && from[1] && delim != '\\') {
+ if (!keeplist) {
+ if (from[1] == delim || from[1] == '\\')
+ from++;
+ else
+ *to++ = *from++;
+ }
+ else if (strchr(keeplist,from[1]))
+ *to++ = *from++;
+ else
+ from++;
+ }
+ else if (*from == delim)
+ break;
+ *to = *from;
+ }
+ *to = '\0';
+ str->str_cur = to - str->str_ptr;
+ return from;
+}
+
+STR *
+str_new(int len)
+{
+ register STR *str;
+
+ if (freestrroot) {
+ str = freestrroot;
+ freestrroot = str->str_link.str_next;
+ }
+ else {
+ str = (STR *) safemalloc(sizeof(STR));
+ bzero((char*)str,sizeof(STR));
+ }
+ if (len)
+ GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
+ return str;
+}
+
+void
+str_grow(register STR *str, int len)
+{
+ if (len && str)
+ GROWSTR(&(str->str_ptr), &(str->str_len), len + 1);
+}
+
+/* make str point to what nstr did */
+
+void
+str_replace(register STR *str, register STR *nstr)
+{
+ safefree(str->str_ptr);
+ str->str_ptr = nstr->str_ptr;
+ str->str_len = nstr->str_len;
+ str->str_cur = nstr->str_cur;
+ str->str_pok = nstr->str_pok;
+ if (str->str_nok = nstr->str_nok)
+ str->str_nval = nstr->str_nval;
+ safefree((char*)nstr);
+}
+
+void
+str_free(register STR *str)
+{
+ if (!str)
+ return;
+ if (str->str_len)
+ str->str_ptr[0] = '\0';
+ str->str_cur = 0;
+ str->str_nok = 0;
+ str->str_pok = 0;
+ str->str_link.str_next = freestrroot;
+ freestrroot = str;
+}
+
+int
+str_len(register STR *str)
+{
+ if (!str)
+ return 0;
+ if (!(str->str_pok))
+ str_2ptr(str);
+ if (str->str_len)
+ return str->str_cur;
+ else
+ return 0;
+}
+
+char *
+str_gets(register STR *str, register FILE *fp)
+{
+#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+ /* Here is some breathtakingly efficient cheating */
+
+ register char *bp; /* we're going to steal some values */
+ register int cnt; /* from the stdio struct and put EVERYTHING */
+ register STDCHAR *ptr; /* in the innermost loop into registers */
+ register char newline = '\n'; /* (assuming at least 6 registers) */
+ int i;
+ int bpx;
+
+#if defined(VMS)
+ /* An ungetc()d char is handled separately from the regular
+ * buffer, so we getc() it back out and stuff it in the buffer.
+ */
+ i = getc(fp);
+ if (i == EOF) return Nullch;
+ *(--((*fp)->_ptr)) = (unsigned char) i;
+ (*fp)->_cnt++;
+#endif
+
+ cnt = FILE_cnt(fp); /* get count into register */
+ str->str_nok = 0; /* invalidate number */
+ str->str_pok = 1; /* validate pointer */
+ if (str->str_len <= cnt) /* make sure we have the room */
+ GROWSTR(&(str->str_ptr), &(str->str_len), cnt+1);
+ bp = str->str_ptr; /* move these two too to registers */
+ ptr = FILE_ptr(fp);
+ for (;;) {
+ while (--cnt >= 0) {
+ if ((*bp++ = *ptr++) == newline)
+ if (bp <= str->str_ptr || bp[-2] != '\\')
+ goto thats_all_folks;
+ else {
+ line++;
+ bp -= 2;
+ }
+ }
+
+ FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */
+ FILE_ptr(fp) = ptr;
+ i = getc(fp); /* get more characters */
+ cnt = FILE_cnt(fp);
+ ptr = FILE_ptr(fp); /* reregisterize cnt and ptr */
+
+ bpx = bp - str->str_ptr; /* prepare for possible relocation */
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + cnt + 1);
+ bp = str->str_ptr + bpx; /* reconstitute our pointer */
+
+ if (i == newline) { /* all done for now? */
+ *bp++ = i;
+ goto thats_all_folks;
+ }
+ else if (i == EOF) /* all done for ever? */
+ goto thats_all_folks;
+ *bp++ = i; /* now go back to screaming loop */
+ }
+
+thats_all_folks:
+ FILE_cnt(fp) = cnt; /* put these back or we're in trouble */
+ FILE_ptr(fp) = ptr;
+ *bp = '\0';
+ str->str_cur = bp - str->str_ptr; /* set length */
+
+#else /* USE_STDIO_PTR && STDIO_PTR_LVALUE && STDIO_CNT_LVALUE */
+ /* The big, slow, and stupid way */
+
+ static char buf[4192];
+
+ if (fgets(buf, sizeof buf, fp) != Nullch)
+ str_set(str, buf);
+ else
+ str_set(str, No);
+
+#endif /* USE_STDIO_PTR && STDIO_PTR_LVALUE && STDIO_CNT_LVALUE */
+
+ return str->str_cur ? str->str_ptr : Nullch;
+}
+
+void
+str_inc(register STR *str)
+{
+ register char *d;
+
+ if (!str)
+ return;
+ if (str->str_nok) {
+ str->str_nval += 1.0;
+ str->str_pok = 0;
+ return;
+ }
+ if (!str->str_pok) {
+ str->str_nval = 1.0;
+ str->str_nok = 1;
+ return;
+ }
+ for (d = str->str_ptr; *d && *d != '.'; d++) ;
+ d--;
+ if (!isdigit(*str->str_ptr) || !isdigit(*d) ) {
+ str_numset(str,atof(str->str_ptr) + 1.0); /* punt */
+ return;
+ }
+ while (d >= str->str_ptr) {
+ if (++*d <= '9')
+ return;
+ *(d--) = '0';
+ }
+ /* oh,oh, the number grew */
+ GROWSTR(&(str->str_ptr), &(str->str_len), str->str_cur + 2);
+ str->str_cur++;
+ for (d = str->str_ptr + str->str_cur; d > str->str_ptr; d--)
+ *d = d[-1];
+ *d = '1';
+}
+
+void
+str_dec(register STR *str)
+{
+ register char *d;
+
+ if (!str)
+ return;
+ if (str->str_nok) {
+ str->str_nval -= 1.0;
+ str->str_pok = 0;
+ return;
+ }
+ if (!str->str_pok) {
+ str->str_nval = -1.0;
+ str->str_nok = 1;
+ return;
+ }
+ for (d = str->str_ptr; *d && *d != '.'; d++) ;
+ d--;
+ if (!isdigit(*str->str_ptr) || !isdigit(*d) || (*d == '0' && d == str->str_ptr)) {
+ str_numset(str,atof(str->str_ptr) - 1.0); /* punt */
+ return;
+ }
+ while (d >= str->str_ptr) {
+ if (--*d >= '0')
+ return;
+ *(d--) = '9';
+ }
+}
+
+/* make a string that will exist for the duration of the expression eval */
+
+STR *
+str_mortal(STR *oldstr)
+{
+ register STR *str = str_new(0);
+ static long tmps_size = -1;
+
+ str_sset(str,oldstr);
+ if (++tmps_max > tmps_size) {
+ tmps_size = tmps_max;
+ if (!(tmps_size & 127)) {
+ if (tmps_size)
+ tmps_list = (STR**)saferealloc((char*)tmps_list,
+ (tmps_size + 128) * sizeof(STR*) );
+ else
+ tmps_list = (STR**)safemalloc(128 * sizeof(char*));
+ }
+ }
+ tmps_list[tmps_max] = str;
+ return str;
+}
+
+STR *
+str_make(char *s)
+{
+ register STR *str = str_new(0);
+
+ str_set(str,s);
+ return str;
+}
+
+STR *
+str_nmake(double n)
+{
+ register STR *str = str_new(0);
+
+ str_numset(str,n);
+ return str;
+}
diff --git a/contrib/perl5/x2p/str.h b/contrib/perl5/x2p/str.h
new file mode 100644
index 000000000000..3deaaec76f0d
--- /dev/null
+++ b/contrib/perl5/x2p/str.h
@@ -0,0 +1,53 @@
+/* $RCSfile: str.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:27 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: str.h,v $
+ */
+
+struct string {
+ char * str_ptr; /* pointer to malloced string */
+ double str_nval; /* numeric value, if any */
+ int str_len; /* allocated size */
+ int str_cur; /* length of str_ptr as a C string */
+ union {
+ STR *str_next; /* while free, link to next free str */
+ } str_link;
+ char str_pok; /* state of str_ptr */
+ char str_nok; /* state of str_nval */
+};
+
+#define Nullstr Null(STR*)
+
+/* the following macro updates any magic values this str is associated with */
+
+#define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x))
+
+EXT STR **tmps_list;
+EXT long tmps_max INIT(-1);
+
+double str_2num _(( STR *str ));
+char * str_2ptr _(( STR *str ));
+char * str_append_till _(( STR *str, char *from, int delim, char *keeplist ));
+void str_cat _(( STR *str, char *ptr ));
+void str_chop _(( STR *str, char *ptr ));
+void str_dec _(( STR *str ));
+void str_free _(( STR *str ));
+char * str_gets _(( STR *str, FILE *fp ));
+void str_grow _(( STR *str, int len ));
+void str_inc _(( STR *str ));
+int str_len _(( STR *str ));
+STR * str_make _(( char *s ));
+STR * str_mortal _(( STR *oldstr ));
+void str_ncat _(( STR *str, char *ptr, int len ));
+STR * str_new _(( int len ));
+STR * str_nmake _(( double n ));
+void str_nset _(( STR *str, char *ptr, int len ));
+void str_numset _(( STR *str, double num ));
+void str_replace _(( STR *str, STR *nstr ));
+void str_scat _(( STR *dstr, STR *sstr ));
+void str_set _(( STR *str, char *ptr ));
+void str_sset _(( STR *dstr, STR *sstr ));
diff --git a/contrib/perl5/x2p/util.c b/contrib/perl5/x2p/util.c
new file mode 100644
index 000000000000..364dfe94fa48
--- /dev/null
+++ b/contrib/perl5/x2p/util.c
@@ -0,0 +1,218 @@
+/* $RCSfile: util.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:29 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: util.c,v $
+ */
+
+#include "EXTERN.h"
+#include "a2p.h"
+#include "INTERN.h"
+#include "util.h"
+
+#include <stdarg.h>
+#define FLUSH
+
+static char nomem[] = "Out of memory!\n";
+
+/* paranoid version of malloc */
+
+
+Malloc_t
+safemalloc(MEM_SIZE size)
+{
+ Malloc_t ptr;
+
+ /* malloc(0) is NASTY on some systems */
+ ptr = malloc(size ? size : 1);
+#ifdef DEBUGGING
+ if (debug & 128)
+ fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",(unsigned long)ptr,
+ an++,(long)size);
+#endif
+ if (ptr != Nullch)
+ return ptr;
+ else {
+ fputs(nomem,stdout) FLUSH;
+ exit(1);
+ }
+ /*NOTREACHED*/
+ return 0;
+}
+
+/* paranoid version of realloc */
+
+Malloc_t
+saferealloc(Malloc_t where, MEM_SIZE size)
+{
+ Malloc_t ptr;
+
+ /* realloc(0) is NASTY on some systems */
+ ptr = realloc(where, size ? size : 1);
+#ifdef DEBUGGING
+ if (debug & 128) {
+ fprintf(stderr,"0x%lx: (%05d) rfree\n",(unsigned long)where,an++);
+ fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",(unsigned long)ptr,an++,(long)size);
+ }
+#endif
+ if (ptr != Nullch)
+ return ptr;
+ else {
+ fputs(nomem,stdout) FLUSH;
+ exit(1);
+ }
+ /*NOTREACHED*/
+ return 0;
+}
+
+/* safe version of free */
+
+Free_t
+safefree(Malloc_t where)
+{
+#ifdef DEBUGGING
+ if (debug & 128)
+ fprintf(stderr,"0x%lx: (%05d) free\n",(unsigned long)where,an++);
+#endif
+ free(where);
+}
+
+/* safe version of string copy */
+
+char *
+safecpy(char *to, register char *from, register int len)
+{
+ register char *dest = to;
+
+ if (from != Nullch)
+ for (len--; len && (*dest++ = *from++); len--) ;
+ *dest = '\0';
+ return to;
+}
+
+/* copy a string up to some (non-backslashed) delimiter, if any */
+
+char *
+cpytill(register char *to, register char *from, register int delim)
+{
+ for (; *from; from++,to++) {
+ if (*from == '\\') {
+ if (from[1] == delim)
+ from++;
+ else if (from[1] == '\\')
+ *to++ = *from++;
+ }
+ else if (*from == delim)
+ break;
+ *to = *from;
+ }
+ *to = '\0';
+ return from;
+}
+
+
+char *
+cpy2(register char *to, register char *from, register int delim)
+{
+ for (; *from; from++,to++) {
+ if (*from == '\\')
+ *to++ = *from++;
+ else if (*from == '$')
+ *to++ = '\\';
+ else if (*from == delim)
+ break;
+ *to = *from;
+ }
+ *to = '\0';
+ return from;
+}
+
+/* return ptr to little string in big string, NULL if not found */
+
+char *
+instr(char *big, char *little)
+{
+ register char *t, *s, *x;
+
+ for (t = big; *t; t++) {
+ for (x=t,s=little; *s; x++,s++) {
+ if (!*x)
+ return Nullch;
+ if (*s != *x)
+ break;
+ }
+ if (!*s)
+ return t;
+ }
+ return Nullch;
+}
+
+/* copy a string to a safe spot */
+
+char *
+savestr(char *str)
+{
+ register char *newaddr = (char *) safemalloc((MEM_SIZE)(strlen(str)+1));
+
+ (void)strcpy(newaddr,str);
+ return newaddr;
+}
+
+/* grow a static string to at least a certain length */
+
+void
+growstr(char **strptr, int *curlen, int newlen)
+{
+ if (newlen > *curlen) { /* need more room? */
+ if (*curlen)
+ *strptr = (char *) saferealloc(*strptr,(MEM_SIZE)newlen);
+ else
+ *strptr = (char *) safemalloc((MEM_SIZE)newlen);
+ *curlen = newlen;
+ }
+}
+
+void
+croak(char *pat,...)
+{
+#if defined(HAS_VPRINTF)
+ va_list args;
+
+ va_start(args, pat);
+ vfprintf(stderr,pat,args);
+#else
+ fprintf(stderr,pat,a1,a2,a3,a4);
+#endif
+ exit(1);
+}
+
+void
+fatal(char *pat,...)
+{
+#if defined(HAS_VPRINTF)
+ va_list args;
+
+ va_start(args, pat);
+ vfprintf(stderr,pat,args);
+#else
+ fprintf(stderr,pat,a1,a2,a3,a4);
+#endif
+ exit(1);
+}
+
+void
+warn(char *pat,...)
+{
+#if defined(HAS_VPRINTF)
+ va_list args;
+
+ va_start(args, pat);
+ vfprintf(stderr,pat,args);
+#else
+ fprintf(stderr,pat,a1,a2,a3,a4);
+#endif
+}
+
diff --git a/contrib/perl5/x2p/util.h b/contrib/perl5/x2p/util.h
new file mode 100644
index 000000000000..aa31bea21768
--- /dev/null
+++ b/contrib/perl5/x2p/util.h
@@ -0,0 +1,39 @@
+/* $RCSfile: util.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:30 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: util.h,v $
+ */
+
+/* is the string for makedir a directory name or a filename? */
+
+#define fatal Myfatal
+
+#define MD_DIR 0
+#define MD_FILE 1
+
+#ifdef SETUIDGID
+ int eaccess();
+#endif
+
+char *getwd();
+int makedir();
+
+char * cpy2 _(( char *to, char *from, int delim ));
+char * cpytill _(( char *to, char *from, int delim ));
+void growstr _(( char **strptr, int *curlen, int newlen ));
+char * instr _(( char *big, char *little ));
+char * safecpy _(( char *to, char *from, int len ));
+char * savestr _(( char *str ));
+void croak _(( char *pat, ... ));
+void fatal _(( char *pat, ... ));
+void warn _(( char *pat, ... ));
+int prewalk _(( int numit, int level, int node, int *numericptr ));
+
+Malloc_t safemalloc _((MEM_SIZE nbytes));
+Malloc_t safecalloc _((MEM_SIZE elements, MEM_SIZE size));
+Malloc_t saferealloc _((Malloc_t where, MEM_SIZE nbytes));
+Free_t safefree _((Malloc_t where));
diff --git a/contrib/perl5/x2p/walk.c b/contrib/perl5/x2p/walk.c
new file mode 100644
index 000000000000..0b4065586bac
--- /dev/null
+++ b/contrib/perl5/x2p/walk.c
@@ -0,0 +1,2066 @@
+/* $RCSfile: walk.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:31 $
+ *
+ * Copyright (c) 1991-1997, Larry Wall
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ *
+ * $Log: walk.c,v $
+ */
+
+#include "EXTERN.h"
+#include "a2p.h"
+#include "util.h"
+
+bool exitval = FALSE;
+bool realexit = FALSE;
+bool saw_getline = FALSE;
+bool subretnum = FALSE;
+bool saw_FNR = FALSE;
+bool saw_argv0 = FALSE;
+bool saw_fh = FALSE;
+int maxtmp = 0;
+char *lparen;
+char *rparen;
+char *limit;
+STR *subs;
+STR *curargs = Nullstr;
+
+static void addsemi _(( STR *str ));
+static void emit_split _(( STR *str, int level ));
+static void fixtab _(( STR *str, int lvl ));
+static void numericize _(( int node ));
+static void tab _(( STR *str, int lvl ));
+
+int prewalk _(( int numit, int level, int node, int *numericptr ));
+STR * walk _(( int useval, int level, int node, int *numericptr, int minprec ));
+
+
+STR *
+walk(int useval, int level, register int node, int *numericptr, int minprec)
+
+
+
+
+ /* minimum precedence without parens */
+{
+ register int len;
+ register STR *str;
+ register int type;
+ register int i;
+ register STR *tmpstr;
+ STR *tmp2str;
+ STR *tmp3str;
+ char *t;
+ char *d, *s;
+ int numarg;
+ int numeric = FALSE;
+ STR *fstr;
+ int prec = P_MAX; /* assume no parens needed */
+
+ if (!node) {
+ *numericptr = 0;
+ return str_make("");
+ }
+ type = ops[node].ival;
+ len = type >> 8;
+ type &= 255;
+ switch (type) {
+ case OPROG:
+ arymax = 0;
+ if (namelist) {
+ while (isalpha(*namelist)) {
+ for (d = tokenbuf,s=namelist;
+ isalpha(*s) || isdigit(*s) || *s == '_';
+ *d++ = *s++) ;
+ *d = '\0';
+ while (*s && !isalpha(*s)) s++;
+ namelist = s;
+ nameary[++arymax] = savestr(tokenbuf);
+ }
+ }
+ if (maxfld < arymax)
+ maxfld = arymax;
+ opens = str_new(0);
+ subs = str_new(0);
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ if (do_split && need_entire && !absmaxfld)
+ split_to_array = TRUE;
+ if (do_split && split_to_array)
+ set_array_base = TRUE;
+ if (set_array_base) {
+ str_cat(str,"$[ = 1;\t\t\t# set array base to 1\n");
+ }
+ if (fswitch && !const_FS)
+ const_FS = fswitch;
+ if (saw_FS > 1 || saw_RS)
+ const_FS = 0;
+ if (saw_ORS && need_entire)
+ do_chop = TRUE;
+ if (fswitch) {
+ str_cat(str,"$FS = '");
+ if (strchr("*+?.[]()|^$\\",fswitch))
+ str_cat(str,"\\");
+ sprintf(tokenbuf,"%c",fswitch);
+ str_cat(str,tokenbuf);
+ str_cat(str,"';\t\t# field separator from -F switch\n");
+ }
+ else if (saw_FS && !const_FS) {
+ str_cat(str,"$FS = ' ';\t\t# set field separator\n");
+ }
+ if (saw_OFS) {
+ str_cat(str,"$, = ' ';\t\t# set output field separator\n");
+ }
+ if (saw_ORS) {
+ str_cat(str,"$\\ = \"\\n\";\t\t# set output record separator\n");
+ }
+ if (saw_argv0) {
+ str_cat(str,"$ARGV0 = $0;\t\t# remember what we ran as\n");
+ }
+ if (str->str_cur > 20)
+ str_cat(str,"\n");
+ if (ops[node+2].ival) {
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,"\n\n");
+ }
+ fstr = walk(0,level+1,ops[node+3].ival,&numarg,P_MIN);
+ if (*fstr->str_ptr) {
+ if (saw_line_op)
+ str_cat(str,"line: ");
+ str_cat(str,"while (<>) {\n");
+ tab(str,++level);
+ if (saw_FS && !const_FS)
+ do_chop = TRUE;
+ if (do_chop) {
+ str_cat(str,"chop;\t# strip record separator\n");
+ tab(str,level);
+ }
+ if (do_split)
+ emit_split(str,level);
+ str_scat(str,fstr);
+ str_free(fstr);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ if (saw_FNR)
+ str_cat(str,"continue {\n $FNRbase = $. if eof;\n}\n");
+ }
+ else if (old_awk)
+ str_cat(str,"while (<>) { } # (no line actions)\n");
+ if (ops[node+4].ival) {
+ realexit = TRUE;
+ str_cat(str,"\n");
+ tab(str,level);
+ str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,"\n");
+ }
+ if (exitval)
+ str_cat(str,"exit $ExitValue;\n");
+ if (subs->str_ptr) {
+ str_cat(str,"\n");
+ str_scat(str,subs);
+ }
+ if (saw_getline) {
+ for (len = 0; len < 4; len++) {
+ if (saw_getline & (1 << len)) {
+ sprintf(tokenbuf,"\nsub Getline%d {\n",len);
+ str_cat(str, tokenbuf);
+ if (len & 2) {
+ if (do_fancy_opens)
+ str_cat(str," &Pick('',@_);\n");
+ else
+ str_cat(str," ($fh) = @_;\n");
+ }
+ else {
+ if (saw_FNR)
+ str_cat(str," $FNRbase = $. if eof;\n");
+ }
+ if (len & 1)
+ str_cat(str," local($_);\n");
+ if (len & 2)
+ str_cat(str,
+ " if ($getline_ok = (($_ = <$fh>) ne ''))");
+ else
+ str_cat(str,
+ " if ($getline_ok = (($_ = <>) ne ''))");
+ str_cat(str, " {\n");
+ level += 2;
+ tab(str,level);
+ i = 0;
+ if (do_chop) {
+ i++;
+ str_cat(str,"chop;\t# strip record separator\n");
+ tab(str,level);
+ }
+ if (do_split && !(len & 1)) {
+ i++;
+ emit_split(str,level);
+ }
+ if (!i)
+ str_cat(str,";\n");
+ fixtab(str,--level);
+ str_cat(str,"}\n $_;\n}\n");
+ --level;
+ }
+ }
+ }
+ if (do_fancy_opens) {
+ str_cat(str,"\n\
+sub Pick {\n\
+ local($mode,$name,$pipe) = @_;\n\
+ $fh = $name;\n\
+ open($name,$mode.$name.$pipe) unless $opened{$name}++;\n\
+}\n\
+");
+ }
+ break;
+ case OHUNKS:
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ if (len == 3) {
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ else {
+ }
+ break;
+ case ORANGE:
+ prec = P_DOTDOT;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
+ str_cat(str," .. ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OPAT:
+ goto def;
+ case OREGEX:
+ str = str_new(0);
+ str_set(str,"/");
+ tmpstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ /* translate \nnn to [\nnn] */
+ for (s = tmpstr->str_ptr, d = tokenbuf; *s; s++, d++) {
+ if (*s == '\\' && isdigit(s[1]) && isdigit(s[2]) && isdigit(s[3])){
+ *d++ = '[';
+ *d++ = *s++;
+ *d++ = *s++;
+ *d++ = *s++;
+ *d++ = *s;
+ *d = ']';
+ }
+ else
+ *d = *s;
+ }
+ *d = '\0';
+ for (d=tokenbuf; *d; d++)
+ *d += 128;
+ str_cat(str,tokenbuf);
+ str_free(tmpstr);
+ str_cat(str,"/");
+ break;
+ case OHUNK:
+ if (len == 1) {
+ str = str_new(0);
+ str = walk(0,level,oper1(OPRINT,0),&numarg,P_MIN);
+ str_cat(str," if ");
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,";");
+ }
+ else {
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ if (*tmpstr->str_ptr) {
+ str = str_new(0);
+ str_set(str,"if (");
+ str_scat(str,tmpstr);
+ str_cat(str,") {\n");
+ tab(str,++level);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ tab(str,level);
+ }
+ else {
+ str = walk(0,level,ops[node+2].ival,&numarg,P_MIN);
+ }
+ }
+ break;
+ case OPPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,")");
+ break;
+ case OPANDAND:
+ prec = P_ANDAND;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," && ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OPOROR:
+ prec = P_OROR;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," || ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OPNOT:
+ prec = P_UNARY;
+ str = str_new(0);
+ str_set(str,"!");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec));
+ str_free(fstr);
+ break;
+ case OCOND:
+ prec = P_COND;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," ? ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_cat(str," : ");
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OCPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ numeric |= numarg;
+ str_cat(str,")");
+ break;
+ case OCANDAND:
+ prec = P_ANDAND;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ numeric = 1;
+ str_cat(str," && ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OCOROR:
+ prec = P_OROR;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ numeric = 1;
+ str_cat(str," || ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OCNOT:
+ prec = P_UNARY;
+ str = str_new(0);
+ str_set(str,"!");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case ORELOP:
+ prec = P_REL;
+ str = walk(1,level,ops[node+2].ival,&numarg,prec+1);
+ numeric |= numarg;
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ tmp2str = walk(1,level,ops[node+3].ival,&numarg,prec+1);
+ numeric |= numarg;
+ if (!numeric ||
+ (!numarg && (*tmp2str->str_ptr == '"' || *tmp2str->str_ptr == '\''))) {
+ t = tmpstr->str_ptr;
+ if (strEQ(t,"=="))
+ str_set(tmpstr,"eq");
+ else if (strEQ(t,"!="))
+ str_set(tmpstr,"ne");
+ else if (strEQ(t,"<"))
+ str_set(tmpstr,"lt");
+ else if (strEQ(t,"<="))
+ str_set(tmpstr,"le");
+ else if (strEQ(t,">"))
+ str_set(tmpstr,"gt");
+ else if (strEQ(t,">="))
+ str_set(tmpstr,"ge");
+ if (!strchr(tmpstr->str_ptr,'\'') && !strchr(tmpstr->str_ptr,'"') &&
+ !strchr(tmp2str->str_ptr,'\'') && !strchr(tmp2str->str_ptr,'"') )
+ numeric |= 2;
+ }
+ if (numeric & 2) {
+ if (numeric & 1) /* numeric is very good guess */
+ str_cat(str," ");
+ else
+ str_cat(str,"\377");
+ numeric = 1;
+ }
+ else
+ str_cat(str," ");
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ str_cat(str," ");
+ str_scat(str,tmp2str);
+ str_free(tmp2str);
+ numeric = 1;
+ break;
+ case ORPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ numeric |= numarg;
+ str_cat(str,")");
+ break;
+ case OMATCHOP:
+ prec = P_MATCH;
+ str = walk(1,level,ops[node+2].ival,&numarg,prec+1);
+ str_cat(str," ");
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ if (strEQ(tmpstr->str_ptr,"~"))
+ str_cat(str,"=~");
+ else {
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ }
+ str_cat(str," ");
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OMPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,
+ fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ numeric |= numarg;
+ str_cat(str,")");
+ break;
+ case OCONCAT:
+ prec = P_ADD;
+ type = ops[ops[node+1].ival].ival & 255;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+(type != OCONCAT));
+ str_cat(str," . ");
+ type = ops[ops[node+2].ival].ival & 255;
+ str_scat(str,
+ fstr=walk(1,level,ops[node+2].ival,&numarg,prec+(type != OCONCAT)));
+ str_free(fstr);
+ break;
+ case OASSIGN:
+ prec = P_ASSIGN;
+ str = walk(0,level,ops[node+2].ival,&numarg,prec+1);
+ str_cat(str," ");
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ str_scat(str,tmpstr);
+ if (str_len(tmpstr) > 1)
+ numeric = 1;
+ str_free(tmpstr);
+ str_cat(str," ");
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec));
+ str_free(fstr);
+ numeric |= numarg;
+ if (strEQ(str->str_ptr,"$/ = ''"))
+ str_set(str, "$/ = \"\\n\\n\"");
+ break;
+ case OADD:
+ prec = P_ADD;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," + ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OSUBTRACT:
+ prec = P_ADD;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," - ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OMULT:
+ prec = P_MUL;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," * ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case ODIV:
+ prec = P_MUL;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," / ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OPOW:
+ prec = P_POW;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
+ str_cat(str," ** ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OMOD:
+ prec = P_MUL;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str," % ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OPOSTINCR:
+ prec = P_AUTO;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
+ str_cat(str,"++");
+ numeric = 1;
+ break;
+ case OPOSTDECR:
+ prec = P_AUTO;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec+1);
+ str_cat(str,"--");
+ numeric = 1;
+ break;
+ case OPREINCR:
+ prec = P_AUTO;
+ str = str_new(0);
+ str_set(str,"++");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OPREDECR:
+ prec = P_AUTO;
+ str = str_new(0);
+ str_set(str,"--");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OUMINUS:
+ prec = P_UNARY;
+ str = str_new(0);
+ str_set(str,"-");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,prec));
+ str_free(fstr);
+ numeric = 1;
+ break;
+ case OUPLUS:
+ numeric = 1;
+ goto def;
+ case OPAREN:
+ str = str_new(0);
+ str_set(str,"(");
+ str_scat(str,
+ fstr=walk(useval != 0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,")");
+ numeric |= numarg;
+ break;
+ case OGETLINE:
+ str = str_new(0);
+ if (useval)
+ str_cat(str,"(");
+ if (len > 0) {
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ if (!*fstr->str_ptr) {
+ str_cat(str,"$_");
+ len = 2; /* a legal fiction */
+ }
+ str_free(fstr);
+ }
+ else
+ str_cat(str,"$_");
+ if (len > 1) {
+ tmpstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN);
+ fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ if (!do_fancy_opens) {
+ t = tmpstr->str_ptr;
+ if (*t == '"' || *t == '\'')
+ t = cpytill(tokenbuf,t+1,*t);
+ else
+ fatal("Internal error: OGETLINE %s", t);
+ d = savestr(t);
+ s = savestr(tokenbuf);
+ for (t = tokenbuf; *t; t++) {
+ *t &= 127;
+ if (islower(*t))
+ *t = toupper(*t);
+ if (!isalpha(*t) && !isdigit(*t))
+ *t = '_';
+ }
+ if (!strchr(tokenbuf,'_'))
+ strcpy(t,"_FH");
+ tmp3str = hfetch(symtab,tokenbuf);
+ if (!tmp3str) {
+ do_opens = TRUE;
+ str_cat(opens,"open(");
+ str_cat(opens,tokenbuf);
+ str_cat(opens,", ");
+ d[1] = '\0';
+ str_cat(opens,d);
+ str_cat(opens,tmpstr->str_ptr+1);
+ opens->str_cur--;
+ if (*fstr->str_ptr == '|')
+ str_cat(opens,"|");
+ str_cat(opens,d);
+ if (*fstr->str_ptr == '|')
+ str_cat(opens,") || die 'Cannot pipe from \"");
+ else
+ str_cat(opens,") || die 'Cannot open file \"");
+ if (*d == '"')
+ str_cat(opens,"'.\"");
+ str_cat(opens,s);
+ if (*d == '"')
+ str_cat(opens,"\".'");
+ str_cat(opens,"\".';\n");
+ hstore(symtab,tokenbuf,str_make("x"));
+ }
+ safefree(s);
+ safefree(d);
+ str_set(tmpstr,"'");
+ str_cat(tmpstr,tokenbuf);
+ str_cat(tmpstr,"'");
+ }
+ if (*fstr->str_ptr == '|')
+ str_cat(tmpstr,", '|'");
+ str_free(fstr);
+ }
+ else
+ tmpstr = str_make("");
+ sprintf(tokenbuf," = &Getline%d(%s)",len,tmpstr->str_ptr);
+ str_cat(str,tokenbuf);
+ str_free(tmpstr);
+ if (useval)
+ str_cat(str,",$getline_ok)");
+ saw_getline |= 1 << len;
+ break;
+ case OSPRINTF:
+ str = str_new(0);
+ str_set(str,"sprintf(");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,")");
+ break;
+ case OSUBSTR:
+ str = str_new(0);
+ str_set(str,"substr(");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ str_cat(str,", ");
+ if (len == 3) {
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ }
+ else
+ str_cat(str,"999999");
+ str_cat(str,")");
+ break;
+ case OSTRING:
+ str = str_new(0);
+ str_set(str,ops[node+1].cval);
+ break;
+ case OSPLIT:
+ str = str_new(0);
+ limit = ", 9999)";
+ numeric = 1;
+ tmpstr = walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ if (useval)
+ str_set(str,"(@");
+ else
+ str_set(str,"@");
+ str_scat(str,tmpstr);
+ str_cat(str," = split(");
+ if (len == 3) {
+ fstr = walk(1,level,ops[node+3].ival,&numarg,P_COMMA+1);
+ if (str_len(fstr) == 3 && *fstr->str_ptr == '\'') {
+ i = fstr->str_ptr[1] & 127;
+ if (strchr("*+?.[]()|^$\\",i))
+ sprintf(tokenbuf,"/\\%c/",i);
+ else if (i == ' ')
+ sprintf(tokenbuf,"' '");
+ else
+ sprintf(tokenbuf,"/%c/",i);
+ str_cat(str,tokenbuf);
+ }
+ else
+ str_scat(str,fstr);
+ str_free(fstr);
+ }
+ else if (const_FS) {
+ sprintf(tokenbuf,"/[%c\\n]/",const_FS);
+ str_cat(str,tokenbuf);
+ }
+ else if (saw_FS)
+ str_cat(str,"$FS");
+ else {
+ str_cat(str,"' '");
+ limit = ")";
+ }
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ str_cat(str,limit);
+ if (useval) {
+ str_cat(str,")");
+ }
+ str_free(tmpstr);
+ break;
+ case OINDEX:
+ str = str_new(0);
+ str_set(str,"index(");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_COMMA+1));
+ str_free(fstr);
+ str_cat(str,")");
+ numeric = 1;
+ break;
+ case OMATCH:
+ str = str_new(0);
+ prec = P_ANDAND;
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MATCH+1));
+ str_free(fstr);
+ str_cat(str," =~ ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MATCH+1));
+ str_free(fstr);
+ str_cat(str," && ($RLENGTH = length($&), $RSTART = length($`)+1)");
+ numeric = 1;
+ break;
+ case OUSERDEF:
+ str = str_new(0);
+ subretnum = FALSE;
+ fstr=walk(1,level-1,ops[node+2].ival,&numarg,P_MIN);
+ curargs = str_new(0);
+ str_sset(curargs,fstr);
+ str_cat(curargs,",");
+ tmp2str=walk(1,level,ops[node+5].ival,&numarg,P_MIN);
+ str_free(curargs);
+ curargs = Nullstr;
+ level--;
+ subretnum |= numarg;
+ s = Nullch;
+ t = tmp2str->str_ptr;
+ while (t = instr(t,"return "))
+ s = t++;
+ if (s) {
+ i = 0;
+ for (t = s+7; *t; t++) {
+ if (*t == ';' || *t == '}')
+ i++;
+ }
+ if (i == 1) {
+ strcpy(s,s+7);
+ tmp2str->str_cur -= 7;
+ }
+ }
+ str_set(str,"\n");
+ tab(str,level);
+ str_cat(str,"sub ");
+ str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_cat(str," {\n");
+ tab(str,++level);
+ if (fstr->str_cur) {
+ str_cat(str,"local(");
+ str_scat(str,fstr);
+ str_cat(str,") = @_;");
+ }
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ fixtab(str,level);
+ str_scat(str,fstr=walk(1,level,ops[node+4].ival,&numarg,P_MIN));
+ str_free(fstr);
+ fixtab(str,level);
+ str_scat(str,tmp2str);
+ str_free(tmp2str);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ tab(str,level);
+ str_scat(subs,str);
+ str_set(str,"");
+ str_cat(tmpstr,"(");
+ tmp2str = str_new(0);
+ if (subretnum)
+ str_set(tmp2str,"1");
+ hstore(symtab,tmpstr->str_ptr,tmp2str);
+ str_free(tmpstr);
+ level++;
+ break;
+ case ORETURN:
+ str = str_new(0);
+ if (len > 0) {
+ str_cat(str,"return ");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_UNI+1));
+ str_free(fstr);
+ if (numarg)
+ subretnum = TRUE;
+ }
+ else
+ str_cat(str,"return");
+ break;
+ case OUSERFUN:
+ str = str_new(0);
+ str_set(str,"&");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,"(");
+ tmpstr = hfetch(symtab,str->str_ptr+3);
+ if (tmpstr && tmpstr->str_ptr)
+ numeric |= atoi(tmpstr->str_ptr);
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,")");
+ break;
+ case OGSUB:
+ case OSUB:
+ if (type == OGSUB)
+ s = "g";
+ else
+ s = "";
+ str = str_new(0);
+ tmpstr = str_new(0);
+ i = 0;
+ if (len == 3) {
+ tmpstr = walk(1,level,ops[node+3].ival,&numarg,P_MATCH+1);
+ if (strNE(tmpstr->str_ptr,"$_")) {
+ str_cat(tmpstr, " =~ s");
+ i++;
+ }
+ else
+ str_set(tmpstr, "s");
+ }
+ else
+ str_set(tmpstr, "s");
+ type = ops[ops[node+2].ival].ival;
+ len = type >> 8;
+ type &= 255;
+ tmp3str = str_new(0);
+ if (type == OSTR) {
+ tmp2str=walk(1,level,ops[ops[node+2].ival+1].ival,&numarg,P_MIN);
+ for (t = tmp2str->str_ptr, d=tokenbuf; *t; d++,t++) {
+ if (*t == '&')
+ *d++ = '$' + 128;
+ else if (*t == '$')
+ *d++ = '\\' + 128;
+ *d = *t + 128;
+ }
+ *d = '\0';
+ str_set(tmp2str,tokenbuf);
+ }
+ else {
+ tmp2str=walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ str_set(tmp3str,"($s_ = '\"'.(");
+ str_scat(tmp3str,tmp2str);
+ str_cat(tmp3str,").'\"') =~ s/&/\\$&/g, ");
+ str_set(tmp2str,"eval $s_");
+ s = (*s == 'g' ? "ge" : "e");
+ i++;
+ }
+ type = ops[ops[node+1].ival].ival;
+ len = type >> 8;
+ type &= 255;
+ fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ if (type == OREGEX) {
+ if (useval && i)
+ str_cat(str,"(");
+ str_scat(str,tmp3str);
+ str_scat(str,tmpstr);
+ str_scat(str,fstr);
+ str_scat(str,tmp2str);
+ str_cat(str,"/");
+ str_cat(str,s);
+ }
+ else if ((type == OFLD && !split_to_array) || (type == OVAR && len == 1)) {
+ if (useval && i)
+ str_cat(str,"(");
+ str_scat(str,tmp3str);
+ str_scat(str,tmpstr);
+ str_cat(str,"/");
+ str_scat(str,fstr);
+ str_cat(str,"/");
+ str_scat(str,tmp2str);
+ str_cat(str,"/");
+ str_cat(str,s);
+ }
+ else {
+ i++;
+ if (useval)
+ str_cat(str,"(");
+ str_cat(str,"$s = ");
+ str_scat(str,fstr);
+ str_cat(str,", ");
+ str_scat(str,tmp3str);
+ str_scat(str,tmpstr);
+ str_cat(str,"/$s/");
+ str_scat(str,tmp2str);
+ str_cat(str,"/");
+ str_cat(str,s);
+ }
+ if (useval && i)
+ str_cat(str,")");
+ str_free(fstr);
+ str_free(tmpstr);
+ str_free(tmp2str);
+ str_free(tmp3str);
+ numeric = 1;
+ break;
+ case ONUM:
+ str = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ numeric = 1;
+ break;
+ case OSTR:
+ tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ s = "'";
+ for (t = tmpstr->str_ptr, d=tokenbuf; *t; d++,t++) {
+ if (*t == '\'')
+ s = "\"";
+ else if (*t == '\\') {
+ s = "\"";
+ *d++ = *t++ + 128;
+ switch (*t) {
+ case '\\': case '"': case 'n': case 't': case '$':
+ break;
+ default: /* hide this from perl */
+ *d++ = '\\' + 128;
+ }
+ }
+ *d = *t + 128;
+ }
+ *d = '\0';
+ str = str_new(0);
+ str_set(str,s);
+ str_cat(str,tokenbuf);
+ str_free(tmpstr);
+ str_cat(str,s);
+ break;
+ case ODEFINED:
+ prec = P_UNI;
+ str = str_new(0);
+ str_set(str,"defined $");
+ goto addvar;
+ case ODELETE:
+ str = str_new(0);
+ str_set(str,"delete $");
+ goto addvar;
+ case OSTAR:
+ str = str_new(0);
+ str_set(str,"*");
+ goto addvar;
+ case OVAR:
+ str = str_new(0);
+ str_set(str,"$");
+ addvar:
+ str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ if (len == 1) {
+ tmp2str = hfetch(symtab,tmpstr->str_ptr);
+ if (tmp2str && atoi(tmp2str->str_ptr))
+ numeric = 2;
+ if (strEQ(str->str_ptr,"$FNR")) {
+ numeric = 1;
+ saw_FNR++;
+ str_set(str,"($.-$FNRbase)");
+ }
+ else if (strEQ(str->str_ptr,"$NR")) {
+ numeric = 1;
+ str_set(str,"$.");
+ }
+ else if (strEQ(str->str_ptr,"$NF")) {
+ numeric = 1;
+ str_set(str,"$#Fld");
+ }
+ else if (strEQ(str->str_ptr,"$0"))
+ str_set(str,"$_");
+ else if (strEQ(str->str_ptr,"$ARGC"))
+ str_set(str,"($#ARGV+1)");
+ }
+ else {
+#ifdef NOTDEF
+ if (curargs) {
+ sprintf(tokenbuf,"$%s,",tmpstr->str_ptr);
+ ??? if (instr(curargs->str_ptr,tokenbuf))
+ str_cat(str,"\377"); /* can't translate yet */
+ }
+#endif
+ str_cat(tmpstr,"[]");
+ tmp2str = hfetch(symtab,tmpstr->str_ptr);
+ if (tmp2str && atoi(tmp2str->str_ptr))
+ str_cat(str,"[");
+ else
+ str_cat(str,"{");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ if (strEQ(str->str_ptr,"$ARGV[0")) {
+ str_set(str,"$ARGV0");
+ saw_argv0++;
+ }
+ else {
+ if (tmp2str && atoi(tmp2str->str_ptr))
+ strcpy(tokenbuf,"]");
+ else
+ strcpy(tokenbuf,"}");
+ *tokenbuf += 128;
+ str_cat(str,tokenbuf);
+ }
+ }
+ str_free(tmpstr);
+ break;
+ case OFLD:
+ str = str_new(0);
+ if (split_to_array) {
+ str_set(str,"$Fld");
+ str_cat(str,"[");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,"]");
+ }
+ else {
+ i = atoi(walk(1,level,ops[node+1].ival,&numarg,P_MIN)->str_ptr);
+ if (i <= arymax)
+ sprintf(tokenbuf,"$%s",nameary[i]);
+ else
+ sprintf(tokenbuf,"$Fld%d",i);
+ str_set(str,tokenbuf);
+ }
+ break;
+ case OVFLD:
+ str = str_new(0);
+ str_set(str,"$Fld[");
+ i = ops[node+1].ival;
+ if ((ops[i].ival & 255) == OPAREN)
+ i = ops[i+1].ival;
+ tmpstr=walk(1,level,i,&numarg,P_MIN);
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ str_cat(str,"]");
+ break;
+ case OJUNK:
+ goto def;
+ case OSNEWLINE:
+ str = str_new(2);
+ str_set(str,";\n");
+ tab(str,level);
+ break;
+ case ONEWLINE:
+ str = str_new(1);
+ str_set(str,"\n");
+ tab(str,level);
+ break;
+ case OSCOMMENT:
+ str = str_new(0);
+ str_set(str,";");
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ for (s = tmpstr->str_ptr; *s && *s != '\n'; s++)
+ *s += 128;
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ tab(str,level);
+ break;
+ case OCOMMENT:
+ str = str_new(0);
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ for (s = tmpstr->str_ptr; *s && *s != '\n'; s++)
+ *s += 128;
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ tab(str,level);
+ break;
+ case OCOMMA:
+ prec = P_COMMA;
+ str = walk(1,level,ops[node+1].ival,&numarg,prec);
+ str_cat(str,", ");
+ str_scat(str,fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,prec+1));
+ str_free(fstr);
+ break;
+ case OSEMICOLON:
+ str = str_new(1);
+ str_set(str,";\n");
+ tab(str,level);
+ break;
+ case OSTATES:
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ break;
+ case OSTATE:
+ str = str_new(0);
+ if (len >= 1) {
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ if (len >= 2) {
+ tmpstr = walk(0,level,ops[node+2].ival,&numarg,P_MIN);
+ if (*tmpstr->str_ptr == ';') {
+ addsemi(str);
+ str_cat(str,tmpstr->str_ptr+1);
+ }
+ str_free(tmpstr);
+ }
+ }
+ break;
+ case OCLOSE:
+ str = str_make("close(");
+ tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ if (!do_fancy_opens) {
+ t = tmpstr->str_ptr;
+ if (*t == '"' || *t == '\'')
+ t = cpytill(tokenbuf,t+1,*t);
+ else
+ fatal("Internal error: OCLOSE %s",t);
+ s = savestr(tokenbuf);
+ for (t = tokenbuf; *t; t++) {
+ *t &= 127;
+ if (islower(*t))
+ *t = toupper(*t);
+ if (!isalpha(*t) && !isdigit(*t))
+ *t = '_';
+ }
+ if (!strchr(tokenbuf,'_'))
+ strcpy(t,"_FH");
+ str_free(tmpstr);
+ safefree(s);
+ str_set(str,"close ");
+ str_cat(str,tokenbuf);
+ }
+ else {
+ sprintf(tokenbuf,"delete $opened{%s} && close(%s)",
+ tmpstr->str_ptr, tmpstr->str_ptr);
+ str_free(tmpstr);
+ str_set(str,tokenbuf);
+ }
+ break;
+ case OPRINTF:
+ case OPRINT:
+ lparen = ""; /* set to parens if necessary */
+ rparen = "";
+ str = str_new(0);
+ if (len == 3) { /* output redirection */
+ tmpstr = walk(1,level,ops[node+3].ival,&numarg,P_MIN);
+ tmp2str = walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ if (!do_fancy_opens) {
+ t = tmpstr->str_ptr;
+ if (*t == '"' || *t == '\'')
+ t = cpytill(tokenbuf,t+1,*t);
+ else
+ fatal("Internal error: OPRINT");
+ d = savestr(t);
+ s = savestr(tokenbuf);
+ for (t = tokenbuf; *t; t++) {
+ *t &= 127;
+ if (islower(*t))
+ *t = toupper(*t);
+ if (!isalpha(*t) && !isdigit(*t))
+ *t = '_';
+ }
+ if (!strchr(tokenbuf,'_'))
+ strcpy(t,"_FH");
+ tmp3str = hfetch(symtab,tokenbuf);
+ if (!tmp3str) {
+ str_cat(opens,"open(");
+ str_cat(opens,tokenbuf);
+ str_cat(opens,", ");
+ d[1] = '\0';
+ str_cat(opens,d);
+ str_scat(opens,tmp2str);
+ str_cat(opens,tmpstr->str_ptr+1);
+ if (*tmp2str->str_ptr == '|')
+ str_cat(opens,") || die 'Cannot pipe to \"");
+ else
+ str_cat(opens,") || die 'Cannot create file \"");
+ if (*d == '"')
+ str_cat(opens,"'.\"");
+ str_cat(opens,s);
+ if (*d == '"')
+ str_cat(opens,"\".'");
+ str_cat(opens,"\".';\n");
+ hstore(symtab,tokenbuf,str_make("x"));
+ }
+ str_free(tmpstr);
+ str_free(tmp2str);
+ safefree(s);
+ safefree(d);
+ }
+ else {
+ sprintf(tokenbuf,"&Pick('%s', %s) &&\n",
+ tmp2str->str_ptr, tmpstr->str_ptr);
+ str_cat(str,tokenbuf);
+ tab(str,level+1);
+ strcpy(tokenbuf,"$fh");
+ str_free(tmpstr);
+ str_free(tmp2str);
+ lparen = "(";
+ rparen = ")";
+ }
+ }
+ else
+ strcpy(tokenbuf,"");
+ str_cat(str,lparen); /* may be null */
+ if (type == OPRINTF)
+ str_cat(str,"printf");
+ else
+ str_cat(str,"print");
+ saw_fh = 0;
+ if (len == 3 || do_fancy_opens) {
+ if (*tokenbuf) {
+ str_cat(str," ");
+ saw_fh = 1;
+ }
+ str_cat(str,tokenbuf);
+ }
+ tmpstr = walk(1+(type==OPRINT),level,ops[node+1].ival,&numarg,P_MIN);
+ if (!*tmpstr->str_ptr && lval_field) {
+ t = saw_OFS ? "$," : "' '";
+ if (split_to_array) {
+ sprintf(tokenbuf,"join(%s,@Fld)",t);
+ str_cat(tmpstr,tokenbuf);
+ }
+ else {
+ for (i = 1; i < maxfld; i++) {
+ if (i <= arymax)
+ sprintf(tokenbuf,"$%s, ",nameary[i]);
+ else
+ sprintf(tokenbuf,"$Fld%d, ",i);
+ str_cat(tmpstr,tokenbuf);
+ }
+ if (maxfld <= arymax)
+ sprintf(tokenbuf,"$%s",nameary[maxfld]);
+ else
+ sprintf(tokenbuf,"$Fld%d",maxfld);
+ str_cat(tmpstr,tokenbuf);
+ }
+ }
+ if (*tmpstr->str_ptr) {
+ str_cat(str," ");
+ if (!saw_fh && *tmpstr->str_ptr == '(') {
+ str_cat(str,"(");
+ str_scat(str,tmpstr);
+ str_cat(str,")");
+ }
+ else
+ str_scat(str,tmpstr);
+ }
+ else {
+ str_cat(str," $_");
+ }
+ str_cat(str,rparen); /* may be null */
+ str_free(tmpstr);
+ break;
+ case ORAND:
+ str = str_make("rand(1)");
+ break;
+ case OSRAND:
+ str = str_make("srand(");
+ goto maybe0;
+ case OATAN2:
+ str = str_make("atan2(");
+ goto maybe0;
+ case OSIN:
+ str = str_make("sin(");
+ goto maybe0;
+ case OCOS:
+ str = str_make("cos(");
+ goto maybe0;
+ case OSYSTEM:
+ str = str_make("system(");
+ goto maybe0;
+ case OLENGTH:
+ str = str_make("length(");
+ goto maybe0;
+ case OLOG:
+ str = str_make("log(");
+ goto maybe0;
+ case OEXP:
+ str = str_make("exp(");
+ goto maybe0;
+ case OSQRT:
+ str = str_make("sqrt(");
+ goto maybe0;
+ case OINT:
+ str = str_make("int(");
+ maybe0:
+ numeric = 1;
+ if (len > 0)
+ tmpstr = walk(1,level,ops[node+1].ival,&numarg,P_MIN);
+ else
+ tmpstr = str_new(0);;
+ if (!tmpstr->str_ptr || !*tmpstr->str_ptr) {
+ if (lval_field) {
+ t = saw_OFS ? "$," : "' '";
+ if (split_to_array) {
+ sprintf(tokenbuf,"join(%s,@Fld)",t);
+ str_cat(tmpstr,tokenbuf);
+ }
+ else {
+ sprintf(tokenbuf,"join(%s, ",t);
+ str_cat(tmpstr,tokenbuf);
+ for (i = 1; i < maxfld; i++) {
+ if (i <= arymax)
+ sprintf(tokenbuf,"$%s,",nameary[i]);
+ else
+ sprintf(tokenbuf,"$Fld%d,",i);
+ str_cat(tmpstr,tokenbuf);
+ }
+ if (maxfld <= arymax)
+ sprintf(tokenbuf,"$%s)",nameary[maxfld]);
+ else
+ sprintf(tokenbuf,"$Fld%d)",maxfld);
+ str_cat(tmpstr,tokenbuf);
+ }
+ }
+ else
+ str_cat(tmpstr,"$_");
+ }
+ if (strEQ(tmpstr->str_ptr,"$_")) {
+ if (type == OLENGTH && !do_chop) {
+ str = str_make("(length(");
+ str_cat(tmpstr,") - 1");
+ }
+ }
+ str_scat(str,tmpstr);
+ str_free(tmpstr);
+ str_cat(str,")");
+ break;
+ case OBREAK:
+ str = str_new(0);
+ str_set(str,"last");
+ break;
+ case ONEXT:
+ str = str_new(0);
+ str_set(str,"next line");
+ break;
+ case OEXIT:
+ str = str_new(0);
+ if (realexit) {
+ prec = P_UNI;
+ str_set(str,"exit");
+ if (len == 1) {
+ str_cat(str," ");
+ exitval = TRUE;
+ str_scat(str,
+ fstr=walk(1,level,ops[node+1].ival,&numarg,prec+1));
+ str_free(fstr);
+ }
+ }
+ else {
+ if (len == 1) {
+ str_set(str,"$ExitValue = ");
+ exitval = TRUE;
+ str_scat(str,
+ fstr=walk(1,level,ops[node+1].ival,&numarg,P_ASSIGN));
+ str_free(fstr);
+ str_cat(str,"; ");
+ }
+ str_cat(str,"last line");
+ }
+ break;
+ case OCONTINUE:
+ str = str_new(0);
+ str_set(str,"next");
+ break;
+ case OREDIR:
+ goto def;
+ case OIF:
+ str = str_new(0);
+ str_set(str,"if (");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,") ");
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ if (len == 3) {
+ i = ops[node+3].ival;
+ if (i) {
+ if ((ops[i].ival & 255) == OBLOCK) {
+ i = ops[i+1].ival;
+ if (i) {
+ if ((ops[i].ival & 255) != OIF)
+ i = 0;
+ }
+ }
+ else
+ i = 0;
+ }
+ if (i) {
+ str_cat(str,"els");
+ str_scat(str,fstr=walk(0,level,i,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ else {
+ str_cat(str,"else ");
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ }
+ break;
+ case OWHILE:
+ str = str_new(0);
+ str_set(str,"while (");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,") ");
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ break;
+ case ODO:
+ str = str_new(0);
+ str_set(str,"do ");
+ str_scat(str,fstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ if (str->str_ptr[str->str_cur - 1] == '\n')
+ --str->str_cur;;
+ str_cat(str," while (");
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,");");
+ break;
+ case OFOR:
+ str = str_new(0);
+ str_set(str,"for (");
+ str_scat(str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ i = numarg;
+ if (i) {
+ t = s = tmpstr->str_ptr;
+ while (isalpha(*t) || isdigit(*t) || *t == '$' || *t == '_')
+ t++;
+ i = t - s;
+ if (i < 2)
+ i = 0;
+ }
+ str_cat(str,"; ");
+ fstr=walk(1,level,ops[node+2].ival,&numarg,P_MIN);
+ if (i && (t = strchr(fstr->str_ptr,0377))) {
+ if (strnEQ(fstr->str_ptr,s,i))
+ *t = ' ';
+ }
+ str_scat(str,fstr);
+ str_free(fstr);
+ str_free(tmpstr);
+ str_cat(str,"; ");
+ str_scat(str,fstr=walk(1,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_cat(str,") ");
+ str_scat(str,fstr=walk(0,level,ops[node+4].ival,&numarg,P_MIN));
+ str_free(fstr);
+ break;
+ case OFORIN:
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ d = strchr(tmpstr->str_ptr,'$');
+ if (!d)
+ fatal("Illegal for loop: %s",tmpstr->str_ptr);
+ s = strchr(d,'{');
+ if (!s)
+ s = strchr(d,'[');
+ if (!s)
+ fatal("Illegal for loop: %s",d);
+ *s++ = '\0';
+ for (t = s; i = *t; t++) {
+ i &= 127;
+ if (i == '}' || i == ']')
+ break;
+ }
+ if (*t)
+ *t = '\0';
+ str = str_new(0);
+ str_set(str,d+1);
+ str_cat(str,"[]");
+ tmp2str = hfetch(symtab,str->str_ptr);
+ if (tmp2str && atoi(tmp2str->str_ptr)) {
+ sprintf(tokenbuf,
+ "foreach %s ($[ .. $#%s) ",
+ s,
+ d+1);
+ }
+ else {
+ sprintf(tokenbuf,
+ "foreach %s (keys %%%s) ",
+ s,
+ d+1);
+ }
+ str_set(str,tokenbuf);
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ str_free(tmpstr);
+ break;
+ case OBLOCK:
+ str = str_new(0);
+ str_set(str,"{");
+ if (len >= 2 && ops[node+2].ival) {
+ str_scat(str,fstr=walk(0,level,ops[node+2].ival,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ fixtab(str,++level);
+ str_scat(str,fstr=walk(0,level,ops[node+1].ival,&numarg,P_MIN));
+ str_free(fstr);
+ addsemi(str);
+ fixtab(str,--level);
+ str_cat(str,"}\n");
+ tab(str,level);
+ if (len >= 3) {
+ str_scat(str,fstr=walk(0,level,ops[node+3].ival,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ break;
+ default:
+ def:
+ if (len) {
+ if (len > 5)
+ fatal("Garbage length in walk");
+ str = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ for (i = 2; i<= len; i++) {
+ str_scat(str,fstr=walk(0,level,ops[node+i].ival,&numarg,P_MIN));
+ str_free(fstr);
+ }
+ }
+ else {
+ str = Nullstr;
+ }
+ break;
+ }
+ if (!str)
+ str = str_new(0);
+
+ if (useval && prec < minprec) { /* need parens? */
+ fstr = str_new(str->str_cur+2);
+ str_nset(fstr,"(",1);
+ str_scat(fstr,str);
+ str_ncat(fstr,")",1);
+ str_free(str);
+ str = fstr;
+ }
+
+ *numericptr = numeric;
+#ifdef DEBUGGING
+ if (debug & 4) {
+ printf("%3d %5d %15s %d %4d ",level,node,opname[type],len,str->str_cur);
+ for (t = str->str_ptr; *t && t - str->str_ptr < 40; t++)
+ if (*t == '\n')
+ printf("\\n");
+ else if (*t == '\t')
+ printf("\\t");
+ else
+ putchar(*t);
+ putchar('\n');
+ }
+#endif
+ return str;
+}
+
+static void
+tab(register STR *str, register int lvl)
+{
+ while (lvl > 1) {
+ str_cat(str,"\t");
+ lvl -= 2;
+ }
+ if (lvl)
+ str_cat(str," ");
+}
+
+static void
+fixtab(register STR *str, register int lvl)
+{
+ register char *s;
+
+ /* strip trailing white space */
+
+ s = str->str_ptr+str->str_cur - 1;
+ while (s >= str->str_ptr && (*s == ' ' || *s == '\t' || *s == '\n'))
+ s--;
+ s[1] = '\0';
+ str->str_cur = s + 1 - str->str_ptr;
+ if (s >= str->str_ptr && *s != '\n')
+ str_cat(str,"\n");
+
+ tab(str,lvl);
+}
+
+static void
+addsemi(register STR *str)
+{
+ register char *s;
+
+ s = str->str_ptr+str->str_cur - 1;
+ while (s >= str->str_ptr && (*s == ' ' || *s == '\t' || *s == '\n'))
+ s--;
+ if (s >= str->str_ptr && *s != ';' && *s != '}')
+ str_cat(str,";");
+}
+
+static void
+emit_split(register STR *str, int level)
+{
+ register int i;
+
+ if (split_to_array)
+ str_cat(str,"@Fld");
+ else {
+ str_cat(str,"(");
+ for (i = 1; i < maxfld; i++) {
+ if (i <= arymax)
+ sprintf(tokenbuf,"$%s,",nameary[i]);
+ else
+ sprintf(tokenbuf,"$Fld%d,",i);
+ str_cat(str,tokenbuf);
+ }
+ if (maxfld <= arymax)
+ sprintf(tokenbuf,"$%s)",nameary[maxfld]);
+ else
+ sprintf(tokenbuf,"$Fld%d)",maxfld);
+ str_cat(str,tokenbuf);
+ }
+ if (const_FS) {
+ sprintf(tokenbuf," = split(/[%c\\n]/, $_, 9999);\n",const_FS);
+ str_cat(str,tokenbuf);
+ }
+ else if (saw_FS)
+ str_cat(str," = split($FS, $_, 9999);\n");
+ else
+ str_cat(str," = split(' ', $_, 9999);\n");
+ tab(str,level);
+}
+
+int
+prewalk(int numit, int level, register int node, int *numericptr)
+{
+ register int len;
+ register int type;
+ register int i;
+ int numarg;
+ int numeric = FALSE;
+ STR *tmpstr;
+ STR *tmp2str;
+
+ if (!node) {
+ *numericptr = 0;
+ return 0;
+ }
+ type = ops[node].ival;
+ len = type >> 8;
+ type &= 255;
+ switch (type) {
+ case OPROG:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ if (ops[node+2].ival) {
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ ++level;
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ --level;
+ if (ops[node+3].ival) {
+ prewalk(0,level,ops[node+4].ival,&numarg);
+ }
+ break;
+ case OHUNKS:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ if (len == 3) {
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ }
+ break;
+ case ORANGE:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ break;
+ case OPAT:
+ goto def;
+ case OREGEX:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OHUNK:
+ if (len == 1) {
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ }
+ else {
+ i = prewalk(0,level,ops[node+1].ival,&numarg);
+ if (i) {
+ ++level;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ --level;
+ }
+ else {
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ }
+ break;
+ case OPPAREN:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OPANDAND:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OPOROR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OPNOT:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OCPAREN:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric |= numarg;
+ break;
+ case OCANDAND:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OCOROR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OCNOT:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case ORELOP:
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ numeric |= numarg;
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ numeric |= numarg;
+ numeric = 1;
+ break;
+ case ORPAREN:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric |= numarg;
+ break;
+ case OMATCHOP:
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ numeric = 1;
+ break;
+ case OMPAREN:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric |= numarg;
+ break;
+ case OCONCAT:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OASSIGN:
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ if (numarg || strlen(ops[ops[node+1].ival+1].cval) > (Size_t)1) {
+ numericize(ops[node+2].ival);
+ if (!numarg)
+ numericize(ops[node+3].ival);
+ }
+ numeric |= numarg;
+ break;
+ case OADD:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OSUBTRACT:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OMULT:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case ODIV:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPOW:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OMOD:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPOSTINCR:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPOSTDECR:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPREINCR:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPREDECR:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OUMINUS:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OUPLUS:
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OPAREN:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric |= numarg;
+ break;
+ case OGETLINE:
+ break;
+ case OSPRINTF:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OSUBSTR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(1,level,ops[node+2].ival,&numarg);
+ if (len == 3) {
+ prewalk(1,level,ops[node+3].ival,&numarg);
+ }
+ break;
+ case OSTRING:
+ break;
+ case OSPLIT:
+ numeric = 1;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ if (len == 3)
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OINDEX:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OMATCH:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ numeric = 1;
+ break;
+ case OUSERDEF:
+ subretnum = FALSE;
+ --level;
+ tmpstr = walk(0,level,ops[node+1].ival,&numarg,P_MIN);
+ ++level;
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+4].ival,&numarg);
+ prewalk(0,level,ops[node+5].ival,&numarg);
+ --level;
+ str_cat(tmpstr,"(");
+ tmp2str = str_new(0);
+ if (subretnum || numarg)
+ str_set(tmp2str,"1");
+ hstore(symtab,tmpstr->str_ptr,tmp2str);
+ str_free(tmpstr);
+ level++;
+ break;
+ case ORETURN:
+ if (len > 0) {
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ if (numarg)
+ subretnum = TRUE;
+ }
+ break;
+ case OUSERFUN:
+ tmp2str = str_new(0);
+ str_scat(tmp2str,tmpstr=walk(1,level,ops[node+1].ival,&numarg,P_MIN));
+ fixrargs(tmpstr->str_ptr,ops[node+2].ival,0);
+ str_free(tmpstr);
+ str_cat(tmp2str,"(");
+ tmpstr = hfetch(symtab,tmp2str->str_ptr);
+ if (tmpstr && tmpstr->str_ptr)
+ numeric |= atoi(tmpstr->str_ptr);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ str_free(tmp2str);
+ break;
+ case OGSUB:
+ case OSUB:
+ if (len >= 3)
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ prewalk(0,level,ops[ops[node+2].ival+1].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case ONUM:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ numeric = 1;
+ break;
+ case OSTR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case ODEFINED:
+ case ODELETE:
+ case OSTAR:
+ case OVAR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ if (len == 1) {
+ if (numit)
+ numericize(node);
+ }
+ else {
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ break;
+ case OFLD:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OVFLD:
+ i = ops[node+1].ival;
+ prewalk(0,level,i,&numarg);
+ break;
+ case OJUNK:
+ goto def;
+ case OSNEWLINE:
+ break;
+ case ONEWLINE:
+ break;
+ case OSCOMMENT:
+ break;
+ case OCOMMENT:
+ break;
+ case OCOMMA:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ break;
+ case OSEMICOLON:
+ break;
+ case OSTATES:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OSTATE:
+ if (len >= 1) {
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ if (len >= 2) {
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ }
+ break;
+ case OCLOSE:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OPRINTF:
+ case OPRINT:
+ if (len == 3) { /* output redirection */
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ prewalk(0+(type==OPRINT),level,ops[node+1].ival,&numarg);
+ break;
+ case ORAND:
+ break;
+ case OSRAND:
+ goto maybe0;
+ case OATAN2:
+ goto maybe0;
+ case OSIN:
+ goto maybe0;
+ case OCOS:
+ goto maybe0;
+ case OSYSTEM:
+ goto maybe0;
+ case OLENGTH:
+ goto maybe0;
+ case OLOG:
+ goto maybe0;
+ case OEXP:
+ goto maybe0;
+ case OSQRT:
+ goto maybe0;
+ case OINT:
+ maybe0:
+ numeric = 1;
+ if (len > 0)
+ prewalk(type != OLENGTH && type != OSYSTEM,
+ level,ops[node+1].ival,&numarg);
+ break;
+ case OBREAK:
+ break;
+ case ONEXT:
+ break;
+ case OEXIT:
+ if (len == 1) {
+ prewalk(1,level,ops[node+1].ival,&numarg);
+ }
+ break;
+ case OCONTINUE:
+ break;
+ case OREDIR:
+ goto def;
+ case OIF:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ if (len == 3) {
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ }
+ break;
+ case OWHILE:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ break;
+ case OFOR:
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+3].ival,&numarg);
+ prewalk(0,level,ops[node+4].ival,&numarg);
+ break;
+ case OFORIN:
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ break;
+ case OBLOCK:
+ if (len == 2) {
+ prewalk(0,level,ops[node+2].ival,&numarg);
+ }
+ ++level;
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ --level;
+ break;
+ default:
+ def:
+ if (len) {
+ if (len > 5)
+ fatal("Garbage length in prewalk");
+ prewalk(0,level,ops[node+1].ival,&numarg);
+ for (i = 2; i<= len; i++) {
+ prewalk(0,level,ops[node+i].ival,&numarg);
+ }
+ }
+ break;
+ }
+ *numericptr = numeric;
+ return 1;
+}
+
+static void
+numericize(register int node)
+{
+ register int len;
+ register int type;
+ STR *tmpstr;
+ STR *tmp2str;
+ int numarg;
+
+ type = ops[node].ival;
+ len = type >> 8;
+ type &= 255;
+ if (type == OVAR && len == 1) {
+ tmpstr=walk(0,0,ops[node+1].ival,&numarg,P_MIN);
+ tmp2str = str_make("1");
+ hstore(symtab,tmpstr->str_ptr,tmp2str);
+ }
+}